diff --git a/assemble/Adapt_Integration.F90 b/assemble/Adapt_Integration.F90 index 562a308929..1c3a2916c3 100644 --- a/assemble/Adapt_Integration.F90 +++ b/assemble/Adapt_Integration.F90 @@ -29,50 +29,50 @@ module adapt_integration - use fldebug - use futils, only: present_and_true - use data_structures - use quadrature - use elements - use spud - use parallel_tools - use fields - use vtk_interfaces - use halos - use meshdiagnostics - use limit_metric_module - use node_locking - use surface_id_interleaving - use tictoc - - implicit none - - private - - public :: adapt_mesh, max_nodes, adapt_integration_check_options, element_quality_pain_p0, mtetin - - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + use fldebug + use futils, only: present_and_true + use data_structures + use quadrature + use elements + use spud + use parallel_tools + use fields + use vtk_interfaces + use halos + use meshdiagnostics + use limit_metric_module + use node_locking + use surface_id_interleaving + use tictoc + + implicit none + + private + + public :: adapt_mesh, max_nodes, adapt_integration_check_options, element_quality_pain_p0, mtetin + + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" #ifdef HAVE_ADAPTIVITY - interface - subroutine adaptmem(nnod, nelm, szenls, nselm, totfre, & + interface + subroutine adaptmem(nnod, nelm, szenls, nselm, totfre, & & xpctel, xpctnd, xpctse, & & metric, szint, szrl) - implicit none - integer, intent(in) :: nnod - integer, intent(in) :: nelm - integer, intent(in) :: szenls - integer, intent(in) :: nselm - integer, intent(in) :: totfre - integer, intent(in) :: xpctel - integer, intent(in) :: xpctnd - integer, intent(in) :: xpctse - logical, intent(in) :: metric - integer, intent(out) :: szint - integer, intent(out) :: szrl - end subroutine adaptmem - - subroutine adptvy(intarr, intsiz, rlarr, rlsiz, & + implicit none + integer, intent(in) :: nnod + integer, intent(in) :: nelm + integer, intent(in) :: szenls + integer, intent(in) :: nselm + integer, intent(in) :: totfre + integer, intent(in) :: xpctel + integer, intent(in) :: xpctnd + integer, intent(in) :: xpctse + logical, intent(in) :: metric + integer, intent(out) :: szint + integer, intent(out) :: szrl + end subroutine adaptmem + + subroutine adptvy(intarr, intsiz, rlarr, rlsiz, & & geom3d, srfgmy, useq, & & nnod, nelm, nselm, absolutemxnods, & & szenls, enlbas, enlist, elmreg, & @@ -91,428 +91,428 @@ subroutine adptvy(intarr, intsiz, rlarr, rlsiz, & & dotop, minchg, nsweep, mshopt, twostg, togthr, & & gather, scater, ngath, nhalo, pnod, & & atosen, atorec, nproc, debug_level, dbg, chcnsy) - implicit none - integer, intent(in) :: intsiz - integer, dimension(intsiz), intent(out) :: intarr - integer, intent(in) :: rlsiz - real, dimension(rlsiz), intent(out) :: rlarr - logical, intent(in) :: geom3d - logical, intent(in) :: srfgmy - logical, intent(in) :: useq - integer, intent(in) :: nnod - integer, intent(in) :: nelm - integer, intent(in) :: nselm - integer, intent(in) :: absolutemxnods - integer, intent(in) :: szenls - integer, dimension(nelm + 1), intent(in) :: enlbas - integer, dimension(nelm * 4), intent(in) :: enlist - integer, dimension(nelm), intent(in) :: elmreg - logical, intent(in) :: clcgmy - integer, intent(in) :: szsnls - integer, dimension(nselm + 1), intent(in) :: snlbas - integer, dimension(nselm * 3), intent(in) :: snlist - integer, dimension(nselm), intent(in) :: surfid - integer, intent(in) :: nprdnd - integer, dimension(nprdnd), intent(in) :: prdnds - real, dimension(nnod), intent(in) :: nodx - real, dimension(nnod), intent(in) :: nody - real, dimension(nnod), intent(in) :: nodz - integer, intent(in) :: intnnd - integer, intent(in) :: intnel - integer, intent(in) :: intszl - integer, dimension(intnel * 4), intent(in) :: intenl - integer, dimension(intnel + 1), intent(in) :: intenb - real, dimension(intnnd), intent(in) :: intndx - real, dimension(intnnd), intent(in) :: intndy - real, dimension(intnnd), intent(in) :: intndz - real, dimension(nnod * 9), intent(in) :: orgmtx - real, dimension(nfield * nnod), intent(in) :: oldfld - integer, intent(in) :: nfield - integer, intent(in) :: xpctel - integer, dimension(nfield), intent(in) :: nfree - integer, intent(in) :: totfre - integer, intent(out) :: nwnnod - integer, intent(out) :: nwnelm - integer, intent(out) :: nwnsel - integer, intent(out) :: nwszen - integer, intent(out) :: nwszsn - integer, intent(out) :: nwsznn - integer, intent(inout) :: nwndlc - integer, intent(inout) :: nwsrow - integer, intent(out) :: nwenlb - integer, intent(out) :: nwenls - integer, intent(out) :: nwsnlb - integer, intent(out) :: nwsnls - integer, intent(out) :: nwsfid - integer, intent(out) :: nwelrg - integer, intent(out) :: nwnodx - integer, intent(out) :: nwnody - integer, intent(out) :: nwnodz - integer, intent(inout) :: newmtx - integer, intent(out) :: newfld - integer, intent(out) :: biglst - integer, intent(out) :: nodlst - real, intent(in) :: dotop - real, intent(in) :: minchg - integer, intent(in) :: nsweep - logical, dimension(6), intent(in) :: mshopt - logical, intent(in) :: twostg - logical, intent(in) :: togthr - integer, intent(in) :: ngath - integer, dimension(ngath), intent(inout) :: gather - integer, intent(in) :: nhalo - integer, dimension(nhalo), intent(inout) :: scater - integer, intent(inout) :: pnod - integer, intent(in) :: nproc - integer, dimension(nproc + 1), intent(in) :: atosen - integer, dimension(nproc + 1), intent(in) :: atorec - integer, intent(in) :: debug_level - logical, intent(in) :: dbg - logical, intent(in) :: chcnsy - end subroutine adptvy - - subroutine mtetin(x, y, z, m, vol, areas, l, radius, qualty) - implicit none - real, dimension(4), intent(in) :: x - real, dimension(4), intent(in) :: y - real, dimension(4), intent(in) :: z - real, dimension(3, 3), intent(in) :: m - real, intent(out) :: vol - real, dimension(4), intent(out) :: areas - real, dimension(6), intent(out) :: l - real, intent(out) :: radius - real, intent(out) :: qualty - end subroutine mtetin - end interface + implicit none + integer, intent(in) :: intsiz + integer, dimension(intsiz), intent(out) :: intarr + integer, intent(in) :: rlsiz + real, dimension(rlsiz), intent(out) :: rlarr + logical, intent(in) :: geom3d + logical, intent(in) :: srfgmy + logical, intent(in) :: useq + integer, intent(in) :: nnod + integer, intent(in) :: nelm + integer, intent(in) :: nselm + integer, intent(in) :: absolutemxnods + integer, intent(in) :: szenls + integer, dimension(nelm + 1), intent(in) :: enlbas + integer, dimension(nelm * 4), intent(in) :: enlist + integer, dimension(nelm), intent(in) :: elmreg + logical, intent(in) :: clcgmy + integer, intent(in) :: szsnls + integer, dimension(nselm + 1), intent(in) :: snlbas + integer, dimension(nselm * 3), intent(in) :: snlist + integer, dimension(nselm), intent(in) :: surfid + integer, intent(in) :: nprdnd + integer, dimension(nprdnd), intent(in) :: prdnds + real, dimension(nnod), intent(in) :: nodx + real, dimension(nnod), intent(in) :: nody + real, dimension(nnod), intent(in) :: nodz + integer, intent(in) :: intnnd + integer, intent(in) :: intnel + integer, intent(in) :: intszl + integer, dimension(intnel * 4), intent(in) :: intenl + integer, dimension(intnel + 1), intent(in) :: intenb + real, dimension(intnnd), intent(in) :: intndx + real, dimension(intnnd), intent(in) :: intndy + real, dimension(intnnd), intent(in) :: intndz + real, dimension(nnod * 9), intent(in) :: orgmtx + real, dimension(nfield * nnod), intent(in) :: oldfld + integer, intent(in) :: nfield + integer, intent(in) :: xpctel + integer, dimension(nfield), intent(in) :: nfree + integer, intent(in) :: totfre + integer, intent(out) :: nwnnod + integer, intent(out) :: nwnelm + integer, intent(out) :: nwnsel + integer, intent(out) :: nwszen + integer, intent(out) :: nwszsn + integer, intent(out) :: nwsznn + integer, intent(inout) :: nwndlc + integer, intent(inout) :: nwsrow + integer, intent(out) :: nwenlb + integer, intent(out) :: nwenls + integer, intent(out) :: nwsnlb + integer, intent(out) :: nwsnls + integer, intent(out) :: nwsfid + integer, intent(out) :: nwelrg + integer, intent(out) :: nwnodx + integer, intent(out) :: nwnody + integer, intent(out) :: nwnodz + integer, intent(inout) :: newmtx + integer, intent(out) :: newfld + integer, intent(out) :: biglst + integer, intent(out) :: nodlst + real, intent(in) :: dotop + real, intent(in) :: minchg + integer, intent(in) :: nsweep + logical, dimension(6), intent(in) :: mshopt + logical, intent(in) :: twostg + logical, intent(in) :: togthr + integer, intent(in) :: ngath + integer, dimension(ngath), intent(inout) :: gather + integer, intent(in) :: nhalo + integer, dimension(nhalo), intent(inout) :: scater + integer, intent(inout) :: pnod + integer, intent(in) :: nproc + integer, dimension(nproc + 1), intent(in) :: atosen + integer, dimension(nproc + 1), intent(in) :: atorec + integer, intent(in) :: debug_level + logical, intent(in) :: dbg + logical, intent(in) :: chcnsy + end subroutine adptvy + + subroutine mtetin(x, y, z, m, vol, areas, l, radius, qualty) + implicit none + real, dimension(4), intent(in) :: x + real, dimension(4), intent(in) :: y + real, dimension(4), intent(in) :: z + real, dimension(3, 3), intent(in) :: m + real, intent(out) :: vol + real, dimension(4), intent(out) :: areas + real, dimension(6), intent(out) :: l + real, intent(out) :: radius + real, intent(out) :: qualty + end subroutine mtetin + end interface #endif contains - subroutine adapt_mesh(input_positions, metric, output_positions, node_ownership, & - & force_preserve_regions, lock_faces) - !!< Adapt the supplied input mesh using libadaptivity. Return the new - !!< adapted mesh in output_positions (which is allocated by this routine). - - type(vector_field), intent(in) :: input_positions - type(tensor_field), intent(in) :: metric - type(vector_field), target, intent(out) :: output_positions - !! Map from new nodes to old elements. Allocated by this routine. - integer, dimension(:), pointer, optional :: node_ownership - logical, intent(in), optional :: force_preserve_regions - type(integer_set), intent(in), optional :: lock_faces - - ! Linear tets only - integer, parameter :: dim = 3, nloc = 4, snloc = 3 - - ! adaptmem arguments - integer :: nnod, nelm, szenls, nselm, totfre, xpctel, xpctnd, xpctse - logical :: have_metric - - ! adptvy arguments - ! Working memory - integer, dimension(:), allocatable :: intarr - integer :: intsiz - real, dimension(:), allocatable :: rlarr - integer :: rlsiz - ! Input variables - logical :: geom3d, srfgmy, useq - integer :: absolutemxnods - integer, dimension(:), allocatable, target :: enlbas - integer, dimension(:), pointer :: enlist - integer, dimension(:), allocatable :: elmreg - logical :: clcgmy - integer :: szsnls - integer, dimension(:), allocatable :: snlbas, snlist, surfid, prdnds - integer :: nprdnd - real, dimension(:), pointer :: nodx, nody, nodz - integer :: intnnd, intnel, intszl - integer, dimension(:), pointer :: intenl, intenb - real, dimension(:), pointer :: intndx, intndy, intndz - real, dimension(:), allocatable :: orgmtx - real, dimension(:), allocatable :: oldfld - integer, dimension(:), allocatable :: nfree - integer :: nfield - ! Output variables - integer :: nwnnod, nwnelm, nwnsel, nwszen, nwszsn, nwsznn, & + subroutine adapt_mesh(input_positions, metric, output_positions, node_ownership, & + & force_preserve_regions, lock_faces) + !!< Adapt the supplied input mesh using libadaptivity. Return the new + !!< adapted mesh in output_positions (which is allocated by this routine). + + type(vector_field), intent(in) :: input_positions + type(tensor_field), intent(in) :: metric + type(vector_field), target, intent(out) :: output_positions + !! Map from new nodes to old elements. Allocated by this routine. + integer, dimension(:), pointer, optional :: node_ownership + logical, intent(in), optional :: force_preserve_regions + type(integer_set), intent(in), optional :: lock_faces + + ! Linear tets only + integer, parameter :: dim = 3, nloc = 4, snloc = 3 + + ! adaptmem arguments + integer :: nnod, nelm, szenls, nselm, totfre, xpctel, xpctnd, xpctse + logical :: have_metric + + ! adptvy arguments + ! Working memory + integer, dimension(:), allocatable :: intarr + integer :: intsiz + real, dimension(:), allocatable :: rlarr + integer :: rlsiz + ! Input variables + logical :: geom3d, srfgmy, useq + integer :: absolutemxnods + integer, dimension(:), allocatable, target :: enlbas + integer, dimension(:), pointer :: enlist + integer, dimension(:), allocatable :: elmreg + logical :: clcgmy + integer :: szsnls + integer, dimension(:), allocatable :: snlbas, snlist, surfid, prdnds + integer :: nprdnd + real, dimension(:), pointer :: nodx, nody, nodz + integer :: intnnd, intnel, intszl + integer, dimension(:), pointer :: intenl, intenb + real, dimension(:), pointer :: intndx, intndy, intndz + real, dimension(:), allocatable :: orgmtx + real, dimension(:), allocatable :: oldfld + integer, dimension(:), allocatable :: nfree + integer :: nfield + ! Output variables + integer :: nwnnod, nwnelm, nwnsel, nwszen, nwszsn, nwsznn, & & nwndlc, nwsrow, nwenlb, nwenls, nwsnlb, nwsnls, nwsfid, nwelrg, & & nwnodx, nwnody, nwnodz, newmtx, newfld, biglst, nodlst - ! More input variables - real :: dotop, minchg - integer :: nsweep - logical, dimension(6) :: mshopt - logical :: twostg - logical :: togthr - integer, dimension(:), allocatable :: gather, scater - integer :: ngath, nhalo, pnod - integer, dimension(:), allocatable :: atosen, atorec - integer :: nproc, debug_level - logical :: dbg, chcnsy - - integer :: i, max_coplanar_id, nhalos - integer, dimension(:), allocatable :: boundary_ids, coplanar_ids - real :: mestp1 - type(halo_type), pointer :: old_halo - type(mesh_type), pointer :: output_mesh - - integer, save :: output_quality_index = 0 - logical :: output_quality - type(scalar_field) :: quality - type(tensor_field) :: new_metric - - ! Buffer factor to emulate behaviour of legacy expected elements function - real, parameter :: expected_elements_buffer = 1.2 - ! Buffer factor for max. nodes - real, parameter :: mxnods_buffer = 1.5 - - ! if we're parallel we'll need to reorder the region ids after the halo derivation - integer, dimension(:), allocatable :: old_new_region_ids, renumber_permutation - - ewrite(1, *) "In adapt_mesh" + ! More input variables + real :: dotop, minchg + integer :: nsweep + logical, dimension(6) :: mshopt + logical :: twostg + logical :: togthr + integer, dimension(:), allocatable :: gather, scater + integer :: ngath, nhalo, pnod + integer, dimension(:), allocatable :: atosen, atorec + integer :: nproc, debug_level + logical :: dbg, chcnsy + + integer :: i, max_coplanar_id, nhalos + integer, dimension(:), allocatable :: boundary_ids, coplanar_ids + real :: mestp1 + type(halo_type), pointer :: old_halo + type(mesh_type), pointer :: output_mesh + + integer, save :: output_quality_index = 0 + logical :: output_quality + type(scalar_field) :: quality + type(tensor_field) :: new_metric + + ! Buffer factor to emulate behaviour of legacy expected elements function + real, parameter :: expected_elements_buffer = 1.2 + ! Buffer factor for max. nodes + real, parameter :: mxnods_buffer = 1.5 + + ! if we're parallel we'll need to reorder the region ids after the halo derivation + integer, dimension(:), allocatable :: old_new_region_ids, renumber_permutation + + ewrite(1, *) "In adapt_mesh" #ifdef DDEBUG - assert(input_positions%dim == dim) - assert(ele_loc(input_positions, 1) == nloc) - if(surface_element_count(input_positions) > 0) then - assert(associated(input_positions%mesh%faces)) - assert(face_loc(input_positions, 1) == snloc) - end if - assert(metric%mesh == input_positions%mesh) + assert(input_positions%dim == dim) + assert(ele_loc(input_positions, 1) == nloc) + if(surface_element_count(input_positions) > 0) then + assert(associated(input_positions%mesh%faces)) + assert(face_loc(input_positions, 1) == snloc) + end if + assert(metric%mesh == input_positions%mesh) #endif - ewrite(2, *) "Forming adaptmem arguments" + ewrite(2, *) "Forming adaptmem arguments" - nnod = node_count(input_positions) ! Number of nodes - nelm = element_count(input_positions) ! Number of volume elements - szenls = nloc * nelm ! Size of the volume element list - nselm = surface_element_count(input_positions) ! Number of surface elements - totfre = 0 ! Number of fields - xpctel = expected_elements(input_positions, metric) * expected_elements_buffer ! Expected number of volume elements - xpctnd = -1 ! Expected number of nodes - xpctse = -1 ! Expected number of surface elements - have_metric = .true. ! Unknown + nnod = node_count(input_positions) ! Number of nodes + nelm = element_count(input_positions) ! Number of volume elements + szenls = nloc * nelm ! Size of the volume element list + nselm = surface_element_count(input_positions) ! Number of surface elements + totfre = 0 ! Number of fields + xpctel = expected_elements(input_positions, metric) * expected_elements_buffer ! Expected number of volume elements + xpctnd = -1 ! Expected number of nodes + xpctse = -1 ! Expected number of surface elements + have_metric = .true. ! Unknown - ! Initialise output variables, just in case they're also used as input - intsiz = 0 ! Integer working memory size - rlsiz = 0 ! Real working memory size + ! Initialise output variables, just in case they're also used as input + intsiz = 0 ! Integer working memory size + rlsiz = 0 ! Real working memory size - ewrite(1, *) "Calling adaptmem from adapt_mesh" + ewrite(1, *) "Calling adaptmem from adapt_mesh" #ifdef HAVE_ADAPTIVITY - call adaptmem(nnod, nelm, szenls, nselm, totfre, & + call adaptmem(nnod, nelm, szenls, nselm, totfre, & & xpctel, xpctnd, xpctse, & & have_metric, intsiz, rlsiz) #else - FLExit("Fluidity compiled without libadaptivity support") + FLExit("Fluidity compiled without libadaptivity support") #endif - ewrite(1, *) "Exited adaptmem" - - ewrite(2, "(a,i0)") "Integer working memory size: ", intsiz - ewrite(2, "(a,i0)") "Real working memory size: ", rlsiz - if(intsiz < 0) then - FLAbort("Invalid integer working memory size") - end if - if(rlsiz < 0) then - FLAbort("Invalid real working memory size") - end if - - ewrite(2, *) "Forming remaining adptvy arguments" - - ! Working memory - allocate(intarr(intsiz)) ! Integer working memory - allocate(rlarr(rlsiz)) ! Real working memory - - geom3d = (mesh_dim(input_positions) == 3) ! Whether the domain is 3D - srfgmy = .false. ! Whether the surface mesh should be kept intact during the adapt - useq = .false. ! Unknown - - ! Maximum number of nodes - absolutemxnods = max_nodes(input_positions, expected_nodes(input_positions, int(xpctel / expected_elements_buffer), global = .false.)) - absolutemxnods = absolutemxnods * mxnods_buffer - ewrite(2, "(a,i0)") "Max. nodes: ", absolutemxnods - - ! Volume element list - allocate(enlbas(nelm + 1)) - do i = 1, nelm + 1 - enlbas(i) = (i - 1) * nloc - end do - enlist => input_positions%mesh%ndglno - - ! Region IDs - allocate(elmreg(nelm)) - if(associated(input_positions%mesh%region_ids).and.& - (have_option(base_path // "/preserve_mesh_regions").or.present_and_true(force_preserve_regions))) then - elmreg = input_positions%mesh%region_ids - else - elmreg = 0 - end if - - ! Surface element list - clcgmy = .true. ! Is .true. if the geometry should be calculated, and ignore snlist - szsnls = nselm * snloc - allocate(snlbas(nselm + 1)) - do i = 1, nselm + 1 - snlbas(i) = (i - 1) * snloc - end do - allocate(snlist(nselm * snloc)) - if(nselm > 0) then - call getsndgln(input_positions%mesh, snlist) - end if - - if (surface_element_count(input_positions)/=unique_surface_element_count(input_positions%mesh)) then - ewrite(0,*) "It appears you have an internal boundary and you're trying to use 3D adaptivity." - ewrite(0,*) "This combination has not been implemented yet." - ! You could try to see if it somehow does work, by simply removing this FLExit() - ! (make sure to check you still have the right internal boundary ids after the adapt) - ! Feel free to discuss on the fluidity mailing list. - FLExit("Cannot have internal boundaries with 3D adaptivity") - end if - - ! Surface IDs - allocate(surfid(nselm)) - call interleave_surface_ids(input_positions%mesh, surfid, max_coplanar_id) - - ! Node locking - if(present(lock_faces)) then - call get_locked_nodes_and_faces(input_positions, lock_faces, prdnds) - else - call get_locked_nodes(input_positions, prdnds) - end if - nprdnd = size(prdnds) - - ! Coordinates - nodx => input_positions%val(1,:) - nody => input_positions%val(2,:) - nodz => input_positions%val(3,:) - - ! Interpolation mesh (the same as the input mesh) - intnnd = nnod - intnel = nelm - intszl = szenls - intenl => enlist - intenb => enlbas - intndx => nodx - intndy => nody - intndz => nodz - - ! Metric - allocate(orgmtx(nnod * dim ** 2)) - select case(metric%field_type) - case(FIELD_TYPE_NORMAL) - orgmtx = reshape(metric%val, (/nnod * dim ** 2/)) - case default - do i = 1, nnod - orgmtx((i - 1) * dim * dim + 1:i * dim * dim) = reshape(node_val(metric, i), (/dim ** 2/)) - end do - end select - - ! Field data - none, as we don't use libadaptivity for interpolation any - ! more - nfield = 0 ! Number of fields - allocate(oldfld(nfield * nnod)) - allocate(nfree(nfield)) - - call get_option(base_path // "/functional_tolerance", mestp1, default = 0.0) - dotop = max(abs(mestp1), 0.15) ! Functional tolerance - minchg = 0.01 ! Unknown - - ! Number of adapt sweeps - call get_option(base_path // "/adaptivity_library/libadaptivity/sweeps/", & + ewrite(1, *) "Exited adaptmem" + + ewrite(2, "(a,i0)") "Integer working memory size: ", intsiz + ewrite(2, "(a,i0)") "Real working memory size: ", rlsiz + if(intsiz < 0) then + FLAbort("Invalid integer working memory size") + end if + if(rlsiz < 0) then + FLAbort("Invalid real working memory size") + end if + + ewrite(2, *) "Forming remaining adptvy arguments" + + ! Working memory + allocate(intarr(intsiz)) ! Integer working memory + allocate(rlarr(rlsiz)) ! Real working memory + + geom3d = (mesh_dim(input_positions) == 3) ! Whether the domain is 3D + srfgmy = .false. ! Whether the surface mesh should be kept intact during the adapt + useq = .false. ! Unknown + + ! Maximum number of nodes + absolutemxnods = max_nodes(input_positions, expected_nodes(input_positions, int(xpctel / expected_elements_buffer), global = .false.)) + absolutemxnods = absolutemxnods * mxnods_buffer + ewrite(2, "(a,i0)") "Max. nodes: ", absolutemxnods + + ! Volume element list + allocate(enlbas(nelm + 1)) + do i = 1, nelm + 1 + enlbas(i) = (i - 1) * nloc + end do + enlist => input_positions%mesh%ndglno + + ! Region IDs + allocate(elmreg(nelm)) + if(associated(input_positions%mesh%region_ids).and.& + (have_option(base_path // "/preserve_mesh_regions").or.present_and_true(force_preserve_regions))) then + elmreg = input_positions%mesh%region_ids + else + elmreg = 0 + end if + + ! Surface element list + clcgmy = .true. ! Is .true. if the geometry should be calculated, and ignore snlist + szsnls = nselm * snloc + allocate(snlbas(nselm + 1)) + do i = 1, nselm + 1 + snlbas(i) = (i - 1) * snloc + end do + allocate(snlist(nselm * snloc)) + if(nselm > 0) then + call getsndgln(input_positions%mesh, snlist) + end if + + if (surface_element_count(input_positions)/=unique_surface_element_count(input_positions%mesh)) then + ewrite(0,*) "It appears you have an internal boundary and you're trying to use 3D adaptivity." + ewrite(0,*) "This combination has not been implemented yet." + ! You could try to see if it somehow does work, by simply removing this FLExit() + ! (make sure to check you still have the right internal boundary ids after the adapt) + ! Feel free to discuss on the fluidity mailing list. + FLExit("Cannot have internal boundaries with 3D adaptivity") + end if + + ! Surface IDs + allocate(surfid(nselm)) + call interleave_surface_ids(input_positions%mesh, surfid, max_coplanar_id) + + ! Node locking + if(present(lock_faces)) then + call get_locked_nodes_and_faces(input_positions, lock_faces, prdnds) + else + call get_locked_nodes(input_positions, prdnds) + end if + nprdnd = size(prdnds) + + ! Coordinates + nodx => input_positions%val(1,:) + nody => input_positions%val(2,:) + nodz => input_positions%val(3,:) + + ! Interpolation mesh (the same as the input mesh) + intnnd = nnod + intnel = nelm + intszl = szenls + intenl => enlist + intenb => enlbas + intndx => nodx + intndy => nody + intndz => nodz + + ! Metric + allocate(orgmtx(nnod * dim ** 2)) + select case(metric%field_type) + case(FIELD_TYPE_NORMAL) + orgmtx = reshape(metric%val, (/nnod * dim ** 2/)) + case default + do i = 1, nnod + orgmtx((i - 1) * dim * dim + 1:i * dim * dim) = reshape(node_val(metric, i), (/dim ** 2/)) + end do + end select + + ! Field data - none, as we don't use libadaptivity for interpolation any + ! more + nfield = 0 ! Number of fields + allocate(oldfld(nfield * nnod)) + allocate(nfree(nfield)) + + call get_option(base_path // "/functional_tolerance", mestp1, default = 0.0) + dotop = max(abs(mestp1), 0.15) ! Functional tolerance + minchg = 0.01 ! Unknown + + ! Number of adapt sweeps + call get_option(base_path // "/adaptivity_library/libadaptivity/sweeps/", & & nsweep, default = 10) - ! Which element operations are we using? - ! Split edges if true - mshopt(1) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_split") - ! Collapse edges if true - mshopt(2) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_collapse") - ! Perform edge to face and edge to edge swapping if true - mshopt(3) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_swap") - ! Perform face to edge swapping if true - mshopt(4) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_swap") - mshopt(5) = .true. ! Split elements (do not use this yet) - ! In fact, this option is currently ignored and element - ! splitting is not performed by libadaptivity - ! Move nodes if true - mshopt(6) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_node_movement") - - twostg = .false. ! Two stages of adapting, with no refinement on first - togthr = .true. ! Lumps node movement adaptivity in with connectivity - ! changes - - ! Parallel data - nhalos = halo_count(input_positions) - assert(any(nhalos == (/0, 1, 2/))) - if(nhalos > 0) then - old_halo => input_positions%mesh%halos(nhalos) - assert(trailing_receives_consistent(old_halo)) - - nproc = halo_proc_count(old_halo) - ngath = halo_all_sends_count(old_halo) - allocate(gather(ngath)) - allocate(atosen(nproc + 1)) - nhalo = halo_all_receives_count(old_halo) - allocate(scater(nhalo)) - allocate(atorec(nproc + 1)) - call extract_raw_halo_data(old_halo, gather, atosen, scater, atorec, nowned_nodes = pnod) - else - nproc = 1 - ngath = 0 - allocate(gather(ngath)) - allocate(atosen(1)) - atosen = 0 - nhalo = 0 - allocate(scater(nhalo)) - allocate(atorec(1)) - atorec = 0 - pnod = nnod - end if - - ! Debugging options - debug_level = current_debug_level ! Verbosity - dbg = .false. ! Enable additional run time debugging within adaptivity. - chcnsy = .false. ! This option was for further run time - ! consistency checks within adaptivity but it's - ! currently disabled. - - ! Initialise output variables, just in case they're also used as input - nwnnod = 0 ! Number of nodes - nwnelm = 0 ! Number of volume elements - nwnsel = 0 ! Number of surface elements - nwszen = 0 ! Size of the volume element list - nwszsn = 0 ! Size of the surface element list - nwsznn = 0 ! Unknown - !nwndlc = 0 ! Node ownership list (start index in intarr) - !nwsrow = 0 ! Surface element ownership list (start index in intarr) - nwenlb = 0 ! Unknown - nwenls = 0 ! Volume element numbering list (start index in intarr) - nwsnlb = 0 ! Unknown - nwsnls = 0 ! Surface element numbering list (start index in intarr) - nwsfid = 0 ! Surface IDs (start index in intarr) - nwelrg = 0 ! Region IDs (start index in intarr) - nwnodx = 0 ! x-coordinates (start index in rlarr) - nwnody = 0 ! y-coordinates (start index in rlarr) - nwnodz = 0 ! z-coordinates (start index in rlarr) - !newmtx = 0 ! Adaptivity metric (start index in rlarr) - newfld = 0 ! Unknown - biglst = 0 ! Unknown - nodlst = 0 ! Unknown - - ! Output options - output_quality = have_option(base_path // "/adaptivity_library/libadaptivity/write_adapted_quality") - if(output_quality) then - newmtx = 1 ! Return interpolated metric - else - newmtx = -1 ! Do not return interpolated metric - end if - if(present(node_ownership)) then - nwndlc = 1 ! Return map from new nodes to old elements - else - nwndlc = -1 ! Do not return map from new nodes to old elements - end if - nwsrow = -1 ! Do not return surface element owners - - ewrite(1, *) "Calling adptvy from adapt_mesh" - call tic(TICTOC_ID_SERIAL_ADAPT) + ! Which element operations are we using? + ! Split edges if true + mshopt(1) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_split") + ! Collapse edges if true + mshopt(2) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_collapse") + ! Perform edge to face and edge to edge swapping if true + mshopt(3) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_swap") + ! Perform face to edge swapping if true + mshopt(4) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_edge_swap") + mshopt(5) = .true. ! Split elements (do not use this yet) + ! In fact, this option is currently ignored and element + ! splitting is not performed by libadaptivity + ! Move nodes if true + mshopt(6) = .not. have_option(base_path // "/adaptivity_library/libadaptivity/disable_node_movement") + + twostg = .false. ! Two stages of adapting, with no refinement on first + togthr = .true. ! Lumps node movement adaptivity in with connectivity + ! changes + + ! Parallel data + nhalos = halo_count(input_positions) + assert(any(nhalos == (/0, 1, 2/))) + if(nhalos > 0) then + old_halo => input_positions%mesh%halos(nhalos) + assert(trailing_receives_consistent(old_halo)) + + nproc = halo_proc_count(old_halo) + ngath = halo_all_sends_count(old_halo) + allocate(gather(ngath)) + allocate(atosen(nproc + 1)) + nhalo = halo_all_receives_count(old_halo) + allocate(scater(nhalo)) + allocate(atorec(nproc + 1)) + call extract_raw_halo_data(old_halo, gather, atosen, scater, atorec, nowned_nodes = pnod) + else + nproc = 1 + ngath = 0 + allocate(gather(ngath)) + allocate(atosen(1)) + atosen = 0 + nhalo = 0 + allocate(scater(nhalo)) + allocate(atorec(1)) + atorec = 0 + pnod = nnod + end if + + ! Debugging options + debug_level = current_debug_level ! Verbosity + dbg = .false. ! Enable additional run time debugging within adaptivity. + chcnsy = .false. ! This option was for further run time + ! consistency checks within adaptivity but it's + ! currently disabled. + + ! Initialise output variables, just in case they're also used as input + nwnnod = 0 ! Number of nodes + nwnelm = 0 ! Number of volume elements + nwnsel = 0 ! Number of surface elements + nwszen = 0 ! Size of the volume element list + nwszsn = 0 ! Size of the surface element list + nwsznn = 0 ! Unknown + !nwndlc = 0 ! Node ownership list (start index in intarr) + !nwsrow = 0 ! Surface element ownership list (start index in intarr) + nwenlb = 0 ! Unknown + nwenls = 0 ! Volume element numbering list (start index in intarr) + nwsnlb = 0 ! Unknown + nwsnls = 0 ! Surface element numbering list (start index in intarr) + nwsfid = 0 ! Surface IDs (start index in intarr) + nwelrg = 0 ! Region IDs (start index in intarr) + nwnodx = 0 ! x-coordinates (start index in rlarr) + nwnody = 0 ! y-coordinates (start index in rlarr) + nwnodz = 0 ! z-coordinates (start index in rlarr) + !newmtx = 0 ! Adaptivity metric (start index in rlarr) + newfld = 0 ! Unknown + biglst = 0 ! Unknown + nodlst = 0 ! Unknown + + ! Output options + output_quality = have_option(base_path // "/adaptivity_library/libadaptivity/write_adapted_quality") + if(output_quality) then + newmtx = 1 ! Return interpolated metric + else + newmtx = -1 ! Do not return interpolated metric + end if + if(present(node_ownership)) then + nwndlc = 1 ! Return map from new nodes to old elements + else + nwndlc = -1 ! Do not return map from new nodes to old elements + end if + nwsrow = -1 ! Do not return surface element owners + + ewrite(1, *) "Calling adptvy from adapt_mesh" + call tic(TICTOC_ID_SERIAL_ADAPT) #ifdef HAVE_ADAPTIVITY - call adptvy(intarr, intsiz, rlarr, rlsiz, & + call adptvy(intarr, intsiz, rlarr, rlsiz, & & geom3d, srfgmy, useq, & & nnod, nelm, nselm, absolutemxnods, & & szenls, enlbas, enlist, elmreg, & @@ -532,385 +532,385 @@ subroutine adapt_mesh(input_positions, metric, output_positions, node_ownership, & gather, scater, ngath, nhalo, pnod, & & atosen, atorec, nproc, debug_level, dbg, chcnsy) #else - FLExit("Fluidity compiled without libadaptivity support") + FLExit("Fluidity compiled without libadaptivity support") #endif - call toc(TICTOC_ID_SERIAL_ADAPT) - ewrite(1, *) "Exited adptvy" - - if(nwnnod < 0) then - FLAbort("Mesh adaptivity exited with an error") - end if - assert(nwnnod <= absolutemxnods) - assert(nwnelm >= 0) - - deallocate(orgmtx) - deallocate(enlbas) - deallocate(elmreg) - deallocate(snlbas) - deallocate(snlist) - deallocate(surfid) - deallocate(prdnds) - deallocate(oldfld) - deallocate(nfree) - - ewrite(2, *) "Constructing output positions" - - allocate(output_mesh) - call allocate(output_mesh, nwnnod, nwnelm, input_positions%mesh%shape, name = input_positions%mesh%name) - output_mesh%shape%refcount%tagged = .false. - output_mesh%shape%quadrature%refcount%tagged = .false. - - output_mesh%ndglno = intarr(nwenls:nwenls + nwszen - 1) - output_mesh%option_path = input_positions%mesh%option_path - - ! Construct the new positions - call allocate(output_positions, dim, output_mesh, name = input_positions%name) - call deallocate(output_mesh) - deallocate(output_mesh) - output_mesh => output_positions%mesh - - call set_all(output_positions, 1, rlarr(nwnodx:nwnodx + nwnnod - 1)) - call set_all(output_positions, 2, rlarr(nwnody:nwnody + nwnnod - 1)) - call set_all(output_positions, 3, rlarr(nwnodz:nwnodz + nwnnod - 1)) - output_positions%option_path = input_positions%option_path - - ! put the region id info in now so we can reorder it if we're parallel - if(have_option(base_path // "/preserve_mesh_regions")& - .or.present_and_true(force_preserve_regions)) then - allocate(output_mesh%region_ids(nwnelm)) - output_mesh%region_ids = intarr(nwelrg:nwelrg + nwnelm - 1) - end if - - if(nhalos > 0) then - ewrite(2, *) "Constructing output halos" - - allocate(renumber_permutation(nwnelm)) - - allocate(output_mesh%halos(nhalos)) - call form_halo_from_raw_data(output_mesh%halos(nhalos), nproc, gather, atosen, scater, atorec,& - & nowned_nodes = nwnnod - nhalo, create_caches = .true.) - - if(nhalos == 2) then - ! Derive remaining halos - call derive_l1_from_l2_halo(output_mesh, & - & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) - - allocate(output_mesh%element_halos(2)) - call derive_element_halo_from_node_halo(output_mesh, & - & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) - else - allocate(output_mesh%element_halos(1)) - call derive_element_halo_from_node_halo(output_mesh, & - & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) - end if + call toc(TICTOC_ID_SERIAL_ADAPT) + ewrite(1, *) "Exited adptvy" + if(nwnnod < 0) then + FLAbort("Mesh adaptivity exited with an error") + end if + assert(nwnnod <= absolutemxnods) + assert(nwnelm >= 0) + + deallocate(orgmtx) + deallocate(enlbas) + deallocate(elmreg) + deallocate(snlbas) + deallocate(snlist) + deallocate(surfid) + deallocate(prdnds) + deallocate(oldfld) + deallocate(nfree) + + ewrite(2, *) "Constructing output positions" + + allocate(output_mesh) + call allocate(output_mesh, nwnnod, nwnelm, input_positions%mesh%shape, name = input_positions%mesh%name) + output_mesh%shape%refcount%tagged = .false. + output_mesh%shape%quadrature%refcount%tagged = .false. + + output_mesh%ndglno = intarr(nwenls:nwenls + nwszen - 1) + output_mesh%option_path = input_positions%mesh%option_path + + ! Construct the new positions + call allocate(output_positions, dim, output_mesh, name = input_positions%name) + call deallocate(output_mesh) + deallocate(output_mesh) + output_mesh => output_positions%mesh + + call set_all(output_positions, 1, rlarr(nwnodx:nwnodx + nwnnod - 1)) + call set_all(output_positions, 2, rlarr(nwnody:nwnody + nwnnod - 1)) + call set_all(output_positions, 3, rlarr(nwnodz:nwnodz + nwnnod - 1)) + output_positions%option_path = input_positions%option_path + + ! put the region id info in now so we can reorder it if we're parallel if(have_option(base_path // "/preserve_mesh_regions")& - .or.present_and_true(force_preserve_regions)) then - ! reorder the region_ids since all out elements have been jiggled about - allocate(old_new_region_ids(nwnelm)) - old_new_region_ids = output_positions%mesh%region_ids - do i = 1, nwnelm - output_positions%mesh%region_ids(renumber_permutation(i)) = old_new_region_ids(i) - end do - deallocate(old_new_region_ids) + .or.present_and_true(force_preserve_regions)) then + allocate(output_mesh%region_ids(nwnelm)) + output_mesh%region_ids = intarr(nwelrg:nwelrg + nwnelm - 1) end if - deallocate(renumber_permutation) - - ! Adaptivity is not guaranteed to return halo elements in the same - ! order in which they went in. We therefore need to fix this order. - call reorder_element_numbering(output_positions) + if(nhalos > 0) then + ewrite(2, *) "Constructing output halos" + + allocate(renumber_permutation(nwnelm)) + + allocate(output_mesh%halos(nhalos)) + call form_halo_from_raw_data(output_mesh%halos(nhalos), nproc, gather, atosen, scater, atorec,& + & nowned_nodes = nwnnod - nhalo, create_caches = .true.) + + if(nhalos == 2) then + ! Derive remaining halos + call derive_l1_from_l2_halo(output_mesh, & + & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) + + allocate(output_mesh%element_halos(2)) + call derive_element_halo_from_node_halo(output_mesh, & + & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) + else + allocate(output_mesh%element_halos(1)) + call derive_element_halo_from_node_halo(output_mesh, & + & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) + end if + + if(have_option(base_path // "/preserve_mesh_regions")& + .or.present_and_true(force_preserve_regions)) then + ! reorder the region_ids since all out elements have been jiggled about + allocate(old_new_region_ids(nwnelm)) + old_new_region_ids = output_positions%mesh%region_ids + do i = 1, nwnelm + output_positions%mesh%region_ids(renumber_permutation(i)) = old_new_region_ids(i) + end do + deallocate(old_new_region_ids) + end if + + deallocate(renumber_permutation) + + ! Adaptivity is not guaranteed to return halo elements in the same + ! order in which they went in. We therefore need to fix this order. + call reorder_element_numbering(output_positions) #ifdef DDEBUG - do i = 1, nhalos - assert(trailing_receives_consistent(output_mesh%halos(i))) - assert(halo_valid_for_communication(output_mesh%halos(i))) - assert(halo_verifies(output_mesh%halos(i), output_positions)) - end do + do i = 1, nhalos + assert(trailing_receives_consistent(output_mesh%halos(i))) + assert(halo_valid_for_communication(output_mesh%halos(i))) + assert(halo_verifies(output_mesh%halos(i), output_positions)) + end do #endif - ewrite(2, *) "Finished constructing output halos" - end if - - deallocate(gather) - deallocate(atosen) - deallocate(scater) - deallocate(atorec) - - ewrite(2, *) "Constructing output surface data" + ewrite(2, *) "Finished constructing output halos" + end if - allocate(boundary_ids(nwnsel)) - allocate(coplanar_ids(nwnsel)) - call deinterleave_surface_ids(intarr(nwsfid:nwsfid + nwnsel - 1), max_coplanar_id, boundary_ids, coplanar_ids) - call add_faces(output_mesh, sndgln = intarr(nwsnls:nwsnls + nwszsn - 1), boundary_ids = boundary_ids) - deallocate(boundary_ids) - if(associated(input_positions%mesh%faces%coplanar_ids)) then - allocate(output_mesh%faces%coplanar_ids(nwnsel)) - output_mesh%faces%coplanar_ids = coplanar_ids - end if - deallocate(coplanar_ids) + deallocate(gather) + deallocate(atosen) + deallocate(scater) + deallocate(atorec) + + ewrite(2, *) "Constructing output surface data" + + allocate(boundary_ids(nwnsel)) + allocate(coplanar_ids(nwnsel)) + call deinterleave_surface_ids(intarr(nwsfid:nwsfid + nwnsel - 1), max_coplanar_id, boundary_ids, coplanar_ids) + call add_faces(output_mesh, sndgln = intarr(nwsnls:nwsnls + nwszsn - 1), boundary_ids = boundary_ids) + deallocate(boundary_ids) + if(associated(input_positions%mesh%faces%coplanar_ids)) then + allocate(output_mesh%faces%coplanar_ids(nwnsel)) + output_mesh%faces%coplanar_ids = coplanar_ids + end if + deallocate(coplanar_ids) - ewrite(2, *) "Finished constructing output surface data" + ewrite(2, *) "Finished constructing output surface data" #ifdef DDEBUG - call verify_positions(output_positions) + call verify_positions(output_positions) #endif - ewrite(2, *) "Finished constructing output positions" + ewrite(2, *) "Finished constructing output positions" - if(output_quality) then - assert(newmtx > 0) - call allocate(new_metric, output_positions%mesh, metric%name) - do i = 1, nwnnod - call set(new_metric, i, reshape(rlarr(newmtx + (i - 1) * dim * dim:newmtx + i * dim * dim - 1), (/dim, dim/))) - end do + if(output_quality) then + assert(newmtx > 0) + call allocate(new_metric, output_positions%mesh, metric%name) + do i = 1, nwnnod + call set(new_metric, i, reshape(rlarr(newmtx + (i - 1) * dim * dim:newmtx + i * dim * dim - 1), (/dim, dim/))) + end do - call element_quality_pain_p0(output_positions, new_metric, quality) - ewrite_minmax(quality) - call vtk_write_fields("adapted_quality", index = output_quality_index, & - & position = output_positions, model = output_positions%mesh, & - & sfields = (/quality/), tfields = (/new_metric/)) - output_quality_index = output_quality_index + 1 - call deallocate(quality) + call element_quality_pain_p0(output_positions, new_metric, quality) + ewrite_minmax(quality) + call vtk_write_fields("adapted_quality", index = output_quality_index, & + & position = output_positions, model = output_positions%mesh, & + & sfields = (/quality/), tfields = (/new_metric/)) + output_quality_index = output_quality_index + 1 + call deallocate(quality) - call deallocate(new_metric) - end if + call deallocate(new_metric) + end if - if(present(node_ownership)) then - ! Return the node ownership - assert(nwnnod > 0) - allocate(node_ownership(nwnnod)) - node_ownership = intarr(nwndlc:nwndlc + nwnnod - 1) - end if + if(present(node_ownership)) then + ! Return the node ownership + assert(nwnnod > 0) + allocate(node_ownership(nwnnod)) + node_ownership = intarr(nwndlc:nwndlc + nwnnod - 1) + end if - deallocate(intarr) - deallocate(rlarr) + deallocate(intarr) + deallocate(rlarr) - ewrite(1, *) "Exiting adapt_mesh" + ewrite(1, *) "Exiting adapt_mesh" - end subroutine adapt_mesh + end subroutine adapt_mesh - function max_nodes(positions, expected_nodes) - type(vector_field), intent(in) :: positions - !! The process local number of expected nodes - integer, intent(in) :: expected_nodes + function max_nodes(positions, expected_nodes) + type(vector_field), intent(in) :: positions + !! The process local number of expected nodes + integer, intent(in) :: expected_nodes - integer :: max_nodes + integer :: max_nodes - call get_option(base_path // "/maximum_number_of_nodes", max_nodes, default = 100000) - if(isparallel()) then - if(.not. have_option(base_path // "/maximum_number_of_nodes/per_process")) then - max_nodes = max_nodes / getnprocs() + call get_option(base_path // "/maximum_number_of_nodes", max_nodes, default = 100000) + if(isparallel()) then + if(.not. have_option(base_path // "/maximum_number_of_nodes/per_process")) then + max_nodes = max_nodes / getnprocs() + end if end if - end if - max_nodes = max(max_nodes, expected_nodes, node_count(positions)) + max_nodes = max(max_nodes, expected_nodes, node_count(positions)) - end function max_nodes + end function max_nodes - subroutine get_locked_nodes_and_faces(positions, lock_faces, locked_nodes) - type(vector_field), intent(in) :: positions - type(integer_set), intent(in) :: lock_faces - integer, dimension(:), allocatable, intent(out) :: locked_nodes + subroutine get_locked_nodes_and_faces(positions, lock_faces, locked_nodes) + type(vector_field), intent(in) :: positions + type(integer_set), intent(in) :: lock_faces + integer, dimension(:), allocatable, intent(out) :: locked_nodes - integer :: i, snloc - integer, dimension(:), allocatable :: llocked_nodes + integer :: i, snloc + integer, dimension(:), allocatable :: llocked_nodes - snloc = face_loc(positions, 1) + snloc = face_loc(positions, 1) - call get_locked_nodes(positions, llocked_nodes) - allocate(locked_nodes(size(llocked_nodes) + key_count(lock_faces) * snloc)) - locked_nodes(:size(llocked_nodes)) = llocked_nodes - do i = 1, key_count(lock_faces) - locked_nodes(size(llocked_nodes) + 1 + snloc * (i - 1):size(llocked_nodes) + snloc * i) = & - & face_global_nodes(positions, fetch(lock_faces, i)) - end do - deallocate(llocked_nodes) + call get_locked_nodes(positions, llocked_nodes) + allocate(locked_nodes(size(llocked_nodes) + key_count(lock_faces) * snloc)) + locked_nodes(:size(llocked_nodes)) = llocked_nodes + do i = 1, key_count(lock_faces) + locked_nodes(size(llocked_nodes) + 1 + snloc * (i - 1):size(llocked_nodes) + snloc * i) = & + & face_global_nodes(positions, fetch(lock_faces, i)) + end do + deallocate(llocked_nodes) - end subroutine get_locked_nodes_and_faces + end subroutine get_locked_nodes_and_faces - subroutine verify_positions(positions) - !!< Verify the supplied Coordinate field - replaces elementsok + subroutine verify_positions(positions) + !!< Verify the supplied Coordinate field - replaces elementsok - type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: positions - integer :: i, nnodes - logical :: positive_volumes - real :: volume - type(element_type), pointer :: shape + integer :: i, nnodes + logical :: positive_volumes + real :: volume + type(element_type), pointer :: shape - ewrite(1, *) "In verify_positions" + ewrite(1, *) "In verify_positions" - nnodes = node_count(positions) + nnodes = node_count(positions) - do i = 1, ele_count(positions) - assert(all(ele_nodes(positions, i) >= 1)) - assert(all(ele_nodes(positions, i) <= nnodes)) + do i = 1, ele_count(positions) + assert(all(ele_nodes(positions, i) >= 1)) + assert(all(ele_nodes(positions, i) <= nnodes)) - shape => ele_shape(positions, i) - if(positions%dim == 3 .and. shape%loc == 4 .and. shape%degree == 1) then - volume = simplex_volume(positions, i) - if(abs(volume) < epsilon(0.0)) then - ewrite(-1, "(a,i0)") "For element: ", i - FLAbort("Degenerate tetrahedron encountered") - end if + shape => ele_shape(positions, i) + if(positions%dim == 3 .and. shape%loc == 4 .and. shape%degree == 1) then + volume = simplex_volume(positions, i) + if(abs(volume) < epsilon(0.0)) then + ewrite(-1, "(a,i0)") "For element: ", i + FLAbort("Degenerate tetrahedron encountered") + end if - if(i > 1) then - if(.not. positive_volumes .eqv. (volume > 0.0)) then - FLAbort("Signs of tetrahredon volumes are not consistent") - end if - else - positive_volumes = volume > 0.0 - end if - end if - end do + if(i > 1) then + if(.not. positive_volumes .eqv. (volume > 0.0)) then + FLAbort("Signs of tetrahredon volumes are not consistent") + end if + else + positive_volumes = volume > 0.0 + end if + end if + end do - ewrite(1, *) "Exiting verify_positions" + ewrite(1, *) "Exiting verify_positions" - end subroutine verify_positions + end subroutine verify_positions - function pain_functional(ele, positions, metric) result(func) - !!< Evaluate the Pain 2001 functional for the supplied 3d tetrahedron. + function pain_functional(ele, positions, metric) result(func) + !!< Evaluate the Pain 2001 functional for the supplied 3d tetrahedron. - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric - real :: func + real :: func - integer, dimension(:), pointer :: nodes - real :: scale_factor = 1.0 / (2.0 * sqrt(6.0)) + integer, dimension(:), pointer :: nodes + real :: scale_factor = 1.0 / (2.0 * sqrt(6.0)) - ! mtetin arguments - real, dimension(4) :: x, y, z - real, dimension(3, 3) :: m - real :: vol - real, dimension(4) :: areas - real, dimension(6) :: l - real :: radius, qualty + ! mtetin arguments + real, dimension(4) :: x, y, z + real, dimension(3, 3) :: m + real :: vol + real, dimension(4) :: areas + real, dimension(6) :: l + real :: radius, qualty - x = ele_val(positions, 1, ele) - y = ele_val(positions, 2, ele) - z = ele_val(positions, 3, ele) - nodes => ele_nodes(metric, ele) - m = 0.25 * (node_val(metric, nodes(1)) + & - & node_val(metric, nodes(2)) + & - & node_val(metric, nodes(3)) + & - & node_val(metric, nodes(4))) + x = ele_val(positions, 1, ele) + y = ele_val(positions, 2, ele) + z = ele_val(positions, 3, ele) + nodes => ele_nodes(metric, ele) + m = 0.25 * (node_val(metric, nodes(1)) + & + & node_val(metric, nodes(2)) + & + & node_val(metric, nodes(3)) + & + & node_val(metric, nodes(4))) - ! Zero output arguments, just in case they're also used as input - vol = 0.0 - areas = 0.0 - l = 0.0 - radius = 0.0 - qualty = 0.0 + ! Zero output arguments, just in case they're also used as input + vol = 0.0 + areas = 0.0 + l = 0.0 + radius = 0.0 + qualty = 0.0 - ! Use libadaptivity to compute the edge lengths and in-sphere radius + ! Use libadaptivity to compute the edge lengths and in-sphere radius #ifdef HAVE_ADAPTIVITY - call mtetin(x, y, z, m, vol, areas, l, radius, qualty) + call mtetin(x, y, z, m, vol, areas, l, radius, qualty) #else - FLExit("Fluidity compiled without libadaptivity support") + FLExit("Fluidity compiled without libadaptivity support") #endif - func = 0.5 * (((1.0 - l(1)) ** 2) + & - & ((1.0 - l(2)) ** 2) + & - & ((1.0 - l(3)) ** 2) + & - & ((1.0 - l(4)) ** 2) + & - & ((1.0 - l(5)) ** 2) + & - & ((1.0 - l(6)) ** 2)) + & - & (((scale_factor / radius) - 1.0) ** 2) + func = 0.5 * (((1.0 - l(1)) ** 2) + & + & ((1.0 - l(2)) ** 2) + & + & ((1.0 - l(3)) ** 2) + & + & ((1.0 - l(4)) ** 2) + & + & ((1.0 - l(5)) ** 2) + & + & ((1.0 - l(6)) ** 2)) + & + & (((scale_factor / radius) - 1.0) ** 2) - end function pain_functional + end function pain_functional - subroutine element_quality_pain_p0(positions, metric, quality) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric - type(scalar_field), intent(out) :: quality + subroutine element_quality_pain_p0(positions, metric, quality) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric + type(scalar_field), intent(out) :: quality - type(tensor_field):: rescaled_metric - type(vector_field):: rescaled_positions - integer :: ele - type(mesh_type) :: pwc_mesh + type(tensor_field):: rescaled_metric + type(vector_field):: rescaled_positions + integer :: ele + type(mesh_type) :: pwc_mesh - assert(positions%dim == 3) + assert(positions%dim == 3) - pwc_mesh = piecewise_constant_mesh(positions%mesh, "PWCMesh") - call allocate(quality, pwc_mesh, "ElementQuality") - call deallocate(pwc_mesh) + pwc_mesh = piecewise_constant_mesh(positions%mesh, "PWCMesh") + call allocate(quality, pwc_mesh, "ElementQuality") + call deallocate(pwc_mesh) - call rescale_mesh_and_metric(positions, metric, rescaled_positions, rescaled_metric) + call rescale_mesh_and_metric(positions, metric, rescaled_positions, rescaled_metric) - do ele=1,ele_count(positions) - call set(quality, ele, pain_functional(ele, rescaled_positions, rescaled_metric)) - end do + do ele=1,ele_count(positions) + call set(quality, ele, pain_functional(ele, rescaled_positions, rescaled_metric)) + end do - call deallocate(rescaled_positions) - call deallocate(rescaled_metric) + call deallocate(rescaled_positions) + call deallocate(rescaled_metric) - end subroutine element_quality_pain_p0 + end subroutine element_quality_pain_p0 - subroutine rescale_mesh_and_metric(positions, metric, rescaled_positions, rescaled_metric) - ! This routine applies the same rescaling to a 500x500x500 box that happens inside libadaptivity (3D) - ! (note that in parallel this happens for each local domain seperately) - type(vector_field), intent(in):: positions - type(tensor_field), intent(in):: metric - type(vector_field), intent(out):: rescaled_positions - type(tensor_field), intent(out):: rescaled_metric + subroutine rescale_mesh_and_metric(positions, metric, rescaled_positions, rescaled_metric) + ! This routine applies the same rescaling to a 500x500x500 box that happens inside libadaptivity (3D) + ! (note that in parallel this happens for each local domain seperately) + type(vector_field), intent(in):: positions + type(tensor_field), intent(in):: metric + type(vector_field), intent(out):: rescaled_positions + type(tensor_field), intent(out):: rescaled_metric - real, parameter:: BOX_SIZE=500.0 - real, dimension(positions%dim):: rescale - real:: shift - integer:: i, j + real, parameter:: BOX_SIZE=500.0 + real, dimension(positions%dim):: rescale + real:: shift + integer:: i, j - call allocate(rescaled_positions, positions%dim, positions%mesh, name="Rescaled"//trim(positions%name)) - call allocate(rescaled_metric, metric%mesh, name="Rescaled"//trim(metric%name)) + call allocate(rescaled_positions, positions%dim, positions%mesh, name="Rescaled"//trim(positions%name)) + call allocate(rescaled_metric, metric%mesh, name="Rescaled"//trim(metric%name)) - do i=1, positions%dim - shift = minval(positions%val(i,:)) - rescale(i) = (maxval(positions%val(i,:))-shift)/BOX_SIZE - call set_all(rescaled_positions, i, (positions%val(i,:)-shift)/rescale(i)) - end do + do i=1, positions%dim + shift = minval(positions%val(i,:)) + rescale(i) = (maxval(positions%val(i,:))-shift)/BOX_SIZE + call set_all(rescaled_positions, i, (positions%val(i,:)-shift)/rescale(i)) + end do - do i=1, positions%dim - do j=1, positions%dim - call set_all(rescaled_metric, i, j, metric%val(i,j,:)*rescale(i)*rescale(j)) + do i=1, positions%dim + do j=1, positions%dim + call set_all(rescaled_metric, i, j, metric%val(i,j,:)*rescale(i)*rescale(j)) + end do end do - end do - end subroutine rescale_mesh_and_metric + end subroutine rescale_mesh_and_metric - subroutine adapt_integration_check_options - !!< Checks libadaptivity integration related options + subroutine adapt_integration_check_options + !!< Checks libadaptivity integration related options - integer :: dim, max_nodes, stat + integer :: dim, max_nodes, stat - if(.not. have_option(base_path)) then - ! Nothing to check - return - end if + if(.not. have_option(base_path)) then + ! Nothing to check + return + end if - call get_option("/geometry/dimension", dim, stat) - if(stat /= SPUD_NO_ERROR) then - ! This isn't the place to complain about this error - return - else if(have_option(base_path // "/adaptivity_library/libadaptivity") .or. dim == 3) then - if(dim /= 3) then - FLExit("libadaptivity can only be used in 3D") + call get_option("/geometry/dimension", dim, stat) + if(stat /= SPUD_NO_ERROR) then + ! This isn't the place to complain about this error + return + else if(have_option(base_path // "/adaptivity_library/libadaptivity") .or. dim == 3) then + if(dim /= 3) then + FLExit("libadaptivity can only be used in 3D") + end if end if - end if - ewrite(2, *) "Checking hr-adaptivity related options" + ewrite(2, *) "Checking hr-adaptivity related options" - call get_option(base_path // "/maximum_number_of_nodes", max_nodes, stat) - if(stat /= SPUD_NO_ERROR) then - FLExit("Maximum number of nodes required for 3d adaptivity with libadaptivity") - else if(max_nodes <= 0) then - FLExit("Maximum number of nodes must be positive") - end if + call get_option(base_path // "/maximum_number_of_nodes", max_nodes, stat) + if(stat /= SPUD_NO_ERROR) then + FLExit("Maximum number of nodes required for 3d adaptivity with libadaptivity") + else if(max_nodes <= 0) then + FLExit("Maximum number of nodes must be positive") + end if - ewrite(2, *) "Finished checking hr-adaptivity related options" + ewrite(2, *) "Finished checking hr-adaptivity related options" - end subroutine adapt_integration_check_options + end subroutine adapt_integration_check_options end module adapt_integration diff --git a/assemble/Adapt_State.F90 b/assemble/Adapt_State.F90 index dff61bbd75..6547ff6fbd 100644 --- a/assemble/Adapt_State.F90 +++ b/assemble/Adapt_State.F90 @@ -28,1787 +28,1787 @@ #include "fdebug.h" module adapt_state_module - use spud - use fldebug - use global_parameters, only : OPTION_PATH_LEN, periodic_boundary_option_path, adaptivity_mesh_name, adaptivity_mesh_name, domain_bbox, topology_mesh_name, FIELD_NAME_LEN - use futils, only: int2str, int2str_len, present_and_false, present_and_true - use reference_counting, only: tag_references, print_tagged_references - use quadrature - use elements - use mpi_interfaces - use parallel_tools - use data_structures - use sparse_tools - use metric_tools - use eventcounter - use parallel_fields - use intersection_finder_module - use fields - use profiler - use state_module - use vtk_interfaces - use halos - use field_options - use node_boundary, only: initialise_boundcount - use boundary_conditions - use detector_data_types - use pickers - use interpolation_module - use hadapt_metric_based_extrude - use tictoc - use adaptivity_1d - use limit_metric_module, only: limit_metric - use adapt_integration, only : adapt_mesh_3d => adapt_mesh - use fefields - use adaptive_timestepping - use detector_parallel - use particles, only: update_particle_attributes_and_fields - use diagnostic_variables - use particle_diagnostics, only: initialise_constant_particle_diagnostics, calculate_diagnostic_fields_from_particles - use checkpoint - use edge_length_module - use boundary_conditions_from_options - use diagnostic_fields_wrapper_new, only : calculate_diagnostic_variables_new => calculate_diagnostic_variables - use hadapt_extrude - use reserve_state_module - use fields_halos - use populate_state_module - use dqmom - use diagnostic_fields_wrapper - use discrete_properties_module - use interpolation_manager - use mba_adapt_module - use mba2d_integration - use mba3d_integration - use anisotropic_gradation, only: use_anisotropic_gradation - use project_metric_to_surface_module - use metric_assemble - use sam_integration - use timeloop_utilities - use write_gmsh + use spud + use fldebug + use global_parameters, only : OPTION_PATH_LEN, periodic_boundary_option_path, adaptivity_mesh_name, adaptivity_mesh_name, domain_bbox, topology_mesh_name, FIELD_NAME_LEN + use futils, only: int2str, int2str_len, present_and_false, present_and_true + use reference_counting, only: tag_references, print_tagged_references + use quadrature + use elements + use mpi_interfaces + use parallel_tools + use data_structures + use sparse_tools + use metric_tools + use eventcounter + use parallel_fields + use intersection_finder_module + use fields + use profiler + use state_module + use vtk_interfaces + use halos + use field_options + use node_boundary, only: initialise_boundcount + use boundary_conditions + use detector_data_types + use pickers + use interpolation_module + use hadapt_metric_based_extrude + use tictoc + use adaptivity_1d + use limit_metric_module, only: limit_metric + use adapt_integration, only : adapt_mesh_3d => adapt_mesh + use fefields + use adaptive_timestepping + use detector_parallel + use particles, only: update_particle_attributes_and_fields + use diagnostic_variables + use particle_diagnostics, only: initialise_constant_particle_diagnostics, calculate_diagnostic_fields_from_particles + use checkpoint + use edge_length_module + use boundary_conditions_from_options + use diagnostic_fields_wrapper_new, only : calculate_diagnostic_variables_new => calculate_diagnostic_variables + use hadapt_extrude + use reserve_state_module + use fields_halos + use populate_state_module + use dqmom + use diagnostic_fields_wrapper + use discrete_properties_module + use interpolation_manager + use mba_adapt_module + use mba2d_integration + use mba3d_integration + use anisotropic_gradation, only: use_anisotropic_gradation + use project_metric_to_surface_module + use metric_assemble + use sam_integration + use timeloop_utilities + use write_gmsh #ifdef HAVE_ZOLTAN - use zoltan_integration + use zoltan_integration #endif - implicit none + implicit none - private + private - public :: adapt_mesh, adapt_state, adapt_state_first_timestep - public :: insert_metric_for_interpolation, extract_and_remove_metric, sam_options - public :: adapt_state_module_check_options + public :: adapt_mesh, adapt_state, adapt_state_first_timestep + public :: insert_metric_for_interpolation, extract_and_remove_metric, sam_options + public :: adapt_state_module_check_options - interface adapt_state - module procedure adapt_state_single, adapt_state_multiple - end interface adapt_state + interface adapt_state + module procedure adapt_state_single, adapt_state_multiple + end interface adapt_state contains - subroutine adapt_mesh_simple(old_positions, metric, new_positions, node_ownership, force_preserve_regions, & + subroutine adapt_mesh_simple(old_positions, metric, new_positions, node_ownership, force_preserve_regions, & lock_faces, allow_boundary_elements) - type(vector_field), intent(in) :: old_positions - type(tensor_field), intent(in) :: metric - type(vector_field) :: stripped_positions - type(tensor_field) :: stripped_metric - type(vector_field), intent(out) :: new_positions - integer, dimension(:), pointer, optional :: node_ownership - logical, intent(in), optional :: force_preserve_regions - type(integer_set), intent(in), optional :: lock_faces - logical, intent(in), optional :: allow_boundary_elements - type(vector_field) :: expanded_positions - - assert(.not. mesh_periodic(old_positions)) - - if(isparallel()) then - ! generate stripped versions of the position and metric fields - call strip_l2_halo(old_positions, metric, stripped_positions, stripped_metric) - else - stripped_positions = old_positions - stripped_metric = metric - call incref(stripped_positions) - call incref(stripped_metric) - end if - - select case(stripped_positions%dim) - case(1) - call adapt_mesh_1d(stripped_positions, stripped_metric, new_positions, & - & node_ownership = node_ownership, force_preserve_regions = force_preserve_regions) - case(2) - call adapt_mesh_mba2d(stripped_positions, stripped_metric, new_positions, & - & force_preserve_regions=force_preserve_regions, lock_faces=lock_faces, & - & allow_boundary_elements=allow_boundary_elements) - case(3) - if(have_option("/mesh_adaptivity/hr_adaptivity/adaptivity_library/libmba3d")) then - assert(.not. present(lock_faces)) - call adapt_mesh_mba3d(stripped_positions, stripped_metric, new_positions, & - force_preserve_regions=force_preserve_regions) - else - call adapt_mesh_3d(stripped_positions, stripped_metric, new_positions, & - force_preserve_regions=force_preserve_regions, lock_faces=lock_faces) - end if - case default - FLAbort("Mesh adaptivity requires a 1D, 2D or 3D mesh") - end select - - if(isparallel()) then - expanded_positions = expand_positions_halo(new_positions) - call deallocate(new_positions) - new_positions = expanded_positions - end if - - ! deallocate stripped metric and positions - we don't need these anymore - call deallocate(stripped_metric) - call deallocate(stripped_positions) - - end subroutine adapt_mesh_simple - - subroutine strip_l2_halo(positions, metric, stripped_positions, stripped_metric) - ! strip level 2 halo from mesh before going into adapt so we don't unnecessarily lock - ! the halo 2 region (in addition to halo 1) - halo 2 regions will be regrown automatically - ! after repartioning in zoltan - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in):: metric - type(vector_field), intent(out) :: stripped_positions - type(tensor_field), intent(out):: stripped_metric - - type(mesh_type):: stripped_mesh, mesh - integer, dimension(:), pointer :: node_list, nodes - integer, dimension(:), allocatable :: non_halo2_elements - integer :: ele, j, non_halo2_count - - ewrite(1,*) "Inside strip_l2_halo" - - allocate(non_halo2_elements(1:element_count(positions))) - non_halo2_count = 0 - ele_loop: do ele=1, element_count(positions) - nodes => ele_nodes(positions, ele) - do j=1, size(nodes) - if (node_owned(positions, nodes(j))) then - non_halo2_count = non_halo2_count + 1 - non_halo2_elements(non_halo2_count) = ele - cycle ele_loop - end if - end do - end do ele_loop - - ! to avoid create_subdomain_mesh recreating a new halo 2 - ! temporarily take it away from the input positions%mesh - ! (create_sudomain_mesh would correctly recreate a halo2, but since - ! all halo2 nodes are stripped, it would end up being the same as halo 1) - ! the new element halos are recreated from the new nodal halo without - ! using those of the input positions%mesh - mesh = positions%mesh - ! since mesh is a copy of positons%mesh, we can change mesh%halos - ! without changing positions%mesh%halos - allocate(mesh%halos(1)) - mesh%halos(1)=positions%mesh%halos(1) - - call create_subdomain_mesh(mesh, non_halo2_elements(1:non_halo2_count), & - mesh%name, stripped_mesh, node_list) - - deallocate(mesh%halos) - - call allocate(stripped_positions, positions%dim, stripped_mesh, name=positions%name) - call allocate(stripped_metric, stripped_mesh, name=metric%name) - call set_all(stripped_positions, node_val(positions, node_list)) - call set_all(stripped_metric, node_val(metric, node_list)) - - call deallocate(stripped_mesh) - deallocate(node_list) - - ewrite(1,*) "Exiting strip_l2_halo" - - end subroutine strip_l2_halo - - subroutine adapt_mesh_periodic(old_positions, metric, new_positions, force_preserve_regions) - type(vector_field), intent(in) :: old_positions - type(tensor_field), intent(inout) :: metric - type(vector_field), intent(out) :: new_positions - logical, intent(in), optional :: force_preserve_regions - - ! Periodic adaptivity variables - integer :: no_bcs, bc, i, j, k, l - type(integer_set) :: lock_faces, surface_ids - type(vector_field) :: unwrapped_positions_A, unwrapped_positions_B, intermediate_positions - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: surface_id - type(tensor_field) :: unwrapped_metric_A, unwrapped_metric_B, intermediate_metric - integer :: stat - type(csr_sparsity), pointer :: eelist, nelist, periodic_eelist - type(scalar_field) :: front_field - integer :: ele, ele2, node, face - integer, dimension(:), pointer :: neighbours, eles, periodic_neighbours, neighbours2 - integer :: new_physical_colour, new_aliased_colour - integer :: face_count, existing_face_count - integer, dimension(:), allocatable :: sndgln, boundary_ids, element_owners, fnodes - integer :: floc - integer, dimension(:), allocatable :: physical_colours, aliased_colours - type(integer_set) :: nodes_to_move, periodic_nodes_to_move, extra_nodes_to_move - real, dimension(:,:), allocatable:: aliased_positions, physical_positions - character(len=OPTION_PATH_LEN) :: periodic_mapping_python - type(integer_hash_table) :: aliased_to_new_node_number - integer, dimension(:), pointer :: nodes, faces - real, dimension(:, :), allocatable :: tmp_bbox - type(integer_set) :: new_aliased_faces, new_physical_faces, old_physical_nodes - type(integer_set) :: front_contained_nodes, front_face_nodes - type(integer_set) :: other_surface_ids - integer :: dim, sid - - integer, save :: delete_me = 1 - - assert(mesh_periodic(metric)) - assert(all(metric%dim == old_positions%dim)) - dim = metric%dim(1) - - no_bcs = option_count(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions') - - intermediate_positions = old_positions - call incref(intermediate_positions) - - intermediate_metric = metric - call incref(metric) - - ! As written, this is quadratic in the number of boundary conditions. I'm not too stressed - ! about that - - do bc=0,no_bcs-1 - - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/physical_boundary_ids') - allocate(physical_colours(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/physical_boundary_ids', physical_colours) - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids') - allocate(aliased_colours(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids', aliased_colours) - - ! Step a). Unwrap the periodic input. - unwrapped_positions_A = make_mesh_unperiodic_from_options(intermediate_positions, trim(periodic_boundary_option_path(dim))) - call allocate(unwrapped_metric_A, unwrapped_positions_A%mesh, trim(metric%name)) - call remap_field(intermediate_metric, unwrapped_metric_A) - - ! We don't need the periodic mesh anymore - call deallocate(intermediate_positions) - call deallocate(intermediate_metric) + type(vector_field), intent(in) :: old_positions + type(tensor_field), intent(in) :: metric + type(vector_field) :: stripped_positions + type(tensor_field) :: stripped_metric + type(vector_field), intent(out) :: new_positions + integer, dimension(:), pointer, optional :: node_ownership + logical, intent(in), optional :: force_preserve_regions + type(integer_set), intent(in), optional :: lock_faces + logical, intent(in), optional :: allow_boundary_elements + type(vector_field) :: expanded_positions + + assert(.not. mesh_periodic(old_positions)) - ! Step b). Collect all the faces that need to be locked through the adapt - call allocate(lock_faces) - call allocate(surface_ids) - call allocate(other_surface_ids) - - ! Collect all the relevant surface labels - do j=0,no_bcs-1 - ! Physical ... - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids') - allocate(surface_id(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids', surface_id) - call insert(surface_ids, surface_id) - if (j /= bc) then - call insert(other_surface_ids, surface_id) - end if - deallocate(surface_id) - - ! and aliased - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids') - allocate(surface_id(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids', surface_id) - call insert(surface_ids, surface_id) - if (j /= bc) then - call insert(other_surface_ids, surface_id) - end if - deallocate(surface_id) - end do + if(isparallel()) then + ! generate stripped versions of the position and metric fields + call strip_l2_halo(old_positions, metric, stripped_positions, stripped_metric) + else + stripped_positions = old_positions + stripped_metric = metric + call incref(stripped_positions) + call incref(stripped_metric) + end if - ! With the relevant surface labels, loop through the mesh and fetch the information from them - do j=1,surface_element_count(unwrapped_positions_A) - if (has_value(surface_ids, surface_element_id(unwrapped_positions_A, j))) then - call insert(lock_faces, j) - end if - end do - call deallocate(surface_ids) + select case(stripped_positions%dim) + case(1) + call adapt_mesh_1d(stripped_positions, stripped_metric, new_positions, & + & node_ownership = node_ownership, force_preserve_regions = force_preserve_regions) + case(2) + call adapt_mesh_mba2d(stripped_positions, stripped_metric, new_positions, & + & force_preserve_regions=force_preserve_regions, lock_faces=lock_faces, & + & allow_boundary_elements=allow_boundary_elements) + case(3) + if(have_option("/mesh_adaptivity/hr_adaptivity/adaptivity_library/libmba3d")) then + assert(.not. present(lock_faces)) + call adapt_mesh_mba3d(stripped_positions, stripped_metric, new_positions, & + force_preserve_regions=force_preserve_regions) + else + call adapt_mesh_3d(stripped_positions, stripped_metric, new_positions, & + force_preserve_regions=force_preserve_regions, lock_faces=lock_faces) + end if + case default + FLAbort("Mesh adaptivity requires a 1D, 2D or 3D mesh") + end select - ! Step c). Adapt the mesh, locking appropriately, and interpolate the metric - ! mesh_0: incoming unwrapped mesh - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 0, position=unwrapped_positions_A, model=unwrapped_positions_A%mesh) - call vtk_write_surface_mesh("surface", 0, unwrapped_positions_A) - end if - call adapt_mesh_simple(unwrapped_positions_A, unwrapped_metric_A, unwrapped_positions_B, & - & force_preserve_regions=force_preserve_regions, & - & lock_faces=lock_faces, allow_boundary_elements=.true.) - ! mesh_1: first adapted mesh - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 1, position=unwrapped_positions_B, model=unwrapped_positions_B%mesh) - call vtk_write_surface_mesh("surface", 1, unwrapped_positions_B) - end if - call allocate(unwrapped_metric_B, unwrapped_positions_B%mesh, trim(metric%name)) - call linear_interpolation(unwrapped_metric_A, unwrapped_positions_A, unwrapped_metric_B, unwrapped_positions_B) - call deallocate(lock_faces) - call deallocate(unwrapped_positions_A) - call deallocate(unwrapped_metric_A) - - ! Step d). Reperiodise - intermediate_positions = make_mesh_periodic_from_options(unwrapped_positions_B, periodic_boundary_option_path(dim)) - intermediate_positions%mesh%name = "TmpMesh" - intermediate_positions%mesh%option_path = periodic_boundary_option_path(dim) - - call allocate(intermediate_metric, intermediate_positions%mesh, trim(metric%name)) - call remap_field(unwrapped_metric_B, intermediate_metric, stat=stat) - assert(stat /= REMAP_ERR_DISCONTINUOUS_CONTINUOUS) - assert(stat /= REMAP_ERR_HIGHER_LOWER_CONTINUOUS) - ! mesh_2: first adapted mesh, periodised - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 2, position=intermediate_positions, model=intermediate_positions%mesh) - call vtk_write_surface_mesh("surface", 2, intermediate_positions) + if(isparallel()) then + expanded_positions = expand_positions_halo(new_positions) + call deallocate(new_positions) + new_positions = expanded_positions end if - ! Step e). Advance a front in the new mesh using the unwrapped nelist from the aliased boundary - ! until the front contains no nodes on the boundary; this forms the new cut - nelist => extract_nelist(unwrapped_positions_B) - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids') - allocate(surface_id(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids', surface_id) - - call allocate(nodes_to_move) - call allocate(periodic_nodes_to_move) - ! start from the nodes on the aliased boundary - do j=1,surface_element_count(unwrapped_positions_B) - if (any(surface_id == surface_element_id(unwrapped_positions_B, j))) then - call insert(nodes_to_move, face_global_nodes(unwrapped_positions_B, j)) - call insert(periodic_nodes_to_move, face_global_nodes(intermediate_positions, j)) - end if - end do - deallocate(surface_id) - - ! if any nodes on the other periodic are in the elements directly - ! adjacent move them too - if (key_count(other_surface_ids)>0) then - call allocate(extra_nodes_to_move) - do i=1, key_count(nodes_to_move) - node = fetch(nodes_to_move, i) - neighbours => row_m_ptr(nelist, node) - do j=1, size(neighbours) - ele = neighbours(j) - faces => ele_faces(unwrapped_positions_B, ele) - do k=1, size(faces) - face = faces(k) - if (face>surface_element_count(unwrapped_positions_B)) cycle - sid = surface_element_id(unwrapped_positions_B, face) - if (has_value(other_surface_ids, sid)) then - call insert(nodes_to_move, face_global_nodes(unwrapped_positions_B, face)) - ! work out face on the other side - periodic_neighbours => ele_neigh(intermediate_positions, ele) - face = ele_face(intermediate_positions, periodic_neighbours(k), ele) - call insert(extra_nodes_to_move, face_global_nodes(unwrapped_positions_B, face)) - end if + ! deallocate stripped metric and positions - we don't need these anymore + call deallocate(stripped_metric) + call deallocate(stripped_positions) + + end subroutine adapt_mesh_simple + + subroutine strip_l2_halo(positions, metric, stripped_positions, stripped_metric) + ! strip level 2 halo from mesh before going into adapt so we don't unnecessarily lock + ! the halo 2 region (in addition to halo 1) - halo 2 regions will be regrown automatically + ! after repartioning in zoltan + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in):: metric + type(vector_field), intent(out) :: stripped_positions + type(tensor_field), intent(out):: stripped_metric + + type(mesh_type):: stripped_mesh, mesh + integer, dimension(:), pointer :: node_list, nodes + integer, dimension(:), allocatable :: non_halo2_elements + integer :: ele, j, non_halo2_count + + ewrite(1,*) "Inside strip_l2_halo" + + allocate(non_halo2_elements(1:element_count(positions))) + non_halo2_count = 0 + ele_loop: do ele=1, element_count(positions) + nodes => ele_nodes(positions, ele) + do j=1, size(nodes) + if (node_owned(positions, nodes(j))) then + non_halo2_count = non_halo2_count + 1 + non_halo2_elements(non_halo2_count) = ele + cycle ele_loop + end if + end do + end do ele_loop + + ! to avoid create_subdomain_mesh recreating a new halo 2 + ! temporarily take it away from the input positions%mesh + ! (create_sudomain_mesh would correctly recreate a halo2, but since + ! all halo2 nodes are stripped, it would end up being the same as halo 1) + ! the new element halos are recreated from the new nodal halo without + ! using those of the input positions%mesh + mesh = positions%mesh + ! since mesh is a copy of positons%mesh, we can change mesh%halos + ! without changing positions%mesh%halos + allocate(mesh%halos(1)) + mesh%halos(1)=positions%mesh%halos(1) + + call create_subdomain_mesh(mesh, non_halo2_elements(1:non_halo2_count), & + mesh%name, stripped_mesh, node_list) + + deallocate(mesh%halos) + + call allocate(stripped_positions, positions%dim, stripped_mesh, name=positions%name) + call allocate(stripped_metric, stripped_mesh, name=metric%name) + call set_all(stripped_positions, node_val(positions, node_list)) + call set_all(stripped_metric, node_val(metric, node_list)) + + call deallocate(stripped_mesh) + deallocate(node_list) + + ewrite(1,*) "Exiting strip_l2_halo" + + end subroutine strip_l2_halo + + subroutine adapt_mesh_periodic(old_positions, metric, new_positions, force_preserve_regions) + type(vector_field), intent(in) :: old_positions + type(tensor_field), intent(inout) :: metric + type(vector_field), intent(out) :: new_positions + logical, intent(in), optional :: force_preserve_regions + + ! Periodic adaptivity variables + integer :: no_bcs, bc, i, j, k, l + type(integer_set) :: lock_faces, surface_ids + type(vector_field) :: unwrapped_positions_A, unwrapped_positions_B, intermediate_positions + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: surface_id + type(tensor_field) :: unwrapped_metric_A, unwrapped_metric_B, intermediate_metric + integer :: stat + type(csr_sparsity), pointer :: eelist, nelist, periodic_eelist + type(scalar_field) :: front_field + integer :: ele, ele2, node, face + integer, dimension(:), pointer :: neighbours, eles, periodic_neighbours, neighbours2 + integer :: new_physical_colour, new_aliased_colour + integer :: face_count, existing_face_count + integer, dimension(:), allocatable :: sndgln, boundary_ids, element_owners, fnodes + integer :: floc + integer, dimension(:), allocatable :: physical_colours, aliased_colours + type(integer_set) :: nodes_to_move, periodic_nodes_to_move, extra_nodes_to_move + real, dimension(:,:), allocatable:: aliased_positions, physical_positions + character(len=OPTION_PATH_LEN) :: periodic_mapping_python + type(integer_hash_table) :: aliased_to_new_node_number + integer, dimension(:), pointer :: nodes, faces + real, dimension(:, :), allocatable :: tmp_bbox + type(integer_set) :: new_aliased_faces, new_physical_faces, old_physical_nodes + type(integer_set) :: front_contained_nodes, front_face_nodes + type(integer_set) :: other_surface_ids + integer :: dim, sid + + integer, save :: delete_me = 1 + + assert(mesh_periodic(metric)) + assert(all(metric%dim == old_positions%dim)) + dim = metric%dim(1) + + no_bcs = option_count(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions') + + intermediate_positions = old_positions + call incref(intermediate_positions) + + intermediate_metric = metric + call incref(metric) + + ! As written, this is quadratic in the number of boundary conditions. I'm not too stressed + ! about that + + do bc=0,no_bcs-1 + + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/physical_boundary_ids') + allocate(physical_colours(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/physical_boundary_ids', physical_colours) + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids') + allocate(aliased_colours(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids', aliased_colours) + + ! Step a). Unwrap the periodic input. + unwrapped_positions_A = make_mesh_unperiodic_from_options(intermediate_positions, trim(periodic_boundary_option_path(dim))) + call allocate(unwrapped_metric_A, unwrapped_positions_A%mesh, trim(metric%name)) + call remap_field(intermediate_metric, unwrapped_metric_A) + + ! We don't need the periodic mesh anymore + call deallocate(intermediate_positions) + call deallocate(intermediate_metric) + + ! Step b). Collect all the faces that need to be locked through the adapt + call allocate(lock_faces) + call allocate(surface_ids) + call allocate(other_surface_ids) + + ! Collect all the relevant surface labels + do j=0,no_bcs-1 + ! Physical ... + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids') + allocate(surface_id(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids', surface_id) + call insert(surface_ids, surface_id) + if (j /= bc) then + call insert(other_surface_ids, surface_id) + end if + deallocate(surface_id) + + ! and aliased + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids') + allocate(surface_id(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids', surface_id) + call insert(surface_ids, surface_id) + if (j /= bc) then + call insert(other_surface_ids, surface_id) + end if + deallocate(surface_id) + end do + + ! With the relevant surface labels, loop through the mesh and fetch the information from them + do j=1,surface_element_count(unwrapped_positions_A) + if (has_value(surface_ids, surface_element_id(unwrapped_positions_A, j))) then + call insert(lock_faces, j) + end if + end do + call deallocate(surface_ids) + + ! Step c). Adapt the mesh, locking appropriately, and interpolate the metric + ! mesh_0: incoming unwrapped mesh + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 0, position=unwrapped_positions_A, model=unwrapped_positions_A%mesh) + call vtk_write_surface_mesh("surface", 0, unwrapped_positions_A) + end if + call adapt_mesh_simple(unwrapped_positions_A, unwrapped_metric_A, unwrapped_positions_B, & + & force_preserve_regions=force_preserve_regions, & + & lock_faces=lock_faces, allow_boundary_elements=.true.) + ! mesh_1: first adapted mesh + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 1, position=unwrapped_positions_B, model=unwrapped_positions_B%mesh) + call vtk_write_surface_mesh("surface", 1, unwrapped_positions_B) + end if + call allocate(unwrapped_metric_B, unwrapped_positions_B%mesh, trim(metric%name)) + call linear_interpolation(unwrapped_metric_A, unwrapped_positions_A, unwrapped_metric_B, unwrapped_positions_B) + call deallocate(lock_faces) + call deallocate(unwrapped_positions_A) + call deallocate(unwrapped_metric_A) + + ! Step d). Reperiodise + intermediate_positions = make_mesh_periodic_from_options(unwrapped_positions_B, periodic_boundary_option_path(dim)) + intermediate_positions%mesh%name = "TmpMesh" + intermediate_positions%mesh%option_path = periodic_boundary_option_path(dim) + + call allocate(intermediate_metric, intermediate_positions%mesh, trim(metric%name)) + call remap_field(unwrapped_metric_B, intermediate_metric, stat=stat) + assert(stat /= REMAP_ERR_DISCONTINUOUS_CONTINUOUS) + assert(stat /= REMAP_ERR_HIGHER_LOWER_CONTINUOUS) + ! mesh_2: first adapted mesh, periodised + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 2, position=intermediate_positions, model=intermediate_positions%mesh) + call vtk_write_surface_mesh("surface", 2, intermediate_positions) + end if + + ! Step e). Advance a front in the new mesh using the unwrapped nelist from the aliased boundary + ! until the front contains no nodes on the boundary; this forms the new cut + nelist => extract_nelist(unwrapped_positions_B) + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids') + allocate(surface_id(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/aliased_boundary_ids', surface_id) + + call allocate(nodes_to_move) + call allocate(periodic_nodes_to_move) + ! start from the nodes on the aliased boundary + do j=1,surface_element_count(unwrapped_positions_B) + if (any(surface_id == surface_element_id(unwrapped_positions_B, j))) then + call insert(nodes_to_move, face_global_nodes(unwrapped_positions_B, j)) + call insert(periodic_nodes_to_move, face_global_nodes(intermediate_positions, j)) + end if + end do + deallocate(surface_id) + + ! if any nodes on the other periodic are in the elements directly + ! adjacent move them too + if (key_count(other_surface_ids)>0) then + call allocate(extra_nodes_to_move) + do i=1, key_count(nodes_to_move) + node = fetch(nodes_to_move, i) + neighbours => row_m_ptr(nelist, node) + do j=1, size(neighbours) + ele = neighbours(j) + faces => ele_faces(unwrapped_positions_B, ele) + do k=1, size(faces) + face = faces(k) + if (face>surface_element_count(unwrapped_positions_B)) cycle + sid = surface_element_id(unwrapped_positions_B, face) + if (has_value(other_surface_ids, sid)) then + call insert(nodes_to_move, face_global_nodes(unwrapped_positions_B, face)) + ! work out face on the other side + periodic_neighbours => ele_neigh(intermediate_positions, ele) + face = ele_face(intermediate_positions, periodic_neighbours(k), ele) + call insert(extra_nodes_to_move, face_global_nodes(unwrapped_positions_B, face)) + end if + end do + end do end do - end do - end do - call insert(nodes_to_move, set2vector(extra_nodes_to_move)) - call deallocate(extra_nodes_to_move) - end if + call insert(nodes_to_move, set2vector(extra_nodes_to_move)) + call deallocate(extra_nodes_to_move) + end if - ! the new cut now consists of the faces in the elements adjacent - ! to the nodes to move that are not in "nodes_to_move" itself - ! the nodes on the cut will in fact not be moved as they will retain - ! their aliased position in the periodic position field - call allocate(new_physical_faces) - call allocate(new_aliased_faces) - - do i=1, key_count(nodes_to_move) - node = fetch(nodes_to_move, i) - neighbours => row_m_ptr(nelist, node) - do j=1, size(neighbours) - ele = neighbours(j) - call insert(periodic_nodes_to_move, ele_nodes(intermediate_positions, ele)) - faces => ele_faces(unwrapped_positions_B, ele) - neighbours2 => ele_neigh(unwrapped_positions_B, ele) - do k=1, size(faces) - face = faces(k) - ele2 = neighbours2(k) - if (ele2<=0) cycle - if (.not. any(has_value(nodes_to_move,face_global_nodes(unwrapped_positions_B, face))) & - .and. .not. any(has_value(nodes_to_move,ele_nodes(unwrapped_positions_B, ele2))) & - ) then - call insert(new_physical_faces, face) - ! opposite face becomes aliased - face = ele_face(unwrapped_positions_B, ele2, ele) - call insert(new_aliased_faces, face) - end if - end do - end do - end do - call deallocate(nodes_to_move) - - ! don't want to move nodes on the new cut, as they'll retain - ! their original before-aliasing position - floc = face_loc(intermediate_positions, 1) - allocate(fnodes(1:floc)) - do j=1, key_count(new_physical_faces) - face = fetch(new_physical_faces, j) - fnodes = face_global_nodes(intermediate_positions, face) - do k=1, floc - node = fnodes(k) - if (has_value(periodic_nodes_to_move, node)) then - call remove(periodic_nodes_to_move, node) - end if - end do - end do - deallocate(fnodes) + ! the new cut now consists of the faces in the elements adjacent + ! to the nodes to move that are not in "nodes_to_move" itself + ! the nodes on the cut will in fact not be moved as they will retain + ! their aliased position in the periodic position field + call allocate(new_physical_faces) + call allocate(new_aliased_faces) + + do i=1, key_count(nodes_to_move) + node = fetch(nodes_to_move, i) + neighbours => row_m_ptr(nelist, node) + do j=1, size(neighbours) + ele = neighbours(j) + call insert(periodic_nodes_to_move, ele_nodes(intermediate_positions, ele)) + faces => ele_faces(unwrapped_positions_B, ele) + neighbours2 => ele_neigh(unwrapped_positions_B, ele) + do k=1, size(faces) + face = faces(k) + ele2 = neighbours2(k) + if (ele2<=0) cycle + if (.not. any(has_value(nodes_to_move,face_global_nodes(unwrapped_positions_B, face))) & + .and. .not. any(has_value(nodes_to_move,ele_nodes(unwrapped_positions_B, ele2))) & + ) then + call insert(new_physical_faces, face) + ! opposite face becomes aliased + face = ele_face(unwrapped_positions_B, ele2, ele) + call insert(new_aliased_faces, face) + end if + end do + end do + end do + call deallocate(nodes_to_move) + + ! don't want to move nodes on the new cut, as they'll retain + ! their original before-aliasing position + floc = face_loc(intermediate_positions, 1) + allocate(fnodes(1:floc)) + do j=1, key_count(new_physical_faces) + face = fetch(new_physical_faces, j) + fnodes = face_global_nodes(intermediate_positions, face) + do k=1, floc + node = fnodes(k) + if (has_value(periodic_nodes_to_move, node)) then + call remove(periodic_nodes_to_move, node) + end if + end do + end do + deallocate(fnodes) + + ! now move the nodes in the periodic positions field + allocate(aliased_positions(intermediate_positions%dim, key_count(periodic_nodes_to_move))) + allocate(physical_positions(intermediate_positions%dim, key_count(periodic_nodes_to_move))) + + do j=1,key_count(periodic_nodes_to_move) + node = fetch(periodic_nodes_to_move, j) + aliased_positions(:, j) = node_val(intermediate_positions, node) + end do + + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/coordinate_map', periodic_mapping_python) + call set_from_python_function(physical_positions, periodic_mapping_python, aliased_positions, time=0.0) + + do j=1,key_count(periodic_nodes_to_move) + node = fetch(periodic_nodes_to_move, j) + call set(intermediate_positions, node, physical_positions(:, j)) + end do + + deallocate(physical_positions) + deallocate(aliased_positions) + call deallocate(periodic_nodes_to_move) + + ! Step f). Colour those faces on either side of the new cut + + ! Choose a new colour that isn't used + new_physical_colour = maxval(physical_colours) + new_aliased_colour = maxval(aliased_colours) + ! the only forward-compatible way of doing this is to fetch the information from + ! the current faces into the primitive data structures, and then re-call add_faces + ! fixme: for mixed meshes + ! note well: we /lose/ the old faces, as we don't need that cut anymore + ! (and can't retain it through the adapt anyway) + + ! first things first: find out how many faces we have + face_count = key_count(new_physical_faces) + key_count(new_aliased_faces) + do j=1,surface_element_count(intermediate_positions) + if (.not. (any(surface_element_id(intermediate_positions, j) == physical_colours) .or. & + & any(surface_element_id(intermediate_positions, j) == aliased_colours))) then + face_count = face_count + 1 + end if + end do + + allocate(boundary_ids(face_count)) + allocate(element_owners(face_count)) + allocate(sndgln(face_count * floc)) + + ! fetch the existing information + l = 0 + do j=1,surface_element_count(intermediate_positions) + if (.not. (any(surface_element_id(intermediate_positions, j) == physical_colours) .or. & + & any(surface_element_id(intermediate_positions, j) == aliased_colours))) then + + l = l + 1 + boundary_ids(l) = surface_element_id(intermediate_positions, j) + element_owners(l) = face_ele(intermediate_positions, j) + sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, j) + end if + end do - ! now move the nodes in the periodic positions field - allocate(aliased_positions(intermediate_positions%dim, key_count(periodic_nodes_to_move))) - allocate(physical_positions(intermediate_positions%dim, key_count(periodic_nodes_to_move))) + ! and now fetch the information for the faces we are adding - do j=1,key_count(periodic_nodes_to_move) - node = fetch(periodic_nodes_to_move, j) - aliased_positions(:, j) = node_val(intermediate_positions, node) - end do + do j=1, key_count(new_physical_faces) + l = l + 1 + face = fetch(new_physical_faces, j) + boundary_ids(l) = new_physical_colour + element_owners(l) = face_ele(unwrapped_positions_B, face) + sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) + end do + call deallocate(new_physical_faces) + + do j=1, key_count(new_aliased_faces) + l = l + 1 + face = fetch(new_aliased_faces, j) + boundary_ids(l) = new_aliased_colour + element_owners(l) = face_ele(unwrapped_positions_B, face) + sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) + end do + call deallocate(new_aliased_faces) + + assert(l == face_count) + + ! deallocate the old faces, and rebuild + ! mesh_3: first adapted mesh, periodised with moving front nodes moved over + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 3, position=intermediate_positions, model=intermediate_positions%mesh) + call vtk_write_surface_mesh("surface", 3, intermediate_positions) + end if - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/coordinate_map', periodic_mapping_python) - call set_from_python_function(physical_positions, periodic_mapping_python, aliased_positions, time=0.0) + call deallocate_faces(intermediate_positions%mesh) + call add_faces(intermediate_positions%mesh, sndgln=sndgln, element_owner=element_owners, boundary_ids=boundary_ids) + intermediate_metric%mesh = intermediate_positions%mesh + ! mesh_4: first adapted mesh, periodised with moving front nodes moved over and surface mesh relabeled + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 4, position=intermediate_positions, model=intermediate_positions%mesh) + call vtk_write_surface_mesh("surface", 4, intermediate_positions) + end if - do j=1,key_count(periodic_nodes_to_move) - node = fetch(periodic_nodes_to_move, j) - call set(intermediate_positions, node, physical_positions(:, j)) - end do + deallocate(sndgln) + deallocate(element_owners) + deallocate(boundary_ids) - deallocate(physical_positions) - deallocate(aliased_positions) - call deallocate(periodic_nodes_to_move) - - ! Step f). Colour those faces on either side of the new cut - - ! Choose a new colour that isn't used - new_physical_colour = maxval(physical_colours) - new_aliased_colour = maxval(aliased_colours) - ! the only forward-compatible way of doing this is to fetch the information from - ! the current faces into the primitive data structures, and then re-call add_faces - ! fixme: for mixed meshes - ! note well: we /lose/ the old faces, as we don't need that cut anymore - ! (and can't retain it through the adapt anyway) - - ! first things first: find out how many faces we have - face_count = key_count(new_physical_faces) + key_count(new_aliased_faces) - do j=1,surface_element_count(intermediate_positions) - if (.not. (any(surface_element_id(intermediate_positions, j) == physical_colours) .or. & - & any(surface_element_id(intermediate_positions, j) == aliased_colours))) then - face_count = face_count + 1 - end if - end do + ! Step g). Unwrap again + ! We need to fiddle with the options tree to mark the aliased and physical surface IDs appropriately - allocate(boundary_ids(face_count)) - allocate(element_owners(face_count)) - allocate(sndgln(face_count * floc)) - - ! fetch the existing information - l = 0 - do j=1,surface_element_count(intermediate_positions) - if (.not. (any(surface_element_id(intermediate_positions, j) == physical_colours) .or. & - & any(surface_element_id(intermediate_positions, j) == aliased_colours))) then - - l = l + 1 - boundary_ids(l) = surface_element_id(intermediate_positions, j) - element_owners(l) = face_ele(intermediate_positions, j) - sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, j) - end if - end do + unwrapped_positions_A = make_mesh_unperiodic_from_options(intermediate_positions, trim(periodic_boundary_option_path(dim)), & + aliased_to_new_node_number=aliased_to_new_node_number, stat=stat) - ! and now fetch the information for the faces we are adding + ! mesh_5: adapted once, moved up, ready to adapt again + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 5, position=unwrapped_positions_A, model=unwrapped_positions_A%mesh) + call vtk_write_surface_mesh("surface", 5, unwrapped_positions_A) + end if - do j=1, key_count(new_physical_faces) - l = l + 1 - face = fetch(new_physical_faces, j) - boundary_ids(l) = new_physical_colour - element_owners(l) = face_ele(unwrapped_positions_B, face) - sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) - end do - call deallocate(new_physical_faces) - - do j=1, key_count(new_aliased_faces) - l = l + 1 - face = fetch(new_aliased_faces, j) - boundary_ids(l) = new_aliased_colour - element_owners(l) = face_ele(unwrapped_positions_B, face) - sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) - end do - call deallocate(new_aliased_faces) + call allocate(unwrapped_metric_A, unwrapped_positions_A%mesh, trim(metric%name)) + call remap_field(intermediate_metric, unwrapped_metric_A) - assert(l == face_count) + call deallocate(intermediate_positions) + call deallocate(intermediate_metric) - ! deallocate the old faces, and rebuild - ! mesh_3: first adapted mesh, periodised with moving front nodes moved over - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 3, position=intermediate_positions, model=intermediate_positions%mesh) - call vtk_write_surface_mesh("surface", 3, intermediate_positions) - end if + assert(has_faces(unwrapped_positions_A%mesh)) - call deallocate_faces(intermediate_positions%mesh) - call add_faces(intermediate_positions%mesh, sndgln=sndgln, element_owner=element_owners, boundary_ids=boundary_ids) - intermediate_metric%mesh = intermediate_positions%mesh - ! mesh_4: first adapted mesh, periodised with moving front nodes moved over and surface mesh relabeled - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 4, position=intermediate_positions, model=intermediate_positions%mesh) - call vtk_write_surface_mesh("surface", 4, intermediate_positions) - end if + call deallocate(unwrapped_positions_B) + call deallocate(unwrapped_metric_B) - deallocate(sndgln) - deallocate(element_owners) - deallocate(boundary_ids) + ! Step h). Adapt again - ! Step g). Unwrap again - ! We need to fiddle with the options tree to mark the aliased and physical surface IDs appropriately + call allocate(lock_faces) + call allocate(surface_ids) - unwrapped_positions_A = make_mesh_unperiodic_from_options(intermediate_positions, trim(periodic_boundary_option_path(dim)), & - aliased_to_new_node_number=aliased_to_new_node_number, stat=stat) + ! Collect all the relevant surface labels + do j=0,no_bcs-1 + ! Physical ... + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids') + allocate(surface_id(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids', surface_id) + call insert(surface_ids, surface_id) + deallocate(surface_id) - ! mesh_5: adapted once, moved up, ready to adapt again - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 5, position=unwrapped_positions_A, model=unwrapped_positions_A%mesh) - call vtk_write_surface_mesh("surface", 5, unwrapped_positions_A) - end if + ! and aliased + shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids') + allocate(surface_id(shape_option(1))) + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids', surface_id) + call insert(surface_ids, surface_id) + deallocate(surface_id) + end do - call allocate(unwrapped_metric_A, unwrapped_positions_A%mesh, trim(metric%name)) - call remap_field(intermediate_metric, unwrapped_metric_A) + ! With the relevant surface labels, loop through the mesh and fetch the information from them + do j=1,surface_element_count(unwrapped_positions_A) + if (has_value(surface_ids, surface_element_id(unwrapped_positions_A, j))) then + call insert(lock_faces, j) + end if + end do + call deallocate(surface_ids) + + call adapt_mesh_simple(unwrapped_positions_A, unwrapped_metric_A, unwrapped_positions_B, & + & force_preserve_regions=force_preserve_regions, & + & lock_faces=lock_faces, allow_boundary_elements=.true.) + call deallocate(lock_faces) + ! mesh_7: after second adapt + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 7, position=unwrapped_positions_B, model=unwrapped_positions_B%mesh) + call vtk_write_surface_mesh("surface", 7, unwrapped_positions_B) + end if - call deallocate(intermediate_positions) - call deallocate(intermediate_metric) + call allocate(unwrapped_metric_B, unwrapped_positions_B%mesh, trim(metric%name)) + call linear_interpolation(unwrapped_metric_A, unwrapped_positions_A, unwrapped_metric_B, unwrapped_positions_B) + call deallocate(unwrapped_positions_A) + call deallocate(unwrapped_metric_A) + + ! Step i). Reperiodise for the next go around! + intermediate_positions = make_mesh_periodic_from_options(unwrapped_positions_B, periodic_boundary_option_path(dim)) + intermediate_positions%mesh%option_path = periodic_boundary_option_path(dim) + call allocate(intermediate_metric, intermediate_positions%mesh, trim(metric%name)) + call remap_field(unwrapped_metric_B, intermediate_metric, stat=stat) + assert(stat /= REMAP_ERR_DISCONTINUOUS_CONTINUOUS) + assert(stat /= REMAP_ERR_HIGHER_LOWER_CONTINUOUS) + + ! Step j). If the user has specified an inverse coordinate map, then let's loop through the nodes in the mesh + ! and map them back to inside the bounding box of the domain + if (have_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map')) then + + ! nodes_to_move stores the potential nodes to map. + ! The rule is: we map any element which contains any node such that: + ! the node's location is not inside the original bounding box, and + ! the image of the node under the inverse mapping is inside the original bounding box + + ! So first let's find the nodes outside the bounding box + call allocate(nodes_to_move) + allocate(tmp_bbox(unwrapped_positions_B%dim, 2)) + do j=1, node_count(unwrapped_positions_B) + tmp_bbox(:, 1) = node_val(unwrapped_positions_B, j) + tmp_bbox(:, 2) = node_val(unwrapped_positions_B, j) + if (.not. bbox_predicate(domain_bbox(1:unwrapped_positions_B%dim, :), tmp_bbox)) then + call insert(nodes_to_move, j) + end if + end do - assert(has_faces(unwrapped_positions_A%mesh)) + allocate(aliased_positions(intermediate_positions%dim, key_count(nodes_to_move))) + allocate(physical_positions(intermediate_positions%dim, key_count(nodes_to_move))) - call deallocate(unwrapped_positions_B) - call deallocate(unwrapped_metric_B) + do j=1,key_count(nodes_to_move) + physical_positions(:, j) = node_val(unwrapped_positions_B, fetch(nodes_to_move, j)) + end do - ! Step h). Adapt again + ! and map those nodes + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map', periodic_mapping_python) + call set_from_python_function(aliased_positions, periodic_mapping_python, physical_positions, time=0.0) + + ! now let's loop through those nodes, and if the image is inside the bounding box, mark + ! the elements to map + front_field = piecewise_constant_field(intermediate_positions%mesh, "AdvancingFront") + call zero(front_field) + nelist => extract_nelist(unwrapped_positions_B) + eelist => extract_eelist(unwrapped_positions_B) + periodic_eelist => extract_eelist(intermediate_positions) + + do j=1,key_count(nodes_to_move) + tmp_bbox(:, 1) = aliased_positions(:, j) + tmp_bbox(:, 2) = aliased_positions(:, j) + if (bbox_predicate(domain_bbox(1:unwrapped_positions_B%dim, :), tmp_bbox)) then + eles => row_m_ptr(nelist, fetch(nodes_to_move, j)) + do k=1,size(eles) + call set(front_field, eles(k), 1.0) + end do + end if + end do - call allocate(lock_faces) - call allocate(surface_ids) + deallocate(physical_positions) + deallocate(aliased_positions) + call deallocate(nodes_to_move) + deallocate(tmp_bbox) + + ! For doubly periodic, we need to make sure that the front is "periodic" in some sense. + ! Otherwise, bad things can happen where the node on one side of the other BC wants to be + ! mapped, but the other node doesn't, and there's no consistent solution. + do ele=1,ele_count(front_field) + if (node_val(front_field, ele) == 1.0) then + neighbours => ele_neigh(intermediate_positions, ele) + do j=1,size(neighbours) + face = ele_face(intermediate_positions, ele, neighbours(j)) + if (face > surface_element_count(intermediate_positions)) cycle + if (has_value(other_surface_ids, surface_element_id(intermediate_positions, face))) then + call set(front_field, neighbours(j), 1.0) + end if + end do + end if + end do - ! Collect all the relevant surface labels - do j=0,no_bcs-1 - ! Physical ... - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids') - allocate(surface_id(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/physical_boundary_ids', surface_id) - call insert(surface_ids, surface_id) - deallocate(surface_id) + ! mesh_8: after second adapt, showing elements to be moved back into bounding box + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 8, position=unwrapped_positions_B, model=unwrapped_positions_B%mesh, sfields=(/front_field/)) + call vtk_write_surface_mesh("surface", 8, unwrapped_positions_B) + end if - ! and aliased - shape_option = option_shape(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids') - allocate(surface_id(shape_option(1))) - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(j)//']/aliased_boundary_ids', surface_id) - call insert(surface_ids, surface_id) - deallocate(surface_id) - end do + ! mesh_8: same thing periodised + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 9, position=intermediate_positions, model=intermediate_positions%mesh, sfields=(/front_field/)) + call vtk_write_surface_mesh("surface", 9, intermediate_positions) + end if - ! With the relevant surface labels, loop through the mesh and fetch the information from them - do j=1,surface_element_count(unwrapped_positions_A) - if (has_value(surface_ids, surface_element_id(unwrapped_positions_A, j))) then - call insert(lock_faces, j) - end if - end do - call deallocate(surface_ids) + ! OK. Now we know which elements we are mapping, it is very similar to the shuffling + ! around we did earlier. The two main subtasks are to + ! a) update the positions of the periodic nodes appropriately + ! b) change the faces of the periodic mesh + + ! First thing: let's build two sets + ! that store the current lists of physical and aliased faces. + + call allocate(new_aliased_faces) + call allocate(new_physical_faces) + call allocate(old_physical_nodes) + existing_face_count = 0 + do j=1,surface_element_count(intermediate_positions) + if (surface_element_id(intermediate_positions, j) == new_physical_colour) then + call insert(new_physical_faces, j) + call insert(old_physical_nodes, face_global_nodes(intermediate_positions, j)) + else if (surface_element_id(intermediate_positions, j) == new_aliased_colour) then + call insert(new_aliased_faces, j) + else + existing_face_count = existing_face_count + 1 + end if + end do - call adapt_mesh_simple(unwrapped_positions_A, unwrapped_metric_A, unwrapped_positions_B, & - & force_preserve_regions=force_preserve_regions, & - & lock_faces=lock_faces, allow_boundary_elements=.true.) - call deallocate(lock_faces) - ! mesh_7: after second adapt - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 7, position=unwrapped_positions_B, model=unwrapped_positions_B%mesh) - call vtk_write_surface_mesh("surface", 7, unwrapped_positions_B) - end if + call allocate(front_contained_nodes) + call allocate(front_face_nodes) + do ele=1,ele_count(front_field) + if (node_val(front_field, ele) == 1.0) then + call insert(front_contained_nodes, ele_nodes(intermediate_positions, ele)) + neighbours => row_m_ptr(eelist, ele) + periodic_neighbours => row_m_ptr(periodic_eelist, ele) + faces => ele_faces(intermediate_positions, ele) + neighbourloop: do k=1,size(neighbours) + j = neighbours(k) + face = faces(k) + + if (has_value(new_physical_faces, face)) then + call insert(front_face_nodes, face_global_nodes(intermediate_positions, face)) + call remove(new_physical_faces, face) + call remove(new_aliased_faces, ele_face(intermediate_positions, periodic_neighbours(k), ele)) + end if + + if (j > 0) then + if (node_val(front_field, j) /= 1.0) then + face = ele_face(intermediate_positions, ele, j) + call insert(new_aliased_faces, face) + + face = ele_face(intermediate_positions, j, ele) + call insert(new_physical_faces, face) + end if + end if + + end do neighbourloop + + nodes => ele_nodes(intermediate_positions, ele) + do k=1,size(nodes) + if (has_value(old_physical_nodes, nodes(k))) then + call insert(front_face_nodes, nodes(k)) + end if + end do - call allocate(unwrapped_metric_B, unwrapped_positions_B%mesh, trim(metric%name)) - call linear_interpolation(unwrapped_metric_A, unwrapped_positions_A, unwrapped_metric_B, unwrapped_positions_B) - call deallocate(unwrapped_positions_A) - call deallocate(unwrapped_metric_A) - - ! Step i). Reperiodise for the next go around! - intermediate_positions = make_mesh_periodic_from_options(unwrapped_positions_B, periodic_boundary_option_path(dim)) - intermediate_positions%mesh%option_path = periodic_boundary_option_path(dim) - call allocate(intermediate_metric, intermediate_positions%mesh, trim(metric%name)) - call remap_field(unwrapped_metric_B, intermediate_metric, stat=stat) - assert(stat /= REMAP_ERR_DISCONTINUOUS_CONTINUOUS) - assert(stat /= REMAP_ERR_HIGHER_LOWER_CONTINUOUS) - - ! Step j). If the user has specified an inverse coordinate map, then let's loop through the nodes in the mesh - ! and map them back to inside the bounding box of the domain - if (have_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map')) then - - ! nodes_to_move stores the potential nodes to map. - ! The rule is: we map any element which contains any node such that: - ! the node's location is not inside the original bounding box, and - ! the image of the node under the inverse mapping is inside the original bounding box - - ! So first let's find the nodes outside the bounding box - call allocate(nodes_to_move) - allocate(tmp_bbox(unwrapped_positions_B%dim, 2)) - do j=1, node_count(unwrapped_positions_B) - tmp_bbox(:, 1) = node_val(unwrapped_positions_B, j) - tmp_bbox(:, 2) = node_val(unwrapped_positions_B, j) - if (.not. bbox_predicate(domain_bbox(1:unwrapped_positions_B%dim, :), tmp_bbox)) then - call insert(nodes_to_move, j) - end if - end do - - allocate(aliased_positions(intermediate_positions%dim, key_count(nodes_to_move))) - allocate(physical_positions(intermediate_positions%dim, key_count(nodes_to_move))) - - do j=1,key_count(nodes_to_move) - physical_positions(:, j) = node_val(unwrapped_positions_B, fetch(nodes_to_move, j)) - end do - - ! and map those nodes - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map', periodic_mapping_python) - call set_from_python_function(aliased_positions, periodic_mapping_python, physical_positions, time=0.0) - - ! now let's loop through those nodes, and if the image is inside the bounding box, mark - ! the elements to map - front_field = piecewise_constant_field(intermediate_positions%mesh, "AdvancingFront") - call zero(front_field) - nelist => extract_nelist(unwrapped_positions_B) - eelist => extract_eelist(unwrapped_positions_B) - periodic_eelist => extract_eelist(intermediate_positions) - - do j=1,key_count(nodes_to_move) - tmp_bbox(:, 1) = aliased_positions(:, j) - tmp_bbox(:, 2) = aliased_positions(:, j) - if (bbox_predicate(domain_bbox(1:unwrapped_positions_B%dim, :), tmp_bbox)) then - eles => row_m_ptr(nelist, fetch(nodes_to_move, j)) - do k=1,size(eles) - call set(front_field, eles(k), 1.0) + end if end do - end if - end do - - deallocate(physical_positions) - deallocate(aliased_positions) - call deallocate(nodes_to_move) - deallocate(tmp_bbox) - - ! For doubly periodic, we need to make sure that the front is "periodic" in some sense. - ! Otherwise, bad things can happen where the node on one side of the other BC wants to be - ! mapped, but the other node doesn't, and there's no consistent solution. - do ele=1,ele_count(front_field) - if (node_val(front_field, ele) == 1.0) then - neighbours => ele_neigh(intermediate_positions, ele) - do j=1,size(neighbours) - face = ele_face(intermediate_positions, ele, neighbours(j)) - if (face > surface_element_count(intermediate_positions)) cycle - if (has_value(other_surface_ids, surface_element_id(intermediate_positions, face))) then - call set(front_field, neighbours(j), 1.0) - end if + + call deallocate(old_physical_nodes) + + ! Now pack into the primitive data structures + + allocate(boundary_ids(existing_face_count + 2 * key_count(new_physical_faces))) + allocate(element_owners(existing_face_count + 2 * key_count(new_physical_faces))) + allocate(sndgln(floc * (existing_face_count + 2 * key_count(new_physical_faces)))) + + l = 1 + do j=1,surface_element_count(intermediate_positions) + if (surface_element_id(intermediate_positions, j) == new_physical_colour) then + cycle + else if (surface_element_id(intermediate_positions, j) == new_aliased_colour) then + cycle + else + boundary_ids(l) = surface_element_id(intermediate_positions, j) + element_owners(l) = face_ele(intermediate_positions, j) + sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, j) + l = l + 1 + end if end do - end if - end do - - ! mesh_8: after second adapt, showing elements to be moved back into bounding box - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 8, position=unwrapped_positions_B, model=unwrapped_positions_B%mesh, sfields=(/front_field/)) - call vtk_write_surface_mesh("surface", 8, unwrapped_positions_B) - end if - - ! mesh_8: same thing periodised - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 9, position=intermediate_positions, model=intermediate_positions%mesh, sfields=(/front_field/)) - call vtk_write_surface_mesh("surface", 9, intermediate_positions) - end if - - ! OK. Now we know which elements we are mapping, it is very similar to the shuffling - ! around we did earlier. The two main subtasks are to - ! a) update the positions of the periodic nodes appropriately - ! b) change the faces of the periodic mesh - - ! First thing: let's build two sets - ! that store the current lists of physical and aliased faces. - - call allocate(new_aliased_faces) - call allocate(new_physical_faces) - call allocate(old_physical_nodes) - existing_face_count = 0 - do j=1,surface_element_count(intermediate_positions) - if (surface_element_id(intermediate_positions, j) == new_physical_colour) then - call insert(new_physical_faces, j) - call insert(old_physical_nodes, face_global_nodes(intermediate_positions, j)) - else if (surface_element_id(intermediate_positions, j) == new_aliased_colour) then - call insert(new_aliased_faces, j) - else - existing_face_count = existing_face_count + 1 - end if - end do - - call allocate(front_contained_nodes) - call allocate(front_face_nodes) - do ele=1,ele_count(front_field) - if (node_val(front_field, ele) == 1.0) then - call insert(front_contained_nodes, ele_nodes(intermediate_positions, ele)) - neighbours => row_m_ptr(eelist, ele) - periodic_neighbours => row_m_ptr(periodic_eelist, ele) - faces => ele_faces(intermediate_positions, ele) - neighbourloop: do k=1,size(neighbours) - j = neighbours(k) - face = faces(k) - - if (has_value(new_physical_faces, face)) then - call insert(front_face_nodes, face_global_nodes(intermediate_positions, face)) - call remove(new_physical_faces, face) - call remove(new_aliased_faces, ele_face(intermediate_positions, periodic_neighbours(k), ele)) - end if - - if (j > 0) then - if (node_val(front_field, j) /= 1.0) then - face = ele_face(intermediate_positions, ele, j) - call insert(new_aliased_faces, face) - - face = ele_face(intermediate_positions, j, ele) - call insert(new_physical_faces, face) - end if - end if - - end do neighbourloop - - nodes => ele_nodes(intermediate_positions, ele) - do k=1,size(nodes) - if (has_value(old_physical_nodes, nodes(k))) then - call insert(front_face_nodes, nodes(k)) - end if + assert(l == existing_face_count + 1) + + do j=1,key_count(new_physical_faces) + face = fetch(new_physical_faces, j) + boundary_ids(l) = new_physical_colour + element_owners(l) = face_ele(intermediate_positions, face) + sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) + l = l + 1 + + face = fetch(new_aliased_faces, j) + boundary_ids(l) = new_aliased_colour + element_owners(l) = face_ele(intermediate_positions, face) + sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) + l = l + 1 end do + assert(l == size(boundary_ids) + 1) + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_internal_face_mesh("surface", 11, unwrapped_positions_B, face_sets=(/new_physical_faces, new_aliased_faces/)) + end if + assert(key_count(new_physical_faces) == key_count(new_aliased_faces)) - end if - end do + call deallocate(new_physical_faces) + call deallocate(new_aliased_faces) - call deallocate(old_physical_nodes) - ! Now pack into the primitive data structures + ! deallocate the old faces, and rebuild + call deallocate_faces(intermediate_positions%mesh) + call add_faces(intermediate_positions%mesh, sndgln=sndgln, element_owner=element_owners, boundary_ids=boundary_ids) + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_surface_mesh("surface", 12, intermediate_positions) + end if - allocate(boundary_ids(existing_face_count + 2 * key_count(new_physical_faces))) - allocate(element_owners(existing_face_count + 2 * key_count(new_physical_faces))) - allocate(sndgln(floc * (existing_face_count + 2 * key_count(new_physical_faces)))) + intermediate_metric%mesh = intermediate_positions%mesh + deallocate(sndgln) + deallocate(element_owners) + deallocate(boundary_ids) - l = 1 - do j=1,surface_element_count(intermediate_positions) - if (surface_element_id(intermediate_positions, j) == new_physical_colour) then - cycle - else if (surface_element_id(intermediate_positions, j) == new_aliased_colour) then - cycle - else - boundary_ids(l) = surface_element_id(intermediate_positions, j) - element_owners(l) = face_ele(intermediate_positions, j) - sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, j) - l = l + 1 - end if - end do - assert(l == existing_face_count + 1) - - do j=1,key_count(new_physical_faces) - face = fetch(new_physical_faces, j) - boundary_ids(l) = new_physical_colour - element_owners(l) = face_ele(intermediate_positions, face) - sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) - l = l + 1 - - face = fetch(new_aliased_faces, j) - boundary_ids(l) = new_aliased_colour - element_owners(l) = face_ele(intermediate_positions, face) - sndgln( (l-1)*floc + 1:l*floc ) = face_global_nodes(intermediate_positions, face) - l = l + 1 - end do - assert(l == size(boundary_ids) + 1) - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_internal_face_mesh("surface", 11, unwrapped_positions_B, face_sets=(/new_physical_faces, new_aliased_faces/)) - end if - assert(key_count(new_physical_faces) == key_count(new_aliased_faces)) - - call deallocate(new_physical_faces) - call deallocate(new_aliased_faces) - - - ! deallocate the old faces, and rebuild - call deallocate_faces(intermediate_positions%mesh) - call add_faces(intermediate_positions%mesh, sndgln=sndgln, element_owner=element_owners, boundary_ids=boundary_ids) - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_surface_mesh("surface", 12, intermediate_positions) - end if - - intermediate_metric%mesh = intermediate_positions%mesh - deallocate(sndgln) - deallocate(element_owners) - deallocate(boundary_ids) - - call set_minus(nodes_to_move, front_contained_nodes, front_face_nodes) - call deallocate(front_contained_nodes) - call deallocate(front_face_nodes) - - allocate(aliased_positions(intermediate_positions%dim, key_count(nodes_to_move))) - allocate(physical_positions(intermediate_positions%dim, key_count(nodes_to_move))) - - do j=1,key_count(nodes_to_move) - physical_positions(:, j) = node_val(intermediate_positions, fetch(nodes_to_move, j)) - end do - - call set_from_python_function(aliased_positions, periodic_mapping_python, physical_positions, time=0.0) - - allocate(tmp_bbox(intermediate_positions%dim, 2)) - do j=1,key_count(nodes_to_move) - tmp_bbox(:, 1) = aliased_positions(:, j) - tmp_bbox(:, 2) = aliased_positions(:, j) - call set(intermediate_positions, fetch(nodes_to_move, j), aliased_positions(:, j)) - end do - deallocate(tmp_bbox) - - deallocate(physical_positions) - deallocate(aliased_positions) - call deallocate(nodes_to_move) - - call deallocate(front_field) - end if + call set_minus(nodes_to_move, front_contained_nodes, front_face_nodes) + call deallocate(front_contained_nodes) + call deallocate(front_face_nodes) - call deallocate(unwrapped_positions_B) - call deallocate(unwrapped_metric_B) + allocate(aliased_positions(intermediate_positions%dim, key_count(nodes_to_move))) + allocate(physical_positions(intermediate_positions%dim, key_count(nodes_to_move))) - deallocate(physical_colours) - deallocate(aliased_colours) + do j=1,key_count(nodes_to_move) + physical_positions(:, j) = node_val(intermediate_positions, fetch(nodes_to_move, j)) + end do - ! mesh_10: final mesh - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("mesh", 10, position=intermediate_positions, model=intermediate_positions%mesh) - call vtk_write_surface_mesh("surface", 10, intermediate_positions) - end if + call set_from_python_function(aliased_positions, periodic_mapping_python, physical_positions, time=0.0) + + allocate(tmp_bbox(intermediate_positions%dim, 2)) + do j=1,key_count(nodes_to_move) + tmp_bbox(:, 1) = aliased_positions(:, j) + tmp_bbox(:, 2) = aliased_positions(:, j) + call set(intermediate_positions, fetch(nodes_to_move, j), aliased_positions(:, j)) + end do + deallocate(tmp_bbox) + + deallocate(physical_positions) + deallocate(aliased_positions) + call deallocate(nodes_to_move) - call deallocate(other_surface_ids) - end do + call deallocate(front_field) + end if + + call deallocate(unwrapped_positions_B) + call deallocate(unwrapped_metric_B) + + deallocate(physical_colours) + deallocate(aliased_colours) + + ! mesh_10: final mesh + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("mesh", 10, position=intermediate_positions, model=intermediate_positions%mesh) + call vtk_write_surface_mesh("surface", 10, intermediate_positions) + end if + + call deallocate(other_surface_ids) + end do - new_positions = intermediate_positions - new_positions%option_path = old_positions%option_path - new_positions%mesh%option_path = old_positions%mesh%option_path - new_positions%name = old_positions%name - new_positions%mesh%name = old_positions%mesh%name + new_positions = intermediate_positions + new_positions%option_path = old_positions%option_path + new_positions%mesh%option_path = old_positions%mesh%option_path + new_positions%name = old_positions%name + new_positions%mesh%name = old_positions%mesh%name - call deallocate(intermediate_metric) + call deallocate(intermediate_metric) - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("adapted_mesh", delete_me, position=new_positions, model=new_positions%mesh) - end if + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("adapted_mesh", delete_me, position=new_positions, model=new_positions%mesh) + end if - unwrapped_positions_A = make_mesh_unperiodic_from_options(intermediate_positions, trim(periodic_boundary_option_path(dim))) - if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then - call vtk_write_fields("adapted_mesh_unwrapped", delete_me, position=unwrapped_positions_A, model=unwrapped_positions_A%mesh) - call vtk_write_surface_mesh("adapted_surface_unwrapped", delete_me, unwrapped_positions_A) - end if + unwrapped_positions_A = make_mesh_unperiodic_from_options(intermediate_positions, trim(periodic_boundary_option_path(dim))) + if(have_option("/mesh_adaptivity/hr_adaptivity/debug/write_periodic_adapted_mesh")) then + call vtk_write_fields("adapted_mesh_unwrapped", delete_me, position=unwrapped_positions_A, model=unwrapped_positions_A%mesh) + call vtk_write_surface_mesh("adapted_surface_unwrapped", delete_me, unwrapped_positions_A) + end if - call deallocate(unwrapped_positions_A) - delete_me = delete_me + 1 + call deallocate(unwrapped_positions_A) + delete_me = delete_me + 1 - end subroutine adapt_mesh_periodic + end subroutine adapt_mesh_periodic - subroutine adapt_mesh(old_positions, metric, new_positions, node_ownership, force_preserve_regions) - !!< A wrapper to select the appropriate adapt_mesh routine. - !!< If the input is periodic, then apply the algorithm for adapting periodic meshes. + subroutine adapt_mesh(old_positions, metric, new_positions, node_ownership, force_preserve_regions) + !!< A wrapper to select the appropriate adapt_mesh routine. + !!< If the input is periodic, then apply the algorithm for adapting periodic meshes. - type(vector_field), intent(in) :: old_positions - type(tensor_field), intent(inout) :: metric - type(vector_field), intent(out) :: new_positions - integer, dimension(:), pointer, optional :: node_ownership - logical, intent(in), optional :: force_preserve_regions + type(vector_field), intent(in) :: old_positions + type(tensor_field), intent(inout) :: metric + type(vector_field), intent(out) :: new_positions + integer, dimension(:), pointer, optional :: node_ownership + logical, intent(in), optional :: force_preserve_regions #ifdef DDEBUG - if(present(node_ownership)) then - assert(.not. associated(node_ownership)) - end if + if(present(node_ownership)) then + assert(.not. associated(node_ownership)) + end if #endif - ! Periodic case - if (mesh_periodic(old_positions)) then - call adapt_mesh_periodic(old_positions, metric, new_positions, force_preserve_regions=force_preserve_regions) - ! Nonperiodic case - else - call adapt_mesh_simple(old_positions, metric, new_positions, node_ownership=node_ownership, force_preserve_regions=force_preserve_regions) - end if - end subroutine adapt_mesh + ! Periodic case + if (mesh_periodic(old_positions)) then + call adapt_mesh_periodic(old_positions, metric, new_positions, force_preserve_regions=force_preserve_regions) + ! Nonperiodic case + else + call adapt_mesh_simple(old_positions, metric, new_positions, node_ownership=node_ownership, force_preserve_regions=force_preserve_regions) + end if + end subroutine adapt_mesh - subroutine adapt_state_single(state, metric, initialise_fields) + subroutine adapt_state_single(state, metric, initialise_fields) - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: metric - !! If present and .true., initialise fields rather than interpolate them - logical, optional, intent(in) :: initialise_fields + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: metric + !! If present and .true., initialise fields rather than interpolate them + logical, optional, intent(in) :: initialise_fields - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - call adapt_state(states, metric, initialise_fields = initialise_fields) - state = states(1) + states = (/state/) + call adapt_state(states, metric, initialise_fields = initialise_fields) + state = states(1) - end subroutine adapt_state_single + end subroutine adapt_state_single - subroutine adapt_state_multiple(states, metric, initialise_fields) + subroutine adapt_state_multiple(states, metric, initialise_fields) - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), intent(inout) :: metric - !! If present and .true., initialise fields rather than interpolate them - logical, optional, intent(in) :: initialise_fields + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), intent(inout) :: metric + !! If present and .true., initialise fields rather than interpolate them + logical, optional, intent(in) :: initialise_fields - call tictoc_clear(TICTOC_ID_SERIAL_ADAPT) - call tictoc_clear(TICTOC_ID_DATA_MIGRATION) - call tictoc_clear(TICTOC_ID_DATA_REMAP) - call tictoc_clear(TICTOC_ID_ADAPT) + call tictoc_clear(TICTOC_ID_SERIAL_ADAPT) + call tictoc_clear(TICTOC_ID_DATA_MIGRATION) + call tictoc_clear(TICTOC_ID_DATA_REMAP) + call tictoc_clear(TICTOC_ID_ADAPT) - call tic(TICTOC_ID_ADAPT) + call tic(TICTOC_ID_ADAPT) - call adapt_state_internal(states, metric, initialise_fields = initialise_fields) + call adapt_state_internal(states, metric, initialise_fields = initialise_fields) - call toc(TICTOC_ID_ADAPT) + call toc(TICTOC_ID_ADAPT) - call tictoc_report(2, TICTOC_ID_SERIAL_ADAPT) - call tictoc_report(2, TICTOC_ID_DATA_MIGRATION) - call tictoc_report(2, TICTOC_ID_DATA_REMAP) - call tictoc_report(2, TICTOC_ID_ADAPT) + call tictoc_report(2, TICTOC_ID_SERIAL_ADAPT) + call tictoc_report(2, TICTOC_ID_DATA_MIGRATION) + call tictoc_report(2, TICTOC_ID_DATA_REMAP) + call tictoc_report(2, TICTOC_ID_ADAPT) - end subroutine adapt_state_multiple + end subroutine adapt_state_multiple - subroutine adapt_state_first_timestep(states) - !!< Subroutine to adapt the supplied states at the simulation start + subroutine adapt_state_first_timestep(states) + !!< Subroutine to adapt the supplied states at the simulation start - type(state_type), dimension(:), intent(inout) :: states + type(state_type), dimension(:), intent(inout) :: states - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity/adapt_at_first_timestep" - integer :: adapt_iterations, i - type(mesh_type), pointer :: old_mesh - type(tensor_field) :: metric - type(vector_field), pointer :: output_positions - real :: dt, current_time + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity/adapt_at_first_timestep" + integer :: adapt_iterations, i + type(mesh_type), pointer :: old_mesh + type(tensor_field) :: metric + type(vector_field), pointer :: output_positions + real :: dt, current_time - ewrite(1, *) "In adapt_state_first_timestep" + ewrite(1, *) "In adapt_state_first_timestep" - call get_option(trim(base_path) // "/number_of_adapts", adapt_iterations) + call get_option(trim(base_path) // "/number_of_adapts", adapt_iterations) - do i = 1, adapt_iterations - ewrite(2, "(a,i0,a,i0)") "Performing first timestep adapt ", i, " of ", adapt_iterations + do i = 1, adapt_iterations + ewrite(2, "(a,i0,a,i0)") "Performing first timestep adapt ", i, " of ", adapt_iterations - ! Recalculate diagnostics, as error metric formulations may need them - call allocate_and_insert_auxilliary_fields(states) - call copy_to_stored_values(states,"Old") - call copy_to_stored_values(states,"Iterated") - call relax_to_nonlinear(states) + ! Recalculate diagnostics, as error metric formulations may need them + call allocate_and_insert_auxilliary_fields(states) + call copy_to_stored_values(states,"Old") + call copy_to_stored_values(states,"Iterated") + call relax_to_nonlinear(states) - call enforce_discrete_properties(states) - if(have_option("/timestepping/adaptive_timestep/at_first_timestep")) then - ! doing this here helps metric advection get the right amount of advection - call get_option("/timestepping/timestep", dt) - call calc_cflnumber_field_based_dt(states, dt, force_calculation = .true.) - call set_option("/timestepping/timestep", dt) - end if + call enforce_discrete_properties(states) + if(have_option("/timestepping/adaptive_timestep/at_first_timestep")) then + ! doing this here helps metric advection get the right amount of advection + call get_option("/timestepping/timestep", dt) + call calc_cflnumber_field_based_dt(states, dt, force_calculation = .true.) + call set_option("/timestepping/timestep", dt) + end if - !Set constant particle attributes and MVF fields based on particles - call initialise_constant_particle_diagnostics(states) + !Set constant particle attributes and MVF fields based on particles + call initialise_constant_particle_diagnostics(states) - call calculate_diagnostic_variables(states) - call calculate_diagnostic_variables_new(states) + call calculate_diagnostic_variables(states) + call calculate_diagnostic_variables_new(states) - !Set particle attributes and dependent fields - call get_option("/timestepping/current_time", current_time) - call update_particle_attributes_and_fields(states, current_time, dt) - call calculate_diagnostic_fields_from_particles(states) + !Set particle attributes and dependent fields + call get_option("/timestepping/current_time", current_time) + call update_particle_attributes_and_fields(states, current_time, dt) + call calculate_diagnostic_fields_from_particles(states) - ! Form the new metric - old_mesh => extract_mesh(states(1), topology_mesh_name) - call allocate(metric, old_mesh, "ErrorMetric") - call assemble_metric(states, metric) + ! Form the new metric + old_mesh => extract_mesh(states(1), topology_mesh_name) + call allocate(metric, old_mesh, "ErrorMetric") + call assemble_metric(states, metric) - ! Adapt state, initialising fields from the options tree rather than - ! interpolating them - call adapt_state(states, metric, initialise_fields = .true.) + ! Adapt state, initialising fields from the options tree rather than + ! interpolating them + call adapt_state(states, metric, initialise_fields = .true.) - ! Population balance equation initialise - dqmom_init() helps to recalculate the abscissas and weights - ! based on moment initial conditions (if provided) - call dqmom_init(states) - end do + ! Population balance equation initialise - dqmom_init() helps to recalculate the abscissas and weights + ! based on moment initial conditions (if provided) + call dqmom_init(states) + end do - if(have_option(trim(base_path) // "/output_adapted_mesh")) then - output_positions => extract_vector_field(states(1), "Coordinate") + if(have_option(trim(base_path) // "/output_adapted_mesh")) then + output_positions => extract_vector_field(states(1), "Coordinate") - if(isparallel()) then - call write_gmsh_file(parallel_filename("first_timestep_adapted_mesh"), output_positions) - call write_halos("first_timestep_adapted_mesh", output_positions%mesh) - else - call write_gmsh_file("first_timestep_adapted_mesh", output_positions) - end if + if(isparallel()) then + call write_gmsh_file(parallel_filename("first_timestep_adapted_mesh"), output_positions) + call write_halos("first_timestep_adapted_mesh", output_positions%mesh) + else + call write_gmsh_file("first_timestep_adapted_mesh", output_positions) + end if - end if + end if - ewrite(1, *) "Exiting adapt_state_first_timestep" + ewrite(1, *) "Exiting adapt_state_first_timestep" - end subroutine adapt_state_first_timestep + end subroutine adapt_state_first_timestep - subroutine adapt_state_internal(states, metric, initialise_fields) - !!< Adapt the supplied states according to the supplied metric. In parallel, - !!< additionally re-load-balance with libsam. metric is deallocated by this - !!< routine. Based on adapt_state_2d. + subroutine adapt_state_internal(states, metric, initialise_fields) + !!< Adapt the supplied states according to the supplied metric. In parallel, + !!< additionally re-load-balance with libsam. metric is deallocated by this + !!< routine. Based on adapt_state_2d. - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), intent(inout) :: metric - !! If present and .true., re-initialise fields with their initial condition. - !! This means that the fields are not interpolated but rather reinitialise - !! according to the specified initial condition in the options tree, except - !! if these fields are initialised from_file (checkpointed). - logical, optional, intent(in) :: initialise_fields + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), intent(inout) :: metric + !! If present and .true., re-initialise fields with their initial condition. + !! This means that the fields are not interpolated but rather reinitialise + !! according to the specified initial condition in the options tree, except + !! if these fields are initialised from_file (checkpointed). + logical, optional, intent(in) :: initialise_fields - character(len = FIELD_NAME_LEN) :: metric_name - integer :: i, j, k, max_adapt_iteration - integer :: zoltan_min_adapt_iterations, zoltan_max_adapt_iterations, zoltan_additional_adapt_iterations - logical :: finished_adapting, final_adapt_iteration - integer, dimension(:), pointer :: node_ownership - type(state_type), dimension(size(states)) :: interpolate_states - type(mesh_type), pointer :: old_linear_mesh - type(vector_field) :: old_positions, new_positions - logical :: vertical_only + character(len = FIELD_NAME_LEN) :: metric_name + integer :: i, j, k, max_adapt_iteration + integer :: zoltan_min_adapt_iterations, zoltan_max_adapt_iterations, zoltan_additional_adapt_iterations + logical :: finished_adapting, final_adapt_iteration + integer, dimension(:), pointer :: node_ownership + type(state_type), dimension(size(states)) :: interpolate_states + type(mesh_type), pointer :: old_linear_mesh + type(vector_field) :: old_positions, new_positions + logical :: vertical_only - ! Vertically structured adaptivity stuff - type(vector_field) :: extruded_positions - type(tensor_field) :: full_metric - logical :: vertically_structured_adaptivity + ! Vertically structured adaptivity stuff + type(vector_field) :: extruded_positions + type(tensor_field) :: full_metric + logical :: vertically_structured_adaptivity - ! Zoltan with detectors stuff - integer :: my_num_detectors, total_num_detectors_before_zoltan, total_num_detectors_after_zoltan - integer :: ierr - type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() - type(detector_type), pointer :: detector => null() + ! Zoltan with detectors stuff + integer :: my_num_detectors, total_num_detectors_before_zoltan, total_num_detectors_after_zoltan + integer :: ierr + type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() + type(detector_type), pointer :: detector => null() - real :: global_min_quality, quality_tolerance + real :: global_min_quality, quality_tolerance - ewrite(1, *) "In adapt_state_internal" + ewrite(1, *) "In adapt_state_internal" - nullify(node_ownership) + nullify(node_ownership) - max_adapt_iteration = adapt_iterations() + max_adapt_iteration = adapt_iterations() - vertically_structured_adaptivity = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity") - vertical_only = have_option(& - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/inhomogenous_vertical_resolution/adapt_in_vertical_only") + vertically_structured_adaptivity = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity") + vertical_only = have_option(& + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/inhomogenous_vertical_resolution/adapt_in_vertical_only") - ! Don't need to strip the level 2 halo with Zoltan .. in fact, we don't want to + ! Don't need to strip the level 2 halo with Zoltan .. in fact, we don't want to #ifndef HAVE_ZOLTAN - if(isparallel()) then - ! In parallel, strip off the level 2 halo (expected by libsam). The level - ! 2 halo is restored on the final adapt iteration by libsam. - call strip_level_2_halo(states, metric, initialise_fields=initialise_fields) - end if + if(isparallel()) then + ! In parallel, strip off the level 2 halo (expected by libsam). The level + ! 2 halo is restored on the final adapt iteration by libsam. + call strip_level_2_halo(states, metric, initialise_fields=initialise_fields) + end if #endif #ifdef HAVE_ZOLTAN - call get_option("/mesh_adaptivity/hr_adaptivity/zoltan_options/additional_adapt_iterations", & - & zoltan_additional_adapt_iterations, default = 0) - if (zoltan_additional_adapt_iterations < 0) then - FLExit("Zoltan additional adapt iterations must not be negative.") - end if + call get_option("/mesh_adaptivity/hr_adaptivity/zoltan_options/additional_adapt_iterations", & + & zoltan_additional_adapt_iterations, default = 0) + if (zoltan_additional_adapt_iterations < 0) then + FLExit("Zoltan additional adapt iterations must not be negative.") + end if - call get_option("/mesh_adaptivity/hr_adaptivity/zoltan_options/element_quality_cutoff", & - & quality_tolerance, default = 0.6) + call get_option("/mesh_adaptivity/hr_adaptivity/zoltan_options/element_quality_cutoff", & + & quality_tolerance, default = 0.6) - zoltan_min_adapt_iterations = adapt_iterations() - zoltan_max_adapt_iterations = zoltan_min_adapt_iterations + zoltan_additional_adapt_iterations + zoltan_min_adapt_iterations = adapt_iterations() + zoltan_max_adapt_iterations = zoltan_min_adapt_iterations + zoltan_additional_adapt_iterations #endif - finished_adapting = .false. + finished_adapting = .false. - if (max_adapt_iteration == 1) then - final_adapt_iteration = .true. - else - final_adapt_iteration = .false. - end if + if (max_adapt_iteration == 1) then + final_adapt_iteration = .true. + else + final_adapt_iteration = .false. + end if - i = 1 + i = 1 - do while (.not. finished_adapting) - if(max_adapt_iteration > 1) then - ewrite(2, "(a,i0)") "Performing adapt ", i - end if + do while (.not. finished_adapting) + if(max_adapt_iteration > 1) then + ewrite(2, "(a,i0)") "Performing adapt ", i + end if - ! Select mesh to adapt. Has to be linear and continuous. - ! For vertically_structured_adaptivity, this is the horizontal mesh! - call find_mesh_to_adapt(states(1), old_linear_mesh) - ewrite(2, *) "External mesh to be adapted: " // trim(old_linear_mesh%name) - if (mesh_periodic(old_linear_mesh)) then - old_positions = extract_vector_field(states(1), trim(old_linear_mesh%name) // "Coordinate") - call incref(old_positions) - else - ! Extract the mesh field to be adapted (takes a reference) - old_positions = get_coordinate_field(states(1), old_linear_mesh) - end if - ewrite(2, *) "Mesh field to be adapted: " // trim(old_positions%name) - - call prepare_vertically_structured_adaptivity(states, metric, full_metric, & - old_positions, extruded_positions) - if (have_option(trim(old_linear_mesh%option_path)//"/from_mesh/extrude")) then - ! this happens with an extruded setup for the initial mesh if we don't - ! have hr_adaptivity/vertically_structured_adaptivity - ! We've reached adaptivity now, so immediately after the adapt there will no longer any - ! relation with the horizontal meshes (and in parallel with their decomposition) - ! We therefore change the options tree to make the adapted mesh external, so we checkpoint - ! correctly, and remove the horizontal mesh options. The horizontal meshes may still linger around - ! for a while as they could be needed for instance in .stat file during this run - call remove_non_extruded_mesh_options(states) - end if + ! Select mesh to adapt. Has to be linear and continuous. + ! For vertically_structured_adaptivity, this is the horizontal mesh! + call find_mesh_to_adapt(states(1), old_linear_mesh) + ewrite(2, *) "External mesh to be adapted: " // trim(old_linear_mesh%name) + if (mesh_periodic(old_linear_mesh)) then + old_positions = extract_vector_field(states(1), trim(old_linear_mesh%name) // "Coordinate") + call incref(old_positions) + else + ! Extract the mesh field to be adapted (takes a reference) + old_positions = get_coordinate_field(states(1), old_linear_mesh) + end if + ewrite(2, *) "Mesh field to be adapted: " // trim(old_positions%name) + + call prepare_vertically_structured_adaptivity(states, metric, full_metric, & + old_positions, extruded_positions) + if (have_option(trim(old_linear_mesh%option_path)//"/from_mesh/extrude")) then + ! this happens with an extruded setup for the initial mesh if we don't + ! have hr_adaptivity/vertically_structured_adaptivity + ! We've reached adaptivity now, so immediately after the adapt there will no longer any + ! relation with the horizontal meshes (and in parallel with their decomposition) + ! We therefore change the options tree to make the adapted mesh external, so we checkpoint + ! correctly, and remove the horizontal mesh options. The horizontal meshes may still linger around + ! for a while as they could be needed for instance in .stat file during this run + call remove_non_extruded_mesh_options(states) + end if - call initialise_boundcount(old_linear_mesh, old_positions) + call initialise_boundcount(old_linear_mesh, old_positions) - do j = 1, size(states) - ! Reference fields to be interpolated in interpolate_states - ! (if initialise_fields then leave out those fields that can be reinitialised) - call select_fields_to_interpolate(states(j), interpolate_states(j), & - & first_time_step = initialise_fields) - end do + do j = 1, size(states) + ! Reference fields to be interpolated in interpolate_states + ! (if initialise_fields then leave out those fields that can be reinitialised) + call select_fields_to_interpolate(states(j), interpolate_states(j), & + & first_time_step = initialise_fields) + end do - do j = 1, size(states) - call deallocate(states(j)) - end do + do j = 1, size(states) + call deallocate(states(j)) + end do - if(isparallel()) then - ! Update the fields to be interpolated, just in case - call halo_update(interpolate_states) - end if + if(isparallel()) then + ! Update the fields to be interpolated, just in case + call halo_update(interpolate_states) + end if - ! Before we start allocating any new objects we tag all references to - ! current objects before the adapt so we can later on check they have all - ! been deallocated - call tag_references() + ! Before we start allocating any new objects we tag all references to + ! current objects before the adapt so we can later on check they have all + ! been deallocated + call tag_references() + + !Check if particle lists are initialised + if (get_num_detector_lists()>0) then + call get_registered_detector_lists(detector_list_array) + ! Check if particle elements exist on this processor, pack to other processor if not + do j = 1, size(detector_list_array) + call distribute_detectors(states(1), detector_list_array(j)%ptr, old_positions) + end do - !Check if particle lists are initialised - if (get_num_detector_lists()>0) then - call get_registered_detector_lists(detector_list_array) - ! Check if particle elements exist on this processor, pack to other processor if not - do j = 1, size(detector_list_array) - call distribute_detectors(states(1), detector_list_array(j)%ptr, old_positions) - end do + end if - end if + ! Generate a new mesh field based on the current mesh field and the input + ! metric + if (.not. vertical_only) then + call adapt_mesh(old_positions, metric, new_positions, node_ownership = node_ownership, & + & force_preserve_regions=initialise_fields) + else + call allocate(new_positions,old_positions%dim,old_positions%mesh,name=trim(old_positions%name)) + call set(new_positions,old_positions) + end if - ! Generate a new mesh field based on the current mesh field and the input - ! metric - if (.not. vertical_only) then - call adapt_mesh(old_positions, metric, new_positions, node_ownership = node_ownership, & - & force_preserve_regions=initialise_fields) - else - call allocate(new_positions,old_positions%dim,old_positions%mesh,name=trim(old_positions%name)) - call set(new_positions,old_positions) - end if + ! Insert the new mesh field and linear mesh into all states + call insert(states, new_positions%mesh, name = new_positions%mesh%name) + call insert(states, new_positions, name = new_positions%name) - ! Insert the new mesh field and linear mesh into all states - call insert(states, new_positions%mesh, name = new_positions%mesh%name) - call insert(states, new_positions, name = new_positions%name) + if(associated(node_ownership)) then + call perform_vertically_inhomogenous_step(states, new_positions, old_positions, & + full_metric, extruded_positions, & + map=node_ownership) + else + call perform_vertically_inhomogenous_step(states, new_positions, old_positions, & + full_metric, extruded_positions) + end if + ! We're done with old_positions, so we may deallocate it + call deallocate(old_positions) - if(associated(node_ownership)) then - call perform_vertically_inhomogenous_step(states, new_positions, old_positions, & - full_metric, extruded_positions, & - map=node_ownership) - else - call perform_vertically_inhomogenous_step(states, new_positions, old_positions, & - full_metric, extruded_positions) - end if - ! We're done with old_positions, so we may deallocate it - call deallocate(old_positions) - - ! Insert meshes from reserve states - call restore_reserved_meshes(states) - ! Next we recreate all derived meshes - call insert_derived_meshes(states) - - if(vertically_structured_adaptivity) then - call deallocate(metric) - call deallocate(new_positions) - - metric = full_metric - new_positions = get_coordinate_field(states(1), extract_mesh(states(1), topology_mesh_name)) - - if(associated(node_ownership)) then - ! Deallocate the node ownership mapping since it's for the lower dimensional mesh - deallocate(node_ownership) - nullify(node_ownership) - end if - end if + ! Insert meshes from reserve states + call restore_reserved_meshes(states) + ! Next we recreate all derived meshes + call insert_derived_meshes(states) - if (get_num_detector_lists()>0) then - ! Update detector element and local_coords for every detector in all lists - call profiler_tic("find_particles_mesh_adapt") - do j = 1, size(detector_list_array) - call search_for_detectors(detector_list_array(j)%ptr, new_positions) - - ! Sanity check that all local detectors are owned - detector=>detector_list_array(j)%ptr%first - do k = 1, detector_list_array(j)%ptr%length - if (detector%element<=0) then - FLAbort("Lost one of the detectors during an adapt") - end if - detector=>detector%next - end do - end do - call profiler_toc("find_particles_mesh_adapt") - end if + if(vertically_structured_adaptivity) then + call deallocate(metric) + call deallocate(new_positions) - ! Then reallocate all fields - call allocate_and_insert_fields(states) - ! Insert fields from reserve states - call restore_reserved_fields(states) - ! Add on the boundary conditions again - call populate_boundary_conditions(states) - ! Set their values - call set_boundary_conditions_values(states) - - if((.not. final_adapt_iteration) .or. isparallel()) then - ! If there are remaining adapt iterations, or we will be calling - ! sam_drive or zoltan_drive, insert the old metric into interpolate_states(1) and a - ! new metric into states(1), for interpolation - call insert_metric_for_interpolation(metric, new_positions%mesh, & - interpolate_states(1), states(1), & - metric_name = metric_name) - end if + metric = full_metric + new_positions = get_coordinate_field(states(1), extract_mesh(states(1), topology_mesh_name)) - ! We're done with the old metric, so we may deallocate it / drop our - ! reference - call deallocate(metric) - ! We're done with the new_positions, so we may drop our reference - call deallocate(new_positions) + if(associated(node_ownership)) then + ! Deallocate the node ownership mapping since it's for the lower dimensional mesh + deallocate(node_ownership) + nullify(node_ownership) + end if + end if - ! Interpolate fields - if(associated(node_ownership)) then - call interpolate(interpolate_states, states, map = node_ownership, only_owned=.true.) - else - call interpolate(interpolate_states, states, only_owned=.true.) - end if + if (get_num_detector_lists()>0) then + ! Update detector element and local_coords for every detector in all lists + call profiler_tic("find_particles_mesh_adapt") + do j = 1, size(detector_list_array) + call search_for_detectors(detector_list_array(j)%ptr, new_positions) + + ! Sanity check that all local detectors are owned + detector=>detector_list_array(j)%ptr%first + do k = 1, detector_list_array(j)%ptr%length + if (detector%element<=0) then + FLAbort("Lost one of the detectors during an adapt") + end if + detector=>detector%next + end do + end do + call profiler_toc("find_particles_mesh_adapt") + end if - ! Deallocate the old fields used for interpolation, referenced in - ! interpolate_states - do j = 1, size(states) - call deallocate(interpolate_states(j)) - end do - if(associated(node_ownership)) then - ! Deallocate the node ownership mapping - deallocate(node_ownership) - nullify(node_ownership) - end if + ! Then reallocate all fields + call allocate_and_insert_fields(states) + ! Insert fields from reserve states + call restore_reserved_fields(states) + ! Add on the boundary conditions again + call populate_boundary_conditions(states) + ! Set their values + call set_boundary_conditions_values(states) + + if((.not. final_adapt_iteration) .or. isparallel()) then + ! If there are remaining adapt iterations, or we will be calling + ! sam_drive or zoltan_drive, insert the old metric into interpolate_states(1) and a + ! new metric into states(1), for interpolation + call insert_metric_for_interpolation(metric, new_positions%mesh, & + interpolate_states(1), states(1), & + metric_name = metric_name) + end if - if((.not. final_adapt_iteration) .or. isparallel()) then - ! If there are remaining adapt iterations, extract the new metric for - ! the next adapt iteration. If we will be calling sam_drive, always - ! extract the new metric. - metric = extract_and_remove_metric(states(1), metric_name) - ! we haven't interpolated in halo2 nodes, so we need to halo update it - call halo_update(metric) - end if + ! We're done with the old metric, so we may deallocate it / drop our + ! reference + call deallocate(metric) + ! We're done with the new_positions, so we may drop our reference + call deallocate(new_positions) - if(present_and_true(initialise_fields)) then - ! Reinitialise the prognostic fields (where possible) - call initialise_prognostic_fields(states) - ! Prescribed fields are recalculated - ! NOTE: we don't have exclude_interpolated, as the only prescribed - ! fields that are interpolated are from_file which will be skipped - ! anyway because initial_mesh = .false., and the routine doesn't know - ! we're not interpolating other prescribed fields with interpolation - ! options - call set_prescribed_field_values(states) - else - ! Prescribed fields are recalculated (except those with interpolation - ! options) - call set_prescribed_field_values(states, exclude_interpolated = .true.) - end if + ! Interpolate fields + if(associated(node_ownership)) then + call interpolate(interpolate_states, states, map = node_ownership, only_owned=.true.) + else + call interpolate(interpolate_states, states, only_owned=.true.) + end if + + ! Deallocate the old fields used for interpolation, referenced in + ! interpolate_states + do j = 1, size(states) + call deallocate(interpolate_states(j)) + end do + if(associated(node_ownership)) then + ! Deallocate the node ownership mapping + deallocate(node_ownership) + nullify(node_ownership) + end if + + if((.not. final_adapt_iteration) .or. isparallel()) then + ! If there are remaining adapt iterations, extract the new metric for + ! the next adapt iteration. If we will be calling sam_drive, always + ! extract the new metric. + metric = extract_and_remove_metric(states(1), metric_name) + ! we haven't interpolated in halo2 nodes, so we need to halo update it + call halo_update(metric) + end if + + if(present_and_true(initialise_fields)) then + ! Reinitialise the prognostic fields (where possible) + call initialise_prognostic_fields(states) + ! Prescribed fields are recalculated + ! NOTE: we don't have exclude_interpolated, as the only prescribed + ! fields that are interpolated are from_file which will be skipped + ! anyway because initial_mesh = .false., and the routine doesn't know + ! we're not interpolating other prescribed fields with interpolation + ! options + call set_prescribed_field_values(states) + else + ! Prescribed fields are recalculated (except those with interpolation + ! options) + call set_prescribed_field_values(states, exclude_interpolated = .true.) + end if - ! If strong bc or weak that overwrite then enforce the bc on the fields - call set_dirichlet_consistent(states) - ! Insert aliased fields in state - call alias_fields(states) + ! If strong bc or weak that overwrite then enforce the bc on the fields + call set_dirichlet_consistent(states) + ! Insert aliased fields in state + call alias_fields(states) - default_stat%zoltan_drive_call=.false. + default_stat%zoltan_drive_call=.false. - if(isparallel()) then + if(isparallel()) then #ifdef HAVE_ZOLTAN #ifdef DDEBUG - ! Re-load-balance using zoltan - my_num_detectors = default_stat%detector_list%length + ! Re-load-balance using zoltan + my_num_detectors = default_stat%detector_list%length - call MPI_ALLREDUCE(my_num_detectors, total_num_detectors_before_zoltan, 1, getPINTEGER(), & - MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) + call MPI_ALLREDUCE(my_num_detectors, total_num_detectors_before_zoltan, 1, getPINTEGER(), & + MPI_SUM, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) #endif - if(vertically_structured_adaptivity) then - ! if we're doing vertically strucvtured adaptivity then we need to pass zoltan the - ! horizontal metric, so let's derive that again but this time off the full metric - ! we just interpolated... - ! first we need the horizontal coordinates (called old_positions here) - call find_mesh_to_adapt(states(1), old_linear_mesh) - if (mesh_periodic(old_linear_mesh)) then - old_positions = extract_vector_field(states(1), trim(old_linear_mesh%name) // "Coordinate") - call incref(old_positions) - else - ! Extract the mesh field to be adapted (takes a reference) - old_positions = get_coordinate_field(states(1), old_linear_mesh) - end if - - ! now collapse metric to a 2d version (saving the metric as full_metric in the meantime) - call prepare_vertically_structured_adaptivity(states, metric, full_metric, & - old_positions) - - ! we're done with the horizontal coordinates (out here at least) - call deallocate(old_positions) - - ! call zoltan now but we need to pass in both the 2d metric (metric) and the 3d full metric (full_metric) - ! the first is needed to define the element qualities while the second must be interpolated to the newly - ! decomposed mesh - if (zoltan_additional_adapt_iterations .gt. 0) then - call zoltan_drive(states, final_adapt_iteration, global_min_quality = global_min_quality, metric = metric, full_metric = full_metric) - else - call zoltan_drive(states, final_adapt_iteration, metric = metric, full_metric = full_metric) - end if - default_stat%zoltan_drive_call=.true. - - ! now we can deallocate the horizontal metric and point metric back at the full metric again - call deallocate(metric) - metric = full_metric - else - - if (zoltan_additional_adapt_iterations .gt. 0) then - call zoltan_drive(states, final_adapt_iteration, global_min_quality = global_min_quality, metric = metric) - else - call zoltan_drive(states, final_adapt_iteration, metric = metric) - end if - default_stat%zoltan_drive_call=.true. - - end if + if(vertically_structured_adaptivity) then + ! if we're doing vertically strucvtured adaptivity then we need to pass zoltan the + ! horizontal metric, so let's derive that again but this time off the full metric + ! we just interpolated... + ! first we need the horizontal coordinates (called old_positions here) + call find_mesh_to_adapt(states(1), old_linear_mesh) + if (mesh_periodic(old_linear_mesh)) then + old_positions = extract_vector_field(states(1), trim(old_linear_mesh%name) // "Coordinate") + call incref(old_positions) + else + ! Extract the mesh field to be adapted (takes a reference) + old_positions = get_coordinate_field(states(1), old_linear_mesh) + end if + + ! now collapse metric to a 2d version (saving the metric as full_metric in the meantime) + call prepare_vertically_structured_adaptivity(states, metric, full_metric, & + old_positions) + + ! we're done with the horizontal coordinates (out here at least) + call deallocate(old_positions) + + ! call zoltan now but we need to pass in both the 2d metric (metric) and the 3d full metric (full_metric) + ! the first is needed to define the element qualities while the second must be interpolated to the newly + ! decomposed mesh + if (zoltan_additional_adapt_iterations .gt. 0) then + call zoltan_drive(states, final_adapt_iteration, global_min_quality = global_min_quality, metric = metric, full_metric = full_metric) + else + call zoltan_drive(states, final_adapt_iteration, metric = metric, full_metric = full_metric) + end if + default_stat%zoltan_drive_call=.true. + + ! now we can deallocate the horizontal metric and point metric back at the full metric again + call deallocate(metric) + metric = full_metric + else + + if (zoltan_additional_adapt_iterations .gt. 0) then + call zoltan_drive(states, final_adapt_iteration, global_min_quality = global_min_quality, metric = metric) + else + call zoltan_drive(states, final_adapt_iteration, metric = metric) + end if + default_stat%zoltan_drive_call=.true. + + end if #ifdef DDEBUG - my_num_detectors = default_stat%detector_list%length + my_num_detectors = default_stat%detector_list%length - call MPI_ALLREDUCE(my_num_detectors, total_num_detectors_after_zoltan, 1, getPINTEGER(), & - MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) + call MPI_ALLREDUCE(my_num_detectors, total_num_detectors_after_zoltan, 1, getPINTEGER(), & + MPI_SUM, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) - assert(total_num_detectors_before_zoltan == total_num_detectors_after_zoltan) + assert(total_num_detectors_before_zoltan == total_num_detectors_after_zoltan) #endif #else - ! Re-load-balance using libsam - call sam_drive(states, sam_options(i, max_adapt_iteration), metric = metric) + ! Re-load-balance using libsam + call sam_drive(states, sam_options(i, max_adapt_iteration), metric = metric) #endif - if(final_adapt_iteration) then - ! On the last adapt iteration the metric was interpolated - ! only for re-load-balancing, hence it must be deallocated - call deallocate(metric) - end if - end if + if(final_adapt_iteration) then + ! On the last adapt iteration the metric was interpolated + ! only for re-load-balancing, hence it must be deallocated + call deallocate(metric) + end if + end if - if(vertical_only) then - ewrite(2,*) "Using vertical_only adaptivity, so skipping the printing of references" - else if (no_reserved_meshes()) then - ewrite(2, *) "Tagged references remaining:" - call print_tagged_references(0) - else - ewrite(2, *) "There are reserved meshes, so skipping printing of references." - end if + if(vertical_only) then + ewrite(2,*) "Using vertical_only adaptivity, so skipping the printing of references" + else if (no_reserved_meshes()) then + ewrite(2, *) "Tagged references remaining:" + call print_tagged_references(0) + else + ewrite(2, *) "There are reserved meshes, so skipping printing of references." + end if - call write_adapt_state_debug_output(states, final_adapt_iteration, & - & initialise_fields = initialise_fields) + call write_adapt_state_debug_output(states, final_adapt_iteration, & + & initialise_fields = initialise_fields) - call incrementeventcounter(EVENT_ADAPTIVITY) - call incrementeventcounter(EVENT_MESH_MOVEMENT) + call incrementeventcounter(EVENT_ADAPTIVITY) + call incrementeventcounter(EVENT_MESH_MOVEMENT) - ! if this was the final adapt iteration we've now finished adapting - if (final_adapt_iteration) then - ewrite(2,*) "Finished adapting." - finished_adapting = .true. - else - ! check whether the next iteration should be the last iteration - i = i + 1 + ! if this was the final adapt iteration we've now finished adapting + if (final_adapt_iteration) then + ewrite(2,*) "Finished adapting." + finished_adapting = .true. + else + ! check whether the next iteration should be the last iteration + i = i + 1 #ifdef HAVE_ZOLTAN - if (i .eq. zoltan_max_adapt_iterations) then + if (i .eq. zoltan_max_adapt_iterations) then - ! Only print out message if additional adapt iterations have been switched on - if (zoltan_additional_adapt_iterations .gt. 0) then - ewrite(2,*) "The next iteration will be final adapt iteration else we'll go over the maximum adapt iterations." - end if + ! Only print out message if additional adapt iterations have been switched on + if (zoltan_additional_adapt_iterations .gt. 0) then + ewrite(2,*) "The next iteration will be final adapt iteration else we'll go over the maximum adapt iterations." + end if - if (zoltan_additional_adapt_iterations .gt. 0) then - if (global_min_quality .le. quality_tolerance) then - ewrite(-1,*) "Mesh contains elements with quality below element quality tolerance. May need to increase number of adapt iterations to ensure good quality mesh." - ewrite(-1,*) "min_quality = ", global_min_quality - ewrite(-1,*) "quality_tolerance = ", quality_tolerance + if (zoltan_additional_adapt_iterations .gt. 0) then + if (global_min_quality .le. quality_tolerance) then + ewrite(-1,*) "Mesh contains elements with quality below element quality tolerance. May need to increase number of adapt iterations to ensure good quality mesh." + ewrite(-1,*) "min_quality = ", global_min_quality + ewrite(-1,*) "quality_tolerance = ", quality_tolerance + end if end if - end if - final_adapt_iteration = .true. - else - ! Only check to allow an early exit if additional adapt iterations have been switched on - if (zoltan_additional_adapt_iterations .gt. 0) then - if((global_min_quality .gt. quality_tolerance) .and. (i .ge. zoltan_min_adapt_iterations)) then - ewrite(2,*) "The next iteration will be final adapt iteration as the mesh is of high enough quality and we have done the minimum number of adapt iterations." - final_adapt_iteration = .true. + final_adapt_iteration = .true. + else + ! Only check to allow an early exit if additional adapt iterations have been switched on + if (zoltan_additional_adapt_iterations .gt. 0) then + if((global_min_quality .gt. quality_tolerance) .and. (i .ge. zoltan_min_adapt_iterations)) then + ewrite(2,*) "The next iteration will be final adapt iteration as the mesh is of high enough quality and we have done the minimum number of adapt iterations." + final_adapt_iteration = .true. + end if end if end if - end if #else - if (i .eq. max_adapt_iteration) then - final_adapt_iteration = .true. - end if + if (i .eq. max_adapt_iteration) then + final_adapt_iteration = .true. + end if #endif - end if + end if - end do + end do - if(isparallel()) then - call compute_domain_statistics(states) - end if + if(isparallel()) then + call compute_domain_statistics(states) + end if - ewrite(1, *) "Exiting adapt_state_internal" + ewrite(1, *) "Exiting adapt_state_internal" - end subroutine adapt_state_internal + end subroutine adapt_state_internal - subroutine insert_metric_for_interpolation(metric, new_mesh, old_state, new_state, metric_name) - !!< Insert the old metric into old_states and a new metric into new_states, - !!< for interpolation + subroutine insert_metric_for_interpolation(metric, new_mesh, old_state, new_state, metric_name) + !!< Insert the old metric into old_states and a new metric into new_states, + !!< for interpolation - type(tensor_field), intent(in) :: metric - type(mesh_type), intent(in) :: new_mesh - type(state_type), intent(inout) :: old_state - type(state_type), intent(inout) :: new_state - character(len = *), optional, intent(out) :: metric_name + type(tensor_field), intent(in) :: metric + type(mesh_type), intent(in) :: new_mesh + type(state_type), intent(inout) :: old_state + type(state_type), intent(inout) :: new_state + character(len = *), optional, intent(out) :: metric_name - type(tensor_field) :: new_metric + type(tensor_field) :: new_metric - assert(.not. has_tensor_field(old_state, metric%name)) - call insert(old_state, metric, metric%name) + assert(.not. has_tensor_field(old_state, metric%name)) + call insert(old_state, metric, metric%name) - call allocate(new_metric, new_mesh, metric%name) - assert(.not. has_tensor_field(new_state, new_metric%name)) - call insert(new_state, new_metric, new_metric%name) + call allocate(new_metric, new_mesh, metric%name) + assert(.not. has_tensor_field(new_state, new_metric%name)) + call insert(new_state, new_metric, new_metric%name) - if(present(metric_name)) metric_name = new_metric%name + if(present(metric_name)) metric_name = new_metric%name - call deallocate(new_metric) + call deallocate(new_metric) - end subroutine insert_metric_for_interpolation + end subroutine insert_metric_for_interpolation - function extract_and_remove_metric(state, metric_name) result(metric) - !!< Extract and remove the metric from the supplied state. metric takes - !!< a reference in this routine. + function extract_and_remove_metric(state, metric_name) result(metric) + !!< Extract and remove the metric from the supplied state. metric takes + !!< a reference in this routine. - type(state_type), intent(inout) :: state - character(len = *), intent(in) :: metric_name + type(state_type), intent(inout) :: state + character(len = *), intent(in) :: metric_name - type(tensor_field) :: metric + type(tensor_field) :: metric - type(tensor_field), pointer :: metric_ptr + type(tensor_field), pointer :: metric_ptr - ! Extract the metric - metric_ptr => extract_tensor_field(state, metric_name) - metric = metric_ptr + ! Extract the metric + metric_ptr => extract_tensor_field(state, metric_name) + metric = metric_ptr #ifdef DDEBUG - ! Check the metric - call check_metric(metric) + ! Check the metric + call check_metric(metric) #endif - ! Take a reference to the metric - call incref(metric) - ! and remove it from state - call remove_tensor_field(state, metric%name) - - end function extract_and_remove_metric - - function adapt_iterations() - !!< Return the number of adapt / re-load-balance iterations - - integer :: adapt_iterations - - integer :: adapt_iterations_default - - if(isparallel()) then - adapt_iterations_default = 3 - else - adapt_iterations_default = 1 - end if - call get_option('/mesh_adaptivity/hr_adaptivity/adapt_iterations', adapt_iterations, & - default=adapt_iterations_default) - - end function adapt_iterations - - pure function sam_options(adapt_iteration, max_adapt_iteration) - !!< Return sam options array - - integer, intent(in) :: adapt_iteration - integer, intent(in) :: max_adapt_iteration - - integer, dimension(10) :: sam_options - - sam_options = 0 - - ! Target number of partitions - 0 indicates size of MPI_COMM_FEMTOOLS - sam_options(1) = 0 - - ! Graph partitioning options: - !sam_options(2) = 1 ! Clean partitioning to optimise the length of the - ! interface boundary. - if(adapt_iteration < max_adapt_iteration) then - ! Diffusive method -- fast partitioning, small partition movement - ! thus edges are weighed to avoid areas of high activity. - ! sam_options(2) = 2 ! Local diffusion - sam_options(2) = 3 ! Directed diffusion - else - ! Clean partitioning to optimise the length of the interface boundary. - ! This partitioning is then remapped onto the original partitioning to - ! maximise overlap and therefore the volume of data migration. - sam_options(2) = 4 - end if - - ! Heterogerious options (disabled) - sam_options(3) = 1 - - ! Node and edge weight options - if(adapt_iteration < max_adapt_iteration) then - ! Node weights are based on an estimate of the density of nodes in the - ! region of a node after adaption - sam_options(4) = 2 - ! Calculate edge weights as being the maximum length in metric space of - ! any element surrounding the edge. This should give high weights to - ! elements that are likely to be involved in adaption. - sam_options(5) = 2 - ! Mixed formulation options - sam_options(6) = 1 ! Disabled - ! Do not restore the level 2 halo - else - ! No node weights - sam_options(4) = 1 - ! No edge weights - sam_options(5) = 1 - ! Mixed formulation options - sam_options(6) = 2 ! Enabled - ! Restore the level 2 halo - end if - - end function sam_options - - subroutine prepare_vertically_structured_adaptivity(states, metric, full_metric, & - old_positions, extruded_positions) - type(state_type), dimension(:), intent(inout) :: states - ! the metric will be collapsed, and the uncollapsed full_metric stored in full_metric - type(tensor_field), intent(inout) :: metric, full_metric - ! old positions of the horizontal mesh - type(vector_field), intent(in) :: old_positions - type(vector_field), intent(inout), optional :: extruded_positions - - integer, save:: adaptcnt=0 - logical :: vertically_structured_adaptivity - logical :: vertically_inhomogenous_adaptivity - logical :: include_bottom_metric - logical :: split_gradation - - type(scalar_field) :: edge_lengths - - vertically_structured_adaptivity = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity") - vertically_inhomogenous_adaptivity = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/inhomogenous_vertical_resolution") - include_bottom_metric = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/include_bottom_metric") - split_gradation = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/split_gradation") - - if (vertically_structured_adaptivity) then - ! project full mesh metric to horizontal surface mesh metric - full_metric=metric - call project_metric_to_surface(full_metric, old_positions, metric) - - ! include the components of the full_metric that are tangential to the bathymetry - ! in the surface metric - ! state only required for DistanceToBottom and Coordinate so states(1) is fine - if(include_bottom_metric) call incorporate_bathymetric_metric(states(1), full_metric, old_positions, metric) - - if(split_gradation) then - call halo_update(metric) - ! apply gradation just to the horizontal metric for now - call apply_horizontal_gradation(states(1), metric, full_metric, old_positions) - call halo_update(metric) + ! Take a reference to the metric + call incref(metric) + ! and remove it from state + call remove_tensor_field(state, metric%name) + + end function extract_and_remove_metric + + function adapt_iterations() + !!< Return the number of adapt / re-load-balance iterations + + integer :: adapt_iterations + + integer :: adapt_iterations_default + + if(isparallel()) then + adapt_iterations_default = 3 + else + adapt_iterations_default = 1 + end if + call get_option('/mesh_adaptivity/hr_adaptivity/adapt_iterations', adapt_iterations, & + default=adapt_iterations_default) + + end function adapt_iterations + + pure function sam_options(adapt_iteration, max_adapt_iteration) + !!< Return sam options array + + integer, intent(in) :: adapt_iteration + integer, intent(in) :: max_adapt_iteration + + integer, dimension(10) :: sam_options + + sam_options = 0 + + ! Target number of partitions - 0 indicates size of MPI_COMM_FEMTOOLS + sam_options(1) = 0 + + ! Graph partitioning options: + !sam_options(2) = 1 ! Clean partitioning to optimise the length of the + ! interface boundary. + if(adapt_iteration < max_adapt_iteration) then + ! Diffusive method -- fast partitioning, small partition movement + ! thus edges are weighed to avoid areas of high activity. + ! sam_options(2) = 2 ! Local diffusion + sam_options(2) = 3 ! Directed diffusion + else + ! Clean partitioning to optimise the length of the interface boundary. + ! This partitioning is then remapped onto the original partitioning to + ! maximise overlap and therefore the volume of data migration. + sam_options(2) = 4 end if - ! apply limiting to enforce maximum number of nodes - call limit_metric(old_positions, metric) - if (have_option('/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages')) then - call allocate(edge_lengths, metric%mesh, "EdgeLengths") - call get_edge_lengths(metric, edge_lengths) - call vtk_write_fields('horizontal_metric', adaptcnt, & - old_positions, old_positions%mesh, & - sfields=(/ edge_lengths /), tfields=(/ metric /) ) - adaptcnt=adaptcnt+1 - call deallocate(edge_lengths) + ! Heterogerious options (disabled) + sam_options(3) = 1 + + ! Node and edge weight options + if(adapt_iteration < max_adapt_iteration) then + ! Node weights are based on an estimate of the density of nodes in the + ! region of a node after adaption + sam_options(4) = 2 + ! Calculate edge weights as being the maximum length in metric space of + ! any element surrounding the edge. This should give high weights to + ! elements that are likely to be involved in adaption. + sam_options(5) = 2 + ! Mixed formulation options + sam_options(6) = 1 ! Disabled + ! Do not restore the level 2 halo + else + ! No node weights + sam_options(4) = 1 + ! No edge weights + sam_options(5) = 1 + ! Mixed formulation options + sam_options(6) = 2 ! Enabled + ! Restore the level 2 halo end if - if (vertically_inhomogenous_adaptivity.and.present(extruded_positions)) then - ! we need the position field later on for vertical adaptivity - ! this takes a reference so that it's prevented from the big deallocate in adapt_state - extruded_positions = get_coordinate_field(states(1), full_metric%mesh) + end function sam_options + + subroutine prepare_vertically_structured_adaptivity(states, metric, full_metric, & + old_positions, extruded_positions) + type(state_type), dimension(:), intent(inout) :: states + ! the metric will be collapsed, and the uncollapsed full_metric stored in full_metric + type(tensor_field), intent(inout) :: metric, full_metric + ! old positions of the horizontal mesh + type(vector_field), intent(in) :: old_positions + type(vector_field), intent(inout), optional :: extruded_positions + + integer, save:: adaptcnt=0 + logical :: vertically_structured_adaptivity + logical :: vertically_inhomogenous_adaptivity + logical :: include_bottom_metric + logical :: split_gradation + + type(scalar_field) :: edge_lengths + + vertically_structured_adaptivity = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity") + vertically_inhomogenous_adaptivity = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/inhomogenous_vertical_resolution") + include_bottom_metric = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/include_bottom_metric") + split_gradation = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/split_gradation") + + if (vertically_structured_adaptivity) then + ! project full mesh metric to horizontal surface mesh metric + full_metric=metric + call project_metric_to_surface(full_metric, old_positions, metric) + + ! include the components of the full_metric that are tangential to the bathymetry + ! in the surface metric + ! state only required for DistanceToBottom and Coordinate so states(1) is fine + if(include_bottom_metric) call incorporate_bathymetric_metric(states(1), full_metric, old_positions, metric) + + if(split_gradation) then + call halo_update(metric) + ! apply gradation just to the horizontal metric for now + call apply_horizontal_gradation(states(1), metric, full_metric, old_positions) + call halo_update(metric) + end if + + ! apply limiting to enforce maximum number of nodes + call limit_metric(old_positions, metric) + if (have_option('/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages')) then + call allocate(edge_lengths, metric%mesh, "EdgeLengths") + call get_edge_lengths(metric, edge_lengths) + call vtk_write_fields('horizontal_metric', adaptcnt, & + old_positions, old_positions%mesh, & + sfields=(/ edge_lengths /), tfields=(/ metric /) ) + adaptcnt=adaptcnt+1 + call deallocate(edge_lengths) + end if + + if (vertically_inhomogenous_adaptivity.and.present(extruded_positions)) then + ! we need the position field later on for vertical adaptivity + ! this takes a reference so that it's prevented from the big deallocate in adapt_state + extruded_positions = get_coordinate_field(states(1), full_metric%mesh) + end if end if - end if - - end subroutine prepare_vertically_structured_adaptivity - - subroutine perform_vertically_inhomogenous_step(states, new_positions, old_positions, full_metric, extruded_positions, map) - type(state_type), intent(inout), dimension(:) :: states - type(vector_field), intent(inout) :: new_positions, old_positions - type(tensor_field), intent(inout) :: full_metric - type(vector_field), intent(inout) :: extruded_positions - !! Map from new nodes to old elements - integer, dimension(:), optional, intent(in) :: map - - logical :: vertically_inhomogenous_adaptivity - - type(vector_field) :: full_metric_positions - type(tensor_field) :: gradation_full_metric - - logical :: split_gradation - - vertically_inhomogenous_adaptivity = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/inhomogenous_vertical_resolution") - - if (vertically_inhomogenous_adaptivity) then - ! save the positions that the full_metric is on in case we're doing iterations of the 1d - ! adaptivity process - full_metric_positions = extruded_positions - call incref(full_metric_positions) - call deallocate(extruded_positions) ! deallocate these to make space for the new extruded positions - - split_gradation = have_option( & - & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/split_gradation") - if(split_gradation) then - ! if we're applying gradation then apply it now to the full metric - ! to see if this helps the linear interpolation pick things up - ! (however, we don't want to modify the metric so let's take a copy) - call allocate(gradation_full_metric, full_metric%mesh, name="VerticalGradationFullMetric") - call set(gradation_full_metric, full_metric) - call apply_vertical_gradation(states(1), gradation_full_metric, full_metric_positions, old_positions) - else - gradation_full_metric = full_metric - call incref(gradation_full_metric) - end if - - ! extrude with adaptivity, computes new extruded_positions - call metric_based_extrude(new_positions, old_positions, extruded_positions, & - gradation_full_metric, full_metric_positions, map=map) - - ! insert the new positions in state: - ! give it a generic temporary name, so that it'll be picked up and - ! adjusted by insert_derived meshes later on: - extruded_positions%name="AdaptedExtrudedPositions" - call insert(states, extruded_positions, name="AdaptedExtrudedPositions") - ! and drop our reference: - call deallocate(extruded_positions) - ! and everything to do with the old metric and mesh too: - call deallocate(full_metric_positions) - call deallocate(gradation_full_metric) - - end if - end subroutine perform_vertically_inhomogenous_step - - subroutine write_adapt_state_debug_output(states, final_adapt_iteration, initialise_fields) - !!< Diagnostic output for mesh adaptivity - - type(state_type), dimension(:), intent(in) :: states - !! Whether this is the final iteration of the adapt-re-load-balance loop - logical, intent(in) :: final_adapt_iteration - !! If present and .true., initialise fields rather than interpolate them - logical, optional, intent(in) :: initialise_fields - - character(len = FIELD_NAME_LEN) :: file_name - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity/debug" - integer :: max_output, stat - type(mesh_type), pointer :: mesh - type(vector_field) :: positions - - integer, save :: cp_no = 0, mesh_dump_no = 0, state_dump_no = 0 - - if(.not. have_option(base_path)) then - ! No debug output options - return - end if - - if(have_option(base_path // "/write_adapted_mesh")) then - ! Debug mesh output. These are output on every adapt iteration. - - file_name = adapt_state_debug_file_name("adapted_mesh", mesh_dump_no) - call find_mesh_to_adapt(states(1), mesh) - positions = get_coordinate_field(states(1), mesh) - call write_gmsh_file(file_name, positions) - if(isparallel()) then - file_name = adapt_state_debug_file_name("adapted_mesh", mesh_dump_no, add_parallel = .false.) ! parallel extension is added by write_halos - call write_halos(file_name, positions%mesh) + + end subroutine prepare_vertically_structured_adaptivity + + subroutine perform_vertically_inhomogenous_step(states, new_positions, old_positions, full_metric, extruded_positions, map) + type(state_type), intent(inout), dimension(:) :: states + type(vector_field), intent(inout) :: new_positions, old_positions + type(tensor_field), intent(inout) :: full_metric + type(vector_field), intent(inout) :: extruded_positions + !! Map from new nodes to old elements + integer, dimension(:), optional, intent(in) :: map + + logical :: vertically_inhomogenous_adaptivity + + type(vector_field) :: full_metric_positions + type(tensor_field) :: gradation_full_metric + + logical :: split_gradation + + vertically_inhomogenous_adaptivity = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/inhomogenous_vertical_resolution") + + if (vertically_inhomogenous_adaptivity) then + ! save the positions that the full_metric is on in case we're doing iterations of the 1d + ! adaptivity process + full_metric_positions = extruded_positions + call incref(full_metric_positions) + call deallocate(extruded_positions) ! deallocate these to make space for the new extruded positions + + split_gradation = have_option( & + & "/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/split_gradation") + if(split_gradation) then + ! if we're applying gradation then apply it now to the full metric + ! to see if this helps the linear interpolation pick things up + ! (however, we don't want to modify the metric so let's take a copy) + call allocate(gradation_full_metric, full_metric%mesh, name="VerticalGradationFullMetric") + call set(gradation_full_metric, full_metric) + call apply_vertical_gradation(states(1), gradation_full_metric, full_metric_positions, old_positions) + else + gradation_full_metric = full_metric + call incref(gradation_full_metric) + end if + + ! extrude with adaptivity, computes new extruded_positions + call metric_based_extrude(new_positions, old_positions, extruded_positions, & + gradation_full_metric, full_metric_positions, map=map) + + ! insert the new positions in state: + ! give it a generic temporary name, so that it'll be picked up and + ! adjusted by insert_derived meshes later on: + extruded_positions%name="AdaptedExtrudedPositions" + call insert(states, extruded_positions, name="AdaptedExtrudedPositions") + ! and drop our reference: + call deallocate(extruded_positions) + ! and everything to do with the old metric and mesh too: + call deallocate(full_metric_positions) + call deallocate(gradation_full_metric) + end if - call deallocate(positions) + end subroutine perform_vertically_inhomogenous_step - mesh_dump_no = mesh_dump_no + 1 - end if + subroutine write_adapt_state_debug_output(states, final_adapt_iteration, initialise_fields) + !!< Diagnostic output for mesh adaptivity - if(have_option(base_path // "/write_adapted_state")) then - ! Debug vtu output. These are output on every adapt iteration. + type(state_type), dimension(:), intent(in) :: states + !! Whether this is the final iteration of the adapt-re-load-balance loop + logical, intent(in) :: final_adapt_iteration + !! If present and .true., initialise fields rather than interpolate them + logical, optional, intent(in) :: initialise_fields - call vtk_write_state("adapted_state", index=state_dump_no, state = states, write_region_ids=.true.) + character(len = FIELD_NAME_LEN) :: file_name + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity/debug" + integer :: max_output, stat + type(mesh_type), pointer :: mesh + type(vector_field) :: positions - state_dump_no = state_dump_no + 1 - end if + integer, save :: cp_no = 0, mesh_dump_no = 0, state_dump_no = 0 - if(final_adapt_iteration .and. have_option(base_path // "/checkpoint")) then - ! Debug checkpointing. These are only output on the final adapt iteration. + if(.not. have_option(base_path)) then + ! No debug output options + return + end if - if(present_and_true(initialise_fields)) then - ! If we're adapting with field initialisation rather than interpolation - ! then we probably don't want to overwrite the field initialisation - ! options by checkpointing, as any subsequent adapt with field - ! initialisation will read (and consistently interpolate) the debug - ! checkpoint. Applies to first timestep adapts. - ewrite(1, *) "Adapt checkpoint skipped, as adapt performed with field initialisation" - else - ewrite(1, "(a,i0)") "Performing adapt checkpoint ", cp_no + if(have_option(base_path // "/write_adapted_mesh")) then + ! Debug mesh output. These are output on every adapt iteration. + + file_name = adapt_state_debug_file_name("adapted_mesh", mesh_dump_no) + call find_mesh_to_adapt(states(1), mesh) + positions = get_coordinate_field(states(1), mesh) + call write_gmsh_file(file_name, positions) + if(isparallel()) then + file_name = adapt_state_debug_file_name("adapted_mesh", mesh_dump_no, add_parallel = .false.) ! parallel extension is added by write_halos + call write_halos(file_name, positions%mesh) + end if + call deallocate(positions) - call checkpoint_simulation(states, postfix = "adapt_checkpoint", cp_no = cp_no) + mesh_dump_no = mesh_dump_no + 1 + end if + + if(have_option(base_path // "/write_adapted_state")) then + ! Debug vtu output. These are output on every adapt iteration. - cp_no = cp_no + 1 + call vtk_write_state("adapted_state", index=state_dump_no, state = states, write_region_ids=.true.) - call get_option(base_path // "/checkpoint/max_checkpoint_count", max_output, stat = stat) - if(stat == SPUD_NO_ERROR) cp_no = modulo(cp_no, max_output) + state_dump_no = state_dump_no + 1 end if - end if + if(final_adapt_iteration .and. have_option(base_path // "/checkpoint")) then + ! Debug checkpointing. These are only output on the final adapt iteration. - contains + if(present_and_true(initialise_fields)) then + ! If we're adapting with field initialisation rather than interpolation + ! then we probably don't want to overwrite the field initialisation + ! options by checkpointing, as any subsequent adapt with field + ! initialisation will read (and consistently interpolate) the debug + ! checkpoint. Applies to first timestep adapts. + ewrite(1, *) "Adapt checkpoint skipped, as adapt performed with field initialisation" + else + ewrite(1, "(a,i0)") "Performing adapt checkpoint ", cp_no - function adapt_state_debug_file_name(base_name, dump_no, add_parallel) result(file_name) - !!< Form an adapt diagnostic output filename + call checkpoint_simulation(states, postfix = "adapt_checkpoint", cp_no = cp_no) - !! Filename base - character(len = *), intent(in) :: base_name - integer, intent(in) :: dump_no - !! If present and .false., do not convert into a parallel file_name - logical, optional, intent(in) :: add_parallel + cp_no = cp_no + 1 - character(len = len_trim(base_name) + 1 + int2str_len(dump_no) + 1 + parallel_filename_len("")) :: file_name + call get_option(base_path // "/checkpoint/max_checkpoint_count", max_output, stat = stat) + if(stat == SPUD_NO_ERROR) cp_no = modulo(cp_no, max_output) + end if - file_name = trim(base_name) // "_" // int2str(dump_no) - if(.not. present_and_false(add_parallel) .and. isparallel()) file_name = parallel_filename(file_name) + end if + + contains + + function adapt_state_debug_file_name(base_name, dump_no, add_parallel) result(file_name) + !!< Form an adapt diagnostic output filename + + !! Filename base + character(len = *), intent(in) :: base_name + integer, intent(in) :: dump_no + !! If present and .false., do not convert into a parallel file_name + logical, optional, intent(in) :: add_parallel - end function adapt_state_debug_file_name + character(len = len_trim(base_name) + 1 + int2str_len(dump_no) + 1 + parallel_filename_len("")) :: file_name - end subroutine write_adapt_state_debug_output + file_name = trim(base_name) // "_" // int2str(dump_no) + if(.not. present_and_false(add_parallel) .and. isparallel()) file_name = parallel_filename(file_name) - subroutine adapt_state_module_check_options + end function adapt_state_debug_file_name - integer :: max_output, stat + end subroutine write_adapt_state_debug_output - call get_option("/mesh_adaptivity/hr_adaptivity/debug/checkpoint/max_checkpoint_count", max_output, stat = stat) - if(stat == SPUD_NO_ERROR) then - if(max_output <= 0) then - FLExit("Max adaptivity debug checkpoint count must be positive") + subroutine adapt_state_module_check_options + + integer :: max_output, stat + + call get_option("/mesh_adaptivity/hr_adaptivity/debug/checkpoint/max_checkpoint_count", max_output, stat = stat) + if(stat == SPUD_NO_ERROR) then + if(max_output <= 0) then + FLExit("Max adaptivity debug checkpoint count must be positive") + end if end if - end if - end subroutine adapt_state_module_check_options + end subroutine adapt_state_module_check_options end module adapt_state_module diff --git a/assemble/Adapt_State_Prescribed.F90 b/assemble/Adapt_State_Prescribed.F90 index ace43b8a81..64b4eebe44 100644 --- a/assemble/Adapt_State_Prescribed.F90 +++ b/assemble/Adapt_State_Prescribed.F90 @@ -29,242 +29,242 @@ module adapt_state_prescribed_module - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use embed_python - use spud - use parallel_tools - use eventcounter, only: EVENT_ADAPTIVITY, EVENT_MESH_MOVEMENT, incrementeventcounter - use fields - use state_module - use field_options - use boundary_conditions - use node_boundary - use boundary_conditions_from_options - use mesh_files - use reserve_state_module - use populate_state_module - use interpolation_manager - - implicit none - - private - - public :: adapt_state_prescribed, & - & adapt_state_prescribed_module_check_options, do_adapt_state_prescribed - - character(len = *), parameter :: base_path = "/mesh_adaptivity/prescribed_adaptivity" + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use embed_python + use spud + use parallel_tools + use eventcounter, only: EVENT_ADAPTIVITY, EVENT_MESH_MOVEMENT, incrementeventcounter + use fields + use state_module + use field_options + use boundary_conditions + use node_boundary + use boundary_conditions_from_options + use mesh_files + use reserve_state_module + use populate_state_module + use interpolation_manager + + implicit none + + private + + public :: adapt_state_prescribed, & + & adapt_state_prescribed_module_check_options, do_adapt_state_prescribed + + character(len = *), parameter :: base_path = "/mesh_adaptivity/prescribed_adaptivity" contains - function do_adapt_state_prescribed(elapsed_time) - !!< Return whether to run through a prescribed mesh adapt + function do_adapt_state_prescribed(elapsed_time) + !!< Return whether to run through a prescribed mesh adapt - real, intent(in) :: elapsed_time + real, intent(in) :: elapsed_time - logical :: do_adapt_state_prescribed + logical :: do_adapt_state_prescribed - character(len = OPTION_PATH_LEN) :: func - integer :: do_adapt + character(len = OPTION_PATH_LEN) :: func + integer :: do_adapt - call get_option(base_path // "/adapt_interval/python", func) - call integer_from_python(func, elapsed_time, do_adapt) + call get_option(base_path // "/adapt_interval/python", func) + call integer_from_python(func, elapsed_time, do_adapt) - do_adapt_state_prescribed = do_adapt /= 0 + do_adapt_state_prescribed = do_adapt /= 0 - end function do_adapt_state_prescribed + end function do_adapt_state_prescribed - subroutine adapt_state_prescribed(states, elapsed_time) - !!< Adapt the supplied states using prescribed meshes (rather than by - !!< running through a mesh adaptivity library) + subroutine adapt_state_prescribed(states, elapsed_time) + !!< Adapt the supplied states using prescribed meshes (rather than by + !!< running through a mesh adaptivity library) - type(state_type), dimension(:), intent(inout) :: states - real, intent(in) :: elapsed_time + type(state_type), dimension(:), intent(inout) :: states + real, intent(in) :: elapsed_time - type(vector_field) :: new_positions + type(vector_field) :: new_positions - ewrite(1, *) "In adapt_state_prescribed" + ewrite(1, *) "In adapt_state_prescribed" - new_positions = adapt_state_prescribed_target(states, elapsed_time) - call adapt_state_prescribed_internal(states, new_positions) - call deallocate(new_positions) + new_positions = adapt_state_prescribed_target(states, elapsed_time) + call adapt_state_prescribed_internal(states, new_positions) + call deallocate(new_positions) - ewrite(1, *) "Exiting adapt_state_prescribed" + ewrite(1, *) "Exiting adapt_state_prescribed" - end subroutine adapt_state_prescribed + end subroutine adapt_state_prescribed - function adapt_state_prescribed_target(states, elapsed_time) result(new_positions) - !!< Return the new positions field for the prescribed mesh adapt + function adapt_state_prescribed_target(states, elapsed_time) result(new_positions) + !!< Return the new positions field for the prescribed mesh adapt - type(state_type), dimension(:), intent(inout) :: states - real, intent(in) :: elapsed_time + type(state_type), dimension(:), intent(inout) :: states + real, intent(in) :: elapsed_time - type(vector_field) :: new_positions + type(vector_field) :: new_positions - character(len = OPTION_PATH_LEN) :: format, func, mesh_name - integer :: quad_degree - type(mesh_type), pointer :: new_mesh + character(len = OPTION_PATH_LEN) :: format, func, mesh_name + integer :: quad_degree + type(mesh_type), pointer :: new_mesh - call get_option(base_path // "/mesh/name/python", func) - call string_from_python(func, elapsed_time, mesh_name) - ewrite(2, *) "New mesh name: " // trim(mesh_name) + call get_option(base_path // "/mesh/name/python", func) + call string_from_python(func, elapsed_time, mesh_name) + ewrite(2, *) "New mesh name: " // trim(mesh_name) - if(have_option(base_path // "/mesh/from_file")) then - call get_option(base_path // "/mesh/from_file/format/name", format) - call get_option("/geometry/quadrature/degree", quad_degree) + if(have_option(base_path // "/mesh/from_file")) then + call get_option(base_path // "/mesh/from_file/format/name", format) + call get_option("/geometry/quadrature/degree", quad_degree) - new_positions = read_mesh_files(mesh_name, quad_degree = quad_degree, format = format) - else - ewrite(2, *) "Extracting new mesh from state" + new_positions = read_mesh_files(mesh_name, quad_degree = quad_degree, format = format) + else + ewrite(2, *) "Extracting new mesh from state" - new_mesh => extract_mesh(states(1), mesh_name) - new_positions = get_coordinate_field(states(1), new_mesh) - end if - - end function adapt_state_prescribed_target + new_mesh => extract_mesh(states(1), mesh_name) + new_positions = get_coordinate_field(states(1), new_mesh) + end if - subroutine adapt_state_prescribed_internal(states, new_positions) - !!< Adapt the supplied states to the supplied new coordinate field + end function adapt_state_prescribed_target - type(state_type), dimension(:), intent(inout) :: states - type(vector_field), intent(in) :: new_positions + subroutine adapt_state_prescribed_internal(states, new_positions) + !!< Adapt the supplied states to the supplied new coordinate field - integer :: i - integer, dimension(:), allocatable :: sndgln - logical :: copy_mesh - type(state_type), dimension(size(states)) :: interpolate_states - type(mesh_type) :: lnew_positions_mesh - type(mesh_type), pointer :: old_linear_mesh - type(vector_field) :: old_positions, lnew_positions - integer :: unique_sids + type(state_type), dimension(:), intent(inout) :: states + type(vector_field), intent(in) :: new_positions - ewrite(1, *) "In adapt_state_prescribed_internal" + integer :: i + integer, dimension(:), allocatable :: sndgln + logical :: copy_mesh + type(state_type), dimension(size(states)) :: interpolate_states + type(mesh_type) :: lnew_positions_mesh + type(mesh_type), pointer :: old_linear_mesh + type(vector_field) :: old_positions, lnew_positions + integer :: unique_sids - if(isparallel()) then - FLExit("Prescribed adaptivity does not work in parallel") - end if + ewrite(1, *) "In adapt_state_prescribed_internal" - ! Select mesh to adapt. Has to be linear and continuous. - call find_mesh_to_adapt(states(1), old_linear_mesh) - ewrite(2, *) "External mesh to be adapted: " // trim(old_linear_mesh%name) - ! Extract the mesh field to be adapted (takes a reference) - old_positions = get_coordinate_field(states(1), old_linear_mesh) - ewrite(2, *) "Mesh field to be adapted: " // trim(old_positions%name) + if(isparallel()) then + FLExit("Prescribed adaptivity does not work in parallel") + end if - ! It is required that the new mesh has the same name and option path as the - ! old mesh. If either of these isn't the case, copy the new mesh and change - ! its name / option_path. - copy_mesh = trim(new_positions%mesh%name) /= trim(old_positions%mesh%name) & + ! Select mesh to adapt. Has to be linear and continuous. + call find_mesh_to_adapt(states(1), old_linear_mesh) + ewrite(2, *) "External mesh to be adapted: " // trim(old_linear_mesh%name) + ! Extract the mesh field to be adapted (takes a reference) + old_positions = get_coordinate_field(states(1), old_linear_mesh) + ewrite(2, *) "Mesh field to be adapted: " // trim(old_positions%name) + + ! It is required that the new mesh has the same name and option path as the + ! old mesh. If either of these isn't the case, copy the new mesh and change + ! its name / option_path. + copy_mesh = trim(new_positions%mesh%name) /= trim(old_positions%mesh%name) & & .or. trim(new_positions%mesh%option_path) /= trim(old_positions%mesh%option_path) - if(copy_mesh) then - assert(ele_count(new_positions%mesh) > 0) - call allocate(lnew_positions_mesh, node_count(new_positions%mesh), ele_count(new_positions%mesh), ele_shape(new_positions%mesh, 1), name = old_positions%mesh%name) - do i = 1, ele_count(lnew_positions_mesh) - call set_ele_nodes(lnew_positions_mesh, i, ele_nodes(new_positions%mesh, i)) - end do - assert(associated(new_positions%mesh%faces)) - assert(associated(new_positions%mesh%faces%boundary_ids)) - unique_sids = unique_surface_element_count(new_positions%mesh) - allocate(sndgln(unique_sids * face_loc(new_positions%mesh, 1))) - call getsndgln(new_positions%mesh, sndgln) - call add_faces(lnew_positions_mesh, sndgln = sndgln, boundary_ids = new_positions%mesh%faces%boundary_ids(1:unique_sids)) - deallocate(sndgln) - if(associated(new_positions%mesh%region_ids)) then - allocate(lnew_positions_mesh%region_ids(ele_count(new_positions%mesh))) - lnew_positions_mesh%region_ids = new_positions%mesh%region_ids + if(copy_mesh) then + assert(ele_count(new_positions%mesh) > 0) + call allocate(lnew_positions_mesh, node_count(new_positions%mesh), ele_count(new_positions%mesh), ele_shape(new_positions%mesh, 1), name = old_positions%mesh%name) + do i = 1, ele_count(lnew_positions_mesh) + call set_ele_nodes(lnew_positions_mesh, i, ele_nodes(new_positions%mesh, i)) + end do + assert(associated(new_positions%mesh%faces)) + assert(associated(new_positions%mesh%faces%boundary_ids)) + unique_sids = unique_surface_element_count(new_positions%mesh) + allocate(sndgln(unique_sids * face_loc(new_positions%mesh, 1))) + call getsndgln(new_positions%mesh, sndgln) + call add_faces(lnew_positions_mesh, sndgln = sndgln, boundary_ids = new_positions%mesh%faces%boundary_ids(1:unique_sids)) + deallocate(sndgln) + if(associated(new_positions%mesh%region_ids)) then + allocate(lnew_positions_mesh%region_ids(ele_count(new_positions%mesh))) + lnew_positions_mesh%region_ids = new_positions%mesh%region_ids + end if + lnew_positions_mesh%option_path = old_positions%mesh%option_path + else + lnew_positions_mesh = new_positions%mesh + call incref(lnew_positions_mesh) end if - lnew_positions_mesh%option_path = old_positions%mesh%option_path - else - lnew_positions_mesh = new_positions%mesh - call incref(lnew_positions_mesh) - end if - - ! It is required that the new mesh field have the same name as the old mesh - ! field. If this isn't the case, or we copied the mesh above, copy the new - ! mesh field. - if(trim(new_positions%name) /= trim(old_positions%name) & + + ! It is required that the new mesh field have the same name as the old mesh + ! field. If this isn't the case, or we copied the mesh above, copy the new + ! mesh field. + if(trim(new_positions%name) /= trim(old_positions%name) & & .or. copy_mesh) then - call allocate(lnew_positions, new_positions%dim, lnew_positions_mesh, old_positions%name) - call set(lnew_positions, new_positions) - lnew_positions%name = old_positions%name - lnew_positions%option_path = old_positions%option_path - else - lnew_positions = new_positions - call incref(lnew_positions) - end if - call deallocate(lnew_positions_mesh) - - ! We're done with old_positions, so we may drop our reference - call deallocate(old_positions) - - do i = 1, size(states) - ! Reference fields to be interpolated in interpolate_states - call select_fields_to_interpolate(states(i), interpolate_states(i)) - end do - - do i = 1, size(states) - call deallocate(states(i)) - end do - - ! Insert the new mesh field and linear mesh into all states - call insert(states, lnew_positions%mesh, name = lnew_positions%mesh%name) - call insert(states, lnew_positions, name = lnew_positions%name) - ! We're done with the new_positions, so we may drop our reference - call deallocate(lnew_positions) - - ! Insert meshes from reserve states - call restore_reserved_meshes(states) - ! Next we recreate all derived meshes - call insert_derived_meshes(states) - ! Then reallocate all fields - call allocate_and_insert_fields(states) - ! Insert fields from reserve states - call restore_reserved_fields(states) - ! Add on the boundary conditions again - call populate_boundary_conditions(states) - ! Set their values - call set_boundary_conditions_values(states) - - ! Interpolate fields - call interpolate(interpolate_states, states) - - ! Deallocate the old fields used for interpolation, referenced in - ! interpolate_states - do i = 1, size(states) - call deallocate(interpolate_states(i)) - end do - - ! Prescribed fields are recalculated (except those with interpolation - ! options) - call set_prescribed_field_values(states, exclude_interpolated = .true.) - ! If strong bc or weak that overwrite then enforce the bc on the fields - call set_dirichlet_consistent(states) - ! Insert aliased fields in state - call alias_fields(states) - - call incrementeventcounter(EVENT_ADAPTIVITY) - call incrementeventcounter(EVENT_MESH_MOVEMENT) - - ewrite(1, *) "Exiting adapt_state_prescribed_internal" - - end subroutine adapt_state_prescribed_internal - - subroutine adapt_state_prescribed_module_check_options - !!< Check prescribed adaptivity related options - - if(.not. have_option(base_path)) then - ! Nothing to check - return - end if - - ewrite(2, *) "Checking prescribed adaptivity options" - - if(isparallel()) then - FLExit("Prescribed adaptivity cannot be used in parallel") - end if - - ewrite(2, *) "Finished checking prescribed adaptivity options" - - end subroutine adapt_state_prescribed_module_check_options + call allocate(lnew_positions, new_positions%dim, lnew_positions_mesh, old_positions%name) + call set(lnew_positions, new_positions) + lnew_positions%name = old_positions%name + lnew_positions%option_path = old_positions%option_path + else + lnew_positions = new_positions + call incref(lnew_positions) + end if + call deallocate(lnew_positions_mesh) + + ! We're done with old_positions, so we may drop our reference + call deallocate(old_positions) + + do i = 1, size(states) + ! Reference fields to be interpolated in interpolate_states + call select_fields_to_interpolate(states(i), interpolate_states(i)) + end do + + do i = 1, size(states) + call deallocate(states(i)) + end do + + ! Insert the new mesh field and linear mesh into all states + call insert(states, lnew_positions%mesh, name = lnew_positions%mesh%name) + call insert(states, lnew_positions, name = lnew_positions%name) + ! We're done with the new_positions, so we may drop our reference + call deallocate(lnew_positions) + + ! Insert meshes from reserve states + call restore_reserved_meshes(states) + ! Next we recreate all derived meshes + call insert_derived_meshes(states) + ! Then reallocate all fields + call allocate_and_insert_fields(states) + ! Insert fields from reserve states + call restore_reserved_fields(states) + ! Add on the boundary conditions again + call populate_boundary_conditions(states) + ! Set their values + call set_boundary_conditions_values(states) + + ! Interpolate fields + call interpolate(interpolate_states, states) + + ! Deallocate the old fields used for interpolation, referenced in + ! interpolate_states + do i = 1, size(states) + call deallocate(interpolate_states(i)) + end do + + ! Prescribed fields are recalculated (except those with interpolation + ! options) + call set_prescribed_field_values(states, exclude_interpolated = .true.) + ! If strong bc or weak that overwrite then enforce the bc on the fields + call set_dirichlet_consistent(states) + ! Insert aliased fields in state + call alias_fields(states) + + call incrementeventcounter(EVENT_ADAPTIVITY) + call incrementeventcounter(EVENT_MESH_MOVEMENT) + + ewrite(1, *) "Exiting adapt_state_prescribed_internal" + + end subroutine adapt_state_prescribed_internal + + subroutine adapt_state_prescribed_module_check_options + !!< Check prescribed adaptivity related options + + if(.not. have_option(base_path)) then + ! Nothing to check + return + end if + + ewrite(2, *) "Checking prescribed adaptivity options" + + if(isparallel()) then + FLExit("Prescribed adaptivity cannot be used in parallel") + end if + + ewrite(2, *) "Finished checking prescribed adaptivity options" + + end subroutine adapt_state_prescribed_module_check_options end module adapt_state_prescribed_module diff --git a/assemble/Adapt_State_Unittest.F90 b/assemble/Adapt_State_Unittest.F90 index a2c02e195b..7cae029f8d 100644 --- a/assemble/Adapt_State_Unittest.F90 +++ b/assemble/Adapt_State_Unittest.F90 @@ -29,292 +29,292 @@ module adapt_state_unittest_module - use fldebug - use global_parameters, only: FIELD_NAME_LEN - use futils, only: present_and_true - use eventcounter - use elements - use parallel_tools - use fields - use state_module - use adapt_integration, adapt_mesh_3d => adapt_mesh - use node_boundary - use field_options - use interpolation_module - use mba2d_integration - use sam_integration - use adapt_state_module - - implicit none - - private - - public :: adapt_state_unittest - - interface adapt_state_unittest - module procedure adapt_state_unittest_single, adapt_state_unittest_multiple - end interface adapt_state_unittest + use fldebug + use global_parameters, only: FIELD_NAME_LEN + use futils, only: present_and_true + use eventcounter + use elements + use parallel_tools + use fields + use state_module + use adapt_integration, adapt_mesh_3d => adapt_mesh + use node_boundary + use field_options + use interpolation_module + use mba2d_integration + use sam_integration + use adapt_state_module + + implicit none + + private + + public :: adapt_state_unittest + + interface adapt_state_unittest + module procedure adapt_state_unittest_single, adapt_state_unittest_multiple + end interface adapt_state_unittest contains - subroutine adapt_state_unittest_single(state, metric, deallocate_metric) - !!< A simple mesh adaptivity wrapper for use by unittests *only*. Single - !!< state version. By default, does not deallocate the metric. - - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: metric - !! If present and .true., deallocate the metric - logical, optional, intent(in) :: deallocate_metric - - type(state_type), dimension(1) :: states - - states = (/state/) - call adapt_state_unittest(states, metric, deallocate_metric = deallocate_metric) - state = states(1) - - end subroutine adapt_state_unittest_single - - subroutine adapt_state_unittest_multiple(states, metric, deallocate_metric) - !!< A simple mesh adaptivity wrapper for use by unittests *only*. Multiple - !!< state version. By default, does not deallocate the metric. - - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), intent(inout) :: metric - !! If present and .true., deallocate the metric - logical, optional, intent(in) :: deallocate_metric - - integer :: i - integer, dimension(:), pointer :: node_ownership - type(mesh_type), pointer :: old_linear_mesh - type(state_type), dimension(size(states)) :: interpolate_states - type(vector_field) :: new_positions, old_positions - integer :: adapt_no, adapt_cnt - character(len=FIELD_NAME_LEN) :: mesh_name - - ewrite(1, *) "In adapt_state_unittest" - - if(isparallel()) then - adapt_cnt = 3 - mesh_name=trim(states(1)%mesh_names(1)) - call strip_level_2_halo(states, metric, external_mesh_name=mesh_name) - else - adapt_cnt = 1 - end if - - do adapt_no=1,adapt_cnt - ! Select mesh to adapt. Has to be linear and continuous. - call find_mesh_to_adapt_unittest(states(1), old_linear_mesh) - ewrite(2, *) "External mesh to be adapted: " // trim(old_linear_mesh%name) - - ! Extract the mesh field to be adapted (takes a reference) - old_positions = get_coordinate_field(states(1), old_linear_mesh) - ewrite(2, *) "Mesh field to be adapted: " // trim(old_positions%name) - assert(old_positions%mesh == old_linear_mesh) - - call initialise_boundcount(old_linear_mesh, old_positions) - - do i = 1, size(states) - ! Reference fields to be interpolated in interpolate_states - call select_fields_to_interpolate_unittest(states(i), interpolate_states(i)) - ! Deallocate no-longer needed (recoverable) fields - call deallocate(states(i)) - end do + subroutine adapt_state_unittest_single(state, metric, deallocate_metric) + !!< A simple mesh adaptivity wrapper for use by unittests *only*. Single + !!< state version. By default, does not deallocate the metric. - if(isparallel()) then - ! Update the fields to be interpolated, just in case - call halo_update(interpolate_states, level = 1) - end if + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: metric + !! If present and .true., deallocate the metric + logical, optional, intent(in) :: deallocate_metric - ! Generate a new mesh field based on the current mesh field and the input - ! metric using libadapt - if (old_positions%dim == 3) then - call adapt_mesh_3d(old_positions, metric, new_positions, node_ownership = node_ownership) - else - call adapt_mesh_mba2d(old_positions, metric, new_positions) - end if + type(state_type), dimension(1) :: states - ! We're done with old_positions, so we may deallocate it - call deallocate(old_positions) + states = (/state/) + call adapt_state_unittest(states, metric, deallocate_metric = deallocate_metric) + state = states(1) - do i = 1, size(states) - ! Reallocate states based upon the new mesh field - call reallocate_state_unittest(states(i), interpolate_states(i), new_positions) - end do + end subroutine adapt_state_unittest_single - if(isparallel()) then - ! If there are remaining adapt iterations, or we will be calling - ! sam_drive, insert the old metric into interpolate_states(1) and a - ! new metric into states(1), for interpolation - call insert_metric_for_interpolation(metric, new_positions%mesh, interpolate_states(1), states(1)) - end if + subroutine adapt_state_unittest_multiple(states, metric, deallocate_metric) + !!< A simple mesh adaptivity wrapper for use by unittests *only*. Multiple + !!< state version. By default, does not deallocate the metric. - ! We're done with the new_positions, so we may drop our reference - call deallocate(new_positions) + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), intent(inout) :: metric + !! If present and .true., deallocate the metric + logical, optional, intent(in) :: deallocate_metric - ! Interpolate the fields using linear interpolation - call linear_interpolate_states(interpolate_states, states) + integer :: i + integer, dimension(:), pointer :: node_ownership + type(mesh_type), pointer :: old_linear_mesh + type(state_type), dimension(size(states)) :: interpolate_states + type(vector_field) :: new_positions, old_positions + integer :: adapt_no, adapt_cnt + character(len=FIELD_NAME_LEN) :: mesh_name - ! Deallocate the old fields used for interpolation, referenced in - ! interpolate_states - do i = 1, size(states) - call deallocate(interpolate_states(i)) - end do - ! Deallocate the node ownership mapping - if (old_positions%dim == 3) then - deallocate(node_ownership) - nullify(node_ownership) - end if + ewrite(1, *) "In adapt_state_unittest" if(isparallel()) then - ! If there are remaining adapt iterations, extract the new metric for - ! the next adapt iteration. If we will be calling sam_drive, always - ! extract the new metric. - metric = extract_and_remove_metric(states(1), trim(metric%name)) - ! Re-load-balance using libsam - call sam_drive(states, sam_options(adapt_no, adapt_cnt), metric = metric, external_mesh_name=mesh_name) - if(adapt_no == adapt_cnt .and. present_and_true(deallocate_metric)) then - ! On the last adapt iteration the metric was interpolated - ! only for sam_drive, hence it must be deallocated - call deallocate(metric) - end if + adapt_cnt = 3 + mesh_name=trim(states(1)%mesh_names(1)) + call strip_level_2_halo(states, metric, external_mesh_name=mesh_name) + else + adapt_cnt = 1 end if - call incrementeventcounter(EVENT_ADAPTIVITY) - call incrementeventcounter(EVENT_MESH_MOVEMENT) - end do + do adapt_no=1,adapt_cnt + ! Select mesh to adapt. Has to be linear and continuous. + call find_mesh_to_adapt_unittest(states(1), old_linear_mesh) + ewrite(2, *) "External mesh to be adapted: " // trim(old_linear_mesh%name) + + ! Extract the mesh field to be adapted (takes a reference) + old_positions = get_coordinate_field(states(1), old_linear_mesh) + ewrite(2, *) "Mesh field to be adapted: " // trim(old_positions%name) + assert(old_positions%mesh == old_linear_mesh) + + call initialise_boundcount(old_linear_mesh, old_positions) + + do i = 1, size(states) + ! Reference fields to be interpolated in interpolate_states + call select_fields_to_interpolate_unittest(states(i), interpolate_states(i)) + ! Deallocate no-longer needed (recoverable) fields + call deallocate(states(i)) + end do + + if(isparallel()) then + ! Update the fields to be interpolated, just in case + call halo_update(interpolate_states, level = 1) + end if + + ! Generate a new mesh field based on the current mesh field and the input + ! metric using libadapt + if (old_positions%dim == 3) then + call adapt_mesh_3d(old_positions, metric, new_positions, node_ownership = node_ownership) + else + call adapt_mesh_mba2d(old_positions, metric, new_positions) + end if + + ! We're done with old_positions, so we may deallocate it + call deallocate(old_positions) + + do i = 1, size(states) + ! Reallocate states based upon the new mesh field + call reallocate_state_unittest(states(i), interpolate_states(i), new_positions) + end do + + if(isparallel()) then + ! If there are remaining adapt iterations, or we will be calling + ! sam_drive, insert the old metric into interpolate_states(1) and a + ! new metric into states(1), for interpolation + call insert_metric_for_interpolation(metric, new_positions%mesh, interpolate_states(1), states(1)) + end if + + ! We're done with the new_positions, so we may drop our reference + call deallocate(new_positions) + + ! Interpolate the fields using linear interpolation + call linear_interpolate_states(interpolate_states, states) + + ! Deallocate the old fields used for interpolation, referenced in + ! interpolate_states + do i = 1, size(states) + call deallocate(interpolate_states(i)) + end do + ! Deallocate the node ownership mapping + if (old_positions%dim == 3) then + deallocate(node_ownership) + nullify(node_ownership) + end if + + if(isparallel()) then + ! If there are remaining adapt iterations, extract the new metric for + ! the next adapt iteration. If we will be calling sam_drive, always + ! extract the new metric. + metric = extract_and_remove_metric(states(1), trim(metric%name)) + ! Re-load-balance using libsam + call sam_drive(states, sam_options(adapt_no, adapt_cnt), metric = metric, external_mesh_name=mesh_name) + if(adapt_no == adapt_cnt .and. present_and_true(deallocate_metric)) then + ! On the last adapt iteration the metric was interpolated + ! only for sam_drive, hence it must be deallocated + call deallocate(metric) + end if + end if + + call incrementeventcounter(EVENT_ADAPTIVITY) + call incrementeventcounter(EVENT_MESH_MOVEMENT) + end do - ewrite(1, *) "Exiting adapt_state_unittest" + ewrite(1, *) "Exiting adapt_state_unittest" - end subroutine adapt_state_unittest_multiple + end subroutine adapt_state_unittest_multiple - subroutine find_mesh_to_adapt_unittest(state, linear_mesh) - !!< Find a linear mesh to adapt (for use by adapt_state_unittest) + subroutine find_mesh_to_adapt_unittest(state, linear_mesh) + !!< Find a linear mesh to adapt (for use by adapt_state_unittest) - type(state_type), intent(in) :: state - type(mesh_type), pointer :: linear_mesh + type(state_type), intent(in) :: state + type(mesh_type), pointer :: linear_mesh - integer :: stat - type(element_type), pointer :: shape + integer :: stat + type(element_type), pointer :: shape - nullify(linear_mesh) + nullify(linear_mesh) - linear_mesh => extract_mesh(state, "CoordinateMesh", stat) - if(stat /= 0) linear_mesh => extract_mesh(state, "Mesh") - shape => ele_shape(linear_mesh, 1) - if(linear_mesh%continuity /= 0 .or. shape%degree /= 1) then - FLAbort("Failed to find a continuous linear mesh") - end if + linear_mesh => extract_mesh(state, "CoordinateMesh", stat) + if(stat /= 0) linear_mesh => extract_mesh(state, "Mesh") + shape => ele_shape(linear_mesh, 1) + if(linear_mesh%continuity /= 0 .or. shape%degree /= 1) then + FLAbort("Failed to find a continuous linear mesh") + end if - end subroutine find_mesh_to_adapt_unittest + end subroutine find_mesh_to_adapt_unittest - subroutine select_fields_to_interpolate_unittest(state, interpolate_state) - !!< Select all fields and meshes in state in interpolate_state (for - !!< use by adapt_state_unittest) + subroutine select_fields_to_interpolate_unittest(state, interpolate_state) + !!< Select all fields and meshes in state in interpolate_state (for + !!< use by adapt_state_unittest) - type(state_type), intent(in):: state - type(state_type), intent(out):: interpolate_state + type(state_type), intent(in):: state + type(state_type), intent(out):: interpolate_state - integer :: i - type(mesh_type), pointer :: mesh - type(scalar_field), pointer :: sfield - type(tensor_field), pointer :: tfield - type(vector_field), pointer :: vfield + integer :: i + type(mesh_type), pointer :: mesh + type(scalar_field), pointer :: sfield + type(tensor_field), pointer :: tfield + type(vector_field), pointer :: vfield - call nullify(interpolate_state) + call nullify(interpolate_state) - do i = 1, mesh_count(state) - mesh => extract_mesh(state, i) - call insert(interpolate_state, mesh, mesh%name) - end do + do i = 1, mesh_count(state) + mesh => extract_mesh(state, i) + call insert(interpolate_state, mesh, mesh%name) + end do - do i = 1, scalar_field_count(state) - sfield => extract_scalar_field(state, i) - call insert(interpolate_state, sfield, sfield%name) - end do + do i = 1, scalar_field_count(state) + sfield => extract_scalar_field(state, i) + call insert(interpolate_state, sfield, sfield%name) + end do - do i = 1, vector_field_count(state) - vfield => extract_vector_field(state, i) - call insert(interpolate_state, vfield, vfield%name) - end do + do i = 1, vector_field_count(state) + vfield => extract_vector_field(state, i) + call insert(interpolate_state, vfield, vfield%name) + end do - do i = 1, tensor_field_count(state) - tfield => extract_tensor_field(state, i) - call insert(interpolate_state, tfield, tfield%name) - end do + do i = 1, tensor_field_count(state) + tfield => extract_tensor_field(state, i) + call insert(interpolate_state, tfield, tfield%name) + end do - end subroutine select_fields_to_interpolate_unittest + end subroutine select_fields_to_interpolate_unittest - subroutine reallocate_state_unittest(new_state, old_state, new_positions) - !!< Allocate a new_state based on old_state, with a new base mesh defined - !!< by new_positions (for use by adapt_state_unittest) + subroutine reallocate_state_unittest(new_state, old_state, new_positions) + !!< Allocate a new_state based on old_state, with a new base mesh defined + !!< by new_positions (for use by adapt_state_unittest) - type(state_type), intent(out) :: new_state - type(state_type), intent(in) :: old_state - type(vector_field), intent(in) :: new_positions + type(state_type), intent(out) :: new_state + type(state_type), intent(in) :: old_state + type(vector_field), intent(in) :: new_positions - integer :: i, new_elements, new_nodes - type(mesh_type) :: new_mesh - type(mesh_type), pointer :: old_mesh - type(scalar_field) :: new_sfield - type(scalar_field), pointer :: old_sfield - type(tensor_field) :: new_tfield - type(tensor_field), pointer :: old_tfield - type(vector_field) :: new_vfield - type(vector_field), pointer :: old_vfield + integer :: i, new_elements, new_nodes + type(mesh_type) :: new_mesh + type(mesh_type), pointer :: old_mesh + type(scalar_field) :: new_sfield + type(scalar_field), pointer :: old_sfield + type(tensor_field) :: new_tfield + type(tensor_field), pointer :: old_tfield + type(vector_field) :: new_vfield + type(vector_field), pointer :: old_vfield - call nullify(new_state) + call nullify(new_state) - new_elements = ele_count(new_positions) - new_nodes = node_count(new_positions) + new_elements = ele_count(new_positions) + new_nodes = node_count(new_positions) - call insert(new_state, new_positions, new_positions%name) - call insert(new_state, new_positions%mesh, new_positions%mesh%name) + call insert(new_state, new_positions, new_positions%name) + call insert(new_state, new_positions%mesh, new_positions%mesh%name) - do i = 1, mesh_count(old_state) - old_mesh => extract_mesh(old_state, i) - if(trim(old_mesh%name) == trim(new_positions%mesh%name)) cycle - call allocate(new_mesh, new_nodes, new_elements, old_mesh%shape, old_mesh%name) - call insert(new_state, new_mesh, new_mesh%name) - call deallocate(new_mesh) - end do + do i = 1, mesh_count(old_state) + old_mesh => extract_mesh(old_state, i) + if(trim(old_mesh%name) == trim(new_positions%mesh%name)) cycle + call allocate(new_mesh, new_nodes, new_elements, old_mesh%shape, old_mesh%name) + call insert(new_state, new_mesh, new_mesh%name) + call deallocate(new_mesh) + end do - do i = 1, scalar_field_count(old_state) - old_sfield => extract_scalar_field(old_state, i) - if(trim(old_sfield%mesh%name) == trim(new_positions%mesh%name)) then - new_mesh = new_positions%mesh - else - new_mesh = extract_mesh(new_state, old_sfield%mesh%name) - end if - call allocate(new_sfield, new_mesh, old_sfield%name) - call insert(new_state, new_sfield, new_sfield%name) - call deallocate(new_sfield) - end do - - do i = 1, vector_field_count(old_state) - old_vfield => extract_vector_field(old_state, i) - if(trim(old_vfield%name) == trim(new_positions%name)) cycle - if(trim(old_vfield%mesh%name) == trim(new_positions%mesh%name)) then - new_mesh = new_positions%mesh - else - new_mesh = extract_mesh(new_state, old_vfield%mesh%name) - end if - call allocate(new_vfield, old_vfield%dim, new_mesh, old_vfield%name) - call insert(new_state, new_vfield, new_vfield%name) - call deallocate(new_vfield) - end do - - do i = 1, tensor_field_count(old_state) - old_tfield => extract_tensor_field(old_state, i) - if(trim(old_tfield%mesh%name) == trim(new_positions%mesh%name)) then - new_mesh = new_positions%mesh - else - new_mesh = extract_mesh(new_state, old_tfield%mesh%name) - end if - call allocate(new_tfield, new_mesh, old_tfield%name) - call insert(new_state, new_tfield, new_tfield%name) - call deallocate(new_tfield) - end do + do i = 1, scalar_field_count(old_state) + old_sfield => extract_scalar_field(old_state, i) + if(trim(old_sfield%mesh%name) == trim(new_positions%mesh%name)) then + new_mesh = new_positions%mesh + else + new_mesh = extract_mesh(new_state, old_sfield%mesh%name) + end if + call allocate(new_sfield, new_mesh, old_sfield%name) + call insert(new_state, new_sfield, new_sfield%name) + call deallocate(new_sfield) + end do + + do i = 1, vector_field_count(old_state) + old_vfield => extract_vector_field(old_state, i) + if(trim(old_vfield%name) == trim(new_positions%name)) cycle + if(trim(old_vfield%mesh%name) == trim(new_positions%mesh%name)) then + new_mesh = new_positions%mesh + else + new_mesh = extract_mesh(new_state, old_vfield%mesh%name) + end if + call allocate(new_vfield, old_vfield%dim, new_mesh, old_vfield%name) + call insert(new_state, new_vfield, new_vfield%name) + call deallocate(new_vfield) + end do + + do i = 1, tensor_field_count(old_state) + old_tfield => extract_tensor_field(old_state, i) + if(trim(old_tfield%mesh%name) == trim(new_positions%mesh%name)) then + new_mesh = new_positions%mesh + else + new_mesh = extract_mesh(new_state, old_tfield%mesh%name) + end if + call allocate(new_tfield, new_mesh, old_tfield%name) + call insert(new_state, new_tfield, new_tfield%name) + call deallocate(new_tfield) + end do - end subroutine reallocate_state_unittest + end subroutine reallocate_state_unittest end module adapt_state_unittest_module diff --git a/assemble/Adaptivity_1D.F90 b/assemble/Adaptivity_1D.F90 index 7afee9d939..5d496124ef 100644 --- a/assemble/Adaptivity_1D.F90 +++ b/assemble/Adaptivity_1D.F90 @@ -29,240 +29,240 @@ module adaptivity_1d - use fldebug - use spud - use futils, only: present_and_true - use elements - use parallel_tools - use metric_tools, only: edge_length_from_eigenvalue - use transform_elements - use fields - use hadapt_metric_based_extrude - use node_locking - use tictoc + use fldebug + use spud + use futils, only: present_and_true + use elements + use parallel_tools + use metric_tools, only: edge_length_from_eigenvalue + use transform_elements + use fields + use hadapt_metric_based_extrude + use node_locking + use tictoc - implicit none + implicit none - private + private - public :: adapt_mesh_1d, adaptivity_1d_check_options + public :: adapt_mesh_1d, adaptivity_1d_check_options contains - subroutine adapt_mesh_1d(old_positions, metric, new_positions, node_ownership, force_preserve_regions) - type(vector_field), intent(in) :: old_positions - type(tensor_field), intent(inout) :: metric - type(vector_field), intent(out) :: new_positions - integer, dimension(:), pointer, optional :: node_ownership - logical, optional, intent(in) :: force_preserve_regions + subroutine adapt_mesh_1d(old_positions, metric, new_positions, node_ownership, force_preserve_regions) + type(vector_field), intent(in) :: old_positions + type(tensor_field), intent(inout) :: metric + type(vector_field), intent(out) :: new_positions + integer, dimension(:), pointer, optional :: node_ownership + logical, optional, intent(in) :: force_preserve_regions - integer :: i - integer, dimension(:), allocatable :: locked_nodes - logical :: preserve_regions - type(element_type), pointer :: shape - type(scalar_field) :: sizing + integer :: i + integer, dimension(:), allocatable :: locked_nodes + logical :: preserve_regions + type(element_type), pointer :: shape + type(scalar_field) :: sizing - ewrite(1, *) "In adapt_mesh_1d" + ewrite(1, *) "In adapt_mesh_1d" - assert(old_positions%dim == 1) - assert(old_positions%mesh == metric%mesh) + assert(old_positions%dim == 1) + assert(old_positions%mesh == metric%mesh) - preserve_regions = have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions") .or. & + preserve_regions = have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions") .or. & & present_and_true(force_preserve_regions) - if(halo_count(old_positions) > 0) then - FLExit("1D adaptivity does not work in parallel") - end if - call get_locked_nodes(old_positions, locked_nodes) - if(size(locked_nodes) > 0) then - FLExit("Node locking is not supported by 1D adaptivity") - end if - deallocate(locked_nodes) - - call allocate(sizing, metric%mesh, name = "SizingFunction") - do i = 1, node_count(sizing) - call set(sizing, i, edge_length_from_eigenvalue(node_val(metric, 1, 1, i))) - end do - - assert(ele_count(old_positions) > 0) - shape => ele_shape(old_positions, 1) - ! since we're using the shape of the old mesh, this shape and its quadrature will survive the adapt - ! and should not show up in print_tagged_refences() - shape%refcount%tagged=.false. - shape%quadrature%refcount%tagged=.false. - - ! TODO: Sort old_positions into descending coordinate order here - - assert(descending_coordinate_ordered(old_positions)) - - call tic(TICTOC_ID_SERIAL_ADAPT) - call adapt_1d(old_positions, sizing, shape, new_positions, preserve_regions=preserve_regions) - call toc(TICTOC_ID_SERIAL_ADAPT) - - call deallocate(sizing) - - if (.not. descending_coordinate_ordered(new_positions)) then - ewrite(-1,*) "To use 1D adaptivity you need an input mesh for which the ordering of the nodes is such that " // & - "their coordinates decrease with increasing node number. If you use the 'interval' script to produce a " // & - "mesh, you can achieve this by adding the '--reverse' option." - FLExit("To be adapted 1D mesh not in descending order.") - end if - - ! adapt_1d doesn't build a complete mesh. Build the rest of the mesh. - assert(ele_count(new_positions) == node_count(new_positions) - 1) - do i = 1, ele_count(new_positions) - call set_ele_nodes(new_positions%mesh, i, (/i, i + 1/)) - end do - ! note that adapt_1d has already allocated and inserted the region_ids - ! if they were meant to be preserved - ! HOWEVER adapt_1d does assume that the elements as well as the nodes - ! are ordered so if this assumption changes here then - ! new_positions%mesh%region_ids will have to be reordered too! - assert(surface_element_count(old_positions) == 2) - call add_faces(new_positions%mesh, sndgln = (/1, node_count(new_positions)/), boundary_ids = old_positions%mesh%faces%boundary_ids) - new_positions%name = old_positions%name - new_positions%mesh%name = old_positions%mesh%name - new_positions%option_path = old_positions%option_path - new_positions%mesh%option_path = old_positions%mesh%option_path - - if(present(node_ownership)) call generate_1d_node_ownership(old_positions, new_positions, node_ownership) - - ewrite(1, *) "Exiting adapt_mesh_1d" - - end subroutine adapt_mesh_1d - - subroutine generate_1d_node_ownership(old_positions, new_positions, node_ownership) - !!< Generate the 1d node ownership list. Assumes the old and new positions - !!< are descending coordinate ordered. - - type(vector_field), intent(in) :: old_positions - type(vector_field), intent(in) :: new_positions - integer, dimension(:), pointer :: node_ownership - - integer :: ele, node - - assert(descending_coordinate_ordered(old_positions)) - assert(descending_coordinate_ordered(new_positions)) - - assert(node_count(old_positions) > 1) - assert(node_count(new_positions) > 0) - - assert(.not. associated(node_ownership)) - allocate(node_ownership(node_count(new_positions))) -#ifdef DDEBUG - node_ownership = -1 -#endif + if(halo_count(old_positions) > 0) then + FLExit("1D adaptivity does not work in parallel") + end if + call get_locked_nodes(old_positions, locked_nodes) + if(size(locked_nodes) > 0) then + FLExit("Node locking is not supported by 1D adaptivity") + end if + deallocate(locked_nodes) + + call allocate(sizing, metric%mesh, name = "SizingFunction") + do i = 1, node_count(sizing) + call set(sizing, i, edge_length_from_eigenvalue(node_val(metric, 1, 1, i))) + end do + + assert(ele_count(old_positions) > 0) + shape => ele_shape(old_positions, 1) + ! since we're using the shape of the old mesh, this shape and its quadrature will survive the adapt + ! and should not show up in print_tagged_refences() + shape%refcount%tagged=.false. + shape%quadrature%refcount%tagged=.false. + + ! TODO: Sort old_positions into descending coordinate order here - ! The first node is owned by the first element - node_ownership(1) = 1 + assert(descending_coordinate_ordered(old_positions)) - ele = 1 - new_pos_loop: do node = 2, node_count(new_positions) - 1 - do while(node_val(new_positions, 1, node) < node_val(old_positions, 1, ele + 1)) - ele = ele + 1 - if(ele >= node_count(old_positions)) exit new_pos_loop + call tic(TICTOC_ID_SERIAL_ADAPT) + call adapt_1d(old_positions, sizing, shape, new_positions, preserve_regions=preserve_regions) + call toc(TICTOC_ID_SERIAL_ADAPT) + + call deallocate(sizing) + + if (.not. descending_coordinate_ordered(new_positions)) then + ewrite(-1,*) "To use 1D adaptivity you need an input mesh for which the ordering of the nodes is such that " // & + "their coordinates decrease with increasing node number. If you use the 'interval' script to produce a " // & + "mesh, you can achieve this by adding the '--reverse' option." + FLExit("To be adapted 1D mesh not in descending order.") + end if + + ! adapt_1d doesn't build a complete mesh. Build the rest of the mesh. + assert(ele_count(new_positions) == node_count(new_positions) - 1) + do i = 1, ele_count(new_positions) + call set_ele_nodes(new_positions%mesh, i, (/i, i + 1/)) end do + ! note that adapt_1d has already allocated and inserted the region_ids + ! if they were meant to be preserved + ! HOWEVER adapt_1d does assume that the elements as well as the nodes + ! are ordered so if this assumption changes here then + ! new_positions%mesh%region_ids will have to be reordered too! + assert(surface_element_count(old_positions) == 2) + call add_faces(new_positions%mesh, sndgln = (/1, node_count(new_positions)/), boundary_ids = old_positions%mesh%faces%boundary_ids) + new_positions%name = old_positions%name + new_positions%mesh%name = old_positions%mesh%name + new_positions%option_path = old_positions%option_path + new_positions%mesh%option_path = old_positions%mesh%option_path - ! Intermediate nodes are owned by the first element that has a left - ! coordinate less than this node coordinate - node_ownership(node) = ele - end do new_pos_loop + if(present(node_ownership)) call generate_1d_node_ownership(old_positions, new_positions, node_ownership) - ! The last node is owned by the last element - node_ownership(node_count(new_positions)) = ele_count(old_positions) + ewrite(1, *) "Exiting adapt_mesh_1d" -#ifdef DDEBUG - ! All nodes are owned by an element - assert(all(node_ownership > 0)) + end subroutine adapt_mesh_1d + + subroutine generate_1d_node_ownership(old_positions, new_positions, node_ownership) + !!< Generate the 1d node ownership list. Assumes the old and new positions + !!< are descending coordinate ordered. + + type(vector_field), intent(in) :: old_positions + type(vector_field), intent(in) :: new_positions + integer, dimension(:), pointer :: node_ownership - call verify_node_ownership(old_positions, new_positions, node_ownership) + integer :: ele, node + + assert(descending_coordinate_ordered(old_positions)) + assert(descending_coordinate_ordered(new_positions)) + + assert(node_count(old_positions) > 1) + assert(node_count(new_positions) > 0) + + assert(.not. associated(node_ownership)) + allocate(node_ownership(node_count(new_positions))) +#ifdef DDEBUG + node_ownership = -1 #endif - end subroutine generate_1d_node_ownership + ! The first node is owned by the first element + node_ownership(1) = 1 - function descending_coordinate_ordered(positions) - !!< Return whether the supplied 1D mesh is in descending coordinate order + ele = 1 + new_pos_loop: do node = 2, node_count(new_positions) - 1 + do while(node_val(new_positions, 1, node) < node_val(old_positions, 1, ele + 1)) + ele = ele + 1 + if(ele >= node_count(old_positions)) exit new_pos_loop + end do - type(vector_field), intent(in) :: positions + ! Intermediate nodes are owned by the first element that has a left + ! coordinate less than this node coordinate + node_ownership(node) = ele + end do new_pos_loop - logical :: descending_coordinate_ordered + ! The last node is owned by the last element + node_ownership(node_count(new_positions)) = ele_count(old_positions) - integer :: i +#ifdef DDEBUG + ! All nodes are owned by an element + assert(all(node_ownership > 0)) - assert(positions%dim == 1) + call verify_node_ownership(old_positions, new_positions, node_ownership) +#endif - descending_coordinate_ordered = .true. - do i = 2, node_count(positions) - if(node_val(positions, 1, i) > node_val(positions, 1, i - 1)) then - descending_coordinate_ordered = .false. - return - end if - end do + end subroutine generate_1d_node_ownership - end function descending_coordinate_ordered + function descending_coordinate_ordered(positions) + !!< Return whether the supplied 1D mesh is in descending coordinate order - subroutine verify_node_ownership(old_positions, new_positions, node_ownership) - !!< Check that the supplied node ownership list is valid. Assumes simplex - !!< elements. + type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: old_positions - type(vector_field), intent(in) :: new_positions - integer, dimension(node_count(new_positions)), intent(in) :: node_ownership + logical :: descending_coordinate_ordered - integer :: i - real, parameter :: tol = 1000.0 * epsilon(0.0) + integer :: i - do i = 1, node_count(new_positions) - call verify_node_ownership_node(node_ownership(i), i, old_positions, new_positions) - end do + assert(positions%dim == 1) + + descending_coordinate_ordered = .true. + do i = 2, node_count(positions) + if(node_val(positions, 1, i) > node_val(positions, 1, i - 1)) then + descending_coordinate_ordered = .false. + return + end if + end do - contains + end function descending_coordinate_ordered + + subroutine verify_node_ownership(old_positions, new_positions, node_ownership) + !!< Check that the supplied node ownership list is valid. Assumes simplex + !!< elements. - subroutine verify_node_ownership_node(ele, node, old_positions, new_positions) - integer, intent(in) :: ele - integer, intent(in) :: node type(vector_field), intent(in) :: old_positions type(vector_field), intent(in) :: new_positions + integer, dimension(node_count(new_positions)), intent(in) :: node_ownership + + integer :: i + real, parameter :: tol = 1000.0 * epsilon(0.0) - real, dimension(ele_loc(old_positions, ele)) :: l_coords + do i = 1, node_count(new_positions) + call verify_node_ownership_node(node_ownership(i), i, old_positions, new_positions) + end do - l_coords = local_coords(old_positions, ele, node_val(new_positions, node)) + contains - if(any(l_coords < -tol)) then - ewrite(-1, "(a,i0,a)") "For node ", node, " in the new positions" - ewrite(-1, *) "Claimed owner in the old positions: ", ele - ewrite(-1, *) "Local coordinates in claimed owner: ", l_coords - ewrite(-1, *) "Test tolerance: ", tol - FLAbort("Invalid node ownership") - end if + subroutine verify_node_ownership_node(ele, node, old_positions, new_positions) + integer, intent(in) :: ele + integer, intent(in) :: node + type(vector_field), intent(in) :: old_positions + type(vector_field), intent(in) :: new_positions - end subroutine verify_node_ownership_node + real, dimension(ele_loc(old_positions, ele)) :: l_coords - end subroutine verify_node_ownership + l_coords = local_coords(old_positions, ele, node_val(new_positions, node)) - subroutine adaptivity_1d_check_options - !!< Checks 1D adaptivity related options + if(any(l_coords < -tol)) then + ewrite(-1, "(a,i0,a)") "For node ", node, " in the new positions" + ewrite(-1, *) "Claimed owner in the old positions: ", ele + ewrite(-1, *) "Local coordinates in claimed owner: ", l_coords + ewrite(-1, *) "Test tolerance: ", tol + FLAbort("Invalid node ownership") + end if - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" - integer :: dim, stat + end subroutine verify_node_ownership_node - if(.not. have_option(base_path)) then - ! Nothing to check - return - end if + end subroutine verify_node_ownership + + subroutine adaptivity_1d_check_options + !!< Checks 1D adaptivity related options + + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + integer :: dim, stat + + if(.not. have_option(base_path)) then + ! Nothing to check + return + end if - call get_option("/geometry/dimension", dim, stat) - if(stat /= SPUD_NO_ERROR) then - ! This isn't the place to complain about this error - return - else if(have_option(base_path // "/adaptivity_library_adaptivity_1d") .or. dim == 1) then - if(dim /= 1) then - FLExit("1D adaptivity can only be used in 1D") - else if(isparallel()) then - FLExit("1D adaptivity can only be used in serial") + call get_option("/geometry/dimension", dim, stat) + if(stat /= SPUD_NO_ERROR) then + ! This isn't the place to complain about this error + return + else if(have_option(base_path // "/adaptivity_library_adaptivity_1d") .or. dim == 1) then + if(dim /= 1) then + FLExit("1D adaptivity can only be used in 1D") + else if(isparallel()) then + FLExit("1D adaptivity can only be used in serial") + end if end if - end if - end subroutine adaptivity_1d_check_options + end subroutine adaptivity_1d_check_options end module adaptivity_1d diff --git a/assemble/Advection_Diffusion_CG.F90 b/assemble/Advection_Diffusion_CG.F90 index d288f8fe04..4fb38c4f90 100644 --- a/assemble/Advection_Diffusion_CG.F90 +++ b/assemble/Advection_Diffusion_CG.F90 @@ -29,1511 +29,1511 @@ module advection_diffusion_cg - use fldebug - use global_parameters, only : FIELD_NAME_LEN, OPTION_PATH_LEN, COLOURING_CG1 - use futils, only: int2str - use quadrature - use elements - use spud - use integer_set_module + use fldebug + use global_parameters, only : FIELD_NAME_LEN, OPTION_PATH_LEN, COLOURING_CG1 + use futils, only: int2str + use quadrature + use elements + use spud + use integer_set_module #ifdef _OPENMP - use omp_lib + use omp_lib #endif - use sparse_tools - use transform_elements - use fetools - use fields - use profiler - use sparse_tools_petsc - use state_module - use boundary_conditions - use field_options - use sparsity_patterns_meshes - use boundary_conditions_from_options - use petsc_solve_state_module - use upwind_stabilisation - use multiphase_module - use colouring - - implicit none - - private - - public :: solve_field_equation_cg, advection_diffusion_cg_check_options - - character(len = *), parameter, public :: advdif_cg_m_name = "AdvectionDiffusionCGMatrix" - character(len = *), parameter, public :: advdif_cg_rhs_name = "AdvectionDiffusionCGRHS" - character(len = *), parameter, public :: advdif_cg_delta_t_name = "AdvectionDiffusionCGChange" - character(len = *), parameter, public :: advdif_cg_velocity_name = "AdvectionDiffusionCGVelocity" - - ! Stabilisation schemes - integer, parameter :: STABILISATION_NONE = 0, & - & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 - - ! Boundary condition types - integer, parameter :: BC_TYPE_NEUMANN = 1, BC_TYPE_WEAKDIRICHLET = 2, BC_TYPE_INTERNAL = 3, & - BC_TYPE_ROBIN = 4 - - ! Global variables, set by assemble_advection_diffusion_cg for use by - ! assemble_advection_diffusion_element_cg and - ! assemble_advection_diffusion_face_cg - - ! Local timestep - real :: local_dt - ! Implicitness/explicitness factor * timestep - real :: dt_theta - ! Implicitness/explicitness factor - real :: theta - ! Conservative/non-conservative discretisation factor - real :: beta - ! Stabilisation scheme - integer :: stabilisation_scheme - integer :: nu_bar_scheme - real :: nu_bar_scale - - ! equation type - integer :: equation_type - ! Implicitness/explicitness factor for density - real :: density_theta - ! Which terms do we have? - - ! Mass term? - logical :: have_mass - ! Lump mass? - logical :: lump_mass - ! Advection? - logical :: have_advection - ! Integrate advection by parts? - logical :: integrate_advection_by_parts - ! Source? - logical :: have_source - ! Add source directly to the right hand side? - logical :: add_src_directly_to_rhs - ! Absorption? - logical :: have_absorption - ! Diffusivity? - logical :: have_diffusivity - ! Isotropic diffusivity? - logical :: isotropic_diffusivity - ! Is the mesh moving? - logical :: move_mesh - ! Is this material_phase compressible? - logical :: compressible = .false. - ! Are we running a multiphase flow simulation? - logical :: multiphase + use sparse_tools + use transform_elements + use fetools + use fields + use profiler + use sparse_tools_petsc + use state_module + use boundary_conditions + use field_options + use sparsity_patterns_meshes + use boundary_conditions_from_options + use petsc_solve_state_module + use upwind_stabilisation + use multiphase_module + use colouring + + implicit none + + private + + public :: solve_field_equation_cg, advection_diffusion_cg_check_options + + character(len = *), parameter, public :: advdif_cg_m_name = "AdvectionDiffusionCGMatrix" + character(len = *), parameter, public :: advdif_cg_rhs_name = "AdvectionDiffusionCGRHS" + character(len = *), parameter, public :: advdif_cg_delta_t_name = "AdvectionDiffusionCGChange" + character(len = *), parameter, public :: advdif_cg_velocity_name = "AdvectionDiffusionCGVelocity" + + ! Stabilisation schemes + integer, parameter :: STABILISATION_NONE = 0, & + & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 + + ! Boundary condition types + integer, parameter :: BC_TYPE_NEUMANN = 1, BC_TYPE_WEAKDIRICHLET = 2, BC_TYPE_INTERNAL = 3, & + BC_TYPE_ROBIN = 4 + + ! Global variables, set by assemble_advection_diffusion_cg for use by + ! assemble_advection_diffusion_element_cg and + ! assemble_advection_diffusion_face_cg + + ! Local timestep + real :: local_dt + ! Implicitness/explicitness factor * timestep + real :: dt_theta + ! Implicitness/explicitness factor + real :: theta + ! Conservative/non-conservative discretisation factor + real :: beta + ! Stabilisation scheme + integer :: stabilisation_scheme + integer :: nu_bar_scheme + real :: nu_bar_scale + + ! equation type + integer :: equation_type + ! Implicitness/explicitness factor for density + real :: density_theta + ! Which terms do we have? + + ! Mass term? + logical :: have_mass + ! Lump mass? + logical :: lump_mass + ! Advection? + logical :: have_advection + ! Integrate advection by parts? + logical :: integrate_advection_by_parts + ! Source? + logical :: have_source + ! Add source directly to the right hand side? + logical :: add_src_directly_to_rhs + ! Absorption? + logical :: have_absorption + ! Diffusivity? + logical :: have_diffusivity + ! Isotropic diffusivity? + logical :: isotropic_diffusivity + ! Is the mesh moving? + logical :: move_mesh + ! Is this material_phase compressible? + logical :: compressible = .false. + ! Are we running a multiphase flow simulation? + logical :: multiphase contains - subroutine solve_field_equation_cg(field_name, state, istate, dt, velocity_name, iterations_taken) - !!< Construct and solve the advection-diffusion equation for the given - !!< field using a continuous Galerkin discretisation. Based on - !!< Advection_Diffusion_DG and Momentum_CG. + subroutine solve_field_equation_cg(field_name, state, istate, dt, velocity_name, iterations_taken) + !!< Construct and solve the advection-diffusion equation for the given + !!< field using a continuous Galerkin discretisation. Based on + !!< Advection_Diffusion_DG and Momentum_CG. - character(len = *), intent(in) :: field_name - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate - real, intent(in) :: dt - character(len = *), optional, intent(in) :: velocity_name - integer, intent(out), optional :: iterations_taken + character(len = *), intent(in) :: field_name + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate + real, intent(in) :: dt + character(len = *), optional, intent(in) :: velocity_name + integer, intent(out), optional :: iterations_taken - type(csr_matrix) :: matrix - type(scalar_field) :: delta_t, rhs - type(scalar_field), pointer :: t + type(csr_matrix) :: matrix + type(scalar_field) :: delta_t, rhs + type(scalar_field), pointer :: t - ewrite(1, *) "In solve_field_equation_cg" + ewrite(1, *) "In solve_field_equation_cg" - ewrite(2, *) "Solving advection-diffusion equation for field " // & + ewrite(2, *) "Solving advection-diffusion equation for field " // & & trim(field_name) // " in state " // trim(state(istate)%name) - call initialise_advection_diffusion_cg(field_name, t, delta_t, matrix, rhs, state(istate)) + call initialise_advection_diffusion_cg(field_name, t, delta_t, matrix, rhs, state(istate)) - call profiler_tic(t, "assembly") - call assemble_advection_diffusion_cg(t, matrix, rhs, state(istate), dt, velocity_name = velocity_name) - - ! Note: the assembly of the heat transfer term is done here to avoid - ! passing in the whole state array to assemble_advection_diffusion_cg. - if(have_option("/multiphase_interaction/heat_transfer") .and. & - equation_type_index(trim(t%option_path)) == FIELD_EQUATION_INTERNALENERGY) then - call add_heat_transfer(state, istate, t, matrix, rhs) - end if - call profiler_toc(t, "assembly") + call profiler_tic(t, "assembly") + call assemble_advection_diffusion_cg(t, matrix, rhs, state(istate), dt, velocity_name = velocity_name) - call profiler_tic(t, "solve_total") - call solve_advection_diffusion_cg(t, delta_t, matrix, rhs, state(istate), & - iterations_taken = iterations_taken) - call profiler_toc(t, "solve_total") + ! Note: the assembly of the heat transfer term is done here to avoid + ! passing in the whole state array to assemble_advection_diffusion_cg. + if(have_option("/multiphase_interaction/heat_transfer") .and. & + equation_type_index(trim(t%option_path)) == FIELD_EQUATION_INTERNALENERGY) then + call add_heat_transfer(state, istate, t, matrix, rhs) + end if + call profiler_toc(t, "assembly") - call profiler_tic(t, "assembly") - call apply_advection_diffusion_cg_change(t, delta_t, dt) + call profiler_tic(t, "solve_total") + call solve_advection_diffusion_cg(t, delta_t, matrix, rhs, state(istate), & + iterations_taken = iterations_taken) + call profiler_toc(t, "solve_total") - call finalise_advection_diffusion_cg(delta_t, matrix, rhs) - call profiler_toc(t, "assembly") + call profiler_tic(t, "assembly") + call apply_advection_diffusion_cg_change(t, delta_t, dt) - ewrite(1, *) "Exiting solve_field_equation_cg" + call finalise_advection_diffusion_cg(delta_t, matrix, rhs) + call profiler_toc(t, "assembly") - end subroutine solve_field_equation_cg + ewrite(1, *) "Exiting solve_field_equation_cg" - subroutine initialise_advection_diffusion_cg(field_name, t, delta_t, matrix, rhs, state) - character(len = *), intent(in) :: field_name - type(scalar_field), pointer :: t - type(scalar_field), intent(out) :: delta_t - type(csr_matrix), intent(out) :: matrix - type(scalar_field), intent(out) :: rhs - type(state_type), intent(inout) :: state + end subroutine solve_field_equation_cg - integer :: stat - type(csr_sparsity), pointer :: sparsity - type(scalar_field), pointer :: t_old + subroutine initialise_advection_diffusion_cg(field_name, t, delta_t, matrix, rhs, state) + character(len = *), intent(in) :: field_name + type(scalar_field), pointer :: t + type(scalar_field), intent(out) :: delta_t + type(csr_matrix), intent(out) :: matrix + type(scalar_field), intent(out) :: rhs + type(state_type), intent(inout) :: state + + integer :: stat + type(csr_sparsity), pointer :: sparsity + type(scalar_field), pointer :: t_old + + t => extract_scalar_field(state, field_name) + if(t%mesh%continuity /= 0) then + FLExit("CG advection-diffusion requires a continuous mesh") + end if - t => extract_scalar_field(state, field_name) - if(t%mesh%continuity /= 0) then - FLExit("CG advection-diffusion requires a continuous mesh") - end if + t_old => extract_scalar_field(state, "Old" // field_name, stat = stat) + if(stat == 0) then + assert(t_old%mesh == t%mesh) + ! Reset t to value at the beginning of the timestep + call set(t, t_old) + end if - t_old => extract_scalar_field(state, "Old" // field_name, stat = stat) - if(stat == 0) then - assert(t_old%mesh == t%mesh) - ! Reset t to value at the beginning of the timestep - call set(t, t_old) - end if + sparsity => get_csr_sparsity_firstorder(state, t%mesh, t%mesh) - sparsity => get_csr_sparsity_firstorder(state, t%mesh, t%mesh) + call allocate(matrix, sparsity, name = advdif_cg_m_name) + call allocate(rhs, t%mesh, name = advdif_cg_rhs_name) + call allocate(delta_t, t%mesh, name = trim(field_name)//advdif_cg_delta_t_name) - call allocate(matrix, sparsity, name = advdif_cg_m_name) - call allocate(rhs, t%mesh, name = advdif_cg_rhs_name) - call allocate(delta_t, t%mesh, name = trim(field_name)//advdif_cg_delta_t_name) + call set_advection_diffusion_cg_initial_guess(delta_t) - call set_advection_diffusion_cg_initial_guess(delta_t) + end subroutine initialise_advection_diffusion_cg - end subroutine initialise_advection_diffusion_cg + subroutine finalise_advection_diffusion_cg(delta_t, matrix, rhs) + type(scalar_field), intent(inout) :: delta_t + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs - subroutine finalise_advection_diffusion_cg(delta_t, matrix, rhs) - type(scalar_field), intent(inout) :: delta_t - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs + call deallocate(matrix) + call deallocate(rhs) + call deallocate(delta_t) - call deallocate(matrix) - call deallocate(rhs) - call deallocate(delta_t) + end subroutine finalise_advection_diffusion_cg - end subroutine finalise_advection_diffusion_cg + subroutine set_advection_diffusion_cg_initial_guess(delta_t) + type(scalar_field), intent(inout) :: delta_t - subroutine set_advection_diffusion_cg_initial_guess(delta_t) - type(scalar_field), intent(inout) :: delta_t + call zero(delta_t) - call zero(delta_t) + end subroutine set_advection_diffusion_cg_initial_guess - end subroutine set_advection_diffusion_cg_initial_guess + subroutine assemble_advection_diffusion_cg(t, matrix, rhs, state, dt, velocity_name) + type(scalar_field), intent(inout) :: t + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(state_type), intent(inout) :: state + real, intent(in) :: dt + character(len = *), optional, intent(in) :: velocity_name - subroutine assemble_advection_diffusion_cg(t, matrix, rhs, state, dt, velocity_name) - type(scalar_field), intent(inout) :: t - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(state_type), intent(inout) :: state - real, intent(in) :: dt - character(len = *), optional, intent(in) :: velocity_name + character(len = FIELD_NAME_LEN) :: lvelocity_name, velocity_equation_type + integer :: i, stat + integer, dimension(:), allocatable :: t_bc_types + type(scalar_field) :: t_bc, t_bc_2 + type(scalar_field), pointer :: absorption, sinking_velocity, source + type(tensor_field), pointer :: diffusivity + type(vector_field) :: velocity + type(vector_field), pointer :: gravity_direction, temp_velocity_ptr, velocity_ptr, grid_velocity + type(vector_field), pointer :: positions, old_positions, new_positions + type(scalar_field), target :: dummydensity + type(scalar_field), pointer :: density, olddensity + character(len = FIELD_NAME_LEN) :: density_name + type(scalar_field), pointer :: pressure - character(len = FIELD_NAME_LEN) :: lvelocity_name, velocity_equation_type - integer :: i, stat - integer, dimension(:), allocatable :: t_bc_types - type(scalar_field) :: t_bc, t_bc_2 - type(scalar_field), pointer :: absorption, sinking_velocity, source - type(tensor_field), pointer :: diffusivity - type(vector_field) :: velocity - type(vector_field), pointer :: gravity_direction, temp_velocity_ptr, velocity_ptr, grid_velocity - type(vector_field), pointer :: positions, old_positions, new_positions - type(scalar_field), target :: dummydensity - type(scalar_field), pointer :: density, olddensity - character(len = FIELD_NAME_LEN) :: density_name - type(scalar_field), pointer :: pressure + ! Volume fraction fields for multiphase flow simulation + type(scalar_field), pointer :: vfrac + type(scalar_field) :: nvfrac ! Non-linear version - ! Volume fraction fields for multiphase flow simulation - type(scalar_field), pointer :: vfrac - type(scalar_field) :: nvfrac ! Non-linear version - - !! Coloring data structures for OpenMP parallization - type(integer_set), dimension(:), pointer :: colours - integer :: clr, nnid, len, ele - integer :: num_threads, thread_num + !! Coloring data structures for OpenMP parallization + type(integer_set), dimension(:), pointer :: colours + integer :: clr, nnid, len, ele + integer :: num_threads, thread_num - type(element_type), dimension(:), allocatable :: supg_element + type(element_type), dimension(:), allocatable :: supg_element - ewrite(1, *) "In assemble_advection_diffusion_cg" + ewrite(1, *) "In assemble_advection_diffusion_cg" - assert(mesh_dim(rhs) == mesh_dim(t)) - assert(ele_count(rhs) == ele_count(t)) + assert(mesh_dim(rhs) == mesh_dim(t)) + assert(ele_count(rhs) == ele_count(t)) - if(present(velocity_name)) then - lvelocity_name = velocity_name - else - lvelocity_name = "NonlinearVelocity" - end if + if(present(velocity_name)) then + lvelocity_name = velocity_name + else + lvelocity_name = "NonlinearVelocity" + end if #ifdef _OPENMP - num_threads = omp_get_max_threads() + num_threads = omp_get_max_threads() #else - num_threads = 1 + num_threads = 1 #endif - ! Step 1: Pull fields out of state - - ! Coordinate - positions => extract_vector_field(state, "Coordinate") - ewrite_minmax(positions) - assert(positions%dim == mesh_dim(t)) - assert(ele_count(positions) == ele_count(t)) - - ! Velocity - velocity_ptr => extract_vector_field(state, lvelocity_name, stat = stat) - if(stat == 0) then - assert(velocity_ptr%dim == mesh_dim(t)) - assert(ele_count(velocity_ptr) == ele_count(t)) - - ewrite(2, *) "Velocity:" - ewrite_minmax(velocity_ptr) - - if (have_option(trim(t%option_path) // & - "/prognostic/spatial_discretisation/continuous_galerkin/advection_terms/only_sinking_velocity")) then - ewrite(2, *) "No advection set for field" - call allocate(velocity, mesh_dim(t), t%mesh, name = advdif_cg_velocity_name) - call zero(velocity) + ! Step 1: Pull fields out of state + + ! Coordinate + positions => extract_vector_field(state, "Coordinate") + ewrite_minmax(positions) + assert(positions%dim == mesh_dim(t)) + assert(ele_count(positions) == ele_count(t)) + + ! Velocity + velocity_ptr => extract_vector_field(state, lvelocity_name, stat = stat) + if(stat == 0) then + assert(velocity_ptr%dim == mesh_dim(t)) + assert(ele_count(velocity_ptr) == ele_count(t)) + + ewrite(2, *) "Velocity:" + ewrite_minmax(velocity_ptr) + + if (have_option(trim(t%option_path) // & + "/prognostic/spatial_discretisation/continuous_galerkin/advection_terms/only_sinking_velocity")) then + ewrite(2, *) "No advection set for field" + call allocate(velocity, mesh_dim(t), t%mesh, name = advdif_cg_velocity_name) + call zero(velocity) + else + call allocate(velocity, velocity_ptr%dim, velocity_ptr%mesh, name = advdif_cg_velocity_name) + call set(velocity, velocity_ptr) + end if else - call allocate(velocity, velocity_ptr%dim, velocity_ptr%mesh, name = advdif_cg_velocity_name) - call set(velocity, velocity_ptr) - end if - else - ewrite(2, *) "No velocity" - call allocate(velocity, mesh_dim(t), t%mesh, name = advdif_cg_velocity_name) - call zero(velocity) - end if - - ! Source - source => extract_scalar_field(state, trim(t%name) // "Source", stat = stat) - have_source = stat == 0 - if(have_source) then - assert(mesh_dim(source) == mesh_dim(t)) - assert(ele_count(source) == ele_count(t)) - - add_src_directly_to_rhs = have_option(trim(source%option_path)//'/diagnostic/add_directly_to_rhs') - - if (add_src_directly_to_rhs) then - ewrite(2, *) "Adding Source field directly to the right hand side" - assert(node_count(source) == node_count(t)) + ewrite(2, *) "No velocity" + call allocate(velocity, mesh_dim(t), t%mesh, name = advdif_cg_velocity_name) + call zero(velocity) end if - ewrite_minmax(source) - else - ewrite(2, *) "No source" - - add_src_directly_to_rhs = .false. - end if - - ! Absorption - absorption => extract_scalar_field(state, trim(t%name) // "Absorption", stat = stat) - have_absorption = stat == 0 - if(have_absorption) then - assert(mesh_dim(absorption) == mesh_dim(t)) - assert(ele_count(absorption) == ele_count(t)) - - ewrite_minmax(absorption) - else - ewrite(2, *) "No absorption" - end if - - ! Sinking velocity - sinking_velocity => extract_scalar_field(state, trim(t%name) // "SinkingVelocity", stat = stat) - if(stat == 0) then - ewrite_minmax(sinking_velocity) - - gravity_direction => extract_vector_field(state, "GravityDirection") - ! this may perform a "remap" internally from CoordinateMesh to VelocitMesh - call addto(velocity, gravity_direction, scale = sinking_velocity) - ewrite_minmax(velocity) - else - ewrite(2, *) "No sinking velocity" - end if - - ! Diffusivity - diffusivity => extract_tensor_field(state, trim(t%name) // "Diffusivity", stat = stat) - have_diffusivity = stat == 0 - if(have_diffusivity) then - assert(all(diffusivity%dim == mesh_dim(t))) - assert(ele_count(diffusivity) == ele_count(t)) - - isotropic_diffusivity = option_count(complete_field_path(diffusivity%option_path)) & - & == option_count(trim(complete_field_path(diffusivity%option_path)) // "/value/isotropic") + ! Source + source => extract_scalar_field(state, trim(t%name) // "Source", stat = stat) + have_source = stat == 0 + if(have_source) then + assert(mesh_dim(source) == mesh_dim(t)) + assert(ele_count(source) == ele_count(t)) - if(isotropic_diffusivity) then - ewrite(2, *) "Isotropic diffusivity" - assert(all(diffusivity%dim > 0)) - ewrite_minmax(diffusivity%val(1, 1, :)) + add_src_directly_to_rhs = have_option(trim(source%option_path)//'/diagnostic/add_directly_to_rhs') + + if (add_src_directly_to_rhs) then + ewrite(2, *) "Adding Source field directly to the right hand side" + assert(node_count(source) == node_count(t)) + end if + + ewrite_minmax(source) else - ewrite_minmax(diffusivity) + ewrite(2, *) "No source" + + add_src_directly_to_rhs = .false. end if - else - isotropic_diffusivity = .false. - ewrite(2, *) "No diffusivity" - end if - ! Step 2: Pull options out of the options tree + ! Absorption + absorption => extract_scalar_field(state, trim(t%name) // "Absorption", stat = stat) + have_absorption = stat == 0 + if(have_absorption) then + assert(mesh_dim(absorption) == mesh_dim(t)) + assert(ele_count(absorption) == ele_count(t)) - call get_option(trim(t%option_path) // "/prognostic/temporal_discretisation/theta", theta) - assert(theta >= 0.0 .and. theta <= 1.0) - ewrite(2, *) "Theta = ", theta - dt_theta = dt * theta - local_dt = dt + ewrite_minmax(absorption) + else + ewrite(2, *) "No absorption" + end if - call get_option(trim(t%option_path) // "/prognostic/spatial_discretisation/conservative_advection", beta) - assert(beta >= 0.0 .and. beta <= 1.0) - ewrite(2, *) "Beta = ", beta + ! Sinking velocity + sinking_velocity => extract_scalar_field(state, trim(t%name) // "SinkingVelocity", stat = stat) + if(stat == 0) then + ewrite_minmax(sinking_velocity) - have_advection = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/advection_terms/exclude_advection_terms") - if(have_advection) then - ewrite(2, *) "Including advection" + gravity_direction => extract_vector_field(state, "GravityDirection") + ! this may perform a "remap" internally from CoordinateMesh to VelocitMesh + call addto(velocity, gravity_direction, scale = sinking_velocity) + ewrite_minmax(velocity) + else + ewrite(2, *) "No sinking velocity" + end if - integrate_advection_by_parts = have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/advection_terms/integrate_advection_by_parts") - if(integrate_advection_by_parts) then - ewrite(2, *) "Integrating advection terms by parts" + ! Diffusivity + diffusivity => extract_tensor_field(state, trim(t%name) // "Diffusivity", stat = stat) + have_diffusivity = stat == 0 + if(have_diffusivity) then + assert(all(diffusivity%dim == mesh_dim(t))) + assert(ele_count(diffusivity) == ele_count(t)) + + isotropic_diffusivity = option_count(complete_field_path(diffusivity%option_path)) & + & == option_count(trim(complete_field_path(diffusivity%option_path)) // "/value/isotropic") + + if(isotropic_diffusivity) then + ewrite(2, *) "Isotropic diffusivity" + assert(all(diffusivity%dim > 0)) + ewrite_minmax(diffusivity%val(1, 1, :)) + else + ewrite_minmax(diffusivity) + end if + else + isotropic_diffusivity = .false. + ewrite(2, *) "No diffusivity" end if - else - integrate_advection_by_parts = .false. - ewrite(2, *) "Excluding advection" - end if - have_mass = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/mass_terms/exclude_mass_terms") - if(have_mass) then - ewrite(2, *) "Including mass" + ! Step 2: Pull options out of the options tree - lump_mass = have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/mass_terms/lump_mass_matrix") - if(lump_mass) then - ewrite(2, *) "Lumping mass" - end if - else - lump_mass = .false. - ewrite(2, *) "Excluding mass" - end if - - ! are we moving the mesh? - move_mesh = (have_option("/mesh_adaptivity/mesh_movement") .and. have_mass) - if(move_mesh) then - ewrite(2,*) "Moving the mesh" - old_positions => extract_vector_field(state, "OldCoordinate") - ewrite_minmax(old_positions) - new_positions => extract_vector_field(state, "IteratedCoordinate") - ewrite_minmax(new_positions) - - ! Grid velocity - grid_velocity => extract_vector_field(state, "GridVelocity") - assert(grid_velocity%dim == mesh_dim(t)) - assert(ele_count(grid_velocity) == ele_count(t)) - - ewrite(2, *) "Grid velocity:" - ewrite_minmax(grid_velocity) - else - ewrite(2,*) "Not moving the mesh" - end if - - allocate(supg_element(num_threads)) - if(have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind")) then - ewrite(2, *) "Streamline upwind stabilisation" - stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND - call get_upwind_options(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind", & - & nu_bar_scheme, nu_bar_scale) - if(move_mesh) then - FLExit("Haven't thought about how mesh movement works with stabilisation yet.") + call get_option(trim(t%option_path) // "/prognostic/temporal_discretisation/theta", theta) + assert(theta >= 0.0 .and. theta <= 1.0) + ewrite(2, *) "Theta = ", theta + dt_theta = dt * theta + local_dt = dt + + call get_option(trim(t%option_path) // "/prognostic/spatial_discretisation/conservative_advection", beta) + assert(beta >= 0.0 .and. beta <= 1.0) + ewrite(2, *) "Beta = ", beta + + have_advection = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/advection_terms/exclude_advection_terms") + if(have_advection) then + ewrite(2, *) "Including advection" + + integrate_advection_by_parts = have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/advection_terms/integrate_advection_by_parts") + if(integrate_advection_by_parts) then + ewrite(2, *) "Integrating advection terms by parts" + end if + else + integrate_advection_by_parts = .false. + ewrite(2, *) "Excluding advection" end if - else if(have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin")) then - ewrite(2, *) "SUPG stabilisation" - stabilisation_scheme = STABILISATION_SUPG - call get_upwind_options(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin", & - & nu_bar_scheme, nu_bar_scale) - ! Note this is not mixed mesh safe (but then nothing really is) - ! You need 1 supg_element per thread. - do i = 1, num_threads - supg_element(i)=make_supg_element(ele_shape(t,1)) - end do - if(move_mesh) then - FLExit("Haven't thought about how mesh movement works with stabilisation yet.") + + have_mass = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/mass_terms/exclude_mass_terms") + if(have_mass) then + ewrite(2, *) "Including mass" + + lump_mass = have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/mass_terms/lump_mass_matrix") + if(lump_mass) then + ewrite(2, *) "Lumping mass" + end if + else + lump_mass = .false. + ewrite(2, *) "Excluding mass" end if - else - ewrite(2, *) "No stabilisation" - stabilisation_scheme = STABILISATION_NONE - end if - - ! PhaseVolumeFraction for multiphase flow simulations - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - multiphase = .true. - vfrac => extract_scalar_field(state, "PhaseVolumeFraction") - call allocate(nvfrac, vfrac%mesh, "NonlinearPhaseVolumeFraction") - call zero(nvfrac) - call get_nonlinear_volume_fraction(state, nvfrac) - - ewrite_minmax(nvfrac) - else - multiphase = .false. - call allocate(nvfrac, t%mesh, "DummyNonlinearPhaseVolumeFraction", field_type=FIELD_TYPE_CONSTANT) - call set(nvfrac, 1.0) - end if - - call allocate(dummydensity, t%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) - call set(dummydensity, 1.0) - ! find out equation type and hence if density is needed or not - equation_type=equation_type_index(trim(t%option_path)) - select case(equation_type) - case(FIELD_EQUATION_ADVECTIONDIFFUSION) - ewrite(2,*) "Solving advection-diffusion equation" - ! density not needed so use a constant field for assembly - density => dummydensity - olddensity => dummydensity - density_theta = 1.0 - pressure => dummydensity - - case(FIELD_EQUATION_INTERNALENERGY) - ewrite(2,*) "Solving internal energy equation" + + ! are we moving the mesh? + move_mesh = (have_option("/mesh_adaptivity/mesh_movement") .and. have_mass) if(move_mesh) then - FLExit("Haven't implemented a moving mesh energy equation yet.") + ewrite(2,*) "Moving the mesh" + old_positions => extract_vector_field(state, "OldCoordinate") + ewrite_minmax(old_positions) + new_positions => extract_vector_field(state, "IteratedCoordinate") + ewrite_minmax(new_positions) + + ! Grid velocity + grid_velocity => extract_vector_field(state, "GridVelocity") + assert(grid_velocity%dim == mesh_dim(t)) + assert(ele_count(grid_velocity) == ele_count(t)) + + ewrite(2, *) "Grid velocity:" + ewrite_minmax(grid_velocity) + else + ewrite(2,*) "Not moving the mesh" end if - ! Get old and current densities - call get_option(trim(t%option_path)//'/prognostic/equation[0]/density[0]/name', & - density_name) - density=>extract_scalar_field(state, trim(density_name)) - ewrite_minmax(density) - olddensity=>extract_scalar_field(state, "Old"//trim(density_name)) - ewrite_minmax(olddensity) - - if(have_option(trim(state%option_path)//'/equation_of_state/compressible')) then - call get_option(trim(density%option_path)//"/prognostic/temporal_discretisation/theta", density_theta) - compressible = .true. - - ! We always include the p*div(u) term if this is the compressible phase. - pressure=>extract_scalar_field(state, "Pressure") - ewrite_minmax(pressure) + allocate(supg_element(num_threads)) + if(have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind")) then + ewrite(2, *) "Streamline upwind stabilisation" + stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND + call get_upwind_options(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind", & + & nu_bar_scheme, nu_bar_scale) + if(move_mesh) then + FLExit("Haven't thought about how mesh movement works with stabilisation yet.") + end if + else if(have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin")) then + ewrite(2, *) "SUPG stabilisation" + stabilisation_scheme = STABILISATION_SUPG + call get_upwind_options(trim(t%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin", & + & nu_bar_scheme, nu_bar_scale) + ! Note this is not mixed mesh safe (but then nothing really is) + ! You need 1 supg_element per thread. + do i = 1, num_threads + supg_element(i)=make_supg_element(ele_shape(t,1)) + end do + if(move_mesh) then + FLExit("Haven't thought about how mesh movement works with stabilisation yet.") + end if else - ! Since the particle phase is always incompressible then its Density - ! will not be prognostic. Just use a fixed theta value of 1.0. - density_theta = 1.0 - compressible = .false. - - ! Don't include the p*div(u) term if this is the incompressible particle phase. - pressure => dummydensity + ewrite(2, *) "No stabilisation" + stabilisation_scheme = STABILISATION_NONE end if - case(FIELD_EQUATION_KEPSILON) - ewrite(2,*) "Solving k-epsilon equation" - if(move_mesh) then - FLExit("Haven't implemented a moving mesh k-epsilon equation yet.") + ! PhaseVolumeFraction for multiphase flow simulations + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + multiphase = .true. + vfrac => extract_scalar_field(state, "PhaseVolumeFraction") + call allocate(nvfrac, vfrac%mesh, "NonlinearPhaseVolumeFraction") + call zero(nvfrac) + call get_nonlinear_volume_fraction(state, nvfrac) + + ewrite_minmax(nvfrac) + else + multiphase = .false. + call allocate(nvfrac, t%mesh, "DummyNonlinearPhaseVolumeFraction", field_type=FIELD_TYPE_CONSTANT) + call set(nvfrac, 1.0) end if - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - temp_velocity_ptr => extract_vector_field(state, "Velocity") - call get_option(trim(temp_velocity_ptr%option_path)//"/prognostic/equation[0]/name", velocity_equation_type) - select case(velocity_equation_type) - case("LinearMomentum") + call allocate(dummydensity, t%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) + call set(dummydensity, 1.0) + ! find out equation type and hence if density is needed or not + equation_type=equation_type_index(trim(t%option_path)) + select case(equation_type) + case(FIELD_EQUATION_ADVECTIONDIFFUSION) + ewrite(2,*) "Solving advection-diffusion equation" + ! density not needed so use a constant field for assembly + density => dummydensity + olddensity => dummydensity + density_theta = 1.0 + pressure => dummydensity + + case(FIELD_EQUATION_INTERNALENERGY) + ewrite(2,*) "Solving internal energy equation" + if(move_mesh) then + FLExit("Haven't implemented a moving mesh energy equation yet.") + end if + + ! Get old and current densities + call get_option(trim(t%option_path)//'/prognostic/equation[0]/density[0]/name', & + density_name) + density=>extract_scalar_field(state, trim(density_name)) + ewrite_minmax(density) + olddensity=>extract_scalar_field(state, "Old"//trim(density_name)) + ewrite_minmax(olddensity) + + if(have_option(trim(state%option_path)//'/equation_of_state/compressible')) then + call get_option(trim(density%option_path)//"/prognostic/temporal_discretisation/theta", density_theta) + compressible = .true. + + ! We always include the p*div(u) term if this is the compressible phase. + pressure=>extract_scalar_field(state, "Pressure") + ewrite_minmax(pressure) + else + ! Since the particle phase is always incompressible then its Density + ! will not be prognostic. Just use a fixed theta value of 1.0. + density_theta = 1.0 + compressible = .false. + + ! Don't include the p*div(u) term if this is the incompressible particle phase. + pressure => dummydensity + end if + + case(FIELD_EQUATION_KEPSILON) + ewrite(2,*) "Solving k-epsilon equation" + if(move_mesh) then + FLExit("Haven't implemented a moving mesh k-epsilon equation yet.") + end if + + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + temp_velocity_ptr => extract_vector_field(state, "Velocity") + call get_option(trim(temp_velocity_ptr%option_path)//"/prognostic/equation[0]/name", velocity_equation_type) + select case(velocity_equation_type) + case("LinearMomentum") density=>extract_scalar_field(state, "Density") olddensity => dummydensity density_theta = 1.0 - case("Boussinesq") + case("Boussinesq") density=>dummydensity olddensity => dummydensity density_theta = 1.0 - case("Drainage") + case("Drainage") density=>dummydensity olddensity => dummydensity density_theta = 1.0 - case default + case default ! developer error... out of sync options input and code FLAbort("Unknown equation type for velocity") - end select - ewrite_minmax(density) + end select + ewrite_minmax(density) - case default - FLExit("Unknown field equation type for cg advection diffusion.") - end select + case default + FLExit("Unknown field equation type for cg advection diffusion.") + end select - ! Step 3: Assembly + ! Step 3: Assembly - call zero(matrix) - call zero(rhs) + call zero(matrix) + call zero(rhs) - call profiler_tic(t, "advection_diffusion_loop_overhead") + call profiler_tic(t, "advection_diffusion_loop_overhead") #ifdef _OPENMP - cache_valid = prepopulate_transform_cache(positions) + cache_valid = prepopulate_transform_cache(positions) #endif - call get_mesh_colouring(state, t%mesh, COLOURING_CG1, colours) - call profiler_toc(t, "advection_diffusion_loop_overhead") + call get_mesh_colouring(state, t%mesh, COLOURING_CG1, colours) + call profiler_toc(t, "advection_diffusion_loop_overhead") - call profiler_tic(t, "advection_diffusion_loop") + call profiler_tic(t, "advection_diffusion_loop") - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(clr, len, nnid, ele, thread_num) + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(clr, len, nnid, ele, thread_num) #ifdef _OPENMP - thread_num = omp_get_thread_num() + thread_num = omp_get_thread_num() #else - thread_num=0 + thread_num=0 #endif - colour_loop: do clr = 1, size(colours) + colour_loop: do clr = 1, size(colours) - len = key_count(colours(clr)) - !$OMP DO SCHEDULE(STATIC) - element_loop: do nnid = 1, len - ele = fetch(colours(clr), nnid) - call assemble_advection_diffusion_element_cg(ele, t, matrix, rhs, & - positions, old_positions, new_positions, & - velocity, grid_velocity, & - source, absorption, diffusivity, & - density, olddensity, pressure, nvfrac, & - supg_element(thread_num+1)) - end do element_loop - !$OMP END DO + len = key_count(colours(clr)) + !$OMP DO SCHEDULE(STATIC) + element_loop: do nnid = 1, len + ele = fetch(colours(clr), nnid) + call assemble_advection_diffusion_element_cg(ele, t, matrix, rhs, & + positions, old_positions, new_positions, & + velocity, grid_velocity, & + source, absorption, diffusivity, & + density, olddensity, pressure, nvfrac, & + supg_element(thread_num+1)) + end do element_loop + !$OMP END DO - end do colour_loop - !$OMP END PARALLEL + end do colour_loop + !$OMP END PARALLEL - call profiler_toc(t, "advection_diffusion_loop") + call profiler_toc(t, "advection_diffusion_loop") - ! Add the source directly to the rhs if required - ! which must be included before dirichlet BC's. - if (add_src_directly_to_rhs) call addto(rhs, source) + ! Add the source directly to the rhs if required + ! which must be included before dirichlet BC's. + if (add_src_directly_to_rhs) call addto(rhs, source) - ! Step 4: Boundary conditions + ! Step 4: Boundary conditions - if( & + if( & & (integrate_advection_by_parts .and. have_advection) & & .or. have_diffusivity & & ) then - allocate(t_bc_types(surface_element_count(t))) - call get_entire_boundary_condition(t, & - (/ "neumann ", & - "weakdirichlet", & - "internal ", & - "robin "/), & - t_bc, & - t_bc_types, & - boundary_second_value = t_bc_2) - - if(any(t_bc_types /= 0)) then - call ewrite_bc_counts(2, t_bc_types) + allocate(t_bc_types(surface_element_count(t))) + call get_entire_boundary_condition(t, & + (/ "neumann ", & + "weakdirichlet", & + "internal ", & + "robin "/), & + t_bc, & + t_bc_types, & + boundary_second_value = t_bc_2) + + if(any(t_bc_types /= 0)) then + call ewrite_bc_counts(2, t_bc_types) + end if + + do i = 1, surface_element_count(t) + if(t_bc_types(i)==BC_TYPE_INTERNAL) cycle + call assemble_advection_diffusion_face_cg(i, t_bc_types(i), t, t_bc, t_bc_2, & + matrix, rhs, & + positions, velocity, grid_velocity, & + density, olddensity, nvfrac) + end do + + call deallocate(t_bc) + call deallocate(t_bc_2) + deallocate(t_bc_types) + end if - do i = 1, surface_element_count(t) - if(t_bc_types(i)==BC_TYPE_INTERNAL) cycle - call assemble_advection_diffusion_face_cg(i, t_bc_types(i), t, t_bc, t_bc_2, & - matrix, rhs, & - positions, velocity, grid_velocity, & - density, olddensity, nvfrac) + ewrite(2, *) "Applying strong Dirichlet boundary conditions" + call apply_dirichlet_conditions(matrix, rhs, t, dt) + + ewrite_minmax(rhs) + + call deallocate(velocity) + call deallocate(nvfrac) + call deallocate(dummydensity) + if (stabilisation_scheme == STABILISATION_SUPG) then + do i = 1, num_threads + call deallocate(supg_element(i)) + end do + end if + deallocate(supg_element) + + ewrite(1, *) "Exiting assemble_advection_diffusion_cg" + + end subroutine assemble_advection_diffusion_cg + + subroutine ewrite_bc_counts(debug_level, bc_types) + !!< A simple subroutine to count and output the number of elements with + !!< each boundary conditions (combines counts into a single surface + !!< element loop). + + integer, intent(in) :: debug_level + integer, dimension(:), intent(in) :: bc_types + + integer :: i, nneumann, nweak_dirichlet, ninternal, nrobin + + if(debug_level > current_debug_level) return + + nneumann = 0 + nweak_dirichlet = 0 + ninternal = 0 + nrobin = 0 + do i = 1, size(bc_types) + select case(bc_types(i)) + case(BC_TYPE_NEUMANN) + nneumann = nneumann + 1 + case(BC_TYPE_WEAKDIRICHLET) + nweak_dirichlet = nweak_dirichlet + 1 + case(BC_TYPE_INTERNAL) + ninternal = ninternal + 1 + case(BC_TYPE_ROBIN) + nrobin = nrobin + 1 + case(0) + case default + ! this is a code error + ewrite(-1, *) "For boundary condition type: ", bc_types(i) + FLAbort("Unrecognised boundary condition type") + end select end do - call deallocate(t_bc) - call deallocate(t_bc_2) - deallocate(t_bc_types) - - end if - - ewrite(2, *) "Applying strong Dirichlet boundary conditions" - call apply_dirichlet_conditions(matrix, rhs, t, dt) - - ewrite_minmax(rhs) - - call deallocate(velocity) - call deallocate(nvfrac) - call deallocate(dummydensity) - if (stabilisation_scheme == STABILISATION_SUPG) then - do i = 1, num_threads - call deallocate(supg_element(i)) - end do - end if - deallocate(supg_element) - - ewrite(1, *) "Exiting assemble_advection_diffusion_cg" - - end subroutine assemble_advection_diffusion_cg - - subroutine ewrite_bc_counts(debug_level, bc_types) - !!< A simple subroutine to count and output the number of elements with - !!< each boundary conditions (combines counts into a single surface - !!< element loop). - - integer, intent(in) :: debug_level - integer, dimension(:), intent(in) :: bc_types - - integer :: i, nneumann, nweak_dirichlet, ninternal, nrobin - - if(debug_level > current_debug_level) return - - nneumann = 0 - nweak_dirichlet = 0 - ninternal = 0 - nrobin = 0 - do i = 1, size(bc_types) - select case(bc_types(i)) - case(BC_TYPE_NEUMANN) - nneumann = nneumann + 1 - case(BC_TYPE_WEAKDIRICHLET) - nweak_dirichlet = nweak_dirichlet + 1 - case(BC_TYPE_INTERNAL) - ninternal = ninternal + 1 - case(BC_TYPE_ROBIN) - nrobin = nrobin + 1 - case(0) - case default - ! this is a code error - ewrite(-1, *) "For boundary condition type: ", bc_types(i) - FLAbort("Unrecognised boundary condition type") - end select - end do - - ewrite(debug_level, *) "Surface elements with Neumann boundary condition: ", nneumann - ewrite(debug_level, *) "Surface elements with weak Dirichlet boundary condition: ", nweak_dirichlet - ewrite(debug_level, *) "Surface elements with internal or periodic boundary condition: ", ninternal - ewrite(debug_level, *) "Surface elements with Robin boundary condition: ", nrobin - - end subroutine ewrite_bc_counts - - subroutine assemble_advection_diffusion_element_cg(ele, t, matrix, rhs, & - positions, old_positions, new_positions, & - velocity, grid_velocity, & - source, absorption, diffusivity, & - density, olddensity, pressure, nvfrac, supg_shape) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: t - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(vector_field), pointer :: old_positions, new_positions - type(vector_field), intent(in) :: velocity - type(vector_field), pointer :: grid_velocity - type(scalar_field), intent(in) :: source - type(scalar_field), intent(in) :: absorption - type(tensor_field), intent(in) :: diffusivity - type(scalar_field), intent(in) :: density - type(scalar_field), intent(in) :: olddensity - type(scalar_field), intent(in) :: pressure - type(scalar_field), intent(in) :: nvfrac - type(element_type), intent(inout) :: supg_shape - - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(t, ele)) :: detwei, detwei_old, detwei_new - real, dimension(ele_loc(t, ele), ele_ngi(t, ele), mesh_dim(t)) :: dt_t - real, dimension(ele_loc(density, ele), ele_ngi(density, ele), mesh_dim(density)) :: drho_t - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(t)) :: du_t - real, dimension(ele_loc(positions, ele), ele_ngi(velocity, ele), mesh_dim(t)) :: dug_t - ! Derivative of shape function for nvfrac field - real, dimension(ele_loc(nvfrac, ele), ele_ngi(nvfrac, ele), mesh_dim(nvfrac)) :: dnvfrac_t - - real, dimension(mesh_dim(t), mesh_dim(t), ele_ngi(t, ele)) :: j_mat - type(element_type) :: test_function - type(element_type), pointer :: t_shape - - ! What we will be adding to the matrix and RHS - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(ele_loc(t, ele)) :: rhs_addto - real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: matrix_addto + ewrite(debug_level, *) "Surface elements with Neumann boundary condition: ", nneumann + ewrite(debug_level, *) "Surface elements with weak Dirichlet boundary condition: ", nweak_dirichlet + ewrite(debug_level, *) "Surface elements with internal or periodic boundary condition: ", ninternal + ewrite(debug_level, *) "Surface elements with Robin boundary condition: ", nrobin + + end subroutine ewrite_bc_counts + + subroutine assemble_advection_diffusion_element_cg(ele, t, matrix, rhs, & + positions, old_positions, new_positions, & + velocity, grid_velocity, & + source, absorption, diffusivity, & + density, olddensity, pressure, nvfrac, supg_shape) + integer, intent(in) :: ele + type(scalar_field), intent(in) :: t + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(vector_field), pointer :: old_positions, new_positions + type(vector_field), intent(in) :: velocity + type(vector_field), pointer :: grid_velocity + type(scalar_field), intent(in) :: source + type(scalar_field), intent(in) :: absorption + type(tensor_field), intent(in) :: diffusivity + type(scalar_field), intent(in) :: density + type(scalar_field), intent(in) :: olddensity + type(scalar_field), intent(in) :: pressure + type(scalar_field), intent(in) :: nvfrac + type(element_type), intent(inout) :: supg_shape + + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(t, ele)) :: detwei, detwei_old, detwei_new + real, dimension(ele_loc(t, ele), ele_ngi(t, ele), mesh_dim(t)) :: dt_t + real, dimension(ele_loc(density, ele), ele_ngi(density, ele), mesh_dim(density)) :: drho_t + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(t)) :: du_t + real, dimension(ele_loc(positions, ele), ele_ngi(velocity, ele), mesh_dim(t)) :: dug_t + ! Derivative of shape function for nvfrac field + real, dimension(ele_loc(nvfrac, ele), ele_ngi(nvfrac, ele), mesh_dim(nvfrac)) :: dnvfrac_t + + real, dimension(mesh_dim(t), mesh_dim(t), ele_ngi(t, ele)) :: j_mat + type(element_type) :: test_function + type(element_type), pointer :: t_shape + + ! What we will be adding to the matrix and RHS - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(ele_loc(t, ele)) :: rhs_addto + real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: matrix_addto #ifdef DDEBUG - assert(ele_ngi(positions, ele) == ele_ngi(t, ele)) - assert(ele_ngi(velocity, ele) == ele_ngi(t, ele)) - if(have_diffusivity) then - assert(ele_ngi(diffusivity, ele) == ele_ngi(t, ele)) - end if - if(have_source) then - assert(ele_ngi(source, ele) == ele_ngi(t, ele)) - end if - if(have_absorption) then - assert(ele_ngi(absorption, ele) == ele_ngi(t, ele)) - end if - if(move_mesh) then - ! the following has been assumed in the declarations above - assert(ele_loc(grid_velocity, ele) == ele_loc(positions, ele)) - assert(ele_ngi(grid_velocity, ele) == ele_ngi(velocity, ele)) - end if + assert(ele_ngi(positions, ele) == ele_ngi(t, ele)) + assert(ele_ngi(velocity, ele) == ele_ngi(t, ele)) + if(have_diffusivity) then + assert(ele_ngi(diffusivity, ele) == ele_ngi(t, ele)) + end if + if(have_source) then + assert(ele_ngi(source, ele) == ele_ngi(t, ele)) + end if + if(have_absorption) then + assert(ele_ngi(absorption, ele) == ele_ngi(t, ele)) + end if + if(move_mesh) then + ! the following has been assumed in the declarations above + assert(ele_loc(grid_velocity, ele) == ele_loc(positions, ele)) + assert(ele_ngi(grid_velocity, ele) == ele_ngi(velocity, ele)) + end if #endif - matrix_addto = 0.0 - rhs_addto = 0.0 - - t_shape => ele_shape(t, ele) - - ! Step 1: Transform - - if(.not. have_advection .and. .not. have_diffusivity) then - call transform_to_physical(positions, ele, detwei = detwei) - else if(any(stabilisation_scheme == (/STABILISATION_STREAMLINE_UPWIND, STABILISATION_SUPG/))) then - call transform_to_physical(positions, ele, t_shape, & - & dshape = dt_t, detwei = detwei, j = j_mat) - else - call transform_to_physical(positions, ele, t_shape, & - & dshape = dt_t, detwei = detwei) - end if - - if(have_advection.or.(equation_type==FIELD_EQUATION_INTERNALENERGY).or.equation_type==FIELD_EQUATION_KEPSILON) then - call transform_to_physical(positions, ele, & - & ele_shape(velocity, ele), dshape = du_t) - end if - - if(have_advection.and.move_mesh.and..not.integrate_advection_by_parts) then - call transform_to_physical(positions, ele, & - & ele_shape(grid_velocity, ele), dshape = dug_t) - end if - - if(move_mesh) then - call transform_to_physical(old_positions, ele, detwei=detwei_old) - call transform_to_physical(new_positions, ele, detwei=detwei_new) - end if - - if(have_advection.and.(equation_type==FIELD_EQUATION_INTERNALENERGY .or. equation_type==FIELD_EQUATION_KEPSILON)) then - if(ele_shape(density, ele)==t_shape) then - drho_t = dt_t + matrix_addto = 0.0 + rhs_addto = 0.0 + + t_shape => ele_shape(t, ele) + + ! Step 1: Transform + + if(.not. have_advection .and. .not. have_diffusivity) then + call transform_to_physical(positions, ele, detwei = detwei) + else if(any(stabilisation_scheme == (/STABILISATION_STREAMLINE_UPWIND, STABILISATION_SUPG/))) then + call transform_to_physical(positions, ele, t_shape, & + & dshape = dt_t, detwei = detwei, j = j_mat) else - call transform_to_physical(positions, ele, & - & ele_shape(density, ele), dshape = drho_t) + call transform_to_physical(positions, ele, t_shape, & + & dshape = dt_t, detwei = detwei) end if - end if - if(have_advection .and. multiphase .and. (equation_type==FIELD_EQUATION_INTERNALENERGY)) then - ! If the field and nvfrac meshes are different, then we need to - ! compute the derivatives of the nvfrac shape functions. - if(ele_shape(nvfrac, ele) == t_shape) then - dnvfrac_t = dt_t - else - call transform_to_physical(positions, ele, ele_shape(nvfrac, ele), dshape=dnvfrac_t) + if(have_advection.or.(equation_type==FIELD_EQUATION_INTERNALENERGY).or.equation_type==FIELD_EQUATION_KEPSILON) then + call transform_to_physical(positions, ele, & + & ele_shape(velocity, ele), dshape = du_t) + end if + + if(have_advection.and.move_mesh.and..not.integrate_advection_by_parts) then + call transform_to_physical(positions, ele, & + & ele_shape(grid_velocity, ele), dshape = dug_t) end if - end if - ! Step 2: Set up test function + if(move_mesh) then + call transform_to_physical(old_positions, ele, detwei=detwei_old) + call transform_to_physical(new_positions, ele, detwei=detwei_new) + end if - select case(stabilisation_scheme) - case(STABILISATION_SUPG) - if(have_diffusivity) then - call supg_test_function(supg_shape, t_shape, dt_t, ele_val_at_quad(velocity, ele), j_mat, diff_q = ele_val_at_quad(diffusivity, ele), & + if(have_advection.and.(equation_type==FIELD_EQUATION_INTERNALENERGY .or. equation_type==FIELD_EQUATION_KEPSILON)) then + if(ele_shape(density, ele)==t_shape) then + drho_t = dt_t + else + call transform_to_physical(positions, ele, & + & ele_shape(density, ele), dshape = drho_t) + end if + end if + + if(have_advection .and. multiphase .and. (equation_type==FIELD_EQUATION_INTERNALENERGY)) then + ! If the field and nvfrac meshes are different, then we need to + ! compute the derivatives of the nvfrac shape functions. + if(ele_shape(nvfrac, ele) == t_shape) then + dnvfrac_t = dt_t + else + call transform_to_physical(positions, ele, ele_shape(nvfrac, ele), dshape=dnvfrac_t) + end if + end if + + ! Step 2: Set up test function + + select case(stabilisation_scheme) + case(STABILISATION_SUPG) + if(have_diffusivity) then + call supg_test_function(supg_shape, t_shape, dt_t, ele_val_at_quad(velocity, ele), j_mat, diff_q = ele_val_at_quad(diffusivity, ele), & & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - else - call supg_test_function(supg_shape, t_shape, dt_t, ele_val_at_quad(velocity, ele), j_mat, & + else + call supg_test_function(supg_shape, t_shape, dt_t, ele_val_at_quad(velocity, ele), j_mat, & & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - end if - test_function = supg_shape - case default - test_function = t_shape - end select - ! Important note: with SUPG the test function derivatives have not been - ! modified - i.e. dt_t is currently used everywhere. This is fine for P1, - ! but is not consistent for P>1. - - ! Step 3: Assemble contributions + end if + test_function = supg_shape + case default + test_function = t_shape + end select + ! Important note: with SUPG the test function derivatives have not been + ! modified - i.e. dt_t is currently used everywhere. This is fine for P1, + ! but is not consistent for P>1. - ! Mass - if(have_mass) call add_mass_element_cg(ele, test_function, t, density, olddensity, nvfrac, detwei, detwei_old, detwei_new, matrix_addto, rhs_addto) + ! Step 3: Assemble contributions - ! Advection - if(have_advection) call add_advection_element_cg(ele, test_function, t, & - velocity, grid_velocity, diffusivity, & - density, olddensity, nvfrac, & - dt_t, du_t, dug_t, drho_t, dnvfrac_t, detwei, j_mat, matrix_addto, rhs_addto) + ! Mass + if(have_mass) call add_mass_element_cg(ele, test_function, t, density, olddensity, nvfrac, detwei, detwei_old, detwei_new, matrix_addto, rhs_addto) - ! Absorption - if(have_absorption) call add_absorption_element_cg(ele, test_function, t, absorption, detwei, matrix_addto, rhs_addto) + ! Advection + if(have_advection) call add_advection_element_cg(ele, test_function, t, & + velocity, grid_velocity, diffusivity, & + density, olddensity, nvfrac, & + dt_t, du_t, dug_t, drho_t, dnvfrac_t, detwei, j_mat, matrix_addto, rhs_addto) - ! Diffusivity - if(have_diffusivity) call add_diffusivity_element_cg(ele, t, diffusivity, dt_t, nvfrac, detwei, matrix_addto, rhs_addto) + ! Absorption + if(have_absorption) call add_absorption_element_cg(ele, test_function, t, absorption, detwei, matrix_addto, rhs_addto) - ! Source - if(have_source .and. (.not. add_src_directly_to_rhs)) then - call add_source_element_cg(ele, test_function, t, source, detwei, rhs_addto) - end if + ! Diffusivity + if(have_diffusivity) call add_diffusivity_element_cg(ele, t, diffusivity, dt_t, nvfrac, detwei, matrix_addto, rhs_addto) - ! Pressure - if(equation_type==FIELD_EQUATION_INTERNALENERGY .and. compressible) then - call add_pressurediv_element_cg(ele, test_function, t, velocity, pressure, nvfrac, du_t, detwei, rhs_addto) - end if + ! Source + if(have_source .and. (.not. add_src_directly_to_rhs)) then + call add_source_element_cg(ele, test_function, t, source, detwei, rhs_addto) + end if + ! Pressure + if(equation_type==FIELD_EQUATION_INTERNALENERGY .and. compressible) then + call add_pressurediv_element_cg(ele, test_function, t, velocity, pressure, nvfrac, du_t, detwei, rhs_addto) + end if - ! Step 4: Insertion - element_nodes => ele_nodes(t, ele) - call addto(matrix, element_nodes, element_nodes, matrix_addto) - call addto(rhs, element_nodes, rhs_addto) + ! Step 4: Insertion - end subroutine assemble_advection_diffusion_element_cg + element_nodes => ele_nodes(t, ele) + call addto(matrix, element_nodes, element_nodes, matrix_addto) + call addto(rhs, element_nodes, rhs_addto) - subroutine add_mass_element_cg(ele, test_function, t, density, olddensity, nvfrac, detwei, detwei_old, detwei_new, matrix_addto, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: density, olddensity - type(scalar_field), intent(in) :: nvfrac - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei, detwei_old, detwei_new - real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + end subroutine assemble_advection_diffusion_element_cg - integer :: i - real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: mass_matrix + subroutine add_mass_element_cg(ele, test_function, t, density, olddensity, nvfrac, detwei, detwei_old, detwei_new, matrix_addto, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: density, olddensity + type(scalar_field), intent(in) :: nvfrac + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei, detwei_old, detwei_new + real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - real, dimension(ele_ngi(density,ele)) :: density_at_quad + integer :: i + real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: mass_matrix - assert(have_mass) + real, dimension(ele_ngi(density,ele)) :: density_at_quad - select case(equation_type) - case(FIELD_EQUATION_INTERNALENERGY) - assert(ele_ngi(density, ele)==ele_ngi(olddensity, ele)) + assert(have_mass) - density_at_quad = ele_val_at_quad(olddensity, ele) + select case(equation_type) + case(FIELD_EQUATION_INTERNALENERGY) + assert(ele_ngi(density, ele)==ele_ngi(olddensity, ele)) - if(move_mesh) then - ! needs to be evaluated at t+dt - mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei_new*density_at_quad) - else - if(multiphase) then - mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei*density_at_quad*ele_val_at_quad(nvfrac, ele)) - else - mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei*density_at_quad) - end if - end if - case(FIELD_EQUATION_KEPSILON) - density_at_quad = ele_val_at_quad(density, ele) - mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei*density_at_quad) - case default + density_at_quad = ele_val_at_quad(olddensity, ele) - if(move_mesh) then - ! needs to be evaluated at t+dt - mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei_new) - else - mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei) - end if + if(move_mesh) then + ! needs to be evaluated at t+dt + mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei_new*density_at_quad) + else + if(multiphase) then + mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei*density_at_quad*ele_val_at_quad(nvfrac, ele)) + else + mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei*density_at_quad) + end if + end if + case(FIELD_EQUATION_KEPSILON) + density_at_quad = ele_val_at_quad(density, ele) + mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei*density_at_quad) + case default + + if(move_mesh) then + ! needs to be evaluated at t+dt + mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei_new) + else + mass_matrix = shape_shape(test_function, ele_shape(t, ele), detwei) + end if - end select + end select - if(lump_mass) then - do i = 1, size(matrix_addto, 1) - matrix_addto(i, i) = matrix_addto(i, i) + sum(mass_matrix(i, :)) - end do - else - matrix_addto = matrix_addto + mass_matrix - end if - - if(move_mesh) then - ! In the unaccelerated form we solve: - ! / - ! | N^{n+1} T^{n+1}/dt - N^{n} T^n/dt + ... = f - ! / - ! so in accelerated form: - ! / - ! | N^{n+1} dT + (N^{n+1}- N^{n}) T^n/dt + ... = f - ! / - ! where dT=(T^{n+1}-T^{n})/dt is the acceleration. - ! Put the (N^{n+1}-N^{n}) T^n term on the rhs - mass_matrix = shape_shape(test_function, ele_shape(t, ele), (detwei_new-detwei_old)) if(lump_mass) then - rhs_addto = rhs_addto - sum(mass_matrix, 2)*ele_val(t, ele)/local_dt + do i = 1, size(matrix_addto, 1) + matrix_addto(i, i) = matrix_addto(i, i) + sum(mass_matrix(i, :)) + end do else - rhs_addto = rhs_addto - matmul(mass_matrix, ele_val(t, ele))/local_dt + matrix_addto = matrix_addto + mass_matrix end if - end if - - end subroutine add_mass_element_cg - - subroutine add_advection_element_cg(ele, test_function, t, & - velocity, grid_velocity, diffusivity, & - density, olddensity, nvfrac, & - dt_t, du_t, dug_t, drho_t, dnvfrac_t, detwei, j_mat, matrix_addto, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: t - type(vector_field), intent(in) :: velocity - type(vector_field), pointer :: grid_velocity - type(tensor_field), intent(in) :: diffusivity - type(scalar_field), intent(in) :: density, olddensity - type(scalar_field), intent(in) :: nvfrac - real, dimension(ele_loc(t, ele), ele_ngi(t, ele), mesh_dim(t)), intent(in) :: dt_t - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(t)) :: du_t - real, dimension(:, :, :) :: dug_t - real, dimension(ele_loc(density, ele), ele_ngi(density, ele), mesh_dim(density)), intent(in) :: drho_t - real, dimension(:, :, :), intent(in) :: dnvfrac_t - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(mesh_dim(t), mesh_dim(t), ele_ngi(t, ele)), intent(in) :: j_mat - real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - - real, dimension(ele_loc(t, ele), ele_loc(t,ele)) :: advection_mat - real, dimension(velocity%dim, ele_ngi(velocity, ele)) :: velocity_at_quad - real, dimension(ele_ngi(velocity, ele)) :: velocity_div_at_quad - type(element_type), pointer :: t_shape - - real, dimension(ele_ngi(density, ele)) :: density_at_quad - real, dimension(velocity%dim, ele_ngi(density, ele)) :: densitygrad_at_quad - real, dimension(ele_ngi(density, ele)) :: udotgradrho_at_quad - - real, dimension(ele_ngi(t, ele)) :: nvfrac_at_quad - real, dimension(velocity%dim, ele_ngi(t, ele)) :: nvfracgrad_at_quad - real, dimension(ele_ngi(t, ele)) :: udotgradnvfrac_at_quad - - assert(have_advection) - - t_shape => ele_shape(t, ele) - - velocity_at_quad = ele_val_at_quad(velocity, ele) - if(move_mesh) then - velocity_at_quad = velocity_at_quad - ele_val_at_quad(grid_velocity, ele) - end if - - select case(equation_type) - case(FIELD_EQUATION_INTERNALENERGY) - assert(ele_ngi(density, ele)==ele_ngi(olddensity, ele)) - - density_at_quad = density_theta*ele_val_at_quad(density, ele)& - +(1.-density_theta)*ele_val_at_quad(olddensity, ele) - densitygrad_at_quad = density_theta*ele_grad_at_quad(density, ele, drho_t) & - +(1.-density_theta)*ele_grad_at_quad(olddensity, ele, drho_t) - udotgradrho_at_quad = sum(densitygrad_at_quad*velocity_at_quad, 1) - if(multiphase) then - nvfrac_at_quad = ele_val_at_quad(nvfrac, ele) + if(move_mesh) then + ! In the unaccelerated form we solve: + ! / + ! | N^{n+1} T^{n+1}/dt - N^{n} T^n/dt + ... = f + ! / + ! so in accelerated form: + ! / + ! | N^{n+1} dT + (N^{n+1}- N^{n}) T^n/dt + ... = f + ! / + ! where dT=(T^{n+1}-T^{n})/dt is the acceleration. + ! Put the (N^{n+1}-N^{n}) T^n term on the rhs + mass_matrix = shape_shape(test_function, ele_shape(t, ele), (detwei_new-detwei_old)) + if(lump_mass) then + rhs_addto = rhs_addto - sum(mass_matrix, 2)*ele_val(t, ele)/local_dt + else + rhs_addto = rhs_addto - matmul(mass_matrix, ele_val(t, ele))/local_dt + end if + end if + + end subroutine add_mass_element_cg + + subroutine add_advection_element_cg(ele, test_function, t, & + velocity, grid_velocity, diffusivity, & + density, olddensity, nvfrac, & + dt_t, du_t, dug_t, drho_t, dnvfrac_t, detwei, j_mat, matrix_addto, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: t + type(vector_field), intent(in) :: velocity + type(vector_field), pointer :: grid_velocity + type(tensor_field), intent(in) :: diffusivity + type(scalar_field), intent(in) :: density, olddensity + type(scalar_field), intent(in) :: nvfrac + real, dimension(ele_loc(t, ele), ele_ngi(t, ele), mesh_dim(t)), intent(in) :: dt_t + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(t)) :: du_t + real, dimension(:, :, :) :: dug_t + real, dimension(ele_loc(density, ele), ele_ngi(density, ele), mesh_dim(density)), intent(in) :: drho_t + real, dimension(:, :, :), intent(in) :: dnvfrac_t + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(mesh_dim(t), mesh_dim(t), ele_ngi(t, ele)), intent(in) :: j_mat + real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + + real, dimension(ele_loc(t, ele), ele_loc(t,ele)) :: advection_mat + real, dimension(velocity%dim, ele_ngi(velocity, ele)) :: velocity_at_quad + real, dimension(ele_ngi(velocity, ele)) :: velocity_div_at_quad + type(element_type), pointer :: t_shape + + real, dimension(ele_ngi(density, ele)) :: density_at_quad + real, dimension(velocity%dim, ele_ngi(density, ele)) :: densitygrad_at_quad + real, dimension(ele_ngi(density, ele)) :: udotgradrho_at_quad + + real, dimension(ele_ngi(t, ele)) :: nvfrac_at_quad + real, dimension(velocity%dim, ele_ngi(t, ele)) :: nvfracgrad_at_quad + real, dimension(ele_ngi(t, ele)) :: udotgradnvfrac_at_quad + + assert(have_advection) + + t_shape => ele_shape(t, ele) + + velocity_at_quad = ele_val_at_quad(velocity, ele) + if(move_mesh) then + velocity_at_quad = velocity_at_quad - ele_val_at_quad(grid_velocity, ele) end if - case(FIELD_EQUATION_KEPSILON) - density_at_quad = ele_val_at_quad(density, ele) - densitygrad_at_quad = ele_grad_at_quad(density, ele, drho_t) - udotgradrho_at_quad = sum(densitygrad_at_quad*velocity_at_quad, 1) - end select - - if(integrate_advection_by_parts) then - ! element advection matrix - ! / / - ! - | (grad N_A dot nu) N_B dV - (1. - beta) | N_A ( div nu ) N_B dV - ! / / - select case(equation_type) - case(FIELD_EQUATION_INTERNALENERGY) - if(multiphase) then - advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei*density_at_quad*nvfrac_at_quad) - else - advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei*density_at_quad) - end if - - if(abs(1.0 - beta) > epsilon(0.0)) then - velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) - - if(multiphase) then - - nvfracgrad_at_quad = ele_grad_at_quad(nvfrac, ele, dnvfrac_t) - udotgradnvfrac_at_quad = sum(nvfracgrad_at_quad*velocity_at_quad, 1) - - advection_mat = advection_mat - (1.0-beta) * ( shape_shape(test_function, t_shape, detwei*velocity_div_at_quad*density_at_quad*nvfrac_at_quad) & - + shape_shape(test_function, t_shape, detwei*nvfrac_at_quad*udotgradrho_at_quad) & - + shape_shape(test_function, t_shape, detwei*density_at_quad*udotgradnvfrac_at_quad) ) - else - advection_mat = advection_mat - (1.0-beta) * shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad + udotgradrho_at_quad)*detwei) - end if - end if - case(FIELD_EQUATION_KEPSILON) - advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei*density_at_quad) - if(abs(1.0 - beta) > epsilon(0.0)) then - velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) - advection_mat = advection_mat & - - (1.0-beta) * shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad & - +udotgradrho_at_quad)* detwei) - end if - case default - advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei) - if(abs(1.0 - beta) > epsilon(0.0)) then - velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) - advection_mat = advection_mat & - - (1.0-beta)*shape_shape(test_function, t_shape, velocity_div_at_quad*detwei) - end if - end select - else - ! element advection matrix - ! / / - ! | N_A (nu dot grad N_B) dV + beta | N_A ( div nu ) N_B dV - ! / / select case(equation_type) - case(FIELD_EQUATION_INTERNALENERGY) - - if(multiphase) then - ! vfrac*rho*nu*grad(internalenergy) - advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei*density_at_quad*nvfrac_at_quad) - else - advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei*density_at_quad) - end if - - if(abs(beta) > epsilon(0.0)) then - velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) - - if(multiphase) then - ! advection_mat + internalenergy*div(vfrac*rho*nu) - ! Split up div(vfrac*rho*nu) = vfrac*rho*div(nu) + nu*grad(vfrac*rho) = vfrac*rho*div(nu) + nu*(vfrac*grad(rho) + rho*grad(nvfrac)) - - nvfracgrad_at_quad = ele_grad_at_quad(nvfrac, ele, dnvfrac_t) - udotgradnvfrac_at_quad = sum(nvfracgrad_at_quad*velocity_at_quad, 1) - - advection_mat = advection_mat + beta * ( shape_shape(test_function, t_shape, detwei*velocity_div_at_quad*density_at_quad*nvfrac_at_quad) & - + shape_shape(test_function, t_shape, detwei*nvfrac_at_quad*udotgradrho_at_quad) & - + shape_shape(test_function, t_shape, detwei*density_at_quad*udotgradnvfrac_at_quad) ) - else - advection_mat = advection_mat + beta*shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad & - +udotgradrho_at_quad)*detwei) - end if - end if - case(FIELD_EQUATION_KEPSILON) - advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei*density_at_quad) - if(abs(beta) > epsilon(0.0)) then - velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) - advection_mat = advection_mat & - + beta*shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad & - +udotgradrho_at_quad)*detwei) - end if - case default - advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei) - if(abs(beta) > epsilon(0.0)) then - velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) - advection_mat = advection_mat & - + beta*shape_shape(test_function, t_shape, velocity_div_at_quad*detwei) - end if - if(move_mesh) then - advection_mat = advection_mat & - - shape_shape(test_function, t_shape, ele_div_at_quad(grid_velocity, ele, dug_t)*detwei) - end if + case(FIELD_EQUATION_INTERNALENERGY) + assert(ele_ngi(density, ele)==ele_ngi(olddensity, ele)) + + density_at_quad = density_theta*ele_val_at_quad(density, ele)& + +(1.-density_theta)*ele_val_at_quad(olddensity, ele) + densitygrad_at_quad = density_theta*ele_grad_at_quad(density, ele, drho_t) & + +(1.-density_theta)*ele_grad_at_quad(olddensity, ele, drho_t) + udotgradrho_at_quad = sum(densitygrad_at_quad*velocity_at_quad, 1) + + if(multiphase) then + nvfrac_at_quad = ele_val_at_quad(nvfrac, ele) + end if + + case(FIELD_EQUATION_KEPSILON) + density_at_quad = ele_val_at_quad(density, ele) + densitygrad_at_quad = ele_grad_at_quad(density, ele, drho_t) + udotgradrho_at_quad = sum(densitygrad_at_quad*velocity_at_quad, 1) end select - end if - ! Stabilisation - select case(stabilisation_scheme) - case(STABILISATION_STREAMLINE_UPWIND) - if(have_diffusivity) then - advection_mat = advection_mat + & + if(integrate_advection_by_parts) then + ! element advection matrix + ! / / + ! - | (grad N_A dot nu) N_B dV - (1. - beta) | N_A ( div nu ) N_B dV + ! / / + select case(equation_type) + case(FIELD_EQUATION_INTERNALENERGY) + if(multiphase) then + advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei*density_at_quad*nvfrac_at_quad) + else + advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei*density_at_quad) + end if + + if(abs(1.0 - beta) > epsilon(0.0)) then + velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) + + if(multiphase) then + + nvfracgrad_at_quad = ele_grad_at_quad(nvfrac, ele, dnvfrac_t) + udotgradnvfrac_at_quad = sum(nvfracgrad_at_quad*velocity_at_quad, 1) + + advection_mat = advection_mat - (1.0-beta) * ( shape_shape(test_function, t_shape, detwei*velocity_div_at_quad*density_at_quad*nvfrac_at_quad) & + + shape_shape(test_function, t_shape, detwei*nvfrac_at_quad*udotgradrho_at_quad) & + + shape_shape(test_function, t_shape, detwei*density_at_quad*udotgradnvfrac_at_quad) ) + else + advection_mat = advection_mat - (1.0-beta) * shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad + udotgradrho_at_quad)*detwei) + end if + end if + case(FIELD_EQUATION_KEPSILON) + advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei*density_at_quad) + if(abs(1.0 - beta) > epsilon(0.0)) then + velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) + advection_mat = advection_mat & + - (1.0-beta) * shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad & + +udotgradrho_at_quad)* detwei) + end if + case default + advection_mat = -dshape_dot_vector_shape(dt_t, velocity_at_quad, t_shape, detwei) + if(abs(1.0 - beta) > epsilon(0.0)) then + velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) + advection_mat = advection_mat & + - (1.0-beta)*shape_shape(test_function, t_shape, velocity_div_at_quad*detwei) + end if + end select + else + ! element advection matrix + ! / / + ! | N_A (nu dot grad N_B) dV + beta | N_A ( div nu ) N_B dV + ! / / + select case(equation_type) + case(FIELD_EQUATION_INTERNALENERGY) + + if(multiphase) then + ! vfrac*rho*nu*grad(internalenergy) + advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei*density_at_quad*nvfrac_at_quad) + else + advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei*density_at_quad) + end if + + if(abs(beta) > epsilon(0.0)) then + velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) + + if(multiphase) then + ! advection_mat + internalenergy*div(vfrac*rho*nu) + ! Split up div(vfrac*rho*nu) = vfrac*rho*div(nu) + nu*grad(vfrac*rho) = vfrac*rho*div(nu) + nu*(vfrac*grad(rho) + rho*grad(nvfrac)) + + nvfracgrad_at_quad = ele_grad_at_quad(nvfrac, ele, dnvfrac_t) + udotgradnvfrac_at_quad = sum(nvfracgrad_at_quad*velocity_at_quad, 1) + + advection_mat = advection_mat + beta * ( shape_shape(test_function, t_shape, detwei*velocity_div_at_quad*density_at_quad*nvfrac_at_quad) & + + shape_shape(test_function, t_shape, detwei*nvfrac_at_quad*udotgradrho_at_quad) & + + shape_shape(test_function, t_shape, detwei*density_at_quad*udotgradnvfrac_at_quad) ) + else + advection_mat = advection_mat + beta*shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad & + +udotgradrho_at_quad)*detwei) + end if + end if + case(FIELD_EQUATION_KEPSILON) + advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei*density_at_quad) + if(abs(beta) > epsilon(0.0)) then + velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) + advection_mat = advection_mat & + + beta*shape_shape(test_function, t_shape, (velocity_div_at_quad*density_at_quad & + +udotgradrho_at_quad)*detwei) + end if + case default + advection_mat = shape_vector_dot_dshape(test_function, velocity_at_quad, dt_t, detwei) + if(abs(beta) > epsilon(0.0)) then + velocity_div_at_quad = ele_div_at_quad(velocity, ele, du_t) + advection_mat = advection_mat & + + beta*shape_shape(test_function, t_shape, velocity_div_at_quad*detwei) + end if + if(move_mesh) then + advection_mat = advection_mat & + - shape_shape(test_function, t_shape, ele_div_at_quad(grid_velocity, ele, dug_t)*detwei) + end if + end select + end if + + ! Stabilisation + select case(stabilisation_scheme) + case(STABILISATION_STREAMLINE_UPWIND) + if(have_diffusivity) then + advection_mat = advection_mat + & & element_upwind_stabilisation(t_shape, dt_t, velocity_at_quad, j_mat, detwei, & & diff_q = ele_val_at_quad(diffusivity, ele), nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - else - advection_mat = advection_mat + & + else + advection_mat = advection_mat + & & element_upwind_stabilisation(t_shape, dt_t, velocity_at_quad, j_mat, detwei, & & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - end if - case default - end select + end if + case default + end select - if(abs(dt_theta) > epsilon(0.0)) then - matrix_addto = matrix_addto + dt_theta * advection_mat - end if + if(abs(dt_theta) > epsilon(0.0)) then + matrix_addto = matrix_addto + dt_theta * advection_mat + end if - rhs_addto = rhs_addto - matmul(advection_mat, ele_val(t, ele)) + rhs_addto = rhs_addto - matmul(advection_mat, ele_val(t, ele)) - end subroutine add_advection_element_cg + end subroutine add_advection_element_cg - subroutine add_source_element_cg(ele, test_function, t, source, detwei, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: source - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + subroutine add_source_element_cg(ele, test_function, t, source, detwei, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: source + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - assert(have_source) + assert(have_source) - rhs_addto = rhs_addto + shape_rhs(test_function, detwei * ele_val_at_quad(source, ele)) + rhs_addto = rhs_addto + shape_rhs(test_function, detwei * ele_val_at_quad(source, ele)) - end subroutine add_source_element_cg + end subroutine add_source_element_cg - subroutine add_absorption_element_cg(ele, test_function, t, absorption, detwei, matrix_addto, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: absorption - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + subroutine add_absorption_element_cg(ele, test_function, t, absorption, detwei, matrix_addto, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: absorption + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: absorption_mat + real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: absorption_mat - assert(have_absorption) + assert(have_absorption) - absorption_mat = shape_shape(test_function, ele_shape(t, ele), detwei * ele_val_at_quad(absorption, ele)) + absorption_mat = shape_shape(test_function, ele_shape(t, ele), detwei * ele_val_at_quad(absorption, ele)) - if(abs(dt_theta) > epsilon(0.0)) matrix_addto = matrix_addto + dt_theta * absorption_mat + if(abs(dt_theta) > epsilon(0.0)) matrix_addto = matrix_addto + dt_theta * absorption_mat - rhs_addto = rhs_addto - matmul(absorption_mat, ele_val(t, ele)) + rhs_addto = rhs_addto - matmul(absorption_mat, ele_val(t, ele)) - end subroutine add_absorption_element_cg + end subroutine add_absorption_element_cg - subroutine add_diffusivity_element_cg(ele, t, diffusivity, dt_t, nvfrac, detwei, matrix_addto, rhs_addto) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: t, nvfrac - type(tensor_field), intent(in) :: diffusivity - real, dimension(ele_loc(t, ele), ele_ngi(t, ele), mesh_dim(t)), intent(in) :: dt_t - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + subroutine add_diffusivity_element_cg(ele, t, diffusivity, dt_t, nvfrac, detwei, matrix_addto, rhs_addto) + integer, intent(in) :: ele + type(scalar_field), intent(in) :: t, nvfrac + type(tensor_field), intent(in) :: diffusivity + real, dimension(ele_loc(t, ele), ele_ngi(t, ele), mesh_dim(t)), intent(in) :: dt_t + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - real, dimension(diffusivity%dim(1), diffusivity%dim(2), ele_ngi(diffusivity, ele)) :: diffusivity_gi - real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: diffusivity_mat + real, dimension(diffusivity%dim(1), diffusivity%dim(2), ele_ngi(diffusivity, ele)) :: diffusivity_gi + real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: diffusivity_mat - assert(have_diffusivity) + assert(have_diffusivity) - diffusivity_gi = ele_val_at_quad(diffusivity, ele) + diffusivity_gi = ele_val_at_quad(diffusivity, ele) - if(isotropic_diffusivity) then - assert(size(diffusivity_gi, 1) > 0) - if(multiphase .and. equation_type==FIELD_EQUATION_INTERNALENERGY) then - ! This allows us to use the Diffusivity term as the heat flux term - ! in the multiphase InternalEnergy equation: div( (k/Cv) * vfrac * grad(ie) ). - ! The user needs to input k/Cv for the prescribed diffusivity, - ! where k is the effective conductivity and Cv is the specific heat - ! at constant volume. We've assumed this will always be isotropic here. - ! The division by Cv is needed because the heat flux - ! is defined in terms of temperature T = ie/Cv. - diffusivity_mat = dshape_dot_dshape(dt_t, dt_t, detwei * diffusivity_gi(1, 1, :) * ele_val_at_quad(nvfrac, ele)) + if(isotropic_diffusivity) then + assert(size(diffusivity_gi, 1) > 0) + if(multiphase .and. equation_type==FIELD_EQUATION_INTERNALENERGY) then + ! This allows us to use the Diffusivity term as the heat flux term + ! in the multiphase InternalEnergy equation: div( (k/Cv) * vfrac * grad(ie) ). + ! The user needs to input k/Cv for the prescribed diffusivity, + ! where k is the effective conductivity and Cv is the specific heat + ! at constant volume. We've assumed this will always be isotropic here. + ! The division by Cv is needed because the heat flux + ! is defined in terms of temperature T = ie/Cv. + diffusivity_mat = dshape_dot_dshape(dt_t, dt_t, detwei * diffusivity_gi(1, 1, :) * ele_val_at_quad(nvfrac, ele)) + else + diffusivity_mat = dshape_dot_dshape(dt_t, dt_t, detwei * diffusivity_gi(1, 1, :)) + end if else - diffusivity_mat = dshape_dot_dshape(dt_t, dt_t, detwei * diffusivity_gi(1, 1, :)) + diffusivity_mat = dshape_tensor_dshape(dt_t, diffusivity_gi, dt_t, detwei) end if - else - diffusivity_mat = dshape_tensor_dshape(dt_t, diffusivity_gi, dt_t, detwei) - end if - - if(abs(dt_theta) > epsilon(0.0)) matrix_addto = matrix_addto + dt_theta * diffusivity_mat - - rhs_addto = rhs_addto - matmul(diffusivity_mat, ele_val(t, ele)) - - end subroutine add_diffusivity_element_cg - - subroutine add_pressurediv_element_cg(ele, test_function, t, velocity, pressure, nvfrac, du_t, detwei, rhs_addto) - - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: t - type(vector_field), intent(in) :: velocity - type(scalar_field), intent(in) :: pressure - type(scalar_field), intent(in) :: nvfrac - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(t)), intent(in) :: du_t - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - - assert(equation_type==FIELD_EQUATION_INTERNALENERGY) - assert(ele_ngi(pressure, ele)==ele_ngi(t, ele)) - - if(multiphase) then - ! -p * vfrac * div(nu) - rhs_addto = rhs_addto - shape_rhs(test_function, ele_div_at_quad(velocity, ele, du_t) * ele_val_at_quad(pressure, ele) * detwei * ele_val_at_quad(nvfrac, ele)) - else - rhs_addto = rhs_addto - shape_rhs(test_function, ele_div_at_quad(velocity, ele, du_t) * ele_val_at_quad(pressure, ele) * detwei) - end if - - end subroutine add_pressurediv_element_cg - - subroutine assemble_advection_diffusion_face_cg(face, bc_type, t, t_bc, t_bc_2, matrix, rhs, positions, velocity, grid_velocity, density, olddensity, nvfrac) - integer, intent(in) :: face - integer, intent(in) :: bc_type - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: t_bc - type(scalar_field), intent(in) :: t_bc_2 - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - type(vector_field), pointer :: grid_velocity - type(scalar_field), intent(in) :: density - type(scalar_field), intent(in) :: olddensity - type(scalar_field), intent(in) :: nvfrac - - integer, dimension(face_loc(t, face)) :: face_nodes - real, dimension(face_ngi(t, face)) :: detwei - real, dimension(mesh_dim(t), face_ngi(t, face)) :: normal - - ! What we will be adding to the matrix and RHS - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(face_loc(t, face)) :: rhs_addto - real, dimension(face_loc(t, face), face_loc(t, face)) :: matrix_addto - - assert(any(bc_type == (/0, BC_TYPE_NEUMANN, BC_TYPE_WEAKDIRICHLET, BC_TYPE_ROBIN/))) - assert(face_ngi(positions, face) == face_ngi(t, face)) - assert(face_ngi(velocity, face) == face_ngi(t, face)) - - matrix_addto = 0.0 - rhs_addto = 0.0 - - ! Step 1: Transform - - if(have_advection .and. integrate_advection_by_parts) then - call transform_facet_to_physical(positions, face, & - & detwei_f = detwei, normal = normal) - else if(have_diffusivity.and.((bc_type == BC_TYPE_NEUMANN).or.(bc_type == BC_TYPE_ROBIN))) then - call transform_facet_to_physical(positions, face, & - & detwei_f = detwei) - end if - - ! Note that with SUPG the surface element test function is not modified - - ! Step 2: Assemble contributions - - ! Advection - if(have_advection .and. integrate_advection_by_parts) & - call add_advection_face_cg(face, bc_type, t, t_bc, velocity, grid_velocity, density, olddensity, nvfrac, detwei, normal, matrix_addto, rhs_addto) - - ! Diffusivity - if(have_diffusivity) call add_diffusivity_face_cg(face, bc_type, t, t_bc, t_bc_2, detwei, matrix_addto, rhs_addto) - - ! Step 3: Insertion - - face_nodes = face_global_nodes(t, face) - call addto(matrix, face_nodes, face_nodes, matrix_addto) - call addto(rhs, face_nodes, rhs_addto) - - end subroutine assemble_advection_diffusion_face_cg - - subroutine add_advection_face_cg(face, bc_type, t, t_bc, velocity, grid_velocity, density, olddensity, nvfrac, detwei, normal, matrix_addto, rhs_addto) - integer, intent(in) :: face - integer, intent(in) :: bc_type - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: t_bc - type(vector_field), intent(in) :: velocity - type(vector_field), pointer :: grid_velocity - type(scalar_field), intent(in) :: density - type(scalar_field), intent(in) :: olddensity - type(scalar_field), intent(in) :: nvfrac - real, dimension(face_ngi(t, face)), intent(in) :: detwei - real, dimension(mesh_dim(t), face_ngi(t, face)), intent(in) :: normal - real, dimension(face_loc(t, face), face_loc(t, face)), intent(inout) :: matrix_addto - real, dimension(face_loc(t, face)), intent(inout) :: rhs_addto - - real, dimension(velocity%dim, face_ngi(velocity, face)) :: velocity_at_quad - real, dimension(face_loc(t, face), face_loc(t,face)) :: advection_mat - type(element_type), pointer :: t_shape - - real, dimension(face_ngi(density, face)) :: density_at_quad - - assert(have_advection) - assert(integrate_advection_by_parts) - - t_shape => face_shape(t, face) - - velocity_at_quad = face_val_at_quad(velocity, face) - if(move_mesh) then - velocity_at_quad = velocity_at_quad - face_val_at_quad(grid_velocity, face) - end if - select case(equation_type) - case(FIELD_EQUATION_INTERNALENERGY) - density_at_quad = density_theta*face_val_at_quad(density, face) & - +(1.0-density_theta)*face_val_at_quad(olddensity, face) + + if(abs(dt_theta) > epsilon(0.0)) matrix_addto = matrix_addto + dt_theta * diffusivity_mat + + rhs_addto = rhs_addto - matmul(diffusivity_mat, ele_val(t, ele)) + + end subroutine add_diffusivity_element_cg + + subroutine add_pressurediv_element_cg(ele, test_function, t, velocity, pressure, nvfrac, du_t, detwei, rhs_addto) + + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: t + type(vector_field), intent(in) :: velocity + type(scalar_field), intent(in) :: pressure + type(scalar_field), intent(in) :: nvfrac + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(t)), intent(in) :: du_t + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + + assert(equation_type==FIELD_EQUATION_INTERNALENERGY) + assert(ele_ngi(pressure, ele)==ele_ngi(t, ele)) if(multiphase) then - advection_mat = shape_shape(t_shape, t_shape, detwei * sum(velocity_at_quad * normal, 1) * density_at_quad * face_val_at_quad(nvfrac, face)) + ! -p * vfrac * div(nu) + rhs_addto = rhs_addto - shape_rhs(test_function, ele_div_at_quad(velocity, ele, du_t) * ele_val_at_quad(pressure, ele) * detwei * ele_val_at_quad(nvfrac, ele)) else - advection_mat = shape_shape(t_shape, t_shape, detwei * sum(velocity_at_quad * normal, 1) * density_at_quad) + rhs_addto = rhs_addto - shape_rhs(test_function, ele_div_at_quad(velocity, ele, du_t) * ele_val_at_quad(pressure, ele) * detwei) end if - case default - advection_mat = shape_shape(t_shape, t_shape, detwei * sum(velocity_at_quad * normal, 1)) + end subroutine add_pressurediv_element_cg + + subroutine assemble_advection_diffusion_face_cg(face, bc_type, t, t_bc, t_bc_2, matrix, rhs, positions, velocity, grid_velocity, density, olddensity, nvfrac) + integer, intent(in) :: face + integer, intent(in) :: bc_type + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: t_bc + type(scalar_field), intent(in) :: t_bc_2 + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(vector_field), pointer :: grid_velocity + type(scalar_field), intent(in) :: density + type(scalar_field), intent(in) :: olddensity + type(scalar_field), intent(in) :: nvfrac + + integer, dimension(face_loc(t, face)) :: face_nodes + real, dimension(face_ngi(t, face)) :: detwei + real, dimension(mesh_dim(t), face_ngi(t, face)) :: normal + + ! What we will be adding to the matrix and RHS - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(face_loc(t, face)) :: rhs_addto + real, dimension(face_loc(t, face), face_loc(t, face)) :: matrix_addto + + assert(any(bc_type == (/0, BC_TYPE_NEUMANN, BC_TYPE_WEAKDIRICHLET, BC_TYPE_ROBIN/))) + assert(face_ngi(positions, face) == face_ngi(t, face)) + assert(face_ngi(velocity, face) == face_ngi(t, face)) + + matrix_addto = 0.0 + rhs_addto = 0.0 + + ! Step 1: Transform + + if(have_advection .and. integrate_advection_by_parts) then + call transform_facet_to_physical(positions, face, & + & detwei_f = detwei, normal = normal) + else if(have_diffusivity.and.((bc_type == BC_TYPE_NEUMANN).or.(bc_type == BC_TYPE_ROBIN))) then + call transform_facet_to_physical(positions, face, & + & detwei_f = detwei) + end if - end select + ! Note that with SUPG the surface element test function is not modified - if(abs(dt_theta) > epsilon(0.0)) then - if(bc_type == BC_TYPE_WEAKDIRICHLET) then - rhs_addto = rhs_addto - theta * matmul(advection_mat, ele_val(t_bc, face) - face_val(t, face)) - else - matrix_addto = matrix_addto + dt_theta * advection_mat - end if - end if + ! Step 2: Assemble contributions + + ! Advection + if(have_advection .and. integrate_advection_by_parts) & + call add_advection_face_cg(face, bc_type, t, t_bc, velocity, grid_velocity, density, olddensity, nvfrac, detwei, normal, matrix_addto, rhs_addto) + + ! Diffusivity + if(have_diffusivity) call add_diffusivity_face_cg(face, bc_type, t, t_bc, t_bc_2, detwei, matrix_addto, rhs_addto) + + ! Step 3: Insertion + + face_nodes = face_global_nodes(t, face) + call addto(matrix, face_nodes, face_nodes, matrix_addto) + call addto(rhs, face_nodes, rhs_addto) - rhs_addto = rhs_addto - matmul(advection_mat, face_val(t, face)) + end subroutine assemble_advection_diffusion_face_cg - end subroutine add_advection_face_cg + subroutine add_advection_face_cg(face, bc_type, t, t_bc, velocity, grid_velocity, density, olddensity, nvfrac, detwei, normal, matrix_addto, rhs_addto) + integer, intent(in) :: face + integer, intent(in) :: bc_type + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: t_bc + type(vector_field), intent(in) :: velocity + type(vector_field), pointer :: grid_velocity + type(scalar_field), intent(in) :: density + type(scalar_field), intent(in) :: olddensity + type(scalar_field), intent(in) :: nvfrac + real, dimension(face_ngi(t, face)), intent(in) :: detwei + real, dimension(mesh_dim(t), face_ngi(t, face)), intent(in) :: normal + real, dimension(face_loc(t, face), face_loc(t, face)), intent(inout) :: matrix_addto + real, dimension(face_loc(t, face)), intent(inout) :: rhs_addto - subroutine add_diffusivity_face_cg(face, bc_type, t, t_bc, t_bc_2, detwei, matrix_addto, rhs_addto) - integer, intent(in) :: face - integer, intent(in) :: bc_type - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: t_bc - type(scalar_field), intent(in) :: t_bc_2 - real, dimension(face_ngi(t, face)), intent(in) :: detwei - real, dimension(face_loc(t, face), face_loc(t, face)), intent(inout) :: matrix_addto - real, dimension(face_loc(t, face)), intent(inout) :: rhs_addto + real, dimension(velocity%dim, face_ngi(velocity, face)) :: velocity_at_quad + real, dimension(face_loc(t, face), face_loc(t,face)) :: advection_mat + type(element_type), pointer :: t_shape - real, dimension(face_loc(t, face), face_loc(t,face)) :: robin_mat - type(element_type), pointer :: t_shape + real, dimension(face_ngi(density, face)) :: density_at_quad - assert(have_diffusivity) + assert(have_advection) + assert(integrate_advection_by_parts) - t_shape => face_shape(t, face) + t_shape => face_shape(t, face) - if(bc_type == BC_TYPE_NEUMANN) then - rhs_addto = rhs_addto + shape_rhs(t_shape, detwei * ele_val_at_quad(t_bc, face)) - else if(bc_type == BC_TYPE_ROBIN) then - rhs_addto = rhs_addto + shape_rhs(t_shape, detwei * ele_val_at_quad(t_bc, face)) - robin_mat = shape_shape(t_shape, t_shape, detwei * ele_val_at_quad(t_bc_2, face)) - if (abs(dt_theta) > epsilon(0.0)) then - matrix_addto = matrix_addto + dt_theta * robin_mat + velocity_at_quad = face_val_at_quad(velocity, face) + if(move_mesh) then + velocity_at_quad = velocity_at_quad - face_val_at_quad(grid_velocity, face) end if - ! this next term is due to solving the acceleration form of the equation - rhs_addto = rhs_addto - matmul(robin_mat, face_val(t, face)) - else if(bc_type == BC_TYPE_WEAKDIRICHLET) then - ! Need to add stuff here once transform_to_physical can supply gradients - ! on faces to ensure that weak bcs work - FLExit("Weak Dirichlet boundary conditions with diffusivity are not supported by CG advection-diffusion") - end if + select case(equation_type) + case(FIELD_EQUATION_INTERNALENERGY) + density_at_quad = density_theta*face_val_at_quad(density, face) & + +(1.0-density_theta)*face_val_at_quad(olddensity, face) - end subroutine add_diffusivity_face_cg + if(multiphase) then + advection_mat = shape_shape(t_shape, t_shape, detwei * sum(velocity_at_quad * normal, 1) * density_at_quad * face_val_at_quad(nvfrac, face)) + else + advection_mat = shape_shape(t_shape, t_shape, detwei * sum(velocity_at_quad * normal, 1) * density_at_quad) + end if + case default - subroutine solve_advection_diffusion_cg(t, delta_t, matrix, rhs, state, iterations_taken) - type(scalar_field), intent(in) :: t - type(scalar_field), intent(inout) :: delta_t - type(csr_matrix), intent(in) :: matrix - type(scalar_field), intent(in) :: rhs - type(state_type), intent(in) :: state - integer, intent(out), optional :: iterations_taken + advection_mat = shape_shape(t_shape, t_shape, detwei * sum(velocity_at_quad * normal, 1)) - call petsc_solve(delta_t, matrix, rhs, state, option_path = t%option_path, & - iterations_taken = iterations_taken) + end select - ewrite_minmax(delta_t) + if(abs(dt_theta) > epsilon(0.0)) then + if(bc_type == BC_TYPE_WEAKDIRICHLET) then + rhs_addto = rhs_addto - theta * matmul(advection_mat, ele_val(t_bc, face) - face_val(t, face)) + else + matrix_addto = matrix_addto + dt_theta * advection_mat + end if + end if - end subroutine solve_advection_diffusion_cg + rhs_addto = rhs_addto - matmul(advection_mat, face_val(t, face)) + + end subroutine add_advection_face_cg + + subroutine add_diffusivity_face_cg(face, bc_type, t, t_bc, t_bc_2, detwei, matrix_addto, rhs_addto) + integer, intent(in) :: face + integer, intent(in) :: bc_type + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: t_bc + type(scalar_field), intent(in) :: t_bc_2 + real, dimension(face_ngi(t, face)), intent(in) :: detwei + real, dimension(face_loc(t, face), face_loc(t, face)), intent(inout) :: matrix_addto + real, dimension(face_loc(t, face)), intent(inout) :: rhs_addto + + real, dimension(face_loc(t, face), face_loc(t,face)) :: robin_mat + type(element_type), pointer :: t_shape + + assert(have_diffusivity) + + t_shape => face_shape(t, face) + + if(bc_type == BC_TYPE_NEUMANN) then + rhs_addto = rhs_addto + shape_rhs(t_shape, detwei * ele_val_at_quad(t_bc, face)) + else if(bc_type == BC_TYPE_ROBIN) then + rhs_addto = rhs_addto + shape_rhs(t_shape, detwei * ele_val_at_quad(t_bc, face)) + robin_mat = shape_shape(t_shape, t_shape, detwei * ele_val_at_quad(t_bc_2, face)) + if (abs(dt_theta) > epsilon(0.0)) then + matrix_addto = matrix_addto + dt_theta * robin_mat + end if + ! this next term is due to solving the acceleration form of the equation + rhs_addto = rhs_addto - matmul(robin_mat, face_val(t, face)) + else if(bc_type == BC_TYPE_WEAKDIRICHLET) then + ! Need to add stuff here once transform_to_physical can supply gradients + ! on faces to ensure that weak bcs work + FLExit("Weak Dirichlet boundary conditions with diffusivity are not supported by CG advection-diffusion") + end if - subroutine apply_advection_diffusion_cg_change(t, delta_t, dt) - type(scalar_field), intent(inout) :: t - type(scalar_field), intent(in) :: delta_t - real, intent(in) :: dt + end subroutine add_diffusivity_face_cg - ewrite_minmax(t) + subroutine solve_advection_diffusion_cg(t, delta_t, matrix, rhs, state, iterations_taken) + type(scalar_field), intent(in) :: t + type(scalar_field), intent(inout) :: delta_t + type(csr_matrix), intent(in) :: matrix + type(scalar_field), intent(in) :: rhs + type(state_type), intent(in) :: state + integer, intent(out), optional :: iterations_taken - call addto(t, delta_t, dt) + call petsc_solve(delta_t, matrix, rhs, state, option_path = t%option_path, & + iterations_taken = iterations_taken) - ewrite_minmax(t) + ewrite_minmax(delta_t) - end subroutine apply_advection_diffusion_cg_change + end subroutine solve_advection_diffusion_cg - subroutine advection_diffusion_cg_check_options - !!< Check CG advection-diffusion specific options + subroutine apply_advection_diffusion_cg_change(t, delta_t, dt) + type(scalar_field), intent(inout) :: t + type(scalar_field), intent(in) :: delta_t + real, intent(in) :: dt - character(len = FIELD_NAME_LEN) :: field_name, state_name, mesh_0, mesh_1 - character(len = OPTION_PATH_LEN) :: path - integer :: i, j, stat - real :: beta, l_theta + ewrite_minmax(t) - if(option_count("/material_phase/scalar_field/prognostic/spatial_discretisation/continuous_galerkin") == 0) then - ! Nothing to check - return - end if + call addto(t, delta_t, dt) - ewrite(2, *) "Checking CG advection-diffusion options" + ewrite_minmax(t) - if(option_count("/material_phase/scalar_field::" // advdif_cg_rhs_name) > 0) then - FLExit("The scalar field name " // advdif_cg_rhs_name // " is reserved") - end if + end subroutine apply_advection_diffusion_cg_change - if(option_count("/material_phase/scalar_field::" // advdif_cg_delta_t_name) > 0) then - FLExit("The scalar field name " // advdif_cg_delta_t_name // " is reserved") - end if + subroutine advection_diffusion_cg_check_options + !!< Check CG advection-diffusion specific options - do i = 0, option_count("/material_phase") - 1 - path = "/material_phase[" // int2str(i) // "]" - call get_option(trim(path) // "/name", state_name) + character(len = FIELD_NAME_LEN) :: field_name, state_name, mesh_0, mesh_1 + character(len = OPTION_PATH_LEN) :: path + integer :: i, j, stat + real :: beta, l_theta - do j = 0, option_count(trim(path) // "/scalar_field") - 1 - path = "/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]" - call get_option(trim(path) // "/name", field_name) + if(option_count("/material_phase/scalar_field/prognostic/spatial_discretisation/continuous_galerkin") == 0) then + ! Nothing to check + return + end if - if(field_name /= "Pressure") then + ewrite(2, *) "Checking CG advection-diffusion options" - path = trim(path) // "/prognostic" + if(option_count("/material_phase/scalar_field::" // advdif_cg_rhs_name) > 0) then + FLExit("The scalar field name " // advdif_cg_rhs_name // " is reserved") + end if - if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin").and.& - have_option(trim(path) // "/equation[0]")) then - call get_option(trim(path) // "/spatial_discretisation/conservative_advection", beta, stat) - if(stat == SPUD_NO_ERROR) then - if(beta < 0.0 .or. beta > 1.0) then + if(option_count("/material_phase/scalar_field::" // advdif_cg_delta_t_name) > 0) then + FLExit("The scalar field name " // advdif_cg_delta_t_name // " is reserved") + end if - call field_error(state_name, field_name, & - & "Conservative advection factor (beta) must be >= 0.0 and <= 1.0") - end if - else - call field_error(state_name, field_name, & - & "Conservative advection factor (beta) required") - end if + do i = 0, option_count("/material_phase") - 1 + path = "/material_phase[" // int2str(i) // "]" + call get_option(trim(path) // "/name", state_name) - call get_option(trim(path) // "/temporal_discretisation/theta", l_theta, stat) - if(stat == SPUD_NO_ERROR) then - if(l_theta < 0. .or. l_theta > 1.0) then - call field_error(state_name, field_name, & - &"Implicitness factor (theta) must be >= 0.0 and <= 1.0") - end if - else - call field_error(state_name, field_name, & - & "Implicitness factor (theta) required") - end if - if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/mass_terms/exclude_mass_terms") .and. & - & abs(l_theta - 1.0) > epsilon(0.0)) then - call field_warning(state_name, field_name, & - & "Implicitness factor (theta) should = 1.0 when excluding mass") - end if + do j = 0, option_count(trim(path) // "/scalar_field") - 1 + path = "/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]" + call get_option(trim(path) // "/name", field_name) - if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin") .and. & - & have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/advection_terms/integrate_advection_by_parts")) then - call field_warning(state_name, field_name, & - & "SUPG stabilisation should only be used with advection not integrated by parts") - end if + if(field_name /= "Pressure") then - if(option_count(trim(path) // "/boundary_conditions/type::dirichlet/apply_weakly") > 0 & - & .and. have_option(trim(path) // "/tensor_field::Diffusivity")) then - call field_error(state_name, field_name, & - & "Weak Dirichlet boundary conditions with diffusivity are not supported by CG advection-diffusion") - end if + path = trim(path) // "/prognostic" - if (have_option(trim(path) // "/scalar_field::SinkingVelocity")) then - call get_option(trim(complete_field_path(trim(path) // & - "/scalar_field::SinkingVelocity"))//"/mesh[0]/name", & - mesh_0, stat) - if(stat == SPUD_NO_ERROR) then - call get_option(trim(complete_field_path("/material_phase[" // int2str(i) // & - "]/vector_field::Velocity")) // "/mesh[0]/name", mesh_1) - if(trim(mesh_0) /= trim(mesh_1)) then + if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin").and.& + have_option(trim(path) // "/equation[0]")) then + call get_option(trim(path) // "/spatial_discretisation/conservative_advection", beta, stat) + if(stat == SPUD_NO_ERROR) then + if(beta < 0.0 .or. beta > 1.0) then + + call field_error(state_name, field_name, & + & "Conservative advection factor (beta) must be >= 0.0 and <= 1.0") + end if + else + call field_error(state_name, field_name, & + & "Conservative advection factor (beta) required") + end if + + call get_option(trim(path) // "/temporal_discretisation/theta", l_theta, stat) + if(stat == SPUD_NO_ERROR) then + if(l_theta < 0. .or. l_theta > 1.0) then + call field_error(state_name, field_name, & + &"Implicitness factor (theta) must be >= 0.0 and <= 1.0") + end if + else + call field_error(state_name, field_name, & + & "Implicitness factor (theta) required") + end if + if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/mass_terms/exclude_mass_terms") .and. & + & abs(l_theta - 1.0) > epsilon(0.0)) then call field_warning(state_name, field_name, & - & "SinkingVelocity is on a different mesh to the Velocity field. This could cause problems") + & "Implicitness factor (theta) should = 1.0 when excluding mass") + end if + + if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin") .and. & + & have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/advection_terms/integrate_advection_by_parts")) then + call field_warning(state_name, field_name, & + & "SUPG stabilisation should only be used with advection not integrated by parts") end if - end if - end if - if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/advection_terms/exclude_advection_terms")) then - if(have_option(trim(path) // "/scalar_field::SinkingVelocity")) then - call field_warning(state_name, field_name, & - & "SinkingVelocity set, but advection terms have been excluded - SinkingVelocity will have no effect") - end if - end if - if(option_count(trim(path) // "/boundary_conditions/type::neumann") > 0 & - & .and. .not. (have_option(trim(path) // "/tensor_field::Diffusivity") & - & .or. have_option(trim(path) // "/subgridscale_parameterisation::k-epsilon") & - & .or. have_option(trim(path) // "/subgridscale_parameterisation::GLS"))) then - call field_warning(state_name, field_name, & - & "Neumann boundary condition set, but have no diffusivity - boundary condition will not be applied") + if(option_count(trim(path) // "/boundary_conditions/type::dirichlet/apply_weakly") > 0 & + & .and. have_option(trim(path) // "/tensor_field::Diffusivity")) then + call field_error(state_name, field_name, & + & "Weak Dirichlet boundary conditions with diffusivity are not supported by CG advection-diffusion") + end if + + if (have_option(trim(path) // "/scalar_field::SinkingVelocity")) then + call get_option(trim(complete_field_path(trim(path) // & + "/scalar_field::SinkingVelocity"))//"/mesh[0]/name", & + mesh_0, stat) + if(stat == SPUD_NO_ERROR) then + call get_option(trim(complete_field_path("/material_phase[" // int2str(i) // & + "]/vector_field::Velocity")) // "/mesh[0]/name", mesh_1) + if(trim(mesh_0) /= trim(mesh_1)) then + call field_warning(state_name, field_name, & + & "SinkingVelocity is on a different mesh to the Velocity field. This could cause problems") + end if + end if + end if + if(have_option(trim(path) // "/spatial_discretisation/continuous_galerkin/advection_terms/exclude_advection_terms")) then + if(have_option(trim(path) // "/scalar_field::SinkingVelocity")) then + call field_warning(state_name, field_name, & + & "SinkingVelocity set, but advection terms have been excluded - SinkingVelocity will have no effect") + end if + end if + + if(option_count(trim(path) // "/boundary_conditions/type::neumann") > 0 & + & .and. .not. (have_option(trim(path) // "/tensor_field::Diffusivity") & + & .or. have_option(trim(path) // "/subgridscale_parameterisation::k-epsilon") & + & .or. have_option(trim(path) // "/subgridscale_parameterisation::GLS"))) then + call field_warning(state_name, field_name, & + & "Neumann boundary condition set, but have no diffusivity - boundary condition will not be applied") + end if + end if end if - end if - end if + end do end do - end do - ewrite(2, *) "Finished checking CG advection-diffusion options" + ewrite(2, *) "Finished checking CG advection-diffusion options" - contains + contains - subroutine field_warning(state_name, field_name, msg) - character(len = *), intent(in) :: state_name - character(len = *), intent(in) :: field_name - character(len = *), intent(in) :: msg + subroutine field_warning(state_name, field_name, msg) + character(len = *), intent(in) :: state_name + character(len = *), intent(in) :: field_name + character(len = *), intent(in) :: msg - ewrite(0, *) "Warning: For field " // trim(field_name) // " in state " // trim(state_name) - ewrite(0, *) trim(msg) + ewrite(0, *) "Warning: For field " // trim(field_name) // " in state " // trim(state_name) + ewrite(0, *) trim(msg) - end subroutine field_warning + end subroutine field_warning - subroutine field_error(state_name, field_name, msg) - character(len = *), intent(in) :: state_name - character(len = *), intent(in) :: field_name - character(len = *), intent(in) :: msg + subroutine field_error(state_name, field_name, msg) + character(len = *), intent(in) :: state_name + character(len = *), intent(in) :: field_name + character(len = *), intent(in) :: msg - ewrite(-1, *) "For field " // trim(field_name) // " in state " // trim(state_name) - FLExit(trim(msg)) + ewrite(-1, *) "For field " // trim(field_name) // " in state " // trim(state_name) + FLExit(trim(msg)) - end subroutine field_error + end subroutine field_error - end subroutine advection_diffusion_cg_check_options + end subroutine advection_diffusion_cg_check_options end module advection_diffusion_cg diff --git a/assemble/Advection_Diffusion_DG.F90 b/assemble/Advection_Diffusion_DG.F90 index 7762ab2615..7bcf0e3487 100644 --- a/assemble/Advection_Diffusion_DG.F90 +++ b/assemble/Advection_Diffusion_DG.F90 @@ -27,3289 +27,3289 @@ #include "fdebug.h" module advection_diffusion_DG - !!< This module contains the Discontinuous Galerkin form of the advection - !!< -diffusion equation for scalars. - use fldebug - use vector_tools - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN, COLOURING_DG2, & -COLOURING_DG0 - use elements - use integer_set_module - use spud + !!< This module contains the Discontinuous Galerkin form of the advection + !!< -diffusion equation for scalars. + use fldebug + use vector_tools + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN, COLOURING_DG2, & + COLOURING_DG0 + use elements + use integer_set_module + use spud #ifdef _OPENMP - use omp_lib + use omp_lib #endif - use parallel_tools - use sparse_tools - use shape_functions - use transform_elements - use fetools - use parallel_fields - use fields - use profiler - use state_module - use boundary_conditions - use sparsity_patterns - use dgtools - use vtk_interfaces - use field_options - use sparse_matrices_fields - use fefields - use field_derivatives - use coordinates - use sparsity_patterns_meshes - use petsc_solve_state_module - use boundary_conditions_from_options - use upwind_stabilisation - use slope_limiters_dg - use diagnostic_fields, only: calculate_diagnostic_variable - use colouring, only: get_mesh_colouring - - implicit none - - private - public solve_advection_diffusion_dg, construct_advection_diffusion_dg, & - advection_diffusion_dg_check_options - - ! Local private control parameters. These are module-global parameters - ! because it would be expensive and/or inconvenient to re-evaluate them - ! on a per-element or per-face basis - real :: dt, theta - - ! Whether the advection term is only integrated by parts once. - logical :: integrate_by_parts_once=.false. - ! Whether the conservation term is integrated by parts or not - logical :: integrate_conservation_term_by_parts=.false. - ! Weight between conservative and non-conservative forms of the advection - ! equation. - ! 1 is for conservative 0 is for non-conservative. - real :: beta - ! Whether we are constructing equations in semidiscrete form - logical :: semi_discrete - ! Whether to include various terms - logical :: include_advection, include_diffusion - ! Whether we have a separate diffusion matrix - logical :: have_diffusion_m - ! Discretisation to use for diffusion term. - integer :: diffusion_scheme - integer, parameter :: ARBITRARY_UPWIND=1 - integer, parameter :: BASSI_REBAY=2 - integer, parameter :: CDG=3 - integer, parameter :: IP=4 - integer, parameter :: MASSLUMPED_RT0=5 - ! Discretisation to use for advective flux. - integer :: flux_scheme - integer, parameter :: UPWIND_FLUX=1 - integer, parameter :: LAX_FRIEDRICHS_FLUX=2 - - ! Boundary condition types: - ! (the numbers should match up with the order in the - ! get_entire_boundary_condition call) - integer :: BCTYPE_WEAKDIRICHLET=1, BCTYPE_DIRICHLET=2, BCTYPE_NEUMANN=3 - - logical :: include_mass - ! are we moving the mesh? - logical :: move_mesh - - ! Stabilisation schemes. - integer :: stabilisation_scheme - integer, parameter :: NONE=0 - integer, parameter :: UPWIND=1 - - !IP penalty parameter - real :: Interior_Penalty_Parameter, edge_length_power - !special debugging options - logical :: debugging, remove_element_integral, remove_primal_fluxes, & - & remove_penalty_fluxes - real :: gradient_test_bound - - ! Method for getting h0 in IP - integer :: edge_length_option - integer, parameter :: USE_FACE_INTEGRALS=1 - integer, parameter :: USE_ELEMENT_CENTRES=2 - - ! CDG stuff - real, dimension(3) :: switch_g - logical :: remove_CDG_fluxes - logical :: CDG_penalty - - ! RT0 masslumping for diffusion - integer :: rt0_masslumping_scheme=0 ! choice from values below: - integer, parameter :: RT0_MASSLUMPING_ARBOGAST=1 - integer, parameter :: RT0_MASSLUMPING_CIRCUMCENTRED=2 - - ! Are we on a sphere? - logical :: on_sphere - ! Vertical diffusion by mixing option - logical :: have_buoyancy_adjustment_by_vertical_diffusion - logical :: have_buoyancy_adjustment_diffusivity + use parallel_tools + use sparse_tools + use shape_functions + use transform_elements + use fetools + use parallel_fields + use fields + use profiler + use state_module + use boundary_conditions + use sparsity_patterns + use dgtools + use vtk_interfaces + use field_options + use sparse_matrices_fields + use fefields + use field_derivatives + use coordinates + use sparsity_patterns_meshes + use petsc_solve_state_module + use boundary_conditions_from_options + use upwind_stabilisation + use slope_limiters_dg + use diagnostic_fields, only: calculate_diagnostic_variable + use colouring, only: get_mesh_colouring + + implicit none + + private + public solve_advection_diffusion_dg, construct_advection_diffusion_dg, & + advection_diffusion_dg_check_options + + ! Local private control parameters. These are module-global parameters + ! because it would be expensive and/or inconvenient to re-evaluate them + ! on a per-element or per-face basis + real :: dt, theta + + ! Whether the advection term is only integrated by parts once. + logical :: integrate_by_parts_once=.false. + ! Whether the conservation term is integrated by parts or not + logical :: integrate_conservation_term_by_parts=.false. + ! Weight between conservative and non-conservative forms of the advection + ! equation. + ! 1 is for conservative 0 is for non-conservative. + real :: beta + ! Whether we are constructing equations in semidiscrete form + logical :: semi_discrete + ! Whether to include various terms + logical :: include_advection, include_diffusion + ! Whether we have a separate diffusion matrix + logical :: have_diffusion_m + ! Discretisation to use for diffusion term. + integer :: diffusion_scheme + integer, parameter :: ARBITRARY_UPWIND=1 + integer, parameter :: BASSI_REBAY=2 + integer, parameter :: CDG=3 + integer, parameter :: IP=4 + integer, parameter :: MASSLUMPED_RT0=5 + ! Discretisation to use for advective flux. + integer :: flux_scheme + integer, parameter :: UPWIND_FLUX=1 + integer, parameter :: LAX_FRIEDRICHS_FLUX=2 + + ! Boundary condition types: + ! (the numbers should match up with the order in the + ! get_entire_boundary_condition call) + integer :: BCTYPE_WEAKDIRICHLET=1, BCTYPE_DIRICHLET=2, BCTYPE_NEUMANN=3 + + logical :: include_mass + ! are we moving the mesh? + logical :: move_mesh + + ! Stabilisation schemes. + integer :: stabilisation_scheme + integer, parameter :: NONE=0 + integer, parameter :: UPWIND=1 + + !IP penalty parameter + real :: Interior_Penalty_Parameter, edge_length_power + !special debugging options + logical :: debugging, remove_element_integral, remove_primal_fluxes, & + & remove_penalty_fluxes + real :: gradient_test_bound + + ! Method for getting h0 in IP + integer :: edge_length_option + integer, parameter :: USE_FACE_INTEGRALS=1 + integer, parameter :: USE_ELEMENT_CENTRES=2 + + ! CDG stuff + real, dimension(3) :: switch_g + logical :: remove_CDG_fluxes + logical :: CDG_penalty + + ! RT0 masslumping for diffusion + integer :: rt0_masslumping_scheme=0 ! choice from values below: + integer, parameter :: RT0_MASSLUMPING_ARBOGAST=1 + integer, parameter :: RT0_MASSLUMPING_CIRCUMCENTRED=2 + + ! Are we on a sphere? + logical :: on_sphere + ! Vertical diffusion by mixing option + logical :: have_buoyancy_adjustment_by_vertical_diffusion + logical :: have_buoyancy_adjustment_diffusivity contains - subroutine solve_advection_diffusion_dg(field_name, state, velocity_name) - !!< Construct and solve the advection-diffusion equation for the given - !!< field using discontinuous elements. + subroutine solve_advection_diffusion_dg(field_name, state, velocity_name) + !!< Construct and solve the advection-diffusion equation for the given + !!< field using discontinuous elements. - !! Name of the field to be solved for. - character(len=*), intent(in) :: field_name - !! Collection of fields defining system state. - type(state_type), intent(inout) :: state - character(len=*), optional, intent(in) :: velocity_name + !! Name of the field to be solved for. + character(len=*), intent(in) :: field_name + !! Collection of fields defining system state. + type(state_type), intent(inout) :: state + character(len=*), optional, intent(in) :: velocity_name - !! Tracer to be solved for. - type(scalar_field), pointer :: T + !! Tracer to be solved for. + type(scalar_field), pointer :: T - !! Local velocity name. - character(len=FIELD_NAME_LEN) :: lvelocity_name, pmesh_name + !! Local velocity name. + character(len=FIELD_NAME_LEN) :: lvelocity_name, pmesh_name - !! Projected velocity field for them as needs it. - type(vector_field) :: pvelocity - !! Nonlinear velocity field. - type(vector_field), pointer :: U_nl, X - !! Mesh for projeced velocity. - type(mesh_type), pointer :: pmesh + !! Projected velocity field for them as needs it. + type(vector_field) :: pvelocity + !! Nonlinear velocity field. + type(vector_field), pointer :: U_nl, X + !! Mesh for projeced velocity. + type(mesh_type), pointer :: pmesh - ewrite(1,*) "In solve_advection_diffusion_dg" - ewrite(1,*) "Solving advection-diffusion equation for field " // & + ewrite(1,*) "In solve_advection_diffusion_dg" + ewrite(1,*) "Solving advection-diffusion equation for field " // & trim(field_name) // " in state " // trim(state%name) - T=>extract_scalar_field(state, field_name) + T=>extract_scalar_field(state, field_name) - ! Set local velocity name: - if(present(velocity_name)) then - lvelocity_name=velocity_name - else - lvelocity_name="NonlinearVelocity" - end if + ! Set local velocity name: + if(present(velocity_name)) then + lvelocity_name=velocity_name + else + lvelocity_name="NonlinearVelocity" + end if - if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/advection_scheme"//& - &"/project_velocity_to_continuous")) then + if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/advection_scheme"//& + &"/project_velocity_to_continuous")) then - if(.not.has_scalar_field(state, "Projected"//trim(lvelocity_name))) & - &then + if(.not.has_scalar_field(state, "Projected"//trim(lvelocity_name))) & + &then - call get_option(trim(T%option_path)& + call get_option(trim(T%option_path)& //"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/advection_scheme"//& - &"/project_velocity_to_continuous/mesh/name",pmesh_name) - - U_nl=>extract_vector_field(state, lvelocity_name) - pmesh=>extract_mesh(state, pmesh_name) - X=>extract_vector_field(state, "Coordinate") - - lvelocity_name="Projected"//trim(lvelocity_name) - call allocate(pvelocity, U_nl%dim, pmesh, lvelocity_name) + &"/discontinuous_galerkin/advection_scheme"//& + &"/project_velocity_to_continuous/mesh/name",pmesh_name) - call project_field(U_nl, pvelocity, X) + U_nl=>extract_vector_field(state, lvelocity_name) + pmesh=>extract_mesh(state, pmesh_name) + X=>extract_vector_field(state, "Coordinate") - call insert(state, pvelocity, lvelocity_name) + lvelocity_name="Projected"//trim(lvelocity_name) + call allocate(pvelocity, U_nl%dim, pmesh, lvelocity_name) - ! Discard the additional reference. - call deallocate(pvelocity) - else - lvelocity_name="Projected"//trim(lvelocity_name) - pvelocity=extract_vector_field(state,lvelocity_name) - end if + call project_field(U_nl, pvelocity, X) - end if + call insert(state, pvelocity, lvelocity_name) + ! Discard the additional reference. + call deallocate(pvelocity) + else + lvelocity_name="Projected"//trim(lvelocity_name) + pvelocity=extract_vector_field(state,lvelocity_name) + end if - call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& - &"conservative_advection", beta) + end if - ! by default we assume we're integrating by parts twice - integrate_by_parts_once = have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& - &"discontinuous_galerkin/advection_scheme/integrate_advection_by_parts/once") - integrate_conservation_term_by_parts = have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& - &"discontinuous_galerkin/advection_scheme/integrate_conservation_term_by_parts") + call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + &"conservative_advection", beta) + + ! by default we assume we're integrating by parts twice + integrate_by_parts_once = have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + &"discontinuous_galerkin/advection_scheme/integrate_advection_by_parts/once") + + integrate_conservation_term_by_parts = have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + &"discontinuous_galerkin/advection_scheme/integrate_conservation_term_by_parts") + + ! Determine the scheme to use to discretise diffusivity. + if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + &"discontinuous_galerkin/diffusion_scheme/bassi_rebay")) then + diffusion_scheme=BASSI_REBAY + else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + &"discontinuous_galerkin/diffusion_scheme/arbitrary_upwind")) then + diffusion_scheme=ARBITRARY_UPWIND + else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + &"discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin")) then + !=================Compact Discontinuous Galerkin + diffusion_scheme=CDG + !Set the switch vector + switch_g = 0. + switch_g(1) = exp(sin(3.0+exp(1.0))) + if(mesh_dim(T)>1) switch_g(2) = (cos(exp(3.0)/sin(2.0)))**2 + if(mesh_dim(T)>2) switch_g(3) = sin(cos(sin(cos(3.0)))) + switch_g = switch_g/sqrt(sum(switch_g**2)) + !switch_g = 1.0/(sqrt(1.0*mesh_dim(T))) + + remove_penalty_fluxes = .true. + interior_penalty_parameter = 0.0 + if(have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation/"//& + &"discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/penalty_parameter")) then + remove_penalty_fluxes = .false. + edge_length_power = 0.0 + call get_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/penalty_parameter"& + &,Interior_Penalty_Parameter) + end if - ! Determine the scheme to use to discretise diffusivity. - if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& - &"discontinuous_galerkin/diffusion_scheme/bassi_rebay")) then - diffusion_scheme=BASSI_REBAY - else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& - &"discontinuous_galerkin/diffusion_scheme/arbitrary_upwind")) then - diffusion_scheme=ARBITRARY_UPWIND - else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation/"//& + debugging = have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation/"//& &"discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin")) then - !=================Compact Discontinuous Galerkin - diffusion_scheme=CDG - !Set the switch vector - switch_g = 0. - switch_g(1) = exp(sin(3.0+exp(1.0))) - if(mesh_dim(T)>1) switch_g(2) = (cos(exp(3.0)/sin(2.0)))**2 - if(mesh_dim(T)>2) switch_g(3) = sin(cos(sin(cos(3.0)))) - switch_g = switch_g/sqrt(sum(switch_g**2)) - !switch_g = 1.0/(sqrt(1.0*mesh_dim(T))) - - remove_penalty_fluxes = .true. - interior_penalty_parameter = 0.0 - if(have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation/"//& - &"discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/penalty_parameter")) then - remove_penalty_fluxes = .false. - edge_length_power = 0.0 - call get_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/penalty_parameter"& - &,Interior_Penalty_Parameter) - end if - - debugging = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation/"//& - &"discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/debug") - CDG_penalty = .true. - if(debugging) then - call get_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/debug/gradient_test_bound",& - &gradient_test_bound) - remove_element_integral = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/debug/remove_element_integral") - remove_primal_fluxes = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/debug/remove_primal_fluxes") - remove_cdg_fluxes = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/debug/remove_cdg_fluxes") + &"/compact_discontinuous_galerkin/debug") + CDG_penalty = .true. + if(debugging) then + call get_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/debug/gradient_test_bound",& + &gradient_test_bound) + remove_element_integral = have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/debug/remove_element_integral") + remove_primal_fluxes = have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/debug/remove_primal_fluxes") + remove_cdg_fluxes = have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/debug/remove_cdg_fluxes") - if (have_option(trim(T%option_path)//& + if (have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/compact_discontinuous_galerkin/debug"//& + &"/edge_length_power")) then + call get_option(trim(T%option_path)//& &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& &"/compact_discontinuous_galerkin/debug"//& - &"/edge_length_power")) then - call get_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/compact_discontinuous_galerkin/debug"//& - &"/edge_length_power",edge_length_power) - cdg_penalty = .false. - end if - end if - edge_length_option = USE_FACE_INTEGRALS - - else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/edge_length_power",edge_length_power) + cdg_penalty = .false. + end if + end if + edge_length_option = USE_FACE_INTEGRALS + + else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/interior_penalty")) then + remove_penalty_fluxes = .false. + diffusion_scheme=IP + CDG_penalty = .false. + call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/interior_penalty/penalty_parameter",Interior_Penalty_Parameter) + call get_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/interior_penalty/edge_length_power",edge_length_power) + edge_length_option = USE_FACE_INTEGRALS + if(have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty")) then - remove_penalty_fluxes = .false. - diffusion_scheme=IP - CDG_penalty = .false. - call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/interior_penalty/edge_length_option/use_element_centres")) then + edge_length_option = USE_ELEMENT_CENTRES + end if + debugging = have_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/interior_penalty/debug") + remove_element_integral = .false. + remove_primal_fluxes = .false. + if(debugging) then + call get_option(trim(T%option_path)//& + &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/penalty_parameter",Interior_Penalty_Parameter) - call get_option(trim(T%option_path)//& + &"/interior_penalty/debug/gradient_test_bound",gradient_test_bound) + remove_element_integral = have_option(trim(T%option_path)//& &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/edge_length_power",edge_length_power) - edge_length_option = USE_FACE_INTEGRALS - if(have_option(trim(T%option_path)//& + &"/interior_penalty/debug/remove_element_integral") + remove_primal_fluxes = have_option(trim(T%option_path)//& &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/edge_length_option/use_element_centres")) then - edge_length_option = USE_ELEMENT_CENTRES - end if - debugging = have_option(trim(T%option_path)//& + &"/interior_penalty/debug/remove_primal_fluxes") + remove_penalty_fluxes = have_option(trim(T%option_path)//& &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/debug") - remove_element_integral = .false. - remove_primal_fluxes = .false. - if(debugging) then - call get_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/debug/gradient_test_bound",gradient_test_bound) - remove_element_integral = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/debug/remove_element_integral") - remove_primal_fluxes = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/debug/remove_primal_fluxes") - remove_penalty_fluxes = have_option(trim(T%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/interior_penalty/debug/remove_penalty_fluxes") - end if - else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/diffusion_scheme"//& - &"/masslumped_rt0")) then - diffusion_scheme=MASSLUMPED_RT0 - if (have_option(trim(T%option_path)//& + &"/interior_penalty/debug/remove_penalty_fluxes") + end if + else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/diffusion_scheme"//& + &"/masslumped_rt0")) then + diffusion_scheme=MASSLUMPED_RT0 + if (have_option(trim(T%option_path)//& &"/prognostic/spatial_discretisation/discontinuous_galerkin/diffusion_scheme/masslumped_rt0/arbogast"& &)) then - rt0_masslumping_scheme=RT0_MASSLUMPING_ARBOGAST - else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + rt0_masslumping_scheme=RT0_MASSLUMPING_ARBOGAST + else if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/diffusion_scheme"//& &"/masslumped_rt0/circumcentred")) then - rt0_masslumping_scheme=RT0_MASSLUMPING_CIRCUMCENTRED - else - FLAbort("Unknown rt0 masslumping for P0 diffusion.") - end if - else - FLAbort("Unknown diffusion scheme for DG Advection Diffusion") - end if - - ! Vertical mixing by diffusion - have_buoyancy_adjustment_by_vertical_diffusion=have_option(trim(T%option_path)//"/prognostic/buoyancy_adjustment/by_vertical_diffusion") - - if (have_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/number_advection_subcycles")) then - call solve_advection_diffusion_dg_subcycle(field_name, state, lvelocity_name) - else if (have_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/maximum_courant_number_per_subcycle")) then - call solve_advection_diffusion_dg_subcycle(field_name, state, lvelocity_name) - else - call solve_advection_diffusion_dg_theta(field_name, state, lvelocity_name) - end if - - end subroutine solve_advection_diffusion_dg - - subroutine solve_advection_diffusion_dg_theta(field_name, state, velocity_name) - !!< Construct and solve the advection-diffusion equation for the given - !!< field unsing discontinuous elements. - - !! Name of the field to be solved for. - character(len=*), intent(in) :: field_name - !! Collection of fields defining system state. - type(state_type), intent(inout) :: state - !! Name of advecting velocity field - character(len=*), intent(in) :: velocity_name - - !! Tracer to be solved for. - type(scalar_field), pointer :: T, T_old - - !! Change in T over one timestep. - type(scalar_field) :: delta_T - - !! Sparsity of advection_diffusion matrix. - type(csr_sparsity), pointer :: sparsity - - !! System matrix. - type(csr_matrix) :: matrix - - !! Right hand side vector. - type(scalar_field) :: rhs - - T=>extract_scalar_field(state, field_name) - T_old=>extract_scalar_field(state, "Old"//field_name) - - ! Reset T to value at the beginning of the timestep. - call set(T, T_old) - - select case(diffusion_scheme) - case(CDG) - ! This is bigger than we need for CDG - sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) - !sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) - case(IP) - sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) - case default - sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) - end select - - call allocate(matrix, sparsity) ! Add data space to the sparsity - ! pattern. - - ! Ensure delta_T inherits options from T. - call allocate(delta_T, T%mesh, trim(field_name)//"Change") - delta_T%option_path = T%option_path - call allocate(rhs, T%mesh, trim(field_name)//"RHS") - - call construct_advection_diffusion_dg(matrix, rhs, field_name, state,& + rt0_masslumping_scheme=RT0_MASSLUMPING_CIRCUMCENTRED + else + FLAbort("Unknown rt0 masslumping for P0 diffusion.") + end if + else + FLAbort("Unknown diffusion scheme for DG Advection Diffusion") + end if + + ! Vertical mixing by diffusion + have_buoyancy_adjustment_by_vertical_diffusion=have_option(trim(T%option_path)//"/prognostic/buoyancy_adjustment/by_vertical_diffusion") + + if (have_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& + &"/number_advection_subcycles")) then + call solve_advection_diffusion_dg_subcycle(field_name, state, lvelocity_name) + else if (have_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& + &"/maximum_courant_number_per_subcycle")) then + call solve_advection_diffusion_dg_subcycle(field_name, state, lvelocity_name) + else + call solve_advection_diffusion_dg_theta(field_name, state, lvelocity_name) + end if + + end subroutine solve_advection_diffusion_dg + + subroutine solve_advection_diffusion_dg_theta(field_name, state, velocity_name) + !!< Construct and solve the advection-diffusion equation for the given + !!< field unsing discontinuous elements. + + !! Name of the field to be solved for. + character(len=*), intent(in) :: field_name + !! Collection of fields defining system state. + type(state_type), intent(inout) :: state + !! Name of advecting velocity field + character(len=*), intent(in) :: velocity_name + + !! Tracer to be solved for. + type(scalar_field), pointer :: T, T_old + + !! Change in T over one timestep. + type(scalar_field) :: delta_T + + !! Sparsity of advection_diffusion matrix. + type(csr_sparsity), pointer :: sparsity + + !! System matrix. + type(csr_matrix) :: matrix + + !! Right hand side vector. + type(scalar_field) :: rhs + + T=>extract_scalar_field(state, field_name) + T_old=>extract_scalar_field(state, "Old"//field_name) + + ! Reset T to value at the beginning of the timestep. + call set(T, T_old) + + select case(diffusion_scheme) + case(CDG) + ! This is bigger than we need for CDG + sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) + !sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) + case(IP) + sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) + case default + sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) + end select + + call allocate(matrix, sparsity) ! Add data space to the sparsity + ! pattern. + + ! Ensure delta_T inherits options from T. + call allocate(delta_T, T%mesh, trim(field_name)//"Change") + delta_T%option_path = T%option_path + call allocate(rhs, T%mesh, trim(field_name)//"RHS") + + call construct_advection_diffusion_dg(matrix, rhs, field_name, state,& velocity_name=velocity_name) - ! Apply strong dirichlet boundary conditions. - ! This is for big spring boundary conditions. - call apply_dirichlet_conditions(matrix, rhs, T, dt) + ! Apply strong dirichlet boundary conditions. + ! This is for big spring boundary conditions. + call apply_dirichlet_conditions(matrix, rhs, T, dt) - call zero(delta_T) ! Impose zero initial guess. - ! Solve for the change in T. - call petsc_solve(delta_T, matrix, rhs, state) + call zero(delta_T) ! Impose zero initial guess. + ! Solve for the change in T. + call petsc_solve(delta_T, matrix, rhs, state) - ! Add the change in T to T. - call addto(T, delta_T, dt) + ! Add the change in T to T. + call addto(T, delta_T, dt) - call deallocate(delta_T) - call deallocate(matrix) - call deallocate(rhs) + call deallocate(delta_T) + call deallocate(matrix) + call deallocate(rhs) - end subroutine solve_advection_diffusion_dg_theta + end subroutine solve_advection_diffusion_dg_theta - subroutine solve_advection_diffusion_dg_subcycle(field_name, state, velocity_name) - !!< Construct and solve the advection-diffusion equation for the given - !!< field using discontinuous elements. + subroutine solve_advection_diffusion_dg_subcycle(field_name, state, velocity_name) + !!< Construct and solve the advection-diffusion equation for the given + !!< field using discontinuous elements. - !! Name of the field to be solved for. - character(len=*), intent(in) :: field_name - !! Collection of fields defining system state. - type(state_type), intent(inout) :: state - !! Optional velocity name - character(len = *), intent(in) :: velocity_name + !! Name of the field to be solved for. + character(len=*), intent(in) :: field_name + !! Collection of fields defining system state. + type(state_type), intent(inout) :: state + !! Optional velocity name + character(len = *), intent(in) :: velocity_name - !! Tracer to be solved for. - type(scalar_field), pointer :: T, T_old, s_field + !! Tracer to be solved for. + type(scalar_field), pointer :: T, T_old, s_field - !! Coordinate field - type(vector_field), pointer :: X, U_nl + !! Coordinate field + type(vector_field), pointer :: X, U_nl - !! Change in T over one timestep. - type(scalar_field) :: delta_T + !! Change in T over one timestep. + type(scalar_field) :: delta_T - !! Sparsity of advection_diffusion matrix. - type(csr_sparsity), pointer :: sparsity + !! Sparsity of advection_diffusion matrix. + type(csr_sparsity), pointer :: sparsity - !! System matrix. - type(csr_matrix) :: matrix, matrix_diff, mass, inv_mass + !! System matrix. + type(csr_matrix) :: matrix, matrix_diff, mass, inv_mass - !! Sparsity of mass matrix. - type(csr_sparsity) :: mass_sparsity + !! Sparsity of mass matrix. + type(csr_sparsity) :: mass_sparsity - !! Right hand side vector. - type(scalar_field) :: rhs, rhs_diff + !! Right hand side vector. + type(scalar_field) :: rhs, rhs_diff - !! Whether to invoke the slope limiter - logical :: limit_slope - !! Which limiter to use - integer :: limiter + !! Whether to invoke the slope limiter + logical :: limit_slope + !! Which limiter to use + integer :: limiter - !! Number of advection subcycles. - integer :: subcycles - real :: max_courant_number + !! Number of advection subcycles. + integer :: subcycles + real :: max_courant_number - character(len=FIELD_NAME_LEN) :: limiter_name - integer :: i + character(len=FIELD_NAME_LEN) :: limiter_name + integer :: i - !! Courant number field name used for temporal subcycling - character(len=FIELD_NAME_LEN) :: Courant_number_name + !! Courant number field name used for temporal subcycling + character(len=FIELD_NAME_LEN) :: Courant_number_name - T=>extract_scalar_field(state, field_name) - T_old=>extract_scalar_field(state, "Old"//field_name) - X=>extract_vector_field(state, "Coordinate") + T=>extract_scalar_field(state, field_name) + T_old=>extract_scalar_field(state, "Old"//field_name) + X=>extract_vector_field(state, "Coordinate") - ! Reset T to value at the beginning of the timestep. - call set(T, T_old) + ! Reset T to value at the beginning of the timestep. + call set(T, T_old) - sparsity => get_csr_sparsity_firstorder(state, T%mesh, T%mesh) + sparsity => get_csr_sparsity_firstorder(state, T%mesh, T%mesh) - call allocate(matrix, sparsity) ! Add data space to the sparsity - ! pattern. + call allocate(matrix, sparsity) ! Add data space to the sparsity + ! pattern. - select case(diffusion_scheme) - case(CDG) - ! This is bigger than we need for CDG - sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) - !sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) - case(IP) - sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) - case default - sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) - end select + select case(diffusion_scheme) + case(CDG) + ! This is bigger than we need for CDG + sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) + !sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) + case(IP) + sparsity => get_csr_sparsity_compactdgdouble(state, T%mesh) + case default + sparsity => get_csr_sparsity_secondorder(state, T%mesh, T%mesh) + end select - ! Ditto for diffusion - call allocate(matrix_diff, sparsity) + ! Ditto for diffusion + call allocate(matrix_diff, sparsity) - mass_sparsity=make_sparsity_dg_mass(T%mesh) - call allocate(mass, mass_sparsity) - call allocate(inv_mass, mass_sparsity) + mass_sparsity=make_sparsity_dg_mass(T%mesh) + call allocate(mass, mass_sparsity) + call allocate(inv_mass, mass_sparsity) - ! Ensure delta_T inherits options from T. - call allocate(delta_T, T%mesh, "delta_T") - delta_T%option_path = T%option_path - call allocate(rhs, T%mesh, trim(field_name)//" RHS") - call allocate(rhs_diff, T%mesh, trim(field_name)//" Diffusion RHS") + ! Ensure delta_T inherits options from T. + call allocate(delta_T, T%mesh, "delta_T") + delta_T%option_path = T%option_path + call allocate(rhs, T%mesh, trim(field_name)//" RHS") + call allocate(rhs_diff, T%mesh, trim(field_name)//" Diffusion RHS") - call construct_advection_diffusion_dg(matrix, rhs, field_name, state, & + call construct_advection_diffusion_dg(matrix, rhs, field_name, state, & mass=mass, diffusion_m=matrix_diff, diffusion_rhs=rhs_diff, semidiscrete=.true., & velocity_name=velocity_name) - ! mass has only been assembled only for owned elements, so we can only compute - ! its inverse for owned elements - call get_dg_inverse_mass_matrix(inv_mass, mass, only_owned_elements=.true.) + ! mass has only been assembled only for owned elements, so we can only compute + ! its inverse for owned elements + call get_dg_inverse_mass_matrix(inv_mass, mass, only_owned_elements=.true.) - ! Note that since theta and dt are module global, these lines have to - ! come after construct_advection_diffusion_dg. - call get_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/theta", theta) - call get_option("/timestepping/timestep", dt) + ! Note that since theta and dt are module global, these lines have to + ! come after construct_advection_diffusion_dg. + call get_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/theta", theta) + call get_option("/timestepping/timestep", dt) - if(have_option(trim(T%option_path)//& + if(have_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& + &"/number_advection_subcycles")) then + call get_option(trim(T%option_path)//& &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/number_advection_subcycles")) then - call get_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/number_advection_subcycles", subcycles) - else - call get_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/maximum_courant_number_per_subcycle", Max_Courant_number) - - ! Determine the courant field to use to find the max - call get_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/maximum_courant_number_per_subcycle/courant_number/name", & - &Courant_number_name, default="DG_CourantNumber") - - s_field => extract_scalar_field(state, trim(Courant_number_name)) - call calculate_diagnostic_variable(state, trim(Courant_number_name), & - & s_field, option_path=trim(T%option_path)//& - &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& - &"/courant_number") - - subcycles = ceiling( maxval(s_field%val)/Max_Courant_number) - call allmax(subcycles) - ewrite(2,*) 'Number of subcycles for tracer eqn: ', subcycles - end if - - limit_slope=.false. - if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/slope_limiter")) then - limit_slope=.true. - - ! Note unsafe for mixed element meshes - if (element_degree(T,1)==0) then - FLExit("Slope limiters make no sense for degree 0 fields") - end if - - call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/slope_limiter/name",limiter_name) - - select case(trim(limiter_name)) - case("Cockburn_Shu") - limiter=LIMITER_COCKBURN - case("Hermite_Weno") - limiter=LIMITER_HERMITE_WENO - case("minimal") - limiter=LIMITER_MINIMAL - case("FPN") - limiter=LIMITER_FPN - case("Vertex_Based") - limiter=LIMITER_VB - case default - FLAbort('No such limiter') - end select - - end if - - U_nl=>extract_vector_field(state, velocity_name) - - do i=1, subcycles - - ! dT = Advection * T - call mult(delta_T, matrix, T) - ! dT = dT + RHS - call addto(delta_T, RHS, -1.0) - ! dT = M^(-1) dT - call dg_apply_mass(inv_mass, delta_T) - - ! T = T + dt/s * dT - call addto(T, delta_T, scale=-dt/subcycles) - call halo_update(T) - if (limit_slope) then - ! Filter wiggles from T - call limit_slope_dg(T, U_nl, X, state, limiter) - end if - - end do - - if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then - ! Form RHS of diffusion equation. - call mult(delta_T, matrix_diff, T) - call addto(RHS_diff, delta_T,-1.0) - - call scale(matrix_diff, theta*dt) - call addto(matrix_diff,mass) - call zero(delta_T) ! Impose zero initial guess. - ! Solve for the change in T. - call petsc_solve(delta_T, matrix_diff, RHS_diff, state) - - ! Add the change in T to T. - call addto(T, delta_T, dt) - end if - - call deallocate(delta_T) - call deallocate(matrix) - call deallocate(matrix_diff) - call deallocate(mass) - call deallocate(inv_mass) - call deallocate(mass_sparsity) - call deallocate(rhs) - call deallocate(rhs_diff) - - end subroutine solve_advection_diffusion_dg_subcycle - - subroutine construct_advection_diffusion_dg(big_m, rhs, field_name,& - & state, mass, diffusion_m, diffusion_rhs, semidiscrete, velocity_name) - !!< Construct the advection_diffusion equation for discontinuous elements in - !!< acceleration form. - !!< - !!< If mass is provided then the mass matrix is not added into big_m or - !!< rhs. It is instead returned as mass. This may be useful for testing - !!< or for solving equations otherwise than in acceleration form. - !!< - !!< If diffusion_m and diffusion_rhs are provided then the diffustion - !!< terms are placed here instead of in big_m and rhs - !!< - !!< If semidiscrete is present and true then the semidiscrete matrices - !!< are formed. This is accomplished by locally setting theta to 1.0 - !!< and only inserting boundary conditions in the right hand side. - !!< Setting semidiscrete to 1 probably only makes sense if a separate - !!< mass matrix is also provided. - - !! Main advection_diffusion matrix. - type(csr_matrix), intent(inout) :: big_m - !! Right hand side vector. - type(scalar_field), intent(inout) :: rhs - - !! Name of the field to be advected. - character(len=*), intent(in) :: field_name - !! Collection of fields defining system state. - type(state_type), intent(inout) :: state - !! Optional separate mass matrix. - type(csr_matrix), intent(inout), optional :: mass - !! Optional separate diffusion matrix - type(csr_matrix), intent(inout), optional :: diffusion_m - !! Corresponding right hand side vector - type(scalar_field), intent(inout), optional :: diffusion_rhs - !! Optional velocity name - character(len = *), intent(in), optional :: velocity_name - - !! Flag for whether to construct semidiscrete form of the equation. - logical, intent(in), optional :: semidiscrete - - !! Position, and velocity fields. - type(vector_field) :: X, U, U_nl - type(vector_field), pointer :: X_new, X_old, U_mesh - !! Tracer to be solved for. - type(scalar_field) :: T - !! Diffusivity - type(tensor_field) :: Diffusivity - type(tensor_field) :: LESDiffusivity - - !! Source and absorption - type(scalar_field) :: Source, Absorption - - !! Local velocity name - character(len = FIELD_NAME_LEN) :: lvelocity_name - - !! Element index - integer :: ele - - !! Status variable for field extraction. - integer :: stat - - !! Gravitational sinking term - type(scalar_field) :: Sink - !! Direction of gravity - type(vector_field) :: gravity - !! Backup of U_nl for calculating sinking - type(vector_field) :: U_nl_backup - !! Buoyancy and gravity - type(scalar_field) :: buoyancy - type(scalar_field) :: buoyancy_from_state - real :: gravity_magnitude - real :: mixing_diffusion_amplitude - - !! Mesh for auxiliary variable - type(mesh_type), save :: q_mesh - - !! Local diffusion matrices and right hand side - type(csr_matrix) :: big_m_diff - type(scalar_field) :: rhs_diff - - !! Field over the entire surface mesh containing bc values: - type(scalar_field) :: bc_value - !! Integer array of all surface elements indicating bc type - !! (see below call to get_entire_boundary_condition): - integer, dimension(:), allocatable :: bc_type - - type(mesh_type), pointer :: mesh_cg - - !! Add the Source directly to the right hand side? - logical :: add_src_directly_to_rhs - - - type(integer_set), dimension(:), pointer :: colours - integer :: len, clr, nnid + &"/number_advection_subcycles", subcycles) + else + call get_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& + &"/maximum_courant_number_per_subcycle", Max_Courant_number) + + ! Determine the courant field to use to find the max + call get_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& + &"/maximum_courant_number_per_subcycle/courant_number/name", & + &Courant_number_name, default="DG_CourantNumber") + + s_field => extract_scalar_field(state, trim(Courant_number_name)) + call calculate_diagnostic_variable(state, trim(Courant_number_name), & + & s_field, option_path=trim(T%option_path)//& + &"/prognostic/temporal_discretisation/discontinuous_galerkin"//& + &"/courant_number") + + subcycles = ceiling( maxval(s_field%val)/Max_Courant_number) + call allmax(subcycles) + ewrite(2,*) 'Number of subcycles for tracer eqn: ', subcycles + end if + + limit_slope=.false. + if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/slope_limiter")) then + limit_slope=.true. + + ! Note unsafe for mixed element meshes + if (element_degree(T,1)==0) then + FLExit("Slope limiters make no sense for degree 0 fields") + end if + + call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/slope_limiter/name",limiter_name) + + select case(trim(limiter_name)) + case("Cockburn_Shu") + limiter=LIMITER_COCKBURN + case("Hermite_Weno") + limiter=LIMITER_HERMITE_WENO + case("minimal") + limiter=LIMITER_MINIMAL + case("FPN") + limiter=LIMITER_FPN + case("Vertex_Based") + limiter=LIMITER_VB + case default + FLAbort('No such limiter') + end select + + end if + + U_nl=>extract_vector_field(state, velocity_name) + + do i=1, subcycles + + ! dT = Advection * T + call mult(delta_T, matrix, T) + ! dT = dT + RHS + call addto(delta_T, RHS, -1.0) + ! dT = M^(-1) dT + call dg_apply_mass(inv_mass, delta_T) + + ! T = T + dt/s * dT + call addto(T, delta_T, scale=-dt/subcycles) + call halo_update(T) + if (limit_slope) then + ! Filter wiggles from T + call limit_slope_dg(T, U_nl, X, state, limiter) + end if + + end do + + if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then + ! Form RHS of diffusion equation. + call mult(delta_T, matrix_diff, T) + call addto(RHS_diff, delta_T,-1.0) + + call scale(matrix_diff, theta*dt) + call addto(matrix_diff,mass) + call zero(delta_T) ! Impose zero initial guess. + ! Solve for the change in T. + call petsc_solve(delta_T, matrix_diff, RHS_diff, state) + + ! Add the change in T to T. + call addto(T, delta_T, dt) + end if + + call deallocate(delta_T) + call deallocate(matrix) + call deallocate(matrix_diff) + call deallocate(mass) + call deallocate(inv_mass) + call deallocate(mass_sparsity) + call deallocate(rhs) + call deallocate(rhs_diff) + + end subroutine solve_advection_diffusion_dg_subcycle + + subroutine construct_advection_diffusion_dg(big_m, rhs, field_name,& + & state, mass, diffusion_m, diffusion_rhs, semidiscrete, velocity_name) + !!< Construct the advection_diffusion equation for discontinuous elements in + !!< acceleration form. + !!< + !!< If mass is provided then the mass matrix is not added into big_m or + !!< rhs. It is instead returned as mass. This may be useful for testing + !!< or for solving equations otherwise than in acceleration form. + !!< + !!< If diffusion_m and diffusion_rhs are provided then the diffustion + !!< terms are placed here instead of in big_m and rhs + !!< + !!< If semidiscrete is present and true then the semidiscrete matrices + !!< are formed. This is accomplished by locally setting theta to 1.0 + !!< and only inserting boundary conditions in the right hand side. + !!< Setting semidiscrete to 1 probably only makes sense if a separate + !!< mass matrix is also provided. + + !! Main advection_diffusion matrix. + type(csr_matrix), intent(inout) :: big_m + !! Right hand side vector. + type(scalar_field), intent(inout) :: rhs + + !! Name of the field to be advected. + character(len=*), intent(in) :: field_name + !! Collection of fields defining system state. + type(state_type), intent(inout) :: state + !! Optional separate mass matrix. + type(csr_matrix), intent(inout), optional :: mass + !! Optional separate diffusion matrix + type(csr_matrix), intent(inout), optional :: diffusion_m + !! Corresponding right hand side vector + type(scalar_field), intent(inout), optional :: diffusion_rhs + !! Optional velocity name + character(len = *), intent(in), optional :: velocity_name + + !! Flag for whether to construct semidiscrete form of the equation. + logical, intent(in), optional :: semidiscrete + + !! Position, and velocity fields. + type(vector_field) :: X, U, U_nl + type(vector_field), pointer :: X_new, X_old, U_mesh + !! Tracer to be solved for. + type(scalar_field) :: T + !! Diffusivity + type(tensor_field) :: Diffusivity + type(tensor_field) :: LESDiffusivity + + !! Source and absorption + type(scalar_field) :: Source, Absorption + + !! Local velocity name + character(len = FIELD_NAME_LEN) :: lvelocity_name + + !! Element index + integer :: ele + + !! Status variable for field extraction. + integer :: stat + + !! Gravitational sinking term + type(scalar_field) :: Sink + !! Direction of gravity + type(vector_field) :: gravity + !! Backup of U_nl for calculating sinking + type(vector_field) :: U_nl_backup + !! Buoyancy and gravity + type(scalar_field) :: buoyancy + type(scalar_field) :: buoyancy_from_state + real :: gravity_magnitude + real :: mixing_diffusion_amplitude + + !! Mesh for auxiliary variable + type(mesh_type), save :: q_mesh + + !! Local diffusion matrices and right hand side + type(csr_matrix) :: big_m_diff + type(scalar_field) :: rhs_diff + + !! Field over the entire surface mesh containing bc values: + type(scalar_field) :: bc_value + !! Integer array of all surface elements indicating bc type + !! (see below call to get_entire_boundary_condition): + integer, dimension(:), allocatable :: bc_type + + type(mesh_type), pointer :: mesh_cg + + !! Add the Source directly to the right hand side? + logical :: add_src_directly_to_rhs + + + type(integer_set), dimension(:), pointer :: colours + integer :: len, clr, nnid #ifdef _OPENMP - !! Is the transform_to_physical cache we prepopulated valid - logical :: cache_valid - integer :: num_threads + !! Is the transform_to_physical cache we prepopulated valid + logical :: cache_valid + integer :: num_threads #endif - !! Diffusivity to add due to the buoyancy adjustment by vertical mixing scheme - type(scalar_field) :: buoyancy_adjustment_diffusivity - - ewrite(1,*) "Writing advection-diffusion equation for "& - &//trim(field_name) - - ! These names are based on the CGNS SIDS. - T=extract_scalar_field(state, field_name) - X=extract_vector_field(state, "Coordinate") - - semi_discrete=present_and_true(semidiscrete) - - ! If a separate diffusion matrix has been provided, put diffusion in - ! there. Otherwise put it in the RHS. - have_diffusion_m = present(diffusion_m) - if (present(diffusion_m)) then - big_m_diff=diffusion_m - else - big_m_diff=big_m - end if - if (present(diffusion_rhs)) then - if(.not.have_diffusion_m) then - FLAbort("diffusion_m required") - end if - rhs_diff=diffusion_rhs - else - rhs_diff=rhs - end if - - if(present(velocity_name)) then - lvelocity_name = velocity_name - else - lvelocity_name = "NonlinearVelocity" - end if - - on_sphere = have_option('/geometry/spherical_earth/') - - if (.not.have_option(trim(T%option_path)//"/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin"//& - &"/advection_scheme/none")) then - U_nl_backup=extract_vector_field(state, lvelocity_name) - call incref(U_nl_backup) - include_advection=.true. - else - ! Forcing a zero NonlinearVelocity will disable advection. - U=extract_vector_field(state, "Velocity", stat) - if (stat/=0) then - FLExit("Oh dear, no velocity field. A velocity field is required for advection!") - end if - call allocate(U_nl_backup, U%dim, U%mesh, "BackupNonlinearVelocity", & + !! Diffusivity to add due to the buoyancy adjustment by vertical mixing scheme + type(scalar_field) :: buoyancy_adjustment_diffusivity + + ewrite(1,*) "Writing advection-diffusion equation for "& + &//trim(field_name) + + ! These names are based on the CGNS SIDS. + T=extract_scalar_field(state, field_name) + X=extract_vector_field(state, "Coordinate") + + semi_discrete=present_and_true(semidiscrete) + + ! If a separate diffusion matrix has been provided, put diffusion in + ! there. Otherwise put it in the RHS. + have_diffusion_m = present(diffusion_m) + if (present(diffusion_m)) then + big_m_diff=diffusion_m + else + big_m_diff=big_m + end if + if (present(diffusion_rhs)) then + if(.not.have_diffusion_m) then + FLAbort("diffusion_m required") + end if + rhs_diff=diffusion_rhs + else + rhs_diff=rhs + end if + + if(present(velocity_name)) then + lvelocity_name = velocity_name + else + lvelocity_name = "NonlinearVelocity" + end if + + on_sphere = have_option('/geometry/spherical_earth/') + + if (.not.have_option(trim(T%option_path)//"/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin"//& + &"/advection_scheme/none")) then + U_nl_backup=extract_vector_field(state, lvelocity_name) + call incref(U_nl_backup) + include_advection=.true. + else + ! Forcing a zero NonlinearVelocity will disable advection. + U=extract_vector_field(state, "Velocity", stat) + if (stat/=0) then + FLExit("Oh dear, no velocity field. A velocity field is required for advection!") + end if + call allocate(U_nl_backup, U%dim, U%mesh, "BackupNonlinearVelocity", & FIELD_TYPE_CONSTANT) - call zero(U_nl_backup) - include_advection=.false. - end if + call zero(U_nl_backup) + include_advection=.false. + end if - flux_scheme=UPWIND_FLUX - if (have_option(trim(T%option_path)//"/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin"//& - &"/advection_scheme/lax_friedrichs")) then - flux_scheme=LAX_FRIEDRICHS_FLUX - end if + flux_scheme=UPWIND_FLUX + if (have_option(trim(T%option_path)//"/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin"//& + &"/advection_scheme/lax_friedrichs")) then + flux_scheme=LAX_FRIEDRICHS_FLUX + end if - call allocate(U_nl, U_nl_backup%dim, U_nl_backup%mesh, "LocalNonlinearVelocity") - call set(U_nl, U_nl_backup) + call allocate(U_nl, U_nl_backup%dim, U_nl_backup%mesh, "LocalNonlinearVelocity") + call set(U_nl, U_nl_backup) - Diffusivity=extract_tensor_field(state, trim(field_name)//"Diffusivity"& - &, stat=stat) - if (stat/=0) then - call allocate(Diffusivity, T%mesh, trim(field_name)//"Diffusivity",& + Diffusivity=extract_tensor_field(state, trim(field_name)//"Diffusivity"& + &, stat=stat) + if (stat/=0) then + call allocate(Diffusivity, T%mesh, trim(field_name)//"Diffusivity",& FIELD_TYPE_CONSTANT) - call zero(Diffusivity) - include_diffusion=.false. - else - if (have_option(trim(T%option_path)//"/prognostic"//& + call zero(Diffusivity) + include_diffusion=.false. + else + if (have_option(trim(T%option_path)//"/prognostic"//& &"/subgridscale_parameterisation::LES")) then - ! this routine takes Diffusivity as its background diffusivity - ! and returns the sum of this and the les diffusivity - call construct_les_dg(state,T, X, Diffusivity, LESDiffusivity) - ! the sum is what we want to apply: - Diffusivity = LESDiffusivity - else - ! Grab an extra reference to cause the deallocate below to be safe. - call incref(Diffusivity) - end if - - include_diffusion=.true. - end if - - Source=extract_scalar_field(state, trim(field_name)//"Source"& - &, stat=stat) - if (stat/=0) then - call allocate(Source, T%mesh, trim(field_name)//"Source",& + ! this routine takes Diffusivity as its background diffusivity + ! and returns the sum of this and the les diffusivity + call construct_les_dg(state,T, X, Diffusivity, LESDiffusivity) + ! the sum is what we want to apply: + Diffusivity = LESDiffusivity + else + ! Grab an extra reference to cause the deallocate below to be safe. + call incref(Diffusivity) + end if + + include_diffusion=.true. + end if + + Source=extract_scalar_field(state, trim(field_name)//"Source"& + &, stat=stat) + if (stat/=0) then + call allocate(Source, T%mesh, trim(field_name)//"Source",& FIELD_TYPE_CONSTANT) - call zero(Source) + call zero(Source) - add_src_directly_to_rhs = .false. - else - ! Grab an extra reference to cause the deallocate below to be safe. - call incref(Source) + add_src_directly_to_rhs = .false. + else + ! Grab an extra reference to cause the deallocate below to be safe. + call incref(Source) - add_src_directly_to_rhs = have_option(trim(Source%option_path)//'/diagnostic/add_directly_to_rhs') + add_src_directly_to_rhs = have_option(trim(Source%option_path)//'/diagnostic/add_directly_to_rhs') - if (add_src_directly_to_rhs) then - ewrite(2, *) "Adding Source field directly to the right hand side" - assert(node_count(Source) == node_count(T)) - end if + if (add_src_directly_to_rhs) then + ewrite(2, *) "Adding Source field directly to the right hand side" + assert(node_count(Source) == node_count(T)) + end if - end if + end if - Absorption=extract_scalar_field(state, trim(field_name)//"Absorption"& - &, stat=stat) - if (stat/=0) then - call allocate(Absorption, T%mesh, trim(field_name)//"Absorption",& + Absorption=extract_scalar_field(state, trim(field_name)//"Absorption"& + &, stat=stat) + if (stat/=0) then + call allocate(Absorption, T%mesh, trim(field_name)//"Absorption",& FIELD_TYPE_CONSTANT) - call zero(Absorption) - else - ! Grab an extra reference to cause the deallocate below to be safe. - call incref(Absorption) - end if - - Sink=extract_scalar_field(state, trim(field_name)//"SinkingVelocity"& - &, stat=stat) - if (stat==0) then - gravity=extract_vector_field(state, "GravityDirection") - - ! this may perform a "remap" internally from CoordinateMesh to VelocityMesh - call addto(U_nl, gravity, scale=Sink) - ! Gravitational sinking only makes sense if you include advection - ! terms. - include_advection=.true. - end if - - ! Retrieve scalar options from the options dictionary. - if (.not.semi_discrete) then - call get_option(trim(T%option_path)//& - &"/prognostic/temporal_discretisation/theta", theta) - call get_option("/timestepping/timestep", dt) - else - ! If we are assembling the semi-discrete forms of the equations then - ! we don't need to scale by theta and dt in this routine. - theta=1.0 - dt=1.0 - end if - - include_mass = .not. have_option(trim(T%option_path)//& - "/prognostic/spatial_discretisation/discontinuous_galerkin/mass_terms/exclude_mass_terms") - - move_mesh = (have_option("/mesh_adaptivity/mesh_movement").and.include_mass) - if(move_mesh) then - ewrite(2,*) 'Moving mesh' - X_old => extract_vector_field(state, "OldCoordinate") - X_new => extract_vector_field(state, "IteratedCoordinate") - - U_mesh=> extract_vector_field(state, "GridVelocity") - assert(U_mesh%dim == mesh_dim(t)) - assert(ele_count(U_mesh) == ele_count(t)) - else - ewrite(2,*) 'Not moving mesh' - end if - - ! Switch on upwind stabilisation if requested. - if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"& - &"/discontinuous_galerkin/upwind_stabilisation")) then - stabilisation_scheme=UPWIND - if(move_mesh) then - FLExit("Haven't thought about how mesh movement works with stabilisation yet.") - end if - else - stabilisation_scheme=NONE - end if - - q_mesh=diffusivity%mesh - - assert(has_faces(X%mesh)) - assert(has_faces(T%mesh)) - - ! Enquire about boundary conditions we're interested in - ! Returns an integer array bc_type over the surface elements - ! that indicates the bc type (in the order we specified, i.e. - ! BCTYPE_WEAKDIRICHLET=1) - allocate( bc_type(1:surface_element_count(T)) ) - call get_entire_boundary_condition(T, & - & (/"weakdirichlet", & - & "dirichlet ", & - & "neumann "/), & - & bc_value, bc_type) - - call zero(big_m) - call zero(RHS) - if (present(mass)) call zero(mass) - if (present(diffusion_m)) call zero(diffusion_m) - if (present(diffusion_RHS)) call zero(diffusion_RHS) - if (have_buoyancy_adjustment_by_vertical_diffusion) then - ewrite(3,*) "Buoyancy adjustment by vertical mixing: enabled" - if (have_option(trim(T%option_path)//"/prognostic/buoyancy_adjustment"//& - &"/by_vertical_diffusion/project_buoyancy_to_continuous_space")) then - buoyancy_from_state = extract_scalar_field(state, "VelocityBuoyancyDensity", stat) - if (stat/=0) FLAbort('Error extracting buoyancy field.') - - mesh_cg=>extract_mesh(state, "CoordinateMesh") - call allocate(buoyancy, mesh_cg, "BuoyancyProjectedToContinuousSpace") - call zero(buoyancy) - ! Grab an extra reference to cause the deallocate below to be safe. - ! Check this is OK - call lumped_mass_galerkin_projection_scalar(state, buoyancy, buoyancy_from_state) - ewrite(3,*) "Buoyancy adjustment by vertical mixing: projecting to continuous space" + call zero(Absorption) else - ewrite(3,*) "Buoyancy adjustment by vertical mixing: no projection" - buoyancy = extract_scalar_field(state, "VelocityBuoyancyDensity", stat) - if (stat/=0) FLAbort('Error extracting buoyancy field.') - call incref(buoyancy) + ! Grab an extra reference to cause the deallocate below to be safe. + call incref(Absorption) end if - gravity=extract_vector_field(state, "GravityDirection",stat) - if (stat/=0) FLAbort('Error extracting gravity field.') - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + Sink=extract_scalar_field(state, trim(field_name)//"SinkingVelocity"& + &, stat=stat) + if (stat==0) then + gravity=extract_vector_field(state, "GravityDirection") - if (have_option(trim(T%option_path)//& - &"/prognostic/buoyancy_adjustment/by_vertical_diffusion/amplitude")) then - call get_option(trim(T%option_path)//& - &"/prognostic/buoyancy_adjustment/by_vertical_diffusion/amplitude", & - &mixing_diffusion_amplitude) + ! this may perform a "remap" internally from CoordinateMesh to VelocityMesh + call addto(U_nl, gravity, scale=Sink) + ! Gravitational sinking only makes sense if you include advection + ! terms. + include_advection=.true. + end if + + ! Retrieve scalar options from the options dictionary. + if (.not.semi_discrete) then + call get_option(trim(T%option_path)//& + &"/prognostic/temporal_discretisation/theta", theta) + call get_option("/timestepping/timestep", dt) else - mixing_diffusion_amplitude = 1.0 + ! If we are assembling the semi-discrete forms of the equations then + ! we don't need to scale by theta and dt in this routine. + theta=1.0 + dt=1.0 end if - ! Set direction of mixing diffusion, default is in the y- and z-direction for 2- and 3-d spaces respectively - ! TODO: Align this direction with gravity local to an element - ! Check if the diagnostic associated with the buoyancy adjustment by vertical mixing scheme is required - buoyancy_adjustment_diffusivity = extract_scalar_field(state, "BuoyancyAdjustmentDiffusivity", stat) - if (stat==0) then - have_buoyancy_adjustment_diffusivity = .true. - ewrite(3,*) "Buoynacy adjustment by vertical mixing: Updating BuoyancyAdjustmentDiffusivity field." + include_mass = .not. have_option(trim(T%option_path)//& + "/prognostic/spatial_discretisation/discontinuous_galerkin/mass_terms/exclude_mass_terms") + + move_mesh = (have_option("/mesh_adaptivity/mesh_movement").and.include_mass) + if(move_mesh) then + ewrite(2,*) 'Moving mesh' + X_old => extract_vector_field(state, "OldCoordinate") + X_new => extract_vector_field(state, "IteratedCoordinate") + + U_mesh=> extract_vector_field(state, "GridVelocity") + assert(U_mesh%dim == mesh_dim(t)) + assert(ele_count(U_mesh) == ele_count(t)) + else + ewrite(2,*) 'Not moving mesh' + end if + + ! Switch on upwind stabilisation if requested. + if (have_option(trim(T%option_path)//"/prognostic/spatial_discretisation"& + &"/discontinuous_galerkin/upwind_stabilisation")) then + stabilisation_scheme=UPWIND + if(move_mesh) then + FLExit("Haven't thought about how mesh movement works with stabilisation yet.") + end if else - have_buoyancy_adjustment_diffusivity = .false. + stabilisation_scheme=NONE end if - end if + q_mesh=diffusivity%mesh + + assert(has_faces(X%mesh)) + assert(has_faces(T%mesh)) + + ! Enquire about boundary conditions we're interested in + ! Returns an integer array bc_type over the surface elements + ! that indicates the bc type (in the order we specified, i.e. + ! BCTYPE_WEAKDIRICHLET=1) + allocate( bc_type(1:surface_element_count(T)) ) + call get_entire_boundary_condition(T, & + & (/"weakdirichlet", & + & "dirichlet ", & + & "neumann "/), & + & bc_value, bc_type) + + call zero(big_m) + call zero(RHS) + if (present(mass)) call zero(mass) + if (present(diffusion_m)) call zero(diffusion_m) + if (present(diffusion_RHS)) call zero(diffusion_RHS) + if (have_buoyancy_adjustment_by_vertical_diffusion) then + ewrite(3,*) "Buoyancy adjustment by vertical mixing: enabled" + if (have_option(trim(T%option_path)//"/prognostic/buoyancy_adjustment"//& + &"/by_vertical_diffusion/project_buoyancy_to_continuous_space")) then + buoyancy_from_state = extract_scalar_field(state, "VelocityBuoyancyDensity", stat) + if (stat/=0) FLAbort('Error extracting buoyancy field.') + + mesh_cg=>extract_mesh(state, "CoordinateMesh") + call allocate(buoyancy, mesh_cg, "BuoyancyProjectedToContinuousSpace") + call zero(buoyancy) + ! Grab an extra reference to cause the deallocate below to be safe. + ! Check this is OK + call lumped_mass_galerkin_projection_scalar(state, buoyancy, buoyancy_from_state) + ewrite(3,*) "Buoyancy adjustment by vertical mixing: projecting to continuous space" + else + ewrite(3,*) "Buoyancy adjustment by vertical mixing: no projection" + buoyancy = extract_scalar_field(state, "VelocityBuoyancyDensity", stat) + if (stat/=0) FLAbort('Error extracting buoyancy field.') + call incref(buoyancy) + end if + + gravity=extract_vector_field(state, "GravityDirection",stat) + if (stat/=0) FLAbort('Error extracting gravity field.') + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + + if (have_option(trim(T%option_path)//& + &"/prognostic/buoyancy_adjustment/by_vertical_diffusion/amplitude")) then + call get_option(trim(T%option_path)//& + &"/prognostic/buoyancy_adjustment/by_vertical_diffusion/amplitude", & + &mixing_diffusion_amplitude) + else + mixing_diffusion_amplitude = 1.0 + end if + ! Set direction of mixing diffusion, default is in the y- and z-direction for 2- and 3-d spaces respectively + ! TODO: Align this direction with gravity local to an element + + ! Check if the diagnostic associated with the buoyancy adjustment by vertical mixing scheme is required + buoyancy_adjustment_diffusivity = extract_scalar_field(state, "BuoyancyAdjustmentDiffusivity", stat) + if (stat==0) then + have_buoyancy_adjustment_diffusivity = .true. + ewrite(3,*) "Buoynacy adjustment by vertical mixing: Updating BuoyancyAdjustmentDiffusivity field." + else + have_buoyancy_adjustment_diffusivity = .false. + end if + + end if - if (include_diffusion) then - call get_mesh_colouring(state, T%mesh, COLOURING_DG2, colours) + if (include_diffusion) then + call get_mesh_colouring(state, T%mesh, COLOURING_DG2, colours) #ifdef _OPENMP - if(diffusion_scheme == MASSLUMPED_RT0) then - call omp_set_num_threads(1) - ewrite(1,*) "WARNING: hybrid assembly can't support The MASSLUMPED_RT0 scheme yet, & - set threads back to 1" - endif + if(diffusion_scheme == MASSLUMPED_RT0) then + call omp_set_num_threads(1) + ewrite(1,*) "WARNING: hybrid assembly can't support The MASSLUMPED_RT0 scheme yet, & + set threads back to 1" + endif #endif - else - call get_mesh_colouring(state, T%mesh, COLOURING_DG0, colours) - end if + else + call get_mesh_colouring(state, T%mesh, COLOURING_DG0, colours) + end if #ifdef _OPENMP - cache_valid = prepopulate_transform_cache(X) + cache_valid = prepopulate_transform_cache(X) #endif - call profiler_tic(t, "advection_diffusion_dg_loop") + call profiler_tic(t, "advection_diffusion_dg_loop") - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(clr, nnid, ele, len) + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(clr, nnid, ele, len) - colour_loop: do clr = 1, size(colours) - len = key_count(colours(clr)) + colour_loop: do clr = 1, size(colours) + len = key_count(colours(clr)) - !$OMP DO SCHEDULE(STATIC) - element_loop: do nnid = 1, len - ele = fetch(colours(clr), nnid) - call construct_adv_diff_element_dg(ele, big_m, rhs, big_m_diff,& + !$OMP DO SCHEDULE(STATIC) + element_loop: do nnid = 1, len + ele = fetch(colours(clr), nnid) + call construct_adv_diff_element_dg(ele, big_m, rhs, big_m_diff,& & rhs_diff, X, X_old, X_new, T, U_nl, U_mesh, Source, & & Absorption, Diffusivity, bc_value, bc_type, q_mesh, mass, & & buoyancy, gravity, gravity_magnitude, mixing_diffusion_amplitude, & & buoyancy_adjustment_diffusivity, & & add_src_directly_to_rhs) - end do element_loop - !$OMP END DO - - end do colour_loop - !$OMP END PARALLEL - - call profiler_toc(t, "advection_diffusion_dg_loop") - ! Add the source directly to the rhs if required - ! which must be included before dirichlet BC's. - if (add_src_directly_to_rhs) call addto(rhs, Source) - - ! Drop any extra field references. - if (have_buoyancy_adjustment_by_vertical_diffusion) call deallocate(buoyancy) - call deallocate(Diffusivity) - call deallocate(Source) - call deallocate(Absorption) - call deallocate(U_nl) - call deallocate(U_nl_backup) - call deallocate(bc_value) - - end subroutine construct_advection_diffusion_dg - - subroutine construct_les_dg(state, T, X, background_diffusivity, LESDiffusivity) - - ! Calculate updates to the field diffusivity due to the LES terms. - - type(state_type), intent(inout) :: state - type(scalar_field), intent(in) :: T - type(vector_field), intent(in) :: X - type(tensor_field), intent(in) :: background_diffusivity - type(tensor_field), intent(out) :: LESDiffusivity - - !! Turbulent diffusion - LES (sp911) - type(scalar_field), pointer :: scalar_eddy_visc - type(scalar_field) :: eddy_visc_component - type(vector_field) :: eddy_visc - real :: prandtl - integer :: i - !! Ri dependent LES (sp911) - real :: Ri_c, N_2, U_2, Ri, f_Ri - type(scalar_field), pointer :: rho - type(vector_field) :: grad_rho - type(vector_field), pointer :: gravity - type(tensor_field) :: grad_u - real, dimension(:), allocatable :: gravity_val, grad_rho_val, dU_dz - ! non-linear velocity (U_nl) is zero when advection is disabled - ! I want this to be the actual non-linear velocity so I obtain it myself - type(vector_field), pointer :: u_nl_ri - real :: gravity_magnitude - real, dimension(:,:), allocatable :: grad_u_val - - integer :: stat - - call allocate(LESDiffusivity, T%mesh, trim(background_diffusivity%name)) - call set(LESDiffusivity, background_diffusivity) - - scalar_eddy_visc => extract_scalar_field(state, "DGLESScalarEddyViscosity", stat=stat) - call get_option(trim(T%option_path)//"/prognostic"//& - &"/subgridscale_parameterisation::LES/PrandtlNumber", prandtl, default=1.0) - - ! possibly anisotropic eddy viscosity if using Ri dependency - call allocate(eddy_visc, mesh_dim(T), scalar_eddy_visc%mesh, & - & "EddyViscosity") - do i = 1, mesh_dim(T) - call set(eddy_visc, i, scalar_eddy_visc) - end do - - ! apply Richardson dependence - if (have_option(trim(T%option_path)//"/prognostic"//& - &"/subgridscale_parameterisation::LES/Ri_c")) then - - ewrite(2,*) 'Calculating Ri dependent eddy viscosity' - - ! obtain required values - call get_option(trim(T%option_path)//"/prognostic"//& - &"/subgridscale_parameterisation::LES/Ri_c", Ri_c) - - rho => extract_scalar_field(state, "Density", stat=stat) - if (stat /= 0) then - FLExit("You must have a density field to have an Ri dependent les model.") - end if - - gravity=>extract_vector_field(state, "GravityDirection",stat) - if (stat/=0) FLAbort('You must have gravity to have an Ri dependent les model.') - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - - ! obtain gradients - call allocate(grad_rho, mesh_dim(T), T%mesh, "grad_rho") - call grad(rho, X, grad_rho) - u_nl_ri => extract_vector_field(state, "NonlinearVelocity", stat) - if (stat/=0) then - FLExit("No velocity field? A velocity field is required for Ri dependent LES!") - end if - call allocate(grad_u, u_nl_ri%mesh, "grad_u") - call grad(u_nl_ri, X, grad_u) - - allocate(gravity_val(mesh_dim(T))) - allocate(grad_rho_val(mesh_dim(T))) - allocate(dU_dz(mesh_dim(T))) - allocate(grad_u_val(mesh_dim(T), mesh_dim(T))) - - do i=1,node_count(eddy_visc) - - gravity_val = node_val(gravity, i) - grad_rho_val = node_val(grad_rho, i) - grad_u_val = node_val(grad_u, i) - - ! assuming boussinesq rho_0 = 1 obtain N_2 - N_2 = gravity_magnitude*dot_product(grad_rho_val, gravity_val) - - ! obtain U_2 = du/dz**2 + dv/dz**2 - dU_dz = matmul(transpose(grad_u_val), gravity_val) - dU_dz = dU_dz - dot_product(dU_dz, gravity_val) - U_2 = norm2(dU_dz)**2.0 - - ! calculate Ri - avoid floating point errors - if ((U_2 > N_2*1e-10) .and. U_2 > tiny(0.0)*1e10) then - Ri = N_2/U_2 - else - Ri = Ri_c*1.1 - end if - ! calculate f(Ri) - if (Ri >= 0 .and. Ri <= Ri_c) then - f_Ri = (1.0 - Ri/Ri_c)**0.5 - else if (Ri > Ri_c) then - f_Ri = 0.0 - else - f_Ri = 1.0 - end if - - ! calculate modified eddy viscosity - call addto(eddy_visc, i, (1-f_Ri)*gravity_val*node_val(scalar_eddy_visc, i)) - - end do - - call deallocate(grad_rho) - call deallocate(grad_u) - - deallocate(gravity_val, grad_u_val, grad_rho_val, dU_dz) - end if - - do i = 1, mesh_dim(X) - eddy_visc_component = extract_scalar_field(eddy_visc, i) - call addto(LESDiffusivity, i, i, eddy_visc_component, scale=1./prandtl) - end do - - call deallocate(eddy_visc) - - end subroutine construct_les_dg - - subroutine lumped_mass_galerkin_projection_scalar(state, field, projected_field) - type(state_type), intent(in) :: state - type(vector_field), pointer :: positions - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(inout) :: projected_field - type(scalar_field) :: rhs - type(scalar_field) :: mass_lumped, inverse_mass_lumped - - integer :: ele - - positions => extract_vector_field(state, "Coordinate") - - ! Assuming they're on the same quadrature - assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) - - call allocate(mass_lumped, field%mesh, name="GalerkinProjectionMassLumped") - call zero(mass_lumped) - - call allocate(rhs, field%mesh, name="GalerkinProjectionRHS") - call zero(rhs) - - do ele=1,ele_count(field) - call assemble_galerkin_projection(field, projected_field, positions, & - & rhs, ele) - end do - - call allocate(inverse_mass_lumped, field%mesh, & - name="GalerkinProjectionInverseMassLumped") - call invert(mass_lumped, inverse_mass_lumped) - call set(field, rhs) - call scale(field, inverse_mass_lumped) - call deallocate(mass_lumped) - call deallocate(inverse_mass_lumped) - call deallocate(rhs) - - contains + end do element_loop + !$OMP END DO + + end do colour_loop + !$OMP END PARALLEL + + call profiler_toc(t, "advection_diffusion_dg_loop") + ! Add the source directly to the rhs if required + ! which must be included before dirichlet BC's. + if (add_src_directly_to_rhs) call addto(rhs, Source) + + ! Drop any extra field references. + if (have_buoyancy_adjustment_by_vertical_diffusion) call deallocate(buoyancy) + call deallocate(Diffusivity) + call deallocate(Source) + call deallocate(Absorption) + call deallocate(U_nl) + call deallocate(U_nl_backup) + call deallocate(bc_value) + + end subroutine construct_advection_diffusion_dg + + subroutine construct_les_dg(state, T, X, background_diffusivity, LESDiffusivity) + + ! Calculate updates to the field diffusivity due to the LES terms. + + type(state_type), intent(inout) :: state + type(scalar_field), intent(in) :: T + type(vector_field), intent(in) :: X + type(tensor_field), intent(in) :: background_diffusivity + type(tensor_field), intent(out) :: LESDiffusivity + + !! Turbulent diffusion - LES (sp911) + type(scalar_field), pointer :: scalar_eddy_visc + type(scalar_field) :: eddy_visc_component + type(vector_field) :: eddy_visc + real :: prandtl + integer :: i + !! Ri dependent LES (sp911) + real :: Ri_c, N_2, U_2, Ri, f_Ri + type(scalar_field), pointer :: rho + type(vector_field) :: grad_rho + type(vector_field), pointer :: gravity + type(tensor_field) :: grad_u + real, dimension(:), allocatable :: gravity_val, grad_rho_val, dU_dz + ! non-linear velocity (U_nl) is zero when advection is disabled + ! I want this to be the actual non-linear velocity so I obtain it myself + type(vector_field), pointer :: u_nl_ri + real :: gravity_magnitude + real, dimension(:,:), allocatable :: grad_u_val + + integer :: stat + + call allocate(LESDiffusivity, T%mesh, trim(background_diffusivity%name)) + call set(LESDiffusivity, background_diffusivity) + + scalar_eddy_visc => extract_scalar_field(state, "DGLESScalarEddyViscosity", stat=stat) + call get_option(trim(T%option_path)//"/prognostic"//& + &"/subgridscale_parameterisation::LES/PrandtlNumber", prandtl, default=1.0) + + ! possibly anisotropic eddy viscosity if using Ri dependency + call allocate(eddy_visc, mesh_dim(T), scalar_eddy_visc%mesh, & + & "EddyViscosity") + do i = 1, mesh_dim(T) + call set(eddy_visc, i, scalar_eddy_visc) + end do + + ! apply Richardson dependence + if (have_option(trim(T%option_path)//"/prognostic"//& + &"/subgridscale_parameterisation::LES/Ri_c")) then + + ewrite(2,*) 'Calculating Ri dependent eddy viscosity' + + ! obtain required values + call get_option(trim(T%option_path)//"/prognostic"//& + &"/subgridscale_parameterisation::LES/Ri_c", Ri_c) + + rho => extract_scalar_field(state, "Density", stat=stat) + if (stat /= 0) then + FLExit("You must have a density field to have an Ri dependent les model.") + end if + + gravity=>extract_vector_field(state, "GravityDirection",stat) + if (stat/=0) FLAbort('You must have gravity to have an Ri dependent les model.') + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + + ! obtain gradients + call allocate(grad_rho, mesh_dim(T), T%mesh, "grad_rho") + call grad(rho, X, grad_rho) + u_nl_ri => extract_vector_field(state, "NonlinearVelocity", stat) + if (stat/=0) then + FLExit("No velocity field? A velocity field is required for Ri dependent LES!") + end if + call allocate(grad_u, u_nl_ri%mesh, "grad_u") + call grad(u_nl_ri, X, grad_u) + + allocate(gravity_val(mesh_dim(T))) + allocate(grad_rho_val(mesh_dim(T))) + allocate(dU_dz(mesh_dim(T))) + allocate(grad_u_val(mesh_dim(T), mesh_dim(T))) + + do i=1,node_count(eddy_visc) + + gravity_val = node_val(gravity, i) + grad_rho_val = node_val(grad_rho, i) + grad_u_val = node_val(grad_u, i) + + ! assuming boussinesq rho_0 = 1 obtain N_2 + N_2 = gravity_magnitude*dot_product(grad_rho_val, gravity_val) + + ! obtain U_2 = du/dz**2 + dv/dz**2 + dU_dz = matmul(transpose(grad_u_val), gravity_val) + dU_dz = dU_dz - dot_product(dU_dz, gravity_val) + U_2 = norm2(dU_dz)**2.0 + + ! calculate Ri - avoid floating point errors + if ((U_2 > N_2*1e-10) .and. U_2 > tiny(0.0)*1e10) then + Ri = N_2/U_2 + else + Ri = Ri_c*1.1 + end if + ! calculate f(Ri) + if (Ri >= 0 .and. Ri <= Ri_c) then + f_Ri = (1.0 - Ri/Ri_c)**0.5 + else if (Ri > Ri_c) then + f_Ri = 0.0 + else + f_Ri = 1.0 + end if + + ! calculate modified eddy viscosity + call addto(eddy_visc, i, (1-f_Ri)*gravity_val*node_val(scalar_eddy_visc, i)) + + end do + + call deallocate(grad_rho) + call deallocate(grad_u) + + deallocate(gravity_val, grad_u_val, grad_rho_val, dU_dz) + end if + + do i = 1, mesh_dim(X) + eddy_visc_component = extract_scalar_field(eddy_visc, i) + call addto(LESDiffusivity, i, i, eddy_visc_component, scale=1./prandtl) + end do + + call deallocate(eddy_visc) + + end subroutine construct_les_dg + + subroutine lumped_mass_galerkin_projection_scalar(state, field, projected_field) + type(state_type), intent(in) :: state + type(vector_field), pointer :: positions + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(inout) :: projected_field + type(scalar_field) :: rhs + type(scalar_field) :: mass_lumped, inverse_mass_lumped + + integer :: ele + + positions => extract_vector_field(state, "Coordinate") + + ! Assuming they're on the same quadrature + assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) + + call allocate(mass_lumped, field%mesh, name="GalerkinProjectionMassLumped") + call zero(mass_lumped) + + call allocate(rhs, field%mesh, name="GalerkinProjectionRHS") + call zero(rhs) + + do ele=1,ele_count(field) + call assemble_galerkin_projection(field, projected_field, positions, & + & rhs, ele) + end do + + call allocate(inverse_mass_lumped, field%mesh, & + name="GalerkinProjectionInverseMassLumped") + call invert(mass_lumped, inverse_mass_lumped) + call set(field, rhs) + call scale(field, inverse_mass_lumped) + call deallocate(mass_lumped) + call deallocate(inverse_mass_lumped) + call deallocate(rhs) + + contains ! projected_field <-> field rename subroutine assemble_galerkin_projection(field, projected_field, positions, rhs, ele) - type(vector_field), intent(in) :: positions - ! Changed to in not inout - type(scalar_field), intent(in) :: field - type(scalar_field), intent(in) :: projected_field - type(scalar_field), intent(inout) :: rhs - integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + ! Changed to in not inout + type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: projected_field + type(scalar_field), intent(inout) :: rhs + integer, intent(in) :: ele - type(element_type), pointer :: field_shape, proj_field_shape + type(element_type), pointer :: field_shape, proj_field_shape - real, dimension(ele_loc(field, ele), ele_loc(field, ele)) :: little_mass - real, dimension(ele_ngi(field, ele)) :: detwei + real, dimension(ele_loc(field, ele), ele_loc(field, ele)) :: little_mass + real, dimension(ele_ngi(field, ele)) :: detwei - real, dimension(ele_loc(field, ele)) :: little_rhs - real, dimension(ele_loc(field, ele), ele_loc(projected_field, ele)) :: little_mba - real, dimension(ele_loc(field, ele), ele_loc(projected_field, ele)) :: little_mba_int - real, dimension(ele_loc(projected_field, ele)) :: proj_field_val + real, dimension(ele_loc(field, ele)) :: little_rhs + real, dimension(ele_loc(field, ele), ele_loc(projected_field, ele)) :: little_mba + real, dimension(ele_loc(field, ele), ele_loc(projected_field, ele)) :: little_mba_int + real, dimension(ele_loc(projected_field, ele)) :: proj_field_val - integer :: i, j, k + integer :: i, j, k - field_shape => ele_shape(field, ele) - proj_field_shape => ele_shape(projected_field, ele) + field_shape => ele_shape(field, ele) + proj_field_shape => ele_shape(projected_field, ele) - call transform_to_physical(positions, ele, detwei=detwei) + call transform_to_physical(positions, ele, detwei=detwei) - little_mass = shape_shape(field_shape, field_shape, detwei) + little_mass = shape_shape(field_shape, field_shape, detwei) - ! And compute the product of the basis functions - little_mba = 0 - do i=1,ele_ngi(field, ele) - forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) - little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) - end forall - little_mba = little_mba + little_mba_int * detwei(i) - end do + ! And compute the product of the basis functions + little_mba = 0 + do i=1,ele_ngi(field, ele) + forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) + little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) + end forall + little_mba = little_mba + little_mba_int * detwei(i) + end do - proj_field_val = ele_val(projected_field, ele) - little_rhs(:) = matmul(little_mba, proj_field_val(:)) - ! Replace 2 lines above with: - ! little_rhs = matmul(little_mba, ele_val(projected_field, ele)) + proj_field_val = ele_val(projected_field, ele) + little_rhs(:) = matmul(little_mba, proj_field_val(:)) + ! Replace 2 lines above with: + ! little_rhs = matmul(little_mba, ele_val(projected_field, ele)) - call addto(mass_lumped, ele_nodes(field, ele), & - sum(little_mass,2)) - call addto(rhs, ele_nodes(field, ele), little_rhs) + call addto(mass_lumped, ele_nodes(field, ele), & + sum(little_mass,2)) + call addto(rhs, ele_nodes(field, ele), little_rhs) end subroutine assemble_galerkin_projection end subroutine lumped_mass_galerkin_projection_scalar subroutine construct_adv_diff_element_dg(ele, big_m, rhs, big_m_diff,& - & rhs_diff, & - & X, X_old, X_new, T, U_nl, U_mesh, Source, Absorption, Diffusivity,& - & bc_value, bc_type, & - & q_mesh, mass, buoyancy, gravity, gravity_magnitude, mixing_diffusion_amplitude, & - & buoyancy_adjustment_diffusivity, & - & add_src_directly_to_rhs) - !!< Construct the advection_diffusion equation for discontinuous elements in - !!< acceleration form. - implicit none - !! Index of current element - integer :: ele - !! Main advection and diffusion matrices. - type(csr_matrix), intent(inout) :: big_m, big_m_diff - !! Right hand side vectors. - type(scalar_field), intent(inout) :: rhs, rhs_diff - !! Field over the entire surface mesh containing bc values: - type(scalar_field), intent(in):: bc_value - !! Integer array of all surface elements indicating bc type - !! (see above call to get_entire_boundary_condition): - integer, dimension(:), intent(in):: bc_type - !! Auxiliary variable mesh - type(mesh_type), intent(in) :: q_mesh - !! Optional separate mass matrix. - type(csr_matrix), intent(inout), optional :: mass - - !! Position and velocity. - type(vector_field), intent(in) :: X, U_nl - type(vector_field), pointer :: X_old, X_new, U_mesh - - type(scalar_field), intent(in) :: T, Source, Absorption - !! Diffusivity - type(tensor_field), intent(in) :: Diffusivity - - !! Diffusivity to add due to the buoyancy adjustment by vertical mixing scheme - type(scalar_field), intent(inout) :: buoyancy_adjustment_diffusivity - - !! If adding Source directly to rhs then - !! do nothing with it here - logical, intent(in) :: add_src_directly_to_rhs - - !! Flag for a periodic boundary - logical :: Periodic_neigh - - !! Buoyancy and gravity direction - type(scalar_field), intent(in) :: buoyancy - type(vector_field), intent(in) :: gravity - real, intent(in) :: gravity_magnitude - - ! Bilinear forms. - real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: & + & rhs_diff, & + & X, X_old, X_new, T, U_nl, U_mesh, Source, Absorption, Diffusivity,& + & bc_value, bc_type, & + & q_mesh, mass, buoyancy, gravity, gravity_magnitude, mixing_diffusion_amplitude, & + & buoyancy_adjustment_diffusivity, & + & add_src_directly_to_rhs) + !!< Construct the advection_diffusion equation for discontinuous elements in + !!< acceleration form. + implicit none + !! Index of current element + integer :: ele + !! Main advection and diffusion matrices. + type(csr_matrix), intent(inout) :: big_m, big_m_diff + !! Right hand side vectors. + type(scalar_field), intent(inout) :: rhs, rhs_diff + !! Field over the entire surface mesh containing bc values: + type(scalar_field), intent(in):: bc_value + !! Integer array of all surface elements indicating bc type + !! (see above call to get_entire_boundary_condition): + integer, dimension(:), intent(in):: bc_type + !! Auxiliary variable mesh + type(mesh_type), intent(in) :: q_mesh + !! Optional separate mass matrix. + type(csr_matrix), intent(inout), optional :: mass + + !! Position and velocity. + type(vector_field), intent(in) :: X, U_nl + type(vector_field), pointer :: X_old, X_new, U_mesh + + type(scalar_field), intent(in) :: T, Source, Absorption + !! Diffusivity + type(tensor_field), intent(in) :: Diffusivity + + !! Diffusivity to add due to the buoyancy adjustment by vertical mixing scheme + type(scalar_field), intent(inout) :: buoyancy_adjustment_diffusivity + + !! If adding Source directly to rhs then + !! do nothing with it here + logical, intent(in) :: add_src_directly_to_rhs + + !! Flag for a periodic boundary + logical :: Periodic_neigh + + !! Buoyancy and gravity direction + type(scalar_field), intent(in) :: buoyancy + type(vector_field), intent(in) :: gravity + real, intent(in) :: gravity_magnitude + + ! Bilinear forms. + real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: & mass_mat - real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: & + real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: & inverse_mass_mat - real, dimension(mesh_dim(T), ele_loc(T,ele), & + real, dimension(mesh_dim(T), ele_loc(T,ele), & ele_loc(T,ele)) :: ele2grad_mat - real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: & + real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: & Advection_mat - real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: Abs_mat - real, dimension(ele_loc(q_mesh,ele), ele_loc(q_mesh,ele)) :: Q_inv - real, dimension(mesh_dim(T), ele_loc(q_mesh,ele), & + real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: Abs_mat + real, dimension(ele_loc(q_mesh,ele), ele_loc(q_mesh,ele)) :: Q_inv + real, dimension(mesh_dim(T), ele_loc(q_mesh,ele), & ele_and_faces_loc(T,ele)) :: Grad_T_mat, Div_T_mat - real, dimension(ele_face_count(T,ele), mesh_dim(T), ele_loc(q_mesh,ele), & + real, dimension(ele_face_count(T,ele), mesh_dim(T), ele_loc(q_mesh,ele), & ele_and_faces_loc(T,ele)) :: Grad_T_face_mat - real, dimension(ele_and_faces_loc(T,ele),ele_and_faces_loc(T,ele)) ::& - & Diffusivity_mat - real, dimension(Diffusivity%dim(1), Diffusivity%dim(2), & - & ele_loc(Diffusivity,ele)) :: Diffusivity_ele - - - ! Local assembly matrices. - real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: l_T_mat - real, dimension(ele_loc(T,ele)) :: l_T_rhs - - ! Local node number map for 2nd order element. - integer, dimension(ele_and_faces_loc(T,ele)) :: local_glno - - ! Local variables. - - ! Neighbour element, face and neighbour face. - integer :: ele_2, face, face_2, ele_2_X - ! Count variable for loops over dimension. - integer :: dim1, dim2 - ! Loops over faces. - integer :: ni - ! Array bounds for faces of the 2nd order element. - integer :: start, finish - - ! Variable transform times quadrature weights. - real, dimension(ele_ngi(T,ele)) :: detwei, detwei_old, detwei_new - ! Transform from local to physical coordinates. - real, dimension(U_nl%dim, U_nl%dim, ele_ngi(T,ele)) :: J_mat - ! Transformed gradient function for tracer. - real, dimension(ele_loc(T, ele), ele_ngi(T, ele), mesh_dim(T)) :: dt_t - ! Transformed gradient function for velocity. - real, dimension(ele_loc(U_nl, ele), ele_ngi(U_nl, ele), mesh_dim(T)) ::& - & du_t - ! Transformed gradient function for grid velocity. - real, dimension(ele_loc(X, ele), ele_ngi(U_nl, ele), mesh_dim(T)) ::& - & dug_t - ! Transformed gradient function for auxiliary variable. - real, dimension(ele_loc(q_mesh,ele), ele_ngi(q_mesh,ele), mesh_dim(T)) :: dq_t - ! Different velocities at quad points. - real, dimension(U_nl%dim, ele_ngi(U_nl, ele)) :: u_nl_q - real, dimension(ele_ngi(U_nl, ele)) :: u_nl_div_q - - ! Node and shape pointers. - integer, dimension(:), pointer :: t_ele - type(element_type), pointer :: t_shape, u_shape, q_shape - ! Neighbours of this element. - integer, dimension(:), pointer :: neigh, x_neigh - ! Whether the tracer field is continuous. - logical :: dg - - logical :: boundary_element - - !Switch to select if we are assembling the primal or dual form - logical :: primal - !Switch to choose side to take fluxes from in CDG element - logical :: CDG_switch_in - - ! Matrix for assembling primal fluxes - ! Note that this assumes same order polys in each element - ! Code will need reorganising for p-refinement - real, dimension(2,face_loc(T,1),ele_loc(T,ele)) :: primal_fluxes_mat - - ! \Int_{ele} N_i kappa N_j dV, used for CDG fluxes - real, dimension(mesh_dim(T),mesh_dim(T), & - & ele_loc(T,ele),ele_loc(T,ele)) :: kappa_mat - - ! \Int_{s_ele} N_iN_j n ds, used for CDG fluxes - real, dimension(mesh_dim(T),face_loc(T,ele),face_loc(T,ele)) :: & - & normal_mat - ! \Int_{s_ele} N_iN_j kappa.n ds, used for CDG fluxes - ! Note that this assumes same order polys in each element - ! Code will need reorganising for p-refinement - real, dimension(mesh_dim(T),face_loc(T,1),face_loc(T,1)) :: & - & kappa_normal_mat - - ! Matrix for assembling penalty fluxes - ! Note that this assumes same order polys in each element - ! Code will need reorganising for p-refinement - real, dimension(2,face_loc(T,1),face_loc(T,1)) :: penalty_fluxes_mat - - integer :: i, j - ! Variables for buoyancy adjustment by vertical diffusion - real, dimension(ele_loc(T,ele), ele_ngi(T,ele), mesh_dim(T)) :: dt_rho - real, dimension(mesh_dim(T), ele_ngi(T,ele)) :: grad_rho - real, dimension(mesh_dim(T),ele_ngi(T,ele)) :: grav_at_quads - real, dimension(ele_ngi(T,ele)) :: buoyancysample - real, dimension(ele_ngi(T,ele)) :: drho_dz - real, dimension(mesh_dim(T), mesh_dim(T), T%mesh%shape%ngi) :: mixing_diffusion - real, dimension(mesh_dim(T), T%mesh%shape%ngi) :: mixing_diffusion_diag - integer, dimension(:), pointer :: enodes - real, dimension(X%dim) :: pos, gravity_at_node - real, dimension(ele_loc(X,ele)) :: rad - real :: dr - - real, intent(in) :: mixing_diffusion_amplitude - - real, dimension(X%dim, X%dim, ele_loc(T, ele)) :: mixing_diffusion_rhs, mixing_diffusion_loc - real, dimension(ele_loc(T, ele), ele_loc(T, ele)) :: t_mass - real, dimension(ele_ngi(T, ele)) :: detwei_rho - - ! element centre and neighbour centre - ! for IP parameters - - real, dimension(mesh_dim(T)) :: ele_centre, neigh_centre, & - & face_centre, face_centre_2 - - !Debugging variables - - real, dimension(ele_loc(T,ele)) :: test_vals - real, dimension(ele_ngi(T,ele)) :: test_vals_out_1, test_vals_out_2 - real :: test_val - - real, dimension(x%dim, ele_loc(x,ele)) :: x_val, x_val_2 - real, dimension(mesh_dim(T)) :: centre_vec - - if(move_mesh) then - ! the following have been assumed in the declarations above - assert(ele_loc(U_mesh, ele)==ele_loc(X, ele)) - assert(ele_ngi(U_mesh, ele)==ele_ngi(U_nl, ele)) - end if - - dg=continuity(T)<0 - primal = .not.dg - if(diffusion_scheme == CDG) primal = .true. - if(diffusion_scheme == IP) primal =.true. - - ! In parallel, we only construct the equations on elements we own, or - ! those in the L1 halo. - if (dg) then - if (.not.(element_owned(T, ele).or.element_neighbour_owned(T, ele))) then - return - end if - end if - - !---------------------------------------------------------------------- - ! Establish local node lists - !---------------------------------------------------------------------- - - T_ele=>ele_nodes(T,ele) ! Tracer node numbers - - local_glno=0 - local_glno(:size(T_ele))=T_ele ! Diffusivity node list. - - !---------------------------------------------------------------------- - ! Establish local shape functions - !---------------------------------------------------------------------- - - t_shape=>ele_shape(T, ele) - u_shape=>ele_shape(U_nl, ele) - q_shape=>ele_shape(q_mesh, ele) - - !========================== - ! Coordinates - !========================== - - x_val = ele_val(X,ele) - - ! Transform Tracer derivatives and weights into physical space. If - ! necessary, grab J_mat as well. - if (stabilisation_scheme==NONE) then - call transform_to_physical(X, ele,& - & t_shape , dshape=dt_t, detwei=detwei) - else - call transform_to_physical(X,ele,& - & t_shape , dshape=dt_t, detwei=detwei, J=J_mat) - end if - - ! Transform U_nl derivatives and weights into physical space. - call transform_to_physical(X,ele,& - & u_shape , dshape=du_t) - - if ((include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion).and..not.primal) then - ! Transform q derivatives into physical space. - call transform_to_physical(X,ele,& - & q_shape , dshape=dq_t) - end if - - if(move_mesh) then - call transform_to_physical(X_old, ele, detwei=detwei_old) - call transform_to_physical(X_new, ele, detwei=detwei_new) - if(include_advection.and..not.integrate_by_parts_once) then - ! need dug_t if we're integrating by parts twice and - ! moving the mesh - call transform_to_physical(X, ele, & + real, dimension(ele_and_faces_loc(T,ele),ele_and_faces_loc(T,ele)) ::& + & Diffusivity_mat + real, dimension(Diffusivity%dim(1), Diffusivity%dim(2), & + & ele_loc(Diffusivity,ele)) :: Diffusivity_ele + + + ! Local assembly matrices. + real, dimension(ele_loc(T,ele), ele_loc(T,ele)) :: l_T_mat + real, dimension(ele_loc(T,ele)) :: l_T_rhs + + ! Local node number map for 2nd order element. + integer, dimension(ele_and_faces_loc(T,ele)) :: local_glno + + ! Local variables. + + ! Neighbour element, face and neighbour face. + integer :: ele_2, face, face_2, ele_2_X + ! Count variable for loops over dimension. + integer :: dim1, dim2 + ! Loops over faces. + integer :: ni + ! Array bounds for faces of the 2nd order element. + integer :: start, finish + + ! Variable transform times quadrature weights. + real, dimension(ele_ngi(T,ele)) :: detwei, detwei_old, detwei_new + ! Transform from local to physical coordinates. + real, dimension(U_nl%dim, U_nl%dim, ele_ngi(T,ele)) :: J_mat + ! Transformed gradient function for tracer. + real, dimension(ele_loc(T, ele), ele_ngi(T, ele), mesh_dim(T)) :: dt_t + ! Transformed gradient function for velocity. + real, dimension(ele_loc(U_nl, ele), ele_ngi(U_nl, ele), mesh_dim(T)) ::& + & du_t + ! Transformed gradient function for grid velocity. + real, dimension(ele_loc(X, ele), ele_ngi(U_nl, ele), mesh_dim(T)) ::& + & dug_t + ! Transformed gradient function for auxiliary variable. + real, dimension(ele_loc(q_mesh,ele), ele_ngi(q_mesh,ele), mesh_dim(T)) :: dq_t + ! Different velocities at quad points. + real, dimension(U_nl%dim, ele_ngi(U_nl, ele)) :: u_nl_q + real, dimension(ele_ngi(U_nl, ele)) :: u_nl_div_q + + ! Node and shape pointers. + integer, dimension(:), pointer :: t_ele + type(element_type), pointer :: t_shape, u_shape, q_shape + ! Neighbours of this element. + integer, dimension(:), pointer :: neigh, x_neigh + ! Whether the tracer field is continuous. + logical :: dg + + logical :: boundary_element + + !Switch to select if we are assembling the primal or dual form + logical :: primal + !Switch to choose side to take fluxes from in CDG element + logical :: CDG_switch_in + + ! Matrix for assembling primal fluxes + ! Note that this assumes same order polys in each element + ! Code will need reorganising for p-refinement + real, dimension(2,face_loc(T,1),ele_loc(T,ele)) :: primal_fluxes_mat + + ! \Int_{ele} N_i kappa N_j dV, used for CDG fluxes + real, dimension(mesh_dim(T),mesh_dim(T), & + & ele_loc(T,ele),ele_loc(T,ele)) :: kappa_mat + + ! \Int_{s_ele} N_iN_j n ds, used for CDG fluxes + real, dimension(mesh_dim(T),face_loc(T,ele),face_loc(T,ele)) :: & + & normal_mat + ! \Int_{s_ele} N_iN_j kappa.n ds, used for CDG fluxes + ! Note that this assumes same order polys in each element + ! Code will need reorganising for p-refinement + real, dimension(mesh_dim(T),face_loc(T,1),face_loc(T,1)) :: & + & kappa_normal_mat + + ! Matrix for assembling penalty fluxes + ! Note that this assumes same order polys in each element + ! Code will need reorganising for p-refinement + real, dimension(2,face_loc(T,1),face_loc(T,1)) :: penalty_fluxes_mat + + integer :: i, j + ! Variables for buoyancy adjustment by vertical diffusion + real, dimension(ele_loc(T,ele), ele_ngi(T,ele), mesh_dim(T)) :: dt_rho + real, dimension(mesh_dim(T), ele_ngi(T,ele)) :: grad_rho + real, dimension(mesh_dim(T),ele_ngi(T,ele)) :: grav_at_quads + real, dimension(ele_ngi(T,ele)) :: buoyancysample + real, dimension(ele_ngi(T,ele)) :: drho_dz + real, dimension(mesh_dim(T), mesh_dim(T), T%mesh%shape%ngi) :: mixing_diffusion + real, dimension(mesh_dim(T), T%mesh%shape%ngi) :: mixing_diffusion_diag + integer, dimension(:), pointer :: enodes + real, dimension(X%dim) :: pos, gravity_at_node + real, dimension(ele_loc(X,ele)) :: rad + real :: dr + + real, intent(in) :: mixing_diffusion_amplitude + + real, dimension(X%dim, X%dim, ele_loc(T, ele)) :: mixing_diffusion_rhs, mixing_diffusion_loc + real, dimension(ele_loc(T, ele), ele_loc(T, ele)) :: t_mass + real, dimension(ele_ngi(T, ele)) :: detwei_rho + + ! element centre and neighbour centre + ! for IP parameters + + real, dimension(mesh_dim(T)) :: ele_centre, neigh_centre, & + & face_centre, face_centre_2 + + !Debugging variables + + real, dimension(ele_loc(T,ele)) :: test_vals + real, dimension(ele_ngi(T,ele)) :: test_vals_out_1, test_vals_out_2 + real :: test_val + + real, dimension(x%dim, ele_loc(x,ele)) :: x_val, x_val_2 + real, dimension(mesh_dim(T)) :: centre_vec + + if(move_mesh) then + ! the following have been assumed in the declarations above + assert(ele_loc(U_mesh, ele)==ele_loc(X, ele)) + assert(ele_ngi(U_mesh, ele)==ele_ngi(U_nl, ele)) + end if + + dg=continuity(T)<0 + primal = .not.dg + if(diffusion_scheme == CDG) primal = .true. + if(diffusion_scheme == IP) primal =.true. + + ! In parallel, we only construct the equations on elements we own, or + ! those in the L1 halo. + if (dg) then + if (.not.(element_owned(T, ele).or.element_neighbour_owned(T, ele))) then + return + end if + end if + + !---------------------------------------------------------------------- + ! Establish local node lists + !---------------------------------------------------------------------- + + T_ele=>ele_nodes(T,ele) ! Tracer node numbers + + local_glno=0 + local_glno(:size(T_ele))=T_ele ! Diffusivity node list. + + !---------------------------------------------------------------------- + ! Establish local shape functions + !---------------------------------------------------------------------- + + t_shape=>ele_shape(T, ele) + u_shape=>ele_shape(U_nl, ele) + q_shape=>ele_shape(q_mesh, ele) + + !========================== + ! Coordinates + !========================== + + x_val = ele_val(X,ele) + + ! Transform Tracer derivatives and weights into physical space. If + ! necessary, grab J_mat as well. + if (stabilisation_scheme==NONE) then + call transform_to_physical(X, ele,& + & t_shape , dshape=dt_t, detwei=detwei) + else + call transform_to_physical(X,ele,& + & t_shape , dshape=dt_t, detwei=detwei, J=J_mat) + end if + + ! Transform U_nl derivatives and weights into physical space. + call transform_to_physical(X,ele,& + & u_shape , dshape=du_t) + + if ((include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion).and..not.primal) then + ! Transform q derivatives into physical space. + call transform_to_physical(X,ele,& + & q_shape , dshape=dq_t) + end if + + if(move_mesh) then + call transform_to_physical(X_old, ele, detwei=detwei_old) + call transform_to_physical(X_new, ele, detwei=detwei_new) + if(include_advection.and..not.integrate_by_parts_once) then + ! need dug_t if we're integrating by parts twice and + ! moving the mesh + call transform_to_physical(X, ele, & & ele_shape(U_mesh, ele), dshape=dug_t) + end if end if - end if - - mixing_diffusion = 0.0 - mixing_diffusion_loc = 0.0 - ! Vertical mixing by diffusion - ! TODO: Add option to generate optimal coefficient - ! k = 1/2 {\Delta t} g ( {\Delta r} )^2 max (d\rho / dr, 0 ) - ! k = 1/2 dt g dr^2 max(drho/dr, 0 ) - if (have_buoyancy_adjustment_by_vertical_diffusion) then - mixing_diffusion_diag = 0.0 - assert(ele_ngi(T, ele) == ele_ngi(buoyancy, ele)) - buoyancysample = ele_val_at_quad(buoyancy, ele) - call transform_to_physical(X, ele, ele_shape(buoyancy,ele), dshape=dt_rho, detwei=detwei_rho) - - grad_rho = ele_grad_at_quad(buoyancy, ele, dt_rho) - - ! Calculate the gradient in the direction of gravity - ! TODO: Build on_sphere into ele_val_at_quad? - if (on_sphere) then - grav_at_quads = radial_inward_normal_at_quad_ele(X, ele) - else - grav_at_quads = ele_val_at_quad(gravity, ele) - end if - ! Calculate element length parallel to the direction of mixing defined above - enodes => ele_nodes(X, ele) - do i = 1,size(enodes) - pos = node_val(X, enodes(i)) - gravity_at_node = node_val(gravity, enodes(i)) - !rad(i) = pos(mesh_dim(T)) - rad(i) = dot_product(pos, gravity_at_node) - end do - dr = maxval(rad) - minval(rad) - do i = 1, ele_ngi(T,ele) - drho_dz(i) = dot_product(grad_rho(:,i), grav_at_quads(:,i)) - ! Note test to limit mixing to adverse changes in density wrt gravity - if (drho_dz(i) > 0.0) drho_dz(i) = 0.0 - ! Form the coefficient of diffusion to deliver the required mixing - end do - ! TODO: Calculate dr - per element? or per Guass point? - ! dimension in which gravity lies parallel to - if (on_sphere) then - mixing_diffusion_diag(mesh_dim(X),:) = mixing_diffusion_amplitude * dt& - &* gravity_magnitude * dr**2 * drho_dz(:) - mixing_diffusion=rotate_diagonal_to_sphere_gi(X, ele, mixing_diffusion_diag) - else - do i = 1, mesh_dim(X) - mixing_diffusion(i,i,:) = mixing_diffusion_amplitude * dt& - &* gravity_magnitude * dr**2 * gravity_at_node(i) * drho_dz(:) + + mixing_diffusion = 0.0 + mixing_diffusion_loc = 0.0 + ! Vertical mixing by diffusion + ! TODO: Add option to generate optimal coefficient + ! k = 1/2 {\Delta t} g ( {\Delta r} )^2 max (d\rho / dr, 0 ) + ! k = 1/2 dt g dr^2 max(drho/dr, 0 ) + if (have_buoyancy_adjustment_by_vertical_diffusion) then + mixing_diffusion_diag = 0.0 + assert(ele_ngi(T, ele) == ele_ngi(buoyancy, ele)) + buoyancysample = ele_val_at_quad(buoyancy, ele) + call transform_to_physical(X, ele, ele_shape(buoyancy,ele), dshape=dt_rho, detwei=detwei_rho) + + grad_rho = ele_grad_at_quad(buoyancy, ele, dt_rho) + + ! Calculate the gradient in the direction of gravity + ! TODO: Build on_sphere into ele_val_at_quad? + if (on_sphere) then + grav_at_quads = radial_inward_normal_at_quad_ele(X, ele) + else + grav_at_quads = ele_val_at_quad(gravity, ele) + end if + ! Calculate element length parallel to the direction of mixing defined above + enodes => ele_nodes(X, ele) + do i = 1,size(enodes) + pos = node_val(X, enodes(i)) + gravity_at_node = node_val(gravity, enodes(i)) + !rad(i) = pos(mesh_dim(T)) + rad(i) = dot_product(pos, gravity_at_node) + end do + dr = maxval(rad) - minval(rad) + do i = 1, ele_ngi(T,ele) + drho_dz(i) = dot_product(grad_rho(:,i), grav_at_quads(:,i)) + ! Note test to limit mixing to adverse changes in density wrt gravity + if (drho_dz(i) > 0.0) drho_dz(i) = 0.0 + ! Form the coefficient of diffusion to deliver the required mixing end do - end if - - if(have_buoyancy_adjustment_diffusivity) then - call set(buoyancy_adjustment_diffusivity, T_ele, mixing_diffusion_amplitude * dt& - &* gravity_magnitude * dr**2 * maxval(drho_dz(:))) - ewrite(4,*) "Buoynacy adjustment diffusivity, ele:", ele, "diffusivity:", mixing_diffusion_amplitude * dt * gravity_magnitude * dr**2 * maxval(drho_dz(:)) - end if - - !! Buoyancy adjustment by vertical mixing scheme debugging statements - ewrite(4,*) "mixing_grad_rho", minval(grad_rho(:,:)), maxval(grad_rho(:,:)) - ewrite(4,*) "mixing_drho_dz", minval(drho_dz(:)), maxval(drho_dz(:)) - ewrite(4,*) "mixing_coeffs amp dt g dr", mixing_diffusion_amplitude, dt, gravity_magnitude, dr**2 - ewrite(4,*) "mixing_diffusion", minval(mixing_diffusion(2,2,:)), maxval(mixing_diffusion(2,2,:)) - - mixing_diffusion_rhs=shape_tensor_rhs(T%mesh%shape, mixing_diffusion, detwei_rho) - t_mass=shape_shape(T%mesh%shape, T%mesh%shape, detwei_rho) - call invert(t_mass) - do i=1,X%dim - do j=1,X%dim - mixing_diffusion_loc(i,j,:) = matmul(t_mass,mixing_diffusion_rhs(i,j,:)) + ! TODO: Calculate dr - per element? or per Guass point? + ! dimension in which gravity lies parallel to + if (on_sphere) then + mixing_diffusion_diag(mesh_dim(X),:) = mixing_diffusion_amplitude * dt& + &* gravity_magnitude * dr**2 * drho_dz(:) + mixing_diffusion=rotate_diagonal_to_sphere_gi(X, ele, mixing_diffusion_diag) + else + do i = 1, mesh_dim(X) + mixing_diffusion(i,i,:) = mixing_diffusion_amplitude * dt& + &* gravity_magnitude * dr**2 * gravity_at_node(i) * drho_dz(:) + end do + end if + + if(have_buoyancy_adjustment_diffusivity) then + call set(buoyancy_adjustment_diffusivity, T_ele, mixing_diffusion_amplitude * dt& + &* gravity_magnitude * dr**2 * maxval(drho_dz(:))) + ewrite(4,*) "Buoynacy adjustment diffusivity, ele:", ele, "diffusivity:", mixing_diffusion_amplitude * dt * gravity_magnitude * dr**2 * maxval(drho_dz(:)) + end if + + !! Buoyancy adjustment by vertical mixing scheme debugging statements + ewrite(4,*) "mixing_grad_rho", minval(grad_rho(:,:)), maxval(grad_rho(:,:)) + ewrite(4,*) "mixing_drho_dz", minval(drho_dz(:)), maxval(drho_dz(:)) + ewrite(4,*) "mixing_coeffs amp dt g dr", mixing_diffusion_amplitude, dt, gravity_magnitude, dr**2 + ewrite(4,*) "mixing_diffusion", minval(mixing_diffusion(2,2,:)), maxval(mixing_diffusion(2,2,:)) + + mixing_diffusion_rhs=shape_tensor_rhs(T%mesh%shape, mixing_diffusion, detwei_rho) + t_mass=shape_shape(T%mesh%shape, T%mesh%shape, detwei_rho) + call invert(t_mass) + do i=1,X%dim + do j=1,X%dim + mixing_diffusion_loc(i,j,:) = matmul(t_mass,mixing_diffusion_rhs(i,j,:)) + end do end do - end do - end if - - !---------------------------------------------------------------------- - ! Construct element-wise quantities. - !---------------------------------------------------------------------- - - Diffusivity_ele = ele_val(Diffusivity, ele) + mixing_diffusion_loc - - !---------------------------------------------------------------------- - ! Construct bilinear forms. - !---------------------------------------------------------------------- - - ! Element density matrix. - ! / - ! | T T dV - ! / - if(move_mesh) then - mass_mat = shape_shape(T_shape, T_shape, detwei_new) - else - mass_mat = shape_shape(T_shape, T_shape, detwei) - end if - - if (include_advection) then - - ! Advecting velocity at quadrature points. - U_nl_q=ele_val_at_quad(U_nl,ele) - - if(integrate_conservation_term_by_parts) then - ! Element advection matrix - ! / / - ! - beta | (grad T dot U_nl) T Rho dV + (1. - beta) | T (U_nl dot grad T) Rho dV - ! / / - - ! Introduce grid velocities in non-linear terms. - Advection_mat = -beta* dshape_dot_vector_shape(dt_t, U_nl_q, t_shape, detwei) & + end if + + !---------------------------------------------------------------------- + ! Construct element-wise quantities. + !---------------------------------------------------------------------- + + Diffusivity_ele = ele_val(Diffusivity, ele) + mixing_diffusion_loc + + !---------------------------------------------------------------------- + ! Construct bilinear forms. + !---------------------------------------------------------------------- + + ! Element density matrix. + ! / + ! | T T dV + ! / + if(move_mesh) then + mass_mat = shape_shape(T_shape, T_shape, detwei_new) + else + mass_mat = shape_shape(T_shape, T_shape, detwei) + end if + + if (include_advection) then + + ! Advecting velocity at quadrature points. + U_nl_q=ele_val_at_quad(U_nl,ele) + + if(integrate_conservation_term_by_parts) then + ! Element advection matrix + ! / / + ! - beta | (grad T dot U_nl) T Rho dV + (1. - beta) | T (U_nl dot grad T) Rho dV + ! / / + + ! Introduce grid velocities in non-linear terms. + Advection_mat = -beta* dshape_dot_vector_shape(dt_t, U_nl_q, t_shape, detwei) & + (1.-beta) * shape_vector_dot_dshape(t_shape, U_nl_q, dt_t, detwei) - if(move_mesh) then - if(integrate_by_parts_once) then - Advection_mat = Advection_mat & - + dshape_dot_vector_shape(dt_t, ele_val_at_quad(U_mesh,ele), t_shape, detwei) - else - Advection_mat = Advection_mat & - - shape_vector_dot_dshape(t_shape, ele_val_at_quad(U_mesh,ele), dt_t, detwei) & - - shape_shape(t_shape, t_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei) + if(move_mesh) then + if(integrate_by_parts_once) then + Advection_mat = Advection_mat & + + dshape_dot_vector_shape(dt_t, ele_val_at_quad(U_mesh,ele), t_shape, detwei) + else + Advection_mat = Advection_mat & + - shape_vector_dot_dshape(t_shape, ele_val_at_quad(U_mesh,ele), dt_t, detwei) & + - shape_shape(t_shape, t_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei) + end if + end if + else + ! Introduce grid velocities in non-linear terms. + if(move_mesh) then + ! NOTE: modifying the velocities at the gauss points in this case! + U_nl_q = U_nl_q - ele_val_at_quad(U_mesh, ele) end if - end if - else - ! Introduce grid velocities in non-linear terms. - if(move_mesh) then - ! NOTE: modifying the velocities at the gauss points in this case! - U_nl_q = U_nl_q - ele_val_at_quad(U_mesh, ele) - end if - U_nl_div_q=ele_div_at_quad(U_nl, ele, du_t) - - if(integrate_by_parts_once) then - ! Element advection matrix - ! / / - ! - | (grad T dot U_nl) T Rho dV - (1. - beta) | T ( div U_nl ) T Rho dV - ! / / - Advection_mat = - dshape_dot_vector_shape(dt_t, U_nl_q, t_shape, detwei) & + U_nl_div_q=ele_div_at_quad(U_nl, ele, du_t) + + if(integrate_by_parts_once) then + ! Element advection matrix + ! / / + ! - | (grad T dot U_nl) T Rho dV - (1. - beta) | T ( div U_nl ) T Rho dV + ! / / + Advection_mat = - dshape_dot_vector_shape(dt_t, U_nl_q, t_shape, detwei) & - (1.-beta) * shape_shape(t_shape, t_shape, U_nl_div_q * detwei) - else - ! Element advection matrix - ! / / - ! | T (U_nl dot grad T) Rho dV + beta | T ( div U_nl ) T Rho dV - ! / / - Advection_mat = shape_vector_dot_dshape(t_shape, U_nl_q, dt_t, detwei) & + else + ! Element advection matrix + ! / / + ! | T (U_nl dot grad T) Rho dV + beta | T ( div U_nl ) T Rho dV + ! / / + Advection_mat = shape_vector_dot_dshape(t_shape, U_nl_q, dt_t, detwei) & + beta * shape_shape(t_shape, t_shape, U_nl_div_q * detwei) - if(move_mesh) then - Advection_mat = Advection_mat & - - shape_shape(t_shape, t_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei) - end if - end if - end if - - ! Add stabilisation to the advection term if requested by the user. - if (stabilisation_scheme==UPWIND) then - ! NOTE: U_nl_q may (or may not) have been modified by the grid velocity - ! with a moving mesh. Don't know what's appropriate so changes may be - ! required above! Hence, this should FLAbort above. - Advection_mat = Advection_mat + & + if(move_mesh) then + Advection_mat = Advection_mat & + - shape_shape(t_shape, t_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei) + end if + end if + end if + + ! Add stabilisation to the advection term if requested by the user. + if (stabilisation_scheme==UPWIND) then + ! NOTE: U_nl_q may (or may not) have been modified by the grid velocity + ! with a moving mesh. Don't know what's appropriate so changes may be + ! required above! Hence, this should FLAbort above. + Advection_mat = Advection_mat + & element_upwind_stabilisation(t_shape, dt_t, U_nl_q, J_mat,& - & detwei) - end if + & detwei) + end if - else - Advection_mat=0.0 - end if + else + Advection_mat=0.0 + end if - ! Absorption matrix. - Abs_mat = shape_shape(T_shape, T_shape, detwei*ele_val_at_quad(Absorption,ele)) + ! Absorption matrix. + Abs_mat = shape_shape(T_shape, T_shape, detwei*ele_val_at_quad(Absorption,ele)) - ! Diffusion. - Diffusivity_mat=0.0 + ! Diffusion. + Diffusivity_mat=0.0 - if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then - if (primal) then - if(.not.remove_element_integral) then + if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then + if (primal) then + if(.not.remove_element_integral) then - Diffusivity_mat(:size(T_ele),:size(T_ele))= & + Diffusivity_mat(:size(T_ele),:size(T_ele))= & dshape_tensor_dshape(dt_t, ele_val_at_quad(Diffusivity,ele) & - & + mixing_diffusion, dt_t, detwei) - - end if - - !Get ele2grad_mat - if((diffusion_scheme==CDG).or.(diffusion_scheme==IP)) then - !Compute a matrix which maps ele vals to ele grad vals - !This works since the gradient of the shape function - !lives in the original polynomial space -- cjc - if(move_mesh) then - inverse_mass_mat = shape_shape(T_shape, T_shape, detwei) - else - inverse_mass_mat = mass_mat - end if - call invert(inverse_mass_mat) - ele2grad_mat = shape_dshape(T_shape,dt_t,detwei) - do i = 1, mesh_dim(T) - ele2grad_mat(i,:,:) = matmul(inverse_mass_mat, & + & + mixing_diffusion, dt_t, detwei) + + end if + + !Get ele2grad_mat + if((diffusion_scheme==CDG).or.(diffusion_scheme==IP)) then + !Compute a matrix which maps ele vals to ele grad vals + !This works since the gradient of the shape function + !lives in the original polynomial space -- cjc + if(move_mesh) then + inverse_mass_mat = shape_shape(T_shape, T_shape, detwei) + else + inverse_mass_mat = mass_mat + end if + call invert(inverse_mass_mat) + ele2grad_mat = shape_dshape(T_shape,dt_t,detwei) + do i = 1, mesh_dim(T) + ele2grad_mat(i,:,:) = matmul(inverse_mass_mat, & ele2grad_mat(i,:,:)) - end do + end do - if(debugging) then - call random_number(test_vals) + if(debugging) then + call random_number(test_vals) - do i = 1, mesh_dim(T) + do i = 1, mesh_dim(T) - test_vals_out_1 = matmul(test_vals,dt_t(:,:,i)) + test_vals_out_1 = matmul(test_vals,dt_t(:,:,i)) - test_vals_out_2 = matmul( transpose(T_shape%n), & + test_vals_out_2 = matmul( transpose(T_shape%n), & matmul(ele2grad_mat(i,:,:), test_vals)) - test_val = maxval(sqrt((test_vals_out_1& - &-test_vals_out_2)**2))& - &/maxval(sqrt(test_vals_out_1)) - if(test_val>gradient_test_bound) then - ewrite(-1,*) test_val, gradient_test_bound - FLAbort('ele2grad test failed') - end if - end do - end if - - end if - - !get kappa mat for CDG - if(diffusion_scheme==CDG) then - kappa_mat = shape_shape_tensor(t_shape,t_shape,detwei, & - & ele_val_at_quad(Diffusivity,ele) + mixing_diffusion) - end if - - else if (diffusion_scheme/=MASSLUMPED_RT0) then - - ! Tau Q = grad(u) - Q_inv= shape_shape(q_shape, q_shape, detwei) - call invert(Q_inv) - call cholesky_factor(Q_inv) - - Grad_T_mat=0.0 - Grad_T_face_mat=0.0 - Div_T_mat=0.0 - Grad_T_mat(:, :, :size(T_ele)) = -dshape_shape(dq_t, T_shape,& + test_val = maxval(sqrt((test_vals_out_1& + &-test_vals_out_2)**2))& + &/maxval(sqrt(test_vals_out_1)) + if(test_val>gradient_test_bound) then + ewrite(-1,*) test_val, gradient_test_bound + FLAbort('ele2grad test failed') + end if + end do + end if + + end if + + !get kappa mat for CDG + if(diffusion_scheme==CDG) then + kappa_mat = shape_shape_tensor(t_shape,t_shape,detwei, & + & ele_val_at_quad(Diffusivity,ele) + mixing_diffusion) + end if + + else if (diffusion_scheme/=MASSLUMPED_RT0) then + + ! Tau Q = grad(u) + Q_inv= shape_shape(q_shape, q_shape, detwei) + call invert(Q_inv) + call cholesky_factor(Q_inv) + + Grad_T_mat=0.0 + Grad_T_face_mat=0.0 + Div_T_mat=0.0 + Grad_T_mat(:, :, :size(T_ele)) = -dshape_shape(dq_t, T_shape,& detwei) !!$ Grad_T_mat(:, :, :size(T_ele)) = shape_dshape(q_shape, dt_t, detwei) - Div_T_mat(:, :, :size(T_ele)) = -shape_dshape(q_shape, dt_t, detwei) - end if - end if + Div_T_mat(:, :, :size(T_ele)) = -shape_dshape(q_shape, dt_t, detwei) + end if + end if - !---------------------------------------------------------------------- - ! Perform global assembly. - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! Perform global assembly. + !---------------------------------------------------------------------- - if (.not.semi_discrete) then - ! Advection and absorbtion - l_T_rhs= - matmul(Advection_mat & + if (.not.semi_discrete) then + ! Advection and absorbtion + l_T_rhs= - matmul(Advection_mat & + Abs_mat(:,:), ele_val(T,ele)) - else - l_T_rhs=0.0 - end if - - ! Source term - if (.not. add_src_directly_to_rhs) then - l_T_rhs=l_T_rhs & - + shape_rhs(T_shape, detwei*ele_val_at_quad(Source, ele)) - end if - - if(move_mesh) then - l_T_rhs=l_T_rhs & - -shape_rhs(T_shape, ele_val_at_quad(t, ele)*(detwei_new-detwei_old)/dt) - end if - - ! Right hand side field. - call addto(RHS, t_ele, l_T_rhs) - ! Assemble matrix. - - ! Advection. - l_T_mat= Advection_mat*theta*dt & - ! Absorption. + else + l_T_rhs=0.0 + end if + + ! Source term + if (.not. add_src_directly_to_rhs) then + l_T_rhs=l_T_rhs & + + shape_rhs(T_shape, detwei*ele_val_at_quad(Source, ele)) + end if + + if(move_mesh) then + l_T_rhs=l_T_rhs & + -shape_rhs(T_shape, ele_val_at_quad(t, ele)*(detwei_new-detwei_old)/dt) + end if + + ! Right hand side field. + call addto(RHS, t_ele, l_T_rhs) + ! Assemble matrix. + + ! Advection. + l_T_mat= Advection_mat*theta*dt & + ! Absorption. + Abs_mat(:,:)*theta*dt - if (present(mass)) then - ! Return mass separately. - ! NOTE: this doesn't deal with mesh movement - call addto(mass, t_ele, t_ele, mass_mat) - else - if(include_mass) then - ! Put mass in the matrix. - l_T_mat=l_T_mat+mass_mat - end if - end if - - call addto(big_m, t_ele, t_ele, l_T_mat) - - !------------------------------------------------------------------- - ! Interface integrals - !------------------------------------------------------------------- - - neigh=>ele_neigh(T, ele) - ! x_neigh/=t_neigh only on periodic boundaries. - x_neigh=>ele_neigh(X, ele) - periodic_neigh = any(neigh .ne. x_neigh) - - ! Local node map counter. - start=size(T_ele)+1 - ! Flag for whether this is a boundary element. - boundary_element=.false. - - neighbourloop: do ni=1,size(neigh) - - primal_fluxes_mat = 0.0 - penalty_fluxes_mat = 0.0 - - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- - - ! These finding routines are outside the inner loop so as to allow - ! for local stack variables of the right size in - ! construct_add_diff_interface_dg. - - ele_2=neigh(ni) - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(T, ele, ele_2) - - if (ele_2>0) then - ! Internal faces. - face_2=ele_face(T, ele_2, ele) - else - ! External face. - face_2=face - boundary_element=.true. - end if - - !Compute distance between cell centre and neighbouring cell centre - !This is for Interior Penalty Method -- cjc - !-------------- - - !NEED TO COMPUTE THE VECTOR BETWEEN THE TWO CELL CENTRES, THEN - !PROJECT ONTO THE NORMAL - - if(dg.and.diffusion_scheme==IP) then - if(edge_length_option==USE_ELEMENT_CENTRES) then - ele_2_X = x_neigh(ni) - ele_centre = sum(X_val,2)/size(X_val,2) - face_centre = sum(face_val(X,face),2)/size(face_val(X,face),2) - if(boundary_element) then + if (present(mass)) then + ! Return mass separately. + ! NOTE: this doesn't deal with mesh movement + call addto(mass, t_ele, t_ele, mass_mat) + else + if(include_mass) then + ! Put mass in the matrix. + l_T_mat=l_T_mat+mass_mat + end if + end if + + call addto(big_m, t_ele, t_ele, l_T_mat) + + !------------------------------------------------------------------- + ! Interface integrals + !------------------------------------------------------------------- + + neigh=>ele_neigh(T, ele) + ! x_neigh/=t_neigh only on periodic boundaries. + x_neigh=>ele_neigh(X, ele) + periodic_neigh = any(neigh .ne. x_neigh) + + ! Local node map counter. + start=size(T_ele)+1 + ! Flag for whether this is a boundary element. + boundary_element=.false. + + neighbourloop: do ni=1,size(neigh) + + primal_fluxes_mat = 0.0 + penalty_fluxes_mat = 0.0 + + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- + + ! These finding routines are outside the inner loop so as to allow + ! for local stack variables of the right size in + ! construct_add_diff_interface_dg. + + ele_2=neigh(ni) + + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(T, ele, ele_2) + + if (ele_2>0) then + ! Internal faces. + face_2=ele_face(T, ele_2, ele) + else + ! External face. + face_2=face + boundary_element=.true. + end if + + !Compute distance between cell centre and neighbouring cell centre + !This is for Interior Penalty Method -- cjc + !-------------- + + !NEED TO COMPUTE THE VECTOR BETWEEN THE TWO CELL CENTRES, THEN + !PROJECT ONTO THE NORMAL + + if(dg.and.diffusion_scheme==IP) then + if(edge_length_option==USE_ELEMENT_CENTRES) then + ele_2_X = x_neigh(ni) + ele_centre = sum(X_val,2)/size(X_val,2) + face_centre = sum(face_val(X,face),2)/size(face_val(X,face),2) + if(boundary_element) then ! Boundary case. We compute 2x the distance to the face centre centre_vec = 2.0*(ele_centre - face_centre) - else if (ele_2/=ele_2_X) then + else if (ele_2/=ele_2_X) then ! Periodic boundary case. We have to cook up the coordinate by ! adding vectors to the face from each side. x_val_2 = ele_val(X,ele_2_X) neigh_centre = sum(X_val_2,2)/size(X_val_2,2) face_centre_2 = & - sum(face_val(X,face_2),2)/size(face_val(X,face_2),2) + sum(face_val(X,face_2),2)/size(face_val(X,face_2),2) centre_vec = ele_centre - face_centre + & - & face_centre_2 - neigh_centre - else + & face_centre_2 - neigh_centre + else x_val_2 = ele_val(X,ele_2_X) neigh_centre = sum(X_val_2,2)/size(X_val_2,2) centre_vec = ele_centre - neigh_centre - end if - end if - end if - !-------------- - - if (dg) then - finish=start+face_loc(T, face_2)-1 - - local_glno(start:finish)=face_global_nodes(T, face_2) - end if - - if(primal) then - call construct_adv_diff_interface_dg(ele, face, face_2, ni,& - & centre_vec,& - & big_m, rhs, rhs_diff, Grad_T_mat, Div_T_mat, X, T, U_nl,& - & bc_value, bc_type, & - & U_mesh, q_mesh, cdg_switch_in, & - & primal_fluxes_mat, ele2grad_mat,diffusivity, & - & penalty_fluxes_mat, normal_mat, kappa_normal_mat) - - select case(diffusion_scheme) - case(IP) - call local_assembly_primal_face - call local_assembly_ip_face - case(CDG) - call local_assembly_primal_face - if(.not.remove_cdg_fluxes) call local_assembly_cdg_face - call local_assembly_ip_face - end select - - else - call construct_adv_diff_interface_dg(ele, face, face_2, ni,& - & centre_vec,& - & big_m, rhs, rhs_diff, Grad_T_mat, Div_T_mat, X, T, U_nl,& - & bc_value, bc_type, & - & U_mesh, q_mesh) - end if - - if (dg) then - start=start+face_loc(T, face_2) - end if - - end do neighbourloop - - !---------------------------------------------------------------------- - ! Construct local diffusivity operator for DG. - !---------------------------------------------------------------------- - - if (dg.and.(include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion)) then - - select case(diffusion_scheme) - case(ARBITRARY_UPWIND) - call local_assembly_arbitrary_upwind - case(BASSI_REBAY) - call local_assembly_bassi_rebay - case(MASSLUMPED_RT0) - select case (rt0_masslumping_scheme) - case (RT0_MASSLUMPING_ARBOGAST) - call local_assembly_masslumped_rt0 - case (RT0_MASSLUMPING_CIRCUMCENTRED) - call local_assembly_masslumped_rt0_circumcentred - case default - FLAbort("Unknown rt0 masslumping for P0 diffusion.") - end select - end select - - if (boundary_element) then - ! Weak application of dirichlet conditions on diffusion term. - - do i=1, 2 - ! this is done in 2 passes - ! iteration 1: wipe the rows corresponding to weak dirichlet boundary faces - ! iteration 2: for columns corresponding to weak dirichlet boundary faces, - ! move this coefficient multiplied with the bc value to the rhs - ! then wipe the column - ! The 2 iterations are necessary for elements with more than one weak dirichlet boundary face - ! as we should not try to move the coefficient in columns corresponding to boundary face 1 - ! in rows correspoding to face 2 to the rhs, i.e. we need to wipe *all* boundary rows first. - ! Local node map counter. - start=size(T_ele)+1 - - boundary_neighbourloop: do ni=1,size(neigh) - ele_2=neigh(ni) - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - if (ele_2>0) then - ! Interior face - we need the neighbouring face to - ! calculate the new start - face=ele_face(T, ele_2, ele) - - else - ! Boundary face - - face=ele_face(T, ele, ele_2) + end if + end if + end if + !-------------- - if (bc_type(face)==BCTYPE_WEAKDIRICHLET) then + if (dg) then + finish=start+face_loc(T, face_2)-1 - ! weak Dirichlet condition. + local_glno(start:finish)=face_global_nodes(T, face_2) + end if - finish=start+face_loc(T, face)-1 + if(primal) then + call construct_adv_diff_interface_dg(ele, face, face_2, ni,& + & centre_vec,& + & big_m, rhs, rhs_diff, Grad_T_mat, Div_T_mat, X, T, U_nl,& + & bc_value, bc_type, & + & U_mesh, q_mesh, cdg_switch_in, & + & primal_fluxes_mat, ele2grad_mat,diffusivity, & + & penalty_fluxes_mat, normal_mat, kappa_normal_mat) + + select case(diffusion_scheme) + case(IP) + call local_assembly_primal_face + call local_assembly_ip_face + case(CDG) + call local_assembly_primal_face + if(.not.remove_cdg_fluxes) call local_assembly_cdg_face + call local_assembly_ip_face + end select - if (i==1) then - ! Wipe out boundary condition's coupling to itself. - Diffusivity_mat(start:finish,:)=0.0 - else + else + call construct_adv_diff_interface_dg(ele, face, face_2, ni,& + & centre_vec,& + & big_m, rhs, rhs_diff, Grad_T_mat, Div_T_mat, X, T, U_nl,& + & bc_value, bc_type, & + & U_mesh, q_mesh) + end if - ! Add BC into RHS - ! - call addto(RHS_diff, local_glno, & - & -matmul(Diffusivity_mat(:,start:finish), & - & ele_val( bc_value, face ))) + if (dg) then + start=start+face_loc(T, face_2) + end if - ! Ensure it is not used again. - Diffusivity_mat(:,start:finish)=0.0 + end do neighbourloop - end if + !---------------------------------------------------------------------- + ! Construct local diffusivity operator for DG. + !---------------------------------------------------------------------- - end if + if (dg.and.(include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion)) then - end if + select case(diffusion_scheme) + case(ARBITRARY_UPWIND) + call local_assembly_arbitrary_upwind + case(BASSI_REBAY) + call local_assembly_bassi_rebay + case(MASSLUMPED_RT0) + select case (rt0_masslumping_scheme) + case (RT0_MASSLUMPING_ARBOGAST) + call local_assembly_masslumped_rt0 + case (RT0_MASSLUMPING_CIRCUMCENTRED) + call local_assembly_masslumped_rt0_circumcentred + case default + FLAbort("Unknown rt0 masslumping for P0 diffusion.") + end select + end select - start=start+face_loc(T, face) + if (boundary_element) then + ! Weak application of dirichlet conditions on diffusion term. - end do boundary_neighbourloop + do i=1, 2 + ! this is done in 2 passes + ! iteration 1: wipe the rows corresponding to weak dirichlet boundary faces + ! iteration 2: for columns corresponding to weak dirichlet boundary faces, + ! move this coefficient multiplied with the bc value to the rhs + ! then wipe the column + ! The 2 iterations are necessary for elements with more than one weak dirichlet boundary face + ! as we should not try to move the coefficient in columns corresponding to boundary face 1 + ! in rows correspoding to face 2 to the rhs, i.e. we need to wipe *all* boundary rows first. + ! Local node map counter. + start=size(T_ele)+1 - end do + boundary_neighbourloop: do ni=1,size(neigh) + ele_2=neigh(ni) - end if + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + if (ele_2>0) then + ! Interior face - we need the neighbouring face to + ! calculate the new start + face=ele_face(T, ele_2, ele) - end if + else + ! Boundary face - !---------------------------------------------------------------------- - ! Global assembly of diffusion. - !---------------------------------------------------------------------- + face=ele_face(T, ele, ele_2) + if (bc_type(face)==BCTYPE_WEAKDIRICHLET) then - if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then - call addto(Big_m_diff, local_glno, local_glno,& - & Diffusivity_mat*theta*dt) + ! weak Dirichlet condition. - if (.not.semi_discrete) then - call addto(RHS_diff, local_glno, & - & -matmul(Diffusivity_mat, node_val(T, local_glno))) - end if - end if + finish=start+face_loc(T, face)-1 - contains + if (i==1) then + ! Wipe out boundary condition's coupling to itself. + Diffusivity_mat(start:finish,:)=0.0 + else - subroutine local_assembly_arbitrary_upwind + ! Add BC into RHS + ! + call addto(RHS_diff, local_glno, & + & -matmul(Diffusivity_mat(:,start:finish), & + & ele_val( bc_value, face ))) - do dim1=1, Diffusivity%dim(1) - do dim2=1,Diffusivity%dim(2) + ! Ensure it is not used again. + Diffusivity_mat(:,start:finish)=0.0 - ! Div U * G^T * Diffusivity * G * Grad U - ! Where G^T*G = inverse(Q_mass) - Diffusivity_mat=Diffusivity_mat& - +0.5*( & - +matmul(matmul(transpose(grad_T_mat(dim1,:,:))& - & ,mat_diag_mat(Q_inv, Diffusivity_ele(dim1,dim2,:)))& - & ,grad_T_mat(dim2,:,:))& - +matmul(matmul(transpose(div_T_mat(dim1,:,:))& - & ,mat_diag_mat(Q_inv, Diffusivity_ele(dim1,dim2,:)))& - & ,div_T_mat(dim2,:,:))& - &) + end if - end do - end do + end if - end subroutine local_assembly_arbitrary_upwind + end if - subroutine local_assembly_bassi_rebay - integer dim1,dim2 + start=start+face_loc(T, face) - do dim1=1, Diffusivity%dim(1) - do dim2=1,Diffusivity%dim(2) + end do boundary_neighbourloop - ! Div U * G^T * Diffusivity * G * Grad U - ! Where G^T*G = inverse(Q_mass) - Diffusivity_mat=Diffusivity_mat& - +matmul(matmul(transpose(grad_T_mat(dim1,:,:))& - & ,mat_diag_mat(Q_inv, Diffusivity_ele(dim1,dim2,:)))& - & ,grad_T_mat(dim2,:,:)) + end do - end do - end do + end if - end subroutine local_assembly_bassi_rebay + end if - subroutine local_assembly_ip_face - implicit none + !---------------------------------------------------------------------- + ! Global assembly of diffusion. + !---------------------------------------------------------------------- - integer :: nfele, nele - integer, dimension(face_loc(T,face)) :: T_face_loc - nfele = face_loc(T,face) - nele = ele_loc(T,ele) - t_face_loc=face_local_nodes(T, face) + if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then + call addto(Big_m_diff, local_glno, local_glno,& + & Diffusivity_mat*theta*dt) + if (.not.semi_discrete) then + call addto(RHS_diff, local_glno, & + & -matmul(Diffusivity_mat, node_val(T, local_glno))) + end if + end if - if (ele_2<0) then - if(bc_type(face)==BCTYPE_WEAKDIRICHLET) then - !!These terms are not included on Neumann integrals + contains - !! Internal Degrees of Freedom + subroutine local_assembly_arbitrary_upwind - !penalty flux + do dim1=1, Diffusivity%dim(1) + do dim2=1,Diffusivity%dim(2) - Diffusivity_mat(t_face_loc,t_face_loc) = & - Diffusivity_mat(t_face_loc,t_face_loc) + & - penalty_fluxes_mat(1,:,:) + ! Div U * G^T * Diffusivity * G * Grad U + ! Where G^T*G = inverse(Q_mass) + Diffusivity_mat=Diffusivity_mat& + +0.5*( & + +matmul(matmul(transpose(grad_T_mat(dim1,:,:))& + & ,mat_diag_mat(Q_inv, Diffusivity_ele(dim1,dim2,:)))& + & ,grad_T_mat(dim2,:,:))& + +matmul(matmul(transpose(div_T_mat(dim1,:,:))& + & ,mat_diag_mat(Q_inv, Diffusivity_ele(dim1,dim2,:)))& + & ,div_T_mat(dim2,:,:))& + &) - !! External Degrees of Freedom + end do + end do - !!penalty fluxes + end subroutine local_assembly_arbitrary_upwind - Diffusivity_mat(t_face_loc,start:finish) = & - Diffusivity_mat(t_face_loc,start:finish) + & - penalty_fluxes_mat(2,:,:) + subroutine local_assembly_bassi_rebay + integer dim1,dim2 - end if - else + do dim1=1, Diffusivity%dim(1) + do dim2=1,Diffusivity%dim(2) - !! Internal Degrees of Freedom + ! Div U * G^T * Diffusivity * G * Grad U + ! Where G^T*G = inverse(Q_mass) + Diffusivity_mat=Diffusivity_mat& + +matmul(matmul(transpose(grad_T_mat(dim1,:,:))& + & ,mat_diag_mat(Q_inv, Diffusivity_ele(dim1,dim2,:)))& + & ,grad_T_mat(dim2,:,:)) - !penalty flux + end do + end do - Diffusivity_mat(t_face_loc,t_face_loc) = & - Diffusivity_mat(t_face_loc,t_face_loc) + & - penalty_fluxes_mat(1,:,:) + end subroutine local_assembly_bassi_rebay - !! External Degrees of Freedom + subroutine local_assembly_ip_face + implicit none - !!penalty fluxes + integer :: nfele, nele + integer, dimension(face_loc(T,face)) :: T_face_loc - Diffusivity_mat(t_face_loc,start:finish) = & - Diffusivity_mat(t_face_loc,start:finish) + & - penalty_fluxes_mat(2,:,:) + nfele = face_loc(T,face) + nele = ele_loc(T,ele) + t_face_loc=face_local_nodes(T, face) - end if - end subroutine local_assembly_ip_face + if (ele_2<0) then + if(bc_type(face)==BCTYPE_WEAKDIRICHLET) then + !!These terms are not included on Neumann integrals - subroutine local_assembly_primal_face - implicit none + !! Internal Degrees of Freedom - integer :: j - integer :: nele - integer, dimension(face_loc(T,face)) :: T_face_loc + !penalty flux - nele = ele_loc(T,ele) - t_face_loc=face_local_nodes(T, face) + Diffusivity_mat(t_face_loc,t_face_loc) = & + Diffusivity_mat(t_face_loc,t_face_loc) + & + penalty_fluxes_mat(1,:,:) + !! External Degrees of Freedom - if (ele_2<0) then - if(bc_type(face)==BCTYPE_WEAKDIRICHLET) then - !!These terms are not included on Neumann integrals + !!penalty fluxes - !! Internal Degrees of Freedom + Diffusivity_mat(t_face_loc,start:finish) = & + Diffusivity_mat(t_face_loc,start:finish) + & + penalty_fluxes_mat(2,:,:) - !primal fluxes + end if + else - Diffusivity_mat(t_face_loc,1:nele) = & - Diffusivity_mat(t_face_loc,1:nele) + & - primal_fluxes_mat(1,:,:) + !! Internal Degrees of Freedom - do j = 1, size(t_face_loc) - Diffusivity_mat(1:nele,t_face_loc(j)) = & - Diffusivity_mat(1:nele,t_face_loc(j)) + & - primal_fluxes_mat(1,j,:) - end do + !penalty flux - !primal fluxes + Diffusivity_mat(t_face_loc,t_face_loc) = & + Diffusivity_mat(t_face_loc,t_face_loc) + & + penalty_fluxes_mat(1,:,:) - Diffusivity_mat(1:nele,start:finish) = & - Diffusivity_mat(1:nele,start:finish) + & - transpose(primal_fluxes_mat(2,:,:)) + !! External Degrees of Freedom - end if - else + !!penalty fluxes - !! Internal Degrees of Freedom + Diffusivity_mat(t_face_loc,start:finish) = & + Diffusivity_mat(t_face_loc,start:finish) + & + penalty_fluxes_mat(2,:,:) - !primal fluxes + end if - Diffusivity_mat(t_face_loc,1:nele) = & - Diffusivity_mat(t_face_loc,1:nele) + & - primal_fluxes_mat(1,:,:) + end subroutine local_assembly_ip_face - do j = 1, size(t_face_loc) - Diffusivity_mat(1:nele,t_face_loc(j)) = & - Diffusivity_mat(1:nele,t_face_loc(j)) + & - primal_fluxes_mat(1,j,:) - end do + subroutine local_assembly_primal_face + implicit none - !! External Degrees of Freedom + integer :: j + integer :: nele + integer, dimension(face_loc(T,face)) :: T_face_loc - !primal fluxes + nele = ele_loc(T,ele) + t_face_loc=face_local_nodes(T, face) - Diffusivity_mat(start:finish,1:nele) = & - Diffusivity_mat(start:finish,1:nele) + & - primal_fluxes_mat(2,:,:) - Diffusivity_mat(1:nele,start:finish) = & - Diffusivity_mat(1:nele,start:finish) + & - transpose(primal_fluxes_mat(2,:,:)) + if (ele_2<0) then + if(bc_type(face)==BCTYPE_WEAKDIRICHLET) then + !!These terms are not included on Neumann integrals - end if + !! Internal Degrees of Freedom - end subroutine local_assembly_primal_face + !primal fluxes - subroutine local_assembly_cdg_face - implicit none - !!< This code assembles the cdg fluxes involving the r_e and l_e lifting - !!< operators. + Diffusivity_mat(t_face_loc,1:nele) = & + Diffusivity_mat(t_face_loc,1:nele) + & + primal_fluxes_mat(1,:,:) - !!< We assemble the operator - !!< \int (r^e([v]) + l^e(C_{12}.[v]) + r^e_D(v).\kappa. - !!< (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u))dV (*) - !!< This is done by forming the operator R: - !!< \int v R(u)dV = \int v (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u)) dV - !!< and then constructing - !!< \int R(v).\kappa.R(u) dV + do j = 1, size(t_face_loc) + Diffusivity_mat(1:nele,t_face_loc(j)) = & + Diffusivity_mat(1:nele,t_face_loc(j)) + & + primal_fluxes_mat(1,j,:) + end do - !!< The lifting operator r^e is defined by - !!< \int_E \tau . r^e([u]) dV = - \int_e {\tau}.[u] dS - !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.(u^+n^+ + u^-n^-) dS - !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS + !primal fluxes - !!< Where + is the ele side, and - is the ele_2 side, and e is the edge + Diffusivity_mat(1:nele,start:finish) = & + Diffusivity_mat(1:nele,start:finish) + & + transpose(primal_fluxes_mat(2,:,:)) - !!< The lifting operator l^e is defined by - !!< \int_E \tau . l^e(C_{12}.[u])dV = - \int_e C_{12}.[u][\tau] dS - !!< = -\int C_{12}.(u^+n^+ + u^-n^-)(\tau^+.n^+ +\tau^-n^-) dS + end if + else - !!< C_{12} = either (1/2)n^+ or (1/2)n^- - !!< Take (1/2)n^+ if switch_g . n^+> 0 + !! Internal Degrees of Freedom - !!becomes - !!< = \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS - !!< with minus sign if switch_g n^+ > 0 + !primal fluxes - !!< So adding r^e and l^e gives + Diffusivity_mat(t_face_loc,1:nele) = & + Diffusivity_mat(t_face_loc,1:nele) + & + primal_fluxes_mat(1,:,:) - !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS - !!< + \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS + do j = 1, size(t_face_loc) + Diffusivity_mat(1:nele,t_face_loc(j)) = & + Diffusivity_mat(1:nele,t_face_loc(j)) + & + primal_fluxes_mat(1,j,:) + end do - !!< = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch_g n^+ > 0 - !!< = -\int_e \tau^-.n^+(u^+ - u^-) dS otherwise + !! External Degrees of Freedom - !!< so definition of r^e+l^e operator is - !!< \int_E \tau.R(u) dV = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch > 0 - !!< \int_E \tau.R(u) dV = -\int_e \tau^-.n^+(u^+ - u^-) dS if switch < 0 + !primal fluxes - !!< we are doing DG so the basis functions which are non-zero in E are - !!< zero outside E, so \tau^- vanishes in this formula, so we get - !!< \int_E \tau.R(u) dV = -\int_e \tau.n^+(u^+ - u^-) dS if switch > 0 - !!< and R(u) = 0 otherwise. + Diffusivity_mat(start:finish,1:nele) = & + Diffusivity_mat(start:finish,1:nele) + & + primal_fluxes_mat(2,:,:) - !!< finally the boundary lifting operator r^e_D - !!< \int_E \tau.r^e_D(u) dV = -\int_e u\tau.n dS + Diffusivity_mat(1:nele,start:finish) = & + Diffusivity_mat(1:nele,start:finish) + & + transpose(primal_fluxes_mat(2,:,:)) - !!< We assemble the binary form (*) locally with - !!< B(u,v) = p^TR^T.K.Rq, where p is the vector of coefficients of u in - !!< element E plus the coefficients of u on the face e on the other side - !!< K is the matrix obtained from the bilinear form - !!< \int_E N_i \kappa N_j dV where \kappa is the diffusion tensor and - !! N_i are the basis functions with support in element E + end if - !!< The matrix R maps from the coefficients of a scalar field on both sides of face e - !!< to the coefficients of a vector field with inside element E - !!< i.e. size (dim x loc(E),2 x loc(e)) - !!< because of symmetry we just store (dim x loc(E), loc(e)) values - !!< The matrix K maps from vector fields inside element E to vector - !!< fields inside element E - !!< i.e. size (dim x loc(E), dim x loc(E)) - !!< Hence, R^TKR maps from the coefficients of a scalar field on both - !!< sides of face e to themselves - !!< i.e. size (2 x loc(E), 2 x - !!< It can be thus interpreted as a fancy penalty term for - !!< discontinuities, a useful one because it is scale invariant - - !!< The matrix R can be formed by constructing the bilinear form matrix - !!< for r^e, l^e and r^e_D, and then dividing by the elemental mass - !!< matrix on E - - !!< we place R^TKR into Diffusivity_mat which maps from u - !!< coefficients in element E plus those on the other side of face e - !!< to themselves, hence it has size (loc(E) + loc(e), loc(E) + loc(e)) - - !!< R^TKR is stored in add_mat which has size(2 x loc(e), 2 x loc(e)) - - !!< we are using a few other pre-assembled local matrices - !!< normal_mat is \int_e \tau.(un) dS (has size (dim x loc(e),loc(e)) - !!< normal_kappa_mat is \int_e \tau.\kappa.(un) dS - !!< has size (dim x loc(e), loc(e)) - !!< inverse_mass_mat is the inverse mass in E - - integer :: i,j,d1,d2,nele,face1,face2 - integer, dimension(face_loc(T,face)) :: T_face_loc - real, dimension(mesh_dim(T),ele_loc(T,ele),face_loc(T,face)) :: R_mat - real, dimension(2,2,face_loc(T,face),face_loc(T,face)) :: add_mat - - nele = ele_loc(T,ele) - t_face_loc=face_local_nodes(T, face) - - R_mat = 0. - do d1 = 1, mesh_dim(T) - do i = 1, ele_loc(T,ele) - do j = 1, face_loc(T,face) - R_mat(d1,i,j) = & + end subroutine local_assembly_primal_face + + subroutine local_assembly_cdg_face + implicit none + !!< This code assembles the cdg fluxes involving the r_e and l_e lifting + !!< operators. + + !!< We assemble the operator + !!< \int (r^e([v]) + l^e(C_{12}.[v]) + r^e_D(v).\kappa. + !!< (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u))dV (*) + !!< This is done by forming the operator R: + !!< \int v R(u)dV = \int v (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u)) dV + !!< and then constructing + !!< \int R(v).\kappa.R(u) dV + + !!< The lifting operator r^e is defined by + !!< \int_E \tau . r^e([u]) dV = - \int_e {\tau}.[u] dS + !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.(u^+n^+ + u^-n^-) dS + !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS + + !!< Where + is the ele side, and - is the ele_2 side, and e is the edge + + !!< The lifting operator l^e is defined by + !!< \int_E \tau . l^e(C_{12}.[u])dV = - \int_e C_{12}.[u][\tau] dS + !!< = -\int C_{12}.(u^+n^+ + u^-n^-)(\tau^+.n^+ +\tau^-n^-) dS + + !!< C_{12} = either (1/2)n^+ or (1/2)n^- + !!< Take (1/2)n^+ if switch_g . n^+> 0 + + !!becomes + !!< = \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS + !!< with minus sign if switch_g n^+ > 0 + + !!< So adding r^e and l^e gives + + !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS + !!< + \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS + + !!< = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch_g n^+ > 0 + !!< = -\int_e \tau^-.n^+(u^+ - u^-) dS otherwise + + !!< so definition of r^e+l^e operator is + !!< \int_E \tau.R(u) dV = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch > 0 + !!< \int_E \tau.R(u) dV = -\int_e \tau^-.n^+(u^+ - u^-) dS if switch < 0 + + !!< we are doing DG so the basis functions which are non-zero in E are + !!< zero outside E, so \tau^- vanishes in this formula, so we get + !!< \int_E \tau.R(u) dV = -\int_e \tau.n^+(u^+ - u^-) dS if switch > 0 + !!< and R(u) = 0 otherwise. + + !!< finally the boundary lifting operator r^e_D + !!< \int_E \tau.r^e_D(u) dV = -\int_e u\tau.n dS + + !!< We assemble the binary form (*) locally with + !!< B(u,v) = p^TR^T.K.Rq, where p is the vector of coefficients of u in + !!< element E plus the coefficients of u on the face e on the other side + !!< K is the matrix obtained from the bilinear form + !!< \int_E N_i \kappa N_j dV where \kappa is the diffusion tensor and + !! N_i are the basis functions with support in element E + + !!< The matrix R maps from the coefficients of a scalar field on both sides of face e + !!< to the coefficients of a vector field with inside element E + !!< i.e. size (dim x loc(E),2 x loc(e)) + !!< because of symmetry we just store (dim x loc(E), loc(e)) values + !!< The matrix K maps from vector fields inside element E to vector + !!< fields inside element E + !!< i.e. size (dim x loc(E), dim x loc(E)) + !!< Hence, R^TKR maps from the coefficients of a scalar field on both + !!< sides of face e to themselves + !!< i.e. size (2 x loc(E), 2 x + !!< It can be thus interpreted as a fancy penalty term for + !!< discontinuities, a useful one because it is scale invariant + + !!< The matrix R can be formed by constructing the bilinear form matrix + !!< for r^e, l^e and r^e_D, and then dividing by the elemental mass + !!< matrix on E + + !!< we place R^TKR into Diffusivity_mat which maps from u + !!< coefficients in element E plus those on the other side of face e + !!< to themselves, hence it has size (loc(E) + loc(e), loc(E) + loc(e)) + + !!< R^TKR is stored in add_mat which has size(2 x loc(e), 2 x loc(e)) + + !!< we are using a few other pre-assembled local matrices + !!< normal_mat is \int_e \tau.(un) dS (has size (dim x loc(e),loc(e)) + !!< normal_kappa_mat is \int_e \tau.\kappa.(un) dS + !!< has size (dim x loc(e), loc(e)) + !!< inverse_mass_mat is the inverse mass in E + + integer :: i,j,d1,d2,nele,face1,face2 + integer, dimension(face_loc(T,face)) :: T_face_loc + real, dimension(mesh_dim(T),ele_loc(T,ele),face_loc(T,face)) :: R_mat + real, dimension(2,2,face_loc(T,face),face_loc(T,face)) :: add_mat + + nele = ele_loc(T,ele) + t_face_loc=face_local_nodes(T, face) + + R_mat = 0. + do d1 = 1, mesh_dim(T) + do i = 1, ele_loc(T,ele) + do j = 1, face_loc(T,face) + R_mat(d1,i,j) = & &sum(inverse_mass_mat(i,t_face_loc)*normal_mat(d1,:,j)) - end do - end do - end do + end do + end do + end do - add_mat = 0.0 - if(ele_2<0) then - if ((bc_type(face)==BCTYPE_DIRICHLET).or.(bc_type(face)& + add_mat = 0.0 + if(ele_2<0) then + if ((bc_type(face)==BCTYPE_DIRICHLET).or.(bc_type(face)& &==BCTYPE_WEAKDIRICHLET)) then - !Boundary case - ! R(/tau,u) = -\int_e \tau.n u dS - !do d1 = 1, mesh_dim(T) - ! do d2 = 1, mesh_dim(T) - ! add_mat(1,1,:,:) = add_mat(1,1,:,:) + & - ! matmul(transpose(R_mat(d1,:,:)), & - ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - ! add_mat(2,2,:,:) = add_mat(2,2,:,:) + & - ! matmul(transpose(R_mat(d1,:,:)), & - ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - ! end do - !end do - - do face1 = 1, 2 - do face2 = 1, 2 - do d1 = 1, mesh_dim(T) - do d2 = 1, mesh_dim(T) - add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & + !Boundary case + ! R(/tau,u) = -\int_e \tau.n u dS + !do d1 = 1, mesh_dim(T) + ! do d2 = 1, mesh_dim(T) + ! add_mat(1,1,:,:) = add_mat(1,1,:,:) + & + ! matmul(transpose(R_mat(d1,:,:)), & + ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) + ! add_mat(2,2,:,:) = add_mat(2,2,:,:) + & + ! matmul(transpose(R_mat(d1,:,:)), & + ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) + ! end do + !end do + + do face1 = 1, 2 + do face2 = 1, 2 + do d1 = 1, mesh_dim(T) + do d2 = 1, mesh_dim(T) + add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & &(-1.)**(face1+face2)*matmul(transpose(R_mat(d1,:,:)), & &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - end do - end do - end do - end do - - end if - else if(CDG_switch_in) then - ! interior case - ! R(\tau,u) = -\int_e \tau.n^+(u^+ - u^-) dS - do face1 = 1, 2 - do face2 = 1, 2 - do d1 = 1, mesh_dim(T) - do d2 = 1, mesh_dim(T) - add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & + end do + end do + end do + end do + + end if + else if(CDG_switch_in) then + ! interior case + ! R(\tau,u) = -\int_e \tau.n^+(u^+ - u^-) dS + do face1 = 1, 2 + do face2 = 1, 2 + do d1 = 1, mesh_dim(T) + do d2 = 1, mesh_dim(T) + add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & &(-1.)**(face1+face2)*matmul(transpose(R_mat(d1,:,:)), & &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - end do - end do - end do - end do - end if + end do + end do + end do + end do + end if - !face1 = 1, face2 = 1 + !face1 = 1, face2 = 1 - Diffusivity_mat(t_face_loc,t_face_loc) = & + Diffusivity_mat(t_face_loc,t_face_loc) = & &Diffusivity_mat(t_face_loc,t_face_loc) + & &add_mat(1,1,:,:) - !face1 = 1, face2 = 2 + !face1 = 1, face2 = 2 - Diffusivity_mat(t_face_loc,start:finish) = & - &Diffusivity_mat(t_face_loc,start:finish) + & - &add_mat(1,2,:,:) + Diffusivity_mat(t_face_loc,start:finish) = & + &Diffusivity_mat(t_face_loc,start:finish) + & + &add_mat(1,2,:,:) - !face1 = 2, face2 = 1 + !face1 = 2, face2 = 1 - Diffusivity_mat(start:finish,t_face_loc) = & - Diffusivity_mat(start:finish,t_face_loc) + & + Diffusivity_mat(start:finish,t_face_loc) = & + Diffusivity_mat(start:finish,t_face_loc) + & &add_mat(2,1,:,:) - !face1 = 2, face2 = 2 + !face1 = 2, face2 = 2 - Diffusivity_mat(start:finish,start:finish) = & - &Diffusivity_mat(start:finish,start:finish) + & - &add_mat(2,2,:,:) + Diffusivity_mat(start:finish,start:finish) = & + &Diffusivity_mat(start:finish,start:finish) + & + &add_mat(2,2,:,:) - end subroutine local_assembly_cdg_face + end subroutine local_assembly_cdg_face - subroutine local_assembly_masslumped_rt0 + subroutine local_assembly_masslumped_rt0 - if (any(shape(diffusivity_ele)/=(/ 2,2,1 /)) .or. size(diffusivity_mat,1)/=4) then - FLExit("Masslumped RT0 diffusivity scheme only works with P0 fields with P0 diffusivity in 2D.") - end if + if (any(shape(diffusivity_ele)/=(/ 2,2,1 /)) .or. size(diffusivity_mat,1)/=4) then + FLExit("Masslumped RT0 diffusivity scheme only works with P0 fields with P0 diffusivity in 2D.") + end if + + diffusivity_mat=0.0 + + diffusivity_mat(2:4,2:4)=masslumped_rt0_aij(diffusivity_ele(:,:,1), X_val, neigh<0, detwei) + diffusivity_mat(1,:)=-sum(diffusivity_mat(2:4,:),dim=1) + diffusivity_mat(:,1)=-sum(diffusivity_mat(:,2:4),dim=2) + + assert( all(transpose(diffusivity_mat)-diffusivity_mat<1e-10)) - diffusivity_mat=0.0 + end subroutine local_assembly_masslumped_rt0 - diffusivity_mat(2:4,2:4)=masslumped_rt0_aij(diffusivity_ele(:,:,1), X_val, neigh<0, detwei) - diffusivity_mat(1,:)=-sum(diffusivity_mat(2:4,:),dim=1) - diffusivity_mat(:,1)=-sum(diffusivity_mat(:,2:4),dim=2) - assert( all(transpose(diffusivity_mat)-diffusivity_mat<1e-10)) + subroutine local_assembly_masslumped_rt0_circumcentred - end subroutine local_assembly_masslumped_rt0 + real:: cot(1:3) + real:: coef + integer:: i, m, lface_2 + if (any(shape(diffusivity_ele)/=(/ 2,2,1 /)) .or. size(diffusivity_mat,1)/=4) then + FLExit("Masslumped RT0 diffusivity scheme only works with P0 fields with P0 diffusivity in 2D.") + end if + + diffusivity_mat = 0.0 + + do i=1, size(neigh) + ele_2 = neigh(i) + ! compute the cotangent of the angle in ele opposite to the edge between ele and ele_2 + ! we will make use of cot=2*dx/l, where dx is the distance between the circumcentre and + ! the edge, and l is the length of the edge + cot(i) = compute_face_cotangent(x_val, i) + if (ele_2>0) then + face_2 = ele_face(T, ele_2, ele) + lface_2 = local_face_number(T, face_2) + ! the same for the opposite angle inside ele_2, so that + ! cot=2*(dx_ele+dx_ele_2)/l + cot(i) = cot(i) + compute_face_cotangent(ele_val(x,ele_2), lface_2) + end if + end do + + if (minval(cot)<1e-16) then + ! if the distance between adjacent circumcentres is too small (this is relative to the edge length) + ! then we merge this cell with its neighbour. The diffusive fluxes will be equally split + ! between this cell and its neighbour, so that when we add its two associated rows we get the + ! right answer for the merged control volume. This is achieved by adding the fluxes between 'ele' + ! and its other neighbours that we compute here to the neighbour we're merging with. The other + ! half of that flux will be added to this 'ele' when these contributions are calculated from inside + ! the other neighbours + + ! merge with neighbour m (+1 so we get the diffusivity_mat index) + m = 1 + minloc(abs(cot), dim=1) + else + m = 1 + end if - subroutine local_assembly_masslumped_rt0_circumcentred + diffusivity_mat = 0.0 + + do i=1, size(neigh) + ! only when merging, i.e m>1: no fluxes between ele and the to be merged neighbour + if (i+1==m) cycle + ! the diffusive flux integrated over the edge between 'ele' and neighbour i is simply + ! deltaT/dx*l - coef only adds in half of this flux as the exact same contribution will be + ! added when assembling the contributions from neighbour i + coef = diffusivity_ele(1,1,1) / abs(cot(i)) + + ! when merging with a neighbour, these fluxes go to the merged neighbour + diffusivity_mat(m,1+i) = -coef + diffusivity_mat(1+i,m) = -coef + diffusivity_mat(1+i,1+i) = coef + diffusivity_mat(m,m) = diffusivity_mat(m,m) + coef + + ! if this is the boundary flux, we need to add in both halfs of that flux + ! (when merging half of it has gone to the neighbour, and we now add half for ourselves) + if (neigh(i)<=0) then + diffusivity_mat(1,1+i) = diffusivity_mat(1,1+i)-coef + diffusivity_mat(1+i,1) = diffusivity_mat(1+i,1)-coef + diffusivity_mat(1+i,1+i) = diffusivity_mat(1+i,1+i) + coef + diffusivity_mat(1,1) = diffusivity_mat(1,1) + coef + end if + end do - real:: cot(1:3) - real:: coef - integer:: i, m, lface_2 + end subroutine local_assembly_masslumped_rt0_circumcentred + + function compute_face_cotangent(x_ele, lface) result (cot) + ! computes the cotangent of the angle opposite an edge in a triangle + ! (dim x 3) location of the vertices + real, dimension(:,:):: x_ele + ! local face number of the edge + integer, intent(in):: lface + real:: cot + + integer, dimension(1:5), parameter:: cycle=(/ 1, 2, 3, 1, 2 /) + real, dimension(size(x_ele,1)):: edge_prev, edge_next + + ! two opposite edges pointing from opposite vertex to the vertices on this edge + edge_prev = x_ele(:,cycle(lface+1)) - x_ele(:,lface) + edge_next = x_ele(:,cycle(lface+2)) - x_ele(:,lface) + + ! cotangent of opposite angle, given by ratio of dot and cross product of these edges + cot = dot_product(edge_prev, edge_next) / cross_product2(edge_prev, edge_next) + + end function compute_face_cotangent + + end subroutine construct_adv_diff_element_dg + + subroutine construct_adv_diff_interface_dg(ele, face, face_2, & + ni, centre_vec,big_m, rhs, rhs_diff, Grad_T_mat, Div_T_mat, & + & X, T, U_nl,& + & bc_value, bc_type, & + & U_mesh, q_mesh, CDG_switch_in, & + & primal_fluxes_mat, ele2grad_mat,diffusivity, & + & penalty_fluxes_mat, normal_mat, kappa_normal_mat) + + !!< Construct the DG element boundary integrals on the ni-th face of + !!< element ele. + implicit none + + integer, intent(in) :: ele, face, face_2, ni + type(csr_matrix), intent(inout) :: big_m + type(scalar_field), intent(inout) :: rhs, rhs_diff + real, dimension(:,:,:), intent(inout) :: Grad_T_mat, Div_T_mat + ! We pass these additional fields to save on state lookups. + type(vector_field), intent(in) :: X, U_nl + type(vector_field), pointer :: U_mesh + type(scalar_field), intent(in) :: T + !! Mesh of the auxiliary variable in the second order operator. + type(mesh_type), intent(in) :: q_mesh + !! switch for CDG fluxes + logical, intent(inout), optional :: CDG_switch_in + !! Field over the entire surface mesh containing bc values: + type(scalar_field), intent(in):: bc_value + !! Integer array of all surface elements indicating bc type + !! (see above call to get_entire_boundary_condition): + integer, dimension(:), intent(in):: bc_type + real, dimension(:), intent(in) :: centre_vec + !! Computation of primal fluxes + real, intent(in), optional, dimension(:,:,:) :: ele2grad_mat + real, intent(inout), optional, dimension(:,:,:) :: primal_fluxes_mat + type(tensor_field), intent(in), optional :: diffusivity + real, intent(inout), optional, dimension(:,:,:) :: penalty_fluxes_mat + real, intent(inout), optional, dimension(:,:,:) :: normal_mat, & + & kappa_normal_mat + + ! Face objects and numberings. + type(element_type), pointer :: T_shape, T_shape_2, q_shape + integer, dimension(face_loc(T,face)) :: T_face, T_face_l + integer, dimension(face_loc(T,face_2)) :: T_face_2 + integer, dimension(face_loc(U_nl,face)) :: U_face + integer, dimension(face_loc(U_nl,face_2)) :: U_face_2 + ! This has to be a pointer to work around a stupid gcc bug. + integer, dimension(:), pointer :: q_face_l + + ! Note that both sides of the face can be assumed to have the same + ! number of quadrature points. + real, dimension(U_nl%dim, face_ngi(U_nl, face)) :: normal, u_nl_q,& + & u_f_q, u_f2_q, div_u_f_q + logical, dimension(face_ngi(U_nl, face)) :: inflow + real, dimension(face_ngi(U_nl, face)) :: u_nl_q_dotn, income + ! Variable transform times quadrature weights. + real, dimension(face_ngi(T,face)) :: detwei + real, dimension(face_ngi(T,face)) :: inner_advection_integral, outer_advection_integral + + ! Bilinear forms + real, dimension(face_loc(T,face),face_loc(T,face)) :: nnAdvection_out + real, dimension(face_loc(T,face),face_loc(T,face_2)) :: nnAdvection_in + + !Diffusion values on face (used for CDG and IP fluxes) + real, dimension(:,:,:), allocatable :: kappa_gi + + integer :: dim, start, finish + logical :: boundary, dirichlet, neumann + + logical :: do_primal_fluxes + + logical :: p0_vel + + ! Lax-Friedrichs flux parameter + real :: C + + integer :: i + + do_primal_fluxes = present(primal_fluxes_mat) + if(do_primal_fluxes.and..not.present(ele2grad_mat)) then + FLAbort('need ele2grad mat to compute primal fluxes') + end if + if(do_primal_fluxes.and..not.present(diffusivity)) then + FLAbort('Need diffusivity to compute primal fluxes') + end if + if(diffusion_scheme==IP.and..not.do_primal_fluxes) then + FLAbort('Primal fluxes needed for IP') + end if - if (any(shape(diffusivity_ele)/=(/ 2,2,1 /)) .or. size(diffusivity_mat,1)/=4) then - FLExit("Masslumped RT0 diffusivity scheme only works with P0 fields with P0 diffusivity in 2D.") + if(do_primal_fluxes) then + allocate( kappa_gi(Diffusivity%dim(1), Diffusivity%dim(2), & + face_ngi(Diffusivity,face)) ) + kappa_gi = face_val_at_quad(Diffusivity, face) end if - diffusivity_mat = 0.0 - - do i=1, size(neigh) - ele_2 = neigh(i) - ! compute the cotangent of the angle in ele opposite to the edge between ele and ele_2 - ! we will make use of cot=2*dx/l, where dx is the distance between the circumcentre and - ! the edge, and l is the length of the edge - cot(i) = compute_face_cotangent(x_val, i) - if (ele_2>0) then - face_2 = ele_face(T, ele_2, ele) - lface_2 = local_face_number(T, face_2) - ! the same for the opposite angle inside ele_2, so that - ! cot=2*(dx_ele+dx_ele_2)/l - cot(i) = cot(i) + compute_face_cotangent(ele_val(x,ele_2), lface_2) - end if - end do + p0_vel =(element_degree(U_nl,ele)==0) - if (minval(cot)<1e-16) then - ! if the distance between adjacent circumcentres is too small (this is relative to the edge length) - ! then we merge this cell with its neighbour. The diffusive fluxes will be equally split - ! between this cell and its neighbour, so that when we add its two associated rows we get the - ! right answer for the merged control volume. This is achieved by adding the fluxes between 'ele' - ! and its other neighbours that we compute here to the neighbour we're merging with. The other - ! half of that flux will be added to this 'ele' when these contributions are calculated from inside - ! the other neighbours - - ! merge with neighbour m (+1 so we get the diffusivity_mat index) - m = 1 + minloc(abs(cot), dim=1) - else - m = 1 + t_face=face_global_nodes(T, face) + t_face_l=face_local_nodes(T, face) + t_shape=>face_shape(T, face) + + t_face_2=face_global_nodes(T, face_2) + t_shape_2=>face_shape(T, face_2) + + q_face_l=>face_local_nodes(q_mesh, face) + q_shape=>face_shape(q_mesh, face) + + ! Boundary nodes have both faces the same. + boundary=(face==face_2) + dirichlet=.false. + neumann=.false. + if (boundary) then + if (bc_type(face)==BCTYPE_WEAKDIRICHLET) then + dirichlet=.true. + elseif (bc_type(face)==BCTYPE_NEUMANN) then + neumann=.true. + end if end if - diffusivity_mat = 0.0 - - do i=1, size(neigh) - ! only when merging, i.e m>1: no fluxes between ele and the to be merged neighbour - if (i+1==m) cycle - ! the diffusive flux integrated over the edge between 'ele' and neighbour i is simply - ! deltaT/dx*l - coef only adds in half of this flux as the exact same contribution will be - ! added when assembling the contributions from neighbour i - coef = diffusivity_ele(1,1,1) / abs(cot(i)) - - ! when merging with a neighbour, these fluxes go to the merged neighbour - diffusivity_mat(m,1+i) = -coef - diffusivity_mat(1+i,m) = -coef - diffusivity_mat(1+i,1+i) = coef - diffusivity_mat(m,m) = diffusivity_mat(m,m) + coef - - ! if this is the boundary flux, we need to add in both halfs of that flux - ! (when merging half of it has gone to the neighbour, and we now add half for ourselves) - if (neigh(i)<=0) then - diffusivity_mat(1,1+i) = diffusivity_mat(1,1+i)-coef - diffusivity_mat(1+i,1) = diffusivity_mat(1+i,1)-coef - diffusivity_mat(1+i,1+i) = diffusivity_mat(1+i,1+i) + coef - diffusivity_mat(1,1) = diffusivity_mat(1,1) + coef - end if - end do + !---------------------------------------------------------------------- + ! Change of coordinates on face. + !---------------------------------------------------------------------- + + !Unambiguously calculate the normal using the face with the higher + !face number. This is so that the normal is identical on both sides. + call transform_facet_to_physical(X, max(face,face_2), & + & detwei_f=detwei,& + & normal=normal) + if(face_2>face) normal = -normal + + !---------------------------------------------------------------------- + ! Construct element-wise quantities. + !---------------------------------------------------------------------- + + if (include_advection.and.(flux_scheme==UPWIND_FLUX)) then + + ! Advecting velocity at quadrature points. + u_f_q = face_val_at_quad(U_nl, face) + u_f2_q = face_val_at_quad(U_nl, face_2) + U_nl_q=0.5*(u_f_q+u_f2_q) + + if(p0_vel) then + ! A surface integral around the inside of a constant + ! velocity field will always produce zero so it's + ! not possible to evaluate the conservation term + ! with p0 that way. Hence take the average across + ! a face. + div_u_f_q = U_nl_q + else + div_u_f_q = u_f_q + end if - end subroutine local_assembly_masslumped_rt0_circumcentred - - function compute_face_cotangent(x_ele, lface) result (cot) - ! computes the cotangent of the angle opposite an edge in a triangle - ! (dim x 3) location of the vertices - real, dimension(:,:):: x_ele - ! local face number of the edge - integer, intent(in):: lface - real:: cot - - integer, dimension(1:5), parameter:: cycle=(/ 1, 2, 3, 1, 2 /) - real, dimension(size(x_ele,1)):: edge_prev, edge_next - - ! two opposite edges pointing from opposite vertex to the vertices on this edge - edge_prev = x_ele(:,cycle(lface+1)) - x_ele(:,lface) - edge_next = x_ele(:,cycle(lface+2)) - x_ele(:,lface) - - ! cotangent of opposite angle, given by ratio of dot and cross product of these edges - cot = dot_product(edge_prev, edge_next) / cross_product2(edge_prev, edge_next) - - end function compute_face_cotangent - - end subroutine construct_adv_diff_element_dg - - subroutine construct_adv_diff_interface_dg(ele, face, face_2, & - ni, centre_vec,big_m, rhs, rhs_diff, Grad_T_mat, Div_T_mat, & - & X, T, U_nl,& - & bc_value, bc_type, & - & U_mesh, q_mesh, CDG_switch_in, & - & primal_fluxes_mat, ele2grad_mat,diffusivity, & - & penalty_fluxes_mat, normal_mat, kappa_normal_mat) - - !!< Construct the DG element boundary integrals on the ni-th face of - !!< element ele. - implicit none - - integer, intent(in) :: ele, face, face_2, ni - type(csr_matrix), intent(inout) :: big_m - type(scalar_field), intent(inout) :: rhs, rhs_diff - real, dimension(:,:,:), intent(inout) :: Grad_T_mat, Div_T_mat - ! We pass these additional fields to save on state lookups. - type(vector_field), intent(in) :: X, U_nl - type(vector_field), pointer :: U_mesh - type(scalar_field), intent(in) :: T - !! Mesh of the auxiliary variable in the second order operator. - type(mesh_type), intent(in) :: q_mesh - !! switch for CDG fluxes - logical, intent(inout), optional :: CDG_switch_in - !! Field over the entire surface mesh containing bc values: - type(scalar_field), intent(in):: bc_value - !! Integer array of all surface elements indicating bc type - !! (see above call to get_entire_boundary_condition): - integer, dimension(:), intent(in):: bc_type - real, dimension(:), intent(in) :: centre_vec - !! Computation of primal fluxes - real, intent(in), optional, dimension(:,:,:) :: ele2grad_mat - real, intent(inout), optional, dimension(:,:,:) :: primal_fluxes_mat - type(tensor_field), intent(in), optional :: diffusivity - real, intent(inout), optional, dimension(:,:,:) :: penalty_fluxes_mat - real, intent(inout), optional, dimension(:,:,:) :: normal_mat, & - & kappa_normal_mat - - ! Face objects and numberings. - type(element_type), pointer :: T_shape, T_shape_2, q_shape - integer, dimension(face_loc(T,face)) :: T_face, T_face_l - integer, dimension(face_loc(T,face_2)) :: T_face_2 - integer, dimension(face_loc(U_nl,face)) :: U_face - integer, dimension(face_loc(U_nl,face_2)) :: U_face_2 - ! This has to be a pointer to work around a stupid gcc bug. - integer, dimension(:), pointer :: q_face_l - - ! Note that both sides of the face can be assumed to have the same - ! number of quadrature points. - real, dimension(U_nl%dim, face_ngi(U_nl, face)) :: normal, u_nl_q,& - & u_f_q, u_f2_q, div_u_f_q - logical, dimension(face_ngi(U_nl, face)) :: inflow - real, dimension(face_ngi(U_nl, face)) :: u_nl_q_dotn, income - ! Variable transform times quadrature weights. - real, dimension(face_ngi(T,face)) :: detwei - real, dimension(face_ngi(T,face)) :: inner_advection_integral, outer_advection_integral - - ! Bilinear forms - real, dimension(face_loc(T,face),face_loc(T,face)) :: nnAdvection_out - real, dimension(face_loc(T,face),face_loc(T,face_2)) :: nnAdvection_in - - !Diffusion values on face (used for CDG and IP fluxes) - real, dimension(:,:,:), allocatable :: kappa_gi - - integer :: dim, start, finish - logical :: boundary, dirichlet, neumann - - logical :: do_primal_fluxes - - logical :: p0_vel - - ! Lax-Friedrichs flux parameter - real :: C - - integer :: i - - do_primal_fluxes = present(primal_fluxes_mat) - if(do_primal_fluxes.and..not.present(ele2grad_mat)) then - FLAbort('need ele2grad mat to compute primal fluxes') - end if - if(do_primal_fluxes.and..not.present(diffusivity)) then - FLAbort('Need diffusivity to compute primal fluxes') - end if - if(diffusion_scheme==IP.and..not.do_primal_fluxes) then - FLAbort('Primal fluxes needed for IP') - end if - - if(do_primal_fluxes) then - allocate( kappa_gi(Diffusivity%dim(1), Diffusivity%dim(2), & - face_ngi(Diffusivity,face)) ) - kappa_gi = face_val_at_quad(Diffusivity, face) - end if - - p0_vel =(element_degree(U_nl,ele)==0) - - t_face=face_global_nodes(T, face) - t_face_l=face_local_nodes(T, face) - t_shape=>face_shape(T, face) - - t_face_2=face_global_nodes(T, face_2) - t_shape_2=>face_shape(T, face_2) - - q_face_l=>face_local_nodes(q_mesh, face) - q_shape=>face_shape(q_mesh, face) - - ! Boundary nodes have both faces the same. - boundary=(face==face_2) - dirichlet=.false. - neumann=.false. - if (boundary) then - if (bc_type(face)==BCTYPE_WEAKDIRICHLET) then - dirichlet=.true. - elseif (bc_type(face)==BCTYPE_NEUMANN) then - neumann=.true. - end if - end if - - !---------------------------------------------------------------------- - ! Change of coordinates on face. - !---------------------------------------------------------------------- - - !Unambiguously calculate the normal using the face with the higher - !face number. This is so that the normal is identical on both sides. - call transform_facet_to_physical(X, max(face,face_2), & - & detwei_f=detwei,& - & normal=normal) - if(face_2>face) normal = -normal - - !---------------------------------------------------------------------- - ! Construct element-wise quantities. - !---------------------------------------------------------------------- - - if (include_advection.and.(flux_scheme==UPWIND_FLUX)) then - - ! Advecting velocity at quadrature points. - u_f_q = face_val_at_quad(U_nl, face) - u_f2_q = face_val_at_quad(U_nl, face_2) - U_nl_q=0.5*(u_f_q+u_f2_q) - - if(p0_vel) then - ! A surface integral around the inside of a constant - ! velocity field will always produce zero so it's - ! not possible to evaluate the conservation term - ! with p0 that way. Hence take the average across - ! a face. - div_u_f_q = U_nl_q - else - div_u_f_q = u_f_q - end if - - ! Introduce grid velocities in non-linear terms. - if(move_mesh) then - ! here we assume that U_mesh at face is the same as U_mesh at face_2 - ! if it isn't then you're in trouble because your mesh will tear - ! itself apart - U_nl_q=U_nl_q - face_val_at_quad(U_mesh, face) - ! the velocity on the internal face isn't used again so we can - ! modify it directly here... - u_f_q = u_f_q - face_val_at_quad(U_mesh, face) - end if - - u_nl_q_dotn = sum(U_nl_q*normal,1) - - ! Inflow is true if the flow at this gauss point is directed - ! into this element. - inflow = u_nl_q_dotn<0.0 - income = merge(1.0,0.0,inflow) - - !---------------------------------------------------------------------- - ! Construct bilinear forms. - !---------------------------------------------------------------------- - - ! Calculate outflow boundary integral. - ! can anyone think of a way of optimising this more to avoid - ! superfluous operations (i.e. multiplying things by 0 or 1)? - - ! first the integral around the inside of the element - ! (this is the flux *out* of the element) - inner_advection_integral = (1.-income)*u_nl_q_dotn - if(.not.integrate_by_parts_once) then - ! i.e. if we're integrating by parts twice - inner_advection_integral = inner_advection_integral & - - sum(u_f_q*normal,1) - end if - if(integrate_conservation_term_by_parts) then - if(integrate_by_parts_once) then - inner_advection_integral = inner_advection_integral & - - (1.-beta)*sum(div_u_f_q*normal,1) - else - ! i.e. integrating by parts twice + ! Introduce grid velocities in non-linear terms. + if(move_mesh) then + ! here we assume that U_mesh at face is the same as U_mesh at face_2 + ! if it isn't then you're in trouble because your mesh will tear + ! itself apart + U_nl_q=U_nl_q - face_val_at_quad(U_mesh, face) + ! the velocity on the internal face isn't used again so we can + ! modify it directly here... + u_f_q = u_f_q - face_val_at_quad(U_mesh, face) + end if + + u_nl_q_dotn = sum(U_nl_q*normal,1) + + ! Inflow is true if the flow at this gauss point is directed + ! into this element. + inflow = u_nl_q_dotn<0.0 + income = merge(1.0,0.0,inflow) + + !---------------------------------------------------------------------- + ! Construct bilinear forms. + !---------------------------------------------------------------------- + + ! Calculate outflow boundary integral. + ! can anyone think of a way of optimising this more to avoid + ! superfluous operations (i.e. multiplying things by 0 or 1)? + + ! first the integral around the inside of the element + ! (this is the flux *out* of the element) + inner_advection_integral = (1.-income)*u_nl_q_dotn + if(.not.integrate_by_parts_once) then + ! i.e. if we're integrating by parts twice inner_advection_integral = inner_advection_integral & - + beta*sum(div_u_f_q*normal,1) - end if - end if - nnAdvection_out=shape_shape(T_shape, T_shape, & - & inner_advection_integral * detwei) + - sum(u_f_q*normal,1) + end if + if(integrate_conservation_term_by_parts) then + if(integrate_by_parts_once) then + inner_advection_integral = inner_advection_integral & + - (1.-beta)*sum(div_u_f_q*normal,1) + else + ! i.e. integrating by parts twice + inner_advection_integral = inner_advection_integral & + + beta*sum(div_u_f_q*normal,1) + end if + end if + nnAdvection_out=shape_shape(T_shape, T_shape, & + & inner_advection_integral * detwei) - ! now the integral around the outside of the element - ! (this is the flux *in* to the element) - outer_advection_integral = income * u_nl_q_dotn - nnAdvection_in=shape_shape(T_shape, T_shape_2, & - & outer_advection_integral * detwei) + ! now the integral around the outside of the element + ! (this is the flux *in* to the element) + outer_advection_integral = income * u_nl_q_dotn + nnAdvection_in=shape_shape(T_shape, T_shape_2, & + & outer_advection_integral * detwei) - else if (include_advection.and.(flux_scheme==LAX_FRIEDRICHS_FLUX)) then + else if (include_advection.and.(flux_scheme==LAX_FRIEDRICHS_FLUX)) then !!$ if(p0_vel) then !!$ FLAbort("Haven't worked out Lax-Friedrichs for P0 yet") !!$ end if - if(move_mesh) then - FLExit("Haven't worked out Lax-Friedrichs with moving mesh yet") - end if + if(move_mesh) then + FLExit("Haven't worked out Lax-Friedrichs with moving mesh yet") + end if - if (X%mesh%shape%degree/=1) then - FLExit("Haven't worked out Lax-Friedrichs for bendy elements yet") - end if + if (X%mesh%shape%degree/=1) then + FLExit("Haven't worked out Lax-Friedrichs for bendy elements yet") + end if - if(integrate_conservation_term_by_parts) then - FLExit("Haven't worked out integration of conservation for Lax-Friedrichs.") - end if + if(integrate_conservation_term_by_parts) then + FLExit("Haven't worked out integration of conservation for Lax-Friedrichs.") + end if - if(.not.integrate_by_parts_once) then - FLExit("Haven't worked out integration by parts twice for Lax-Friedrichs.") - end if + if(.not.integrate_by_parts_once) then + FLExit("Haven't worked out integration by parts twice for Lax-Friedrichs.") + end if - u_face=face_global_nodes(U_nl, face) - u_face_2=face_global_nodes(U_nl, face_2) + u_face=face_global_nodes(U_nl, face) + u_face_2=face_global_nodes(U_nl, face_2) - C=0.0 - do i=1,size(u_face) - C=max(C,abs(dot_product(normal(:,1),node_val(U_nl,u_face(i))))) - end do - do i=1,size(u_face_2) - C=max(C,abs(dot_product(normal(:,1),node_val(U_nl,u_face_2(i))))) - end do + C=0.0 + do i=1,size(u_face) + C=max(C,abs(dot_product(normal(:,1),node_val(U_nl,u_face(i))))) + end do + do i=1,size(u_face_2) + C=max(C,abs(dot_product(normal(:,1),node_val(U_nl,u_face_2(i))))) + end do - ! Velocity over interior face: - inner_advection_integral=& + ! Velocity over interior face: + inner_advection_integral=& 0.5*(sum(face_val_at_quad(U_nl, face)*normal,1)+C) - nnAdvection_out=shape_shape(T_shape, T_shape, & - & inner_advection_integral * detwei) + nnAdvection_out=shape_shape(T_shape, T_shape, & + & inner_advection_integral * detwei) - ! Velocity over exterior face: - outer_advection_integral=& + ! Velocity over exterior face: + outer_advection_integral=& 0.5*(sum(face_val_at_quad(U_nl, face_2)*normal,1)-C) - nnAdvection_in=shape_shape(T_shape, T_shape_2, & - & outer_advection_integral * detwei) - - - end if - if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then - - if (continuity(T)<0) then - ! Boundary term in grad_U. - ! / - ! | q, u, normal dx - ! / - start=ele_loc(T, ele)+(ni-1)*face_loc(T, face_2)+1 - finish=start+face_loc(T, face_2)-1 - - select case (diffusion_scheme) - case (ARBITRARY_UPWIND) - call arbitrary_upwind_diffusion - case (BASSI_REBAY) - call bassi_rebay_diffusion - case (IP) - if(.not.remove_primal_fluxes) call primal_fluxes - if(.not.remove_penalty_fluxes) call interior_penalty - case (CDG) - call primal_fluxes - if(.not.remove_penalty_fluxes) call interior_penalty - call get_normal_mat - end select - end if - end if - - !---------------------------------------------------------------------- - ! Perform global assembly. - !---------------------------------------------------------------------- - - ! Insert advection in matrix. - if (include_advection) then - - ! Outflow boundary integral. - call addto(big_M, T_face, T_face,& + nnAdvection_in=shape_shape(T_shape, T_shape_2, & + & outer_advection_integral * detwei) + + + end if + if (include_diffusion.or.have_buoyancy_adjustment_by_vertical_diffusion) then + + if (continuity(T)<0) then + ! Boundary term in grad_U. + ! / + ! | q, u, normal dx + ! / + start=ele_loc(T, ele)+(ni-1)*face_loc(T, face_2)+1 + finish=start+face_loc(T, face_2)-1 + + select case (diffusion_scheme) + case (ARBITRARY_UPWIND) + call arbitrary_upwind_diffusion + case (BASSI_REBAY) + call bassi_rebay_diffusion + case (IP) + if(.not.remove_primal_fluxes) call primal_fluxes + if(.not.remove_penalty_fluxes) call interior_penalty + case (CDG) + call primal_fluxes + if(.not.remove_penalty_fluxes) call interior_penalty + call get_normal_mat + end select + end if + end if + + !---------------------------------------------------------------------- + ! Perform global assembly. + !---------------------------------------------------------------------- + + ! Insert advection in matrix. + if (include_advection) then + + ! Outflow boundary integral. + call addto(big_M, T_face, T_face,& nnAdvection_out*dt*theta) - if (.not.dirichlet) then - ! Inflow boundary integral. - call addto(big_M, T_face, T_face_2,& + if (.not.dirichlet) then + ! Inflow boundary integral. + call addto(big_M, T_face, T_face_2,& nnAdvection_in*dt*theta) - end if + end if - ! Insert advection in RHS. + ! Insert advection in RHS. - if (.not.dirichlet) then - ! For interior interfaces this is the upwinding term. For a Neumann - ! boundary it's necessary to apply downwinding here to maintain the - ! surface integral. Fortunately, since face_2==face for a boundary - ! this is automagic. + if (.not.dirichlet) then + ! For interior interfaces this is the upwinding term. For a Neumann + ! boundary it's necessary to apply downwinding here to maintain the + ! surface integral. Fortunately, since face_2==face for a boundary + ! this is automagic. - if (.not.semi_discrete) then - call addto(RHS, T_face, & - ! Outflow boundary integral. + if (.not.semi_discrete) then + call addto(RHS, T_face, & + ! Outflow boundary integral. -matmul(nnAdvection_out,face_val(T,face))& - ! Inflow boundary integral. + ! Inflow boundary integral. -matmul(nnAdvection_in,face_val(T,face_2))) - end if + end if - else + else - ! Inflow and outflow of Dirichlet value. - call addto(RHS, T_face, & + ! Inflow and outflow of Dirichlet value. + call addto(RHS, T_face, & -matmul(nnAdvection_in,& ele_val(bc_value, face))) - if(.not.semi_discrete) then - ! The interior integral is still interior! - call addto(RHS, T_face, & + if(.not.semi_discrete) then + ! The interior integral is still interior! + call addto(RHS, T_face, & -matmul(nnAdvection_out,face_val(T,face))) - end if + end if - end if + end if - end if + end if - ! Add non-zero contributions from Neumann boundary conditions (if present) - if (neumann) then - call addto(RHS_diff, T_face, shape_rhs(T_shape, detwei * ele_val_at_quad(bc_value, face))) - end if + ! Add non-zero contributions from Neumann boundary conditions (if present) + if (neumann) then + call addto(RHS_diff, T_face, shape_rhs(T_shape, detwei * ele_val_at_quad(bc_value, face))) + end if - contains + contains - subroutine arbitrary_upwind_diffusion + subroutine arbitrary_upwind_diffusion - !! Arbitrary upwinding scheme. - do dim=1,mesh_dim(T) - if (normal(dim,1)>0) then - ! Internal face. - Grad_T_mat(dim, q_face_l, T_face_l)=& + !! Arbitrary upwinding scheme. + do dim=1,mesh_dim(T) + if (normal(dim,1)>0) then + ! Internal face. + Grad_T_mat(dim, q_face_l, T_face_l)=& Grad_T_mat(dim, q_face_l, T_face_l) & +shape_shape(q_shape, T_shape, detwei*normal(dim,:)) - ! External face. Note the sign change which is caused by the - ! divergence matrix being constructed in transpose. - Div_T_mat(dim, q_face_l, start:finish)=& + ! External face. Note the sign change which is caused by the + ! divergence matrix being constructed in transpose. + Div_T_mat(dim, q_face_l, start:finish)=& -shape_shape(q_shape, T_shape_2, detwei*normal(dim,:)) - ! Internal face. - Div_T_mat(dim, q_face_l, T_face_l)=& + ! Internal face. + Div_T_mat(dim, q_face_l, T_face_l)=& Div_T_mat(dim, q_face_l, T_face_l) & +shape_shape(q_shape, T_shape, detwei*normal(dim,:)) - else - ! External face. - Grad_T_mat(dim, q_face_l, start:finish)=& + else + ! External face. + Grad_T_mat(dim, q_face_l, start:finish)=& +shape_shape(q_shape, T_shape_2, detwei*normal(dim,:)) - end if - end do + end if + end do - end subroutine arbitrary_upwind_diffusion + end subroutine arbitrary_upwind_diffusion - subroutine bassi_rebay_diffusion + subroutine bassi_rebay_diffusion - do dim=1,mesh_dim(T) + do dim=1,mesh_dim(T) - if(.not.boundary) then - ! Internal face. - Grad_T_mat(dim, q_face_l, T_face_l)=& - Grad_T_mat(dim, q_face_l, T_face_l) & - +0.5*shape_shape(q_shape, T_shape, detwei*normal(dim,:)) + if(.not.boundary) then + ! Internal face. + Grad_T_mat(dim, q_face_l, T_face_l)=& + Grad_T_mat(dim, q_face_l, T_face_l) & + +0.5*shape_shape(q_shape, T_shape, detwei*normal(dim,:)) - ! External face. - Grad_T_mat(dim, q_face_l, start:finish)=& - +0.5*shape_shape(q_shape, T_shape_2, detwei*normal(dim,:)) + ! External face. + Grad_T_mat(dim, q_face_l, start:finish)=& + +0.5*shape_shape(q_shape, T_shape_2, detwei*normal(dim,:)) - else - ! Boundary case. Put the whole integral in the external bit. + else + ! Boundary case. Put the whole integral in the external bit. - ! External face. - Grad_T_mat(dim, q_face_l, start:finish)=& - +shape_shape(q_shape, T_shape_2, detwei*normal(dim,:)) + ! External face. + Grad_T_mat(dim, q_face_l, start:finish)=& + +shape_shape(q_shape, T_shape_2, detwei*normal(dim,:)) - end if - end do + end if + end do - end subroutine bassi_rebay_diffusion + end subroutine bassi_rebay_diffusion - subroutine get_normal_mat - !!< We assemble - !!< \int_e N_i N_j n dS - !!< where n is the normal - !!< indices are (dim1, loc1, loc2) + subroutine get_normal_mat + !!< We assemble + !!< \int_e N_i N_j n dS + !!< where n is the normal + !!< indices are (dim1, loc1, loc2) - integer :: d1,d2 + integer :: d1,d2 - normal_mat = shape_shape_vector(T_shape,T_shape,detwei,normal) + normal_mat = shape_shape_vector(T_shape,T_shape,detwei,normal) - !!< We assemble - !!< \int_e N_i N_j kappa.n dS - !!< where n is the normal - !!< indices are (dim1, loc1, loc2) + !!< We assemble + !!< \int_e N_i N_j kappa.n dS + !!< where n is the normal + !!< indices are (dim1, loc1, loc2) - kappa_normal_mat = 0 - do d1 = 1, mesh_dim(T) - do d2 = 1, mesh_dim(T) - kappa_normal_mat(d1,:,:) = kappa_normal_mat(d1,:,:) + & - & shape_shape(T_shape,T_shape,detwei* & - & kappa_gi(d1,d2,:)*normal(d2,:)) + kappa_normal_mat = 0 + do d1 = 1, mesh_dim(T) + do d2 = 1, mesh_dim(T) + kappa_normal_mat(d1,:,:) = kappa_normal_mat(d1,:,:) + & + & shape_shape(T_shape,T_shape,detwei* & + & kappa_gi(d1,d2,:)*normal(d2,:)) + end do end do - end do - end subroutine get_normal_mat + end subroutine get_normal_mat - subroutine primal_fluxes + subroutine primal_fluxes - !!< Notes for primal fluxes which are present in the interior penalty - !!< and CDG methods (and, I believe, the LDG method when written in - !! primal form) + !!< Notes for primal fluxes which are present in the interior penalty + !!< and CDG methods (and, I believe, the LDG method when written in + !! primal form) - !!< We assemble + !!< We assemble - !!< -Int_e [u]{kappa grad v} + [v]{kappa grad u} + !!< -Int_e [u]{kappa grad v} + [v]{kappa grad u} - !!< = -Int_e 1/2(u^+n^+ + u^-n^-).(kappa^+ grad v^+ + kappa^- grad v^-) - !!< -Int_e 1/2(v^+n^+ + v^-n^-).(kappa^+ grad u^+ + kappa^- grad u^-) + !!< = -Int_e 1/2(u^+n^+ + u^-n^-).(kappa^+ grad v^+ + kappa^- grad v^-) + !!< -Int_e 1/2(v^+n^+ + v^-n^-).(kappa^+ grad u^+ + kappa^- grad u^-) - !!< Where + is the ele side, and - is the ele_2 side, and e is the edge + !!< Where + is the ele side, and - is the ele_2 side, and e is the edge - !! + !!< C_{12} = either (1/2)n^+ or (1/2)n^- + !!< Take (1/2)n^+ if switch_g . n^+> - !!0 and plus otherwise + !!< where we take the minus if switch_g.n^+>0 and plus otherwise - !!< Note that this means that it cancels the primal term if - !!0) - if(CDG_switch_in) flux_factor = 1.0 - else - flux_factor = 0.5 - CDG_switch_in = .true. - end if + if(diffusion_scheme==CDG) then + flux_factor = 0.0 + CDG_switch_in = (sum(switch_g(1:mesh_dim(T))*sum(normal,2)/size(normal,2))>0) + if(CDG_switch_in) flux_factor = 1.0 + else + flux_factor = 0.5 + CDG_switch_in = .true. + end if - do d1 = 1, mesh_dim(T) - do d2 = 1, mesh_dim(T) - ! -Int_e 1/2 (u^+ - u^-)n^+.kappa^+ grad v^+ - if(.not.boundary) then - ! Internal face. - if(CDG_switch_in) then - primal_fluxes_mat(1,:,:) =& - primal_fluxes_mat(1,:,:)& - -flux_factor*matmul( & - shape_shape(T_shape,T_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,T_face_l,:)) + do d1 = 1, mesh_dim(T) + do d2 = 1, mesh_dim(T) + ! -Int_e 1/2 (u^+ - u^-)n^+.kappa^+ grad v^+ + if(.not.boundary) then + ! Internal face. + if(CDG_switch_in) then + primal_fluxes_mat(1,:,:) =& + primal_fluxes_mat(1,:,:)& + -flux_factor*matmul( & + shape_shape(T_shape,T_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,T_face_l,:)) + + ! External face. + primal_fluxes_mat(2,:,:) =& + primal_fluxes_mat(2,:,:)& + +flux_factor*matmul( & + shape_shape(T_shape,T_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,T_face_l,:)) + end if + else + !If a Dirichlet boundary, we add these terms, otherwise not. - ! External face. + !we do the entire integral on the inside face + primal_fluxes_mat(1,:,:) =& + primal_fluxes_mat(1,:,:)& + -matmul( & + shape_shape(T_shape,T_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,T_face_l,:)) + + !There is also a corresponding boundary condition integral + !on the RHS primal_fluxes_mat(2,:,:) =& - primal_fluxes_mat(2,:,:)& - +flux_factor*matmul( & - shape_shape(T_shape,T_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,T_face_l,:)) + primal_fluxes_mat(2,:,:)& + +matmul( & + shape_shape(T_shape,T_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,T_face_l,:)) end if - else - !If a Dirichlet boundary, we add these terms, otherwise not. - - !we do the entire integral on the inside face - primal_fluxes_mat(1,:,:) =& - primal_fluxes_mat(1,:,:)& - -matmul( & - shape_shape(T_shape,T_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,T_face_l,:)) - - !There is also a corresponding boundary condition integral - !on the RHS - primal_fluxes_mat(2,:,:) =& - primal_fluxes_mat(2,:,:)& - +matmul( & - shape_shape(T_shape,T_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,T_face_l,:)) - end if + end do end do - end do - end subroutine primal_fluxes + end subroutine primal_fluxes - subroutine interior_penalty + subroutine interior_penalty - !!< We assemble + !!< We assemble - !!< Int_e [u][v] + !!< Int_e [u][v] - !!< = Int_e C(u^+n^+ + u^-n^-).(v^+n^+ + v^-n^-) + !!< = Int_e C(u^+n^+ + u^-n^-).(v^+n^+ + v^-n^-) - !!< Where + is the ele side, and - is the ele_2 side, and e is the edge - !!< and C is the penalty parameter + !!< Where + is the ele side, and - is the ele_2 side, and e is the edge + !!< and C is the penalty parameter - !!< We are only storing trial functions from this element, so - !!< will assemble the u^+ parts only, the u^- parts will be done - !!< from the other side + !!< We are only storing trial functions from this element, so + !!< will assemble the u^+ parts only, the u^- parts will be done + !!< from the other side - !!extract_scalar_field(state, field_name) + if((continuity(T)>=0).or.(element_degree(T,1)/=0)) then + FLExit("FV advection-diffusion requires a discontinuous P0 mesh.") + end if + + t_old=>extract_scalar_field(state, "Old"//field_name) + + ! Reset T to value at the beginning of the timestep. + call set(t, t_old) + + sparsity => get_csr_sparsity_firstorder(state, t%mesh, t%mesh) - !! Name of the field to be solved for. - character(len=*), intent(in) :: field_name - !! Collection of fields defining system state. - type(state_type), intent(inout) :: state + call allocate(matrix, sparsity, name = trim(field_name)//"Matrix") + call allocate(rhs, t%mesh, name = trim(field_name)//"RHS") - !! Tracer to be solved for. - type(scalar_field), pointer :: T, T_old - !! Change in T over one timestep. - type(scalar_field) :: delta_T - !! System matrix. - type(csr_matrix) :: matrix - !! Right hand side vector. - type(scalar_field) :: rhs - !! Sparsity of advection_diffusion matrix - type(csr_sparsity), pointer :: sparsity + call allocate(delta_t, t%mesh, "Delta"//trim(field_name)) + call zero(delta_t) - ewrite(1,*) 'In solve_advection_diffusion_fv' + call get_option("/timestepping/timestep", dt) - t=>extract_scalar_field(state, field_name) - if((continuity(T)>=0).or.(element_degree(T,1)/=0)) then - FLExit("FV advection-diffusion requires a discontinuous P0 mesh.") - end if + call assemble_advection_diffusion_fv(t, matrix, rhs, state) - t_old=>extract_scalar_field(state, "Old"//field_name) + call petsc_solve(delta_t, matrix, rhs, state, option_path = trim(t%option_path)) - ! Reset T to value at the beginning of the timestep. - call set(t, t_old) + ewrite_minmax(delta_t) - sparsity => get_csr_sparsity_firstorder(state, t%mesh, t%mesh) + call addto(t, delta_t, dt) - call allocate(matrix, sparsity, name = trim(field_name)//"Matrix") - call allocate(rhs, t%mesh, name = trim(field_name)//"RHS") + ewrite_minmax(t) - call allocate(delta_t, t%mesh, "Delta"//trim(field_name)) - call zero(delta_t) + call deallocate(matrix) + call deallocate(rhs) + call deallocate(delta_t) - call get_option("/timestepping/timestep", dt) + ewrite(1,*) 'Exiting solve_advection_diffusion_fv' - call assemble_advection_diffusion_fv(t, matrix, rhs, state) + end subroutine solve_advection_diffusion_fv - call petsc_solve(delta_t, matrix, rhs, state, option_path = trim(t%option_path)) + subroutine assemble_advection_diffusion_fv(t, matrix, rhs, state) - ewrite_minmax(delta_t) + type(scalar_field), intent(inout) :: t + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(state_type), intent(inout) :: state - call addto(t, delta_t, dt) + type(vector_field), pointer :: coordinate, & + old_coordinate, new_coordinate, & + grid_velocity + type(vector_field) :: t_coordinate + type(scalar_field), pointer :: source, absorption + type(tensor_field), pointer :: diffusivity - ewrite_minmax(t) + integer :: stat - call deallocate(matrix) - call deallocate(rhs) - call deallocate(delta_t) + !! Coloring data structures for OpenMP parallization + type(integer_set), dimension(:), pointer :: colours + integer :: clr, nnid, len, ele + integer :: thread_num - ewrite(1,*) 'Exiting solve_advection_diffusion_fv' + ewrite(1,*) "In assemble_advection_diffusion_fv" - end subroutine solve_advection_diffusion_fv + coordinate => extract_vector_field(state, "Coordinate") + assert(coordinate%dim == mesh_dim(t)) + assert(ele_count(coordinate) == ele_count(t)) + ! Source + source => extract_scalar_field(state, trim(t%name)//"Source", stat = stat) + have_source = stat == 0 + if(have_source) then + assert(mesh_dim(source) == mesh_dim(t)) + assert(ele_count(source) == ele_count(t)) - subroutine assemble_advection_diffusion_fv(t, matrix, rhs, state) + add_src_directly_to_rhs = have_option(trim(source%option_path)//'/diagnostic/add_directly_to_rhs') - type(scalar_field), intent(inout) :: t - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(state_type), intent(inout) :: state + if (add_src_directly_to_rhs) then + ewrite(2, *) "Adding Source field directly to the right hand side" + assert(node_count(source) == node_count(t)) + end if + + ewrite_minmax(source) + else + ewrite(2,*) 'No source' + + add_src_directly_to_rhs = .false. + end if - type(vector_field), pointer :: coordinate, & - old_coordinate, new_coordinate, & - grid_velocity - type(vector_field) :: t_coordinate - type(scalar_field), pointer :: source, absorption - type(tensor_field), pointer :: diffusivity + ! Absorption + absorption => extract_scalar_field(state, trim(t%name) // "Absorption", stat = stat) + have_absorption = stat == 0 + if(have_absorption) then + assert(mesh_dim(absorption) == mesh_dim(t)) + assert(ele_count(absorption) == ele_count(t)) - integer :: stat + ewrite_minmax(absorption) + else + ewrite(2, *) "No absorption" + end if - !! Coloring data structures for OpenMP parallization - type(integer_set), dimension(:), pointer :: colours - integer :: clr, nnid, len, ele - integer :: thread_num + ! Diffusivity + diffusivity => extract_tensor_field(state, trim(t%name) // "Diffusivity", stat = stat) + have_diffusivity = stat == 0 + if(have_diffusivity) then + assert(all(diffusivity%dim == mesh_dim(t))) + assert(ele_count(diffusivity) == ele_count(t)) + + isotropic_diffusivity = option_count(complete_field_path(diffusivity%option_path)) & + & == option_count(trim(complete_field_path(diffusivity%option_path)) // "/value/isotropic") + + if(isotropic_diffusivity) then + ewrite(2, *) "Isotropic diffusivity" + assert(all(diffusivity%dim > 0)) + ewrite_minmax(diffusivity%val(1, 1, :)) + else + ewrite_minmax(diffusivity) + end if + else + isotropic_diffusivity = .false. + ewrite(2, *) "No diffusivity" + end if - ewrite(1,*) "In assemble_advection_diffusion_fv" + ! field coordinate + if(have_diffusivity) then + t_coordinate = get_coordinate_field(state, t%mesh) + else + t_coordinate = coordinate + call incref(t_coordinate) + end if - coordinate => extract_vector_field(state, "Coordinate") - assert(coordinate%dim == mesh_dim(t)) - assert(ele_count(coordinate) == ele_count(t)) - ! Source - source => extract_scalar_field(state, trim(t%name)//"Source", stat = stat) - have_source = stat == 0 - if(have_source) then - assert(mesh_dim(source) == mesh_dim(t)) - assert(ele_count(source) == ele_count(t)) + call get_option(trim(t%option_path) // "/prognostic/temporal_discretisation/theta", theta) + assert(theta >= 0.0 .and. theta <= 1.0) + ewrite(2, *) "Theta = ", theta + dt_theta = dt*theta - add_src_directly_to_rhs = have_option(trim(source%option_path)//'/diagnostic/add_directly_to_rhs') + have_advection = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/finite_volume/advection_terms/exclude_advection_terms") + if(have_advection) then + FLExit("Including advection not currently supported with FV") + ewrite(2, *) "Including advection" + else + ewrite(2, *) "Excluding advection" + end if - if (add_src_directly_to_rhs) then - ewrite(2, *) "Adding Source field directly to the right hand side" - assert(node_count(source) == node_count(t)) + have_mass = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/finite_volume/mass_terms/exclude_mass_terms") + if(have_mass) then + ewrite(2, *) "Including mass" + else + ewrite(2, *) "Excluding mass" end if - ewrite_minmax(source) - else - ewrite(2,*) 'No source' - - add_src_directly_to_rhs = .false. - end if - - ! Absorption - absorption => extract_scalar_field(state, trim(t%name) // "Absorption", stat = stat) - have_absorption = stat == 0 - if(have_absorption) then - assert(mesh_dim(absorption) == mesh_dim(t)) - assert(ele_count(absorption) == ele_count(t)) - - ewrite_minmax(absorption) - else - ewrite(2, *) "No absorption" - end if - - ! Diffusivity - diffusivity => extract_tensor_field(state, trim(t%name) // "Diffusivity", stat = stat) - have_diffusivity = stat == 0 - if(have_diffusivity) then - assert(all(diffusivity%dim == mesh_dim(t))) - assert(ele_count(diffusivity) == ele_count(t)) - - isotropic_diffusivity = option_count(complete_field_path(diffusivity%option_path)) & - & == option_count(trim(complete_field_path(diffusivity%option_path)) // "/value/isotropic") - - if(isotropic_diffusivity) then - ewrite(2, *) "Isotropic diffusivity" - assert(all(diffusivity%dim > 0)) - ewrite_minmax(diffusivity%val(1, 1, :)) + ! are we moving the mesh? + move_mesh = (have_option("/mesh_adaptivity/mesh_movement") .and. have_mass) + if(move_mesh) then + FLExit("Moving the mesh not currently supported with FV") + ewrite(2,*) "Moving the mesh" + old_coordinate => extract_vector_field(state, "OldCoordinate") + new_coordinate => extract_vector_field(state, "IteratedCoordinate") + + ! Grid velocity + grid_velocity => extract_vector_field(state, "GridVelocity") + assert(grid_velocity%dim == mesh_dim(t)) + assert(ele_count(grid_velocity) == ele_count(t)) + + ewrite(2, *) "Grid velocity:" + ewrite_minmax(grid_velocity) else - ewrite_minmax(diffusivity) + ewrite(2,*) "Not moving the mesh" end if - else - isotropic_diffusivity = .false. - ewrite(2, *) "No diffusivity" - end if - - ! field coordinate - if(have_diffusivity) then - t_coordinate = get_coordinate_field(state, t%mesh) - else - t_coordinate = coordinate - call incref(t_coordinate) - end if - - call get_option(trim(t%option_path) // "/prognostic/temporal_discretisation/theta", theta) - assert(theta >= 0.0 .and. theta <= 1.0) - ewrite(2, *) "Theta = ", theta - dt_theta = dt*theta - - have_advection = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/finite_volume/advection_terms/exclude_advection_terms") - if(have_advection) then - FLExit("Including advection not currently supported with FV") - ewrite(2, *) "Including advection" - else - ewrite(2, *) "Excluding advection" - end if - - have_mass = .not. have_option(trim(t%option_path) // "/prognostic/spatial_discretisation/finite_volume/mass_terms/exclude_mass_terms") - if(have_mass) then - ewrite(2, *) "Including mass" - else - ewrite(2, *) "Excluding mass" - end if - - ! are we moving the mesh? - move_mesh = (have_option("/mesh_adaptivity/mesh_movement") .and. have_mass) - if(move_mesh) then - FLExit("Moving the mesh not currently supported with FV") - ewrite(2,*) "Moving the mesh" - old_coordinate => extract_vector_field(state, "OldCoordinate") - new_coordinate => extract_vector_field(state, "IteratedCoordinate") - - ! Grid velocity - grid_velocity => extract_vector_field(state, "GridVelocity") - assert(grid_velocity%dim == mesh_dim(t)) - assert(ele_count(grid_velocity) == ele_count(t)) - - ewrite(2, *) "Grid velocity:" - ewrite_minmax(grid_velocity) - else - ewrite(2,*) "Not moving the mesh" - end if - - call zero(matrix) - call zero(rhs) + + call zero(matrix) + call zero(rhs) #ifdef _OPENMP - cache_valid = prepopulate_transform_cache(coordinate) + cache_valid = prepopulate_transform_cache(coordinate) #endif - call get_mesh_colouring(state, T%mesh, COLOURING_DG1, colours) + call get_mesh_colouring(state, T%mesh, COLOURING_DG1, colours) - call profiler_tic(t, "advection_diffusion_fv_loop") + call profiler_tic(t, "advection_diffusion_fv_loop") - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(clr, len, nnid, ele, thread_num) + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(clr, len, nnid, ele, thread_num) #ifdef _OPENMP - thread_num = omp_get_thread_num() + thread_num = omp_get_thread_num() #else - thread_num=0 + thread_num=0 #endif - colour_loop: do clr = 1, size(colours) - len = key_count(colours(clr)) - !$OMP DO SCHEDULE(STATIC) - element_loop: do nnid = 1, len - ele = fetch(colours(clr), nnid) - call assemble_advection_diffusion_element_fv(ele, t, matrix, rhs, & - coordinate, t_coordinate, & - source, absorption, diffusivity) - end do element_loop - !$OMP END DO + colour_loop: do clr = 1, size(colours) + len = key_count(colours(clr)) + !$OMP DO SCHEDULE(STATIC) + element_loop: do nnid = 1, len + ele = fetch(colours(clr), nnid) + call assemble_advection_diffusion_element_fv(ele, t, matrix, rhs, & + coordinate, t_coordinate, & + source, absorption, diffusivity) + end do element_loop + !$OMP END DO - end do colour_loop - !$OMP END PARALLEL + end do colour_loop + !$OMP END PARALLEL - call profiler_toc(t, "advection_diffusion_fv_loop") + call profiler_toc(t, "advection_diffusion_fv_loop") - ! Add the source directly to the rhs if required - ! which must be included before dirichlet BC's. - if (add_src_directly_to_rhs) call addto(rhs, source) + ! Add the source directly to the rhs if required + ! which must be included before dirichlet BC's. + if (add_src_directly_to_rhs) call addto(rhs, source) - ewrite(2, *) "Applying strong Dirichlet boundary conditions" - call apply_dirichlet_conditions(matrix, rhs, t, dt) + ewrite(2, *) "Applying strong Dirichlet boundary conditions" + call apply_dirichlet_conditions(matrix, rhs, t, dt) - ewrite_minmax(rhs) - call deallocate(t_coordinate) + ewrite_minmax(rhs) + call deallocate(t_coordinate) - ewrite(1,*) "Exiting assemble_advection_diffusion_fv" + ewrite(1,*) "Exiting assemble_advection_diffusion_fv" - end subroutine assemble_advection_diffusion_fv + end subroutine assemble_advection_diffusion_fv - subroutine assemble_advection_diffusion_element_fv(ele, t, matrix, rhs, & - coordinate, t_coordinate, & - source, absorption, diffusivity) + subroutine assemble_advection_diffusion_element_fv(ele, t, matrix, rhs, & + coordinate, t_coordinate, & + source, absorption, diffusivity) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: t - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: coordinate, t_coordinate - type(scalar_field), intent(in) :: source - type(scalar_field), intent(in) :: absorption - type(tensor_field), intent(in) :: diffusivity + integer, intent(in) :: ele + type(scalar_field), intent(in) :: t + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: coordinate, t_coordinate + type(scalar_field), intent(in) :: source + type(scalar_field), intent(in) :: absorption + type(tensor_field), intent(in) :: diffusivity - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(t, ele)) :: detwei - type(element_type), pointer :: t_shape + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(t, ele)) :: detwei + type(element_type), pointer :: t_shape - ! What we will be adding to the matrix and RHS - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(ele_and_faces_loc(t, ele)) :: rhs_addto - real, dimension(ele_and_faces_loc(t, ele), ele_and_faces_loc(t, ele)) :: matrix_addto - integer, dimension(ele_and_faces_loc(t,ele)) :: local_glno + ! What we will be adding to the matrix and RHS - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(ele_and_faces_loc(t, ele)) :: rhs_addto + real, dimension(ele_and_faces_loc(t, ele), ele_and_faces_loc(t, ele)) :: matrix_addto + integer, dimension(ele_and_faces_loc(t,ele)) :: local_glno - integer, dimension(:), pointer :: neigh, x_neigh - integer :: loc, ni, ele_2, face, face_2, start, finish + integer, dimension(:), pointer :: neigh, x_neigh + integer :: loc, ni, ele_2, face, face_2, start, finish - assert(element_degree(t,ele)==0) - t_shape => ele_shape(t, ele) + assert(element_degree(t,ele)==0) + t_shape => ele_shape(t, ele) - loc = ele_loc(t, ele) ! how many nodes belong to this element... should be 1 + loc = ele_loc(t, ele) ! how many nodes belong to this element... should be 1 - element_nodes => ele_nodes(t, ele) - local_glno(:loc)=element_nodes + element_nodes => ele_nodes(t, ele) + local_glno(:loc)=element_nodes - matrix_addto = 0.0 - rhs_addto = 0.0 + matrix_addto = 0.0 + rhs_addto = 0.0 - if(have_mass.or.have_source.or.have_absorption) then - call transform_to_physical(coordinate, ele, detwei=detwei) - end if + if(have_mass.or.have_source.or.have_absorption) then + call transform_to_physical(coordinate, ele, detwei=detwei) + end if - ! Mass - if(have_mass) call add_mass_element_fv(ele, t_shape, t, detwei, matrix_addto(:loc,:loc)) + ! Mass + if(have_mass) call add_mass_element_fv(ele, t_shape, t, detwei, matrix_addto(:loc,:loc)) - ! Absorption - if(have_absorption) call add_absorption_element_fv(ele, t_shape, t, absorption, detwei, matrix_addto(:loc,:loc), rhs_addto(:loc)) + ! Absorption + if(have_absorption) call add_absorption_element_fv(ele, t_shape, t, absorption, detwei, matrix_addto(:loc,:loc), rhs_addto(:loc)) - ! Source - if(have_source .and. (.not. add_src_directly_to_rhs)) then - call add_source_element_fv(ele, t_shape, t, source, detwei, rhs_addto(:loc)) - end if + ! Source + if(have_source .and. (.not. add_src_directly_to_rhs)) then + call add_source_element_fv(ele, t_shape, t, source, detwei, rhs_addto(:loc)) + end if - if(have_diffusivity.or.have_advection) then + if(have_diffusivity.or.have_advection) then - ! this part of assembly is over faces of elements so it needs - ! to know about boundary conditions + ! this part of assembly is over faces of elements so it needs + ! to know about boundary conditions ! allocate(t_bc_types(surface_element_count(t))) ! call get_entire_boundary_condition(t, (/ & ! "neumann ", & ! "weakdirichlet", & ! "internal "/), t_bc, t_bc_types) - neigh=>ele_neigh(t, ele) - x_neigh => ele_neigh(coordinate, ele) + neigh=>ele_neigh(t, ele) + x_neigh => ele_neigh(coordinate, ele) - start = size(element_nodes)+1 + start = size(element_nodes)+1 - neighboorloop: do ni = 1, size(neigh) + neighboorloop: do ni = 1, size(neigh) - ele_2=neigh(ni) - face=ele_face(t, ele, ele_2) - if(ele_2>0) then - face_2=ele_face(t, ele_2, ele) - else - ! external face - face_2 = face - end if + ele_2=neigh(ni) + face=ele_face(t, ele, ele_2) + if(ele_2>0) then + face_2=ele_face(t, ele_2, ele) + else + ! external face + face_2 = face + end if - finish = start+face_loc(t, face_2)-1 - local_glno(start:finish) = face_global_nodes(t, face_2) + finish = start+face_loc(t, face_2)-1 + local_glno(start:finish) = face_global_nodes(t, face_2) - call assemble_advection_diffusion_face_fv(face, face_2, start, finish, & - t, coordinate, t_coordinate, diffusivity, & - matrix_addto, rhs_addto) + call assemble_advection_diffusion_face_fv(face, face_2, start, finish, & + t, coordinate, t_coordinate, diffusivity, & + matrix_addto, rhs_addto) - start = start+face_loc(t, face_2) + start = start+face_loc(t, face_2) - end do neighboorloop + end do neighboorloop ! call deallocate(t_bc) ! deallocate(t_bc_types) - end if + end if - if(have_diffusivity.or.have_advection) then - ! element depends on its neighbours - if(have_diffusivity) then - ! have diffusivity, all neighbours involved - call addto(matrix, local_glno, local_glno, matrix_addto) - call addto(rhs, local_glno, rhs_addto) + if(have_diffusivity.or.have_advection) then + ! element depends on its neighbours + if(have_diffusivity) then + ! have diffusivity, all neighbours involved + call addto(matrix, local_glno, local_glno, matrix_addto) + call addto(rhs, local_glno, rhs_addto) + else + ! no diffusivity so only some neighbours need adding to + call addto(matrix, element_nodes, local_glno, matrix_addto(:loc,:)) + call addto(rhs, element_nodes, rhs_addto(:loc)) + end if else - ! no diffusivity so only some neighbours need adding to - call addto(matrix, element_nodes, local_glno, matrix_addto(:loc,:)) - call addto(rhs, element_nodes, rhs_addto(:loc)) + ! element doesn't depend on its neighbours + call addto(matrix, element_nodes, element_nodes, matrix_addto(:loc,:loc)) + call addto(rhs, element_nodes, rhs_addto(:loc)) end if - else - ! element doesn't depend on its neighbours - call addto(matrix, element_nodes, element_nodes, matrix_addto(:loc,:loc)) - call addto(rhs, element_nodes, rhs_addto(:loc)) - end if - - end subroutine assemble_advection_diffusion_element_fv - - subroutine assemble_advection_diffusion_face_fv(face, face_2, start, finish, & - t, coordinate, t_coordinate, diffusivity, & - matrix_addto, rhs_addto) - - integer, intent(in) :: face, face_2, start, finish - type(scalar_field), intent(in) :: t - type(vector_field), intent(in) :: coordinate, t_coordinate - type(tensor_field), intent(in) :: diffusivity - real, dimension(:,:), intent(inout) :: matrix_addto - real, dimension(:), intent(inout) :: rhs_addto - - real, dimension(face_ngi(t, face)) :: detwei - real, dimension(mesh_dim(t), face_ngi(t, face)) :: normal - - - call transform_facet_to_physical(coordinate, face, & - detwei_f=detwei, normal=normal) - - if(have_diffusivity) then - call add_diffusivity_face_fv(face, face_2, start, finish, & - t, t_coordinate, diffusivity, & - detwei, normal, & - matrix_addto, rhs_addto) - end if - - - end subroutine assemble_advection_diffusion_face_fv - - subroutine add_diffusivity_face_fv(face, face_2, start, finish, & - t, t_coordinate, diffusivity, & - detwei, normal, & - matrix_addto, rhs_addto) - - integer, intent(in) :: face, face_2, start, finish - type(scalar_field), intent(in) :: t - type(vector_field), intent(in) :: t_coordinate - type(tensor_field), intent(in) :: diffusivity - real, dimension(:), intent(in) :: detwei - real, dimension(:,:), intent(in) :: normal - real, dimension(:,:), intent(inout) :: matrix_addto - real, dimension(:), intent(inout) :: rhs_addto - - real, dimension(face_loc(t_coordinate, face), t_coordinate%dim) :: c_vector - real, dimension(face_loc(t_coordinate, face)) :: c_dist - real, dimension(diffusivity%dim(1), diffusivity%dim(2), face_ngi(diffusivity, face)) :: diffusivity_gi - real, dimension(face_loc(t, face)+face_loc(t,face_2), face_ngi(t, face), mesh_dim(t)) :: dt_t - type(element_type), pointer :: t_shape - real, dimension(face_loc(t, face), face_loc(t,face)+face_loc(t,face_2)) :: diff_mat - integer, dimension(face_loc(t, face)) :: t_face_l - real, dimension(face_loc(t, face) + face_loc(t, face_2)) :: t_val - integer :: loc, tloc, iloc, jloc, gi - - assert(face_loc(t, face)==face_loc(t_coordinate, face)) - assert(face_loc(t, face)==face_loc(t, face_2)) - - loc = face_loc(t,face) ! should just be 1 but being paranoid - tloc = face_loc(t, face) + face_loc(t, face_2) ! so clearly should be 2 - - t_face_l = face_local_nodes(t, face) - t_val(:loc) = face_val(t, face) - t_val(loc+1:) = face_val(t, face_2) - - ! first we need to construct the derivative of a pseudo "shape function" - dt_t = 0.0 - - if(face==face_2) then - ! on boundary - - else - ! internal (but might be a periodic boundary) - - c_vector = transpose(face_val(t_coordinate, face) - face_val(t_coordinate, face_2)) - c_dist = sum(c_vector**2, dim=2) ! this is the square of the distance - do iloc = 1, loc - ! normalise - c_vector(iloc,:) = c_vector(iloc,:)/c_dist(iloc) - end do - dt_t(:loc,:,:) = spread(c_vector, 2, face_ngi(t,face)) - dt_t(loc+1:,:,:) = spread(-c_vector, 2, face_ngi(t,face)) - - ! now we need to construct the matrix entries for the face integral: - ! / - ! | shape (diffusivity dt_t) . normal ds - ! / - diff_mat = 0.0 - - diffusivity_gi = face_val_at_quad(diffusivity, face) - t_shape => face_shape(t, face) - do iloc = 1, face_loc(t, face) ! just the node at the centre of this element - do jloc = 1, (face_loc(t, face)+face_loc(t, face_2)) ! this element's node plus the neighbouring element's - do gi = 1, face_ngi(t, face) ! all the gauss points on this face - diff_mat(iloc, jloc) = diff_mat(iloc, jloc) - t_shape%n(iloc, gi)*& - sum(matmul(diffusivity_gi(:,:,gi), dt_t(jloc, gi, :))*normal(:,gi), 1)*& - detwei(gi) - end do - end do - end do + end subroutine assemble_advection_diffusion_element_fv + + subroutine assemble_advection_diffusion_face_fv(face, face_2, start, finish, & + t, coordinate, t_coordinate, diffusivity, & + matrix_addto, rhs_addto) + + integer, intent(in) :: face, face_2, start, finish + type(scalar_field), intent(in) :: t + type(vector_field), intent(in) :: coordinate, t_coordinate + type(tensor_field), intent(in) :: diffusivity + real, dimension(:,:), intent(inout) :: matrix_addto + real, dimension(:), intent(inout) :: rhs_addto + + real, dimension(face_ngi(t, face)) :: detwei + real, dimension(mesh_dim(t), face_ngi(t, face)) :: normal + - if(abs(dt_theta) > epsilon(0.0)) then - matrix_addto(t_face_l, t_face_l) = matrix_addto(t_face_l, t_face_l) + dt_theta*diff_mat(:,:loc) - matrix_addto(t_face_l, start:finish) = matrix_addto(t_face_l, start:finish) + dt_theta*diff_mat(:,loc+1:) + call transform_facet_to_physical(coordinate, face, & + detwei_f=detwei, normal=normal) + + if(have_diffusivity) then + call add_diffusivity_face_fv(face, face_2, start, finish, & + t, t_coordinate, diffusivity, & + detwei, normal, & + matrix_addto, rhs_addto) end if - rhs_addto(t_face_l) = rhs_addto(t_face_l) - matmul(diff_mat, t_val) - end if - end subroutine add_diffusivity_face_fv + end subroutine assemble_advection_diffusion_face_fv - subroutine add_mass_element_fv(ele, t_shape, t, detwei, matrix_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: t_shape - type(scalar_field), intent(in) :: t - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto + subroutine add_diffusivity_face_fv(face, face_2, start, finish, & + t, t_coordinate, diffusivity, & + detwei, normal, & + matrix_addto, rhs_addto) - real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: mass_matrix + integer, intent(in) :: face, face_2, start, finish + type(scalar_field), intent(in) :: t + type(vector_field), intent(in) :: t_coordinate + type(tensor_field), intent(in) :: diffusivity + real, dimension(:), intent(in) :: detwei + real, dimension(:,:), intent(in) :: normal + real, dimension(:,:), intent(inout) :: matrix_addto + real, dimension(:), intent(inout) :: rhs_addto - assert(have_mass) + real, dimension(face_loc(t_coordinate, face), t_coordinate%dim) :: c_vector + real, dimension(face_loc(t_coordinate, face)) :: c_dist + real, dimension(diffusivity%dim(1), diffusivity%dim(2), face_ngi(diffusivity, face)) :: diffusivity_gi + real, dimension(face_loc(t, face)+face_loc(t,face_2), face_ngi(t, face), mesh_dim(t)) :: dt_t + type(element_type), pointer :: t_shape + real, dimension(face_loc(t, face), face_loc(t,face)+face_loc(t,face_2)) :: diff_mat + integer, dimension(face_loc(t, face)) :: t_face_l + real, dimension(face_loc(t, face) + face_loc(t, face_2)) :: t_val + integer :: loc, tloc, iloc, jloc, gi - mass_matrix = shape_shape(t_shape, t_shape, detwei) + assert(face_loc(t, face)==face_loc(t_coordinate, face)) + assert(face_loc(t, face)==face_loc(t, face_2)) - matrix_addto = matrix_addto + mass_matrix + loc = face_loc(t,face) ! should just be 1 but being paranoid + tloc = face_loc(t, face) + face_loc(t, face_2) ! so clearly should be 2 - end subroutine add_mass_element_fv + t_face_l = face_local_nodes(t, face) + t_val(:loc) = face_val(t, face) + t_val(loc+1:) = face_val(t, face_2) - subroutine add_absorption_element_fv(ele, t_shape, t, absorption, detwei, matrix_addto, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: t_shape - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: absorption - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + ! first we need to construct the derivative of a pseudo "shape function" + dt_t = 0.0 - real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: absorption_mat + if(face==face_2) then + ! on boundary - assert(have_absorption) + else + ! internal (but might be a periodic boundary) + + c_vector = transpose(face_val(t_coordinate, face) - face_val(t_coordinate, face_2)) + c_dist = sum(c_vector**2, dim=2) ! this is the square of the distance + do iloc = 1, loc + ! normalise + c_vector(iloc,:) = c_vector(iloc,:)/c_dist(iloc) + end do + + dt_t(:loc,:,:) = spread(c_vector, 2, face_ngi(t,face)) + dt_t(loc+1:,:,:) = spread(-c_vector, 2, face_ngi(t,face)) + + ! now we need to construct the matrix entries for the face integral: + ! / + ! | shape (diffusivity dt_t) . normal ds + ! / + diff_mat = 0.0 + + diffusivity_gi = face_val_at_quad(diffusivity, face) + t_shape => face_shape(t, face) + do iloc = 1, face_loc(t, face) ! just the node at the centre of this element + do jloc = 1, (face_loc(t, face)+face_loc(t, face_2)) ! this element's node plus the neighbouring element's + do gi = 1, face_ngi(t, face) ! all the gauss points on this face + diff_mat(iloc, jloc) = diff_mat(iloc, jloc) - t_shape%n(iloc, gi)*& + sum(matmul(diffusivity_gi(:,:,gi), dt_t(jloc, gi, :))*normal(:,gi), 1)*& + detwei(gi) + end do + end do + end do + + if(abs(dt_theta) > epsilon(0.0)) then + matrix_addto(t_face_l, t_face_l) = matrix_addto(t_face_l, t_face_l) + dt_theta*diff_mat(:,:loc) + matrix_addto(t_face_l, start:finish) = matrix_addto(t_face_l, start:finish) + dt_theta*diff_mat(:,loc+1:) + end if + rhs_addto(t_face_l) = rhs_addto(t_face_l) - matmul(diff_mat, t_val) - absorption_mat = shape_shape(t_shape, t_shape, detwei * ele_val_at_quad(absorption, ele)) + end if - if(abs(dt_theta) > epsilon(0.0)) matrix_addto = matrix_addto + dt_theta * absorption_mat + end subroutine add_diffusivity_face_fv - rhs_addto = rhs_addto - matmul(absorption_mat, ele_val(t, ele)) + subroutine add_mass_element_fv(ele, t_shape, t, detwei, matrix_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: t_shape + type(scalar_field), intent(in) :: t + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto - end subroutine add_absorption_element_fv + real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: mass_matrix - subroutine add_source_element_fv(ele, t_shape, t, source, detwei, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: t_shape - type(scalar_field), intent(in) :: t - type(scalar_field), intent(in) :: source - real, dimension(ele_ngi(t, ele)), intent(in) :: detwei - real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto + assert(have_mass) - assert(have_source) + mass_matrix = shape_shape(t_shape, t_shape, detwei) - rhs_addto = rhs_addto + shape_rhs(t_shape, detwei * ele_val_at_quad(source, ele)) + matrix_addto = matrix_addto + mass_matrix - end subroutine add_source_element_fv + end subroutine add_mass_element_fv - subroutine advection_diffusion_fv_check_options + subroutine add_absorption_element_fv(ele, t_shape, t, absorption, detwei, matrix_addto, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: t_shape + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: absorption + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele), ele_loc(t, ele)), intent(inout) :: matrix_addto + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - character(len = FIELD_NAME_LEN) :: field_name, mesh_0, mesh_1, state_name - character(len = OPTION_PATH_LEN) :: path - integer :: i, j, stat - real :: beta, l_theta + real, dimension(ele_loc(t, ele), ele_loc(t, ele)) :: absorption_mat - if(option_count("/material_phase/scalar_field/prognostic/spatial_discretisation/finite_volume") == 0) then - ! Nothing to check - return - end if + assert(have_absorption) - ewrite(2, *) "Checking FV advection-diffusion options" + absorption_mat = shape_shape(t_shape, t_shape, detwei * ele_val_at_quad(absorption, ele)) - do i = 0, option_count("/material_phase") - 1 - path = "/material_phase[" // int2str(i) // "]" - call get_option(trim(path) // "/name", state_name) + if(abs(dt_theta) > epsilon(0.0)) matrix_addto = matrix_addto + dt_theta * absorption_mat - do j = 0, option_count(trim(path) // "/scalar_field") - 1 - path = "/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]" - call get_option(trim(path) // "/name", field_name) + rhs_addto = rhs_addto - matmul(absorption_mat, ele_val(t, ele)) - if(field_name /= "Pressure") then + end subroutine add_absorption_element_fv - path = trim(path) // "/prognostic" + subroutine add_source_element_fv(ele, t_shape, t, source, detwei, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: t_shape + type(scalar_field), intent(in) :: t + type(scalar_field), intent(in) :: source + real, dimension(ele_ngi(t, ele)), intent(in) :: detwei + real, dimension(ele_loc(t, ele)), intent(inout) :: rhs_addto - if(have_option(trim(path) // "/spatial_discretisation/finite_volume").and.& - have_option(trim(path) // "/equation[0]")) then + assert(have_source) - call get_option(trim(path) // "/spatial_discretisation/conservative_advection", beta, stat) - if(stat == SPUD_NO_ERROR) then - if(beta < 0.0 .or. beta > 1.0) then + rhs_addto = rhs_addto + shape_rhs(t_shape, detwei * ele_val_at_quad(source, ele)) - call field_error(state_name, field_name, & - & "Conservative advection factor (beta) must be >= 0.0 and <= 1.0") - end if - else - call field_error(state_name, field_name, & - & "Conservative advection factor (beta) required") - end if + end subroutine add_source_element_fv - call get_option(trim(path) // "/temporal_discretisation/theta", l_theta, stat) - if(stat == SPUD_NO_ERROR) then - if(l_theta < 0. .or. l_theta > 1.0) then - call field_error(state_name, field_name, & - &"Implicitness factor (theta) must be >= 0.0 and <= 1.0") - end if - else - call field_error(state_name, field_name, & - & "Implicitness factor (theta) required") - end if - if(have_option(trim(path) // "/spatial_discretisation/finite_volume/mass_terms/exclude_mass_terms") .and. & - & abs(l_theta - 1.0) > epsilon(0.0)) then - call field_warning(state_name, field_name, & - & "Implicitness factor (theta) should = 1.0 when excluding mass") - end if + subroutine advection_diffusion_fv_check_options + + character(len = FIELD_NAME_LEN) :: field_name, mesh_0, mesh_1, state_name + character(len = OPTION_PATH_LEN) :: path + integer :: i, j, stat + real :: beta, l_theta + + if(option_count("/material_phase/scalar_field/prognostic/spatial_discretisation/finite_volume") == 0) then + ! Nothing to check + return + end if + + ewrite(2, *) "Checking FV advection-diffusion options" + + do i = 0, option_count("/material_phase") - 1 + path = "/material_phase[" // int2str(i) // "]" + call get_option(trim(path) // "/name", state_name) + + do j = 0, option_count(trim(path) // "/scalar_field") - 1 + path = "/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]" + call get_option(trim(path) // "/name", field_name) + + if(field_name /= "Pressure") then - if (have_option(trim(path) // "/scalar_field::SinkingVelocity")) then - call get_option(trim(complete_field_path(trim(path) // & - "/scalar_field::SinkingVelocity"))//"/mesh[0]/name", & - mesh_0, stat) - if(stat == SPUD_NO_ERROR) then - call get_option(trim(complete_field_path("/material_phase[" // int2str(i) // & - "]/vector_field::Velocity")) // "/mesh[0]/name", mesh_1) - if(trim(mesh_0) /= trim(mesh_1)) then + path = trim(path) // "/prognostic" + + if(have_option(trim(path) // "/spatial_discretisation/finite_volume").and.& + have_option(trim(path) // "/equation[0]")) then + + call get_option(trim(path) // "/spatial_discretisation/conservative_advection", beta, stat) + if(stat == SPUD_NO_ERROR) then + if(beta < 0.0 .or. beta > 1.0) then + + call field_error(state_name, field_name, & + & "Conservative advection factor (beta) must be >= 0.0 and <= 1.0") + end if + else + call field_error(state_name, field_name, & + & "Conservative advection factor (beta) required") + end if + + call get_option(trim(path) // "/temporal_discretisation/theta", l_theta, stat) + if(stat == SPUD_NO_ERROR) then + if(l_theta < 0. .or. l_theta > 1.0) then + call field_error(state_name, field_name, & + &"Implicitness factor (theta) must be >= 0.0 and <= 1.0") + end if + else + call field_error(state_name, field_name, & + & "Implicitness factor (theta) required") + end if + if(have_option(trim(path) // "/spatial_discretisation/finite_volume/mass_terms/exclude_mass_terms") .and. & + & abs(l_theta - 1.0) > epsilon(0.0)) then call field_warning(state_name, field_name, & - & "SinkingVelocity is on a different mesh to the Velocity field this could cause problems") + & "Implicitness factor (theta) should = 1.0 when excluding mass") + end if + + if (have_option(trim(path) // "/scalar_field::SinkingVelocity")) then + call get_option(trim(complete_field_path(trim(path) // & + "/scalar_field::SinkingVelocity"))//"/mesh[0]/name", & + mesh_0, stat) + if(stat == SPUD_NO_ERROR) then + call get_option(trim(complete_field_path("/material_phase[" // int2str(i) // & + "]/vector_field::Velocity")) // "/mesh[0]/name", mesh_1) + if(trim(mesh_0) /= trim(mesh_1)) then + call field_warning(state_name, field_name, & + & "SinkingVelocity is on a different mesh to the Velocity field this could cause problems") + end if + end if + end if + if(have_option(trim(path) // "/spatial_discretisation/finite_volume/advection_terms/exclude_advection_terms")) then + if(have_option(trim(path) // "/scalar_field::SinkingVelocity")) then + call field_warning(state_name, field_name, & + & "SinkingVelocity set, but advection terms have been excluded - SinkingVelocity will have no effect") + end if end if - end if - end if - if(have_option(trim(path) // "/spatial_discretisation/finite_volume/advection_terms/exclude_advection_terms")) then - if(have_option(trim(path) // "/scalar_field::SinkingVelocity")) then - call field_warning(state_name, field_name, & - & "SinkingVelocity set, but advection terms have been excluded - SinkingVelocity will have no effect") - end if - end if - if(option_count(trim(path) // "/boundary_conditions/type::neumann") > 0 & - & .and. .not. (have_option(trim(path) // "/tensor_field::Diffusivity") & - & .or. have_option(trim(path) // "/subgridscale_parameterisation::k-epsilon") & - & .or. have_option(trim(path) // "/subgridscale_parameterisation::GLS"))) then - call field_warning(state_name, field_name, & - & "Neumann boundary condition set, but have no diffusivity - boundary condition will not be applied") + if(option_count(trim(path) // "/boundary_conditions/type::neumann") > 0 & + & .and. .not. (have_option(trim(path) // "/tensor_field::Diffusivity") & + & .or. have_option(trim(path) // "/subgridscale_parameterisation::k-epsilon") & + & .or. have_option(trim(path) // "/subgridscale_parameterisation::GLS"))) then + call field_warning(state_name, field_name, & + & "Neumann boundary condition set, but have no diffusivity - boundary condition will not be applied") + end if + end if end if - end if - end if + end do end do - end do - ewrite(2, *) "Finished checking CG advection-diffusion options" + ewrite(2, *) "Finished checking CG advection-diffusion options" - contains + contains - subroutine field_warning(state_name, field_name, msg) - character(len = *), intent(in) :: state_name - character(len = *), intent(in) :: field_name - character(len = *), intent(in) :: msg + subroutine field_warning(state_name, field_name, msg) + character(len = *), intent(in) :: state_name + character(len = *), intent(in) :: field_name + character(len = *), intent(in) :: msg - ewrite(0, *) "Warning: For field " // trim(field_name) // " in state " // trim(state_name) - ewrite(0, *) trim(msg) + ewrite(0, *) "Warning: For field " // trim(field_name) // " in state " // trim(state_name) + ewrite(0, *) trim(msg) - end subroutine field_warning + end subroutine field_warning - subroutine field_error(state_name, field_name, msg) - character(len = *), intent(in) :: state_name - character(len = *), intent(in) :: field_name - character(len = *), intent(in) :: msg + subroutine field_error(state_name, field_name, msg) + character(len = *), intent(in) :: state_name + character(len = *), intent(in) :: field_name + character(len = *), intent(in) :: msg - ewrite(-1, *) "For field " // trim(field_name) // " in state " // trim(state_name) - FLExit(trim(msg)) + ewrite(-1, *) "For field " // trim(field_name) // " in state " // trim(state_name) + FLExit(trim(msg)) - end subroutine field_error + end subroutine field_error - end subroutine advection_diffusion_fv_check_options + end subroutine advection_diffusion_fv_check_options end module advection_diffusion_fv diff --git a/assemble/Assemble_CMC.F90 b/assemble/Assemble_CMC.F90 index f55cb4783c..37709e8121 100644 --- a/assemble/Assemble_CMC.F90 +++ b/assemble/Assemble_CMC.F90 @@ -29,33 +29,33 @@ module assemble_CMC - use fldebug - use spud - use global_parameters, only: OPTION_PATH_LEN - use sparse_tools - use linked_lists - use elements - use transform_elements - use fetools, only: shape_shape - use fields - use sparse_tools_petsc - use state_module - use boundary_conditions - use sparse_matrices_fields - use field_options - use fefields - - implicit none - - private - - public :: assemble_cmc_dg, assemble_masslumped_cmc, & - assemble_masslumped_ctm, repair_stiff_nodes, zero_stiff_nodes, & - assemble_diagonal_schur, assemble_scaled_pressure_mass_matrix + use fldebug + use spud + use global_parameters, only: OPTION_PATH_LEN + use sparse_tools + use linked_lists + use elements + use transform_elements + use fetools, only: shape_shape + use fields + use sparse_tools_petsc + use state_module + use boundary_conditions + use sparse_matrices_fields + use field_options + use fefields + + implicit none + + private + + public :: assemble_cmc_dg, assemble_masslumped_cmc, & + assemble_masslumped_ctm, repair_stiff_nodes, zero_stiff_nodes, & + assemble_diagonal_schur, assemble_scaled_pressure_mass_matrix contains - subroutine assemble_cmc_dg(CMC, CTP, CT, inverse_mass) + subroutine assemble_cmc_dg(CMC, CTP, CT, inverse_mass) !!< Assemble the pressure matrix C^T M^{-1} C for a DG mesh. !!< This currently does not support rotations. type(csr_matrix), intent(inout) :: CMC @@ -114,9 +114,9 @@ subroutine assemble_cmc_dg(CMC, CTP, CT, inverse_mass) ewrite_minmax(cmc) - end subroutine assemble_cmc_dg + end subroutine assemble_cmc_dg - subroutine assemble_masslumped_cmc(cmc_m, ctp_m, inverse_masslump, ct_m) + subroutine assemble_masslumped_cmc(cmc_m, ctp_m, inverse_masslump, ct_m) !!< Assemble the pressure matrix C_P^T M_l^{-1} C. !!< This currently does not support rotations. @@ -132,9 +132,9 @@ subroutine assemble_masslumped_cmc(cmc_m, ctp_m, inverse_masslump, ct_m) ewrite_minmax(cmc_m) - end subroutine assemble_masslumped_cmc + end subroutine assemble_masslumped_cmc - subroutine assemble_diagonal_schur(schur_diagonal_matrix,u,inner_m,ctp_m,ct_m) + subroutine assemble_diagonal_schur(schur_diagonal_matrix,u,inner_m,ctp_m,ct_m) !!< Assemble the matrix C_P^T * [(Big_m)_diagonal]^-1 * C. !!< This is used as a preconditioner for the full projection solve !!< when using the full momentum matrix. @@ -160,8 +160,8 @@ subroutine assemble_diagonal_schur(schur_diagonal_matrix,u,inner_m,ctp_m,ct_m) ewrite_minmax(inner_m_diagonal) if(any(inner_m_diagonal%val < 0)) then - ewrite(-1,*) 'Inner_m_diagonal has negative values' - FLExit("Negative values in the diagonal schur complement preconditioner") + ewrite(-1,*) 'Inner_m_diagonal has negative values' + FLExit("Negative values in the diagonal schur complement preconditioner") end if @@ -171,9 +171,9 @@ subroutine assemble_diagonal_schur(schur_diagonal_matrix,u,inner_m,ctp_m,ct_m) ewrite_minmax(schur_diagonal_matrix) call deallocate(inner_m_diagonal) - end subroutine assemble_diagonal_schur + end subroutine assemble_diagonal_schur - subroutine assemble_scaled_pressure_mass_matrix(state, scaled_pressure_mass_matrix, p_mesh, dt) + subroutine assemble_scaled_pressure_mass_matrix(state, scaled_pressure_mass_matrix, p_mesh, dt) ! This routine assembles the scaled_pressure_mass_matrix at the ! quadrature points. It is scaled by the inverse of viscosity. @@ -213,27 +213,27 @@ subroutine assemble_scaled_pressure_mass_matrix(state, scaled_pressure_mass_matr ! Initialise and assemble scaled pressure mass matrix: allocate(detwei(ele_ngi(p_mesh, 1)), & - mass_matrix(ele_loc(p_mesh, 1), ele_loc(p_mesh, 1)), & - mu_gi(ele_ngi(viscosity_component, 1))) + mass_matrix(ele_loc(p_mesh, 1), ele_loc(p_mesh, 1)), & + mu_gi(ele_ngi(viscosity_component, 1))) call zero(scaled_pressure_mass_matrix) do ele = 1, ele_count(p_mesh) - p_shape => ele_shape(p_mesh, ele) - mu_gi = ele_val_at_quad(viscosity_component, ele) - call transform_to_physical(positions, ele, detwei=detwei) - mass_matrix = shape_shape(p_shape, p_shape, detwei/(mu_gi*dt)) - call addto(scaled_pressure_mass_matrix, ele_nodes(p_mesh, ele),& - ele_nodes(p_mesh, ele), mass_matrix) + p_shape => ele_shape(p_mesh, ele) + mu_gi = ele_val_at_quad(viscosity_component, ele) + call transform_to_physical(positions, ele, detwei=detwei) + mass_matrix = shape_shape(p_shape, p_shape, detwei/(mu_gi*dt)) + call addto(scaled_pressure_mass_matrix, ele_nodes(p_mesh, ele),& + ele_nodes(p_mesh, ele), mass_matrix) end do ewrite_minmax(scaled_pressure_mass_matrix) deallocate(detwei, mass_matrix, mu_gi) - end subroutine assemble_scaled_pressure_mass_matrix + end subroutine assemble_scaled_pressure_mass_matrix - subroutine repair_stiff_nodes(cmc_m, stiff_nodes_list) + subroutine repair_stiff_nodes(cmc_m, stiff_nodes_list) type(csr_matrix), intent(inout) :: cmc_m type(ilist), intent(inout) :: stiff_nodes_list @@ -252,23 +252,23 @@ subroutine repair_stiff_nodes(cmc_m, stiff_nodes_list) call flush_list(stiff_nodes_list) do row = 1, size(cmc_m, 1) - row_diag=>diag_val_ptr(cmc_m, row) - row_m=>row_m_ptr(cmc_m, row) - row_val=>row_val_ptr(cmc_m, row) - if(row_diag0) then - ewrite(2,*) 'before node_val = ', node_val(rhs, list2vector(stiff_nodes_list)) - call set(rhs, list2vector(stiff_nodes_list), spread(0.0, 1, stiff_nodes_list%length)) + ewrite(2,*) 'before node_val = ', node_val(rhs, list2vector(stiff_nodes_list)) + call set(rhs, list2vector(stiff_nodes_list), spread(0.0, 1, stiff_nodes_list%length)) end if - end subroutine zero_stiff_nodes + end subroutine zero_stiff_nodes - subroutine assemble_masslumped_ctm(ctm_m, ctp_m, masslump) + subroutine assemble_masslumped_ctm(ctm_m, ctp_m, masslump) !!< Assemble the matrix C_P^T M_l^{-1} !!< This currently does not support rotations. @@ -304,19 +304,19 @@ subroutine assemble_masslumped_ctm(ctm_m, ctp_m, masslump) do dim = 1, ctm_m%blocks(2) - lctm_m_block = block(ctm_m, 1, dim) + lctm_m_block = block(ctm_m, 1, dim) - do row = 1, size(ctp_m, 1) - row_indices=>row_m_ptr(ctp_m, row) - row_val=>row_val_ptr(ctp_m, 1, dim, row) - call set(lctm_m_block, (/row/), row_indices, & - spread((row_val/node_val(masslump, row_indices)), 1, 1)) - end do + do row = 1, size(ctp_m, 1) + row_indices=>row_m_ptr(ctp_m, row) + row_val=>row_val_ptr(ctp_m, 1, dim, row) + call set(lctm_m_block, (/row/), row_indices, & + spread((row_val/node_val(masslump, row_indices)), 1, 1)) + end do end do ewrite_minmax(ctm_m) - end subroutine assemble_masslumped_ctm + end subroutine assemble_masslumped_ctm end module assemble_cmc diff --git a/assemble/Biology.F90 b/assemble/Biology.F90 index 48ab6b02c7..1be30cd0c2 100644 --- a/assemble/Biology.F90 +++ b/assemble/Biology.F90 @@ -27,537 +27,537 @@ #include "fdebug.h" module biology - !!< This module implements a simple PZND (phytoplankton, zooplankton, - !!< nutrient, detritus) model in ICOM. - use fldebug - use spud - use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN, PYTHON_FUNC_LEN - use sparse_tools - use fetools - use fields - use state_module - use boundary_conditions - use solvers - use python_state - use sparsity_patterns_meshes - use field_options - use fefields - - implicit none - - private - public calculate_biology_terms, biology_check_options - - character(len=FIELD_NAME_LEN), dimension(6), parameter ::& - & biology_fields = (/ & - "Phytoplankton ", & - "Zooplankton ", & - "Nutrient ", & - "Detritus ", & - "Chlorophyll ", & - "Ammonium "/) - - ! Boundary condition types: - ! (the numbers should match up with the order in the - ! get_entire_boundary_condition call) - integer :: BCTYPE_WEAKDIRICHLET=1 + !!< This module implements a simple PZND (phytoplankton, zooplankton, + !!< nutrient, detritus) model in ICOM. + use fldebug + use spud + use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN, PYTHON_FUNC_LEN + use sparse_tools + use fetools + use fields + use state_module + use boundary_conditions + use solvers + use python_state + use sparsity_patterns_meshes + use field_options + use fefields + + implicit none + + private + public calculate_biology_terms, biology_check_options + + character(len=FIELD_NAME_LEN), dimension(6), parameter ::& + & biology_fields = (/ & + "Phytoplankton ", & + "Zooplankton ", & + "Nutrient ", & + "Detritus ", & + "Chlorophyll ", & + "Ammonium "/) + + ! Boundary condition types: + ! (the numbers should match up with the order in the + ! get_entire_boundary_condition call) + integer :: BCTYPE_WEAKDIRICHLET=1 contains - subroutine calculate_biology_terms(state) - !!< Calculate the incident light and hence the sources and sinks in the - !!< biology equations. - type(state_type), intent(inout) :: state - - character(len=OPTION_PATH_LEN) :: prefix, algorithm - ! This is the photosynthetic radiation projected onto the - ! same mesh as the biology fields - ! It also takes into account the "active" part of the solar radiation - type(scalar_field) :: par_bio - ! we use the phytoplankton as the "bio" mesh - type(scalar_field), pointer :: phytoplankton, PhotosyntheticRadiation - type(vector_field) :: coords - integer :: stat - - call backup_source_terms(state) - - ! Don't do biology if it's not included in the model! - if (.not.have_option("/ocean_biology")) return - if (have_option("/ocean_biology/pznd")) then - prefix="/ocean_biology/pznd" - algorithm="/source_and_sink_algorithm" - else if (have_option("/ocean_biology/lagrangian_ensemble")) then - prefix="/ocean_biology/lagrangian_ensemble" - algorithm="/biology_algorithm" - else if (have_option("/ocean_biology/six_component")) then - prefix="/ocean_biology/six_component" - algorithm="/source_and_sink_algorithm" - else - FLExit("Unknown biology algorithm") - end if - - ewrite(1,*) "Solving biology sources" - - ewrite(2,*) "will use ",trim(prefix)," model" - - ! Calculate the light field at every point. - call solve_light_equation(state, prefix) - - par_bio = extract_scalar_field(state, "_PAR", stat) - phytoplankton => extract_scalar_field(state, "Phytoplankton") - if (stat /= 0) then - ! field does not yet exist: create it - call allocate(par_bio,phytoplankton%mesh, name="_PAR") - call zero(par_bio) - call insert(state, par_bio, par_bio%name) - call deallocate(par_bio) - par_bio = extract_scalar_field(state, "_PAR", stat) - end if - PhotosyntheticRadiation => extract_scalar_field(state, "PhotosyntheticRadiation") - coords = get_coordinate_field(state, par_bio%mesh) - ! project the Photosynthetic radaition field onto the _PAR field - call project_field(PhotosyntheticRadiation, par_bio, coords) - ! scale it to get the active part - call scale(par_bio, 0.43) - call deallocate(coords) - - ! Calculate the sources and sinks at every point. - call calculate_biology_from_python(state, prefix, algorithm) - - end subroutine calculate_biology_terms - - - subroutine calculate_biology_from_python(state, prefix, algorithm) - ! Set the biological sources and sinks from python. - type(state_type),intent(inout) :: state - character(len=*), intent(in) :: prefix, algorithm - character(len=PYTHON_FUNC_LEN) :: pycode - - if (.not.have_option(trim(prefix)//trim(algorithm))) then - ! No sources and sinks specified. - return - end if - - ! Clean up to make sure that nothing else interferes + subroutine calculate_biology_terms(state) + !!< Calculate the incident light and hence the sources and sinks in the + !!< biology equations. + type(state_type), intent(inout) :: state + + character(len=OPTION_PATH_LEN) :: prefix, algorithm + ! This is the photosynthetic radiation projected onto the + ! same mesh as the biology fields + ! It also takes into account the "active" part of the solar radiation + type(scalar_field) :: par_bio + ! we use the phytoplankton as the "bio" mesh + type(scalar_field), pointer :: phytoplankton, PhotosyntheticRadiation + type(vector_field) :: coords + integer :: stat + + call backup_source_terms(state) + + ! Don't do biology if it's not included in the model! + if (.not.have_option("/ocean_biology")) return + if (have_option("/ocean_biology/pznd")) then + prefix="/ocean_biology/pznd" + algorithm="/source_and_sink_algorithm" + else if (have_option("/ocean_biology/lagrangian_ensemble")) then + prefix="/ocean_biology/lagrangian_ensemble" + algorithm="/biology_algorithm" + else if (have_option("/ocean_biology/six_component")) then + prefix="/ocean_biology/six_component" + algorithm="/source_and_sink_algorithm" + else + FLExit("Unknown biology algorithm") + end if + + ewrite(1,*) "Solving biology sources" + + ewrite(2,*) "will use ",trim(prefix)," model" + + ! Calculate the light field at every point. + call solve_light_equation(state, prefix) + + par_bio = extract_scalar_field(state, "_PAR", stat) + phytoplankton => extract_scalar_field(state, "Phytoplankton") + if (stat /= 0) then + ! field does not yet exist: create it + call allocate(par_bio,phytoplankton%mesh, name="_PAR") + call zero(par_bio) + call insert(state, par_bio, par_bio%name) + call deallocate(par_bio) + par_bio = extract_scalar_field(state, "_PAR", stat) + end if + PhotosyntheticRadiation => extract_scalar_field(state, "PhotosyntheticRadiation") + coords = get_coordinate_field(state, par_bio%mesh) + ! project the Photosynthetic radaition field onto the _PAR field + call project_field(PhotosyntheticRadiation, par_bio, coords) + ! scale it to get the active part + call scale(par_bio, 0.43) + call deallocate(coords) + + ! Calculate the sources and sinks at every point. + call calculate_biology_from_python(state, prefix, algorithm) + + end subroutine calculate_biology_terms + + + subroutine calculate_biology_from_python(state, prefix, algorithm) + ! Set the biological sources and sinks from python. + type(state_type),intent(inout) :: state + character(len=*), intent(in) :: prefix, algorithm + character(len=PYTHON_FUNC_LEN) :: pycode + + if (.not.have_option(trim(prefix)//trim(algorithm))) then + ! No sources and sinks specified. + return + end if + + ! Clean up to make sure that nothing else interferes #ifdef HAVE_NUMPY - call python_reset() - call python_add_state(state) - call get_option(trim(prefix)//trim(algorithm),pycode) - ! And finally run the user's code - call python_run_string(trim(pycode)) + call python_reset() + call python_add_state(state) + call get_option(trim(prefix)//trim(algorithm),pycode) + ! And finally run the user's code + call python_run_string(trim(pycode)) #else - ewrite(-1,*) "When configuring, make sure NumPy is found" - FLExit("Python biological models require NumPy") + ewrite(-1,*) "When configuring, make sure NumPy is found" + FLExit("Python biological models require NumPy") #endif - end subroutine calculate_biology_from_python + end subroutine calculate_biology_from_python - subroutine backup_source_terms(state) - !!< Produce a backup copy of prescribed source fields and zero any - !!< diagnostic source fields. - type(state_type), intent(inout) :: state + subroutine backup_source_terms(state) + !!< Produce a backup copy of prescribed source fields and zero any + !!< diagnostic source fields. + type(state_type), intent(inout) :: state - type(scalar_field) :: this_field, old_field - integer :: i, stat + type(scalar_field) :: this_field, old_field + integer :: i, stat - field_loop: do i = 1, size(biology_fields) - this_field= extract_scalar_field(state, & + field_loop: do i = 1, size(biology_fields) + this_field= extract_scalar_field(state, & trim(biology_fields(i))//"Source", stat=stat) - if (stat/=0) then - cycle field_loop - end if - if (have_option(trim(this_field%option_path)//"/prescribed")) then - ! Prescribed field. - if (.not.has_scalar_field(state, & + if (stat/=0) then + cycle field_loop + end if + if (have_option(trim(this_field%option_path)//"/prescribed")) then + ! Prescribed field. + if (.not.has_scalar_field(state, & "Old"//trim(biology_fields(i))//"Source")) then - call allocate(old_field, this_field%mesh, & + call allocate(old_field, this_field%mesh, & "Old"//trim(this_field%name)) - call set(old_field, this_field) - call insert(state, old_field, trim(old_field%name)) - call deallocate(old_field) - - end if - else - ! Diagnostic field. - - call zero(this_field) - end if - end do field_loop - - end subroutine backup_source_terms - - subroutine solve_light_equation(state, prefix) - !!< The photosynthetically active radiation at any depth in the ocean - !!< is given by the equation: - !!< - !!< dL - !!< -- = (k_w - k_c P) L - !!< dg - !!< - !!< Where g is the direction of gravity, k is a constant and P is the - !!< phytoplankton concentration. - type(state_type), intent(inout) :: state - !! Prefix to the options path. This selects the right biology model. - character(len=*), intent(in) :: prefix - !! Position - type(vector_field) :: X - !! Direction of gravity - type(vector_field) :: g - !! Light intensity - type(scalar_field) :: light - !! Phytoplankton density. - type(scalar_field) :: P - - !! Normal first order sparsity pattern - type(csr_sparsity), pointer :: sparsity - !! Matrix for light - type(csr_matrix) :: light_mat - !! Right hand side for light equation - type(scalar_field) :: rhs - - !! Field over the entire surface mesh containing bc values: - type(scalar_field) :: bc_value - !! Integer array of all surface elements indicating bc type - !! (see below call to get_entire_boundary_condition): - integer, dimension(:), allocatable :: bc_type - - ! Values of absorption coefficients for water and phytoplankton. - real :: k_w, k_p - - ! Loop varable over elements - integer :: ele - - ! If the PhotosyntheticRadiation field is not prognostic we don't solve - ! anything. - if (.not.have_option(trim(prefix)//& - &"/scalar_field::PhotosyntheticRadiation/prognostic")) then - return - end if - - X=extract_vector_field(state, "Coordinate") - g=extract_vector_field(state, "GravityDirection") - light=extract_scalar_field(state, "PhotosyntheticRadiation") - P=extract_scalar_field(state, "Phytoplankton") - - ! Only need first order sparsity as we have no diffusion - sparsity=>get_csr_sparsity_firstorder(state, light%mesh, light%mesh) - - call get_option(trim(light%option_path)//& + call set(old_field, this_field) + call insert(state, old_field, trim(old_field%name)) + call deallocate(old_field) + + end if + else + ! Diagnostic field. + + call zero(this_field) + end if + end do field_loop + + end subroutine backup_source_terms + + subroutine solve_light_equation(state, prefix) + !!< The photosynthetically active radiation at any depth in the ocean + !!< is given by the equation: + !!< + !!< dL + !!< -- = (k_w - k_c P) L + !!< dg + !!< + !!< Where g is the direction of gravity, k is a constant and P is the + !!< phytoplankton concentration. + type(state_type), intent(inout) :: state + !! Prefix to the options path. This selects the right biology model. + character(len=*), intent(in) :: prefix + !! Position + type(vector_field) :: X + !! Direction of gravity + type(vector_field) :: g + !! Light intensity + type(scalar_field) :: light + !! Phytoplankton density. + type(scalar_field) :: P + + !! Normal first order sparsity pattern + type(csr_sparsity), pointer :: sparsity + !! Matrix for light + type(csr_matrix) :: light_mat + !! Right hand side for light equation + type(scalar_field) :: rhs + + !! Field over the entire surface mesh containing bc values: + type(scalar_field) :: bc_value + !! Integer array of all surface elements indicating bc type + !! (see below call to get_entire_boundary_condition): + integer, dimension(:), allocatable :: bc_type + + ! Values of absorption coefficients for water and phytoplankton. + real :: k_w, k_p + + ! Loop varable over elements + integer :: ele + + ! If the PhotosyntheticRadiation field is not prognostic we don't solve + ! anything. + if (.not.have_option(trim(prefix)//& + &"/scalar_field::PhotosyntheticRadiation/prognostic")) then + return + end if + + X=extract_vector_field(state, "Coordinate") + g=extract_vector_field(state, "GravityDirection") + light=extract_scalar_field(state, "PhotosyntheticRadiation") + P=extract_scalar_field(state, "Phytoplankton") + + ! Only need first order sparsity as we have no diffusion + sparsity=>get_csr_sparsity_firstorder(state, light%mesh, light%mesh) + + call get_option(trim(light%option_path)//& "/prognostic/absorption_coefficients/water", k_w) - call get_option(trim(light%option_path)//& + call get_option(trim(light%option_path)//& "/prognostic/absorption_coefficients/phytoplankton", k_p) - call allocate(light_mat, sparsity) - call zero(light_mat) - - call allocate(rhs, light%mesh, "LightRHS") - call zero(rhs) - - ! Enquire about boundary conditions we're interested in - ! Returns an integer array bc_type over the surface elements - ! that indicates the bc type (in the order we specified, i.e. - ! BCTYPE_WEAKDIRICHLET=1) - allocate( bc_type(1:surface_element_count(light)) ) - call get_entire_boundary_condition(light, & - & (/"weakdirichlet"/), & - & bc_value, bc_type) - - assert(has_faces(X%mesh)) - assert(has_faces(light%mesh)) - - do ele=1,element_count(light) - call construct_light_element(ele, light_mat, rhs, X, g, P, light,& - & bc_value, bc_type, k_w, k_p) - end do - - call zero(light) - call petsc_solve(light, light_mat, rhs) - - call deallocate(bc_value) - call deallocate(light_mat) - call deallocate(rhs) - - end subroutine solve_light_equation - - subroutine construct_light_element(ele, light_mat, rhs, X, g, P, light,& - & bc_value, bc_type, k_w, k_p) - integer, intent(in) :: ele - type(csr_matrix), intent(inout) :: light_mat - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: X, g - type(scalar_field), intent(in) :: P, light - !! Field over the entire surface mesh containing bc values: - type(scalar_field), intent(in):: bc_value - !! Integer array of all surface elements indicating bc type - !! (see above call to get_entire_boundary_condition): - integer, dimension(:), intent(in):: bc_type - !! Values of absorption coefficients for water and phytoplankton. - real :: k_w, k_p - - ! Neighbour element, face and neighbour face. - integer :: ele_2, face, face_2 - ! Loops over faces. - integer :: ni - - ! Variable transform times quadrature weights. - real, dimension(ele_ngi(light,ele)) :: detwei - ! Transformed gradient function for light. - real, dimension(ele_loc(light, ele), ele_ngi(light, ele), & + call allocate(light_mat, sparsity) + call zero(light_mat) + + call allocate(rhs, light%mesh, "LightRHS") + call zero(rhs) + + ! Enquire about boundary conditions we're interested in + ! Returns an integer array bc_type over the surface elements + ! that indicates the bc type (in the order we specified, i.e. + ! BCTYPE_WEAKDIRICHLET=1) + allocate( bc_type(1:surface_element_count(light)) ) + call get_entire_boundary_condition(light, & + & (/"weakdirichlet"/), & + & bc_value, bc_type) + + assert(has_faces(X%mesh)) + assert(has_faces(light%mesh)) + + do ele=1,element_count(light) + call construct_light_element(ele, light_mat, rhs, X, g, P, light,& + & bc_value, bc_type, k_w, k_p) + end do + + call zero(light) + call petsc_solve(light, light_mat, rhs) + + call deallocate(bc_value) + call deallocate(light_mat) + call deallocate(rhs) + + end subroutine solve_light_equation + + subroutine construct_light_element(ele, light_mat, rhs, X, g, P, light,& + & bc_value, bc_type, k_w, k_p) + integer, intent(in) :: ele + type(csr_matrix), intent(inout) :: light_mat + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: X, g + type(scalar_field), intent(in) :: P, light + !! Field over the entire surface mesh containing bc values: + type(scalar_field), intent(in):: bc_value + !! Integer array of all surface elements indicating bc type + !! (see above call to get_entire_boundary_condition): + integer, dimension(:), intent(in):: bc_type + !! Values of absorption coefficients for water and phytoplankton. + real :: k_w, k_p + + ! Neighbour element, face and neighbour face. + integer :: ele_2, face, face_2 + ! Loops over faces. + integer :: ni + + ! Variable transform times quadrature weights. + real, dimension(ele_ngi(light,ele)) :: detwei + ! Transformed gradient function for light. + real, dimension(ele_loc(light, ele), ele_ngi(light, ele), & mesh_dim(light)) :: dl_t - ! Gravity vector at each quadrature point. - real, dimension(g%dim, ele_ngi(light, ele)) :: grav_q - ! Phytoplankton concentration at each quadrature point. - real, dimension(ele_ngi(P, ele)) :: P_q + ! Gravity vector at each quadrature point. + real, dimension(g%dim, ele_ngi(light, ele)) :: grav_q + ! Phytoplankton concentration at each quadrature point. + real, dimension(ele_ngi(P, ele)) :: P_q - ! Neighbours of this element. - integer, dimension(:), pointer :: neigh - ! Whether the tracer field is continuous. - logical :: dg + ! Neighbours of this element. + integer, dimension(:), pointer :: neigh + ! Whether the tracer field is continuous. + logical :: dg - ! Shape of the current element. - type(element_type), pointer :: l_shape - ! Global node numbers of the current element. - integer, dimension(:), pointer :: light_ele + ! Shape of the current element. + type(element_type), pointer :: l_shape + ! Global node numbers of the current element. + integer, dimension(:), pointer :: light_ele - dg=continuity(light)<0 + dg=continuity(light)<0 - !---------------------------------------------------------------------- - ! Establish local node lists - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! Establish local node lists + !---------------------------------------------------------------------- - light_ele=>ele_nodes(light,ele) + light_ele=>ele_nodes(light,ele) - !---------------------------------------------------------------------- - ! Establish local shape functions - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! Establish local shape functions + !---------------------------------------------------------------------- - l_shape=>ele_shape(light, ele) + l_shape=>ele_shape(light, ele) - ! Transform Tracer derivatives and weights into physical space. - call transform_to_physical(X, ele, l_shape , dshape=dl_t, detwei=detwei) + ! Transform Tracer derivatives and weights into physical space. + call transform_to_physical(X, ele, l_shape , dshape=dl_t, detwei=detwei) - !---------------------------------------------------------------------- - ! Construct element-wise quantities. - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! Construct element-wise quantities. + !---------------------------------------------------------------------- - grav_q = ele_val_at_quad(g, ele) + grav_q = ele_val_at_quad(g, ele) - P_q = k_w + k_p * max(ele_val_at_quad(P, ele), 0.0) + P_q = k_w + k_p * max(ele_val_at_quad(P, ele), 0.0) - !---------------------------------------------------------------------- - ! Local and global assembly in one fell swoop as it's so trivial. - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! Local and global assembly in one fell swoop as it's so trivial. + !---------------------------------------------------------------------- - call addto(light_mat, light_ele, light_ele, & - ! dL - ! -- (integrated by parts) - ! dg + call addto(light_mat, light_ele, light_ele, & + ! dL + ! -- (integrated by parts) + ! dg -dshape_dot_vector_shape(dl_t, grav_q, l_shape, detwei)& - ! RHS + ! RHS +shape_shape(l_shape, l_shape, detwei*P_q)& ) - !------------------------------------------------------------------- - ! Interface integrals - !------------------------------------------------------------------- - - neigh=>ele_neigh(light, ele) - - neighbourloop: do ni=1,size(neigh) - - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- - - ! These finding routines are outside the inner loop so as to allow - ! for local stack variables of the right size in - ! construct_add_diff_interface_dg. - - ele_2=neigh(ni) - - ! Note that although face is calculated on field light, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(light, ele, ele_2) - - if (ele_2>0) then - ! Internal faces. - - if (.not. dg) then - ! Continuous galerkin has no interior face terms. - cycle neighbourloop - else - face_2=ele_face(light, ele_2, ele) - end if - else - ! External face. - face_2=face - end if - - call construct_light_interface(face, face_2,& - & light_mat, rhs, X, g, light, & - & bc_value, bc_type) - end do neighbourloop - - end subroutine construct_light_element - - subroutine construct_light_interface(face, face_2,& - & light_mat, rhs, X, g, light, bc_value, bc_type) - !!< Construct the element boundary integrals on the ni-th face of - !!< element ele. For continuous discretisation, this is only boundary - !!< faces. For DG it's all of them. - implicit none - - integer, intent(in) :: face, face_2 - type(csr_matrix), intent(inout) :: light_mat - type(scalar_field), intent(inout) :: rhs - ! We pass these additional fields to save on state lookups. - type(vector_field), intent(in) :: X, g - type(scalar_field), intent(in) :: light - !! Field over the entire surface mesh containing bc values: - type(scalar_field), intent(in):: bc_value - !! Integer array of all surface elements indicating bc type - !! (see above call to get_entire_boundary_condition): - integer, dimension(:), intent(in):: bc_type - - ! Face objects and numberings. - type(element_type), pointer ::l_shape, l_shape_2 - integer, dimension(face_loc(light,face)) :: l_face - integer, dimension(face_loc(light,face_2)) :: l_face_2 - - ! Note that both sides of the face can be assumed to have the same - ! number of quadrature points. - real, dimension(X%dim, face_ngi(X, face)) :: normal, grav_q - real, dimension(face_ngi(X, face)) :: grav_flux - logical, dimension(face_ngi(X, face)) :: influx - ! Variable transform times quadrature weights. - real, dimension(face_ngi(light,face)) :: detwei - ! Gravity flux at each - ! Whether this is a boundary, and if so whether it is Dirichlet. - logical :: boundary, Dirichlet - - ! Bilinear forms - real, dimension(face_loc(light,face),face_loc(light,face)) ::& - & nnlight_out - real, dimension(face_loc(light,face),face_loc(light,face_2)) ::& - & nnlight_in - - l_face=face_global_nodes(light, face) - l_shape=>face_shape(light, face) - - l_face_2=face_global_nodes(light, face_2) - l_shape_2=>face_shape(light, face_2) - - ! Boundary nodes have both faces the same. - boundary=(face==face_2) - dirichlet=.false. - if (boundary .and. face < size(bc_type)) then - if (bc_type(face)==BCTYPE_WEAKDIRICHLET) then - dirichlet=.true. - end if - end if - - !---------------------------------------------------------------------- - ! Change of coordinates on face. - !---------------------------------------------------------------------- - - call transform_facet_to_physical(X, face, & - & detwei_f=detwei,& - & normal=normal) - - !---------------------------------------------------------------------- - ! Construct element-wise quantities. - !---------------------------------------------------------------------- - - grav_q=face_val_at_quad(g, face) - - ! grav_flux is negative if gravity at this gauss point is directed - ! into this element. - grav_flux= sum(grav_q*normal,1) - - ! Flag for incoming flow. - influx=grav_flux<0.0 - - !---------------------------------------------------------------------- - ! Construct bilinear forms. - !---------------------------------------------------------------------- - - ! Calculate outflow boundary integral. - nnlight_out=shape_shape(l_shape, l_shape, & - & merge(1.0,0.0,.not.influx)*grav_flux*detwei) - - nnlight_in=shape_shape(l_shape, l_shape_2, & - & merge(1.0,0.0,influx)*grav_flux*detwei) - - !---------------------------------------------------------------------- - ! Perform global assembly. - !---------------------------------------------------------------------- - - ! Insert flux terms in matrix. - - ! Outflux boundary integral. - call addto(light_mat, l_face, l_face, nnlight_out) - - if (.not.dirichlet) then - ! Influx boundary integral. - call addto(light_mat, l_face, l_face_2,nnlight_in) - end if - - ! Dirichlet boundary flux into rhs - - if (Dirichlet) then - - ! Inflow of Dirichlet value. - call addto(RHS, l_face, & + !------------------------------------------------------------------- + ! Interface integrals + !------------------------------------------------------------------- + + neigh=>ele_neigh(light, ele) + + neighbourloop: do ni=1,size(neigh) + + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- + + ! These finding routines are outside the inner loop so as to allow + ! for local stack variables of the right size in + ! construct_add_diff_interface_dg. + + ele_2=neigh(ni) + + ! Note that although face is calculated on field light, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(light, ele, ele_2) + + if (ele_2>0) then + ! Internal faces. + + if (.not. dg) then + ! Continuous galerkin has no interior face terms. + cycle neighbourloop + else + face_2=ele_face(light, ele_2, ele) + end if + else + ! External face. + face_2=face + end if + + call construct_light_interface(face, face_2,& + & light_mat, rhs, X, g, light, & + & bc_value, bc_type) + end do neighbourloop + + end subroutine construct_light_element + + subroutine construct_light_interface(face, face_2,& + & light_mat, rhs, X, g, light, bc_value, bc_type) + !!< Construct the element boundary integrals on the ni-th face of + !!< element ele. For continuous discretisation, this is only boundary + !!< faces. For DG it's all of them. + implicit none + + integer, intent(in) :: face, face_2 + type(csr_matrix), intent(inout) :: light_mat + type(scalar_field), intent(inout) :: rhs + ! We pass these additional fields to save on state lookups. + type(vector_field), intent(in) :: X, g + type(scalar_field), intent(in) :: light + !! Field over the entire surface mesh containing bc values: + type(scalar_field), intent(in):: bc_value + !! Integer array of all surface elements indicating bc type + !! (see above call to get_entire_boundary_condition): + integer, dimension(:), intent(in):: bc_type + + ! Face objects and numberings. + type(element_type), pointer ::l_shape, l_shape_2 + integer, dimension(face_loc(light,face)) :: l_face + integer, dimension(face_loc(light,face_2)) :: l_face_2 + + ! Note that both sides of the face can be assumed to have the same + ! number of quadrature points. + real, dimension(X%dim, face_ngi(X, face)) :: normal, grav_q + real, dimension(face_ngi(X, face)) :: grav_flux + logical, dimension(face_ngi(X, face)) :: influx + ! Variable transform times quadrature weights. + real, dimension(face_ngi(light,face)) :: detwei + ! Gravity flux at each + ! Whether this is a boundary, and if so whether it is Dirichlet. + logical :: boundary, Dirichlet + + ! Bilinear forms + real, dimension(face_loc(light,face),face_loc(light,face)) ::& + & nnlight_out + real, dimension(face_loc(light,face),face_loc(light,face_2)) ::& + & nnlight_in + + l_face=face_global_nodes(light, face) + l_shape=>face_shape(light, face) + + l_face_2=face_global_nodes(light, face_2) + l_shape_2=>face_shape(light, face_2) + + ! Boundary nodes have both faces the same. + boundary=(face==face_2) + dirichlet=.false. + if (boundary .and. face < size(bc_type)) then + if (bc_type(face)==BCTYPE_WEAKDIRICHLET) then + dirichlet=.true. + end if + end if + + !---------------------------------------------------------------------- + ! Change of coordinates on face. + !---------------------------------------------------------------------- + + call transform_facet_to_physical(X, face, & + & detwei_f=detwei,& + & normal=normal) + + !---------------------------------------------------------------------- + ! Construct element-wise quantities. + !---------------------------------------------------------------------- + + grav_q=face_val_at_quad(g, face) + + ! grav_flux is negative if gravity at this gauss point is directed + ! into this element. + grav_flux= sum(grav_q*normal,1) + + ! Flag for incoming flow. + influx=grav_flux<0.0 + + !---------------------------------------------------------------------- + ! Construct bilinear forms. + !---------------------------------------------------------------------- + + ! Calculate outflow boundary integral. + nnlight_out=shape_shape(l_shape, l_shape, & + & merge(1.0,0.0,.not.influx)*grav_flux*detwei) + + nnlight_in=shape_shape(l_shape, l_shape_2, & + & merge(1.0,0.0,influx)*grav_flux*detwei) + + !---------------------------------------------------------------------- + ! Perform global assembly. + !---------------------------------------------------------------------- + + ! Insert flux terms in matrix. + + ! Outflux boundary integral. + call addto(light_mat, l_face, l_face, nnlight_out) + + if (.not.dirichlet) then + ! Influx boundary integral. + call addto(light_mat, l_face, l_face_2,nnlight_in) + end if + + ! Dirichlet boundary flux into rhs + + if (Dirichlet) then + + ! Inflow of Dirichlet value. + call addto(RHS, l_face, & -matmul(nnlight_in,& ele_val(bc_value, face))) - end if - - end subroutine construct_light_interface - - subroutine biology_check_options - character(len=FIELD_NAME_LEN) :: buffer - integer :: itmp, stat - - ! Don't do biology if it's not included in the model! - if (.not.have_option("/ocean_biology/pznd") .or. & - .not.have_option("/ocean_biology/six_component")) return - - call get_option("/problem_type", buffer) - if (buffer/="oceans") then - FLExit("Biology modelling is only supported for problem type oceans.") - end if - - if (.not.have_option("/physical_parameters/gravity")) then - ewrite(-1, *) "Biology modelling requires gravity" - FLExit("(otherwise which way does the crap fall?)") - end if - - if (have_option("/ocean_biology/pznd/scalar_field& - &::PhotosyntheticRadiation/prognostic/solver/& - &preconditioner::sor")) then - ewrite(0, *) "Warning: Sor may not work for the PhotosyntheticRadiation "//& - &"equation" - ewrite(0, *) "Consider using ilu as a preconditioner instead." - end if - if (have_option("/ocean_biology/six_component/scalar_field& - &::PhotosyntheticRadiation/prognostic/solver/& - &preconditioner::sor")) then - ewrite(0, *) "Warning: Sor may not work for the PhotosyntheticRadiation "//& - &"equation" - ewrite(0, *) "Consider using ilu as a preconditioner instead." - end if - - call get_option("/timestepping/nonlinear_iterations", itmp, stat) - - if (stat/=0.or.itmp<2) then - ewrite(0,*) "Warning: For stability reasons it is recommended that "//& - "you have at least 2 nonlinear_iterations when using ocean biology" - end if - - end subroutine biology_check_options + end if + + end subroutine construct_light_interface + + subroutine biology_check_options + character(len=FIELD_NAME_LEN) :: buffer + integer :: itmp, stat + + ! Don't do biology if it's not included in the model! + if (.not.have_option("/ocean_biology/pznd") .or. & + .not.have_option("/ocean_biology/six_component")) return + + call get_option("/problem_type", buffer) + if (buffer/="oceans") then + FLExit("Biology modelling is only supported for problem type oceans.") + end if + + if (.not.have_option("/physical_parameters/gravity")) then + ewrite(-1, *) "Biology modelling requires gravity" + FLExit("(otherwise which way does the crap fall?)") + end if + + if (have_option("/ocean_biology/pznd/scalar_field& + &::PhotosyntheticRadiation/prognostic/solver/& + &preconditioner::sor")) then + ewrite(0, *) "Warning: Sor may not work for the PhotosyntheticRadiation "//& + &"equation" + ewrite(0, *) "Consider using ilu as a preconditioner instead." + end if + if (have_option("/ocean_biology/six_component/scalar_field& + &::PhotosyntheticRadiation/prognostic/solver/& + &preconditioner::sor")) then + ewrite(0, *) "Warning: Sor may not work for the PhotosyntheticRadiation "//& + &"equation" + ewrite(0, *) "Consider using ilu as a preconditioner instead." + end if + + call get_option("/timestepping/nonlinear_iterations", itmp, stat) + + if (stat/=0.or.itmp<2) then + ewrite(0,*) "Warning: For stability reasons it is recommended that "//& + "you have at least 2 nonlinear_iterations when using ocean biology" + end if + + end subroutine biology_check_options end module biology diff --git a/assemble/Burgers_Assembly.F90 b/assemble/Burgers_Assembly.F90 index c4fb380112..a987854894 100644 --- a/assemble/Burgers_Assembly.F90 +++ b/assemble/Burgers_Assembly.F90 @@ -1,84 +1,84 @@ - ! Copyright (C) 2006 Imperial College London and others. - ! - ! Please see the AUTHORS file in the main source directory for a full list - ! of copyright holders. - ! - ! Prof. C Pain - ! Applied Modelling and Computation Group - ! Department of Earth Science and Engineering - ! Imperial College London - ! - ! amcgsoftware@imperial.ac.uk - ! - ! This library is free software; you can redistribute it and/or - ! modify it under the terms of the GNU Lesser General Public - ! License as published by the Free Software Foundation, - ! version 2.1 of the License. - ! - ! This library is distributed in the hope that it will be useful, - ! but WITHOUT ANY WARRANTY; without even the implied warranty of - ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - ! Lesser General Public License for more details. - ! - ! You should have received a copy of the GNU Lesser General Public - ! License along with this library; if not, write to the Free Software - ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 - ! USA + ! Copyright (C) 2006 Imperial College London and others. + ! + ! Please see the AUTHORS file in the main source directory for a full list + ! of copyright holders. + ! + ! Prof. C Pain + ! Applied Modelling and Computation Group + ! Department of Earth Science and Engineering + ! Imperial College London + ! + ! amcgsoftware@imperial.ac.uk + ! + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation, + ! version 2.1 of the License. + ! + ! This library is distributed in the hope that it will be useful, + ! but WITHOUT ANY WARRANTY; without even the implied warranty of + ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + ! Lesser General Public License for more details. + ! + ! You should have received a copy of the GNU Lesser General Public + ! License along with this library; if not, write to the Free Software + ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + ! USA module burgers_assembly - use spud - use sparse_tools - use transform_elements - use fetools - use fields - implicit none + use spud + use sparse_tools + use transform_elements + use fetools + use fields + implicit none - private - public :: assemble_advection_matrix + private + public :: assemble_advection_matrix - contains +contains - subroutine assemble_advection_matrix(advection_matrix, x, u_left, u_right) - type(csr_matrix), intent(inout) :: advection_matrix - type(vector_field), intent(in) :: x - type(scalar_field), intent(in), target :: u_left, u_right + subroutine assemble_advection_matrix(advection_matrix, x, u_left, u_right) + type(csr_matrix), intent(inout) :: advection_matrix + type(vector_field), intent(in) :: x + type(scalar_field), intent(in), target :: u_left, u_right - type(scalar_field) :: nu - type(mesh_type), pointer :: mesh - integer :: ele - real :: itheta + type(scalar_field) :: nu + type(mesh_type), pointer :: mesh + integer :: ele + real :: itheta - call get_option(trim(u_left%option_path) // "/prognostic/temporal_discretisation/relaxation", itheta, default=0.5) - mesh => u_left%mesh - call allocate(nu, mesh, "NonlinearVelocity") - call set(nu, u_left) - call scale(nu, (1.0 - itheta)) - call addto(nu, u_right, scale=itheta) - nu%option_path = u_left%option_path + call get_option(trim(u_left%option_path) // "/prognostic/temporal_discretisation/relaxation", itheta, default=0.5) + mesh => u_left%mesh + call allocate(nu, mesh, "NonlinearVelocity") + call set(nu, u_left) + call scale(nu, (1.0 - itheta)) + call addto(nu, u_right, scale=itheta) + nu%option_path = u_left%option_path - call zero(advection_matrix) - if (.not. have_option(trim(nu%option_path) // "/prognostic/remove_advection_term")) then - do ele=1,ele_count(nu) - call assemble_advection_matrix_ele(advection_matrix, x, nu, ele) - end do - end if + call zero(advection_matrix) + if (.not. have_option(trim(nu%option_path) // "/prognostic/remove_advection_term")) then + do ele=1,ele_count(nu) + call assemble_advection_matrix_ele(advection_matrix, x, nu, ele) + end do + end if - call deallocate(nu) - end subroutine assemble_advection_matrix + call deallocate(nu) + end subroutine assemble_advection_matrix - subroutine assemble_advection_matrix_ele(advection_matrix, x, nu, ele) - type(csr_matrix), intent(inout) :: advection_matrix - type(vector_field), intent(in) :: x - type(scalar_field), intent(in) :: nu - integer, intent(in) :: ele + subroutine assemble_advection_matrix_ele(advection_matrix, x, nu, ele) + type(csr_matrix), intent(inout) :: advection_matrix + type(vector_field), intent(in) :: x + type(scalar_field), intent(in) :: nu + integer, intent(in) :: ele - real, dimension(ele_loc(nu, ele), ele_loc(nu, ele)) :: little_advection_matrix - real, dimension(ele_ngi(nu, ele)) :: detwei - real, dimension(ele_loc(nu, ele), ele_ngi(nu, ele), x%dim) :: du_t + real, dimension(ele_loc(nu, ele), ele_loc(nu, ele)) :: little_advection_matrix + real, dimension(ele_ngi(nu, ele)) :: detwei + real, dimension(ele_loc(nu, ele), ele_ngi(nu, ele), x%dim) :: du_t - call transform_to_physical(x, ele, ele_shape(nu, ele), detwei=detwei, dshape=du_t) - little_advection_matrix = shape_vector_dot_dshape(ele_shape(nu, ele), ele_val_at_quad(nu, ele), du_t, detwei) - call addto(advection_matrix, ele_nodes(nu, ele), ele_nodes(nu, ele), little_advection_matrix) - end subroutine assemble_advection_matrix_ele + call transform_to_physical(x, ele, ele_shape(nu, ele), detwei=detwei, dshape=du_t) + little_advection_matrix = shape_vector_dot_dshape(ele_shape(nu, ele), ele_val_at_quad(nu, ele), du_t, detwei) + call addto(advection_matrix, ele_nodes(nu, ele), ele_nodes(nu, ele), little_advection_matrix) + end subroutine assemble_advection_matrix_ele end module burgers_assembly diff --git a/assemble/Compressible_Projection.F90 b/assemble/Compressible_Projection.F90 index d61b17444b..b553389710 100644 --- a/assemble/Compressible_Projection.F90 +++ b/assemble/Compressible_Projection.F90 @@ -27,633 +27,633 @@ #include "fdebug.h" module compressible_projection - use fldebug - use spud - use global_parameters, only: OPTION_PATH_LEN - use futils, only: int2str - use sparse_tools - use elements - use transform_elements - use fetools, only: shape_shape, shape_rhs - use fields - use state_module - use sparse_matrices_fields - use field_options - use fefields, only: compute_cv_mass - use state_fields_module - use equation_of_state, only: compressible_eos, compressible_material_eos - use upwind_stabilisation - use multiphase_module - implicit none + use fldebug + use spud + use global_parameters, only: OPTION_PATH_LEN + use futils, only: int2str + use sparse_tools + use elements + use transform_elements + use fetools, only: shape_shape, shape_rhs + use fields + use state_module + use sparse_matrices_fields + use field_options + use fefields, only: compute_cv_mass + use state_fields_module + use equation_of_state, only: compressible_eos, compressible_material_eos + use upwind_stabilisation + use multiphase_module + implicit none + + ! Buffer for output messages. + character(len=255), private :: message + + private + public :: assemble_compressible_projection_cv, assemble_compressible_projection_cg, update_compressible_density + public :: compressible_projection_check_options + + ! Stabilisation schemes + integer, parameter :: STABILISATION_NONE = 0, & + & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 + ! Stabilisation scheme + integer :: stabilisation_scheme + integer :: nu_bar_scheme + real :: nu_bar_scale + + !! Are we running a multiphase flow simulation? + logical :: multiphase + +contains + + subroutine assemble_compressible_projection_cv(state, cmc, rhs, dt, theta_pg, theta_divergence, cmcget) + + ! inputs: + ! bucket full of fields + type(state_type), dimension(:), intent(inout) :: state + + type(csr_matrix), intent(inout) :: cmc + type(scalar_field), intent(inout) :: rhs + + real, intent(in) :: dt + real, intent(in) :: theta_pg, theta_divergence + logical, intent(in) :: cmcget + + if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then + + call assemble_1mat_compressible_projection_cv(state(1), cmc, rhs, dt, & + theta_pg, theta_divergence, cmcget) - ! Buffer for output messages. - character(len=255), private :: message - - private - public :: assemble_compressible_projection_cv, assemble_compressible_projection_cg, update_compressible_density - public :: compressible_projection_check_options - - ! Stabilisation schemes - integer, parameter :: STABILISATION_NONE = 0, & - & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 - ! Stabilisation scheme - integer :: stabilisation_scheme - integer :: nu_bar_scheme - real :: nu_bar_scale - - !! Are we running a multiphase flow simulation? - logical :: multiphase - - contains - - subroutine assemble_compressible_projection_cv(state, cmc, rhs, dt, theta_pg, theta_divergence, cmcget) - - ! inputs: - ! bucket full of fields - type(state_type), dimension(:), intent(inout) :: state - - type(csr_matrix), intent(inout) :: cmc - type(scalar_field), intent(inout) :: rhs - - real, intent(in) :: dt - real, intent(in) :: theta_pg, theta_divergence - logical, intent(in) :: cmcget - - if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then - - call assemble_1mat_compressible_projection_cv(state(1), cmc, rhs, dt, & - theta_pg, theta_divergence, cmcget) - - else + else - call assemble_mmat_compressible_projection_cv(state, cmc, rhs, dt, cmcget) + call assemble_mmat_compressible_projection_cv(state, cmc, rhs, dt, cmcget) - end if + end if - end subroutine assemble_compressible_projection_cv + end subroutine assemble_compressible_projection_cv - subroutine assemble_1mat_compressible_projection_cv(state, cmc, rhs, dt, & - theta_pg, theta_divergence, cmcget) + subroutine assemble_1mat_compressible_projection_cv(state, cmc, rhs, dt, & + theta_pg, theta_divergence, cmcget) - ! inputs: - ! bucket full of fields - type(state_type), intent(inout) :: state + ! inputs: + ! bucket full of fields + type(state_type), intent(inout) :: state - type(csr_matrix), intent(inout) :: cmc - type(scalar_field), intent(inout) :: rhs + type(csr_matrix), intent(inout) :: cmc + type(scalar_field), intent(inout) :: rhs - real, intent(in) :: dt - real, intent(in) :: theta_pg, theta_divergence - logical, intent(in) :: cmcget + real, intent(in) :: dt + real, intent(in) :: theta_pg, theta_divergence + logical, intent(in) :: cmcget - ! local: - type(scalar_field) :: eospressure, drhodp - type(scalar_field), pointer :: density, olddensity - type(scalar_field), pointer :: pressure - type(scalar_field), pointer :: p_cvmass - type(scalar_field) :: lhsfield, absrhs + ! local: + type(scalar_field) :: eospressure, drhodp + type(scalar_field), pointer :: density, olddensity + type(scalar_field), pointer :: pressure + type(scalar_field), pointer :: p_cvmass + type(scalar_field) :: lhsfield, absrhs - type(scalar_field), pointer :: source, absorption - integer :: stat + type(scalar_field), pointer :: source, absorption + integer :: stat - real :: atmospheric_pressure, theta + real :: atmospheric_pressure, theta - ewrite(1,*) 'Entering assemble_1mat_compressible_projection_cv' + ewrite(1,*) 'Entering assemble_1mat_compressible_projection_cv' - call zero(rhs) + call zero(rhs) - ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) - if(cmcget) then + ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) + if(cmcget) then - pressure=>extract_scalar_field(state, "Pressure") - call get_option(trim(pressure%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) + pressure=>extract_scalar_field(state, "Pressure") + call get_option(trim(pressure%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) - ! find the cv mass - p_cvmass => get_cv_mass(state, pressure%mesh) + ! find the cv mass + p_cvmass => get_cv_mass(state, pressure%mesh) - ewrite_minmax(p_cvmass) + ewrite_minmax(p_cvmass) - call allocate(lhsfield, pressure%mesh, "LHSField") + call allocate(lhsfield, pressure%mesh, "LHSField") - call allocate(eospressure, pressure%mesh, 'EOSPressure') - call allocate(drhodp, pressure%mesh, 'DerivativeDensityWRTBulkPressure') + call allocate(eospressure, pressure%mesh, 'EOSPressure') + call allocate(drhodp, pressure%mesh, 'DerivativeDensityWRTBulkPressure') - call zero(eospressure) - call zero(drhodp) + call zero(eospressure) + call zero(drhodp) - call compressible_eos(state, pressure=eospressure, drhodp=drhodp) + call compressible_eos(state, pressure=eospressure, drhodp=drhodp) - density=>extract_scalar_field(state,'Density') - ewrite_minmax(density) - olddensity=>extract_scalar_field(state,'OldDensity') - ewrite_minmax(olddensity) + density=>extract_scalar_field(state,'Density') + ewrite_minmax(density) + olddensity=>extract_scalar_field(state,'OldDensity') + ewrite_minmax(olddensity) - call get_option(trim(density%option_path)//"/prognostic/temporal_discretisation/theta", theta) + call get_option(trim(density%option_path)//"/prognostic/temporal_discretisation/theta", theta) - call set(lhsfield, p_cvmass) - call scale(lhsfield, drhodp) - call addto_diag(cmc, lhsfield, scale=1./(dt*dt*theta_divergence*theta_pg)) + call set(lhsfield, p_cvmass) + call scale(lhsfield, drhodp) + call addto_diag(cmc, lhsfield, scale=1./(dt*dt*theta_divergence*theta_pg)) ! rhs = p_cvmass* & ! ( (1./dt)*(olddensity - density + drhodp*(eospressure - (pressure + atmospheric_pressure))) ! +(absorption)*(drhodp*theta_pg*(eospressure - (pressure + atmospheric_pressure)) - theta_pg*density - (1-theta_pg)*olddensity) ! +source) - call set(rhs, pressure) - call addto(rhs, atmospheric_pressure) - call scale(rhs, -1.0) - call addto(rhs, eospressure) - call scale(rhs, drhodp) - call addto(rhs, density, -1.0) - call addto(rhs, olddensity) - call scale(rhs, (1./dt)) - - source => extract_scalar_field(state, "DensitySource", stat=stat) - if(stat==0) then - call addto(rhs, source) - end if + call set(rhs, pressure) + call addto(rhs, atmospheric_pressure) + call scale(rhs, -1.0) + call addto(rhs, eospressure) + call scale(rhs, drhodp) + call addto(rhs, density, -1.0) + call addto(rhs, olddensity) + call scale(rhs, (1./dt)) - absorption => extract_scalar_field(state, "DensityAbsorption", stat=stat) - if(stat==0) then - call allocate(absrhs, absorption%mesh, "AbsorptionRHS") + source => extract_scalar_field(state, "DensitySource", stat=stat) + if(stat==0) then + call addto(rhs, source) + end if - call set(absrhs, pressure) - call addto(absrhs, atmospheric_pressure) - call scale(absrhs, -1.0) - call addto(absrhs, eospressure) - call scale(absrhs, drhodp) - call scale(absrhs, theta) - call addto(absrhs, density, -theta) - call addto(absrhs, olddensity, -(1-theta)) - call scale(absrhs, absorption) + absorption => extract_scalar_field(state, "DensityAbsorption", stat=stat) + if(stat==0) then + call allocate(absrhs, absorption%mesh, "AbsorptionRHS") - call addto(rhs, absrhs) + call set(absrhs, pressure) + call addto(absrhs, atmospheric_pressure) + call scale(absrhs, -1.0) + call addto(absrhs, eospressure) + call scale(absrhs, drhodp) + call scale(absrhs, theta) + call addto(absrhs, density, -theta) + call addto(absrhs, olddensity, -(1-theta)) + call scale(absrhs, absorption) - call deallocate(absrhs) + call addto(rhs, absrhs) - call scale(lhsfield, absorption) - call addto_diag(cmc, lhsfield, scale=(theta/(dt*theta_divergence*theta_pg))) - end if + call deallocate(absrhs) - call scale(rhs, p_cvmass) + call scale(lhsfield, absorption) + call addto_diag(cmc, lhsfield, scale=(theta/(dt*theta_divergence*theta_pg))) + end if - call deallocate(eospressure) - call deallocate(drhodp) + call scale(rhs, p_cvmass) - call deallocate(lhsfield) + call deallocate(eospressure) + call deallocate(drhodp) - end if + call deallocate(lhsfield) - end subroutine assemble_1mat_compressible_projection_cv + end if - subroutine assemble_mmat_compressible_projection_cv(state, cmc, rhs, dt, cmcget) + end subroutine assemble_1mat_compressible_projection_cv - ! inputs: - ! bucket full of fields - type(state_type), dimension(:), intent(inout) :: state + subroutine assemble_mmat_compressible_projection_cv(state, cmc, rhs, dt, cmcget) - type(csr_matrix), intent(inout) :: cmc - type(scalar_field), intent(inout) :: rhs + ! inputs: + ! bucket full of fields + type(state_type), dimension(:), intent(inout) :: state - real, intent(in) :: dt - logical, intent(in) :: cmcget + type(csr_matrix), intent(inout) :: cmc + type(scalar_field), intent(inout) :: rhs - ! local: - integer :: i, stat - character(len=OPTION_PATH_LEN) :: pressure_option_path + real, intent(in) :: dt + logical, intent(in) :: cmcget - type(scalar_field) :: materialpressure, materialdrhodp, density, & - olddensity, matdrhodpp, drhodp - type(scalar_field), pointer :: volumefraction, oldvolumefraction, materialdensity, oldmaterialdensity - type(scalar_field), pointer :: dummy_ones + ! local: + integer :: i, stat + character(len=OPTION_PATH_LEN) :: pressure_option_path - type(scalar_field), pointer :: pressure - type(vector_field), pointer :: positions - type(scalar_field) :: cv_mass, tempfield + type(scalar_field) :: materialpressure, materialdrhodp, density, & + olddensity, matdrhodpp, drhodp + type(scalar_field), pointer :: volumefraction, oldvolumefraction, materialdensity, oldmaterialdensity + type(scalar_field), pointer :: dummy_ones - real :: atmospheric_pressure - ! Do we want to use the compressible projection method? - logical :: have_compressible_eos + type(scalar_field), pointer :: pressure + type(vector_field), pointer :: positions + type(scalar_field) :: cv_mass, tempfield - ewrite(1,*) 'Entering assemble_mmat_compressible_projection_cv' + real :: atmospheric_pressure + ! Do we want to use the compressible projection method? + logical :: have_compressible_eos - pressure=>extract_prognostic_pressure(state, stat=stat) - if(stat/=0) then - ! how did we end up here? - FLAbort("In assemble_mmat_compressible_projection_cv without a pressure") - end if - pressure_option_path=trim(pressure%option_path) + ewrite(1,*) 'Entering assemble_mmat_compressible_projection_cv' - have_compressible_eos = .false. - state_loop: do i = 1, size(state) - have_compressible_eos = have_option("/material_phase::"//trim(state(i)%name)//"/equation_of_state/compressible") - if(have_compressible_eos) then - exit state_loop + pressure=>extract_prognostic_pressure(state, stat=stat) + if(stat/=0) then + ! how did we end up here? + FLAbort("In assemble_mmat_compressible_projection_cv without a pressure") end if - end do state_loop - - call zero(rhs) + pressure_option_path=trim(pressure%option_path) - if(have_compressible_eos) THEN + have_compressible_eos = .false. + state_loop: do i = 1, size(state) + have_compressible_eos = have_option("/material_phase::"//trim(state(i)%name)//"/equation_of_state/compressible") + if(have_compressible_eos) then + exit state_loop + end if + end do state_loop - ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) - if(cmcget) then - - positions=>extract_vector_field(state(1), "Coordinate") - call allocate(cv_mass, pressure%mesh, "CVMassField") - call allocate(tempfield, pressure%mesh, "TemporaryAssemblyField") - call compute_cv_mass(positions, cv_mass) + call zero(rhs) - allocate(dummy_ones) - call allocate(dummy_ones, pressure%mesh, "DummyOnesField") - call set(dummy_ones, 1.0) + if(have_compressible_eos) THEN - call get_option(trim(pressure_option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) + ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) + if(cmcget) then - call allocate(materialpressure, pressure%mesh, 'MaterialEOSPressure') - call allocate(materialdrhodp, pressure%mesh, 'DerivativeMaterialdensityWRTBulkPressure') + positions=>extract_vector_field(state(1), "Coordinate") + call allocate(cv_mass, pressure%mesh, "CVMassField") + call allocate(tempfield, pressure%mesh, "TemporaryAssemblyField") + call compute_cv_mass(positions, cv_mass) - call allocate(density, pressure%mesh, 'MaterialDensity') - call allocate(olddensity, pressure%mesh, 'OldMaterialDensity') - call allocate(matdrhodpp, pressure%mesh, 'MaterialPressure') - call allocate(drhodp, pressure%mesh, 'Drhodp') + allocate(dummy_ones) + call allocate(dummy_ones, pressure%mesh, "DummyOnesField") + call set(dummy_ones, 1.0) - density%val = 0.0 - olddensity%val = 0.0 - matdrhodpp%val = 0.0 - drhodp%val=0.0 + call get_option(trim(pressure_option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) - do i = 1,size(state) + call allocate(materialpressure, pressure%mesh, 'MaterialEOSPressure') + call allocate(materialdrhodp, pressure%mesh, 'DerivativeMaterialdensityWRTBulkPressure') - materialpressure%val=0.0 - materialdrhodp%val=0.0 + call allocate(density, pressure%mesh, 'MaterialDensity') + call allocate(olddensity, pressure%mesh, 'OldMaterialDensity') + call allocate(matdrhodpp, pressure%mesh, 'MaterialPressure') + call allocate(drhodp, pressure%mesh, 'Drhodp') - call compressible_material_eos(state(i), materialpressure=materialpressure, materialdrhodp=materialdrhodp) + density%val = 0.0 + olddensity%val = 0.0 + matdrhodpp%val = 0.0 + drhodp%val=0.0 - volumefraction=>extract_scalar_field(state(i),'MaterialVolumeFraction', stat=stat) - if(stat==0) then - oldvolumefraction=>extract_scalar_field(state(i),'OldMaterialVolumeFraction') - materialdensity=>extract_scalar_field(state(i),'MaterialDensity') - oldmaterialdensity=>extract_scalar_field(state(i),'OldMaterialDensity') + do i = 1,size(state) - density%val = density%val & - + materialdensity%val*volumefraction%val - olddensity%val = olddensity%val & - + oldmaterialdensity%val*oldvolumefraction%val - matdrhodpp%val = matdrhodpp%val & - + materialpressure%val*materialdrhodp%val*volumefraction%val - drhodp%val = drhodp%val & - + materialdrhodp%val*volumefraction%val - endif + materialpressure%val=0.0 + materialdrhodp%val=0.0 - end do + call compressible_material_eos(state(i), materialpressure=materialpressure, materialdrhodp=materialdrhodp) - call zero(tempfield) - tempfield%val = (1./(dt*dt))*cv_mass%val*drhodp%val + volumefraction=>extract_scalar_field(state(i),'MaterialVolumeFraction', stat=stat) + if(stat==0) then + oldvolumefraction=>extract_scalar_field(state(i),'OldMaterialVolumeFraction') + materialdensity=>extract_scalar_field(state(i),'MaterialDensity') + oldmaterialdensity=>extract_scalar_field(state(i),'OldMaterialDensity') - call addto_diag(cmc, tempfield) + density%val = density%val & + + materialdensity%val*volumefraction%val + olddensity%val = olddensity%val & + + oldmaterialdensity%val*oldvolumefraction%val + matdrhodpp%val = matdrhodpp%val & + + materialpressure%val*materialdrhodp%val*volumefraction%val + drhodp%val = drhodp%val & + + materialdrhodp%val*volumefraction%val + endif - rhs%val = (1./dt)*cv_mass%val* & - ( & - olddensity%val & - - density%val & - ) & - +(1./dt)*cv_mass%val* & - ( & - matdrhodpp%val & - - drhodp%val*(pressure%val+atmospheric_pressure) & - ) - - call deallocate(density) - call deallocate(olddensity) - call deallocate(matdrhodpp) - call deallocate(drhodp) + end do - call deallocate(materialpressure) - call deallocate(materialdrhodp) + call zero(tempfield) + tempfield%val = (1./(dt*dt))*cv_mass%val*drhodp%val - call deallocate(cv_mass) - call deallocate(tempfield) - call deallocate(dummy_ones) - deallocate(dummy_ones) + call addto_diag(cmc, tempfield) - end if + rhs%val = (1./dt)*cv_mass%val* & + ( & + olddensity%val & + - density%val & + ) & + +(1./dt)*cv_mass%val* & + ( & + matdrhodpp%val & + - drhodp%val*(pressure%val+atmospheric_pressure) & + ) - end if + call deallocate(density) + call deallocate(olddensity) + call deallocate(matdrhodpp) + call deallocate(drhodp) - end subroutine assemble_mmat_compressible_projection_cv + call deallocate(materialpressure) + call deallocate(materialdrhodp) - subroutine assemble_compressible_projection_cg(state, istate, cmc, rhs, dt, theta_pg, theta_divergence, cmcget) + call deallocate(cv_mass) + call deallocate(tempfield) + call deallocate(dummy_ones) + deallocate(dummy_ones) - ! inputs: - ! bucket full of fields - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate + end if - type(csr_matrix), intent(inout) :: cmc - type(scalar_field), intent(inout) :: rhs + end if - real, intent(in) :: dt - real, intent(in) :: theta_pg, theta_divergence - logical, intent(in) :: cmcget + end subroutine assemble_mmat_compressible_projection_cv - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - multiphase = .true. - call assemble_1mat_compressible_projection_cg(state(istate), cmc, rhs, dt, & - theta_pg, theta_divergence, cmcget) - else - multiphase = .false. + subroutine assemble_compressible_projection_cg(state, istate, cmc, rhs, dt, theta_pg, theta_divergence, cmcget) - if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then + ! inputs: + ! bucket full of fields + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate - call assemble_1mat_compressible_projection_cg(state(1), cmc, rhs, dt, & - theta_pg, theta_divergence, cmcget) + type(csr_matrix), intent(inout) :: cmc + type(scalar_field), intent(inout) :: rhs - else + real, intent(in) :: dt + real, intent(in) :: theta_pg, theta_divergence + logical, intent(in) :: cmcget - FLExit("Multimaterial compressible continuous_galerkin pressure not possible.") + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + multiphase = .true. + call assemble_1mat_compressible_projection_cg(state(istate), cmc, rhs, dt, & + theta_pg, theta_divergence, cmcget) + else + multiphase = .false. - end if + if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then - end if + call assemble_1mat_compressible_projection_cg(state(1), cmc, rhs, dt, & + theta_pg, theta_divergence, cmcget) - end subroutine assemble_compressible_projection_cg + else - subroutine assemble_1mat_compressible_projection_cg(state, cmc, rhs, dt, & - theta_pg, theta_divergence, cmcget) + FLExit("Multimaterial compressible continuous_galerkin pressure not possible.") - ! inputs: - ! bucket full of fields - type(state_type), intent(inout) :: state + end if - type(csr_matrix), intent(inout) :: cmc - type(scalar_field), intent(inout) :: rhs + end if - real, intent(in) :: dt - real, intent(in) :: theta_pg, theta_divergence - logical, intent(in) :: cmcget + end subroutine assemble_compressible_projection_cg - ! local - type(mesh_type), pointer :: test_mesh + subroutine assemble_1mat_compressible_projection_cg(state, cmc, rhs, dt, & + theta_pg, theta_divergence, cmcget) - type(vector_field), pointer :: field + ! inputs: + ! bucket full of fields + type(state_type), intent(inout) :: state - integer, dimension(:), pointer :: test_nodes + type(csr_matrix), intent(inout) :: cmc + type(scalar_field), intent(inout) :: rhs - real, dimension(:), allocatable :: ele_rhs - type(element_type), pointer :: test_shape_ptr - type(element_type) :: test_shape - real, dimension(:,:,:), allocatable :: dtest_t - real, dimension(:), allocatable :: detwei - real, dimension(:,:,:), allocatable :: j_mat + real, intent(in) :: dt + real, intent(in) :: theta_pg, theta_divergence + logical, intent(in) :: cmcget - real, dimension(:), allocatable :: density_at_quad, olddensity_at_quad, p_at_quad, & - drhodp_at_quad, eosp_at_quad, abs_at_quad - real, dimension(:,:), allocatable :: nlvelocity_at_quad + ! local + type(mesh_type), pointer :: test_mesh - ! loop integers - integer :: ele + type(vector_field), pointer :: field - ! pointer to coordinates - type(vector_field), pointer :: coordinate, nonlinearvelocity, velocity - type(scalar_field), pointer :: pressure, density, olddensity - type(scalar_field), pointer :: source, absorption - type(scalar_field) :: eospressure, drhodp - real :: theta, atmospheric_pressure + integer, dimension(:), pointer :: test_nodes - real, dimension(:,:), allocatable :: ele_mat + real, dimension(:), allocatable :: ele_rhs + type(element_type), pointer :: test_shape_ptr + type(element_type) :: test_shape + real, dimension(:,:,:), allocatable :: dtest_t + real, dimension(:), allocatable :: detwei + real, dimension(:,:,:), allocatable :: j_mat - logical :: have_absorption, have_source - integer :: stat + real, dimension(:), allocatable :: density_at_quad, olddensity_at_quad, p_at_quad, & + drhodp_at_quad, eosp_at_quad, abs_at_quad + real, dimension(:,:), allocatable :: nlvelocity_at_quad - !! Multiphase variables - ! Volume fraction fields - type(scalar_field), pointer :: vfrac - type(scalar_field) :: nvfrac + ! loop integers + integer :: ele - ! ============================================================= - ! Subroutine to construct the matrix CT_m (a.k.a. C1/2/3T). - ! ============================================================= + ! pointer to coordinates + type(vector_field), pointer :: coordinate, nonlinearvelocity, velocity + type(scalar_field), pointer :: pressure, density, olddensity + type(scalar_field), pointer :: source, absorption + type(scalar_field) :: eospressure, drhodp + real :: theta, atmospheric_pressure - ewrite(1,*) 'Entering assemble_1mat_compressible_projection_cg' + real, dimension(:,:), allocatable :: ele_mat - call zero(rhs) + logical :: have_absorption, have_source + integer :: stat - ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) - if(cmcget) then - coordinate=> extract_vector_field(state, "Coordinate") + !! Multiphase variables + ! Volume fraction fields + type(scalar_field), pointer :: vfrac + type(scalar_field) :: nvfrac - density => extract_scalar_field(state, "Density") - olddensity => extract_scalar_field(state, "OldDensity") + ! ============================================================= + ! Subroutine to construct the matrix CT_m (a.k.a. C1/2/3T). + ! ============================================================= - absorption => extract_scalar_field(state, "DensityAbsorption", stat=stat) - have_absorption = (stat==0) - if(have_absorption) then - ewrite(2,*) 'Have DensityAbsorption' - end if + ewrite(1,*) 'Entering assemble_1mat_compressible_projection_cg' - source => extract_scalar_field(state, "DensitySource", stat=stat) - have_source = (stat==0) - if(have_source) then - ewrite(2,*) 'Have DensitySource' - end if + call zero(rhs) - velocity=>extract_vector_field(state, "Velocity") - nonlinearvelocity=>extract_vector_field(state, "NonlinearVelocity") ! maybe this should be updated after the velocity solve? + ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) + if(cmcget) then + coordinate=> extract_vector_field(state, "Coordinate") + + density => extract_scalar_field(state, "Density") + olddensity => extract_scalar_field(state, "OldDensity") + + absorption => extract_scalar_field(state, "DensityAbsorption", stat=stat) + have_absorption = (stat==0) + if(have_absorption) then + ewrite(2,*) 'Have DensityAbsorption' + end if + + source => extract_scalar_field(state, "DensitySource", stat=stat) + have_source = (stat==0) + if(have_source) then + ewrite(2,*) 'Have DensitySource' + end if + + velocity=>extract_vector_field(state, "Velocity") + nonlinearvelocity=>extract_vector_field(state, "NonlinearVelocity") ! maybe this should be updated after the velocity solve? + + ! Get the non-linear PhaseVolumeFraction field if multiphase + if(multiphase) then + vfrac => extract_scalar_field(state, "PhaseVolumeFraction") + call allocate(nvfrac, vfrac%mesh, "NonlinearPhaseVolumeFraction") + call zero(nvfrac) + call get_nonlinear_volume_fraction(state, nvfrac) + ewrite_minmax(nvfrac) + end if + + pressure => extract_scalar_field(state, "Pressure") + + call get_option(trim(pressure%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + + ! these are put on the density mesh, which should be of sufficient order to represent + ! the multiplication of the eos (of course that may not be possible in which case + ! something should be done at the gauss points instead) + call allocate(eospressure, density%mesh, 'EOSPressure') + call allocate(drhodp, density%mesh, 'DerivativeDensityWRTBulkPressure') + + call zero(eospressure) + call zero(drhodp) + + ! this needs to be changed to be evaluated at the quadrature points! + call compressible_eos(state, pressure=eospressure, drhodp=drhodp) + + ewrite_minmax(density) + ewrite_minmax(olddensity) + + if(have_option(trim(density%option_path) // & + "/prognostic/spatial_discretisation/continuous_galerkin/& + &stabilisation/streamline_upwind_petrov_galerkin")) then + ewrite(2, *) "SUPG stabilisation" + stabilisation_scheme = STABILISATION_SUPG + call get_upwind_options(trim(density%option_path) // & + "/prognostic/spatial_discretisation/continuous_galerkin/& + &stabilisation/streamline_upwind_petrov_galerkin", & + & nu_bar_scheme, nu_bar_scale) + else + ewrite(2, *) "No stabilisation" + stabilisation_scheme = STABILISATION_NONE + end if + + call get_option(trim(density%option_path)//"/prognostic/temporal_discretisation/theta", theta) + + test_mesh => pressure%mesh + field => velocity + + allocate(dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), field%dim), & + detwei(ele_ngi(field, 1)), & + ele_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1)), & + ele_rhs(ele_loc(test_mesh, 1)), & + density_at_quad(ele_ngi(density, 1)), & + olddensity_at_quad(ele_ngi(density, 1)), & + nlvelocity_at_quad(field%dim, ele_ngi(field, 1)), & + j_mat(field%dim, field%dim, ele_ngi(density, 1)), & + drhodp_at_quad(ele_ngi(drhodp, 1)), & + eosp_at_quad(ele_ngi(eospressure, 1)), & + abs_at_quad(ele_ngi(density, 1)), & + p_at_quad(ele_ngi(pressure, 1))) + + do ele=1, element_count(test_mesh) + + test_nodes=>ele_nodes(test_mesh, ele) + + test_shape_ptr => ele_shape(test_mesh, ele) + + density_at_quad = ele_val_at_quad(density, ele) + olddensity_at_quad = ele_val_at_quad(olddensity, ele) + + p_at_quad = ele_val_at_quad(pressure, ele) + atmospheric_pressure + + nlvelocity_at_quad = ele_val_at_quad(nonlinearvelocity, ele) + + drhodp_at_quad = ele_val_at_quad(drhodp, ele) + eosp_at_quad = ele_val_at_quad(eospressure, ele) + + select case(stabilisation_scheme) + case(STABILISATION_SUPG) + call transform_to_physical(coordinate, ele, test_shape_ptr, dshape = dtest_t, detwei=detwei, j=j_mat) + test_shape = make_supg_shape(test_shape_ptr, dtest_t, nlvelocity_at_quad, j_mat, & + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + case default + call transform_to_physical(coordinate, ele, detwei=detwei) + test_shape = test_shape_ptr + call incref(test_shape) + end select + ! Important note: with SUPG the test function derivatives have not been + ! modified. + + if(multiphase) then + ele_mat = (1./(dt*dt*theta_divergence*theta_pg))*shape_shape(test_shape, test_shape_ptr, detwei*ele_val_at_quad(nvfrac, ele)*drhodp_at_quad) + else + ele_mat = (1./(dt*dt*theta_divergence*theta_pg))*shape_shape(test_shape, test_shape_ptr, detwei*drhodp_at_quad) + end if + ! / + ! rhs = |test_shape* & + ! / + ! ((1./dt)*(drhodp*(eospressure - (pressure + atmospheric_pressure)) + olddensity - density) + ! +(absorption)*(drhodp*theta*(eospressure - (pressure + atmospheric_pressure)) + ! - theta*density - (1-theta)*olddensity) + ! +source)dV + + if(multiphase) then + ele_rhs = (1./dt)*shape_rhs(test_shape, detwei*(ele_val_at_quad(nvfrac, ele))*((drhodp_at_quad*(eosp_at_quad - p_at_quad)) & + +(olddensity_at_quad - density_at_quad))) + else + ele_rhs = (1./dt)*shape_rhs(test_shape, detwei*((drhodp_at_quad*(eosp_at_quad - p_at_quad)) & + +(olddensity_at_quad - density_at_quad))) + end if + + if(have_source) then + ele_rhs = ele_rhs + shape_rhs(test_shape, detwei*ele_val_at_quad(source, ele)) + end if + + if(have_absorption) then + abs_at_quad = ele_val_at_quad(absorption, ele) + ele_mat = ele_mat + & + (theta/(dt*theta_divergence*theta_pg))*shape_shape(test_shape, test_shape_ptr, & + detwei*drhodp_at_quad*abs_at_quad) + ele_rhs = ele_rhs + & + shape_rhs(test_shape, detwei*abs_at_quad*(theta*(drhodp_at_quad*(eosp_at_quad - p_at_quad)-density_at_quad) & + -(1-theta)*olddensity_at_quad)) + end if + + call addto(cmc, test_nodes, test_nodes, ele_mat) + + call addto(rhs, test_nodes, ele_rhs) + + call deallocate(test_shape) + + end do + + call deallocate(drhodp) + call deallocate(eospressure) + + if(multiphase) then + call deallocate(nvfrac) + end if - ! Get the non-linear PhaseVolumeFraction field if multiphase - if(multiphase) then - vfrac => extract_scalar_field(state, "PhaseVolumeFraction") - call allocate(nvfrac, vfrac%mesh, "NonlinearPhaseVolumeFraction") - call zero(nvfrac) - call get_nonlinear_volume_fraction(state, nvfrac) - ewrite_minmax(nvfrac) end if - pressure => extract_scalar_field(state, "Pressure") + end subroutine assemble_1mat_compressible_projection_cg - call get_option(trim(pressure%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) + subroutine update_compressible_density(state) - ! these are put on the density mesh, which should be of sufficient order to represent - ! the multiplication of the eos (of course that may not be possible in which case - ! something should be done at the gauss points instead) - call allocate(eospressure, density%mesh, 'EOSPressure') - call allocate(drhodp, density%mesh, 'DerivativeDensityWRTBulkPressure') + type(state_type), dimension(:), intent(inout) :: state - call zero(eospressure) - call zero(drhodp) + type(scalar_field), pointer :: density - ! this needs to be changed to be evaluated at the quadrature points! - call compressible_eos(state, pressure=eospressure, drhodp=drhodp) + integer :: istate - ewrite_minmax(density) - ewrite_minmax(olddensity) + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + do istate=1,size(state) + density=>extract_scalar_field(state(istate),'Density') - if(have_option(trim(density%option_path) // & - "/prognostic/spatial_discretisation/continuous_galerkin/& - &stabilisation/streamline_upwind_petrov_galerkin")) then - ewrite(2, *) "SUPG stabilisation" - stabilisation_scheme = STABILISATION_SUPG - call get_upwind_options(trim(density%option_path) // & - "/prognostic/spatial_discretisation/continuous_galerkin/& - &stabilisation/streamline_upwind_petrov_galerkin", & - & nu_bar_scheme, nu_bar_scale) + if(have_option(trim(density%option_path)//"/prognostic")) then + call compressible_eos(state(istate), density=density) + end if + end do else - ewrite(2, *) "No stabilisation" - stabilisation_scheme = STABILISATION_NONE - end if - - call get_option(trim(density%option_path)//"/prognostic/temporal_discretisation/theta", theta) - - test_mesh => pressure%mesh - field => velocity - - allocate(dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), field%dim), & - detwei(ele_ngi(field, 1)), & - ele_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1)), & - ele_rhs(ele_loc(test_mesh, 1)), & - density_at_quad(ele_ngi(density, 1)), & - olddensity_at_quad(ele_ngi(density, 1)), & - nlvelocity_at_quad(field%dim, ele_ngi(field, 1)), & - j_mat(field%dim, field%dim, ele_ngi(density, 1)), & - drhodp_at_quad(ele_ngi(drhodp, 1)), & - eosp_at_quad(ele_ngi(eospressure, 1)), & - abs_at_quad(ele_ngi(density, 1)), & - p_at_quad(ele_ngi(pressure, 1))) - - do ele=1, element_count(test_mesh) - - test_nodes=>ele_nodes(test_mesh, ele) - - test_shape_ptr => ele_shape(test_mesh, ele) - - density_at_quad = ele_val_at_quad(density, ele) - olddensity_at_quad = ele_val_at_quad(olddensity, ele) - - p_at_quad = ele_val_at_quad(pressure, ele) + atmospheric_pressure - - nlvelocity_at_quad = ele_val_at_quad(nonlinearvelocity, ele) - - drhodp_at_quad = ele_val_at_quad(drhodp, ele) - eosp_at_quad = ele_val_at_quad(eospressure, ele) - - select case(stabilisation_scheme) - case(STABILISATION_SUPG) - call transform_to_physical(coordinate, ele, test_shape_ptr, dshape = dtest_t, detwei=detwei, j=j_mat) - test_shape = make_supg_shape(test_shape_ptr, dtest_t, nlvelocity_at_quad, j_mat, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - case default - call transform_to_physical(coordinate, ele, detwei=detwei) - test_shape = test_shape_ptr - call incref(test_shape) - end select - ! Important note: with SUPG the test function derivatives have not been - ! modified. - - if(multiphase) then - ele_mat = (1./(dt*dt*theta_divergence*theta_pg))*shape_shape(test_shape, test_shape_ptr, detwei*ele_val_at_quad(nvfrac, ele)*drhodp_at_quad) - else - ele_mat = (1./(dt*dt*theta_divergence*theta_pg))*shape_shape(test_shape, test_shape_ptr, detwei*drhodp_at_quad) - end if - ! / - ! rhs = |test_shape* & - ! / - ! ((1./dt)*(drhodp*(eospressure - (pressure + atmospheric_pressure)) + olddensity - density) - ! +(absorption)*(drhodp*theta*(eospressure - (pressure + atmospheric_pressure)) - ! - theta*density - (1-theta)*olddensity) - ! +source)dV - - if(multiphase) then - ele_rhs = (1./dt)*shape_rhs(test_shape, detwei*(ele_val_at_quad(nvfrac, ele))*((drhodp_at_quad*(eosp_at_quad - p_at_quad)) & - +(olddensity_at_quad - density_at_quad))) - else - ele_rhs = (1./dt)*shape_rhs(test_shape, detwei*((drhodp_at_quad*(eosp_at_quad - p_at_quad)) & - +(olddensity_at_quad - density_at_quad))) - end if - - if(have_source) then - ele_rhs = ele_rhs + shape_rhs(test_shape, detwei*ele_val_at_quad(source, ele)) - end if - - if(have_absorption) then - abs_at_quad = ele_val_at_quad(absorption, ele) - ele_mat = ele_mat + & - (theta/(dt*theta_divergence*theta_pg))*shape_shape(test_shape, test_shape_ptr, & - detwei*drhodp_at_quad*abs_at_quad) - ele_rhs = ele_rhs + & - shape_rhs(test_shape, detwei*abs_at_quad*(theta*(drhodp_at_quad*(eosp_at_quad - p_at_quad)-density_at_quad) & - -(1-theta)*olddensity_at_quad)) - end if - - call addto(cmc, test_nodes, test_nodes, ele_mat) - - call addto(rhs, test_nodes, ele_rhs) - - call deallocate(test_shape) + if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then - end do - - call deallocate(drhodp) - call deallocate(eospressure) + density=>extract_scalar_field(state(1),'Density') - if(multiphase) then - call deallocate(nvfrac) - end if + if(have_option(trim(density%option_path)//"/prognostic")) then - end if + call compressible_eos(state(1), density=density) - end subroutine assemble_1mat_compressible_projection_cg + end if - subroutine update_compressible_density(state) - - type(state_type), dimension(:), intent(inout) :: state - - type(scalar_field), pointer :: density - - integer :: istate - - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - do istate=1,size(state) - density=>extract_scalar_field(state(istate),'Density') - - if(have_option(trim(density%option_path)//"/prognostic")) then - call compressible_eos(state(istate), density=density) - end if - end do - else - if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then - - density=>extract_scalar_field(state(1),'Density') - - if(have_option(trim(density%option_path)//"/prognostic")) then - - call compressible_eos(state(1), density=density) - - end if - - end if - end if + end if + end if - end subroutine update_compressible_density + end subroutine update_compressible_density - subroutine compressible_projection_check_options + subroutine compressible_projection_check_options - character(len=OPTION_PATH_LEN):: pressure_option_path - integer:: iphase - logical:: have_compressible_eos + character(len=OPTION_PATH_LEN):: pressure_option_path + integer:: iphase + logical:: have_compressible_eos - do iphase=0, option_count("/material_phase")-1 - have_compressible_eos = have_option("/material_phase["//int2str(iphase)//"]/equation_of_state/compressible") - pressure_option_path = "/material_phase["//int2str(iphase)//"]/scalar_field::Pressure" - if(have_compressible_eos.and. & + do iphase=0, option_count("/material_phase")-1 + have_compressible_eos = have_option("/material_phase["//int2str(iphase)//"]/equation_of_state/compressible") + pressure_option_path = "/material_phase["//int2str(iphase)//"]/scalar_field::Pressure" + if(have_compressible_eos.and. & have_option(trim(pressure_option_path)//"/prognostic/spatial_discretisation/discontinuous_galerkin")) then - FLExit("With a DG pressure you cannot have use a compressible eos") - end if - end do + FLExit("With a DG pressure you cannot have use a compressible eos") + end if + end do - end subroutine compressible_projection_check_options + end subroutine compressible_projection_check_options end module compressible_projection diff --git a/assemble/Coriolis.F90 b/assemble/Coriolis.F90 index 690d6063b9..50afe581f4 100644 --- a/assemble/Coriolis.F90 +++ b/assemble/Coriolis.F90 @@ -29,207 +29,207 @@ module coriolis_module - use spud - use fldebug - use global_parameters, only : current_time, PYTHON_FUNC_LEN - use embed_python - use parallel_tools, only: abort_if_in_parallel_region - - implicit none - - !! Coriolis parameters: - !! these are stored as global module variables and set directly - !! from the options tree, this is to avoid having to read the options - !! in performance critical routines in this module. They are private - !! and should not be accessed directly - real, save :: f0 - real, dimension(:), pointer, save :: coriolis_beta - real, save :: latitude0, R_earth - ! coriolis_option has to have one of the following values: - integer, parameter :: NO_CORIOLIS=0, F_PLANE=1, BETA_PLANE=2, & - SINE_OF_LATITUDE=3, CORIOLIS_ON_SPHERE=4, PYTHON_F_PLANE=5, NOT_INITIALISED=-1 - integer, save :: coriolis_option=NOT_INITIALISED - - character(len = PYTHON_FUNC_LEN), save :: coriolis_python_func - logical, save :: python_coriolis_initialised = .false. - real, save :: python_coriolis_time - - ! legacy thing for use in funome(): - integer, save :: coriolis_dim=3 - - private - - public :: coriolis, funome, set_coriolis_parameters, coriolis_module_check_options - - contains - - function coriolis(xyz) - !!< Returns the coriolis magnitude f so that the coriolis force is given - !!< by: f k x u - real, dimension(:,:):: xyz - real, dimension(size(xyz,2)):: coriolis - - if (coriolis_option==NOT_INITIALISED) call set_coriolis_parameters - - select case (coriolis_option) - case (NO_CORIOLIS) - coriolis=0.0 - case (F_PLANE) - coriolis=f0 - case (BETA_PLANE) - coriolis=f0+matmul(coriolis_beta, xyz) - case (SINE_OF_LATITUDE) - coriolis=f0*sin(xyz(2,:)/R_earth+latitude0) - case (CORIOLIS_ON_SPHERE) - ! at the moment the same as f-plane: - coriolis=f0 - case (PYTHON_F_PLANE) - call update_f_plane_coriolis() - coriolis = f0 - case default - ewrite(-1,*) "coriolis_option:", coriolis_option - FLAbort("Unknown coriolis option") - end select - - end function coriolis - - subroutine update_f_plane_coriolis() - !!< Update python set f-plane Coriolis variables - - if(.not. do_update_f_plane_coriolis()) return - - ewrite(2, *) "Updating f-plane Coriolis from python" - call real_from_python(coriolis_python_func, current_time, f0) - - python_coriolis_initialised = .true. - python_coriolis_time = current_time - - contains - - function do_update_f_plane_coriolis() result(update) - logical :: update - - if(.not. python_coriolis_initialised) then - update = .true. - else - update = python_coriolis_time /= current_time + use spud + use fldebug + use global_parameters, only : current_time, PYTHON_FUNC_LEN + use embed_python + use parallel_tools, only: abort_if_in_parallel_region + + implicit none + + !! Coriolis parameters: + !! these are stored as global module variables and set directly + !! from the options tree, this is to avoid having to read the options + !! in performance critical routines in this module. They are private + !! and should not be accessed directly + real, save :: f0 + real, dimension(:), pointer, save :: coriolis_beta + real, save :: latitude0, R_earth + ! coriolis_option has to have one of the following values: + integer, parameter :: NO_CORIOLIS=0, F_PLANE=1, BETA_PLANE=2, & + SINE_OF_LATITUDE=3, CORIOLIS_ON_SPHERE=4, PYTHON_F_PLANE=5, NOT_INITIALISED=-1 + integer, save :: coriolis_option=NOT_INITIALISED + + character(len = PYTHON_FUNC_LEN), save :: coriolis_python_func + logical, save :: python_coriolis_initialised = .false. + real, save :: python_coriolis_time + + ! legacy thing for use in funome(): + integer, save :: coriolis_dim=3 + + private + + public :: coriolis, funome, set_coriolis_parameters, coriolis_module_check_options + +contains + + function coriolis(xyz) + !!< Returns the coriolis magnitude f so that the coriolis force is given + !!< by: f k x u + real, dimension(:,:):: xyz + real, dimension(size(xyz,2)):: coriolis + + if (coriolis_option==NOT_INITIALISED) call set_coriolis_parameters + + select case (coriolis_option) + case (NO_CORIOLIS) + coriolis=0.0 + case (F_PLANE) + coriolis=f0 + case (BETA_PLANE) + coriolis=f0+matmul(coriolis_beta, xyz) + case (SINE_OF_LATITUDE) + coriolis=f0*sin(xyz(2,:)/R_earth+latitude0) + case (CORIOLIS_ON_SPHERE) + ! at the moment the same as f-plane: + coriolis=f0 + case (PYTHON_F_PLANE) + call update_f_plane_coriolis() + coriolis = f0 + case default + ewrite(-1,*) "coriolis_option:", coriolis_option + FLAbort("Unknown coriolis option") + end select + + end function coriolis + + subroutine update_f_plane_coriolis() + !!< Update python set f-plane Coriolis variables + + if(.not. do_update_f_plane_coriolis()) return + + ewrite(2, *) "Updating f-plane Coriolis from python" + call real_from_python(coriolis_python_func, current_time, f0) + + python_coriolis_initialised = .true. + python_coriolis_time = current_time + + contains + + function do_update_f_plane_coriolis() result(update) + logical :: update + + if(.not. python_coriolis_initialised) then + update = .true. + else + update = python_coriolis_time /= current_time + end if + + end function do_update_f_plane_coriolis + + end subroutine update_f_plane_coriolis + + function funome(xd,yd,zd) + !!< This is a legacy wrapper around coriolis() + !!< it returns omega, not f, so the coriolis force is 2*omega*(k x u) + real :: funome + real, intent(in):: xd,yd,zd + + real, dimension( 1:coriolis_dim, 1 ):: xyz + real, dimension(1) :: omega + + xyz(1,1)=xd + if (size(xyz,1)>1) then + xyz(2,1)=yd + end if + if (size(xyz,1)>2) then + xyz(3,1)=zd end if - end function do_update_f_plane_coriolis - - end subroutine update_f_plane_coriolis - - function funome(xd,yd,zd) - !!< This is a legacy wrapper around coriolis() - !!< it returns omega, not f, so the coriolis force is 2*omega*(k x u) - real :: funome - real, intent(in):: xd,yd,zd - - real, dimension( 1:coriolis_dim, 1 ):: xyz - real, dimension(1) :: omega - - xyz(1,1)=xd - if (size(xyz,1)>1) then - xyz(2,1)=yd - end if - if (size(xyz,1)>2) then - xyz(3,1)=zd - end if - - omega=coriolis(xyz)/2.0 - funome=omega(1) + omega=coriolis(xyz)/2.0 + funome=omega(1) - end function funome + end function funome - subroutine set_coriolis_parameters + subroutine set_coriolis_parameters - real:: omega + real:: omega - if (coriolis_option/=NOT_INITIALISED) return + if (coriolis_option/=NOT_INITIALISED) return - call abort_if_in_parallel_region + call abort_if_in_parallel_region - ewrite(1, *) "Initialising Coriolis" + ewrite(1, *) "Initialising Coriolis" - call get_option("/geometry/dimension", coriolis_dim) + call get_option("/geometry/dimension", coriolis_dim) - if (have_option("/physical_parameters/coriolis/f_plane")) then + if (have_option("/physical_parameters/coriolis/f_plane")) then - ewrite(2, *) "Coriolis type: f-plane" + ewrite(2, *) "Coriolis type: f-plane" - call get_option("/physical_parameters/coriolis/f_plane/f", f0) - coriolis_option=F_PLANE + call get_option("/physical_parameters/coriolis/f_plane/f", f0) + coriolis_option=F_PLANE - else if (have_option("/physical_parameters/coriolis/beta_plane"))& - & then + else if (have_option("/physical_parameters/coriolis/beta_plane"))& + & then - ewrite(2, *) "Coriolis type: beta-plane" + ewrite(2, *) "Coriolis type: beta-plane" - call get_option("/physical_parameters/coriolis/beta_plane/f_0", f0) + call get_option("/physical_parameters/coriolis/beta_plane/f_0", f0) - allocate( coriolis_beta(1:coriolis_dim) ) - call get_option("/physical_parameters/coriolis/& - &beta_plane/beta", coriolis_beta) - coriolis_option=BETA_PLANE + allocate( coriolis_beta(1:coriolis_dim) ) + call get_option("/physical_parameters/coriolis/& + &beta_plane/beta", coriolis_beta) + coriolis_option=BETA_PLANE - else if (have_option("/physical_parameters/coriolis/sine_of_latitude")) then + else if (have_option("/physical_parameters/coriolis/sine_of_latitude")) then - ewrite(2, *) "Coriolis type: Sine of latitude" + ewrite(2, *) "Coriolis type: Sine of latitude" - call get_option("/physical_parameters/coriolis/sine_of_latitude/omega", omega) - f0=2*omega + call get_option("/physical_parameters/coriolis/sine_of_latitude/omega", omega) + f0=2*omega - call get_option("/physical_parameters/coriolis/sine_of_latitude/R_earth", R_earth) - call get_option("/physical_parameters/coriolis/sine_of_latitude/latitude_0", latitude0) + call get_option("/physical_parameters/coriolis/sine_of_latitude/R_earth", R_earth) + call get_option("/physical_parameters/coriolis/sine_of_latitude/latitude_0", latitude0) - coriolis_option=SINE_OF_LATITUDE + coriolis_option=SINE_OF_LATITUDE - else if (have_option("/physical_parameters/coriolis/on_sphere"))& - & then + else if (have_option("/physical_parameters/coriolis/on_sphere"))& + & then - ewrite(2, *) "Coriolis type: On sphere" + ewrite(2, *) "Coriolis type: On sphere" - call get_option("/physical_parameters/coriolis/on_sphere/& - &omega", omega) - f0=2*omega - coriolis_option=CORIOLIS_ON_SPHERE + call get_option("/physical_parameters/coriolis/on_sphere/& + &omega", omega) + f0=2*omega + coriolis_option=CORIOLIS_ON_SPHERE - else if(have_option("/physical_parameters/coriolis/python_f_plane")) then + else if(have_option("/physical_parameters/coriolis/python_f_plane")) then - ewrite(2, *) "Coriolis type: f-plane (python)" + ewrite(2, *) "Coriolis type: f-plane (python)" - call get_option("/physical_parameters/coriolis/python_f_plane", coriolis_python_func) - coriolis_option = PYTHON_F_PLANE + call get_option("/physical_parameters/coriolis/python_f_plane", coriolis_python_func) + coriolis_option = PYTHON_F_PLANE - else + else - ewrite(2, *) "Coriolis type: None" + ewrite(2, *) "Coriolis type: None" - coriolis_option=NO_CORIOLIS + coriolis_option=NO_CORIOLIS - end if + end if - end subroutine set_coriolis_parameters + end subroutine set_coriolis_parameters - subroutine coriolis_module_check_options() + subroutine coriolis_module_check_options() - if (have_option("/geometry/spherical_earth") .and. & - have_option("/physical_parameters/coriolis") .and. & - .not. have_option("/physical_parameters/coriolis/on_sphere")) then + if (have_option("/geometry/spherical_earth") .and. & + have_option("/physical_parameters/coriolis") .and. & + .not. have_option("/physical_parameters/coriolis/on_sphere")) then - ewrite(-1,*) "With /geometry/spherical_earth you need /physical_parameters/coriolis/on_sphere" - FLExit("Fiddle with your FLML and try again...") + ewrite(-1,*) "With /geometry/spherical_earth you need /physical_parameters/coriolis/on_sphere" + FLExit("Fiddle with your FLML and try again...") - end if + end if - if (have_option("/physical_parameters/coriolis/on_sphere") .and. & - .not. have_option("/geometry/spherical_earth")) then + if (have_option("/physical_parameters/coriolis/on_sphere") .and. & + .not. have_option("/geometry/spherical_earth")) then - ewrite(-1,*) "With /physical_parameters/coriolis/on_sphere you need /geometry/spherical_earth." - FLExit("Fiddle with your FLML and try again...") + ewrite(-1,*) "With /physical_parameters/coriolis/on_sphere you need /geometry/spherical_earth." + FLExit("Fiddle with your FLML and try again...") - end if + end if - end subroutine coriolis_module_check_options + end subroutine coriolis_module_check_options end module coriolis_module diff --git a/assemble/Diagnostic_Children.F90 b/assemble/Diagnostic_Children.F90 index 8f8e7c372e..27261ba7a6 100644 --- a/assemble/Diagnostic_Children.F90 +++ b/assemble/Diagnostic_Children.F90 @@ -27,61 +27,61 @@ #include "fdebug.h" module diagnostic_children -use spud -use fields -use state_module -use diagnostic_fields_wrapper_new, only: calculate_diagnostic_variable + use spud + use fields + use state_module + use diagnostic_fields_wrapper_new, only: calculate_diagnostic_variable -private + private -public :: calculate_diagnostic_children + public :: calculate_diagnostic_children contains - subroutine calculate_diagnostic_children(states, istate, field) - !!< Calculates the diagnostic child fields of a prognostic scalar field - type(state_type), dimension(:), intent(inout):: states - integer, intent(in):: istate - type(scalar_field), intent(in):: field + subroutine calculate_diagnostic_children(states, istate, field) + !!< Calculates the diagnostic child fields of a prognostic scalar field + type(state_type), dimension(:), intent(inout):: states + integer, intent(in):: istate + type(scalar_field), intent(in):: field - ! scalar child fields that can be handled by just calling - ! calculate_diagnostic_variable - character(len=*), dimension(1:3), parameter :: generic_scalar_child_field_names = & - (/ "Source ", & + ! scalar child fields that can be handled by just calling + ! calculate_diagnostic_variable + character(len=*), dimension(1:3), parameter :: generic_scalar_child_field_names = & + (/ "Source ", & "Absorption ", & "SinkingVelocity" /) - type(tensor_field), pointer:: tfield - type(scalar_field), pointer:: sfield - logical:: diagnostic - integer:: i, stat + type(tensor_field), pointer:: tfield + type(scalar_field), pointer:: sfield + logical:: diagnostic + integer:: i, stat - ! first the scalar child fields - do i=1, size(generic_scalar_child_field_names) - sfield => extract_scalar_field(states(istate), & - trim(field%name)//generic_scalar_child_field_names(i), stat) - if (stat==0) then - diagnostic = have_option(trim(sfield%option_path)//'/diagnostic') - if(diagnostic) then - call calculate_diagnostic_variable(states, istate, sfield) - end if - end if - end do + ! first the scalar child fields + do i=1, size(generic_scalar_child_field_names) + sfield => extract_scalar_field(states(istate), & + trim(field%name)//generic_scalar_child_field_names(i), stat) + if (stat==0) then + diagnostic = have_option(trim(sfield%option_path)//'/diagnostic') + if(diagnostic) then + call calculate_diagnostic_variable(states, istate, sfield) + end if + end if + end do - ! no vector child fields at the moment + ! no vector child fields at the moment - ! only one tensor child field - tfield => extract_tensor_field(states(istate), & - trim(field%name)//"Diffusivity", stat) - if (stat==0) then - diagnostic = have_option(trim(tfield%option_path)//'/diagnostic') - ! the check for .not. tfield%aliased is a temporary hack to deal with - ! the subgridparameterisation diffusivity fields - if(diagnostic) then - call calculate_diagnostic_variable(states, istate, tfield) + ! only one tensor child field + tfield => extract_tensor_field(states(istate), & + trim(field%name)//"Diffusivity", stat) + if (stat==0) then + diagnostic = have_option(trim(tfield%option_path)//'/diagnostic') + ! the check for .not. tfield%aliased is a temporary hack to deal with + ! the subgridparameterisation diffusivity fields + if(diagnostic) then + call calculate_diagnostic_variable(states, istate, tfield) + end if end if - end if - end subroutine calculate_diagnostic_children + end subroutine calculate_diagnostic_children end module diagnostic_children diff --git a/assemble/Diagnostic_Fields_Matrices.F90 b/assemble/Diagnostic_Fields_Matrices.F90 index e3cc6f6b97..01007c5869 100644 --- a/assemble/Diagnostic_Fields_Matrices.F90 +++ b/assemble/Diagnostic_Fields_Matrices.F90 @@ -28,43 +28,43 @@ #include "fdebug.h" module diagnostic_fields_matrices - !!< A module to link to diagnostic variable calculations. - - use fldebug - use global_parameters, only:FIELD_NAME_LEN - use futils - use spud - use parallel_tools - use sparse_tools - use transform_elements - use fetools - use parallel_fields, only: zero_non_owned, element_owned - use fields - use sparse_matrices_fields - use state_module - use halos - use field_derivatives - use sparsity_patterns, only: make_sparsity - use sparsity_patterns_meshes - use state_fields_module - use solvers - use divergence_matrix_cv, only: assemble_divergence_matrix_cv - use divergence_matrix_cg, only: assemble_divergence_matrix_cg, assemble_compressible_divergence_matrix_cg - use gradient_matrix_cg, only: assemble_gradient_matrix_cg - use state_matrices_module - - implicit none - - private - - public :: calculate_divergence_cv, calculate_divergence_fe, & - calculate_div_t_cv, calculate_div_t_fe, & - calculate_grad_fe, calculate_sum_velocity_divergence, & - calculate_compressible_continuity_residual + !!< A module to link to diagnostic variable calculations. + + use fldebug + use global_parameters, only:FIELD_NAME_LEN + use futils + use spud + use parallel_tools + use sparse_tools + use transform_elements + use fetools + use parallel_fields, only: zero_non_owned, element_owned + use fields + use sparse_matrices_fields + use state_module + use halos + use field_derivatives + use sparsity_patterns, only: make_sparsity + use sparsity_patterns_meshes + use state_fields_module + use solvers + use divergence_matrix_cv, only: assemble_divergence_matrix_cv + use divergence_matrix_cg, only: assemble_divergence_matrix_cg, assemble_compressible_divergence_matrix_cg + use gradient_matrix_cg, only: assemble_gradient_matrix_cg + use state_matrices_module + + implicit none + + private + + public :: calculate_divergence_cv, calculate_divergence_fe, & + calculate_div_t_cv, calculate_div_t_fe, & + calculate_grad_fe, calculate_sum_velocity_divergence, & + calculate_compressible_continuity_residual contains - subroutine calculate_divergence_cv(state, div) + subroutine calculate_divergence_cv(state, div) type(state_type), intent(inout) :: state type(scalar_field), intent(inout) :: div @@ -105,9 +105,9 @@ subroutine calculate_divergence_cv(state, div) call halo_update(div) - end subroutine calculate_divergence_cv + end subroutine calculate_divergence_cv - subroutine calculate_div_t_cv(state, grad) + subroutine calculate_div_t_cv(state, grad) type(state_type), intent(inout) :: state type(vector_field), intent(inout) :: grad @@ -130,9 +130,9 @@ subroutine calculate_div_t_cv(state, grad) dg = (continuity(grad)<0) lump_mass = have_option(trim(grad%option_path)//& - &"/diagnostic/lump_mass_matrix") + &"/diagnostic/lump_mass_matrix") normalise = have_option(trim(grad%option_path)//& - &"/diagnostic/normalise") + &"/diagnostic/normalise") field=>extract_scalar_field(state, trim(field_name)) @@ -147,38 +147,38 @@ subroutine calculate_div_t_cv(state, grad) if(lump_mass) then - lumped_mass => get_lumped_mass(state, grad%mesh) - call allocate(inverse_lumped_mass, lumped_mass%mesh, "InverseLumpedMass") + lumped_mass => get_lumped_mass(state, grad%mesh) + call allocate(inverse_lumped_mass, lumped_mass%mesh, "InverseLumpedMass") - call invert(lumped_mass, inverse_lumped_mass) - call set(grad, cfield) - call scale(grad, inverse_lumped_mass) + call invert(lumped_mass, inverse_lumped_mass) + call set(grad, cfield) + call scale(grad, inverse_lumped_mass) - call deallocate(inverse_lumped_mass) + call deallocate(inverse_lumped_mass) else if(dg) then - inverse_mass => get_dg_inverse_mass(state, grad%mesh) - call mult(grad, inverse_mass, cfield) + inverse_mass => get_dg_inverse_mass(state, grad%mesh) + call mult(grad, inverse_mass, cfield) else - mass => get_mass_matrix(state, grad%mesh) - call petsc_solve(grad, mass, cfield) + mass => get_mass_matrix(state, grad%mesh) + call petsc_solve(grad, mass, cfield) end if if(normalise) then - mag = magnitude(grad) - call allocate(inverse_mag, mag%mesh, "InverseMagnitude") + mag = magnitude(grad) + call allocate(inverse_mag, mag%mesh, "InverseMagnitude") - call invert(mag, inverse_mag, tolerance=epsilon(0.0)) - call scale(grad, inverse_mag) + call invert(mag, inverse_mag, tolerance=epsilon(0.0)) + call scale(grad, inverse_mag) - call deallocate(inverse_mag) - call deallocate(mag) + call deallocate(inverse_mag) + call deallocate(mag) end if call deallocate(cfield) - end subroutine calculate_div_t_cv + end subroutine calculate_div_t_cv - subroutine calculate_divergence_fe(state, div) + subroutine calculate_divergence_fe(state, div) type(state_type), intent(inout) :: state type(scalar_field), intent(inout) :: div @@ -212,8 +212,8 @@ subroutine calculate_divergence_fe(state, div) call zero(mass) call assemble_divergence_matrix_cg(CT_m, state, ct_rhs=ct_rhs, & - test_mesh=div%mesh, field=field, & - option_path=div%option_path, div_mass=mass) + test_mesh=div%mesh, field=field, & + option_path=div%option_path, div_mass=mass) call mult(ctfield, CT_m, field) call addto(ctfield, ct_rhs, -1.0) @@ -229,9 +229,9 @@ subroutine calculate_divergence_fe(state, div) call deallocate(mass_sparsity) call deallocate(mass) - end subroutine calculate_divergence_fe + end subroutine calculate_divergence_fe - subroutine calculate_div_t_fe(state, grad) + subroutine calculate_div_t_fe(state, grad) type(state_type), intent(inout) :: state type(vector_field), intent(inout) :: grad @@ -263,8 +263,8 @@ subroutine calculate_div_t_fe(state, grad) call allocate(mass, mass_sparsity, name="MassMatrix") call assemble_divergence_matrix_cg(CT_m, state, & - test_mesh=field%mesh, field=grad, & - grad_mass=mass) + test_mesh=field%mesh, field=grad, & + grad_mass=mass) call mult_T(cfield, CT_m, field) call scale(cfield, -1.0) @@ -279,9 +279,9 @@ subroutine calculate_div_t_fe(state, grad) call deallocate(mass) call deallocate(cfield) - end subroutine calculate_div_t_fe + end subroutine calculate_div_t_fe - subroutine calculate_grad_fe(state, grad) + subroutine calculate_grad_fe(state, grad) type(state_type), intent(inout) :: state type(vector_field), intent(inout) :: grad @@ -312,9 +312,9 @@ subroutine calculate_grad_fe(state, grad) call allocate(mass, mass_sparsity, name="MassMatrix") call assemble_gradient_matrix_cg(C_m, state, & - test_mesh=grad%mesh, field=field, & - option_path=trim(grad%option_path), & - grad_mass=mass) + test_mesh=grad%mesh, field=field, & + option_path=trim(grad%option_path), & + grad_mass=mass) call mult(cfield, C_m, field) @@ -327,10 +327,10 @@ subroutine calculate_grad_fe(state, grad) call deallocate(mass) call deallocate(cfield) - end subroutine calculate_grad_fe + end subroutine calculate_grad_fe - subroutine calculate_sum_velocity_divergence(state, sum_velocity_divergence) + subroutine calculate_sum_velocity_divergence(state, sum_velocity_divergence) !!< Calculates \sum{div(vfrac*u)}, where we sum over each prognostic velocity !!< field (i.e. each phase). Used in multiphase flow simulations. @@ -392,16 +392,16 @@ subroutine calculate_sum_velocity_divergence(state, sum_velocity_divergence) ! Reassemble C^T matrix here if (test_with_cv_dual) then call assemble_divergence_matrix_cv(ct_m, state(i), ct_rhs=ct_rhs, & - test_mesh=sum_velocity_divergence%mesh, field=u) + test_mesh=sum_velocity_divergence%mesh, field=u) else if(i==1) then ! Construct the mass matrix (just do this once) call assemble_divergence_matrix_cg(ct_m, state(i), ct_rhs=ct_rhs, & - test_mesh=sum_velocity_divergence%mesh, field=u, & - option_path=sum_velocity_divergence%option_path, div_mass=mass) + test_mesh=sum_velocity_divergence%mesh, field=u, & + option_path=sum_velocity_divergence%option_path, div_mass=mass) else call assemble_divergence_matrix_cg(ct_m, state(i), ct_rhs=ct_rhs, & - test_mesh=sum_velocity_divergence%mesh, field=u, & - option_path=sum_velocity_divergence%option_path) + test_mesh=sum_velocity_divergence%mesh, field=u, & + option_path=sum_velocity_divergence%option_path) end if end if @@ -445,10 +445,10 @@ subroutine calculate_sum_velocity_divergence(state, sum_velocity_divergence) ewrite(1,*) 'Exiting calculate_sum_velocity_divergence' - end subroutine calculate_sum_velocity_divergence + end subroutine calculate_sum_velocity_divergence - subroutine calculate_compressible_continuity_residual(state, compressible_continuity_residual) + subroutine calculate_compressible_continuity_residual(state, compressible_continuity_residual) !!< Calculates the residual of the continity equation used in compressible multiphase flow simulations: !!< vfrac_c*d(rho_c)/dt + div(rho_c*vfrac_c*u_c) + \sum_i{ rho_c*div(vfrac_i*u_i) } @@ -588,7 +588,7 @@ subroutine calculate_compressible_continuity_residual(state, compressible_contin ewrite(1,*) 'Exiting calculate_compressible_continuity_residual' - end subroutine calculate_compressible_continuity_residual + end subroutine calculate_compressible_continuity_residual end module diagnostic_fields_matrices diff --git a/assemble/Diagnostic_fields_wrapper.F90 b/assemble/Diagnostic_fields_wrapper.F90 index 4813743f70..bae07caed0 100644 --- a/assemble/Diagnostic_fields_wrapper.F90 +++ b/assemble/Diagnostic_fields_wrapper.F90 @@ -28,595 +28,595 @@ #include "fdebug.h" module diagnostic_fields_wrapper - !!< A module to link to diagnostic variable calculations. - - use fldebug - use global_parameters, only: FIELD_NAME_LEN, timestep - use futils - use spud - use parallel_tools - use fetools - use fields - use sparse_matrices_fields - use state_module - use field_derivatives - use field_options, only: do_not_recalculate - use diagnostic_fields, only: calculate_diagnostic_variable - use equation_of_state - use multiphase_module - use diagnostic_fields_matrices - use multimaterial_module, only: calculate_material_mass, & - calculate_bulk_material_pressure, & - calculate_sum_material_volume_fractions, & - calculate_material_volume - use tidal_module, only: calculate_diagnostic_equilibrium_pressure - use free_surface_module, only: calculate_diagnostic_free_surface, & - calculate_diagnostic_wettingdrying_alpha - use vorticity_diagnostics - use momentum_diagnostic_fields - use sediment_diagnostics - use dqmom - use geostrophic_pressure - - implicit none - - private - - public :: calculate_diagnostic_variables + !!< A module to link to diagnostic variable calculations. + + use fldebug + use global_parameters, only: FIELD_NAME_LEN, timestep + use futils + use spud + use parallel_tools + use fetools + use fields + use sparse_matrices_fields + use state_module + use field_derivatives + use field_options, only: do_not_recalculate + use diagnostic_fields, only: calculate_diagnostic_variable + use equation_of_state + use multiphase_module + use diagnostic_fields_matrices + use multimaterial_module, only: calculate_material_mass, & + calculate_bulk_material_pressure, & + calculate_sum_material_volume_fractions, & + calculate_material_volume + use tidal_module, only: calculate_diagnostic_equilibrium_pressure + use free_surface_module, only: calculate_diagnostic_free_surface, & + calculate_diagnostic_wettingdrying_alpha + use vorticity_diagnostics + use momentum_diagnostic_fields + use sediment_diagnostics + use dqmom + use geostrophic_pressure + + implicit none + + private + + public :: calculate_diagnostic_variables contains - subroutine calculate_diagnostic_variables(state, exclude_nonrecalculated) - !!< Updates diagnostic fields in the supplied states. + subroutine calculate_diagnostic_variables(state, exclude_nonrecalculated) + !!< Updates diagnostic fields in the supplied states. - type(state_type), dimension(:) :: state - logical, intent(in), optional :: exclude_nonrecalculated + type(state_type), dimension(:) :: state + logical, intent(in), optional :: exclude_nonrecalculated - integer :: i,stat - type(scalar_field), pointer :: s_field - type(vector_field), pointer :: v_field - logical :: diagnostic - integer :: diagnostic_particles + integer :: i,stat + type(scalar_field), pointer :: s_field + type(vector_field), pointer :: v_field + logical :: diagnostic + integer :: diagnostic_particles - ! An array of submaterials of the current phase in state(istate). - type(state_type), dimension(:), pointer :: submaterials + ! An array of submaterials of the current phase in state(istate). + type(state_type), dimension(:), pointer :: submaterials - ewrite(1, *) "In calculate_diagnostic_variables" + ewrite(1, *) "In calculate_diagnostic_variables" - do i = 1, size(state) + do i = 1, size(state) - ! start of fields that can be called through the generic calculate_diagnostic_variable - ! interface, i.e. - those that only require things available in f90modules + ! start of fields that can be called through the generic calculate_diagnostic_variable + ! interface, i.e. - those that only require things available in f90modules - s_field => extract_scalar_field(state(i), "CFLNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "CFLNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "CFLNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "CFLNumber", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "GridReynoldsNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "GridReynoldsNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "GridReynoldsNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "GridReynoldsNumber", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "GridPecletNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "GridPecletNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "GridPecletNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "GridPecletNumber", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "ControlVolumeCFLNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "ControlVolumeCFLNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "ControlVolumeCFLNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "ControlVolumeCFLNumber", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "DG_CourantNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "DG_CourantNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "DG_CourantNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "DG_CourantNumber", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "CVMaterialDensityCFLNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "CVMaterialDensityCFLNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "CVMaterialDensityCFLNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "CVMaterialDensityCFLNumber", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "KineticEnergyDensity", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "KineticEnergyDensity", & - & s_field) + s_field => extract_scalar_field(state(i), "KineticEnergyDensity", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "KineticEnergyDensity", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "HorizontalVelocityDivergence", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "HorizontalVelocityDivergence", s_field) + s_field => extract_scalar_field(state(i), "HorizontalVelocityDivergence", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "HorizontalVelocityDivergence", s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), & + s_field => extract_scalar_field(state(i), & & "VelocityDivergence", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "VelocityDivergence", s_field) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "VelocityDivergence", s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), & + s_field => extract_scalar_field(state(i), & & "PerturbationDensity", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - ! this routine returns the density used in the buoyancy term, which we're not really interested in - ! but it computes the PerturbationDensity as a side effect. Note that this means it will happen twice - ! as it will be recalculated at the beginning of Momemtum_Equation after the Temperature and Salinity - ! fields have been solved for. - call calculate_perturbation_density(state(i), s_field) - end if - end if - - ! this diagnostic field depends on PerturbationDensity - s_field => extract_scalar_field(state(i), "GravitationalPotentialEnergyDensity", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "GravitationalPotentialEnergyDensity", s_field) - end if - end if - - ! this diagnostic field depends on PerturbationDensity - s_field => extract_scalar_field(state(i), "IsopycnalCoordinate", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "IsopycnalCoordinate", & - & s_field) - end if - end if - - ! Must be calculated after IsopycnalCoordinate - s_field => extract_scalar_field(state(i), "BackgroundPotentialEnergyDensity", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "BackgroundPotentialEnergyDensity", s_field) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + ! this routine returns the density used in the buoyancy term, which we're not really interested in + ! but it computes the PerturbationDensity as a side effect. Note that this means it will happen twice + ! as it will be recalculated at the beginning of Momemtum_Equation after the Temperature and Salinity + ! fields have been solved for. + call calculate_perturbation_density(state(i), s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "InnerElementFullVelocity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "InnerElementFullVelocity", & - & v_field) + ! this diagnostic field depends on PerturbationDensity + s_field => extract_scalar_field(state(i), "GravitationalPotentialEnergyDensity", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "GravitationalPotentialEnergyDensity", s_field) + end if end if - end if - ! Must be calculated after InnerElementFullVelocity - v_field => extract_vector_field(state(i), "InnerElementFullVorticity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "InnerElementFullVorticity", & - & v_field) + ! this diagnostic field depends on PerturbationDensity + s_field => extract_scalar_field(state(i), "IsopycnalCoordinate", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "IsopycnalCoordinate", & + & s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "InnerElementVorticity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "InnerElementVorticity", & - & v_field) + ! Must be calculated after IsopycnalCoordinate + s_field => extract_scalar_field(state(i), "BackgroundPotentialEnergyDensity", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "BackgroundPotentialEnergyDensity", s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "DgMappedVelocity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "DgMappedVelocity", & - & v_field) + v_field => extract_vector_field(state(i), "InnerElementFullVelocity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "InnerElementFullVelocity", & + & v_field) + end if end if - end if - v_field => extract_vector_field(state(i), "DgMappedVorticity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "DgMappedVorticity", & - & v_field) + ! Must be calculated after InnerElementFullVelocity + v_field => extract_vector_field(state(i), "InnerElementFullVorticity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "InnerElementFullVorticity", & + & v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "HorizontalStreamFunction", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "HorizontalStreamFunction", s_field) + v_field => extract_vector_field(state(i), "InnerElementVorticity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "InnerElementVorticity", & + & v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "Speed", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "Speed", & - & s_field) + v_field => extract_vector_field(state(i), "DgMappedVelocity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "DgMappedVelocity", & + & v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "DiffusiveDissipation", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "DiffusiveDissipation", & - & s_field) + v_field => extract_vector_field(state(i), "DgMappedVorticity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "DgMappedVorticity", & + & v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "RichardsonNumber", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "RichardsonNumber", & - & s_field) + s_field => extract_scalar_field(state(i), "HorizontalStreamFunction", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "HorizontalStreamFunction", s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "StreamFunction", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "StreamFunction", s_field) + s_field => extract_scalar_field(state(i), "Speed", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "Speed", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "MultiplyConnectedStreamFunction", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "MultiplyConnectedStreamFunction", s_field) + s_field => extract_scalar_field(state(i), "DiffusiveDissipation", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "DiffusiveDissipation", & + & s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "Time", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "Time", s_field) + s_field => extract_scalar_field(state(i), "RichardsonNumber", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "RichardsonNumber", & + & s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "LinearMomentum", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "LinearMomentum", v_field) + s_field => extract_scalar_field(state(i), "StreamFunction", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "StreamFunction", s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "DiagnosticCoordinate", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "DiagnosticCoordinate", v_field) + s_field => extract_scalar_field(state(i), "MultiplyConnectedStreamFunction", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "MultiplyConnectedStreamFunction", s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "BedShearStress", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "BedShearStress", v_field) - end if - end if - - v_field => extract_vector_field(state(i), "MaxBedShearStress", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "MaxBedShearStress", v_field) - end if - end if - - s_field => extract_scalar_field(state(i), "GalerkinProjection", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "GalerkinProjection", s_field) - end if - end if - - v_field => extract_vector_field(state(i), "GalerkinProjection", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "GalerkinProjection", v_field) + s_field => extract_scalar_field(state(i), "Time", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "Time", s_field) + end if end if - end if - - s_field => extract_scalar_field(state(i), "UniversalNumber", stat) - if(stat == 0) then - call calculate_diagnostic_variable(state(i), "UniversalNumber", s_field) - end if - s_field => extract_scalar_field(state(i), "NodeOwner", stat) - if(stat == 0) then - call calculate_diagnostic_variable(state(i), "NodeOwner", s_field) - end if + v_field => extract_vector_field(state(i), "LinearMomentum", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "LinearMomentum", v_field) + end if + end if - ! end of fields that can be called through the generic calculate_diagnostic_variable - ! interface, i.e. - those that only require things available in f90modules + v_field => extract_vector_field(state(i), "DiagnosticCoordinate", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "DiagnosticCoordinate", v_field) + end if + end if - ! start of fields that cannot be called through the generic calculate_diagnostic_variable - ! interface, i.e. - those that need things from assemble - s_field => extract_scalar_field(state(i), "ControlVolumeDivergence", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_divergence_cv(state(i), s_field) + v_field => extract_vector_field(state(i), "BedShearStress", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "BedShearStress", v_field) + end if end if - end if - - s_field => extract_scalar_field(state(i), "FiniteElementDivergence", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_divergence_fe(state(i), s_field) + + v_field => extract_vector_field(state(i), "MaxBedShearStress", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "MaxBedShearStress", v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "MaterialVolumeFraction", stat) - if(stat == 0) then - diagnostic = have_option(trim(s_field%option_path)//"/diagnostic/algorithm::Internal") - !Check if any other MaterialVolumeFraction field is set from particles, if so don't calculate internal MVF here - diagnostic_particles = option_count("material_phase/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::from_particles") - if(diagnostic .and. .not. aliased(s_field) .and. diagnostic_particles == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_sum_material_volume_fractions(state, s_field) - call scale(s_field, -1.0) - call addto(s_field, 1.0) - end if + s_field => extract_scalar_field(state(i), "GalerkinProjection", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "GalerkinProjection", s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "MaterialMass", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_material_mass(state(i), s_field) + v_field => extract_vector_field(state(i), "GalerkinProjection", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "GalerkinProjection", v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "MaterialVolume", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_material_volume(state(i), s_field) + s_field => extract_scalar_field(state(i), "UniversalNumber", stat) + if(stat == 0) then + call calculate_diagnostic_variable(state(i), "UniversalNumber", s_field) end if - end if - s_field => extract_scalar_field(state(i), "MaterialDensity", stat) - if(stat == 0) then - diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") - if(diagnostic .and. .not.(aliased(s_field))) then - if(recalculate(trim(s_field%option_path))) then - call calculate_densities(state(i), bulk_density=s_field) - end if + s_field => extract_scalar_field(state(i), "NodeOwner", stat) + if(stat == 0) then + call calculate_diagnostic_variable(state(i), "NodeOwner", s_field) end if - end if - s_field => extract_scalar_field(state(i), "Density", stat) - if(stat == 0) then - diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") - if(diagnostic .and. .not.(aliased(s_field))) then - if(recalculate(trim(s_field%option_path))) then - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - call get_phase_submaterials(state, i, submaterials) - call calculate_densities(submaterials, bulk_density=s_field) - deallocate(submaterials) - else - call calculate_densities(state, bulk_density=s_field) - end if - end if + ! end of fields that can be called through the generic calculate_diagnostic_variable + ! interface, i.e. - those that only require things available in f90modules + + ! start of fields that cannot be called through the generic calculate_diagnostic_variable + ! interface, i.e. - those that need things from assemble + s_field => extract_scalar_field(state(i), "ControlVolumeDivergence", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_divergence_cv(state(i), s_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "MaterialEOSDensity", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call compressible_material_eos(state(i), materialdensity=s_field) - end if - end if - - s_field => extract_scalar_field(state(i), "MaterialPressure", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call compressible_material_eos(state(i), materialpressure=s_field) - end if - end if - - s_field => extract_scalar_field(state(i), "BulkMaterialPressure", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_bulk_material_pressure(state, s_field) - end if - end if - - s_field => extract_scalar_field(state(i), "SumMaterialVolumeFractions", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_sum_material_volume_fractions(state, s_field) - end if - end if - - s_field => extract_scalar_field(state(i), "FreeSurface", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_free_surface(state(i), s_field) - end if - end if - - s_field => extract_scalar_field(state(i), "WettingDryingAlpha", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_wettingdrying_alpha(state(i), s_field) - end if - end if - - s_field => extract_scalar_field(state(i), "EquilibriumPressure", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_equilibrium_pressure(state(i), s_field) - end if - end if - - v_field => extract_vector_field(state(i), "ControlVolumeDivergenceTransposed", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_div_t_cv(state(i), v_field) - end if - end if - - v_field => extract_vector_field(state(i), "FiniteElementGradient", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_grad_fe(state(i), v_field) - end if - end if - - v_field => extract_vector_field(state(i), "FiniteElementDivergenceTransposed", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_div_t_fe(state(i), v_field) - end if - end if - - v_field => extract_vector_field(state(i), "PlanetaryVorticity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_planetary_vorticity(state(i), v_field) - end if - end if - - v_field => extract_vector_field(state(i), "AbsoluteVorticity", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_absolute_vorticity(state(i), v_field) - end if - end if - - s_field => extract_scalar_field(state(i), "PotentialVorticity", stat) - if(stat == 0) then - diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") - if(diagnostic .and. recalculate(trim(s_field%option_path))) then - call calculate_potential_vorticity(state(i), s_field) - end if - end if + s_field => extract_scalar_field(state(i), "FiniteElementDivergence", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_divergence_fe(state(i), s_field) + end if + end if - s_field => extract_scalar_field(state(i), "RelativePotentialVorticity", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_relative_potential_vorticity(state(i), s_field) + s_field => extract_scalar_field(state(i), "MaterialVolumeFraction", stat) + if(stat == 0) then + diagnostic = have_option(trim(s_field%option_path)//"/diagnostic/algorithm::Internal") + !Check if any other MaterialVolumeFraction field is set from particles, if so don't calculate internal MVF here + diagnostic_particles = option_count("material_phase/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::from_particles") + if(diagnostic .and. .not. aliased(s_field) .and. diagnostic_particles == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_sum_material_volume_fractions(state, s_field) + call scale(s_field, -1.0) + call addto(s_field, 1.0) + end if + end if end if - end if - ! End of vorticity diagnostics - ! Start of sediment diagnostics. - if (have_option("/material_phase[0]/sediment")) then - call calculate_sediment_sinking_velocity(state(i)) - call calculate_sediment_active_layer_d50(state(i)) - call calculate_sediment_active_layer_sigma(state(i)) - call calculate_sediment_active_layer_volume_fractions(state(i)) - end if - ! End of sediment diagnostics. + s_field => extract_scalar_field(state(i), "MaterialMass", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_material_mass(state(i), s_field) + end if + end if - ! Start of population balance diagnostics. - call dqmom_calculate_moments(state(i)) - call dqmom_calculate_statistics(state(i)) - ! End of population balance diagnostics. + s_field => extract_scalar_field(state(i), "MaterialVolume", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_material_volume(state(i), s_field) + end if + end if - ! Multiphase-related diagnostic fields - s_field => extract_scalar_field(state(i), "PhaseVolumeFraction", stat) - if(stat == 0) then - diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") - if(diagnostic .and. .not.(aliased(s_field))) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_phase_volume_fraction(state) - end if + s_field => extract_scalar_field(state(i), "MaterialDensity", stat) + if(stat == 0) then + diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") + if(diagnostic .and. .not.(aliased(s_field))) then + if(recalculate(trim(s_field%option_path))) then + call calculate_densities(state(i), bulk_density=s_field) + end if + end if end if - end if - s_field => extract_scalar_field(state(i), "SumVelocityDivergence", stat) - if(stat == 0) then - ! Check that we are running a multiphase simulation - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + s_field => extract_scalar_field(state(i), "Density", stat) + if(stat == 0) then diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") if(diagnostic .and. .not.(aliased(s_field))) then if(recalculate(trim(s_field%option_path))) then - call calculate_sum_velocity_divergence(state, s_field) + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + call get_phase_submaterials(state, i, submaterials) + call calculate_densities(submaterials, bulk_density=s_field) + deallocate(submaterials) + else + call calculate_densities(state, bulk_density=s_field) + end if end if end if - else - FLExit("The SumVelocityDivergence field is only used in multiphase simulations.") end if - end if - s_field => extract_scalar_field(state(i), "CompressibleContinuityResidual", stat) - if(stat == 0) then - ! Check that we are running a compressible multiphase simulation - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1 .and. option_count("/material_phase/equation_of_state/compressible") > 0) then + s_field => extract_scalar_field(state(i), "MaterialEOSDensity", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call compressible_material_eos(state(i), materialdensity=s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "MaterialPressure", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call compressible_material_eos(state(i), materialpressure=s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "BulkMaterialPressure", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_bulk_material_pressure(state, s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "SumMaterialVolumeFractions", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_sum_material_volume_fractions(state, s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "FreeSurface", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_free_surface(state(i), s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "WettingDryingAlpha", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_wettingdrying_alpha(state(i), s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "EquilibriumPressure", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_equilibrium_pressure(state(i), s_field) + end if + end if + + v_field => extract_vector_field(state(i), "ControlVolumeDivergenceTransposed", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_div_t_cv(state(i), v_field) + end if + end if + + v_field => extract_vector_field(state(i), "FiniteElementGradient", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_grad_fe(state(i), v_field) + end if + end if + + v_field => extract_vector_field(state(i), "FiniteElementDivergenceTransposed", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_div_t_fe(state(i), v_field) + end if + end if + + v_field => extract_vector_field(state(i), "PlanetaryVorticity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_planetary_vorticity(state(i), v_field) + end if + end if + + v_field => extract_vector_field(state(i), "AbsoluteVorticity", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_absolute_vorticity(state(i), v_field) + end if + end if + + s_field => extract_scalar_field(state(i), "PotentialVorticity", stat) + if(stat == 0) then + diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") + if(diagnostic .and. recalculate(trim(s_field%option_path))) then + call calculate_potential_vorticity(state(i), s_field) + end if + end if + + s_field => extract_scalar_field(state(i), "RelativePotentialVorticity", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_relative_potential_vorticity(state(i), s_field) + end if + end if + ! End of vorticity diagnostics + + ! Start of sediment diagnostics. + if (have_option("/material_phase[0]/sediment")) then + call calculate_sediment_sinking_velocity(state(i)) + call calculate_sediment_active_layer_d50(state(i)) + call calculate_sediment_active_layer_sigma(state(i)) + call calculate_sediment_active_layer_volume_fractions(state(i)) + end if + ! End of sediment diagnostics. + + ! Start of population balance diagnostics. + call dqmom_calculate_moments(state(i)) + call dqmom_calculate_statistics(state(i)) + ! End of population balance diagnostics. + + ! Multiphase-related diagnostic fields + s_field => extract_scalar_field(state(i), "PhaseVolumeFraction", stat) + if(stat == 0) then diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") if(diagnostic .and. .not.(aliased(s_field))) then if(recalculate(trim(s_field%option_path))) then - call calculate_compressible_continuity_residual(state, s_field) + call calculate_diagnostic_phase_volume_fraction(state) end if end if - else - FLExit("The CompressibleContinuityResidual field is only used in compressible multiphase simulations.") end if - end if - ! end of fields that cannot be called through the generic - ! calculate_diagnostic_variable interface, i.e. - those that need things - ! higher than femtools in the build + s_field => extract_scalar_field(state(i), "SumVelocityDivergence", stat) + if(stat == 0) then + ! Check that we are running a multiphase simulation + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") + if(diagnostic .and. .not.(aliased(s_field))) then + if(recalculate(trim(s_field%option_path))) then + call calculate_sum_velocity_divergence(state, s_field) + end if + end if + else + FLExit("The SumVelocityDivergence field is only used in multiphase simulations.") + end if + end if - ! the following fields need to be here in case they are taking the difference with - ! other diagnostic fields - s_field => extract_scalar_field(state(i), "ScalarAbsoluteDifference", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "AbsoluteDifference", s_field) + s_field => extract_scalar_field(state(i), "CompressibleContinuityResidual", stat) + if(stat == 0) then + ! Check that we are running a compressible multiphase simulation + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1 .and. option_count("/material_phase/equation_of_state/compressible") > 0) then + diagnostic = have_option(trim(s_field%option_path)//"/diagnostic") + if(diagnostic .and. .not.(aliased(s_field))) then + if(recalculate(trim(s_field%option_path))) then + call calculate_compressible_continuity_residual(state, s_field) + end if + end if + else + FLExit("The CompressibleContinuityResidual field is only used in compressible multiphase simulations.") + end if end if - end if - v_field => extract_vector_field(state(i), "VectorAbsoluteDifference", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "AbsoluteDifference", v_field) + ! end of fields that cannot be called through the generic + ! calculate_diagnostic_variable interface, i.e. - those that need things + ! higher than femtools in the build + + ! the following fields need to be here in case they are taking the difference with + ! other diagnostic fields + s_field => extract_scalar_field(state(i), "ScalarAbsoluteDifference", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "AbsoluteDifference", s_field) + end if + end if + + v_field => extract_vector_field(state(i), "VectorAbsoluteDifference", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "AbsoluteDifference", v_field) + end if end if - end if - s_field => extract_scalar_field(state(i), "AbsoluteDifference", stat) - if(stat == 0) then - if(recalculate(trim(s_field%option_path))) then - call calculate_diagnostic_variable(state(i), "AbsoluteDifference", s_field) + s_field => extract_scalar_field(state(i), "AbsoluteDifference", stat) + if(stat == 0) then + if(recalculate(trim(s_field%option_path))) then + call calculate_diagnostic_variable(state(i), "AbsoluteDifference", s_field) + end if end if - end if - v_field => extract_vector_field(state(i), "AbsoluteDifference", stat) - if(stat == 0) then - if(recalculate(trim(v_field%option_path))) then - call calculate_diagnostic_variable(state(i), "AbsoluteDifference", v_field) + v_field => extract_vector_field(state(i), "AbsoluteDifference", stat) + if(stat == 0) then + if(recalculate(trim(v_field%option_path))) then + call calculate_diagnostic_variable(state(i), "AbsoluteDifference", v_field) + end if end if - end if - end do + end do - ewrite(1, *) "Exiting calculate_diagnostic_variables" + ewrite(1, *) "Exiting calculate_diagnostic_variables" - contains + contains - logical function recalculate(option_path) - character(len=*) :: option_path + logical function recalculate(option_path) + character(len=*) :: option_path - recalculate = ((.not.present_and_true(exclude_nonrecalculated)).or. & - (.not.do_not_recalculate(option_path))) + recalculate = ((.not.present_and_true(exclude_nonrecalculated)).or. & + (.not.do_not_recalculate(option_path))) - end function recalculate + end function recalculate - end subroutine calculate_diagnostic_variables + end subroutine calculate_diagnostic_variables end module diagnostic_fields_wrapper diff --git a/assemble/Discrete_Properties.F90 b/assemble/Discrete_Properties.F90 index 852580b59d..9788969428 100644 --- a/assemble/Discrete_Properties.F90 +++ b/assemble/Discrete_Properties.F90 @@ -28,196 +28,196 @@ #include "fdebug.h" module discrete_properties_module - use spud - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use futils, only: present_and_true - use fields - use state_module - use field_options - use solenoidal_interpolation_module + use spud + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use futils, only: present_and_true + use fields + use state_module + use field_options + use solenoidal_interpolation_module - implicit none + implicit none - private + private - public :: enforce_discrete_properties + public :: enforce_discrete_properties contains - subroutine enforce_discrete_properties(states, only_prescribed, exclude_interpolated, exclude_nonreprescribed) - type(state_type), dimension(:), intent(inout) :: states - ! if a field isn't prescribed then don't process it - logical, intent(in), optional :: only_prescribed - ! if a field has interpolation options then don't process it - logical, intent(in), optional :: exclude_interpolated - ! if a field hasn't been represcribed then don't process it - logical, intent(in), optional :: exclude_nonreprescribed - - ! The fields organised by algorithm. - type(state_type) :: alg_state - - integer :: state, state_cnt, mesh_i - - character(len=255), dimension(1), parameter :: algorithms = (/& - & "solenoidal" /) - integer :: alg_cnt, alg - - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: pos - - integer :: processed - - ewrite(1, *) "In enforce_discrete_properties" - - alg_cnt = size(algorithms) - state_cnt = size(states) - - do state = 1, state_cnt - ! some fields require post processing that needs more than one mesh - ! these are dealt with in this loop - ewrite(2, *) "Processing fields in state " // trim(states(state)%name) - - processed = 0 - alg_loop: do alg = 1, alg_cnt - ! only actually care about one algorithm at the moment but for futureproofing we'll do this in a loop - ewrite(2, *) " Considering algorithm " // trim(algorithms(alg)) - - do mesh_i = 1, mesh_count(states(state)) - mesh => extract_mesh(states(state), mesh_i) - call insert(alg_state, mesh, name=trim(mesh%name)) - end do - pos => extract_vector_field(states(state), "Coordinate") - call insert(alg_state, pos, "Coordinate") - - select case(trim(algorithms(alg))) - case("solenoidal") - call collect_fields_to_process(interpolate_field_solenoidal, states(state), alg_state, & - only_prescribed=only_prescribed, & - exclude_interpolated=exclude_interpolated, & - exclude_nonreprescribed=exclude_nonreprescribed) - - if(field_count(alg_state) > 1) then - call solenoidal_interpolation(alg_state) + subroutine enforce_discrete_properties(states, only_prescribed, exclude_interpolated, exclude_nonreprescribed) + type(state_type), dimension(:), intent(inout) :: states + ! if a field isn't prescribed then don't process it + logical, intent(in), optional :: only_prescribed + ! if a field has interpolation options then don't process it + logical, intent(in), optional :: exclude_interpolated + ! if a field hasn't been represcribed then don't process it + logical, intent(in), optional :: exclude_nonreprescribed + + ! The fields organised by algorithm. + type(state_type) :: alg_state + + integer :: state, state_cnt, mesh_i + + character(len=255), dimension(1), parameter :: algorithms = (/& + & "solenoidal" /) + integer :: alg_cnt, alg + + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: pos + + integer :: processed + + ewrite(1, *) "In enforce_discrete_properties" + + alg_cnt = size(algorithms) + state_cnt = size(states) + + do state = 1, state_cnt + ! some fields require post processing that needs more than one mesh + ! these are dealt with in this loop + ewrite(2, *) "Processing fields in state " // trim(states(state)%name) + + processed = 0 + alg_loop: do alg = 1, alg_cnt + ! only actually care about one algorithm at the moment but for futureproofing we'll do this in a loop + ewrite(2, *) " Considering algorithm " // trim(algorithms(alg)) + + do mesh_i = 1, mesh_count(states(state)) + mesh => extract_mesh(states(state), mesh_i) + call insert(alg_state, mesh, name=trim(mesh%name)) + end do + pos => extract_vector_field(states(state), "Coordinate") + call insert(alg_state, pos, "Coordinate") + + select case(trim(algorithms(alg))) + case("solenoidal") + call collect_fields_to_process(interpolate_field_solenoidal, states(state), alg_state, & + only_prescribed=only_prescribed, & + exclude_interpolated=exclude_interpolated, & + exclude_nonreprescribed=exclude_nonreprescribed) + + if(field_count(alg_state) > 1) then + call solenoidal_interpolation(alg_state) + end if + case default + ! coding/schema error + FLAbort("Unknown discrete property algorithm.") + end select + + processed = processed + field_count(alg_state) - 1 + assert(processed <= field_count(states(state))) + + call deallocate(alg_state) + + if(processed >= field_count(states(state))) then + ewrite(2, *) "All fields in state " // trim(states(state)%name) // " processed" + exit alg_loop end if - case default - ! coding/schema error - FLAbort("Unknown discrete property algorithm.") - end select - - processed = processed + field_count(alg_state) - 1 - assert(processed <= field_count(states(state))) - call deallocate(alg_state) + end do alg_loop - if(processed >= field_count(states(state))) then - ewrite(2, *) "All fields in state " // trim(states(state)%name) // " processed" - exit alg_loop - end if + end do - end do alg_loop + ewrite(1, *) "Exiting enforce_discrete_properties" - end do + end subroutine enforce_discrete_properties - ewrite(1, *) "Exiting enforce_discrete_properties" + function interpolate_field_solenoidal(option_path, only_prescribed, exclude_interpolated, exclude_nonreprescribed) result(process) + character(len = *), intent(in) :: option_path + logical, intent(in), optional :: only_prescribed + logical, intent(in), optional :: exclude_interpolated + logical, intent(in), optional :: exclude_nonreprescribed - end subroutine enforce_discrete_properties + logical :: process - function interpolate_field_solenoidal(option_path, only_prescribed, exclude_interpolated, exclude_nonreprescribed) result(process) - character(len = *), intent(in) :: option_path - logical, intent(in), optional :: only_prescribed - logical, intent(in), optional :: exclude_interpolated - logical, intent(in), optional :: exclude_nonreprescribed + character(len = OPTION_PATH_LEN) :: base_path - logical :: process + process = .false. + if(len_trim(option_path) == 0) return - character(len = OPTION_PATH_LEN) :: base_path + base_path = trim(complete_field_path(option_path)) - process = .false. - if(len_trim(option_path) == 0) return + process = have_option(trim(base_path) // "/enforce_discrete_properties/solenoidal") & + .or. have_option(trim(base_path) // "/enforce_discrete_properties/solenoidal_lagrange_update") - base_path = trim(complete_field_path(option_path)) - - process = have_option(trim(base_path) // "/enforce_discrete_properties/solenoidal") & - .or. have_option(trim(base_path) // "/enforce_discrete_properties/solenoidal_lagrange_update") - - if(present_and_true(exclude_nonreprescribed)) then - process = process .and. .not.have_option(trim(base_path)//"/do_not_recalculate") - end if - - if(present_and_true(exclude_interpolated)) then - process = process .and. .not.interpolate_field(trim(option_path)) - end if - - if(present_and_true(only_prescribed)) then - process = process .and. have_option(trim(option_path)//"/prescribed") - end if - - end function interpolate_field_solenoidal - - subroutine collect_fields_to_process(test, input_state, output_state, & - only_prescribed, exclude_interpolated, exclude_nonreprescribed) - !!< Collect all fields in the supplied input states that - !!< pass the supplied test, and insert them into output_state. - - interface - function test(option_path, only_prescribed, exclude_interpolated, exclude_nonreprescribed) - implicit none - character(len = *), intent(in) :: option_path - logical, intent(in), optional :: only_prescribed - logical, intent(in), optional :: exclude_interpolated - logical, intent(in), optional :: exclude_nonreprescribed - logical :: test - end function test - end interface - type(state_type), intent(in) :: input_state - type(state_type), intent(inout) :: output_state - logical, intent(in), optional :: only_prescribed - logical, intent(in), optional :: exclude_interpolated - logical, intent(in), optional :: exclude_nonreprescribed - - integer :: i - type(scalar_field), pointer :: s_field => null() - type(tensor_field), pointer :: t_field => null() - type(vector_field), pointer :: v_field => null() - - do i = 1, scalar_field_count(input_state) - s_field => extract_scalar_field(input_state, i) - if(.not.aliased(s_field).and.test(s_field%option_path, & - only_prescribed=only_prescribed, & - exclude_interpolated=exclude_interpolated, & - exclude_nonreprescribed=exclude_nonreprescribed)) then - - ewrite(2, *) " Found ", trim(s_field%name) - - call insert(output_state, s_field, trim(input_state%scalar_names(i))) + if(present_and_true(exclude_nonreprescribed)) then + process = process .and. .not.have_option(trim(base_path)//"/do_not_recalculate") end if - end do - - do i = 1, vector_field_count(input_state) - v_field => extract_vector_field(input_state, i) - if(.not.aliased(v_field).and.test(v_field%option_path, & - only_prescribed=only_prescribed, & - exclude_interpolated=exclude_interpolated, & - exclude_nonreprescribed=exclude_nonreprescribed)) then - ewrite(2, *) " Found ", trim(v_field%name) - call insert(output_state, v_field, trim(input_state%vector_names(i))) + if(present_and_true(exclude_interpolated)) then + process = process .and. .not.interpolate_field(trim(option_path)) end if - end do - - do i = 1, tensor_field_count(input_state) - t_field => extract_tensor_field(input_state, i) - if(.not.aliased(t_field).and.test(t_field%option_path, & - only_prescribed=only_prescribed, & - exclude_interpolated=exclude_interpolated, & - exclude_nonreprescribed=exclude_nonreprescribed)) then - ewrite(2, *) " Found ", trim(t_field%name) - call insert(output_state, t_field, trim(input_state%tensor_names(i))) + if(present_and_true(only_prescribed)) then + process = process .and. have_option(trim(option_path)//"/prescribed") end if - end do - end subroutine collect_fields_to_process + end function interpolate_field_solenoidal + + subroutine collect_fields_to_process(test, input_state, output_state, & + only_prescribed, exclude_interpolated, exclude_nonreprescribed) + !!< Collect all fields in the supplied input states that + !!< pass the supplied test, and insert them into output_state. + + interface + function test(option_path, only_prescribed, exclude_interpolated, exclude_nonreprescribed) + implicit none + character(len = *), intent(in) :: option_path + logical, intent(in), optional :: only_prescribed + logical, intent(in), optional :: exclude_interpolated + logical, intent(in), optional :: exclude_nonreprescribed + logical :: test + end function test + end interface + type(state_type), intent(in) :: input_state + type(state_type), intent(inout) :: output_state + logical, intent(in), optional :: only_prescribed + logical, intent(in), optional :: exclude_interpolated + logical, intent(in), optional :: exclude_nonreprescribed + + integer :: i + type(scalar_field), pointer :: s_field => null() + type(tensor_field), pointer :: t_field => null() + type(vector_field), pointer :: v_field => null() + + do i = 1, scalar_field_count(input_state) + s_field => extract_scalar_field(input_state, i) + if(.not.aliased(s_field).and.test(s_field%option_path, & + only_prescribed=only_prescribed, & + exclude_interpolated=exclude_interpolated, & + exclude_nonreprescribed=exclude_nonreprescribed)) then + + ewrite(2, *) " Found ", trim(s_field%name) + + call insert(output_state, s_field, trim(input_state%scalar_names(i))) + end if + end do + + do i = 1, vector_field_count(input_state) + v_field => extract_vector_field(input_state, i) + if(.not.aliased(v_field).and.test(v_field%option_path, & + only_prescribed=only_prescribed, & + exclude_interpolated=exclude_interpolated, & + exclude_nonreprescribed=exclude_nonreprescribed)) then + ewrite(2, *) " Found ", trim(v_field%name) + + call insert(output_state, v_field, trim(input_state%vector_names(i))) + end if + end do + + do i = 1, tensor_field_count(input_state) + t_field => extract_tensor_field(input_state, i) + if(.not.aliased(t_field).and.test(t_field%option_path, & + only_prescribed=only_prescribed, & + exclude_interpolated=exclude_interpolated, & + exclude_nonreprescribed=exclude_nonreprescribed)) then + ewrite(2, *) " Found ", trim(t_field%name) + + call insert(output_state, t_field, trim(input_state%tensor_names(i))) + end if + end do + + end subroutine collect_fields_to_process end module discrete_properties_module diff --git a/assemble/Divergence_Matrix_CG.F90 b/assemble/Divergence_Matrix_CG.F90 index 3c69e883b1..a7ab3188a2 100644 --- a/assemble/Divergence_Matrix_CG.F90 +++ b/assemble/Divergence_Matrix_CG.F90 @@ -29,46 +29,46 @@ module divergence_matrix_cg - use global_parameters, only: OPTION_PATH_LEN - use fldebug - use quadrature - use futils - use spud - use sparse_tools - use transform_elements - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use field_options, only: complete_field_path - use upwind_stabilisation - use equation_of_state - use multiphase_module - - implicit none - - private - public :: assemble_divergence_matrix_cg, assemble_compressible_divergence_matrix_cg - - ! Stabilisation schemes - integer, parameter :: STABILISATION_NONE = 0, & - & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 - ! Stabilisation scheme - integer :: stabilisation_scheme - integer :: nu_bar_scheme - real :: nu_bar_scale - - !! Are we running a multiphase flow simulation? - logical :: multiphase - - contains - - subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & - test_mesh, field, option_path, & - div_mass, grad_mass, & - div_mass_lumped,& - grad_mass_lumped, get_ct) + use global_parameters, only: OPTION_PATH_LEN + use fldebug + use quadrature + use futils + use spud + use sparse_tools + use transform_elements + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use field_options, only: complete_field_path + use upwind_stabilisation + use equation_of_state + use multiphase_module + + implicit none + + private + public :: assemble_divergence_matrix_cg, assemble_compressible_divergence_matrix_cg + + ! Stabilisation schemes + integer, parameter :: STABILISATION_NONE = 0, & + & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 + ! Stabilisation scheme + integer :: stabilisation_scheme + integer :: nu_bar_scheme + real :: nu_bar_scale + + !! Are we running a multiphase flow simulation? + logical :: multiphase + +contains + + subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & + test_mesh, field, option_path, & + div_mass, grad_mass, & + div_mass_lumped,& + grad_mass_lumped, get_ct) ! inputs/outputs ! bucket full of fields @@ -137,27 +137,27 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & ewrite(2,*) 'In assemble_divergence_matrix_cg' if(present(get_ct)) then - l_get_ct = get_ct + l_get_ct = get_ct else - l_get_ct = .true. + l_get_ct = .true. end if if(present(option_path)) then - l_option_path = trim(option_path) + l_option_path = trim(option_path) else - l_option_path = trim(field%option_path) + l_option_path = trim(field%option_path) end if coordinate=>extract_vector_field(state, "Coordinate") integrate_by_parts=have_option(trim(complete_field_path(l_option_path, stat=stat))//& - &"/spatial_discretisation/continuous_galerkin/integrate_continuity_by_parts")& - .or. have_option(trim(complete_field_path(l_option_path, stat=stat))//& - &"/integrate_divergence_by_parts")& - .or. have_option(trim(complete_field_path(l_option_path, stat=stat))//& - &"/spatial_discretisation/continuous_galerkin/integrate_divergence_by_parts")& - .or. have_option(trim(complete_field_path(l_option_path, stat=stat))//& - &"/spatial_discretisation/discontinuous_galerkin") + &"/spatial_discretisation/continuous_galerkin/integrate_continuity_by_parts")& + .or. have_option(trim(complete_field_path(l_option_path, stat=stat))//& + &"/integrate_divergence_by_parts")& + .or. have_option(trim(complete_field_path(l_option_path, stat=stat))//& + &"/spatial_discretisation/continuous_galerkin/integrate_divergence_by_parts")& + .or. have_option(trim(complete_field_path(l_option_path, stat=stat))//& + &"/spatial_discretisation/discontinuous_galerkin") ewrite(2,*) "Divergence is integrated by parts: ", integrate_by_parts @@ -188,11 +188,11 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & if(present(grad_mass_lumped)) call zero(grad_mass_lumped) allocate(dfield_t(ele_loc(field, 1), ele_ngi(field, 1), field%dim), & - dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), field%dim), & - ele_mat(field%dim, ele_loc(test_mesh, 1), ele_loc(field, 1)), & - detwei(ele_ngi(field, 1)), & - grad_mass_mat(ele_loc(field, 1), ele_loc(field, 1)), & - div_mass_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1))) + dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), field%dim), & + ele_mat(field%dim, ele_loc(test_mesh, 1), ele_loc(field, 1)), & + detwei(ele_ngi(field, 1)), & + grad_mass_mat(ele_loc(field, 1), ele_loc(field, 1)), & + div_mass_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1))) if(multiphase) then allocate(dnvfrac_t(ele_loc(nvfrac,1), ele_ngi(nvfrac,1), field%dim)) @@ -210,7 +210,7 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & ! transform the pressure derivatives into physical space ! (and get detwei) call transform_to_physical(coordinate, ele, test_shape, & - dshape=dtest_t, detwei=detwei) + dshape=dtest_t, detwei=detwei) if(multiphase) then ele_mat = -dshape_shape(dtest_t, field_shape, detwei*ele_val_at_quad(nvfrac, ele)) @@ -221,7 +221,7 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & ! transform the velociy derivatives into physical space ! (and get detwei) call transform_to_physical(coordinate, ele, field_shape, & - dshape=dfield_t, detwei=detwei) + dshape=dfield_t, detwei=detwei) if(multiphase) then ! Split up the divergence term div(vfrac*u) = vfrac*div(u) + u*grad(vfrac) @@ -236,7 +236,7 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & end if ele_mat = shape_dshape(test_shape, dfield_t, detwei*ele_val_at_quad(nvfrac, ele)) + & - shape_shape_vector(test_shape, field_shape, detwei, ele_grad_at_quad(nvfrac, ele, dnvfrac_t)) + shape_shape_vector(test_shape, field_shape, detwei, ele_grad_at_quad(nvfrac, ele, dnvfrac_t)) else ele_mat = shape_dshape(test_shape, dfield_t, detwei) end if @@ -292,77 +292,77 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & if(integrate_by_parts) then - allocate(detwei_bdy(face_ngi(field, 1)), & - normal_bdy(field%dim, face_ngi(field, 1))) - allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) - allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) - allocate(ele_mat_bdy(field%dim, face_loc(test_mesh, 1), face_loc(field, 1))) + allocate(detwei_bdy(face_ngi(field, 1)), & + normal_bdy(field%dim, face_ngi(field, 1))) + allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) + allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) + allocate(ele_mat_bdy(field%dim, face_loc(test_mesh, 1), face_loc(field, 1))) - assert(surface_element_count(test_mesh)==surface_element_count(field)) - allocate(field_bc_type(field%dim, surface_element_count(field))) - call get_entire_boundary_condition(field, (/ & - "weakdirichlet ", & - "no_normal_flow ", & - "internal ", & - "free_surface ", & - "prescribed_normal_flow "/), field_bc, field_bc_type) + assert(surface_element_count(test_mesh)==surface_element_count(field)) + allocate(field_bc_type(field%dim, surface_element_count(field))) + call get_entire_boundary_condition(field, (/ & + "weakdirichlet ", & + "no_normal_flow ", & + "internal ", & + "free_surface ", & + "prescribed_normal_flow "/), field_bc, field_bc_type) - do sele = 1, surface_element_count(test_mesh) + do sele = 1, surface_element_count(test_mesh) - if(any(field_bc_type(:,sele)==2)& + if(any(field_bc_type(:,sele)==2)& .or.any(field_bc_type(:,sele)==3)& .or.any(field_bc_type(:,sele)==4)) cycle - test_shape=>face_shape(test_mesh, sele) - field_shape=>face_shape(field, sele) + test_shape=>face_shape(test_mesh, sele) + field_shape=>face_shape(field, sele) - test_nodes_bdy=face_global_nodes(test_mesh, sele) - field_nodes_bdy=face_global_nodes(field, sele) + test_nodes_bdy=face_global_nodes(test_mesh, sele) + field_nodes_bdy=face_global_nodes(field, sele) - if (field_bc_type(1,sele)==5 .and. present(ct_rhs)) then + if (field_bc_type(1,sele)==5 .and. present(ct_rhs)) then - ! prescribed_normal_flow - call transform_facet_to_physical(coordinate, sele, & - & detwei_f=detwei_bdy) - if(multiphase) then - detwei_bdy = detwei_bdy*face_val_at_quad(nvfrac, sele) - end if + ! prescribed_normal_flow + call transform_facet_to_physical(coordinate, sele, & + & detwei_f=detwei_bdy) + if(multiphase) then + detwei_bdy = detwei_bdy*face_val_at_quad(nvfrac, sele) + end if - call addto(ct_rhs, test_nodes_bdy, -shape_rhs(test_shape, detwei_bdy*ele_val_at_quad(field_bc, sele, 1))) + call addto(ct_rhs, test_nodes_bdy, -shape_rhs(test_shape, detwei_bdy*ele_val_at_quad(field_bc, sele, 1))) - else + else - ! Dirichlet or no boundary condition + ! Dirichlet or no boundary condition - call transform_facet_to_physical(coordinate, sele, & - & detwei_f=detwei_bdy,& - & normal=normal_bdy) + call transform_facet_to_physical(coordinate, sele, & + & detwei_f=detwei_bdy,& + & normal=normal_bdy) - if(multiphase) then - ele_mat_bdy = shape_shape_vector(test_shape, field_shape, detwei_bdy*face_val_at_quad(nvfrac, ele), normal_bdy) - else - ele_mat_bdy = shape_shape_vector(test_shape, field_shape, detwei_bdy, normal_bdy) - end if + if(multiphase) then + ele_mat_bdy = shape_shape_vector(test_shape, field_shape, detwei_bdy*face_val_at_quad(nvfrac, ele), normal_bdy) + else + ele_mat_bdy = shape_shape_vector(test_shape, field_shape, detwei_bdy, normal_bdy) + end if - do dim = 1, field%dim - if((field_bc_type(dim, sele)==1).and.present(ct_rhs)) then - call addto(ct_rhs, test_nodes_bdy, & - -matmul(ele_mat_bdy(dim,:,:), & - ele_val(field_bc, dim, sele))) - else - if (l_get_ct) then - call addto(ct_m, 1, dim, test_nodes_bdy, field_nodes_bdy, & - ele_mat_bdy(dim,:,:)) - end if - end if - end do - end if - end do + do dim = 1, field%dim + if((field_bc_type(dim, sele)==1).and.present(ct_rhs)) then + call addto(ct_rhs, test_nodes_bdy, & + -matmul(ele_mat_bdy(dim,:,:), & + ele_val(field_bc, dim, sele))) + else + if (l_get_ct) then + call addto(ct_m, 1, dim, test_nodes_bdy, field_nodes_bdy, & + ele_mat_bdy(dim,:,:)) + end if + end if + end do + end if + end do - call deallocate(field_bc) - deallocate(field_bc_type) - deallocate(detwei_bdy, normal_bdy) - deallocate(test_nodes_bdy, field_nodes_bdy) + call deallocate(field_bc) + deallocate(field_bc_type) + deallocate(detwei_bdy, normal_bdy) + deallocate(test_nodes_bdy, field_nodes_bdy) end if @@ -372,9 +372,9 @@ subroutine assemble_divergence_matrix_cg(CT_m, state, ct_rhs, & ewrite(2,*) 'Exiting assemble_divergence_matrix_cg' - end subroutine assemble_divergence_matrix_cg + end subroutine assemble_divergence_matrix_cg - subroutine assemble_compressible_divergence_matrix_cg(ctp_m, state, istate, ct_rhs, div_mass) + subroutine assemble_compressible_divergence_matrix_cg(ctp_m, state, istate, ct_rhs, div_mass) ! inputs/outputs ! bucket full of fields @@ -407,9 +407,9 @@ subroutine assemble_compressible_divergence_matrix_cg(ctp_m, state, istate, ct_r - end subroutine assemble_compressible_divergence_matrix_cg + end subroutine assemble_compressible_divergence_matrix_cg - subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, ct_rhs, div_mass) + subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, ct_rhs, div_mass) ! inputs/outputs ! bucket full of fields @@ -515,37 +515,37 @@ subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, end if integrate_by_parts=have_option(trim(complete_field_path(density%option_path, stat=stat))//& - &"/spatial_discretisation/continuous_galerkin/advection_terms/integrate_advection_by_parts")& - .or. have_option(trim(complete_field_path(velocity%option_path, stat=stat))//& - &"/spatial_discretisation/discontinuous_galerkin") + &"/spatial_discretisation/continuous_galerkin/advection_terms/integrate_advection_by_parts")& + .or. have_option(trim(complete_field_path(velocity%option_path, stat=stat))//& + &"/spatial_discretisation/discontinuous_galerkin") ewrite(2,*) "Compressible divergence is integrated by parts: ", integrate_by_parts if(have_option(trim(density%option_path) // "/prognostic/spatial_discretisation/& - &continuous_galerkin/stabilisation/streamline_upwind")) then - ewrite(2, *) "Streamline upwind stabilisation" - FLExit("SU stabilisation broken with continuity at the moment.") - stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND - call get_upwind_options(trim(density%option_path) // & - "/prognostic/spatial_discretisation/continuous_galerkin/& - &stabilisation/streamline_upwind", & - & nu_bar_scheme, nu_bar_scale) + &continuous_galerkin/stabilisation/streamline_upwind")) then + ewrite(2, *) "Streamline upwind stabilisation" + FLExit("SU stabilisation broken with continuity at the moment.") + stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND + call get_upwind_options(trim(density%option_path) // & + "/prognostic/spatial_discretisation/continuous_galerkin/& + &stabilisation/streamline_upwind", & + & nu_bar_scheme, nu_bar_scale) else if(have_option(trim(density%option_path) // & - "/prognostic/spatial_discretisation/continuous_galerkin/& - &stabilisation/streamline_upwind_petrov_galerkin")) then - ewrite(2, *) "SUPG stabilisation" - stabilisation_scheme = STABILISATION_SUPG - call get_upwind_options(trim(density%option_path) // & - "/prognostic/spatial_discretisation/continuous_galerkin/& - &stabilisation/streamline_upwind_petrov_galerkin", & - & nu_bar_scheme, nu_bar_scale) + "/prognostic/spatial_discretisation/continuous_galerkin/& + &stabilisation/streamline_upwind_petrov_galerkin")) then + ewrite(2, *) "SUPG stabilisation" + stabilisation_scheme = STABILISATION_SUPG + call get_upwind_options(trim(density%option_path) // & + "/prognostic/spatial_discretisation/continuous_galerkin/& + &stabilisation/streamline_upwind_petrov_galerkin", & + & nu_bar_scheme, nu_bar_scale) else - ewrite(2, *) "No stabilisation" - stabilisation_scheme = STABILISATION_NONE + ewrite(2, *) "No stabilisation" + stabilisation_scheme = STABILISATION_NONE end if call get_option(trim(complete_field_path(density%option_path, stat=stat))//& - &"/temporal_discretisation/theta", theta) + &"/temporal_discretisation/theta", theta) call get_option("/timestepping/timestep", dt) test_mesh => pressure%mesh @@ -557,16 +557,16 @@ subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, call zero(ctp_m) allocate(dfield_t(ele_loc(field, 1), ele_ngi(field, 1), field%dim), & - dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), field%dim), & - ddensity_t(ele_loc(density, 1), ele_ngi(density, 1), field%dim), & - ele_mat(field%dim, ele_loc(test_mesh, 1), ele_loc(field, 1)), & - detwei(ele_ngi(field, 1)), & - density_at_quad(ele_ngi(density, 1)), & - olddensity_at_quad(ele_ngi(density, 1)), & - nlvelocity_at_quad(nonlinearvelocity%dim, ele_ngi(nonlinearvelocity, 1)), & - density_grad_at_quad(field%dim, ele_ngi(density,1)), & - j_mat(field%dim, field%dim, ele_ngi(density, 1)), & - div_mass_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1))) + dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), field%dim), & + ddensity_t(ele_loc(density, 1), ele_ngi(density, 1), field%dim), & + ele_mat(field%dim, ele_loc(test_mesh, 1), ele_loc(field, 1)), & + detwei(ele_ngi(field, 1)), & + density_at_quad(ele_ngi(density, 1)), & + olddensity_at_quad(ele_ngi(density, 1)), & + nlvelocity_at_quad(nonlinearvelocity%dim, ele_ngi(nonlinearvelocity, 1)), & + density_grad_at_quad(field%dim, ele_ngi(density,1)), & + j_mat(field%dim, field%dim, ele_ngi(density, 1)), & + div_mass_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1))) if(multiphase) then ! We will need grad(nvfrac) if we are not integrating by parts below @@ -575,58 +575,58 @@ subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, do ele=1, element_count(test_mesh) - test_nodes=>ele_nodes(test_mesh, ele) - field_nodes=>ele_nodes(field, ele) + test_nodes=>ele_nodes(test_mesh, ele) + field_nodes=>ele_nodes(field, ele) - test_shape_ptr => ele_shape(test_mesh, ele) - field_shape=>ele_shape(field, ele) - density_shape => ele_shape(density, ele) + test_shape_ptr => ele_shape(test_mesh, ele) + field_shape=>ele_shape(field, ele) + density_shape => ele_shape(density, ele) - density_at_quad = ele_val_at_quad(density, ele) - olddensity_at_quad = ele_val_at_quad(olddensity, ele) + density_at_quad = ele_val_at_quad(density, ele) + olddensity_at_quad = ele_val_at_quad(olddensity, ele) - nlvelocity_at_quad = ele_val_at_quad(nonlinearvelocity, ele) + nlvelocity_at_quad = ele_val_at_quad(nonlinearvelocity, ele) - if(any(stabilisation_scheme == (/STABILISATION_STREAMLINE_UPWIND, STABILISATION_SUPG/))) then - call transform_to_physical(coordinate, ele, test_shape_ptr, dshape = dtest_t, & - detwei = detwei, j = j_mat) - else - call transform_to_physical(coordinate, ele, test_shape_ptr, dshape = dtest_t, detwei=detwei) - end if + if(any(stabilisation_scheme == (/STABILISATION_STREAMLINE_UPWIND, STABILISATION_SUPG/))) then + call transform_to_physical(coordinate, ele, test_shape_ptr, dshape = dtest_t, & + detwei = detwei, j = j_mat) + else + call transform_to_physical(coordinate, ele, test_shape_ptr, dshape = dtest_t, detwei=detwei) + end if - if(.not.integrate_by_parts .or. (multiphase .and. integrate_by_parts .and. .not.is_compressible_phase)) then - ! transform the field (velocity) derivatives into physical space - call transform_to_physical(coordinate, ele, field_shape, dshape=dfield_t) + if(.not.integrate_by_parts .or. (multiphase .and. integrate_by_parts .and. .not.is_compressible_phase)) then + ! transform the field (velocity) derivatives into physical space + call transform_to_physical(coordinate, ele, field_shape, dshape=dfield_t) - if(test_shape_ptr==density_shape) then - ddensity_t = dtest_t - else - call transform_to_physical(coordinate, ele, density_shape, dshape = ddensity_t) - end if - else - dfield_t = 0.0 - ddensity_t = 0.0 - end if + if(test_shape_ptr==density_shape) then + ddensity_t = dtest_t + else + call transform_to_physical(coordinate, ele, density_shape, dshape = ddensity_t) + end if + else + dfield_t = 0.0 + ddensity_t = 0.0 + end if - select case(stabilisation_scheme) + select case(stabilisation_scheme) case(STABILISATION_SUPG) test_shape = make_supg_shape(test_shape_ptr, dtest_t, nlvelocity_at_quad, j_mat, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) case default test_shape = test_shape_ptr call incref(test_shape) - end select - ! Important note: with SUPG the test function derivatives have not been - ! modified - i.e. dtest_t is currently used everywhere. This is fine for P1, - ! but is not consistent for P>1. + end select + ! Important note: with SUPG the test function derivatives have not been + ! modified - i.e. dtest_t is currently used everywhere. This is fine for P1, + ! but is not consistent for P>1. - if(integrate_by_parts) then + if(integrate_by_parts) then ! if SUPG is fixed for P>1 then this dtest_t should be updated if(multiphase .and. .not.is_compressible_phase) then density_grad_at_quad = theta*(ele_grad_at_quad(density, ele, ddensity_t))+& - (1-theta)*(ele_grad_at_quad(olddensity, ele, ddensity_t)) + (1-theta)*(ele_grad_at_quad(olddensity, ele, ddensity_t)) ele_mat = -dshape_shape(dtest_t, field_shape, detwei*ele_val_at_quad(nvfrac, ele)*(theta*density_at_quad + (1-theta)*olddensity_at_quad)) - shape_shape_vector(test_shape, field_shape, detwei*ele_val_at_quad(nvfrac, ele), density_grad_at_quad) @@ -637,9 +637,9 @@ subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, ele_mat = -dshape_shape(dtest_t, field_shape, detwei*(theta*density_at_quad + (1-theta)*olddensity_at_quad)) end if - else + else density_grad_at_quad = theta*(ele_grad_at_quad(density, ele, ddensity_t))+& - (1-theta)*(ele_grad_at_quad(olddensity, ele, ddensity_t)) + (1-theta)*(ele_grad_at_quad(olddensity, ele, ddensity_t)) if(multiphase) then @@ -665,105 +665,105 @@ subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, else ele_mat = shape_dshape(test_shape, dfield_t, & - detwei*(theta*density_at_quad + (1-theta)*olddensity_at_quad)) + & - shape_shape_vector(test_shape, field_shape, detwei, density_grad_at_quad) + detwei*(theta*density_at_quad + (1-theta)*olddensity_at_quad)) + & + shape_shape_vector(test_shape, field_shape, detwei, density_grad_at_quad) end if - end if + end if - ! Stabilisation does not return the right shape for this operator! - select case(stabilisation_scheme) + ! Stabilisation does not return the right shape for this operator! + select case(stabilisation_scheme) case(STABILISATION_STREAMLINE_UPWIND) ! ele_mat = ele_mat + & ! & element_upwind_stabilisation_div(field_shape, ddensity_t, nlvelocity_at_quad, j_mat, detwei, & ! & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - end select + end select - do dim = 1, field%dim + do dim = 1, field%dim call addto(ctp_m, 1, dim, test_nodes, field_nodes, ele_mat(dim,:,:)) - end do + end do - if(present(div_mass)) then - div_mass_mat = shape_shape(test_shape, test_shape, detwei) - call addto(div_mass, test_nodes, test_nodes, div_mass_mat) - end if + if(present(div_mass)) then + div_mass_mat = shape_shape(test_shape, test_shape, detwei) + call addto(div_mass, test_nodes, test_nodes, div_mass_mat) + end if - call deallocate(test_shape) + call deallocate(test_shape) end do if(integrate_by_parts) then - allocate(detwei_bdy(face_ngi(field, 1)), & - density_bdy(face_ngi(density, 1)), & - normal_bdy(field%dim, face_ngi(field, 1))) - allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) - allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) - allocate(ele_mat_bdy(field%dim, face_loc(test_mesh, 1), face_loc(field, 1))) + allocate(detwei_bdy(face_ngi(field, 1)), & + density_bdy(face_ngi(density, 1)), & + normal_bdy(field%dim, face_ngi(field, 1))) + allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) + allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) + allocate(ele_mat_bdy(field%dim, face_loc(test_mesh, 1), face_loc(field, 1))) - assert(surface_element_count(test_mesh)==surface_element_count(field)) - allocate(field_bc_type(field%dim, surface_element_count(field))) - call get_entire_boundary_condition(field, (/ & - "weakdirichlet ", & - "no_normal_flow", & - "internal ", & - "free_surface "/), field_bc, field_bc_type) + assert(surface_element_count(test_mesh)==surface_element_count(field)) + allocate(field_bc_type(field%dim, surface_element_count(field))) + call get_entire_boundary_condition(field, (/ & + "weakdirichlet ", & + "no_normal_flow", & + "internal ", & + "free_surface "/), field_bc, field_bc_type) - allocate(density_bc_type(surface_element_count(density))) - call get_entire_boundary_condition(density, (/ & - "weakdirichlet"/), density_bc, density_bc_type) + allocate(density_bc_type(surface_element_count(density))) + call get_entire_boundary_condition(density, (/ & + "weakdirichlet"/), density_bc, density_bc_type) - do sele = 1, surface_element_count(test_mesh) + do sele = 1, surface_element_count(test_mesh) - if(any(field_bc_type(:,sele)==2)& + if(any(field_bc_type(:,sele)==2)& .or.any(field_bc_type(:,sele)==3)& .or.any(field_bc_type(:,sele)==4)) cycle - test_shape_ptr=>face_shape(test_mesh, sele) - field_shape=>face_shape(field, sele) - - test_nodes_bdy=face_global_nodes(test_mesh, sele) - field_nodes_bdy=face_global_nodes(field, sele) - - if(density_bc_type(sele)==1) then - ! not considering time varying bc yet! - density_bdy = ele_val_at_quad(density_bc, sele) - else - density_bdy = theta*face_val_at_quad(density, sele) + & - (1-theta)*face_val_at_quad(olddensity, sele) - end if - - call transform_facet_to_physical(coordinate, sele, & - & detwei_f=detwei_bdy,& - & normal=normal_bdy) - - - if(multiphase) then - ele_mat_bdy = shape_shape_vector(test_shape_ptr, field_shape, & - detwei_bdy*density_bdy*face_val_at_quad(nvfrac, sele), normal_bdy) - else - ele_mat_bdy = shape_shape_vector(test_shape_ptr, field_shape, & - detwei_bdy*density_bdy, normal_bdy) - end if - - do dim = 1, field%dim - if((field_bc_type(dim, sele)==1).and.present(ct_rhs)) then - call addto(ct_rhs, test_nodes_bdy, & - -matmul(ele_mat_bdy(dim,:,:), & - ele_val(field_bc, dim, sele))) + test_shape_ptr=>face_shape(test_mesh, sele) + field_shape=>face_shape(field, sele) + + test_nodes_bdy=face_global_nodes(test_mesh, sele) + field_nodes_bdy=face_global_nodes(field, sele) + + if(density_bc_type(sele)==1) then + ! not considering time varying bc yet! + density_bdy = ele_val_at_quad(density_bc, sele) + else + density_bdy = theta*face_val_at_quad(density, sele) + & + (1-theta)*face_val_at_quad(olddensity, sele) + end if + + call transform_facet_to_physical(coordinate, sele, & + & detwei_f=detwei_bdy,& + & normal=normal_bdy) + + + if(multiphase) then + ele_mat_bdy = shape_shape_vector(test_shape_ptr, field_shape, & + detwei_bdy*density_bdy*face_val_at_quad(nvfrac, sele), normal_bdy) else - call addto(ctp_m, 1, dim, test_nodes_bdy, field_nodes_bdy, & - ele_mat_bdy(dim,:,:)) + ele_mat_bdy = shape_shape_vector(test_shape_ptr, field_shape, & + detwei_bdy*density_bdy, normal_bdy) end if - end do - end do + do dim = 1, field%dim + if((field_bc_type(dim, sele)==1).and.present(ct_rhs)) then + call addto(ct_rhs, test_nodes_bdy, & + -matmul(ele_mat_bdy(dim,:,:), & + ele_val(field_bc, dim, sele))) + else + call addto(ctp_m, 1, dim, test_nodes_bdy, field_nodes_bdy, & + ele_mat_bdy(dim,:,:)) + end if + end do + + end do - call deallocate(field_bc) - call deallocate(density_bc) - deallocate(field_bc_type, density_bc_type) - deallocate(detwei_bdy, normal_bdy, density_bdy) - deallocate(test_nodes_bdy, field_nodes_bdy) + call deallocate(field_bc) + call deallocate(density_bc) + deallocate(field_bc_type, density_bc_type) + deallocate(detwei_bdy, normal_bdy, density_bdy) + deallocate(test_nodes_bdy, field_nodes_bdy) end if @@ -772,6 +772,6 @@ subroutine assemble_1mat_compressible_divergence_matrix_cg(ctp_m, state, istate, call deallocate(nvfrac) end if - end subroutine assemble_1mat_compressible_divergence_matrix_cg + end subroutine assemble_1mat_compressible_divergence_matrix_cg end module divergence_matrix_cg diff --git a/assemble/Divergence_Matrix_CV.F90 b/assemble/Divergence_Matrix_CV.F90 index b4434bfbd4..83a05b4948 100644 --- a/assemble/Divergence_Matrix_CV.F90 +++ b/assemble/Divergence_Matrix_CV.F90 @@ -27,39 +27,39 @@ #include "fdebug.h" module divergence_matrix_cv - use fldebug - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use quadrature - use futils - use spud - use sparse_tools - use cv_faces - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use cv_shape_functions - use field_options, only: get_coordinate_field - use cvtools - use cv_options - use cv_upwind_values - use cv_face_values, only: theta_val, evaluate_face_val - use sparsity_patterns_meshes - use diagnostic_fields, only: calculate_diagnostic_variable - use cv_fields - use multiphase_module - implicit none - - private - public :: assemble_divergence_matrix_cv, assemble_compressible_divergence_matrix_cv + use fldebug + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use quadrature + use futils + use spud + use sparse_tools + use cv_faces + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use cv_shape_functions + use field_options, only: get_coordinate_field + use cvtools + use cv_options + use cv_upwind_values + use cv_face_values, only: theta_val, evaluate_face_val + use sparsity_patterns_meshes + use diagnostic_fields, only: calculate_diagnostic_variable + use cv_fields + use multiphase_module + implicit none + + private + public :: assemble_divergence_matrix_cv, assemble_compressible_divergence_matrix_cv contains - !************************************************************************ - subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & - test_mesh, field, & - get_ct, exclude_boundaries, include_vfrac) + !************************************************************************ + subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & + test_mesh, field, & + get_ct, exclude_boundaries, include_vfrac) ! inputs/outputs ! bucket full of fields @@ -128,7 +128,7 @@ subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & ! Boundary condition types integer, parameter :: BC_TYPE_WEAKDIRICHLET = 1, BC_TYPE_NO_NORMAL_FLOW = 2, BC_TYPE_INTERNAL = 3, & - BC_TYPE_FREE_SURFACE = 4 + BC_TYPE_FREE_SURFACE = 4 ! ============================================================= ! Subroutine to construct the matrix CT_m (a.k.a. C1/2/3T). @@ -137,9 +137,9 @@ subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & ewrite(1,*) 'In assemble_divergence_matrix_cv' if(present(get_ct)) then - l_get_ct = get_ct + l_get_ct = get_ct else - l_get_ct = .true. + l_get_ct = .true. end if ! In some cases we might not want to include the PhaseVolumeFraction @@ -148,24 +148,24 @@ subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & ! For example, in the InternalEnergy equation we just want ! div(u), not div(vfrac*u). if(present(include_vfrac)) then - l_include_vfrac = include_vfrac + l_include_vfrac = include_vfrac else - l_include_vfrac = .true. + l_include_vfrac = .true. end if x=>extract_vector_field(state, "Coordinate") allocate(x_ele(x%dim,x%mesh%shape%loc)) call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + quaddegree, default=1) ! Clear memory of arrays being designed if(present(ct_rhs)) call zero(ct_rhs) cvfaces=find_cv_faces(vertices=ele_vertices(test_mesh, 1), & - dimension=mesh_dim(test_mesh), & - polydegree=test_mesh%shape%degree, & - quaddegree=quaddegree) + dimension=mesh_dim(test_mesh), & + polydegree=test_mesh%shape%degree, & + quaddegree=quaddegree) ! Check if we need to multiply through by the non-linear volume fraction if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1 .and. l_include_vfrac) then @@ -185,261 +185,261 @@ subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & if(l_get_ct) then - call zero(CT_m) + call zero(CT_m) - x_test=get_coordinate_field(state, test_mesh) + x_test=get_coordinate_field(state, test_mesh) - x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) - test_cvshape=make_cv_element_shape(cvfaces, test_mesh%shape) - field_cvshape=make_cv_element_shape(cvfaces, field%mesh%shape) + x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) + test_cvshape=make_cv_element_shape(cvfaces, test_mesh%shape) + field_cvshape=make_cv_element_shape(cvfaces, field%mesh%shape) - if(multiphase) then - ! If the Coordinate and PhaseVolumeFraction meshes are different, then we need to - ! get the PhaseVolumeFraction CV shape functions. - if(.not.(nvfrac%mesh == x%mesh)) then - nvfrac_cvshape = make_cv_element_shape(cvfaces, nvfrac%mesh%shape) - else - nvfrac_cvshape = x_cvshape - call incref(nvfrac_cvshape) - end if + if(multiphase) then + ! If the Coordinate and PhaseVolumeFraction meshes are different, then we need to + ! get the PhaseVolumeFraction CV shape functions. + if(.not.(nvfrac%mesh == x%mesh)) then + nvfrac_cvshape = make_cv_element_shape(cvfaces, nvfrac%mesh%shape) + else + nvfrac_cvshape = x_cvshape + call incref(nvfrac_cvshape) + end if - allocate(nvfrac_gi(nvfrac_cvshape%ngi)) - end if + allocate(nvfrac_gi(nvfrac_cvshape%ngi)) + end if - allocate(x_f(x%dim, x_cvshape%ngi), & - detwei(x_cvshape%ngi), & - normal(x%dim, x_cvshape%ngi), & - normgi(x%dim), & - ct_mat_local(x%dim, test_mesh%shape%loc, field%mesh%shape%loc)) + allocate(x_f(x%dim, x_cvshape%ngi), & + detwei(x_cvshape%ngi), & + normal(x%dim, x_cvshape%ngi), & + normgi(x%dim), & + ct_mat_local(x%dim, test_mesh%shape%loc, field%mesh%shape%loc)) - allocate(notvisited(x_cvshape%ngi)) + allocate(notvisited(x_cvshape%ngi)) - element_loop: do ele=1, element_count(test_mesh) - x_ele=ele_val(x, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - test_nodes=>ele_nodes(test_mesh, ele) - field_nodes=>ele_nodes(field, ele) - x_test_nodes=>ele_nodes(x_test, ele) + element_loop: do ele=1, element_count(test_mesh) + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + test_nodes=>ele_nodes(test_mesh, ele) + field_nodes=>ele_nodes(field, ele) + x_test_nodes=>ele_nodes(x_test, ele) - if(multiphase) then - nvfrac_gi = ele_val_at_quad(nvfrac, ele, nvfrac_cvshape) - end if + if(multiphase) then + nvfrac_gi = ele_val_at_quad(nvfrac, ele, nvfrac_cvshape) + end if - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) - notvisited=.true. + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) + notvisited=.true. - ct_mat_local = 0.0 + ct_mat_local = 0.0 - nodal_loop_i: do iloc = 1, test_mesh%shape%loc + nodal_loop_i: do iloc = 1, test_mesh%shape%loc - face_loop: do face = 1, cvfaces%faces + face_loop: do face = 1, cvfaces%faces - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) - quadrature_loop: do gi = 1, cvfaces%shape%ngi + quadrature_loop: do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - if(notvisited(ggi)) then - notvisited(ggi)=.false. + if(notvisited(ggi)) then + notvisited(ggi)=.false. - normgi=orientate_cvsurf_normgi(node_val(x_test, x_test_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + normgi=orientate_cvsurf_normgi(node_val(x_test, x_test_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - nodal_loop_j: do jloc = 1, field%mesh%shape%loc + nodal_loop_j: do jloc = 1, field%mesh%shape%loc - inner_dimension_loop: do dim = 1, size(normgi) + inner_dimension_loop: do dim = 1, size(normgi) - if(multiphase) then - ct_mat_local(dim, iloc, jloc) = ct_mat_local(dim, iloc, jloc) & - + field_cvshape%n(jloc, ggi)*detwei(ggi)*nvfrac_gi(ggi)*normgi(dim) - ct_mat_local(dim, oloc, jloc) = ct_mat_local(dim, oloc, jloc) & - + field_cvshape%n(jloc, ggi)*detwei(ggi)*nvfrac_gi(ggi)*(-normgi(dim)) ! notvisited - else - ct_mat_local(dim, iloc, jloc) = ct_mat_local(dim, iloc, jloc) & - + field_cvshape%n(jloc, ggi)*detwei(ggi)*normgi(dim) - ct_mat_local(dim, oloc, jloc) = ct_mat_local(dim, oloc, jloc) & - + field_cvshape%n(jloc, ggi)*detwei(ggi)*(-normgi(dim)) ! notvisited - end if + if(multiphase) then + ct_mat_local(dim, iloc, jloc) = ct_mat_local(dim, iloc, jloc) & + + field_cvshape%n(jloc, ggi)*detwei(ggi)*nvfrac_gi(ggi)*normgi(dim) + ct_mat_local(dim, oloc, jloc) = ct_mat_local(dim, oloc, jloc) & + + field_cvshape%n(jloc, ggi)*detwei(ggi)*nvfrac_gi(ggi)*(-normgi(dim)) ! notvisited + else + ct_mat_local(dim, iloc, jloc) = ct_mat_local(dim, iloc, jloc) & + + field_cvshape%n(jloc, ggi)*detwei(ggi)*normgi(dim) + ct_mat_local(dim, oloc, jloc) = ct_mat_local(dim, oloc, jloc) & + + field_cvshape%n(jloc, ggi)*detwei(ggi)*(-normgi(dim)) ! notvisited + end if - end do inner_dimension_loop + end do inner_dimension_loop - end do nodal_loop_j + end do nodal_loop_j - end if ! notvisited + end if ! notvisited - end do quadrature_loop + end do quadrature_loop - end if + end if - end do face_loop + end do face_loop - end do nodal_loop_i + end do nodal_loop_i - outer_dimension_loop: do dim = 1, size(normgi) + outer_dimension_loop: do dim = 1, size(normgi) - call addto(CT_m, 1, dim, test_nodes, field_nodes, ct_mat_local(dim,:,:)) + call addto(CT_m, 1, dim, test_nodes, field_nodes, ct_mat_local(dim,:,:)) - end do outer_dimension_loop + end do outer_dimension_loop - end do element_loop + end do element_loop - call deallocate(x_cvshape) - call deallocate(test_cvshape) - call deallocate(field_cvshape) - deallocate(x_f, detwei, normal, normgi) - deallocate(notvisited) - call deallocate(x_test) - if(multiphase) then - deallocate(nvfrac_gi) - call deallocate(nvfrac_cvshape) - end if + call deallocate(x_cvshape) + call deallocate(test_cvshape) + call deallocate(field_cvshape) + deallocate(x_f, detwei, normal, normgi) + deallocate(notvisited) + call deallocate(x_test) + if(multiphase) then + deallocate(nvfrac_gi) + call deallocate(nvfrac_cvshape) + end if end if if(.not.present_and_true(exclude_boundaries)) then - x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) - test_cvbdyshape=make_cvbdy_element_shape(cvfaces, test_mesh%faces%shape) - field_cvbdyshape=make_cvbdy_element_shape(cvfaces, field%mesh%faces%shape) - - if(multiphase) then - ! If the Coordinate and PhaseVolumeFraction meshes are different, then we need to - ! generate the PhaseVolumeFraction CV shape functions. - if(.not.(nvfrac%mesh == x%mesh)) then - nvfrac_cvbdyshape = make_cvbdy_element_shape(cvfaces, nvfrac%mesh%faces%shape) - else - nvfrac_cvbdyshape = x_cvbdyshape - call incref(nvfrac_cvbdyshape) - end if - - allocate(nvfrac_gi_f(nvfrac_cvbdyshape%ngi)) - end if - - assert(surface_element_count(test_mesh)==surface_element_count(field)) - allocate(field_bc_type(field%dim, surface_element_count(test_mesh))) - call get_entire_boundary_condition(field, (/"weakdirichlet ", & - "no_normal_flow", & - "internal ", & - "free_surface "/), field_bc, field_bc_type) - - allocate(x_ele_bdy(x%dim,x%mesh%faces%shape%loc), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi), & - field_bc_val(field_bc%dim, field_bc%mesh%shape%loc)) - allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) - allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) - allocate(ct_mat_local_bdy(x%dim, test_mesh%faces%shape%loc, field%mesh%faces%shape%loc), & - ct_rhs_local(x%dim, test_mesh%faces%shape%loc)) - - surface_element_loop: do sele = 1, surface_element_count(test_mesh) - - ! cycle if this is a no_normal_flow or a periodic or a free_surface boundary then cycle - if(any(field_bc_type(:,sele)==BC_TYPE_NO_NORMAL_FLOW).or.any(field_bc_type(:,sele)==BC_TYPE_INTERNAL)& - .or.any(field_bc_type(:,sele)==BC_TYPE_FREE_SURFACE)) cycle - - ! cycle if there's no rhs present or there's no weakdirichlet conditions or we're not - ! assembling the matrix - if(.not.(present(ct_rhs).and.any(field_bc_type(:,sele)==BC_TYPE_WEAKDIRICHLET)).and..not.l_get_ct) cycle - - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - test_nodes_bdy=face_global_nodes(test_mesh, sele) - field_nodes_bdy=face_global_nodes(field, sele) - - if(any(field_bc_type(:, sele)==BC_TYPE_WEAKDIRICHLET)) then - field_bc_val = ele_val(field_bc, sele) - else - field_bc_val = 0.0 - end if - - if(multiphase) then - nvfrac_gi_f = face_val_at_quad(nvfrac, sele, nvfrac_cvbdyshape) - end if - - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) - - ct_mat_local_bdy = 0.0 - ct_rhs_local = 0.0 - - surface_nodal_loop_i: do iloc = 1, test_mesh%faces%shape%loc + x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) + test_cvbdyshape=make_cvbdy_element_shape(cvfaces, test_mesh%faces%shape) + field_cvbdyshape=make_cvbdy_element_shape(cvfaces, field%mesh%faces%shape) - surface_face_loop: do face = 1, cvfaces%sfaces - if(cvfaces%sneiloc(iloc,face)/=0) then + if(multiphase) then + ! If the Coordinate and PhaseVolumeFraction meshes are different, then we need to + ! generate the PhaseVolumeFraction CV shape functions. + if(.not.(nvfrac%mesh == x%mesh)) then + nvfrac_cvbdyshape = make_cvbdy_element_shape(cvfaces, nvfrac%mesh%faces%shape) + else + nvfrac_cvbdyshape = x_cvbdyshape + call incref(nvfrac_cvbdyshape) + end if - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + allocate(nvfrac_gi_f(nvfrac_cvbdyshape%ngi)) + end if - ggi = (face-1)*cvfaces%shape%ngi + gi + assert(surface_element_count(test_mesh)==surface_element_count(field)) + allocate(field_bc_type(field%dim, surface_element_count(test_mesh))) + call get_entire_boundary_condition(field, (/"weakdirichlet ", & + "no_normal_flow", & + "internal ", & + "free_surface "/), field_bc, field_bc_type) - surface_nodal_loop_j: do jloc = 1, field%mesh%faces%shape%loc + allocate(x_ele_bdy(x%dim,x%mesh%faces%shape%loc), & + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi), & + field_bc_val(field_bc%dim, field_bc%mesh%shape%loc)) + allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) + allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) + allocate(ct_mat_local_bdy(x%dim, test_mesh%faces%shape%loc, field%mesh%faces%shape%loc), & + ct_rhs_local(x%dim, test_mesh%faces%shape%loc)) - surface_inner_dimension_loop: do dim = 1, size(normal_bdy,1) + surface_element_loop: do sele = 1, surface_element_count(test_mesh) - if((present(ct_rhs)).and.(field_bc_type(dim, sele)==BC_TYPE_WEAKDIRICHLET)) then + ! cycle if this is a no_normal_flow or a periodic or a free_surface boundary then cycle + if(any(field_bc_type(:,sele)==BC_TYPE_NO_NORMAL_FLOW).or.any(field_bc_type(:,sele)==BC_TYPE_INTERNAL)& + .or.any(field_bc_type(:,sele)==BC_TYPE_FREE_SURFACE)) cycle - if(multiphase) then - ct_rhs_local(dim, iloc) = ct_rhs_local(dim, iloc) - & - field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*nvfrac_gi_f(ggi)*& - normal_bdy(dim,ggi)*field_bc_val(dim, jloc) - else - ct_rhs_local(dim, iloc) = ct_rhs_local(dim, iloc) - & - field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim,ggi)*& - field_bc_val(dim, jloc) - end if + ! cycle if there's no rhs present or there's no weakdirichlet conditions or we're not + ! assembling the matrix + if(.not.(present(ct_rhs).and.any(field_bc_type(:,sele)==BC_TYPE_WEAKDIRICHLET)).and..not.l_get_ct) cycle - else + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + test_nodes_bdy=face_global_nodes(test_mesh, sele) + field_nodes_bdy=face_global_nodes(field, sele) - if(multiphase) then - ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & - field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*nvfrac_gi_f(ggi)*normal_bdy(dim, ggi) - else - ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & - field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) - end if + if(any(field_bc_type(:, sele)==BC_TYPE_WEAKDIRICHLET)) then + field_bc_val = ele_val(field_bc, sele) + else + field_bc_val = 0.0 + end if - end if + if(multiphase) then + nvfrac_gi_f = face_val_at_quad(nvfrac, sele, nvfrac_cvbdyshape) + end if - end do surface_inner_dimension_loop + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) - end do surface_nodal_loop_j + ct_mat_local_bdy = 0.0 + ct_rhs_local = 0.0 - end do surface_quadrature_loop + surface_nodal_loop_i: do iloc = 1, test_mesh%faces%shape%loc - end if + surface_face_loop: do face = 1, cvfaces%sfaces + if(cvfaces%sneiloc(iloc,face)/=0) then - end do surface_face_loop + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - end do surface_nodal_loop_i + ggi = (face-1)*cvfaces%shape%ngi + gi - surface_outer_dimension_loop: do dim = 1, size(normal_bdy,1) + surface_nodal_loop_j: do jloc = 1, field%mesh%faces%shape%loc - if((present(ct_rhs)).and.(field_bc_type(dim, sele)==BC_TYPE_WEAKDIRICHLET)) then + surface_inner_dimension_loop: do dim = 1, size(normal_bdy,1) - call addto(ct_rhs, test_nodes_bdy, ct_rhs_local(dim,:)) + if((present(ct_rhs)).and.(field_bc_type(dim, sele)==BC_TYPE_WEAKDIRICHLET)) then - elseif(l_get_ct) then + if(multiphase) then + ct_rhs_local(dim, iloc) = ct_rhs_local(dim, iloc) - & + field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*nvfrac_gi_f(ggi)*& + normal_bdy(dim,ggi)*field_bc_val(dim, jloc) + else + ct_rhs_local(dim, iloc) = ct_rhs_local(dim, iloc) - & + field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim,ggi)*& + field_bc_val(dim, jloc) + end if - call addto(CT_m, 1, dim, test_nodes_bdy, field_nodes_bdy, ct_mat_local_bdy(dim,:,:)) + else - end if + if(multiphase) then + ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & + field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*nvfrac_gi_f(ggi)*normal_bdy(dim, ggi) + else + ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & + field_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) + end if + + end if + + end do surface_inner_dimension_loop - end do surface_outer_dimension_loop + end do surface_nodal_loop_j - end do surface_element_loop + end do surface_quadrature_loop - call deallocate(field_bc) - deallocate(field_bc_type) - call deallocate(x_cvbdyshape) - call deallocate(test_cvbdyshape) - call deallocate(field_cvbdyshape) - deallocate(x_ele_bdy, detwei_bdy, normal_bdy) - deallocate(test_nodes_bdy, field_nodes_bdy) - if(multiphase) then - deallocate(nvfrac_gi_f) - call deallocate(nvfrac_cvbdyshape) - end if + end if + + end do surface_face_loop + + end do surface_nodal_loop_i + + surface_outer_dimension_loop: do dim = 1, size(normal_bdy,1) + + if((present(ct_rhs)).and.(field_bc_type(dim, sele)==BC_TYPE_WEAKDIRICHLET)) then + + call addto(ct_rhs, test_nodes_bdy, ct_rhs_local(dim,:)) + + elseif(l_get_ct) then + + call addto(CT_m, 1, dim, test_nodes_bdy, field_nodes_bdy, ct_mat_local_bdy(dim,:,:)) + + end if + + end do surface_outer_dimension_loop + + end do surface_element_loop + + call deallocate(field_bc) + deallocate(field_bc_type) + call deallocate(x_cvbdyshape) + call deallocate(test_cvbdyshape) + call deallocate(field_cvbdyshape) + deallocate(x_ele_bdy, detwei_bdy, normal_bdy) + deallocate(test_nodes_bdy, field_nodes_bdy) + if(multiphase) then + deallocate(nvfrac_gi_f) + call deallocate(nvfrac_cvbdyshape) + end if end if @@ -450,10 +450,10 @@ subroutine assemble_divergence_matrix_cv(CT_m, state, ct_rhs, & call deallocate(nvfrac) end if - end subroutine assemble_divergence_matrix_cv - !************************************************************************ + end subroutine assemble_divergence_matrix_cv + !************************************************************************ - subroutine assemble_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) + subroutine assemble_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) ! inputs/outputs ! bucket full of fields @@ -466,17 +466,17 @@ subroutine assemble_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) if((size(state)==1).and.(.not.has_scalar_field(state(1), "MaterialVolumeFraction"))) then - call assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state(1), ct_rhs) + call assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state(1), ct_rhs) else - call assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) + call assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) end if - end subroutine assemble_compressible_divergence_matrix_cv + end subroutine assemble_compressible_divergence_matrix_cv - subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) + subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) ! inputs/outputs ! bucket full of fields @@ -560,7 +560,7 @@ subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) call get_option("/timestepping/timestep", dt) call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + quaddegree, default=1) dens=>extract_scalar_field(state, "Density") olddens=>extract_scalar_field(state, "OldDensity") @@ -578,9 +578,9 @@ subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) cvfaces=find_cv_faces(vertices=ele_vertices(dens%mesh, 1), & - dimension=mesh_dim(dens%mesh), & - polydegree=dens%mesh%shape%degree, & - quaddegree=quaddegree) + dimension=mesh_dim(dens%mesh), & + polydegree=dens%mesh%shape%degree, & + quaddegree=quaddegree) x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) dens_cvshape=make_cv_element_shape(cvfaces, dens%mesh%shape) @@ -596,120 +596,120 @@ subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) if(need_upwind_values(dens_options)) then - call find_upwind_values(state, x_p, dens, dens_upwind, & - olddens, olddens_upwind) + call find_upwind_values(state, x_p, dens, dens_upwind, & + olddens, olddens_upwind) else - call zero(dens_upwind) - call zero(olddens_upwind) + call zero(dens_upwind) + call zero(olddens_upwind) end if ! find courant number (if needed) option_path_array(1) = trim(dens%option_path) ! temporary hack for compiler failure call cv_disc_get_cfl_no(option_path_array, & - state, dens%mesh, cfl_no) + state, dens%mesh, cfl_no) ! Clear memory of arrays being designed call zero(CTP_m) if(present(ct_rhs)) call zero(ct_rhs) allocate(x_ele(x%dim,ele_loc(x,1)), & - x_f(x%dim, x_cvshape%ngi), & - u_f(u%dim, u_cvshape%ngi), & - detwei(x_cvshape%ngi), & - normal(x%dim, x_cvshape%ngi), & - normgi(x%dim)) + x_f(x%dim, x_cvshape%ngi), & + u_f(u%dim, u_cvshape%ngi), & + detwei(x_cvshape%ngi), & + normal(x%dim, x_cvshape%ngi), & + normgi(x%dim)) allocate(cfl_ele(ele_loc(p,1)), & - dens_ele(ele_loc(p,1)), & - olddens_ele(ele_loc(p,1))) + dens_ele(ele_loc(p,1)), & + olddens_ele(ele_loc(p,1))) allocate(notvisited(x_cvshape%ngi)) allocate(ctp_mat_local(x%dim, p%mesh%shape%loc, u_cvshape%loc)) element_loop: do ele=1, element_count(p) - x_ele=ele_val(x, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - u_f=ele_val_at_quad(relu, ele, u_cvshape) - p_nodes=>ele_nodes(p, ele) - u_nodes=>ele_nodes(u, ele) - x_nodes=>ele_nodes(x_p, ele) + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + u_f=ele_val_at_quad(relu, ele, u_cvshape) + p_nodes=>ele_nodes(p, ele) + u_nodes=>ele_nodes(u, ele) + x_nodes=>ele_nodes(x_p, ele) - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) - cfl_ele = ele_val(cfl_no, ele) + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) + cfl_ele = ele_val(cfl_no, ele) - dens_ele = ele_val(dens, ele) - olddens_ele = ele_val(olddens, ele) + dens_ele = ele_val(dens, ele) + olddens_ele = ele_val(olddens, ele) - notvisited=.true. + notvisited=.true. - ctp_mat_local = 0.0 + ctp_mat_local = 0.0 - nodal_loop_i: do iloc = 1, p%mesh%shape%loc + nodal_loop_i: do iloc = 1, p%mesh%shape%loc - face_loop: do face = 1, cvfaces%faces + face_loop: do face = 1, cvfaces%faces - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) - quadrature_loop: do gi = 1, cvfaces%shape%ngi + quadrature_loop: do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - if(notvisited(ggi)) then - notvisited(ggi)=.false. + if(notvisited(ggi)) then + notvisited(ggi)=.false. - normgi=orientate_cvsurf_normgi(node_val(x_p, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + normgi=orientate_cvsurf_normgi(node_val(x_p, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - udotn=dot_product(u_f(:,ggi), normgi(:)) + udotn=dot_product(u_f(:,ggi), normgi(:)) - inflow = (udotn<=0.0) + inflow = (udotn<=0.0) - income = merge(1.0,0.0,inflow) + income = merge(1.0,0.0,inflow) - call evaluate_face_val(dens_face_val, olddens_face_val, & - iloc, oloc, ggi, x_nodes, & - dens_cvshape,& - dens_ele, olddens_ele, & - dens_upwind, olddens_upwind, & - inflow, cfl_ele, & - dens_options) + call evaluate_face_val(dens_face_val, olddens_face_val, & + iloc, oloc, ggi, x_nodes, & + dens_cvshape,& + dens_ele, olddens_ele, & + dens_upwind, olddens_upwind, & + inflow, cfl_ele, & + dens_options) - dens_theta_val=theta_val(iloc, oloc, & - dens_face_val, & - olddens_face_val, & - dens_options%theta, dt, udotn, & - x_ele, dens_options%limit_theta, & - dens_ele, olddens_ele) + dens_theta_val=theta_val(iloc, oloc, & + dens_face_val, & + olddens_face_val, & + dens_options%theta, dt, udotn, & + x_ele, dens_options%limit_theta, & + dens_ele, olddens_ele) - nodal_loop_j: do jloc = 1, u_cvshape%loc + nodal_loop_j: do jloc = 1, u_cvshape%loc - face_value = u_cvshape%n(jloc, ggi)*detwei(ggi)*dens_theta_val + face_value = u_cvshape%n(jloc, ggi)*detwei(ggi)*dens_theta_val - inner_dimension_loop: do dim = 1, size(normgi) + inner_dimension_loop: do dim = 1, size(normgi) - ctp_mat_local(dim, iloc, jloc) = ctp_mat_local(dim, iloc, jloc) & - + face_value*normgi(dim) - ctp_mat_local(dim, oloc, jloc) = ctp_mat_local(dim, oloc, jloc) & - + face_value*(-normgi(dim)) ! notvisited + ctp_mat_local(dim, iloc, jloc) = ctp_mat_local(dim, iloc, jloc) & + + face_value*normgi(dim) + ctp_mat_local(dim, oloc, jloc) = ctp_mat_local(dim, oloc, jloc) & + + face_value*(-normgi(dim)) ! notvisited - end do inner_dimension_loop + end do inner_dimension_loop - end do nodal_loop_j + end do nodal_loop_j - end if ! notvisited + end if ! notvisited - end do quadrature_loop + end do quadrature_loop - end if - end do face_loop - end do nodal_loop_i + end if + end do face_loop + end do nodal_loop_i - outer_dimension_loop: do dim = 1, size(normgi) + outer_dimension_loop: do dim = 1, size(normgi) call addto(CTP_m, 1, dim, p_nodes, u_nodes, ctp_mat_local(dim,:,:)) - end do outer_dimension_loop + end do outer_dimension_loop end do element_loop @@ -718,130 +718,130 @@ subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) dens_cvbdyshape=make_cvbdy_element_shape(cvfaces, dens%mesh%faces%shape) allocate(x_ele_bdy(x%dim,face_loc(x,1)), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi), & - u_bdy_f(u%dim, u_cvbdyshape%ngi), & - dens_ele_bdy(face_loc(dens,1)), & - olddens_ele_bdy(face_loc(dens,1)), & - ghost_dens_ele_bdy(face_loc(dens,1)), & - ghost_olddens_ele_bdy(face_loc(dens,1))) + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi), & + u_bdy_f(u%dim, u_cvbdyshape%ngi), & + dens_ele_bdy(face_loc(dens,1)), & + olddens_ele_bdy(face_loc(dens,1)), & + ghost_dens_ele_bdy(face_loc(dens,1)), & + ghost_olddens_ele_bdy(face_loc(dens,1))) allocate(dens_bc_type(surface_element_count(dens)), & - u_nodes_bdy(face_loc(u,1)), & - p_nodes_bdy(face_loc(p,1)), & - velocity_bc_type(u%dim, surface_element_count(u)), & - velocity_bc_val(u%dim, u%mesh%faces%shape%loc)) + u_nodes_bdy(face_loc(u,1)), & + p_nodes_bdy(face_loc(p,1)), & + velocity_bc_type(u%dim, surface_element_count(u)), & + velocity_bc_val(u%dim, u%mesh%faces%shape%loc)) allocate(ctp_mat_local_bdy(x%dim, p%mesh%faces%shape%loc, u_cvbdyshape%loc), & - ct_rhs_local(p%mesh%faces%shape%loc)) + ct_rhs_local(p%mesh%faces%shape%loc)) call get_entire_boundary_condition(dens, & - (/"weakdirichlet"/), & - dens_bc, dens_bc_type) + (/"weakdirichlet"/), & + dens_bc, dens_bc_type) call get_entire_boundary_condition(u, (/"weakdirichlet ", & - "no_normal_flow", & - "internal "/), & - velocity_bc, velocity_bc_type) + "no_normal_flow", & + "internal "/), & + velocity_bc, velocity_bc_type) surface_element_loop: do sele = 1, surface_element_count(p) - if(any(velocity_bc_type(:,sele)==2).or.any(velocity_bc_type(:,sele)==3)) cycle + if(any(velocity_bc_type(:,sele)==2).or.any(velocity_bc_type(:,sele)==3)) cycle - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - u_nodes_bdy=face_global_nodes(u, sele) - p_nodes_bdy=face_global_nodes(p, sele) + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + u_nodes_bdy=face_global_nodes(u, sele) + p_nodes_bdy=face_global_nodes(p, sele) - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) - u_bdy_f=face_val_at_quad(relu, sele, u_cvbdyshape) + u_bdy_f=face_val_at_quad(relu, sele, u_cvbdyshape) - if(any(velocity_bc_type(:, sele)==1)) then - velocity_bc_val = ele_val(velocity_bc, sele) - else - velocity_bc_val = 0.0 - end if + if(any(velocity_bc_type(:, sele)==1)) then + velocity_bc_val = ele_val(velocity_bc, sele) + else + velocity_bc_val = 0.0 + end if - if(dens_bc_type(sele)==1) then - ghost_dens_ele_bdy=ele_val(dens_bc, sele) - else - ghost_dens_ele_bdy=face_val(dens, sele) - end if + if(dens_bc_type(sele)==1) then + ghost_dens_ele_bdy=ele_val(dens_bc, sele) + else + ghost_dens_ele_bdy=face_val(dens, sele) + end if - if(dens_bc_type(sele)==1) then - ghost_olddens_ele_bdy=ele_val(dens_bc, sele) ! not considering time varying bcs yet - unused - else - ghost_olddens_ele_bdy=face_val(olddens, sele) ! - unused - end if + if(dens_bc_type(sele)==1) then + ghost_olddens_ele_bdy=ele_val(dens_bc, sele) ! not considering time varying bcs yet - unused + else + ghost_olddens_ele_bdy=face_val(olddens, sele) ! - unused + end if - dens_ele_bdy=face_val(dens, sele) - olddens_ele_bdy=face_val(olddens, sele) + dens_ele_bdy=face_val(dens, sele) + olddens_ele_bdy=face_val(olddens, sele) - ctp_mat_local_bdy = 0.0 - ct_rhs_local = 0.0 + ctp_mat_local_bdy = 0.0 + ct_rhs_local = 0.0 - surface_nodal_loop_i: do iloc = 1, p%mesh%faces%shape%loc + surface_nodal_loop_i: do iloc = 1, p%mesh%faces%shape%loc - surface_face_loop: do face = 1, cvfaces%sfaces + surface_face_loop: do face = 1, cvfaces%sfaces - if(cvfaces%sneiloc(iloc,face)/=0) then + if(cvfaces%sneiloc(iloc,face)/=0) then - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) + udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) - if(udotn>0) then - income=0.0 - else - income=1.0 - end if + if(udotn>0) then + income=0.0 + else + income=1.0 + end if - face_value = (income*ghost_dens_ele_bdy(iloc) + (1.-income)*dens_ele_bdy(iloc)) + face_value = (income*ghost_dens_ele_bdy(iloc) + (1.-income)*dens_ele_bdy(iloc)) - surface_nodal_loop_j: do jloc = 1, u_cvbdyshape%loc + surface_nodal_loop_j: do jloc = 1, u_cvbdyshape%loc - surface_inner_dimension_loop: do dim = 1, size(normal_bdy,1) + surface_inner_dimension_loop: do dim = 1, size(normal_bdy,1) - if((present(ct_rhs)).and.(velocity_bc_type(dim, sele)==1)) then + if((present(ct_rhs)).and.(velocity_bc_type(dim, sele)==1)) then - ct_rhs_local(iloc) = ct_rhs_local(iloc) + & - face_value*u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim,ggi)*velocity_bc_val(dim,jloc) + ct_rhs_local(iloc) = ct_rhs_local(iloc) + & + face_value*u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim,ggi)*velocity_bc_val(dim,jloc) - else + else - ctp_mat_local_bdy(dim, iloc, jloc) = ctp_mat_local_bdy(dim, iloc, jloc) & - + face_value*u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) + ctp_mat_local_bdy(dim, iloc, jloc) = ctp_mat_local_bdy(dim, iloc, jloc) & + + face_value*u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) - end if + end if - end do surface_inner_dimension_loop + end do surface_inner_dimension_loop - end do surface_nodal_loop_j + end do surface_nodal_loop_j - end do surface_quadrature_loop + end do surface_quadrature_loop - end if ! sneiloc + end if ! sneiloc - end do surface_face_loop + end do surface_face_loop - end do surface_nodal_loop_i + end do surface_nodal_loop_i - surface_outer_dimension_loop: do dim = 1, size(normal_bdy,1) + surface_outer_dimension_loop: do dim = 1, size(normal_bdy,1) - if((present(ct_rhs)).and.(velocity_bc_type(dim, sele)==1)) then + if((present(ct_rhs)).and.(velocity_bc_type(dim, sele)==1)) then - call addto(ct_rhs, p_nodes_bdy, ct_rhs_local) + call addto(ct_rhs, p_nodes_bdy, ct_rhs_local) - else + else - call addto(CTP_m, 1, dim, p_nodes_bdy, u_nodes_bdy, ctp_mat_local_bdy(dim,:,:)) + call addto(CTP_m, 1, dim, p_nodes_bdy, u_nodes_bdy, ctp_mat_local_bdy(dim,:,:)) - end if + end if - end do surface_outer_dimension_loop + end do surface_outer_dimension_loop end do surface_element_loop @@ -873,10 +873,10 @@ subroutine assemble_1mat_compressible_divergence_matrix_cv(CTP_m, state, ct_rhs) call deallocate(cfl_no) call deallocate(x_p) - end subroutine assemble_1mat_compressible_divergence_matrix_cv - !************************************************************************ + end subroutine assemble_1mat_compressible_divergence_matrix_cv + !************************************************************************ - subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) + subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) ! inputs/outputs ! bucket full of fields @@ -900,11 +900,11 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) real :: matvfrac_face_val, matdens_face_val real :: oldmatvfrac_face_val, oldmatdens_face_val real, dimension(:), allocatable :: matdens_ele, oldmatdens_ele, & - matvfrac_ele, oldmatvfrac_ele + matvfrac_ele, oldmatvfrac_ele real, dimension(:), allocatable :: matdens_ele_bdy, oldmatdens_ele_bdy, & - matvfrac_ele_bdy, oldmatvfrac_ele_bdy + matvfrac_ele_bdy, oldmatvfrac_ele_bdy real, dimension(:), allocatable :: ghost_matdens_ele_bdy, ghost_oldmatdens_ele_bdy, & - ghost_matvfrac_ele_bdy, ghost_oldmatvfrac_ele_bdy + ghost_matvfrac_ele_bdy, ghost_oldmatvfrac_ele_bdy integer, dimension(:), allocatable :: visited @@ -925,8 +925,8 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) type(csr_sparsity), pointer :: mesh_sparsity type(csr_matrix) :: matvfrac_upwind, & - oldmatvfrac_upwind, matdens_upwind, oldmatdens_upwind, & - summatvfrac_upwind, sumoldmatvfrac_upwind + oldmatvfrac_upwind, matdens_upwind, oldmatdens_upwind, & + summatvfrac_upwind, sumoldmatvfrac_upwind type(scalar_field), pointer :: matvfrac, oldmatvfrac, matdens, oldmatdens type(scalar_field), pointer :: dummyvfrac @@ -980,28 +980,28 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) call get_option("/timestepping/timestep", dt) call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + quaddegree, default=1) cvfaces=find_cv_faces(vertices=ele_vertices(p, 1), & - dimension=mesh_dim(p), & - polydegree=p%mesh%shape%degree, & - quaddegree=quaddegree) + dimension=mesh_dim(p), & + polydegree=p%mesh%shape%degree, & + quaddegree=quaddegree) x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) u_cvshape=make_cv_element_shape(cvfaces, u%mesh%shape) p_cvshape=make_cv_element_shape(cvfaces, p%mesh%shape) allocate(x_ele(x%dim,ele_loc(x,1)), & - x_f(x%dim, x_cvshape%ngi), & - u_f(u%dim, u_cvshape%ngi), & - detwei(x_cvshape%ngi), & - normal(x%dim, x_cvshape%ngi), & - normgi(x%dim)) + x_f(x%dim, x_cvshape%ngi), & + u_f(u%dim, u_cvshape%ngi), & + detwei(x_cvshape%ngi), & + normal(x%dim, x_cvshape%ngi), & + normgi(x%dim)) allocate(cfl_ele(ele_loc(p,1)), & - matvfrac_ele(ele_loc(p,1)), & - oldmatvfrac_ele(ele_loc(p,1)), & - matdens_ele(ele_loc(p,1)), & - oldmatdens_ele(ele_loc(p,1))) + matvfrac_ele(ele_loc(p,1)), & + oldmatvfrac_ele(ele_loc(p,1)), & + matdens_ele(ele_loc(p,1)), & + oldmatdens_ele(ele_loc(p,1))) allocate(visited(x_cvshape%ngi)) allocate(ctp_mat_local(x%dim, p%mesh%shape%loc, u_cvshape%loc)) @@ -1028,35 +1028,35 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) vfrac_option_path = " " do i = 1, size(state) - matvfrac=>extract_scalar_field(state(i), "MaterialVolumeFraction", stat=vstat) - if(vstat==0) then - if((.not.aliased(matvfrac)).and.(.not.have_option(trim(matvfrac%option_path)//"/diagnostic"))) then + matvfrac=>extract_scalar_field(state(i), "MaterialVolumeFraction", stat=vstat) + if(vstat==0) then + if((.not.aliased(matvfrac)).and.(.not.have_option(trim(matvfrac%option_path)//"/diagnostic"))) then - vfrac_option_path = trim(matvfrac%option_path) + vfrac_option_path = trim(matvfrac%option_path) - if(need_upwind_values(trim(matvfrac%option_path))) then - oldmatvfrac=>extract_scalar_field(state(i), "OldMaterialVolumeFraction") + if(need_upwind_values(trim(matvfrac%option_path))) then + oldmatvfrac=>extract_scalar_field(state(i), "OldMaterialVolumeFraction") - call find_upwind_values(state, x_p, matvfrac, matvfrac_upwind, & - oldmatvfrac, oldmatvfrac_upwind, defer_deletion=.true.) - summatvfrac_upwind%val=summatvfrac_upwind%val+matvfrac_upwind%val + call find_upwind_values(state, x_p, matvfrac, matvfrac_upwind, & + oldmatvfrac, oldmatvfrac_upwind, defer_deletion=.true.) + summatvfrac_upwind%val=summatvfrac_upwind%val+matvfrac_upwind%val - sumoldmatvfrac_upwind%val=sumoldmatvfrac_upwind%val+oldmatvfrac_upwind%val - end if + sumoldmatvfrac_upwind%val=sumoldmatvfrac_upwind%val+oldmatvfrac_upwind%val + end if - allocate(matvfrac_bc_type(surface_element_count(matvfrac))) - call get_entire_boundary_condition(matvfrac, (/"weakdirichlet"/), matvfrac_bc, matvfrac_bc_type) + allocate(matvfrac_bc_type(surface_element_count(matvfrac))) + call get_entire_boundary_condition(matvfrac, (/"weakdirichlet"/), matvfrac_bc, matvfrac_bc_type) - assert(all(summatvfrac_bc%mesh%ndglno==matvfrac_bc%mesh%ndglno)) ! make sure fields are on the same mesh + assert(all(summatvfrac_bc%mesh%ndglno==matvfrac_bc%mesh%ndglno)) ! make sure fields are on the same mesh - summatvfrac_bc%val=summatvfrac_bc%val+matvfrac_bc%val - dummyvfrac_bc_type=matvfrac_bc_type ! we assume the bcs are the same on all volume fractions + summatvfrac_bc%val=summatvfrac_bc%val+matvfrac_bc%val + dummyvfrac_bc_type=matvfrac_bc_type ! we assume the bcs are the same on all volume fractions - call deallocate(matvfrac_bc) - deallocate(matvfrac_bc_type) - end if + call deallocate(matvfrac_bc) + deallocate(matvfrac_bc_type) + end if - end if + end if end do @@ -1066,8 +1066,8 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) ! FIXME: don't make me assume I'm on the volume fraction call allocate(cfl_no, p%mesh, "CourantNumber") call get_option(trim(complete_cv_field_path(vfrac_option_path))//& - "/face_value[0]/courant_number[0]/name", & - cfl_type, stat) + "/face_value[0]/courant_number[0]/name", & + cfl_type, stat) if (stat==0) then call calculate_diagnostic_variable(state(1), trim(cfl_type), cfl_no) else @@ -1078,331 +1078,331 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) call zero(CTP_m) do i = 1, size(state) - matdens=>extract_scalar_field(state(i), "MaterialDensity", stat=dstat) + matdens=>extract_scalar_field(state(i), "MaterialDensity", stat=dstat) - if(dstat==0) then - oldmatdens=>extract_scalar_field(state(i), "OldMaterialDensity") + if(dstat==0) then + oldmatdens=>extract_scalar_field(state(i), "OldMaterialDensity") - if(need_upwind_values(trim(matdens%option_path))) then + if(need_upwind_values(trim(matdens%option_path))) then - call find_upwind_values(state, x_p, matdens, matdens_upwind, & - oldmatdens, oldmatdens_upwind, defer_deletion=.true.) + call find_upwind_values(state, x_p, matdens, matdens_upwind, & + oldmatdens, oldmatdens_upwind, defer_deletion=.true.) - else + else - call zero(matdens_upwind) - call zero(oldmatdens_upwind) + call zero(matdens_upwind) + call zero(oldmatdens_upwind) - end if + end if - ! get all the relevent options for material density - ! handily wrapped in a new type... - matdens_options = get_cv_options(matdens%option_path, matdens%mesh%shape%numbering%family, mesh_dim(matdens)) + ! get all the relevent options for material density + ! handily wrapped in a new type... + matdens_options = get_cv_options(matdens%option_path, matdens%mesh%shape%numbering%family, mesh_dim(matdens)) - matvfrac=>extract_scalar_field(state(i), "MaterialVolumeFraction", stat=vstat) - if(vstat==0) then - oldmatvfrac=>extract_scalar_field(state(i), "OldMaterialVolumeFraction") - else - if(nmatdens==1) then + matvfrac=>extract_scalar_field(state(i), "MaterialVolumeFraction", stat=vstat) + if(vstat==0) then + oldmatvfrac=>extract_scalar_field(state(i), "OldMaterialVolumeFraction") + else + if(nmatdens==1) then - matvfrac=>dummyvfrac - oldmatvfrac=>dummyvfrac + matvfrac=>dummyvfrac + oldmatvfrac=>dummyvfrac - else - ewrite(-1,*) "Multiple MaterialDensities but at least " - ewrite(-1,*) "one has no associated MaterialVolumeFraction" - FLExit("This shouldn't happen") ! move this to a multimaterials check options + else + ewrite(-1,*) "Multiple MaterialDensities but at least " + ewrite(-1,*) "one has no associated MaterialVolumeFraction" + FLExit("This shouldn't happen") ! move this to a multimaterials check options + end if end if - end if - if(need_upwind_values(trim(matvfrac%option_path))) then + if(need_upwind_values(trim(matvfrac%option_path))) then + + call find_upwind_values(state, x_p, matvfrac, matvfrac_upwind, & + oldmatvfrac, oldmatvfrac_upwind, defer_deletion=.true.) - call find_upwind_values(state, x_p, matvfrac, matvfrac_upwind, & - oldmatvfrac, oldmatvfrac_upwind, defer_deletion=.true.) + vfrac_option_path=trim(matvfrac%option_path) - vfrac_option_path=trim(matvfrac%option_path) + else - else + matvfrac_upwind%val = 1.0 - summatvfrac_upwind%val + oldmatvfrac_upwind%val = 1.0 - sumoldmatvfrac_upwind%val - matvfrac_upwind%val = 1.0 - summatvfrac_upwind%val - oldmatvfrac_upwind%val = 1.0 - sumoldmatvfrac_upwind%val + end if - end if + ! get all the relevent options for material volume fraction + ! handily wrapped in a new type... + if((size(state)>1)) then + ! only possible if we have more than 1 state (since with 1 state the volume fraction won't + ! be prognostic and won't have the relevant options) + matvfrac_options = get_cv_options(vfrac_option_path, matvfrac%mesh%shape%numbering%family, mesh_dim(matvfrac)) + end if - ! get all the relevent options for material volume fraction - ! handily wrapped in a new type... - if((size(state)>1)) then - ! only possible if we have more than 1 state (since with 1 state the volume fraction won't - ! be prognostic and won't have the relevant options) - matvfrac_options = get_cv_options(vfrac_option_path, matvfrac%mesh%shape%numbering%family, mesh_dim(matvfrac)) - end if + do ele=1, element_count(p) + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + u_f=ele_val_at_quad(relu, ele, u_cvshape) + nodes=>ele_nodes(u, ele) + x_nodes=>ele_nodes(x_p, ele) - do ele=1, element_count(p) - x_ele=ele_val(x, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - u_f=ele_val_at_quad(relu, ele, u_cvshape) - nodes=>ele_nodes(u, ele) - x_nodes=>ele_nodes(x_p, ele) + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) + cfl_ele = ele_val(cfl_no, ele) - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) - cfl_ele = ele_val(cfl_no, ele) + matvfrac_ele = ele_val(matvfrac, ele) + oldmatvfrac_ele = ele_val(oldmatvfrac, ele) - matvfrac_ele = ele_val(matvfrac, ele) - oldmatvfrac_ele = ele_val(oldmatvfrac, ele) + matdens_ele = ele_val(matdens, ele) + oldmatdens_ele = ele_val(oldmatdens, ele) - matdens_ele = ele_val(matdens, ele) - oldmatdens_ele = ele_val(oldmatdens, ele) + visited=0 - visited=0 + ctp_mat_local = 0.0 - ctp_mat_local = 0.0 + do iloc = 1, p%mesh%shape%loc - do iloc = 1, p%mesh%shape%loc + do face = 1, cvfaces%faces - do face = 1, cvfaces%faces + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) + do gi = 1, cvfaces%shape%ngi - do gi = 1, cvfaces%shape%ngi + ggi = (face-1)*cvfaces%shape%ngi + gi - ggi = (face-1)*cvfaces%shape%ngi + gi + if(visited(ggi)==0) then + visited(ggi)=1 - if(visited(ggi)==0) then - visited(ggi)=1 + normgi=orientate_cvsurf_normgi(x_ele(:,iloc),x_f(:,ggi),normal(:,ggi)) - normgi=orientate_cvsurf_normgi(x_ele(:,iloc),x_f(:,ggi),normal(:,ggi)) + udotn=dot_product(u_f(:,ggi), normgi(:)) - udotn=dot_product(u_f(:,ggi), normgi(:)) + inflow = (udotn<=0.0) - inflow = (udotn<=0.0) + income = merge(1.0,0.0,inflow) - income = merge(1.0,0.0,inflow) + select case (matvfrac%field_type) + case(FIELD_TYPE_CONSTANT) - select case (matvfrac%field_type) - case(FIELD_TYPE_CONSTANT) + matvfrac_face_val = matvfrac_ele(iloc) + oldmatvfrac_face_val = oldmatvfrac_ele(iloc) - matvfrac_face_val = matvfrac_ele(iloc) - oldmatvfrac_face_val = oldmatvfrac_ele(iloc) + case default - case default + if(size(state)>1) then + call evaluate_face_val(matvfrac_face_val, oldmatvfrac_face_val, & + iloc, oloc, ggi, x_nodes, & + p_cvshape, & + matvfrac_ele, oldmatvfrac_ele, & + matvfrac_upwind, oldmatvfrac_upwind, & + inflow, cfl_ele, & + matvfrac_options) + else + matvfrac_face_val = matvfrac_ele(iloc) + oldmatvfrac_face_val = oldmatvfrac_ele(iloc) + end if - if(size(state)>1) then - call evaluate_face_val(matvfrac_face_val, oldmatvfrac_face_val, & - iloc, oloc, ggi, x_nodes, & - p_cvshape, & - matvfrac_ele, oldmatvfrac_ele, & - matvfrac_upwind, oldmatvfrac_upwind, & - inflow, cfl_ele, & - matvfrac_options) - else - matvfrac_face_val = matvfrac_ele(iloc) - oldmatvfrac_face_val = oldmatvfrac_ele(iloc) - end if + end select - end select + call evaluate_face_val(matdens_face_val, oldmatdens_face_val, & + iloc, oloc, ggi, x_nodes, & + p_cvshape,& + matdens_ele, oldmatdens_ele, & + matdens_upwind, oldmatdens_upwind, & + inflow, cfl_ele, & + matdens_options) - call evaluate_face_val(matdens_face_val, oldmatdens_face_val, & - iloc, oloc, ggi, x_nodes, & - p_cvshape,& - matdens_ele, oldmatdens_ele, & - matdens_upwind, oldmatdens_upwind, & - inflow, cfl_ele, & - matdens_options) + if(size(state)>1) then + matvfrac_theta_val=theta_val(iloc, oloc, & + matvfrac_face_val, & + oldmatvfrac_face_val, & + matvfrac_options%theta, dt, udotn, & + x_ele, matvfrac_options%limit_theta, & + matvfrac_ele, oldmatvfrac_ele) + else + matvfrac_theta_val = matvfrac_face_val + end if - if(size(state)>1) then - matvfrac_theta_val=theta_val(iloc, oloc, & - matvfrac_face_val, & - oldmatvfrac_face_val, & - matvfrac_options%theta, dt, udotn, & - x_ele, matvfrac_options%limit_theta, & - matvfrac_ele, oldmatvfrac_ele) - else - matvfrac_theta_val = matvfrac_face_val - end if + matdens_theta_val=theta_val(iloc, oloc, & + matdens_face_val, & + oldmatdens_face_val, & + matdens_options%theta, dt, udotn, & + x_ele, matdens_options%limit_theta, & + matdens_ele, oldmatdens_ele) - matdens_theta_val=theta_val(iloc, oloc, & - matdens_face_val, & - oldmatdens_face_val, & - matdens_options%theta, dt, udotn, & - x_ele, matdens_options%limit_theta, & - matdens_ele, oldmatdens_ele) + do jloc = 1, u_cvshape%loc - do jloc = 1, u_cvshape%loc + face_value = u_cvshape%n(jloc, ggi)*detwei(ggi)*matvfrac_theta_val*matdens_theta_val - face_value = u_cvshape%n(jloc, ggi)*detwei(ggi)*matvfrac_theta_val*matdens_theta_val + do dim = 1, size(normgi) - do dim = 1, size(normgi) + ctp_mat_local(dim, iloc, jloc) = ctp_mat_local(dim, iloc, jloc) & + + face_value*normgi(dim) + ctp_mat_local(dim, oloc, jloc) = ctp_mat_local(dim, oloc, jloc) & + + face_value*(-normgi(dim)) ! notvisited - ctp_mat_local(dim, iloc, jloc) = ctp_mat_local(dim, iloc, jloc) & - + face_value*normgi(dim) - ctp_mat_local(dim, oloc, jloc) = ctp_mat_local(dim, oloc, jloc) & - + face_value*(-normgi(dim)) ! notvisited + end do - end do + end do - end do + end if ! visited - end if ! visited + end do + end if end do + end do - end if - end do - end do + do dim = 1, size(normgi) + call addto(CTP_m, 1, dim, nodes, nodes, ctp_mat_local(dim,:,:)) + end do - do dim = 1, size(normgi) - call addto(CTP_m, 1, dim, nodes, nodes, ctp_mat_local(dim,:,:)) end do - end do - - x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) - u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) - p_cvbdyshape=make_cvbdy_element_shape(cvfaces, p%mesh%faces%shape) - - allocate(x_ele_bdy(x%dim,face_loc(x,1)), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi), & - u_bdy_f(u%dim, u_cvbdyshape%ngi), & - matdens_ele_bdy(face_loc(p,1)), & - oldmatdens_ele_bdy(face_loc(p,1)), & - matvfrac_ele_bdy(face_loc(p,1)), & - oldmatvfrac_ele_bdy(face_loc(p,1)), & - ghost_matdens_ele_bdy(face_loc(p,1)), & - ghost_oldmatdens_ele_bdy(face_loc(p,1)), & - ghost_matvfrac_ele_bdy(face_loc(p,1)), & - ghost_oldmatvfrac_ele_bdy(face_loc(p,1))) - allocate(matvfrac_bc_type(surface_element_count(matvfrac)), & - matdens_bc_type(surface_element_count(matdens)), & - nodes_bdy(face_loc(u,1)), & - velocity_bc_type(u%dim, surface_element_count(u))) - allocate(ctp_mat_local_bdy(x%dim, p%mesh%faces%shape%loc, u_cvbdyshape%loc)) - - if((.not.aliased(matvfrac)).and.(.not.have_option(trim(matvfrac%option_path)//"/diagnostic"))) then - call get_entire_boundary_condition(matvfrac, (/"weakdirichlet"/), matvfrac_bc, matvfrac_bc_type) - else - call allocate(matvfrac_bc, summatvfrac_bc%mesh, "TemporaryMaterialVolumeFraction") - matvfrac_bc%val = 1.0-summatvfrac_bc%val - matvfrac_bc_type = dummyvfrac_bc_type - end if - call get_entire_boundary_condition(matdens, (/"weakdirichlet"/), matdens_bc, matdens_bc_type) - - call get_entire_boundary_condition(u, (/"weakdirichlet ", "no_normal_flow", "internal "/), velocity_bc, velocity_bc_type) - - do sele = 1, surface_element_count(p) - - if(any(velocity_bc_type(:,sele)==2).or.any(velocity_bc_type(:,sele)==3)) cycle + x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) + u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) + p_cvbdyshape=make_cvbdy_element_shape(cvfaces, p%mesh%faces%shape) - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - nodes_bdy=face_global_nodes(u, sele) + allocate(x_ele_bdy(x%dim,face_loc(x,1)), & + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi), & + u_bdy_f(u%dim, u_cvbdyshape%ngi), & + matdens_ele_bdy(face_loc(p,1)), & + oldmatdens_ele_bdy(face_loc(p,1)), & + matvfrac_ele_bdy(face_loc(p,1)), & + oldmatvfrac_ele_bdy(face_loc(p,1)), & + ghost_matdens_ele_bdy(face_loc(p,1)), & + ghost_oldmatdens_ele_bdy(face_loc(p,1)), & + ghost_matvfrac_ele_bdy(face_loc(p,1)), & + ghost_oldmatvfrac_ele_bdy(face_loc(p,1))) + allocate(matvfrac_bc_type(surface_element_count(matvfrac)), & + matdens_bc_type(surface_element_count(matdens)), & + nodes_bdy(face_loc(u,1)), & + velocity_bc_type(u%dim, surface_element_count(u))) + allocate(ctp_mat_local_bdy(x%dim, p%mesh%faces%shape%loc, u_cvbdyshape%loc)) + + if((.not.aliased(matvfrac)).and.(.not.have_option(trim(matvfrac%option_path)//"/diagnostic"))) then + call get_entire_boundary_condition(matvfrac, (/"weakdirichlet"/), matvfrac_bc, matvfrac_bc_type) + else + call allocate(matvfrac_bc, summatvfrac_bc%mesh, "TemporaryMaterialVolumeFraction") + matvfrac_bc%val = 1.0-summatvfrac_bc%val + matvfrac_bc_type = dummyvfrac_bc_type + end if + call get_entire_boundary_condition(matdens, (/"weakdirichlet"/), matdens_bc, matdens_bc_type) - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) + call get_entire_boundary_condition(u, (/"weakdirichlet ", "no_normal_flow", "internal "/), velocity_bc, velocity_bc_type) - u_bdy_f=face_val_at_quad(relu, sele, u_cvbdyshape) + do sele = 1, surface_element_count(p) - if(matvfrac_bc_type(sele)==1) then - ghost_matvfrac_ele_bdy=ele_val(matvfrac_bc, sele) - else - ghost_matvfrac_ele_bdy=face_val(matvfrac, sele) - end if + if(any(velocity_bc_type(:,sele)==2).or.any(velocity_bc_type(:,sele)==3)) cycle - if(matvfrac_bc_type(sele)==1) then - ghost_oldmatvfrac_ele_bdy=ele_val(matvfrac_bc, sele) ! not considering time varying bcs yet - unused - else - ghost_oldmatvfrac_ele_bdy=face_val(oldmatvfrac, sele) ! - unused - end if + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + nodes_bdy=face_global_nodes(u, sele) - matvfrac_ele_bdy=face_val(matvfrac, sele) - oldmatvfrac_ele_bdy=face_val(oldmatvfrac, sele) + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) - if(matdens_bc_type(sele)==1) then - ghost_matdens_ele_bdy=ele_val(matdens_bc, sele) - else - ghost_matdens_ele_bdy=face_val(matdens, sele) - end if + u_bdy_f=face_val_at_quad(relu, sele, u_cvbdyshape) - if(matdens_bc_type(sele)==1) then - ghost_oldmatdens_ele_bdy=ele_val(matdens_bc, sele) ! not considering time varying bcs yet - unused - else - ghost_oldmatdens_ele_bdy=face_val(oldmatdens, sele) ! - unused - end if + if(matvfrac_bc_type(sele)==1) then + ghost_matvfrac_ele_bdy=ele_val(matvfrac_bc, sele) + else + ghost_matvfrac_ele_bdy=face_val(matvfrac, sele) + end if - matdens_ele_bdy=face_val(matdens, sele) - oldmatdens_ele_bdy=face_val(oldmatdens, sele) + if(matvfrac_bc_type(sele)==1) then + ghost_oldmatvfrac_ele_bdy=ele_val(matvfrac_bc, sele) ! not considering time varying bcs yet - unused + else + ghost_oldmatvfrac_ele_bdy=face_val(oldmatvfrac, sele) ! - unused + end if - ctp_mat_local_bdy = 0.0 + matvfrac_ele_bdy=face_val(matvfrac, sele) + oldmatvfrac_ele_bdy=face_val(oldmatvfrac, sele) - do iloc = 1, p%mesh%faces%shape%loc + if(matdens_bc_type(sele)==1) then + ghost_matdens_ele_bdy=ele_val(matdens_bc, sele) + else + ghost_matdens_ele_bdy=face_val(matdens, sele) + end if - do face = 1, cvfaces%sfaces + if(matdens_bc_type(sele)==1) then + ghost_oldmatdens_ele_bdy=ele_val(matdens_bc, sele) ! not considering time varying bcs yet - unused + else + ghost_oldmatdens_ele_bdy=face_val(oldmatdens, sele) ! - unused + end if - if(cvfaces%sneiloc(iloc,face)/=0) then + matdens_ele_bdy=face_val(matdens, sele) + oldmatdens_ele_bdy=face_val(oldmatdens, sele) - do gi = 1, cvfaces%shape%ngi + ctp_mat_local_bdy = 0.0 - ggi = (face-1)*cvfaces%shape%ngi + gi + do iloc = 1, p%mesh%faces%shape%loc - udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) + do face = 1, cvfaces%sfaces - if(udotn>0) then - income=0.0 - else - income=1.0 - end if + if(cvfaces%sneiloc(iloc,face)/=0) then - face_value = (income*ghost_matvfrac_ele_bdy(iloc) + (1.-income)*matvfrac_ele_bdy(iloc))* & - (income*ghost_matdens_ele_bdy(iloc) + (1.-income)*matdens_ele_bdy(iloc)) + do gi = 1, cvfaces%shape%ngi - do jloc = 1, u_cvbdyshape%loc + ggi = (face-1)*cvfaces%shape%ngi + gi - do dim = 1, size(normal_bdy,1) + udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) - ctp_mat_local_bdy(dim, iloc, jloc) = ctp_mat_local_bdy(dim, iloc, jloc) & + if(udotn>0) then + income=0.0 + else + income=1.0 + end if + + face_value = (income*ghost_matvfrac_ele_bdy(iloc) + (1.-income)*matvfrac_ele_bdy(iloc))* & + (income*ghost_matdens_ele_bdy(iloc) + (1.-income)*matdens_ele_bdy(iloc)) + + do jloc = 1, u_cvbdyshape%loc + + do dim = 1, size(normal_bdy,1) + + ctp_mat_local_bdy(dim, iloc, jloc) = ctp_mat_local_bdy(dim, iloc, jloc) & + face_value*u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) - end do ! dim + end do ! dim - end do ! jloc + end do ! jloc - end do ! gi + end do ! gi - end if ! sneiloc + end if ! sneiloc - end do ! face + end do ! face - end do ! iloc + end do ! iloc - do dim = 1, size(normal_bdy,1) + do dim = 1, size(normal_bdy,1) - call addto(CTP_m, 1, dim, nodes_bdy, nodes_bdy, ctp_mat_local_bdy(dim,:,:)) + call addto(CTP_m, 1, dim, nodes_bdy, nodes_bdy, ctp_mat_local_bdy(dim,:,:)) - end do ! dim + end do ! dim - end do ! sele + end do ! sele - call deallocate(velocity_bc) - deallocate(velocity_bc_type) + call deallocate(velocity_bc) + deallocate(velocity_bc_type) - call deallocate(x_cvbdyshape) - call deallocate(u_cvbdyshape) - call deallocate(p_cvbdyshape) - deallocate(x_ele_bdy, detwei_bdy, normal_bdy, u_bdy_f) - deallocate(nodes_bdy) - deallocate(matdens_ele_bdy, oldmatdens_ele_bdy, matvfrac_ele_bdy, oldmatvfrac_ele_bdy) - deallocate(ghost_matdens_ele_bdy, ghost_oldmatdens_ele_bdy, & - ghost_matvfrac_ele_bdy, ghost_oldmatvfrac_ele_bdy) - call deallocate(matvfrac_bc) - call deallocate(matdens_bc) - deallocate(matvfrac_bc_type, matdens_bc_type) - deallocate(ctp_mat_local_bdy) + call deallocate(x_cvbdyshape) + call deallocate(u_cvbdyshape) + call deallocate(p_cvbdyshape) + deallocate(x_ele_bdy, detwei_bdy, normal_bdy, u_bdy_f) + deallocate(nodes_bdy) + deallocate(matdens_ele_bdy, oldmatdens_ele_bdy, matvfrac_ele_bdy, oldmatvfrac_ele_bdy) + deallocate(ghost_matdens_ele_bdy, ghost_oldmatdens_ele_bdy, & + ghost_matvfrac_ele_bdy, ghost_oldmatvfrac_ele_bdy) + call deallocate(matvfrac_bc) + call deallocate(matdens_bc) + deallocate(matvfrac_bc_type, matdens_bc_type) + deallocate(ctp_mat_local_bdy) - end if ! dstat==0 + end if ! dstat==0 end do ! i @@ -1430,7 +1430,7 @@ subroutine assemble_mmat_compressible_divergence_matrix_cv(CTP_m, state) call clean_deferred_deletion(state) - end subroutine assemble_mmat_compressible_divergence_matrix_cv - !************************************************************************ + end subroutine assemble_mmat_compressible_divergence_matrix_cv + !************************************************************************ end module divergence_matrix_cv diff --git a/assemble/Drag.F90 b/assemble/Drag.F90 index 76c8b491a7..a74c19a450 100644 --- a/assemble/Drag.F90 +++ b/assemble/Drag.F90 @@ -26,135 +26,135 @@ ! USA #include "fdebug.h" module drag_module -use fldebug -use global_parameters, only : OPTION_PATH_LEN -use spud -use futils, only: int2str -use parallel_tools -use sparse_tools -use fetools -use parallel_fields -use fields -use sparse_tools_petsc -use state_module -use boundary_conditions - -implicit none - -private -public drag_surface + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use spud + use futils, only: int2str + use parallel_tools + use sparse_tools + use fetools + use parallel_fields + use fields + use sparse_tools_petsc + use state_module + use boundary_conditions + + implicit none + + private + public drag_surface contains -subroutine drag_surface(bigm, rhs, state, density) + subroutine drag_surface(bigm, rhs, state, density) !!< Applies quadratic or linear drag at boundaries with bc of "drag" type !!< This version applies the proper surface integral. - type(petsc_csr_matrix), intent(inout):: bigm - type(vector_field), intent(inout):: rhs - type(state_type), intent(in):: state - type(scalar_field), intent(in) :: density - - type(vector_field), pointer:: velocity, nl_velocity, position, old_velocity - type(scalar_field), pointer:: drag_coefficient, distance_top, distance_bottom - character(len=OPTION_PATH_LEN) bctype - real, dimension(:), allocatable:: face_detwei, coefficient, density_face_gi - real, dimension(:,:), allocatable:: drag_mat - real dt, theta, gravity_magnitude - integer, dimension(:), allocatable:: faceglobalnodes - integer, dimension(:), pointer:: surface_element_list - integer i, j, k, nobcs, stat - integer snloc, sele, sngi - logical:: parallel_dg, have_distance_bottom, have_distance_top, have_gravity, manning_strickler - - ewrite(1,*) 'Inside drag_surface' - - velocity => extract_vector_field(state, "Velocity") - ! velocity at the beginning of the time step - old_velocity => extract_vector_field(state, "OldVelocity") - ! velocity weighted between old and new with theta - nl_velocity => extract_vector_field(state, "NonlinearVelocity") - position => extract_vector_field(state, "Coordinate") - distance_bottom => extract_scalar_field(state, "DistanceToBottom", stat) - have_distance_bottom = stat == 0 - distance_top => extract_scalar_field(state, "DistanceToTop", stat) - have_distance_top = stat == 0 - - call get_option("/timestepping/timestep", dt) - call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/theta", & - theta) - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude, & - stat=stat) - have_gravity = stat == 0 - parallel_dg=continuity(velocity)<0 .and. IsParallel() - - sngi=face_ngi(velocity, 1) - snloc=face_loc(velocity,1) - - allocate(faceglobalnodes(1:snloc), & - face_detwei(1:sngi), coefficient(1:sngi), & - drag_mat(1:snloc,1:snloc), density_face_gi(1:sngi)) - - nobcs=option_count(trim(velocity%option_path)//'/prognostic/boundary_conditions') - do i=1, nobcs - call get_boundary_condition(velocity, i, type=bctype, & - surface_element_list=surface_element_list) - if (bctype=='drag') then - manning_strickler=have_option(trim(velocity%option_path)//& + type(petsc_csr_matrix), intent(inout):: bigm + type(vector_field), intent(inout):: rhs + type(state_type), intent(in):: state + type(scalar_field), intent(in) :: density + + type(vector_field), pointer:: velocity, nl_velocity, position, old_velocity + type(scalar_field), pointer:: drag_coefficient, distance_top, distance_bottom + character(len=OPTION_PATH_LEN) bctype + real, dimension(:), allocatable:: face_detwei, coefficient, density_face_gi + real, dimension(:,:), allocatable:: drag_mat + real dt, theta, gravity_magnitude + integer, dimension(:), allocatable:: faceglobalnodes + integer, dimension(:), pointer:: surface_element_list + integer i, j, k, nobcs, stat + integer snloc, sele, sngi + logical:: parallel_dg, have_distance_bottom, have_distance_top, have_gravity, manning_strickler + + ewrite(1,*) 'Inside drag_surface' + + velocity => extract_vector_field(state, "Velocity") + ! velocity at the beginning of the time step + old_velocity => extract_vector_field(state, "OldVelocity") + ! velocity weighted between old and new with theta + nl_velocity => extract_vector_field(state, "NonlinearVelocity") + position => extract_vector_field(state, "Coordinate") + distance_bottom => extract_scalar_field(state, "DistanceToBottom", stat) + have_distance_bottom = stat == 0 + distance_top => extract_scalar_field(state, "DistanceToTop", stat) + have_distance_top = stat == 0 + + call get_option("/timestepping/timestep", dt) + call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/theta", & + theta) + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude, & + stat=stat) + have_gravity = stat == 0 + parallel_dg=continuity(velocity)<0 .and. IsParallel() + + sngi=face_ngi(velocity, 1) + snloc=face_loc(velocity,1) + + allocate(faceglobalnodes(1:snloc), & + face_detwei(1:sngi), coefficient(1:sngi), & + drag_mat(1:snloc,1:snloc), density_face_gi(1:sngi)) + + nobcs=option_count(trim(velocity%option_path)//'/prognostic/boundary_conditions') + do i=1, nobcs + call get_boundary_condition(velocity, i, type=bctype, & + surface_element_list=surface_element_list) + if (bctype=='drag') then + manning_strickler=have_option(trim(velocity%option_path)//& '/prognostic/boundary_conditions['//int2str(i-1)//']/type[0]/quadratic_drag/manning-strickler') - if (manning_strickler) then - if (.not. have_distance_bottom .or. .not. have_distance_top .or. .not. have_gravity) then - ewrite(-1,*) "Manning-strickler drag needs DistanceToTop and DistanceToBottom fields and gravity." - FLExit("Turn on ocean_boundaries underneath geometry.") + if (manning_strickler) then + if (.not. have_distance_bottom .or. .not. have_distance_top .or. .not. have_gravity) then + ewrite(-1,*) "Manning-strickler drag needs DistanceToTop and DistanceToBottom fields and gravity." + FLExit("Turn on ocean_boundaries underneath geometry.") + end if end if - end if - drag_coefficient => extract_scalar_surface_field(velocity, i, "DragCoefficient") - do j=1, size(surface_element_list) + drag_coefficient => extract_scalar_surface_field(velocity, i, "DragCoefficient") + do j=1, size(surface_element_list) - sele=surface_element_list(j) - if (parallel_dg) then - if (.not. element_owned(velocity, face_ele(velocity, sele))) cycle - end if + sele=surface_element_list(j) + if (parallel_dg) then + if (.not. element_owned(velocity, face_ele(velocity, sele))) cycle + end if - call transform_facet_to_physical(position, sele, face_detwei) - - faceglobalnodes=face_global_nodes(nl_velocity, sele) - - if(have_option(trim(velocity%option_path)//& - '/prognostic/boundary_conditions['//int2str(i-1)//']/type[0]/linear_drag')) then - ! drag coefficient: C_D - coefficient=ele_val_at_quad(drag_coefficient, j) - else ! default to quadratic_drag - ! drag coefficient: C_D * |u| - coefficient=ele_val_at_quad(drag_coefficient, j)* & - sqrt(sum(face_val_at_quad(nl_velocity, sele)**2, dim=1)) - if (manning_strickler) then - ! The manning-strickler formulation takes the form n**2g|u|u/(H**0.3333), where H is the water level, g is gravity and n is the Manning coefficient - ! Note that distance_bottom+distance_top is the current water level H - coefficient=ele_val_at_quad(drag_coefficient, j)*gravity_magnitude*coefficient/((face_val_at_quad(distance_bottom, sele)+face_val_at_quad(distance_top, sele))**(1./3.)) + call transform_facet_to_physical(position, sele, face_detwei) + + faceglobalnodes=face_global_nodes(nl_velocity, sele) + + if(have_option(trim(velocity%option_path)//& + '/prognostic/boundary_conditions['//int2str(i-1)//']/type[0]/linear_drag')) then + ! drag coefficient: C_D + coefficient=ele_val_at_quad(drag_coefficient, j) + else ! default to quadratic_drag + ! drag coefficient: C_D * |u| + coefficient=ele_val_at_quad(drag_coefficient, j)* & + sqrt(sum(face_val_at_quad(nl_velocity, sele)**2, dim=1)) + if (manning_strickler) then + ! The manning-strickler formulation takes the form n**2g|u|u/(H**0.3333), where H is the water level, g is gravity and n is the Manning coefficient + ! Note that distance_bottom+distance_top is the current water level H + coefficient=ele_val_at_quad(drag_coefficient, j)*gravity_magnitude*coefficient/((face_val_at_quad(distance_bottom, sele)+face_val_at_quad(distance_top, sele))**(1./3.)) + end if end if - end if - ! density to turn this into a momentum absorption term - ! (of course this will just be 1 with boussinesq) - density_face_gi = face_val_at_quad(density, sele) + ! density to turn this into a momentum absorption term + ! (of course this will just be 1 with boussinesq) + density_face_gi = face_val_at_quad(density, sele) - drag_mat=shape_shape(face_shape(velocity, sele), & - face_shape(velocity, sele), coefficient*face_detwei*density_face_gi) + drag_mat=shape_shape(face_shape(velocity, sele), & + face_shape(velocity, sele), coefficient*face_detwei*density_face_gi) - do k=1, velocity%dim - call addto(bigm, k, k, faceglobalnodes, faceglobalnodes, & - dt*theta*drag_mat) - call addto(rhs, k, faceglobalnodes, & - -matmul(drag_mat, face_val(old_velocity, k, sele)) ) - end do + do k=1, velocity%dim + call addto(bigm, k, k, faceglobalnodes, faceglobalnodes, & + dt*theta*drag_mat) + call addto(rhs, k, faceglobalnodes, & + -matmul(drag_mat, face_val(old_velocity, k, sele)) ) + end do - end do + end do - end if - end do + end if + end do - deallocate(faceglobalnodes, face_detwei, coefficient, drag_mat) + deallocate(faceglobalnodes, face_detwei, coefficient, drag_mat) -end subroutine drag_surface + end subroutine drag_surface end module drag_module diff --git a/assemble/Field_Equations_CV.F90 b/assemble/Field_Equations_CV.F90 index 2a509bc41b..a326718234 100644 --- a/assemble/Field_Equations_CV.F90 +++ b/assemble/Field_Equations_CV.F90 @@ -27,82 +27,82 @@ #include "fdebug.h" module field_equations_cv - !!< This module contains the assembly subroutines for advection - !!< using control volumes - use fldebug - use spud - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str, free_unit - use element_numbering, only: ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES - use elements - use cv_faces - use parallel_tools - use sparse_tools - use transform_elements, only: transform_cvsurf_to_physical, & - transform_cvsurf_facet_to_physical, transform_to_physical - use fields - use sparse_matrices_fields - use state_module - use sparsity_patterns_meshes - use cv_shape_functions - use field_options - use cvtools - use cv_options - use boundary_conditions - use halos - use cv_upwind_values - use cv_face_values, only: evaluate_face_val, theta_val, couple_face_value - use fefields, only: compute_cv_mass - use state_fields_module - use diagnostic_fields, only: calculate_diagnostic_variable - use cv_fields - use diagnostic_variables, only: field_tag - use boundary_conditions_from_options - use multiphase_module - use divergence_matrix_cv, only: assemble_divergence_matrix_cv - use petsc_solve_state_module - - implicit none - - private - public :: solve_field_eqn_cv, field_equations_cv_check_options, & - initialise_advection_convergence, coupled_cv_field_eqn, & - assemble_advectiondiffusion_m_cv - - integer, dimension(:), allocatable, save :: conv_unit - - !! This allows a reference between the field and the file its meant to be - !! writing to. - character(len=OPTION_PATH_LEN), dimension(:), allocatable, save :: sfield_list - - ! are we moving the mesh? - logical :: move_mesh = .false. - ! are we including density? - logical :: include_density = .false. - ! are we including a souce? - logical :: include_source = .false. - ! Add source directly to the right hand side? - logical :: add_src_directly_to_rhs = .false. - ! are we including an absorption? - logical :: include_absorption = .false. - ! are we including diffusion? - logical :: include_diffusion = .false. - ! are we including advection? - logical :: include_advection = .true. - ! are we including mass? - logical :: include_mass = .true. - ! are we assembling particular matrices? - ! advection? - logical :: assemble_advection_matrix = .true. - ! diffusion? - logical :: assemble_diffusion = .false. - ! Are we running a multiphase flow simulation? - logical :: multiphase = .false. + !!< This module contains the assembly subroutines for advection + !!< using control volumes + use fldebug + use spud + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str, free_unit + use element_numbering, only: ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES + use elements + use cv_faces + use parallel_tools + use sparse_tools + use transform_elements, only: transform_cvsurf_to_physical, & + transform_cvsurf_facet_to_physical, transform_to_physical + use fields + use sparse_matrices_fields + use state_module + use sparsity_patterns_meshes + use cv_shape_functions + use field_options + use cvtools + use cv_options + use boundary_conditions + use halos + use cv_upwind_values + use cv_face_values, only: evaluate_face_val, theta_val, couple_face_value + use fefields, only: compute_cv_mass + use state_fields_module + use diagnostic_fields, only: calculate_diagnostic_variable + use cv_fields + use diagnostic_variables, only: field_tag + use boundary_conditions_from_options + use multiphase_module + use divergence_matrix_cv, only: assemble_divergence_matrix_cv + use petsc_solve_state_module + + implicit none + + private + public :: solve_field_eqn_cv, field_equations_cv_check_options, & + initialise_advection_convergence, coupled_cv_field_eqn, & + assemble_advectiondiffusion_m_cv + + integer, dimension(:), allocatable, save :: conv_unit + + !! This allows a reference between the field and the file its meant to be + !! writing to. + character(len=OPTION_PATH_LEN), dimension(:), allocatable, save :: sfield_list + + ! are we moving the mesh? + logical :: move_mesh = .false. + ! are we including density? + logical :: include_density = .false. + ! are we including a souce? + logical :: include_source = .false. + ! Add source directly to the right hand side? + logical :: add_src_directly_to_rhs = .false. + ! are we including an absorption? + logical :: include_absorption = .false. + ! are we including diffusion? + logical :: include_diffusion = .false. + ! are we including advection? + logical :: include_advection = .true. + ! are we including mass? + logical :: include_mass = .true. + ! are we assembling particular matrices? + ! advection? + logical :: assemble_advection_matrix = .true. + ! diffusion? + logical :: assemble_diffusion = .false. + ! Are we running a multiphase flow simulation? + logical :: multiphase = .false. contains - !************************************************************************ - ! solution wrapping subroutines - subroutine solve_field_eqn_cv(field_name, state, istate, global_it) + !************************************************************************ + ! solution wrapping subroutines + subroutine solve_field_eqn_cv(field_name, state, istate, global_it) !!< Construct and solve the advection-diffusion equation for the given !!< field using control volumes. @@ -136,7 +136,7 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) type(csr_matrix) :: D_m ! sparsity structure to construct the matrices with type(csr_sparsity), pointer :: mesh_sparsity_1, mesh_sparsity, & - mesh_sparsity_x, grad_m_t_sparsity + mesh_sparsity_x, grad_m_t_sparsity ! Right hand side vector, cv mass matrix, ! locally iterated field (for advection iterations) @@ -165,14 +165,14 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) type(element_type) :: u_cvshape, u_cvbdyshape type(element_type) :: ug_cvshape, ug_cvbdyshape type(element_type) :: x_cvshape, x_cvbdyshape, & - x_cvshape_full, x_cvbdyshape_full + x_cvshape_full, x_cvbdyshape_full ! t_cvshape is the element with reduced numbers of derivatives ! taken across the control volume faces ! t_cvshape_full contains the derivatives with respect to the parent ! elements canonical coordinates evaluated at the control volume faces ! t_cvbdyshape_full is the same but on the boundary type(element_type) :: t_cvshape, t_cvshape_full, diff_cvshape_full, & - t_cvbdyshape_full, diff_cvbdyshape_full + t_cvbdyshape_full, diff_cvbdyshape_full ! options wrappers for tfield and tdensity type(cv_options_type) :: tfield_options, tdensity_options @@ -278,47 +278,47 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) equation_type=equation_type_index(trim(option_path)) include_density = .false. select case(equation_type) - case(FIELD_EQUATION_ADVECTIONDIFFUSION) - - ! density not needed so use a constant field for assembly - tdensity=>dummyscalar - oldtdensity=>dummyscalar - - case(FIELD_EQUATION_KEPSILON) - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - temp_velocity_ptr => extract_vector_field(state(istate), "Velocity") - call get_option(trim(temp_velocity_ptr%option_path)//"/prognostic/equation[0]/name", velocity_equation_type) - select case(velocity_equation_type) - case("LinearMomentum") - include_density = .true. - tdensity=>extract_scalar_field(state(istate), "Density") - oldtdensity=>extract_scalar_field(state(istate), "OldDensity") - case("Boussinesq") - tdensity => dummydensity - oldtdensity => dummydensity - case("Drainage") - tdensity => dummydensity - oldtdensity => dummydensity - case default - ! developer error... out of sync options input and code - FLAbort("Unknown equation type for velocity") - end select - - case(FIELD_EQUATION_CONSERVATIONOFMASS, FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS, & - FIELD_EQUATION_INTERNALENERGY, FIELD_EQUATION_HEATTRANSFER ) - call get_option(trim(option_path)//'/prognostic/equation[0]/density[0]/name', & - tmpstring) - include_density = .true. - ! density needed so extract the type specified in the input - ! ?? are there circumstances where this should be "Iterated"... need to be - ! careful with priority ordering - tdensity=>extract_scalar_field(state(istate), trim(tmpstring)) - ewrite_minmax(tdensity) - - ! halo exchange? - not currently necessary when suboptimal halo exchange if density - ! is solved for with this subroutine and the correct priority ordering. - oldtdensity=>extract_scalar_field(state(istate), "Old"//trim(tmpstring)) - ewrite_minmax(oldtdensity) + case(FIELD_EQUATION_ADVECTIONDIFFUSION) + + ! density not needed so use a constant field for assembly + tdensity=>dummyscalar + oldtdensity=>dummyscalar + + case(FIELD_EQUATION_KEPSILON) + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + temp_velocity_ptr => extract_vector_field(state(istate), "Velocity") + call get_option(trim(temp_velocity_ptr%option_path)//"/prognostic/equation[0]/name", velocity_equation_type) + select case(velocity_equation_type) + case("LinearMomentum") + include_density = .true. + tdensity=>extract_scalar_field(state(istate), "Density") + oldtdensity=>extract_scalar_field(state(istate), "OldDensity") + case("Boussinesq") + tdensity => dummydensity + oldtdensity => dummydensity + case("Drainage") + tdensity => dummydensity + oldtdensity => dummydensity + case default + ! developer error... out of sync options input and code + FLAbort("Unknown equation type for velocity") + end select + + case(FIELD_EQUATION_CONSERVATIONOFMASS, FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS, & + FIELD_EQUATION_INTERNALENERGY, FIELD_EQUATION_HEATTRANSFER ) + call get_option(trim(option_path)//'/prognostic/equation[0]/density[0]/name', & + tmpstring) + include_density = .true. + ! density needed so extract the type specified in the input + ! ?? are there circumstances where this should be "Iterated"... need to be + ! careful with priority ordering + tdensity=>extract_scalar_field(state(istate), trim(tmpstring)) + ewrite_minmax(tdensity) + + ! halo exchange? - not currently necessary when suboptimal halo exchange if density + ! is solved for with this subroutine and the correct priority ordering. + oldtdensity=>extract_scalar_field(state(istate), "Old"//trim(tmpstring)) + ewrite_minmax(oldtdensity) end select @@ -327,26 +327,26 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) ! 2) the options underneath the density field itself if it is prognostic and cv ! 3) throw an error as otherwise it would default to poorly defined options if(include_density) then - if(have_option(trim(option_path)//'/prognostic/equation[0]/density[0]/discretisation_options')) then - tdensity_option_path = trim(option_path)//'/prognostic/equation[0]/density[0]/discretisation_options' - else - if(have_option(trim(tdensity%option_path)//"/prognostic/spatial_discretisation/control_volumes")) then - tdensity_option_path = trim(tdensity%option_path) - else - FLExit("Additional discretisation options required for the density coefficient. Please set equation/density/discretisation_options.") - end if - end if + if(have_option(trim(option_path)//'/prognostic/equation[0]/density[0]/discretisation_options')) then + tdensity_option_path = trim(option_path)//'/prognostic/equation[0]/density[0]/discretisation_options' + else + if(have_option(trim(tdensity%option_path)//"/prognostic/spatial_discretisation/control_volumes")) then + tdensity_option_path = trim(tdensity%option_path) + else + FLExit("Additional discretisation options required for the density coefficient. Please set equation/density/discretisation_options.") + end if + end if else - tdensity_option_path = "" + tdensity_option_path = "" end if ! now we can get the options for these fields ! handily wrapped in a new type... tfield_options=get_cv_options(tfield%option_path, tfield%mesh%shape%numbering%family, mesh_dim(tfield)) if(include_density) then - tdensity_options=get_cv_options(tdensity_option_path, tdensity%mesh%shape%numbering%family, mesh_dim(tdensity), coefficient_field=.true.) + tdensity_options=get_cv_options(tdensity_option_path, tdensity%mesh%shape%numbering%family, mesh_dim(tdensity), coefficient_field=.true.) else - tdensity_options=tfield_options ! dummy so we don't leave variables undefined but shouldn't get used + tdensity_options=tfield_options ! dummy so we don't leave variables undefined but shouldn't get used end if ! extract fields from state @@ -361,34 +361,34 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) ! are we inclulding advection (generally yes)? include_advection = .not.(tfield_options%facevalue==CV_FACEVALUE_NONE) if(include_advection) then - nu=>extract_vector_field(state(istate), "NonlinearVelocity") - ewrite_minmax(nu) - ! find relative velocity - allocate(advu) - call allocate(advu, nu%dim, nu%mesh, "AdvectionVelocity") - call set(advu, nu) - if (have_option(trim(tfield%option_path)// & - "/prognostic/spatial_discretisation/control_volumes/"// & - "face_value::FiniteElement/only_sinking_velocity")) then + nu=>extract_vector_field(state(istate), "NonlinearVelocity") + ewrite_minmax(nu) + ! find relative velocity + allocate(advu) + call allocate(advu, nu%dim, nu%mesh, "AdvectionVelocity") + call set(advu, nu) + if (have_option(trim(tfield%option_path)// & + "/prognostic/spatial_discretisation/control_volumes/"// & + "face_value::FiniteElement/only_sinking_velocity")) then call zero(advu) ewrite(2,*) "Removing velocity from ", trim(field_name) - end if - ! add in sinking velocity - sink=>extract_scalar_field(state(istate), trim(field_name)//"SinkingVelocity"& - &, stat=stat) - if(stat==0) then - gravity=>extract_vector_field(state(istate), "GravityDirection") - ! this may perform a "remap" internally from CoordinateMesh to VelocityMesh - call addto(advu, gravity, scale=sink) - end if - ewrite_minmax(advu) + end if + ! add in sinking velocity + sink=>extract_scalar_field(state(istate), trim(field_name)//"SinkingVelocity"& + &, stat=stat) + if(stat==0) then + gravity=>extract_vector_field(state(istate), "GravityDirection") + ! this may perform a "remap" internally from CoordinateMesh to VelocityMesh + call addto(advu, gravity, scale=sink) + end if + ewrite_minmax(advu) else - ewrite(2,*) 'Excluding advection' - advu => dummyvector - if(has_scalar_field(state(istate), trim(field_name)//"SinkingVelocity")) then + ewrite(2,*) 'Excluding advection' + advu => dummyvector + if(has_scalar_field(state(istate), trim(field_name)//"SinkingVelocity")) then ewrite(-1,*) "No advection in "//trim(field_name) FLExit("But you have a sinking velocity on. Can't have that") - end if + end if end if ! do we have a diffusivity - this will control whether we construct an auxiliary @@ -397,88 +397,88 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) diffusivity=>extract_tensor_field(state(istate), trim(field_name)//"Diffusivity", stat=stat) include_diffusion = (stat==0).and.(tfield_options%diffusionscheme/=CV_DIFFUSION_NONE) if(.not.include_diffusion) then - diffusivity => dummytensor + diffusivity => dummytensor else - ewrite_minmax(diffusivity) + ewrite_minmax(diffusivity) end if ! do we have a source? source=>extract_scalar_field(state(istate), trim(field_name)//"Source", stat=stat) include_source = (stat==0) if(.not.include_source) then - source=>dummyscalar + source=>dummyscalar else - add_src_directly_to_rhs = have_option(trim(source%option_path)//'/diagnostic/add_directly_to_rhs') + add_src_directly_to_rhs = have_option(trim(source%option_path)//'/diagnostic/add_directly_to_rhs') - if (add_src_directly_to_rhs) then - ewrite(2, *) "Adding Source field directly to the right hand side" - assert(node_count(source) == node_count(tfield)) - end if + if (add_src_directly_to_rhs) then + ewrite(2, *) "Adding Source field directly to the right hand side" + assert(node_count(source) == node_count(tfield)) + end if - ewrite_minmax(source) + ewrite_minmax(source) end if ! do we have an absorption? absorption=>extract_scalar_field(state(istate), trim(field_name)//"Absorption", stat=stat) include_absorption = (stat==0) if(.not.include_absorption) then - absorption=>dummyscalar + absorption=>dummyscalar else - ewrite_minmax(absorption) + ewrite_minmax(absorption) end if ! create control volume shape functions call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + quaddegree, default=1) cvfaces=find_cv_faces(vertices=ele_vertices(tfield, 1), & - dimension=mesh_dim(tfield), & - polydegree=tfield%mesh%shape%degree, & - quaddegree=quaddegree) + dimension=mesh_dim(tfield), & + polydegree=tfield%mesh%shape%degree, & + quaddegree=quaddegree) x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) t_cvshape=make_cv_element_shape(cvfaces, tfield%mesh%shape) if(include_advection) then - u_cvshape=make_cv_element_shape(cvfaces, nu%mesh%shape) + u_cvshape=make_cv_element_shape(cvfaces, nu%mesh%shape) else - u_cvshape=t_cvshape - call incref(u_cvshape) + u_cvshape=t_cvshape + call incref(u_cvshape) end if x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) if(include_advection) then - u_cvbdyshape=make_cvbdy_element_shape(cvfaces, nu%mesh%faces%shape) + u_cvbdyshape=make_cvbdy_element_shape(cvfaces, nu%mesh%faces%shape) else - u_cvbdyshape=x_cvbdyshape - call incref(u_cvbdyshape) + u_cvbdyshape=x_cvbdyshape + call incref(u_cvbdyshape) end if if(include_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_ELEMENTGRADIENT)) then - x_cvshape_full=make_cv_element_shape(cvfaces, x%mesh%shape, & - type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - t_cvshape_full=make_cv_element_shape(cvfaces, tfield%mesh%shape, & - type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - diff_cvshape_full=make_cv_element_shape(cvfaces, diffusivity%mesh%shape, & - type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - - x_cvbdyshape_full=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape, & - type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - t_cvbdyshape_full=make_cvbdy_element_shape(cvfaces, tfield%mesh%shape, & - type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - diff_cvbdyshape_full=make_cvbdy_element_shape(cvfaces, diffusivity%mesh%shape, & - type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + x_cvshape_full=make_cv_element_shape(cvfaces, x%mesh%shape, & + type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + t_cvshape_full=make_cv_element_shape(cvfaces, tfield%mesh%shape, & + type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + diff_cvshape_full=make_cv_element_shape(cvfaces, diffusivity%mesh%shape, & + type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + + x_cvbdyshape_full=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape, & + type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + t_cvbdyshape_full=make_cvbdy_element_shape(cvfaces, tfield%mesh%shape, & + type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + diff_cvbdyshape_full=make_cvbdy_element_shape(cvfaces, diffusivity%mesh%shape, & + type=ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) else - x_cvshape_full=x_cvshape - t_cvshape_full=t_cvshape - diff_cvshape_full=t_cvshape - x_cvbdyshape_full=x_cvbdyshape - t_cvbdyshape_full=x_cvbdyshape - diff_cvbdyshape_full=x_cvbdyshape - - call incref(x_cvshape_full) - call incref(t_cvshape_full) - call incref(diff_cvshape_full) - call incref(x_cvbdyshape_full) - call incref(t_cvbdyshape_full) - call incref(diff_cvbdyshape_full) + x_cvshape_full=x_cvshape + t_cvshape_full=t_cvshape + diff_cvshape_full=t_cvshape + x_cvbdyshape_full=x_cvbdyshape + t_cvbdyshape_full=x_cvbdyshape + diff_cvbdyshape_full=x_cvbdyshape + + call incref(x_cvshape_full) + call incref(t_cvshape_full) + call incref(diff_cvshape_full) + call incref(x_cvbdyshape_full) + call incref(t_cvbdyshape_full) + call incref(diff_cvbdyshape_full) end if ! is this explicit? @@ -491,78 +491,78 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) option_path_array(1) = trim(option_path) ! temporary hack for compiler failure tdensity_option_path_array(1) = tdensity_option_path call cv_disc_get_cfl_no(option_path_array, & - state(istate), tfield%mesh, cfl_no, & - tdensity_option_path_array) + state(istate), tfield%mesh, cfl_no, & + tdensity_option_path_array) ! get the mesh sparsity for the matrices if(include_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then - ! in this case we need to extend the sparsity to second order - mesh_sparsity => get_csr_sparsity_secondorder(state, tfield%mesh, diffusivity%mesh) - - ! except for some things we still need a first order sparsity (upwind value matrices for instance) - ! although note that this may get modified when periodic depending on the face value scheme - mesh_sparsity_1 => get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) - if(.not.(tfield%mesh==diffusivity%mesh)) then - if(tfield%mesh%shape%degree>1) then - FLExit("To have a different diffusivity mesh the field must be at most P1") - elseif(diffusivity%mesh%shape%degree>tfield%mesh%shape%degree) then - FLExit("The diffusivity mesh must be of a lower degree than the field") - end if - - ! we also need a first order sparsity using the diffusivity mesh for the assembly of the auxilliary eqn - grad_m_t_sparsity => get_csr_sparsity_firstorder(state, tfield%mesh, diffusivity%mesh) - else - ! no difference between the meshes so this is safe (and faster) - grad_m_t_sparsity => mesh_sparsity_1 - end if + ! in this case we need to extend the sparsity to second order + mesh_sparsity => get_csr_sparsity_secondorder(state, tfield%mesh, diffusivity%mesh) + + ! except for some things we still need a first order sparsity (upwind value matrices for instance) + ! although note that this may get modified when periodic depending on the face value scheme + mesh_sparsity_1 => get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) + if(.not.(tfield%mesh==diffusivity%mesh)) then + if(tfield%mesh%shape%degree>1) then + FLExit("To have a different diffusivity mesh the field must be at most P1") + elseif(diffusivity%mesh%shape%degree>tfield%mesh%shape%degree) then + FLExit("The diffusivity mesh must be of a lower degree than the field") + end if + + ! we also need a first order sparsity using the diffusivity mesh for the assembly of the auxilliary eqn + grad_m_t_sparsity => get_csr_sparsity_firstorder(state, tfield%mesh, diffusivity%mesh) + else + ! no difference between the meshes so this is safe (and faster) + grad_m_t_sparsity => mesh_sparsity_1 + end if else - ! no BassiRebay diffusion so only a first order sparsity is needed... woo! - mesh_sparsity => get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) - grad_m_t_sparsity => mesh_sparsity - mesh_sparsity_1 => mesh_sparsity + ! no BassiRebay diffusion so only a first order sparsity is needed... woo! + mesh_sparsity => get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) + grad_m_t_sparsity => mesh_sparsity + mesh_sparsity_1 => mesh_sparsity end if if(mesh_periodic(tfield)) then - ! we have a periodic mesh and depending on the upwind value scheme - ! we may want to modify the sparsity for the upwind value matrices - if((tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& - (tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then - ! yup, we need an unperiodic sparsity - mesh_sparsity_x => get_csr_sparsity_firstorder(state, x_tfield%mesh, x_tfield%mesh) - else - ! periodic sparsity is fine - mesh_sparsity_x => mesh_sparsity_1 - end if + ! we have a periodic mesh and depending on the upwind value scheme + ! we may want to modify the sparsity for the upwind value matrices + if((tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& + (tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then + ! yup, we need an unperiodic sparsity + mesh_sparsity_x => get_csr_sparsity_firstorder(state, x_tfield%mesh, x_tfield%mesh) + else + ! periodic sparsity is fine + mesh_sparsity_x => mesh_sparsity_1 + end if else - ! not periodic so who cares - mesh_sparsity_x => mesh_sparsity_1 + ! not periodic so who cares + mesh_sparsity_x => mesh_sparsity_1 end if if(.not.explicit) then - ! allocate the lhs matrix - call allocate(M, mesh_sparsity, name=trim(field_name)//"Matrix") - call zero(M) + ! allocate the lhs matrix + call allocate(M, mesh_sparsity, name=trim(field_name)//"Matrix") + call zero(M) - ! allocate the advection matrix - call allocate(A_m, mesh_sparsity, name=trim(field_name)//"AdvectionMatrix") - call zero(A_m) + ! allocate the advection matrix + call allocate(A_m, mesh_sparsity, name=trim(field_name)//"AdvectionMatrix") + call zero(A_m) else - if(.not.include_mass) then - FLExit("Can't be explicit and exclude the mass terms.") - end if + if(.not.include_mass) then + FLExit("Can't be explicit and exclude the mass terms.") + end if - ! allocate a local cvmass field because it will get modified by bc etc. - call allocate(cvmass, tfield%mesh, name=trim(field_name)//"CVMass") - call zero(cvmass) + ! allocate a local cvmass field because it will get modified by bc etc. + call allocate(cvmass, tfield%mesh, name=trim(field_name)//"CVMass") + call zero(cvmass) end if if(include_diffusion) then - call allocate(D_m, sparsity=mesh_sparsity, name=trim(field_name)//"AuxiliaryMatrix") - call zero(D_m) + call allocate(D_m, sparsity=mesh_sparsity, name=trim(field_name)//"AuxiliaryMatrix") + call zero(D_m) - call allocate(diff_rhs, tfield%mesh, name=trim(field_name)//"DiffusionRHS") - call zero(diff_rhs) + call allocate(diff_rhs, tfield%mesh, name=trim(field_name)//"DiffusionRHS") + call zero(diff_rhs) end if ! allocate the rhs of the equation @@ -578,42 +578,42 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) move_mesh = have_option("/mesh_adaptivity/mesh_movement") if(move_mesh) then - if(.not.include_advection) then - FLExit("Moving the mesh but not including advection is not possible yet.") - end if - ewrite(2,*) "Moving mesh." - x_old=>extract_vector_field(state(istate), "OldCoordinate") - x_new=>extract_vector_field(state(istate), "IteratedCoordinate") - call allocate(t_cvmass_old, tfield%mesh, name=trim(field_name)//"OldCVMass") - call allocate(t_cvmass_new, tfield%mesh, name=trim(field_name)//"NewCVMass") - - call compute_cv_mass(x_old, t_cvmass_old) - call compute_cv_mass(x_new, t_cvmass_new) - ewrite_minmax(t_cvmass_old) - ewrite_minmax(t_cvmass_new) - - ug=>extract_vector_field(state(istate), "GridVelocity") - ewrite_minmax(ug) - - ug_cvshape=make_cv_element_shape(cvfaces, ug%mesh%shape) - ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) + if(.not.include_advection) then + FLExit("Moving the mesh but not including advection is not possible yet.") + end if + ewrite(2,*) "Moving mesh." + x_old=>extract_vector_field(state(istate), "OldCoordinate") + x_new=>extract_vector_field(state(istate), "IteratedCoordinate") + call allocate(t_cvmass_old, tfield%mesh, name=trim(field_name)//"OldCVMass") + call allocate(t_cvmass_new, tfield%mesh, name=trim(field_name)//"NewCVMass") + + call compute_cv_mass(x_old, t_cvmass_old) + call compute_cv_mass(x_new, t_cvmass_new) + ewrite_minmax(t_cvmass_old) + ewrite_minmax(t_cvmass_new) + + ug=>extract_vector_field(state(istate), "GridVelocity") + ewrite_minmax(ug) + + ug_cvshape=make_cv_element_shape(cvfaces, ug%mesh%shape) + ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) else - ewrite(2,*) "Not moving mesh." - ug_cvshape=u_cvshape - ug_cvbdyshape=u_cvbdyshape - call incref(ug_cvshape) - call incref(ug_cvbdyshape) + ewrite(2,*) "Not moving mesh." + ug_cvshape=u_cvshape + ug_cvbdyshape=u_cvbdyshape + call incref(ug_cvshape) + call incref(ug_cvbdyshape) end if if(include_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then - if(.not.(tfield%mesh==diffusivity%mesh)) then - q_cvmass => get_cv_mass(state, diffusivity%mesh) - else - q_cvmass => t_cvmass - end if + if(.not.(tfield%mesh==diffusivity%mesh)) then + q_cvmass => get_cv_mass(state, diffusivity%mesh) + else + q_cvmass => t_cvmass + end if else - q_cvmass => t_cvmass + q_cvmass => t_cvmass end if ! allocate a field to store the locally iterated values in @@ -629,47 +629,47 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) ! find out how many iterations we'll be doing call get_option(trim(option_path)//"/prognostic/temporal_discretisation& - &/control_volumes/number_advection_iterations", & - adv_iterations, default=1) + &/control_volumes/number_advection_iterations", & + adv_iterations, default=1) call get_option(trim(option_path)//"/prognostic/temporal_discretisation& - &/control_volumes/number_advection_iterations/tolerance", & - adv_tolerance, default=0.0) + &/control_volumes/number_advection_iterations/tolerance", & + adv_tolerance, default=0.0) sub_dt=dt ! just in case I don't initialise this somehow ! are we subcycling? no_subcycles = 1 call get_option(trim(option_path)//"/prognostic/temporal_discretisation& - &/control_volumes/number_advection_subcycles", & - no_subcycles, stat=stat) + &/control_volumes/number_advection_subcycles", & + no_subcycles, stat=stat) if(stat/=0) then - ! have not specified a number of subcycles but perhaps we're using a - ! courant number definition? - call get_option(trim(option_path)//"/prognostic/temporal_discretisation& - &/control_volumes/maximum_courant_number_per_subcycle", & - max_sub_cfl, stat=stat) - if(stat==0) then - max_cfl = maxval(cfl_no%val) - call allmax(max_cfl) - ! yes, we're subcycling - ! we should have already calculated the courant number (or aborted in the attempt) - no_subcycles=ceiling(max_cfl/max_sub_cfl) - if(include_diffusion.or.include_source.or.include_absorption) then - no_subcycles = max(no_subcycles, 1) - end if - if(no_subcycles>1) then + ! have not specified a number of subcycles but perhaps we're using a + ! courant number definition? + call get_option(trim(option_path)//"/prognostic/temporal_discretisation& + &/control_volumes/maximum_courant_number_per_subcycle", & + max_sub_cfl, stat=stat) + if(stat==0) then + max_cfl = maxval(cfl_no%val) + call allmax(max_cfl) + ! yes, we're subcycling + ! we should have already calculated the courant number (or aborted in the attempt) + no_subcycles=ceiling(max_cfl/max_sub_cfl) + if(include_diffusion.or.include_source.or.include_absorption) then + no_subcycles = max(no_subcycles, 1) + end if + if(no_subcycles>1) then + sub_dt=dt/real(no_subcycles) + call scale(cfl_no, 1.0/real(no_subcycles)) + end if + else + ! no, we're not subcycling + no_subcycles=1 + sub_dt = dt + end if + else + if(no_subcycles>1) then sub_dt=dt/real(no_subcycles) call scale(cfl_no, 1.0/real(no_subcycles)) - end if - else - ! no, we're not subcycling - no_subcycles=1 - sub_dt = dt - end if - else - if(no_subcycles>1) then - sub_dt=dt/real(no_subcycles) - call scale(cfl_no, 1.0/real(no_subcycles)) - end if + end if end if ! when subcycling we're going to need to be starting each subcycle from the @@ -681,82 +681,82 @@ subroutine solve_field_eqn_cv(field_name, state, istate, global_it) ! subcycling loop subcycling_loop: do sub = 1, no_subcycles - ! advection iteration loop - advection_iteration_loop: do adv_it = 1, adv_iterations - ! construct the advection matrix if this is the first advection iteration - ! and the first subcycle and we're not explicit and we're including advection - assemble_advection_matrix=(adv_it==1).and.(sub==1).and.(.not.explicit).and.include_advection - ! construct the diffusion matrix and rhs if we're including diffusion and - ! if we're on the first advection iteration and the first subcycle - assemble_diffusion=(adv_it==1).and.(sub==1).and.include_diffusion - - ! record the value of tfield since the previous iteration - call set(advit_tfield, tfield) - - if(include_advection.or.assemble_diffusion) then - ! if advection is being included or we need to assemble a - ! diffusion matrix then assemble A_m, D_m and rhs here - call assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & - tfield, l_old_tfield, tfield_options, & - tdensity, oldtdensity, nvfrac, oldvfrac, & - tdensity_options, cvfaces, x_cvshape, x_cvbdyshape, & - u_cvshape, u_cvbdyshape, t_cvshape, & - ug_cvshape, ug_cvbdyshape, & - x_cvshape_full, x_cvbdyshape_full, & - t_cvshape_full, t_cvbdyshape_full, & - diff_cvshape_full, diff_cvbdyshape_full, & - state(istate:istate), advu, ug, x, x_tfield, cfl_no, sub_dt, & - diffusivity, q_cvmass, & - mesh_sparsity_x, grad_m_t_sparsity) - end if - - ! assemble it all into a coherent equation - call assemble_field_eqn_cv(M, A_m, cvmass, rhs, & - tfield, l_old_tfield, & - tdensity, oldtdensity, tdensity_options, & - source, absorption, tfield_options%theta, & - state(istate:istate), advu, sub_dt, explicit, & - t_cvmass, t_abs_src_cvmass, t_cvmass_old, t_cvmass_new, & - D_m, diff_rhs, nvfrac, oldvfrac) - - if(have_option("/multiphase_interaction/heat_transfer") .and. & - equation_type_index(trim(tfield%option_path)) == FIELD_EQUATION_INTERNALENERGY) then - call add_heat_transfer(state, istate, tfield, M, rhs) - end if - - ! Solve for the change in tfield. - if(explicit) then - call apply_dirichlet_conditions(cvmass, rhs, tfield, sub_dt) - - delta_tfield%val = rhs%val/cvmass%val - else - ! apply strong dirichlet boundary conditions (if any) - ! note that weak conditions (known as control volume boundary conditions) - ! will already have been applied - call apply_dirichlet_conditions(M, rhs, tfield, sub_dt) - - call zero(delta_tfield) - call petsc_solve(delta_tfield, M, rhs, state(istate)) - end if - - ! reset tfield to l_old_tfield before applying change - call set(tfield, l_old_tfield) - ! Add the change in tfield to tfield. - call addto(tfield, delta_tfield, sub_dt) - - call halo_update(tfield) ! exchange the extended halos - - call test_and_write_advection_convergence(tfield, advit_tfield, x, t_cvmass, & - filename=trim(state(istate)%name)//"__"//trim(tfield%name), & - time=time+sub_dt, dt=sub_dt, it=global_it, adv_it=adv_it, & - subcyc=sub, error=error) - - if(errorextract_scalar_field(state(1), "Pressure") - ewrite_minmax(p) - assert(p%mesh==tfield%mesh) - ! halo exchange not necessary as it is done straight after solve - call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) - gradient_sparsity => get_csr_sparsity_firstorder(state, p%mesh, advu%mesh) - - call allocate(CT_m, gradient_sparsity, (/1, advu%dim/), name="DivergenceMatrix" ) - call assemble_divergence_matrix_cv(CT_m, state(1), & - test_mesh=p%mesh, field=advu, include_vfrac=.false.) - - call allocate(pterm, p%mesh, "PressureTerm") - - ! construct the pressure term - call mult(pterm, CT_m, advu) - if(multiphase) then - call scale(pterm, nvfrac) ! We need vfrac*p*div(u) for the multiphase InternalEnergy equation - end if - - ! should this really be the advection velocity or just the relative or the nonlinear? - pterm%val = pterm%val*(p%val+atmospheric_pressure) - - call addto(rhs, pterm, -1.0) - - call deallocate(CT_m) - call deallocate(pterm) - end if - - ! construct M - if(explicit) then - if(include_mass) then - call scale(m_cvmass, tdensity) - if(multiphase) then - call scale(m_cvmass, nvfrac) + call addto(rhs, diff_rhs, -1.0) + + if(.not.explicit) then + call addto(M, D_m, theta*dt) end if - end if - else - if(include_mass) then - call mult_diag(M, tdensity) - if(multiphase) then - call mult_diag(M, nvfrac) + end if + + if(move_mesh) then + FLExit("Moving mesh with this equation type not yet supported.") + end if + + case (FIELD_EQUATION_HEATTRANSFER) + + ! [\rho^{n+\theta}M + dt*A_m + dt*theta*D_m](T^{n+1}-T^{n})/dt = rhs - [A_m + D_m]*T^{n} - diff_rhs + tdensity_theta = tdensity_options%theta + + ! construct M + ! multiply the diagonal by the previous timesteps density + if(explicit) then + if(include_mass) then + m_cvmass%val = m_cvmass%val*(tdensity_theta*tdensity%val+(1.0-tdensity_theta)*oldtdensity%val) + end if + else + if(include_mass) then + call mult_diag(M, ((tdensity_theta)*tdensity%val+(1.0-tdensity_theta)*oldtdensity%val)) end if - end if - if(include_advection) call addto(M, A_m, dt) - if(include_absorption) call addto_diag(M, massabsorption, theta*dt) + if(include_advection) call addto(M, A_m, dt) + if(include_absorption) call addto_diag(M, massabsorption, theta*dt) + + ! construct rhs + if(include_advection) then + call mult(MT_old, A_m, oldtfield) + call addto(rhs, MT_old, -1.0) + end if + end if - if(include_advection) then - call mult(MT_old, A_m, oldtfield) + if(include_source .and. (.not. add_src_directly_to_rhs)) call addto(rhs, masssource) + + if(include_absorption) then + ! massabsorption has already been added to the matrix so it can now be scaled + ! by the old field value to add it to the rhs + call scale(massabsorption, oldtfield) + call addto(rhs, massabsorption, -1.0) + end if + + if(include_diffusion) then + call mult(MT_old, D_m, oldtfield) call addto(rhs, MT_old, -1.0) - end if - end if + call addto(rhs, diff_rhs, -1.0) - if(include_source .and. (.not. add_src_directly_to_rhs)) call addto(rhs, masssource) + if(.not.explicit) then + call addto(M, D_m, theta*dt) + end if + end if - if(include_absorption) then - ! massabsorption has already been added to the matrix so it can now be scaled - ! by the old field value to add it to the rhs - call scale(massabsorption, oldtfield) - call addto(rhs, massabsorption, -1.0) - end if + if(move_mesh) then + FLExit("Moving mesh with this equation type not yet supported.") + end if - if(include_diffusion) then - call mult(MT_old, D_m, oldtfield) - call addto(rhs, MT_old, -1.0) - call addto(rhs, diff_rhs, -1.0) + case (FIELD_EQUATION_INTERNALENERGY) - if(.not.explicit) then - call addto(M, D_m, theta*dt) - end if - end if + ! [\rho^{n+1}M + dt*A_m + dt*theta*D_m](T^{n+1}-T^{n})/dt = rhs - [A_m + D_m]*T^{n} - diff_rhs - (p+atm_p)*CT_m*u - if(move_mesh) then - FLExit("Moving mesh with this equation type not yet supported.") - end if + ! construct rhs + if(have_option(trim(state(1)%option_path)//'/equation_of_state/compressible')) then + p=>extract_scalar_field(state(1), "Pressure") + ewrite_minmax(p) + assert(p%mesh==tfield%mesh) + ! halo exchange not necessary as it is done straight after solve + call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + gradient_sparsity => get_csr_sparsity_firstorder(state, p%mesh, advu%mesh) - case (FIELD_EQUATION_KEPSILON) + call allocate(CT_m, gradient_sparsity, (/1, advu%dim/), name="DivergenceMatrix" ) + call assemble_divergence_matrix_cv(CT_m, state(1), & + test_mesh=p%mesh, field=advu, include_vfrac=.false.) - ! [\rho^{n+1}M + dt*A_m + dt*theta*D_m](T^{n+1}-T^{n})/dt = rhs - [A_m + D_m]*T^{n} - diff_rhs + call allocate(pterm, p%mesh, "PressureTerm") - ! construct M - if(explicit) then - if(include_mass) then - call scale(m_cvmass, tdensity) + ! construct the pressure term + call mult(pterm, CT_m, advu) if(multiphase) then - call scale(m_cvmass, nvfrac) + call scale(pterm, nvfrac) ! We need vfrac*p*div(u) for the multiphase InternalEnergy equation end if - end if - else - if(include_mass) then - call mult_diag(M, tdensity) - if(multiphase) then - call mult_diag(M, nvfrac) + + ! should this really be the advection velocity or just the relative or the nonlinear? + pterm%val = pterm%val*(p%val+atmospheric_pressure) + + call addto(rhs, pterm, -1.0) + + call deallocate(CT_m) + call deallocate(pterm) + end if + + ! construct M + if(explicit) then + if(include_mass) then + call scale(m_cvmass, tdensity) + if(multiphase) then + call scale(m_cvmass, nvfrac) + end if + end if + else + if(include_mass) then + call mult_diag(M, tdensity) + if(multiphase) then + call mult_diag(M, nvfrac) + end if end if - end if - if(include_advection) call addto(M, A_m, dt) - if(include_absorption) call addto_diag(M, massabsorption, theta*dt) + if(include_advection) call addto(M, A_m, dt) + if(include_absorption) call addto_diag(M, massabsorption, theta*dt) - if(include_advection) then - call mult(MT_old, A_m, oldtfield) + if(include_advection) then + call mult(MT_old, A_m, oldtfield) + call addto(rhs, MT_old, -1.0) + end if + end if + + if(include_source .and. (.not. add_src_directly_to_rhs)) call addto(rhs, masssource) + + if(include_absorption) then + ! massabsorption has already been added to the matrix so it can now be scaled + ! by the old field value to add it to the rhs + call scale(massabsorption, oldtfield) + call addto(rhs, massabsorption, -1.0) + end if + + if(include_diffusion) then + call mult(MT_old, D_m, oldtfield) call addto(rhs, MT_old, -1.0) - end if - end if + call addto(rhs, diff_rhs, -1.0) + + if(.not.explicit) then + call addto(M, D_m, theta*dt) + end if + end if + + if(move_mesh) then + FLExit("Moving mesh with this equation type not yet supported.") + end if + + case (FIELD_EQUATION_KEPSILON) + + ! [\rho^{n+1}M + dt*A_m + dt*theta*D_m](T^{n+1}-T^{n})/dt = rhs - [A_m + D_m]*T^{n} - diff_rhs - if(include_source .and. (.not. add_src_directly_to_rhs)) call addto(rhs, masssource) + ! construct M + if(explicit) then + if(include_mass) then + call scale(m_cvmass, tdensity) + if(multiphase) then + call scale(m_cvmass, nvfrac) + end if + end if + else + if(include_mass) then + call mult_diag(M, tdensity) + if(multiphase) then + call mult_diag(M, nvfrac) + end if + end if + if(include_advection) call addto(M, A_m, dt) + if(include_absorption) call addto_diag(M, massabsorption, theta*dt) + + if(include_advection) then + call mult(MT_old, A_m, oldtfield) + call addto(rhs, MT_old, -1.0) + end if + end if - if(include_absorption) then - ! massabsorption has already been added to the matrix so it can now be scaled - ! by the old field value to add it to the rhs - call scale(massabsorption, oldtfield) - call addto(rhs, massabsorption, -1.0) - end if + if(include_source .and. (.not. add_src_directly_to_rhs)) call addto(rhs, masssource) - if(include_diffusion) then - call mult(MT_old, D_m, oldtfield) - call addto(rhs, MT_old, -1.0) - call addto(rhs, diff_rhs, -1.0) + if(include_absorption) then + ! massabsorption has already been added to the matrix so it can now be scaled + ! by the old field value to add it to the rhs + call scale(massabsorption, oldtfield) + call addto(rhs, massabsorption, -1.0) + end if - if(.not.explicit) then - call addto(M, D_m, theta*dt) - end if - end if + if(include_diffusion) then + call mult(MT_old, D_m, oldtfield) + call addto(rhs, MT_old, -1.0) + call addto(rhs, diff_rhs, -1.0) - if(move_mesh) then - FLExit("Moving mesh with this equation type not yet supported.") - end if + if(.not.explicit) then + call addto(M, D_m, theta*dt) + end if + end if + + if(move_mesh) then + FLExit("Moving mesh with this equation type not yet supported.") + end if end select @@ -1296,23 +1296,23 @@ subroutine assemble_field_eqn_cv(M, A_m, m_cvmass, rhs, & ewrite(1, *) "Exiting assemble_field_eqn_cv" - end subroutine assemble_field_eqn_cv - ! end of equation wrapping subroutines - !************************************************************************ - !************************************************************************ - ! assembly subroutines - subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & - tfield, oldtfield, tfield_options, & - tdensity, oldtdensity, nvfrac, oldvfrac, & - tdensity_options, cvfaces, x_cvshape, x_cvbdyshape, & - u_cvshape, u_cvbdyshape, t_cvshape, & - ug_cvshape, ug_cvbdyshape, & - x_cvshape_full, x_cvbdyshape_full, & - t_cvshape_full, t_cvbdyshape_full, & - diff_cvshape_full, diff_cvbdyshape_full, & - state, advu, ug, x, x_tfield, cfl_no, dt, & - diffusivity, q_cvmass, & - mesh_sparsity, grad_m_t_sparsity) + end subroutine assemble_field_eqn_cv + ! end of equation wrapping subroutines + !************************************************************************ + !************************************************************************ + ! assembly subroutines + subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & + tfield, oldtfield, tfield_options, & + tdensity, oldtdensity, nvfrac, oldvfrac, & + tdensity_options, cvfaces, x_cvshape, x_cvbdyshape, & + u_cvshape, u_cvbdyshape, t_cvshape, & + ug_cvshape, ug_cvbdyshape, & + x_cvshape_full, x_cvbdyshape_full, & + t_cvshape_full, t_cvbdyshape_full, & + diff_cvshape_full, diff_cvbdyshape_full, & + state, advu, ug, x, x_tfield, cfl_no, dt, & + diffusivity, q_cvmass, & + mesh_sparsity, grad_m_t_sparsity) ! This subroutine assembles the advection and diffusion matrices and rhs(s) for ! control volume field equations such that: @@ -1406,9 +1406,9 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & real, dimension(ele_loc(tdensity,1)) :: tdensity_ele, oldtdensity_ele real, dimension(ele_loc(tfield,1)) :: tfield_ele, oldtfield_ele real, dimension(face_loc(tdensity,1)) :: tdensity_ele_bdy, oldtdensity_ele_bdy, & - ghost_tdensity_ele_bdy, ghost_oldtdensity_ele_bdy + ghost_tdensity_ele_bdy, ghost_oldtdensity_ele_bdy real, dimension(face_loc(tfield,1)) :: tfield_ele_bdy, oldtfield_ele_bdy, & - ghost_tfield_ele_bdy, ghost_gradtfield_ele_bdy, ghost_oldtfield_ele_bdy + ghost_tfield_ele_bdy, ghost_gradtfield_ele_bdy, ghost_oldtfield_ele_bdy ! some memory used in assembly of the face values real :: tfield_theta_val, tdensity_theta_val, tfield_pivot_val @@ -1426,7 +1426,7 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & ! upwind value matrices for the fields and densities type(csr_matrix) :: tfield_upwind, & - oldtfield_upwind, tdensity_upwind, oldtdensity_upwind + oldtfield_upwind, tdensity_upwind, oldtdensity_upwind ! incoming or outgoing flow real :: udotn, divudotn, income @@ -1467,7 +1467,7 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & ! Boundary condition types integer, parameter :: BC_TYPE_WEAKDIRICHLET = 1, BC_TYPE_NEUMANN = 2, BC_TYPE_INTERNAL = 3, & - BC_TYPE_ZEROFLUX = 4, BC_TYPE_FLUX = 5, BC_TYPE_ROBIN = 6 + BC_TYPE_ZEROFLUX = 4, BC_TYPE_FLUX = 5, BC_TYPE_ROBIN = 6 ewrite(1, *) "In assemble_advectiondiffusion_m_cv" @@ -1481,55 +1481,55 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & ! does the field need upwind values if(need_upwind_values(tfield_options)) then - call find_upwind_values(state, x_tfield, tfield, tfield_upwind, & - oldtfield, oldtfield_upwind, & - option_path=trim(tfield%option_path)) + call find_upwind_values(state, x_tfield, tfield, tfield_upwind, & + oldtfield, oldtfield_upwind, & + option_path=trim(tfield%option_path)) else - call zero(tfield_upwind) - call zero(oldtfield_upwind) + call zero(tfield_upwind) + call zero(oldtfield_upwind) end if ! does the density field need upwind values? if(include_density) then - call allocate(tdensity_upwind, mesh_sparsity, name="TDensityUpwindValues") - call allocate(oldtdensity_upwind, mesh_sparsity, name="OldTDensityUpwindValues") - - if(need_upwind_values(tdensity_options)) then - if(have_option(trim(tfield%option_path)//'/prognostic/equation[0]/density[0]/discretisation_options')) then - call find_upwind_values(state, x_tfield, tdensity, tdensity_upwind, & - oldtdensity, oldtdensity_upwind, & - option_path=trim(tfield%option_path)//'/prognostic/equation[0]/density[0]/discretisation_options') - else - call find_upwind_values(state, x_tfield, tdensity, tdensity_upwind, & - oldtdensity, oldtdensity_upwind & - ) - end if - - else - - call zero(tdensity_upwind) - call zero(oldtdensity_upwind) - - end if + call allocate(tdensity_upwind, mesh_sparsity, name="TDensityUpwindValues") + call allocate(oldtdensity_upwind, mesh_sparsity, name="OldTDensityUpwindValues") + + if(need_upwind_values(tdensity_options)) then + if(have_option(trim(tfield%option_path)//'/prognostic/equation[0]/density[0]/discretisation_options')) then + call find_upwind_values(state, x_tfield, tdensity, tdensity_upwind, & + oldtdensity, oldtdensity_upwind, & + option_path=trim(tfield%option_path)//'/prognostic/equation[0]/density[0]/discretisation_options') + else + call find_upwind_values(state, x_tfield, tdensity, tdensity_upwind, & + oldtdensity, oldtdensity_upwind & + ) + end if + + else + + call zero(tdensity_upwind) + call zero(oldtdensity_upwind) + + end if end if ! allocate and clear memory for diffusion if(assemble_diffusion) then - if(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY) then - call allocate(div_m, sparsity=grad_m_t_sparsity, & - blocks=(/1, mesh_dim(tfield)/), & - name=trim(tfield%name)//"AuxilliaryGradientMatrixTransposed") - call zero(div_m) - call allocate(grad_rhs, mesh_dim(tfield), diffusivity%mesh, & - name=trim(tfield%name)//"AuxilliaryGradientRHS") - call zero(grad_rhs) - end if - - call zero(D_m) - call zero(diff_rhs) + if(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY) then + call allocate(div_m, sparsity=grad_m_t_sparsity, & + blocks=(/1, mesh_dim(tfield)/), & + name=trim(tfield%name)//"AuxilliaryGradientMatrixTransposed") + call zero(div_m) + call allocate(grad_rhs, mesh_dim(tfield), diffusivity%mesh, & + name=trim(tfield%name)//"AuxilliaryGradientRHS") + call zero(grad_rhs) + end if + + call zero(D_m) + call zero(diff_rhs) end if ! some temporal discretisation options for clarity @@ -1539,294 +1539,294 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & ! loop over elements element_loop: do ele=1, element_count(tfield) - x_ele=ele_val(x, ele) - xt_ele=ele_val(x_tfield, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - nodes=>ele_nodes(tfield, ele) - ! the nodes in this element from the coordinate mesh projected - ! to the tfield mesh (unperiodised perhaps... hence different to tfield mesh) - x_nodes=>ele_nodes(x_tfield, ele) - if(include_advection) then - u_f=ele_val_at_quad(advu, ele, u_cvshape) - if(move_mesh) ug_f=ele_val_at_quad(ug, ele, ug_cvshape) - if((tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& - (tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then - upwind_nodes=>x_nodes - else - upwind_nodes=>nodes - end if - end if - - ! find determinant and unorientated normal - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) - - if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then - diffusivity_nodes=>ele_nodes(diffusivity, ele) - ! diffusivity may be on a lower degree mesh than the field... to allow that - ! without changing the assembly code for each specific case we construct - ! a mapping to the global nodes that is consistent with the local node - ! numbering of the parent field. - ! warning: this is not ideal as it will require more csr_pos's - ! but its more intended as a proof of concept - do iloc = 1, size(diffusivity_lglno), size(diffusivity_nodes) - diffusivity_lglno(iloc:iloc+size(diffusivity_nodes)-1)=diffusivity_nodes - end do - end if - - if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_ELEMENTGRADIENT)) then - call transform_to_physical(X, ele, x_shape=x_cvshape_full, & - shape=t_cvshape_full, dshape=dt_t) - diffusivity_gi = ele_val_at_quad(diffusivity, ele, diff_cvshape_full) - - if(multiphase .and. equation_type==FIELD_EQUATION_INTERNALENERGY) then - nvfrac_gi = ele_val_at_quad(nvfrac, ele, diff_cvshape_full) - end if - - end if - - cfl_ele = ele_val(cfl_no, ele) - - tfield_ele = ele_val(tfield, ele) - oldtfield_ele = ele_val(oldtfield, ele) - - if(include_density) then - tdensity_ele = ele_val(tdensity, ele) - oldtdensity_ele = ele_val(oldtdensity, ele) - - if(multiphase) then - tdensity_ele = tdensity_ele*ele_val(nvfrac,ele) - oldtdensity_ele = oldtdensity_ele*ele_val(oldvfrac,ele) - end if - end if - - notvisited=.true. - - grad_mat_local = 0.0 - mat_local = 0.0 - rhs_local = 0.0 - diff_mat_local = 0.0 - - ! loop over nodes within this element - nodal_loop_i: do iloc = 1, tfield%mesh%shape%loc - - ! loop over cv faces internal to this element - face_loop: do face = 1, cvfaces%faces - - ! is this a face neighbouring iloc? - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) - - ! loop over gauss points on face - quadrature_loop: do gi = 1, cvfaces%shape%ngi - - ! global gauss pt index - ggi = (face-1)*cvfaces%shape%ngi + gi - - ! have we been here before? - if(notvisited(ggi)) then - notvisited(ggi)=.false. - - ! correct the orientation of the normal so it points away from iloc - normgi=orientate_cvsurf_normgi(node_val(x_tfield, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - - if(include_advection) then - ! calculate u.n - if(move_mesh) then - udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi(:)) - divudotn=dot_product(u_f(:,ggi), normgi(:)) - else - udotn=dot_product(u_f(:,ggi), normgi(:)) - divudotn=udotn - end if - inflow = (udotn<=0.0) - income = merge(1.0,0.0,inflow) - - ! calculate the iterated pivot value (so far only does first order upwind) - ! which will be subtracted out from the rhs such that with an increasing number - ! of iterations the true implicit lhs pivot is cancelled out (if it converges!) - tfield_pivot_val = income*tfield_ele(oloc) + (1.-income)*tfield_ele(iloc) - - ! evaluate the nonlinear face value that will go into the rhs - ! this is the value that you choose the discretisation for and - ! that will become the dominant term once convergence is achieved - call evaluate_face_val(tfield_face_val, oldtfield_face_val, & - iloc, oloc, ggi, upwind_nodes, & - t_cvshape, & - tfield_ele, oldtfield_ele, & - tfield_upwind, oldtfield_upwind, & - inflow, cfl_ele, & - tfield_options) - - ! perform the time discretisation on the combined tdensity tfield product - tfield_theta_val=theta_val(iloc, oloc, & - tfield_face_val, & - oldtfield_face_val, & - tfield_options%theta, dt, udotn, & - xt_ele, tfield_options%limit_theta, & - tfield_ele, oldtfield_ele, & - ftheta=ftheta) - - if(include_density) then - ! do the same for the density but save some effort if it's just a dummy - select case (tdensity%field_type) - case(FIELD_TYPE_CONSTANT) - tdensity_face_val = tdensity_ele(iloc) - oldtdensity_face_val = oldtdensity_ele(iloc) - - case default - call evaluate_face_val(tdensity_face_val, oldtdensity_face_val, & - iloc, oloc, ggi, upwind_nodes, & - t_cvshape,& - tdensity_ele, oldtdensity_ele, & - tdensity_upwind, oldtdensity_upwind, & - inflow, cfl_ele, & - tdensity_options) - - end select - tdensity_theta_val=theta_val(iloc, oloc, & - tdensity_face_val, & - oldtdensity_face_val, & - tdensity_options%theta, dt, udotn, & - xt_ele, tdensity_options%limit_theta, & - tdensity_ele, oldtdensity_ele) - - if(assemble_advection_matrix) then - mat_local(iloc, oloc) = mat_local(iloc, oloc) & - + ptheta*detwei(ggi)*udotn*income*tdensity_theta_val - mat_local(oloc, iloc) = mat_local(oloc, iloc) & - + ptheta*detwei(ggi)*(-udotn)*(1.-income)*tdensity_theta_val - mat_local(iloc, iloc) = mat_local(iloc, iloc) & - + ptheta*detwei(ggi)*udotn*(1.0-income)*tdensity_theta_val & - - ftheta*(1.-beta)*detwei(ggi)*divudotn*tdensity_theta_val - mat_local(oloc, oloc) = mat_local(oloc, oloc) & - + ptheta*detwei(ggi)*(-udotn)*income*tdensity_theta_val & - - ftheta*(1.-beta)*detwei(ggi)*(-divudotn)*tdensity_theta_val - end if - - rhs_local(iloc) = rhs_local(iloc) & - + ptheta*udotn*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & - - udotn*detwei(ggi)*tfield_theta_val*tdensity_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*divudotn*tdensity_theta_val*oldtfield_ele(iloc) - rhs_local(oloc) = rhs_local(oloc) & - + ptheta*(-udotn)*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & - - (-udotn)*detwei(ggi)*tfield_theta_val*tdensity_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-divudotn)*tdensity_theta_val*oldtfield_ele(oloc) - - else - if(assemble_advection_matrix) then - mat_local(iloc, oloc) = mat_local(iloc, oloc) & - + ptheta*detwei(ggi)*udotn*income - mat_local(oloc, iloc) = mat_local(oloc, iloc) & - + ptheta*detwei(ggi)*(-udotn)*(1.-income) - mat_local(iloc, iloc) = mat_local(iloc, iloc) & - + ptheta*detwei(ggi)*udotn*(1.0-income) & - - ftheta*(1.-beta)*detwei(ggi)*divudotn - mat_local(oloc, oloc) = mat_local(oloc, oloc) & - + ptheta*detwei(ggi)*(-udotn)*income & - - ftheta*(1.-beta)*detwei(ggi)*(-divudotn) - end if - - rhs_local(iloc) = rhs_local(iloc) & - + ptheta*udotn*detwei(ggi)*tfield_pivot_val & - - udotn*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*divudotn*oldtfield_ele(iloc) - rhs_local(oloc) = rhs_local(oloc) & - + ptheta*(-udotn)*detwei(ggi)*tfield_pivot_val & - - (-udotn)*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-divudotn)*oldtfield_ele(oloc) - end if - end if + x_ele=ele_val(x, ele) + xt_ele=ele_val(x_tfield, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + nodes=>ele_nodes(tfield, ele) + ! the nodes in this element from the coordinate mesh projected + ! to the tfield mesh (unperiodised perhaps... hence different to tfield mesh) + x_nodes=>ele_nodes(x_tfield, ele) + if(include_advection) then + u_f=ele_val_at_quad(advu, ele, u_cvshape) + if(move_mesh) ug_f=ele_val_at_quad(ug, ele, ug_cvshape) + if((tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& + (tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then + upwind_nodes=>x_nodes + else + upwind_nodes=>nodes + end if + end if - if(assemble_diffusion) then - select case(tfield_options%diffusionscheme) - case(CV_DIFFUSION_BASSIREBAY) - - ! assemble the auxiliary gradient matrix - dimension_loop1: do dim = 1, mesh_dim(tfield) - - grad_mat_local(dim, iloc, iloc) = grad_mat_local(dim, iloc, iloc) & - +0.5*detwei(ggi)*normgi(dim) - ! the divergence form: - grad_mat_local(dim, iloc, oloc) = grad_mat_local(dim, iloc, oloc) & - +0.5*detwei(ggi)*normgi(dim) ! remember this is a divergence assembly - ! this is the equivalent gradient transposed form: - ! grad_mat_local(dim, oloc, iloc) = grad_mat_local(dim, oloc, iloc) & - ! +0.5*detwei(ggi)*normgi(dim) ! remember this is a gradient transposed - - ! evaluate the faces we're not visiting (as an optimisation) - grad_mat_local(dim, oloc, oloc) = grad_mat_local(dim, oloc, oloc) & - -0.5*detwei(ggi)*normgi(dim) - grad_mat_local(dim, oloc, iloc) = grad_mat_local(dim, oloc, iloc) & - -0.5*detwei(ggi)*normgi(dim) ! remember this is a divergence assembly - ! this is the equivalent gradient transposed form: - ! grad_mat_local(dim, iloc, oloc) = grad_mat_local(dim, iloc, oloc) & - ! -0.5*detwei(ggi)*normgi(dim) ! remember this is a gradient transposed - end do dimension_loop1 - - case(CV_DIFFUSION_ELEMENTGRADIENT) - - if(multiphase .and. equation_type==FIELD_EQUATION_INTERNALENERGY) then - ! This allows us to use the Diffusivity term as the heat flux term - ! in the multiphase InternalEnergy equation: div( (k/Cv) * vfrac * grad(ie) ). - ! The user needs to input k/Cv for the prescribed diffusivity, - ! where k is the effective conductivity and Cv is the specific heat - ! at constant volume. The division by Cv is needed because the heat flux - ! is defined in terms of temperature T = ie/Cv. - - do dloc=1,size(dt_t,1) - ! n_i K_{ij} dT/dx_j - diff_mat_local(iloc,dloc) = diff_mat_local(iloc,dloc) - & - sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*normgi, 1)*detwei(ggi)*nvfrac_gi(ggi) - - ! notvisited - diff_mat_local(oloc, dloc) = diff_mat_local(oloc,dloc) - & - sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*(-normgi), 1)*detwei(ggi)*nvfrac_gi(ggi) - end do - else - do dloc=1,size(dt_t,1) - ! n_i K_{ij} dT/dx_j - diff_mat_local(iloc,dloc) = diff_mat_local(iloc,dloc) - & - sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*normgi, 1)*detwei(ggi) - - ! notvisited - diff_mat_local(oloc, dloc) = diff_mat_local(oloc,dloc) - & - sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*(-normgi), 1)*detwei(ggi) - end do - end if + ! find determinant and unorientated normal + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) + + if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then + diffusivity_nodes=>ele_nodes(diffusivity, ele) + ! diffusivity may be on a lower degree mesh than the field... to allow that + ! without changing the assembly code for each specific case we construct + ! a mapping to the global nodes that is consistent with the local node + ! numbering of the parent field. + ! warning: this is not ideal as it will require more csr_pos's + ! but its more intended as a proof of concept + do iloc = 1, size(diffusivity_lglno), size(diffusivity_nodes) + diffusivity_lglno(iloc:iloc+size(diffusivity_nodes)-1)=diffusivity_nodes + end do + end if - end select - end if + if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_ELEMENTGRADIENT)) then + call transform_to_physical(X, ele, x_shape=x_cvshape_full, & + shape=t_cvshape_full, dshape=dt_t) + diffusivity_gi = ele_val_at_quad(diffusivity, ele, diff_cvshape_full) - end if ! notvisited - end do quadrature_loop + if(multiphase .and. equation_type==FIELD_EQUATION_INTERNALENERGY) then + nvfrac_gi = ele_val_at_quad(nvfrac, ele, diff_cvshape_full) + end if - end if ! neiloc - end do face_loop - end do nodal_loop_i + end if - ! if we need the matrix then assemble it now - if(assemble_advection_matrix) then - call addto(A_m, nodes, nodes, mat_local) - end if + cfl_ele = ele_val(cfl_no, ele) - if(assemble_diffusion) then - select case(tfield_options%diffusionscheme) - case(CV_DIFFUSION_BASSIREBAY) + tfield_ele = ele_val(tfield, ele) + oldtfield_ele = ele_val(oldtfield, ele) - call addto(div_m, nodes, diffusivity_lglno, spread(grad_mat_local, 1, 1)) + if(include_density) then + tdensity_ele = ele_val(tdensity, ele) + oldtdensity_ele = ele_val(oldtdensity, ele) - case(CV_DIFFUSION_ELEMENTGRADIENT) + if(multiphase) then + tdensity_ele = tdensity_ele*ele_val(nvfrac,ele) + oldtdensity_ele = oldtdensity_ele*ele_val(oldvfrac,ele) + end if + end if + + notvisited=.true. + + grad_mat_local = 0.0 + mat_local = 0.0 + rhs_local = 0.0 + diff_mat_local = 0.0 + + ! loop over nodes within this element + nodal_loop_i: do iloc = 1, tfield%mesh%shape%loc + + ! loop over cv faces internal to this element + face_loop: do face = 1, cvfaces%faces + + ! is this a face neighbouring iloc? + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) + + ! loop over gauss points on face + quadrature_loop: do gi = 1, cvfaces%shape%ngi + + ! global gauss pt index + ggi = (face-1)*cvfaces%shape%ngi + gi + + ! have we been here before? + if(notvisited(ggi)) then + notvisited(ggi)=.false. + + ! correct the orientation of the normal so it points away from iloc + normgi=orientate_cvsurf_normgi(node_val(x_tfield, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + + if(include_advection) then + ! calculate u.n + if(move_mesh) then + udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi(:)) + divudotn=dot_product(u_f(:,ggi), normgi(:)) + else + udotn=dot_product(u_f(:,ggi), normgi(:)) + divudotn=udotn + end if + inflow = (udotn<=0.0) + income = merge(1.0,0.0,inflow) + + ! calculate the iterated pivot value (so far only does first order upwind) + ! which will be subtracted out from the rhs such that with an increasing number + ! of iterations the true implicit lhs pivot is cancelled out (if it converges!) + tfield_pivot_val = income*tfield_ele(oloc) + (1.-income)*tfield_ele(iloc) + + ! evaluate the nonlinear face value that will go into the rhs + ! this is the value that you choose the discretisation for and + ! that will become the dominant term once convergence is achieved + call evaluate_face_val(tfield_face_val, oldtfield_face_val, & + iloc, oloc, ggi, upwind_nodes, & + t_cvshape, & + tfield_ele, oldtfield_ele, & + tfield_upwind, oldtfield_upwind, & + inflow, cfl_ele, & + tfield_options) + + ! perform the time discretisation on the combined tdensity tfield product + tfield_theta_val=theta_val(iloc, oloc, & + tfield_face_val, & + oldtfield_face_val, & + tfield_options%theta, dt, udotn, & + xt_ele, tfield_options%limit_theta, & + tfield_ele, oldtfield_ele, & + ftheta=ftheta) + + if(include_density) then + ! do the same for the density but save some effort if it's just a dummy + select case (tdensity%field_type) + case(FIELD_TYPE_CONSTANT) + tdensity_face_val = tdensity_ele(iloc) + oldtdensity_face_val = oldtdensity_ele(iloc) + + case default + call evaluate_face_val(tdensity_face_val, oldtdensity_face_val, & + iloc, oloc, ggi, upwind_nodes, & + t_cvshape,& + tdensity_ele, oldtdensity_ele, & + tdensity_upwind, oldtdensity_upwind, & + inflow, cfl_ele, & + tdensity_options) + + end select + tdensity_theta_val=theta_val(iloc, oloc, & + tdensity_face_val, & + oldtdensity_face_val, & + tdensity_options%theta, dt, udotn, & + xt_ele, tdensity_options%limit_theta, & + tdensity_ele, oldtdensity_ele) + + if(assemble_advection_matrix) then + mat_local(iloc, oloc) = mat_local(iloc, oloc) & + + ptheta*detwei(ggi)*udotn*income*tdensity_theta_val + mat_local(oloc, iloc) = mat_local(oloc, iloc) & + + ptheta*detwei(ggi)*(-udotn)*(1.-income)*tdensity_theta_val + mat_local(iloc, iloc) = mat_local(iloc, iloc) & + + ptheta*detwei(ggi)*udotn*(1.0-income)*tdensity_theta_val & + - ftheta*(1.-beta)*detwei(ggi)*divudotn*tdensity_theta_val + mat_local(oloc, oloc) = mat_local(oloc, oloc) & + + ptheta*detwei(ggi)*(-udotn)*income*tdensity_theta_val & + - ftheta*(1.-beta)*detwei(ggi)*(-divudotn)*tdensity_theta_val + end if + + rhs_local(iloc) = rhs_local(iloc) & + + ptheta*udotn*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & + - udotn*detwei(ggi)*tfield_theta_val*tdensity_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*divudotn*tdensity_theta_val*oldtfield_ele(iloc) + rhs_local(oloc) = rhs_local(oloc) & + + ptheta*(-udotn)*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & + - (-udotn)*detwei(ggi)*tfield_theta_val*tdensity_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-divudotn)*tdensity_theta_val*oldtfield_ele(oloc) + + else + if(assemble_advection_matrix) then + mat_local(iloc, oloc) = mat_local(iloc, oloc) & + + ptheta*detwei(ggi)*udotn*income + mat_local(oloc, iloc) = mat_local(oloc, iloc) & + + ptheta*detwei(ggi)*(-udotn)*(1.-income) + mat_local(iloc, iloc) = mat_local(iloc, iloc) & + + ptheta*detwei(ggi)*udotn*(1.0-income) & + - ftheta*(1.-beta)*detwei(ggi)*divudotn + mat_local(oloc, oloc) = mat_local(oloc, oloc) & + + ptheta*detwei(ggi)*(-udotn)*income & + - ftheta*(1.-beta)*detwei(ggi)*(-divudotn) + end if + + rhs_local(iloc) = rhs_local(iloc) & + + ptheta*udotn*detwei(ggi)*tfield_pivot_val & + - udotn*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*divudotn*oldtfield_ele(iloc) + rhs_local(oloc) = rhs_local(oloc) & + + ptheta*(-udotn)*detwei(ggi)*tfield_pivot_val & + - (-udotn)*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-divudotn)*oldtfield_ele(oloc) + end if + end if + + if(assemble_diffusion) then + select case(tfield_options%diffusionscheme) + case(CV_DIFFUSION_BASSIREBAY) + + ! assemble the auxiliary gradient matrix + dimension_loop1: do dim = 1, mesh_dim(tfield) + + grad_mat_local(dim, iloc, iloc) = grad_mat_local(dim, iloc, iloc) & + +0.5*detwei(ggi)*normgi(dim) + ! the divergence form: + grad_mat_local(dim, iloc, oloc) = grad_mat_local(dim, iloc, oloc) & + +0.5*detwei(ggi)*normgi(dim) ! remember this is a divergence assembly + ! this is the equivalent gradient transposed form: + ! grad_mat_local(dim, oloc, iloc) = grad_mat_local(dim, oloc, iloc) & + ! +0.5*detwei(ggi)*normgi(dim) ! remember this is a gradient transposed + + ! evaluate the faces we're not visiting (as an optimisation) + grad_mat_local(dim, oloc, oloc) = grad_mat_local(dim, oloc, oloc) & + -0.5*detwei(ggi)*normgi(dim) + grad_mat_local(dim, oloc, iloc) = grad_mat_local(dim, oloc, iloc) & + -0.5*detwei(ggi)*normgi(dim) ! remember this is a divergence assembly + ! this is the equivalent gradient transposed form: + ! grad_mat_local(dim, iloc, oloc) = grad_mat_local(dim, iloc, oloc) & + ! -0.5*detwei(ggi)*normgi(dim) ! remember this is a gradient transposed + end do dimension_loop1 + + case(CV_DIFFUSION_ELEMENTGRADIENT) + + if(multiphase .and. equation_type==FIELD_EQUATION_INTERNALENERGY) then + ! This allows us to use the Diffusivity term as the heat flux term + ! in the multiphase InternalEnergy equation: div( (k/Cv) * vfrac * grad(ie) ). + ! The user needs to input k/Cv for the prescribed diffusivity, + ! where k is the effective conductivity and Cv is the specific heat + ! at constant volume. The division by Cv is needed because the heat flux + ! is defined in terms of temperature T = ie/Cv. + + do dloc=1,size(dt_t,1) + ! n_i K_{ij} dT/dx_j + diff_mat_local(iloc,dloc) = diff_mat_local(iloc,dloc) - & + sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*normgi, 1)*detwei(ggi)*nvfrac_gi(ggi) + + ! notvisited + diff_mat_local(oloc, dloc) = diff_mat_local(oloc,dloc) - & + sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*(-normgi), 1)*detwei(ggi)*nvfrac_gi(ggi) + end do + else + do dloc=1,size(dt_t,1) + ! n_i K_{ij} dT/dx_j + diff_mat_local(iloc,dloc) = diff_mat_local(iloc,dloc) - & + sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*normgi, 1)*detwei(ggi) + + ! notvisited + diff_mat_local(oloc, dloc) = diff_mat_local(oloc,dloc) - & + sum(matmul(diffusivity_gi(:,:,ggi), dt_t(dloc, ggi, :))*(-normgi), 1)*detwei(ggi) + end do + end if + + end select + end if + + end if ! notvisited + end do quadrature_loop + + end if ! neiloc + end do face_loop + end do nodal_loop_i + + ! if we need the matrix then assemble it now + if(assemble_advection_matrix) then + call addto(A_m, nodes, nodes, mat_local) + end if + + if(assemble_diffusion) then + select case(tfield_options%diffusionscheme) + case(CV_DIFFUSION_BASSIREBAY) - call addto(D_m, nodes, nodes, diff_mat_local) + call addto(div_m, nodes, diffusivity_lglno, spread(grad_mat_local, 1, 1)) - end select - end if + case(CV_DIFFUSION_ELEMENTGRADIENT) - ! assemble the rhs - if(include_advection) then - call addto(rhs, nodes, rhs_local) - end if + call addto(D_m, nodes, nodes, diff_mat_local) + + end select + end if + + ! assemble the rhs + if(include_advection) then + call addto(rhs, nodes, rhs_local) + end if end do element_loop @@ -1835,367 +1835,367 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & ! get the fields over the surface containing the bcs call get_entire_boundary_condition(tfield, (/ & - "weakdirichlet", & - "neumann ", & - "internal ", & - "zero_flux ", & - "flux ", & - "robin "/), tfield_bc, tfield_bc_type, boundary_second_value = tfield_bc2) + "weakdirichlet", & + "neumann ", & + "internal ", & + "zero_flux ", & + "flux ", & + "robin "/), tfield_bc, tfield_bc_type, boundary_second_value = tfield_bc2) if(include_density) then - allocate(tdensity_bc_type(surface_element_count(tdensity))) - call get_entire_boundary_condition(tdensity, (/"weakdirichlet"/), tdensity_bc, tdensity_bc_type) + allocate(tdensity_bc_type(surface_element_count(tdensity))) + call get_entire_boundary_condition(tdensity, (/"weakdirichlet"/), tdensity_bc, tdensity_bc_type) end if ! loop over the surface elements surface_element_loop: do sele = 1, surface_element_count(tfield) - if((tfield_bc_type(sele)==BC_TYPE_INTERNAL)) cycle - - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - nodes_bdy=face_global_nodes(tfield, sele) - - ! calculate the determinant and orientated normal - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) - - if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then - diffusivity_nodes_bdy=face_global_nodes(diffusivity,sele) - ! diffusivity may be on a lower degree mesh than the field... to allow that - ! without changing the assembly code for each specific case we construct - ! a mapping to the global nodes that is consistent with the local node - ! numbering of the parent field. - ! warning: this is not ideal as it will require more csr_pos's - ! but its more intended as a proof of concept - do iloc = 1, size(diffusivity_lglno_bdy), size(diffusivity_nodes_bdy) - diffusivity_lglno_bdy(iloc:iloc+size(diffusivity_nodes_bdy)-1)=diffusivity_nodes_bdy - end do - end if - - if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_ELEMENTGRADIENT)) then - ! call transform_to_physical(x_ele_bdy, x_cvbdyshape_full, & - ! m=t_cvbdyshape_full, dm_t=dt_ft) - dt_ft = 0.0 ! at the moment its not possible to get the full gradient - ! so until this is fixed we're just going to have to assume - ! zero neumann on outflow boundaries - diffusivity_gi_f = face_val_at_quad(diffusivity, sele, diff_cvbdyshape_full) - end if - - ! deal with bcs for tfield - if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET .or. tfield_bc_type(sele)==BC_TYPE_FLUX) then - ghost_tfield_ele_bdy=ele_val(tfield_bc, sele) - else - ghost_tfield_ele_bdy=face_val(tfield, sele) - end if - - if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_oldtfield_ele_bdy=ele_val(tfield_bc, sele) ! not considering time varying bcs yet - else - ghost_oldtfield_ele_bdy=face_val(oldtfield, sele) - end if - - if(include_advection) then - u_bdy_f=face_val_at_quad(advu, sele, u_cvbdyshape) - if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) - - tfield_ele_bdy=face_val(tfield, sele) - oldtfield_ele_bdy=face_val(oldtfield, sele) - - if(include_density) then - ! deal with bcs for tdensity - if(tdensity_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_tdensity_ele_bdy=ele_val(tdensity_bc, sele) - else - if(multiphase) then - ghost_tdensity_ele_bdy=face_val(tdensity, sele)*face_val(nvfrac, sele) - else - ghost_tdensity_ele_bdy=face_val(tdensity, sele) - end if - end if + if((tfield_bc_type(sele)==BC_TYPE_INTERNAL)) cycle + + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + nodes_bdy=face_global_nodes(tfield, sele) + + ! calculate the determinant and orientated normal + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) + + if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then + diffusivity_nodes_bdy=face_global_nodes(diffusivity,sele) + ! diffusivity may be on a lower degree mesh than the field... to allow that + ! without changing the assembly code for each specific case we construct + ! a mapping to the global nodes that is consistent with the local node + ! numbering of the parent field. + ! warning: this is not ideal as it will require more csr_pos's + ! but its more intended as a proof of concept + do iloc = 1, size(diffusivity_lglno_bdy), size(diffusivity_nodes_bdy) + diffusivity_lglno_bdy(iloc:iloc+size(diffusivity_nodes_bdy)-1)=diffusivity_nodes_bdy + end do + end if - if(tdensity_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_oldtdensity_ele_bdy=ele_val(tdensity_bc, sele) ! not considering time varying bcs yet - else - if(multiphase) then - ghost_oldtdensity_ele_bdy=face_val(oldtdensity, sele)*face_val(oldvfrac, sele) - else - ghost_oldtdensity_ele_bdy=face_val(oldtdensity, sele) - end if - end if + if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_ELEMENTGRADIENT)) then + ! call transform_to_physical(x_ele_bdy, x_cvbdyshape_full, & + ! m=t_cvbdyshape_full, dm_t=dt_ft) + dt_ft = 0.0 ! at the moment its not possible to get the full gradient + ! so until this is fixed we're just going to have to assume + ! zero neumann on outflow boundaries + diffusivity_gi_f = face_val_at_quad(diffusivity, sele, diff_cvbdyshape_full) + end if - tdensity_ele_bdy=face_val(tdensity, sele) - oldtdensity_ele_bdy=face_val(oldtdensity, sele) + ! deal with bcs for tfield + if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET .or. tfield_bc_type(sele)==BC_TYPE_FLUX) then + ghost_tfield_ele_bdy=ele_val(tfield_bc, sele) + else + ghost_tfield_ele_bdy=face_val(tfield, sele) + end if - if(multiphase) then - tdensity_ele_bdy=tdensity_ele_bdy*face_val(nvfrac, sele) - oldtdensity_ele_bdy=oldtdensity_ele_bdy*face_val(oldvfrac, sele) - end if - end if - end if - - if(assemble_diffusion) then - if (tfield_bc_type(sele)==BC_TYPE_ROBIN) then - if (.not. tfield_options%diffusionscheme == CV_DIFFUSION_ELEMENTGRADIENT) then - FLExit('Can only use CV robin BC with ElementGradient diffusion scheme') - end if - robin_bc_val1_ele_bdy = ele_val(tfield_bc, sele) - robin_bc_val2_ele_bdy = ele_val(tfield_bc2, sele) - robin_diff_mat_local_bdy = 0.0 - robin_diff_rhs_local_bdy = 0.0 - else - ghost_gradtfield_ele_bdy = ele_val(tfield_bc, sele) - end if - end if - - ! zero small matrices for assembly - grad_mat_local_bdy = 0.0 - grad_rhs_local_bdy = 0.0 - div_rhs_local_bdy = 0.0 - mat_local_bdy = 0.0 - rhs_local_bdy = 0.0 - diff_mat_local_bdy = 0.0 - - ! loop over the nodes on this surface element - surface_nodal_loop_i: do iloc = 1, tfield%mesh%faces%shape%loc - - ! loop over the faces in this surface element - surface_face_loop: do face = 1, cvfaces%sfaces - - ! is this face a neighbour of iloc? - if(cvfaces%sneiloc(iloc,face)/=0) then - - ! loop over the gauss pts on this face - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - - ! global gauss point index - ggi = (face-1)*cvfaces%shape%ngi + gi - - if(include_advection) then - - ! u.n - divudotn = dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) - if(move_mesh) then - if((tfield_bc_type(sele)==BC_TYPE_ZEROFLUX .or. tfield_bc_type(sele)==BC_TYPE_FLUX)) then - ! If we have zero flux, or a flux BC, set u.n = 0 - udotn = 0.0 - else - udotn = dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) - end if - else - if((tfield_bc_type(sele)==BC_TYPE_ZEROFLUX .or. tfield_bc_type(sele)==BC_TYPE_FLUX)) then - udotn = 0.0 - else - udotn = divudotn - end if - end if + if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_oldtfield_ele_bdy=ele_val(tfield_bc, sele) ! not considering time varying bcs yet + else + ghost_oldtfield_ele_bdy=face_val(oldtfield, sele) + end if + + if(include_advection) then + u_bdy_f=face_val_at_quad(advu, sele, u_cvbdyshape) + if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) + + tfield_ele_bdy=face_val(tfield, sele) + oldtfield_ele_bdy=face_val(oldtfield, sele) - if(udotn>0) then - income=0.0 ! flow leaving the domain + if(include_density) then + ! deal with bcs for tdensity + if(tdensity_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_tdensity_ele_bdy=ele_val(tdensity_bc, sele) + else + if(multiphase) then + ghost_tdensity_ele_bdy=face_val(tdensity, sele)*face_val(nvfrac, sele) else - income=1.0 ! flow entering the domain + ghost_tdensity_ele_bdy=face_val(tdensity, sele) end if + end if - ! as we're on the boundary it's not possible to use "high order" methods so just - ! default to the pivotted solution method (first order upwinding) - ! if the flow is incoming then use the bc ghost values - ! if the flow is outgoing then use the surface nodes value - - ! for tfield - tfield_face_val = income*ghost_tfield_ele_bdy(iloc) + (1.-income)*tfield_ele_bdy(iloc) - oldtfield_face_val = income*ghost_oldtfield_ele_bdy(iloc) + (1.-income)*oldtfield_ele_bdy(iloc) - - if(include_density) then - ! for tdensity - tdensity_face_val = income*ghost_tdensity_ele_bdy(iloc) + (1.-income)*tdensity_ele_bdy(iloc) - oldtdensity_face_val = income*ghost_oldtdensity_ele_bdy(iloc) + (1.-income)*oldtdensity_ele_bdy(iloc) - - tdensity_theta_val = tdensity_options%theta*tdensity_face_val + (1.-tdensity_options%theta)*oldtdensity_face_val - - if(assemble_advection_matrix) then - ! if iloc is the donor we can do this implicitly - mat_local_bdy(iloc) = mat_local_bdy(iloc) & - + ptheta*detwei_bdy(ggi)*udotn*(1.-income)*tdensity_theta_val & - - ptheta*(1.-beta)*detwei_bdy(ggi)*divudotn*tdensity_theta_val - end if - - ! but we can't if it's the downwind - rhs_local_bdy(iloc) = rhs_local_bdy(iloc) & - - ptheta*udotn*detwei_bdy(ggi)*income*tdensity_theta_val*ghost_tfield_ele_bdy(iloc) & - - (1.-ptheta)*udotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_face_val & - + (1.-ptheta)*(1.-beta)*divudotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_ele_bdy(iloc) + if(tdensity_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_oldtdensity_ele_bdy=ele_val(tdensity_bc, sele) ! not considering time varying bcs yet + else + if(multiphase) then + ghost_oldtdensity_ele_bdy=face_val(oldtdensity, sele)*face_val(oldvfrac, sele) else - if(assemble_advection_matrix) then - ! if iloc is the donor we can do this implicitly - mat_local_bdy(iloc) = mat_local_bdy(iloc) & - + ptheta*detwei_bdy(ggi)*udotn*(1.-income) & - - ptheta*(1.-beta)*detwei_bdy(ggi)*divudotn - end if - - ! but we can't if it's the downwind - rhs_local_bdy(iloc) = rhs_local_bdy(iloc) & - - ptheta*udotn*detwei_bdy(ggi)*income*ghost_tfield_ele_bdy(iloc) & - - (1.-ptheta)*udotn*detwei_bdy(ggi)*oldtfield_face_val & - + (1.-ptheta)*(1.-beta)*divudotn*detwei_bdy(ggi)*oldtfield_ele_bdy(iloc) + ghost_oldtdensity_ele_bdy=face_val(oldtdensity, sele) end if - end if + end if + + tdensity_ele_bdy=face_val(tdensity, sele) + oldtdensity_ele_bdy=face_val(oldtdensity, sele) + + if(multiphase) then + tdensity_ele_bdy=tdensity_ele_bdy*face_val(nvfrac, sele) + oldtdensity_ele_bdy=oldtdensity_ele_bdy*face_val(oldvfrac, sele) + end if + end if + end if + + if(assemble_diffusion) then + if (tfield_bc_type(sele)==BC_TYPE_ROBIN) then + if (.not. tfield_options%diffusionscheme == CV_DIFFUSION_ELEMENTGRADIENT) then + FLExit('Can only use CV robin BC with ElementGradient diffusion scheme') + end if + robin_bc_val1_ele_bdy = ele_val(tfield_bc, sele) + robin_bc_val2_ele_bdy = ele_val(tfield_bc2, sele) + robin_diff_mat_local_bdy = 0.0 + robin_diff_rhs_local_bdy = 0.0 + else + ghost_gradtfield_ele_bdy = ele_val(tfield_bc, sele) + end if + end if + + ! zero small matrices for assembly + grad_mat_local_bdy = 0.0 + grad_rhs_local_bdy = 0.0 + div_rhs_local_bdy = 0.0 + mat_local_bdy = 0.0 + rhs_local_bdy = 0.0 + diff_mat_local_bdy = 0.0 + + ! loop over the nodes on this surface element + surface_nodal_loop_i: do iloc = 1, tfield%mesh%faces%shape%loc + + ! loop over the faces in this surface element + surface_face_loop: do face = 1, cvfaces%sfaces + + ! is this face a neighbour of iloc? + if(cvfaces%sneiloc(iloc,face)/=0) then + + ! loop over the gauss pts on this face + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + + ! global gauss point index + ggi = (face-1)*cvfaces%shape%ngi + gi + + if(include_advection) then + + ! u.n + divudotn = dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) + if(move_mesh) then + if((tfield_bc_type(sele)==BC_TYPE_ZEROFLUX .or. tfield_bc_type(sele)==BC_TYPE_FLUX)) then + ! If we have zero flux, or a flux BC, set u.n = 0 + udotn = 0.0 + else + udotn = dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) + end if + else + if((tfield_bc_type(sele)==BC_TYPE_ZEROFLUX .or. tfield_bc_type(sele)==BC_TYPE_FLUX)) then + udotn = 0.0 + else + udotn = divudotn + end if + end if + + if(udotn>0) then + income=0.0 ! flow leaving the domain + else + income=1.0 ! flow entering the domain + end if + + ! as we're on the boundary it's not possible to use "high order" methods so just + ! default to the pivotted solution method (first order upwinding) + ! if the flow is incoming then use the bc ghost values + ! if the flow is outgoing then use the surface nodes value + + ! for tfield + tfield_face_val = income*ghost_tfield_ele_bdy(iloc) + (1.-income)*tfield_ele_bdy(iloc) + oldtfield_face_val = income*ghost_oldtfield_ele_bdy(iloc) + (1.-income)*oldtfield_ele_bdy(iloc) + + if(include_density) then + ! for tdensity + tdensity_face_val = income*ghost_tdensity_ele_bdy(iloc) + (1.-income)*tdensity_ele_bdy(iloc) + oldtdensity_face_val = income*ghost_oldtdensity_ele_bdy(iloc) + (1.-income)*oldtdensity_ele_bdy(iloc) + + tdensity_theta_val = tdensity_options%theta*tdensity_face_val + (1.-tdensity_options%theta)*oldtdensity_face_val + + if(assemble_advection_matrix) then + ! if iloc is the donor we can do this implicitly + mat_local_bdy(iloc) = mat_local_bdy(iloc) & + + ptheta*detwei_bdy(ggi)*udotn*(1.-income)*tdensity_theta_val & + - ptheta*(1.-beta)*detwei_bdy(ggi)*divudotn*tdensity_theta_val + end if + + ! but we can't if it's the downwind + rhs_local_bdy(iloc) = rhs_local_bdy(iloc) & + - ptheta*udotn*detwei_bdy(ggi)*income*tdensity_theta_val*ghost_tfield_ele_bdy(iloc) & + - (1.-ptheta)*udotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_face_val & + + (1.-ptheta)*(1.-beta)*divudotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_ele_bdy(iloc) + else + if(assemble_advection_matrix) then + ! if iloc is the donor we can do this implicitly + mat_local_bdy(iloc) = mat_local_bdy(iloc) & + + ptheta*detwei_bdy(ggi)*udotn*(1.-income) & + - ptheta*(1.-beta)*detwei_bdy(ggi)*divudotn + end if + + ! but we can't if it's the downwind + rhs_local_bdy(iloc) = rhs_local_bdy(iloc) & + - ptheta*udotn*detwei_bdy(ggi)*income*ghost_tfield_ele_bdy(iloc) & + - (1.-ptheta)*udotn*detwei_bdy(ggi)*oldtfield_face_val & + + (1.-ptheta)*(1.-beta)*divudotn*detwei_bdy(ggi)*oldtfield_ele_bdy(iloc) + end if + end if - ! If we have a flux boundary condition, then we need to set up the equation so that - ! d(field)/dt = flux_val_at_boundary - ! We add the flux_val_at_boundary contribution to rhs_local_bdy, after setting the advection - ! and diffusion terms to zero at the boundary. - if(tfield_bc_type(sele)==BC_TYPE_FLUX) then - rhs_local_bdy(iloc) = rhs_local_bdy(iloc) + detwei_bdy(ggi)*ghost_tfield_ele_bdy(iloc) - end if + ! If we have a flux boundary condition, then we need to set up the equation so that + ! d(field)/dt = flux_val_at_boundary + ! We add the flux_val_at_boundary contribution to rhs_local_bdy, after setting the advection + ! and diffusion terms to zero at the boundary. + if(tfield_bc_type(sele)==BC_TYPE_FLUX) then + rhs_local_bdy(iloc) = rhs_local_bdy(iloc) + detwei_bdy(ggi)*ghost_tfield_ele_bdy(iloc) + end if - if(assemble_diffusion) then + if(assemble_diffusion) then - select case(tfield_options%diffusionscheme) - case(CV_DIFFUSION_BASSIREBAY) + select case(tfield_options%diffusionscheme) + case(CV_DIFFUSION_BASSIREBAY) - if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then - ! assemble grad_rhs + if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then + ! assemble grad_rhs - grad_rhs_local_bdy(:, iloc) = grad_rhs_local_bdy(:,iloc) & - -detwei_bdy(ggi)*normal_bdy(:,ggi)*ghost_tfield_ele_bdy(iloc) + grad_rhs_local_bdy(:, iloc) = grad_rhs_local_bdy(:,iloc) & + -detwei_bdy(ggi)*normal_bdy(:,ggi)*ghost_tfield_ele_bdy(iloc) - ! when assembling a divergence operator you need this: - ! (but not when its a gradient transposed operator) - dimension_loop2: do dim = 1, mesh_dim(tfield) - ! assemble matrix - grad_mat_local_bdy(dim, iloc) = grad_mat_local_bdy(dim, iloc) & - +detwei_bdy(ggi)*normal_bdy(dim,ggi) - end do dimension_loop2 + ! when assembling a divergence operator you need this: + ! (but not when its a gradient transposed operator) + dimension_loop2: do dim = 1, mesh_dim(tfield) + ! assemble matrix + grad_mat_local_bdy(dim, iloc) = grad_mat_local_bdy(dim, iloc) & + +detwei_bdy(ggi)*normal_bdy(dim,ggi) + end do dimension_loop2 - else + else - if(tfield_bc_type(sele)==BC_TYPE_NEUMANN) then + if(tfield_bc_type(sele)==BC_TYPE_NEUMANN) then - ! assemble div_rhs - div_rhs_local_bdy(iloc) = div_rhs_local_bdy(iloc) & + ! assemble div_rhs + div_rhs_local_bdy(iloc) = div_rhs_local_bdy(iloc) & -detwei_bdy(ggi)*ghost_gradtfield_ele_bdy(iloc) - end if + end if - ! when assembling a gradient transposed operator you need this: - ! (but not when its a divergence operator) - ! dimension_loop2: do dim = 1, mesh_dim(tfield) - ! grad_mat_local_bdy(dim, iloc) = grad_mat_local_bdy(dim, iloc) & - ! -detwei_bdy(ggi)*normal_bdy(dim,ggi) - ! end do dimension_loop2 + ! when assembling a gradient transposed operator you need this: + ! (but not when its a divergence operator) + ! dimension_loop2: do dim = 1, mesh_dim(tfield) + ! grad_mat_local_bdy(dim, iloc) = grad_mat_local_bdy(dim, iloc) & + ! -detwei_bdy(ggi)*normal_bdy(dim,ggi) + ! end do dimension_loop2 - end if + end if - case(CV_DIFFUSION_ELEMENTGRADIENT) + case(CV_DIFFUSION_ELEMENTGRADIENT) - if(tfield_bc_type(sele)==BC_TYPE_NEUMANN) then + if(tfield_bc_type(sele)==BC_TYPE_NEUMANN) then - div_rhs_local_bdy(iloc) = div_rhs_local_bdy(iloc) & - -detwei_bdy(ggi)*ghost_gradtfield_ele_bdy(iloc) + div_rhs_local_bdy(iloc) = div_rhs_local_bdy(iloc) & + -detwei_bdy(ggi)*ghost_gradtfield_ele_bdy(iloc) - else if (tfield_bc_type(sele)==BC_TYPE_ROBIN) then + else if (tfield_bc_type(sele)==BC_TYPE_ROBIN) then - ! Add first coeff term to rhs - robin_diff_rhs_local_bdy(iloc) = robin_diff_rhs_local_bdy(iloc) - & - detwei_bdy(ggi) * & - robin_bc_val1_ele_bdy(iloc) + ! Add first coeff term to rhs + robin_diff_rhs_local_bdy(iloc) = robin_diff_rhs_local_bdy(iloc) - & + detwei_bdy(ggi) * & + robin_bc_val1_ele_bdy(iloc) - ! Add implicit second coeff * tfield term to matrix - robin_diff_mat_local_bdy(iloc) = robin_diff_mat_local_bdy(iloc) + & - detwei_bdy(ggi) * & - robin_bc_val2_ele_bdy(iloc) + ! Add implicit second coeff * tfield term to matrix + robin_diff_mat_local_bdy(iloc) = robin_diff_mat_local_bdy(iloc) + & + detwei_bdy(ggi) * & + robin_bc_val2_ele_bdy(iloc) - else + else - ! because transform to physical doesn't give the full gradient at a face - ! yet this can't be done so we're going to have to assume zero neumann - ! at outflow faces - ! do dloc= 1,tfield%mesh%faces%shape%loc - ! - ! ! n_i K_{ij} dT/dx_j - ! diff_mat_local_bdy(iloc, dloc) = diff_mat_local_bdy(iloc,dloc) + & - ! sum(matmul(diffusivity_gi_f(:,:,ggi), dt_ft(dloc, ggi, :))*normal_bdy(:,ggi), 1)& - ! *detwei_bdy(ggi) - ! - ! end do + ! because transform to physical doesn't give the full gradient at a face + ! yet this can't be done so we're going to have to assume zero neumann + ! at outflow faces + ! do dloc= 1,tfield%mesh%faces%shape%loc + ! + ! ! n_i K_{ij} dT/dx_j + ! diff_mat_local_bdy(iloc, dloc) = diff_mat_local_bdy(iloc,dloc) + & + ! sum(matmul(diffusivity_gi_f(:,:,ggi), dt_ft(dloc, ggi, :))*normal_bdy(:,ggi), 1)& + ! *detwei_bdy(ggi) + ! + ! end do - end if + end if - end select + end select - end if + end if - end do surface_quadrature_loop + end do surface_quadrature_loop - end if ! sneiloc + end if ! sneiloc - end do surface_face_loop + end do surface_face_loop - end do surface_nodal_loop_i + end do surface_nodal_loop_i - ! assemble matrix - if(assemble_advection_matrix) then - call addto_diag(A_m, nodes_bdy, mat_local_bdy) - end if + ! assemble matrix + if(assemble_advection_matrix) then + call addto_diag(A_m, nodes_bdy, mat_local_bdy) + end if - if(assemble_diffusion) then - select case(tfield_options%diffusionscheme) - case(CV_DIFFUSION_BASSIREBAY) + if(assemble_diffusion) then + select case(tfield_options%diffusionscheme) + case(CV_DIFFUSION_BASSIREBAY) - do dim = 1, mesh_dim(tfield) - do iloc = 1, size(grad_mat_local_bdy,2) - call addto(div_m, 1, dim, nodes_bdy(iloc), diffusivity_lglno_bdy(iloc), & - grad_mat_local_bdy(dim,iloc)) - end do - end do - call addto(grad_rhs, diffusivity_lglno_bdy, grad_rhs_local_bdy) + do dim = 1, mesh_dim(tfield) + do iloc = 1, size(grad_mat_local_bdy,2) + call addto(div_m, 1, dim, nodes_bdy(iloc), diffusivity_lglno_bdy(iloc), & + grad_mat_local_bdy(dim,iloc)) + end do + end do + call addto(grad_rhs, diffusivity_lglno_bdy, grad_rhs_local_bdy) - call addto(diff_rhs, nodes_bdy, div_rhs_local_bdy) + call addto(diff_rhs, nodes_bdy, div_rhs_local_bdy) - case(CV_DIFFUSION_ELEMENTGRADIENT) + case(CV_DIFFUSION_ELEMENTGRADIENT) - if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then + if(tfield_bc_type(sele)==BC_TYPE_WEAKDIRICHLET) then - ! assume zero neumann for the moment - ! call addto(diff_rhs, nodes_bdy, -matmul(diff_mat_local_bdy, ghost_gradtfield_ele_bdy)) + ! assume zero neumann for the moment + ! call addto(diff_rhs, nodes_bdy, -matmul(diff_mat_local_bdy, ghost_gradtfield_ele_bdy)) - elseif(tfield_bc_type(sele)==BC_TYPE_NEUMANN) then + elseif(tfield_bc_type(sele)==BC_TYPE_NEUMANN) then - call addto(diff_rhs, nodes_bdy, div_rhs_local_bdy) + call addto(diff_rhs, nodes_bdy, div_rhs_local_bdy) - else if (tfield_bc_type(sele)==BC_TYPE_ROBIN) then + else if (tfield_bc_type(sele)==BC_TYPE_ROBIN) then - call addto(diff_rhs, nodes_bdy, robin_diff_rhs_local_bdy) + call addto(diff_rhs, nodes_bdy, robin_diff_rhs_local_bdy) - call addto_diag(D_m, nodes_bdy, robin_diff_mat_local_bdy) + call addto_diag(D_m, nodes_bdy, robin_diff_mat_local_bdy) - else + else - ! assume zero neumann for the moment - ! call addto(D_m, nodes_bdy, nodes_bdy, diff_mat_local_bdy) + ! assume zero neumann for the moment + ! call addto(D_m, nodes_bdy, nodes_bdy, diff_mat_local_bdy) - end if + end if - end select - end if + end select + end if - ! assemble RHS - this contains the advection boundary terms, or - ! a RHS term from the flux boundary condition, so that - ! we have the equation in the form d(field)/dt = flux_val - if(include_advection .or. tfield_bc_type(sele)==BC_TYPE_FLUX) then - call addto(rhs, nodes_bdy, rhs_local_bdy) - end if + ! assemble RHS - this contains the advection boundary terms, or + ! a RHS term from the flux boundary condition, so that + ! we have the equation in the form d(field)/dt = flux_val + if(include_advection .or. tfield_bc_type(sele)==BC_TYPE_FLUX) then + call addto(rhs, nodes_bdy, rhs_local_bdy) + end if end do surface_element_loop if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then - ! assemble div_m and q_cvmass into the final D_m - call assemble_bassirebay_diffusion_m_cv(D_m, diff_rhs, & - div_m, grad_rhs, & - diffusivity, q_cvmass) - ! ElementGradient assembles D_m directly so no need for a step like this + ! assemble div_m and q_cvmass into the final D_m + call assemble_bassirebay_diffusion_m_cv(D_m, diff_rhs, & + div_m, grad_rhs, & + diffusivity, q_cvmass) + ! ElementGradient assembles D_m directly so no need for a step like this end if @@ -2205,25 +2205,25 @@ subroutine assemble_advectiondiffusion_m_cv(A_m, rhs, D_m, diff_rhs, & call deallocate(tfield_upwind) call deallocate(oldtfield_upwind) if(include_density) then - deallocate(tdensity_bc_type) - call deallocate(tdensity_bc) + deallocate(tdensity_bc_type) + call deallocate(tdensity_bc) - call deallocate(tdensity_upwind) - call deallocate(oldtdensity_upwind) + call deallocate(tdensity_upwind) + call deallocate(oldtdensity_upwind) end if if(assemble_diffusion.and.(tfield_options%diffusionscheme==CV_DIFFUSION_BASSIREBAY)) then - call deallocate(div_m) - call deallocate(grad_rhs) + call deallocate(div_m) + call deallocate(grad_rhs) end if ewrite(1, *) "Exiting assemble_advectiondiffusion_m_cv" - end subroutine assemble_advectiondiffusion_m_cv + end subroutine assemble_advectiondiffusion_m_cv - subroutine assemble_bassirebay_diffusion_m_cv(D_m, diff_rhs, & - div_m, grad_rhs, & - diffusivity, q_cvmass) + subroutine assemble_bassirebay_diffusion_m_cv(D_m, diff_rhs, & + div_m, grad_rhs, & + diffusivity, q_cvmass) type(csr_matrix), intent(inout) :: D_m type(scalar_field), intent(inout) :: diff_rhs @@ -2242,18 +2242,18 @@ subroutine assemble_bassirebay_diffusion_m_cv(D_m, diff_rhs, & isotropic=isotropic_field(diffusivity) call mult_div_tensorinvscalar_div_T(D_m, div_m, diffusivity, q_cvmass, div_m, & - isotropic) + isotropic) call mult_div_tensorinvscalar_vector(diff_rhs, div_m, diffusivity, q_cvmass, grad_rhs, & - isotropic) + isotropic) - end subroutine assemble_bassirebay_diffusion_m_cv - !************************************************************************ + end subroutine assemble_bassirebay_diffusion_m_cv + !************************************************************************ - !************************************************************************ - ! subroutines dealing coupled control volume advection - ! coupled wrapper - subroutine coupled_cv_field_eqn(state, global_it) + !************************************************************************ + ! subroutines dealing coupled control volume advection + ! coupled wrapper + subroutine coupled_cv_field_eqn(state, global_it) !!< This subroutine wraps the solve for groups of interdependent coupled fields. !! bucket full of fields from all materials @@ -2287,46 +2287,46 @@ subroutine coupled_cv_field_eqn(state, global_it) nfield_groups = 0 do i = 1, size(state) - do f = 1, scalar_field_count(state(i)) + do f = 1, scalar_field_count(state(i)) - sfield => extract_scalar_field(state(i), f) - if(have_option(trim(sfield%option_path)//"/prognostic/spatial_discretisation/coupled_cv")) then + sfield => extract_scalar_field(state(i), f) + if(have_option(trim(sfield%option_path)//"/prognostic/spatial_discretisation/coupled_cv")) then - name_check_loop: do c = 1, nfields - if(trim(sfield%name)==trim(field_name_list(c))) exit name_check_loop - end do name_check_loop + name_check_loop: do c = 1, nfields + if(trim(sfield%name)==trim(field_name_list(c))) exit name_check_loop + end do name_check_loop - if(c>nfields) then - ! not yet in the list so add it - nfield_groups = nfield_groups + 1 - field_name_list(nfield_groups) = trim(sfield%name) - field_numbers(nfield_groups) = 1 - else - ! found in list, increment number of fields - assert(c<=nfield_groups) - field_numbers(c) = field_numbers(c) + 1 - end if + if(c>nfields) then + ! not yet in the list so add it + nfield_groups = nfield_groups + 1 + field_name_list(nfield_groups) = trim(sfield%name) + field_numbers(nfield_groups) = 1 + else + ! found in list, increment number of fields + assert(c<=nfield_groups) + field_numbers(c) = field_numbers(c) + 1 + end if - end if + end if - end do + end do end do ewrite(2,*) 'nfield_groups = ', nfield_groups do i = 1, nfield_groups - assert(field_numbers(i)>0) - call solve_coupled_cv(trim(field_name_list(i)), field_numbers(i), state, global_it) + assert(field_numbers(i)>0) + call solve_coupled_cv(trim(field_name_list(i)), field_numbers(i), state, global_it) end do deallocate(field_name_list) deallocate(field_numbers) - end subroutine coupled_cv_field_eqn + end subroutine coupled_cv_field_eqn - ! coupled solution: - subroutine solve_coupled_cv(field_name, nfields, state, global_it) + ! coupled solution: + subroutine solve_coupled_cv(field_name, nfields, state, global_it) !!< Construct and solve the advection equation for the given !!< field using coupled (i.e. interdependent face values) control volumes. @@ -2429,13 +2429,13 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) tmp_state_indices = 0 priorities = 0 do i = 1, size(state) - tmpfield=>extract_scalar_field(state(i), trim(field_name)) + tmpfield=>extract_scalar_field(state(i), trim(field_name)) - if(have_option(trim(tmpfield%option_path)//"/prognostic/spatial_discretisation/coupled_cv")) then - f = f + 1 - call get_option(trim(tmpfield%option_path)//"/prognostic/priority", priorities(f)) - tmp_state_indices(f) = i - end if + if(have_option(trim(tmpfield%option_path)//"/prognostic/spatial_discretisation/coupled_cv")) then + f = f + 1 + call get_option(trim(tmpfield%option_path)//"/prognostic/priority", priorities(f)) + tmp_state_indices(f) = i + end if end do assert(f==nfields) @@ -2444,12 +2444,12 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) f = 0 state_indices = 0 do p = maxval(priorities), minval(priorities), -1 - do i=1, nfields - if(priorities(i)==p) then - f = f + 1 - state_indices(f) = tmp_state_indices(i) - end if - end do + do i=1, nfields + if(priorities(i)==p) then + f = f + 1 + state_indices(f) = tmp_state_indices(i) + end if + end do end do assert(f==nfields) @@ -2474,93 +2474,93 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) ! now extract everything in the right order do f = 1, nfields - ewrite(2,*) 'extracting '//trim(field_name)//' from state '//trim(state(state_indices(f))%name) - ! the field we want to solve for - tfield(f)%ptr => extract_scalar_field(state(state_indices(f)), trim(field_name)) - ! its option path - option_path(f)=tfield(f)%ptr%option_path - ! its previous timelevel - oldtfield(f)%ptr=>extract_scalar_field(state(state_indices(f)), "Old"//trim(field_name)) - ! because fluidity resets tfield to oldtfield at the start of every - ! global iteration we need to undo this so that the control volume faces - ! are discretised using the most up to date values - ! therefore extract the iterated values: - it_tfield=>extract_scalar_field(state(state_indices(f)), "Iterated"//trim(field_name)) - ! and set tfield to them: - call set(tfield(f)%ptr, it_tfield) - - include_density = .false. - ! find out equation type and hence if density is needed or not - equation_type=equation_type_index(trim(option_path(f))) - select case(equation_type) - case(FIELD_EQUATION_ADVECTIONDIFFUSION) - ! density not needed so use a constant field for assembly - tdensity(f)%ptr=>dummydensity - oldtdensity(f)%ptr=>dummydensity - case(FIELD_EQUATION_CONSERVATIONOFMASS, FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS, & - FIELD_EQUATION_INTERNALENERGY, FIELD_EQUATION_HEATTRANSFER ) - call get_option(trim(option_path(f))//'/prognostic/equation[0]/density[0]/name', & - tmpstring) - include_density = .true. - ! density needed so extract the type specified in the input - ! ?? are there circumstances where this should be "Iterated"... need to be - ! careful with priority ordering - tdensity(f)%ptr=>extract_scalar_field(state(state_indices(f)), trim(tmpstring)) - ! halo exchange? - not currently necessary when suboptimal halo exchange if density - ! is solved for with this subroutine and the correct priority ordering. - oldtdensity(f)%ptr=>extract_scalar_field(state(state_indices(f)), "Old"//trim(tmpstring)) - end select - - ! get the tdensity discretisation options from: - ! 1) the user specified options for the coefficient of this field - ! 2) the options underneath the density field itself if it is prognostic and cv - ! 3) throw an error as otherwise it would default to poorly defined options - if(include_density) then - if(have_option(trim(option_path(f))//'/prognostic/equation[0]/density[0]/discretisation_options')) then - tdensity_option_path(f) = trim(option_path(f))//'/prognostic/equation[0]/density[0]/discretisation_options' - else - if(have_option(trim(tdensity(f)%ptr%option_path)//"/prognostic/spatial_discretisation/control_volumes")) then - tdensity_option_path(f) = trim(tdensity(f)%ptr%option_path) + ewrite(2,*) 'extracting '//trim(field_name)//' from state '//trim(state(state_indices(f))%name) + ! the field we want to solve for + tfield(f)%ptr => extract_scalar_field(state(state_indices(f)), trim(field_name)) + ! its option path + option_path(f)=tfield(f)%ptr%option_path + ! its previous timelevel + oldtfield(f)%ptr=>extract_scalar_field(state(state_indices(f)), "Old"//trim(field_name)) + ! because fluidity resets tfield to oldtfield at the start of every + ! global iteration we need to undo this so that the control volume faces + ! are discretised using the most up to date values + ! therefore extract the iterated values: + it_tfield=>extract_scalar_field(state(state_indices(f)), "Iterated"//trim(field_name)) + ! and set tfield to them: + call set(tfield(f)%ptr, it_tfield) + + include_density = .false. + ! find out equation type and hence if density is needed or not + equation_type=equation_type_index(trim(option_path(f))) + select case(equation_type) + case(FIELD_EQUATION_ADVECTIONDIFFUSION) + ! density not needed so use a constant field for assembly + tdensity(f)%ptr=>dummydensity + oldtdensity(f)%ptr=>dummydensity + case(FIELD_EQUATION_CONSERVATIONOFMASS, FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS, & + FIELD_EQUATION_INTERNALENERGY, FIELD_EQUATION_HEATTRANSFER ) + call get_option(trim(option_path(f))//'/prognostic/equation[0]/density[0]/name', & + tmpstring) + include_density = .true. + ! density needed so extract the type specified in the input + ! ?? are there circumstances where this should be "Iterated"... need to be + ! careful with priority ordering + tdensity(f)%ptr=>extract_scalar_field(state(state_indices(f)), trim(tmpstring)) + ! halo exchange? - not currently necessary when suboptimal halo exchange if density + ! is solved for with this subroutine and the correct priority ordering. + oldtdensity(f)%ptr=>extract_scalar_field(state(state_indices(f)), "Old"//trim(tmpstring)) + end select + + ! get the tdensity discretisation options from: + ! 1) the user specified options for the coefficient of this field + ! 2) the options underneath the density field itself if it is prognostic and cv + ! 3) throw an error as otherwise it would default to poorly defined options + if(include_density) then + if(have_option(trim(option_path(f))//'/prognostic/equation[0]/density[0]/discretisation_options')) then + tdensity_option_path(f) = trim(option_path(f))//'/prognostic/equation[0]/density[0]/discretisation_options' else - FLExit("Additional discretisation options required for the density coefficient. Please set equation/density/discretisation_options.") + if(have_option(trim(tdensity(f)%ptr%option_path)//"/prognostic/spatial_discretisation/control_volumes")) then + tdensity_option_path(f) = trim(tdensity(f)%ptr%option_path) + else + FLExit("Additional discretisation options required for the density coefficient. Please set equation/density/discretisation_options.") + end if end if - end if - else - tdensity_option_path(f) = "" - end if - - ! now we can get the options for these fields - ! handily wrapped in a new type... - tfield_options(f)=get_cv_options(tfield(f)%ptr%option_path, tfield(f)%ptr%mesh%shape%numbering%family, mesh_dim(tfield(f)%ptr)) - if(include_density) then - tdensity_options(f)=get_cv_options(tdensity_option_path(f), tdensity(f)%ptr%mesh%shape%numbering%family, mesh_dim(tdensity(f)%ptr), coefficient_field=.true.) - else - tdensity_options(f)=tfield_options(f) ! dummy so we don't leave variables undefined but shouldn't get used - end if - - source(f)%ptr=>extract_scalar_field(state(state_indices(f)), trim(field_name)//"Source", stat=stat) - if(stat==0) then - FLExit("Coupled CV broken with Sources") - ! If Coupled CV is ever fixed to work with Sources then the - ! option source(f)%option_path//'/diagnostic/add_directly_to_rhs' - ! should be accounted for. - end if - if(stat/=0) source(f)%ptr=>dummyscalar - absorption(f)%ptr=>extract_scalar_field(state(state_indices(f)), trim(field_name)//"Absorption", stat=stat) - if(stat==0) then - FLExit("Coupled CV broken with Absorptions") - end if - if(stat/=0) absorption(f)%ptr=>dummyscalar - - ! is this explicit? - explicit(f)=have_option(trim(option_path(f))//"/prognostic/explicit") + else + tdensity_option_path(f) = "" + end if + + ! now we can get the options for these fields + ! handily wrapped in a new type... + tfield_options(f)=get_cv_options(tfield(f)%ptr%option_path, tfield(f)%ptr%mesh%shape%numbering%family, mesh_dim(tfield(f)%ptr)) + if(include_density) then + tdensity_options(f)=get_cv_options(tdensity_option_path(f), tdensity(f)%ptr%mesh%shape%numbering%family, mesh_dim(tdensity(f)%ptr), coefficient_field=.true.) + else + tdensity_options(f)=tfield_options(f) ! dummy so we don't leave variables undefined but shouldn't get used + end if + + source(f)%ptr=>extract_scalar_field(state(state_indices(f)), trim(field_name)//"Source", stat=stat) + if(stat==0) then + FLExit("Coupled CV broken with Sources") + ! If Coupled CV is ever fixed to work with Sources then the + ! option source(f)%option_path//'/diagnostic/add_directly_to_rhs' + ! should be accounted for. + end if + if(stat/=0) source(f)%ptr=>dummyscalar + absorption(f)%ptr=>extract_scalar_field(state(state_indices(f)), trim(field_name)//"Absorption", stat=stat) + if(stat==0) then + FLExit("Coupled CV broken with Absorptions") + end if + if(stat/=0) absorption(f)%ptr=>dummyscalar + + ! is this explicit? + explicit(f)=have_option(trim(option_path(f))//"/prognostic/explicit") end do ! we assume that all fields are on the same mesh as for the method to the work the faces must intersect! do f = 2, nfields - assert(tfield(f)%ptr%mesh%shape%degree==tfield(1)%ptr%mesh%shape%degree) - assert(all(tfield(f)%ptr%mesh%ndglno==tfield(1)%ptr%mesh%ndglno)) + assert(tfield(f)%ptr%mesh%shape%degree==tfield(1)%ptr%mesh%shape%degree) + assert(all(tfield(f)%ptr%mesh%ndglno==tfield(1)%ptr%mesh%ndglno)) end do ! for now we assume as this is a effectively a multimaterial problem @@ -2577,11 +2577,11 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) ! create control volume shape functions call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + quaddegree, default=1) cvfaces=find_cv_faces(vertices=ele_vertices(tfield(1)%ptr, 1), & - dimension=mesh_dim(tfield(1)%ptr), & - polydegree=element_degree(tfield(1)%ptr, 1), & - quaddegree=quaddegree) + dimension=mesh_dim(tfield(1)%ptr), & + polydegree=element_degree(tfield(1)%ptr, 1), & + quaddegree=quaddegree) u_cvshape=make_cv_element_shape(cvfaces, nu%mesh%shape) x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) t_cvshape=make_cv_element_shape(cvfaces, tfield(1)%ptr%mesh%shape) @@ -2594,39 +2594,39 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) ! allocate and retrieve the cfl no. if necessary call cv_disc_get_cfl_no(option_path, & - state(state_indices(1)), tfield(1)%ptr%mesh, cfl_no, & - tdensity_option_path) + state(state_indices(1)), tfield(1)%ptr%mesh, cfl_no, & + tdensity_option_path) ! get the mesh sparsity for the matrices mesh_sparsity => get_csr_sparsity_firstorder(state, tfield(1)%ptr%mesh, tfield(1)%ptr%mesh) if(mesh_periodic(tfield(1)%ptr)) then - if((tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& - (tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then - mesh_sparsity_x => get_csr_sparsity_firstorder(state, x_tfield%mesh, x_tfield%mesh) - else - mesh_sparsity_x => mesh_sparsity - end if + if((tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& + (tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then + mesh_sparsity_x => get_csr_sparsity_firstorder(state, x_tfield%mesh, x_tfield%mesh) + else + mesh_sparsity_x => mesh_sparsity + end if else - mesh_sparsity_x => mesh_sparsity + mesh_sparsity_x => mesh_sparsity end if do f = 1, nfields - ! allocate the lhs matrix - if(.not.explicit(f)) then - call allocate(M(f), mesh_sparsity, name=trim(field_name)//"Matrix") - call zero(M(f)) - - ! allocate the advection matrix - call allocate(A_m(f), mesh_sparsity, name=trim(field_name)//int2str(f)//"AdvectionMatrix") - call zero(A_m(f)) - else - call allocate(cvmass(f), tfield(1)%ptr%mesh, name=trim(field_name)//"LocalCVMass") - call zero(cvmass(f)) - end if - - ! allocate the rhs of the equation - call allocate(rhs(f), tfield(f)%ptr%mesh, name=trim(field_name)//int2str(f)//"RHS") + ! allocate the lhs matrix + if(.not.explicit(f)) then + call allocate(M(f), mesh_sparsity, name=trim(field_name)//"Matrix") + call zero(M(f)) + + ! allocate the advection matrix + call allocate(A_m(f), mesh_sparsity, name=trim(field_name)//int2str(f)//"AdvectionMatrix") + call zero(A_m(f)) + else + call allocate(cvmass(f), tfield(1)%ptr%mesh, name=trim(field_name)//"LocalCVMass") + call zero(cvmass(f)) + end if + + ! allocate the rhs of the equation + call allocate(rhs(f), tfield(f)%ptr%mesh, name=trim(field_name)//int2str(f)//"RHS") end do ! find the cv mass that is used for the absorption and source terms @@ -2641,50 +2641,50 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) move_mesh = have_option("/mesh_adaptivity/mesh_movement") if(move_mesh) then - if(.not.include_advection) then - FLExit("Moving the mesh but not including advection is not possible yet.") - end if - ewrite(2,*) "Moving mesh." - x_old=>extract_vector_field(state(1), "OldCoordinate") - x_new=>extract_vector_field(state(1), "IteratedCoordinate") - call allocate(t_cvmass_old, tfield(1)%ptr%mesh, name=trim(field_name)//"OldCVMass") - call allocate(t_cvmass_new, tfield(1)%ptr%mesh, name=trim(field_name)//"NewCVMass") - - call compute_cv_mass(x_old, t_cvmass_old) - call compute_cv_mass(x_new, t_cvmass_new) - ewrite_minmax(t_cvmass_old) - ewrite_minmax(t_cvmass_new) - - ug=>extract_vector_field(state(1), "GridVelocity") - ewrite_minmax(ug) - - ug_cvshape=make_cv_element_shape(cvfaces, ug%mesh%shape) - ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) + if(.not.include_advection) then + FLExit("Moving the mesh but not including advection is not possible yet.") + end if + ewrite(2,*) "Moving mesh." + x_old=>extract_vector_field(state(1), "OldCoordinate") + x_new=>extract_vector_field(state(1), "IteratedCoordinate") + call allocate(t_cvmass_old, tfield(1)%ptr%mesh, name=trim(field_name)//"OldCVMass") + call allocate(t_cvmass_new, tfield(1)%ptr%mesh, name=trim(field_name)//"NewCVMass") + + call compute_cv_mass(x_old, t_cvmass_old) + call compute_cv_mass(x_new, t_cvmass_new) + ewrite_minmax(t_cvmass_old) + ewrite_minmax(t_cvmass_new) + + ug=>extract_vector_field(state(1), "GridVelocity") + ewrite_minmax(ug) + + ug_cvshape=make_cv_element_shape(cvfaces, ug%mesh%shape) + ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) else - ewrite(2,*) "Not moving mesh." - ug_cvshape=u_cvshape - ug_cvbdyshape=u_cvbdyshape - call incref(ug_cvshape) - call incref(ug_cvbdyshape) + ewrite(2,*) "Not moving mesh." + ug_cvshape=u_cvshape + ug_cvbdyshape=u_cvbdyshape + call incref(ug_cvshape) + call incref(ug_cvbdyshape) end if do f = 1, nfields - ! allocate a field to store the locally iterated values in - call allocate(advit_tfield(f), tfield(f)%ptr%mesh, name="AdvIterated"//int2str(f)//trim(field_name)) - ! allocate a field to use as the local old field for subcycling - allocate(l_old_tfield(f)%ptr) - call allocate(l_old_tfield(f)%ptr, tfield(f)%ptr%mesh, name="LocalOld"//int2str(f)//trim(field_name)) - ! when subcycling we're going to need to be starting each subcycle from the - ! "new" old value but I don't want to screw with old code by updating the actual - ! global timestep old value so lets create a copy now and update it instead - call set(l_old_tfield(f)%ptr, oldtfield(f)%ptr) - - ! allocate a field to store the change between the old and new values - call allocate(delta_tfield(f), tfield(f)%ptr%mesh, name="Delta_"//int2str(f)//trim(field_name)) - call zero(delta_tfield(f)) ! Impose zero initial guess. - ! Ensure delta_tfield inherits options from tfield for solver - delta_tfield(f)%option_path = option_path(f) + ! allocate a field to store the locally iterated values in + call allocate(advit_tfield(f), tfield(f)%ptr%mesh, name="AdvIterated"//int2str(f)//trim(field_name)) + ! allocate a field to use as the local old field for subcycling + allocate(l_old_tfield(f)%ptr) + call allocate(l_old_tfield(f)%ptr, tfield(f)%ptr%mesh, name="LocalOld"//int2str(f)//trim(field_name)) + ! when subcycling we're going to need to be starting each subcycle from the + ! "new" old value but I don't want to screw with old code by updating the actual + ! global timestep old value so lets create a copy now and update it instead + call set(l_old_tfield(f)%ptr, oldtfield(f)%ptr) + + ! allocate a field to store the change between the old and new values + call allocate(delta_tfield(f), tfield(f)%ptr%mesh, name="Delta_"//int2str(f)//trim(field_name)) + call zero(delta_tfield(f)) ! Impose zero initial guess. + ! Ensure delta_tfield inherits options from tfield for solver + delta_tfield(f)%option_path = option_path(f) end do adv_iterations = 1 @@ -2693,18 +2693,18 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) cfl_sub_stat = 1 sub_dt=dt ! just in case I don't initialise this somehow do f = 1, nfields - ! find out how many iterations we'll be doing - call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& - &/control_volumes/number_advection_iterations", & - adv_iterations(f), default=1) + ! find out how many iterations we'll be doing + call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& + &/control_volumes/number_advection_iterations", & + adv_iterations(f), default=1) - call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& - &/control_volumes/number_advection_iterations/tolerance", & - adv_tolerance(f), default=0.0) + call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& + &/control_volumes/number_advection_iterations/tolerance", & + adv_tolerance(f), default=0.0) - call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& - &/control_volumes/number_advection_subcycles", & - no_subcycles(f), stat=cfl_sub_stat(f)) + call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& + &/control_volumes/number_advection_subcycles", & + no_subcycles(f), stat=cfl_sub_stat(f)) end do assert(all(adv_iterations==adv_iterations(1))) @@ -2716,124 +2716,124 @@ subroutine solve_coupled_cv(field_name, nfields, state, global_it) cfl_sub_stat = 1 max_sub_cfl=0.0 if(stat/=0) then - ! have not specified a number of subcycles but perhaps we're using a - ! courant number definition? - do f = 1, nfields - call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& - &/control_volumes/maximum_courant_number_per_subcycle", & - max_sub_cfl(f), stat=cfl_sub_stat(f)) - end do - assert(all(max_sub_cfl==max_sub_cfl(1))) - assert(all(cfl_sub_stat==cfl_sub_stat(1))) - if(cfl_sub_stat(1)==0) then - max_cfl = maxval(cfl_no%val) - call allmax(max_cfl) - ! yes, we're subcycling - ! we should have already calculated the courant number (or aborted in the attempt) - no_subcycles=ceiling(max_cfl/max_sub_cfl(1)) - if(no_subcycles(1)>1) then + ! have not specified a number of subcycles but perhaps we're using a + ! courant number definition? + do f = 1, nfields + call get_option(trim(option_path(f))//"/prognostic/temporal_discretisation& + &/control_volumes/maximum_courant_number_per_subcycle", & + max_sub_cfl(f), stat=cfl_sub_stat(f)) + end do + assert(all(max_sub_cfl==max_sub_cfl(1))) + assert(all(cfl_sub_stat==cfl_sub_stat(1))) + if(cfl_sub_stat(1)==0) then + max_cfl = maxval(cfl_no%val) + call allmax(max_cfl) + ! yes, we're subcycling + ! we should have already calculated the courant number (or aborted in the attempt) + no_subcycles=ceiling(max_cfl/max_sub_cfl(1)) + if(no_subcycles(1)>1) then + sub_dt=dt/real(no_subcycles(1)) + call scale(cfl_no, 1.0/real(no_subcycles(1))) + end if + else + ! no, we're not subcycling + no_subcycles=1 + sub_dt = dt + end if + else + if(no_subcycles(1)>1) then sub_dt=dt/real(no_subcycles(1)) call scale(cfl_no, 1.0/real(no_subcycles(1))) - end if - else - ! no, we're not subcycling - no_subcycles=1 - sub_dt = dt - end if - else - if(no_subcycles(1)>1) then - sub_dt=dt/real(no_subcycles(1)) - call scale(cfl_no, 1.0/real(no_subcycles(1))) - end if + end if end if ewrite(2,*) 'entering subcycling_loop', no_subcycles(1) ! subcycling loop subcycling_loop: do sub = 1, no_subcycles(1) - ! advection iteration loop - advection_iteration_loop: do adv_it = 1, adv_iterations(1) - - do f = 1, nfields - getmat(f)=(adv_it==1).and.(sub==1).and.(.not.explicit(f)).and.include_advection - - ! record the value of tfield since the previous iteration - call set(advit_tfield(f), tfield(f)%ptr) - end do - - ! assemble A_m and rhs - call assemble_coupled_advection_m_cv(A_m, rhs, & - tfield, l_old_tfield, tfield_options, & - tdensity, oldtdensity, tdensity_options, & - cvfaces, x_cvshape, x_cvbdyshape, & - u_cvshape, u_cvbdyshape, t_cvshape, & - ug_cvshape, ug_cvbdyshape, & - state, advu, ug, x, x_tfield, cfl_no, & - getmat, sub_dt, & - mesh_sparsity_x) - - do f = 1, nfields + ! advection iteration loop + advection_iteration_loop: do adv_it = 1, adv_iterations(1) - ! assemble it all into a coherent equation - call assemble_field_eqn_cv(M(f), A_m(f), cvmass(f), rhs(f), & - tfield(f)%ptr, l_old_tfield(f)%ptr, & - tdensity(f)%ptr, oldtdensity(f)%ptr, tdensity_options(f), & - source(f)%ptr, absorption(f)%ptr, tfield_options(f)%theta, & - state(state_indices(f):state_indices(f)), advu, sub_dt, explicit(f), & - t_cvmass(f)%ptr, t_abs_src_cvmass, t_cvmass_old, t_cvmass_new) + do f = 1, nfields + getmat(f)=(adv_it==1).and.(sub==1).and.(.not.explicit(f)).and.include_advection - ! Solve for the change in tfield. - if(explicit(f)) then - call apply_dirichlet_conditions(cvmass(f), rhs(f), tfield(f)%ptr, sub_dt) + ! record the value of tfield since the previous iteration + call set(advit_tfield(f), tfield(f)%ptr) + end do - delta_tfield(f)%val = rhs(f)%val/cvmass(f)%val - else - ! apply strong dirichlet boundary conditions (if any) - ! note that weak conditions (known as control volume boundary conditions) - ! will already have been applied - call apply_dirichlet_conditions(M(f), rhs(f), tfield(f)%ptr, sub_dt) + ! assemble A_m and rhs + call assemble_coupled_advection_m_cv(A_m, rhs, & + tfield, l_old_tfield, tfield_options, & + tdensity, oldtdensity, tdensity_options, & + cvfaces, x_cvshape, x_cvbdyshape, & + u_cvshape, u_cvbdyshape, t_cvshape, & + ug_cvshape, ug_cvbdyshape, & + state, advu, ug, x, x_tfield, cfl_no, & + getmat, sub_dt, & + mesh_sparsity_x) + + do f = 1, nfields + + ! assemble it all into a coherent equation + call assemble_field_eqn_cv(M(f), A_m(f), cvmass(f), rhs(f), & + tfield(f)%ptr, l_old_tfield(f)%ptr, & + tdensity(f)%ptr, oldtdensity(f)%ptr, tdensity_options(f), & + source(f)%ptr, absorption(f)%ptr, tfield_options(f)%theta, & + state(state_indices(f):state_indices(f)), advu, sub_dt, explicit(f), & + t_cvmass(f)%ptr, t_abs_src_cvmass, t_cvmass_old, t_cvmass_new) + + ! Solve for the change in tfield. + if(explicit(f)) then + call apply_dirichlet_conditions(cvmass(f), rhs(f), tfield(f)%ptr, sub_dt) + + delta_tfield(f)%val = rhs(f)%val/cvmass(f)%val + else + ! apply strong dirichlet boundary conditions (if any) + ! note that weak conditions (known as control volume boundary conditions) + ! will already have been applied + call apply_dirichlet_conditions(M(f), rhs(f), tfield(f)%ptr, sub_dt) + + call zero(delta_tfield(f)) + call petsc_solve(delta_tfield(f), M(f), rhs(f), state(1)) + end if - call zero(delta_tfield(f)) - call petsc_solve(delta_tfield(f), M(f), rhs(f), state(1)) - end if + ewrite_minmax(delta_tfield(f)) - ewrite_minmax(delta_tfield(f)) + ! reset tfield to l_old_tfield before applying change + call set(tfield(f)%ptr, l_old_tfield(f)%ptr) + ! Add the change in tfield to tfield. + call addto(tfield(f)%ptr, delta_tfield(f), sub_dt) - ! reset tfield to l_old_tfield before applying change - call set(tfield(f)%ptr, l_old_tfield(f)%ptr) - ! Add the change in tfield to tfield. - call addto(tfield(f)%ptr, delta_tfield(f), sub_dt) + call halo_update(tfield(f)%ptr) ! exchange the extended halos - call halo_update(tfield(f)%ptr) ! exchange the extended halos + call test_and_write_advection_convergence(tfield(f)%ptr, advit_tfield(f), x, t_cvmass(f)%ptr, & + filename=trim(state(state_indices(f))%name)//"__"//trim(tfield(f)%ptr%name), & + time=time+sub_dt, dt=sub_dt, it=global_it, adv_it=adv_it, & + subcyc=sub, error=error(f)) - call test_and_write_advection_convergence(tfield(f)%ptr, advit_tfield(f), x, t_cvmass(f)%ptr, & - filename=trim(state(state_indices(f))%name)//"__"//trim(tfield(f)%ptr%name), & - time=time+sub_dt, dt=sub_dt, it=global_it, adv_it=adv_it, & - subcyc=sub, error=error(f)) - - end do + end do - if(all(errorele_nodes(tfield(1)%ptr, ele) - x_nodes=>ele_nodes(x_tfield, ele) - if(move_mesh) ug_f=ele_val_at_quad(ug, ele, ug_cvshape) - if((tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& - (tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then - upwind_nodes=>x_nodes - else - upwind_nodes=>nodes - end if - - ! find determinant and unorientated normal - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) - - cfl_ele = ele_val(cfl_no, ele) - - sum_tfield_ele = 0.0 - sum_oldtfield_ele = 0.0 - do f = 1, nfields - tfield_ele(f,:) = ele_val(tfield(f)%ptr, ele) - oldtfield_ele(f,:) = ele_val(oldtfield(f)%ptr, ele) - - do f2 = f, nfields - sum_tfield_ele(f2,:) = sum_tfield_ele(f2,:) + tfield_ele(f,:) - sum_oldtfield_ele(f2,:) = sum_oldtfield_ele(f2,:) + oldtfield_ele(f,:) - end do - - tdensity_ele(f,:) = ele_val(tdensity(f)%ptr, ele) - oldtdensity_ele(f,:) = ele_val(oldtdensity(f)%ptr, ele) - end do - - notvisited=.true. - - ! loop over nodes within this element - nodal_loop_i: do iloc = 1, tfield(1)%ptr%mesh%shape%loc - - ! loop over cv faces internal to this element - face_loop: do face = 1, cvfaces%faces - - ! is this a face neighbouring iloc? - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) - - ! loop over gauss points on face - quadrature_loop: do gi = 1, cvfaces%shape%ngi - - ! global gauss pt index - ggi = (face-1)*cvfaces%shape%ngi + gi - - ! have we been here before? - if(notvisited(ggi)) then - notvisited(ggi)=.false. - - ! correct the orientation of the normal so it points away from iloc - normgi=orientate_cvsurf_normgi(node_val(x_tfield, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - - ! calculate u.n - if(move_mesh) then - udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi(:)) - divudotn=dot_product(u_f(:,ggi), normgi(:)) - else - udotn=dot_product(u_f(:,ggi), normgi(:)) - divudotn=udotn - end if + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + u_f=ele_val_at_quad(advu, ele, u_cvshape) + nodes=>ele_nodes(tfield(1)%ptr, ele) + x_nodes=>ele_nodes(x_tfield, ele) + if(move_mesh) ug_f=ele_val_at_quad(ug, ele, ug_cvshape) + if((tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& + (tfield_options(1)%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then + upwind_nodes=>x_nodes + else + upwind_nodes=>nodes + end if + + ! find determinant and unorientated normal + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) + + cfl_ele = ele_val(cfl_no, ele) + + sum_tfield_ele = 0.0 + sum_oldtfield_ele = 0.0 + do f = 1, nfields + tfield_ele(f,:) = ele_val(tfield(f)%ptr, ele) + oldtfield_ele(f,:) = ele_val(oldtfield(f)%ptr, ele) + + do f2 = f, nfields + sum_tfield_ele(f2,:) = sum_tfield_ele(f2,:) + tfield_ele(f,:) + sum_oldtfield_ele(f2,:) = sum_oldtfield_ele(f2,:) + oldtfield_ele(f,:) + end do + + tdensity_ele(f,:) = ele_val(tdensity(f)%ptr, ele) + oldtdensity_ele(f,:) = ele_val(oldtdensity(f)%ptr, ele) + end do - inflow = (udotn<=0.0) - - income = merge(1.0,0.0,inflow) - - field_loop: do f = 1, nfields - ! calculate the iterated pivot value (so far only does first order upwind) - ! which will be subtracted out from the rhs such that with an increasing number - ! of iterations the true implicit lhs pivot is cancelled out (if it converges!) - tfield_pivot_val = income*tfield_ele(f, oloc) + (1.-income)*tfield_ele(f, iloc) - - ! evaluate the nonlinear face value that will go into the rhs - ! this is the value that you choose the discretisation for and - ! that will become the dominant term once convergence is achieved - - call evaluate_face_val(tfield_face_val(f), oldtfield_face_val(f), & - iloc, oloc, ggi, upwind_nodes, & - t_cvshape, & - tfield_ele(f,:), oldtfield_ele(f,:), & - tfield_upwind(f), oldtfield_upwind(f), & - inflow, cfl_ele, & - tfield_options(f), save_pos=upwind_pos) - - if(f>1) then - - call couple_face_value(tfield_face_val(f), oldtfield_face_val(f), & - sum(tfield_face_val(1:f-1)), sum(oldtfield_face_val(1:f-1)), & - tfield_ele(f,:), oldtfield_ele(f,:), & - sum_tfield_ele(f-1,:), sum_oldtfield_ele(f-1,:), & - tfield_upwind(f), oldtfield_upwind(f), & - inflow, iloc, oloc, upwind_nodes, cfl_ele, & - tfield_options(f), save_pos=upwind_pos) - - end if - - ! perform the time discretisation on the combined tdensity tfield product - tfield_theta_val=theta_val(iloc, oloc, & - tfield_face_val(f), & - oldtfield_face_val(f), & - tfield_options(f)%theta, dt, udotn, & - x_ele, tfield_options(f)%limit_theta, & - tfield_ele(f,:), oldtfield_ele(f,:), & - ftheta=ftheta) - - if(include_density) then - ! do the same for the density but save some effort if it's just a dummy - select case (tdensity(f)%ptr%field_type) - case(FIELD_TYPE_CONSTANT) - - tdensity_face_val = tdensity_ele(f,iloc) - oldtdensity_face_val = oldtdensity_ele(f,iloc) - - case default - - call evaluate_face_val(tdensity_face_val, oldtdensity_face_val, & - iloc, oloc, ggi, upwind_nodes, & - t_cvshape,& - tdensity_ele(f,:), oldtdensity_ele(f,:), & - tdensity_upwind(f), oldtdensity_upwind(f), & - inflow, cfl_ele, & - tdensity_options(f), save_pos = upwind_pos) - - end select - - tdensity_theta_val=theta_val(iloc, oloc, & - tdensity_face_val, & - oldtdensity_face_val, & - tdensity_options(f)%theta, dt, udotn, & - x_ele, tdensity_options(f)%limit_theta, & - tdensity_ele(f,:), oldtdensity_ele(f,:)) - - ! if we need the matrix then assemble it now - if(getmat(f)) then - call addto(A_m(f), nodes(iloc), nodes(oloc), & - ptheta(f)*detwei(ggi)*udotn*income*tdensity_theta_val) - call addto(A_m(f), nodes(oloc), nodes(iloc), & - ptheta(f)*detwei(ggi)*(-udotn)*(1.-income)*tdensity_theta_val) ! notvisited - - call addto_diag(A_m(f), nodes(iloc), & - ptheta(f)*detwei(ggi)*udotn*(1.0-income)*tdensity_theta_val & - -ftheta*(1.-beta(f))*detwei(ggi)*divudotn*tdensity_theta_val) - call addto_diag(A_m(f), nodes(oloc), & - ptheta(f)*detwei(ggi)*(-udotn)*income*tdensity_theta_val & - -ftheta*(1.-beta(f))*detwei(ggi)*(-divudotn)*tdensity_theta_val) ! notvisited - - end if - - ! assemble the rhs - call addto(rhs(f), nodes(iloc), & - ptheta(f)*udotn*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & - - udotn*detwei(ggi)*tfield_theta_val*tdensity_theta_val & - + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*divudotn*tdensity_theta_val*oldtfield_ele(f,iloc)) - call addto(rhs(f), nodes(oloc), & - ptheta(f)*(-udotn)*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & - - (-udotn)*detwei(ggi)*tfield_theta_val*tdensity_theta_val & - + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*(-divudotn)*tdensity_theta_val*oldtfield_ele(f,oloc)) ! notvisited - else - ! if we need the matrix then assemble it now - if(getmat(f)) then - call addto(A_m(f), nodes(iloc), nodes(oloc), & - ptheta(f)*detwei(ggi)*udotn*income) - call addto(A_m(f), nodes(oloc), nodes(iloc), & - ptheta(f)*detwei(ggi)*(-udotn)*(1.-income)) ! notvisited - - call addto_diag(A_m(f), nodes(iloc), & - ptheta(f)*detwei(ggi)*udotn*(1.0-income)*tdensity_theta_val & - -ftheta*(1.-beta(f))*detwei(ggi)*divudotn) - call addto_diag(A_m(f), nodes(oloc), & - ptheta(f)*detwei(ggi)*(-udotn)*income*tdensity_theta_val & - -ftheta*(1.-beta(f))*detwei(ggi)*(-divudotn)) ! notvisited - - end if - - ! assemble the rhs - call addto(rhs(f), nodes(iloc), & - ptheta(f)*udotn*detwei(ggi)*tfield_pivot_val & - - udotn*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*divudotn*oldtfield_ele(f,iloc)) - call addto(rhs(f), nodes(oloc), & - ptheta(f)*(-udotn)*detwei(ggi)*tfield_pivot_val & - - (-udotn)*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*(-divudotn)*oldtfield_ele(f,oloc)) ! notvisited - - end if - - end do field_loop - - end if ! notvisited - end do quadrature_loop - end if ! neiloc - end do face_loop - end do nodal_loop_i + notvisited=.true. + + ! loop over nodes within this element + nodal_loop_i: do iloc = 1, tfield(1)%ptr%mesh%shape%loc + + ! loop over cv faces internal to this element + face_loop: do face = 1, cvfaces%faces + + ! is this a face neighbouring iloc? + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) + + ! loop over gauss points on face + quadrature_loop: do gi = 1, cvfaces%shape%ngi + + ! global gauss pt index + ggi = (face-1)*cvfaces%shape%ngi + gi + + ! have we been here before? + if(notvisited(ggi)) then + notvisited(ggi)=.false. + + ! correct the orientation of the normal so it points away from iloc + normgi=orientate_cvsurf_normgi(node_val(x_tfield, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + + ! calculate u.n + if(move_mesh) then + udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi(:)) + divudotn=dot_product(u_f(:,ggi), normgi(:)) + else + udotn=dot_product(u_f(:,ggi), normgi(:)) + divudotn=udotn + end if + + inflow = (udotn<=0.0) + + income = merge(1.0,0.0,inflow) + + field_loop: do f = 1, nfields + ! calculate the iterated pivot value (so far only does first order upwind) + ! which will be subtracted out from the rhs such that with an increasing number + ! of iterations the true implicit lhs pivot is cancelled out (if it converges!) + tfield_pivot_val = income*tfield_ele(f, oloc) + (1.-income)*tfield_ele(f, iloc) + + ! evaluate the nonlinear face value that will go into the rhs + ! this is the value that you choose the discretisation for and + ! that will become the dominant term once convergence is achieved + + call evaluate_face_val(tfield_face_val(f), oldtfield_face_val(f), & + iloc, oloc, ggi, upwind_nodes, & + t_cvshape, & + tfield_ele(f,:), oldtfield_ele(f,:), & + tfield_upwind(f), oldtfield_upwind(f), & + inflow, cfl_ele, & + tfield_options(f), save_pos=upwind_pos) + + if(f>1) then + + call couple_face_value(tfield_face_val(f), oldtfield_face_val(f), & + sum(tfield_face_val(1:f-1)), sum(oldtfield_face_val(1:f-1)), & + tfield_ele(f,:), oldtfield_ele(f,:), & + sum_tfield_ele(f-1,:), sum_oldtfield_ele(f-1,:), & + tfield_upwind(f), oldtfield_upwind(f), & + inflow, iloc, oloc, upwind_nodes, cfl_ele, & + tfield_options(f), save_pos=upwind_pos) + + end if + + ! perform the time discretisation on the combined tdensity tfield product + tfield_theta_val=theta_val(iloc, oloc, & + tfield_face_val(f), & + oldtfield_face_val(f), & + tfield_options(f)%theta, dt, udotn, & + x_ele, tfield_options(f)%limit_theta, & + tfield_ele(f,:), oldtfield_ele(f,:), & + ftheta=ftheta) + + if(include_density) then + ! do the same for the density but save some effort if it's just a dummy + select case (tdensity(f)%ptr%field_type) + case(FIELD_TYPE_CONSTANT) + + tdensity_face_val = tdensity_ele(f,iloc) + oldtdensity_face_val = oldtdensity_ele(f,iloc) + + case default + + call evaluate_face_val(tdensity_face_val, oldtdensity_face_val, & + iloc, oloc, ggi, upwind_nodes, & + t_cvshape,& + tdensity_ele(f,:), oldtdensity_ele(f,:), & + tdensity_upwind(f), oldtdensity_upwind(f), & + inflow, cfl_ele, & + tdensity_options(f), save_pos = upwind_pos) + + end select + + tdensity_theta_val=theta_val(iloc, oloc, & + tdensity_face_val, & + oldtdensity_face_val, & + tdensity_options(f)%theta, dt, udotn, & + x_ele, tdensity_options(f)%limit_theta, & + tdensity_ele(f,:), oldtdensity_ele(f,:)) + + ! if we need the matrix then assemble it now + if(getmat(f)) then + call addto(A_m(f), nodes(iloc), nodes(oloc), & + ptheta(f)*detwei(ggi)*udotn*income*tdensity_theta_val) + call addto(A_m(f), nodes(oloc), nodes(iloc), & + ptheta(f)*detwei(ggi)*(-udotn)*(1.-income)*tdensity_theta_val) ! notvisited + + call addto_diag(A_m(f), nodes(iloc), & + ptheta(f)*detwei(ggi)*udotn*(1.0-income)*tdensity_theta_val & + -ftheta*(1.-beta(f))*detwei(ggi)*divudotn*tdensity_theta_val) + call addto_diag(A_m(f), nodes(oloc), & + ptheta(f)*detwei(ggi)*(-udotn)*income*tdensity_theta_val & + -ftheta*(1.-beta(f))*detwei(ggi)*(-divudotn)*tdensity_theta_val) ! notvisited + + end if + + ! assemble the rhs + call addto(rhs(f), nodes(iloc), & + ptheta(f)*udotn*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & + - udotn*detwei(ggi)*tfield_theta_val*tdensity_theta_val & + + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*divudotn*tdensity_theta_val*oldtfield_ele(f,iloc)) + call addto(rhs(f), nodes(oloc), & + ptheta(f)*(-udotn)*detwei(ggi)*tdensity_theta_val*tfield_pivot_val & + - (-udotn)*detwei(ggi)*tfield_theta_val*tdensity_theta_val & + + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*(-divudotn)*tdensity_theta_val*oldtfield_ele(f,oloc)) ! notvisited + else + ! if we need the matrix then assemble it now + if(getmat(f)) then + call addto(A_m(f), nodes(iloc), nodes(oloc), & + ptheta(f)*detwei(ggi)*udotn*income) + call addto(A_m(f), nodes(oloc), nodes(iloc), & + ptheta(f)*detwei(ggi)*(-udotn)*(1.-income)) ! notvisited + + call addto_diag(A_m(f), nodes(iloc), & + ptheta(f)*detwei(ggi)*udotn*(1.0-income)*tdensity_theta_val & + -ftheta*(1.-beta(f))*detwei(ggi)*divudotn) + call addto_diag(A_m(f), nodes(oloc), & + ptheta(f)*detwei(ggi)*(-udotn)*income*tdensity_theta_val & + -ftheta*(1.-beta(f))*detwei(ggi)*(-divudotn)) ! notvisited + + end if + + ! assemble the rhs + call addto(rhs(f), nodes(iloc), & + ptheta(f)*udotn*detwei(ggi)*tfield_pivot_val & + - udotn*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*divudotn*oldtfield_ele(f,iloc)) + call addto(rhs(f), nodes(oloc), & + ptheta(f)*(-udotn)*detwei(ggi)*tfield_pivot_val & + - (-udotn)*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta(f))*detwei(ggi)*(-divudotn)*oldtfield_ele(f,oloc)) ! notvisited + + end if + + end do field_loop + + end if ! notvisited + end do quadrature_loop + end if ! neiloc + end do face_loop + end do nodal_loop_i end do element_loop ! allocate memory for assembly allocate(x_ele_bdy(x%dim,face_loc(x,1)), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi), & - u_bdy_f(advu%dim, u_cvbdyshape%ngi), & - ug_bdy_f(advu%dim, ug_cvbdyshape%ngi), & - tdensity_ele_bdy(nfields,face_loc(tdensity(1)%ptr,1)), & - oldtdensity_ele_bdy(nfields,face_loc(oldtdensity(1)%ptr,1)), & - tfield_ele_bdy(nfields,face_loc(tfield(1)%ptr,1)), & - oldtfield_ele_bdy(nfields,face_loc(oldtfield(1)%ptr,1)), & - ghost_tdensity_ele_bdy(nfields,face_loc(tdensity(1)%ptr,1)), & - ghost_oldtdensity_ele_bdy(nfields,face_loc(oldtdensity(1)%ptr,1)), & - ghost_tfield_ele_bdy(nfields,face_loc(tfield(1)%ptr,1)), & - ghost_oldtfield_ele_bdy(nfields,face_loc(oldtfield(1)%ptr,1))) + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi), & + u_bdy_f(advu%dim, u_cvbdyshape%ngi), & + ug_bdy_f(advu%dim, ug_cvbdyshape%ngi), & + tdensity_ele_bdy(nfields,face_loc(tdensity(1)%ptr,1)), & + oldtdensity_ele_bdy(nfields,face_loc(oldtdensity(1)%ptr,1)), & + tfield_ele_bdy(nfields,face_loc(tfield(1)%ptr,1)), & + oldtfield_ele_bdy(nfields,face_loc(oldtfield(1)%ptr,1)), & + ghost_tdensity_ele_bdy(nfields,face_loc(tdensity(1)%ptr,1)), & + ghost_oldtdensity_ele_bdy(nfields,face_loc(oldtdensity(1)%ptr,1)), & + ghost_tfield_ele_bdy(nfields,face_loc(tfield(1)%ptr,1)), & + ghost_oldtfield_ele_bdy(nfields,face_loc(oldtfield(1)%ptr,1))) allocate(tfield_bc_type(nfields, surface_element_count(tfield(1)%ptr)), & - tdensity_bc_type(nfields, surface_element_count(tdensity(1)%ptr)), & - nodes_bdy(face_loc(tfield(1)%ptr,1))) + tdensity_bc_type(nfields, surface_element_count(tdensity(1)%ptr)), & + nodes_bdy(face_loc(tfield(1)%ptr,1))) do f = 1, nfields - ! get the fields over the surface containing the bcs - call get_entire_boundary_condition(tfield(f)%ptr, (/ & - "weakdirichlet", & - "internal ", & - "zero_flux "/), tfield_bc(f), tfield_bc_type(f,:)) - call get_entire_boundary_condition(tdensity(f)%ptr, (/"weakdirichlet"/), tdensity_bc(f), tdensity_bc_type(f,:)) + ! get the fields over the surface containing the bcs + call get_entire_boundary_condition(tfield(f)%ptr, (/ & + "weakdirichlet", & + "internal ", & + "zero_flux "/), tfield_bc(f), tfield_bc_type(f,:)) + call get_entire_boundary_condition(tdensity(f)%ptr, (/"weakdirichlet"/), tdensity_bc(f), tdensity_bc_type(f,:)) end do ! loop over the surface elements surface_element_loop: do sele = 1, surface_element_count(tfield(1)%ptr) - if(any(tfield_bc_type(:,sele)==BC_TYPE_INTERNAL)) cycle - - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - nodes_bdy=face_global_nodes(tfield(1)%ptr, sele) - - ! calculate the determinant and orientated normal - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) - - u_bdy_f=face_val_at_quad(advu, sele, u_cvbdyshape) - if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) - - do f = 1, nfields - ! deal with bcs for tfield - if(tfield_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_tfield_ele_bdy(f,:)=ele_val(tfield_bc(f), sele) - else - ghost_tfield_ele_bdy(f,:)=face_val(tfield(f)%ptr, sele) - end if - - if(tfield_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_oldtfield_ele_bdy(f,:)=ele_val(tfield_bc(f), sele) ! not considering time varying bcs yet - else - ghost_oldtfield_ele_bdy(f,:)=face_val(oldtfield(f)%ptr, sele) - end if - - tfield_ele_bdy(f,:)=face_val(tfield(f)%ptr, sele) - oldtfield_ele_bdy(f,:)=face_val(oldtfield(f)%ptr, sele) - - ! deal with bcs for tdensity - if(tdensity_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_tdensity_ele_bdy(f,:)=ele_val(tdensity_bc(f), sele) - else - ghost_tdensity_ele_bdy(f,:)=face_val(tdensity(f)%ptr, sele) - end if - - if(tdensity_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then - ghost_oldtdensity_ele_bdy(f,:)=ele_val(tdensity_bc(f), sele) ! not considering time varying bcs yet - else - ghost_oldtdensity_ele_bdy(f,:)=face_val(oldtdensity(f)%ptr, sele) - end if - - tdensity_ele_bdy(f,:)=face_val(tdensity(f)%ptr, sele) - oldtdensity_ele_bdy(f,:)=face_val(oldtdensity(f)%ptr, sele) - - end do - - ! loop over the nodes on this surface element - surface_nodal_loop_i: do iloc = 1, tfield(1)%ptr%mesh%faces%shape%loc - - ! loop over the faces in this surface element - surface_face_loop: do face = 1, cvfaces%sfaces - - ! is this face a neighbour of iloc? - if(cvfaces%sneiloc(iloc,face)/=0) then - - ! loop over the gauss pts on this face - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - - ! global gauss point index - ggi = (face-1)*cvfaces%shape%ngi + gi - - ! u.n - divudotn = dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) - if(move_mesh) then - udotn_bdy = dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) - else - udotn_bdy = divudotn - end if - - if(udotn_bdy>0) then - income=0.0 ! flow leaving the domain - else - income=1.0 ! flow entering the domain - end if - - ! as we're on the boundary it's not possible to use high order methods so just - ! default to the pivotted solution method (first order upwinding) - ! if the flow is incoming then use the bc ghost values - ! if the flow is outgoing then use the surface nodes value - - surface_field_loop: do f = 1, nfields - - if((tfield_bc_type(f,sele)==BC_TYPE_ZEROFLUX)) then - ! zero_flux - udotn = 0.0 - else - udotn=udotn_bdy - end if + if(any(tfield_bc_type(:,sele)==BC_TYPE_INTERNAL)) cycle - ! for tfield - tfield_face_val(f) = income*ghost_tfield_ele_bdy(f,iloc) + (1.-income)*tfield_ele_bdy(f,iloc) - oldtfield_face_val(f) = income*ghost_oldtfield_ele_bdy(f,iloc) + (1.-income)*oldtfield_ele_bdy(f,iloc) - - if(include_density) then - ! for tdensity - tdensity_face_val = income*ghost_tdensity_ele_bdy(f,iloc) + (1.-income)*tdensity_ele_bdy(f,iloc) - oldtdensity_face_val = income*ghost_oldtdensity_ele_bdy(f,iloc) + (1.-income)*oldtdensity_ele_bdy(f,iloc) - - tdensity_theta_val = tdensity_options(f)%theta*tdensity_face_val + (1.-tdensity_options(f)%theta)*oldtdensity_face_val - - ! assemble matrix - if(getmat(f)) then - call addto_diag(A_m(f), nodes_bdy(iloc), & - ptheta(f)*detwei_bdy(ggi)*udotn*(1.-income)*tdensity_theta_val & ! if iloc is the donor we can do this implicitly - - ptheta(f)*(1.-beta(f))*detwei_bdy(ggi)*divudotn*tdensity_theta_val) - end if - - ! assemble rhs - call addto(rhs(f), nodes_bdy(iloc), & - -ptheta(f)*udotn*detwei_bdy(ggi)*income*tdensity_theta_val*ghost_tfield_ele_bdy(f,iloc) & ! but we can't if it's the downwind - -(1.-ptheta(f))*udotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_face_val(f) & - +(1.-ptheta(f))*(1.-beta(f))*divudotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_ele_bdy(f,iloc)) - else - ! assemble matrix - if(getmat(f)) then - call addto_diag(A_m(f), nodes_bdy(iloc), & - ptheta(f)*detwei_bdy(ggi)*udotn*(1.-income) & ! if iloc is the donor we can do this implicitly - - ptheta(f)*(1.-beta(f))*detwei_bdy(ggi)*divudotn) - end if - - ! assemble rhs - call addto(rhs(f), nodes_bdy(iloc), & - -ptheta(f)*udotn*detwei_bdy(ggi)*income*ghost_tfield_ele_bdy(f,iloc) & ! but we can't if it's the downwind - -(1.-ptheta(f))*udotn*detwei_bdy(ggi)*oldtfield_face_val(f) & - +(1.-ptheta(f))*(1.-beta(f))*divudotn*detwei_bdy(ggi)*oldtfield_ele_bdy(f,iloc)) - end if + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + nodes_bdy=face_global_nodes(tfield(1)%ptr, sele) + + ! calculate the determinant and orientated normal + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) + + u_bdy_f=face_val_at_quad(advu, sele, u_cvbdyshape) + if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) + + do f = 1, nfields + ! deal with bcs for tfield + if(tfield_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_tfield_ele_bdy(f,:)=ele_val(tfield_bc(f), sele) + else + ghost_tfield_ele_bdy(f,:)=face_val(tfield(f)%ptr, sele) + end if + + if(tfield_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_oldtfield_ele_bdy(f,:)=ele_val(tfield_bc(f), sele) ! not considering time varying bcs yet + else + ghost_oldtfield_ele_bdy(f,:)=face_val(oldtfield(f)%ptr, sele) + end if + + tfield_ele_bdy(f,:)=face_val(tfield(f)%ptr, sele) + oldtfield_ele_bdy(f,:)=face_val(oldtfield(f)%ptr, sele) + + ! deal with bcs for tdensity + if(tdensity_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_tdensity_ele_bdy(f,:)=ele_val(tdensity_bc(f), sele) + else + ghost_tdensity_ele_bdy(f,:)=face_val(tdensity(f)%ptr, sele) + end if + + if(tdensity_bc_type(f,sele)==BC_TYPE_WEAKDIRICHLET) then + ghost_oldtdensity_ele_bdy(f,:)=ele_val(tdensity_bc(f), sele) ! not considering time varying bcs yet + else + ghost_oldtdensity_ele_bdy(f,:)=face_val(oldtdensity(f)%ptr, sele) + end if + + tdensity_ele_bdy(f,:)=face_val(tdensity(f)%ptr, sele) + oldtdensity_ele_bdy(f,:)=face_val(oldtdensity(f)%ptr, sele) + + end do + + ! loop over the nodes on this surface element + surface_nodal_loop_i: do iloc = 1, tfield(1)%ptr%mesh%faces%shape%loc + + ! loop over the faces in this surface element + surface_face_loop: do face = 1, cvfaces%sfaces + + ! is this face a neighbour of iloc? + if(cvfaces%sneiloc(iloc,face)/=0) then + + ! loop over the gauss pts on this face + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + + ! global gauss point index + ggi = (face-1)*cvfaces%shape%ngi + gi + + ! u.n + divudotn = dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) + if(move_mesh) then + udotn_bdy = dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) + else + udotn_bdy = divudotn + end if + + if(udotn_bdy>0) then + income=0.0 ! flow leaving the domain + else + income=1.0 ! flow entering the domain + end if - end do surface_field_loop + ! as we're on the boundary it's not possible to use high order methods so just + ! default to the pivotted solution method (first order upwinding) + ! if the flow is incoming then use the bc ghost values + ! if the flow is outgoing then use the surface nodes value - end do surface_quadrature_loop + surface_field_loop: do f = 1, nfields - end if ! sneiloc + if((tfield_bc_type(f,sele)==BC_TYPE_ZEROFLUX)) then + ! zero_flux + udotn = 0.0 + else + udotn=udotn_bdy + end if - end do surface_face_loop + ! for tfield + tfield_face_val(f) = income*ghost_tfield_ele_bdy(f,iloc) + (1.-income)*tfield_ele_bdy(f,iloc) + oldtfield_face_val(f) = income*ghost_oldtfield_ele_bdy(f,iloc) + (1.-income)*oldtfield_ele_bdy(f,iloc) - end do surface_nodal_loop_i + if(include_density) then + ! for tdensity + tdensity_face_val = income*ghost_tdensity_ele_bdy(f,iloc) + (1.-income)*tdensity_ele_bdy(f,iloc) + oldtdensity_face_val = income*ghost_oldtdensity_ele_bdy(f,iloc) + (1.-income)*oldtdensity_ele_bdy(f,iloc) + + tdensity_theta_val = tdensity_options(f)%theta*tdensity_face_val + (1.-tdensity_options(f)%theta)*oldtdensity_face_val + + ! assemble matrix + if(getmat(f)) then + call addto_diag(A_m(f), nodes_bdy(iloc), & + ptheta(f)*detwei_bdy(ggi)*udotn*(1.-income)*tdensity_theta_val & ! if iloc is the donor we can do this implicitly + - ptheta(f)*(1.-beta(f))*detwei_bdy(ggi)*divudotn*tdensity_theta_val) + end if + + ! assemble rhs + call addto(rhs(f), nodes_bdy(iloc), & + -ptheta(f)*udotn*detwei_bdy(ggi)*income*tdensity_theta_val*ghost_tfield_ele_bdy(f,iloc) & ! but we can't if it's the downwind + -(1.-ptheta(f))*udotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_face_val(f) & + +(1.-ptheta(f))*(1.-beta(f))*divudotn*detwei_bdy(ggi)*tdensity_theta_val*oldtfield_ele_bdy(f,iloc)) + else + ! assemble matrix + if(getmat(f)) then + call addto_diag(A_m(f), nodes_bdy(iloc), & + ptheta(f)*detwei_bdy(ggi)*udotn*(1.-income) & ! if iloc is the donor we can do this implicitly + - ptheta(f)*(1.-beta(f))*detwei_bdy(ggi)*divudotn) + end if + + ! assemble rhs + call addto(rhs(f), nodes_bdy(iloc), & + -ptheta(f)*udotn*detwei_bdy(ggi)*income*ghost_tfield_ele_bdy(f,iloc) & ! but we can't if it's the downwind + -(1.-ptheta(f))*udotn*detwei_bdy(ggi)*oldtfield_face_val(f) & + +(1.-ptheta(f))*(1.-beta(f))*divudotn*detwei_bdy(ggi)*oldtfield_ele_bdy(f,iloc)) + end if + + end do surface_field_loop + + end do surface_quadrature_loop + + end if ! sneiloc + + end do surface_face_loop + + end do surface_nodal_loop_i end do surface_element_loop @@ -3427,31 +3427,31 @@ subroutine assemble_coupled_advection_m_cv(A_m, rhs, & deallocate(nodes_bdy) deallocate(tdensity_ele_bdy, oldtdensity_ele_bdy, tfield_ele_bdy, oldtfield_ele_bdy) deallocate(ghost_tdensity_ele_bdy, ghost_oldtdensity_ele_bdy, & - ghost_tfield_ele_bdy, ghost_oldtfield_ele_bdy) + ghost_tfield_ele_bdy, ghost_oldtfield_ele_bdy) deallocate(tfield_bc_type, tdensity_bc_type) do f = 1, nfields - call deallocate(tfield_bc(f)) - call deallocate(tdensity_bc(f)) + call deallocate(tfield_bc(f)) + call deallocate(tdensity_bc(f)) - if(include_density) then - call deallocate(tdensity_upwind(f)) - call deallocate(oldtdensity_upwind(f)) - end if + if(include_density) then + call deallocate(tdensity_upwind(f)) + call deallocate(oldtdensity_upwind(f)) + end if - call deallocate(tfield_upwind(f)) - call deallocate(oldtfield_upwind(f)) + call deallocate(tfield_upwind(f)) + call deallocate(oldtfield_upwind(f)) end do deallocate(x_ele, x_f, detwei, normal, normgi, u_f, ug_f) deallocate(cfl_ele, tfield_ele, oldtfield_ele, tdensity_ele, oldtdensity_ele) deallocate(notvisited) - end subroutine assemble_coupled_advection_m_cv - !************************************************************************ - !************************************************************************ - ! subroutines dealing with the writing of the advection_convergence files - subroutine initialise_advection_convergence(state) + end subroutine assemble_coupled_advection_m_cv + !************************************************************************ + !************************************************************************ + ! subroutines dealing with the writing of the advection_convergence files + subroutine initialise_advection_convergence(state) type(state_type), dimension(:), intent(in) :: state @@ -3475,122 +3475,122 @@ subroutine initialise_advection_convergence(state) fileno = 0 do i = 1, size(state) - material_phase_name=trim(state(i)%name) + material_phase_name=trim(state(i)%name) - do j = 1, size(state(i)%scalar_fields) + do j = 1, size(state(i)%scalar_fields) - if(have_option(trim(state(i)%scalar_fields(j)%ptr%option_path)//& - "/prognostic/output/convergence_file")) then - field_name=trim(state(i)%scalar_fields(j)%ptr%name) + if(have_option(trim(state(i)%scalar_fields(j)%ptr%option_path)//& + "/prognostic/output/convergence_file")) then + field_name=trim(state(i)%scalar_fields(j)%ptr%name) - fileno=fileno+1 + fileno=fileno+1 - if(fileno>nfiles) then - ewrite(-1,*) 'fileno = ', fileno, 'nfiles = ', nfiles - ! this shouldn't happen - FLAbort("More fields think they want a convergence file than expected.") - end if + if(fileno>nfiles) then + ewrite(-1,*) 'fileno = ', fileno, 'nfiles = ', nfiles + ! this shouldn't happen + FLAbort("More fields think they want a convergence file than expected.") + end if - sfield_list(fileno) = trim(material_phase_name)//& - "__"//trim(field_name) - - ! open and write a file (if its the first processor) - if(getprocno() == 1) then - conv_unit(fileno) = free_unit() - open(unit=conv_unit(fileno), file=trim(sfield_list(fileno))//".convergence", & - action="write") - - - write(conv_unit(fileno), '(a)') "
" - - column=0 - ! Initial columns are elapsed time, dt, global iteration and advective iteration - column=column+1 - buffer=field_tag(name="ElapsedTime", column=column, statistic="value") - write(conv_unit(fileno), '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="dt", column=column, statistic="value") - write(conv_unit(fileno), '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="Iteration", column=column, statistic="value") - write(conv_unit(fileno), '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="Subcycle", column=column, statistic="value") - write(conv_unit(fileno), '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="AdvectionIteration", column=column, statistic="value") - write(conv_unit(fileno), '(a)') trim(buffer) - - column=column+1 - buffer=field_tag(name=trim(field_name), column=column, statistic="error", material_phase_name=trim(material_phase_name)) - write(conv_unit(fileno), '(a)') trim(buffer) - - write(conv_unit(fileno), '(a)') "
" + sfield_list(fileno) = trim(material_phase_name)//& + "__"//trim(field_name) + + ! open and write a file (if its the first processor) + if(getprocno() == 1) then + conv_unit(fileno) = free_unit() + open(unit=conv_unit(fileno), file=trim(sfield_list(fileno))//".convergence", & + action="write") + + + write(conv_unit(fileno), '(a)') "
" + + column=0 + ! Initial columns are elapsed time, dt, global iteration and advective iteration + column=column+1 + buffer=field_tag(name="ElapsedTime", column=column, statistic="value") + write(conv_unit(fileno), '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="dt", column=column, statistic="value") + write(conv_unit(fileno), '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="Iteration", column=column, statistic="value") + write(conv_unit(fileno), '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="Subcycle", column=column, statistic="value") + write(conv_unit(fileno), '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="AdvectionIteration", column=column, statistic="value") + write(conv_unit(fileno), '(a)') trim(buffer) + + column=column+1 + buffer=field_tag(name=trim(field_name), column=column, statistic="error", material_phase_name=trim(material_phase_name)) + write(conv_unit(fileno), '(a)') trim(buffer) + + write(conv_unit(fileno), '(a)') "
" - end if + end if - end if - end do + end if + end do end do if(fileno/=nfiles) then - ! something's gone wrong - ewrite(-1,*) 'fileno = ', fileno, 'nfiles = ', nfiles - FLAbort("Fewer fields thought they wanted a convergence file than expected.") + ! something's gone wrong + ewrite(-1,*) 'fileno = ', fileno, 'nfiles = ', nfiles + FLAbort("Fewer fields thought they wanted a convergence file than expected.") end if - end subroutine initialise_advection_convergence + end subroutine initialise_advection_convergence - subroutine test_and_write_advection_convergence(field, nlfield, coordinates, cv_mass, filename, & - time, dt, it, subcyc, adv_it, & - error) + subroutine test_and_write_advection_convergence(field, nlfield, coordinates, cv_mass, filename, & + time, dt, it, subcyc, adv_it, & + error) - type(scalar_field), intent(inout) :: field, nlfield - type(vector_field), intent(in) :: coordinates - type(scalar_field), intent(in) :: cv_mass - character(len=*), intent(in) :: filename - real, intent(in) :: time, dt - integer, intent(in) :: it, subcyc, adv_it + type(scalar_field), intent(inout) :: field, nlfield + type(vector_field), intent(in) :: coordinates + type(scalar_field), intent(in) :: cv_mass + character(len=*), intent(in) :: filename + real, intent(in) :: time, dt + integer, intent(in) :: it, subcyc, adv_it - real, intent(out) :: error + real, intent(out) :: error - logical :: write_convergence_file - character(len=10) :: format, iformat - integer :: fileno + logical :: write_convergence_file + character(len=10) :: format, iformat + integer :: fileno - integer :: convergence_norm + integer :: convergence_norm - convergence_norm = convergence_norm_integer(trim(field%option_path)//& - "/prognostic/temporal_discretisation/control_volumes/number_advection_iterations/tolerance") + convergence_norm = convergence_norm_integer(trim(field%option_path)//& + "/prognostic/temporal_discretisation/control_volumes/number_advection_iterations/tolerance") - error = 0.0 - call field_con_stats(field, nlfield, error, & - convergence_norm, coordinates, cv_mass) + error = 0.0 + call field_con_stats(field, nlfield, error, & + convergence_norm, coordinates, cv_mass) - format='(e15.6e3)' - iformat='(i4)' + format='(e15.6e3)' + iformat='(i4)' - write_convergence_file = .false. - fileno=find_fileno(filename) - if(fileno/=0) then + write_convergence_file = .false. + fileno=find_fileno(filename) + if(fileno/=0) then write_convergence_file = .true. - end if + end if - if(write_convergence_file) then + if(write_convergence_file) then if(getprocno() == 1) then - write(conv_unit(fileno), format, advance="no") time - write(conv_unit(fileno), format, advance="no") dt - write(conv_unit(fileno), iformat, advance="no") it - write(conv_unit(fileno), iformat, advance="no") subcyc - write(conv_unit(fileno), iformat, advance="no") adv_it - write(conv_unit(fileno), format, advance="no") error - write(conv_unit(fileno),'(a)') "" ! end of line + write(conv_unit(fileno), format, advance="no") time + write(conv_unit(fileno), format, advance="no") dt + write(conv_unit(fileno), iformat, advance="no") it + write(conv_unit(fileno), iformat, advance="no") subcyc + write(conv_unit(fileno), iformat, advance="no") adv_it + write(conv_unit(fileno), format, advance="no") error + write(conv_unit(fileno),'(a)') "" ! end of line end if - end if + end if - end subroutine test_and_write_advection_convergence + end subroutine test_and_write_advection_convergence - pure function find_fileno(filename) result(fileno) + pure function find_fileno(filename) result(fileno) integer :: fileno character(len=*), intent(in) :: filename @@ -3600,18 +3600,18 @@ pure function find_fileno(filename) result(fileno) fileno = 0 do i = 1, size(sfield_list) - if(trim(filename)==trim(sfield_list(i))) then - fileno = i - return - end if + if(trim(filename)==trim(sfield_list(i))) then + fileno = i + return + end if end do - end function find_fileno - ! end of convergence file subroutines - !************************************************************************ - !************************************************************************ - ! control volume options checking - subroutine field_equations_cv_check_options + end function find_fileno + ! end of convergence file subroutines + !************************************************************************ + !************************************************************************ + ! control volume options checking + subroutine field_equations_cv_check_options integer :: nmat, nfield, m, f, stat character(len=OPTION_PATH_LEN) :: mat_name, field_name, mesh_0, mesh_1, diff_scheme integer :: weakdirichlet_count @@ -3625,147 +3625,147 @@ subroutine field_equations_cv_check_options nfield = option_count("/material_phase["//int2str(m)//"]/scalar_field") do f = 0, nfield-1 call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/name", field_name) + "]/name", field_name) cv_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/spatial_discretisation/control_volumes") + "]/prognostic/spatial_discretisation/control_volumes") mmat_cv_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/spatial_discretisation/coupled_cv") + "]/prognostic/spatial_discretisation/coupled_cv") diff=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/tensor_field::Diffusivity") + "]/prognostic/tensor_field::Diffusivity") call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/spatial_discretisation/control_volumes/diffusion_scheme[0]/name", & - diff_scheme, default="None") + "]/prognostic/spatial_discretisation/control_volumes/diffusion_scheme[0]/name", & + diff_scheme, default="None") conv_file=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/output/convergence_file") + "]/prognostic/output/convergence_file") cv_temp_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/control_volumes") + "]/prognostic/temporal_discretisation/control_volumes") tolerance=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/control_volumes/number_advection_iterations/tolerance") + "]/prognostic/temporal_discretisation/control_volumes/number_advection_iterations/tolerance") subcycle=((have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/control_volumes/maximum_courant_number_per_subcycle")).or.& - (have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/control_volumes/number_advection_subcycles"))) + "]/prognostic/temporal_discretisation/control_volumes/maximum_courant_number_per_subcycle")).or.& + (have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/temporal_discretisation/control_volumes/number_advection_subcycles"))) explicit=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/explicit") + "]/prognostic/explicit") weakdirichlet_count=option_count("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/boundary_conditions/type[0]/apply_weakly") + "]/prognostic/boundary_conditions/type[0]/apply_weakly") if(mmat_cv_disc) then - if(diff) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - ewrite(-1,*) "Use control volume discretisation if you want diffusion." - FLExit("Multiple coupled control volume discretisation not compatible with Diffusivity") - end if - - if(.not.have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/priority")) then - FLExit("Coupled control volume discretisation requires a priority option.") - end if - - if(explicit) then - - call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/theta", theta) - if (theta/=0.0) then + if(diff) then ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Explicit coupled control volume discretisations must use temporal_discretisation/theta = 0.0") - end if - - call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/control_volumes/pivot_theta", p_theta, default=1.0) - if (p_theta/=0.0) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Explicit coupled control volume discretisations must use temporal_discretisation/control_volumes/pivot_theta = 0.0") - end if + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + ewrite(-1,*) "Use control volume discretisation if you want diffusion." + FLExit("Multiple coupled control volume discretisation not compatible with Diffusivity") + end if - end if + if(.not.have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/priority")) then + FLExit("Coupled control volume discretisation requires a priority option.") + end if + + if(explicit) then + + call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/temporal_discretisation/theta", theta) + if (theta/=0.0) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Explicit coupled control volume discretisations must use temporal_discretisation/theta = 0.0") + end if + + call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/temporal_discretisation/control_volumes/pivot_theta", p_theta, default=1.0) + if (p_theta/=0.0) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Explicit coupled control volume discretisations must use temporal_discretisation/control_volumes/pivot_theta = 0.0") + end if + + end if elseif(cv_disc) then - if(diff) then - select case(diff_scheme) - case("ElementGradient") - if(weakdirichlet_count>0) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - ewrite(-1,*) "ElementGradient diffusion scheme not compatible with weak dirichlet boundary conditions!" - ewrite(-1,*) "Use strong dirichlet boundary conditions or switch the diffusion scheme to BassiRebay." - ewrite(-1,*) "Sorry and Good Luck!" - FLExit("ElementGradient diffusion scheme not compatible with weak dirichlet boundary conditions") + if(diff) then + select case(diff_scheme) + case("ElementGradient") + if(weakdirichlet_count>0) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + ewrite(-1,*) "ElementGradient diffusion scheme not compatible with weak dirichlet boundary conditions!" + ewrite(-1,*) "Use strong dirichlet boundary conditions or switch the diffusion scheme to BassiRebay." + ewrite(-1,*) "Sorry and Good Luck!" + FLExit("ElementGradient diffusion scheme not compatible with weak dirichlet boundary conditions") + end if + end select + end if + if(explicit) then + + call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/temporal_discretisation/theta", theta) + if (theta/=0.0) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Explicit control volume discretisations must use temporal_discretisation/theta = 0.0") end if - end select - end if - if(explicit) then - call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/theta", theta) - if (theta/=0.0) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Explicit control volume discretisations must use temporal_discretisation/theta = 0.0") - end if - - call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/temporal_discretisation/control_volumes/pivot_theta", p_theta, default=1.0) - if (p_theta/=0.0) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Explicit control volume discretisations must use temporal_discretisation/control_volumes/pivot_theta = 0.0") - end if + call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/temporal_discretisation/control_volumes/pivot_theta", p_theta, default=1.0) + if (p_theta/=0.0) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Explicit control volume discretisations must use temporal_discretisation/control_volumes/pivot_theta = 0.0") + end if - end if + end if else - if(conv_file) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Only pure control volume and coupled_cv discretisations can output a convergence file") - end if - if(cv_temp_disc) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Only control volume or coupled_cv discretisations can use control_volume temporal discretisations") - end if - if(explicit) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Only pure control volume or coupled_cv discretisations can solve explicitly") - end if + if(conv_file) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Only pure control volume and coupled_cv discretisations can output a convergence file") + end if + if(cv_temp_disc) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Only control volume or coupled_cv discretisations can use control_volume temporal discretisations") + end if + if(explicit) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Only pure control volume or coupled_cv discretisations can solve explicitly") + end if end if if(mmat_cv_disc .or. cv_disc) then if (have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/scalar_field::SinkingVelocity")) then + "]/prognostic/scalar_field::SinkingVelocity")) then call get_option(trim(complete_field_path("/material_phase["//& - int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/scalar_field::SinkingVelocity"))//"/mesh[0]/name", mesh_0, stat) + int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/scalar_field::SinkingVelocity"))//"/mesh[0]/name", mesh_0, stat) if(stat == 0) then call get_option(trim(complete_field_path("/material_phase[" // int2str(m) // & - "]/vector_field::Velocity")) // "/mesh[0]/name", mesh_1) + "]/vector_field::Velocity")) // "/mesh[0]/name", mesh_1) if(trim(mesh_0) /= trim(mesh_1)) then ewrite(0, *) "SinkingVelocity for "//trim(field_name)//& - " is on a different mesh to the Velocity field this could cause problems" + " is on a different mesh to the Velocity field this could cause problems" end if end if end if end if end do - end do + end do - end subroutine field_equations_cv_check_options - ! end of control volume options checking - !************************************************************************ + end subroutine field_equations_cv_check_options + ! end of control volume options checking + !************************************************************************ end module field_equations_CV diff --git a/assemble/Foam_Drainage.F90 b/assemble/Foam_Drainage.F90 index 45b28e19ce..f445ef0c56 100644 --- a/assemble/Foam_Drainage.F90 +++ b/assemble/Foam_Drainage.F90 @@ -28,121 +28,121 @@ #include "fdebug.h" module foam_drainage - ! This module contains the options used for Foam drainage - use fldebug - use spud - use fields - use state_module - use field_options - use cv_upwind_values - use state_fields_module - use diagnostic_fields_matrices + ! This module contains the options used for Foam drainage + use fldebug + use spud + use fields + use state_module + use field_options + use cv_upwind_values + use state_fields_module + use diagnostic_fields_matrices - implicit none + implicit none - private - public :: calculate_drainage_source_absor + private + public :: calculate_drainage_source_absor contains - subroutine calculate_drainage_source_absor(state) + subroutine calculate_drainage_source_absor(state) - type(state_type), intent(inout) :: state + type(state_type), intent(inout) :: state - integer :: i - type(vector_field), pointer :: K1, foamvel, liquidvelocity, liqcontentvel, source, absor - type(scalar_field), pointer :: p, liquidcontent, K2 + integer :: i + type(vector_field), pointer :: K1, foamvel, liquidvelocity, liqcontentvel, source, absor + type(scalar_field), pointer :: p, liquidcontent, K2 - type(scalar_field) :: p_remap, rho_remap, K2_remap - type(vector_field) :: foamvel_remap, K1_remap - type(vector_field), pointer :: x + type(scalar_field) :: p_remap, rho_remap, K2_remap + type(vector_field) :: foamvel_remap, K1_remap + type(vector_field), pointer :: x - real :: atmospheric_pressure - real, allocatable, dimension(:) :: absor_val + real :: atmospheric_pressure + real, allocatable, dimension(:) :: absor_val - x => extract_vector_field(state, "Coordinate") + x => extract_vector_field(state, "Coordinate") - ! K1 is a vector based on the properties of the liquid within the Plateau borders: (0.0, -density*gravity/3*drag_coefficient*viscosity, 0.0) - K1 => extract_vector_field(state,'VelocityDrainageK1') + ! K1 is a vector based on the properties of the liquid within the Plateau borders: (0.0, -density*gravity/3*drag_coefficient*viscosity, 0.0) + K1 => extract_vector_field(state,'VelocityDrainageK1') - ! K2 is a scalar based on the properties of the liquid within the Plateau borders: sqrt(sqrt(3)-pi/2)*surface_tension/(6*drag_coefficient*viscosity) - K2 => extract_scalar_field(state,'VelocityDrainageK2') + ! K2 is a scalar based on the properties of the liquid within the Plateau borders: sqrt(sqrt(3)-pi/2)*surface_tension/(6*drag_coefficient*viscosity) + K2 => extract_scalar_field(state,'VelocityDrainageK2') - p => extract_scalar_field(state,'Pressure') + p => extract_scalar_field(state,'Pressure') - foamvel => extract_vector_field(state,'FoamVelocity') + foamvel => extract_vector_field(state,'FoamVelocity') - if (have_option("/material_phase[0]/vector_field::FoamLiquidContentVelocity/diagnostic")) then - liqcontentvel => extract_vector_field(state,'FoamLiquidContentVelocity') - liquidcontent => extract_scalar_field(state,'Density') - liquidvelocity => extract_vector_field(state,'Velocity') - call zero(liqcontentvel) - call allocate(rho_remap, liquidvelocity%mesh, 'RemappedLiquidContent') - call remap_field(liquidcontent, rho_remap) - do i=1, node_count(liqcontentvel) - call set(liqcontentvel, i, ( node_val(rho_remap, i)*node_val(liquidvelocity, i) ) ) - enddo - call deallocate(rho_remap) - else - ewrite (0,*)"WARNING: You should have a FoamLiquidContentVelocity field if you want to obtain the volumetric liquid flow at the boundaries" - endif + if (have_option("/material_phase[0]/vector_field::FoamLiquidContentVelocity/diagnostic")) then + liqcontentvel => extract_vector_field(state,'FoamLiquidContentVelocity') + liquidcontent => extract_scalar_field(state,'Density') + liquidvelocity => extract_vector_field(state,'Velocity') + call zero(liqcontentvel) + call allocate(rho_remap, liquidvelocity%mesh, 'RemappedLiquidContent') + call remap_field(liquidcontent, rho_remap) + do i=1, node_count(liqcontentvel) + call set(liqcontentvel, i, ( node_val(rho_remap, i)*node_val(liquidvelocity, i) ) ) + enddo + call deallocate(rho_remap) + else + ewrite (0,*)"WARNING: You should have a FoamLiquidContentVelocity field if you want to obtain the volumetric liquid flow at the boundaries" + endif - liquidvelocity => extract_vector_field(state,'Velocity') + liquidvelocity => extract_vector_field(state,'Velocity') - source => extract_vector_field(state,'VelocitySource') - if (have_option(trim(source%option_path)//'/diagnostic')) then - call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) - call zero(source) + source => extract_vector_field(state,'VelocitySource') + if (have_option(trim(source%option_path)//'/diagnostic')) then + call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + call zero(source) - call allocate(p_remap, source%mesh, 'RemappedPressure') - call allocate(K1_remap, source%dim, source%mesh, 'RemappedK1') - call allocate(K2_remap, source%mesh, 'RemappedK2') - call allocate(foamvel_remap, source%dim, source%mesh, 'RemappedFoamVelocity') - call remap_field(p, p_remap) - call remap_field(K1, K1_remap) - call remap_field(K2, K2_remap) - call remap_field(foamvel, foamvel_remap) + call allocate(p_remap, source%mesh, 'RemappedPressure') + call allocate(K1_remap, source%dim, source%mesh, 'RemappedK1') + call allocate(K2_remap, source%mesh, 'RemappedK2') + call allocate(foamvel_remap, source%dim, source%mesh, 'RemappedFoamVelocity') + call remap_field(p, p_remap) + call remap_field(K1, K1_remap) + call remap_field(K2, K2_remap) + call remap_field(foamvel, foamvel_remap) - do i=1, node_count(source) + do i=1, node_count(source) call set(source, i, ((-node_val(K1_remap, i)/node_val(K2_remap, i))*(node_val(p_remap, i)+atmospheric_pressure )**1.5 + (node_val(foamvel_remap,i)/node_val(K2_remap, i))*(node_val(p_remap, i)+atmospheric_pressure )**0.5)) - enddo + enddo - call deallocate(p_remap) - call deallocate(K1_remap) - call deallocate(K2_remap) - call deallocate(foamvel_remap) + call deallocate(p_remap) + call deallocate(K1_remap) + call deallocate(K2_remap) + call deallocate(foamvel_remap) - endif + endif - absor => extract_vector_field(state,'VelocityAbsorption') - if (have_option(trim(absor%option_path)//'/diagnostic')) then - call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=3.6E-8) - call zero(absor) + absor => extract_vector_field(state,'VelocityAbsorption') + if (have_option(trim(absor%option_path)//'/diagnostic')) then + call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=3.6E-8) + call zero(absor) - call allocate(p_remap, absor%mesh, 'RemappedPressure') - call allocate(K2_remap, source%mesh, 'RemappedK2') - call remap_field(p, p_remap) - call remap_field(K2, K2_remap) + call allocate(p_remap, absor%mesh, 'RemappedPressure') + call allocate(K2_remap, source%mesh, 'RemappedK2') + call remap_field(p, p_remap) + call remap_field(K2, K2_remap) - allocate (absor_val(absor%dim)) + allocate (absor_val(absor%dim)) - do i=1, node_count(absor) - absor_val = (1/node_val(K2_remap, i))*(node_val(p_remap, i)+atmospheric_pressure )**0.5 - call set(absor, i, absor_val ) - enddo + do i=1, node_count(absor) + absor_val = (1/node_val(K2_remap, i))*(node_val(p_remap, i)+atmospheric_pressure )**0.5 + call set(absor, i, absor_val ) + enddo - deallocate(absor_val) + deallocate(absor_val) - call deallocate(p_remap) - call deallocate(K2_remap) + call deallocate(p_remap) + call deallocate(K2_remap) - endif + endif - end subroutine calculate_drainage_source_absor + end subroutine calculate_drainage_source_absor end module foam_drainage diff --git a/assemble/Foam_Flow.F90 b/assemble/Foam_Flow.F90 index 22e72ea897..c629047891 100644 --- a/assemble/Foam_Flow.F90 +++ b/assemble/Foam_Flow.F90 @@ -28,317 +28,317 @@ #include "fdebug.h" module foam_flow_module - ! This module contains the options used to solve Laplace's equation for arbitrary geometries and BC's in Fluidity and to calculate the foam velocity - use fldebug - use spud - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use vector_tools - use quadrature - use elements - use sparse_tools - use transform_elements - use fetools - use fields - use state_module - use field_options - use vtk_interfaces - use sparsity_patterns - use sparse_matrices_fields - use solvers - use boundary_conditions - use sparsity_patterns_meshes - use petsc_solve_state_module - use field_derivatives - use gradient_matrix_cg, only: assemble_gradient_matrix_cg - use state_matrices_module - - implicit none - - private - public :: calculate_potential_flow, calculate_foam_velocity - - character(len = *), parameter, public :: phi_name = "FoamVelocityPotential" - character(len = *), parameter, public :: phi_sparsity_name = "FoamVelocityPotentialSparsity" - character(len = *), parameter, public :: phi_rhs_name = "FoamVelocityPotentialRhs" - character(len = *), parameter, public :: phi_m_name = "FoamVelocityPotentialMatrix" - character(len = *), parameter, public :: foamvel_name = "FoamVelocity" + ! This module contains the options used to solve Laplace's equation for arbitrary geometries and BC's in Fluidity and to calculate the foam velocity + use fldebug + use spud + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use vector_tools + use quadrature + use elements + use sparse_tools + use transform_elements + use fetools + use fields + use state_module + use field_options + use vtk_interfaces + use sparsity_patterns + use sparse_matrices_fields + use solvers + use boundary_conditions + use sparsity_patterns_meshes + use petsc_solve_state_module + use field_derivatives + use gradient_matrix_cg, only: assemble_gradient_matrix_cg + use state_matrices_module + + implicit none + + private + public :: calculate_potential_flow, calculate_foam_velocity + + character(len = *), parameter, public :: phi_name = "FoamVelocityPotential" + character(len = *), parameter, public :: phi_sparsity_name = "FoamVelocityPotentialSparsity" + character(len = *), parameter, public :: phi_rhs_name = "FoamVelocityPotentialRhs" + character(len = *), parameter, public :: phi_m_name = "FoamVelocityPotentialMatrix" + character(len = *), parameter, public :: foamvel_name = "FoamVelocity" contains - subroutine calculate_potential_flow(state, phi) + subroutine calculate_potential_flow(state, phi) - type(state_type), intent(inout) :: state - type(scalar_field), optional, intent(out) :: phi - type(csr_matrix) :: phi_m - type(scalar_field) :: phi_rhs + type(state_type), intent(inout) :: state + type(scalar_field), optional, intent(out) :: phi + type(csr_matrix) :: phi_m + type(scalar_field) :: phi_rhs - ! Step 1: Allocate and insert objects into state / extract objects from - ! state and take references - call initialise_potential_flow(phi, phi_rhs, state, phi_m) + ! Step 1: Allocate and insert objects into state / extract objects from + ! state and take references + call initialise_potential_flow(phi, phi_rhs, state, phi_m) - ! Step 2: Assemble - call assemble_potential_flow_cg(phi_rhs, state, phi_m, phi) + ! Step 2: Assemble + call assemble_potential_flow_cg(phi_rhs, state, phi_m, phi) - ! Step 3: Solve - call solve_potential_flow(phi_m, phi_rhs, phi, state) + ! Step 3: Solve + call solve_potential_flow(phi_m, phi_rhs, phi, state) - ! Step 4: Drop references - call deallocate(phi_m) - call deallocate(phi_rhs) + ! Step 4: Drop references + call deallocate(phi_m) + call deallocate(phi_rhs) - end subroutine calculate_potential_flow + end subroutine calculate_potential_flow - subroutine initialise_potential_flow(phi, phi_rhs, state, phi_m) - ! Allocate / extract FoamVelocityPotential variables. phi, phi_m and - ! phi_rhs all take references in this routine and, if new objects are - ! constructed, are inserted into state. + subroutine initialise_potential_flow(phi, phi_rhs, state, phi_m) + ! Allocate / extract FoamVelocityPotential variables. phi, phi_m and + ! phi_rhs all take references in this routine and, if new objects are + ! constructed, are inserted into state. - type(scalar_field), target, intent(out) :: phi - type(csr_matrix), intent(out) :: phi_m - type(scalar_field), intent(out) :: phi_rhs - type(state_type), intent(inout) :: state + type(scalar_field), target, intent(out) :: phi + type(csr_matrix), intent(out) :: phi_m + type(scalar_field), intent(out) :: phi_rhs + type(state_type), intent(inout) :: state - type(csr_sparsity), pointer :: phi_sparsity => null() + type(csr_sparsity), pointer :: phi_sparsity => null() - phi = extract_scalar_field(state, phi_name) + phi = extract_scalar_field(state, phi_name) - ! Matrix sparsity - phi_sparsity => get_csr_sparsity_firstorder(state, phi%mesh, phi%mesh) - call allocate(phi_m, phi_sparsity, name = phi_m_name) + ! Matrix sparsity + phi_sparsity => get_csr_sparsity_firstorder(state, phi%mesh, phi%mesh) + call allocate(phi_m, phi_sparsity, name = phi_m_name) - ! RHS - call allocate(phi_rhs, phi%mesh, phi_rhs_name) + ! RHS + call allocate(phi_rhs, phi%mesh, phi_rhs_name) - end subroutine initialise_potential_flow + end subroutine initialise_potential_flow - subroutine assemble_potential_flow_cg(phi_rhs, state, phi_m, phi) - ! Assemble Laplace's equation for FoamVelocityPotential - type(scalar_field), target, intent(inout) :: phi_rhs - type(state_type), intent(inout) :: state - type(csr_matrix), optional, intent(inout) :: phi_m - type(scalar_field), intent(inout) :: phi - type(scalar_field) :: foamvelocitypotential_bc - integer, dimension(:), allocatable :: foamvelocitypotential_bc_type - integer :: ele, sele - type(vector_field), pointer :: positions => null() + subroutine assemble_potential_flow_cg(phi_rhs, state, phi_m, phi) + ! Assemble Laplace's equation for FoamVelocityPotential + type(scalar_field), target, intent(inout) :: phi_rhs + type(state_type), intent(inout) :: state + type(csr_matrix), optional, intent(inout) :: phi_m + type(scalar_field), intent(inout) :: phi + type(scalar_field) :: foamvelocitypotential_bc + integer, dimension(:), allocatable :: foamvelocitypotential_bc_type + integer :: ele, sele + type(vector_field), pointer :: positions => null() - ewrite(1, *) "In assemble_potential_flow_cg" + ewrite(1, *) "In assemble_potential_flow_cg" - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") - call zero(phi_m) + call zero(phi_m) - call zero(phi_rhs) + call zero(phi_rhs) - ! element loop - element_loop: do ele=1, element_count(phi) - call assemble_potential_flow_element_cg(ele, phi_m, phi_rhs, positions, phi) - end do element_loop - ! end element loop + ! element loop + element_loop: do ele=1, element_count(phi) + call assemble_potential_flow_element_cg(ele, phi_m, phi_rhs, positions, phi) + end do element_loop + ! end element loop allocate(foamvelocitypotential_bc_type(surface_element_count(phi))) call get_entire_boundary_condition(phi, (/ "neumann "/), foamvelocitypotential_bc, foamvelocitypotential_bc_type) - ! surface element loop - surface_element_loop: do sele=1, surface_element_count(phi) - ele = face_ele(positions, sele) - call assemble_potential_flow_surface_element_cg(sele, ele, positions, & - & phi_rhs, phi, foamvelocitypotential_bc) - end do surface_element_loop - ! end surface element loop + ! surface element loop + surface_element_loop: do sele=1, surface_element_count(phi) + ele = face_ele(positions, sele) + call assemble_potential_flow_surface_element_cg(sele, ele, positions, & + & phi_rhs, phi, foamvelocitypotential_bc) + end do surface_element_loop + ! end surface element loop call deallocate(foamvelocitypotential_bc) - ! Set a reference node, zero at the first node of the first process - ! (should be called by all processes though) - ! This needs to be done every time, to zero the rhs - call set_reference_node(phi_m, 1, phi_rhs, 0.0) + ! Set a reference node, zero at the first node of the first process + ! (should be called by all processes though) + ! This needs to be done every time, to zero the rhs + call set_reference_node(phi_m, 1, phi_rhs, 0.0) - ewrite_minmax(phi_rhs) + ewrite_minmax(phi_rhs) - ewrite(1, *) "Exiting assemble_potential_flow_cg" + ewrite(1, *) "Exiting assemble_potential_flow_cg" - end subroutine assemble_potential_flow_cg + end subroutine assemble_potential_flow_cg - subroutine assemble_potential_flow_element_cg(ele, phi_m, phi_rhs, positions, phi) - !!< Assemble the element matrix contributions - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: phi - type(csr_matrix), optional, intent(inout) :: phi_m - type(scalar_field), intent(inout) :: phi_rhs + subroutine assemble_potential_flow_element_cg(ele, phi_m, phi_rhs, positions, phi) + !!< Assemble the element matrix contributions + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: phi + type(csr_matrix), optional, intent(inout) :: phi_m + type(scalar_field), intent(inout) :: phi_rhs - ! Node numbers of phi element: - integer, dimension(:), pointer :: phi_ele - ! Locations of nodes: - real, dimension(positions%dim, ele_loc(positions, ele)) :: x_val - ! Shape functions: - type(element_type), pointer :: phi_shape, x_shape - ! Coordinate transform*quadrature weights : - real, dimension(ele_ngi(positions, ele)) :: detwei + ! Node numbers of phi element: + integer, dimension(:), pointer :: phi_ele + ! Locations of nodes: + real, dimension(positions%dim, ele_loc(positions, ele)) :: x_val + ! Shape functions: + type(element_type), pointer :: phi_shape, x_shape + ! Coordinate transform*quadrature weights : + real, dimension(ele_ngi(positions, ele)) :: detwei - ! Locations of quadrature points - real, dimension(positions%dim,ele_ngi(positions,ele)) :: x_quad + ! Locations of quadrature points + real, dimension(positions%dim,ele_ngi(positions,ele)) :: x_quad - !Derivatives of shape function: - real, dimension(ele_loc(phi, ele), ele_ngi(phi, ele), positions%dim) :: dphi_t + !Derivatives of shape function: + real, dimension(ele_loc(phi, ele), ele_ngi(phi, ele), positions%dim) :: dphi_t - ! Local Laplacian matrix - real, dimension(ele_loc(phi, ele), ele_loc(phi, ele)) :: phi_mat + ! Local Laplacian matrix + real, dimension(ele_loc(phi, ele), ele_loc(phi, ele)) :: phi_mat - phi_ele => ele_nodes(phi, ele) - phi_shape=>ele_shape(phi, ele) + phi_ele => ele_nodes(phi, ele) + phi_shape=>ele_shape(phi, ele) - x_shape=> ele_shape(positions, ele) - ! Location of local vertices - x_val = ele_val(positions,ele) + x_shape=> ele_shape(positions, ele) + ! Location of local vertices + x_val = ele_val(positions,ele) - ! Locations of quadrature points - x_quad=ele_val_at_quad(positions, ele) + ! Locations of quadrature points + x_quad=ele_val_at_quad(positions, ele) - ! Transform derivatives and weights into physical space - call transform_to_physical(positions, ele, phi_shape, & + ! Transform derivatives and weights into physical space + call transform_to_physical(positions, ele, phi_shape, & & dshape = dphi_t, detwei = detwei) - ! Local assembly: - ! / - ! | grad N_A dot grad N_B dV - ! / - phi_mat=dshape_dot_dshape(dphi_t, dphi_t, detwei) + ! Local assembly: + ! / + ! | grad N_A dot grad N_B dV + ! / + phi_mat=dshape_dot_dshape(dphi_t, dphi_t, detwei) - ! Global assembly: - call addto(phi_m, phi_ele, phi_ele, phi_mat) + ! Global assembly: + call addto(phi_m, phi_ele, phi_ele, phi_mat) - ! The rhs is always zero for Laplace's equation - call zero(phi_rhs) + ! The rhs is always zero for Laplace's equation + call zero(phi_rhs) - end subroutine assemble_potential_flow_element_cg + end subroutine assemble_potential_flow_element_cg - subroutine assemble_potential_flow_surface_element_cg(sele, ele, positions, & - & phi_rhs, phi, foamvelocitypotential_bc) - integer, intent(in) :: sele, ele - type(scalar_field), intent(inout) :: phi_rhs + subroutine assemble_potential_flow_surface_element_cg(sele, ele, positions, & + & phi_rhs, phi, foamvelocitypotential_bc) + integer, intent(in) :: sele, ele + type(scalar_field), intent(inout) :: phi_rhs - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: phi + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: phi - type(scalar_field), intent(in) :: foamvelocitypotential_bc + type(scalar_field), intent(in) :: foamvelocitypotential_bc - integer, dimension(face_loc(phi, sele)) :: phi_nodes_bdy - real, dimension(positions%dim, ele_loc(positions, ele)) :: x_ele - real, dimension(positions%dim, face_loc(positions, sele)) :: x_ele_bdy - type(element_type), pointer :: x_shape, x_shape_bdy, phi_shape + integer, dimension(face_loc(phi, sele)) :: phi_nodes_bdy + real, dimension(positions%dim, ele_loc(positions, ele)) :: x_ele + real, dimension(positions%dim, face_loc(positions, sele)) :: x_ele_bdy + type(element_type), pointer :: x_shape, x_shape_bdy, phi_shape - real, dimension(face_ngi(positions, sele)) :: detwei_bdy - real, dimension(face_loc(phi, sele), face_loc(phi, sele)) :: face_mat + real, dimension(face_ngi(positions, sele)) :: detwei_bdy + real, dimension(face_loc(phi, sele), face_loc(phi, sele)) :: face_mat - x_ele = ele_val(positions, ele) - x_ele_bdy = face_val(positions, sele) + x_ele = ele_val(positions, ele) + x_ele_bdy = face_val(positions, sele) - x_shape=> ele_shape(positions, ele) - x_shape_bdy=>face_shape(positions, sele) + x_shape=> ele_shape(positions, ele) + x_shape_bdy=>face_shape(positions, sele) - ! Transform derivatives and weights into physical space (calculate quadrature weights) - call transform_facet_to_physical(positions, sele, detwei_f=detwei_bdy) + ! Transform derivatives and weights into physical space (calculate quadrature weights) + call transform_facet_to_physical(positions, sele, detwei_f=detwei_bdy) - ! integral over the face of the form \int N_i N_j - ! where N_i and N_j are shape functions of phi - phi_shape=> face_shape(phi, sele) - face_mat=shape_shape(phi_shape, phi_shape, detwei_bdy) + ! integral over the face of the form \int N_i N_j + ! where N_i and N_j are shape functions of phi + phi_shape=> face_shape(phi, sele) + face_mat=shape_shape(phi_shape, phi_shape, detwei_bdy) - ! global node numbers of nodes of this face - phi_nodes_bdy = face_global_nodes(phi, sele) + ! global node numbers of nodes of this face + phi_nodes_bdy = face_global_nodes(phi, sele) - ! global node numbers of nodes of this face in phi%mesh - ! this implements a Neumann bc with values given by foamvelocitypotential_bc - call addto(phi_rhs, phi_nodes_bdy, matmul(face_mat, ele_val(foamvelocitypotential_bc, sele) )) + ! global node numbers of nodes of this face in phi%mesh + ! this implements a Neumann bc with values given by foamvelocitypotential_bc + call addto(phi_rhs, phi_nodes_bdy, matmul(face_mat, ele_val(foamvelocitypotential_bc, sele) )) - end subroutine assemble_potential_flow_surface_element_cg + end subroutine assemble_potential_flow_surface_element_cg - subroutine solve_potential_flow(phi_m, phi_rhs, phi, state) + subroutine solve_potential_flow(phi_m, phi_rhs, phi, state) - type(csr_matrix), intent(in) :: phi_m - type(scalar_field), intent(in) :: phi_rhs - type(scalar_field), intent(inout) :: phi - type(state_type), intent(inout) :: state + type(csr_matrix), intent(in) :: phi_m + type(scalar_field), intent(in) :: phi_rhs + type(scalar_field), intent(inout) :: phi + type(state_type), intent(inout) :: state - call petsc_solve(phi, phi_m, phi_rhs, state) + call petsc_solve(phi, phi_m, phi_rhs, state) - ewrite_minmax(phi) + ewrite_minmax(phi) - end subroutine solve_potential_flow + end subroutine solve_potential_flow - subroutine calculate_foam_velocity(state, foamvel) + subroutine calculate_foam_velocity(state, foamvel) - type(state_type), intent(inout) :: state - type(vector_field), pointer, intent(out) :: foamvel - type(scalar_field), pointer :: field - type(csr_sparsity) :: gradient_sparsity - type(block_csr_matrix) :: C_m - type(csr_sparsity) :: mass_sparsity - type(csr_matrix) :: mass - type(vector_field) :: cfield + type(state_type), intent(inout) :: state + type(vector_field), pointer, intent(out) :: foamvel + type(scalar_field), pointer :: field + type(csr_sparsity) :: gradient_sparsity + type(block_csr_matrix) :: C_m + type(csr_sparsity) :: mass_sparsity + type(csr_matrix) :: mass + type(vector_field) :: cfield - integer :: i + integer :: i - foamvel => extract_vector_field(state, foamvel_name) - if (have_option(trim(foamvel%option_path)//'/diagnostic')) then - field=>extract_scalar_field(state, "FoamVelocityPotential") + foamvel => extract_vector_field(state, foamvel_name) + if (have_option(trim(foamvel%option_path)//'/diagnostic')) then + field=>extract_scalar_field(state, "FoamVelocityPotential") - !The following does the same as the subroutine calculate_grad_fe in Diagnostic_Fields_Matrices.F90 - call allocate(cfield, foamvel%dim, foamvel%mesh, name="CField") + !The following does the same as the subroutine calculate_grad_fe in Diagnostic_Fields_Matrices.F90 + call allocate(cfield, foamvel%dim, foamvel%mesh, name="CField") - ! Sparsity of C^T - the transpose of the gradient operator. - gradient_sparsity=make_sparsity(foamvel%mesh, field%mesh, "GradientSparsity") - call allocate(C_m, gradient_sparsity, (/foamvel%dim, 1/), name="GradientMatrix" ) + ! Sparsity of C^T - the transpose of the gradient operator. + gradient_sparsity=make_sparsity(foamvel%mesh, field%mesh, "GradientSparsity") + call allocate(C_m, gradient_sparsity, (/foamvel%dim, 1/), name="GradientMatrix" ) - mass_sparsity=make_sparsity(foamvel%mesh, foamvel%mesh, "MassSparsity") - call allocate(mass, mass_sparsity, name="MassMatrix") + mass_sparsity=make_sparsity(foamvel%mesh, foamvel%mesh, "MassSparsity") + call allocate(mass, mass_sparsity, name="MassMatrix") - call assemble_gradient_matrix_cg(C_m, state, & - test_mesh=foamvel%mesh, field=field, & - option_path=trim(foamvel%option_path), & - grad_mass=mass) + call assemble_gradient_matrix_cg(C_m, state, & + test_mesh=foamvel%mesh, field=field, & + option_path=trim(foamvel%option_path), & + grad_mass=mass) - call mult(cfield, C_m, field) + call mult(cfield, C_m, field) - call zero(foamvel) - call petsc_solve(foamvel, mass, cfield) + call zero(foamvel) + call petsc_solve(foamvel, mass, cfield) - call deallocate(gradient_sparsity) - call deallocate(C_m) - call deallocate(mass_sparsity) - call deallocate(mass) - call deallocate(cfield) + call deallocate(gradient_sparsity) + call deallocate(C_m) + call deallocate(mass_sparsity) + call deallocate(mass) + call deallocate(cfield) - !Changing the sign since foamvel= -grad phi - do i=1, node_count(foamvel) - call set(foamvel, i, ( -node_val(foamvel, i) ) ) - enddo + !Changing the sign since foamvel= -grad phi + do i=1, node_count(foamvel) + call set(foamvel, i, ( -node_val(foamvel, i) ) ) + enddo - ewrite_minmax(foamvel) + ewrite_minmax(foamvel) - endif + endif - end subroutine calculate_foam_velocity + end subroutine calculate_foam_velocity diff --git a/assemble/Free_Surface.F90 b/assemble/Free_Surface.F90 index decd6102ee..b32cadc5c7 100644 --- a/assemble/Free_Surface.F90 +++ b/assemble/Free_Surface.F90 @@ -27,235 +27,235 @@ #include "fdebug.h" module free_surface_module - use fldebug - use integer_set_module - use data_structures - use spud - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str, present_and_true - use parallel_tools - use sparse_tools - use parallel_fields - use eventcounter - use cv_faces - use transform_elements - use fetools - use fields - use sparse_tools_petsc - use state_module - use sparse_matrices_fields - use boundary_conditions - use halos - use field_options - use vertical_extrapolation_module - use physics_from_options - use coordinates - use tidal_module, only: calculate_diagnostic_equilibrium_pressure - use sparsity_patterns - use sparsity_patterns_meshes - use solvers - use cv_shape_functions - -implicit none - -private - -public move_mesh_free_surface, add_free_surface_to_cmc_projection, & - vertical_prolongator_from_free_surface, & - free_surface_nodes, calculate_diagnostic_free_surface, & - add_free_surface_to_poisson_rhs, copy_poisson_solution_to_interior, & - calculate_diagnostic_wettingdrying_alpha, insert_original_distance_to_bottom, & - calculate_volume_by_surface_integral -public get_extended_pressure_mesh_for_viscous_free_surface, copy_to_extended_p, & - get_extended_velocity_divergence_matrix, get_extended_pressure_poisson_matrix, & - get_extended_schur_auxillary_sparsity, & - update_pressure_and_viscous_free_surface, & - add_implicit_viscous_free_surface_integrals, & - add_implicit_viscous_free_surface_integrals_cv, & - add_implicit_viscous_free_surface_scaled_mass_integrals, update_prognostic_free_surface, & - update_implicit_scaled_free_surface, has_implicit_viscous_free_surface_bc, & - has_explicit_viscous_free_surface_bc, has_standard_free_surface_bc, & - add_explicit_viscous_free_surface_integrals, & - add_explicit_viscous_free_surface_integrals_cv - -public free_surface_module_check_options + use fldebug + use integer_set_module + use data_structures + use spud + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str, present_and_true + use parallel_tools + use sparse_tools + use parallel_fields + use eventcounter + use cv_faces + use transform_elements + use fetools + use fields + use sparse_tools_petsc + use state_module + use sparse_matrices_fields + use boundary_conditions + use halos + use field_options + use vertical_extrapolation_module + use physics_from_options + use coordinates + use tidal_module, only: calculate_diagnostic_equilibrium_pressure + use sparsity_patterns + use sparsity_patterns_meshes + use solvers + use cv_shape_functions + + implicit none + + private + + public move_mesh_free_surface, add_free_surface_to_cmc_projection, & + vertical_prolongator_from_free_surface, & + free_surface_nodes, calculate_diagnostic_free_surface, & + add_free_surface_to_poisson_rhs, copy_poisson_solution_to_interior, & + calculate_diagnostic_wettingdrying_alpha, insert_original_distance_to_bottom, & + calculate_volume_by_surface_integral + public get_extended_pressure_mesh_for_viscous_free_surface, copy_to_extended_p, & + get_extended_velocity_divergence_matrix, get_extended_pressure_poisson_matrix, & + get_extended_schur_auxillary_sparsity, & + update_pressure_and_viscous_free_surface, & + add_implicit_viscous_free_surface_integrals, & + add_implicit_viscous_free_surface_integrals_cv, & + add_implicit_viscous_free_surface_scaled_mass_integrals, update_prognostic_free_surface, & + update_implicit_scaled_free_surface, has_implicit_viscous_free_surface_bc, & + has_explicit_viscous_free_surface_bc, has_standard_free_surface_bc, & + add_explicit_viscous_free_surface_integrals, & + add_explicit_viscous_free_surface_integrals_cv + + public free_surface_module_check_options contains - function has_standard_free_surface_bc(u) result(standard_free_surface) - !!< whether velocity has a 'standard' free surface boundary condition, - !!< i.e. a fs bc without the no_normal_stress option - type(vector_field), intent(in):: u - logical:: standard_free_surface + function has_standard_free_surface_bc(u) result(standard_free_surface) + !!< whether velocity has a 'standard' free surface boundary condition, + !!< i.e. a fs bc without the no_normal_stress option + type(vector_field), intent(in):: u + logical:: standard_free_surface - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN) :: bc_option_path - integer:: i + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN) :: bc_option_path + integer:: i - standard_free_surface = .false. - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - option_path=bc_option_path) - if (bctype=="free_surface") then + standard_free_surface = .false. + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + option_path=bc_option_path) + if (bctype=="free_surface") then - if(.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress")) then - standard_free_surface = .true. - return - end if - end if - end do - - end function has_standard_free_surface_bc - - function has_implicit_viscous_free_surface_bc(u) result(implicit_free_surface) - !!< whether velocity has a free surface boundary condition with - !!< the no_normal_stress option but without the explicit option - type(vector_field), intent(in):: u - logical:: implicit_free_surface - - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN) :: bc_option_path - integer:: i - - implicit_free_surface = .false. - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - option_path=bc_option_path) - if (bctype=="free_surface") then - - if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then - implicit_free_surface = .true. - return - end if - end if - end do - - end function has_implicit_viscous_free_surface_bc - - function has_explicit_viscous_free_surface_bc(u) result(explicit_free_surface) - !!< whether velocity has a free surface boundary condition with - !!< the no_normal_stress option and the explicit option - type(vector_field), intent(in):: u - logical:: explicit_free_surface - - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN) :: bc_option_path - integer:: i - - explicit_free_surface = .false. - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - option_path=bc_option_path) - if (bctype=="free_surface") then - - if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & - have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit")) then - explicit_free_surface = .true. - return - end if - end if - end do + if(.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress")) then + standard_free_surface = .true. + return + end if + end if + end do - end function has_explicit_viscous_free_surface_bc + end function has_standard_free_surface_bc - subroutine update_implicit_scaled_free_surface(states) - !!< Set OldScaledFreeSurface to ScaledFreeSurface, these - !!< ScaledFreeSurface is the surface fields \Delta\rho g\eta that we solve for - !!< with the implicit viscous fs method - type(state_type), dimension(:), intent(in) :: states + function has_implicit_viscous_free_surface_bc(u) result(implicit_free_surface) + !!< whether velocity has a free surface boundary condition with + !!< the no_normal_stress option but without the explicit option + type(vector_field), intent(in):: u + logical:: implicit_free_surface - type(scalar_field), pointer:: free_surface, scaled_fs, old_scaled_fs - integer:: i, fs_stat + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN) :: bc_option_path + integer:: i - do i=1,size(states) - free_surface => extract_scalar_field(states(i), "FreeSurface", stat=fs_stat) - if(fs_stat==0) then - if(have_option(trim(free_surface%option_path)//"/prognostic")) then - if (has_boundary_condition_name(free_surface, "_implicit_free_surface")) then - ewrite(2,*) 'Updating OldScaledFreeSurface surface field for the FreeSurface field in state '//trim(states(i)%name)//'.' + implicit_free_surface = .false. + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + option_path=bc_option_path) + if (bctype=="free_surface") then + + if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then + implicit_free_surface = .true. + return + end if + end if + end do - scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "ScaledFreeSurface") - old_scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "OldScaledFreeSurface") + end function has_implicit_viscous_free_surface_bc - call set(old_scaled_fs, scaled_fs) + function has_explicit_viscous_free_surface_bc(u) result(explicit_free_surface) + !!< whether velocity has a free surface boundary condition with + !!< the no_normal_stress option and the explicit option + type(vector_field), intent(in):: u + logical:: explicit_free_surface - end if - end if - end if - end do - - end subroutine update_implicit_scaled_free_surface - - subroutine insert_original_distance_to_bottom(state) - !!< Adds the OriginalDistanceToBottom field into the state. - !!< Note: In order to to get the correct values, this subroutine - !!< has to be called before the first timestep. - type(state_type), intent(inout) :: state - type(mesh_type), pointer :: p_mesh - type(scalar_field), pointer :: bottomdist - type(scalar_field) :: original_bottomdist, original_bottomdist_remap - - if (.not. has_scalar_field(state, "OriginalDistanceToBottom")) then - ewrite(2, *) "Inserting OriginalDistanceToBottom field into state." - bottomdist => extract_scalar_field(state, "DistanceToBottom") - call allocate(original_bottomdist, bottomdist%mesh, "OriginalDistanceToBottom") - call zero(original_bottomdist) - call addto(original_bottomdist, bottomdist) - call insert(state, original_bottomdist, name="OriginalDistanceToBottom") - call deallocate(original_bottomdist) - - ! We also cache the OriginalDistanceToBottom on the pressure mesh - ewrite(2, *) "Inserting OriginalDistanceToBottomPressureMesh field into state." - p_mesh => extract_pressure_mesh(state) - call allocate(original_bottomdist_remap, p_mesh, "OriginalDistanceToBottomPressureMesh") - call remap_field(original_bottomdist, original_bottomdist_remap) - call insert(state, original_bottomdist_remap, name="OriginalDistanceToBottomPressureMesh") - call deallocate(original_bottomdist_remap) - end if - - end subroutine insert_original_distance_to_bottom - - subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & - theta_pressure_gradient, theta_divergence, & - assemble_cmc, rhs) - !!< Adds a boundary integral to the continuity equation - !!< that weakly enforces the kinematic boundary condition. - !!< - !!< The free surface is combined in with the pressure field such that - !!< *at* the free surface p=g \Delta rho \eta. This has the advantage of combining - !!< the pressure gradient and free surface gradient terms in the momentum - !!< equation. It solves the continuity equation directly coupled with - !!< the free surface. - !!< With this approach all pressures are considered at the integer time - !!< levels, i.e. we apply a theta weighting for the pressure gradient term - !!< in the momentum equation: - !!< M (u^n+1-u^n) - dt C p^{n+theta_pg} + ... = 0 - !!< We're solving the continuity equation: - !!< C^T u^{n+theta_div}+ alpha M_fs p^{n+1}-p^n = 0 - !!< which leads to a projection equation of: - !!< ( C^T M^-1 C dt dp + coef M_fs ) phi = - !!< theta_div C^T u* + (1-theta_div) C^T u^n - - !!< alpha M_fs (p*-p^n) - !!< where M_fs is the free surface integral of M_i M_j, - !!< alpha=1/(g dt), coef=alpha/(theta_div theta_pg dt) - !!< and phi=dp theta_div theta_pg dt and dp=p^n+1-p^* - !!< Notes: - !!< - the above is slightly misleading because with a prognostic f.s. we only apply theta weighting - !!< to the free surface (not interior pressure), but for the purposes of this routine we can ignore that - !!< - the above assumes \Delta rho=1 but should be included in alpha M_fs (divided by). For - !!< this will be included in the mass matrix, otherwise we apply it as an overall factor 1/\Delta rho - - type(state_type), intent(inout) :: state - type(csr_matrix), intent(inout) :: cmc - real, intent(in) :: dt - real, intent(in) :: theta_pressure_gradient - real, intent(in) :: theta_divergence - !! only add in to the matrix if assemble_cmc==.true. - !! if .not. assemble_cmc we still need to add in a correction - !! if the timestep has changed since last call - logical, intent(in):: assemble_cmc - type(scalar_field), optional, intent(inout) :: rhs + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN) :: bc_option_path + integer:: i + + explicit_free_surface = .false. + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + option_path=bc_option_path) + if (bctype=="free_surface") then + + if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & + have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit")) then + explicit_free_surface = .true. + return + end if + end if + end do + + end function has_explicit_viscous_free_surface_bc + + subroutine update_implicit_scaled_free_surface(states) + !!< Set OldScaledFreeSurface to ScaledFreeSurface, these + !!< ScaledFreeSurface is the surface fields \Delta\rho g\eta that we solve for + !!< with the implicit viscous fs method + type(state_type), dimension(:), intent(in) :: states + + type(scalar_field), pointer:: free_surface, scaled_fs, old_scaled_fs + integer:: i, fs_stat + + do i=1,size(states) + free_surface => extract_scalar_field(states(i), "FreeSurface", stat=fs_stat) + if(fs_stat==0) then + if(have_option(trim(free_surface%option_path)//"/prognostic")) then + if (has_boundary_condition_name(free_surface, "_implicit_free_surface")) then + ewrite(2,*) 'Updating OldScaledFreeSurface surface field for the FreeSurface field in state '//trim(states(i)%name)//'.' + + scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "ScaledFreeSurface") + old_scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "OldScaledFreeSurface") + + call set(old_scaled_fs, scaled_fs) + + end if + end if + end if + end do + + end subroutine update_implicit_scaled_free_surface + + subroutine insert_original_distance_to_bottom(state) + !!< Adds the OriginalDistanceToBottom field into the state. + !!< Note: In order to to get the correct values, this subroutine + !!< has to be called before the first timestep. + type(state_type), intent(inout) :: state + type(mesh_type), pointer :: p_mesh + type(scalar_field), pointer :: bottomdist + type(scalar_field) :: original_bottomdist, original_bottomdist_remap + + if (.not. has_scalar_field(state, "OriginalDistanceToBottom")) then + ewrite(2, *) "Inserting OriginalDistanceToBottom field into state." + bottomdist => extract_scalar_field(state, "DistanceToBottom") + call allocate(original_bottomdist, bottomdist%mesh, "OriginalDistanceToBottom") + call zero(original_bottomdist) + call addto(original_bottomdist, bottomdist) + call insert(state, original_bottomdist, name="OriginalDistanceToBottom") + call deallocate(original_bottomdist) + + ! We also cache the OriginalDistanceToBottom on the pressure mesh + ewrite(2, *) "Inserting OriginalDistanceToBottomPressureMesh field into state." + p_mesh => extract_pressure_mesh(state) + call allocate(original_bottomdist_remap, p_mesh, "OriginalDistanceToBottomPressureMesh") + call remap_field(original_bottomdist, original_bottomdist_remap) + call insert(state, original_bottomdist_remap, name="OriginalDistanceToBottomPressureMesh") + call deallocate(original_bottomdist_remap) + end if + + end subroutine insert_original_distance_to_bottom + + subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & + theta_pressure_gradient, theta_divergence, & + assemble_cmc, rhs) + !!< Adds a boundary integral to the continuity equation + !!< that weakly enforces the kinematic boundary condition. + !!< + !!< The free surface is combined in with the pressure field such that + !!< *at* the free surface p=g \Delta rho \eta. This has the advantage of combining + !!< the pressure gradient and free surface gradient terms in the momentum + !!< equation. It solves the continuity equation directly coupled with + !!< the free surface. + !!< With this approach all pressures are considered at the integer time + !!< levels, i.e. we apply a theta weighting for the pressure gradient term + !!< in the momentum equation: + !!< M (u^n+1-u^n) - dt C p^{n+theta_pg} + ... = 0 + !!< We're solving the continuity equation: + !!< C^T u^{n+theta_div}+ alpha M_fs p^{n+1}-p^n = 0 + !!< which leads to a projection equation of: + !!< ( C^T M^-1 C dt dp + coef M_fs ) phi = + !!< theta_div C^T u* + (1-theta_div) C^T u^n - + !!< alpha M_fs (p*-p^n) + !!< where M_fs is the free surface integral of M_i M_j, + !!< alpha=1/(g dt), coef=alpha/(theta_div theta_pg dt) + !!< and phi=dp theta_div theta_pg dt and dp=p^n+1-p^* + !!< Notes: + !!< - the above is slightly misleading because with a prognostic f.s. we only apply theta weighting + !!< to the free surface (not interior pressure), but for the purposes of this routine we can ignore that + !!< - the above assumes \Delta rho=1 but should be included in alpha M_fs (divided by). For + !!< this will be included in the mass matrix, otherwise we apply it as an overall factor 1/\Delta rho + + type(state_type), intent(inout) :: state + type(csr_matrix), intent(inout) :: cmc + real, intent(in) :: dt + real, intent(in) :: theta_pressure_gradient + real, intent(in) :: theta_divergence + !! only add in to the matrix if assemble_cmc==.true. + !! if .not. assemble_cmc we still need to add in a correction + !! if the timestep has changed since last call + logical, intent(in):: assemble_cmc + type(scalar_field), optional, intent(inout) :: rhs type(integer_hash_table):: sele_to_fs_ele type(vector_field), pointer:: positions, u, gravity_normal, old_positions @@ -285,7 +285,7 @@ subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & ! gravity acceleration call get_option('/physical_parameters/gravity/magnitude', g, stat=grav_stat) if (grav_stat/=0) then - FLExit("For a free surface you need gravity") + FLExit("For a free surface you need gravity") end if ! get the pressure, and the pressure at the beginning of the time step @@ -296,20 +296,20 @@ subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & ! the prognostic free surface can only be used with the no_normal_stress option implicit_prognostic_fs=has_implicit_viscous_free_surface_bc(u) if(implicit_prognostic_fs) then - free_surface => extract_scalar_field(state, "FreeSurface") - assert(have_option(trim(free_surface%option_path)//"/prognostic")) - if (.not. has_boundary_condition_name(free_surface, "_implicit_free_surface")) then - call initialise_implicit_prognostic_free_surface(state, free_surface, u) - end if - ! obtain the f.s. surface mesh that has been stored under the - ! "_implicit_free_surface" boundary condition - call get_boundary_condition(free_surface, "_implicit_free_surface", & - surface_mesh=fs_mesh, surface_element_list=fs_surface_element_list) - ! create a map from face numbers to element numbers in fs_mesh - call invert_set(fs_surface_element_list, sele_to_fs_ele) - scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "ScaledFreeSurface") - old_scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "OldScaledFreeSurface") - embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") + free_surface => extract_scalar_field(state, "FreeSurface") + assert(have_option(trim(free_surface%option_path)//"/prognostic")) + if (.not. has_boundary_condition_name(free_surface, "_implicit_free_surface")) then + call initialise_implicit_prognostic_free_surface(state, free_surface, u) + end if + ! obtain the f.s. surface mesh that has been stored under the + ! "_implicit_free_surface" boundary condition + call get_boundary_condition(free_surface, "_implicit_free_surface", & + surface_mesh=fs_mesh, surface_element_list=fs_surface_element_list) + ! create a map from face numbers to element numbers in fs_mesh + call invert_set(fs_surface_element_list, sele_to_fs_ele) + scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "ScaledFreeSurface") + old_scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "OldScaledFreeSurface") + embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") end if ! reference density @@ -320,13 +320,13 @@ subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & have_wd=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying") have_wd_node_int=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/conserve_geometric_volume") if (have_wd) then - if (.not. assemble_cmc) then - ewrite(-1,*) "Wetting and drying needs to be reassembled at each timestep at the moment. Switch it on "//& - &"in diamond under .../Pressure/prognostic/scheme/update_discretised_equation" - FLExit("Error in user options") - end if - call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) - original_bottomdist_remap=>extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") + if (.not. assemble_cmc) then + ewrite(-1,*) "Wetting and drying needs to be reassembled at each timestep at the moment. Switch it on "//& + &"in diamond under .../Pressure/prognostic/scheme/update_discretised_equation" + FLExit("Error in user options") + end if + call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) + original_bottomdist_remap=>extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") end if move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") @@ -336,8 +336,8 @@ subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & ! (and on top unless we use a prognostic fs, which may be on the bottom) include_normals = move_mesh .or. implicit_prognostic_fs if (include_normals) then - ewrite(2,*) 'Including inner product of normals in kinematic bc' - gravity_normal => extract_vector_field(state, "GravityDirection") + ewrite(2,*) 'Including inner product of normals in kinematic bc' + gravity_normal => extract_vector_field(state, "GravityDirection") end if ewrite_minmax(p) @@ -347,104 +347,104 @@ subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & end if if (move_mesh) then - positions => extract_vector_field(state, "IteratedCoordinate") - old_positions => extract_vector_field(state, "OldCoordinate") + positions => extract_vector_field(state, "IteratedCoordinate") + old_positions => extract_vector_field(state, "OldCoordinate") else - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") end if ! only add to cmc if we're reassembling it (assemble_cmc = .true.) ! or if the timestep has changed addto_cmc = assemble_cmc.or.& - (have_option("/timestepping/adaptive_timestep").and.(dt/=dt_old)) + (have_option("/timestepping/adaptive_timestep").and.(dt/=dt_old)) any_variable_density = .false. do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_mesh=surface_mesh, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface" .and. size(surface_element_list)>0) then - - if (have_option(trim(fs_option_path)//"/type[0]/no_normal_stress").and. & - (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then - assert(implicit_prognostic_fs) - use_fs_mesh=.true. - else - use_fs_mesh=.false. - end if - radial_fs = have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/radial_normals") - - variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") - if (variable_density .and. move_mesh) then - FLExit("Free surface with variable density and mesh movement not implemented") - end if - if (variable_density .and. (.not. have_density)) then - FLExit("Variable density free surface requires a Density field.") - end if - if (variable_density) then - if(.not.has_scalar_surface_field(u, i, "OldSurfaceDensity")) then - - if(.not.assemble_cmc) then - FLAbort("Adding free surface to cmc with variable density but no old surface density field available.") - end if - - call create_surface_mesh(dens_surface_mesh, dens_surface_node_list, & - density%mesh, surface_element_list, "FreeSurfaceDensityMesh") - - allocate(old_surface_density) - call allocate(old_surface_density, dens_surface_mesh, "OldSurfaceDensity") - call deallocate(dens_surface_mesh) - - ! shouldn't be used this time around anyway, thanks to coef_old=0.0 - call remap_field_to_surface(density, old_surface_density, surface_element_list) - - call insert_surface_field(u, i, old_surface_density) - - call deallocate(old_surface_density) - deallocate(old_surface_density) + call get_boundary_condition(u, i, type=bctype, & + surface_mesh=surface_mesh, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface" .and. size(surface_element_list)>0) then + + if (have_option(trim(fs_option_path)//"/type[0]/no_normal_stress").and. & + (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then + assert(implicit_prognostic_fs) + use_fs_mesh=.true. + else + use_fs_mesh=.false. + end if + radial_fs = have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/radial_normals") + + variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") + if (variable_density .and. move_mesh) then + FLExit("Free surface with variable density and mesh movement not implemented") + end if + if (variable_density .and. (.not. have_density)) then + FLExit("Variable density free surface requires a Density field.") + end if + if (variable_density) then + if(.not.has_scalar_surface_field(u, i, "OldSurfaceDensity")) then + + if(.not.assemble_cmc) then + FLAbort("Adding free surface to cmc with variable density but no old surface density field available.") + end if + + call create_surface_mesh(dens_surface_mesh, dens_surface_node_list, & + density%mesh, surface_element_list, "FreeSurfaceDensityMesh") + + allocate(old_surface_density) + call allocate(old_surface_density, dens_surface_mesh, "OldSurfaceDensity") + call deallocate(dens_surface_mesh) + + ! shouldn't be used this time around anyway, thanks to coef_old=0.0 + call remap_field_to_surface(density, old_surface_density, surface_element_list) + + call insert_surface_field(u, i, old_surface_density) + + call deallocate(old_surface_density) + deallocate(old_surface_density) + end if + old_surface_density => extract_scalar_surface_field(u, i, "OldSurfaceDensity") + + end if + any_variable_density = any_variable_density .or. variable_density + + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 + ! delta_rho is only used when .not. variable_density: + if (have_external_density) then + delta_rho = rho0 - node_val(external_density, 1) + else + delta_rho = rho0 end if - old_surface_density => extract_scalar_surface_field(u, i, "OldSurfaceDensity") - - end if - any_variable_density = any_variable_density .or. variable_density - - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - ! delta_rho is only used when .not. variable_density: - if (have_external_density) then - delta_rho = rho0 - node_val(external_density, 1) - else - delta_rho = rho0 - end if - - alpha=1.0/g/dt ! delta_rho included in alpha and coeff within element loop - coef = alpha/(theta_pressure_gradient*theta_divergence*dt) - - if (assemble_cmc) then - coef_old=0.0 - else - alpha_old=1.0/g/dt_old - coef_old = alpha_old/(theta_pressure_gradient*theta_divergence*dt_old) - end if - - do j=1, size(surface_element_list) - call add_free_surface_element(j, surface_element_list(j)) - end do - - if(variable_density) then - ! save the current density at the surface for next time - call remap_field_to_surface(density, old_surface_density, surface_element_list) - end if - - end if + + alpha=1.0/g/dt ! delta_rho included in alpha and coeff within element loop + coef = alpha/(theta_pressure_gradient*theta_divergence*dt) + + if (assemble_cmc) then + coef_old=0.0 + else + alpha_old=1.0/g/dt_old + coef_old = alpha_old/(theta_pressure_gradient*theta_divergence*dt_old) + end if + + do j=1, size(surface_element_list) + call add_free_surface_element(j, surface_element_list(j)) + end do + + if(variable_density) then + ! save the current density at the surface for next time + call remap_field_to_surface(density, old_surface_density, surface_element_list) + end if + + end if end do if(addto_cmc.or.any_variable_density) then - ! cmc has been modified (most likely by changing the timestep) - ! therefore we need to invalidate the solver context - call destroy_solver_cache(cmc) + ! cmc has been modified (most likely by changing the timestep) + ! therefore we need to invalidate the solver context + call destroy_solver_cache(cmc) end if if (implicit_prognostic_fs) then - call deallocate(sele_to_fs_ele) + call deallocate(sele_to_fs_ele) end if ! save the current timestep, so we know how much to add when it changes @@ -454,2499 +454,2499 @@ subroutine add_free_surface_to_cmc_projection(state, cmc, dt, & ewrite_minmax(rhs) end if - contains + contains - subroutine add_free_surface_element(surface_mesh_ele, sele) - integer, intent(in):: surface_mesh_ele, sele ! element number in surface mesh and facet number in full mesh + subroutine add_free_surface_element(surface_mesh_ele, sele) + integer, intent(in):: surface_mesh_ele, sele ! element number in surface mesh and facet number in full mesh - integer, dimension(face_loc(p, sele)):: nodes - integer :: i + integer, dimension(face_loc(p, sele)):: nodes + integer :: i - real, dimension(face_loc(p, sele)):: top_pressures, old_top_pressures - real, dimension(positions%dim, face_ngi(positions, sele)):: normals - real, dimension(face_loc(p, sele), face_loc(p, sele)):: mass_ele, mass_ele_wd, mass_ele_old, mass_ele_old_wd - real, dimension(face_ngi(p, sele)):: detwei, alpha_wetdry_quad, alpha_wetdry_quad_prevp - real, dimension(face_loc(p, sele)):: alpha_wetdry, alpha_wetdry_prevp + real, dimension(face_loc(p, sele)):: top_pressures, old_top_pressures + real, dimension(positions%dim, face_ngi(positions, sele)):: normals + real, dimension(face_loc(p, sele), face_loc(p, sele)):: mass_ele, mass_ele_wd, mass_ele_old, mass_ele_old_wd + real, dimension(face_ngi(p, sele)):: detwei, alpha_wetdry_quad, alpha_wetdry_quad_prevp + real, dimension(face_loc(p, sele)):: alpha_wetdry, alpha_wetdry_prevp - real, dimension(face_ngi(p, sele)):: inv_delta_rho_quad, old_inv_delta_rho_quad + real, dimension(face_ngi(p, sele)):: inv_delta_rho_quad, old_inv_delta_rho_quad - if(radial_fs) then - ! we assume the gravity and surface normal are the same (both radial) - ! we do however need to include their relative sign - call transform_facet_to_physical(positions, sele, detwei_f=detwei,& + if(radial_fs) then + ! we assume the gravity and surface normal are the same (both radial) + ! we do however need to include their relative sign + call transform_facet_to_physical(positions, sele, detwei_f=detwei,& & normal=normals) - detwei=detwei*(-1.0)*sign(1.0, sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1)) - else if(include_normals) then - call transform_facet_to_physical(positions, sele, detwei_f=detwei,& + detwei=detwei*(-1.0)*sign(1.0, sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1)) + else if(include_normals) then + call transform_facet_to_physical(positions, sele, detwei_f=detwei,& & normal=normals) - ! at each gauss point multiply with inner product of gravity and surface normal - detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) - else - call transform_facet_to_physical(positions, sele, detwei_f=detwei) + ! at each gauss point multiply with inner product of gravity and surface normal + detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) + else + call transform_facet_to_physical(positions, sele, detwei_f=detwei) + end if + + if(variable_density) then + if (have_external_density) then + inv_delta_rho_quad = 1.0/(face_val_at_quad(density, sele) - ele_val_at_quad(external_density, surface_mesh_ele)) + old_inv_delta_rho_quad = 1.0/(ele_val_at_quad(old_surface_density, surface_mesh_ele) - & + ele_val_at_quad(external_density, surface_mesh_ele)) + else + inv_delta_rho_quad = 1.0/face_val_at_quad(density, sele) + old_inv_delta_rho_quad = 1.0/ele_val_at_quad(old_surface_density, surface_mesh_ele) + end if + end if + + if (have_wd) then + if (have_wd_node_int) then + call compute_alpha_wetdry(p, sele, alpha_wetdry) + call compute_alpha_wetdry(prevp, sele, alpha_wetdry_prevp) + else + call compute_alpha_wetdry_quad(p, sele, alpha_wetdry_quad) + call compute_alpha_wetdry_quad(prevp, sele, alpha_wetdry_quad_prevp) + end if + end if + + if (have_wd .and. .not. have_wd_node_int) then + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*(1.0-alpha_wetdry_quad)) + mass_ele_wd=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*alpha_wetdry_quad) + else + if (variable_density) then ! this excludes the case of a moving mesh so we use mass_ele_old here too + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*inv_delta_rho_quad) + mass_ele_old=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*old_inv_delta_rho_quad) + else + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) + end if + if (have_wd .and. have_wd_node_int) then + mass_ele_wd=mass_ele + do i=1,size(mass_ele,1) + mass_ele(i,:)=mass_ele(i,:)*(1.0-alpha_wetdry) + mass_ele_wd(i,:)=mass_ele_wd(i,:)*alpha_wetdry + end do + end if + end if + + if (use_fs_mesh) then + nodes = ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)) + top_pressures = ele_val(scaled_fs, fetch(sele_to_fs_ele, sele)) + old_top_pressures = ele_val(old_scaled_fs, fetch(sele_to_fs_ele, sele)) + else + nodes = face_global_nodes(p, sele) + top_pressures = face_val(p, sele) + old_top_pressures = face_val(prevp, sele) + end if + + if (addto_cmc.or.variable_density) then + ! we consider the projection equation to solve for + ! phi=theta_pressure_gradient theta_divergence dt dp, so that the f.s. integral + ! alpha M_fs dp=alpha M_fs phi/(theta_pressure_gradient theta_divergence g dt**2) + ! =coef M_fs phi + if(variable_density) then + call addto(cmc, nodes, nodes, & + (coef*mass_ele - coef_old*mass_ele_old)) ! here, delta_rho is already incorporated into mass_ele and mass_ele_old + else + call addto(cmc, nodes, nodes, & + ((coef-coef_old)/delta_rho)*mass_ele) + end if + end if + if (move_mesh) then + ! detwei and normals at the begin of the time step + call transform_facet_to_physical(old_positions, sele, detwei_f=detwei,& + & normal=normals) + ! at each gauss point multiply with inner product of gravity and surface normal + detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) + if (have_wd .and. .not. have_wd_node_int) then + mass_ele_old=shape_shape(face_shape(prevp, sele), face_shape(prevp, sele), detwei*(1.0-alpha_wetdry_quad_prevp)) + mass_ele_old_wd=shape_shape(face_shape(prevp, sele), face_shape(prevp, sele), detwei*alpha_wetdry_quad_prevp) + else + mass_ele_old=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) + if (have_wd .and. have_wd_node_int) then + mass_ele_old_wd=mass_ele_old + do i=1,size(mass_ele_old,1) + mass_ele_old(i,:)=mass_ele_old(i,:)*(1.0-alpha_wetdry_prevp) + mass_ele_old_wd(i,:)=mass_ele_old_wd(i,:)*alpha_wetdry_prevp + end do + end if + end if + + if(present(rhs)) then + assert(.not. variable_density) + call addto(rhs, nodes, & + -(matmul(mass_ele, top_pressures) & + -matmul(mass_ele_old, old_top_pressures))*alpha/delta_rho) + end if + if (have_wd .and. present(rhs)) then + call addto(rhs, nodes, & + +(matmul(mass_ele_wd, face_val(original_bottomdist_remap, sele)-d0) & + -matmul(mass_ele_old_wd, face_val(original_bottomdist_remap,sele)-d0))*alpha*g) + end if + + else + ! no mesh movement - just use the same mass matrix as above + if(present(rhs)) then + if (variable_density) then + call addto(rhs, nodes, & + -1.0*matmul(mass_ele, top_pressures-old_top_pressures)*alpha) ! here, delta_rho is in mass_ele + else + call addto(rhs, nodes, & + -1.0*matmul(mass_ele, top_pressures-old_top_pressures)*alpha/delta_rho) + end if + end if + end if + + end subroutine add_free_surface_element + + ! Computes alpha_wetdry. The resulting array is 0 if the node point is wet (p > -g d_0) and 1 if the node point is dry (p <= -g d_0) + subroutine compute_alpha_wetdry(p, sele, alpha_wetdry) + type(scalar_field), pointer, intent(in) :: p + integer, intent(in) :: sele + real, dimension(:), intent(inout) :: alpha_wetdry + integer :: i + + alpha_wetdry = -face_val(p, sele)-face_val(original_bottomdist_remap, sele)*g+d0*g + do i=1, size(alpha_wetdry) + if (alpha_wetdry(i)>0.0) then + alpha_wetdry(i)=1.0 + else + alpha_wetdry(i)=0.0 + end if + end do + end subroutine compute_alpha_wetdry + + ! Computes alpha_wetdry at each quadrature point. The resulting array is 0 if the quad point is wet (p > -g d_0) and 1 if the quad point is dry (p <= -g d_0) + subroutine compute_alpha_wetdry_quad(p, sele, alpha_wetdry_quad) + type(scalar_field), pointer, intent(in) :: p + integer, intent(in) :: sele + real, dimension(:), intent(inout) :: alpha_wetdry_quad + integer :: i + + alpha_wetdry_quad = -face_val_at_quad(p, sele)-face_val_at_quad(original_bottomdist_remap, sele)*g+d0*g + do i=1, size(alpha_wetdry_quad) + if (alpha_wetdry_quad(i)>0.0) then + alpha_wetdry_quad(i)=1.0 + else + alpha_wetdry_quad(i)=0.0 + end if + end do + end subroutine compute_alpha_wetdry_quad + + end subroutine add_free_surface_to_cmc_projection + + subroutine update_prognostic_free_surface(state, fs, implicit_prognostic_fs, explicit_prognostic_fs) + !!< For the viscous free surface method, update the prognostic surface field + !!< from the scaled free surface (\Delta\rho g\eta) that has just been solved with + !!< the pressure projection (implicit) or time-integrated explicitly. + !!< This is done via a small, surface Galerkin projection equation that is + !!< assembled and solved for. If /geometry/ocean_boundaries are specified the updated + !!< values are also extrapolated from the top surface. + type(state_type), intent(inout):: state + type(scalar_field), intent(inout):: fs + logical, intent(in):: implicit_prognostic_fs, explicit_prognostic_fs + + type(vector_field), pointer:: u, x, gravity_normal + type(scalar_field), pointer:: topdis + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + real:: g, rho0, dt + integer:: i, j, stat + + type(integer_hash_table):: sele_to_fs_ele, sele_to_implicit_fs_ele + integer, dimension(:), pointer:: surface_node_list, surface_element_list + type(mesh_type), pointer:: surface_mesh + type(csr_sparsity), pointer :: surface_sparsity + type(csr_matrix):: fs_matrix + type(scalar_field):: fs_rhs, surface_fs + type(scalar_field), pointer :: density, external_density + type(scalar_field), pointer :: scaled_fs, old_fs + integer external_density_stat + logical :: have_density, variable_density, move_mesh, have_external_density + + ewrite(1,*) 'Entering update_prognostic_free_surface' + + assert(implicit_prognostic_fs.or.explicit_prognostic_fs) + + u => extract_vector_field(state, "Velocity") + assert(have_option(trim(u%option_path)//"/prognostic")) + + if(implicit_prognostic_fs) then + if(.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then + call initialise_implicit_prognostic_free_surface(state, fs, u) + end if + + call get_boundary_condition(fs, "_implicit_free_surface", & + surface_element_list=surface_element_list) + call invert_set(surface_element_list, sele_to_implicit_fs_ele) + ! obtain the scaled f.s. that has been stored under the + ! "_implicit_free_surface" boundary condition + scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "ScaledFreeSurface") + end if - if(variable_density) then - if (have_external_density) then - inv_delta_rho_quad = 1.0/(face_val_at_quad(density, sele) - ele_val_at_quad(external_density, surface_mesh_ele)) - old_inv_delta_rho_quad = 1.0/(ele_val_at_quad(old_surface_density, surface_mesh_ele) - & - ele_val_at_quad(external_density, surface_mesh_ele)) - else - inv_delta_rho_quad = 1.0/face_val_at_quad(density, sele) - old_inv_delta_rho_quad = 1.0/ele_val_at_quad(old_surface_density, surface_mesh_ele) - end if + if(explicit_prognostic_fs) then + + old_fs => extract_scalar_field(state, "OldFreeSurface") + end if - if (have_wd) then - if (have_wd_node_int) then - call compute_alpha_wetdry(p, sele, alpha_wetdry) - call compute_alpha_wetdry(prevp, sele, alpha_wetdry_prevp) - else - call compute_alpha_wetdry_quad(p, sele, alpha_wetdry_quad) - call compute_alpha_wetdry_quad(prevp, sele, alpha_wetdry_quad_prevp) - end if + if (.not. has_boundary_condition_name(fs, "_free_surface")) then + call initialise_prognostic_free_surface(fs, u) end if - if (have_wd .and. .not. have_wd_node_int) then - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*(1.0-alpha_wetdry_quad)) - mass_ele_wd=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*alpha_wetdry_quad) - else - if (variable_density) then ! this excludes the case of a moving mesh so we use mass_ele_old here too - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*inv_delta_rho_quad) - mass_ele_old=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*old_inv_delta_rho_quad) - else - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) - end if - if (have_wd .and. have_wd_node_int) then - mass_ele_wd=mass_ele - do i=1,size(mass_ele,1) - mass_ele(i,:)=mass_ele(i,:)*(1.0-alpha_wetdry) - mass_ele_wd(i,:)=mass_ele_wd(i,:)*alpha_wetdry - end do - end if + call get_boundary_condition(fs, "_free_surface", surface_mesh=surface_mesh, & + surface_element_list=surface_element_list, & + surface_node_list=surface_node_list) + call invert_set(surface_element_list, sele_to_fs_ele) + + move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") + x => extract_vector_field(state, "Coordinate") + ! gravity acceleration + call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) + if (stat/=0) then + FLExit("For a free surface you need gravity") end if + gravity_normal => extract_vector_field(state, "GravityDirection") + density => extract_scalar_field(state, "Density", stat=stat) + have_density = (stat==0) + call get_fs_reference_density_from_options(rho0, state%option_path) + call get_option('/timestepping/timestep', dt) - if (use_fs_mesh) then - nodes = ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)) - top_pressures = ele_val(scaled_fs, fetch(sele_to_fs_ele, sele)) - old_top_pressures = ele_val(old_scaled_fs, fetch(sele_to_fs_ele, sele)) - else - nodes = face_global_nodes(p, sele) - top_pressures = face_val(p, sele) - old_top_pressures = face_val(prevp, sele) + surface_sparsity => get_csr_sparsity_firstorder(state, surface_mesh, surface_mesh) + call allocate(fs_matrix, surface_sparsity, name="FSMatrix") + call zero(fs_matrix) + call allocate(fs_rhs, surface_mesh, name="FSRHS") + call zero(fs_rhs) + call allocate(surface_fs, surface_mesh, name="SurfaceFS") + call zero(surface_fs) + + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress")) then + + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 + + variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & + .and. (.not.move_mesh) + if (variable_density.and.(.not.have_density)) then + FLExit("Variable density free surface requires a Density field.") + end if + + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit")) then + + do j=1, size(surface_element_list) + call add_explicit_boundary_integral_sele(surface_element_list(j)) + end do + + else + + do j=1, size(surface_element_list) + call add_implicit_boundary_integral_sele(j, surface_element_list(j)) + end do + end if + + end if + end if + end do + + if(implicit_prognostic_fs) call deallocate(sele_to_implicit_fs_ele) + call deallocate(sele_to_fs_ele) + + call petsc_solve(surface_fs, fs_matrix, fs_rhs, option_path=trim(fs%option_path)) + ewrite_minmax(surface_fs) + + call deallocate(fs_matrix) + call deallocate(fs_rhs) + + call set(fs, surface_node_list, surface_fs%val) + ewrite_minmax(fs) + call deallocate(surface_fs) + + ! if /geometry/ocean_boundaries are specified take the new fs values + ! at the top and extrapolate them downwards + topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) + if (stat==0) then + ! note we're not using the actual free_surface bc here, as + ! that may be specified in parts, or not cover the whole area + call get_boundary_condition(topdis, 1, & + surface_element_list=surface_element_list) + + x => extract_vector_field(state, "Coordinate") + + ! vertically extrapolate pressure values at the free surface downwards + ! (reuse projected horizontal top surface mesh cached under DistanceToTop) + call VerticalExtrapolation(fs, fs, x, & + gravity_normal, surface_element_list=surface_element_list, & + surface_name="DistanceToTop") + end if + + contains + + subroutine add_implicit_boundary_integral_sele(surface_mesh_ele, sele) + integer, intent(in):: surface_mesh_ele, sele ! element number in surface mesh, and facet number in u%mesh + + real, dimension(face_ngi(fs, sele)) :: detwei_bdy + real, dimension(face_ngi(fs, sele)):: inv_delta_rho_g_quad + + if(variable_density .and. have_external_density) then + inv_delta_rho_g_quad = 1.0/g/(face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele)) + elseif (variable_density) then + inv_delta_rho_g_quad = 1.0/g/face_val_at_quad(density, sele) + elseif (have_external_density) then + inv_delta_rho_g_quad = 1.0/g/(rho0-node_val(external_density, 1)) + else + inv_delta_rho_g_quad = 1.0/g/rho0 + end if + + + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy) + + call addto(fs_matrix, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & + ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & + shape_shape(face_shape(fs, sele), face_shape(fs, sele), detwei_bdy)) + + call addto(fs_rhs, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & + shape_rhs(face_shape(fs, sele), & + detwei_bdy* & + ele_val_at_quad(scaled_fs, fetch(sele_to_implicit_fs_ele, sele))* & + inv_delta_rho_g_quad)) + + end subroutine add_implicit_boundary_integral_sele + + subroutine add_explicit_boundary_integral_sele(sele) + integer, intent(in):: sele + + real, dimension(face_ngi(u, sele)) :: detwei_bdy + real, dimension(x%dim, face_ngi(u, sele)) :: normal_bdy + + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) + + call addto(fs_matrix, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & + ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & + shape_shape(face_shape(fs, sele), face_shape(fs, sele), detwei_bdy)) + + call addto(fs_rhs, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & + shape_rhs(face_shape(fs, sele), & + detwei_bdy* & + (face_val_at_quad(old_fs, sele) - & + dt*sum(face_val_at_quad(u,sele)*normal_bdy, dim=1)/ & + sum(face_val_at_quad(gravity_normal,sele)*normal_bdy, dim=1)))) + + end subroutine add_explicit_boundary_integral_sele + + end subroutine update_prognostic_free_surface + + subroutine add_free_surface_to_poisson_rhs(poisson_rhs, state, dt, theta_pg) + !!< Add the rhs contributions of the fs terms in the continuity equation + !!< to the initial Poisson equation + type(scalar_field), intent(inout) :: poisson_rhs + type(state_type), intent(inout) :: state + real, intent(in) :: dt, theta_pg + + type(integer_hash_table):: sele_to_fs_ele + type(vector_field), pointer:: positions, u, gravity_normal + type(scalar_field), pointer:: p, free_surface, scaled_fs, density, external_density + type(mesh_type), pointer:: embedded_fs_mesh + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + real g, coef, rho0 + integer, dimension(:), pointer:: surface_element_list, fs_surface_element_list + integer i, j, grav_stat, dens_stat, external_density_stat + logical:: include_normals + logical:: implicit_prognostic_fs, use_fs_mesh + logical:: move_mesh, variable_density, have_density, have_external_density + + ewrite(1,*) 'Entering assemble_masslumped_poisson_rhs_free_surface' + + ! gravity acceleration + call get_option('/physical_parameters/gravity/magnitude', g, stat=grav_stat) + if (grav_stat/=0) then + FLExit("For a free surface you need gravity") end if - if (addto_cmc.or.variable_density) then - ! we consider the projection equation to solve for - ! phi=theta_pressure_gradient theta_divergence dt dp, so that the f.s. integral - ! alpha M_fs dp=alpha M_fs phi/(theta_pressure_gradient theta_divergence g dt**2) - ! =coef M_fs phi - if(variable_density) then - call addto(cmc, nodes, nodes, & - (coef*mass_ele - coef_old*mass_ele_old)) ! here, delta_rho is already incorporated into mass_ele and mass_ele_old - else - call addto(cmc, nodes, nodes, & - ((coef-coef_old)/delta_rho)*mass_ele) - end if + ! with a free surface the initial condition prescribed for pressure + ! is used at the free surface nodes only + p => extract_scalar_field(state, "Pressure") + u => extract_vector_field(state, "Velocity") + + ! the prognostic free surface can only be used with the no_normal_stress option + implicit_prognostic_fs=has_implicit_viscous_free_surface_bc(u) + if(implicit_prognostic_fs) then + free_surface => extract_scalar_field(state, "FreeSurface") + assert(have_option(trim(free_surface%option_path)//"/prognostic")) + if (.not. has_boundary_condition_name(free_surface, "_implicit_free_surface")) then + call initialise_implicit_prognostic_free_surface(state, free_surface, u) + end if + ! obtain the f.s. surface mesh that has been stored under the + ! "_implicit_free_surface" boundary condition + call get_boundary_condition(free_surface, "_implicit_free_surface", & + surface_element_list=fs_surface_element_list) + ! create a map from face numbers to element numbers in the fs mesh + call invert_set(fs_surface_element_list, sele_to_fs_ele) + scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "ScaledFreeSurface") + embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") end if - if (move_mesh) then - ! detwei and normals at the begin of the time step - call transform_facet_to_physical(old_positions, sele, detwei_f=detwei,& - & normal=normals) - ! at each gauss point multiply with inner product of gravity and surface normal - detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) - if (have_wd .and. .not. have_wd_node_int) then - mass_ele_old=shape_shape(face_shape(prevp, sele), face_shape(prevp, sele), detwei*(1.0-alpha_wetdry_quad_prevp)) - mass_ele_old_wd=shape_shape(face_shape(prevp, sele), face_shape(prevp, sele), detwei*alpha_wetdry_quad_prevp) - else - mass_ele_old=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) - if (have_wd .and. have_wd_node_int) then - mass_ele_old_wd=mass_ele_old - do i=1,size(mass_ele_old,1) - mass_ele_old(i,:)=mass_ele_old(i,:)*(1.0-alpha_wetdry_prevp) - mass_ele_old_wd(i,:)=mass_ele_old_wd(i,:)*alpha_wetdry_prevp - end do + + ! reference density + call get_fs_reference_density_from_options(rho0, state%option_path) + density => extract_scalar_field(state, "Density", stat=dens_stat) + have_density = (dens_stat==0) + + ! only include the inner product of gravity and surface normal + ! if the free surface nodes are actually moved (not necessary + ! for large scale ocean simulations) + include_normals = have_option("/mesh_adaptivity/mesh_movement/free_surface") + if (include_normals) then + ewrite(2,*) 'Including inner product of normals in kinematic bc' + gravity_normal => extract_vector_field(state, "GravityDirection") + end if + + move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") + ! adding in the free surface integral using the free surface + ! elevation (p/rho0/g) specified by the inital pressure at the surface nodes + ! or, with prognostic fs, use the free surface node values directly + positions => extract_vector_field(state, "Coordinate") + + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then + if (have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then + assert(implicit_prognostic_fs) + use_fs_mesh=.true. + else + use_fs_mesh=.false. end if - end if - - if(present(rhs)) then - assert(.not. variable_density) - call addto(rhs, nodes, & - -(matmul(mass_ele, top_pressures) & - -matmul(mass_ele_old, old_top_pressures))*alpha/delta_rho) - end if - if (have_wd .and. present(rhs)) then - call addto(rhs, nodes, & - +(matmul(mass_ele_wd, face_val(original_bottomdist_remap, sele)-d0) & - -matmul(mass_ele_old_wd, face_val(original_bottomdist_remap,sele)-d0))*alpha*g) - end if + coef=g*theta_pg**2*dt**2 + + variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & + .and. (.not.move_mesh) + if(variable_density.and.(.not.have_density)) then + FLExit("Variable density free surface requires a Density field.") + end if + + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 + + do j=1, size(surface_element_list) + call add_free_surface_element(j, surface_element_list(j)) + end do + end if + end do + + if (implicit_prognostic_fs) then + call deallocate(sele_to_fs_ele) + end if + + contains + + subroutine add_free_surface_element(surface_mesh_ele, sele) + integer, intent(in):: surface_mesh_ele, sele + real, dimension(face_loc(p, sele)):: values + real, dimension(positions%dim, face_ngi(positions, sele)):: normals + real, dimension(face_loc(p, sele), face_loc(p, sele)):: mass_ele + real, dimension(face_ngi(p, sele)):: detwei + real, dimension(face_ngi(p, sele)):: inv_delta_rho_quad + integer, dimension(face_loc(p, sele)):: nodes + integer:: ele + + ele=face_ele(positions, sele) + call transform_facet_to_physical(positions, sele, detwei_f=detwei,& + & normal=normals) + if (include_normals) then + ! at each gauss point multiply with inner product of gravity and surface normal + detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) + end if + + if(variable_density .and. have_external_density) then + inv_delta_rho_quad = 1.0/(face_val_at_quad(density, sele) - ele_val_at_quad(external_density, surface_mesh_ele)) + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*inv_delta_rho_quad) + else if (variable_density) then + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei/face_val_at_quad(density, sele)) + else if (have_external_density) then + mass_ele = shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) / (rho0 - node_val(external_density, 1)) + else + mass_ele = shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) / rho0 + end if + + if (use_fs_mesh) then + nodes = ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)) + values = ele_val(scaled_fs, fetch(sele_to_fs_ele, sele)) + else + nodes = face_global_nodes(p, sele) + values = face_val(p, sele) + end if + + call addto(poisson_rhs, nodes, matmul(mass_ele, values)/coef) + + end subroutine add_free_surface_element + + end subroutine add_free_surface_to_poisson_rhs + + subroutine copy_poisson_solution_to_interior(state, p_theta, p, old_p, u) + !!< Copy the solved for initial Poisson solution p_theta into p and old_p + !!< but maintain initial condition for free surface nodes. + type(state_type), intent(in):: state + type(scalar_field), intent(inout), target:: p_theta, p, old_p + type(vector_field), intent(in):: u + + type(scalar_field), pointer:: free_surface + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + logical:: prognostic_fs + integer, dimension(:), pointer:: surface_element_list + integer:: fs_stat + integer:: i, j, sele + + ! the prognostic free surface can only be used with the no_normal_stress option + free_surface => extract_scalar_field(state, "FreeSurface", stat=fs_stat) + prognostic_fs=.false. + if (fs_stat==0) then + prognostic_fs=have_option(trim(free_surface%option_path)//"/prognostic") + end if + + if (prognostic_fs) then + ! only copy over solved for pressure values + ! we keep the initial free surface + call set_all(p, p_theta%val(1:node_count(p))) else - ! no mesh movement - just use the same mass matrix as above - if(present(rhs)) then - if (variable_density) then - call addto(rhs, nodes, & - -1.0*matmul(mass_ele, top_pressures-old_top_pressures)*alpha) ! here, delta_rho is in mass_ele - else - call addto(rhs, nodes, & - -1.0*matmul(mass_ele, top_pressures-old_top_pressures)*alpha/delta_rho) + + ! first copy initial free surface elevations (p/g) at free surface nodes + ! to p_theta + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then + + if (have_option(trim(fs_option_path)//"/type[0]/no_normal_stress")) then + ! this should have been options checked + FLAbort("No normal stress free surface without prognostic free surface") + end if + + do j=1, size(surface_element_list) + sele=surface_element_list(j) + call set(p_theta, face_global_nodes(p_theta,sele), face_val(p, sele)) + end do + + end if + end do + + ! then copy everything (including interior) back from p_theta to p + call set(p, p_theta) + end if + + ! p and old_p should be the same (as we're in the first non-linear iteration) + ! but they might be different fields (if #nonlinear iterations>1) + call set(old_p, p) + ewrite_minmax(p) + + end subroutine copy_poisson_solution_to_interior + + subroutine initialise_implicit_prognostic_free_surface(state, fs, u) + !!< Setup ScaledFreeSurface and OldScaledFreeSurface surface fields (to contain + !!< \Delta\rho g\eta values). Initialise them with initial condition (requires + !!< little mass matrix solve). + type(state_type), intent(inout):: state + type(scalar_field), intent(inout):: fs + type(vector_field), intent(in):: u + + character(len=OPTION_PATH_LEN):: fs_option_path + character(len=FIELD_NAME_LEN):: bctype + type(integer_set):: surface_elements + type(mesh_type), pointer:: surface_mesh + type(scalar_field):: scaled_fs, old_scaled_fs + type(integer_hash_table):: sele_to_fs_ele + integer, dimension(:), pointer:: surface_element_list, surface_node_list + integer:: i + + + ewrite(1,*) 'Entering initialise_implicit_prognostic_free_surface' + + call allocate(surface_elements) + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then + ! include only implicit free surfaces + call insert(surface_elements, surface_element_list) end if end if + end do + + allocate(surface_element_list(1:key_count(surface_elements))) + surface_element_list=set2vector(surface_elements) + call add_boundary_condition_surface_elements(fs, "_implicit_free_surface", "free_surface", & + surface_element_list) + call invert_set(surface_element_list, sele_to_fs_ele) + deallocate(surface_element_list) + call deallocate(surface_elements) + + call get_boundary_condition(fs, "_implicit_free_surface", surface_mesh=surface_mesh, & + surface_node_list=surface_node_list) + if (IsParallel()) then + call generate_surface_mesh_halos(fs%mesh, surface_mesh, surface_node_list) end if - end subroutine add_free_surface_element + call allocate(scaled_fs, surface_mesh, "ScaledFreeSurface") + call zero(scaled_fs) - ! Computes alpha_wetdry. The resulting array is 0 if the node point is wet (p > -g d_0) and 1 if the node point is dry (p <= -g d_0) - subroutine compute_alpha_wetdry(p, sele, alpha_wetdry) - type(scalar_field), pointer, intent(in) :: p - integer, intent(in) :: sele - real, dimension(:), intent(inout) :: alpha_wetdry - integer :: i + call solve_initial_scaled_free_surface(state, scaled_fs, u, sele_to_fs_ele, fs) - alpha_wetdry = -face_val(p, sele)-face_val(original_bottomdist_remap, sele)*g+d0*g - do i=1, size(alpha_wetdry) - if (alpha_wetdry(i)>0.0) then - alpha_wetdry(i)=1.0 - else - alpha_wetdry(i)=0.0 - end if + call insert_surface_field(fs, "_implicit_free_surface", scaled_fs) + + call allocate(old_scaled_fs, surface_mesh, "OldScaledFreeSurface") + call set(old_scaled_fs, scaled_fs) + call deallocate(scaled_fs) + + call insert_surface_field(fs, "_implicit_free_surface", old_scaled_fs) + call deallocate(old_scaled_fs) + + call deallocate(sele_to_fs_ele) + + + end subroutine initialise_implicit_prognostic_free_surface + + subroutine solve_initial_scaled_free_surface(state, scaled_fs, u, sele_to_fs_ele, fs) + !!< Solve for the initial value of the "ScaledFreeSurface" surface field, this is + !!< obtained by solving scaled_fs = g*delta_rho*fs as a mass matrix equation on the surface + !!< where fs is the initial condition (or interpolated after adaptivity) value of the prognostic fs field + type(state_type), intent(inout):: state + type(scalar_field), intent(inout):: scaled_fs ! the surface field solved for + type(vector_field), intent(in):: u + ! a map between surface element nos of the fs%mesh, and elements in scaled_fs%mesh: + type(integer_hash_table), intent(in):: sele_to_fs_ele + type(scalar_field), intent(in):: fs ! the full, prognostic fs + + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + real:: rho0, g + integer, dimension(:), pointer:: surface_element_list + integer:: i, j, stat, external_density_stat + + type(csr_sparsity), pointer :: surface_sparsity + type(csr_matrix):: fs_matrix + type(scalar_field):: fs_rhs + type(vector_field), pointer :: x + type(scalar_field), pointer :: density, external_density + logical :: have_density, variable_density, move_mesh, have_external_density + + ewrite(1,*) "Inside solve_initial_scaled_free_surface" + + move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") + x => extract_vector_field(state, "Coordinate") + call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) + if (stat/=0) then + FLExit("For a free surface you need gravity") + end if + density => extract_scalar_field(state, "Density", stat=stat) + have_density = (stat==0) + call get_fs_reference_density_from_options(rho0, state%option_path) + + surface_sparsity => get_csr_sparsity_firstorder(state, scaled_fs%mesh, scaled_fs%mesh) + call allocate(fs_matrix, surface_sparsity, name="FSMatrix") + call zero(fs_matrix) + call allocate(fs_rhs, scaled_fs%mesh, name="FSRHS") + call zero(fs_rhs) + + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then + + variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & + .and. (.not.move_mesh) + if (variable_density.and.(.not.have_density)) then + FLExit("Variable density free surface requires a Density field.") + end if + + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 + + do j=1, size(surface_element_list) + call add_boundary_integral_sele(j, surface_element_list(j)) + end do + end if + end if end do - end subroutine compute_alpha_wetdry - - ! Computes alpha_wetdry at each quadrature point. The resulting array is 0 if the quad point is wet (p > -g d_0) and 1 if the quad point is dry (p <= -g d_0) - subroutine compute_alpha_wetdry_quad(p, sele, alpha_wetdry_quad) - type(scalar_field), pointer, intent(in) :: p - integer, intent(in) :: sele - real, dimension(:), intent(inout) :: alpha_wetdry_quad - integer :: i - - alpha_wetdry_quad = -face_val_at_quad(p, sele)-face_val_at_quad(original_bottomdist_remap, sele)*g+d0*g - do i=1, size(alpha_wetdry_quad) - if (alpha_wetdry_quad(i)>0.0) then - alpha_wetdry_quad(i)=1.0 - else - alpha_wetdry_quad(i)=0.0 - end if + + call petsc_solve(scaled_fs, fs_matrix, fs_rhs, option_path=trim(fs%option_path)) + ewrite_minmax(fs) + ewrite_minmax(scaled_fs) + + call deallocate(fs_matrix) + call deallocate(fs_rhs) + + contains + + subroutine add_boundary_integral_sele(surface_mesh_ele, sele) + integer, intent(in):: surface_mesh_ele, sele + + real, dimension(face_ngi(fs, sele)) :: detwei_bdy + real, dimension(face_ngi(fs, sele)):: delta_rho_quad + integer :: fs_ele + + if(variable_density .and. have_external_density) then + delta_rho_quad = face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele) + else if (variable_density) then + delta_rho_quad = face_val_at_quad(density, sele) + else if (have_external_density) then + delta_rho_quad = rho0-node_val(external_density, 1) + else + delta_rho_quad = rho0 + end if + + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy) + + fs_ele = fetch(sele_to_fs_ele, sele) + call addto(fs_matrix, ele_nodes(scaled_fs, fs_ele), & + ele_nodes(scaled_fs, fs_ele), & + shape_shape(face_shape(fs, sele), face_shape(fs, sele), detwei_bdy)) + + call addto(fs_rhs, ele_nodes(scaled_fs, fs_ele), & + shape_rhs(face_shape(fs,sele), & + detwei_bdy * face_val_at_quad(fs,sele) * g * delta_rho_quad)) + + end subroutine add_boundary_integral_sele + + end subroutine solve_initial_scaled_free_surface + + subroutine initialise_prognostic_free_surface(fs, u) + type(scalar_field), intent(inout):: fs + type(vector_field), intent(in):: u + + type(mesh_type), pointer:: surface_mesh + type(integer_set):: surface_elements + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + integer, dimension(:), pointer:: surface_element_list, surface_node_list + integer:: i + + ewrite(1,*) 'Entering initialise_prognostic_free_surface' + + call allocate(surface_elements) + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress")) then + ! include all explicit and implicit free surfaces + call insert(surface_elements, surface_element_list) + end if + end if end do - end subroutine compute_alpha_wetdry_quad - - end subroutine add_free_surface_to_cmc_projection - - subroutine update_prognostic_free_surface(state, fs, implicit_prognostic_fs, explicit_prognostic_fs) - !!< For the viscous free surface method, update the prognostic surface field - !!< from the scaled free surface (\Delta\rho g\eta) that has just been solved with - !!< the pressure projection (implicit) or time-integrated explicitly. - !!< This is done via a small, surface Galerkin projection equation that is - !!< assembled and solved for. If /geometry/ocean_boundaries are specified the updated - !!< values are also extrapolated from the top surface. - type(state_type), intent(inout):: state - type(scalar_field), intent(inout):: fs - logical, intent(in):: implicit_prognostic_fs, explicit_prognostic_fs - - type(vector_field), pointer:: u, x, gravity_normal - type(scalar_field), pointer:: topdis - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - real:: g, rho0, dt - integer:: i, j, stat - - type(integer_hash_table):: sele_to_fs_ele, sele_to_implicit_fs_ele - integer, dimension(:), pointer:: surface_node_list, surface_element_list - type(mesh_type), pointer:: surface_mesh - type(csr_sparsity), pointer :: surface_sparsity - type(csr_matrix):: fs_matrix - type(scalar_field):: fs_rhs, surface_fs - type(scalar_field), pointer :: density, external_density - type(scalar_field), pointer :: scaled_fs, old_fs - integer external_density_stat - logical :: have_density, variable_density, move_mesh, have_external_density - - ewrite(1,*) 'Entering update_prognostic_free_surface' - - assert(implicit_prognostic_fs.or.explicit_prognostic_fs) - - u => extract_vector_field(state, "Velocity") - assert(have_option(trim(u%option_path)//"/prognostic")) - - if(implicit_prognostic_fs) then - if(.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then - call initialise_implicit_prognostic_free_surface(state, fs, u) + + allocate(surface_element_list(1:key_count(surface_elements))) + surface_element_list=set2vector(surface_elements) + call add_boundary_condition_surface_elements(fs, "_free_surface", "free_surface", & + surface_element_list) + deallocate(surface_element_list) + call deallocate(surface_elements) + if (IsParallel()) then + call get_boundary_condition(fs, "_free_surface", surface_mesh=surface_mesh, & + surface_node_list=surface_node_list) + call generate_surface_mesh_halos(fs%mesh, surface_mesh, surface_node_list) + end if + + end subroutine initialise_prognostic_free_surface + + function get_extended_pressure_mesh_for_viscous_free_surface(state, pressure_mesh, fs) result (extended_pressure_mesh) + ! extend the pressure mesh to contain the extra free surface dofs + ! (doubling the pressure nodes at the free surface). The returned mesh uses + ! a new node numbering that includes the pressure and separate fs nodes, but has + ! the same elements as the pressure_mesh. This routine also creates, seperately, a surface + ! mesh (the "embedded" fs mesh) that uses the same combined pressure and fs node numbering, but only contains the surface + ! elements with fs nodes as its elements. Both are stored in state. + + ! this must be the state containing the prognostic pressure and free surface + type(state_type), intent(inout):: state + ! the origional pressure mesh (without fs nodes) + type(mesh_type), intent(in):: pressure_mesh + ! the prognostic free surface field + type(scalar_field), intent(inout):: fs + type(mesh_type), pointer:: extended_pressure_mesh + + type(integer_vector), dimension(2):: new_node_map + type(vector_field), pointer:: u + type(mesh_type), pointer:: fs_mesh + type(mesh_type):: extended_mesh, embedded_fs_mesh + + integer, dimension(ele_loc(pressure_mesh, 1)):: new_nodes + integer, dimension(face_loc(fs%mesh, 1)):: new_fs_nodes + integer, dimension(:), pointer:: nodes + integer :: ihalo, ele, j, pnodes + logical :: parallel + + if (.not. has_mesh(state, "_extended_pressure_mesh")) then + + if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then + u => extract_vector_field(state, "Velocity") + assert(have_option(trim(u%option_path)//"/prognostic")) + call initialise_implicit_prognostic_free_surface(state, fs, u) + end if + ! obtain the f.s. surface mesh that has been stored under the + ! "_implicit_free_surface" boundary condition (this is a surface + ! mesh with a separate fs node numbering) + call get_boundary_condition(fs, "_implicit_free_surface", & + surface_mesh=fs_mesh) + + if (associated(pressure_mesh%halos) .and. associated(fs_mesh%halos)) then + assert(size(pressure_mesh%halos)==2 .and. size(fs_mesh%halos)==2) + + ! create a node numbering for the combined pressure and fs system + ! that is trailing receives consistent + new_node_map = create_combined_numbering_trailing_receives( & + (/ pressure_mesh%halos(1), fs_mesh%halos(1) /), & + (/ pressure_mesh%halos(2), fs_mesh%halos(2) /)) + parallel = .true. + else + assert(.not. associated(pressure_mesh%halos)) + assert(.not. associated(fs_mesh%halos)) + parallel = .false. + end if + + call allocate(extended_mesh, node_count(pressure_mesh)+node_count(fs_mesh), & + element_count(pressure_mesh), pressure_mesh%shape, & + "Extended"//trim(pressure_mesh%name)) + extended_mesh%periodic = pressure_mesh%periodic + + do ele=1, element_count(pressure_mesh) + nodes => ele_nodes(pressure_mesh,ele) + if (parallel) then + do j=1, size(nodes) + new_nodes(j) = new_node_map(1)%ptr(nodes(j)) + end do + call set_ele_nodes(extended_mesh, ele, new_nodes) + else + call set_ele_nodes(extended_mesh, ele, nodes) + end if + end do + + call add_faces(extended_mesh, model=pressure_mesh) + + if (parallel) then + ! Allocate extended mesh halos: + allocate(extended_mesh%halos(2)) + + ! Derive extended_mesh nodal halos: + do ihalo = 1, 2 + + extended_mesh%halos(ihalo) = combine_halos( & + (/ pressure_mesh%halos(ihalo), fs_mesh%halos(ihalo) /), & + new_node_map, & + name="Extended"//trim(pressure_mesh%halos(ihalo)%name)) + + assert(trailing_receives_consistent(extended_mesh%halos(ihalo))) + assert(halo_valid_for_communication(extended_mesh%halos(ihalo))) + call create_global_to_universal_numbering(extended_mesh%halos(ihalo)) + call create_ownership(extended_mesh%halos(ihalo)) + + end do + end if + + call insert(state, extended_mesh, "_extended_pressure_mesh") + call deallocate(extended_mesh) + + ! now create an auxillary surface mesh, that has the same topology as surface_mesh + ! but uses the node numbering for free surface nodes of the extended mesh + call allocate(embedded_fs_mesh, node_count(extended_mesh), & + element_count(fs_mesh), fs_mesh%shape, & + name="Emmbedded"//trim(fs_mesh%name)) + + pnodes = node_count(pressure_mesh) + do ele=1, element_count(fs_mesh) + nodes => ele_nodes(fs_mesh,ele) + if (parallel) then + do j=1, size(nodes) + new_fs_nodes(j) = new_node_map(2)%ptr(nodes(j)) + end do + else + new_fs_nodes = nodes + pnodes ! fs nodes come after the pressure nodes in the extended mesh + end if + call set_ele_nodes(embedded_fs_mesh, ele, new_fs_nodes) + end do + + call insert(state, embedded_fs_mesh, "_embedded_free_surface_mesh") + call deallocate(embedded_fs_mesh) + + if (parallel) then + ! the node maps are no longer needed: the correspondence between + ! pressure mesh/fs surface mesh and extended_mesh/embedded_fs_mesh resp. + ! is maintained by looping over the elements of both simultaneously + deallocate(new_node_map(1)%ptr) + deallocate(new_node_map(2)%ptr) + end if + end if - call get_boundary_condition(fs, "_implicit_free_surface", & - surface_element_list=surface_element_list) - call invert_set(surface_element_list, sele_to_implicit_fs_ele) + extended_pressure_mesh => extract_mesh(state, "_extended_pressure_mesh") + + end function get_extended_pressure_mesh_for_viscous_free_surface + + subroutine copy_to_extended_p(p, fs, theta_pg, p_theta) + type(scalar_field), intent(in):: p, fs + real, intent(in):: theta_pg + type(scalar_field), intent(inout):: p_theta + ! copy p and fs into p_theta that is allocated on the extended pressure mesh + + type(scalar_field), pointer:: scaled_fs, old_scaled_fs + integer:: powned_nodes, fsowned_nodes + ! obtain the scaled f.s. that has been stored under the ! "_implicit_free_surface" boundary condition scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "ScaledFreeSurface") + old_scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "OldScaledFreeSurface") - end if + powned_nodes = nowned_nodes(p) + fsowned_nodes = nowned_nodes(scaled_fs) - if(explicit_prognostic_fs) then + ! p is not theta weighted (as usual for incompressible) + p_theta%val(1:powned_nodes) = p%val(1:powned_nodes) - old_fs => extract_scalar_field(state, "OldFreeSurface") + ! setting this to the old scaled fs values means we're calculating the change in the free surface across the timestep + ! not just since the last solve - unlike pressure where delta_p is since the last solve! + p_theta%val(powned_nodes+1:powned_nodes+fsowned_nodes) = theta_pg*scaled_fs%val(1:fsowned_nodes) + (1.-theta_pg)*old_scaled_fs%val(1:fsowned_nodes) - end if - - if (.not. has_boundary_condition_name(fs, "_free_surface")) then - call initialise_prognostic_free_surface(fs, u) - end if - - call get_boundary_condition(fs, "_free_surface", surface_mesh=surface_mesh, & - surface_element_list=surface_element_list, & - surface_node_list=surface_node_list) - call invert_set(surface_element_list, sele_to_fs_ele) - - move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") - x => extract_vector_field(state, "Coordinate") - ! gravity acceleration - call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) - if (stat/=0) then - FLExit("For a free surface you need gravity") - end if - gravity_normal => extract_vector_field(state, "GravityDirection") - density => extract_scalar_field(state, "Density", stat=stat) - have_density = (stat==0) - call get_fs_reference_density_from_options(rho0, state%option_path) - call get_option('/timestepping/timestep', dt) - - surface_sparsity => get_csr_sparsity_firstorder(state, surface_mesh, surface_mesh) - call allocate(fs_matrix, surface_sparsity, name="FSMatrix") - call zero(fs_matrix) - call allocate(fs_rhs, surface_mesh, name="FSRHS") - call zero(fs_rhs) - call allocate(surface_fs, surface_mesh, name="SurfaceFS") - call zero(surface_fs) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress")) then - - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - - variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & - .and. (.not.move_mesh) - if (variable_density.and.(.not.have_density)) then - FLExit("Variable density free surface requires a Density field.") - end if - - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit")) then + ! we only copy the owned nodes into to combined pressure/fs field p_theta + ! because the renumbering of the receive nodes is a little more complicated + ! therefore, do a halo update to give the receive nodes its correct values as well + call halo_update(p_theta) - do j=1, size(surface_element_list) - call add_explicit_boundary_integral_sele(surface_element_list(j)) - end do + end subroutine copy_to_extended_p - else + subroutine update_pressure_and_viscous_free_surface(state, p, fs, delta_p, theta_pg) + type(state_type), intent(inout):: state + ! after the pressure+fs projection add in the solved for delta_p + ! into the pressure and prognostic fs + type(scalar_field), intent(inout):: p, fs + type(scalar_field), intent(in):: delta_p + real, intent(in):: theta_pg - do j=1, size(surface_element_list) - call add_implicit_boundary_integral_sele(j, surface_element_list(j)) - end do - end if + type(vector_field), pointer:: u + type(scalar_field), pointer :: scaled_fs + integer:: powned_nodes, fsowned_nodes + real:: dt + + ewrite(1,*) 'Entering update_pressure_and_viscous_free_surface' - end if + u => extract_vector_field(state, "Velocity") + if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then + assert(have_option(trim(u%option_path)//"/prognostic")) + call initialise_implicit_prognostic_free_surface(state, fs, u) end if - end do + ! obtain the scaled f.s. that has been stored under the + ! "_implicit_free_surface" boundary condition + scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "ScaledFreeSurface") - if(implicit_prognostic_fs) call deallocate(sele_to_implicit_fs_ele) - call deallocate(sele_to_fs_ele) + call get_option('/timestepping/timestep', dt) - call petsc_solve(surface_fs, fs_matrix, fs_rhs, option_path=trim(fs%option_path)) - ewrite_minmax(surface_fs) + powned_nodes = nowned_nodes(p) + fsowned_nodes = nowned_nodes(scaled_fs) - call deallocate(fs_matrix) - call deallocate(fs_rhs) + p%val(1:powned_nodes) = p%val(1:powned_nodes) + delta_p%val(1:powned_nodes)/dt + call halo_update(p) - call set(fs, surface_node_list, surface_fs%val) - ewrite_minmax(fs) - call deallocate(surface_fs) + scaled_fs%val(1:fsowned_nodes) = scaled_fs%val(1:fsowned_nodes) + delta_p%val(powned_nodes+1:powned_nodes+fsowned_nodes)/(dt*theta_pg) + call halo_update(scaled_fs) + ewrite_minmax(scaled_fs) - ! if /geometry/ocean_boundaries are specified take the new fs values - ! at the top and extrapolate them downwards - topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) - if (stat==0) then - ! note we're not using the actual free_surface bc here, as - ! that may be specified in parts, or not cover the whole area - call get_boundary_condition(topdis, 1, & - surface_element_list=surface_element_list) + end subroutine update_pressure_and_viscous_free_surface - x => extract_vector_field(state, "Coordinate") + function get_extended_velocity_divergence_matrix(state, u, fs, & + extended_mesh, get_ct, ct_m_name) result (ct_m_ptr) + ! returns the velocity divergence matrix from state (or creates a new one if none present) + ! with extra rows associated with prognostic fs nodes + ! this routine mimicks the behaviour of get_velocity_divergence_matrix() + type(state_type), intent(inout):: state + type(vector_field), intent(in):: u + type(scalar_field), intent(in):: fs + type(mesh_type), intent(in):: extended_mesh + ! returns .true. if the matrix needs to be reassembled (because it has just been allocated or because of mesh movement) + logical, optional, intent(out):: get_ct + character(len=*), intent(in), optional :: ct_m_name + type(block_csr_matrix), pointer:: ct_m_ptr + + type(block_csr_matrix):: new_ct_m + type(csr_sparsity), pointer:: sparsity + integer:: stat + integer, save:: last_mesh_movement = -1 + logical:: mesh_moved + character(len=FIELD_NAME_LEN) :: l_ct_m_name + + mesh_moved = eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + + ! Form the ct_m_name dependent on interface argument + if (present(ct_m_name)) then + l_ct_m_name = trim(ct_m_name) + else + l_ct_m_name = "ExtendedVelocityDivergenceMatrix" + end if - ! vertically extrapolate pressure values at the free surface downwards - ! (reuse projected horizontal top surface mesh cached under DistanceToTop) - call VerticalExtrapolation(fs, fs, x, & - gravity_normal, surface_element_list=surface_element_list, & - surface_name="DistanceToTop") - end if + ct_m_ptr => extract_block_csr_matrix(state, l_ct_m_name, stat=stat) + if (stat==0) then + if (present(get_ct)) then + get_ct = mesh_moved + end if + return + end if - contains + sparsity => get_extended_velocity_divergence_sparsity(state, u, fs, extended_mesh) - subroutine add_implicit_boundary_integral_sele(surface_mesh_ele, sele) - integer, intent(in):: surface_mesh_ele, sele ! element number in surface mesh, and facet number in u%mesh + call allocate(new_ct_m, sparsity, blocks=(/ 1, u%dim /), name=l_ct_m_name) + call insert(state, new_ct_m, new_ct_m%name) + call deallocate(new_ct_m) - real, dimension(face_ngi(fs, sele)) :: detwei_bdy - real, dimension(face_ngi(fs, sele)):: inv_delta_rho_g_quad + ct_m_ptr => extract_block_csr_matrix(state, l_ct_m_name) - if(variable_density .and. have_external_density) then - inv_delta_rho_g_quad = 1.0/g/(face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele)) - elseif (variable_density) then - inv_delta_rho_g_quad = 1.0/g/face_val_at_quad(density, sele) - elseif (have_external_density) then - inv_delta_rho_g_quad = 1.0/g/(rho0-node_val(external_density, 1)) - else - inv_delta_rho_g_quad = 1.0/g/rho0 + if (present(get_ct)) then + get_ct = .true. + end if + + end function get_extended_velocity_divergence_matrix + + function get_extended_velocity_divergence_sparsity(state, u, fs, extended_mesh) result (sparsity) + ! returns the sparsity of the velocity divergence matrix from state (or creates a new one if none present) + ! with extra rows associated with prognostic fs nodes + ! this routine mimicks the behaviour of get_velocity_divergence_matrix() + type(state_type), intent(inout):: state + type(vector_field), intent(in):: u + type(scalar_field), intent(in):: fs + type(mesh_type), intent(in):: extended_mesh + type(csr_sparsity), pointer:: sparsity + + type(mesh_type), pointer:: embedded_fs_mesh + type(mesh_type):: u_surface_mesh + type(csr_sparsity):: new_sparsity, fs_sparsity, p_sparsity + integer, dimension(:), pointer :: fs_surface_element_list + integer, dimension(:), pointer :: p_row, fs_row, new_row + integer:: entries, stat, i, sele + + sparsity => extract_csr_sparsity(state, "ExtendedVelocityDivergenceSparsity", stat=stat) + if (stat==0) return + + ! this will create a sparsity with only the rows associated with the pressure + ! nodes filled in (in the extended mesh numbering), fs nodes have zero row length + p_sparsity = make_sparsity(extended_mesh, u%mesh, name="TempPartialSparsityPressure") + + ! now do the same for rows associated with fs nodes in the combined mesh + ! to make this sparsity we need a velocity surface mesh that uses the + ! velocity dof numbering of the entire mesh + call get_boundary_condition(fs, "_implicit_free_surface", & + surface_element_list=fs_surface_element_list) + call allocate(u_surface_mesh, node_count(u), size(fs_surface_element_list), & + face_shape(u,1), & + name="TempVelocityFreeSurfaceMesh") + do i=1, size(fs_surface_element_list) + sele = fs_surface_element_list(i) + call set_ele_nodes(u_surface_mesh, i, face_global_nodes(u, sele)) + end do + embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") + fs_sparsity = make_sparsity(embedded_fs_mesh, u_surface_mesh, name="TempPartialSparsityFreeSurface") + call deallocate(u_surface_mesh) + + ! now we simply combine the two sparsities + entries = size(p_sparsity%colm) + size(fs_sparsity%colm) + call allocate(new_sparsity, node_count(extended_mesh), node_count(u), & + entries, name="ExtendedVelocityDivergenceSparsity") + new_sparsity%findrm(1) = 1 + do i=1, node_count(extended_mesh) + new_sparsity%findrm(i+1) = new_sparsity%findrm(i) + & + row_length(p_sparsity, i) + row_length(fs_sparsity, i) + end do + do i=1, node_count(extended_mesh) + p_row => row_m_ptr(p_sparsity, i) + fs_row => row_m_ptr(fs_sparsity, i) + new_row => row_m_ptr(new_sparsity, i) + if (size(new_row)==size(p_row)) then + new_row = p_row + else if (size(new_row)==size(fs_row)) then + new_row = fs_row + else + ! we assume that each row is either associated with a fs node, in which case size(p_row)==0 + ! and size(new_row)=size(new_row), or associated with a p node, in which case size(fs_row)==0 + ! and size(new_row)=size(p_row) + FLAbort("Node in combined mesh that is neither fs or pressure node (or both).") + end if + end do + new_sparsity%sorted_rows = p_sparsity%sorted_rows .and. fs_sparsity%sorted_rows + call deallocate(p_sparsity) + call deallocate(fs_sparsity) + + if (associated(extended_mesh%halos)) then + allocate(new_sparsity%row_halo) + new_sparsity%row_halo = extended_mesh%halos(1) + call incref(new_sparsity%row_halo) + allocate(new_sparsity%column_halo) + new_sparsity%column_halo = u%mesh%halos(1) + call incref(new_sparsity%column_halo) + end if + call insert(state, new_sparsity, new_sparsity%name) + call deallocate(new_sparsity) + + sparsity => extract_csr_sparsity(state, "ExtendedVelocityDivergenceSparsity") + + end function get_extended_velocity_divergence_sparsity + + function get_extended_pressure_poisson_matrix(state, ct_m, extended_mesh, get_cmc) result (cmc_m_ptr) + ! returns the pressure poisson matrix from state (or creates a new one if none present) + ! with extra rows and columns associated with prognostic fs nodes + ! this routine mimicks the behaviour of get_pressure_poisson_matrix() + type(state_type), intent(inout):: state + type(block_csr_matrix), intent(in):: ct_m + type(mesh_type), intent(in):: extended_mesh + ! returns .true. if the matrix needs to be reassembled (because it has just been allocated or because of mesh movement) + logical, optional, intent(out):: get_cmc + type(csr_matrix), pointer:: cmc_m_ptr + + type(csr_matrix):: cmc_m + type(csr_sparsity):: grad_sparsity, cmc_sparsity + integer, save:: last_mesh_movement=-1 + integer:: stat + logical:: mesh_moved + + mesh_moved = eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + + cmc_m_ptr => extract_csr_matrix(state, "ExtendedPressurePoissonMatrix", stat=stat) + if (stat==0) then + if (present(get_cmc)) then + get_cmc = mesh_moved + end if + return end if + grad_sparsity=transpose(ct_m%sparsity) + cmc_sparsity = matmul(ct_m%sparsity, grad_sparsity) - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy) - - call addto(fs_matrix, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & - ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & - shape_shape(face_shape(fs, sele), face_shape(fs, sele), detwei_bdy)) - - call addto(fs_rhs, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & - shape_rhs(face_shape(fs, sele), & - detwei_bdy* & - ele_val_at_quad(scaled_fs, fetch(sele_to_implicit_fs_ele, sele))* & - inv_delta_rho_g_quad)) - - end subroutine add_implicit_boundary_integral_sele - - subroutine add_explicit_boundary_integral_sele(sele) - integer, intent(in):: sele - - real, dimension(face_ngi(u, sele)) :: detwei_bdy - real, dimension(x%dim, face_ngi(u, sele)) :: normal_bdy - - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) - - call addto(fs_matrix, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & - ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & - shape_shape(face_shape(fs, sele), face_shape(fs, sele), detwei_bdy)) - - call addto(fs_rhs, ele_nodes(surface_mesh, fetch(sele_to_fs_ele, sele)), & - shape_rhs(face_shape(fs, sele), & - detwei_bdy* & - (face_val_at_quad(old_fs, sele) - & - dt*sum(face_val_at_quad(u,sele)*normal_bdy, dim=1)/ & - sum(face_val_at_quad(gravity_normal,sele)*normal_bdy, dim=1)))) - - end subroutine add_explicit_boundary_integral_sele - - end subroutine update_prognostic_free_surface - - subroutine add_free_surface_to_poisson_rhs(poisson_rhs, state, dt, theta_pg) - !!< Add the rhs contributions of the fs terms in the continuity equation - !!< to the initial Poisson equation - type(scalar_field), intent(inout) :: poisson_rhs - type(state_type), intent(inout) :: state - real, intent(in) :: dt, theta_pg - - type(integer_hash_table):: sele_to_fs_ele - type(vector_field), pointer:: positions, u, gravity_normal - type(scalar_field), pointer:: p, free_surface, scaled_fs, density, external_density - type(mesh_type), pointer:: embedded_fs_mesh - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - real g, coef, rho0 - integer, dimension(:), pointer:: surface_element_list, fs_surface_element_list - integer i, j, grav_stat, dens_stat, external_density_stat - logical:: include_normals - logical:: implicit_prognostic_fs, use_fs_mesh - logical:: move_mesh, variable_density, have_density, have_external_density - - ewrite(1,*) 'Entering assemble_masslumped_poisson_rhs_free_surface' - - ! gravity acceleration - call get_option('/physical_parameters/gravity/magnitude', g, stat=grav_stat) - if (grav_stat/=0) then - FLExit("For a free surface you need gravity") - end if - - ! with a free surface the initial condition prescribed for pressure - ! is used at the free surface nodes only - p => extract_scalar_field(state, "Pressure") - u => extract_vector_field(state, "Velocity") - - ! the prognostic free surface can only be used with the no_normal_stress option - implicit_prognostic_fs=has_implicit_viscous_free_surface_bc(u) - if(implicit_prognostic_fs) then - free_surface => extract_scalar_field(state, "FreeSurface") - assert(have_option(trim(free_surface%option_path)//"/prognostic")) - if (.not. has_boundary_condition_name(free_surface, "_implicit_free_surface")) then - call initialise_implicit_prognostic_free_surface(state, free_surface, u) + if (associated(extended_mesh%halos)) then + allocate(cmc_sparsity%row_halo) + cmc_sparsity%row_halo = extended_mesh%halos(2) + call incref(cmc_sparsity%row_halo) + allocate(cmc_sparsity%column_halo) + cmc_sparsity%column_halo = extended_mesh%halos(2) + call incref(cmc_sparsity%column_halo) + end if + + call allocate(cmc_m, cmc_sparsity, name="ExtendedPressurePoissonMatrix") + call insert(state, cmc_m, cmc_m%name) + call deallocate(cmc_m) + call deallocate(cmc_sparsity) + call deallocate(grad_sparsity) + + cmc_m_ptr => extract_csr_matrix(state, "ExtendedPressurePoissonMatrix") + if (present(get_cmc)) then + get_cmc = mesh_moved + end if + + end function get_extended_pressure_poisson_matrix + + function get_extended_schur_auxillary_sparsity(state, ct_m, extended_mesh) result (aux_sparsity_ptr) + ! returns the sparsity of the schur auxillary matrix from state (or creates a new one if none present) + ! with extra rows and columns associated with prognostic fs nodes + ! here it is assumed that the matrix has the same sparsity as the pressure poisson matrix has, obtained + ! by sparsity multiplication of C^T * C + type(state_type), intent(inout):: state + type(block_csr_matrix), intent(in):: ct_m + type(mesh_type), intent(in):: extended_mesh + type(csr_sparsity), pointer:: aux_sparsity_ptr + + type(csr_sparsity):: grad_sparsity, aux_sparsity + + if (.not. has_csr_sparsity(state, "ExtendedSchurAuxillarySparsity")) then + grad_sparsity=transpose(ct_m%sparsity) + aux_sparsity = matmul(ct_m%sparsity, grad_sparsity) + aux_sparsity%name="ExtendedSchurAuxillarySparsity" + + if (associated(extended_mesh%halos)) then + allocate(aux_sparsity%row_halo) + aux_sparsity%row_halo = extended_mesh%halos(2) + call incref(aux_sparsity%row_halo) + allocate(aux_sparsity%column_halo) + aux_sparsity%column_halo = extended_mesh%halos(2) + call incref(aux_sparsity%column_halo) + end if + + call insert(state, aux_sparsity, aux_sparsity%name) + call deallocate(aux_sparsity) + call deallocate(grad_sparsity) + end if + + aux_sparsity_ptr => extract_csr_sparsity(state, "ExtendedSchurAuxillarySparsity") + + end function get_extended_schur_auxillary_sparsity + + subroutine add_implicit_viscous_free_surface_integrals(state, ct_m, u, & + p_mesh, fs) + ! This routine adds in the boundary conditions for the viscous free surface + ! (that is the free_surface bc with the no_normal_stress option) + ! ct_m has been extended with some extra rows (corresponding to free surface + ! nodes) that are used to enforce the kinematic bc, the transpose of that + ! will produce the \rho_0 g\eta term in the no_normal_stress boundary condition: + ! n\cdot\tau\cdot n + p - \rho_0 g\eta = 0 + ! if pressure is also extended to contain \rho g\eta in the extra nodes. + + type(state_type), intent(inout):: state + type(block_csr_matrix), intent(inout):: ct_m + type(vector_field), intent(in):: u + type(mesh_type), intent(in):: p_mesh ! the extended pressure mesh + type(scalar_field), intent(inout):: fs + + type(vector_field), pointer:: x + type(mesh_type), pointer:: fs_mesh, embedded_fs_mesh + type(integer_hash_table):: sele_to_fs_ele + character(len=FIELD_NAME_LEN):: bc_type + character(len=OPTION_PATH_LEN):: bc_option_path + logical :: radial_fs + integer, dimension(:), pointer:: surface_element_list + integer:: i, j + + assert(have_option(trim(fs%option_path)//"/prognostic")) + + if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then + call initialise_implicit_prognostic_free_surface(state, fs, u) end if ! obtain the f.s. surface mesh that has been stored under the ! "_implicit_free_surface" boundary condition - call get_boundary_condition(free_surface, "_implicit_free_surface", & - surface_element_list=fs_surface_element_list) - ! create a map from face numbers to element numbers in the fs mesh - call invert_set(fs_surface_element_list, sele_to_fs_ele) - scaled_fs => extract_surface_field(free_surface, "_implicit_free_surface", "ScaledFreeSurface") + call get_boundary_condition(fs, "_implicit_free_surface", & + surface_mesh=fs_mesh, surface_element_list=surface_element_list) + ! create a map from face numbers to element numbers in fs_mesh + call invert_set(surface_element_list, sele_to_fs_ele) embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - end if - - ! reference density - call get_fs_reference_density_from_options(rho0, state%option_path) - density => extract_scalar_field(state, "Density", stat=dens_stat) - have_density = (dens_stat==0) - - ! only include the inner product of gravity and surface normal - ! if the free surface nodes are actually moved (not necessary - ! for large scale ocean simulations) - include_normals = have_option("/mesh_adaptivity/mesh_movement/free_surface") - if (include_normals) then - ewrite(2,*) 'Including inner product of normals in kinematic bc' - gravity_normal => extract_vector_field(state, "GravityDirection") - end if - - move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") - ! adding in the free surface integral using the free surface - ! elevation (p/rho0/g) specified by the inital pressure at the surface nodes - ! or, with prognostic fs, use the free surface node values directly - positions => extract_vector_field(state, "Coordinate") - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - if (have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then - assert(implicit_prognostic_fs) - use_fs_mesh=.true. - else - use_fs_mesh=.false. - end if - coef=g*theta_pg**2*dt**2 - - variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & - .and. (.not.move_mesh) - if(variable_density.and.(.not.have_density)) then - FLExit("Variable density free surface requires a Density field.") - end if - - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - - do j=1, size(surface_element_list) - call add_free_surface_element(j, surface_element_list(j)) - end do + + x => extract_vector_field(state, "Coordinate") + + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bc_type, option_path=bc_option_path, & + surface_element_list=surface_element_list) + if (bc_type=="free_surface") then + if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then + radial_fs = have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/radial_normals") + do j=1, size(surface_element_list) + call add_boundary_integral_sele(surface_element_list(j)) + end do + end if + end if + end do + + contains + + subroutine add_boundary_integral_sele(sele) + integer, intent(in):: sele + + real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy + real, dimension(u%dim, face_loc(fs, sele), face_loc(u, sele)) :: ht_mat_bdy + real, dimension(face_ngi(u, sele)) :: detwei_bdy + real, dimension(u%dim, face_ngi(u, sele)) :: normal_bdy, radials_bdy + integer:: dim + + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) + ct_mat_bdy = shape_shape_vector(face_shape(p_mesh, sele), face_shape(u, sele), & + detwei_bdy, normal_bdy) + if (radial_fs) then + ! use purely radial normals instead + radials_bdy = radial_inward_normal_at_quad_face(X, sele) + detwei_bdy = detwei_bdy * sign(1.0, sum(radials_bdy*normal_bdy, dim=1)) + normal_bdy = radials_bdy + end if + ht_mat_bdy = shape_shape_vector(face_shape(fs, sele), face_shape(u, sele), & + detwei_bdy, normal_bdy) + do dim=1, u%dim + ! we've integrated continuity by parts, but not yet added in the resulting + ! surface integral - for the non-viscous free surface this is left + ! out to enforce the kinematic bc + call addto(ct_m, 1, dim, face_global_nodes(p_mesh,sele), & + face_global_nodes(u,sele), ct_mat_bdy(dim,:,:)) + ! for the viscous bc however we add this bc in the extra rows at the bottom of ct_m + ! this integral will also enforce the \rho_0 g\eta term in the no_normal_stress bc: + ! n\cdot\tau\cdot n + p - (\rho_0-\rho_external) g\eta = 0 + call addto(ct_m, 1, dim, ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & + face_global_nodes(u,sele), -ht_mat_bdy(dim,:,:)) + end do + + end subroutine add_boundary_integral_sele + + end subroutine add_implicit_viscous_free_surface_integrals + + subroutine add_implicit_viscous_free_surface_integrals_cv(state, ct_m, u, & + p_mesh, fs) + ! This routine adds in the boundary conditions for the viscous free surface + ! (that is the free_surface bc with the no_normal_stress option) + ! ct_m has been extended with some extra rows (corresponding to free surface + ! nodes) that are used to enforce the kinematic bc, the transpose of that + ! will produce the \rho_0 g\eta term in the no_normal_stress boundary condition: + ! n\cdot\tau\cdot n + p - \rho_0 g\eta = 0 + ! if pressure is also extended to contain \rho g\eta in the extra nodes. + + type(state_type), intent(inout):: state + type(block_csr_matrix), intent(inout):: ct_m + type(vector_field), intent(in):: u + type(mesh_type), intent(in):: p_mesh ! the extended pressure mesh + type(scalar_field), intent(inout):: fs + + type(vector_field), pointer:: x + type(mesh_type), pointer:: fs_mesh, embedded_fs_mesh + type(integer_hash_table):: sele_to_fs_ele + character(len=FIELD_NAME_LEN):: bc_type + character(len=OPTION_PATH_LEN):: bc_option_path + integer, dimension(:), pointer:: surface_element_list + integer:: i, j + + ! information about cv faces + type(cv_faces_type) :: cvfaces + ! shape functions for region and surface + type(element_type) :: x_cvbdyshape + type(element_type) :: p_cvbdyshape + type(element_type) :: u_cvbdyshape + integer:: quaddegree, ele, sele + + assert(have_option(trim(fs%option_path)//"/prognostic")) + + if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then + call initialise_implicit_prognostic_free_surface(state, fs, u) end if - end do + ! obtain the f.s. surface mesh that has been stored under the + ! "_implicit_free_surface" boundary condition + call get_boundary_condition(fs, "_implicit_free_surface", & + surface_mesh=fs_mesh, surface_element_list=surface_element_list) + ! create a map from face numbers to element numbers in fs_mesh + call invert_set(surface_element_list, sele_to_fs_ele) + embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - if (implicit_prognostic_fs) then - call deallocate(sele_to_fs_ele) - end if + x => extract_vector_field(state, "Coordinate") + + call get_option("/geometry/quadrature/controlvolume_surface_degree", & + quaddegree, default=1) + + cvfaces=find_cv_faces(vertices=ele_vertices(p_mesh, 1), & + dimension=mesh_dim(p_mesh), & + polydegree=p_mesh%shape%degree, & + quaddegree=quaddegree) - contains + x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) + p_cvbdyshape=make_cvbdy_element_shape(cvfaces, p_mesh%faces%shape) + u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) - subroutine add_free_surface_element(surface_mesh_ele, sele) - integer, intent(in):: surface_mesh_ele, sele + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bc_type, option_path=bc_option_path, & + surface_element_list=surface_element_list) + if (bc_type=="free_surface") then + if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then + do j=1, size(surface_element_list) + sele = surface_element_list(j) + ele = face_ele(x, sele) + call add_boundary_integral_sele(sele, ele) + end do + end if + end if + end do + + call deallocate(x_cvbdyshape) + call deallocate(p_cvbdyshape) + call deallocate(u_cvbdyshape) + call deallocate(cvfaces) + + contains + + subroutine add_boundary_integral_sele(sele, ele) + integer, intent(in):: sele, ele + + real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy + real, dimension(u%dim, face_loc(fs, sele), face_loc(u, sele)) :: ht_mat_bdy + real, dimension(face_ngi(u, sele)) :: detwei_bdy + real, dimension(x_cvbdyshape%ngi) :: detwei_bdy_cv + real, dimension(x%dim, face_ngi(x, sele)) :: normal_bdy + real, dimension(x%dim, x_cvbdyshape%ngi) :: normal_bdy_cv + real, dimension(x%dim, ele_loc(x, ele)) :: x_ele + real, dimension(x%dim, face_loc(x, sele)) :: x_ele_bdy + integer:: dim, gi, ggi, iloc, jloc, face + + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy_cv, detwei_bdy_cv) + + ct_mat_bdy = 0.0 + surface_nodal_loop_i: do iloc = 1, face_loc(p_mesh, sele) + + surface_face_loop: do face = 1, cvfaces%sfaces + if(cvfaces%sneiloc(iloc,face)/=0) then + + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + + ggi = (face-1)*cvfaces%shape%ngi + gi + + surface_nodal_loop_j: do jloc = 1, face_loc(u, sele) + + surface_inner_dimension_loop: do dim = 1, size(normal_bdy_cv,1) + + ct_mat_bdy(dim, iloc, jloc) = ct_mat_bdy(dim, iloc, jloc) + & + u_cvbdyshape%n(jloc,ggi)*detwei_bdy_cv(ggi)*normal_bdy_cv(dim, ggi) + + end do surface_inner_dimension_loop + + end do surface_nodal_loop_j + + end do surface_quadrature_loop + + end if + + end do surface_face_loop + + end do surface_nodal_loop_i + + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) + ht_mat_bdy = shape_shape_vector(face_shape(fs, sele), face_shape(u, sele), & + detwei_bdy, normal_bdy) + + + do dim=1, u%dim + ! we've integrated continuity by parts, but not yet added in the resulting + ! surface integral - for the non-viscous free surface this is left + ! out to enforce the kinematic bc + call addto(ct_m, 1, dim, face_global_nodes(p_mesh,sele), & + face_global_nodes(u,sele), ct_mat_bdy(dim,:,:)) + ! for the viscous bc however we add this bc in the extra rows at the bottom of ct_m + ! this integral will also enforce the \rho_0 g\eta term in the no_normal_stress bc: + ! n\cdot\tau\cdot n + p - (\rho_0-\rho_external) g\eta = 0 + call addto(ct_m, 1, dim, ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & + face_global_nodes(u,sele), -ht_mat_bdy(dim,:,:)) + end do + + end subroutine add_boundary_integral_sele + + end subroutine add_implicit_viscous_free_surface_integrals_cv + + subroutine add_explicit_viscous_free_surface_integrals(state, mom_rhs, ct_m, & + reassemble_ct_m, u, p_mesh, fs) + type(state_type), intent(inout):: state + type(vector_field), intent(inout):: mom_rhs + type(block_csr_matrix), intent(inout):: ct_m + logical, intent(in):: reassemble_ct_m + type(vector_field), intent(in):: u + type(mesh_type), intent(in):: p_mesh + type(scalar_field), intent(in):: fs + + type(scalar_field), pointer:: it_fs, old_fs, density, external_density + type(vector_field), pointer:: x + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + real:: itheta, rho0, g + integer, dimension(:), pointer:: surface_element_list + integer:: i, j, dens_stat, stat, external_density_stat + logical:: variable_density, have_density, move_mesh, have_external_density - real, dimension(face_loc(p, sele)):: values - real, dimension(positions%dim, face_ngi(positions, sele)):: normals - real, dimension(face_loc(p, sele), face_loc(p, sele)):: mass_ele - real, dimension(face_ngi(p, sele)):: detwei - real, dimension(face_ngi(p, sele)):: inv_delta_rho_quad - integer, dimension(face_loc(p, sele)):: nodes - integer:: ele + assert(have_option(trim(fs%option_path)//"/prognostic")) - ele=face_ele(positions, sele) - call transform_facet_to_physical(positions, sele, detwei_f=detwei,& - & normal=normals) - if (include_normals) then - ! at each gauss point multiply with inner product of gravity and surface normal - detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) - end if + it_fs => extract_scalar_field(state, "IteratedFreeSurface") + old_fs => extract_scalar_field(state, "OldFreeSurface") - if(variable_density .and. have_external_density) then - inv_delta_rho_quad = 1.0/(face_val_at_quad(density, sele) - ele_val_at_quad(external_density, surface_mesh_ele)) - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*inv_delta_rho_quad) - else if (variable_density) then - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei/face_val_at_quad(density, sele)) - else if (have_external_density) then - mass_ele = shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) / (rho0 - node_val(external_density, 1)) - else - mass_ele = shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) / rho0 + move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") + x => extract_vector_field(state, "Coordinate") + ! reference density + call get_fs_reference_density_from_options(rho0, state%option_path) + density => extract_scalar_field(state, "Density", stat=dens_stat) + have_density = (dens_stat==0) + call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) + if (stat/=0) then + FLExit("For a free surface you need gravity") end if - if (use_fs_mesh) then - nodes = ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)) - values = ele_val(scaled_fs, fetch(sele_to_fs_ele, sele)) - else - nodes = face_global_nodes(p, sele) - values = face_val(p, sele) - end if + call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/relaxation", & + itheta) - call addto(poisson_rhs, nodes, matmul(mass_ele, values)/coef) - - end subroutine add_free_surface_element - - end subroutine add_free_surface_to_poisson_rhs - - subroutine copy_poisson_solution_to_interior(state, p_theta, p, old_p, u) - !!< Copy the solved for initial Poisson solution p_theta into p and old_p - !!< but maintain initial condition for free surface nodes. - type(state_type), intent(in):: state - type(scalar_field), intent(inout), target:: p_theta, p, old_p - type(vector_field), intent(in):: u - - type(scalar_field), pointer:: free_surface - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - logical:: prognostic_fs - integer, dimension(:), pointer:: surface_element_list - integer:: fs_stat - integer:: i, j, sele - - ! the prognostic free surface can only be used with the no_normal_stress option - free_surface => extract_scalar_field(state, "FreeSurface", stat=fs_stat) - prognostic_fs=.false. - if (fs_stat==0) then - prognostic_fs=have_option(trim(free_surface%option_path)//"/prognostic") - end if - - if (prognostic_fs) then - ! only copy over solved for pressure values - ! we keep the initial free surface - call set_all(p, p_theta%val(1:node_count(p))) - else - - ! first copy initial free surface elevations (p/g) at free surface nodes - ! to p_theta do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & + call get_boundary_condition(u, i, type=bctype, & surface_element_list=surface_element_list, & option_path=fs_option_path) - if (bctype=="free_surface") then + if (bctype=="free_surface") then + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & + have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit")) then + + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 + + variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & + .and. (.not.move_mesh) + if (variable_density.and.(.not.have_density)) then + FLExit("Variable density free surface requires a Density field.") + end if + + do j=1, size(surface_element_list) + call add_boundary_integral_sele(j, surface_element_list(j)) + end do + end if + end if + end do - if (have_option(trim(fs_option_path)//"/type[0]/no_normal_stress")) then - ! this should have been options checked - FLAbort("No normal stress free surface without prognostic free surface") - end if + contains + + subroutine add_boundary_integral_sele(surface_mesh_ele, sele) + integer, intent(in):: surface_mesh_ele, sele + + real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy + real, dimension(face_ngi(u, sele)) :: detwei_bdy + real, dimension(u%dim, face_ngi(u, sele)) :: normal_bdy + real, dimension(face_ngi(fs, sele)):: delta_rho_g_quad + integer, dimension(face_loc(u, sele)) :: u_nodes_bdy + integer, dimension(face_loc(p_mesh, sele)) :: p_nodes_bdy + integer:: dim + + u_nodes_bdy = face_global_nodes(u, sele) + + if(variable_density .and. have_external_density) then + delta_rho_g_quad = g*(face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele)) + else if (variable_density) then + delta_rho_g_quad = g*face_val_at_quad(density, sele) + else if (have_external_density) then + delta_rho_g_quad = g*(rho0-node_val(external_density,1)) + else + delta_rho_g_quad = g*rho0 + end if - do j=1, size(surface_element_list) - sele=surface_element_list(j) - call set(p_theta, face_global_nodes(p_theta,sele), face_val(p, sele)) - end do + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) - end if - end do + call addto(mom_rhs, u_nodes_bdy, shape_vector_rhs(face_shape(u, sele), normal_bdy, & + -detwei_bdy*delta_rho_g_quad* & + (itheta*face_val_at_quad(it_fs, sele) + & + (1.0-itheta)*face_val_at_quad(old_fs, sele)))) + + if(reassemble_ct_m) then + p_nodes_bdy = face_global_nodes(p_mesh, sele) + + ct_mat_bdy = shape_shape_vector(face_shape(p_mesh, sele), face_shape(u, sele), & + detwei_bdy, normal_bdy) - ! then copy everything (including interior) back from p_theta to p - call set(p, p_theta) - end if - - ! p and old_p should be the same (as we're in the first non-linear iteration) - ! but they might be different fields (if #nonlinear iterations>1) - call set(old_p, p) - ewrite_minmax(p) - - end subroutine copy_poisson_solution_to_interior - - subroutine initialise_implicit_prognostic_free_surface(state, fs, u) - !!< Setup ScaledFreeSurface and OldScaledFreeSurface surface fields (to contain - !!< \Delta\rho g\eta values). Initialise them with initial condition (requires - !!< little mass matrix solve). - type(state_type), intent(inout):: state - type(scalar_field), intent(inout):: fs - type(vector_field), intent(in):: u - - character(len=OPTION_PATH_LEN):: fs_option_path - character(len=FIELD_NAME_LEN):: bctype - type(integer_set):: surface_elements - type(mesh_type), pointer:: surface_mesh - type(scalar_field):: scaled_fs, old_scaled_fs - type(integer_hash_table):: sele_to_fs_ele - integer, dimension(:), pointer:: surface_element_list, surface_node_list - integer:: i - - - ewrite(1,*) 'Entering initialise_implicit_prognostic_free_surface' - - call allocate(surface_elements) - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then - ! include only implicit free surfaces - call insert(surface_elements, surface_element_list) + do dim=1, u%dim + ! we've integrated continuity by parts, but not yet added in the resulting + ! surface integral - for the non-viscous free surface this is left + ! out to enforce the kinematic bc + call addto(ct_m, 1, dim, p_nodes_bdy, u_nodes_bdy, ct_mat_bdy(dim,:,:)) + end do end if - end if - end do - - allocate(surface_element_list(1:key_count(surface_elements))) - surface_element_list=set2vector(surface_elements) - call add_boundary_condition_surface_elements(fs, "_implicit_free_surface", "free_surface", & - surface_element_list) - call invert_set(surface_element_list, sele_to_fs_ele) - deallocate(surface_element_list) - call deallocate(surface_elements) - - call get_boundary_condition(fs, "_implicit_free_surface", surface_mesh=surface_mesh, & - surface_node_list=surface_node_list) - if (IsParallel()) then - call generate_surface_mesh_halos(fs%mesh, surface_mesh, surface_node_list) - end if - - call allocate(scaled_fs, surface_mesh, "ScaledFreeSurface") - call zero(scaled_fs) - - call solve_initial_scaled_free_surface(state, scaled_fs, u, sele_to_fs_ele, fs) - - call insert_surface_field(fs, "_implicit_free_surface", scaled_fs) - - call allocate(old_scaled_fs, surface_mesh, "OldScaledFreeSurface") - call set(old_scaled_fs, scaled_fs) - call deallocate(scaled_fs) - - call insert_surface_field(fs, "_implicit_free_surface", old_scaled_fs) - call deallocate(old_scaled_fs) - - call deallocate(sele_to_fs_ele) - - - end subroutine initialise_implicit_prognostic_free_surface - - subroutine solve_initial_scaled_free_surface(state, scaled_fs, u, sele_to_fs_ele, fs) - !!< Solve for the initial value of the "ScaledFreeSurface" surface field, this is - !!< obtained by solving scaled_fs = g*delta_rho*fs as a mass matrix equation on the surface - !!< where fs is the initial condition (or interpolated after adaptivity) value of the prognostic fs field - type(state_type), intent(inout):: state - type(scalar_field), intent(inout):: scaled_fs ! the surface field solved for - type(vector_field), intent(in):: u - ! a map between surface element nos of the fs%mesh, and elements in scaled_fs%mesh: - type(integer_hash_table), intent(in):: sele_to_fs_ele - type(scalar_field), intent(in):: fs ! the full, prognostic fs - - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - real:: rho0, g - integer, dimension(:), pointer:: surface_element_list - integer:: i, j, stat, external_density_stat - - type(csr_sparsity), pointer :: surface_sparsity - type(csr_matrix):: fs_matrix - type(scalar_field):: fs_rhs - type(vector_field), pointer :: x - type(scalar_field), pointer :: density, external_density - logical :: have_density, variable_density, move_mesh, have_external_density - - ewrite(1,*) "Inside solve_initial_scaled_free_surface" - - move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") - x => extract_vector_field(state, "Coordinate") - call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) - if (stat/=0) then - FLExit("For a free surface you need gravity") - end if - density => extract_scalar_field(state, "Density", stat=stat) - have_density = (stat==0) - call get_fs_reference_density_from_options(rho0, state%option_path) - - surface_sparsity => get_csr_sparsity_firstorder(state, scaled_fs%mesh, scaled_fs%mesh) - call allocate(fs_matrix, surface_sparsity, name="FSMatrix") - call zero(fs_matrix) - call allocate(fs_rhs, scaled_fs%mesh, name="FSRHS") - call zero(fs_rhs) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit"))) then - - variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & - .and. (.not.move_mesh) - if (variable_density.and.(.not.have_density)) then - FLExit("Variable density free surface requires a Density field.") - end if - - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - - do j=1, size(surface_element_list) - call add_boundary_integral_sele(j, surface_element_list(j)) - end do - end if - end if - end do - call petsc_solve(scaled_fs, fs_matrix, fs_rhs, option_path=trim(fs%option_path)) - ewrite_minmax(fs) - ewrite_minmax(scaled_fs) + end subroutine add_boundary_integral_sele + + end subroutine add_explicit_viscous_free_surface_integrals - call deallocate(fs_matrix) - call deallocate(fs_rhs) + subroutine add_explicit_viscous_free_surface_integrals_cv(state, ct_m, & + reassemble_ct_m, u, p_mesh, fs, mom_rhs) + type(state_type), intent(inout):: state + type(block_csr_matrix), intent(inout):: ct_m + logical, intent(in):: reassemble_ct_m + type(vector_field), intent(in):: u + type(mesh_type), intent(in):: p_mesh + type(scalar_field), intent(inout):: fs + type(vector_field), intent(inout), optional:: mom_rhs - contains + type(scalar_field), pointer:: it_fs, old_fs, density, external_density + type(vector_field), pointer:: x + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: fs_option_path + real:: itheta, rho0, g + integer, dimension(:), pointer:: surface_element_list + integer:: i, j, dens_stat, stat, external_density_stat + logical:: variable_density, have_density, move_mesh, have_external_density - subroutine add_boundary_integral_sele(surface_mesh_ele, sele) - integer, intent(in):: surface_mesh_ele, sele + ! information about cv faces + type(cv_faces_type) :: cvfaces + ! shape functions for region and surface + type(element_type) :: x_cvbdyshape + type(element_type) :: p_cvbdyshape + type(element_type) :: u_cvbdyshape + integer:: quaddegree, ele, sele - real, dimension(face_ngi(fs, sele)) :: detwei_bdy - real, dimension(face_ngi(fs, sele)):: delta_rho_quad - integer :: fs_ele + if (.not.present(mom_rhs) .and. .not. reassemble_ct_m) return - if(variable_density .and. have_external_density) then - delta_rho_quad = face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele) - else if (variable_density) then - delta_rho_quad = face_val_at_quad(density, sele) - else if (have_external_density) then - delta_rho_quad = rho0-node_val(external_density, 1) - else - delta_rho_quad = rho0 - end if + assert(have_option(trim(fs%option_path)//"/prognostic")) - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy) + it_fs => extract_scalar_field(state, "IteratedFreeSurface") + old_fs => extract_scalar_field(state, "OldFreeSurface") - fs_ele = fetch(sele_to_fs_ele, sele) - call addto(fs_matrix, ele_nodes(scaled_fs, fs_ele), & - ele_nodes(scaled_fs, fs_ele), & - shape_shape(face_shape(fs, sele), face_shape(fs, sele), detwei_bdy)) + move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") + x => extract_vector_field(state, "Coordinate") + ! reference density + call get_fs_reference_density_from_options(rho0, state%option_path) + density => extract_scalar_field(state, "Density", stat=dens_stat) + have_density = (dens_stat==0) + call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) + if (stat/=0) then + FLExit("For a free surface you need gravity") + end if - call addto(fs_rhs, ele_nodes(scaled_fs, fs_ele), & - shape_rhs(face_shape(fs,sele), & - detwei_bdy * face_val_at_quad(fs,sele) * g * delta_rho_quad)) + call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/relaxation", & + itheta) - end subroutine add_boundary_integral_sele + call get_option("/geometry/quadrature/controlvolume_surface_degree", & + quaddegree, default=1) - end subroutine solve_initial_scaled_free_surface + cvfaces=find_cv_faces(vertices=ele_vertices(p_mesh, 1), & + dimension=mesh_dim(p_mesh), & + polydegree=p_mesh%shape%degree, & + quaddegree=quaddegree) - subroutine initialise_prognostic_free_surface(fs, u) - type(scalar_field), intent(inout):: fs - type(vector_field), intent(in):: u + x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) + p_cvbdyshape=make_cvbdy_element_shape(cvfaces, p_mesh%faces%shape) + u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) - type(mesh_type), pointer:: surface_mesh - type(integer_set):: surface_elements - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - integer, dimension(:), pointer:: surface_element_list, surface_node_list - integer:: i + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, option_path=fs_option_path, & + surface_element_list=surface_element_list) + if (bctype=="free_surface") then + if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & + have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit")) then + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 + + variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & + .and. (.not.move_mesh) + if (variable_density.and.(.not.have_density)) then + FLExit("Variable density free surface requires a Density field.") + end if + + do j=1, size(surface_element_list) + sele = surface_element_list(j) + ele = face_ele(x, sele) + call add_boundary_integral_sele(j, sele, ele) + end do + end if + end if + end do - ewrite(1,*) 'Entering initialise_prognostic_free_surface' + call deallocate(x_cvbdyshape) + call deallocate(p_cvbdyshape) + call deallocate(u_cvbdyshape) + call deallocate(cvfaces) + + contains + + subroutine add_boundary_integral_sele(surface_mesh_ele, sele, ele) + integer, intent(in):: surface_mesh_ele, sele, ele + + real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy + real, dimension(face_ngi(u, sele)) :: detwei_bdy + real, dimension(x_cvbdyshape%ngi) :: detwei_bdy_cv + real, dimension(x%dim, face_ngi(x, sele)) :: normal_bdy + real, dimension(x%dim, x_cvbdyshape%ngi) :: normal_bdy_cv + real, dimension(face_ngi(fs, sele)):: delta_rho_g_quad + integer, dimension(face_loc(u, sele)) :: u_nodes_bdy + integer, dimension(face_loc(p_mesh, sele)) :: p_nodes_bdy + real, dimension(x%dim, ele_loc(x, ele)) :: x_ele + real, dimension(x%dim, face_loc(x, sele)) :: x_ele_bdy + integer:: dim, gi, ggi, iloc, jloc, face + + u_nodes_bdy = face_global_nodes(u, sele) + + if (present(mom_rhs)) then + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) + + if(variable_density .and. have_external_density) then + delta_rho_g_quad = g*(face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele)) + else if (variable_density) then + delta_rho_g_quad = g*face_val_at_quad(density, sele) + else if (have_external_density) then + delta_rho_g_quad = g*(rho0-node_val(external_density, 1)) + else + delta_rho_g_quad = g*rho0 + end if - call allocate(surface_elements) - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress")) then - ! include all explicit and implicit free surfaces - call insert(surface_elements, surface_element_list) + call addto(mom_rhs, u_nodes_bdy, shape_vector_rhs(face_shape(u, sele), normal_bdy, & + -detwei_bdy*delta_rho_g_quad* & + (itheta*face_val_at_quad(it_fs, sele) + & + (1.0-itheta)*face_val_at_quad(old_fs, sele)))) end if - end if - end do - - allocate(surface_element_list(1:key_count(surface_elements))) - surface_element_list=set2vector(surface_elements) - call add_boundary_condition_surface_elements(fs, "_free_surface", "free_surface", & - surface_element_list) - deallocate(surface_element_list) - call deallocate(surface_elements) - if (IsParallel()) then - call get_boundary_condition(fs, "_free_surface", surface_mesh=surface_mesh, & - surface_node_list=surface_node_list) - call generate_surface_mesh_halos(fs%mesh, surface_mesh, surface_node_list) - end if - - end subroutine initialise_prognostic_free_surface - - function get_extended_pressure_mesh_for_viscous_free_surface(state, pressure_mesh, fs) result (extended_pressure_mesh) - ! extend the pressure mesh to contain the extra free surface dofs - ! (doubling the pressure nodes at the free surface). The returned mesh uses - ! a new node numbering that includes the pressure and separate fs nodes, but has - ! the same elements as the pressure_mesh. This routine also creates, seperately, a surface - ! mesh (the "embedded" fs mesh) that uses the same combined pressure and fs node numbering, but only contains the surface - ! elements with fs nodes as its elements. Both are stored in state. - - ! this must be the state containing the prognostic pressure and free surface - type(state_type), intent(inout):: state - ! the origional pressure mesh (without fs nodes) - type(mesh_type), intent(in):: pressure_mesh - ! the prognostic free surface field - type(scalar_field), intent(inout):: fs - type(mesh_type), pointer:: extended_pressure_mesh - - type(integer_vector), dimension(2):: new_node_map - type(vector_field), pointer:: u - type(mesh_type), pointer:: fs_mesh - type(mesh_type):: extended_mesh, embedded_fs_mesh - - integer, dimension(ele_loc(pressure_mesh, 1)):: new_nodes - integer, dimension(face_loc(fs%mesh, 1)):: new_fs_nodes - integer, dimension(:), pointer:: nodes - integer :: ihalo, ele, j, pnodes - logical :: parallel - - if (.not. has_mesh(state, "_extended_pressure_mesh")) then - if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then - u => extract_vector_field(state, "Velocity") - assert(have_option(trim(u%option_path)//"/prognostic")) - call initialise_implicit_prognostic_free_surface(state, fs, u) - end if - ! obtain the f.s. surface mesh that has been stored under the - ! "_implicit_free_surface" boundary condition (this is a surface - ! mesh with a separate fs node numbering) - call get_boundary_condition(fs, "_implicit_free_surface", & - surface_mesh=fs_mesh) + if(reassemble_ct_m) then - if (associated(pressure_mesh%halos) .and. associated(fs_mesh%halos)) then - assert(size(pressure_mesh%halos)==2 .and. size(fs_mesh%halos)==2) + p_nodes_bdy = face_global_nodes(p_mesh, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) - ! create a node numbering for the combined pressure and fs system - ! that is trailing receives consistent - new_node_map = create_combined_numbering_trailing_receives( & - (/ pressure_mesh%halos(1), fs_mesh%halos(1) /), & - (/ pressure_mesh%halos(2), fs_mesh%halos(2) /)) - parallel = .true. - else - assert(.not. associated(pressure_mesh%halos)) - assert(.not. associated(fs_mesh%halos)) - parallel = .false. - end if + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy_cv, detwei_bdy_cv) + ct_mat_bdy = 0.0 + surface_nodal_loop_i: do iloc = 1, face_loc(p_mesh, sele) - call allocate(extended_mesh, node_count(pressure_mesh)+node_count(fs_mesh), & - element_count(pressure_mesh), pressure_mesh%shape, & - "Extended"//trim(pressure_mesh%name)) - extended_mesh%periodic = pressure_mesh%periodic - - do ele=1, element_count(pressure_mesh) - nodes => ele_nodes(pressure_mesh,ele) - if (parallel) then - do j=1, size(nodes) - new_nodes(j) = new_node_map(1)%ptr(nodes(j)) - end do - call set_ele_nodes(extended_mesh, ele, new_nodes) - else - call set_ele_nodes(extended_mesh, ele, nodes) - end if - end do + surface_face_loop: do face = 1, cvfaces%sfaces + if(cvfaces%sneiloc(iloc,face)/=0) then - call add_faces(extended_mesh, model=pressure_mesh) + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - if (parallel) then - ! Allocate extended mesh halos: - allocate(extended_mesh%halos(2)) + ggi = (face-1)*cvfaces%shape%ngi + gi - ! Derive extended_mesh nodal halos: - do ihalo = 1, 2 + surface_nodal_loop_j: do jloc = 1, face_loc(u, sele) - extended_mesh%halos(ihalo) = combine_halos( & - (/ pressure_mesh%halos(ihalo), fs_mesh%halos(ihalo) /), & - new_node_map, & - name="Extended"//trim(pressure_mesh%halos(ihalo)%name)) + surface_inner_dimension_loop: do dim = 1, size(normal_bdy_cv,1) - assert(trailing_receives_consistent(extended_mesh%halos(ihalo))) - assert(halo_valid_for_communication(extended_mesh%halos(ihalo))) - call create_global_to_universal_numbering(extended_mesh%halos(ihalo)) - call create_ownership(extended_mesh%halos(ihalo)) + ct_mat_bdy(dim, iloc, jloc) = ct_mat_bdy(dim, iloc, jloc) + & + u_cvbdyshape%n(jloc,ggi)*detwei_bdy_cv(ggi)*normal_bdy_cv(dim, ggi) - end do - end if + end do surface_inner_dimension_loop - call insert(state, extended_mesh, "_extended_pressure_mesh") - call deallocate(extended_mesh) - - ! now create an auxillary surface mesh, that has the same topology as surface_mesh - ! but uses the node numbering for free surface nodes of the extended mesh - call allocate(embedded_fs_mesh, node_count(extended_mesh), & - element_count(fs_mesh), fs_mesh%shape, & - name="Emmbedded"//trim(fs_mesh%name)) - - pnodes = node_count(pressure_mesh) - do ele=1, element_count(fs_mesh) - nodes => ele_nodes(fs_mesh,ele) - if (parallel) then - do j=1, size(nodes) - new_fs_nodes(j) = new_node_map(2)%ptr(nodes(j)) - end do - else - new_fs_nodes = nodes + pnodes ! fs nodes come after the pressure nodes in the extended mesh - end if - call set_ele_nodes(embedded_fs_mesh, ele, new_fs_nodes) - end do + end do surface_nodal_loop_j - call insert(state, embedded_fs_mesh, "_embedded_free_surface_mesh") - call deallocate(embedded_fs_mesh) + end do surface_quadrature_loop - if (parallel) then - ! the node maps are no longer needed: the correspondence between - ! pressure mesh/fs surface mesh and extended_mesh/embedded_fs_mesh resp. - ! is maintained by looping over the elements of both simultaneously - deallocate(new_node_map(1)%ptr) - deallocate(new_node_map(2)%ptr) - end if + end if - end if + end do surface_face_loop - extended_pressure_mesh => extract_mesh(state, "_extended_pressure_mesh") + end do surface_nodal_loop_i - end function get_extended_pressure_mesh_for_viscous_free_surface + do dim=1, u%dim + ! we've integrated continuity by parts, but not yet added in the resulting + ! surface integral - for the non-viscous free surface this is left + ! out to enforce the kinematic bc + call addto(ct_m, 1, dim, face_global_nodes(p_mesh,sele), & + face_global_nodes(u,sele), ct_mat_bdy(dim,:,:)) + end do + end if - subroutine copy_to_extended_p(p, fs, theta_pg, p_theta) - type(scalar_field), intent(in):: p, fs - real, intent(in):: theta_pg - type(scalar_field), intent(inout):: p_theta - ! copy p and fs into p_theta that is allocated on the extended pressure mesh + end subroutine add_boundary_integral_sele + + end subroutine add_explicit_viscous_free_surface_integrals_cv + + subroutine add_implicit_viscous_free_surface_scaled_mass_integrals(state, mass, u, p_mesh, fs, dt) + ! This routine adds in the boundary conditions for the viscous free surface + ! (that is the free_surface bc with the no_normal_stress option) + ! to the "scaled mass matrix" (pressure mass scaled with inverse of viscosity used as stokes preconditioner) + ! mass has been extended with some extra rows and columns (corresponding to free surface + ! nodes) that are used to enforce the kinematic bc. + ! Here we fill in those terms with the scaled mass on the free surface. + + type(state_type), intent(inout):: state + type(csr_matrix), intent(inout):: mass + type(vector_field), intent(in):: u + type(scalar_field), intent(in):: p_mesh + type(scalar_field), intent(inout):: fs + real, intent(in) :: dt + + type(tensor_field), pointer :: viscosity + type(vector_field), pointer:: x + type(scalar_field) :: viscosity_component + type(mesh_type), pointer:: fs_mesh, embedded_fs_mesh + type(integer_hash_table):: sele_to_fs_ele + character(len=FIELD_NAME_LEN):: bc_type + character(len=OPTION_PATH_LEN):: bc_option_path + integer, dimension(:), pointer:: surface_element_list, fs_surface_element_list + integer:: i, j - type(scalar_field), pointer:: scaled_fs, old_scaled_fs - integer:: powned_nodes, fsowned_nodes + assert(have_option(trim(fs%option_path)//"/prognostic")) - ! obtain the scaled f.s. that has been stored under the - ! "_implicit_free_surface" boundary condition - scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "ScaledFreeSurface") - old_scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "OldScaledFreeSurface") + if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then + call initialise_implicit_prognostic_free_surface(state, fs, u) + end if + ! obtain the f.s. surface mesh that has been stored under the + ! "_implicit_free_surface" boundary condition + call get_boundary_condition(fs, "_implicit_free_surface", & + surface_mesh=fs_mesh, surface_element_list=fs_surface_element_list) + ! create a map from face numbers to element numbers in fs_mesh + call invert_set(fs_surface_element_list, sele_to_fs_ele) + embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - powned_nodes = nowned_nodes(p) - fsowned_nodes = nowned_nodes(scaled_fs) + x => extract_vector_field(state, "Coordinate") - ! p is not theta weighted (as usual for incompressible) - p_theta%val(1:powned_nodes) = p%val(1:powned_nodes) + ! Extract viscosity tensor from state: + viscosity => extract_tensor_field(state,'Viscosity') - ! setting this to the old scaled fs values means we're calculating the change in the free surface across the timestep - ! not just since the last solve - unlike pressure where delta_p is since the last solve! - p_theta%val(powned_nodes+1:powned_nodes+fsowned_nodes) = theta_pg*scaled_fs%val(1:fsowned_nodes) + (1.-theta_pg)*old_scaled_fs%val(1:fsowned_nodes) + ! Extract first component of viscosity tensor from full tensor: + viscosity_component = extract_scalar_field(viscosity,1,1) - ! we only copy the owned nodes into to combined pressure/fs field p_theta - ! because the renumbering of the receive nodes is a little more complicated - ! therefore, do a halo update to give the receive nodes its correct values as well - call halo_update(p_theta) + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bc_type, & + option_path=bc_option_path, & + surface_element_list=surface_element_list) + if (bc_type=="free_surface") then + if (have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & + (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then + do j=1, size(surface_element_list) + call add_boundary_integral_sele(surface_element_list(j)) + end do + end if + end if + end do - end subroutine copy_to_extended_p + contains - subroutine update_pressure_and_viscous_free_surface(state, p, fs, delta_p, theta_pg) - type(state_type), intent(inout):: state - ! after the pressure+fs projection add in the solved for delta_p - ! into the pressure and prognostic fs - type(scalar_field), intent(inout):: p, fs - type(scalar_field), intent(in):: delta_p - real, intent(in):: theta_pg + subroutine add_boundary_integral_sele(sele) + integer, intent(in):: sele - type(vector_field), pointer:: u - type(scalar_field), pointer :: scaled_fs - integer:: powned_nodes, fsowned_nodes - real:: dt + real, dimension(face_loc(p_mesh, sele), face_loc(p_mesh, sele)) :: mat_bdy + real, dimension(face_ngi(p_mesh, sele)) :: detwei_bdy - ewrite(1,*) 'Entering update_pressure_and_viscous_free_surface' + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy) + mat_bdy = shape_shape(face_shape(fs, sele), face_shape(fs, sele), & + detwei_bdy/(face_val_at_quad(viscosity_component, sele)*dt)) + call addto(mass, ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & + ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & + mat_bdy) - u => extract_vector_field(state, "Velocity") - if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then - assert(have_option(trim(u%option_path)//"/prognostic")) - call initialise_implicit_prognostic_free_surface(state, fs, u) - end if - ! obtain the scaled f.s. that has been stored under the - ! "_implicit_free_surface" boundary condition - scaled_fs => extract_surface_field(fs, "_implicit_free_surface", "ScaledFreeSurface") + end subroutine add_boundary_integral_sele - call get_option('/timestepping/timestep', dt) + end subroutine add_implicit_viscous_free_surface_scaled_mass_integrals - powned_nodes = nowned_nodes(p) - fsowned_nodes = nowned_nodes(scaled_fs) - p%val(1:powned_nodes) = p%val(1:powned_nodes) + delta_p%val(1:powned_nodes)/dt - call halo_update(p) + subroutine move_mesh_free_surface(states, initialise, nonlinear_iteration) + type(state_type), dimension(:), intent(inout) :: states + ! if present_and_true: zero gridvelocity and compute OldCoordinate=Coordinate=IteratedCoordinate + logical, intent(in), optional :: initialise + ! only supply if total number nonlinear_iterations>1, in which case we do something else for the first nonlinear_iteration + integer, intent(in), optional:: nonlinear_iteration - scaled_fs%val(1:fsowned_nodes) = scaled_fs%val(1:fsowned_nodes) + delta_p%val(powned_nodes+1:powned_nodes+fsowned_nodes)/(dt*theta_pg) - call halo_update(scaled_fs) - ewrite_minmax(scaled_fs) + type(vector_field), pointer :: velocity + real :: itheta + integer :: i, its - end subroutine update_pressure_and_viscous_free_surface + logical :: complete - function get_extended_velocity_divergence_matrix(state, u, fs, & - extended_mesh, get_ct, ct_m_name) result (ct_m_ptr) - ! returns the velocity divergence matrix from state (or creates a new one if none present) - ! with extra rows associated with prognostic fs nodes - ! this routine mimicks the behaviour of get_velocity_divergence_matrix() - type(state_type), intent(inout):: state - type(vector_field), intent(in):: u - type(scalar_field), intent(in):: fs - type(mesh_type), intent(in):: extended_mesh - ! returns .true. if the matrix needs to be reassembled (because it has just been allocated or because of mesh movement) - logical, optional, intent(out):: get_ct - character(len=*), intent(in), optional :: ct_m_name - type(block_csr_matrix), pointer:: ct_m_ptr - - type(block_csr_matrix):: new_ct_m - type(csr_sparsity), pointer:: sparsity - integer:: stat - integer, save:: last_mesh_movement = -1 - logical:: mesh_moved - character(len=FIELD_NAME_LEN) :: l_ct_m_name - - mesh_moved = eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - - ! Form the ct_m_name dependent on interface argument - if (present(ct_m_name)) then - l_ct_m_name = trim(ct_m_name) - else - l_ct_m_name = "ExtendedVelocityDivergenceMatrix" - end if - - ct_m_ptr => extract_block_csr_matrix(state, l_ct_m_name, stat=stat) - if (stat==0) then - if (present(get_ct)) then - get_ct = mesh_moved - end if - return - end if - - sparsity => get_extended_velocity_divergence_sparsity(state, u, fs, extended_mesh) - - call allocate(new_ct_m, sparsity, blocks=(/ 1, u%dim /), name=l_ct_m_name) - call insert(state, new_ct_m, new_ct_m%name) - call deallocate(new_ct_m) - - ct_m_ptr => extract_block_csr_matrix(state, l_ct_m_name) - - if (present(get_ct)) then - get_ct = .true. - end if - - end function get_extended_velocity_divergence_matrix - - function get_extended_velocity_divergence_sparsity(state, u, fs, extended_mesh) result (sparsity) - ! returns the sparsity of the velocity divergence matrix from state (or creates a new one if none present) - ! with extra rows associated with prognostic fs nodes - ! this routine mimicks the behaviour of get_velocity_divergence_matrix() - type(state_type), intent(inout):: state - type(vector_field), intent(in):: u - type(scalar_field), intent(in):: fs - type(mesh_type), intent(in):: extended_mesh - type(csr_sparsity), pointer:: sparsity - - type(mesh_type), pointer:: embedded_fs_mesh - type(mesh_type):: u_surface_mesh - type(csr_sparsity):: new_sparsity, fs_sparsity, p_sparsity - integer, dimension(:), pointer :: fs_surface_element_list - integer, dimension(:), pointer :: p_row, fs_row, new_row - integer:: entries, stat, i, sele - - sparsity => extract_csr_sparsity(state, "ExtendedVelocityDivergenceSparsity", stat=stat) - if (stat==0) return - - ! this will create a sparsity with only the rows associated with the pressure - ! nodes filled in (in the extended mesh numbering), fs nodes have zero row length - p_sparsity = make_sparsity(extended_mesh, u%mesh, name="TempPartialSparsityPressure") - - ! now do the same for rows associated with fs nodes in the combined mesh - ! to make this sparsity we need a velocity surface mesh that uses the - ! velocity dof numbering of the entire mesh - call get_boundary_condition(fs, "_implicit_free_surface", & - surface_element_list=fs_surface_element_list) - call allocate(u_surface_mesh, node_count(u), size(fs_surface_element_list), & - face_shape(u,1), & - name="TempVelocityFreeSurfaceMesh") - do i=1, size(fs_surface_element_list) - sele = fs_surface_element_list(i) - call set_ele_nodes(u_surface_mesh, i, face_global_nodes(u, sele)) - end do - embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - fs_sparsity = make_sparsity(embedded_fs_mesh, u_surface_mesh, name="TempPartialSparsityFreeSurface") - call deallocate(u_surface_mesh) - - ! now we simply combine the two sparsities - entries = size(p_sparsity%colm) + size(fs_sparsity%colm) - call allocate(new_sparsity, node_count(extended_mesh), node_count(u), & - entries, name="ExtendedVelocityDivergenceSparsity") - new_sparsity%findrm(1) = 1 - do i=1, node_count(extended_mesh) - new_sparsity%findrm(i+1) = new_sparsity%findrm(i) + & - row_length(p_sparsity, i) + row_length(fs_sparsity, i) - end do - do i=1, node_count(extended_mesh) - p_row => row_m_ptr(p_sparsity, i) - fs_row => row_m_ptr(fs_sparsity, i) - new_row => row_m_ptr(new_sparsity, i) - if (size(new_row)==size(p_row)) then - new_row = p_row - else if (size(new_row)==size(fs_row)) then - new_row = fs_row + if (present(nonlinear_iteration)) then + ! we do something different in the first nonlinear iteration, see below + its=nonlinear_iteration else - ! we assume that each row is either associated with a fs node, in which case size(p_row)==0 - ! and size(new_row)=size(new_row), or associated with a p node, in which case size(fs_row)==0 - ! and size(new_row)=size(p_row) - FLAbort("Node in combined mesh that is neither fs or pressure node (or both).") - end if - end do - new_sparsity%sorted_rows = p_sparsity%sorted_rows .and. fs_sparsity%sorted_rows - call deallocate(p_sparsity) - call deallocate(fs_sparsity) - - if (associated(extended_mesh%halos)) then - allocate(new_sparsity%row_halo) - new_sparsity%row_halo = extended_mesh%halos(1) - call incref(new_sparsity%row_halo) - allocate(new_sparsity%column_halo) - new_sparsity%column_halo = u%mesh%halos(1) - call incref(new_sparsity%column_halo) - end if - call insert(state, new_sparsity, new_sparsity%name) - call deallocate(new_sparsity) - - sparsity => extract_csr_sparsity(state, "ExtendedVelocityDivergenceSparsity") - - end function get_extended_velocity_divergence_sparsity - - function get_extended_pressure_poisson_matrix(state, ct_m, extended_mesh, get_cmc) result (cmc_m_ptr) - ! returns the pressure poisson matrix from state (or creates a new one if none present) - ! with extra rows and columns associated with prognostic fs nodes - ! this routine mimicks the behaviour of get_pressure_poisson_matrix() - type(state_type), intent(inout):: state - type(block_csr_matrix), intent(in):: ct_m - type(mesh_type), intent(in):: extended_mesh - ! returns .true. if the matrix needs to be reassembled (because it has just been allocated or because of mesh movement) - logical, optional, intent(out):: get_cmc - type(csr_matrix), pointer:: cmc_m_ptr - - type(csr_matrix):: cmc_m - type(csr_sparsity):: grad_sparsity, cmc_sparsity - integer, save:: last_mesh_movement=-1 - integer:: stat - logical:: mesh_moved - - mesh_moved = eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - - cmc_m_ptr => extract_csr_matrix(state, "ExtendedPressurePoissonMatrix", stat=stat) - if (stat==0) then - if (present(get_cmc)) then - get_cmc = mesh_moved - end if - return - end if - - grad_sparsity=transpose(ct_m%sparsity) - cmc_sparsity = matmul(ct_m%sparsity, grad_sparsity) - - if (associated(extended_mesh%halos)) then - allocate(cmc_sparsity%row_halo) - cmc_sparsity%row_halo = extended_mesh%halos(2) - call incref(cmc_sparsity%row_halo) - allocate(cmc_sparsity%column_halo) - cmc_sparsity%column_halo = extended_mesh%halos(2) - call incref(cmc_sparsity%column_halo) - end if - - call allocate(cmc_m, cmc_sparsity, name="ExtendedPressurePoissonMatrix") - call insert(state, cmc_m, cmc_m%name) - call deallocate(cmc_m) - call deallocate(cmc_sparsity) - call deallocate(grad_sparsity) - - cmc_m_ptr => extract_csr_matrix(state, "ExtendedPressurePoissonMatrix") - if (present(get_cmc)) then - get_cmc = mesh_moved - end if - - end function get_extended_pressure_poisson_matrix - - function get_extended_schur_auxillary_sparsity(state, ct_m, extended_mesh) result (aux_sparsity_ptr) - ! returns the sparsity of the schur auxillary matrix from state (or creates a new one if none present) - ! with extra rows and columns associated with prognostic fs nodes - ! here it is assumed that the matrix has the same sparsity as the pressure poisson matrix has, obtained - ! by sparsity multiplication of C^T * C - type(state_type), intent(inout):: state - type(block_csr_matrix), intent(in):: ct_m - type(mesh_type), intent(in):: extended_mesh - type(csr_sparsity), pointer:: aux_sparsity_ptr - - type(csr_sparsity):: grad_sparsity, aux_sparsity - - if (.not. has_csr_sparsity(state, "ExtendedSchurAuxillarySparsity")) then - grad_sparsity=transpose(ct_m%sparsity) - aux_sparsity = matmul(ct_m%sparsity, grad_sparsity) - aux_sparsity%name="ExtendedSchurAuxillarySparsity" - - if (associated(extended_mesh%halos)) then - allocate(aux_sparsity%row_halo) - aux_sparsity%row_halo = extended_mesh%halos(2) - call incref(aux_sparsity%row_halo) - allocate(aux_sparsity%column_halo) - aux_sparsity%column_halo = extended_mesh%halos(2) - call incref(aux_sparsity%column_halo) + ! if we don't have a non-linear loop, we do the same as + ! in the 2nd nonlinear iteration if we would have non-linear iterations, i.e.: + ! OldCoordinate gets set to IteratedCoordinate at the end of last timestep + ! and we compute a new IteratedCoordinate and therefore Coordinate and GridVelocity + its=2 end if - call insert(state, aux_sparsity, aux_sparsity%name) - call deallocate(aux_sparsity) - call deallocate(grad_sparsity) - end if - - aux_sparsity_ptr => extract_csr_sparsity(state, "ExtendedSchurAuxillarySparsity") + complete = .false. - end function get_extended_schur_auxillary_sparsity + do i=1, size(states) + velocity => extract_vector_field(states(i), "Velocity") - subroutine add_implicit_viscous_free_surface_integrals(state, ct_m, u, & - p_mesh, fs) - ! This routine adds in the boundary conditions for the viscous free surface - ! (that is the free_surface bc with the no_normal_stress option) - ! ct_m has been extended with some extra rows (corresponding to free surface - ! nodes) that are used to enforce the kinematic bc, the transpose of that - ! will produce the \rho_0 g\eta term in the no_normal_stress boundary condition: - ! n\cdot\tau\cdot n + p - \rho_0 g\eta = 0 - ! if pressure is also extended to contain \rho g\eta in the extra nodes. - - type(state_type), intent(inout):: state - type(block_csr_matrix), intent(inout):: ct_m - type(vector_field), intent(in):: u - type(mesh_type), intent(in):: p_mesh ! the extended pressure mesh - type(scalar_field), intent(inout):: fs - - type(vector_field), pointer:: x - type(mesh_type), pointer:: fs_mesh, embedded_fs_mesh - type(integer_hash_table):: sele_to_fs_ele - character(len=FIELD_NAME_LEN):: bc_type - character(len=OPTION_PATH_LEN):: bc_option_path - logical :: radial_fs - integer, dimension(:), pointer:: surface_element_list - integer:: i, j - - assert(have_option(trim(fs%option_path)//"/prognostic")) - - if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then - call initialise_implicit_prognostic_free_surface(state, fs, u) - end if - ! obtain the f.s. surface mesh that has been stored under the - ! "_implicit_free_surface" boundary condition - call get_boundary_condition(fs, "_implicit_free_surface", & - surface_mesh=fs_mesh, surface_element_list=surface_element_list) - ! create a map from face numbers to element numbers in fs_mesh - call invert_set(surface_element_list, sele_to_fs_ele) - embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - - x => extract_vector_field(state, "Coordinate") - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bc_type, option_path=bc_option_path, & - surface_element_list=surface_element_list) - if (bc_type=="free_surface") then - if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then - radial_fs = have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/radial_normals") - do j=1, size(surface_element_list) - call add_boundary_integral_sele(surface_element_list(j)) - end do - end if - end if - end do - - contains - - subroutine add_boundary_integral_sele(sele) - integer, intent(in):: sele - - real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy - real, dimension(u%dim, face_loc(fs, sele), face_loc(u, sele)) :: ht_mat_bdy - real, dimension(face_ngi(u, sele)) :: detwei_bdy - real, dimension(u%dim, face_ngi(u, sele)) :: normal_bdy, radials_bdy - integer:: dim - - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) - ct_mat_bdy = shape_shape_vector(face_shape(p_mesh, sele), face_shape(u, sele), & - detwei_bdy, normal_bdy) - if (radial_fs) then - ! use purely radial normals instead - radials_bdy = radial_inward_normal_at_quad_face(X, sele) - detwei_bdy = detwei_bdy * sign(1.0, sum(radials_bdy*normal_bdy, dim=1)) - normal_bdy = radials_bdy - end if - ht_mat_bdy = shape_shape_vector(face_shape(fs, sele), face_shape(u, sele), & - detwei_bdy, normal_bdy) - do dim=1, u%dim - ! we've integrated continuity by parts, but not yet added in the resulting - ! surface integral - for the non-viscous free surface this is left - ! out to enforce the kinematic bc - call addto(ct_m, 1, dim, face_global_nodes(p_mesh,sele), & - face_global_nodes(u,sele), ct_mat_bdy(dim,:,:)) - ! for the viscous bc however we add this bc in the extra rows at the bottom of ct_m - ! this integral will also enforce the \rho_0 g\eta term in the no_normal_stress bc: - ! n\cdot\tau\cdot n + p - (\rho_0-\rho_external) g\eta = 0 - call addto(ct_m, 1, dim, ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & - face_global_nodes(u,sele), -ht_mat_bdy(dim,:,:)) - end do + if (aliased(velocity)) cycle - end subroutine add_boundary_integral_sele + if (has_boundary_condition(velocity, "free_surface") .and. & + & have_option('/mesh_adaptivity/mesh_movement/free_surface')) then - end subroutine add_implicit_viscous_free_surface_integrals + if(complete) then + FLExit("Two velocity fields with free_surface boundary conditions are not permitted.") + end if - subroutine add_implicit_viscous_free_surface_integrals_cv(state, ct_m, u, & - p_mesh, fs) - ! This routine adds in the boundary conditions for the viscous free surface - ! (that is the free_surface bc with the no_normal_stress option) - ! ct_m has been extended with some extra rows (corresponding to free surface - ! nodes) that are used to enforce the kinematic bc, the transpose of that - ! will produce the \rho_0 g\eta term in the no_normal_stress boundary condition: - ! n\cdot\tau\cdot n + p - \rho_0 g\eta = 0 - ! if pressure is also extended to contain \rho g\eta in the extra nodes. - - type(state_type), intent(inout):: state - type(block_csr_matrix), intent(inout):: ct_m - type(vector_field), intent(in):: u - type(mesh_type), intent(in):: p_mesh ! the extended pressure mesh - type(scalar_field), intent(inout):: fs - - type(vector_field), pointer:: x - type(mesh_type), pointer:: fs_mesh, embedded_fs_mesh - type(integer_hash_table):: sele_to_fs_ele - character(len=FIELD_NAME_LEN):: bc_type - character(len=OPTION_PATH_LEN):: bc_option_path - integer, dimension(:), pointer:: surface_element_list - integer:: i, j - - ! information about cv faces - type(cv_faces_type) :: cvfaces - ! shape functions for region and surface - type(element_type) :: x_cvbdyshape - type(element_type) :: p_cvbdyshape - type(element_type) :: u_cvbdyshape - integer:: quaddegree, ele, sele - - assert(have_option(trim(fs%option_path)//"/prognostic")) - - if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then - call initialise_implicit_prognostic_free_surface(state, fs, u) - end if - ! obtain the f.s. surface mesh that has been stored under the - ! "_implicit_free_surface" boundary condition - call get_boundary_condition(fs, "_implicit_free_surface", & - surface_mesh=fs_mesh, surface_element_list=surface_element_list) - ! create a map from face numbers to element numbers in fs_mesh - call invert_set(surface_element_list, sele_to_fs_ele) - embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - - x => extract_vector_field(state, "Coordinate") - - call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) - - cvfaces=find_cv_faces(vertices=ele_vertices(p_mesh, 1), & - dimension=mesh_dim(p_mesh), & - polydegree=p_mesh%shape%degree, & - quaddegree=quaddegree) - - x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) - p_cvbdyshape=make_cvbdy_element_shape(cvfaces, p_mesh%faces%shape) - u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bc_type, option_path=bc_option_path, & - surface_element_list=surface_element_list) - if (bc_type=="free_surface") then - if(have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then - do j=1, size(surface_element_list) - sele = surface_element_list(j) - ele = face_ele(x, sele) - call add_boundary_integral_sele(sele, ele) - end do - end if - end if - end do + call get_option( trim(velocity%option_path)//'/prognostic/temporal_discretisation/relaxation', & + itheta, default=0.5) - call deallocate(x_cvbdyshape) - call deallocate(p_cvbdyshape) - call deallocate(u_cvbdyshape) - call deallocate(cvfaces) + if (its==1) then - contains + ! The first nonlinear iteration we'll keep using the OldCoordinate and IteratedCoordinate + ! and GridVelocityfrom last timestep. Only Coordinate has been set to IteratedCoordinate + ! at the end of last timestep, so we need to weight it again + call interpolate_coordinate_with_theta(states(i), itheta) - subroutine add_boundary_integral_sele(sele, ele) - integer, intent(in):: sele, ele + else - real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy - real, dimension(u%dim, face_loc(fs, sele), face_loc(u, sele)) :: ht_mat_bdy - real, dimension(face_ngi(u, sele)) :: detwei_bdy - real, dimension(x_cvbdyshape%ngi) :: detwei_bdy_cv - real, dimension(x%dim, face_ngi(x, sele)) :: normal_bdy - real, dimension(x%dim, x_cvbdyshape%ngi) :: normal_bdy_cv - real, dimension(x%dim, ele_loc(x, ele)) :: x_ele - real, dimension(x%dim, face_loc(x, sele)) :: x_ele_bdy - integer:: dim, gi, ggi, iloc, jloc, face + ewrite(1,*) "Going into move_free_surface_nodes to compute new node coordinates" - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) + if (its==2) then + ! the first nonlinear iteration we've used OldCoordinate,IteratedCoordinate,GridVelocity + ! from previous timestep. Now we recompute IteratedCoordinate and GridVelocity, based on + ! the new free surface approx. calculated in the first nonlinear iteration. OldCoordinate + ! should be set to IteratedCoordinate of last timestep + call set_vector_field_in_state(states(i), "OldCoordinate", "IteratedCoordinate") + end if - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy_cv, detwei_bdy_cv) + call move_free_surface_nodes(states(i), itheta, initialise = initialise) - ct_mat_bdy = 0.0 - surface_nodal_loop_i: do iloc = 1, face_loc(p_mesh, sele) + ! need to update ocean boundaries again if you've just moved the mesh + if (has_scalar_field(states(i), "DistanceToTop")) then + if (.not. have_option('/geometry/ocean_boundaries')) then + FLExit("ocean_boundaries required under geometry for mesh movement with a free_surface") + end if + call CalculateTopBottomDistance(states(i)) + end if + call update_wettingdrying_alpha(states(i)) - surface_face_loop: do face = 1, cvfaces%sfaces - if(cvfaces%sneiloc(iloc,face)/=0) then - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + end if - surface_nodal_loop_j: do jloc = 1, face_loc(u, sele) + complete = .true. - surface_inner_dimension_loop: do dim = 1, size(normal_bdy_cv,1) + end if + end do - ct_mat_bdy(dim, iloc, jloc) = ct_mat_bdy(dim, iloc, jloc) + & - u_cvbdyshape%n(jloc,ggi)*detwei_bdy_cv(ggi)*normal_bdy_cv(dim, ggi) + end subroutine move_mesh_free_surface - end do surface_inner_dimension_loop + subroutine interpolate_coordinate_with_theta(state, theta) + type(state_type), intent(inout) :: state + real, intent(in):: theta - end do surface_nodal_loop_j + type(vector_field), pointer:: positions, old_positions, iterated_positions - end do surface_quadrature_loop + call IncrementEventCounter(EVENT_MESH_MOVEMENT) - end if + positions => extract_vector_field(state, "Coordinate") + old_positions => extract_vector_field(state, "OldCoordinate") + iterated_positions => extract_vector_field(state, "IteratedCoordinate") + call set(positions, old_positions, iterated_positions, theta) + + end subroutine interpolate_coordinate_with_theta + + subroutine move_free_surface_nodes(state, theta, initialise) + type(state_type), intent(inout) :: state + real, intent(in):: theta + logical, intent(in), optional :: initialise + + type(vector_field), pointer:: positions, u, original_positions + type(vector_field), pointer:: gravity_normal, old_positions, grid_u + type(vector_field), pointer:: iterated_positions + type(scalar_field), pointer:: p + type(scalar_field), pointer:: topdis, bottomdis + type(vector_field), target :: local_grid_u + type(scalar_field), target:: fs_mapped_to_coordinate_space, local_fs + type(scalar_field):: local_fracdis, scaled_fs + character(len=FIELD_NAME_LEN):: bctype + real dt + integer, dimension(:), allocatable:: face_nodes + integer, dimension(:), pointer:: surface_element_list + integer i, j, k, node, sele, stat - end do surface_face_loop + ! some fields for when moving the entire mesh + type(scalar_field), pointer :: fracdis + type(scalar_field), pointer :: fs - end do surface_nodal_loop_i + logical :: l_initialise, have_prognostic_fs - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) - ht_mat_bdy = shape_shape_vector(face_shape(fs, sele), face_shape(u, sele), & - detwei_bdy, normal_bdy) + ewrite(1,*) 'Entering move_free_surface_nodes' + ! increase event counter, so position caching know the mesh has moved + call IncrementEventCounter(EVENT_MESH_MOVEMENT) - do dim=1, u%dim - ! we've integrated continuity by parts, but not yet added in the resulting - ! surface integral - for the non-viscous free surface this is left - ! out to enforce the kinematic bc - call addto(ct_m, 1, dim, face_global_nodes(p_mesh,sele), & - face_global_nodes(u,sele), ct_mat_bdy(dim,:,:)) - ! for the viscous bc however we add this bc in the extra rows at the bottom of ct_m - ! this integral will also enforce the \rho_0 g\eta term in the no_normal_stress bc: - ! n\cdot\tau\cdot n + p - (\rho_0-\rho_external) g\eta = 0 - call addto(ct_m, 1, dim, ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & - face_global_nodes(u,sele), -ht_mat_bdy(dim,:,:)) - end do + l_initialise = present_and_true(initialise) - end subroutine add_boundary_integral_sele - - end subroutine add_implicit_viscous_free_surface_integrals_cv - - subroutine add_explicit_viscous_free_surface_integrals(state, mom_rhs, ct_m, & - reassemble_ct_m, u, p_mesh, fs) - type(state_type), intent(inout):: state - type(vector_field), intent(inout):: mom_rhs - type(block_csr_matrix), intent(inout):: ct_m - logical, intent(in):: reassemble_ct_m - type(vector_field), intent(in):: u - type(mesh_type), intent(in):: p_mesh - type(scalar_field), intent(in):: fs - - type(scalar_field), pointer:: it_fs, old_fs, density, external_density - type(vector_field), pointer:: x - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - real:: itheta, rho0, g - integer, dimension(:), pointer:: surface_element_list - integer:: i, j, dens_stat, stat, external_density_stat - logical:: variable_density, have_density, move_mesh, have_external_density - - assert(have_option(trim(fs%option_path)//"/prognostic")) - - it_fs => extract_scalar_field(state, "IteratedFreeSurface") - old_fs => extract_scalar_field(state, "OldFreeSurface") - - move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") - x => extract_vector_field(state, "Coordinate") - ! reference density - call get_fs_reference_density_from_options(rho0, state%option_path) - density => extract_scalar_field(state, "Density", stat=dens_stat) - have_density = (dens_stat==0) - call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) - if (stat/=0) then - FLExit("For a free surface you need gravity") - end if - - call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/relaxation", & - itheta) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & - have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit")) then - - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - - variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & - .and. (.not.move_mesh) - if (variable_density.and.(.not.have_density)) then - FLExit("Variable density free surface requires a Density field.") - end if - - do j=1, size(surface_element_list) - call add_boundary_integral_sele(j, surface_element_list(j)) - end do - end if - end if - end do - - contains - - subroutine add_boundary_integral_sele(surface_mesh_ele, sele) - integer, intent(in):: surface_mesh_ele, sele - - real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy - real, dimension(face_ngi(u, sele)) :: detwei_bdy - real, dimension(u%dim, face_ngi(u, sele)) :: normal_bdy - real, dimension(face_ngi(fs, sele)):: delta_rho_g_quad - integer, dimension(face_loc(u, sele)) :: u_nodes_bdy - integer, dimension(face_loc(p_mesh, sele)) :: p_nodes_bdy - integer:: dim - - u_nodes_bdy = face_global_nodes(u, sele) - - if(variable_density .and. have_external_density) then - delta_rho_g_quad = g*(face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele)) - else if (variable_density) then - delta_rho_g_quad = g*face_val_at_quad(density, sele) - else if (have_external_density) then - delta_rho_g_quad = g*(rho0-node_val(external_density,1)) - else - delta_rho_g_quad = g*rho0 - end if + ! gravity acceleration + call get_option('/timestepping/timestep', dt) - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) + positions => extract_vector_field(state, "Coordinate") + original_positions => extract_vector_field(state, "OriginalCoordinate") + iterated_positions => extract_vector_field(state, "IteratedCoordinate") + old_positions => extract_vector_field(state, "OldCoordinate") - call addto(mom_rhs, u_nodes_bdy, shape_vector_rhs(face_shape(u, sele), normal_bdy, & - -detwei_bdy*delta_rho_g_quad* & - (itheta*face_val_at_quad(it_fs, sele) + & - (1.0-itheta)*face_val_at_quad(old_fs, sele)))) + gravity_normal => extract_vector_field(state, "GravityDirection") + ! it's alright for gravity to be on a DG version of the CoordinateMesh: + assert( face_loc(gravity_normal,1)==face_loc(positions,1) ) - if(reassemble_ct_m) then - p_nodes_bdy = face_global_nodes(p_mesh, sele) + u => extract_vector_field(state, "Velocity") + p => extract_scalar_field(state, "Pressure") - ct_mat_bdy = shape_shape_vector(face_shape(p_mesh, sele), face_shape(u, sele), & - detwei_bdy, normal_bdy) + fs => extract_scalar_field(state, "FreeSurface", stat=stat) + have_prognostic_fs=.false. + if (stat==0) then + have_prognostic_fs = have_option(trim(fs%option_path)//"/prognostic") + else + call allocate(local_fs, p%mesh, "LocalFreeSurface") + fs => local_fs + end if + if (.not. have_prognostic_fs) then + ! make sure the fs is up-to-date with the latest pressure values + call calculate_diagnostic_free_surface(state, fs) + end if + + if (.not. fs%mesh==positions%mesh) then + call allocate(fs_mapped_to_coordinate_space, positions%mesh) + call remap_field(fs, fs_mapped_to_coordinate_space, stat=stat) + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + ewrite(-1,*) "Just remapped from a discontinuous to a continuous field when using free_surface mesh movement." + ewrite(-1,*) "This suggests the FreeSurface is discontinuous, which isn't supported." + FLExit("Discontinuous pressure not permitted.") + else if(stat/=0 .and. stat/=REMAP_ERR_UNPERIODIC_PERIODIC .and. stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then + FLAbort("Something went wrong mapping FreeSurface to the CoordinateMesh") + end if + ! we've allowed it to remap from periodic to unperiodic and from higher order to lower order - do dim=1, u%dim - ! we've integrated continuity by parts, but not yet added in the resulting - ! surface integral - for the non-viscous free surface this is left - ! out to enforce the kinematic bc - call addto(ct_m, 1, dim, p_nodes_bdy, u_nodes_bdy, ct_mat_bdy(dim,:,:)) - end do + if (associated(fs, local_fs)) then + call deallocate(local_fs) + end if + fs => fs_mapped_to_coordinate_space end if - end subroutine add_boundary_integral_sele - - end subroutine add_explicit_viscous_free_surface_integrals - - subroutine add_explicit_viscous_free_surface_integrals_cv(state, ct_m, & - reassemble_ct_m, u, p_mesh, fs, mom_rhs) - type(state_type), intent(inout):: state - type(block_csr_matrix), intent(inout):: ct_m - logical, intent(in):: reassemble_ct_m - type(vector_field), intent(in):: u - type(mesh_type), intent(in):: p_mesh - type(scalar_field), intent(inout):: fs - type(vector_field), intent(inout), optional:: mom_rhs - - type(scalar_field), pointer:: it_fs, old_fs, density, external_density - type(vector_field), pointer:: x - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: fs_option_path - real:: itheta, rho0, g - integer, dimension(:), pointer:: surface_element_list - integer:: i, j, dens_stat, stat, external_density_stat - logical:: variable_density, have_density, move_mesh, have_external_density - - ! information about cv faces - type(cv_faces_type) :: cvfaces - ! shape functions for region and surface - type(element_type) :: x_cvbdyshape - type(element_type) :: p_cvbdyshape - type(element_type) :: u_cvbdyshape - integer:: quaddegree, ele, sele - - if (.not.present(mom_rhs) .and. .not. reassemble_ct_m) return - - assert(have_option(trim(fs%option_path)//"/prognostic")) - - it_fs => extract_scalar_field(state, "IteratedFreeSurface") - old_fs => extract_scalar_field(state, "OldFreeSurface") - - move_mesh = have_option("/mesh_adaptivity/mesh_movement/free_surface") - x => extract_vector_field(state, "Coordinate") - ! reference density - call get_fs_reference_density_from_options(rho0, state%option_path) - density => extract_scalar_field(state, "Density", stat=dens_stat) - have_density = (dens_stat==0) - call get_option('/physical_parameters/gravity/magnitude', g, stat=stat) - if (stat/=0) then - FLExit("For a free surface you need gravity") - end if - - call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/relaxation", & - itheta) - - call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) - - cvfaces=find_cv_faces(vertices=ele_vertices(p_mesh, 1), & - dimension=mesh_dim(p_mesh), & - polydegree=p_mesh%shape%degree, & - quaddegree=quaddegree) - - x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) - p_cvbdyshape=make_cvbdy_element_shape(cvfaces, p_mesh%faces%shape) - u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, option_path=fs_option_path, & - surface_element_list=surface_element_list) - if (bctype=="free_surface") then - if(have_option(trim(fs_option_path)//"/type[0]/no_normal_stress") .and. & - have_option(trim(fs_option_path)//"/type[0]/no_normal_stress/explicit")) then - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - - variable_density = have_option(trim(fs_option_path)//"/type[0]/variable_density") & - .and. (.not.move_mesh) - if (variable_density.and.(.not.have_density)) then - FLExit("Variable density free surface requires a Density field.") - end if - - do j=1, size(surface_element_list) - sele = surface_element_list(j) - ele = face_ele(x, sele) - call add_boundary_integral_sele(j, sele, ele) - end do - end if - end if - end do - - call deallocate(x_cvbdyshape) - call deallocate(p_cvbdyshape) - call deallocate(u_cvbdyshape) - call deallocate(cvfaces) - - contains - - subroutine add_boundary_integral_sele(surface_mesh_ele, sele, ele) - integer, intent(in):: surface_mesh_ele, sele, ele - - real, dimension(u%dim, face_loc(p_mesh, sele), face_loc(u, sele)) :: ct_mat_bdy - real, dimension(face_ngi(u, sele)) :: detwei_bdy - real, dimension(x_cvbdyshape%ngi) :: detwei_bdy_cv - real, dimension(x%dim, face_ngi(x, sele)) :: normal_bdy - real, dimension(x%dim, x_cvbdyshape%ngi) :: normal_bdy_cv - real, dimension(face_ngi(fs, sele)):: delta_rho_g_quad - integer, dimension(face_loc(u, sele)) :: u_nodes_bdy - integer, dimension(face_loc(p_mesh, sele)) :: p_nodes_bdy - real, dimension(x%dim, ele_loc(x, ele)) :: x_ele - real, dimension(x%dim, face_loc(x, sele)) :: x_ele_bdy - integer:: dim, gi, ggi, iloc, jloc, face - - u_nodes_bdy = face_global_nodes(u, sele) - - if (present(mom_rhs)) then - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) - - if(variable_density .and. have_external_density) then - delta_rho_g_quad = g*(face_val_at_quad(density, sele)-ele_val_at_quad(external_density, surface_mesh_ele)) - else if (variable_density) then - delta_rho_g_quad = g*face_val_at_quad(density, sele) - else if (have_external_density) then - delta_rho_g_quad = g*(rho0-node_val(external_density, 1)) - else - delta_rho_g_quad = g*rho0 - end if - - call addto(mom_rhs, u_nodes_bdy, shape_vector_rhs(face_shape(u, sele), normal_bdy, & - -detwei_bdy*delta_rho_g_quad* & - (itheta*face_val_at_quad(it_fs, sele) + & - (1.0-itheta)*face_val_at_quad(old_fs, sele)))) + if(.not.l_initialise) then + ! if we're initialising then the grid velocity stays as zero + grid_u => extract_vector_field(state, "GridVelocity") + + if(.not. grid_u%mesh==positions%mesh) then + ! allocate this on the positions mesh to calculate the values + call allocate(local_grid_u, grid_u%dim, positions%mesh, "LocalGridVelocity") + call zero(local_grid_u) + grid_u => local_grid_u + end if end if - if(reassemble_ct_m) then + if (have_option("/mesh_adaptivity/mesh_movement/free_surface/move_whole_mesh")) then - p_nodes_bdy = face_global_nodes(p_mesh, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) + if (.not. have_option("/geometry/ocean_boundaries")) then + ! ensure we have ocean boundaries so the fs has been extrapolated downwards + ewrite(-1,*) "With /mesh_adaptivity/mesh_movement/free_surface/move_whole_mesh" // & + "you need /geometry/ocean_boundaries" + FLExit("Missing option") + end if - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy_cv, detwei_bdy_cv) - ct_mat_bdy = 0.0 - surface_nodal_loop_i: do iloc = 1, face_loc(p_mesh, sele) + topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) + bottomdis => extract_scalar_field(state, "DistanceToBottom", stat=stat) + + ! allocate a scaled free surface, that is equal to fs at the top + ! and linearly decreases to 0 at the bottom + call allocate(scaled_fs, fs%mesh, "ScaledFreeSurface") + ! start by setting it equal to fs everywhere + call set(scaled_fs, fs) + + ! Now we need to scale it by its fractional distance from the bottom + ! Since the fractional distance is constant in time, we compute it once and save it. + if (.not. has_scalar_field(state, "FractionalDistance")) then + call allocate(local_fracdis, fs%mesh, "FractionalDistance") + call set(local_fracdis, topdis) + call addto(local_fracdis, bottomdis) + call invert(local_fracdis) + call scale(local_fracdis, bottomdis) + call insert(state, local_fracdis, name="FractionalDistance") + call deallocate(local_fracdis) + end if + fracdis => extract_scalar_field(state, "FractionalDistance") - surface_face_loop: do face = 1, cvfaces%sfaces - if(cvfaces%sneiloc(iloc,face)/=0) then + call scale(scaled_fs, fracdis) - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + do node=1, node_count(positions) + call set(iterated_positions, node, & + node_val(original_positions, node)- & + node_val(scaled_fs, node)*node_val(gravity_normal, node)) - ggi = (face-1)*cvfaces%shape%ngi + gi + if(.not.l_initialise) call set(grid_u, node, & + (node_val(iterated_positions, node)-node_val(old_positions,node))/dt) + end do - surface_nodal_loop_j: do jloc = 1, face_loc(u, sele) + call deallocate(scaled_fs) - surface_inner_dimension_loop: do dim = 1, size(normal_bdy_cv,1) + else - ct_mat_bdy(dim, iloc, jloc) = ct_mat_bdy(dim, iloc, jloc) + & - u_cvbdyshape%n(jloc,ggi)*detwei_bdy_cv(ggi)*normal_bdy_cv(dim, ggi) + ! we assume no p-refinement on the coordinate mesh + allocate( face_nodes(1:face_loc(positions,1)) ) - end do surface_inner_dimension_loop + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list) + if (bctype=="free_surface") then - end do surface_nodal_loop_j + face_loop: do j=1, size(surface_element_list) - end do surface_quadrature_loop + sele=surface_element_list(j) + face_nodes=face_global_nodes(positions, sele) - end if + node_loop: do k=1, size(face_nodes) + node=face_nodes(k) + ! compute new surface node position: + call set(iterated_positions, node, & + node_val(original_positions, node)- & + node_val(fs, node)*node_val(gravity_normal, node)) - end do surface_face_loop + ! compute new surface node grid velocity: + if(.not.l_initialise) call set(grid_u, node, & + (node_val(iterated_positions, node)-node_val(old_positions,node))/dt) + end do node_loop - end do surface_nodal_loop_i + end do face_loop - do dim=1, u%dim - ! we've integrated continuity by parts, but not yet added in the resulting - ! surface integral - for the non-viscous free surface this is left - ! out to enforce the kinematic bc - call addto(ct_m, 1, dim, face_global_nodes(p_mesh,sele), & - face_global_nodes(u,sele), ct_mat_bdy(dim,:,:)) - end do - end if + end if + end do - end subroutine add_boundary_integral_sele - - end subroutine add_explicit_viscous_free_surface_integrals_cv - - subroutine add_implicit_viscous_free_surface_scaled_mass_integrals(state, mass, u, p_mesh, fs, dt) - ! This routine adds in the boundary conditions for the viscous free surface - ! (that is the free_surface bc with the no_normal_stress option) - ! to the "scaled mass matrix" (pressure mass scaled with inverse of viscosity used as stokes preconditioner) - ! mass has been extended with some extra rows and columns (corresponding to free surface - ! nodes) that are used to enforce the kinematic bc. - ! Here we fill in those terms with the scaled mass on the free surface. - - type(state_type), intent(inout):: state - type(csr_matrix), intent(inout):: mass - type(vector_field), intent(in):: u - type(scalar_field), intent(in):: p_mesh - type(scalar_field), intent(inout):: fs - real, intent(in) :: dt - - type(tensor_field), pointer :: viscosity - type(vector_field), pointer:: x - type(scalar_field) :: viscosity_component - type(mesh_type), pointer:: fs_mesh, embedded_fs_mesh - type(integer_hash_table):: sele_to_fs_ele - character(len=FIELD_NAME_LEN):: bc_type - character(len=OPTION_PATH_LEN):: bc_option_path - integer, dimension(:), pointer:: surface_element_list, fs_surface_element_list - integer:: i, j - - assert(have_option(trim(fs%option_path)//"/prognostic")) - - if (.not. has_boundary_condition_name(fs, "_implicit_free_surface")) then - call initialise_implicit_prognostic_free_surface(state, fs, u) - end if - ! obtain the f.s. surface mesh that has been stored under the - ! "_implicit_free_surface" boundary condition - call get_boundary_condition(fs, "_implicit_free_surface", & - surface_mesh=fs_mesh, surface_element_list=fs_surface_element_list) - ! create a map from face numbers to element numbers in fs_mesh - call invert_set(fs_surface_element_list, sele_to_fs_ele) - embedded_fs_mesh => extract_mesh(state, "_embedded_free_surface_mesh") - - x => extract_vector_field(state, "Coordinate") - - ! Extract viscosity tensor from state: - viscosity => extract_tensor_field(state,'Viscosity') - - ! Extract first component of viscosity tensor from full tensor: - viscosity_component = extract_scalar_field(viscosity,1,1) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bc_type, & - option_path=bc_option_path, & - surface_element_list=surface_element_list) - if (bc_type=="free_surface") then - if (have_option(trim(bc_option_path)//"/type[0]/no_normal_stress") .and. & - (.not.have_option(trim(bc_option_path)//"/type[0]/no_normal_stress/explicit"))) then - do j=1, size(surface_element_list) - call add_boundary_integral_sele(surface_element_list(j)) - end do - end if end if - end do - contains - subroutine add_boundary_integral_sele(sele) - integer, intent(in):: sele - - real, dimension(face_loc(p_mesh, sele), face_loc(p_mesh, sele)) :: mat_bdy - real, dimension(face_ngi(p_mesh, sele)) :: detwei_bdy - - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy) - mat_bdy = shape_shape(face_shape(fs, sele), face_shape(fs, sele), & - detwei_bdy/(face_val_at_quad(viscosity_component, sele)*dt)) - call addto(mass, ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & - ele_nodes(embedded_fs_mesh, fetch(sele_to_fs_ele, sele)), & - mat_bdy) - - end subroutine add_boundary_integral_sele + if (l_initialise) then + call set(positions, iterated_positions) + call set(old_positions, iterated_positions) + else + call set(positions, iterated_positions, old_positions, theta) + if(associated(grid_u, local_grid_u)) then + grid_u => extract_vector_field(state, "GridVelocity") + call remap_field(local_grid_u, grid_u) + call deallocate(local_grid_u) + end if + ewrite_minmax(grid_u) + end if - end subroutine add_implicit_viscous_free_surface_scaled_mass_integrals + if (associated(fs, fs_mapped_to_coordinate_space)) then + call deallocate(fs_mapped_to_coordinate_space) + else if (associated(fs, local_fs)) then + call deallocate(local_fs) + end if + end subroutine move_free_surface_nodes - subroutine move_mesh_free_surface(states, initialise, nonlinear_iteration) - type(state_type), dimension(:), intent(inout) :: states - ! if present_and_true: zero gridvelocity and compute OldCoordinate=Coordinate=IteratedCoordinate - logical, intent(in), optional :: initialise - ! only supply if total number nonlinear_iterations>1, in which case we do something else for the first nonlinear_iteration - integer, intent(in), optional:: nonlinear_iteration + function vertical_prolongator_from_free_surface(state, mesh) result (vertical_prolongator) + !! Creates a prolongation operator from the free surface mesh to + !! the full mesh which when provided to petsc_solve is used + !! to implement vertical lumping if the "mg" preconditioner is selected. + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh + type(petsc_csr_matrix):: vertical_prolongator - type(vector_field), pointer :: velocity - real :: itheta - integer :: i, its + type(csr_matrix):: csr_vertical_prolongator + type(scalar_field), pointer:: topdis + type(vector_field), pointer:: positions, vertical_normal + type(integer_set):: owned_surface_nodes + integer, dimension(:), pointer:: surface_element_list, surface_node_list + integer:: stat, i, face, ncols - logical :: complete + ewrite(1, *) "Constructing vertical_prolongator_from_free_surface to be used in mg" + topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) + if (stat/=0) then + FLExit("For vertical lumping you need to specify the ocean_boundaries under /geometry") + end if - if (present(nonlinear_iteration)) then - ! we do something different in the first nonlinear iteration, see below - its=nonlinear_iteration - else - ! if we don't have a non-linear loop, we do the same as - ! in the 2nd nonlinear iteration if we would have non-linear iterations, i.e.: - ! OldCoordinate gets set to IteratedCoordinate at the end of last timestep - ! and we compute a new IteratedCoordinate and therefore Coordinate and GridVelocity - its=2 - end if + positions => extract_vector_field(state, "Coordinate") + vertical_normal => extract_vector_field(state, "GravityDirection") - complete = .false. + call get_boundary_condition(topdis, 1, & + surface_element_list=surface_element_list, & + surface_node_list=surface_node_list) - do i=1, size(states) - velocity => extract_vector_field(states(i), "Velocity") - if (aliased(velocity)) cycle + csr_vertical_prolongator=VerticalProlongationOperator( & + mesh, positions, vertical_normal, surface_element_list) +#ifdef DDEBUG + ! note that in surface_positions the non-owned free surface nodes may be inbetween + ! the reduce_columns option should have removed those however + ! with debugging perform test to check if this is the case: + if (IsParallel()) then + assert( associated(mesh%halos) ) + ! count n/o owned surface nodes + call allocate(owned_surface_nodes) + do i=1, size(surface_element_list) + face=surface_element_list(i) + call insert(owned_surface_nodes, face_global_nodes(mesh, face)) + end do + ! this should be size(csr_vertical_prolongator,2) but intel with debugging + ! seems to choke on it: + ncols = csr_vertical_prolongator%sparsity%columns + ewrite(2,*) "Number of owned surface nodes:", key_count(owned_surface_nodes) + ewrite(2,*) "Number of columns in vertical prolongator:", ncols + if (ncols>key_count(owned_surface_nodes)) then + ewrite(-1,*) "Vertical prolongator seems to be using more surface nodes than the number" + ewrite(-1,*) "of surface nodes within completely owned surface elements. This indicates" + ewrite(-1,*) "the parallel decomposition is not done along columns. You shouldn't be using" + ewrite(-1,*) "mg with vertical_lumping in that case." + FLExit("Vertical lumping requires 2d decomposition along columns") + end if + call deallocate(owned_surface_nodes) + end if +#endif - if (has_boundary_condition(velocity, "free_surface") .and. & - & have_option('/mesh_adaptivity/mesh_movement/free_surface')) then + vertical_prolongator=csr2petsc_csr(csr_vertical_prolongator) + call deallocate(csr_vertical_prolongator) - if(complete) then - FLExit("Two velocity fields with free_surface boundary conditions are not permitted.") - end if + end function vertical_prolongator_from_free_surface - call get_option( trim(velocity%option_path)//'/prognostic/temporal_discretisation/relaxation', & - itheta, default=0.5) + function free_surface_nodes(state, mesh) + !! Returns the list of the nodes on the free surface of the given mesh. + !! Returns a pointer to an allocated array to be deallocated by the caller. + integer, dimension(:), pointer:: free_surface_nodes + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh - if (its==1) then + type(scalar_field), pointer:: topdis + type(mesh_type) surface_mesh + integer, dimension(:), pointer:: surface_element_list, surface_node_list + integer stat - ! The first nonlinear iteration we'll keep using the OldCoordinate and IteratedCoordinate - ! and GridVelocityfrom last timestep. Only Coordinate has been set to IteratedCoordinate - ! at the end of last timestep, so we need to weight it again - call interpolate_coordinate_with_theta(states(i), itheta) + ewrite(1, *) "Extracting list of nodes on the free surface" + topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) + if (stat/=0) then + FLExit("Need to specify the ocean_boundaries under /geometry") + end if - else + if (mesh==topdis%mesh) then + ! we can just copy this info, from the coordinate mesh + call get_boundary_condition(topdis, 1, & + surface_node_list=surface_node_list) + allocate( free_surface_nodes(1: size(surface_node_list)) ) + free_surface_nodes=surface_node_list + else + ! by creating a temporary surface mesh we get exactly this information + call get_boundary_condition(topdis, 1, & + surface_element_list=surface_element_list) + call create_surface_mesh(surface_mesh, surface_node_list, & + mesh, surface_element_list, name=trim(mesh%name)//'FreeSurface') + free_surface_nodes => surface_node_list + call deallocate(surface_mesh) + end if - ewrite(1,*) "Going into move_free_surface_nodes to compute new node coordinates" + end function free_surface_nodes - if (its==2) then - ! the first nonlinear iteration we've used OldCoordinate,IteratedCoordinate,GridVelocity - ! from previous timestep. Now we recompute IteratedCoordinate and GridVelocity, based on - ! the new free surface approx. calculated in the first nonlinear iteration. OldCoordinate - ! should be set to IteratedCoordinate of last timestep - call set_vector_field_in_state(states(i), "OldCoordinate", "IteratedCoordinate") - end if + subroutine calculate_diagnostic_free_surface(state, free_surface) + !!< calculates a 3D field (constant over the vertical) of the free surface elevation + !!< This can be added as a diagnostic field in the flml. + type(state_type), intent(inout):: state + type(scalar_field), target, intent(inout):: free_surface - call move_free_surface_nodes(states(i), itheta, initialise = initialise) + integer, dimension(:), pointer:: surface_element_list + type(vector_field), pointer:: x, u, vertical_normal + type(scalar_field), pointer:: p, topdis, external_density + type(scalar_field), pointer :: original_bottomdist_remap + character(len=OPTION_PATH_LEN):: fs_option_path + type(scalar_field) :: p_min + type(scalar_field), target :: p_capped + character(len=FIELD_NAME_LEN):: bctype + real:: g, rho0, delta_rho, d0, p_atm + integer:: i, j, sele, stat, external_density_stat + logical :: have_wd, have_external_density - ! need to update ocean boundaries again if you've just moved the mesh - if (has_scalar_field(states(i), "DistanceToTop")) then - if (.not. have_option('/geometry/ocean_boundaries')) then - FLExit("ocean_boundaries required under geometry for mesh movement with a free_surface") - end if - call CalculateTopBottomDistance(states(i)) - end if - call update_wettingdrying_alpha(states(i)) + ! the prognostic free surface is calculated elsewhere (this is used + ! in combination with the viscous free surface) + if (have_option(trim(free_surface%option_path)//'/prognostic')) return + x => extract_vector_field(state, "Coordinate") + p => extract_scalar_field(state, "Pressure") + assert(free_surface%mesh==p%mesh) + call get_option('/physical_parameters/gravity/magnitude', g) + call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & + p_atm, default=0.0) - end if + have_wd=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying") - complete = .true. + u => extract_vector_field(state, "Velocity") + call get_fs_reference_density_from_options(rho0, state%option_path) + if (have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater')) then + ! For the shallow water equations we only have a 2D, horizontal mesh + ! and f.s. is simply p/g everywhere: + call set(free_surface, p) + call scale(free_surface, 1./g) + return end if - end do - - end subroutine move_mesh_free_surface - - subroutine interpolate_coordinate_with_theta(state, theta) - type(state_type), intent(inout) :: state - real, intent(in):: theta - - type(vector_field), pointer:: positions, old_positions, iterated_positions - - call IncrementEventCounter(EVENT_MESH_MOVEMENT) - - positions => extract_vector_field(state, "Coordinate") - old_positions => extract_vector_field(state, "OldCoordinate") - iterated_positions => extract_vector_field(state, "IteratedCoordinate") - call set(positions, old_positions, iterated_positions, theta) - - end subroutine interpolate_coordinate_with_theta - - subroutine move_free_surface_nodes(state, theta, initialise) - type(state_type), intent(inout) :: state - real, intent(in):: theta - logical, intent(in), optional :: initialise - - type(vector_field), pointer:: positions, u, original_positions - type(vector_field), pointer:: gravity_normal, old_positions, grid_u - type(vector_field), pointer:: iterated_positions - type(scalar_field), pointer:: p - type(scalar_field), pointer:: topdis, bottomdis - type(vector_field), target :: local_grid_u - type(scalar_field), target:: fs_mapped_to_coordinate_space, local_fs - type(scalar_field):: local_fracdis, scaled_fs - character(len=FIELD_NAME_LEN):: bctype - real dt - integer, dimension(:), allocatable:: face_nodes - integer, dimension(:), pointer:: surface_element_list - integer i, j, k, node, sele, stat - - ! some fields for when moving the entire mesh - type(scalar_field), pointer :: fracdis - type(scalar_field), pointer :: fs - - logical :: l_initialise, have_prognostic_fs - - ewrite(1,*) 'Entering move_free_surface_nodes' - - ! increase event counter, so position caching know the mesh has moved - call IncrementEventCounter(EVENT_MESH_MOVEMENT) - - l_initialise = present_and_true(initialise) - - ! gravity acceleration - call get_option('/timestepping/timestep', dt) - - positions => extract_vector_field(state, "Coordinate") - original_positions => extract_vector_field(state, "OriginalCoordinate") - iterated_positions => extract_vector_field(state, "IteratedCoordinate") - old_positions => extract_vector_field(state, "OldCoordinate") - - gravity_normal => extract_vector_field(state, "GravityDirection") - ! it's alright for gravity to be on a DG version of the CoordinateMesh: - assert( face_loc(gravity_normal,1)==face_loc(positions,1) ) - - u => extract_vector_field(state, "Velocity") - p => extract_scalar_field(state, "Pressure") - - fs => extract_scalar_field(state, "FreeSurface", stat=stat) - have_prognostic_fs=.false. - if (stat==0) then - have_prognostic_fs = have_option(trim(fs%option_path)//"/prognostic") - else - call allocate(local_fs, p%mesh, "LocalFreeSurface") - fs => local_fs - end if - if (.not. have_prognostic_fs) then - ! make sure the fs is up-to-date with the latest pressure values - call calculate_diagnostic_free_surface(state, fs) - end if - - if (.not. fs%mesh==positions%mesh) then - call allocate(fs_mapped_to_coordinate_space, positions%mesh) - call remap_field(fs, fs_mapped_to_coordinate_space, stat=stat) - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - ewrite(-1,*) "Just remapped from a discontinuous to a continuous field when using free_surface mesh movement." - ewrite(-1,*) "This suggests the FreeSurface is discontinuous, which isn't supported." - FLExit("Discontinuous pressure not permitted.") - else if(stat/=0 .and. stat/=REMAP_ERR_UNPERIODIC_PERIODIC .and. stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then - FLAbort("Something went wrong mapping FreeSurface to the CoordinateMesh") - end if - ! we've allowed it to remap from periodic to unperiodic and from higher order to lower order - if (associated(fs, local_fs)) then - call deallocate(local_fs) - end if - fs => fs_mapped_to_coordinate_space - end if - - if(.not.l_initialise) then - ! if we're initialising then the grid velocity stays as zero - grid_u => extract_vector_field(state, "GridVelocity") - - if(.not. grid_u%mesh==positions%mesh) then - ! allocate this on the positions mesh to calculate the values - call allocate(local_grid_u, grid_u%dim, positions%mesh, "LocalGridVelocity") - call zero(local_grid_u) - grid_u => local_grid_u - end if - end if + ! + ! first we compute the right free surface values at the free surface + ! nodes only + ! - if (have_option("/mesh_adaptivity/mesh_movement/free_surface/move_whole_mesh")) then + ! Do the wetting and drying corrections: + ! In dry regions, the free surface is not coupled to the pressure but is fixed to -OriginalCoordinate+d0. + ! Hence, we create temporary pressure that is capped to d0-bottom_depth on the surface before extruding it downwards. + if (have_wd) then + call allocate(p_min, p%mesh, "MinimumSurfacePressure") + call allocate(p_capped, p%mesh, "CappedPressure") + call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) + original_bottomdist_remap=>extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") - if (.not. have_option("/geometry/ocean_boundaries")) then - ! ensure we have ocean boundaries so the fs has been extrapolated downwards - ewrite(-1,*) "With /mesh_adaptivity/mesh_movement/free_surface/move_whole_mesh" // & - "you need /geometry/ocean_boundaries" - FLExit("Missing option") - end if + ! We are looking for p_capped = min(p, g*rho0*(d0-bottom_depth)) on the surface + call set(p_min, original_bottomdist_remap) + call addto(p_min, -d0) + call scale(p_min, -g*rho0) + call set(p_capped, p) + call bound(p_capped, lower_bound=p_min) + p=>p_capped - topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) - bottomdis => extract_scalar_field(state, "DistanceToBottom", stat=stat) - - ! allocate a scaled free surface, that is equal to fs at the top - ! and linearly decreases to 0 at the bottom - call allocate(scaled_fs, fs%mesh, "ScaledFreeSurface") - ! start by setting it equal to fs everywhere - call set(scaled_fs, fs) - - ! Now we need to scale it by its fractional distance from the bottom - ! Since the fractional distance is constant in time, we compute it once and save it. - if (.not. has_scalar_field(state, "FractionalDistance")) then - call allocate(local_fracdis, fs%mesh, "FractionalDistance") - call set(local_fracdis, topdis) - call addto(local_fracdis, bottomdis) - call invert(local_fracdis) - call scale(local_fracdis, bottomdis) - call insert(state, local_fracdis, name="FractionalDistance") - call deallocate(local_fracdis) + call deallocate(p_min) end if - fracdis => extract_scalar_field(state, "FractionalDistance") - call scale(scaled_fs, fracdis) + ! make sure other nodes are zeroed + call zero(free_surface) + + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, & + option_path=fs_option_path) + if (bctype=="free_surface") then - do node=1, node_count(positions) - call set(iterated_positions, node, & - node_val(original_positions, node)- & - node_val(scaled_fs, node)*node_val(gravity_normal, node)) + if (have_option(trim(fs_option_path)//"/type[0]/variable_density")) then + ! options checked below with an flexit + FLAbort("Cannot use a diagnostic free surface field with a variable density free surface bc") + end if + external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) + have_external_density = external_density_stat==0 - if(.not.l_initialise) call set(grid_u, node, & - (node_val(iterated_positions, node)-node_val(old_positions,node))/dt) - end do + if (size(surface_element_list)==0) cycle - call deallocate(scaled_fs) + if (have_external_density) then + delta_rho=rho0-node_val(external_density, 1) + else + delta_rho=rho0 + end if - else + face_loop: do j=1, size(surface_element_list) - ! we assume no p-refinement on the coordinate mesh - allocate( face_nodes(1:face_loc(positions,1)) ) + sele=surface_element_list(j) - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list) - if (bctype=="free_surface") then + call set(free_surface, & + face_global_nodes(free_surface, sele), & + (face_val(p, sele)-p_atm)/delta_rho/g) + if (have_wd) then + ! bound free surface from below by -orig_bottomdist+d0 + call set(free_surface, face_global_nodes(free_surface, sele), & + max(face_val(free_surface, sele), -face_val(original_bottomdist_remap, sele))) + end if - face_loop: do j=1, size(surface_element_list) + end do face_loop - sele=surface_element_list(j) - face_nodes=face_global_nodes(positions, sele) + end if - node_loop: do k=1, size(face_nodes) - node=face_nodes(k) - ! compute new surface node position: - call set(iterated_positions, node, & - node_val(original_positions, node)- & - node_val(fs, node)*node_val(gravity_normal, node)) + end do - ! compute new surface node grid velocity: - if(.not.l_initialise) call set(grid_u, node, & - (node_val(iterated_positions, node)-node_val(old_positions,node))/dt) - end do node_loop + topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) + ! if /geometry/ocean_boundaries are not specified we leave at this + if (stat/=0) return - end do face_loop + ! + ! otherwise we continue to extrapolate vertically from the free + ! surface values calculated above + ! - end if - end do - end if + ! note we're not using the actual free_surface bc here, as + ! that may be specified in parts, or not cover the whole area + call get_boundary_condition(topdis, 1, & + surface_element_list=surface_element_list) + vertical_normal => extract_vector_field(state, "GravityDirection") + ! vertically extrapolate pressure values at the free surface downwards + ! (reuse projected horizontal top surface mesh cached under DistanceToTop) + call VerticalExtrapolation(free_surface, free_surface, x, & + vertical_normal, surface_element_list=surface_element_list, & + surface_name="DistanceToTop") - if (l_initialise) then - call set(positions, iterated_positions) - call set(old_positions, iterated_positions) - else - call set(positions, iterated_positions, old_positions, theta) - if(associated(grid_u, local_grid_u)) then - grid_u => extract_vector_field(state, "GridVelocity") - call remap_field(local_grid_u, grid_u) - call deallocate(local_grid_u) - end if - ewrite_minmax(grid_u) - end if - - if (associated(fs, fs_mapped_to_coordinate_space)) then - call deallocate(fs_mapped_to_coordinate_space) - else if (associated(fs, local_fs)) then - call deallocate(local_fs) - end if - - end subroutine move_free_surface_nodes - - function vertical_prolongator_from_free_surface(state, mesh) result (vertical_prolongator) - !! Creates a prolongation operator from the free surface mesh to - !! the full mesh which when provided to petsc_solve is used - !! to implement vertical lumping if the "mg" preconditioner is selected. - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh - type(petsc_csr_matrix):: vertical_prolongator - - type(csr_matrix):: csr_vertical_prolongator - type(scalar_field), pointer:: topdis - type(vector_field), pointer:: positions, vertical_normal - type(integer_set):: owned_surface_nodes - integer, dimension(:), pointer:: surface_element_list, surface_node_list - integer:: stat, i, face, ncols - - ewrite(1, *) "Constructing vertical_prolongator_from_free_surface to be used in mg" - topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) - if (stat/=0) then - FLExit("For vertical lumping you need to specify the ocean_boundaries under /geometry") - end if - - positions => extract_vector_field(state, "Coordinate") - vertical_normal => extract_vector_field(state, "GravityDirection") - - call get_boundary_condition(topdis, 1, & - surface_element_list=surface_element_list, & - surface_node_list=surface_node_list) - - - csr_vertical_prolongator=VerticalProlongationOperator( & - mesh, positions, vertical_normal, surface_element_list) -#ifdef DDEBUG - ! note that in surface_positions the non-owned free surface nodes may be inbetween - ! the reduce_columns option should have removed those however - ! with debugging perform test to check if this is the case: - if (IsParallel()) then - assert( associated(mesh%halos) ) - ! count n/o owned surface nodes - call allocate(owned_surface_nodes) - do i=1, size(surface_element_list) - face=surface_element_list(i) - call insert(owned_surface_nodes, face_global_nodes(mesh, face)) - end do - ! this should be size(csr_vertical_prolongator,2) but intel with debugging - ! seems to choke on it: - ncols = csr_vertical_prolongator%sparsity%columns - ewrite(2,*) "Number of owned surface nodes:", key_count(owned_surface_nodes) - ewrite(2,*) "Number of columns in vertical prolongator:", ncols - if (ncols>key_count(owned_surface_nodes)) then - ewrite(-1,*) "Vertical prolongator seems to be using more surface nodes than the number" - ewrite(-1,*) "of surface nodes within completely owned surface elements. This indicates" - ewrite(-1,*) "the parallel decomposition is not done along columns. You shouldn't be using" - ewrite(-1,*) "mg with vertical_lumping in that case." - FLExit("Vertical lumping requires 2d decomposition along columns") + if (have_wd) then + call deallocate(p_capped) end if - call deallocate(owned_surface_nodes) - end if -#endif - vertical_prolongator=csr2petsc_csr(csr_vertical_prolongator) - call deallocate(csr_vertical_prolongator) + end subroutine calculate_diagnostic_free_surface - end function vertical_prolongator_from_free_surface + subroutine update_wettingdrying_alpha(state) + !!< calculates and updates the alpha coefficients for wetting and drying. + type(state_type), intent(in):: state + type(scalar_field), pointer:: scalar_surface_field - function free_surface_nodes(state, mesh) - !! Returns the list of the nodes on the free surface of the given mesh. - !! Returns a pointer to an allocated array to be deallocated by the caller. - integer, dimension(:), pointer:: free_surface_nodes - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh + integer, dimension(:), pointer :: surface_element_list + type(vector_field), pointer:: u + type(scalar_field), pointer:: p, original_bottomdist_remap + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN) fs_option_path + real:: rho0, g, d0 + integer:: i, j, sele + real, dimension(:), allocatable :: alpha - type(scalar_field), pointer:: topdis - type(mesh_type) surface_mesh - integer, dimension(:), pointer:: surface_element_list, surface_node_list - integer stat - ewrite(1, *) "Extracting list of nodes on the free surface" - topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) - if (stat/=0) then - FLExit("Need to specify the ocean_boundaries under /geometry") - end if + u => extract_vector_field(state, "Velocity") + p => extract_scalar_field(state, "Pressure") + allocate(alpha(face_loc(p, 1))) - if (mesh==topdis%mesh) then - ! we can just copy this info, from the coordinate mesh - call get_boundary_condition(topdis, 1, & - surface_node_list=surface_node_list) - allocate( free_surface_nodes(1: size(surface_node_list)) ) - free_surface_nodes=surface_node_list - else - ! by creating a temporary surface mesh we get exactly this information - call get_boundary_condition(topdis, 1, & - surface_element_list=surface_element_list) - call create_surface_mesh(surface_mesh, surface_node_list, & - mesh, surface_element_list, name=trim(mesh%name)//'FreeSurface') - free_surface_nodes => surface_node_list - call deallocate(surface_mesh) - end if - - end function free_surface_nodes - - subroutine calculate_diagnostic_free_surface(state, free_surface) - !!< calculates a 3D field (constant over the vertical) of the free surface elevation - !!< This can be added as a diagnostic field in the flml. - type(state_type), intent(inout):: state - type(scalar_field), target, intent(inout):: free_surface - - integer, dimension(:), pointer:: surface_element_list - type(vector_field), pointer:: x, u, vertical_normal - type(scalar_field), pointer:: p, topdis, external_density - type(scalar_field), pointer :: original_bottomdist_remap - character(len=OPTION_PATH_LEN):: fs_option_path - type(scalar_field) :: p_min - type(scalar_field), target :: p_capped - character(len=FIELD_NAME_LEN):: bctype - real:: g, rho0, delta_rho, d0, p_atm - integer:: i, j, sele, stat, external_density_stat - logical :: have_wd, have_external_density - - ! the prognostic free surface is calculated elsewhere (this is used - ! in combination with the viscous free surface) - if (have_option(trim(free_surface%option_path)//'/prognostic')) return - - x => extract_vector_field(state, "Coordinate") - p => extract_scalar_field(state, "Pressure") - assert(free_surface%mesh==p%mesh) - - call get_option('/physical_parameters/gravity/magnitude', g) - call get_option(trim(p%option_path)//'/prognostic/atmospheric_pressure', & - p_atm, default=0.0) - - have_wd=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying") - - u => extract_vector_field(state, "Velocity") - call get_fs_reference_density_from_options(rho0, state%option_path) - - if (have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater')) then - ! For the shallow water equations we only have a 2D, horizontal mesh - ! and f.s. is simply p/g everywhere: - call set(free_surface, p) - call scale(free_surface, 1./g) - return - end if - - ! - ! first we compute the right free surface values at the free surface - ! nodes only - ! - - ! Do the wetting and drying corrections: - ! In dry regions, the free surface is not coupled to the pressure but is fixed to -OriginalCoordinate+d0. - ! Hence, we create temporary pressure that is capped to d0-bottom_depth on the surface before extruding it downwards. - if (have_wd) then - call allocate(p_min, p%mesh, "MinimumSurfacePressure") - call allocate(p_capped, p%mesh, "CappedPressure") - call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) - original_bottomdist_remap=>extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") - - ! We are looking for p_capped = min(p, g*rho0*(d0-bottom_depth)) on the surface - call set(p_min, original_bottomdist_remap) - call addto(p_min, -d0) - call scale(p_min, -g*rho0) - call set(p_capped, p) - call bound(p_capped, lower_bound=p_min) - p=>p_capped - - call deallocate(p_min) - end if - - ! make sure other nodes are zeroed - call zero(free_surface) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, & - option_path=fs_option_path) - if (bctype=="free_surface") then - - if (have_option(trim(fs_option_path)//"/type[0]/variable_density")) then - ! options checked below with an flexit - FLAbort("Cannot use a diagnostic free surface field with a variable density free surface bc") - end if - external_density => extract_scalar_surface_field(u, i, "ExternalDensity", stat=external_density_stat) - have_external_density = external_density_stat==0 - - if (size(surface_element_list)==0) cycle - - if (have_external_density) then - delta_rho=rho0-node_val(external_density, 1) - else - delta_rho=rho0 - end if - - face_loop: do j=1, size(surface_element_list) - - sele=surface_element_list(j) - - call set(free_surface, & - face_global_nodes(free_surface, sele), & - (face_val(p, sele)-p_atm)/delta_rho/g) - if (have_wd) then - ! bound free surface from below by -orig_bottomdist+d0 - call set(free_surface, face_global_nodes(free_surface, sele), & - max(face_val(free_surface, sele), -face_val(original_bottomdist_remap, sele))) + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list, option_path=fs_option_path) + if (bctype=="free_surface" .and. has_scalar_surface_field(u, i, "WettingDryingAlpha")) then + scalar_surface_field => extract_scalar_surface_field(u, i, "WettingDryingAlpha") + ! Update WettingDryingAlpha + call get_fs_reference_density_from_options(rho0, state%option_path) + original_bottomdist_remap => extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") + call get_option('/physical_parameters/gravity/magnitude', g) + call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) + + ! Calculate alpha for each surface element + face_loop: do j=1, size(surface_element_list) + sele=surface_element_list(j) + call calculate_alpha(sele, alpha) + call set(scalar_surface_field, & + ele_nodes(scalar_surface_field, j), & + alpha) + end do face_loop + end if + end do + deallocate(alpha) + + contains + subroutine calculate_alpha(sele, alpha) + integer, intent(in) :: sele + real, dimension(face_loc(p, sele)), intent(inout) :: alpha + integer :: i + + alpha = g * face_val(original_bottomdist_remap, sele) -g * d0 + face_val(p, sele) + alpha = alpha/g * (-d0) + do i=1, size(alpha) + if (alpha(i)<=0.0) then + alpha(i)=0.0 + else + alpha(i)=1.0 end if + end do + end subroutine calculate_alpha + end subroutine update_wettingdrying_alpha - end do face_loop - end if - - end do - - topdis => extract_scalar_field(state, "DistanceToTop", stat=stat) - ! if /geometry/ocean_boundaries are not specified we leave at this - if (stat/=0) return + subroutine calculate_diagnostic_wettingdrying_alpha(state, wettingdrying_alpha) + !!< calculates the alpha coefficient of the wetting and drying algorithm. + !!< This can be added as a diagnostic field in the flml. + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: wettingdrying_alpha + type(scalar_field), pointer :: scalar_surface_field - ! - ! otherwise we continue to extrapolate vertically from the free - ! surface values calculated above - ! + integer, dimension(:), pointer :: surface_element_list + type(vector_field), pointer :: x, u, gravity_normal + type(scalar_field), pointer :: topdis + character(len=FIELD_NAME_LEN):: bctype + integer :: i, j, sele, stat + u => extract_vector_field(state, "Velocity") + if (.not. wettingdrying_alpha%mesh==extract_pressure_mesh(state)) then + FLExit("The WettingDryingAlpha diagnostic field must live on the PressureMesh.") + end if - ! note we're not using the actual free_surface bc here, as - ! that may be specified in parts, or not cover the whole area - call get_boundary_condition(topdis, 1, & - surface_element_list=surface_element_list) - vertical_normal => extract_vector_field(state, "GravityDirection") - - ! vertically extrapolate pressure values at the free surface downwards - ! (reuse projected horizontal top surface mesh cached under DistanceToTop) - call VerticalExtrapolation(free_surface, free_surface, x, & - vertical_normal, surface_element_list=surface_element_list, & - surface_name="DistanceToTop") - - if (have_wd) then - call deallocate(p_capped) - end if - - end subroutine calculate_diagnostic_free_surface - - subroutine update_wettingdrying_alpha(state) - !!< calculates and updates the alpha coefficients for wetting and drying. - type(state_type), intent(in):: state - type(scalar_field), pointer:: scalar_surface_field - - integer, dimension(:), pointer :: surface_element_list - type(vector_field), pointer:: u - type(scalar_field), pointer:: p, original_bottomdist_remap - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN) fs_option_path - real:: rho0, g, d0 - integer:: i, j, sele - real, dimension(:), allocatable :: alpha - - - u => extract_vector_field(state, "Velocity") - p => extract_scalar_field(state, "Pressure") - allocate(alpha(face_loc(p, 1))) - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list, option_path=fs_option_path) - if (bctype=="free_surface" .and. has_scalar_surface_field(u, i, "WettingDryingAlpha")) then - scalar_surface_field => extract_scalar_surface_field(u, i, "WettingDryingAlpha") - ! Update WettingDryingAlpha - call get_fs_reference_density_from_options(rho0, state%option_path) - original_bottomdist_remap => extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") - call get_option('/physical_parameters/gravity/magnitude', g) - call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) - - ! Calculate alpha for each surface element - face_loop: do j=1, size(surface_element_list) - sele=surface_element_list(j) - call calculate_alpha(sele, alpha) - call set(scalar_surface_field, & - ele_nodes(scalar_surface_field, j), & - alpha) - end do face_loop - end if - end do - deallocate(alpha) - - contains - subroutine calculate_alpha(sele, alpha) - integer, intent(in) :: sele - real, dimension(face_loc(p, sele)), intent(inout) :: alpha - integer :: i - - alpha = g * face_val(original_bottomdist_remap, sele) -g * d0 + face_val(p, sele) - alpha = alpha/g * (-d0) - do i=1, size(alpha) - if (alpha(i)<=0.0) then - alpha(i)=0.0 - else - alpha(i)=1.0 - end if - end do - end subroutine calculate_alpha - end subroutine update_wettingdrying_alpha - - - subroutine calculate_diagnostic_wettingdrying_alpha(state, wettingdrying_alpha) - !!< calculates the alpha coefficient of the wetting and drying algorithm. - !!< This can be added as a diagnostic field in the flml. - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: wettingdrying_alpha - type(scalar_field), pointer :: scalar_surface_field - - integer, dimension(:), pointer :: surface_element_list - type(vector_field), pointer :: x, u, gravity_normal - type(scalar_field), pointer :: topdis - character(len=FIELD_NAME_LEN):: bctype - integer :: i, j, sele, stat - - u => extract_vector_field(state, "Velocity") - if (.not. wettingdrying_alpha%mesh==extract_pressure_mesh(state)) then - FLExit("The WettingDryingAlpha diagnostic field must live on the PressureMesh.") - end if - - call zero(wettingdrying_alpha) - do i = 1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list = surface_element_list) - if (bctype=="free_surface") then + call zero(wettingdrying_alpha) + do i = 1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & + surface_element_list = surface_element_list) + if (bctype=="free_surface") then scalar_surface_field => extract_scalar_surface_field(u, i, "WettingDryingAlpha") do j = 1, size(surface_element_list) - sele = surface_element_list(j) - call set(wettingdrying_alpha, & - face_global_nodes(wettingdrying_alpha, sele), & - ele_val(scalar_surface_field, j)) + sele = surface_element_list(j) + call set(wettingdrying_alpha, & + face_global_nodes(wettingdrying_alpha, sele), & + ele_val(scalar_surface_field, j)) end do - end if - end do - ! Extrapolate values down the horizontal if possible. - topdis => extract_scalar_field(state, "DistanceToTop", stat = stat) - if (stat == 0) then - ! note we're not using the actual wettingdrying_alpha bc here, as - ! that may be specified in parts, or not cover the whole area - call get_boundary_condition(topdis, 1, & - surface_element_list = surface_element_list) - gravity_normal => extract_vector_field(state, "GravityDirection") - x => extract_vector_field(state, "Coordinate") - - ! vertically extrapolate pressure values at the free surface downwards - ! (reuse projected horizontal top surface mesh cached under DistanceToTop) - call VerticalExtrapolation(wettingdrying_alpha, wettingdrying_alpha, x, & - gravity_normal, surface_element_list = surface_element_list) - end if - - end subroutine calculate_diagnostic_wettingdrying_alpha - - - function calculate_volume_by_surface_integral(state) result(volume) + end if + end do + ! Extrapolate values down the horizontal if possible. + topdis => extract_scalar_field(state, "DistanceToTop", stat = stat) + if (stat == 0) then + ! note we're not using the actual wettingdrying_alpha bc here, as + ! that may be specified in parts, or not cover the whole area + call get_boundary_condition(topdis, 1, & + surface_element_list = surface_element_list) + gravity_normal => extract_vector_field(state, "GravityDirection") + x => extract_vector_field(state, "Coordinate") + + ! vertically extrapolate pressure values at the free surface downwards + ! (reuse projected horizontal top surface mesh cached under DistanceToTop) + call VerticalExtrapolation(wettingdrying_alpha, wettingdrying_alpha, x, & + gravity_normal, surface_element_list = surface_element_list) + end if + + end subroutine calculate_diagnostic_wettingdrying_alpha + + + function calculate_volume_by_surface_integral(state) result(volume) type(state_type), intent(in) :: state real :: dt @@ -2968,9 +2968,9 @@ function calculate_volume_by_surface_integral(state) result(volume) u => extract_vector_field(state, "Velocity") have_wd=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying") if (have_wd) then - call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) - ! original_bottomdist is needed on the pressure mesh - original_bottomdist_remap=>extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") + call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/d0", d0) + ! original_bottomdist is needed on the pressure mesh + original_bottomdist_remap=>extract_scalar_field(state, "OriginalDistanceToBottomPressureMesh") end if ! reference density @@ -2983,254 +2983,254 @@ function calculate_volume_by_surface_integral(state) result(volume) ! for large scale ocean simulations) - otherwise the free surface is assumed flat include_normals = move_mesh if (include_normals) then - gravity_normal => extract_vector_field(state, "GravityDirection") + gravity_normal => extract_vector_field(state, "GravityDirection") end if positions => extract_vector_field(state, "Coordinate") volume=0.0 do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & - surface_element_list=surface_element_list,option_path=fs_option_path) - if (bctype=="free_surface") then - call get_option(trim(fs_option_path)//"/type[0]/external_density", & - external_density, default=0.0) - delta_rho=rho0-external_density - alpha=1.0/g/delta_rho/dt - do j=1, size(surface_element_list) - volume=volume+calculate_volume_by_surface_integral_element(surface_element_list(j)) - end do - end if + call get_boundary_condition(u, i, type=bctype, & + surface_element_list=surface_element_list,option_path=fs_option_path) + if (bctype=="free_surface") then + call get_option(trim(fs_option_path)//"/type[0]/external_density", & + external_density, default=0.0) + delta_rho=rho0-external_density + alpha=1.0/g/delta_rho/dt + do j=1, size(surface_element_list) + volume=volume+calculate_volume_by_surface_integral_element(surface_element_list(j)) + end do + end if end do - contains + contains - function calculate_volume_by_surface_integral_element(sele) result(volume) - integer, intent(in) :: sele - integer :: i + function calculate_volume_by_surface_integral_element(sele) result(volume) + integer, intent(in) :: sele + integer :: i - real, dimension(positions%dim, face_ngi(positions, sele)):: normals - real, dimension(face_loc(p, sele), face_loc(p, sele)):: mass_ele, mass_ele_wd - real, dimension(face_ngi(p, sele)):: detwei, alpha_wetdry_quad - real, dimension(face_loc(p, sele)) :: one - real :: volume + real, dimension(positions%dim, face_ngi(positions, sele)):: normals + real, dimension(face_loc(p, sele), face_loc(p, sele)):: mass_ele, mass_ele_wd + real, dimension(face_ngi(p, sele)):: detwei, alpha_wetdry_quad + real, dimension(face_loc(p, sele)) :: one + real :: volume - one = 1.0 + one = 1.0 - if(include_normals) then - call transform_facet_to_physical(positions, sele, detwei_f=detwei,& - & normal=normals) - ! at each gauss point multiply with inner product of gravity and surface normal - detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) - else - call transform_facet_to_physical(positions, sele, detwei_f=detwei) - end if + if(include_normals) then + call transform_facet_to_physical(positions, sele, detwei_f=detwei,& + & normal=normals) + ! at each gauss point multiply with inner product of gravity and surface normal + detwei=detwei*(-1.0)*sum(face_val_at_quad(gravity_normal,sele)*normals, dim=1) + else + call transform_facet_to_physical(positions, sele, detwei_f=detwei) + end if - if (have_wd) then + if (have_wd) then ! Calculate alpha_wetdry_quad. The resulting array is 0 if the quad point is wet (p > -g d_0) ! and 1 if the quad point is dry (p <= -g d_0) alpha_wetdry_quad = -face_val_at_quad(p, sele)-face_val_at_quad(original_bottomdist_remap, sele)*g + d0 * g do i=1, size(alpha_wetdry_quad) - if (alpha_wetdry_quad(i)>0.0) then - alpha_wetdry_quad(i)=1.0 - else - alpha_wetdry_quad(i)=0.0 - end if + if (alpha_wetdry_quad(i)>0.0) then + alpha_wetdry_quad(i)=1.0 + else + alpha_wetdry_quad(i)=0.0 + end if end do - end if - - if (have_wd) then - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*(1.0-alpha_wetdry_quad)) - mass_ele_wd=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*alpha_wetdry_quad) - else - mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) - mass_ele_wd=0.0 - end if - - volume=dot_product(one,matmul(mass_ele, face_val(original_bottomdist_remap, sele)) & - +matmul(mass_ele_wd, face_val(original_bottomdist_remap, sele))) - - volume=volume-dt*dot_product(one,-matmul(mass_ele, face_val(p, sele))*alpha & - +matmul(mass_ele_wd, face_val(original_bottomdist_remap, sele)-d0)*alpha*g) - - end function calculate_volume_by_surface_integral_element - end function calculate_volume_by_surface_integral - - subroutine free_surface_module_check_options - - character(len=OPTION_PATH_LEN):: option_path, phase_path, pressure_path, pade_path, bc_option_path - character(len=FIELD_NAME_LEN):: fs_meshname, p_meshname, bctype - logical:: have_free_surface, have_explicit_free_surface, have_viscous_free_surface - logical:: have_standard_free_surface, have_variable_density - logical:: local_have_explicit_free_surface, local_have_viscous_free_surface - logical:: have_wd, have_swe - integer i, p - - do p=1, option_count('/material_phase') - phase_path='/material_phase['//int2str(p-1)//']' - pressure_path=trim(phase_path)//'/scalar_field::Pressure/prognostic' - ! check if we have a free_surface bc - option_path=trim(phase_path)//'/vector_field::Velocity/prognostic' - if (have_option(trim(option_path))) then - have_free_surface=.false. - have_viscous_free_surface=.false. - have_explicit_free_surface=.false. - have_standard_free_surface=.false. - have_variable_density=.false. - do i=1, option_count(trim(option_path)//'/boundary_conditions') - call get_option(trim(option_path)//'/boundary_conditions['// & - int2str(i-1)//']/type[0]/name', bctype) - if (bctype=='free_surface') then - have_free_surface=.true. - bc_option_path = trim(option_path)//'/boundary_conditions['// & - int2str(i-1)//']/type[0]' - local_have_viscous_free_surface = have_option(trim(bc_option_path)//'/no_normal_stress').and. & - .not.have_option(trim(bc_option_path)//'/no_normal_stress/explicit') - local_have_explicit_free_surface = have_option(trim(bc_option_path)//'/no_normal_stress').and. & - have_option(trim(bc_option_path)//'/no_normal_stress/explicit') - have_standard_free_surface=have_standard_free_surface.or. & - ((.not.local_have_viscous_free_surface).and.(.not.local_have_explicit_free_surface)) - have_viscous_free_surface=have_viscous_free_surface.or.local_have_viscous_free_surface - have_explicit_free_surface=have_explicit_free_surface.or.local_have_explicit_free_surface - have_variable_density = have_variable_density .or. have_option(trim(bc_option_path)//'/variable_density') - - if (have_option(trim(bc_option_path)//'/external_density') .and. & - .not. have_option(trim(bc_option_path)//'/external_density/constant') .and. & - .not. have_option(trim(bc_option_path)//'/variable_density')) then - ewrite(-1,*) "Under the free surface boundary condition at "//trim(bc_option_path) - FLExit("With a non-constant external density you also need the variable_density option") - end if - end if - end do - else - ! no prognostic velocity, no free_surface bc - have_free_surface=.false. - have_standard_free_surface=.false. - have_explicit_free_surface=.false. - have_viscous_free_surface = .false. - end if - have_wd=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying") + end if - have_swe=have_option(trim(option_path)//'/equation::ShallowWater') + if (have_wd) then + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*(1.0-alpha_wetdry_quad)) + mass_ele_wd=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei*alpha_wetdry_quad) + else + mass_ele=shape_shape(face_shape(p, sele), face_shape(p, sele), detwei) + mass_ele_wd=0.0 + end if - if (have_standard_free_surface) then - ewrite(2,*) "You have a standard free surface boundary condition, checking its options" - end if + volume=dot_product(one,matmul(mass_ele, face_val(original_bottomdist_remap, sele)) & + +matmul(mass_ele_wd, face_val(original_bottomdist_remap, sele))) + + volume=volume-dt*dot_product(one,-matmul(mass_ele, face_val(p, sele))*alpha & + +matmul(mass_ele_wd, face_val(original_bottomdist_remap, sele)-d0)*alpha*g) + + end function calculate_volume_by_surface_integral_element + end function calculate_volume_by_surface_integral + + subroutine free_surface_module_check_options + + character(len=OPTION_PATH_LEN):: option_path, phase_path, pressure_path, pade_path, bc_option_path + character(len=FIELD_NAME_LEN):: fs_meshname, p_meshname, bctype + logical:: have_free_surface, have_explicit_free_surface, have_viscous_free_surface + logical:: have_standard_free_surface, have_variable_density + logical:: local_have_explicit_free_surface, local_have_viscous_free_surface + logical:: have_wd, have_swe + integer i, p + + do p=1, option_count('/material_phase') + phase_path='/material_phase['//int2str(p-1)//']' + pressure_path=trim(phase_path)//'/scalar_field::Pressure/prognostic' + ! check if we have a free_surface bc + option_path=trim(phase_path)//'/vector_field::Velocity/prognostic' + if (have_option(trim(option_path))) then + have_free_surface=.false. + have_viscous_free_surface=.false. + have_explicit_free_surface=.false. + have_standard_free_surface=.false. + have_variable_density=.false. + do i=1, option_count(trim(option_path)//'/boundary_conditions') + call get_option(trim(option_path)//'/boundary_conditions['// & + int2str(i-1)//']/type[0]/name', bctype) + if (bctype=='free_surface') then + have_free_surface=.true. + bc_option_path = trim(option_path)//'/boundary_conditions['// & + int2str(i-1)//']/type[0]' + local_have_viscous_free_surface = have_option(trim(bc_option_path)//'/no_normal_stress').and. & + .not.have_option(trim(bc_option_path)//'/no_normal_stress/explicit') + local_have_explicit_free_surface = have_option(trim(bc_option_path)//'/no_normal_stress').and. & + have_option(trim(bc_option_path)//'/no_normal_stress/explicit') + have_standard_free_surface=have_standard_free_surface.or. & + ((.not.local_have_viscous_free_surface).and.(.not.local_have_explicit_free_surface)) + have_viscous_free_surface=have_viscous_free_surface.or.local_have_viscous_free_surface + have_explicit_free_surface=have_explicit_free_surface.or.local_have_explicit_free_surface + have_variable_density = have_variable_density .or. have_option(trim(bc_option_path)//'/variable_density') + + if (have_option(trim(bc_option_path)//'/external_density') .and. & + .not. have_option(trim(bc_option_path)//'/external_density/constant') .and. & + .not. have_option(trim(bc_option_path)//'/variable_density')) then + ewrite(-1,*) "Under the free surface boundary condition at "//trim(bc_option_path) + FLExit("With a non-constant external density you also need the variable_density option") + end if + end if + end do + else + ! no prognostic velocity, no free_surface bc + have_free_surface=.false. + have_standard_free_surface=.false. + have_explicit_free_surface=.false. + have_viscous_free_surface = .false. + end if + have_wd=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying") - if (have_explicit_free_surface) then - ewrite(2,*) "You have an explicit viscous free surface boundary condition, checking its options" - end if + have_swe=have_option(trim(option_path)//'/equation::ShallowWater') - if (have_viscous_free_surface) then - ewrite(2,*) "You have an implicit viscous free surface boundary condition, checking its options" - end if + if (have_standard_free_surface) then + ewrite(2,*) "You have a standard free surface boundary condition, checking its options" + end if - ! first check we're using the new code path (cg_test or dg) - if (have_free_surface .and. .not. have_option(trim(option_path)// & - '/spatial_discretisation/continuous_galerkin') .and. & - .not. have_option(trim(option_path)// & - '/spatial_discretisation/discontinuous_galerkin')) then - ewrite(-1,*) "With the free_surface boundary condition" - FLExit("you have to use continuous_galerkin or discontinuous_galerkin Velocity") - end if + if (have_explicit_free_surface) then + ewrite(2,*) "You have an explicit viscous free surface boundary condition, checking its options" + end if - ! check pressure options - ! first check we have a progn. pressure at all - if (have_free_surface .and. .not. have_option(pressure_path)) then - ewrite(-1,*) "With the free_surface boundary condition" - FLExit("You need a prognostic pressure") - end if + if (have_viscous_free_surface) then + ewrite(2,*) "You have an implicit viscous free surface boundary condition, checking its options" + end if - if (have_standard_free_surface .and. .not. have_option(trim(pressure_path)// & - '/spatial_discretisation/continuous_galerkin')) then - ewrite(-1,*) "With standard free_surface boundary condition" - FLExit("only a continuous_galerkin spatial_discretisation works for Pressure.") - end if + ! first check we're using the new code path (cg_test or dg) + if (have_free_surface .and. .not. have_option(trim(option_path)// & + '/spatial_discretisation/continuous_galerkin') .and. & + .not. have_option(trim(option_path)// & + '/spatial_discretisation/discontinuous_galerkin')) then + ewrite(-1,*) "With the free_surface boundary condition" + FLExit("you have to use continuous_galerkin or discontinuous_galerkin Velocity") + end if - if (have_standard_free_surface .and. have_option(trim(pressure_path)// & - '/spatial_discretisation/continuous_galerkin/test_continuity_with_cv_dual')) then - ewrite(-1,*) "With standard free_surface boundary condition" - FLExit("you cannot use test_continuity_with_cv_dual under Pressure.") - end if + ! check pressure options + ! first check we have a progn. pressure at all + if (have_free_surface .and. .not. have_option(pressure_path)) then + ewrite(-1,*) "With the free_surface boundary condition" + FLExit("You need a prognostic pressure") + end if - if (have_free_surface .and. .not. have_option(trim(pressure_path)// & - '/spatial_discretisation/continuous_galerkin/integrate_continuity_by_parts')) then - ewrite(-1,*) "With the free_surface boundary condition" - FLExit("you have to use the integrate_continuity_by_parts option under Pressure") - end if + if (have_standard_free_surface .and. .not. have_option(trim(pressure_path)// & + '/spatial_discretisation/continuous_galerkin')) then + ewrite(-1,*) "With standard free_surface boundary condition" + FLExit("only a continuous_galerkin spatial_discretisation works for Pressure.") + end if - ! check diagnostic FreeSurface options: - option_path=trim(phase_path)//'/scalar_field::FreeSurface/diagnostic' - if (have_option(trim(option_path))) then - call get_option(trim(option_path)//'/mesh[0]/name', fs_meshname) - call get_option(trim(pressure_path)//'/mesh[0]/name', p_meshname) - if (.not. (have_free_surface .or. have_swe)) then - ewrite(-1,*) "The diagnostic FreeSurface field has to be used in combination " // & - "with the free_surface boundary condition under Velocity, or with " // & - "equation type ShallowWater for Velocity." - FLExit("Exit") - end if - if (.not. fs_meshname==p_meshname) then - FLExit("The diagnostic FreeSurface field and the Pressure field have to be on the same mesh") - end if - if (.not. have_option('/geometry/ocean_boundaries') .and. .not. have_swe) then - ewrite(0,*) "Warning: your diagnostic free surface will only be " // & - "defined at the free surface nodes and not extrapolated downwards, " // & - "because you didn't specify geometry/ocean_boundaries." - end if - if (have_variable_density) then - FLExit("The diagnostic FreeSurface field cannot be used in combination with a variable density") - end if - end if + if (have_standard_free_surface .and. have_option(trim(pressure_path)// & + '/spatial_discretisation/continuous_galerkin/test_continuity_with_cv_dual')) then + ewrite(-1,*) "With standard free_surface boundary condition" + FLExit("you cannot use test_continuity_with_cv_dual under Pressure.") + end if - ! check prognostic FreeSurface options: - option_path=trim(phase_path)//'/scalar_field::FreeSurface/prognostic' - if ((have_viscous_free_surface.or.have_explicit_free_surface) .and. .not. have_option(option_path)) then - FLExit("For a free surface with no_normal_stress you need a prognostic FreeSurface") - end if - if (have_option(trim(option_path))) then - call get_option(trim(option_path)//'/mesh[0]/name', fs_meshname) - call get_option(trim(pressure_path)//'/mesh[0]/name', p_meshname) - if (.not. have_viscous_free_surface .and. .not. have_explicit_free_surface) then - ewrite(-1,*) "The prognostic FreeSurface field has to be used in combination " // & - "with the free_surface boundary condition under Velocity with the." //& - "no_normal_stress option underneath it." - FLExit("Exit") - end if - if (.not. fs_meshname==p_meshname) then - FLExit("The prognostic FreeSurface field and the Pressure field have to be on the same mesh") - end if - if (.not. have_option('/geometry/ocean_boundaries')) then - ewrite(0,*) "Warning: your prognostic free surface will only be " // & - "defined at the free surface nodes and not extrapolated downwards, " // & - "because you didn't specify geometry/ocean_boundaries." - end if - end if + if (have_free_surface .and. .not. have_option(trim(pressure_path)// & + '/spatial_discretisation/continuous_galerkin/integrate_continuity_by_parts')) then + ewrite(-1,*) "With the free_surface boundary condition" + FLExit("you have to use the integrate_continuity_by_parts option under Pressure") + end if - option_path=trim(phase_path)//'/equation_of_state/fluids/linear/subtract_out_hydrostatic_level' - pade_path=trim(phase_path)//'/equation_of_state/fluids/ocean_pade_approximation' - if (have_free_surface .and. .not.(have_option(option_path)) .and. .not.(have_option(pade_path))) then - ewrite(-1,*) "Missing option: ", trim(option_path) - FLExit("With the free surface you need to subtract out the hydrostatic level.") - end if + ! check diagnostic FreeSurface options: + option_path=trim(phase_path)//'/scalar_field::FreeSurface/diagnostic' + if (have_option(trim(option_path))) then + call get_option(trim(option_path)//'/mesh[0]/name', fs_meshname) + call get_option(trim(pressure_path)//'/mesh[0]/name', p_meshname) + if (.not. (have_free_surface .or. have_swe)) then + ewrite(-1,*) "The diagnostic FreeSurface field has to be used in combination " // & + "with the free_surface boundary condition under Velocity, or with " // & + "equation type ShallowWater for Velocity." + FLExit("Exit") + end if + if (.not. fs_meshname==p_meshname) then + FLExit("The diagnostic FreeSurface field and the Pressure field have to be on the same mesh") + end if + if (.not. have_option('/geometry/ocean_boundaries') .and. .not. have_swe) then + ewrite(0,*) "Warning: your diagnostic free surface will only be " // & + "defined at the free surface nodes and not extrapolated downwards, " // & + "because you didn't specify geometry/ocean_boundaries." + end if + if (have_variable_density) then + FLExit("The diagnostic FreeSurface field cannot be used in combination with a variable density") + end if + end if - option_path=trim(phase_path)//'/scalar_field::Pressure/prognostic/reference_node' - if (have_free_surface .and. have_option(option_path)) then - FLExit("With the free surface you shouldn't set a reference node for Pressure") - end if + ! check prognostic FreeSurface options: + option_path=trim(phase_path)//'/scalar_field::FreeSurface/prognostic' + if ((have_viscous_free_surface.or.have_explicit_free_surface) .and. .not. have_option(option_path)) then + FLExit("For a free surface with no_normal_stress you need a prognostic FreeSurface") + end if + if (have_option(trim(option_path))) then + call get_option(trim(option_path)//'/mesh[0]/name', fs_meshname) + call get_option(trim(pressure_path)//'/mesh[0]/name', p_meshname) + if (.not. have_viscous_free_surface .and. .not. have_explicit_free_surface) then + ewrite(-1,*) "The prognostic FreeSurface field has to be used in combination " // & + "with the free_surface boundary condition under Velocity with the." //& + "no_normal_stress option underneath it." + FLExit("Exit") + end if + if (.not. fs_meshname==p_meshname) then + FLExit("The prognostic FreeSurface field and the Pressure field have to be on the same mesh") + end if + if (.not. have_option('/geometry/ocean_boundaries')) then + ewrite(0,*) "Warning: your prognostic free surface will only be " // & + "defined at the free surface nodes and not extrapolated downwards, " // & + "because you didn't specify geometry/ocean_boundaries." + end if + end if - option_path=trim(phase_path)//'/scalar_field::Pressure/prognostic/solver/remove_null_space' - if (have_free_surface .and. have_option(option_path)) then - FLExit("With the free surface you shouldn't set remove the null space ") - end if + option_path=trim(phase_path)//'/equation_of_state/fluids/linear/subtract_out_hydrostatic_level' + pade_path=trim(phase_path)//'/equation_of_state/fluids/ocean_pade_approximation' + if (have_free_surface .and. .not.(have_option(option_path)) .and. .not.(have_option(pade_path))) then + ewrite(-1,*) "Missing option: ", trim(option_path) + FLExit("With the free surface you need to subtract out the hydrostatic level.") + end if - if ((have_viscous_free_surface .or. have_explicit_free_surface) .and. have_wd) then - ! feel free to try and add a test case - ! if you find it indeed doesn't work please change to FLExit - ewrite(0,*) "WARNING: the combination no_normal_stress under and wetting and drying is completely untested." - end if - end do + option_path=trim(phase_path)//'/scalar_field::Pressure/prognostic/reference_node' + if (have_free_surface .and. have_option(option_path)) then + FLExit("With the free surface you shouldn't set a reference node for Pressure") + end if + + option_path=trim(phase_path)//'/scalar_field::Pressure/prognostic/solver/remove_null_space' + if (have_free_surface .and. have_option(option_path)) then + FLExit("With the free surface you shouldn't set remove the null space ") + end if + + if ((have_viscous_free_surface .or. have_explicit_free_surface) .and. have_wd) then + ! feel free to try and add a test case + ! if you find it indeed doesn't work please change to FLExit + ewrite(0,*) "WARNING: the combination no_normal_stress under and wetting and drying is completely untested." + end if + end do - end subroutine free_surface_module_check_options + end subroutine free_surface_module_check_options end module free_surface_module diff --git a/assemble/Full_Projection.F90 b/assemble/Full_Projection.F90 index 972386592b..d7a43ee0c5 100644 --- a/assemble/Full_Projection.F90 +++ b/assemble/Full_Projection.F90 @@ -26,40 +26,40 @@ ! USA #include "fdebug.h" - module Full_Projection - use fldebug - use global_parameters - use elements - use spud - use petsc - use parallel_tools - use data_structures - use sparse_tools - use fields - use petsc_tools - use signal_vars - use sparse_tools_petsc - use sparse_matrices_fields - use state_module - use halos - use multigrid - use solvers - use boundary_conditions - use petsc_solve_state_module - use boundary_conditions_from_options - - implicit none +module Full_Projection + use fldebug + use global_parameters + use elements + use spud + use petsc + use parallel_tools + use data_structures + use sparse_tools + use fields + use petsc_tools + use signal_vars + use sparse_tools_petsc + use sparse_matrices_fields + use state_module + use halos + use multigrid + use solvers + use boundary_conditions + use petsc_solve_state_module + use boundary_conditions_from_options + + implicit none #include "petsc_legacy.h" - private + private - public petsc_solve_full_projection + public petsc_solve_full_projection - contains +contains !-------------------------------------------------------------------------------------------------------------------- - subroutine petsc_solve_full_projection(x,ctp_m,inner_m,ct_m,rhs,pmat, velocity, & + subroutine petsc_solve_full_projection(x,ctp_m,inner_m,ct_m,rhs,pmat, velocity, & state, inner_mesh, auxiliary_matrix) !-------------------------------------------------------------------------------------------------------------------- @@ -103,8 +103,8 @@ subroutine petsc_solve_full_projection(x,ctp_m,inner_m,ct_m,rhs,pmat, velocity, ! Build Schur complement and set KSP. ewrite(2,*) 'Entering PETSc setup for Full Projection Solve' call petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering,name,solver_option_path, & - lstartfromzero,inner_m,ctp_m,ct_m,x%option_path,pmat, & - rhs, velocity, state, inner_mesh, auxiliary_matrix) + lstartfromzero,inner_m,ctp_m,ct_m,x%option_path,pmat, & + rhs, velocity, state, inner_mesh, auxiliary_matrix) ewrite(2,*) 'Create RHS and solution Vectors in PETSc Format' ! create PETSc vec for rhs using above numbering: @@ -120,7 +120,7 @@ subroutine petsc_solve_full_projection(x,ctp_m,inner_m,ct_m,rhs,pmat, velocity, ewrite(2,*) 'Entering Core PETSc Solve' ! Solve Ay = b using KSP and PC. Also check convergence. We call this the inner solve. call petsc_solve_core(y, A, b, ksp, petsc_numbering, solver_option_path, lstartfromzero, & - literations, sfield=x, x0=x%val, nomatrixdump=.true.) + literations, sfield=x, x0=x%val, nomatrixdump=.true.) ewrite(2,*) 'Copying PETSc solution vector into designated Fluidity array' ! Copy back the result into the fluidity solution array (x) using the PETSc numbering: @@ -132,12 +132,12 @@ subroutine petsc_solve_full_projection(x,ctp_m,inner_m,ct_m,rhs,pmat, velocity, ewrite(2,*) 'Leaving PETSc_solve_full_projection' - end subroutine petsc_solve_full_projection + end subroutine petsc_solve_full_projection !-------------------------------------------------------------------------------------------------------- - subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,solver_option_path, & - lstartfromzero,inner_m,div_matrix_comp, div_matrix_incomp,option_path,preconditioner_matrix,rhs, & - velocity, state, inner_mesh, auxiliary_matrix) + subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,solver_option_path, & + lstartfromzero,inner_m,div_matrix_comp, div_matrix_incomp,option_path,preconditioner_matrix,rhs, & + velocity, state, inner_mesh, auxiliary_matrix) !-------------------------------------------------------------------------------------------------------- @@ -212,8 +212,8 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so ! Sort option paths etc... solver_option_path=complete_solver_option_path(option_path) inner_option_path= trim(option_path)//& - "/prognostic/scheme/use_projection_method& - &/full_schur_complement/inner_matrix[0]" + "/prognostic/scheme/use_projection_method& + &/full_schur_complement/inner_matrix[0]" if (have_option(trim(option_path)//'/name')) then call get_option(trim(option_path)//'/name', name) @@ -225,15 +225,15 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so ! Are we applying a reference pressure node? apply_reference_node = have_option(trim(option_path)//& - '/prognostic/reference_node') + '/prognostic/reference_node') apply_reference_node_from_coordinates = have_option(trim(option_path)//& - '/prognostic/reference_coordinates') + '/prognostic/reference_coordinates') ! If so, impose reference pressure node: if(apply_reference_node) then call get_option(trim(option_path)//& - '/prognostic/reference_node', reference_node) + '/prognostic/reference_node', reference_node) if (GetProcNo()==1) then ewrite(2,*) 'Imposing_reference_pressure_node' allocate(ghost_nodes(1:1)) @@ -274,20 +274,20 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so ! set up numbering used in PETSc objects: call allocate(petsc_numbering_u, & - nnodes=block_size(div_matrix_comp,2), nfields=blocks(div_matrix_comp,2), & - group_size=inner_m%row_numbering%group_size, & - halo=div_matrix_comp%sparsity%column_halo) + nnodes=block_size(div_matrix_comp,2), nfields=blocks(div_matrix_comp,2), & + group_size=inner_m%row_numbering%group_size, & + halo=div_matrix_comp%sparsity%column_halo) call allocate(petsc_numbering_p, & - nnodes=block_size(div_matrix_comp,1), nfields=1, & - halo=preconditioner_matrix%sparsity%row_halo, ghost_nodes=ghost_nodes) + nnodes=block_size(div_matrix_comp,1), nfields=1, & + halo=preconditioner_matrix%sparsity%row_halo, ghost_nodes=ghost_nodes) - ! - why is this using the row halo of the preconditioner matrix when there might be rows missing? - ! - same question about the nnodes use of the rows of the block of the divergence matrix? - ! - and how can ghost_nodes be appropriate for both this and the auxiliary_matrix? - ! this definitely appears to be inappropriate for the auxiliary matrix (hence there's a new one added - ! below) so two questions: - ! 1. is it definitely appropriate for all its other used (the divergence matrix and the pressure vectors)? - ! 2. can it be made appropriate for the auxiliary matrix at the same time as being appropriate for the current uses? + ! - why is this using the row halo of the preconditioner matrix when there might be rows missing? + ! - same question about the nnodes use of the rows of the block of the divergence matrix? + ! - and how can ghost_nodes be appropriate for both this and the auxiliary_matrix? + ! this definitely appears to be inappropriate for the auxiliary matrix (hence there's a new one added + ! below) so two questions: + ! 1. is it definitely appropriate for all its other used (the divergence matrix and the pressure vectors)? + ! 2. can it be made appropriate for the auxiliary matrix at the same time as being appropriate for the current uses? ! the rows of the gradient matrix (ct_m^T) and columns of ctp_m ! corresponding to dirichlet bcs have not been zeroed @@ -309,8 +309,8 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so call collect_vector_dirichlet_conditions(velocity, boundary_row_set) ! mark these out with -1 do i=1, velocity%dim - petsc_numbering_u%gnn2unn(set2vector(boundary_row_set(i)), i) = -1 - call deallocate(boundary_row_set(i)) + petsc_numbering_u%gnn2unn(set2vector(boundary_row_set(i)), i) = -1 + call deallocate(boundary_row_set(i)) end do ! Convert Divergence matrix (currently stored as block_csr matrix) to petsc format: @@ -337,9 +337,9 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so ! NOTE: we use size(auxiliary_matrix,2) here as halo rows may be absent allocate(ghost_nodes_aux(1:0)) call allocate(petsc_numbering_aux, & - nnodes=size(auxiliary_matrix,2), nfields=1, & - halo=auxiliary_matrix%sparsity%column_halo, & - ghost_nodes=ghost_nodes_aux) + nnodes=size(auxiliary_matrix,2), nfields=1, & + halo=auxiliary_matrix%sparsity%column_halo, & + ghost_nodes=ghost_nodes_aux) S=csr2petsc(auxiliary_matrix, petsc_numbering_aux, petsc_numbering_aux) @@ -362,67 +362,67 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so end if if (have_option(trim(inner_option_path)//"/solver")) then - ! for FullMass solver/ is required - and this is the first time we use these options - ! for FullMomentum solver/ is optional - if present the specified nullspace options are possibly different - ! in both cases we need to setup the null spaces of the inner matrix here - - ! this call returns, depending on options, prolongators and mesh_positions needed for setting - ! up the ksp and the nullspaces - call petsc_solve_state_setup(inner_solver_option_path, prolongators, surface_nodes, & - state, inner_mesh, blocks(div_matrix_comp,2), inner_option_path, matrix_has_solver_cache=.false., & - mesh_positions=mesh_positions) - - if (associated(prolongators))then - FLExit("mg vertical_lumping and higher_order_lumping not supported for inner_matrix solve") - end if - - rotation_matrix => extract_petsc_csr_matrix(state, "RotationMatrix", stat=rotation_stat) - if (associated(mesh_positions)) then - if (rotation_stat==0) then + ! for FullMass solver/ is required - and this is the first time we use these options + ! for FullMomentum solver/ is optional - if present the specified nullspace options are possibly different + ! in both cases we need to setup the null spaces of the inner matrix here + + ! this call returns, depending on options, prolongators and mesh_positions needed for setting + ! up the ksp and the nullspaces + call petsc_solve_state_setup(inner_solver_option_path, prolongators, surface_nodes, & + state, inner_mesh, blocks(div_matrix_comp,2), inner_option_path, matrix_has_solver_cache=.false., & + mesh_positions=mesh_positions) + + if (associated(prolongators))then + FLExit("mg vertical_lumping and higher_order_lumping not supported for inner_matrix solve") + end if + + rotation_matrix => extract_petsc_csr_matrix(state, "RotationMatrix", stat=rotation_stat) + if (associated(mesh_positions)) then + if (rotation_stat==0) then + call attach_null_space_from_options(inner_M%M, inner_solver_option_path, & + positions=mesh_positions, rotation_matrix=rotation_matrix%M, & + petsc_numbering=petsc_numbering_u) + else + call attach_null_space_from_options(inner_M%M, inner_solver_option_path, & + positions=mesh_positions, petsc_numbering=petsc_numbering_u) + end if + call deallocate(mesh_positions) + deallocate(mesh_positions) + elseif (rotation_stat==0) then call attach_null_space_from_options(inner_M%M, inner_solver_option_path, & - positions=mesh_positions, rotation_matrix=rotation_matrix%M, & - petsc_numbering=petsc_numbering_u) - else + rotation_matrix=rotation_matrix%M, petsc_numbering=petsc_numbering_u) + else call attach_null_space_from_options(inner_M%M, inner_solver_option_path, & - positions=mesh_positions, petsc_numbering=petsc_numbering_u) - end if - call deallocate(mesh_positions) - deallocate(mesh_positions) - elseif (rotation_stat==0) then - call attach_null_space_from_options(inner_M%M, inner_solver_option_path, & - rotation_matrix=rotation_matrix%M, petsc_numbering=petsc_numbering_u) - else - call attach_null_space_from_options(inner_M%M, inner_solver_option_path, & - petsc_numbering=petsc_numbering_u) - end if + petsc_numbering=petsc_numbering_u) + end if else - ! for FullMomentum solver/ is optional - if it's not there we reuse the option path of velocity - inner_solver_option_path = complete_solver_option_path(velocity%option_path) + ! for FullMomentum solver/ is optional - if it's not there we reuse the option path of velocity + inner_solver_option_path = complete_solver_option_path(velocity%option_path) end if if (inner_M%ksp==PETSC_NULL_KSP) then - ! use the one that's just been created for us - call MatSchurComplementGetKSP(A,ksp_schur,ierr) + ! use the one that's just been created for us + call MatSchurComplementGetKSP(A,ksp_schur,ierr) - ! we keep our own reference, so it can be re-used in the velocity correction solve - call PetscObjectReferenceWrapper(ksp_schur, ierr) - inner_M%ksp = ksp_schur + ! we keep our own reference, so it can be re-used in the velocity correction solve + call PetscObjectReferenceWrapper(ksp_schur, ierr) + inner_M%ksp = ksp_schur else - ! we have a ksp (presumably from the first velocity solve), try to reuse it - ewrite(2,*) "Reusing the ksp from the initial velocity solve" - call MatSchurComplementSetKSP(A, inner_M%ksp, ierr) + ! we have a ksp (presumably from the first velocity solve), try to reuse it + ewrite(2,*) "Reusing the ksp from the initial velocity solve" + call MatSchurComplementSetKSP(A, inner_M%ksp, ierr) end if call setup_ksp_from_options(inner_M%ksp, inner_M%M, inner_M%M, & - inner_solver_option_path, petsc_numbering=petsc_numbering_u, startfromzero_in=.true.) + inner_solver_option_path, petsc_numbering=petsc_numbering_u, startfromzero_in=.true.) ! leaving out petsc_numbering and mesh, so "iteration_vtus" monitor won't work! ! Assemble preconditioner matrix in petsc format (if required): have_preconditioner_matrix=.not.(have_option(trim(option_path)//& - "/prognostic/scheme/use_projection_method& - &/full_schur_complement/preconditioner_matrix::NoPreconditionerMatrix")) + "/prognostic/scheme/use_projection_method& + &/full_schur_complement/preconditioner_matrix::NoPreconditionerMatrix")) if(have_preconditioner_matrix) then pmat=csr2petsc(preconditioner_matrix, petsc_numbering_p, petsc_numbering_p) @@ -457,6 +457,6 @@ subroutine petsc_solve_setup_full_projection(y,A,b,ksp,petsc_numbering_p,name,so call deallocate( petsc_numbering_u ) ! petsc_numbering_p is passed back and destroyed there - end subroutine petsc_solve_setup_full_projection + end subroutine petsc_solve_setup_full_projection - end module Full_Projection +end module Full_Projection diff --git a/assemble/Geostrophic_Pressure.F90 b/assemble/Geostrophic_Pressure.F90 index 7494fc51ab..4c271c04a9 100644 --- a/assemble/Geostrophic_Pressure.F90 +++ b/assemble/Geostrophic_Pressure.F90 @@ -28,3230 +28,3230 @@ #include "fdebug.h" module geostrophic_pressure - use fldebug - use global_parameters, only : empty_path, FIELD_NAME_LEN, OPTION_PATH_LEN - use futils, only: present_and_true, present_and_false, int2str - use spud - use vector_tools, only: solve - use data_structures - use parallel_tools, only: allsum - use sparse_tools - use quadrature - use eventcounter - use element_numbering, only : FAMILY_SIMPLEX - use elements - use unittest_tools - use parallel_fields, only: assemble_ele, element_owned - use fetools - use fields - use state_module - use field_options - use sparse_matrices_fields - use vtk_interfaces - use fefields - use boundary_conditions - use assemble_cmc - use sparsity_patterns - use dgtools - use solvers - use sparsity_patterns_meshes - use state_fields_module - use surfacelabels - use boundary_conditions_from_options - use pickers - use conservative_interpolation_module - use coriolis_module, only : two_omega => coriolis - use divergence_matrix_cg - use hydrostatic_pressure - use petsc_solve_state_module - use momentum_cg - use momentum_dg - - implicit none - - private - - public :: subtract_geostrophic_pressure_gradient, & - & calculate_geostrophic_pressure_options, calculate_geostrophic_pressure, & - & geostrophic_pressure_check_options - - public :: projection_decomposition, geopressure_decomposition, & - & geostrophic_velocity, initialise_geostrophic_interpolation, & - & finalise_geostrophic_interpolation - public :: cmc_matrices, allocate, deallocate, add_cmc_matrix, & - & add_geopressure_matrices, correct_velocity, compute_conservative, & - & compute_divergence - public :: coriolis_val, velocity_from_coriolis_val - - character(len = *), parameter, public :: gp_name = "GeostrophicPressure" - character(len = *), parameter, public :: gp_rhs_name = "GeostrophicPressureRhs" - character(len = *), parameter, public :: gp_m_name = "GeostrophicPressureMatrix" - - ! Note: calculate_geostrophic_pressure_options and - ! calculate_geostrophic_pressure cannot be nicely interfaced because of - ! ambiguity in the interfaces - - integer, save :: last_mesh_movement = -1 - - ! Assembly options - character(len = FIELD_NAME_LEN), save :: velocity_name = "NonlinearVelocity" - logical, save :: assemble_matrix = .true. - logical, save :: include_buoyancy = .true. - logical, save :: include_coriolis = .true. - integer, save :: reference_node = 0 - - !! Type for handling pressure projection matrices - type cmc_matrices - !! Whether this is a lumped mass projection - logical :: lump_mass - !! Whether divergence has been integrated by parts - logical :: integrate_by_parts - !! Velocity mesh - type(mesh_type) :: u_mesh - !! Pressure mesh - type(mesh_type) :: p_mesh - !! Pressure option path - character(len = OPTION_PATH_LEN) :: p_option_path - !! Mass option path - character(len = OPTION_PATH_LEN) :: mass_option_path - !! Divergence matrix - type(block_csr_matrix), pointer :: ct_m - !! RHS terms from integrating the divergence operator by parts - type(scalar_field) :: ct_rhs - !! Mass matrix. Only used when not lumping mass for continuous u_mesh. - type(block_csr_matrix) :: mass_b - !! Inverse mass matrix. Only used when not lumping mass for discontinuous u_mesh. - type(block_csr_matrix) :: inverse_mass_b - !! Inverse lumped mass matrix. Only used when lumping mass. - type(vector_field) :: inverse_masslump_v - - !! Whether CMC itself has been added - logical :: have_cmc_m = .false. - !! Laplacian matrix, C^T M^-1 C - type(csr_matrix) :: cmc_m - - !! Whether geopressure preconditioner matrices have been added - logical :: have_geopressure = .false. - !! Geopressure mesh - type(mesh_type) :: gp_mesh - !! Geopressure divergence matrix - type(block_csr_matrix) :: ct_gp_m - !! Geopressure Laplacian matrix, C^T M^-1 C_gp - type(csr_matrix) :: cmc_gp_m - end type cmc_matrices - - interface allocate - module procedure allocate_cmc_matrices - end interface allocate - - interface deallocate - module procedure deallocate_cmc_matrices - end interface deallocate - - interface coriolis_val - module procedure coriolis_val_single, coriolis_val_multiple - end interface coriolis_val - - interface velocity_from_coriolis_val - module procedure velocity_from_coriolis_val_single, velocity_from_coriolis_val_multiple - end interface velocity_from_coriolis_val - - interface clear_boundary_conditions - module procedure clear_boundary_conditions_scalar_single, clear_boundary_conditions_scalar_multiple - end interface clear_boundary_conditions - - interface derive_interpolated_p_dirichlet - module procedure derive_interpolated_p_dirichlet_single, derive_interpolated_p_dirichlet_double, & + use fldebug + use global_parameters, only : empty_path, FIELD_NAME_LEN, OPTION_PATH_LEN + use futils, only: present_and_true, present_and_false, int2str + use spud + use vector_tools, only: solve + use data_structures + use parallel_tools, only: allsum + use sparse_tools + use quadrature + use eventcounter + use element_numbering, only : FAMILY_SIMPLEX + use elements + use unittest_tools + use parallel_fields, only: assemble_ele, element_owned + use fetools + use fields + use state_module + use field_options + use sparse_matrices_fields + use vtk_interfaces + use fefields + use boundary_conditions + use assemble_cmc + use sparsity_patterns + use dgtools + use solvers + use sparsity_patterns_meshes + use state_fields_module + use surfacelabels + use boundary_conditions_from_options + use pickers + use conservative_interpolation_module + use coriolis_module, only : two_omega => coriolis + use divergence_matrix_cg + use hydrostatic_pressure + use petsc_solve_state_module + use momentum_cg + use momentum_dg + + implicit none + + private + + public :: subtract_geostrophic_pressure_gradient, & + & calculate_geostrophic_pressure_options, calculate_geostrophic_pressure, & + & geostrophic_pressure_check_options + + public :: projection_decomposition, geopressure_decomposition, & + & geostrophic_velocity, initialise_geostrophic_interpolation, & + & finalise_geostrophic_interpolation + public :: cmc_matrices, allocate, deallocate, add_cmc_matrix, & + & add_geopressure_matrices, correct_velocity, compute_conservative, & + & compute_divergence + public :: coriolis_val, velocity_from_coriolis_val + + character(len = *), parameter, public :: gp_name = "GeostrophicPressure" + character(len = *), parameter, public :: gp_rhs_name = "GeostrophicPressureRhs" + character(len = *), parameter, public :: gp_m_name = "GeostrophicPressureMatrix" + + ! Note: calculate_geostrophic_pressure_options and + ! calculate_geostrophic_pressure cannot be nicely interfaced because of + ! ambiguity in the interfaces + + integer, save :: last_mesh_movement = -1 + + ! Assembly options + character(len = FIELD_NAME_LEN), save :: velocity_name = "NonlinearVelocity" + logical, save :: assemble_matrix = .true. + logical, save :: include_buoyancy = .true. + logical, save :: include_coriolis = .true. + integer, save :: reference_node = 0 + + !! Type for handling pressure projection matrices + type cmc_matrices + !! Whether this is a lumped mass projection + logical :: lump_mass + !! Whether divergence has been integrated by parts + logical :: integrate_by_parts + !! Velocity mesh + type(mesh_type) :: u_mesh + !! Pressure mesh + type(mesh_type) :: p_mesh + !! Pressure option path + character(len = OPTION_PATH_LEN) :: p_option_path + !! Mass option path + character(len = OPTION_PATH_LEN) :: mass_option_path + !! Divergence matrix + type(block_csr_matrix), pointer :: ct_m + !! RHS terms from integrating the divergence operator by parts + type(scalar_field) :: ct_rhs + !! Mass matrix. Only used when not lumping mass for continuous u_mesh. + type(block_csr_matrix) :: mass_b + !! Inverse mass matrix. Only used when not lumping mass for discontinuous u_mesh. + type(block_csr_matrix) :: inverse_mass_b + !! Inverse lumped mass matrix. Only used when lumping mass. + type(vector_field) :: inverse_masslump_v + + !! Whether CMC itself has been added + logical :: have_cmc_m = .false. + !! Laplacian matrix, C^T M^-1 C + type(csr_matrix) :: cmc_m + + !! Whether geopressure preconditioner matrices have been added + logical :: have_geopressure = .false. + !! Geopressure mesh + type(mesh_type) :: gp_mesh + !! Geopressure divergence matrix + type(block_csr_matrix) :: ct_gp_m + !! Geopressure Laplacian matrix, C^T M^-1 C_gp + type(csr_matrix) :: cmc_gp_m + end type cmc_matrices + + interface allocate + module procedure allocate_cmc_matrices + end interface allocate + + interface deallocate + module procedure deallocate_cmc_matrices + end interface deallocate + + interface coriolis_val + module procedure coriolis_val_single, coriolis_val_multiple + end interface coriolis_val + + interface velocity_from_coriolis_val + module procedure velocity_from_coriolis_val_single, velocity_from_coriolis_val_multiple + end interface velocity_from_coriolis_val + + interface clear_boundary_conditions + module procedure clear_boundary_conditions_scalar_single, clear_boundary_conditions_scalar_multiple + end interface clear_boundary_conditions + + interface derive_interpolated_p_dirichlet + module procedure derive_interpolated_p_dirichlet_single, derive_interpolated_p_dirichlet_double, & & derive_interpolated_p_dirichlet_multiple - end interface derive_interpolated_p_dirichlet - - interface decompose_p_mean - module procedure decompose_p_mean_single, decompose_p_mean_double, decompose_p_mean_multiple - end interface decompose_p_mean - - interface decompose_p_optimal - module procedure decompose_p_optimal_single, decompose_p_optimal_double, decompose_p_optimal_multiple - end interface decompose_p_optimal - - character(len = *), parameter :: temp_solver_path = "/temporary/solver/path" - character(len = *), parameter :: gi_prefix = "GeostrophicInterpolation" - character(len = *), parameter :: gi_res_name = gi_prefix // "CoriolisNonConservativeResidual" - character(len = *), parameter :: gi_conservative_potential_name = gi_prefix // "CoriolisConservativePotential" - character(len = *), parameter :: gi_gp_conservative_potential_name = gi_prefix // "CoriolisGeopressureConservativePotential" - character(len = *), parameter :: gi_w_name = gi_prefix // "VerticalVelocity" - character(len = *), parameter :: gi_p_decomp_postfix = "Imbalanced" - - interface insert_for_interpolation - module procedure insert_for_interpolation_scalar, & + end interface derive_interpolated_p_dirichlet + + interface decompose_p_mean + module procedure decompose_p_mean_single, decompose_p_mean_double, decompose_p_mean_multiple + end interface decompose_p_mean + + interface decompose_p_optimal + module procedure decompose_p_optimal_single, decompose_p_optimal_double, decompose_p_optimal_multiple + end interface decompose_p_optimal + + character(len = *), parameter :: temp_solver_path = "/temporary/solver/path" + character(len = *), parameter :: gi_prefix = "GeostrophicInterpolation" + character(len = *), parameter :: gi_res_name = gi_prefix // "CoriolisNonConservativeResidual" + character(len = *), parameter :: gi_conservative_potential_name = gi_prefix // "CoriolisConservativePotential" + character(len = *), parameter :: gi_gp_conservative_potential_name = gi_prefix // "CoriolisGeopressureConservativePotential" + character(len = *), parameter :: gi_w_name = gi_prefix // "VerticalVelocity" + character(len = *), parameter :: gi_p_decomp_postfix = "Imbalanced" + + interface insert_for_interpolation + module procedure insert_for_interpolation_scalar, & & insert_for_interpolation_vector - end interface insert_for_interpolation + end interface insert_for_interpolation - interface initialise_geostrophic_interpolation - module procedure initialise_geostrophic_interpolation_states, & + interface initialise_geostrophic_interpolation + module procedure initialise_geostrophic_interpolation_states, & & initialise_geostrophic_interpolation_velocity - end interface initialise_geostrophic_interpolation + end interface initialise_geostrophic_interpolation - interface finalise_geostrophic_interpolation - module procedure finalise_geostrophic_interpolation_states, & + interface finalise_geostrophic_interpolation + module procedure finalise_geostrophic_interpolation_states, & & finalise_geostrophic_interpolation_velocity - end interface finalise_geostrophic_interpolation + end interface finalise_geostrophic_interpolation contains - subroutine calculate_geostrophic_pressure_options(state, gp) - !!< Calculate the GeostrophicPressure field. The field is inserted into - !!< state, and optionally returned through the "gp" argument. - !!< Based on David's Geostrophic_Pressure, and some parts of Assnav / - !!< geoeli1p. - !!< Replaces geobal = -20 and -21. + subroutine calculate_geostrophic_pressure_options(state, gp) + !!< Calculate the GeostrophicPressure field. The field is inserted into + !!< state, and optionally returned through the "gp" argument. + !!< Based on David's Geostrophic_Pressure, and some parts of Assnav / + !!< geoeli1p. + !!< Replaces geobal = -20 and -21. - type(state_type), intent(inout) :: state - type(scalar_field), optional, intent(out) :: gp + type(state_type), intent(inout) :: state + type(scalar_field), optional, intent(out) :: gp - character(len = OPTION_PATH_LEN) :: path, geostrophic_pressure_option - integer :: reference_node, stat - logical :: assemble_matrix, include_buoyancy, include_coriolis - real, dimension(:), allocatable :: zero_coord - type(scalar_field), pointer :: lgp - type(vector_field), pointer :: positions + character(len = OPTION_PATH_LEN) :: path, geostrophic_pressure_option + integer :: reference_node, stat + logical :: assemble_matrix, include_buoyancy, include_coriolis + real, dimension(:), allocatable :: zero_coord + type(scalar_field), pointer :: lgp + type(vector_field), pointer :: positions - ewrite(1, *) "In calculate_geostrophic_pressure_options" + ewrite(1, *) "In calculate_geostrophic_pressure_options" - lgp => extract_scalar_field(state, gp_name) - path = complete_field_path(lgp%option_path) + lgp => extract_scalar_field(state, gp_name) + path = complete_field_path(lgp%option_path) - assemble_matrix = do_assemble_matrix(state) - call get_option(trim(path) // "/spatial_discretisation/geostrophic_pressure_option", geostrophic_pressure_option) - include_buoyancy = have_option("/physical_parameters/gravity") .and. & + assemble_matrix = do_assemble_matrix(state) + call get_option(trim(path) // "/spatial_discretisation/geostrophic_pressure_option", geostrophic_pressure_option) + include_buoyancy = have_option("/physical_parameters/gravity") .and. & & geostrophic_pressure_option /= "exclude_buoyancy" - include_coriolis = have_option("/physical_parameters/coriolis") .and. & + include_coriolis = have_option("/physical_parameters/coriolis") .and. & & geostrophic_pressure_option /= "exclude_coriolis" - call get_option(trim(path) // "/reference_node", reference_node, default = 0) + call get_option(trim(path) // "/reference_node", reference_node, default = 0) - ! Calculate GeostrophicPressure - call calculate_geostrophic_pressure(state, lgp, & + ! Calculate GeostrophicPressure + call calculate_geostrophic_pressure(state, lgp, & & velocity_name = "NonlinearVelocity", assemble_matrix = assemble_matrix, include_buoyancy = include_buoyancy, include_coriolis = include_coriolis, & & reference_node = reference_node) - ! Enforce zero point coordinate (if selected) - allocate(zero_coord(mesh_dim(lgp))) - call get_option(trim(path) // "/zero_coord", zero_coord, stat = stat) - if(stat == SPUD_NO_ERROR) then - positions => extract_vector_field(state, "Coordinate") - call set_zero_point(lgp, positions, zero_coord) - end if - deallocate(zero_coord) + ! Enforce zero point coordinate (if selected) + allocate(zero_coord(mesh_dim(lgp))) + call get_option(trim(path) // "/zero_coord", zero_coord, stat = stat) + if(stat == SPUD_NO_ERROR) then + positions => extract_vector_field(state, "Coordinate") + call set_zero_point(lgp, positions, zero_coord) + end if + deallocate(zero_coord) - if(present(gp)) then - gp = lgp - call incref(gp) - end if + if(present(gp)) then + gp = lgp + call incref(gp) + end if - ewrite(1, *) "Exiting calculate_geostrophic_pressure_options" + ewrite(1, *) "Exiting calculate_geostrophic_pressure_options" - end subroutine calculate_geostrophic_pressure_options + end subroutine calculate_geostrophic_pressure_options - function do_assemble_matrix(state) - !!< Return whether the LHS GeostrophicPressure matrix should be assembled + function do_assemble_matrix(state) + !!< Return whether the LHS GeostrophicPressure matrix should be assembled - type(state_type), intent(in) :: state + type(state_type), intent(in) :: state - logical :: do_assemble_matrix + logical :: do_assemble_matrix - if(.not. has_csr_matrix(state, gp_m_name) & + if(.not. has_csr_matrix(state, gp_m_name) & & .or. eventcount(EVENT_MESH_MOVEMENT) /= last_mesh_movement) then - do_assemble_matrix = .true. - else - do_assemble_matrix = .false. - end if - - end function do_assemble_matrix - - subroutine calculate_geostrophic_pressure(state, gp, & - & velocity_name, assemble_matrix, include_buoyancy, include_coriolis, reference_node) - !!< Calculate the GeostrophicPressure field. The field is inserted into - !!< state, and optionally returned through the "gp" argument. - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: gp - !! name of velocity field used in coriolis: - character(len = *), optional, intent(in) :: velocity_name - !! If present and .false., turn off LHS matrix assembly - logical, optional, intent(in) :: assemble_matrix - !! If present and .false., turn off buoyancy in the RHS - logical, optional, intent(in) :: include_buoyancy - !! If present and .false., turn off Coriolis in the RHS - logical, optional, intent(in) :: include_coriolis - !! Reference node - integer, optional, intent(in) :: reference_node - - type(csr_matrix) :: gp_m - type(scalar_field) :: gp_rhs - - ! Step 1: Initialise - call initialise_geostrophic_pressure(gp, gp_m, gp_rhs, state) - call initialise_assembly_options(a_velocity_name = velocity_name, & + do_assemble_matrix = .true. + else + do_assemble_matrix = .false. + end if + + end function do_assemble_matrix + + subroutine calculate_geostrophic_pressure(state, gp, & + & velocity_name, assemble_matrix, include_buoyancy, include_coriolis, reference_node) + !!< Calculate the GeostrophicPressure field. The field is inserted into + !!< state, and optionally returned through the "gp" argument. + + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: gp + !! name of velocity field used in coriolis: + character(len = *), optional, intent(in) :: velocity_name + !! If present and .false., turn off LHS matrix assembly + logical, optional, intent(in) :: assemble_matrix + !! If present and .false., turn off buoyancy in the RHS + logical, optional, intent(in) :: include_buoyancy + !! If present and .false., turn off Coriolis in the RHS + logical, optional, intent(in) :: include_coriolis + !! Reference node + integer, optional, intent(in) :: reference_node + + type(csr_matrix) :: gp_m + type(scalar_field) :: gp_rhs + + ! Step 1: Initialise + call initialise_geostrophic_pressure(gp, gp_m, gp_rhs, state) + call initialise_assembly_options(a_velocity_name = velocity_name, & & a_assemble_matrix = assemble_matrix, & & a_include_buoyancy = include_buoyancy, & & a_include_coriolis = include_coriolis, & & a_reference_node = reference_node) - ! Step 2: Assemble - select case(continuity(gp)) - case(0) - call assemble_geostrophic_pressure_cg(gp_rhs, state, gp_m, gp) - case(-1) - FLExit("DG GeostrophicPressure is not available") - case default - ewrite(-1, "(a,i0)") "For mesh continuity ", continuity(gp) - FLAbort("Unrecognised mesh continuity") - end select - - ! Step 3: Solve - call solve_geostrophic_pressure(gp_m, gp_rhs, gp, state) - - ! Step 4: Drop references - call deallocate(gp_m) - call deallocate(gp_rhs) - - ! Remove RHS from state - call remove_scalar_field(state, gp_rhs_name) - - end subroutine calculate_geostrophic_pressure - - subroutine initialise_assembly_options(a_velocity_name, a_assemble_matrix, a_include_buoyancy, a_include_coriolis, a_reference_node) - !!< Initialise assemble options. Arguments are preceded with "a_" to - !!< distinguish them from the module variables - - !! name of velocity field used in coriolis: - character(len = *), optional, intent(in) :: a_velocity_name - !! If present and .false., turn off LHS matrix assembly - logical, optional, intent(in) :: a_assemble_matrix - !! If present and .false., turn off buoyancy in the RHS - logical, optional, intent(in) :: a_include_buoyancy - !! If present and .false., turn off Coriolis in the RHS - logical, optional, intent(in) :: a_include_coriolis - !! Reference node - integer, optional, intent(in) :: a_reference_node - - if(present(a_velocity_name)) then - velocity_name = a_velocity_name - else - velocity_name = "NonlinearVelocity" - end if - assemble_matrix = .not. present_and_false(a_assemble_matrix) - include_buoyancy = .not. present_and_false(a_include_buoyancy) - include_coriolis = .not. present_and_false(a_include_coriolis) - if(present(a_reference_node)) then - reference_node = a_reference_node - else - reference_node = 0 - end if - - end subroutine initialise_assembly_options - - subroutine initialise_geostrophic_pressure(gp, gp_m, gp_rhs, state) - !!< Allocate / extract GeostrophicPressure variables. gp_m and gp_rhs take - !!< references in this routine and, if new objects are constructed, are - !!< inserted into state. - - type(scalar_field), target, intent(in) :: gp - type(csr_matrix), intent(out) :: gp_m - type(scalar_field), intent(out) :: gp_rhs - type(state_type), intent(inout) :: state - - integer :: stat - type(csr_sparsity), pointer :: gp_sparsity - type(mesh_type), pointer :: gp_mesh - - gp_mesh => gp%mesh - - ! LHS Matrix - gp_m = extract_csr_matrix(state, gp_m_name, stat = stat) - if(stat == 0) then - call incref(gp_m) - else - ! Matrix sparsity - gp_sparsity => get_csr_sparsity_firstorder(state, gp_mesh, gp_mesh) - - call allocate(gp_m, gp_sparsity, name = gp_m_name) - call insert(state, gp_m, gp_m%name) - end if - - ! RHS - gp_rhs = extract_scalar_field(state, gp_rhs_name, stat = stat) - if(stat == 0) then - call incref(gp_rhs) - else - call allocate(gp_rhs, gp_mesh, gp_rhs_name) - call insert(state, gp_rhs, gp_rhs%name) - end if - - end subroutine initialise_geostrophic_pressure - - subroutine assemble_geostrophic_pressure_cg(gp_rhs, state, gp_m, gp) - !!< Assemble the elliptic equation for GeostrophicPressure - - type(scalar_field), intent(inout) :: gp_rhs - type(state_type), intent(inout) :: state - type(csr_matrix), intent(inout) :: gp_m - type(scalar_field), intent(in) :: gp - - integer :: i, stat - real :: gravity_magnitude - logical :: have_density, have_hp, have_hpg - type(scalar_field), pointer :: buoyancy, density, hp - type(scalar_field), target :: dummy_scalar - type(vector_field), pointer :: gravity, hpg, positions, velocity - type(vector_field), target :: dummy_vector - - ewrite(1, *) "In assemble_geostrophic_pressure_cg" - - ewrite(2, *) "Assemble LHS matrix? ", assemble_matrix - ewrite(2, *) "Include buoyancy? ", include_buoyancy - ewrite(2, *) "Include Coriolis? ", include_coriolis - - if(.not. include_buoyancy .and. .not. include_coriolis) then - ewrite(0, *) "Warning: Assembling GeostrophicPressure equation with no RHS terms" - if(.not. assemble_matrix) then - ewrite(0, *) "Warning: Not assembling LHS matrix either!" - end if - end if - - if((.not. any(mesh_dim(gp_rhs) == (/2, 3/))).and.include_coriolis) then - FLExit("GeostrophicPressure requires a 2 or 3 dimensional mesh when including coriolis.") - end if - - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mesh_dim(gp_rhs)) - assert(ele_count(positions) == ele_count(gp_rhs)) - - density => extract_scalar_field(state, "Density", stat = stat) - have_density = stat == 0 - if(have_density) then - assert(ele_count(density) == ele_count(gp_rhs)) - - ewrite_minmax(density) - else - density => dummy_scalar - - ewrite(2, *) "No density" - end if - - if(include_buoyancy) then - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - - buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") - assert(ele_count(buoyancy) == ele_count(gp_rhs)) - ewrite_minmax(buoyancy) - - gravity => extract_vector_field(state, "GravityDirection") - assert(gravity%dim == mesh_dim(gp_rhs)) - assert(ele_count(gravity) == ele_count(gp_rhs)) - - hp => extract_scalar_field(state, hp_name, stat = stat) + ! Step 2: Assemble + select case(continuity(gp)) + case(0) + call assemble_geostrophic_pressure_cg(gp_rhs, state, gp_m, gp) + case(-1) + FLExit("DG GeostrophicPressure is not available") + case default + ewrite(-1, "(a,i0)") "For mesh continuity ", continuity(gp) + FLAbort("Unrecognised mesh continuity") + end select + + ! Step 3: Solve + call solve_geostrophic_pressure(gp_m, gp_rhs, gp, state) + + ! Step 4: Drop references + call deallocate(gp_m) + call deallocate(gp_rhs) + + ! Remove RHS from state + call remove_scalar_field(state, gp_rhs_name) + + end subroutine calculate_geostrophic_pressure + + subroutine initialise_assembly_options(a_velocity_name, a_assemble_matrix, a_include_buoyancy, a_include_coriolis, a_reference_node) + !!< Initialise assemble options. Arguments are preceded with "a_" to + !!< distinguish them from the module variables + + !! name of velocity field used in coriolis: + character(len = *), optional, intent(in) :: a_velocity_name + !! If present and .false., turn off LHS matrix assembly + logical, optional, intent(in) :: a_assemble_matrix + !! If present and .false., turn off buoyancy in the RHS + logical, optional, intent(in) :: a_include_buoyancy + !! If present and .false., turn off Coriolis in the RHS + logical, optional, intent(in) :: a_include_coriolis + !! Reference node + integer, optional, intent(in) :: a_reference_node + + if(present(a_velocity_name)) then + velocity_name = a_velocity_name + else + velocity_name = "NonlinearVelocity" + end if + assemble_matrix = .not. present_and_false(a_assemble_matrix) + include_buoyancy = .not. present_and_false(a_include_buoyancy) + include_coriolis = .not. present_and_false(a_include_coriolis) + if(present(a_reference_node)) then + reference_node = a_reference_node + else + reference_node = 0 + end if + + end subroutine initialise_assembly_options + + subroutine initialise_geostrophic_pressure(gp, gp_m, gp_rhs, state) + !!< Allocate / extract GeostrophicPressure variables. gp_m and gp_rhs take + !!< references in this routine and, if new objects are constructed, are + !!< inserted into state. + + type(scalar_field), target, intent(in) :: gp + type(csr_matrix), intent(out) :: gp_m + type(scalar_field), intent(out) :: gp_rhs + type(state_type), intent(inout) :: state + + integer :: stat + type(csr_sparsity), pointer :: gp_sparsity + type(mesh_type), pointer :: gp_mesh + + gp_mesh => gp%mesh + + ! LHS Matrix + gp_m = extract_csr_matrix(state, gp_m_name, stat = stat) if(stat == 0) then - ewrite(2, *) "Using " // hp_name - have_hp = .true. - ewrite_minmax(hp) + call incref(gp_m) else - ewrite(2, *) "No " // hp_name - have_hp = .false. - hp => dummy_scalar + ! Matrix sparsity + gp_sparsity => get_csr_sparsity_firstorder(state, gp_mesh, gp_mesh) + + call allocate(gp_m, gp_sparsity, name = gp_m_name) + call insert(state, gp_m, gp_m%name) end if - hpg => extract_vector_field(state, hpg_name, stat = stat) + ! RHS + gp_rhs = extract_scalar_field(state, gp_rhs_name, stat = stat) if(stat == 0) then - ewrite(2, *) "Using " // hpg_name - have_hpg = .true. - ewrite_minmax(hpg) + call incref(gp_rhs) else - ewrite(2, *) "No " // hpg_name - have_hpg = .false. - hpg => dummy_vector - end if - - assert(.not. have_hp .or. .not. have_hpg) - else - gravity_magnitude = 0.0 - gravity => dummy_vector - buoyancy => dummy_scalar - hp => dummy_scalar - hpg => dummy_vector - have_hp = .false. - have_hpg = .false. - end if - - if(include_coriolis) then - velocity => extract_vector_field(state, velocity_name) - assert(velocity%dim == mesh_dim(gp_rhs)) - assert(ele_count(velocity) == ele_count(gp_rhs)) + call allocate(gp_rhs, gp_mesh, gp_rhs_name) + call insert(state, gp_rhs, gp_rhs%name) + end if - ewrite_minmax(velocity) - else - velocity => dummy_vector - end if - - if(assemble_matrix) then - call zero(gp_m) - end if - call zero(gp_rhs) - - do i = 1, ele_count(gp_rhs) - if(.not. assemble_ele(gp_rhs, i)) cycle - - call assemble_geostrophic_pressure_element_cg(i, positions, & - & density, have_density, & - & gravity_magnitude, buoyancy, gravity, velocity, & - & hp, have_hp, hpg, have_hpg, & - & gp_m, gp_rhs) - end do - - ! Set the pressure level to zero at the reference node of the first - ! process (should be called by all processes though). This needs to be done - ! every time, to zero the rhs. - call set_geostrophic_pressure_reference_node(gp_m, gp_rhs) - - ! Set any strong dirichlet bc specified - call apply_dirichlet_conditions(gp_m, gp_rhs, gp) - - ewrite_minmax(gp_rhs) - - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - - ewrite(1, *) "Exiting assemble_geostrophic_pressure_cg" - - end subroutine assemble_geostrophic_pressure_cg - - subroutine set_geostrophic_pressure_reference_node(gp_m, gp_rhs) - !!< Set the GeostrophicPressure reference node - - type(csr_matrix), intent(inout) :: gp_m - type(scalar_field), intent(inout) :: gp_rhs - - if(reference_node > 0) call set_reference_node(gp_m, reference_node, gp_rhs) - - end subroutine set_geostrophic_pressure_reference_node - - subroutine assemble_geostrophic_pressure_element_cg(ele, positions, & - & density, have_density, & - & gravity_magnitude, buoyancy, gravity, velocity, & - & hp, have_hp, hpg, have_hpg, & - & gp_m, gp_rhs) - !!< Assemble the element-wise contribution to the elliptic equation for - !!< GeostrophicPressure - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: density - logical, intent(in) :: have_density - real, intent(in) :: gravity_magnitude - type(scalar_field), intent(in) :: buoyancy - type(vector_field), intent(in) :: gravity - type(vector_field), intent(in) :: velocity - type(scalar_field), intent(in) :: hp - logical, intent(in) :: have_hp - type(vector_field), intent(in) :: hpg - logical, intent(in) :: have_hpg - type(csr_matrix), intent(inout) :: gp_m - type(scalar_field), intent(inout) :: gp_rhs - - integer :: dim - integer, dimension(:), pointer :: gp_element_nodes - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(positions%dim, ele_ngi(positions, ele)) :: vec_gi - real, dimension(ele_loc(gp_rhs, ele), ele_ngi(positions, ele), positions%dim) :: dshape - type(element_type), pointer :: gp_shape - - dim = mesh_dim(gp_rhs) - gp_shape => ele_shape(gp_rhs, ele) - gp_element_nodes => ele_nodes(gp_rhs, ele) - - call transform_to_physical(positions, ele, gp_shape, & - & dshape = dshape, detwei = detwei) + end subroutine initialise_geostrophic_pressure - if(assemble_matrix) then - ! LHS matrix - ! / - ! | grad N_A dot grad N_B dV - ! / - call addto(gp_m, gp_element_nodes, gp_element_nodes, dshape_dot_dshape(dshape, dshape, detwei)) - end if + subroutine assemble_geostrophic_pressure_cg(gp_rhs, state, gp_m, gp) + !!< Assemble the elliptic equation for GeostrophicPressure - if(include_coriolis) then - ! RHS Coriolis term - ! / - ! | grad N_A dot (rho f k x u) dV - ! / + type(scalar_field), intent(inout) :: gp_rhs + type(state_type), intent(inout) :: state + type(csr_matrix), intent(inout) :: gp_m + type(scalar_field), intent(in) :: gp - ! coriolis only works in 2 (horizontal) or 3 dimensions - ! and the rotation axis is always in the z direction - vec_gi( U_, :) = ele_val_at_quad( velocity, ele, dim=V_) - vec_gi( V_, :) = -ele_val_at_quad( velocity, ele, dim=U_) - if(dim==3) vec_gi( W_,:)=0.0 + integer :: i, stat + real :: gravity_magnitude + logical :: have_density, have_hp, have_hpg + type(scalar_field), pointer :: buoyancy, density, hp + type(scalar_field), target :: dummy_scalar + type(vector_field), pointer :: gravity, hpg, positions, velocity + type(vector_field), target :: dummy_vector - if(have_density) then - vec_gi = vec_gi * spread(two_omega(ele_val_at_quad(positions, ele)) * ele_val_at_quad(density, ele), 1, dim) - else - vec_gi = vec_gi * spread(two_omega(ele_val_at_quad(positions, ele)), 1, dim) + ewrite(1, *) "In assemble_geostrophic_pressure_cg" + + ewrite(2, *) "Assemble LHS matrix? ", assemble_matrix + ewrite(2, *) "Include buoyancy? ", include_buoyancy + ewrite(2, *) "Include Coriolis? ", include_coriolis + + if(.not. include_buoyancy .and. .not. include_coriolis) then + ewrite(0, *) "Warning: Assembling GeostrophicPressure equation with no RHS terms" + if(.not. assemble_matrix) then + ewrite(0, *) "Warning: Not assembling LHS matrix either!" + end if end if - else - vec_gi = 0.0 - end if - if(include_buoyancy) then - ! RHS buoyancy term - ! / - ! | grad N_A dot buoyancy dV - ! / + if((.not. any(mesh_dim(gp_rhs) == (/2, 3/))).and.include_coriolis) then + FLExit("GeostrophicPressure requires a 2 or 3 dimensional mesh when including coriolis.") + end if - vec_gi = vec_gi + ele_val_at_quad(gravity, ele) * spread(ele_val_at_quad(buoyancy, ele) * gravity_magnitude, 1, dim) - end if + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mesh_dim(gp_rhs)) + assert(ele_count(positions) == ele_count(gp_rhs)) - if(have_hp) then - ! Precondition using HydrostaticPressure - call add_hp_ele - else if(have_hpg) then - ! Precondition using HydrostaticPressureGradient - vec_gi = vec_gi - ele_val_at_quad(hpg, ele) - end if + density => extract_scalar_field(state, "Density", stat = stat) + have_density = stat == 0 + if(have_density) then + assert(ele_count(density) == ele_count(gp_rhs)) - call addto(gp_rhs, gp_element_nodes, dshape_dot_vector_rhs(dshape, vec_gi, detwei)) + ewrite_minmax(density) + else + density => dummy_scalar - contains + ewrite(2, *) "No density" + end if - subroutine add_hp_ele + if(include_buoyancy) then + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + + buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") + assert(ele_count(buoyancy) == ele_count(gp_rhs)) + ewrite_minmax(buoyancy) + + gravity => extract_vector_field(state, "GravityDirection") + assert(gravity%dim == mesh_dim(gp_rhs)) + assert(ele_count(gravity) == ele_count(gp_rhs)) + + hp => extract_scalar_field(state, hp_name, stat = stat) + if(stat == 0) then + ewrite(2, *) "Using " // hp_name + have_hp = .true. + ewrite_minmax(hp) + else + ewrite(2, *) "No " // hp_name + have_hp = .false. + hp => dummy_scalar + end if + + hpg => extract_vector_field(state, hpg_name, stat = stat) + if(stat == 0) then + ewrite(2, *) "Using " // hpg_name + have_hpg = .true. + ewrite_minmax(hpg) + else + ewrite(2, *) "No " // hpg_name + have_hpg = .false. + hpg => dummy_vector + end if + + assert(.not. have_hp .or. .not. have_hpg) + else + gravity_magnitude = 0.0 + gravity => dummy_vector + buoyancy => dummy_scalar + hp => dummy_scalar + hpg => dummy_vector + have_hp = .false. + have_hpg = .false. + end if - real, dimension(ele_loc(hp, ele), ele_ngi(positions, ele), positions%dim) :: hp_dshape - type(element_type), pointer :: hp_shape + if(include_coriolis) then + velocity => extract_vector_field(state, velocity_name) + assert(velocity%dim == mesh_dim(gp_rhs)) + assert(ele_count(velocity) == ele_count(gp_rhs)) - hp_shape => ele_shape(hp, ele) - if(hp_shape == gp_shape) then - hp_dshape = dshape + ewrite_minmax(velocity) else - call transform_to_physical(positions, ele, hp_shape, & - & dshape = hp_dshape) + velocity => dummy_vector end if - vec_gi = vec_gi - ele_grad_at_quad(hp, ele, hp_dshape) + if(assemble_matrix) then + call zero(gp_m) + end if + call zero(gp_rhs) - end subroutine add_hp_ele + do i = 1, ele_count(gp_rhs) + if(.not. assemble_ele(gp_rhs, i)) cycle - end subroutine assemble_geostrophic_pressure_element_cg + call assemble_geostrophic_pressure_element_cg(i, positions, & + & density, have_density, & + & gravity_magnitude, buoyancy, gravity, velocity, & + & hp, have_hp, hpg, have_hpg, & + & gp_m, gp_rhs) + end do - subroutine solve_geostrophic_pressure(gp_m, gp_rhs, gp, state) - !!< Solve the elliptic equation for GeostrophicPressure + ! Set the pressure level to zero at the reference node of the first + ! process (should be called by all processes though). This needs to be done + ! every time, to zero the rhs. + call set_geostrophic_pressure_reference_node(gp_m, gp_rhs) - type(csr_matrix), intent(in) :: gp_m - type(scalar_field), intent(in) :: gp_rhs - type(scalar_field), intent(inout) :: gp - type(state_type), intent(inout) :: state + ! Set any strong dirichlet bc specified + call apply_dirichlet_conditions(gp_m, gp_rhs, gp) - call petsc_solve(gp, gp_m, gp_rhs, state) + ewrite_minmax(gp_rhs) - ewrite_minmax(gp) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end subroutine solve_geostrophic_pressure + ewrite(1, *) "Exiting assemble_geostrophic_pressure_cg" - subroutine set_zero_point(s_field, positions, coord) - !!< Enforce a value of zero at the given coordinate + end subroutine assemble_geostrophic_pressure_cg - type(scalar_field), intent(inout) :: s_field - type(vector_field), intent(inout) :: positions - real, dimension(positions%dim) :: coord + subroutine set_geostrophic_pressure_reference_node(gp_m, gp_rhs) + !!< Set the GeostrophicPressure reference node - integer :: ele - real :: zp_val - real, dimension(ele_loc(positions, 1)) :: local_coord + type(csr_matrix), intent(inout) :: gp_m + type(scalar_field), intent(inout) :: gp_rhs - call picker_inquire(positions, coord, ele, local_coord = local_coord) + if(reference_node > 0) call set_reference_node(gp_m, reference_node, gp_rhs) - if(ele > 0) then - zp_val = eval_field(ele, s_field, local_coord) - else - zp_val = 0.0 - end if - call allsum(zp_val) - ewrite(2, *) "Zero point offet: ", zp_val + end subroutine set_geostrophic_pressure_reference_node - call addto(s_field, -zp_val) + subroutine assemble_geostrophic_pressure_element_cg(ele, positions, & + & density, have_density, & + & gravity_magnitude, buoyancy, gravity, velocity, & + & hp, have_hp, hpg, have_hpg, & + & gp_m, gp_rhs) + !!< Assemble the element-wise contribution to the elliptic equation for + !!< GeostrophicPressure + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: density + logical, intent(in) :: have_density + real, intent(in) :: gravity_magnitude + type(scalar_field), intent(in) :: buoyancy + type(vector_field), intent(in) :: gravity + type(vector_field), intent(in) :: velocity + type(scalar_field), intent(in) :: hp + logical, intent(in) :: have_hp + type(vector_field), intent(in) :: hpg + logical, intent(in) :: have_hpg + type(csr_matrix), intent(inout) :: gp_m + type(scalar_field), intent(inout) :: gp_rhs + + integer :: dim + integer, dimension(:), pointer :: gp_element_nodes + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(positions%dim, ele_ngi(positions, ele)) :: vec_gi + real, dimension(ele_loc(gp_rhs, ele), ele_ngi(positions, ele), positions%dim) :: dshape + type(element_type), pointer :: gp_shape - end subroutine set_zero_point + dim = mesh_dim(gp_rhs) + gp_shape => ele_shape(gp_rhs, ele) + gp_element_nodes => ele_nodes(gp_rhs, ele) - subroutine subtract_geostrophic_pressure_gradient(mom_rhs, state) - !!< Subtract the GeostrophicPressure gradient from the momentum equation - !!< RHS. Based on David's Geostrophic_Pressure, and some parts of Assnav / - !!< geoeli1p. - !!< Replaces geobal = -20 and -21. + call transform_to_physical(positions, ele, gp_shape, & + & dshape = dshape, detwei = detwei) - type(vector_field), intent(inout) :: mom_rhs - type(state_type), intent(inout) :: state + if(assemble_matrix) then + ! LHS matrix + ! / + ! | grad N_A dot grad N_B dV + ! / + call addto(gp_m, gp_element_nodes, gp_element_nodes, dshape_dot_dshape(dshape, dshape, detwei)) + end if - integer :: i - type(vector_field), pointer :: positions - type(scalar_field), pointer :: gp + if(include_coriolis) then + ! RHS Coriolis term + ! / + ! | grad N_A dot (rho f k x u) dV + ! / + + ! coriolis only works in 2 (horizontal) or 3 dimensions + ! and the rotation axis is always in the z direction + vec_gi( U_, :) = ele_val_at_quad( velocity, ele, dim=V_) + vec_gi( V_, :) = -ele_val_at_quad( velocity, ele, dim=U_) + if(dim==3) vec_gi( W_,:)=0.0 + + if(have_density) then + vec_gi = vec_gi * spread(two_omega(ele_val_at_quad(positions, ele)) * ele_val_at_quad(density, ele), 1, dim) + else + vec_gi = vec_gi * spread(two_omega(ele_val_at_quad(positions, ele)), 1, dim) + end if + else + vec_gi = 0.0 + end if - ewrite(1, *) "In subtract_geostrophic_pressure_gradient" + if(include_buoyancy) then + ! RHS buoyancy term + ! / + ! | grad N_A dot buoyancy dV + ! / - gp => extract_scalar_field(state, gp_name) + vec_gi = vec_gi + ele_val_at_quad(gravity, ele) * spread(ele_val_at_quad(buoyancy, ele) * gravity_magnitude, 1, dim) + end if - ! Apply to momentum equation - assert(ele_count(gp) == ele_count(mom_rhs)) + if(have_hp) then + ! Precondition using HydrostaticPressure + call add_hp_ele + else if(have_hpg) then + ! Precondition using HydrostaticPressureGradient + vec_gi = vec_gi - ele_val_at_quad(hpg, ele) + end if - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mom_rhs%dim) - assert(ele_count(positions) == ele_count(mom_rhs)) + call addto(gp_rhs, gp_element_nodes, dshape_dot_vector_rhs(dshape, vec_gi, detwei)) - ewrite_minmax(mom_rhs) + contains - do i = 1, ele_count(mom_rhs) - if((continuity(mom_rhs)>=0).or.(element_owned(mom_rhs, i))) then - call subtract_given_geostrophic_pressure_gradient_element(i, positions, gp, mom_rhs) - end if - end do + subroutine add_hp_ele - ewrite_minmax(mom_rhs) + real, dimension(ele_loc(hp, ele), ele_ngi(positions, ele), positions%dim) :: hp_dshape + type(element_type), pointer :: hp_shape - ewrite(1, *) "Exiting subtract_geostrophic_pressure_gradient" + hp_shape => ele_shape(hp, ele) + if(hp_shape == gp_shape) then + hp_dshape = dshape + else + call transform_to_physical(positions, ele, hp_shape, & + & dshape = hp_dshape) + end if - end subroutine subtract_geostrophic_pressure_gradient + vec_gi = vec_gi - ele_grad_at_quad(hp, ele, hp_dshape) - subroutine subtract_given_geostrophic_pressure_gradient_element(ele, positions, gp, mom_rhs) - !!< Subtract the element-wise contribution of the GeostrophicPressure - !!< gradient from the momentum equation RHS + end subroutine add_hp_ele - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: gp - type(vector_field), intent(inout) :: mom_rhs + end subroutine assemble_geostrophic_pressure_element_cg - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(gp, ele), ele_ngi(gp, ele), mom_rhs%dim) :: dshape + subroutine solve_geostrophic_pressure(gp_m, gp_rhs, gp, state) + !!< Solve the elliptic equation for GeostrophicPressure - assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) - assert(ele_ngi(gp, ele) == ele_ngi(mom_rhs, ele)) + type(csr_matrix), intent(in) :: gp_m + type(scalar_field), intent(in) :: gp_rhs + type(scalar_field), intent(inout) :: gp + type(state_type), intent(inout) :: state - call transform_to_physical(positions, ele, ele_shape(gp, ele), & - & dshape = dshape, detwei = detwei) + call petsc_solve(gp, gp_m, gp_rhs, state) - ! / - ! | -N_A grad gp dV - ! / - call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_grad_at_quad(gp, ele, dshape), detwei)) - - end subroutine subtract_given_geostrophic_pressure_gradient_element - - subroutine allocate_cmc_matrices(matrices, state, field, p, option_path, bcfield, gp, add_cmc) - !!< Allocate cmc_matrices. By default, this assembles the divergence C^T - !!< and Laplacian C^T M^-1 C matrices. - - type(cmc_matrices), intent(out) :: matrices - type(state_type), intent(inout) :: state - type(vector_field), target, intent(inout) :: field - type(scalar_field), target, intent(inout) :: p - character(len = *), optional, intent(in) :: option_path - type(vector_field), optional, target, intent(in) :: bcfield - !! If present, additionally assembles geopressure preconditioner matrices - type(scalar_field), optional, intent(inout) :: gp - !! If present and .false., do not assemble CMC itself - logical, optional, intent(in) :: add_cmc - - integer :: dim, i, stat - type(csr_matrix) :: inverse_mass, mass - type(csr_sparsity) :: mass_sparsity - type(csr_sparsity), pointer :: ct_sparsity - type(scalar_field) :: inverse_masslump - type(vector_field), pointer :: lbcfield, positions - - ewrite(1, *) "In allocate_cmc_matrices" - - if(present(bcfield)) then - assert(bcfield%mesh == field%mesh) - lbcfield => bcfield - else - lbcfield => field - end if - if(present(option_path)) then - matrices%p_option_path = option_path - else - matrices%p_option_path = complete_field_path(p%option_path, stat = stat) - end if - ewrite(2, *) "Option path: " // trim(matrices%p_option_path) - - dim = field%dim - matrices%u_mesh = field%mesh - matrices%p_mesh = p%mesh - call incref(matrices%u_mesh) - call incref(matrices%p_mesh) - assert(continuity(matrices%p_mesh) == 0) - - ewrite(2, *) "Decomposed field: ", trim(field%name) - ewrite(2, *) "On mesh: ", trim(matrices%u_mesh%name) - ewrite(2, *) "Scalar potential mesh: ", trim(matrices%p_mesh%name) - ewrite(2, *) "Boundary conditions field: ", trim(lbcfield%name) - - ct_sparsity => get_csr_sparsity_firstorder(state, matrices%p_mesh, matrices%u_mesh) - allocate(matrices%ct_m) - call allocate(matrices%ct_m, ct_sparsity, blocks = (/1, dim/), name = "CT") - call allocate(matrices%ct_rhs, matrices%p_mesh, "CTRHS") - - ! Options - if(have_option(trim(matrices%p_option_path) // & - & "/spatial_discretisation/mass")) then - matrices%lump_mass = have_option(trim(matrices%p_option_path) // & - & "/spatial_discretisation/mass/lump_mass") - matrices%mass_option_path = trim(matrices%p_option_path) // "/spatial_discretisation/mass" - else if(have_option(trim(matrices%p_option_path) // & - & "/mass")) then - matrices%lump_mass = have_option(trim(matrices%p_option_path) // & - & "/mass/lump_mass") - matrices%mass_option_path = trim(matrices%p_option_path) // "/mass" - else - ! Choose sensible defaults if mass options are not supplied - select case(continuity(field)) - case(-1) - matrices%lump_mass = .false. - case(0) - matrices%lump_mass = .true. - case default - ewrite(-1, *) "For mesh continuity: ", continuity(field) - FLAbort("Unrecognised mesh continuity") - end select - matrices%mass_option_path = empty_path - end if - matrices%integrate_by_parts = have_option(trim(matrices%p_option_path) // & - & "/spatial_discretisation/continuous_galerkin/integrate_divergence_by_parts") & - & .or. have_option(trim(matrices%p_option_path) // & - & "/continuous_galerkin/integrate_divergence_by_parts") & - & .or. have_option(trim(matrices%p_option_path) // & - & "/integrate_divergence_by_parts") + ewrite_minmax(gp) - ewrite(2, *) "Lump mass? ", matrices%lump_mass - ewrite(2, *) "Integrate divergence by parts? ", matrices%integrate_by_parts + end subroutine solve_geostrophic_pressure - ! Assemble the matrices + subroutine set_zero_point(s_field, positions, coord) + !!< Enforce a value of zero at the given coordinate - if(matrices%lump_mass) then - call allocate(inverse_masslump, matrices%u_mesh, "InverseLumpedMass") - call assemble_divergence_matrix_cg(matrices%ct_m, state, ct_rhs = matrices%ct_rhs, & - test_mesh = matrices%p_mesh, field = lbcfield, & - grad_mass_lumped = inverse_masslump, option_path = matrices%p_option_path) + type(scalar_field), intent(inout) :: s_field + type(vector_field), intent(inout) :: positions + real, dimension(positions%dim) :: coord - call invert(inverse_masslump) - call allocate(matrices%inverse_masslump_v, dim, inverse_masslump%mesh, "InverseLumpedMass") - do i = 1, dim - call set(matrices%inverse_masslump_v, i, inverse_masslump) - end do - call deallocate(inverse_masslump) + integer :: ele + real :: zp_val + real, dimension(ele_loc(positions, 1)) :: local_coord + + call picker_inquire(positions, coord, ele, local_coord = local_coord) + + if(ele > 0) then + zp_val = eval_field(ele, s_field, local_coord) + else + zp_val = 0.0 + end if + call allsum(zp_val) + ewrite(2, *) "Zero point offet: ", zp_val + + call addto(s_field, -zp_val) + + end subroutine set_zero_point + + subroutine subtract_geostrophic_pressure_gradient(mom_rhs, state) + !!< Subtract the GeostrophicPressure gradient from the momentum equation + !!< RHS. Based on David's Geostrophic_Pressure, and some parts of Assnav / + !!< geoeli1p. + !!< Replaces geobal = -20 and -21. + + type(vector_field), intent(inout) :: mom_rhs + type(state_type), intent(inout) :: state + + integer :: i + type(vector_field), pointer :: positions + type(scalar_field), pointer :: gp + + ewrite(1, *) "In subtract_geostrophic_pressure_gradient" + + gp => extract_scalar_field(state, gp_name) + + ! Apply to momentum equation + assert(ele_count(gp) == ele_count(mom_rhs)) - call apply_dirichlet_conditions_inverse_mass(matrices%inverse_masslump_v, lbcfield) - else positions => extract_vector_field(state, "Coordinate") - call assemble_divergence_matrix_cg(matrices%ct_m, state, ct_rhs = matrices%ct_rhs, & - test_mesh = matrices%p_mesh, field = lbcfield, & - option_path = matrices%p_option_path) - - select case(continuity(matrices%u_mesh)) - case(0) - mass_sparsity = get_csr_sparsity_firstorder(state, matrices%u_mesh, matrices%u_mesh) - call allocate(matrices%mass_b,mass_sparsity, (/dim, dim/), diagonal = .true., name = "Mass") - mass = block(matrices%mass_b, 1, 1) - call compute_mass(positions, matrices%u_mesh, mass) - do i = 2, dim - matrices%mass_b%val(i, i)%ptr = mass%val - end do - !call apply_dirichlet_conditions_mass(matrices%mass_b, lbcfield) - case(-1) - mass_sparsity = make_sparsity_dg_mass(matrices%u_mesh) - call allocate(matrices%inverse_mass_b, mass_sparsity, (/dim, dim/), diagonal = .true., name = "InverseMass") - call deallocate(mass_sparsity) - assert(dim > 0) - inverse_mass = block(matrices%inverse_mass_b, 1, 1) - do i = 1, ele_count(field) - call assemble_mass_ele(i, matrices%u_mesh, positions, inverse_mass = inverse_mass) - end do - do i = 2, dim - matrices%inverse_mass_b%val(i, i)%ptr = inverse_mass%val - end do - call apply_dirichlet_conditions_inverse_mass(matrices%inverse_mass_b, lbcfield) - case default - ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) - FLAbort("Unrecognised mesh continuity") - end select - end if + assert(positions%dim == mom_rhs%dim) + assert(ele_count(positions) == ele_count(mom_rhs)) - if(present(gp)) then - call add_geopressure_matrices(state, gp%mesh, matrices) - end if + ewrite_minmax(mom_rhs) - if(.not. present_and_false(add_cmc)) then - call add_cmc_matrix(state, matrices) - end if + do i = 1, ele_count(mom_rhs) + if((continuity(mom_rhs)>=0).or.(element_owned(mom_rhs, i))) then + call subtract_given_geostrophic_pressure_gradient_element(i, positions, gp, mom_rhs) + end if + end do + + ewrite_minmax(mom_rhs) - ewrite(1, *) "Exiting allocate_cmc_matrices" + ewrite(1, *) "Exiting subtract_geostrophic_pressure_gradient" - contains + end subroutine subtract_geostrophic_pressure_gradient + + subroutine subtract_given_geostrophic_pressure_gradient_element(ele, positions, gp, mom_rhs) + !!< Subtract the element-wise contribution of the GeostrophicPressure + !!< gradient from the momentum equation RHS - subroutine assemble_mass_ele(ele, mesh, positions, inverse_mass, masslump) integer, intent(in) :: ele - type(mesh_type), intent(in) :: mesh type(vector_field), intent(in) :: positions - type(csr_matrix), optional, intent(inout) :: inverse_mass - type(scalar_field), optional, intent(inout) :: masslump + type(scalar_field), intent(in) :: gp + type(vector_field), intent(inout) :: mom_rhs - integer, dimension(:), pointer :: nodes - real, dimension(ele_loc(mesh, ele), ele_loc(mesh, ele)) :: little_mass - real, dimension(ele_ngi(mesh, ele)) :: detwei - type(element_type), pointer :: shape + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(gp, ele), ele_ngi(gp, ele), mom_rhs%dim) :: dshape + + assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(gp, ele) == ele_ngi(mom_rhs, ele)) + + call transform_to_physical(positions, ele, ele_shape(gp, ele), & + & dshape = dshape, detwei = detwei) + + ! / + ! | -N_A grad gp dV + ! / + call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_grad_at_quad(gp, ele, dshape), detwei)) + + end subroutine subtract_given_geostrophic_pressure_gradient_element + + subroutine allocate_cmc_matrices(matrices, state, field, p, option_path, bcfield, gp, add_cmc) + !!< Allocate cmc_matrices. By default, this assembles the divergence C^T + !!< and Laplacian C^T M^-1 C matrices. + + type(cmc_matrices), intent(out) :: matrices + type(state_type), intent(inout) :: state + type(vector_field), target, intent(inout) :: field + type(scalar_field), target, intent(inout) :: p + character(len = *), optional, intent(in) :: option_path + type(vector_field), optional, target, intent(in) :: bcfield + !! If present, additionally assembles geopressure preconditioner matrices + type(scalar_field), optional, intent(inout) :: gp + !! If present and .false., do not assemble CMC itself + logical, optional, intent(in) :: add_cmc + + integer :: dim, i, stat + type(csr_matrix) :: inverse_mass, mass + type(csr_sparsity) :: mass_sparsity + type(csr_sparsity), pointer :: ct_sparsity + type(scalar_field) :: inverse_masslump + type(vector_field), pointer :: lbcfield, positions + + ewrite(1, *) "In allocate_cmc_matrices" + + if(present(bcfield)) then + assert(bcfield%mesh == field%mesh) + lbcfield => bcfield + else + lbcfield => field + end if + if(present(option_path)) then + matrices%p_option_path = option_path + else + matrices%p_option_path = complete_field_path(p%option_path, stat = stat) + end if + ewrite(2, *) "Option path: " // trim(matrices%p_option_path) + + dim = field%dim + matrices%u_mesh = field%mesh + matrices%p_mesh = p%mesh + call incref(matrices%u_mesh) + call incref(matrices%p_mesh) + assert(continuity(matrices%p_mesh) == 0) + + ewrite(2, *) "Decomposed field: ", trim(field%name) + ewrite(2, *) "On mesh: ", trim(matrices%u_mesh%name) + ewrite(2, *) "Scalar potential mesh: ", trim(matrices%p_mesh%name) + ewrite(2, *) "Boundary conditions field: ", trim(lbcfield%name) + + ct_sparsity => get_csr_sparsity_firstorder(state, matrices%p_mesh, matrices%u_mesh) + allocate(matrices%ct_m) + call allocate(matrices%ct_m, ct_sparsity, blocks = (/1, dim/), name = "CT") + call allocate(matrices%ct_rhs, matrices%p_mesh, "CTRHS") + + ! Options + if(have_option(trim(matrices%p_option_path) // & + & "/spatial_discretisation/mass")) then + matrices%lump_mass = have_option(trim(matrices%p_option_path) // & + & "/spatial_discretisation/mass/lump_mass") + matrices%mass_option_path = trim(matrices%p_option_path) // "/spatial_discretisation/mass" + else if(have_option(trim(matrices%p_option_path) // & + & "/mass")) then + matrices%lump_mass = have_option(trim(matrices%p_option_path) // & + & "/mass/lump_mass") + matrices%mass_option_path = trim(matrices%p_option_path) // "/mass" + else + ! Choose sensible defaults if mass options are not supplied + select case(continuity(field)) + case(-1) + matrices%lump_mass = .false. + case(0) + matrices%lump_mass = .true. + case default + ewrite(-1, *) "For mesh continuity: ", continuity(field) + FLAbort("Unrecognised mesh continuity") + end select + matrices%mass_option_path = empty_path + end if + matrices%integrate_by_parts = have_option(trim(matrices%p_option_path) // & + & "/spatial_discretisation/continuous_galerkin/integrate_divergence_by_parts") & + & .or. have_option(trim(matrices%p_option_path) // & + & "/continuous_galerkin/integrate_divergence_by_parts") & + & .or. have_option(trim(matrices%p_option_path) // & + & "/integrate_divergence_by_parts") + + ewrite(2, *) "Lump mass? ", matrices%lump_mass + ewrite(2, *) "Integrate divergence by parts? ", matrices%integrate_by_parts + + ! Assemble the matrices - shape => ele_shape(mesh, ele) + if(matrices%lump_mass) then + call allocate(inverse_masslump, matrices%u_mesh, "InverseLumpedMass") + call assemble_divergence_matrix_cg(matrices%ct_m, state, ct_rhs = matrices%ct_rhs, & + test_mesh = matrices%p_mesh, field = lbcfield, & + grad_mass_lumped = inverse_masslump, option_path = matrices%p_option_path) - call transform_to_physical(positions, ele, & - & detwei = detwei) + call invert(inverse_masslump) + call allocate(matrices%inverse_masslump_v, dim, inverse_masslump%mesh, "InverseLumpedMass") + do i = 1, dim + call set(matrices%inverse_masslump_v, i, inverse_masslump) + end do + call deallocate(inverse_masslump) - little_mass = shape_shape(shape, shape, detwei) + call apply_dirichlet_conditions_inverse_mass(matrices%inverse_masslump_v, lbcfield) + else + positions => extract_vector_field(state, "Coordinate") + call assemble_divergence_matrix_cg(matrices%ct_m, state, ct_rhs = matrices%ct_rhs, & + test_mesh = matrices%p_mesh, field = lbcfield, & + option_path = matrices%p_option_path) + + select case(continuity(matrices%u_mesh)) + case(0) + mass_sparsity = get_csr_sparsity_firstorder(state, matrices%u_mesh, matrices%u_mesh) + call allocate(matrices%mass_b,mass_sparsity, (/dim, dim/), diagonal = .true., name = "Mass") + mass = block(matrices%mass_b, 1, 1) + call compute_mass(positions, matrices%u_mesh, mass) + do i = 2, dim + matrices%mass_b%val(i, i)%ptr = mass%val + end do + !call apply_dirichlet_conditions_mass(matrices%mass_b, lbcfield) + case(-1) + mass_sparsity = make_sparsity_dg_mass(matrices%u_mesh) + call allocate(matrices%inverse_mass_b, mass_sparsity, (/dim, dim/), diagonal = .true., name = "InverseMass") + call deallocate(mass_sparsity) + assert(dim > 0) + inverse_mass = block(matrices%inverse_mass_b, 1, 1) + do i = 1, ele_count(field) + call assemble_mass_ele(i, matrices%u_mesh, positions, inverse_mass = inverse_mass) + end do + do i = 2, dim + matrices%inverse_mass_b%val(i, i)%ptr = inverse_mass%val + end do + call apply_dirichlet_conditions_inverse_mass(matrices%inverse_mass_b, lbcfield) + case default + ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) + FLAbort("Unrecognised mesh continuity") + end select + end if - nodes => ele_nodes(mesh, ele) - if(present(masslump)) then - call addto(masslump, nodes, sum(little_mass, 2)) + if(present(gp)) then + call add_geopressure_matrices(state, gp%mesh, matrices) end if - if(present(inverse_mass)) then - assert(continuity(mesh) == -1) - assert(.not. any(is_nan(little_mass))) - call invert(little_mass) - assert(.not. any(is_nan(little_mass))) - call set(inverse_mass, nodes, nodes, little_mass) + + if(.not. present_and_false(add_cmc)) then + call add_cmc_matrix(state, matrices) end if - end subroutine assemble_mass_ele + ewrite(1, *) "Exiting allocate_cmc_matrices" - end subroutine allocate_cmc_matrices + contains - subroutine add_cmc_matrix(state, matrices) - !!< Add CMC to the supplied cmc_matrices + subroutine assemble_mass_ele(ele, mesh, positions, inverse_mass, masslump) + integer, intent(in) :: ele + type(mesh_type), intent(in) :: mesh + type(vector_field), intent(in) :: positions + type(csr_matrix), optional, intent(inout) :: inverse_mass + type(scalar_field), optional, intent(inout) :: masslump - type(state_type), intent(inout) :: state - type(cmc_matrices), intent(inout) :: matrices + integer, dimension(:), pointer :: nodes + real, dimension(ele_loc(mesh, ele), ele_loc(mesh, ele)) :: little_mass + real, dimension(ele_ngi(mesh, ele)) :: detwei + type(element_type), pointer :: shape - logical :: apply_kmk - type(csr_sparsity), pointer :: cmc_sparsity - type(element_type), pointer :: p_shape, u_shape + shape => ele_shape(mesh, ele) - type(scalar_field) :: dummy_p - type(scalar_field), pointer :: masslump - type(state_type) :: lstate - type(vector_field) :: dummy_u - type(vector_field), pointer :: positions + call transform_to_physical(positions, ele, & + & detwei = detwei) - ewrite(1, *) "In add_cmc_matrix" + little_mass = shape_shape(shape, shape, detwei) - if(matrices%have_cmc_m) then - ewrite(1, *) "Exiting add_cmc_matrix" - return - end if - - u_shape => ele_shape(matrices%u_mesh, 1) - p_shape => ele_shape(matrices%p_mesh, 1) - apply_kmk = continuity(matrices%p_mesh) == 0 .and. p_shape%degree == 1 .and. ele_numbering_family(p_shape) == FAMILY_SIMPLEX & - & .and. continuity(matrices%u_mesh) == 0 .and. u_shape%degree == 1 .and. ele_numbering_family(u_shape) == FAMILY_SIMPLEX & - & .and. .not. have_option(trim(matrices%p_option_path) // & - & "/spatial_discretisation/continuous_galerkin/remove_stabilisation_term") - - ewrite(2, *) "KMK stabilisation? ", apply_kmk - - cmc_sparsity => get_csr_sparsity_secondorder(state, matrices%p_mesh, matrices%u_mesh) - call allocate(matrices%cmc_m, cmc_sparsity, name = "CMC") - - if(matrices%lump_mass) then - call assemble_masslumped_cmc(matrices%cmc_m, matrices%ct_m, matrices%inverse_masslump_v, matrices%ct_m) - else - select case(continuity(matrices%u_mesh)) - case(-1) - call assemble_cmc_dg(matrices%cmc_m, matrices%ct_m, matrices%ct_m, matrices%inverse_mass_b) - case(0) - ewrite(-1, *) "Decomposed field on mesh: " // trim(matrices%u_mesh%name) - FLExit("Must lump mass with continuous decomposed field") - case default - ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) - FLAbort("Unrecognised mesh continuity") - end select - end if + nodes => ele_nodes(mesh, ele) + if(present(masslump)) then + call addto(masslump, nodes, sum(little_mass, 2)) + end if + if(present(inverse_mass)) then + assert(continuity(mesh) == -1) + assert(.not. any(is_nan(little_mass))) + call invert(little_mass) + assert(.not. any(is_nan(little_mass))) + call set(inverse_mass, nodes, nodes, little_mass) + end if - if(apply_kmk) then - ! this is only to retrieve the right meshes to base sparsities on: - positions => extract_vector_field(state, "Coordinate") - call allocate(dummy_p, matrices%p_mesh, "Pressure", field_type = FIELD_TYPE_CONSTANT) - call allocate(dummy_u, positions%dim, matrices%u_mesh, "Velocity", field_type = FIELD_TYPE_CONSTANT) - call insert(lstate, positions, "Coordinate") - call insert(lstate, dummy_p, "Pressure") - call insert(lstate, dummy_u, "Velocity") + end subroutine assemble_mass_ele + + end subroutine allocate_cmc_matrices - masslump => get_lumped_mass(state, dummy_p%mesh) - call insert(lstate, masslump, trim(dummy_p%mesh%name) // "LumpedMass") + subroutine add_cmc_matrix(state, matrices) + !!< Add CMC to the supplied cmc_matrices - call deallocate(dummy_p) - call deallocate(dummy_u) + type(state_type), intent(inout) :: state + type(cmc_matrices), intent(inout) :: matrices - call assemble_kmk_matrix(lstate, matrices%u_mesh, positions, theta_pg = 1.0) - call add_kmk_matrix(lstate, matrices%cmc_m) + logical :: apply_kmk + type(csr_sparsity), pointer :: cmc_sparsity + type(element_type), pointer :: p_shape, u_shape - call deallocate(lstate) - end if + type(scalar_field) :: dummy_p + type(scalar_field), pointer :: masslump + type(state_type) :: lstate + type(vector_field) :: dummy_u + type(vector_field), pointer :: positions - matrices%have_cmc_m = .true. + ewrite(1, *) "In add_cmc_matrix" - ewrite(1, *) "Exiting add_cmc_matrix" + if(matrices%have_cmc_m) then + ewrite(1, *) "Exiting add_cmc_matrix" + return + end if - end subroutine add_cmc_matrix + u_shape => ele_shape(matrices%u_mesh, 1) + p_shape => ele_shape(matrices%p_mesh, 1) + apply_kmk = continuity(matrices%p_mesh) == 0 .and. p_shape%degree == 1 .and. ele_numbering_family(p_shape) == FAMILY_SIMPLEX & + & .and. continuity(matrices%u_mesh) == 0 .and. u_shape%degree == 1 .and. ele_numbering_family(u_shape) == FAMILY_SIMPLEX & + & .and. .not. have_option(trim(matrices%p_option_path) // & + & "/spatial_discretisation/continuous_galerkin/remove_stabilisation_term") - function geopressure_divergence(state, u_mesh, gp_mesh, positions) result(ct_gp_m) - !!< Assemble the geopressure divergence operator + ewrite(2, *) "KMK stabilisation? ", apply_kmk - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: u_mesh - type(mesh_type), intent(inout) :: gp_mesh - type(vector_field), intent(in) :: positions + cmc_sparsity => get_csr_sparsity_secondorder(state, matrices%p_mesh, matrices%u_mesh) + call allocate(matrices%cmc_m, cmc_sparsity, name = "CMC") - type(block_csr_matrix) :: ct_gp_m + if(matrices%lump_mass) then + call assemble_masslumped_cmc(matrices%cmc_m, matrices%ct_m, matrices%inverse_masslump_v, matrices%ct_m) + else + select case(continuity(matrices%u_mesh)) + case(-1) + call assemble_cmc_dg(matrices%cmc_m, matrices%ct_m, matrices%ct_m, matrices%inverse_mass_b) + case(0) + ewrite(-1, *) "Decomposed field on mesh: " // trim(matrices%u_mesh%name) + FLExit("Must lump mass with continuous decomposed field") + case default + ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) + FLAbort("Unrecognised mesh continuity") + end select + end if - integer :: i - type(csr_sparsity), pointer :: ct_gp_sparsity + if(apply_kmk) then + ! this is only to retrieve the right meshes to base sparsities on: + positions => extract_vector_field(state, "Coordinate") + call allocate(dummy_p, matrices%p_mesh, "Pressure", field_type = FIELD_TYPE_CONSTANT) + call allocate(dummy_u, positions%dim, matrices%u_mesh, "Velocity", field_type = FIELD_TYPE_CONSTANT) + call insert(lstate, positions, "Coordinate") + call insert(lstate, dummy_p, "Pressure") + call insert(lstate, dummy_u, "Velocity") - ct_gp_sparsity => get_csr_sparsity_firstorder(state, gp_mesh, u_mesh) - call allocate(ct_gp_m, ct_gp_sparsity, blocks = (/1, positions%dim/), name = "CT_gp") + masslump => get_lumped_mass(state, dummy_p%mesh) + call insert(lstate, masslump, trim(dummy_p%mesh%name) // "LumpedMass") - call zero(ct_gp_m) - do i = 1, ele_count(u_mesh) - call assemble_geopressure_divergence(i, u_mesh, gp_mesh, ct_gp_m, positions) - end do + call deallocate(dummy_p) + call deallocate(dummy_u) - contains + call assemble_kmk_matrix(lstate, matrices%u_mesh, positions, theta_pg = 1.0) + call add_kmk_matrix(lstate, matrices%cmc_m) - subroutine assemble_geopressure_divergence(ele, u_mesh, gp_mesh, ct_gp_m, positions) - integer, intent(in) :: ele - type(mesh_type), intent(in) :: u_mesh - type(mesh_type), intent(in) :: gp_mesh - type(block_csr_matrix), intent(inout) :: ct_gp_m + call deallocate(lstate) + end if + + matrices%have_cmc_m = .true. + + ewrite(1, *) "Exiting add_cmc_matrix" + + end subroutine add_cmc_matrix + + function geopressure_divergence(state, u_mesh, gp_mesh, positions) result(ct_gp_m) + !!< Assemble the geopressure divergence operator + + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: u_mesh + type(mesh_type), intent(inout) :: gp_mesh type(vector_field), intent(in) :: positions - integer, dimension(:), pointer :: gp_nodes, u_nodes - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(gp_mesh, ele), ele_ngi(positions, ele), positions%dim) :: dgp_shape + type(block_csr_matrix) :: ct_gp_m + + integer :: i + type(csr_sparsity), pointer :: ct_gp_sparsity - call transform_to_physical(positions, ele, ele_shape(gp_mesh, ele), & - & dshape = dgp_shape, detwei = detwei) + ct_gp_sparsity => get_csr_sparsity_firstorder(state, gp_mesh, u_mesh) + call allocate(ct_gp_m, ct_gp_sparsity, blocks = (/1, positions%dim/), name = "CT_gp") - u_nodes => ele_nodes(u_mesh, ele) - gp_nodes => ele_nodes(gp_mesh, ele) - call addto(ct_gp_m, gp_nodes, u_nodes, spread(-dshape_shape(dgp_shape, ele_shape(u_mesh, ele), detwei), 1, 1)) + call zero(ct_gp_m) + do i = 1, ele_count(u_mesh) + call assemble_geopressure_divergence(i, u_mesh, gp_mesh, ct_gp_m, positions) + end do - end subroutine assemble_geopressure_divergence + contains - end function geopressure_divergence + subroutine assemble_geopressure_divergence(ele, u_mesh, gp_mesh, ct_gp_m, positions) + integer, intent(in) :: ele + type(mesh_type), intent(in) :: u_mesh + type(mesh_type), intent(in) :: gp_mesh + type(block_csr_matrix), intent(inout) :: ct_gp_m + type(vector_field), intent(in) :: positions - subroutine add_geopressure_matrices(state, gp_mesh, matrices) - !!< Add geopressure preconditioner matrices to the supplied cmc_matrices + integer, dimension(:), pointer :: gp_nodes, u_nodes + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(gp_mesh, ele), ele_ngi(positions, ele), positions%dim) :: dgp_shape - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: gp_mesh - type(cmc_matrices), intent(inout) :: matrices + call transform_to_physical(positions, ele, ele_shape(gp_mesh, ele), & + & dshape = dgp_shape, detwei = detwei) - type(csr_sparsity) :: sparsity - type(vector_field), pointer :: positions + u_nodes => ele_nodes(u_mesh, ele) + gp_nodes => ele_nodes(gp_mesh, ele) + call addto(ct_gp_m, gp_nodes, u_nodes, spread(-dshape_shape(dgp_shape, ele_shape(u_mesh, ele), detwei), 1, 1)) - ewrite(1, *) "In add_geopressure_matrices" + end subroutine assemble_geopressure_divergence + + end function geopressure_divergence + + subroutine add_geopressure_matrices(state, gp_mesh, matrices) + !!< Add geopressure preconditioner matrices to the supplied cmc_matrices + + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: gp_mesh + type(cmc_matrices), intent(inout) :: matrices + + type(csr_sparsity) :: sparsity + type(vector_field), pointer :: positions + + ewrite(1, *) "In add_geopressure_matrices" + + if(matrices%have_geopressure) then + ewrite(1, *) "Exiting add_geopressure_matrices" + return + end if + + matrices%gp_mesh = gp_mesh + call incref(matrices%gp_mesh) + + positions => extract_vector_field(state, "Coordinate") + matrices%ct_gp_m = geopressure_divergence(state, matrices%u_mesh, matrices%gp_mesh, positions) + + sparsity = make_sparsity_mult(matrices%p_mesh, matrices%u_mesh, matrices%gp_mesh, name = "CMC_gpSparsity") + call allocate(matrices%cmc_gp_m, sparsity, name = "CMC_gp") + call deallocate(sparsity) + if(matrices%lump_mass) then + call assemble_masslumped_cmc(matrices%cmc_gp_m, matrices%ct_m, matrices%inverse_masslump_v, matrices%ct_gp_m) + else + select case(continuity(matrices%u_mesh)) + case(-1) + call assemble_cmc_dg(matrices%cmc_gp_m, matrices%ct_gp_m, matrices%ct_m, matrices%inverse_mass_b) + case(0) + ewrite(-1, *) "Decomposed field on mesh: " // trim(matrices%u_mesh%name) + FLExit("Must lump mass with continuous decomposed field") + case default + ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) + FLAbort("Unrecognised mesh continuity") + end select + end if + + matrices%have_geopressure = .true. - if(matrices%have_geopressure) then ewrite(1, *) "Exiting add_geopressure_matrices" - return - end if - - matrices%gp_mesh = gp_mesh - call incref(matrices%gp_mesh) - - positions => extract_vector_field(state, "Coordinate") - matrices%ct_gp_m = geopressure_divergence(state, matrices%u_mesh, matrices%gp_mesh, positions) - - sparsity = make_sparsity_mult(matrices%p_mesh, matrices%u_mesh, matrices%gp_mesh, name = "CMC_gpSparsity") - call allocate(matrices%cmc_gp_m, sparsity, name = "CMC_gp") - call deallocate(sparsity) - if(matrices%lump_mass) then - call assemble_masslumped_cmc(matrices%cmc_gp_m, matrices%ct_m, matrices%inverse_masslump_v, matrices%ct_gp_m) - else - select case(continuity(matrices%u_mesh)) - case(-1) - call assemble_cmc_dg(matrices%cmc_gp_m, matrices%ct_gp_m, matrices%ct_m, matrices%inverse_mass_b) - case(0) - ewrite(-1, *) "Decomposed field on mesh: " // trim(matrices%u_mesh%name) - FLExit("Must lump mass with continuous decomposed field") - case default - ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) - FLAbort("Unrecognised mesh continuity") - end select - end if - matrices%have_geopressure = .true. + end subroutine add_geopressure_matrices - ewrite(1, *) "Exiting add_geopressure_matrices" + subroutine assemble_cmc_rhs(field, matrices, cmc_rhs, gp) + !!< Assemble the pressure projection RHS - end subroutine add_geopressure_matrices + type(vector_field), intent(in) :: field + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(inout) :: cmc_rhs + type(scalar_field), optional, intent(in) :: gp + + type(scalar_field) :: cmc_rhs_addto + + assert(field%mesh == matrices%u_mesh) + assert(cmc_rhs%mesh == matrices%p_mesh) + + call mult(cmc_rhs, matrices%ct_m, field) + call scale(cmc_rhs, -1.0) + if(present(gp)) then + assert(matrices%have_geopressure) + assert(gp%mesh == matrices%gp_mesh) + call allocate(cmc_rhs_addto, cmc_rhs%mesh, trim(cmc_rhs%name) // "Addto") + call mult(cmc_rhs_addto, matrices%cmc_gp_m, gp) + + call scale(cmc_rhs_addto, -1.0) + call addto(cmc_rhs, cmc_rhs_addto) + call deallocate(cmc_rhs_addto) + end if + call addto(cmc_rhs, matrices%ct_rhs) - subroutine assemble_cmc_rhs(field, matrices, cmc_rhs, gp) - !!< Assemble the pressure projection RHS + end subroutine assemble_cmc_rhs - type(vector_field), intent(in) :: field - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(inout) :: cmc_rhs - type(scalar_field), optional, intent(in) :: gp + subroutine apply_cmc_reference_node(matrices, cmc_rhs, positions) + !!< Apply reference node to CMC - type(scalar_field) :: cmc_rhs_addto + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(inout) :: cmc_rhs + type(vector_field), intent(inout) :: positions - assert(field%mesh == matrices%u_mesh) - assert(cmc_rhs%mesh == matrices%p_mesh) + assert(matrices%have_cmc_m) - call mult(cmc_rhs, matrices%ct_m, field) - call scale(cmc_rhs, -1.0) - if(present(gp)) then - assert(matrices%have_geopressure) - assert(gp%mesh == matrices%gp_mesh) - call allocate(cmc_rhs_addto, cmc_rhs%mesh, trim(cmc_rhs%name) // "Addto") - call mult(cmc_rhs_addto, matrices%cmc_gp_m, gp) + call impose_reference_pressure_node(matrices%cmc_m, cmc_rhs, positions, option_path = matrices%p_option_path) - call scale(cmc_rhs_addto, -1.0) - call addto(cmc_rhs, cmc_rhs_addto) - call deallocate(cmc_rhs_addto) - end if - call addto(cmc_rhs, matrices%ct_rhs) + end subroutine apply_cmc_reference_node - end subroutine assemble_cmc_rhs + subroutine apply_cmc_boundary_value(matrices, cmc_rhs, value) + !!< Apply a strong dirichlet bc to CMC on all boundaries - subroutine apply_cmc_reference_node(matrices, cmc_rhs, positions) - !!< Apply reference node to CMC + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(inout) :: cmc_rhs + real, intent(in) :: value - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(inout) :: cmc_rhs - type(vector_field), intent(inout) :: positions + integer :: i - assert(matrices%have_cmc_m) + assert(matrices%have_cmc_m) - call impose_reference_pressure_node(matrices%cmc_m, cmc_rhs, positions, option_path = matrices%p_option_path) + do i = 1, surface_element_count(cmc_rhs) + call set_dirichlet_face(i, matrices%cmc_m, cmc_rhs, value) + end do - end subroutine apply_cmc_reference_node + contains - subroutine apply_cmc_boundary_value(matrices, cmc_rhs, value) - !!< Apply a strong dirichlet bc to CMC on all boundaries + subroutine set_dirichlet_face(face, matrix, rhs, val) + integer, intent(in) :: face + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + real, intent(in) :: val - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(inout) :: cmc_rhs - real, intent(in) :: value + integer, dimension(face_loc(rhs, face)) :: nodes - integer :: i + nodes = face_global_nodes(rhs, face) - assert(matrices%have_cmc_m) + call set_inactive(matrix, nodes) + call set(rhs, nodes, spread(val, 1, face_loc(rhs, face))) - do i = 1, surface_element_count(cmc_rhs) - call set_dirichlet_face(i, matrices%cmc_m, cmc_rhs, value) - end do + end subroutine set_dirichlet_face - contains + end subroutine apply_cmc_boundary_value - subroutine set_dirichlet_face(face, matrix, rhs, val) - integer, intent(in) :: face - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - real, intent(in) :: val + subroutine cmc_solve_finalise(matrices) + !!< Cleanup cmc_matrices after a solve - integer, dimension(face_loc(rhs, face)) :: nodes + type(cmc_matrices), intent(inout) :: matrices - nodes = face_global_nodes(rhs, face) + assert(matrices%have_cmc_m) - call set_inactive(matrix, nodes) - call set(rhs, nodes, spread(val, 1, face_loc(rhs, face))) + if(has_inactive(matrices%cmc_m)) matrices%cmc_m%inactive%ptr = .false. - end subroutine set_dirichlet_face + end subroutine cmc_solve_finalise - end subroutine apply_cmc_boundary_value + subroutine deallocate_cmc_matrices(matrices) + !!< Deallocate cmc_matrices - subroutine cmc_solve_finalise(matrices) - !!< Cleanup cmc_matrices after a solve + type(cmc_matrices), intent(inout) :: matrices - type(cmc_matrices), intent(inout) :: matrices + call deallocate(matrices%u_mesh) + call deallocate(matrices%p_mesh) + if(matrices%lump_mass) then + call deallocate(matrices%inverse_masslump_v) + else + select case(continuity(matrices%u_mesh)) + case(0) + call deallocate(matrices%mass_b) + case(-1) + call deallocate(matrices%inverse_mass_b) + case default + ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) + FLAbort("Unrecognised mesh continuity") + end select + end if + call deallocate(matrices%ct_m) + deallocate(matrices%ct_m) + call deallocate(matrices%ct_rhs) - assert(matrices%have_cmc_m) + if(matrices%have_cmc_m) then + call deallocate(matrices%cmc_m) + matrices%have_cmc_m = .false. + end if - if(has_inactive(matrices%cmc_m)) matrices%cmc_m%inactive%ptr = .false. + if(matrices%have_geopressure) then + call deallocate(matrices%gp_mesh) + call deallocate(matrices%cmc_gp_m) + call deallocate(matrices%ct_gp_m) + matrices%have_geopressure = .false. + end if - end subroutine cmc_solve_finalise + end subroutine deallocate_cmc_matrices - subroutine deallocate_cmc_matrices(matrices) - !!< Deallocate cmc_matrices + subroutine projection_decomposition(state, field, p, gp, option_path, & + & bcfield, matrices) + !!< Perform a Helmholz decomposition of the supplied vector field using + !!< a pressure projection solve. - type(cmc_matrices), intent(inout) :: matrices + type(state_type), intent(inout) :: state + type(vector_field), target, intent(inout) :: field + type(scalar_field), target, intent(inout) :: p + type(scalar_field), optional, intent(inout) :: gp + character(len = *), optional, intent(in) :: option_path + type(vector_field), optional, intent(in) :: bcfield + type(cmc_matrices), optional, intent(out) :: matrices - call deallocate(matrices%u_mesh) - call deallocate(matrices%p_mesh) - if(matrices%lump_mass) then - call deallocate(matrices%inverse_masslump_v) - else - select case(continuity(matrices%u_mesh)) - case(0) - call deallocate(matrices%mass_b) - case(-1) - call deallocate(matrices%inverse_mass_b) - case default - ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) - FLAbort("Unrecognised mesh continuity") - end select - end if - call deallocate(matrices%ct_m) - deallocate(matrices%ct_m) - call deallocate(matrices%ct_rhs) - - if(matrices%have_cmc_m) then - call deallocate(matrices%cmc_m) - matrices%have_cmc_m = .false. - end if + type(vector_field), pointer :: positions + type(cmc_matrices) :: lmatrices + type(scalar_field) :: cmc_rhs - if(matrices%have_geopressure) then - call deallocate(matrices%gp_mesh) - call deallocate(matrices%cmc_gp_m) - call deallocate(matrices%ct_gp_m) - matrices%have_geopressure = .false. - end if + ewrite(1, *) "In projection_decomposition" - end subroutine deallocate_cmc_matrices + call allocate(lmatrices, state, field, p, option_path = option_path, bcfield = bcfield, gp = gp, add_cmc = .true.) - subroutine projection_decomposition(state, field, p, gp, option_path, & - & bcfield, matrices) - !!< Perform a Helmholz decomposition of the supplied vector field using - !!< a pressure projection solve. + call allocate(cmc_rhs, lmatrices%p_mesh, "CMCRHS") + call assemble_cmc_rhs(field, lmatrices, cmc_rhs, gp = gp) - type(state_type), intent(inout) :: state - type(vector_field), target, intent(inout) :: field - type(scalar_field), target, intent(inout) :: p - type(scalar_field), optional, intent(inout) :: gp - character(len = *), optional, intent(in) :: option_path - type(vector_field), optional, intent(in) :: bcfield - type(cmc_matrices), optional, intent(out) :: matrices + positions => extract_vector_field(state, "Coordinate") + call apply_cmc_reference_node(lmatrices, cmc_rhs, positions) + call petsc_solve(p, lmatrices%cmc_m, cmc_rhs, option_path = lmatrices%p_option_path) + call cmc_solve_finalise(lmatrices) - type(vector_field), pointer :: positions - type(cmc_matrices) :: lmatrices - type(scalar_field) :: cmc_rhs + call deallocate(cmc_rhs) - ewrite(1, *) "In projection_decomposition" + if(present(matrices)) then + matrices = lmatrices + else + call deallocate(lmatrices) + end if - call allocate(lmatrices, state, field, p, option_path = option_path, bcfield = bcfield, gp = gp, add_cmc = .true.) + ewrite(1, *) "Exiting projection_decomposition" - call allocate(cmc_rhs, lmatrices%p_mesh, "CMCRHS") - call assemble_cmc_rhs(field, lmatrices, cmc_rhs, gp = gp) + end subroutine projection_decomposition - positions => extract_vector_field(state, "Coordinate") - call apply_cmc_reference_node(lmatrices, cmc_rhs, positions) - call petsc_solve(p, lmatrices%cmc_m, cmc_rhs, option_path = lmatrices%p_option_path) - call cmc_solve_finalise(lmatrices) + subroutine geopressure_decomposition(state, field, p, option_path) + !!< Perform a Helmholz decomposition of the supplied vector field using + !!< a geopressure solve. - call deallocate(cmc_rhs) + type(state_type), intent(inout) :: state + type(vector_field), target, intent(in) :: field + type(scalar_field), target, intent(inout) :: p + character(len = *), optional, intent(in) :: option_path - if(present(matrices)) then - matrices = lmatrices - else - call deallocate(lmatrices) - end if + character(len = OPTION_PATH_LEN) :: loption_path + integer :: i, stat + type(csr_matrix) :: matrix + type(csr_sparsity), pointer :: sparsity + type(mesh_type), pointer :: p_mesh + type(scalar_field) :: rhs + type(vector_field), pointer :: positions - ewrite(1, *) "Exiting projection_decomposition" + ewrite(1, *) "In geopressure_decomposition" - end subroutine projection_decomposition + if(present(option_path)) then + loption_path = option_path + else + loption_path = complete_field_path(p%option_path, stat = stat) + end if + ewrite(2, *) "Option path: " // trim(loption_path) - subroutine geopressure_decomposition(state, field, p, option_path) - !!< Perform a Helmholz decomposition of the supplied vector field using - !!< a geopressure solve. + p_mesh => p%mesh + assert(continuity(p_mesh) == 0) - type(state_type), intent(inout) :: state - type(vector_field), target, intent(in) :: field - type(scalar_field), target, intent(inout) :: p - character(len = *), optional, intent(in) :: option_path + ewrite(2, *) "Decomposed field: ", trim(field%name) + ewrite(2, *) "On mesh: ", trim(field%mesh%name) + ewrite(2, *) "Scalar potential mesh: ", trim(p_mesh%name) - character(len = OPTION_PATH_LEN) :: loption_path - integer :: i, stat - type(csr_matrix) :: matrix - type(csr_sparsity), pointer :: sparsity - type(mesh_type), pointer :: p_mesh - type(scalar_field) :: rhs - type(vector_field), pointer :: positions + positions => extract_vector_field(state, "Coordinate") - ewrite(1, *) "In geopressure_decomposition" + sparsity => get_csr_sparsity_firstorder(state, p_mesh, p_mesh) + call allocate(matrix, sparsity, name = gp_m_name) + call allocate(rhs, p_mesh, name = gp_rhs_name) - if(present(option_path)) then - loption_path = option_path - else - loption_path = complete_field_path(p%option_path, stat = stat) - end if - ewrite(2, *) "Option path: " // trim(loption_path) + call zero(matrix) + call zero(rhs) + do i = 1, ele_count(field) + call assemble_geopressure_ele(i, p_mesh, field, matrix, rhs, positions) + end do - p_mesh => p%mesh - assert(continuity(p_mesh) == 0) + call impose_reference_pressure_node(matrix, rhs, positions, option_path = loption_path) - ewrite(2, *) "Decomposed field: ", trim(field%name) - ewrite(2, *) "On mesh: ", trim(field%mesh%name) - ewrite(2, *) "Scalar potential mesh: ", trim(p_mesh%name) + call petsc_solve(p, matrix, rhs, option_path = loption_path) - positions => extract_vector_field(state, "Coordinate") + call deallocate(matrix) + call deallocate(rhs) - sparsity => get_csr_sparsity_firstorder(state, p_mesh, p_mesh) - call allocate(matrix, sparsity, name = gp_m_name) - call allocate(rhs, p_mesh, name = gp_rhs_name) + ewrite(1, *) "Exiting geopressure_decomposition" - call zero(matrix) - call zero(rhs) - do i = 1, ele_count(field) - call assemble_geopressure_ele(i, p_mesh, field, matrix, rhs, positions) - end do + contains - call impose_reference_pressure_node(matrix, rhs, positions, option_path = loption_path) + subroutine assemble_geopressure_ele(ele, p_mesh, field, matrix, rhs, positions) + integer, intent(in) :: ele + type(mesh_type), intent(in) :: p_mesh + type(vector_field), intent(in) :: field + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions - call petsc_solve(p, matrix, rhs, option_path = loption_path) + integer, dimension(:), pointer :: p_nodes + real, dimension(ele_ngi(p_mesh, ele)) :: detwei + real, dimension(ele_loc(p_mesh, ele), ele_ngi(p_mesh, ele), mesh_dim(p_mesh)) :: dp_shape - call deallocate(matrix) - call deallocate(rhs) + call transform_to_physical(positions, ele, ele_shape(p_mesh, ele), & + & dshape = dp_shape, detwei = detwei) - ewrite(1, *) "Exiting geopressure_decomposition" + p_nodes => ele_nodes(p_mesh, ele) - contains + call addto(matrix, p_nodes, p_nodes, dshape_dot_dshape(dp_shape, dp_shape, detwei)) + call addto(rhs, p_nodes, dshape_dot_vector_rhs(dp_shape, ele_val_at_quad(field, ele), detwei)) - subroutine assemble_geopressure_ele(ele, p_mesh, field, matrix, rhs, positions) - integer, intent(in) :: ele - type(mesh_type), intent(in) :: p_mesh - type(vector_field), intent(in) :: field - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions + end subroutine assemble_geopressure_ele - integer, dimension(:), pointer :: p_nodes - real, dimension(ele_ngi(p_mesh, ele)) :: detwei - real, dimension(ele_loc(p_mesh, ele), ele_ngi(p_mesh, ele), mesh_dim(p_mesh)) :: dp_shape + end subroutine geopressure_decomposition - call transform_to_physical(positions, ele, ele_shape(p_mesh, ele), & - & dshape = dp_shape, detwei = detwei) + subroutine correct_velocity(matrices, velocity, p, conserv, gp) + !!< Project velocity onto the solenoidal space - p_nodes => ele_nodes(p_mesh, ele) + type(cmc_matrices), intent(inout) :: matrices + type(vector_field), intent(inout) :: velocity + type(scalar_field), intent(in) :: p + type(vector_field), optional, intent(inout) :: conserv + type(scalar_field), optional, intent(in) :: gp - call addto(matrix, p_nodes, p_nodes, dshape_dot_dshape(dp_shape, dp_shape, detwei)) - call addto(rhs, p_nodes, dshape_dot_vector_rhs(dp_shape, ele_val_at_quad(field, ele), detwei)) + type(vector_field) :: lconserv, conserv_gp - end subroutine assemble_geopressure_ele + assert(velocity%mesh == matrices%u_mesh) + assert(p%mesh == matrices%p_mesh) + + if(present(conserv)) then + assert(conserv%mesh == matrices%u_mesh) + lconserv = conserv + call incref(lconserv) + else + call allocate(lconserv, velocity%dim, velocity%mesh, trim(p%name) // "Gradient") + end if - end subroutine geopressure_decomposition + call compute_conservative(matrices, lconserv, p) + if(present(gp)) then + assert(matrices%have_geopressure) + assert(gp%mesh == matrices%gp_mesh) + call allocate(conserv_gp, velocity%dim, velocity%mesh, trim(gp%name) // "Gradient") + call compute_conservative(matrices, conserv_gp, gp, geopressure = .true.) + call addto(lconserv, conserv_gp) + call deallocate(conserv_gp) + end if + call addto(velocity, lconserv, scale = -1.0) + call deallocate(lconserv) - subroutine correct_velocity(matrices, velocity, p, conserv, gp) - !!< Project velocity onto the solenoidal space + end subroutine correct_velocity - type(cmc_matrices), intent(inout) :: matrices - type(vector_field), intent(inout) :: velocity - type(scalar_field), intent(in) :: p - type(vector_field), optional, intent(inout) :: conserv - type(scalar_field), optional, intent(in) :: gp + subroutine compute_conservative(matrices, conserv, p, geopressure) + !!< Compute the gradient of a field - type(vector_field) :: lconserv, conserv_gp + type(cmc_matrices), target, intent(in) :: matrices + type(vector_field), intent(inout) :: conserv + type(scalar_field), intent(in) :: p + logical, optional, intent(in) :: geopressure - assert(velocity%mesh == matrices%u_mesh) - assert(p%mesh == matrices%p_mesh) + integer :: i + type(block_csr_matrix), pointer :: ct_m + type(scalar_field) :: conserv_comp, ct_m_p - if(present(conserv)) then assert(conserv%mesh == matrices%u_mesh) - lconserv = conserv - call incref(lconserv) - else - call allocate(lconserv, velocity%dim, velocity%mesh, trim(p%name) // "Gradient") - end if - - call compute_conservative(matrices, lconserv, p) - if(present(gp)) then - assert(matrices%have_geopressure) - assert(gp%mesh == matrices%gp_mesh) - call allocate(conserv_gp, velocity%dim, velocity%mesh, trim(gp%name) // "Gradient") - call compute_conservative(matrices, conserv_gp, gp, geopressure = .true.) - call addto(lconserv, conserv_gp) - call deallocate(conserv_gp) - end if - call addto(velocity, lconserv, scale = -1.0) - call deallocate(lconserv) - - end subroutine correct_velocity - - subroutine compute_conservative(matrices, conserv, p, geopressure) - !!< Compute the gradient of a field - - type(cmc_matrices), target, intent(in) :: matrices - type(vector_field), intent(inout) :: conserv - type(scalar_field), intent(in) :: p - logical, optional, intent(in) :: geopressure - - integer :: i - type(block_csr_matrix), pointer :: ct_m - type(scalar_field) :: conserv_comp, ct_m_p - - assert(conserv%mesh == matrices%u_mesh) - if(present_and_true(geopressure)) then - assert(matrices%have_geopressure) - assert(p%mesh == matrices%gp_mesh) - ct_m => matrices%ct_gp_m - else - assert(p%mesh == matrices%p_mesh) - ct_m => matrices%ct_m - end if - - if(matrices%lump_mass) then - do i = 1, conserv%dim - conserv_comp = extract_scalar_field(conserv, i) - call mult_t(conserv_comp, block(ct_m, 1, i), p) - call scale(conserv_comp, extract_scalar_field(matrices%inverse_masslump_v, i)) - end do - else - select case(continuity(matrices%u_mesh)) - case(0) - if(.not. have_option(trim(matrices%mass_option_path) // "/solver")) then - FLExit("Must lump mass or supply solver options for continuous compute_conservative") - end if - call allocate(ct_m_p, conserv%mesh, "CTxp") - do i = 1, conserv%dim - conserv_comp = extract_scalar_field(conserv, i) - call mult_t(ct_m_p, block(ct_m, 1, i), p) - call zero(conserv_comp) - call petsc_solve(conserv_comp, block(matrices%mass_b, i, i), ct_m_p, option_path = matrices%mass_option_path) - end do - call deallocate(ct_m_p) - case(-1) - call allocate(ct_m_p, conserv%mesh, "CTxp") - do i = 1, conserv%dim + if(present_and_true(geopressure)) then + assert(matrices%have_geopressure) + assert(p%mesh == matrices%gp_mesh) + ct_m => matrices%ct_gp_m + else + assert(p%mesh == matrices%p_mesh) + ct_m => matrices%ct_m + end if + + if(matrices%lump_mass) then + do i = 1, conserv%dim conserv_comp = extract_scalar_field(conserv, i) - call mult_t(ct_m_p, block(ct_m, 1, i), p) - call mult(conserv_comp, block(matrices%inverse_mass_b, i, i), ct_m_p) - end do - call deallocate(ct_m_p) - case default - ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) - FLAbort("Unrecognised mesh continuity") - end select - end if - call scale(conserv, -1.0) - call halo_update(conserv) + call mult_t(conserv_comp, block(ct_m, 1, i), p) + call scale(conserv_comp, extract_scalar_field(matrices%inverse_masslump_v, i)) + end do + else + select case(continuity(matrices%u_mesh)) + case(0) + if(.not. have_option(trim(matrices%mass_option_path) // "/solver")) then + FLExit("Must lump mass or supply solver options for continuous compute_conservative") + end if + call allocate(ct_m_p, conserv%mesh, "CTxp") + do i = 1, conserv%dim + conserv_comp = extract_scalar_field(conserv, i) + call mult_t(ct_m_p, block(ct_m, 1, i), p) + call zero(conserv_comp) + call petsc_solve(conserv_comp, block(matrices%mass_b, i, i), ct_m_p, option_path = matrices%mass_option_path) + end do + call deallocate(ct_m_p) + case(-1) + call allocate(ct_m_p, conserv%mesh, "CTxp") + do i = 1, conserv%dim + conserv_comp = extract_scalar_field(conserv, i) + call mult_t(ct_m_p, block(ct_m, 1, i), p) + call mult(conserv_comp, block(matrices%inverse_mass_b, i, i), ct_m_p) + end do + call deallocate(ct_m_p) + case default + ewrite(-1, *) "For mesh continuity: ", continuity(matrices%u_mesh) + FLAbort("Unrecognised mesh continuity") + end select + end if + call scale(conserv, -1.0) + call halo_update(conserv) - end subroutine compute_conservative + end subroutine compute_conservative - subroutine compute_divergence(field, ct_m, mass, div) - !!< Compute the divergence of a field + subroutine compute_divergence(field, ct_m, mass, div) + !!< Compute the divergence of a field - type(vector_field), intent(in) :: field - type(block_csr_matrix), pointer :: ct_m - type(csr_matrix), intent(in) :: mass - type(scalar_field), intent(inout) :: div + type(vector_field), intent(in) :: field + type(block_csr_matrix), pointer :: ct_m + type(csr_matrix), intent(in) :: mass + type(scalar_field), intent(inout) :: div - type(scalar_field) :: rhs + type(scalar_field) :: rhs - call allocate(rhs, div%mesh, "RHS") - call mult(rhs, ct_m, field) - call petsc_solve(div, mass, rhs) - call deallocate(rhs) + call allocate(rhs, div%mesh, "RHS") + call mult(rhs, ct_m, field) + call petsc_solve(div, mass, rhs) + call deallocate(rhs) - end subroutine compute_divergence + end subroutine compute_divergence - function coriolis_val_single(coord, velocity) result(coriolis_val) - real, dimension(:), intent(in) :: coord - real, dimension(size(coord)), intent(in) :: velocity + function coriolis_val_single(coord, velocity) result(coriolis_val) + real, dimension(:), intent(in) :: coord + real, dimension(size(coord)), intent(in) :: velocity - real, dimension(size(coord)) :: coriolis_val + real, dimension(size(coord)) :: coriolis_val - real :: two_omega_val + real :: two_omega_val - two_omega_val = sum(two_omega(spread(coord, 2, 1))) - assert(any(size(velocity) == (/2, 3/))) - coriolis_val(U_) = velocity(V_) * two_omega_val - coriolis_val(V_) = -velocity(U_) * two_omega_val - if(size(velocity) == 3) coriolis_val(W_) = 0.0 + two_omega_val = sum(two_omega(spread(coord, 2, 1))) + assert(any(size(velocity) == (/2, 3/))) + coriolis_val(U_) = velocity(V_) * two_omega_val + coriolis_val(V_) = -velocity(U_) * two_omega_val + if(size(velocity) == 3) coriolis_val(W_) = 0.0 - end function coriolis_val_single + end function coriolis_val_single - function coriolis_val_multiple(coord, velocity) result(coriolis_val) - !! size(dim, loc) - real, dimension(:, :), intent(in) :: coord - !! size(dim, loc) - real, dimension(size(coord, 1), size(coord, 2)), intent(in) :: velocity + function coriolis_val_multiple(coord, velocity) result(coriolis_val) + !! size(dim, loc) + real, dimension(:, :), intent(in) :: coord + !! size(dim, loc) + real, dimension(size(coord, 1), size(coord, 2)), intent(in) :: velocity - !! size(dim, loc) - real, dimension(size(coord, 1), size(coord, 2)) :: coriolis_val + !! size(dim, loc) + real, dimension(size(coord, 1), size(coord, 2)) :: coriolis_val - real, dimension(size(coord, 2)) :: two_omega_vals + real, dimension(size(coord, 2)) :: two_omega_vals - two_omega_vals = two_omega(coord) - assert(any(size(velocity, 1) == (/2, 3/))) - coriolis_val(U_, :) = velocity(V_, :) * two_omega_vals - coriolis_val(V_, :) = -velocity(U_, :) * two_omega_vals - if(size(velocity, 1) == 3) coriolis_val(W_, :) = 0.0 + two_omega_vals = two_omega(coord) + assert(any(size(velocity, 1) == (/2, 3/))) + coriolis_val(U_, :) = velocity(V_, :) * two_omega_vals + coriolis_val(V_, :) = -velocity(U_, :) * two_omega_vals + if(size(velocity, 1) == 3) coriolis_val(W_, :) = 0.0 - end function coriolis_val_multiple + end function coriolis_val_multiple - function velocity_from_coriolis_val_single(coord, coriolis_val) result(velocity) - real, dimension(:), intent(in) :: coord - real, dimension(size(coord)) :: coriolis_val + function velocity_from_coriolis_val_single(coord, coriolis_val) result(velocity) + real, dimension(:), intent(in) :: coord + real, dimension(size(coord)) :: coriolis_val - real, dimension(size(coord)) :: velocity + real, dimension(size(coord)) :: velocity - real :: two_omega_val + real :: two_omega_val - two_omega_val = sum(two_omega(spread(coord, 2, 1))) - assert(any(size(coriolis_val) == (/2, 3/))) - velocity(U_) = -coriolis_val(V_) / two_omega_val - velocity(V_) = coriolis_val(U_) / two_omega_val - if(size(coriolis_val, 1) == 3) velocity(W_) = 0.0 + two_omega_val = sum(two_omega(spread(coord, 2, 1))) + assert(any(size(coriolis_val) == (/2, 3/))) + velocity(U_) = -coriolis_val(V_) / two_omega_val + velocity(V_) = coriolis_val(U_) / two_omega_val + if(size(coriolis_val, 1) == 3) velocity(W_) = 0.0 - end function velocity_from_coriolis_val_single + end function velocity_from_coriolis_val_single - function velocity_from_coriolis_val_multiple(coord, coriolis_val) result(velocity) - !! size(dim, loc) - real, dimension(:, :), intent(in) :: coord - !! size(dim, loc) - real, dimension(size(coord, 1), size(coord, 2)) :: coriolis_val + function velocity_from_coriolis_val_multiple(coord, coriolis_val) result(velocity) + !! size(dim, loc) + real, dimension(:, :), intent(in) :: coord + !! size(dim, loc) + real, dimension(size(coord, 1), size(coord, 2)) :: coriolis_val - !! size(dim, loc) - real, dimension(size(coord, 1), size(coord, 2)) :: velocity + !! size(dim, loc) + real, dimension(size(coord, 1), size(coord, 2)) :: velocity - real, dimension(size(coord, 2)) :: two_omega_vals + real, dimension(size(coord, 2)) :: two_omega_vals - two_omega_vals = two_omega(coord) - assert(any(size(coriolis_val, 1) == (/2, 3/))) - velocity(U_, :) = -coriolis_val(V_, :) / two_omega_vals - velocity(V_, :) = coriolis_val(U_, :) / two_omega_vals - if(size(coriolis_val, 1) == 3) velocity(W_, :) = 0.0 + two_omega_vals = two_omega(coord) + assert(any(size(coriolis_val, 1) == (/2, 3/))) + velocity(U_, :) = -coriolis_val(V_, :) / two_omega_vals + velocity(V_, :) = coriolis_val(U_, :) / two_omega_vals + if(size(coriolis_val, 1) == 3) velocity(W_, :) = 0.0 - end function velocity_from_coriolis_val_multiple + end function velocity_from_coriolis_val_multiple - subroutine geostrophic_velocity(matrices, state, velocity, p) - type(cmc_matrices), intent(in) :: matrices - type(state_type), intent(inout) :: state - type(vector_field), target, intent(inout) :: velocity - type(scalar_field), intent(in) :: p + subroutine geostrophic_velocity(matrices, state, velocity, p) + type(cmc_matrices), intent(in) :: matrices + type(state_type), intent(inout) :: state + type(vector_field), target, intent(inout) :: velocity + type(scalar_field), intent(in) :: p - type(vector_field) :: coriolis + type(vector_field) :: coriolis - assert(velocity%mesh == matrices%u_mesh) - assert(p%mesh == matrices%p_mesh) + assert(velocity%mesh == matrices%u_mesh) + assert(p%mesh == matrices%p_mesh) - call allocate(coriolis, velocity%dim, matrices%u_mesh, "Coriolis") - call compute_conservative(matrices, coriolis, p) + call allocate(coriolis, velocity%dim, matrices%u_mesh, "Coriolis") + call compute_conservative(matrices, coriolis, p) - call velocity_from_coriolis(state, coriolis, velocity, & + call velocity_from_coriolis(state, coriolis, velocity, & & lump_mass = matrices%lump_mass, solver_path = matrices%mass_option_path) - call deallocate(coriolis) - - end subroutine geostrophic_velocity - - subroutine velocity_from_coriolis(state, coriolis, velocity, lump_mass, lump_rhs, solver_path) - type(state_type), intent(inout) :: state - type(vector_field), intent(in) :: coriolis - type(vector_field), intent(inout) :: velocity - logical, optional, intent(in) :: lump_mass - logical, optional, intent(in) :: lump_rhs - character(len = *), optional, intent(in) :: solver_path - - integer :: cont, i, stat - logical :: llump_mass, llump_rhs - type(csr_matrix), pointer :: mass - type(scalar_field), pointer :: masslump - type(vector_field) :: rhs - type(vector_field), pointer :: positions - - ewrite(1, *) "In velocity_from_coriolis" - - ewrite(2, *) "Coriolis mesh: " // trim(coriolis%mesh%name) - ewrite(2, *) "Velocity mesh: " // trim(velocity%mesh%name) - - cont = continuity(velocity) - if(present(lump_mass)) then - llump_mass = lump_mass - else - llump_mass = (cont == 0) - end if - llump_rhs = present_and_true(lump_rhs) - if(llump_rhs) then - if(.not. coriolis%mesh == velocity%mesh) then - FLAbort("Velocity and Coriolis must be on the same mesh when lumping RHS") - end if - end if - - ewrite(2, *) "Velocity mesh continuity: ", cont - ewrite(2, *) "Lump mass? ", llump_mass - ewrite(2, *) "Lump RHS? ", llump_rhs - - positions => extract_vector_field(state, "Coordinate") - if(llump_mass) then - masslump => get_lumped_mass(state, velocity%mesh) - call zero(velocity) - do i = 1, ele_count(velocity) - call assemble_velocity_ele(i, positions, coriolis, velocity, llump_rhs) - end do - do i = 1, coriolis%dim - velocity%val(i,:) = velocity%val(i,:) / masslump%val - end do - else - select case(cont) - case(0) - if(.not. present(solver_path)) then - if(.not. have_option(trim(complete_field_path(velocity%option_path, stat = stat)) // "/solver")) then - FLExit("Must lump mass or supply solver options for continuous velocity_from_coriolis") - end if - else if(.not. have_option(trim(solver_path) // "/solver")) then - FLExit("Must lump mass or supply solver options for continuous velocity_from_coriolis") - end if - mass => get_mass_matrix(state, velocity%mesh) - call allocate(rhs, velocity%dim, velocity%mesh, "RHS") - call zero(rhs) - do i = 1, ele_count(rhs) - call assemble_velocity_ele(i, positions, coriolis, rhs, llump_rhs) - end do - ewrite_minmax(rhs) - call petsc_solve(velocity, mass, rhs, option_path = solver_path) - call deallocate(rhs) - case(-1) - do i = 1, ele_count(velocity) - call solve_velocity_ele(i, positions, coriolis, velocity, llump_rhs) - end do - case default - ewrite(-1, *) "For mesh continuity: ", cont - FLAbort("Unrecognised mesh continuity") - end select - end if - - ewrite_minmax(velocity) - - ewrite(1, *) "Exiting velocity_from_coriolis" - - contains - - subroutine assemble_velocity_ele(ele, positions, coriolis, rhs, lump_rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions + call deallocate(coriolis) + + end subroutine geostrophic_velocity + + subroutine velocity_from_coriolis(state, coriolis, velocity, lump_mass, lump_rhs, solver_path) + type(state_type), intent(inout) :: state type(vector_field), intent(in) :: coriolis - type(vector_field), intent(inout) :: rhs - logical, intent(in) :: lump_rhs + type(vector_field), intent(inout) :: velocity + logical, optional, intent(in) :: lump_mass + logical, optional, intent(in) :: lump_rhs + character(len = *), optional, intent(in) :: solver_path - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(rhs, ele)) :: little_lumped_lrhs - real, dimension(rhs%dim, ele_loc(rhs, ele)) :: little_rhs - type(element_type), pointer :: shape + integer :: cont, i, stat + logical :: llump_mass, llump_rhs + type(csr_matrix), pointer :: mass + type(scalar_field), pointer :: masslump + type(vector_field) :: rhs + type(vector_field), pointer :: positions - call transform_to_physical(positions, ele, & - & detwei = detwei) + ewrite(1, *) "In velocity_from_coriolis" - shape => ele_shape(rhs, ele) + ewrite(2, *) "Coriolis mesh: " // trim(coriolis%mesh%name) + ewrite(2, *) "Velocity mesh: " // trim(velocity%mesh%name) - if(lump_rhs) then - little_lumped_lrhs = sum(shape_shape(shape, shape, detwei / two_omega(ele_val_at_quad(positions, ele))), 2) - little_rhs(U_, :) = -little_lumped_lrhs * ele_val(coriolis, V_, ele) - little_rhs(V_, :) = little_lumped_lrhs * ele_val(coriolis, U_, ele) - if(size(little_rhs, 1) == 3) little_rhs(W_, :) = 0.0 + cont = continuity(velocity) + if(present(lump_mass)) then + llump_mass = lump_mass else - little_rhs = shape_vector_rhs(shape, & - & velocity_from_coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(coriolis, ele)), detwei) + llump_mass = (cont == 0) + end if + llump_rhs = present_and_true(lump_rhs) + if(llump_rhs) then + if(.not. coriolis%mesh == velocity%mesh) then + FLAbort("Velocity and Coriolis must be on the same mesh when lumping RHS") + end if end if - call addto(rhs, ele_nodes(rhs, ele), little_rhs) - - end subroutine assemble_velocity_ele - - subroutine solve_velocity_ele(ele, positions, coriolis, velocity, lump_rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: coriolis - type(vector_field), intent(inout) :: velocity - logical, intent(in) :: lump_rhs + ewrite(2, *) "Velocity mesh continuity: ", cont + ewrite(2, *) "Lump mass? ", llump_mass + ewrite(2, *) "Lump RHS? ", llump_rhs - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(velocity, ele)) :: little_lumped_lrhs - real, dimension(ele_loc(velocity, ele), velocity%dim) :: little_rhs - real, dimension(ele_loc(velocity, ele), ele_loc(velocity, ele)) :: little_mass - type(element_type), pointer :: shape - - call transform_to_physical(positions, ele, & - & detwei = detwei) - - shape => ele_shape(velocity, ele) - little_mass = shape_shape(shape, shape, detwei) - - if(lump_rhs) then - little_lumped_lrhs = sum(shape_shape(shape, shape, detwei / two_omega(ele_val_at_quad(positions, ele))), 2) - little_rhs(U_, :) = -little_lumped_lrhs * ele_val(coriolis, V_, ele) - little_rhs(V_, :) = little_lumped_lrhs * ele_val(coriolis, U_, ele) - if(size(little_rhs, 2) == 3) little_rhs(:, W_) = 0.0 + positions => extract_vector_field(state, "Coordinate") + if(llump_mass) then + masslump => get_lumped_mass(state, velocity%mesh) + call zero(velocity) + do i = 1, ele_count(velocity) + call assemble_velocity_ele(i, positions, coriolis, velocity, llump_rhs) + end do + do i = 1, coriolis%dim + velocity%val(i,:) = velocity%val(i,:) / masslump%val + end do else - little_rhs = transpose(shape_vector_rhs(shape, & - & velocity_from_coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(coriolis, ele)), detwei)) + select case(cont) + case(0) + if(.not. present(solver_path)) then + if(.not. have_option(trim(complete_field_path(velocity%option_path, stat = stat)) // "/solver")) then + FLExit("Must lump mass or supply solver options for continuous velocity_from_coriolis") + end if + else if(.not. have_option(trim(solver_path) // "/solver")) then + FLExit("Must lump mass or supply solver options for continuous velocity_from_coriolis") + end if + mass => get_mass_matrix(state, velocity%mesh) + call allocate(rhs, velocity%dim, velocity%mesh, "RHS") + call zero(rhs) + do i = 1, ele_count(rhs) + call assemble_velocity_ele(i, positions, coriolis, rhs, llump_rhs) + end do + ewrite_minmax(rhs) + call petsc_solve(velocity, mass, rhs, option_path = solver_path) + call deallocate(rhs) + case(-1) + do i = 1, ele_count(velocity) + call solve_velocity_ele(i, positions, coriolis, velocity, llump_rhs) + end do + case default + ewrite(-1, *) "For mesh continuity: ", cont + FLAbort("Unrecognised mesh continuity") + end select end if - call solve(little_mass, little_rhs) + ewrite_minmax(velocity) - call set(velocity, ele_nodes(velocity, ele), transpose(little_rhs)) + ewrite(1, *) "Exiting velocity_from_coriolis" - end subroutine solve_velocity_ele + contains - end subroutine velocity_from_coriolis + subroutine assemble_velocity_ele(ele, positions, coriolis, rhs, lump_rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: coriolis + type(vector_field), intent(inout) :: rhs + logical, intent(in) :: lump_rhs - subroutine coriolis_from_velocity(state, velocity, coriolis, lump_mass, lump_rhs, solver_path) - type(state_type), intent(inout) :: state - type(vector_field), intent(in) :: velocity - type(vector_field), intent(inout) :: coriolis - logical, optional, intent(in) :: lump_mass - logical, optional, intent(in) :: lump_rhs - character(len = *), optional, intent(in) :: solver_path + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(rhs, ele)) :: little_lumped_lrhs + real, dimension(rhs%dim, ele_loc(rhs, ele)) :: little_rhs + type(element_type), pointer :: shape - integer :: cont, i, stat - logical :: llump_mass, llump_rhs - type(csr_matrix), pointer :: matrix - type(scalar_field), pointer :: masslump - type(vector_field) :: rhs - type(vector_field), pointer :: positions + call transform_to_physical(positions, ele, & + & detwei = detwei) - ewrite(1, *) "In coriolis_from_velocity" + shape => ele_shape(rhs, ele) - ewrite(2, *) "Coriolis mesh: " // trim(coriolis%mesh%name) - ewrite(2, *) "Velocity mesh: " // trim(velocity%mesh%name) + if(lump_rhs) then + little_lumped_lrhs = sum(shape_shape(shape, shape, detwei / two_omega(ele_val_at_quad(positions, ele))), 2) + little_rhs(U_, :) = -little_lumped_lrhs * ele_val(coriolis, V_, ele) + little_rhs(V_, :) = little_lumped_lrhs * ele_val(coriolis, U_, ele) + if(size(little_rhs, 1) == 3) little_rhs(W_, :) = 0.0 + else + little_rhs = shape_vector_rhs(shape, & + & velocity_from_coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(coriolis, ele)), detwei) + end if - cont = continuity(coriolis) - if(present(lump_mass)) then - llump_mass = lump_mass - else - llump_mass = (cont == 0) - end if - llump_rhs = present_and_true(lump_rhs) - if(llump_rhs) then - if(.not. coriolis%mesh == velocity%mesh) then - FLExit("Velocity and Coriolis must be on the same mesh when lumping RHS") - end if - end if + call addto(rhs, ele_nodes(rhs, ele), little_rhs) - ewrite(2, *) "Coriolis mesh continuity: ", cont - ewrite(2, *) "Lump mass? ", llump_mass - ewrite(2, *) "Lump RHS? ", llump_rhs + end subroutine assemble_velocity_ele - positions => extract_vector_field(state, "Coordinate") - if(llump_mass) then - masslump => get_lumped_mass(state, coriolis%mesh) - call zero(coriolis) - do i = 1, ele_count(coriolis) - call assemble_coriolis_ele(i, positions, velocity, coriolis, llump_rhs) - end do - do i = 1, coriolis%dim - coriolis%val(i,:) = coriolis%val(i,:) / masslump%val - end do - else - select case(cont) - case(0) - if(.not. present(solver_path)) then - if(.not. have_option(trim(complete_field_path(velocity%option_path, stat = stat)) // "/solver")) then - FLExit("Must lump mass or supply solver options for continuous coriolis_from_velocity") - end if - else if(.not. have_option(trim(solver_path) // "/solver")) then - FLExit("Must lump mass or supply solver options for continuous coriolis_from_velocity") - end if - matrix => get_mass_matrix(state, coriolis%mesh) - call allocate(rhs, coriolis%dim, coriolis%mesh, name = "RHS") - call zero(rhs) - do i = 1, ele_count(coriolis) - call assemble_coriolis_ele(i, positions, velocity, rhs, llump_rhs) - end do - call petsc_solve(coriolis, matrix, rhs, option_path = solver_path) - call deallocate(rhs) - case(-1) - do i = 1, ele_count(coriolis) - call solve_coriolis_ele(i, positions, velocity, coriolis, llump_rhs) - end do - case default - ewrite(-1, *) "For mesh continuity: ", cont - FLAbort("Unrecognised mesh continuity") - end select - end if + subroutine solve_velocity_ele(ele, positions, coriolis, velocity, lump_rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: coriolis + type(vector_field), intent(inout) :: velocity + logical, intent(in) :: lump_rhs - ewrite_minmax(coriolis) + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(velocity, ele)) :: little_lumped_lrhs + real, dimension(ele_loc(velocity, ele), velocity%dim) :: little_rhs + real, dimension(ele_loc(velocity, ele), ele_loc(velocity, ele)) :: little_mass + type(element_type), pointer :: shape - ewrite(1, *) "Exiting coriolis_from_velocity" + call transform_to_physical(positions, ele, & + & detwei = detwei) - contains + shape => ele_shape(velocity, ele) + little_mass = shape_shape(shape, shape, detwei) - subroutine assemble_coriolis_ele(ele, positions, velocity, rhs, lump_rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions + if(lump_rhs) then + little_lumped_lrhs = sum(shape_shape(shape, shape, detwei / two_omega(ele_val_at_quad(positions, ele))), 2) + little_rhs(U_, :) = -little_lumped_lrhs * ele_val(coriolis, V_, ele) + little_rhs(V_, :) = little_lumped_lrhs * ele_val(coriolis, U_, ele) + if(size(little_rhs, 2) == 3) little_rhs(:, W_) = 0.0 + else + little_rhs = transpose(shape_vector_rhs(shape, & + & velocity_from_coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(coriolis, ele)), detwei)) + end if + + call solve(little_mass, little_rhs) + + call set(velocity, ele_nodes(velocity, ele), transpose(little_rhs)) + + end subroutine solve_velocity_ele + + end subroutine velocity_from_coriolis + + subroutine coriolis_from_velocity(state, velocity, coriolis, lump_mass, lump_rhs, solver_path) + type(state_type), intent(inout) :: state type(vector_field), intent(in) :: velocity - type(vector_field), intent(inout) :: rhs - logical, intent(in) :: lump_rhs + type(vector_field), intent(inout) :: coriolis + logical, optional, intent(in) :: lump_mass + logical, optional, intent(in) :: lump_rhs + character(len = *), optional, intent(in) :: solver_path - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(rhs, ele)) :: little_lumped_l - real, dimension(rhs%dim, ele_loc(rhs, ele)) :: little_rhs - type(element_type), pointer :: shape + integer :: cont, i, stat + logical :: llump_mass, llump_rhs + type(csr_matrix), pointer :: matrix + type(scalar_field), pointer :: masslump + type(vector_field) :: rhs + type(vector_field), pointer :: positions - call transform_to_physical(positions, ele, & - & detwei = detwei) + ewrite(1, *) "In coriolis_from_velocity" - shape => ele_shape(rhs, ele) + ewrite(2, *) "Coriolis mesh: " // trim(coriolis%mesh%name) + ewrite(2, *) "Velocity mesh: " // trim(velocity%mesh%name) - if(lump_rhs) then - little_lumped_l = sum(shape_shape(shape, shape, detwei * two_omega(ele_val_at_quad(positions, ele))), 2) - assert(any(size(little_rhs, 1) == (/2, 3/))) - little_rhs(U_, :) = -little_lumped_l * ele_val(velocity, V_, ele) - little_rhs(V_, :) = little_lumped_l * ele_val(velocity, U_, ele) - if(size(little_rhs, 1) == 3) little_rhs(W_, :) = 0.0 + cont = continuity(coriolis) + if(present(lump_mass)) then + llump_mass = lump_mass else - little_rhs = shape_vector_rhs(shape, coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(velocity, ele)), detwei) + llump_mass = (cont == 0) + end if + llump_rhs = present_and_true(lump_rhs) + if(llump_rhs) then + if(.not. coriolis%mesh == velocity%mesh) then + FLExit("Velocity and Coriolis must be on the same mesh when lumping RHS") + end if end if - call addto(rhs, ele_nodes(rhs, ele), little_rhs) + ewrite(2, *) "Coriolis mesh continuity: ", cont + ewrite(2, *) "Lump mass? ", llump_mass + ewrite(2, *) "Lump RHS? ", llump_rhs - end subroutine assemble_coriolis_ele + positions => extract_vector_field(state, "Coordinate") + if(llump_mass) then + masslump => get_lumped_mass(state, coriolis%mesh) + call zero(coriolis) + do i = 1, ele_count(coriolis) + call assemble_coriolis_ele(i, positions, velocity, coriolis, llump_rhs) + end do + do i = 1, coriolis%dim + coriolis%val(i,:) = coriolis%val(i,:) / masslump%val + end do + else + select case(cont) + case(0) + if(.not. present(solver_path)) then + if(.not. have_option(trim(complete_field_path(velocity%option_path, stat = stat)) // "/solver")) then + FLExit("Must lump mass or supply solver options for continuous coriolis_from_velocity") + end if + else if(.not. have_option(trim(solver_path) // "/solver")) then + FLExit("Must lump mass or supply solver options for continuous coriolis_from_velocity") + end if + matrix => get_mass_matrix(state, coriolis%mesh) + call allocate(rhs, coriolis%dim, coriolis%mesh, name = "RHS") + call zero(rhs) + do i = 1, ele_count(coriolis) + call assemble_coriolis_ele(i, positions, velocity, rhs, llump_rhs) + end do + call petsc_solve(coriolis, matrix, rhs, option_path = solver_path) + call deallocate(rhs) + case(-1) + do i = 1, ele_count(coriolis) + call solve_coriolis_ele(i, positions, velocity, coriolis, llump_rhs) + end do + case default + ewrite(-1, *) "For mesh continuity: ", cont + FLAbort("Unrecognised mesh continuity") + end select + end if - subroutine solve_coriolis_ele(ele, positions, velocity, coriolis, lump_rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - type(vector_field), intent(inout) :: coriolis - logical, intent(in) :: lump_rhs + ewrite_minmax(coriolis) - integer, dimension(:), pointer :: nodes - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(coriolis, ele)) :: little_lumped_l - real, dimension(ele_loc(coriolis, ele), coriolis%dim) :: little_rhs - real, dimension(ele_loc(coriolis, ele), ele_loc(coriolis, ele)) :: little_mass - type(element_type), pointer :: shape + ewrite(1, *) "Exiting coriolis_from_velocity" - call transform_to_physical(positions, ele, & - & detwei = detwei) + contains - shape => ele_shape(coriolis, ele) + subroutine assemble_coriolis_ele(ele, positions, velocity, rhs, lump_rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(vector_field), intent(inout) :: rhs + logical, intent(in) :: lump_rhs - little_mass = shape_shape(shape, shape, detwei) + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(rhs, ele)) :: little_lumped_l + real, dimension(rhs%dim, ele_loc(rhs, ele)) :: little_rhs + type(element_type), pointer :: shape - if(lump_rhs) then - little_lumped_l = sum(shape_shape(shape, shape, detwei * two_omega(ele_val_at_quad(positions, ele))), 2) - assert(any(size(little_rhs, 2) == (/2, 3/))) - little_rhs(:, U_) = -little_lumped_l * ele_val(velocity, V_, ele) - little_rhs(:, V_) = little_lumped_l * ele_val(velocity, U_, ele) - if(size(little_rhs, 2) == 3) little_rhs(:, W_) = 0.0 - else - little_rhs = transpose(shape_vector_rhs(shape, coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(velocity, ele)), detwei)) - end if + call transform_to_physical(positions, ele, & + & detwei = detwei) + + shape => ele_shape(rhs, ele) - call solve(little_mass, little_rhs) + if(lump_rhs) then + little_lumped_l = sum(shape_shape(shape, shape, detwei * two_omega(ele_val_at_quad(positions, ele))), 2) + assert(any(size(little_rhs, 1) == (/2, 3/))) + little_rhs(U_, :) = -little_lumped_l * ele_val(velocity, V_, ele) + little_rhs(V_, :) = little_lumped_l * ele_val(velocity, U_, ele) + if(size(little_rhs, 1) == 3) little_rhs(W_, :) = 0.0 + else + little_rhs = shape_vector_rhs(shape, coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(velocity, ele)), detwei) + end if - nodes => ele_nodes(coriolis, ele) - call set(coriolis, nodes, transpose(little_rhs)) + call addto(rhs, ele_nodes(rhs, ele), little_rhs) - end subroutine solve_coriolis_ele + end subroutine assemble_coriolis_ele - end subroutine coriolis_from_velocity + subroutine solve_coriolis_ele(ele, positions, velocity, coriolis, lump_rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(vector_field), intent(inout) :: coriolis + logical, intent(in) :: lump_rhs - subroutine interpolate_boundary_values(fields_a, positions_a, fields_b, positions_b, b_mesh, surface_element_list, b_fields) - !!< Consistently interpolate the values on the surface of fields_a onto the - !!< surface of fields_b. All of fields_a and fields_b must have the same - !!< continuous mesh. + integer, dimension(:), pointer :: nodes + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(coriolis, ele)) :: little_lumped_l + real, dimension(ele_loc(coriolis, ele), coriolis%dim) :: little_rhs + real, dimension(ele_loc(coriolis, ele), ele_loc(coriolis, ele)) :: little_mass + type(element_type), pointer :: shape - type(scalar_field), dimension(:), intent(inout) :: fields_a - type(vector_field), intent(inout) :: positions_a - type(scalar_field), dimension(size(fields_a)), target, intent(inout) :: fields_b - type(vector_field), intent(inout) :: positions_b - type(mesh_type), intent(inout) :: b_mesh - integer, dimension(:), intent(in) :: surface_element_list - type(scalar_field), dimension(size(fields_a)), intent(out) :: b_fields + call transform_to_physical(positions, ele, & + & detwei = detwei) - integer :: i, j, k - integer, dimension(:), allocatable :: eles - integer, dimension(:), pointer :: nodes - real, dimension(:, :), allocatable :: l_coords - type(vector_field) :: b_positions + shape => ele_shape(coriolis, ele) + + little_mass = shape_shape(shape, shape, detwei) + + if(lump_rhs) then + little_lumped_l = sum(shape_shape(shape, shape, detwei * two_omega(ele_val_at_quad(positions, ele))), 2) + assert(any(size(little_rhs, 2) == (/2, 3/))) + little_rhs(:, U_) = -little_lumped_l * ele_val(velocity, V_, ele) + little_rhs(:, V_) = little_lumped_l * ele_val(velocity, U_, ele) + if(size(little_rhs, 2) == 3) little_rhs(:, W_) = 0.0 + else + little_rhs = transpose(shape_vector_rhs(shape, coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(velocity, ele)), detwei)) + end if + + call solve(little_mass, little_rhs) + + nodes => ele_nodes(coriolis, ele) + call set(coriolis, nodes, transpose(little_rhs)) + + end subroutine solve_coriolis_ele + + end subroutine coriolis_from_velocity + + subroutine interpolate_boundary_values(fields_a, positions_a, fields_b, positions_b, b_mesh, surface_element_list, b_fields) + !!< Consistently interpolate the values on the surface of fields_a onto the + !!< surface of fields_b. All of fields_a and fields_b must have the same + !!< continuous mesh. + + type(scalar_field), dimension(:), intent(inout) :: fields_a + type(vector_field), intent(inout) :: positions_a + type(scalar_field), dimension(size(fields_a)), target, intent(inout) :: fields_b + type(vector_field), intent(inout) :: positions_b + type(mesh_type), intent(inout) :: b_mesh + integer, dimension(:), intent(in) :: surface_element_list + type(scalar_field), dimension(size(fields_a)), intent(out) :: b_fields + + integer :: i, j, k + integer, dimension(:), allocatable :: eles + integer, dimension(:), pointer :: nodes + real, dimension(:, :), allocatable :: l_coords + type(vector_field) :: b_positions #ifdef DDEBUG - assert(size(fields_a) > 0) - do i = 2, size(fields_a) - assert(fields_a(i)%mesh == fields_a(1)%mesh) - assert(fields_b(i)%mesh == fields_b(1)%mesh) - end do - assert(continuity(fields_b(1)) == 0) + assert(size(fields_a) > 0) + do i = 2, size(fields_a) + assert(fields_a(i)%mesh == fields_a(1)%mesh) + assert(fields_b(i)%mesh == fields_b(1)%mesh) + end do + assert(continuity(fields_b(1)) == 0) #endif - do i = 1, size(b_fields) - call allocate(b_fields(i), b_mesh, name = fields_b(i)%name) + do i = 1, size(b_fields) + call allocate(b_fields(i), b_mesh, name = fields_b(i)%name) #ifdef DDEBUG - call set(b_fields(i), huge(0.0)) + call set(b_fields(i), huge(0.0)) #endif - end do - - call allocate(b_positions, positions_b%dim, b_mesh, "SurfacePositions") - call remap_field_to_surface(positions_b, b_positions, surface_element_list) - - allocate(eles(face_loc(fields_b(1), 1))) - allocate(l_coords(ele_loc(positions_a, 1), ele_loc(b_positions, 1))) - do i = 1, ele_count(b_positions) - call picker_inquire(positions_a, ele_val(b_positions, i), eles, local_coords = l_coords, global = .false.) - assert(all(eles > 0)) - nodes => ele_nodes(b_mesh, i) - assert(size(nodes) == size(eles)) - do j = 1, size(eles) - do k = 1, size(b_fields) - call set(b_fields(k), nodes(j), eval_field(eles(j), fields_a(k), l_coords(:, j))) - end do end do - end do - deallocate(eles) - deallocate(l_coords) - call deallocate(b_positions) + call allocate(b_positions, positions_b%dim, b_mesh, "SurfacePositions") + call remap_field_to_surface(positions_b, b_positions, surface_element_list) + + allocate(eles(face_loc(fields_b(1), 1))) + allocate(l_coords(ele_loc(positions_a, 1), ele_loc(b_positions, 1))) + do i = 1, ele_count(b_positions) + call picker_inquire(positions_a, ele_val(b_positions, i), eles, local_coords = l_coords, global = .false.) + assert(all(eles > 0)) + nodes => ele_nodes(b_mesh, i) + assert(size(nodes) == size(eles)) + do j = 1, size(eles) + do k = 1, size(b_fields) + call set(b_fields(k), nodes(j), eval_field(eles(j), fields_a(k), l_coords(:, j))) + end do + end do + end do + deallocate(eles) + deallocate(l_coords) - end subroutine interpolate_boundary_values + call deallocate(b_positions) - subroutine derive_interpolated_p_dirichlet_single(base_p, base_positions, p, positions) - type(scalar_field), intent(in) :: base_p - type(vector_field), intent(inout) :: base_positions - type(scalar_field), intent(inout) :: p - type(vector_field), intent(inout) :: positions + end subroutine interpolate_boundary_values - type(scalar_field), dimension(1) :: lbase_p, lp + subroutine derive_interpolated_p_dirichlet_single(base_p, base_positions, p, positions) + type(scalar_field), intent(in) :: base_p + type(vector_field), intent(inout) :: base_positions + type(scalar_field), intent(inout) :: p + type(vector_field), intent(inout) :: positions - lbase_p = (/base_p/) - lp = (/p/) - call derive_interpolated_p_dirichlet(lbase_p, base_positions, lp, positions) - p = lp(1) + type(scalar_field), dimension(1) :: lbase_p, lp - end subroutine derive_interpolated_p_dirichlet_single + lbase_p = (/base_p/) + lp = (/p/) + call derive_interpolated_p_dirichlet(lbase_p, base_positions, lp, positions) + p = lp(1) - subroutine derive_interpolated_p_dirichlet_double(base_p_1, base_p_2, base_positions, p_1, p_2, positions) - type(scalar_field), intent(in) :: base_p_1 - type(scalar_field), intent(in) :: base_p_2 - type(vector_field), intent(inout) :: base_positions - type(scalar_field), intent(inout) :: p_1 - type(scalar_field), intent(inout) :: p_2 - type(vector_field), intent(inout) :: positions + end subroutine derive_interpolated_p_dirichlet_single - type(scalar_field), dimension(2) :: lbase_p, lp + subroutine derive_interpolated_p_dirichlet_double(base_p_1, base_p_2, base_positions, p_1, p_2, positions) + type(scalar_field), intent(in) :: base_p_1 + type(scalar_field), intent(in) :: base_p_2 + type(vector_field), intent(inout) :: base_positions + type(scalar_field), intent(inout) :: p_1 + type(scalar_field), intent(inout) :: p_2 + type(vector_field), intent(inout) :: positions - lbase_p = (/base_p_1, base_p_2/) - lp = (/p_1, p_2/) - call derive_interpolated_p_dirichlet(lbase_p, base_positions, lp, positions) - p_1 = lp(1) - p_2 = lp(2) + type(scalar_field), dimension(2) :: lbase_p, lp - end subroutine derive_interpolated_p_dirichlet_double + lbase_p = (/base_p_1, base_p_2/) + lp = (/p_1, p_2/) + call derive_interpolated_p_dirichlet(lbase_p, base_positions, lp, positions) + p_1 = lp(1) + p_2 = lp(2) - subroutine clear_boundary_conditions_scalar_single(field) - type(scalar_field), intent(inout) :: field + end subroutine derive_interpolated_p_dirichlet_double - type(scalar_field), dimension(1) :: lfield + subroutine clear_boundary_conditions_scalar_single(field) + type(scalar_field), intent(inout) :: field - lfield(1) = field - call clear_boundary_conditions(lfield) - field = lfield(1) + type(scalar_field), dimension(1) :: lfield - end subroutine clear_boundary_conditions_scalar_single + lfield(1) = field + call clear_boundary_conditions(lfield) + field = lfield(1) - subroutine clear_boundary_conditions_scalar_multiple(fields) - type(scalar_field), dimension(:), intent(inout) :: fields + end subroutine clear_boundary_conditions_scalar_single - integer :: i, j + subroutine clear_boundary_conditions_scalar_multiple(fields) + type(scalar_field), dimension(:), intent(inout) :: fields - do i = 1, size(fields) - if(associated(fields(i)%bc%boundary_condition)) then - do j = 1, size(fields(i)%bc%boundary_condition) - call deallocate(fields(i)%bc%boundary_condition(j)) - end do - deallocate(fields(i)%bc%boundary_condition) - end if - end do + integer :: i, j - end subroutine clear_boundary_conditions_scalar_multiple + do i = 1, size(fields) + if(associated(fields(i)%bc%boundary_condition)) then + do j = 1, size(fields(i)%bc%boundary_condition) + call deallocate(fields(i)%bc%boundary_condition(j)) + end do + deallocate(fields(i)%bc%boundary_condition) + end if + end do - subroutine derive_interpolated_p_dirichlet_multiple(base_ps, base_positions, ps, positions) - type(scalar_field), dimension(:), intent(inout) :: base_ps - type(vector_field), intent(inout) :: base_positions - type(scalar_field), dimension(size(base_ps)), intent(inout) :: ps - type(vector_field), intent(inout) :: positions + end subroutine clear_boundary_conditions_scalar_multiple - integer :: i - integer, dimension(:), pointer :: surface_element_list - integer, dimension(surface_element_count(positions)) :: surface_eles - type(scalar_field), dimension(size(ps)) :: b_ps - type(mesh_type), pointer :: b_mesh + subroutine derive_interpolated_p_dirichlet_multiple(base_ps, base_positions, ps, positions) + type(scalar_field), dimension(:), intent(inout) :: base_ps + type(vector_field), intent(inout) :: base_positions + type(scalar_field), dimension(size(base_ps)), intent(inout) :: ps + type(vector_field), intent(inout) :: positions + + integer :: i + integer, dimension(:), pointer :: surface_element_list + integer, dimension(surface_element_count(positions)) :: surface_eles + type(scalar_field), dimension(size(ps)) :: b_ps + type(mesh_type), pointer :: b_mesh #ifdef DDEBUG - assert(size(base_ps) > 0) - do i = 2, size(base_ps) - assert(base_ps(i)%mesh == base_ps(1)%mesh) - assert(ps(i)%mesh == ps(1)%mesh) - end do + assert(size(base_ps) > 0) + do i = 2, size(base_ps) + assert(base_ps(i)%mesh == base_ps(1)%mesh) + assert(ps(i)%mesh == ps(1)%mesh) + end do #endif - call clear_boundary_conditions(ps) + call clear_boundary_conditions(ps) - ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(ps(1)%name) - do i = 1, size(surface_eles) - surface_eles(i) = i - end do - call add_boundary_condition_surface_elements(ps(1), "InterpolatedBoundary", "dirichlet", surface_eles) - call get_boundary_condition(ps(1), 1, surface_mesh = b_mesh, & + ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(ps(1)%name) + do i = 1, size(surface_eles) + surface_eles(i) = i + end do + call add_boundary_condition_surface_elements(ps(1), "InterpolatedBoundary", "dirichlet", surface_eles) + call get_boundary_condition(ps(1), 1, surface_mesh = b_mesh, & & surface_element_list = surface_element_list) - call interpolate_boundary_values(base_ps, base_positions, ps, positions, b_mesh, surface_element_list, b_ps) - b_ps%name = "value" - ewrite_minmax(b_ps(1)) - call insert_surface_field(ps(1), 1, b_ps(1)) - call deallocate(b_ps(1)) - do i = 2, size(ps) - ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(ps(i)%name) - call add_boundary_condition_surface_elements(ps(i), "InterpolatedBoundary", "dirichlet", surface_eles) - ewrite_minmax(b_ps(i)) - call insert_surface_field(ps(i), 1, b_ps(i)) - call deallocate(b_ps(i)) - end do - - end subroutine derive_interpolated_p_dirichlet_multiple - - subroutine decompose_p_mean_single(matrices, base_p, positions, ps, solver_path, bc_p) - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(in) :: base_p - type(vector_field), intent(inout) :: positions - type(scalar_field), dimension(2), intent(inout) :: ps - character(len = *), intent(in) :: solver_path - type(scalar_field), optional, intent(inout) :: bc_p - - type(scalar_field), dimension(1) :: lbase_ps, lbc_ps - type(scalar_field), dimension(1, 2) :: lps - - lbase_ps(1) = base_p - lps(1, :) = ps - if(present(bc_p)) then - lbc_ps(1) = bc_p - call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) - else - call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path) - end if - ps = lps(1, :) - if(present(bc_p)) then - bc_p = lbc_ps(1) - end if - - end subroutine decompose_p_mean_single - - subroutine decompose_p_mean_double(matrices, base_p_1, base_p_2, positions, ps_1, ps_2, solver_path, bc_p_1, bc_p_2) - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(in) :: base_p_1 - type(scalar_field), intent(in) :: base_p_2 - type(vector_field), intent(inout) :: positions - type(scalar_field), dimension(2), intent(inout) :: ps_1 - type(scalar_field), dimension(2), intent(inout) :: ps_2 - character(len = *), intent(in) :: solver_path - type(scalar_field), optional, intent(inout) :: bc_p_1 - type(scalar_field), optional, intent(inout) :: bc_p_2 - - type(scalar_field), dimension(2) :: lbase_ps, lbc_ps - type(scalar_field), dimension(2, 2) :: lps - - lbase_ps(1) = base_p_1 - lbase_ps(2) = base_p_2 - lps(1, :) = ps_1 - lps(2, :) = ps_2 - if(present(bc_p_1)) then - assert(present(bc_p_2)) - lbc_ps(1) = bc_p_1 - lbc_ps(2) = bc_p_2 - call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) - else - call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path) - end if - ps_1 = lps(1, :) - ps_2 = lps(2, :) - if(present(bc_p_1)) then - assert(present(bc_p_2)) - bc_p_1 = lbc_ps(1) - bc_p_2 = lbc_ps(2) - end if - - end subroutine decompose_p_mean_double - - subroutine decompose_p_mean_multiple(matrices, base_ps, positions, ps, solver_path, bc_ps) - !!< Decompose a conservative potential into a part constant on the - !!< boundary and a residual, by taking a mean on the boundary - - type(cmc_matrices), target, intent(inout) :: matrices - type(scalar_field), dimension(:), intent(inout) :: base_ps - type(vector_field), intent(inout) :: positions - type(scalar_field), dimension(size(base_ps), 2), intent(inout) :: ps - character(len = *), intent(in) :: solver_path - !! Adds strong dirichlet bcs to these fields to impose the constant value - !! on the boundary used to decompose base_ps - type(scalar_field), dimension(size(base_ps)), optional, intent(inout) :: bc_ps - - integer :: i - integer, dimension(:), allocatable :: surface_eles - integer, dimension(:), pointer :: bc_surface_element_list - real :: surface_area - real, dimension(:), allocatable :: surface_means - type(mesh_type), pointer :: bc_mesh, mesh - type(scalar_field) :: bc_field - type(scalar_field) :: rhs - - ewrite(1, *) "In decompose_p_mean_multiple" + call interpolate_boundary_values(base_ps, base_positions, ps, positions, b_mesh, surface_element_list, b_ps) + b_ps%name = "value" + ewrite_minmax(b_ps(1)) + call insert_surface_field(ps(1), 1, b_ps(1)) + call deallocate(b_ps(1)) + do i = 2, size(ps) + ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(ps(i)%name) + call add_boundary_condition_surface_elements(ps(i), "InterpolatedBoundary", "dirichlet", surface_eles) + ewrite_minmax(b_ps(i)) + call insert_surface_field(ps(i), 1, b_ps(i)) + call deallocate(b_ps(i)) + end do + + end subroutine derive_interpolated_p_dirichlet_multiple + + subroutine decompose_p_mean_single(matrices, base_p, positions, ps, solver_path, bc_p) + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(in) :: base_p + type(vector_field), intent(inout) :: positions + type(scalar_field), dimension(2), intent(inout) :: ps + character(len = *), intent(in) :: solver_path + type(scalar_field), optional, intent(inout) :: bc_p + + type(scalar_field), dimension(1) :: lbase_ps, lbc_ps + type(scalar_field), dimension(1, 2) :: lps + + lbase_ps(1) = base_p + lps(1, :) = ps + if(present(bc_p)) then + lbc_ps(1) = bc_p + call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) + else + call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path) + end if + ps = lps(1, :) + if(present(bc_p)) then + bc_p = lbc_ps(1) + end if + + end subroutine decompose_p_mean_single + + subroutine decompose_p_mean_double(matrices, base_p_1, base_p_2, positions, ps_1, ps_2, solver_path, bc_p_1, bc_p_2) + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(in) :: base_p_1 + type(scalar_field), intent(in) :: base_p_2 + type(vector_field), intent(inout) :: positions + type(scalar_field), dimension(2), intent(inout) :: ps_1 + type(scalar_field), dimension(2), intent(inout) :: ps_2 + character(len = *), intent(in) :: solver_path + type(scalar_field), optional, intent(inout) :: bc_p_1 + type(scalar_field), optional, intent(inout) :: bc_p_2 + + type(scalar_field), dimension(2) :: lbase_ps, lbc_ps + type(scalar_field), dimension(2, 2) :: lps + + lbase_ps(1) = base_p_1 + lbase_ps(2) = base_p_2 + lps(1, :) = ps_1 + lps(2, :) = ps_2 + if(present(bc_p_1)) then + assert(present(bc_p_2)) + lbc_ps(1) = bc_p_1 + lbc_ps(2) = bc_p_2 + call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) + else + call decompose_p_mean(matrices, lbase_ps, positions, lps, solver_path) + end if + ps_1 = lps(1, :) + ps_2 = lps(2, :) + if(present(bc_p_1)) then + assert(present(bc_p_2)) + bc_p_1 = lbc_ps(1) + bc_p_2 = lbc_ps(2) + end if + + end subroutine decompose_p_mean_double + + subroutine decompose_p_mean_multiple(matrices, base_ps, positions, ps, solver_path, bc_ps) + !!< Decompose a conservative potential into a part constant on the + !!< boundary and a residual, by taking a mean on the boundary + + type(cmc_matrices), target, intent(inout) :: matrices + type(scalar_field), dimension(:), intent(inout) :: base_ps + type(vector_field), intent(inout) :: positions + type(scalar_field), dimension(size(base_ps), 2), intent(inout) :: ps + character(len = *), intent(in) :: solver_path + !! Adds strong dirichlet bcs to these fields to impose the constant value + !! on the boundary used to decompose base_ps + type(scalar_field), dimension(size(base_ps)), optional, intent(inout) :: bc_ps + + integer :: i + integer, dimension(:), allocatable :: surface_eles + integer, dimension(:), pointer :: bc_surface_element_list + real :: surface_area + real, dimension(:), allocatable :: surface_means + type(mesh_type), pointer :: bc_mesh, mesh + type(scalar_field) :: bc_field + type(scalar_field) :: rhs + + ewrite(1, *) "In decompose_p_mean_multiple" #ifdef DDEBUG - assert(size(base_ps) > 0) - assert(base_ps(1)%mesh == matrices%p_mesh) - do i = 2, size(base_ps) - assert(base_ps(i)%mesh == base_ps(1)%mesh) - assert(ps(i, 1)%mesh == ps(1, 1)%mesh) - assert(ps(i, 2)%mesh == ps(1, 1)%mesh) - end do - if(present(bc_ps)) then - do i = 2, size(bc_ps) - assert(bc_ps(i)%mesh == bc_ps(1)%mesh) + assert(size(base_ps) > 0) + assert(base_ps(1)%mesh == matrices%p_mesh) + do i = 2, size(base_ps) + assert(base_ps(i)%mesh == base_ps(1)%mesh) + assert(ps(i, 1)%mesh == ps(1, 1)%mesh) + assert(ps(i, 2)%mesh == ps(1, 1)%mesh) end do - end if + if(present(bc_ps)) then + do i = 2, size(bc_ps) + assert(bc_ps(i)%mesh == bc_ps(1)%mesh) + end do + end if #endif - if(positions%dim /= 2) then - ! Doing this for 3D unstructured meshes is very tricky - FLExit("Conservative potential decomposition only implemented for 2D") - end if + if(positions%dim /= 2) then + ! Doing this for 3D unstructured meshes is very tricky + FLExit("Conservative potential decomposition only implemented for 2D") + end if - mesh => matrices%p_mesh - assert(continuity(mesh) == 0) + mesh => matrices%p_mesh + assert(continuity(mesh) == 0) #ifdef DDEBUG - ! This test isn't cheap, so only perform it with debugging - if(connected_surfaces_count(mesh) /= 1) then - FLAbort("Conservative potential decomposition only implemented for simply connected domains") - end if + ! This test isn't cheap, so only perform it with debugging + if(connected_surfaces_count(mesh) /= 1) then + FLAbort("Conservative potential decomposition only implemented for simply connected domains") + end if #endif - ! Compute the mean surface value - allocate(surface_means(size(base_ps))) - surface_area = 0.0 - surface_means = 0.0 - do i = 1, surface_element_count(mesh) - call integrate_surface_element(i, base_ps, positions, & - & surface_area, surface_means) - end do - ewrite(2, *) "Surface area: ", surface_area - do i = 1, size(surface_means, 1) - surface_means(i) = surface_means(i) / surface_area - ewrite(2, *) "Surface mean for " // trim(base_ps(i)%name) // ": ", surface_means(i) - end do - - call allocate(rhs, mesh, name = "Rhs") - do i = 1, size(base_ps) - ! Assemble the projection RHS - assert(matrices%have_cmc_m) - call mult(rhs, matrices%cmc_m, base_ps(i)) - ewrite_minmax(rhs) + ! Compute the mean surface value + allocate(surface_means(size(base_ps))) + surface_area = 0.0 + surface_means = 0.0 + do i = 1, surface_element_count(mesh) + call integrate_surface_element(i, base_ps, positions, & + & surface_area, surface_means) + end do + ewrite(2, *) "Surface area: ", surface_area + do i = 1, size(surface_means, 1) + surface_means(i) = surface_means(i) / surface_area + ewrite(2, *) "Surface mean for " // trim(base_ps(i)%name) // ": ", surface_means(i) + end do - ! Compute the part constant on the boundary - call apply_cmc_boundary_value(matrices, rhs, surface_means(i)) - call petsc_solve(ps(i, 1), matrices%cmc_m, rhs, option_path = solver_path) - call cmc_solve_finalise(matrices) - end do - call deallocate(rhs) - - ! Compute the residual - do i = 1, size(ps, 1) - ewrite_minmax(ps(i, 1)) - ps(i, 2)%val = base_ps(i)%val - ps(i, 1)%val - ewrite_minmax(ps(i, 2)) - end do - - if(present(bc_ps)) then - ! Add strong dirichlet bcs to the part constant on the boundary - allocate(surface_eles(surface_element_count(bc_ps(1)))) - do i = 1, size(surface_eles) - surface_eles(i) = i + call allocate(rhs, mesh, name = "Rhs") + do i = 1, size(base_ps) + ! Assemble the projection RHS + assert(matrices%have_cmc_m) + call mult(rhs, matrices%cmc_m, base_ps(i)) + ewrite_minmax(rhs) + + ! Compute the part constant on the boundary + call apply_cmc_boundary_value(matrices, rhs, surface_means(i)) + call petsc_solve(ps(i, 1), matrices%cmc_m, rhs, option_path = solver_path) + call cmc_solve_finalise(matrices) end do - do i = 1, size(bc_ps, 1) - call clear_boundary_conditions(bc_ps(i)) - ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(bc_ps(i)%name) - call add_boundary_condition_surface_elements(bc_ps(i), "ConstantBoundary", "dirichlet", surface_eles) - call get_boundary_condition(bc_ps(i), 1, surface_mesh = bc_mesh, & - & surface_element_list = bc_surface_element_list) - call allocate(bc_field, bc_mesh, name = "value") - call set(bc_field, surface_means(i)) - call insert_surface_field(bc_ps(i), 1, bc_field) - call deallocate(bc_field) + call deallocate(rhs) + + ! Compute the residual + do i = 1, size(ps, 1) + ewrite_minmax(ps(i, 1)) + ps(i, 2)%val = base_ps(i)%val - ps(i, 1)%val + ewrite_minmax(ps(i, 2)) end do - deallocate(surface_eles) - end if - deallocate(surface_means) + if(present(bc_ps)) then + ! Add strong dirichlet bcs to the part constant on the boundary + allocate(surface_eles(surface_element_count(bc_ps(1)))) + do i = 1, size(surface_eles) + surface_eles(i) = i + end do + do i = 1, size(bc_ps, 1) + call clear_boundary_conditions(bc_ps(i)) + ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(bc_ps(i)%name) + call add_boundary_condition_surface_elements(bc_ps(i), "ConstantBoundary", "dirichlet", surface_eles) + call get_boundary_condition(bc_ps(i), 1, surface_mesh = bc_mesh, & + & surface_element_list = bc_surface_element_list) + call allocate(bc_field, bc_mesh, name = "value") + call set(bc_field, surface_means(i)) + call insert_surface_field(bc_ps(i), 1, bc_field) + call deallocate(bc_field) + end do + deallocate(surface_eles) + end if - ewrite(1, *) "Exiting decompose_p_mean_multiple" + deallocate(surface_means) - contains + ewrite(1, *) "Exiting decompose_p_mean_multiple" - subroutine integrate_surface_element(face, ps, positions, area, integrals) - integer, intent(in) :: face - type(scalar_field), dimension(:), intent(in) :: ps - type(vector_field), intent(in) :: positions - real, intent(inout) :: area - real, dimension(size(ps)), intent(inout) :: integrals + contains - integer :: i - real, dimension(face_ngi(positions, face)) :: detwei + subroutine integrate_surface_element(face, ps, positions, area, integrals) + integer, intent(in) :: face + type(scalar_field), dimension(:), intent(in) :: ps + type(vector_field), intent(in) :: positions + real, intent(inout) :: area + real, dimension(size(ps)), intent(inout) :: integrals - call transform_facet_to_physical(positions, face, & - & detwei_f = detwei) + integer :: i + real, dimension(face_ngi(positions, face)) :: detwei - area = area + abs(sum(detwei)) - do i = 1, size(ps) - integrals(i) = integrals(i) + dot_product(face_val_at_quad(ps(i), face), detwei) - end do + call transform_facet_to_physical(positions, face, & + & detwei_f = detwei) + + area = area + abs(sum(detwei)) + do i = 1, size(ps) + integrals(i) = integrals(i) + dot_product(face_val_at_quad(ps(i), face), detwei) + end do + + end subroutine integrate_surface_element + + end subroutine decompose_p_mean_multiple - end subroutine integrate_surface_element - - end subroutine decompose_p_mean_multiple - - subroutine decompose_p_optimal_single(matrices, base_p, positions, ps, solver_path, bc_p) - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(in) :: base_p - type(vector_field), intent(inout) :: positions - type(scalar_field), dimension(2), intent(inout) :: ps - character(len = *), intent(in) :: solver_path - type(scalar_field), optional, intent(inout) :: bc_p - - type(scalar_field), dimension(1) :: lbase_ps, lbc_ps - type(scalar_field), dimension(1, 2) :: lps - - lbase_ps(1) = base_p - lps(1, :) = ps - if(present(bc_p)) then - lbc_ps(1) = bc_p - call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) - else - call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path) - end if - ps = lps(1, :) - if(present(bc_p)) then - bc_p = lbc_ps(1) - end if - - end subroutine decompose_p_optimal_single - - subroutine decompose_p_optimal_double(matrices, base_p_1, base_p_2, positions, ps_1, ps_2, solver_path, bc_p_1, bc_p_2) - type(cmc_matrices), intent(inout) :: matrices - type(scalar_field), intent(in) :: base_p_1 - type(scalar_field), intent(in) :: base_p_2 - type(vector_field), intent(inout) :: positions - type(scalar_field), dimension(2), intent(inout) :: ps_1 - type(scalar_field), dimension(2), intent(inout) :: ps_2 - character(len = *), intent(in) :: solver_path - type(scalar_field), optional, intent(inout) :: bc_p_1 - type(scalar_field), optional, intent(inout) :: bc_p_2 - - type(scalar_field), dimension(2) :: lbase_ps, lbc_ps - type(scalar_field), dimension(2, 2) :: lps - - lbase_ps(1) = base_p_1 - lbase_ps(2) = base_p_2 - lps(1, :) = ps_1 - lps(2, :) = ps_2 - if(present(bc_p_1)) then - assert(present(bc_p_2)) - lbc_ps(1) = bc_p_1 - lbc_ps(2) = bc_p_2 - call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) - else - call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path) - end if - ps_1 = lps(1, :) - ps_2 = lps(2, :) - if(present(bc_p_1)) then - assert(present(bc_p_2)) - bc_p_1 = lbc_ps(1) - bc_p_2 = lbc_ps(2) - end if - - end subroutine decompose_p_optimal_double - - subroutine decompose_p_optimal_multiple(matrices, base_ps, positions, ps, solver_path, bc_ps) - !!< Decompose a conservative potential into a part constant on the - !!< boundary and a residual, by minimising the L2 norm of the residual - - type(cmc_matrices), target, intent(inout) :: matrices - type(scalar_field), dimension(:), intent(inout) :: base_ps - type(vector_field), intent(inout) :: positions - type(scalar_field), dimension(size(base_ps), 2), intent(inout) :: ps - character(len = *), intent(in) :: solver_path - !! Adds strong dirichlet bcs to these fields to impose the constant value - !! on the boundary used to decompose base_ps - type(scalar_field), dimension(size(base_ps)), optional, intent(inout) :: bc_ps - - integer :: i - integer, dimension(:), allocatable :: surface_eles - integer, dimension(:), pointer :: bc_surface_element_list - real :: denom - real, dimension(size(base_ps)) :: num, c - type(mesh_type), pointer :: bc_mesh, mesh - type(scalar_field) :: bc_field - type(scalar_field) :: p_1 - type(scalar_field) :: rhs - - ewrite(1, *) "In decompose_p_optimal_multiple" + subroutine decompose_p_optimal_single(matrices, base_p, positions, ps, solver_path, bc_p) + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(in) :: base_p + type(vector_field), intent(inout) :: positions + type(scalar_field), dimension(2), intent(inout) :: ps + character(len = *), intent(in) :: solver_path + type(scalar_field), optional, intent(inout) :: bc_p + + type(scalar_field), dimension(1) :: lbase_ps, lbc_ps + type(scalar_field), dimension(1, 2) :: lps + + lbase_ps(1) = base_p + lps(1, :) = ps + if(present(bc_p)) then + lbc_ps(1) = bc_p + call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) + else + call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path) + end if + ps = lps(1, :) + if(present(bc_p)) then + bc_p = lbc_ps(1) + end if + + end subroutine decompose_p_optimal_single + + subroutine decompose_p_optimal_double(matrices, base_p_1, base_p_2, positions, ps_1, ps_2, solver_path, bc_p_1, bc_p_2) + type(cmc_matrices), intent(inout) :: matrices + type(scalar_field), intent(in) :: base_p_1 + type(scalar_field), intent(in) :: base_p_2 + type(vector_field), intent(inout) :: positions + type(scalar_field), dimension(2), intent(inout) :: ps_1 + type(scalar_field), dimension(2), intent(inout) :: ps_2 + character(len = *), intent(in) :: solver_path + type(scalar_field), optional, intent(inout) :: bc_p_1 + type(scalar_field), optional, intent(inout) :: bc_p_2 + + type(scalar_field), dimension(2) :: lbase_ps, lbc_ps + type(scalar_field), dimension(2, 2) :: lps + + lbase_ps(1) = base_p_1 + lbase_ps(2) = base_p_2 + lps(1, :) = ps_1 + lps(2, :) = ps_2 + if(present(bc_p_1)) then + assert(present(bc_p_2)) + lbc_ps(1) = bc_p_1 + lbc_ps(2) = bc_p_2 + call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path, bc_ps = lbc_ps) + else + call decompose_p_optimal(matrices, lbase_ps, positions, lps, solver_path) + end if + ps_1 = lps(1, :) + ps_2 = lps(2, :) + if(present(bc_p_1)) then + assert(present(bc_p_2)) + bc_p_1 = lbc_ps(1) + bc_p_2 = lbc_ps(2) + end if + + end subroutine decompose_p_optimal_double + + subroutine decompose_p_optimal_multiple(matrices, base_ps, positions, ps, solver_path, bc_ps) + !!< Decompose a conservative potential into a part constant on the + !!< boundary and a residual, by minimising the L2 norm of the residual + + type(cmc_matrices), target, intent(inout) :: matrices + type(scalar_field), dimension(:), intent(inout) :: base_ps + type(vector_field), intent(inout) :: positions + type(scalar_field), dimension(size(base_ps), 2), intent(inout) :: ps + character(len = *), intent(in) :: solver_path + !! Adds strong dirichlet bcs to these fields to impose the constant value + !! on the boundary used to decompose base_ps + type(scalar_field), dimension(size(base_ps)), optional, intent(inout) :: bc_ps + + integer :: i + integer, dimension(:), allocatable :: surface_eles + integer, dimension(:), pointer :: bc_surface_element_list + real :: denom + real, dimension(size(base_ps)) :: num, c + type(mesh_type), pointer :: bc_mesh, mesh + type(scalar_field) :: bc_field + type(scalar_field) :: p_1 + type(scalar_field) :: rhs + + ewrite(1, *) "In decompose_p_optimal_multiple" #ifdef DDEBUG - assert(size(base_ps) > 0) - assert(base_ps(1)%mesh == matrices%p_mesh) - do i = 2, size(base_ps) - assert(base_ps(i)%mesh == base_ps(1)%mesh) - assert(ps(i, 1)%mesh == ps(1, 1)%mesh) - assert(ps(i, 2)%mesh == ps(1, 1)%mesh) - end do - if(present(bc_ps)) then - do i = 2, size(bc_ps) - assert(bc_ps(i)%mesh == bc_ps(1)%mesh) + assert(size(base_ps) > 0) + assert(base_ps(1)%mesh == matrices%p_mesh) + do i = 2, size(base_ps) + assert(base_ps(i)%mesh == base_ps(1)%mesh) + assert(ps(i, 1)%mesh == ps(1, 1)%mesh) + assert(ps(i, 2)%mesh == ps(1, 1)%mesh) end do - end if + if(present(bc_ps)) then + do i = 2, size(bc_ps) + assert(bc_ps(i)%mesh == bc_ps(1)%mesh) + end do + end if #endif - if(positions%dim /= 2) then - ! Doing this for 3D unstructured meshes is very tricky - FLExit("Conservative potential decomposition only implemented for 2D") - end if + if(positions%dim /= 2) then + ! Doing this for 3D unstructured meshes is very tricky + FLExit("Conservative potential decomposition only implemented for 2D") + end if - mesh => matrices%p_mesh - assert(continuity(mesh) == 0) + mesh => matrices%p_mesh + assert(continuity(mesh) == 0) #ifdef DDEBUG - ! This test isn't cheap, so only perform it with debugging - if(connected_surfaces_count(mesh) /= 1) then - FLAbort("Conservative potential decomposition only implemented for simply connected domains") - end if + ! This test isn't cheap, so only perform it with debugging + if(connected_surfaces_count(mesh) /= 1) then + FLAbort("Conservative potential decomposition only implemented for simply connected domains") + end if #endif - call allocate(rhs, mesh, name = "Rhs") - do i = 1, size(base_ps) - ! Assemble the projection RHS - assert(matrices%have_cmc_m) - call mult(rhs, matrices%cmc_m, base_ps(i)) - ewrite_minmax(rhs) + call allocate(rhs, mesh, name = "Rhs") + do i = 1, size(base_ps) + ! Assemble the projection RHS + assert(matrices%have_cmc_m) + call mult(rhs, matrices%cmc_m, base_ps(i)) + ewrite_minmax(rhs) + + ! Compute the part zero on the boundary + call apply_cmc_boundary_value(matrices, rhs, 0.0) + call petsc_solve(ps(i, 1), matrices%cmc_m, rhs, option_path = solver_path) + call cmc_solve_finalise(matrices) + end do + + call allocate(p_1, mesh, "ZeroBoundaryOne") + call zero(p_1) + call zero(rhs) - ! Compute the part zero on the boundary - call apply_cmc_boundary_value(matrices, rhs, 0.0) - call petsc_solve(ps(i, 1), matrices%cmc_m, rhs, option_path = solver_path) + ! Compute the part one on the boundary and zero elsewhere + call apply_cmc_boundary_value(matrices, rhs, 1.0) + call petsc_solve(p_1, matrices%cmc_m, rhs, option_path = solver_path) call cmc_solve_finalise(matrices) - end do - - call allocate(p_1, mesh, "ZeroBoundaryOne") - call zero(p_1) - call zero(rhs) - - ! Compute the part one on the boundary and zero elsewhere - call apply_cmc_boundary_value(matrices, rhs, 1.0) - call petsc_solve(p_1, matrices%cmc_m, rhs, option_path = solver_path) - call cmc_solve_finalise(matrices) - call deallocate(rhs) - - ! Compute the boundary value that minimises the l2 norm of the residual - num = 0.0 - denom = 0.0 - do i = 1, ele_count(mesh) - call add_inner_products_ele(i, positions, base_ps, ps(:, 1), p_1, num, denom) - end do - c = num / denom - - ! Compute the part constant on the boundary - do i = 1, size(base_ps) - ewrite(2, *) "Boundary value for " // trim(base_ps(i)%name) // ": ", c(i) - call addto(ps(i, 1), p_1, scale = c(i)) - ewrite_minmax(ps(i, 1)) - end do - call deallocate(p_1) - - ! Compute the residual - do i = 1, size(ps, 1) - ps(i, 2)%val = base_ps(i)%val - ps(i, 1)%val - ewrite_minmax(ps(i, 2)) - end do - - if(present(bc_ps)) then - ! Add strong dirichlet bcs to the part constant on the boundary - allocate(surface_eles(surface_element_count(bc_ps(1)))) - do i = 1, size(surface_eles) - surface_eles(i) = i + call deallocate(rhs) + + ! Compute the boundary value that minimises the l2 norm of the residual + num = 0.0 + denom = 0.0 + do i = 1, ele_count(mesh) + call add_inner_products_ele(i, positions, base_ps, ps(:, 1), p_1, num, denom) end do - do i = 1, size(bc_ps, 1) - call clear_boundary_conditions(bc_ps(i)) - ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(bc_ps(i)%name) - call add_boundary_condition_surface_elements(bc_ps(i), "ConstantBoundary", "dirichlet", surface_eles) - call get_boundary_condition(bc_ps(i), 1, surface_mesh = bc_mesh, & - & surface_element_list = bc_surface_element_list) - call allocate(bc_field, bc_mesh, name = "value") - call set(bc_field, c(i)) - call insert_surface_field(bc_ps(i), 1, bc_field) - call deallocate(bc_field) + c = num / denom + + ! Compute the part constant on the boundary + do i = 1, size(base_ps) + ewrite(2, *) "Boundary value for " // trim(base_ps(i)%name) // ": ", c(i) + call addto(ps(i, 1), p_1, scale = c(i)) + ewrite_minmax(ps(i, 1)) end do - deallocate(surface_eles) - end if + call deallocate(p_1) - ewrite(1, *) "Exiting decompose_p_optimal_multiple" + ! Compute the residual + do i = 1, size(ps, 1) + ps(i, 2)%val = base_ps(i)%val - ps(i, 1)%val + ewrite_minmax(ps(i, 2)) + end do - contains + if(present(bc_ps)) then + ! Add strong dirichlet bcs to the part constant on the boundary + allocate(surface_eles(surface_element_count(bc_ps(1)))) + do i = 1, size(surface_eles) + surface_eles(i) = i + end do + do i = 1, size(bc_ps, 1) + call clear_boundary_conditions(bc_ps(i)) + ewrite(2, *) "Adding strong Dirichlet bc for field " // trim(bc_ps(i)%name) + call add_boundary_condition_surface_elements(bc_ps(i), "ConstantBoundary", "dirichlet", surface_eles) + call get_boundary_condition(bc_ps(i), 1, surface_mesh = bc_mesh, & + & surface_element_list = bc_surface_element_list) + call allocate(bc_field, bc_mesh, name = "value") + call set(bc_field, c(i)) + call insert_surface_field(bc_ps(i), 1, bc_field) + call deallocate(bc_field) + end do + deallocate(surface_eles) + end if - subroutine add_inner_products_ele(ele, positions, p, p_0, p_1, num, denom) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), dimension(:), intent(in) :: p - type(scalar_field), dimension(size(p)), intent(in) :: p_0 - type(scalar_field), intent(in) :: p_1 - real, dimension(size(p)), intent(inout) :: num - real, intent(inout) :: denom + ewrite(1, *) "Exiting decompose_p_optimal_multiple" - integer :: i - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(p(1), ele), ele_loc(p(1), ele)) :: little_mass - type(element_type), pointer :: shape + contains - call transform_to_physical(positions, ele, & - & detwei = detwei) + subroutine add_inner_products_ele(ele, positions, p, p_0, p_1, num, denom) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), dimension(:), intent(in) :: p + type(scalar_field), dimension(size(p)), intent(in) :: p_0 + type(scalar_field), intent(in) :: p_1 + real, dimension(size(p)), intent(inout) :: num + real, intent(inout) :: denom - shape => ele_shape(p(1), ele) - little_mass = shape_shape(shape, shape, detwei) + integer :: i + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(p(1), ele), ele_loc(p(1), ele)) :: little_mass + type(element_type), pointer :: shape - do i = 1, size(p) - num(i) = num(i) + dot_product(ele_val(p_1, ele), matmul(little_mass, ele_val(p(i), ele) - ele_val(p_0(i), ele))) - end do - denom = denom + dot_product(ele_val(p_1, ele), matmul(little_mass, ele_val(p_1, ele))) + call transform_to_physical(positions, ele, & + & detwei = detwei) + + shape => ele_shape(p(1), ele) + little_mass = shape_shape(shape, shape, detwei) - end subroutine add_inner_products_ele + do i = 1, size(p) + num(i) = num(i) + dot_product(ele_val(p_1, ele), matmul(little_mass, ele_val(p(i), ele) - ele_val(p_0(i), ele))) + end do + denom = denom + dot_product(ele_val(p_1, ele), matmul(little_mass, ele_val(p_1, ele))) - end subroutine decompose_p_optimal_multiple + end subroutine add_inner_products_ele - subroutine initialise_geostrophic_interpolation_states(old_states, new_states) - !!< Set up a state for geostrophic interpolation + end subroutine decompose_p_optimal_multiple - type(state_type), dimension(:), intent(inout) :: old_states - type(state_type), dimension(size(old_states)), intent(inout) :: new_states + subroutine initialise_geostrophic_interpolation_states(old_states, new_states) + !!< Set up a state for geostrophic interpolation - integer :: i, j, stat - type(vector_field), pointer :: new_velocity, old_velocity + type(state_type), dimension(:), intent(inout) :: old_states + type(state_type), dimension(size(old_states)), intent(inout) :: new_states - do i = 1, size(new_states) - do j = 1, vector_field_count(new_states(i)) - new_velocity => extract_vector_field(new_states(i), j) - if(have_option(trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation")) then - old_velocity => extract_vector_field(old_states(i), new_velocity%name) - call initialise_geostrophic_interpolation(old_states(i), old_velocity, new_states(i), new_velocity) - end if + integer :: i, j, stat + type(vector_field), pointer :: new_velocity, old_velocity + + do i = 1, size(new_states) + do j = 1, vector_field_count(new_states(i)) + new_velocity => extract_vector_field(new_states(i), j) + if(have_option(trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation")) then + old_velocity => extract_vector_field(old_states(i), new_velocity%name) + call initialise_geostrophic_interpolation(old_states(i), old_velocity, new_states(i), new_velocity) + end if + end do end do - end do - - end subroutine initialise_geostrophic_interpolation_states - - subroutine insert_for_interpolation_scalar(old_state, old_field) - !!< Insert a field for interpolation, and deallocate the field. This checks - !!< for namespace clashes. - - type(state_type), intent(inout) :: old_state - type(scalar_field), intent(inout) :: old_field - - if(has_scalar_field(old_state, old_field%name)) then - ewrite(-1, *) "For scalar field with name: " // trim(old_field%name) - ewrite(-1, *) "Field already exists in state" - FLAbort("Unable to insert field for interpolation") - end if - call insert(old_state, old_field, old_field%name) - call deallocate(old_field) - - end subroutine insert_for_interpolation_scalar - - subroutine insert_for_interpolation_vector(old_state, old_field) - !!< Insert a field for interpolation, and deallocate the field. This checks - !!< for namespace clashes. - - type(state_type), intent(inout) :: old_state - type(vector_field), intent(inout) :: old_field - - if(has_vector_field(old_state, old_field%name)) then - ewrite(-1, *) "For vector field with name: " // trim(old_field%name) - ewrite(-1, *) "Field already exists in state" - FLAbort("Unable to insert field for interpolation") - end if - call insert(old_state, old_field, old_field%name) - call deallocate(old_field) - - end subroutine insert_for_interpolation_vector - - subroutine initialise_geostrophic_interpolation_velocity(old_state, old_velocity, new_state, new_velocity) - !!< Set up a state for geostrophic interpolation - - type(state_type), intent(inout) :: old_state - type(vector_field), target, intent(inout) :: old_velocity - type(state_type), intent(inout) :: new_state - type(vector_field), target, intent(inout) :: new_velocity - - character(len = OPTION_PATH_LEN) :: base_path, u_mesh_name, p_mesh_name - integer :: dim, stat - type(cmc_matrices) :: aux_matrices, matrices - type(mesh_type), pointer :: new_p_mesh, new_u_mesh, old_p_mesh, old_u_mesh - type(scalar_field) :: new_p, old_w, old_p, new_w - type(vector_field) :: coriolis, conserv, new_res, old_res - type(vector_field), pointer :: old_bc_velocity, new_positions, old_positions - - logical :: gp - character(len = OPTION_PATH_LEN) :: gp_mesh_name - type(mesh_type), pointer :: new_gp_mesh, old_gp_mesh - type(scalar_field) :: new_gp, old_gp - - logical :: aux_p - character(len = OPTION_PATH_LEN) :: aux_p_name - real :: aux_p_scale - type(scalar_field), pointer :: new_aux_p, old_aux_p - - logical :: decompose_p - type(scalar_field), dimension(2) :: new_p_decomp, old_p_decomp - type(scalar_field), dimension(2) :: new_aux_p_decomp, old_aux_p_decomp - - logical :: debug_vtus - integer :: max_vtu_count - integer, save :: vtu_index = 0 - type(scalar_field) :: div - - ewrite(1, *) "In initialise_geostrophic_interpolation_velocity" - ewrite(2, *) "Input field: " // trim(new_velocity%name) - ewrite(2, *) "In state: " // trim(new_state%name) - - base_path = trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation" - ewrite(2, *) "Option path: " // trim(base_path) - debug_vtus = have_option(trim(base_path) // "/debug/write_debug_vtus") - - old_positions => extract_vector_field(old_state, "Coordinate") - new_positions => extract_vector_field(new_state, "Coordinate") - dim = old_positions%dim - assert(any(dim == (/2, 3/))) - - call get_option(trim(base_path) // "/coriolis/mesh/name", u_mesh_name, stat = stat) - if(stat == SPUD_NO_ERROR) then - old_u_mesh => extract_mesh(old_state, u_mesh_name) - new_u_mesh => extract_mesh(new_state, u_mesh_name) - allocate(old_bc_velocity) - call allocate(old_bc_velocity, old_velocity%dim, old_u_mesh, old_velocity%name) - old_bc_velocity%option_path = old_velocity%option_path - call zero(old_bc_velocity) - call populate_vector_boundary_conditions(old_state, old_bc_velocity, trim(complete_field_path(old_bc_velocity%option_path)) // "/boundary_conditions", old_positions) - else - old_u_mesh => old_velocity%mesh - new_u_mesh => new_velocity%mesh - allocate(old_bc_velocity) - old_bc_velocity = old_velocity - call incref(old_bc_velocity) - end if - call get_option(trim(base_path) // "/conservative_potential/mesh/name", p_mesh_name) - old_p_mesh => extract_mesh(old_state, p_mesh_name) - new_p_mesh => extract_mesh(new_state, p_mesh_name) - - ! Compute the old Coriolis - - call allocate(coriolis, dim, old_u_mesh, "Coriolis") - coriolis%option_path = old_velocity%option_path - call zero(coriolis) - call coriolis_from_velocity(old_state, old_velocity, coriolis, & + + end subroutine initialise_geostrophic_interpolation_states + + subroutine insert_for_interpolation_scalar(old_state, old_field) + !!< Insert a field for interpolation, and deallocate the field. This checks + !!< for namespace clashes. + + type(state_type), intent(inout) :: old_state + type(scalar_field), intent(inout) :: old_field + + if(has_scalar_field(old_state, old_field%name)) then + ewrite(-1, *) "For scalar field with name: " // trim(old_field%name) + ewrite(-1, *) "Field already exists in state" + FLAbort("Unable to insert field for interpolation") + end if + call insert(old_state, old_field, old_field%name) + call deallocate(old_field) + + end subroutine insert_for_interpolation_scalar + + subroutine insert_for_interpolation_vector(old_state, old_field) + !!< Insert a field for interpolation, and deallocate the field. This checks + !!< for namespace clashes. + + type(state_type), intent(inout) :: old_state + type(vector_field), intent(inout) :: old_field + + if(has_vector_field(old_state, old_field%name)) then + ewrite(-1, *) "For vector field with name: " // trim(old_field%name) + ewrite(-1, *) "Field already exists in state" + FLAbort("Unable to insert field for interpolation") + end if + call insert(old_state, old_field, old_field%name) + call deallocate(old_field) + + end subroutine insert_for_interpolation_vector + + subroutine initialise_geostrophic_interpolation_velocity(old_state, old_velocity, new_state, new_velocity) + !!< Set up a state for geostrophic interpolation + + type(state_type), intent(inout) :: old_state + type(vector_field), target, intent(inout) :: old_velocity + type(state_type), intent(inout) :: new_state + type(vector_field), target, intent(inout) :: new_velocity + + character(len = OPTION_PATH_LEN) :: base_path, u_mesh_name, p_mesh_name + integer :: dim, stat + type(cmc_matrices) :: aux_matrices, matrices + type(mesh_type), pointer :: new_p_mesh, new_u_mesh, old_p_mesh, old_u_mesh + type(scalar_field) :: new_p, old_w, old_p, new_w + type(vector_field) :: coriolis, conserv, new_res, old_res + type(vector_field), pointer :: old_bc_velocity, new_positions, old_positions + + logical :: gp + character(len = OPTION_PATH_LEN) :: gp_mesh_name + type(mesh_type), pointer :: new_gp_mesh, old_gp_mesh + type(scalar_field) :: new_gp, old_gp + + logical :: aux_p + character(len = OPTION_PATH_LEN) :: aux_p_name + real :: aux_p_scale + type(scalar_field), pointer :: new_aux_p, old_aux_p + + logical :: decompose_p + type(scalar_field), dimension(2) :: new_p_decomp, old_p_decomp + type(scalar_field), dimension(2) :: new_aux_p_decomp, old_aux_p_decomp + + logical :: debug_vtus + integer :: max_vtu_count + integer, save :: vtu_index = 0 + type(scalar_field) :: div + + ewrite(1, *) "In initialise_geostrophic_interpolation_velocity" + ewrite(2, *) "Input field: " // trim(new_velocity%name) + ewrite(2, *) "In state: " // trim(new_state%name) + + base_path = trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation" + ewrite(2, *) "Option path: " // trim(base_path) + debug_vtus = have_option(trim(base_path) // "/debug/write_debug_vtus") + + old_positions => extract_vector_field(old_state, "Coordinate") + new_positions => extract_vector_field(new_state, "Coordinate") + dim = old_positions%dim + assert(any(dim == (/2, 3/))) + + call get_option(trim(base_path) // "/coriolis/mesh/name", u_mesh_name, stat = stat) + if(stat == SPUD_NO_ERROR) then + old_u_mesh => extract_mesh(old_state, u_mesh_name) + new_u_mesh => extract_mesh(new_state, u_mesh_name) + allocate(old_bc_velocity) + call allocate(old_bc_velocity, old_velocity%dim, old_u_mesh, old_velocity%name) + old_bc_velocity%option_path = old_velocity%option_path + call zero(old_bc_velocity) + call populate_vector_boundary_conditions(old_state, old_bc_velocity, trim(complete_field_path(old_bc_velocity%option_path)) // "/boundary_conditions", old_positions) + else + old_u_mesh => old_velocity%mesh + new_u_mesh => new_velocity%mesh + allocate(old_bc_velocity) + old_bc_velocity = old_velocity + call incref(old_bc_velocity) + end if + call get_option(trim(base_path) // "/conservative_potential/mesh/name", p_mesh_name) + old_p_mesh => extract_mesh(old_state, p_mesh_name) + new_p_mesh => extract_mesh(new_state, p_mesh_name) + + ! Compute the old Coriolis + + call allocate(coriolis, dim, old_u_mesh, "Coriolis") + coriolis%option_path = old_velocity%option_path + call zero(coriolis) + call coriolis_from_velocity(old_state, old_velocity, coriolis, & & lump_mass = have_option(trim(base_path) // "/coriolis/velocity_to_coriolis/lump_mass"), & & lump_rhs = have_option(trim(base_path) // "/coriolis/velocity_to_coriolis/lump_rhs"), & & solver_path = trim(base_path) // "/coriolis/velocity_to_coriolis") - call allocate(old_p, old_p_mesh, gi_conservative_potential_name) - old_p%option_path = trim(base_path) // "/conservative_potential" - call allocate(old_res, dim, old_u_mesh, gi_res_name) - old_res%option_path = trim(base_path) // "/residual" - aux_p = have_option(trim(base_path) // "/conservative_potential/project_pressure") - if(aux_p) then - call get_option(trim(base_path) // "/conservative_potential/project_pressure/name", aux_p_name) - old_aux_p => extract_scalar_field(old_state, aux_p_name) - new_aux_p => extract_scalar_field(new_state, aux_p_name) - - call get_option(trim(base_path) // "/conservative_potential/project_pressure/scale_factor", aux_p_scale, stat = stat) - if(stat == SPUD_NO_ERROR) then - ewrite(2, *) "Applying pressure scale factor: ", aux_p_scale - call scale(old_aux_p, aux_p_scale) + call allocate(old_p, old_p_mesh, gi_conservative_potential_name) + old_p%option_path = trim(base_path) // "/conservative_potential" + call allocate(old_res, dim, old_u_mesh, gi_res_name) + old_res%option_path = trim(base_path) // "/residual" + aux_p = have_option(trim(base_path) // "/conservative_potential/project_pressure") + if(aux_p) then + call get_option(trim(base_path) // "/conservative_potential/project_pressure/name", aux_p_name) + old_aux_p => extract_scalar_field(old_state, aux_p_name) + new_aux_p => extract_scalar_field(new_state, aux_p_name) + + call get_option(trim(base_path) // "/conservative_potential/project_pressure/scale_factor", aux_p_scale, stat = stat) + if(stat == SPUD_NO_ERROR) then + ewrite(2, *) "Applying pressure scale factor: ", aux_p_scale + call scale(old_aux_p, aux_p_scale) + end if end if - end if - ! Perform a Helmholz decomposition of the old Coriolis + ! Perform a Helmholz decomposition of the old Coriolis - gp = have_option(trim(base_path) // "/geopressure") - if(gp) then - call get_option(trim(base_path) // "/geopressure/mesh/name", gp_mesh_name) - old_gp_mesh => extract_mesh(old_state, gp_mesh_name) - new_gp_mesh => extract_mesh(new_state, gp_mesh_name) + gp = have_option(trim(base_path) // "/geopressure") + if(gp) then + call get_option(trim(base_path) // "/geopressure/mesh/name", gp_mesh_name) + old_gp_mesh => extract_mesh(old_state, gp_mesh_name) + new_gp_mesh => extract_mesh(new_state, gp_mesh_name) - call allocate(old_gp, old_gp_mesh, gi_gp_conservative_potential_name) - old_gp%option_path = trim(base_path) // "/geopressure" - end if + call allocate(old_gp, old_gp_mesh, gi_gp_conservative_potential_name) + old_gp%option_path = trim(base_path) // "/geopressure" + end if - ! Set up initial guesses - if(aux_p) then - ! Use the Pressure field as an initial guess for the conservative - ! potential - if(gp) then - call remap_field(old_aux_p, old_gp) - call zero(old_p) - else - call remap_field(old_aux_p, old_p) - end if - else - ! Use zero initial guess - if(gp) call zero(old_gp) - call zero(old_p) - end if - - call set(old_res, coriolis) - call allocate(conserv, dim, old_u_mesh, name = "CoriolisConservative") - if(gp) then - call geopressure_decomposition(old_state, coriolis, old_gp) - call projection_decomposition(old_state, coriolis, old_p, bcfield = old_bc_velocity, matrices = matrices, gp = old_gp) - call correct_velocity(matrices, old_res, old_p, conserv = conserv, gp = old_gp) - else - call projection_decomposition(old_state, coriolis, old_p, bcfield = old_bc_velocity, matrices = matrices) - call correct_velocity(matrices, old_res, old_p, conserv = conserv) - end if - - if(debug_vtus) then - if(old_velocity%mesh == old_u_mesh) then - call allocate(div, old_p_mesh, trim(old_velocity%name) // "Divergence") - call set_solver_options(temp_solver_path, ksptype = "cg", pctype = "sor", rtol = 0.0, atol = epsilon(0.0), max_its = 10000) - div%option_path = temp_solver_path - call zero(div) - call compute_divergence(old_velocity, matrices%ct_m, get_mass_matrix(old_state, old_p_mesh), div) - if(gp) then - call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & - & sfields = (/old_p, old_gp, div/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) - else - call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & - & sfields = (/old_p, div/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) - end if - if(stat /= 0) then - ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat - end if - call delete_option(div%option_path) - call deallocate(div) + ! Set up initial guesses + if(aux_p) then + ! Use the Pressure field as an initial guess for the conservative + ! potential + if(gp) then + call remap_field(old_aux_p, old_gp) + call zero(old_p) + else + call remap_field(old_aux_p, old_p) + end if else - if(gp) then - call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & - & sfields = (/old_p, old_gp/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) - else - call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & - & sfields = (/old_p/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) - end if - if(stat /= 0) then - ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat - end if - end if - end if - call deallocate(conserv) - - ! Insert the horizontal Velocity residual - - call allocate(new_res, dim, new_u_mesh, old_res%name) - new_res%option_path = old_res%option_path - - call insert_for_interpolation(old_state, old_res) - call insert_for_interpolation(new_state, new_res) - if(dim == 3) then - ! Insert the vertical Velocity - call allocate(old_w, old_velocity%mesh, gi_w_name) - old_w%option_path = trim(base_path) // "/vertical_velocity" - call set(old_w, old_velocity, W_) - ewrite_minmax(old_w) - - call allocate(new_w, new_velocity%mesh, old_w%name) - new_w%option_path = old_w%option_path - - call insert_for_interpolation(old_state, old_w) - call insert_for_interpolation(new_state, new_w) - end if - - ! Insert the conservative potential - - if(gp) then - call allocate(new_gp, new_gp_mesh, old_gp%name) - new_gp%option_path = old_gp%option_path - - call insert_for_interpolation(old_state, old_gp) - call insert_for_interpolation(new_state, new_gp) - end if - - call allocate(new_p, new_p_mesh, old_p%name) - new_p%option_path = old_p%option_path - - decompose_p = have_option(trim(base_path) // "/conservative_potential/decompose") - if(decompose_p) then - ! Decompose the conservative potential - - call allocate(old_p_decomp(1), old_p_mesh, old_p%name) - call set(old_p_decomp(1), old_p) - call allocate(old_p_decomp(2), old_p_mesh, trim(old_p%name) // gi_p_decomp_postfix) - old_p_decomp%option_path = old_p%option_path - - new_p_decomp(1) = new_p - call incref(new_p_decomp(1)) - call allocate(new_p_decomp(2), new_p_mesh, trim(old_p%name) // gi_p_decomp_postfix) - new_p_decomp(2)%option_path = new_p%option_path + ! Use zero initial guess + if(gp) call zero(old_gp) + call zero(old_p) + end if - if(aux_p) then - ! Decompose the Pressure - - call allocate(old_aux_p_decomp(1), old_aux_p%mesh, old_aux_p%name) - call set(old_aux_p_decomp(1), old_aux_p) - old_aux_p_decomp(1)%option_path = old_aux_p%option_path - call allocate(old_aux_p_decomp(2), old_aux_p%mesh, trim(old_aux_p%name) // gi_p_decomp_postfix) - old_aux_p_decomp(2)%option_path = old_aux_p%option_path - - new_aux_p_decomp(1) = new_aux_p - call allocate(new_aux_p_decomp(2), new_aux_p%mesh, trim(new_aux_p%name) // gi_p_decomp_postfix) - new_aux_p_decomp(2)%option_path = new_aux_p%option_path - - if(have_option(trim(base_path) // "/conservative_potential/decompose/boundary_mean")) then - if(old_p%mesh == old_aux_p%mesh) then - call decompose_p_mean(matrices, old_p, old_aux_p, old_positions, old_p_decomp, old_aux_p_decomp, & - & bc_p_1 = new_p_decomp(1), bc_p_2 = new_aux_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - else - call decompose_p_mean(matrices, old_p, old_positions, old_p_decomp, & - & bc_p = new_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - call allocate(aux_matrices, old_state, coriolis, old_aux_p, & - & option_path = old_p%option_path, bcfield = old_bc_velocity, add_cmc = .true.) - call decompose_p_mean(aux_matrices, old_aux_p, old_positions, old_aux_p_decomp, & - & bc_p = new_aux_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - call deallocate(aux_matrices) - end if - else if(have_option(trim(base_path) // "/conservative_potential/decompose/l2_minimised_residual")) then - if(old_p%mesh == old_aux_p%mesh) then - call decompose_p_optimal(matrices, old_p, old_aux_p, old_positions, old_p_decomp, old_aux_p_decomp, & - & bc_p_1 = new_p_decomp(1), bc_p_2 = new_aux_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - else - call decompose_p_optimal(matrices, old_p, old_positions, old_p_decomp, & - & bc_p = new_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - call allocate(aux_matrices, old_state, coriolis, old_aux_p, & - & option_path = old_p%option_path, bcfield = old_bc_velocity, add_cmc = .true.) - call decompose_p_optimal(aux_matrices, old_aux_p, old_positions, old_aux_p_decomp, & - & bc_p = new_aux_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - call deallocate(aux_matrices) - end if - else - FLAbort("Unable to determine conservative potential decomposition type") - end if - - call set(old_aux_p, old_aux_p_decomp(1)) - call deallocate(old_aux_p_decomp(1)) - old_aux_p_decomp(1) = old_aux_p - call insert_for_interpolation(old_state, old_aux_p_decomp(2)) - new_aux_p = new_aux_p_decomp(1) - call insert_for_interpolation(new_state, new_aux_p_decomp(2)) + call set(old_res, coriolis) + call allocate(conserv, dim, old_u_mesh, name = "CoriolisConservative") + if(gp) then + call geopressure_decomposition(old_state, coriolis, old_gp) + call projection_decomposition(old_state, coriolis, old_p, bcfield = old_bc_velocity, matrices = matrices, gp = old_gp) + call correct_velocity(matrices, old_res, old_p, conserv = conserv, gp = old_gp) else - if(have_option(trim(base_path) // "/conservative_potential/decompose/boundary_mean")) then - call decompose_p_mean(matrices, old_p, old_positions, old_p_decomp, & - & bc_p = new_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - else if(have_option(trim(base_path) // "/conservative_potential/decompose/l2_minimised_residual")) then - call decompose_p_optimal(matrices, old_p, old_positions, old_p_decomp, & - & bc_p = new_p_decomp(1), & - & solver_path = trim(base_path) // "/conservative_potential/decompose") - else - FLAbort("Unable to determine conservative potential decomposition type") - end if + call projection_decomposition(old_state, coriolis, old_p, bcfield = old_bc_velocity, matrices = matrices) + call correct_velocity(matrices, old_res, old_p, conserv = conserv) end if + if(debug_vtus) then - call vtk_write_fields("p_decomp_old", index = vtu_index, position = old_positions, model = old_p_mesh, & - & sfields = (/old_p, old_p_decomp(1), old_p_decomp(2)/), stat = stat) - if(stat /= 0) then - ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat - end if + if(old_velocity%mesh == old_u_mesh) then + call allocate(div, old_p_mesh, trim(old_velocity%name) // "Divergence") + call set_solver_options(temp_solver_path, ksptype = "cg", pctype = "sor", rtol = 0.0, atol = epsilon(0.0), max_its = 10000) + div%option_path = temp_solver_path + call zero(div) + call compute_divergence(old_velocity, matrices%ct_m, get_mass_matrix(old_state, old_p_mesh), div) + if(gp) then + call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & + & sfields = (/old_p, old_gp, div/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) + else + call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & + & sfields = (/old_p, div/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) + end if + if(stat /= 0) then + ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat + end if + call delete_option(div%option_path) + call deallocate(div) + else + if(gp) then + call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & + & sfields = (/old_p, old_gp/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) + else + call vtk_write_fields("geostrophic_interpolation_old", vtu_index, old_positions, model = old_u_mesh, & + & sfields = (/old_p/), vfields = (/old_velocity, coriolis, conserv, old_res/), stat = stat) + end if + if(stat /= 0) then + ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat + end if + end if end if + call deallocate(conserv) - call insert_for_interpolation(old_state, old_p_decomp(1)) - call insert_for_interpolation(old_state, old_p_decomp(2)) - call insert_for_interpolation(new_state, new_p_decomp(1)) - call insert_for_interpolation(new_state, new_p_decomp(2)) + ! Insert the horizontal Velocity residual - call deallocate(old_p) - call deallocate(new_p) - else - if(have_option(trim(base_path) // "/conservative_potential/interpolate_boundary")) then - ! Interpolate boundary conditions - if(aux_p) then - if(old_p%mesh == old_aux_p%mesh) then - call derive_interpolated_p_dirichlet(old_p, old_aux_p, old_positions, new_p, new_aux_p, new_positions) - else - call derive_interpolated_p_dirichlet(old_p, old_positions, new_p, new_positions) - call derive_interpolated_p_dirichlet(old_aux_p, old_positions, new_aux_p, new_positions) - end if - else - call derive_interpolated_p_dirichlet(old_p, old_positions, new_p, new_positions) - end if + call allocate(new_res, dim, new_u_mesh, old_res%name) + new_res%option_path = old_res%option_path + + call insert_for_interpolation(old_state, old_res) + call insert_for_interpolation(new_state, new_res) + if(dim == 3) then + ! Insert the vertical Velocity + call allocate(old_w, old_velocity%mesh, gi_w_name) + old_w%option_path = trim(base_path) // "/vertical_velocity" + call set(old_w, old_velocity, W_) + ewrite_minmax(old_w) + + call allocate(new_w, new_velocity%mesh, old_w%name) + new_w%option_path = old_w%option_path + + call insert_for_interpolation(old_state, old_w) + call insert_for_interpolation(new_state, new_w) end if - call insert_for_interpolation(old_state, old_p) - call insert_for_interpolation(new_state, new_p) - end if + ! Insert the conservative potential - call deallocate(coriolis) - call deallocate(old_bc_velocity) - deallocate(old_bc_velocity) - call deallocate(matrices) + if(gp) then + call allocate(new_gp, new_gp_mesh, old_gp%name) + new_gp%option_path = old_gp%option_path - if(debug_vtus) then - vtu_index = vtu_index + 1 - call get_option(trim(base_path) // "/debug/write_debug_vtus/max_vtu_count", max_vtu_count, stat = stat) - if(stat == SPUD_NO_ERROR) vtu_index = modulo(vtu_index, max_vtu_count) - end if + call insert_for_interpolation(old_state, old_gp) + call insert_for_interpolation(new_state, new_gp) + end if - ewrite(1, *) "Exiting initialise_geostrophic_interpolation_velocity" + call allocate(new_p, new_p_mesh, old_p%name) + new_p%option_path = old_p%option_path - end subroutine initialise_geostrophic_interpolation_velocity + decompose_p = have_option(trim(base_path) // "/conservative_potential/decompose") + if(decompose_p) then + ! Decompose the conservative potential + + call allocate(old_p_decomp(1), old_p_mesh, old_p%name) + call set(old_p_decomp(1), old_p) + call allocate(old_p_decomp(2), old_p_mesh, trim(old_p%name) // gi_p_decomp_postfix) + old_p_decomp%option_path = old_p%option_path + + new_p_decomp(1) = new_p + call incref(new_p_decomp(1)) + call allocate(new_p_decomp(2), new_p_mesh, trim(old_p%name) // gi_p_decomp_postfix) + new_p_decomp(2)%option_path = new_p%option_path + + if(aux_p) then + ! Decompose the Pressure + + call allocate(old_aux_p_decomp(1), old_aux_p%mesh, old_aux_p%name) + call set(old_aux_p_decomp(1), old_aux_p) + old_aux_p_decomp(1)%option_path = old_aux_p%option_path + call allocate(old_aux_p_decomp(2), old_aux_p%mesh, trim(old_aux_p%name) // gi_p_decomp_postfix) + old_aux_p_decomp(2)%option_path = old_aux_p%option_path + + new_aux_p_decomp(1) = new_aux_p + call allocate(new_aux_p_decomp(2), new_aux_p%mesh, trim(new_aux_p%name) // gi_p_decomp_postfix) + new_aux_p_decomp(2)%option_path = new_aux_p%option_path + + if(have_option(trim(base_path) // "/conservative_potential/decompose/boundary_mean")) then + if(old_p%mesh == old_aux_p%mesh) then + call decompose_p_mean(matrices, old_p, old_aux_p, old_positions, old_p_decomp, old_aux_p_decomp, & + & bc_p_1 = new_p_decomp(1), bc_p_2 = new_aux_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + else + call decompose_p_mean(matrices, old_p, old_positions, old_p_decomp, & + & bc_p = new_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + call allocate(aux_matrices, old_state, coriolis, old_aux_p, & + & option_path = old_p%option_path, bcfield = old_bc_velocity, add_cmc = .true.) + call decompose_p_mean(aux_matrices, old_aux_p, old_positions, old_aux_p_decomp, & + & bc_p = new_aux_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + call deallocate(aux_matrices) + end if + else if(have_option(trim(base_path) // "/conservative_potential/decompose/l2_minimised_residual")) then + if(old_p%mesh == old_aux_p%mesh) then + call decompose_p_optimal(matrices, old_p, old_aux_p, old_positions, old_p_decomp, old_aux_p_decomp, & + & bc_p_1 = new_p_decomp(1), bc_p_2 = new_aux_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + else + call decompose_p_optimal(matrices, old_p, old_positions, old_p_decomp, & + & bc_p = new_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + call allocate(aux_matrices, old_state, coriolis, old_aux_p, & + & option_path = old_p%option_path, bcfield = old_bc_velocity, add_cmc = .true.) + call decompose_p_optimal(aux_matrices, old_aux_p, old_positions, old_aux_p_decomp, & + & bc_p = new_aux_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + call deallocate(aux_matrices) + end if + else + FLAbort("Unable to determine conservative potential decomposition type") + end if + + call set(old_aux_p, old_aux_p_decomp(1)) + call deallocate(old_aux_p_decomp(1)) + old_aux_p_decomp(1) = old_aux_p + call insert_for_interpolation(old_state, old_aux_p_decomp(2)) + new_aux_p = new_aux_p_decomp(1) + call insert_for_interpolation(new_state, new_aux_p_decomp(2)) + else + if(have_option(trim(base_path) // "/conservative_potential/decompose/boundary_mean")) then + call decompose_p_mean(matrices, old_p, old_positions, old_p_decomp, & + & bc_p = new_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + else if(have_option(trim(base_path) // "/conservative_potential/decompose/l2_minimised_residual")) then + call decompose_p_optimal(matrices, old_p, old_positions, old_p_decomp, & + & bc_p = new_p_decomp(1), & + & solver_path = trim(base_path) // "/conservative_potential/decompose") + else + FLAbort("Unable to determine conservative potential decomposition type") + end if + end if + if(debug_vtus) then + call vtk_write_fields("p_decomp_old", index = vtu_index, position = old_positions, model = old_p_mesh, & + & sfields = (/old_p, old_p_decomp(1), old_p_decomp(2)/), stat = stat) + if(stat /= 0) then + ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat + end if + end if - subroutine finalise_geostrophic_interpolation_states(new_states) - !!< Finalise a state set up for geostrophic interpolation + call insert_for_interpolation(old_state, old_p_decomp(1)) + call insert_for_interpolation(old_state, old_p_decomp(2)) + call insert_for_interpolation(new_state, new_p_decomp(1)) + call insert_for_interpolation(new_state, new_p_decomp(2)) - type(state_type), dimension(:), intent(inout) :: new_states + call deallocate(old_p) + call deallocate(new_p) + else + if(have_option(trim(base_path) // "/conservative_potential/interpolate_boundary")) then + ! Interpolate boundary conditions + if(aux_p) then + if(old_p%mesh == old_aux_p%mesh) then + call derive_interpolated_p_dirichlet(old_p, old_aux_p, old_positions, new_p, new_aux_p, new_positions) + else + call derive_interpolated_p_dirichlet(old_p, old_positions, new_p, new_positions) + call derive_interpolated_p_dirichlet(old_aux_p, old_positions, new_aux_p, new_positions) + end if + else + call derive_interpolated_p_dirichlet(old_p, old_positions, new_p, new_positions) + end if + end if + + call insert_for_interpolation(old_state, old_p) + call insert_for_interpolation(new_state, new_p) + end if + + call deallocate(coriolis) + call deallocate(old_bc_velocity) + deallocate(old_bc_velocity) + call deallocate(matrices) + + if(debug_vtus) then + vtu_index = vtu_index + 1 + call get_option(trim(base_path) // "/debug/write_debug_vtus/max_vtu_count", max_vtu_count, stat = stat) + if(stat == SPUD_NO_ERROR) vtu_index = modulo(vtu_index, max_vtu_count) + end if + + ewrite(1, *) "Exiting initialise_geostrophic_interpolation_velocity" + + end subroutine initialise_geostrophic_interpolation_velocity + + subroutine finalise_geostrophic_interpolation_states(new_states) + !!< Finalise a state set up for geostrophic interpolation + + type(state_type), dimension(:), intent(inout) :: new_states #ifdef DDEBUG - type(vector_field), pointer :: new_velocity_2 + type(vector_field), pointer :: new_velocity_2 #endif - integer :: i, j, stat - type(vector_field), pointer :: new_velocity - - do i = 1, size(new_states) - ! Confusing note: finalise_geostrophic_interpolation removes vector - ! fields, but these are guaranteed to appear *after* any interpolated - ! fields. Hence we loop with a do while and not a for. - j = 1 - do while(j <= vector_field_count(new_states(i))) - new_velocity => extract_vector_field(new_states(i), j) - if(have_option(trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation")) then - call finalise_geostrophic_interpolation(new_states(i), new_velocity) + integer :: i, j, stat + type(vector_field), pointer :: new_velocity + + do i = 1, size(new_states) + ! Confusing note: finalise_geostrophic_interpolation removes vector + ! fields, but these are guaranteed to appear *after* any interpolated + ! fields. Hence we loop with a do while and not a for. + j = 1 + do while(j <= vector_field_count(new_states(i))) + new_velocity => extract_vector_field(new_states(i), j) + if(have_option(trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation")) then + call finalise_geostrophic_interpolation(new_states(i), new_velocity) #ifdef DDEBUG - ! Check that finalise_geostrophic_interpolation hasn't removed - ! any vector fields that appear *before* the interpolated field - new_velocity_2 => extract_vector_field(new_states(i), j) - assert(new_velocity%name == new_velocity_2%name) + ! Check that finalise_geostrophic_interpolation hasn't removed + ! any vector fields that appear *before* the interpolated field + new_velocity_2 => extract_vector_field(new_states(i), j) + assert(new_velocity%name == new_velocity_2%name) #endif - end if - j = j + 1 + end if + j = j + 1 + end do end do - end do - - end subroutine finalise_geostrophic_interpolation_states - - function extract_interpolated_scalar(new_state, name) result(field) - !!< Extract an interpolated field from state, and remove it from state - - type(state_type), intent(inout) :: new_state - character(len = *), intent(in) :: name - - type(scalar_field) :: field - - field = extract_scalar_field(new_state, name) - call incref(field) - call remove_scalar_field(new_state, name) - - end function extract_interpolated_scalar - - function extract_interpolated_vector(new_state, name) result(field) - !!< Extract an interpolated field from state, and remove it from state - - type(state_type), intent(inout) :: new_state - character(len = *), intent(in) :: name - - type(vector_field) :: field - - field = extract_vector_field(new_state, name) - call incref(field) - call remove_vector_field(new_state, name) - - end function extract_interpolated_vector - - subroutine finalise_geostrophic_interpolation_velocity(new_state, new_velocity) - !!< Finalise a state set up for geostrophic interpolation - - type(state_type), intent(inout) :: new_state - type(vector_field), target, intent(inout) :: new_velocity - - character(len = OPTION_PATH_LEN) :: base_path, u_mesh_name, p_mesh_name - integer :: dim, stat - type(cmc_matrices) :: matrices - type(mesh_type), pointer :: new_p_mesh, new_u_mesh - type(scalar_field) :: res_p - type(scalar_field) :: new_p, new_w - type(vector_field) :: conserv, coriolis, new_res - type(vector_field), pointer :: new_bc_velocity, new_positions - - logical :: gp - type(scalar_field) :: new_gp - - logical :: aux_p - character(len = OPTION_PATH_LEN) :: aux_p_name - real :: aux_p_scale - type(scalar_field), pointer :: new_aux_p - - logical :: decompose_p - type(scalar_field) :: new_p_decomp - type(scalar_field) :: new_aux_p_decomp - - logical :: debug_vtus - integer :: max_vtu_count - integer, save :: vtu_index = 0 - type(scalar_field) :: div - - ewrite(1, *) "In finalise_geostrophic_interpolation_velocity" - ewrite(2, *) "Input field: " // trim(new_velocity%name) - ewrite(2, *) "In state: " // trim(new_state%name) - - base_path = trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation" - ewrite(2, *) "Option path: " // trim(base_path) - debug_vtus = have_option(trim(base_path) // "/debug/write_debug_vtus") - - new_positions => extract_vector_field(new_state, "Coordinate") - dim = new_positions%dim - assert(any(dim == (/2, 3/))) - - call get_option(trim(base_path) // "/coriolis/mesh/name", u_mesh_name, stat = stat) - if(stat == SPUD_NO_ERROR) then - new_u_mesh => extract_mesh(new_state, u_mesh_name) - allocate(new_bc_velocity) - call allocate(new_bc_velocity, new_velocity%dim, new_u_mesh, new_velocity%name) - new_bc_velocity%option_path = new_velocity%option_path - call zero(new_bc_velocity) - call populate_vector_boundary_conditions(new_state, new_bc_velocity, trim(complete_field_path(new_bc_velocity%option_path)) // "/boundary_conditions", new_positions) - else - new_u_mesh => new_velocity%mesh - allocate(new_bc_velocity) - new_bc_velocity = new_velocity - call incref(new_bc_velocity) - end if - call get_option(trim(base_path) // "/conservative_potential/mesh/name", p_mesh_name) - new_p_mesh => extract_mesh(new_state, p_mesh_name) - - new_p = extract_interpolated_scalar(new_state, gi_conservative_potential_name) - ! Make sure strong Dirichlet bcs are applied - call set_dirichlet_consistent(new_p) - new_res = extract_interpolated_vector(new_state, gi_res_name) - if(dim == 3) then - new_w = extract_interpolated_scalar(new_state, gi_w_name) - end if - - aux_p = have_option(trim(base_path) // "/conservative_potential/project_pressure") - if(aux_p) then - call get_option(trim(base_path) // "/conservative_potential/project_pressure/name", aux_p_name) - new_aux_p => extract_scalar_field(new_state, aux_p_name) - ! Make sure strong Dirichlet bcs are applied - call set_dirichlet_consistent(new_aux_p) - ! Restore any pressure bcs - call clear_boundary_conditions(new_aux_p) - call populate_scalar_boundary_conditions(new_aux_p, trim(complete_field_path(new_aux_p%option_path)) // "/boundary_conditions", new_positions) - end if - - gp = have_option(trim(base_path) // "/geopressure") - if(gp) then - new_gp = extract_interpolated_scalar(new_state, gi_gp_conservative_potential_name) - end if - - decompose_p = have_option(trim(base_path) // "/conservative_potential/decompose") - if(decompose_p) then - new_p_decomp = extract_interpolated_scalar(new_state, gi_conservative_potential_name // gi_p_decomp_postfix) - if(aux_p) then - new_aux_p_decomp = extract_interpolated_scalar(new_state, trim(new_aux_p%name) // gi_p_decomp_postfix) - end if - end if - call allocate(coriolis, dim, new_u_mesh, "Coriolis") + end subroutine finalise_geostrophic_interpolation_states - ! Add the solenoidal component + function extract_interpolated_scalar(new_state, name) result(field) + !!< Extract an interpolated field from state, and remove it from state - call set(coriolis, new_res) - if(have_option(trim(base_path) // "/residual/enforce_solenoidal")) then - ! Project the interpolated residual to guarantee solenoidal - call allocate(res_p, new_p_mesh, trim(new_res%name) // "ConservativePotential") - res_p%option_path = new_p%option_path - call zero(res_p) - call projection_decomposition(new_state, new_res, res_p, bcfield = new_bc_velocity, matrices = matrices) - call correct_velocity(matrices, coriolis, res_p) - call deallocate(res_p) - else - call allocate(matrices, new_state, new_res, new_p, bcfield = new_bc_velocity, add_cmc = .false.) - end if + type(state_type), intent(inout) :: new_state + character(len = *), intent(in) :: name - ! Add the conservative component + type(scalar_field) :: field - call allocate(conserv, dim, new_u_mesh, name = "CoriolisConservative") - if(gp) then - call add_geopressure_matrices(new_state, new_gp%mesh, matrices) - call compute_conservative(matrices, conserv, new_gp, geopressure = .true.) - call addto(coriolis, conserv) - end if + field = extract_scalar_field(new_state, name) + call incref(field) + call remove_scalar_field(new_state, name) - if(decompose_p) then - if(debug_vtus) then - call vtk_write_fields("p_decomp_new", index = vtu_index, position = new_positions, model = new_p_mesh, & - & sfields = (/new_p, new_p_decomp/), stat = stat) - if(stat /= 0) then - ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat - end if - end if + end function extract_interpolated_scalar - call addto(new_p, new_p_decomp) - call deallocate(new_p_decomp) - end if - call compute_conservative(matrices, conserv, new_p) - call addto(coriolis, conserv) + function extract_interpolated_vector(new_state, name) result(field) + !!< Extract an interpolated field from state, and remove it from state - ! Invert for the new Velocity + type(state_type), intent(inout) :: new_state + character(len = *), intent(in) :: name - call velocity_from_coriolis(new_state, coriolis, new_velocity, & - & lump_mass = have_option(trim(base_path) // "/coriolis/coriolis_to_velocity/lump_mass"), & - & lump_rhs = have_option(trim(base_path) // "/coriolis/coriolis_to_velocity/lump_rhs"), & - & solver_path = trim(base_path) // "/coriolis/coriolis_to_velocity") - if(dim == 3) then - ! Recover the vertical velocity - ewrite_minmax(new_velocity%val(W_,:)) - call set(new_velocity, W_, new_w) - ewrite_minmax(new_velocity%val(W_,:)) - call deallocate(new_w) - end if - - if(debug_vtus) then - if(new_velocity%mesh == new_u_mesh) then - call allocate(div, new_p_mesh, trim(new_velocity%name) // "Divergence") - call set_solver_options(temp_solver_path, ksptype = "cg", pctype = "sor", rtol = 0.0, atol = epsilon(0.0), max_its = 10000) - div%option_path = temp_solver_path - call zero(div) - call compute_divergence(new_velocity, matrices%ct_m, get_mass_matrix(new_state, new_p_mesh), div) - if(gp) then - call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & - & sfields = (/new_p, new_gp, div/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) - else - call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & - & sfields = (/new_p, div/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) - end if - if(stat /= 0) then - ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat - end if - call delete_option(div%option_path) - call deallocate(div) - else - if(gp) then - call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & - & sfields = (/new_p, new_gp/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) - else - call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & - & sfields = (/new_p/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) - end if - if(stat /= 0) then - ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat - end if - end if - end if - call deallocate(conserv) - - if(aux_p) then - ! Construct the new Pressure - if(decompose_p) then - call addto(new_aux_p, new_aux_p_decomp) - call deallocate(new_aux_p_decomp) - end if - call get_option(trim(base_path) // "/conservative_potential/project_pressure/scale_factor", aux_p_scale, stat = stat) + type(vector_field) :: field + + field = extract_vector_field(new_state, name) + call incref(field) + call remove_vector_field(new_state, name) + + end function extract_interpolated_vector + + subroutine finalise_geostrophic_interpolation_velocity(new_state, new_velocity) + !!< Finalise a state set up for geostrophic interpolation + + type(state_type), intent(inout) :: new_state + type(vector_field), target, intent(inout) :: new_velocity + + character(len = OPTION_PATH_LEN) :: base_path, u_mesh_name, p_mesh_name + integer :: dim, stat + type(cmc_matrices) :: matrices + type(mesh_type), pointer :: new_p_mesh, new_u_mesh + type(scalar_field) :: res_p + type(scalar_field) :: new_p, new_w + type(vector_field) :: conserv, coriolis, new_res + type(vector_field), pointer :: new_bc_velocity, new_positions + + logical :: gp + type(scalar_field) :: new_gp + + logical :: aux_p + character(len = OPTION_PATH_LEN) :: aux_p_name + real :: aux_p_scale + type(scalar_field), pointer :: new_aux_p + + logical :: decompose_p + type(scalar_field) :: new_p_decomp + type(scalar_field) :: new_aux_p_decomp + + logical :: debug_vtus + integer :: max_vtu_count + integer, save :: vtu_index = 0 + type(scalar_field) :: div + + ewrite(1, *) "In finalise_geostrophic_interpolation_velocity" + ewrite(2, *) "Input field: " // trim(new_velocity%name) + ewrite(2, *) "In state: " // trim(new_state%name) + + base_path = trim(complete_field_path(new_velocity%option_path, stat = stat)) // "/geostrophic_interpolation" + ewrite(2, *) "Option path: " // trim(base_path) + debug_vtus = have_option(trim(base_path) // "/debug/write_debug_vtus") + + new_positions => extract_vector_field(new_state, "Coordinate") + dim = new_positions%dim + assert(any(dim == (/2, 3/))) + + call get_option(trim(base_path) // "/coriolis/mesh/name", u_mesh_name, stat = stat) if(stat == SPUD_NO_ERROR) then - ewrite(2, *) "Applying pressure scale factor: ", 1.0 / aux_p_scale - call scale(new_aux_p, 1.0 / aux_p_scale) + new_u_mesh => extract_mesh(new_state, u_mesh_name) + allocate(new_bc_velocity) + call allocate(new_bc_velocity, new_velocity%dim, new_u_mesh, new_velocity%name) + new_bc_velocity%option_path = new_velocity%option_path + call zero(new_bc_velocity) + call populate_vector_boundary_conditions(new_state, new_bc_velocity, trim(complete_field_path(new_bc_velocity%option_path)) // "/boundary_conditions", new_positions) + else + new_u_mesh => new_velocity%mesh + allocate(new_bc_velocity) + new_bc_velocity = new_velocity + call incref(new_bc_velocity) end if - end if + call get_option(trim(base_path) // "/conservative_potential/mesh/name", p_mesh_name) + new_p_mesh => extract_mesh(new_state, p_mesh_name) - call deallocate(coriolis) - call deallocate(matrices) - call deallocate(new_p) - call deallocate(new_res) - if(gp) call deallocate(new_gp) - call deallocate(new_bc_velocity) - deallocate(new_bc_velocity) + new_p = extract_interpolated_scalar(new_state, gi_conservative_potential_name) + ! Make sure strong Dirichlet bcs are applied + call set_dirichlet_consistent(new_p) + new_res = extract_interpolated_vector(new_state, gi_res_name) + if(dim == 3) then + new_w = extract_interpolated_scalar(new_state, gi_w_name) + end if - if(debug_vtus) then - vtu_index = vtu_index + 1 - call get_option(trim(base_path) // "/debug/write_debug_vtus/max_vtu_count", max_vtu_count, stat = stat) - if(stat == SPUD_NO_ERROR) vtu_index = modulo(vtu_index, max_vtu_count) - end if + aux_p = have_option(trim(base_path) // "/conservative_potential/project_pressure") + if(aux_p) then + call get_option(trim(base_path) // "/conservative_potential/project_pressure/name", aux_p_name) + new_aux_p => extract_scalar_field(new_state, aux_p_name) + ! Make sure strong Dirichlet bcs are applied + call set_dirichlet_consistent(new_aux_p) + ! Restore any pressure bcs + call clear_boundary_conditions(new_aux_p) + call populate_scalar_boundary_conditions(new_aux_p, trim(complete_field_path(new_aux_p%option_path)) // "/boundary_conditions", new_positions) + end if - ewrite(1, *) "Exiting finalise_geostrophic_interpolation_velocity" + gp = have_option(trim(base_path) // "/geopressure") + if(gp) then + new_gp = extract_interpolated_scalar(new_state, gi_gp_conservative_potential_name) + end if - end subroutine finalise_geostrophic_interpolation_velocity + decompose_p = have_option(trim(base_path) // "/conservative_potential/decompose") + if(decompose_p) then + new_p_decomp = extract_interpolated_scalar(new_state, gi_conservative_potential_name // gi_p_decomp_postfix) + if(aux_p) then + new_aux_p_decomp = extract_interpolated_scalar(new_state, trim(new_aux_p%name) // gi_p_decomp_postfix) + end if + end if - subroutine geostrophic_pressure_check_options - !!< Check GeostrophicPressure specific options + call allocate(coriolis, dim, new_u_mesh, "Coriolis") - character(len = FIELD_NAME_LEN) :: field_name - character(len = OPTION_PATH_LEN) :: mat_phase_path, path, & - & geostrophic_pressure_option - integer :: dim, i, j, reference_node, stat + ! Add the solenoidal component - character(len = OPTION_PATH_LEN) :: aux_p_name, mesh_name, mesh_name_2 + call set(coriolis, new_res) + if(have_option(trim(base_path) // "/residual/enforce_solenoidal")) then + ! Project the interpolated residual to guarantee solenoidal + call allocate(res_p, new_p_mesh, trim(new_res%name) // "ConservativePotential") + res_p%option_path = new_p%option_path + call zero(res_p) + call projection_decomposition(new_state, new_res, res_p, bcfield = new_bc_velocity, matrices = matrices) + call correct_velocity(matrices, coriolis, res_p) + call deallocate(res_p) + else + call allocate(matrices, new_state, new_res, new_p, bcfield = new_bc_velocity, add_cmc = .false.) + end if - if(option_count("/material_phase/scalar_field::" // gp_name) > 0) then - ewrite(2, *) "Checking GeostrophicPressure options" + ! Add the conservative component - if(option_count("/material_phase/scalar_field::" // gp_rhs_name) > 0) then - FLExit("The scalar field name " // gp_rhs_name // " is reserved") + call allocate(conserv, dim, new_u_mesh, name = "CoriolisConservative") + if(gp) then + call add_geopressure_matrices(new_state, new_gp%mesh, matrices) + call compute_conservative(matrices, conserv, new_gp, geopressure = .true.) + call addto(coriolis, conserv) end if - do i = 0, option_count("/material_phase") - 1 - mat_phase_path = "/material_phase[" // int2str(i) // "]" - do j = 0, option_count(trim(mat_phase_path) // "/scalar_field") - 1 - path = "/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]" - - call get_option(trim(path) // "/name", field_name) - if(field_name == gp_name) then - path = complete_field_path(path, stat = stat) - - call get_option(trim(path) // "/reference_node", reference_node, stat = stat) - if(stat /= SPUD_NO_ERROR) then - if(.not. (have_option(trim(path) // "/solver/remove_null_space") .or. have_option(trim(path) // "/boundary_conditions"))) then - FLExit("GeostrophicPressure requires either a reference node, a boundary condition or null space removal in the solver") - end if - else if(reference_node <= 0) then - FLExit("GeostrophicPressure reference node must be positive") - else - if(have_option(trim(path) // "/boundary_conditions")) then - FLExit("Shouldn't specify a reference node and a boundary condition for GeostrophicPressure") - end if + if(decompose_p) then + if(debug_vtus) then + call vtk_write_fields("p_decomp_new", index = vtu_index, position = new_positions, model = new_p_mesh, & + & sfields = (/new_p, new_p_decomp/), stat = stat) + if(stat /= 0) then + ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat end if + end if - call get_option(trim(path) // "/spatial_discretisation/geostrophic_pressure_option", geostrophic_pressure_option) - if(geostrophic_pressure_option /= "exclude_coriolis" .and. & - & have_option("/physical_parameters/coriolis") .and. & - & have_option(trim(path) // "/boundary_conditions")) then - FLExit("Boundary conditions for GeostrophicPressure only make sense when excluding coriolis.") - end if - end if - end do - end do + call addto(new_p, new_p_decomp) + call deallocate(new_p_decomp) + end if + call compute_conservative(matrices, conserv, new_p) + call addto(coriolis, conserv) - ewrite(2, *) "Finished checking GeostrophicPressure options" - end if - if(option_count("/material_phase/scalar_field::BalancePressure") > 0) then - FLExit("BalancePressure has been removed - switch to GeostrophicPressure") - end if + ! Invert for the new Velocity - do i = 0, option_count("/material_phase") - 1 - if(have_option("/material_phase["//int2str(i)//"]/scalar_field::" // hp_name) .and. & - & have_option("/material_phase["//int2str(i)//"/vector_field::" // hpg_name)) then - FLExit("Cannot use both HydrostaticPressure and HydrostaticPressureGradient") + call velocity_from_coriolis(new_state, coriolis, new_velocity, & + & lump_mass = have_option(trim(base_path) // "/coriolis/coriolis_to_velocity/lump_mass"), & + & lump_rhs = have_option(trim(base_path) // "/coriolis/coriolis_to_velocity/lump_rhs"), & + & solver_path = trim(base_path) // "/coriolis/coriolis_to_velocity") + if(dim == 3) then + ! Recover the vertical velocity + ewrite_minmax(new_velocity%val(W_,:)) + call set(new_velocity, W_, new_w) + ewrite_minmax(new_velocity%val(W_,:)) + call deallocate(new_w) end if - end do - if(have_option("/material_phase/vector_field/prescribed/geostrophic_interpolation") .or. & - & have_option("/material_phase/vector_field/diagnostic/geostrophic_interpolation") .or. & - & have_option("/material_phase/vector_field/prognostic/geostrophic_interpolation")) then - ewrite(2, *) "Checking geostrophic interpolation options" + if(debug_vtus) then + if(new_velocity%mesh == new_u_mesh) then + call allocate(div, new_p_mesh, trim(new_velocity%name) // "Divergence") + call set_solver_options(temp_solver_path, ksptype = "cg", pctype = "sor", rtol = 0.0, atol = epsilon(0.0), max_its = 10000) + div%option_path = temp_solver_path + call zero(div) + call compute_divergence(new_velocity, matrices%ct_m, get_mass_matrix(new_state, new_p_mesh), div) + if(gp) then + call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & + & sfields = (/new_p, new_gp, div/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) + else + call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & + & sfields = (/new_p, div/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) + end if + if(stat /= 0) then + ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat + end if + call delete_option(div%option_path) + call deallocate(div) + else + if(gp) then + call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & + & sfields = (/new_p, new_gp/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) + else + call vtk_write_fields("geostrophic_interpolation_new", vtu_index, new_positions, model = new_u_mesh, & + & sfields = (/new_p/), vfields = (/new_velocity, coriolis, conserv, new_res/), stat = stat) + end if + if(stat /= 0) then + ewrite(0, *) "WARNING: Error returned by vtk_write_fields: ", stat + end if + end if + end if + call deallocate(conserv) - if(.not. have_option("/physical_parameters/coriolis")) then - FLExit("Geostrophic interpolation requires Coriolis") + if(aux_p) then + ! Construct the new Pressure + if(decompose_p) then + call addto(new_aux_p, new_aux_p_decomp) + call deallocate(new_aux_p_decomp) + end if + call get_option(trim(base_path) // "/conservative_potential/project_pressure/scale_factor", aux_p_scale, stat = stat) + if(stat == SPUD_NO_ERROR) then + ewrite(2, *) "Applying pressure scale factor: ", 1.0 / aux_p_scale + call scale(new_aux_p, 1.0 / aux_p_scale) + end if end if - do i = 0, option_count("/material_phase") - 1 - mat_phase_path = "/material_phase[" // int2str(i) // "]" - do j = 0, option_count(trim(mat_phase_path) // "/vector_field") - 1 - path = "/material_phase[" // int2str(i) // "]/vector_field[" // int2str(j) // "]" - call get_option(trim(path) // "/name", field_name) - path = complete_field_path(path, stat = stat) - - if(have_option(trim(path) // "/geostrophic_interpolation")) then - call get_option(trim(path) // "/geostrophic_interpolation/coriolis/mesh/name", mesh_name, stat = stat) - if(stat == SPUD_NO_ERROR) then - if(option_count("/geometry/mesh::" // trim(mesh_name)) == 0) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("Coriolis mesh " // trim(mesh_name) // " is not defined") - end if - end if + call deallocate(coriolis) + call deallocate(matrices) + call deallocate(new_p) + call deallocate(new_res) + if(gp) call deallocate(new_gp) + call deallocate(new_bc_velocity) + deallocate(new_bc_velocity) - if(have_option(trim(path) // "/geostrophic_interpolation/coriolis/velocity_to_coriolis/lump_rhs")) then - ! Note: Using mesh query above again here - if(stat == SPUD_NO_ERROR) then - call get_option(trim(path) // "/mesh/name", mesh_name_2) - if(mesh_name /= mesh_name_2) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("For velocity_to_coriolis, cannot lump the RHS term if Coriolis is not on the same mesh as Velocity") - end if - end if - end if + if(debug_vtus) then + vtu_index = vtu_index + 1 + call get_option(trim(base_path) // "/debug/write_debug_vtus/max_vtu_count", max_vtu_count, stat = stat) + if(stat == SPUD_NO_ERROR) vtu_index = modulo(vtu_index, max_vtu_count) + end if - if(have_option(trim(path) // "/geostrophic_interpolation/coriolis/coriolis_to_velocity/lump_rhs")) then - ! Note: Using mesh query above again here - if(stat == SPUD_NO_ERROR) then - call get_option(trim(path) // "/mesh/name", mesh_name_2) - if(mesh_name /= mesh_name_2) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("For coriolis_to_velocity, cannot lump the RHS term if Coriolis is not on the same mesh as Velocity") - end if - end if - end if + ewrite(1, *) "Exiting finalise_geostrophic_interpolation_velocity" - call get_option(trim(path) // "/geostrophic_interpolation/conservative_potential/mesh/name", mesh_name) - if(option_count("/geometry/mesh::" // trim(mesh_name)) == 0) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("Conservative potential mesh " // trim(mesh_name) // " is not defined") - end if + end subroutine finalise_geostrophic_interpolation_velocity - if(have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/project_pressure")) then - call get_option(trim(path) // "/geostrophic_interpolation/conservative_potential/project_pressure/name", aux_p_name) - if(have_option(trim(complete_field_path(trim(mat_phase_path) // "/scalar_field::" // trim(aux_p_name), stat = stat)) // "/no_interpolation")) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - ewrite(-1, *) "Pressure field: " // trim(aux_p_name) - FLExit("project_pressure selected, but pressure field has interpolation disabled") - end if - - if(have_option(trim(complete_field_path(trim(mat_phase_path) // "/scalar_field::" // aux_p_name)) // "/galerkin_projection") .and. & - & have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/galerkin_projection") .and. & - & (have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/decompose") .or. & - & have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/interpolate_boundary")) .and. & - & .not. have_option(trim(complete_field_path(trim(mat_phase_path) // "/scalar_field::" // aux_p_name)) & - & // "/galerkin_projection/honour_strong_boundary_conditions")) then - ewrite(0, *) "For geostrophic interpolation of field: " // trim(field_name) - ewrite(0, *) "Pressure field: " // trim(aux_p_name) - ewrite(0, *) "Warning: Conservative potential decompose or boundary_interpolation selected," - ewrite(0, *) "with project_pressure and galerkin_projection for the conservative potential" - ewrite(0, *) "and pressure, but honour_strong_boundary_conditions has not been selected for" - ewrite(0, *) "pressure" - end if - end if + subroutine geostrophic_pressure_check_options + !!< Check GeostrophicPressure specific options - if(have_option(trim(path) // "/geostrophic_interpolation/geopressure")) then - call get_option(trim(path) // "/geostrophic_interpolation/geopressure/mesh/name", mesh_name) - if(option_count("/geometry/mesh::" // trim(mesh_name)) == 0) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("Geopressure mesh " // trim(mesh_name) // " is not defined") - end if - - call get_option(trim(path) // "/geostrophic_interpolation/geopressure/reference_node", reference_node, stat = stat) - if(stat /= SPUD_NO_ERROR) then - if(.not. have_option(trim(path) // "/geostrophic_interpolation/geopressure/solver/remove_null_space")) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("Geopressure requires either a reference node or null space removal in the solver") - end if - else if(reference_node <= 0) then - ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) - FLExit("Geopressure reference node must be positive") - end if - end if + character(len = FIELD_NAME_LEN) :: field_name + character(len = OPTION_PATH_LEN) :: mat_phase_path, path, & + & geostrophic_pressure_option + integer :: dim, i, j, reference_node, stat + + character(len = OPTION_PATH_LEN) :: aux_p_name, mesh_name, mesh_name_2 + + if(option_count("/material_phase/scalar_field::" // gp_name) > 0) then + ewrite(2, *) "Checking GeostrophicPressure options" + + if(option_count("/material_phase/scalar_field::" // gp_rhs_name) > 0) then + FLExit("The scalar field name " // gp_rhs_name // " is reserved") + end if + + do i = 0, option_count("/material_phase") - 1 + mat_phase_path = "/material_phase[" // int2str(i) // "]" + do j = 0, option_count(trim(mat_phase_path) // "/scalar_field") - 1 + path = "/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]" + + call get_option(trim(path) // "/name", field_name) + if(field_name == gp_name) then + path = complete_field_path(path, stat = stat) + + call get_option(trim(path) // "/reference_node", reference_node, stat = stat) + if(stat /= SPUD_NO_ERROR) then + if(.not. (have_option(trim(path) // "/solver/remove_null_space") .or. have_option(trim(path) // "/boundary_conditions"))) then + FLExit("GeostrophicPressure requires either a reference node, a boundary condition or null space removal in the solver") + end if + else if(reference_node <= 0) then + FLExit("GeostrophicPressure reference node must be positive") + else + if(have_option(trim(path) // "/boundary_conditions")) then + FLExit("Shouldn't specify a reference node and a boundary condition for GeostrophicPressure") + end if + end if + + call get_option(trim(path) // "/spatial_discretisation/geostrophic_pressure_option", geostrophic_pressure_option) + if(geostrophic_pressure_option /= "exclude_coriolis" .and. & + & have_option("/physical_parameters/coriolis") .and. & + & have_option(trim(path) // "/boundary_conditions")) then + FLExit("Boundary conditions for GeostrophicPressure only make sense when excluding coriolis.") + end if + end if + end do + end do + + ewrite(2, *) "Finished checking GeostrophicPressure options" + end if + if(option_count("/material_phase/scalar_field::BalancePressure") > 0) then + FLExit("BalancePressure has been removed - switch to GeostrophicPressure") + end if - call get_option("/geometry/dimension", dim, stat = stat) - if(stat == SPUD_NO_ERROR) then - if(dim == 3) then - if(.not. have_option(trim(path) // "/geostrophic_interpolation/vertical_velocity")) then - FLExit("Vertical velocity options are required in 3D") - end if - end if - end if - end if - end do + do i = 0, option_count("/material_phase") - 1 + if(have_option("/material_phase["//int2str(i)//"]/scalar_field::" // hp_name) .and. & + & have_option("/material_phase["//int2str(i)//"/vector_field::" // hpg_name)) then + FLExit("Cannot use both HydrostaticPressure and HydrostaticPressureGradient") + end if end do - ewrite(2, *) "Finished checking geostrophic interpolation options" - end if + if(have_option("/material_phase/vector_field/prescribed/geostrophic_interpolation") .or. & + & have_option("/material_phase/vector_field/diagnostic/geostrophic_interpolation") .or. & + & have_option("/material_phase/vector_field/prognostic/geostrophic_interpolation")) then + ewrite(2, *) "Checking geostrophic interpolation options" + + if(.not. have_option("/physical_parameters/coriolis")) then + FLExit("Geostrophic interpolation requires Coriolis") + end if + + do i = 0, option_count("/material_phase") - 1 + mat_phase_path = "/material_phase[" // int2str(i) // "]" + do j = 0, option_count(trim(mat_phase_path) // "/vector_field") - 1 + path = "/material_phase[" // int2str(i) // "]/vector_field[" // int2str(j) // "]" + call get_option(trim(path) // "/name", field_name) + path = complete_field_path(path, stat = stat) + + if(have_option(trim(path) // "/geostrophic_interpolation")) then + call get_option(trim(path) // "/geostrophic_interpolation/coriolis/mesh/name", mesh_name, stat = stat) + if(stat == SPUD_NO_ERROR) then + if(option_count("/geometry/mesh::" // trim(mesh_name)) == 0) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("Coriolis mesh " // trim(mesh_name) // " is not defined") + end if + end if + + if(have_option(trim(path) // "/geostrophic_interpolation/coriolis/velocity_to_coriolis/lump_rhs")) then + ! Note: Using mesh query above again here + if(stat == SPUD_NO_ERROR) then + call get_option(trim(path) // "/mesh/name", mesh_name_2) + if(mesh_name /= mesh_name_2) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("For velocity_to_coriolis, cannot lump the RHS term if Coriolis is not on the same mesh as Velocity") + end if + end if + end if + + if(have_option(trim(path) // "/geostrophic_interpolation/coriolis/coriolis_to_velocity/lump_rhs")) then + ! Note: Using mesh query above again here + if(stat == SPUD_NO_ERROR) then + call get_option(trim(path) // "/mesh/name", mesh_name_2) + if(mesh_name /= mesh_name_2) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("For coriolis_to_velocity, cannot lump the RHS term if Coriolis is not on the same mesh as Velocity") + end if + end if + end if + + call get_option(trim(path) // "/geostrophic_interpolation/conservative_potential/mesh/name", mesh_name) + if(option_count("/geometry/mesh::" // trim(mesh_name)) == 0) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("Conservative potential mesh " // trim(mesh_name) // " is not defined") + end if + + if(have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/project_pressure")) then + call get_option(trim(path) // "/geostrophic_interpolation/conservative_potential/project_pressure/name", aux_p_name) + if(have_option(trim(complete_field_path(trim(mat_phase_path) // "/scalar_field::" // trim(aux_p_name), stat = stat)) // "/no_interpolation")) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + ewrite(-1, *) "Pressure field: " // trim(aux_p_name) + FLExit("project_pressure selected, but pressure field has interpolation disabled") + end if + + if(have_option(trim(complete_field_path(trim(mat_phase_path) // "/scalar_field::" // aux_p_name)) // "/galerkin_projection") .and. & + & have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/galerkin_projection") .and. & + & (have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/decompose") .or. & + & have_option(trim(path) // "/geostrophic_interpolation/conservative_potential/interpolate_boundary")) .and. & + & .not. have_option(trim(complete_field_path(trim(mat_phase_path) // "/scalar_field::" // aux_p_name)) & + & // "/galerkin_projection/honour_strong_boundary_conditions")) then + ewrite(0, *) "For geostrophic interpolation of field: " // trim(field_name) + ewrite(0, *) "Pressure field: " // trim(aux_p_name) + ewrite(0, *) "Warning: Conservative potential decompose or boundary_interpolation selected," + ewrite(0, *) "with project_pressure and galerkin_projection for the conservative potential" + ewrite(0, *) "and pressure, but honour_strong_boundary_conditions has not been selected for" + ewrite(0, *) "pressure" + end if + end if + + if(have_option(trim(path) // "/geostrophic_interpolation/geopressure")) then + call get_option(trim(path) // "/geostrophic_interpolation/geopressure/mesh/name", mesh_name) + if(option_count("/geometry/mesh::" // trim(mesh_name)) == 0) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("Geopressure mesh " // trim(mesh_name) // " is not defined") + end if + + call get_option(trim(path) // "/geostrophic_interpolation/geopressure/reference_node", reference_node, stat = stat) + if(stat /= SPUD_NO_ERROR) then + if(.not. have_option(trim(path) // "/geostrophic_interpolation/geopressure/solver/remove_null_space")) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("Geopressure requires either a reference node or null space removal in the solver") + end if + else if(reference_node <= 0) then + ewrite(-1, *) "For geostrophic interpolation of field: " // trim(field_name) + FLExit("Geopressure reference node must be positive") + end if + end if + + call get_option("/geometry/dimension", dim, stat = stat) + if(stat == SPUD_NO_ERROR) then + if(dim == 3) then + if(.not. have_option(trim(path) // "/geostrophic_interpolation/vertical_velocity")) then + FLExit("Vertical velocity options are required in 3D") + end if + end if + end if + end if + end do + end do + + ewrite(2, *) "Finished checking geostrophic interpolation options" + end if - end subroutine geostrophic_pressure_check_options + end subroutine geostrophic_pressure_check_options end module geostrophic_pressure diff --git a/assemble/Gradient_Matrix_CG.F90 b/assemble/Gradient_Matrix_CG.F90 index f491cc6157..99407cd1ae 100644 --- a/assemble/Gradient_Matrix_CG.F90 +++ b/assemble/Gradient_Matrix_CG.F90 @@ -29,30 +29,30 @@ module gradient_matrix_cg - use global_parameters, only: OPTION_PATH_LEN - use fldebug - use quadrature - use futils - use spud - use sparse_tools - use transform_elements - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use field_options, only: complete_field_path - - implicit none - - private - public :: assemble_gradient_matrix_cg + use global_parameters, only: OPTION_PATH_LEN + use fldebug + use quadrature + use futils + use spud + use sparse_tools + use transform_elements + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use field_options, only: complete_field_path + + implicit none + + private + public :: assemble_gradient_matrix_cg contains - subroutine assemble_gradient_matrix_cg(C_m, state, c_rhs, & - test_mesh, field, option_path, & - grad_mass, div_mass) + subroutine assemble_gradient_matrix_cg(C_m, state, c_rhs, & + test_mesh, field, option_path, & + grad_mass, div_mass) ! inputs/outputs ! bucket full of fields @@ -107,15 +107,15 @@ subroutine assemble_gradient_matrix_cg(C_m, state, c_rhs, & ewrite(2,*) 'In assemble_divergence_matrix_cg' if(present(option_path)) then - l_option_path = trim(option_path) + l_option_path = trim(option_path) else - l_option_path = trim(field%option_path) + l_option_path = trim(field%option_path) end if x=>extract_vector_field(state, "Coordinate") integrate_by_parts=have_option(trim(complete_field_path(l_option_path, stat=stat))//& - &"/integrate_gradient_by_parts") + &"/integrate_gradient_by_parts") ! Clear memory of arrays being designed call zero(C_m) @@ -124,103 +124,103 @@ subroutine assemble_gradient_matrix_cg(C_m, state, c_rhs, & if(present(grad_mass)) call zero(grad_mass) allocate(dfield_t(ele_loc(field, 1), ele_ngi(field, 1), mesh_dim(field)), & - dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), mesh_dim(field)), & - ele_mat(mesh_dim(test_mesh), ele_loc(test_mesh, 1), ele_loc(field, 1)), & - detwei(ele_ngi(field, 1)), & - grad_mass_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1)), & - div_mass_mat(ele_loc(field, 1), ele_loc(field, 1))) + dtest_t(ele_loc(test_mesh, 1), ele_ngi(test_mesh, 1), mesh_dim(field)), & + ele_mat(mesh_dim(test_mesh), ele_loc(test_mesh, 1), ele_loc(field, 1)), & + detwei(ele_ngi(field, 1)), & + grad_mass_mat(ele_loc(test_mesh, 1), ele_loc(test_mesh, 1)), & + div_mass_mat(ele_loc(field, 1), ele_loc(field, 1))) do ele=1, element_count(test_mesh) - test_nodes=>ele_nodes(test_mesh, ele) - field_nodes=>ele_nodes(field, ele) + test_nodes=>ele_nodes(test_mesh, ele) + field_nodes=>ele_nodes(field, ele) - test_shape=>ele_shape(test_mesh, ele) - field_shape=>ele_shape(field, ele) + test_shape=>ele_shape(test_mesh, ele) + field_shape=>ele_shape(field, ele) - if(integrate_by_parts) then - ! transform the pressure derivatives into physical space - ! (and get detwei) - call transform_to_physical(X, ele, test_shape, dshape=dtest_t,& - & detwei=detwei) + if(integrate_by_parts) then + ! transform the pressure derivatives into physical space + ! (and get detwei) + call transform_to_physical(X, ele, test_shape, dshape=dtest_t,& + & detwei=detwei) - ele_mat = -dshape_shape(dtest_t, field_shape, detwei) - else - ! transform the velociy derivatives into physical space - ! (and get detwei) - call transform_to_physical(X, ele, field_shape, dshape=dfield_t,& - & detwei=detwei) + ele_mat = -dshape_shape(dtest_t, field_shape, detwei) + else + ! transform the velociy derivatives into physical space + ! (and get detwei) + call transform_to_physical(X, ele, field_shape, dshape=dfield_t,& + & detwei=detwei) - ele_mat = shape_dshape(test_shape, dfield_t, detwei) - end if + ele_mat = shape_dshape(test_shape, dfield_t, detwei) + end if - do dim = 1, mesh_dim(test_mesh) - call addto(c_m, dim, 1, test_nodes, field_nodes, ele_mat(dim,:,:)) - end do + do dim = 1, mesh_dim(test_mesh) + call addto(c_m, dim, 1, test_nodes, field_nodes, ele_mat(dim,:,:)) + end do - if(present(div_mass)) then + if(present(div_mass)) then - div_mass_mat = shape_shape(field_shape, field_shape, detwei) - call addto(div_mass, field_nodes, field_nodes, div_mass_mat) + div_mass_mat = shape_shape(field_shape, field_shape, detwei) + call addto(div_mass, field_nodes, field_nodes, div_mass_mat) - end if + end if - if(present(grad_mass)) then + if(present(grad_mass)) then - grad_mass_mat = shape_shape(test_shape, test_shape, detwei) - call addto(grad_mass, test_nodes, test_nodes, grad_mass_mat) + grad_mass_mat = shape_shape(test_shape, test_shape, detwei) + call addto(grad_mass, test_nodes, test_nodes, grad_mass_mat) - end if + end if end do if(integrate_by_parts) then - allocate(detwei_bdy(face_ngi(field, 1)), & - normal_bdy(mesh_dim(field), face_ngi(field, 1))) - allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) - allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) - allocate(ele_mat_bdy(mesh_dim(field), face_loc(test_mesh, 1), face_loc(field, 1))) + allocate(detwei_bdy(face_ngi(field, 1)), & + normal_bdy(mesh_dim(field), face_ngi(field, 1))) + allocate(field_nodes_bdy(field%mesh%faces%shape%loc)) + allocate(test_nodes_bdy(test_mesh%faces%shape%loc)) + allocate(ele_mat_bdy(mesh_dim(field), face_loc(test_mesh, 1), face_loc(field, 1))) - assert(surface_element_count(test_mesh)==surface_element_count(field)) - allocate(field_bc_type(surface_element_count(field))) - call get_entire_boundary_condition(field, (/"weakdirichlet"/), field_bc, field_bc_type) + assert(surface_element_count(test_mesh)==surface_element_count(field)) + allocate(field_bc_type(surface_element_count(field))) + call get_entire_boundary_condition(field, (/"weakdirichlet"/), field_bc, field_bc_type) - do sele = 1, surface_element_count(test_mesh) + do sele = 1, surface_element_count(test_mesh) - test_shape=>face_shape(test_mesh, sele) - field_shape=>face_shape(field, sele) + test_shape=>face_shape(test_mesh, sele) + field_shape=>face_shape(field, sele) - test_nodes_bdy=face_global_nodes(test_mesh, sele) - field_nodes_bdy=face_global_nodes(field, sele) + test_nodes_bdy=face_global_nodes(test_mesh, sele) + field_nodes_bdy=face_global_nodes(field, sele) - call transform_facet_to_physical(X, sele, & - & detwei_f=detwei_bdy,& - & normal=normal_bdy) + call transform_facet_to_physical(X, sele, & + & detwei_f=detwei_bdy,& + & normal=normal_bdy) - ele_mat_bdy = shape_shape_vector(test_shape, field_shape, detwei_bdy, normal_bdy) + ele_mat_bdy = shape_shape_vector(test_shape, field_shape, detwei_bdy, normal_bdy) - do dim = 1, mesh_dim(field) - if((field_bc_type(sele)==1).and.present(c_rhs)) then - call addto(c_rhs, dim, test_nodes_bdy, & - -matmul(ele_mat_bdy(dim,:,:), & - ele_val(field_bc, sele))) - else - call addto(c_m, dim, 1, test_nodes_bdy, field_nodes_bdy, & - ele_mat_bdy(dim,:,:)) - end if - end do + do dim = 1, mesh_dim(field) + if((field_bc_type(sele)==1).and.present(c_rhs)) then + call addto(c_rhs, dim, test_nodes_bdy, & + -matmul(ele_mat_bdy(dim,:,:), & + ele_val(field_bc, sele))) + else + call addto(c_m, dim, 1, test_nodes_bdy, field_nodes_bdy, & + ele_mat_bdy(dim,:,:)) + end if + end do - end do + end do - call deallocate(field_bc) - deallocate(field_bc_type) - deallocate(detwei_bdy, normal_bdy) - deallocate(test_nodes_bdy, field_nodes_bdy) + call deallocate(field_bc) + deallocate(field_bc_type) + deallocate(detwei_bdy, normal_bdy) + deallocate(test_nodes_bdy, field_nodes_bdy) end if deallocate(detwei) - end subroutine assemble_gradient_matrix_cg + end subroutine assemble_gradient_matrix_cg end module gradient_matrix_cg diff --git a/assemble/Hybridized_Helmholtz.F90 b/assemble/Hybridized_Helmholtz.F90 index eec3f1a96e..5b6fe6d97a 100644 --- a/assemble/Hybridized_Helmholtz.F90 +++ b/assemble/Hybridized_Helmholtz.F90 @@ -1,1809 +1,1809 @@ - ! Copyright (C) 2006 Imperial College London and others. - ! - ! Please see the AUTHORS file in the main source directory for a full list - ! of copyright holders. - ! - ! Prof. C Pain - ! Applied Modelling and Computation Group - ! Department of Earth Science and Engineering - ! Imperial College London - ! - ! amcgsoftware@imperial.ac.uk - ! - ! This library is free software; you can redistribute it and/or - ! modify it under the terms of the GNU Lesser General Public - ! License as published by the Free Software Foundation, - ! version 2.1 of the License. - ! - ! This library is distributed in the hope that it will be useful, - ! but WITHOUT ANY WARRANTY; without even the implied warranty of - ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - ! Lesser General Public License for more details. - ! - ! You should have received a copy of the GNU Lesser General Public - ! License along with this library; if not, write to the Free Software - ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 - ! USA + ! Copyright (C) 2006 Imperial College London and others. + ! + ! Please see the AUTHORS file in the main source directory for a full list + ! of copyright holders. + ! + ! Prof. C Pain + ! Applied Modelling and Computation Group + ! Department of Earth Science and Engineering + ! Imperial College London + ! + ! amcgsoftware@imperial.ac.uk + ! + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation, + ! version 2.1 of the License. + ! + ! This library is distributed in the hope that it will be useful, + ! but WITHOUT ANY WARRANTY; without even the implied warranty of + ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + ! Lesser General Public License for more details. + ! + ! You should have received a copy of the GNU Lesser General Public + ! License along with this library; if not, write to the Free Software + ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + ! USA #include "fdebug.h" module hybridized_helmholtz - use spud - use FLDebug - use global_parameters, only: option_path_len - use FUtils, only : real_vector, real_matrix, present_and_true - use vector_tools, only: solve, cross_product - use sparse_tools - use element_numbering, only: FAMILY_SIMPLEX, FAMILY_CUBE - use fetools - use fields - use state_module - use write_state_module - use sparsity_patterns_meshes - use sparse_matrices_fields - use solvers - use diagnostic_variables - use populate_state_module - use timeloop_utilities - use assemble_cmc - use manifold_projections - implicit none - - private - - public :: solve_hybridized_helmholtz + use spud + use FLDebug + use global_parameters, only: option_path_len + use FUtils, only : real_vector, real_matrix, present_and_true + use vector_tools, only: solve, cross_product + use sparse_tools + use element_numbering, only: FAMILY_SIMPLEX, FAMILY_CUBE + use fetools + use fields + use state_module + use write_state_module + use sparsity_patterns_meshes + use sparse_matrices_fields + use solvers + use diagnostic_variables + use populate_state_module + use timeloop_utilities + use assemble_cmc + use manifold_projections + implicit none + + private + + public :: solve_hybridized_helmholtz contains - subroutine solve_hybridized_helmholtz(state,D_rhs,U_Rhs,& - &D_out,U_out,& - &compute_cartesian,& - &check_continuity,output_dense,& - &projection,poisson,u_rhs_local,& - &solver_option_path) - ! Subroutine to solve hybridized helmholtz equation - ! If D_rhs (scalar pressure field) is present, then solve: - ! + - g
+ <<[w],d>> = - ! <\phi,d> + <\phi,div u> = <\phi, D_rhs> - ! <<\gamma, [u]>> = 0 - ! (i.e. for unit testing) - ! otherwise solve: - ! + dt*theta* - dt*theta*g
+ <<[w],d>> = - ! -dt* + dt*g*
- ! <\phi,\eta> + dt*theta*<\phi,div u> = <\ph - ! <<\gamma, [u]>> = 0 - ! and then updating - ! u = u^n + dt*u, d = d^n + dt*d - ! (i.e. for solving wave equation) - implicit none - type(state_type), intent(inout) :: state - type(scalar_field), intent(in), optional :: D_rhs - type(vector_field), intent(inout), optional :: U_rhs - type(scalar_field), intent(inout), optional :: D_out - type(vector_field), intent(inout), optional :: U_out - logical, intent(in), optional :: compute_cartesian, & - &check_continuity,output_dense, projection,poisson - logical, intent(in), optional :: u_rhs_local !means u_rhs is in local coords - character(len=OPTION_PATH_LEN), intent(in), optional :: solver_option_path - ! - type(vector_field), pointer :: X, U, down, U_cart - type(scalar_field), pointer :: D, f - type(scalar_field) :: lambda - type(scalar_field), target :: lambda_rhs, u_cpt - type(csr_sparsity) :: lambda_sparsity, continuity_sparsity - type(csr_matrix) :: lambda_mat, continuity_block_mat - type(block_csr_matrix) :: continuity_mat - type(mesh_type), pointer :: lambda_mesh - real :: D0, dt, g, theta - integer :: ele, i1, dim1 - logical :: l_compute_cartesian,l_check_continuity, l_output_dense - real, dimension(:,:), allocatable :: lambda_mat_dense - - ewrite(1,*) ' subroutine solve_hybridized_helmholtz(' - - l_compute_cartesian = .false. - if(present(compute_cartesian)) l_compute_cartesian = compute_cartesian - if(present(check_continuity)) l_check_continuity = check_continuity - if(l_check_continuity) l_compute_cartesian = .true. - l_output_dense = .false. - if(present(output_dense)) l_output_dense = output_dense - - !Pull the fields out of state - D=>extract_scalar_field(state, "LayerThickness") - f=>extract_scalar_field(state, "Coriolis") - U=>extract_vector_field(state, "LocalVelocity") - X=>extract_vector_field(state, "Coordinate") - down=>extract_vector_field(state, "GravityDirection") - - lambda_mesh=>extract_mesh(state, "VelocityMeshTrace") - call allocate(lambda,lambda_mesh,name="LagrangeMultiplier") - - U_cart => extract_vector_field(state, "Velocity") - - !construct/extract sparsities - lambda_sparsity=get_csr_sparsity_firstorder(state, lambda%mesh, lambda& - &%mesh) - continuity_sparsity=get_csr_sparsity_firstorder(state, u%mesh, lambda%mesh) - - !allocate matrices - call allocate(lambda_mat,lambda_sparsity) - call zero(lambda_mat) - call allocate(continuity_mat,continuity_sparsity,(/U%dim,1/)) - call zero(continuity_mat) - - !allocate hybridized RHS - call allocate(lambda_rhs,lambda%mesh,"LambdaRHS") - call zero(lambda_rhs) - - !get parameters - call get_option("/physical_parameters/gravity/magnitude", g) - !theta - call get_option("/material_phase::Fluid/scalar_field::LayerThickness/& - &prognostic/temporal_discretisation/theta",theta) - !D0 - call get_option("/material_phase::Fluid/scalar_field::LayerThickness/& - &p& - &rognostic/mean_layer_thickness",D0) - call get_option("/timestepping/timestep", dt) - - !Assemble matrices - do ele = 1, ele_count(D) - call assemble_hybridized_helmholtz_ele(D,f,U,X,down,ele, & - &g,dt,theta,D0,lambda_mat=lambda_mat,& - &lambda_rhs=lambda_rhs,D_rhs=D_rhs,U_rhs=U_rhs,& - &continuity_mat=continuity_mat,& - &projection=projection,poisson=poisson,& - &u_rhs_local=u_rhs_local) - end do - - ewrite(1,*) 'LAMBDARHS', maxval(abs(lambda_rhs%val)) - - !Solve the equations - if(present(solver_option_path)) then - call petsc_solve(lambda,lambda_mat,lambda_rhs,& + subroutine solve_hybridized_helmholtz(state,D_rhs,U_Rhs,& + &D_out,U_out,& + &compute_cartesian,& + &check_continuity,output_dense,& + &projection,poisson,u_rhs_local,& + &solver_option_path) + ! Subroutine to solve hybridized helmholtz equation + ! If D_rhs (scalar pressure field) is present, then solve: + ! + - g
+ <<[w],d>> = + ! <\phi,d> + <\phi,div u> = <\phi, D_rhs> + ! <<\gamma, [u]>> = 0 + ! (i.e. for unit testing) + ! otherwise solve: + ! + dt*theta* - dt*theta*g
+ <<[w],d>> = + ! -dt* + dt*g*
+ ! <\phi,\eta> + dt*theta*<\phi,div u> = <\ph + ! <<\gamma, [u]>> = 0 + ! and then updating + ! u = u^n + dt*u, d = d^n + dt*d + ! (i.e. for solving wave equation) + implicit none + type(state_type), intent(inout) :: state + type(scalar_field), intent(in), optional :: D_rhs + type(vector_field), intent(inout), optional :: U_rhs + type(scalar_field), intent(inout), optional :: D_out + type(vector_field), intent(inout), optional :: U_out + logical, intent(in), optional :: compute_cartesian, & + &check_continuity,output_dense, projection,poisson + logical, intent(in), optional :: u_rhs_local !means u_rhs is in local coords + character(len=OPTION_PATH_LEN), intent(in), optional :: solver_option_path + ! + type(vector_field), pointer :: X, U, down, U_cart + type(scalar_field), pointer :: D, f + type(scalar_field) :: lambda + type(scalar_field), target :: lambda_rhs, u_cpt + type(csr_sparsity) :: lambda_sparsity, continuity_sparsity + type(csr_matrix) :: lambda_mat, continuity_block_mat + type(block_csr_matrix) :: continuity_mat + type(mesh_type), pointer :: lambda_mesh + real :: D0, dt, g, theta + integer :: ele, i1, dim1 + logical :: l_compute_cartesian,l_check_continuity, l_output_dense + real, dimension(:,:), allocatable :: lambda_mat_dense + + ewrite(1,*) ' subroutine solve_hybridized_helmholtz(' + + l_compute_cartesian = .false. + if(present(compute_cartesian)) l_compute_cartesian = compute_cartesian + if(present(check_continuity)) l_check_continuity = check_continuity + if(l_check_continuity) l_compute_cartesian = .true. + l_output_dense = .false. + if(present(output_dense)) l_output_dense = output_dense + + !Pull the fields out of state + D=>extract_scalar_field(state, "LayerThickness") + f=>extract_scalar_field(state, "Coriolis") + U=>extract_vector_field(state, "LocalVelocity") + X=>extract_vector_field(state, "Coordinate") + down=>extract_vector_field(state, "GravityDirection") + + lambda_mesh=>extract_mesh(state, "VelocityMeshTrace") + call allocate(lambda,lambda_mesh,name="LagrangeMultiplier") + + U_cart => extract_vector_field(state, "Velocity") + + !construct/extract sparsities + lambda_sparsity=get_csr_sparsity_firstorder(state, lambda%mesh, lambda& + &%mesh) + continuity_sparsity=get_csr_sparsity_firstorder(state, u%mesh, lambda%mesh) + + !allocate matrices + call allocate(lambda_mat,lambda_sparsity) + call zero(lambda_mat) + call allocate(continuity_mat,continuity_sparsity,(/U%dim,1/)) + call zero(continuity_mat) + + !allocate hybridized RHS + call allocate(lambda_rhs,lambda%mesh,"LambdaRHS") + call zero(lambda_rhs) + + !get parameters + call get_option("/physical_parameters/gravity/magnitude", g) + !theta + call get_option("/material_phase::Fluid/scalar_field::LayerThickness/& + &prognostic/temporal_discretisation/theta",theta) + !D0 + call get_option("/material_phase::Fluid/scalar_field::LayerThickness/& + &p& + &rognostic/mean_layer_thickness",D0) + call get_option("/timestepping/timestep", dt) + + !Assemble matrices + do ele = 1, ele_count(D) + call assemble_hybridized_helmholtz_ele(D,f,U,X,down,ele, & + &g,dt,theta,D0,lambda_mat=lambda_mat,& + &lambda_rhs=lambda_rhs,D_rhs=D_rhs,U_rhs=U_rhs,& + &continuity_mat=continuity_mat,& + &projection=projection,poisson=poisson,& + &u_rhs_local=u_rhs_local) + end do + + ewrite(1,*) 'LAMBDARHS', maxval(abs(lambda_rhs%val)) + + !Solve the equations + if(present(solver_option_path)) then + call petsc_solve(lambda,lambda_mat,lambda_rhs,& option_path=solver_option_path) - else - call petsc_solve(lambda,lambda_mat,lambda_rhs,& + else + call petsc_solve(lambda,lambda_mat,lambda_rhs,& option_path=trim(U_cart%mesh%option_path)//& - &"/from_mesh/constraint_type") - end if - ewrite(1,*) 'LAMBDA', maxval(abs(lambda%val)) - - !Reconstruct U and D from lambda - do ele = 1, ele_count(D) - call reconstruct_u_d_ele(D,f,U,X,down,ele, & - &g,dt,theta,D0,D_rhs=D_rhs,U_rhs=U_rhs,lambda=lambda,& - &D_out=D_out,U_out=U_out,& - &projection=projection,poisson=poisson,& - &u_rhs_local=u_rhs_local) - end do - - if(l_output_dense) then - allocate(lambda_mat_dense(node_count(lambda),node_count(lambda))) - lambda_mat_dense = dense(lambda_mat) - ewrite(1,*) '-----------' - do i1 = 1, node_count(lambda) - ewrite(1,*) lambda_mat_dense(i1,:) - end do - ewrite(1,*) '-----------' - end if - - if(l_compute_cartesian) then - U_cart => extract_vector_field(state, "Velocity") - if(present(U_out)) then - call project_local_to_cartesian(X,U_out,U_cart) - else - call project_local_to_cartesian(X,U,U_cart) - end if - end if - if(l_check_continuity) then - ewrite(1,*) 'Checking continuity' - - call zero(lambda_rhs) - do dim1 = 1,U%dim - if(present(U_out)) then - u_cpt = extract_scalar_field(U_out,dim1) - else - u_cpt = extract_scalar_field(U,dim1) - end if - continuity_block_mat = block(continuity_mat,dim1,1) - call mult_T_addto(lambda_rhs,continuity_block_mat,u_cpt) - ewrite(1,*) 'U, lambda',& - &maxval(u_cpt%val), maxval(abs(lambda_rhs%val)) - end do - ewrite(1,*)'JUMPS MIN:MAX',minval(lambda_rhs%val),& - &maxval(lambda_rhs%val) - assert(maxval(abs(lambda_rhs%val))<1.0e-10) - - ewrite(1,*) 'D MAXABS', maxval(abs(D%val)) - do ele = 1, ele_count(U) - call check_continuity_ele(U_cart,X,ele) - end do - end if - - call deallocate(lambda_mat) - call deallocate(lambda_rhs) - call deallocate(lambda) - - ewrite(1,*) 'END subroutine solve_hybridized_helmholtz' - - end subroutine solve_hybridized_helmholtz - - subroutine assemble_hybridized_helmholtz_ele(D,f,U,X,down,ele, & - g,dt,theta,D0,lambda_mat,lambda_rhs,U_rhs,D_rhs,& - continuity_mat,projection,poisson,u_rhs_local) - !subroutine to assemble hybridized helmholtz equation. - !For assembly, must provide: - ! lambda_mat,lambda_rhs - !For assembly, may provide: - ! D_rhs and U_rhs - ! If neither are present, D_rhs reconstructed from D and U - ! as part of an implicit timestepping algorithm - - implicit none - type(scalar_field), intent(in) :: D,f - type(scalar_field), intent(inout) :: lambda_rhs - type(vector_field), intent(in) :: U,X,down - type(vector_field), intent(in), optional :: U_rhs - type(scalar_field), intent(in), optional :: D_rhs - integer, intent(in) :: ele - real, intent(in) :: g,dt,theta,D0 - type(csr_matrix), intent(inout) :: lambda_mat - type(block_csr_matrix), intent(inout), optional :: continuity_mat - logical, intent(in), optional :: projection, poisson,u_rhs_local - ! - real, allocatable, dimension(:,:),target :: & - &l_continuity_mat, l_continuity_mat2 - real, allocatable, dimension(:,:) :: helmholtz_loc_mat - real, allocatable, dimension(:,:,:) :: continuity_face_mat - integer :: ni, face - integer, dimension(:), pointer :: neigh - real, dimension(ele_loc(lambda_rhs,ele)) :: lambda_rhs_loc - real, dimension(:),allocatable,target :: Rhs_loc - real, dimension(:,:), allocatable :: local_solver_matrix, local_solver_rhs - type(element_type) :: U_shape - integer :: d_start, d_end, dim1, mdim, uloc,dloc, lloc - integer, dimension(mesh_dim(U)) :: U_start, U_end - type(real_vector), dimension(mesh_dim(U)) :: rhs_u_ptr - real, dimension(:), pointer :: rhs_d_ptr - type(real_matrix), dimension(mesh_dim(U)) :: & - & continuity_mat_u_ptr - logical :: have_constraint - integer :: n_constraints - - !Get some sizes - lloc = ele_loc(lambda_rhs,ele) - mdim = mesh_dim(U) - uloc = ele_loc(U,ele) - dloc = ele_loc(d,ele) - U_shape = ele_shape(U,ele) - - have_constraint = & - &have_option(trim(U%mesh%option_path)//"/from_mesh/constraint_type") - n_constraints = 0 - if(have_constraint) then - n_constraints = ele_n_constraints(U,ele) - end if - - allocate(rhs_loc(2*uloc+dloc+n_constraints)) - allocate(local_solver_matrix(mdim*uloc+dloc+n_constraints,& + &"/from_mesh/constraint_type") + end if + ewrite(1,*) 'LAMBDA', maxval(abs(lambda%val)) + + !Reconstruct U and D from lambda + do ele = 1, ele_count(D) + call reconstruct_u_d_ele(D,f,U,X,down,ele, & + &g,dt,theta,D0,D_rhs=D_rhs,U_rhs=U_rhs,lambda=lambda,& + &D_out=D_out,U_out=U_out,& + &projection=projection,poisson=poisson,& + &u_rhs_local=u_rhs_local) + end do + + if(l_output_dense) then + allocate(lambda_mat_dense(node_count(lambda),node_count(lambda))) + lambda_mat_dense = dense(lambda_mat) + ewrite(1,*) '-----------' + do i1 = 1, node_count(lambda) + ewrite(1,*) lambda_mat_dense(i1,:) + end do + ewrite(1,*) '-----------' + end if + + if(l_compute_cartesian) then + U_cart => extract_vector_field(state, "Velocity") + if(present(U_out)) then + call project_local_to_cartesian(X,U_out,U_cart) + else + call project_local_to_cartesian(X,U,U_cart) + end if + end if + if(l_check_continuity) then + ewrite(1,*) 'Checking continuity' + + call zero(lambda_rhs) + do dim1 = 1,U%dim + if(present(U_out)) then + u_cpt = extract_scalar_field(U_out,dim1) + else + u_cpt = extract_scalar_field(U,dim1) + end if + continuity_block_mat = block(continuity_mat,dim1,1) + call mult_T_addto(lambda_rhs,continuity_block_mat,u_cpt) + ewrite(1,*) 'U, lambda',& + &maxval(u_cpt%val), maxval(abs(lambda_rhs%val)) + end do + ewrite(1,*)'JUMPS MIN:MAX',minval(lambda_rhs%val),& + &maxval(lambda_rhs%val) + assert(maxval(abs(lambda_rhs%val))<1.0e-10) + + ewrite(1,*) 'D MAXABS', maxval(abs(D%val)) + do ele = 1, ele_count(U) + call check_continuity_ele(U_cart,X,ele) + end do + end if + + call deallocate(lambda_mat) + call deallocate(lambda_rhs) + call deallocate(lambda) + + ewrite(1,*) 'END subroutine solve_hybridized_helmholtz' + + end subroutine solve_hybridized_helmholtz + + subroutine assemble_hybridized_helmholtz_ele(D,f,U,X,down,ele, & + g,dt,theta,D0,lambda_mat,lambda_rhs,U_rhs,D_rhs,& + continuity_mat,projection,poisson,u_rhs_local) + !subroutine to assemble hybridized helmholtz equation. + !For assembly, must provide: + ! lambda_mat,lambda_rhs + !For assembly, may provide: + ! D_rhs and U_rhs + ! If neither are present, D_rhs reconstructed from D and U + ! as part of an implicit timestepping algorithm + + implicit none + type(scalar_field), intent(in) :: D,f + type(scalar_field), intent(inout) :: lambda_rhs + type(vector_field), intent(in) :: U,X,down + type(vector_field), intent(in), optional :: U_rhs + type(scalar_field), intent(in), optional :: D_rhs + integer, intent(in) :: ele + real, intent(in) :: g,dt,theta,D0 + type(csr_matrix), intent(inout) :: lambda_mat + type(block_csr_matrix), intent(inout), optional :: continuity_mat + logical, intent(in), optional :: projection, poisson,u_rhs_local + ! + real, allocatable, dimension(:,:),target :: & + &l_continuity_mat, l_continuity_mat2 + real, allocatable, dimension(:,:) :: helmholtz_loc_mat + real, allocatable, dimension(:,:,:) :: continuity_face_mat + integer :: ni, face + integer, dimension(:), pointer :: neigh + real, dimension(ele_loc(lambda_rhs,ele)) :: lambda_rhs_loc + real, dimension(:),allocatable,target :: Rhs_loc + real, dimension(:,:), allocatable :: local_solver_matrix, local_solver_rhs + type(element_type) :: U_shape + integer :: d_start, d_end, dim1, mdim, uloc,dloc, lloc + integer, dimension(mesh_dim(U)) :: U_start, U_end + type(real_vector), dimension(mesh_dim(U)) :: rhs_u_ptr + real, dimension(:), pointer :: rhs_d_ptr + type(real_matrix), dimension(mesh_dim(U)) :: & + & continuity_mat_u_ptr + logical :: have_constraint + integer :: n_constraints + + !Get some sizes + lloc = ele_loc(lambda_rhs,ele) + mdim = mesh_dim(U) + uloc = ele_loc(U,ele) + dloc = ele_loc(d,ele) + U_shape = ele_shape(U,ele) + + have_constraint = & + &have_option(trim(U%mesh%option_path)//"/from_mesh/constraint_type") + n_constraints = 0 + if(have_constraint) then + n_constraints = ele_n_constraints(U,ele) + end if + + allocate(rhs_loc(2*uloc+dloc+n_constraints)) + allocate(local_solver_matrix(mdim*uloc+dloc+n_constraints,& mdim*uloc+dloc+n_constraints)) - allocate(local_solver_rhs(mdim*uloc+dloc,mdim*uloc+dloc)) - - !Calculate indices in a vector containing all the U and D dofs in - !element ele, First the u1 components, then the u2 components, then the - !D components are stored. - do dim1 = 1, mdim - u_start(dim1) = uloc*(dim1-1)+1 - u_end(dim1) = uloc*dim1 - end do - d_start = uloc*mdim + 1 - d_end = uloc*mdim+dloc - - !Get pointers to different parts of rhs_loc and l_continuity_mat - do dim1 = 1, mdim - rhs_u_ptr(dim1)%ptr => rhs_loc(u_start(dim1):u_end(dim1)) - end do - rhs_d_ptr => rhs_loc(d_start:d_end) - allocate(l_continuity_mat(2*uloc+dloc+n_constraints,lloc)) - do dim1= 1,mdim - continuity_mat_u_ptr(dim1)%ptr => & - & l_continuity_mat(u_start(dim1):u_end(dim1),:) - end do - - ! ( M C -L)(u) (v) - ! ( -C^T N 0 )(h) = (j) - ! ( L^T 0 0 )(l) (0) - ! - ! (u) (M C)^{-1}(v) (M C)^{-1}(L) - ! (h) = (-C^T N) (j) + (-C^T N) (0)(l) - ! so - ! (M C)^{-1}(L) (M C)^{-1}(v) - ! (L^T 0)(-C^T N) (0)=-(L^T 0)(-C^T N) (j) - - !Get the local_solver matrix that obtains U and D from Lambda on the - !boundaries - call get_local_solver(local_solver_matrix,U,X,down,D,f,ele,& - & g,dt,theta,D0,have_constraint,local_solver_rhs,& + allocate(local_solver_rhs(mdim*uloc+dloc,mdim*uloc+dloc)) + + !Calculate indices in a vector containing all the U and D dofs in + !element ele, First the u1 components, then the u2 components, then the + !D components are stored. + do dim1 = 1, mdim + u_start(dim1) = uloc*(dim1-1)+1 + u_end(dim1) = uloc*dim1 + end do + d_start = uloc*mdim + 1 + d_end = uloc*mdim+dloc + + !Get pointers to different parts of rhs_loc and l_continuity_mat + do dim1 = 1, mdim + rhs_u_ptr(dim1)%ptr => rhs_loc(u_start(dim1):u_end(dim1)) + end do + rhs_d_ptr => rhs_loc(d_start:d_end) + allocate(l_continuity_mat(2*uloc+dloc+n_constraints,lloc)) + do dim1= 1,mdim + continuity_mat_u_ptr(dim1)%ptr => & + & l_continuity_mat(u_start(dim1):u_end(dim1),:) + end do + + ! ( M C -L)(u) (v) + ! ( -C^T N 0 )(h) = (j) + ! ( L^T 0 0 )(l) (0) + ! + ! (u) (M C)^{-1}(v) (M C)^{-1}(L) + ! (h) = (-C^T N) (j) + (-C^T N) (0)(l) + ! so + ! (M C)^{-1}(L) (M C)^{-1}(v) + ! (L^T 0)(-C^T N) (0)=-(L^T 0)(-C^T N) (j) + + !Get the local_solver matrix that obtains U and D from Lambda on the + !boundaries + call get_local_solver(local_solver_matrix,U,X,down,D,f,ele,& + & g,dt,theta,D0,have_constraint,local_solver_rhs,& projection) - !!!Construct the continuity matrix that multiplies lambda in - !!! the U equation - !allocate l_continuity_mat - l_continuity_mat = 0. - !get list of neighbours - neigh => ele_neigh(D,ele) - !calculate l_continuity_mat - do ni = 1, size(neigh) - face=ele_face(U, ele, neigh(ni)) - allocate(continuity_face_mat(mdim,face_loc(U,face)& - &,face_loc(lambda_rhs,face))) - continuity_face_mat = 0. - call get_continuity_face_mat(continuity_face_mat,face,& + !!!Construct the continuity matrix that multiplies lambda in + !!! the U equation + !allocate l_continuity_mat + l_continuity_mat = 0. + !get list of neighbours + neigh => ele_neigh(D,ele) + !calculate l_continuity_mat + do ni = 1, size(neigh) + face=ele_face(U, ele, neigh(ni)) + allocate(continuity_face_mat(mdim,face_loc(U,face)& + &,face_loc(lambda_rhs,face))) + continuity_face_mat = 0. + call get_continuity_face_mat(continuity_face_mat,face,& U,lambda_rhs) - do dim1 = 1, mdim - continuity_mat_u_ptr(dim1)%ptr(face_local_nodes(U,face),& + do dim1 = 1, mdim + continuity_mat_u_ptr(dim1)%ptr(face_local_nodes(U,face),& face_local_nodes(lambda_rhs,face))=& - continuity_mat_u_ptr(dim1)%ptr(face_local_nodes(U,face),& + continuity_mat_u_ptr(dim1)%ptr(face_local_nodes(U,face),& face_local_nodes(lambda_rhs,face))+& continuity_face_mat(dim1,:,:) - end do - if(present(continuity_mat)) then - do dim1 = 1, mdim - call addto(continuity_mat,dim1,1,face_global_nodes(U,face)& - &,face_global_nodes(lambda_rhs,face),& - &continuity_face_mat(dim1,:,:)) - end do - end if - - deallocate(continuity_face_mat) - end do - - !compute l_continuity_mat2 = inverse(local_solver)*l_continuity_mat - allocate(l_continuity_mat2(uloc*2+dloc+n_constraints,lloc)) - l_continuity_mat2 = l_continuity_mat - call solve(local_solver_matrix,l_continuity_mat2) - - !compute helmholtz_loc_mat - allocate(helmholtz_loc_mat(lloc,lloc)) - helmholtz_loc_mat = matmul(transpose(l_continuity_mat),l_continuity_mat2) - - !construct lambda_rhs - rhs_loc=0. - lambda_rhs_loc = 0. - call assemble_rhs_ele(Rhs_loc,D,U,X,ele,D_rhs,U_rhs,u_rhs_local) - if(.not.(present(d_rhs).or.present(u_rhs)))then - assert(.not.present_and_true(projection)) - assert(.not.present_and_true(poisson)) - rhs_loc(1:d_end) = matmul(local_solver_rhs,rhs_loc(1:d_end)) - end if - call solve(local_solver_matrix,Rhs_loc) - lambda_rhs_loc = -matmul(transpose(l_continuity_mat),& - &Rhs_loc) - !insert lambda_rhs_loc into lambda_rhs - call addto(lambda_rhs,ele_nodes(lambda_rhs,ele),lambda_rhs_loc) - !insert helmholtz_loc_mat into global lambda matrix - call addto(lambda_mat,ele_nodes(lambda_rhs,ele),& + end do + if(present(continuity_mat)) then + do dim1 = 1, mdim + call addto(continuity_mat,dim1,1,face_global_nodes(U,face)& + &,face_global_nodes(lambda_rhs,face),& + &continuity_face_mat(dim1,:,:)) + end do + end if + + deallocate(continuity_face_mat) + end do + + !compute l_continuity_mat2 = inverse(local_solver)*l_continuity_mat + allocate(l_continuity_mat2(uloc*2+dloc+n_constraints,lloc)) + l_continuity_mat2 = l_continuity_mat + call solve(local_solver_matrix,l_continuity_mat2) + + !compute helmholtz_loc_mat + allocate(helmholtz_loc_mat(lloc,lloc)) + helmholtz_loc_mat = matmul(transpose(l_continuity_mat),l_continuity_mat2) + + !construct lambda_rhs + rhs_loc=0. + lambda_rhs_loc = 0. + call assemble_rhs_ele(Rhs_loc,D,U,X,ele,D_rhs,U_rhs,u_rhs_local) + if(.not.(present(d_rhs).or.present(u_rhs)))then + assert(.not.present_and_true(projection)) + assert(.not.present_and_true(poisson)) + rhs_loc(1:d_end) = matmul(local_solver_rhs,rhs_loc(1:d_end)) + end if + call solve(local_solver_matrix,Rhs_loc) + lambda_rhs_loc = -matmul(transpose(l_continuity_mat),& + &Rhs_loc) + !insert lambda_rhs_loc into lambda_rhs + call addto(lambda_rhs,ele_nodes(lambda_rhs,ele),lambda_rhs_loc) + !insert helmholtz_loc_mat into global lambda matrix + call addto(lambda_mat,ele_nodes(lambda_rhs,ele),& ele_nodes(lambda_rhs,ele),helmholtz_loc_mat) - end subroutine assemble_hybridized_helmholtz_ele - - subroutine reconstruct_U_d_ele(D,f,U,X,down,ele, & - g,dt,theta,D0,U_rhs,D_rhs,lambda,& - &D_out,U_out,projection,poisson,u_rhs_local) - !subroutine to reconstruct U and D having solved for lambda - implicit none - type(scalar_field), intent(in) :: f,lambda - type(scalar_field), intent(inout) :: D - type(vector_field), intent(inout) :: U - type(vector_field), intent(in) :: X,down - type(scalar_field), intent(in), optional :: D_rhs - type(vector_field), intent(in), optional :: U_rhs - type(scalar_field), intent(inout), optional :: D_out - type(vector_field), intent(inout), optional :: U_out - integer, intent(in) :: ele - real, intent(in) :: g,dt,theta,D0 - logical, intent(in), optional :: projection, poisson,u_rhs_local - ! - real, allocatable, dimension(:,:,:) :: continuity_face_mat - integer :: ni, face - integer, dimension(:), pointer :: neigh - type(element_type) :: U_shape - integer :: d_start, d_end, dim1, mdim, uloc,dloc,lloc - integer, dimension(mesh_dim(U)) :: U_start, U_end - type(real_vector), dimension(mesh_dim(U)) :: rhs_u_ptr - real, dimension(ele_loc(lambda,ele)) :: lambda_val - real, dimension(:),allocatable,target :: Rhs_loc - real, dimension(:,:), allocatable :: local_solver_matrix, local_solver_rhs - real, dimension(mesh_dim(U),ele_loc(U,ele)) :: U_solved - real, dimension(ele_loc(D,ele)) :: D_solved - logical :: have_constraint - integer :: n_constraints, i1 - type(constraints_type), pointer :: constraints - real :: constraint_check - - !Get some sizes - lloc = ele_loc(lambda,ele) - mdim = mesh_dim(U) - uloc = ele_loc(U,ele) - dloc = ele_loc(d,ele) - U_shape = ele_shape(U,ele) - - have_constraint = & - &have_option(trim(U%mesh%option_path)//"/from_mesh/constraint_type") - n_constraints = 0 - if(have_constraint) then - n_constraints = ele_n_constraints(U,ele) - end if - - allocate(rhs_loc(2*uloc+dloc+n_constraints)) - rhs_loc = 0. - allocate(local_solver_matrix(mdim*uloc+dloc+n_constraints,& + end subroutine assemble_hybridized_helmholtz_ele + + subroutine reconstruct_U_d_ele(D,f,U,X,down,ele, & + g,dt,theta,D0,U_rhs,D_rhs,lambda,& + &D_out,U_out,projection,poisson,u_rhs_local) + !subroutine to reconstruct U and D having solved for lambda + implicit none + type(scalar_field), intent(in) :: f,lambda + type(scalar_field), intent(inout) :: D + type(vector_field), intent(inout) :: U + type(vector_field), intent(in) :: X,down + type(scalar_field), intent(in), optional :: D_rhs + type(vector_field), intent(in), optional :: U_rhs + type(scalar_field), intent(inout), optional :: D_out + type(vector_field), intent(inout), optional :: U_out + integer, intent(in) :: ele + real, intent(in) :: g,dt,theta,D0 + logical, intent(in), optional :: projection, poisson,u_rhs_local + ! + real, allocatable, dimension(:,:,:) :: continuity_face_mat + integer :: ni, face + integer, dimension(:), pointer :: neigh + type(element_type) :: U_shape + integer :: d_start, d_end, dim1, mdim, uloc,dloc,lloc + integer, dimension(mesh_dim(U)) :: U_start, U_end + type(real_vector), dimension(mesh_dim(U)) :: rhs_u_ptr + real, dimension(ele_loc(lambda,ele)) :: lambda_val + real, dimension(:),allocatable,target :: Rhs_loc + real, dimension(:,:), allocatable :: local_solver_matrix, local_solver_rhs + real, dimension(mesh_dim(U),ele_loc(U,ele)) :: U_solved + real, dimension(ele_loc(D,ele)) :: D_solved + logical :: have_constraint + integer :: n_constraints, i1 + type(constraints_type), pointer :: constraints + real :: constraint_check + + !Get some sizes + lloc = ele_loc(lambda,ele) + mdim = mesh_dim(U) + uloc = ele_loc(U,ele) + dloc = ele_loc(d,ele) + U_shape = ele_shape(U,ele) + + have_constraint = & + &have_option(trim(U%mesh%option_path)//"/from_mesh/constraint_type") + n_constraints = 0 + if(have_constraint) then + n_constraints = ele_n_constraints(U,ele) + end if + + allocate(rhs_loc(2*uloc+dloc+n_constraints)) + rhs_loc = 0. + allocate(local_solver_matrix(mdim*uloc+dloc+n_constraints,& mdim*uloc+dloc+n_constraints)) - allocate(local_solver_rhs(mdim*uloc+dloc,mdim*uloc+dloc)) - - !Calculate indices in a vector containing all the U and D dofs in - !element ele, First the u1 components, then the u2 components, then the - !D components are stored. - d_start = uloc*mdim + 1 - d_end = uloc*mdim+dloc - do dim1 = 1, mdim - u_start(dim1) = uloc*(dim1-1)+1 - u_end(dim1) = uloc*dim1 - end do - - !Get pointers to different parts of rhs_loc and l_continuity_mat - do dim1 = 1, mdim - rhs_u_ptr(dim1)%ptr => rhs_loc(u_start(dim1):u_end(dim1)) - end do - - !Get the local_solver matrix that obtains U and D from Lambda on the - !boundaries - call get_local_solver(local_solver_matrix,U,X,down,D,f,ele,& - & g,dt,theta,D0,have_constraint,& - & local_solver_rhs=local_solver_rhs,projection=projection,& - & poisson=poisson) - - !Construct the rhs sources for U from lambda - call assemble_rhs_ele(Rhs_loc,D,U,X,ele,D_rhs,U_rhs,U_rhs_local) - if(.not.(present(d_rhs).or.present(u_rhs)))then - assert(.not.present_and_true(projection)) - assert(.not.present_and_true(poisson)) - rhs_loc(1:d_end) = matmul(local_solver_rhs,rhs_loc(1:d_end)) - end if - - lambda_val = ele_val(lambda,ele) - !get list of neighbours - neigh => ele_neigh(D,ele) - !calculate l_continuity_mat - do ni = 1, size(neigh) - face=ele_face(U, ele, neigh(ni)) - allocate(continuity_face_mat(mdim,face_loc(U,face),& + allocate(local_solver_rhs(mdim*uloc+dloc,mdim*uloc+dloc)) + + !Calculate indices in a vector containing all the U and D dofs in + !element ele, First the u1 components, then the u2 components, then the + !D components are stored. + d_start = uloc*mdim + 1 + d_end = uloc*mdim+dloc + do dim1 = 1, mdim + u_start(dim1) = uloc*(dim1-1)+1 + u_end(dim1) = uloc*dim1 + end do + + !Get pointers to different parts of rhs_loc and l_continuity_mat + do dim1 = 1, mdim + rhs_u_ptr(dim1)%ptr => rhs_loc(u_start(dim1):u_end(dim1)) + end do + + !Get the local_solver matrix that obtains U and D from Lambda on the + !boundaries + call get_local_solver(local_solver_matrix,U,X,down,D,f,ele,& + & g,dt,theta,D0,have_constraint,& + & local_solver_rhs=local_solver_rhs,projection=projection,& + & poisson=poisson) + + !Construct the rhs sources for U from lambda + call assemble_rhs_ele(Rhs_loc,D,U,X,ele,D_rhs,U_rhs,U_rhs_local) + if(.not.(present(d_rhs).or.present(u_rhs)))then + assert(.not.present_and_true(projection)) + assert(.not.present_and_true(poisson)) + rhs_loc(1:d_end) = matmul(local_solver_rhs,rhs_loc(1:d_end)) + end if + + lambda_val = ele_val(lambda,ele) + !get list of neighbours + neigh => ele_neigh(D,ele) + !calculate l_continuity_mat + do ni = 1, size(neigh) + face=ele_face(U, ele, neigh(ni)) + allocate(continuity_face_mat(mdim,face_loc(U,face),& face_loc(lambda,face))) - continuity_face_mat = 0. - call get_continuity_face_mat(continuity_face_mat,face,& + continuity_face_mat = 0. + call get_continuity_face_mat(continuity_face_mat,face,& U,lambda) - do dim1 = 1, mdim - rhs_u_ptr(dim1)%ptr(face_local_nodes(U,face)) = & - & rhs_u_ptr(dim1)%ptr(face_local_nodes(U,face)) + & - & matmul(continuity_face_mat(dim1,:,:),& - & face_val(lambda,face)) - end do - deallocate(continuity_face_mat) - end do - - ! ( M C -L)(u) (0) - ! ( -C^T N 0 )(h) = (j) - ! ( L^T 0 0 )(l) (0) - ! - ! (u) (M C)^{-1}(0) (M C)^{-1}(L) - ! (h) = (-C^T N) (j) + (-C^T N) (0)(l) - - call solve(local_solver_matrix,Rhs_loc) - rhs_loc = matmul(local_solver_matrix,rhs_loc) - call solve(local_solver_matrix,Rhs_loc) - - do dim1 = 1, mdim - U_solved(dim1,:) = rhs_loc(u_start(dim1):u_end(dim1)) - if(.not.(present_and_true(poisson))) then - if(present(U_out)) then - call set(U_out,dim1,ele_nodes(u,ele),u_solved(dim1,:)) - else - call set(U,dim1,ele_nodes(u,ele),u_solved(dim1,:)) - end if - end if - end do - - D_solved = rhs_loc(d_start:d_end) - if(.not.(present_and_true(projection))) then - if(present(D_out)) then - call set(D_out,ele_nodes(d,ele),D_solved) - else - call set(D,ele_nodes(d,ele),D_solved) - end if - end if - - !check that the constraints are satisfied - if(have_constraint) then - constraints => U%mesh%shape%constraints - do i1 = 1, constraints%n_constraints - constraint_check = 0. - do dim1 = 1, mdim - constraint_check = constraint_check + & - & sum(U_solved(dim1,:)*constraints%orthogonal(i1,:,dim1)) - end do - if(abs(constraint_check)>1.0e-8) then - ewrite(1,*) 'Constraint check', constraint_check - FLAbort('Constraint not enforced') - end if - end do - end if - - end subroutine reconstruct_U_d_ele - - subroutine get_local_solver(local_solver_matrix,U,X,down,D,f,ele,& - & g,dt,theta,D0,have_constraint, & - & local_solver_rhs,projection,poisson) - !Subroutine to get the matrix and rhs for obtaining U and D within - !element ele from the lagrange multipliers on the boundaries. - !This matrix-vector system is referred to as the "local solver" in the - !literature e.g. - !Cockburn et al, Unified hybridization of discontinuous Galerkin, mixed - ! and continuous Galerkin methods for second order elliptic problems, - ! SIAM J. Numer. Anal., 2009 - implicit none - !If projection is present and true, set dt to zero and just project U - !into div-conforming space - real, intent(in) :: g,dt,theta,D0 - type(vector_field), intent(in) :: U,X,down - type(scalar_field), intent(in) :: D,f - integer, intent(in) :: ele - real, dimension(:,:)& - &, intent(inout) :: local_solver_matrix - real, dimension(:,:)& - &, intent(inout), optional :: local_solver_rhs - logical, intent(in), optional :: projection, poisson - logical, intent(in) :: have_constraint - ! - real, dimension(mesh_dim(U), X%dim, ele_ngi(U,ele)) :: J - real, dimension(ele_ngi(x,ele)) :: f_gi - real, dimension(X%dim, ele_ngi(X,ele)) :: up_gi - real, dimension(mesh_dim(U),ele_loc(U,ele),ele_loc(D,ele)) :: l_div_mat - real, dimension(mesh_dim(U), mesh_dim(U), ele_ngi(U,ele)) :: Metric, & - &Metricf - real, dimension(X%dim, X%dim, ele_ngi(U,ele)) :: rot - real, dimension(mesh_dim(U),mesh_dim(U),ele_loc(U,ele),ele_loc(U& - &,ele)) :: l_u_mat - integer :: mdim, uloc,dloc,dim1,dim2,gi - type(element_type) :: u_shape, d_shape - real, dimension(ele_ngi(D,ele)) :: detwei, detJ - integer, dimension(:), pointer :: D_ele,U_ele - integer :: d_start, d_end - integer, dimension(mesh_dim(U)) :: U_start, U_end - type(constraints_type), pointer :: constraints - integer :: i1, c_start, c_end - real :: l_dt - - if(present_and_true(projection)) then - l_dt = 0. - else - l_dt = dt - end if - - mdim = mesh_dim(U) - uloc = ele_loc(U,ele) - dloc = ele_loc(d,ele) - - d_start = uloc*2 + 1 - d_end = uloc*2+dloc - do dim1 = 1, mdim - u_start(dim1) = uloc*(dim1-1)+1 - u_end(dim1) = uloc*dim1 - end do - - local_solver_matrix = 0. - if(present(local_solver_rhs)) then - local_solver_rhs = 0. - end if - - u_shape=ele_shape(u, ele) - D_shape=ele_shape(d, ele) - D_ele => ele_nodes(D, ele) - U_ele => ele_nodes(U, ele) - - if(present_and_true(projection)) then - f_gi = 0. - else - f_gi = ele_val_at_quad(f,ele) - end if - up_gi = -ele_val_at_quad(down,ele) - - call get_up_gi(X,ele,up_gi) - - !J, detJ is needed for Piola transform - !detwei is needed for pressure mass matrix - call compute_jacobian(X, ele, J=J, detwei=detwei, detJ=detJ) - - !----construct local solver - !metrics for velocity mass and coriolis matrices - do gi=1, ele_ngi(U,ele) - rot(1,:,gi)=(/0.,-up_gi(3,gi),up_gi(2,gi)/) - rot(2,:,gi)=(/up_gi(3,gi),0.,-up_gi(1,gi)/) - rot(3,:,gi)=(/-up_gi(2,gi),up_gi(1,gi),0./) - end do - do gi=1,ele_ngi(U,ele) - Metric(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) - Metricf(:,:,gi)=matmul(J(:,:,gi), & + do dim1 = 1, mdim + rhs_u_ptr(dim1)%ptr(face_local_nodes(U,face)) = & + & rhs_u_ptr(dim1)%ptr(face_local_nodes(U,face)) + & + & matmul(continuity_face_mat(dim1,:,:),& + & face_val(lambda,face)) + end do + deallocate(continuity_face_mat) + end do + + ! ( M C -L)(u) (0) + ! ( -C^T N 0 )(h) = (j) + ! ( L^T 0 0 )(l) (0) + ! + ! (u) (M C)^{-1}(0) (M C)^{-1}(L) + ! (h) = (-C^T N) (j) + (-C^T N) (0)(l) + + call solve(local_solver_matrix,Rhs_loc) + rhs_loc = matmul(local_solver_matrix,rhs_loc) + call solve(local_solver_matrix,Rhs_loc) + + do dim1 = 1, mdim + U_solved(dim1,:) = rhs_loc(u_start(dim1):u_end(dim1)) + if(.not.(present_and_true(poisson))) then + if(present(U_out)) then + call set(U_out,dim1,ele_nodes(u,ele),u_solved(dim1,:)) + else + call set(U,dim1,ele_nodes(u,ele),u_solved(dim1,:)) + end if + end if + end do + + D_solved = rhs_loc(d_start:d_end) + if(.not.(present_and_true(projection))) then + if(present(D_out)) then + call set(D_out,ele_nodes(d,ele),D_solved) + else + call set(D,ele_nodes(d,ele),D_solved) + end if + end if + + !check that the constraints are satisfied + if(have_constraint) then + constraints => U%mesh%shape%constraints + do i1 = 1, constraints%n_constraints + constraint_check = 0. + do dim1 = 1, mdim + constraint_check = constraint_check + & + & sum(U_solved(dim1,:)*constraints%orthogonal(i1,:,dim1)) + end do + if(abs(constraint_check)>1.0e-8) then + ewrite(1,*) 'Constraint check', constraint_check + FLAbort('Constraint not enforced') + end if + end do + end if + + end subroutine reconstruct_U_d_ele + + subroutine get_local_solver(local_solver_matrix,U,X,down,D,f,ele,& + & g,dt,theta,D0,have_constraint, & + & local_solver_rhs,projection,poisson) + !Subroutine to get the matrix and rhs for obtaining U and D within + !element ele from the lagrange multipliers on the boundaries. + !This matrix-vector system is referred to as the "local solver" in the + !literature e.g. + !Cockburn et al, Unified hybridization of discontinuous Galerkin, mixed + ! and continuous Galerkin methods for second order elliptic problems, + ! SIAM J. Numer. Anal., 2009 + implicit none + !If projection is present and true, set dt to zero and just project U + !into div-conforming space + real, intent(in) :: g,dt,theta,D0 + type(vector_field), intent(in) :: U,X,down + type(scalar_field), intent(in) :: D,f + integer, intent(in) :: ele + real, dimension(:,:)& + &, intent(inout) :: local_solver_matrix + real, dimension(:,:)& + &, intent(inout), optional :: local_solver_rhs + logical, intent(in), optional :: projection, poisson + logical, intent(in) :: have_constraint + ! + real, dimension(mesh_dim(U), X%dim, ele_ngi(U,ele)) :: J + real, dimension(ele_ngi(x,ele)) :: f_gi + real, dimension(X%dim, ele_ngi(X,ele)) :: up_gi + real, dimension(mesh_dim(U),ele_loc(U,ele),ele_loc(D,ele)) :: l_div_mat + real, dimension(mesh_dim(U), mesh_dim(U), ele_ngi(U,ele)) :: Metric, & + &Metricf + real, dimension(X%dim, X%dim, ele_ngi(U,ele)) :: rot + real, dimension(mesh_dim(U),mesh_dim(U),ele_loc(U,ele),ele_loc(U& + &,ele)) :: l_u_mat + integer :: mdim, uloc,dloc,dim1,dim2,gi + type(element_type) :: u_shape, d_shape + real, dimension(ele_ngi(D,ele)) :: detwei, detJ + integer, dimension(:), pointer :: D_ele,U_ele + integer :: d_start, d_end + integer, dimension(mesh_dim(U)) :: U_start, U_end + type(constraints_type), pointer :: constraints + integer :: i1, c_start, c_end + real :: l_dt + + if(present_and_true(projection)) then + l_dt = 0. + else + l_dt = dt + end if + + mdim = mesh_dim(U) + uloc = ele_loc(U,ele) + dloc = ele_loc(d,ele) + + d_start = uloc*2 + 1 + d_end = uloc*2+dloc + do dim1 = 1, mdim + u_start(dim1) = uloc*(dim1-1)+1 + u_end(dim1) = uloc*dim1 + end do + + local_solver_matrix = 0. + if(present(local_solver_rhs)) then + local_solver_rhs = 0. + end if + + u_shape=ele_shape(u, ele) + D_shape=ele_shape(d, ele) + D_ele => ele_nodes(D, ele) + U_ele => ele_nodes(U, ele) + + if(present_and_true(projection)) then + f_gi = 0. + else + f_gi = ele_val_at_quad(f,ele) + end if + up_gi = -ele_val_at_quad(down,ele) + + call get_up_gi(X,ele,up_gi) + + !J, detJ is needed for Piola transform + !detwei is needed for pressure mass matrix + call compute_jacobian(X, ele, J=J, detwei=detwei, detJ=detJ) + + !----construct local solver + !metrics for velocity mass and coriolis matrices + do gi=1, ele_ngi(U,ele) + rot(1,:,gi)=(/0.,-up_gi(3,gi),up_gi(2,gi)/) + rot(2,:,gi)=(/up_gi(3,gi),0.,-up_gi(1,gi)/) + rot(3,:,gi)=(/-up_gi(2,gi),up_gi(1,gi),0./) + end do + do gi=1,ele_ngi(U,ele) + Metric(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) + Metricf(:,:,gi)=matmul(J(:,:,gi), & matmul(f_gi(gi)*rot(:,:,gi), transpose(J(:,:,gi))))/detJ(gi) - end do - - ! + dt*theta* - g*dt*theta
= - - !dt*theta*<\phi,div u> + D_0<\phi,h> = 0 - - !pressure mass matrix (done in global coordinates) - local_solver_matrix(d_start:d_end,d_start:d_end)=& - &shape_shape(d_shape,d_shape,detwei) - if(present(local_solver_rhs)) then - local_solver_rhs(d_start:d_end,d_start:d_end) = & - shape_shape(d_shape,d_shape,detwei) - end if - !divergence matrix (done in local coordinates) - l_div_mat = dshape_shape(u_shape%dn,d_shape,& - &D_shape%quadrature%weight) - do dim1 = 1, mdim - !pressure gradient term [integrated by parts so minus sign] - local_solver_matrix(u_start(dim1):u_end(dim1),d_start:d_end)=& - & -g*l_dt*theta*l_div_mat(dim1,:,:) - if(present(local_solver_rhs)) then - local_solver_rhs(u_start(dim1):u_end(dim1),d_start:d_end)=& - & -g*(theta-1.0)*l_dt*l_div_mat(dim1,:,:) - end if - !divergence continuity term - local_solver_matrix(d_start:d_end,u_start(dim1):u_end(dim1))=& - & d0*l_dt*theta*transpose(l_div_mat(dim1,:,:)) - if(present(local_solver_rhs)) then - local_solver_rhs(d_start:d_end,u_start(dim1):u_end(dim1))=& - & d0*(theta-1.0)*l_dt*transpose(l_div_mat(dim1,:,:)) - end if - end do - !velocity mass matrix and Coriolis matrix (done in local coordinates) - l_u_mat = shape_shape_tensor(u_shape, u_shape, & + end do + + ! + dt*theta* - g*dt*theta
= - + !dt*theta*<\phi,div u> + D_0<\phi,h> = 0 + + !pressure mass matrix (done in global coordinates) + local_solver_matrix(d_start:d_end,d_start:d_end)=& + &shape_shape(d_shape,d_shape,detwei) + if(present(local_solver_rhs)) then + local_solver_rhs(d_start:d_end,d_start:d_end) = & + shape_shape(d_shape,d_shape,detwei) + end if + !divergence matrix (done in local coordinates) + l_div_mat = dshape_shape(u_shape%dn,d_shape,& + &D_shape%quadrature%weight) + do dim1 = 1, mdim + !pressure gradient term [integrated by parts so minus sign] + local_solver_matrix(u_start(dim1):u_end(dim1),d_start:d_end)=& + & -g*l_dt*theta*l_div_mat(dim1,:,:) + if(present(local_solver_rhs)) then + local_solver_rhs(u_start(dim1):u_end(dim1),d_start:d_end)=& + & -g*(theta-1.0)*l_dt*l_div_mat(dim1,:,:) + end if + !divergence continuity term + local_solver_matrix(d_start:d_end,u_start(dim1):u_end(dim1))=& + & d0*l_dt*theta*transpose(l_div_mat(dim1,:,:)) + if(present(local_solver_rhs)) then + local_solver_rhs(d_start:d_end,u_start(dim1):u_end(dim1))=& + & d0*(theta-1.0)*l_dt*transpose(l_div_mat(dim1,:,:)) + end if + end do + !velocity mass matrix and Coriolis matrix (done in local coordinates) + l_u_mat = shape_shape_tensor(u_shape, u_shape, & u_shape%quadrature%weight, Metric+l_dt*theta*Metricf) - do dim1 = 1, mdim - do dim2 = 1, mdim - local_solver_matrix(u_start(dim1):u_end(dim1),& + do dim1 = 1, mdim + do dim2 = 1, mdim + local_solver_matrix(u_start(dim1):u_end(dim1),& u_start(dim2):u_end(dim2))=& - & l_u_mat(dim1,dim2,:,:) - end do - end do + & l_u_mat(dim1,dim2,:,:) + end do + end do - if(present(local_solver_rhs)) then - l_u_mat = shape_shape_tensor(u_shape, u_shape, & + if(present(local_solver_rhs)) then + l_u_mat = shape_shape_tensor(u_shape, u_shape, & u_shape%quadrature%weight, & Metric+(theta-1.0)*l_dt*Metricf) - do dim1 = 1, mdim - do dim2 = 1, mdim - local_solver_rhs(u_start(dim1):u_end(dim1),& + do dim1 = 1, mdim + do dim2 = 1, mdim + local_solver_rhs(u_start(dim1):u_end(dim1),& u_start(dim2):u_end(dim2))=& - & l_u_mat(dim1,dim2,:,:) - end do - end do - end if - - if(have_constraint) then - constraints => U%mesh%shape%constraints - c_start = d_end+1 - c_end = d_end + constraints%n_constraints - do i1 = 1, constraints%n_constraints - do dim1 = 1, mdim - local_solver_matrix(d_end+i1,u_start(dim1):u_end(dim1))=& - &constraints%orthogonal(i1,:,dim1) - local_solver_matrix(u_start(dim1):u_end(dim1),d_end+i1)=& - &constraints%orthogonal(i1,:,dim1) - end do - end do - end if - - end subroutine get_local_solver - - subroutine get_up_gi(X,ele,up_gi,orientation) - !subroutine to replace up_gi with a normal to the surface - !with the same orientation - implicit none - type(vector_field), intent(in) :: X - integer, intent(in) :: ele - real, dimension(X%dim,ele_ngi(X,ele)), intent(inout) :: up_gi - integer, intent(out), optional :: orientation - ! - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - integer :: gi - real, dimension(X%dim,ele_ngi(X,ele)) :: normal_gi - real, dimension(ele_ngi(X,ele)) :: orientation_gi - real :: norm - - call compute_jacobian(X, ele, J) - - select case(mesh_dim(X)) - case (2) - !Coriolis only makes sense for 2d surfaces embedded in 3d - do gi = 1, ele_ngi(X,ele) - normal_gi(:,gi) = cross_product(J(1,:,gi),J(2,:,gi)) - norm = sqrt(sum(normal_gi(:,gi)**2)) - normal_gi(:,gi) = normal_gi(:,gi)/norm - end do - do gi = 1, ele_ngi(X,ele) - orientation_gi(gi) = dot_product(normal_gi(:,gi),up_gi(:,gi)) - end do - if(any(abs(orientation_gi-orientation_gi(1))>1.0e-8)) then - FLAbort('Nasty geometry problem') - end if - do gi = 1, ele_ngi(X,ele) - up_gi(:,gi) = normal_gi(:,gi)*orientation_gi(gi) - end do - if(present(orientation)) then - if(orientation_gi(1)>0.0) then - orientation = 1 - else - orientation = -1 - end if - end if - case default - FLAbort('not implemented') - end select - end subroutine get_up_gi - - function get_orientation(X_val, up) result (orientation) - !function compares the orientation of the element with the - !up direction - implicit none - real, dimension(:,:), intent(in) :: X_val !(dim,loc) - real, dimension(:,:), intent(in) :: up - integer :: orientation - ! - real, dimension(size(X_val,1)) :: t1,t2 - real, dimension(size(X_val,1)) :: crossprod - integer :: gi - ! if elements are triangles: - if(size(X_val,2)==3) then - t1 = X_val(:,2)-X_val(:,1) - t2 = X_val(:,3)-X_val(:,1) - crossprod = cross_product(t1,t2) - if(dot_product(crossprod,up(:,1))>0.0) then - do gi = 1, size(up,2) - if(dot_product(crossprod,up(:,gi))<0.0) then - FLAbort('Something nasty with down direction') - end if - end do - orientation = 1 - else - do gi = 1, size(up,2) - if(dot_product(crossprod,up(:,gi))>0.0) then - FLAbort('Something nasty with down direction') - end if - end do - orientation = -1 - end if - else - FLAbort('Haven''t sorted out quads yet.') - end if - end function get_orientation - - subroutine get_continuity_face_mat(continuity_face_mat,face,& - U,lambda) - ! integral is done in local coordinates to avoid computing - ! dx/dxi on face (using properties of the Piola transform) - ! \int_f [[w]]\lambda dS - implicit none - integer, intent(in) :: face - type(scalar_field), intent(in) :: lambda - type(vector_field), intent(in) :: U - real, dimension(mesh_dim(U),face_loc(U,face),face_loc(lambda,face)),& - &intent(inout) :: continuity_face_mat - ! - real, dimension(U%dim, face_ngi(U, face)) :: n1 - real :: weight - type(element_type), pointer :: U_face_shape,lambda_face_shape - real, dimension(face_ngi(U,face)) :: detwei - - U_face_shape=>face_shape(U, face) - lambda_face_shape=>face_shape(lambda, face) - - !Get normal in local coordinates - call get_local_normal(n1,weight,U,local_face_number(U%mesh,face)) - detwei = weight*U_face_shape%quadrature%weight - - continuity_face_mat = shape_shape_vector(& + & l_u_mat(dim1,dim2,:,:) + end do + end do + end if + + if(have_constraint) then + constraints => U%mesh%shape%constraints + c_start = d_end+1 + c_end = d_end + constraints%n_constraints + do i1 = 1, constraints%n_constraints + do dim1 = 1, mdim + local_solver_matrix(d_end+i1,u_start(dim1):u_end(dim1))=& + &constraints%orthogonal(i1,:,dim1) + local_solver_matrix(u_start(dim1):u_end(dim1),d_end+i1)=& + &constraints%orthogonal(i1,:,dim1) + end do + end do + end if + + end subroutine get_local_solver + + subroutine get_up_gi(X,ele,up_gi,orientation) + !subroutine to replace up_gi with a normal to the surface + !with the same orientation + implicit none + type(vector_field), intent(in) :: X + integer, intent(in) :: ele + real, dimension(X%dim,ele_ngi(X,ele)), intent(inout) :: up_gi + integer, intent(out), optional :: orientation + ! + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + integer :: gi + real, dimension(X%dim,ele_ngi(X,ele)) :: normal_gi + real, dimension(ele_ngi(X,ele)) :: orientation_gi + real :: norm + + call compute_jacobian(X, ele, J) + + select case(mesh_dim(X)) + case (2) + !Coriolis only makes sense for 2d surfaces embedded in 3d + do gi = 1, ele_ngi(X,ele) + normal_gi(:,gi) = cross_product(J(1,:,gi),J(2,:,gi)) + norm = sqrt(sum(normal_gi(:,gi)**2)) + normal_gi(:,gi) = normal_gi(:,gi)/norm + end do + do gi = 1, ele_ngi(X,ele) + orientation_gi(gi) = dot_product(normal_gi(:,gi),up_gi(:,gi)) + end do + if(any(abs(orientation_gi-orientation_gi(1))>1.0e-8)) then + FLAbort('Nasty geometry problem') + end if + do gi = 1, ele_ngi(X,ele) + up_gi(:,gi) = normal_gi(:,gi)*orientation_gi(gi) + end do + if(present(orientation)) then + if(orientation_gi(1)>0.0) then + orientation = 1 + else + orientation = -1 + end if + end if + case default + FLAbort('not implemented') + end select + end subroutine get_up_gi + + function get_orientation(X_val, up) result (orientation) + !function compares the orientation of the element with the + !up direction + implicit none + real, dimension(:,:), intent(in) :: X_val !(dim,loc) + real, dimension(:,:), intent(in) :: up + integer :: orientation + ! + real, dimension(size(X_val,1)) :: t1,t2 + real, dimension(size(X_val,1)) :: crossprod + integer :: gi + ! if elements are triangles: + if(size(X_val,2)==3) then + t1 = X_val(:,2)-X_val(:,1) + t2 = X_val(:,3)-X_val(:,1) + crossprod = cross_product(t1,t2) + if(dot_product(crossprod,up(:,1))>0.0) then + do gi = 1, size(up,2) + if(dot_product(crossprod,up(:,gi))<0.0) then + FLAbort('Something nasty with down direction') + end if + end do + orientation = 1 + else + do gi = 1, size(up,2) + if(dot_product(crossprod,up(:,gi))>0.0) then + FLAbort('Something nasty with down direction') + end if + end do + orientation = -1 + end if + else + FLAbort('Haven''t sorted out quads yet.') + end if + end function get_orientation + + subroutine get_continuity_face_mat(continuity_face_mat,face,& + U,lambda) + ! integral is done in local coordinates to avoid computing + ! dx/dxi on face (using properties of the Piola transform) + ! \int_f [[w]]\lambda dS + implicit none + integer, intent(in) :: face + type(scalar_field), intent(in) :: lambda + type(vector_field), intent(in) :: U + real, dimension(mesh_dim(U),face_loc(U,face),face_loc(lambda,face)),& + &intent(inout) :: continuity_face_mat + ! + real, dimension(U%dim, face_ngi(U, face)) :: n1 + real :: weight + type(element_type), pointer :: U_face_shape,lambda_face_shape + real, dimension(face_ngi(U,face)) :: detwei + + U_face_shape=>face_shape(U, face) + lambda_face_shape=>face_shape(lambda, face) + + !Get normal in local coordinates + call get_local_normal(n1,weight,U,local_face_number(U%mesh,face)) + detwei = weight*U_face_shape%quadrature%weight + + continuity_face_mat = shape_shape_vector(& U_face_shape,lambda_face_shape,detwei,n1) - end subroutine get_continuity_face_mat - - subroutine get_scalar_continuity_face_mat(continuity_face_mat,face,& - lambda) - ! integral is done in local coordinates to avoid computing - ! dx/dxi on face (using properties of the Piola transform) - ! \int_f [[w]]\lambda dS - implicit none - integer, intent(in) :: face - type(scalar_field), intent(in) :: lambda - real, dimension(face_loc(lambda,face),face_loc(lambda,face)),& - &intent(inout) :: continuity_face_mat - ! - real :: weight - type(element_type), pointer :: lambda_face_shape - real, dimension(face_ngi(lambda,face)) :: detwei - - lambda_face_shape=>face_shape(lambda, face) - - !Integral is taken on one of the edges of the local 2D element - !This edge must be transformed to the local 1D element - !to do numerical integration, with the following weight factors - if(face==3) then - weight = sqrt(2.) - else - weight = 1.0 - end if - - !Get normal in local coordinates - detwei = weight*lambda_face_shape%quadrature%weight - - continuity_face_mat = shape_shape(& + end subroutine get_continuity_face_mat + + subroutine get_scalar_continuity_face_mat(continuity_face_mat,face,& + lambda) + ! integral is done in local coordinates to avoid computing + ! dx/dxi on face (using properties of the Piola transform) + ! \int_f [[w]]\lambda dS + implicit none + integer, intent(in) :: face + type(scalar_field), intent(in) :: lambda + real, dimension(face_loc(lambda,face),face_loc(lambda,face)),& + &intent(inout) :: continuity_face_mat + ! + real :: weight + type(element_type), pointer :: lambda_face_shape + real, dimension(face_ngi(lambda,face)) :: detwei + + lambda_face_shape=>face_shape(lambda, face) + + !Integral is taken on one of the edges of the local 2D element + !This edge must be transformed to the local 1D element + !to do numerical integration, with the following weight factors + if(face==3) then + weight = sqrt(2.) + else + weight = 1.0 + end if + + !Get normal in local coordinates + detwei = weight*lambda_face_shape%quadrature%weight + + continuity_face_mat = shape_shape(& lambda_face_shape,lambda_face_shape,detwei) - end subroutine get_scalar_continuity_face_mat - - subroutine get_local_normal(norm,weight,U,face) - !Function returns normal to face on local 2D element - implicit none - type(vector_field), intent(in) :: U - integer, intent(in) :: face - real, dimension(U%dim, face_ngi(U,face)), intent(out) :: norm - real, intent(out) :: weight - - integer :: i - - select case(U%mesh%shape%numbering%family) - case (FAMILY_SIMPLEX) - if(U%dim==1) then - if(face==1) then - forall(i=1:face_ngi(U,face)) norm(1,i)=1. - else if(face==2) then - forall(i=1:face_ngi(U,face)) norm(1,i)=-1. - else - FLAbort('Funny face?') - end if - weight = 1.0 - - else if(U%dim==2) then - if(face==1) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/-1.,0./) - else if(face==2) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/0.,-1./) - else if(face==3) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/1/sqrt(2.),1& - &/sqrt(2.)/) - else - FLAbort('Funny face?') - end if - - !Integral is taken on one of the edges of the local 2D element - !This edge must be transformed to the local 1D element - !to do numerical integration, with the following weight factors - if(face==3) then - weight = sqrt(2.) - else - weight = 1.0 - end if - - else - FLAbort('Dimension not supported.') - end if - case (FAMILY_CUBE) - if(U%dim==2) then - if(face==1) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/-1.,0./) - else if(face==2) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/ 1.,0./) - else if(face==3) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/0.,-1./) - else if(face==4) then - forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/0.,1./) - else - FLAbort('Funny face?') - end if - weight = 1.0 - else - FLAbort('Dimension not supported.') - end if - end select - - end subroutine get_local_normal - - subroutine compute_cartesian_ele(U_cart,U,X,ele) - implicit none - type(vector_field), intent(inout) :: U_cart - type(vector_field), intent(in) :: U, X - integer, intent(in) :: ele - ! - real, dimension(ele_loc(U,ele),ele_loc(U,ele)) :: l_u_mat - real, dimension(X%dim,ele_loc(U,ele)) :: u_rhs - real, dimension(mesh_dim(U), ele_ngi(U,ele)) :: local_u_gi - real, dimension(X%dim, ele_ngi(U,ele)) :: cart_u_gi - integer :: dim1 - type(element_type) :: u_shape - integer, dimension(mesh_dim(U)) :: U_start, U_end - integer, dimension(:), pointer :: U_ele - integer :: mdim, uloc, gi - real, dimension(ele_ngi(U,ele)) :: detwei, detJ - real, dimension(mesh_dim(U), X%dim, ele_ngi(U,ele)) :: J - - mdim = mesh_dim(U) - uloc = ele_loc(U,ele) - do dim1 = 1, mdim - u_start(dim1) = uloc*(dim1-1)+1 - u_end(dim1) = uloc+dim1 - end do - - U_ele => ele_nodes(U, ele) - - u_shape=ele_shape(u, ele) - call compute_jacobian(X, ele, J=J, detwei=detwei,detJ=detJ) - - local_u_gi = ele_val_at_quad(U,ele) - do gi = 1, ele_ngi(U,ele) - cart_u_gi(:,gi) = matmul(transpose(J(:,:,gi)),local_u_gi(:,gi))/detJ(gi) - end do - u_rhs = shape_vector_rhs(u_shape,cart_u_gi,detwei) - l_u_mat = shape_shape(u_shape, u_shape, detwei) - - do dim1 = 1, mdim - call solve(l_u_mat,u_rhs(dim1,:)) - end do - - do dim1 = 1, U_cart%dim - call set(U_cart,dim1,u_ele,u_rhs(dim1,:)) - end do - end subroutine compute_cartesian_ele - - subroutine check_continuity_local_ele(U,ele) - implicit none - type(vector_field), intent(in) :: U - integer, intent(in) :: ele - ! - integer, dimension(:), pointer :: neigh - integer :: ni,face,ele2,face2 - - neigh => ele_neigh(U,ele) - do ni = 1, size(neigh) - ele2 = neigh(ni) - face = ele_face(U,ele,ele2) - if(ele2>0) then - face2 = ele_face(U,ele2,ele) - else - face2 = -1 - end if - call check_continuity_local_face(U,ele,ele2,face,face2) - end do - end subroutine check_continuity_local_ele - - subroutine check_continuity_local_face(U,ele,ele2,face,face2) - implicit none - integer, intent(in) :: face, face2,ele,ele2 - type(vector_field), intent(in) :: U - ! - real, dimension(U%dim, face_ngi(U, face)) :: n1,n2,u1,u2 - real :: weight, jump - - !Get normal in local coordinates - call get_local_normal(n1,weight,U,local_face_number(U%mesh,face)) - call get_local_normal(n2,weight,U,local_face_number(U%mesh,face2)) - u1 = face_val_at_quad(U,face) - u2 = face_val_at_quad(U,face2) - jump = maxval(abs(sum(u1*n1+u2*n2,1))) - ewrite(1,*) jump - assert(jump<1.0e-8) - - end subroutine check_continuity_local_face - - subroutine check_continuity_ele(U_cart,X,ele) - implicit none - type(vector_field), intent(in) :: U_cart,X - integer, intent(in) :: ele - ! - integer, dimension(:), pointer :: neigh - integer :: ni,face,ele2,face2 - - neigh => ele_neigh(U_cart,ele) - do ni = 1, size(neigh) - ele2 = neigh(ni) - face = ele_face(U_cart,ele,ele2) - if(ele2>0) then - face2 = ele_face(U_cart,ele2,ele) - else - face2 = -1 - end if - call check_continuity_face(U_cart,X,ele,ele2,face,face2) - end do - end subroutine check_continuity_ele - - subroutine check_continuity_face(U_cart,X,ele,ele2,face,face2) - !subroutine to check the continuity of normal component - !of velocity at quadrature points - implicit none - type(vector_field), intent(in) :: U_cart,X - integer, intent(in) :: face,face2,ele,ele2 - real, dimension(X%dim, face_ngi(U_cart, face)) :: n1,n2 - real, dimension(X%dim, face_ngi(U_cart, face)) :: u1,u2,x1 - real, dimension(face_ngi(U_cart, face)) :: jump_at_quad - integer :: dim1 - ! - u1 = face_val_at_quad(U_cart,face) - x1 = face_val_at_quad(X,face) - if(ele2>0) then - u2 = face_val_at_quad(U_cart,face2) - else - u2 = 0. - end if - - n1 = get_face_normal_manifold(X,ele,face) - if(ele2>0) then - n2 = get_face_normal_manifold(X,ele2,face2) - else - n2 = -n1 - end if - jump_at_quad = sum(n1*u1+n2*u2,1) - if(maxval(abs(jump_at_quad))>1.0e-8) then - ewrite(1,*) 'Jump at quadrature face, face2 =', jump_at_quad - ewrite(1,*) 'ELE = ',ele,ele2 - do dim1 = 1, X%dim - ewrite(1,*) 'normal',dim1,n1(dim1,:) - ewrite(1,*) 'normal',dim1,n2(dim1,:) - ewrite(1,*) 'X',dim1,x1(dim1,:) - end do - ewrite(1,*) 'n cpt1',sum(n1*u1,1) - ewrite(1,*) 'n cpt2',sum(n2*u2,1) - ewrite(1,*) jump_at_quad/max(maxval(abs(u1)),maxval(abs(u2))) - FLAbort('stopping because of jumps') - end if - - end subroutine check_continuity_face - - function get_face_normal_manifold(X,ele,face) result (normal) - implicit none - type(vector_field), intent(in) :: X - integer, intent(in) :: ele, face - real, dimension(X%dim,face_ngi(X,face)) :: normal - ! - real, dimension(ele_ngi(X,ele)) :: detwei - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - real, dimension(face_ngi(X,face)) :: detwei_f - real, dimension(mesh_dim(X)-1, X%dim, face_ngi(X,face)) :: J_f - real, dimension(ele_loc(X,ele),ele_loc(X,ele)) :: X_mass_mat - real, dimension(mesh_dim(X), X%dim, ele_loc(X,ele)) :: J_loc - real, dimension(ele_loc(X,ele)) :: J_loc_rhs - real, dimension(mesh_dim(X), X%dim, face_ngi(X,face)) :: J_face_gi - integer :: dim1, dim2, gi - real, dimension(X%dim) :: ele_normal_gi, edge_tangent_gi, X_mid_ele,& - &X_mid_face - type(element_type) :: X_shape, X_face_shape - - call compute_jacobian(X, ele, J=J, detwei=detwei) - call compute_jacobian(X,face, J=J_f, detwei=detwei_f, facet=.true.) - - !Jacobian can be expanded without error in X function space - !so we map it to the basis function DOFs by projection - X_shape = ele_shape(X,ele) - X_face_shape = face_shape(X,face) - X_mass_mat = shape_shape(X_shape,X_shape,detwei) - do dim1 = 1, mesh_dim(X) - do dim2 = 1, X%dim - J_loc_rhs = shape_rhs(X_shape,J(dim1,dim2,:)*detwei) - call solve(X_mass_mat,J_loc_rhs) - J_loc(dim1,dim2,:) = J_loc_rhs - end do - end do - - do dim1 = 1, mesh_dim(X) - do dim2 = 1, X%dim - J_face_gi(dim1,dim2,:) = & - & matmul(transpose(X_face_shape%n),& + end subroutine get_scalar_continuity_face_mat + + subroutine get_local_normal(norm,weight,U,face) + !Function returns normal to face on local 2D element + implicit none + type(vector_field), intent(in) :: U + integer, intent(in) :: face + real, dimension(U%dim, face_ngi(U,face)), intent(out) :: norm + real, intent(out) :: weight + + integer :: i + + select case(U%mesh%shape%numbering%family) + case (FAMILY_SIMPLEX) + if(U%dim==1) then + if(face==1) then + forall(i=1:face_ngi(U,face)) norm(1,i)=1. + else if(face==2) then + forall(i=1:face_ngi(U,face)) norm(1,i)=-1. + else + FLAbort('Funny face?') + end if + weight = 1.0 + + else if(U%dim==2) then + if(face==1) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/-1.,0./) + else if(face==2) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/0.,-1./) + else if(face==3) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/1/sqrt(2.),1& + &/sqrt(2.)/) + else + FLAbort('Funny face?') + end if + + !Integral is taken on one of the edges of the local 2D element + !This edge must be transformed to the local 1D element + !to do numerical integration, with the following weight factors + if(face==3) then + weight = sqrt(2.) + else + weight = 1.0 + end if + + else + FLAbort('Dimension not supported.') + end if + case (FAMILY_CUBE) + if(U%dim==2) then + if(face==1) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/-1.,0./) + else if(face==2) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/ 1.,0./) + else if(face==3) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/0.,-1./) + else if(face==4) then + forall(i=1:face_ngi(U,face)) norm(1:2,i)=(/0.,1./) + else + FLAbort('Funny face?') + end if + weight = 1.0 + else + FLAbort('Dimension not supported.') + end if + end select + + end subroutine get_local_normal + + subroutine compute_cartesian_ele(U_cart,U,X,ele) + implicit none + type(vector_field), intent(inout) :: U_cart + type(vector_field), intent(in) :: U, X + integer, intent(in) :: ele + ! + real, dimension(ele_loc(U,ele),ele_loc(U,ele)) :: l_u_mat + real, dimension(X%dim,ele_loc(U,ele)) :: u_rhs + real, dimension(mesh_dim(U), ele_ngi(U,ele)) :: local_u_gi + real, dimension(X%dim, ele_ngi(U,ele)) :: cart_u_gi + integer :: dim1 + type(element_type) :: u_shape + integer, dimension(mesh_dim(U)) :: U_start, U_end + integer, dimension(:), pointer :: U_ele + integer :: mdim, uloc, gi + real, dimension(ele_ngi(U,ele)) :: detwei, detJ + real, dimension(mesh_dim(U), X%dim, ele_ngi(U,ele)) :: J + + mdim = mesh_dim(U) + uloc = ele_loc(U,ele) + do dim1 = 1, mdim + u_start(dim1) = uloc*(dim1-1)+1 + u_end(dim1) = uloc+dim1 + end do + + U_ele => ele_nodes(U, ele) + + u_shape=ele_shape(u, ele) + call compute_jacobian(X, ele, J=J, detwei=detwei,detJ=detJ) + + local_u_gi = ele_val_at_quad(U,ele) + do gi = 1, ele_ngi(U,ele) + cart_u_gi(:,gi) = matmul(transpose(J(:,:,gi)),local_u_gi(:,gi))/detJ(gi) + end do + u_rhs = shape_vector_rhs(u_shape,cart_u_gi,detwei) + l_u_mat = shape_shape(u_shape, u_shape, detwei) + + do dim1 = 1, mdim + call solve(l_u_mat,u_rhs(dim1,:)) + end do + + do dim1 = 1, U_cart%dim + call set(U_cart,dim1,u_ele,u_rhs(dim1,:)) + end do + end subroutine compute_cartesian_ele + + subroutine check_continuity_local_ele(U,ele) + implicit none + type(vector_field), intent(in) :: U + integer, intent(in) :: ele + ! + integer, dimension(:), pointer :: neigh + integer :: ni,face,ele2,face2 + + neigh => ele_neigh(U,ele) + do ni = 1, size(neigh) + ele2 = neigh(ni) + face = ele_face(U,ele,ele2) + if(ele2>0) then + face2 = ele_face(U,ele2,ele) + else + face2 = -1 + end if + call check_continuity_local_face(U,ele,ele2,face,face2) + end do + end subroutine check_continuity_local_ele + + subroutine check_continuity_local_face(U,ele,ele2,face,face2) + implicit none + integer, intent(in) :: face, face2,ele,ele2 + type(vector_field), intent(in) :: U + ! + real, dimension(U%dim, face_ngi(U, face)) :: n1,n2,u1,u2 + real :: weight, jump + + !Get normal in local coordinates + call get_local_normal(n1,weight,U,local_face_number(U%mesh,face)) + call get_local_normal(n2,weight,U,local_face_number(U%mesh,face2)) + u1 = face_val_at_quad(U,face) + u2 = face_val_at_quad(U,face2) + jump = maxval(abs(sum(u1*n1+u2*n2,1))) + ewrite(1,*) jump + assert(jump<1.0e-8) + + end subroutine check_continuity_local_face + + subroutine check_continuity_ele(U_cart,X,ele) + implicit none + type(vector_field), intent(in) :: U_cart,X + integer, intent(in) :: ele + ! + integer, dimension(:), pointer :: neigh + integer :: ni,face,ele2,face2 + + neigh => ele_neigh(U_cart,ele) + do ni = 1, size(neigh) + ele2 = neigh(ni) + face = ele_face(U_cart,ele,ele2) + if(ele2>0) then + face2 = ele_face(U_cart,ele2,ele) + else + face2 = -1 + end if + call check_continuity_face(U_cart,X,ele,ele2,face,face2) + end do + end subroutine check_continuity_ele + + subroutine check_continuity_face(U_cart,X,ele,ele2,face,face2) + !subroutine to check the continuity of normal component + !of velocity at quadrature points + implicit none + type(vector_field), intent(in) :: U_cart,X + integer, intent(in) :: face,face2,ele,ele2 + real, dimension(X%dim, face_ngi(U_cart, face)) :: n1,n2 + real, dimension(X%dim, face_ngi(U_cart, face)) :: u1,u2,x1 + real, dimension(face_ngi(U_cart, face)) :: jump_at_quad + integer :: dim1 + ! + u1 = face_val_at_quad(U_cart,face) + x1 = face_val_at_quad(X,face) + if(ele2>0) then + u2 = face_val_at_quad(U_cart,face2) + else + u2 = 0. + end if + + n1 = get_face_normal_manifold(X,ele,face) + if(ele2>0) then + n2 = get_face_normal_manifold(X,ele2,face2) + else + n2 = -n1 + end if + jump_at_quad = sum(n1*u1+n2*u2,1) + if(maxval(abs(jump_at_quad))>1.0e-8) then + ewrite(1,*) 'Jump at quadrature face, face2 =', jump_at_quad + ewrite(1,*) 'ELE = ',ele,ele2 + do dim1 = 1, X%dim + ewrite(1,*) 'normal',dim1,n1(dim1,:) + ewrite(1,*) 'normal',dim1,n2(dim1,:) + ewrite(1,*) 'X',dim1,x1(dim1,:) + end do + ewrite(1,*) 'n cpt1',sum(n1*u1,1) + ewrite(1,*) 'n cpt2',sum(n2*u2,1) + ewrite(1,*) jump_at_quad/max(maxval(abs(u1)),maxval(abs(u2))) + FLAbort('stopping because of jumps') + end if + + end subroutine check_continuity_face + + function get_face_normal_manifold(X,ele,face) result (normal) + implicit none + type(vector_field), intent(in) :: X + integer, intent(in) :: ele, face + real, dimension(X%dim,face_ngi(X,face)) :: normal + ! + real, dimension(ele_ngi(X,ele)) :: detwei + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + real, dimension(face_ngi(X,face)) :: detwei_f + real, dimension(mesh_dim(X)-1, X%dim, face_ngi(X,face)) :: J_f + real, dimension(ele_loc(X,ele),ele_loc(X,ele)) :: X_mass_mat + real, dimension(mesh_dim(X), X%dim, ele_loc(X,ele)) :: J_loc + real, dimension(ele_loc(X,ele)) :: J_loc_rhs + real, dimension(mesh_dim(X), X%dim, face_ngi(X,face)) :: J_face_gi + integer :: dim1, dim2, gi + real, dimension(X%dim) :: ele_normal_gi, edge_tangent_gi, X_mid_ele,& + &X_mid_face + type(element_type) :: X_shape, X_face_shape + + call compute_jacobian(X, ele, J=J, detwei=detwei) + call compute_jacobian(X,face, J=J_f, detwei=detwei_f, facet=.true.) + + !Jacobian can be expanded without error in X function space + !so we map it to the basis function DOFs by projection + X_shape = ele_shape(X,ele) + X_face_shape = face_shape(X,face) + X_mass_mat = shape_shape(X_shape,X_shape,detwei) + do dim1 = 1, mesh_dim(X) + do dim2 = 1, X%dim + J_loc_rhs = shape_rhs(X_shape,J(dim1,dim2,:)*detwei) + call solve(X_mass_mat,J_loc_rhs) + J_loc(dim1,dim2,:) = J_loc_rhs + end do + end do + + do dim1 = 1, mesh_dim(X) + do dim2 = 1, X%dim + J_face_gi(dim1,dim2,:) = & + & matmul(transpose(X_face_shape%n),& J_loc(dim1,dim2,face_local_nodes(X,face))) - end do - end do - - X_mid_ele = sum(ele_val(X,ele),2)/size(ele_val(X,ele),2) - X_mid_face = sum(face_val(X,face),2)/size(face_val(X,face),2) - select case(X%dim) - case (3) - select case (mesh_dim(X)) - case (2) - do gi = 1, face_ngi(X,face) - !Get normal to element e on face quad points - ele_normal_gi = cross_product(J_face_gi(1,:,gi),& - &J_face_gi(2,:,gi)) - ele_normal_gi = ele_normal_gi/(norm2(ele_normal_gi)) - !Get tangent to face f - edge_tangent_gi = J_f(1,:,gi) - edge_tangent_gi = edge_tangent_gi/norm2(edge_tangent_gi) - !Compute normal to face f in manifold - normal(:,gi) = cross_product(ele_normal_gi,edge_tangent_gi) - if(dot_product(normal(:,gi),X_mid_face-X_mid_ele)<0) then - normal(:,gi)=-normal(:,gi) - end if - end do + end do + end do + + X_mid_ele = sum(ele_val(X,ele),2)/size(ele_val(X,ele),2) + X_mid_face = sum(face_val(X,face),2)/size(face_val(X,face),2) + select case(X%dim) + case (3) + select case (mesh_dim(X)) + case (2) + do gi = 1, face_ngi(X,face) + !Get normal to element e on face quad points + ele_normal_gi = cross_product(J_face_gi(1,:,gi),& + &J_face_gi(2,:,gi)) + ele_normal_gi = ele_normal_gi/(norm2(ele_normal_gi)) + !Get tangent to face f + edge_tangent_gi = J_f(1,:,gi) + edge_tangent_gi = edge_tangent_gi/norm2(edge_tangent_gi) + !Compute normal to face f in manifold + normal(:,gi) = cross_product(ele_normal_gi,edge_tangent_gi) + if(dot_product(normal(:,gi),X_mid_face-X_mid_ele)<0) then + normal(:,gi)=-normal(:,gi) + end if + end do + case default + FLAbort('dimension combination not implemented') + end select case default - FLAbort('dimension combination not implemented') - end select - case default - FLAbort('dimension combination not implemented') - end select - - end function get_face_normal_manifold - - subroutine reconstruct_lambda_nc(lambda,lambda_nc,X,ele) - type(scalar_field), intent(in) :: lambda - type(scalar_field), intent(inout) :: lambda_nc - type(vector_field), intent(in) :: X - integer, intent(in) :: ele - ! - real, dimension(ele_loc(lambda_nc,ele)) :: nc_rhs - type(element_type), pointer :: lambda_nc_shape - integer, dimension(:), pointer :: neigh - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - real, dimension(ele_ngi(lambda,ele)) :: detwei - integer :: ni,ele2,face - real, dimension(ele_loc(lambda_nc,ele),ele_loc(lambda_nc,ele)) :: & - & l_mass_mat - - nc_rhs = 0. - lambda_nc_shape => ele_shape(lambda_nc,ele) - neigh => ele_neigh(lambda,ele) - l_mass_mat = 0. - do ni = 1, size(neigh) - ele2 = neigh(ni) - face = ele_face(X,ele,ele2) - call get_nc_rhs_face(nc_rhs,l_mass_mat,lambda,lambda_nc,X,face) - end do - call compute_jacobian(X, ele, J=J, detwei=detwei) - call solve(l_mass_mat,nc_rhs) - call set(lambda_nc,ele_nodes(lambda_nc,ele),nc_rhs) - end subroutine reconstruct_lambda_nc - - subroutine get_nc_rhs_face(nc_rhs,l_mass_mat,& - lambda,lambda_nc,X,face) - implicit none - real, intent(inout), dimension(:) :: nc_rhs - real, intent(inout), dimension(:,:) :: l_mass_mat - type(scalar_field), intent(in) :: lambda, lambda_nc - type(vector_field), intent(in) :: X - integer, intent(in) :: face - ! - real, dimension(face_ngi(lambda,face)) :: detwei - type(element_type), pointer :: lambda_nc_face_shape - real, dimension(X%dim,face_loc(X,face)) :: x_loc - - lambda_nc_face_shape => face_shape(lambda_nc,face) - X_loc = face_val(X,face) - - call transform_facet_to_physical(X,face,detwei_f=detwei) - nc_rhs(face_local_nodes(lambda_nc,face)) = & - &nc_rhs(face_local_nodes(lambda_nc,face)) & - &+ shape_rhs(lambda_nc_face_shape,face_val_at_quad(lambda,face)*detwei) - l_mass_mat(face_local_nodes(lambda_nc,face), & - &face_local_nodes(lambda_nc,face)) = & - &l_mass_mat(face_local_nodes(lambda_nc,face), & - &face_local_nodes(lambda_nc,face)) + & - &shape_shape(lambda_nc_face_shape,lambda_nc_face_shape,detwei) - end subroutine get_nc_rhs_face - - subroutine assemble_rhs_ele(Rhs_loc,D,U,X,ele,D_rhs,U_rhs,u_rhs_local) - implicit none - integer, intent(in) :: ele - type(scalar_field), intent(in), optional, target :: D_rhs - type(vector_field), intent(in), optional, target :: U_rhs - type(vector_field), intent(in) :: X,U - type(scalar_field), intent(in) :: D - real, dimension(:), & - &intent(inout) :: Rhs_loc - logical, intent(in), optional :: u_rhs_local - ! - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - real, dimension(mesh_dim(U),ele_loc(U,ele)) :: u_rhs_loc - real, allocatable, dimension(:,:) :: u_cart_quad - real, dimension(mesh_dim(U),ele_ngi(X,ele)) :: u_local_quad - integer :: d_start, d_end, dim1, mdim, uloc,dloc, gi - integer, dimension(mesh_dim(U)) :: U_start, U_end - type(element_type) :: u_shape - real, dimension(ele_ngi(D,ele)) :: detwei, detJ - logical :: have_d_rhs,have_u_rhs - type(scalar_field), pointer :: l_d_rhs - type(vector_field), pointer :: l_u_rhs - real, dimension(mesh_dim(U), mesh_dim(U)) :: Metric - - !Get some sizes - mdim = mesh_dim(U) - uloc = ele_loc(U,ele) - dloc = ele_loc(d,ele) - U_shape = ele_shape(U,ele) - - !Calculate indices in a vector containing all the U and D dofs in - !element ele, First the u1 components, then the u2 components, then the - !D components are stored. - d_start = uloc*mdim + 1 - d_end = uloc*mdim+dloc - do dim1 = 1, mdim - u_start(dim1) = uloc*(dim1-1)+1 - u_end(dim1) = uloc*dim1 - end do - - if(.not.(present(D_rhs).or.present(u_rhs))) then - !We are in timestepping mode. - rhs_loc(d_start:d_end) = ele_val(D,ele) - u_rhs_loc = ele_val(U,ele) - do dim1 = 1, mdim - rhs_loc(u_start(dim1):u_end(dim1)) = & - & U_rhs_loc(dim1,:) - end do - else - have_d_rhs = present(d_rhs) - have_u_rhs = present(u_rhs) - if(have_d_rhs) l_d_rhs => d_rhs - if(have_u_rhs) l_u_rhs => u_rhs - - call compute_jacobian(X, ele, J=J, detJ=detJ,detwei=detwei) - - Rhs_loc = 0. - if(have_d_rhs) then - Rhs_loc(d_start:d_end) = shape_rhs(ele_shape(D,ele),& - &ele_val_at_quad(l_D_rhs,ele)*detwei) - end if - if(have_u_rhs) then - if(present_and_true(u_rhs_local)) then - u_local_quad = ele_val_at_quad(l_u_rhs,ele) - do gi=1,ele_ngi(U,ele) - Metric=matmul(J(:,:,gi), transpose(J(:,:,gi)))& - &/detJ(gi) - u_local_quad(:,gi) = matmul(Metric,u_local_quad(:,gi)) - end do - else - allocate(u_cart_quad(l_U_rhs%dim,ele_ngi(X,ele))) - u_cart_quad = ele_val_at_quad(l_u_rhs,ele) - do gi = 1, ele_ngi(D,ele) - !Don't divide by detJ as we can use weight instead of detwei - u_local_quad(:,gi) = matmul(J(:,:,gi)& - &,u_cart_quad(:,gi)) - end do - end if - U_rhs_loc = shape_vector_rhs(u_shape,& + FLAbort('dimension combination not implemented') + end select + + end function get_face_normal_manifold + + subroutine reconstruct_lambda_nc(lambda,lambda_nc,X,ele) + type(scalar_field), intent(in) :: lambda + type(scalar_field), intent(inout) :: lambda_nc + type(vector_field), intent(in) :: X + integer, intent(in) :: ele + ! + real, dimension(ele_loc(lambda_nc,ele)) :: nc_rhs + type(element_type), pointer :: lambda_nc_shape + integer, dimension(:), pointer :: neigh + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + real, dimension(ele_ngi(lambda,ele)) :: detwei + integer :: ni,ele2,face + real, dimension(ele_loc(lambda_nc,ele),ele_loc(lambda_nc,ele)) :: & + & l_mass_mat + + nc_rhs = 0. + lambda_nc_shape => ele_shape(lambda_nc,ele) + neigh => ele_neigh(lambda,ele) + l_mass_mat = 0. + do ni = 1, size(neigh) + ele2 = neigh(ni) + face = ele_face(X,ele,ele2) + call get_nc_rhs_face(nc_rhs,l_mass_mat,lambda,lambda_nc,X,face) + end do + call compute_jacobian(X, ele, J=J, detwei=detwei) + call solve(l_mass_mat,nc_rhs) + call set(lambda_nc,ele_nodes(lambda_nc,ele),nc_rhs) + end subroutine reconstruct_lambda_nc + + subroutine get_nc_rhs_face(nc_rhs,l_mass_mat,& + lambda,lambda_nc,X,face) + implicit none + real, intent(inout), dimension(:) :: nc_rhs + real, intent(inout), dimension(:,:) :: l_mass_mat + type(scalar_field), intent(in) :: lambda, lambda_nc + type(vector_field), intent(in) :: X + integer, intent(in) :: face + ! + real, dimension(face_ngi(lambda,face)) :: detwei + type(element_type), pointer :: lambda_nc_face_shape + real, dimension(X%dim,face_loc(X,face)) :: x_loc + + lambda_nc_face_shape => face_shape(lambda_nc,face) + X_loc = face_val(X,face) + + call transform_facet_to_physical(X,face,detwei_f=detwei) + nc_rhs(face_local_nodes(lambda_nc,face)) = & + &nc_rhs(face_local_nodes(lambda_nc,face)) & + &+ shape_rhs(lambda_nc_face_shape,face_val_at_quad(lambda,face)*detwei) + l_mass_mat(face_local_nodes(lambda_nc,face), & + &face_local_nodes(lambda_nc,face)) = & + &l_mass_mat(face_local_nodes(lambda_nc,face), & + &face_local_nodes(lambda_nc,face)) + & + &shape_shape(lambda_nc_face_shape,lambda_nc_face_shape,detwei) + end subroutine get_nc_rhs_face + + subroutine assemble_rhs_ele(Rhs_loc,D,U,X,ele,D_rhs,U_rhs,u_rhs_local) + implicit none + integer, intent(in) :: ele + type(scalar_field), intent(in), optional, target :: D_rhs + type(vector_field), intent(in), optional, target :: U_rhs + type(vector_field), intent(in) :: X,U + type(scalar_field), intent(in) :: D + real, dimension(:), & + &intent(inout) :: Rhs_loc + logical, intent(in), optional :: u_rhs_local + ! + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + real, dimension(mesh_dim(U),ele_loc(U,ele)) :: u_rhs_loc + real, allocatable, dimension(:,:) :: u_cart_quad + real, dimension(mesh_dim(U),ele_ngi(X,ele)) :: u_local_quad + integer :: d_start, d_end, dim1, mdim, uloc,dloc, gi + integer, dimension(mesh_dim(U)) :: U_start, U_end + type(element_type) :: u_shape + real, dimension(ele_ngi(D,ele)) :: detwei, detJ + logical :: have_d_rhs,have_u_rhs + type(scalar_field), pointer :: l_d_rhs + type(vector_field), pointer :: l_u_rhs + real, dimension(mesh_dim(U), mesh_dim(U)) :: Metric + + !Get some sizes + mdim = mesh_dim(U) + uloc = ele_loc(U,ele) + dloc = ele_loc(d,ele) + U_shape = ele_shape(U,ele) + + !Calculate indices in a vector containing all the U and D dofs in + !element ele, First the u1 components, then the u2 components, then the + !D components are stored. + d_start = uloc*mdim + 1 + d_end = uloc*mdim+dloc + do dim1 = 1, mdim + u_start(dim1) = uloc*(dim1-1)+1 + u_end(dim1) = uloc*dim1 + end do + + if(.not.(present(D_rhs).or.present(u_rhs))) then + !We are in timestepping mode. + rhs_loc(d_start:d_end) = ele_val(D,ele) + u_rhs_loc = ele_val(U,ele) + do dim1 = 1, mdim + rhs_loc(u_start(dim1):u_end(dim1)) = & + & U_rhs_loc(dim1,:) + end do + else + have_d_rhs = present(d_rhs) + have_u_rhs = present(u_rhs) + if(have_d_rhs) l_d_rhs => d_rhs + if(have_u_rhs) l_u_rhs => u_rhs + + call compute_jacobian(X, ele, J=J, detJ=detJ,detwei=detwei) + + Rhs_loc = 0. + if(have_d_rhs) then + Rhs_loc(d_start:d_end) = shape_rhs(ele_shape(D,ele),& + &ele_val_at_quad(l_D_rhs,ele)*detwei) + end if + if(have_u_rhs) then + if(present_and_true(u_rhs_local)) then + u_local_quad = ele_val_at_quad(l_u_rhs,ele) + do gi=1,ele_ngi(U,ele) + Metric=matmul(J(:,:,gi), transpose(J(:,:,gi)))& + &/detJ(gi) + u_local_quad(:,gi) = matmul(Metric,u_local_quad(:,gi)) + end do + else + allocate(u_cart_quad(l_U_rhs%dim,ele_ngi(X,ele))) + u_cart_quad = ele_val_at_quad(l_u_rhs,ele) + do gi = 1, ele_ngi(D,ele) + !Don't divide by detJ as we can use weight instead of detwei + u_local_quad(:,gi) = matmul(J(:,:,gi)& + &,u_cart_quad(:,gi)) + end do + end if + U_rhs_loc = shape_vector_rhs(u_shape,& u_local_quad,u_shape%quadrature%weight) - do dim1 = 1, mdim - Rhs_loc(u_start(dim1):u_end(dim1)) = & - & U_rhs_loc(dim1,:) - end do - end if - end if - end subroutine assemble_rhs_ele - - subroutine check_divergence_ele(U,D,D_rhs,X,ele) - implicit none - type(vector_field), intent(in) :: U, X - type(scalar_field), intent(in) :: D, D_rhs - integer, intent(in) :: ele - ! - real, dimension(ele_ngi(D,ele)) :: detwei, detJ - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - integer :: dim1 - real, dimension(ele_ngi(X,ele)) :: div - real, dimension(U%dim, ele_loc(U,ele)) :: U_loc - type(element_type) :: u_shape, d_shape - real, dimension(ele_loc(D,ele)) :: Div_loc - real, dimension(mesh_dim(U),ele_loc(U,ele),ele_loc(D,ele)) :: l_div_mat - real, dimension(ele_loc(D,ele),ele_loc(D,ele)) :: d_mass_mat - ! - call compute_jacobian(X, ele, J=J, detJ=detJ,detwei=detwei) - - u_shape = ele_shape(U,ele) - d_shape = ele_shape(D,ele) - U_loc = ele_val(U,ele) - - div = 0. - do dim1 = 1, U%dim - div = div + & - & matmul(U_loc(dim1,:),u_shape%dn(:,:,dim1))/detJ - end do - - l_div_mat = dshape_shape(u_shape%dn,d_shape,& - &D_shape%quadrature%weight) - - div_loc = 0. - do dim1 = 1, U%dim - div_loc = div_loc + matmul(transpose(l_div_mat(dim1,:,:))& - &,U_loc(dim1,:)) - end do - d_mass_mat = shape_shape(d_shape,d_shape,detwei) - call solve(d_mass_mat,div_loc) - !ewrite(1,*) 'div_loc', div_loc - !ewrite(1,*) 'div', div - end subroutine check_divergence_ele - - subroutine compute_energy_hybridized(state,energy) - implicit none - type(state_type), intent(inout) :: state - real, intent(inout) :: energy - ! - type(scalar_field), pointer :: D - type(vector_field), pointer :: u,X - integer :: ele - real :: old_energy,g,d0 - - !get parameters - call get_option("/physical_parameters/gravity/magnitude", g) - call get_option("/material_phase::Fluid/scalar_field::LayerThickness/p& - &rognostic/mean_layer_thickness",D0) - - U=>extract_vector_field(state, "Velocity") - D => extract_scalar_field(state, "LayerThickness") - X=>extract_vector_field(state, "Coordinate") - - old_energy = energy - energy = 0. - - do ele = 1, element_count(X) - call compute_energy_ele(energy,U,D,X,D0,g,ele) - end do - - ewrite(1,*) 'Energy:= ', energy - ewrite(1,*) 'Change in energy:= ', energy-old_energy - - end subroutine compute_energy_hybridized - - subroutine compute_energy_ele(energy,U,D,X,D0,g,ele) - implicit none - real, intent(inout) :: energy - type(vector_field), intent(in) :: U,X - type(scalar_field), intent(in) :: D - integer, intent(in) :: ele - real, intent(in) :: D0,g - ! - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - real, dimension(ele_ngi(D,ele)) :: detwei - type(element_type) :: d_shape, u_shape, x_shape - real, dimension(ele_loc(U,ele),ele_loc(U,ele)) :: u_mass - real, dimension(ele_loc(D,ele),ele_loc(D,ele)) :: d_mass - real, dimension(u%dim,ele_loc(U,ele)) :: U_val - real, dimension(ele_loc(D,ele)) :: D_val - real, dimension(X%dim,ele_loc(X,ele)) :: X_val - integer :: dim1 - - U_val = ele_val(U,ele) - D_val = ele_val(D,ele) - X_val = ele_val(X,ele) - - u_shape = ele_shape(u,ele) - d_shape = ele_shape(d,ele) - x_shape = ele_shape(X,ele) - call compute_jacobian(X, ele, J=J, detwei=detwei) - - u_mass = shape_shape(u_shape,u_shape,detwei) - d_mass = shape_shape(d_shape,d_shape,detwei) - - !kinetic energy - do dim1 = 1, u%dim - energy = energy + D0*dot_product(U_val(dim1,:),& - &matmul(u_mass,U_val(dim1,:))) - end do - - energy = energy + g*dot_product(D_val,& - &matmul(D_mass,D_val)) - - end subroutine compute_energy_ele - - subroutine set_velocity_from_geostrophic_balance_hybridized(& - &state) - implicit none - type(state_type), intent(inout) :: state - ! - type(scalar_field), pointer :: D,psi,f - type(scalar_field) :: D_rhs - type(vector_field), pointer :: U_local,down,X, U_cart - type(vector_field) :: Coriolis_term, Balance_eqn, tmp_field - integer :: ele,dim1 - real :: g - logical :: elliptic_method - - D=>extract_scalar_field(state, "LayerThickness") - psi=>extract_scalar_field(state, "Streamfunction") - f=>extract_scalar_field(state, "Coriolis") - U_local=>extract_vector_field(state, "LocalVelocity") - U_cart=>extract_vector_field(state, "Velocity") - X=>extract_vector_field(state, "Coordinate") - down=>extract_vector_field(state, "GravityDirection") - call get_option("/physical_parameters/gravity/magnitude", g) - call allocate(tmp_field,mesh_dim(U_local), U_local%mesh, "tmp_field") - call allocate(D_rhs,D%mesh,'BalancedSolverRHS') - call allocate(Coriolis_term,mesh_dim(U_local),& + do dim1 = 1, mdim + Rhs_loc(u_start(dim1):u_end(dim1)) = & + & U_rhs_loc(dim1,:) + end do + end if + end if + end subroutine assemble_rhs_ele + + subroutine check_divergence_ele(U,D,D_rhs,X,ele) + implicit none + type(vector_field), intent(in) :: U, X + type(scalar_field), intent(in) :: D, D_rhs + integer, intent(in) :: ele + ! + real, dimension(ele_ngi(D,ele)) :: detwei, detJ + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + integer :: dim1 + real, dimension(ele_ngi(X,ele)) :: div + real, dimension(U%dim, ele_loc(U,ele)) :: U_loc + type(element_type) :: u_shape, d_shape + real, dimension(ele_loc(D,ele)) :: Div_loc + real, dimension(mesh_dim(U),ele_loc(U,ele),ele_loc(D,ele)) :: l_div_mat + real, dimension(ele_loc(D,ele),ele_loc(D,ele)) :: d_mass_mat + ! + call compute_jacobian(X, ele, J=J, detJ=detJ,detwei=detwei) + + u_shape = ele_shape(U,ele) + d_shape = ele_shape(D,ele) + U_loc = ele_val(U,ele) + + div = 0. + do dim1 = 1, U%dim + div = div + & + & matmul(U_loc(dim1,:),u_shape%dn(:,:,dim1))/detJ + end do + + l_div_mat = dshape_shape(u_shape%dn,d_shape,& + &D_shape%quadrature%weight) + + div_loc = 0. + do dim1 = 1, U%dim + div_loc = div_loc + matmul(transpose(l_div_mat(dim1,:,:))& + &,U_loc(dim1,:)) + end do + d_mass_mat = shape_shape(d_shape,d_shape,detwei) + call solve(d_mass_mat,div_loc) + !ewrite(1,*) 'div_loc', div_loc + !ewrite(1,*) 'div', div + end subroutine check_divergence_ele + + subroutine compute_energy_hybridized(state,energy) + implicit none + type(state_type), intent(inout) :: state + real, intent(inout) :: energy + ! + type(scalar_field), pointer :: D + type(vector_field), pointer :: u,X + integer :: ele + real :: old_energy,g,d0 + + !get parameters + call get_option("/physical_parameters/gravity/magnitude", g) + call get_option("/material_phase::Fluid/scalar_field::LayerThickness/p& + &rognostic/mean_layer_thickness",D0) + + U=>extract_vector_field(state, "Velocity") + D => extract_scalar_field(state, "LayerThickness") + X=>extract_vector_field(state, "Coordinate") + + old_energy = energy + energy = 0. + + do ele = 1, element_count(X) + call compute_energy_ele(energy,U,D,X,D0,g,ele) + end do + + ewrite(1,*) 'Energy:= ', energy + ewrite(1,*) 'Change in energy:= ', energy-old_energy + + end subroutine compute_energy_hybridized + + subroutine compute_energy_ele(energy,U,D,X,D0,g,ele) + implicit none + real, intent(inout) :: energy + type(vector_field), intent(in) :: U,X + type(scalar_field), intent(in) :: D + integer, intent(in) :: ele + real, intent(in) :: D0,g + ! + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + real, dimension(ele_ngi(D,ele)) :: detwei + type(element_type) :: d_shape, u_shape, x_shape + real, dimension(ele_loc(U,ele),ele_loc(U,ele)) :: u_mass + real, dimension(ele_loc(D,ele),ele_loc(D,ele)) :: d_mass + real, dimension(u%dim,ele_loc(U,ele)) :: U_val + real, dimension(ele_loc(D,ele)) :: D_val + real, dimension(X%dim,ele_loc(X,ele)) :: X_val + integer :: dim1 + + U_val = ele_val(U,ele) + D_val = ele_val(D,ele) + X_val = ele_val(X,ele) + + u_shape = ele_shape(u,ele) + d_shape = ele_shape(d,ele) + x_shape = ele_shape(X,ele) + call compute_jacobian(X, ele, J=J, detwei=detwei) + + u_mass = shape_shape(u_shape,u_shape,detwei) + d_mass = shape_shape(d_shape,d_shape,detwei) + + !kinetic energy + do dim1 = 1, u%dim + energy = energy + D0*dot_product(U_val(dim1,:),& + &matmul(u_mass,U_val(dim1,:))) + end do + + energy = energy + g*dot_product(D_val,& + &matmul(D_mass,D_val)) + + end subroutine compute_energy_ele + + subroutine set_velocity_from_geostrophic_balance_hybridized(& + &state) + implicit none + type(state_type), intent(inout) :: state + ! + type(scalar_field), pointer :: D,psi,f + type(scalar_field) :: D_rhs + type(vector_field), pointer :: U_local,down,X, U_cart + type(vector_field) :: Coriolis_term, Balance_eqn, tmp_field + integer :: ele,dim1 + real :: g + logical :: elliptic_method + + D=>extract_scalar_field(state, "LayerThickness") + psi=>extract_scalar_field(state, "Streamfunction") + f=>extract_scalar_field(state, "Coriolis") + U_local=>extract_vector_field(state, "LocalVelocity") + U_cart=>extract_vector_field(state, "Velocity") + X=>extract_vector_field(state, "Coordinate") + down=>extract_vector_field(state, "GravityDirection") + call get_option("/physical_parameters/gravity/magnitude", g) + call allocate(tmp_field,mesh_dim(U_local), U_local%mesh, "tmp_field") + call allocate(D_rhs,D%mesh,'BalancedSolverRHS') + call allocate(Coriolis_term,mesh_dim(U_local),& U_local%mesh,"CoriolisTerm") - call allocate(balance_eqn,mesh_dim(D),u_local%mesh,'BalancedEquation') - - !STAGE 1: Set velocity from streamfunction - do ele = 1, element_count(D) - call set_local_velocity_from_streamfunction_ele(& - &U_local,psi,down,X,ele) - end do - - !STAGE 1a: verify that velocity projects is div-conforming - call project_local_to_cartesian(X,U_local,U_cart) - do ele = 1, ele_count(U_local) - call check_continuity_ele(U_cart,X,ele) - end do - - !Stage 1b: verify that projection is idempotent - ewrite(1,*) 'CHECKING CONTINUOUS', maxval(abs(u_local%val)) - call solve_hybridized_helmholtz(state,U_Rhs=U_local,& + call allocate(balance_eqn,mesh_dim(D),u_local%mesh,'BalancedEquation') + + !STAGE 1: Set velocity from streamfunction + do ele = 1, element_count(D) + call set_local_velocity_from_streamfunction_ele(& + &U_local,psi,down,X,ele) + end do + + !STAGE 1a: verify that velocity projects is div-conforming + call project_local_to_cartesian(X,U_local,U_cart) + do ele = 1, ele_count(U_local) + call check_continuity_ele(U_cart,X,ele) + end do + + !Stage 1b: verify that projection is idempotent + ewrite(1,*) 'CHECKING CONTINUOUS', maxval(abs(u_local%val)) + call solve_hybridized_helmholtz(state,U_Rhs=U_local,& + &U_out=tmp_field,& + &compute_cartesian=.true.,& + &check_continuity=.true.,projection=.true.,& + &u_rhs_local=.true.)!verified that projection is idempotent + assert(maxval(abs(U_local%val-tmp_field%val))<1.0e-8) + + elliptic_method = .false. + + if(elliptic_method) then + + !STAGE 2: Construct Coriolis term + call zero(Coriolis_term) + do ele = 1, element_count(D) + call set_coriolis_term_ele(Coriolis_term,f,down,U_local,X,ele) + end do!checked!signs checked + + !STAGE 3: Project Coriolis term into div-conforming space + + !debugging bits - checking if it works with cartesian instead + call project_local_to_cartesian(X,Coriolis_Term,U_cart) + call solve_hybridized_helmholtz(state,U_Rhs=U_cart,& + &U_out=tmp_field,& + &compute_cartesian=.true.,output_dense=.false.,& + &check_continuity=.true.,projection=.true.,& + &u_rhs_local=.false.) + + ewrite(0,*) 'REMEMBER TO REMOVE DEBUGGING TESTS' + call solve_hybridized_helmholtz(state,U_Rhs=Coriolis_term,& &U_out=tmp_field,& &compute_cartesian=.true.,& &check_continuity=.true.,projection=.true.,& &u_rhs_local=.true.)!verified that projection is idempotent - assert(maxval(abs(U_local%val-tmp_field%val))<1.0e-8) - - elliptic_method = .false. - - if(elliptic_method) then - - !STAGE 2: Construct Coriolis term - call zero(Coriolis_term) - do ele = 1, element_count(D) - call set_coriolis_term_ele(Coriolis_term,f,down,U_local,X,ele) - end do!checked!signs checked - - !STAGE 3: Project Coriolis term into div-conforming space - - !debugging bits - checking if it works with cartesian instead - call project_local_to_cartesian(X,Coriolis_Term,U_cart) - call solve_hybridized_helmholtz(state,U_Rhs=U_cart,& - &U_out=tmp_field,& - &compute_cartesian=.true.,output_dense=.false.,& - &check_continuity=.true.,projection=.true.,& - &u_rhs_local=.false.) - - ewrite(0,*) 'REMEMBER TO REMOVE DEBUGGING TESTS' - call solve_hybridized_helmholtz(state,U_Rhs=Coriolis_term,& - &U_out=tmp_field,& - &compute_cartesian=.true.,& - &check_continuity=.true.,projection=.true.,& - &u_rhs_local=.true.)!verified that projection is idempotent - - !STAGE 4: Construct the RHS for the balanced layer depth equation - call zero(D_rhs) - do ele = 1, element_count(D) - call set_geostrophic_balance_rhs_ele(D_rhs,Coriolis_term,ele) - end do - - !STAGE 5: Solve Poisson equation for the balanced layer depth - ewrite(0,*) 'REMEMBER ABOUT SETTING MEAN VALUE' - ewrite(0,*) trim(u_cart%option_path) - - call solve_hybridized_helmholtz(state,D_rhs=D_rhs,& - &compute_cartesian=.false.,& - &check_continuity=.false.,Poisson=.true.,& - &solver_option_path=trim(u_cart%option_path)//'/prognostic/initial_condition::WholeMesh/balanced') - - !STAGE 6: Check if we have a balanced solution - !Can be done by projecting balance equation into div-conforming space - !and checking that it is equal to zero - !STAGE 6a: Project balance equation into DG space - do ele = 1, element_count(D) - call set_pressure_force_ele(balance_eqn,D,X,g,ele) - end do - call addto(balance_eqn,coriolis_term) - - !STAGE 6b: Project balance equation into div-conforming space - call solve_hybridized_helmholtz(state,U_Rhs=balance_eqn,& - &U_out=balance_eqn,& - &compute_cartesian=.true.,& - &check_continuity=.true.,projection=.true.,& - &u_rhs_local=.true.) - - do dim1 = 1, mesh_dim(D) - ewrite(1,*) 'Balance equation', maxval(abs(balance_eqn%val(dim1,:))) - assert(maxval(abs(balance_eqn%val(dim1,:)))<1.0e-8) - end do - - else - !Project the streamfunction into pressure space - do ele = 1, element_count(D) - call project_streamfunction_for_balance_ele(D,psi,X,f,g,ele) - end do - ewrite(1,*) maxval(abs(D%val)) - - !debugging tests - call zero(Coriolis_term) - do ele = 1, element_count(D) - call set_coriolis_term_ele(Coriolis_term,f,down,U_local,X,ele) - end do - call zero(balance_eqn) - do ele = 1, element_count(D) - call set_pressure_force_ele(balance_eqn,D,X,g,ele) - end do - call addto(balance_eqn,coriolis_term,scale=1.0) - ewrite(1,*) 'CJC b4',maxval(abs(balance_eqn%val)),& - & maxval(abs(coriolis_term%val)) - !Project balance equation into div-conforming space - call solve_hybridized_helmholtz(state,U_Rhs=balance_eqn,& - &U_out=balance_eqn,& - &compute_cartesian=.true.,& - &check_continuity=.true.,projection=.true.,& - &u_rhs_local=.true.) - - do dim1 = 1, mesh_dim(D) - ewrite(1,*) 'Balance equation', maxval(abs(balance_eqn%val(dim1,:))) - assert(maxval(abs(balance_eqn%val(dim1,:)))<1.0e-8) - end do - end if - !Clean up after yourself - call deallocate(Coriolis_term) - call deallocate(D_rhs) - call deallocate(balance_eqn) - call deallocate(tmp_field) - - end subroutine set_velocity_from_geostrophic_balance_hybridized - - subroutine project_streamfunction_for_balance_ele(D,psi,X,f,g,ele) - implicit none - type(scalar_field), intent(in) :: psi,f - type(scalar_field), intent(inout) :: D - type(vector_field), intent(in) :: X - integer, intent(in) :: ele - real, intent(in) :: g - ! - real, dimension(ele_loc(d,ele),ele_loc(d,ele)) :: d_mass - real, dimension(ele_loc(d,ele)) :: d_rhs - type(element_type) :: psi_shape, d_shape - real, dimension(ele_ngi(d,ele)) :: detwei, psi_quad,f_gi - real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J - - f_gi = ele_val_at_quad(f,ele) - psi_shape = ele_shape(psi,ele) - d_shape = ele_shape(d,ele) - psi_quad = ele_val_at_quad(psi,ele) - - call compute_jacobian(X, ele, J=J, detwei=detwei) - - d_rhs = shape_rhs(d_shape,detwei*psi_quad*f_gi/g) - d_mass = shape_shape(d_shape,d_shape,detwei) - call solve(d_mass,d_rhs) - call set(D,ele_nodes(D,ele),d_rhs) - - end subroutine project_streamfunction_for_balance_ele - - subroutine set_pressure_force_ele(force,D,X,g,ele) - implicit none - type(vector_field), intent(inout) :: force - type(scalar_field), intent(in) :: D - type(vector_field), intent(in) :: X - real, intent(in) :: g - integer, intent(in) :: ele - ! - real, dimension(ele_ngi(D,ele)) :: D_gi - real, dimension(mesh_dim(D),ele_loc(force,ele)) :: & - & rhs_loc - real, dimension(ele_loc(force,ele),ele_loc(force,ele)) :: & - & l_mass_mat - integer :: dim1,dim2,gi,uloc - real, dimension(mesh_dim(force), X%dim, ele_ngi(force,ele)) :: J - real, dimension(ele_ngi(force,ele)) :: detJ - real, dimension(mesh_dim(force),mesh_dim(force),ele_ngi(force,ele))::& - &Metric - real, dimension(mesh_dim(force)*ele_loc(force,ele),& + + !STAGE 4: Construct the RHS for the balanced layer depth equation + call zero(D_rhs) + do ele = 1, element_count(D) + call set_geostrophic_balance_rhs_ele(D_rhs,Coriolis_term,ele) + end do + + !STAGE 5: Solve Poisson equation for the balanced layer depth + ewrite(0,*) 'REMEMBER ABOUT SETTING MEAN VALUE' + ewrite(0,*) trim(u_cart%option_path) + + call solve_hybridized_helmholtz(state,D_rhs=D_rhs,& + &compute_cartesian=.false.,& + &check_continuity=.false.,Poisson=.true.,& + &solver_option_path=trim(u_cart%option_path)//'/prognostic/initial_condition::WholeMesh/balanced') + + !STAGE 6: Check if we have a balanced solution + !Can be done by projecting balance equation into div-conforming space + !and checking that it is equal to zero + !STAGE 6a: Project balance equation into DG space + do ele = 1, element_count(D) + call set_pressure_force_ele(balance_eqn,D,X,g,ele) + end do + call addto(balance_eqn,coriolis_term) + + !STAGE 6b: Project balance equation into div-conforming space + call solve_hybridized_helmholtz(state,U_Rhs=balance_eqn,& + &U_out=balance_eqn,& + &compute_cartesian=.true.,& + &check_continuity=.true.,projection=.true.,& + &u_rhs_local=.true.) + + do dim1 = 1, mesh_dim(D) + ewrite(1,*) 'Balance equation', maxval(abs(balance_eqn%val(dim1,:))) + assert(maxval(abs(balance_eqn%val(dim1,:)))<1.0e-8) + end do + + else + !Project the streamfunction into pressure space + do ele = 1, element_count(D) + call project_streamfunction_for_balance_ele(D,psi,X,f,g,ele) + end do + ewrite(1,*) maxval(abs(D%val)) + + !debugging tests + call zero(Coriolis_term) + do ele = 1, element_count(D) + call set_coriolis_term_ele(Coriolis_term,f,down,U_local,X,ele) + end do + call zero(balance_eqn) + do ele = 1, element_count(D) + call set_pressure_force_ele(balance_eqn,D,X,g,ele) + end do + call addto(balance_eqn,coriolis_term,scale=1.0) + ewrite(1,*) 'CJC b4',maxval(abs(balance_eqn%val)),& + & maxval(abs(coriolis_term%val)) + !Project balance equation into div-conforming space + call solve_hybridized_helmholtz(state,U_Rhs=balance_eqn,& + &U_out=balance_eqn,& + &compute_cartesian=.true.,& + &check_continuity=.true.,projection=.true.,& + &u_rhs_local=.true.) + + do dim1 = 1, mesh_dim(D) + ewrite(1,*) 'Balance equation', maxval(abs(balance_eqn%val(dim1,:))) + assert(maxval(abs(balance_eqn%val(dim1,:)))<1.0e-8) + end do + end if + !Clean up after yourself + call deallocate(Coriolis_term) + call deallocate(D_rhs) + call deallocate(balance_eqn) + call deallocate(tmp_field) + + end subroutine set_velocity_from_geostrophic_balance_hybridized + + subroutine project_streamfunction_for_balance_ele(D,psi,X,f,g,ele) + implicit none + type(scalar_field), intent(in) :: psi,f + type(scalar_field), intent(inout) :: D + type(vector_field), intent(in) :: X + integer, intent(in) :: ele + real, intent(in) :: g + ! + real, dimension(ele_loc(d,ele),ele_loc(d,ele)) :: d_mass + real, dimension(ele_loc(d,ele)) :: d_rhs + type(element_type) :: psi_shape, d_shape + real, dimension(ele_ngi(d,ele)) :: detwei, psi_quad,f_gi + real, dimension(mesh_dim(X), X%dim, ele_ngi(X,ele)) :: J + + f_gi = ele_val_at_quad(f,ele) + psi_shape = ele_shape(psi,ele) + d_shape = ele_shape(d,ele) + psi_quad = ele_val_at_quad(psi,ele) + + call compute_jacobian(X, ele, J=J, detwei=detwei) + + d_rhs = shape_rhs(d_shape,detwei*psi_quad*f_gi/g) + d_mass = shape_shape(d_shape,d_shape,detwei) + call solve(d_mass,d_rhs) + call set(D,ele_nodes(D,ele),d_rhs) + + end subroutine project_streamfunction_for_balance_ele + + subroutine set_pressure_force_ele(force,D,X,g,ele) + implicit none + type(vector_field), intent(inout) :: force + type(scalar_field), intent(in) :: D + type(vector_field), intent(in) :: X + real, intent(in) :: g + integer, intent(in) :: ele + ! + real, dimension(ele_ngi(D,ele)) :: D_gi + real, dimension(mesh_dim(D),ele_loc(force,ele)) :: & + & rhs_loc + real, dimension(ele_loc(force,ele),ele_loc(force,ele)) :: & + & l_mass_mat + integer :: dim1,dim2,gi,uloc + real, dimension(mesh_dim(force), X%dim, ele_ngi(force,ele)) :: J + real, dimension(ele_ngi(force,ele)) :: detJ + real, dimension(mesh_dim(force),mesh_dim(force),ele_ngi(force,ele))::& + &Metric + real, dimension(mesh_dim(force)*ele_loc(force,ele),& mesh_dim(force)*ele_loc(force,ele)) :: l_u_mat - real, dimension(mesh_dim(force)*ele_loc(force,ele)) :: force_rhs - type(element_type) :: force_shape - - uloc = ele_loc(force,ele) - force_shape = ele_shape(force,ele) - call compute_jacobian(X, ele, J=J, detJ=detJ) - do gi=1,ele_ngi(force,ele) - Metric(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) - end do - - D_gi = ele_val_at_quad(D,ele) - rhs_loc = -g*dshape_rhs(force%mesh%shape%dn,& + real, dimension(mesh_dim(force)*ele_loc(force,ele)) :: force_rhs + type(element_type) :: force_shape + + uloc = ele_loc(force,ele) + force_shape = ele_shape(force,ele) + call compute_jacobian(X, ele, J=J, detJ=detJ) + do gi=1,ele_ngi(force,ele) + Metric(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) + end do + + D_gi = ele_val_at_quad(D,ele) + rhs_loc = -g*dshape_rhs(force%mesh%shape%dn,& D_gi*D%mesh%shape%quadrature%weight) - l_mass_mat = shape_shape(ele_shape(force,ele),ele_shape(force,ele),& - &force%mesh%shape%quadrature%weight) - do dim1 = 1, mesh_dim(force) - force_rhs((dim1-1)*uloc+1:dim1*uloc) = rhs_loc(dim1,:) - end do - do dim1 = 1, mesh_dim(force) - do dim2 = 1, mesh_dim(force) - l_u_mat((dim1-1)*uloc+1:dim1*uloc,& - & (dim2-1)*uloc+1:dim2*uloc ) = & - & shape_shape(force_shape,force_shape,& - & force_shape%quadrature%weight*Metric(dim1,dim2,:)) - end do - end do - - call solve(l_u_mat,force_rhs) - do dim1= 1, mesh_dim(force) - call set(force,dim1,ele_nodes(force,ele),& - &force_rhs((dim1-1)*uloc+1:dim1*uloc)) - end do - - end subroutine set_pressure_force_ele - - subroutine set_geostrophic_balance_rhs_ele(D_rhs,Coriolis_term,ele) - implicit none - type(scalar_field), intent(inout) :: D_rhs - type(vector_field), intent(in) :: Coriolis_term - integer, intent(in) :: ele - ! - real, dimension(mesh_dim(Coriolis_term),ele_loc(Coriolis_term,ele)) :: & - & Coriolis_loc - real, dimension(ele_ngi(D_rhs,ele)) :: div_gi - real, dimension(ele_loc(D_rhs,ele)) :: D_rhs_loc - real, dimension(ele_loc(D_rhs,ele),ele_loc(D_rhs,ele)) :: d_mass - integer :: dim1 - type(element_type) :: U_shape, D_shape - real :: g - - !Computes the divergence of projected Coriolis term - !Can be done locally since d commutes with pullback - - call get_option("/physical_parameters/gravity/magnitude", g) - - U_shape = ele_shape(Coriolis_term,ele) - D_shape = ele_shape(D_rhs,ele) - Coriolis_loc = ele_val(Coriolis_term,ele) - - div_gi = 0. - do dim1 = 1, mesh_dim(Coriolis_term) - div_gi = div_gi + matmul(transpose(U_shape%dn(:,:,dim1)),& - &Coriolis_loc(dim1,:)) - end do - D_rhs_loc = shape_rhs(D_shape,div_gi*U_shape%quadrature%weight) - d_mass = shape_shape(d_shape,d_shape,d_shape%quadrature%weight) - call solve(d_mass,D_rhs_loc) - call set(D_rhs,ele_nodes(D_rhs,ele),-D_rhs_loc/g) - end subroutine set_geostrophic_balance_rhs_ele - - subroutine set_coriolis_term_ele(Coriolis_term,f,down,U_local,X,ele) - implicit none - type(vector_field), intent(inout) :: Coriolis_term - type(vector_field), intent(in) :: U_local,X,down - type(scalar_field), intent(in) :: f - integer, intent(in) :: ele - ! - real, dimension(ele_ngi(x,ele)) :: f_gi - real, dimension(X%dim, ele_ngi(X,ele)) :: up_gi - real, dimension(mesh_dim(U_local),mesh_dim(U_local),ele_ngi(U_local,ele))::& - &Metric, Metricf - real, dimension(mesh_dim(U_local), X%dim, ele_ngi(U_local,ele)) :: J - real, dimension(ele_ngi(U_local,ele)) :: detJ - real, dimension(X%dim, X%dim, ele_ngi(U_local,ele)) :: rot - real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele),& + l_mass_mat = shape_shape(ele_shape(force,ele),ele_shape(force,ele),& + &force%mesh%shape%quadrature%weight) + do dim1 = 1, mesh_dim(force) + force_rhs((dim1-1)*uloc+1:dim1*uloc) = rhs_loc(dim1,:) + end do + do dim1 = 1, mesh_dim(force) + do dim2 = 1, mesh_dim(force) + l_u_mat((dim1-1)*uloc+1:dim1*uloc,& + & (dim2-1)*uloc+1:dim2*uloc ) = & + & shape_shape(force_shape,force_shape,& + & force_shape%quadrature%weight*Metric(dim1,dim2,:)) + end do + end do + + call solve(l_u_mat,force_rhs) + do dim1= 1, mesh_dim(force) + call set(force,dim1,ele_nodes(force,ele),& + &force_rhs((dim1-1)*uloc+1:dim1*uloc)) + end do + + end subroutine set_pressure_force_ele + + subroutine set_geostrophic_balance_rhs_ele(D_rhs,Coriolis_term,ele) + implicit none + type(scalar_field), intent(inout) :: D_rhs + type(vector_field), intent(in) :: Coriolis_term + integer, intent(in) :: ele + ! + real, dimension(mesh_dim(Coriolis_term),ele_loc(Coriolis_term,ele)) :: & + & Coriolis_loc + real, dimension(ele_ngi(D_rhs,ele)) :: div_gi + real, dimension(ele_loc(D_rhs,ele)) :: D_rhs_loc + real, dimension(ele_loc(D_rhs,ele),ele_loc(D_rhs,ele)) :: d_mass + integer :: dim1 + type(element_type) :: U_shape, D_shape + real :: g + + !Computes the divergence of projected Coriolis term + !Can be done locally since d commutes with pullback + + call get_option("/physical_parameters/gravity/magnitude", g) + + U_shape = ele_shape(Coriolis_term,ele) + D_shape = ele_shape(D_rhs,ele) + Coriolis_loc = ele_val(Coriolis_term,ele) + + div_gi = 0. + do dim1 = 1, mesh_dim(Coriolis_term) + div_gi = div_gi + matmul(transpose(U_shape%dn(:,:,dim1)),& + &Coriolis_loc(dim1,:)) + end do + D_rhs_loc = shape_rhs(D_shape,div_gi*U_shape%quadrature%weight) + d_mass = shape_shape(d_shape,d_shape,d_shape%quadrature%weight) + call solve(d_mass,D_rhs_loc) + call set(D_rhs,ele_nodes(D_rhs,ele),-D_rhs_loc/g) + end subroutine set_geostrophic_balance_rhs_ele + + subroutine set_coriolis_term_ele(Coriolis_term,f,down,U_local,X,ele) + implicit none + type(vector_field), intent(inout) :: Coriolis_term + type(vector_field), intent(in) :: U_local,X,down + type(scalar_field), intent(in) :: f + integer, intent(in) :: ele + ! + real, dimension(ele_ngi(x,ele)) :: f_gi + real, dimension(X%dim, ele_ngi(X,ele)) :: up_gi + real, dimension(mesh_dim(U_local),mesh_dim(U_local),ele_ngi(U_local,ele))::& + &Metric, Metricf + real, dimension(mesh_dim(U_local), X%dim, ele_ngi(U_local,ele)) :: J + real, dimension(ele_ngi(U_local,ele)) :: detJ + real, dimension(X%dim, X%dim, ele_ngi(U_local,ele)) :: rot + real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele),& mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_u_mat - real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele)) :: coriolis_rhs - real, dimension(mesh_dim(U_local), ele_ngi(U_local,ele)) :: U_gi - real, dimension(mesh_dim(U_local), ele_ngi(U_local,ele)) :: coriolis_gi - integer :: dim1, dim2,uloc,gi - type(element_type) :: u_shape - - uloc = ele_loc(u_local,ele) - u_shape = ele_shape(u_local,ele) - - u_gi = ele_val_at_quad(u_local,ele) - f_gi = ele_val_at_quad(f,ele) - up_gi = -ele_val_at_quad(down,ele) - - call get_up_gi(X,ele,up_gi) - - coriolis_rhs = 0. - l_u_mat = 0. - !metrics for velocity mass and coriolis matrices - call compute_jacobian(X, ele, J=J, detJ=detJ) - do gi=1, ele_ngi(U_local,ele) - rot(1,:,gi)=(/0.,-up_gi(3,gi),up_gi(2,gi)/) - rot(2,:,gi)=(/up_gi(3,gi),0.,-up_gi(1,gi)/) - rot(3,:,gi)=(/-up_gi(2,gi),up_gi(1,gi),0./) - end do - do gi=1,ele_ngi(U_local,ele) - Metric(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) - Metricf(:,:,gi)=matmul(J(:,:,gi), & + real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele)) :: coriolis_rhs + real, dimension(mesh_dim(U_local), ele_ngi(U_local,ele)) :: U_gi + real, dimension(mesh_dim(U_local), ele_ngi(U_local,ele)) :: coriolis_gi + integer :: dim1, dim2,uloc,gi + type(element_type) :: u_shape + + uloc = ele_loc(u_local,ele) + u_shape = ele_shape(u_local,ele) + + u_gi = ele_val_at_quad(u_local,ele) + f_gi = ele_val_at_quad(f,ele) + up_gi = -ele_val_at_quad(down,ele) + + call get_up_gi(X,ele,up_gi) + + coriolis_rhs = 0. + l_u_mat = 0. + !metrics for velocity mass and coriolis matrices + call compute_jacobian(X, ele, J=J, detJ=detJ) + do gi=1, ele_ngi(U_local,ele) + rot(1,:,gi)=(/0.,-up_gi(3,gi),up_gi(2,gi)/) + rot(2,:,gi)=(/up_gi(3,gi),0.,-up_gi(1,gi)/) + rot(3,:,gi)=(/-up_gi(2,gi),up_gi(1,gi),0./) + end do + do gi=1,ele_ngi(U_local,ele) + Metric(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) + Metricf(:,:,gi)=matmul(J(:,:,gi), & matmul(f_gi(gi)*rot(:,:,gi), transpose(J(:,:,gi))))/detJ(gi) - Coriolis_gi(:,gi) = matmul(Metricf(:,:,gi),u_gi(:,gi)) - end do - - !Coriolis term is evaluated in global coordinates [hence presence of - ! metric terms] and projected into local velocity coordinates - do dim1 = 1, mesh_dim(U_local) - do dim2 = 1, mesh_dim(U_local) - l_u_mat((dim1-1)*uloc+1:dim1*uloc,& - & (dim2-1)*uloc+1:dim2*uloc ) = & - & shape_shape(u_shape,u_shape,& - & u_shape%quadrature%weight*Metric(dim1,dim2,:)) - end do - coriolis_rhs((dim1-1)*uloc+1:dim1*uloc) = & - & shape_rhs(u_shape,Coriolis_gi(dim1,:)*u_shape%quadrature%weight) - end do - call solve(l_u_mat,coriolis_rhs) - do dim1= 1, mesh_dim(coriolis_term) - call set(coriolis_term,dim1,ele_nodes(Coriolis_term,ele),& - &Coriolis_rhs((dim1-1)*uloc+1:dim1*uloc)) - end do - end subroutine set_coriolis_term_ele - - subroutine set_local_velocity_from_streamfunction_ele(& - &U_local,psi,down,X,ele) - implicit none - type(vector_field), intent(inout) :: U_local - type(vector_field), intent(in) :: down,X - type(scalar_field), intent(in) :: psi - integer, intent(in) :: ele - ! - real, dimension(ele_loc(psi,ele)) :: psi_loc - real, dimension(mesh_dim(psi),ele_ngi(psi,ele)) :: dpsi_gi - real, dimension(ele_ngi(psi,ele)) :: div_gi - real, dimension(mesh_dim(U_local),ele_loc(U_local,ele)) :: U_loc - real, dimension(ele_loc(U_local,ele),ele_loc(U_local,ele)) :: & - & l_mass_mat - type(element_type) :: u_shape, psi_shape - integer :: dim1,gi,uloc - real, dimension(X%dim, ele_ngi(X,ele)) :: up_gi - integer :: orientation - - uloc = ele_loc(U_local,ele) - u_shape = ele_shape(U_local,ele) - psi_shape = ele_shape(psi,ele) - up_gi = -ele_val_at_quad(down,ele) - call get_up_gi(X,ele,up_gi,orientation) - - !We can do everything in local coordinates since d commutes with pullback - !usual tricks: dpsi lives in the U space so we can do projection - - l_mass_mat = shape_shape(u_shape,u_shape,U_shape%quadrature%weight) - - !Streamfunction at node values - psi_loc = ele_val(psi,ele) - !Skew gradient of streamfunction at quadrature points - select case(mesh_dim(psi)) - case (2) - forall(gi=1:ele_ngi(psi,ele)) - dpsi_gi(1,gi) = -sum(psi_loc*psi_shape%dn(:,gi,2)) - dpsi_gi(2,gi) = sum(psi_loc*psi_shape%dn(:,gi,1)) - end forall - case default - FLAbort('Exterior derivative not implemented for given mesh dimension') - end select - dpsi_gi = orientation*dpsi_gi - U_loc = shape_vector_rhs(u_shape,dpsi_gi,U_shape%quadrature%weight) - - do dim1 = 1, U_local%dim - call solve(l_mass_mat,U_loc(dim1,:)) - call set(U_local,dim1,ele_nodes(U_local,ele),& + Coriolis_gi(:,gi) = matmul(Metricf(:,:,gi),u_gi(:,gi)) + end do + + !Coriolis term is evaluated in global coordinates [hence presence of + ! metric terms] and projected into local velocity coordinates + do dim1 = 1, mesh_dim(U_local) + do dim2 = 1, mesh_dim(U_local) + l_u_mat((dim1-1)*uloc+1:dim1*uloc,& + & (dim2-1)*uloc+1:dim2*uloc ) = & + & shape_shape(u_shape,u_shape,& + & u_shape%quadrature%weight*Metric(dim1,dim2,:)) + end do + coriolis_rhs((dim1-1)*uloc+1:dim1*uloc) = & + & shape_rhs(u_shape,Coriolis_gi(dim1,:)*u_shape%quadrature%weight) + end do + call solve(l_u_mat,coriolis_rhs) + do dim1= 1, mesh_dim(coriolis_term) + call set(coriolis_term,dim1,ele_nodes(Coriolis_term,ele),& + &Coriolis_rhs((dim1-1)*uloc+1:dim1*uloc)) + end do + end subroutine set_coriolis_term_ele + + subroutine set_local_velocity_from_streamfunction_ele(& + &U_local,psi,down,X,ele) + implicit none + type(vector_field), intent(inout) :: U_local + type(vector_field), intent(in) :: down,X + type(scalar_field), intent(in) :: psi + integer, intent(in) :: ele + ! + real, dimension(ele_loc(psi,ele)) :: psi_loc + real, dimension(mesh_dim(psi),ele_ngi(psi,ele)) :: dpsi_gi + real, dimension(ele_ngi(psi,ele)) :: div_gi + real, dimension(mesh_dim(U_local),ele_loc(U_local,ele)) :: U_loc + real, dimension(ele_loc(U_local,ele),ele_loc(U_local,ele)) :: & + & l_mass_mat + type(element_type) :: u_shape, psi_shape + integer :: dim1,gi,uloc + real, dimension(X%dim, ele_ngi(X,ele)) :: up_gi + integer :: orientation + + uloc = ele_loc(U_local,ele) + u_shape = ele_shape(U_local,ele) + psi_shape = ele_shape(psi,ele) + up_gi = -ele_val_at_quad(down,ele) + call get_up_gi(X,ele,up_gi,orientation) + + !We can do everything in local coordinates since d commutes with pullback + !usual tricks: dpsi lives in the U space so we can do projection + + l_mass_mat = shape_shape(u_shape,u_shape,U_shape%quadrature%weight) + + !Streamfunction at node values + psi_loc = ele_val(psi,ele) + !Skew gradient of streamfunction at quadrature points + select case(mesh_dim(psi)) + case (2) + forall(gi=1:ele_ngi(psi,ele)) + dpsi_gi(1,gi) = -sum(psi_loc*psi_shape%dn(:,gi,2)) + dpsi_gi(2,gi) = sum(psi_loc*psi_shape%dn(:,gi,1)) + end forall + case default + FLAbort('Exterior derivative not implemented for given mesh dimension') + end select + dpsi_gi = orientation*dpsi_gi + U_loc = shape_vector_rhs(u_shape,dpsi_gi,U_shape%quadrature%weight) + + do dim1 = 1, U_local%dim + call solve(l_mass_mat,U_loc(dim1,:)) + call set(U_local,dim1,ele_nodes(U_local,ele),& u_loc(dim1,:)) - end do - - !verify divergence-free-ness - div_gi = 0. - do gi = 1, ele_ngi(psi,ele) - do dim1 = 1, mesh_dim(psi) - div_gi(gi) = div_gi(gi) + sum(u_shape%dn(:,gi,dim1)*u_loc(dim1,:)) - end do - end do - assert(maxval(abs(div_gi))<1.0e-8) - end subroutine set_local_velocity_from_streamfunction_ele - - subroutine project_to_constrained_space(state,v_field) - !wrapper for projecting vector field to constrained space - implicit none - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field - - call solve_hybridized_helmholtz(state,& - &U_rhs=v_field,& - &compute_cartesian=.true.,& - &check_continuity=.true.,projection=.true.,& - &u_rhs_local=.true.) - - end subroutine project_to_constrained_space + end do + + !verify divergence-free-ness + div_gi = 0. + do gi = 1, ele_ngi(psi,ele) + do dim1 = 1, mesh_dim(psi) + div_gi(gi) = div_gi(gi) + sum(u_shape%dn(:,gi,dim1)*u_loc(dim1,:)) + end do + end do + assert(maxval(abs(div_gi))<1.0e-8) + end subroutine set_local_velocity_from_streamfunction_ele + + subroutine project_to_constrained_space(state,v_field) + !wrapper for projecting vector field to constrained space + implicit none + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field + + call solve_hybridized_helmholtz(state,& + &U_rhs=v_field,& + &compute_cartesian=.true.,& + &check_continuity=.true.,projection=.true.,& + &u_rhs_local=.true.) + + end subroutine project_to_constrained_space end module hybridized_helmholtz diff --git a/assemble/Hydrostatic_Pressure.F90 b/assemble/Hydrostatic_Pressure.F90 index b423e22eed..0912868a55 100644 --- a/assemble/Hydrostatic_Pressure.F90 +++ b/assemble/Hydrostatic_Pressure.F90 @@ -31,764 +31,764 @@ module hydrostatic_pressure - use fldebug - use vector_tools, only: solve - use quadrature - use elements - use parallel_tools - use spud - use sparse_tools - use shape_functions - use transform_elements - use fetools - use parallel_fields - use fields - use profiler - use state_module - use boundary_conditions - use vertical_extrapolation_module - use upwind_stabilisation - use solvers - use state_matrices_module - - implicit none - - private - - public calculate_hydrostatic_pressure, & - & calculate_hydrostatic_pressure_gradient, & - & subtract_hydrostatic_pressure_gradient - - character(len = *), parameter, public :: hp_name = "HydrostaticPressure" - character(len = *), parameter, public :: hpg_name = "HydrostaticPressureGradient" - - ! Stabilisation schemes - integer, parameter :: STABILISATION_NONE = 0, & - & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 - - ! Stabilisation scheme - integer :: stabilisation_scheme - integer :: nu_bar_scheme - real :: nu_bar_scale - - interface subtract_given_hydrostatic_pressure_gradient_element - module procedure & + use fldebug + use vector_tools, only: solve + use quadrature + use elements + use parallel_tools + use spud + use sparse_tools + use shape_functions + use transform_elements + use fetools + use parallel_fields + use fields + use profiler + use state_module + use boundary_conditions + use vertical_extrapolation_module + use upwind_stabilisation + use solvers + use state_matrices_module + + implicit none + + private + + public calculate_hydrostatic_pressure, & + & calculate_hydrostatic_pressure_gradient, & + & subtract_hydrostatic_pressure_gradient + + character(len = *), parameter, public :: hp_name = "HydrostaticPressure" + character(len = *), parameter, public :: hpg_name = "HydrostaticPressureGradient" + + ! Stabilisation schemes + integer, parameter :: STABILISATION_NONE = 0, & + & STABILISATION_STREAMLINE_UPWIND = 1, STABILISATION_SUPG = 2 + + ! Stabilisation scheme + integer :: stabilisation_scheme + integer :: nu_bar_scheme + real :: nu_bar_scale + + interface subtract_given_hydrostatic_pressure_gradient_element + module procedure & & subtract_given_hydrostatic_pressure_gradient_element_scalar, & & subtract_given_hydrostatic_pressure_gradient_element_vector - end interface subtract_given_hydrostatic_pressure_gradient_element + end interface subtract_given_hydrostatic_pressure_gradient_element - contains +contains - subroutine calculate_hydrostatic_pressure(state) - type(state_type), intent(inout) :: state + subroutine calculate_hydrostatic_pressure(state) + type(state_type), intent(inout) :: state - integer :: stat - type(scalar_field), pointer :: hp + integer :: stat + type(scalar_field), pointer :: hp - hp => extract_scalar_field(state, hp_name, stat = stat) - if(stat /= 0) return + hp => extract_scalar_field(state, hp_name, stat = stat) + if(stat /= 0) return - if(have_option(trim(hp%option_path)//& - & "/prognostic/spatial_discretisation/discontinuous_galerkin")) then - if(continuity(hp) > 0) then - FLExit("HydrostaticPressure with discontinuous_galerkin requires a discontinuous mesh") - end if + if(have_option(trim(hp%option_path)//& + & "/prognostic/spatial_discretisation/discontinuous_galerkin")) then + if(continuity(hp) > 0) then + FLExit("HydrostaticPressure with discontinuous_galerkin requires a discontinuous mesh") + end if - call calculate_hydrostatic_pressure_dg(state, hp) + call calculate_hydrostatic_pressure_dg(state, hp) - else if(have_option(trim(hp%option_path)//& - & "/prognostic/spatial_discretisation/continuous_galerkin")) then - if(continuity(hp) < 0) then - FLExit("HydrostaticPressure with continuous_galerkin requires a continuous mesh") - end if + else if(have_option(trim(hp%option_path)//& + & "/prognostic/spatial_discretisation/continuous_galerkin")) then + if(continuity(hp) < 0) then + FLExit("HydrostaticPressure with continuous_galerkin requires a continuous mesh") + end if - call calculate_hydrostatic_pressure_cg(state, hp) + call calculate_hydrostatic_pressure_cg(state, hp) - else - FLAbort("Unknown spatial_discretisation option for HydrostaticPressure") - end if + else + FLAbort("Unknown spatial_discretisation option for HydrostaticPressure") + end if - ewrite_minmax(hp) + ewrite_minmax(hp) - end subroutine calculate_hydrostatic_pressure + end subroutine calculate_hydrostatic_pressure - subroutine calculate_hydrostatic_pressure_gradient(state) - type(state_type), intent(inout) :: state + subroutine calculate_hydrostatic_pressure_gradient(state) + type(state_type), intent(inout) :: state - integer :: stat - type(vector_field), pointer :: hpg + integer :: stat + type(vector_field), pointer :: hpg - hpg => extract_vector_field(state, hpg_name, stat = stat) - if(stat /= 0) return + hpg => extract_vector_field(state, hpg_name, stat = stat) + if(stat /= 0) return - select case(continuity(hpg)) - case(0) - FLExit("HydrostaticPressureGradient requires a discontinuous mesh") - case(-1) - call calculate_hydrostatic_pressure_gradient_dg(state, hpg) - case default - ewrite(-1, *) "For mesh continuity: ", continuity(hpg) - FLAbort("Unrecognised mesh continuity") - end select + select case(continuity(hpg)) + case(0) + FLExit("HydrostaticPressureGradient requires a discontinuous mesh") + case(-1) + call calculate_hydrostatic_pressure_gradient_dg(state, hpg) + case default + ewrite(-1, *) "For mesh continuity: ", continuity(hpg) + FLAbort("Unrecognised mesh continuity") + end select - ewrite_minmax(hpg) + ewrite_minmax(hpg) - end subroutine calculate_hydrostatic_pressure_gradient + end subroutine calculate_hydrostatic_pressure_gradient - subroutine calculate_hydrostatic_pressure_dg(state, hp) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: hp + subroutine calculate_hydrostatic_pressure_dg(state, hp) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: hp - integer, dimension(:), pointer :: surface_element_list - real :: gravity_magnitude - type(mesh_type) :: from_hp_mesh - type(mesh_type), pointer :: surface_mesh - type(scalar_field) :: lbuoyancy, from_hp - type(scalar_field), pointer :: buoyancy, topdis - type(vector_field), pointer :: positions, gravity + integer, dimension(:), pointer :: surface_element_list + real :: gravity_magnitude + type(mesh_type) :: from_hp_mesh + type(mesh_type), pointer :: surface_mesh + type(scalar_field) :: lbuoyancy, from_hp + type(scalar_field), pointer :: buoyancy, topdis + type(vector_field), pointer :: positions, gravity - ewrite(1, *) "In calculate_hydrostatic_pressure_dg" + ewrite(1, *) "In calculate_hydrostatic_pressure_dg" - if(.not. continuity(hp) == -1) then - FLExit("HydrostaticPressure using discontinuous_galerkin requires a discontinuous mesh") - end if + if(.not. continuity(hp) == -1) then + FLExit("HydrostaticPressure using discontinuous_galerkin requires a discontinuous mesh") + end if - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") - assert(ele_count(buoyancy) == ele_count(hp)) - ewrite_minmax(buoyancy) - call allocate(lbuoyancy, buoyancy%mesh, "Buoyancy") - call set(lbuoyancy, buoyancy) - call scale(lbuoyancy, gravity_magnitude) + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") + assert(ele_count(buoyancy) == ele_count(hp)) + ewrite_minmax(buoyancy) + call allocate(lbuoyancy, buoyancy%mesh, "Buoyancy") + call set(lbuoyancy, buoyancy) + call scale(lbuoyancy, gravity_magnitude) - gravity => extract_vector_field(state, "GravityDirection") - assert(gravity%dim == mesh_dim(hp)) - assert(ele_count(gravity) == ele_count(hp)) + gravity => extract_vector_field(state, "GravityDirection") + assert(gravity%dim == mesh_dim(hp)) + assert(ele_count(gravity) == ele_count(hp)) - topdis => extract_scalar_field(state, "DistanceToTop") - call get_boundary_condition(topdis, 1, surface_mesh = surface_mesh, surface_element_list = surface_element_list) - from_hp_mesh = make_mesh(surface_mesh, shape = face_shape(hp, 1), continuity = -1) - call allocate(from_hp, from_hp_mesh, hp_name // "BoundaryCondition") - call deallocate(from_hp_mesh) - call zero(from_hp) + topdis => extract_scalar_field(state, "DistanceToTop") + call get_boundary_condition(topdis, 1, surface_mesh = surface_mesh, surface_element_list = surface_element_list) + from_hp_mesh = make_mesh(surface_mesh, shape = face_shape(hp, 1), continuity = -1) + call allocate(from_hp, from_hp_mesh, hp_name // "BoundaryCondition") + call deallocate(from_hp_mesh) + call zero(from_hp) - call vertical_integration(from_hp, hp, positions, gravity, surface_element_list, lbuoyancy) + call vertical_integration(from_hp, hp, positions, gravity, surface_element_list, lbuoyancy) - call deallocate(from_hp) - call deallocate(lbuoyancy) + call deallocate(from_hp) + call deallocate(lbuoyancy) - ewrite(1, *) "Exiting calculate_hydrostatic_pressure_dg" + ewrite(1, *) "Exiting calculate_hydrostatic_pressure_dg" - end subroutine calculate_hydrostatic_pressure_dg + end subroutine calculate_hydrostatic_pressure_dg - subroutine calculate_hydrostatic_pressure_gradient_dg(state, hpg) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: hpg + subroutine calculate_hydrostatic_pressure_gradient_dg(state, hpg) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: hpg - integer :: i - integer, dimension(:), pointer :: surface_element_list - real :: gravity_magnitude - type(element_type) :: grad_buoyancy_shape - type(element_type), pointer :: buoyancy_shape - type(mesh_type) :: from_hpg_mesh, grad_buoyancy_mesh - type(mesh_type), pointer :: surface_mesh - type(scalar_field) :: from_hpg - type(scalar_field), dimension(hpg%dim) :: from_hpg_flattened, & + integer :: i + integer, dimension(:), pointer :: surface_element_list + real :: gravity_magnitude + type(element_type) :: grad_buoyancy_shape + type(element_type), pointer :: buoyancy_shape + type(mesh_type) :: from_hpg_mesh, grad_buoyancy_mesh + type(mesh_type), pointer :: surface_mesh + type(scalar_field) :: from_hpg + type(scalar_field), dimension(hpg%dim) :: from_hpg_flattened, & & hpg_flattened, grad_buoyancy_flattened - type(scalar_field), pointer :: buoyancy, topdis - type(vector_field) :: grad_buoyancy - type(vector_field), pointer :: positions, gravity - - ewrite(1, *) "In calculate_hydrostatic_pressure_gradient_dg" - - if(.not. continuity(hpg) == -1) then - FLExit("HydrostaticPressureGradient requires a discontinuous mesh") - end if - - positions => extract_vector_field(state, "Coordinate") - - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") - assert(ele_count(buoyancy) == ele_count(hpg)) - ewrite_minmax(buoyancy) - - gravity => extract_vector_field(state, "GravityDirection") - assert(gravity%dim == mesh_dim(hpg)) - assert(ele_count(gravity) == ele_count(hpg)) - - if(continuity(buoyancy) /= 0) then - ewrite(-1, *) "VelocityBuoyancyDensity on mesh " // trim(buoyancy%mesh%name) - ewrite(-1, *) "With continuity: ", continuity(buoyancy) - ewrite(-1, *) "The buoyancy field needs to be continuous for HydrostaticPressureGradient." - ewrite(-1, *) "The buoyancy inherits its mesh from the Density field, if present, or from" - ewrite(-1, *) "the Velocity field when the Density is not found. Try setting a Density" - ewrite(-1, *) "field on a continuous mesh to overcome this error." - FLExit("HydrostaticPressureGradient requires a continuous VelocityBuoyancyDensity mesh") - end if - buoyancy_shape => ele_shape(buoyancy, 1) - ! Make some assumptions in the projection of the buoyancy gradient - assert(ele_numbering_family(buoyancy_shape) == FAMILY_SIMPLEX) - assert(buoyancy_shape%numbering%type == ELEMENT_LAGRANGIAN) - assert(buoyancy_shape%degree > 0) - grad_buoyancy_shape = make_element_shape(buoyancy_shape, degree = buoyancy_shape%degree - 1) - grad_buoyancy_mesh = make_mesh(buoyancy%mesh, shape = grad_buoyancy_shape, continuity = -1) - call deallocate(grad_buoyancy_shape) - call allocate(grad_buoyancy, positions%dim, grad_buoyancy_mesh, name = "RHS") - call deallocate(grad_buoyancy_mesh) - do i = 1, ele_count(grad_buoyancy) - call calculate_grad_h_ele(i, positions, buoyancy, grad_buoyancy, gravity) - end do - call scale(grad_buoyancy, gravity_magnitude) - ewrite_minmax(grad_buoyancy) - - topdis => extract_scalar_field(state, "DistanceToTop") - call get_boundary_condition(topdis, 1, surface_mesh = surface_mesh, surface_element_list = surface_element_list) - from_hpg_mesh = make_mesh(surface_mesh, shape = face_shape(hpg, 1), continuity = -1) - call allocate(from_hpg, from_hpg_mesh, hp_name // "BoundaryCondition") - call deallocate(from_hpg_mesh) - call zero(from_hpg) - - do i = 1, hpg%dim - from_hpg_flattened(i) = from_hpg - hpg_flattened(i) = extract_scalar_field(hpg, i) - grad_buoyancy_flattened(i) = extract_scalar_field(grad_buoyancy, i) - end do - call vertical_integration(from_hpg_flattened, hpg_flattened, positions, gravity, surface_element_list, grad_buoyancy_flattened) - - call deallocate(from_hpg) - call deallocate(grad_buoyancy) - - ewrite(1, *) "Exiting calculate_hydrostatic_pressure_gradient_dg" - - contains - - subroutine calculate_grad_h_ele(ele, positions, source, grad_h, vertical_normal) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source - type(vector_field), intent(inout) :: grad_h - type(vector_field), intent(in) :: vertical_normal + type(scalar_field), pointer :: buoyancy, topdis + type(vector_field) :: grad_buoyancy + type(vector_field), pointer :: positions, gravity - integer :: i - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(source, ele), ele_ngi(positions, ele), positions%dim) :: dshape - real, dimension(ele_loc(grad_h, ele), grad_h%dim) :: little_rhs - real, dimension(ele_loc(grad_h, ele), ele_loc(grad_h, ele)) :: little_mass - real, dimension(positions%dim, ele_ngi(positions, ele)) :: g_gi, grad_gi, grad_h_gi - type(element_type), pointer :: shape + ewrite(1, *) "In calculate_hydrostatic_pressure_gradient_dg" - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + if(.not. continuity(hpg) == -1) then + FLExit("HydrostaticPressureGradient requires a discontinuous mesh") + end if - shape => ele_shape(grad_h, ele) - little_mass = shape_shape(shape, shape, detwei) + positions => extract_vector_field(state, "Coordinate") - grad_gi = ele_grad_at_quad(source, ele, dshape) - g_gi = ele_val_at_quad(vertical_normal, ele) + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") + assert(ele_count(buoyancy) == ele_count(hpg)) + ewrite_minmax(buoyancy) + + gravity => extract_vector_field(state, "GravityDirection") + assert(gravity%dim == mesh_dim(hpg)) + assert(ele_count(gravity) == ele_count(hpg)) + + if(continuity(buoyancy) /= 0) then + ewrite(-1, *) "VelocityBuoyancyDensity on mesh " // trim(buoyancy%mesh%name) + ewrite(-1, *) "With continuity: ", continuity(buoyancy) + ewrite(-1, *) "The buoyancy field needs to be continuous for HydrostaticPressureGradient." + ewrite(-1, *) "The buoyancy inherits its mesh from the Density field, if present, or from" + ewrite(-1, *) "the Velocity field when the Density is not found. Try setting a Density" + ewrite(-1, *) "field on a continuous mesh to overcome this error." + FLExit("HydrostaticPressureGradient requires a continuous VelocityBuoyancyDensity mesh") + end if + buoyancy_shape => ele_shape(buoyancy, 1) + ! Make some assumptions in the projection of the buoyancy gradient + assert(ele_numbering_family(buoyancy_shape) == FAMILY_SIMPLEX) + assert(buoyancy_shape%numbering%type == ELEMENT_LAGRANGIAN) + assert(buoyancy_shape%degree > 0) + grad_buoyancy_shape = make_element_shape(buoyancy_shape, degree = buoyancy_shape%degree - 1) + grad_buoyancy_mesh = make_mesh(buoyancy%mesh, shape = grad_buoyancy_shape, continuity = -1) + call deallocate(grad_buoyancy_shape) + call allocate(grad_buoyancy, positions%dim, grad_buoyancy_mesh, name = "RHS") + call deallocate(grad_buoyancy_mesh) + do i = 1, ele_count(grad_buoyancy) + call calculate_grad_h_ele(i, positions, buoyancy, grad_buoyancy, gravity) + end do + call scale(grad_buoyancy, gravity_magnitude) + ewrite_minmax(grad_buoyancy) - do i = 1, size(grad_h_gi, 2) - grad_h_gi(:, i) = grad_gi(:, i) - (dot_product(grad_gi(:, i), g_gi(:, i)) * g_gi(:, i)) + topdis => extract_scalar_field(state, "DistanceToTop") + call get_boundary_condition(topdis, 1, surface_mesh = surface_mesh, surface_element_list = surface_element_list) + from_hpg_mesh = make_mesh(surface_mesh, shape = face_shape(hpg, 1), continuity = -1) + call allocate(from_hpg, from_hpg_mesh, hp_name // "BoundaryCondition") + call deallocate(from_hpg_mesh) + call zero(from_hpg) + + do i = 1, hpg%dim + from_hpg_flattened(i) = from_hpg + hpg_flattened(i) = extract_scalar_field(hpg, i) + grad_buoyancy_flattened(i) = extract_scalar_field(grad_buoyancy, i) end do + call vertical_integration(from_hpg_flattened, hpg_flattened, positions, gravity, surface_element_list, grad_buoyancy_flattened) - little_rhs = transpose(shape_vector_rhs(shape, grad_h_gi, detwei)) + call deallocate(from_hpg) + call deallocate(grad_buoyancy) - call solve(little_mass, little_rhs) + ewrite(1, *) "Exiting calculate_hydrostatic_pressure_gradient_dg" - call set(grad_h, ele_nodes(grad_h, ele), transpose(little_rhs)) + contains - end subroutine calculate_grad_h_ele + subroutine calculate_grad_h_ele(ele, positions, source, grad_h, vertical_normal) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source + type(vector_field), intent(inout) :: grad_h + type(vector_field), intent(in) :: vertical_normal - end subroutine calculate_hydrostatic_pressure_gradient_dg + integer :: i + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(source, ele), ele_ngi(positions, ele), positions%dim) :: dshape + real, dimension(ele_loc(grad_h, ele), grad_h%dim) :: little_rhs + real, dimension(ele_loc(grad_h, ele), ele_loc(grad_h, ele)) :: little_mass + real, dimension(positions%dim, ele_ngi(positions, ele)) :: g_gi, grad_gi, grad_h_gi + type(element_type), pointer :: shape - subroutine calculate_hydrostatic_pressure_cg(state, hp) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: hp + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - type(csr_matrix), pointer :: matrix - type(scalar_field) :: rhs - logical :: assemble_matrix + shape => ele_shape(grad_h, ele) + little_mass = shape_shape(shape, shape, detwei) - ewrite(1,*) 'In calculate_hydrostatic_pressure_cg' + grad_gi = ele_grad_at_quad(source, ele, dshape) + g_gi = ele_val_at_quad(vertical_normal, ele) - matrix => get_hydrostatic_pressure_cg_matrix(state, assemble_matrix=assemble_matrix) - call allocate(rhs, hp%mesh, "HydrostaticPressureCGRHS") + do i = 1, size(grad_h_gi, 2) + grad_h_gi(:, i) = grad_gi(:, i) - (dot_product(grad_gi(:, i), g_gi(:, i)) * g_gi(:, i)) + end do - ewrite(2,*) 'assembling matrix: ', assemble_matrix + little_rhs = transpose(shape_vector_rhs(shape, grad_h_gi, detwei)) - call profiler_tic(hp, "assembly") - call assemble_hydrostatic_pressure_cg(state, hp, matrix, rhs, assemble_matrix) - call profiler_toc(hp, "assembly") + call solve(little_mass, little_rhs) - call petsc_solve(hp, matrix, rhs) + call set(grad_h, ele_nodes(grad_h, ele), transpose(little_rhs)) - call deallocate(rhs) + end subroutine calculate_grad_h_ele - end subroutine calculate_hydrostatic_pressure_cg + end subroutine calculate_hydrostatic_pressure_gradient_dg - subroutine assemble_hydrostatic_pressure_cg(state, hp, matrix, rhs, assemble_matrix) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: hp - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - logical, intent(in) :: assemble_matrix + subroutine calculate_hydrostatic_pressure_cg(state, hp) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: hp - real :: gravity_magnitude - type(scalar_field), pointer :: buoyancy, topdis - type(vector_field), pointer :: coordinate, gravity - type(scalar_field) :: lbuoyancy + type(csr_matrix), pointer :: matrix + type(scalar_field) :: rhs + logical :: assemble_matrix - integer :: i, ele, face + ewrite(1,*) 'In calculate_hydrostatic_pressure_cg' - integer, dimension(:), pointer :: surface_element_list + matrix => get_hydrostatic_pressure_cg_matrix(state, assemble_matrix=assemble_matrix) + call allocate(rhs, hp%mesh, "HydrostaticPressureCGRHS") - ewrite(1,*) 'In assemble_hydrostatic_pressure_cg' + ewrite(2,*) 'assembling matrix: ', assemble_matrix - coordinate => extract_vector_field(state, "Coordinate") - assert(coordinate%dim == mesh_dim(hp)) - assert(ele_count(coordinate) == ele_count(hp)) + call profiler_tic(hp, "assembly") + call assemble_hydrostatic_pressure_cg(state, hp, matrix, rhs, assemble_matrix) + call profiler_toc(hp, "assembly") - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") - assert(ele_count(buoyancy) == ele_count(hp)) - ewrite_minmax(buoyancy) - call allocate(lbuoyancy, buoyancy%mesh, "HydrostaticPressureCGBuoyancy") - call set(lbuoyancy, buoyancy) - call scale(lbuoyancy, gravity_magnitude) + call petsc_solve(hp, matrix, rhs) - gravity => extract_vector_field(state, "GravityDirection") - assert(gravity%dim == mesh_dim(hp)) - assert(ele_count(gravity) == ele_count(hp)) + call deallocate(rhs) - if(have_option(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind")) then - ewrite(2, *) "Streamline upwind stabilisation" - stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND - call get_upwind_options(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind", & - & nu_bar_scheme, nu_bar_scale) - else if(have_option(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin")) then - ewrite(2, *) "SUPG stabilisation" - stabilisation_scheme = STABILISATION_SUPG - call get_upwind_options(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin", & - & nu_bar_scheme, nu_bar_scale) - else - ewrite(2, *) "No stabilisation" - stabilisation_scheme = STABILISATION_NONE - end if + end subroutine calculate_hydrostatic_pressure_cg - if(assemble_matrix) call zero(matrix) - call zero(rhs) + subroutine assemble_hydrostatic_pressure_cg(state, hp, matrix, rhs, assemble_matrix) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: hp + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + logical, intent(in) :: assemble_matrix - do ele = 1, element_count(hp) - call assemble_hydrostatic_pressure_cg_element(matrix, rhs, & - hp, coordinate, lbuoyancy, gravity, & - ele, assemble_matrix) - end do + real :: gravity_magnitude + type(scalar_field), pointer :: buoyancy, topdis + type(vector_field), pointer :: coordinate, gravity + type(scalar_field) :: lbuoyancy - if(assemble_matrix) then - topdis => extract_scalar_field(state, "DistanceToTop") - call get_boundary_condition(topdis, 1, surface_element_list = surface_element_list) + integer :: i, ele, face - do i = 1, size(surface_element_list) - face=surface_element_list(i) - call assemble_hydrostatic_pressure_cg_facet(matrix, & - hp, coordinate, gravity, & - face) + integer, dimension(:), pointer :: surface_element_list + + ewrite(1,*) 'In assemble_hydrostatic_pressure_cg' + + coordinate => extract_vector_field(state, "Coordinate") + assert(coordinate%dim == mesh_dim(hp)) + assert(ele_count(coordinate) == ele_count(hp)) + + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") + assert(ele_count(buoyancy) == ele_count(hp)) + ewrite_minmax(buoyancy) + call allocate(lbuoyancy, buoyancy%mesh, "HydrostaticPressureCGBuoyancy") + call set(lbuoyancy, buoyancy) + call scale(lbuoyancy, gravity_magnitude) + + gravity => extract_vector_field(state, "GravityDirection") + assert(gravity%dim == mesh_dim(hp)) + assert(ele_count(gravity) == ele_count(hp)) + + if(have_option(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind")) then + ewrite(2, *) "Streamline upwind stabilisation" + stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND + call get_upwind_options(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind", & + & nu_bar_scheme, nu_bar_scale) + else if(have_option(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin")) then + ewrite(2, *) "SUPG stabilisation" + stabilisation_scheme = STABILISATION_SUPG + call get_upwind_options(trim(hp%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin", & + & nu_bar_scheme, nu_bar_scale) + else + ewrite(2, *) "No stabilisation" + stabilisation_scheme = STABILISATION_NONE + end if + + if(assemble_matrix) call zero(matrix) + call zero(rhs) + + do ele = 1, element_count(hp) + call assemble_hydrostatic_pressure_cg_element(matrix, rhs, & + hp, coordinate, lbuoyancy, gravity, & + ele, assemble_matrix) end do - end if - ewrite_minmax(rhs) + if(assemble_matrix) then + topdis => extract_scalar_field(state, "DistanceToTop") + call get_boundary_condition(topdis, 1, surface_element_list = surface_element_list) - call deallocate(lbuoyancy) + do i = 1, size(surface_element_list) + face=surface_element_list(i) + call assemble_hydrostatic_pressure_cg_facet(matrix, & + hp, coordinate, gravity, & + face) + end do + end if + + ewrite_minmax(rhs) - end subroutine assemble_hydrostatic_pressure_cg + call deallocate(lbuoyancy) - subroutine assemble_hydrostatic_pressure_cg_element(matrix, rhs, & - hp, coordinate, buoyancy, gravity, & - ele, assemble_matrix) - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs + end subroutine assemble_hydrostatic_pressure_cg - type(scalar_field), intent(in) :: hp - type(vector_field), intent(in) :: coordinate - type(scalar_field), intent(in) :: buoyancy - type(vector_field), intent(in) :: gravity + subroutine assemble_hydrostatic_pressure_cg_element(matrix, rhs, & + hp, coordinate, buoyancy, gravity, & + ele, assemble_matrix) + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs - integer, intent(in) :: ele - logical, intent(in) :: assemble_matrix + type(scalar_field), intent(in) :: hp + type(vector_field), intent(in) :: coordinate + type(scalar_field), intent(in) :: buoyancy + type(vector_field), intent(in) :: gravity + + integer, intent(in) :: ele + logical, intent(in) :: assemble_matrix - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(hp, ele)) :: detwei - real, dimension(ele_loc(hp, ele), ele_ngi(hp, ele), mesh_dim(hp)) :: dhp_t - real, dimension(mesh_dim(hp), mesh_dim(hp), ele_ngi(hp, ele)) :: j_mat - type(element_type) :: test_function - type(element_type), pointer :: hp_shape + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(hp, ele)) :: detwei + real, dimension(ele_loc(hp, ele), ele_ngi(hp, ele), mesh_dim(hp)) :: dhp_t + real, dimension(mesh_dim(hp), mesh_dim(hp), ele_ngi(hp, ele)) :: j_mat + type(element_type) :: test_function + type(element_type), pointer :: hp_shape - ! What we will be adding to the matrix and RHS - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(ele_loc(hp, ele)) :: rhs_addto - real, dimension(ele_loc(hp, ele), ele_loc(hp, ele)) :: matrix_addto + ! What we will be adding to the matrix and RHS - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(ele_loc(hp, ele)) :: rhs_addto + real, dimension(ele_loc(hp, ele), ele_loc(hp, ele)) :: matrix_addto #ifdef DDEBUG - assert(ele_ngi(coordinate, ele) == ele_ngi(hp, ele)) - assert(ele_ngi(gravity, ele) == ele_ngi(hp, ele)) - assert(ele_ngi(buoyancy, ele) == ele_ngi(hp, ele)) + assert(ele_ngi(coordinate, ele) == ele_ngi(hp, ele)) + assert(ele_ngi(gravity, ele) == ele_ngi(hp, ele)) + assert(ele_ngi(buoyancy, ele) == ele_ngi(hp, ele)) #endif - matrix_addto = 0.0 - rhs_addto = 0.0 - - hp_shape => ele_shape(hp, ele) - - if(any(stabilisation_scheme == (/STABILISATION_STREAMLINE_UPWIND, STABILISATION_SUPG/))) then - call transform_to_physical(coordinate, ele, hp_shape, & - dshape=dhp_t, detwei=detwei, j=j_mat) - else - call transform_to_physical(coordinate, ele, hp_shape, & - dshape=dhp_t, detwei=detwei) - end if - - select case(stabilisation_scheme) - case(STABILISATION_SUPG) - test_function = make_supg_shape(hp_shape, dhp_t, ele_val_at_quad(gravity, ele), j_mat, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - case default - test_function = hp_shape - call incref(test_function) - end select - ! Important note: with SUPG the test function derivatives have not been - ! modified - i.e. dhp_t is currently used everywhere. This is fine for P1, - ! but is not consistent for P>1. - - if(assemble_matrix) then - call add_matrix_element_cg(ele, test_function, hp, & - gravity, & - dhp_t, detwei, j_mat, & - matrix_addto) - end if - - call add_buoyancy_element_cg(ele, test_function, hp, & - buoyancy, detwei, rhs_addto) - - element_nodes => ele_nodes(hp, ele) - if(assemble_matrix) call addto(matrix, element_nodes, element_nodes, matrix_addto) - call addto(rhs, element_nodes, rhs_addto) - - call deallocate(test_function) - - end subroutine assemble_hydrostatic_pressure_cg_element - - subroutine add_matrix_element_cg(ele, test_function, hp, & - gravity, & - dhp_t, detwei, j_mat, & - matrix_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: hp - type(vector_field), intent(in) :: gravity - real, dimension(ele_loc(hp, ele), ele_ngi(hp, ele), mesh_dim(hp)), intent(in) :: dhp_t - real, dimension(ele_ngi(hp, ele)), intent(in) :: detwei - real, dimension(mesh_dim(hp), mesh_dim(hp), ele_ngi(hp, ele)), intent(in) :: j_mat - real, dimension(ele_loc(hp, ele), ele_loc(hp, ele)), intent(inout) :: matrix_addto + matrix_addto = 0.0 + rhs_addto = 0.0 - real, dimension(ele_loc(hp, ele), ele_loc(hp,ele)) :: advection_mat - real, dimension(gravity%dim, ele_ngi(gravity, ele)) :: gravity_at_quad - type(element_type), pointer :: hp_shape + hp_shape => ele_shape(hp, ele) - hp_shape => ele_shape(hp, ele) + if(any(stabilisation_scheme == (/STABILISATION_STREAMLINE_UPWIND, STABILISATION_SUPG/))) then + call transform_to_physical(coordinate, ele, hp_shape, & + dshape=dhp_t, detwei=detwei, j=j_mat) + else + call transform_to_physical(coordinate, ele, hp_shape, & + dshape=dhp_t, detwei=detwei) + end if - gravity_at_quad = ele_val_at_quad(gravity, ele) + select case(stabilisation_scheme) + case(STABILISATION_SUPG) + test_function = make_supg_shape(hp_shape, dhp_t, ele_val_at_quad(gravity, ele), j_mat, & + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + case default + test_function = hp_shape + call incref(test_function) + end select + ! Important note: with SUPG the test function derivatives have not been + ! modified - i.e. dhp_t is currently used everywhere. This is fine for P1, + ! but is not consistent for P>1. + + if(assemble_matrix) then + call add_matrix_element_cg(ele, test_function, hp, & + gravity, & + dhp_t, detwei, j_mat, & + matrix_addto) + end if - ! element advection matrix - ! / - ! | N_A (grav dot grad N_B) dV - ! / - advection_mat = shape_vector_dot_dshape(test_function, gravity_at_quad, dhp_t, detwei) + call add_buoyancy_element_cg(ele, test_function, hp, & + buoyancy, detwei, rhs_addto) - ! Stabilisation - select case(stabilisation_scheme) - case(STABILISATION_STREAMLINE_UPWIND) - advection_mat = advection_mat + & - & element_upwind_stabilisation(hp_shape, dhp_t, gravity_at_quad, j_mat, detwei, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - end select + element_nodes => ele_nodes(hp, ele) + if(assemble_matrix) call addto(matrix, element_nodes, element_nodes, matrix_addto) + call addto(rhs, element_nodes, rhs_addto) - matrix_addto = matrix_addto + advection_mat + call deallocate(test_function) - end subroutine add_matrix_element_cg + end subroutine assemble_hydrostatic_pressure_cg_element - subroutine add_buoyancy_element_cg(ele, test_function, & - hp, buoyancy, detwei, rhs_addto) - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(scalar_field), intent(in) :: hp - type(scalar_field), intent(in) :: buoyancy - real, dimension(ele_ngi(hp, ele)), intent(in) :: detwei - real, dimension(ele_loc(hp, ele)), intent(inout) :: rhs_addto + subroutine add_matrix_element_cg(ele, test_function, hp, & + gravity, & + dhp_t, detwei, j_mat, & + matrix_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: hp + type(vector_field), intent(in) :: gravity + real, dimension(ele_loc(hp, ele), ele_ngi(hp, ele), mesh_dim(hp)), intent(in) :: dhp_t + real, dimension(ele_ngi(hp, ele)), intent(in) :: detwei + real, dimension(mesh_dim(hp), mesh_dim(hp), ele_ngi(hp, ele)), intent(in) :: j_mat + real, dimension(ele_loc(hp, ele), ele_loc(hp, ele)), intent(inout) :: matrix_addto + + real, dimension(ele_loc(hp, ele), ele_loc(hp,ele)) :: advection_mat + real, dimension(gravity%dim, ele_ngi(gravity, ele)) :: gravity_at_quad + type(element_type), pointer :: hp_shape + + hp_shape => ele_shape(hp, ele) + + gravity_at_quad = ele_val_at_quad(gravity, ele) + + ! element advection matrix + ! / + ! | N_A (grav dot grad N_B) dV + ! / + advection_mat = shape_vector_dot_dshape(test_function, gravity_at_quad, dhp_t, detwei) + + ! Stabilisation + select case(stabilisation_scheme) + case(STABILISATION_STREAMLINE_UPWIND) + advection_mat = advection_mat + & + & element_upwind_stabilisation(hp_shape, dhp_t, gravity_at_quad, j_mat, detwei, & + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + end select + + matrix_addto = matrix_addto + advection_mat + + end subroutine add_matrix_element_cg + + subroutine add_buoyancy_element_cg(ele, test_function, & + hp, buoyancy, detwei, rhs_addto) + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(scalar_field), intent(in) :: hp + type(scalar_field), intent(in) :: buoyancy + real, dimension(ele_ngi(hp, ele)), intent(in) :: detwei + real, dimension(ele_loc(hp, ele)), intent(inout) :: rhs_addto - rhs_addto = rhs_addto + shape_rhs(test_function, detwei * ele_val_at_quad(buoyancy, ele)) + rhs_addto = rhs_addto + shape_rhs(test_function, detwei * ele_val_at_quad(buoyancy, ele)) - end subroutine add_buoyancy_element_cg + end subroutine add_buoyancy_element_cg - subroutine assemble_hydrostatic_pressure_cg_facet(matrix, & - hp, coordinate, gravity, & - face) - type(csr_matrix), intent(inout) :: matrix + subroutine assemble_hydrostatic_pressure_cg_facet(matrix, & + hp, coordinate, gravity, & + face) + type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(in) :: hp - type(vector_field), intent(in) :: coordinate - type(vector_field), intent(in) :: gravity + type(scalar_field), intent(in) :: hp + type(vector_field), intent(in) :: coordinate + type(vector_field), intent(in) :: gravity - integer, intent(in) :: face + integer, intent(in) :: face - ! What we will be adding to the matrix - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(face_loc(hp, face), face_loc(hp, face)) :: matrix_addto + ! What we will be adding to the matrix - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(face_loc(hp, face), face_loc(hp, face)) :: matrix_addto - integer, dimension(face_loc(hp, face)) :: face_nodes - real, dimension(face_ngi(hp, face)) :: detwei - real, dimension(mesh_dim(hp), face_ngi(hp, face)) :: normal + integer, dimension(face_loc(hp, face)) :: face_nodes + real, dimension(face_ngi(hp, face)) :: detwei + real, dimension(mesh_dim(hp), face_ngi(hp, face)) :: normal - assert(face_ngi(coordinate, face) == face_ngi(hp, face)) - assert(face_ngi(gravity, face) == face_ngi(hp, face)) + assert(face_ngi(coordinate, face) == face_ngi(hp, face)) + assert(face_ngi(gravity, face) == face_ngi(hp, face)) - matrix_addto = 0.0 + matrix_addto = 0.0 - call transform_facet_to_physical(coordinate, face, & - & detwei_f = detwei, normal = normal) + call transform_facet_to_physical(coordinate, face, & + & detwei_f = detwei, normal = normal) - call add_matrix_face_cg(face, hp, gravity, detwei, normal, matrix_addto) + call add_matrix_face_cg(face, hp, gravity, detwei, normal, matrix_addto) - face_nodes = face_global_nodes(hp, face) - call addto(matrix, face_nodes, face_nodes, matrix_addto) + face_nodes = face_global_nodes(hp, face) + call addto(matrix, face_nodes, face_nodes, matrix_addto) - end subroutine assemble_hydrostatic_pressure_cg_facet + end subroutine assemble_hydrostatic_pressure_cg_facet - subroutine add_matrix_face_cg(face, hp, gravity, detwei, normal, matrix_addto) - integer, intent(in) :: face - type(scalar_field), intent(in) :: hp - type(vector_field), intent(in) :: gravity - real, dimension(face_ngi(hp, face)), intent(in) :: detwei - real, dimension(mesh_dim(hp), face_ngi(hp, face)), intent(in) :: normal - real, dimension(face_loc(hp, face), face_loc(hp, face)), intent(inout) :: matrix_addto + subroutine add_matrix_face_cg(face, hp, gravity, detwei, normal, matrix_addto) + integer, intent(in) :: face + type(scalar_field), intent(in) :: hp + type(vector_field), intent(in) :: gravity + real, dimension(face_ngi(hp, face)), intent(in) :: detwei + real, dimension(mesh_dim(hp), face_ngi(hp, face)), intent(in) :: normal + real, dimension(face_loc(hp, face), face_loc(hp, face)), intent(inout) :: matrix_addto - real, dimension(gravity%dim, face_ngi(gravity, face)) :: gravity_at_quad - real, dimension(face_loc(hp, face), face_loc(hp,face)) :: advection_mat - type(element_type), pointer :: hp_shape + real, dimension(gravity%dim, face_ngi(gravity, face)) :: gravity_at_quad + real, dimension(face_loc(hp, face), face_loc(hp,face)) :: advection_mat + type(element_type), pointer :: hp_shape - hp_shape => face_shape(hp, face) + hp_shape => face_shape(hp, face) - gravity_at_quad = face_val_at_quad(gravity, face) + gravity_at_quad = face_val_at_quad(gravity, face) - advection_mat = shape_shape(hp_shape, hp_shape, detwei * sum(gravity_at_quad * normal, 1)) + advection_mat = shape_shape(hp_shape, hp_shape, detwei * sum(gravity_at_quad * normal, 1)) - matrix_addto = matrix_addto - advection_mat + matrix_addto = matrix_addto - advection_mat - end subroutine add_matrix_face_cg + end subroutine add_matrix_face_cg - subroutine subtract_hydrostatic_pressure_gradient(mom_rhs, state) - !!< Subtract the HydrostaticPressure gradient from the momentum equation - !!< RHS + subroutine subtract_hydrostatic_pressure_gradient(mom_rhs, state) + !!< Subtract the HydrostaticPressure gradient from the momentum equation + !!< RHS - type(vector_field), intent(inout) :: mom_rhs - type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: mom_rhs + type(state_type), intent(inout) :: state - integer :: i, stat - type(scalar_field), pointer :: hp - type(vector_field), pointer :: positions, hpg + integer :: i, stat + type(scalar_field), pointer :: hp + type(vector_field), pointer :: positions, hpg - logical :: dg + logical :: dg - ewrite(1, *) "In subtract_hydrostatic_pressure_gradient" + ewrite(1, *) "In subtract_hydrostatic_pressure_gradient" - hp => extract_scalar_field(state, hp_name, stat) - if(stat == 0) then - assert(ele_count(hp) == ele_count(mom_rhs)) + hp => extract_scalar_field(state, hp_name, stat) + if(stat == 0) then + assert(ele_count(hp) == ele_count(mom_rhs)) - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mom_rhs%dim) - assert(ele_count(positions) == ele_count(mom_rhs)) - - ewrite_minmax(mom_rhs) - - if(have_option(trim(hp%option_path)// & - "/prognostic/spatial_discretisation/continuous_galerkin/do_not_integrate_gradient_by_parts")) then - ewrite(2,*) 'not integrating gradient by parts' - do i = 1, ele_count(mom_rhs) - if((continuity(mom_rhs)>=0).or.(element_owned(mom_rhs, i))) then - call subtract_given_hydrostatic_pressure_gradient_element(i, positions,hp, mom_rhs) - end if - end do - else - dg = (continuity(mom_rhs)==-1) - ewrite(2,*) 'integrating gradient by parts, dg = ', dg - do i = 1, ele_count(mom_rhs) - if((.not.dg).or.(element_owned(mom_rhs, i))) then - call subtract_given_hydrostatic_pressure_gradient_element_ibp(i, positions,hp, mom_rhs, dg) - end if - end do + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mom_rhs%dim) + assert(ele_count(positions) == ele_count(mom_rhs)) - end if + ewrite_minmax(mom_rhs) - ewrite_minmax(mom_rhs) - end if + if(have_option(trim(hp%option_path)// & + "/prognostic/spatial_discretisation/continuous_galerkin/do_not_integrate_gradient_by_parts")) then + ewrite(2,*) 'not integrating gradient by parts' + do i = 1, ele_count(mom_rhs) + if((continuity(mom_rhs)>=0).or.(element_owned(mom_rhs, i))) then + call subtract_given_hydrostatic_pressure_gradient_element(i, positions,hp, mom_rhs) + end if + end do + else + dg = (continuity(mom_rhs)==-1) + ewrite(2,*) 'integrating gradient by parts, dg = ', dg + do i = 1, ele_count(mom_rhs) + if((.not.dg).or.(element_owned(mom_rhs, i))) then + call subtract_given_hydrostatic_pressure_gradient_element_ibp(i, positions,hp, mom_rhs, dg) + end if + end do - hpg => extract_vector_field(state, hpg_name, stat) - if(stat == 0) then - assert(ele_count(hpg) == ele_count(mom_rhs)) + end if - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mom_rhs%dim) - assert(ele_count(positions) == ele_count(mom_rhs)) + ewrite_minmax(mom_rhs) + end if - ewrite_minmax(mom_rhs) + hpg => extract_vector_field(state, hpg_name, stat) + if(stat == 0) then + assert(ele_count(hpg) == ele_count(mom_rhs)) - do i = 1, ele_count(mom_rhs) - call subtract_given_hydrostatic_pressure_gradient_element(i, positions, hpg, mom_rhs) - end do + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mom_rhs%dim) + assert(ele_count(positions) == ele_count(mom_rhs)) - ewrite_minmax(mom_rhs) - end if + ewrite_minmax(mom_rhs) - ewrite(1, *) "Exiting subtract_hydrostatic_pressure_gradient" + do i = 1, ele_count(mom_rhs) + call subtract_given_hydrostatic_pressure_gradient_element(i, positions, hpg, mom_rhs) + end do - end subroutine subtract_hydrostatic_pressure_gradient + ewrite_minmax(mom_rhs) + end if - subroutine subtract_given_hydrostatic_pressure_gradient_element_scalar(ele, positions, hp, mom_rhs) - !!< Subtract the element-wise contribution of the HydrostaticPressure - !!< gradient from the momentum equation RHS + ewrite(1, *) "Exiting subtract_hydrostatic_pressure_gradient" - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: hp - type(vector_field), intent(inout) :: mom_rhs + end subroutine subtract_hydrostatic_pressure_gradient - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(hp, ele), ele_ngi(positions, ele), positions%dim) :: dn_t + subroutine subtract_given_hydrostatic_pressure_gradient_element_scalar(ele, positions, hp, mom_rhs) + !!< Subtract the element-wise contribution of the HydrostaticPressure + !!< gradient from the momentum equation RHS - assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) - assert(ele_ngi(hp, ele) == ele_ngi(mom_rhs, ele)) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: hp + type(vector_field), intent(inout) :: mom_rhs + + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(hp, ele), ele_ngi(positions, ele), positions%dim) :: dn_t + + assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(hp, ele) == ele_ngi(mom_rhs, ele)) - call transform_to_physical(positions, ele, ele_shape(hp, ele), & + call transform_to_physical(positions, ele, ele_shape(hp, ele), & & dshape = dn_t, detwei = detwei) - ! / - ! | -N_A grad gp dV - ! / - call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_grad_at_quad(hp, ele, dn_t), detwei)) + ! / + ! | -N_A grad gp dV + ! / + call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_grad_at_quad(hp, ele, dn_t), detwei)) - end subroutine subtract_given_hydrostatic_pressure_gradient_element_scalar + end subroutine subtract_given_hydrostatic_pressure_gradient_element_scalar - subroutine subtract_given_hydrostatic_pressure_gradient_element_vector(ele, positions, hpg, mom_rhs) - !!< Subtract the element-wise contribution of the HydrostaticPressureGradient - !!< from the momentum equation RHS + subroutine subtract_given_hydrostatic_pressure_gradient_element_vector(ele, positions, hpg, mom_rhs) + !!< Subtract the element-wise contribution of the HydrostaticPressureGradient + !!< from the momentum equation RHS - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: hpg - type(vector_field), intent(inout) :: mom_rhs + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: hpg + type(vector_field), intent(inout) :: mom_rhs - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) - assert(ele_ngi(hpg, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(hpg, ele) == ele_ngi(mom_rhs, ele)) - call transform_to_physical(positions, ele, & + call transform_to_physical(positions, ele, & & detwei = detwei) - ! / - ! | -N_A grad gp dV - ! / - call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_val_at_quad(hpg, ele), detwei)) + ! / + ! | -N_A grad gp dV + ! / + call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_val_at_quad(hpg, ele), detwei)) - end subroutine subtract_given_hydrostatic_pressure_gradient_element_vector + end subroutine subtract_given_hydrostatic_pressure_gradient_element_vector - subroutine subtract_given_hydrostatic_pressure_gradient_element_ibp(ele, positions, hp, mom_rhs, dg) - !!< Subtract the element-wise contribution of the HydrostaticPressure - !!< gradient from the momentum equation RHS + subroutine subtract_given_hydrostatic_pressure_gradient_element_ibp(ele, positions, hp, mom_rhs, dg) + !!< Subtract the element-wise contribution of the HydrostaticPressure + !!< gradient from the momentum equation RHS - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: hp - type(vector_field), intent(inout) :: mom_rhs - logical, intent(in) :: dg + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: hp + type(vector_field), intent(inout) :: mom_rhs + logical, intent(in) :: dg - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(mom_rhs, ele), ele_ngi(mom_rhs, ele), mom_rhs%dim) :: dn_s + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(mom_rhs, ele), ele_ngi(mom_rhs, ele), mom_rhs%dim) :: dn_s - integer, dimension(:), pointer :: neigh - integer :: ele_2, face, face_2, ni - logical :: p0 + integer, dimension(:), pointer :: neigh + integer :: ele_2, face, face_2, ni + logical :: p0 - assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) - assert(ele_ngi(hp, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(hp, ele) == ele_ngi(mom_rhs, ele)) - p0 =(element_degree(mom_rhs,ele)==0) + p0 =(element_degree(mom_rhs,ele)==0) - if(.not.p0) then - call transform_to_physical(positions, ele, ele_shape(mom_rhs, ele), & - & dshape = dn_s, detwei = detwei) + if(.not.p0) then + call transform_to_physical(positions, ele, ele_shape(mom_rhs, ele), & + & dshape = dn_s, detwei = detwei) - ! / - ! | -N_A grad gp dV - ! / - call addto(mom_rhs, ele_nodes(mom_rhs, ele), dshape_rhs(dn_s, detwei*ele_val_at_quad(hp, ele))) - end if - - neigh=>ele_neigh(hp, ele) - neighbourloop: do ni = 1, size(neigh) - ele_2 = neigh(ni) - if((ele_2<0).or.dg) then - ! get in here if it's an external face with a cg test space - ! or always for a dg test space - face = ele_face(hp, ele, ele_2) - if(ele_2>0) then - ! internal face... should only be here with dg - face_2=ele_face(hp, ele_2, ele) - else - ! the boundary case... get here with dg and cg - face_2=face - end if - - call subtract_given_hydrostatic_pressure_gradient_face_ibp(face, face_2, positions, hp, mom_rhs, dg) + ! / + ! | -N_A grad gp dV + ! / + call addto(mom_rhs, ele_nodes(mom_rhs, ele), dshape_rhs(dn_s, detwei*ele_val_at_quad(hp, ele))) + end if + neigh=>ele_neigh(hp, ele) + neighbourloop: do ni = 1, size(neigh) + ele_2 = neigh(ni) + if((ele_2<0).or.dg) then + ! get in here if it's an external face with a cg test space + ! or always for a dg test space + face = ele_face(hp, ele, ele_2) + if(ele_2>0) then + ! internal face... should only be here with dg + face_2=ele_face(hp, ele_2, ele) + else + ! the boundary case... get here with dg and cg + face_2=face + end if + + call subtract_given_hydrostatic_pressure_gradient_face_ibp(face, face_2, positions, hp, mom_rhs, dg) + + end if + end do neighbourloop + + end subroutine subtract_given_hydrostatic_pressure_gradient_element_ibp + + subroutine subtract_given_hydrostatic_pressure_gradient_face_ibp(face, face_2, positions, hp, mom_rhs, dg) + integer, intent(in) :: face, face_2 + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: hp + type(vector_field), intent(inout) :: mom_rhs + logical, intent(in) :: dg + + real, dimension(face_ngi(hp, face)) :: detwei + real, dimension(mesh_dim(hp), face_ngi(hp, face)) :: normal + + real, dimension(face_ngi(hp, face)) :: hp_at_quad + + if(face==face_2) then + ! boundary case - should be the only case we end up here with cg + ! but we'll end up here with dg too + hp_at_quad = face_val_at_quad(hp, face) + else if(dg) then + ! if we're here then we have a dg test space and this is an internal face + hp_at_quad = 0.5*face_val_at_quad(hp, face)+0.5*face_val_at_quad(hp, face_2) + else + ! should never get here... if we are then we're on an internal face with a cg + ! test space. Put in a bug trap until this is tested with a cg test space. + FLAbort("Huh? Ended up at an internal face with a cg test space.") end if - end do neighbourloop - - end subroutine subtract_given_hydrostatic_pressure_gradient_element_ibp - - subroutine subtract_given_hydrostatic_pressure_gradient_face_ibp(face, face_2, positions, hp, mom_rhs, dg) - integer, intent(in) :: face, face_2 - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: hp - type(vector_field), intent(inout) :: mom_rhs - logical, intent(in) :: dg - - real, dimension(face_ngi(hp, face)) :: detwei - real, dimension(mesh_dim(hp), face_ngi(hp, face)) :: normal - - real, dimension(face_ngi(hp, face)) :: hp_at_quad - - if(face==face_2) then - ! boundary case - should be the only case we end up here with cg - ! but we'll end up here with dg too - hp_at_quad = face_val_at_quad(hp, face) - else if(dg) then - ! if we're here then we have a dg test space and this is an internal face - hp_at_quad = 0.5*face_val_at_quad(hp, face)+0.5*face_val_at_quad(hp, face_2) - else - ! should never get here... if we are then we're on an internal face with a cg - ! test space. Put in a bug trap until this is tested with a cg test space. - FLAbort("Huh? Ended up at an internal face with a cg test space.") - end if - - call transform_facet_to_physical(positions, face, & - detwei_f = detwei, normal = normal) - - call addto(mom_rhs, face_global_nodes(mom_rhs, face), & - -shape_vector_rhs(face_shape(mom_rhs, face), normal, & - hp_at_quad*detwei)) - - end subroutine subtract_given_hydrostatic_pressure_gradient_face_ibp + + call transform_facet_to_physical(positions, face, & + detwei_f = detwei, normal = normal) + + call addto(mom_rhs, face_global_nodes(mom_rhs, face), & + -shape_vector_rhs(face_shape(mom_rhs, face), normal, & + hp_at_quad*detwei)) + + end subroutine subtract_given_hydrostatic_pressure_gradient_face_ibp end module hydrostatic_pressure diff --git a/assemble/Interpolation_manager.F90 b/assemble/Interpolation_manager.F90 index 12fcbe4d2e..2d18824d12 100644 --- a/assemble/Interpolation_manager.F90 +++ b/assemble/Interpolation_manager.F90 @@ -29,1039 +29,1039 @@ module interpolation_manager - use fldebug - use spud - use global_parameters, only : OPTION_PATH_LEN, periodic_boundary_option_path,& + use fldebug + use spud + use global_parameters, only : OPTION_PATH_LEN, periodic_boundary_option_path,& FIELD_NAME_LEN - use futils, only: int2str - use linked_lists - use element_numbering, only: ELEMENT_LAGRANGIAN - use elements - use supermesh_construction - use intersection_finder_module - use fields - use state_module - use field_options - use vtk_interfaces - use interpolation_module - use conservative_interpolation_module - use dg_interpolation_module - use tictoc - use boundary_conditions_from_options - use populate_state_module - use geostrophic_pressure - use pseudo_consistent_interpolation - - implicit none - - private - - public :: interpolate, interpolation_manager_check_options - - interface collect_fields_to_interpolate - module procedure collect_fields_to_interpolate_single_state, collect_fields_to_interpolate_multiple_states - end interface + use futils, only: int2str + use linked_lists + use element_numbering, only: ELEMENT_LAGRANGIAN + use elements + use supermesh_construction + use intersection_finder_module + use fields + use state_module + use field_options + use vtk_interfaces + use interpolation_module + use conservative_interpolation_module + use dg_interpolation_module + use tictoc + use boundary_conditions_from_options + use populate_state_module + use geostrophic_pressure + use pseudo_consistent_interpolation + + implicit none + + private + + public :: interpolate, interpolation_manager_check_options + + interface collect_fields_to_interpolate + module procedure collect_fields_to_interpolate_single_state, collect_fields_to_interpolate_multiple_states + end interface contains - subroutine interpolate(states_old, states_new, map, only_owned) - !! OK! We need to figure out what algorithm to use when and where. - type(state_type), dimension(:), intent(inout) :: states_old, states_new - !! Map from new nodes to old elements - integer, dimension(:), optional, intent(in) :: map - !! Only interpolate in owned nodes - logical, optional, intent(in) :: only_owned - - ! The fields organised by mesh: - type(state_type), dimension(:), allocatable :: meshes_old, meshes_new - ! For periodic interpolation, we need to interpolate the unwrapped fields, - ! but keep the periodic fields too - type(state_type), dimension(:), allocatable :: periodic_new - ! Within each mesh, the fields organised by algorithm. - type(state_type), dimension(:), allocatable :: alg_old, alg_new - - integer :: state, state_cnt, mesh - integer :: mesh_cnt - character(len=FIELD_NAME_LEN) :: mesh_name - - type(scalar_field), pointer :: field_s, p_field_s - type(vector_field), pointer :: field_v, p_field_v - type(tensor_field), pointer :: field_t, p_field_t - integer :: field - - character(len=255), dimension(4), parameter :: algorithms = (/& - & "consistent_interpolation ", & - & "pseudo_consistent_interpolation", & - & "interpolation_galerkin ", & - & "grandy_interpolation " /) - integer :: alg_cnt, alg - - type(mesh_type), pointer :: old_mesh, new_mesh - type(vector_field) :: old_pos, new_pos - type(ilist), dimension(:), allocatable :: map_BA - - logical :: all_consistent_interpolation, all_linear_meshes, & - any_periodic_meshes - type(element_type), pointer :: field_shape - - integer :: no_fields - - integer :: stat - - ewrite(1, *) "In interpolate" - - call initialise_geostrophic_interpolation(states_old, states_new) - - mesh_cnt = option_count("/geometry/mesh") - allocate(meshes_old(mesh_cnt)) - allocate(meshes_new(mesh_cnt)) - allocate(periodic_new(mesh_cnt)) - allocate(alg_old(mesh_cnt)) - allocate(alg_new(mesh_cnt)) - alg_cnt = size(algorithms) - state_cnt = size(states_old) - assert(size(states_old) == size(states_new)) - - ! First thing: check the usual case. If all field request consistent - ! interpolation, and all fields are on linear meshes, the just pass over to - ! linear interpolation - - all_consistent_interpolation = .true. - all_linear_meshes = .true. - any_periodic_meshes = .false. - - consistent_linear_state_loop: do state=1,state_cnt - do field=1,scalar_field_count(states_old(state)) - field_s => extract_scalar_field(states_old(state), field) - ! If the field has no option path, assume consistent interpolation - if(len_trim(field_s%option_path) /= 0) then - all_consistent_interpolation = all_consistent_interpolation & - .and. have_option(trim(complete_field_path( & - field_s%option_path, stat=stat)) // "/consistent_interpolation") - - field_shape => ele_shape(field_s, 1) - all_linear_meshes = all_linear_meshes .and. (field_shape%degree == 1) .and. & - (field_shape%numbering%type==ELEMENT_LAGRANGIAN) - any_periodic_meshes = any_periodic_meshes .or. mesh_periodic(field_s) - end if - end do - - do field=1,vector_field_count(states_old(state)) - field_v => extract_vector_field(states_old(state), field) - ! If the field has no option path, assume consistent interpolation - if(len_trim(field_v%option_path) /= 0) then - if (len_trim(field_v%name) >= len_trim("Coordinate")) then - if (field_v%name(len_trim(field_v%name)-10+1:) == trim("Coordinate")) then - cycle + subroutine interpolate(states_old, states_new, map, only_owned) + !! OK! We need to figure out what algorithm to use when and where. + type(state_type), dimension(:), intent(inout) :: states_old, states_new + !! Map from new nodes to old elements + integer, dimension(:), optional, intent(in) :: map + !! Only interpolate in owned nodes + logical, optional, intent(in) :: only_owned + + ! The fields organised by mesh: + type(state_type), dimension(:), allocatable :: meshes_old, meshes_new + ! For periodic interpolation, we need to interpolate the unwrapped fields, + ! but keep the periodic fields too + type(state_type), dimension(:), allocatable :: periodic_new + ! Within each mesh, the fields organised by algorithm. + type(state_type), dimension(:), allocatable :: alg_old, alg_new + + integer :: state, state_cnt, mesh + integer :: mesh_cnt + character(len=FIELD_NAME_LEN) :: mesh_name + + type(scalar_field), pointer :: field_s, p_field_s + type(vector_field), pointer :: field_v, p_field_v + type(tensor_field), pointer :: field_t, p_field_t + integer :: field + + character(len=255), dimension(4), parameter :: algorithms = (/& + & "consistent_interpolation ", & + & "pseudo_consistent_interpolation", & + & "interpolation_galerkin ", & + & "grandy_interpolation " /) + integer :: alg_cnt, alg + + type(mesh_type), pointer :: old_mesh, new_mesh + type(vector_field) :: old_pos, new_pos + type(ilist), dimension(:), allocatable :: map_BA + + logical :: all_consistent_interpolation, all_linear_meshes, & + any_periodic_meshes + type(element_type), pointer :: field_shape + + integer :: no_fields + + integer :: stat + + ewrite(1, *) "In interpolate" + + call initialise_geostrophic_interpolation(states_old, states_new) + + mesh_cnt = option_count("/geometry/mesh") + allocate(meshes_old(mesh_cnt)) + allocate(meshes_new(mesh_cnt)) + allocate(periodic_new(mesh_cnt)) + allocate(alg_old(mesh_cnt)) + allocate(alg_new(mesh_cnt)) + alg_cnt = size(algorithms) + state_cnt = size(states_old) + assert(size(states_old) == size(states_new)) + + ! First thing: check the usual case. If all field request consistent + ! interpolation, and all fields are on linear meshes, the just pass over to + ! linear interpolation + + all_consistent_interpolation = .true. + all_linear_meshes = .true. + any_periodic_meshes = .false. + + consistent_linear_state_loop: do state=1,state_cnt + do field=1,scalar_field_count(states_old(state)) + field_s => extract_scalar_field(states_old(state), field) + ! If the field has no option path, assume consistent interpolation + if(len_trim(field_s%option_path) /= 0) then + all_consistent_interpolation = all_consistent_interpolation & + .and. have_option(trim(complete_field_path( & + field_s%option_path, stat=stat)) // "/consistent_interpolation") + + field_shape => ele_shape(field_s, 1) + all_linear_meshes = all_linear_meshes .and. (field_shape%degree == 1) .and. & + (field_shape%numbering%type==ELEMENT_LAGRANGIAN) + any_periodic_meshes = any_periodic_meshes .or. mesh_periodic(field_s) end if - end if - - all_consistent_interpolation = all_consistent_interpolation & - .and. have_option(trim(complete_field_path( & - field_v%option_path, stat=stat)) // "/consistent_interpolation") - - field_shape => ele_shape(field_v, 1) - all_linear_meshes = all_linear_meshes .and. (field_shape%degree == 1) .and. & - (field_shape%numbering%type==ELEMENT_LAGRANGIAN) - any_periodic_meshes = any_periodic_meshes .or. mesh_periodic(field_v) - end if - end do - - do field=1,tensor_field_count(states_old(state)) - field_t => extract_tensor_field(states_old(state), field) - ! If the field has no option path, assume consistent interpolation - if(len_trim(field_t%option_path) /= 0) then + end do + + do field=1,vector_field_count(states_old(state)) + field_v => extract_vector_field(states_old(state), field) + ! If the field has no option path, assume consistent interpolation + if(len_trim(field_v%option_path) /= 0) then + if (len_trim(field_v%name) >= len_trim("Coordinate")) then + if (field_v%name(len_trim(field_v%name)-10+1:) == trim("Coordinate")) then + cycle + end if + end if + + all_consistent_interpolation = all_consistent_interpolation & + .and. have_option(trim(complete_field_path( & + field_v%option_path, stat=stat)) // "/consistent_interpolation") + + field_shape => ele_shape(field_v, 1) + all_linear_meshes = all_linear_meshes .and. (field_shape%degree == 1) .and. & + (field_shape%numbering%type==ELEMENT_LAGRANGIAN) + any_periodic_meshes = any_periodic_meshes .or. mesh_periodic(field_v) + end if + end do - all_consistent_interpolation = all_consistent_interpolation & - .and. have_option(trim(complete_field_path( & - field_t%option_path, stat=stat)) // "/consistent_interpolation") + do field=1,tensor_field_count(states_old(state)) + field_t => extract_tensor_field(states_old(state), field) + ! If the field has no option path, assume consistent interpolation + if(len_trim(field_t%option_path) /= 0) then - field_shape => ele_shape(field_t, 1) - all_linear_meshes = all_linear_meshes .and. (field_shape%degree == 1) .and. & - (field_shape%numbering%type==ELEMENT_LAGRANGIAN) - any_periodic_meshes = any_periodic_meshes .or. mesh_periodic(field_t) - end if - end do + all_consistent_interpolation = all_consistent_interpolation & + .and. have_option(trim(complete_field_path( & + field_t%option_path, stat=stat)) // "/consistent_interpolation") - end do consistent_linear_state_loop + field_shape => ele_shape(field_t, 1) + all_linear_meshes = all_linear_meshes .and. (field_shape%degree == 1) .and. & + (field_shape%numbering%type==ELEMENT_LAGRANGIAN) + any_periodic_meshes = any_periodic_meshes .or. mesh_periodic(field_t) + end if + end do - if(all_consistent_interpolation & - .and. all_linear_meshes .and. .not. any_periodic_meshes) then - ewrite(2, *) "All fields are on linear meshes and use consistent interpolation" + end do consistent_linear_state_loop - call tictoc_clear(TICTOC_ID_INTERPOLATION) - call tic(TICTOC_ID_INTERPOLATION) + if(all_consistent_interpolation & + .and. all_linear_meshes .and. .not. any_periodic_meshes) then + ewrite(2, *) "All fields are on linear meshes and use consistent interpolation" - ! Assuming here that "map" is for the linear mesh - call linear_interpolate_states(states_old, states_new, map = map, only_owned=only_owned) + call tictoc_clear(TICTOC_ID_INTERPOLATION) + call tic(TICTOC_ID_INTERPOLATION) - call toc(TICTOC_ID_INTERPOLATION) - call tictoc_report(2, TICTOC_ID_INTERPOLATION) + ! Assuming here that "map" is for the linear mesh + call linear_interpolate_states(states_old, states_new, map = map, only_owned=only_owned) - ewrite(1, *) "Exiting interpolate" + call toc(TICTOC_ID_INTERPOLATION) + call tictoc_report(2, TICTOC_ID_INTERPOLATION) - return - end if + ewrite(1, *) "Exiting interpolate" - ewrite(2, *) "Not all fields are on linear meshes and use consistent interpolation" - ewrite(2, *) "Gathering fields for more general interpolation" + return + end if - old_pos = extract_vector_field(states_old(1), "Coordinate") - new_pos = extract_vector_field(states_new(1), "Coordinate") + ewrite(2, *) "Not all fields are on linear meshes and use consistent interpolation" + ewrite(2, *) "Gathering fields for more general interpolation" - ! OK! So we have some work to do. - ! First, let's organise the fields according to what mesh - ! they are on. - do mesh=1,mesh_cnt + old_pos = extract_vector_field(states_old(1), "Coordinate") + new_pos = extract_vector_field(states_new(1), "Coordinate") - call get_option("/geometry/mesh["//int2str(mesh-1)//"]/name", mesh_name) + ! OK! So we have some work to do. + ! First, let's organise the fields according to what mesh + ! they are on. + do mesh=1,mesh_cnt - do state=1,state_cnt - do field=1,scalar_field_count(states_old(state)) - field_s => extract_scalar_field(states_old(state), field) - if(.not. has_scalar_field(states_new(state), field_s%name)) then - ewrite(0, *) "Warning: Cannot interpolate field " // trim(field_s%name) // " - no target" - cycle - end if - if (trim(field_s%mesh%name) == trim(mesh_name)) then - ! we need to append the state name here to make this safe for - ! multi-material_phase/state... let's just hope you aren't going - ! to try to pull this out of state by its name! - call insert(meshes_old(mesh), field_s, trim(states_new(state)%name)//"::"//trim(field_s%name)) - field_s => extract_scalar_field(states_new(state), trim(field_s%name)) - ! we need to append the state name here to make this safe for - ! multi-material_phase/state... let's just hope you aren't going - ! to try to pull this out of state by its name! - call insert(meshes_new(mesh), field_s, trim(states_new(state)%name)//"::"//trim(field_s%name)) - end if - end do - - do field=1,vector_field_count(states_old(state)) - field_v => extract_vector_field(states_old(state), field) - if(.not. has_vector_field(states_new(state), field_v%name)) then - ewrite(0, *) "Warning: Cannot interpolate field " // trim(field_v%name) // " - no target" - cycle - end if - if (trim(field_v%mesh%name) == trim(mesh_name)) then - if (field_v%name=="Coordinate" .or. field_v%name==trim(mesh_name)//"Coordinate") cycle - ! we need to append the state name here to make this safe for - ! multi-material_phase/state... let's just hope you aren't going - ! to try to pull this out of state by its name! - call insert(meshes_old(mesh), field_v, trim(states_new(state)%name)//"::"//trim(field_v%name)) - field_v => extract_vector_field(states_new(state), trim(field_v%name)) - ! we need to append the state name here to make this safe for - ! multi-material_phase/state... let's just hope you aren't going - ! to try to pull this out of state by its name! - call insert(meshes_new(mesh), field_v, trim(states_new(state)%name)//"::"//trim(field_v%name)) - end if - end do - - do field=1,tensor_field_count(states_old(state)) - field_t => extract_tensor_field(states_old(state), field) - if(.not. has_tensor_field(states_new(state), field_t%name)) then - ewrite(0, *) "Warning: Cannot interpolate field " // trim(field_t%name) // " - no target" - cycle - end if - if (trim(field_t%mesh%name) == trim(mesh_name)) then - ! we need to append the state name here to make this safe for - ! multi-material_phase/state... let's just hope you aren't going - ! to try to pull this out of state by its name! - call insert(meshes_old(mesh), field_t, trim(states_new(state)%name)//"::"//trim(field_t%name)) - field_t => extract_tensor_field(states_new(state), trim(field_t%name)) - ! we need to append the state name here to make this safe for - ! multi-material_phase/state... let's just hope you aren't going - ! to try to pull this out of state by its name! - call insert(meshes_new(mesh), field_t, trim(states_new(state)%name)//"::"//trim(field_t%name)) - end if - end do + call get_option("/geometry/mesh["//int2str(mesh-1)//"]/name", mesh_name) + + do state=1,state_cnt + do field=1,scalar_field_count(states_old(state)) + field_s => extract_scalar_field(states_old(state), field) + if(.not. has_scalar_field(states_new(state), field_s%name)) then + ewrite(0, *) "Warning: Cannot interpolate field " // trim(field_s%name) // " - no target" + cycle + end if + if (trim(field_s%mesh%name) == trim(mesh_name)) then + ! we need to append the state name here to make this safe for + ! multi-material_phase/state... let's just hope you aren't going + ! to try to pull this out of state by its name! + call insert(meshes_old(mesh), field_s, trim(states_new(state)%name)//"::"//trim(field_s%name)) + field_s => extract_scalar_field(states_new(state), trim(field_s%name)) + ! we need to append the state name here to make this safe for + ! multi-material_phase/state... let's just hope you aren't going + ! to try to pull this out of state by its name! + call insert(meshes_new(mesh), field_s, trim(states_new(state)%name)//"::"//trim(field_s%name)) + end if + end do + + do field=1,vector_field_count(states_old(state)) + field_v => extract_vector_field(states_old(state), field) + if(.not. has_vector_field(states_new(state), field_v%name)) then + ewrite(0, *) "Warning: Cannot interpolate field " // trim(field_v%name) // " - no target" + cycle + end if + if (trim(field_v%mesh%name) == trim(mesh_name)) then + if (field_v%name=="Coordinate" .or. field_v%name==trim(mesh_name)//"Coordinate") cycle + ! we need to append the state name here to make this safe for + ! multi-material_phase/state... let's just hope you aren't going + ! to try to pull this out of state by its name! + call insert(meshes_old(mesh), field_v, trim(states_new(state)%name)//"::"//trim(field_v%name)) + field_v => extract_vector_field(states_new(state), trim(field_v%name)) + ! we need to append the state name here to make this safe for + ! multi-material_phase/state... let's just hope you aren't going + ! to try to pull this out of state by its name! + call insert(meshes_new(mesh), field_v, trim(states_new(state)%name)//"::"//trim(field_v%name)) + end if + end do + + do field=1,tensor_field_count(states_old(state)) + field_t => extract_tensor_field(states_old(state), field) + if(.not. has_tensor_field(states_new(state), field_t%name)) then + ewrite(0, *) "Warning: Cannot interpolate field " // trim(field_t%name) // " - no target" + cycle + end if + if (trim(field_t%mesh%name) == trim(mesh_name)) then + ! we need to append the state name here to make this safe for + ! multi-material_phase/state... let's just hope you aren't going + ! to try to pull this out of state by its name! + call insert(meshes_old(mesh), field_t, trim(states_new(state)%name)//"::"//trim(field_t%name)) + field_t => extract_tensor_field(states_new(state), trim(field_t%name)) + ! we need to append the state name here to make this safe for + ! multi-material_phase/state... let's just hope you aren't going + ! to try to pull this out of state by its name! + call insert(meshes_new(mesh), field_t, trim(states_new(state)%name)//"::"//trim(field_t%name)) + end if + end do + + end do + + old_mesh => extract_mesh(states_old(1), trim(mesh_name)) + call insert(meshes_old(mesh), old_mesh, "Mesh") + + new_mesh => extract_mesh(states_new(1), trim(mesh_name)) + call insert(meshes_new(mesh), new_mesh, "Mesh") + + call insert(meshes_old(mesh), old_pos, "Coordinate") + call insert(meshes_new(mesh), new_pos, "Coordinate") + + if (mesh_periodic(new_mesh)) then + + ! Nice work, soldier! Now if the mesh is periodic we need to expand the mesh in the plane, + ! as if we've adapted the domain edges won't match up, will they? + + ! first we keep a copy of meshes_new + do field=1,scalar_field_count(meshes_new(mesh)) + field_s => extract_scalar_field(meshes_new(mesh), field) + call insert(periodic_new(mesh), field_s, trim(field_s%name)) + end do + + do field=1,vector_field_count(meshes_new(mesh)) + field_v => extract_vector_field(meshes_new(mesh), field) + call insert(periodic_new(mesh), field_v, trim(field_v%name)) + end do + + do field=1,tensor_field_count(meshes_new(mesh)) + field_t => extract_tensor_field(meshes_new(mesh), field) + call insert(periodic_new(mesh), field_t, trim(field_t%name)) + end do + + ! create an expanded, non-periodic version of meshes_old + ! and a non-periodic version of meshes_new, and remap all fields + ! to it + call prepare_periodic_states_for_interpolation(meshes_old(mesh), meshes_new(mesh)) + end if end do - old_mesh => extract_mesh(states_old(1), trim(mesh_name)) - call insert(meshes_old(mesh), old_mesh, "Mesh") - - new_mesh => extract_mesh(states_new(1), trim(mesh_name)) - call insert(meshes_new(mesh), new_mesh, "Mesh") - - call insert(meshes_old(mesh), old_pos, "Coordinate") - call insert(meshes_new(mesh), new_pos, "Coordinate") - - if (mesh_periodic(new_mesh)) then - - ! Nice work, soldier! Now if the mesh is periodic we need to expand the mesh in the plane, - ! as if we've adapted the domain edges won't match up, will they? - - ! first we keep a copy of meshes_new - do field=1,scalar_field_count(meshes_new(mesh)) - field_s => extract_scalar_field(meshes_new(mesh), field) - call insert(periodic_new(mesh), field_s, trim(field_s%name)) - end do - - do field=1,vector_field_count(meshes_new(mesh)) - field_v => extract_vector_field(meshes_new(mesh), field) - call insert(periodic_new(mesh), field_v, trim(field_v%name)) - end do + ! Great! Now let's loop over the fields associated with each mesh + ! and group them by algorithm. + + alg_loop: do alg = 1, alg_cnt + ewrite(2, *) " Considering algorithm " // trim(algorithms(alg)) + + call tictoc_clear(TICTOC_ID_INTERPOLATION) + call tic(TICTOC_ID_INTERPOLATION) + + select case(trim(algorithms(alg))) + case("consistent_interpolation") + do mesh = 1, mesh_cnt + call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) + old_mesh => extract_mesh(states_old(1), trim(mesh_name)) + new_mesh => extract_mesh(states_new(1), trim(mesh_name)) + old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") + new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") + + call insert(alg_old(mesh), old_mesh, "Mesh") + call insert(alg_new(mesh), new_mesh, "Mesh") + call insert(alg_old(mesh), old_pos, "Coordinate") + call insert(alg_new(mesh), new_pos, "Coordinate") + + call collect_fields_to_interpolate(interpolate_field_consistent, meshes_new(mesh), meshes_old(mesh), alg_new(mesh), alg_old(mesh)) + + if(field_count(alg_old(mesh)) > 1) then + if(present(map)) then + ! Cannot assume here that "map" applies for new_mesh (as + ! new_mesh may have any degree) + if(size(map) == node_count(new_mesh)) then + call linear_interpolation(alg_old(mesh), alg_new(mesh), map = map, only_owned=only_owned) + else + call linear_interpolation(alg_old(mesh), alg_new(mesh), only_owned=only_owned) + end if + else + call linear_interpolation(alg_old(mesh), alg_new(mesh), only_owned=only_owned) + end if + end if + + call deallocate(alg_old(mesh)) + call deallocate(alg_new(mesh)) + end do + case("pseudo_consistent_interpolation") + do mesh = 1, mesh_cnt + call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) + old_mesh => extract_mesh(states_old(1), trim(mesh_name)) + new_mesh => extract_mesh(states_new(1), trim(mesh_name)) + old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") + new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") + + call insert(alg_old(mesh), old_mesh, "Mesh") + call insert(alg_new(mesh), new_mesh, "Mesh") + call insert(alg_old(mesh), old_pos, "Coordinate") + call insert(alg_new(mesh), new_pos, "Coordinate") + + call collect_fields_to_interpolate(interpolate_field_pseudo_consistent, meshes_new(mesh), meshes_old(mesh), alg_new(mesh), alg_old(mesh)) + + if(field_count(alg_old(mesh)) > 1) then + call pseudo_consistent_interpolate(alg_old(mesh), alg_new(mesh)) + end if + + call deallocate(alg_old(mesh)) + call deallocate(alg_new(mesh)) + end do + case("interpolation_galerkin") + if(.not. allocated(map_BA)) then + allocate(map_BA(ele_count(new_pos))) + map_BA = intersection_finder(new_pos, old_pos) + end if - do field=1,tensor_field_count(meshes_new(mesh)) - field_t => extract_tensor_field(meshes_new(mesh), field) - call insert(periodic_new(mesh), field_t, trim(field_t%name)) - end do + do mesh = 1, mesh_cnt + call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) + old_mesh => extract_mesh(states_old(1), trim(mesh_name)) + new_mesh => extract_mesh(states_new(1), trim(mesh_name)) + old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") + new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") + + call insert(alg_old(mesh), old_mesh, "Mesh") + call insert(alg_new(mesh), new_mesh, "Mesh") + call insert(alg_old(mesh), old_pos, "Coordinate") + call insert(alg_new(mesh), new_pos, "Coordinate") + end do + + call collect_fields_to_interpolate(interpolate_field_galerkin_projection, meshes_new, meshes_old, alg_new, alg_old) + + no_fields = 0 + do mesh = 1, mesh_cnt + no_fields = no_fields + field_count(alg_old(mesh)) + end do + if(no_fields > mesh_cnt) then ! there will always be a Coordinate per mesh + assert(allocated(map_BA)) + call interpolation_galerkin(alg_old, alg_new, map_BA = map_BA) + end if - ! create an expanded, non-periodic version of meshes_old - ! and a non-periodic version of meshes_new, and remap all fields - ! to it - call prepare_periodic_states_for_interpolation(meshes_old(mesh), meshes_new(mesh)) - end if + do mesh=1,mesh_cnt + call deallocate(alg_old(mesh)) + call deallocate(alg_new(mesh)) + end do + case("grandy_interpolation") + if(.not. allocated(map_BA)) then + allocate(map_BA(ele_count(new_pos))) + map_BA = intersection_finder(new_pos, old_pos) + end if - end do + do mesh = 1, mesh_cnt + call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) + old_mesh => extract_mesh(states_old(1), trim(mesh_name)) + new_mesh => extract_mesh(states_new(1), trim(mesh_name)) + old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") + new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") + + call insert(alg_old(mesh), old_mesh, "Mesh") + call insert(alg_new(mesh), new_mesh, "Mesh") + call insert(alg_old(mesh), old_pos, "Coordinate") + call insert(alg_new(mesh), new_pos, "Coordinate") + end do + + call collect_fields_to_interpolate(interpolate_field_grandy_interpolation, meshes_new, meshes_old, alg_new, alg_old) + + no_fields = 0 + do mesh = 1, mesh_cnt + no_fields = no_fields + field_count(alg_old(mesh)) + end do + if(no_fields > mesh_cnt) then ! there will always be a Coordinate per mesh + assert(allocated(map_BA)) + call grandy_projection(alg_old, alg_new, map_BA = map_BA) + end if - ! Great! Now let's loop over the fields associated with each mesh - ! and group them by algorithm. + do mesh=1,mesh_cnt + call deallocate(alg_old(mesh)) + call deallocate(alg_new(mesh)) + end do - alg_loop: do alg = 1, alg_cnt - ewrite(2, *) " Considering algorithm " // trim(algorithms(alg)) + case("no_interpolation") + ! nothing to be done obviously + case default + FLAbort("Unrecognised interpolation algorithm") + end select - call tictoc_clear(TICTOC_ID_INTERPOLATION) - call tic(TICTOC_ID_INTERPOLATION) + call toc(TICTOC_ID_INTERPOLATION) + call tictoc_report(2, TICTOC_ID_INTERPOLATION) - select case(trim(algorithms(alg))) - case("consistent_interpolation") - do mesh = 1, mesh_cnt - call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) - old_mesh => extract_mesh(states_old(1), trim(mesh_name)) - new_mesh => extract_mesh(states_new(1), trim(mesh_name)) - old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") - new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") - - call insert(alg_old(mesh), old_mesh, "Mesh") - call insert(alg_new(mesh), new_mesh, "Mesh") - call insert(alg_old(mesh), old_pos, "Coordinate") - call insert(alg_new(mesh), new_pos, "Coordinate") - - call collect_fields_to_interpolate(interpolate_field_consistent, meshes_new(mesh), meshes_old(mesh), alg_new(mesh), alg_old(mesh)) - - if(field_count(alg_old(mesh)) > 1) then - if(present(map)) then - ! Cannot assume here that "map" applies for new_mesh (as - ! new_mesh may have any degree) - if(size(map) == node_count(new_mesh)) then - call linear_interpolation(alg_old(mesh), alg_new(mesh), map = map, only_owned=only_owned) - else - call linear_interpolation(alg_old(mesh), alg_new(mesh), only_owned=only_owned) - end if - else - call linear_interpolation(alg_old(mesh), alg_new(mesh), only_owned=only_owned) - end if - end if + end do alg_loop - call deallocate(alg_old(mesh)) - call deallocate(alg_new(mesh)) - end do - case("pseudo_consistent_interpolation") - do mesh = 1, mesh_cnt - call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) + if (any_periodic_meshes) then + do mesh=1,mesh_cnt + call get_option("/geometry/mesh["//int2str(mesh-1)//"]/name", mesh_name) old_mesh => extract_mesh(states_old(1), trim(mesh_name)) - new_mesh => extract_mesh(states_new(1), trim(mesh_name)) - old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") - new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") - - call insert(alg_old(mesh), old_mesh, "Mesh") - call insert(alg_new(mesh), new_mesh, "Mesh") - call insert(alg_old(mesh), old_pos, "Coordinate") - call insert(alg_new(mesh), new_pos, "Coordinate") - - call collect_fields_to_interpolate(interpolate_field_pseudo_consistent, meshes_new(mesh), meshes_old(mesh), alg_new(mesh), alg_old(mesh)) - if(field_count(alg_old(mesh)) > 1) then - call pseudo_consistent_interpolate(alg_old(mesh), alg_new(mesh)) - end if + if (.not. mesh_periodic(old_mesh)) cycle + + ! If we are periodic, we have interpolated the unwrapped version + ! So let's remap to the periodic one we actually need + do field=1,scalar_field_count(meshes_new(mesh)) + field_s => extract_scalar_field(meshes_new(mesh), field) + p_field_s => extract_scalar_field(periodic_new(mesh), trim(field_s%name)) + assert(trim(field_s%name) == trim(p_field_s%name)) + call remap_field(field_s, p_field_s, stat=stat) + end do + + do field=1,vector_field_count(meshes_new(mesh)) + field_v => extract_vector_field(meshes_new(mesh), field) + if (trim(field_v%name) == "Coordinate") cycle + p_field_v => extract_vector_field(periodic_new(mesh), trim(field_v%name)) + assert(trim(field_v%name) == trim(p_field_v%name)) + call remap_field(field_v, p_field_v, stat=stat) + end do + + do field=1,tensor_field_count(meshes_new(mesh)) + field_t => extract_tensor_field(meshes_new(mesh), field) + p_field_t => extract_tensor_field(periodic_new(mesh), trim(field_t%name)) + assert(trim(field_t%name) == trim(p_field_t%name)) + call remap_field(field_t, p_field_t, stat=stat) + end do + + call deallocate(periodic_new(mesh)) + end do + end if - call deallocate(alg_old(mesh)) - call deallocate(alg_new(mesh)) - end do - case("interpolation_galerkin") - if(.not. allocated(map_BA)) then - allocate(map_BA(ele_count(new_pos))) - map_BA = intersection_finder(new_pos, old_pos) - end if - - do mesh = 1, mesh_cnt - call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) - old_mesh => extract_mesh(states_old(1), trim(mesh_name)) - new_mesh => extract_mesh(states_new(1), trim(mesh_name)) - old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") - new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") - - call insert(alg_old(mesh), old_mesh, "Mesh") - call insert(alg_new(mesh), new_mesh, "Mesh") - call insert(alg_old(mesh), old_pos, "Coordinate") - call insert(alg_new(mesh), new_pos, "Coordinate") - end do - - call collect_fields_to_interpolate(interpolate_field_galerkin_projection, meshes_new, meshes_old, alg_new, alg_old) - - no_fields = 0 - do mesh = 1, mesh_cnt - no_fields = no_fields + field_count(alg_old(mesh)) - end do - if(no_fields > mesh_cnt) then ! there will always be a Coordinate per mesh - assert(allocated(map_BA)) - call interpolation_galerkin(alg_old, alg_new, map_BA = map_BA) - end if - - do mesh=1,mesh_cnt - call deallocate(alg_old(mesh)) - call deallocate(alg_new(mesh)) - end do - case("grandy_interpolation") - if(.not. allocated(map_BA)) then - allocate(map_BA(ele_count(new_pos))) - map_BA = intersection_finder(new_pos, old_pos) - end if - - do mesh = 1, mesh_cnt - call get_option("/geometry/mesh[" // int2str(mesh - 1) // "]/name", mesh_name) - old_mesh => extract_mesh(states_old(1), trim(mesh_name)) - new_mesh => extract_mesh(states_new(1), trim(mesh_name)) - old_pos = extract_vector_field(meshes_old(mesh), "Coordinate") - new_pos = extract_vector_field(meshes_new(mesh), "Coordinate") - - call insert(alg_old(mesh), old_mesh, "Mesh") - call insert(alg_new(mesh), new_mesh, "Mesh") - call insert(alg_old(mesh), old_pos, "Coordinate") - call insert(alg_new(mesh), new_pos, "Coordinate") - end do - - call collect_fields_to_interpolate(interpolate_field_grandy_interpolation, meshes_new, meshes_old, alg_new, alg_old) - - no_fields = 0 - do mesh = 1, mesh_cnt - no_fields = no_fields + field_count(alg_old(mesh)) - end do - if(no_fields > mesh_cnt) then ! there will always be a Coordinate per mesh - assert(allocated(map_BA)) - call grandy_projection(alg_old, alg_new, map_BA = map_BA) - end if - - do mesh=1,mesh_cnt - call deallocate(alg_old(mesh)) - call deallocate(alg_new(mesh)) - end do - - case("no_interpolation") - ! nothing to be done obviously - case default - FLAbort("Unrecognised interpolation algorithm") - end select - - call toc(TICTOC_ID_INTERPOLATION) - call tictoc_report(2, TICTOC_ID_INTERPOLATION) - - end do alg_loop - - if (any_periodic_meshes) then - do mesh=1,mesh_cnt - call get_option("/geometry/mesh["//int2str(mesh-1)//"]/name", mesh_name) - old_mesh => extract_mesh(states_old(1), trim(mesh_name)) - - if (.not. mesh_periodic(old_mesh)) cycle - - ! If we are periodic, we have interpolated the unwrapped version - ! So let's remap to the periodic one we actually need - do field=1,scalar_field_count(meshes_new(mesh)) - field_s => extract_scalar_field(meshes_new(mesh), field) - p_field_s => extract_scalar_field(periodic_new(mesh), trim(field_s%name)) - assert(trim(field_s%name) == trim(p_field_s%name)) - call remap_field(field_s, p_field_s, stat=stat) - end do - - do field=1,vector_field_count(meshes_new(mesh)) - field_v => extract_vector_field(meshes_new(mesh), field) - if (trim(field_v%name) == "Coordinate") cycle - p_field_v => extract_vector_field(periodic_new(mesh), trim(field_v%name)) - assert(trim(field_v%name) == trim(p_field_v%name)) - call remap_field(field_v, p_field_v, stat=stat) - end do - - do field=1,tensor_field_count(meshes_new(mesh)) - field_t => extract_tensor_field(meshes_new(mesh), field) - p_field_t => extract_tensor_field(periodic_new(mesh), trim(field_t%name)) - assert(trim(field_t%name) == trim(p_field_t%name)) - call remap_field(field_t, p_field_t, stat=stat) - end do - - call deallocate(periodic_new(mesh)) + do mesh=1, mesh_cnt + call deallocate(meshes_old(mesh)) + call deallocate(meshes_new(mesh)) end do - end if - do mesh=1, mesh_cnt - call deallocate(meshes_old(mesh)) - call deallocate(meshes_new(mesh)) - end do + deallocate(meshes_old) + deallocate(meshes_new) + deallocate(periodic_new) - deallocate(meshes_old) - deallocate(meshes_new) - deallocate(periodic_new) + deallocate(alg_old) + deallocate(alg_new) - deallocate(alg_old) - deallocate(alg_new) - - if(allocated(map_BA)) then - call deallocate(map_BA) - deallocate(map_BA) - end if + if(allocated(map_BA)) then + call deallocate(map_BA) + deallocate(map_BA) + end if - call finalise_geostrophic_interpolation(states_new) + call finalise_geostrophic_interpolation(states_new) - ewrite(1, *) "Exiting interpolate" + ewrite(1, *) "Exiting interpolate" - end subroutine interpolate + end subroutine interpolate - function interpolate_field_consistent(option_path) result(interpolate) - character(len = *), intent(in) :: option_path + function interpolate_field_consistent(option_path) result(interpolate) + character(len = *), intent(in) :: option_path - logical :: interpolate + logical :: interpolate - integer :: stat + integer :: stat - interpolate = .false. - if(len_trim(option_path) == 0) then - interpolate = .true. - else if(have_option(trim(complete_field_path(option_path, stat = stat)) // "/consistent_interpolation")) then - interpolate = .true. - end if + interpolate = .false. + if(len_trim(option_path) == 0) then + interpolate = .true. + else if(have_option(trim(complete_field_path(option_path, stat = stat)) // "/consistent_interpolation")) then + interpolate = .true. + end if - end function interpolate_field_consistent + end function interpolate_field_consistent - function interpolate_field_pseudo_consistent(option_path) result(interpolate) - character(len = *), intent(in) :: option_path + function interpolate_field_pseudo_consistent(option_path) result(interpolate) + character(len = *), intent(in) :: option_path - logical :: interpolate + logical :: interpolate - integer :: stat + integer :: stat - interpolate = .false. - if(have_option(trim(complete_field_path(option_path, stat = stat)) // "/pseudo_consistent_interpolation")) then - interpolate = .true. - end if + interpolate = .false. + if(have_option(trim(complete_field_path(option_path, stat = stat)) // "/pseudo_consistent_interpolation")) then + interpolate = .true. + end if - end function interpolate_field_pseudo_consistent + end function interpolate_field_pseudo_consistent - function interpolate_field_galerkin_projection(option_path) result(interpolate) - character(len = *), intent(in) :: option_path + function interpolate_field_galerkin_projection(option_path) result(interpolate) + character(len = *), intent(in) :: option_path - logical :: interpolate + logical :: interpolate - character(len = OPTION_PATH_LEN) :: base_path - integer :: stat + character(len = OPTION_PATH_LEN) :: base_path + integer :: stat - interpolate = .false. - if(len_trim(option_path) == 0) return + interpolate = .false. + if(len_trim(option_path) == 0) return - base_path = trim(complete_field_path(option_path, stat = stat)) + base_path = trim(complete_field_path(option_path, stat = stat)) - interpolate = have_option(trim(base_path) // "/galerkin_projection") & + interpolate = have_option(trim(base_path) // "/galerkin_projection") & & .and. .not. have_option(trim(base_path) // "/galerkin_projection/supermesh_free") - end function interpolate_field_galerkin_projection + end function interpolate_field_galerkin_projection - function interpolate_field_grandy_interpolation(option_path) result(interpolate) - character(len = *), intent(in) :: option_path + function interpolate_field_grandy_interpolation(option_path) result(interpolate) + character(len = *), intent(in) :: option_path - logical :: interpolate + logical :: interpolate - character(len = OPTION_PATH_LEN) :: base_path - integer :: stat + character(len = OPTION_PATH_LEN) :: base_path + integer :: stat - interpolate = .false. - if(len_trim(option_path) == 0) return + interpolate = .false. + if(len_trim(option_path) == 0) return - base_path = trim(complete_field_path(option_path, stat = stat)) + base_path = trim(complete_field_path(option_path, stat = stat)) - interpolate = have_option(trim(base_path) // "/grandy_interpolation") - end function interpolate_field_grandy_interpolation + interpolate = have_option(trim(base_path) // "/grandy_interpolation") + end function interpolate_field_grandy_interpolation - function interpolate_field_galerkin_projection_cg_supermesh_free(option_path) result(interpolate) - character(len = *), intent(in) :: option_path + function interpolate_field_galerkin_projection_cg_supermesh_free(option_path) result(interpolate) + character(len = *), intent(in) :: option_path - logical :: interpolate + logical :: interpolate - character(len = OPTION_PATH_LEN) :: base_path - integer :: stat + character(len = OPTION_PATH_LEN) :: base_path + integer :: stat - interpolate = .false. - if(len_trim(option_path) == 0) return + interpolate = .false. + if(len_trim(option_path) == 0) return - base_path = trim(complete_field_path(option_path, stat = stat)) + base_path = trim(complete_field_path(option_path, stat = stat)) - interpolate = have_option(trim(base_path) // "/galerkin_projection/continuous") & + interpolate = have_option(trim(base_path) // "/galerkin_projection/continuous") & & .and. have_option(trim(base_path) // "/galerkin_projection/supermesh_free") #ifdef DDEBUG - if(interpolate) then - assert(.not. have_option(trim(base_path) // "/galerkin_projection/continuous/bounded")) - end if + if(interpolate) then + assert(.not. have_option(trim(base_path) // "/galerkin_projection/continuous/bounded")) + end if #endif - end function interpolate_field_galerkin_projection_cg_supermesh_free + end function interpolate_field_galerkin_projection_cg_supermesh_free - function interpolate_field_galerkin_projection_dg_supermesh_free(option_path) result(interpolate) - character(len = *), intent(in) :: option_path + function interpolate_field_galerkin_projection_dg_supermesh_free(option_path) result(interpolate) + character(len = *), intent(in) :: option_path - logical :: interpolate + logical :: interpolate - character(len = OPTION_PATH_LEN) :: base_path - integer :: stat + character(len = OPTION_PATH_LEN) :: base_path + integer :: stat - interpolate = .false. - if(len_trim(option_path) == 0) return + interpolate = .false. + if(len_trim(option_path) == 0) return - base_path = trim(complete_field_path(option_path, stat = stat)) + base_path = trim(complete_field_path(option_path, stat = stat)) - interpolate = have_option(trim(base_path) // "/galerkin_projection/discontinuous") & + interpolate = have_option(trim(base_path) // "/galerkin_projection/discontinuous") & & .and. have_option(trim(base_path) // "/galerkin_projection/supermesh_free") - end function interpolate_field_galerkin_projection_dg_supermesh_free - - subroutine collect_fields_to_interpolate_single_state(test, input_state_new, input_state_old, output_state_new, output_state_old) - interface - function test(option_path) - implicit none - character(len = *), intent(in) :: option_path - logical :: test - end function test - end interface - type(state_type), intent(inout) :: input_state_new - type(state_type), intent(inout) :: input_state_old - type(state_type), intent(inout) :: output_state_new - type(state_type), intent(inout) :: output_state_old - - type(state_type), dimension(1) :: input_states_new - type(state_type), dimension(1) :: input_states_old - type(state_type), dimension(1) :: output_states_new - type(state_type), dimension(1) :: output_states_old - - input_states_new = (/input_state_new/) - input_states_old = (/input_state_old/) - output_states_new = (/output_state_new/) - output_states_old = (/output_state_old/) - - call collect_fields_to_interpolate(test, input_states_new, input_states_old, output_states_new, output_states_old) - - input_state_new = input_states_new(1) - input_state_old = input_states_old(1) - output_state_new = output_states_new(1) - output_state_old = output_states_old(1) - - end subroutine collect_fields_to_interpolate_single_state - - subroutine collect_fields_to_interpolate_multiple_states(test, input_states_new, input_states_old, output_states_new, output_states_old) - !!< Collect all fields in the supplied input_old and input_new states that - !!< pass the supplied tests, and insert them into output_state_new and - !!< output_state_old - - interface - function test(option_path) - implicit none - character(len = *), intent(in) :: option_path - logical :: test - end function test - end interface - type(state_type), dimension(:), intent(in) :: input_states_new - type(state_type), dimension(:), intent(in) :: input_states_old - type(state_type), dimension(:), intent(inout) :: output_states_new - type(state_type), dimension(:), intent(inout) :: output_states_old - - integer :: i, j - type(scalar_field), pointer :: s_field_new, s_field_old - type(tensor_field), pointer :: t_field_new, t_field_old - type(vector_field), pointer :: v_field_new , v_field_old + end function interpolate_field_galerkin_projection_dg_supermesh_free + + subroutine collect_fields_to_interpolate_single_state(test, input_state_new, input_state_old, output_state_new, output_state_old) + interface + function test(option_path) + implicit none + character(len = *), intent(in) :: option_path + logical :: test + end function test + end interface + type(state_type), intent(inout) :: input_state_new + type(state_type), intent(inout) :: input_state_old + type(state_type), intent(inout) :: output_state_new + type(state_type), intent(inout) :: output_state_old + + type(state_type), dimension(1) :: input_states_new + type(state_type), dimension(1) :: input_states_old + type(state_type), dimension(1) :: output_states_new + type(state_type), dimension(1) :: output_states_old + + input_states_new = (/input_state_new/) + input_states_old = (/input_state_old/) + output_states_new = (/output_state_new/) + output_states_old = (/output_state_old/) + + call collect_fields_to_interpolate(test, input_states_new, input_states_old, output_states_new, output_states_old) + + input_state_new = input_states_new(1) + input_state_old = input_states_old(1) + output_state_new = output_states_new(1) + output_state_old = output_states_old(1) + + end subroutine collect_fields_to_interpolate_single_state + + subroutine collect_fields_to_interpolate_multiple_states(test, input_states_new, input_states_old, output_states_new, output_states_old) + !!< Collect all fields in the supplied input_old and input_new states that + !!< pass the supplied tests, and insert them into output_state_new and + !!< output_state_old + + interface + function test(option_path) + implicit none + character(len = *), intent(in) :: option_path + logical :: test + end function test + end interface + type(state_type), dimension(:), intent(in) :: input_states_new + type(state_type), dimension(:), intent(in) :: input_states_old + type(state_type), dimension(:), intent(inout) :: output_states_new + type(state_type), dimension(:), intent(inout) :: output_states_old + + integer :: i, j + type(scalar_field), pointer :: s_field_new, s_field_old + type(tensor_field), pointer :: t_field_new, t_field_old + type(vector_field), pointer :: v_field_new , v_field_old #ifdef DDEBUG - assert(size(input_states_new)==size(input_states_old)) - assert(size(output_states_new)==size(output_states_old)) - assert(size(input_states_new)==size(output_states_new)) + assert(size(input_states_new)==size(input_states_old)) + assert(size(output_states_new)==size(output_states_old)) + assert(size(input_states_new)==size(output_states_new)) #endif - do j = 1, size(input_states_new) + do j = 1, size(input_states_new) - assert(scalar_field_count(input_states_new(j)) == scalar_field_count(input_states_old(j))) + assert(scalar_field_count(input_states_new(j)) == scalar_field_count(input_states_old(j))) - do i = 1, scalar_field_count(input_states_new(j)) - s_field_new => extract_scalar_field(input_states_new(j), i) - s_field_old => extract_scalar_field(input_states_old(j), i) + do i = 1, scalar_field_count(input_states_new(j)) + s_field_new => extract_scalar_field(input_states_new(j), i) + s_field_old => extract_scalar_field(input_states_old(j), i) #ifdef DDEBUG - assert(trim(s_field_new%name) == trim(s_field_old%name)) - assert(trim(s_field_new%option_path) == trim(s_field_old%option_path)) + assert(trim(s_field_new%name) == trim(s_field_old%name)) + assert(trim(s_field_new%option_path) == trim(s_field_old%option_path)) #endif - if(.not.aliased(s_field_new).and.test(s_field_new%option_path)) then - ewrite(2, *) " Found ", trim(s_field_new%name) - ! make sure we keep the multi-material_phase/state safe names from state - call insert(output_states_new(j), s_field_new, trim(input_states_new(j)%scalar_names(i))) - call insert(output_states_old(j), s_field_old, trim(input_states_old(j)%scalar_names(i))) - end if - end do + if(.not.aliased(s_field_new).and.test(s_field_new%option_path)) then + ewrite(2, *) " Found ", trim(s_field_new%name) + ! make sure we keep the multi-material_phase/state safe names from state + call insert(output_states_new(j), s_field_new, trim(input_states_new(j)%scalar_names(i))) + call insert(output_states_old(j), s_field_old, trim(input_states_old(j)%scalar_names(i))) + end if + end do - assert(vector_field_count(input_states_new(j)) == vector_field_count(input_states_old(j))) + assert(vector_field_count(input_states_new(j)) == vector_field_count(input_states_old(j))) - do i = 1, vector_field_count(input_states_new(j)) - v_field_new => extract_vector_field(input_states_new(j), i) - v_field_old => extract_vector_field(input_states_old(j), i) + do i = 1, vector_field_count(input_states_new(j)) + v_field_new => extract_vector_field(input_states_new(j), i) + v_field_old => extract_vector_field(input_states_old(j), i) #ifdef DDEBUG - assert(trim(v_field_new%name) == trim(v_field_old%name)) - assert(trim(v_field_new%option_path) == trim(v_field_old%option_path)) + assert(trim(v_field_new%name) == trim(v_field_old%name)) + assert(trim(v_field_new%option_path) == trim(v_field_old%option_path)) #endif - if(index(trim(v_field_new%name), "Coordinate") /= 0) cycle - if(.not.aliased(v_field_new).and.test(v_field_new%option_path)) then - ewrite(2, *) " Found ", trim(v_field_new%name) - ! make sure we keep the multi-material_phase/state safe names from state - call insert(output_states_new(j), v_field_new, trim(input_states_new(j)%vector_names(i))) - call insert(output_states_old(j), v_field_old, trim(input_states_old(j)%vector_names(i))) - end if - end do + if(index(trim(v_field_new%name), "Coordinate") /= 0) cycle + if(.not.aliased(v_field_new).and.test(v_field_new%option_path)) then + ewrite(2, *) " Found ", trim(v_field_new%name) + ! make sure we keep the multi-material_phase/state safe names from state + call insert(output_states_new(j), v_field_new, trim(input_states_new(j)%vector_names(i))) + call insert(output_states_old(j), v_field_old, trim(input_states_old(j)%vector_names(i))) + end if + end do - assert(tensor_field_count(input_states_new(j)) == tensor_field_count(input_states_old(j))) + assert(tensor_field_count(input_states_new(j)) == tensor_field_count(input_states_old(j))) - do i = 1, tensor_field_count(input_states_new(j)) - t_field_new => extract_tensor_field(input_states_new(j), i) - t_field_old => extract_tensor_field(input_states_old(j), i) + do i = 1, tensor_field_count(input_states_new(j)) + t_field_new => extract_tensor_field(input_states_new(j), i) + t_field_old => extract_tensor_field(input_states_old(j), i) #ifdef DDEBUG - assert(trim(t_field_new%name) == trim(t_field_old%name)) - assert(trim(t_field_new%option_path) == trim(t_field_old%option_path)) + assert(trim(t_field_new%name) == trim(t_field_old%name)) + assert(trim(t_field_new%option_path) == trim(t_field_old%option_path)) #endif - if(.not.aliased(t_field_new).and.test(t_field_new%option_path)) then - ewrite(2, *) " Found ", trim(t_field_new%name) - ! make sure we keep the multi-material_phase/state safe names from state - call insert(output_states_new(j), t_field_new, trim(input_states_new(j)%tensor_names(i))) - call insert(output_states_old(j), t_field_old, trim(input_states_old(j)%tensor_names(i))) - end if + if(.not.aliased(t_field_new).and.test(t_field_new%option_path)) then + ewrite(2, *) " Found ", trim(t_field_new%name) + ! make sure we keep the multi-material_phase/state safe names from state + call insert(output_states_new(j), t_field_new, trim(input_states_new(j)%tensor_names(i))) + call insert(output_states_old(j), t_field_old, trim(input_states_old(j)%tensor_names(i))) + end if + end do end do - end do - end subroutine collect_fields_to_interpolate_multiple_states + end subroutine collect_fields_to_interpolate_multiple_states - subroutine interpolation_manager_check_options() - !!< Check interpolation algorithm selection options + subroutine interpolation_manager_check_options() + !!< Check interpolation algorithm selection options - character(len = OPTION_PATH_LEN) :: base_path - integer :: i, j + character(len = OPTION_PATH_LEN) :: base_path + integer :: i, j - ewrite(2, *) "Checking interpolation algorithm selection options" + ewrite(2, *) "Checking interpolation algorithm selection options" - do i = 0, option_count("/material_phase") - 1 - do j = 0, option_count("/material_phase[" // int2str(i) // "]/scalar_field") - 1 - base_path = complete_field_path("/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]") - if(have_option(trim(base_path) // "/galerkin_projection/supermesh_free")) then - FLExit("Supermesh free Galerkin projection is not yet available") - end if - end do - do j = 0, option_count("/material_phase[" // int2str(i) // "]/vector_field") - 1 - base_path = complete_field_path("/material_phase[" // int2str(i) // "]/vector_field[" // int2str(j) // "]") - if(have_option(trim(base_path) // "/galerkin_projection/supermesh_free")) then - FLExit("Supermesh free Galerkin projection is not yet available") - end if - end do - do j = 0, option_count("/material_phase[" // int2str(i) // "]/tensor_field") - 1 - base_path = complete_field_path("/material_phase[" // int2str(i) // "]/tensor_field[" // int2str(j) // "]") - if(have_option(trim(base_path) // "/galerkin_projection/supermesh_free")) then - FLExit("Supermesh free Galerkin projection is not yet available") - end if - end do - end do - - ewrite(2, *) "Finished checking interpolation algorithm selection options" - - end subroutine interpolation_manager_check_options - - subroutine prepare_periodic_states_for_interpolation(mesh_old, mesh_new) - type(state_type), intent(inout) :: mesh_old, mesh_new - - type(vector_field), pointer :: positions_new - type(mesh_type), pointer :: new_mesh - type(mesh_type) :: new_mesh_unperiodic - - type(vector_field) :: expanded_positions - type(vector_field), pointer :: positions_old - type(mesh_type), pointer :: old_mesh - type(mesh_type) :: old_mesh_unperiodic, old_mesh_expanded - - integer :: field - type(scalar_field), pointer :: p_field_s, u_field_s - type(scalar_field) :: field_s - type(vector_field), pointer :: p_field_v, u_field_v - type(vector_field) :: field_v - type(tensor_field), pointer :: p_field_t, u_field_t - type(tensor_field) :: field_t - - type(element_type), pointer :: x_shape, mesh_shape - - integer :: j, node, total_multiple - - type(state_type) :: unwrapped_state - - integer :: dim - - ! Easiest first. Unwrap the coordinate of mesh_new, reallocate all the fields, - ! and remap periodic -> nonperiodic. - - positions_new => extract_vector_field(mesh_new, "Coordinate") - new_mesh => extract_mesh(mesh_new, "Mesh") - dim = positions_new%dim - - x_shape => positions_new%mesh%shape - mesh_shape => new_mesh%shape - if (mesh_shape%degree/=x_shape%degree .or. & - continuity(new_mesh)/=0) then - ! make a non-periodic version of the mesh - new_mesh_unperiodic = make_mesh(positions_new%mesh, mesh_shape, & - continuity=continuity(new_mesh), name=trim(new_mesh%name)//"Unperiodic") - else - new_mesh_unperiodic = positions_new%mesh - call incref(new_mesh_unperiodic) - end if - - do field=1,scalar_field_count(mesh_new) - p_field_s => extract_scalar_field(mesh_new, field) - call allocate(field_s, new_mesh_unperiodic, trim(p_field_s%name)) - field_s%option_path = p_field_s%option_path - call remap_field(p_field_s, field_s) - call insert(mesh_new, field_s, trim(mesh_new%scalar_names(field))) - call deallocate(field_s) - end do - - do field=1,vector_field_count(mesh_new) - p_field_v => extract_vector_field(mesh_new, field) - if (trim(p_field_v%name) == "Coordinate") then - cycle - end if - call allocate(field_v, p_field_v%dim, new_mesh_unperiodic, trim(p_field_v%name)) - field_v%option_path = p_field_v%option_path - call remap_field(p_field_v, field_v) - call insert(mesh_new, field_v, trim(mesh_new%vector_names(field))) - call deallocate(field_v) - end do - - do field=1,tensor_field_count(mesh_new) - p_field_t => extract_tensor_field(mesh_new, field) - call allocate(field_t, new_mesh_unperiodic, trim(p_field_t%name)) - field_t%option_path = p_field_t%option_path - call remap_field(p_field_t, field_t) - call insert(mesh_new, field_t, trim(mesh_new%tensor_names(field))) - call deallocate(field_t) - end do - - ! replace mesh with non-periodic version: - call insert(mesh_new, new_mesh_unperiodic, "Mesh") - call deallocate(new_mesh_unperiodic) - - ! OK. Let's do the same for the old fields, with the additional twist - ! that we duplicate the mesh on either side of the periodic boundary. - ! Since the boundaries of the new domain don't match up with the old one, - ! this is necessary so the new domain can find the relevant information. - - positions_old => extract_vector_field(mesh_old, "Coordinate") - old_mesh => extract_mesh(mesh_old, "Mesh") - dim = positions_old%dim - - x_shape => positions_old%mesh%shape - mesh_shape => old_mesh%shape - if (mesh_shape%degree/=x_shape%degree .or. & - continuity(old_mesh)/=0) then - ! make a non-periodic version of the mesh - old_mesh_unperiodic = make_mesh(positions_old%mesh, mesh_shape, & - continuity=continuity(old_mesh), name=trim(old_mesh%name)//"Unperiodic") - else - old_mesh_unperiodic = positions_old%mesh - call incref(old_mesh_unperiodic) - end if - - call expand_periodic_mesh(positions_old, old_mesh_unperiodic, & - expanded_positions, old_mesh_expanded) - - total_multiple = element_count(old_mesh_expanded)/element_count(old_mesh_unperiodic) - assert(element_count(old_mesh_expanded) == total_multiple*element_count(old_mesh_unperiodic)) - - ! Let's unwrap everything and put it into the unwrapped_state. - do field=1,scalar_field_count(mesh_old) - p_field_s => extract_scalar_field(mesh_old, field) - call allocate(field_s, old_mesh_unperiodic, trim(p_field_s%name)) - call remap_field(p_field_s, field_s) - call insert(unwrapped_state, field_s, trim(p_field_s%name)) - call deallocate(field_s) - end do - - do field=1,vector_field_count(mesh_old) - p_field_v => extract_vector_field(mesh_old, field) - call allocate(field_v, p_field_v%dim, old_mesh_unperiodic, trim(p_field_v%name)) - call remap_field(p_field_v, field_v) - call insert(unwrapped_state, field_v, trim(p_field_v%name)) - call deallocate(field_v) - end do - - do field=1,tensor_field_count(mesh_old) - p_field_t => extract_tensor_field(mesh_old, field) - call allocate(field_t, old_mesh_unperiodic, trim(p_field_t%name)) - call remap_field(p_field_t, field_t) - call insert(unwrapped_state, field_t, trim(p_field_t%name)) - call deallocate(field_t) - end do - - ! now copy the unwrapped fields into expanded versions, and put them - ! in mesh_old states - - do field=1,scalar_field_count(mesh_old) - p_field_s => extract_scalar_field(mesh_old, field) - u_field_s => extract_scalar_field(unwrapped_state, trim(p_field_s%name)) - call allocate(field_s, old_mesh_expanded, trim(p_field_s%name)) - field_s%option_path = p_field_s%option_path - do node=1,node_count(u_field_s) - do j=0,total_multiple-1 - call set(field_s, node + j*node_count(u_field_s), node_val(u_field_s, node)) - end do + do i = 0, option_count("/material_phase") - 1 + do j = 0, option_count("/material_phase[" // int2str(i) // "]/scalar_field") - 1 + base_path = complete_field_path("/material_phase[" // int2str(i) // "]/scalar_field[" // int2str(j) // "]") + if(have_option(trim(base_path) // "/galerkin_projection/supermesh_free")) then + FLExit("Supermesh free Galerkin projection is not yet available") + end if + end do + do j = 0, option_count("/material_phase[" // int2str(i) // "]/vector_field") - 1 + base_path = complete_field_path("/material_phase[" // int2str(i) // "]/vector_field[" // int2str(j) // "]") + if(have_option(trim(base_path) // "/galerkin_projection/supermesh_free")) then + FLExit("Supermesh free Galerkin projection is not yet available") + end if + end do + do j = 0, option_count("/material_phase[" // int2str(i) // "]/tensor_field") - 1 + base_path = complete_field_path("/material_phase[" // int2str(i) // "]/tensor_field[" // int2str(j) // "]") + if(have_option(trim(base_path) // "/galerkin_projection/supermesh_free")) then + FLExit("Supermesh free Galerkin projection is not yet available") + end if + end do end do - call insert(mesh_old, field_s, trim(mesh_old%scalar_names(field))) - call deallocate(field_s) - end do - - do field=1,vector_field_count(mesh_old) - p_field_v => extract_vector_field(mesh_old, field) - if (trim(p_field_v%name) == "Coordinate") then - cycle + + ewrite(2, *) "Finished checking interpolation algorithm selection options" + + end subroutine interpolation_manager_check_options + + subroutine prepare_periodic_states_for_interpolation(mesh_old, mesh_new) + type(state_type), intent(inout) :: mesh_old, mesh_new + + type(vector_field), pointer :: positions_new + type(mesh_type), pointer :: new_mesh + type(mesh_type) :: new_mesh_unperiodic + + type(vector_field) :: expanded_positions + type(vector_field), pointer :: positions_old + type(mesh_type), pointer :: old_mesh + type(mesh_type) :: old_mesh_unperiodic, old_mesh_expanded + + integer :: field + type(scalar_field), pointer :: p_field_s, u_field_s + type(scalar_field) :: field_s + type(vector_field), pointer :: p_field_v, u_field_v + type(vector_field) :: field_v + type(tensor_field), pointer :: p_field_t, u_field_t + type(tensor_field) :: field_t + + type(element_type), pointer :: x_shape, mesh_shape + + integer :: j, node, total_multiple + + type(state_type) :: unwrapped_state + + integer :: dim + + ! Easiest first. Unwrap the coordinate of mesh_new, reallocate all the fields, + ! and remap periodic -> nonperiodic. + + positions_new => extract_vector_field(mesh_new, "Coordinate") + new_mesh => extract_mesh(mesh_new, "Mesh") + dim = positions_new%dim + + x_shape => positions_new%mesh%shape + mesh_shape => new_mesh%shape + if (mesh_shape%degree/=x_shape%degree .or. & + continuity(new_mesh)/=0) then + ! make a non-periodic version of the mesh + new_mesh_unperiodic = make_mesh(positions_new%mesh, mesh_shape, & + continuity=continuity(new_mesh), name=trim(new_mesh%name)//"Unperiodic") + else + new_mesh_unperiodic = positions_new%mesh + call incref(new_mesh_unperiodic) end if - u_field_v => extract_vector_field(unwrapped_state, trim(p_field_v%name)) - call allocate(field_v, p_field_v%dim, old_mesh_expanded, trim(p_field_v%name)) - field_v%option_path = p_field_v%option_path - do node=1,node_count(u_field_v) - do j=0,total_multiple-1 - call set(field_v, node + j*node_count(u_field_v), node_val(u_field_v, node)) - end do + + do field=1,scalar_field_count(mesh_new) + p_field_s => extract_scalar_field(mesh_new, field) + call allocate(field_s, new_mesh_unperiodic, trim(p_field_s%name)) + field_s%option_path = p_field_s%option_path + call remap_field(p_field_s, field_s) + call insert(mesh_new, field_s, trim(mesh_new%scalar_names(field))) + call deallocate(field_s) end do - call insert(mesh_old, field_v, trim(mesh_old%vector_names(field))) - call deallocate(field_v) - end do - - do field=1,tensor_field_count(mesh_old) - p_field_t => extract_tensor_field(mesh_old, field) - u_field_t => extract_tensor_field(unwrapped_state, trim(p_field_t%name)) - call allocate(field_t, old_mesh_expanded, trim(p_field_t%name)) - field_t%option_path = p_field_t%option_path - do node=1,node_count(u_field_t) - do j=0,total_multiple-1 - call set(field_t, node + j*node_count(u_field_t), node_val(u_field_t, node)) - end do + + do field=1,vector_field_count(mesh_new) + p_field_v => extract_vector_field(mesh_new, field) + if (trim(p_field_v%name) == "Coordinate") then + cycle + end if + call allocate(field_v, p_field_v%dim, new_mesh_unperiodic, trim(p_field_v%name)) + field_v%option_path = p_field_v%option_path + call remap_field(p_field_v, field_v) + call insert(mesh_new, field_v, trim(mesh_new%vector_names(field))) + call deallocate(field_v) end do - call insert(mesh_old, field_t, trim(mesh_old%tensor_names(field))) - call deallocate(field_t) - end do - - ! replace mesh and positions with expanded non-periodic version: - call insert(mesh_old, old_mesh_expanded, "Mesh") - call insert(mesh_old, expanded_positions, "Coordinate") - - ! debugging vtus: - !call insert(unwrapped_state, old_mesh_unperiodic, "Mesh") - !call vtk_write_state("unwrapped", 0, model="Mesh", state=(/unwrapped_state/)) - !call vtk_write_state("mesh_new", 0, model="Mesh", state=(/mesh_new/)) - !call vtk_write_state("mesh_old", 0, model="Mesh", state=(/mesh_old/)) - - call deallocate(old_mesh_unperiodic) - call deallocate(old_mesh_expanded) - call deallocate(expanded_positions) - call deallocate(unwrapped_state) - - end subroutine prepare_periodic_states_for_interpolation - - subroutine expand_periodic_mesh(positions_in, mesh_in, & - expanded_positions, expanded_mesh) - ! creates an expanded version of the provided positions_in field - ! and the (possibly different) mesh_in, adding periodic copies - ! by applying the periodic (inverse) maps - type(vector_field), intent(in):: positions_in - type(mesh_type), intent(in):: mesh_in - type(vector_field), intent(out):: expanded_positions - type(mesh_type), intent(out):: expanded_mesh - - type(vector_field) :: positions - type(mesh_type) :: mesh, expanded_x_mesh - character(len=OPTION_PATH_LEN) :: periodic_mapping_python, inverse_periodic_mapping_python - real, dimension(:, :), allocatable :: forward_mapped_nodes, inverse_mapped_nodes - integer :: multiple, j, bc, no_bcs, ele, node, total_multiple - integer :: dim - - dim = positions_in%dim - - no_bcs = option_count(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions') - total_multiple = 1 - - positions = positions_in - mesh = mesh_in - call incref(positions) - call incref(mesh) - - do bc=0,no_bcs-1 - - ! figure out how many copies to make - multiple = 2 ! for the current mesh, as well as the one under the forward periodic mapping - if (have_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map')) then - multiple = multiple + 1 ! plus the inverse periodic mapping, if we have it - end if - total_multiple = total_multiple * multiple - - ! expand the coordinate mesh - call allocate(expanded_x_mesh, multiple * node_count(positions), multiple * ele_count(positions), & - & positions%mesh%shape, positions%mesh%name) - do ele=1,ele_count(positions) - do j=0,multiple-1 - call set_ele_nodes(expanded_x_mesh, ele + j*ele_count(positions), ele_nodes(positions, ele) + j*node_count(positions)) - end do + + do field=1,tensor_field_count(mesh_new) + p_field_t => extract_tensor_field(mesh_new, field) + call allocate(field_t, new_mesh_unperiodic, trim(p_field_t%name)) + field_t%option_path = p_field_t%option_path + call remap_field(p_field_t, field_t) + call insert(mesh_new, field_t, trim(mesh_new%tensor_names(field))) + call deallocate(field_t) end do - ! do the same for the provided 'mesh_in' - if (positions_in%mesh==mesh_in) then - expanded_mesh = expanded_x_mesh - call incref(expanded_mesh) + ! replace mesh with non-periodic version: + call insert(mesh_new, new_mesh_unperiodic, "Mesh") + call deallocate(new_mesh_unperiodic) + + ! OK. Let's do the same for the old fields, with the additional twist + ! that we duplicate the mesh on either side of the periodic boundary. + ! Since the boundaries of the new domain don't match up with the old one, + ! this is necessary so the new domain can find the relevant information. + + positions_old => extract_vector_field(mesh_old, "Coordinate") + old_mesh => extract_mesh(mesh_old, "Mesh") + dim = positions_old%dim + + x_shape => positions_old%mesh%shape + mesh_shape => old_mesh%shape + if (mesh_shape%degree/=x_shape%degree .or. & + continuity(old_mesh)/=0) then + ! make a non-periodic version of the mesh + old_mesh_unperiodic = make_mesh(positions_old%mesh, mesh_shape, & + continuity=continuity(old_mesh), name=trim(old_mesh%name)//"Unperiodic") else - call allocate(expanded_mesh, multiple * node_count(mesh), multiple * ele_count(mesh), & - & mesh%shape, mesh%name) - expanded_mesh%continuity=mesh%continuity - do ele=1,ele_count(mesh) - do j=0,multiple-1 - call set_ele_nodes(expanded_mesh, ele + j*ele_count(mesh), ele_nodes(mesh, ele) + j*node_count(mesh)) - end do - end do + old_mesh_unperiodic = positions_old%mesh + call incref(old_mesh_unperiodic) end if - call allocate(expanded_positions, dim, expanded_x_mesh, positions%name) - call deallocate(expanded_x_mesh) + call expand_periodic_mesh(positions_old, old_mesh_unperiodic, & + expanded_positions, old_mesh_expanded) - do node=1, node_count(positions) - call set(expanded_positions, node, node_val(positions, node)) + total_multiple = element_count(old_mesh_expanded)/element_count(old_mesh_unperiodic) + assert(element_count(old_mesh_expanded) == total_multiple*element_count(old_mesh_unperiodic)) + + ! Let's unwrap everything and put it into the unwrapped_state. + do field=1,scalar_field_count(mesh_old) + p_field_s => extract_scalar_field(mesh_old, field) + call allocate(field_s, old_mesh_unperiodic, trim(p_field_s%name)) + call remap_field(p_field_s, field_s) + call insert(unwrapped_state, field_s, trim(p_field_s%name)) + call deallocate(field_s) end do - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/coordinate_map', periodic_mapping_python) - allocate(forward_mapped_nodes(dim, node_count(positions))) - call set_from_python_function(forward_mapped_nodes, periodic_mapping_python, positions, time=0.0) - do node=1, node_count(positions) - call set(expanded_positions, node + node_count(positions), forward_mapped_nodes(:, node)) + do field=1,vector_field_count(mesh_old) + p_field_v => extract_vector_field(mesh_old, field) + call allocate(field_v, p_field_v%dim, old_mesh_unperiodic, trim(p_field_v%name)) + call remap_field(p_field_v, field_v) + call insert(unwrapped_state, field_v, trim(p_field_v%name)) + call deallocate(field_v) end do - deallocate(forward_mapped_nodes) - - if (have_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map')) then - call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map', inverse_periodic_mapping_python) - allocate(inverse_mapped_nodes(dim, node_count(positions))) - call set_from_python_function(inverse_mapped_nodes, inverse_periodic_mapping_python, positions, time=0.0) - do node=1,node_count(positions) - call set(expanded_positions, node + 2*node_count(positions), inverse_mapped_nodes(:, node)) - end do - deallocate(inverse_mapped_nodes) - end if - call deallocate(mesh) - call deallocate(positions) - positions = expanded_positions - mesh = expanded_mesh - end do + do field=1,tensor_field_count(mesh_old) + p_field_t => extract_tensor_field(mesh_old, field) + call allocate(field_t, old_mesh_unperiodic, trim(p_field_t%name)) + call remap_field(p_field_t, field_t) + call insert(unwrapped_state, field_t, trim(p_field_t%name)) + call deallocate(field_t) + end do + + ! now copy the unwrapped fields into expanded versions, and put them + ! in mesh_old states + + do field=1,scalar_field_count(mesh_old) + p_field_s => extract_scalar_field(mesh_old, field) + u_field_s => extract_scalar_field(unwrapped_state, trim(p_field_s%name)) + call allocate(field_s, old_mesh_expanded, trim(p_field_s%name)) + field_s%option_path = p_field_s%option_path + do node=1,node_count(u_field_s) + do j=0,total_multiple-1 + call set(field_s, node + j*node_count(u_field_s), node_val(u_field_s, node)) + end do + end do + call insert(mesh_old, field_s, trim(mesh_old%scalar_names(field))) + call deallocate(field_s) + end do + + do field=1,vector_field_count(mesh_old) + p_field_v => extract_vector_field(mesh_old, field) + if (trim(p_field_v%name) == "Coordinate") then + cycle + end if + u_field_v => extract_vector_field(unwrapped_state, trim(p_field_v%name)) + call allocate(field_v, p_field_v%dim, old_mesh_expanded, trim(p_field_v%name)) + field_v%option_path = p_field_v%option_path + do node=1,node_count(u_field_v) + do j=0,total_multiple-1 + call set(field_v, node + j*node_count(u_field_v), node_val(u_field_v, node)) + end do + end do + call insert(mesh_old, field_v, trim(mesh_old%vector_names(field))) + call deallocate(field_v) + end do + + do field=1,tensor_field_count(mesh_old) + p_field_t => extract_tensor_field(mesh_old, field) + u_field_t => extract_tensor_field(unwrapped_state, trim(p_field_t%name)) + call allocate(field_t, old_mesh_expanded, trim(p_field_t%name)) + field_t%option_path = p_field_t%option_path + do node=1,node_count(u_field_t) + do j=0,total_multiple-1 + call set(field_t, node + j*node_count(u_field_t), node_val(u_field_t, node)) + end do + end do + call insert(mesh_old, field_t, trim(mesh_old%tensor_names(field))) + call deallocate(field_t) + end do + + ! replace mesh and positions with expanded non-periodic version: + call insert(mesh_old, old_mesh_expanded, "Mesh") + call insert(mesh_old, expanded_positions, "Coordinate") + + ! debugging vtus: + !call insert(unwrapped_state, old_mesh_unperiodic, "Mesh") + !call vtk_write_state("unwrapped", 0, model="Mesh", state=(/unwrapped_state/)) + !call vtk_write_state("mesh_new", 0, model="Mesh", state=(/mesh_new/)) + !call vtk_write_state("mesh_old", 0, model="Mesh", state=(/mesh_old/)) + + call deallocate(old_mesh_unperiodic) + call deallocate(old_mesh_expanded) + call deallocate(expanded_positions) + call deallocate(unwrapped_state) + + end subroutine prepare_periodic_states_for_interpolation + + subroutine expand_periodic_mesh(positions_in, mesh_in, & + expanded_positions, expanded_mesh) + ! creates an expanded version of the provided positions_in field + ! and the (possibly different) mesh_in, adding periodic copies + ! by applying the periodic (inverse) maps + type(vector_field), intent(in):: positions_in + type(mesh_type), intent(in):: mesh_in + type(vector_field), intent(out):: expanded_positions + type(mesh_type), intent(out):: expanded_mesh + + type(vector_field) :: positions + type(mesh_type) :: mesh, expanded_x_mesh + character(len=OPTION_PATH_LEN) :: periodic_mapping_python, inverse_periodic_mapping_python + real, dimension(:, :), allocatable :: forward_mapped_nodes, inverse_mapped_nodes + integer :: multiple, j, bc, no_bcs, ele, node, total_multiple + integer :: dim + + dim = positions_in%dim + + no_bcs = option_count(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions') + total_multiple = 1 + + positions = positions_in + mesh = mesh_in + call incref(positions) + call incref(mesh) + + do bc=0,no_bcs-1 + + ! figure out how many copies to make + multiple = 2 ! for the current mesh, as well as the one under the forward periodic mapping + if (have_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map')) then + multiple = multiple + 1 ! plus the inverse periodic mapping, if we have it + end if + total_multiple = total_multiple * multiple + + ! expand the coordinate mesh + call allocate(expanded_x_mesh, multiple * node_count(positions), multiple * ele_count(positions), & + & positions%mesh%shape, positions%mesh%name) + do ele=1,ele_count(positions) + do j=0,multiple-1 + call set_ele_nodes(expanded_x_mesh, ele + j*ele_count(positions), ele_nodes(positions, ele) + j*node_count(positions)) + end do + end do + + ! do the same for the provided 'mesh_in' + if (positions_in%mesh==mesh_in) then + expanded_mesh = expanded_x_mesh + call incref(expanded_mesh) + else + call allocate(expanded_mesh, multiple * node_count(mesh), multiple * ele_count(mesh), & + & mesh%shape, mesh%name) + expanded_mesh%continuity=mesh%continuity + do ele=1,ele_count(mesh) + do j=0,multiple-1 + call set_ele_nodes(expanded_mesh, ele + j*ele_count(mesh), ele_nodes(mesh, ele) + j*node_count(mesh)) + end do + end do + end if + + call allocate(expanded_positions, dim, expanded_x_mesh, positions%name) + call deallocate(expanded_x_mesh) + + do node=1, node_count(positions) + call set(expanded_positions, node, node_val(positions, node)) + end do + + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/coordinate_map', periodic_mapping_python) + allocate(forward_mapped_nodes(dim, node_count(positions))) + call set_from_python_function(forward_mapped_nodes, periodic_mapping_python, positions, time=0.0) + do node=1, node_count(positions) + call set(expanded_positions, node + node_count(positions), forward_mapped_nodes(:, node)) + end do + deallocate(forward_mapped_nodes) + + if (have_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map')) then + call get_option(trim(periodic_boundary_option_path(dim)) // '/from_mesh/periodic_boundary_conditions['//int2str(bc)//']/inverse_coordinate_map', inverse_periodic_mapping_python) + allocate(inverse_mapped_nodes(dim, node_count(positions))) + call set_from_python_function(inverse_mapped_nodes, inverse_periodic_mapping_python, positions, time=0.0) + do node=1,node_count(positions) + call set(expanded_positions, node + 2*node_count(positions), inverse_mapped_nodes(:, node)) + end do + deallocate(inverse_mapped_nodes) + end if + + call deallocate(mesh) + call deallocate(positions) + positions = expanded_positions + mesh = expanded_mesh + end do - end subroutine expand_periodic_mesh + end subroutine expand_periodic_mesh end module interpolation_manager diff --git a/assemble/LES.F90 b/assemble/LES.F90 index ff2f759e41..0ba52859a4 100644 --- a/assemble/LES.F90 +++ b/assemble/LES.F90 @@ -27,368 +27,368 @@ #include "fdebug.h" module les_module - !!< This module contains several subroutines and functions used to implement LES models - use fldebug - use spud - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN - use sparse_tools - use vector_tools - use fetools - use fields - use state_module - use field_options - use solvers - use smoothing_module - use state_fields_module, only: get_lumped_mass_on_submesh, get_lumped_mass,& - get_mass_matrix - implicit none - - private - - public les_viscosity_strength, wale_viscosity_strength - public les_init_diagnostic_fields, les_assemble_diagnostic_fields, les_solve_diagnostic_fields, & - leonard_tensor, les_strain_rate + !!< This module contains several subroutines and functions used to implement LES models + use fldebug + use spud + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use sparse_tools + use vector_tools + use fetools + use fields + use state_module + use field_options + use solvers + use smoothing_module + use state_fields_module, only: get_lumped_mass_on_submesh, get_lumped_mass,& + get_mass_matrix + implicit none + + private + + public les_viscosity_strength, wale_viscosity_strength + public les_init_diagnostic_fields, les_assemble_diagnostic_fields, les_solve_diagnostic_fields, & + leonard_tensor, les_strain_rate contains - subroutine les_init_diagnostic_fields(state, have_eddy_visc, have_filter_width, have_coeff) + subroutine les_init_diagnostic_fields(state, have_eddy_visc, have_filter_width, have_coeff) - ! Arguments - type(state_type), intent(inout) :: state - logical, intent(in) :: have_eddy_visc, have_filter_width, have_coeff + ! Arguments + type(state_type), intent(inout) :: state + logical, intent(in) :: have_eddy_visc, have_filter_width, have_coeff - ! Local variables - logical, dimension(2) :: have_diagnostic_tfield - logical, dimension(1) :: have_diagnostic_sfield - character(len=FIELD_NAME_LEN), dimension(2) :: diagnostic_tfield_names - character(len=FIELD_NAME_LEN), dimension(1) :: diagnostic_sfield_names - type(tensor_field), pointer :: tfield - type(scalar_field), pointer :: sfield - integer :: i + ! Local variables + logical, dimension(2) :: have_diagnostic_tfield + logical, dimension(1) :: have_diagnostic_sfield + character(len=FIELD_NAME_LEN), dimension(2) :: diagnostic_tfield_names + character(len=FIELD_NAME_LEN), dimension(1) :: diagnostic_sfield_names + type(tensor_field), pointer :: tfield + type(scalar_field), pointer :: sfield + integer :: i - ewrite(2,*) "Initialising optional LES diagnostic fields" + ewrite(2,*) "Initialising optional LES diagnostic fields" - have_diagnostic_tfield = (/have_eddy_visc, have_filter_width/) - diagnostic_tfield_names(1) = "EddyViscosity" - diagnostic_tfield_names(2) = "FilterWidth" + have_diagnostic_tfield = (/have_eddy_visc, have_filter_width/) + diagnostic_tfield_names(1) = "EddyViscosity" + diagnostic_tfield_names(2) = "FilterWidth" - diagnostic_tfield_loop: do i = 1, size(diagnostic_tfield_names) - if(have_diagnostic_tfield(i)) then - tfield => extract_tensor_field(state, diagnostic_tfield_names(i)) - call zero(tfield) + diagnostic_tfield_loop: do i = 1, size(diagnostic_tfield_names) + if(have_diagnostic_tfield(i)) then + tfield => extract_tensor_field(state, diagnostic_tfield_names(i)) + call zero(tfield) + end if + end do diagnostic_tfield_loop + + have_diagnostic_sfield = (/have_coeff/) + diagnostic_sfield_names(1) = "SmagorinskyCoefficient" + + diagnostic_sfield_loop: do i = 1, size(diagnostic_sfield_names) + if(have_diagnostic_sfield(i)) then + sfield => extract_scalar_field(state, diagnostic_sfield_names(i)) + call zero(sfield) + end if + end do diagnostic_sfield_loop + + end subroutine les_init_diagnostic_fields + + subroutine les_assemble_diagnostic_fields(state, nu, ele, detwei, & + mesh_size_gi,les_tensor_gi, les_coef_gi, & + have_eddy_visc, have_filter_width, have_coeff) + + ! Arguments + type(state_type), intent(inout) :: state + type(vector_field), intent(in) :: nu + integer, intent(in) :: ele + real, dimension(ele_ngi(nu,ele)), intent(in) :: les_coef_gi, detwei + real, dimension(nu%dim,nu%dim,ele_ngi(nu,ele)),intent(in) :: mesh_size_gi, les_tensor_gi + logical, intent(in) :: have_eddy_visc, have_filter_width, have_coeff + + ! Local variables + type(tensor_field), pointer :: tfield + type(scalar_field), pointer :: sfield + real, dimension(nu%dim,nu%dim,ele_loc(nu,ele)) :: tensor_loc + real, dimension(ele_loc(nu,ele)) :: scalar_loc + + ! Eddy viscosity + if(have_eddy_visc) then + tfield => extract_tensor_field(state, "EddyViscosity") + tensor_loc=shape_tensor_rhs(ele_shape(nu, ele), les_tensor_gi, detwei) + call addto(tfield, ele_nodes(nu, ele), tensor_loc) end if - end do diagnostic_tfield_loop - have_diagnostic_sfield = (/have_coeff/) - diagnostic_sfield_names(1) = "SmagorinskyCoefficient" + ! Filter width + if(have_filter_width) then + tfield => extract_tensor_field(state, "FilterWidth") + tensor_loc=shape_tensor_rhs(ele_shape(nu, ele), mesh_size_gi, detwei) + call addto(tfield, ele_nodes(nu, ele), tensor_loc) + end if - diagnostic_sfield_loop: do i = 1, size(diagnostic_sfield_names) - if(have_diagnostic_sfield(i)) then - sfield => extract_scalar_field(state, diagnostic_sfield_names(i)) - call zero(sfield) + ! Smagorinsky Coefficient + if(have_coeff) then + sfield => extract_scalar_field(state, "SmagorinskyCoefficient") + scalar_loc=shape_rhs(ele_shape(nu, ele), les_coef_gi*detwei) + call addto(sfield, ele_nodes(nu, ele), scalar_loc) end if - end do diagnostic_sfield_loop - - end subroutine les_init_diagnostic_fields - - subroutine les_assemble_diagnostic_fields(state, nu, ele, detwei, & - mesh_size_gi,les_tensor_gi, les_coef_gi, & - have_eddy_visc, have_filter_width, have_coeff) - - ! Arguments - type(state_type), intent(inout) :: state - type(vector_field), intent(in) :: nu - integer, intent(in) :: ele - real, dimension(ele_ngi(nu,ele)), intent(in) :: les_coef_gi, detwei - real, dimension(nu%dim,nu%dim,ele_ngi(nu,ele)),intent(in) :: mesh_size_gi, les_tensor_gi - logical, intent(in) :: have_eddy_visc, have_filter_width, have_coeff - - ! Local variables - type(tensor_field), pointer :: tfield - type(scalar_field), pointer :: sfield - real, dimension(nu%dim,nu%dim,ele_loc(nu,ele)) :: tensor_loc - real, dimension(ele_loc(nu,ele)) :: scalar_loc - - ! Eddy viscosity - if(have_eddy_visc) then - tfield => extract_tensor_field(state, "EddyViscosity") - tensor_loc=shape_tensor_rhs(ele_shape(nu, ele), les_tensor_gi, detwei) - call addto(tfield, ele_nodes(nu, ele), tensor_loc) - end if - - ! Filter width - if(have_filter_width) then - tfield => extract_tensor_field(state, "FilterWidth") - tensor_loc=shape_tensor_rhs(ele_shape(nu, ele), mesh_size_gi, detwei) - call addto(tfield, ele_nodes(nu, ele), tensor_loc) - end if - - ! Smagorinsky Coefficient - if(have_coeff) then - sfield => extract_scalar_field(state, "SmagorinskyCoefficient") - scalar_loc=shape_rhs(ele_shape(nu, ele), les_coef_gi*detwei) - call addto(sfield, ele_nodes(nu, ele), scalar_loc) - end if - - end subroutine les_assemble_diagnostic_fields - - subroutine les_solve_diagnostic_fields(state, have_eddy_visc, have_filter_width, have_coeff) - - ! Arguments - type(state_type), intent(inout) :: state - logical, intent(in) :: have_eddy_visc, have_filter_width, have_coeff - - ! Local variables - logical, dimension(2) :: have_diagnostic_tfield - logical, dimension(1) :: have_diagnostic_sfield - character(len=FIELD_NAME_LEN), dimension(2) :: diagnostic_tfield_names - character(len=FIELD_NAME_LEN), dimension(1) :: diagnostic_sfield_names - type(tensor_field), pointer :: tfield - type(scalar_field), pointer :: sfield - integer :: i - type(vector_field), pointer :: u - type(csr_matrix), pointer :: mass_matrix - type(scalar_field), pointer :: lumped_mass - type(scalar_field) :: inv_lumped_mass - logical :: lump_mass = .false. - logical :: use_submesh = .false. - - ewrite(2,*) "Solving for optional LES diagnostic fields" - - u => extract_vector_field(state, "Velocity") - - have_diagnostic_tfield = (/have_eddy_visc, have_filter_width/) - diagnostic_tfield_names(1) = "EddyViscosity" - diagnostic_tfield_names(2) = "FilterWidth" - - diagnostic_tfield_loop: do i = 1, size(diagnostic_tfield_names) - if(have_diagnostic_tfield(i)) then - tfield => extract_tensor_field(state, diagnostic_tfield_names(i)) - lump_mass = have_option(trim(tfield%option_path)//"/diagnostic/mass_matrix"//& + + end subroutine les_assemble_diagnostic_fields + + subroutine les_solve_diagnostic_fields(state, have_eddy_visc, have_filter_width, have_coeff) + + ! Arguments + type(state_type), intent(inout) :: state + logical, intent(in) :: have_eddy_visc, have_filter_width, have_coeff + + ! Local variables + logical, dimension(2) :: have_diagnostic_tfield + logical, dimension(1) :: have_diagnostic_sfield + character(len=FIELD_NAME_LEN), dimension(2) :: diagnostic_tfield_names + character(len=FIELD_NAME_LEN), dimension(1) :: diagnostic_sfield_names + type(tensor_field), pointer :: tfield + type(scalar_field), pointer :: sfield + integer :: i + type(vector_field), pointer :: u + type(csr_matrix), pointer :: mass_matrix + type(scalar_field), pointer :: lumped_mass + type(scalar_field) :: inv_lumped_mass + logical :: lump_mass = .false. + logical :: use_submesh = .false. + + ewrite(2,*) "Solving for optional LES diagnostic fields" + + u => extract_vector_field(state, "Velocity") + + have_diagnostic_tfield = (/have_eddy_visc, have_filter_width/) + diagnostic_tfield_names(1) = "EddyViscosity" + diagnostic_tfield_names(2) = "FilterWidth" + + diagnostic_tfield_loop: do i = 1, size(diagnostic_tfield_names) + if(have_diagnostic_tfield(i)) then + tfield => extract_tensor_field(state, diagnostic_tfield_names(i)) + lump_mass = have_option(trim(tfield%option_path)//"/diagnostic/mass_matrix"//& &"/use_lumped_mass_matrix") - use_submesh = have_option(trim(tfield%option_path)//"/diagnostic/mass_matrix"//& + use_submesh = have_option(trim(tfield%option_path)//"/diagnostic/mass_matrix"//& &"/use_lumped_mass_matrix/use_submesh") ! For P2 meshes. - if(lump_mass) then - if(use_submesh) then - lumped_mass => get_lumped_mass_on_submesh(state, tfield%mesh) + if(lump_mass) then + if(use_submesh) then + lumped_mass => get_lumped_mass_on_submesh(state, tfield%mesh) + else + lumped_mass => get_lumped_mass(state, tfield%mesh) + end if + call allocate(inv_lumped_mass, tfield%mesh) + call invert(lumped_mass, inv_lumped_mass) + call scale(tfield, inv_lumped_mass) + call deallocate(inv_lumped_mass) else - lumped_mass => get_lumped_mass(state, tfield%mesh) + mass_matrix => get_mass_matrix(state, tfield%mesh) + call petsc_solve(tfield, mass_matrix, tfield, option_path=u%option_path) end if - call allocate(inv_lumped_mass, tfield%mesh) - call invert(lumped_mass, inv_lumped_mass) - call scale(tfield, inv_lumped_mass) - call deallocate(inv_lumped_mass) - else - mass_matrix => get_mass_matrix(state, tfield%mesh) - call petsc_solve(tfield, mass_matrix, tfield, option_path=u%option_path) end if - end if - end do diagnostic_tfield_loop + end do diagnostic_tfield_loop - have_diagnostic_sfield = (/have_coeff/) - diagnostic_sfield_names(1) = "SmagorinskyCoefficient" + have_diagnostic_sfield = (/have_coeff/) + diagnostic_sfield_names(1) = "SmagorinskyCoefficient" - diagnostic_sfield_loop: do i = 1, size(diagnostic_sfield_names) - if(have_diagnostic_sfield(i)) then - sfield => extract_scalar_field(state, diagnostic_sfield_names(i)) - lump_mass = have_option(trim(sfield%option_path)//"/diagnostic/mass_matrix"//& + diagnostic_sfield_loop: do i = 1, size(diagnostic_sfield_names) + if(have_diagnostic_sfield(i)) then + sfield => extract_scalar_field(state, diagnostic_sfield_names(i)) + lump_mass = have_option(trim(sfield%option_path)//"/diagnostic/mass_matrix"//& &"/use_lumped_mass_matrix") - use_submesh = have_option(trim(sfield%option_path)//"/diagnostic/mass_matrix"//& + use_submesh = have_option(trim(sfield%option_path)//"/diagnostic/mass_matrix"//& &"/use_lumped_mass_matrix/use_submesh") ! For P2 meshes. - if(lump_mass) then - if(use_submesh) then - lumped_mass => get_lumped_mass_on_submesh(state, sfield%mesh) + if(lump_mass) then + if(use_submesh) then + lumped_mass => get_lumped_mass_on_submesh(state, sfield%mesh) + else + lumped_mass => get_lumped_mass(state, sfield%mesh) + end if + call allocate(inv_lumped_mass, sfield%mesh) + call invert(lumped_mass, inv_lumped_mass) + call scale(sfield, inv_lumped_mass) + call deallocate(inv_lumped_mass) else - lumped_mass => get_lumped_mass(state, sfield%mesh) + mass_matrix => get_mass_matrix(state, sfield%mesh) + call petsc_solve(sfield, mass_matrix, sfield, option_path=u%option_path) end if - call allocate(inv_lumped_mass, sfield%mesh) - call invert(lumped_mass, inv_lumped_mass) - call scale(sfield, inv_lumped_mass) - call deallocate(inv_lumped_mass) - else - mass_matrix => get_mass_matrix(state, sfield%mesh) - call petsc_solve(sfield, mass_matrix, sfield, option_path=u%option_path) end if - end if - end do diagnostic_sfield_loop - - end subroutine les_solve_diagnostic_fields - - subroutine leonard_tensor(nu, positions, fnu, tnu, leonard, strainprod, alpha, gamma, path) - - ! Unfiltered velocity - type(vector_field), pointer :: nu - type(vector_field), intent(in) :: positions - ! Filtered velocities - type(vector_field), pointer :: fnu, tnu - ! Leonard tensor and strain product - type(tensor_field), pointer :: leonard, strainprod - ! Scale factors - real, intent(in) :: alpha, gamma - character(len=OPTION_PATH_LEN), intent(in) :: path - ! Local quantities - type(tensor_field), pointer :: ui_uj, tui_tuj - character(len=OPTION_PATH_LEN) :: lpath - integer :: i, ele, gi - real, dimension(:), allocatable :: u_loc - real, dimension(:,:), allocatable :: t_loc - real, dimension(ele_loc(nu,1), ele_ngi(nu,1), nu%dim) :: du_t - real, dimension(ele_ngi(nu,1)) :: detwei - real, dimension(nu%dim, nu%dim, ele_ngi(nu,1)) :: strain_gi, strain_prod_gi - type(element_type) :: shape_nu - - ! Path is to level above solver options - lpath = (trim(path)//"/dynamic_les") - ewrite(2,*) "filter factor alpha: ", alpha - ewrite(2,*) "filter factor gamma: ", gamma - - ! First filter operator returns u^f: - call anisotropic_smooth_vector(nu, positions, fnu, alpha, lpath) - ! Test filter operator needs the ratio of test filter to mesh size and returns u^ft: - call anisotropic_smooth_vector(fnu, positions, tnu, alpha*gamma, lpath) - ewrite_minmax(nu) - ewrite_minmax(fnu) - ewrite_minmax(tnu) - - ! Velocity products (ui*uj) - allocate(ui_uj); allocate(tui_tuj) - call allocate(ui_uj, nu%mesh, "NonlinearVelocityProduct") - call allocate(tui_tuj, nu%mesh, "TestNonlinearVelocityProduct") - call zero(ui_uj); call zero(tui_tuj) - - ! Other local variables - allocate(u_loc(nu%dim)); allocate(t_loc(nu%dim, nu%dim)) - u_loc=0.0; t_loc=0.0 - - ! Get cross products of velocities - do i=1, node_count(nu) - u_loc = node_val(fnu,i) - t_loc = outer_product(u_loc, u_loc) - call set( ui_uj, i, t_loc ) - u_loc = node_val(tnu,i) - ! Calculate (test-filtered velocity) products: (ui^ft*uj^ft) - t_loc = outer_product(u_loc, u_loc) - call set( tui_tuj, i, t_loc ) - end do - - ! Calculate test-filtered (velocity products): (ui^f*uj^f)^t - call anisotropic_smooth_tensor(ui_uj, positions, leonard, alpha*gamma, lpath) - - ! Leonard tensor field - call addto( leonard, tui_tuj, -1.0 ) - - ! Zero tensor field for reuse in strain product assembly - call zero(ui_uj) - - do i=1, element_count(nu) - shape_nu = ele_shape(nu, i) - ! Assuming no FE stabilisation is used with LES so we can use velocity shape. - call transform_to_physical(positions, i, shape_nu, dshape=du_t, detwei=detwei) - ! Strain rate of first filtered velocity S1^f - strain_gi = les_strain_rate(du_t, ele_val(fnu, i)) - do gi=1, ele_ngi(nu, ele) - ! Strain product = strain modulus*strain rate: |S1^f|S1^f - strain_prod_gi(:,:,gi) = sqrt(2*sum(strain_gi(:,:,gi)*strain_gi(:,:,gi))) * strain_gi(:,:,gi) + end do diagnostic_sfield_loop + + end subroutine les_solve_diagnostic_fields + + subroutine leonard_tensor(nu, positions, fnu, tnu, leonard, strainprod, alpha, gamma, path) + + ! Unfiltered velocity + type(vector_field), pointer :: nu + type(vector_field), intent(in) :: positions + ! Filtered velocities + type(vector_field), pointer :: fnu, tnu + ! Leonard tensor and strain product + type(tensor_field), pointer :: leonard, strainprod + ! Scale factors + real, intent(in) :: alpha, gamma + character(len=OPTION_PATH_LEN), intent(in) :: path + ! Local quantities + type(tensor_field), pointer :: ui_uj, tui_tuj + character(len=OPTION_PATH_LEN) :: lpath + integer :: i, ele, gi + real, dimension(:), allocatable :: u_loc + real, dimension(:,:), allocatable :: t_loc + real, dimension(ele_loc(nu,1), ele_ngi(nu,1), nu%dim) :: du_t + real, dimension(ele_ngi(nu,1)) :: detwei + real, dimension(nu%dim, nu%dim, ele_ngi(nu,1)) :: strain_gi, strain_prod_gi + type(element_type) :: shape_nu + + ! Path is to level above solver options + lpath = (trim(path)//"/dynamic_les") + ewrite(2,*) "filter factor alpha: ", alpha + ewrite(2,*) "filter factor gamma: ", gamma + + ! First filter operator returns u^f: + call anisotropic_smooth_vector(nu, positions, fnu, alpha, lpath) + ! Test filter operator needs the ratio of test filter to mesh size and returns u^ft: + call anisotropic_smooth_vector(fnu, positions, tnu, alpha*gamma, lpath) + ewrite_minmax(nu) + ewrite_minmax(fnu) + ewrite_minmax(tnu) + + ! Velocity products (ui*uj) + allocate(ui_uj); allocate(tui_tuj) + call allocate(ui_uj, nu%mesh, "NonlinearVelocityProduct") + call allocate(tui_tuj, nu%mesh, "TestNonlinearVelocityProduct") + call zero(ui_uj); call zero(tui_tuj) + + ! Other local variables + allocate(u_loc(nu%dim)); allocate(t_loc(nu%dim, nu%dim)) + u_loc=0.0; t_loc=0.0 + + ! Get cross products of velocities + do i=1, node_count(nu) + u_loc = node_val(fnu,i) + t_loc = outer_product(u_loc, u_loc) + call set( ui_uj, i, t_loc ) + u_loc = node_val(tnu,i) + ! Calculate (test-filtered velocity) products: (ui^ft*uj^ft) + t_loc = outer_product(u_loc, u_loc) + call set( tui_tuj, i, t_loc ) + end do + + ! Calculate test-filtered (velocity products): (ui^f*uj^f)^t + call anisotropic_smooth_tensor(ui_uj, positions, leonard, alpha*gamma, lpath) + + ! Leonard tensor field + call addto( leonard, tui_tuj, -1.0 ) + + ! Zero tensor field for reuse in strain product assembly + call zero(ui_uj) + + do i=1, element_count(nu) + shape_nu = ele_shape(nu, i) + ! Assuming no FE stabilisation is used with LES so we can use velocity shape. + call transform_to_physical(positions, i, shape_nu, dshape=du_t, detwei=detwei) + ! Strain rate of first filtered velocity S1^f + strain_gi = les_strain_rate(du_t, ele_val(fnu, i)) + do gi=1, ele_ngi(nu, ele) + ! Strain product = strain modulus*strain rate: |S1^f|S1^f + strain_prod_gi(:,:,gi) = sqrt(2*sum(strain_gi(:,:,gi)*strain_gi(:,:,gi))) * strain_gi(:,:,gi) + end do + ! Assemble local tensor field + call addto(ui_uj, ele_nodes(nu,i), shape_tensor_rhs(ele_shape(nu,i), strain_prod_gi, detwei)) end do - ! Assemble local tensor field - call addto(ui_uj, ele_nodes(nu,i), shape_tensor_rhs(ele_shape(nu,i), strain_prod_gi, detwei)) - end do - ! Filter strain product with test filter: (|S1^f|S1^f)^t - call anisotropic_smooth_tensor(ui_uj, positions, strainprod, alpha*gamma, lpath) + ! Filter strain product with test filter: (|S1^f|S1^f)^t + call anisotropic_smooth_tensor(ui_uj, positions, strainprod, alpha*gamma, lpath) - ! Deallocates - deallocate(u_loc, t_loc) - call deallocate(ui_uj) - call deallocate(tui_tuj) - deallocate(ui_uj); deallocate(tui_tuj) + ! Deallocates + deallocate(u_loc, t_loc) + call deallocate(ui_uj) + call deallocate(tui_tuj) + deallocate(ui_uj); deallocate(tui_tuj) - end subroutine leonard_tensor + end subroutine leonard_tensor - function les_strain_rate(du_t, nu) - !! Computes the strain rate - !! derivative of velocity shape function (nloc x ngi x dim) - real, dimension(:,:,:), intent(in):: du_t - !! nonlinear velocity (dim x nloc) - real, dimension(:,:), intent(in):: nu - real, dimension( size(du_t,3),size(du_t,3),size(du_t,2) ):: les_strain_rate - real, dimension(size(du_t,3),size(du_t,3)):: s - integer dim, ngi, gi + function les_strain_rate(du_t, nu) + !! Computes the strain rate + !! derivative of velocity shape function (nloc x ngi x dim) + real, dimension(:,:,:), intent(in):: du_t + !! nonlinear velocity (dim x nloc) + real, dimension(:,:), intent(in):: nu + real, dimension( size(du_t,3),size(du_t,3),size(du_t,2) ):: les_strain_rate + real, dimension(size(du_t,3),size(du_t,3)):: s + integer dim, ngi, gi - ngi=size(du_t,2) - dim=size(du_t,3) + ngi=size(du_t,2) + dim=size(du_t,3) - do gi=1, ngi + do gi=1, ngi - s=0.5*matmul( nu, du_t(:,gi,:) ) - les_strain_rate(:,:,gi)=s+transpose(s) + s=0.5*matmul( nu, du_t(:,gi,:) ) + les_strain_rate(:,:,gi)=s+transpose(s) - end do + end do - end function les_strain_rate + end function les_strain_rate - function les_viscosity_strength(du_t, relu) - !! Computes the strain rate modulus for the LES model - !! derivative of velocity shape function (nloc x ngi x dim) - real, dimension(:,:,:), intent(in):: du_t - !! relative velocity (nonl. vel.- grid vel.) (dim x nloc) - real, dimension(:,:), intent(in):: relu + function les_viscosity_strength(du_t, relu) + !! Computes the strain rate modulus for the LES model + !! derivative of velocity shape function (nloc x ngi x dim) + real, dimension(:,:,:), intent(in):: du_t + !! relative velocity (nonl. vel.- grid vel.) (dim x nloc) + real, dimension(:,:), intent(in):: relu - real, dimension( size(du_t,2) ):: les_viscosity_strength + real, dimension( size(du_t,2) ):: les_viscosity_strength - real, dimension(size(du_t,3),size(du_t,3)):: s - real vis - integer dim, ngi, gi + real, dimension(size(du_t,3),size(du_t,3)):: s + real vis + integer dim, ngi, gi - ngi=size(du_t,2) - dim=size(du_t,3) + ngi=size(du_t,2) + dim=size(du_t,3) - do gi=1, ngi + do gi=1, ngi - s=0.5*matmul( relu, du_t(:,gi,:) ) - s=s+transpose(s) - ! Calculate modulus of strain rate - vis=sqrt( 2*sum( s**2 ) ) + s=0.5*matmul( relu, du_t(:,gi,:) ) + s=s+transpose(s) + ! Calculate modulus of strain rate + vis=sqrt( 2*sum( s**2 ) ) - les_viscosity_strength(gi)=vis + les_viscosity_strength(gi)=vis - end do + end do - end function les_viscosity_strength + end function les_viscosity_strength - function wale_viscosity_strength(du_t, relu) - !! Computes the traceless symmetric part of the square of - !! the resolved velocity gradient tensor for the LES model - !! See a WALE paper for more (G_{ij}) - !! derivative of velocity shape function (nloc x ngi x dim) - real, dimension(:,:,:), intent(in):: du_t - !! relative velocity (nonl. vel.- grid vel.) (dim x nloc) - real, dimension(:,:), intent(in):: relu + function wale_viscosity_strength(du_t, relu) + !! Computes the traceless symmetric part of the square of + !! the resolved velocity gradient tensor for the LES model + !! See a WALE paper for more (G_{ij}) + !! derivative of velocity shape function (nloc x ngi x dim) + real, dimension(:,:,:), intent(in):: du_t + !! relative velocity (nonl. vel.- grid vel.) (dim x nloc) + real, dimension(:,:), intent(in):: relu - real, dimension( size(du_t,2) ):: wale_viscosity_strength + real, dimension( size(du_t,2) ):: wale_viscosity_strength - real, dimension(size(du_t,3),size(du_t,3)):: s, g - real vis - integer dim, ngi, gi, i + real, dimension(size(du_t,3),size(du_t,3)):: s, g + real vis + integer dim, ngi, gi, i - ngi=size(du_t,2) - dim=size(du_t,3) + ngi=size(du_t,2) + dim=size(du_t,3) - do gi=1, ngi + do gi=1, ngi - s=matmul( relu, du_t(:,gi,:) ) - g=0.5*matmul(s,s) - g=g+transpose(g) - forall(i=1:dim) g(i,i)=0. + s=matmul( relu, du_t(:,gi,:) ) + g=0.5*matmul(s,s) + g=g+transpose(g) + forall(i=1:dim) g(i,i)=0. - vis=sqrt( 2*sum( g**2 ) ) + vis=sqrt( 2*sum( g**2 ) ) - wale_viscosity_strength(gi)=vis + wale_viscosity_strength(gi)=vis - end do + end do - end function wale_viscosity_strength + end function wale_viscosity_strength end module les_module diff --git a/assemble/Manifold_Projections.F90 b/assemble/Manifold_Projections.F90 index d40cba1a7c..71a16a1558 100644 --- a/assemble/Manifold_Projections.F90 +++ b/assemble/Manifold_Projections.F90 @@ -26,315 +26,315 @@ ! USA #include "fdebug.h" module manifold_projections - use fldebug - use futils, only: present_and_true - use vector_tools, only: solve - use fetools - use fields - use state_module - - implicit none + use fldebug + use futils, only: present_and_true + use vector_tools, only: solve + use fetools + use fields + use state_module + + implicit none + + interface project_cartesian_to_local + module procedure project_cartesian_to_local_generic, project_cartesian_to_local_state + end interface + + interface project_local_to_cartesian + module procedure project_local_to_cartesian_generic, project_local_to_cartesian_state + end interface + private + public :: project_cartesian_to_local, project_local_to_cartesian + +contains + + subroutine project_cartesian_to_local_state(state, field, transpose) + !!< Project the cartesian velocity to local coordinates + type(state_type), intent(inout) :: state + type(vector_field), pointer, intent(in) :: field + logical, intent(in), optional :: transpose + + integer :: ele + type(vector_field), pointer :: X, U_local, U_cartesian + + ewrite(1,*) "In project_cartesian_to_local" + + X=>extract_vector_field(state, "Coordinate") + U_local=>extract_vector_field(state, "Local"//field%name) + U_cartesian=>extract_vector_field(state, field%name) + + if (present_and_true(transpose)) then + do ele=1, element_count(U_local) + call project_cartesian_to_local_transpose_ele(ele, X, U_cartesian, U_local) + end do + else + do ele=1, element_count(U_local) + call project_cartesian_to_local_ele(ele, X, U_local, U_cartesian) + end do + end if + end subroutine project_cartesian_to_local_state + + ! In the case tranpose=.false., the third argument is the output + ! In the case tranpose=.true., the second argument is the output + subroutine project_cartesian_to_local_generic(X, in_field_cartesian, out_field_local, transpose) + !!< Project the cartesian velocity to local coordinates + type(vector_field), intent(in) :: X + type(vector_field), intent(inout) :: out_field_local, in_field_cartesian + logical, intent(in), optional :: transpose + + integer :: ele + + ewrite(1,*) "In project_cartesian_to_local" + + if (present_and_true(transpose)) then + do ele=1, element_count(out_field_local) + call project_cartesian_to_local_transpose_ele(ele, X, in_field_cartesian, out_field_local) + end do + else + do ele=1, element_count(out_field_local) + call project_cartesian_to_local_ele(ele, X, out_field_local, in_field_cartesian) + end do + end if + end subroutine project_cartesian_to_local_generic + + subroutine project_cartesian_to_local_ele(ele, X, U_local, U_cartesian) + !!< Project the cartesian velocity to local coordinates + integer, intent(in) :: ele + type(vector_field), intent(in) :: X, U_cartesian + type(vector_field), intent(inout) :: U_local + + real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_ngi(X,ele)) :: G + real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J + real, dimension(ele_ngi(X,ele)) :: detwei, detJ + real, dimension(U_cartesian%dim, ele_ngi(X,ele)) :: U_quad + real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_rhs + real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_loc(U_local,ele), ele_loc(U_local,ele)) :: l_mass + real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele), mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_big_mat + type(element_type), pointer :: U_shape + integer, dimension(:), pointer :: U_ele + integer :: dim, dim1, dim2, gi, loc, nloc + + dim=U_local%dim + + call compute_jacobian(X, ele, J, detwei, detJ) + + U_shape=>ele_shape(U_local,ele) + U_quad=ele_val_at_quad(U_cartesian,ele) + U_ele=>ele_nodes(U_local, ele) + + nloc=ele_loc(U_local,ele) + do dim1=1, dim + l_rhs((dim1-1)*nloc+1:dim1*nloc)=shape_rhs(U_shape, sum(& + J(dim1,:,:)*U_quad(:,:),dim=1)*U_shape%quadrature%weight) + end do - interface project_cartesian_to_local - module procedure project_cartesian_to_local_generic, project_cartesian_to_local_state - end interface + do gi=1,ele_ngi(X,ele) + G(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) + end do - interface project_local_to_cartesian - module procedure project_local_to_cartesian_generic, project_local_to_cartesian_state - end interface - private - public :: project_cartesian_to_local, project_local_to_cartesian + l_mass=shape_shape_tensor(u_shape, u_shape, & + u_shape%quadrature%weight, G) - contains + do dim1 = 1, dim + do dim2 = 1, dim + l_big_mat(nloc*(dim1-1)+1:nloc*dim1, & + nloc*(dim2-1)+1:nloc*dim2) = & + l_mass(dim1,dim2,:,:) + end do + end do - subroutine project_cartesian_to_local_state(state, field, transpose) - !!< Project the cartesian velocity to local coordinates - type(state_type), intent(inout) :: state - type(vector_field), pointer, intent(in) :: field - logical, intent(in), optional :: transpose + call solve(l_big_mat, l_rhs) - integer :: ele - type(vector_field), pointer :: X, U_local, U_cartesian + do dim1=1, U_local%dim + do loc=1, nloc + call set(U_local, dim1, U_ele(loc), l_rhs((dim1-1)*nloc+loc)) + end do + end do - ewrite(1,*) "In project_cartesian_to_local" + end subroutine project_cartesian_to_local_ele + + subroutine project_cartesian_to_local_transpose_ele(ele, X, U_cartesian, U_local) + !!< Project the cartesian velocity to local coordinates + integer, intent(in) :: ele + type(vector_field), intent(in) :: X, U_local + type(vector_field), intent(inout) :: U_cartesian + + real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_ngi(X,ele)) :: G + real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J + real, dimension(ele_ngi(X,ele)) :: detwei, detJ + real, dimension(U_cartesian%dim, ele_ngi(X,ele)) :: U_quad + real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_loc(U_local,ele), ele_loc(U_local,ele)) :: l_mass + real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele), mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_big_mat + real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele)) :: tmp + real, dimension(mesh_dim(U_local),ele_loc(U_local,ele)) :: U_local_ele + real, dimension(U_local%dim, ele_ngi(X, ele)) :: tmp_at_quad + real, dimension(X%dim, ele_ngi(X,ele)) :: U_cartesian_gi + real, dimension(X%dim, ele_loc(U_cartesian,ele)) :: rhs + type(element_type), pointer :: U_shape + integer, dimension(:), pointer :: U_ele + integer :: dim, dim1, dim2, gi, nloc + + dim=U_local%dim + + call compute_jacobian(X, ele, J, detwei, detJ) + + U_shape=>ele_shape(U_local,ele) + U_quad=ele_val_at_quad(U_cartesian,ele) + U_ele=>ele_nodes(U_local, ele) + + nloc=ele_loc(U_local,ele) + + do gi=1,ele_ngi(X,ele) + G(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) + end do - X=>extract_vector_field(state, "Coordinate") - U_local=>extract_vector_field(state, "Local"//field%name) - U_cartesian=>extract_vector_field(state, field%name) + l_mass=shape_shape_tensor(u_shape, u_shape, & + u_shape%quadrature%weight, G) - if (present_and_true(transpose)) then - do ele=1, element_count(U_local) - call project_cartesian_to_local_transpose_ele(ele, X, U_cartesian, U_local) - end do - else - do ele=1, element_count(U_local) - call project_cartesian_to_local_ele(ele, X, U_local, U_cartesian) + do dim1 = 1, dim + do dim2 = 1, dim + l_big_mat(nloc*(dim1-1)+1:nloc*dim1, & + nloc*(dim2-1)+1:nloc*dim2) = & + l_mass(dim1,dim2,:,:) + end do end do - end if - end subroutine project_cartesian_to_local_state - ! In the case tranpose=.false., the third argument is the output - ! In the case tranpose=.true., the second argument is the output - subroutine project_cartesian_to_local_generic(X, in_field_cartesian, out_field_local, transpose) - !!< Project the cartesian velocity to local coordinates - type(vector_field), intent(in) :: X - type(vector_field), intent(inout) :: out_field_local, in_field_cartesian - logical, intent(in), optional :: transpose + U_local_ele = ele_val(U_local, ele) + do dim1=1,U_local%dim + tmp(nloc*(dim1-1) + 1: nloc * dim1) = U_local_ele(dim1, :) + end do - integer :: ele + call solve(l_big_mat, tmp) + do dim1=1,U_local%dim + U_local_ele(dim1,:) = tmp(nloc*(dim1-1)+1:nloc*dim1) + end do + tmp_at_quad = matmul(U_local_ele, U_shape%n) - ewrite(1,*) "In project_cartesian_to_local" + U_cartesian_gi = 0.0 + do gi=1,ele_ngi(X, ele) + U_cartesian_gi(:, gi) = matmul(transpose(J(:, :, gi)), tmp_at_quad(:, gi)) + end do - if (present_and_true(transpose)) then - do ele=1, element_count(out_field_local) - call project_cartesian_to_local_transpose_ele(ele, X, in_field_cartesian, out_field_local) + rhs = shape_vector_rhs(U_shape, U_cartesian_gi, U_shape%quadrature%weight) + do dim1 = 1, U_cartesian%dim + call set(U_cartesian, dim1, ele_nodes(U_cartesian, ele), rhs(dim1, :)) end do - else - do ele=1, element_count(out_field_local) - call project_cartesian_to_local_ele(ele, X, out_field_local, in_field_cartesian) + + end subroutine project_cartesian_to_local_transpose_ele + + subroutine project_local_to_cartesian_state(state, adjoint, transpose) + !!< Project the local velocity to cartesian coordinates + type(state_type), intent(inout) :: state + logical, intent(in), optional :: adjoint, transpose + + integer :: ele + type(vector_field), pointer :: X, U_local, U_cartesian + + ewrite(1,*) "In project_local_to_cartesian" + + X=>extract_vector_field(state, "Coordinate") + if (present_and_true(adjoint)) then + U_local=>extract_vector_field(state, "AdjointLocalVelocity") + else + U_local=>extract_vector_field(state, "LocalVelocity") + endif + U_cartesian=>extract_vector_field(state, "Velocity") + + if (present_and_true(transpose)) then + do ele=1, element_count(U_cartesian) + call project_local_to_cartesian_transpose_ele(ele, X, U_local, U_cartesian) + end do + else + do ele=1, element_count(U_cartesian) + call project_local_to_cartesian_ele(ele, X, U_cartesian, U_local) + end do + end if + + end subroutine project_local_to_cartesian_state + + subroutine project_local_to_cartesian_generic(X, in_field_local, out_field_cartesian, transpose) + !!< Project the local velocity to cartesian coordinates + type(vector_field), intent(in) :: X + type(vector_field), intent(inout) :: out_field_cartesian, in_field_local + logical, intent(in), optional :: transpose + + integer :: ele + + ewrite(1,*) "In project_local_to_cartesian_generic" + + if (present_and_true(transpose)) then + do ele=1, element_count(out_field_cartesian) + call project_local_to_cartesian_transpose_ele(ele, X, in_field_local, out_field_cartesian) + end do + else + do ele=1, element_count(out_field_cartesian) + call project_local_to_cartesian_ele(ele, X, out_field_cartesian, in_field_local) + end do + end if + end subroutine project_local_to_cartesian_generic + + subroutine project_local_to_cartesian_ele(ele, X, U_cartesian, U_local) + !!< Project the local velocity to cartesian + integer, intent(in) :: ele + type(vector_field), intent(in) :: X, U_local + type(vector_field), intent(inout) :: U_cartesian + + real, dimension(ele_loc(U_cartesian,ele), ele_loc(U_cartesian,ele)) :: mass + real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J + real, dimension(ele_ngi(U_local,ele)) :: detwei + real, dimension(U_local%dim, ele_ngi(X,ele)) :: U_quad + real, dimension(X%dim, ele_ngi(X,ele)) :: U_cartesian_gi + real, dimension(X%dim, ele_loc(U_cartesian,ele)) :: rhs + type(element_type), pointer :: U_shape + integer :: d, gi + + call compute_jacobian(X, ele, J=J, detwei=detwei) + + U_shape=>ele_shape(U_cartesian,ele) + U_quad=ele_val_at_quad(U_local,ele) + + mass=shape_shape(U_shape, U_shape, detwei) + call invert(mass) + + U_cartesian_gi=0. + do gi=1, ele_ngi(X,ele) + U_cartesian_gi(:,gi)=matmul(transpose(J(:,:,gi)),U_quad(:,gi)) end do - end if - end subroutine project_cartesian_to_local_generic - - subroutine project_cartesian_to_local_ele(ele, X, U_local, U_cartesian) - !!< Project the cartesian velocity to local coordinates - integer, intent(in) :: ele - type(vector_field), intent(in) :: X, U_cartesian - type(vector_field), intent(inout) :: U_local - - real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_ngi(X,ele)) :: G - real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J - real, dimension(ele_ngi(X,ele)) :: detwei, detJ - real, dimension(U_cartesian%dim, ele_ngi(X,ele)) :: U_quad - real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_rhs - real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_loc(U_local,ele), ele_loc(U_local,ele)) :: l_mass - real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele), mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_big_mat - type(element_type), pointer :: U_shape - integer, dimension(:), pointer :: U_ele - integer :: dim, dim1, dim2, gi, loc, nloc - - dim=U_local%dim - - call compute_jacobian(X, ele, J, detwei, detJ) - - U_shape=>ele_shape(U_local,ele) - U_quad=ele_val_at_quad(U_cartesian,ele) - U_ele=>ele_nodes(U_local, ele) - - nloc=ele_loc(U_local,ele) - do dim1=1, dim - l_rhs((dim1-1)*nloc+1:dim1*nloc)=shape_rhs(U_shape, sum(& - J(dim1,:,:)*U_quad(:,:),dim=1)*U_shape%quadrature%weight) - end do - do gi=1,ele_ngi(X,ele) - G(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) - end do + rhs=shape_vector_rhs(U_shape, U_cartesian_gi, U_shape%quadrature%weight) - l_mass=shape_shape_tensor(u_shape, u_shape, & - u_shape%quadrature%weight, G) + do d=1,U_cartesian%dim + call set(U_cartesian, d, ele_nodes(U_cartesian,ele), matmul(mass,rhs(d,:))) + end do - do dim1 = 1, dim - do dim2 = 1, dim - l_big_mat(nloc*(dim1-1)+1:nloc*dim1, & - nloc*(dim2-1)+1:nloc*dim2) = & - l_mass(dim1,dim2,:,:) - end do - end do - - call solve(l_big_mat, l_rhs) - - do dim1=1, U_local%dim - do loc=1, nloc - call set(U_local, dim1, U_ele(loc), l_rhs((dim1-1)*nloc+loc)) - end do - end do - - end subroutine project_cartesian_to_local_ele - - subroutine project_cartesian_to_local_transpose_ele(ele, X, U_cartesian, U_local) - !!< Project the cartesian velocity to local coordinates - integer, intent(in) :: ele - type(vector_field), intent(in) :: X, U_local - type(vector_field), intent(inout) :: U_cartesian - - real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_ngi(X,ele)) :: G - real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J - real, dimension(ele_ngi(X,ele)) :: detwei, detJ - real, dimension(U_cartesian%dim, ele_ngi(X,ele)) :: U_quad - real, dimension(mesh_dim(U_local), mesh_dim(U_local), ele_loc(U_local,ele), ele_loc(U_local,ele)) :: l_mass - real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele), mesh_dim(U_local)*ele_loc(U_local,ele)) :: l_big_mat - real, dimension(mesh_dim(U_local)*ele_loc(U_local,ele)) :: tmp - real, dimension(mesh_dim(U_local),ele_loc(U_local,ele)) :: U_local_ele - real, dimension(U_local%dim, ele_ngi(X, ele)) :: tmp_at_quad - real, dimension(X%dim, ele_ngi(X,ele)) :: U_cartesian_gi - real, dimension(X%dim, ele_loc(U_cartesian,ele)) :: rhs - type(element_type), pointer :: U_shape - integer, dimension(:), pointer :: U_ele - integer :: dim, dim1, dim2, gi, nloc - - dim=U_local%dim - - call compute_jacobian(X, ele, J, detwei, detJ) - - U_shape=>ele_shape(U_local,ele) - U_quad=ele_val_at_quad(U_cartesian,ele) - U_ele=>ele_nodes(U_local, ele) - - nloc=ele_loc(U_local,ele) - - do gi=1,ele_ngi(X,ele) - G(:,:,gi)=matmul(J(:,:,gi), transpose(J(:,:,gi)))/detJ(gi) - end do - - l_mass=shape_shape_tensor(u_shape, u_shape, & - u_shape%quadrature%weight, G) + end subroutine project_local_to_cartesian_ele - do dim1 = 1, dim - do dim2 = 1, dim - l_big_mat(nloc*(dim1-1)+1:nloc*dim1, & - nloc*(dim2-1)+1:nloc*dim2) = & - l_mass(dim1,dim2,:,:) - end do - end do - - U_local_ele = ele_val(U_local, ele) - do dim1=1,U_local%dim - tmp(nloc*(dim1-1) + 1: nloc * dim1) = U_local_ele(dim1, :) - end do - - call solve(l_big_mat, tmp) - do dim1=1,U_local%dim - U_local_ele(dim1,:) = tmp(nloc*(dim1-1)+1:nloc*dim1) - end do - tmp_at_quad = matmul(U_local_ele, U_shape%n) - - U_cartesian_gi = 0.0 - do gi=1,ele_ngi(X, ele) - U_cartesian_gi(:, gi) = matmul(transpose(J(:, :, gi)), tmp_at_quad(:, gi)) - end do - - rhs = shape_vector_rhs(U_shape, U_cartesian_gi, U_shape%quadrature%weight) - do dim1 = 1, U_cartesian%dim - call set(U_cartesian, dim1, ele_nodes(U_cartesian, ele), rhs(dim1, :)) - end do - - end subroutine project_cartesian_to_local_transpose_ele - - subroutine project_local_to_cartesian_state(state, adjoint, transpose) - !!< Project the local velocity to cartesian coordinates - type(state_type), intent(inout) :: state - logical, intent(in), optional :: adjoint, transpose - - integer :: ele - type(vector_field), pointer :: X, U_local, U_cartesian - - ewrite(1,*) "In project_local_to_cartesian" - - X=>extract_vector_field(state, "Coordinate") - if (present_and_true(adjoint)) then - U_local=>extract_vector_field(state, "AdjointLocalVelocity") - else - U_local=>extract_vector_field(state, "LocalVelocity") - endif - U_cartesian=>extract_vector_field(state, "Velocity") - - if (present_and_true(transpose)) then - do ele=1, element_count(U_cartesian) - call project_local_to_cartesian_transpose_ele(ele, X, U_local, U_cartesian) - end do - else - do ele=1, element_count(U_cartesian) - call project_local_to_cartesian_ele(ele, X, U_cartesian, U_local) - end do - end if + subroutine project_local_to_cartesian_transpose_ele(ele, X, U_local, U_cartesian) + !!< Transpose of project the local velocity to cartesian + integer, intent(in) :: ele + type(vector_field), intent(in) :: X, U_cartesian + type(vector_field), intent(inout) :: U_local - end subroutine project_local_to_cartesian_state + real, dimension(ele_loc(U_cartesian,ele), ele_loc(U_cartesian,ele)) :: mass + real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J + real, dimension(ele_ngi(U_local,ele)) :: detwei + real, dimension(U_cartesian%dim, ele_loc(U_cartesian, ele)) :: tmp, U_cartesian_ele + type(element_type), pointer :: U_shape + integer :: d - subroutine project_local_to_cartesian_generic(X, in_field_local, out_field_cartesian, transpose) - !!< Project the local velocity to cartesian coordinates - type(vector_field), intent(in) :: X - type(vector_field), intent(inout) :: out_field_cartesian, in_field_local - logical, intent(in), optional :: transpose + call compute_jacobian(X, ele, J=J, detwei=detwei) - integer :: ele + U_shape=>ele_shape(U_cartesian,ele) - ewrite(1,*) "In project_local_to_cartesian_generic" + mass=shape_shape(U_shape, U_shape, detwei) + call invert(mass) + U_cartesian_ele = ele_val(U_cartesian, ele) - if (present_and_true(transpose)) then - do ele=1, element_count(out_field_cartesian) - call project_local_to_cartesian_transpose_ele(ele, X, in_field_local, out_field_cartesian) + do d=1,U_cartesian%dim + tmp(d, :) = matmul(mass, U_cartesian_ele(d, :)) end do - else - do ele=1, element_count(out_field_cartesian) - call project_local_to_cartesian_ele(ele, X, out_field_cartesian, in_field_local) + + do d=1,U_local%dim + call set(U_local, d, ele_nodes(U_local, ele), shape_rhs(U_shape, sum(J(d,:,:)*matmul(tmp, U_shape%n),dim=1)*U_shape%quadrature%weight)) end do - end if - end subroutine project_local_to_cartesian_generic - - subroutine project_local_to_cartesian_ele(ele, X, U_cartesian, U_local) - !!< Project the local velocity to cartesian - integer, intent(in) :: ele - type(vector_field), intent(in) :: X, U_local - type(vector_field), intent(inout) :: U_cartesian - - real, dimension(ele_loc(U_cartesian,ele), ele_loc(U_cartesian,ele)) :: mass - real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J - real, dimension(ele_ngi(U_local,ele)) :: detwei - real, dimension(U_local%dim, ele_ngi(X,ele)) :: U_quad - real, dimension(X%dim, ele_ngi(X,ele)) :: U_cartesian_gi - real, dimension(X%dim, ele_loc(U_cartesian,ele)) :: rhs - type(element_type), pointer :: U_shape - integer :: d, gi - - call compute_jacobian(X, ele, J=J, detwei=detwei) - - U_shape=>ele_shape(U_cartesian,ele) - U_quad=ele_val_at_quad(U_local,ele) - - mass=shape_shape(U_shape, U_shape, detwei) - call invert(mass) - - U_cartesian_gi=0. - do gi=1, ele_ngi(X,ele) - U_cartesian_gi(:,gi)=matmul(transpose(J(:,:,gi)),U_quad(:,gi)) - end do - - rhs=shape_vector_rhs(U_shape, U_cartesian_gi, U_shape%quadrature%weight) - - do d=1,U_cartesian%dim - call set(U_cartesian, d, ele_nodes(U_cartesian,ele), matmul(mass,rhs(d,:))) - end do - - end subroutine project_local_to_cartesian_ele - - subroutine project_local_to_cartesian_transpose_ele(ele, X, U_local, U_cartesian) - !!< Transpose of project the local velocity to cartesian - integer, intent(in) :: ele - type(vector_field), intent(in) :: X, U_cartesian - type(vector_field), intent(inout) :: U_local - - real, dimension(ele_loc(U_cartesian,ele), ele_loc(U_cartesian,ele)) :: mass - real, dimension(mesh_dim(U_local), X%dim, ele_ngi(X,ele)) :: J - real, dimension(ele_ngi(U_local,ele)) :: detwei - real, dimension(U_cartesian%dim, ele_loc(U_cartesian, ele)) :: tmp, U_cartesian_ele - type(element_type), pointer :: U_shape - integer :: d - - call compute_jacobian(X, ele, J=J, detwei=detwei) - - U_shape=>ele_shape(U_cartesian,ele) - - mass=shape_shape(U_shape, U_shape, detwei) - call invert(mass) - U_cartesian_ele = ele_val(U_cartesian, ele) - - do d=1,U_cartesian%dim - tmp(d, :) = matmul(mass, U_cartesian_ele(d, :)) - end do - - do d=1,U_local%dim - call set(U_local, d, ele_nodes(U_local, ele), shape_rhs(U_shape, sum(J(d,:,:)*matmul(tmp, U_shape%n),dim=1)*U_shape%quadrature%weight)) - end do - end subroutine project_local_to_cartesian_transpose_ele + end subroutine project_local_to_cartesian_transpose_ele end module manifold_projections diff --git a/assemble/Mba2d_Integration.F90 b/assemble/Mba2d_Integration.F90 index a8c244b41f..4c09dea187 100644 --- a/assemble/Mba2d_Integration.F90 +++ b/assemble/Mba2d_Integration.F90 @@ -1,378 +1,378 @@ #include "fdebug.h" module mba2d_integration - use fldebug - use spud - use global_parameters, only : current_debug_level - use futils, only: present_and_true - use quadrature - use elements - use eventcounter - use quicksort - use data_structures - use parallel_tools - use sparse_tools - use metric_tools - use fields - use state_module - use meshdiagnostics - use vtk_interfaces - use halos - use node_boundary - use interpolation_module - use limit_metric_module + use fldebug + use spud + use global_parameters, only : current_debug_level + use futils, only: present_and_true + use quadrature + use elements + use eventcounter + use quicksort + use data_structures + use parallel_tools + use sparse_tools + use metric_tools + use fields + use state_module + use meshdiagnostics + use vtk_interfaces + use halos + use node_boundary + use interpolation_module + use limit_metric_module #ifdef HAVE_MBA_2D - use mba2d_module + use mba2d_module #endif - use mba_adapt_module - use node_locking - use surface_id_interleaving - use adapt_integration - implicit none - - private - - public :: adapt_mesh_mba2d, mba2d_integration_check_options - - contains - - subroutine adapt_mesh_mba2d(input_positions, metric, output_positions, force_preserve_regions, & - lock_faces, allow_boundary_elements) - type(vector_field), intent(in), target :: input_positions - type(tensor_field), intent(in) :: metric - type(vector_field), intent(out) :: output_positions - logical, intent(in), optional :: force_preserve_regions - type(integer_set), intent(in), optional :: lock_faces - ! if present and true allow boundary elements, i.e. elements with - ! all nodes on the boundary, if not present, the default - ! in serial is to forbid boundary elements, and allow them in parallel - logical, intent(in), optional :: allow_boundary_elements + use mba_adapt_module + use node_locking + use surface_id_interleaving + use adapt_integration + implicit none + + private + + public :: adapt_mesh_mba2d, mba2d_integration_check_options + +contains + + subroutine adapt_mesh_mba2d(input_positions, metric, output_positions, force_preserve_regions, & + lock_faces, allow_boundary_elements) + type(vector_field), intent(in), target :: input_positions + type(tensor_field), intent(in) :: metric + type(vector_field), intent(out) :: output_positions + logical, intent(in), optional :: force_preserve_regions + type(integer_set), intent(in), optional :: lock_faces + ! if present and true allow boundary elements, i.e. elements with + ! all nodes on the boundary, if not present, the default + ! in serial is to forbid boundary elements, and allow them in parallel + logical, intent(in), optional :: allow_boundary_elements #ifdef HAVE_MBA_2D - type(mesh_type), pointer :: xmesh - - integer :: nonods, mxnods, orig_stotel, stotel, mxface, totele, maxele, stotel_external - real, dimension(:, :), allocatable :: pos - integer, dimension(:, :), allocatable :: ipf - integer, dimension(:, :), allocatable :: ipe - real, dimension(:, :), allocatable :: parcrv - integer, dimension(:), allocatable :: ipv - integer, dimension(:), allocatable :: ifv - integer, dimension(:), allocatable :: iFnc - integer, dimension(:), allocatable :: lbE - real, dimension(:, :), allocatable :: tmp_metric - integer :: i, j, partition_surface_id, face, face2 - real :: quality, rQuality - integer :: iPrint, ierr, maxWr, maxWi - real, dimension(:), allocatable :: rW - integer, dimension(:), allocatable :: iW - integer :: status - type(mesh_type) :: new_mesh - integer :: npv - integer :: xpctel - integer, dimension(:,:), allocatable:: new_sndgln - integer :: maxp - integer :: iterations - integer, dimension(:), allocatable :: locked_nodes - integer, dimension(:), pointer :: neighbours, faces - type(halo_type), pointer :: old_halo, new_halo - integer :: proc - - ! Surface ID interleaving - integer :: max_coplanar_id - integer, dimension(:), allocatable :: boundary_ids, coplanar_ids, surface_ids, mba_boundary_ids - type(integer_hash_table) :: physical_surface_ids - ! Element locking - integer :: nfe - integer, dimension(:), allocatable :: ife - integer, dimension(:), pointer:: nodes - integer :: ele - integer :: nfv - type(csr_sparsity), pointer :: nelist - ! Flattened halo data - integer :: nhalos - type(integer_hash_table) :: input_face_numbering_to_mba2d_numbering - - ! if we're parallel we'll need to reorder the region ids after the halo derivation - integer, dimension(:), allocatable :: old_new_region_ids, renumber_permutation + type(mesh_type), pointer :: xmesh + + integer :: nonods, mxnods, orig_stotel, stotel, mxface, totele, maxele, stotel_external + real, dimension(:, :), allocatable :: pos + integer, dimension(:, :), allocatable :: ipf + integer, dimension(:, :), allocatable :: ipe + real, dimension(:, :), allocatable :: parcrv + integer, dimension(:), allocatable :: ipv + integer, dimension(:), allocatable :: ifv + integer, dimension(:), allocatable :: iFnc + integer, dimension(:), allocatable :: lbE + real, dimension(:, :), allocatable :: tmp_metric + integer :: i, j, partition_surface_id, face, face2 + real :: quality, rQuality + integer :: iPrint, ierr, maxWr, maxWi + real, dimension(:), allocatable :: rW + integer, dimension(:), allocatable :: iW + integer :: status + type(mesh_type) :: new_mesh + integer :: npv + integer :: xpctel + integer, dimension(:,:), allocatable:: new_sndgln + integer :: maxp + integer :: iterations + integer, dimension(:), allocatable :: locked_nodes + integer, dimension(:), pointer :: neighbours, faces + type(halo_type), pointer :: old_halo, new_halo + integer :: proc + + ! Surface ID interleaving + integer :: max_coplanar_id + integer, dimension(:), allocatable :: boundary_ids, coplanar_ids, surface_ids, mba_boundary_ids + type(integer_hash_table) :: physical_surface_ids + ! Element locking + integer :: nfe + integer, dimension(:), allocatable :: ife + integer, dimension(:), pointer:: nodes + integer :: ele + integer :: nfv + type(csr_sparsity), pointer :: nelist + ! Flattened halo data + integer :: nhalos + type(integer_hash_table) :: input_face_numbering_to_mba2d_numbering + + ! if we're parallel we'll need to reorder the region ids after the halo derivation + integer, dimension(:), allocatable :: old_new_region_ids, renumber_permutation !#define DUMP_HALO_INTERPOLATION #ifdef DUMP_HALO_INTERPOLATION - type(mesh_type):: p0mesh - type(scalar_field):: locked_field - integer, save:: ix=0 + type(mesh_type):: p0mesh + type(scalar_field):: locked_field + integer, save:: ix=0 #endif #ifdef GIVE_LIPNIKOV_OUTPUT - integer :: rank - character(len=255) :: filename + integer :: rank + character(len=255) :: filename #endif !#define DUMP_HALO #ifdef DUMP_HALO - type(scalar_field) :: sends_sfield, receives_sfield + type(scalar_field) :: sends_sfield, receives_sfield #endif - ewrite(1, *) "In adapt_mesh_mba2d" - - assert(all(metric%dim == 2)) - - xmesh => input_positions%mesh - call deallocate_boundcount - call initialise_boundcount(xmesh, input_positions) - - ! mxnods is an option to adaptivity specifying the maximum number of nodes - xpctel = max(expected_elements(input_positions, metric), 5) - mxnods = max_nodes(input_positions, expected_nodes(input_positions, xpctel, global = .false.)) - - nonods = node_count(xmesh) - totele = ele_count(xmesh) - orig_stotel = unique_surface_element_count(xmesh) - mxface = int(max((float(mxnods) / float(nonods)) * orig_stotel * 3.5, 10000.0)) - maxele = int(max((float(mxnods) / float(nonods)) * totele * 1.5, 10000.0)) - maxp = mxnods * 1.2 - - allocate(pos(2, maxp)) - pos = 0.0 - do i=1,2 - pos(i, 1:nonods) = input_positions%val(i,:) - end do - - allocate(surface_ids(orig_stotel)) - call interleave_surface_ids(xmesh, surface_ids, max_coplanar_id) - - allocate(ipf(4, mxface)) - ipf = 0 - partition_surface_id = maxval(surface_ids) + 1 - stotel = 0 - stotel_external = 0 - - call allocate(input_face_numbering_to_mba2d_numbering) - do i=1,totele - neighbours => ele_neigh(xmesh, i) - faces => ele_faces(xmesh, i) - do j=1,3 ! 3 faces per element in 2D - if (neighbours(j) <= 0) then - face = faces(j) - stotel = stotel + 1 - call insert(input_face_numbering_to_mba2d_numbering, face, stotel) - ipf(1:2, stotel) = face_global_nodes(xmesh, face) - ipf(3, stotel) = 0 - if (face <= orig_stotel) then ! if facet is genuinely external, i.e. on the domain exterior - ipf(4, stotel) = surface_ids(face) - stotel_external = stotel_external + 1 - else if (face <= surface_element_count(xmesh)) then - ! this should only happen for the 2nd copy of an internal facet - ! so something's wrong in the faces admin - FLAbort("Detected external facet that's numbered incorrectly.") - else - ipf(4, stotel) = partition_surface_id - end if - end if + ewrite(1, *) "In adapt_mesh_mba2d" + + assert(all(metric%dim == 2)) + + xmesh => input_positions%mesh + call deallocate_boundcount + call initialise_boundcount(xmesh, input_positions) + + ! mxnods is an option to adaptivity specifying the maximum number of nodes + xpctel = max(expected_elements(input_positions, metric), 5) + mxnods = max_nodes(input_positions, expected_nodes(input_positions, xpctel, global = .false.)) + + nonods = node_count(xmesh) + totele = ele_count(xmesh) + orig_stotel = unique_surface_element_count(xmesh) + mxface = int(max((float(mxnods) / float(nonods)) * orig_stotel * 3.5, 10000.0)) + maxele = int(max((float(mxnods) / float(nonods)) * totele * 1.5, 10000.0)) + maxp = mxnods * 1.2 + + allocate(pos(2, maxp)) + pos = 0.0 + do i=1,2 + pos(i, 1:nonods) = input_positions%val(i,:) + end do + + allocate(surface_ids(orig_stotel)) + call interleave_surface_ids(xmesh, surface_ids, max_coplanar_id) + + allocate(ipf(4, mxface)) + ipf = 0 + partition_surface_id = maxval(surface_ids) + 1 + stotel = 0 + stotel_external = 0 + + call allocate(input_face_numbering_to_mba2d_numbering) + do i=1,totele + neighbours => ele_neigh(xmesh, i) + faces => ele_faces(xmesh, i) + do j=1,3 ! 3 faces per element in 2D + if (neighbours(j) <= 0) then + face = faces(j) + stotel = stotel + 1 + call insert(input_face_numbering_to_mba2d_numbering, face, stotel) + ipf(1:2, stotel) = face_global_nodes(xmesh, face) + ipf(3, stotel) = 0 + if (face <= orig_stotel) then ! if facet is genuinely external, i.e. on the domain exterior + ipf(4, stotel) = surface_ids(face) + stotel_external = stotel_external + 1 + else if (face <= surface_element_count(xmesh)) then + ! this should only happen for the 2nd copy of an internal facet + ! so something's wrong in the faces admin + FLAbort("Detected external facet that's numbered incorrectly.") + else + ipf(4, stotel) = partition_surface_id + end if + end if + end do end do - end do - - if (stotel_external mxface) then + FLAbort("Expected number of facets too small!") + end if + + allocate(ipe(3, maxele)) + ipe = 0 + do i=1,totele + ipe(:, i) = ele_nodes(xmesh, i) end do - end if - - if (.not. present(lock_faces)) then - nfv = 0 - allocate(ifv(nfv)) - else - nfv = key_count(lock_faces) - allocate(ifv(nfv)) - ifv = fetch(input_face_numbering_to_mba2d_numbering, set2vector(lock_faces)) - end if - - call deallocate(input_face_numbering_to_mba2d_numbering) - - deallocate(surface_ids) - - ! If you fail this, you need to know the following. - ! Divide the surface elements into three classes: - ! (a) physical surface elements (on the exterior of the domain) - ! (b) partition surface elements (on the boundary with another partition) - ! (c) internal surface elements (between elements of the mesh - ! When we allocated mxface, we only had the count of (a). - ! However, we actually want to pass (a) + (b) to mba2d. - ! Mxface was allocated with a nice big multiple to make sure that - ! there was enough space. - ! Afterwards, we went through and counted (b) and added it on to stotel. - ! But in a very odd situation, this might not be enough memory! - ! So either find a smarter number to set mxface, or make the multiple bigger. - if (stotel > mxface) then - FLAbort("Expected number of facets too small!") - end if - - allocate(ipe(3, maxele)) - ipe = 0 - do i=1,totele - ipe(:, i) = ele_nodes(xmesh, i) - end do - - nhalos = halo_count(xmesh) - assert(any(nhalos == (/0, 1, 2/))) - if(nhalos > 0) then + nhalos = halo_count(xmesh) + assert(any(nhalos == (/0, 1, 2/))) + if(nhalos > 0) then #ifdef DUMP_HALO_INTERPOLATION - p0mesh = piecewise_constant_mesh(xmesh, "P0Mesh") - call allocate(locked_field, p0mesh, "Locked") + p0mesh = piecewise_constant_mesh(xmesh, "P0Mesh") + call allocate(locked_field, p0mesh, "Locked") #endif - nelist => extract_nelist(xmesh) - - old_halo => xmesh%halos(nhalos) - - allocate(ife(totele)) - nfe = 0 - ele_loop: do ele=1, element_count(xmesh) - nodes => ele_nodes(xmesh, ele) - do j=1, size(nodes) - if (.not. node_owned(old_halo, nodes(j))) then - nfe = nfe +1 - ife(nfe) = ele + nelist => extract_nelist(xmesh) + + old_halo => xmesh%halos(nhalos) + + allocate(ife(totele)) + nfe = 0 + ele_loop: do ele=1, element_count(xmesh) + nodes => ele_nodes(xmesh, ele) + do j=1, size(nodes) + if (.not. node_owned(old_halo, nodes(j))) then + nfe = nfe +1 + ife(nfe) = ele #ifdef DUMP_HALO_INTERPOLATION - call set(locked_field, ele, 1.0) + call set(locked_field, ele, 1.0) #endif - cycle ele_loop - end if - end do - end do ele_loop + cycle ele_loop + end if + end do + end do ele_loop #ifdef DUMP_HALO_INTERPOLATION - call vtk_write_fields("locked", index=ix, position=input_positions, model=xmesh, sfields=(/ locked_field /)) - ix = ix+1 - call deallocate(locked_field) - call deallocate(p0mesh) + call vtk_write_fields("locked", index=ix, position=input_positions, model=xmesh, sfields=(/ locked_field /)) + ix = ix+1 + call deallocate(locked_field) + call deallocate(p0mesh) #endif - else - nfe = 0 - allocate(ife(nfe)) - end if - - ! construct list of nodes to be locked - call get_locked_nodes(input_positions, locked_nodes) - npv = count(boundcount > 1) + size(locked_nodes) - if (nhalos>0) then - npv = npv + halo_all_sends_count(old_halo) + halo_all_receives_count(old_halo) - end if - allocate(ipv(npv)) - j = 1 - - if (nhalos>0) then - ! lock the send and receive nodes - these are locked above already as halo 1 elements - ! but locking them here again, get back a list in the new numbering after the adapt - ! thus allowing us to reconstruct the halo - do proc=1, halo_proc_count(old_halo) - ipv(j:j+halo_send_count(old_halo, proc)-1) = halo_sends(old_halo, proc) - j = j + halo_send_count(old_halo, proc) - end do - do proc=1, halo_proc_count(old_halo) - ipv(j:j+halo_receive_count(old_halo, proc)-1) = halo_receives(old_halo, proc) - j = j + halo_receive_count(old_halo, proc) - end do - end if - - ! lock nodes on the boundary that are adjacent to more than one coplanar id, i.e. corner nodes - ! (see node_boundary module) - do i=1,nonods - if (boundcount(i) > 1) then - ipv(j) = i - j = j + 1 + else + nfe = 0 + allocate(ife(nfe)) + end if + + ! construct list of nodes to be locked + call get_locked_nodes(input_positions, locked_nodes) + npv = count(boundcount > 1) + size(locked_nodes) + if (nhalos>0) then + npv = npv + halo_all_sends_count(old_halo) + halo_all_receives_count(old_halo) + end if + allocate(ipv(npv)) + j = 1 + + if (nhalos>0) then + ! lock the send and receive nodes - these are locked above already as halo 1 elements + ! but locking them here again, get back a list in the new numbering after the adapt + ! thus allowing us to reconstruct the halo + do proc=1, halo_proc_count(old_halo) + ipv(j:j+halo_send_count(old_halo, proc)-1) = halo_sends(old_halo, proc) + j = j + halo_send_count(old_halo, proc) + end do + do proc=1, halo_proc_count(old_halo) + ipv(j:j+halo_receive_count(old_halo, proc)-1) = halo_receives(old_halo, proc) + j = j + halo_receive_count(old_halo, proc) + end do end if - end do - ! nodes locked as prescribed by python - ipv(j:) = locked_nodes - deallocate(locked_nodes) - allocate(parcrv(2, mxface)) - parcrv = 0 + ! lock nodes on the boundary that are adjacent to more than one coplanar id, i.e. corner nodes + ! (see node_boundary module) + do i=1,nonods + if (boundcount(i) > 1) then + ipv(j) = i + j = j + 1 + end if + end do + ! nodes locked as prescribed by python + ipv(j:) = locked_nodes + deallocate(locked_nodes) + + allocate(parcrv(2, mxface)) + parcrv = 0 - allocate(iFnc(mxface)) - iFnc = 0 + allocate(iFnc(mxface)) + iFnc = 0 - allocate(lbE(maxele)) - lbE = 1 - if ((associated(xmesh%region_ids)).and.& - (have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& + allocate(lbE(maxele)) + lbE = 1 + if ((associated(xmesh%region_ids)).and.& + (have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& .or.present_and_true(force_preserve_regions))) then - ! offset surface IDs by 1 because libmba2d requires them to be positive - lbE(1:totele) = xmesh%region_ids + 1 - end if - - allocate(tmp_metric(3, maxp)) - tmp_metric = 0.0 - do i=1,nonods - tmp_metric(1, i) = node_val(metric, 1, 1, i) - tmp_metric(2, i) = node_val(metric, 2, 2, i) - tmp_metric(3, i) = node_val(metric, 1, 2, i) - end do - - call relax_metric_locked_regions(tmp_metric, ife(1:nfe), input_positions) - - maxWr = (4 * maxp + 10 * nonods + mxface + maxele) * 1.5 - maxWi = (6 * maxp + 10 * nonods + 19 * mxface + 11 * maxele + 12 * totele) * 1.5 - allocate(rW(maxWr)) - allocate(iW(maxWi)) - - if (present(allow_boundary_elements)) then - if (allow_boundary_elements) then - status=0 + ! offset surface IDs by 1 because libmba2d requires them to be positive + lbE(1:totele) = xmesh%region_ids + 1 + end if + + allocate(tmp_metric(3, maxp)) + tmp_metric = 0.0 + do i=1,nonods + tmp_metric(1, i) = node_val(metric, 1, 1, i) + tmp_metric(2, i) = node_val(metric, 2, 2, i) + tmp_metric(3, i) = node_val(metric, 1, 2, i) + end do + + call relax_metric_locked_regions(tmp_metric, ife(1:nfe), input_positions) + + maxWr = (4 * maxp + 10 * nonods + mxface + maxele) * 1.5 + maxWi = (6 * maxp + 10 * nonods + 19 * mxface + 11 * maxele + 12 * totele) * 1.5 + allocate(rW(maxWr)) + allocate(iW(maxWi)) + + if (present(allow_boundary_elements)) then + if (allow_boundary_elements) then + status=0 + else + status=1 + end if + else if(nhalos > 0) then + ! we don't want to avoid boundary elements along the local domain + ! boundaries, as the ragged boundary will usually have a lot of + ! triangles with 2 faces on the boundary and we don't want to split + ! these up unnecessarily - unfortunately we can't only allow it + ! along local domain boundaries and forbid them on the global domain boundary + status = 0 ! allow boundary elements else - status=1 + status = 1 ! forbid boundary elements end if - else if(nhalos > 0) then - ! we don't want to avoid boundary elements along the local domain - ! boundaries, as the ragged boundary will usually have a lot of - ! triangles with 2 faces on the boundary and we don't want to split - ! these up unnecessarily - unfortunately we can't only allow it - ! along local domain boundaries and forbid them on the global domain boundary - status = 0 ! allow boundary elements - else - status = 1 ! forbid boundary elements - end if - - ! Now we decide how many iterations the library - ! should do. - ! Say the number of elements (totel) >> - ! the desired number of elements (xpctel). - ! Then it takes at least one iteration to remove it. - ! So, we should calibrate the number of iterations - ! we let it do, depending on how much work we expect it - ! to take. - iterations = max(50000, int(abs(totele - xpctel)*1.2)) - - ! Fine-tuning options - call get_option("/mesh_adaptivity/hr_adaptivity/adaptivity_library/libmba2d/quality", quality, default = 0.6) + + ! Now we decide how many iterations the library + ! should do. + ! Say the number of elements (totel) >> + ! the desired number of elements (xpctel). + ! Then it takes at least one iteration to remove it. + ! So, we should calibrate the number of iterations + ! we let it do, depending on how much work we expect it + ! to take. + iterations = max(50000, int(abs(totele - xpctel)*1.2)) + + ! Fine-tuning options + call get_option("/mesh_adaptivity/hr_adaptivity/adaptivity_library/libmba2d/quality", quality, default = 0.6) #ifdef GIVE_LIPNIKOV_OUTPUT - rank = getrank() - write(filename, '(a,i0,a)') "debug_", rank, ".ani" - call saveMani(nonods, stotel, totele, npv, 0, nfe, & - pos, ipf, ipe, ipv, ipv, ife, lbE, & - parcrv, iFnc, filename) + rank = getrank() + write(filename, '(a,i0,a)') "debug_", rank, ".ani" + call saveMani(nonods, stotel, totele, npv, 0, nfe, & + pos, ipf, ipe, ipv, ipv, ife, lbE, & + parcrv, iFnc, filename) #endif - iprint = min(max(current_debug_level * 5, 0), 9) + iprint = min(max(current_debug_level * 5, 0), 9) - call mbaNodal( & + call mbaNodal( & nonods, maxp, stotel, mxface, totele, maxele, npv, & pos, ipf, ipe, ipv, & CrvFunction_ani, parcrv, iFnc, & @@ -384,260 +384,260 @@ subroutine adapt_mesh_mba2d(input_positions, metric, output_positions, force_pre maxWr, maxWi, rW, iW, & iPrint, ierr) - call incrementeventcounter(EVENT_ADAPTIVITY) - call incrementeventcounter(EVENT_MESH_MOVEMENT) + call incrementeventcounter(EVENT_ADAPTIVITY) + call incrementeventcounter(EVENT_MESH_MOVEMENT) - ! Hooray! You didn't crash. Congratulations. Now let's assemble the output and interpolate. + ! Hooray! You didn't crash. Congratulations. Now let's assemble the output and interpolate. - call allocate(new_mesh, nonods, totele, ele_shape(xmesh, 1), trim(xmesh%name)) - ! Hack: untag these references so that people (i.e. me) don't get confused. - new_mesh%shape%refcount%tagged = .false. - new_mesh%shape%quadrature%refcount%tagged = .false. - new_mesh%ndglno = reshape(IPE(:, 1:totele), (/size(new_mesh%ndglno)/)) - new_mesh%option_path = xmesh%option_path + call allocate(new_mesh, nonods, totele, ele_shape(xmesh, 1), trim(xmesh%name)) + ! Hack: untag these references so that people (i.e. me) don't get confused. + new_mesh%shape%refcount%tagged = .false. + new_mesh%shape%quadrature%refcount%tagged = .false. + new_mesh%ndglno = reshape(IPE(:, 1:totele), (/size(new_mesh%ndglno)/)) + new_mesh%option_path = xmesh%option_path - if (.not. isparallel()) then - allocate(new_sndgln(1:2,1:stotel), mba_boundary_ids(1:stotel)) - new_sndgln = ipf(1:2,1:stotel) - mba_boundary_ids =ipf(4,1:stotel) - else - ! In parallel, we need to filter out the surface elements with colour partition_surface_id, because - ! they are not real external faces - call allocate(physical_surface_ids) - - j = 1 - do i=1,stotel - if (ipf(4, i) /= partition_surface_id) then - call insert(physical_surface_ids, j, i) - j = j + 1 - end if - end do - - ! number of surface elements without inter-partition surface elements - stotel = j - 1 - allocate(mba_boundary_ids(1:stotel), new_sndgln(1:2,1:stotel)) - do i=1, stotel - mba_boundary_ids(i) = ipf(4, fetch(physical_surface_ids, i)) - new_sndgln(1:2, i) = ipf(1:2, fetch(physical_surface_ids, i)) - end do - - do i=1, stotel - new_sndgln(1:2, i) = ipf(1:2, fetch(physical_surface_ids, i)) - end do - call deallocate(physical_surface_ids) - end if - - ! add_faces might create extra (internal) surface elements, so we - ! use the combined boundary+coplanar ids first - call add_faces(new_mesh, sndgln=reshape(new_sndgln, (/ 2*stotel /) ), & - boundary_ids=mba_boundary_ids) - deallocate(mba_boundary_ids) - deallocate(new_sndgln) - - ! and only deinterleave now we know the total number of elements in the surface mesh - ! add_faces will have copied the interleaved id to the second copy of each interior facet - stotel = surface_element_count(new_mesh) - allocate(boundary_ids(1:stotel), coplanar_ids(1:stotel)) - call deinterleave_surface_ids(new_mesh%faces%boundary_ids, max_coplanar_id, boundary_ids, coplanar_ids) - - new_mesh%faces%boundary_ids = boundary_ids - - if(associated(xmesh%faces%coplanar_ids)) then - allocate(new_mesh%faces%coplanar_ids(1:stotel)) - new_mesh%faces%coplanar_ids = coplanar_ids - end if - deallocate(boundary_ids, coplanar_ids) - - if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& - .or.present_and_true(force_preserve_regions)) then - allocate(new_mesh%region_ids(totele)) - new_mesh%region_ids = lbE(1:totele) - 1 - end if - - - call allocate(output_positions, 2, new_mesh, trim(input_positions%name)) - output_positions%option_path = input_positions%option_path - call deallocate(new_mesh) - call set_all(output_positions, pos(:, 1:nonods)) - - if(nhalos > 0) then - - allocate(output_positions%mesh%halos(nhalos)) - new_halo => output_positions%mesh%halos(nhalos) - - ! halo is the same in terms of n/o sends and receives, name, ordering_type, etc. - call allocate(new_halo, old_halo) - ! except for n/o owned nodes - call set_halo_nowned_nodes(new_halo, nonods-halo_all_receives_count(new_halo)) + if (.not. isparallel()) then + allocate(new_sndgln(1:2,1:stotel), mba_boundary_ids(1:stotel)) + new_sndgln = ipf(1:2,1:stotel) + mba_boundary_ids =ipf(4,1:stotel) + else + ! In parallel, we need to filter out the surface elements with colour partition_surface_id, because + ! they are not real external faces + call allocate(physical_surface_ids) + + j = 1 + do i=1,stotel + if (ipf(4, i) /= partition_surface_id) then + call insert(physical_surface_ids, j, i) + j = j + 1 + end if + end do + + ! number of surface elements without inter-partition surface elements + stotel = j - 1 + allocate(mba_boundary_ids(1:stotel), new_sndgln(1:2,1:stotel)) + do i=1, stotel + mba_boundary_ids(i) = ipf(4, fetch(physical_surface_ids, i)) + new_sndgln(1:2, i) = ipf(1:2, fetch(physical_surface_ids, i)) + end do + + do i=1, stotel + new_sndgln(1:2, i) = ipf(1:2, fetch(physical_surface_ids, i)) + end do + call deallocate(physical_surface_ids) + end if - j = 1 - do proc=1, halo_proc_count(new_halo) - call set_halo_sends(new_halo, proc, ipv(j:j+halo_send_count(new_halo, proc)-1)) - j = j + halo_send_count(new_halo, proc) - end do - do proc=1, halo_proc_count(new_halo) - call set_halo_receives(new_halo, proc, ipv(j:j+halo_receive_count(new_halo, proc)-1)) - j = j + halo_receive_count(new_halo, proc) - end do + ! add_faces might create extra (internal) surface elements, so we + ! use the combined boundary+coplanar ids first + call add_faces(new_mesh, sndgln=reshape(new_sndgln, (/ 2*stotel /) ), & + boundary_ids=mba_boundary_ids) + deallocate(mba_boundary_ids) + deallocate(new_sndgln) - allocate(renumber_permutation(totele)) + ! and only deinterleave now we know the total number of elements in the surface mesh + ! add_faces will have copied the interleaved id to the second copy of each interior facet + stotel = surface_element_count(new_mesh) + allocate(boundary_ids(1:stotel), coplanar_ids(1:stotel)) + call deinterleave_surface_ids(new_mesh%faces%boundary_ids, max_coplanar_id, boundary_ids, coplanar_ids) - if(nhalos == 2) then - ! Derive remaining halos - call derive_l1_from_l2_halo(output_positions%mesh, ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - ! Reorder the nodes for trailing receives consistency - call renumber_positions_trailing_receives(output_positions) + new_mesh%faces%boundary_ids = boundary_ids - allocate(output_positions%mesh%element_halos(2)) - ! Reorder the elements for trailing receives consistency - call derive_element_halo_from_node_halo(output_positions%mesh, & - & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) - else - ! Reorder the nodes for trailing receives consistency - call renumber_positions_trailing_receives(output_positions) - - allocate(output_positions%mesh%element_halos(1)) - ! Reorder the elements for trailing receives consistency - call derive_element_halo_from_node_halo(output_positions%mesh, & - & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) + if(associated(xmesh%faces%coplanar_ids)) then + allocate(new_mesh%faces%coplanar_ids(1:stotel)) + new_mesh%faces%coplanar_ids = coplanar_ids end if + deallocate(boundary_ids, coplanar_ids) if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& - .or.present_and_true(force_preserve_regions)) then - ! reorder the region_ids since all out elements have been jiggled about - allocate(old_new_region_ids(totele)) - old_new_region_ids = output_positions%mesh%region_ids - do i = 1, totele - output_positions%mesh%region_ids(renumber_permutation(i)) = old_new_region_ids(i) - end do - deallocate(old_new_region_ids) + .or.present_and_true(force_preserve_regions)) then + allocate(new_mesh%region_ids(totele)) + new_mesh%region_ids = lbE(1:totele) - 1 end if - deallocate(renumber_permutation) + call allocate(output_positions, 2, new_mesh, trim(input_positions%name)) + output_positions%option_path = input_positions%option_path + call deallocate(new_mesh) + call set_all(output_positions, pos(:, 1:nonods)) + + if(nhalos > 0) then + + allocate(output_positions%mesh%halos(nhalos)) + new_halo => output_positions%mesh%halos(nhalos) + + ! halo is the same in terms of n/o sends and receives, name, ordering_type, etc. + call allocate(new_halo, old_halo) + ! except for n/o owned nodes + call set_halo_nowned_nodes(new_halo, nonods-halo_all_receives_count(new_halo)) + + j = 1 + do proc=1, halo_proc_count(new_halo) + call set_halo_sends(new_halo, proc, ipv(j:j+halo_send_count(new_halo, proc)-1)) + j = j + halo_send_count(new_halo, proc) + end do + do proc=1, halo_proc_count(new_halo) + call set_halo_receives(new_halo, proc, ipv(j:j+halo_receive_count(new_halo, proc)-1)) + j = j + halo_receive_count(new_halo, proc) + end do + + allocate(renumber_permutation(totele)) + + if(nhalos == 2) then + ! Derive remaining halos + call derive_l1_from_l2_halo(output_positions%mesh, ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + ! Reorder the nodes for trailing receives consistency + call renumber_positions_trailing_receives(output_positions) + + allocate(output_positions%mesh%element_halos(2)) + ! Reorder the elements for trailing receives consistency + call derive_element_halo_from_node_halo(output_positions%mesh, & + & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) + else + ! Reorder the nodes for trailing receives consistency + call renumber_positions_trailing_receives(output_positions) + + allocate(output_positions%mesh%element_halos(1)) + ! Reorder the elements for trailing receives consistency + call derive_element_halo_from_node_halo(output_positions%mesh, & + & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + call renumber_positions_elements_trailing_receives(output_positions, permutation=renumber_permutation) + end if + + if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& + .or.present_and_true(force_preserve_regions)) then + ! reorder the region_ids since all out elements have been jiggled about + allocate(old_new_region_ids(totele)) + old_new_region_ids = output_positions%mesh%region_ids + do i = 1, totele + output_positions%mesh%region_ids(renumber_permutation(i)) = old_new_region_ids(i) + end do + deallocate(old_new_region_ids) + end if + + deallocate(renumber_permutation) -#ifdef DUMP_HALO - call allocate(sends_sfield, output_positions%mesh, "Sends") - call zero(sends_sfield) - call allocate(receives_sfield, output_positions%mesh, "Receives") - call zero(receives_sfield) - - do proc=1,halo_proc_count(output_positions%mesh%halos(1)) - do i=1,size(output_positions%mesh%halos(1)%sends(proc)%ptr) - call set(sends_sfield, output_positions%mesh%halos(1)%sends(proc)%ptr(i), 1.0) - end do - do i=1,size(output_positions%mesh%halos(1)%receives(proc)%ptr) - call set(receives_sfield, output_positions%mesh%halos(1)%receives(proc)%ptr(i), 1.0) - end do - end do - - call vtk_write_fields("halo", position=output_positions, model=output_positions%mesh, sfields=(/sends_sfield, receives_sfield/)) - call deallocate(sends_sfield) - call deallocate(receives_sfield) +#ifdef DUMP_HALO + call allocate(sends_sfield, output_positions%mesh, "Sends") + call zero(sends_sfield) + call allocate(receives_sfield, output_positions%mesh, "Receives") + call zero(receives_sfield) + + do proc=1,halo_proc_count(output_positions%mesh%halos(1)) + do i=1,size(output_positions%mesh%halos(1)%sends(proc)%ptr) + call set(sends_sfield, output_positions%mesh%halos(1)%sends(proc)%ptr(i), 1.0) + end do + do i=1,size(output_positions%mesh%halos(1)%receives(proc)%ptr) + call set(receives_sfield, output_positions%mesh%halos(1)%receives(proc)%ptr(i), 1.0) + end do + end do + + call vtk_write_fields("halo", position=output_positions, model=output_positions%mesh, sfields=(/sends_sfield, receives_sfield/)) + + call deallocate(sends_sfield) + call deallocate(receives_sfield) #endif - ! Adaptivity is not guaranteed to return halo elements in the same - ! order in which they went in. We therefore need to fix this order. - call reorder_element_numbering(output_positions) + ! Adaptivity is not guaranteed to return halo elements in the same + ! order in which they went in. We therefore need to fix this order. + call reorder_element_numbering(output_positions) #ifdef DDEBUG - do i = 1, nhalos - assert(trailing_receives_consistent(output_positions%mesh%halos(i))) - assert(halo_valid_for_communication(output_positions%mesh%halos(i))) - assert(halo_verifies(output_positions%mesh%halos(i), output_positions)) - end do + do i = 1, nhalos + assert(trailing_receives_consistent(output_positions%mesh%halos(i))) + assert(halo_valid_for_communication(output_positions%mesh%halos(i))) + assert(halo_verifies(output_positions%mesh%halos(i), output_positions)) + end do #endif - end if + end if - deallocate(pos) - deallocate(ipf) - deallocate(ipe) - deallocate(ipv) - deallocate(parcrv) - deallocate(iFnc) - deallocate(lbE) - deallocate(rW) - deallocate(iW) - deallocate(tmp_metric) + deallocate(pos) + deallocate(ipf) + deallocate(ipe) + deallocate(ipv) + deallocate(parcrv) + deallocate(iFnc) + deallocate(lbE) + deallocate(rW) + deallocate(iW) + deallocate(tmp_metric) - ewrite(1, *) "Exiting adapt_mesh_mba2d" + ewrite(1, *) "Exiting adapt_mesh_mba2d" #else - FLExit("You called mba_adapt without the mba2d library. Reconfigure with --enable-2d-adaptivity") + FLExit("You called mba_adapt without the mba2d library. Reconfigure with --enable-2d-adaptivity") #endif - end subroutine adapt_mesh_mba2d - - subroutine relax_metric_locked_regions(metric, locked_elements, positions) - ! in the locked regions (halo regions in parallel) and the region immediately - ! adjacent to it, mba can't satisfy what we ask for in the metric - ! This tends to upset mba and sometimes leads it to give up altogether (leaving other regions - ! unadapted). Therefore we adjust the metric in the nodes of the locked regions to adhere to - ! the locked elements (i.e. tell mba that the mesh is perfect there already). Directly adjacent to - ! the locked region it will interpolate linearly between the overwritten metric and the metric we want, - ! so that it still adapts to our desired quality everywhere it is allowed to. - real, dimension(:,:), intent(inout):: metric - integer, dimension(:), intent(in):: locked_elements - type(vector_field), intent(in):: positions - - real, dimension(2,2) :: ele_metric - real, dimension(3) :: ele_metric_vector - integer, dimension(:), allocatable:: adjacent_locked_element_count - integer, dimension(:), pointer:: nodes - integer :: i, j, ele, n - - ! keep track of how many element metrics we've added into each node already - allocate(adjacent_locked_element_count(1:node_count(positions))) - adjacent_locked_element_count = 0 - - do i=1, size(locked_elements) - ele = locked_elements(i) - ele_metric = simplex_tensor(positions, ele) - ele_metric_vector(1) = ele_metric(1,1) - ele_metric_vector(2) = ele_metric(2,2) - ele_metric_vector(3) = ele_metric(1,2) - nodes => ele_nodes(positions, ele) - do j=1, size(nodes) - n = adjacent_locked_element_count(nodes(j)) - ! take running average of all 'element metric's for the elements adjacent to the nodes - ! note that in the first contribution, n=0, we throw out the metric values that were there originally - metric(:,nodes(j)) = (n*metric(:,nodes(j))+ele_metric_vector)/(n+1) - adjacent_locked_element_count(nodes(j)) = n+1 + end subroutine adapt_mesh_mba2d + + subroutine relax_metric_locked_regions(metric, locked_elements, positions) + ! in the locked regions (halo regions in parallel) and the region immediately + ! adjacent to it, mba can't satisfy what we ask for in the metric + ! This tends to upset mba and sometimes leads it to give up altogether (leaving other regions + ! unadapted). Therefore we adjust the metric in the nodes of the locked regions to adhere to + ! the locked elements (i.e. tell mba that the mesh is perfect there already). Directly adjacent to + ! the locked region it will interpolate linearly between the overwritten metric and the metric we want, + ! so that it still adapts to our desired quality everywhere it is allowed to. + real, dimension(:,:), intent(inout):: metric + integer, dimension(:), intent(in):: locked_elements + type(vector_field), intent(in):: positions + + real, dimension(2,2) :: ele_metric + real, dimension(3) :: ele_metric_vector + integer, dimension(:), allocatable:: adjacent_locked_element_count + integer, dimension(:), pointer:: nodes + integer :: i, j, ele, n + + ! keep track of how many element metrics we've added into each node already + allocate(adjacent_locked_element_count(1:node_count(positions))) + adjacent_locked_element_count = 0 + + do i=1, size(locked_elements) + ele = locked_elements(i) + ele_metric = simplex_tensor(positions, ele) + ele_metric_vector(1) = ele_metric(1,1) + ele_metric_vector(2) = ele_metric(2,2) + ele_metric_vector(3) = ele_metric(1,2) + nodes => ele_nodes(positions, ele) + do j=1, size(nodes) + n = adjacent_locked_element_count(nodes(j)) + ! take running average of all 'element metric's for the elements adjacent to the nodes + ! note that in the first contribution, n=0, we throw out the metric values that were there originally + metric(:,nodes(j)) = (n*metric(:,nodes(j))+ele_metric_vector)/(n+1) + adjacent_locked_element_count(nodes(j)) = n+1 + end do end do - end do - end subroutine relax_metric_locked_regions + end subroutine relax_metric_locked_regions - subroutine mba2d_integration_check_options - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" - integer :: dim, stat + subroutine mba2d_integration_check_options + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + integer :: dim, stat - if(.not. have_option(base_path)) then - ! Nothing to check - return - end if + if(.not. have_option(base_path)) then + ! Nothing to check + return + end if - call get_option("/geometry/dimension", dim, stat) - if(stat /= SPUD_NO_ERROR) then - ! This isn't the place to complain about this error - return - else if(have_option(base_path // "/adaptivity_library/libmba2d") .or. dim == 2) then + call get_option("/geometry/dimension", dim, stat) + if(stat /= SPUD_NO_ERROR) then + ! This isn't the place to complain about this error + return + else if(have_option(base_path // "/adaptivity_library/libmba2d") .or. dim == 2) then #ifndef HAVE_MBA_2D - FLExit("Cannot use libmba2d without the libmba2d library. Reconfigure with --enable-2d-adaptivity") + FLExit("Cannot use libmba2d without the libmba2d library. Reconfigure with --enable-2d-adaptivity") #endif #ifndef HAVE_ZOLTAN - if(isparallel()) then - ewrite(0, *) "Warning: It is recommended that you use zoltan with libmba2d in parallel. Reconfigure with --with-zoltan" - end if + if(isparallel()) then + ewrite(0, *) "Warning: It is recommended that you use zoltan with libmba2d in parallel. Reconfigure with --with-zoltan" + end if #endif - if((dim /= 2).and.(.not.(have_option(base_path // "/vertically_structured_adaptivity").and.(dim==3)))) then - FLExit("libmba2d can only be used in 2D or 2+1D") + if((dim /= 2).and.(.not.(have_option(base_path // "/vertically_structured_adaptivity").and.(dim==3)))) then + FLExit("libmba2d can only be used in 2D or 2+1D") + end if end if - end if - end subroutine mba2d_integration_check_options + end subroutine mba2d_integration_check_options end module mba2d_integration diff --git a/assemble/Mba3d_Integration.F90 b/assemble/Mba3d_Integration.F90 index 9498577a1e..bb269b40ae 100644 --- a/assemble/Mba3d_Integration.F90 +++ b/assemble/Mba3d_Integration.F90 @@ -29,202 +29,202 @@ module mba3d_integration - use iso_c_binding, only: c_double - use fldebug - use futils, only: present_and_true - use quadrature - use elements - use spud - use parallel_tools - use fields - use halos - use limit_metric_module - use node_locking - use surface_id_interleaving - use adapt_integration + use iso_c_binding, only: c_double + use fldebug + use futils, only: present_and_true + use quadrature + use elements + use spud + use parallel_tools + use fields + use halos + use limit_metric_module + use node_locking + use surface_id_interleaving + use adapt_integration #ifdef HAVE_MBA_3D - use mba3d_mba_nodal + use mba3d_mba_nodal #endif - implicit none + implicit none - private + private - public :: adapt_mesh_mba3d, mba3d_integration_check_options + public :: adapt_mesh_mba3d, mba3d_integration_check_options - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" contains - subroutine adapt_mesh_mba3d(input_positions, metric, output_positions, force_preserve_regions) - !!< Adapt the supplied input mesh using libmba3d. Return the new adapted - !!< mesh in output_positions (which is allocated by this routine). - !!< input_positions and output_positions are the Coordinate fields of - !!< the old and new meshes respectively. - - type(vector_field), intent(in) :: input_positions - type(tensor_field), intent(in) :: metric - type(vector_field), intent(out) :: output_positions - logical, intent(in), optional :: force_preserve_regions - - ! Linear tets only - integer, parameter :: dim = 3, nloc = 4, snloc = 3 - - integer :: i, max_coplanar_id - integer, dimension(:), allocatable :: boundary_ids, coplanar_ids, sndgln - real, parameter :: limit_buffer = 5.0, memory_buffer = 2.0 - type(element_type) :: output_shape - type(mesh_type) :: output_mesh - type(quadrature_type) :: output_quad - - ! mbanodal arguments - ! Group (M) - integer :: np, maxp, nf, maxf, ne, maxe - real(kind = c_double), dimension(:, :), allocatable :: xyp - integer, dimension(:, :), allocatable :: ipf, ipe - integer, dimension(:), allocatable :: lbf, lbe - integer :: nestar - ! Group (Dev) - integer :: npv, nfv, nev - integer, dimension(:), allocatable :: ipv, ifv, iev - logical :: flagauto - integer :: status - ! Group (Q) - integer :: maxskipe, maxqitr - real(kind = c_double), dimension(:, :), allocatable :: metric_handle - real(kind = c_double) :: quality, rquality - ! Group (W) - integer :: maxwr, maxwi - real(kind = c_double), dimension(:), allocatable :: rw - integer, dimension(:), allocatable :: iw - integer :: iprint, ierr - - ewrite(1, *) "In adapt_mesh_mba_3d" - - assert(input_positions%dim == 3) - assert(ele_loc(input_positions, 1) == 4) + subroutine adapt_mesh_mba3d(input_positions, metric, output_positions, force_preserve_regions) + !!< Adapt the supplied input mesh using libmba3d. Return the new adapted + !!< mesh in output_positions (which is allocated by this routine). + !!< input_positions and output_positions are the Coordinate fields of + !!< the old and new meshes respectively. + + type(vector_field), intent(in) :: input_positions + type(tensor_field), intent(in) :: metric + type(vector_field), intent(out) :: output_positions + logical, intent(in), optional :: force_preserve_regions + + ! Linear tets only + integer, parameter :: dim = 3, nloc = 4, snloc = 3 + + integer :: i, max_coplanar_id + integer, dimension(:), allocatable :: boundary_ids, coplanar_ids, sndgln + real, parameter :: limit_buffer = 5.0, memory_buffer = 2.0 + type(element_type) :: output_shape + type(mesh_type) :: output_mesh + type(quadrature_type) :: output_quad + + ! mbanodal arguments + ! Group (M) + integer :: np, maxp, nf, maxf, ne, maxe + real(kind = c_double), dimension(:, :), allocatable :: xyp + integer, dimension(:, :), allocatable :: ipf, ipe + integer, dimension(:), allocatable :: lbf, lbe + integer :: nestar + ! Group (Dev) + integer :: npv, nfv, nev + integer, dimension(:), allocatable :: ipv, ifv, iev + logical :: flagauto + integer :: status + ! Group (Q) + integer :: maxskipe, maxqitr + real(kind = c_double), dimension(:, :), allocatable :: metric_handle + real(kind = c_double) :: quality, rquality + ! Group (W) + integer :: maxwr, maxwi + real(kind = c_double), dimension(:), allocatable :: rw + integer, dimension(:), allocatable :: iw + integer :: iprint, ierr + + ewrite(1, *) "In adapt_mesh_mba_3d" + + assert(input_positions%dim == 3) + assert(ele_loc(input_positions, 1) == 4) #ifdef DDEBUG - if(surface_element_count(input_positions) > 0) then - assert(associated(input_positions%mesh%faces)) - assert(face_loc(input_positions, 1) == 3) - end if + if(surface_element_count(input_positions) > 0) then + assert(associated(input_positions%mesh%faces)) + assert(face_loc(input_positions, 1) == 3) + end if #endif - assert(metric%mesh == input_positions%mesh) - - ewrite(2, *) "Forming mbanodal arguments" - - ewrite(2, *) "Forming group (M) arguments" - - nestar = expected_elements(input_positions, metric, global = .false.) - - ! Factor of limit_buffer buffers in limits - np = node_count(input_positions) - maxp = max_nodes(input_positions, expected_nodes(input_positions, nestar, global = .false.)) * limit_buffer - nf = unique_surface_element_count(input_positions%mesh) - maxf = max(int(((maxp * 1.0) / (np * 1.0)) * nf), nf) * limit_buffer + 1 - ne = ele_count(input_positions) - maxe = max(nestar, ne) * limit_buffer + 1 - - allocate(xyp(dim, maxp)) - xyp = 0.0 - do i = 1, dim - xyp(i, :np) = input_positions%val(i,:) - end do - - allocate(ipf(snloc, maxf)) - ipf = 0 - allocate(sndgln(nf * snloc)) - call getsndgln(input_positions%mesh, sndgln) - ipf(:, :nf) = reshape(sndgln, (/snloc, nf/)) - deallocate(sndgln) - - allocate(ipe(nloc, maxe)) - ipe = 0 - ipe(:, :ne) = reshape(input_positions%mesh%ndglno, (/nloc, ne/)) - - allocate(lbf(maxf)) - lbf = 0 - call interleave_surface_ids(input_positions%mesh, lbf(:nf), max_coplanar_id) - if(minval(lbf(:nf)) < 0) then - FLExit("libmba3d does not permit negative surface IDs") - end if - if(maxval(lbf(:nf)) >= huge(0)) then - FLAbort("Exceeded max surface ID allowed by libmba3d") - end if - ! Offset surface IDs by 1, as libmba3d requires them to be positive - lbf(:nf) = lbf(:nf) + 1 - if(maxval(lbf(:nf)) >= maxf - 100) then - FLAbort("Exceeded max surface ID allowed by libmba3d") - end if - - allocate(lbe(maxe)) - if(associated(input_positions%mesh%region_ids).and.& - (have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& - .or.present_and_true(force_preserve_regions))) then - lbe(:ne) = input_positions%mesh%region_ids - if(minval(lbe(:ne)) < 0) then - FLExit("libmba3d does not permit negative region IDs") + assert(metric%mesh == input_positions%mesh) + + ewrite(2, *) "Forming mbanodal arguments" + + ewrite(2, *) "Forming group (M) arguments" + + nestar = expected_elements(input_positions, metric, global = .false.) + + ! Factor of limit_buffer buffers in limits + np = node_count(input_positions) + maxp = max_nodes(input_positions, expected_nodes(input_positions, nestar, global = .false.)) * limit_buffer + nf = unique_surface_element_count(input_positions%mesh) + maxf = max(int(((maxp * 1.0) / (np * 1.0)) * nf), nf) * limit_buffer + 1 + ne = ele_count(input_positions) + maxe = max(nestar, ne) * limit_buffer + 1 + + allocate(xyp(dim, maxp)) + xyp = 0.0 + do i = 1, dim + xyp(i, :np) = input_positions%val(i,:) + end do + + allocate(ipf(snloc, maxf)) + ipf = 0 + allocate(sndgln(nf * snloc)) + call getsndgln(input_positions%mesh, sndgln) + ipf(:, :nf) = reshape(sndgln, (/snloc, nf/)) + deallocate(sndgln) + + allocate(ipe(nloc, maxe)) + ipe = 0 + ipe(:, :ne) = reshape(input_positions%mesh%ndglno, (/nloc, ne/)) + + allocate(lbf(maxf)) + lbf = 0 + call interleave_surface_ids(input_positions%mesh, lbf(:nf), max_coplanar_id) + if(minval(lbf(:nf)) < 0) then + FLExit("libmba3d does not permit negative surface IDs") + end if + if(maxval(lbf(:nf)) >= huge(0)) then + FLAbort("Exceeded max surface ID allowed by libmba3d") end if - if(maxval(lbe(:ne)) >= huge(0)) then - FLExit("Exceeded max region ID allowed by libmba3d") + ! Offset surface IDs by 1, as libmba3d requires them to be positive + lbf(:nf) = lbf(:nf) + 1 + if(maxval(lbf(:nf)) >= maxf - 100) then + FLAbort("Exceeded max surface ID allowed by libmba3d") end if - ! Offset region IDs by 1, as libmba3d requires them to be positive - lbe(:ne) = lbe(:ne) + 1 - else - lbe = 1 - end if - ewrite(2, *) "Forming group (Dev) arguments" + allocate(lbe(maxe)) + if(associated(input_positions%mesh%region_ids).and.& + (have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& + .or.present_and_true(force_preserve_regions))) then + lbe(:ne) = input_positions%mesh%region_ids + if(minval(lbe(:ne)) < 0) then + FLExit("libmba3d does not permit negative region IDs") + end if + if(maxval(lbe(:ne)) >= huge(0)) then + FLExit("Exceeded max region ID allowed by libmba3d") + end if + ! Offset region IDs by 1, as libmba3d requires them to be positive + lbe(:ne) = lbe(:ne) + 1 + else + lbe = 1 + end if - ! Locked nodes - call get_locked_nodes(input_positions, ipv) - npv = size(ipv) + ewrite(2, *) "Forming group (Dev) arguments" - ! Locked faces - nfv = 0 - allocate(ifv(nfv)) + ! Locked nodes + call get_locked_nodes(input_positions, ipv) + npv = size(ipv) - ! Locked elements - nev = 0 - allocate(iev(nev)) + ! Locked faces + nfv = 0 + allocate(ifv(nfv)) - flagauto = .true. - status = 0 + ! Locked elements + nev = 0 + allocate(iev(nev)) - ewrite(2, *) "Forming group (Q) arguments" + flagauto = .true. + status = 0 - maxskipe = ne - call get_option(base_path // "/adaptivity_library/libmba3d/max_optimisations", maxqitr, default = 100000) + ewrite(2, *) "Forming group (Q) arguments" - allocate(metric_handle(6, np)) - do i = 1, np - metric_handle(1, i) = node_val(metric, 1, 1, i) - metric_handle(2, i) = node_val(metric, 2, 2, i) - metric_handle(3, i) = node_val(metric, 3, 3, i) - metric_handle(4, i) = node_val(metric, 1, 2, i) - metric_handle(5, i) = node_val(metric, 2, 3, i) - metric_handle(6, i) = node_val(metric, 1, 3, i) - end do + maxskipe = ne + call get_option(base_path // "/adaptivity_library/libmba3d/max_optimisations", maxqitr, default = 100000) - call get_option(base_path // "/adaptivity_library/libmba3d/quality", quality, default = real(0.6, kind = c_double)) - ! Output variable - initialise just in case it's also used as input - rquality = 0.0 + allocate(metric_handle(6, np)) + do i = 1, np + metric_handle(1, i) = node_val(metric, 1, 1, i) + metric_handle(2, i) = node_val(metric, 2, 2, i) + metric_handle(3, i) = node_val(metric, 3, 3, i) + metric_handle(4, i) = node_val(metric, 1, 2, i) + metric_handle(5, i) = node_val(metric, 2, 3, i) + metric_handle(6, i) = node_val(metric, 1, 3, i) + end do - ewrite(2, *) "Forming group (W) arguments" + call get_option(base_path // "/adaptivity_library/libmba3d/quality", quality, default = real(0.6, kind = c_double)) + ! Output variable - initialise just in case it's also used as input + rquality = 0.0 - maxwr = (14 * maxp + 2 * np + maxe) * memory_buffer + 1 - allocate(rw(maxwr)) + ewrite(2, *) "Forming group (W) arguments" - maxwi = (7 * maxp + np + 7 * maxf + 18 * maxe + 13 * ne) * memory_buffer + 1 - allocate(iw(maxwi)) + maxwr = (14 * maxp + 2 * np + maxe) * memory_buffer + 1 + allocate(rw(maxwr)) - iprint = min(max(current_debug_level * 5, 0), 9) - ! Output variable - initialise just in case it's also used as input - ierr = 0 + maxwi = (7 * maxp + np + 7 * maxf + 18 * maxe + 13 * ne) * memory_buffer + 1 + allocate(iw(maxwi)) - ewrite(1, *) "Calling mbanodal from adapt_mesh_mba3d" + iprint = min(max(current_debug_level * 5, 0), 9) + ! Output variable - initialise just in case it's also used as input + ierr = 0 + + ewrite(1, *) "Calling mbanodal from adapt_mesh_mba3d" #ifdef HAVE_MBA_3D - call mbanodal( & + call mbanodal( & ! Group (M) & np, maxp, nf, maxf, ne, maxe, & & xyp, ipf, ipe, lbf, lbe, & @@ -239,118 +239,118 @@ subroutine adapt_mesh_mba3d(input_positions, metric, output_positions, force_pre & maxwr, maxwi, rw, iw, & & iprint, ierr) #else - FLExit("Fluidity compiled without libmba3d support") + FLExit("Fluidity compiled without libmba3d support") #endif - ewrite(1, *) "Exited mbanodal" - - if(.not. any(ierr == (/0, 1000/))) then - ewrite(-1, *) "libmba3d error code: ", ierr - FLExit("libmba3d returned with an error") - end if - - deallocate(ipv) - deallocate(ifv) - deallocate(iev) - - deallocate(metric_handle) - - deallocate(rw) - deallocate(iw) - - ! Undo surface ID offset - lbf(:nf) = lbf(:nf) - 1 - ! Undo region ID offset - lbe(:ne) = lbe(:ne) - 1 - - ewrite(2, *) "Target mesh quality: ", quality - ewrite(2, *) "Mesh quality reported by mba3d: ", rquality - if(ierr == 1000) then - ewrite(1, *) "Warning: Target mesh quality not reached" - end if - - if(isparallel()) then - ewrite(2, *) "Constructing output halo" - - FLExit("libmba3d not available in parallel - halo recovery not implemented") - - ewrite(2, *) "Finished constructing output halo" - end if - - ewrite(2, *) "Constructing output positions" - - ! Construct the new mesh - output_quad = make_quadrature(nloc, dim, degree = input_positions%mesh%shape%quadrature%degree) - output_shape = make_element_shape(nloc, dim, input_positions%mesh%shape%degree, output_quad) - call allocate(output_mesh, np, ne, output_shape, name = input_positions%mesh%name) - call deallocate(output_quad) - call deallocate(output_shape) - - output_mesh%ndglno = reshape(ipe(:, :ne), (/ne * nloc/)) - allocate(boundary_ids(nf)) - allocate(coplanar_ids(nf)) - call deinterleave_surface_ids(lbf(:nf), max_coplanar_id, boundary_ids, coplanar_ids) - call add_faces(output_mesh, sndgln = reshape(ipf(:, :nf), (/nf * snloc/)), boundary_ids = boundary_ids) - deallocate(boundary_ids) - if (nf/=surface_element_count(output_mesh)) then - ! add_faces has duplicated internal boundary facets - this needs to be fixed - ! see the mba2d wrapper - FLAbort("Mba3d wrapper does not support internal boundary facets.") - end if - allocate(output_mesh%faces%coplanar_ids(nf)) - output_mesh%faces%coplanar_ids = coplanar_ids - deallocate(coplanar_ids) - - if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& - .or.present_and_true(force_preserve_regions)) then - allocate(output_mesh%region_ids(ne)) - output_mesh%region_ids = lbe(:ne) - end if - output_mesh%option_path = input_positions%mesh%option_path - - ! Construct the new positions - call allocate(output_positions, dim, output_mesh, name = input_positions%name) - call deallocate(output_mesh) - - do i = 1, dim - output_positions%val(i,:) = xyp(i, :np) - end do - output_positions%option_path = input_positions%option_path - - deallocate(xyp) - deallocate(ipf) - deallocate(ipe) - deallocate(lbf) - deallocate(lbe) - - ewrite(2, *) "Finished constructing output positions" - - ewrite(1, *) "Exiting adapt_mesh_mba3d" - - end subroutine adapt_mesh_mba3d - - subroutine mba3d_integration_check_options - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" - integer :: dim, stat - - if(.not. have_option(base_path) .or. .not. have_option(base_path // "/adaptivity_library/libmba3d")) then - ! Nothing to check - return - end if + ewrite(1, *) "Exited mbanodal" + + if(.not. any(ierr == (/0, 1000/))) then + ewrite(-1, *) "libmba3d error code: ", ierr + FLExit("libmba3d returned with an error") + end if + + deallocate(ipv) + deallocate(ifv) + deallocate(iev) + + deallocate(metric_handle) + + deallocate(rw) + deallocate(iw) + + ! Undo surface ID offset + lbf(:nf) = lbf(:nf) - 1 + ! Undo region ID offset + lbe(:ne) = lbe(:ne) - 1 + + ewrite(2, *) "Target mesh quality: ", quality + ewrite(2, *) "Mesh quality reported by mba3d: ", rquality + if(ierr == 1000) then + ewrite(1, *) "Warning: Target mesh quality not reached" + end if + + if(isparallel()) then + ewrite(2, *) "Constructing output halo" + + FLExit("libmba3d not available in parallel - halo recovery not implemented") + + ewrite(2, *) "Finished constructing output halo" + end if + + ewrite(2, *) "Constructing output positions" + + ! Construct the new mesh + output_quad = make_quadrature(nloc, dim, degree = input_positions%mesh%shape%quadrature%degree) + output_shape = make_element_shape(nloc, dim, input_positions%mesh%shape%degree, output_quad) + call allocate(output_mesh, np, ne, output_shape, name = input_positions%mesh%name) + call deallocate(output_quad) + call deallocate(output_shape) + + output_mesh%ndglno = reshape(ipe(:, :ne), (/ne * nloc/)) + allocate(boundary_ids(nf)) + allocate(coplanar_ids(nf)) + call deinterleave_surface_ids(lbf(:nf), max_coplanar_id, boundary_ids, coplanar_ids) + call add_faces(output_mesh, sndgln = reshape(ipf(:, :nf), (/nf * snloc/)), boundary_ids = boundary_ids) + deallocate(boundary_ids) + if (nf/=surface_element_count(output_mesh)) then + ! add_faces has duplicated internal boundary facets - this needs to be fixed + ! see the mba2d wrapper + FLAbort("Mba3d wrapper does not support internal boundary facets.") + end if + allocate(output_mesh%faces%coplanar_ids(nf)) + output_mesh%faces%coplanar_ids = coplanar_ids + deallocate(coplanar_ids) + + if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")& + .or.present_and_true(force_preserve_regions)) then + allocate(output_mesh%region_ids(ne)) + output_mesh%region_ids = lbe(:ne) + end if + output_mesh%option_path = input_positions%mesh%option_path + + ! Construct the new positions + call allocate(output_positions, dim, output_mesh, name = input_positions%name) + call deallocate(output_mesh) + + do i = 1, dim + output_positions%val(i,:) = xyp(i, :np) + end do + output_positions%option_path = input_positions%option_path + + deallocate(xyp) + deallocate(ipf) + deallocate(ipe) + deallocate(lbf) + deallocate(lbe) + + ewrite(2, *) "Finished constructing output positions" + + ewrite(1, *) "Exiting adapt_mesh_mba3d" + + end subroutine adapt_mesh_mba3d + + subroutine mba3d_integration_check_options + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + integer :: dim, stat + + if(.not. have_option(base_path) .or. .not. have_option(base_path // "/adaptivity_library/libmba3d")) then + ! Nothing to check + return + end if #ifndef HAVE_MBA_3D - FLExit("Cannot use libmba3d without the libmba3d library. Reconfigure with --enable-mba3d") + FLExit("Cannot use libmba3d without the libmba3d library. Reconfigure with --enable-mba3d") #endif - call get_option("/geometry/dimension", dim, stat) - if(stat /= SPUD_NO_ERROR) then - ! This isn't the place to complain about this error - return - else if(dim /= 3) then - FLExit("libmba3d can only be used in 3D") - else if(isparallel()) then - FLExit("libmba3d can only be used in serial") - end if - - end subroutine mba3d_integration_check_options + call get_option("/geometry/dimension", dim, stat) + if(stat /= SPUD_NO_ERROR) then + ! This isn't the place to complain about this error + return + else if(dim /= 3) then + FLExit("libmba3d can only be used in 3D") + else if(isparallel()) then + FLExit("libmba3d can only be used in serial") + end if + + end subroutine mba3d_integration_check_options end module mba3d_integration diff --git a/assemble/MeshMovement.F90 b/assemble/MeshMovement.F90 index 51fb87cac4..8e31d3a29c 100644 --- a/assemble/MeshMovement.F90 +++ b/assemble/MeshMovement.F90 @@ -2,153 +2,153 @@ module meshmovement - use global_parameters - use fldebug - use vector_tools, only: solve, mat_diag_mat, eigendecomposition_symmetric - use element_numbering - use elements - use shape_functions - use spud - use sparse_tools - use fields_base - use global_numbering - use eventcounter - use fetools - use unittest_tools - use fields - use state_module - use vtk_interfaces - use sparse_matrices_fields - use solvers - use fefields - use field_derivatives - use sparsity_patterns - use sparsity_patterns_meshes - - implicit none - - interface - - subroutine set_debug_level(level) - implicit none - integer, intent(in) :: level - end subroutine set_debug_level - - subroutine reset_debug_level - end subroutine reset_debug_level - end interface - - private - - public :: move_mesh_imposed_velocity, move_mesh_pseudo_lagrangian + use global_parameters + use fldebug + use vector_tools, only: solve, mat_diag_mat, eigendecomposition_symmetric + use element_numbering + use elements + use shape_functions + use spud + use sparse_tools + use fields_base + use global_numbering + use eventcounter + use fetools + use unittest_tools + use fields + use state_module + use vtk_interfaces + use sparse_matrices_fields + use solvers + use fefields + use field_derivatives + use sparsity_patterns + use sparsity_patterns_meshes + + implicit none + + interface + + subroutine set_debug_level(level) + implicit none + integer, intent(in) :: level + end subroutine set_debug_level + + subroutine reset_debug_level + end subroutine reset_debug_level + end interface + + private + + public :: move_mesh_imposed_velocity, move_mesh_pseudo_lagrangian contains - subroutine move_mesh_imposed_velocity(states) - type(state_type), dimension(:), intent(inout) :: states + subroutine move_mesh_imposed_velocity(states) + type(state_type), dimension(:), intent(inout) :: states - type(vector_field), pointer :: coordinate, old_coordinate, new_coordinate - type(vector_field), pointer :: velocity - type(vector_field), pointer :: grid_velocity + type(vector_field), pointer :: coordinate, old_coordinate, new_coordinate + type(vector_field), pointer :: velocity + type(vector_field), pointer :: grid_velocity - integer :: i, stat - real :: itheta, dt - logical :: found_velocity + integer :: i, stat + real :: itheta, dt + logical :: found_velocity - if(.not.have_option("/mesh_adaptivity/mesh_movement/imposed_grid_velocity")) return - call IncrementEventCounter(EVENT_MESH_MOVEMENT) + if(.not.have_option("/mesh_adaptivity/mesh_movement/imposed_grid_velocity")) return + call IncrementEventCounter(EVENT_MESH_MOVEMENT) - ewrite(1,*) 'Entering move_mesh_imposed_velocity' + ewrite(1,*) 'Entering move_mesh_imposed_velocity' - grid_velocity => extract_vector_field(states(1), "GridVelocity") + grid_velocity => extract_vector_field(states(1), "GridVelocity") - coordinate => extract_vector_field(states(1), "Coordinate") - old_coordinate => extract_vector_field(states(1), "OldCoordinate") - new_coordinate => extract_vector_field(states(1), "IteratedCoordinate") + coordinate => extract_vector_field(states(1), "Coordinate") + old_coordinate => extract_vector_field(states(1), "OldCoordinate") + new_coordinate => extract_vector_field(states(1), "IteratedCoordinate") - call get_option("/timestepping/timestep", dt) + call get_option("/timestepping/timestep", dt) - found_velocity = .false. - do i = 1, size(states) - velocity => extract_vector_field(states(i), "Velocity", stat) - if(stat==0 .and. .not. velocity%aliased) then - call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/relaxation", itheta, stat) - if(found_velocity.and.(stat==0)) then - FLExit("Only one prognostic velocity allowed with imposed mesh movement.") - else - found_velocity = (stat==0) - end if + found_velocity = .false. + do i = 1, size(states) + velocity => extract_vector_field(states(i), "Velocity", stat) + if(stat==0 .and. .not. velocity%aliased) then + call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/relaxation", itheta, stat) + if(found_velocity.and.(stat==0)) then + FLExit("Only one prognostic velocity allowed with imposed mesh movement.") + else + found_velocity = (stat==0) + end if + end if + end do + if(.not.found_velocity) then + itheta = 0.5 end if - end do - if(.not.found_velocity) then - itheta = 0.5 - end if - call set(new_coordinate, old_coordinate) - call addto(new_coordinate, grid_velocity, scale=dt) + call set(new_coordinate, old_coordinate) + call addto(new_coordinate, grid_velocity, scale=dt) - call set(coordinate, new_coordinate, old_coordinate, itheta) + call set(coordinate, new_coordinate, old_coordinate, itheta) - end subroutine move_mesh_imposed_velocity + end subroutine move_mesh_imposed_velocity - subroutine move_mesh_pseudo_lagrangian(states) - type(state_type), dimension(:), intent(inout) :: states + subroutine move_mesh_pseudo_lagrangian(states) + type(state_type), dimension(:), intent(inout) :: states - type(vector_field), pointer :: coordinate, old_coordinate, new_coordinate - type(vector_field), pointer :: velocity - type(vector_field), pointer :: grid_velocity + type(vector_field), pointer :: coordinate, old_coordinate, new_coordinate + type(vector_field), pointer :: velocity + type(vector_field), pointer :: grid_velocity - integer :: i, stat - real :: itheta, dt - logical :: found_velocity + integer :: i, stat + real :: itheta, dt + logical :: found_velocity - character(len=FIELD_NAME_LEN) :: state_name + character(len=FIELD_NAME_LEN) :: state_name - if(.not.have_option("/mesh_adaptivity/mesh_movement/pseudo_lagrangian")) return - call IncrementEventCounter(EVENT_MESH_MOVEMENT) + if(.not.have_option("/mesh_adaptivity/mesh_movement/pseudo_lagrangian")) return + call IncrementEventCounter(EVENT_MESH_MOVEMENT) - ewrite(1,*) 'Entering move_mesh_pseudo_lagrangian' + ewrite(1,*) 'Entering move_mesh_pseudo_lagrangian' - grid_velocity => extract_vector_field(states(1), "GridVelocity") + grid_velocity => extract_vector_field(states(1), "GridVelocity") - call get_option("/mesh_adaptivity/mesh_movement/pseudo_lagrangian/velocity_material_phase/material_phase_name", & - state_name, stat=stat) - if(stat==0) then - i = get_state_index(states, trim(state_name)) - velocity => extract_vector_field(states(i), "Velocity") - else - velocity => extract_vector_field(states(1), "Velocity") - end if - - call set(grid_velocity, velocity) - - coordinate => extract_vector_field(states(1), "Coordinate") - old_coordinate => extract_vector_field(states(1), "OldCoordinate") - new_coordinate => extract_vector_field(states(1), "IteratedCoordinate") - - call get_option("/timestepping/timestep", dt) - - found_velocity = .false. - do i = 1, size(states) - velocity => extract_vector_field(states(i), "Velocity", stat) + call get_option("/mesh_adaptivity/mesh_movement/pseudo_lagrangian/velocity_material_phase/material_phase_name", & + state_name, stat=stat) if(stat==0) then - call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/relaxation", itheta, stat) - if(found_velocity.and.(stat==0)) then - FLExit("Only one prognostic velocity allowed with pseudo lagrangian mesh movement.") - else - found_velocity = (stat==0) - end if + i = get_state_index(states, trim(state_name)) + velocity => extract_vector_field(states(i), "Velocity") + else + velocity => extract_vector_field(states(1), "Velocity") + end if + + call set(grid_velocity, velocity) + + coordinate => extract_vector_field(states(1), "Coordinate") + old_coordinate => extract_vector_field(states(1), "OldCoordinate") + new_coordinate => extract_vector_field(states(1), "IteratedCoordinate") + + call get_option("/timestepping/timestep", dt) + + found_velocity = .false. + do i = 1, size(states) + velocity => extract_vector_field(states(i), "Velocity", stat) + if(stat==0) then + call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/relaxation", itheta, stat) + if(found_velocity.and.(stat==0)) then + FLExit("Only one prognostic velocity allowed with pseudo lagrangian mesh movement.") + else + found_velocity = (stat==0) + end if + end if + end do + if(.not.found_velocity) then + itheta = 0.5 end if - end do - if(.not.found_velocity) then - itheta = 0.5 - end if - call set(new_coordinate, old_coordinate) - call addto(new_coordinate, grid_velocity, scale=dt) + call set(new_coordinate, old_coordinate) + call addto(new_coordinate, grid_velocity, scale=dt) - call set(coordinate, new_coordinate, old_coordinate, itheta) + call set(coordinate, new_coordinate, old_coordinate, itheta) - end subroutine move_mesh_pseudo_lagrangian + end subroutine move_mesh_pseudo_lagrangian end module meshmovement diff --git a/assemble/Momentum_CG.F90 b/assemble/Momentum_CG.F90 index 4aeceb5863..e6d487dd5c 100644 --- a/assemble/Momentum_CG.F90 +++ b/assemble/Momentum_CG.F90 @@ -27,161 +27,161 @@ #include "fdebug.h" - module momentum_cg +module momentum_cg - use spud - use fldebug - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN, timestep, & - COLOURING_CG1 + use spud + use fldebug + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN, timestep, & + COLOURING_CG1 #ifdef _OPENMP - use omp_lib + use omp_lib #endif - use integer_set_module - use sparse_tools - use vector_tools - use elements - use transform_elements, only: transform_to_physical - use fetools - use metric_tools - use fields - use profiler - use sparse_tools_petsc - use state_module - use boundary_conditions - use sparse_matrices_fields - use halos - use solvers - use field_options - use sparsity_patterns_meshes, only: get_csr_sparsity_firstorder - use physics_from_options - use smoothing_module - use fefields - use state_fields_module, only: get_lumped_mass - use field_derivatives - use coordinates, only: radial_inward_normal_at_quad_face,& - rotate_diagonal_to_sphere_face, radial_inward_normal_at_quad_ele,& - rotate_diagonal_to_sphere_gi - use boundary_conditions_from_options - use petsc_solve_state_module, only: petsc_solve - use coriolis_module, only: coriolis, set_coriolis_parameters - use upwind_stabilisation, only: make_supg_element, supg_test_function, element_upwind_stabilisation, get_upwind_options - use les_module - use multiphase_module - use state_matrices_module, only: get_pressure_stabilisation_matrix - use rotated_boundary_conditions - use edge_length_module - use colouring - - implicit none - - private - public :: construct_momentum_cg, correct_masslumped_velocity, & - correct_velocity_cg, assemble_masslumped_poisson_rhs, & - add_kmk_matrix, add_kmk_rhs, assemble_kmk_matrix, & - deallocate_cg_mass, assemble_poisson_rhs - - ! are we lumping the mass, absorption or source - logical :: lump_mass, lump_absorption, lump_source - ! is the pressure correction included in the absorption term? - ! if so, lump_absorption gets set equal to lump_mass - logical :: pressure_corrected_absorption - ! do we have isotropic viscosity? - logical :: isotropic_viscosity - ! do we have diagonal viscosity? - logical :: diagonal_viscosity - ! are we using the stress form of the viscosity terms? - logical :: stress_form - logical :: partial_stress_form - ! do we want to integrate the continuity matrix by parts? - logical :: integrate_continuity_by_parts - ! exclude the advection or mass terms from the equation - logical :: exclude_advection, exclude_mass - ! integrate the advection term by parts - logical :: integrate_advection_by_parts - ! do we need the inverse lumped mass to assemble a lumped cmc preconditioner - logical :: cmc_lump_mass - ! use the sub mesh to lump the mass - logical :: vel_lump_on_submesh, cmc_lump_on_submesh, abs_lump_on_submesh - ! integrate the surface tension by parts - logical :: integrate_surfacetension_by_parts - - ! which terms do we have? - logical :: have_source - logical :: have_gravity - logical :: have_absorption - logical :: have_vertical_stabilization - logical :: have_implicit_buoyancy - logical :: have_vertical_velocity_relaxation - logical :: have_swe_bottom_drag - logical :: have_viscosity - logical :: have_surfacetension - logical :: have_coriolis - logical :: have_geostrophic_pressure - logical :: have_temperature_dependent_viscosity - logical :: have_les - logical :: have_surface_fs_stabilisation - logical :: les_second_order, les_fourth_order, wale, dynamic_les - logical :: on_sphere, radial_gravity - - logical :: move_mesh - - ! assemble mass or inverse lumped mass? - logical :: assemble_mass_matrix - logical :: assemble_inverse_masslump - - ! implicitness parameter, timestep, conservation parameter, nonlinear theta factor - real :: theta, dt, beta, gravity_magnitude, itheta - - ! Boundary condition types for velocity, and pressure - ! the ids have to correspond to the order of the arguments in - ! the calls to get_entire_boundary_condition below - integer, parameter :: BC_TYPE_WEAKDIRICHLET = 1, BC_TYPE_NO_NORMAL_FLOW=2, & - BC_TYPE_INTERNAL = 3, BC_TYPE_FREE_SURFACE = 4, & - BC_TYPE_FLUX = 5 - integer, parameter :: PRESSURE_BC_TYPE_WEAKDIRICHLET = 1, PRESSURE_BC_DIRICHLET = 2 - - ! Stabilisation schemes. - integer :: stabilisation_scheme - integer, parameter :: STABILISATION_NONE=0 - integer, parameter :: STABILISATION_STREAMLINE_UPWIND=1, & - & STABILISATION_SUPG=2 - integer :: nu_bar_scheme - real :: nu_bar_scale = 1.0 - - ! LES coefficients and options - real :: smagorinsky_coefficient - character(len=OPTION_PATH_LEN) :: length_scale_type - logical :: have_eddy_visc, have_filter_width, have_coeff - - ! Temperature dependent viscosity coefficients: - real :: reference_viscosity - real :: activation_energy - - ! wetting and drying switch - logical :: have_wd_abs - - ! If .true., the pressure and density fields will be split up into hydrostatic - ! and perturbed components. The hydrostatic components will be subtracted - ! from the pressure and density used in the pressure gradient and buoyancy terms - ! in the momentum equation. This helps to maintain hydrostatic balance and prevent - ! spurious oscillations in the pressure field when using unbalanced finite element pairs. - logical :: subtract_out_reference_profile - - ! scale factor for the absorption - real :: vvr_sf - ! scale factor for the free surface stabilisation - real :: fs_sf - ! min vertical density gradient for implicit buoyancy - real :: ib_min_grad - - ! Are we running a multi-phase flow simulation? - logical :: multiphase - - contains - - subroutine construct_momentum_cg(u, p, density, x, & - big_m, rhs, ct_m, ct_rhs, mass, inverse_masslump, & - state, assemble_ct_matrix_here, include_pressure_and_continuity_bcs) + use integer_set_module + use sparse_tools + use vector_tools + use elements + use transform_elements, only: transform_to_physical + use fetools + use metric_tools + use fields + use profiler + use sparse_tools_petsc + use state_module + use boundary_conditions + use sparse_matrices_fields + use halos + use solvers + use field_options + use sparsity_patterns_meshes, only: get_csr_sparsity_firstorder + use physics_from_options + use smoothing_module + use fefields + use state_fields_module, only: get_lumped_mass + use field_derivatives + use coordinates, only: radial_inward_normal_at_quad_face,& + rotate_diagonal_to_sphere_face, radial_inward_normal_at_quad_ele,& + rotate_diagonal_to_sphere_gi + use boundary_conditions_from_options + use petsc_solve_state_module, only: petsc_solve + use coriolis_module, only: coriolis, set_coriolis_parameters + use upwind_stabilisation, only: make_supg_element, supg_test_function, element_upwind_stabilisation, get_upwind_options + use les_module + use multiphase_module + use state_matrices_module, only: get_pressure_stabilisation_matrix + use rotated_boundary_conditions + use edge_length_module + use colouring + + implicit none + + private + public :: construct_momentum_cg, correct_masslumped_velocity, & + correct_velocity_cg, assemble_masslumped_poisson_rhs, & + add_kmk_matrix, add_kmk_rhs, assemble_kmk_matrix, & + deallocate_cg_mass, assemble_poisson_rhs + + ! are we lumping the mass, absorption or source + logical :: lump_mass, lump_absorption, lump_source + ! is the pressure correction included in the absorption term? + ! if so, lump_absorption gets set equal to lump_mass + logical :: pressure_corrected_absorption + ! do we have isotropic viscosity? + logical :: isotropic_viscosity + ! do we have diagonal viscosity? + logical :: diagonal_viscosity + ! are we using the stress form of the viscosity terms? + logical :: stress_form + logical :: partial_stress_form + ! do we want to integrate the continuity matrix by parts? + logical :: integrate_continuity_by_parts + ! exclude the advection or mass terms from the equation + logical :: exclude_advection, exclude_mass + ! integrate the advection term by parts + logical :: integrate_advection_by_parts + ! do we need the inverse lumped mass to assemble a lumped cmc preconditioner + logical :: cmc_lump_mass + ! use the sub mesh to lump the mass + logical :: vel_lump_on_submesh, cmc_lump_on_submesh, abs_lump_on_submesh + ! integrate the surface tension by parts + logical :: integrate_surfacetension_by_parts + + ! which terms do we have? + logical :: have_source + logical :: have_gravity + logical :: have_absorption + logical :: have_vertical_stabilization + logical :: have_implicit_buoyancy + logical :: have_vertical_velocity_relaxation + logical :: have_swe_bottom_drag + logical :: have_viscosity + logical :: have_surfacetension + logical :: have_coriolis + logical :: have_geostrophic_pressure + logical :: have_temperature_dependent_viscosity + logical :: have_les + logical :: have_surface_fs_stabilisation + logical :: les_second_order, les_fourth_order, wale, dynamic_les + logical :: on_sphere, radial_gravity + + logical :: move_mesh + + ! assemble mass or inverse lumped mass? + logical :: assemble_mass_matrix + logical :: assemble_inverse_masslump + + ! implicitness parameter, timestep, conservation parameter, nonlinear theta factor + real :: theta, dt, beta, gravity_magnitude, itheta + + ! Boundary condition types for velocity, and pressure + ! the ids have to correspond to the order of the arguments in + ! the calls to get_entire_boundary_condition below + integer, parameter :: BC_TYPE_WEAKDIRICHLET = 1, BC_TYPE_NO_NORMAL_FLOW=2, & + BC_TYPE_INTERNAL = 3, BC_TYPE_FREE_SURFACE = 4, & + BC_TYPE_FLUX = 5 + integer, parameter :: PRESSURE_BC_TYPE_WEAKDIRICHLET = 1, PRESSURE_BC_DIRICHLET = 2 + + ! Stabilisation schemes. + integer :: stabilisation_scheme + integer, parameter :: STABILISATION_NONE=0 + integer, parameter :: STABILISATION_STREAMLINE_UPWIND=1, & + & STABILISATION_SUPG=2 + integer :: nu_bar_scheme + real :: nu_bar_scale = 1.0 + + ! LES coefficients and options + real :: smagorinsky_coefficient + character(len=OPTION_PATH_LEN) :: length_scale_type + logical :: have_eddy_visc, have_filter_width, have_coeff + + ! Temperature dependent viscosity coefficients: + real :: reference_viscosity + real :: activation_energy + + ! wetting and drying switch + logical :: have_wd_abs + + ! If .true., the pressure and density fields will be split up into hydrostatic + ! and perturbed components. The hydrostatic components will be subtracted + ! from the pressure and density used in the pressure gradient and buoyancy terms + ! in the momentum equation. This helps to maintain hydrostatic balance and prevent + ! spurious oscillations in the pressure field when using unbalanced finite element pairs. + logical :: subtract_out_reference_profile + + ! scale factor for the absorption + real :: vvr_sf + ! scale factor for the free surface stabilisation + real :: fs_sf + ! min vertical density gradient for implicit buoyancy + real :: ib_min_grad + + ! Are we running a multi-phase flow simulation? + logical :: multiphase + +contains + + subroutine construct_momentum_cg(u, p, density, x, & + big_m, rhs, ct_m, ct_rhs, mass, inverse_masslump, & + state, assemble_ct_matrix_here, include_pressure_and_continuity_bcs) !!< Assembles the momentum matrix and rhs for the LinearMomentum, !!< Boussinesq and Drainage equation types such that !!< big_m*u = rhs + ct_m*p @@ -335,69 +335,69 @@ subroutine construct_momentum_cg(u, p, density, x, & have_wd_abs=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption") ! Absorption term in dry zones for wetting and drying if (have_wd_abs) then - call allocate(abs_wd, u%dim, u%mesh, "VelocityAbsorption_WettingDrying", FIELD_TYPE_CONSTANT) - call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption", abs_wd_const) - call set(abs_wd, abs_wd_const) + call allocate(abs_wd, u%dim, u%mesh, "VelocityAbsorption_WettingDrying", FIELD_TYPE_CONSTANT) + call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption", abs_wd_const) + call set(abs_wd, abs_wd_const) end if ! Check if we have either implicit absorption term have_vertical_stabilization=have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation").or. & - have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") + have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") ! If we have vertical velocity relaxation set then grab the required fields ! sigma = n_z*g*dt*_rho_o/depth have_vertical_velocity_relaxation=have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation") if (have_vertical_velocity_relaxation) then - call get_option(trim(u%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation/scale_factor", vvr_sf) - ewrite(2,*) "vertical velocity relaxation scale_factor= ", vvr_sf - dtt => extract_scalar_field(state, "DistanceToTop") - dtb => extract_scalar_field(state, "DistanceToBottom") - call allocate(depth, dtt%mesh, "Depth") - do node=1,node_count(dtt) - call set(depth, node, node_val(dtt, node)+node_val(dtb, node)) - end do + call get_option(trim(u%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation/scale_factor", vvr_sf) + ewrite(2,*) "vertical velocity relaxation scale_factor= ", vvr_sf + dtt => extract_scalar_field(state, "DistanceToTop") + dtb => extract_scalar_field(state, "DistanceToBottom") + call allocate(depth, dtt%mesh, "Depth") + do node=1,node_count(dtt) + call set(depth, node, node_val(dtt, node)+node_val(dtb, node)) + end do endif ! Implicit buoyancy (theta*g*dt*drho/dr) have_implicit_buoyancy=have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") if (have_implicit_buoyancy) then - call get_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy/min_gradient", & - ib_min_grad, default=0.0) + call get_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy/min_gradient", & + ib_min_grad, default=0.0) end if have_swe_bottom_drag = have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater/bottom_drag') if (have_swe_bottom_drag) then - swe_bottom_drag => extract_scalar_field(state, "BottomDragCoefficient") - assert(.not. have_vertical_velocity_relaxation) - depth = extract_scalar_field(state, "BottomDepth") ! we reuse the field that's already passed for VVR - old_pressure => extract_scalar_field(state, "OldPressure") + swe_bottom_drag => extract_scalar_field(state, "BottomDragCoefficient") + assert(.not. have_vertical_velocity_relaxation) + depth = extract_scalar_field(state, "BottomDepth") ! we reuse the field that's already passed for VVR + old_pressure => extract_scalar_field(state, "OldPressure") else - ! just to be sure, nullify these pointer instead of passing them undefined: - nullify(swe_bottom_drag) - nullify(old_pressure) + ! just to be sure, nullify these pointer instead of passing them undefined: + nullify(swe_bottom_drag) + nullify(old_pressure) end if call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude, & - stat=stat) + stat=stat) have_gravity = stat == 0 if (have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater')) then - ! for the swe there's no buoyancy term - have_gravity = .false. - buoyancy=>dummyscalar - gravity=>dummyvector - ! but we do need gravity_magnitude to convert pressure to free surface elevation + ! for the swe there's no buoyancy term + have_gravity = .false. + buoyancy=>dummyscalar + gravity=>dummyvector + ! but we do need gravity_magnitude to convert pressure to free surface elevation else if(have_gravity) then - buoyancy=>extract_scalar_field(state, "VelocityBuoyancyDensity") - gravity=>extract_vector_field(state, "GravityDirection", stat) + buoyancy=>extract_scalar_field(state, "VelocityBuoyancyDensity") + gravity=>extract_vector_field(state, "GravityDirection", stat) else - buoyancy=>dummyscalar - gravity=>dummyvector - gravity_magnitude = 0.0 + buoyancy=>dummyscalar + gravity=>dummyvector + gravity_magnitude = 0.0 end if ewrite_minmax(buoyancy) radial_gravity = have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/buoyancy/radial_gravity_direction_at_gauss_points") + &"/buoyancy/radial_gravity_direction_at_gauss_points") ! Splits up the Density and Pressure fields into a hydrostatic component (') and a perturbed component (''). ! The hydrostatic components, denoted p' and rho', should satisfy the balance: grad(p') = rho'*g @@ -419,7 +419,7 @@ subroutine construct_momentum_cg(u, p, density, x, & if(.not. have_viscosity) then viscosity=>dummytensor else - ewrite_minmax(viscosity) + ewrite_minmax(viscosity) end if surfacetension=>extract_tensor_field(state, "VelocitySurfaceTension", stat) @@ -427,25 +427,25 @@ subroutine construct_momentum_cg(u, p, density, x, & if(.not. have_surfacetension) then surfacetension=>dummytensor else - ewrite_minmax(surfacetension) + ewrite_minmax(surfacetension) end if have_coriolis = have_option("/physical_parameters/coriolis") have_les = have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/les_model") + &"/continuous_galerkin/les_model") if (have_les) then ! Set everything to false initially, then set to true if present have_eddy_visc=.false.; have_filter_width=.false.; have_coeff=.false. les_option_path=(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/les_model") + &"/continuous_galerkin/les_model") les_second_order=have_option(trim(les_option_path)//"/second_order") les_fourth_order=have_option(trim(les_option_path)//"/fourth_order") wale=have_option(trim(les_option_path)//"/wale") dynamic_les=have_option(trim(les_option_path)//"/dynamic_les") if (les_second_order) then call get_option(trim(les_option_path)//"/second_order/smagorinsky_coefficient", & - smagorinsky_coefficient) + smagorinsky_coefficient) call get_option(trim(les_option_path)//"/second_order/length_scale_type", length_scale_type) @@ -458,57 +458,57 @@ subroutine construct_momentum_cg(u, p, density, x, & end if if (les_fourth_order) then call get_option(trim(les_option_path)//"/fourth_order/smagorinsky_coefficient", & - smagorinsky_coefficient) + smagorinsky_coefficient) call allocate( grad_u, u%mesh, "VelocityGradient") call differentiate_field_lumped( nu, x, grad_u) end if if (wale) then call get_option(trim(les_option_path)//"/wale/smagorinsky_coefficient", & - smagorinsky_coefficient) + smagorinsky_coefficient) end if if(dynamic_les) then - ! Scalar or tensor filter width - call get_option(trim(les_option_path)//"/dynamic_les/length_scale_type", length_scale_type) - ! Initialise optional diagnostic fields - have_eddy_visc = have_option(trim(les_option_path)//"/dynamic_les/tensor_field::EddyViscosity") - have_filter_width = have_option(trim(les_option_path)//"/dynamic_les/tensor_field::FilterWidth") - have_coeff = have_option(trim(les_option_path)//"/dynamic_les/scalar_field::SmagorinskyCoefficient") - call les_init_diagnostic_fields(state, have_eddy_visc, have_filter_width, have_coeff) - - ! Initialise necessary local fields. - ewrite(2,*) "Initialising compulsory dynamic LES fields" - if(have_option(trim(les_option_path)//"/dynamic_les/vector_field::FirstFilteredVelocity")) then - fnu => extract_vector_field(state, "FirstFilteredVelocity") - else - allocate(fnu) - call allocate(fnu, u%dim, u%mesh, "FirstFilteredVelocity") - end if - call zero(fnu) - if(have_option(trim(les_option_path)//"/dynamic_les/vector_field::TestFilteredVelocity")) then - tnu => extract_vector_field(state, "TestFilteredVelocity") - else - allocate(tnu) - call allocate(tnu, u%dim, u%mesh, "TestFilteredVelocity") - end if - call zero(tnu) - allocate(leonard) - call allocate(leonard, u%mesh, "LeonardTensor") - call zero(leonard) - allocate(strainprod) - call allocate(strainprod, u%mesh, "StrainProduct") - call zero(strainprod) - - ! Get (first filter)/(mesh size) ratio alpha. Default value is 2. - call get_option(trim(les_option_path)//"/dynamic_les/alpha", alpha, default=2.0) - ! Get (test filter)/(first filter) size ratio alpha. Default value is 2. - call get_option(trim(les_option_path)//"/dynamic_les/gama", gamma, default=2.0) - - ! Calculate test-filtered velocity field and Leonard tensor field. - ewrite(2,*) "Calculating test-filtered velocity and Leonard tensor" - call leonard_tensor(nu, x, fnu, tnu, leonard, strainprod, alpha, gamma, les_option_path) - - ewrite_minmax(leonard) - ewrite_minmax(strainprod) + ! Scalar or tensor filter width + call get_option(trim(les_option_path)//"/dynamic_les/length_scale_type", length_scale_type) + ! Initialise optional diagnostic fields + have_eddy_visc = have_option(trim(les_option_path)//"/dynamic_les/tensor_field::EddyViscosity") + have_filter_width = have_option(trim(les_option_path)//"/dynamic_les/tensor_field::FilterWidth") + have_coeff = have_option(trim(les_option_path)//"/dynamic_les/scalar_field::SmagorinskyCoefficient") + call les_init_diagnostic_fields(state, have_eddy_visc, have_filter_width, have_coeff) + + ! Initialise necessary local fields. + ewrite(2,*) "Initialising compulsory dynamic LES fields" + if(have_option(trim(les_option_path)//"/dynamic_les/vector_field::FirstFilteredVelocity")) then + fnu => extract_vector_field(state, "FirstFilteredVelocity") + else + allocate(fnu) + call allocate(fnu, u%dim, u%mesh, "FirstFilteredVelocity") + end if + call zero(fnu) + if(have_option(trim(les_option_path)//"/dynamic_les/vector_field::TestFilteredVelocity")) then + tnu => extract_vector_field(state, "TestFilteredVelocity") + else + allocate(tnu) + call allocate(tnu, u%dim, u%mesh, "TestFilteredVelocity") + end if + call zero(tnu) + allocate(leonard) + call allocate(leonard, u%mesh, "LeonardTensor") + call zero(leonard) + allocate(strainprod) + call allocate(strainprod, u%mesh, "StrainProduct") + call zero(strainprod) + + ! Get (first filter)/(mesh size) ratio alpha. Default value is 2. + call get_option(trim(les_option_path)//"/dynamic_les/alpha", alpha, default=2.0) + ! Get (test filter)/(first filter) size ratio alpha. Default value is 2. + call get_option(trim(les_option_path)//"/dynamic_les/gama", gamma, default=2.0) + + ! Calculate test-filtered velocity field and Leonard tensor field. + ewrite(2,*) "Calculating test-filtered velocity and Leonard tensor" + call leonard_tensor(nu, x, fnu, tnu, leonard, strainprod, alpha, gamma, les_option_path) + + ewrite_minmax(leonard) + ewrite_minmax(strainprod) else fnu => dummyvector tnu => dummyvector @@ -522,14 +522,14 @@ subroutine construct_momentum_cg(u, p, density, x, & have_temperature_dependent_viscosity = have_option(trim(u%option_path)//"/prognostic"//& - &"/spatial_discretisation/continuous_galerkin/temperature_dependent_viscosity") + &"/spatial_discretisation/continuous_galerkin/temperature_dependent_viscosity") if (have_temperature_dependent_viscosity) then call get_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/temperature_dependent_viscosity/reference_viscosity", & - &reference_viscosity) + &"/continuous_galerkin/temperature_dependent_viscosity/reference_viscosity", & + &reference_viscosity) call get_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/temperature_dependent_viscosity/activation_energy", & - activation_energy) + &"/continuous_galerkin/temperature_dependent_viscosity/activation_energy", & + activation_energy) ! Extract temperature field from state: temperature => extract_scalar_field(state,"Temperature") else @@ -538,62 +538,62 @@ subroutine construct_momentum_cg(u, p, density, x, & have_geostrophic_pressure = has_scalar_field(state, "GeostrophicPressure") if(have_geostrophic_pressure) then - gp => extract_scalar_field(state, "GeostrophicPressure") + gp => extract_scalar_field(state, "GeostrophicPressure") - ewrite_minmax(gp) + ewrite_minmax(gp) else - gp => dummyscalar + gp => dummyscalar end if on_sphere = have_option('/geometry/spherical_earth') #ifdef _OPENMP - num_threads = omp_get_max_threads() + num_threads = omp_get_max_threads() #else - num_threads = 1 + num_threads = 1 #endif allocate(supg_element(num_threads)) call get_option("/timestepping/timestep", dt) call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/theta", & - theta) + theta) call get_option(trim(u%option_path)//"/prognostic/spatial_discretisation/& - &conservative_advection", beta) + &conservative_advection", beta) call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/relaxation", & - itheta) + itheta) lump_mass=have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/mass_terms/lump_mass_matrix") + &"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin/mass_terms/lump_mass_matrix") lump_absorption=have_option(trim(u%option_path)//& - &"/prognostic/vector_field::Absorption"//& - &"/lump_absorption") + &"/prognostic/vector_field::Absorption"//& + &"/lump_absorption") abs_lump_on_submesh = have_option(trim(u%option_path)//& - &"/prognostic/vector_field::Absorption"//& - &"/lump_absorption/use_submesh") + &"/prognostic/vector_field::Absorption"//& + &"/lump_absorption/use_submesh") pressure_corrected_absorption=have_option(trim(u%option_path)//& - &"/prognostic/vector_field::Absorption"//& - &"/include_pressure_correction") .or. (have_vertical_stabilization) + &"/prognostic/vector_field::Absorption"//& + &"/include_pressure_correction") .or. (have_vertical_stabilization) if (pressure_corrected_absorption) then ! as we add the absorption into the mass matrix ! lump_absorption needs to match lump_mass lump_absorption = lump_mass end if lump_source=have_option(trim(u%option_path)//& - &"/prognostic/vector_field::Source"//& - &"/lump_source") + &"/prognostic/vector_field::Source"//& + &"/lump_source") if(have_viscosity) then isotropic_viscosity = have_viscosity .and. & - & isotropic_field(viscosity) + & isotropic_field(viscosity) diagonal_viscosity = have_viscosity .and. & - & diagonal_field(viscosity) + & diagonal_field(viscosity) stress_form=have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/stress_terms/stress_form") + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/stress_terms/stress_form") partial_stress_form=have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/stress_terms/partial_stress_form") + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/stress_terms/partial_stress_form") else isotropic_viscosity = .false. diagonal_viscosity = .false. @@ -601,56 +601,56 @@ subroutine construct_momentum_cg(u, p, density, x, & partial_stress_form = .false. end if integrate_continuity_by_parts=have_option(trim(p%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/integrate_continuity_by_parts") + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/integrate_continuity_by_parts") integrate_advection_by_parts = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/advection_terms/integrate_advection_by_parts") + &"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin/advection_terms/integrate_advection_by_parts") exclude_advection = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/advection_terms/exclude_advection_terms") + &"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin/advection_terms/exclude_advection_terms") exclude_mass = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/mass_terms/exclude_mass_terms") + &"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin/mass_terms/exclude_mass_terms") vel_lump_on_submesh = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/mass_terms"//& - &"/lump_mass_matrix/use_submesh") + &"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin/mass_terms"//& + &"/lump_mass_matrix/use_submesh") if (pressure_corrected_absorption) then ! as we add the absorption into the mass matrix ! the meshes need to be the same abs_lump_on_submesh = vel_lump_on_submesh end if cmc_lump_mass = have_option(trim(p%option_path)//& - &"/prognostic/scheme"//& - &"/use_projection_method/full_schur_complement"//& - &"/preconditioner_matrix::LumpedSchurComplement") + &"/prognostic/scheme"//& + &"/use_projection_method/full_schur_complement"//& + &"/preconditioner_matrix::LumpedSchurComplement") cmc_lump_on_submesh = have_option(trim(p%option_path)//& - &"/prognostic/scheme"//& - &"/use_projection_method/full_schur_complement"//& - &"/preconditioner_matrix[0]/lump_on_submesh") + &"/prognostic/scheme"//& + &"/use_projection_method/full_schur_complement"//& + &"/preconditioner_matrix[0]/lump_on_submesh") assemble_inverse_masslump = lump_mass .or. cmc_lump_mass assemble_mass_matrix = have_option(trim(p%option_path)//& - &"/prognostic/scheme/use_projection_method"//& - &"/full_schur_complement/inner_matrix::FullMassMatrix") + &"/prognostic/scheme/use_projection_method"//& + &"/full_schur_complement/inner_matrix::FullMassMatrix") if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind")) then - stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND - call get_upwind_options(trim(u%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind", & - & nu_bar_scheme, nu_bar_scale) + stabilisation_scheme = STABILISATION_STREAMLINE_UPWIND + call get_upwind_options(trim(u%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind", & + & nu_bar_scheme, nu_bar_scale) else if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin")) then - stabilisation_scheme = STABILISATION_SUPG - call get_upwind_options(trim(u%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin", & - & nu_bar_scheme, nu_bar_scale) - !! we need 1 supg_element per thread - do i = 1, num_threads - supg_element(i)=make_supg_element(ele_shape(u,1)) - enddo + stabilisation_scheme = STABILISATION_SUPG + call get_upwind_options(trim(u%option_path) // "/prognostic/spatial_discretisation/continuous_galerkin/stabilisation/streamline_upwind_petrov_galerkin", & + & nu_bar_scheme, nu_bar_scale) + !! we need 1 supg_element per thread + do i = 1, num_threads + supg_element(i)=make_supg_element(ele_shape(u,1)) + enddo else - stabilisation_scheme = STABILISATION_NONE + stabilisation_scheme = STABILISATION_NONE end if integrate_surfacetension_by_parts = have_option(trim(u%option_path)//& - &"/prognostic/tensor_field::SurfaceTension"//& - &"/diagnostic/integrate_by_parts") + &"/prognostic/tensor_field::SurfaceTension"//& + &"/diagnostic/integrate_by_parts") ! Are we running a multi-phase simulation? if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then @@ -669,117 +669,117 @@ subroutine construct_momentum_cg(u, p, density, x, & if (assemble_inverse_masslump) then - ! construct the inverse of the lumped mass matrix - call allocate( inverse_masslump, u%dim, u%mesh, "InverseLumpedMass") - call zero(inverse_masslump) + ! construct the inverse of the lumped mass matrix + call allocate( inverse_masslump, u%dim, u%mesh, "InverseLumpedMass") + call zero(inverse_masslump) end if if (assemble_mass_matrix) then - ! construct mass matrix instead - u_sparsity => get_csr_sparsity_firstorder(state, u%mesh, u%mesh) + ! construct mass matrix instead + u_sparsity => get_csr_sparsity_firstorder(state, u%mesh, u%mesh) - call allocate( mass, u_sparsity, (/ u%dim, u%dim /), & + call allocate( mass, u_sparsity, (/ u%dim, u%dim /), & diagonal=.true., name="MassMatrix") - call zero( mass ) + call zero( mass ) end if move_mesh = (have_option("/mesh_adaptivity/mesh_movement").and.(.not.exclude_mass)) if(move_mesh) then - ewrite(2,*) 'Moving mesh' - x_old => extract_vector_field(state, "OldCoordinate") - x_new => extract_vector_field(state, "IteratedCoordinate") - ug=>extract_vector_field(state, "GridVelocity") + ewrite(2,*) 'Moving mesh' + x_old => extract_vector_field(state, "OldCoordinate") + x_new => extract_vector_field(state, "IteratedCoordinate") + ug=>extract_vector_field(state, "GridVelocity") else - ewrite(2,*) 'Not moving mesh' + ewrite(2,*) 'Not moving mesh' end if if (on_sphere.and.pressure_corrected_absorption) then - ewrite(-1,*) 'WARNING:: Absorption in spherical geometry cannot currently' - ewrite(-1,*) ' be included in the pressure correction. This option' - ewrite(-1,*) ' will be ignored.' + ewrite(-1,*) 'WARNING:: Absorption in spherical geometry cannot currently' + ewrite(-1,*) ' be included in the pressure correction. This option' + ewrite(-1,*) ' will be ignored.' end if if (have_wd_abs .and. on_sphere) then - FLExit("The wetting and drying absorption term does currently not work on the sphere.") + FLExit("The wetting and drying absorption term does currently not work on the sphere.") end if if (have_wd_abs .and. .not. has_scalar_field(state, "WettingDryingAlpha")) then - FLExit("The wetting and drying absorption needs the diagnostic field WettingDryingAlpha activated.") + FLExit("The wetting and drying absorption needs the diagnostic field WettingDryingAlpha activated.") end if if (have_wd_abs) then - ! The alpha fields lives on the pressure mesh, but we need it on the velocity, so let's remap it. - wettingdrying_alpha => extract_scalar_field(state, "WettingDryingAlpha") - call allocate(alpha_u_field, u%mesh, "alpha_u") - call remap_field(wettingdrying_alpha, alpha_u_field) + ! The alpha fields lives on the pressure mesh, but we need it on the velocity, so let's remap it. + wettingdrying_alpha => extract_scalar_field(state, "WettingDryingAlpha") + call allocate(alpha_u_field, u%mesh, "alpha_u") + call remap_field(wettingdrying_alpha, alpha_u_field) end if call get_mesh_colouring(state, u%mesh, COLOURING_CG1, colours) ! ----- Volume integrals over elements ------------- #ifdef _OPENMP - cache_valid = prepopulate_transform_cache(x) - if (have_coriolis) then - call set_coriolis_parameters - end if + cache_valid = prepopulate_transform_cache(x) + if (have_coriolis) then + call set_coriolis_parameters + end if #endif - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(clr, len, nnid, ele, thread_num) + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(clr, len, nnid, ele, thread_num) #ifdef _OPENMP - thread_num = omp_get_thread_num() + thread_num = omp_get_thread_num() #else - thread_num = 0 + thread_num = 0 #endif - colour_loop: do clr = 1, size(colours) - len = key_count(colours(clr)) - !$OMP DO SCHEDULE(STATIC) - element_loop: do nnid = 1, len - ele = fetch(colours(clr), nnid) - call construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, mass, inverse_masslump, & - x, x_old, x_new, u, oldu, nu, ug, & - density, ct_rhs, & - source, absorption, buoyancy, hb_density, gravity, & - viscosity, grad_u, & - fnu, tnu, leonard, strainprod, alpha, gamma, & - gp, surfacetension, & - swe_bottom_drag, old_pressure, p, & - assemble_ct_matrix_here, depth, & - alpha_u_field, abs_wd, temperature, nvfrac, & - supg_element(thread_num+1)) - end do element_loop - !$OMP END DO - - end do colour_loop - !$OMP END PARALLEL + colour_loop: do clr = 1, size(colours) + len = key_count(colours(clr)) + !$OMP DO SCHEDULE(STATIC) + element_loop: do nnid = 1, len + ele = fetch(colours(clr), nnid) + call construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, mass, inverse_masslump, & + x, x_old, x_new, u, oldu, nu, ug, & + density, ct_rhs, & + source, absorption, buoyancy, hb_density, gravity, & + viscosity, grad_u, & + fnu, tnu, leonard, strainprod, alpha, gamma, & + gp, surfacetension, & + swe_bottom_drag, old_pressure, p, & + assemble_ct_matrix_here, depth, & + alpha_u_field, abs_wd, temperature, nvfrac, & + supg_element(thread_num+1)) + end do element_loop + !$OMP END DO + + end do colour_loop + !$OMP END PARALLEL if (have_wd_abs) then - ! the remapped field is not needed anymore. - call deallocate(alpha_u_field) - call deallocate(Abs_wd) + ! the remapped field is not needed anymore. + call deallocate(alpha_u_field) + call deallocate(Abs_wd) end if ! ----- Surface integrals over boundaries ----------- allocate(velocity_bc_type(u%dim, surface_element_count(u))) call get_entire_boundary_condition(u, & - & (/ & - "weakdirichlet ", & - "no_normal_flow", & - "internal ", & - "free_surface ", & - "flux " & - & /), velocity_bc, velocity_bc_type) + & (/ & + "weakdirichlet ", & + "no_normal_flow", & + "internal ", & + "free_surface ", & + "flux " & + & /), velocity_bc, velocity_bc_type) allocate(pressure_bc_type(surface_element_count(p))) call get_entire_boundary_condition(p, & - & (/ & - "weakdirichlet", & - "dirichlet " /), & - pressure_bc, pressure_bc_type) + & (/ & + "weakdirichlet", & + "dirichlet " /), & + pressure_bc, pressure_bc_type) ! Check if we want free surface stabilisation (in development!) have_surface_fs_stabilisation=have_fs_stab(u) if (have_surface_fs_stabilisation) then - fs_sf=get_surface_stab_scale_factor(u) + fs_sf=get_surface_stab_scale_factor(u) end if if(subtract_out_reference_profile.and.integrate_continuity_by_parts.and.(assemble_ct_matrix_here .or. include_pressure_and_continuity_bcs)) then @@ -797,17 +797,17 @@ subroutine construct_momentum_cg(u, p, density, x, & ! if no_normal flow and no other condition in the tangential directions, or if periodic ! but not if there's a pressure bc if(((velocity_bc_type(1,sele)==BC_TYPE_NO_NORMAL_FLOW & - .and. sum(velocity_bc_type(:,sele))==BC_TYPE_NO_NORMAL_FLOW) & - .or. any(velocity_bc_type(:,sele)==BC_TYPE_INTERNAL)) & - .and. pressure_bc_type(sele)==0) cycle + .and. sum(velocity_bc_type(:,sele))==BC_TYPE_NO_NORMAL_FLOW) & + .or. any(velocity_bc_type(:,sele)==BC_TYPE_INTERNAL)) & + .and. pressure_bc_type(sele)==0) cycle ele = face_ele(x, sele) call construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, & - inverse_masslump, x, u, nu, ug, density, gravity, & - velocity_bc, velocity_bc_type, & - pressure_bc, pressure_bc_type, hb_pressure, & - assemble_ct_matrix_here, include_pressure_and_continuity_bcs, oldu, nvfrac) + inverse_masslump, x, u, nu, ug, density, gravity, & + velocity_bc, velocity_bc_type, & + pressure_bc, pressure_bc_type, hb_pressure, & + assemble_ct_matrix_here, include_pressure_and_continuity_bcs, oldu, nvfrac) end do surface_element_loop @@ -818,67 +818,67 @@ subroutine construct_momentum_cg(u, p, density, x, & if(abs_lump_on_submesh) then - call allocate(abslump, inverse_masslump%dim, inverse_masslump%mesh, "LumpedAbsorption") - call allocate(absdensity, absorption%mesh, "AbsorptionComponentTimesDensity") + call allocate(abslump, inverse_masslump%dim, inverse_masslump%mesh, "LumpedAbsorption") + call allocate(absdensity, absorption%mesh, "AbsorptionComponentTimesDensity") - do dim = 1, inverse_masslump%dim - call remap_field(density, absdensity) - abs_component = extract_scalar_field(absorption, dim) - call scale(absdensity, abs_component) + do dim = 1, inverse_masslump%dim + call remap_field(density, absdensity) + abs_component = extract_scalar_field(absorption, dim) + call scale(absdensity, abs_component) - abslump_component = extract_scalar_field(abslump, dim) - call compute_lumped_mass_on_submesh(state, abslump_component, density=absdensity) - end do + abslump_component = extract_scalar_field(abslump, dim) + call compute_lumped_mass_on_submesh(state, abslump_component, density=absdensity) + end do - call deallocate(absdensity) + call deallocate(absdensity) - if(assemble_inverse_masslump.and.pressure_corrected_absorption) then - call addto(inverse_masslump, abslump, theta) - end if + if(assemble_inverse_masslump.and.pressure_corrected_absorption) then + call addto(inverse_masslump, abslump, theta) + end if - call addto_diag(big_m, abslump, dt*theta) + call addto_diag(big_m, abslump, dt*theta) - call scale(abslump, oldu) - call addto(rhs, abslump, -1.0) + call scale(abslump, oldu) + call addto(rhs, abslump, -1.0) - call deallocate(abslump) + call deallocate(abslump) end if if (assemble_inverse_masslump) then - if(vel_lump_on_submesh .or. cmc_lump_on_submesh) then - if(move_mesh) then - FLExit("Can't move the mesh and lump on the submesh yet.") - end if - ! we still have to make the lumped mass if this is true - masslump_component=extract_scalar_field(inverse_masslump, 1) - - if(multiphase) then - call compute_lumped_mass_on_submesh(state, masslump_component, density=density, vfrac=nvfrac) - else - call compute_lumped_mass_on_submesh(state, masslump_component, density=density) - end if - - ! copy over to other components - do dim = 2, inverse_masslump%dim - call set(inverse_masslump, dim, masslump_component) - end do - - if(vel_lump_on_submesh) then - call addto_diag(big_m, masslump_component) - end if - end if - - ! thus far we have just assembled the lumped mass in inverse_masslump - ! now invert it: - call invert(inverse_masslump) - ! apply boundary conditions (zeroing out strong dirichl. rows) - call apply_dirichlet_conditions_inverse_mass(inverse_masslump, u) - ewrite_minmax(inverse_masslump) + if(vel_lump_on_submesh .or. cmc_lump_on_submesh) then + if(move_mesh) then + FLExit("Can't move the mesh and lump on the submesh yet.") + end if + ! we still have to make the lumped mass if this is true + masslump_component=extract_scalar_field(inverse_masslump, 1) + + if(multiphase) then + call compute_lumped_mass_on_submesh(state, masslump_component, density=density, vfrac=nvfrac) + else + call compute_lumped_mass_on_submesh(state, masslump_component, density=density) + end if + + ! copy over to other components + do dim = 2, inverse_masslump%dim + call set(inverse_masslump, dim, masslump_component) + end do + + if(vel_lump_on_submesh) then + call addto_diag(big_m, masslump_component) + end if + end if + + ! thus far we have just assembled the lumped mass in inverse_masslump + ! now invert it: + call invert(inverse_masslump) + ! apply boundary conditions (zeroing out strong dirichl. rows) + call apply_dirichlet_conditions_inverse_mass(inverse_masslump, u) + ewrite_minmax(inverse_masslump) end if if (assemble_mass_matrix) then - call apply_dirichlet_conditions(matrix=mass, field=u) + call apply_dirichlet_conditions(matrix=mass, field=u) end if ewrite_minmax(rhs) @@ -888,18 +888,18 @@ subroutine construct_momentum_cg(u, p, density, x, & end if if (les_fourth_order) then - call deallocate(grad_u) + call deallocate(grad_u) end if if (dynamic_les) then - if(.not. have_option(trim(les_option_path)//"/dynamic_les/vector_field::FirstFilteredVelocity")) then - call deallocate(tnu); deallocate(tnu) - end if - if(.not. have_option(trim(les_option_path)//"/dynamic_les/vector_field::TestFilteredVelocity")) then - call deallocate(fnu); deallocate(fnu) - end if - call deallocate(leonard); deallocate(leonard) - call deallocate(strainprod); deallocate(strainprod) + if(.not. have_option(trim(les_option_path)//"/dynamic_les/vector_field::FirstFilteredVelocity")) then + call deallocate(tnu); deallocate(tnu) + end if + if(.not. have_option(trim(les_option_path)//"/dynamic_les/vector_field::TestFilteredVelocity")) then + call deallocate(fnu); deallocate(fnu) + end if + call deallocate(leonard); deallocate(leonard) + call deallocate(strainprod); deallocate(strainprod) end if call deallocate(dummytensor) @@ -920,48 +920,48 @@ subroutine construct_momentum_cg(u, p, density, x, & end if deallocate(supg_element) - contains - - logical function have_fs_stab(u) - type(vector_field), intent(in) :: u - character(len=OPTION_PATH_LEN) :: type - character(len=OPTION_PATH_LEN) :: option_path - integer :: n - - have_fs_stab=.false. - do n=1,get_boundary_condition_count(u) - call get_boundary_condition(u, n, type=type, option_path=option_path) - if (have_option(trim(option_path)//"/type::free_surface/surface_stabilisation")) then - have_fs_stab=.true. - return - end if - end do - end function have_fs_stab - - function get_surface_stab_scale_factor(u) result(scale_factor) - type(vector_field), intent(in) :: u - character(len=OPTION_PATH_LEN) :: type - character(len=OPTION_PATH_LEN) :: option_path - integer :: n - real :: scale_factor - - do n=1,get_boundary_condition_count(u) - call get_boundary_condition(u, n, type=type, option_path=option_path) - if (have_option(trim(option_path)//"/type::free_surface/surface_stabilisation")) then - call get_option(trim(option_path)//"/type::free_surface/surface_stabilisation/scale_factor", scale_factor) - end if - end do + contains + + logical function have_fs_stab(u) + type(vector_field), intent(in) :: u + character(len=OPTION_PATH_LEN) :: type + character(len=OPTION_PATH_LEN) :: option_path + integer :: n + + have_fs_stab=.false. + do n=1,get_boundary_condition_count(u) + call get_boundary_condition(u, n, type=type, option_path=option_path) + if (have_option(trim(option_path)//"/type::free_surface/surface_stabilisation")) then + have_fs_stab=.true. + return + end if + end do + end function have_fs_stab + + function get_surface_stab_scale_factor(u) result(scale_factor) + type(vector_field), intent(in) :: u + character(len=OPTION_PATH_LEN) :: type + character(len=OPTION_PATH_LEN) :: option_path + integer :: n + real :: scale_factor + + do n=1,get_boundary_condition_count(u) + call get_boundary_condition(u, n, type=type, option_path=option_path) + if (have_option(trim(option_path)//"/type::free_surface/surface_stabilisation")) then + call get_option(trim(option_path)//"/type::free_surface/surface_stabilisation/scale_factor", scale_factor) + end if + end do - end function get_surface_stab_scale_factor + end function get_surface_stab_scale_factor - end subroutine construct_momentum_cg + end subroutine construct_momentum_cg - subroutine construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, & - masslump, x, u, nu, ug, density, gravity, & - velocity_bc, velocity_bc_type, & - pressure_bc, pressure_bc_type, hb_pressure, & - assemble_ct_matrix_here, include_pressure_and_continuity_bcs,& - oldu, nvfrac) + subroutine construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, & + masslump, x, u, nu, ug, density, gravity, & + velocity_bc, velocity_bc_type, & + pressure_bc, pressure_bc_type, hb_pressure, & + assemble_ct_matrix_here, include_pressure_and_continuity_bcs,& + oldu, nvfrac) integer, intent(in) :: sele @@ -1022,7 +1022,7 @@ subroutine construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, oldu_val = face_val(oldu, sele) call transform_facet_to_physical(X, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) + detwei_f=detwei_bdy, normal=normal_bdy) ! Note that with SUPG the surface element test function is not modified @@ -1034,7 +1034,7 @@ subroutine construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, relu_gi = face_val_at_quad(nu, sele) if(move_mesh) then - relu_gi = relu_gi - face_val_at_quad(ug, sele) + relu_gi = relu_gi - face_val_at_quad(ug, sele) end if if(multiphase) then @@ -1052,11 +1052,11 @@ subroutine construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, if(velocity_bc_type(dim, sele)==BC_TYPE_WEAKDIRICHLET) then call addto(rhs, dim, u_nodes_bdy, -matmul(adv_mat_bdy, & - ele_val(velocity_bc, dim, sele))) + ele_val(velocity_bc, dim, sele))) else call addto(big_m, dim, dim, u_nodes_bdy, u_nodes_bdy, & - dt*theta*adv_mat_bdy) + dt*theta*adv_mat_bdy) call addto(rhs, dim, u_nodes_bdy, -matmul(adv_mat_bdy, face_val(oldu, dim, sele))) @@ -1068,139 +1068,139 @@ subroutine construct_momentum_surface_element_cg(sele, big_m, rhs, ct_m, ct_rhs, ! now do surface integrals for divergence/pressure gradient matrix if(integrate_continuity_by_parts.and. (assemble_ct_matrix_here .or. include_pressure_and_continuity_bcs)) then - if (velocity_bc_type(1,sele)/=BC_TYPE_NO_NORMAL_FLOW .and. velocity_bc_type(1,sele)/=BC_TYPE_FREE_SURFACE) then + if (velocity_bc_type(1,sele)/=BC_TYPE_NO_NORMAL_FLOW .and. velocity_bc_type(1,sele)/=BC_TYPE_FREE_SURFACE) then - if(multiphase) then - ct_mat_bdy = shape_shape_vector(p_shape, u_shape, detwei_bdy*face_val_at_quad(nvfrac, sele), normal_bdy) - else - ct_mat_bdy = shape_shape_vector(p_shape, u_shape, detwei_bdy, normal_bdy) - end if + if(multiphase) then + ct_mat_bdy = shape_shape_vector(p_shape, u_shape, detwei_bdy*face_val_at_quad(nvfrac, sele), normal_bdy) + else + ct_mat_bdy = shape_shape_vector(p_shape, u_shape, detwei_bdy, normal_bdy) + end if - do dim = 1, u%dim - if(include_pressure_and_continuity_bcs .and. velocity_bc_type(dim, sele)==1 )then - call addto(ct_rhs, p_nodes_bdy, & + do dim = 1, u%dim + if(include_pressure_and_continuity_bcs .and. velocity_bc_type(dim, sele)==1 )then + call addto(ct_rhs, p_nodes_bdy, & -matmul(ct_mat_bdy(dim,:,:), ele_val(velocity_bc, dim, sele))) - else if (assemble_ct_matrix_here) then - ! for open boundaries add in the boundary integral from integrating by parts - for - ! other bcs leaving this out enforces a dirichlet-type restriction in the normal direction - call addto(ct_m, 1, dim, p_nodes_bdy, u_nodes_bdy, ct_mat_bdy(dim,:,:)) - end if - if(pressure_bc_type(sele)>0) then - ! for both weak and strong pressure dirichlet bcs: - ! / - ! add -| N_i M_j \vec n p_j, where p_j are the prescribed bc values - ! / - if (subtract_out_reference_profile) then - ! Here we subtract the hydrostatic component from the pressure boundary condition used in the surface integral when - ! assembling ct_m. Hopefully this will be the same as the pressure boundary condition itself. - call addto(rhs, dim, u_nodes_bdy, -matmul(ele_val(pressure_bc, sele)-face_val(hb_pressure, sele), & - ct_mat_bdy(dim,:,:) )) - else - call addto(rhs, dim, u_nodes_bdy, -matmul( ele_val(pressure_bc, sele), & - ct_mat_bdy(dim,:,:) )) - end if - end if - end do - end if + else if (assemble_ct_matrix_here) then + ! for open boundaries add in the boundary integral from integrating by parts - for + ! other bcs leaving this out enforces a dirichlet-type restriction in the normal direction + call addto(ct_m, 1, dim, p_nodes_bdy, u_nodes_bdy, ct_mat_bdy(dim,:,:)) + end if + if(pressure_bc_type(sele)>0) then + ! for both weak and strong pressure dirichlet bcs: + ! / + ! add -| N_i M_j \vec n p_j, where p_j are the prescribed bc values + ! / + if (subtract_out_reference_profile) then + ! Here we subtract the hydrostatic component from the pressure boundary condition used in the surface integral when + ! assembling ct_m. Hopefully this will be the same as the pressure boundary condition itself. + call addto(rhs, dim, u_nodes_bdy, -matmul(ele_val(pressure_bc, sele)-face_val(hb_pressure, sele), & + ct_mat_bdy(dim,:,:) )) + else + call addto(rhs, dim, u_nodes_bdy, -matmul( ele_val(pressure_bc, sele), & + ct_mat_bdy(dim,:,:) )) + end if + end if + end do + end if end if ! Add free surface stabilisation. if (velocity_bc_type(1,sele)==BC_TYPE_FREE_SURFACE .and. have_surface_fs_stabilisation) then - if (on_sphere) then - upwards_gi=-radial_inward_normal_at_quad_face(x, sele) - else - upwards_gi=-face_val_at_quad(gravity, sele) - end if - - if (on_sphere) then - ndotk_k=0.0 - do i=1,face_ngi(u,sele) - ndotk_k(3,i)=fs_sf*dot_product(normal_bdy(:,i),upwards_gi(:,i)) - end do - else - do i=1,face_ngi(u,sele) - ndotk_k(:,i)=fs_sf*dot_product(normal_bdy(:,i),upwards_gi(:,i))*upwards_gi(:,i) - end do - end if - - ! Rotate if on the sphere - if (on_sphere) then - fs_stab_gi_sphere=dt*gravity_magnitude*rotate_diagonal_to_sphere_face(x, sele, ndotk_k) - endif - - density_gi=face_val_at_quad(density, sele) - - if (on_sphere) then - fs_surfacestab_sphere = shape_shape_tensor(u_shape, u_shape, & - detwei_bdy*density_gi, fs_stab_gi_sphere) - else - fs_surfacestab = shape_shape_vector(u_shape, u_shape, & - detwei_bdy*density_gi, dt*gravity_magnitude*ndotk_k) - end if - - if (on_sphere) then - do dim = 1, u%dim - do dim2 = 1, u%dim - call addto(big_m, dim, dim2, u_nodes_bdy, u_nodes_bdy, dt*theta*fs_surfacestab_sphere(dim,dim2,:,:)) - end do - call addto(rhs, dim, u_nodes_bdy, -matmul(fs_surfacestab_sphere(dim,dim,:,:), oldu_val(dim,:))) - ! off block diagonal absorption terms - do dim2 = 1, u%dim - if (dim==dim2) cycle ! The dim=dim2 terms were done above - call addto(rhs, dim, u_nodes_bdy, -matmul(fs_surfacestab_sphere(dim,dim2,:,:), oldu_val(dim2,:))) + if (on_sphere) then + upwards_gi=-radial_inward_normal_at_quad_face(x, sele) + else + upwards_gi=-face_val_at_quad(gravity, sele) + end if + + if (on_sphere) then + ndotk_k=0.0 + do i=1,face_ngi(u,sele) + ndotk_k(3,i)=fs_sf*dot_product(normal_bdy(:,i),upwards_gi(:,i)) end do - end do - else - if (lump_mass) then - lumped_fs_surfacestab = sum(fs_surfacestab, 3) - do dim = 1, u%dim - call addto_diag(big_m, dim, dim, u_nodes_bdy, dt*theta*lumped_fs_surfacestab(dim,:)) - call addto(rhs, dim, u_nodes_bdy, -lumped_fs_surfacestab(dim,:)*oldu_val(dim,:)) + else + do i=1,face_ngi(u,sele) + ndotk_k(:,i)=fs_sf*dot_product(normal_bdy(:,i),upwards_gi(:,i))*upwards_gi(:,i) end do - else if (.not.pressure_corrected_absorption) then + end if + + ! Rotate if on the sphere + if (on_sphere) then + fs_stab_gi_sphere=dt*gravity_magnitude*rotate_diagonal_to_sphere_face(x, sele, ndotk_k) + endif + + density_gi=face_val_at_quad(density, sele) + + if (on_sphere) then + fs_surfacestab_sphere = shape_shape_tensor(u_shape, u_shape, & + detwei_bdy*density_gi, fs_stab_gi_sphere) + else + fs_surfacestab = shape_shape_vector(u_shape, u_shape, & + detwei_bdy*density_gi, dt*gravity_magnitude*ndotk_k) + end if + + if (on_sphere) then do dim = 1, u%dim - call addto(big_m, dim, dim, u_nodes_bdy, u_nodes_bdy, dt*theta*fs_surfacestab(dim,:,:)) - call addto(rhs, dim, u_nodes_bdy, -matmul(fs_surfacestab(dim,:,:), oldu_val(dim,:))) + do dim2 = 1, u%dim + call addto(big_m, dim, dim2, u_nodes_bdy, u_nodes_bdy, dt*theta*fs_surfacestab_sphere(dim,dim2,:,:)) + end do + call addto(rhs, dim, u_nodes_bdy, -matmul(fs_surfacestab_sphere(dim,dim,:,:), oldu_val(dim,:))) + ! off block diagonal absorption terms + do dim2 = 1, u%dim + if (dim==dim2) cycle ! The dim=dim2 terms were done above + call addto(rhs, dim, u_nodes_bdy, -matmul(fs_surfacestab_sphere(dim,dim2,:,:), oldu_val(dim2,:))) + end do end do - else - ewrite(-1,*) "Free surface stabilisation requires that mass is lumped or that" - FLExit("absorption is not included in the pressure correction") - end if - if (pressure_corrected_absorption) then - if (assemble_inverse_masslump.and.(.not.(abs_lump_on_submesh))) then - call addto(masslump, u_nodes_bdy, dt*theta*lumped_fs_surfacestab) + else + if (lump_mass) then + lumped_fs_surfacestab = sum(fs_surfacestab, 3) + do dim = 1, u%dim + call addto_diag(big_m, dim, dim, u_nodes_bdy, dt*theta*lumped_fs_surfacestab(dim,:)) + call addto(rhs, dim, u_nodes_bdy, -lumped_fs_surfacestab(dim,:)*oldu_val(dim,:)) + end do + else if (.not.pressure_corrected_absorption) then + do dim = 1, u%dim + call addto(big_m, dim, dim, u_nodes_bdy, u_nodes_bdy, dt*theta*fs_surfacestab(dim,:,:)) + call addto(rhs, dim, u_nodes_bdy, -matmul(fs_surfacestab(dim,:,:), oldu_val(dim,:))) + end do else - FLAbort("Error?") + ewrite(-1,*) "Free surface stabilisation requires that mass is lumped or that" + FLExit("absorption is not included in the pressure correction") end if - end if - end if + if (pressure_corrected_absorption) then + if (assemble_inverse_masslump.and.(.not.(abs_lump_on_submesh))) then + call addto(masslump, u_nodes_bdy, dt*theta*lumped_fs_surfacestab) + else + FLAbort("Error?") + end if + end if + end if end if if (any(velocity_bc_type(:,sele)==BC_TYPE_FLUX)) then - do dim = 1, u%dim - if(velocity_bc_type(dim,sele)==BC_TYPE_FLUX) then - call addto(rhs, dim, u_nodes_bdy, shape_rhs(u_shape, ele_val_at_quad(velocity_bc, sele, dim)*detwei_bdy)) - end if - end do + do dim = 1, u%dim + if(velocity_bc_type(dim,sele)==BC_TYPE_FLUX) then + call addto(rhs, dim, u_nodes_bdy, shape_rhs(u_shape, ele_val_at_quad(velocity_bc, sele, dim)*detwei_bdy)) + end if + end do end if - end subroutine construct_momentum_surface_element_cg + end subroutine construct_momentum_surface_element_cg - subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & - mass, masslump, & - x, x_old, x_new, u, oldu, nu, ug, & - density, ct_rhs, & - source, absorption, buoyancy, hb_density, gravity, & - viscosity, grad_u, & - fnu, tnu, leonard, strainprod, alpha, gamma, & - gp, surfacetension, & - swe_bottom_drag, old_pressure, p, & - assemble_ct_matrix_here, depth, & - alpha_u_field, abs_wd, temperature, nvfrac, supg_shape) + subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & + mass, masslump, & + x, x_old, x_new, u, oldu, nu, ug, & + density, ct_rhs, & + source, absorption, buoyancy, hb_density, gravity, & + viscosity, grad_u, & + fnu, tnu, leonard, strainprod, alpha, gamma, & + gp, surfacetension, & + swe_bottom_drag, old_pressure, p, & + assemble_ct_matrix_here, depth, & + alpha_u_field, abs_wd, temperature, nvfrac, supg_shape) !!< Assembles the local element matrix contributions and places them in big_m !!< and rhs for the continuous galerkin momentum equations @@ -1278,11 +1278,11 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & type(element_type) :: test_function if(move_mesh) then - ! we've assumed the following in the declarations - ! above so we better make sure they're true! - assert(ele_loc(ug, ele)==ele_loc(u,ele)) - assert(ele_ngi(ug, ele)==ele_ngi(u,ele)) - assert(ug%dim==u%dim) + ! we've assumed the following in the declarations + ! above so we better make sure they're true! + assert(ele_loc(ug, ele)==ele_loc(u,ele)) + assert(ele_ngi(ug, ele)==ele_ngi(u,ele)) + assert(ug%dim==u%dim) end if big_m_diag_addto = 0.0 @@ -1291,12 +1291,12 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & ! we always want things added to the diagonal blocks ! but we must check if we have_coriolis to add things to the others if(have_coriolis.or.(have_viscosity.and.(stress_form.or.partial_stress_form))) then - block_mask = .true. + block_mask = .true. else - block_mask = .false. - do dim = 1, u%dim - block_mask(dim, dim) = .true. - end do + block_mask = .false. + do dim = 1, u%dim + block_mask(dim, dim) = .true. + end do end if u_ele=>ele_nodes(u, ele) @@ -1311,27 +1311,27 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & ! transform the velocity derivatives into physical space ! (and get detwei) if(stabilisation_scheme==STABILISATION_NONE) then - call transform_to_physical(X, ele, & - u_shape, dshape=du_t, detwei=detwei) - ! J_mat = 0.0 + call transform_to_physical(X, ele, & + u_shape, dshape=du_t, detwei=detwei) + ! J_mat = 0.0 else - call transform_to_physical(x, ele, & - u_shape, dshape=du_t, detwei=detwei, J=J_mat) + call transform_to_physical(x, ele, & + u_shape, dshape=du_t, detwei=detwei, J=J_mat) end if if(assemble_ct_matrix_here .and.integrate_continuity_by_parts) then - ! transform the pressure derivatives into physical space - call transform_to_physical(x, ele, & - p_shape, dshape=dp_t) + ! transform the pressure derivatives into physical space + call transform_to_physical(x, ele, & + p_shape, dshape=dp_t) end if if(move_mesh) then - call transform_to_physical(x_old, ele, detwei=detwei_old) - call transform_to_physical(x_new, ele, detwei=detwei_new) - if(.not.exclude_advection.and..not.integrate_advection_by_parts) then - call transform_to_physical(x, ele, & - ele_shape(ug, ele), dshape=dug_t) - end if + call transform_to_physical(x_old, ele, detwei=detwei_old) + call transform_to_physical(x_new, ele, detwei=detwei_new) + if(.not.exclude_advection.and..not.integrate_advection_by_parts) then + call transform_to_physical(x, ele, & + ele_shape(ug, ele), dshape=dug_t) + end if end if if(multiphase) then @@ -1343,32 +1343,32 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & ! Step 2: Set up test function select case(stabilisation_scheme) - case(STABILISATION_SUPG) - relu_gi = ele_val_at_quad(nu, ele) - if(move_mesh) then + case(STABILISATION_SUPG) + relu_gi = ele_val_at_quad(nu, ele) + if(move_mesh) then relu_gi = relu_gi - ele_val_at_quad(ug, ele) - end if - if(have_viscosity) then - diff_q = ele_val_at_quad(viscosity, ele) - - ! for full and partial stress form we need to set the off diagonal terms of the viscosity tensor to zero - ! to be able to invert it when calculating nu_bar - do i=1,size(diff_q,1) - do j=1,size(diff_q,2) - if(i.eq.j) cycle - diff_q(i,j,:) = 0.0 - end do - end do - - call supg_test_function(supg_shape, u_shape, du_t, relu_gi, j_mat, diff_q = diff_q, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - else - call supg_test_function(supg_shape, u_shape, du_t, relu_gi, j_mat, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - end if - test_function = supg_shape - case default - test_function = u_shape + end if + if(have_viscosity) then + diff_q = ele_val_at_quad(viscosity, ele) + + ! for full and partial stress form we need to set the off diagonal terms of the viscosity tensor to zero + ! to be able to invert it when calculating nu_bar + do i=1,size(diff_q,1) + do j=1,size(diff_q,2) + if(i.eq.j) cycle + diff_q(i,j,:) = 0.0 + end do + end do + + call supg_test_function(supg_shape, u_shape, du_t, relu_gi, j_mat, diff_q = diff_q, & + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + else + call supg_test_function(supg_shape, u_shape, du_t, relu_gi, j_mat, & + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + end if + test_function = supg_shape + case default + test_function = u_shape end select ! Important note: the test function derivatives have not been modified - ! i.e. du_t is currently used everywhere. This is fine for P1, but is not @@ -1396,7 +1396,7 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & end if grad_p_u_mat = shape_dshape(p_shape, du_t, detwei*ele_val_at_quad(nvfrac, ele)) + & - shape_shape_vector(p_shape, u_shape, detwei, ele_grad_at_quad(nvfrac, ele, dnvfrac_t)) + shape_shape_vector(p_shape, u_shape, detwei, ele_grad_at_quad(nvfrac, ele, dnvfrac_t)) else grad_p_u_mat = shape_dshape(p_shape, du_t, detwei) end if @@ -1407,53 +1407,53 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & ! Mass terms if(assemble_inverse_masslump .or. assemble_mass_matrix .or. & - (.not. exclude_mass)) then - call add_mass_element_cg(ele, test_function, u, oldu_val, density, nvfrac, detwei, detwei_old, detwei_new, big_m_diag_addto, big_m_tensor_addto, rhs_addto, mass, masslump) + (.not. exclude_mass)) then + call add_mass_element_cg(ele, test_function, u, oldu_val, density, nvfrac, detwei, detwei_old, detwei_new, big_m_diag_addto, big_m_tensor_addto, rhs_addto, mass, masslump) end if ! Advection terms if(.not. exclude_advection) then - call add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, density, viscosity, nvfrac, du_t, dug_t, dnvfrac_t, detwei, J_mat, big_m_tensor_addto, rhs_addto) + call add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, density, viscosity, nvfrac, du_t, dug_t, dnvfrac_t, detwei, J_mat, big_m_tensor_addto, rhs_addto) end if ! Source terms if(have_source) then - call add_sources_element_cg(ele, test_function, u, density, source, detwei, rhs_addto) + call add_sources_element_cg(ele, test_function, u, density, source, detwei, rhs_addto) end if ! Buoyancy terms if(have_gravity) then - call add_buoyancy_element_cg(x, ele, test_function, u, buoyancy, hb_density, gravity, nvfrac, detwei, rhs_addto) + call add_buoyancy_element_cg(x, ele, test_function, u, buoyancy, hb_density, gravity, nvfrac, detwei, rhs_addto) end if ! Surface tension if(have_surfacetension) then - call add_surfacetension_element_cg(ele, test_function, u, surfacetension, du_t, detwei, rhs_addto) + call add_surfacetension_element_cg(ele, test_function, u, surfacetension, du_t, detwei, rhs_addto) end if ! Absorption terms (sponges) and WettingDrying absorption if (have_absorption .or. have_vertical_stabilization .or. have_wd_abs .or. have_swe_bottom_drag) then - call add_absorption_element_cg(x, ele, test_function, u, oldu_val, density, & - absorption, detwei, big_m_diag_addto, big_m_tensor_addto, rhs_addto, & - masslump, mass, depth, gravity, buoyancy, & - swe_bottom_drag, old_pressure, p, nu, & - alpha_u_field, abs_wd) + call add_absorption_element_cg(x, ele, test_function, u, oldu_val, density, & + absorption, detwei, big_m_diag_addto, big_m_tensor_addto, rhs_addto, & + masslump, mass, depth, gravity, buoyancy, & + swe_bottom_drag, old_pressure, p, nu, & + alpha_u_field, abs_wd) end if ! Viscous terms if(have_viscosity .or. have_les) then - call add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, x, viscosity, grad_u, & - fnu, tnu, leonard, strainprod, alpha, gamma, du_t, detwei, big_m_tensor_addto, rhs_addto, temperature, density, nvfrac) + call add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, x, viscosity, grad_u, & + fnu, tnu, leonard, strainprod, alpha, gamma, du_t, detwei, big_m_tensor_addto, rhs_addto, temperature, density, nvfrac) end if ! Coriolis terms if(have_coriolis) then - call add_coriolis_element_cg(ele, test_function, x, u, oldu_val, density, detwei, big_m_tensor_addto, rhs_addto) + call add_coriolis_element_cg(ele, test_function, x, u, oldu_val, density, detwei, big_m_tensor_addto, rhs_addto) end if ! Geostrophic pressure if(have_geostrophic_pressure) then - call add_geostrophic_pressure_element_cg(ele, test_function, x, u, gp, detwei, rhs_addto) + call add_geostrophic_pressure_element_cg(ele, test_function, x, u, gp, detwei, rhs_addto) end if ! Step 4: Insertion @@ -1466,30 +1466,30 @@ subroutine construct_momentum_element_cg(state, ele, big_m, rhs, ct_m, & call addto(rhs, u_ele, rhs_addto) if(assemble_ct_matrix_here) then - call addto(ct_m, p_ele, u_ele, spread(grad_p_u_mat, 1, 1)) + call addto(ct_m, p_ele, u_ele, spread(grad_p_u_mat, 1, 1)) end if if(multiphase) then deallocate(dnvfrac_t) end if - contains + contains subroutine add_diagonal_to_tensor(big_m_diag_addto, big_m_tensor_addto) - real, dimension(u%dim, ele_loc(u, ele)), intent(in) :: big_m_diag_addto - real, dimension(u%dim, u%dim, ele_loc(u, ele), ele_loc(u, ele)), intent(inout) :: big_m_tensor_addto + real, dimension(u%dim, ele_loc(u, ele)), intent(in) :: big_m_diag_addto + real, dimension(u%dim, u%dim, ele_loc(u, ele), ele_loc(u, ele)), intent(inout) :: big_m_tensor_addto - integer :: dim, loc + integer :: dim, loc - forall(dim = 1:size(big_m_diag_addto, 1), loc = 1:size(big_m_diag_addto, 2)) - big_m_tensor_addto(dim, dim, loc, loc) = big_m_tensor_addto(dim, dim, loc, loc) + big_m_diag_addto(dim, loc) - end forall + forall(dim = 1:size(big_m_diag_addto, 1), loc = 1:size(big_m_diag_addto, 2)) + big_m_tensor_addto(dim, dim, loc, loc) = big_m_tensor_addto(dim, dim, loc, loc) + big_m_diag_addto(dim, loc) + end forall end subroutine add_diagonal_to_tensor - end subroutine construct_momentum_element_cg + end subroutine construct_momentum_element_cg - subroutine add_mass_element_cg(ele, test_function, u, oldu_val, density, nvfrac, detwei, detwei_old, detwei_new, big_m_diag_addto, big_m_tensor_addto, rhs_addto, mass, masslump) + subroutine add_mass_element_cg(ele, test_function, u, oldu_val, density, nvfrac, detwei, detwei_old, detwei_new, big_m_diag_addto, big_m_tensor_addto, rhs_addto, mass, masslump) integer, intent(in) :: ele type(element_type), intent(in) :: test_function type(vector_field), intent(in) :: u @@ -1544,24 +1544,24 @@ subroutine add_mass_element_cg(ele, test_function, u, oldu_val, density, nvfrac, compute_lumped_mass_here=.not. (vel_lump_on_submesh .or. cmc_lump_on_submesh) if(.not.exclude_mass) then - if(lump_mass) then - if (compute_lumped_mass_here) then + if(lump_mass) then + if (compute_lumped_mass_here) then + do dim = 1, u%dim + big_m_diag_addto(dim, :) = big_m_diag_addto(dim, :) + mass_lump + end do + end if + else do dim = 1, u%dim - big_m_diag_addto(dim, :) = big_m_diag_addto(dim, :) + mass_lump + big_m_tensor_addto(dim, dim, :, :) = big_m_tensor_addto(dim, dim, :, :) + mass_mat end do - end if - else - do dim = 1, u%dim - big_m_tensor_addto(dim, dim, :, :) = big_m_tensor_addto(dim, dim, :, :) + mass_mat - end do - end if + end if end if if(assemble_inverse_masslump .and. compute_lumped_mass_here) then - ! store the lumped mass as field, the same for each component - do dim = 1, u%dim - call addto(masslump, dim, u_ele, mass_lump) - end do + ! store the lumped mass as field, the same for each component + do dim = 1, u%dim + call addto(masslump, dim, u_ele, mass_lump) + end do end if if(assemble_mass_matrix) then @@ -1571,35 +1571,35 @@ subroutine add_mass_element_cg(ele, test_function, u, oldu_val, density, nvfrac, end if if(move_mesh) then - ! In the unaccelerated form we solve: - ! / - ! | N^{n+1} u^{n+1}/dt - N^{n} u^n/dt + ... = f - ! / - ! so in accelerated form: - ! / - ! | N^{n+1} du + (N^{n+1}- N^{n}) u^n/dt + ... = f - ! / - ! where du=(u^{n+1}-u^{n})/dt is the acceleration. - ! Put the (N^{n+1}-N^{n}) u^n term on the rhs - mass_mat = shape_shape(test_function, u_shape, (detwei_new-detwei_old)*density_gi) - - if(lump_mass) then - if(compute_lumped_mass_here) then - mass_lump = sum(mass_mat, 2) + ! In the unaccelerated form we solve: + ! / + ! | N^{n+1} u^{n+1}/dt - N^{n} u^n/dt + ... = f + ! / + ! so in accelerated form: + ! / + ! | N^{n+1} du + (N^{n+1}- N^{n}) u^n/dt + ... = f + ! / + ! where du=(u^{n+1}-u^{n})/dt is the acceleration. + ! Put the (N^{n+1}-N^{n}) u^n term on the rhs + mass_mat = shape_shape(test_function, u_shape, (detwei_new-detwei_old)*density_gi) + + if(lump_mass) then + if(compute_lumped_mass_here) then + mass_lump = sum(mass_mat, 2) + do dim = 1, u%dim + rhs_addto(dim,:) = rhs_addto(dim,:) - mass_lump*oldu_val(dim,:)/dt + end do + end if + else do dim = 1, u%dim - rhs_addto(dim,:) = rhs_addto(dim,:) - mass_lump*oldu_val(dim,:)/dt + rhs_addto(dim,:) = rhs_addto(dim,:) - matmul(mass_mat, oldu_val(dim,:))/dt end do - end if - else - do dim = 1, u%dim - rhs_addto(dim,:) = rhs_addto(dim,:) - matmul(mass_mat, oldu_val(dim,:))/dt - end do - end if + end if end if - end subroutine add_mass_element_cg + end subroutine add_mass_element_cg - subroutine add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, density, viscosity, nvfrac, du_t, dug_t, dnvfrac_t, detwei, J_mat, big_m_tensor_addto, rhs_addto) + subroutine add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, density, viscosity, nvfrac, du_t, dug_t, dnvfrac_t, detwei, J_mat, big_m_tensor_addto, rhs_addto) integer, intent(in) :: ele type(element_type), intent(in) :: test_function type(vector_field), intent(in) :: u @@ -1634,7 +1634,7 @@ subroutine add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, de density_gi=ele_val_at_quad(density, ele) relu_gi = ele_val_at_quad(nu, ele) if(move_mesh) then - relu_gi = relu_gi - ele_val_at_quad(ug, ele) + relu_gi = relu_gi - ele_val_at_quad(ug, ele) end if div_relu_gi = ele_div_at_quad(nu, ele, du_t) @@ -1644,11 +1644,11 @@ subroutine add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, de end if if(integrate_advection_by_parts) then - ! element advection matrix - ! / / - ! - | (grad N_A dot nu) N_B rho dV - (1. - beta) | N_A ( div nu ) N_B rho dV - ! / / - if(multiphase) then + ! element advection matrix + ! / / + ! - | (grad N_A dot nu) N_B rho dV - (1. - beta) | N_A ( div nu ) N_B rho dV + ! / / + if(multiphase) then ! element advection matrix ! / / ! - | (grad N_A dot nu) N_B rho vfrac dV - (1. - beta) | N_A ( div(nu vfrac) ) N_B rho dV @@ -1661,30 +1661,30 @@ subroutine add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, de relu_dot_grad_nvfrac_gi(i) = dot_product(relu_gi(:,i), grad_nvfrac_gi(:,i)) end do advection_mat = -dshape_dot_vector_shape(du_t, relu_gi, u_shape, detwei*density_gi*nvfrac_gi) & - -(1.-beta)*(shape_shape(test_function, u_shape, div_relu_gi*detwei*density_gi*nvfrac_gi) + & - shape_shape(test_function, u_shape, detwei*density_gi*relu_dot_grad_nvfrac_gi)) - else + -(1.-beta)*(shape_shape(test_function, u_shape, div_relu_gi*detwei*density_gi*nvfrac_gi) + & + shape_shape(test_function, u_shape, detwei*density_gi*relu_dot_grad_nvfrac_gi)) + else advection_mat = -dshape_dot_vector_shape(du_t, relu_gi, u_shape, detwei*density_gi) & - -(1.-beta)*shape_shape(test_function, u_shape, div_relu_gi*detwei*density_gi) - end if + -(1.-beta)*shape_shape(test_function, u_shape, div_relu_gi*detwei*density_gi) + end if else - ! element advection matrix - ! / / - ! | N_A (nu dot grad N_B) rho dV + beta | N_A ( div nu ) N_B rho dV - ! / / - coefficient_detwei = density_gi*detwei - if(multiphase) then - coefficient_detwei = coefficient_detwei*nvfrac_gi - end if - advection_mat = shape_vector_dot_dshape(test_function, relu_gi, du_t, coefficient_detwei) & - +beta*shape_shape(test_function, u_shape, div_relu_gi*detwei*density_gi) - if(move_mesh) then - advection_mat = advection_mat - shape_shape(test_function, u_shape, ele_div_at_quad(ug, ele, dug_t)*detwei*density_gi) - end if + ! element advection matrix + ! / / + ! | N_A (nu dot grad N_B) rho dV + beta | N_A ( div nu ) N_B rho dV + ! / / + coefficient_detwei = density_gi*detwei + if(multiphase) then + coefficient_detwei = coefficient_detwei*nvfrac_gi + end if + advection_mat = shape_vector_dot_dshape(test_function, relu_gi, du_t, coefficient_detwei) & + +beta*shape_shape(test_function, u_shape, div_relu_gi*detwei*density_gi) + if(move_mesh) then + advection_mat = advection_mat - shape_shape(test_function, u_shape, ele_div_at_quad(ug, ele, dug_t)*detwei*density_gi) + end if end if select case(stabilisation_scheme) - case(STABILISATION_STREAMLINE_UPWIND) + case(STABILISATION_STREAMLINE_UPWIND) if(have_viscosity) then diff_q = ele_val_at_quad(viscosity, ele) @@ -1698,23 +1698,23 @@ subroutine add_advection_element_cg(ele, test_function, u, oldu_val, nu, ug, de end do advection_mat = advection_mat + & - & element_upwind_stabilisation(u_shape, du_t, relu_gi, J_mat, detwei, & - & diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + & element_upwind_stabilisation(u_shape, du_t, relu_gi, J_mat, detwei, & + & diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) else advection_mat = advection_mat + & - & element_upwind_stabilisation(u_shape, du_t, relu_gi, J_mat, detwei, & - & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + & element_upwind_stabilisation(u_shape, du_t, relu_gi, J_mat, detwei, & + & nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) end if end select do dim = 1, u%dim - big_m_tensor_addto(dim, dim, :, :) = big_m_tensor_addto(dim, dim, :, :) + dt*theta*advection_mat - rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(advection_mat, oldu_val(dim,:)) + big_m_tensor_addto(dim, dim, :, :) = big_m_tensor_addto(dim, dim, :, :) + dt*theta*advection_mat + rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(advection_mat, oldu_val(dim,:)) end do - end subroutine add_advection_element_cg + end subroutine add_advection_element_cg - subroutine add_sources_element_cg(ele, test_function, u, density, source, detwei, rhs_addto) + subroutine add_sources_element_cg(ele, test_function, u, density, source, detwei, rhs_addto) integer, intent(in) :: ele type(element_type), intent(in) :: test_function type(vector_field), intent(in) :: u @@ -1736,21 +1736,21 @@ subroutine add_sources_element_cg(ele, test_function, u, density, source, detwei ! / source_mat = shape_shape(test_function, ele_shape(source, ele), detwei*density_gi) if(lump_source) then - assert(ele_loc(source, ele)==ele_loc(u, ele)) - source_lump = sum(source_mat, 2) - do dim = 1, u%dim - ! lumped source - rhs_addto(dim, :) = rhs_addto(dim, :) + source_lump*ele_val(source, dim, ele) - end do + assert(ele_loc(source, ele)==ele_loc(u, ele)) + source_lump = sum(source_mat, 2) + do dim = 1, u%dim + ! lumped source + rhs_addto(dim, :) = rhs_addto(dim, :) + source_lump*ele_val(source, dim, ele) + end do else - do dim = 1, u%dim - rhs_addto(dim, :) = rhs_addto(dim, :) + matmul(source_mat, ele_val(source, dim, ele)) - end do + do dim = 1, u%dim + rhs_addto(dim, :) = rhs_addto(dim, :) + matmul(source_mat, ele_val(source, dim, ele)) + end do end if - end subroutine add_sources_element_cg + end subroutine add_sources_element_cg - subroutine add_buoyancy_element_cg(positions, ele, test_function, u, buoyancy, hb_density, gravity, nvfrac, detwei, rhs_addto) + subroutine add_buoyancy_element_cg(positions, ele, test_function, u, buoyancy, hb_density, gravity, nvfrac, detwei, rhs_addto) type(vector_field), intent(in) :: positions integer, intent(in) :: ele type(element_type), intent(in) :: test_function @@ -1765,9 +1765,9 @@ subroutine add_buoyancy_element_cg(positions, ele, test_function, u, buoyancy, h real, dimension(ele_ngi(u, ele)) :: coefficient_detwei if (subtract_out_reference_profile) then - coefficient_detwei = gravity_magnitude*(ele_val_at_quad(buoyancy, ele)-ele_val_at_quad(hb_density, ele))*detwei + coefficient_detwei = gravity_magnitude*(ele_val_at_quad(buoyancy, ele)-ele_val_at_quad(hb_density, ele))*detwei else - coefficient_detwei = gravity_magnitude*ele_val_at_quad(buoyancy, ele)*detwei + coefficient_detwei = gravity_magnitude*ele_val_at_quad(buoyancy, ele)*detwei end if if(multiphase) then @@ -1776,22 +1776,22 @@ subroutine add_buoyancy_element_cg(positions, ele, test_function, u, buoyancy, h end if if (radial_gravity) then - ! If we're using radial gravity evaluate the direction of the gravity vector - ! exactly at quadrature points. - rhs_addto = rhs_addto + & - shape_vector_rhs(test_function, & - radial_inward_normal_at_quad_ele(positions, ele), & - coefficient_detwei) + ! If we're using radial gravity evaluate the direction of the gravity vector + ! exactly at quadrature points. + rhs_addto = rhs_addto + & + shape_vector_rhs(test_function, & + radial_inward_normal_at_quad_ele(positions, ele), & + coefficient_detwei) else - rhs_addto = rhs_addto + & - shape_vector_rhs(test_function, & - ele_val_at_quad(gravity, ele), & - coefficient_detwei) + rhs_addto = rhs_addto + & + shape_vector_rhs(test_function, & + ele_val_at_quad(gravity, ele), & + coefficient_detwei) endif - end subroutine add_buoyancy_element_cg + end subroutine add_buoyancy_element_cg - subroutine add_surfacetension_element_cg(ele, test_function, u, surfacetension, du_t, detwei, rhs_addto) + subroutine add_surfacetension_element_cg(ele, test_function, u, surfacetension, du_t, detwei, rhs_addto) integer, intent(in) :: ele type(element_type), intent(in) :: test_function type(vector_field), intent(in) :: u @@ -1804,23 +1804,23 @@ subroutine add_surfacetension_element_cg(ele, test_function, u, surfacetension, real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: tension if(integrate_surfacetension_by_parts) then - tension = ele_val_at_quad(surfacetension, ele) + tension = ele_val_at_quad(surfacetension, ele) - rhs_addto = rhs_addto - dshape_dot_tensor_rhs(du_t, tension, detwei) + rhs_addto = rhs_addto - dshape_dot_tensor_rhs(du_t, tension, detwei) else - dtensiondj = ele_div_at_quad_tensor(surfacetension, ele, du_t) + dtensiondj = ele_div_at_quad_tensor(surfacetension, ele, du_t) - rhs_addto = rhs_addto + shape_vector_rhs(test_function,dtensiondj,detwei) + rhs_addto = rhs_addto + shape_vector_rhs(test_function,dtensiondj,detwei) end if - end subroutine add_surfacetension_element_cg + end subroutine add_surfacetension_element_cg - subroutine add_absorption_element_cg(positions, ele, test_function, u, oldu_val, & - density, absorption, detwei, & - big_m_diag_addto, big_m_tensor_addto, rhs_addto, & - masslump, mass, depth, gravity, buoyancy, & - swe_bottom_drag, old_pressure, p, nu, & - alpha_u_field, abs_wd) + subroutine add_absorption_element_cg(positions, ele, test_function, u, oldu_val, & + density, absorption, detwei, & + big_m_diag_addto, big_m_tensor_addto, rhs_addto, & + masslump, mass, depth, gravity, buoyancy, & + swe_bottom_drag, old_pressure, p, nu, & + alpha_u_field, abs_wd) type(vector_field), intent(in) :: positions integer, intent(in) :: ele type(element_type), intent(in) :: test_function @@ -1874,97 +1874,97 @@ subroutine add_absorption_element_cg(positions, ele, test_function, u, oldu_val, tensor_absorption_gi=0.0 if (have_absorption) then - absorption_gi = ele_val_at_quad(absorption, ele) + absorption_gi = ele_val_at_quad(absorption, ele) end if if (on_sphere.and.have_absorption) then ! Rotate the absorption - tensor_absorption_gi=rotate_diagonal_to_sphere_gi(positions, ele, absorption_gi) + tensor_absorption_gi=rotate_diagonal_to_sphere_gi(positions, ele, absorption_gi) end if ! If we have any vertical stabilizing absorption terms, calculate them now if (have_vertical_stabilization) then - ! zero the vertical stab absorptions - vvr_abs_diag=0.0 - vvr_abs=0.0 - ib_abs=0.0 - ib_abs_diag=0.0 - - if (have_vertical_velocity_relaxation) then - - assert(ele_ngi(u, ele)==ele_ngi(density, ele)) - assert(ele_ngi(density,ele)==ele_ngi(depth,ele)) - - ! Form the vertical velocity relaxation absorption term - if (on_sphere) then - assert(ele_ngi(u, ele)==ele_ngi(positions, ele)) - else - assert(ele_ngi(u, ele)==ele_ngi(gravity, ele)) - grav_at_quads=ele_val_at_quad(gravity, ele) - end if - depth_at_quads=ele_val_at_quad(depth, ele) - - if (on_sphere) then - do i=1,ele_ngi(u,ele) - vvr_abs_diag(3,i)=-vvr_sf*gravity_magnitude*dt/depth_at_quads(i) - end do - vvr_abs=rotate_diagonal_to_sphere_gi(positions, ele, vvr_abs_diag) - else - do i=1,ele_ngi(u,ele) - vvr_abs_diag(:,i)=vvr_sf*gravity_magnitude*dt*grav_at_quads(:,i)/depth_at_quads(i) - end do - end if - end if + ! zero the vertical stab absorptions + vvr_abs_diag=0.0 + vvr_abs=0.0 + ib_abs=0.0 + ib_abs_diag=0.0 - if (have_implicit_buoyancy) then + if (have_vertical_velocity_relaxation) then - assert(ele_ngi(u, ele)==ele_ngi(buoyancy, ele)) + assert(ele_ngi(u, ele)==ele_ngi(density, ele)) + assert(ele_ngi(density,ele)==ele_ngi(depth,ele)) - call transform_to_physical(positions, ele, ele_shape(buoyancy,ele), dshape=dt_rho) - grad_rho=ele_grad_at_quad(buoyancy, ele, dt_rho) + ! Form the vertical velocity relaxation absorption term + if (on_sphere) then + assert(ele_ngi(u, ele)==ele_ngi(positions, ele)) + else + assert(ele_ngi(u, ele)==ele_ngi(gravity, ele)) + grav_at_quads=ele_val_at_quad(gravity, ele) + end if + depth_at_quads=ele_val_at_quad(depth, ele) - ! Calculate the gradient in the direction of gravity - if (on_sphere) then - grav_at_quads=radial_inward_normal_at_quad_ele(positions, ele) - else - grav_at_quads=ele_val_at_quad(gravity, ele) - end if + if (on_sphere) then + do i=1,ele_ngi(u,ele) + vvr_abs_diag(3,i)=-vvr_sf*gravity_magnitude*dt/depth_at_quads(i) + end do + vvr_abs=rotate_diagonal_to_sphere_gi(positions, ele, vvr_abs_diag) + else + do i=1,ele_ngi(u,ele) + vvr_abs_diag(:,i)=vvr_sf*gravity_magnitude*dt*grav_at_quads(:,i)/depth_at_quads(i) + end do + end if + end if - do i=1,ele_ngi(U,ele) - drho_dz(i)=dot_product(grad_rho(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? - if (drho_dz(i) < ib_min_grad) drho_dz(i)=ib_min_grad ! Default ib_min_grad=0.0 - end do + if (have_implicit_buoyancy) then + + assert(ele_ngi(u, ele)==ele_ngi(buoyancy, ele)) + + call transform_to_physical(positions, ele, ele_shape(buoyancy,ele), dshape=dt_rho) + grad_rho=ele_grad_at_quad(buoyancy, ele, dt_rho) + + ! Calculate the gradient in the direction of gravity + if (on_sphere) then + grav_at_quads=radial_inward_normal_at_quad_ele(positions, ele) + else + grav_at_quads=ele_val_at_quad(gravity, ele) + end if - ! Form the implicit buoyancy absorption terms - if (on_sphere) then - do i=1,ele_ngi(U,ele) - ib_abs_diag(3,i)=-theta*dt*gravity_magnitude*drho_dz(i) - end do - ib_abs=rotate_diagonal_to_sphere_gi(positions, ele, ib_abs_diag) - else do i=1,ele_ngi(U,ele) - ib_abs_diag(:,i)=theta*dt*gravity_magnitude*drho_dz(i)*grav_at_quads(:,i) + drho_dz(i)=dot_product(grad_rho(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? + if (drho_dz(i) < ib_min_grad) drho_dz(i)=ib_min_grad ! Default ib_min_grad=0.0 end do - end if - end if - ! Add any vertical stabilization to the absorption term - if (on_sphere) then - tensor_absorption_gi=tensor_absorption_gi-vvr_abs-ib_abs - absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag - else - absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag - end if + ! Form the implicit buoyancy absorption terms + if (on_sphere) then + do i=1,ele_ngi(U,ele) + ib_abs_diag(3,i)=-theta*dt*gravity_magnitude*drho_dz(i) + end do + ib_abs=rotate_diagonal_to_sphere_gi(positions, ele, ib_abs_diag) + else + do i=1,ele_ngi(U,ele) + ib_abs_diag(:,i)=theta*dt*gravity_magnitude*drho_dz(i)*grav_at_quads(:,i) + end do + end if + end if + + ! Add any vertical stabilization to the absorption term + if (on_sphere) then + tensor_absorption_gi=tensor_absorption_gi-vvr_abs-ib_abs + absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag + else + absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag + end if end if if (have_swe_bottom_drag) then - ! first compute total water depth H - depth_at_quads = ele_val_at_quad(depth, ele) + (itheta*ele_val_at_quad(p, ele) + (1.0-itheta)*ele_val_at_quad(old_pressure, ele))/gravity_magnitude - ! now reuse depth_at_quads to be the absorption coefficient: C_D*|u|/H - depth_at_quads = (ele_val_at_quad(swe_bottom_drag, ele)*sqrt(sum(ele_val_at_quad(nu, ele)**2, dim=1)))/depth_at_quads - do i=1, u%dim - absorption_gi(i,:) = absorption_gi(i,:) + depth_at_quads - end do + ! first compute total water depth H + depth_at_quads = ele_val_at_quad(depth, ele) + (itheta*ele_val_at_quad(p, ele) + (1.0-itheta)*ele_val_at_quad(old_pressure, ele))/gravity_magnitude + ! now reuse depth_at_quads to be the absorption coefficient: C_D*|u|/H + depth_at_quads = (ele_val_at_quad(swe_bottom_drag, ele)*sqrt(sum(ele_val_at_quad(nu, ele)**2, dim=1)))/depth_at_quads + do i=1, u%dim + absorption_gi(i,:) = absorption_gi(i,:) + depth_at_quads + end do end if @@ -1977,108 +1977,108 @@ subroutine add_absorption_element_cg(positions, ele, test_function, u, oldu_val, ! the absorption cannot be used in the pressure correction. if (on_sphere) then - absorption_mat_sphere = shape_shape_tensor(test_function, ele_shape(u, ele), detwei*density_gi, tensor_absorption_gi) + absorption_mat_sphere = shape_shape_tensor(test_function, ele_shape(u, ele), detwei*density_gi, tensor_absorption_gi) - if(lump_absorption) then + if(lump_absorption) then - if(.not.abs_lump_on_submesh) then - absorption_lump_sphere = sum(absorption_mat_sphere, 4) + if(.not.abs_lump_on_submesh) then + absorption_lump_sphere = sum(absorption_mat_sphere, 4) - do dim = 1, u%dim - do dim2 = 1, u%dim - do i = 1, ele_loc(u, ele) - big_m_tensor_addto(dim, dim2, i, i) = big_m_tensor_addto(dim, dim2, i, i) + & - & dt*theta*absorption_lump_sphere(dim,dim2,i) + do dim = 1, u%dim + do dim2 = 1, u%dim + do i = 1, ele_loc(u, ele) + big_m_tensor_addto(dim, dim2, i, i) = big_m_tensor_addto(dim, dim2, i, i) + & + & dt*theta*absorption_lump_sphere(dim,dim2,i) + end do end do - end do - rhs_addto(dim, :) = rhs_addto(dim, :) - absorption_lump_sphere(dim,dim,:)*oldu_val(dim,:) - ! off block diagonal absorption terms - do dim2 = 1, u%dim - if (dim==dim2) cycle ! The dim=dim2 terms were done above - rhs_addto(dim, :) = rhs_addto(dim, :) - absorption_lump_sphere(dim,dim2,:)*oldu_val(dim2,:) - end do - end do + rhs_addto(dim, :) = rhs_addto(dim, :) - absorption_lump_sphere(dim,dim,:)*oldu_val(dim,:) + ! off block diagonal absorption terms + do dim2 = 1, u%dim + if (dim==dim2) cycle ! The dim=dim2 terms were done above + rhs_addto(dim, :) = rhs_addto(dim, :) - absorption_lump_sphere(dim,dim2,:)*oldu_val(dim2,:) + end do + end do - end if + end if - else - do dim = 1, u%dim - do dim2 = 1, u%dim - big_m_tensor_addto(dim, dim2, :, :) = big_m_tensor_addto(dim, dim2, :, :) + & - & dt*theta*absorption_mat_sphere(dim,dim2,:,:) - end do - rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(absorption_mat_sphere(dim,dim,:,:), oldu_val(dim,:)) - ! off block diagonal absorption terms - do dim2 = 1, u%dim - if (dim==dim2) cycle ! The dim=dim2 terms were done above - rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(absorption_mat_sphere(dim,dim2,:,:), oldu_val(dim2,:)) - end do - end do - absorption_lump_sphere = 0.0 - end if - - if (pressure_corrected_absorption) then - ! ct_m and u will later be rotated in this case, thus use a 'vector' absorption at - ! this stage. - absorption_mat = shape_shape_vector(test_function, ele_shape(u, ele), detwei*density_gi, absorption_gi) - absorption_lump = sum(absorption_mat, 3) - if (assemble_inverse_masslump.and.(.not.(abs_lump_on_submesh))) then - call addto(masslump, ele_nodes(u, ele), dt*theta*absorption_lump) - end if - if (assemble_mass_matrix) then + else do dim = 1, u%dim - call addto(mass, dim, dim, ele_nodes(u, ele), ele_nodes(u,ele), & - dt*theta*absorption_mat(dim,:,:)) + do dim2 = 1, u%dim + big_m_tensor_addto(dim, dim2, :, :) = big_m_tensor_addto(dim, dim2, :, :) + & + & dt*theta*absorption_mat_sphere(dim,dim2,:,:) + end do + rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(absorption_mat_sphere(dim,dim,:,:), oldu_val(dim,:)) + ! off block diagonal absorption terms + do dim2 = 1, u%dim + if (dim==dim2) cycle ! The dim=dim2 terms were done above + rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(absorption_mat_sphere(dim,dim2,:,:), oldu_val(dim2,:)) + end do end do - end if - end if + absorption_lump_sphere = 0.0 + end if + + if (pressure_corrected_absorption) then + ! ct_m and u will later be rotated in this case, thus use a 'vector' absorption at + ! this stage. + absorption_mat = shape_shape_vector(test_function, ele_shape(u, ele), detwei*density_gi, absorption_gi) + absorption_lump = sum(absorption_mat, 3) + if (assemble_inverse_masslump.and.(.not.(abs_lump_on_submesh))) then + call addto(masslump, ele_nodes(u, ele), dt*theta*absorption_lump) + end if + if (assemble_mass_matrix) then + do dim = 1, u%dim + call addto(mass, dim, dim, ele_nodes(u, ele), ele_nodes(u,ele), & + dt*theta*absorption_mat(dim,:,:)) + end do + end if + end if else - absorption_mat = shape_shape_vector(test_function, ele_shape(u, ele), detwei*density_gi, absorption_gi) + absorption_mat = shape_shape_vector(test_function, ele_shape(u, ele), detwei*density_gi, absorption_gi) - if (have_wd_abs) then - alpha_u_quad=ele_val_at_quad(alpha_u_field, ele) !! Wetting and drying absorption becomes active when water level reaches d_0 - absorption_mat = absorption_mat + & + if (have_wd_abs) then + alpha_u_quad=ele_val_at_quad(alpha_u_field, ele) !! Wetting and drying absorption becomes active when water level reaches d_0 + absorption_mat = absorption_mat + & & shape_shape_vector(test_function, ele_shape(u, ele), alpha_u_quad*detwei*density_gi, & & ele_val_at_quad(abs_wd,ele)) - end if + end if - if(lump_absorption) then - if(.not.abs_lump_on_submesh) then - absorption_lump = sum(absorption_mat, 3) - do dim = 1, u%dim - big_m_diag_addto(dim, :) = big_m_diag_addto(dim, :) + dt*theta*absorption_lump(dim,:) - rhs_addto(dim, :) = rhs_addto(dim, :) - absorption_lump(dim,:)*oldu_val(dim,:) - end do - end if - else - do dim = 1, u%dim - big_m_tensor_addto(dim, dim, :, :) = big_m_tensor_addto(dim, dim, :, :) + & - & dt*theta*absorption_mat(dim,:,:) - rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(absorption_mat(dim,:,:), oldu_val(dim,:)) - end do - absorption_lump = 0.0 - end if - if (pressure_corrected_absorption) then - if (assemble_inverse_masslump.and.(.not.(abs_lump_on_submesh))) then - call addto(masslump, ele_nodes(u, ele), dt*theta*absorption_lump) - end if - if (assemble_mass_matrix) then + if(lump_absorption) then + if(.not.abs_lump_on_submesh) then + absorption_lump = sum(absorption_mat, 3) + do dim = 1, u%dim + big_m_diag_addto(dim, :) = big_m_diag_addto(dim, :) + dt*theta*absorption_lump(dim,:) + rhs_addto(dim, :) = rhs_addto(dim, :) - absorption_lump(dim,:)*oldu_val(dim,:) + end do + end if + else do dim = 1, u%dim - call addto(mass, dim, dim, ele_nodes(u, ele), ele_nodes(u,ele), & - dt*theta*absorption_mat(dim,:,:)) + big_m_tensor_addto(dim, dim, :, :) = big_m_tensor_addto(dim, dim, :, :) + & + & dt*theta*absorption_mat(dim,:,:) + rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(absorption_mat(dim,:,:), oldu_val(dim,:)) end do - end if - end if + absorption_lump = 0.0 + end if + if (pressure_corrected_absorption) then + if (assemble_inverse_masslump.and.(.not.(abs_lump_on_submesh))) then + call addto(masslump, ele_nodes(u, ele), dt*theta*absorption_lump) + end if + if (assemble_mass_matrix) then + do dim = 1, u%dim + call addto(mass, dim, dim, ele_nodes(u, ele), ele_nodes(u,ele), & + dt*theta*absorption_mat(dim,:,:)) + end do + end if + end if end if - end subroutine add_absorption_element_cg + end subroutine add_absorption_element_cg - subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, x, viscosity, grad_u, & - fnu, tnu, leonard, strainprod, alpha, gamma, & - du_t, detwei, big_m_tensor_addto, rhs_addto, temperature, density, nvfrac) + subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, x, viscosity, grad_u, & + fnu, tnu, leonard, strainprod, alpha, gamma, & + du_t, detwei, big_m_tensor_addto, rhs_addto, temperature, density, nvfrac) type(state_type), intent(inout) :: state integer, intent(in) :: ele type(element_type), intent(in) :: test_function @@ -2139,7 +2139,7 @@ subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, do dim=1, u%dim do dimj = 1, u%dim viscosity_gi(dim,dimj,:) = reference_viscosity * & - exp(-activation_energy*(ele_val_at_quad(temperature,ele))) + exp(-activation_energy*(ele_val_at_quad(temperature,ele))) end do end do end if @@ -2158,10 +2158,10 @@ subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, wale_coef_gi=wale_viscosity_strength(du_t, nu_ele) do gi=1, size(les_coef_gi) les_tensor_gi(:,:,gi)=4.*les_tensor_gi(:,:,gi)* & - wale_coef_gi(gi)**3 * smagorinsky_coefficient**2 / & - max(les_coef_gi(gi)**5 + wale_coef_gi(gi)**2.5, 1.e-10) + wale_coef_gi(gi)**3 * smagorinsky_coefficient**2 / & + max(les_coef_gi(gi)**5 + wale_coef_gi(gi)**2.5, 1.e-10) end do - ! Second order Smagorinsky model + ! Second order Smagorinsky model else if(les_second_order) then les_coef_gi = les_viscosity_strength(du_t, nu_ele) ! In Boussinesq simulations this density will be set to unity. @@ -2169,41 +2169,41 @@ subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, density_gi = ele_val_at_quad(density, ele) select case(length_scale_type) - case("scalar") - ! Length scale is the cube root of the element's volume in 3D. - ! In 2D, it is the square root of the element's area. - les_scalar_gi = length_scale_scalar(x, ele) - do gi = 1, size(les_coef_gi) - ! The factor of 4 arises here because the filter width separating resolved - ! and unresolved scales is assumed to be twice the local element size, - ! which is squared in the viscosity model. - les_tensor_gi(:,:,gi) = 4.0*les_scalar_gi(gi)*& - density_gi(gi)*les_coef_gi(gi)*(smagorinsky_coefficient**2) - end do - case("tensor") - ! This uses a tensor length scale metric from the adaptivity process - ! to better handle anisotropic elements. - les_tensor_gi = length_scale_tensor(du_t, ele_shape(u, ele)) - do gi = 1, size(les_coef_gi) - ! The factor of 4 arises here because the filter width separating resolved - ! and unresolved scales is assumed to be twice the local element size, - ! which is squared in the viscosity model. - les_tensor_gi(:,:,gi) = 4.0*les_tensor_gi(:,:,gi)*& - density_gi(gi)*les_coef_gi(gi)*(smagorinsky_coefficient**2) - end do - case default - FLExit("Unknown length scale type") + case("scalar") + ! Length scale is the cube root of the element's volume in 3D. + ! In 2D, it is the square root of the element's area. + les_scalar_gi = length_scale_scalar(x, ele) + do gi = 1, size(les_coef_gi) + ! The factor of 4 arises here because the filter width separating resolved + ! and unresolved scales is assumed to be twice the local element size, + ! which is squared in the viscosity model. + les_tensor_gi(:,:,gi) = 4.0*les_scalar_gi(gi)*& + density_gi(gi)*les_coef_gi(gi)*(smagorinsky_coefficient**2) + end do + case("tensor") + ! This uses a tensor length scale metric from the adaptivity process + ! to better handle anisotropic elements. + les_tensor_gi = length_scale_tensor(du_t, ele_shape(u, ele)) + do gi = 1, size(les_coef_gi) + ! The factor of 4 arises here because the filter width separating resolved + ! and unresolved scales is assumed to be twice the local element size, + ! which is squared in the viscosity model. + les_tensor_gi(:,:,gi) = 4.0*les_tensor_gi(:,:,gi)*& + density_gi(gi)*les_coef_gi(gi)*(smagorinsky_coefficient**2) + end do + case default + FLExit("Unknown length scale type") end select ! Eddy viscosity tensor field. Calling this subroutine works because ! you can't have 2 different types of LES model for the same material_phase. if(have_eddy_visc) then - call les_assemble_diagnostic_fields(state, u, ele, detwei, & - les_tensor_gi, les_tensor_gi, les_coef_gi, & - have_eddy_visc, .false., .false.) + call les_assemble_diagnostic_fields(state, u, ele, detwei, & + les_tensor_gi, les_tensor_gi, les_coef_gi, & + have_eddy_visc, .false., .false.) end if - ! Fourth order Smagorinsky model + ! Fourth order Smagorinsky model else if (les_fourth_order) then les_tensor_gi=length_scale_tensor(du_t, ele_shape(u, ele)) les_coef_gi=les_viscosity_strength(du_t, nu_ele) @@ -2212,10 +2212,10 @@ subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, do dim=1, u%dim do iloc=1, ele_loc(u, ele) rhs_addto(dim,iloc)=rhs_addto(dim,iloc)+ & - sum(div_les_viscosity(:,:,iloc)*grad_u_nodes(:,dim,:)) + sum(div_les_viscosity(:,:,iloc)*grad_u_nodes(:,dim,:)) end do end do - ! Germano dynamic model + ! Germano dynamic model else if (dynamic_les) then shape_nu = ele_shape(nu, ele) nodes_nu => ele_nodes(nu, ele) @@ -2239,42 +2239,42 @@ subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, end do select case(length_scale_type) - case("scalar") - ! Scalar first filter width G1 = alpha^2*meshsize (units length^2) - f_scalar = alpha**2*length_scale_scalar(x, ele) - ! Combined width G2 = (1+gamma^2)*G1 - t_scalar = (1.0+gamma**2)*f_scalar - do gi=1, ele_ngi(nu, ele) - ! Tensor M_ij = (|S2|*S2)G2 - ((|S1|S1)^f2)G1 - mij = t_strain_mod(gi)*t_strain_gi(:,:,gi)*t_scalar(gi) - strainprod_gi(:,:,gi)*f_scalar(gi) - ! Model coeff C_S = -(L_ij M_ij) / 2(M_ij M_ij) - les_coef_gi(gi) = -0.5*sum(leonard_gi(:,:,gi)*mij) / sum(mij*mij) - ! Constrain C_S to be between 0 and 0.04. - les_coef_gi(gi) = min(max(les_coef_gi(gi),0.0), 0.04) - ! Isotropic tensor dynamic eddy viscosity = -2C_S|S1|.alpha^2.G1 - les_tensor_gi(:,:,gi) = 2*alpha**2*les_coef_gi(gi)*strain_mod(gi)*f_scalar(gi) - end do - case("tensor") - ! First filter width G1 = alpha^2*mesh size (units length^2) - f_tensor = alpha**2*mesh_size_gi - ! Combined width G2 = (1+gamma^2)*G1 - t_tensor = (1.0+gamma**2)*f_tensor - do gi=1, ele_ngi(nu, ele) - ! Tensor M_ij = (|S2|*S2).G2 - ((|S1|S1)^f2).G1 - mij = t_strain_mod(gi)*t_strain_gi(:,:,gi)*t_tensor(:,:,gi) - strainprod_gi(:,:,gi)*f_tensor(:,:,gi) - ! Model coeff C_S = -(L_ij M_ij) / 2(M_ij M_ij) - les_coef_gi(gi) = -0.5*sum(leonard_gi(:,:,gi)*mij) / sum(mij*mij) - ! Constrain C_S to be between 0 and 0.04. - les_coef_gi(gi) = min(max(les_coef_gi(gi),0.0), 0.04) - ! Anisotropic tensor dynamic eddy viscosity m_ij = -2C_S|S1|.alpha^2.G1 - les_tensor_gi(:,:,gi) = 2*alpha**2*les_coef_gi(gi)*strain_mod(gi)*f_tensor(:,:,gi) - end do + case("scalar") + ! Scalar first filter width G1 = alpha^2*meshsize (units length^2) + f_scalar = alpha**2*length_scale_scalar(x, ele) + ! Combined width G2 = (1+gamma^2)*G1 + t_scalar = (1.0+gamma**2)*f_scalar + do gi=1, ele_ngi(nu, ele) + ! Tensor M_ij = (|S2|*S2)G2 - ((|S1|S1)^f2)G1 + mij = t_strain_mod(gi)*t_strain_gi(:,:,gi)*t_scalar(gi) - strainprod_gi(:,:,gi)*f_scalar(gi) + ! Model coeff C_S = -(L_ij M_ij) / 2(M_ij M_ij) + les_coef_gi(gi) = -0.5*sum(leonard_gi(:,:,gi)*mij) / sum(mij*mij) + ! Constrain C_S to be between 0 and 0.04. + les_coef_gi(gi) = min(max(les_coef_gi(gi),0.0), 0.04) + ! Isotropic tensor dynamic eddy viscosity = -2C_S|S1|.alpha^2.G1 + les_tensor_gi(:,:,gi) = 2*alpha**2*les_coef_gi(gi)*strain_mod(gi)*f_scalar(gi) + end do + case("tensor") + ! First filter width G1 = alpha^2*mesh size (units length^2) + f_tensor = alpha**2*mesh_size_gi + ! Combined width G2 = (1+gamma^2)*G1 + t_tensor = (1.0+gamma**2)*f_tensor + do gi=1, ele_ngi(nu, ele) + ! Tensor M_ij = (|S2|*S2).G2 - ((|S1|S1)^f2).G1 + mij = t_strain_mod(gi)*t_strain_gi(:,:,gi)*t_tensor(:,:,gi) - strainprod_gi(:,:,gi)*f_tensor(:,:,gi) + ! Model coeff C_S = -(L_ij M_ij) / 2(M_ij M_ij) + les_coef_gi(gi) = -0.5*sum(leonard_gi(:,:,gi)*mij) / sum(mij*mij) + ! Constrain C_S to be between 0 and 0.04. + les_coef_gi(gi) = min(max(les_coef_gi(gi),0.0), 0.04) + ! Anisotropic tensor dynamic eddy viscosity m_ij = -2C_S|S1|.alpha^2.G1 + les_tensor_gi(:,:,gi) = 2*alpha**2*les_coef_gi(gi)*strain_mod(gi)*f_tensor(:,:,gi) + end do end select ! Assemble diagnostic fields call les_assemble_diagnostic_fields(state, nu, ele, detwei, & - mesh_size_gi, les_tensor_gi, les_coef_gi, & - have_eddy_visc, have_filter_width, have_coeff) + mesh_size_gi, les_tensor_gi, les_coef_gi, & + have_eddy_visc, have_filter_width, have_coeff) else FLAbort("Unknown LES model") @@ -2291,74 +2291,74 @@ subroutine add_viscosity_element_cg(state, ele, test_function, u, oldu_val, nu, viscosity_mat = 0.0 if(stress_form.or.partial_stress_form) then - ! add in the stress form entries of the element viscosity matrix - ! / - ! | B_A^T C B_B dV - ! / - if(multiphase) then - viscosity_mat = stiffness_matrix(du_t, viscosity_gi, du_t, detwei*ele_val_at_quad(nvfrac, ele)) - else - viscosity_mat = stiffness_matrix(du_t, viscosity_gi, du_t, detwei) - end if + ! add in the stress form entries of the element viscosity matrix + ! / + ! | B_A^T C B_B dV + ! / + if(multiphase) then + viscosity_mat = stiffness_matrix(du_t, viscosity_gi, du_t, detwei*ele_val_at_quad(nvfrac, ele)) + else + viscosity_mat = stiffness_matrix(du_t, viscosity_gi, du_t, detwei) + end if else - if(isotropic_viscosity .and. .not. have_les) then - assert(u%dim > 0) - - if(multiphase) then - ! We need to compute \int{grad(N_A) vfrac viscosity grad(N_B)} - viscosity_mat(1, 1, :, :) = dshape_dot_dshape(du_t, du_t, detwei*viscosity_gi(1, 1, :)*& - ele_val_at_quad(nvfrac, ele)) - else - viscosity_mat(1, 1, :, :) = dshape_dot_dshape(du_t, du_t, detwei * viscosity_gi(1, 1, :)) - end if - - do dim = 2, u%dim - viscosity_mat(dim, dim, :, :) = viscosity_mat(1, 1, :, :) - end do - else if(diagonal_viscosity .and. .not. have_les) then - assert(u%dim > 0) - - if(multiphase) then - viscosity_mat(1, 1, :, :) = dshape_diagtensor_dshape(du_t, viscosity_gi, du_t, detwei*& - ele_val_at_quad(nvfrac, ele)) - else - viscosity_mat(1, 1, :, :) = dshape_diagtensor_dshape(du_t, viscosity_gi, du_t, detwei) - end if - - do dim = 2, u%dim - viscosity_mat(dim, dim, :, :) = viscosity_mat(1, 1, :, :) - end do - else - do dim = 1, u%dim + if(isotropic_viscosity .and. .not. have_les) then + assert(u%dim > 0) + if(multiphase) then - viscosity_mat(dim, dim, :, :) = dshape_tensor_dshape(du_t, viscosity_gi, du_t, detwei*& - ele_val_at_quad(nvfrac, ele)) + ! We need to compute \int{grad(N_A) vfrac viscosity grad(N_B)} + viscosity_mat(1, 1, :, :) = dshape_dot_dshape(du_t, du_t, detwei*viscosity_gi(1, 1, :)*& + ele_val_at_quad(nvfrac, ele)) else - viscosity_mat(dim, dim, :, :) = dshape_tensor_dshape(du_t, viscosity_gi, du_t, detwei) + viscosity_mat(1, 1, :, :) = dshape_dot_dshape(du_t, du_t, detwei * viscosity_gi(1, 1, :)) end if - end do - end if + + do dim = 2, u%dim + viscosity_mat(dim, dim, :, :) = viscosity_mat(1, 1, :, :) + end do + else if(diagonal_viscosity .and. .not. have_les) then + assert(u%dim > 0) + + if(multiphase) then + viscosity_mat(1, 1, :, :) = dshape_diagtensor_dshape(du_t, viscosity_gi, du_t, detwei*& + ele_val_at_quad(nvfrac, ele)) + else + viscosity_mat(1, 1, :, :) = dshape_diagtensor_dshape(du_t, viscosity_gi, du_t, detwei) + end if + + do dim = 2, u%dim + viscosity_mat(dim, dim, :, :) = viscosity_mat(1, 1, :, :) + end do + else + do dim = 1, u%dim + if(multiphase) then + viscosity_mat(dim, dim, :, :) = dshape_tensor_dshape(du_t, viscosity_gi, du_t, detwei*& + ele_val_at_quad(nvfrac, ele)) + else + viscosity_mat(dim, dim, :, :) = dshape_tensor_dshape(du_t, viscosity_gi, du_t, detwei) + end if + end do + end if end if big_m_tensor_addto = big_m_tensor_addto + dt*theta*viscosity_mat do dim = 1, u%dim - rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(viscosity_mat(dim,dim,:,:), oldu_val(dim,:)) + rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(viscosity_mat(dim,dim,:,:), oldu_val(dim,:)) - ! off block diagonal viscosity terms - if(stress_form.or.partial_stress_form) then - do dimj = 1, u%dim + ! off block diagonal viscosity terms + if(stress_form.or.partial_stress_form) then + do dimj = 1, u%dim - if (dim==dimj) cycle ! already done this + if (dim==dimj) cycle ! already done this - rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(viscosity_mat(dim,dimj,:,:), oldu_val(dimj,:)) - end do - end if + rhs_addto(dim, :) = rhs_addto(dim, :) - matmul(viscosity_mat(dim,dimj,:,:), oldu_val(dimj,:)) + end do + end if end do - end subroutine add_viscosity_element_cg + end subroutine add_viscosity_element_cg - subroutine add_coriolis_element_cg(ele, test_function, x, u, oldu_val, density, detwei, big_m_tensor_addto, rhs_addto) + subroutine add_coriolis_element_cg(ele, test_function, x, u, oldu_val, density, detwei, big_m_tensor_addto, rhs_addto) integer, intent(in) :: ele type(element_type), intent(in) :: test_function type(vector_field), intent(in) :: x @@ -2390,9 +2390,9 @@ subroutine add_coriolis_element_cg(ele, test_function, x, u, oldu_val, density, rhs_addto(U_, :) = rhs_addto(U_, :) + matmul(coriolis_mat, oldu_val(V_,:)) rhs_addto(V_, :) = rhs_addto(V_, :) - matmul(coriolis_mat, oldu_val(U_,:)) - end subroutine add_coriolis_element_cg + end subroutine add_coriolis_element_cg - subroutine add_geostrophic_pressure_element_cg(ele, test_function, x, u, gp, detwei, rhs_addto) + subroutine add_geostrophic_pressure_element_cg(ele, test_function, x, u, gp, detwei, rhs_addto) integer, intent(in) :: ele type(element_type), intent(in) :: test_function type(vector_field), intent(in) :: x @@ -2405,13 +2405,13 @@ subroutine add_geostrophic_pressure_element_cg(ele, test_function, x, u, gp, de ! We assume here that gp is usually on a different mesh to u or p call transform_to_physical(x, ele, ele_shape(gp, ele), & - & dshape = dgp_t) + & dshape = dgp_t) rhs_addto = rhs_addto - shape_vector_rhs(test_function, ele_grad_at_quad(gp, ele, dgp_t), detwei) - end subroutine add_geostrophic_pressure_element_cg + end subroutine add_geostrophic_pressure_element_cg - function stiffness_matrix(dshape1, tensor, dshape2, detwei) result (matrix) + function stiffness_matrix(dshape1, tensor, dshape2, detwei) result (matrix) !!< Calculates the stiffness matrix. !!< !!< / @@ -2465,83 +2465,83 @@ function stiffness_matrix(dshape1, tensor, dshape2, detwei) result (matrix) ! matrix = I| gradN_a^T row(symm(mu)) gradN_b dV ! / do i=1,dim - ! extract the relevent tensor entries into a vector - do j = 1, i-1 - tensor_entries(j,:) = tensor(j,i,:) - end do - do j = i, dim - tensor_entries(j,:) = tensor(i,j,:) - end do - matrix(i,i,:,:) = dshape_vector_dshape(dshape1, tensor_entries, dshape2, detwei) + ! extract the relevent tensor entries into a vector + do j = 1, i-1 + tensor_entries(j,:) = tensor(j,i,:) + end do + do j = i, dim + tensor_entries(j,:) = tensor(i,j,:) + end do + matrix(i,i,:,:) = dshape_vector_dshape(dshape1, tensor_entries, dshape2, detwei) end do if(partial_stress_form) then - ! matrix = matrix + b_a^T c b_b - I gradN_a^T row(symm(mu)) gradN_b - ! = matrix + / N_a,x*N_b,x*mu_xx - ! | N_a,x*N_b,y*mu_xy ... - ! \ N_a,x*N_b,z*mu_xz - ! - ! N_a,y*N_b,x*mu_xy - ! ... N_a,y*N_b,y*mu_yy ... - ! N_a,y*N_b,z*mu_yz - ! - ! N_a,z*N_b,x*mu_xz \ - ! ... N_a,z*N_b,y*mu_yz | - ! N_a,z*N_b,z*mu_zz / - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - matrix(:,:,iloc,jloc) = matrix(:,:,iloc,jloc) & - +(spread(dshape1(iloc,gi,:), 1, dim) & - *spread(dshape2(jloc,gi,:), 2, dim) & - *tensor(:,:,gi)) & - *detwei(gi) - end forall - end do + ! matrix = matrix + b_a^T c b_b - I gradN_a^T row(symm(mu)) gradN_b + ! = matrix + / N_a,x*N_b,x*mu_xx + ! | N_a,x*N_b,y*mu_xy ... + ! \ N_a,x*N_b,z*mu_xz + ! + ! N_a,y*N_b,x*mu_xy + ! ... N_a,y*N_b,y*mu_yy ... + ! N_a,y*N_b,z*mu_yz + ! + ! N_a,z*N_b,x*mu_xz \ + ! ... N_a,z*N_b,y*mu_yz | + ! N_a,z*N_b,z*mu_zz / + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + matrix(:,:,iloc,jloc) = matrix(:,:,iloc,jloc) & + +(spread(dshape1(iloc,gi,:), 1, dim) & + *spread(dshape2(jloc,gi,:), 2, dim) & + *tensor(:,:,gi)) & + *detwei(gi) + end forall + end do else - ! matrix = matrix + b_a^T c b_b - I gradN_a^T row(symm(mu)) gradN_b - ! = matrix + / N_a,x*N_b,x*mu_xx - 2/3*N_a,x*N_b,x*mu_xx - ! | N_a,x*N_b,y*mu_xy - 2/3*N_a,y*N_b,x*mu_yx ... - ! \ N_a,x*N_b,z*mu_xz - 2/3*N_a,z*N_b,x*mu_zx - ! - ! N_a,y*N_b,x*mu_xy - 2/3*N_a,x*N_b,y*mu_xy - ! ... N_a,y*N_b,y*mu_yy - 2/3*N_a,y*N_b,y*mu_yy ... - ! N_a,y*N_b,z*mu_yz - 2/3*N_a,z*N_b,y*mu_zy - ! - ! N_a,z*N_b,x*mu_xz - 2/3*N_a,x*N_b,z*mu_xz \ - ! ... N_a,z*N_b,y*mu_yz - 2/3*N_a,y*N_b,z*mu_yz | - ! N_a,z*N_b,z*mu_zz - 2/3*N_a,z*N_b,z*mu_zz / - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - matrix(:,:,iloc,jloc) = matrix(:,:,iloc,jloc) & - +(spread(dshape1(iloc,gi,:), 1, dim) & - *spread(dshape2(jloc,gi,:), 2, dim) & - *tensor(:,:,gi) & - -spread(dshape1(iloc,gi,:), 2, dim) & - *spread(dshape2(jloc,gi,:), 1, dim) & - *(2./3.)*tensor(:,:,gi)) & - *detwei(gi) - end forall - end do - end if - - end function stiffness_matrix - - subroutine deallocate_cg_mass(mass, inverse_masslump) + ! matrix = matrix + b_a^T c b_b - I gradN_a^T row(symm(mu)) gradN_b + ! = matrix + / N_a,x*N_b,x*mu_xx - 2/3*N_a,x*N_b,x*mu_xx + ! | N_a,x*N_b,y*mu_xy - 2/3*N_a,y*N_b,x*mu_yx ... + ! \ N_a,x*N_b,z*mu_xz - 2/3*N_a,z*N_b,x*mu_zx + ! + ! N_a,y*N_b,x*mu_xy - 2/3*N_a,x*N_b,y*mu_xy + ! ... N_a,y*N_b,y*mu_yy - 2/3*N_a,y*N_b,y*mu_yy ... + ! N_a,y*N_b,z*mu_yz - 2/3*N_a,z*N_b,y*mu_zy + ! + ! N_a,z*N_b,x*mu_xz - 2/3*N_a,x*N_b,z*mu_xz \ + ! ... N_a,z*N_b,y*mu_yz - 2/3*N_a,y*N_b,z*mu_yz | + ! N_a,z*N_b,z*mu_zz - 2/3*N_a,z*N_b,z*mu_zz / + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + matrix(:,:,iloc,jloc) = matrix(:,:,iloc,jloc) & + +(spread(dshape1(iloc,gi,:), 1, dim) & + *spread(dshape2(jloc,gi,:), 2, dim) & + *tensor(:,:,gi) & + -spread(dshape1(iloc,gi,:), 2, dim) & + *spread(dshape2(jloc,gi,:), 1, dim) & + *(2./3.)*tensor(:,:,gi)) & + *detwei(gi) + end forall + end do + end if + + end function stiffness_matrix + + subroutine deallocate_cg_mass(mass, inverse_masslump) !!< Deallocates mass and/or inverse_masslump !!< if they are assembled in construct_momentum_cg() type(petsc_csr_matrix), intent(inout):: mass type(vector_field), intent(inout):: inverse_masslump if (assemble_mass_matrix) then - call deallocate(mass) + call deallocate(mass) end if if (assemble_inverse_masslump) then - call deallocate(inverse_masslump) + call deallocate(inverse_masslump) end if - end subroutine deallocate_cg_mass + end subroutine deallocate_cg_mass - subroutine correct_masslumped_velocity(u, inverse_masslump, ct_m, delta_p) + subroutine correct_masslumped_velocity(u, inverse_masslump, ct_m, delta_p) !!< Given the pressure correction delta_p, correct the velocity. !!< !!< U_new = U_old + M_l^{-1} * C * delta_P @@ -2560,11 +2560,11 @@ subroutine correct_masslumped_velocity(u, inverse_masslump, ct_m, delta_p) call allocate(delta_u, u%mesh, "Delta_U") do dim=1,u%dim - call mult_t(delta_u, block(ct_m,1,dim), delta_p) - inverse_masslump_component = extract_scalar_field(inverse_masslump, dim) + call mult_t(delta_u, block(ct_m,1,dim), delta_p) + inverse_masslump_component = extract_scalar_field(inverse_masslump, dim) - call scale(delta_u, inverse_masslump_component) - call addto(u, dim, delta_u) + call scale(delta_u, inverse_masslump_component) + call addto(u, dim, delta_u) end do call halo_update(u) @@ -2572,9 +2572,9 @@ subroutine correct_masslumped_velocity(u, inverse_masslump, ct_m, delta_p) call deallocate(delta_u) - end subroutine correct_masslumped_velocity + end subroutine correct_masslumped_velocity - subroutine correct_velocity_cg(u, mass, ct_m, delta_p, state) + subroutine correct_velocity_cg(u, mass, ct_m, delta_p, state) !!< Given the pressure correction delta_p, correct the velocity. !!< !!< U_new = U_old + M_l^{-1} * C * delta_P @@ -2592,12 +2592,12 @@ subroutine correct_velocity_cg(u, mass, ct_m, delta_p, state) call allocate(delta_u1, u%dim, u%mesh, "Delta_U1") call allocate(delta_u2, u%dim, u%mesh, "Delta_U2") delta_u2%option_path = trim(delta_p%option_path)//& - &"/prognostic/scheme/use_projection_method"//& - &"/full_schur_complement/inner_matrix[0]" + &"/prognostic/scheme/use_projection_method"//& + &"/full_schur_complement/inner_matrix[0]" if (.not. have_option(trim(delta_u2%option_path)//"/solver")) then - ! inner solver options are optional (for FullMomemtumMatrix), if not - ! present use the same as those for the initial velocity solve - delta_u2%option_path = u%option_path + ! inner solver options are optional (for FullMomemtumMatrix), if not + ! present use the same as those for the initial velocity solve + delta_u2%option_path = u%option_path end if ! compute delta_u1=grad delta_p @@ -2627,9 +2627,9 @@ subroutine correct_velocity_cg(u, mass, ct_m, delta_p, state) call deallocate(delta_U1) call deallocate(delta_U2) - end subroutine correct_velocity_cg + end subroutine correct_velocity_cg - subroutine assemble_poisson_rhs(poisson_rhs, & + subroutine assemble_poisson_rhs(poisson_rhs, & ctp_m, mom_rhs, ct_rhs, big_m, velocity, dt, theta_pg) type(scalar_field), intent(inout) :: poisson_rhs @@ -2665,9 +2665,9 @@ subroutine assemble_poisson_rhs(poisson_rhs, & call deallocate(l_mom_rhs) - end subroutine assemble_poisson_rhs + end subroutine assemble_poisson_rhs - subroutine assemble_masslumped_poisson_rhs(poisson_rhs, & + subroutine assemble_masslumped_poisson_rhs(poisson_rhs, & ctp_m, mom_rhs, ct_rhs, inverse_masslump, velocity, dt, theta_pg) type(scalar_field), intent(inout) :: poisson_rhs @@ -2702,11 +2702,11 @@ subroutine assemble_masslumped_poisson_rhs(poisson_rhs, & call deallocate(l_mom_rhs) - end subroutine assemble_masslumped_poisson_rhs + end subroutine assemble_masslumped_poisson_rhs - subroutine assemble_kmk_matrix(state, pressure_mesh, coordinates, & + subroutine assemble_kmk_matrix(state, pressure_mesh, coordinates, & theta_pg) - ! Assemble P1-P1 stabilisation term in the pressure matrix. + ! Assemble P1-P1 stabilisation term in the pressure matrix. type(state_type), intent(inout) :: state type(mesh_type), intent(inout) :: pressure_mesh type(vector_field), intent(in) :: coordinates @@ -2742,31 +2742,31 @@ subroutine assemble_kmk_matrix(state, pressure_mesh, coordinates, & ! (h_bar). Simplex_tensor gives the metric that would make that element ! the ideal element. do ele=1,ele_count(pressure_mesh) - call transform_to_physical(coordinates, ele, p_shape, dshape=dp_t, detwei=detwei) - call get_edge_lengths(pressure_mesh, coordinates, ele, h_bar) - little_stiff_matrix = dshape_tensor_dshape(dp_t, h_bar, dp_t, detwei) - call addto(kt, ele_nodes(pressure_mesh, ele), ele_nodes(pressure_mesh, ele), 0.5 * little_stiff_matrix) + call transform_to_physical(coordinates, ele, p_shape, dshape=dp_t, detwei=detwei) + call get_edge_lengths(pressure_mesh, coordinates, ele, h_bar) + little_stiff_matrix = dshape_tensor_dshape(dp_t, h_bar, dp_t, detwei) + call addto(kt, ele_nodes(pressure_mesh, ele), ele_nodes(pressure_mesh, ele), 0.5 * little_stiff_matrix) end do ! by scaling masslump with theta, we divide kmk by theta if(abs(theta_pg - 1.0) < epsilon(0.0)) then - call mult_div_invscalar_div_T(kmk, kt, p_masslump, kt) + call mult_div_invscalar_div_T(kmk, kt, p_masslump, kt) else - call allocate(scaled_p_masslump, p_masslump%mesh, trim(p_masslump%name) // "Scaled") - call set(scaled_p_masslump, p_masslump) - call scale(scaled_p_masslump, theta_pg) + call allocate(scaled_p_masslump, p_masslump%mesh, trim(p_masslump%name) // "Scaled") + call set(scaled_p_masslump, p_masslump) + call scale(scaled_p_masslump, theta_pg) - ! Compute kmk, the stabilisation term. - call mult_div_invscalar_div_T(kmk, kt, scaled_p_masslump, kt) + ! Compute kmk, the stabilisation term. + call mult_div_invscalar_div_T(kmk, kt, scaled_p_masslump, kt) - call deallocate(scaled_p_masslump) + call deallocate(scaled_p_masslump) end if call deallocate(kt) - end subroutine assemble_kmk_matrix + end subroutine assemble_kmk_matrix - subroutine add_kmk_matrix(state, cmc_m) - ! Add kmk (P1-P1 stabilisation term in the pressure matrix) to cmc_m. + subroutine add_kmk_matrix(state, cmc_m) + ! Add kmk (P1-P1 stabilisation term in the pressure matrix) to cmc_m. type(state_type), intent(inout) :: state type(csr_matrix), intent(inout) :: cmc_m type(csr_matrix), pointer :: kmk @@ -2774,9 +2774,9 @@ subroutine add_kmk_matrix(state, cmc_m) kmk => get_pressure_stabilisation_matrix(state) call addto(cmc_m, kmk) - end subroutine add_kmk_matrix + end subroutine add_kmk_matrix - subroutine add_kmk_rhs(state, rhs, pressure, dt) + subroutine add_kmk_rhs(state, rhs, pressure, dt) type(state_type), intent(inout) :: state type(scalar_field), intent(inout) :: rhs type(scalar_field), intent(in) :: pressure @@ -2787,6 +2787,6 @@ subroutine add_kmk_rhs(state, rhs, pressure, dt) kmk => get_pressure_stabilisation_matrix(state) call mult(rhs, kmk, pressure) call scale(rhs, dt) - end subroutine add_kmk_rhs + end subroutine add_kmk_rhs - end module momentum_cg +end module momentum_cg diff --git a/assemble/Momentum_DG.F90 b/assemble/Momentum_DG.F90 index 038fb11d2e..feba300ed7 100644 --- a/assemble/Momentum_DG.F90 +++ b/assemble/Momentum_DG.F90 @@ -27,728 +27,728 @@ #include "fdebug.h" module momentum_DG - ! This module contains the Discontinuous Galerkin form of the momentum - ! equation. - use spud - use fldebug - use vector_tools - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN, COLOURING_DG2, & - COLOURING_DG0 + ! This module contains the Discontinuous Galerkin form of the momentum + ! equation. + use spud + use fldebug + use vector_tools + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN, COLOURING_DG2, & + COLOURING_DG0 #ifdef _OPENMP - use omp_lib + use omp_lib #endif - use integer_set_module - use parallel_tools - use sparse_tools - use shape_functions - use transform_elements - use fetools - use parallel_fields - use fields - use profiler - use petsc_tools - use sparse_tools_petsc - use sparse_matrices_fields - use state_module - use vtk_interfaces - use halos - use field_options - use fefields - use boundary_conditions, only: has_boundary_condition, get_entire_boundary_condition - use field_derivatives - use coordinates - use solvers - use sparsity_patterns - use dgtools - use smoothing_module - use sparsity_patterns_meshes - use boundary_conditions_from_options - use coriolis_module, only : coriolis, set_coriolis_parameters - use turbine - use diagnostic_fields - use slope_limiters_dg - use colouring - use multiphase_module - - implicit none - - ! Buffer for output messages. - character(len=255), private :: message - - private - public construct_momentum_dg, & - momentum_DG_check_options, correct_velocity_dg, & - assemble_poisson_rhs_dg, allocate_big_m_dg, & - subcycle_momentum_dg - - ! Module private variables for model options. This prevents us having to - ! do dictionary lookups for every element (or element face!) - real :: dt, theta, theta_nl - logical :: lump_mass, lump_abs, lump_source, subcycle - - ! Whether the advection term is only integrated by parts once. - logical :: integrate_by_parts_once=.false. - ! Whether the conservation term is integrated by parts or not - logical :: integrate_conservation_term_by_parts=.false. - ! Whether or not to integrate the surface tension term by parts - logical :: integrate_surfacetension_by_parts - - ! Weight between conservative and non-conservative forms of the advection - ! equation. - ! 1 is for conservative 0 is for non-conservative. - real :: beta - - ! Discretisation to use for viscosity term. - integer :: viscosity_scheme - integer, parameter :: ARBITRARY_UPWIND=1 - integer, parameter :: BASSI_REBAY=2 - integer, parameter :: CDG=3 - integer, parameter :: IP=4 - - ! Method for getting h0 in IP - integer :: edge_length_option - integer, parameter :: USE_FACE_INTEGRALS=1 - integer, parameter :: USE_ELEMENT_CENTRES=2 - - ! Parameters for interior penalty method - real :: Interior_Penalty_Parameter, edge_length_power, h0 - - ! Flag indicating whether to include pressure bcs (not for cv pressure) - logical :: l_include_pressure_bcs - - ! which terms do we have? - logical :: have_mass - logical :: have_source - logical :: have_gravity - logical :: on_sphere, radial_gravity - logical :: have_absorption - logical :: have_vertical_stabilization - logical :: have_implicit_buoyancy - logical :: have_vertical_velocity_relaxation - logical :: have_swe_bottom_drag - ! implicit absorption is corrected by the pressure correction - ! by combining the implicit part of absorption with the mass term of u^{n+1} - logical :: pressure_corrected_absorption - logical :: have_viscosity - logical :: have_surfacetension - logical :: have_coriolis - logical :: have_advection - logical :: move_mesh - logical :: have_pressure_bc - logical :: subtract_out_reference_profile - logical :: have_les - - real :: gravity_magnitude - - ! CDG stuff - real, dimension(3) :: switch_g - logical :: CDG_penalty - logical :: remove_penalty_fluxes - - ! Are we running a multi-phase flow simulation? - logical :: multiphase + use integer_set_module + use parallel_tools + use sparse_tools + use shape_functions + use transform_elements + use fetools + use parallel_fields + use fields + use profiler + use petsc_tools + use sparse_tools_petsc + use sparse_matrices_fields + use state_module + use vtk_interfaces + use halos + use field_options + use fefields + use boundary_conditions, only: has_boundary_condition, get_entire_boundary_condition + use field_derivatives + use coordinates + use solvers + use sparsity_patterns + use dgtools + use smoothing_module + use sparsity_patterns_meshes + use boundary_conditions_from_options + use coriolis_module, only : coriolis, set_coriolis_parameters + use turbine + use diagnostic_fields + use slope_limiters_dg + use colouring + use multiphase_module + + implicit none + + ! Buffer for output messages. + character(len=255), private :: message + + private + public construct_momentum_dg, & + momentum_DG_check_options, correct_velocity_dg, & + assemble_poisson_rhs_dg, allocate_big_m_dg, & + subcycle_momentum_dg + + ! Module private variables for model options. This prevents us having to + ! do dictionary lookups for every element (or element face!) + real :: dt, theta, theta_nl + logical :: lump_mass, lump_abs, lump_source, subcycle + + ! Whether the advection term is only integrated by parts once. + logical :: integrate_by_parts_once=.false. + ! Whether the conservation term is integrated by parts or not + logical :: integrate_conservation_term_by_parts=.false. + ! Whether or not to integrate the surface tension term by parts + logical :: integrate_surfacetension_by_parts + + ! Weight between conservative and non-conservative forms of the advection + ! equation. + ! 1 is for conservative 0 is for non-conservative. + real :: beta + + ! Discretisation to use for viscosity term. + integer :: viscosity_scheme + integer, parameter :: ARBITRARY_UPWIND=1 + integer, parameter :: BASSI_REBAY=2 + integer, parameter :: CDG=3 + integer, parameter :: IP=4 + + ! Method for getting h0 in IP + integer :: edge_length_option + integer, parameter :: USE_FACE_INTEGRALS=1 + integer, parameter :: USE_ELEMENT_CENTRES=2 + + ! Parameters for interior penalty method + real :: Interior_Penalty_Parameter, edge_length_power, h0 + + ! Flag indicating whether to include pressure bcs (not for cv pressure) + logical :: l_include_pressure_bcs + + ! which terms do we have? + logical :: have_mass + logical :: have_source + logical :: have_gravity + logical :: on_sphere, radial_gravity + logical :: have_absorption + logical :: have_vertical_stabilization + logical :: have_implicit_buoyancy + logical :: have_vertical_velocity_relaxation + logical :: have_swe_bottom_drag + ! implicit absorption is corrected by the pressure correction + ! by combining the implicit part of absorption with the mass term of u^{n+1} + logical :: pressure_corrected_absorption + logical :: have_viscosity + logical :: have_surfacetension + logical :: have_coriolis + logical :: have_advection + logical :: move_mesh + logical :: have_pressure_bc + logical :: subtract_out_reference_profile + logical :: have_les + + real :: gravity_magnitude + + ! CDG stuff + real, dimension(3) :: switch_g + logical :: CDG_penalty + logical :: remove_penalty_fluxes + + ! Are we running a multi-phase flow simulation? + logical :: multiphase contains - subroutine construct_momentum_dg(u, p, rho, x, & - & big_m, rhs, state, & - & inverse_masslump, inverse_mass, mass, & - & include_pressure_bcs, subcycle_m, subcycle_rhs) - !!< Construct the momentum equation for discontinuous elements in - !!< acceleration form. - - !! velocity and coordinate - type(vector_field), intent(inout) :: u, x - !! pressure and density - type(scalar_field), intent(inout) :: p, rho - - !! Main momentum matrix. - type(petsc_csr_matrix), intent(inout) :: big_m - !! Explicit subcycling matrix. - type(block_csr_matrix), intent(inout), optional :: subcycle_m - !! Momentum right hand side vector for each point. - type(vector_field), intent(inout) :: rhs - !! Right hand side vector containing advection bc terms if subcycling - type(vector_field), intent(inout), optional :: subcycle_rhs - !! Collection of fields defining system state. - type(state_type) :: state - - !! Inverse of the lumped mass lumping at each point. - !! NOTE: only allocated and calculated if (lump_mass) - type(vector_field), intent(inout), optional :: inverse_masslump - !! Optional separate mass matrix. - !! NOTE: if provided the mass matrix, won't be added to big_m - !! NOTE2: this mass matrix does not include density, bcs or absorption factors - !! NOTE3: mass is not allocated here (unlike inverse_masslump and inverse_mass) - type(csr_matrix), intent(inout), optional :: mass - !! Inverse mass matrix - !! NOTE: only allocated and calculated if (.not. lump_mass) - !! NOTE2: diagonal blocks may be different due to dirichlet bcs and/or absorption - type(block_csr_matrix), intent(inout), optional :: inverse_mass - - !! whether to include the dirichlet pressure bc integrals to the rhs - logical, intent(in), optional :: include_pressure_bcs - - !! Position, velocity and source fields. - type(vector_field), pointer :: U_mesh, X_old, X_new - type(vector_field), target :: U_nl - !! Projected velocity field for them as needs it. - type(vector_field), target :: pvelocity - type(vector_field), pointer :: advecting_velocity - !! Mesh for projected velocity. - type(mesh_type) :: pmesh - character(len=FIELD_NAME_LEN) :: pmesh_name - - !! Viscosity - type(tensor_field) :: Viscosity - - !! Momentum source and absorption fields - type(scalar_field) :: buoyancy - type(vector_field) :: Source, gravity, Abs, Abs_wd - !! Surface tension field - type(tensor_field) :: surfacetension - - ! Dummy fields in case state doesn't contain the above fields - type(scalar_field), pointer :: dummyscalar - - ! Fields for the subtract_out_reference_profile option under the Velocity field - type(scalar_field), pointer :: hb_density, hb_pressure - - !! field over the entire surface mesh, giving bc values - type(vector_field) :: velocity_bc - type(scalar_field) :: pressure_bc - !! for each surface element, the bc type to be applied there - !! integer value determined by ordering in call to get_entire_boundary_condition - integer, dimension(:,:), allocatable :: velocity_bc_type - integer, dimension(:), allocatable :: pressure_bc_type - - !! Sparsity for inverse mass - type(csr_sparsity):: mass_sparsity - - !! Element index - integer :: ele - - !! Status variable for field extraction. - integer :: stat - - !! Mesh for auxiliary variable - type(mesh_type), save :: q_mesh, turbine_conn_mesh - - ! Fields for vertical velocity relaxation - type(scalar_field), pointer :: dtt, dtb - type(scalar_field) :: depth - integer :: node - real :: vvr_sf ! A scale factor for the absorption - - ! Min vertical density gradient for implicit buoyancy - real :: ib_min_grad - - !! Wetting and drying - type(scalar_field), pointer :: wettingdrying_alpha - type(scalar_field) :: alpha_u_field - logical :: have_wd_abs - real, dimension(u%dim) :: abs_wd_const - - !! shallow water bottom drag - type(scalar_field) :: swe_bottom_drag, old_pressure - type(vector_field) :: swe_u_nl - - !! - type(integer_set), dimension(:), pointer :: colours - integer :: len, clr, nnid - !! Is the transform_to_physical cache we prepopulated valid + subroutine construct_momentum_dg(u, p, rho, x, & + & big_m, rhs, state, & + & inverse_masslump, inverse_mass, mass, & + & include_pressure_bcs, subcycle_m, subcycle_rhs) + !!< Construct the momentum equation for discontinuous elements in + !!< acceleration form. + + !! velocity and coordinate + type(vector_field), intent(inout) :: u, x + !! pressure and density + type(scalar_field), intent(inout) :: p, rho + + !! Main momentum matrix. + type(petsc_csr_matrix), intent(inout) :: big_m + !! Explicit subcycling matrix. + type(block_csr_matrix), intent(inout), optional :: subcycle_m + !! Momentum right hand side vector for each point. + type(vector_field), intent(inout) :: rhs + !! Right hand side vector containing advection bc terms if subcycling + type(vector_field), intent(inout), optional :: subcycle_rhs + !! Collection of fields defining system state. + type(state_type) :: state + + !! Inverse of the lumped mass lumping at each point. + !! NOTE: only allocated and calculated if (lump_mass) + type(vector_field), intent(inout), optional :: inverse_masslump + !! Optional separate mass matrix. + !! NOTE: if provided the mass matrix, won't be added to big_m + !! NOTE2: this mass matrix does not include density, bcs or absorption factors + !! NOTE3: mass is not allocated here (unlike inverse_masslump and inverse_mass) + type(csr_matrix), intent(inout), optional :: mass + !! Inverse mass matrix + !! NOTE: only allocated and calculated if (.not. lump_mass) + !! NOTE2: diagonal blocks may be different due to dirichlet bcs and/or absorption + type(block_csr_matrix), intent(inout), optional :: inverse_mass + + !! whether to include the dirichlet pressure bc integrals to the rhs + logical, intent(in), optional :: include_pressure_bcs + + !! Position, velocity and source fields. + type(vector_field), pointer :: U_mesh, X_old, X_new + type(vector_field), target :: U_nl + !! Projected velocity field for them as needs it. + type(vector_field), target :: pvelocity + type(vector_field), pointer :: advecting_velocity + !! Mesh for projected velocity. + type(mesh_type) :: pmesh + character(len=FIELD_NAME_LEN) :: pmesh_name + + !! Viscosity + type(tensor_field) :: Viscosity + + !! Momentum source and absorption fields + type(scalar_field) :: buoyancy + type(vector_field) :: Source, gravity, Abs, Abs_wd + !! Surface tension field + type(tensor_field) :: surfacetension + + ! Dummy fields in case state doesn't contain the above fields + type(scalar_field), pointer :: dummyscalar + + ! Fields for the subtract_out_reference_profile option under the Velocity field + type(scalar_field), pointer :: hb_density, hb_pressure + + !! field over the entire surface mesh, giving bc values + type(vector_field) :: velocity_bc + type(scalar_field) :: pressure_bc + !! for each surface element, the bc type to be applied there + !! integer value determined by ordering in call to get_entire_boundary_condition + integer, dimension(:,:), allocatable :: velocity_bc_type + integer, dimension(:), allocatable :: pressure_bc_type + + !! Sparsity for inverse mass + type(csr_sparsity):: mass_sparsity + + !! Element index + integer :: ele + + !! Status variable for field extraction. + integer :: stat + + !! Mesh for auxiliary variable + type(mesh_type), save :: q_mesh, turbine_conn_mesh + + ! Fields for vertical velocity relaxation + type(scalar_field), pointer :: dtt, dtb + type(scalar_field) :: depth + integer :: node + real :: vvr_sf ! A scale factor for the absorption + + ! Min vertical density gradient for implicit buoyancy + real :: ib_min_grad + + !! Wetting and drying + type(scalar_field), pointer :: wettingdrying_alpha + type(scalar_field) :: alpha_u_field + logical :: have_wd_abs + real, dimension(u%dim) :: abs_wd_const + + !! shallow water bottom drag + type(scalar_field) :: swe_bottom_drag, old_pressure + type(vector_field) :: swe_u_nl + + !! + type(integer_set), dimension(:), pointer :: colours + integer :: len, clr, nnid + !! Is the transform_to_physical cache we prepopulated valid #ifdef _OPENMP - logical :: cache_valid + logical :: cache_valid #endif - integer :: num_threads + integer :: num_threads - ! Volume fraction fields for multi-phase flow simulation - type(scalar_field), pointer :: vfrac - type(scalar_field) :: nvfrac ! Non-linear approximation to the PhaseVolumeFraction + ! Volume fraction fields for multi-phase flow simulation + type(scalar_field), pointer :: vfrac + type(scalar_field) :: nvfrac ! Non-linear approximation to the PhaseVolumeFraction - ! Partial stress - sp911 - logical :: partial_stress + ! Partial stress - sp911 + logical :: partial_stress - ! LES - sp911 - real :: smagorinsky_coefficient - type(scalar_field), pointer :: eddy_visc, prescribed_filter_width, distance_to_wall, & - & y_plus_debug, les_filter_width_debug + ! LES - sp911 + real :: smagorinsky_coefficient + type(scalar_field), pointer :: eddy_visc, prescribed_filter_width, distance_to_wall, & + & y_plus_debug, les_filter_width_debug - ewrite(1, *) "In construct_momentum_dg" + ewrite(1, *) "In construct_momentum_dg" - call profiler_tic("construct_momentum_dg") - assert(continuity(u)<0) + call profiler_tic("construct_momentum_dg") + assert(continuity(u)<0) - if(present(include_pressure_bcs)) then - l_include_pressure_bcs = include_pressure_bcs - else - l_include_pressure_bcs = .true. - end if + if(present(include_pressure_bcs)) then + l_include_pressure_bcs = include_pressure_bcs + else + l_include_pressure_bcs = .true. + end if - ! These names are based on the CGNS SIDS. - U_nl=extract_vector_field(state, "NonlinearVelocity") - call incref(U_nl) + ! These names are based on the CGNS SIDS. + U_nl=extract_vector_field(state, "NonlinearVelocity") + call incref(U_nl) - if (.not.have_option(trim(U%option_path)//"/prognostic"//& + if (.not.have_option(trim(U%option_path)//"/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin"//& + &"/advection_scheme/none")) then + if(have_option(trim(U%option_path)//"/prognostic"//& &"/spatial_discretisation/discontinuous_galerkin"//& - &"/advection_scheme/none")) then - if(have_option(trim(U%option_path)//"/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin"//& - &"/advection_scheme/project_velocity_to_continuous")) then - ewrite(3,*) 'CREATING PROJECTEDNONLINEARVELOCITY, cjc' - if(.not.has_scalar_field(state, "ProjectedNonlinearVelocity")) then - - call get_option(trim(U%option_path)//"/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin"//& - &"/advection_scheme/project_velocity_to_continuous"//& - &"/mesh/name",pmesh_name) - pmesh = extract_mesh(state, pmesh_name) - call allocate(pvelocity, U_nl%dim, pmesh, & - &"ProjectedNonlinearVelocity") - call project_field(U_nl, pvelocity, X) - call insert(state, pvelocity, "ProjectedNonlinearVelocity") - advecting_velocity => pvelocity - - ! Discard the additional reference. - call deallocate(pvelocity) - else - pvelocity = extract_vector_field(state, & - &"ProjectedNonlinearVelocity") - - advecting_velocity => pvelocity - end if - else - advecting_velocity => U_nl - end if - have_advection = .true. - else - have_advection=.false. - advecting_velocity => U_nl - end if - ewrite(2, *) "Include advection? ", have_advection - - allocate(dummyscalar) - call allocate(dummyscalar, u%mesh, "DummyScalar", field_type=FIELD_TYPE_CONSTANT) - call zero(dummyscalar) - dummyscalar%option_path="" - - Source=extract_vector_field(state, "VelocitySource", stat) - have_source = (stat==0) - if (.not.have_source) then - call allocate(Source, U%dim, U%mesh, "VelocitySource", FIELD_TYPE_CONSTANT) - call zero(Source) - else - ! Grab an extra reference to cause the deallocate below to be safe. - call incref(Source) - ewrite_minmax(source) - end if - - Abs=extract_vector_field(state, "VelocityAbsorption", stat) - have_absorption = (stat==0) - if (.not.have_absorption) then - call allocate(Abs, U%dim, U%mesh, "VelocityAbsorption", FIELD_TYPE_CONSTANT) - call zero(Abs) - else - ! Grab an extra reference to cause the deallocate below to be safe. - call incref(Abs) - ewrite_minmax(Abs) - end if - - have_wd_abs=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption") - ! Absorption term in dry zones for wetting and drying - if (have_wd_abs) then - call allocate(Abs_wd, U%dim, U%mesh, "VelocityAbsorption_WettingDrying", FIELD_TYPE_CONSTANT) - call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption", abs_wd_const) - call set(Abs_wd, abs_wd_const) - ! else - ! call zero(Abs_wd) - end if - - ! Check if we have either implicit absorption term - have_vertical_stabilization=have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation").or. & - have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") - - ! If we have vertical velocity relaxation set then grab the required fields - ! sigma = n_z*g*dt*_rho_o/depth - have_vertical_velocity_relaxation=have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation") - if (have_vertical_velocity_relaxation) then - call get_option(trim(U%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation/scale_factor", vvr_sf) - dtt => extract_scalar_field(state, "DistanceToTop") - dtb => extract_scalar_field(state, "DistanceToBottom") - call allocate(depth, dtt%mesh, "Depth") - do node=1,node_count(dtt) - call set(depth, node, node_val(dtt, node)+node_val(dtb, node)) - end do - endif - - ! Implicit buoyancy (theta*g*dt*drho/dr) - have_implicit_buoyancy=have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") - call get_option(trim(U%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy/min_gradient"& - , ib_min_grad, default=0.0) - - have_swe_bottom_drag = have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater/bottom_drag') - if (have_swe_bottom_drag) then - ! Note that we don't do this incref business, instead we just pass uninitialised fields if .not. have_swe_bottom_drag - swe_bottom_drag = extract_scalar_field(state, "BottomDragCoefficient") - assert(.not. have_vertical_stabilization) - depth = extract_scalar_field(state, "BottomDepth") ! we reuse the field that's already passed for VVR - old_pressure = extract_scalar_field(state, "OldPressure") + &"/advection_scheme/project_velocity_to_continuous")) then + ewrite(3,*) 'CREATING PROJECTEDNONLINEARVELOCITY, cjc' + if(.not.has_scalar_field(state, "ProjectedNonlinearVelocity")) then + + call get_option(trim(U%option_path)//"/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin"//& + &"/advection_scheme/project_velocity_to_continuous"//& + &"/mesh/name",pmesh_name) + pmesh = extract_mesh(state, pmesh_name) + call allocate(pvelocity, U_nl%dim, pmesh, & + &"ProjectedNonlinearVelocity") + call project_field(U_nl, pvelocity, X) + call insert(state, pvelocity, "ProjectedNonlinearVelocity") + advecting_velocity => pvelocity + + ! Discard the additional reference. + call deallocate(pvelocity) + else + pvelocity = extract_vector_field(state, & + &"ProjectedNonlinearVelocity") + + advecting_velocity => pvelocity + end if + else + advecting_velocity => U_nl + end if + have_advection = .true. + else + have_advection=.false. + advecting_velocity => U_nl + end if + ewrite(2, *) "Include advection? ", have_advection + + allocate(dummyscalar) + call allocate(dummyscalar, u%mesh, "DummyScalar", field_type=FIELD_TYPE_CONSTANT) + call zero(dummyscalar) + dummyscalar%option_path="" + + Source=extract_vector_field(state, "VelocitySource", stat) + have_source = (stat==0) + if (.not.have_source) then + call allocate(Source, U%dim, U%mesh, "VelocitySource", FIELD_TYPE_CONSTANT) + call zero(Source) + else + ! Grab an extra reference to cause the deallocate below to be safe. + call incref(Source) + ewrite_minmax(source) + end if + + Abs=extract_vector_field(state, "VelocityAbsorption", stat) + have_absorption = (stat==0) + if (.not.have_absorption) then + call allocate(Abs, U%dim, U%mesh, "VelocityAbsorption", FIELD_TYPE_CONSTANT) + call zero(Abs) + else + ! Grab an extra reference to cause the deallocate below to be safe. + call incref(Abs) + ewrite_minmax(Abs) + end if + + have_wd_abs=have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption") + ! Absorption term in dry zones for wetting and drying + if (have_wd_abs) then + call allocate(Abs_wd, U%dim, U%mesh, "VelocityAbsorption_WettingDrying", FIELD_TYPE_CONSTANT) + call get_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying/dry_absorption", abs_wd_const) + call set(Abs_wd, abs_wd_const) + ! else + ! call zero(Abs_wd) + end if + + ! Check if we have either implicit absorption term + have_vertical_stabilization=have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation").or. & + have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") + + ! If we have vertical velocity relaxation set then grab the required fields + ! sigma = n_z*g*dt*_rho_o/depth + have_vertical_velocity_relaxation=have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation") + if (have_vertical_velocity_relaxation) then + call get_option(trim(U%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation/scale_factor", vvr_sf) + dtt => extract_scalar_field(state, "DistanceToTop") + dtb => extract_scalar_field(state, "DistanceToBottom") + call allocate(depth, dtt%mesh, "Depth") + do node=1,node_count(dtt) + call set(depth, node, node_val(dtt, node)+node_val(dtb, node)) + end do + endif + + ! Implicit buoyancy (theta*g*dt*drho/dr) + have_implicit_buoyancy=have_option(trim(U%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") + call get_option(trim(U%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy/min_gradient"& + , ib_min_grad, default=0.0) + + have_swe_bottom_drag = have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater/bottom_drag') + if (have_swe_bottom_drag) then + ! Note that we don't do this incref business, instead we just pass uninitialised fields if .not. have_swe_bottom_drag + swe_bottom_drag = extract_scalar_field(state, "BottomDragCoefficient") + assert(.not. have_vertical_stabilization) + depth = extract_scalar_field(state, "BottomDepth") ! we reuse the field that's already passed for VVR + old_pressure = extract_scalar_field(state, "OldPressure") + call get_option(trim(U%option_path)//& + &"/prognostic/temporal_discretisation/relaxation", theta_nl) + ! because of the kludge above with advecting velocity, let's just have our own u_nl + ! can be on whatever mesh + swe_u_nl = extract_vector_field(state, "NonlinearVelocity") + end if + + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude, stat) + have_gravity = stat==0 + if (have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater')) then + ! for the swe there's no buoyancy term + have_gravity = .false. + assert(stat==0) ! we should have a gravity_magnitude though + end if + + if(have_gravity) then + buoyancy=extract_scalar_field(state, "VelocityBuoyancyDensity") + call incref(buoyancy) + gravity=extract_vector_field(state, "GravityDirection", stat) + call incref(gravity) + else + call allocate(buoyancy, u%mesh, "VelocityBuoyancyDensity", FIELD_TYPE_CONSTANT) + call zero(buoyancy) + call allocate(gravity, u%dim, u%mesh, "GravityDirection", FIELD_TYPE_CONSTANT) + call zero(gravity) + end if + ewrite_minmax(buoyancy) + + radial_gravity = have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/discontinuous_galerkin"//& + &"/buoyancy/radial_gravity_direction_at_gauss_points") + + ! Splits up the Density and Pressure fields into a hydrostatic component (') and a perturbed component (''). + ! The hydrostatic components, denoted p' and rho', should satisfy the balance: grad(p') = rho'*g + ! We subtract the hydrostatic component from the density used in the buoyancy term of the momentum equation. + if (have_option(trim(state%option_path)//'/equation_of_state/compressible/subtract_out_reference_profile')) then + subtract_out_reference_profile = .true. + hb_density => extract_scalar_field(state, "HydrostaticReferenceDensity") + + if(l_include_pressure_bcs) then + hb_pressure => extract_scalar_field(state, "HydrostaticReferencePressure") + else + hb_pressure => dummyscalar + end if + else + subtract_out_reference_profile = .false. + hb_density => dummyscalar + hb_pressure => dummyscalar + end if + + Viscosity=extract_tensor_field(state, "Viscosity", stat) + have_viscosity = (stat==0) + if (.not.have_viscosity) then + call allocate(Viscosity, U%mesh, "Viscosity", FIELD_TYPE_CONSTANT) + call zero(Viscosity) + else + ! Grab an extra reference to cause the deallocate below to be safe. + call incref(Viscosity) + ewrite_minmax(viscosity) + end if + + surfacetension = extract_tensor_field(state, "VelocitySurfaceTension", stat) + have_surfacetension = (stat == 0) + if(.not. have_surfacetension) then + call allocate(surfacetension, u%mesh, "VelocitySurfaceTension", FIELD_TYPE_CONSTANT) + call zero(surfacetension) + else + call incref(surfacetension) + ewrite_minmax(surfacetension) + end if + + ! Are we running a multi-phase simulation? + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + multiphase = .true. + + vfrac => extract_scalar_field(state, "PhaseVolumeFraction") + call allocate(nvfrac, vfrac%mesh, "NonlinearPhaseVolumeFraction") + call zero(nvfrac) + call get_nonlinear_volume_fraction(state, nvfrac) + + ewrite_minmax(nvfrac) + + else + multiphase = .false. + nullify(vfrac) + end if + + have_coriolis = have_option("/physical_parameters/coriolis") + + q_mesh=Viscosity%mesh + + on_sphere = have_option('/geometry/spherical_earth/') + + ! Extract model parameters from options dictionary. call get_option(trim(U%option_path)//& - &"/prognostic/temporal_discretisation/relaxation", theta_nl) - ! because of the kludge above with advecting velocity, let's just have our own u_nl - ! can be on whatever mesh - swe_u_nl = extract_vector_field(state, "NonlinearVelocity") - end if - - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude, stat) - have_gravity = stat==0 - if (have_option(trim(u%option_path)//'/prognostic/equation::ShallowWater')) then - ! for the swe there's no buoyancy term - have_gravity = .false. - assert(stat==0) ! we should have a gravity_magnitude though - end if - - if(have_gravity) then - buoyancy=extract_scalar_field(state, "VelocityBuoyancyDensity") - call incref(buoyancy) - gravity=extract_vector_field(state, "GravityDirection", stat) - call incref(gravity) - else - call allocate(buoyancy, u%mesh, "VelocityBuoyancyDensity", FIELD_TYPE_CONSTANT) - call zero(buoyancy) - call allocate(gravity, u%dim, u%mesh, "GravityDirection", FIELD_TYPE_CONSTANT) - call zero(gravity) - end if - ewrite_minmax(buoyancy) - - radial_gravity = have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/discontinuous_galerkin"//& - &"/buoyancy/radial_gravity_direction_at_gauss_points") - - ! Splits up the Density and Pressure fields into a hydrostatic component (') and a perturbed component (''). - ! The hydrostatic components, denoted p' and rho', should satisfy the balance: grad(p') = rho'*g - ! We subtract the hydrostatic component from the density used in the buoyancy term of the momentum equation. - if (have_option(trim(state%option_path)//'/equation_of_state/compressible/subtract_out_reference_profile')) then - subtract_out_reference_profile = .true. - hb_density => extract_scalar_field(state, "HydrostaticReferenceDensity") - - if(l_include_pressure_bcs) then - hb_pressure => extract_scalar_field(state, "HydrostaticReferencePressure") - else - hb_pressure => dummyscalar - end if - else - subtract_out_reference_profile = .false. - hb_density => dummyscalar - hb_pressure => dummyscalar - end if - - Viscosity=extract_tensor_field(state, "Viscosity", stat) - have_viscosity = (stat==0) - if (.not.have_viscosity) then - call allocate(Viscosity, U%mesh, "Viscosity", FIELD_TYPE_CONSTANT) - call zero(Viscosity) - else - ! Grab an extra reference to cause the deallocate below to be safe. - call incref(Viscosity) - ewrite_minmax(viscosity) - end if - - surfacetension = extract_tensor_field(state, "VelocitySurfaceTension", stat) - have_surfacetension = (stat == 0) - if(.not. have_surfacetension) then - call allocate(surfacetension, u%mesh, "VelocitySurfaceTension", FIELD_TYPE_CONSTANT) - call zero(surfacetension) - else - call incref(surfacetension) - ewrite_minmax(surfacetension) - end if - - ! Are we running a multi-phase simulation? - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - multiphase = .true. - - vfrac => extract_scalar_field(state, "PhaseVolumeFraction") - call allocate(nvfrac, vfrac%mesh, "NonlinearPhaseVolumeFraction") - call zero(nvfrac) - call get_nonlinear_volume_fraction(state, nvfrac) - - ewrite_minmax(nvfrac) - - else - multiphase = .false. - nullify(vfrac) - end if - - have_coriolis = have_option("/physical_parameters/coriolis") - - q_mesh=Viscosity%mesh - - on_sphere = have_option('/geometry/spherical_earth/') - - ! Extract model parameters from options dictionary. - call get_option(trim(U%option_path)//& - &"/prognostic/temporal_discretisation/theta", theta) - call get_option("/timestepping/timestep", dt) - - have_mass = .not. have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/mass_terms/exclude_mass_terms") - lump_mass=have_option(trim(U%option_path)//& + &"/prognostic/temporal_discretisation/theta", theta) + call get_option("/timestepping/timestep", dt) + + have_mass = .not. have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/mass_terms/exclude_mass_terms") + lump_mass=have_option(trim(U%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/mass_terms/lump_mass_matrix") + lump_abs=have_option(trim(U%option_path)//& + &"/prognostic/vector_field::Absorption"//& + &"/lump_absorption") + pressure_corrected_absorption=have_option(trim(u%option_path)//& + &"/prognostic/vector_field::Absorption"//& + &"/include_pressure_correction") .or. (have_vertical_stabilization) + + if (pressure_corrected_absorption) then + ! as we add the absorption into the mass matrix + ! lump_abs needs to match lump_mass + lump_abs = lump_mass + end if + lump_source=have_option(trim(u%option_path)//& + &"/prognostic/vector_field::Source"//& + &"/lump_source") + call get_option(trim(U%option_path)//"/prognostic/spatial_discretisation"//& + &"/conservative_advection", beta) + + ! mesh movement here only matters for the mass terms + ! other terms are evaluated using "Coordinate" which is evaluated at t+theta*dt + move_mesh = have_option("/mesh_adaptivity/mesh_movement") .and. & + have_mass + if (move_mesh) then + X_old => extract_vector_field(state, "OldCoordinate") + X_new => extract_vector_field(state, "IteratedCoordinate") + U_mesh => extract_vector_field(state, "GridVelocity") + end if + + ! by default we assume we're integrating by parts twice + integrate_by_parts_once = have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/advection_scheme/integrate_advection_by_parts/once") + + integrate_conservation_term_by_parts = have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/advection_scheme/integrate_conservation_term_by_parts") + + ! Determine the scheme to use to discretise viscosity. + if (have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/viscosity_scheme/bassi_rebay")) then + viscosity_scheme=BASSI_REBAY + else if (have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/viscosity_scheme& + &/compact_discontinuous_galerkin")) then + !=================Compact Discontinuous Galerkin + viscosity_scheme=CDG + !Set the switch vector + switch_g = 0. + switch_g(1) = exp(sin(3.0+exp(1.0))) + if(mesh_dim(U)>1) switch_g(2) = (cos(exp(3.0)/sin(2.0)))**2 + if(mesh_dim(U)>2) switch_g(3) = sin(cos(sin(cos(3.0)))) + switch_g = switch_g/sqrt(sum(switch_g**2)) + + remove_penalty_fluxes = .true. + interior_penalty_parameter = 0.0 + if(have_option(trim(U%option_path)//& &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/mass_terms/lump_mass_matrix") - lump_abs=have_option(trim(U%option_path)//& - &"/prognostic/vector_field::Absorption"//& - &"/lump_absorption") - pressure_corrected_absorption=have_option(trim(u%option_path)//& - &"/prognostic/vector_field::Absorption"//& - &"/include_pressure_correction") .or. (have_vertical_stabilization) - - if (pressure_corrected_absorption) then - ! as we add the absorption into the mass matrix - ! lump_abs needs to match lump_mass - lump_abs = lump_mass - end if - lump_source=have_option(trim(u%option_path)//& - &"/prognostic/vector_field::Source"//& - &"/lump_source") - call get_option(trim(U%option_path)//"/prognostic/spatial_discretisation"//& - &"/conservative_advection", beta) - - ! mesh movement here only matters for the mass terms - ! other terms are evaluated using "Coordinate" which is evaluated at t+theta*dt - move_mesh = have_option("/mesh_adaptivity/mesh_movement") .and. & - have_mass - if (move_mesh) then - X_old => extract_vector_field(state, "OldCoordinate") - X_new => extract_vector_field(state, "IteratedCoordinate") - U_mesh => extract_vector_field(state, "GridVelocity") - end if - - ! by default we assume we're integrating by parts twice - integrate_by_parts_once = have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/advection_scheme/integrate_advection_by_parts/once") - - integrate_conservation_term_by_parts = have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/advection_scheme/integrate_conservation_term_by_parts") - - ! Determine the scheme to use to discretise viscosity. - if (have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/viscosity_scheme/bassi_rebay")) then - viscosity_scheme=BASSI_REBAY - else if (have_option(trim(U%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/viscosity_scheme& - &/compact_discontinuous_galerkin")) then - !=================Compact Discontinuous Galerkin - viscosity_scheme=CDG - !Set the switch vector - switch_g = 0. - switch_g(1) = exp(sin(3.0+exp(1.0))) - if(mesh_dim(U)>1) switch_g(2) = (cos(exp(3.0)/sin(2.0)))**2 - if(mesh_dim(U)>2) switch_g(3) = sin(cos(sin(cos(3.0)))) - switch_g = switch_g/sqrt(sum(switch_g**2)) - - remove_penalty_fluxes = .true. - interior_penalty_parameter = 0.0 - if(have_option(trim(U%option_path)//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/compact_discontinuous_galerkin/penalty_parameter")) then + remove_penalty_fluxes = .false. + edge_length_power = 0.0 + call get_option(trim(U%option_path)//& &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/viscosity_scheme"//& - &"/compact_discontinuous_galerkin/penalty_parameter")) then - remove_penalty_fluxes = .false. - edge_length_power = 0.0 - call get_option(trim(U%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/compact_discontinuous_galerkin/penalty_parameter"& - &,Interior_Penalty_Parameter) - end if - - CDG_penalty = .true. - edge_length_option = USE_FACE_INTEGRALS - - else if (have_option(trim(U%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme/arbitrary_upwind")) then - viscosity_scheme=ARBITRARY_UPWIND - else if (have_option(trim(U%option_path)//& + &"/compact_discontinuous_galerkin/penalty_parameter"& + &,Interior_Penalty_Parameter) + end if + + CDG_penalty = .true. + edge_length_option = USE_FACE_INTEGRALS + + else if (have_option(trim(U%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme/arbitrary_upwind")) then + viscosity_scheme=ARBITRARY_UPWIND + else if (have_option(trim(U%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme/interior_penalty")) then + remove_penalty_fluxes = .false. + viscosity_scheme=IP + CDG_penalty = .false. + call get_option(trim(U%option_path)//& &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme/interior_penalty")) then - remove_penalty_fluxes = .false. - viscosity_scheme=IP - CDG_penalty = .false. - call get_option(trim(U%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/interior_penalty/penalty_parameter",Interior_Penalty_Parameter) - call get_option(trim(U%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/interior_penalty/edge_length_power",edge_length_power) - edge_length_option = USE_FACE_INTEGRALS - if(have_option(trim(U%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/interior_penalty/edge_length_option/use_element_centres")) then - edge_length_option = USE_ELEMENT_CENTRES - end if - else - FLAbort("Unknown viscosity scheme - Options tree corrupted?") - end if - - partial_stress = .false. - have_les = .false. - if (have_option(trim(u%option_path)//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/interior_penalty/penalty_parameter",Interior_Penalty_Parameter) + call get_option(trim(U%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/interior_penalty/edge_length_power",edge_length_power) + edge_length_option = USE_FACE_INTEGRALS + if(have_option(trim(U%option_path)//& &"/prognostic/spatial_discretisation"//& &"/discontinuous_galerkin/viscosity_scheme"//& - &"/partial_stress_form")) then + &"/interior_penalty/edge_length_option/use_element_centres")) then + edge_length_option = USE_ELEMENT_CENTRES + end if + else + FLAbort("Unknown viscosity scheme - Options tree corrupted?") + end if - partial_stress = .true. + partial_stress = .false. + have_les = .false. + if (have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/partial_stress_form")) then - ! if we have stress form then we may be doing LES modelling - end if + partial_stress = .true. - if (have_option(trim(u%option_path)//& + ! if we have stress form then we may be doing LES modelling + end if + + if (have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/les_model")) then + have_les = .true. + call get_option(trim(u%option_path)//& &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/les_model")) then - have_les = .true. - call get_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/les_model"//& - &"/smagorinsky_coefficient", & + &"/discontinuous_galerkin/les_model"//& + &"/smagorinsky_coefficient", & smagorinsky_coefficient) - end if - - ewrite(2,*) 'partial stress? ', partial_stress - - ! les variables - need to be nullified if non-existent - eddy_visc => extract_scalar_field(state, "DGLESScalarEddyViscosity", stat=stat) - if (stat/=0) then - nullify(eddy_visc) - end if - prescribed_filter_width => extract_scalar_field(state, "FilterWidth", stat=stat) - if (stat/=0) then - nullify(prescribed_filter_width) - end if - distance_to_wall => extract_scalar_field(state, "DistanceToWall", stat=stat) - if (stat/=0) then - nullify(distance_to_wall) - end if - y_plus_debug => extract_scalar_field(state, "YPlus", stat=stat) - if (stat/=0) then - nullify(y_plus_debug) - end if - les_filter_width_debug => extract_scalar_field(state, "DampedFilterWidth", stat=stat) - if (stat/=0) then - nullify(les_filter_width_debug) - end if - ! end of les variables - - integrate_surfacetension_by_parts = have_option(trim(u%option_path)//& + end if + + ewrite(2,*) 'partial stress? ', partial_stress + + ! les variables - need to be nullified if non-existent + eddy_visc => extract_scalar_field(state, "DGLESScalarEddyViscosity", stat=stat) + if (stat/=0) then + nullify(eddy_visc) + end if + prescribed_filter_width => extract_scalar_field(state, "FilterWidth", stat=stat) + if (stat/=0) then + nullify(prescribed_filter_width) + end if + distance_to_wall => extract_scalar_field(state, "DistanceToWall", stat=stat) + if (stat/=0) then + nullify(distance_to_wall) + end if + y_plus_debug => extract_scalar_field(state, "YPlus", stat=stat) + if (stat/=0) then + nullify(y_plus_debug) + end if + les_filter_width_debug => extract_scalar_field(state, "DampedFilterWidth", stat=stat) + if (stat/=0) then + nullify(les_filter_width_debug) + end if + ! end of les variables + + integrate_surfacetension_by_parts = have_option(trim(u%option_path)//& &"/prognostic/tensor_field::SurfaceTension"//& &"/diagnostic/integrate_by_parts") - assert(has_faces(X%mesh)) - assert(has_faces(P%mesh)) - - call zero(big_m) - call zero(RHS) - - subcycle=.false. - if(present(subcycle_m)) subcycle=.true. - - if(subcycle) then - call zero(subcycle_m) - if (.not. present(subcycle_rhs)) then - FLAbort("Need to call construct_momentum_dg with both subcycle_m and subcycle_rhs") - end if - call zero(subcycle_rhs) - end if - - if(present(inverse_masslump) .and. lump_mass) then - call allocate(inverse_masslump, u%dim, u%mesh, "InverseLumpedMass") - call zero(inverse_masslump) - end if - if(present(inverse_mass) .and. .not. lump_mass) then - assert(u%mesh%continuity<0) - mass_sparsity=make_sparsity_dg_mass(u%mesh) - - if (pressure_corrected_absorption .or. has_boundary_condition(u, "dirichlet")) then - ! the diagonal blocks are different - call allocate( inverse_mass, mass_sparsity, (/ u%dim, u%dim /), & - diagonal=.true., name="InverseMassMatrix") - else - ! diagonal blocks are the same and all point to the same memory - call allocate( inverse_mass, mass_sparsity, (/ u%dim, u%dim /), & - diagonal=.true., equal_diagonal_blocks=.true., name="InverseMassMatrix") - end if - ! Drop the extra reference to sparsity. - call deallocate(mass_sparsity) - end if - - ! get bc type and values on entire surface mesh - ! numbering of types, determined by ordering here, i.e. - ! weakdirichlet=1, free_surface=2 - allocate(velocity_bc_type(U%dim, surface_element_count(U))) - call get_entire_boundary_condition(U, (/ & - "weakdirichlet ", & - "free_surface ", & - "no_normal_flow ", & - "turbine_flux_penalty", & - "turbine_flux_dg " /), velocity_bc, velocity_bc_type) - - ! the turbine connectivity mesh is only needed if one of the boundaries is a turbine. - if (any(velocity_bc_type==4) .or. any(velocity_bc_type==5)) then - turbine_conn_mesh=get_periodic_mesh(state, u%mesh) - end if - - ! same for pressure - allocate(pressure_bc_type(surface_element_count(P))) - call get_entire_boundary_condition(P, (/ & - "weakdirichlet", & - "dirichlet "/), pressure_bc, pressure_bc_type) - have_pressure_bc = any(pressure_bc_type>0) - - if (have_wd_abs) then - if (.not. has_scalar_field(state, "WettingDryingAlpha")) then - FLExit("Wetting and drying needs the diagnostic field WettingDryingAlpha activated.") - end if - ! The alpha fields lives on the pressure mesh, but we need it on the velocity, so let's remap it. - wettingdrying_alpha => extract_scalar_field(state, "WettingDryingAlpha") - call allocate(alpha_u_field, u%mesh, "alpha_u") - call remap_field(wettingdrying_alpha, alpha_u_field) - end if - - call profiler_tic(u, "element_loop-omp_overhead") + assert(has_faces(X%mesh)) + assert(has_faces(P%mesh)) + + call zero(big_m) + call zero(RHS) + + subcycle=.false. + if(present(subcycle_m)) subcycle=.true. + + if(subcycle) then + call zero(subcycle_m) + if (.not. present(subcycle_rhs)) then + FLAbort("Need to call construct_momentum_dg with both subcycle_m and subcycle_rhs") + end if + call zero(subcycle_rhs) + end if + + if(present(inverse_masslump) .and. lump_mass) then + call allocate(inverse_masslump, u%dim, u%mesh, "InverseLumpedMass") + call zero(inverse_masslump) + end if + if(present(inverse_mass) .and. .not. lump_mass) then + assert(u%mesh%continuity<0) + mass_sparsity=make_sparsity_dg_mass(u%mesh) + + if (pressure_corrected_absorption .or. has_boundary_condition(u, "dirichlet")) then + ! the diagonal blocks are different + call allocate( inverse_mass, mass_sparsity, (/ u%dim, u%dim /), & + diagonal=.true., name="InverseMassMatrix") + else + ! diagonal blocks are the same and all point to the same memory + call allocate( inverse_mass, mass_sparsity, (/ u%dim, u%dim /), & + diagonal=.true., equal_diagonal_blocks=.true., name="InverseMassMatrix") + end if + ! Drop the extra reference to sparsity. + call deallocate(mass_sparsity) + end if + + ! get bc type and values on entire surface mesh + ! numbering of types, determined by ordering here, i.e. + ! weakdirichlet=1, free_surface=2 + allocate(velocity_bc_type(U%dim, surface_element_count(U))) + call get_entire_boundary_condition(U, (/ & + "weakdirichlet ", & + "free_surface ", & + "no_normal_flow ", & + "turbine_flux_penalty", & + "turbine_flux_dg " /), velocity_bc, velocity_bc_type) + + ! the turbine connectivity mesh is only needed if one of the boundaries is a turbine. + if (any(velocity_bc_type==4) .or. any(velocity_bc_type==5)) then + turbine_conn_mesh=get_periodic_mesh(state, u%mesh) + end if + + ! same for pressure + allocate(pressure_bc_type(surface_element_count(P))) + call get_entire_boundary_condition(P, (/ & + "weakdirichlet", & + "dirichlet "/), pressure_bc, pressure_bc_type) + have_pressure_bc = any(pressure_bc_type>0) + + if (have_wd_abs) then + if (.not. has_scalar_field(state, "WettingDryingAlpha")) then + FLExit("Wetting and drying needs the diagnostic field WettingDryingAlpha activated.") + end if + ! The alpha fields lives on the pressure mesh, but we need it on the velocity, so let's remap it. + wettingdrying_alpha => extract_scalar_field(state, "WettingDryingAlpha") + call allocate(alpha_u_field, u%mesh, "alpha_u") + call remap_field(wettingdrying_alpha, alpha_u_field) + end if + + call profiler_tic(u, "element_loop-omp_overhead") #ifdef _OPENMP - num_threads = omp_get_max_threads() + num_threads = omp_get_max_threads() #else - num_threads=1 + num_threads=1 #endif - if (have_viscosity) then - call get_mesh_colouring(state, u%mesh, COLOURING_DG2, colours) - else - call get_mesh_colouring(state, u%mesh, COLOURING_DG0, colours) - end if + if (have_viscosity) then + call get_mesh_colouring(state, u%mesh, COLOURING_DG2, colours) + else + call get_mesh_colouring(state, u%mesh, COLOURING_DG0, colours) + end if #ifdef _OPENMP - cache_valid = prepopulate_transform_cache(X) - if (have_coriolis) then - call set_coriolis_parameters - end if + cache_valid = prepopulate_transform_cache(X) + if (have_coriolis) then + call set_coriolis_parameters + end if #endif - call profiler_toc(u, "element_loop-omp_overhead") + call profiler_toc(u, "element_loop-omp_overhead") - call profiler_tic(u, "element_loop") + call profiler_tic(u, "element_loop") - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(clr, nnid, ele, len) + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(clr, nnid, ele, len) - colour_loop: do clr = 1, size(colours) - len = key_count(colours(clr)) + colour_loop: do clr = 1, size(colours) + len = key_count(colours(clr)) - !$OMP DO SCHEDULE(STATIC) - element_loop: do nnid = 1, len - ele = fetch(colours(clr), nnid) - call construct_momentum_element_dg(ele, big_m, rhs, & + !$OMP DO SCHEDULE(STATIC) + element_loop: do nnid = 1, len + ele = fetch(colours(clr), nnid) + call construct_momentum_element_dg(ele, big_m, rhs, & & X, U, advecting_velocity, U_mesh, X_old, X_new, & & Source, Buoyancy, hb_density, hb_pressure, gravity, Abs, Viscosity, & & swe_bottom_drag, swe_u_nl, & @@ -765,2883 +765,2883 @@ subroutine construct_momentum_dg(u, p, rho, x, & & eddy_visc=eddy_visc, prescribed_filter_width=prescribed_filter_width, & & distance_to_wall=distance_to_wall, y_plus_debug=y_plus_debug, & & les_filter_width_debug=les_filter_width_debug) - end do element_loop - !$OMP END DO - - end do colour_loop - !$OMP END PARALLEL - - call profiler_toc(u, "element_loop") - - if (have_wd_abs) then - ! the remapped field is not needed anymore. - call deallocate(alpha_u_field) - ! deallocate(alpha_u_field) - call deallocate(Abs_wd) - end if - - if (present(inverse_masslump) .and. lump_mass) then - call apply_dirichlet_conditions_inverse_mass(inverse_masslump, u) - ewrite_minmax(inverse_masslump) - end if - if (present(inverse_mass) .and. .not. lump_mass) then - call apply_dirichlet_conditions_inverse_mass(inverse_mass, u) - ewrite_minmax(inverse_mass) - end if - ewrite_minmax(rhs) - - if (associated(eddy_visc)) then - ! eddy visc is calculated in momentum_dg element loop. we need to do a halo_update - call halo_update(eddy_visc) - end if - - ! Drop the reference to the fields we may have made. - call deallocate(Viscosity) - call deallocate(Abs) - call deallocate(Source) - call deallocate(U_nl) - call deallocate(velocity_bc) - call deallocate(pressure_bc) - deallocate(velocity_bc_type) - deallocate(pressure_bc_type) - call deallocate(surfacetension) - call deallocate(buoyancy) - call deallocate(gravity) - if(multiphase) then - call deallocate(nvfrac) - end if - call deallocate(dummyscalar) - deallocate(dummyscalar) - - ewrite(1, *) "Exiting construct_momentum_dg" - - call profiler_toc("construct_momentum_dg") - - end subroutine construct_momentum_dg - - subroutine construct_momentum_element_dg(ele, big_m, rhs, & - &X, U, U_nl, U_mesh, X_old, X_new, Source, Buoyancy, hb_density, hb_pressure, gravity, Abs, & - &Viscosity, swe_bottom_drag, swe_u_nl, P, old_pressure, Rho, surfacetension, q_mesh, & - &velocity_bc, velocity_bc_type, & - &pressure_bc, pressure_bc_type, & - &turbine_conn_mesh, depth, have_wd_abs, alpha_u_field, Abs_wd, & - &vvr_sf, ib_min_grad, nvfrac, & - &inverse_mass, inverse_masslump, mass, subcycle_m, subcycle_rhs, partial_stress, & - &smagorinsky_coefficient, eddy_visc, prescribed_filter_width, distance_to_wall, & - &y_plus_debug, les_filter_width_debug) - - !!< Construct the momentum equation for discontinuous elements in - !!< acceleration form. - implicit none - !! Index of current element - integer :: ele - !! Main momentum matrix. - type(petsc_csr_matrix), intent(inout) :: big_m - !! Momentum right hand side vector for each point. - type(vector_field), intent(inout) :: rhs - !! Auxiliary variable mesh - type(mesh_type), intent(in) :: q_mesh - type(mesh_type), intent(in) :: turbine_conn_mesh - !! - type(block_csr_matrix), intent(inout), optional :: subcycle_m - type(vector_field), intent(inout), optional :: subcycle_rhs - - !! Position, velocity and source fields. - type(scalar_field), intent(in) :: buoyancy - type(vector_field), intent(in) :: X, U, U_nl, Source, gravity, Abs - type(vector_field), pointer :: U_mesh, X_old, X_new - !! Viscosity - type(tensor_field) :: Viscosity - type(scalar_field) :: P, Rho - type(scalar_field), intent(in) :: hb_density, hb_pressure - !! surfacetension - type(tensor_field) :: surfacetension - !! field containing the bc values of velocity - type(vector_field), intent(in) :: velocity_bc - !! array of the type of bc (see get_entire_boundary_condition call above) - integer, dimension(:,:), intent(in) :: velocity_bc_type - !! same for pressure - type(scalar_field), intent(in) :: pressure_bc - integer, dimension(:), intent(in) :: pressure_bc_type - !! fields only used for swe bottom drag (otherwise unitialised) - type(scalar_field), intent(in) :: swe_bottom_drag, old_pressure - type(vector_field), intent(in) :: swe_u_nl - - !! Inverse mass matrix - type(block_csr_matrix), intent(inout), optional :: inverse_mass - !! Mass lumping for each point - type(vector_field), intent(inout), optional :: inverse_masslump - !! Optional separate mass matrix. - type(csr_matrix), intent(inout), optional :: mass - logical, intent(in) :: have_wd_abs !! Wetting and drying switch, if TRUE, alpha_u_field must be passed as well - type(scalar_field), intent(in) :: alpha_u_field - type(vector_field), intent(in) :: Abs_wd - - ! Bilinear forms. - real, dimension(ele_loc(U,ele), ele_loc(U,ele)) :: & + end do element_loop + !$OMP END DO + + end do colour_loop + !$OMP END PARALLEL + + call profiler_toc(u, "element_loop") + + if (have_wd_abs) then + ! the remapped field is not needed anymore. + call deallocate(alpha_u_field) + ! deallocate(alpha_u_field) + call deallocate(Abs_wd) + end if + + if (present(inverse_masslump) .and. lump_mass) then + call apply_dirichlet_conditions_inverse_mass(inverse_masslump, u) + ewrite_minmax(inverse_masslump) + end if + if (present(inverse_mass) .and. .not. lump_mass) then + call apply_dirichlet_conditions_inverse_mass(inverse_mass, u) + ewrite_minmax(inverse_mass) + end if + ewrite_minmax(rhs) + + if (associated(eddy_visc)) then + ! eddy visc is calculated in momentum_dg element loop. we need to do a halo_update + call halo_update(eddy_visc) + end if + + ! Drop the reference to the fields we may have made. + call deallocate(Viscosity) + call deallocate(Abs) + call deallocate(Source) + call deallocate(U_nl) + call deallocate(velocity_bc) + call deallocate(pressure_bc) + deallocate(velocity_bc_type) + deallocate(pressure_bc_type) + call deallocate(surfacetension) + call deallocate(buoyancy) + call deallocate(gravity) + if(multiphase) then + call deallocate(nvfrac) + end if + call deallocate(dummyscalar) + deallocate(dummyscalar) + + ewrite(1, *) "Exiting construct_momentum_dg" + + call profiler_toc("construct_momentum_dg") + + end subroutine construct_momentum_dg + + subroutine construct_momentum_element_dg(ele, big_m, rhs, & + &X, U, U_nl, U_mesh, X_old, X_new, Source, Buoyancy, hb_density, hb_pressure, gravity, Abs, & + &Viscosity, swe_bottom_drag, swe_u_nl, P, old_pressure, Rho, surfacetension, q_mesh, & + &velocity_bc, velocity_bc_type, & + &pressure_bc, pressure_bc_type, & + &turbine_conn_mesh, depth, have_wd_abs, alpha_u_field, Abs_wd, & + &vvr_sf, ib_min_grad, nvfrac, & + &inverse_mass, inverse_masslump, mass, subcycle_m, subcycle_rhs, partial_stress, & + &smagorinsky_coefficient, eddy_visc, prescribed_filter_width, distance_to_wall, & + &y_plus_debug, les_filter_width_debug) + + !!< Construct the momentum equation for discontinuous elements in + !!< acceleration form. + implicit none + !! Index of current element + integer :: ele + !! Main momentum matrix. + type(petsc_csr_matrix), intent(inout) :: big_m + !! Momentum right hand side vector for each point. + type(vector_field), intent(inout) :: rhs + !! Auxiliary variable mesh + type(mesh_type), intent(in) :: q_mesh + type(mesh_type), intent(in) :: turbine_conn_mesh + !! + type(block_csr_matrix), intent(inout), optional :: subcycle_m + type(vector_field), intent(inout), optional :: subcycle_rhs + + !! Position, velocity and source fields. + type(scalar_field), intent(in) :: buoyancy + type(vector_field), intent(in) :: X, U, U_nl, Source, gravity, Abs + type(vector_field), pointer :: U_mesh, X_old, X_new + !! Viscosity + type(tensor_field) :: Viscosity + type(scalar_field) :: P, Rho + type(scalar_field), intent(in) :: hb_density, hb_pressure + !! surfacetension + type(tensor_field) :: surfacetension + !! field containing the bc values of velocity + type(vector_field), intent(in) :: velocity_bc + !! array of the type of bc (see get_entire_boundary_condition call above) + integer, dimension(:,:), intent(in) :: velocity_bc_type + !! same for pressure + type(scalar_field), intent(in) :: pressure_bc + integer, dimension(:), intent(in) :: pressure_bc_type + !! fields only used for swe bottom drag (otherwise unitialised) + type(scalar_field), intent(in) :: swe_bottom_drag, old_pressure + type(vector_field), intent(in) :: swe_u_nl + + !! Inverse mass matrix + type(block_csr_matrix), intent(inout), optional :: inverse_mass + !! Mass lumping for each point + type(vector_field), intent(inout), optional :: inverse_masslump + !! Optional separate mass matrix. + type(csr_matrix), intent(inout), optional :: mass + logical, intent(in) :: have_wd_abs !! Wetting and drying switch, if TRUE, alpha_u_field must be passed as well + type(scalar_field), intent(in) :: alpha_u_field + type(vector_field), intent(in) :: Abs_wd + + ! Bilinear forms. + real, dimension(ele_loc(U,ele), ele_loc(U,ele)) :: & Coriolis_mat, rho_mat, rho_move_mat, mass_mat - real, dimension(ele_loc(U,ele), ele_loc(U,ele)) :: & + real, dimension(ele_loc(U,ele), ele_loc(U,ele)) :: & inverse_mass_mat - real, dimension(mesh_dim(U), ele_loc(U,ele), & + real, dimension(mesh_dim(U), ele_loc(U,ele), & ele_loc(U,ele)) :: ele2grad_mat - real, dimension(ele_loc(U,ele), ele_loc(U,ele)) :: & + real, dimension(ele_loc(U,ele), ele_loc(U,ele)) :: & Advection_mat - real, dimension(ele_loc(U,ele), ele_loc(Source,ele)) :: & + real, dimension(ele_loc(U,ele), ele_loc(Source,ele)) :: & Source_mat - real, dimension(U%dim, ele_loc(U,ele), ele_loc(U,ele)) :: & + real, dimension(U%dim, ele_loc(U,ele), ele_loc(U,ele)) :: & Abs_mat - real, dimension(U%dim, U%dim, ele_loc(U,ele), ele_loc(U,ele)) :: & + real, dimension(U%dim, U%dim, ele_loc(U,ele), ele_loc(U,ele)) :: & Abs_mat_sphere - real, dimension(U%dim, ele_loc(U,ele)) :: & + real, dimension(U%dim, ele_loc(U,ele)) :: & Abs_lump - real, dimension(U%dim, U%dim, ele_loc(U,ele)) :: & + real, dimension(U%dim, U%dim, ele_loc(U,ele)) :: & Abs_lump_sphere - real, dimension(ele_loc(U,ele)) :: & + real, dimension(ele_loc(U,ele)) :: & source_lump - real, dimension(ele_loc(q_mesh,ele), ele_loc(q_mesh,ele)) :: Q_inv - real, dimension(U%dim, ele_loc(q_mesh,ele), ele_and_faces_loc(U,ele)) ::& - & Grad_u_mat_q, Div_u_mat_q - real, dimension(U%dim,U%dim,ele_and_faces_loc(U,ele),ele_and_faces_loc(U,ele)) ::& - & Viscosity_mat - real, dimension(Viscosity%dim(1), Viscosity%dim(2), & - & ele_loc(Viscosity,ele)) :: Viscosity_ele - real, dimension(x%dim, ele_loc(x,ele)) :: x_val, x_val_2 - real, dimension(u%dim, ele_loc(u,ele)) :: u_val - - ! \Int_{ele} N_i kappa N_j dV, used for CDG fluxes - real, dimension(mesh_dim(U),mesh_dim(U), & - & ele_loc(U,ele),ele_loc(U,ele)) :: kappa_mat - - ! Local assembly matrices. - real, dimension(ele_loc(U,ele)) :: l_MassLump, l_move_masslump - - ! Local node number map for 2nd order element. - integer, dimension(ele_and_faces_loc(U,ele)) :: local_glno - - ! Local variables. - - ! Neighbour element, face, neighbour face, no. internal element nodes - integer :: ele_2, ele_2_X, face, face_2, loc - ! Count variable for loops over dimension. - integer :: dim, dim1, dim2, dim3, dim4 - ! Loops over faces. - integer :: ni - ! Array bounds for faces of the 2nd order element. - integer :: start, finish - - ! Variable transform times quadrature weights. - real, dimension(ele_ngi(U,ele)) :: detwei, detwei_old, detwei_new, coefficient_detwei - ! Transformed gradient function for velocity. - real, dimension(ele_loc(U, ele), ele_ngi(U, ele), mesh_dim(U)) :: du_t - ! Transformed gradient function for grid velocity. - real, dimension(ele_loc(X, ele), ele_ngi(U, ele), mesh_dim(U)) :: dug_t - ! Transformed gradient function for auxiliary variable. - real, dimension(ele_loc(q_mesh,ele), ele_ngi(q_mesh,ele), mesh_dim(U)) :: dq_t - ! Density at quadrature points. - real, dimension(ele_ngi(U_nl, ele)) :: Rho_q - ! Coriolis magnitude and sign at quadrature points. - real, dimension(ele_ngi(U_nl, ele)) :: Coriolis_q - ! Different velocities at quad points. - real, dimension(U%dim, ele_ngi(U_nl, ele)) :: u_nl_q - real, dimension(ele_ngi(U_nl, ele)) :: u_nl_div_q - - ! surface tension terms - real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: tension - real, dimension(u%dim, ele_ngi(u, ele)) :: dtensiondj - - ! Node and shape pointers. - integer, dimension(:), pointer :: u_ele, p_ele - type(element_type), pointer :: u_shape, p_shape, q_shape - ! Neighbours of this element. - integer, dimension(:), pointer :: neigh, X_neigh - ! Whether the velocity field is continuous and if it is piecewise constant. - logical :: dg, p0 - integer :: i - logical :: boundary_element, turbine_face - - ! What we will be adding to the matrix and RHS - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(u%dim, ele_and_faces_loc(U,ele)) :: big_m_diag_addto,& - & rhs_addto - ! rhs terms for subcycling coming from advection bc terms - real, dimension(u%dim, ele_loc(U, ele)) :: subcycle_rhs_addto - - real, dimension(u%dim, u%dim, ele_and_faces_loc(U,ele), ele_and_faces_loc(U,ele)) :: big_m_tensor_addto - logical, dimension(u%dim, u%dim) :: diagonal_block_mask, off_diagonal_block_mask - ! Addto matrices for when subcycling is performed - real, dimension(u%dim, u%dim, ele_and_faces_loc(U,ele), & + real, dimension(ele_loc(q_mesh,ele), ele_loc(q_mesh,ele)) :: Q_inv + real, dimension(U%dim, ele_loc(q_mesh,ele), ele_and_faces_loc(U,ele)) ::& + & Grad_u_mat_q, Div_u_mat_q + real, dimension(U%dim,U%dim,ele_and_faces_loc(U,ele),ele_and_faces_loc(U,ele)) ::& + & Viscosity_mat + real, dimension(Viscosity%dim(1), Viscosity%dim(2), & + & ele_loc(Viscosity,ele)) :: Viscosity_ele + real, dimension(x%dim, ele_loc(x,ele)) :: x_val, x_val_2 + real, dimension(u%dim, ele_loc(u,ele)) :: u_val + + ! \Int_{ele} N_i kappa N_j dV, used for CDG fluxes + real, dimension(mesh_dim(U),mesh_dim(U), & + & ele_loc(U,ele),ele_loc(U,ele)) :: kappa_mat + + ! Local assembly matrices. + real, dimension(ele_loc(U,ele)) :: l_MassLump, l_move_masslump + + ! Local node number map for 2nd order element. + integer, dimension(ele_and_faces_loc(U,ele)) :: local_glno + + ! Local variables. + + ! Neighbour element, face, neighbour face, no. internal element nodes + integer :: ele_2, ele_2_X, face, face_2, loc + ! Count variable for loops over dimension. + integer :: dim, dim1, dim2, dim3, dim4 + ! Loops over faces. + integer :: ni + ! Array bounds for faces of the 2nd order element. + integer :: start, finish + + ! Variable transform times quadrature weights. + real, dimension(ele_ngi(U,ele)) :: detwei, detwei_old, detwei_new, coefficient_detwei + ! Transformed gradient function for velocity. + real, dimension(ele_loc(U, ele), ele_ngi(U, ele), mesh_dim(U)) :: du_t + ! Transformed gradient function for grid velocity. + real, dimension(ele_loc(X, ele), ele_ngi(U, ele), mesh_dim(U)) :: dug_t + ! Transformed gradient function for auxiliary variable. + real, dimension(ele_loc(q_mesh,ele), ele_ngi(q_mesh,ele), mesh_dim(U)) :: dq_t + ! Density at quadrature points. + real, dimension(ele_ngi(U_nl, ele)) :: Rho_q + ! Coriolis magnitude and sign at quadrature points. + real, dimension(ele_ngi(U_nl, ele)) :: Coriolis_q + ! Different velocities at quad points. + real, dimension(U%dim, ele_ngi(U_nl, ele)) :: u_nl_q + real, dimension(ele_ngi(U_nl, ele)) :: u_nl_div_q + + ! surface tension terms + real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: tension + real, dimension(u%dim, ele_ngi(u, ele)) :: dtensiondj + + ! Node and shape pointers. + integer, dimension(:), pointer :: u_ele, p_ele + type(element_type), pointer :: u_shape, p_shape, q_shape + ! Neighbours of this element. + integer, dimension(:), pointer :: neigh, X_neigh + ! Whether the velocity field is continuous and if it is piecewise constant. + logical :: dg, p0 + integer :: i + logical :: boundary_element, turbine_face + + ! What we will be adding to the matrix and RHS - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(u%dim, ele_and_faces_loc(U,ele)) :: big_m_diag_addto,& + & rhs_addto + ! rhs terms for subcycling coming from advection bc terms + real, dimension(u%dim, ele_loc(U, ele)) :: subcycle_rhs_addto + + real, dimension(u%dim, u%dim, ele_and_faces_loc(U,ele), ele_and_faces_loc(U,ele)) :: big_m_tensor_addto + logical, dimension(u%dim, u%dim) :: diagonal_block_mask, off_diagonal_block_mask + ! Addto matrices for when subcycling is performed + real, dimension(u%dim, u%dim, ele_and_faces_loc(U,ele), & ele_and_faces_loc(U,ele)) :: subcycle_m_tensor_addto - !Switch to select if we are assembling the primal or dual form - logical :: primal - - ! In parallel, we assemble terms on elements we own, and those in - ! the L1 element halo - logical :: assemble_element - - ! Absorption matrices - real, dimension(u%dim, ele_ngi(u, ele)) :: absorption_gi - real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: tensor_absorption_gi - - ! Add vertical velocity relaxation to the absorption if present - real, intent(in) :: vvr_sf - real, dimension(u%dim,u%dim,ele_ngi(u,ele)) :: vvr_abs - real, dimension(u%dim,ele_ngi(u,ele)) :: vvr_abs_diag - real, dimension(ele_ngi(u,ele)) :: depth_at_quads - type(scalar_field), intent(in) :: depth - - ! Add implicit buoyancy to the absorption if present - real, intent(in) :: ib_min_grad - real, dimension(u%dim,u%dim,ele_ngi(u,ele)) :: ib_abs - real, dimension(u%dim,ele_ngi(u,ele)) :: ib_abs_diag - real, dimension(ele_loc(u,ele),ele_ngi(u,ele),mesh_dim(u)) :: dt_rho - real, dimension(u%dim,ele_ngi(u,ele)) :: grav_at_quads - real, dimension(u%dim, ele_ngi(u,ele)) :: grad_rho - real, dimension(ele_ngi(u,ele)) :: drho_dz - - ! Non-linear approximation to the PhaseVolumeFraction field - type(scalar_field), intent(in) :: nvfrac - type(element_type), pointer :: nvfrac_shape - ! Transformed gradient function for the non-linear PhaseVolumeFraction. - real, dimension(:, :, :), allocatable :: dnvfrac_t - ! nvfrac at quadrature points. - real, dimension(ele_ngi(u, ele)) :: nvfrac_gi, u_nl_dot_grad_nvfrac_gi - real, dimension(u%dim, ele_ngi(u, ele)) :: grad_nvfrac_gi - - ! element centre and neighbour centre - ! for IP parameters - - real, dimension(mesh_dim(U)) :: ele_centre, neigh_centre, & - & face_centre, face_centre_2 - real :: turbine_fluxfac - - real, dimension(ele_ngi(u,ele)) :: alpha_u_quad - - ! added for partial stress form (sp911) - logical, intent(in) :: partial_stress - - ! LES - sp911 - real, intent(in) :: smagorinsky_coefficient - type(scalar_field), pointer, intent(inout) :: eddy_visc, y_plus_debug, & - & les_filter_width_debug - type(scalar_field), pointer, intent(in) :: prescribed_filter_width, distance_to_wall - - dg=continuity(U)<0 - p0=(element_degree(u,ele)==0) - - ! In parallel, we construct terms on elements we own and those in - ! the L1 element halo. - ! Note that element_neighbour_owned(U, ele) may return .false. if - ! ele is owned. For example, if ele is the only owned element on - ! this process. Hence we have to check for element ownership - ! directly as well. - assemble_element = .not.dg.or.element_neighbour_owned(U, ele).or.element_owned(U, ele) - - primal = .not.dg - if(viscosity_scheme == CDG) primal = .true. - if(viscosity_scheme == IP) primal =.true. - - if(p0) then - assert(dg) - end if - if(move_mesh) then - ! In the declarations above we've assumed these - ! so that U_mesh doesn't always have to be - ! present - assert(ele_loc(U_mesh, ele)==ele_loc(X, ele)) - assert(ele_ngi(U_mesh, ele)==ele_ngi(U, ele)) - assert(mesh_dim(U_mesh)==mesh_dim(U)) - end if - - big_m_diag_addto = 0.0 - big_m_tensor_addto = 0.0 - rhs_addto = 0.0 - if(subcycle) then - subcycle_m_tensor_addto = 0.0 - subcycle_rhs_addto = 0.0 - end if - - diagonal_block_mask = .false. - do dim = 1, u%dim - diagonal_block_mask(dim, dim) = .true. - end do - - off_diagonal_block_mask = .not. diagonal_block_mask - - !---------------------------------------------------------------------- - ! Establish local node lists - !---------------------------------------------------------------------- - - u_ele=>ele_nodes(U,ele) ! Velocity - p_ele=>ele_nodes(P,ele) ! Pressure - - loc = ele_loc(u, ele) - - local_glno=0 - local_glno(:loc)=u_ele ! Viscosity node list - - !---------------------------------------------------------------------- - ! Establish local shape functions - !---------------------------------------------------------------------- - - u_shape=>ele_shape(U,ele) - p_shape=>ele_shape(P,ele) - q_shape=>ele_shape(q_mesh, ele) - - x_val = ele_val(X,ele) - - ! Transform U derivatives and weights into physical space. - if(.not.p0) then - call transform_to_physical(X, ele,& - & u_shape , dshape=du_t, detwei=detwei) - else - call transform_to_physical(X, ele, & - & detwei=detwei) - du_t = 0.0 - end if - - if(move_mesh) then - call transform_to_physical(X_old, ele, & - & detwei=detwei_old) - call transform_to_physical(X_new, ele, & - & detwei=detwei_new) - if(have_advection.and..not.integrate_by_parts_once) then - call transform_to_physical(X, ele, & - & ele_shape(U_mesh, ele), dshape = dug_t) - end if - end if + !Switch to select if we are assembling the primal or dual form + logical :: primal + + ! In parallel, we assemble terms on elements we own, and those in + ! the L1 element halo + logical :: assemble_element + + ! Absorption matrices + real, dimension(u%dim, ele_ngi(u, ele)) :: absorption_gi + real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: tensor_absorption_gi + + ! Add vertical velocity relaxation to the absorption if present + real, intent(in) :: vvr_sf + real, dimension(u%dim,u%dim,ele_ngi(u,ele)) :: vvr_abs + real, dimension(u%dim,ele_ngi(u,ele)) :: vvr_abs_diag + real, dimension(ele_ngi(u,ele)) :: depth_at_quads + type(scalar_field), intent(in) :: depth + + ! Add implicit buoyancy to the absorption if present + real, intent(in) :: ib_min_grad + real, dimension(u%dim,u%dim,ele_ngi(u,ele)) :: ib_abs + real, dimension(u%dim,ele_ngi(u,ele)) :: ib_abs_diag + real, dimension(ele_loc(u,ele),ele_ngi(u,ele),mesh_dim(u)) :: dt_rho + real, dimension(u%dim,ele_ngi(u,ele)) :: grav_at_quads + real, dimension(u%dim, ele_ngi(u,ele)) :: grad_rho + real, dimension(ele_ngi(u,ele)) :: drho_dz + + ! Non-linear approximation to the PhaseVolumeFraction field + type(scalar_field), intent(in) :: nvfrac + type(element_type), pointer :: nvfrac_shape + ! Transformed gradient function for the non-linear PhaseVolumeFraction. + real, dimension(:, :, :), allocatable :: dnvfrac_t + ! nvfrac at quadrature points. + real, dimension(ele_ngi(u, ele)) :: nvfrac_gi, u_nl_dot_grad_nvfrac_gi + real, dimension(u%dim, ele_ngi(u, ele)) :: grad_nvfrac_gi + + ! element centre and neighbour centre + ! for IP parameters + + real, dimension(mesh_dim(U)) :: ele_centre, neigh_centre, & + & face_centre, face_centre_2 + real :: turbine_fluxfac + + real, dimension(ele_ngi(u,ele)) :: alpha_u_quad + + ! added for partial stress form (sp911) + logical, intent(in) :: partial_stress + + ! LES - sp911 + real, intent(in) :: smagorinsky_coefficient + type(scalar_field), pointer, intent(inout) :: eddy_visc, y_plus_debug, & + & les_filter_width_debug + type(scalar_field), pointer, intent(in) :: prescribed_filter_width, distance_to_wall + + dg=continuity(U)<0 + p0=(element_degree(u,ele)==0) + + ! In parallel, we construct terms on elements we own and those in + ! the L1 element halo. + ! Note that element_neighbour_owned(U, ele) may return .false. if + ! ele is owned. For example, if ele is the only owned element on + ! this process. Hence we have to check for element ownership + ! directly as well. + assemble_element = .not.dg.or.element_neighbour_owned(U, ele).or.element_owned(U, ele) + + primal = .not.dg + if(viscosity_scheme == CDG) primal = .true. + if(viscosity_scheme == IP) primal =.true. - if(have_viscosity.and.(.not.(q_mesh==u%mesh))) then - ! Transform q derivatives into physical space. - call transform_to_physical(X, ele,& - & q_shape , dshape=dq_t) - else - dq_t=du_t - end if + if(p0) then + assert(dg) + end if + if(move_mesh) then + ! In the declarations above we've assumed these + ! so that U_mesh doesn't always have to be + ! present + assert(ele_loc(U_mesh, ele)==ele_loc(X, ele)) + assert(ele_ngi(U_mesh, ele)==ele_ngi(U, ele)) + assert(mesh_dim(U_mesh)==mesh_dim(U)) + end if - !---------------------------------------------------------------------- - ! Construct element-wise quantities. - !---------------------------------------------------------------------- + big_m_diag_addto = 0.0 + big_m_tensor_addto = 0.0 + rhs_addto = 0.0 + if(subcycle) then + subcycle_m_tensor_addto = 0.0 + subcycle_rhs_addto = 0.0 + end if - Rho_q=ele_val_at_quad(Rho, ele) + diagonal_block_mask = .false. + do dim = 1, u%dim + diagonal_block_mask(dim, dim) = .true. + end do - if(multiphase) then - allocate(dnvfrac_t(ele_loc(nvfrac%mesh,ele), ele_ngi(nvfrac%mesh,ele), mesh_dim(u))) + off_diagonal_block_mask = .not. diagonal_block_mask - ! If the Velocity and PhaseVolumeFraction meshes are different, then we need to - ! compute the derivatives of the PhaseVolumeFraction shape functions. - if(.not.(nvfrac%mesh == u%mesh)) then - nvfrac_shape => ele_shape(nvfrac%mesh, ele) - call transform_to_physical(X, ele, nvfrac_shape, dshape=dnvfrac_t) - else - dnvfrac_t = du_t - end if + !---------------------------------------------------------------------- + ! Establish local node lists + !---------------------------------------------------------------------- - nvfrac_gi = ele_val_at_quad(nvfrac, ele) - grad_nvfrac_gi = ele_grad_at_quad(nvfrac, ele, dnvfrac_t) + u_ele=>ele_nodes(U,ele) ! Velocity + p_ele=>ele_nodes(P,ele) ! Pressure - deallocate(dnvfrac_t) - end if + loc = ele_loc(u, ele) - if ((have_viscosity).and.assemble_element) then - Viscosity_ele = ele_val(Viscosity,ele) - end if + local_glno=0 + local_glno(:loc)=u_ele ! Viscosity node list - if (assemble_element) then - u_val = ele_val(u, ele) - end if + !---------------------------------------------------------------------- + ! Establish local shape functions + !---------------------------------------------------------------------- - !---------------------------------------------------------------------- - ! Construct bilinear forms. - !---------------------------------------------------------------------- + u_shape=>ele_shape(U,ele) + p_shape=>ele_shape(P,ele) + q_shape=>ele_shape(q_mesh, ele) - ! Element density matrix. - ! (compute for first component only at first, others are copied - ! when necessary) - if (move_mesh) then - ! this rho_mat (and l_masslump) is only used in the actual mass term in big_m - ! (and its derivative inverse_mass or inverse_mass_lump) - ! so should be evaluated at t+dt - rho_mat = shape_shape(u_shape, u_shape, detwei_new*Rho_q) - else + x_val = ele_val(X,ele) - if(multiphase) then - rho_mat = shape_shape(u_shape, u_shape, detwei*Rho_q*nvfrac_gi) + ! Transform U derivatives and weights into physical space. + if(.not.p0) then + call transform_to_physical(X, ele,& + & u_shape , dshape=du_t, detwei=detwei) else - rho_mat = shape_shape(u_shape, u_shape, detwei*Rho_q) - end if - - end if - l_masslump= sum(rho_mat,2) - - if(present(mass)) then - ! Return mass separately. - ! NOTE: this doesn't deal with mesh movement - call addto(mass, u_ele, u_ele, Rho_mat) - else - if(have_mass.and.assemble_element) then - if(lump_mass) then - do dim = 1, u%dim - big_m_diag_addto(dim, :loc) = big_m_diag_addto(dim, :loc) + l_masslump - end do - else - do dim = 1, u%dim - big_m_tensor_addto(dim, dim, :loc, :loc) = big_m_tensor_addto(dim, dim, :loc, :loc) + rho_mat - end do - end if - end if - if (move_mesh.and.assemble_element) then - ! In the unaccelerated form we solve: - ! / - ! | N^{n+1} u^{n+1}/dt - N^{n} u^n/dt + ... = f - ! / - ! so in accelerated form: - ! / - ! | N^{n+1} du + (N^{n+1}- N^{n}) u^n/dt + ... = f - ! / - ! where du=(u^{n+1}-u^{n})/dt is the acceleration. - ! Put the (N^{n+1}-N^{n}) u^n term on the rhs - rho_move_mat = shape_shape(u_shape, u_shape, (detwei_new-detwei_old)*Rho_q) - if(lump_mass) then - l_move_masslump= sum(rho_move_mat,2) - do dim = 1, u%dim - rhs_addto(dim,:loc) = rhs_addto(dim,:loc) - l_move_masslump*u_val(dim,:)/dt - end do - else - do dim = 1, u%dim - rhs_addto(dim,:loc) = rhs_addto(dim,:loc) - matmul(rho_move_mat, u_val(dim,:))/dt - end do - end if - end if - end if - - if(have_coriolis.and.(rhs%dim>1).and.assemble_element) then - Coriolis_q=coriolis(ele_val_at_quad(X,ele)) - - ! Element Coriolis parameter matrix. - Coriolis_mat = shape_shape(u_shape, u_shape, Rho_q*Coriolis_q*detwei) - - ! cross terms in U_ and V_ for coriolis - big_m_tensor_addto(U_, V_, :loc, :loc) = big_m_tensor_addto(U_, V_, :loc, :loc) - dt*theta*coriolis_mat - big_m_tensor_addto(V_, U_, :loc, :loc) = big_m_tensor_addto(V_, U_, :loc, :loc) + dt*theta*coriolis_mat - - rhs_addto(U_, :loc) = rhs_addto(U_, :loc) + matmul(coriolis_mat, u_val(V_,:)) - rhs_addto(V_, :loc) = rhs_addto(V_, :loc) - matmul(coriolis_mat, u_val(U_,:)) - end if - - if(have_advection.and.(.not.p0).and.assemble_element) then - ! Advecting velocity at quadrature points. - U_nl_q=ele_val_at_quad(U_nl,ele) - - if(integrate_conservation_term_by_parts) then - - if(multiphase) then - ! Element advection matrix - ! / / - ! - beta | (grad T dot U_nl) T Rho vfrac dV + (1. - beta) | T (vfrac U_nl dot grad T) Rho dV - ! / / - Advection_mat = -beta*dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q*nvfrac_gi) & - + (1.-beta)*shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q*nvfrac_gi) - else - ! Element advection matrix - ! / / - ! - beta | (grad T dot U_nl) T Rho dV + (1. - beta) | T (U_nl dot grad T) Rho dV - ! / / - Advection_mat = -beta*dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q) & - + (1.-beta)*shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q) - end if - - if(move_mesh) then - if(integrate_by_parts_once) then - Advection_mat = Advection_mat & - + dshape_dot_vector_shape(du_t, ele_val_at_quad(U_mesh,ele), u_shape, detwei * Rho_q) - else - Advection_mat = Advection_mat & - - shape_vector_dot_dshape(u_shape, ele_val_at_quad(U_mesh,ele), du_t, detwei * Rho_q) & - - shape_shape(u_shape, u_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei * Rho_q) - end if - end if + call transform_to_physical(X, ele, & + & detwei=detwei) + du_t = 0.0 + end if + + if(move_mesh) then + call transform_to_physical(X_old, ele, & + & detwei=detwei_old) + call transform_to_physical(X_new, ele, & + & detwei=detwei_new) + if(have_advection.and..not.integrate_by_parts_once) then + call transform_to_physical(X, ele, & + & ele_shape(U_mesh, ele), dshape = dug_t) + end if + end if + + if(have_viscosity.and.(.not.(q_mesh==u%mesh))) then + ! Transform q derivatives into physical space. + call transform_to_physical(X, ele,& + & q_shape , dshape=dq_t) else - ! Introduce grid velocities - if (move_mesh) then - ! NOTE: this modifies the velocities stored at the gauss pts. - U_nl_q = U_nl_q - ele_val_at_quad(U_mesh, ele) - end if - U_nl_div_q=ele_div_at_quad(U_nl, ele, du_t) - - if(integrate_by_parts_once) then - - if(multiphase) then - ! Element advection matrix - ! / / - ! - | (grad T dot U_nl vfrac) T Rho dV - (1. - beta) | T ( div(U_nl vfrac) ) T Rho dV - ! / / - - ! We need to compute \int{T div(u_nl vfrac) T}, - ! so split up the div using the product rule and compute - ! \int{T vfrac div(u_nl) T} + \int{T u_nl grad(vfrac) T} - do i = 1, ele_ngi(u, ele) - u_nl_dot_grad_nvfrac_gi(i) = dot_product(U_nl_q(:,i), grad_nvfrac_gi(:,i)) - end do - Advection_mat = -dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q*nvfrac_gi) & - - (1.-beta) * (shape_shape(u_shape, u_shape, U_nl_div_q*detwei*Rho_q*nvfrac_gi) + & - shape_shape(u_shape, u_shape, detwei*Rho_q*u_nl_dot_grad_nvfrac_gi)) - else - ! Element advection matrix - ! / / - ! - | (grad T dot U_nl) T Rho dV - (1. - beta) | T ( div U_nl ) T Rho dV - ! / / - Advection_mat = - dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q) & - - (1.-beta) * shape_shape(u_shape, u_shape, U_nl_div_q*detwei*Rho_q) - end if - - else - - if(multiphase) then - ! Element advection matrix - ! / / - ! | T (vfrac U_nl dot grad T) Rho dV + beta | T ( div (vfrac U_nl) ) T Rho dV - ! / / - - ! We need to compute \int{T div(vfrac u_nl) T}, - ! so split up the div using the product rule and compute - ! \int{T vfrac div(u_nl) T} + \int{T u_nl grad(vfrac) T} - do i = 1, ele_ngi(u, ele) - u_nl_dot_grad_nvfrac_gi(i) = dot_product(U_nl_q(:,i), grad_nvfrac_gi(:,i)) - end do - Advection_mat = shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q*nvfrac_gi) & - + beta * (shape_shape(u_shape, u_shape, U_nl_div_q*detwei*Rho_q*nvfrac_gi) + & - shape_shape(u_shape, u_shape, detwei*Rho_q*u_nl_dot_grad_nvfrac_gi)) - else - ! Element advection matrix - ! / / - ! | T (U_nl dot grad T) Rho dV + beta | T ( div U_nl ) T Rho dV - ! / / - Advection_mat = shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q) & - + beta * shape_shape(u_shape, u_shape, U_nl_div_q * detwei*Rho_q) - end if - - if(move_mesh) then - Advection_mat = Advection_mat & - - shape_shape(u_shape, u_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei * Rho_q) - end if - end if + dq_t=du_t end if - do dim = 1, u%dim - if(subcycle) then - subcycle_m_tensor_addto(dim, dim, :loc, :loc) & - &= subcycle_m_tensor_addto(dim, dim, :loc, :loc) & - &+ advection_mat + !---------------------------------------------------------------------- + ! Construct element-wise quantities. + !---------------------------------------------------------------------- + + Rho_q=ele_val_at_quad(Rho, ele) + + if(multiphase) then + allocate(dnvfrac_t(ele_loc(nvfrac%mesh,ele), ele_ngi(nvfrac%mesh,ele), mesh_dim(u))) + + ! If the Velocity and PhaseVolumeFraction meshes are different, then we need to + ! compute the derivatives of the PhaseVolumeFraction shape functions. + if(.not.(nvfrac%mesh == u%mesh)) then + nvfrac_shape => ele_shape(nvfrac%mesh, ele) + call transform_to_physical(X, ele, nvfrac_shape, dshape=dnvfrac_t) else - big_m_tensor_addto(dim, dim, :loc, :loc) & - &= big_m_tensor_addto(dim, dim, :loc, :loc) & - &+ dt*theta*advection_mat - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) & - &- matmul(advection_mat, u_val(dim,:)) + dnvfrac_t = du_t end if - end do - end if - - if(have_source .and. assemble_element) then - ! Momentum source matrix. - Source_mat = shape_shape(U_shape, ele_shape(Source,ele), detwei*Rho_q) - if(lump_source) then - source_lump = sum(source_mat, 2) - do dim = 1, u%dim - ! lumped source - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) + source_lump*(ele_val(source, dim, ele)) - end do - else - do dim = 1, u%dim - ! nonlumped source - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) + matmul(source_mat, ele_val(source, dim, ele)) - end do + nvfrac_gi = ele_val_at_quad(nvfrac, ele) + grad_nvfrac_gi = ele_grad_at_quad(nvfrac, ele, dnvfrac_t) + + deallocate(dnvfrac_t) end if - end if - if(have_gravity .and. assemble_element) then - ! buoyancy - if(subtract_out_reference_profile) then - coefficient_detwei = detwei*gravity_magnitude*(ele_val_at_quad(buoyancy, ele)-ele_val_at_quad(hb_density, ele)) - else - coefficient_detwei = detwei*gravity_magnitude*ele_val_at_quad(buoyancy, ele) + if ((have_viscosity).and.assemble_element) then + Viscosity_ele = ele_val(Viscosity,ele) + end if + + if (assemble_element) then + u_val = ele_val(u, ele) end if - if (radial_gravity) then - ! If we're using a radial gravity, evaluate the direction of the gravity vector - ! exactly at quadrature points. - rhs_addto(:, :loc) = rhs_addto(:, :loc) + shape_vector_rhs(u_shape, & - radial_inward_normal_at_quad_ele(X, ele), & - coefficient_detwei) + !---------------------------------------------------------------------- + ! Construct bilinear forms. + !---------------------------------------------------------------------- + + ! Element density matrix. + ! (compute for first component only at first, others are copied + ! when necessary) + if (move_mesh) then + ! this rho_mat (and l_masslump) is only used in the actual mass term in big_m + ! (and its derivative inverse_mass or inverse_mass_lump) + ! so should be evaluated at t+dt + rho_mat = shape_shape(u_shape, u_shape, detwei_new*Rho_q) else - if(multiphase) then - rhs_addto(:, :loc) = rhs_addto(:, :loc) + shape_vector_rhs(u_shape, & - ele_val_at_quad(gravity, ele), & - coefficient_detwei*nvfrac_gi) - else - rhs_addto(:, :loc) = rhs_addto(:, :loc) + shape_vector_rhs(u_shape, & - ele_val_at_quad(gravity, ele), & - coefficient_detwei) - end if + if(multiphase) then + rho_mat = shape_shape(u_shape, u_shape, detwei*Rho_q*nvfrac_gi) + else + rho_mat = shape_shape(u_shape, u_shape, detwei*Rho_q) + end if end if - end if + l_masslump= sum(rho_mat,2) - if((have_absorption.or.have_vertical_stabilization.or.have_wd_abs .or. have_swe_bottom_drag) .and. & - (assemble_element .or. pressure_corrected_absorption)) then + if(present(mass)) then + ! Return mass separately. + ! NOTE: this doesn't deal with mesh movement + call addto(mass, u_ele, u_ele, Rho_mat) + else + if(have_mass.and.assemble_element) then + if(lump_mass) then + do dim = 1, u%dim + big_m_diag_addto(dim, :loc) = big_m_diag_addto(dim, :loc) + l_masslump + end do + else + do dim = 1, u%dim + big_m_tensor_addto(dim, dim, :loc, :loc) = big_m_tensor_addto(dim, dim, :loc, :loc) + rho_mat + end do + end if + end if + if (move_mesh.and.assemble_element) then + ! In the unaccelerated form we solve: + ! / + ! | N^{n+1} u^{n+1}/dt - N^{n} u^n/dt + ... = f + ! / + ! so in accelerated form: + ! / + ! | N^{n+1} du + (N^{n+1}- N^{n}) u^n/dt + ... = f + ! / + ! where du=(u^{n+1}-u^{n})/dt is the acceleration. + ! Put the (N^{n+1}-N^{n}) u^n term on the rhs + rho_move_mat = shape_shape(u_shape, u_shape, (detwei_new-detwei_old)*Rho_q) + if(lump_mass) then + l_move_masslump= sum(rho_move_mat,2) + do dim = 1, u%dim + rhs_addto(dim,:loc) = rhs_addto(dim,:loc) - l_move_masslump*u_val(dim,:)/dt + end do + else + do dim = 1, u%dim + rhs_addto(dim,:loc) = rhs_addto(dim,:loc) - matmul(rho_move_mat, u_val(dim,:))/dt + end do + end if + end if + end if + + if(have_coriolis.and.(rhs%dim>1).and.assemble_element) then + Coriolis_q=coriolis(ele_val_at_quad(X,ele)) + + ! Element Coriolis parameter matrix. + Coriolis_mat = shape_shape(u_shape, u_shape, Rho_q*Coriolis_q*detwei) - absorption_gi=0.0 - tensor_absorption_gi=0.0 - absorption_gi = ele_val_at_quad(Abs, ele) - if (on_sphere.and.have_absorption) then ! Rotate the absorption - tensor_absorption_gi=rotate_diagonal_to_sphere_gi(X, ele, absorption_gi) + ! cross terms in U_ and V_ for coriolis + big_m_tensor_addto(U_, V_, :loc, :loc) = big_m_tensor_addto(U_, V_, :loc, :loc) - dt*theta*coriolis_mat + big_m_tensor_addto(V_, U_, :loc, :loc) = big_m_tensor_addto(V_, U_, :loc, :loc) + dt*theta*coriolis_mat + + rhs_addto(U_, :loc) = rhs_addto(U_, :loc) + matmul(coriolis_mat, u_val(V_,:)) + rhs_addto(V_, :loc) = rhs_addto(V_, :loc) - matmul(coriolis_mat, u_val(U_,:)) end if - vvr_abs_diag=0.0 - vvr_abs=0.0 - ib_abs=0.0 - ib_abs_diag=0.0 + if(have_advection.and.(.not.p0).and.assemble_element) then + ! Advecting velocity at quadrature points. + U_nl_q=ele_val_at_quad(U_nl,ele) - if (have_vertical_velocity_relaxation) then + if(integrate_conservation_term_by_parts) then + + if(multiphase) then + ! Element advection matrix + ! / / + ! - beta | (grad T dot U_nl) T Rho vfrac dV + (1. - beta) | T (vfrac U_nl dot grad T) Rho dV + ! / / + Advection_mat = -beta*dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q*nvfrac_gi) & + + (1.-beta)*shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q*nvfrac_gi) + else + ! Element advection matrix + ! / / + ! - beta | (grad T dot U_nl) T Rho dV + (1. - beta) | T (U_nl dot grad T) Rho dV + ! / / + Advection_mat = -beta*dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q) & + + (1.-beta)*shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q) + end if + + if(move_mesh) then + if(integrate_by_parts_once) then + Advection_mat = Advection_mat & + + dshape_dot_vector_shape(du_t, ele_val_at_quad(U_mesh,ele), u_shape, detwei * Rho_q) + else + Advection_mat = Advection_mat & + - shape_vector_dot_dshape(u_shape, ele_val_at_quad(U_mesh,ele), du_t, detwei * Rho_q) & + - shape_shape(u_shape, u_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei * Rho_q) + end if + end if + else + ! Introduce grid velocities + if (move_mesh) then + ! NOTE: this modifies the velocities stored at the gauss pts. + U_nl_q = U_nl_q - ele_val_at_quad(U_mesh, ele) + end if + U_nl_div_q=ele_div_at_quad(U_nl, ele, du_t) + + if(integrate_by_parts_once) then + + if(multiphase) then + ! Element advection matrix + ! / / + ! - | (grad T dot U_nl vfrac) T Rho dV - (1. - beta) | T ( div(U_nl vfrac) ) T Rho dV + ! / / + + ! We need to compute \int{T div(u_nl vfrac) T}, + ! so split up the div using the product rule and compute + ! \int{T vfrac div(u_nl) T} + \int{T u_nl grad(vfrac) T} + do i = 1, ele_ngi(u, ele) + u_nl_dot_grad_nvfrac_gi(i) = dot_product(U_nl_q(:,i), grad_nvfrac_gi(:,i)) + end do + Advection_mat = -dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q*nvfrac_gi) & + - (1.-beta) * (shape_shape(u_shape, u_shape, U_nl_div_q*detwei*Rho_q*nvfrac_gi) + & + shape_shape(u_shape, u_shape, detwei*Rho_q*u_nl_dot_grad_nvfrac_gi)) + else + ! Element advection matrix + ! / / + ! - | (grad T dot U_nl) T Rho dV - (1. - beta) | T ( div U_nl ) T Rho dV + ! / / + Advection_mat = - dshape_dot_vector_shape(du_t, U_nl_q, u_shape, detwei*Rho_q) & + - (1.-beta) * shape_shape(u_shape, u_shape, U_nl_div_q*detwei*Rho_q) + end if + + else + + if(multiphase) then + ! Element advection matrix + ! / / + ! | T (vfrac U_nl dot grad T) Rho dV + beta | T ( div (vfrac U_nl) ) T Rho dV + ! / / + + ! We need to compute \int{T div(vfrac u_nl) T}, + ! so split up the div using the product rule and compute + ! \int{T vfrac div(u_nl) T} + \int{T u_nl grad(vfrac) T} + do i = 1, ele_ngi(u, ele) + u_nl_dot_grad_nvfrac_gi(i) = dot_product(U_nl_q(:,i), grad_nvfrac_gi(:,i)) + end do + Advection_mat = shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q*nvfrac_gi) & + + beta * (shape_shape(u_shape, u_shape, U_nl_div_q*detwei*Rho_q*nvfrac_gi) + & + shape_shape(u_shape, u_shape, detwei*Rho_q*u_nl_dot_grad_nvfrac_gi)) + else + ! Element advection matrix + ! / / + ! | T (U_nl dot grad T) Rho dV + beta | T ( div U_nl ) T Rho dV + ! / / + Advection_mat = shape_vector_dot_dshape(u_shape, U_nl_q, du_t, detwei*Rho_q) & + + beta * shape_shape(u_shape, u_shape, U_nl_div_q * detwei*Rho_q) + end if + + if(move_mesh) then + Advection_mat = Advection_mat & + - shape_shape(u_shape, u_shape, ele_div_at_quad(U_mesh, ele, dug_t) * detwei * Rho_q) + end if + end if + end if + + do dim = 1, u%dim + if(subcycle) then + subcycle_m_tensor_addto(dim, dim, :loc, :loc) & + &= subcycle_m_tensor_addto(dim, dim, :loc, :loc) & + &+ advection_mat + else + big_m_tensor_addto(dim, dim, :loc, :loc) & + &= big_m_tensor_addto(dim, dim, :loc, :loc) & + &+ dt*theta*advection_mat + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) & + &- matmul(advection_mat, u_val(dim,:)) + end if + end do - ! Form the vertical velocity relaxation absorption term - if (.not.on_sphere) then - grav_at_quads=ele_val_at_quad(gravity, ele) - end if - depth_at_quads=ele_val_at_quad(depth, ele) - - if (on_sphere) then - do i=1,ele_ngi(U,ele) - vvr_abs_diag(3,i)=-vvr_sf*gravity_magnitude*dt*rho_q(i)/depth_at_quads(i) - end do - vvr_abs=rotate_diagonal_to_sphere_gi(X, ele, vvr_abs_diag) - else - do i=1,ele_ngi(u,ele) - vvr_abs_diag(:,i)=vvr_sf*gravity_magnitude*dt*grav_at_quads(:,i)*rho_q(i)/depth_at_quads(i) - end do - end if - - end if - - if (have_implicit_buoyancy) then - - call transform_to_physical(X, ele, ele_shape(buoyancy,ele), dshape=dt_rho) - grad_rho=ele_grad_at_quad(buoyancy, ele, dt_rho) - - ! Calculate the gradient in the direction of gravity - if (on_sphere) then - grav_at_quads=radial_inward_normal_at_quad_ele(X, ele) - else - grav_at_quads=ele_val_at_quad(gravity, ele) - end if - - do i=1,ele_ngi(U,ele) - drho_dz(i)=dot_product(grad_rho(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? - if (drho_dz(i) < ib_min_grad) drho_dz(i)=ib_min_grad ! Default ib_min_grad=0.0 - end do - - ! Form the implicit buoyancy absorption terms - if (on_sphere) then - do i=1,ele_ngi(U,ele) - ib_abs_diag(3,i)=-theta*dt*gravity_magnitude*drho_dz(i) - end do - ib_abs=rotate_diagonal_to_sphere_gi(X, ele, ib_abs_diag) - else - do i=1,ele_ngi(U,ele) - ib_abs_diag(:,i)=theta*dt*gravity_magnitude*drho_dz(i)*grav_at_quads(:,i) - end do - end if - - end if - - ! Add any vertical stabilization to the absorption term - if (on_sphere) then - tensor_absorption_gi=tensor_absorption_gi-vvr_abs-ib_abs - absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag - else - absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag end if - if (have_swe_bottom_drag) then - ! first compute total water depth H - depth_at_quads = ele_val_at_quad(depth, ele) + (theta_nl*ele_val_at_quad(p, ele) + (1.0-theta_nl)*ele_val_at_quad(old_pressure, ele))/gravity_magnitude - ! now reuse depth_at_quads to be the absorption coefficient: C_D*|u|/H - depth_at_quads = (ele_val_at_quad(swe_bottom_drag, ele)*sqrt(sum(ele_val_at_quad(swe_u_nl, ele)**2, dim=1)))/depth_at_quads - do i=1, u%dim - absorption_gi(i,:) = absorption_gi(i,:) + depth_at_quads - end do + if(have_source .and. assemble_element) then + ! Momentum source matrix. + Source_mat = shape_shape(U_shape, ele_shape(Source,ele), detwei*Rho_q) + if(lump_source) then + source_lump = sum(source_mat, 2) + do dim = 1, u%dim + ! lumped source + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) + source_lump*(ele_val(source, dim, ele)) + end do + else + do dim = 1, u%dim + ! nonlumped source + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) + matmul(source_mat, ele_val(source, dim, ele)) + end do + end if + end if + + if(have_gravity .and. assemble_element) then + ! buoyancy + if(subtract_out_reference_profile) then + coefficient_detwei = detwei*gravity_magnitude*(ele_val_at_quad(buoyancy, ele)-ele_val_at_quad(hb_density, ele)) + else + coefficient_detwei = detwei*gravity_magnitude*ele_val_at_quad(buoyancy, ele) + end if + + if (radial_gravity) then + ! If we're using a radial gravity, evaluate the direction of the gravity vector + ! exactly at quadrature points. + rhs_addto(:, :loc) = rhs_addto(:, :loc) + shape_vector_rhs(u_shape, & + radial_inward_normal_at_quad_ele(X, ele), & + coefficient_detwei) + else + if(multiphase) then + rhs_addto(:, :loc) = rhs_addto(:, :loc) + shape_vector_rhs(u_shape, & + ele_val_at_quad(gravity, ele), & + coefficient_detwei*nvfrac_gi) + else + rhs_addto(:, :loc) = rhs_addto(:, :loc) + shape_vector_rhs(u_shape, & + ele_val_at_quad(gravity, ele), & + coefficient_detwei) + end if + + end if end if - ! If on the sphere then use 'tensor' absorption. Note that using tensor absorption means that, currently, - ! the absorption cannot be used in the pressure correction. - if (on_sphere) then + if((have_absorption.or.have_vertical_stabilization.or.have_wd_abs .or. have_swe_bottom_drag) .and. & + (assemble_element .or. pressure_corrected_absorption)) then - Abs_mat_sphere = shape_shape_tensor(U_shape, U_shape, detwei*rho_q, tensor_absorption_gi) - Abs_mat = shape_shape_vector(U_shape, U_shape, detwei*rho_q, absorption_gi) - if (have_wd_abs) then - FLExit("Wetting and drying absorption does currently not work on the sphere.") - end if - - if(lump_abs) then - - Abs_lump_sphere = sum(Abs_mat_sphere, 4) - if (assemble_element) then - do dim = 1, U%dim - do dim2 = 1, U%dim - do i = 1, ele_loc(U, ele) - big_m_tensor_addto(dim, dim2, i, i) = big_m_tensor_addto(dim, dim2, i, i) + & - & dt*theta*Abs_lump_sphere(dim,dim2,i) - end do - end do - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - Abs_lump_sphere(dim,dim,:)*u_val(dim,:) - ! off block diagonal absorption terms - do dim2 = 1, u%dim - if (dim==dim2) cycle ! The dim=dim2 terms were done above - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - Abs_lump_sphere(dim,dim2,:)*u_val(dim2,:) - end do + absorption_gi=0.0 + tensor_absorption_gi=0.0 + absorption_gi = ele_val_at_quad(Abs, ele) + if (on_sphere.and.have_absorption) then ! Rotate the absorption + tensor_absorption_gi=rotate_diagonal_to_sphere_gi(X, ele, absorption_gi) + end if + + vvr_abs_diag=0.0 + vvr_abs=0.0 + ib_abs=0.0 + ib_abs_diag=0.0 + + if (have_vertical_velocity_relaxation) then + + ! Form the vertical velocity relaxation absorption term + if (.not.on_sphere) then + grav_at_quads=ele_val_at_quad(gravity, ele) + end if + depth_at_quads=ele_val_at_quad(depth, ele) + + if (on_sphere) then + do i=1,ele_ngi(U,ele) + vvr_abs_diag(3,i)=-vvr_sf*gravity_magnitude*dt*rho_q(i)/depth_at_quads(i) + end do + vvr_abs=rotate_diagonal_to_sphere_gi(X, ele, vvr_abs_diag) + else + do i=1,ele_ngi(u,ele) + vvr_abs_diag(:,i)=vvr_sf*gravity_magnitude*dt*grav_at_quads(:,i)*rho_q(i)/depth_at_quads(i) + end do + end if + + end if + + if (have_implicit_buoyancy) then + + call transform_to_physical(X, ele, ele_shape(buoyancy,ele), dshape=dt_rho) + grad_rho=ele_grad_at_quad(buoyancy, ele, dt_rho) + + ! Calculate the gradient in the direction of gravity + if (on_sphere) then + grav_at_quads=radial_inward_normal_at_quad_ele(X, ele) + else + grav_at_quads=ele_val_at_quad(gravity, ele) + end if + + do i=1,ele_ngi(U,ele) + drho_dz(i)=dot_product(grad_rho(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? + if (drho_dz(i) < ib_min_grad) drho_dz(i)=ib_min_grad ! Default ib_min_grad=0.0 end do - end if - if (present(inverse_masslump) .and. pressure_corrected_absorption) then - assert(lump_mass) - abs_lump = sum(Abs_mat, 3) - do dim = 1, u%dim - if(have_mass) then - call set( inverse_masslump, dim, u_ele, & - 1.0/(l_masslump+dt*theta*abs_lump(dim,:)) ) - else - call set( inverse_masslump, dim, u_ele, & - 1.0/(dt*theta*abs_lump(dim,:)) ) - end if + + ! Form the implicit buoyancy absorption terms + if (on_sphere) then + do i=1,ele_ngi(U,ele) + ib_abs_diag(3,i)=-theta*dt*gravity_magnitude*drho_dz(i) + end do + ib_abs=rotate_diagonal_to_sphere_gi(X, ele, ib_abs_diag) + else + do i=1,ele_ngi(U,ele) + ib_abs_diag(:,i)=theta*dt*gravity_magnitude*drho_dz(i)*grav_at_quads(:,i) + end do + end if + + end if + + ! Add any vertical stabilization to the absorption term + if (on_sphere) then + tensor_absorption_gi=tensor_absorption_gi-vvr_abs-ib_abs + absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag + else + absorption_gi=absorption_gi-vvr_abs_diag-ib_abs_diag + end if + + if (have_swe_bottom_drag) then + ! first compute total water depth H + depth_at_quads = ele_val_at_quad(depth, ele) + (theta_nl*ele_val_at_quad(p, ele) + (1.0-theta_nl)*ele_val_at_quad(old_pressure, ele))/gravity_magnitude + ! now reuse depth_at_quads to be the absorption coefficient: C_D*|u|/H + depth_at_quads = (ele_val_at_quad(swe_bottom_drag, ele)*sqrt(sum(ele_val_at_quad(swe_u_nl, ele)**2, dim=1)))/depth_at_quads + do i=1, u%dim + absorption_gi(i,:) = absorption_gi(i,:) + depth_at_quads end do - end if - else + end if + + ! If on the sphere then use 'tensor' absorption. Note that using tensor absorption means that, currently, + ! the absorption cannot be used in the pressure correction. + if (on_sphere) then - if (assemble_element) then + Abs_mat_sphere = shape_shape_tensor(U_shape, U_shape, detwei*rho_q, tensor_absorption_gi) + Abs_mat = shape_shape_vector(U_shape, U_shape, detwei*rho_q, absorption_gi) + if (have_wd_abs) then + FLExit("Wetting and drying absorption does currently not work on the sphere.") + end if + + if(lump_abs) then + + Abs_lump_sphere = sum(Abs_mat_sphere, 4) + if (assemble_element) then + do dim = 1, U%dim + do dim2 = 1, U%dim + do i = 1, ele_loc(U, ele) + big_m_tensor_addto(dim, dim2, i, i) = big_m_tensor_addto(dim, dim2, i, i) + & + & dt*theta*Abs_lump_sphere(dim,dim2,i) + end do + end do + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - Abs_lump_sphere(dim,dim,:)*u_val(dim,:) + ! off block diagonal absorption terms + do dim2 = 1, u%dim + if (dim==dim2) cycle ! The dim=dim2 terms were done above + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - Abs_lump_sphere(dim,dim2,:)*u_val(dim2,:) + end do + end do + end if + if (present(inverse_masslump) .and. pressure_corrected_absorption) then + assert(lump_mass) + abs_lump = sum(Abs_mat, 3) + do dim = 1, u%dim + if(have_mass) then + call set( inverse_masslump, dim, u_ele, & + 1.0/(l_masslump+dt*theta*abs_lump(dim,:)) ) + else + call set( inverse_masslump, dim, u_ele, & + 1.0/(dt*theta*abs_lump(dim,:)) ) + end if + end do + end if + + else + + if (assemble_element) then + do dim = 1, u%dim + do dim2 = 1, u%dim + big_m_tensor_addto(dim, dim2, :loc, :loc) = big_m_tensor_addto(dim, dim2, :loc, :loc) + & + & dt*theta*Abs_mat_sphere(dim,dim2,:,:) + end do + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - matmul(Abs_mat_sphere(dim,dim,:,:), u_val(dim,:)) + ! off block diagonal absorption terms + do dim2 = 1, u%dim + if (dim==dim2) cycle ! The dim=dim2 terms were done above + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - matmul(Abs_mat_sphere(dim,dim2,:,:), u_val(dim2,:)) + end do + end do + end if + Abs_lump_sphere = 0.0 + if (present(inverse_mass) .and. pressure_corrected_absorption) then + assert(.not. lump_mass) + do dim = 1, u%dim + if(have_mass) then + call set(inverse_mass, dim, dim, u_ele, u_ele, & + inverse(rho_mat + dt*theta*Abs_mat(dim,:,:))) + else + call set(inverse_mass, dim, dim, u_ele, u_ele, & + inverse(dt*theta*Abs_mat(dim,:,:))) + end if + end do + end if + + end if + + else + + Abs_mat = shape_shape_vector(U_shape, U_shape, detwei*rho_q, absorption_gi) + + if (have_wd_abs) then + alpha_u_quad=ele_val_at_quad(alpha_u_field, ele) !! Wetting and drying absorption becomes active when water level reaches d_0 + Abs_mat = Abs_mat + shape_shape_vector(U_shape, U_shape, alpha_u_quad*detwei*rho_q, & + & ele_val_at_quad(Abs_wd,ele)) + end if + + if(lump_abs) then + abs_lump = sum(Abs_mat, 3) + do dim = 1, u%dim + if (assemble_element) then + big_m_diag_addto(dim, :loc) = big_m_diag_addto(dim, :loc) + dt*theta*abs_lump(dim,:) + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - abs_lump(dim,:)*u_val(dim,:) + end if + if (present(inverse_masslump) .and. pressure_corrected_absorption) then + assert(lump_mass) + if(have_mass) then + call set( inverse_masslump, dim, u_ele, & + 1.0/(l_masslump+dt*theta*abs_lump(dim,:)) ) + else + call set( inverse_masslump, dim, u_ele, & + 1.0/(dt*theta*abs_lump(dim,:)) ) + end if + end if + end do + + else + + do dim = 1, u%dim + if (assemble_element) then + big_m_tensor_addto(dim, dim, :loc, :loc) = big_m_tensor_addto(dim, dim, :loc, :loc) + & + & dt*theta*Abs_mat(dim,:,:) + rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - matmul(Abs_mat(dim,:,:), u_val(dim,:)) + end if + if (present(inverse_mass) .and. pressure_corrected_absorption) then + assert(.not. lump_mass) + if(have_mass) then + call set(inverse_mass, dim, dim, u_ele, u_ele, & + inverse(rho_mat + dt*theta*Abs_mat(dim,:,:))) + else + call set(inverse_mass, dim, dim, u_ele, u_ele, & + inverse(dt*theta*Abs_mat(dim,:,:))) + end if + end if + end do + + end if + + end if + + end if + + if ((((.not.have_absorption).and.(.not.have_vertical_stabilization).and.(.not.have_wd_abs)) .or. (.not.pressure_corrected_absorption)).and.(have_mass)) then + ! no absorption: all mass matrix components are the same + if (present(inverse_mass) .and. .not. lump_mass) then + inverse_mass_mat=inverse(rho_mat) + call set(inverse_mass, 1, 1, u_ele, u_ele, inverse_mass_mat) + if (.not. inverse_mass%equal_diagonal_blocks) then + ! after the strong dirichlet bcs have been applied, the diagonal + ! blocks will be different. So for now we just copy: + do dim = 2, u%dim + call set(inverse_mass, dim, dim, u_ele, u_ele, inverse_mass_mat) + end do + end if + end if + if (present(inverse_masslump) .and. lump_mass) then do dim = 1, u%dim - do dim2 = 1, u%dim - big_m_tensor_addto(dim, dim2, :loc, :loc) = big_m_tensor_addto(dim, dim2, :loc, :loc) + & - & dt*theta*Abs_mat_sphere(dim,dim2,:,:) - end do - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - matmul(Abs_mat_sphere(dim,dim,:,:), u_val(dim,:)) - ! off block diagonal absorption terms - do dim2 = 1, u%dim - if (dim==dim2) cycle ! The dim=dim2 terms were done above - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - matmul(Abs_mat_sphere(dim,dim2,:,:), u_val(dim2,:)) - end do + call set(inverse_masslump, dim, u_ele, 1.0/l_masslump) end do - end if - Abs_lump_sphere = 0.0 - if (present(inverse_mass) .and. pressure_corrected_absorption) then - assert(.not. lump_mass) + end if + + end if + + ! Viscosity. + Viscosity_mat=0 + if(have_viscosity.and.assemble_element) then + if (primal) then do dim = 1, u%dim - if(have_mass) then - call set(inverse_mass, dim, dim, u_ele, u_ele, & - inverse(rho_mat + dt*theta*Abs_mat(dim,:,:))) - else - call set(inverse_mass, dim, dim, u_ele, u_ele, & - inverse(dt*theta*Abs_mat(dim,:,:))) - end if + if(multiphase) then + ! Viscosity matrix is \int{grad(N_A)*viscosity*vfrac*grad(N_B)} for multiphase. + Viscosity_mat(dim,dim,:loc,:loc) = & + dshape_tensor_dshape(du_t, ele_val_at_quad(Viscosity,ele), & + & du_t, detwei*nvfrac_gi) + else + Viscosity_mat(dim,dim,:loc,:loc) = & + dshape_tensor_dshape(du_t, ele_val_at_quad(Viscosity,ele), & + & du_t, detwei) + end if end do - end if - end if + if((viscosity_scheme==CDG).or.(viscosity_scheme==IP)) then + !Compute a matrix which maps ele vals to ele grad vals + !This works since the gradient of the shape function + !lives in the original polynomial space -- cjc + Mass_mat = shape_shape(u_shape, u_shape, detwei) + inverse_mass_mat = mass_mat + call invert(inverse_mass_mat) + ele2grad_mat = shape_dshape(u_shape,du_t,detwei) + do i = 1, mesh_dim(U) + ele2grad_mat(i,:,:) = matmul(inverse_mass_mat, & + ele2grad_mat(i,:,:)) + end do - else + end if - Abs_mat = shape_shape_vector(U_shape, U_shape, detwei*rho_q, absorption_gi) + ! Get kappa mat for CDG + if(viscosity_scheme==CDG) then + if(multiphase) then + ! kappa = mu*vfrac for multiphase + kappa_mat = shape_shape_tensor(u_shape,u_shape,detwei*nvfrac_gi, & + & ele_val_at_quad(Viscosity,ele)) + else + kappa_mat = shape_shape_tensor(u_shape,u_shape,detwei, & + & ele_val_at_quad(Viscosity,ele)) + end if + end if - if (have_wd_abs) then - alpha_u_quad=ele_val_at_quad(alpha_u_field, ele) !! Wetting and drying absorption becomes active when water level reaches d_0 - Abs_mat = Abs_mat + shape_shape_vector(U_shape, U_shape, alpha_u_quad*detwei*rho_q, & - & ele_val_at_quad(Abs_wd,ele)) - end if + else + ! Tau Q = grad(u) + if(multiphase) then + ! We define the auxiliary variable as vfrac*q = vfrac*div(u) + ! to obtain the correct form of the grad_u_mat_q matrix. This way, + ! transpose(grad_u_mat_q) gives the correct form of the viscosity term. + Q_inv= shape_shape(q_shape, q_shape, detwei*nvfrac_gi) + else + Q_inv= shape_shape(q_shape, q_shape, detwei) + end if + + call invert(Q_inv) + call cholesky_factor(Q_inv) + + Grad_U_mat_q=0.0 + Div_U_mat_q=0.0 + if(.not.p0) then + + if(multiphase) then + ! Split up -\int{grad(N_A vfrac) N_B} using the product rule + ! and compute -\int{grad(N_A) vfrac N_B} - \int{N_A grad(vfrac) N_B} + Grad_U_mat_q(:, :, :loc) = -dshape_shape(dq_t, u_shape, detwei*nvfrac_gi) - & + & shape_shape_vector(q_shape, u_shape, detwei, grad_nvfrac_gi) + else + Grad_U_mat_q(:, :, :loc) = -dshape_shape(dq_t, u_shape, detwei) + end if + + if(viscosity_scheme==ARBITRARY_UPWIND) then + Div_U_mat_q(:, :, :loc) = -shape_dshape(q_shape, du_t, detwei) + end if - if(lump_abs) then - abs_lump = sum(Abs_mat, 3) - do dim = 1, u%dim - if (assemble_element) then - big_m_diag_addto(dim, :loc) = big_m_diag_addto(dim, :loc) + dt*theta*abs_lump(dim,:) - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - abs_lump(dim,:)*u_val(dim,:) end if - if (present(inverse_masslump) .and. pressure_corrected_absorption) then - assert(lump_mass) - if(have_mass) then - call set( inverse_masslump, dim, u_ele, & - 1.0/(l_masslump+dt*theta*abs_lump(dim,:)) ) - else - call set( inverse_masslump, dim, u_ele, & - 1.0/(dt*theta*abs_lump(dim,:)) ) - end if + end if + end if + + if(have_surfacetension.and.(.not.p0).and.assemble_element) then + if(integrate_surfacetension_by_parts) then + tension = ele_val_at_quad(surfacetension, ele) + + rhs_addto(:,:loc) = rhs_addto(:,:loc) - & + &dshape_dot_tensor_rhs(du_t, tension, detwei) + else + dtensiondj = ele_div_at_quad_tensor(surfacetension, ele, du_t) + + rhs_addto(:,:loc) = rhs_addto(:,:loc) + & + & shape_vector_rhs(u_shape,dtensiondj,detwei) + end if + end if + + !------------------------------------------------------------------- + ! Interface integrals + !------------------------------------------------------------------- + + if(dg.and.(have_viscosity.or.have_advection.or.have_pressure_bc).and.assemble_element) then + neigh=>ele_neigh(U, ele) + ! x_neigh/=t_neigh only on periodic boundaries. + x_neigh=>ele_neigh(X, ele) + + ! Local node map counter. + start=loc+1 + ! Flag for whether this is a boundary element. + boundary_element=.false. + + neighbourloop: do ni=1,size(neigh) + + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- + turbine_face=.false. + ! These finding routines are outside the inner loop so as to allow + ! for local stack variables of the right size in + ! construct_momentum_interface_dg. + + ele_2=neigh(ni) + + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(U, ele, ele_2) + + if (ele_2>0) then + ! Internal faces. + face_2=ele_face(U, ele_2, ele) + ! Check if face is turbine face (note: get_entire_boundary_condition only returns "applied" boundaries and we reset the apply status in each timestep) + elseif (velocity_bc_type(1,face)==4 .or. velocity_bc_type(1,face)==5) then + face_2=face_neigh(turbine_conn_mesh, face) + turbine_face=.true. + else + ! External face. + face_2=face + boundary_element=.true. end if - end do - else + !Compute distance between cell centre and neighbouring cell centre + !This is for Interior Penalty Method -- cjc + !-------------- + if(dg.and.viscosity_scheme==IP) then + if(edge_length_option==USE_ELEMENT_CENTRES) then + ele_2_X = x_neigh(ni) + ele_centre = sum(X_val,2)/size(X_val,2) + face_centre = sum(face_val(X,face),2)/size(face_val(X,face),2) + if(face==face_2) then + ! Boundary case. We compute 2x the distance to the face centre + h0 = 2*sqrt( sum(ele_centre - face_centre)**2 ) + else if (ele_2/=x_neigh(ni)) then + ! Periodic boundary case. We have to cook up the coordinate by + ! adding vectors to the face from each side. + x_val_2 = ele_val(X,ele_2_X) + neigh_centre = sum(X_val_2,2)/size(X_val_2,2) + face_centre_2 = & + sum(face_val(X,face_2),2)/size(face_val(X,face_2),2) + h0 = sqrt ( sum(ele_centre - face_centre)**2 ) + h0 = h0 + sqrt( sum(neigh_centre - face_centre_2)**2 ) + else + x_val_2 = ele_val(X,ele_2_X) + neigh_centre = sum(X_val_2,2)/size(X_val_2,2) + h0 = sqrt ( sum(ele_centre - neigh_centre)**2 ) + end if + end if + end if + !-------------- + + if (dg) then + finish=start+face_loc(U, face_2)-1 - do dim = 1, u%dim - if (assemble_element) then - big_m_tensor_addto(dim, dim, :loc, :loc) = big_m_tensor_addto(dim, dim, :loc, :loc) + & - & dt*theta*Abs_mat(dim,:,:) - rhs_addto(dim, :loc) = rhs_addto(dim, :loc) - matmul(Abs_mat(dim,:,:), u_val(dim,:)) + local_glno(start:finish)=face_global_nodes(U, face_2) end if - if (present(inverse_mass) .and. pressure_corrected_absorption) then - assert(.not. lump_mass) - if(have_mass) then - call set(inverse_mass, dim, dim, u_ele, u_ele, & - inverse(rho_mat + dt*theta*Abs_mat(dim,:,:))) - else - call set(inverse_mass, dim, dim, u_ele, u_ele, & - inverse(dt*theta*Abs_mat(dim,:,:))) - end if + + ! Turbine face + if (turbine_face) then + call construct_turbine_interface(turbine_fluxfac, theta, dt, ele, face, face_2, ni, & + & big_m_tensor_addto, rhs_addto, X, U, velocity_bc, velocity_bc_type) end if - end do - end if + if(primal) then + if(.not. turbine_face .or. turbine_fluxfac>=0) then + call construct_momentum_interface_dg(ele, face, face_2, ni,& + & big_m_tensor_addto, & + & rhs_addto, Grad_U_mat_q, Div_U_mat_q, X,& + & Rho, U, U_nl, U_mesh, P, q_mesh, surfacetension, & + & velocity_bc, velocity_bc_type, & + & pressure_bc, pressure_bc_type, hb_pressure, & + & subcycle_m_tensor_addto, subcycle_rhs_addto, nvfrac, & + & ele2grad_mat=ele2grad_mat, kappa_mat=kappa_mat, & + & inverse_mass_mat=inverse_mass_mat, & + & viscosity=viscosity, viscosity_mat=viscosity_mat) + end if + else + if(.not. turbine_face .or. turbine_fluxfac>=0) then + call construct_momentum_interface_dg(ele, face, face_2, ni,& + & big_m_tensor_addto, & + & rhs_addto, Grad_U_mat_q, Div_U_mat_q, X,& + & Rho, U, U_nl, U_mesh, P, q_mesh, surfacetension, & + & velocity_bc, velocity_bc_type, & + & pressure_bc, pressure_bc_type, hb_pressure, & + & subcycle_m_tensor_addto, subcycle_rhs_addto, nvfrac) + end if + end if - end if + if (dg) then + start=start+face_loc(U, face_2) + end if - end if + end do neighbourloop - if ((((.not.have_absorption).and.(.not.have_vertical_stabilization).and.(.not.have_wd_abs)) .or. (.not.pressure_corrected_absorption)).and.(have_mass)) then - ! no absorption: all mass matrix components are the same - if (present(inverse_mass) .and. .not. lump_mass) then - inverse_mass_mat=inverse(rho_mat) - call set(inverse_mass, 1, 1, u_ele, u_ele, inverse_mass_mat) - if (.not. inverse_mass%equal_diagonal_blocks) then - ! after the strong dirichlet bcs have been applied, the diagonal - ! blocks will be different. So for now we just copy: - do dim = 2, u%dim - call set(inverse_mass, dim, dim, u_ele, u_ele, inverse_mass_mat) - end do - end if - end if - if (present(inverse_masslump) .and. lump_mass) then - do dim = 1, u%dim - call set(inverse_masslump, dim, u_ele, 1.0/l_masslump) - end do - end if - - end if - - ! Viscosity. - Viscosity_mat=0 - if(have_viscosity.and.assemble_element) then - if (primal) then - do dim = 1, u%dim - if(multiphase) then - ! Viscosity matrix is \int{grad(N_A)*viscosity*vfrac*grad(N_B)} for multiphase. - Viscosity_mat(dim,dim,:loc,:loc) = & - dshape_tensor_dshape(du_t, ele_val_at_quad(Viscosity,ele), & - & du_t, detwei*nvfrac_gi) - else - Viscosity_mat(dim,dim,:loc,:loc) = & - dshape_tensor_dshape(du_t, ele_val_at_quad(Viscosity,ele), & - & du_t, detwei) - end if - end do - - if((viscosity_scheme==CDG).or.(viscosity_scheme==IP)) then - !Compute a matrix which maps ele vals to ele grad vals - !This works since the gradient of the shape function - !lives in the original polynomial space -- cjc - Mass_mat = shape_shape(u_shape, u_shape, detwei) - inverse_mass_mat = mass_mat - call invert(inverse_mass_mat) - ele2grad_mat = shape_dshape(u_shape,du_t,detwei) - do i = 1, mesh_dim(U) - ele2grad_mat(i,:,:) = matmul(inverse_mass_mat, & - ele2grad_mat(i,:,:)) - end do - - end if - - ! Get kappa mat for CDG - if(viscosity_scheme==CDG) then - if(multiphase) then - ! kappa = mu*vfrac for multiphase - kappa_mat = shape_shape_tensor(u_shape,u_shape,detwei*nvfrac_gi, & - & ele_val_at_quad(Viscosity,ele)) - else - kappa_mat = shape_shape_tensor(u_shape,u_shape,detwei, & - & ele_val_at_quad(Viscosity,ele)) - end if - end if - - else - ! Tau Q = grad(u) - if(multiphase) then - ! We define the auxiliary variable as vfrac*q = vfrac*div(u) - ! to obtain the correct form of the grad_u_mat_q matrix. This way, - ! transpose(grad_u_mat_q) gives the correct form of the viscosity term. - Q_inv= shape_shape(q_shape, q_shape, detwei*nvfrac_gi) - else - Q_inv= shape_shape(q_shape, q_shape, detwei) - end if - - call invert(Q_inv) - call cholesky_factor(Q_inv) - - Grad_U_mat_q=0.0 - Div_U_mat_q=0.0 - if(.not.p0) then - - if(multiphase) then - ! Split up -\int{grad(N_A vfrac) N_B} using the product rule - ! and compute -\int{grad(N_A) vfrac N_B} - \int{N_A grad(vfrac) N_B} - Grad_U_mat_q(:, :, :loc) = -dshape_shape(dq_t, u_shape, detwei*nvfrac_gi) - & - & shape_shape_vector(q_shape, u_shape, detwei, grad_nvfrac_gi) - else - Grad_U_mat_q(:, :, :loc) = -dshape_shape(dq_t, u_shape, detwei) - end if - - if(viscosity_scheme==ARBITRARY_UPWIND) then - Div_U_mat_q(:, :, :loc) = -shape_dshape(q_shape, du_t, detwei) - end if - - end if - end if - end if - - if(have_surfacetension.and.(.not.p0).and.assemble_element) then - if(integrate_surfacetension_by_parts) then - tension = ele_val_at_quad(surfacetension, ele) - - rhs_addto(:,:loc) = rhs_addto(:,:loc) - & - &dshape_dot_tensor_rhs(du_t, tension, detwei) - else - dtensiondj = ele_div_at_quad_tensor(surfacetension, ele, du_t) - - rhs_addto(:,:loc) = rhs_addto(:,:loc) + & - & shape_vector_rhs(u_shape,dtensiondj,detwei) - end if - end if - - !------------------------------------------------------------------- - ! Interface integrals - !------------------------------------------------------------------- - - if(dg.and.(have_viscosity.or.have_advection.or.have_pressure_bc).and.assemble_element) then - neigh=>ele_neigh(U, ele) - ! x_neigh/=t_neigh only on periodic boundaries. - x_neigh=>ele_neigh(X, ele) - - ! Local node map counter. - start=loc+1 - ! Flag for whether this is a boundary element. - boundary_element=.false. - - neighbourloop: do ni=1,size(neigh) - - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- - turbine_face=.false. - ! These finding routines are outside the inner loop so as to allow - ! for local stack variables of the right size in - ! construct_momentum_interface_dg. - - ele_2=neigh(ni) - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(U, ele, ele_2) - - if (ele_2>0) then - ! Internal faces. - face_2=ele_face(U, ele_2, ele) - ! Check if face is turbine face (note: get_entire_boundary_condition only returns "applied" boundaries and we reset the apply status in each timestep) - elseif (velocity_bc_type(1,face)==4 .or. velocity_bc_type(1,face)==5) then - face_2=face_neigh(turbine_conn_mesh, face) - turbine_face=.true. - else - ! External face. - face_2=face - boundary_element=.true. - end if - - !Compute distance between cell centre and neighbouring cell centre - !This is for Interior Penalty Method -- cjc - !-------------- - if(dg.and.viscosity_scheme==IP) then - if(edge_length_option==USE_ELEMENT_CENTRES) then - ele_2_X = x_neigh(ni) - ele_centre = sum(X_val,2)/size(X_val,2) - face_centre = sum(face_val(X,face),2)/size(face_val(X,face),2) - if(face==face_2) then - ! Boundary case. We compute 2x the distance to the face centre - h0 = 2*sqrt( sum(ele_centre - face_centre)**2 ) - else if (ele_2/=x_neigh(ni)) then - ! Periodic boundary case. We have to cook up the coordinate by - ! adding vectors to the face from each side. - x_val_2 = ele_val(X,ele_2_X) - neigh_centre = sum(X_val_2,2)/size(X_val_2,2) - face_centre_2 = & - sum(face_val(X,face_2),2)/size(face_val(X,face_2),2) - h0 = sqrt ( sum(ele_centre - face_centre)**2 ) - h0 = h0 + sqrt( sum(neigh_centre - face_centre_2)**2 ) - else - x_val_2 = ele_val(X,ele_2_X) - neigh_centre = sum(X_val_2,2)/size(X_val_2,2) - h0 = sqrt ( sum(ele_centre - neigh_centre)**2 ) - end if - end if - end if - !-------------- - - if (dg) then - finish=start+face_loc(U, face_2)-1 - - local_glno(start:finish)=face_global_nodes(U, face_2) - end if - - ! Turbine face - if (turbine_face) then - call construct_turbine_interface(turbine_fluxfac, theta, dt, ele, face, face_2, ni, & - & big_m_tensor_addto, rhs_addto, X, U, velocity_bc, velocity_bc_type) - end if - - if(primal) then - if(.not. turbine_face .or. turbine_fluxfac>=0) then - call construct_momentum_interface_dg(ele, face, face_2, ni,& - & big_m_tensor_addto, & - & rhs_addto, Grad_U_mat_q, Div_U_mat_q, X,& - & Rho, U, U_nl, U_mesh, P, q_mesh, surfacetension, & - & velocity_bc, velocity_bc_type, & - & pressure_bc, pressure_bc_type, hb_pressure, & - & subcycle_m_tensor_addto, subcycle_rhs_addto, nvfrac, & - & ele2grad_mat=ele2grad_mat, kappa_mat=kappa_mat, & - & inverse_mass_mat=inverse_mass_mat, & - & viscosity=viscosity, viscosity_mat=viscosity_mat) - end if - else - if(.not. turbine_face .or. turbine_fluxfac>=0) then - call construct_momentum_interface_dg(ele, face, face_2, ni,& - & big_m_tensor_addto, & - & rhs_addto, Grad_U_mat_q, Div_U_mat_q, X,& - & Rho, U, U_nl, U_mesh, P, q_mesh, surfacetension, & - & velocity_bc, velocity_bc_type, & - & pressure_bc, pressure_bc_type, hb_pressure, & - & subcycle_m_tensor_addto, subcycle_rhs_addto, nvfrac) + !---------------------------------------------------------------------- + ! Construct local diffusivity operator for DG. + !---------------------------------------------------------------------- + + if(have_viscosity) then + + select case(viscosity_scheme) + case(ARBITRARY_UPWIND) + call local_assembly_arbitrary_upwind + case(BASSI_REBAY) + if (partial_stress) then + call local_assembly_bassi_rebay_stress_form + else + call local_assembly_bassi_rebay + end if + end select + + if (boundary_element) then + + ! Weak application of dirichlet conditions on viscosity term. + + weak_dirichlet_loop: do i=1,2 + ! this is done in 2 passes + ! iteration 1: wipe the rows corresponding to weak dirichlet boundary faces + ! iteration 2: for columns corresponding to weak dirichlet boundary faces, + ! move this coefficient multiplied with the bc value to the rhs + ! then wipe the column + ! The 2 iterations are necessary for elements with more than one weak dirichlet boundary face + ! as we should not try to move the coefficient in columns corresponding to boundary face 1 + ! in rows correspoding to face 2 to the rhs, i.e. we need to wipe *all* boundary rows first. + + do dim=1,u%dim + + ! Local node map counter. + start=loc+1 + + boundary_neighbourloop: do ni=1,size(neigh) + ele_2=neigh(ni) + + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + if (ele_2>0) then + ! Interior face - we need the neighbouring face to + ! calculate the new start + face=ele_face(U, ele_2, ele) + else + ! Boundary face + face=ele_face(U, ele, ele_2) + if (velocity_bc_type(dim,face)==1) then + + ! Dirichlet condition. + + finish=start+face_loc(U, face)-1 + + if (i==1) then + ! Wipe out boundary condition's coupling to itself. + Viscosity_mat(:,dim,start:finish,:)=0.0 + else + ! Add BC into RHS + ! + do dim1=1,u%dim + rhs_addto(dim1,:) = rhs_addto(dim1,:) & + & -matmul(Viscosity_mat(dim1,dim,:,start:finish), & + & ele_val(velocity_bc,dim,face)) + end do + ! Ensure it is not used again. + Viscosity_mat(:,dim,:,start:finish)=0.0 + end if + ! Check if face is turbine face (note: get_entire_boundary_condition only returns + ! "applied" boundaries and we reset the apply status in each timestep) + elseif (velocity_bc_type(dim,face)==4 .or. velocity_bc_type(dim,face)==5) then + face=face_neigh(turbine_conn_mesh, face) + end if + end if + start=start+face_loc(U, face) + + end do boundary_neighbourloop + + end do + + end do weak_dirichlet_loop + + end if + + ! Insert viscosity in matrix. + big_m_tensor_addto = big_m_tensor_addto + Viscosity_mat*theta*dt + + do dim1=1,U%dim + do dim2=1, U%dim + rhs_addto(dim1, :) = rhs_addto(dim1, :) & + - matmul(Viscosity_mat(dim1,dim2,:,:), & + node_val(U, dim2, local_glno)) + end do + end do + + end if !have_viscosity + + end if !dg.and.(have_viscosity.or.have_advection) + + !---------------------------------------------------------------------- + ! Perform global assembly. + !---------------------------------------------------------------------- + + if (assemble_element) then + + ! add lumped terms to the diagonal of the matrix + call add_diagonal_to_tensor(big_m_diag_addto, big_m_tensor_addto) + + if(dg.and.(have_viscosity.or.have_advection)) then + + ! first the diagonal blocks, i.e. the coupling within the element + ! and neighbouring face nodes but with the same component + if(have_viscosity) then + if(partial_stress) then + call addto(big_m, local_glno, local_glno, & + big_m_tensor_addto) + else + ! add to the matrix + call addto(big_m, local_glno, local_glno, big_m_tensor_addto, & + block_mask=diagonal_block_mask) + end if + ! add to the rhs + call addto(rhs, local_glno, rhs_addto) + else + ! add to the matrix + call addto(big_m, u_ele, local_glno, big_m_tensor_addto(:,:,:loc,:), & + block_mask=diagonal_block_mask) + ! add to the rhs + call addto(rhs, u_ele, rhs_addto(:,:loc)) + end if + if(subcycle) then + call addto(subcycle_m, u_ele, local_glno,& + &subcycle_m_tensor_addto(:,:,:loc,:), & + &block_mask=diagonal_block_mask) + call addto(subcycle_rhs, u_ele, subcycle_rhs_addto) end if - end if + if(.not. partial_stress .and. have_coriolis) then + ! add in coupling between different components, but only within the element + call addto(big_m, u_ele, u_ele, & + big_m_tensor_addto(:,:,:loc,:loc), block_mask& + &=off_diagonal_block_mask) + end if + else + ! in this case we only have coupling between nodes within the element + if (have_coriolis) then + call addto(big_m, u_ele, u_ele, big_m_tensor_addto(:,:,:loc,:loc)) + else + ! add to the matrix + call addto(big_m, u_ele, u_ele, big_m_tensor_addto(:,:,:loc,:loc), & + block_mask=diagonal_block_mask) + end if + ! add to the rhs + call addto(rhs, u_ele, rhs_addto(:,:loc)) + end if + + end if + + + contains + + subroutine local_assembly_arbitrary_upwind + integer :: d3 + + do dim1=1, Viscosity%dim(1) + do dim2=1,Viscosity%dim(2) + do d3 = 1, mesh_dim(U) + ! Div U * G^U * Viscosity * G * Grad U + ! Where G^U*G = inverse(Q_mass) + Viscosity_mat(d3,d3,:,:)=Viscosity_mat(d3,d3,:,:)& + +0.5*( & + +matmul(matmul(transpose(grad_U_mat_q(dim1,:,:))& + & ,mat_diag_mat(Q_inv, Viscosity_ele(dim1,dim2,:)))& + & ,grad_U_mat_q(dim2,:,:))& + +matmul(matmul(transpose(div_U_mat_q(dim1,:,:))& + & ,mat_diag_mat(Q_inv, Viscosity_ele(dim1,dim2,:)))& + & ,div_U_mat_q(dim2,:,:))& + &) + end do + end do + end do + + end subroutine local_assembly_arbitrary_upwind + + subroutine local_assembly_bassi_rebay + + integer :: d3 + + do dim1=1, Viscosity%dim(1) + do dim2=1,Viscosity%dim(2) + do d3 = 1, mesh_dim(U) + + ! Div U * G^U * Viscosity * G * Grad U + ! Where G^U*G = inverse(Q_mass) + Viscosity_mat(d3,d3,:,:)=Viscosity_mat(d3,d3,:,:)& + +matmul(matmul(transpose(grad_U_mat_q(dim1,:,:))& + & ,mat_diag_mat(Q_inv, Viscosity_ele(dim1,dim2,:)))& + & ,grad_U_mat_q(dim2,:,:)) + + end do + end do + end do + + end subroutine local_assembly_bassi_rebay + + subroutine local_assembly_bassi_rebay_stress_form + + ! Instead of: + ! M_v = G^T_m (\nu Q^{-1})_mn G_n + ! We construct: + ! M_v_rs = G^T_m A_rmsn Q^{-1} G_n + ! where A is a dim x dim x dim x dim linear operator: + ! A_rmsn = \partial ( \nu ( u_{r,m} + u_{m,r} ) ) / \partial u_{s,n} + ! where a_{b,c} = \partial a_b / \partial x_c + ! off diagonal terms define the coupling between the velocity components + + real, dimension(size(Q_inv,1), size(Q_inv,2)) :: Q_visc + real, dimension(ele_loc(u, ele)) :: isotropic_visc + + dim = Viscosity%dim(1) + isotropic_visc = Viscosity_ele(1,1,:) + if (have_les) then + call les_viscosity(isotropic_visc) + end if + Q_visc = mat_diag_mat(Q_inv, isotropic_visc) + + do dim1=1,u%dim + do dim2=1,u%dim + do dim3=1,u%dim + do dim4=1,u%dim + if (dim1==dim2 .and. dim2==dim3 .and. dim3==dim4) then + Viscosity_mat(dim1,dim3,:,:) = Viscosity_mat(dim1,dim3,:,:) & + + 2.0 * matmul(matmul(transpose(grad_U_mat_q(dim2,:,:)),Q_visc),grad_U_mat_q(dim4,:,:)) + else if ((dim1==dim3 .and. dim2==dim4) .or. (dim2==dim3 .and. dim1==dim4)) then + Viscosity_mat(dim1,dim3,:,:) = Viscosity_mat(dim1,dim3,:,:) & + + matmul(matmul(transpose(grad_U_mat_q(dim2,:,:)),Q_visc),grad_U_mat_q(dim4,:,:)) + end if + end do + end do + end do + end do + + end subroutine local_assembly_bassi_rebay_stress_form + + subroutine add_diagonal_to_tensor(big_m_diag_addto, big_m_tensor_addto) + real, dimension(u%dim, ele_and_faces_loc(u, ele)), intent(in) :: big_m_diag_addto + real, dimension(u%dim, u%dim, ele_and_faces_loc(u, ele), ele_and_faces_loc(u, ele)), intent(inout) :: big_m_tensor_addto + + integer :: dim, loc + + forall(dim = 1:size(big_m_diag_addto, 1), loc = 1:size(big_m_diag_addto, 2)) + big_m_tensor_addto(dim, dim, loc, loc) = big_m_tensor_addto(dim, dim, loc, loc) + big_m_diag_addto(dim, loc) + end forall + + end subroutine add_diagonal_to_tensor + + subroutine les_viscosity(isotropic_visc) + + !!! Calculate LES contribution to the viscosity in the momentum equation. + + !!! This is a Smagorinsky style model + + !!! \nu_{eddy} = C_s Delta x_{grid} | S | where + !!! S= ( \nabla u + \nabla u ^T )/2.0 + + real, dimension(ele_loc(u,ele)), intent(inout) :: isotropic_visc + + real, dimension(ele_loc(u,ele)) :: les_filter_width + real, dimension(mesh_dim(u), mesh_dim(u), ele_loc(u,ele)) :: g_nl + real, dimension(mesh_dim(u), mesh_dim(u)) :: s + real, dimension(ele_loc(u,ele)) :: s_mod + real, dimension(ele_loc(u,ele)) :: les_scalar_viscosity, y_wall, y_plus + real, dimension(ele_loc(u,ele), ele_loc(u,ele)) :: M_inv + + ! get inverse mass + M_inv = shape_shape(u_shape, u_shape, detwei) + call invert(M_inv) + + ! Compute gradient of non-linear velocity + do dim1=1,mesh_dim(u) + do dim2=1,mesh_dim(u) + ! interior contribution + g_nl(dim1,dim2,:)=matmul(grad_U_mat_q(dim2,:,:loc), ele_val(u_nl,dim1,ele)) + + ! boundary contributions (have to be done seperately as we need to apply bc's at boundaries) + ! local node map counter. + start=loc+1 + do ni=1,size(neigh) + ! get neighbour ele, corresponding faces, and complete local node map + ele_2=neigh(ni) + + if (ele_2>0) then + ! obtain corresponding faces, and complete local node map + face=ele_face(U, ele_2, ele) + finish=start+face_loc(U, face)-1 + ! for interior faces we use the face values + g_nl(dim1,dim2,:)=g_nl(dim1,dim2,:)+matmul(grad_U_mat_q(dim2,:,start:finish), face_val(u_nl,dim1,face)) + else + ! obtain corresponding faces, and complete local node map + face=ele_face(U, ele, ele_2) + finish=start+face_loc(U, face)-1 + ! for boundary faces the value we use depends upon if a weak bc is applied + if (velocity_bc_type(dim1,face)==1) then + ! weak bc! use the bc value + g_nl(dim1,dim2,:)=g_nl(dim1,dim2,:)+matmul(grad_U_mat_q(dim2,:,start:finish), ele_val(velocity_bc,dim1,face)) + else + ! no weak bc, use node values on internal face + g_nl(dim1,dim2,:)=g_nl(dim1,dim2,:)+matmul(grad_U_mat_q(dim2,:,start:finish), face_val(u_nl,dim1,face)) + end if + end if - if (dg) then - start=start+face_loc(U, face_2) - end if + ! update node map counter + start=start+face_loc(U, face) + end do - end do neighbourloop + ! apply inverse mass + g_nl(dim1,dim2,:)=matmul(M_inv, g_nl(dim1,dim2,:)) + end do + end do - !---------------------------------------------------------------------- - ! Construct local diffusivity operator for DG. - !---------------------------------------------------------------------- + ! call calculate_les_grad_u(g_nl) - if(have_viscosity) then - - select case(viscosity_scheme) - case(ARBITRARY_UPWIND) - call local_assembly_arbitrary_upwind - case(BASSI_REBAY) - if (partial_stress) then - call local_assembly_bassi_rebay_stress_form - else - call local_assembly_bassi_rebay - end if - end select - - if (boundary_element) then - - ! Weak application of dirichlet conditions on viscosity term. - - weak_dirichlet_loop: do i=1,2 - ! this is done in 2 passes - ! iteration 1: wipe the rows corresponding to weak dirichlet boundary faces - ! iteration 2: for columns corresponding to weak dirichlet boundary faces, - ! move this coefficient multiplied with the bc value to the rhs - ! then wipe the column - ! The 2 iterations are necessary for elements with more than one weak dirichlet boundary face - ! as we should not try to move the coefficient in columns corresponding to boundary face 1 - ! in rows correspoding to face 2 to the rhs, i.e. we need to wipe *all* boundary rows first. - - do dim=1,u%dim - - ! Local node map counter. - start=loc+1 - - boundary_neighbourloop: do ni=1,size(neigh) - ele_2=neigh(ni) - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - if (ele_2>0) then - ! Interior face - we need the neighbouring face to - ! calculate the new start - face=ele_face(U, ele_2, ele) - else - ! Boundary face - face=ele_face(U, ele, ele_2) - if (velocity_bc_type(dim,face)==1) then - - ! Dirichlet condition. - - finish=start+face_loc(U, face)-1 - - if (i==1) then - ! Wipe out boundary condition's coupling to itself. - Viscosity_mat(:,dim,start:finish,:)=0.0 - else - ! Add BC into RHS - ! - do dim1=1,u%dim - rhs_addto(dim1,:) = rhs_addto(dim1,:) & - & -matmul(Viscosity_mat(dim1,dim,:,start:finish), & - & ele_val(velocity_bc,dim,face)) - end do - ! Ensure it is not used again. - Viscosity_mat(:,dim,:,start:finish)=0.0 - end if - ! Check if face is turbine face (note: get_entire_boundary_condition only returns - ! "applied" boundaries and we reset the apply status in each timestep) - elseif (velocity_bc_type(dim,face)==4 .or. velocity_bc_type(dim,face)==5) then - face=face_neigh(turbine_conn_mesh, face) - end if - end if - start=start+face_loc(U, face) + ! Compute modulus of strain rate + do i=1,ele_loc(u,ele) + s=0.5*(g_nl(:,:,i)+transpose(g_nl(:,:,i))) + ! Calculate modulus of strain rate + s_mod(i)=sqrt(2*sum(s**2)) + end do - end do boundary_neighbourloop + ! Compute filter width + if (associated(prescribed_filter_width)) then + les_filter_width = ele_val(prescribed_filter_width, ele) + else + ! when using the element size to compute the filter width we assume the filter + ! width is twice the element size + les_filter_width = 2*length_scale_scalar(X, ele) + end if + ! apply Van Driest damping functions + if (associated(distance_to_wall)) then + y_wall = ele_val(distance_to_wall, ele) + do i=1,ele_loc(u,ele) + y_plus(i) = y_wall(i) * sqrt(norm2(g_nl(:,:,i)+transpose(g_nl(:,:,i))))/sqrt(isotropic_visc(i)) end do + les_filter_width = (1 - exp(-1.0*y_plus/25.0))*les_filter_width - end do weak_dirichlet_loop + ! debugging fields + if (associated(y_plus_debug)) then + call set(y_plus_debug, ele_nodes(y_plus_debug, ele), y_plus) + end if + end if - end if + if (associated(les_filter_width_debug)) then + call set(les_filter_width_debug, ele_nodes(les_filter_width_debug, ele), les_filter_width) + end if - ! Insert viscosity in matrix. - big_m_tensor_addto = big_m_tensor_addto + Viscosity_mat*theta*dt + les_scalar_viscosity = (les_filter_width*smagorinsky_coefficient)**2 * s_mod - do dim1=1,U%dim - do dim2=1, U%dim - rhs_addto(dim1, :) = rhs_addto(dim1, :) & - - matmul(Viscosity_mat(dim1,dim2,:,:), & - node_val(U, dim2, local_glno)) - end do - end do + ! store sgs viscosity + if (associated(eddy_visc)) then + call set(eddy_visc, ele_nodes(eddy_visc, ele), les_scalar_viscosity) + end if - end if !have_viscosity + ! Add to molecular viscosity + isotropic_visc = isotropic_visc + les_scalar_viscosity - end if !dg.and.(have_viscosity.or.have_advection) + end subroutine les_viscosity - !---------------------------------------------------------------------- - ! Perform global assembly. - !---------------------------------------------------------------------- + end subroutine construct_momentum_element_dg - if (assemble_element) then + subroutine construct_momentum_interface_dg(ele, face, face_2, ni, & + & big_m_tensor_addto, & + & rhs_addto, Grad_U_mat, Div_U_mat, X, Rho, U,& + & U_nl, U_mesh, P, q_mesh, surfacetension, & + & velocity_bc, velocity_bc_type, & + & pressure_bc, pressure_bc_type, hb_pressure, & + & subcycle_m_tensor_addto, subcycle_rhs_addto, nvfrac, & + & ele2grad_mat, kappa_mat, inverse_mass_mat, & + & viscosity, viscosity_mat) + !!< Construct the DG element boundary integrals on the ni-th face of + !!< element ele. + implicit none - ! add lumped terms to the diagonal of the matrix - call add_diagonal_to_tensor(big_m_diag_addto, big_m_tensor_addto) + logical :: CDG_switch_in + + integer, intent(in) :: ele, face, face_2, ni + real, dimension(:,:,:,:), intent(inout) :: big_m_tensor_addto + real, dimension(:,:,:,:), intent(inout) :: subcycle_m_tensor_addto + real, dimension(:,:), intent(inout) :: rhs_addto, subcycle_rhs_addto + real, dimension(:,:,:), intent(inout) :: Grad_U_mat, Div_U_mat + ! We pass these additional fields to save on state lookups. + type(vector_field), intent(in) :: X, U, U_nl + type(vector_field), pointer :: U_mesh + type(scalar_field), intent(in) :: Rho, P + type(scalar_field), intent(in) :: nvfrac + !! Mesh of the auxiliary variable in the second order operator. + type(mesh_type), intent(in) :: q_mesh + !! surfacetension + type(tensor_field), intent(in) :: surfacetension + !! Boundary conditions associated with this interface (if any). + type(vector_field), intent(in) :: velocity_bc + integer, dimension(:,:), intent(in) :: velocity_bc_type + type(scalar_field), intent(in) :: pressure_bc + integer, dimension(:), intent(in) :: pressure_bc_type + type(scalar_field), intent(in) :: hb_pressure + + !! Computation of primal fluxes and penalty fluxes + real, intent(in), optional, dimension(:,:,:) :: ele2grad_mat + + !! \Int_{ele} N_i kappa N_j dV, used for CDG fluxes + real, dimension(:,:,:,:), intent(in), optional :: kappa_mat + + !! Inverse element mass matrix. + real, dimension(:,:), intent(in), optional :: inverse_mass_mat + + type(tensor_field), intent(in), optional :: viscosity + + !! Local viscosity matrix for assembly. + real, intent(inout), dimension(:,:,:,:), optional :: viscosity_mat + + ! Matrix for assembling primal fluxes + ! Note that this assumes same order polys in each element + ! Code will need reorganising for p-refinement + real, dimension(2,face_loc(U,face),ele_loc(U,ele)) ::& + & primal_fluxes_mat + + ! Matrix for assembling penalty fluxes + ! Note that this assumes same order polys in each element + ! Code will need reorganising for p-refinement + real, dimension(2,face_loc(U,face),face_loc(U,face)) ::& + & penalty_fluxes_mat + + ! \Int_{s_ele} N_iN_j n ds, used for CDG fluxes + real, dimension(mesh_dim(U),ele_loc(U,ele),ele_loc(U,ele)) :: & + & normal_mat + + ! \Int_{s_ele} N_iN_j kappa.n ds, used for CDG fluxes + ! Note that this assumes same order polys in each element + ! Code will need reorganising for p-refinement + real, dimension(mesh_dim(U),face_loc(U,face),face_loc(U,face)) :: & + & kappa_normal_mat + + ! Face objects and numberings. + type(element_type), pointer :: u_shape, u_shape_2, p_shape, q_shape + integer, dimension(face_loc(U,face)) :: u_face_l + ! This has to be a pointer to work around a stupid gcc bug. + integer, dimension(:), pointer :: q_face_l + + ! Note that both sides of the face can be assumed to have the same + ! number of quadrature points. + real, dimension(face_ngi(U_nl, face)) :: Rho_q, nvfrac_gi + real, dimension(U%dim, face_ngi(U_nl, face)) :: normal, u_nl_q,& + & u_f_q, u_f2_q, div_u_f_q + logical, dimension(face_ngi(U_nl, face)) :: inflow + real, dimension(face_ngi(U_nl, face)) :: u_nl_q_dotn, income + ! Variable transform times quadrature weights. + real, dimension(face_ngi(U,face)) :: detwei + real, dimension(face_ngi(U,face)) :: inner_advection_integral, outer_advection_integral + + ! Bilinear forms + real, dimension(face_loc(U,face),face_loc(U,face)) :: nnAdvection_out + real, dimension(face_loc(U,face),face_loc(U,face_2)) :: nnAdvection_in + real, dimension(1,mesh_dim(U), face_loc(P,face),face_loc(U,face)) :: mnCT + + ! Viscosity values on face (used for CDG and IP fluxes) + real, dimension(:,:,:), allocatable :: kappa_gi + + ! surfacetension stuff + real, dimension(u%dim, u%dim, face_ngi(u_nl, face)) :: tension_q + + integer :: dim, start, finish, floc + logical :: boundary, free_surface, no_normal_flow, l_have_pressure_bc + logical, dimension(U%dim) :: dirichlet + + logical :: p0 - if(dg.and.(have_viscosity.or.have_advection)) then + integer :: d1, d2 - ! first the diagonal blocks, i.e. the coupling within the element - ! and neighbouring face nodes but with the same component - if(have_viscosity) then - if(partial_stress) then - call addto(big_m, local_glno, local_glno, & - big_m_tensor_addto) - else - ! add to the matrix - call addto(big_m, local_glno, local_glno, big_m_tensor_addto, & - block_mask=diagonal_block_mask) - end if - ! add to the rhs - call addto(rhs, local_glno, rhs_addto) - else - ! add to the matrix - call addto(big_m, u_ele, local_glno, big_m_tensor_addto(:,:,:loc,:), & - block_mask=diagonal_block_mask) - ! add to the rhs - call addto(rhs, u_ele, rhs_addto(:,:loc)) - end if - if(subcycle) then - call addto(subcycle_m, u_ele, local_glno,& - &subcycle_m_tensor_addto(:,:,:loc,:), & - &block_mask=diagonal_block_mask) - call addto(subcycle_rhs, u_ele, subcycle_rhs_addto) - end if - if(.not. partial_stress .and. have_coriolis) then - ! add in coupling between different components, but only within the element - call addto(big_m, u_ele, u_ele, & - big_m_tensor_addto(:,:,:loc,:loc), block_mask& - &=off_diagonal_block_mask) - end if - else - ! in this case we only have coupling between nodes within the element - if (have_coriolis) then - call addto(big_m, u_ele, u_ele, big_m_tensor_addto(:,:,:loc,:loc)) - else - ! add to the matrix - call addto(big_m, u_ele, u_ele, big_m_tensor_addto(:,:,:loc,:loc), & - block_mask=diagonal_block_mask) - end if - ! add to the rhs - call addto(rhs, u_ele, rhs_addto(:,:loc)) - end if - - end if - - - contains - - subroutine local_assembly_arbitrary_upwind - integer :: d3 - - do dim1=1, Viscosity%dim(1) - do dim2=1,Viscosity%dim(2) - do d3 = 1, mesh_dim(U) - ! Div U * G^U * Viscosity * G * Grad U - ! Where G^U*G = inverse(Q_mass) - Viscosity_mat(d3,d3,:,:)=Viscosity_mat(d3,d3,:,:)& - +0.5*( & - +matmul(matmul(transpose(grad_U_mat_q(dim1,:,:))& - & ,mat_diag_mat(Q_inv, Viscosity_ele(dim1,dim2,:)))& - & ,grad_U_mat_q(dim2,:,:))& - +matmul(matmul(transpose(div_U_mat_q(dim1,:,:))& - & ,mat_diag_mat(Q_inv, Viscosity_ele(dim1,dim2,:)))& - & ,div_U_mat_q(dim2,:,:))& - &) - end do - end do - end do + floc = face_loc(u, face) - end subroutine local_assembly_arbitrary_upwind + start=ele_loc(u,ele)+(ni-1)*face_loc(U, face_2)+1 + finish=start+face_loc(U, face_2)-1 - subroutine local_assembly_bassi_rebay + p0=(element_degree(u,ele)==0) - integer :: d3 + ! Get Density and (non-linear) PhaseVolumeFraction values + ! at the Gauss points on the current face. + Rho_q=face_val_at_quad(Rho, face) - do dim1=1, Viscosity%dim(1) - do dim2=1,Viscosity%dim(2) - do d3 = 1, mesh_dim(U) + if(multiphase) then + nvfrac_gi = face_val_at_quad(nvfrac, face) + end if - ! Div U * G^U * Viscosity * G * Grad U - ! Where G^U*G = inverse(Q_mass) - Viscosity_mat(d3,d3,:,:)=Viscosity_mat(d3,d3,:,:)& - +matmul(matmul(transpose(grad_U_mat_q(dim1,:,:))& - & ,mat_diag_mat(Q_inv, Viscosity_ele(dim1,dim2,:)))& - & ,grad_U_mat_q(dim2,:,:)) + if(present(viscosity)) then + allocate( kappa_gi(Viscosity%dim(1), Viscosity%dim(2), & + face_ngi(Viscosity,face)) ) - end do - end do - end do + kappa_gi = face_val_at_quad(Viscosity, face) - end subroutine local_assembly_bassi_rebay - - subroutine local_assembly_bassi_rebay_stress_form - - ! Instead of: - ! M_v = G^T_m (\nu Q^{-1})_mn G_n - ! We construct: - ! M_v_rs = G^T_m A_rmsn Q^{-1} G_n - ! where A is a dim x dim x dim x dim linear operator: - ! A_rmsn = \partial ( \nu ( u_{r,m} + u_{m,r} ) ) / \partial u_{s,n} - ! where a_{b,c} = \partial a_b / \partial x_c - ! off diagonal terms define the coupling between the velocity components - - real, dimension(size(Q_inv,1), size(Q_inv,2)) :: Q_visc - real, dimension(ele_loc(u, ele)) :: isotropic_visc - - dim = Viscosity%dim(1) - isotropic_visc = Viscosity_ele(1,1,:) - if (have_les) then - call les_viscosity(isotropic_visc) - end if - Q_visc = mat_diag_mat(Q_inv, isotropic_visc) - - do dim1=1,u%dim - do dim2=1,u%dim - do dim3=1,u%dim - do dim4=1,u%dim - if (dim1==dim2 .and. dim2==dim3 .and. dim3==dim4) then - Viscosity_mat(dim1,dim3,:,:) = Viscosity_mat(dim1,dim3,:,:) & - + 2.0 * matmul(matmul(transpose(grad_U_mat_q(dim2,:,:)),Q_visc),grad_U_mat_q(dim4,:,:)) - else if ((dim1==dim3 .and. dim2==dim4) .or. (dim2==dim3 .and. dim1==dim4)) then - Viscosity_mat(dim1,dim3,:,:) = Viscosity_mat(dim1,dim3,:,:) & - + matmul(matmul(transpose(grad_U_mat_q(dim2,:,:)),Q_visc),grad_U_mat_q(dim4,:,:)) - end if + if(multiphase) then + ! Multiply the viscosity tensor by the PhaseVolumeFraction + ! since kappa = viscosity*vfrac for multiphase flow simulations. + do d1=1,Viscosity%dim(1) + do d2=1,Viscosity%dim(2) + kappa_gi(d1,d2,:) = kappa_gi(d1,d2,:)*nvfrac_gi + end do end do - end do - end do - end do + end if - end subroutine local_assembly_bassi_rebay_stress_form + end if - subroutine add_diagonal_to_tensor(big_m_diag_addto, big_m_tensor_addto) - real, dimension(u%dim, ele_and_faces_loc(u, ele)), intent(in) :: big_m_diag_addto - real, dimension(u%dim, u%dim, ele_and_faces_loc(u, ele), ele_and_faces_loc(u, ele)), intent(inout) :: big_m_tensor_addto + u_face_l=face_local_nodes(U, face) + u_shape=>face_shape(U, face) - integer :: dim, loc + u_shape_2=>face_shape(U, face_2) - forall(dim = 1:size(big_m_diag_addto, 1), loc = 1:size(big_m_diag_addto, 2)) - big_m_tensor_addto(dim, dim, loc, loc) = big_m_tensor_addto(dim, dim, loc, loc) + big_m_diag_addto(dim, loc) - end forall + p_shape=>face_shape(P, face) - end subroutine add_diagonal_to_tensor + q_face_l=>face_local_nodes(q_mesh, face) + q_shape=>face_shape(q_mesh, face) - subroutine les_viscosity(isotropic_visc) + ! Boundary nodes have both faces the same. + boundary=(face==face_2) + dirichlet=.false. + free_surface=.false. + no_normal_flow=.false. + l_have_pressure_bc=.false. + if (boundary) then + do dim=1,U%dim + if (velocity_bc_type(dim,face)==1) then + dirichlet(dim)=.true. + end if + end do + ! free surface b.c. is set for the 1st (normal) component + if (velocity_bc_type(1,face)==2) then + free_surface=.true. + end if + ! no normal flow b.c. is set for the 1st (normal) component + if (velocity_bc_type(1,face)==3) then + ! No normal flow is implemented here by switching off the + ! advection boundary integral. + no_normal_flow=.true. + end if + l_have_pressure_bc = pressure_bc_type(face) > 0 + end if - !!! Calculate LES contribution to the viscosity in the momentum equation. + !---------------------------------------------------------------------- + ! Change of coordinates on face. + !---------------------------------------------------------------------- + call transform_facet_to_physical(X, face,& + & detwei_f=detwei,& + & normal=normal) - !!! This is a Smagorinsky style model + !---------------------------------------------------------------------- + ! Construct bilinear forms. + !---------------------------------------------------------------------- - !!! \nu_{eddy} = C_s Delta x_{grid} | S | where - !!! S= ( \nabla u + \nabla u ^T )/2.0 + if(have_advection.and..not.no_normal_flow) then + ! Advecting velocity at quadrature points. + u_f_q = face_val_at_quad(U_nl, face) + u_f2_q = face_val_at_quad(U_nl, face_2) + U_nl_q=0.5*(u_f_q+u_f2_q) - real, dimension(ele_loc(u,ele)), intent(inout) :: isotropic_visc + if(p0) then + ! in this case the surface integral of u_f_q is zero so we need + ! to modify it to be a suitable measure of divergence + div_u_f_q = U_nl_q + else + div_u_f_q = u_f_q + end if - real, dimension(ele_loc(u,ele)) :: les_filter_width - real, dimension(mesh_dim(u), mesh_dim(u), ele_loc(u,ele)) :: g_nl - real, dimension(mesh_dim(u), mesh_dim(u)) :: s - real, dimension(ele_loc(u,ele)) :: s_mod - real, dimension(ele_loc(u,ele)) :: les_scalar_viscosity, y_wall, y_plus - real, dimension(ele_loc(u,ele), ele_loc(u,ele)) :: M_inv + ! Mesh velocity at quadrature points. + if(move_mesh) then + ! here we assume that U_mesh at face is the same as U_mesh at face_2 + ! if it isn't then you're in trouble because your mesh will tear + ! itself apart + u_nl_q=u_nl_q - face_val_at_quad(U_mesh, face) + ! the velocity on the internal face isn't used again so we can + ! modify it directly here... + u_f_q = u_f_q - face_val_at_quad(U_mesh, face) + end if - ! get inverse mass - M_inv = shape_shape(u_shape, u_shape, detwei) - call invert(M_inv) + u_nl_q_dotn = sum(U_nl_q*normal,1) - ! Compute gradient of non-linear velocity - do dim1=1,mesh_dim(u) - do dim2=1,mesh_dim(u) - ! interior contribution - g_nl(dim1,dim2,:)=matmul(grad_U_mat_q(dim2,:,:loc), ele_val(u_nl,dim1,ele)) + ! Inflow is true if the flow at this gauss point is directed + ! into this element. + inflow= u_nl_q_dotn<0.0 + income = merge(1.0,0.0,inflow) - ! boundary contributions (have to be done seperately as we need to apply bc's at boundaries) - ! local node map counter. - start=loc+1 - do ni=1,size(neigh) - ! get neighbour ele, corresponding faces, and complete local node map - ele_2=neigh(ni) + ! Calculate outflow boundary integral. + ! can anyone think of a way of optimising this more to avoid + ! superfluous operations (i.e. multiplying things by 0 or 1)? - if (ele_2>0) then - ! obtain corresponding faces, and complete local node map - face=ele_face(U, ele_2, ele) - finish=start+face_loc(U, face)-1 - ! for interior faces we use the face values - g_nl(dim1,dim2,:)=g_nl(dim1,dim2,:)+matmul(grad_U_mat_q(dim2,:,start:finish), face_val(u_nl,dim1,face)) + ! first the integral around the inside of the element + ! (this is the flux *out* of the element) + inner_advection_integral = (1.-income)*u_nl_q_dotn + if(.not.integrate_by_parts_once) then + ! i.e. if we're integrating by parts twice + inner_advection_integral = inner_advection_integral & + - sum(u_f_q*normal,1) + end if + if(integrate_conservation_term_by_parts) then + if(integrate_by_parts_once) then + inner_advection_integral = inner_advection_integral & + - (1.-beta)*sum(div_u_f_q*normal,1) else - ! obtain corresponding faces, and complete local node map - face=ele_face(U, ele, ele_2) - finish=start+face_loc(U, face)-1 - ! for boundary faces the value we use depends upon if a weak bc is applied - if (velocity_bc_type(dim1,face)==1) then - ! weak bc! use the bc value - g_nl(dim1,dim2,:)=g_nl(dim1,dim2,:)+matmul(grad_U_mat_q(dim2,:,start:finish), ele_val(velocity_bc,dim1,face)) - else - ! no weak bc, use node values on internal face - g_nl(dim1,dim2,:)=g_nl(dim1,dim2,:)+matmul(grad_U_mat_q(dim2,:,start:finish), face_val(u_nl,dim1,face)) - end if + ! i.e. integrating by parts twice + inner_advection_integral = inner_advection_integral & + + beta*sum(div_u_f_q*normal,1) end if + end if - ! update node map counter - start=start+face_loc(U, face) - end do - - ! apply inverse mass - g_nl(dim1,dim2,:)=matmul(M_inv, g_nl(dim1,dim2,:)) - end do - end do - - ! call calculate_les_grad_u(g_nl) - - ! Compute modulus of strain rate - do i=1,ele_loc(u,ele) - s=0.5*(g_nl(:,:,i)+transpose(g_nl(:,:,i))) - ! Calculate modulus of strain rate - s_mod(i)=sqrt(2*sum(s**2)) - end do - - ! Compute filter width - if (associated(prescribed_filter_width)) then - les_filter_width = ele_val(prescribed_filter_width, ele) - else - ! when using the element size to compute the filter width we assume the filter - ! width is twice the element size - les_filter_width = 2*length_scale_scalar(X, ele) - end if + if(multiphase) then + nnAdvection_out=shape_shape(U_shape, U_shape, & + & inner_advection_integral * detwei * Rho_q * nvfrac_gi) + else + nnAdvection_out=shape_shape(U_shape, U_shape, & + & inner_advection_integral * detwei * Rho_q) + end if - ! apply Van Driest damping functions - if (associated(distance_to_wall)) then - y_wall = ele_val(distance_to_wall, ele) - do i=1,ele_loc(u,ele) - y_plus(i) = y_wall(i) * sqrt(norm2(g_nl(:,:,i)+transpose(g_nl(:,:,i))))/sqrt(isotropic_visc(i)) - end do - les_filter_width = (1 - exp(-1.0*y_plus/25.0))*les_filter_width + ! now the integral around the outside of the element + ! (this is the flux *in* to the element) + outer_advection_integral = income * u_nl_q_dotn + if(multiphase) then + nnAdvection_in=shape_shape(U_shape, U_shape_2, & + & outer_advection_integral * detwei * Rho_q * nvfrac_gi) + else + nnAdvection_in=shape_shape(U_shape, U_shape_2, & + & outer_advection_integral * detwei * Rho_q) + end if - ! debugging fields - if (associated(y_plus_debug)) then - call set(y_plus_debug, ele_nodes(y_plus_debug, ele), y_plus) - end if - end if + do dim = 1, u%dim + + ! Insert advection in matrix. + if(subcycle) then + subcycle_m_tensor_addto(dim, dim, u_face_l, u_face_l) = & + &subcycle_m_tensor_addto(dim, dim, u_face_l, u_face_l) + & + &nnAdvection_out + + if (.not.dirichlet(dim)) then + subcycle_m_tensor_addto(dim, dim, u_face_l, start:finish) = & + &subcycle_m_tensor_addto(dim, dim, u_face_l, start:finish)& + &+nnAdvection_in + else + ! on a Dirichlet boundary, the incoming advection term + ! on the lhs is replaced by the same term on the right using + ! the boundary value - outgoing term is the same as always + ! (meaning no dirichlet bc is applied on outgoing facets) + subcycle_rhs_addto(dim,u_face_l) = subcycle_rhs_addto(dim,u_face_l) & + -matmul(nnAdvection_in,ele_val(velocity_bc,dim,face)) + end if + else + big_m_tensor_addto(dim, dim, u_face_l, u_face_l) = & + big_m_tensor_addto(dim, dim, u_face_l, u_face_l) + & + nnAdvection_out*dt*theta + + if (.not.dirichlet(dim)) then + big_m_tensor_addto(dim, dim, u_face_l, start:finish) = & + big_m_tensor_addto(dim, dim, u_face_l, start:finish) + & + nnAdvection_in*dt*theta + + rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & + -matmul(nnAdvection_out,face_val(U,dim,face))& + -matmul(nnAdvection_in,face_val(U,dim,face_2)) + else + ! on a Dirichlet boundary, the incoming advection term + ! on the lhs is replaced by the same term on the right using + ! the boundary value - outgoing term is the same as always + ! (meaning no dirichlet bc is applied on outgoing facets) + rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & + -matmul(nnAdvection_out,face_val(U,dim,face))& + -matmul(nnAdvection_in,ele_val(velocity_bc,dim,face)) + end if + end if + end do - if (associated(les_filter_width_debug)) then - call set(les_filter_width_debug, ele_nodes(les_filter_width_debug, ele), les_filter_width) end if - les_scalar_viscosity = (les_filter_width*smagorinsky_coefficient)**2 * s_mod - - ! store sgs viscosity - if (associated(eddy_visc)) then - call set(eddy_visc, ele_nodes(eddy_visc, ele), les_scalar_viscosity) - end if - - ! Add to molecular viscosity - isotropic_visc = isotropic_visc + les_scalar_viscosity - - end subroutine les_viscosity - - end subroutine construct_momentum_element_dg - - subroutine construct_momentum_interface_dg(ele, face, face_2, ni, & - & big_m_tensor_addto, & - & rhs_addto, Grad_U_mat, Div_U_mat, X, Rho, U,& - & U_nl, U_mesh, P, q_mesh, surfacetension, & - & velocity_bc, velocity_bc_type, & - & pressure_bc, pressure_bc_type, hb_pressure, & - & subcycle_m_tensor_addto, subcycle_rhs_addto, nvfrac, & - & ele2grad_mat, kappa_mat, inverse_mass_mat, & - & viscosity, viscosity_mat) - !!< Construct the DG element boundary integrals on the ni-th face of - !!< element ele. - implicit none - - logical :: CDG_switch_in - - integer, intent(in) :: ele, face, face_2, ni - real, dimension(:,:,:,:), intent(inout) :: big_m_tensor_addto - real, dimension(:,:,:,:), intent(inout) :: subcycle_m_tensor_addto - real, dimension(:,:), intent(inout) :: rhs_addto, subcycle_rhs_addto - real, dimension(:,:,:), intent(inout) :: Grad_U_mat, Div_U_mat - ! We pass these additional fields to save on state lookups. - type(vector_field), intent(in) :: X, U, U_nl - type(vector_field), pointer :: U_mesh - type(scalar_field), intent(in) :: Rho, P - type(scalar_field), intent(in) :: nvfrac - !! Mesh of the auxiliary variable in the second order operator. - type(mesh_type), intent(in) :: q_mesh - !! surfacetension - type(tensor_field), intent(in) :: surfacetension - !! Boundary conditions associated with this interface (if any). - type(vector_field), intent(in) :: velocity_bc - integer, dimension(:,:), intent(in) :: velocity_bc_type - type(scalar_field), intent(in) :: pressure_bc - integer, dimension(:), intent(in) :: pressure_bc_type - type(scalar_field), intent(in) :: hb_pressure - - !! Computation of primal fluxes and penalty fluxes - real, intent(in), optional, dimension(:,:,:) :: ele2grad_mat - - !! \Int_{ele} N_i kappa N_j dV, used for CDG fluxes - real, dimension(:,:,:,:), intent(in), optional :: kappa_mat - - !! Inverse element mass matrix. - real, dimension(:,:), intent(in), optional :: inverse_mass_mat - - type(tensor_field), intent(in), optional :: viscosity - - !! Local viscosity matrix for assembly. - real, intent(inout), dimension(:,:,:,:), optional :: viscosity_mat - - ! Matrix for assembling primal fluxes - ! Note that this assumes same order polys in each element - ! Code will need reorganising for p-refinement - real, dimension(2,face_loc(U,face),ele_loc(U,ele)) ::& - & primal_fluxes_mat - - ! Matrix for assembling penalty fluxes - ! Note that this assumes same order polys in each element - ! Code will need reorganising for p-refinement - real, dimension(2,face_loc(U,face),face_loc(U,face)) ::& - & penalty_fluxes_mat - - ! \Int_{s_ele} N_iN_j n ds, used for CDG fluxes - real, dimension(mesh_dim(U),ele_loc(U,ele),ele_loc(U,ele)) :: & - & normal_mat - - ! \Int_{s_ele} N_iN_j kappa.n ds, used for CDG fluxes - ! Note that this assumes same order polys in each element - ! Code will need reorganising for p-refinement - real, dimension(mesh_dim(U),face_loc(U,face),face_loc(U,face)) :: & - & kappa_normal_mat - - ! Face objects and numberings. - type(element_type), pointer :: u_shape, u_shape_2, p_shape, q_shape - integer, dimension(face_loc(U,face)) :: u_face_l - ! This has to be a pointer to work around a stupid gcc bug. - integer, dimension(:), pointer :: q_face_l - - ! Note that both sides of the face can be assumed to have the same - ! number of quadrature points. - real, dimension(face_ngi(U_nl, face)) :: Rho_q, nvfrac_gi - real, dimension(U%dim, face_ngi(U_nl, face)) :: normal, u_nl_q,& - & u_f_q, u_f2_q, div_u_f_q - logical, dimension(face_ngi(U_nl, face)) :: inflow - real, dimension(face_ngi(U_nl, face)) :: u_nl_q_dotn, income - ! Variable transform times quadrature weights. - real, dimension(face_ngi(U,face)) :: detwei - real, dimension(face_ngi(U,face)) :: inner_advection_integral, outer_advection_integral - - ! Bilinear forms - real, dimension(face_loc(U,face),face_loc(U,face)) :: nnAdvection_out - real, dimension(face_loc(U,face),face_loc(U,face_2)) :: nnAdvection_in - real, dimension(1,mesh_dim(U), face_loc(P,face),face_loc(U,face)) :: mnCT - - ! Viscosity values on face (used for CDG and IP fluxes) - real, dimension(:,:,:), allocatable :: kappa_gi - - ! surfacetension stuff - real, dimension(u%dim, u%dim, face_ngi(u_nl, face)) :: tension_q - - integer :: dim, start, finish, floc - logical :: boundary, free_surface, no_normal_flow, l_have_pressure_bc - logical, dimension(U%dim) :: dirichlet - - logical :: p0 - - integer :: d1, d2 - - floc = face_loc(u, face) - - start=ele_loc(u,ele)+(ni-1)*face_loc(U, face_2)+1 - finish=start+face_loc(U, face_2)-1 - - p0=(element_degree(u,ele)==0) - - ! Get Density and (non-linear) PhaseVolumeFraction values - ! at the Gauss points on the current face. - Rho_q=face_val_at_quad(Rho, face) - - if(multiphase) then - nvfrac_gi = face_val_at_quad(nvfrac, face) - end if - - if(present(viscosity)) then - allocate( kappa_gi(Viscosity%dim(1), Viscosity%dim(2), & - face_ngi(Viscosity,face)) ) - - kappa_gi = face_val_at_quad(Viscosity, face) - - if(multiphase) then - ! Multiply the viscosity tensor by the PhaseVolumeFraction - ! since kappa = viscosity*vfrac for multiphase flow simulations. - do d1=1,Viscosity%dim(1) - do d2=1,Viscosity%dim(2) - kappa_gi(d1,d2,:) = kappa_gi(d1,d2,:)*nvfrac_gi - end do - end do - end if - - end if - - u_face_l=face_local_nodes(U, face) - u_shape=>face_shape(U, face) - - u_shape_2=>face_shape(U, face_2) - - p_shape=>face_shape(P, face) - - q_face_l=>face_local_nodes(q_mesh, face) - q_shape=>face_shape(q_mesh, face) - - ! Boundary nodes have both faces the same. - boundary=(face==face_2) - dirichlet=.false. - free_surface=.false. - no_normal_flow=.false. - l_have_pressure_bc=.false. - if (boundary) then - do dim=1,U%dim - if (velocity_bc_type(dim,face)==1) then - dirichlet(dim)=.true. - end if - end do - ! free surface b.c. is set for the 1st (normal) component - if (velocity_bc_type(1,face)==2) then - free_surface=.true. - end if - ! no normal flow b.c. is set for the 1st (normal) component - if (velocity_bc_type(1,face)==3) then - ! No normal flow is implemented here by switching off the - ! advection boundary integral. - no_normal_flow=.true. - end if - l_have_pressure_bc = pressure_bc_type(face) > 0 - end if - - !---------------------------------------------------------------------- - ! Change of coordinates on face. - !---------------------------------------------------------------------- - call transform_facet_to_physical(X, face,& - & detwei_f=detwei,& - & normal=normal) - - !---------------------------------------------------------------------- - ! Construct bilinear forms. - !---------------------------------------------------------------------- - - if(have_advection.and..not.no_normal_flow) then - ! Advecting velocity at quadrature points. - u_f_q = face_val_at_quad(U_nl, face) - u_f2_q = face_val_at_quad(U_nl, face_2) - U_nl_q=0.5*(u_f_q+u_f2_q) - - if(p0) then - ! in this case the surface integral of u_f_q is zero so we need - ! to modify it to be a suitable measure of divergence - div_u_f_q = U_nl_q - else - div_u_f_q = u_f_q - end if + if (have_viscosity) then + ! Boundary term in grad_U. + ! / + ! | q, u, normal dx + ! / + select case (viscosity_scheme) + case (ARBITRARY_UPWIND) + call arbitrary_upwind_viscosity + case (BASSI_REBAY) + call bassi_rebay_viscosity + case (IP) + primal_fluxes_mat = 0.0 + penalty_fluxes_mat = 0.0 + call primal_fluxes + call interior_penalty + call local_assembly_primal_face + call local_assembly_ip_face + case (CDG) + primal_fluxes_mat = 0.0 + penalty_fluxes_mat = 0.0 + call primal_fluxes + if(.not.remove_penalty_fluxes) call interior_penalty + call get_normal_mat + call local_assembly_primal_face + call local_assembly_cdg_face + call local_assembly_ip_face + end select - ! Mesh velocity at quadrature points. - if(move_mesh) then - ! here we assume that U_mesh at face is the same as U_mesh at face_2 - ! if it isn't then you're in trouble because your mesh will tear - ! itself apart - u_nl_q=u_nl_q - face_val_at_quad(U_mesh, face) - ! the velocity on the internal face isn't used again so we can - ! modify it directly here... - u_f_q = u_f_q - face_val_at_quad(U_mesh, face) - end if - - u_nl_q_dotn = sum(U_nl_q*normal,1) - - ! Inflow is true if the flow at this gauss point is directed - ! into this element. - inflow= u_nl_q_dotn<0.0 - income = merge(1.0,0.0,inflow) - - ! Calculate outflow boundary integral. - ! can anyone think of a way of optimising this more to avoid - ! superfluous operations (i.e. multiplying things by 0 or 1)? - - ! first the integral around the inside of the element - ! (this is the flux *out* of the element) - inner_advection_integral = (1.-income)*u_nl_q_dotn - if(.not.integrate_by_parts_once) then - ! i.e. if we're integrating by parts twice - inner_advection_integral = inner_advection_integral & - - sum(u_f_q*normal,1) - end if - if(integrate_conservation_term_by_parts) then - if(integrate_by_parts_once) then - inner_advection_integral = inner_advection_integral & - - (1.-beta)*sum(div_u_f_q*normal,1) - else - ! i.e. integrating by parts twice - inner_advection_integral = inner_advection_integral & - + beta*sum(div_u_f_q*normal,1) - end if end if - if(multiphase) then - nnAdvection_out=shape_shape(U_shape, U_shape, & - & inner_advection_integral * detwei * Rho_q * nvfrac_gi) - else - nnAdvection_out=shape_shape(U_shape, U_shape, & - & inner_advection_integral * detwei * Rho_q) + if(have_surfacetension.and.integrate_surfacetension_by_parts) then + tension_q = 0.5*face_val_at_quad(surfacetension,face)+0.5*face_val_at_quad(surfacetension,face_2) + rhs_addto(:,u_face_l) = rhs_addto(:,u_face_l) + shape_tensor_dot_vector_rhs(u_shape, tension_q, normal, detwei) end if - ! now the integral around the outside of the element - ! (this is the flux *in* to the element) - outer_advection_integral = income * u_nl_q_dotn - if(multiphase) then - nnAdvection_in=shape_shape(U_shape, U_shape_2, & - & outer_advection_integral * detwei * Rho_q * nvfrac_gi) - else - nnAdvection_in=shape_shape(U_shape, U_shape_2, & - & outer_advection_integral * detwei * Rho_q) - end if - do dim = 1, u%dim + !---------------------------------------------------------------------- + ! Perform global assembly. + !---------------------------------------------------------------------- - ! Insert advection in matrix. - if(subcycle) then - subcycle_m_tensor_addto(dim, dim, u_face_l, u_face_l) = & - &subcycle_m_tensor_addto(dim, dim, u_face_l, u_face_l) + & - &nnAdvection_out + ! Insert pressure boundary integral. + if (l_include_pressure_bcs .and. boundary .and. l_have_pressure_bc) then - if (.not.dirichlet(dim)) then - subcycle_m_tensor_addto(dim, dim, u_face_l, start:finish) = & - &subcycle_m_tensor_addto(dim, dim, u_face_l, start:finish)& - &+nnAdvection_in - else - ! on a Dirichlet boundary, the incoming advection term - ! on the lhs is replaced by the same term on the right using - ! the boundary value - outgoing term is the same as always - ! (meaning no dirichlet bc is applied on outgoing facets) - subcycle_rhs_addto(dim,u_face_l) = subcycle_rhs_addto(dim,u_face_l) & - -matmul(nnAdvection_in,ele_val(velocity_bc,dim,face)) - end if + if(multiphase) then + mnCT(1,:,:,:) = shape_shape_vector(P_shape, U_shape_2, detwei*nvfrac_gi, normal) else - big_m_tensor_addto(dim, dim, u_face_l, u_face_l) = & - big_m_tensor_addto(dim, dim, u_face_l, u_face_l) + & - nnAdvection_out*dt*theta - - if (.not.dirichlet(dim)) then - big_m_tensor_addto(dim, dim, u_face_l, start:finish) = & - big_m_tensor_addto(dim, dim, u_face_l, start:finish) + & - nnAdvection_in*dt*theta - - rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & - -matmul(nnAdvection_out,face_val(U,dim,face))& - -matmul(nnAdvection_in,face_val(U,dim,face_2)) + mnCT(1,:,:,:) = shape_shape_vector(P_shape, U_shape_2, detwei, normal) + end if + ! for both weak and strong pressure dirichlet bcs: + ! / + ! add -| N_i M_j \vec n p_j, where p_j are the prescribed bc values + ! / + do dim = 1, U%dim + if(subtract_out_reference_profile) then + rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) - & + matmul( ele_val(pressure_bc, face) - face_val(hb_pressure, face), mnCT(1,dim,:,:) ) else - ! on a Dirichlet boundary, the incoming advection term - ! on the lhs is replaced by the same term on the right using - ! the boundary value - outgoing term is the same as always - ! (meaning no dirichlet bc is applied on outgoing facets) - rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & - -matmul(nnAdvection_out,face_val(U,dim,face))& - -matmul(nnAdvection_in,ele_val(velocity_bc,dim,face)) + rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) - & + matmul( ele_val(pressure_bc, face), mnCT(1,dim,:,:) ) end if - end if - end do - - end if - - if (have_viscosity) then - ! Boundary term in grad_U. - ! / - ! | q, u, normal dx - ! / - select case (viscosity_scheme) - case (ARBITRARY_UPWIND) - call arbitrary_upwind_viscosity - case (BASSI_REBAY) - call bassi_rebay_viscosity - case (IP) - primal_fluxes_mat = 0.0 - penalty_fluxes_mat = 0.0 - call primal_fluxes - call interior_penalty - call local_assembly_primal_face - call local_assembly_ip_face - case (CDG) - primal_fluxes_mat = 0.0 - penalty_fluxes_mat = 0.0 - call primal_fluxes - if(.not.remove_penalty_fluxes) call interior_penalty - call get_normal_mat - call local_assembly_primal_face - call local_assembly_cdg_face - call local_assembly_ip_face - end select - - end if - - if(have_surfacetension.and.integrate_surfacetension_by_parts) then - tension_q = 0.5*face_val_at_quad(surfacetension,face)+0.5*face_val_at_quad(surfacetension,face_2) - rhs_addto(:,u_face_l) = rhs_addto(:,u_face_l) + shape_tensor_dot_vector_rhs(u_shape, tension_q, normal, detwei) - end if - - - !---------------------------------------------------------------------- - ! Perform global assembly. - !---------------------------------------------------------------------- - - ! Insert pressure boundary integral. - if (l_include_pressure_bcs .and. boundary .and. l_have_pressure_bc) then - - if(multiphase) then - mnCT(1,:,:,:) = shape_shape_vector(P_shape, U_shape_2, detwei*nvfrac_gi, normal) - else - mnCT(1,:,:,:) = shape_shape_vector(P_shape, U_shape_2, detwei, normal) - end if - ! for both weak and strong pressure dirichlet bcs: - ! / - ! add -| N_i M_j \vec n p_j, where p_j are the prescribed bc values - ! / - do dim = 1, U%dim - if(subtract_out_reference_profile) then - rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) - & - matmul( ele_val(pressure_bc, face) - face_val(hb_pressure, face), mnCT(1,dim,:,:) ) - else - rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) - & - matmul( ele_val(pressure_bc, face), mnCT(1,dim,:,:) ) - end if - end do - end if + end do + end if contains - subroutine arbitrary_upwind_viscosity + subroutine arbitrary_upwind_viscosity - !! Arbitrary upwinding scheme. - do dim=1,mesh_dim(U) + !! Arbitrary upwinding scheme. + do dim=1,mesh_dim(U) - if (normal(dim,1)>0) then - ! Internal face. - Grad_U_mat(dim, q_face_l, U_face_l)=& + if (normal(dim,1)>0) then + ! Internal face. + Grad_U_mat(dim, q_face_l, U_face_l)=& Grad_U_mat(dim, q_face_l, U_face_l) & +shape_shape(q_shape, U_shape, detwei*normal(dim,:)) - ! External face. Note the sign change which is caused by the - ! divergence matrix being constructed in transpose. - Div_U_mat(dim, q_face_l, start:finish)=& + ! External face. Note the sign change which is caused by the + ! divergence matrix being constructed in transpose. + Div_U_mat(dim, q_face_l, start:finish)=& -shape_shape(q_shape, U_shape_2, detwei*normal(dim,:)) - ! Internal face. - Div_U_mat(dim, q_face_l, U_face_l)=& + ! Internal face. + Div_U_mat(dim, q_face_l, U_face_l)=& Div_U_mat(dim, q_face_l, U_face_l) & +shape_shape(q_shape, U_shape, detwei*normal(dim,:)) - else - ! External face. - Grad_U_mat(dim, q_face_l, start:finish)=& + else + ! External face. + Grad_U_mat(dim, q_face_l, start:finish)=& +shape_shape(q_shape, U_shape_2, detwei*normal(dim,:)) - end if - end do + end if + end do - end subroutine arbitrary_upwind_viscosity + end subroutine arbitrary_upwind_viscosity - subroutine bassi_rebay_viscosity + subroutine bassi_rebay_viscosity - real, dimension(face_ngi(u_nl, face)) :: coefficient_detwei + real, dimension(face_ngi(u_nl, face)) :: coefficient_detwei - do dim=1,mesh_dim(U) + do dim=1,mesh_dim(U) - coefficient_detwei = detwei*normal(dim,:) - if(multiphase) then - coefficient_detwei = coefficient_detwei*nvfrac_gi - end if + coefficient_detwei = detwei*normal(dim,:) + if(multiphase) then + coefficient_detwei = coefficient_detwei*nvfrac_gi + end if - if(.not.boundary) then - ! Internal face. - Grad_U_mat(dim, q_face_l, U_face_l)=& - Grad_U_mat(dim, q_face_l, U_face_l) & - +0.5*shape_shape(q_shape, U_shape, coefficient_detwei) + if(.not.boundary) then + ! Internal face. + Grad_U_mat(dim, q_face_l, U_face_l)=& + Grad_U_mat(dim, q_face_l, U_face_l) & + +0.5*shape_shape(q_shape, U_shape, coefficient_detwei) - ! External face. - Grad_U_mat(dim, q_face_l, start:finish)=& - +0.5*shape_shape(q_shape, U_shape_2, coefficient_detwei) - else - ! Boundary case. Put the whole integral in the external bit. + ! External face. + Grad_U_mat(dim, q_face_l, start:finish)=& + +0.5*shape_shape(q_shape, U_shape_2, coefficient_detwei) + else + ! Boundary case. Put the whole integral in the external bit. - ! External face. - Grad_U_mat(dim, q_face_l, start:finish)=& - +shape_shape(q_shape, U_shape_2, coefficient_detwei) - end if - end do + ! External face. + Grad_U_mat(dim, q_face_l, start:finish)=& + +shape_shape(q_shape, U_shape_2, coefficient_detwei) + end if + end do - end subroutine bassi_rebay_viscosity + end subroutine bassi_rebay_viscosity - subroutine get_normal_mat - !!< We assemble - !!< \int_e N_i N_j n dS - !!< where n is the normal - !!< indices are (dim1, loc1, loc2) + subroutine get_normal_mat + !!< We assemble + !!< \int_e N_i N_j n dS + !!< where n is the normal + !!< indices are (dim1, loc1, loc2) - integer :: d1,d2 + integer :: d1,d2 - normal_mat = shape_shape_vector(U_shape,U_shape,detwei,normal) + normal_mat = shape_shape_vector(U_shape,U_shape,detwei,normal) - !!< We assemble - !!< \int_e N_i N_j kappa.n dS - !!< where n is the normal - !!< indices are (dim1, loc1, loc2) + !!< We assemble + !!< \int_e N_i N_j kappa.n dS + !!< where n is the normal + !!< indices are (dim1, loc1, loc2) - kappa_normal_mat = 0 - do d1 = 1, mesh_dim(U) - do d2 = 1, mesh_dim(U) - kappa_normal_mat(d1,:,:) = kappa_normal_mat(d1,:,:) + & - & shape_shape(U_shape,U_shape,detwei* & - & kappa_gi(d1,d2,:)*normal(d2,:)) + kappa_normal_mat = 0 + do d1 = 1, mesh_dim(U) + do d2 = 1, mesh_dim(U) + kappa_normal_mat(d1,:,:) = kappa_normal_mat(d1,:,:) + & + & shape_shape(U_shape,U_shape,detwei* & + & kappa_gi(d1,d2,:)*normal(d2,:)) + end do end do - end do - end subroutine get_normal_mat + end subroutine get_normal_mat - subroutine primal_fluxes + subroutine primal_fluxes - !!< Notes for primal fluxes which are present in the interior penalty - !!< and CDG methods (and, I believe, the LDG method when written in - !! primal form) + !!< Notes for primal fluxes which are present in the interior penalty + !!< and CDG methods (and, I believe, the LDG method when written in + !! primal form) - !!< We assemble + !!< We assemble - !!< -Int_e [u]{kappa grad v} + [v]{kappa grad u} + !!< -Int_e [u]{kappa grad v} + [v]{kappa grad u} - !!< = -Int_e 1/2(u^+n^+ + u^-n^-).(kappa^+ grad v^+ + kappa^- grad v^-) - !!< -Int_e 1/2(v^+n^+ + v^-n^-).(kappa^+ grad u^+ + kappa^- grad u^-) + !!< = -Int_e 1/2(u^+n^+ + u^-n^-).(kappa^+ grad v^+ + kappa^- grad v^-) + !!< -Int_e 1/2(v^+n^+ + v^-n^-).(kappa^+ grad u^+ + kappa^- grad u^-) - !!< Where + is the ele side, and - is the ele_2 side, and e is the edge + !!< Where + is the ele side, and - is the ele_2 side, and e is the edge - !! + !!< C_{12} = either (1/2)n^+ or (1/2)n^- + !!< Take (1/2)n^+ if switch_g . n^+> - !!0 and plus otherwise + !!< where we take the minus if switch_g.n^+>0 and plus otherwise - !!< Note that this means that it cancels the primal term if - !!0) - if(CDG_switch_in) flux_factor = 1.0 - else - flux_factor = 0.5 - CDG_switch_in = .true. - end if + if(viscosity_scheme==CDG) then + flux_factor = 0.0 + CDG_switch_in = (sum(switch_g(1:mesh_dim(U))*sum(normal,2)/size(normal,2))>0) + if(CDG_switch_in) flux_factor = 1.0 + else + flux_factor = 0.5 + CDG_switch_in = .true. + end if - do d1 = 1, mesh_dim(U) - do d2 = 1, mesh_dim(U) - ! -Int_e 1/2 (u^+ - u^-)n^+.kappa^+ grad v^+ - if(.not.boundary) then - ! Internal face. - if(CDG_switch_in) then - primal_fluxes_mat(1,:,:) =& - primal_fluxes_mat(1,:,:)& - -flux_factor*matmul( & - shape_shape(U_shape,U_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,U_face_l,:)) + do d1 = 1, mesh_dim(U) + do d2 = 1, mesh_dim(U) + ! -Int_e 1/2 (u^+ - u^-)n^+.kappa^+ grad v^+ + if(.not.boundary) then + ! Internal face. + if(CDG_switch_in) then + primal_fluxes_mat(1,:,:) =& + primal_fluxes_mat(1,:,:)& + -flux_factor*matmul( & + shape_shape(U_shape,U_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,U_face_l,:)) + + ! External face. + primal_fluxes_mat(2,:,:) =& + primal_fluxes_mat(2,:,:)& + +flux_factor*matmul( & + shape_shape(U_shape,U_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,U_face_l,:)) + end if + else + !If a Dirichlet boundary, we add these terms, otherwise not. - ! External face. + !we do the entire integral on the inside face + primal_fluxes_mat(1,:,:) =& + primal_fluxes_mat(1,:,:)& + -matmul( & + shape_shape(U_shape,U_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,U_face_l,:)) + + !There is also a corresponding boundary condition integral + !on the RHS primal_fluxes_mat(2,:,:) =& - primal_fluxes_mat(2,:,:)& - +flux_factor*matmul( & - shape_shape(U_shape,U_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,U_face_l,:)) + primal_fluxes_mat(2,:,:)& + +matmul( & + shape_shape(U_shape,U_shape, & + & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & + ele2grad_mat(d2,U_face_l,:)) end if - else - !If a Dirichlet boundary, we add these terms, otherwise not. - - !we do the entire integral on the inside face - primal_fluxes_mat(1,:,:) =& - primal_fluxes_mat(1,:,:)& - -matmul( & - shape_shape(U_shape,U_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,U_face_l,:)) - - !There is also a corresponding boundary condition integral - !on the RHS - primal_fluxes_mat(2,:,:) =& - primal_fluxes_mat(2,:,:)& - +matmul( & - shape_shape(U_shape,U_shape, & - & detwei * normal(d1,:) * kappa_gi(d1,d2,:)), & - ele2grad_mat(d2,U_face_l,:)) - end if + end do end do - end do - end subroutine primal_fluxes + end subroutine primal_fluxes - subroutine interior_penalty + subroutine interior_penalty - !! Ripped from Advection_Diffusion_DG.F90 == cjc + !! Ripped from Advection_Diffusion_DG.F90 == cjc - !! We assemble + !! We assemble - !! Int_e [u][v] + !! Int_e [u][v] - !! = Int_e C(u^+n^+ + u^-n^-).(v^+n^+ + v^-n^-) + !! = Int_e C(u^+n^+ + u^-n^-).(v^+n^+ + v^-n^-) - !! Where + is the ele side, and - is the ele_2 side, and e is the edge - !! and C is the penalty parameter + !! Where + is the ele side, and - is the ele_2 side, and e is the edge + !! and C is the penalty parameter - !! We are only storing trial functions from this element, so - !! will assemble the u^+ parts only, the u^- parts will be done - !! from the other side + !! We are only storing trial functions from this element, so + !! will assemble the u^+ parts only, the u^- parts will be done + !! from the other side - !!So we assemble + !!So we assemble - !! Int_e C u^+ (v^+ - v^-) + !! Int_e C u^+ (v^+ - v^-) - !!On the (Dirichlet) boundary we are assembling + !!On the (Dirichlet) boundary we are assembling - !! Int_e C uv + !! Int_e C uv - !! In practise we'll assemble it everywhere and only - !! add it on if we have a Dirichlet boundary + !! In practise we'll assemble it everywhere and only + !! add it on if we have a Dirichlet boundary - !! penalty_fluxes_mat(1,:,:) maps from internal face dof - !! to internal face dof - !! penalty_fluxes_mat(2,:,:) maps from internal face dof - !! to external face dof - !! or face boundary conditions + !! penalty_fluxes_mat(1,:,:) maps from internal face dof + !! to internal face dof + !! penalty_fluxes_mat(2,:,:) maps from internal face dof + !! to external face dof + !! or face boundary conditions - ! Penalty parameter is C_0/h where h is the distance between the - ! cell centre and the neighbours cell centre + ! Penalty parameter is C_0/h where h is the distance between the + ! cell centre and the neighbours cell centre - real :: C_h - integer :: nf, d1, d2 + real :: C_h + integer :: nf, d1, d2 - real, dimension(size(kappa_gi,3)) :: kappa_n - nf = face_loc(U,face) + real, dimension(size(kappa_gi,3)) :: kappa_n + nf = face_loc(U,face) - kappa_n = 0.0 - do d1 = 1, mesh_dim(U) - do d2 = 1, mesh_dim(U) - kappa_n = kappa_n + & - normal(d1,:)*kappa_gi(d1,d2,:)*normal(d2,:) + kappa_n = 0.0 + do d1 = 1, mesh_dim(U) + do d2 = 1, mesh_dim(U) + kappa_n = kappa_n + & + normal(d1,:)*kappa_gi(d1,d2,:)*normal(d2,:) + end do end do - end do - if(EDGE_LENGTH_OPTION==USE_FACE_INTEGRALS) then - h0 = sum(detwei) - if(mesh_dim(U)==3) h0 = sqrt(h0) - end if + if(EDGE_LENGTH_OPTION==USE_FACE_INTEGRALS) then + h0 = sum(detwei) + if(mesh_dim(U)==3) h0 = sqrt(h0) + end if - if(cdg_penalty) then - C_h = Interior_Penalty_Parameter - else - C_h = Interior_Penalty_Parameter*(h0**edge_length_power) - end if + if(cdg_penalty) then + C_h = Interior_Penalty_Parameter + else + C_h = Interior_Penalty_Parameter*(h0**edge_length_power) + end if - !If a dirichlet boundary then we add these terms, otherwise not + !If a dirichlet boundary then we add these terms, otherwise not - penalty_fluxes_mat(1,:,:) =& - penalty_fluxes_mat(1,:,:)+& - ! C_h*shape_shape(U_shape,U_shape,detwei) - C_h*shape_shape(U_shape,U_shape,detwei*kappa_n) + penalty_fluxes_mat(1,:,:) =& + penalty_fluxes_mat(1,:,:)+& + ! C_h*shape_shape(U_shape,U_shape,detwei) + C_h*shape_shape(U_shape,U_shape,detwei*kappa_n) - penalty_fluxes_mat(2,:,:) =& - penalty_fluxes_mat(2,:,:)-& - !C_h*shape_shape(U_shape,U_shape,detwei) - C_h*shape_shape(U_shape,U_shape,detwei*kappa_n) + penalty_fluxes_mat(2,:,:) =& + penalty_fluxes_mat(2,:,:)-& + !C_h*shape_shape(U_shape,U_shape,detwei) + C_h*shape_shape(U_shape,U_shape,detwei*kappa_n) - end subroutine interior_penalty + end subroutine interior_penalty - subroutine local_assembly_ip_face - implicit none + subroutine local_assembly_ip_face + implicit none - integer :: d - integer :: nfele, nele - integer, dimension(face_loc(U,face)) :: U_face_loc + integer :: d + integer :: nfele, nele + integer, dimension(face_loc(U,face)) :: U_face_loc - nfele = face_loc(U,face) - nele = ele_loc(U,ele) - u_face_loc=face_local_nodes(U, face) + nfele = face_loc(U,face) + nele = ele_loc(U,ele) + u_face_loc=face_local_nodes(U, face) - if (boundary) then - do d=1,U%dim - if(dirichlet(d)) then - !!These terms are not included on Neumann integrals + if (boundary) then + do d=1,U%dim + if(dirichlet(d)) then + !!These terms are not included on Neumann integrals + + !! Internal Degrees of Freedom + + !penalty flux + Viscosity_mat(d,d,u_face_loc,u_face_loc) = & + Viscosity_mat(d,d,u_face_loc,u_face_loc) + & + penalty_fluxes_mat(1,:,:) + + !! External Degrees of Freedom + + !!penalty fluxes + + Viscosity_mat(d,d,u_face_loc,start:finish) = & + Viscosity_mat(d,d,u_face_loc,start:finish) + & + penalty_fluxes_mat(2,:,:) + + end if + end do + else + do d=1,U%dim !! Internal Degrees of Freedom !penalty flux Viscosity_mat(d,d,u_face_loc,u_face_loc) = & - Viscosity_mat(d,d,u_face_loc,u_face_loc) + & - penalty_fluxes_mat(1,:,:) + Viscosity_mat(d,d,u_face_loc,u_face_loc) + & + penalty_fluxes_mat(1,:,:) !! External Degrees of Freedom !!penalty fluxes Viscosity_mat(d,d,u_face_loc,start:finish) = & - Viscosity_mat(d,d,u_face_loc,start:finish) + & - penalty_fluxes_mat(2,:,:) + Viscosity_mat(d,d,u_face_loc,start:finish) + & + penalty_fluxes_mat(2,:,:) - end if - end do - else - do d=1,U%dim - !! Internal Degrees of Freedom + end do + end if - !penalty flux + end subroutine local_assembly_ip_face - Viscosity_mat(d,d,u_face_loc,u_face_loc) = & - Viscosity_mat(d,d,u_face_loc,u_face_loc) + & - penalty_fluxes_mat(1,:,:) + subroutine local_assembly_primal_face + implicit none - !! External Degrees of Freedom + integer :: j,d + integer :: nele + integer, dimension(face_loc(U,face)) :: U_face_loc - !!penalty fluxes + nele = ele_loc(U,ele) + u_face_loc=face_local_nodes(U, face) - Viscosity_mat(d,d,u_face_loc,start:finish) = & - Viscosity_mat(d,d,u_face_loc,start:finish) + & - penalty_fluxes_mat(2,:,:) - end do - end if + if (boundary) then + do d=1,U%dim + if(dirichlet(d)) then + !!These terms are not included on Neumann integrals - end subroutine local_assembly_ip_face + !! Internal Degrees of Freedom - subroutine local_assembly_primal_face - implicit none + !primal fluxes - integer :: j,d - integer :: nele - integer, dimension(face_loc(U,face)) :: U_face_loc + Viscosity_mat(d,d,u_face_loc,1:nele) = & + Viscosity_mat(d,d,u_face_loc,1:nele) + & + primal_fluxes_mat(1,:,:) - nele = ele_loc(U,ele) - u_face_loc=face_local_nodes(U, face) + do j = 1, size(u_face_loc) + Viscosity_mat(d,d,1:nele,u_face_loc(j)) = & + Viscosity_mat(d,d,1:nele,u_face_loc(j)) + & + primal_fluxes_mat(1,j,:) + end do + !primal fluxes - if (boundary) then - do d=1,U%dim - if(dirichlet(d)) then - !!These terms are not included on Neumann integrals + Viscosity_mat(d,d,1:nele,start:finish) = & + Viscosity_mat(d,d,1:nele,start:finish) + & + transpose(primal_fluxes_mat(2,:,:)) + end if + end do + else + do d=1,U%dim !! Internal Degrees of Freedom !primal fluxes Viscosity_mat(d,d,u_face_loc,1:nele) = & - Viscosity_mat(d,d,u_face_loc,1:nele) + & - primal_fluxes_mat(1,:,:) + Viscosity_mat(d,d,u_face_loc,1:nele) + & + primal_fluxes_mat(1,:,:) do j = 1, size(u_face_loc) Viscosity_mat(d,d,1:nele,u_face_loc(j)) = & - Viscosity_mat(d,d,1:nele,u_face_loc(j)) + & - primal_fluxes_mat(1,j,:) + Viscosity_mat(d,d,1:nele,u_face_loc(j)) + & + primal_fluxes_mat(1,j,:) end do - !primal fluxes - - Viscosity_mat(d,d,1:nele,start:finish) = & - Viscosity_mat(d,d,1:nele,start:finish) + & - transpose(primal_fluxes_mat(2,:,:)) + !! External Degrees of Freedom - end if - end do - else - do d=1,U%dim - !! Internal Degrees of Freedom + !primal fluxes - !primal fluxes + Viscosity_mat(d,d,start:finish,1:nele) = & + Viscosity_mat(d,d,start:finish,1:nele) + & + primal_fluxes_mat(2,:,:) - Viscosity_mat(d,d,u_face_loc,1:nele) = & - Viscosity_mat(d,d,u_face_loc,1:nele) + & - primal_fluxes_mat(1,:,:) + Viscosity_mat(d,d,1:nele,start:finish) = & + Viscosity_mat(d,d,1:nele,start:finish) + & + transpose(primal_fluxes_mat(2,:,:)) - do j = 1, size(u_face_loc) - Viscosity_mat(d,d,1:nele,u_face_loc(j)) = & - Viscosity_mat(d,d,1:nele,u_face_loc(j)) + & - primal_fluxes_mat(1,j,:) end do + end if - !! External Degrees of Freedom - - !primal fluxes - - Viscosity_mat(d,d,start:finish,1:nele) = & - Viscosity_mat(d,d,start:finish,1:nele) + & - primal_fluxes_mat(2,:,:) - - Viscosity_mat(d,d,1:nele,start:finish) = & - Viscosity_mat(d,d,1:nele,start:finish) + & - transpose(primal_fluxes_mat(2,:,:)) - - end do - end if - - end subroutine local_assembly_primal_face - - subroutine local_assembly_cdg_face - implicit none - !!< This code assembles the cdg fluxes involving the r_e and l_e lifting - !!< operators. - - !!< We assemble the operator - !!< \int (r^e([v]) + l^e(C_{12}.[v]) + r^e_D(v).\kappa. - !!< (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u))dV (*) - !!< This is done by forming the operator R: - !!< \int v R(u)dV = \int v (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u)) dV - !!< and then constructing - !!< \int R(v).\kappa.R(u) dV - - !!< The lifting operator r^e is defined by - !!< \int_E \tau . r^e([u]) dV = - \int_e {\tau}.[u] dS - !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.(u^+n^+ + u^-n^-) dS - !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS - - !!< Where + is the ele side, and - is the ele_2 side, and e is the edge - - !!< The lifting operator l^e is defined by - !!< \int_E \tau . l^e(C_{12}.[u])dV = - \int_e C_{12}.[u][\tau] dS - !!< = -\int C_{12}.(u^+n^+ + u^-n^-)(\tau^+.n^+ +\tau^-n^-) dS - - !!< C_{12} = either (1/2)n^+ or (1/2)n^- - !!< Take (1/2)n^+ if switch_g . n^+> 0 - - !!becomes - !!< = \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS - !!< with minus sign if switch_g n^+ > 0 - - !!< So adding r^e and l^e gives - - !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS - !!< + \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS - - !!< = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch_g n^+ > 0 - !!< = -\int_e \tau^-.n^+(u^+ - u^-) dS otherwise - - !!< so definition of r^e+l^e operator is - !!< \int_E \tau.R(u) dV = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch > 0 - !!< \int_E \tau.R(u) dV = -\int_e \tau^-.n^+(u^+ - u^-) dS if switch < 0 - - !!< we are doing DG so the basis functions which are non-zero in E are - !!< zero outside E, so \tau^- vanishes in this formula, so we get - !!< \int_E \tau.R(u) dV = -\int_e \tau.n^+(u^+ - u^-) dS if switch > 0 - !!< and R(u) = 0 otherwise. - - !!< finally the boundary lifting operator r^e_D - !!< \int_E \tau.r^e_D(u) dV = -\int_e u\tau.n dS - - !!< We assemble the binary form (*) locally with - !!< B(u,v) = p^TR^T.K.Rq, where p is the vector of coefficients of u in - !!< element E plus the coefficients of u on the face e on the other side - !!< K is the matrix obtained from the bilinear form - !!< \int_E N_i \kappa N_j dV where \kappa is the viscosity tensor and - !! N_i are the basis functions with support in element E - - !!< The matrix R maps from the coefficients of a scalar field on both sides of face e - !!< to the coefficients of a vector field with inside element E - !!< i.e. size (dim x loc(E),2 x loc(e)) - !!< because of symmetry we just store (dim x loc(E), loc(e)) values - !!< The matrix K maps from vector fields inside element E to vector - !!< fields inside element E - !!< i.e. size (dim x loc(E), dim x loc(E)) - !!< Hence, R^TKR maps from the coefficients of a scalar field on both - !!< sides of face e to themselves - !!< i.e. size (2 x loc(E), 2 x - !!< It can be thus interpreted as a fancy penalty term for - !!< discontinuities, a useful one because it is scale invariant - - !!< The matrix R can be formed by constructing the bilinear form matrix - !!< for r^e, l^e and r^e_D, and then dividing by the elemental mass - !!< matrix on E - - !!< we place R^TKR into Viscosity_mat which maps from u - !!< coefficients in element E plus those on the other side of face e - !!< to themselves, hence it has size (loc(E) + loc(e), loc(E) + loc(e)) - - !!< R^TKR is stored in add_mat which has size(2 x loc(e), 2 x loc(e)) - - !!< we are using a few other pre-assembled local matrices - !!< normal_mat is \int_e \tau.(un) dS (has size (dim x loc(e),loc(e)) - !!< normal_kappa_mat is \int_e \tau.\kappa.(un) dS - !!< has size (dim x loc(e), loc(e)) - !!< inverse_mass_mat is the inverse mass in E - - integer :: i,j,d1,d2,nele,face1,face2,d - integer, dimension(face_loc(U,face)) :: U_face_loc - real, dimension(mesh_dim(U),ele_loc(U,ele),face_loc(U,face)) :: R_mat - real, dimension(2,2,face_loc(U,face),face_loc(U,face)) :: add_mat - - nele = ele_loc(U,ele) - u_face_loc=face_local_nodes(U, face) - - R_mat = 0. - do d1 = 1, mesh_dim(U) - do i = 1, ele_loc(U,ele) - do j = 1, face_loc(U,face) - R_mat(d1,i,j) = & - &sum(inverse_mass_mat(i,u_face_loc)*normal_mat(d1,:,j)) + end subroutine local_assembly_primal_face + + subroutine local_assembly_cdg_face + implicit none + !!< This code assembles the cdg fluxes involving the r_e and l_e lifting + !!< operators. + + !!< We assemble the operator + !!< \int (r^e([v]) + l^e(C_{12}.[v]) + r^e_D(v).\kappa. + !!< (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u))dV (*) + !!< This is done by forming the operator R: + !!< \int v R(u)dV = \int v (r^e([u]) + l^e(C_{12}.[u]) + r^e_D(u)) dV + !!< and then constructing + !!< \int R(v).\kappa.R(u) dV + + !!< The lifting operator r^e is defined by + !!< \int_E \tau . r^e([u]) dV = - \int_e {\tau}.[u] dS + !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.(u^+n^+ + u^-n^-) dS + !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS + + !!< Where + is the ele side, and - is the ele_2 side, and e is the edge + + !!< The lifting operator l^e is defined by + !!< \int_E \tau . l^e(C_{12}.[u])dV = - \int_e C_{12}.[u][\tau] dS + !!< = -\int C_{12}.(u^+n^+ + u^-n^-)(\tau^+.n^+ +\tau^-n^-) dS + + !!< C_{12} = either (1/2)n^+ or (1/2)n^- + !!< Take (1/2)n^+ if switch_g . n^+> 0 + + !!becomes + !!< = \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS + !!< with minus sign if switch_g n^+ > 0 + + !!< So adding r^e and l^e gives + + !!< = -\frac{1}{2} \int_e {\tau^+ + \tau^-}.n^+(u^+ - u^-) dS + !!< + \int_e (- or +)(u^+ - u^-)n^+.(\tau^+ - \tau^-) dS + + !!< = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch_g n^+ > 0 + !!< = -\int_e \tau^-.n^+(u^+ - u^-) dS otherwise + + !!< so definition of r^e+l^e operator is + !!< \int_E \tau.R(u) dV = -\int_e \tau^+.n^+(u^+ - u^-) dS if switch > 0 + !!< \int_E \tau.R(u) dV = -\int_e \tau^-.n^+(u^+ - u^-) dS if switch < 0 + + !!< we are doing DG so the basis functions which are non-zero in E are + !!< zero outside E, so \tau^- vanishes in this formula, so we get + !!< \int_E \tau.R(u) dV = -\int_e \tau.n^+(u^+ - u^-) dS if switch > 0 + !!< and R(u) = 0 otherwise. + + !!< finally the boundary lifting operator r^e_D + !!< \int_E \tau.r^e_D(u) dV = -\int_e u\tau.n dS + + !!< We assemble the binary form (*) locally with + !!< B(u,v) = p^TR^T.K.Rq, where p is the vector of coefficients of u in + !!< element E plus the coefficients of u on the face e on the other side + !!< K is the matrix obtained from the bilinear form + !!< \int_E N_i \kappa N_j dV where \kappa is the viscosity tensor and + !! N_i are the basis functions with support in element E + + !!< The matrix R maps from the coefficients of a scalar field on both sides of face e + !!< to the coefficients of a vector field with inside element E + !!< i.e. size (dim x loc(E),2 x loc(e)) + !!< because of symmetry we just store (dim x loc(E), loc(e)) values + !!< The matrix K maps from vector fields inside element E to vector + !!< fields inside element E + !!< i.e. size (dim x loc(E), dim x loc(E)) + !!< Hence, R^TKR maps from the coefficients of a scalar field on both + !!< sides of face e to themselves + !!< i.e. size (2 x loc(E), 2 x + !!< It can be thus interpreted as a fancy penalty term for + !!< discontinuities, a useful one because it is scale invariant + + !!< The matrix R can be formed by constructing the bilinear form matrix + !!< for r^e, l^e and r^e_D, and then dividing by the elemental mass + !!< matrix on E + + !!< we place R^TKR into Viscosity_mat which maps from u + !!< coefficients in element E plus those on the other side of face e + !!< to themselves, hence it has size (loc(E) + loc(e), loc(E) + loc(e)) + + !!< R^TKR is stored in add_mat which has size(2 x loc(e), 2 x loc(e)) + + !!< we are using a few other pre-assembled local matrices + !!< normal_mat is \int_e \tau.(un) dS (has size (dim x loc(e),loc(e)) + !!< normal_kappa_mat is \int_e \tau.\kappa.(un) dS + !!< has size (dim x loc(e), loc(e)) + !!< inverse_mass_mat is the inverse mass in E + + integer :: i,j,d1,d2,nele,face1,face2,d + integer, dimension(face_loc(U,face)) :: U_face_loc + real, dimension(mesh_dim(U),ele_loc(U,ele),face_loc(U,face)) :: R_mat + real, dimension(2,2,face_loc(U,face),face_loc(U,face)) :: add_mat + + nele = ele_loc(U,ele) + u_face_loc=face_local_nodes(U, face) + + R_mat = 0. + do d1 = 1, mesh_dim(U) + do i = 1, ele_loc(U,ele) + do j = 1, face_loc(U,face) + R_mat(d1,i,j) = & + &sum(inverse_mass_mat(i,u_face_loc)*normal_mat(d1,:,j)) + end do end do end do - end do - do d=1,U%dim - - add_mat = 0.0 - if(boundary) then - if (dirichlet(d)) then - !Boundary case - ! R(/tau,u) = -\int_e \tau.n u dS - !do d1 = 1, mesh_dim(U) - ! do d2 = 1, mesh_dim(U) - ! add_mat(1,1,:,:) = add_mat(1,1,:,:) + & - ! matmul(transpose(R_mat(d1,:,:)), & - ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - ! add_mat(2,2,:,:) = add_mat(2,2,:,:) + & - ! matmul(transpose(R_mat(d1,:,:)), & - ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - ! end do - !end do + do d=1,U%dim + + add_mat = 0.0 + if(boundary) then + if (dirichlet(d)) then + !Boundary case + ! R(/tau,u) = -\int_e \tau.n u dS + !do d1 = 1, mesh_dim(U) + ! do d2 = 1, mesh_dim(U) + ! add_mat(1,1,:,:) = add_mat(1,1,:,:) + & + ! matmul(transpose(R_mat(d1,:,:)), & + ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) + ! add_mat(2,2,:,:) = add_mat(2,2,:,:) + & + ! matmul(transpose(R_mat(d1,:,:)), & + ! &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) + ! end do + !end do + + do face1 = 1, 2 + do face2 = 1, 2 + do d1 = 1, mesh_dim(U) + do d2 = 1, mesh_dim(U) + add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & + &(-1.)**(face1+face2)*matmul(transpose(R_mat(d1,:,:)), & + &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) + end do + end do + end do + end do + end if + else if(CDG_switch_in) then + ! interior case + ! R(\tau,u) = -\int_e \tau.n^+(u^+ - u^-) dS do face1 = 1, 2 do face2 = 1, 2 do d1 = 1, mesh_dim(U) do d2 = 1, mesh_dim(U) add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & - &(-1.)**(face1+face2)*matmul(transpose(R_mat(d1,:,:)), & - &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) + &(-1.)**(face1+face2)*matmul(transpose(R_mat(d1,:,:)), & + &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) end do end do end do end do - end if - else if(CDG_switch_in) then - ! interior case - ! R(\tau,u) = -\int_e \tau.n^+(u^+ - u^-) dS - do face1 = 1, 2 - do face2 = 1, 2 - do d1 = 1, mesh_dim(U) - do d2 = 1, mesh_dim(U) - add_mat(face1,face2,:,:) = add_mat(face1,face2,:,:) + & - &(-1.)**(face1+face2)*matmul(transpose(R_mat(d1,:,:)), & - &matmul(kappa_mat(d1,d2,:,:),R_mat(d2,:,:))) - end do - end do - end do - end do - end if - !face1 = 1, face2 = 1 + !face1 = 1, face2 = 1 - Viscosity_mat(d,d,u_face_loc,u_face_loc) = & - &Viscosity_mat(d,d,u_face_loc,u_face_loc) + & - &add_mat(1,1,:,:) + Viscosity_mat(d,d,u_face_loc,u_face_loc) = & + &Viscosity_mat(d,d,u_face_loc,u_face_loc) + & + &add_mat(1,1,:,:) - !face1 = 1, face2 = 2 + !face1 = 1, face2 = 2 - Viscosity_mat(d,d,u_face_loc,start:finish) = & - &Viscosity_mat(d,d,u_face_loc,start:finish) + & - &add_mat(1,2,:,:) + Viscosity_mat(d,d,u_face_loc,start:finish) = & + &Viscosity_mat(d,d,u_face_loc,start:finish) + & + &add_mat(1,2,:,:) - !face1 = 2, face2 = 1 + !face1 = 2, face2 = 1 - Viscosity_mat(d,d,start:finish,u_face_loc) = & - Viscosity_mat(d,d,start:finish,u_face_loc) + & - &add_mat(2,1,:,:) + Viscosity_mat(d,d,start:finish,u_face_loc) = & + Viscosity_mat(d,d,start:finish,u_face_loc) + & + &add_mat(2,1,:,:) - !face1 = 2, face2 = 2 + !face1 = 2, face2 = 2 - Viscosity_mat(d,d,start:finish,start:finish) = & - &Viscosity_mat(d,d,start:finish,start:finish) + & - &add_mat(2,2,:,:) - end do + Viscosity_mat(d,d,start:finish,start:finish) = & + &Viscosity_mat(d,d,start:finish,start:finish) + & + &add_mat(2,2,:,:) + end do - end subroutine local_assembly_cdg_face - - end subroutine construct_momentum_interface_dg - - subroutine subcycle_momentum_dg(u, mom_rhs, subcycle_m, subcycle_rhs, inverse_mass, state) - type(vector_field), intent(inout) :: u - type(vector_field), intent(inout):: mom_rhs - type(block_csr_matrix), intent(in):: subcycle_m, inverse_mass - type(vector_field), intent(in):: subcycle_rhs - type(state_type), intent(inout):: state - - type(vector_field) :: u_sub, m_delta_u, delta_u - type(scalar_field), pointer :: courant_number_field - type(scalar_field) :: u_cpt - real :: max_courant_number - integer :: d, i, subcycles - logical :: limit_slope - - ewrite(1,*) 'Inside subcycle_momentum_dg' - - !Always limit slope using VB limiter if subcycling - !If we get suitable alternative limiter options we shall use them - limit_slope = .true. - - call get_option(trim(u%option_path)//& - &"/prognostic/temporal_discretisation"//& - &"/discontinuous_galerkin/maximum_courant_number_per_subcycle",& - &max_courant_number) - courant_number_field => & - extract_scalar_field(state, "DG_CourantNumber") - call calculate_diagnostic_variable(state, & - "DG_CourantNumber", & - & courant_number_field) - subcycles = ceiling( maxval(courant_number_field%val)& - &/max_courant_number) - call allmax(subcycles) - ewrite(2,*) 'Number of subcycles: ', subcycles - if (subcycles==0) return - - call allocate(u_sub, u%dim, u%mesh, "SubcycleU") - u_sub%option_path = trim(u%option_path) - call set(u_sub, u) - - ! aux. field to store increment between subcycles - call allocate(delta_u, u%dim, u%mesh, "SubcycleDeltaU") - ! aux. field that incrementally computes M (u^sub-u^n)/dt - call allocate(m_delta_u, u%dim, u%mesh, "SubcycleMDeltaU") - call zero(m_delta_u) - - do i=1, subcycles - if (limit_slope) then - - ! filter wiggles from u - do d =1, mesh_dim(u) - u_cpt = extract_scalar_field_from_vector_field(u_sub,d) - call limit_vb(state,u_cpt) - end do - - end if - - ! du = advection * u - f_adv - call mult(delta_u, subcycle_m, u_sub) - ! -f_adv for bc terms - call addto(delta_u, subcycle_rhs, scale=-1.0) - ! M*du/dt = M*du/dt - advection * u + f_adv - call addto(m_delta_u, delta_u, scale=-1.0/subcycles) - - ! we're only interested in m_delta_u, so we may leave early: - if (i==subcycles) exit - - ! du = m^(-1) du - call dg_apply_mass(inverse_mass, delta_u) - - ! u = u - dt/s * du - call addto(u_sub, delta_u, scale=-dt/subcycles) - call halo_update(u_sub) - - end do - - ewrite_minmax(delta_u) - - !update RHS of momentum equation - - ! here is the low-down: - ! - ! This is what we get from construct_momentum_dg: - ! big_m = M + dt*theta*K, where K are any terms not included in subcycling (viscosity, coriolis etc.) - ! mom_rhs = f - K u^n - ! This is what we want to solve: - ! M (u^sub - u^n)/dt + A u^n = f_adv, assuming one subcycle here - ! M (u^n+1 - u^sub)/dt + K u^n+theta = f - ! The last eqn can be rewritten: - ! M (u^n+1 - u^n)/dt - M (u^sub - u^n)/dt + K u^n + dt*theta*K (u^n+1-u^n)/dt = f - ! i.o.w.: - ! big_m (u^n+1 - u^n)/dt = f - K u^n + M (u^sub - u^n)/dt - ! This means mom_rhs needs to have M (u^sub - u^n)/dt added in - ! and the implicit big_m solve computes a du/dt starting from u^n and not u^sub! - ! Therefor this sub doesn't actually change u, but only adds in the explicit advection - ! to the rhs of the mom eqn. - - call addto(mom_rhs, m_delta_u) - - call deallocate(m_delta_u) - call deallocate(u_sub) - call deallocate(delta_u) - - end subroutine subcycle_momentum_dg - - ! The Coordinate and Solution fields of a turbine simulation live on a non-periodic mesh (that is with option remove-periodicity). - ! This function takes such a field's mesh and returns the periodic mesh from which it is derived. - recursive function get_periodic_mesh(state, mesh) result(periodic_mesh) - type(state_type), intent(in) :: state - type(mesh_type), intent(in) :: mesh - type(mesh_type) :: periodic_mesh - character(len=OPTION_PATH_LEN) :: option_path - character(len=4096) :: derived_meshname - integer :: stat - - option_path=mesh%option_path - if (have_option(trim(mesh%option_path) // '/from_mesh')) then - call get_option(trim(mesh%option_path) // '/from_mesh/mesh/name', derived_meshname, stat) - assert(stat==0) - if (have_option(trim(mesh%option_path) // '/from_mesh/periodic_boundary_conditions/remove_periodicity')) then - periodic_mesh=extract_mesh(state, derived_meshname, stat) - else - periodic_mesh=get_periodic_mesh(state, extract_mesh(state, derived_meshname, stat)) - end if - assert(stat==0) - else - FLExit("A periodic mesh with remove_periodicity has to be used in combination with the turbine model.") - end if - end function get_periodic_mesh - - subroutine allocate_big_m_dg(state, big_m, u) - !!< This routine allocates big_m as a petsc_csr_matrix without explicitly - !!< constructing a sparsity, but only working the number of local and non-local - !!< nonzero entries per row. As this should be a reasonably cheap operation this - !!< is done every non-linear iteration. - !!< Assumptions: - !!< - contiguous numbering of owned nodes and elements - !!< - number of nodes per element is the same - !!< - both test and trial space are discontinuous - type(state_type) :: state - type(petsc_csr_matrix), intent(out):: big_m - type(vector_field), intent(in):: u - - !! NOTE: use_element_blocks only works if all element have the same number of nodes - logical:: use_element_blocks - - character(len=FIELD_NAME_LEN):: pc - type(halo_type), pointer:: halo - integer, dimension(:), pointer:: neighbours, neighbours2, nodes - integer, dimension(:), allocatable:: dnnz, onnz - logical:: compact_stencil, have_viscosity, have_coriolis, have_advection, have_turbine, partial_stress - integer:: rows_per_dim, rows, nonods, elements - integer:: owned_neighbours, foreign_neighbours, coupled_components, coupled_components_ele - integer:: i, j, dim, ele, nloc - type(mesh_type) :: neigh_mesh - - assert( continuity(u)<0 ) - - compact_stencil = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/interior_penalty") .or. & - &have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/compact_discontinuous_galerkin") - - ! NOTE: this only sets the local have_viscosity, have_advection, have_coriolis and partial stress - have_viscosity = have_option(trim(u%option_path)//& - &"/prognostic/tensor_field::Viscosity") - have_advection = .not. have_option(trim(u%option_path)//"/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin"//& - &"/advection_scheme/none") - have_coriolis = have_option("/physical_parameters/coriolis") - partial_stress = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/viscosity_scheme"//& - &"/partial_stress_form") + end subroutine local_assembly_cdg_face + + end subroutine construct_momentum_interface_dg + + subroutine subcycle_momentum_dg(u, mom_rhs, subcycle_m, subcycle_rhs, inverse_mass, state) + type(vector_field), intent(inout) :: u + type(vector_field), intent(inout):: mom_rhs + type(block_csr_matrix), intent(in):: subcycle_m, inverse_mass + type(vector_field), intent(in):: subcycle_rhs + type(state_type), intent(inout):: state + + type(vector_field) :: u_sub, m_delta_u, delta_u + type(scalar_field), pointer :: courant_number_field + type(scalar_field) :: u_cpt + real :: max_courant_number + integer :: d, i, subcycles + logical :: limit_slope + + ewrite(1,*) 'Inside subcycle_momentum_dg' + + !Always limit slope using VB limiter if subcycling + !If we get suitable alternative limiter options we shall use them + limit_slope = .true. + + call get_option(trim(u%option_path)//& + &"/prognostic/temporal_discretisation"//& + &"/discontinuous_galerkin/maximum_courant_number_per_subcycle",& + &max_courant_number) + courant_number_field => & + extract_scalar_field(state, "DG_CourantNumber") + call calculate_diagnostic_variable(state, & + "DG_CourantNumber", & + & courant_number_field) + subcycles = ceiling( maxval(courant_number_field%val)& + &/max_courant_number) + call allmax(subcycles) + ewrite(2,*) 'Number of subcycles: ', subcycles + if (subcycles==0) return + + call allocate(u_sub, u%dim, u%mesh, "SubcycleU") + u_sub%option_path = trim(u%option_path) + call set(u_sub, u) + + ! aux. field to store increment between subcycles + call allocate(delta_u, u%dim, u%mesh, "SubcycleDeltaU") + ! aux. field that incrementally computes M (u^sub-u^n)/dt + call allocate(m_delta_u, u%dim, u%mesh, "SubcycleMDeltaU") + call zero(m_delta_u) + + do i=1, subcycles + if (limit_slope) then + + ! filter wiggles from u + do d =1, mesh_dim(u) + u_cpt = extract_scalar_field_from_vector_field(u_sub,d) + call limit_vb(state,u_cpt) + end do + + end if + + ! du = advection * u - f_adv + call mult(delta_u, subcycle_m, u_sub) + ! -f_adv for bc terms + call addto(delta_u, subcycle_rhs, scale=-1.0) + ! M*du/dt = M*du/dt - advection * u + f_adv + call addto(m_delta_u, delta_u, scale=-1.0/subcycles) + + ! we're only interested in m_delta_u, so we may leave early: + if (i==subcycles) exit + + ! du = m^(-1) du + call dg_apply_mass(inverse_mass, delta_u) + + ! u = u - dt/s * du + call addto(u_sub, delta_u, scale=-dt/subcycles) + call halo_update(u_sub) - ! It would be enough to set this variable to true only if there is a flux turbine. - ! However, for performance reasons, this is done whenever a turbine model is in use. - have_turbine = have_option("/turbine_model") + end do - ! some preconditioners do not support petsc block matrix - call get_option(trim(u%option_path)// & + ewrite_minmax(delta_u) + + !update RHS of momentum equation + + ! here is the low-down: + ! + ! This is what we get from construct_momentum_dg: + ! big_m = M + dt*theta*K, where K are any terms not included in subcycling (viscosity, coriolis etc.) + ! mom_rhs = f - K u^n + ! This is what we want to solve: + ! M (u^sub - u^n)/dt + A u^n = f_adv, assuming one subcycle here + ! M (u^n+1 - u^sub)/dt + K u^n+theta = f + ! The last eqn can be rewritten: + ! M (u^n+1 - u^n)/dt - M (u^sub - u^n)/dt + K u^n + dt*theta*K (u^n+1-u^n)/dt = f + ! i.o.w.: + ! big_m (u^n+1 - u^n)/dt = f - K u^n + M (u^sub - u^n)/dt + ! This means mom_rhs needs to have M (u^sub - u^n)/dt added in + ! and the implicit big_m solve computes a du/dt starting from u^n and not u^sub! + ! Therefor this sub doesn't actually change u, but only adds in the explicit advection + ! to the rhs of the mom eqn. + + call addto(mom_rhs, m_delta_u) + + call deallocate(m_delta_u) + call deallocate(u_sub) + call deallocate(delta_u) + + end subroutine subcycle_momentum_dg + + ! The Coordinate and Solution fields of a turbine simulation live on a non-periodic mesh (that is with option remove-periodicity). + ! This function takes such a field's mesh and returns the periodic mesh from which it is derived. + recursive function get_periodic_mesh(state, mesh) result(periodic_mesh) + type(state_type), intent(in) :: state + type(mesh_type), intent(in) :: mesh + type(mesh_type) :: periodic_mesh + character(len=OPTION_PATH_LEN) :: option_path + character(len=4096) :: derived_meshname + integer :: stat + + option_path=mesh%option_path + if (have_option(trim(mesh%option_path) // '/from_mesh')) then + call get_option(trim(mesh%option_path) // '/from_mesh/mesh/name', derived_meshname, stat) + assert(stat==0) + if (have_option(trim(mesh%option_path) // '/from_mesh/periodic_boundary_conditions/remove_periodicity')) then + periodic_mesh=extract_mesh(state, derived_meshname, stat) + else + periodic_mesh=get_periodic_mesh(state, extract_mesh(state, derived_meshname, stat)) + end if + assert(stat==0) + else + FLExit("A periodic mesh with remove_periodicity has to be used in combination with the turbine model.") + end if + end function get_periodic_mesh + + subroutine allocate_big_m_dg(state, big_m, u) + !!< This routine allocates big_m as a petsc_csr_matrix without explicitly + !!< constructing a sparsity, but only working the number of local and non-local + !!< nonzero entries per row. As this should be a reasonably cheap operation this + !!< is done every non-linear iteration. + !!< Assumptions: + !!< - contiguous numbering of owned nodes and elements + !!< - number of nodes per element is the same + !!< - both test and trial space are discontinuous + type(state_type) :: state + type(petsc_csr_matrix), intent(out):: big_m + type(vector_field), intent(in):: u + + !! NOTE: use_element_blocks only works if all element have the same number of nodes + logical:: use_element_blocks + + character(len=FIELD_NAME_LEN):: pc + type(halo_type), pointer:: halo + integer, dimension(:), pointer:: neighbours, neighbours2, nodes + integer, dimension(:), allocatable:: dnnz, onnz + logical:: compact_stencil, have_viscosity, have_coriolis, have_advection, have_turbine, partial_stress + integer:: rows_per_dim, rows, nonods, elements + integer:: owned_neighbours, foreign_neighbours, coupled_components, coupled_components_ele + integer:: i, j, dim, ele, nloc + type(mesh_type) :: neigh_mesh + + assert( continuity(u)<0 ) + + compact_stencil = have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/interior_penalty") .or. & + &have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/compact_discontinuous_galerkin") + + ! NOTE: this only sets the local have_viscosity, have_advection, have_coriolis and partial stress + have_viscosity = have_option(trim(u%option_path)//& + &"/prognostic/tensor_field::Viscosity") + have_advection = .not. have_option(trim(u%option_path)//"/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin"//& + &"/advection_scheme/none") + have_coriolis = have_option("/physical_parameters/coriolis") + partial_stress = have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/viscosity_scheme"//& + &"/partial_stress_form") + + ! It would be enough to set this variable to true only if there is a flux turbine. + ! However, for performance reasons, this is done whenever a turbine model is in use. + have_turbine = have_option("/turbine_model") + + ! some preconditioners do not support petsc block matrix + call get_option(trim(u%option_path)// & &"/prognostic/solver/preconditioner/name", pc) - use_element_blocks = .not. (pc=="eisenstat" .or. pc=="mg" & - .or. compact_stencil) + use_element_blocks = .not. (pc=="eisenstat" .or. pc=="mg" & + .or. compact_stencil) - if (have_turbine) then + if (have_turbine) then neigh_mesh=get_periodic_mesh(state, u%mesh) - else + else neigh_mesh=u%mesh - end if - if (associated(u%mesh%halos)) then - halo => u%mesh%halos(1) - rows_per_dim=halo_nowned_nodes(halo) - else - nullify(halo) - rows_per_dim=node_count(u) - end if - if (use_element_blocks) rows_per_dim=rows_per_dim/ele_loc(u,1) - - rows=rows_per_dim*u%dim - allocate( dnnz(1:rows), onnz(1:rows) ) - - coupled_components = 0 - coupled_components_ele = 0 - if (partial_stress) then - coupled_components = u%dim - 1 - else if (have_coriolis) then - coupled_components_ele = u%dim -1 - end if - - ! we first work everything out for rows corresponding to the first component - do ele=1, element_count(u) - ! we only have to provide nnz for owned rows. The owner - ! therefore needs to specify the correct nnzs including - ! contributions from others. - ! NOTE: that the allocate interface assumes a contiguous - ! numbering of owned nodes and elements - if (.not. element_owned(u, ele)) cycle - - ! for each element work out the number of neighbours it talks to - - ! this is for zeroth order (i.e. without advection and viscosity) - owned_neighbours = 0 - foreign_neighbours = 0 - - if (have_viscosity .or. have_advection) then - ! start with first order - neighbours => ele_neigh(neigh_mesh, ele) - do i=1, size(neighbours) - ! skip boundaries - if (neighbours(i)<=0) cycle - if (element_owned(u, neighbours(i))) then - owned_neighbours = owned_neighbours+1 - else - foreign_neighbours = foreign_neighbours+1 - end if - end do - end if - - ! Added brackes around (.not. compact_stencil), check this - if (have_viscosity .and. (.not. compact_stencil)) then - ! traverse the second order neighbours - do i=1, size(neighbours) - ! skip boundaries - if (neighbours(i)<=0) cycle - - neighbours2 => ele_neigh(neigh_mesh, neighbours(i)) - do j=1, size(neighbours2) - ! skip boundaries: - if (neighbours2(j)<=0) cycle - ! prevent double counting: - if (neighbours2(j)==ele .or. any(neighbours==neighbours2(j))) cycle - - if (element_owned(u, neighbours2(j))) then - owned_neighbours = owned_neighbours + 1 - else - foreign_neighbours = foreign_neighbours + 1 - end if - end do - end do - end if - - if (.not. use_element_blocks) then - nodes => ele_nodes(u, ele) - ! NOTE: there is an assumption here that n/o nodes of the neighbours - ! is equal to that of ele (so in fact is the same for all elements) - ! We need to do something more complicated if this is no longer true - nloc = size(nodes) - do i=1, nloc - ! this break down as follows: - ! 1 for node-node coupling of the same component within the element - ! owned_neighbours for node-node coupling of the same component with 1st or 2nd order neighbours - ! coupled components_ele for node-node coupling with different components only within the element - ! note: no coupling with different components of neighbouring elements as long as we're in tensor form - ! coupled components for node-node coupling with different components - dnnz( nodes(i) ) = ( (1+owned_neighbours)*(coupled_components+1) + coupled_components_ele) * nloc - ! this breaks down as follows: - ! foreign_neighbours for node-node coupling of the same component with neighbours that are owned by an other process - ! note: coriolis only couples within the element and is therefore always completely local - onnz( nodes(i) ) = foreign_neighbours*(coupled_components+1) * nloc - end do + end if + if (associated(u%mesh%halos)) then + halo => u%mesh%halos(1) + rows_per_dim=halo_nowned_nodes(halo) else - ! see above for reasoning - dnnz(ele)=(1+owned_neighbours)*(coupled_components+1) + coupled_components_ele - onnz(ele)=foreign_neighbours*(coupled_components+1) + nullify(halo) + rows_per_dim=node_count(u) + end if + if (use_element_blocks) rows_per_dim=rows_per_dim/ele_loc(u,1) + + rows=rows_per_dim*u%dim + allocate( dnnz(1:rows), onnz(1:rows) ) + + coupled_components = 0 + coupled_components_ele = 0 + if (partial_stress) then + coupled_components = u%dim - 1 + else if (have_coriolis) then + coupled_components_ele = u%dim -1 end if - end do - ! then copy to rows of other components - do dim=2, u%dim - dnnz( (dim-1)*rows_per_dim+1:dim*rows_per_dim ) = dnnz(1:rows_per_dim) - onnz( (dim-1)*rows_per_dim+1:dim*rows_per_dim ) = onnz(1:rows_per_dim) - end do + ! we first work everything out for rows corresponding to the first component + do ele=1, element_count(u) + ! we only have to provide nnz for owned rows. The owner + ! therefore needs to specify the correct nnzs including + ! contributions from others. + ! NOTE: that the allocate interface assumes a contiguous + ! numbering of owned nodes and elements + if (.not. element_owned(u, ele)) cycle + + ! for each element work out the number of neighbours it talks to + + ! this is for zeroth order (i.e. without advection and viscosity) + owned_neighbours = 0 + foreign_neighbours = 0 + + if (have_viscosity .or. have_advection) then + ! start with first order + neighbours => ele_neigh(neigh_mesh, ele) + do i=1, size(neighbours) + ! skip boundaries + if (neighbours(i)<=0) cycle + if (element_owned(u, neighbours(i))) then + owned_neighbours = owned_neighbours+1 + else + foreign_neighbours = foreign_neighbours+1 + end if + end do + end if + + ! Added brackes around (.not. compact_stencil), check this + if (have_viscosity .and. (.not. compact_stencil)) then + ! traverse the second order neighbours + do i=1, size(neighbours) + ! skip boundaries + if (neighbours(i)<=0) cycle + + neighbours2 => ele_neigh(neigh_mesh, neighbours(i)) + do j=1, size(neighbours2) + ! skip boundaries: + if (neighbours2(j)<=0) cycle + ! prevent double counting: + if (neighbours2(j)==ele .or. any(neighbours==neighbours2(j))) cycle + + if (element_owned(u, neighbours2(j))) then + owned_neighbours = owned_neighbours + 1 + else + foreign_neighbours = foreign_neighbours + 1 + end if + end do + end do + end if + + if (.not. use_element_blocks) then + nodes => ele_nodes(u, ele) + ! NOTE: there is an assumption here that n/o nodes of the neighbours + ! is equal to that of ele (so in fact is the same for all elements) + ! We need to do something more complicated if this is no longer true + nloc = size(nodes) + do i=1, nloc + ! this break down as follows: + ! 1 for node-node coupling of the same component within the element + ! owned_neighbours for node-node coupling of the same component with 1st or 2nd order neighbours + ! coupled components_ele for node-node coupling with different components only within the element + ! note: no coupling with different components of neighbouring elements as long as we're in tensor form + ! coupled components for node-node coupling with different components + dnnz( nodes(i) ) = ( (1+owned_neighbours)*(coupled_components+1) + coupled_components_ele) * nloc + ! this breaks down as follows: + ! foreign_neighbours for node-node coupling of the same component with neighbours that are owned by an other process + ! note: coriolis only couples within the element and is therefore always completely local + onnz( nodes(i) ) = foreign_neighbours*(coupled_components+1) * nloc + end do + else + ! see above for reasoning + dnnz(ele)=(1+owned_neighbours)*(coupled_components+1) + coupled_components_ele + onnz(ele)=foreign_neighbours*(coupled_components+1) + end if + end do + + ! then copy to rows of other components + do dim=2, u%dim + dnnz( (dim-1)*rows_per_dim+1:dim*rows_per_dim ) = dnnz(1:rows_per_dim) + onnz( (dim-1)*rows_per_dim+1:dim*rows_per_dim ) = onnz(1:rows_per_dim) + end do - if (use_element_blocks) then - ! local owned and non-elements - elements=element_count(u) - call allocate(big_m, elements, elements, & - dnnz, onnz, (/ u%dim, u%dim /), "BIG_m", halo=halo, & - element_size=ele_loc(u,1)) - else - ! local owned and non-owned nodes - nonods=node_count(u) - call allocate(big_m, nonods, nonods, & - dnnz, onnz, (/ u%dim, u%dim /), "BIG_m", halo=halo) - end if + if (use_element_blocks) then + ! local owned and non-elements + elements=element_count(u) + call allocate(big_m, elements, elements, & + dnnz, onnz, (/ u%dim, u%dim /), "BIG_m", halo=halo, & + element_size=ele_loc(u,1)) + else + ! local owned and non-owned nodes + nonods=node_count(u) + call allocate(big_m, nonods, nonods, & + dnnz, onnz, (/ u%dim, u%dim /), "BIG_m", halo=halo) + end if - end subroutine allocate_big_m_dg + end subroutine allocate_big_m_dg - subroutine correct_velocity_dg(U, inverse_mass, CT, delta_P) - !!< Given the pressure correction delta_P, correct the velocity. - !!< - !!< U_new = U_old + M^{-1} * C * delta_P - type(vector_field), intent(inout) :: U - type(block_csr_matrix), intent(in):: inverse_mass - type(block_csr_matrix), intent(in) :: CT - type(scalar_field), intent(in) :: delta_P + subroutine correct_velocity_dg(U, inverse_mass, CT, delta_P) + !!< Given the pressure correction delta_P, correct the velocity. + !!< + !!< U_new = U_old + M^{-1} * C * delta_P + type(vector_field), intent(inout) :: U + type(block_csr_matrix), intent(in):: inverse_mass + type(block_csr_matrix), intent(in) :: CT + type(scalar_field), intent(in) :: delta_P - ! Correction to U one dimension at a time. - type(scalar_field) :: delta_U1, delta_U2 + ! Correction to U one dimension at a time. + type(scalar_field) :: delta_U1, delta_U2 - integer :: dim + integer :: dim - ewrite(1,*) 'correct_velocity_dg' + ewrite(1,*) 'correct_velocity_dg' - call allocate(delta_U1, U%mesh, "Delta_U1") - call allocate(delta_U2, U%mesh, "Delta_U2") + call allocate(delta_U1, U%mesh, "Delta_U1") + call allocate(delta_U2, U%mesh, "Delta_U2") - do dim=1,U%dim + do dim=1,U%dim - call mult_T(delta_U1, block(CT,1,dim), delta_P) - call mult(delta_U2, block(inverse_mass,dim, dim), delta_U1) + call mult_T(delta_U1, block(CT,1,dim), delta_P) + call mult(delta_U2, block(inverse_mass,dim, dim), delta_U1) - call addto(U, dim, delta_U2) + call addto(U, dim, delta_U2) - end do + end do - call halo_update(u) - ewrite_minmax(u) + call halo_update(u) + ewrite_minmax(u) - call deallocate(delta_U1) - call deallocate(delta_U2) + call deallocate(delta_U1) + call deallocate(delta_U2) - end subroutine correct_velocity_dg + end subroutine correct_velocity_dg - subroutine assemble_poisson_rhs_dg(poisson_rhs, ctp_m, inverse_mass, & - mom_rhs, ct_rhs, velocity, dt, theta_pg) + subroutine assemble_poisson_rhs_dg(poisson_rhs, ctp_m, inverse_mass, & + mom_rhs, ct_rhs, velocity, dt, theta_pg) - type(scalar_field), intent(inout) :: poisson_rhs - type(block_csr_matrix), intent(in) :: ctp_m - type(block_csr_matrix), intent(in) :: inverse_mass - type(vector_field), intent(inout) :: mom_rhs - type(scalar_field), intent(inout) :: ct_rhs - type(vector_field), intent(inout) :: velocity - real, intent(in) :: dt, theta_pg + type(scalar_field), intent(inout) :: poisson_rhs + type(block_csr_matrix), intent(in) :: ctp_m + type(block_csr_matrix), intent(in) :: inverse_mass + type(vector_field), intent(inout) :: mom_rhs + type(scalar_field), intent(inout) :: ct_rhs + type(vector_field), intent(inout) :: velocity + real, intent(in) :: dt, theta_pg - type(vector_field) :: l_mom_rhs, minv_mom_rhs - type(halo_type), pointer :: halo + type(vector_field) :: l_mom_rhs, minv_mom_rhs + type(halo_type), pointer :: halo - ewrite(1,*) 'Entering assemble_poisson_rhs_dg' + ewrite(1,*) 'Entering assemble_poisson_rhs_dg' - ! poisson_rhs = ct_rhs/dt - C^T ( M^-1 mom_rhs + velocity/dt ) + ! poisson_rhs = ct_rhs/dt - C^T ( M^-1 mom_rhs + velocity/dt ) - if (IsParallel()) then + if (IsParallel()) then - call allocate(l_mom_rhs, mom_rhs%dim, mom_rhs%mesh, name="AssemblePoissonMomRHS") - call set(l_mom_rhs, mom_rhs) + call allocate(l_mom_rhs, mom_rhs%dim, mom_rhs%mesh, name="AssemblePoissonMomRHS") + call set(l_mom_rhs, mom_rhs) - ! we need to still add up the non-owned contributions from the global assembly of the mom_rhs - ! this is done via a slight hack: assemble it as a petsc vector where petsc will add up the local - ! contributions, and copy it back again - halo => mom_rhs%mesh%halos(1) - call addup_global_assembly(l_mom_rhs, halo) + ! we need to still add up the non-owned contributions from the global assembly of the mom_rhs + ! this is done via a slight hack: assemble it as a petsc vector where petsc will add up the local + ! contributions, and copy it back again + halo => mom_rhs%mesh%halos(1) + call addup_global_assembly(l_mom_rhs, halo) - else + else - l_mom_rhs = mom_rhs + l_mom_rhs = mom_rhs - end if + end if - ! compute M^-1 mom_rhs - call allocate(minv_mom_rhs, mom_rhs%dim, mom_rhs%mesh, name="AssembleMinvPoissonMomRHS") - call mult(minv_mom_rhs, inverse_mass, l_mom_rhs) - call halo_update(minv_mom_rhs) + ! compute M^-1 mom_rhs + call allocate(minv_mom_rhs, mom_rhs%dim, mom_rhs%mesh, name="AssembleMinvPoissonMomRHS") + call mult(minv_mom_rhs, inverse_mass, l_mom_rhs) + call halo_update(minv_mom_rhs) - call addto(minv_mom_rhs, velocity, scale=1.0/dt/theta_pg) - call mult(poisson_rhs, ctp_m, minv_mom_rhs) + call addto(minv_mom_rhs, velocity, scale=1.0/dt/theta_pg) + call mult(poisson_rhs, ctp_m, minv_mom_rhs) - call scale(poisson_rhs, -1.0) + call scale(poisson_rhs, -1.0) - call addto(poisson_rhs, ct_rhs, scale=1.0/dt/theta_pg) + call addto(poisson_rhs, ct_rhs, scale=1.0/dt/theta_pg) - call deallocate(minv_mom_rhs) - if (IsParallel()) then - call deallocate(l_mom_rhs) - end if + call deallocate(minv_mom_rhs) + if (IsParallel()) then + call deallocate(l_mom_rhs) + end if - ewrite_minmax(poisson_rhs%val(1:nowned_nodes(poisson_rhs))) + ewrite_minmax(poisson_rhs%val(1:nowned_nodes(poisson_rhs))) - end subroutine assemble_poisson_rhs_dg + end subroutine assemble_poisson_rhs_dg - subroutine momentum_DG_check_options + subroutine momentum_DG_check_options - character(len=OPTION_PATH_LEN) :: phase_path, velocity_path, dg_path - integer :: i - integer :: nstates ! number of states + character(len=OPTION_PATH_LEN) :: phase_path, velocity_path, dg_path + integer :: i + integer :: nstates ! number of states - nstates=option_count("/material_phase") + nstates=option_count("/material_phase") - state_loop: do i=0, nstates-1 + state_loop: do i=0, nstates-1 - phase_path="/material_phase["//int2str(i)//"]" - velocity_path=trim(phase_path)//"/vector_field::Velocity/prognostic" - dg_path=trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin" + phase_path="/material_phase["//int2str(i)//"]" + velocity_path=trim(phase_path)//"/vector_field::Velocity/prognostic" + dg_path=trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin" - if (have_option(dg_path)) then - if (have_option(trim(velocity_path)//"/solver/iterative_method::cg") & - &.and. & - &( (.not. have_option(trim(dg_path)//"/advection_scheme/none")) & - & .or. have_option("/physical_parameters/coriolis"))) then + if (have_option(dg_path)) then + if (have_option(trim(velocity_path)//"/solver/iterative_method::cg") & + &.and. & + &( (.not. have_option(trim(dg_path)//"/advection_scheme/none")) & + & .or. have_option("/physical_parameters/coriolis"))) then - ewrite(0,*) "Warning: You have selected conjugate gradient & - &as a solver for" - ewrite(0,*) " "//trim(phase_path)//& - &"/vector_field::Velocity" - ewrite(0,*) "which is probably an asymmetric matrix" - end if - end if + ewrite(0,*) "Warning: You have selected conjugate gradient & + &as a solver for" + ewrite(0,*) " "//trim(phase_path)//& + &"/vector_field::Velocity" + ewrite(0,*) "which is probably an asymmetric matrix" + end if + end if - if (((have_option(trim(velocity_path)//"vertical_stabilization/vertical_velocity_relaxation") .or. & - have_option(trim(velocity_path)//"vertical_stabilization/implicit_buoyancy")).and. & - have_option(trim(velocity_path)//"vector_field::Absorption")) .and. & - (.not. have_option(trim(velocity_path)//"vector_field::Absorption/include_pressure_correction"))) then - ewrite(0,*) "Warning: You have selected a vertical stabilization but have not set" - ewrite(0,*) "include_pressure_correction under your absorption field." - ewrite(0,*) "This option will now be turned on by default." - end if + if (((have_option(trim(velocity_path)//"vertical_stabilization/vertical_velocity_relaxation") .or. & + have_option(trim(velocity_path)//"vertical_stabilization/implicit_buoyancy")).and. & + have_option(trim(velocity_path)//"vector_field::Absorption")) .and. & + (.not. have_option(trim(velocity_path)//"vector_field::Absorption/include_pressure_correction"))) then + ewrite(0,*) "Warning: You have selected a vertical stabilization but have not set" + ewrite(0,*) "include_pressure_correction under your absorption field." + ewrite(0,*) "This option will now be turned on by default." + end if - if (have_option(trim(dg_path)//"/viscosity_scheme/partial_stress_form") .and. .not. & + if (have_option(trim(dg_path)//"/viscosity_scheme/partial_stress_form") .and. .not. & have_option(trim(dg_path)//"/viscosity_scheme/bassi_rebay")) then - FLAbort("partial stress form is only implemented for the bassi-rebay viscosity scheme in DG") - end if + FLAbort("partial stress form is only implemented for the bassi-rebay viscosity scheme in DG") + end if - if (have_option(trim(velocity_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/les_model") .and.& + if (have_option(trim(velocity_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/les_model") .and.& .not. have_option(trim(dg_path)//& "/viscosity_scheme/partial_stress_form")) then - FLAbort("The LES scheme for discontinuous velocity fields requires that the viscosity scheme use partial stress form.") + FLAbort("The LES scheme for discontinuous velocity fields requires that the viscosity scheme use partial stress form.") - end if + end if - end do state_loop + end do state_loop - end subroutine momentum_DG_check_options + end subroutine momentum_DG_check_options diff --git a/assemble/Momentum_Diagnostic_Fields.F90 b/assemble/Momentum_Diagnostic_Fields.F90 index 67eebba5ed..2c33c499e5 100644 --- a/assemble/Momentum_Diagnostic_Fields.F90 +++ b/assemble/Momentum_Diagnostic_Fields.F90 @@ -27,518 +27,518 @@ #include "fdebug.h" module momentum_diagnostic_fields - use fldebug - use spud - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN - use futils - use fields - use state_module - use equation_of_state - use field_priority_lists - use multiphase_module - use k_epsilon, only: keps_momentum_diagnostics - use initialise_fields_module - use multimaterial_module - use diagnostic_fields_wrapper_new - implicit none - - interface calculate_densities - module procedure calculate_densities_single_state, calculate_densities_multiple_states - end interface - - private - public :: calculate_momentum_diagnostics, calculate_densities + use fldebug + use spud + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use futils + use fields + use state_module + use equation_of_state + use field_priority_lists + use multiphase_module + use k_epsilon, only: keps_momentum_diagnostics + use initialise_fields_module + use multimaterial_module + use diagnostic_fields_wrapper_new + implicit none + + interface calculate_densities + module procedure calculate_densities_single_state, calculate_densities_multiple_states + end interface + + private + public :: calculate_momentum_diagnostics, calculate_densities contains - subroutine calculate_momentum_diagnostics(state, istate, submaterials, submaterials_istate, submaterials_indices) - !< A subroutine to group together all the diagnostic calculations that - !< must happen before a momentum solve. - - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate - ! An array of submaterials of the current phase in state(istate). - type(state_type), dimension(:), intent(inout) :: submaterials - ! The index of the current phase (i.e. state(istate)) in the submaterials array - integer, intent(in) :: submaterials_istate - integer, dimension(:), intent(in) :: submaterials_indices - - ! Local variables - type(state_type), dimension(size(state)) :: calculated_state - type(state_type), dimension(size(submaterials)) :: calculated_submaterials - type(scalar_field), pointer :: bulk_density, buoyancy_density, sfield - type(vector_field), pointer :: vfield, velocity - type(tensor_field), pointer :: tfield - - integer :: stat, i - logical :: gravity, diagnostic - - ewrite(1,*) 'Entering calculate_momentum_diagnostics' - - ! This needs to be done first or none of the following multimaterial algorithms will work... - call calculate_diagnostic_material_volume_fraction(submaterials) - call calculate_diagnostic_phase_volume_fraction(state) - - ! Calculate the density according to the eos... do the buoyancy density and the density - ! at the same time to save computations. Do not calculate buoyancy if there is no gravity. - gravity = have_option("/physical_parameters/gravity") - - ! submaterials_istate should always have a Velocity - velocity => extract_vector_field(submaterials(submaterials_istate), 'Velocity') - if (have_option(trim(velocity%option_path)//'/prognostic/equation::ShallowWater')) then - ! for the swe there's no buoyancy term - gravity = .false. - end if - - bulk_density => extract_scalar_field(submaterials(submaterials_istate), 'Density', stat) - diagnostic = .false. - if (stat==0) diagnostic = have_option(trim(bulk_density%option_path)//'/diagnostic') - if(diagnostic.and.gravity) then - buoyancy_density => extract_scalar_field(submaterials(submaterials_istate),'VelocityBuoyancyDensity') - call calculate_densities(submaterials,& - buoyancy_density=buoyancy_density, & - bulk_density=bulk_density, & - momentum_diagnostic=.true.) - else if(diagnostic) then - call calculate_densities(submaterials,& - bulk_density=bulk_density, & - momentum_diagnostic=.true.) - else if(gravity) then - buoyancy_density => extract_scalar_field(submaterials(submaterials_istate),'VelocityBuoyancyDensity') - call calculate_densities(submaterials,& - buoyancy_density=buoyancy_density, & - momentum_diagnostic=.true.) - end if - - ! Note: For multimaterial-multiphase simulations we normally pass the submaterials array to - ! diagnostic algorithms in order to compute bulk properties correctly. However, for Python - ! diagnostic algorithms where the user may wish to use fields from other phases, we need to - ! pass in the whole state array. - vfield => extract_vector_field(submaterials(submaterials_istate), "VelocityAbsorption", stat = stat) - if(stat == 0) then - if(have_option(trim(vfield%option_path) // "/diagnostic")) then - ! Update VelocityAbsorption Field and all associated dependencies (dep) using the generic subroutine - ! calculate_diagnostic_variable_dep. To maximise efficiency, we track the various dependencies through a calculated mask (dep_states_mask), - ! which requires some copying back and forth between two arrays of states (one for all states the other for the phase/submaterials). - if(have_option(trim(vfield%option_path) // "/diagnostic/algorithm::vector_python_diagnostic")) then - call calculate_diagnostic_variable_dep(state, istate, vfield, dep_states_mask=calculated_state) - call update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) - else - call calculate_diagnostic_variable_dep(submaterials, submaterials_istate, vfield, dep_states_mask=calculated_submaterials) - call update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) - end if + subroutine calculate_momentum_diagnostics(state, istate, submaterials, submaterials_istate, submaterials_indices) + !< A subroutine to group together all the diagnostic calculations that + !< must happen before a momentum solve. + + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate + ! An array of submaterials of the current phase in state(istate). + type(state_type), dimension(:), intent(inout) :: submaterials + ! The index of the current phase (i.e. state(istate)) in the submaterials array + integer, intent(in) :: submaterials_istate + integer, dimension(:), intent(in) :: submaterials_indices + + ! Local variables + type(state_type), dimension(size(state)) :: calculated_state + type(state_type), dimension(size(submaterials)) :: calculated_submaterials + type(scalar_field), pointer :: bulk_density, buoyancy_density, sfield + type(vector_field), pointer :: vfield, velocity + type(tensor_field), pointer :: tfield + + integer :: stat, i + logical :: gravity, diagnostic + + ewrite(1,*) 'Entering calculate_momentum_diagnostics' + + ! This needs to be done first or none of the following multimaterial algorithms will work... + call calculate_diagnostic_material_volume_fraction(submaterials) + call calculate_diagnostic_phase_volume_fraction(state) + + ! Calculate the density according to the eos... do the buoyancy density and the density + ! at the same time to save computations. Do not calculate buoyancy if there is no gravity. + gravity = have_option("/physical_parameters/gravity") + + ! submaterials_istate should always have a Velocity + velocity => extract_vector_field(submaterials(submaterials_istate), 'Velocity') + if (have_option(trim(velocity%option_path)//'/prognostic/equation::ShallowWater')) then + ! for the swe there's no buoyancy term + gravity = .false. end if - end if - - vfield => extract_vector_field(submaterials(submaterials_istate), "VelocitySource", stat = stat) - if(stat == 0) then - if(have_option(trim(vfield%option_path) // "/diagnostic")) then - ! Update VelocitySource Field and all associated dependencies (dep) using the generic subroutine - ! calculate_diagnostic_variable_dep. To maximise efficiency, we track the various dependencies through a calculated mask (dep_states_mask), - ! which requires some copying back and forth between two arrays of states (one for all states the other for the phase/submaterials). - if(have_option(trim(vfield%option_path) // "/diagnostic/algorithm::vector_python_diagnostic")) then - call calculate_diagnostic_variable_dep(state, istate, vfield, dep_states_mask=calculated_state) - call update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) - else - call calculate_diagnostic_variable_dep(submaterials, submaterials_istate, vfield, dep_states_mask=calculated_submaterials) - call update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) - end if + + bulk_density => extract_scalar_field(submaterials(submaterials_istate), 'Density', stat) + diagnostic = .false. + if (stat==0) diagnostic = have_option(trim(bulk_density%option_path)//'/diagnostic') + if(diagnostic.and.gravity) then + buoyancy_density => extract_scalar_field(submaterials(submaterials_istate),'VelocityBuoyancyDensity') + call calculate_densities(submaterials,& + buoyancy_density=buoyancy_density, & + bulk_density=bulk_density, & + momentum_diagnostic=.true.) + else if(diagnostic) then + call calculate_densities(submaterials,& + bulk_density=bulk_density, & + momentum_diagnostic=.true.) + else if(gravity) then + buoyancy_density => extract_scalar_field(submaterials(submaterials_istate),'VelocityBuoyancyDensity') + call calculate_densities(submaterials,& + buoyancy_density=buoyancy_density, & + momentum_diagnostic=.true.) end if - end if - - tfield => extract_tensor_field(submaterials(submaterials_istate),'Viscosity',stat) - if (stat==0) then - diagnostic = have_option(trim(tfield%option_path)//'/diagnostic') - if(diagnostic) then - ! Update Viscosity Field and all associated dependencies (dep). In certain simulations, there is the need to - ! update the second invariant of the strain rate tensor and other fields before updating the viscosity (e.g. Non Newtonian - ! Stokes simulations). Calculate_diagnostic_variable_dep does so. To maximise efficiency, we track the various dependencies - ! through a calculated mask (dep_states_mask), which requires some copying back and forth of updated dependencies between - ! two arrays of states (one for all states the other for the phase/submaterials). The calculated dependencies are stored in - ! calculated_state and calculate_submaterials, respectively. - if(have_option(trim(tfield%option_path) // "/diagnostic/algorithm::tensor_python_diagnostic")) then - call calculate_diagnostic_variable_dep(state, istate, tfield, dep_states_mask=calculated_state) - call update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) - else - call calculate_diagnostic_variable_dep(submaterials, submaterials_istate, tfield, dep_states_mask=calculated_submaterials) - call update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) - end if + + ! Note: For multimaterial-multiphase simulations we normally pass the submaterials array to + ! diagnostic algorithms in order to compute bulk properties correctly. However, for Python + ! diagnostic algorithms where the user may wish to use fields from other phases, we need to + ! pass in the whole state array. + vfield => extract_vector_field(submaterials(submaterials_istate), "VelocityAbsorption", stat = stat) + if(stat == 0) then + if(have_option(trim(vfield%option_path) // "/diagnostic")) then + ! Update VelocityAbsorption Field and all associated dependencies (dep) using the generic subroutine + ! calculate_diagnostic_variable_dep. To maximise efficiency, we track the various dependencies through a calculated mask (dep_states_mask), + ! which requires some copying back and forth between two arrays of states (one for all states the other for the phase/submaterials). + if(have_option(trim(vfield%option_path) // "/diagnostic/algorithm::vector_python_diagnostic")) then + call calculate_diagnostic_variable_dep(state, istate, vfield, dep_states_mask=calculated_state) + call update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) + else + call calculate_diagnostic_variable_dep(submaterials, submaterials_istate, vfield, dep_states_mask=calculated_submaterials) + call update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) + end if + end if end if - end if - - tfield => extract_tensor_field(submaterials(submaterials_istate), 'VelocitySurfaceTension', stat) - if(stat==0) then - diagnostic = have_option(trim(tfield%option_path)//'/diagnostic') - if(diagnostic) then - ! Unlike the above diagnostic variables, SurfaceTension doesn't include - ! a Python diagnostic algorithm option yet, so we'll just pass in submaterials for now. - call calculate_surfacetension(submaterials, tfield) + + vfield => extract_vector_field(submaterials(submaterials_istate), "VelocitySource", stat = stat) + if(stat == 0) then + if(have_option(trim(vfield%option_path) // "/diagnostic")) then + ! Update VelocitySource Field and all associated dependencies (dep) using the generic subroutine + ! calculate_diagnostic_variable_dep. To maximise efficiency, we track the various dependencies through a calculated mask (dep_states_mask), + ! which requires some copying back and forth between two arrays of states (one for all states the other for the phase/submaterials). + if(have_option(trim(vfield%option_path) // "/diagnostic/algorithm::vector_python_diagnostic")) then + call calculate_diagnostic_variable_dep(state, istate, vfield, dep_states_mask=calculated_state) + call update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) + else + call calculate_diagnostic_variable_dep(submaterials, submaterials_istate, vfield, dep_states_mask=calculated_submaterials) + call update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) + end if + end if end if - end if - - ! diagnostic Pressure (only for compressible) calculated from - ! Density and InternalEnergie via compressible eos - sfield => extract_scalar_field(submaterials(submaterials_istate), 'Pressure', stat) - if(stat==0) then - diagnostic = have_option(trim(sfield%option_path)//'/diagnostic') - if(diagnostic) then - call calculate_diagnostic_pressure(submaterials(submaterials_istate), sfield) + + tfield => extract_tensor_field(submaterials(submaterials_istate),'Viscosity',stat) + if (stat==0) then + diagnostic = have_option(trim(tfield%option_path)//'/diagnostic') + if(diagnostic) then + ! Update Viscosity Field and all associated dependencies (dep). In certain simulations, there is the need to + ! update the second invariant of the strain rate tensor and other fields before updating the viscosity (e.g. Non Newtonian + ! Stokes simulations). Calculate_diagnostic_variable_dep does so. To maximise efficiency, we track the various dependencies + ! through a calculated mask (dep_states_mask), which requires some copying back and forth of updated dependencies between + ! two arrays of states (one for all states the other for the phase/submaterials). The calculated dependencies are stored in + ! calculated_state and calculate_submaterials, respectively. + if(have_option(trim(tfield%option_path) // "/diagnostic/algorithm::tensor_python_diagnostic")) then + call calculate_diagnostic_variable_dep(state, istate, tfield, dep_states_mask=calculated_state) + call update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) + else + call calculate_diagnostic_variable_dep(submaterials, submaterials_istate, tfield, dep_states_mask=calculated_submaterials) + call update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) + end if + end if + end if + + tfield => extract_tensor_field(submaterials(submaterials_istate), 'VelocitySurfaceTension', stat) + if(stat==0) then + diagnostic = have_option(trim(tfield%option_path)//'/diagnostic') + if(diagnostic) then + ! Unlike the above diagnostic variables, SurfaceTension doesn't include + ! a Python diagnostic algorithm option yet, so we'll just pass in submaterials for now. + call calculate_surfacetension(submaterials, tfield) + end if end if - end if - ! k-epsilon momentum diagnostics (reynolds stress tensor) - if(have_option(trim(state(istate)%option_path)//& + ! diagnostic Pressure (only for compressible) calculated from + ! Density and InternalEnergie via compressible eos + sfield => extract_scalar_field(submaterials(submaterials_istate), 'Pressure', stat) + if(stat==0) then + diagnostic = have_option(trim(sfield%option_path)//'/diagnostic') + if(diagnostic) then + call calculate_diagnostic_pressure(submaterials(submaterials_istate), sfield) + end if + end if + + ! k-epsilon momentum diagnostics (reynolds stress tensor) + if(have_option(trim(state(istate)%option_path)//& "/subgridscale_parameterisations/k-epsilon")) then - call keps_momentum_diagnostics(state(istate)) - end if + call keps_momentum_diagnostics(state(istate)) + end if - ! clean up - do i = 1, size(calculated_state) - call deallocate(calculated_state(i)) - end do - do i = 1, size(calculated_submaterials) - call deallocate(calculated_submaterials(i)) - end do - - ewrite(1,*) 'Exiting calculate_momentum_diagnostics' - - end subroutine calculate_momentum_diagnostics - - subroutine update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) - ! When updating diagnostic dependencies, we track the various dependencies through a calculated mask. This requires some copying back and forth - ! between two arrays of states (one for all states the other for the phase/submaterials). This routine updates the state mask (target) by copying across - ! references from the submaterials mask (donor). - - type(state_type), dimension(:), intent(inout) :: calculated_state - type(state_type), dimension(:), intent(in) :: calculated_submaterials - integer, dimension(:), intent(in) :: submaterials_indices - - integer :: i - - do i = 1, size(calculated_submaterials) - call insert(calculated_state(submaterials_indices(i)), calculated_submaterials(i)) - end do - - end subroutine update_calculated_state - - subroutine update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) - ! When updating diagnostic dependencies, we track the various dependencies through a calculated mask. This requires some copying back and forth - ! between two arrays of states (one for all states the other for the phase/submaterials). This routine updates the submaterials mask (target) by copying across - ! references from the state mask (donor). - type(state_type), dimension(:), intent(inout) :: calculated_submaterials - type(state_type), dimension(:), intent(in) :: calculated_state - integer, dimension(:), intent(in) :: submaterials_indices - - integer :: i - - do i = 1, size(calculated_submaterials) - call insert(calculated_submaterials(i), calculated_state(submaterials_indices(i))) - end do - - end subroutine update_calculated_submaterials - - subroutine calculate_densities_single_state(state, buoyancy_density, bulk_density, & - momentum_diagnostic) - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout), optional, target :: buoyancy_density - type(scalar_field), intent(inout), optional, target :: bulk_density - logical, intent(in), optional :: momentum_diagnostic - - type(state_type), dimension(1) :: states - - states = (/state/) - call calculate_densities(states, buoyancy_density=buoyancy_density, bulk_density=bulk_density, & - momentum_diagnostic=momentum_diagnostic) - state = states(1) - - end subroutine calculate_densities_single_state - - subroutine calculate_densities_multiple_states(state, buoyancy_density, bulk_density, & - momentum_diagnostic) - - type(state_type), dimension(:), intent(inout) :: state - type(scalar_field), intent(inout), optional, target :: buoyancy_density - type(scalar_field), intent(inout), optional, target :: bulk_density - logical, intent(in), optional ::momentum_diagnostic - - type(scalar_field) :: eosdensity - type(scalar_field), pointer :: tmpdensity - type(scalar_field) :: bulksumvolumefractionsbound - type(scalar_field) :: buoyancysumvolumefractionsbound - type(mesh_type), pointer :: mesh - integer, dimension(size(state)) :: state_order - logical :: subtract_out_hydrostatic, multimaterial - character(len=OPTION_PATH_LEN) :: option_path - integer :: subtract_count, materialvolumefraction_count - real :: hydrostatic_rho0, reference_density - integer :: i, stat - - logical :: boussinesq - type(vector_field), pointer :: velocity - real :: boussinesq_rho0 - - if(.not.present(buoyancy_density).and..not.present(bulk_density)) then - ! coding error - FLAbort("No point calling me if I don't have anything to do.") - end if - - if(present(buoyancy_density)) call zero(buoyancy_density) - if(present(bulk_density)) call zero(bulk_density) - - if(present(bulk_density)) then - mesh => bulk_density%mesh - else - mesh => buoyancy_density%mesh - end if - - multimaterial = .false. - materialvolumefraction_count = 0 - subtract_count = 0 - if(size(state)>1) then - do i = 1, size(state) - if(has_scalar_field(state(i), "MaterialVolumeFraction")) then - materialvolumefraction_count = materialvolumefraction_count + 1 - end if + ! clean up + do i = 1, size(calculated_state) + call deallocate(calculated_state(i)) + end do + do i = 1, size(calculated_submaterials) + call deallocate(calculated_submaterials(i)) + end do + + ewrite(1,*) 'Exiting calculate_momentum_diagnostics' + + end subroutine calculate_momentum_diagnostics + + subroutine update_calculated_state(calculated_state, calculated_submaterials, submaterials_indices) + ! When updating diagnostic dependencies, we track the various dependencies through a calculated mask. This requires some copying back and forth + ! between two arrays of states (one for all states the other for the phase/submaterials). This routine updates the state mask (target) by copying across + ! references from the submaterials mask (donor). + + type(state_type), dimension(:), intent(inout) :: calculated_state + type(state_type), dimension(:), intent(in) :: calculated_submaterials + integer, dimension(:), intent(in) :: submaterials_indices - option_path='/material_phase::'//trim(state(i)%name)//'/equation_of_state' - - subtract_count = subtract_count + & - option_count(trim(option_path)//'/fluids/linear/subtract_out_hydrostatic_level') + & - option_count(trim(option_path)//'/fluids/ocean_pade_approximation') + integer :: i + do i = 1, size(calculated_submaterials) + call insert(calculated_state(submaterials_indices(i)), calculated_submaterials(i)) end do - if(size(state)/=materialvolumefraction_count) then - FLExit("Multiple material_phases but not all of them have MaterialVolumeFractions.") - end if - if(subtract_count>1) then - FLExit("You can only select one material_phase to use the reference_density from to subtract out the hydrostatic level.") + + end subroutine update_calculated_state + + subroutine update_calculated_submaterials(calculated_submaterials, calculated_state, submaterials_indices) + ! When updating diagnostic dependencies, we track the various dependencies through a calculated mask. This requires some copying back and forth + ! between two arrays of states (one for all states the other for the phase/submaterials). This routine updates the submaterials mask (target) by copying across + ! references from the state mask (donor). + type(state_type), dimension(:), intent(inout) :: calculated_submaterials + type(state_type), dimension(:), intent(in) :: calculated_state + integer, dimension(:), intent(in) :: submaterials_indices + + integer :: i + + do i = 1, size(calculated_submaterials) + call insert(calculated_submaterials(i), calculated_state(submaterials_indices(i))) + end do + + end subroutine update_calculated_submaterials + + subroutine calculate_densities_single_state(state, buoyancy_density, bulk_density, & + momentum_diagnostic) + + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout), optional, target :: buoyancy_density + type(scalar_field), intent(inout), optional, target :: bulk_density + logical, intent(in), optional :: momentum_diagnostic + + type(state_type), dimension(1) :: states + + states = (/state/) + call calculate_densities(states, buoyancy_density=buoyancy_density, bulk_density=bulk_density, & + momentum_diagnostic=momentum_diagnostic) + state = states(1) + + end subroutine calculate_densities_single_state + + subroutine calculate_densities_multiple_states(state, buoyancy_density, bulk_density, & + momentum_diagnostic) + + type(state_type), dimension(:), intent(inout) :: state + type(scalar_field), intent(inout), optional, target :: buoyancy_density + type(scalar_field), intent(inout), optional, target :: bulk_density + logical, intent(in), optional ::momentum_diagnostic + + type(scalar_field) :: eosdensity + type(scalar_field), pointer :: tmpdensity + type(scalar_field) :: bulksumvolumefractionsbound + type(scalar_field) :: buoyancysumvolumefractionsbound + type(mesh_type), pointer :: mesh + integer, dimension(size(state)) :: state_order + logical :: subtract_out_hydrostatic, multimaterial + character(len=OPTION_PATH_LEN) :: option_path + integer :: subtract_count, materialvolumefraction_count + real :: hydrostatic_rho0, reference_density + integer :: i, stat + + logical :: boussinesq + type(vector_field), pointer :: velocity + real :: boussinesq_rho0 + + if(.not.present(buoyancy_density).and..not.present(bulk_density)) then + ! coding error + FLAbort("No point calling me if I don't have anything to do.") end if - multimaterial = .true. + if(present(buoyancy_density)) call zero(buoyancy_density) + if(present(bulk_density)) call zero(bulk_density) - ! allocate a bounding field for the volume fractions if(present(bulk_density)) then - call allocate(bulksumvolumefractionsbound, mesh, "SumMaterialVolumeFractionsBound") - call set(bulksumvolumefractionsbound, 1.0) - end if - if(present(buoyancy_density)) then - call allocate(buoyancysumvolumefractionsbound, mesh, "SumMaterialVolumeFractionsBound") - call set(buoyancysumvolumefractionsbound, 1.0) + mesh => bulk_density%mesh + else + mesh => buoyancy_density%mesh end if - ! get the order in which states should be processed - call order_states_priority(state, state_order) + multimaterial = .false. + materialvolumefraction_count = 0 + subtract_count = 0 + if(size(state)>1) then + do i = 1, size(state) + if(has_scalar_field(state(i), "MaterialVolumeFraction")) then + materialvolumefraction_count = materialvolumefraction_count + 1 + end if - ! this needs to be done first or none of the following multimaterial algorithms will work... - call calculate_diagnostic_material_volume_fraction(state) - else - assert(size(state_order)==1) - ! set up a dummy state ordering for the single material case - state_order(1) = 1 - end if + option_path='/material_phase::'//trim(state(i)%name)//'/equation_of_state' - boussinesq = .false. - hydrostatic_rho0 = 0.0 - state_loop: do i = 1, size(state) + subtract_count = subtract_count + & + option_count(trim(option_path)//'/fluids/linear/subtract_out_hydrostatic_level') + & + option_count(trim(option_path)//'/fluids/ocean_pade_approximation') - option_path='/material_phase::'//trim(state(state_order(i))%name)//'/equation_of_state' + end do + if(size(state)/=materialvolumefraction_count) then + FLExit("Multiple material_phases but not all of them have MaterialVolumeFractions.") + end if + if(subtract_count>1) then + FLExit("You can only select one material_phase to use the reference_density from to subtract out the hydrostatic level.") + end if - if(have_option(trim(option_path)//'/fluids')) then - ! we have a fluids eos + multimaterial = .true. - subtract_out_hydrostatic = & - have_option(trim(option_path)//'/fluids/linear/subtract_out_hydrostatic_level') .or. & - have_option(trim(option_path)//'/fluids/ocean_pade_approximation') + ! allocate a bounding field for the volume fractions + if(present(bulk_density)) then + call allocate(bulksumvolumefractionsbound, mesh, "SumMaterialVolumeFractionsBound") + call set(bulksumvolumefractionsbound, 1.0) + end if + if(present(buoyancy_density)) then + call allocate(buoyancysumvolumefractionsbound, mesh, "SumMaterialVolumeFractionsBound") + call set(buoyancysumvolumefractionsbound, 1.0) + end if - call allocate(eosdensity, mesh, "LocalPerturbationDensity") + ! get the order in which states should be processed + call order_states_priority(state, state_order) - call calculate_perturbation_density(state(state_order(i)), eosdensity, reference_density) + ! this needs to be done first or none of the following multimaterial algorithms will work... + call calculate_diagnostic_material_volume_fraction(state) + else + assert(size(state_order)==1) + ! set up a dummy state ordering for the single material case + state_order(1) = 1 + end if - if(multimaterial) then - ! if multimaterial we have to subtract out a single reference density at the end - ! rather than one per material so add it in always for now - call addto(eosdensity, reference_density) - end if + boussinesq = .false. + hydrostatic_rho0 = 0.0 + state_loop: do i = 1, size(state) - if(present(buoyancy_density)) then - if(multimaterial) then - if(subtract_out_hydrostatic) then - ! if multimaterial we have to subtract out a single global value at the end - ! so save it for now - hydrostatic_rho0 = reference_density - end if - call add_scaled_material_property(state(state_order(i)), buoyancy_density, eosdensity, & - sumvolumefractionsbound=buoyancysumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) - else - call set(buoyancy_density, eosdensity) - if(.not.subtract_out_hydrostatic) then - call addto(buoyancy_density, reference_density) - end if - end if - - ! find out if the velocity in this state is *the* (i.e. not aliased) - ! prognostic one and if it's using a Boussinesq equation. - ! if it is record the rho0 and it will be used later to scale - ! the buoyancy density - velocity => extract_vector_field(state(state_order(i)), "Velocity", stat) - if(stat==0) then - if(.not.aliased(velocity)) then - if (have_option(trim(velocity%option_path)//"/prognostic/equation::Boussinesq")) then - ! have we already found a state where the velocity was using Boussinesq? - if(boussinesq) then - ! uh oh... looks like you're using multiphase... good luck with that... - ! everything here at the moment assumes a single prognostic velocity - FLExit("Two nonaliased velocities using equation type Boussinesq. Don't know what to do.") - end if - boussinesq=.true. - boussinesq_rho0 = reference_density - end if - end if - end if + option_path='/material_phase::'//trim(state(state_order(i))%name)//'/equation_of_state' - end if + if(have_option(trim(option_path)//'/fluids')) then + ! we have a fluids eos - if(present(bulk_density)) then - if(multimaterial) then - ! the perturbation density has already had the reference density added to it - ! if you're multimaterial - call add_scaled_material_property(state(state_order(i)), bulk_density, eosdensity, & - sumvolumefractionsbound=bulksumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) - else - call set(bulk_density, eosdensity) - call addto(bulk_density, reference_density) - end if - end if + subtract_out_hydrostatic = & + have_option(trim(option_path)//'/fluids/linear/subtract_out_hydrostatic_level') .or. & + have_option(trim(option_path)//'/fluids/ocean_pade_approximation') - call deallocate(eosdensity) + call allocate(eosdensity, mesh, "LocalPerturbationDensity") - else - ! we don't have a fluids eos + call calculate_perturbation_density(state(state_order(i)), eosdensity, reference_density) - tmpdensity => extract_scalar_field(state(state_order(i)), "MaterialDensity", stat) - if(stat==0) then - if(multimaterial) then - if(present(buoyancy_density)) then - call add_scaled_material_property(state(state_order(i)), buoyancy_density, tmpdensity, & - sumvolumefractionsbound=buoyancysumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) + if(multimaterial) then + ! if multimaterial we have to subtract out a single reference density at the end + ! rather than one per material so add it in always for now + call addto(eosdensity, reference_density) end if - if(present(bulk_density)) then - call add_scaled_material_property(state(state_order(i)), bulk_density, tmpdensity, & - sumvolumefractionsbound=bulksumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) - end if - else + if(present(buoyancy_density)) then - call remap_field(tmpdensity, buoyancy_density) + if(multimaterial) then + if(subtract_out_hydrostatic) then + ! if multimaterial we have to subtract out a single global value at the end + ! so save it for now + hydrostatic_rho0 = reference_density + end if + call add_scaled_material_property(state(state_order(i)), buoyancy_density, eosdensity, & + sumvolumefractionsbound=buoyancysumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) + else + call set(buoyancy_density, eosdensity) + if(.not.subtract_out_hydrostatic) then + call addto(buoyancy_density, reference_density) + end if + end if + + ! find out if the velocity in this state is *the* (i.e. not aliased) + ! prognostic one and if it's using a Boussinesq equation. + ! if it is record the rho0 and it will be used later to scale + ! the buoyancy density + velocity => extract_vector_field(state(state_order(i)), "Velocity", stat) + if(stat==0) then + if(.not.aliased(velocity)) then + if (have_option(trim(velocity%option_path)//"/prognostic/equation::Boussinesq")) then + ! have we already found a state where the velocity was using Boussinesq? + if(boussinesq) then + ! uh oh... looks like you're using multiphase... good luck with that... + ! everything here at the moment assumes a single prognostic velocity + FLExit("Two nonaliased velocities using equation type Boussinesq. Don't know what to do.") + end if + boussinesq=.true. + boussinesq_rho0 = reference_density + end if + end if + end if + end if + if(present(bulk_density)) then - call remap_field(tmpdensity, bulk_density) + if(multimaterial) then + ! the perturbation density has already had the reference density added to it + ! if you're multimaterial + call add_scaled_material_property(state(state_order(i)), bulk_density, eosdensity, & + sumvolumefractionsbound=bulksumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) + else + call set(bulk_density, eosdensity) + call addto(bulk_density, reference_density) + end if end if - end if - else - if(multimaterial) then - FLExit("No multimaterial MaterialDensity or fluid eos provided") - else - if(have_option(trim(option_path)//'/compressible')) then - call allocate(eosdensity, mesh, "LocalCompressibleEOSDensity") - - call compressible_eos(state(state_order(i)), density=eosdensity) - - if(present(bulk_density)) then - call set(bulk_density, eosdensity) - end if - if(present(buoyancy_density)) then - call set(buoyancy_density, eosdensity) - end if - - call deallocate(eosdensity) + + call deallocate(eosdensity) + + else + ! we don't have a fluids eos + + tmpdensity => extract_scalar_field(state(state_order(i)), "MaterialDensity", stat) + if(stat==0) then + if(multimaterial) then + if(present(buoyancy_density)) then + call add_scaled_material_property(state(state_order(i)), buoyancy_density, tmpdensity, & + sumvolumefractionsbound=buoyancysumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) + end if + if(present(bulk_density)) then + call add_scaled_material_property(state(state_order(i)), bulk_density, tmpdensity, & + sumvolumefractionsbound=bulksumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) + end if + else + if(present(buoyancy_density)) then + call remap_field(tmpdensity, buoyancy_density) + end if + if(present(bulk_density)) then + call remap_field(tmpdensity, bulk_density) + end if + end if else - tmpdensity => extract_scalar_field(state(state_order(i)), "Density", stat) - if(stat==0) then - if(present(buoyancy_density)) then - call remap_field(tmpdensity, buoyancy_density) - end if - if(present(bulk_density)) then - call remap_field(tmpdensity, bulk_density) - end if - else - if(present(buoyancy_density)) then - FLExit("You haven't provide enough information to set the buoyancy density.") - end if - if(present(bulk_density)) then - ! coding error... hopefully - FLAbort("How on Earth did you get here without a density?!") - end if - end if + if(multimaterial) then + FLExit("No multimaterial MaterialDensity or fluid eos provided") + else + if(have_option(trim(option_path)//'/compressible')) then + call allocate(eosdensity, mesh, "LocalCompressibleEOSDensity") + + call compressible_eos(state(state_order(i)), density=eosdensity) + + if(present(bulk_density)) then + call set(bulk_density, eosdensity) + end if + if(present(buoyancy_density)) then + call set(buoyancy_density, eosdensity) + end if + + call deallocate(eosdensity) + else + tmpdensity => extract_scalar_field(state(state_order(i)), "Density", stat) + if(stat==0) then + if(present(buoyancy_density)) then + call remap_field(tmpdensity, buoyancy_density) + end if + if(present(bulk_density)) then + call remap_field(tmpdensity, bulk_density) + end if + else + if(present(buoyancy_density)) then + FLExit("You haven't provide enough information to set the buoyancy density.") + end if + if(present(bulk_density)) then + ! coding error... hopefully + FLAbort("How on Earth did you get here without a density?!") + end if + end if + end if + end if end if - end if - end if - end if + end if - end do state_loop + end do state_loop - if(present(buoyancy_density)) then - if(multimaterial) call addto(buoyancy_density, -hydrostatic_rho0) + if(present(buoyancy_density)) then + if(multimaterial) call addto(buoyancy_density, -hydrostatic_rho0) - if(boussinesq) then - ! the buoyancy density is being used in a Boussinesq eqn - ! therefore it needs to be scaled by rho0: - call scale(buoyancy_density, 1./boussinesq_rho0) + if(boussinesq) then + ! the buoyancy density is being used in a Boussinesq eqn + ! therefore it needs to be scaled by rho0: + call scale(buoyancy_density, 1./boussinesq_rho0) + end if end if - end if - if(multimaterial) then - if(present(buoyancy_density)) then - call deallocate(buoyancysumvolumefractionsbound) - end if - if(present(bulk_density)) then - call deallocate(bulksumvolumefractionsbound) + if(multimaterial) then + if(present(buoyancy_density)) then + call deallocate(buoyancysumvolumefractionsbound) + end if + if(present(bulk_density)) then + call deallocate(bulksumvolumefractionsbound) + end if end if - end if - end subroutine calculate_densities_multiple_states + end subroutine calculate_densities_multiple_states - subroutine calculate_diagnostic_pressure(state, pressure) - ! diagnostic Pressure (only for compressible) calculated from - ! Density and InternalEnergie via compressible eos - type(state_type), intent(inout):: state - type(scalar_field), intent(inout):: pressure + subroutine calculate_diagnostic_pressure(state, pressure) + ! diagnostic Pressure (only for compressible) calculated from + ! Density and InternalEnergie via compressible eos + type(state_type), intent(inout):: state + type(scalar_field), intent(inout):: pressure - ewrite(1,*) "In calculate_diagnostic_pressure" + ewrite(1,*) "In calculate_diagnostic_pressure" - if (have_option(trim(state%option_path)//'/equation_of_state/compressible')) then - call compressible_eos(state, pressure=pressure) - else - FLExit("Diagnostic pressure can only be used in combination with a compressible equation of state.") - end if + if (have_option(trim(state%option_path)//'/equation_of_state/compressible')) then + call compressible_eos(state, pressure=pressure) + else + FLExit("Diagnostic pressure can only be used in combination with a compressible equation of state.") + end if - ewrite_minmax(pressure) + ewrite_minmax(pressure) - end subroutine calculate_diagnostic_pressure + end subroutine calculate_diagnostic_pressure - subroutine momentum_diagnostics_fields_check_options + subroutine momentum_diagnostics_fields_check_options - character(len=OPTION_PATH_LEN):: phase_path - integer:: i + character(len=OPTION_PATH_LEN):: phase_path + integer:: i - do i=0, option_count('/material_phase')-1 - phase_path = '/material_phase[' // int2str(i) // ']' - if (have_option(trim(phase_path)//'/scalar_field::Pressure/diagnostic')) then - if (.not. have_option(trim(phase_path)//'/equation_of_state/compressible')) then - FLExit("Diagnostic pressure can only be used in combination with a compressible equation of state.") - end if - if (have_option(trim(phase_path)//'/scalar_field::MaterialVolumeFraction')) then - FLExit("Diagnostic pressure currently does not work with multi-material") - end if + do i=0, option_count('/material_phase')-1 + phase_path = '/material_phase[' // int2str(i) // ']' + if (have_option(trim(phase_path)//'/scalar_field::Pressure/diagnostic')) then + if (.not. have_option(trim(phase_path)//'/equation_of_state/compressible')) then + FLExit("Diagnostic pressure can only be used in combination with a compressible equation of state.") + end if + if (have_option(trim(phase_path)//'/scalar_field::MaterialVolumeFraction')) then + FLExit("Diagnostic pressure currently does not work with multi-material") + end if - end if - end do + end if + end do - end subroutine momentum_diagnostics_fields_check_options + end subroutine momentum_diagnostics_fields_check_options end module momentum_diagnostic_fields diff --git a/assemble/Momentum_Equation.F90 b/assemble/Momentum_Equation.F90 index 16f6fbc3a1..ac378e54aa 100644 --- a/assemble/Momentum_Equation.F90 +++ b/assemble/Momentum_Equation.F90 @@ -27,2131 +27,2131 @@ #include "fdebug.h" - module momentum_equation - - use spud - use fldebug - use global_parameters, only: FIELD_NAME_LEN - use futils, only: int2str - use parallel_tools - use element_numbering, only: FAMILY_SIMPLEX - use sparse_tools - use linked_lists - use parallel_fields, only: zero_non_owned - use fields - use profiler - use sparse_tools_petsc - use state_module - use field_options - use boundary_conditions - use sparsity_patterns_meshes - use sparse_matrices_fields - use vtk_interfaces - use dgtools, only: dg_apply_mass - use state_fields_module - use field_priority_lists - use solvers - use diagnostic_fields, only: calculate_diagnostic_variable - use multiphase_module - use divergence_matrix_cv - use divergence_matrix_cg - use coordinates - use tidal_module - use boundary_conditions_from_options - use free_surface_module - use petsc_solve_state_module - use state_matrices_module - use rotated_boundary_conditions - use momentum_cg - use slope_limiters_dg - use momentum_dg - use assemble_cmc - use momentum_diagnostic_fields, only: calculate_momentum_diagnostics - use compressible_projection - use full_projection - use hydrostatic_pressure - use geostrophic_pressure - use vertical_balance_pressure - use foam_drainage, only: calculate_drainage_source_absor - use oceansurfaceforcing - use drag_module - use pressure_dirichlet_bcs_cv - use shallow_water_equations - - implicit none - - private - public :: solve_momentum, momentum_equation_check_options - - ! The timestep - real :: dt - - ! Are we going to form the Diagonal Schur complement preconditioner? - logical :: get_diag_schur - ! Do we need the scaled pressure mass matrix? - logical :: get_scaled_pressure_mass_matrix - ! Do we need an auxiliary matrix for full_projection solve? - logical :: assemble_schur_auxiliary_matrix - - ! Do we want to use the compressible projection method? - logical :: compressible_eos - ! are we solving the shallow water equations (which partly follows the compressible projection path) - logical :: shallow_water_projection - ! Are we doing a full Schur solve? - logical :: full_schur - ! Are we lumping mass or assuming consistent mass? - logical, dimension(:), allocatable :: lump_mass - ! are we using a cv pressure - logical :: cv_pressure - ! for a CG pressure are we testing the continuity with cv - logical :: cg_pressure_cv_test_continuity - - ! Do we need to reassemble the C^T or CMC matrices? - logical :: reassemble_all_ct_m, reassemble_all_cmc_m - - ! Do we want to apply a theta weighting to the pressure gradient term? - logical :: use_theta_pg - - ! Is a theta-weighting term present in the velocity-divergence? - logical :: use_theta_divergence - - ! Are we using a discontinuous Galerkin discretisation? - logical, dimension(:), allocatable :: dg - ! True if advection-subcycling is performed - logical, dimension(:), allocatable :: subcycle - - ! Apply KMK stabilisation? - logical :: apply_kmk - - logical :: diagonal_big_m - logical :: pressure_debugging_vtus - - ! Increased each call to momentum equation, used as index for pressure debugging vtus - integer, save :: pdv_count = -1 - - logical, dimension(:), allocatable :: sphere_absorption +module momentum_equation + + use spud + use fldebug + use global_parameters, only: FIELD_NAME_LEN + use futils, only: int2str + use parallel_tools + use element_numbering, only: FAMILY_SIMPLEX + use sparse_tools + use linked_lists + use parallel_fields, only: zero_non_owned + use fields + use profiler + use sparse_tools_petsc + use state_module + use field_options + use boundary_conditions + use sparsity_patterns_meshes + use sparse_matrices_fields + use vtk_interfaces + use dgtools, only: dg_apply_mass + use state_fields_module + use field_priority_lists + use solvers + use diagnostic_fields, only: calculate_diagnostic_variable + use multiphase_module + use divergence_matrix_cv + use divergence_matrix_cg + use coordinates + use tidal_module + use boundary_conditions_from_options + use free_surface_module + use petsc_solve_state_module + use state_matrices_module + use rotated_boundary_conditions + use momentum_cg + use slope_limiters_dg + use momentum_dg + use assemble_cmc + use momentum_diagnostic_fields, only: calculate_momentum_diagnostics + use compressible_projection + use full_projection + use hydrostatic_pressure + use geostrophic_pressure + use vertical_balance_pressure + use foam_drainage, only: calculate_drainage_source_absor + use oceansurfaceforcing + use drag_module + use pressure_dirichlet_bcs_cv + use shallow_water_equations + + implicit none + + private + public :: solve_momentum, momentum_equation_check_options + + ! The timestep + real :: dt + + ! Are we going to form the Diagonal Schur complement preconditioner? + logical :: get_diag_schur + ! Do we need the scaled pressure mass matrix? + logical :: get_scaled_pressure_mass_matrix + ! Do we need an auxiliary matrix for full_projection solve? + logical :: assemble_schur_auxiliary_matrix + + ! Do we want to use the compressible projection method? + logical :: compressible_eos + ! are we solving the shallow water equations (which partly follows the compressible projection path) + logical :: shallow_water_projection + ! Are we doing a full Schur solve? + logical :: full_schur + ! Are we lumping mass or assuming consistent mass? + logical, dimension(:), allocatable :: lump_mass + ! are we using a cv pressure + logical :: cv_pressure + ! for a CG pressure are we testing the continuity with cv + logical :: cg_pressure_cv_test_continuity + + ! Do we need to reassemble the C^T or CMC matrices? + logical :: reassemble_all_ct_m, reassemble_all_cmc_m + + ! Do we want to apply a theta weighting to the pressure gradient term? + logical :: use_theta_pg + + ! Is a theta-weighting term present in the velocity-divergence? + logical :: use_theta_divergence + + ! Are we using a discontinuous Galerkin discretisation? + logical, dimension(:), allocatable :: dg + ! True if advection-subcycling is performed + logical, dimension(:), allocatable :: subcycle + + ! Apply KMK stabilisation? + logical :: apply_kmk + + logical :: diagonal_big_m + logical :: pressure_debugging_vtus + + ! Increased each call to momentum equation, used as index for pressure debugging vtus + integer, save :: pdv_count = -1 + + logical, dimension(:), allocatable :: sphere_absorption + + ! Are we running a multi-phase simulation? + logical :: multiphase + + ! Do we have a prognostic free surface (currently only in + ! combination with a no_normal_stress free_surface) + logical :: implicit_prognostic_fs, explicit_prognostic_fs, standard_fs + +contains + + subroutine solve_momentum(state, at_first_timestep, timestep) + !!< Construct and solve the momentum and continuity equations + !!< using Chorin's projection method (Chorin, 1968) + + ! An array of buckets full of fields + ! The whole array is needed for the sake of multimaterial assembly + type(state_type), dimension(:), intent(inout) :: state + logical, intent(in) :: at_first_timestep + integer, intent(in) :: timestep + + ! Counter iterating over each state + integer :: istate + + ! The pressure gradient matrix (extracted from state) + type(block_csr_matrix_pointer), dimension(:), allocatable :: ct_m + ! The pressure projection matrix (extracted from state) + type(csr_matrix), pointer :: cmc_m + + ! logical to indicate whether ct_m and cmc_m need reassembling + ! (used for each state within the assembly loop) + logical :: reassemble_ct_m, reassemble_cmc_m + ! is there a pressure in state? + logical :: have_pressure + ! Are we solving a Poisson pressure equation? + logical :: poisson_p + + ! Matrix sparsity patterns for the matrices we allocate locally + type(csr_sparsity), pointer :: u_sparsity + + !! Locally allocated matrices: + ! Momentum LHS + type(petsc_csr_matrix), dimension(:), allocatable, target :: big_m + ! Matrix for split explicit advection + type(block_csr_matrix), dimension(:), allocatable :: subcycle_m + ! Pointer to matrix for full projection solve: + type(petsc_csr_matrix_pointer), dimension(:), allocatable :: inner_m + ! Pointer to preconditioner matrix for full projection solve: + type(csr_matrix), pointer :: full_projection_preconditioner + ! Auxiliary matrix for full_projection solve + type(csr_sparsity), pointer :: schur_auxiliary_matrix_sparsity + type(csr_matrix) :: schur_auxiliary_matrix + ! Scaled pressure mass matrix - used for preconditioning full projection solve: + type(csr_matrix), target :: scaled_pressure_mass_matrix + type(csr_sparsity), pointer :: scaled_pressure_mass_matrix_sparsity + ! Left hand matrix of CMC. For incompressible flow this points to ct_m as they are identical, + ! unless for CG pressure with CV tested continuity case when this matrix will be the + ! CV divergence tested matrix and ct_m the CG divergence tested matrix (right hand matrix of CMC). + ! For compressible flow this differs to ct_m in that it will contain the variable density. + type(block_csr_matrix_pointer), dimension(:), allocatable :: ctp_m + ! The lumped mass matrix (may vary per component as absorption could be included) + type(vector_field), dimension(1:size(state)) :: inverse_masslump + ! Mass matrix + type(petsc_csr_matrix), dimension(1:size(state)), target :: mass + ! For DG: + type(block_csr_matrix), dimension(1:size(state)):: inverse_mass + + ! Momentum RHS + type(vector_field), dimension(1:size(state)):: mom_rhs + ! Projection RHS + type(scalar_field) :: projec_rhs + ! RHS for continuity equation + type(scalar_field), dimension(1:size(state)):: ct_rhs + ! RHS for subcycling containing advection bc terms + type(vector_field), dimension(1:size(state)):: subcycle_rhs + + ! Do we want to assemble the KMK stabilisation matrix? + logical :: assemble_kmk + + ! Change in pressure + type(scalar_field) :: delta_p + + ! Dummy fields + type(scalar_field), pointer :: dummyscalar, dummydensity, dummypressure + + ! Pressure and density + type(scalar_field), pointer :: p, density + ! this is the mesh on which the pressure projection is performed + ! usually just p%mesh, but in case of a no_normal_stress free_surface + ! (and in future hydrostatic projection) these are different + type(mesh_type), pointer :: p_mesh + ! Velocity and space + type(vector_field), pointer :: u, x + ! with a no_normal_stress free_surface we use a prognostic free surface + type(scalar_field), pointer:: free_surface + + ! with free-surface or compressible pressure projection pressures + ! are at integer time levels and we apply a theta weighting to the + ! pressure gradient term + real :: theta_pg, theta_u + ! With free-surface or compressible-projection the velocity divergence is + ! calculated at time n+theta_divergence instead of at the end of the timestep + real :: theta_divergence + ! in this case p_theta=theta_pg*p+(1-theta_pg)*old_p + type(scalar_field), pointer :: old_p, p_theta + type(vector_field), pointer :: old_u + ! all of this only applies if use_theta_pg .eqv. .true. + ! without a free surface, or with a free surface and theta==1 + ! use_theta_pg .eqv. .false. and p_theta => p + + ! What is the equation type? + character(len=FIELD_NAME_LEN) :: equation_type, poisson_scheme, schur_scheme, pressure_pmat + + integer :: stat + + ! The list of stiff nodes + ! This is saved because the list is only formed when cmc is assembled, which + ! isn't necessarily every time this subroutine is called but the list is + ! still needed to fix the rhs (applying the fix to cmc itself wipes out the + ! information that would be required to recompile the list) + type(ilist), save :: stiff_nodes_list + + !! Variables for multi-phase flow model + integer :: prognostic_count + ! Do we have a prognostic pressure field to solve for? + logical :: prognostic_p + ! Prognostic pressure field's state index (if present) + integer :: prognostic_p_istate + ! The 'global' CMC matrix (the sum of all individual phase CMC matrices) + type(csr_matrix), pointer :: cmc_global + ! An array of submaterials of the current phase in state(istate). + type(state_type), dimension(:), pointer :: submaterials + ! The index of the current phase (i.e. state(istate)) in the submaterials array + integer :: submaterials_istate + ! The full list of indices between submaterials and state + integer, dimension(:), pointer :: submaterials_indices + ! Do we have fluid-particle drag between phases? + logical :: have_fp_drag + + ewrite(1,*) 'Entering solve_momentum' + + + !! Get diagnostics (equations of state, etc) and assemble matrices + + ! Get some options that are independent of the states + call get_option("/timestepping/timestep", dt) ! Are we running a multi-phase simulation? - logical :: multiphase - - ! Do we have a prognostic free surface (currently only in - ! combination with a no_normal_stress free_surface) - logical :: implicit_prognostic_fs, explicit_prognostic_fs, standard_fs - - contains - - subroutine solve_momentum(state, at_first_timestep, timestep) - !!< Construct and solve the momentum and continuity equations - !!< using Chorin's projection method (Chorin, 1968) - - ! An array of buckets full of fields - ! The whole array is needed for the sake of multimaterial assembly - type(state_type), dimension(:), intent(inout) :: state - logical, intent(in) :: at_first_timestep - integer, intent(in) :: timestep - - ! Counter iterating over each state - integer :: istate - - ! The pressure gradient matrix (extracted from state) - type(block_csr_matrix_pointer), dimension(:), allocatable :: ct_m - ! The pressure projection matrix (extracted from state) - type(csr_matrix), pointer :: cmc_m - - ! logical to indicate whether ct_m and cmc_m need reassembling - ! (used for each state within the assembly loop) - logical :: reassemble_ct_m, reassemble_cmc_m - ! is there a pressure in state? - logical :: have_pressure - ! Are we solving a Poisson pressure equation? - logical :: poisson_p - - ! Matrix sparsity patterns for the matrices we allocate locally - type(csr_sparsity), pointer :: u_sparsity - - !! Locally allocated matrices: - ! Momentum LHS - type(petsc_csr_matrix), dimension(:), allocatable, target :: big_m - ! Matrix for split explicit advection - type(block_csr_matrix), dimension(:), allocatable :: subcycle_m - ! Pointer to matrix for full projection solve: - type(petsc_csr_matrix_pointer), dimension(:), allocatable :: inner_m - ! Pointer to preconditioner matrix for full projection solve: - type(csr_matrix), pointer :: full_projection_preconditioner - ! Auxiliary matrix for full_projection solve - type(csr_sparsity), pointer :: schur_auxiliary_matrix_sparsity - type(csr_matrix) :: schur_auxiliary_matrix - ! Scaled pressure mass matrix - used for preconditioning full projection solve: - type(csr_matrix), target :: scaled_pressure_mass_matrix - type(csr_sparsity), pointer :: scaled_pressure_mass_matrix_sparsity - ! Left hand matrix of CMC. For incompressible flow this points to ct_m as they are identical, - ! unless for CG pressure with CV tested continuity case when this matrix will be the - ! CV divergence tested matrix and ct_m the CG divergence tested matrix (right hand matrix of CMC). - ! For compressible flow this differs to ct_m in that it will contain the variable density. - type(block_csr_matrix_pointer), dimension(:), allocatable :: ctp_m - ! The lumped mass matrix (may vary per component as absorption could be included) - type(vector_field), dimension(1:size(state)) :: inverse_masslump - ! Mass matrix - type(petsc_csr_matrix), dimension(1:size(state)), target :: mass - ! For DG: - type(block_csr_matrix), dimension(1:size(state)):: inverse_mass - - ! Momentum RHS - type(vector_field), dimension(1:size(state)):: mom_rhs - ! Projection RHS - type(scalar_field) :: projec_rhs - ! RHS for continuity equation - type(scalar_field), dimension(1:size(state)):: ct_rhs - ! RHS for subcycling containing advection bc terms - type(vector_field), dimension(1:size(state)):: subcycle_rhs - - ! Do we want to assemble the KMK stabilisation matrix? - logical :: assemble_kmk - - ! Change in pressure - type(scalar_field) :: delta_p - - ! Dummy fields - type(scalar_field), pointer :: dummyscalar, dummydensity, dummypressure - - ! Pressure and density - type(scalar_field), pointer :: p, density - ! this is the mesh on which the pressure projection is performed - ! usually just p%mesh, but in case of a no_normal_stress free_surface - ! (and in future hydrostatic projection) these are different - type(mesh_type), pointer :: p_mesh - ! Velocity and space - type(vector_field), pointer :: u, x - ! with a no_normal_stress free_surface we use a prognostic free surface - type(scalar_field), pointer:: free_surface - - ! with free-surface or compressible pressure projection pressures - ! are at integer time levels and we apply a theta weighting to the - ! pressure gradient term - real :: theta_pg, theta_u - ! With free-surface or compressible-projection the velocity divergence is - ! calculated at time n+theta_divergence instead of at the end of the timestep - real :: theta_divergence - ! in this case p_theta=theta_pg*p+(1-theta_pg)*old_p - type(scalar_field), pointer :: old_p, p_theta - type(vector_field), pointer :: old_u - ! all of this only applies if use_theta_pg .eqv. .true. - ! without a free surface, or with a free surface and theta==1 - ! use_theta_pg .eqv. .false. and p_theta => p - - ! What is the equation type? - character(len=FIELD_NAME_LEN) :: equation_type, poisson_scheme, schur_scheme, pressure_pmat - - integer :: stat - - ! The list of stiff nodes - ! This is saved because the list is only formed when cmc is assembled, which - ! isn't necessarily every time this subroutine is called but the list is - ! still needed to fix the rhs (applying the fix to cmc itself wipes out the - ! information that would be required to recompile the list) - type(ilist), save :: stiff_nodes_list - - !! Variables for multi-phase flow model - integer :: prognostic_count - ! Do we have a prognostic pressure field to solve for? - logical :: prognostic_p - ! Prognostic pressure field's state index (if present) - integer :: prognostic_p_istate - ! The 'global' CMC matrix (the sum of all individual phase CMC matrices) - type(csr_matrix), pointer :: cmc_global - ! An array of submaterials of the current phase in state(istate). - type(state_type), dimension(:), pointer :: submaterials - ! The index of the current phase (i.e. state(istate)) in the submaterials array - integer :: submaterials_istate - ! The full list of indices between submaterials and state - integer, dimension(:), pointer :: submaterials_indices - ! Do we have fluid-particle drag between phases? - logical :: have_fp_drag - - ewrite(1,*) 'Entering solve_momentum' - - - !! Get diagnostics (equations of state, etc) and assemble matrices - - ! Get some options that are independent of the states - call get_option("/timestepping/timestep", dt) - - ! Are we running a multi-phase simulation? - prognostic_count = option_count("/material_phase/vector_field::Velocity/prognostic") - if(prognostic_count == 0) then - return ! We don't have a velocity field to solve for, so exit. - else if(prognostic_count > 1) then - multiphase = .true. - else - multiphase = .false. + prognostic_count = option_count("/material_phase/vector_field::Velocity/prognostic") + if(prognostic_count == 0) then + return ! We don't have a velocity field to solve for, so exit. + else if(prognostic_count > 1) then + multiphase = .true. + else + multiphase = .false. + end if + ! Do we have fluid-particle drag (for multi-phase simulations)? + have_fp_drag = have_option("/multiphase_interaction/fluid_particle_drag") + + ! Get the pressure p^{n}, and get the assembly options for the divergence and CMC matrices + ! find the first non-aliased pressure + do istate=1, size(state) + p => extract_scalar_field(state(istate), "Pressure", stat) + if (stat/=0) cycle + if (.not. aliased(p)) exit + end do + have_pressure = istate<=size(state) + + if(.not. have_pressure) then + ! Allocate a dummy scalar field in case we have no pressure + allocate(dummypressure) + ! pull a random velocity out of any of the states + u => extract_vector_field(state, "Velocity") + call allocate(dummypressure, u%mesh, "DummyPressure", field_type=FIELD_TYPE_CONSTANT) + call zero(dummypressure) + dummypressure%option_path = "" + + p => dummypressure + p_mesh => u%mesh + old_p => dummypressure + free_surface => dummypressure + + prognostic_p=.false. + standard_fs=.false. + implicit_prognostic_fs=.false. + explicit_prognostic_fs=.false. + + else + + p_mesh => p%mesh + nullify(dummypressure) + old_p => extract_scalar_field(state, "OldPressure", stat) + if(stat/=0) then + old_p => p + end if + prognostic_p = have_option(trim(p%option_path)//"/prognostic") + if (prognostic_p) then + prognostic_p_istate = istate end if - ! Do we have fluid-particle drag (for multi-phase simulations)? - have_fp_drag = have_option("/multiphase_interaction/fluid_particle_drag") - - ! Get the pressure p^{n}, and get the assembly options for the divergence and CMC matrices - ! find the first non-aliased pressure - do istate=1, size(state) - p => extract_scalar_field(state(istate), "Pressure", stat) - if (stat/=0) cycle - if (.not. aliased(p)) exit - end do - have_pressure = istate<=size(state) - if(.not. have_pressure) then - ! Allocate a dummy scalar field in case we have no pressure - allocate(dummypressure) - ! pull a random velocity out of any of the states - u => extract_vector_field(state, "Velocity") - call allocate(dummypressure, u%mesh, "DummyPressure", field_type=FIELD_TYPE_CONSTANT) - call zero(dummypressure) - dummypressure%option_path = "" - - p => dummypressure - p_mesh => u%mesh - old_p => dummypressure - free_surface => dummypressure - - prognostic_p=.false. - standard_fs=.false. - implicit_prognostic_fs=.false. - explicit_prognostic_fs=.false. + u => extract_vector_field(state, "Velocity") + standard_fs = has_standard_free_surface_bc(u) + implicit_prognostic_fs = has_implicit_viscous_free_surface_bc(u) + explicit_prognostic_fs = has_explicit_viscous_free_surface_bc(u) + if(implicit_prognostic_fs.or.explicit_prognostic_fs) then + free_surface => extract_scalar_field(state(istate), "FreeSurface") + assert(have_option(trim(free_surface%option_path)//"/prognostic")) else + free_surface => dummypressure + end if - p_mesh => p%mesh - nullify(dummypressure) - old_p => extract_scalar_field(state, "OldPressure", stat) - if(stat/=0) then - old_p => p - end if - prognostic_p = have_option(trim(p%option_path)//"/prognostic") - if (prognostic_p) then - prognostic_p_istate = istate - end if - - u => extract_vector_field(state, "Velocity") - standard_fs = has_standard_free_surface_bc(u) - implicit_prognostic_fs = has_implicit_viscous_free_surface_bc(u) - explicit_prognostic_fs = has_explicit_viscous_free_surface_bc(u) - - if(implicit_prognostic_fs.or.explicit_prognostic_fs) then - free_surface => extract_scalar_field(state(istate), "FreeSurface") - assert(have_option(trim(free_surface%option_path)//"/prognostic")) - else - free_surface => dummypressure - end if - - if (implicit_prognostic_fs) then - p_mesh => get_extended_pressure_mesh_for_viscous_free_surface(state(istate), & - p%mesh, free_surface) - end if - + if (implicit_prognostic_fs) then + p_mesh => get_extended_pressure_mesh_for_viscous_free_surface(state(istate), & + p%mesh, free_surface) end if - !! Get some pressure options - call get_pressure_options(p) + end if - ! Allocate arrays for the N states/phases - allocate(big_m(size(state))) - allocate(ct_m(size(state))) - allocate(ctp_m(size(state))) - allocate(subcycle_m(size(state))) - allocate(inner_m(size(state))) + !! Get some pressure options + call get_pressure_options(p) - nullify(cmc_global) + ! Allocate arrays for the N states/phases + allocate(big_m(size(state))) + allocate(ct_m(size(state))) + allocate(ctp_m(size(state))) + allocate(subcycle_m(size(state))) + allocate(inner_m(size(state))) - ! Allocate arrays for phase-dependent options - allocate(dg(size(state))) - allocate(subcycle(size(state))) - allocate(lump_mass(size(state))) - allocate(sphere_absorption(size(state))) + nullify(cmc_global) - call profiler_tic("assembly_loop") - assembly_loop: do istate = 1, size(state) + ! Allocate arrays for phase-dependent options + allocate(dg(size(state))) + allocate(subcycle(size(state))) + allocate(lump_mass(size(state))) + allocate(sphere_absorption(size(state))) - ! Get the velocity u^{n} - u => extract_vector_field(state(istate), "Velocity", stat) - ! If there's no velocity then cycle - if(stat/=0) cycle - ! If this is an aliased velocity then cycle - if(aliased(u)) cycle - ! If the velocity isn't prognostic then cycle - if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle + call profiler_tic("assembly_loop") + assembly_loop: do istate = 1, size(state) - ! Calculate equations of state, etc. - call profiler_tic("momentum_diagnostics") + ! Get the velocity u^{n} + u => extract_vector_field(state(istate), "Velocity", stat) + ! If there's no velocity then cycle + if(stat/=0) cycle + ! If this is an aliased velocity then cycle + if(aliased(u)) cycle + ! If the velocity isn't prognostic then cycle + if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle - ! This sets up an array of the submaterials of a phase. - ! NB: The submaterials array includes the current state itself, at index submaterials_istate. - call get_phase_submaterials(state, istate, submaterials, submaterials_istate, submaterials_indices) - call calculate_momentum_diagnostics(state, istate, submaterials, submaterials_istate, submaterials_indices) - deallocate(submaterials) - deallocate(submaterials_indices) + ! Calculate equations of state, etc. + call profiler_tic("momentum_diagnostics") - call profiler_toc("momentum_diagnostics") + ! This sets up an array of the submaterials of a phase. + ! NB: The submaterials array includes the current state itself, at index submaterials_istate. + call get_phase_submaterials(state, istate, submaterials, submaterials_istate, submaterials_indices) + call calculate_momentum_diagnostics(state, istate, submaterials, submaterials_istate, submaterials_indices) + deallocate(submaterials) + deallocate(submaterials_indices) - ! Print out some statistics for the velocity - ewrite_minmax(u) + call profiler_toc("momentum_diagnostics") - x => extract_vector_field(state(istate), "Coordinate") + ! Print out some statistics for the velocity + ewrite_minmax(u) - !! Get some velocity options: - call get_velocity_options(state, istate, u) + x => extract_vector_field(state(istate), "Coordinate") - if(.not. have_pressure) then + !! Get some velocity options: + call get_velocity_options(state, istate, u) - ! Don't bother solving for pressure if a pressure field doesn't exist - nullify(ct_m(istate)%ptr) - reassemble_ct_m = .false. - nullify(cmc_m) - reassemble_cmc_m = .false. + if(.not. have_pressure) then + + ! Don't bother solving for pressure if a pressure field doesn't exist + nullify(ct_m(istate)%ptr) + reassemble_ct_m = .false. + nullify(cmc_m) + reassemble_cmc_m = .false. + else + + call profiler_tic(p, "assembly") + ! Get the pressure gradient matrix (i.e. the divergence matrix) + ! reassemble_ct_m is set to true if it does not already exist in state(i) + if (implicit_prognostic_fs) then + ct_m(istate)%ptr => get_extended_velocity_divergence_matrix(state(istate), u, free_surface, p_mesh, get_ct=reassemble_ct_m) else + ct_m(istate)%ptr => get_velocity_divergence_matrix(state(istate), get_ct=reassemble_ct_m) + end if + reassemble_ct_m = reassemble_ct_m .or. reassemble_all_ct_m - call profiler_tic(p, "assembly") - ! Get the pressure gradient matrix (i.e. the divergence matrix) - ! reassemble_ct_m is set to true if it does not already exist in state(i) + ! For the CG pressure with CV tested continuity case + ! get the CV tested pressure gradient matrix (i.e. the divergence matrix) + ! if required with a different unique name. Note there is no need + ! to again decide reassemble_ct_m as ctp_m for this case is assembled when ct_m is. + if (.not. (compressible_eos .or. shallow_water_projection) .and. cg_pressure_cv_test_continuity) then if (implicit_prognostic_fs) then - ct_m(istate)%ptr => get_extended_velocity_divergence_matrix(state(istate), u, free_surface, p_mesh, get_ct=reassemble_ct_m) + ctp_m(istate)%ptr => get_extended_velocity_divergence_matrix(state(istate), u, free_surface, p_mesh, ct_m_name = "CVTestedExtendedVelocityDivergenceMatrix") else - ct_m(istate)%ptr => get_velocity_divergence_matrix(state(istate), get_ct=reassemble_ct_m) + ctp_m(istate)%ptr => get_velocity_divergence_matrix(state(istate), ct_m_name = "CVTestedVelocityDivergenceMatrix") end if - reassemble_ct_m = reassemble_ct_m .or. reassemble_all_ct_m + end if - ! For the CG pressure with CV tested continuity case - ! get the CV tested pressure gradient matrix (i.e. the divergence matrix) - ! if required with a different unique name. Note there is no need - ! to again decide reassemble_ct_m as ctp_m for this case is assembled when ct_m is. - if (.not. (compressible_eos .or. shallow_water_projection) .and. cg_pressure_cv_test_continuity) then - if (implicit_prognostic_fs) then - ctp_m(istate)%ptr => get_extended_velocity_divergence_matrix(state(istate), u, free_surface, p_mesh, ct_m_name = "CVTestedExtendedVelocityDivergenceMatrix") - else - ctp_m(istate)%ptr => get_velocity_divergence_matrix(state(istate), ct_m_name = "CVTestedVelocityDivergenceMatrix") - end if - end if + ! Get the pressure poisson matrix (i.e. the CMC/projection matrix) + if (implicit_prognostic_fs) then + cmc_m => get_extended_pressure_poisson_matrix(state(istate), ct_m(istate)%ptr, p_mesh, get_cmc=reassemble_cmc_m) + else + cmc_m => get_pressure_poisson_matrix(state(istate), get_cmc=reassemble_cmc_m) + end if + reassemble_cmc_m = reassemble_cmc_m .or. reassemble_all_cmc_m - ! Get the pressure poisson matrix (i.e. the CMC/projection matrix) - if (implicit_prognostic_fs) then - cmc_m => get_extended_pressure_poisson_matrix(state(istate), ct_m(istate)%ptr, p_mesh, get_cmc=reassemble_cmc_m) - else - cmc_m => get_pressure_poisson_matrix(state(istate), get_cmc=reassemble_cmc_m) - end if - reassemble_cmc_m = reassemble_cmc_m .or. reassemble_all_cmc_m + call profiler_toc(p, "assembly") - call profiler_toc(p, "assembly") + end if + ewrite_minmax(p) - end if - ewrite_minmax(p) - - allocate(dummydensity) - call allocate(dummydensity, x%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) - call set(dummydensity, 1.0) - dummydensity%option_path = "" - - allocate(dummyscalar) - call allocate(dummyscalar, x%mesh, "DummyScalar", field_type=FIELD_TYPE_CONSTANT) - call zero(dummyscalar) - dummyscalar%option_path = "" - - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - call get_option(trim(u%option_path)//"/prognostic/equation[0]/name", & - equation_type) - select case(equation_type) - case("LinearMomentum") - density=>extract_scalar_field(state(istate), "Density") - reassemble_cmc_m = reassemble_cmc_m .or. .not.constant_field(density) - case("Boussinesq", "ShallowWater", "Drainage") - density=>dummydensity - case default - ! developer error... out of sync options input and code - FLAbort("Unknown equation type for velocity") - end select - ewrite_minmax(density) + allocate(dummydensity) + call allocate(dummydensity, x%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) + call set(dummydensity, 1.0) + dummydensity%option_path = "" + + allocate(dummyscalar) + call allocate(dummyscalar, x%mesh, "DummyScalar", field_type=FIELD_TYPE_CONSTANT) + call zero(dummyscalar) + dummyscalar%option_path = "" + + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + call get_option(trim(u%option_path)//"/prognostic/equation[0]/name", & + equation_type) + select case(equation_type) + case("LinearMomentum") + density=>extract_scalar_field(state(istate), "Density") + reassemble_cmc_m = reassemble_cmc_m .or. .not.constant_field(density) + case("Boussinesq", "ShallowWater", "Drainage") + density=>dummydensity + case default + ! developer error... out of sync options input and code + FLAbort("Unknown equation type for velocity") + end select + ewrite_minmax(density) - if(full_schur) then - ! Check to see whether pressure cmc_m preconditioning matrix is needed: - call get_option(trim(p%option_path)//& - &"/prognostic/scheme/use_projection_method"//& - &"/full_schur_complement/preconditioner_matrix[0]/name", pressure_pmat) - - ! this is an utter mess, Rhodri, please clean up! - select case(pressure_pmat) - case("LumpedSchurComplement") - full_projection_preconditioner => cmc_m - case("DiagonalSchurComplement") - reassemble_cmc_m = .false. - get_diag_schur = .true. - full_projection_preconditioner => cmc_m - case("ScaledPressureMassMatrix") - reassemble_cmc_m = .false. - get_scaled_pressure_mass_matrix = .true. - full_projection_preconditioner => scaled_pressure_mass_matrix - case("NoPreconditionerMatrix") - reassemble_cmc_m = .false. - full_projection_preconditioner => cmc_m - case default - ! Developer error... out of sync options input and code - FLAbort("Unknown Matrix Type for Full_Projection") - end select - - ! Decide on configuration of inner_m for full_projection solve: - call get_option(trim(p%option_path)//& - &"/prognostic/scheme/use_projection_method"//& - &"/full_schur_complement/inner_matrix[0]/name", schur_scheme) - select case(schur_scheme) - case("FullMassMatrix") - inner_m(istate)%ptr => mass(istate) - case("FullMomentumMatrix") - inner_m(istate)%ptr => big_m(istate) - case default - ! Developer error... out of sync options input and code - FLAbort("Unknown Matrix Type for Full_Projection") - end select - end if + if(full_schur) then + ! Check to see whether pressure cmc_m preconditioning matrix is needed: + call get_option(trim(p%option_path)//& + &"/prognostic/scheme/use_projection_method"//& + &"/full_schur_complement/preconditioner_matrix[0]/name", pressure_pmat) + + ! this is an utter mess, Rhodri, please clean up! + select case(pressure_pmat) + case("LumpedSchurComplement") + full_projection_preconditioner => cmc_m + case("DiagonalSchurComplement") + reassemble_cmc_m = .false. + get_diag_schur = .true. + full_projection_preconditioner => cmc_m + case("ScaledPressureMassMatrix") + reassemble_cmc_m = .false. + get_scaled_pressure_mass_matrix = .true. + full_projection_preconditioner => scaled_pressure_mass_matrix + case("NoPreconditionerMatrix") + reassemble_cmc_m = .false. + full_projection_preconditioner => cmc_m + case default + ! Developer error... out of sync options input and code + FLAbort("Unknown Matrix Type for Full_Projection") + end select - if (standard_fs .or. implicit_prognostic_fs .or. compressible_eos .or. shallow_water_projection) then - ! this needs fixing for multiphase theta_pg could in principle be chosen - ! per phase but then we need an array and we'd have to include theta_pg - ! in cmc_m, i.e. solve for theta_div*dt*dp instead of theta_div*theta_pg*dt*dp - ! theta_div can only be set once, but where and what is the default? - if (has_boundary_condition(u, "free_surface") .and. multiphase) then - FLExit("Multiphase does not work with a free surface.") - end if + ! Decide on configuration of inner_m for full_projection solve: + call get_option(trim(p%option_path)//& + &"/prognostic/scheme/use_projection_method"//& + &"/full_schur_complement/inner_matrix[0]/name", schur_scheme) + select case(schur_scheme) + case("FullMassMatrix") + inner_m(istate)%ptr => mass(istate) + case("FullMomentumMatrix") + inner_m(istate)%ptr => big_m(istate) + case default + ! Developer error... out of sync options input and code + FLAbort("Unknown Matrix Type for Full_Projection") + end select + end if - call get_option( trim(u%option_path)//'/prognostic/temporal_discretisation/theta', & - theta_u) - ! With free surface or compressible-projection pressures are at integer - ! time levels and we apply a theta-weighting to the pressure gradient term - ! Also, obtain theta-weighting to be used in divergence term - call get_option( trim(u%option_path)//'/prognostic/temporal_discretisation/theta_pressure_gradient', & - theta_pg, default=theta_u) - use_theta_pg = (theta_pg/=1.0) - call get_option( trim(u%option_path)//& - '/prognostic/temporal_discretisation/theta_divergence', & - theta_divergence, default=theta_u) - use_theta_divergence = (theta_divergence/=1.0) - ewrite(2,*) "Pressure gradient is evaluated at n+theta_pg" - ewrite(2,*) "theta_pg: ", theta_pg - ewrite(2,*) "Velocity divergence is evaluated at n+theta_divergence" - ewrite(2,*) "theta_divergence: ", theta_divergence - - ! Note: Compressible multiphase simulations work, but only when use_theta_pg and use_theta_divergence - ! are false. This needs improving - see comment above. - if((compressible_eos .or. shallow_water_projection) .and. multiphase .and. (use_theta_pg .or. use_theta_divergence)) then - ewrite(-1,*) "Currently, for compressible multiphase flow simulations, the" - ewrite(-1,*) "temporal_discretisation/theta and temporal_discretisation/theta_divergence values" - ewrite(-1,*) "for each Velocity field must be set to 1.0." - FLExit("Multiphase does not work when use_theta_pg or use_theta_divergence are true.") - end if - else - ! Pressures are, as usual, staggered in time with the velocities - use_theta_pg=.false. - use_theta_divergence=.false. - theta_divergence=1.0 - theta_pg=1.0 + if (standard_fs .or. implicit_prognostic_fs .or. compressible_eos .or. shallow_water_projection) then + ! this needs fixing for multiphase theta_pg could in principle be chosen + ! per phase but then we need an array and we'd have to include theta_pg + ! in cmc_m, i.e. solve for theta_div*dt*dp instead of theta_div*theta_pg*dt*dp + ! theta_div can only be set once, but where and what is the default? + if (has_boundary_condition(u, "free_surface") .and. multiphase) then + FLExit("Multiphase does not work with a free surface.") end if - if (implicit_prognostic_fs) then - allocate(p_theta) - ! allocate p_theta on the extended mesh: - call allocate(p_theta, p_mesh, "PressureAndFreeSurfaceTheta") - p_theta%option_path=p%option_path ! Use p's solver options - call copy_to_extended_p(p, free_surface, theta_pg, p_theta) - else if (use_theta_pg) then - allocate(p_theta) - call allocate(p_theta, p_mesh, "PressureTheta") - - ! p_theta = theta*p + (1-theta)*old_p - call set(p_theta, p, old_p, theta_pg) - p_theta%option_path=p%option_path ! Use p's solver options - else - p_theta => p - theta_pg=1.0 + call get_option( trim(u%option_path)//'/prognostic/temporal_discretisation/theta', & + theta_u) + ! With free surface or compressible-projection pressures are at integer + ! time levels and we apply a theta-weighting to the pressure gradient term + ! Also, obtain theta-weighting to be used in divergence term + call get_option( trim(u%option_path)//'/prognostic/temporal_discretisation/theta_pressure_gradient', & + theta_pg, default=theta_u) + use_theta_pg = (theta_pg/=1.0) + call get_option( trim(u%option_path)//& + '/prognostic/temporal_discretisation/theta_divergence', & + theta_divergence, default=theta_u) + use_theta_divergence = (theta_divergence/=1.0) + ewrite(2,*) "Pressure gradient is evaluated at n+theta_pg" + ewrite(2,*) "theta_pg: ", theta_pg + ewrite(2,*) "Velocity divergence is evaluated at n+theta_divergence" + ewrite(2,*) "theta_divergence: ", theta_divergence + + ! Note: Compressible multiphase simulations work, but only when use_theta_pg and use_theta_divergence + ! are false. This needs improving - see comment above. + if((compressible_eos .or. shallow_water_projection) .and. multiphase .and. (use_theta_pg .or. use_theta_divergence)) then + ewrite(-1,*) "Currently, for compressible multiphase flow simulations, the" + ewrite(-1,*) "temporal_discretisation/theta and temporal_discretisation/theta_divergence values" + ewrite(-1,*) "for each Velocity field must be set to 1.0." + FLExit("Multiphase does not work when use_theta_pg or use_theta_divergence are true.") end if + else + ! Pressures are, as usual, staggered in time with the velocities + use_theta_pg=.false. + use_theta_divergence=.false. + theta_divergence=1.0 + theta_pg=1.0 + end if - call profiler_tic(u, "assembly") - ! Allocation of big_m - if(dg(istate)) then - call allocate_big_m_dg(state(istate), big_m(istate), u) - - if(subcycle(istate)) then - u_sparsity => get_csr_sparsity_firstorder(state, u%mesh, u%mesh) - ! subcycle_m currently only contains advection, so diagonal=.true. - call allocate(subcycle_m(istate), u_sparsity, (/u%dim, u%dim/), & - diagonal=.true., name = "subcycle_m") - call allocate(subcycle_rhs(istate), u%dim, u%mesh, "SubCycleMomentumRHS") - end if - else - ! Create a sparsity if necessary or pull it from state: + if (implicit_prognostic_fs) then + allocate(p_theta) + ! allocate p_theta on the extended mesh: + call allocate(p_theta, p_mesh, "PressureAndFreeSurfaceTheta") + p_theta%option_path=p%option_path ! Use p's solver options + call copy_to_extended_p(p, free_surface, theta_pg, p_theta) + else if (use_theta_pg) then + allocate(p_theta) + call allocate(p_theta, p_mesh, "PressureTheta") + + ! p_theta = theta*p + (1-theta)*old_p + call set(p_theta, p, old_p, theta_pg) + p_theta%option_path=p%option_path ! Use p's solver options + else + p_theta => p + theta_pg=1.0 + end if + + call profiler_tic(u, "assembly") + ! Allocation of big_m + if(dg(istate)) then + call allocate_big_m_dg(state(istate), big_m(istate), u) + + if(subcycle(istate)) then u_sparsity => get_csr_sparsity_firstorder(state, u%mesh, u%mesh) - ! and then allocate - call allocate(big_m(istate), u_sparsity, (/u%dim, u%dim/), group_size=(/u%dim, u%dim/),& - diagonal=diagonal_big_m, name="BIG_m") + ! subcycle_m currently only contains advection, so diagonal=.true. + call allocate(subcycle_m(istate), u_sparsity, (/u%dim, u%dim/), & + diagonal=.true., name = "subcycle_m") + call allocate(subcycle_rhs(istate), u%dim, u%mesh, "SubCycleMomentumRHS") end if + else + ! Create a sparsity if necessary or pull it from state: + u_sparsity => get_csr_sparsity_firstorder(state, u%mesh, u%mesh) + ! and then allocate + call allocate(big_m(istate), u_sparsity, (/u%dim, u%dim/), group_size=(/u%dim, u%dim/),& + diagonal=diagonal_big_m, name="BIG_m") + end if - ! Initialise the big_m, ct_m and ctp_m matrices - call zero(big_m(istate)) - if(reassemble_ct_m) then - call zero(ct_m(istate)%ptr) - if (.not.(compressible_eos .or. shallow_water_projection) .and. cg_pressure_cv_test_continuity) then - call zero(ctp_m(istate)%ptr) - end if + ! Initialise the big_m, ct_m and ctp_m matrices + call zero(big_m(istate)) + if(reassemble_ct_m) then + call zero(ct_m(istate)%ptr) + if (.not.(compressible_eos .or. shallow_water_projection) .and. cg_pressure_cv_test_continuity) then + call zero(ctp_m(istate)%ptr) end if + end if - ! Allocate the momentum RHS - call allocate(mom_rhs(istate), u%dim, u%mesh, "MomentumRHS") - call zero(mom_rhs(istate)) - ! Allocate the ct RHS - call allocate(ct_rhs(istate), p_mesh, "DivergenceRHS") - call zero(ct_rhs(istate)) - call profiler_toc(u, "assembly") + ! Allocate the momentum RHS + call allocate(mom_rhs(istate), u%dim, u%mesh, "MomentumRHS") + call zero(mom_rhs(istate)) + ! Allocate the ct RHS + call allocate(ct_rhs(istate), p_mesh, "DivergenceRHS") + call zero(ct_rhs(istate)) + call profiler_toc(u, "assembly") - if(has_scalar_field(state(istate), hp_name)) then - call calculate_hydrostatic_pressure(state(istate)) - end if - if(has_vector_field(state(istate), hpg_name)) then - call calculate_hydrostatic_pressure_gradient(state(istate)) + if(has_scalar_field(state(istate), hp_name)) then + call calculate_hydrostatic_pressure(state(istate)) + end if + if(has_vector_field(state(istate), hpg_name)) then + call calculate_hydrostatic_pressure_gradient(state(istate)) + end if + if(has_scalar_field(state(istate), gp_name)) then + call calculate_geostrophic_pressure_options(state(istate)) + end if + + if (has_vector_field(state(istate), "VelocityDrainageK1")) then + call calculate_drainage_source_absor(state(istate)) + endif + + ! Assemble the momentum equation + call profiler_tic(u, "assembly") + if(dg(istate)) then + if(subcycle(istate)) then + call construct_momentum_dg(u, p, density, x, & + big_m(istate), mom_rhs(istate), state(istate), & + inverse_masslump=inverse_masslump(istate), & + inverse_mass=inverse_mass(istate), & + include_pressure_bcs=.not. cv_pressure, & + subcycle_m=subcycle_m(istate), subcycle_rhs=subcycle_rhs(istate)) + else + call construct_momentum_dg(u, p, density, x, & + big_m(istate), mom_rhs(istate), state(istate), & + inverse_masslump=inverse_masslump(istate), & + inverse_mass=inverse_mass(istate), & + include_pressure_bcs=.not. cv_pressure) end if if(has_scalar_field(state(istate), gp_name)) then - call calculate_geostrophic_pressure_options(state(istate)) + call subtract_geostrophic_pressure_gradient(mom_rhs(istate), state(istate)) end if + else + ! This call will form the ct_rhs, which for compressible_eos + ! or cg_pressure_cv_test_continuity is formed for a second time later below. + call construct_momentum_cg(u, p, density, x, & + big_m(istate), mom_rhs(istate), ct_m(istate)%ptr, & + ct_rhs(istate), mass(istate), inverse_masslump(istate), & + state(istate), & + assemble_ct_matrix_here=reassemble_ct_m .and. .not. cv_pressure, & + include_pressure_and_continuity_bcs=.not. cv_pressure) + end if - if (has_vector_field(state(istate), "VelocityDrainageK1")) then - call calculate_drainage_source_absor(state(istate)) - endif - - ! Assemble the momentum equation - call profiler_tic(u, "assembly") - if(dg(istate)) then - if(subcycle(istate)) then - call construct_momentum_dg(u, p, density, x, & - big_m(istate), mom_rhs(istate), state(istate), & - inverse_masslump=inverse_masslump(istate), & - inverse_mass=inverse_mass(istate), & - include_pressure_bcs=.not. cv_pressure, & - subcycle_m=subcycle_m(istate), subcycle_rhs=subcycle_rhs(istate)) - else - call construct_momentum_dg(u, p, density, x, & - big_m(istate), mom_rhs(istate), state(istate), & - inverse_masslump=inverse_masslump(istate), & - inverse_mass=inverse_mass(istate), & - include_pressure_bcs=.not. cv_pressure) - end if - if(has_scalar_field(state(istate), gp_name)) then - call subtract_geostrophic_pressure_gradient(mom_rhs(istate), state(istate)) - end if - else - ! This call will form the ct_rhs, which for compressible_eos - ! or cg_pressure_cv_test_continuity is formed for a second time later below. - call construct_momentum_cg(u, p, density, x, & - big_m(istate), mom_rhs(istate), ct_m(istate)%ptr, & - ct_rhs(istate), mass(istate), inverse_masslump(istate), & - state(istate), & - assemble_ct_matrix_here=reassemble_ct_m .and. .not. cv_pressure, & - include_pressure_and_continuity_bcs=.not. cv_pressure) - end if + ! If CV pressure then add in any dirichlet pressure BC integrals to the mom_rhs. + if (cv_pressure) then + call add_pressure_dirichlet_bcs_cv(mom_rhs(istate), u, p, state(istate)) + end if - ! If CV pressure then add in any dirichlet pressure BC integrals to the mom_rhs. - if (cv_pressure) then - call add_pressure_dirichlet_bcs_cv(mom_rhs(istate), u, p, state(istate)) - end if + ! Add in multiphase interactions (e.g. fluid-particle drag) if necessary + ! Note: this is done outside of construct_momentum_cg/dg to keep things + ! neater in Momentum_CG/DG.F90, since we would need to pass around multiple phases + ! and their fields otherwise. + if(multiphase .and. have_fp_drag) then + call add_fluid_particle_drag(state, istate, u, x, big_m(istate), mom_rhs(istate)) + end if - ! Add in multiphase interactions (e.g. fluid-particle drag) if necessary - ! Note: this is done outside of construct_momentum_cg/dg to keep things - ! neater in Momentum_CG/DG.F90, since we would need to pass around multiple phases - ! and their fields otherwise. - if(multiphase .and. have_fp_drag) then - call add_fluid_particle_drag(state, istate, u, x, big_m(istate), mom_rhs(istate)) - end if + call profiler_toc(u, "assembly") - call profiler_toc(u, "assembly") + if(has_scalar_field(state(istate), hp_name)) then + call subtract_hydrostatic_pressure_gradient(mom_rhs(istate), state(istate)) + end if + if(has_vector_field(state(istate), hpg_name)) then + call subtract_hydrostatic_pressure_gradient(mom_rhs(istate), state(istate)) + end if + if(has_scalar_field(state(istate), vbp_name)) then + call calculate_vertical_balance_pressure(state(istate)) + call subtract_vertical_balance_pressure_gradient(mom_rhs(istate), state(istate)) + end if - if(has_scalar_field(state(istate), hp_name)) then - call subtract_hydrostatic_pressure_gradient(mom_rhs(istate), state(istate)) - end if - if(has_vector_field(state(istate), hpg_name)) then - call subtract_hydrostatic_pressure_gradient(mom_rhs(istate), state(istate)) - end if - if(has_scalar_field(state(istate), vbp_name)) then - call calculate_vertical_balance_pressure(state(istate)) - call subtract_vertical_balance_pressure_gradient(mom_rhs(istate), state(istate)) - end if + call profiler_tic(u, "assembly") + if (has_boundary_condition(u, "wind_forcing")) then + call wind_forcing(state(istate), mom_rhs(istate)) + end if - call profiler_tic(u, "assembly") - if (has_boundary_condition(u, "wind_forcing")) then - call wind_forcing(state(istate), mom_rhs(istate)) - end if + if (has_boundary_condition(u, "drag")) then + call drag_surface(big_m(istate), mom_rhs(istate), state(istate), density) + end if - if (has_boundary_condition(u, "drag")) then - call drag_surface(big_m(istate), mom_rhs(istate), state(istate), density) - end if + call profiler_toc(u, "assembly") - call profiler_toc(u, "assembly") + call profiler_tic(p, "assembly") - call profiler_tic(p, "assembly") + ! Assemble divergence matrix C^T. + ! At the moment cg does its own ct assembly. We might change this in the future. + ! This call will form the ct_rhs, which for compressible_eos + ! or cg_pressure_cv_test_continuity is formed for a second time later below. + if(dg(istate) .and. .not. cv_pressure) then + call assemble_divergence_matrix_cg(ct_m(istate)%ptr, state(istate), ct_rhs=ct_rhs(istate), & + test_mesh=p_theta%mesh, field=u, get_ct=reassemble_ct_m) + end if - ! Assemble divergence matrix C^T. - ! At the moment cg does its own ct assembly. We might change this in the future. + if(cv_pressure) then ! This call will form the ct_rhs, which for compressible_eos - ! or cg_pressure_cv_test_continuity is formed for a second time later below. - if(dg(istate) .and. .not. cv_pressure) then - call assemble_divergence_matrix_cg(ct_m(istate)%ptr, state(istate), ct_rhs=ct_rhs(istate), & - test_mesh=p_theta%mesh, field=u, get_ct=reassemble_ct_m) + ! is formed for a second time later below. + call assemble_divergence_matrix_cv(ct_m(istate)%ptr, state(istate), ct_rhs=ct_rhs(istate), & + test_mesh=p_theta%mesh, field=u, get_ct=reassemble_ct_m) + if (implicit_prognostic_fs .and. reassemble_ct_m) then + call add_implicit_viscous_free_surface_integrals_cv(state(istate), & + ct_m(istate)%ptr, u, p_mesh, free_surface) end if - - if(cv_pressure) then - ! This call will form the ct_rhs, which for compressible_eos - ! is formed for a second time later below. - call assemble_divergence_matrix_cv(ct_m(istate)%ptr, state(istate), ct_rhs=ct_rhs(istate), & - test_mesh=p_theta%mesh, field=u, get_ct=reassemble_ct_m) - if (implicit_prognostic_fs .and. reassemble_ct_m) then - call add_implicit_viscous_free_surface_integrals_cv(state(istate), & - ct_m(istate)%ptr, u, p_mesh, free_surface) - end if - if (explicit_prognostic_fs) then - call add_explicit_viscous_free_surface_integrals_cv(state(istate), & - ct_m(istate)%ptr, reassemble_ct_m, & - u, p_mesh, free_surface, mom_rhs=mom_rhs(istate)) - end if - else - if (implicit_prognostic_fs .and. reassemble_ct_m) then - call add_implicit_viscous_free_surface_integrals(state(istate), & - ct_m(istate)%ptr, u, p_mesh, free_surface) - end if - if (explicit_prognostic_fs) then - call add_explicit_viscous_free_surface_integrals(state(istate), & - mom_rhs(istate), ct_m(istate)%ptr, reassemble_ct_m, & - u, p_mesh, free_surface) - end if + if (explicit_prognostic_fs) then + call add_explicit_viscous_free_surface_integrals_cv(state(istate), & + ct_m(istate)%ptr, reassemble_ct_m, & + u, p_mesh, free_surface, mom_rhs=mom_rhs(istate)) end if - - call profiler_toc(p, "assembly") - - call profiler_tic(u, "assembly") - if (have_rotated_bcs(u)) then - ! Rotates big_m, rhs and the velocity field at strong, surface_aligned dirichlet bcs - call rotate_momentum_equation(big_m(istate), mom_rhs(istate), u, state(istate), dg(istate)) - if (reassemble_ct_m) then - call rotate_ct_m(ct_m(istate)%ptr, u) - end if + else + if (implicit_prognostic_fs .and. reassemble_ct_m) then + call add_implicit_viscous_free_surface_integrals(state(istate), & + ct_m(istate)%ptr, u, p_mesh, free_surface) end if - if (sphere_absorption(istate)) then - ! On the sphere inverse_masslump can currently only be assembled - ! in the rotated frame. Thus we need to rotate anything that will - ! interact with this. - call rotate_momentum_to_sphere(big_m(istate), mom_rhs(istate), u, state(istate), dg(istate)) - if (reassemble_ct_m) then - call rotate_ct_m_sphere(state(istate), ct_m(istate)%ptr, u) - end if + if (explicit_prognostic_fs) then + call add_explicit_viscous_free_surface_integrals(state(istate), & + mom_rhs(istate), ct_m(istate)%ptr, reassemble_ct_m, & + u, p_mesh, free_surface) end if + end if - call profiler_toc(u, "assembly") + call profiler_toc(p, "assembly") - if (associated(ct_m(istate)%ptr)) then - ewrite_minmax(ct_m(istate)%ptr) + call profiler_tic(u, "assembly") + if (have_rotated_bcs(u)) then + ! Rotates big_m, rhs and the velocity field at strong, surface_aligned dirichlet bcs + call rotate_momentum_equation(big_m(istate), mom_rhs(istate), u, state(istate), dg(istate)) + if (reassemble_ct_m) then + call rotate_ct_m(ct_m(istate)%ptr, u) end if + end if + if (sphere_absorption(istate)) then + ! On the sphere inverse_masslump can currently only be assembled + ! in the rotated frame. Thus we need to rotate anything that will + ! interact with this. + call rotate_momentum_to_sphere(big_m(istate), mom_rhs(istate), u, state(istate), dg(istate)) + if (reassemble_ct_m) then + call rotate_ct_m_sphere(state(istate), ct_m(istate)%ptr, u) + end if + end if - ! Do we want to solve for pressure? - call profiler_tic(p, "assembly") + call profiler_toc(u, "assembly") - if (prognostic_p) then + if (associated(ct_m(istate)%ptr)) then + ewrite_minmax(ct_m(istate)%ptr) + end if - ! Set up the left C matrix in CMC + ! Do we want to solve for pressure? + call profiler_tic(p, "assembly") - if(compressible_eos) then - ! Note: If we are running a compressible multiphase simulation then the C^T matrix for each phase becomes: - ! rho*div(vfrac*u) for each incompressible phase - ! rho*div(vfrac*u) + vfrac*u*grad(rho) for the single compressible phase. + if (prognostic_p) then - allocate(ctp_m(istate)%ptr) - call allocate(ctp_m(istate)%ptr, ct_m(istate)%ptr%sparsity, (/1, u%dim/), name="CTP_m") - ! NOTE that this is not optimal in that the ct_rhs - ! was formed already above. The call here will overwrite those values. - if(cv_pressure) then - call assemble_compressible_divergence_matrix_cv(ctp_m(istate)%ptr, state, ct_rhs(istate)) - else - call assemble_compressible_divergence_matrix_cg(ctp_m(istate)%ptr, state, istate, ct_rhs(istate)) - end if - else if (shallow_water_projection) then + ! Set up the left C matrix in CMC - assert(istate==1) - allocate(ctp_m(1)%ptr) - call allocate(ctp_m(1)%ptr, ct_m(1)%ptr%sparsity, (/1, u%dim/), name="CTP_m") - call assemble_swe_divergence_matrix_cg(ctp_m(1)%ptr, state(1), ct_rhs(1)) + if(compressible_eos) then + ! Note: If we are running a compressible multiphase simulation then the C^T matrix for each phase becomes: + ! rho*div(vfrac*u) for each incompressible phase + ! rho*div(vfrac*u) + vfrac*u*grad(rho) for the single compressible phase. + allocate(ctp_m(istate)%ptr) + call allocate(ctp_m(istate)%ptr, ct_m(istate)%ptr%sparsity, (/1, u%dim/), name="CTP_m") + ! NOTE that this is not optimal in that the ct_rhs + ! was formed already above. The call here will overwrite those values. + if(cv_pressure) then + call assemble_compressible_divergence_matrix_cv(ctp_m(istate)%ptr, state, ct_rhs(istate)) else - ! Incompressible scenario - if (cg_pressure_cv_test_continuity) then - ! Form the CV tested divergence matrix and ct_rhs. - ! This will only reassemble ctp_m when ct_m - ! also requires reassemble. NOTE that this is not optimal in that the ct_rhs - ! was formed already above. The call here will overwrite those values. - call assemble_divergence_matrix_cv(ctp_m(istate)%ptr, state(istate), ct_rhs=ct_rhs(istate), & - test_mesh=p_theta%mesh, field=u, get_ct=reassemble_ct_m) - if (implicit_prognostic_fs .and. reassemble_ct_m) then - call add_implicit_viscous_free_surface_integrals_cv(state(istate), & + call assemble_compressible_divergence_matrix_cg(ctp_m(istate)%ptr, state, istate, ct_rhs(istate)) + end if + else if (shallow_water_projection) then + + assert(istate==1) + allocate(ctp_m(1)%ptr) + call allocate(ctp_m(1)%ptr, ct_m(1)%ptr%sparsity, (/1, u%dim/), name="CTP_m") + call assemble_swe_divergence_matrix_cg(ctp_m(1)%ptr, state(1), ct_rhs(1)) + + else + ! Incompressible scenario + if (cg_pressure_cv_test_continuity) then + ! Form the CV tested divergence matrix and ct_rhs. + ! This will only reassemble ctp_m when ct_m + ! also requires reassemble. NOTE that this is not optimal in that the ct_rhs + ! was formed already above. The call here will overwrite those values. + call assemble_divergence_matrix_cv(ctp_m(istate)%ptr, state(istate), ct_rhs=ct_rhs(istate), & + test_mesh=p_theta%mesh, field=u, get_ct=reassemble_ct_m) + if (implicit_prognostic_fs .and. reassemble_ct_m) then + call add_implicit_viscous_free_surface_integrals_cv(state(istate), & ctp_m(istate)%ptr, u, p_mesh, free_surface) - end if - if (explicit_prognostic_fs) then - call add_explicit_viscous_free_surface_integrals_cv(state(istate), & + end if + if (explicit_prognostic_fs) then + call add_explicit_viscous_free_surface_integrals_cv(state(istate), & ctp_m(istate)%ptr, reassemble_ct_m, & u, p_mesh, free_surface) - end if - else - ! ctp_m is identical to ct_m - ctp_m(istate)%ptr => ct_m(istate)%ptr end if + else + ! ctp_m is identical to ct_m + ctp_m(istate)%ptr => ct_m(istate)%ptr end if + end if - if (compressible_eos .or. shallow_water_projection .or. cg_pressure_cv_test_continuity) then - if (have_rotated_bcs(u)) then - if (dg(istate)) then - call zero_non_owned(u) - end if - call rotate_ct_m(ctp_m(istate)%ptr, u) + if (compressible_eos .or. shallow_water_projection .or. cg_pressure_cv_test_continuity) then + if (have_rotated_bcs(u)) then + if (dg(istate)) then + call zero_non_owned(u) end if - if (sphere_absorption(istate)) then - if (dg(istate)) then - call zero_non_owned(u) - end if - call rotate_ct_m_sphere(state(istate), ctp_m(istate)%ptr, u) + call rotate_ct_m(ctp_m(istate)%ptr, u) + end if + if (sphere_absorption(istate)) then + if (dg(istate)) then + call zero_non_owned(u) end if + call rotate_ct_m_sphere(state(istate), ctp_m(istate)%ptr, u) end if + end if - ewrite_minmax(ctp_m(istate)%ptr) - ewrite_minmax(ct_rhs(istate)) - - ! Decide whether or not to form KMK stabilisation matrix: - apply_kmk = (continuity(p_mesh) >= 0 .and. p_mesh%shape%degree == 1 & - & .and. p_mesh%shape%numbering%family == FAMILY_SIMPLEX & - & .and. continuity(u%mesh) >= 0 .and. u%mesh%shape%degree == 1 & - & .and. u%mesh%shape%numbering%family == FAMILY_SIMPLEX & - & .and. .not. have_option(trim(p%option_path) // & - & "/prognostic/spatial_discretisation/continuous_galerkin/remove_stabilisation_term") & - & .and. .not. cv_pressure) - assemble_kmk = apply_kmk .and. & - ((.not. has_csr_matrix(state(istate), "PressureStabilisationMatrix")) .or. & - have_option(trim(p%option_path)// & - "/prognostic/scheme/update_discretised_equation") .or. & - have_option("/mesh_adaptivity/mesh_movement")) - - - ! Assemble KMK stabilisation matrix if required: - if(assemble_kmk) then - ewrite(2,*) "Assembling P1-P1 stabilisation" - call assemble_kmk_matrix(state(istate), p%mesh, x, theta_pg) + ewrite_minmax(ctp_m(istate)%ptr) + ewrite_minmax(ct_rhs(istate)) + + ! Decide whether or not to form KMK stabilisation matrix: + apply_kmk = (continuity(p_mesh) >= 0 .and. p_mesh%shape%degree == 1 & + & .and. p_mesh%shape%numbering%family == FAMILY_SIMPLEX & + & .and. continuity(u%mesh) >= 0 .and. u%mesh%shape%degree == 1 & + & .and. u%mesh%shape%numbering%family == FAMILY_SIMPLEX & + & .and. .not. have_option(trim(p%option_path) // & + & "/prognostic/spatial_discretisation/continuous_galerkin/remove_stabilisation_term") & + & .and. .not. cv_pressure) + assemble_kmk = apply_kmk .and. & + ((.not. has_csr_matrix(state(istate), "PressureStabilisationMatrix")) .or. & + have_option(trim(p%option_path)// & + "/prognostic/scheme/update_discretised_equation") .or. & + have_option("/mesh_adaptivity/mesh_movement")) + + + ! Assemble KMK stabilisation matrix if required: + if(assemble_kmk) then + ewrite(2,*) "Assembling P1-P1 stabilisation" + call assemble_kmk_matrix(state(istate), p%mesh, x, theta_pg) + end if + + if(full_schur) then + ! Decide whether we need to assemble an auxiliary matrix for full_projection solve: + if(apply_kmk) then + assemble_schur_auxiliary_matrix = .true. + end if + if (standard_fs .or. implicit_prognostic_fs) then + assemble_schur_auxiliary_matrix = .true. end if - if(full_schur) then - ! Decide whether we need to assemble an auxiliary matrix for full_projection solve: + ! If schur_auxiliary_matrix is needed then assemble it: + if(assemble_schur_auxiliary_matrix) then + ! Get sparsity and assemble: + ewrite(2,*) "Assembling auxiliary matrix for full_projection solve" + if (implicit_prognostic_fs) then + schur_auxiliary_matrix_sparsity => get_extended_schur_auxillary_sparsity(state(istate), & + ct_m(istate)%ptr, p_mesh) + else + schur_auxiliary_matrix_sparsity => get_csr_sparsity_secondorder(state(istate), p%mesh, u%mesh) + end if + call allocate(schur_auxiliary_matrix, schur_auxiliary_matrix_sparsity,& + name="schur_auxiliary_matrix") + ! Initialize matrix: + call zero(schur_auxiliary_matrix) if(apply_kmk) then - assemble_schur_auxiliary_matrix = .true. + ewrite(2,*) "Adding kmk stabilisation matrix to full_projection auxiliary matrix" + call add_kmk_matrix(state(istate), schur_auxiliary_matrix) end if if (standard_fs .or. implicit_prognostic_fs) then - assemble_schur_auxiliary_matrix = .true. - end if - - ! If schur_auxiliary_matrix is needed then assemble it: - if(assemble_schur_auxiliary_matrix) then - ! Get sparsity and assemble: - ewrite(2,*) "Assembling auxiliary matrix for full_projection solve" - if (implicit_prognostic_fs) then - schur_auxiliary_matrix_sparsity => get_extended_schur_auxillary_sparsity(state(istate), & - ct_m(istate)%ptr, p_mesh) - else - schur_auxiliary_matrix_sparsity => get_csr_sparsity_secondorder(state(istate), p%mesh, u%mesh) - end if - call allocate(schur_auxiliary_matrix, schur_auxiliary_matrix_sparsity,& - name="schur_auxiliary_matrix") - ! Initialize matrix: - call zero(schur_auxiliary_matrix) - if(apply_kmk) then - ewrite(2,*) "Adding kmk stabilisation matrix to full_projection auxiliary matrix" - call add_kmk_matrix(state(istate), schur_auxiliary_matrix) - end if - if (standard_fs .or. implicit_prognostic_fs) then - ewrite(2,*) "Adding free surface to full_projection auxiliary matrix" - call add_free_surface_to_cmc_projection(state(istate), & - schur_auxiliary_matrix, dt, theta_pg, & - theta_divergence, assemble_cmc=.true., rhs=ct_rhs(istate)) - end if + ewrite(2,*) "Adding free surface to full_projection auxiliary matrix" + call add_free_surface_to_cmc_projection(state(istate), & + schur_auxiliary_matrix, dt, theta_pg, & + theta_divergence, assemble_cmc=.true., rhs=ct_rhs(istate)) end if end if + end if - !! Assemble the appropriate projection matrix (CMC) - if(reassemble_cmc_m) then - call zero(cmc_m) + !! Assemble the appropriate projection matrix (CMC) + if(reassemble_cmc_m) then + call zero(cmc_m) - if(dg(istate).and.(.not.lump_mass(istate))) then - call assemble_cmc_dg(cmc_m, ctp_m(istate)%ptr, ct_m(istate)%ptr, inverse_mass(istate)) - else - call assemble_masslumped_cmc(cmc_m, ctp_m(istate)%ptr, inverse_masslump(istate), ct_m(istate)%ptr) + if(dg(istate).and.(.not.lump_mass(istate))) then + call assemble_cmc_dg(cmc_m, ctp_m(istate)%ptr, ct_m(istate)%ptr, inverse_mass(istate)) + else + call assemble_masslumped_cmc(cmc_m, ctp_m(istate)%ptr, inverse_masslump(istate), ct_m(istate)%ptr) - ! P1-P1 stabilisation - if (apply_kmk) then - ewrite(2,*) "Adding P1-P1 stabilisation matrix to cmc_m" - call add_kmk_matrix(state(istate), cmc_m) - end if + ! P1-P1 stabilisation + if (apply_kmk) then + ewrite(2,*) "Adding P1-P1 stabilisation matrix to cmc_m" + call add_kmk_matrix(state(istate), cmc_m) end if + end if - if(have_option(trim(p%option_path)//"/prognostic/repair_stiff_nodes")) then - call repair_stiff_nodes(cmc_m, stiff_nodes_list) - end if + if(have_option(trim(p%option_path)//"/prognostic/repair_stiff_nodes")) then + call repair_stiff_nodes(cmc_m, stiff_nodes_list) + end if - end if ! end 'if(reassemble_cmc_m)' + end if ! end 'if(reassemble_cmc_m)' + if (standard_fs .or. implicit_prognostic_fs) then + call add_free_surface_to_cmc_projection(state(istate), & + cmc_m, dt, theta_pg, theta_divergence, & + assemble_cmc=reassemble_cmc_m, rhs=ct_rhs(istate)) + end if + + if(get_diag_schur) then + ! Assemble diagonal Schur complement preconditioner: + call assemble_diagonal_schur(cmc_m, u, inner_m(istate)%ptr, ctp_m(istate)%ptr, ct_m(istate)%ptr) + ! P1-P1 stabilisation: + if (apply_kmk) then + ewrite(2,*) "Adding P1-P1 stabilisation to diagonal schur complement preconditioner matrix" + call add_kmk_matrix(state(istate), cmc_m) + end if if (standard_fs .or. implicit_prognostic_fs) then + ewrite(2,*) "Adding free surface to diagonal schur complement preconditioner matrix" call add_free_surface_to_cmc_projection(state(istate), & - cmc_m, dt, theta_pg, theta_divergence, & - assemble_cmc=reassemble_cmc_m, rhs=ct_rhs(istate)) + cmc_m, dt, theta_pg, theta_divergence, assemble_cmc=.true.) end if + end if - if(get_diag_schur) then - ! Assemble diagonal Schur complement preconditioner: - call assemble_diagonal_schur(cmc_m, u, inner_m(istate)%ptr, ctp_m(istate)%ptr, ct_m(istate)%ptr) - ! P1-P1 stabilisation: - if (apply_kmk) then - ewrite(2,*) "Adding P1-P1 stabilisation to diagonal schur complement preconditioner matrix" - call add_kmk_matrix(state(istate), cmc_m) - end if - if (standard_fs .or. implicit_prognostic_fs) then - ewrite(2,*) "Adding free surface to diagonal schur complement preconditioner matrix" - call add_free_surface_to_cmc_projection(state(istate), & - cmc_m, dt, theta_pg, theta_divergence, assemble_cmc=.true.) - end if + if(get_scaled_pressure_mass_matrix) then + ! Assemble scaled pressure mass matrix which will later be used as a + ! preconditioner in the full projection solve: + ewrite(2,*) "Assembling scaled pressure mass matrix preconditioner" + if (implicit_prognostic_fs) then + scaled_pressure_mass_matrix_sparsity => get_extended_schur_auxillary_sparsity(state(istate), & + ct_m(istate)%ptr, p_mesh) + else + scaled_pressure_mass_matrix_sparsity => get_csr_sparsity_firstorder(state(istate), p%mesh, p%mesh) end if - - if(get_scaled_pressure_mass_matrix) then - ! Assemble scaled pressure mass matrix which will later be used as a - ! preconditioner in the full projection solve: - ewrite(2,*) "Assembling scaled pressure mass matrix preconditioner" - if (implicit_prognostic_fs) then - scaled_pressure_mass_matrix_sparsity => get_extended_schur_auxillary_sparsity(state(istate), & - ct_m(istate)%ptr, p_mesh) - else - scaled_pressure_mass_matrix_sparsity => get_csr_sparsity_firstorder(state(istate), p%mesh, p%mesh) - end if - call allocate(scaled_pressure_mass_matrix, scaled_pressure_mass_matrix_sparsity,& - name="scaled_pressure_mass_matrix") - call assemble_scaled_pressure_mass_matrix(state(istate),scaled_pressure_mass_matrix, p_mesh, dt) - if (implicit_prognostic_fs) then - call add_implicit_viscous_free_surface_scaled_mass_integrals(state(istate), scaled_pressure_mass_matrix, u, p, free_surface, dt) - end if - if (standard_fs .or. implicit_prognostic_fs) then - ewrite(2,*) "Adding free surface to scaled pressure mass matrix preconditioner" - call add_free_surface_to_cmc_projection(state(istate), & - scaled_pressure_mass_matrix, dt, theta_pg, theta_divergence, assemble_cmc=.true.) - end if + call allocate(scaled_pressure_mass_matrix, scaled_pressure_mass_matrix_sparsity,& + name="scaled_pressure_mass_matrix") + call assemble_scaled_pressure_mass_matrix(state(istate),scaled_pressure_mass_matrix, p_mesh, dt) + if (implicit_prognostic_fs) then + call add_implicit_viscous_free_surface_scaled_mass_integrals(state(istate), scaled_pressure_mass_matrix, u, p, free_surface, dt) + end if + if (standard_fs .or. implicit_prognostic_fs) then + ewrite(2,*) "Adding free surface to scaled pressure mass matrix preconditioner" + call add_free_surface_to_cmc_projection(state(istate), & + scaled_pressure_mass_matrix, dt, theta_pg, theta_divergence, assemble_cmc=.true.) end if - - end if ! end of prognostic pressure - call profiler_toc(p, "assembly") - - if (associated(dummypressure)) then - call deallocate(dummypressure) - deallocate(dummypressure) end if - call deallocate(dummydensity) - deallocate(dummydensity) - call deallocate(dummyscalar) - deallocate(dummyscalar) - end do assembly_loop - call profiler_toc("assembly_loop") ! End of Step 1 (diagnostics and matrix assembly) + end if ! end of prognostic pressure + call profiler_toc(p, "assembly") + if (associated(dummypressure)) then + call deallocate(dummypressure) + deallocate(dummypressure) + end if + call deallocate(dummydensity) + deallocate(dummydensity) + call deallocate(dummyscalar) + deallocate(dummyscalar) - !! Obtain pressure guess p^{*} (assemble and solve a Poisson pressure equation for p^{*} if desired) + end do assembly_loop + call profiler_toc("assembly_loop") ! End of Step 1 (diagnostics and matrix assembly) - ! Do we have a prognostic pressure field we can actually solve for? - if(prognostic_p) then - call profiler_tic(p, "assembly") + !! Obtain pressure guess p^{*} (assemble and solve a Poisson pressure equation for p^{*} if desired) - u => extract_vector_field(state(prognostic_p_istate), "Velocity", stat) - x => extract_vector_field(state(prognostic_p_istate), "Coordinate") - ! Are we solving a Poisson pressure equation for a pressure guess p^{*}? - call get_option(trim(p%option_path)//& - "/prognostic/scheme/poisson_pressure_solution", poisson_scheme, & - default="never") - select case (poisson_scheme) - case ("never") - poisson_p = .false. - case ("only first timestep") - poisson_p = at_first_timestep - call set_option(trim(p%option_path)//& - "/prognostic/scheme/poisson_pressure_solution", "never") - case default - FLExit(trim(poisson_scheme)//" is not a legal poisson_pressure_solution") - end select + ! Do we have a prognostic pressure field we can actually solve for? + if(prognostic_p) then + call profiler_tic(p, "assembly") - ! If desired, assemble Poisson pressure equation and get an initial guess at the pressure - if(poisson_p) then - call solve_poisson_pressure(state, prognostic_p_istate, x, u, p, old_p, p_theta, theta_pg, & - ct_m, ctp_m, mom_rhs, ct_rhs, inner_m, inverse_mass, & - inverse_masslump, cmc_m, full_projection_preconditioner, schur_auxiliary_matrix) - end if ! end of Poisson pressure solution + u => extract_vector_field(state(prognostic_p_istate), "Velocity", stat) + x => extract_vector_field(state(prognostic_p_istate), "Coordinate") + + ! Are we solving a Poisson pressure equation for a pressure guess p^{*}? + call get_option(trim(p%option_path)//& + "/prognostic/scheme/poisson_pressure_solution", poisson_scheme, & + default="never") + select case (poisson_scheme) + case ("never") + poisson_p = .false. + case ("only first timestep") + poisson_p = at_first_timestep + call set_option(trim(p%option_path)//& + "/prognostic/scheme/poisson_pressure_solution", "never") + case default + FLExit(trim(poisson_scheme)//" is not a legal poisson_pressure_solution") + end select + + ! If desired, assemble Poisson pressure equation and get an initial guess at the pressure + if(poisson_p) then + call solve_poisson_pressure(state, prognostic_p_istate, x, u, p, old_p, p_theta, theta_pg, & + ct_m, ctp_m, mom_rhs, ct_rhs, inner_m, inverse_mass, & + inverse_masslump, cmc_m, full_projection_preconditioner, schur_auxiliary_matrix) + end if ! end of Poisson pressure solution + + + ! Allocate RHS for pressure correction step + call allocate(projec_rhs, p_mesh, "ProjectionRHS") + call zero(projec_rhs) + call profiler_toc(p, "assembly") + end if ! end of prognostic pressure - ! Allocate RHS for pressure correction step - call allocate(projec_rhs, p_mesh, "ProjectionRHS") - call zero(projec_rhs) + !! Advance velocity from u^{n} to an intermediate velocity u^{*} - call profiler_toc(p, "assembly") - end if ! end of prognostic pressure + call profiler_tic("velocity_solve_loop") + velocity_solve_loop: do istate = 1, size(state) - !! Advance velocity from u^{n} to an intermediate velocity u^{*} + ! Get the velocity u^{n} + u => extract_vector_field(state(istate), "Velocity", stat) - call profiler_tic("velocity_solve_loop") - velocity_solve_loop: do istate = 1, size(state) + ! If there's no velocity then cycle + if(stat/=0) cycle + ! If this is an aliased velocity then cycle + if(aliased(u)) cycle + ! If the velocity isn't prognostic then cycle + if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle - ! Get the velocity u^{n} - u => extract_vector_field(state(istate), "Velocity", stat) + if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin").or.& + have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin")) then - ! If there's no velocity then cycle - if(stat/=0) cycle - ! If this is an aliased velocity then cycle - if(aliased(u)) cycle - ! If the velocity isn't prognostic then cycle - if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle + x => extract_vector_field(state(istate), "Coordinate") - if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin").or.& - have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin")) then - - x => extract_vector_field(state(istate), "Coordinate") - - if(use_theta_divergence) then - ! old_u is only used if use_theta_divergence, i.e. if theta_divergence/=1.0 - old_u => extract_vector_field(state(istate), "OldVelocity") - if (old_u%aliased) then - ! in the case of one non-linear iteration, there is no OldVelocity, - ! it's just aliased to Velocity, therefore we make temp. version - allocate(old_u) - ! give it a distinct name, so we know to deallocate it - call allocate(old_u, u%dim, u%mesh, "TempOldVelocity") - call set(old_u, u) - end if + if(use_theta_divergence) then + ! old_u is only used if use_theta_divergence, i.e. if theta_divergence/=1.0 + old_u => extract_vector_field(state(istate), "OldVelocity") + if (old_u%aliased) then + ! in the case of one non-linear iteration, there is no OldVelocity, + ! it's just aliased to Velocity, therefore we make temp. version + allocate(old_u) + ! give it a distinct name, so we know to deallocate it + call allocate(old_u, u%dim, u%mesh, "TempOldVelocity") + call set(old_u, u) end if + end if - call advance_velocity(state, istate, x, u, p_theta, big_m, ct_m, & - mom_rhs, subcycle_m, subcycle_rhs, inverse_mass) + call advance_velocity(state, istate, x, u, p_theta, big_m, ct_m, & + mom_rhs, subcycle_m, subcycle_rhs, inverse_mass) - if(prognostic_p) then - call assemble_projection(state, istate, u, old_u, p, cmc_m, reassemble_cmc_m, cmc_global, ctp_m, & - ct_rhs, projec_rhs, p_theta, theta_pg, theta_divergence) - end if + if(prognostic_p) then + call assemble_projection(state, istate, u, old_u, p, cmc_m, reassemble_cmc_m, cmc_global, ctp_m, & + ct_rhs, projec_rhs, p_theta, theta_pg, theta_divergence) + end if - ! Deallocate the old velocity field - if(use_theta_divergence) then - if (old_u%name == "TempOldVelocity") then - call deallocate(old_u) - deallocate(old_u) - else if (have_rotated_bcs(u)) then - if (dg(istate)) then - call zero_non_owned(old_u) - end if - call rotate_velocity_back(old_u, state(istate)) + ! Deallocate the old velocity field + if(use_theta_divergence) then + if (old_u%name == "TempOldVelocity") then + call deallocate(old_u) + deallocate(old_u) + else if (have_rotated_bcs(u)) then + if (dg(istate)) then + call zero_non_owned(old_u) end if - if (sphere_absorption(istate)) then - if (dg(istate)) then - call zero_non_owned(old_u) - end if - call rotate_velocity_back_sphere(old_u, state(istate)) + call rotate_velocity_back(old_u, state(istate)) + end if + if (sphere_absorption(istate)) then + if (dg(istate)) then + call zero_non_owned(old_u) end if + call rotate_velocity_back_sphere(old_u, state(istate)) end if + end if - end if ! end of prognostic velocity - - end do velocity_solve_loop - call profiler_toc("velocity_solve_loop") - + end if ! end of prognostic velocity - !! Solve for delta_p -- the pressure correction term - if(prognostic_p) then - call profiler_tic(p, "assembly") + end do velocity_solve_loop + call profiler_toc("velocity_solve_loop") - ! Get the intermediate velocity u^{*} and the coordinate vector field - u=>extract_vector_field(state(prognostic_p_istate), "Velocity", stat) - x=>extract_vector_field(state(prognostic_p_istate), "Coordinate") - if(multiphase) then - cmc_m => cmc_global ! Use the sum over all individual phase CMC matrices - end if + !! Solve for delta_p -- the pressure correction term + if(prognostic_p) then + call profiler_tic(p, "assembly") - call correct_pressure(state, prognostic_p_istate, x, u, p, old_p, delta_p, & - p_theta, free_surface, theta_pg, theta_divergence, & - cmc_m, ct_m, ctp_m, projec_rhs, inner_m, full_projection_preconditioner, & - schur_auxiliary_matrix, stiff_nodes_list) + ! Get the intermediate velocity u^{*} and the coordinate vector field + u=>extract_vector_field(state(prognostic_p_istate), "Velocity", stat) + x=>extract_vector_field(state(prognostic_p_istate), "Coordinate") - call deallocate(projec_rhs) - call profiler_toc(p, "assembly") + if(multiphase) then + cmc_m => cmc_global ! Use the sum over all individual phase CMC matrices end if + call correct_pressure(state, prognostic_p_istate, x, u, p, old_p, delta_p, & + p_theta, free_surface, theta_pg, theta_divergence, & + cmc_m, ct_m, ctp_m, projec_rhs, inner_m, full_projection_preconditioner, & + schur_auxiliary_matrix, stiff_nodes_list) - !! Correct and update velocity fields to u^{n+1} using pressure correction term delta_p - if(prognostic_p) then + call deallocate(projec_rhs) + call profiler_toc(p, "assembly") + end if - call profiler_tic("velocity_correction_loop") - velocity_correction_loop: do istate = 1, size(state) - ! Get the velocity u^{*} - u => extract_vector_field(state(istate), "Velocity", stat) + !! Correct and update velocity fields to u^{n+1} using pressure correction term delta_p + if(prognostic_p) then - ! If there's no velocity then cycle - if(stat/=0) cycle - ! If this is an aliased velocity then cycle - if(aliased(u)) cycle - ! If the velocity isn't prognostic then cycle - if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle + call profiler_tic("velocity_correction_loop") + velocity_correction_loop: do istate = 1, size(state) - if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin").or.& - have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin")) then + ! Get the velocity u^{*} + u => extract_vector_field(state(istate), "Velocity", stat) - call profiler_tic(u, "assembly") + ! If there's no velocity then cycle + if(stat/=0) cycle + ! If this is an aliased velocity then cycle + if(aliased(u)) cycle + ! If the velocity isn't prognostic then cycle + if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle - ! Correct velocity according to new delta_p - if(full_schur) then - call correct_velocity_cg(u, inner_m(istate)%ptr, ct_m(istate)%ptr, delta_p, state(istate)) - else if(lump_mass(istate)) then - call correct_masslumped_velocity(u, inverse_masslump(istate), ct_m(istate)%ptr, delta_p) - else if(dg(istate)) then - call correct_velocity_dg(u, inverse_mass(istate), ct_m(istate)%ptr, delta_p) - else - ! Something's gone wrong in the code - FLAbort("Don't know how to correct the velocity.") - end if + if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin").or.& + have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin")) then - if(implicit_prognostic_fs.or.explicit_prognostic_fs) then - call update_prognostic_free_surface(state(istate), free_surface, implicit_prognostic_fs, & - explicit_prognostic_fs) - end if + call profiler_tic(u, "assembly") - call profiler_toc(u, "assembly") + ! Correct velocity according to new delta_p + if(full_schur) then + call correct_velocity_cg(u, inner_m(istate)%ptr, ct_m(istate)%ptr, delta_p, state(istate)) + else if(lump_mass(istate)) then + call correct_masslumped_velocity(u, inverse_masslump(istate), ct_m(istate)%ptr, delta_p) + else if(dg(istate)) then + call correct_velocity_dg(u, inverse_mass(istate), ct_m(istate)%ptr, delta_p) + else + ! Something's gone wrong in the code + FLAbort("Don't know how to correct the velocity.") + end if - if(compressible_eos .or. shallow_water_projection) then - call deallocate(ctp_m(istate)%ptr) - deallocate(ctp_m(istate)%ptr) - end if + if(implicit_prognostic_fs.or.explicit_prognostic_fs) then + call update_prognostic_free_surface(state(istate), free_surface, implicit_prognostic_fs, & + explicit_prognostic_fs) + end if - end if ! prognostic velocity + call profiler_toc(u, "assembly") - end do velocity_correction_loop - call profiler_toc("velocity_correction_loop") + if(compressible_eos .or. shallow_water_projection) then + call deallocate(ctp_m(istate)%ptr) + deallocate(ctp_m(istate)%ptr) + end if - !! Deallocate some memory reserved for the pressure solve - call deallocate(delta_p) + end if ! prognostic velocity - if(assemble_schur_auxiliary_matrix) then - ! Deallocate schur_auxiliary_matrix: - call deallocate(schur_auxiliary_matrix) - end if + end do velocity_correction_loop + call profiler_toc("velocity_correction_loop") - if(get_scaled_pressure_mass_matrix) then - ! Deallocate scaled pressure mass matrix: - call deallocate(scaled_pressure_mass_matrix) - end if + !! Deallocate some memory reserved for the pressure solve + call deallocate(delta_p) - end if ! prognostic pressure + if(assemble_schur_auxiliary_matrix) then + ! Deallocate schur_auxiliary_matrix: + call deallocate(schur_auxiliary_matrix) + end if - !! Finalisation and memory deallocation - call profiler_tic("finalisation_loop") - finalisation_loop: do istate = 1, size(state) + if(get_scaled_pressure_mass_matrix) then + ! Deallocate scaled pressure mass matrix: + call deallocate(scaled_pressure_mass_matrix) + end if - ! Get the velocity u^{n+1} - u => extract_vector_field(state(istate), "Velocity", stat) + end if ! prognostic pressure - ! If there's no velocity then cycle - if(stat/=0) cycle - ! If this is an aliased velocity then cycle - if(aliased(u)) cycle - ! If the velocity isn't prognostic then cycle - if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle + !! Finalisation and memory deallocation + call profiler_tic("finalisation_loop") + finalisation_loop: do istate = 1, size(state) - if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin").or.& - have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin")) then + ! Get the velocity u^{n+1} + u => extract_vector_field(state(istate), "Velocity", stat) - call finalise_state(state, istate, u, mass, inverse_mass, inverse_masslump, & - big_m, mom_rhs, ct_rhs, subcycle_m, subcycle_rhs) + ! If there's no velocity then cycle + if(stat/=0) cycle + ! If this is an aliased velocity then cycle + if(aliased(u)) cycle + ! If the velocity isn't prognostic then cycle + if(.not.have_option(trim(u%option_path)//"/prognostic")) cycle - end if + if(have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin").or.& + have_option(trim(u%option_path)//"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin")) then - end do finalisation_loop - call profiler_toc("finalisation_loop") + call finalise_state(state, istate, u, mass, inverse_mass, inverse_masslump, & + big_m, mom_rhs, ct_rhs, subcycle_m, subcycle_rhs) - u => extract_vector_field(state, "Velocity") - if(implicit_prognostic_fs .or. use_theta_pg) then - call deallocate(p_theta) - deallocate(p_theta) end if - ! Deallocate arrays of matricies/fields/pointers - deallocate(big_m) - deallocate(ct_m) - deallocate(ctp_m) - deallocate(subcycle_m) - deallocate(inner_m) + end do finalisation_loop + call profiler_toc("finalisation_loop") - if(multiphase .and. associated(cmc_global)) then - call deallocate(cmc_global) - deallocate(cmc_global) - end if + u => extract_vector_field(state, "Velocity") + if(implicit_prognostic_fs .or. use_theta_pg) then + call deallocate(p_theta) + deallocate(p_theta) + end if - ! Deallocate arrays of options - deallocate(dg) - deallocate(subcycle) - deallocate(lump_mass) - deallocate(sphere_absorption) + ! Deallocate arrays of matricies/fields/pointers + deallocate(big_m) + deallocate(ct_m) + deallocate(ctp_m) + deallocate(subcycle_m) + deallocate(inner_m) - end subroutine solve_momentum + if(multiphase .and. associated(cmc_global)) then + call deallocate(cmc_global) + deallocate(cmc_global) + end if + ! Deallocate arrays of options + deallocate(dg) + deallocate(subcycle) + deallocate(lump_mass) + deallocate(sphere_absorption) - subroutine get_velocity_options(state, istate, u) - !!< Gets some velocity options from the options tree + end subroutine solve_momentum - ! An array of buckets full of fields - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate - type(vector_field), pointer :: u + subroutine get_velocity_options(state, istate, u) + !!< Gets some velocity options from the options tree - ! Local variables - integer :: stat - type(vector_field), pointer :: dummy_absorption - logical :: have_viscosity, have_les, stress_form, partial_stress_form, have_coriolis - logical :: on_sphere, have_absorption, have_vertical_stabilization + ! An array of buckets full of fields + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate - ewrite(1,*) 'Entering get_velocity_options' + type(vector_field), pointer :: u + ! Local variables + integer :: stat + type(vector_field), pointer :: dummy_absorption + logical :: have_viscosity, have_les, stress_form, partial_stress_form, have_coriolis + logical :: on_sphere, have_absorption, have_vertical_stabilization - dg(istate) = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin") + ewrite(1,*) 'Entering get_velocity_options' - subcycle(istate) = have_option(trim(u%option_path)//& - &"/prognostic/temporal_discretisation"//& - &"/discontinuous_galerkin/maximum_courant_number_per_subcycle") - ! Are we lumping the mass matrix? - lump_mass(istate) = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/continuous_galerkin/mass_terms"//& - &"/lump_mass_matrix").or.& - have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation"//& - &"/discontinuous_galerkin/mass_terms"//& - &"/lump_mass_matrix") + dg(istate) = have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin") - ! Here is where we try to decide how big big_m should be - have_viscosity = have_option(trim(u%option_path)//& - &"/prognostic/tensor_field::Viscosity") + subcycle(istate) = have_option(trim(u%option_path)//& + &"/prognostic/temporal_discretisation"//& + &"/discontinuous_galerkin/maximum_courant_number_per_subcycle") - ! The following should include a dg option when a stress form version gets implemented - stress_form = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/stress_terms/stress_form") + ! Are we lumping the mass matrix? + lump_mass(istate) = have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/continuous_galerkin/mass_terms"//& + &"/lump_mass_matrix").or.& + have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation"//& + &"/discontinuous_galerkin/mass_terms"//& + &"/lump_mass_matrix") - partial_stress_form = have_option(trim(u%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/stress_terms/partial_stress_form") + ! Here is where we try to decide how big big_m should be + have_viscosity = have_option(trim(u%option_path)//& + &"/prognostic/tensor_field::Viscosity") - have_les = have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/"//& - &"/continuous_galerkin/les_model") + ! The following should include a dg option when a stress form version gets implemented + stress_form = have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/stress_terms/stress_form") - have_coriolis = have_option("/physical_parameters/coriolis") + partial_stress_form = have_option(trim(u%option_path)//& + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/stress_terms/partial_stress_form") - diagonal_big_m = .not.have_coriolis.and.(.not.((have_viscosity.or.have_les).and.(stress_form.or.partial_stress_form))) + have_les = have_option(trim(u%option_path)//"/prognostic/spatial_discretisation/"//& + &"/continuous_galerkin/les_model") - ! Do we want to rotate our equations to include absorption in a spherical geometry? - on_sphere = have_option('/geometry/spherical_earth/') - dummy_absorption => extract_vector_field(state(istate), "VelocityAbsorption", stat) - have_absorption = stat == 0 - have_vertical_stabilization = have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation").or. & - have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") - sphere_absorption(istate) = on_sphere.and.(have_absorption.or.have_vertical_stabilization) + have_coriolis = have_option("/physical_parameters/coriolis") - shallow_water_projection = have_option(trim(u%option_path)//"/prognostic/equation::ShallowWater") - ! NOTE: this relies on get_pressure_options() being called first! - reassemble_all_cmc_m = reassemble_all_cmc_m .or. shallow_water_projection + diagonal_big_m = .not.have_coriolis.and.(.not.((have_viscosity.or.have_les).and.(stress_form.or.partial_stress_form))) - end subroutine get_velocity_options + ! Do we want to rotate our equations to include absorption in a spherical geometry? + on_sphere = have_option('/geometry/spherical_earth/') + dummy_absorption => extract_vector_field(state(istate), "VelocityAbsorption", stat) + have_absorption = stat == 0 + have_vertical_stabilization = have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/vertical_velocity_relaxation").or. & + have_option(trim(u%option_path)//"/prognostic/vertical_stabilization/implicit_buoyancy") + sphere_absorption(istate) = on_sphere.and.(have_absorption.or.have_vertical_stabilization) + shallow_water_projection = have_option(trim(u%option_path)//"/prognostic/equation::ShallowWater") + ! NOTE: this relies on get_pressure_options() being called first! + reassemble_all_cmc_m = reassemble_all_cmc_m .or. shallow_water_projection - subroutine get_pressure_options(p) - !!< Gets some pressure options from the options tree + end subroutine get_velocity_options - type(scalar_field), pointer :: p - ewrite(1,*) 'Entering get_pressure_options' + subroutine get_pressure_options(p) + !!< Gets some pressure options from the options tree - ! Are we using a compressible projection? - compressible_eos = option_count("/material_phase/equation_of_state/compressible") > 0 + type(scalar_field), pointer :: p - reassemble_all_cmc_m = have_option(trim(p%option_path)//& - "/prognostic/scheme/update_discretised_equation") .or. & - compressible_eos + ewrite(1,*) 'Entering get_pressure_options' - reassemble_all_ct_m = have_option(trim(p%option_path)//& - "/prognostic/scheme/update_discretised_equation") + ! Are we using a compressible projection? + compressible_eos = option_count("/material_phase/equation_of_state/compressible") > 0 - pressure_debugging_vtus = have_option(trim(p%option_path)// & - "/prognostic/output/debugging_vtus") - if (pressure_debugging_vtus) then - pdv_count = pdv_count+1 - end if + reassemble_all_cmc_m = have_option(trim(p%option_path)//& + "/prognostic/scheme/update_discretised_equation") .or. & + compressible_eos + + reassemble_all_ct_m = have_option(trim(p%option_path)//& + "/prognostic/scheme/update_discretised_equation") - get_diag_schur = .false. - get_scaled_pressure_mass_matrix = .false. - assemble_schur_auxiliary_matrix = .false. + pressure_debugging_vtus = have_option(trim(p%option_path)// & + "/prognostic/output/debugging_vtus") + if (pressure_debugging_vtus) then + pdv_count = pdv_count+1 + end if - full_schur = have_option(trim(p%option_path)//& - &"/prognostic/scheme& - &/use_projection_method/full_schur_complement") + get_diag_schur = .false. + get_scaled_pressure_mass_matrix = .false. + assemble_schur_auxiliary_matrix = .false. - ! Are we getting the pressure gradient matrix using control volumes? - cv_pressure = have_option(trim(p%option_path)//& - "/prognostic/spatial_discretisation/control_volumes") + full_schur = have_option(trim(p%option_path)//& + &"/prognostic/scheme& + &/use_projection_method/full_schur_complement") - ! For CG pressure are we testing the continuity with the CV dual - cg_pressure_cv_test_continuity = have_option(trim(p%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin& - &/test_continuity_with_cv_dual") + ! Are we getting the pressure gradient matrix using control volumes? + cv_pressure = have_option(trim(p%option_path)//& + "/prognostic/spatial_discretisation/control_volumes") - end subroutine get_pressure_options + ! For CG pressure are we testing the continuity with the CV dual + cg_pressure_cv_test_continuity = have_option(trim(p%option_path)//& + &"/prognostic/spatial_discretisation/continuous_galerkin& + &/test_continuity_with_cv_dual") + end subroutine get_pressure_options - subroutine solve_poisson_pressure(state, prognostic_p_istate, x, u, p, old_p, & - p_theta, theta_pg, ct_m, ctp_m, & - mom_rhs, ct_rhs, inner_m, inverse_mass, inverse_masslump, & - cmc_m, full_projection_preconditioner, schur_auxiliary_matrix) - !!< Solves a Poisson pressure equation for the pressure guess p^{*} - ! An array of buckets full of fields - type(state_type), dimension(:), intent(inout) :: state + subroutine solve_poisson_pressure(state, prognostic_p_istate, x, u, p, old_p, & + p_theta, theta_pg, ct_m, ctp_m, & + mom_rhs, ct_rhs, inner_m, inverse_mass, inverse_masslump, & + cmc_m, full_projection_preconditioner, schur_auxiliary_matrix) + !!< Solves a Poisson pressure equation for the pressure guess p^{*} - integer, intent(in) :: prognostic_p_istate + ! An array of buckets full of fields + type(state_type), dimension(:), intent(inout) :: state - type(block_csr_matrix), dimension(:), intent(in) :: inverse_mass - type(vector_field), dimension(:), intent(in) :: inverse_masslump + integer, intent(in) :: prognostic_p_istate - type(scalar_field), pointer :: p, p_theta, old_p - type(vector_field), pointer :: x, u + type(block_csr_matrix), dimension(:), intent(in) :: inverse_mass + type(vector_field), dimension(:), intent(in) :: inverse_masslump - type(vector_field), dimension(:), intent(inout) :: mom_rhs - type(scalar_field), dimension(:), intent(inout) :: ct_rhs + type(scalar_field), pointer :: p, p_theta, old_p + type(vector_field), pointer :: x, u - type(csr_matrix), pointer :: cmc_m + type(vector_field), dimension(:), intent(inout) :: mom_rhs + type(scalar_field), dimension(:), intent(inout) :: ct_rhs - ! The pressure gradient matrices (extracted from state) - type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ct_m - ! Compressible pressure gradient operator/left hand matrix of CMC - type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ctp_m + type(csr_matrix), pointer :: cmc_m - ! Pointer to matrix for full projection solve: - type(petsc_csr_matrix_pointer), dimension(:), intent(inout) :: inner_m - ! Pointer to preconditioner matrix for full projection solve: - type(csr_matrix), pointer :: full_projection_preconditioner + ! The pressure gradient matrices (extracted from state) + type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ct_m + ! Compressible pressure gradient operator/left hand matrix of CMC + type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ctp_m - type(csr_matrix), intent(in) :: schur_auxiliary_matrix + ! Pointer to matrix for full projection solve: + type(petsc_csr_matrix_pointer), dimension(:), intent(inout) :: inner_m + ! Pointer to preconditioner matrix for full projection solve: + type(csr_matrix), pointer :: full_projection_preconditioner - type(vector_field), pointer :: positions + type(csr_matrix), intent(in) :: schur_auxiliary_matrix - real, intent(in) :: theta_pg + type(vector_field), pointer :: positions - !! Local variables - type(scalar_field) :: poisson_rhs + real, intent(in) :: theta_pg - ewrite(1,*) 'Entering solve_poisson_pressure' + !! Local variables + type(scalar_field) :: poisson_rhs - call allocate(poisson_rhs, p_theta%mesh, "PoissonRHS") + ewrite(1,*) 'Entering solve_poisson_pressure' - if (full_schur) then - call assemble_poisson_rhs(poisson_rhs, ctp_m(prognostic_p_istate)%ptr, mom_rhs(prognostic_p_istate), ct_rhs(prognostic_p_istate), inner_m(prognostic_p_istate)%ptr, u, dt, theta_pg) + call allocate(poisson_rhs, p_theta%mesh, "PoissonRHS") + + if (full_schur) then + call assemble_poisson_rhs(poisson_rhs, ctp_m(prognostic_p_istate)%ptr, mom_rhs(prognostic_p_istate), ct_rhs(prognostic_p_istate), inner_m(prognostic_p_istate)%ptr, u, dt, theta_pg) + else + ! Get the RHS for the Poisson pressure equation... + if(dg(prognostic_p_istate) .and. .not.lump_mass(prognostic_p_istate)) then + call assemble_poisson_rhs_dg(poisson_rhs, ctp_m(prognostic_p_istate)%ptr, inverse_mass(prognostic_p_istate), mom_rhs(prognostic_p_istate), ct_rhs(prognostic_p_istate), u, dt, theta_pg) else - ! Get the RHS for the Poisson pressure equation... - if(dg(prognostic_p_istate) .and. .not.lump_mass(prognostic_p_istate)) then - call assemble_poisson_rhs_dg(poisson_rhs, ctp_m(prognostic_p_istate)%ptr, inverse_mass(prognostic_p_istate), mom_rhs(prognostic_p_istate), ct_rhs(prognostic_p_istate), u, dt, theta_pg) - else - ! Here we assume that we're using mass lumping if we're not using dg - ! if this isn't true then this leads to inconsistent mass matrices in poisson_rhs and cmc_m - ! but as we're only hoping to get a guesstimate of the pressure hopefully this won't be too - ! bad. - call assemble_masslumped_poisson_rhs(poisson_rhs, ctp_m(prognostic_p_istate)%ptr, mom_rhs(prognostic_p_istate), ct_rhs(prognostic_p_istate), inverse_masslump(prognostic_p_istate), u, dt, theta_pg) - end if + ! Here we assume that we're using mass lumping if we're not using dg + ! if this isn't true then this leads to inconsistent mass matrices in poisson_rhs and cmc_m + ! but as we're only hoping to get a guesstimate of the pressure hopefully this won't be too + ! bad. + call assemble_masslumped_poisson_rhs(poisson_rhs, ctp_m(prognostic_p_istate)%ptr, mom_rhs(prognostic_p_istate), ct_rhs(prognostic_p_istate), inverse_masslump(prognostic_p_istate), u, dt, theta_pg) end if + end if - if (standard_fs .or. implicit_prognostic_fs) then - call add_free_surface_to_poisson_rhs(poisson_rhs, state(prognostic_p_istate), dt, theta_pg) - end if + if (standard_fs .or. implicit_prognostic_fs) then + call add_free_surface_to_poisson_rhs(poisson_rhs, state(prognostic_p_istate), dt, theta_pg) + end if - ! Apply strong dirichlet conditions - call apply_dirichlet_conditions(cmc_m, poisson_rhs, p) + ! Apply strong dirichlet conditions + call apply_dirichlet_conditions(cmc_m, poisson_rhs, p) - positions => extract_vector_field(state(prognostic_p_istate), "Coordinate") - call impose_reference_pressure_node(cmc_m, poisson_rhs, positions, trim(p%option_path)) + positions => extract_vector_field(state(prognostic_p_istate), "Coordinate") + call impose_reference_pressure_node(cmc_m, poisson_rhs, positions, trim(p%option_path)) - call profiler_toc(p, "assembly") ! Don't include Poisson solve - if(full_schur) then - if(assemble_schur_auxiliary_matrix) then - call petsc_solve_full_projection(p_theta, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, poisson_rhs, & - full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh, & - auxiliary_matrix=schur_auxiliary_matrix) - else - call petsc_solve_full_projection(p_theta, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, poisson_rhs, & - full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh) - end if + call profiler_toc(p, "assembly") ! Don't include Poisson solve + if(full_schur) then + if(assemble_schur_auxiliary_matrix) then + call petsc_solve_full_projection(p_theta, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, poisson_rhs, & + full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh, & + auxiliary_matrix=schur_auxiliary_matrix) else - !! Go ahead and solve for the pressure guess p^{*} - call petsc_solve(p_theta, cmc_m, poisson_rhs, state(prognostic_p_istate)) + call petsc_solve_full_projection(p_theta, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, poisson_rhs, & + full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh) end if - call profiler_tic(p, "assembly") - - if (standard_fs .or. implicit_prognostic_fs) then - ! Use this as initial pressure guess, except at the free surface - ! where we use the prescribed initial condition - call copy_poisson_solution_to_interior(state(prognostic_p_istate), & - p_theta, p, old_p, u) - end if - - if (pressure_debugging_vtus) then - if (p_theta%mesh==p%mesh) then - call vtk_write_fields("initial_poisson", pdv_count, x, p%mesh, & - sfields=(/ p_theta, p, old_p /)) - else - ! for the prognostic fs, p_theta is on the extended mesh, so we omit it here - call vtk_write_fields("initial_poisson", pdv_count, x, p%mesh, & - sfields=(/ p, old_p /)) - end if + else + !! Go ahead and solve for the pressure guess p^{*} + call petsc_solve(p_theta, cmc_m, poisson_rhs, state(prognostic_p_istate)) + end if + call profiler_tic(p, "assembly") + + if (standard_fs .or. implicit_prognostic_fs) then + ! Use this as initial pressure guess, except at the free surface + ! where we use the prescribed initial condition + call copy_poisson_solution_to_interior(state(prognostic_p_istate), & + p_theta, p, old_p, u) + end if + + if (pressure_debugging_vtus) then + if (p_theta%mesh==p%mesh) then + call vtk_write_fields("initial_poisson", pdv_count, x, p%mesh, & + sfields=(/ p_theta, p, old_p /)) + else + ! for the prognostic fs, p_theta is on the extended mesh, so we omit it here + call vtk_write_fields("initial_poisson", pdv_count, x, p%mesh, & + sfields=(/ p, old_p /)) end if + end if - ewrite_minmax(p_theta) + ewrite_minmax(p_theta) - call deallocate(poisson_rhs) + call deallocate(poisson_rhs) - end subroutine solve_poisson_pressure + end subroutine solve_poisson_pressure - subroutine advance_velocity(state, istate, x, u, p_theta, big_m, ct_m, mom_rhs, subcycle_m, subcycle_rhs, inverse_mass) - !!< Solve momentum equation using pressure guess and advance velocity from u^{n} to u^{*} + subroutine advance_velocity(state, istate, x, u, p_theta, big_m, ct_m, mom_rhs, subcycle_m, subcycle_rhs, inverse_mass) + !!< Solve momentum equation using pressure guess and advance velocity from u^{n} to u^{*} - ! An array of buckets full of fields - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate + ! An array of buckets full of fields + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate - type(vector_field), pointer :: x, u - type(scalar_field), pointer :: p_theta + type(vector_field), pointer :: x, u + type(scalar_field), pointer :: p_theta - ! Momentum LHS - type(petsc_csr_matrix), dimension(:), target, intent(inout) :: big_m + ! Momentum LHS + type(petsc_csr_matrix), dimension(:), target, intent(inout) :: big_m - type(block_csr_matrix), dimension(:), intent(inout) :: inverse_mass + type(block_csr_matrix), dimension(:), intent(inout) :: inverse_mass - ! The pressure gradient matrix (extracted from state) - type(block_csr_matrix_pointer), dimension(:) :: ct_m + ! The pressure gradient matrix (extracted from state) + type(block_csr_matrix_pointer), dimension(:) :: ct_m - type(vector_field), dimension(:), intent(inout) :: mom_rhs + type(vector_field), dimension(:), intent(inout) :: mom_rhs - ! Matrix and rhs for split explicit advection - type(block_csr_matrix), dimension(:), intent(in) :: subcycle_m - type(vector_field), dimension(:), intent(in) :: subcycle_rhs + ! Matrix and rhs for split explicit advection + type(block_csr_matrix), dimension(:), intent(in) :: subcycle_m + type(vector_field), dimension(:), intent(in) :: subcycle_rhs - !! Local variables - ! Change in velocity - type(vector_field) :: delta_u - type(vector_field), pointer :: positions + !! Local variables + ! Change in velocity + type(vector_field) :: delta_u + type(vector_field), pointer :: positions - ! Fields for the subtract_out_reference_profile option under the Velocity field - type(scalar_field), pointer :: hb_pressure - type(scalar_field) :: combined_p - integer :: stat + ! Fields for the subtract_out_reference_profile option under the Velocity field + type(scalar_field), pointer :: hb_pressure + type(scalar_field) :: combined_p + integer :: stat - ewrite(1,*) 'Entering advance_velocity' + ewrite(1,*) 'Entering advance_velocity' - ! Allocate the momentum solution vector - call profiler_tic(u, "assembly") - call allocate(delta_u, u%dim, u%mesh, "DeltaU") - delta_u%option_path = trim(u%option_path) + ! Allocate the momentum solution vector + call profiler_tic(u, "assembly") + call allocate(delta_u, u%dim, u%mesh, "DeltaU") + delta_u%option_path = trim(u%option_path) - ! Apply advection subcycling - if(subcycle(istate)) then - call subcycle_momentum_dg(u, mom_rhs(istate), subcycle_m(istate), & - subcycle_rhs(istate), inverse_mass(istate), state(istate)) - end if + ! Apply advection subcycling + if(subcycle(istate)) then + call subcycle_momentum_dg(u, mom_rhs(istate), subcycle_m(istate), & + subcycle_rhs(istate), inverse_mass(istate), state(istate)) + end if - if (associated(ct_m(istate)%ptr)) then - ! add - ct_m^T*p to the rhs of the momentum eqn - ! (delta_u is just used as dummy memory here) - ! - ! despite multiplying pressure by a nonlocal operator - ! a halo_update isn't necessary as this is just a rhs - ! contribution - if (have_option('/ocean_forcing/tidal_forcing') .or. & - &have_option('/ocean_forcing/shelf')) then + if (associated(ct_m(istate)%ptr)) then + ! add - ct_m^T*p to the rhs of the momentum eqn + ! (delta_u is just used as dummy memory here) + ! + ! despite multiplying pressure by a nonlocal operator + ! a halo_update isn't necessary as this is just a rhs + ! contribution + if (have_option('/ocean_forcing/tidal_forcing') .or. & + &have_option('/ocean_forcing/shelf')) then ewrite(1,*) "shelf: Entering compute_pressure_and_tidal_gradient" - call compute_pressure_and_tidal_gradient(state(istate), delta_u, ct_m(istate)%ptr, p_theta, x) - else if (have_option(trim(state(istate)%option_path)//'/equation_of_state/compressible/subtract_out_reference_profile')) then - ! Splits up the Density and Pressure fields into a hydrostatic component (') and a perturbed component (''). - ! The hydrostatic components, denoted p' and rho', should satisfy the balance: grad(p') = rho'*g - ! We subtract the hydrostatic component from the pressure used in the pressure gradient term of the momentum equation. - hb_pressure => extract_scalar_field(state(istate), "HydrostaticReferencePressure", stat) - if(stat /= 0) then - FLExit("When using the subtract_out_reference_profile option, please set a (prescribed) HydrostaticReferencePressure field.") - ewrite(-1,*) 'The HydrostaticReferencePressure field, defining the hydrostatic component of the pressure field, needs to be set.' - end if - call allocate(combined_p,p_theta%mesh, "PressurePerturbation") - call set(combined_p, p_theta) - call addto(combined_p, hb_pressure, scale=-1.0) - call mult_T(delta_u, ct_m(istate)%ptr, combined_p) - call deallocate(combined_p) - else - call mult_T(delta_u, ct_m(istate)%ptr, p_theta) - end if - - if (dg(istate)) then - ! We have just poluted the halo rows of delta_u. This is incorrect - ! in the dg case due to the non-local assembly system employed. - call zero_non_owned(delta_u) + call compute_pressure_and_tidal_gradient(state(istate), delta_u, ct_m(istate)%ptr, p_theta, x) + else if (have_option(trim(state(istate)%option_path)//'/equation_of_state/compressible/subtract_out_reference_profile')) then + ! Splits up the Density and Pressure fields into a hydrostatic component (') and a perturbed component (''). + ! The hydrostatic components, denoted p' and rho', should satisfy the balance: grad(p') = rho'*g + ! We subtract the hydrostatic component from the pressure used in the pressure gradient term of the momentum equation. + hb_pressure => extract_scalar_field(state(istate), "HydrostaticReferencePressure", stat) + if(stat /= 0) then + FLExit("When using the subtract_out_reference_profile option, please set a (prescribed) HydrostaticReferencePressure field.") + ewrite(-1,*) 'The HydrostaticReferencePressure field, defining the hydrostatic component of the pressure field, needs to be set.' end if + call allocate(combined_p,p_theta%mesh, "PressurePerturbation") + call set(combined_p, p_theta) + call addto(combined_p, hb_pressure, scale=-1.0) + call mult_T(delta_u, ct_m(istate)%ptr, combined_p) + call deallocate(combined_p) + else + call mult_T(delta_u, ct_m(istate)%ptr, p_theta) + end if - ewrite(2,*) 'note that delta_u = ct_m^T*p at this stage' - ewrite_minmax(delta_u) - call addto(mom_rhs(istate), delta_u) + if (dg(istate)) then + ! We have just poluted the halo rows of delta_u. This is incorrect + ! in the dg case due to the non-local assembly system employed. + call zero_non_owned(delta_u) end if - ! Impose zero guess on change in u - call zero(delta_u) + ewrite(2,*) 'note that delta_u = ct_m^T*p at this stage' + ewrite_minmax(delta_u) + call addto(mom_rhs(istate), delta_u) + end if - ! Impose any reference nodes on velocity - positions => extract_vector_field(state(istate), "Coordinate") - call impose_reference_velocity_node(big_m(istate), mom_rhs(istate), trim(u%option_path), positions) - call apply_dirichlet_conditions(big_m(istate), mom_rhs(istate), u, dt) + ! Impose zero guess on change in u + call zero(delta_u) - call profiler_toc(u, "assembly") + ! Impose any reference nodes on velocity + positions => extract_vector_field(state(istate), "Coordinate") + call impose_reference_velocity_node(big_m(istate), mom_rhs(istate), trim(u%option_path), positions) + call apply_dirichlet_conditions(big_m(istate), mom_rhs(istate), u, dt) - !! Solve for the change in velocity - call petsc_solve(delta_u, big_m(istate), mom_rhs(istate), state(istate)) - ewrite_minmax(delta_u) + call profiler_toc(u, "assembly") - call profiler_tic(u, "assembly") - ! Apply change to velocity field (Note that this gets stored in state) - call addto(u, delta_u, dt) - ewrite_minmax(u) + !! Solve for the change in velocity + call petsc_solve(delta_u, big_m(istate), mom_rhs(istate), state(istate)) + ewrite_minmax(delta_u) - call deallocate(delta_u) - call profiler_toc(u, "assembly") + call profiler_tic(u, "assembly") + ! Apply change to velocity field (Note that this gets stored in state) + call addto(u, delta_u, dt) + ewrite_minmax(u) - end subroutine advance_velocity + call deallocate(delta_u) + call profiler_toc(u, "assembly") + end subroutine advance_velocity - subroutine assemble_projection(state, istate, u, old_u, p, cmc_m, reassemble_cmc_m, cmc_global, ctp_m, & - ct_rhs, projec_rhs, p_theta, theta_pg, theta_divergence) - !!< Assembles the RHS for the projection solve step and, if required, the 'global' CMC matrix for multi-phase simulations. - !!< Note that in the case of multi-phase simulations, projec_rhs contains the sum of ct_m*u over each prognostic velocity field, - !!< and cmc_global contains the sum of the individual phase CMC matrices. - ! An array of buckets full of fields - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate + subroutine assemble_projection(state, istate, u, old_u, p, cmc_m, reassemble_cmc_m, cmc_global, ctp_m, & + ct_rhs, projec_rhs, p_theta, theta_pg, theta_divergence) + !!< Assembles the RHS for the projection solve step and, if required, the 'global' CMC matrix for multi-phase simulations. + !!< Note that in the case of multi-phase simulations, projec_rhs contains the sum of ct_m*u over each prognostic velocity field, + !!< and cmc_global contains the sum of the individual phase CMC matrices. - type(vector_field), pointer :: u, old_u - type(scalar_field), pointer :: p, p_theta + ! An array of buckets full of fields + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate - ! Compressible pressure gradient operator/left hand matrix of CMC - type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ctp_m - ! The pressure projection matrix (extracted from state) - type(csr_matrix), pointer :: cmc_m, cmc_global - logical, intent(in) :: reassemble_cmc_m + type(vector_field), pointer :: u, old_u + type(scalar_field), pointer :: p, p_theta - type(scalar_field), dimension(:), intent(inout) :: ct_rhs - type(scalar_field), intent(inout) :: projec_rhs + ! Compressible pressure gradient operator/left hand matrix of CMC + type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ctp_m + ! The pressure projection matrix (extracted from state) + type(csr_matrix), pointer :: cmc_m, cmc_global + logical, intent(in) :: reassemble_cmc_m - real, intent(in) :: theta_pg - real, intent(in) :: theta_divergence + type(scalar_field), dimension(:), intent(inout) :: ct_rhs + type(scalar_field), intent(inout) :: projec_rhs - ! Local variables - type(scalar_field) :: kmk_rhs, temp_projec_rhs, compress_projec_rhs - type(vector_field) :: delta_u - integer :: stat + real, intent(in) :: theta_pg + real, intent(in) :: theta_divergence - ewrite(1,*) 'Entering assemble_projection' + ! Local variables + type(scalar_field) :: kmk_rhs, temp_projec_rhs, compress_projec_rhs + type(vector_field) :: delta_u + integer :: stat + ewrite(1,*) 'Entering assemble_projection' - call profiler_tic(p, "assembly") - ! Assemble the rhs - ! If we are adding the P1-P1 stabilisation, - ! this will have to have KMK * P added to it; - ! - ! Despite multiplying velocity by a nonlocal operator - ! a halo_update isn't necessary as this is just a rhs - ! contribution - call allocate(temp_projec_rhs, p_theta%mesh, "TempProjectionRHS") - call zero(temp_projec_rhs) - if (.not. use_theta_divergence) then - ! Velocity divergence is evaluated at the end of the time step - call mult(temp_projec_rhs, ctp_m(istate)%ptr, u) - else - ! Evaluate continuity at n+theta_divergence - ! compute theta_divergence*u+(1-theta_divergence)*old_u - call allocate(delta_u, u%dim, u%mesh, "VelocityTheta") - if (have_rotated_bcs(u)) then - if (dg(istate)) then - call zero_non_owned(old_u) - end if - call rotate_velocity(old_u, state(istate)) + call profiler_tic(p, "assembly") + ! Assemble the rhs + ! If we are adding the P1-P1 stabilisation, + ! this will have to have KMK * P added to it; + ! + ! Despite multiplying velocity by a nonlocal operator + ! a halo_update isn't necessary as this is just a rhs + ! contribution + call allocate(temp_projec_rhs, p_theta%mesh, "TempProjectionRHS") + call zero(temp_projec_rhs) + + if (.not. use_theta_divergence) then + ! Velocity divergence is evaluated at the end of the time step + call mult(temp_projec_rhs, ctp_m(istate)%ptr, u) + else + ! Evaluate continuity at n+theta_divergence + ! compute theta_divergence*u+(1-theta_divergence)*old_u + call allocate(delta_u, u%dim, u%mesh, "VelocityTheta") + if (have_rotated_bcs(u)) then + if (dg(istate)) then + call zero_non_owned(old_u) end if - if (sphere_absorption(istate)) then - if (dg(istate)) then - call zero_non_owned(old_u) - end if - call rotate_velocity_sphere(old_u, state(istate)) + call rotate_velocity(old_u, state(istate)) + end if + if (sphere_absorption(istate)) then + if (dg(istate)) then + call zero_non_owned(old_u) end if - call set(delta_u, u, old_u, theta_divergence) - call mult(temp_projec_rhs, ctp_m(istate)%ptr, delta_u) - call deallocate(delta_u) + call rotate_velocity_sphere(old_u, state(istate)) end if + call set(delta_u, u, old_u, theta_divergence) + call mult(temp_projec_rhs, ctp_m(istate)%ptr, delta_u) + call deallocate(delta_u) + end if - ! Allocate the RHS - call allocate(kmk_rhs, p_theta%mesh, "KMKRHS") - call zero(kmk_rhs) + ! Allocate the RHS + call allocate(kmk_rhs, p_theta%mesh, "KMKRHS") + call zero(kmk_rhs) - if (apply_kmk) then - call add_kmk_rhs(state(istate), kmk_rhs, p_theta, dt) - end if - ewrite_minmax(kmk_rhs) + if (apply_kmk) then + call add_kmk_rhs(state(istate), kmk_rhs, p_theta, dt) + end if + ewrite_minmax(kmk_rhs) - call addto(temp_projec_rhs, kmk_rhs) - call scale(temp_projec_rhs, -1.0) - call addto(temp_projec_rhs, ct_rhs(istate)) - ewrite_minmax(temp_projec_rhs) + call addto(temp_projec_rhs, kmk_rhs) + call scale(temp_projec_rhs, -1.0) + call addto(temp_projec_rhs, ct_rhs(istate)) + ewrite_minmax(temp_projec_rhs) - call deallocate(kmk_rhs) + call deallocate(kmk_rhs) - cmc_m => extract_csr_matrix(state(istate), "PressurePoissonMatrix", stat) + cmc_m => extract_csr_matrix(state(istate), "PressurePoissonMatrix", stat) - if((compressible_eos .and. have_option(trim(state(istate)%option_path)//'/equation_of_state/compressible')) & - .or. shallow_water_projection) then - call allocate(compress_projec_rhs, p_theta%mesh, "CompressibleProjectionRHS") + if((compressible_eos .and. have_option(trim(state(istate)%option_path)//'/equation_of_state/compressible')) & + .or. shallow_water_projection) then + call allocate(compress_projec_rhs, p_theta%mesh, "CompressibleProjectionRHS") - if (shallow_water_projection) then - assert(istate==1) - call assemble_shallow_water_projection(state(1), cmc_m, compress_projec_rhs, dt, & - theta_pg, theta_divergence, reassemble_cmc_m) - else if(cv_pressure) then - call assemble_compressible_projection_cv(state, cmc_m, compress_projec_rhs, dt, & - theta_pg, theta_divergence, reassemble_cmc_m) - else - call assemble_compressible_projection_cg(state, istate, cmc_m, compress_projec_rhs, dt, & - theta_pg, theta_divergence, reassemble_cmc_m) - end if + if (shallow_water_projection) then + assert(istate==1) + call assemble_shallow_water_projection(state(1), cmc_m, compress_projec_rhs, dt, & + theta_pg, theta_divergence, reassemble_cmc_m) + else if(cv_pressure) then + call assemble_compressible_projection_cv(state, cmc_m, compress_projec_rhs, dt, & + theta_pg, theta_divergence, reassemble_cmc_m) + else + call assemble_compressible_projection_cg(state, istate, cmc_m, compress_projec_rhs, dt, & + theta_pg, theta_divergence, reassemble_cmc_m) + end if - ewrite_minmax(compress_projec_rhs) - ewrite_minmax(cmc_m) + ewrite_minmax(compress_projec_rhs) + ewrite_minmax(cmc_m) - call addto(temp_projec_rhs, compress_projec_rhs) + call addto(temp_projec_rhs, compress_projec_rhs) - call deallocate(compress_projec_rhs) - end if + call deallocate(compress_projec_rhs) + end if - !! Add individual phase CMC matrix to 'global' CMC matrix - if(multiphase) then - if(.not.associated(cmc_global)) then - ! If not yet allocated, allocate it here using the current CMC's sparsity pattern - ! Assumes the same sparsity throughout (i.e. the same velocity and pressure mesh is used for each velocity field) - allocate(cmc_global) - call allocate(cmc_global, cmc_m%sparsity) - call zero(cmc_global) - end if - call addto(cmc_global, cmc_m) + !! Add individual phase CMC matrix to 'global' CMC matrix + if(multiphase) then + if(.not.associated(cmc_global)) then + ! If not yet allocated, allocate it here using the current CMC's sparsity pattern + ! Assumes the same sparsity throughout (i.e. the same velocity and pressure mesh is used for each velocity field) + allocate(cmc_global) + call allocate(cmc_global, cmc_m%sparsity) + call zero(cmc_global) end if + call addto(cmc_global, cmc_m) + end if - call addto(projec_rhs, temp_projec_rhs) - ewrite_minmax(projec_rhs) + call addto(projec_rhs, temp_projec_rhs) + ewrite_minmax(projec_rhs) - call deallocate(temp_projec_rhs) + call deallocate(temp_projec_rhs) - call profiler_toc(p, "assembly") + call profiler_toc(p, "assembly") - end subroutine assemble_projection + end subroutine assemble_projection - subroutine correct_pressure(state, prognostic_p_istate, x, u, p, old_p, delta_p, & - p_theta, free_surface, theta_pg, theta_divergence, & - cmc_m, ct_m, ctp_m, projec_rhs, inner_m, full_projection_preconditioner, & - schur_auxiliary_matrix, stiff_nodes_list) - !!< Finds the pressure correction term delta_p needed to make the intermediate velocity field (u^{*}) divergence-free + subroutine correct_pressure(state, prognostic_p_istate, x, u, p, old_p, delta_p, & + p_theta, free_surface, theta_pg, theta_divergence, & + cmc_m, ct_m, ctp_m, projec_rhs, inner_m, full_projection_preconditioner, & + schur_auxiliary_matrix, stiff_nodes_list) + !!< Finds the pressure correction term delta_p needed to make the intermediate velocity field (u^{*}) divergence-free - ! An array of buckets full of fields - type(state_type), dimension(:), intent(inout) :: state - type(vector_field), pointer :: x, u - type(scalar_field), pointer :: p, old_p, p_theta, free_surface - type(scalar_field), intent(inout) :: delta_p + ! An array of buckets full of fields + type(state_type), dimension(:), intent(inout) :: state + type(vector_field), pointer :: x, u + type(scalar_field), pointer :: p, old_p, p_theta, free_surface + type(scalar_field), intent(inout) :: delta_p - integer, intent(in) :: prognostic_p_istate + integer, intent(in) :: prognostic_p_istate - real, intent(inout) :: theta_pg - real, intent(inout) :: theta_divergence + real, intent(inout) :: theta_pg + real, intent(inout) :: theta_divergence - ! The pressure projection matrix (extracted from state) - type(csr_matrix), pointer :: cmc_m + ! The pressure projection matrix (extracted from state) + type(csr_matrix), pointer :: cmc_m - ! The pressure gradient matrix (extracted from state) - type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ct_m - ! Compressible pressure gradient operator/left hand matrix of CMC - type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ctp_m + ! The pressure gradient matrix (extracted from state) + type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ct_m + ! Compressible pressure gradient operator/left hand matrix of CMC + type(block_csr_matrix_pointer), dimension(:), intent(inout) :: ctp_m - ! Projection RHS - type(scalar_field), intent(inout) :: projec_rhs + ! Projection RHS + type(scalar_field), intent(inout) :: projec_rhs - ! Pointer to matrix for full projection solve: - type(petsc_csr_matrix_pointer), dimension(:), intent(inout) :: inner_m - ! Pointer to preconditioner matrix for full projection solve: - type(csr_matrix), pointer :: full_projection_preconditioner + ! Pointer to matrix for full projection solve: + type(petsc_csr_matrix_pointer), dimension(:), intent(inout) :: inner_m + ! Pointer to preconditioner matrix for full projection solve: + type(csr_matrix), pointer :: full_projection_preconditioner - type(csr_matrix), intent(in) :: schur_auxiliary_matrix + type(csr_matrix), intent(in) :: schur_auxiliary_matrix - type(ilist), intent(inout) :: stiff_nodes_list + type(ilist), intent(inout) :: stiff_nodes_list - type(vector_field), pointer :: positions + type(vector_field), pointer :: positions - ewrite(1,*) 'Entering correct_pressure' + ewrite(1,*) 'Entering correct_pressure' - ! Apply strong Dirichlet conditions - ! we're solving for "delta_p"=theta_pg*theta_divergence*dp*dt, where dp=p_final-p_current - ! apply_dirichlet_condition however assumes we're solving for - ! "acceleration" dp/dt, by providing dt=1/(dt*theta_pg**2) we get what we want - call apply_dirichlet_conditions(cmc_m, projec_rhs, p, & - dt=1.0/(dt*theta_pg*theta_divergence)) + ! Apply strong Dirichlet conditions + ! we're solving for "delta_p"=theta_pg*theta_divergence*dp*dt, where dp=p_final-p_current + ! apply_dirichlet_condition however assumes we're solving for + ! "acceleration" dp/dt, by providing dt=1/(dt*theta_pg**2) we get what we want + call apply_dirichlet_conditions(cmc_m, projec_rhs, p, & + dt=1.0/(dt*theta_pg*theta_divergence)) - positions => extract_vector_field(state(prognostic_p_istate), "Coordinate") - call impose_reference_pressure_node(cmc_m, projec_rhs, positions, trim(p%option_path)) + positions => extract_vector_field(state(prognostic_p_istate), "Coordinate") + call impose_reference_pressure_node(cmc_m, projec_rhs, positions, trim(p%option_path)) - ! Allocate the change in pressure field - call allocate(delta_p, p_theta%mesh, "DeltaP") - delta_p%option_path = trim(p%option_path) - call zero(delta_p) + ! Allocate the change in pressure field + call allocate(delta_p, p_theta%mesh, "DeltaP") + delta_p%option_path = trim(p%option_path) + call zero(delta_p) - if(have_option(trim(p%option_path)//"/prognostic/repair_stiff_nodes")) then - call zero_stiff_nodes(projec_rhs, stiff_nodes_list) - end if - call profiler_toc(p, "assembly") + if(have_option(trim(p%option_path)//"/prognostic/repair_stiff_nodes")) then + call zero_stiff_nodes(projec_rhs, stiff_nodes_list) + end if + call profiler_toc(p, "assembly") - ! Solve for the change in pressure, delta_p - if(full_schur) then - if(assemble_schur_auxiliary_matrix) then - call petsc_solve_full_projection(delta_p, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, projec_rhs, & - full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh, & - auxiliary_matrix=schur_auxiliary_matrix) - else - call petsc_solve_full_projection(delta_p, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, projec_rhs, & - full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh) - end if + ! Solve for the change in pressure, delta_p + if(full_schur) then + if(assemble_schur_auxiliary_matrix) then + call petsc_solve_full_projection(delta_p, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, projec_rhs, & + full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh, & + auxiliary_matrix=schur_auxiliary_matrix) else - call petsc_solve(delta_p, cmc_m, projec_rhs, state(prognostic_p_istate)) + call petsc_solve_full_projection(delta_p, ctp_m(prognostic_p_istate)%ptr, inner_m(prognostic_p_istate)%ptr, ct_m(prognostic_p_istate)%ptr, projec_rhs, & + full_projection_preconditioner, u, state(prognostic_p_istate), u%mesh) end if - - ewrite_minmax(delta_p) - - if (pressure_debugging_vtus) then - ! Writes out the pressure and velocity before the correction is added in - ! (as the corrected fields are already available in the convergence files) - if (p%mesh==p_theta%mesh) then - call vtk_write_fields("pressure_correction", pdv_count, x, p%mesh, & - sfields=(/ p, old_p, p_theta /)) - ! same thing but now on velocity mesh: - call vtk_write_fields("velocity_before_correction", pdv_count, x, u%mesh, & - sfields=(/ p, old_p, p_theta /), vfields=(/ u /)) - else - ! this is the case for the prognostic fs where p_theta is on an extended mesh - ! we simply omit p_theta - additional output could be implemented - call vtk_write_fields("pressure_correction", pdv_count, x, p%mesh, & - sfields=(/ p, old_p /)) - call vtk_write_fields("velocity_before_correction", pdv_count, x, u%mesh, & - sfields=(/ p, old_p /), vfields=(/ u /)) - end if + else + call petsc_solve(delta_p, cmc_m, projec_rhs, state(prognostic_p_istate)) + end if + + ewrite_minmax(delta_p) + + if (pressure_debugging_vtus) then + ! Writes out the pressure and velocity before the correction is added in + ! (as the corrected fields are already available in the convergence files) + if (p%mesh==p_theta%mesh) then + call vtk_write_fields("pressure_correction", pdv_count, x, p%mesh, & + sfields=(/ p, old_p, p_theta /)) + ! same thing but now on velocity mesh: + call vtk_write_fields("velocity_before_correction", pdv_count, x, u%mesh, & + sfields=(/ p, old_p, p_theta /), vfields=(/ u /)) + else + ! this is the case for the prognostic fs where p_theta is on an extended mesh + ! we simply omit p_theta - additional output could be implemented + call vtk_write_fields("pressure_correction", pdv_count, x, p%mesh, & + sfields=(/ p, old_p /)) + call vtk_write_fields("velocity_before_correction", pdv_count, x, u%mesh, & + sfields=(/ p, old_p /), vfields=(/ u /)) end if - - call profiler_tic(p, "assembly") - if (use_theta_divergence) then - ! We've solved theta_pg*theta_divergence*dt*dp, in the velocity correction - ! however we need theta_pg*dt*dp - call scale(delta_p, 1.0/theta_divergence) + end if + + call profiler_tic(p, "assembly") + if (use_theta_divergence) then + ! We've solved theta_pg*theta_divergence*dt*dp, in the velocity correction + ! however we need theta_pg*dt*dp + call scale(delta_p, 1.0/theta_divergence) + end if + + if (implicit_prognostic_fs) then + call update_pressure_and_viscous_free_surface(state(prognostic_p_istate), p, free_surface, delta_p, theta_pg) + else + ! Add the change in pressure to the pressure + ! (if .not. use_theta_pg then theta_pg is 1.0) + call addto(p, delta_p, scale=1.0/(theta_pg*dt)) + end if + ewrite_minmax(p) + + if(compressible_eos) then + call update_compressible_density(state) + end if + + end subroutine correct_pressure + + subroutine finalise_state(state, istate, u, mass, inverse_mass, inverse_masslump, & + big_m, mom_rhs, ct_rhs, subcycle_m, subcycle_rhs) + !!< Does some finalisation steps to the velocity field and deallocates some memory + !!< allocated for the specified state. + + ! An array of buckets full of fields + type(state_type), dimension(:), intent(inout) :: state + + integer, intent(in) :: istate + type(vector_field), pointer :: u + + ! Mass matrix + type(petsc_csr_matrix), dimension(:), target, intent(inout) :: mass + ! For DG: + type(block_csr_matrix), dimension(:), intent(inout) :: inverse_mass + ! The lumped mass matrix (may vary per component as absorption could be included) + type(vector_field), dimension(:), intent(inout) :: inverse_masslump + + ! Momentum LHS + type(petsc_csr_matrix), dimension(:), target, intent(inout) :: big_m + ! Momentum RHS + type(vector_field), dimension(:), intent(inout) :: mom_rhs + type(scalar_field), dimension(:), intent(inout) :: ct_rhs + ! Matrix and rhs for split explicit advection + type(block_csr_matrix), dimension(:), intent(inout) :: subcycle_m + type(vector_field), dimension(:), intent(inout) :: subcycle_rhs + + integer :: d + type(vector_field), pointer :: x + type(vector_field) :: u_positions + type(scalar_field) :: u_cpt + + ewrite(1,*) 'Entering finalise_state' + + call profiler_tic(u, "assembly") + if (have_rotated_bcs(u)) then + if (dg(istate)) then + call zero_non_owned(u) end if - - if (implicit_prognostic_fs) then - call update_pressure_and_viscous_free_surface(state(prognostic_p_istate), p, free_surface, delta_p, theta_pg) - else - ! Add the change in pressure to the pressure - ! (if .not. use_theta_pg then theta_pg is 1.0) - call addto(p, delta_p, scale=1.0/(theta_pg*dt)) + call rotate_velocity_back(u, state(istate)) + end if + if (sphere_absorption(istate)) then + if (dg(istate)) then + call zero_non_owned(u) end if - ewrite_minmax(p) + call rotate_velocity_back_sphere(u, state(istate)) + end if + if (subcycle(istate)) then + ! Filter wiggles from u + do d = 1, mesh_dim(u) + u_cpt = extract_scalar_field_from_vector_field(u, d) + call limit_vb(state(istate), u_cpt) + end do + end if - if(compressible_eos) then - call update_compressible_density(state) - end if + if (have_option(trim(u%option_path)//"/prognostic/solver/remove_null_space")) then + x => extract_vector_field(state(istate), "Coordinate") + u_positions = get_nodal_coordinate_field(state(istate), u%mesh) + call L2_project_nullspace_vector(u, trim(u%option_path)//"/prognostic/solver/remove_null_space", x, u_positions) + call deallocate(u_positions) + end if - end subroutine correct_pressure + call profiler_toc(u, "assembly") - subroutine finalise_state(state, istate, u, mass, inverse_mass, inverse_masslump, & - big_m, mom_rhs, ct_rhs, subcycle_m, subcycle_rhs) - !!< Does some finalisation steps to the velocity field and deallocates some memory - !!< allocated for the specified state. + if(dg(istate)) then + if(lump_mass(istate)) then + call deallocate(inverse_masslump(istate)) + else + call deallocate(inverse_mass(istate)) + end if + else + call deallocate_cg_mass(mass(istate), inverse_masslump(istate)) + end if - ! An array of buckets full of fields - type(state_type), dimension(:), intent(inout) :: state + call deallocate(mom_rhs(istate)) + call deallocate(ct_rhs(istate)) + call deallocate(big_m(istate)) + if(subcycle(istate)) then + call deallocate(subcycle_m(istate)) + call deallocate(subcycle_rhs(istate)) + end if - integer, intent(in) :: istate - type(vector_field), pointer :: u + end subroutine finalise_state - ! Mass matrix - type(petsc_csr_matrix), dimension(:), target, intent(inout) :: mass - ! For DG: - type(block_csr_matrix), dimension(:), intent(inout) :: inverse_mass - ! The lumped mass matrix (may vary per component as absorption could be included) - type(vector_field), dimension(:), intent(inout) :: inverse_masslump + subroutine momentum_equation_check_options - ! Momentum LHS - type(petsc_csr_matrix), dimension(:), target, intent(inout) :: big_m - ! Momentum RHS - type(vector_field), dimension(:), intent(inout) :: mom_rhs - type(scalar_field), dimension(:), intent(inout) :: ct_rhs - ! Matrix and rhs for split explicit advection - type(block_csr_matrix), dimension(:), intent(inout) :: subcycle_m - type(vector_field), dimension(:), intent(inout) :: subcycle_rhs + integer :: i, nmat + character(len=FIELD_NAME_LEN) :: schur_scheme + character(len=FIELD_NAME_LEN) :: schur_preconditioner + character(len=FIELD_NAME_LEN) :: pressure_mesh + character(len=FIELD_NAME_LEN) :: pressure_mesh_element_type - integer :: d - type(vector_field), pointer :: x - type(vector_field) :: u_positions - type(scalar_field) :: u_cpt + ewrite(1,*) 'Checking momentum discretisation options' - ewrite(1,*) 'Entering finalise_state' + nmat = option_count("/material_phase") - call profiler_tic(u, "assembly") - if (have_rotated_bcs(u)) then - if (dg(istate)) then - call zero_non_owned(u) - end if - call rotate_velocity_back(u, state(istate)) - end if - if (sphere_absorption(istate)) then - if (dg(istate)) then - call zero_non_owned(u) - end if - call rotate_velocity_back_sphere(u, state(istate)) - end if - if (subcycle(istate)) then - ! Filter wiggles from u - do d = 1, mesh_dim(u) - u_cpt = extract_scalar_field_from_vector_field(u, d) - call limit_vb(state(istate), u_cpt) - end do - end if + do i = 0, nmat-1 - if (have_option(trim(u%option_path)//"/prognostic/solver/remove_null_space")) then - x => extract_vector_field(state(istate), "Coordinate") - u_positions = get_nodal_coordinate_field(state(istate), u%mesh) - call L2_project_nullspace_vector(u, trim(u%option_path)//"/prognostic/solver/remove_null_space", x, u_positions) - call deallocate(u_positions) + if(have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/reference_node").and.& + have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/solver/remove_null_space")) then + FLExit("Can't set a pressure reference node and remove the null space.") end if - call profiler_toc(u, "assembly") - - if(dg(istate)) then - if(lump_mass(istate)) then - call deallocate(inverse_masslump(istate)) - else - call deallocate(inverse_mass(istate)) - end if - else - call deallocate_cg_mass(mass(istate), inverse_masslump(istate)) + if(have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin") & + .and. .not. have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin")) then + FLExit("With discontinuous galerkin Pressure you need a continuous Velocity") end if - call deallocate(mom_rhs(istate)) - call deallocate(ct_rhs(istate)) - call deallocate(big_m(istate)) - if(subcycle(istate)) then - call deallocate(subcycle_m(istate)) - call deallocate(subcycle_rhs(istate)) + if(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic/reference_node")) then + if((.not.(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin/mass_terms/exclude_mass_terms").and. & + have_option("/material_phase["//int2str(i)//& + "]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin/advection_terms/exclude_advection_terms"))).and. & + (.not.(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin/mass_terms/exclude_mass_terms").and. & + have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin/advection_scheme/none")))) then + ewrite(-1,*) "Error: You have set a Velocity reference node but don't appear" + ewrite(-1,*) "to be solving the Stokes equation." + ewrite(-1,*) "Setting a reference node for Velocity only makes sense if both" + ewrite(-1,*) "mass and advection terms are excluded from the momentum" + ewrite(-1,*) "equation. Even then whether it is valid depends on your" + ewrite(-1,*) "boundary conditions and whether your velocity components" + ewrite(-1,*) "are coupled but I can't check for that." + FLExit("Don't set a Velocity reference_node unless solving the Stokes equation.") + end if end if - end subroutine finalise_state - - subroutine momentum_equation_check_options - - integer :: i, nmat - character(len=FIELD_NAME_LEN) :: schur_scheme - character(len=FIELD_NAME_LEN) :: schur_preconditioner - character(len=FIELD_NAME_LEN) :: pressure_mesh - character(len=FIELD_NAME_LEN) :: pressure_mesh_element_type - ewrite(1,*) 'Checking momentum discretisation options' + if(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin")& + .and.(.not.have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin"//& + &"/mass_terms/lump_mass_matrix"))) then - nmat = option_count("/material_phase") + if(have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method")) then + if(.not.have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method"//& + &"/full_schur_complement")) then + ewrite(-1,*) "Error: You're not lumping the velocity mass matrix" + ewrite(-1,*) "but haven't selected any schur complement options." + ewrite(-1,*) "Are you sure you don't want to lump the mass?" + ewrite(-1,*) "The consistent mass method is VERY SLOW!" + ewrite(-1,*) "If you really want to use it then its under" + ewrite(-1,*) "the projection scheme options underneath Pressure." + ewrite(-1,*) "Otherwise switch on mass lumping under vector_field::Velocity/" + ewrite(-1,*) "spatial_discretisation/continuous_galerkin/" + ewrite(-1,*) "mass_terms/lump_mass_matrix" + FLExit("Good luck!") + end if + end if - do i = 0, nmat-1 + end if - if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/reference_node").and.& + if(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/isotropic").or. & have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/solver/remove_null_space")) then - FLExit("Can't set a pressure reference node and remove the null space.") - end if + &"]/vector_field::Velocity/prognostic"//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/diagonal")) then if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin") & - .and. .not. have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin")) then - FLExit("With discontinuous galerkin Pressure you need a continuous Velocity") + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin/stress_terms/stress_form").or.& + have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/continuous_galerkin/stress_terms/partial_stress_form")) then + ewrite(-1,*) "You have selected stress form viscosity but have entered an isotropic or" + ewrite(-1,*) "diagonal Viscosity tensor." + ewrite(-1,*) "Zero off diagonal entries in the Viscosity tensor do not make physical" + ewrite(-1,*) "sense when using stress form viscosity." + ewrite(-1,*) "Use tensor_form or anisotropic_symmetric Viscosity instead." + FLExit("Use tensor_form or anisotropic_symmetric Viscosity.") end if - if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic/reference_node")) then - if((.not.(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin/mass_terms/exclude_mass_terms").and. & - have_option("/material_phase["//int2str(i)//& - "]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin/advection_terms/exclude_advection_terms"))).and. & - (.not.(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin/mass_terms/exclude_mass_terms").and. & - have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin/advection_scheme/none")))) then - ewrite(-1,*) "Error: You have set a Velocity reference node but don't appear" - ewrite(-1,*) "to be solving the Stokes equation." - ewrite(-1,*) "Setting a reference node for Velocity only makes sense if both" - ewrite(-1,*) "mass and advection terms are excluded from the momentum" - ewrite(-1,*) "equation. Even then whether it is valid depends on your" - ewrite(-1,*) "boundary conditions and whether your velocity components" - ewrite(-1,*) "are coupled but I can't check for that." - FLExit("Don't set a Velocity reference_node unless solving the Stokes equation.") - end if + end if + + if(have_option("/material_phase["//int2str(i)//"]/vector_field::Velocity/prognostic/"//& + &"spatial_discretisation/continuous_galerkin/temperature_dependent_viscosity")) then + + if(.not.have_option("/material_phase["//int2str(i)//"]/scalar_field::Temperature")) then + FLExit("You must have a temperature field to have a temperature dependent viscosity.") end if + ewrite(-1,*) "Warning - any viscosity values set under tensor_field::Viscosity will be" + ewrite(-1,*) "overwritten by a calculated temperature dependent viscosity. Nonetheless," + ewrite(-1,*) "to ensure that the viscosity tensor is simulated in the correct form, please" + ewrite(-1,*) "select a form under tensor_field::Viscosity. Note that only partial stress and" + ewrite(-1,*) "stress form are valid for a spatially varying viscosity field." if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin")& - .and.(.not.have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin"//& - &"/mass_terms/lump_mass_matrix"))) then + &"]/vector_field::Velocity/prognostic"//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/isotropic").or.& + &have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/diagonal")) then + + ewrite(-1,*) "A spatially varying viscosity (for example a viscosity that depends" + ewrite(-1,*) "upon a spatiall varying temperature field) is only valid with stress" + ewrite(-1,*) "or partial stress form viscosity" + FLExit("For a spatially varying viscosity field, use stress or partial stress form viscosity") + end if - if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method")) then - if(.not.have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method"//& - &"/full_schur_complement")) then - ewrite(-1,*) "Error: You're not lumping the velocity mass matrix" - ewrite(-1,*) "but haven't selected any schur complement options." - ewrite(-1,*) "Are you sure you don't want to lump the mass?" - ewrite(-1,*) "The consistent mass method is VERY SLOW!" - ewrite(-1,*) "If you really want to use it then its under" - ewrite(-1,*) "the projection scheme options underneath Pressure." - ewrite(-1,*) "Otherwise switch on mass lumping under vector_field::Velocity/" - ewrite(-1,*) "spatial_discretisation/continuous_galerkin/" - ewrite(-1,*) "mass_terms/lump_mass_matrix" - FLExit("Good luck!") - end if - end if + end if - end if + if(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/anisotropic_symmetric").or.& + have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/anisotropic_asymmetric")) then if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/isotropic").or. & - have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/diagonal")) then + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method")) then if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin/stress_terms/stress_form").or.& - have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/continuous_galerkin/stress_terms/partial_stress_form")) then - ewrite(-1,*) "You have selected stress form viscosity but have entered an isotropic or" - ewrite(-1,*) "diagonal Viscosity tensor." - ewrite(-1,*) "Zero off diagonal entries in the Viscosity tensor do not make physical" - ewrite(-1,*) "sense when using stress form viscosity." - ewrite(-1,*) "Use tensor_form or anisotropic_symmetric Viscosity instead." - FLExit("Use tensor_form or anisotropic_symmetric Viscosity.") - end if + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method"//& + &"/full_schur_complement")) then - end if + call get_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method"//& + &"/full_schur_complement/preconditioner_matrix[0]/name", schur_preconditioner) - if(have_option("/material_phase["//int2str(i)//"]/vector_field::Velocity/prognostic/"//& - &"spatial_discretisation/continuous_galerkin/temperature_dependent_viscosity")) then + select case(schur_preconditioner) + case("ScaledPressureMassMatrix") + ewrite(-1,*) "WARNING - At present, the viscosity scaling for the pressure mass matrix is" + ewrite(-1,*) "taken from the 1st component of the viscosity tensor. Such a scaling" + ewrite(-1,*) "is only valid when all components of each viscosity tensor are constant." + end select - if(.not.have_option("/material_phase["//int2str(i)//"]/scalar_field::Temperature")) then - FLExit("You must have a temperature field to have a temperature dependent viscosity.") end if - ewrite(-1,*) "Warning - any viscosity values set under tensor_field::Viscosity will be" - ewrite(-1,*) "overwritten by a calculated temperature dependent viscosity. Nonetheless," - ewrite(-1,*) "to ensure that the viscosity tensor is simulated in the correct form, please" - ewrite(-1,*) "select a form under tensor_field::Viscosity. Note that only partial stress and" - ewrite(-1,*) "stress form are valid for a spatially varying viscosity field." + end if - if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/isotropic").or.& - &have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/diagonal")) then - - ewrite(-1,*) "A spatially varying viscosity (for example a viscosity that depends" - ewrite(-1,*) "upon a spatiall varying temperature field) is only valid with stress" - ewrite(-1,*) "or partial stress form viscosity" - FLExit("For a spatially varying viscosity field, use stress or partial stress form viscosity") - end if + end if - end if + if(have_option("/material_phase["//int2str(i)//& + &"]/vector_field::Velocity/prognostic"//& + &"/spatial_discretisation/discontinuous_galerkin")) then if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/anisotropic_symmetric").or.& - have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/anisotropic_asymmetric")) then - + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method")) then if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method")) then - - if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method"//& - &"/full_schur_complement")) then + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method"//& + &"/full_schur_complement")) then - call get_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method"//& - &"/full_schur_complement/preconditioner_matrix[0]/name", schur_preconditioner) - - select case(schur_preconditioner) - case("ScaledPressureMassMatrix") - ewrite(-1,*) "WARNING - At present, the viscosity scaling for the pressure mass matrix is" - ewrite(-1,*) "taken from the 1st component of the viscosity tensor. Such a scaling" - ewrite(-1,*) "is only valid when all components of each viscosity tensor are constant." - end select - - end if + call get_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic"//& + &"/scheme/use_projection_method"//& + &"/full_schur_complement/inner_matrix[0]/name", schur_scheme) + select case(schur_scheme) + case("FullMassMatrix") + FLExit("Can't do a full schur complement solve with dg velocity and a mass inner matrix.") + end select end if - end if - if(have_option("/material_phase["//int2str(i)//& - &"]/vector_field::Velocity/prognostic"//& - &"/spatial_discretisation/discontinuous_galerkin")) then - - if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method")) then - if(have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method"//& - &"/full_schur_complement")) then - - call get_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic"//& - &"/scheme/use_projection_method"//& - &"/full_schur_complement/inner_matrix[0]/name", schur_scheme) - select case(schur_scheme) - case("FullMassMatrix") - FLExit("Can't do a full schur complement solve with dg velocity and a mass inner matrix.") - end select - - end if - end if + end if + ! Check options for case with CG pressure and + ! testing continuity with CV dual mesh. + ! Will not work with compressible, free surface or + ! wetting and drying. Also will not work if the pressure is on a mesh that has + ! bubble or trace shape functions. + if (have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic& + &/spatial_discretisation/continuous_galerkin& + &/test_continuity_with_cv_dual")) then + + ! Check that the incompressible projection is being used + if(.not.have_option("/material_phase["//int2str(i)//& + &"]/scalar_field::Pressure/prognostic& + &/scheme/use_projection_method")) then + + ewrite(-1,*) "Error: For a CG Pressure the continuity" + ewrite(-1,*) "can only be tested with the cv dual mesh" + ewrite(-1,*) "if the pressure scheme is the incompressible" + ewrite(-1,*) "projection method, which is given by the option" + ewrite(-1,*) "path material_phase/Pressure/spatial_discretisation/" + ewrite(-1,*) "continuous_galerkin/scheme/use_projection_method" + FLExit("Use incompressible projection method if wanting to test continuity with cv dual with CG pressure") end if - ! Check options for case with CG pressure and - ! testing continuity with CV dual mesh. - ! Will not work with compressible, free surface or - ! wetting and drying. Also will not work if the pressure is on a mesh that has - ! bubble or trace shape functions. - if (have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic& - &/spatial_discretisation/continuous_galerkin& - &/test_continuity_with_cv_dual")) then - - ! Check that the incompressible projection is being used - if(.not.have_option("/material_phase["//int2str(i)//& - &"]/scalar_field::Pressure/prognostic& - &/scheme/use_projection_method")) then - - ewrite(-1,*) "Error: For a CG Pressure the continuity" - ewrite(-1,*) "can only be tested with the cv dual mesh" - ewrite(-1,*) "if the pressure scheme is the incompressible" - ewrite(-1,*) "projection method, which is given by the option" - ewrite(-1,*) "path material_phase/Pressure/spatial_discretisation/" - ewrite(-1,*) "continuous_galerkin/scheme/use_projection_method" - FLExit("Use incompressible projection method if wanting to test continuity with cv dual with CG pressure") - end if - - ! Check that the wetting_and_drying model is not being used - if(have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then - FLExit("For CG Pressure cannot test the continuity equation with CV when using the wetting and drying model") - end if - - ! get the pressure mesh name - call get_option("/material_phase["//int2str(i)//"]/scalar_field::Pressure/prognostic/mesh/name", & - pressure_mesh) + ! Check that the wetting_and_drying model is not being used + if(have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then + FLExit("For CG Pressure cannot test the continuity equation with CV when using the wetting and drying model") + end if - ! check that the pressure mesh options - ! do NOT say bubble or trace - call get_option("/geometry/mesh::"//trim(pressure_mesh)//"/from_mesh/mesh_shape/element_type", & - pressure_mesh_element_type, & - default = "lagranian") + ! get the pressure mesh name + call get_option("/material_phase["//int2str(i)//"]/scalar_field::Pressure/prognostic/mesh/name", & + pressure_mesh) - if (trim(pressure_mesh_element_type) == "bubble") then - FLExit("For CG Pressure cannot test the continuity equation with CV if the pressure mesh has element type bubble") - end if - - if (trim(pressure_mesh_element_type) == "trace") then - FLExit("For CG Pressure cannot test the continuity equation with CV if the pressure mesh has element type trace") - end if + ! check that the pressure mesh options + ! do NOT say bubble or trace + call get_option("/geometry/mesh::"//trim(pressure_mesh)//"/from_mesh/mesh_shape/element_type", & + pressure_mesh_element_type, & + default = "lagranian") + if (trim(pressure_mesh_element_type) == "bubble") then + FLExit("For CG Pressure cannot test the continuity equation with CV if the pressure mesh has element type bubble") end if - ! Check that each particle phase has a PROGNOSTIC PhaseVolumeFraction field. - ! The fluid phase cannot have a prognostic PhaseVolumeFraction as this is not always valid. - ! For example, since we do not include the Density in the advection-diffusion equation for the PhaseVolumeFraction, - ! solving this equation for the compressible fluid phase would not be correct. The particle phases on the other hand - ! are always incompressible where the density is constant. - if((have_option("/material_phase["//int2str(i)//"]/multiphase_properties/particle_diameter") .or. have_option("/material_phase["//int2str(i)//"]/multiphase_properties/particle_dia_use_scalar_field")) .and. & - .not.(have_option("/material_phase["//int2str(i)//"]/scalar_field::PhaseVolumeFraction/prognostic") .or. & - have_option("/material_phase["//int2str(i)//"]/scalar_field::PhaseVolumeFraction/prescribed"))) then - FLExit("All particle phases must have a prognostic/prescribed PhaseVolumeFraction field. The diagnostic PhaseVolumeFraction field should always be in the continuous/fluid phase.") + if (trim(pressure_mesh_element_type) == "trace") then + FLExit("For CG Pressure cannot test the continuity equation with CV if the pressure mesh has element type trace") end if - end do + end if + + ! Check that each particle phase has a PROGNOSTIC PhaseVolumeFraction field. + ! The fluid phase cannot have a prognostic PhaseVolumeFraction as this is not always valid. + ! For example, since we do not include the Density in the advection-diffusion equation for the PhaseVolumeFraction, + ! solving this equation for the compressible fluid phase would not be correct. The particle phases on the other hand + ! are always incompressible where the density is constant. + if((have_option("/material_phase["//int2str(i)//"]/multiphase_properties/particle_diameter") .or. have_option("/material_phase["//int2str(i)//"]/multiphase_properties/particle_dia_use_scalar_field")) .and. & + .not.(have_option("/material_phase["//int2str(i)//"]/scalar_field::PhaseVolumeFraction/prognostic") .or. & + have_option("/material_phase["//int2str(i)//"]/scalar_field::PhaseVolumeFraction/prescribed"))) then + FLExit("All particle phases must have a prognostic/prescribed PhaseVolumeFraction field. The diagnostic PhaseVolumeFraction field should always be in the continuous/fluid phase.") + end if + + end do - ewrite(1,*) 'Finished checking momentum discretisation options' + ewrite(1,*) 'Finished checking momentum discretisation options' - end subroutine momentum_equation_check_options + end subroutine momentum_equation_check_options - end module momentum_equation +end module momentum_equation diff --git a/assemble/Multimaterials.F90 b/assemble/Multimaterials.F90 index d22a11fe9e..30a9eed5ae 100644 --- a/assemble/Multimaterials.F90 +++ b/assemble/Multimaterials.F90 @@ -27,807 +27,807 @@ #include "fdebug.h" module multimaterial_module - !! This module contains the options and material properties used - !! when running a multimaterial simulation. - use fldebug - use spud - use global_parameters, only: OPTION_PATH_LEN - use futils, only: present_and_true - use fields - use state_module - use field_options - use fefields, only: compute_cv_mass - use field_priority_lists - use cv_upwind_values - use equation_of_state, only: compressible_material_eos - use diagnostic_fields_matrices - - implicit none - - interface calculate_bulk_property - module procedure calculate_bulk_scalar_property, calculate_bulk_vector_property, calculate_bulk_tensor_property - end interface - - interface add_scaled_material_property - module procedure add_scaled_material_property_scalar, add_scaled_material_property_vector, add_scaled_material_property_tensor - end interface - - private - public :: initialise_diagnostic_material_properties, & - calculate_material_mass, calculate_bulk_material_pressure, & - calculate_sum_material_volume_fractions, calculate_material_volume, & - calculate_bulk_property, add_scaled_material_property, calculate_surfacetension, & - calculate_diagnostic_material_volume_fraction, order_states_priority + !! This module contains the options and material properties used + !! when running a multimaterial simulation. + use fldebug + use spud + use global_parameters, only: OPTION_PATH_LEN + use futils, only: present_and_true + use fields + use state_module + use field_options + use fefields, only: compute_cv_mass + use field_priority_lists + use cv_upwind_values + use equation_of_state, only: compressible_material_eos + use diagnostic_fields_matrices + + implicit none + + interface calculate_bulk_property + module procedure calculate_bulk_scalar_property, calculate_bulk_vector_property, calculate_bulk_tensor_property + end interface + + interface add_scaled_material_property + module procedure add_scaled_material_property_scalar, add_scaled_material_property_vector, add_scaled_material_property_tensor + end interface + + private + public :: initialise_diagnostic_material_properties, & + calculate_material_mass, calculate_bulk_material_pressure, & + calculate_sum_material_volume_fractions, calculate_material_volume, & + calculate_bulk_property, add_scaled_material_property, calculate_surfacetension, & + calculate_diagnostic_material_volume_fraction, order_states_priority contains - subroutine calculate_surfacetension(state, surfacetension) - ! calculates the surface tension in tensor form - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(inout) :: surfacetension - - type(scalar_field), pointer :: volumefraction - integer :: i, node, dimi, dimj, stat - logical :: prognostic - type(scalar_field) :: grad_mag, grad_mag2 - type(vector_field) :: gradient - - type(vector_field) :: normals - logical, dimension(:), allocatable :: on_boundary - type(vector_field), pointer :: x - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: surface_ids - - real :: coeff, eq_angle - real, dimension(surfacetension%dim(1), surfacetension%dim(2)) :: tensor - - if(size(state)==1) then - FLExit("Don't know how to calculate a surface tension with only one material_phase.") - end if - - x => extract_vector_field(state(1), "Coordinate") - - call allocate(gradient, surfacetension%dim(1), surfacetension%mesh, "Gradient") - gradient%option_path = surfacetension%option_path - - call zero(surfacetension) - - do i = 1, size(state) - volumefraction => extract_scalar_field(state(i), "MaterialVolumeFraction") - - prognostic = have_option(trim(volumefraction%option_path)//"/prognostic") - - if(prognostic.and.(.not.aliased(volumefraction))) then - call get_option(trim(volumefraction%option_path)//& - "/prognostic/surface_tension/surface_tension_coefficient", & - coeff, default=0.0) - - call zero(gradient) - - call calculate_div_t_cv(state(i), gradient) - - ! the magnitude of the field gradient is a regularisation of the delta function - ! indicating where the interface is - grad_mag = magnitude(gradient) - - ! normalise the gradient - do node = 1, node_count(surfacetension) - if(node_val(grad_mag, node)>epsilon(0.0)) then - call set(gradient, node, node_val(gradient, node)/node_val(grad_mag, node)) - else - call set(gradient, node, spread(0.0, 1, gradient%dim)) - call set(grad_mag, node, 0.0) - end if - end do - - ! if we have an equilibrium contact angle then modify the gradient near the requested walls - ! (note that grad_mag is unchanged) - call get_option(trim(volumefraction%option_path)//& - "/prognostic/surface_tension/equilibrium_contact_angle", eq_angle, stat) - if(stat==0) then - call allocate(normals, mesh_dim(surfacetension), surfacetension%mesh, "NormalsToBoundary") - call zero(normals) - - allocate(on_boundary(node_count(surfacetension))) - on_boundary = .false. - - shape_option=option_shape(trim(volumefraction%option_path) // & - & "/prognostic/surface_tension/equilibrium_contact_angle/surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option(trim(volumefraction%option_path)//& - &"/prognostic/surface_tension/equilibrium_contact_angle/surface_ids", surface_ids) - - call calculate_boundary_normals(surfacetension%mesh, x, & - normals, on_boundary, & - surface_ids = surface_ids) - - do node = 1, node_count(surfacetension) - if(on_boundary(node)) then - call set(gradient, node, & - (node_val(normals, node)*cos(eq_angle)+node_val(gradient, node)*sin(eq_angle))) - end if - end do + subroutine calculate_surfacetension(state, surfacetension) + ! calculates the surface tension in tensor form + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(inout) :: surfacetension - grad_mag2 = magnitude(gradient) + type(scalar_field), pointer :: volumefraction + integer :: i, node, dimi, dimj, stat + logical :: prognostic + type(scalar_field) :: grad_mag, grad_mag2 + type(vector_field) :: gradient - ! renormalise the gradient - do node = 1, node_count(surfacetension) - if(node_val(grad_mag2, node)>epsilon(0.0)) then - call set(gradient, node, node_val(gradient, node)/node_val(grad_mag2, node)) - else - call set(gradient, node, spread(0.0, 1, gradient%dim)) - end if - end do + type(vector_field) :: normals + logical, dimension(:), allocatable :: on_boundary + type(vector_field), pointer :: x + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: surface_ids - call deallocate(grad_mag2) + real :: coeff, eq_angle + real, dimension(surfacetension%dim(1), surfacetension%dim(2)) :: tensor - deallocate(on_boundary) - call deallocate(normals) - deallocate(surface_ids) + if(size(state)==1) then + FLExit("Don't know how to calculate a surface tension with only one material_phase.") + end if - end if + x => extract_vector_field(state(1), "Coordinate") - do node = 1, node_count(surfacetension) - tensor = 0.0 - do dimi = 1, size(tensor,1) - do dimj = 1, size(tensor,2) - if(dimi==dimj) tensor(dimi,dimj) = coeff*node_val(grad_mag, node) - tensor(dimi,dimj) = tensor(dimi,dimj) - & - coeff*node_val(gradient, dimi, node)*node_val(gradient, dimj, node)*& - node_val(grad_mag, node) - end do - end do + call allocate(gradient, surfacetension%dim(1), surfacetension%mesh, "Gradient") + gradient%option_path = surfacetension%option_path - call addto(surfacetension, node, tensor) + call zero(surfacetension) - end do + do i = 1, size(state) + volumefraction => extract_scalar_field(state(i), "MaterialVolumeFraction") - call deallocate(grad_mag) + prognostic = have_option(trim(volumefraction%option_path)//"/prognostic") - end if + if(prognostic.and.(.not.aliased(volumefraction))) then + call get_option(trim(volumefraction%option_path)//& + "/prognostic/surface_tension/surface_tension_coefficient", & + coeff, default=0.0) - end do + call zero(gradient) - call deallocate(gradient) + call calculate_div_t_cv(state(i), gradient) - end subroutine calculate_surfacetension + ! the magnitude of the field gradient is a regularisation of the delta function + ! indicating where the interface is + grad_mag = magnitude(gradient) - subroutine initialise_diagnostic_material_properties(state) + ! normalise the gradient + do node = 1, node_count(surfacetension) + if(node_val(grad_mag, node)>epsilon(0.0)) then + call set(gradient, node, node_val(gradient, node)/node_val(grad_mag, node)) + else + call set(gradient, node, spread(0.0, 1, gradient%dim)) + call set(grad_mag, node, 0.0) + end if + end do - type(state_type), dimension(:), intent(inout) :: state + ! if we have an equilibrium contact angle then modify the gradient near the requested walls + ! (note that grad_mag is unchanged) + call get_option(trim(volumefraction%option_path)//& + "/prognostic/surface_tension/equilibrium_contact_angle", eq_angle, stat) + if(stat==0) then + call allocate(normals, mesh_dim(surfacetension), surfacetension%mesh, "NormalsToBoundary") + call zero(normals) + + allocate(on_boundary(node_count(surfacetension))) + on_boundary = .false. + + shape_option=option_shape(trim(volumefraction%option_path) // & + & "/prognostic/surface_tension/equilibrium_contact_angle/surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option(trim(volumefraction%option_path)//& + &"/prognostic/surface_tension/equilibrium_contact_angle/surface_ids", surface_ids) + + call calculate_boundary_normals(surfacetension%mesh, x, & + normals, on_boundary, & + surface_ids = surface_ids) + + do node = 1, node_count(surfacetension) + if(on_boundary(node)) then + call set(gradient, node, & + (node_val(normals, node)*cos(eq_angle)+node_val(gradient, node)*sin(eq_angle))) + end if + end do + + grad_mag2 = magnitude(gradient) + + ! renormalise the gradient + do node = 1, node_count(surfacetension) + if(node_val(grad_mag2, node)>epsilon(0.0)) then + call set(gradient, node, node_val(gradient, node)/node_val(grad_mag2, node)) + else + call set(gradient, node, spread(0.0, 1, gradient%dim)) + end if + end do + + call deallocate(grad_mag2) + + deallocate(on_boundary) + call deallocate(normals) + deallocate(surface_ids) - !locals - integer :: stat, i - type(scalar_field), pointer :: sfield - logical :: prognostic + end if - do i = 1, size(state) + do node = 1, node_count(surfacetension) + tensor = 0.0 + do dimi = 1, size(tensor,1) + do dimj = 1, size(tensor,2) + if(dimi==dimj) tensor(dimi,dimj) = coeff*node_val(grad_mag, node) + tensor(dimi,dimj) = tensor(dimi,dimj) - & + coeff*node_val(gradient, dimi, node)*node_val(gradient, dimj, node)*& + node_val(grad_mag, node) + end do + end do - sfield=>extract_scalar_field(state(i),'MaterialDensity',stat) - if(stat==0) then - prognostic=(have_option(trim(sfield%option_path)//'/prognostic')) - if((.not.aliased(sfield)).and. prognostic) then - call compressible_material_eos(state(i),materialdensity=sfield) - end if - end if + call addto(surfacetension, node, tensor) - end do + end do - end subroutine initialise_diagnostic_material_properties + call deallocate(grad_mag) - subroutine calculate_diagnostic_material_volume_fraction(state) + end if - type(state_type), dimension(:), intent(inout) :: state + end do - !locals - type(scalar_field), pointer :: materialvolumefraction - integer :: i, stat, diagnostic_count, diagnostic_state_index - type(scalar_field) :: sumvolumefractions - type(scalar_field), pointer :: sfield - logical :: diagnostic + call deallocate(gradient) - ! How many diagnostic internal MaterialVolumeFraction fields do we have in state? - ! Note that state contains all the submaterials of the current phase, including the phase itself. - ! Therefore, if the only material is the phase itself, diagnostic_count should be 0. Otherwise, - ! it should be 1. - diagnostic_count = 0 - do i = 1, size(state) - if(have_option(trim(state(i)%option_path)//"/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::Internal")) then - diagnostic_count = diagnostic_count + 1 - ! Record the index of the state containing the diagnostic MaterialVolumeFraction field - diagnostic_state_index = i - end if - end do + end subroutine calculate_surfacetension - if(diagnostic_count>1) then - ewrite(0,*) diagnostic_count, ' diagnostic MaterialVolumeFractions' - FLExit("Only one internal diagnostic MaterialVolumeFraction permitted.") - end if + subroutine initialise_diagnostic_material_properties(state) - if(diagnostic_count==1) then - ! Extract the diagnostic volume fraction - materialvolumefraction => extract_scalar_field(state(diagnostic_state_index), 'MaterialVolumeFraction') + type(state_type), dimension(:), intent(inout) :: state - call allocate(sumvolumefractions, materialvolumefraction%mesh, 'Sum of volume fractions') - call zero(sumvolumefractions) + !locals + integer :: stat, i + type(scalar_field), pointer :: sfield + logical :: prognostic - do i = 1,size(state) - sfield=>extract_scalar_field(state(i),'MaterialVolumeFraction',stat) - if (stat==0) then - diagnostic=(have_option(trim(sfield%option_path)//'/diagnostic/algorithm::Internal')) - if (.not. aliased(sfield) .and. .not. diagnostic) then - call addto(sumvolumefractions, sfield) - end if - end if - end do + do i = 1, size(state) - call set(materialvolumefraction, 1.0) - call addto(materialvolumefraction, sumvolumefractions, -1.0) - call deallocate(sumvolumefractions) - end if + sfield=>extract_scalar_field(state(i),'MaterialDensity',stat) + if(stat==0) then + prognostic=(have_option(trim(sfield%option_path)//'/prognostic')) + if((.not.aliased(sfield)).and. prognostic) then + call compressible_material_eos(state(i),materialdensity=sfield) + end if + end if - end subroutine calculate_diagnostic_material_volume_fraction + end do - subroutine order_states_priority(state, state_order) - type(state_type), dimension(:), intent(inout) :: state - integer, dimension(:), intent(inout) :: state_order + end subroutine initialise_diagnostic_material_properties + + subroutine calculate_diagnostic_material_volume_fraction(state) + + type(state_type), dimension(:), intent(inout) :: state + + !locals + type(scalar_field), pointer :: materialvolumefraction + integer :: i, stat, diagnostic_count, diagnostic_state_index + type(scalar_field) :: sumvolumefractions + type(scalar_field), pointer :: sfield + logical :: diagnostic + + ! How many diagnostic internal MaterialVolumeFraction fields do we have in state? + ! Note that state contains all the submaterials of the current phase, including the phase itself. + ! Therefore, if the only material is the phase itself, diagnostic_count should be 0. Otherwise, + ! it should be 1. + diagnostic_count = 0 + do i = 1, size(state) + if(have_option(trim(state(i)%option_path)//"/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::Internal")) then + diagnostic_count = diagnostic_count + 1 + ! Record the index of the state containing the diagnostic MaterialVolumeFraction field + diagnostic_state_index = i + end if + end do - type(scalar_field), pointer :: volumefraction - logical, dimension(size(state)) :: priority_states - integer, dimension(size(state)) :: state_priorities + if(diagnostic_count>1) then + ewrite(0,*) diagnostic_count, ' diagnostic MaterialVolumeFractions' + FLExit("Only one internal diagnostic MaterialVolumeFraction permitted.") + end if - integer :: i, p, f + if(diagnostic_count==1) then + ! Extract the diagnostic volume fraction + materialvolumefraction => extract_scalar_field(state(diagnostic_state_index), 'MaterialVolumeFraction') - assert(size(state_order)==size(state)) + call allocate(sumvolumefractions, materialvolumefraction%mesh, 'Sum of volume fractions') + call zero(sumvolumefractions) - priority_states = .false. - state_priorities = 0 - do i = 1, size(state) - volumefraction=>extract_scalar_field(state(i), "MaterialVolumeFraction") + do i = 1,size(state) + sfield=>extract_scalar_field(state(i),'MaterialVolumeFraction',stat) + if (stat==0) then + diagnostic=(have_option(trim(sfield%option_path)//'/diagnostic/algorithm::Internal')) + if (.not. aliased(sfield) .and. .not. diagnostic) then + call addto(sumvolumefractions, sfield) + end if + end if + end do - if(have_option(trim(volumefraction%option_path)//"/prognostic/priority")) then - call get_option(trim(volumefraction%option_path)//"/prognostic/priority", state_priorities(i)) - priority_states(i) = .true. + call set(materialvolumefraction, 1.0) + call addto(materialvolumefraction, sumvolumefractions, -1.0) + call deallocate(sumvolumefractions) end if - end do - do i = 1, size(state) - if(.not.priority_states(i)) then - state_priorities(i) = minval(state_priorities)-1 - end if - end do - - ! now work out the right order - f = 0 - state_order = 0 - do p = maxval(state_priorities), minval(state_priorities), -1 - do i=1, size(state) - if(state_priorities(i)==p) then - f = f + 1 - state_order(f) = i - end if - end do - end do - assert(all(state_order>0)) + end subroutine calculate_diagnostic_material_volume_fraction - end subroutine order_states_priority + subroutine order_states_priority(state, state_order) + type(state_type), dimension(:), intent(inout) :: state + integer, dimension(:), intent(inout) :: state_order - subroutine calculate_bulk_scalar_property(state,bulkfield,materialname,mean_type,momentum_diagnostic) + type(scalar_field), pointer :: volumefraction + logical, dimension(size(state)) :: priority_states + integer, dimension(size(state)) :: state_priorities - type(state_type), dimension(:), intent(inout) :: state - type(scalar_field), intent(inout) :: bulkfield - character(len=*), intent(in) :: materialname - character(len=*), intent(in), optional :: mean_type - logical, intent(in), optional ::momentum_diagnostic + integer :: i, p, f - !locals - integer :: i, stat - character(len=OPTION_PATH_LEN) :: l_mean_type - type(scalar_field), pointer :: sfield + assert(size(state_order)==size(state)) - integer, dimension(size(state)) :: state_order - type(scalar_field) :: sumvolumefractionsbound + priority_states = .false. + state_priorities = 0 + do i = 1, size(state) + volumefraction=>extract_scalar_field(state(i), "MaterialVolumeFraction") - ewrite(1,*) 'In calculate_bulk_scalar_property:', trim(bulkfield%name) + if(have_option(trim(volumefraction%option_path)//"/prognostic/priority")) then + call get_option(trim(volumefraction%option_path)//"/prognostic/priority", state_priorities(i)) + priority_states(i) = .true. + end if + end do - if (present(mean_type)) then - l_mean_type = mean_type - else - l_mean_type = "arithmetic" - end if + do i = 1, size(state) + if(.not.priority_states(i)) then + state_priorities(i) = minval(state_priorities)-1 + end if + end do - select case(l_mean_type) - case("arithmetic") - call zero(bulkfield) - case("harmonic") - call zero(bulkfield) - case("geometric") - call set(bulkfield, 1.0) - case default - FLExit("Invalid mean_type in calculate_bulk_property") - end select + ! now work out the right order + f = 0 + state_order = 0 + do p = maxval(state_priorities), minval(state_priorities), -1 + do i=1, size(state) + if(state_priorities(i)==p) then + f = f + 1 + state_order(f) = i + end if + end do + end do + assert(all(state_order>0)) - call order_states_priority(state, state_order) + end subroutine order_states_priority - call allocate(sumvolumefractionsbound, bulkfield%mesh, "SumMaterialVolumeFractionsBound") - call set(sumvolumefractionsbound, 1.0) + subroutine calculate_bulk_scalar_property(state,bulkfield,materialname,mean_type,momentum_diagnostic) - do i = 1, size(state) + type(state_type), dimension(:), intent(inout) :: state + type(scalar_field), intent(inout) :: bulkfield + character(len=*), intent(in) :: materialname + character(len=*), intent(in), optional :: mean_type + logical, intent(in), optional ::momentum_diagnostic - ewrite(2,*) 'Considering state: ', state(state_order(i))%name - sfield => extract_scalar_field(state(state_order(i)), trim(materialname), stat) - if(stat==0) then - call add_scaled_material_property(state(state_order(i)), bulkfield, sfield, & - sumvolumefractionsbound=sumvolumefractionsbound, & - mean_type=l_mean_type, momentum_diagnostic=momentum_diagnostic) + !locals + integer :: i, stat + character(len=OPTION_PATH_LEN) :: l_mean_type + type(scalar_field), pointer :: sfield + + integer, dimension(size(state)) :: state_order + type(scalar_field) :: sumvolumefractionsbound + + ewrite(1,*) 'In calculate_bulk_scalar_property:', trim(bulkfield%name) + + if (present(mean_type)) then + l_mean_type = mean_type + else + l_mean_type = "arithmetic" end if - end do + select case(l_mean_type) + case("arithmetic") + call zero(bulkfield) + case("harmonic") + call zero(bulkfield) + case("geometric") + call set(bulkfield, 1.0) + case default + FLExit("Invalid mean_type in calculate_bulk_property") + end select - select case(l_mean_type) - case("harmonic") - call invert(bulkfield, tolerance=tiny(0.0)) - end select + call order_states_priority(state, state_order) - call deallocate(sumvolumefractionsbound) + call allocate(sumvolumefractionsbound, bulkfield%mesh, "SumMaterialVolumeFractionsBound") + call set(sumvolumefractionsbound, 1.0) - end subroutine calculate_bulk_scalar_property + do i = 1, size(state) - subroutine calculate_bulk_vector_property(state,bulkfield,materialname,mean_type,momentum_diagnostic) + ewrite(2,*) 'Considering state: ', state(state_order(i))%name + sfield => extract_scalar_field(state(state_order(i)), trim(materialname), stat) + if(stat==0) then + call add_scaled_material_property(state(state_order(i)), bulkfield, sfield, & + sumvolumefractionsbound=sumvolumefractionsbound, & + mean_type=l_mean_type, momentum_diagnostic=momentum_diagnostic) + end if - type(state_type), dimension(:), intent(inout) :: state - type(vector_field), intent(inout) :: bulkfield - character(len=*), intent(in) :: materialname - character(len=*), intent(in), optional :: mean_type - logical, intent(in), optional :: momentum_diagnostic + end do - !locals - integer :: i, stat - character(len=OPTION_PATH_LEN) :: l_mean_type - type(vector_field), pointer :: vfield + select case(l_mean_type) + case("harmonic") + call invert(bulkfield, tolerance=tiny(0.0)) + end select - integer, dimension(size(state)) :: state_order - type(scalar_field) :: sumvolumefractionsbound + call deallocate(sumvolumefractionsbound) - ewrite(1,*) 'In calculate_bulk_vector_property:', trim(bulkfield%name) + end subroutine calculate_bulk_scalar_property - if (present(mean_type)) then - l_mean_type = mean_type - else - l_mean_type = "arithmetic" - end if + subroutine calculate_bulk_vector_property(state,bulkfield,materialname,mean_type,momentum_diagnostic) - select case(l_mean_type) - case("arithmetic") - call zero(bulkfield) - case("harmonic") - call zero(bulkfield) - case("geometric") - do i = 1, bulkfield%dim - call set(bulkfield, i, 1.0) - end do - case default - FLExit("Invalid mean_type in calculate_bulk_property") - end select + type(state_type), dimension(:), intent(inout) :: state + type(vector_field), intent(inout) :: bulkfield + character(len=*), intent(in) :: materialname + character(len=*), intent(in), optional :: mean_type + logical, intent(in), optional :: momentum_diagnostic - call order_states_priority(state, state_order) + !locals + integer :: i, stat + character(len=OPTION_PATH_LEN) :: l_mean_type + type(vector_field), pointer :: vfield - call allocate(sumvolumefractionsbound, bulkfield%mesh, "SumMaterialVolumeFractionsBound") - call set(sumvolumefractionsbound, 1.0) + integer, dimension(size(state)) :: state_order + type(scalar_field) :: sumvolumefractionsbound - do i = 1, size(state) + ewrite(1,*) 'In calculate_bulk_vector_property:', trim(bulkfield%name) - ewrite(2,*) 'Considering state: ', state(state_order(i))%name - vfield => extract_vector_field(state(state_order(i)), trim(materialname), stat) - if(stat==0) then - call add_scaled_material_property(state(state_order(i)), bulkfield, vfield, & - sumvolumefractionsbound=sumvolumefractionsbound, & - mean_type=l_mean_type, momentum_diagnostic=momentum_diagnostic) + if (present(mean_type)) then + l_mean_type = mean_type + else + l_mean_type = "arithmetic" end if - end do + select case(l_mean_type) + case("arithmetic") + call zero(bulkfield) + case("harmonic") + call zero(bulkfield) + case("geometric") + do i = 1, bulkfield%dim + call set(bulkfield, i, 1.0) + end do + case default + FLExit("Invalid mean_type in calculate_bulk_property") + end select + + call order_states_priority(state, state_order) + + call allocate(sumvolumefractionsbound, bulkfield%mesh, "SumMaterialVolumeFractionsBound") + call set(sumvolumefractionsbound, 1.0) + + do i = 1, size(state) + + ewrite(2,*) 'Considering state: ', state(state_order(i))%name + vfield => extract_vector_field(state(state_order(i)), trim(materialname), stat) + if(stat==0) then + call add_scaled_material_property(state(state_order(i)), bulkfield, vfield, & + sumvolumefractionsbound=sumvolumefractionsbound, & + mean_type=l_mean_type, momentum_diagnostic=momentum_diagnostic) + end if - select case(l_mean_type) - case("harmonic") - call invert(bulkfield, tolerance=tiny(0.0)) - end select + end do - call deallocate(sumvolumefractionsbound) + select case(l_mean_type) + case("harmonic") + call invert(bulkfield, tolerance=tiny(0.0)) + end select - end subroutine calculate_bulk_vector_property + call deallocate(sumvolumefractionsbound) - subroutine calculate_bulk_tensor_property(state,bulkfield,materialname,mean_type,momentum_diagnostic) + end subroutine calculate_bulk_vector_property - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(inout) :: bulkfield - character(len=*), intent(in) :: materialname - character(len=*), intent(in), optional :: mean_type - logical, intent(in), optional :: momentum_diagnostic + subroutine calculate_bulk_tensor_property(state,bulkfield,materialname,mean_type,momentum_diagnostic) - !locals - integer :: i, j, stat - character(len=OPTION_PATH_LEN) :: l_mean_type - type(tensor_field), pointer :: tfield + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(inout) :: bulkfield + character(len=*), intent(in) :: materialname + character(len=*), intent(in), optional :: mean_type + logical, intent(in), optional :: momentum_diagnostic - integer, dimension(size(state)) :: state_order - type(scalar_field) :: sumvolumefractionsbound + !locals + integer :: i, j, stat + character(len=OPTION_PATH_LEN) :: l_mean_type + type(tensor_field), pointer :: tfield - ewrite(1,*) 'In calculate_bulk_tensor_property:', trim(bulkfield%name) + integer, dimension(size(state)) :: state_order + type(scalar_field) :: sumvolumefractionsbound - if (present(mean_type)) then - l_mean_type = mean_type - else - l_mean_type = "arithmetic" - end if + ewrite(1,*) 'In calculate_bulk_tensor_property:', trim(bulkfield%name) - select case(l_mean_type) - case("arithmetic") - call zero(bulkfield) - case("harmonic") - call zero(bulkfield) - case("geometric") - do i = 1, bulkfield%dim(1) - do j = 1, bulkfield%dim(2) - call set(bulkfield, i, j, 1.0) - end do - end do - case default - FLExit("Invalid mean_type in calculate_bulk_property") - end select + if (present(mean_type)) then + l_mean_type = mean_type + else + l_mean_type = "arithmetic" + end if - call order_states_priority(state, state_order) + select case(l_mean_type) + case("arithmetic") + call zero(bulkfield) + case("harmonic") + call zero(bulkfield) + case("geometric") + do i = 1, bulkfield%dim(1) + do j = 1, bulkfield%dim(2) + call set(bulkfield, i, j, 1.0) + end do + end do + case default + FLExit("Invalid mean_type in calculate_bulk_property") + end select - call allocate(sumvolumefractionsbound, bulkfield%mesh, "SumMaterialVolumeFractionsBound") - call set(sumvolumefractionsbound, 1.0) + call order_states_priority(state, state_order) - do i = 1, size(state) + call allocate(sumvolumefractionsbound, bulkfield%mesh, "SumMaterialVolumeFractionsBound") + call set(sumvolumefractionsbound, 1.0) - ewrite(2,*) 'Considering state: ', state(state_order(i))%name - tfield => extract_tensor_field(state(state_order(i)), trim(materialname), stat) - if(stat==0) then - call add_scaled_material_property(state(state_order(i)), bulkfield, tfield, & - sumvolumefractionsbound=sumvolumefractionsbound, & - mean_type=l_mean_type, momentum_diagnostic=momentum_diagnostic) - end if + do i = 1, size(state) + + ewrite(2,*) 'Considering state: ', state(state_order(i))%name + tfield => extract_tensor_field(state(state_order(i)), trim(materialname), stat) + if(stat==0) then + call add_scaled_material_property(state(state_order(i)), bulkfield, tfield, & + sumvolumefractionsbound=sumvolumefractionsbound, & + mean_type=l_mean_type, momentum_diagnostic=momentum_diagnostic) + end if - end do + end do - select case(l_mean_type) - case("harmonic") - call invert(bulkfield, tolerance=tiny(0.0)) - end select + select case(l_mean_type) + case("harmonic") + call invert(bulkfield, tolerance=tiny(0.0)) + end select - call deallocate(sumvolumefractionsbound) + call deallocate(sumvolumefractionsbound) - end subroutine calculate_bulk_tensor_property + end subroutine calculate_bulk_tensor_property - subroutine get_scalable_volume_fraction(scaledvfrac, state, sumvolumefractionsbound, momentum_diagnostic) + subroutine get_scalable_volume_fraction(scaledvfrac, state, sumvolumefractionsbound, momentum_diagnostic) - type(scalar_field), intent(inout) :: scaledvfrac - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout), optional :: sumvolumefractionsbound - logical, intent(in), optional :: momentum_diagnostic + type(scalar_field), intent(inout) :: scaledvfrac + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout), optional :: sumvolumefractionsbound + logical, intent(in), optional :: momentum_diagnostic - type(scalar_field), pointer :: volumefraction, oldvolumefraction - type(vector_field), pointer :: velocity - type(scalar_field) :: remapvfrac + type(scalar_field), pointer :: volumefraction, oldvolumefraction + type(vector_field), pointer :: velocity + type(scalar_field) :: remapvfrac - integer :: stat - real :: theta + integer :: stat + real :: theta - logical :: cap - real:: u_cap_val, l_cap_val + logical :: cap + real:: u_cap_val, l_cap_val - volumefraction => extract_scalar_field(state, 'MaterialVolumeFraction') + volumefraction => extract_scalar_field(state, 'MaterialVolumeFraction') - call remap_field(volumefraction, scaledvfrac) + call remap_field(volumefraction, scaledvfrac) - if(present_and_true(momentum_diagnostic)) then - velocity => extract_vector_field(state, 'Velocity', stat=stat) - if(stat==0) then - call get_option(trim(velocity%option_path)//'/prognostic/temporal_discretisation/theta', & - theta, stat) - if(stat==0) then - call allocate(remapvfrac, scaledvfrac%mesh, "RemappedMaterialVolumeFraction") + if(present_and_true(momentum_diagnostic)) then + velocity => extract_vector_field(state, 'Velocity', stat=stat) + if(stat==0) then + call get_option(trim(velocity%option_path)//'/prognostic/temporal_discretisation/theta', & + theta, stat) + if(stat==0) then + call allocate(remapvfrac, scaledvfrac%mesh, "RemappedMaterialVolumeFraction") - oldvolumefraction => extract_scalar_field(state, 'OldMaterialVolumeFraction') - call remap_field(oldvolumefraction, remapvfrac) + oldvolumefraction => extract_scalar_field(state, 'OldMaterialVolumeFraction') + call remap_field(oldvolumefraction, remapvfrac) - call scale(scaledvfrac, theta) - call addto(scaledvfrac, remapvfrac, (1.-theta)) + call scale(scaledvfrac, theta) + call addto(scaledvfrac, remapvfrac, (1.-theta)) - call deallocate(remapvfrac) - end if + call deallocate(remapvfrac) + end if + end if end if - end if - cap = (have_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values")) + cap = (have_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values")) + + if(cap) then + ! this capping takes care of under or overshoots in this volume fraction individually + ! these will have typically occurred during advection - if(cap) then - ! this capping takes care of under or overshoots in this volume fraction individually - ! these will have typically occurred during advection + call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/upper_cap", & + u_cap_val, default=huge(0.0)*epsilon(0.0)) + call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/lower_cap", & + l_cap_val, default=-huge(0.0)*epsilon(0.0)) - call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/upper_cap", & - u_cap_val, default=huge(0.0)*epsilon(0.0)) - call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/lower_cap", & - l_cap_val, default=-huge(0.0)*epsilon(0.0)) + call bound(scaledvfrac, l_cap_val, u_cap_val) - call bound(scaledvfrac, l_cap_val, u_cap_val) + if(present(sumvolumefractionsbound)) then + assert(sumvolumefractionsbound%mesh==scaledvfrac%mesh) + ! this capping takes care of overlapping volume fractions + call bound(scaledvfrac, upper_bound=sumvolumefractionsbound) + call addto(sumvolumefractionsbound, scaledvfrac, scale=-1.0) + ewrite_minmax(sumvolumefractionsbound) + end if - if(present(sumvolumefractionsbound)) then - assert(sumvolumefractionsbound%mesh==scaledvfrac%mesh) - ! this capping takes care of overlapping volume fractions - call bound(scaledvfrac, upper_bound=sumvolumefractionsbound) - call addto(sumvolumefractionsbound, scaledvfrac, scale=-1.0) - ewrite_minmax(sumvolumefractionsbound) end if + ewrite_minmax(scaledvfrac) - end if - ewrite_minmax(scaledvfrac) - - end subroutine get_scalable_volume_fraction - - subroutine add_scaled_material_property_scalar(state,bulkfield,field,sumvolumefractionsbound,mean_type,momentum_diagnostic) - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: bulkfield, field - type(scalar_field), intent(inout), optional :: sumvolumefractionsbound - logical, intent(in), optional :: momentum_diagnostic - character(len=*), intent(in), optional :: mean_type - - !locals - character(len=OPTION_PATH_LEN) :: l_mean_type - type(scalar_field) :: scaledvfrac - type(scalar_field) :: tempfield - - if (present(mean_type)) then - l_mean_type = mean_type - else - l_mean_type = "arithmetic" - end if - - call allocate(tempfield, bulkfield%mesh, "Temp"//trim(bulkfield%name)) - call allocate(scaledvfrac, bulkfield%mesh, "ScaledMaterialVolumeFraction") - - call get_scalable_volume_fraction(scaledvfrac, state, & - sumvolumefractionsbound=sumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) - - call remap_field(field, tempfield) - select case(l_mean_type) - case("arithmetic") - call scale(tempfield, scaledvfrac) - call addto(bulkfield, tempfield) - case("harmonic") - call invert(tempfield, tolerance=tiny(0.0)) - call scale(tempfield, scaledvfrac) - call addto(bulkfield, tempfield) - case("geometric") - call power(tempfield, scaledvfrac) - call scale(bulkfield, tempfield) - case default - FLExit("Invalid mean_type in add_scaled_material_property") - end select - - call deallocate(tempfield) - call deallocate(scaledvfrac) - - end subroutine add_scaled_material_property_scalar - - subroutine add_scaled_material_property_vector(state,bulkfield,field,sumvolumefractionsbound,mean_type,momentum_diagnostic) - - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: bulkfield, field - type(scalar_field), intent(inout), optional :: sumvolumefractionsbound - logical, intent(in), optional :: momentum_diagnostic - character(len=*), intent(in), optional :: mean_type - - !locals - character(len=OPTION_PATH_LEN) :: l_mean_type - type(scalar_field) :: scaledvfrac - type(vector_field) :: tempfield - - if (present(mean_type)) then - l_mean_type = mean_type - else - l_mean_type = "arithmetic" - end if - - call allocate(tempfield, bulkfield%dim, bulkfield%mesh, "Temp"//trim(bulkfield%name)) - call allocate(scaledvfrac, bulkfield%mesh, "ScaledMaterialVolumeFraction") - - call get_scalable_volume_fraction(scaledvfrac, state, & - sumvolumefractionsbound=sumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) - - call remap_field(field, tempfield) - select case(l_mean_type) - case("arithmetic") - call scale(tempfield, scaledvfrac) - call addto(bulkfield, tempfield) - case("harmonic") - call invert(tempfield, tolerance=tiny(0.0)) - call scale(tempfield, scaledvfrac) - call addto(bulkfield, tempfield) - case("geometric") - call power(tempfield, scaledvfrac) - call scale(bulkfield, tempfield) - case default - FLExit("Invalid mean_type in add_scaled_material_property") - end select - - call deallocate(tempfield) - call deallocate(scaledvfrac) - - end subroutine add_scaled_material_property_vector - - subroutine add_scaled_material_property_tensor(state,bulkfield,field,sumvolumefractionsbound,mean_type,momentum_diagnostic) - - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: bulkfield, field - type(scalar_field), intent(inout), optional :: sumvolumefractionsbound - logical, intent(in), optional :: momentum_diagnostic - character(len=*), intent(in), optional :: mean_type - - !locals - character(len=OPTION_PATH_LEN) :: l_mean_type - type(scalar_field) :: scaledvfrac - type(tensor_field) :: tempfield - - if (present(mean_type)) then - l_mean_type = mean_type - else - l_mean_type = "arithmetic" - end if - - call allocate(tempfield, bulkfield%mesh, "Temp"//trim(bulkfield%name)) - call allocate(scaledvfrac, bulkfield%mesh, "ScaledMaterialVolumeFraction") - - call get_scalable_volume_fraction(scaledvfrac, state, & - sumvolumefractionsbound=sumvolumefractionsbound, & - momentum_diagnostic=momentum_diagnostic) + end subroutine get_scalable_volume_fraction - call remap_field(field, tempfield) - select case(l_mean_type) - case("arithmetic") - call scale(tempfield, scaledvfrac) - call addto(bulkfield, tempfield) - case("harmonic") - call invert(tempfield, tolerance=tiny(0.0)) - call scale(tempfield, scaledvfrac) - call addto(bulkfield, tempfield) - case("geometric") - call power(tempfield, scaledvfrac) - call scale(bulkfield, tempfield) - case default - FLExit("Invalid mean_type in add_scaled_material_property") - end select + subroutine add_scaled_material_property_scalar(state,bulkfield,field,sumvolumefractionsbound,mean_type,momentum_diagnostic) - call deallocate(tempfield) - call deallocate(scaledvfrac) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: bulkfield, field + type(scalar_field), intent(inout), optional :: sumvolumefractionsbound + logical, intent(in), optional :: momentum_diagnostic + character(len=*), intent(in), optional :: mean_type - end subroutine add_scaled_material_property_tensor + !locals + character(len=OPTION_PATH_LEN) :: l_mean_type + type(scalar_field) :: scaledvfrac + type(scalar_field) :: tempfield - subroutine calculate_material_volume(state, materialvolume) + if (present(mean_type)) then + l_mean_type = mean_type + else + l_mean_type = "arithmetic" + end if - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: materialvolume + call allocate(tempfield, bulkfield%mesh, "Temp"//trim(bulkfield%name)) + call allocate(scaledvfrac, bulkfield%mesh, "ScaledMaterialVolumeFraction") + + call get_scalable_volume_fraction(scaledvfrac, state, & + sumvolumefractionsbound=sumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) + + call remap_field(field, tempfield) + select case(l_mean_type) + case("arithmetic") + call scale(tempfield, scaledvfrac) + call addto(bulkfield, tempfield) + case("harmonic") + call invert(tempfield, tolerance=tiny(0.0)) + call scale(tempfield, scaledvfrac) + call addto(bulkfield, tempfield) + case("geometric") + call power(tempfield, scaledvfrac) + call scale(bulkfield, tempfield) + case default + FLExit("Invalid mean_type in add_scaled_material_property") + end select + + call deallocate(tempfield) + call deallocate(scaledvfrac) + + end subroutine add_scaled_material_property_scalar + + subroutine add_scaled_material_property_vector(state,bulkfield,field,sumvolumefractionsbound,mean_type,momentum_diagnostic) + + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: bulkfield, field + type(scalar_field), intent(inout), optional :: sumvolumefractionsbound + logical, intent(in), optional :: momentum_diagnostic + character(len=*), intent(in), optional :: mean_type + + !locals + character(len=OPTION_PATH_LEN) :: l_mean_type + type(scalar_field) :: scaledvfrac + type(vector_field) :: tempfield + + if (present(mean_type)) then + l_mean_type = mean_type + else + l_mean_type = "arithmetic" + end if - ! local - type(scalar_field) :: cvmass - type(scalar_field), pointer :: volumefraction - type(vector_field), pointer :: coordinates + call allocate(tempfield, bulkfield%dim, bulkfield%mesh, "Temp"//trim(bulkfield%name)) + call allocate(scaledvfrac, bulkfield%mesh, "ScaledMaterialVolumeFraction") + + call get_scalable_volume_fraction(scaledvfrac, state, & + sumvolumefractionsbound=sumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) + + call remap_field(field, tempfield) + select case(l_mean_type) + case("arithmetic") + call scale(tempfield, scaledvfrac) + call addto(bulkfield, tempfield) + case("harmonic") + call invert(tempfield, tolerance=tiny(0.0)) + call scale(tempfield, scaledvfrac) + call addto(bulkfield, tempfield) + case("geometric") + call power(tempfield, scaledvfrac) + call scale(bulkfield, tempfield) + case default + FLExit("Invalid mean_type in add_scaled_material_property") + end select + + call deallocate(tempfield) + call deallocate(scaledvfrac) + + end subroutine add_scaled_material_property_vector + + subroutine add_scaled_material_property_tensor(state,bulkfield,field,sumvolumefractionsbound,mean_type,momentum_diagnostic) + + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: bulkfield, field + type(scalar_field), intent(inout), optional :: sumvolumefractionsbound + logical, intent(in), optional :: momentum_diagnostic + character(len=*), intent(in), optional :: mean_type + + !locals + character(len=OPTION_PATH_LEN) :: l_mean_type + type(scalar_field) :: scaledvfrac + type(tensor_field) :: tempfield + + if (present(mean_type)) then + l_mean_type = mean_type + else + l_mean_type = "arithmetic" + end if - coordinates=>extract_vector_field(state, "Coordinate") + call allocate(tempfield, bulkfield%mesh, "Temp"//trim(bulkfield%name)) + call allocate(scaledvfrac, bulkfield%mesh, "ScaledMaterialVolumeFraction") - call allocate(cvmass, materialvolume%mesh, "CV mass") - call zero(cvmass) + call get_scalable_volume_fraction(scaledvfrac, state, & + sumvolumefractionsbound=sumvolumefractionsbound, & + momentum_diagnostic=momentum_diagnostic) - call compute_cv_mass(coordinates, cvmass) + call remap_field(field, tempfield) + select case(l_mean_type) + case("arithmetic") + call scale(tempfield, scaledvfrac) + call addto(bulkfield, tempfield) + case("harmonic") + call invert(tempfield, tolerance=tiny(0.0)) + call scale(tempfield, scaledvfrac) + call addto(bulkfield, tempfield) + case("geometric") + call power(tempfield, scaledvfrac) + call scale(bulkfield, tempfield) + case default + FLExit("Invalid mean_type in add_scaled_material_property") + end select - volumefraction=>extract_scalar_field(state,"MaterialVolumeFraction") + call deallocate(tempfield) + call deallocate(scaledvfrac) - materialvolume%val=volumefraction%val*cvmass%val + end subroutine add_scaled_material_property_tensor - call deallocate(cvmass) + subroutine calculate_material_volume(state, materialvolume) - end subroutine calculate_material_volume + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: materialvolume - subroutine calculate_material_mass(state, materialmass) + ! local + type(scalar_field) :: cvmass + type(scalar_field), pointer :: volumefraction + type(vector_field), pointer :: coordinates - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: materialmass + coordinates=>extract_vector_field(state, "Coordinate") - ! local - integer :: stat - type(scalar_field) :: cvmass - type(scalar_field), pointer :: volumefraction, materialdensity - type(vector_field), pointer :: coordinates - real :: rho_0 + call allocate(cvmass, materialvolume%mesh, "CV mass") + call zero(cvmass) - coordinates=>extract_vector_field(state, "Coordinate") + call compute_cv_mass(coordinates, cvmass) - call allocate(cvmass, materialmass%mesh, "CV mass") - call zero(cvmass) + volumefraction=>extract_scalar_field(state,"MaterialVolumeFraction") - call compute_cv_mass(coordinates, cvmass) + materialvolume%val=volumefraction%val*cvmass%val - volumefraction=>extract_scalar_field(state,"MaterialVolumeFraction") - call set(materialmass, volumefraction) - call scale(materialmass, cvmass) + call deallocate(cvmass) - materialdensity=>extract_scalar_field(state,"MaterialDensity", stat=stat) - if(stat==0) then - call scale(materialmass, materialdensity) - else - call get_option("/material_phase::"//trim(state%name)& - //"/equation_of_state/fluids/linear/reference_density", rho_0) - call scale(materialmass, rho_0) - end if + end subroutine calculate_material_volume - call deallocate(cvmass) + subroutine calculate_material_mass(state, materialmass) - end subroutine calculate_material_mass + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: materialmass - subroutine calculate_bulk_material_pressure(state,bulkmaterialpressure) + ! local + integer :: stat + type(scalar_field) :: cvmass + type(scalar_field), pointer :: volumefraction, materialdensity + type(vector_field), pointer :: coordinates + real :: rho_0 - type(state_type), dimension(:), intent(inout) :: state - type(scalar_field) :: bulkmaterialpressure + coordinates=>extract_vector_field(state, "Coordinate") - !locals - integer :: i, stat - type(scalar_field), pointer :: volumefraction - type(scalar_field) :: materialpressure + call allocate(cvmass, materialmass%mesh, "CV mass") + call zero(cvmass) - call zero(bulkmaterialpressure) + call compute_cv_mass(coordinates, cvmass) - call allocate(materialpressure, bulkmaterialpressure%mesh, "TempBulkPressure") + volumefraction=>extract_scalar_field(state,"MaterialVolumeFraction") + call set(materialmass, volumefraction) + call scale(materialmass, cvmass) - do i = 1, size(state) + materialdensity=>extract_scalar_field(state,"MaterialDensity", stat=stat) + if(stat==0) then + call scale(materialmass, materialdensity) + else + call get_option("/material_phase::"//trim(state%name)& + //"/equation_of_state/fluids/linear/reference_density", rho_0) + call scale(materialmass, rho_0) + end if - volumefraction => extract_scalar_field(state(i), 'MaterialVolumeFraction', stat) + call deallocate(cvmass) - if (stat==0) then + end subroutine calculate_material_mass - call compressible_material_eos(state(i), materialpressure=materialpressure) + subroutine calculate_bulk_material_pressure(state,bulkmaterialpressure) - bulkmaterialpressure%val=bulkmaterialpressure%val+volumefraction%val*materialpressure%val + type(state_type), dimension(:), intent(inout) :: state + type(scalar_field) :: bulkmaterialpressure - end if + !locals + integer :: i, stat + type(scalar_field), pointer :: volumefraction + type(scalar_field) :: materialpressure - end do + call zero(bulkmaterialpressure) - call deallocate(materialpressure) + call allocate(materialpressure, bulkmaterialpressure%mesh, "TempBulkPressure") - end subroutine calculate_bulk_material_pressure + do i = 1, size(state) - subroutine calculate_sum_material_volume_fractions(state,sumvolumefractions) + volumefraction => extract_scalar_field(state(i), 'MaterialVolumeFraction', stat) - type(state_type), dimension(:), intent(inout) :: state - type(scalar_field), intent(inout) :: sumvolumefractions + if (stat==0) then - !locals - integer :: i, stat - type(scalar_field), pointer :: sfield - logical :: prognostic, diagnostic, prescribed, diagnostic_particles + call compressible_material_eos(state(i), materialpressure=materialpressure) - diagnostic = have_option(trim(sumvolumefractions%option_path)//"/diagnostic/algorithm::Internal") - if(.not.diagnostic) return + bulkmaterialpressure%val=bulkmaterialpressure%val+volumefraction%val*materialpressure%val - call zero(sumvolumefractions) + end if - do i = 1,size(state) - sfield=>extract_scalar_field(state(i),'MaterialVolumeFraction',stat) - if(stat==0) then - prognostic = have_option(trim(sfield%option_path)//"/prognostic") - prescribed = have_option(trim(sfield%option_path)//"/prescribed") - diagnostic_particles = have_option(trim(sfield%option_path)//"/diagnostic/algorithm::from_particles") - if ((.not.aliased(sfield)).and.(prognostic.or.prescribed.or.diagnostic_particles)) then - call addto(sumvolumefractions, sfield) - end if - end if - end do + end do + + call deallocate(materialpressure) + + end subroutine calculate_bulk_material_pressure + + subroutine calculate_sum_material_volume_fractions(state,sumvolumefractions) + + type(state_type), dimension(:), intent(inout) :: state + type(scalar_field), intent(inout) :: sumvolumefractions + + !locals + integer :: i, stat + type(scalar_field), pointer :: sfield + logical :: prognostic, diagnostic, prescribed, diagnostic_particles + + diagnostic = have_option(trim(sumvolumefractions%option_path)//"/diagnostic/algorithm::Internal") + if(.not.diagnostic) return + + call zero(sumvolumefractions) + + do i = 1,size(state) + sfield=>extract_scalar_field(state(i),'MaterialVolumeFraction',stat) + if(stat==0) then + prognostic = have_option(trim(sfield%option_path)//"/prognostic") + prescribed = have_option(trim(sfield%option_path)//"/prescribed") + diagnostic_particles = have_option(trim(sfield%option_path)//"/diagnostic/algorithm::from_particles") + if ((.not.aliased(sfield)).and.(prognostic.or.prescribed.or.diagnostic_particles)) then + call addto(sumvolumefractions, sfield) + end if + end if + end do - end subroutine calculate_sum_material_volume_fractions + end subroutine calculate_sum_material_volume_fractions end module multimaterial_module diff --git a/assemble/Multiphase.F90 b/assemble/Multiphase.F90 index b85d32a4e7..591da77542 100644 --- a/assemble/Multiphase.F90 +++ b/assemble/Multiphase.F90 @@ -27,988 +27,988 @@ #include "fdebug.h" - module multiphase_module - !! This module contains various subroutines and functions for - !! multiphase flow simulations - use fldebug - use spud - use global_parameters, only: OPTION_PATH_LEN - use sparse_tools - use parallel_fields - use fetools - use fields - use profiler - use sparse_tools_petsc - use state_module - use field_options - use field_priority_lists - - implicit none - - private - public :: get_phase_submaterials, get_nonlinear_volume_fraction, & - calculate_diagnostic_phase_volume_fraction, & - add_fluid_particle_drag, add_heat_transfer +module multiphase_module + !! This module contains various subroutines and functions for + !! multiphase flow simulations + use fldebug + use spud + use global_parameters, only: OPTION_PATH_LEN + use sparse_tools + use parallel_fields + use fetools + use fields + use profiler + use sparse_tools_petsc + use state_module + use field_options + use field_priority_lists + + implicit none + + private + public :: get_phase_submaterials, get_nonlinear_volume_fraction, & + calculate_diagnostic_phase_volume_fraction, & + add_fluid_particle_drag, add_heat_transfer + +contains + + subroutine get_phase_submaterials(state, istate, submaterials, phase_istate, submaterials_indices) + !!< Sets up an array of the submaterials of a phase. + !!< NB: This includes the current state itself (i.e. state(istate)). + + type(state_type), dimension(:), target, intent(inout) :: state + integer, intent(in) :: istate + type(state_type), dimension(:), pointer :: submaterials + integer, intent(inout), optional :: phase_istate + integer, dimension(:), pointer, optional :: submaterials_indices + + !! Local variables + integer :: i, next, stat, material_count + type(vector_field), pointer :: u + character(len=OPTION_PATH_LEN) :: phase_name, target_name + logical, dimension(:), pointer :: is_submaterial + + ewrite(1,*) 'Entering get_phase_submaterials' + + !! Store whether state(i) is a material or not in an array of logicals + !! to save on computations in the second loop + allocate(is_submaterial(size(state))) + + !! Get the number of submaterials so we can make submaterials the correct size + + material_count = 1 ! We will include state(istate) as one of the materials + + phase_name = trim(state(istate)%name) + + do i = 1, size(state) + + if(i == istate) then + is_submaterial(i) = .true. + cycle ! Already counted the current state + end if - contains + u => extract_vector_field(state(i), "Velocity", stat) + is_submaterial(i) = .false. - subroutine get_phase_submaterials(state, istate, submaterials, phase_istate, submaterials_indices) - !!< Sets up an array of the submaterials of a phase. - !!< NB: This includes the current state itself (i.e. state(istate)). + ! If velocity field exists and is aliased to a phase's velocity field... + if(stat == 0) then + if(aliased(u)) then + ! ...then find out which phase it is aliased to. If it's the current phase, + ! then we have found one more submaterial. - type(state_type), dimension(:), target, intent(inout) :: state - integer, intent(in) :: istate - type(state_type), dimension(:), pointer :: submaterials - integer, intent(inout), optional :: phase_istate - integer, dimension(:), pointer, optional :: submaterials_indices + ! Save the name of the phase that the current state is aliased to + call get_option(trim(state(i)%option_path)//"/vector_field::Velocity/aliased/material_phase_name", target_name) - !! Local variables - integer :: i, next, stat, material_count - type(vector_field), pointer :: u - character(len=OPTION_PATH_LEN) :: phase_name, target_name - logical, dimension(:), pointer :: is_submaterial + if(target_name == phase_name) then + ! Found one more submaterial! + material_count = material_count + 1 + is_submaterial(i) = .true. + end if + end if + end if - ewrite(1,*) 'Entering get_phase_submaterials' + end do - !! Store whether state(i) is a material or not in an array of logicals - !! to save on computations in the second loop - allocate(is_submaterial(size(state))) + ewrite(1,*) 'Number of sub-materials = ', material_count - !! Get the number of submaterials so we can make submaterials the correct size + !! Allocate submaterials array + allocate(submaterials(material_count)) + if (present(submaterials_indices)) then + allocate(submaterials_indices(material_count)) + end if - material_count = 1 ! We will include state(istate) as one of the materials + !! Assign the states to the submaterials array + next = 1 ! Keep track of where we are in the submaterials array + do i = 1, size(state) + if(is_submaterial(i)) then + submaterials(next) = state(i) + if (present(submaterials_indices)) then + submaterials_indices(next) = i + end if - phase_name = trim(state(istate)%name) + ! Keep track of the phase's index in the new submaterials array + if(present(phase_istate) .and. (i == istate)) then + phase_istate = next + end if - do i = 1, size(state) + next = next + 1 + end if + end do - if(i == istate) then - is_submaterial(i) = .true. - cycle ! Already counted the current state - end if + deallocate(is_submaterial) - u => extract_vector_field(state(i), "Velocity", stat) - is_submaterial(i) = .false. + ewrite(1,*) 'Exiting get_phase_submaterials' - ! If velocity field exists and is aliased to a phase's velocity field... - if(stat == 0) then - if(aliased(u)) then - ! ...then find out which phase it is aliased to. If it's the current phase, - ! then we have found one more submaterial. + end subroutine get_phase_submaterials - ! Save the name of the phase that the current state is aliased to - call get_option(trim(state(i)%option_path)//"/vector_field::Velocity/aliased/material_phase_name", target_name) - if(target_name == phase_name) then - ! Found one more submaterial! - material_count = material_count + 1 - is_submaterial(i) = .true. - end if - end if - end if + subroutine get_nonlinear_volume_fraction(state, nvfrac) + !!< Computes the nonlinear approximation to the phase volume fraction + !!< and stores it in a locally allocated field before assembling the momentum equation. - end do + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: nvfrac - ewrite(1,*) 'Number of sub-materials = ', material_count + type(scalar_field), pointer :: volumefraction, oldvolumefraction + type(vector_field), pointer :: velocity + type(scalar_field) :: remapvfrac - !! Allocate submaterials array - allocate(submaterials(material_count)) - if (present(submaterials_indices)) then - allocate(submaterials_indices(material_count)) - end if + integer :: stat + real :: theta - !! Assign the states to the submaterials array - next = 1 ! Keep track of where we are in the submaterials array - do i = 1, size(state) - if(is_submaterial(i)) then - submaterials(next) = state(i) - if (present(submaterials_indices)) then - submaterials_indices(next) = i - end if + logical :: cap + real:: u_cap_val, l_cap_val - ! Keep track of the phase's index in the new submaterials array - if(present(phase_istate) .and. (i == istate)) then - phase_istate = next - end if + ewrite(1,*) 'Entering get_nonlinear_volume_fraction' - next = next + 1 - end if - end do - deallocate(is_submaterial) + volumefraction => extract_scalar_field(state, 'PhaseVolumeFraction') - ewrite(1,*) 'Exiting get_phase_submaterials' + ! Calculate the non-linear PhaseVolumeFraction + call remap_field(volumefraction, nvfrac) - end subroutine get_phase_submaterials + velocity => extract_vector_field(state, 'Velocity', stat=stat) + if(stat==0) then + call get_option(trim(velocity%option_path)//'/prognostic/temporal_discretisation/theta', & + theta, stat) + if(stat==0) then + call allocate(remapvfrac, nvfrac%mesh, "RemppedPhaseVolumeFraction") + oldvolumefraction => extract_scalar_field(state, 'OldPhaseVolumeFraction') - subroutine get_nonlinear_volume_fraction(state, nvfrac) - !!< Computes the nonlinear approximation to the phase volume fraction - !!< and stores it in a locally allocated field before assembling the momentum equation. + ewrite_minmax(oldvolumefraction) + ewrite_minmax(volumefraction) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: nvfrac + call remap_field(oldvolumefraction, remapvfrac) - type(scalar_field), pointer :: volumefraction, oldvolumefraction - type(vector_field), pointer :: velocity - type(scalar_field) :: remapvfrac + call scale(nvfrac, theta) + call addto(nvfrac, remapvfrac, (1.0-theta)) - integer :: stat - real :: theta + call deallocate(remapvfrac) + end if + end if - logical :: cap - real:: u_cap_val, l_cap_val + ! Cap the volume fraction to take care of under or overshoots. + ! This will have typically occurred during advection. + cap = (have_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values")) + if(cap) then + call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/upper_cap", & + u_cap_val, default=huge(0.0)*epsilon(0.0)) + call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/lower_cap", & + l_cap_val, default=-huge(0.0)*epsilon(0.0)) - ewrite(1,*) 'Entering get_nonlinear_volume_fraction' + call bound(nvfrac, l_cap_val, u_cap_val) + end if + ewrite_minmax(nvfrac) - volumefraction => extract_scalar_field(state, 'PhaseVolumeFraction') + ewrite(1,*) 'Exiting get_nonlinear_volume_fraction' - ! Calculate the non-linear PhaseVolumeFraction - call remap_field(volumefraction, nvfrac) + end subroutine get_nonlinear_volume_fraction - velocity => extract_vector_field(state, 'Velocity', stat=stat) - if(stat==0) then - call get_option(trim(velocity%option_path)//'/prognostic/temporal_discretisation/theta', & - theta, stat) - if(stat==0) then - call allocate(remapvfrac, nvfrac%mesh, "RemppedPhaseVolumeFraction") - oldvolumefraction => extract_scalar_field(state, 'OldPhaseVolumeFraction') + subroutine calculate_diagnostic_phase_volume_fraction(state) + !!< Searches for the state with the diagnostic PhaseVolumeFraction field, + !!< and then computes it using the formula: + !!< diagnostic volume fraction = 1.0 - (sum of all other volume fractions) + + type(state_type), dimension(:), intent(inout) :: state - ewrite_minmax(oldvolumefraction) - ewrite_minmax(volumefraction) + ! Local variables + type(scalar_field), pointer :: phasevolumefraction + integer :: i, stat, diagnostic_count + type(scalar_field) :: sumvolumefractions + type(scalar_field), pointer :: sfield + logical :: diagnostic - call remap_field(oldvolumefraction, remapvfrac) + ewrite(1,*) 'Entering calculate_diagnostic_phase_volume_fraction' - call scale(nvfrac, theta) - call addto(nvfrac, remapvfrac, (1.0-theta)) + diagnostic_count = option_count("/material_phase/scalar_field::PhaseVolumeFraction/diagnostic") + if(diagnostic_count>1) then + ewrite(0,*) diagnostic_count, ' diagnostic PhaseVolumeFractions' + FLExit("Only one diagnostic PhaseVolumeFraction permitted.") + end if - call deallocate(remapvfrac) + if(diagnostic_count==1) then + ! Find the diagnostic volume fraction + state_loop: do i = 1, size(state) + phasevolumefraction=>extract_scalar_field(state(i), 'PhaseVolumeFraction', stat) + if (stat==0) then + diagnostic = (have_option(trim(phasevolumefraction%option_path)//'/diagnostic')) + if((.not. aliased(phasevolumefraction)).and. diagnostic) then + exit state_loop + end if end if - end if + end do state_loop - ! Cap the volume fraction to take care of under or overshoots. - ! This will have typically occurred during advection. - cap = (have_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values")) - if(cap) then - call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/upper_cap", & - u_cap_val, default=huge(0.0)*epsilon(0.0)) - call get_option(trim(complete_field_path(volumefraction%option_path))//"/cap_values/lower_cap", & - l_cap_val, default=-huge(0.0)*epsilon(0.0)) + call allocate(sumvolumefractions, phasevolumefraction%mesh, 'Sum of volume fractions') + call zero(sumvolumefractions) - call bound(nvfrac, l_cap_val, u_cap_val) - end if + do i = 1, size(state) + sfield=>extract_scalar_field(state(i),'PhaseVolumeFraction',stat) + diagnostic=(have_option(trim(sfield%option_path)//'/diagnostic')) + if ( (stat==0).and.(.not. aliased(sfield)).and.(.not.diagnostic)) then + call addto(sumvolumefractions, sfield) + end if + end do - ewrite_minmax(nvfrac) + call set(phasevolumefraction, 1.0) + call addto(phasevolumefraction, sumvolumefractions, -1.0) + call deallocate(sumvolumefractions) + end if - ewrite(1,*) 'Exiting get_nonlinear_volume_fraction' + ewrite(1,*) 'Exiting calculate_diagnostic_phase_volume_fraction' - end subroutine get_nonlinear_volume_fraction + end subroutine calculate_diagnostic_phase_volume_fraction - subroutine calculate_diagnostic_phase_volume_fraction(state) - !!< Searches for the state with the diagnostic PhaseVolumeFraction field, - !!< and then computes it using the formula: - !!< diagnostic volume fraction = 1.0 - (sum of all other volume fractions) + !! Multiphase interaction terms, F_i + subroutine add_fluid_particle_drag(state, istate, u, x, big_m, mom_rhs) + !!< This computes the fluid-particle drag force term. + !!< Note that this assumes only one fluid phase, and one or more particle phases. - type(state_type), dimension(:), intent(inout) :: state + type(state_type), dimension(:), intent(inout) :: state + integer, intent(in) :: istate + type(vector_field), intent(in) :: u, x + type(petsc_csr_matrix), intent(inout) :: big_m + type(vector_field), intent(inout) :: mom_rhs - ! Local variables - type(scalar_field), pointer :: phasevolumefraction - integer :: i, stat, diagnostic_count - type(scalar_field) :: sumvolumefractions - type(scalar_field), pointer :: sfield - logical :: diagnostic - - ewrite(1,*) 'Entering calculate_diagnostic_phase_volume_fraction' - - diagnostic_count = option_count("/material_phase/scalar_field::PhaseVolumeFraction/diagnostic") - if(diagnostic_count>1) then - ewrite(0,*) diagnostic_count, ' diagnostic PhaseVolumeFractions' - FLExit("Only one diagnostic PhaseVolumeFraction permitted.") - end if + ! Local variables + integer :: ele + type(element_type) :: test_function + type(element_type), pointer :: u_shape + integer, dimension(:), pointer :: u_nodes + logical :: dg - if(diagnostic_count==1) then - ! Find the diagnostic volume fraction - state_loop: do i = 1, size(state) - phasevolumefraction=>extract_scalar_field(state(i), 'PhaseVolumeFraction', stat) - if (stat==0) then - diagnostic = (have_option(trim(phasevolumefraction%option_path)//'/diagnostic')) - if((.not. aliased(phasevolumefraction)).and. diagnostic) then - exit state_loop - end if - end if - end do state_loop + type(vector_field), pointer :: velocity_fluid - call allocate(sumvolumefractions, phasevolumefraction%mesh, 'Sum of volume fractions') - call zero(sumvolumefractions) + logical :: is_particle_phase - do i = 1, size(state) - sfield=>extract_scalar_field(state(i),'PhaseVolumeFraction',stat) - diagnostic=(have_option(trim(sfield%option_path)//'/diagnostic')) - if ( (stat==0).and.(.not. aliased(sfield)).and.(.not.diagnostic)) then - call addto(sumvolumefractions, sfield) - end if - end do + real :: dt, theta + logical, dimension(u%dim, u%dim) :: block_mask ! Control whether the off diagonal entries are used - call set(phasevolumefraction, 1.0) - call addto(phasevolumefraction, sumvolumefractions, -1.0) - call deallocate(sumvolumefractions) - end if + integer :: i, dim + logical :: not_found ! Error flag. Have we found the fluid phase? + integer :: istate_fluid - ewrite(1,*) 'Exiting calculate_diagnostic_phase_volume_fraction' + ! Types of drag correlation + integer, parameter :: DRAG_CORRELATION_TYPE_STOKES = 1, DRAG_CORRELATION_TYPE_WEN_YU = 2, DRAG_CORRELATION_TYPE_ERGUN = 3, DRAG_CORRELATION_TYPE_SCHILLER_NAUMANN = 4, DRAG_CORRELATION_TYPE_LAIN_1_1999= 5, DRAG_CORRELATION_TYPE_LAIN_2_2002 = 6 - end subroutine calculate_diagnostic_phase_volume_fraction + ewrite(1, *) "Entering add_fluid_particle_drag" + ! Let's check whether we actually have at least one particle phase. + if( (option_count("/material_phase/multiphase_properties/particle_diameter") == 0) .and. (option_count("/material_phase/multiphase_properties/particle_dia_use_scalar_field") == 0) ) then + FLExit("Fluid-particle drag enabled but no particle_diameter has been specified for the particle phase(s).") + end if - !! Multiphase interaction terms, F_i - subroutine add_fluid_particle_drag(state, istate, u, x, big_m, mom_rhs) - !!< This computes the fluid-particle drag force term. - !!< Note that this assumes only one fluid phase, and one or more particle phases. + ! Get the timestepping options + call get_option("/timestepping/timestep", dt) + call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/theta", theta) - type(state_type), dimension(:), intent(inout) :: state - integer, intent(in) :: istate - type(vector_field), intent(in) :: u, x - type(petsc_csr_matrix), intent(inout) :: big_m - type(vector_field), intent(inout) :: mom_rhs + ! For the big_m matrix. Controls whether the off diagonal entries are used + block_mask = .false. + do dim = 1, u%dim + block_mask(dim, dim) = .true. + end do - ! Local variables - integer :: ele - type(element_type) :: test_function - type(element_type), pointer :: u_shape - integer, dimension(:), pointer :: u_nodes - logical :: dg + ! Are we using a discontinuous Galerkin discretisation? + dg = continuity(u) < 0 - type(vector_field), pointer :: velocity_fluid + ! Is this phase a particle phase? + is_particle_phase = have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field") - logical :: is_particle_phase + ! Retrieve the index of the fluid phase in the state array. + not_found = .true. + if(is_particle_phase) then + do i = 1, size(state) + if(.not.(have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field"))) then + + velocity_fluid => extract_vector_field(state(i), "Velocity") + ! Aliased material_phases will also not have a particle_diameter, + ! so here we make sure that we don't count these as the fluid phase + if(.not.aliased(velocity_fluid)) then + istate_fluid = i + if(.not.not_found) then + FLExit("Fluid-particle drag does not currently support more than one fluid phase.") + end if + not_found = .false. + end if - real :: dt, theta - logical, dimension(u%dim, u%dim) :: block_mask ! Control whether the off diagonal entries are used + end if + end do + else + istate_fluid = istate + not_found = .false. + end if + + if(not_found) then + FLExit("No fluid phase found for the fluid-particle drag.") + end if + + ! If we have a fluid-particle pair, then assemble the drag term + if(is_particle_phase) then + call assemble_fluid_particle_drag(istate_fluid, istate) + else + state_loop: do i = 1, size(state) + if(i /= istate_fluid) then + call assemble_fluid_particle_drag(istate_fluid, i) + end if + end do state_loop + end if - integer :: i, dim - logical :: not_found ! Error flag. Have we found the fluid phase? - integer :: istate_fluid + ewrite(1, *) "Exiting add_fluid_particle_drag" - ! Types of drag correlation - integer, parameter :: DRAG_CORRELATION_TYPE_STOKES = 1, DRAG_CORRELATION_TYPE_WEN_YU = 2, DRAG_CORRELATION_TYPE_ERGUN = 3, DRAG_CORRELATION_TYPE_SCHILLER_NAUMANN = 4, DRAG_CORRELATION_TYPE_LAIN_1_1999= 5, DRAG_CORRELATION_TYPE_LAIN_2_2002 = 6 + contains - ewrite(1, *) "Entering add_fluid_particle_drag" + subroutine assemble_fluid_particle_drag(istate_fluid, istate_particle) + + integer, intent(in) :: istate_fluid, istate_particle + + type(scalar_field), pointer :: vfrac_fluid, vfrac_particle + type(scalar_field), pointer :: density_fluid, density_particle + type(scalar_field), pointer :: d_field ! scalar field defining particle diameter + type(vector_field), pointer :: velocity_fluid, velocity_particle + type(vector_field), pointer :: oldu_fluid, oldu_particle + type(vector_field), pointer :: nu_fluid, nu_particle ! Non-linear approximation to the Velocities + type(tensor_field), pointer :: viscosity_fluid + type(scalar_field) :: nvfrac_fluid, nvfrac_particle + real :: d ! Particle diameter + real :: d_cap_lower + character(len=OPTION_PATH_LEN) :: drag_correlation_name + character(len=OPTION_PATH_LEN) :: d_field_name ! name of scalar field that defines particle diameter (can be the sauter mean dia) + integer :: drag_correlation + logical :: have_constant_d ! checks if the particle diameter is a constant or not + + ! Get the necessary fields to calculate the drag force + velocity_fluid => extract_vector_field(state(istate_fluid), "Velocity") + velocity_particle => extract_vector_field(state(istate_particle), "Velocity") + if(.not.aliased(velocity_particle)) then ! Don't count the aliased material_phases + + vfrac_fluid => extract_scalar_field(state(istate_fluid), "PhaseVolumeFraction") + vfrac_particle => extract_scalar_field(state(istate_particle), "PhaseVolumeFraction") + density_fluid => extract_scalar_field(state(istate_fluid), "Density") + density_particle => extract_scalar_field(state(istate_particle), "Density") + ! Make sure that the molecular viscosity is used. Not the effective viscosity + if(have_option(trim(state(istate_fluid)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then + viscosity_fluid => extract_tensor_field(state(istate_fluid),"BackgroundViscosity") + else + viscosity_fluid => extract_tensor_field(state(istate_fluid), "Viscosity") + end if + if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter")) then + call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter", d) + have_constant_d = .true. + else if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter_use_scalar_field")) then + call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter_use_scalar_field", d_field_name) + d_field => extract_scalar_field(state(istate_particle), d_field_name) + have_constant_d = .false. + end if - ! Let's check whether we actually have at least one particle phase. - if( (option_count("/material_phase/multiphase_properties/particle_diameter") == 0) .and. (option_count("/material_phase/multiphase_properties/particle_dia_use_scalar_field") == 0) ) then - FLExit("Fluid-particle drag enabled but no particle_diameter has been specified for the particle phase(s).") - end if + call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/apply_diameter_cap/lower_cap", d_cap_lower, default = 1.0e-12) + + ! Calculate the non-linear approximation to the PhaseVolumeFractions + call allocate(nvfrac_fluid, vfrac_fluid%mesh, "NonlinearPhaseVolumeFraction") + call allocate(nvfrac_particle, vfrac_particle%mesh, "NonlinearPhaseVolumeFraction") + call zero(nvfrac_fluid) + call zero(nvfrac_particle) + call get_nonlinear_volume_fraction(state(istate_fluid), nvfrac_fluid) + call get_nonlinear_volume_fraction(state(istate_particle), nvfrac_particle) + + ! Get the non-linear approximation to the Velocities + nu_fluid => extract_vector_field(state(istate_fluid), "NonlinearVelocity") + nu_particle => extract_vector_field(state(istate_particle), "NonlinearVelocity") + oldu_fluid => extract_vector_field(state(istate_fluid), "OldVelocity") + oldu_particle => extract_vector_field(state(istate_particle), "OldVelocity") + + call get_option("/multiphase_interaction/fluid_particle_drag/drag_correlation/name", drag_correlation_name) + select case(trim(drag_correlation_name)) + case("stokes") + drag_correlation = DRAG_CORRELATION_TYPE_STOKES + case("wen_yu") + drag_correlation = DRAG_CORRELATION_TYPE_WEN_YU + case("ergun") + drag_correlation = DRAG_CORRELATION_TYPE_ERGUN + case("schiller_naumann") + drag_correlation = DRAG_CORRELATION_TYPE_SCHILLER_NAUMANN + case("lain_1_1999") + drag_correlation = DRAG_CORRELATION_TYPE_LAIN_1_1999 + case("lain_2_2002") + drag_correlation = DRAG_CORRELATION_TYPE_LAIN_2_2002 + case default + FLAbort("Unknown correlation for fluid-particle drag") + end select + + ! ----- Volume integrals over elements ------------- + call profiler_tic(u, "element_loop") + element_loop: do ele = 1, element_count(u) + + if(.not.dg .or. (dg .and. element_owned(u,ele))) then + u_nodes => ele_nodes(u, ele) + u_shape => ele_shape(u, ele) + test_function = u_shape + + call add_fluid_particle_drag_element(ele, test_function, u_shape, & + x, u, big_m, mom_rhs, & + nvfrac_fluid, nvfrac_particle, & + density_fluid, density_particle, & + nu_fluid, nu_particle, & + oldu_fluid, oldu_particle, & + viscosity_fluid, & + have_constant_d, d, d_field, d_cap_lower, & + drag_correlation) + end if - ! Get the timestepping options - call get_option("/timestepping/timestep", dt) - call get_option(trim(u%option_path)//"/prognostic/temporal_discretisation/theta", theta) + end do element_loop + call profiler_toc(u, "element_loop") - ! For the big_m matrix. Controls whether the off diagonal entries are used - block_mask = .false. - do dim = 1, u%dim - block_mask(dim, dim) = .true. - end do + call deallocate(nvfrac_fluid) + call deallocate(nvfrac_particle) + end if - ! Are we using a discontinuous Galerkin discretisation? - dg = continuity(u) < 0 + end subroutine assemble_fluid_particle_drag + + subroutine add_fluid_particle_drag_element(ele, test_function, u_shape, & + x, u, big_m, mom_rhs, & + vfrac_fluid, vfrac_particle, & + density_fluid, density_particle, & + nu_fluid, nu_particle, & + oldu_fluid, oldu_particle, & + viscosity_fluid, & + have_constant_d, d, d_field, d_cap_lower, & + drag_correlation) + + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(element_type), intent(in) :: u_shape + type(vector_field), intent(in) :: u, x + type(petsc_csr_matrix), intent(inout) :: big_m + type(vector_field), intent(inout) :: mom_rhs - ! Is this phase a particle phase? - is_particle_phase = have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field") + type(scalar_field), intent(in) :: vfrac_fluid, vfrac_particle + type(scalar_field), intent(in) :: density_fluid, density_particle + type(scalar_field), pointer, intent(in) :: d_field ! Scalar field representing particle diameter + type(vector_field), intent(in) :: nu_fluid, nu_particle + type(vector_field), intent(in) :: oldu_fluid, oldu_particle + type(tensor_field), intent(in) :: viscosity_fluid + real, intent(in) :: d ! Constant particle diameter + real, intent(in) :: d_cap_lower + integer, intent(in) :: drag_correlation + logical, intent(in) :: have_constant_d ! is true if particle diameter is a constant. is false if it is a scalar field (e.g. sauter mean dia) - ! Retrieve the index of the fluid phase in the state array. - not_found = .true. - if(is_particle_phase) then - do i = 1, size(state) - if(.not.(have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field"))) then - - velocity_fluid => extract_vector_field(state(i), "Velocity") - ! Aliased material_phases will also not have a particle_diameter, - ! so here we make sure that we don't count these as the fluid phase - if(.not.aliased(velocity_fluid)) then - istate_fluid = i - if(.not.not_found) then - FLExit("Fluid-particle drag does not currently support more than one fluid phase.") - end if - not_found = .false. - end if + ! Local variables + real, dimension(ele_ngi(u,ele)) :: vfrac_fluid_gi, vfrac_particle_gi + real, dimension(ele_ngi(u,ele)) :: density_fluid_gi, density_particle_gi + real, dimension(u%dim, ele_ngi(u,ele)) :: nu_fluid_gi, nu_particle_gi + real, dimension(u%dim, u%dim, ele_ngi(u,ele)) :: viscosity_fluid_gi + + real, dimension(u%dim, ele_loc(u, ele)) :: oldu_val + + real, dimension(ele_loc(u, ele), ele_ngi(u, ele), x%dim) :: du_t + real, dimension(ele_ngi(u, ele)) :: detwei + real, dimension(u%dim, ele_loc(u,ele)) :: interaction_rhs + real, dimension(ele_loc(u, ele), ele_loc(u, ele)) :: interaction_big_m_mat + real, dimension(u%dim, ele_loc(u,ele)) :: rhs_addto + real, dimension(u%dim, u%dim, ele_loc(u,ele), ele_loc(u,ele)) :: big_m_tensor_addto + + real, dimension(ele_ngi(u,ele)) :: particle_re_gi ! Particle Reynolds number + real, dimension(ele_ngi(u,ele)) :: drag_coefficient_gi + real, dimension(ele_ngi(u,ele)) :: magnitude_gi ! |v_f - v_p| + real, dimension(ele_ngi(u,ele)) :: d_gi ! particle diameter at the Gauss points + + real, dimension(ele_ngi(u,ele)) :: K + real, dimension(ele_ngi(u,ele)) :: drag_force_big_m + real, dimension(u%dim, ele_ngi(u,ele)) :: drag_force_rhs ! drag_force = K*(v_f - v_p) + + integer :: dim, gi + + ! Compute detwei + call transform_to_physical(x, ele, u_shape, dshape=du_t, detwei=detwei) + + ! Get the values of the necessary fields at the Gauss points + vfrac_fluid_gi = ele_val_at_quad(vfrac_fluid, ele) + vfrac_particle_gi = ele_val_at_quad(vfrac_particle, ele) + density_fluid_gi = ele_val_at_quad(density_fluid, ele) + density_particle_gi = ele_val_at_quad(density_particle, ele) + nu_fluid_gi = ele_val_at_quad(nu_fluid, ele) + nu_particle_gi = ele_val_at_quad(nu_particle, ele) + viscosity_fluid_gi = ele_val_at_quad(viscosity_fluid, ele) + + ! Compute the magnitude of the relative velocity + do gi = 1, ele_ngi(u,ele) + magnitude_gi(gi) = norm2(nu_fluid_gi(:,gi) - nu_particle_gi(:,gi)) + end do - end if - end do + ! Compute the particle diameter at the Gauss points + if(have_constant_d) then + d_gi = d else - istate_fluid = istate - not_found = .false. + d_gi = ele_val_at_quad(d_field, ele) end if - if(not_found) then - FLExit("No fluid phase found for the fluid-particle drag.") - end if + ! Cap diameter on the lower side to prevent large drag forces + WHERE (d_gi extract_vector_field(state(istate_fluid), "Velocity") - velocity_particle => extract_vector_field(state(istate_particle), "Velocity") - if(.not.aliased(velocity_particle)) then ! Don't count the aliased material_phases - - vfrac_fluid => extract_scalar_field(state(istate_fluid), "PhaseVolumeFraction") - vfrac_particle => extract_scalar_field(state(istate_particle), "PhaseVolumeFraction") - density_fluid => extract_scalar_field(state(istate_fluid), "Density") - density_particle => extract_scalar_field(state(istate_particle), "Density") - ! Make sure that the molecular viscosity is used. Not the effective viscosity - if(have_option(trim(state(istate_fluid)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then - viscosity_fluid => extract_tensor_field(state(istate_fluid),"BackgroundViscosity") - else - viscosity_fluid => extract_tensor_field(state(istate_fluid), "Viscosity") - end if - if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter")) then - call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter", d) - have_constant_d = .true. - else if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter_use_scalar_field")) then - call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter_use_scalar_field", d_field_name) - d_field => extract_scalar_field(state(istate_particle), d_field_name) - have_constant_d = .false. - end if + case(DRAG_CORRELATION_TYPE_ERGUN) + ! No drag coefficient is needed here. - call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/apply_diameter_cap/lower_cap", d_cap_lower, default = 1.0e-12) - - ! Calculate the non-linear approximation to the PhaseVolumeFractions - call allocate(nvfrac_fluid, vfrac_fluid%mesh, "NonlinearPhaseVolumeFraction") - call allocate(nvfrac_particle, vfrac_particle%mesh, "NonlinearPhaseVolumeFraction") - call zero(nvfrac_fluid) - call zero(nvfrac_particle) - call get_nonlinear_volume_fraction(state(istate_fluid), nvfrac_fluid) - call get_nonlinear_volume_fraction(state(istate_particle), nvfrac_particle) - - ! Get the non-linear approximation to the Velocities - nu_fluid => extract_vector_field(state(istate_fluid), "NonlinearVelocity") - nu_particle => extract_vector_field(state(istate_particle), "NonlinearVelocity") - oldu_fluid => extract_vector_field(state(istate_fluid), "OldVelocity") - oldu_particle => extract_vector_field(state(istate_particle), "OldVelocity") - - call get_option("/multiphase_interaction/fluid_particle_drag/drag_correlation/name", drag_correlation_name) - select case(trim(drag_correlation_name)) - case("stokes") - drag_correlation = DRAG_CORRELATION_TYPE_STOKES - case("wen_yu") - drag_correlation = DRAG_CORRELATION_TYPE_WEN_YU - case("ergun") - drag_correlation = DRAG_CORRELATION_TYPE_ERGUN - case("schiller_naumann") - drag_correlation = DRAG_CORRELATION_TYPE_SCHILLER_NAUMANN - case("lain_1_1999") - drag_correlation = DRAG_CORRELATION_TYPE_LAIN_1_1999 - case("lain_2_2002") - drag_correlation = DRAG_CORRELATION_TYPE_LAIN_2_2002 - case default - FLAbort("Unknown correlation for fluid-particle drag") - end select - - ! ----- Volume integrals over elements ------------- - call profiler_tic(u, "element_loop") - element_loop: do ele = 1, element_count(u) - - if(.not.dg .or. (dg .and. element_owned(u,ele))) then - u_nodes => ele_nodes(u, ele) - u_shape => ele_shape(u, ele) - test_function = u_shape - - call add_fluid_particle_drag_element(ele, test_function, u_shape, & - x, u, big_m, mom_rhs, & - nvfrac_fluid, nvfrac_particle, & - density_fluid, density_particle, & - nu_fluid, nu_particle, & - oldu_fluid, oldu_particle, & - viscosity_fluid, & - have_constant_d, d, d_field, d_cap_lower, & - drag_correlation) - end if - - end do element_loop - call profiler_toc(u, "element_loop") - - call deallocate(nvfrac_fluid) - call deallocate(nvfrac_particle) + case(DRAG_CORRELATION_TYPE_SCHILLER_NAUMANN) + ! Schiller & Naumann (1933) drag correlation, also same as the one implemented in Fluent + ! Since the particle Reynolds number definition currently contains vfrac_fluid in numerator, + ! we need to take that out by dividing as done below. + do gi = 1, ele_ngi(u,ele) + if((particle_re_gi(gi)/vfrac_fluid_gi(gi)) < 1000) then + drag_coefficient_gi(gi) = (24.0/(particle_re_gi(gi)/vfrac_fluid_gi(gi)))*(1.0+0.15*(particle_re_gi(gi)/vfrac_fluid_gi(gi))**0.687) + else + drag_coefficient_gi(gi) = 0.44 end if - - end subroutine assemble_fluid_particle_drag - - subroutine add_fluid_particle_drag_element(ele, test_function, u_shape, & - x, u, big_m, mom_rhs, & - vfrac_fluid, vfrac_particle, & - density_fluid, density_particle, & - nu_fluid, nu_particle, & - oldu_fluid, oldu_particle, & - viscosity_fluid, & - have_constant_d, d, d_field, d_cap_lower, & - drag_correlation) - - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(element_type), intent(in) :: u_shape - type(vector_field), intent(in) :: u, x - type(petsc_csr_matrix), intent(inout) :: big_m - type(vector_field), intent(inout) :: mom_rhs - - type(scalar_field), intent(in) :: vfrac_fluid, vfrac_particle - type(scalar_field), intent(in) :: density_fluid, density_particle - type(scalar_field), pointer, intent(in) :: d_field ! Scalar field representing particle diameter - type(vector_field), intent(in) :: nu_fluid, nu_particle - type(vector_field), intent(in) :: oldu_fluid, oldu_particle - type(tensor_field), intent(in) :: viscosity_fluid - real, intent(in) :: d ! Constant particle diameter - real, intent(in) :: d_cap_lower - integer, intent(in) :: drag_correlation - logical, intent(in) :: have_constant_d ! is true if particle diameter is a constant. is false if it is a scalar field (e.g. sauter mean dia) - - ! Local variables - real, dimension(ele_ngi(u,ele)) :: vfrac_fluid_gi, vfrac_particle_gi - real, dimension(ele_ngi(u,ele)) :: density_fluid_gi, density_particle_gi - real, dimension(u%dim, ele_ngi(u,ele)) :: nu_fluid_gi, nu_particle_gi - real, dimension(u%dim, u%dim, ele_ngi(u,ele)) :: viscosity_fluid_gi - - real, dimension(u%dim, ele_loc(u, ele)) :: oldu_val - - real, dimension(ele_loc(u, ele), ele_ngi(u, ele), x%dim) :: du_t - real, dimension(ele_ngi(u, ele)) :: detwei - real, dimension(u%dim, ele_loc(u,ele)) :: interaction_rhs - real, dimension(ele_loc(u, ele), ele_loc(u, ele)) :: interaction_big_m_mat - real, dimension(u%dim, ele_loc(u,ele)) :: rhs_addto - real, dimension(u%dim, u%dim, ele_loc(u,ele), ele_loc(u,ele)) :: big_m_tensor_addto - - real, dimension(ele_ngi(u,ele)) :: particle_re_gi ! Particle Reynolds number - real, dimension(ele_ngi(u,ele)) :: drag_coefficient_gi - real, dimension(ele_ngi(u,ele)) :: magnitude_gi ! |v_f - v_p| - real, dimension(ele_ngi(u,ele)) :: d_gi ! particle diameter at the Gauss points - - real, dimension(ele_ngi(u,ele)) :: K - real, dimension(ele_ngi(u,ele)) :: drag_force_big_m - real, dimension(u%dim, ele_ngi(u,ele)) :: drag_force_rhs ! drag_force = K*(v_f - v_p) - - integer :: dim, gi - - ! Compute detwei - call transform_to_physical(x, ele, u_shape, dshape=du_t, detwei=detwei) - - ! Get the values of the necessary fields at the Gauss points - vfrac_fluid_gi = ele_val_at_quad(vfrac_fluid, ele) - vfrac_particle_gi = ele_val_at_quad(vfrac_particle, ele) - density_fluid_gi = ele_val_at_quad(density_fluid, ele) - density_particle_gi = ele_val_at_quad(density_particle, ele) - nu_fluid_gi = ele_val_at_quad(nu_fluid, ele) - nu_particle_gi = ele_val_at_quad(nu_particle, ele) - viscosity_fluid_gi = ele_val_at_quad(viscosity_fluid, ele) - - ! Compute the magnitude of the relative velocity - do gi = 1, ele_ngi(u,ele) - magnitude_gi(gi) = norm2(nu_fluid_gi(:,gi) - nu_particle_gi(:,gi)) - end do - - ! Compute the particle diameter at the Gauss points - if(have_constant_d) then - d_gi = d + end do + case(DRAG_CORRELATION_TYPE_LAIN_1_1999) + ! Lain 1999 - Rigid Bubble + do gi = 1, ele_ngi(u,ele) + if((particle_re_gi(gi)/vfrac_fluid_gi(gi)) < 500) then + drag_coefficient_gi(gi) = (24.0/(particle_re_gi(gi)/vfrac_fluid_gi(gi)))*(1.0+0.15*(particle_re_gi(gi)/vfrac_fluid_gi(gi))**0.687) + else if ((particle_re_gi(gi)/vfrac_fluid_gi(gi)) < 1500) then + drag_coefficient_gi(gi) = 9.5E-5 * (particle_re_gi(gi)/vfrac_fluid_gi(gi))**1.397 else - d_gi = ele_val_at_quad(d_field, ele) + drag_coefficient_gi(gi) = 2.61 end if - - ! Cap diameter on the lower side to prevent large drag forces - WHERE (d_gi extract_vector_field(state(istate), "Coordinate") - ewrite_minmax(x) - assert(x%dim == mesh_dim(internal_energy)) - assert(ele_count(x) == ele_count(internal_energy)) - ! Are we using a discontinuous Galerkin discretisation? - dg = continuity(internal_energy) < 0 + ewrite(1, *) "Entering add_heat_transfer" - ! Is this phase a particle phase? - is_particle_phase = have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field") + ! Get the timestepping options + call get_option("/timestepping/timestep", dt) + call get_option(trim(internal_energy%option_path)//"/prognostic/temporal_discretisation/theta", & + theta) - ! Retrieve the index of the fluid phase in the state array. - not_found = .true. - if(is_particle_phase) then - do i = 1, size(state) - if(.not.(have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field"))) then - - velocity_fluid => extract_vector_field(state(i), "Velocity") - ! Aliased material_phases will also not have a particle_diameter, - ! so here we make sure that we don't count these as the fluid phase - if(.not.aliased(velocity_fluid)) then - istate_fluid = i - if(.not.not_found) then - FLExit("Heat transfer term does not currently support more than one fluid phase.") - end if - not_found = .false. - end if + ! Get the coordinate field from state(istate) + x => extract_vector_field(state(istate), "Coordinate") + ewrite_minmax(x) + assert(x%dim == mesh_dim(internal_energy)) + assert(ele_count(x) == ele_count(internal_energy)) - end if - end do - else - istate_fluid = istate - not_found = .false. - end if + ! Are we using a discontinuous Galerkin discretisation? + dg = continuity(internal_energy) < 0 - if(not_found) then - FLExit("No fluid phase found for the heat transfer term.") - end if + ! Is this phase a particle phase? + is_particle_phase = have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(istate)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field") - ! If we have a fluid-particle pair, then assemble the heat transfer term - if(is_particle_phase) then - call assemble_heat_transfer(istate_fluid, istate) - else - state_loop: do i = 1, size(state) - if(i /= istate_fluid) then - call assemble_heat_transfer(istate_fluid, i) + ! Retrieve the index of the fluid phase in the state array. + not_found = .true. + if(is_particle_phase) then + do i = 1, size(state) + if(.not.(have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_diameter") .or. have_option(trim(state(i)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field"))) then + + velocity_fluid => extract_vector_field(state(i), "Velocity") + ! Aliased material_phases will also not have a particle_diameter, + ! so here we make sure that we don't count these as the fluid phase + if(.not.aliased(velocity_fluid)) then + istate_fluid = i + if(.not.not_found) then + FLExit("Heat transfer term does not currently support more than one fluid phase.") + end if + not_found = .false. end if - end do state_loop - end if - ewrite(1, *) "Exiting add_heat_transfer" - - contains - - subroutine assemble_heat_transfer(istate_fluid, istate_particle) - - integer, intent(in) :: istate_fluid, istate_particle - - type(scalar_field), pointer :: vfrac_fluid, vfrac_particle - type(scalar_field), pointer :: density_fluid, density_particle - type(scalar_field), pointer :: d_field ! scalar field defining particle diameter - type(vector_field), pointer :: velocity_fluid, velocity_particle - type(scalar_field), pointer :: internal_energy_fluid, internal_energy_particle - type(scalar_field), pointer :: old_internal_energy_fluid, old_internal_energy_particle - type(vector_field), pointer :: nu_fluid, nu_particle ! Non-linear approximation to the Velocities - type(tensor_field), pointer :: viscosity_fluid - type(scalar_field) :: nvfrac_fluid, nvfrac_particle - real :: d ! Particle diameter - real :: k ! Effective gas conductivity - real :: C_fluid, C_particle ! Specific heat of the fluid and particle phases at constant volume - real :: gamma ! Ratio of specific heats for compressible phase - integer :: kstat, cstat_fluid, cstat_particle, gstat - character(len=OPTION_PATH_LEN) :: d_field_name ! name of scalar field that defines particle diameter (can be the sauter mean dia) - logical :: have_constant_d ! checks if the particle diameter is a constant or not - - ! Get the necessary fields to calculate the heat transfer term - velocity_fluid => extract_vector_field(state(istate_fluid), "Velocity") - velocity_particle => extract_vector_field(state(istate_particle), "Velocity") - if(.not.aliased(velocity_particle)) then ! Don't count the aliased material_phases - - vfrac_fluid => extract_scalar_field(state(istate_fluid), "PhaseVolumeFraction") - vfrac_particle => extract_scalar_field(state(istate_particle), "PhaseVolumeFraction") - density_fluid => extract_scalar_field(state(istate_fluid), "Density") - density_particle => extract_scalar_field(state(istate_particle), "Density") - viscosity_fluid => extract_tensor_field(state(istate_fluid), "Viscosity") - - if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter")) then - call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter", d) - have_constant_d = .true. - else if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field")) then - call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field", d_field_name) - d_field => extract_scalar_field(state(istate_particle), d_field_name) - have_constant_d = .false. - end if + end if + end do + else + istate_fluid = istate + not_found = .false. + end if + + if(not_found) then + FLExit("No fluid phase found for the heat transfer term.") + end if + + ! If we have a fluid-particle pair, then assemble the heat transfer term + if(is_particle_phase) then + call assemble_heat_transfer(istate_fluid, istate) + else + state_loop: do i = 1, size(state) + if(i /= istate_fluid) then + call assemble_heat_transfer(istate_fluid, i) + end if + end do state_loop + end if - call get_option(trim(state(istate_fluid)%option_path)//"/multiphase_properties/effective_conductivity", k, kstat) + ewrite(1, *) "Exiting add_heat_transfer" - call get_option(trim(state(istate_fluid)%option_path)//"/multiphase_properties/specific_heat", C_fluid, cstat_fluid) + contains - call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/specific_heat", C_particle, cstat_particle) + subroutine assemble_heat_transfer(istate_fluid, istate_particle) + + integer, intent(in) :: istate_fluid, istate_particle + + type(scalar_field), pointer :: vfrac_fluid, vfrac_particle + type(scalar_field), pointer :: density_fluid, density_particle + type(scalar_field), pointer :: d_field ! scalar field defining particle diameter + type(vector_field), pointer :: velocity_fluid, velocity_particle + type(scalar_field), pointer :: internal_energy_fluid, internal_energy_particle + type(scalar_field), pointer :: old_internal_energy_fluid, old_internal_energy_particle + type(vector_field), pointer :: nu_fluid, nu_particle ! Non-linear approximation to the Velocities + type(tensor_field), pointer :: viscosity_fluid + type(scalar_field) :: nvfrac_fluid, nvfrac_particle + real :: d ! Particle diameter + real :: k ! Effective gas conductivity + real :: C_fluid, C_particle ! Specific heat of the fluid and particle phases at constant volume + real :: gamma ! Ratio of specific heats for compressible phase + integer :: kstat, cstat_fluid, cstat_particle, gstat + character(len=OPTION_PATH_LEN) :: d_field_name ! name of scalar field that defines particle diameter (can be the sauter mean dia) + logical :: have_constant_d ! checks if the particle diameter is a constant or not + + ! Get the necessary fields to calculate the heat transfer term + velocity_fluid => extract_vector_field(state(istate_fluid), "Velocity") + velocity_particle => extract_vector_field(state(istate_particle), "Velocity") + if(.not.aliased(velocity_particle)) then ! Don't count the aliased material_phases + + vfrac_fluid => extract_scalar_field(state(istate_fluid), "PhaseVolumeFraction") + vfrac_particle => extract_scalar_field(state(istate_particle), "PhaseVolumeFraction") + density_fluid => extract_scalar_field(state(istate_fluid), "Density") + density_particle => extract_scalar_field(state(istate_particle), "Density") + viscosity_fluid => extract_tensor_field(state(istate_fluid), "Viscosity") + + if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter")) then + call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_diameter", d) + have_constant_d = .true. + else if(have_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field")) then + call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/particle_dia_use_scalar_field", d_field_name) + d_field => extract_scalar_field(state(istate_particle), d_field_name) + have_constant_d = .false. + end if - call get_option(trim(state(istate_fluid)%option_path)//"/equation_of_state/compressible/stiffened_gas/ratio_specific_heats", gamma, gstat) + call get_option(trim(state(istate_fluid)%option_path)//"/multiphase_properties/effective_conductivity", k, kstat) - if(kstat /= 0) then - FLExit("For inter-phase heat transfer, an effective_conductivity needs to be specified for the fluid phase.") - end if - if(cstat_fluid /= 0 .or. cstat_particle /= 0) then - FLExit("For inter-phase heat transfer, a specific_heat needs to be specified for each phase.") - end if - if(gstat /= 0) then - FLExit("For inter-phase heat transfer, ratio_specific_heats needs to be specified for the compressible phase.") - end if + call get_option(trim(state(istate_fluid)%option_path)//"/multiphase_properties/specific_heat", C_fluid, cstat_fluid) - ! Calculate the non-linear approximation to the PhaseVolumeFractions - call allocate(nvfrac_fluid, vfrac_fluid%mesh, "NonlinearPhaseVolumeFraction") - call allocate(nvfrac_particle, vfrac_particle%mesh, "NonlinearPhaseVolumeFraction") - call zero(nvfrac_fluid) - call zero(nvfrac_particle) - call get_nonlinear_volume_fraction(state(istate_fluid), nvfrac_fluid) - call get_nonlinear_volume_fraction(state(istate_particle), nvfrac_particle) - - ! Get the non-linear approximation to the Velocities - nu_fluid => extract_vector_field(state(istate_fluid), "NonlinearVelocity") - nu_particle => extract_vector_field(state(istate_particle), "NonlinearVelocity") - - ! Get the current and old internal energy fields - internal_energy_fluid => extract_scalar_field(state(istate_fluid), "InternalEnergy") - internal_energy_particle => extract_scalar_field(state(istate_particle), "InternalEnergy") - old_internal_energy_fluid => extract_scalar_field(state(istate_fluid), "OldInternalEnergy") - old_internal_energy_particle => extract_scalar_field(state(istate_particle), "OldInternalEnergy") - - ! ----- Volume integrals over elements ------------- - call profiler_tic(internal_energy, "element_loop") - element_loop: do ele = 1, element_count(internal_energy) - - if(.not.dg .or. (dg .and. element_owned(internal_energy,ele))) then - internal_energy_nodes => ele_nodes(internal_energy, ele) - internal_energy_shape => ele_shape(internal_energy, ele) - test_function = internal_energy_shape - - call add_heat_transfer_element(ele, test_function, internal_energy_shape, & - x, internal_energy, matrix, rhs, & - nvfrac_fluid, nvfrac_particle, & - density_fluid, density_particle, & - nu_fluid, nu_particle, & - internal_energy_fluid, & - internal_energy_particle, & - old_internal_energy_fluid, & - old_internal_energy_particle, & - viscosity_fluid, & - have_constant_d, d, d_field, & - k, C_fluid, & - C_particle, gamma) - end if - - end do element_loop - call profiler_toc(internal_energy, "element_loop") - - call deallocate(nvfrac_fluid) - call deallocate(nvfrac_particle) - end if + call get_option(trim(state(istate_particle)%option_path)//"/multiphase_properties/specific_heat", C_particle, cstat_particle) - end subroutine assemble_heat_transfer - - subroutine add_heat_transfer_element(ele, test_function, internal_energy_shape, & - x, internal_energy, matrix, rhs, & - vfrac_fluid, vfrac_particle, & - density_fluid, density_particle, & - nu_fluid, nu_particle, & - internal_energy_fluid, & - internal_energy_particle, & - old_internal_energy_fluid, & - old_internal_energy_particle, & - viscosity_fluid, & - have_constant_d, d, d_field, & - k, C_fluid, & - C_particle, gamma) - - integer, intent(in) :: ele - type(element_type), intent(in) :: test_function - type(element_type), intent(in) :: internal_energy_shape - type(vector_field), intent(in) :: x - type(scalar_field), intent(in) :: internal_energy - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - - type(scalar_field), intent(in) :: vfrac_fluid, vfrac_particle - type(scalar_field), intent(in) :: density_fluid, density_particle - type(scalar_field), pointer, intent(in) :: d_field ! Scalar field representing particle diameter - type(vector_field), intent(in) :: nu_fluid, nu_particle - type(scalar_field), intent(in) :: internal_energy_fluid, internal_energy_particle - type(scalar_field), intent(in) :: old_internal_energy_fluid, old_internal_energy_particle - type(tensor_field), intent(in) :: viscosity_fluid - real, intent(in) :: d ! Constant particle diameter - real, intent(in) :: k, C_fluid, C_particle, gamma - logical, intent(in) :: have_constant_d ! is true if particle diameter is a constant. is false if it is a scalar field (e.g. sauter mean dia) - - ! Local variables - real, dimension(ele_ngi(x,ele)) :: internal_energy_fluid_gi, internal_energy_particle_gi - real, dimension(ele_ngi(x,ele)) :: vfrac_fluid_gi, vfrac_particle_gi - real, dimension(ele_ngi(x,ele)) :: density_fluid_gi, density_particle_gi - real, dimension(x%dim, ele_ngi(x,ele)) :: nu_fluid_gi, nu_particle_gi - real, dimension(x%dim, x%dim, ele_ngi(x,ele)) :: viscosity_fluid_gi - - real, dimension(ele_loc(internal_energy,ele)) :: old_internal_energy_val - - real, dimension(ele_ngi(x,ele)) :: detwei - real, dimension(ele_ngi(x,ele)) :: coefficient_for_matrix, coefficient_for_rhs - real, dimension(ele_loc(internal_energy,ele)) :: rhs_addto - real, dimension(ele_loc(internal_energy,ele), ele_loc(internal_energy,ele)) :: matrix_addto - - real, dimension(ele_ngi(x,ele)) :: d_gi ! particle diameter at quadrature points - real, dimension(ele_ngi(x,ele)) :: particle_Re ! Particle Reynolds number - real, dimension(ele_ngi(x,ele)) :: Pr ! Prandtl number - real, dimension(ele_ngi(x,ele)) :: particle_Nu ! Particle Nusselt number - real, dimension(ele_ngi(x,ele)) :: velocity_magnitude ! |v_f - v_p| - - real, dimension(ele_ngi(x,ele)) :: Q ! heat transfer term = Q*(T_p - T_f) - real, dimension(ele_loc(internal_energy,ele), ele_loc(internal_energy,ele)) :: heat_transfer_matrix - real, dimension(ele_loc(internal_energy,ele)) :: heat_transfer_rhs - - integer :: gi - - ! Compute detwei - call transform_to_physical(x, ele, detwei) - - ! Get the values of the necessary fields at the Gauss points - vfrac_fluid_gi = ele_val_at_quad(vfrac_fluid, ele) - vfrac_particle_gi = ele_val_at_quad(vfrac_particle, ele) - density_fluid_gi = ele_val_at_quad(density_fluid, ele) - density_particle_gi = ele_val_at_quad(density_particle, ele) - nu_fluid_gi = ele_val_at_quad(nu_fluid, ele) - nu_particle_gi = ele_val_at_quad(nu_particle, ele) - viscosity_fluid_gi = ele_val_at_quad(viscosity_fluid, ele) - internal_energy_fluid_gi = ele_val_at_quad(internal_energy_fluid, ele) - internal_energy_particle_gi = ele_val_at_quad(internal_energy_particle, ele) - - ! Compute the magnitude of the relative velocity - do gi = 1, ele_ngi(x,ele) - velocity_magnitude(gi) = norm2(nu_fluid_gi(:,gi) - nu_particle_gi(:,gi)) - end do - - ! Compute the particle diameter at quadrature points - if(have_constant_d) then - d_gi = d - else - d_gi = ele_val_at_quad(d_field, ele) + call get_option(trim(state(istate_fluid)%option_path)//"/equation_of_state/compressible/stiffened_gas/ratio_specific_heats", gamma, gstat) + + if(kstat /= 0) then + FLExit("For inter-phase heat transfer, an effective_conductivity needs to be specified for the fluid phase.") + end if + if(cstat_fluid /= 0 .or. cstat_particle /= 0) then + FLExit("For inter-phase heat transfer, a specific_heat needs to be specified for each phase.") + end if + if(gstat /= 0) then + FLExit("For inter-phase heat transfer, ratio_specific_heats needs to be specified for the compressible phase.") + end if + + ! Calculate the non-linear approximation to the PhaseVolumeFractions + call allocate(nvfrac_fluid, vfrac_fluid%mesh, "NonlinearPhaseVolumeFraction") + call allocate(nvfrac_particle, vfrac_particle%mesh, "NonlinearPhaseVolumeFraction") + call zero(nvfrac_fluid) + call zero(nvfrac_particle) + call get_nonlinear_volume_fraction(state(istate_fluid), nvfrac_fluid) + call get_nonlinear_volume_fraction(state(istate_particle), nvfrac_particle) + + ! Get the non-linear approximation to the Velocities + nu_fluid => extract_vector_field(state(istate_fluid), "NonlinearVelocity") + nu_particle => extract_vector_field(state(istate_particle), "NonlinearVelocity") + + ! Get the current and old internal energy fields + internal_energy_fluid => extract_scalar_field(state(istate_fluid), "InternalEnergy") + internal_energy_particle => extract_scalar_field(state(istate_particle), "InternalEnergy") + old_internal_energy_fluid => extract_scalar_field(state(istate_fluid), "OldInternalEnergy") + old_internal_energy_particle => extract_scalar_field(state(istate_particle), "OldInternalEnergy") + + ! ----- Volume integrals over elements ------------- + call profiler_tic(internal_energy, "element_loop") + element_loop: do ele = 1, element_count(internal_energy) + + if(.not.dg .or. (dg .and. element_owned(internal_energy,ele))) then + internal_energy_nodes => ele_nodes(internal_energy, ele) + internal_energy_shape => ele_shape(internal_energy, ele) + test_function = internal_energy_shape + + call add_heat_transfer_element(ele, test_function, internal_energy_shape, & + x, internal_energy, matrix, rhs, & + nvfrac_fluid, nvfrac_particle, & + density_fluid, density_particle, & + nu_fluid, nu_particle, & + internal_energy_fluid, & + internal_energy_particle, & + old_internal_energy_fluid, & + old_internal_energy_particle, & + viscosity_fluid, & + have_constant_d, d, d_field, & + k, C_fluid, & + C_particle, gamma) end if - ! Compute the particle Reynolds number - ! (Assumes isotropic viscosity for now) - particle_Re = (density_fluid_gi*velocity_magnitude*d_gi) / viscosity_fluid_gi(1,1,:) + end do element_loop + call profiler_toc(internal_energy, "element_loop") - ! Compute the Prandtl number - ! (Assumes isotropic viscosity for now) - ! Note: C_fluid (at constant volume) multiplied by gamma = C_fluid at constant pressure - Pr = C_fluid*gamma*viscosity_fluid_gi(1,1,:)/k + call deallocate(nvfrac_fluid) + call deallocate(nvfrac_particle) + end if - particle_Nu = (7.0 - 10.0*vfrac_fluid_gi + 5.0*vfrac_fluid_gi**2)*(1.0 + 0.7*(particle_Re**0.2)*(Pr**(1.0/3.0))) + & - (1.33 - 2.4*vfrac_fluid_gi + 1.2*vfrac_fluid_gi**2)*(particle_Re**0.7)*(Pr**(1.0/3.0)) + end subroutine assemble_heat_transfer + + subroutine add_heat_transfer_element(ele, test_function, internal_energy_shape, & + x, internal_energy, matrix, rhs, & + vfrac_fluid, vfrac_particle, & + density_fluid, density_particle, & + nu_fluid, nu_particle, & + internal_energy_fluid, & + internal_energy_particle, & + old_internal_energy_fluid, & + old_internal_energy_particle, & + viscosity_fluid, & + have_constant_d, d, d_field, & + k, C_fluid, & + C_particle, gamma) + + integer, intent(in) :: ele + type(element_type), intent(in) :: test_function + type(element_type), intent(in) :: internal_energy_shape + type(vector_field), intent(in) :: x + type(scalar_field), intent(in) :: internal_energy + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs - Q = (6.0*k*vfrac_particle_gi*particle_Nu)/(d_gi**2) + type(scalar_field), intent(in) :: vfrac_fluid, vfrac_particle + type(scalar_field), intent(in) :: density_fluid, density_particle + type(scalar_field), pointer, intent(in) :: d_field ! Scalar field representing particle diameter + type(vector_field), intent(in) :: nu_fluid, nu_particle + type(scalar_field), intent(in) :: internal_energy_fluid, internal_energy_particle + type(scalar_field), intent(in) :: old_internal_energy_fluid, old_internal_energy_particle + type(tensor_field), intent(in) :: viscosity_fluid + real, intent(in) :: d ! Constant particle diameter + real, intent(in) :: k, C_fluid, C_particle, gamma + logical, intent(in) :: have_constant_d ! is true if particle diameter is a constant. is false if it is a scalar field (e.g. sauter mean dia) - ! Note that the transfer term is defined in terms of temperatures (T_fluid and T_particle) - ! Let's convert the temperatures to internal energy (E) using E_i = C_i*T_i, - ! where C is the specific heat of phase i at constant volume. - if(is_particle_phase) then - coefficient_for_matrix = -Q/C_particle - coefficient_for_rhs = -Q*(-internal_energy_fluid_gi/C_fluid) - else - coefficient_for_matrix = -Q/C_fluid - coefficient_for_rhs = Q*(internal_energy_particle_gi/C_particle) - end if + ! Local variables + real, dimension(ele_ngi(x,ele)) :: internal_energy_fluid_gi, internal_energy_particle_gi + real, dimension(ele_ngi(x,ele)) :: vfrac_fluid_gi, vfrac_particle_gi + real, dimension(ele_ngi(x,ele)) :: density_fluid_gi, density_particle_gi + real, dimension(x%dim, ele_ngi(x,ele)) :: nu_fluid_gi, nu_particle_gi + real, dimension(x%dim, x%dim, ele_ngi(x,ele)) :: viscosity_fluid_gi + + real, dimension(ele_loc(internal_energy,ele)) :: old_internal_energy_val + + real, dimension(ele_ngi(x,ele)) :: detwei + real, dimension(ele_ngi(x,ele)) :: coefficient_for_matrix, coefficient_for_rhs + real, dimension(ele_loc(internal_energy,ele)) :: rhs_addto + real, dimension(ele_loc(internal_energy,ele), ele_loc(internal_energy,ele)) :: matrix_addto + + real, dimension(ele_ngi(x,ele)) :: d_gi ! particle diameter at quadrature points + real, dimension(ele_ngi(x,ele)) :: particle_Re ! Particle Reynolds number + real, dimension(ele_ngi(x,ele)) :: Pr ! Prandtl number + real, dimension(ele_ngi(x,ele)) :: particle_Nu ! Particle Nusselt number + real, dimension(ele_ngi(x,ele)) :: velocity_magnitude ! |v_f - v_p| + + real, dimension(ele_ngi(x,ele)) :: Q ! heat transfer term = Q*(T_p - T_f) + real, dimension(ele_loc(internal_energy,ele), ele_loc(internal_energy,ele)) :: heat_transfer_matrix + real, dimension(ele_loc(internal_energy,ele)) :: heat_transfer_rhs + + integer :: gi + + ! Compute detwei + call transform_to_physical(x, ele, detwei) + + ! Get the values of the necessary fields at the Gauss points + vfrac_fluid_gi = ele_val_at_quad(vfrac_fluid, ele) + vfrac_particle_gi = ele_val_at_quad(vfrac_particle, ele) + density_fluid_gi = ele_val_at_quad(density_fluid, ele) + density_particle_gi = ele_val_at_quad(density_particle, ele) + nu_fluid_gi = ele_val_at_quad(nu_fluid, ele) + nu_particle_gi = ele_val_at_quad(nu_particle, ele) + viscosity_fluid_gi = ele_val_at_quad(viscosity_fluid, ele) + internal_energy_fluid_gi = ele_val_at_quad(internal_energy_fluid, ele) + internal_energy_particle_gi = ele_val_at_quad(internal_energy_particle, ele) + + ! Compute the magnitude of the relative velocity + do gi = 1, ele_ngi(x,ele) + velocity_magnitude(gi) = norm2(nu_fluid_gi(:,gi) - nu_particle_gi(:,gi)) + end do + + ! Compute the particle diameter at quadrature points + if(have_constant_d) then + d_gi = d + else + d_gi = ele_val_at_quad(d_field, ele) + end if - ! Form the element heat transfer matrix and RHS - heat_transfer_matrix = shape_shape(test_function, internal_energy_shape, detwei*coefficient_for_matrix) - heat_transfer_rhs = shape_rhs(test_function, coefficient_for_rhs*detwei) + ! Compute the particle Reynolds number + ! (Assumes isotropic viscosity for now) + particle_Re = (density_fluid_gi*velocity_magnitude*d_gi) / viscosity_fluid_gi(1,1,:) - ! Add contribution - matrix_addto = 0.0 - rhs_addto = 0.0 - if(is_particle_phase) then - old_internal_energy_val = ele_val(old_internal_energy_particle, ele) - else - old_internal_energy_val = ele_val(old_internal_energy_fluid, ele) - end if + ! Compute the Prandtl number + ! (Assumes isotropic viscosity for now) + ! Note: C_fluid (at constant volume) multiplied by gamma = C_fluid at constant pressure + Pr = C_fluid*gamma*viscosity_fluid_gi(1,1,:)/k + + particle_Nu = (7.0 - 10.0*vfrac_fluid_gi + 5.0*vfrac_fluid_gi**2)*(1.0 + 0.7*(particle_Re**0.2)*(Pr**(1.0/3.0))) + & + (1.33 - 2.4*vfrac_fluid_gi + 1.2*vfrac_fluid_gi**2)*(particle_Re**0.7)*(Pr**(1.0/3.0)) + + Q = (6.0*k*vfrac_particle_gi*particle_Nu)/(d_gi**2) + + ! Note that the transfer term is defined in terms of temperatures (T_fluid and T_particle) + ! Let's convert the temperatures to internal energy (E) using E_i = C_i*T_i, + ! where C is the specific heat of phase i at constant volume. + if(is_particle_phase) then + coefficient_for_matrix = -Q/C_particle + coefficient_for_rhs = -Q*(-internal_energy_fluid_gi/C_fluid) + else + coefficient_for_matrix = -Q/C_fluid + coefficient_for_rhs = Q*(internal_energy_particle_gi/C_particle) + end if + + ! Form the element heat transfer matrix and RHS + heat_transfer_matrix = shape_shape(test_function, internal_energy_shape, detwei*coefficient_for_matrix) + heat_transfer_rhs = shape_rhs(test_function, coefficient_for_rhs*detwei) + + ! Add contribution + matrix_addto = 0.0 + rhs_addto = 0.0 + if(is_particle_phase) then + old_internal_energy_val = ele_val(old_internal_energy_particle, ele) + else + old_internal_energy_val = ele_val(old_internal_energy_fluid, ele) + end if - matrix_addto = matrix_addto - dt*theta*heat_transfer_matrix - rhs_addto = rhs_addto + matmul(heat_transfer_matrix, old_internal_energy_val) + heat_transfer_rhs + matrix_addto = matrix_addto - dt*theta*heat_transfer_matrix + rhs_addto = rhs_addto + matmul(heat_transfer_matrix, old_internal_energy_val) + heat_transfer_rhs - ! Add to the internal energy equation's RHS - call addto(rhs, internal_energy_nodes, rhs_addto) - ! Add to the matrix - call addto(matrix, internal_energy_nodes, internal_energy_nodes, matrix_addto) + ! Add to the internal energy equation's RHS + call addto(rhs, internal_energy_nodes, rhs_addto) + ! Add to the matrix + call addto(matrix, internal_energy_nodes, internal_energy_nodes, matrix_addto) - end subroutine add_heat_transfer_element + end subroutine add_heat_transfer_element - end subroutine add_heat_transfer + end subroutine add_heat_transfer - end module multiphase_module +end module multiphase_module diff --git a/assemble/Node_Locking.F90 b/assemble/Node_Locking.F90 index 71fe8103c9..bc0b6749ae 100644 --- a/assemble/Node_Locking.F90 +++ b/assemble/Node_Locking.F90 @@ -29,73 +29,73 @@ module node_locking - use fldebug - use global_parameters, only : PYTHON_FUNC_LEN - use embed_python - use spud - use fields + use fldebug + use global_parameters, only : PYTHON_FUNC_LEN + use embed_python + use spud + use fields - implicit none + implicit none - private + private - public :: get_locked_nodes + public :: get_locked_nodes contains - subroutine get_locked_nodes(positions, locked_nodes, current_time) - !!< Return an array of nodes to be locked in mesh adaptivity. locked_nodes - !!< is allocated by this routine. + subroutine get_locked_nodes(positions, locked_nodes, current_time) + !!< Return an array of nodes to be locked in mesh adaptivity. locked_nodes + !!< is allocated by this routine. - type(vector_field), intent(in) :: positions - integer, dimension(:), allocatable, intent(out) :: locked_nodes - real, optional, intent(in) :: current_time + type(vector_field), intent(in) :: positions + integer, dimension(:), allocatable, intent(out) :: locked_nodes + real, optional, intent(in) :: current_time - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity/node_locking" - character(len = PYTHON_FUNC_LEN) :: func - integer :: i, index, stat - integer, dimension(:), allocatable :: is_node_locked - real :: lcurrent_time + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity/node_locking" + character(len = PYTHON_FUNC_LEN) :: func + integer :: i, index, stat + integer, dimension(:), allocatable :: is_node_locked + real :: lcurrent_time - if(.not. have_option(base_path)) then - allocate(locked_nodes(0)) - ewrite(2, *) "Number of locked nodes = 0" - return - end if + if(.not. have_option(base_path)) then + allocate(locked_nodes(0)) + ewrite(2, *) "Number of locked nodes = 0" + return + end if - if(present(current_time)) then - lcurrent_time = current_time - else - call get_option("/timestepping/current_time", lcurrent_time, default = 0.0) - end if + if(present(current_time)) then + lcurrent_time = current_time + else + call get_option("/timestepping/current_time", lcurrent_time, default = 0.0) + end if - call get_option(base_path // "/python", func) + call get_option(base_path // "/python", func) - allocate(is_node_locked(node_count(positions))) + allocate(is_node_locked(node_count(positions))) - call set_integer_array_from_python(func, len_trim(func), positions%dim, node_count(positions), & + call set_integer_array_from_python(func, len_trim(func), positions%dim, node_count(positions), & & positions%val(1,:), positions%val(2,:), positions%val(3,:), lcurrent_time, & & is_node_locked, stat) - if(stat /= 0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(func) - FLExit("Dying") - end if - - allocate(locked_nodes(count(is_node_locked /= 0))) - ewrite(2, "(a,i0)") "Number of locked nodes = ", size(locked_nodes) - index = 0 - do i = 1, size(is_node_locked) - if(is_node_locked(i) /= 0) then - index = index + 1 - assert(index <= size(locked_nodes)) - locked_nodes(index) = i + if(stat /= 0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(func) + FLExit("Dying") end if - end do - assert(index == size(locked_nodes)) - - deallocate(is_node_locked) - end subroutine get_locked_nodes + allocate(locked_nodes(count(is_node_locked /= 0))) + ewrite(2, "(a,i0)") "Number of locked nodes = ", size(locked_nodes) + index = 0 + do i = 1, size(is_node_locked) + if(is_node_locked(i) /= 0) then + index = index + 1 + assert(index <= size(locked_nodes)) + locked_nodes(index) = i + end if + end do + assert(index == size(locked_nodes)) + + deallocate(is_node_locked) + + end subroutine get_locked_nodes end module node_locking diff --git a/assemble/OceanSurfaceForcing.F90 b/assemble/OceanSurfaceForcing.F90 index ddb071e091..f98db5477b 100644 --- a/assemble/OceanSurfaceForcing.F90 +++ b/assemble/OceanSurfaceForcing.F90 @@ -27,146 +27,146 @@ #include "fdebug.h" module OceanSurfaceForcing - use fldebug - use global_parameters, only : OPTION_PATH_LEN, pi - use futils, only: int2str - use elements - use spud - use parallel_tools - use transform_elements - use fetools - use parallel_fields - use fields - use state_module - use boundary_conditions - use coordinates - - implicit none - - private - public:: wind_forcing + use fldebug + use global_parameters, only : OPTION_PATH_LEN, pi + use futils, only: int2str + use elements + use spud + use parallel_tools + use transform_elements + use fetools + use parallel_fields + use fields + use state_module + use boundary_conditions + use coordinates + + implicit none + + private + public:: wind_forcing contains - subroutine wind_forcing(state, rhs) - !!< Implements wind forcing from new options. - type(state_type), intent(in):: state - type(vector_field), intent(inout):: rhs - - type(vector_field), pointer:: velocity, positions, wind_surface_field - type(scalar_field), pointer:: wind_drag_coefficient - type(element_type):: faceshape - character(len=OPTION_PATH_LEN):: bctype - real, dimension(:,:), allocatable:: llpos_at_quads, ll_wind_at_quads - real, dimension(:,:), allocatable:: wind_at_quads - real, dimension(:), allocatable:: detwei, C_D, unorm - real rho_air - logical apply_wind_formula, on_sphere - integer, dimension(:), pointer:: surface_element_list - integer sngi, wdim, nobcs - integer i, j, k, sele - logical:: parallel_dg - - ewrite(1,*) 'Inside wind_forcing' - ewrite_minmax(rhs) - - velocity => extract_vector_field(state, "Velocity") - positions => extract_vector_field(state, "Coordinate") - - parallel_dg=continuity(velocity)<0 .and. IsParallel() - on_sphere=have_option('/geometry/spherical_earth') - faceshape=face_shape(velocity, 1) - sngi=face_ngi(velocity, 1) - if (on_sphere) then - wdim=3 ! dimension of the wind - assert(velocity%dim==3) - else - wdim=velocity%dim-1 ! dimension of the wind - end if - - allocate(detwei(1:sngi), C_D(1:sngi), unorm(1:sngi), & - wind_at_quads(1:wdim,1:sngi)) - if (on_sphere) then - allocate( llpos_at_quads(1:2,1:sngi), ll_wind_at_quads(1:2,1:sngi) ) - end if - - nobcs = get_boundary_condition_count(velocity) - do i=1, nobcs - call get_boundary_condition(velocity, i, type=bctype, & - surface_element_list=surface_element_list) - if (bctype=='wind_forcing') then - wind_surface_field => extract_surface_field(velocity, i, "WindSurfaceField") - apply_wind_formula=has_scalar_surface_field(velocity, i, "WindDragCoefficient") - if (apply_wind_formula) then - wind_drag_coefficient => extract_scalar_surface_field(velocity, & - i, "WindDragCoefficient") - call get_option(trim(velocity%option_path)// & - '/prognostic/boundary_conditions['//int2str(i-1)//']& - &/type[0]/wind_velocity/density_air', rho_air) - end if - - do j=1, size(surface_element_list) - sele=surface_element_list(j) ! face/surface element nr. - - if (parallel_dg) then - if (.not. element_owned(velocity, face_ele(velocity,sele))) cycle - end if - - ! compute integration weights detwei - call transform_facet_to_physical(positions, sele, detwei) - - ! compute wind_at_quads: wind velocity at quadr. points - ! OR (if .not. apply_wind_formula): wind stress at quadr. points - if (on_sphere) then - call LongitudeLatitude(face_val_at_quad(positions,sele), & - llpos_at_quads(1,:), llpos_at_quads(2,:)) - ll_wind_at_quads=ele_val_at_quad(wind_surface_field, j) - call ll2r3_rotate( & - llpos_at_quads(1,:), llpos_at_quads(2,:), & - ll_wind_at_quads(1,:), ll_wind_at_quads(2,:), & - wind_at_quads(1,:), wind_at_quads(2,:), wind_at_quads(3,:)) - else - - wind_at_quads=ele_val_at_quad(wind_surface_field, j) - end if - - - if (apply_wind_formula) then - - ! wind_at_quads is actual wind velocity - - ! make wind_at_quads relative velocity (specified wind-sea surface velocity) - ! at quadrature points - do k=1, wdim - wind_at_quads(k,:)=wind_at_quads(k,:)- & - face_val_at_quad(velocity, sele, dim=k) - end do - ! drag coefficient: - C_D=ele_val_at_quad(wind_drag_coefficient, j) - - ! compute its norm, sum over dim=1 is sum over components - unorm=sqrt(sum(wind_at_quads**2, dim=1)) - - ! multiply at each gauss point: - detwei=detwei*C_D*unorm*rho_air - end if - - do k=1, wdim - ! add surface forcing in rhs of momentum equation: - call addto(rhs, k, face_global_nodes(velocity, sele), & - shape_rhs( faceshape, wind_at_quads(k,:)*detwei )) - end do - end do + subroutine wind_forcing(state, rhs) + !!< Implements wind forcing from new options. + type(state_type), intent(in):: state + type(vector_field), intent(inout):: rhs + + type(vector_field), pointer:: velocity, positions, wind_surface_field + type(scalar_field), pointer:: wind_drag_coefficient + type(element_type):: faceshape + character(len=OPTION_PATH_LEN):: bctype + real, dimension(:,:), allocatable:: llpos_at_quads, ll_wind_at_quads + real, dimension(:,:), allocatable:: wind_at_quads + real, dimension(:), allocatable:: detwei, C_D, unorm + real rho_air + logical apply_wind_formula, on_sphere + integer, dimension(:), pointer:: surface_element_list + integer sngi, wdim, nobcs + integer i, j, k, sele + logical:: parallel_dg + + ewrite(1,*) 'Inside wind_forcing' + ewrite_minmax(rhs) + + velocity => extract_vector_field(state, "Velocity") + positions => extract_vector_field(state, "Coordinate") + + parallel_dg=continuity(velocity)<0 .and. IsParallel() + on_sphere=have_option('/geometry/spherical_earth') + faceshape=face_shape(velocity, 1) + sngi=face_ngi(velocity, 1) + if (on_sphere) then + wdim=3 ! dimension of the wind + assert(velocity%dim==3) + else + wdim=velocity%dim-1 ! dimension of the wind + end if + + allocate(detwei(1:sngi), C_D(1:sngi), unorm(1:sngi), & + wind_at_quads(1:wdim,1:sngi)) + if (on_sphere) then + allocate( llpos_at_quads(1:2,1:sngi), ll_wind_at_quads(1:2,1:sngi) ) end if - end do - deallocate(detwei, C_D, unorm, wind_at_quads) - if (on_sphere) then - deallocate(llpos_at_quads, ll_wind_at_quads) - end if + nobcs = get_boundary_condition_count(velocity) + do i=1, nobcs + call get_boundary_condition(velocity, i, type=bctype, & + surface_element_list=surface_element_list) + if (bctype=='wind_forcing') then + wind_surface_field => extract_surface_field(velocity, i, "WindSurfaceField") + apply_wind_formula=has_scalar_surface_field(velocity, i, "WindDragCoefficient") + if (apply_wind_formula) then + wind_drag_coefficient => extract_scalar_surface_field(velocity, & + i, "WindDragCoefficient") + call get_option(trim(velocity%option_path)// & + '/prognostic/boundary_conditions['//int2str(i-1)//']& + &/type[0]/wind_velocity/density_air', rho_air) + end if + + do j=1, size(surface_element_list) + sele=surface_element_list(j) ! face/surface element nr. + + if (parallel_dg) then + if (.not. element_owned(velocity, face_ele(velocity,sele))) cycle + end if + + ! compute integration weights detwei + call transform_facet_to_physical(positions, sele, detwei) + + ! compute wind_at_quads: wind velocity at quadr. points + ! OR (if .not. apply_wind_formula): wind stress at quadr. points + if (on_sphere) then + call LongitudeLatitude(face_val_at_quad(positions,sele), & + llpos_at_quads(1,:), llpos_at_quads(2,:)) + ll_wind_at_quads=ele_val_at_quad(wind_surface_field, j) + call ll2r3_rotate( & + llpos_at_quads(1,:), llpos_at_quads(2,:), & + ll_wind_at_quads(1,:), ll_wind_at_quads(2,:), & + wind_at_quads(1,:), wind_at_quads(2,:), wind_at_quads(3,:)) + else + + wind_at_quads=ele_val_at_quad(wind_surface_field, j) + end if + + + if (apply_wind_formula) then + + ! wind_at_quads is actual wind velocity + + ! make wind_at_quads relative velocity (specified wind-sea surface velocity) + ! at quadrature points + do k=1, wdim + wind_at_quads(k,:)=wind_at_quads(k,:)- & + face_val_at_quad(velocity, sele, dim=k) + end do + ! drag coefficient: + C_D=ele_val_at_quad(wind_drag_coefficient, j) + + ! compute its norm, sum over dim=1 is sum over components + unorm=sqrt(sum(wind_at_quads**2, dim=1)) + + ! multiply at each gauss point: + detwei=detwei*C_D*unorm*rho_air + end if + + do k=1, wdim + ! add surface forcing in rhs of momentum equation: + call addto(rhs, k, face_global_nodes(velocity, sele), & + shape_rhs( faceshape, wind_at_quads(k,:)*detwei )) + end do + end do + end if + end do + + deallocate(detwei, C_D, unorm, wind_at_quads) + if (on_sphere) then + deallocate(llpos_at_quads, ll_wind_at_quads) + end if - ewrite_minmax(rhs) + ewrite_minmax(rhs) - end subroutine wind_forcing + end subroutine wind_forcing end module OceanSurfaceForcing diff --git a/assemble/Particle_Diagnostics.F90 b/assemble/Particle_Diagnostics.F90 index d4e54d9637..5d2475d909 100644 --- a/assemble/Particle_Diagnostics.F90 +++ b/assemble/Particle_Diagnostics.F90 @@ -29,1223 +29,1223 @@ module particle_diagnostics - use fldebug - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str - use spud - use parallel_tools, only: getnprocs, allsum, getprocno - use elements, only: eval_shape - use fields_base, only: ele_val, ele_loc, node_val, eval_field - use parallel_fields, only: node_owned - use fields_calculations, only: dot_product - use fields - use profiler - use state_module - use halos - use detector_data_types - use pickers - use field_options - use detector_tools, only: temp_list_insert, insert, allocate, deallocate, temp_list_deallocate, & - & remove, temp_list_remove - use particles, only : get_particle_arrays, initialise_constant_particle_attributes, & - & update_particle_attributes_and_fields, get_particle_arrays, particle_lists - use multimaterial_module, only: calculate_sum_material_volume_fractions - - implicit none - - private - - public :: update_particle_attributes_and_fields, calculate_particle_material_fields, & - & calculate_diagnostic_fields_from_particles, initialise_constant_particle_diagnostics, & - & particle_cv_check - - contains - - subroutine initialise_constant_particle_diagnostics(state) - !subroutine to initialise constant particle attributes and - !MVF fields if 'from_particles' - - type(state_type), dimension(:), intent(inout) :: state - - character(len = OPTION_PATH_LEN) :: group_path, subgroup_path - integer :: i, j - integer :: particle_groups, list_counter - integer, dimension(:), allocatable :: particle_arrays - - type(detector_type), pointer :: particle - - ewrite(1,*) "In initialise_constant_particle_diagnostics" - - !Check if there are particles - particle_groups = option_count("/particles/particle_group") - - if (particle_groups==0) return - - !Set up particle_lists - allocate(particle_arrays(particle_groups)) - particle_arrays = 0 - do i = 1,particle_groups - particle_arrays(i) = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup") - end do - - !Initialise constant particle attributes - list_counter=1 - do i = 1,particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - do j = 1,particle_arrays(i) - particle => particle_lists(list_counter)%first - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(j-1)//"]" - if (option_count(trim(subgroup_path) // "/attributes/scalar_attribute/constant") + & - & option_count(trim(subgroup_path) // "/attributes/vector_attribute/constant") + & - & option_count(trim(subgroup_path) // "/attributes/tensor_attribute/constant")>0) then - call initialise_constant_particle_attributes(state, subgroup_path, particle_lists(list_counter)) - end if - list_counter = list_counter + 1 - end do - end do - - deallocate(particle_arrays) - - end subroutine initialise_constant_particle_diagnostics - - subroutine calculate_diagnostic_fields_from_particles(state) - !subroutine to calculate diagnostic fields which are dependent on particles - !MVF fields are not calculated here - type(state_type), dimension(:), intent(inout) :: state - - character(len = OPTION_PATH_LEN) :: name - type(scalar_field), pointer :: s_field - integer :: i, k - integer :: particle_groups - - ewrite(1,*) "In calculate_diagnostic_fields_from_particles" - !Check if there are particles - particle_groups = option_count("/particles/particle_group") - - if (particle_groups==0) return - - !Initialise diagnostic fields generated from particles - do i = 1,size(state) - do k = 1,scalar_field_count(state(i)) - s_field => extract_scalar_field(state(i),k) - if (have_option(trim(s_field%option_path)//"/diagnostic/algorithm::from_particles")) then - call get_option(trim(s_field%option_path)//"/name", name) - if (name=="MaterialVolumeFraction") cycle - call calculate_field_from_particles(state, i, s_field) - end if - end do - end do - - !Initialise fields based on number of particles if present - do i = 1,size(state) - do k = 1,scalar_field_count(state(i)) - s_field => extract_scalar_field(state(i),k) - if (have_option(trim(s_field%option_path)//"/diagnostic/algorithm::number_of_particles")) then - call calculate_field_from_particles(state, i, s_field) - end if - end do - end do - - end subroutine calculate_diagnostic_fields_from_particles - - subroutine calculate_particle_material_fields(state) - !subroutine to initialise MVF fields from particles - - type(state_type), dimension(:), intent(inout) :: state - - type(scalar_field), pointer :: s_field - integer :: i, k, particle_materials - - !Check if MVF field is generated from particles - particle_materials = option_count("/material_phase/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::from_particles") - if (particle_materials==0) return - - k = 0 - - !Initialise MaterialVolumeFraction fields dependent on particles - do i = 1,size(state) - s_field => extract_scalar_field(state(i), "MaterialVolumeFraction") - if (have_option(trim(s_field%option_path)//"/diagnostic/algorithm::from_particles")) then - call calculate_field_from_particles(state, i, s_field) - else if(have_option(trim(s_field%option_path)//"/diagnostic/algorithm::Internal")) then - k = i - end if - end do - - if (k==0) FLAbort("No diagnostic internal algorithm found.") - - !Initialise internal MaterialVolumeFraction field - s_field => extract_scalar_field(state(k), "MaterialVolumeFraction") - call calculate_sum_material_volume_fractions(state, s_field) - call scale(s_field, -1.0) - call addto(s_field, 1.0) - - end subroutine calculate_particle_material_fields - - subroutine calculate_field_from_particles(states, state_index, s_field) - - !!Calculate s_field using the ratio method, or from the number of particles present - !!If using the ratio method first determine which particle groups/subgroups/attributes - !!are being used, then determine the closest node for each particle and store attribute - !!values. Finally use the ratio method to calculate field values and place on - !!Diagnostic scalar field - - type(state_type), dimension(:), target, intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - type(halo_type), pointer :: halo - - character(len=OPTION_PATH_LEN) :: lgroup, lattribute - type(vector_field), pointer :: xfield - type(detector_type), pointer :: particle - integer :: i - real, allocatable, dimension(:) :: node_values - real, allocatable, dimension(:) :: node_part_count ! real instead of integer, so we can use halo_accumulate - integer :: element, node_number - real, allocatable, dimension(:) :: local_crds - integer, dimension(:), pointer :: nodes - integer :: nprocs, att_n - real :: att_value - character(len= OPTION_PATH_LEN) :: lmethod - logical :: from_particles - - integer :: group_attribute - integer, allocatable, dimension(:) :: group_arrays - - call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/name", lmethod, default = "from_particles") - - from_particles = trim(lmethod)=="from_particles" - - call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/name", lgroup) - if (from_particles) then - if (have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute")) then - call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute/name", lattribute) - att_n=0 - ewrite(2,*) "Calculate diagnostic field from particle group: ", trim(lgroup), ", attribute: ", trim(lattribute) - else if (have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute_array")) then - call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute_array/name", lattribute) - call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute_array/attribute_index", att_n) - ewrite(2,*) "Calculate diagnostic field from particle group: ", trim(lgroup), ", attribute_array: ", trim(lattribute), ", attribute_index: ", att_n - end if - else - ewrite(2,*) "Calculate diagnostic field from number of particles on particle group: ", trim(lgroup) - end if - - xfield=>extract_vector_field(states(1), "Coordinate") - - nodes => ele_nodes(s_field, 1) - if (xfield%dim+1/=size(nodes)) then - FLAbort("Can only generate particle diagnostic fields for a P1CV mesh") - end if - - ! contribution of local particles to non-owned nodes are summed - ! into the owner in the halo_accumulate calls below - ! we might be safe to assume we only need to add into halo 1 nodes (as these - ! are the only ones that make up owned elements), but let's include halo 2 to be sure - ! Only run this if nprocs > 1 - nprocs = getnprocs() - if (nprocs>1) then - halo => s_field%mesh%halos(2) - end if - - if (.not. allocated(particle_lists)) return !Particles not yet setup, Initial field value will be 0 - !Particles are initialized, call subroutine to get relevant particle arrays and attributes - if (from_particles) then - call get_particle_arrays(lgroup, group_arrays, group_attribute, att_n=att_n, lattribute=lattribute) - else - call get_particle_arrays(lgroup, group_arrays) - end if - - - !Allocate arrays to store summed attribute values and particle counts at nodes - if (from_particles) then - allocate(node_values(node_count(s_field))) - node_values = 0 - end if - allocate(node_part_count(node_count(s_field))) - node_part_count = 0 - - if (from_particles .and. have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/interpolation/weighted_distance")) then - !Calculate node values from attributes with the weighted_distance interpolation algorithm - !Loop over particle arrays - do i = 1,size(group_arrays) - particle => particle_lists(group_arrays(i))%first - if (.not. associated(particle)) cycle !Only work on arrays if local_particles exist on this processor - allocate(local_crds(size(particle%local_coords))) - do while(associated(particle)) - !Get element, local_crds and attribute value of each particle - element = particle%element - local_crds = particle%local_coords - att_value = particle%attributes(group_attribute) - - !Find nodes for specified element - nodes => ele_nodes(s_field, element) - - !Distribute particle values across nodes of element by weighted distance function - node_values(nodes) = node_values(nodes) + att_value*local_crds - node_part_count(nodes) = node_part_count(nodes) + local_crds - particle => particle%next - - end do - if (allocated(local_crds)) then - deallocate(local_crds) - end if - end do - - else if (.not. from_particles .or. have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/interpolation/nearest_neighbour")) then - !Calculate node values from attributes with the nearest neighbour interpolation algorithm - !or for the case where we are simply counting the number of particles (if not from_particles) - - !Loop over particle arrays - do i = 1,size(group_arrays) - particle => particle_lists(group_arrays(i))%first - if (associated(particle)) then !Only work on arrays if local_particles exist on this processor - allocate(local_crds(size(particle%local_coords))) - end if - do while(associated(particle)) - !Get element, local_crds and attribute value of each particle - element = particle%element - local_crds = particle%local_coords - if (from_particles) then - att_value = particle%attributes(group_attribute) - end if - !Find nodes for specified element - nodes => ele_nodes(s_field, element) - ! work out nearest node based on max. local coordinate - node_number = nodes(maxloc(local_crds, dim=1)) - if (from_particles) then - !Store particle attribute value on closest node - node_values(node_number) = node_values(node_number) + att_value - end if - !Increase particle count for this node by 1 - node_part_count(node_number) = node_part_count(node_number) + 1.0 - particle => particle%next - - end do - if (allocated(local_crds)) then - deallocate(local_crds) - end if - end do - end if - - if (nprocs>1) then - call halo_accumulate(halo, node_part_count) - if (from_particles) then - call halo_accumulate(halo, node_values) - end if - end if - - if (from_particles) then - !Store value on field (if node has at least one particle) - where (node_part_count/=0) - !Determine field value from ratio method - s_field%val = node_values/node_part_count - elsewhere - s_field%val = 0 - end where - else - !Store number of particles on field - s_field%val = node_part_count - end if - - if (from_particles) then - deallocate(node_values) - end if - deallocate(node_part_count) - deallocate(group_arrays) - - ! all values in owned nodes should now be correct - ! now we need to make sure the halo is updated accordingly - if (nprocs>1) then - call halo_update(s_field) - end if - - end subroutine calculate_field_from_particles - - subroutine particle_cv_check(states) - !Routine to check particle numbers fall within CV thresholds - !Spawns or deletes particles if numbers exceed or fall below CV thresholds - - type(state_type), dimension(:), target, intent(in) :: states - - type(mesh_type), pointer :: mesh - integer, allocatable, dimension(:) :: group_arrays - integer :: particle_groups, k - character(len=OPTION_PATH_LEN) :: mesh_name - character(len=OPTION_PATH_LEN) :: particle_group - - logical :: have_attribute_caps, have_radius, copy_parents - integer :: min_thresh, max_thresh - integer, allocatable :: seed(:) - integer :: n - real :: radius, cap_percent - - ewrite(1,*) "In particle_cv_check" - - call profiler_tic("particles_spawn_delete") - !Check if there are particles - particle_groups = option_count('/particles/particle_group') - - if (particle_groups==0) return - call random_seed(size = n) - allocate(seed(n)) - do k = 1,n - seed(k) = k*n - end do - call random_seed(PUT=seed) - do k = 1, particle_groups - if (have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning")) then - !Get the mesh particles will be spawned to - call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/mesh/name", mesh_name) - mesh => extract_mesh(states(1), trim(mesh_name)) - - !Set minimum and maximum particle thresholds per control volume - call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/min_cv_threshhold", min_thresh) - call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/max_cv_threshhold", max_thresh) - - !Check option for where particles should be spawned within a control volume. - have_radius = have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/spawn_location/radius") - if (have_radius) call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/spawn_location/radius", radius) - - !Check option for what algorithm particle_attributes should be calculated with - copy_parents = have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/spawn_attributes/copy_parent_attributes") - - !Check option on whether certain particle subgroup spawning should be capped if one subgroup is dominant - have_attribute_caps = have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/subgroup_spawning_caps") - if (have_attribute_caps) then - call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/subgroup_spawning_caps/percentage", cap_percent) - end if - - !Need to get particle arrays - call get_option("/particles/particle_group["//int2str(k-1)//"]/name", particle_group) - call get_particle_arrays(particle_group, group_arrays) - !call routine with optional cap parameters when relevant - if (have_attribute_caps) then - call spawn_delete_particles(states, mesh, group_arrays, max_thresh, min_thresh, have_radius, radius, copy_parents, cap_percent) - else - call spawn_delete_particles(states, mesh, group_arrays, max_thresh, min_thresh, have_radius, radius, copy_parents) - end if - deallocate(group_arrays) - end if - end do - call profiler_toc("particles_spawn_delete") - - end subroutine particle_cv_check - - subroutine spawn_delete_particles(states, mesh, group_arrays, max_thresh, min_thresh, have_radius, radius, copy_parents, cap_percent) - - !Subroutine to calculate the number of particles in each control volume, and call spawning - !or deleting routines if threshold limits are broken - !> Model state structure - type(state_type), dimension(:), target, intent(in) :: states - !> Model mesh - type (mesh_type), intent(in) :: mesh - !> Indicies in particle_lists present - integer, dimension(:), intent(in) :: group_arrays - !> Minimum and maximum control volume particle thresholds - integer, intent(in) :: min_thresh, max_thresh - !> Parameter to determine spawning scheme used - logical, intent(in) :: have_radius - !> Parameter to determine particle spawn location - real, intent(in) :: radius - !> Parameter to determine spawned particle attribute values - logical, intent(in) :: copy_parents - !> Parameter to determine if spawning/deleting will be capped per group - real, optional, intent(in) :: cap_percent - - type(halo_type), pointer :: halo - type(detector_linked_list), allocatable, target, dimension(:,:) :: node_particles - type(detector_linked_list), pointer :: del_node_particles - real, allocatable, dimension(:) :: node_part_count - real, allocatable, dimension(:) :: local_crds - type(detector_type), pointer :: particle - integer :: element, node_number - integer, dimension(:), pointer :: nodes - integer :: nprocs - type(vector_field), pointer :: xfield - integer :: i, j, mult - - !Counters to determine the new total number of particles in the relevant linked_list per processor - integer, allocatable, dimension(:) :: summed_particles, add_particles, remove_particles - !Temporary particle counter to determine how many particles have been spawned per group per control volume - real, dimension(:), allocatable :: temp_part_count - integer :: total_particles - - ewrite(1,*) "In spawn_delete_particles" - - !Get initial fields and number of processors - xfield=>extract_vector_field(states(1), "Coordinate") - nprocs = getnprocs() - if (nprocs>1) then - halo => mesh%halos(2) - end if - !Get number of nodes on the mesh - !NOTE: this has the potential to be very memory intensive, and we should consider improving this data structure - allocate(node_particles(size(group_arrays),node_count(mesh))) - allocate(node_part_count(node_count(mesh))) - node_part_count = 0 - - !Loop over particle arrays and sum particles per node - do i = 1,size(group_arrays) - particle => particle_lists(group_arrays(i))%first - if (associated(particle)) then !Only work on arrays if local_particles exist on this processor - allocate(local_crds(size(particle%local_coords))) - end if - do while(associated(particle)) - !Get element, local_crds and attribute value of each particle - element = particle%element - local_crds = particle%local_coords - - !Find nodes for specified element - nodes => ele_nodes(mesh, element) - - !work out nearest node based on max. local coordinate - node_number = nodes(maxloc(local_crds, dim=1)) - - !Increase particle count for this node by 1 - node_part_count(node_number) = node_part_count(node_number) + 1.0 - call temp_list_insert(particle,node_particles(i,node_number)) - particle => particle%next - - end do - if (allocated(local_crds)) then - deallocate(local_crds) - end if - end do - - if (nprocs>1) then - call halo_accumulate(halo, node_part_count) - end if - - allocate(summed_particles(size(group_arrays))) - allocate(add_particles(size(group_arrays))) - allocate(remove_particles(size(group_arrays))) - allocate(temp_part_count(size(node_part_count))) - - summed_particles = 0 - temp_part_count = 0 - - !Loop over all nodes and ensure thresholds are not broken. Check minimum threshold and spawn particles, then check maximum threshold and delete particles - - !Loop over all nodes - do i = 1,node_count(mesh) - !Count number of particles per node and ensure minimum threshold is not broken - !Spawn particles if threshold is broken (but only for nodes with particles in CV) - if (node_part_count(i)>0) then - if (node_part_count(i)<(min_thresh/2)) then - mult = nint(min_thresh/node_part_count(i)*1.0) - call multi_spawn_particles(temp_part_count(i), node_particles(:,i), group_arrays, xfield, summed_particles, i, mult, have_radius, radius, copy_parents, cap_percent) - else if (node_part_count(i)1) then - call halo_accumulate(halo, temp_part_count) - end if - !Add number of spawned particles on each CV to particle count - node_part_count = node_part_count(:) + temp_part_count(:) - - !Loop over all nodes - do i = 1,node_count(mesh) - !Count number of particles per node and ensure maximum threshold is not broken - !Delete particles if threshold is broken - if (node_part_count(i)>(2*max_thresh)) then - mult = nint(node_part_count(i)*1.0/max_thresh) - call multi_delete_particles(mult, node_particles(:,i), group_arrays, summed_particles, cap_percent) - else if (node_part_count(i)>max_thresh) then - call delete_particles(node_particles(:,i), group_arrays, remove_particles, cap_percent=cap_percent) - summed_particles=summed_particles-remove_particles - end if - end do - - !Update particle_list parameters - do j=1,size(group_arrays) - call allsum(summed_particles(j)) - particle_lists(group_arrays(j))%total_num_det=particle_lists(group_arrays(j))%total_num_det+summed_particles(j) - end do - - !Sanity check - do j=1,size(group_arrays) - total_particles = particle_lists(group_arrays(j))%length - call allsum(total_particles) - assert(total_particles==particle_lists(group_arrays(j))%total_num_det) - end do - - deallocate(node_part_count) - deallocate(add_particles) - deallocate(remove_particles) - deallocate(summed_particles) - deallocate(temp_part_count) - - do i=1,node_count(mesh) - do j=1,size(group_arrays) - del_node_particles => node_particles(j,i) - call temp_list_deallocate(del_node_particles) - end do - end do - deallocate(node_particles) - - end subroutine spawn_delete_particles - - subroutine multi_spawn_particles(node_part_count, node_particles, group_arrays, xfield, summed_particles, node_num, mult, have_radius, radius, copy_parents, cap_percent) - !Subroutine to call spawn particles multiple times based on the mult factor - !calculated from the current number of particles and the minimum threshold - !> Linked list of particles which exist on this node - type(detector_linked_list), intent(inout), dimension(:) :: node_particles - !> Array counting particles on all nodes - real, intent(inout) :: node_part_count - !> Indicies in particle_lists present - integer, intent(in), dimension(:) :: group_arrays - !> Current node number we are working on - integer, intent(in) :: node_num - !> Input position field - type(vector_field), pointer, intent(in) :: xfield - !> Array to sum spawned particles - integer, dimension(:), intent(inout) :: summed_particles - !> Factor to determine number of spawn_particle calls - integer, intent(in) :: mult - !> Parameter to determine spawning scheme used - logical, intent(in) :: have_radius - !> Parameter to determine particle spawn location - real, intent(in) :: radius - !> Parameter to determine spawned particle attribute values - logical, intent(in) :: copy_parents - !> Parameter to determine if spawning/deleting will be capped per group - real, optional, intent(in) :: cap_percent - - integer :: i, power, j - !> Array to count number of particles spawned per particle group - integer, allocatable, dimension(:) :: add_particles - logical :: power_set - - allocate(add_particles(size(group_arrays))) - - power_set=.false. - j=0 - !Loop to find the largest power of 2 less than or equal to mult factor - do while (.not. power_set) - if (mult>=2**j) then - j=j+1 - else - power=j-1 - power_set=.true. - end if - end do - - do i = 1,power - call spawn_particles(node_part_count, node_particles, group_arrays, xfield, add_particles, node_num, have_radius, radius, copy_parents, cap_percent) - summed_particles=summed_particles+add_particles - end do - - deallocate(add_particles) - - end subroutine multi_spawn_particles - - subroutine spawn_particles(node_part_count, node_particles, group_arrays, xfield, add_particles, node_num, have_radius, radius, copy_parents, cap_percent) - !Subroutine to spawn particles in a control volume based off the parent particles present - - !> Linked list of particles which exist on this node - type(detector_linked_list), intent(inout), dimension(:) :: node_particles - !> Array counting particles on all nodes - real, intent(inout) :: node_part_count - !> Indicies in particle_lists present - integer, intent(in), dimension(:) :: group_arrays - !> Current node number we are working on - integer, intent(in) :: node_num - !> Input position field - type(vector_field), pointer, intent(in) :: xfield - !> Array to count number of particles spawned per particle group - integer, dimension(:), intent(inout) :: add_particles - !> Parameter to determine spawning scheme used - logical, intent(in) :: have_radius - !> Parameter to determine particle spawn location - real, intent(in) :: radius - !> Parameter to determine spawned particle attribute values - logical, intent(in) :: copy_parents - !> Parameter to determine if spawning/deleting will be capped per group - real, optional, intent(in) :: cap_percent - - !> Dummy particles - type(detector_type), pointer :: particle - type(detector_type), pointer :: temp_part - - real, dimension(:), allocatable :: node_coord - real, dimension(:), allocatable :: average_attributes, average_old_attributes, average_old_fields - - integer, dimension(:), allocatable :: node_numbers, ele_num_part - integer, dimension(:), pointer :: ele_nums - integer :: id, group_spawn, ele_spawn, proc_num - integer :: j, i, k, l, m, dim - logical :: spawn_group, coords_set, rand_set - real :: max_lcoord, rand_lcoord, rand_val - real, dimension(:), allocatable :: rand_lcoords - - proc_num = getprocno() - - !Check the ratio of particles present per group and determine which groups spawn - spawn_group = .true. - if (present(cap_percent)) then - spawn_group = .false. - do i=1,size(group_arrays) - !Check if a particle group makes up >= cap_percent of the total particles in the current control volume - assert(cap_percent>50) - if ((((node_particles(i)%length*1.0)/sum(node_particles(:)%length)*1.0)*100)>=cap_percent) then - spawn_group = .true. - group_spawn = i - end if - end do - end if - - add_particles = 0 - !Return if no groups spawn - if (.not. spawn_group) return - - !Count the number of particles per surrounding element for weighted spawning if - !not spawning based on radius from parent - if (.not. have_radius) then - ele_nums => node_neigh(xfield, node_num) - allocate(ele_num_part(size(ele_nums))) - ele_num_part = 0 - do j = 1,size(group_arrays) - particle => node_particles(j)%first - do while(associated(particle)) - do i = 1,size(ele_nums) - if (ele_nums(i) == particle%element) then - ele_num_part(i) = ele_num_part(i) + 1 - end if - end do - particle => particle%temp_next - end do - end do - end if - - !Loop over particle groups for spawning - do j = 1,size(group_arrays) - if (present(cap_percent)) then - if (j/=group_spawn) cycle - end if - !Calculated average attribute parameters based on existing particles if - !not copying parent attributes when spawning - if (.not. copy_parents) then - particle => node_particles(j)%first - if (associated(particle)) then - allocate(average_attributes(size(particle%attributes))) - allocate(average_old_attributes(size(particle%old_attributes))) - allocate(average_old_fields(size(particle%old_fields))) - average_attributes = 0 - average_old_attributes = 0 - average_old_fields = 0 - end if - do while(associated(particle)) - average_attributes = average_attributes + particle%attributes - average_old_attributes = average_old_attributes + particle%old_attributes - average_old_fields = average_old_fields + particle%old_fields - particle => particle%temp_next - end do - if (allocated(average_attributes)) then - average_attributes = average_attributes/node_particles(j)%length - average_old_attributes = average_old_attributes/node_particles(j)%length - average_old_fields = average_old_fields/node_particles(j)%length - end if - end if - - !Determine id, size and shape of spawned particle parameters - temp_part => particle_lists(group_arrays(j))%last - if (associated(temp_part)) then - id = particle_lists(group_arrays(j))%proc_part_count - allocate(node_coord(size(temp_part%local_coords))) - allocate(node_numbers(size(temp_part%local_coords))) - end if - - dim = size(node_coord)-1 - - !Spawn particles - particle => node_particles(j)%first - do while(associated(particle)) - temp_part => null() - call allocate(temp_part, size(particle%position), size(particle%local_coords), particle_lists(group_arrays(j))%total_attributes) - - temp_part%id_number = id+1 - temp_part%list_id = particle%list_id - temp_part%proc_id = proc_num - - !Check if particles are spawning within a radius around their parent, or randomly within the CV - if (have_radius) then - !Spawn particles within radius of parent particle - temp_part%element=particle%element - node_numbers(:) = ele_nodes(xfield, temp_part%element) - allocate(rand_lcoords(size(node_coord))) - coords_set=.false. - !dummy counter l to prevent infinite looping - l = 0 - !randomly select local coords within input radius around parent particle - !ensuring new particle falls within cv - do while (.not. coords_set) - rand_set=.false. - do while (.not. rand_set) - rand_lcoord=0 - call random_number(rand_val) - k = 1 + floor(size(node_coord)*rand_val) !randomly select a local_coord to be sum of other coords - do i = 1,size(node_coord) - if (node_numbers(i)==node_num) m=i - if (i==k) cycle - call random_number(rand_val) - rand_lcoords(i) = (rand_val-0.5)*2*(radius/dim) !perturb each free local_coord by +/- radius/dim - rand_lcoord = rand_lcoord + rand_lcoords(i)!sum local coord perturbations - end do - rand_lcoords(k) = -rand_lcoord !calculate final coord - if (maxval(rand_lcoords)>((radius/dim)*0.8)) then !Enforce the new particle to be at least rad/dim * 80% away - rand_set=.true. - end if - end do - node_coord(:) = particle%local_coords(:) + rand_lcoords(:) !add perturbation to spawned local_coordinates - coords_set=.true. - l = l + 1 - if ((maxloc(node_coord, 1)/=m).or.node_coord(m)>1.0) then !Not within CV or element, try again - coords_set=.false. - end if - if (minval(node_coord)<0.0) then !not within element, try again - coords_set=.false. - end if - if (l>100) then !Catch to stop infinite looping - ewrite(2,*) "loop limit reached, setting spawned coords to parent coords" - node_coord(:) = particle%local_coords(:) - coords_set=.true. - end if - end do - temp_part%local_coords = node_coord - deallocate(rand_lcoords) - else !Particles will spawn randomly in the CV, prioritizing + use fldebug + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str + use spud + use parallel_tools, only: getnprocs, allsum, getprocno + use elements, only: eval_shape + use fields_base, only: ele_val, ele_loc, node_val, eval_field + use parallel_fields, only: node_owned + use fields_calculations, only: dot_product + use fields + use profiler + use state_module + use halos + use detector_data_types + use pickers + use field_options + use detector_tools, only: temp_list_insert, insert, allocate, deallocate, temp_list_deallocate, & + & remove, temp_list_remove + use particles, only : get_particle_arrays, initialise_constant_particle_attributes, & + & update_particle_attributes_and_fields, get_particle_arrays, particle_lists + use multimaterial_module, only: calculate_sum_material_volume_fractions + + implicit none + + private + + public :: update_particle_attributes_and_fields, calculate_particle_material_fields, & + & calculate_diagnostic_fields_from_particles, initialise_constant_particle_diagnostics, & + & particle_cv_check + +contains + + subroutine initialise_constant_particle_diagnostics(state) + !subroutine to initialise constant particle attributes and + !MVF fields if 'from_particles' + + type(state_type), dimension(:), intent(inout) :: state + + character(len = OPTION_PATH_LEN) :: group_path, subgroup_path + integer :: i, j + integer :: particle_groups, list_counter + integer, dimension(:), allocatable :: particle_arrays + + type(detector_type), pointer :: particle + + ewrite(1,*) "In initialise_constant_particle_diagnostics" + + !Check if there are particles + particle_groups = option_count("/particles/particle_group") + + if (particle_groups==0) return + + !Set up particle_lists + allocate(particle_arrays(particle_groups)) + particle_arrays = 0 + do i = 1,particle_groups + particle_arrays(i) = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup") + end do + + !Initialise constant particle attributes + list_counter=1 + do i = 1,particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + do j = 1,particle_arrays(i) + particle => particle_lists(list_counter)%first + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(j-1)//"]" + if (option_count(trim(subgroup_path) // "/attributes/scalar_attribute/constant") + & + & option_count(trim(subgroup_path) // "/attributes/vector_attribute/constant") + & + & option_count(trim(subgroup_path) // "/attributes/tensor_attribute/constant")>0) then + call initialise_constant_particle_attributes(state, subgroup_path, particle_lists(list_counter)) + end if + list_counter = list_counter + 1 + end do + end do + + deallocate(particle_arrays) + + end subroutine initialise_constant_particle_diagnostics + + subroutine calculate_diagnostic_fields_from_particles(state) + !subroutine to calculate diagnostic fields which are dependent on particles + !MVF fields are not calculated here + type(state_type), dimension(:), intent(inout) :: state + + character(len = OPTION_PATH_LEN) :: name + type(scalar_field), pointer :: s_field + integer :: i, k + integer :: particle_groups + + ewrite(1,*) "In calculate_diagnostic_fields_from_particles" + !Check if there are particles + particle_groups = option_count("/particles/particle_group") + + if (particle_groups==0) return + + !Initialise diagnostic fields generated from particles + do i = 1,size(state) + do k = 1,scalar_field_count(state(i)) + s_field => extract_scalar_field(state(i),k) + if (have_option(trim(s_field%option_path)//"/diagnostic/algorithm::from_particles")) then + call get_option(trim(s_field%option_path)//"/name", name) + if (name=="MaterialVolumeFraction") cycle + call calculate_field_from_particles(state, i, s_field) + end if + end do + end do + + !Initialise fields based on number of particles if present + do i = 1,size(state) + do k = 1,scalar_field_count(state(i)) + s_field => extract_scalar_field(state(i),k) + if (have_option(trim(s_field%option_path)//"/diagnostic/algorithm::number_of_particles")) then + call calculate_field_from_particles(state, i, s_field) + end if + end do + end do + + end subroutine calculate_diagnostic_fields_from_particles + + subroutine calculate_particle_material_fields(state) + !subroutine to initialise MVF fields from particles + + type(state_type), dimension(:), intent(inout) :: state + + type(scalar_field), pointer :: s_field + integer :: i, k, particle_materials + + !Check if MVF field is generated from particles + particle_materials = option_count("/material_phase/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::from_particles") + if (particle_materials==0) return + + k = 0 + + !Initialise MaterialVolumeFraction fields dependent on particles + do i = 1,size(state) + s_field => extract_scalar_field(state(i), "MaterialVolumeFraction") + if (have_option(trim(s_field%option_path)//"/diagnostic/algorithm::from_particles")) then + call calculate_field_from_particles(state, i, s_field) + else if(have_option(trim(s_field%option_path)//"/diagnostic/algorithm::Internal")) then + k = i + end if + end do + + if (k==0) FLAbort("No diagnostic internal algorithm found.") + + !Initialise internal MaterialVolumeFraction field + s_field => extract_scalar_field(state(k), "MaterialVolumeFraction") + call calculate_sum_material_volume_fractions(state, s_field) + call scale(s_field, -1.0) + call addto(s_field, 1.0) + + end subroutine calculate_particle_material_fields + + subroutine calculate_field_from_particles(states, state_index, s_field) + + !!Calculate s_field using the ratio method, or from the number of particles present + !!If using the ratio method first determine which particle groups/subgroups/attributes + !!are being used, then determine the closest node for each particle and store attribute + !!values. Finally use the ratio method to calculate field values and place on + !!Diagnostic scalar field + + type(state_type), dimension(:), target, intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + type(halo_type), pointer :: halo + + character(len=OPTION_PATH_LEN) :: lgroup, lattribute + type(vector_field), pointer :: xfield + type(detector_type), pointer :: particle + integer :: i + real, allocatable, dimension(:) :: node_values + real, allocatable, dimension(:) :: node_part_count ! real instead of integer, so we can use halo_accumulate + integer :: element, node_number + real, allocatable, dimension(:) :: local_crds + integer, dimension(:), pointer :: nodes + integer :: nprocs, att_n + real :: att_value + character(len= OPTION_PATH_LEN) :: lmethod + logical :: from_particles + + integer :: group_attribute + integer, allocatable, dimension(:) :: group_arrays + + call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/name", lmethod, default = "from_particles") + + from_particles = trim(lmethod)=="from_particles" + + call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/name", lgroup) + if (from_particles) then + if (have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute")) then + call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute/name", lattribute) + att_n=0 + ewrite(2,*) "Calculate diagnostic field from particle group: ", trim(lgroup), ", attribute: ", trim(lattribute) + else if (have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute_array")) then + call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute_array/name", lattribute) + call get_option(trim(complete_field_path(s_field%option_path))// "/algorithm/particle_group/particle_attribute_array/attribute_index", att_n) + ewrite(2,*) "Calculate diagnostic field from particle group: ", trim(lgroup), ", attribute_array: ", trim(lattribute), ", attribute_index: ", att_n + end if + else + ewrite(2,*) "Calculate diagnostic field from number of particles on particle group: ", trim(lgroup) + end if + + xfield=>extract_vector_field(states(1), "Coordinate") + + nodes => ele_nodes(s_field, 1) + if (xfield%dim+1/=size(nodes)) then + FLAbort("Can only generate particle diagnostic fields for a P1CV mesh") + end if + + ! contribution of local particles to non-owned nodes are summed + ! into the owner in the halo_accumulate calls below + ! we might be safe to assume we only need to add into halo 1 nodes (as these + ! are the only ones that make up owned elements), but let's include halo 2 to be sure + ! Only run this if nprocs > 1 + nprocs = getnprocs() + if (nprocs>1) then + halo => s_field%mesh%halos(2) + end if + + if (.not. allocated(particle_lists)) return !Particles not yet setup, Initial field value will be 0 + !Particles are initialized, call subroutine to get relevant particle arrays and attributes + if (from_particles) then + call get_particle_arrays(lgroup, group_arrays, group_attribute, att_n=att_n, lattribute=lattribute) + else + call get_particle_arrays(lgroup, group_arrays) + end if + + + !Allocate arrays to store summed attribute values and particle counts at nodes + if (from_particles) then + allocate(node_values(node_count(s_field))) + node_values = 0 + end if + allocate(node_part_count(node_count(s_field))) + node_part_count = 0 + + if (from_particles .and. have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/interpolation/weighted_distance")) then + !Calculate node values from attributes with the weighted_distance interpolation algorithm + !Loop over particle arrays + do i = 1,size(group_arrays) + particle => particle_lists(group_arrays(i))%first + if (.not. associated(particle)) cycle !Only work on arrays if local_particles exist on this processor + allocate(local_crds(size(particle%local_coords))) + do while(associated(particle)) + !Get element, local_crds and attribute value of each particle + element = particle%element + local_crds = particle%local_coords + att_value = particle%attributes(group_attribute) + + !Find nodes for specified element + nodes => ele_nodes(s_field, element) + + !Distribute particle values across nodes of element by weighted distance function + node_values(nodes) = node_values(nodes) + att_value*local_crds + node_part_count(nodes) = node_part_count(nodes) + local_crds + particle => particle%next + + end do + if (allocated(local_crds)) then + deallocate(local_crds) + end if + end do + + else if (.not. from_particles .or. have_option(trim(complete_field_path(s_field%option_path))// "/algorithm/interpolation/nearest_neighbour")) then + !Calculate node values from attributes with the nearest neighbour interpolation algorithm + !or for the case where we are simply counting the number of particles (if not from_particles) + + !Loop over particle arrays + do i = 1,size(group_arrays) + particle => particle_lists(group_arrays(i))%first + if (associated(particle)) then !Only work on arrays if local_particles exist on this processor + allocate(local_crds(size(particle%local_coords))) + end if + do while(associated(particle)) + !Get element, local_crds and attribute value of each particle + element = particle%element + local_crds = particle%local_coords + if (from_particles) then + att_value = particle%attributes(group_attribute) + end if + !Find nodes for specified element + nodes => ele_nodes(s_field, element) + ! work out nearest node based on max. local coordinate + node_number = nodes(maxloc(local_crds, dim=1)) + if (from_particles) then + !Store particle attribute value on closest node + node_values(node_number) = node_values(node_number) + att_value + end if + !Increase particle count for this node by 1 + node_part_count(node_number) = node_part_count(node_number) + 1.0 + particle => particle%next + + end do + if (allocated(local_crds)) then + deallocate(local_crds) + end if + end do + end if + + if (nprocs>1) then + call halo_accumulate(halo, node_part_count) + if (from_particles) then + call halo_accumulate(halo, node_values) + end if + end if + + if (from_particles) then + !Store value on field (if node has at least one particle) + where (node_part_count/=0) + !Determine field value from ratio method + s_field%val = node_values/node_part_count + elsewhere + s_field%val = 0 + end where + else + !Store number of particles on field + s_field%val = node_part_count + end if + + if (from_particles) then + deallocate(node_values) + end if + deallocate(node_part_count) + deallocate(group_arrays) + + ! all values in owned nodes should now be correct + ! now we need to make sure the halo is updated accordingly + if (nprocs>1) then + call halo_update(s_field) + end if + + end subroutine calculate_field_from_particles + + subroutine particle_cv_check(states) + !Routine to check particle numbers fall within CV thresholds + !Spawns or deletes particles if numbers exceed or fall below CV thresholds + + type(state_type), dimension(:), target, intent(in) :: states + + type(mesh_type), pointer :: mesh + integer, allocatable, dimension(:) :: group_arrays + integer :: particle_groups, k + character(len=OPTION_PATH_LEN) :: mesh_name + character(len=OPTION_PATH_LEN) :: particle_group + + logical :: have_attribute_caps, have_radius, copy_parents + integer :: min_thresh, max_thresh + integer, allocatable :: seed(:) + integer :: n + real :: radius, cap_percent + + ewrite(1,*) "In particle_cv_check" + + call profiler_tic("particles_spawn_delete") + !Check if there are particles + particle_groups = option_count('/particles/particle_group') + + if (particle_groups==0) return + call random_seed(size = n) + allocate(seed(n)) + do k = 1,n + seed(k) = k*n + end do + call random_seed(PUT=seed) + do k = 1, particle_groups + if (have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning")) then + !Get the mesh particles will be spawned to + call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/mesh/name", mesh_name) + mesh => extract_mesh(states(1), trim(mesh_name)) + + !Set minimum and maximum particle thresholds per control volume + call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/min_cv_threshhold", min_thresh) + call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/max_cv_threshhold", max_thresh) + + !Check option for where particles should be spawned within a control volume. + have_radius = have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/spawn_location/radius") + if (have_radius) call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/spawn_location/radius", radius) + + !Check option for what algorithm particle_attributes should be calculated with + copy_parents = have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/spawn_attributes/copy_parent_attributes") + + !Check option on whether certain particle subgroup spawning should be capped if one subgroup is dominant + have_attribute_caps = have_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/subgroup_spawning_caps") + if (have_attribute_caps) then + call get_option("/particles/particle_group["//int2str(k-1)//"]/particle_spawning/subgroup_spawning_caps/percentage", cap_percent) + end if + + !Need to get particle arrays + call get_option("/particles/particle_group["//int2str(k-1)//"]/name", particle_group) + call get_particle_arrays(particle_group, group_arrays) + !call routine with optional cap parameters when relevant + if (have_attribute_caps) then + call spawn_delete_particles(states, mesh, group_arrays, max_thresh, min_thresh, have_radius, radius, copy_parents, cap_percent) + else + call spawn_delete_particles(states, mesh, group_arrays, max_thresh, min_thresh, have_radius, radius, copy_parents) + end if + deallocate(group_arrays) + end if + end do + call profiler_toc("particles_spawn_delete") + + end subroutine particle_cv_check + + subroutine spawn_delete_particles(states, mesh, group_arrays, max_thresh, min_thresh, have_radius, radius, copy_parents, cap_percent) + + !Subroutine to calculate the number of particles in each control volume, and call spawning + !or deleting routines if threshold limits are broken + !> Model state structure + type(state_type), dimension(:), target, intent(in) :: states + !> Model mesh + type (mesh_type), intent(in) :: mesh + !> Indicies in particle_lists present + integer, dimension(:), intent(in) :: group_arrays + !> Minimum and maximum control volume particle thresholds + integer, intent(in) :: min_thresh, max_thresh + !> Parameter to determine spawning scheme used + logical, intent(in) :: have_radius + !> Parameter to determine particle spawn location + real, intent(in) :: radius + !> Parameter to determine spawned particle attribute values + logical, intent(in) :: copy_parents + !> Parameter to determine if spawning/deleting will be capped per group + real, optional, intent(in) :: cap_percent + + type(halo_type), pointer :: halo + type(detector_linked_list), allocatable, target, dimension(:,:) :: node_particles + type(detector_linked_list), pointer :: del_node_particles + real, allocatable, dimension(:) :: node_part_count + real, allocatable, dimension(:) :: local_crds + type(detector_type), pointer :: particle + integer :: element, node_number + integer, dimension(:), pointer :: nodes + integer :: nprocs + type(vector_field), pointer :: xfield + integer :: i, j, mult + + !Counters to determine the new total number of particles in the relevant linked_list per processor + integer, allocatable, dimension(:) :: summed_particles, add_particles, remove_particles + !Temporary particle counter to determine how many particles have been spawned per group per control volume + real, dimension(:), allocatable :: temp_part_count + integer :: total_particles + + ewrite(1,*) "In spawn_delete_particles" + + !Get initial fields and number of processors + xfield=>extract_vector_field(states(1), "Coordinate") + nprocs = getnprocs() + if (nprocs>1) then + halo => mesh%halos(2) + end if + !Get number of nodes on the mesh + !NOTE: this has the potential to be very memory intensive, and we should consider improving this data structure + allocate(node_particles(size(group_arrays),node_count(mesh))) + allocate(node_part_count(node_count(mesh))) + node_part_count = 0 + + !Loop over particle arrays and sum particles per node + do i = 1,size(group_arrays) + particle => particle_lists(group_arrays(i))%first + if (associated(particle)) then !Only work on arrays if local_particles exist on this processor + allocate(local_crds(size(particle%local_coords))) + end if + do while(associated(particle)) + !Get element, local_crds and attribute value of each particle + element = particle%element + local_crds = particle%local_coords + + !Find nodes for specified element + nodes => ele_nodes(mesh, element) + + !work out nearest node based on max. local coordinate + node_number = nodes(maxloc(local_crds, dim=1)) + + !Increase particle count for this node by 1 + node_part_count(node_number) = node_part_count(node_number) + 1.0 + call temp_list_insert(particle,node_particles(i,node_number)) + particle => particle%next + + end do + if (allocated(local_crds)) then + deallocate(local_crds) + end if + end do + + if (nprocs>1) then + call halo_accumulate(halo, node_part_count) + end if + + allocate(summed_particles(size(group_arrays))) + allocate(add_particles(size(group_arrays))) + allocate(remove_particles(size(group_arrays))) + allocate(temp_part_count(size(node_part_count))) + + summed_particles = 0 + temp_part_count = 0 + + !Loop over all nodes and ensure thresholds are not broken. Check minimum threshold and spawn particles, then check maximum threshold and delete particles + + !Loop over all nodes + do i = 1,node_count(mesh) + !Count number of particles per node and ensure minimum threshold is not broken + !Spawn particles if threshold is broken (but only for nodes with particles in CV) + if (node_part_count(i)>0) then + if (node_part_count(i)<(min_thresh/2)) then + mult = nint(min_thresh/node_part_count(i)*1.0) + call multi_spawn_particles(temp_part_count(i), node_particles(:,i), group_arrays, xfield, summed_particles, i, mult, have_radius, radius, copy_parents, cap_percent) + else if (node_part_count(i)1) then + call halo_accumulate(halo, temp_part_count) + end if + !Add number of spawned particles on each CV to particle count + node_part_count = node_part_count(:) + temp_part_count(:) + + !Loop over all nodes + do i = 1,node_count(mesh) + !Count number of particles per node and ensure maximum threshold is not broken + !Delete particles if threshold is broken + if (node_part_count(i)>(2*max_thresh)) then + mult = nint(node_part_count(i)*1.0/max_thresh) + call multi_delete_particles(mult, node_particles(:,i), group_arrays, summed_particles, cap_percent) + else if (node_part_count(i)>max_thresh) then + call delete_particles(node_particles(:,i), group_arrays, remove_particles, cap_percent=cap_percent) + summed_particles=summed_particles-remove_particles + end if + end do + + !Update particle_list parameters + do j=1,size(group_arrays) + call allsum(summed_particles(j)) + particle_lists(group_arrays(j))%total_num_det=particle_lists(group_arrays(j))%total_num_det+summed_particles(j) + end do + + !Sanity check + do j=1,size(group_arrays) + total_particles = particle_lists(group_arrays(j))%length + call allsum(total_particles) + assert(total_particles==particle_lists(group_arrays(j))%total_num_det) + end do + + deallocate(node_part_count) + deallocate(add_particles) + deallocate(remove_particles) + deallocate(summed_particles) + deallocate(temp_part_count) + + do i=1,node_count(mesh) + do j=1,size(group_arrays) + del_node_particles => node_particles(j,i) + call temp_list_deallocate(del_node_particles) + end do + end do + deallocate(node_particles) + + end subroutine spawn_delete_particles + + subroutine multi_spawn_particles(node_part_count, node_particles, group_arrays, xfield, summed_particles, node_num, mult, have_radius, radius, copy_parents, cap_percent) + !Subroutine to call spawn particles multiple times based on the mult factor + !calculated from the current number of particles and the minimum threshold + !> Linked list of particles which exist on this node + type(detector_linked_list), intent(inout), dimension(:) :: node_particles + !> Array counting particles on all nodes + real, intent(inout) :: node_part_count + !> Indicies in particle_lists present + integer, intent(in), dimension(:) :: group_arrays + !> Current node number we are working on + integer, intent(in) :: node_num + !> Input position field + type(vector_field), pointer, intent(in) :: xfield + !> Array to sum spawned particles + integer, dimension(:), intent(inout) :: summed_particles + !> Factor to determine number of spawn_particle calls + integer, intent(in) :: mult + !> Parameter to determine spawning scheme used + logical, intent(in) :: have_radius + !> Parameter to determine particle spawn location + real, intent(in) :: radius + !> Parameter to determine spawned particle attribute values + logical, intent(in) :: copy_parents + !> Parameter to determine if spawning/deleting will be capped per group + real, optional, intent(in) :: cap_percent + + integer :: i, power, j + !> Array to count number of particles spawned per particle group + integer, allocatable, dimension(:) :: add_particles + logical :: power_set + + allocate(add_particles(size(group_arrays))) + + power_set=.false. + j=0 + !Loop to find the largest power of 2 less than or equal to mult factor + do while (.not. power_set) + if (mult>=2**j) then + j=j+1 + else + power=j-1 + power_set=.true. + end if + end do + + do i = 1,power + call spawn_particles(node_part_count, node_particles, group_arrays, xfield, add_particles, node_num, have_radius, radius, copy_parents, cap_percent) + summed_particles=summed_particles+add_particles + end do + + deallocate(add_particles) + + end subroutine multi_spawn_particles + + subroutine spawn_particles(node_part_count, node_particles, group_arrays, xfield, add_particles, node_num, have_radius, radius, copy_parents, cap_percent) + !Subroutine to spawn particles in a control volume based off the parent particles present + + !> Linked list of particles which exist on this node + type(detector_linked_list), intent(inout), dimension(:) :: node_particles + !> Array counting particles on all nodes + real, intent(inout) :: node_part_count + !> Indicies in particle_lists present + integer, intent(in), dimension(:) :: group_arrays + !> Current node number we are working on + integer, intent(in) :: node_num + !> Input position field + type(vector_field), pointer, intent(in) :: xfield + !> Array to count number of particles spawned per particle group + integer, dimension(:), intent(inout) :: add_particles + !> Parameter to determine spawning scheme used + logical, intent(in) :: have_radius + !> Parameter to determine particle spawn location + real, intent(in) :: radius + !> Parameter to determine spawned particle attribute values + logical, intent(in) :: copy_parents + !> Parameter to determine if spawning/deleting will be capped per group + real, optional, intent(in) :: cap_percent + + !> Dummy particles + type(detector_type), pointer :: particle + type(detector_type), pointer :: temp_part + + real, dimension(:), allocatable :: node_coord + real, dimension(:), allocatable :: average_attributes, average_old_attributes, average_old_fields + + integer, dimension(:), allocatable :: node_numbers, ele_num_part + integer, dimension(:), pointer :: ele_nums + integer :: id, group_spawn, ele_spawn, proc_num + integer :: j, i, k, l, m, dim + logical :: spawn_group, coords_set, rand_set + real :: max_lcoord, rand_lcoord, rand_val + real, dimension(:), allocatable :: rand_lcoords + + proc_num = getprocno() + + !Check the ratio of particles present per group and determine which groups spawn + spawn_group = .true. + if (present(cap_percent)) then + spawn_group = .false. + do i=1,size(group_arrays) + !Check if a particle group makes up >= cap_percent of the total particles in the current control volume + assert(cap_percent>50) + if ((((node_particles(i)%length*1.0)/sum(node_particles(:)%length)*1.0)*100)>=cap_percent) then + spawn_group = .true. + group_spawn = i + end if + end do + end if + + add_particles = 0 + !Return if no groups spawn + if (.not. spawn_group) return + + !Count the number of particles per surrounding element for weighted spawning if + !not spawning based on radius from parent + if (.not. have_radius) then + ele_nums => node_neigh(xfield, node_num) + allocate(ele_num_part(size(ele_nums))) + ele_num_part = 0 + do j = 1,size(group_arrays) + particle => node_particles(j)%first + do while(associated(particle)) + do i = 1,size(ele_nums) + if (ele_nums(i) == particle%element) then + ele_num_part(i) = ele_num_part(i) + 1 + end if + end do + particle => particle%temp_next + end do + end do + end if + + !Loop over particle groups for spawning + do j = 1,size(group_arrays) + if (present(cap_percent)) then + if (j/=group_spawn) cycle + end if + !Calculated average attribute parameters based on existing particles if + !not copying parent attributes when spawning + if (.not. copy_parents) then + particle => node_particles(j)%first + if (associated(particle)) then + allocate(average_attributes(size(particle%attributes))) + allocate(average_old_attributes(size(particle%old_attributes))) + allocate(average_old_fields(size(particle%old_fields))) + average_attributes = 0 + average_old_attributes = 0 + average_old_fields = 0 + end if + do while(associated(particle)) + average_attributes = average_attributes + particle%attributes + average_old_attributes = average_old_attributes + particle%old_attributes + average_old_fields = average_old_fields + particle%old_fields + particle => particle%temp_next + end do + if (allocated(average_attributes)) then + average_attributes = average_attributes/node_particles(j)%length + average_old_attributes = average_old_attributes/node_particles(j)%length + average_old_fields = average_old_fields/node_particles(j)%length + end if + end if + + !Determine id, size and shape of spawned particle parameters + temp_part => particle_lists(group_arrays(j))%last + if (associated(temp_part)) then + id = particle_lists(group_arrays(j))%proc_part_count + allocate(node_coord(size(temp_part%local_coords))) + allocate(node_numbers(size(temp_part%local_coords))) + end if + + dim = size(node_coord)-1 + + !Spawn particles + particle => node_particles(j)%first + do while(associated(particle)) + temp_part => null() + call allocate(temp_part, size(particle%position), size(particle%local_coords), particle_lists(group_arrays(j))%total_attributes) + + temp_part%id_number = id+1 + temp_part%list_id = particle%list_id + temp_part%proc_id = proc_num + + !Check if particles are spawning within a radius around their parent, or randomly within the CV + if (have_radius) then + !Spawn particles within radius of parent particle + temp_part%element=particle%element + node_numbers(:) = ele_nodes(xfield, temp_part%element) + allocate(rand_lcoords(size(node_coord))) + coords_set=.false. + !dummy counter l to prevent infinite looping + l = 0 + !randomly select local coords within input radius around parent particle + !ensuring new particle falls within cv + do while (.not. coords_set) + rand_set=.false. + do while (.not. rand_set) + rand_lcoord=0 + call random_number(rand_val) + k = 1 + floor(size(node_coord)*rand_val) !randomly select a local_coord to be sum of other coords + do i = 1,size(node_coord) + if (node_numbers(i)==node_num) m=i + if (i==k) cycle + call random_number(rand_val) + rand_lcoords(i) = (rand_val-0.5)*2*(radius/dim) !perturb each free local_coord by +/- radius/dim + rand_lcoord = rand_lcoord + rand_lcoords(i)!sum local coord perturbations + end do + rand_lcoords(k) = -rand_lcoord !calculate final coord + if (maxval(rand_lcoords)>((radius/dim)*0.8)) then !Enforce the new particle to be at least rad/dim * 80% away + rand_set=.true. + end if + end do + node_coord(:) = particle%local_coords(:) + rand_lcoords(:) !add perturbation to spawned local_coordinates + coords_set=.true. + l = l + 1 + if ((maxloc(node_coord, 1)/=m).or.node_coord(m)>1.0) then !Not within CV or element, try again + coords_set=.false. + end if + if (minval(node_coord)<0.0) then !not within element, try again + coords_set=.false. + end if + if (l>100) then !Catch to stop infinite looping + ewrite(2,*) "loop limit reached, setting spawned coords to parent coords" + node_coord(:) = particle%local_coords(:) + coords_set=.true. + end if + end do + temp_part%local_coords = node_coord + deallocate(rand_lcoords) + else !Particles will spawn randomly in the CV, prioritizing !elements with fewer particles !randomly select adjacent element to node !Get ele numbers of adjacent elements - ele_spawn = minloc(ele_num_part, DIM=1) - temp_part%element = ele_nums(ele_spawn) - node_numbers(:) = ele_nodes(xfield, ele_nums(ele_spawn)) - call random_number(rand_val) - max_lcoord = rand_val/(1/0.49)+0.51!lcoords for cv range from 0.51 particle%temp_next - - end do - if (allocated(node_coord)) then - deallocate(node_coord) - deallocate(node_numbers) - end if - if (allocated(average_attributes)) then - deallocate(average_attributes) - deallocate(average_old_attributes) - deallocate(average_old_fields) - end if - end do - if (allocated(ele_num_part)) deallocate(ele_num_part) - - end subroutine spawn_particles - - subroutine spawn_zero_particles(node_part_count, node_particles, group_arrays, xfield, add_particles, node_num, max_thresh, copy_parents) - !Subroutine to spawn particles in a control volume with 0 'parent' particles in the CV - - !> Linked list of particles which exist on this node - type(detector_linked_list), intent(inout), dimension(:,:) :: node_particles - !> Array counting particles on all nodes - real, intent(inout), dimension(:) :: node_part_count - !> Indicies in particle_lists present - integer, intent(in), dimension(:) :: group_arrays - !> Input position field - type(vector_field), pointer, intent(in) :: xfield - !> Array to count number of particles spawned per particle group - integer, dimension(:), intent(inout) :: add_particles - !> Current node number we are working on - integer, intent(in) :: node_num - !> Maximum number of particles allowed per control volume - integer, intent(in) :: max_thresh - !> Parameter to determine spawned particle attribute values - logical, intent(in) :: copy_parents - - !> Array for element numbers associated with a node - integer, dimension(:), pointer :: ele_nums - !> Array for node numbers associated with an element - integer, allocatable, dimension(:,:) :: node_numbers - integer :: part_total - - !> Dummy particles - type(detector_type), pointer :: particle - type(detector_type), pointer :: temp_part - - !> Arrays for coordinates of nodes and distance from nodes - real, dimension(:), allocatable :: node_coord, node_loc, distance - real, dimension(:,:,:), allocatable :: ele_val - real :: max_lcoord, ratio, rand_val - - integer :: id - integer :: i, j, k, l, m, proc_num - integer, dimension(:), allocatable :: remove_particles - integer, dimension(:), allocatable :: length_group - - !Variable arrays to calculated average attribute values when not - !copying attributes from parents - type VarSizedArray - real, allocatable :: col(:) - end type VarSizedArray - type(VarSizedArray), allocatable :: average_attributes(:) - type(VarSizedArray), allocatable :: average_old_attributes(:) - type(VarSizedArray), allocatable :: average_old_fields(:) - - ewrite(1,*) "In spawn_zero_particles" - - proc_num = getprocno() - add_particles = 0 - - !Get ele numbers of adjacent elements - ele_nums => node_neigh(xfield, node_num) - - allocate(node_numbers(size(ele_nums),xfield%dim+1)) - allocate(node_coord(xfield%dim+1)) - allocate(node_loc(xfield%dim)) - allocate(ele_val(size(group_arrays),size(ele_nums),xfield%dim+1)) - - !Get node numbers for each adjacent element - do j = 1,size(ele_nums) - node_numbers(j,:) = ele_nodes(xfield,ele_nums(j)) - end do - - !Initialise average attribute arrays based on particle attributes in - !surrounding elements if not copying parent attributes - if (.not. copy_parents) then - allocate(average_attributes(size(group_arrays))) - allocate(average_old_attributes(size(group_arrays))) - allocate(average_old_fields(size(group_arrays))) - allocate(length_group(size(group_arrays))) - length_group = 0 - do i = 1,size(group_arrays) - temp_part => particle_lists(group_arrays(i))%last - if (associated(temp_part)) then - allocate(average_attributes(i)%col(size(temp_part%attributes))) - allocate(average_old_attributes(i)%col(size(temp_part%old_attributes))) - allocate(average_old_fields(i)%col(size(temp_part%old_fields))) - average_attributes(i)%col(:)=0 - average_old_attributes(i)%col(:)=0 - average_old_fields(i)%col(:)=0 - end if - end do - end if - node_loc = node_val(xfield,node_num) - ele_val(:,:,:) = 0 - part_total = 0 - !Loop over elements adjacent to control volume - do j = 1,size(ele_nums) - do k = 1,xfield%dim+1 !loop over each node of the element - if (node_numbers(j,k)==node_num) cycle !cycle if node is the node from our control volume - do i = 1,size(group_arrays) !loop over particle grouos - temp_part => node_particles(i,node_numbers(j,k))%first - allocate(distance(node_particles(i,node_numbers(j,k))%length)) - distance(:)=0 - !loop over particles in this group and determine distance from the CV node - do l = 1,node_particles(i,node_numbers(j,k))%length - do m = 1,xfield%dim - distance(l) = distance(l) + abs(node_loc(m)-temp_part%position(m))**2 - end do - distance(l) = SQRT(distance(l)) - ele_val(i,j,k) = ele_val(i,j,k) + 1/distance(l)**2!store distance values for weighting - if (.not. copy_parents) then !copy attributes to take average - average_attributes(i)%col(:) = average_attributes(i)%col(:) + temp_part%attributes(:) - average_old_attributes(i)%col(:) = average_old_attributes(i)%col(:) + temp_part%old_attributes(:) - average_old_fields(i)%col(:) = average_old_fields(i)%col(:) + temp_part%old_fields(:) - end if - temp_part => temp_part%temp_next - end do - part_total = part_total + node_particles(i,node_numbers(j,k))%length - if (.not. copy_parents) then !determine the number of particles in each group being weighted - length_group(i) = length_group(i) + node_particles(i,node_numbers(j,k))%length - end if - deallocate(distance) - end do - end do - end do - - !Return if no particles in surrounding control volumes - if (part_total==0) then - ewrite(2,*) "There are no particles present in adjacent CV's" - return - end if - - !If adjacent CV's contain particles, clone weighted particles - !from adjacent CV's into this CV - do i = 1,size(group_arrays)!Loop over particle groups - temp_part => particle_lists(group_arrays(i))%last - id = particle_lists(group_arrays(i))%proc_part_count - if (.not. copy_parents) then !take average of surrounding attributes if not copying from parent - average_attributes(i)%col(:) = average_attributes(i)%col(:)/length_group(i) - average_old_attributes(i)%col(:) = average_old_attributes(i)%col(:)/length_group(i) - average_old_fields(i)%col(:) = average_old_fields(i)%col(:)/length_group(i) - end if - !Duplicate parent particles in from surrounding CV's weighting based on distance - do j = 1,size(ele_nums)!loop over surrounding elements - do k = 1,xfield%dim+1!loop over nodes attached to element - particle => node_particles(i, node_numbers(j,k))%first - if (node_numbers(j,k)==node_num) cycle !prevent from duplicating particles spawned in this routine - if (.not. associated(particle)) cycle - if (sum(ele_val(:,j,k))==0) then - ratio=0 - else - ratio = ele_val(i,j,k)/sum(ele_val(:,j,k))!determine ratio of particles in given CV to all surrounding CV's - end if - !Spawn a number of particle from this CV based on given parameters: - !maximum particle threshold/4 * 1/number of surrounding elements * ratio - !of particles in given CV to all surrounding CV's - do l = 1,nint((max_thresh/4.0)*(1.0/size(ele_nums))*ratio) - temp_part => null() - call allocate(temp_part, size(particle%position), size(particle%local_coords), particle_lists(group_arrays(i))%total_attributes) - temp_part%id_number = id+1 - temp_part%list_id = particle%list_id - temp_part%proc_id = proc_num - temp_part%element=ele_nums(j) - !randomly select local coords within the element, ensuring coords are within cv - call random_number(rand_val) - max_lcoord=rand_val/(1/0.49)+0.51!lcoords for cv range from 0.51max_thresh) - call delete_particles(node_particles(:,node_num), group_arrays, remove_particles, node_part_count=node_part_count(node_num)) - add_particles(:) = add_particles(:) - remove_particles(:) - end do - - deallocate(remove_particles) - deallocate(node_coord) - deallocate(node_numbers) - deallocate(node_loc) - deallocate(ele_val) - if (allocated(average_attributes)) then - deallocate(average_attributes) - deallocate(average_old_attributes) - deallocate(average_old_fields) - deallocate(length_group) - end if - - end subroutine spawn_zero_particles - - subroutine set_spawned_lcoords(max_lcoord, node_coord, node_num, node_numbers) - !Subroutine to randomly set spawned particle local coordinates based off - !the maximum local coordinate given - - real, intent(inout) :: max_lcoord - real, dimension(:), intent(inout) :: node_coord - integer, intent(in) :: node_num - integer, dimension(:), intent(in) :: node_numbers - - integer, dimension(4,4) :: permutation = reshape([1,2,3,4, 2,1,3,4, 2,3,1,4, 2,3,4,1], [4,4]) - real, dimension(4) :: work - real :: tmp_res, rand_val - integer :: i, j - - max_lcoord = max(0.51, min(max_lcoord, 0.999)) - ! set up the node coordinates to be permuted - ! looks like: [x, (1 - x) * rand(), (1 - x - y) * rand(), 1 - x - y - z] - ! depending on the number of coordinates - work(1) = max_lcoord - tmp_res = 1 - max_lcoord - do j = 2, size(node_coord) - 1 - call random_number(rand_val) - work(j) = tmp_res * rand_val - tmp_res = tmp_res - work(j) - end do - work(size(node_coord)) = tmp_res - - do i = 1,size(node_coord) - ! determine the node index corresponding to the - ! target node number - if (node_num == node_numbers(i)) exit - end do - assert(i<=size(node_coord)) - ! set the coordinates according to the permutation for this index - do j = 1, size(node_coord) - node_coord(j) = work(permutation(j,i)) - end do - - end subroutine set_spawned_lcoords - - subroutine multi_delete_particles(mult, node_particles, group_arrays, summed_particles, cap_percent) - !Subroutine to call delete particles multiple times based on the mult factor - !calculated from the current number of particles and the maximum threshold - !> Factor to determine number of delete_particle calls - integer, intent(in) :: mult - !> Linked list of particles which exist on this node - type(detector_linked_list), intent(inout), dimension(:) :: node_particles - !> Indicies in particle_lists present - integer, intent(in), dimension(:) :: group_arrays - !> Array to sum deleted particles - integer, dimension(:), intent(inout) :: summed_particles - !> Parameter to determine if spawning/deleting will be capped per group - real, optional, intent(in) :: cap_percent - - integer :: i, power, j - integer, allocatable, dimension(:) :: remove_particles - logical :: power_set - - allocate(remove_particles(size(group_arrays))) - - power_set=.false. - j=0 - !Loop to find the largest power of 2 less than or equal to mult factor - do while (.not. power_set) - if (mult>=2**j) then - j=j+1 - else - power=j-1 - power_set=.true. - end if - end do - - do i = 1,power - call delete_particles(node_particles, group_arrays, remove_particles, cap_percent=cap_percent) - summed_particles=summed_particles-remove_particles - end do - - deallocate(remove_particles) - - end subroutine multi_delete_particles - - subroutine delete_particles(node_particles, group_arrays, remove_particles, cap_percent, node_part_count) - !Subroutine to delete particles in a control volume based off the number of particles present - - !> Linked list of particles which exist on this node - type(detector_linked_list), intent(inout), dimension(:) :: node_particles - !> Indicies in particle_lists present - integer, intent(in), dimension(:) :: group_arrays - !> Array to sum number of deleted particles per particle group - integer, dimension(:), intent(inout) :: remove_particles - !> Parameter to determine if spawning/deleting will be capped per group - real, optional, intent(in) :: cap_percent - !> Array counting number of deleted particles - real, optional, intent(inout) :: node_part_count - - type(detector_type), pointer :: particle - type(detector_type), pointer :: temp_part - - logical :: delete_group - integer :: j - real :: rand_val - - !Check ratio of each particle group present and which groups will be deleted - delete_group = .true. - if (present(cap_percent)) then - delete_group = .false. - do j=1,size(group_arrays) - !Check if a particle group makes up >= cap_percent of the total particles in the current control volume - assert(cap_percent>50) - if ((((node_particles(j)%length*1.0)/sum(node_particles(:)%length)*1.0)*100)>=cap_percent) then - delete_group = .true. - end if - end do - end if - - remove_particles = 0 - - !return if no group is being deleted - if (.not. delete_group) return - - !loop over all particles in each particle group, flip a coin, if coin is heads (r>0.5) delete the particle - do j = 1,size(group_arrays) - particle =>node_particles(j)%first - do while(associated(particle)) - call random_number(rand_val) - if (rand_val>0.5) then !Delete the particle - !Remove from particle list - call remove(particle,particle_lists(group_arrays(j))) - temp_part =>particle%temp_next - !Remove from temp list - call temp_list_remove(particle,node_particles(j)) - remove_particles(j)=remove_particles(j)+1 - if (present(node_part_count)) node_part_count = node_part_count - 1 - call deallocate(particle) - end if - if (associated(particle)) then - particle => particle%temp_next - else - particle =>temp_part - temp_part => null() - end if - end do - end do - - end subroutine delete_particles + ele_spawn = minloc(ele_num_part, DIM=1) + temp_part%element = ele_nums(ele_spawn) + node_numbers(:) = ele_nodes(xfield, ele_nums(ele_spawn)) + call random_number(rand_val) + max_lcoord = rand_val/(1/0.49)+0.51!lcoords for cv range from 0.51 particle%temp_next + + end do + if (allocated(node_coord)) then + deallocate(node_coord) + deallocate(node_numbers) + end if + if (allocated(average_attributes)) then + deallocate(average_attributes) + deallocate(average_old_attributes) + deallocate(average_old_fields) + end if + end do + if (allocated(ele_num_part)) deallocate(ele_num_part) + + end subroutine spawn_particles + + subroutine spawn_zero_particles(node_part_count, node_particles, group_arrays, xfield, add_particles, node_num, max_thresh, copy_parents) + !Subroutine to spawn particles in a control volume with 0 'parent' particles in the CV + + !> Linked list of particles which exist on this node + type(detector_linked_list), intent(inout), dimension(:,:) :: node_particles + !> Array counting particles on all nodes + real, intent(inout), dimension(:) :: node_part_count + !> Indicies in particle_lists present + integer, intent(in), dimension(:) :: group_arrays + !> Input position field + type(vector_field), pointer, intent(in) :: xfield + !> Array to count number of particles spawned per particle group + integer, dimension(:), intent(inout) :: add_particles + !> Current node number we are working on + integer, intent(in) :: node_num + !> Maximum number of particles allowed per control volume + integer, intent(in) :: max_thresh + !> Parameter to determine spawned particle attribute values + logical, intent(in) :: copy_parents + + !> Array for element numbers associated with a node + integer, dimension(:), pointer :: ele_nums + !> Array for node numbers associated with an element + integer, allocatable, dimension(:,:) :: node_numbers + integer :: part_total + + !> Dummy particles + type(detector_type), pointer :: particle + type(detector_type), pointer :: temp_part + + !> Arrays for coordinates of nodes and distance from nodes + real, dimension(:), allocatable :: node_coord, node_loc, distance + real, dimension(:,:,:), allocatable :: ele_val + real :: max_lcoord, ratio, rand_val + + integer :: id + integer :: i, j, k, l, m, proc_num + integer, dimension(:), allocatable :: remove_particles + integer, dimension(:), allocatable :: length_group + + !Variable arrays to calculated average attribute values when not + !copying attributes from parents + type VarSizedArray + real, allocatable :: col(:) + end type VarSizedArray + type(VarSizedArray), allocatable :: average_attributes(:) + type(VarSizedArray), allocatable :: average_old_attributes(:) + type(VarSizedArray), allocatable :: average_old_fields(:) + + ewrite(1,*) "In spawn_zero_particles" + + proc_num = getprocno() + add_particles = 0 + + !Get ele numbers of adjacent elements + ele_nums => node_neigh(xfield, node_num) + + allocate(node_numbers(size(ele_nums),xfield%dim+1)) + allocate(node_coord(xfield%dim+1)) + allocate(node_loc(xfield%dim)) + allocate(ele_val(size(group_arrays),size(ele_nums),xfield%dim+1)) + + !Get node numbers for each adjacent element + do j = 1,size(ele_nums) + node_numbers(j,:) = ele_nodes(xfield,ele_nums(j)) + end do + + !Initialise average attribute arrays based on particle attributes in + !surrounding elements if not copying parent attributes + if (.not. copy_parents) then + allocate(average_attributes(size(group_arrays))) + allocate(average_old_attributes(size(group_arrays))) + allocate(average_old_fields(size(group_arrays))) + allocate(length_group(size(group_arrays))) + length_group = 0 + do i = 1,size(group_arrays) + temp_part => particle_lists(group_arrays(i))%last + if (associated(temp_part)) then + allocate(average_attributes(i)%col(size(temp_part%attributes))) + allocate(average_old_attributes(i)%col(size(temp_part%old_attributes))) + allocate(average_old_fields(i)%col(size(temp_part%old_fields))) + average_attributes(i)%col(:)=0 + average_old_attributes(i)%col(:)=0 + average_old_fields(i)%col(:)=0 + end if + end do + end if + node_loc = node_val(xfield,node_num) + ele_val(:,:,:) = 0 + part_total = 0 + !Loop over elements adjacent to control volume + do j = 1,size(ele_nums) + do k = 1,xfield%dim+1 !loop over each node of the element + if (node_numbers(j,k)==node_num) cycle !cycle if node is the node from our control volume + do i = 1,size(group_arrays) !loop over particle grouos + temp_part => node_particles(i,node_numbers(j,k))%first + allocate(distance(node_particles(i,node_numbers(j,k))%length)) + distance(:)=0 + !loop over particles in this group and determine distance from the CV node + do l = 1,node_particles(i,node_numbers(j,k))%length + do m = 1,xfield%dim + distance(l) = distance(l) + abs(node_loc(m)-temp_part%position(m))**2 + end do + distance(l) = SQRT(distance(l)) + ele_val(i,j,k) = ele_val(i,j,k) + 1/distance(l)**2!store distance values for weighting + if (.not. copy_parents) then !copy attributes to take average + average_attributes(i)%col(:) = average_attributes(i)%col(:) + temp_part%attributes(:) + average_old_attributes(i)%col(:) = average_old_attributes(i)%col(:) + temp_part%old_attributes(:) + average_old_fields(i)%col(:) = average_old_fields(i)%col(:) + temp_part%old_fields(:) + end if + temp_part => temp_part%temp_next + end do + part_total = part_total + node_particles(i,node_numbers(j,k))%length + if (.not. copy_parents) then !determine the number of particles in each group being weighted + length_group(i) = length_group(i) + node_particles(i,node_numbers(j,k))%length + end if + deallocate(distance) + end do + end do + end do + + !Return if no particles in surrounding control volumes + if (part_total==0) then + ewrite(2,*) "There are no particles present in adjacent CV's" + return + end if + + !If adjacent CV's contain particles, clone weighted particles + !from adjacent CV's into this CV + do i = 1,size(group_arrays)!Loop over particle groups + temp_part => particle_lists(group_arrays(i))%last + id = particle_lists(group_arrays(i))%proc_part_count + if (.not. copy_parents) then !take average of surrounding attributes if not copying from parent + average_attributes(i)%col(:) = average_attributes(i)%col(:)/length_group(i) + average_old_attributes(i)%col(:) = average_old_attributes(i)%col(:)/length_group(i) + average_old_fields(i)%col(:) = average_old_fields(i)%col(:)/length_group(i) + end if + !Duplicate parent particles in from surrounding CV's weighting based on distance + do j = 1,size(ele_nums)!loop over surrounding elements + do k = 1,xfield%dim+1!loop over nodes attached to element + particle => node_particles(i, node_numbers(j,k))%first + if (node_numbers(j,k)==node_num) cycle !prevent from duplicating particles spawned in this routine + if (.not. associated(particle)) cycle + if (sum(ele_val(:,j,k))==0) then + ratio=0 + else + ratio = ele_val(i,j,k)/sum(ele_val(:,j,k))!determine ratio of particles in given CV to all surrounding CV's + end if + !Spawn a number of particle from this CV based on given parameters: + !maximum particle threshold/4 * 1/number of surrounding elements * ratio + !of particles in given CV to all surrounding CV's + do l = 1,nint((max_thresh/4.0)*(1.0/size(ele_nums))*ratio) + temp_part => null() + call allocate(temp_part, size(particle%position), size(particle%local_coords), particle_lists(group_arrays(i))%total_attributes) + temp_part%id_number = id+1 + temp_part%list_id = particle%list_id + temp_part%proc_id = proc_num + temp_part%element=ele_nums(j) + !randomly select local coords within the element, ensuring coords are within cv + call random_number(rand_val) + max_lcoord=rand_val/(1/0.49)+0.51!lcoords for cv range from 0.51max_thresh) + call delete_particles(node_particles(:,node_num), group_arrays, remove_particles, node_part_count=node_part_count(node_num)) + add_particles(:) = add_particles(:) - remove_particles(:) + end do + + deallocate(remove_particles) + deallocate(node_coord) + deallocate(node_numbers) + deallocate(node_loc) + deallocate(ele_val) + if (allocated(average_attributes)) then + deallocate(average_attributes) + deallocate(average_old_attributes) + deallocate(average_old_fields) + deallocate(length_group) + end if + + end subroutine spawn_zero_particles + + subroutine set_spawned_lcoords(max_lcoord, node_coord, node_num, node_numbers) + !Subroutine to randomly set spawned particle local coordinates based off + !the maximum local coordinate given + + real, intent(inout) :: max_lcoord + real, dimension(:), intent(inout) :: node_coord + integer, intent(in) :: node_num + integer, dimension(:), intent(in) :: node_numbers + + integer, dimension(4,4) :: permutation = reshape([1,2,3,4, 2,1,3,4, 2,3,1,4, 2,3,4,1], [4,4]) + real, dimension(4) :: work + real :: tmp_res, rand_val + integer :: i, j + + max_lcoord = max(0.51, min(max_lcoord, 0.999)) + ! set up the node coordinates to be permuted + ! looks like: [x, (1 - x) * rand(), (1 - x - y) * rand(), 1 - x - y - z] + ! depending on the number of coordinates + work(1) = max_lcoord + tmp_res = 1 - max_lcoord + do j = 2, size(node_coord) - 1 + call random_number(rand_val) + work(j) = tmp_res * rand_val + tmp_res = tmp_res - work(j) + end do + work(size(node_coord)) = tmp_res + + do i = 1,size(node_coord) + ! determine the node index corresponding to the + ! target node number + if (node_num == node_numbers(i)) exit + end do + assert(i<=size(node_coord)) + ! set the coordinates according to the permutation for this index + do j = 1, size(node_coord) + node_coord(j) = work(permutation(j,i)) + end do + + end subroutine set_spawned_lcoords + + subroutine multi_delete_particles(mult, node_particles, group_arrays, summed_particles, cap_percent) + !Subroutine to call delete particles multiple times based on the mult factor + !calculated from the current number of particles and the maximum threshold + !> Factor to determine number of delete_particle calls + integer, intent(in) :: mult + !> Linked list of particles which exist on this node + type(detector_linked_list), intent(inout), dimension(:) :: node_particles + !> Indicies in particle_lists present + integer, intent(in), dimension(:) :: group_arrays + !> Array to sum deleted particles + integer, dimension(:), intent(inout) :: summed_particles + !> Parameter to determine if spawning/deleting will be capped per group + real, optional, intent(in) :: cap_percent + + integer :: i, power, j + integer, allocatable, dimension(:) :: remove_particles + logical :: power_set + + allocate(remove_particles(size(group_arrays))) + + power_set=.false. + j=0 + !Loop to find the largest power of 2 less than or equal to mult factor + do while (.not. power_set) + if (mult>=2**j) then + j=j+1 + else + power=j-1 + power_set=.true. + end if + end do + + do i = 1,power + call delete_particles(node_particles, group_arrays, remove_particles, cap_percent=cap_percent) + summed_particles=summed_particles-remove_particles + end do + + deallocate(remove_particles) + + end subroutine multi_delete_particles + + subroutine delete_particles(node_particles, group_arrays, remove_particles, cap_percent, node_part_count) + !Subroutine to delete particles in a control volume based off the number of particles present + + !> Linked list of particles which exist on this node + type(detector_linked_list), intent(inout), dimension(:) :: node_particles + !> Indicies in particle_lists present + integer, intent(in), dimension(:) :: group_arrays + !> Array to sum number of deleted particles per particle group + integer, dimension(:), intent(inout) :: remove_particles + !> Parameter to determine if spawning/deleting will be capped per group + real, optional, intent(in) :: cap_percent + !> Array counting number of deleted particles + real, optional, intent(inout) :: node_part_count + + type(detector_type), pointer :: particle + type(detector_type), pointer :: temp_part + + logical :: delete_group + integer :: j + real :: rand_val + + !Check ratio of each particle group present and which groups will be deleted + delete_group = .true. + if (present(cap_percent)) then + delete_group = .false. + do j=1,size(group_arrays) + !Check if a particle group makes up >= cap_percent of the total particles in the current control volume + assert(cap_percent>50) + if ((((node_particles(j)%length*1.0)/sum(node_particles(:)%length)*1.0)*100)>=cap_percent) then + delete_group = .true. + end if + end do + end if + + remove_particles = 0 + + !return if no group is being deleted + if (.not. delete_group) return + + !loop over all particles in each particle group, flip a coin, if coin is heads (r>0.5) delete the particle + do j = 1,size(group_arrays) + particle =>node_particles(j)%first + do while(associated(particle)) + call random_number(rand_val) + if (rand_val>0.5) then !Delete the particle + !Remove from particle list + call remove(particle,particle_lists(group_arrays(j))) + temp_part =>particle%temp_next + !Remove from temp list + call temp_list_remove(particle,node_particles(j)) + remove_particles(j)=remove_particles(j)+1 + if (present(node_part_count)) node_part_count = node_part_count - 1 + call deallocate(particle) + end if + if (associated(particle)) then + particle => particle%temp_next + else + particle =>temp_part + temp_part => null() + end if + end do + end do + + end subroutine delete_particles end module particle_diagnostics diff --git a/assemble/Petsc_Solve_State.F90 b/assemble/Petsc_Solve_State.F90 index 60c0a369bc..84b5340be9 100644 --- a/assemble/Petsc_Solve_State.F90 +++ b/assemble/Petsc_Solve_State.F90 @@ -35,391 +35,391 @@ module petsc_solve_state_module !!< This is put in a separate module as the way this information is stored !!< in state is fluidity specific and should therefore not be dealt with !!< in femtools/. -use spud -use fldebug -use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN -use sparse_tools -use parallel_fields -use fields -use sparse_tools_petsc -use state_module -use solvers -use field_options + use spud + use fldebug + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use sparse_tools + use parallel_fields + use fields + use sparse_tools_petsc + use state_module + use solvers + use field_options ! modules from assemble: -use free_surface_module -implicit none + use free_surface_module + implicit none -interface petsc_solve - module procedure petsc_solve_scalar_state, & - petsc_solve_scalar_state_petsc_csr, & - petsc_solve_vector_state_petsc_csr -end interface + interface petsc_solve + module procedure petsc_solve_scalar_state, & + petsc_solve_scalar_state_petsc_csr, & + petsc_solve_vector_state_petsc_csr + end interface -private -public petsc_solve, petsc_solve_needs_state, & - petsc_solve_state_setup + private + public petsc_solve, petsc_solve_needs_state, & + petsc_solve_state_setup contains - subroutine petsc_solve_scalar_state(x, matrix, rhs, state, & - option_path, iterations_taken) - !!< Solve a linear system the nice way. - !!< This version uses state to pull geometric information from - !!< if required for the specified options. - type(scalar_field), intent(inout) :: x - type(scalar_field), intent(in) :: rhs - type(csr_matrix), intent(in) :: matrix - type(state_type), intent(in):: state - !! override x%option_path if provided: - character(len=*), optional, intent(in):: option_path - !! the number of petsc iterations taken - integer, intent(out), optional :: iterations_taken + subroutine petsc_solve_scalar_state(x, matrix, rhs, state, & + option_path, iterations_taken) + !!< Solve a linear system the nice way. + !!< This version uses state to pull geometric information from + !!< if required for the specified options. + type(scalar_field), intent(inout) :: x + type(scalar_field), intent(in) :: rhs + type(csr_matrix), intent(in) :: matrix + type(state_type), intent(in):: state + !! override x%option_path if provided: + character(len=*), optional, intent(in):: option_path + !! the number of petsc iterations taken + integer, intent(out), optional :: iterations_taken - integer, dimension(:), pointer:: surface_nodes - type(petsc_csr_matrix), dimension(:), pointer:: prolongators - character(len=OPTION_PATH_LEN):: solver_option_path - integer:: i + integer, dimension(:), pointer:: surface_nodes + type(petsc_csr_matrix), dimension(:), pointer:: prolongators + character(len=OPTION_PATH_LEN):: solver_option_path + integer:: i - call petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & - state, x%mesh, 1, x%option_path, has_solver_cache(matrix), option_path=option_path) + call petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & + state, x%mesh, 1, x%option_path, has_solver_cache(matrix), option_path=option_path) - if (associated(prolongators)) then + if (associated(prolongators)) then - if (associated(surface_nodes)) then + if (associated(surface_nodes)) then - call petsc_solve(x, matrix, rhs, & - prolongators=prolongators, & - surface_node_list=surface_nodes, option_path=option_path, & - iterations_taken = iterations_taken) + call petsc_solve(x, matrix, rhs, & + prolongators=prolongators, & + surface_node_list=surface_nodes, option_path=option_path, & + iterations_taken = iterations_taken) - deallocate(surface_nodes) + deallocate(surface_nodes) + + else + + call petsc_solve(x, matrix, rhs, & + prolongators=prolongators, option_path=option_path, & + iterations_taken = iterations_taken) + + end if + + do i=1, size(prolongators) + call deallocate(prolongators(i)) + end do + deallocate(prolongators) else - call petsc_solve(x, matrix, rhs, & - prolongators=prolongators, option_path=option_path, & - iterations_taken = iterations_taken) + call petsc_solve(x, matrix, rhs, option_path=option_path, & + iterations_taken = iterations_taken) end if - do i=1, size(prolongators) - call deallocate(prolongators(i)) - end do - deallocate(prolongators) + end subroutine petsc_solve_scalar_state - else + subroutine petsc_solve_scalar_state_petsc_csr(x, matrix, rhs, state, & + option_path) + !!< Solve a linear system the nice way. + !!< This version uses state to pull geometric information from + !!< if required for the specified options. + type(scalar_field), intent(inout) :: x + type(scalar_field), intent(in) :: rhs + type(petsc_csr_matrix), intent(inout) :: matrix + type(state_type), intent(in):: state + !! override x%option_path if provided: + character(len=*), optional, intent(in):: option_path - call petsc_solve(x, matrix, rhs, option_path=option_path, & - iterations_taken = iterations_taken) + integer, dimension(:), pointer:: surface_nodes + type(petsc_csr_matrix), dimension(:), pointer:: prolongators + character(len=OPTION_PATH_LEN):: solver_option_path + integer:: i - end if + ! no solver cache for petsc_csr_matrices at the mo' + call petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & + state, x%mesh, 1, x%option_path, .false., option_path=option_path) - end subroutine petsc_solve_scalar_state + if (associated(prolongators)) then - subroutine petsc_solve_scalar_state_petsc_csr(x, matrix, rhs, state, & - option_path) - !!< Solve a linear system the nice way. - !!< This version uses state to pull geometric information from - !!< if required for the specified options. - type(scalar_field), intent(inout) :: x - type(scalar_field), intent(in) :: rhs - type(petsc_csr_matrix), intent(inout) :: matrix - type(state_type), intent(in):: state - !! override x%option_path if provided: - character(len=*), optional, intent(in):: option_path + if (associated(surface_nodes)) then - integer, dimension(:), pointer:: surface_nodes - type(petsc_csr_matrix), dimension(:), pointer:: prolongators - character(len=OPTION_PATH_LEN):: solver_option_path - integer:: i + call petsc_solve(x, matrix, rhs, & + prolongators=prolongators, & + surface_node_list=surface_nodes, option_path=option_path) - ! no solver cache for petsc_csr_matrices at the mo' - call petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & - state, x%mesh, 1, x%option_path, .false., option_path=option_path) + deallocate(surface_nodes) - if (associated(prolongators)) then + else - if (associated(surface_nodes)) then + call petsc_solve(x, matrix, rhs, & + prolongators=prolongators, option_path=option_path) - call petsc_solve(x, matrix, rhs, & - prolongators=prolongators, & - surface_node_list=surface_nodes, option_path=option_path) + end if - deallocate(surface_nodes) + do i=1, size(prolongators) + call deallocate(prolongators(i)) + end do + deallocate(prolongators) else - call petsc_solve(x, matrix, rhs, & - prolongators=prolongators, option_path=option_path) + call petsc_solve(x, matrix, rhs, option_path=option_path) end if - do i=1, size(prolongators) - call deallocate(prolongators(i)) - end do - deallocate(prolongators) - - else - - call petsc_solve(x, matrix, rhs, option_path=option_path) - - end if - - end subroutine petsc_solve_scalar_state_petsc_csr - - subroutine petsc_solve_vector_state_petsc_csr(x, matrix, rhs, state, & - option_path) - !!< Solve a linear system the nice way. - !!< This version uses state to pull geometric information from - !!< if required for the specified options. - type(vector_field), intent(inout) :: x - type(vector_field), intent(in) :: rhs - type(petsc_csr_matrix), intent(inout) :: matrix - type(state_type), intent(in):: state - !! override x%option_path if provided: - character(len=*), optional, intent(in):: option_path - - type(vector_field), pointer :: mesh_positions - integer, dimension(:), pointer:: surface_nodes - type(petsc_csr_matrix), dimension(:), pointer:: prolongators - character(len=OPTION_PATH_LEN):: solver_option_path - type(petsc_csr_matrix), pointer:: rotation_matrix - integer:: i, rotation_stat - - ! no solver cache for petsc_csr_matrices at the mo' - call petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & - state, x%mesh, x%dim, x%option_path, .false., option_path=option_path, & - mesh_positions=mesh_positions) - - rotation_matrix => extract_petsc_csr_matrix(state, "RotationMatrix", stat=rotation_stat) - if (rotation_stat==0 .and. associated(prolongators)) then - FLExit("Rotated boundary conditions do not work with mg prolongators in the velocity solve") - end if - - if (associated(prolongators) .and. associated(mesh_positions)) then - call petsc_solve(x, matrix, rhs, & - prolongators=prolongators, option_path=option_path, positions=mesh_positions) - else if (associated(prolongators)) then - call petsc_solve(x, matrix, rhs, & - prolongators=prolongators, option_path=option_path) - else if (associated(mesh_positions) .and. rotation_stat==0) then - call petsc_solve(x, matrix, rhs, option_path=option_path, positions=mesh_positions, & - rotation_matrix=rotation_matrix%M) - else if (associated(mesh_positions)) then - call petsc_solve(x, matrix, rhs, option_path=option_path, positions=mesh_positions) - else if (rotation_stat==0) then - call petsc_solve(x, matrix, rhs, option_path=option_path, rotation_matrix=rotation_matrix%M) - else - call petsc_solve(x, matrix, rhs, option_path=option_path) - end if - - if (associated(mesh_positions)) then - call deallocate(mesh_positions) - deallocate(mesh_positions) - end if - - if (associated(prolongators)) then - do i=1, size(prolongators) - call deallocate(prolongators(i)) - end do - deallocate(prolongators) - end if - - end subroutine petsc_solve_vector_state_petsc_csr - - subroutine petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & - state, mesh, field_dim, field_option_path, matrix_has_solver_cache, option_path, & - mesh_positions) - ! sets up monitors and returns solver_option_path, - ! and prolongators and surface_nodes to be used in "mg" preconditioner - character(len=*), intent(out):: solver_option_path - ! if associated on return, this array of prolongators should be passed into petsc_solve - type(petsc_csr_matrix), dimension(:), pointer:: prolongators - ! if associated on return, this array of surface_nodes should be passed into petsc_solve - integer, dimension(:), pointer:: surface_nodes - - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh ! mesh we're solving on - integer, intent(in):: field_dim ! dimension of the field - ! option_path of the provided field: - character(len=*), intent(in):: field_option_path - logical, intent(in):: matrix_has_solver_cache - ! optional option_path that may be provided to override field option_path - character(len=*), intent(in), optional:: option_path - ! if associated on return, this mesh_positions field should be passed into petsc_solve - ! currently only for vector solves - type(vector_field), pointer, optional:: mesh_positions - - type(vector_field):: positions - type(scalar_field), pointer:: exact - type(mesh_type), pointer:: linear_mesh - character(len=FIELD_NAME_LEN):: exact_field_name - logical:: vertical_lumping, higher_order_lumping - integer:: stat, no_prolongators - - if (present(option_path)) then - solver_option_path=complete_solver_option_path(option_path) - else - solver_option_path=complete_solver_option_path(field_option_path) - end if - - call get_option(trim(solver_option_path)// & - '/diagnostics/monitors/true_error/exact_solution_field', & - exact_field_name, stat=stat) - if (stat==0) then - exact => extract_scalar_field(state, exact_field_name) - call petsc_solve_monitor_exact(exact) - end if - - if (have_option(trim(solver_option_path)// & - '/diagnostics/monitors/iteration_vtus')) then - positions=get_nodal_coordinate_field(state, mesh) - ! creates its own reference that's cleaned up in petsc_solve: - call petsc_solve_monitor_iteration_vtus(positions) - ! so we're free to get rid of ours - call deallocate(positions) - end if - - nullify(prolongators) - nullify(surface_nodes) - - higher_order_lumping = have_option(trim(solver_option_path)//'/preconditioner::mg/higher_order_lumping') - vertical_lumping = have_option(trim(solver_option_path)//'/preconditioner::mg/vertical_lumping') - no_prolongators = count( (/ higher_order_lumping, vertical_lumping /) ) - - ! if the solver context has been cached from last time, we don't - ! need to recreate the prolongation operators for "mg" - if (no_prolongators>0 .and. .not. matrix_has_solver_cache) then - allocate( prolongators(1:no_prolongators) ) - if (higher_order_lumping) then - call find_linear_parent_mesh(state, mesh, linear_mesh) - prolongators(1) = higher_order_prolongator(linear_mesh, mesh, field_dim) + end subroutine petsc_solve_scalar_state_petsc_csr + + subroutine petsc_solve_vector_state_petsc_csr(x, matrix, rhs, state, & + option_path) + !!< Solve a linear system the nice way. + !!< This version uses state to pull geometric information from + !!< if required for the specified options. + type(vector_field), intent(inout) :: x + type(vector_field), intent(in) :: rhs + type(petsc_csr_matrix), intent(inout) :: matrix + type(state_type), intent(in):: state + !! override x%option_path if provided: + character(len=*), optional, intent(in):: option_path + + type(vector_field), pointer :: mesh_positions + integer, dimension(:), pointer:: surface_nodes + type(petsc_csr_matrix), dimension(:), pointer:: prolongators + character(len=OPTION_PATH_LEN):: solver_option_path + type(petsc_csr_matrix), pointer:: rotation_matrix + integer:: i, rotation_stat + + ! no solver cache for petsc_csr_matrices at the mo' + call petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & + state, x%mesh, x%dim, x%option_path, .false., option_path=option_path, & + mesh_positions=mesh_positions) + + rotation_matrix => extract_petsc_csr_matrix(state, "RotationMatrix", stat=rotation_stat) + if (rotation_stat==0 .and. associated(prolongators)) then + FLExit("Rotated boundary conditions do not work with mg prolongators in the velocity solve") + end if + + if (associated(prolongators) .and. associated(mesh_positions)) then + call petsc_solve(x, matrix, rhs, & + prolongators=prolongators, option_path=option_path, positions=mesh_positions) + else if (associated(prolongators)) then + call petsc_solve(x, matrix, rhs, & + prolongators=prolongators, option_path=option_path) + else if (associated(mesh_positions) .and. rotation_stat==0) then + call petsc_solve(x, matrix, rhs, option_path=option_path, positions=mesh_positions, & + rotation_matrix=rotation_matrix%M) + else if (associated(mesh_positions)) then + call petsc_solve(x, matrix, rhs, option_path=option_path, positions=mesh_positions) + else if (rotation_stat==0) then + call petsc_solve(x, matrix, rhs, option_path=option_path, rotation_matrix=rotation_matrix%M) + else + call petsc_solve(x, matrix, rhs, option_path=option_path) + end if + + if (associated(mesh_positions)) then + call deallocate(mesh_positions) + deallocate(mesh_positions) + end if + + if (associated(prolongators)) then + do i=1, size(prolongators) + call deallocate(prolongators(i)) + end do + deallocate(prolongators) + end if + + end subroutine petsc_solve_vector_state_petsc_csr + + subroutine petsc_solve_state_setup(solver_option_path, prolongators, surface_nodes, & + state, mesh, field_dim, field_option_path, matrix_has_solver_cache, option_path, & + mesh_positions) + ! sets up monitors and returns solver_option_path, + ! and prolongators and surface_nodes to be used in "mg" preconditioner + character(len=*), intent(out):: solver_option_path + ! if associated on return, this array of prolongators should be passed into petsc_solve + type(petsc_csr_matrix), dimension(:), pointer:: prolongators + ! if associated on return, this array of surface_nodes should be passed into petsc_solve + integer, dimension(:), pointer:: surface_nodes + + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh ! mesh we're solving on + integer, intent(in):: field_dim ! dimension of the field + ! option_path of the provided field: + character(len=*), intent(in):: field_option_path + logical, intent(in):: matrix_has_solver_cache + ! optional option_path that may be provided to override field option_path + character(len=*), intent(in), optional:: option_path + ! if associated on return, this mesh_positions field should be passed into petsc_solve + ! currently only for vector solves + type(vector_field), pointer, optional:: mesh_positions + + type(vector_field):: positions + type(scalar_field), pointer:: exact + type(mesh_type), pointer:: linear_mesh + character(len=FIELD_NAME_LEN):: exact_field_name + logical:: vertical_lumping, higher_order_lumping + integer:: stat, no_prolongators + + if (present(option_path)) then + solver_option_path=complete_solver_option_path(option_path) + else + solver_option_path=complete_solver_option_path(field_option_path) end if - if (vertical_lumping) then - if (field_dim>1) then - FLExit("Cannot use vertical_lumping for vector fields") - end if - if (higher_order_lumping) then - prolongators(2) = vertical_prolongator_from_free_surface(state, linear_mesh) - else - prolongators(1) = vertical_prolongator_from_free_surface(state, mesh) - end if - if (have_option(trim(solver_option_path)//'/preconditioner::mg/vertical_lumping/internal_smoother')) then - surface_nodes => free_surface_nodes(state, mesh) - end if + + call get_option(trim(solver_option_path)// & + '/diagnostics/monitors/true_error/exact_solution_field', & + exact_field_name, stat=stat) + if (stat==0) then + exact => extract_scalar_field(state, exact_field_name) + call petsc_solve_monitor_exact(exact) end if - end if - if (petsc_solve_needs_positions(solver_option_path)) then - if (.not. present(mesh_positions)) then - ! currently this option only exists for vector solves, if it occurs in other places - ! mesh_positions should be passed down - FLAbort("mesh_positions should have been present") + if (have_option(trim(solver_option_path)// & + '/diagnostics/monitors/iteration_vtus')) then + positions=get_nodal_coordinate_field(state, mesh) + ! creates its own reference that's cleaned up in petsc_solve: + call petsc_solve_monitor_iteration_vtus(positions) + ! so we're free to get rid of ours + call deallocate(positions) end if - allocate(mesh_positions) - ! get the positions of the nodes - for periodic this gives the aliased positions, is that right? who knows... - mesh_positions = get_nodal_coordinate_field(state, mesh) - else if (present(mesh_positions)) then - nullify(mesh_positions) - end if - - end subroutine petsc_solve_state_setup - - logical function petsc_solve_needs_state(option_path) - ! function used in petsc_readnsolve to work out whether it needs - ! to read state and call the above petsc_solve_state, or can just - ! go for the simple petsc_solve instead - character(len=*), intent(in):: option_path - - character(len=OPTION_PATH_LEN) solver_option_path - - solver_option_path=complete_solver_option_path(option_path) - - petsc_solve_needs_state=have_option( & - trim(solver_option_path)//'/preconditioner::mg/vertical_lumping') & - .or. have_option( & - trim(solver_option_path)//'/preconditioner::mg/higher_order_lumping') & - .or. have_option( & - trim(solver_option_path)//'/diagnostics/monitors/true_error') & - .or. have_option( & - trim(solver_option_path)//'/diagnostics/monitors/iteration_vtus') & - .or. petsc_solve_needs_positions(solver_option_path) - - end function petsc_solve_needs_state - - function higher_order_prolongator(p1_mesh, pn_mesh, ncomponents) result (P) - ! Creates the linear operator that extrapolates p1 fields to higher - ! order pn meshes. This can be used as the first stage prolongator - ! in the "mg" multigrid preconditioner - type(mesh_type), intent(in):: p1_mesh, pn_mesh - integer, intent(in):: ncomponents - type(petsc_csr_matrix):: P - - logical, dimension(:), allocatable:: nodes_visited - integer, dimension(:), allocatable:: onnz, dnnz - integer, dimension(:), pointer:: p1_nodes, pn_nodes - integer:: rows, columns - integer:: i, j, k, node, ele - real, dimension(p1_mesh%shape%loc):: N - - rows=nowned_nodes(pn_mesh) - columns=node_count(p1_mesh) - allocate(dnnz(1:rows*ncomponents), onnz(1:rows*ncomponents)) - - dnnz=0 - onnz=0 - do ele=1, ele_count(pn_mesh) - pn_nodes => ele_nodes(pn_mesh, ele) - p1_nodes => ele_nodes(p1_mesh, ele) - do j=1, size(pn_nodes) - node=pn_nodes(j) - if (node_owned(pn_mesh, node)) then - do k=1, size(p1_nodes) - if (node_owned(p1_mesh, p1_nodes(k))) then - dnnz(node)=dnnz(node)+1 + + nullify(prolongators) + nullify(surface_nodes) + + higher_order_lumping = have_option(trim(solver_option_path)//'/preconditioner::mg/higher_order_lumping') + vertical_lumping = have_option(trim(solver_option_path)//'/preconditioner::mg/vertical_lumping') + no_prolongators = count( (/ higher_order_lumping, vertical_lumping /) ) + + ! if the solver context has been cached from last time, we don't + ! need to recreate the prolongation operators for "mg" + if (no_prolongators>0 .and. .not. matrix_has_solver_cache) then + allocate( prolongators(1:no_prolongators) ) + if (higher_order_lumping) then + call find_linear_parent_mesh(state, mesh, linear_mesh) + prolongators(1) = higher_order_prolongator(linear_mesh, mesh, field_dim) + end if + if (vertical_lumping) then + if (field_dim>1) then + FLExit("Cannot use vertical_lumping for vector fields") + end if + if (higher_order_lumping) then + prolongators(2) = vertical_prolongator_from_free_surface(state, linear_mesh) else - onnz(node)=onnz(node)+1 + prolongators(1) = vertical_prolongator_from_free_surface(state, mesh) + end if + if (have_option(trim(solver_option_path)//'/preconditioner::mg/vertical_lumping/internal_smoother')) then + surface_nodes => free_surface_nodes(state, mesh) end if - end do - end if + end if + end if + + if (petsc_solve_needs_positions(solver_option_path)) then + if (.not. present(mesh_positions)) then + ! currently this option only exists for vector solves, if it occurs in other places + ! mesh_positions should be passed down + FLAbort("mesh_positions should have been present") + end if + allocate(mesh_positions) + ! get the positions of the nodes - for periodic this gives the aliased positions, is that right? who knows... + mesh_positions = get_nodal_coordinate_field(state, mesh) + else if (present(mesh_positions)) then + nullify(mesh_positions) + end if + + end subroutine petsc_solve_state_setup + + logical function petsc_solve_needs_state(option_path) + ! function used in petsc_readnsolve to work out whether it needs + ! to read state and call the above petsc_solve_state, or can just + ! go for the simple petsc_solve instead + character(len=*), intent(in):: option_path + + character(len=OPTION_PATH_LEN) solver_option_path + + solver_option_path=complete_solver_option_path(option_path) + + petsc_solve_needs_state=have_option( & + trim(solver_option_path)//'/preconditioner::mg/vertical_lumping') & + .or. have_option( & + trim(solver_option_path)//'/preconditioner::mg/higher_order_lumping') & + .or. have_option( & + trim(solver_option_path)//'/diagnostics/monitors/true_error') & + .or. have_option( & + trim(solver_option_path)//'/diagnostics/monitors/iteration_vtus') & + .or. petsc_solve_needs_positions(solver_option_path) + + end function petsc_solve_needs_state + + function higher_order_prolongator(p1_mesh, pn_mesh, ncomponents) result (P) + ! Creates the linear operator that extrapolates p1 fields to higher + ! order pn meshes. This can be used as the first stage prolongator + ! in the "mg" multigrid preconditioner + type(mesh_type), intent(in):: p1_mesh, pn_mesh + integer, intent(in):: ncomponents + type(petsc_csr_matrix):: P + + logical, dimension(:), allocatable:: nodes_visited + integer, dimension(:), allocatable:: onnz, dnnz + integer, dimension(:), pointer:: p1_nodes, pn_nodes + integer:: rows, columns + integer:: i, j, k, node, ele + real, dimension(p1_mesh%shape%loc):: N + + rows=nowned_nodes(pn_mesh) + columns=node_count(p1_mesh) + allocate(dnnz(1:rows*ncomponents), onnz(1:rows*ncomponents)) + + dnnz=0 + onnz=0 + do ele=1, ele_count(pn_mesh) + pn_nodes => ele_nodes(pn_mesh, ele) + p1_nodes => ele_nodes(p1_mesh, ele) + do j=1, size(pn_nodes) + node=pn_nodes(j) + if (node_owned(pn_mesh, node)) then + do k=1, size(p1_nodes) + if (node_owned(p1_mesh, p1_nodes(k))) then + dnnz(node)=dnnz(node)+1 + else + onnz(node)=onnz(node)+1 + end if + end do + end if + end do + end do + ! copy over to other components, if any + do i=2, ncomponents + dnnz( (i-1)*rows+1:i*rows )=dnnz(1:rows) + onnz( (i-1)*rows+1:i*rows )=onnz(1:rows) end do - end do - ! copy over to other components, if any - do i=2, ncomponents - dnnz( (i-1)*rows+1:i*rows )=dnnz(1:rows) - onnz( (i-1)*rows+1:i*rows )=onnz(1:rows) - end do - - call allocate(P, rows, columns, dnnz, onnz, (/ ncomponents, ncomponents /), name="HigherOrderProlongator") - if (associated(P%column_halo)) then - allocate(P%column_halo) - P%column_halo = p1_mesh%halos(1) - call incref(P%column_halo) - end if - call zero(P) - - allocate(nodes_visited(1:node_count(pn_mesh))) - nodes_visited=.false. - - do ele=1, ele_count(pn_mesh) - pn_nodes => ele_nodes(pn_mesh, ele) - p1_nodes => ele_nodes(p1_mesh, ele) - do j=1, size(pn_nodes) - node=pn_nodes(j) - if (node_owned(pn_mesh, node) .and. .not. nodes_visited(node)) then - N = eval_shape(p1_mesh%shape, local_coords(j, pn_mesh%shape)) - do i=1, ncomponents - do k=1, size(p1_nodes) - call addto(P, i, i, node, p1_nodes(k), N(k)) - end do - end do - nodes_visited(node)=.true. - end if + + call allocate(P, rows, columns, dnnz, onnz, (/ ncomponents, ncomponents /), name="HigherOrderProlongator") + if (associated(P%column_halo)) then + allocate(P%column_halo) + P%column_halo = p1_mesh%halos(1) + call incref(P%column_halo) + end if + call zero(P) + + allocate(nodes_visited(1:node_count(pn_mesh))) + nodes_visited=.false. + + do ele=1, ele_count(pn_mesh) + pn_nodes => ele_nodes(pn_mesh, ele) + p1_nodes => ele_nodes(p1_mesh, ele) + do j=1, size(pn_nodes) + node=pn_nodes(j) + if (node_owned(pn_mesh, node) .and. .not. nodes_visited(node)) then + N = eval_shape(p1_mesh%shape, local_coords(j, pn_mesh%shape)) + do i=1, ncomponents + do k=1, size(p1_nodes) + call addto(P, i, i, node, p1_nodes(k), N(k)) + end do + end do + nodes_visited(node)=.true. + end if + end do end do - end do - call assemble(P) + call assemble(P) - end function higher_order_prolongator + end function higher_order_prolongator end module petsc_solve_state_module diff --git a/assemble/Pressure_Dirichlet_BCS_CV.F90 b/assemble/Pressure_Dirichlet_BCS_CV.F90 index 048f665ca3..c84fe78405 100644 --- a/assemble/Pressure_Dirichlet_BCS_CV.F90 +++ b/assemble/Pressure_Dirichlet_BCS_CV.F90 @@ -28,38 +28,38 @@ module pressure_dirichlet_bcs_cv - use fldebug - use global_parameters, only: OPTION_PATH_LEN - use quadrature - use futils - use spud - use cv_faces - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use cv_shape_functions - use field_options, only: get_coordinate_field - use cvtools - use cv_options - use cv_upwind_values - use sparsity_patterns_meshes - use diagnostic_fields, only: calculate_diagnostic_variable - use cv_fields - use multiphase_module - - implicit none - - private - - public :: add_pressure_dirichlet_bcs_cv + use fldebug + use global_parameters, only: OPTION_PATH_LEN + use quadrature + use futils + use spud + use cv_faces + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use cv_shape_functions + use field_options, only: get_coordinate_field + use cvtools + use cv_options + use cv_upwind_values + use sparsity_patterns_meshes + use diagnostic_fields, only: calculate_diagnostic_variable + use cv_fields + use multiphase_module + + implicit none + + private + + public :: add_pressure_dirichlet_bcs_cv contains - ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- - subroutine add_pressure_dirichlet_bcs_cv(mom_rhs, u, p, state) + subroutine add_pressure_dirichlet_bcs_cv(mom_rhs, u, p, state) !!< Add any CV pressure dirichlet BC integrals to the mom_rhs field if required. !!< If this is a multiphase simulation then the phase volume fraction spatial @@ -130,9 +130,9 @@ subroutine add_pressure_dirichlet_bcs_cv(mom_rhs, u, p, state) call get_option("/geometry/quadrature/controlvolume_surface_degree", quaddegree, default=1) cvfaces = find_cv_faces(vertices = ele_vertices(p, 1), & - dimension = mesh_dim(p), & - polydegree = p%mesh%shape%degree, & - quaddegree = quaddegree) + dimension = mesh_dim(p), & + polydegree = p%mesh%shape%degree, & + quaddegree = quaddegree) x_cvbdyshape = make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) u_cvbdyshape = make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) @@ -143,12 +143,12 @@ subroutine add_pressure_dirichlet_bcs_cv(mom_rhs, u, p, state) allocate(pressure_bc_type(surface_element_count(p))) call get_entire_boundary_condition(p, (/"weakdirichlet", & - "dirichlet "/), pressure_bc, pressure_bc_type) + "dirichlet "/), pressure_bc, pressure_bc_type) allocate(x_ele_bdy(x%dim,x%mesh%faces%shape%loc), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi), & - pressure_bc_val(pressure_bc%mesh%shape%loc)) + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi), & + pressure_bc_val(pressure_bc%mesh%shape%loc)) allocate(u_nodes_bdy(u%mesh%faces%shape%loc)) @@ -186,70 +186,70 @@ subroutine add_pressure_dirichlet_bcs_cv(mom_rhs, u, p, state) surface_element_loop: do sele = 1, surface_element_count(p) - ! cycle if this not a dirichlet pressure BC. - if (pressure_bc_type(sele) == 0) cycle + ! cycle if this not a dirichlet pressure BC. + if (pressure_bc_type(sele) == 0) cycle - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - u_nodes_bdy = face_global_nodes(u, sele) + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + u_nodes_bdy = face_global_nodes(u, sele) - ! Get the phase volume fraction face value - if(multiphase) then - nvfrac_gi_f = face_val_at_quad(nvfrac, sele, nvfrac_cvbdyshape) - end if + ! Get the phase volume fraction face value + if(multiphase) then + nvfrac_gi_f = face_val_at_quad(nvfrac, sele, nvfrac_cvbdyshape) + end if - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) - ct_mat_local_bdy = 0.0 + ct_mat_local_bdy = 0.0 - ! calculate the ct local matrix - surface_nodal_loop_i: do iloc = 1, p%mesh%faces%shape%loc + ! calculate the ct local matrix + surface_nodal_loop_i: do iloc = 1, p%mesh%faces%shape%loc - surface_face_loop: do face = 1, cvfaces%sfaces + surface_face_loop: do face = 1, cvfaces%sfaces - if(cvfaces%sneiloc(iloc,face) /= 0) then + if(cvfaces%sneiloc(iloc,face) /= 0) then - surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi + surface_quadrature_loop: do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - surface_nodal_loop_j: do jloc = 1, u%mesh%faces%shape%loc + surface_nodal_loop_j: do jloc = 1, u%mesh%faces%shape%loc - surface_inner_dimension_loop: do dim = 1, size(normal_bdy,1) + surface_inner_dimension_loop: do dim = 1, size(normal_bdy,1) - if(multiphase) then - ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & - u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*nvfrac_gi_f(ggi)*normal_bdy(dim, ggi) - else - ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & - u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) - end if + if(multiphase) then + ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & + u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*nvfrac_gi_f(ggi)*normal_bdy(dim, ggi) + else + ct_mat_local_bdy(dim, iloc, jloc) = ct_mat_local_bdy(dim, iloc, jloc) + & + u_cvbdyshape%n(jloc,ggi)*detwei_bdy(ggi)*normal_bdy(dim, ggi) + end if - end do surface_inner_dimension_loop + end do surface_inner_dimension_loop - end do surface_nodal_loop_j + end do surface_nodal_loop_j - end do surface_quadrature_loop + end do surface_quadrature_loop - end if + end if - end do surface_face_loop + end do surface_face_loop - end do surface_nodal_loop_i + end do surface_nodal_loop_i - ! pressure dirichlet BC is -c*press_bc_val = -press_bc_val*ct, integrated over surface elements appropriate - surface_outer_dimension_loop: do dim = 1, size(normal_bdy,1) + ! pressure dirichlet BC is -c*press_bc_val = -press_bc_val*ct, integrated over surface elements appropriate + surface_outer_dimension_loop: do dim = 1, size(normal_bdy,1) - ! for weak and strong pressure dirichlet bcs: - ! / - ! add -| N_i M_j \vec n p_j, where p_j are the prescribed bc values - ! / + ! for weak and strong pressure dirichlet bcs: + ! / + ! add -| N_i M_j \vec n p_j, where p_j are the prescribed bc values + ! / - call addto(mom_rhs, dim, u_nodes_bdy, -matmul(ele_val(pressure_bc, sele), ct_mat_local_bdy(dim,:,:))) + call addto(mom_rhs, dim, u_nodes_bdy, -matmul(ele_val(pressure_bc, sele), ct_mat_local_bdy(dim,:,:))) - end do surface_outer_dimension_loop + end do surface_outer_dimension_loop end do surface_element_loop @@ -272,8 +272,8 @@ subroutine add_pressure_dirichlet_bcs_cv(mom_rhs, u, p, state) call deallocate(nvfrac_cvbdyshape) end if - end subroutine add_pressure_dirichlet_bcs_cv + end subroutine add_pressure_dirichlet_bcs_cv - ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- end module pressure_dirichlet_bcs_cv diff --git a/assemble/Pseudo_supermesh.F90 b/assemble/Pseudo_supermesh.F90 index b44a55a715..027b51d867 100644 --- a/assemble/Pseudo_supermesh.F90 +++ b/assemble/Pseudo_supermesh.F90 @@ -15,119 +15,119 @@ module pseudo_supermesh !!< nodal placement for heuristic statements !!< about local node density. - use fields - use state_module - use vtk_interfaces - use merge_tensors - use interpolation_module - use edge_length_module - use limit_metric_module - use conformity_measurement - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - implicit none - - private - - public :: compute_pseudo_supermesh - - contains - - subroutine compute_pseudo_supermesh(snapshots, starting_positions, super_positions, no_its, mxnods) - !!< snapshots is a list of VTUs containing the meshes we want - !!< to merge. - !!< starting_positions is the initial mesh + positions to interpolate the - !!< metric tensor fields describing the snapshot meshes onto. - !!< super_positions is the output -- a positions field on a mesh. - character(len=255), dimension(:), intent(in) :: snapshots - type(vector_field), intent(in) :: starting_positions - type(vector_field), intent(out) :: super_positions - integer, intent(in), optional :: no_its, mxnods - - integer :: lno_its - integer :: it, i - - type(mesh_type) :: current_mesh, vtk_mesh - type(vector_field) :: current_pos, vtk_pos - type(state_type) :: vtk_state, temp_state - type(state_type) :: interpolation_input, interpolation_output - - type(tensor_field) :: merged_metric, interpolated_metric - type(tensor_field) :: vtk_metric - - if (present(no_its)) then - lno_its = no_its - else - lno_its = 3 - end if - - current_pos = starting_positions - call incref(starting_positions) - current_mesh = starting_positions%mesh - call incref(current_mesh) - - do it=1,lno_its - call allocate(merged_metric, current_mesh, "MergedMetric") - call zero(merged_metric) - call allocate(interpolated_metric, current_mesh, "InterpolatedMetric") - call zero(interpolated_metric) - call insert(interpolation_output, interpolated_metric, "InterpolatedMetric") - call insert(interpolation_output, current_mesh, "Mesh") - call insert(interpolation_output, current_pos, "Coordinate") + use fields + use state_module + use vtk_interfaces + use merge_tensors + use interpolation_module + use edge_length_module + use limit_metric_module + use conformity_measurement + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + implicit none + + private + + public :: compute_pseudo_supermesh + +contains + + subroutine compute_pseudo_supermesh(snapshots, starting_positions, super_positions, no_its, mxnods) + !!< snapshots is a list of VTUs containing the meshes we want + !!< to merge. + !!< starting_positions is the initial mesh + positions to interpolate the + !!< metric tensor fields describing the snapshot meshes onto. + !!< super_positions is the output -- a positions field on a mesh. + character(len=255), dimension(:), intent(in) :: snapshots + type(vector_field), intent(in) :: starting_positions + type(vector_field), intent(out) :: super_positions + integer, intent(in), optional :: no_its, mxnods + + integer :: lno_its + integer :: it, i + + type(mesh_type) :: current_mesh, vtk_mesh + type(vector_field) :: current_pos, vtk_pos + type(state_type) :: vtk_state, temp_state + type(state_type) :: interpolation_input, interpolation_output + + type(tensor_field) :: merged_metric, interpolated_metric + type(tensor_field) :: vtk_metric + + if (present(no_its)) then + lno_its = no_its + else + lno_its = 3 + end if -! call allocate(edgelen, current_mesh, "EdgeLengths") + current_pos = starting_positions + call incref(starting_positions) + current_mesh = starting_positions%mesh + call incref(current_mesh) - do i=1,size(snapshots) - call zero(interpolated_metric) - call vtk_read_state(trim(snapshots(i)), vtk_state) - vtk_mesh = extract_mesh(vtk_state, "Mesh") - vtk_pos = extract_vector_field(vtk_state, "Coordinate") - call compute_mesh_metric(vtk_pos, vtk_metric) - call insert(interpolation_input, vtk_metric, "InterpolatedMetric") - call insert(interpolation_input, vtk_mesh, "Mesh") - call insert(interpolation_input, vtk_pos, "Coordinate") - call vtk_write_state("interpolation_input", i, state=(/interpolation_input/)) - call linear_interpolation(interpolation_input, interpolation_output) - call vtk_write_state("interpolation_output", i, state=(/interpolation_output/)) - call merge_tensor_fields(merged_metric, interpolated_metric) - call deallocate(vtk_metric) - call deallocate(interpolation_input) - call deallocate(vtk_state) - end do + do it=1,lno_its + call allocate(merged_metric, current_mesh, "MergedMetric") + call zero(merged_metric) + call allocate(interpolated_metric, current_mesh, "InterpolatedMetric") + call zero(interpolated_metric) + call insert(interpolation_output, interpolated_metric, "InterpolatedMetric") + call insert(interpolation_output, current_mesh, "Mesh") + call insert(interpolation_output, current_pos, "Coordinate") - call deallocate(interpolated_metric) - call deallocate(interpolation_output) +! call allocate(edgelen, current_mesh, "EdgeLengths") - call insert(temp_state, current_mesh, "Mesh") - call insert(temp_state, current_pos, "Coordinate") - ! Assuming current_mesh had a refcount of one, - ! it now has a refcount of two. + do i=1,size(snapshots) + call zero(interpolated_metric) + call vtk_read_state(trim(snapshots(i)), vtk_state) + vtk_mesh = extract_mesh(vtk_state, "Mesh") + vtk_pos = extract_vector_field(vtk_state, "Coordinate") + call compute_mesh_metric(vtk_pos, vtk_metric) + call insert(interpolation_input, vtk_metric, "InterpolatedMetric") + call insert(interpolation_input, vtk_mesh, "Mesh") + call insert(interpolation_input, vtk_pos, "Coordinate") + call vtk_write_state("interpolation_input", i, state=(/interpolation_input/)) + call linear_interpolation(interpolation_input, interpolation_output) + call vtk_write_state("interpolation_output", i, state=(/interpolation_output/)) + call merge_tensor_fields(merged_metric, interpolated_metric) + call deallocate(vtk_metric) + call deallocate(interpolation_input) + call deallocate(vtk_state) + end do + + call deallocate(interpolated_metric) + call deallocate(interpolation_output) + + call insert(temp_state, current_mesh, "Mesh") + call insert(temp_state, current_pos, "Coordinate") + ! Assuming current_mesh had a refcount of one, + ! it now has a refcount of two. ! call get_edge_lengths(merged_metric, edgelen) ! call vtk_write_fields("supermesh_before_adapt", it, current_pos, current_mesh, sfields=(/edgelen/), tfields=(/merged_metric/)) - if (present(mxnods)) then - call limit_metric(current_pos, merged_metric, min_nodes=1, max_nodes=mxnods) - end if - call adapt_state(temp_state, merged_metric) + if (present(mxnods)) then + call limit_metric(current_pos, merged_metric, min_nodes=1, max_nodes=mxnods) + end if + call adapt_state(temp_state, merged_metric) ! call vtk_write_state("supermesh_after_adapt", it, state=(/temp_state/)) - call deallocate(merged_metric) + call deallocate(merged_metric) ! call deallocate(edgelen) - ! Now it has a refcount of one, as adapt_state - ! has destroyed the old one and created a new mesh - ! with refcount one. + ! Now it has a refcount of one, as adapt_state + ! has destroyed the old one and created a new mesh + ! with refcount one. + + ! We're finished with the current_mesh, so let it be + ! deallocated if no one else is using it. + call deallocate(current_mesh) + call deallocate(current_pos) + + current_mesh = extract_mesh(temp_state, "Mesh") + current_pos = extract_vector_field(temp_state, "Coordinate") + call incref(current_mesh) + call incref(current_pos) + call deallocate(temp_state) + end do - ! We're finished with the current_mesh, so let it be - ! deallocated if no one else is using it. call deallocate(current_mesh) - call deallocate(current_pos) - - current_mesh = extract_mesh(temp_state, "Mesh") - current_pos = extract_vector_field(temp_state, "Coordinate") - call incref(current_mesh) - call incref(current_pos) - call deallocate(temp_state) - end do - - call deallocate(current_mesh) - super_positions = current_pos - end subroutine compute_pseudo_supermesh + super_positions = current_pos + end subroutine compute_pseudo_supermesh end module pseudo_supermesh diff --git a/assemble/Sam_integration.F90 b/assemble/Sam_integration.F90 index 41d8906b9f..16ad61ac7e 100644 --- a/assemble/Sam_integration.F90 +++ b/assemble/Sam_integration.F90 @@ -29,340 +29,340 @@ module sam_integration - use fldebug - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use futils - use reference_counting, only: print_tagged_references - use quadrature - use elements - use spud - use mpi_interfaces - use parallel_tools - use memory_diagnostics - use data_structures - use ieee_arithmetic - use metric_tools - use fields - use state_module - use field_options - use halos - use surfacelabels - use node_boundary - use boundary_conditions - use tictoc - use detector_data_types - use boundary_conditions_from_options - use reserve_state_module - use pickers - use detector_tools - use diagnostic_variables - use populate_state_module - use surface_id_interleaving - - implicit none - - interface - !subroutine flstriph2(nnodes, nprivatenodes, nprocs, & - ! & volumeenlist, nvolumeelems, nloc, & - ! & surfaceenlist, surfaceids, nsurfaceelems, snloc, & - ! & x, y, z, & - ! & fields, nfields, fstride, & - ! & metric, & - ! & scatter, nscatter) - ! implicit none - ! integer, intent(inout) :: nnodes - ! integer, intent(in) :: nprivatenodes - ! integer, intent(in) :: nprocs - ! integer, intent(inout) :: nvolumeelems - ! integer, intent(in) :: nloc - ! integer, dimension(nvolumeelems * nloc), intent(inout) :: volumeenlist - ! integer, intent(inout) :: nsurfaceelems - ! integer, intent(in) :: snloc - ! integer, dimension(nsurfaceelems * snloc), intent(inout) :: surfaceenlist - ! integer, dimension(nsurfaceelems), intent(inout) :: surfaceids - ! real, dimension(nnodes), intent(inout) :: x - ! real, dimension(nnodes), intent(inout) :: y - ! real, dimension(nnodes), intent(inout) :: z - ! integer, intent(inout) :: nfields - ! integer, intent(inout) :: fstride - ! real, dimension(nnodes * nfields * fstride), intent(inout) :: fields - ! real, dimension(nnodes * 9), intent(inout) :: metric - ! integer, intent(inout) :: nscatter - ! integer, dimension(nscatter), intent(inout) :: scatter - !end subroutine flstriph2 - - subroutine sam_init_c(dim, nonods, totele, stotel, & - & gather, atosen, & - & scater, atorec, & - & ncolga, nscate, nprocs, & - & NDGLNO, nloc, & - & SNDGLN, SURFID, snloc, & - & X, Y, Z, & - & metric, FIELDS, NFIELDS, & - & options, MESTP1) - implicit none - integer, intent(in) :: dim - integer, intent(in) :: nonods, totele, stotel - integer, intent(in) :: ncolga - integer, intent(in) :: nscate - integer, intent(in) :: nprocs - integer, intent(in) :: nloc, snloc - integer, dimension(ncolga), intent(in) :: gather - integer, dimension(nprocs + 1), intent(in) :: atosen - integer, dimension(nscate), intent(in) :: scater - integer, dimension(nprocs + 1), intent(in) :: atorec - integer, intent(in), dimension(stotel * snloc) :: SNDGLN - integer, intent(in), dimension(stotel) :: SURFID - integer, intent(in), dimension(totele * nloc) :: NDGLNO - real, dimension(nonods), intent(in) :: X, Y, Z - real, dimension(dim ** 2 * nonods), intent(in) :: metric - integer, intent(in) :: NFIELDS - real, dimension(NFIELDS * NONODS), intent(in) :: FIELDS - integer, dimension(10), intent(in) :: options - real, intent(in) :: MESTP1 - end subroutine sam_init_c + use fldebug + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use futils + use reference_counting, only: print_tagged_references + use quadrature + use elements + use spud + use mpi_interfaces + use parallel_tools + use memory_diagnostics + use data_structures + use ieee_arithmetic + use metric_tools + use fields + use state_module + use field_options + use halos + use surfacelabels + use node_boundary + use boundary_conditions + use tictoc + use detector_data_types + use boundary_conditions_from_options + use reserve_state_module + use pickers + use detector_tools + use diagnostic_variables + use populate_state_module + use surface_id_interleaving + + implicit none + + interface + !subroutine flstriph2(nnodes, nprivatenodes, nprocs, & + ! & volumeenlist, nvolumeelems, nloc, & + ! & surfaceenlist, surfaceids, nsurfaceelems, snloc, & + ! & x, y, z, & + ! & fields, nfields, fstride, & + ! & metric, & + ! & scatter, nscatter) + ! implicit none + ! integer, intent(inout) :: nnodes + ! integer, intent(in) :: nprivatenodes + ! integer, intent(in) :: nprocs + ! integer, intent(inout) :: nvolumeelems + ! integer, intent(in) :: nloc + ! integer, dimension(nvolumeelems * nloc), intent(inout) :: volumeenlist + ! integer, intent(inout) :: nsurfaceelems + ! integer, intent(in) :: snloc + ! integer, dimension(nsurfaceelems * snloc), intent(inout) :: surfaceenlist + ! integer, dimension(nsurfaceelems), intent(inout) :: surfaceids + ! real, dimension(nnodes), intent(inout) :: x + ! real, dimension(nnodes), intent(inout) :: y + ! real, dimension(nnodes), intent(inout) :: z + ! integer, intent(inout) :: nfields + ! integer, intent(inout) :: fstride + ! real, dimension(nnodes * nfields * fstride), intent(inout) :: fields + ! real, dimension(nnodes * 9), intent(inout) :: metric + ! integer, intent(inout) :: nscatter + ! integer, dimension(nscatter), intent(inout) :: scatter + !end subroutine flstriph2 + + subroutine sam_init_c(dim, nonods, totele, stotel, & + & gather, atosen, & + & scater, atorec, & + & ncolga, nscate, nprocs, & + & NDGLNO, nloc, & + & SNDGLN, SURFID, snloc, & + & X, Y, Z, & + & metric, FIELDS, NFIELDS, & + & options, MESTP1) + implicit none + integer, intent(in) :: dim + integer, intent(in) :: nonods, totele, stotel + integer, intent(in) :: ncolga + integer, intent(in) :: nscate + integer, intent(in) :: nprocs + integer, intent(in) :: nloc, snloc + integer, dimension(ncolga), intent(in) :: gather + integer, dimension(nprocs + 1), intent(in) :: atosen + integer, dimension(nscate), intent(in) :: scater + integer, dimension(nprocs + 1), intent(in) :: atorec + integer, intent(in), dimension(stotel * snloc) :: SNDGLN + integer, intent(in), dimension(stotel) :: SURFID + integer, intent(in), dimension(totele * nloc) :: NDGLNO + real, dimension(nonods), intent(in) :: X, Y, Z + real, dimension(dim ** 2 * nonods), intent(in) :: metric + integer, intent(in) :: NFIELDS + real, dimension(NFIELDS * NONODS), intent(in) :: FIELDS + integer, dimension(10), intent(in) :: options + real, intent(in) :: MESTP1 + end subroutine sam_init_c end interface interface sam_migrate - subroutine sam_migrate_c - end subroutine sam_migrate_c + subroutine sam_migrate_c + end subroutine sam_migrate_c end interface sam_migrate interface sam_add_field - module procedure sam_add_field_scalar, sam_add_field_vector, sam_add_field_tensor + module procedure sam_add_field_scalar, sam_add_field_vector, sam_add_field_tensor end interface interface sam_query - subroutine sam_query_c(NONODS, TOTELE, STOTEL, ncolga, nscate, pncolga, pnscate) - implicit none - integer, intent(out) :: NONODS, TOTELE, STOTEL - integer, intent(out) :: ncolga - integer, intent(out) :: nscate - integer, intent(out) :: pncolga - integer, intent(out) :: pnscate - end subroutine sam_query_c + subroutine sam_query_c(NONODS, TOTELE, STOTEL, ncolga, nscate, pncolga, pnscate) + implicit none + integer, intent(out) :: NONODS, TOTELE, STOTEL + integer, intent(out) :: ncolga + integer, intent(out) :: nscate + integer, intent(out) :: pncolga + integer, intent(out) :: pnscate + end subroutine sam_query_c end interface sam_query interface sam_cleanup - subroutine sam_cleanup_c - end subroutine sam_cleanup_c + subroutine sam_cleanup_c + end subroutine sam_cleanup_c end interface sam_cleanup interface sam_export_mesh - subroutine sam_export_mesh_c(nonods, totele, stotel, nloc, snloc, nodx, nody, nodz, enlist, senlist, surfid) - implicit none - integer, intent(in) :: nonods, totele, stotel, nloc, snloc - real, dimension(nonods), intent(out) :: nodx - real, dimension(nonods), intent(out) :: nody - real, dimension(nonods), intent(out) :: nodz - integer, dimension(totele * nloc), intent(out) :: enlist - integer, dimension(stotel * snloc), intent(out) :: senlist - integer, dimension(stotel), intent(out) :: surfid - end subroutine sam_export_mesh_c + subroutine sam_export_mesh_c(nonods, totele, stotel, nloc, snloc, nodx, nody, nodz, enlist, senlist, surfid) + implicit none + integer, intent(in) :: nonods, totele, stotel, nloc, snloc + real, dimension(nonods), intent(out) :: nodx + real, dimension(nonods), intent(out) :: nody + real, dimension(nonods), intent(out) :: nodz + integer, dimension(totele * nloc), intent(out) :: enlist + integer, dimension(stotel * snloc), intent(out) :: senlist + integer, dimension(stotel), intent(out) :: surfid + end subroutine sam_export_mesh_c end interface sam_export_mesh interface sam_export_halo - subroutine sam_export_halo_c(colgat, atosen, scater, atorec, ncolga, nscate, nprocs, pnodes, nnodes) - implicit none - integer, intent(in) :: ncolga - integer, intent(in) :: nscate - integer, intent(in) :: nprocs - integer, dimension(ncolga), intent(out) :: colgat - integer, dimension(nprocs + 1), intent(out) :: atosen - integer, dimension(nscate), intent(out) :: scater - integer, dimension(nprocs + 1), intent(out) :: atorec - integer, intent(out) :: pnodes - integer, intent(out) :: nnodes - end subroutine sam_export_halo_c + subroutine sam_export_halo_c(colgat, atosen, scater, atorec, ncolga, nscate, nprocs, pnodes, nnodes) + implicit none + integer, intent(in) :: ncolga + integer, intent(in) :: nscate + integer, intent(in) :: nprocs + integer, dimension(ncolga), intent(out) :: colgat + integer, dimension(nprocs + 1), intent(out) :: atosen + integer, dimension(nscate), intent(out) :: scater + integer, dimension(nprocs + 1), intent(out) :: atorec + integer, intent(out) :: pnodes + integer, intent(out) :: nnodes + end subroutine sam_export_halo_c end interface sam_export_halo interface sam_export_phalo - subroutine sam_export_phalo_c(pcolgat, patosen, pscater, patorec, pncolga, pnscate, nprocs, ppnodes, pnnodes) - implicit none - integer, intent(in) :: pncolga - integer, intent(in) :: pnscate - integer, intent(in) :: nprocs - integer, dimension(pncolga), intent(out) :: pcolgat - integer, dimension(nprocs + 1), intent(out) :: patosen - integer, dimension(pnscate), intent(out) :: pscater - integer, dimension(nprocs + 1), intent(out) :: patorec - integer, intent(out) :: ppnodes - integer, intent(out) :: pnnodes - end subroutine sam_export_phalo_c + subroutine sam_export_phalo_c(pcolgat, patosen, pscater, patorec, pncolga, pnscate, nprocs, ppnodes, pnnodes) + implicit none + integer, intent(in) :: pncolga + integer, intent(in) :: pnscate + integer, intent(in) :: nprocs + integer, dimension(pncolga), intent(out) :: pcolgat + integer, dimension(nprocs + 1), intent(out) :: patosen + integer, dimension(pnscate), intent(out) :: pscater + integer, dimension(nprocs + 1), intent(out) :: patorec + integer, intent(out) :: ppnodes + integer, intent(out) :: pnnodes + end subroutine sam_export_phalo_c end interface sam_export_phalo interface sam_add_field - subroutine sam_add_field_c(field_data, nnodes) - implicit none - integer, intent(in) :: nnodes - real, dimension(nnodes), intent(in) :: field_data - end subroutine sam_add_field_c + subroutine sam_add_field_c(field_data, nnodes) + implicit none + integer, intent(in) :: nnodes + real, dimension(nnodes), intent(in) :: field_data + end subroutine sam_add_field_c end interface sam_add_field interface sam_pop_field - subroutine sam_pop_field_c(field_data, nnodes) - implicit none - integer, intent(in) :: nnodes - real, dimension(nnodes), intent(out) :: field_data - end subroutine sam_pop_field_c + subroutine sam_pop_field_c(field_data, nnodes) + implicit none + integer, intent(in) :: nnodes + real, dimension(nnodes), intent(out) :: field_data + end subroutine sam_pop_field_c end interface sam_pop_field interface sam_export_node_ownership - subroutine sam_export_node_ownership_c(node_ownership, nnodes) - implicit none - integer, intent(in) :: nnodes - integer, dimension(nnodes), intent(out) :: node_ownership - end subroutine sam_export_node_ownership_c + subroutine sam_export_node_ownership_c(node_ownership, nnodes) + implicit none + integer, intent(in) :: nnodes + integer, dimension(nnodes), intent(out) :: node_ownership + end subroutine sam_export_node_ownership_c end interface sam_export_node_ownership private public :: sam_drive, strip_level_2_halo, sam_integration_check_options - contains - - subroutine strip_level_2_halo(states, metric, external_mesh_name, initialise_fields) - !!< Strip the level 2 halo from the supplied states and error metric. - !!< Replaces flstriph2. - - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), optional, intent(inout) :: metric - character(len=FIELD_NAME_LEN), optional, intent(in) :: external_mesh_name - logical, optional, intent(in) :: initialise_fields - - character(len = FIELD_NAME_LEN) :: linear_coordinate_field_name - integer :: i, j, nlocal_dets, stat - integer, dimension(:), allocatable :: renumber - logical, dimension(:), allocatable :: keep - type(halo_type), pointer :: level_1_halo, level_2_halo - type(mesh_type) :: new_linear_mesh, old_linear_mesh - type(mesh_type), pointer :: old_linear_mesh_ptr - type(scalar_field), pointer :: new_s_field - type(vector_field) :: new_positions, old_positions - type(vector_field), pointer :: new_v_field - type(state_type), dimension(:), allocatable :: interpolate_states - type(tensor_field), pointer :: new_t_field - type(tensor_field) :: new_metric - - ewrite(1, *) "In strip_level_2_halo" - - ! Find the external mesh. Must be linear and continuous. - old_linear_mesh_ptr => get_external_mesh(states, external_mesh_name=external_mesh_name) - - old_linear_mesh = old_linear_mesh_ptr - old_linear_mesh_ptr => null() - call incref(old_linear_mesh) - ewrite(2, *) "External mesh: " // trim(old_linear_mesh%name) - if(trim(old_linear_mesh%name) == "CoordinateMesh") then - linear_coordinate_field_name = "Coordinate" - else - linear_coordinate_field_name = trim(old_linear_mesh%name) // "Coordinate" - end if - ewrite(2, *) "Mesh field: " // trim(linear_coordinate_field_name) - - ! Extract the mesh field - old_positions = extract_vector_field(states(1), linear_coordinate_field_name) - call incref(old_positions) - assert(old_positions%mesh == old_linear_mesh) - - call initialise_boundcount(old_linear_mesh, old_positions) - - ! Use select_fields_to_interpolate to reference all non-recoverable - ! information in interpolate_states - allocate(interpolate_states(size(states))) - do i = 1, size(states) +contains + + subroutine strip_level_2_halo(states, metric, external_mesh_name, initialise_fields) + !!< Strip the level 2 halo from the supplied states and error metric. + !!< Replaces flstriph2. + + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), optional, intent(inout) :: metric + character(len=FIELD_NAME_LEN), optional, intent(in) :: external_mesh_name + logical, optional, intent(in) :: initialise_fields + + character(len = FIELD_NAME_LEN) :: linear_coordinate_field_name + integer :: i, j, nlocal_dets, stat + integer, dimension(:), allocatable :: renumber + logical, dimension(:), allocatable :: keep + type(halo_type), pointer :: level_1_halo, level_2_halo + type(mesh_type) :: new_linear_mesh, old_linear_mesh + type(mesh_type), pointer :: old_linear_mesh_ptr + type(scalar_field), pointer :: new_s_field + type(vector_field) :: new_positions, old_positions + type(vector_field), pointer :: new_v_field + type(state_type), dimension(:), allocatable :: interpolate_states + type(tensor_field), pointer :: new_t_field + type(tensor_field) :: new_metric + + ewrite(1, *) "In strip_level_2_halo" + + ! Find the external mesh. Must be linear and continuous. + old_linear_mesh_ptr => get_external_mesh(states, external_mesh_name=external_mesh_name) + + old_linear_mesh = old_linear_mesh_ptr + old_linear_mesh_ptr => null() + call incref(old_linear_mesh) + ewrite(2, *) "External mesh: " // trim(old_linear_mesh%name) + if(trim(old_linear_mesh%name) == "CoordinateMesh") then + linear_coordinate_field_name = "Coordinate" + else + linear_coordinate_field_name = trim(old_linear_mesh%name) // "Coordinate" + end if + ewrite(2, *) "Mesh field: " // trim(linear_coordinate_field_name) + + ! Extract the mesh field + old_positions = extract_vector_field(states(1), linear_coordinate_field_name) + call incref(old_positions) + assert(old_positions%mesh == old_linear_mesh) + + call initialise_boundcount(old_linear_mesh, old_positions) + + ! Use select_fields_to_interpolate to reference all non-recoverable + ! information in interpolate_states + allocate(interpolate_states(size(states))) + do i = 1, size(states) call select_fields_to_interpolate(states(i), interpolate_states(i), first_time_step=initialise_fields) ! If the old mesh field is referenced in interpolate_states(i), remove ! it (it will be dealt with seperately) call remove_vector_field(interpolate_states(i), old_positions%name, stat) - end do - - ! Extract the level 1 and level 2 halos - assert(associated(old_positions%mesh%halos)) - assert(size(old_positions%mesh%halos) >= 2) - level_1_halo => old_positions%mesh%halos(1) - call incref(level_1_halo) - level_2_halo => old_positions%mesh%halos(2) - call incref(level_2_halo) - - ! Deallocate all recoverable information - do i = 1, size(states) + end do + + ! Extract the level 1 and level 2 halos + assert(associated(old_positions%mesh%halos)) + assert(size(old_positions%mesh%halos) >= 2) + level_1_halo => old_positions%mesh%halos(1) + call incref(level_1_halo) + level_2_halo => old_positions%mesh%halos(2) + call incref(level_2_halo) + + ! Deallocate all recoverable information + do i = 1, size(states) call deallocate(states(i)) - end do - - ! Find the nodes to keep - allocate(keep(node_count(old_positions))) - call find_nodes_to_keep(keep, level_1_halo, level_2_halo) - call deallocate(level_2_halo) - - ! Generate the renumbering map - allocate(renumber(size(keep))) - call create_renumbering_map(renumber, keep) - - ewrite(2, *) "Stripping level 2 halo from the external mesh" - call generate_stripped_linear_mesh(old_linear_mesh, new_linear_mesh, level_1_halo, keep, renumber) - call insert(states, new_linear_mesh, new_linear_mesh%name) - - ewrite(2, *) "Stripping level 2 halo from the mesh field" - call allocate(new_positions, mesh_dim(new_linear_mesh), new_linear_mesh, old_positions%name) - call generate_stripped_vector_field(old_positions, old_linear_mesh, new_positions, new_linear_mesh, keep) - call insert(states, new_positions, new_positions%name) - call deallocate(old_positions) - - nlocal_dets = default_stat%detector_list%length - call allsum(nlocal_dets) - if(nlocal_dets > 0) call halo_transfer_detectors(old_linear_mesh, new_positions) - call deallocate(new_positions) - - ! Insert meshes from reserve states - call restore_reserved_meshes(states) - ! Next we recreate all derived meshes - call insert_derived_meshes(states) - ! Then reallocate all fields - call allocate_and_insert_fields(states) - ! Insert fields from reserve states - call restore_reserved_fields(states) - - ! Strip the level 2 halo from all fields in states - do i = 1, size(interpolate_states) + end do + + ! Find the nodes to keep + allocate(keep(node_count(old_positions))) + call find_nodes_to_keep(keep, level_1_halo, level_2_halo) + call deallocate(level_2_halo) + + ! Generate the renumbering map + allocate(renumber(size(keep))) + call create_renumbering_map(renumber, keep) + + ewrite(2, *) "Stripping level 2 halo from the external mesh" + call generate_stripped_linear_mesh(old_linear_mesh, new_linear_mesh, level_1_halo, keep, renumber) + call insert(states, new_linear_mesh, new_linear_mesh%name) + + ewrite(2, *) "Stripping level 2 halo from the mesh field" + call allocate(new_positions, mesh_dim(new_linear_mesh), new_linear_mesh, old_positions%name) + call generate_stripped_vector_field(old_positions, old_linear_mesh, new_positions, new_linear_mesh, keep) + call insert(states, new_positions, new_positions%name) + call deallocate(old_positions) + + nlocal_dets = default_stat%detector_list%length + call allsum(nlocal_dets) + if(nlocal_dets > 0) call halo_transfer_detectors(old_linear_mesh, new_positions) + call deallocate(new_positions) + + ! Insert meshes from reserve states + call restore_reserved_meshes(states) + ! Next we recreate all derived meshes + call insert_derived_meshes(states) + ! Then reallocate all fields + call allocate_and_insert_fields(states) + ! Insert fields from reserve states + call restore_reserved_fields(states) + + ! Strip the level 2 halo from all fields in states + do i = 1, size(interpolate_states) do j = 1, scalar_field_count(interpolate_states(i)) - assert(associated(interpolate_states(i)%scalar_fields(j)%ptr)) - ewrite(2, *) "Stripping level 2 halo from field " // trim(interpolate_states(i)%scalar_fields(j)%ptr%name) // " in state " // trim(states(i)%name) - new_s_field => extract_scalar_field(states(i), interpolate_states(i)%scalar_fields(j)%ptr%name) - call generate_stripped_scalar_field(interpolate_states(i)%scalar_fields(j)%ptr, old_linear_mesh, new_s_field, new_linear_mesh, keep) + assert(associated(interpolate_states(i)%scalar_fields(j)%ptr)) + ewrite(2, *) "Stripping level 2 halo from field " // trim(interpolate_states(i)%scalar_fields(j)%ptr%name) // " in state " // trim(states(i)%name) + new_s_field => extract_scalar_field(states(i), interpolate_states(i)%scalar_fields(j)%ptr%name) + call generate_stripped_scalar_field(interpolate_states(i)%scalar_fields(j)%ptr, old_linear_mesh, new_s_field, new_linear_mesh, keep) end do do j = 1, vector_field_count(interpolate_states(i)) - assert(associated(interpolate_states(i)%vector_fields(j)%ptr)) - if(trim(interpolate_states(i)%vector_fields(j)%ptr%name) == trim(linear_coordinate_field_name)) cycle - ewrite(2, *) "Stripping level 2 halo from field " // trim(interpolate_states(i)%vector_fields(j)%ptr%name) // " in state " // trim(states(i)%name) - new_v_field => extract_vector_field(states(i), interpolate_states(i)%vector_fields(j)%ptr%name) - call generate_stripped_vector_field(interpolate_states(i)%vector_fields(j)%ptr, old_linear_mesh, new_v_field, new_linear_mesh, keep) + assert(associated(interpolate_states(i)%vector_fields(j)%ptr)) + if(trim(interpolate_states(i)%vector_fields(j)%ptr%name) == trim(linear_coordinate_field_name)) cycle + ewrite(2, *) "Stripping level 2 halo from field " // trim(interpolate_states(i)%vector_fields(j)%ptr%name) // " in state " // trim(states(i)%name) + new_v_field => extract_vector_field(states(i), interpolate_states(i)%vector_fields(j)%ptr%name) + call generate_stripped_vector_field(interpolate_states(i)%vector_fields(j)%ptr, old_linear_mesh, new_v_field, new_linear_mesh, keep) end do do j = 1, tensor_field_count(interpolate_states(i)) - assert(associated(interpolate_states(i)%tensor_fields(j)%ptr)) - ewrite(2, *) "Stripping level 2 halo from field " // trim(interpolate_states(i)%tensor_fields(j)%ptr%name) // " in state " // trim(states(i)%name) - new_t_field => extract_tensor_field(states(i), interpolate_states(i)%tensor_fields(j)%ptr%name) - call generate_stripped_tensor_field(interpolate_states(i)%tensor_fields(j)%ptr, old_linear_mesh, new_t_field, new_linear_mesh, keep) + assert(associated(interpolate_states(i)%tensor_fields(j)%ptr)) + ewrite(2, *) "Stripping level 2 halo from field " // trim(interpolate_states(i)%tensor_fields(j)%ptr%name) // " in state " // trim(states(i)%name) + new_t_field => extract_tensor_field(states(i), interpolate_states(i)%tensor_fields(j)%ptr%name) + call generate_stripped_tensor_field(interpolate_states(i)%tensor_fields(j)%ptr, old_linear_mesh, new_t_field, new_linear_mesh, keep) end do - end do + end do - do i = 1, size(interpolate_states) + do i = 1, size(interpolate_states) call deallocate(interpolate_states(i)) - end do - deallocate(interpolate_states) + end do + deallocate(interpolate_states) - ewrite(2, *) "Renumbering level 1 halo" - call renumber_halo(level_1_halo, renumber) + ewrite(2, *) "Renumbering level 1 halo" + call renumber_halo(level_1_halo, renumber) #ifdef DDEBUG - if(isparallel()) then + if(isparallel()) then assert(halo_verifies(level_1_halo, extract_vector_field(states(1), linear_coordinate_field_name))) - end if + end if #endif - call deallocate(level_1_halo) + call deallocate(level_1_halo) - if(present(metric)) then + if(present(metric)) then ewrite(2, *) "Stripping level 2 halo from metric " // trim(metric%name) call allocate(new_metric, new_linear_mesh, metric%name) call generate_stripped_tensor_field(metric, old_linear_mesh, new_metric, new_linear_mesh, keep) @@ -373,658 +373,658 @@ subroutine strip_level_2_halo(states, metric, external_mesh_name, initialise_fie #ifdef DDEBUG call check_metric(metric) #endif - end if - - call deallocate(old_linear_mesh) - call deallocate(new_linear_mesh) - - deallocate(keep) - deallocate(renumber) - - ! The following is the same as the tail of populate_state: - ! Prescribed fields are recalculated - call set_prescribed_field_values(states, exclude_interpolated=.true.) - ! Add on the boundary conditions again - call populate_boundary_conditions(states) - ! Set their values - call set_boundary_conditions_values(states) - ! if strong bc or weak that overwrite then enforce the bc on the fields - call set_dirichlet_consistent(states) - ! Insert aliased fields in state - call alias_fields(states) + end if - if(no_reserved_meshes()) then - ewrite(2, *) "Tagged references remaining:" - call print_tagged_references(0) - else - ewrite(2, *) "There are reserved meshes, so skipping printing of references." - end if + call deallocate(old_linear_mesh) + call deallocate(new_linear_mesh) + + deallocate(keep) + deallocate(renumber) + + ! The following is the same as the tail of populate_state: + ! Prescribed fields are recalculated + call set_prescribed_field_values(states, exclude_interpolated=.true.) + ! Add on the boundary conditions again + call populate_boundary_conditions(states) + ! Set their values + call set_boundary_conditions_values(states) + ! if strong bc or weak that overwrite then enforce the bc on the fields + call set_dirichlet_consistent(states) + ! Insert aliased fields in state + call alias_fields(states) + + if(no_reserved_meshes()) then + ewrite(2, *) "Tagged references remaining:" + call print_tagged_references(0) + else + ewrite(2, *) "There are reserved meshes, so skipping printing of references." + end if - ewrite(1, *) "Exiting strip_level_2_halo" + ewrite(1, *) "Exiting strip_level_2_halo" - end subroutine strip_level_2_halo + end subroutine strip_level_2_halo - subroutine find_nodes_to_keep(keep, level_1_halo, level_2_halo) - !!< Set the keep array, deciding whether a node should be kept + subroutine find_nodes_to_keep(keep, level_1_halo, level_2_halo) + !!< Set the keep array, deciding whether a node should be kept - logical, dimension(:), intent(out) :: keep - type(halo_type), intent(in) :: level_1_halo - type(halo_type), intent(in) :: level_2_halo + logical, dimension(:), intent(out) :: keep + type(halo_type), intent(in) :: level_1_halo + type(halo_type), intent(in) :: level_2_halo - integer :: i, j + integer :: i, j - assert(size(keep) >= max_halo_node(level_1_halo)) - assert(size(keep) >= max_halo_node(level_2_halo)) - assert(halo_proc_count(level_1_halo) == halo_proc_count(level_2_halo)) + assert(size(keep) >= max_halo_node(level_1_halo)) + assert(size(keep) >= max_halo_node(level_2_halo)) + assert(halo_proc_count(level_1_halo) == halo_proc_count(level_2_halo)) - keep = .true. - do i = 1, halo_proc_count(level_2_halo) + keep = .true. + do i = 1, halo_proc_count(level_2_halo) do j = 1, halo_receive_count(level_2_halo, i) - keep(halo_receive(level_2_halo, i, j)) = .false. + keep(halo_receive(level_2_halo, i, j)) = .false. end do - end do - do i = 1, halo_proc_count(level_1_halo) + end do + do i = 1, halo_proc_count(level_1_halo) do j = 1, halo_receive_count(level_1_halo, i) - keep(halo_receive(level_1_halo, i, j)) = .true. + keep(halo_receive(level_1_halo, i, j)) = .true. end do - end do + end do - end subroutine find_nodes_to_keep + end subroutine find_nodes_to_keep - subroutine create_renumbering_map(renumber, keep) - !!< Generate the map used for node renumbering when stripping the halo. - !!< renumber is negative if the node is to be stripped, and forms - !!< a consecutive list elsewhere. + subroutine create_renumbering_map(renumber, keep) + !!< Generate the map used for node renumbering when stripping the halo. + !!< renumber is negative if the node is to be stripped, and forms + !!< a consecutive list elsewhere. - integer, dimension(:), intent(out) :: renumber - logical, dimension(size(renumber)), intent(in) :: keep + integer, dimension(:), intent(out) :: renumber + logical, dimension(size(renumber)), intent(in) :: keep - integer :: i, index + integer :: i, index - index = 0 - renumber = -1 - do i = 1, size(keep) + index = 0 + renumber = -1 + do i = 1, size(keep) if(keep(i)) then - index = index + 1 - renumber(i) = index + index = index + 1 + renumber(i) = index end if - end do + end do - end subroutine create_renumbering_map + end subroutine create_renumbering_map - subroutine generate_stripped_linear_mesh(input_linear_mesh, output_linear_mesh, level_1_halo, keep, renumber) - !!< Generate a new mesh based on the input mesh, with nodes stripped - !!< as specified by keep and renumber. output_linear_mesh is allocated - !!< by this routine. + subroutine generate_stripped_linear_mesh(input_linear_mesh, output_linear_mesh, level_1_halo, keep, renumber) + !!< Generate a new mesh based on the input mesh, with nodes stripped + !!< as specified by keep and renumber. output_linear_mesh is allocated + !!< by this routine. - type(mesh_type), intent(in) :: input_linear_mesh - type(mesh_type), intent(out) :: output_linear_mesh - type(halo_type), intent(in) :: level_1_halo - logical, dimension(:), intent(in) :: keep - integer, dimension(size(keep)), intent(in) :: renumber + type(mesh_type), intent(in) :: input_linear_mesh + type(mesh_type), intent(out) :: output_linear_mesh + type(halo_type), intent(in) :: level_1_halo + logical, dimension(:), intent(in) :: keep + integer, dimension(size(keep)), intent(in) :: renumber - integer :: i, j, new_boundary_ids_size, new_coplanar_ids_size, new_nelms, new_ndglno_size, new_nnodes, new_region_ids_size, new_sndgln_size, nowned_nodes - integer, dimension(:), allocatable :: sloc, new_boundary_ids, new_coplanar_ids, new_ndglno, new_region_ids, new_sndgln - integer, dimension(:), pointer :: loc - logical :: keep_element - type(element_type) :: output_shape - type(quadrature_type) :: output_quad + integer :: i, j, new_boundary_ids_size, new_coplanar_ids_size, new_nelms, new_ndglno_size, new_nnodes, new_region_ids_size, new_sndgln_size, nowned_nodes + integer, dimension(:), allocatable :: sloc, new_boundary_ids, new_coplanar_ids, new_ndglno, new_region_ids, new_sndgln + integer, dimension(:), pointer :: loc + logical :: keep_element + type(element_type) :: output_shape + type(quadrature_type) :: output_quad - assert(size(keep) == node_count(input_linear_mesh)) - assert(trailing_receives_consistent(level_1_halo)) + assert(size(keep) == node_count(input_linear_mesh)) + assert(trailing_receives_consistent(level_1_halo)) - nowned_nodes = halo_nowned_nodes(level_1_halo) + nowned_nodes = halo_nowned_nodes(level_1_halo) - ! Count number of nodes in the stripped mesh - if(size(renumber) > 0) then + ! Count number of nodes in the stripped mesh + if(size(renumber) > 0) then new_nnodes = max(maxval(renumber), 0) - else + else new_nnodes = 0 - end if - - ! Strip volume elements - new_nelms = 0 - allocate(new_ndglno(size(input_linear_mesh%ndglno))) - new_ndglno_size = 0 - allocate(new_region_ids(ele_count(input_linear_mesh))) - new_region_ids_size = 0 - volume_element_loop: do i = 1, ele_count(input_linear_mesh) + end if + + ! Strip volume elements + new_nelms = 0 + allocate(new_ndglno(size(input_linear_mesh%ndglno))) + new_ndglno_size = 0 + allocate(new_region_ids(ele_count(input_linear_mesh))) + new_region_ids_size = 0 + volume_element_loop: do i = 1, ele_count(input_linear_mesh) assert(ele_loc(input_linear_mesh, i) == ele_loc(input_linear_mesh, 1)) loc => ele_nodes(input_linear_mesh, i) keep_element = .true. element_loc_node_loop: do j = 1, size(loc) - assert(loc(j) >= lbound(keep, 1) .and. loc(j) <= ubound(keep, 1)) - if(.not. keep(loc(j))) then - keep_element = .false. - exit element_loc_node_loop - end if + assert(loc(j) >= lbound(keep, 1) .and. loc(j) <= ubound(keep, 1)) + if(.not. keep(loc(j))) then + keep_element = .false. + exit element_loc_node_loop + end if end do element_loc_node_loop ! This really shouldn't be necessary, but some elements have all ! nodes in the level 1 halo and no owned nodes! if(keep_element .and. .not. any(loc <= nowned_nodes)) then - keep_element = .false. - !ewrite(2, *) "Warning: Element found that has all nodes in the level 1 halo and no owned nodes" + keep_element = .false. + !ewrite(2, *) "Warning: Element found that has all nodes in the level 1 halo and no owned nodes" end if keep_element = keep_element .and. any(loc <= nowned_nodes) if(keep_element) then - new_nelms = new_nelms + 1 - new_ndglno_size = new_ndglno_size + size(loc) - ! Renumber nodes in the new volume element list - add_volume_element_loop: do j = 1, size(loc) - assert(loc(j) >= lbound(renumber, 1) .and. loc(j) <= ubound(renumber, 1)) - assert(renumber(loc(j)) > 0) - new_ndglno(new_ndglno_size - size(loc) + j) = renumber(loc(j)) - end do add_volume_element_loop - if(associated(input_linear_mesh%region_ids)) then - new_region_ids_size = new_region_ids_size + 1 - new_region_ids(new_region_ids_size) = input_linear_mesh%region_ids(i) - end if + new_nelms = new_nelms + 1 + new_ndglno_size = new_ndglno_size + size(loc) + ! Renumber nodes in the new volume element list + add_volume_element_loop: do j = 1, size(loc) + assert(loc(j) >= lbound(renumber, 1) .and. loc(j) <= ubound(renumber, 1)) + assert(renumber(loc(j)) > 0) + new_ndglno(new_ndglno_size - size(loc) + j) = renumber(loc(j)) + end do add_volume_element_loop + if(associated(input_linear_mesh%region_ids)) then + new_region_ids_size = new_region_ids_size + 1 + new_region_ids(new_region_ids_size) = input_linear_mesh%region_ids(i) + end if end if - end do volume_element_loop + end do volume_element_loop - ! Strip surface elements - if(surface_element_count(input_linear_mesh) > 0) then + ! Strip surface elements + if(surface_element_count(input_linear_mesh) > 0) then allocate(new_sndgln(surface_element_count(input_linear_mesh) * face_loc(input_linear_mesh, 1))) - else + else allocate(new_sndgln(0)) - end if - new_sndgln_size = 0 - allocate(new_boundary_ids(surface_element_count(input_linear_mesh))) - new_boundary_ids_size = 0 - allocate(new_coplanar_ids(surface_element_count(input_linear_mesh))) - new_coplanar_ids_size = 0 - surface_element_loop: do i = 1, surface_element_count(input_linear_mesh) + end if + new_sndgln_size = 0 + allocate(new_boundary_ids(surface_element_count(input_linear_mesh))) + new_boundary_ids_size = 0 + allocate(new_coplanar_ids(surface_element_count(input_linear_mesh))) + new_coplanar_ids_size = 0 + surface_element_loop: do i = 1, surface_element_count(input_linear_mesh) assert(face_loc(input_linear_mesh, i) == face_loc(input_linear_mesh, 1)) loc => ele_nodes(input_linear_mesh, face_ele(input_linear_mesh, i)) keep_element = .true. face_loc_node_loop: do j = 1, size(loc) - assert(loc(j) >= lbound(keep, 1) .and. loc(j) <= ubound(keep, 1)) - if(.not. keep(loc(j))) then - keep_element = .false. - exit face_loc_node_loop - end if + assert(loc(j) >= lbound(keep, 1) .and. loc(j) <= ubound(keep, 1)) + if(.not. keep(loc(j))) then + keep_element = .false. + exit face_loc_node_loop + end if end do face_loc_node_loop ! This really shouldn't be necessary, but some elements have all ! nodes in the level 1 halo and no owned nodes! if(keep_element .and. .not. any(loc <= nowned_nodes)) then - keep_element = .false. - !ewrite(2, *) "Warning: Surface element found attached to element that has all nodes in the level 1 halo and no owned nodes" + keep_element = .false. + !ewrite(2, *) "Warning: Surface element found attached to element that has all nodes in the level 1 halo and no owned nodes" end if if(keep_element) then - allocate(sloc(face_loc(input_linear_mesh, i))) - sloc = face_global_nodes(input_linear_mesh, i) - new_sndgln_size = new_sndgln_size + size(sloc) - ! Renumber nodes in the new surface element list - add_surface_element_loop: do j = 1, size(sloc) - assert(sloc(j) >= lbound(renumber, 1) .and. sloc(j) <= ubound(renumber, 1)) - assert(renumber(sloc(j)) > 0) - new_sndgln(new_sndgln_size - size(sloc) + j) = renumber(sloc(j)) - end do add_surface_element_loop - if(associated(input_linear_mesh%faces%boundary_ids)) then - new_boundary_ids_size = new_boundary_ids_size + 1 - new_boundary_ids(new_boundary_ids_size) = input_linear_mesh%faces%boundary_ids(i) - end if - if(associated(input_linear_mesh%faces%coplanar_ids)) then - new_coplanar_ids_size = new_coplanar_ids_size + 1 - new_coplanar_ids(new_coplanar_ids_size) = input_linear_mesh%faces%coplanar_ids(i) - end if - deallocate(sloc) + allocate(sloc(face_loc(input_linear_mesh, i))) + sloc = face_global_nodes(input_linear_mesh, i) + new_sndgln_size = new_sndgln_size + size(sloc) + ! Renumber nodes in the new surface element list + add_surface_element_loop: do j = 1, size(sloc) + assert(sloc(j) >= lbound(renumber, 1) .and. sloc(j) <= ubound(renumber, 1)) + assert(renumber(sloc(j)) > 0) + new_sndgln(new_sndgln_size - size(sloc) + j) = renumber(sloc(j)) + end do add_surface_element_loop + if(associated(input_linear_mesh%faces%boundary_ids)) then + new_boundary_ids_size = new_boundary_ids_size + 1 + new_boundary_ids(new_boundary_ids_size) = input_linear_mesh%faces%boundary_ids(i) + end if + if(associated(input_linear_mesh%faces%coplanar_ids)) then + new_coplanar_ids_size = new_coplanar_ids_size + 1 + new_coplanar_ids(new_coplanar_ids_size) = input_linear_mesh%faces%coplanar_ids(i) + end if + deallocate(sloc) end if - end do surface_element_loop - - ! Construct the new mesh - output_quad = make_quadrature(ele_loc(input_linear_mesh, 1), mesh_dim(input_linear_mesh), degree = input_linear_mesh%shape%quadrature%degree) - output_shape = make_element_shape(ele_loc(input_linear_mesh, 1), mesh_dim(input_linear_mesh), input_linear_mesh%shape%degree, output_quad) - call allocate(output_linear_mesh, new_nnodes, new_nelms, output_shape, name = input_linear_mesh%name) - call deallocate(output_quad) - call deallocate(output_shape) - output_linear_mesh%ndglno = new_ndglno(1:new_ndglno_size) - if(isparallel()) then + end do surface_element_loop + + ! Construct the new mesh + output_quad = make_quadrature(ele_loc(input_linear_mesh, 1), mesh_dim(input_linear_mesh), degree = input_linear_mesh%shape%quadrature%degree) + output_shape = make_element_shape(ele_loc(input_linear_mesh, 1), mesh_dim(input_linear_mesh), input_linear_mesh%shape%degree, output_quad) + call allocate(output_linear_mesh, new_nnodes, new_nelms, output_shape, name = input_linear_mesh%name) + call deallocate(output_quad) + call deallocate(output_shape) + output_linear_mesh%ndglno = new_ndglno(1:new_ndglno_size) + if(isparallel()) then if(associated(input_linear_mesh%faces%boundary_ids)) then - call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size), boundary_ids = new_boundary_ids(1:new_boundary_ids_size)) + call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size), boundary_ids = new_boundary_ids(1:new_boundary_ids_size)) else - call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size)) + call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size)) end if - else + else if(associated(input_linear_mesh%faces%boundary_ids)) then - call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size), boundary_ids = new_boundary_ids(1:new_boundary_ids_size)) + call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size), boundary_ids = new_boundary_ids(1:new_boundary_ids_size)) else - call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size)) + call add_faces(output_linear_mesh, sndgln = new_sndgln(1:new_sndgln_size)) end if - end if - if(associated(input_linear_mesh%faces%coplanar_ids)) then + end if + if(associated(input_linear_mesh%faces%coplanar_ids)) then allocate(output_linear_mesh%faces%coplanar_ids(new_coplanar_ids_size)) output_linear_mesh%faces%coplanar_ids = new_coplanar_ids(1:new_coplanar_ids_size) - end if - if(associated(input_linear_mesh%region_ids)) then + end if + if(associated(input_linear_mesh%region_ids)) then allocate(output_linear_mesh%region_ids(new_region_ids_size)) output_linear_mesh%region_ids = new_region_ids(1:new_region_ids_size) - end if - output_linear_mesh%option_path = input_linear_mesh%option_path + end if + output_linear_mesh%option_path = input_linear_mesh%option_path - allocate(output_linear_mesh%halos(1)) - output_linear_mesh%halos(1)=level_1_halo - call incref(level_1_halo) - if(.not. serial_storage_halo(level_1_halo)) then ! Cannot derive halos in serial + allocate(output_linear_mesh%halos(1)) + output_linear_mesh%halos(1)=level_1_halo + call incref(level_1_halo) + if(.not. serial_storage_halo(level_1_halo)) then ! Cannot derive halos in serial allocate(output_linear_mesh%element_halos(1)) call derive_element_halo_from_node_halo(output_linear_mesh, & - & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) - end if + & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) + end if - deallocate(new_ndglno) - deallocate(new_boundary_ids) - deallocate(new_coplanar_ids) - deallocate(new_sndgln) - deallocate(new_region_ids) + deallocate(new_ndglno) + deallocate(new_boundary_ids) + deallocate(new_coplanar_ids) + deallocate(new_sndgln) + deallocate(new_region_ids) - end subroutine generate_stripped_linear_mesh + end subroutine generate_stripped_linear_mesh - subroutine generate_stripped_scalar_field(input_field, input_linear_mesh, output_field, output_linear_mesh, keep) - !!< Generate a new field based on the input field, with nodes stripped - !!< as specified by keep. + subroutine generate_stripped_scalar_field(input_field, input_linear_mesh, output_field, output_linear_mesh, keep) + !!< Generate a new field based on the input field, with nodes stripped + !!< as specified by keep. - type(scalar_field), intent(in) :: input_field - type(mesh_type), intent(inout) :: input_linear_mesh - type(scalar_field), intent(inout) :: output_field - type(mesh_type), intent(inout) :: output_linear_mesh - logical, dimension(:), intent(in) :: keep + type(scalar_field), intent(in) :: input_field + type(mesh_type), intent(inout) :: input_linear_mesh + type(scalar_field), intent(inout) :: output_field + type(mesh_type), intent(inout) :: output_linear_mesh + logical, dimension(:), intent(in) :: keep - integer :: i, index - type(scalar_field) :: input_linear_field, output_linear_field + integer :: i, index + type(scalar_field) :: input_linear_field, output_linear_field - assert(mesh_dim(input_field) == mesh_dim(output_field)) - assert(size(keep) == node_count(input_linear_mesh)) + assert(mesh_dim(input_field) == mesh_dim(output_field)) + assert(size(keep) == node_count(input_linear_mesh)) - call allocate(input_linear_field, input_linear_mesh, input_field%name) - call remap_field(input_field, input_linear_field) + call allocate(input_linear_field, input_linear_mesh, input_field%name) + call remap_field(input_field, input_linear_field) - call allocate(output_linear_field, output_linear_mesh, input_field%name) + call allocate(output_linear_field, output_linear_mesh, input_field%name) - index = 0 - do i = 1, node_count(input_linear_field) + index = 0 + do i = 1, node_count(input_linear_field) if(keep(i)) then - index = index + 1 - assert(index <= node_count(output_linear_field)) - call set(output_linear_field, index, node_val(input_linear_field, i)) + index = index + 1 + assert(index <= node_count(output_linear_field)) + call set(output_linear_field, index, node_val(input_linear_field, i)) end if - end do + end do - call remap_field(output_linear_field, output_field) + call remap_field(output_linear_field, output_field) - call deallocate(input_linear_field) - call deallocate(output_linear_field) + call deallocate(input_linear_field) + call deallocate(output_linear_field) - end subroutine generate_stripped_scalar_field + end subroutine generate_stripped_scalar_field - subroutine generate_stripped_vector_field(input_field, input_linear_mesh, output_field, output_linear_mesh, keep) - !!< Generate a new field based on the input field, with nodes stripped - !!< as specified by keep. + subroutine generate_stripped_vector_field(input_field, input_linear_mesh, output_field, output_linear_mesh, keep) + !!< Generate a new field based on the input field, with nodes stripped + !!< as specified by keep. - type(vector_field), intent(in) :: input_field - type(mesh_type), intent(in) :: input_linear_mesh - type(vector_field), target, intent(inout) :: output_field - type(mesh_type), intent(in) :: output_linear_mesh - logical, dimension(:), intent(in) :: keep + type(vector_field), intent(in) :: input_field + type(mesh_type), intent(in) :: input_linear_mesh + type(vector_field), target, intent(inout) :: output_field + type(mesh_type), intent(in) :: output_linear_mesh + logical, dimension(:), intent(in) :: keep - integer :: i, index - type(vector_field) :: input_linear_field, output_linear_field + integer :: i, index + type(vector_field) :: input_linear_field, output_linear_field - assert(mesh_dim(input_field) == mesh_dim(output_field)) - assert(size(keep) == node_count(input_linear_mesh)) + assert(mesh_dim(input_field) == mesh_dim(output_field)) + assert(size(keep) == node_count(input_linear_mesh)) - call allocate(input_linear_field, mesh_dim(input_linear_mesh), input_linear_mesh, input_field%name) - call remap_field(input_field, input_linear_field) + call allocate(input_linear_field, mesh_dim(input_linear_mesh), input_linear_mesh, input_field%name) + call remap_field(input_field, input_linear_field) - call allocate(output_linear_field, mesh_dim(output_linear_mesh), output_linear_mesh, input_field%name) + call allocate(output_linear_field, mesh_dim(output_linear_mesh), output_linear_mesh, input_field%name) - index = 0 - do i = 1, node_count(input_linear_field) + index = 0 + do i = 1, node_count(input_linear_field) if(keep(i)) then - index = index + 1 - assert(index <= node_count(output_linear_field)) - call set(output_linear_field, index, node_val(input_linear_field, i)) + index = index + 1 + assert(index <= node_count(output_linear_field)) + call set(output_linear_field, index, node_val(input_linear_field, i)) end if - end do + end do - call remap_field(output_linear_field, output_field) + call remap_field(output_linear_field, output_field) - call deallocate(input_linear_field) - call deallocate(output_linear_field) + call deallocate(input_linear_field) + call deallocate(output_linear_field) - end subroutine generate_stripped_vector_field + end subroutine generate_stripped_vector_field - subroutine generate_stripped_tensor_field(input_field, input_linear_mesh, output_field, output_linear_mesh, keep) - !!< Generate a new field based on the input field, with nodes stripped - !!< as specified by keep. output_field is allocated by this routine. + subroutine generate_stripped_tensor_field(input_field, input_linear_mesh, output_field, output_linear_mesh, keep) + !!< Generate a new field based on the input field, with nodes stripped + !!< as specified by keep. output_field is allocated by this routine. - type(tensor_field), intent(in) :: input_field - type(mesh_type), intent(in) :: input_linear_mesh - type(tensor_field), intent(inout) :: output_field - type(mesh_type), intent(in) :: output_linear_mesh - logical, dimension(:), intent(in) :: keep + type(tensor_field), intent(in) :: input_field + type(mesh_type), intent(in) :: input_linear_mesh + type(tensor_field), intent(inout) :: output_field + type(mesh_type), intent(in) :: output_linear_mesh + logical, dimension(:), intent(in) :: keep - integer :: i, index - type(tensor_field) :: input_linear_field, output_linear_field + integer :: i, index + type(tensor_field) :: input_linear_field, output_linear_field - assert(mesh_dim(input_field) == mesh_dim(output_field)) - assert(size(keep) == node_count(input_linear_mesh)) + assert(mesh_dim(input_field) == mesh_dim(output_field)) + assert(size(keep) == node_count(input_linear_mesh)) - call allocate(input_linear_field, input_linear_mesh, input_field%name) - call remap_field(input_field, input_linear_field) + call allocate(input_linear_field, input_linear_mesh, input_field%name) + call remap_field(input_field, input_linear_field) - call allocate(output_linear_field, output_linear_mesh, input_field%name) + call allocate(output_linear_field, output_linear_mesh, input_field%name) - index = 0 - do i = 1, node_count(input_linear_field) + index = 0 + do i = 1, node_count(input_linear_field) if(keep(i)) then - index = index + 1 - assert(index <= node_count(output_linear_field)) - call set(output_linear_field, index, node_val(input_linear_field, i)) + index = index + 1 + assert(index <= node_count(output_linear_field)) + call set(output_linear_field, index, node_val(input_linear_field, i)) end if - end do + end do - call remap_field(output_linear_field, output_field) + call remap_field(output_linear_field, output_field) - call deallocate(input_linear_field) - call deallocate(output_linear_field) + call deallocate(input_linear_field) + call deallocate(output_linear_field) - end subroutine generate_stripped_tensor_field + end subroutine generate_stripped_tensor_field - subroutine renumber_halo(halo, renumber) - !!< Renumber the supplied halo according to the specified renumbering. + subroutine renumber_halo(halo, renumber) + !!< Renumber the supplied halo according to the specified renumbering. - type(halo_type), intent(inout) :: halo - integer, dimension(:), intent(in) :: renumber + type(halo_type), intent(inout) :: halo + integer, dimension(:), intent(in) :: renumber - integer :: i, j, receive + integer :: i, j, receive - do i = 1, halo_proc_count(halo) + do i = 1, halo_proc_count(halo) do j = 1, halo_receive_count(halo, i) - receive = halo_receive(halo, i, j) - assert(receive >= lbound(renumber, 1) .and. receive <= ubound(renumber, 1)) - assert(renumber(receive) > 0) - call set_halo_receive(halo, i, j, renumber(receive)) + receive = halo_receive(halo, i, j) + assert(receive >= lbound(renumber, 1) .and. receive <= ubound(renumber, 1)) + assert(renumber(receive) > 0) + call set_halo_receive(halo, i, j, renumber(receive)) end do - end do + end do - assert(halo_valid_for_communication(halo)) + assert(halo_valid_for_communication(halo)) - end subroutine renumber_halo + end subroutine renumber_halo - subroutine sam_drive(states, options, metric, external_mesh_name, initialise_fields) - type(state_type), dimension(:), intent(inout) :: states - integer, dimension(10), intent(in) :: options - type(tensor_field), optional, intent(inout) :: metric - character(len=FIELD_NAME_LEN), intent(in), optional :: external_mesh_name - ! if present and true: don't bother redistributing fields that can be reinitialised - logical, intent(in), optional :: initialise_fields + subroutine sam_drive(states, options, metric, external_mesh_name, initialise_fields) + type(state_type), dimension(:), intent(inout) :: states + integer, dimension(10), intent(in) :: options + type(tensor_field), optional, intent(inout) :: metric + character(len=FIELD_NAME_LEN), intent(in), optional :: external_mesh_name + ! if present and true: don't bother redistributing fields that can be reinitialised + logical, intent(in), optional :: initialise_fields - type(state_type), dimension(size(states)) :: interpolate_states + type(state_type), dimension(size(states)) :: interpolate_states - integer :: field, state + integer :: field, state - type(scalar_field) :: linear_s - type(vector_field) :: linear_v - type(tensor_field) :: linear_t + type(scalar_field) :: linear_s + type(vector_field) :: linear_v + type(tensor_field) :: linear_t - character(len=FIELD_NAME_LEN), dimension(:, :), allocatable, target :: namelist_s, namelist_v, namelist_t - type(scalar_field), pointer :: field_s - type(vector_field), pointer :: field_v - type(tensor_field), pointer :: field_t + character(len=FIELD_NAME_LEN), dimension(:, :), allocatable, target :: namelist_s, namelist_v, namelist_t + type(scalar_field), pointer :: field_s + type(vector_field), pointer :: field_v + type(tensor_field), pointer :: field_t - integer, dimension(size(states)) :: scount, vcount, tcount + integer, dimension(size(states)) :: scount, vcount, tcount - type(element_type) :: linear_shape + type(element_type) :: linear_shape - integer :: max_coplanar_id, nlocal_dets - integer, dimension(:), allocatable :: boundary_ids, coplanar_ids + integer :: max_coplanar_id, nlocal_dets + integer, dimension(:), allocatable :: boundary_ids, coplanar_ids - integer :: NNODP, NONODS, TOTELE, STOTEL, ncolga, nscate, pncolga, pnscate - type(mesh_type) :: old_linear_mesh - type(mesh_type), pointer :: linear_mesh + integer :: NNODP, NONODS, TOTELE, STOTEL, ncolga, nscate, pncolga, pnscate + type(mesh_type) :: old_linear_mesh + type(mesh_type), pointer :: linear_mesh - integer, dimension(:), allocatable :: ATOSEN, ATOREC - integer, dimension(:), allocatable :: COLGAT, SCATER - type(vector_field), target :: new_positions - type(vector_field), pointer :: old_positions - integer :: dim, snloc, nloc - integer, dimension(:), allocatable :: senlist, surface_ids - character(len=FIELD_NAME_LEN) :: linear_mesh_name, linear_coordinate_field_name, metric_name - character(len=OPTION_PATH_LEN) :: linear_mesh_option_path - integer :: component, component_i, component_j + integer, dimension(:), allocatable :: ATOSEN, ATOREC + integer, dimension(:), allocatable :: COLGAT, SCATER + type(vector_field), target :: new_positions + type(vector_field), pointer :: old_positions + integer :: dim, snloc, nloc + integer, dimension(:), allocatable :: senlist, surface_ids + character(len=FIELD_NAME_LEN) :: linear_mesh_name, linear_coordinate_field_name, metric_name + character(len=OPTION_PATH_LEN) :: linear_mesh_option_path + integer :: component, component_i, component_j - real, dimension(:,:), allocatable :: xyz - real, dimension(:), allocatable :: value + real, dimension(:,:), allocatable :: xyz + real, dimension(:), allocatable :: value - integer :: stat + integer :: stat - ewrite(1, *) "In sam_drive" - call tic(TICTOC_ID_DATA_REMAP) + ewrite(1, *) "In sam_drive" + call tic(TICTOC_ID_DATA_REMAP) - ! Step 1. Initialise sam. - if(present(metric)) then + ! Step 1. Initialise sam. + if(present(metric)) then call sam_init(states, options, max_coplanar_id, metric = metric, external_mesh_name=external_mesh_name) - else + else call sam_init(states, options, max_coplanar_id, external_mesh_name=external_mesh_name) - end if + end if - ! Step 2. Supply sam with all the fields it needs to migrate. - old_linear_mesh = get_external_mesh(states, external_mesh_name=external_mesh_name) + ! Step 2. Supply sam with all the fields it needs to migrate. + old_linear_mesh = get_external_mesh(states, external_mesh_name=external_mesh_name) - nlocal_dets = default_stat%detector_list%length - call allsum(nlocal_dets) - if(nlocal_dets > 0) then + nlocal_dets = default_stat%detector_list%length + call allsum(nlocal_dets) + if(nlocal_dets > 0) then ! Detector communication required. Take a reference to the old mesh. ! If no detector communication is required, avoid taking a reference to ! save memory. call incref(old_linear_mesh) - end if + end if - linear_mesh_name = old_linear_mesh%name - linear_mesh_option_path = old_linear_mesh%option_path - if(trim(linear_mesh_name) == "CoordinateMesh") then - linear_coordinate_field_name="Coordinate" - else - linear_coordinate_field_name=trim(linear_mesh_name)//"Coordinate" - end if + linear_mesh_name = old_linear_mesh%name + linear_mesh_option_path = old_linear_mesh%option_path + if(trim(linear_mesh_name) == "CoordinateMesh") then + linear_coordinate_field_name="Coordinate" + else + linear_coordinate_field_name=trim(linear_mesh_name)//"Coordinate" + end if - old_positions => extract_vector_field(states(1), trim(linear_coordinate_field_name)) - dim = old_positions%dim - linear_shape = ele_shape(old_linear_mesh, 1) + old_positions => extract_vector_field(states(1), trim(linear_coordinate_field_name)) + dim = old_positions%dim + linear_shape = ele_shape(old_linear_mesh, 1) - nloc = old_linear_mesh%shape%loc - snloc = old_linear_mesh%faces%surface_mesh%shape%loc - call incref(linear_shape) + nloc = old_linear_mesh%shape%loc + snloc = old_linear_mesh%faces%surface_mesh%shape%loc + call incref(linear_shape) - call allocate(linear_s, old_linear_mesh, "LinearScalarField") - call allocate(linear_v, dim, old_linear_mesh, "LinearVectorField") - call allocate(linear_t, old_linear_mesh, "LinearTensorField") + call allocate(linear_s, old_linear_mesh, "LinearScalarField") + call allocate(linear_v, dim, old_linear_mesh, "LinearVectorField") + call allocate(linear_t, old_linear_mesh, "LinearTensorField") - ! Get the sizes so I can allocate the right amount of headers - ! Multiple states is a REAL pain + ! Get the sizes so I can allocate the right amount of headers + ! Multiple states is a REAL pain - ! Select fields to interpolate - do state=1,size(states) + ! Select fields to interpolate + do state=1,size(states) call select_fields_to_interpolate(states(state), interpolate_states(state), & - no_positions=.true., first_time_step=initialise_fields) - end do - - ! Record the headers of the interpolated fields - scount = 0 - vcount = 0 - tcount = 0 - do state=1,size(states) + no_positions=.true., first_time_step=initialise_fields) + end do + + ! Record the headers of the interpolated fields + scount = 0 + vcount = 0 + tcount = 0 + do state=1,size(states) scount(state) = scalar_field_count(interpolate_states(state)) vcount(state) = vector_field_count(interpolate_states(state)) tcount(state) = tensor_field_count(interpolate_states(state)) - end do + end do - allocate(namelist_s(size(states), maxval(scount))) - allocate(namelist_v(size(states), maxval(vcount))) - allocate(namelist_t(size(states), maxval(tcount))) + allocate(namelist_s(size(states), maxval(scount))) + allocate(namelist_v(size(states), maxval(vcount))) + allocate(namelist_t(size(states), maxval(tcount))) - do state=1,size(states) + do state=1,size(states) do field=1,scalar_field_count(interpolate_states(state)) - field_s => extract_scalar_field(interpolate_states(state), field) - namelist_s(state, field) = field_s%name + field_s => extract_scalar_field(interpolate_states(state), field) + namelist_s(state, field) = field_s%name end do do field=1,vector_field_count(interpolate_states(state)) - field_v => extract_vector_field(interpolate_states(state), field) - namelist_v(state, field) = field_v%name + field_v => extract_vector_field(interpolate_states(state), field) + namelist_v(state, field) = field_v%name end do do field=1,tensor_field_count(interpolate_states(state)) - field_t => extract_tensor_field(interpolate_states(state), field) - namelist_t(state, field) = field_t%name + field_t => extract_tensor_field(interpolate_states(state), field) + namelist_t(state, field) = field_t%name end do - end do + end do - do state=1,size(states) + do state=1,size(states) do field=1,scount(state) - field_s => extract_scalar_field(interpolate_states(state), trim(namelist_s(state, field))) - call remap_field(field_s, linear_s,stat) - call check_sam_linear_remap_validity(stat, trim(namelist_s(state, field))) - call sam_add_field(linear_s) - call remove_scalar_field(states(state), trim(namelist_s(state, field))) - call remove_scalar_field(interpolate_states(state), trim(namelist_s(state, field))) + field_s => extract_scalar_field(interpolate_states(state), trim(namelist_s(state, field))) + call remap_field(field_s, linear_s,stat) + call check_sam_linear_remap_validity(stat, trim(namelist_s(state, field))) + call sam_add_field(linear_s) + call remove_scalar_field(states(state), trim(namelist_s(state, field))) + call remove_scalar_field(interpolate_states(state), trim(namelist_s(state, field))) end do do field=1,vcount(state) - field_v => extract_vector_field(interpolate_states(state), trim(namelist_v(state, field))) - call remap_field(field_v, linear_v,stat) - call check_sam_linear_remap_validity(stat, trim(namelist_v(state, field))) - call sam_add_field(linear_v) - call remove_vector_field(states(state), trim(namelist_v(state, field))) - call remove_vector_field(interpolate_states(state), trim(namelist_v(state, field))) + field_v => extract_vector_field(interpolate_states(state), trim(namelist_v(state, field))) + call remap_field(field_v, linear_v,stat) + call check_sam_linear_remap_validity(stat, trim(namelist_v(state, field))) + call sam_add_field(linear_v) + call remove_vector_field(states(state), trim(namelist_v(state, field))) + call remove_vector_field(interpolate_states(state), trim(namelist_v(state, field))) end do do field=1,tcount(state) - field_t => extract_tensor_field(interpolate_states(state), trim(namelist_t(state, field))) - call remap_field(field_t, linear_t,stat) - call check_sam_linear_remap_validity(stat, trim(namelist_t(state, field))) - call sam_add_field(linear_t) - call remove_tensor_field(states(state), trim(namelist_t(state, field))) - call remove_tensor_field(interpolate_states(state), trim(namelist_t(state, field))) + field_t => extract_tensor_field(interpolate_states(state), trim(namelist_t(state, field))) + call remap_field(field_t, linear_t,stat) + call check_sam_linear_remap_validity(stat, trim(namelist_t(state, field))) + call sam_add_field(linear_t) + call remove_tensor_field(states(state), trim(namelist_t(state, field))) + call remove_tensor_field(interpolate_states(state), trim(namelist_t(state, field))) end do - end do + end do - if(present(metric)) then + if(present(metric)) then ! Add the metric call remap_field(metric, linear_t) call sam_add_field(linear_t) - end if + end if - call deallocate(linear_s) - call deallocate(linear_v) - call deallocate(linear_t) + call deallocate(linear_s) + call deallocate(linear_v) + call deallocate(linear_t) - if(present(metric)) metric_name = metric%name + if(present(metric)) metric_name = metric%name - ! Step 3. Deallocate. + ! Step 3. Deallocate. - ! Deallocate the states - do state=1,size(states) + ! Deallocate the states + do state=1,size(states) call deallocate(states(state)) call deallocate(interpolate_states(state)) - end do - if(present(metric)) then + end do + if(present(metric)) then ! Deallocate the metric call deallocate(metric) - end if - - ! Step 4. Migrate. - ewrite(1, *) "Calling sam_migrate from sam_drive" - call tic(TICTOC_ID_DATA_MIGRATION) - call sam_migrate - call toc(TICTOC_ID_DATA_MIGRATION) - ewrite(1, *) "Exited sam_migrate" - - ! Step 5. Now, we need to reconstruct. - - ! Query the statistics of the new mesh. - ewrite(1, *) "Calling sam_query from sam_drive" - call sam_query(nonods, totele, stotel, ncolga, nscate, pncolga, pnscate) - ewrite(1, *) "Exited sam_query" - - !!! sanity check - - if (nonods==0) then - FLExit("Libsam has produced an empty partition for your problem. Please consider reconfiguring with Zoltan") - end if - - ! Export mesh data from sam - allocate(linear_mesh) - call allocate(linear_mesh, nonods, totele, linear_shape, linear_mesh_name) - call deallocate(linear_shape) - call allocate(new_positions, dim, linear_mesh, linear_coordinate_field_name) - call deallocate(linear_mesh) - deallocate(linear_mesh) - linear_mesh => new_positions%mesh - allocate(surface_ids(stotel)) - allocate(senlist(stotel * snloc)) - ewrite(1, *) "Calling sam_export_mesh from sam_drive" - allocate(xyz(1:nonods, 1:3)) - call sam_export_mesh(nonods, totele, stotel, nloc, snloc, & - & xyz(:,1), xyz(:,2), xyz(:,3), & - & linear_mesh%ndglno, senlist, surface_ids) - new_positions%val=transpose(xyz(:,1:new_positions%dim)) - deallocate(xyz) - ewrite(1, *) "Exited sam_export_mesh" - linear_mesh%option_path = linear_mesh_option_path - - if(nlocal_dets > 0) then + end if + + ! Step 4. Migrate. + ewrite(1, *) "Calling sam_migrate from sam_drive" + call tic(TICTOC_ID_DATA_MIGRATION) + call sam_migrate + call toc(TICTOC_ID_DATA_MIGRATION) + ewrite(1, *) "Exited sam_migrate" + + ! Step 5. Now, we need to reconstruct. + + ! Query the statistics of the new mesh. + ewrite(1, *) "Calling sam_query from sam_drive" + call sam_query(nonods, totele, stotel, ncolga, nscate, pncolga, pnscate) + ewrite(1, *) "Exited sam_query" + + !!! sanity check + + if (nonods==0) then + FLExit("Libsam has produced an empty partition for your problem. Please consider reconfiguring with Zoltan") + end if + + ! Export mesh data from sam + allocate(linear_mesh) + call allocate(linear_mesh, nonods, totele, linear_shape, linear_mesh_name) + call deallocate(linear_shape) + call allocate(new_positions, dim, linear_mesh, linear_coordinate_field_name) + call deallocate(linear_mesh) + deallocate(linear_mesh) + linear_mesh => new_positions%mesh + allocate(surface_ids(stotel)) + allocate(senlist(stotel * snloc)) + ewrite(1, *) "Calling sam_export_mesh from sam_drive" + allocate(xyz(1:nonods, 1:3)) + call sam_export_mesh(nonods, totele, stotel, nloc, snloc, & + & xyz(:,1), xyz(:,2), xyz(:,3), & + & linear_mesh%ndglno, senlist, surface_ids) + new_positions%val=transpose(xyz(:,1:new_positions%dim)) + deallocate(xyz) + ewrite(1, *) "Exited sam_export_mesh" + linear_mesh%option_path = linear_mesh_option_path + + if(nlocal_dets > 0) then ! Communicate the local detectors call sam_transfer_detectors(old_linear_mesh, new_positions) call deallocate(old_linear_mesh) - end if - - ! Add the surface mesh data - allocate(boundary_ids(stotel)) - allocate(coplanar_ids(stotel)) - call deinterleave_surface_ids(surface_ids, max_coplanar_id, boundary_ids, coplanar_ids) - call add_faces(linear_mesh, sndgln=senlist, boundary_ids=boundary_ids) - deallocate(boundary_ids) - allocate(linear_mesh%faces%coplanar_ids(stotel)) - linear_mesh%faces%coplanar_ids = coplanar_ids - deallocate(coplanar_ids) - deallocate(surface_ids) - deallocate(senlist) - - ! Check that the level 2 halo is around - if(pncolga >= 0) then + end if + + ! Add the surface mesh data + allocate(boundary_ids(stotel)) + allocate(coplanar_ids(stotel)) + call deinterleave_surface_ids(surface_ids, max_coplanar_id, boundary_ids, coplanar_ids) + call add_faces(linear_mesh, sndgln=senlist, boundary_ids=boundary_ids) + deallocate(boundary_ids) + allocate(linear_mesh%faces%coplanar_ids(stotel)) + linear_mesh%faces%coplanar_ids = coplanar_ids + deallocate(coplanar_ids) + deallocate(surface_ids) + deallocate(senlist) + + ! Check that the level 2 halo is around + if(pncolga >= 0) then allocate(linear_mesh%halos(2)) - else + else allocate(linear_mesh%halos(1)) - end if - - ! Export the level 1 halo - allocate(colgat(ncolga)) - allocate(scater(nscate)) - allocate(atosen(getnprocs() + 1)) - allocate(atorec(getnprocs() + 1)) - ewrite(1, *) "Calling sam_export_halo from sam_drive" - call sam_export_halo(colgat, atosen, scater, atorec, ncolga, nscate, getnprocs(), nnodp, nonods) - ewrite(1, *) "Exited sam_export_halo" - assert(nonods == node_count(linear_mesh)) - ! Form a halo from the primitive data structures - call form_halo_from_raw_data(linear_mesh%halos(1), getnprocs(), colgat, atosen, scater, atorec, nowned_nodes = nnodp) - ! Deallocate the primitive data structures - deallocate(colgat) - deallocate(atosen) - deallocate(scater) - deallocate(atorec) + end if + + ! Export the level 1 halo + allocate(colgat(ncolga)) + allocate(scater(nscate)) + allocate(atosen(getnprocs() + 1)) + allocate(atorec(getnprocs() + 1)) + ewrite(1, *) "Calling sam_export_halo from sam_drive" + call sam_export_halo(colgat, atosen, scater, atorec, ncolga, nscate, getnprocs(), nnodp, nonods) + ewrite(1, *) "Exited sam_export_halo" + assert(nonods == node_count(linear_mesh)) + ! Form a halo from the primitive data structures + call form_halo_from_raw_data(linear_mesh%halos(1), getnprocs(), colgat, atosen, scater, atorec, nowned_nodes = nnodp) + ! Deallocate the primitive data structures + deallocate(colgat) + deallocate(atosen) + deallocate(scater) + deallocate(atorec) #ifdef DDEBUG - if(isparallel()) then + if(isparallel()) then ! Check the new halo assert(trailing_receives_consistent(linear_mesh%halos(1))) assert(halo_valid_for_communication(linear_mesh%halos(1))) assert(halo_verifies(linear_mesh%halos(1), new_positions)) - end if + end if #endif - if(pncolga >= 0) then + if(pncolga >= 0) then ! In "mixed formulation" export the level 2 halo assert(pnscate >= 0) allocate(colgat(pncolga)) @@ -1051,240 +1051,240 @@ subroutine sam_drive(states, options, metric, external_mesh_name, initialise_fie ! Derive the elements halo allocate(linear_mesh%element_halos(2)) call derive_element_halo_from_node_halo(linear_mesh, & - & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) - else + & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) + else if(.not. serial_storage_halo(linear_mesh%halos(1))) then ! Cannot derive halos in serial - allocate(linear_mesh%element_halos(1)) - call derive_element_halo_from_node_halo(linear_mesh, & - & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) + allocate(linear_mesh%element_halos(1)) + call derive_element_halo_from_node_halo(linear_mesh, & + & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) else - allocate(linear_mesh%element_halos(0)) + allocate(linear_mesh%element_halos(0)) end if - end if + end if - ! Insert the positions and linear mesh into all states - call insert(states, linear_mesh, trim(linear_mesh_name)) - call insert(states, new_positions, trim(linear_coordinate_field_name)) + ! Insert the positions and linear mesh into all states + call insert(states, linear_mesh, trim(linear_mesh_name)) + call insert(states, new_positions, trim(linear_coordinate_field_name)) - ! Insert meshes from reserve state - call restore_reserved_meshes(states) - ! Next we recreate all derived meshes - call insert_derived_meshes(states) - ! Then reallocate all fields - call allocate_and_insert_fields(states, dont_allocate_prognostic_value_spaces = .true.) + ! Insert meshes from reserve state + call restore_reserved_meshes(states) + ! Next we recreate all derived meshes + call insert_derived_meshes(states) + ! Then reallocate all fields + call allocate_and_insert_fields(states, dont_allocate_prognostic_value_spaces = .true.) - ! Now extract all fields in the reverse order we put them in - call allocate(linear_s, linear_mesh, "LinearScalarField") - call allocate(linear_v, dim, linear_mesh, "LinearVectorField") - call allocate(linear_t, linear_mesh, "LinearTensorField") + ! Now extract all fields in the reverse order we put them in + call allocate(linear_s, linear_mesh, "LinearScalarField") + call allocate(linear_v, dim, linear_mesh, "LinearVectorField") + call allocate(linear_t, linear_mesh, "LinearTensorField") - if(present(metric)) then + if(present(metric)) then do component_i=dim,1,-1 - do component_j=dim,1,-1 - call sam_pop_field(linear_t%val(component_i, component_j, :), node_count(linear_mesh)) - end do + do component_j=dim,1,-1 + call sam_pop_field(linear_t%val(component_i, component_j, :), node_count(linear_mesh)) + end do end do call allocate(metric, linear_mesh, name = metric_name) call remap_field(linear_t, metric) #ifdef DDEBUG call check_metric(metric) #endif - end if + end if - allocate(value(1:node_count(linear_mesh))) - ! Extract field data from sam - do state=size(states),1,-1 + allocate(value(1:node_count(linear_mesh))) + ! Extract field data from sam + do state=size(states),1,-1 do field=tcount(state),1,-1 - do component_i=dim,1,-1 - do component_j=dim,1,-1 - call sam_pop_field(linear_t%val(component_i, component_j, :), node_count(linear_mesh)) - end do - end do - - field_t => extract_tensor_field(states(state), trim(namelist_t(state, field))) - deallocate(field_t%val) - allocate(field_t%val(dim, dim, node_count(field_t%mesh))) + do component_i=dim,1,-1 + do component_j=dim,1,-1 + call sam_pop_field(linear_t%val(component_i, component_j, :), node_count(linear_mesh)) + end do + end do + + field_t => extract_tensor_field(states(state), trim(namelist_t(state, field))) + deallocate(field_t%val) + allocate(field_t%val(dim, dim, node_count(field_t%mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("tensor_field", "real", node_count(field_t%mesh)*mesh_dim(field_t%mesh)**2, name=trim(field_t%name)) + call register_allocation("tensor_field", "real", node_count(field_t%mesh)*mesh_dim(field_t%mesh)**2, name=trim(field_t%name)) #endif - field_t%field_type = FIELD_TYPE_NORMAL + field_t%field_type = FIELD_TYPE_NORMAL - call remap_field(linear_t, field_t) + call remap_field(linear_t, field_t) end do do field=vcount(state),1,-1 - do component=dim,1,-1 - call sam_pop_field(value, node_count(linear_mesh)) - call set_all(linear_v, component, value) - end do - - field_v => extract_vector_field(states(state), trim(namelist_v(state, field))) - deallocate(field_v%val) - allocate(field_v%val(dim,node_count(field_v%mesh))) + do component=dim,1,-1 + call sam_pop_field(value, node_count(linear_mesh)) + call set_all(linear_v, component, value) + end do + + field_v => extract_vector_field(states(state), trim(namelist_v(state, field))) + deallocate(field_v%val) + allocate(field_v%val(dim,node_count(field_v%mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("vector_field", "real", node_count(field_v%mesh)*mesh_dim(field_v%mesh), name=trim(field_v%name)) + call register_allocation("vector_field", "real", node_count(field_v%mesh)*mesh_dim(field_v%mesh), name=trim(field_v%name)) #endif - field_v%field_type = FIELD_TYPE_NORMAL + field_v%field_type = FIELD_TYPE_NORMAL - call remap_field(linear_v, field_v) + call remap_field(linear_v, field_v) end do do field=scount(state),1,-1 - call sam_pop_field(linear_s%val, node_count(linear_mesh)) + call sam_pop_field(linear_s%val, node_count(linear_mesh)) - field_s => extract_scalar_field(states(state), trim(namelist_s(state, field))) - deallocate(field_s%val) - allocate(field_s%val(node_count(field_s%mesh))) + field_s => extract_scalar_field(states(state), trim(namelist_s(state, field))) + deallocate(field_s%val) + allocate(field_s%val(node_count(field_s%mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("scalar_field", "real", size(field_s%val), name=trim(field_s%name)) + call register_allocation("scalar_field", "real", size(field_s%val), name=trim(field_s%name)) #endif - field_s%field_type = FIELD_TYPE_NORMAL + field_s%field_type = FIELD_TYPE_NORMAL - call remap_field(linear_s, field_s) + call remap_field(linear_s, field_s) end do - end do + end do - call deallocate(linear_s) - call deallocate(linear_v) - call deallocate(linear_t) + call deallocate(linear_s) + call deallocate(linear_v) + call deallocate(linear_t) - deallocate(namelist_s) - deallocate(namelist_v) - deallocate(namelist_t) + deallocate(namelist_s) + deallocate(namelist_v) + deallocate(namelist_t) - ! We're done with the new positions now so we may drop our reference - call deallocate(new_positions) + ! We're done with the new positions now so we may drop our reference + call deallocate(new_positions) - ! Make sure all fields have their value space allocated, even those that - ! aren't interpolated - call allocate_remaining_fields(states) + ! Make sure all fields have their value space allocated, even those that + ! aren't interpolated + call allocate_remaining_fields(states) - ! The following is the same as the tail of populate_state: - ! Prescribed fields are recalculated - call set_prescribed_field_values(states, exclude_interpolated=.true.) - ! Add on the boundary conditions again - call populate_boundary_conditions(states) - ! Set their values - call set_boundary_conditions_values(states) - ! if strong bc or weak that overwrite then enforce the bc on the fields - call set_dirichlet_consistent(states) - ! Insert aliased fields in state - call alias_fields(states) + ! The following is the same as the tail of populate_state: + ! Prescribed fields are recalculated + call set_prescribed_field_values(states, exclude_interpolated=.true.) + ! Add on the boundary conditions again + call populate_boundary_conditions(states) + ! Set their values + call set_boundary_conditions_values(states) + ! if strong bc or weak that overwrite then enforce the bc on the fields + call set_dirichlet_consistent(states) + ! Insert aliased fields in state + call alias_fields(states) - ! Step 6. Cleanup + ! Step 6. Cleanup - ewrite(1, *) "Calling sam_cleanup from sam_drive" - call sam_cleanup - ewrite(1, *) "Exited sam_cleanup" + ewrite(1, *) "Calling sam_cleanup from sam_drive" + call sam_cleanup + ewrite(1, *) "Exited sam_cleanup" - call ewrite_load_imbalance(2, "Owned nodes:", nnodp) - call ewrite_load_imbalance(2, "Total nodes:", nonods) - call ewrite_load_imbalance(2, "Total elements:", totele) + call ewrite_load_imbalance(2, "Owned nodes:", nnodp) + call ewrite_load_imbalance(2, "Total nodes:", nonods) + call ewrite_load_imbalance(2, "Total elements:", totele) - call toc(TICTOC_ID_DATA_REMAP) - ewrite(1, *) "Exiting sam_drive" - end subroutine sam_drive + call toc(TICTOC_ID_DATA_REMAP) + ewrite(1, *) "Exiting sam_drive" + end subroutine sam_drive - subroutine allocate_remaining_fields(states) - !!< Allocate all fields that have not had their value spaces allocated, - !!< but which are non-constant + subroutine allocate_remaining_fields(states) + !!< Allocate all fields that have not had their value spaces allocated, + !!< but which are non-constant - type(state_type), dimension(:), intent(inout) :: states + type(state_type), dimension(:), intent(inout) :: states - integer :: i, j - type(scalar_field), pointer :: s_field - type(tensor_field), pointer :: t_field - type(vector_field), pointer :: v_field + integer :: i, j + type(scalar_field), pointer :: s_field + type(tensor_field), pointer :: t_field + type(vector_field), pointer :: v_field - do i = 1, size(states) + do i = 1, size(states) do j = 1, scalar_field_count(states(i)) - s_field => extract_scalar_field(states(i), j) - if(s_field%field_type == FIELD_TYPE_DEFERRED) then - deallocate(s_field%val) - allocate(s_field%val(node_count(s_field%mesh))) + s_field => extract_scalar_field(states(i), j) + if(s_field%field_type == FIELD_TYPE_DEFERRED) then + deallocate(s_field%val) + allocate(s_field%val(node_count(s_field%mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("scalar_field", "real", size(s_field%val), name=trim(s_field%name)) + call register_allocation("scalar_field", "real", size(s_field%val), name=trim(s_field%name)) #endif - s_field%field_type = FIELD_TYPE_NORMAL - call zero(s_field) - end if + s_field%field_type = FIELD_TYPE_NORMAL + call zero(s_field) + end if end do do j = 1, vector_field_count(states(i)) - v_field => extract_vector_field(states(i), j) - if(v_field%field_type == FIELD_TYPE_DEFERRED) then - deallocate(v_field%val) - allocate(v_field%val(mesh_dim(v_field%mesh),node_count(v_field%mesh))) + v_field => extract_vector_field(states(i), j) + if(v_field%field_type == FIELD_TYPE_DEFERRED) then + deallocate(v_field%val) + allocate(v_field%val(mesh_dim(v_field%mesh),node_count(v_field%mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("vector_field", "real", node_count(v_field%mesh)*mesh_dim(v_field%mesh), name=trim(v_field%name)) + call register_allocation("vector_field", "real", node_count(v_field%mesh)*mesh_dim(v_field%mesh), name=trim(v_field%name)) #endif - v_field%field_type = FIELD_TYPE_NORMAL - call zero(v_field) - end if + v_field%field_type = FIELD_TYPE_NORMAL + call zero(v_field) + end if end do do j = 1, tensor_field_count(states(i)) - t_field => extract_tensor_field(states(i), j) - if(t_field%field_type == FIELD_TYPE_DEFERRED) then - deallocate(t_field%val) - allocate(t_field%val(mesh_dim(t_field%mesh), mesh_dim(t_field%mesh), node_count(t_field%mesh))) + t_field => extract_tensor_field(states(i), j) + if(t_field%field_type == FIELD_TYPE_DEFERRED) then + deallocate(t_field%val) + allocate(t_field%val(mesh_dim(t_field%mesh), mesh_dim(t_field%mesh), node_count(t_field%mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("tensor_field", "real", node_count(t_field%mesh)*mesh_dim(t_field%mesh)**2, name=trim(t_field%name)) + call register_allocation("tensor_field", "real", node_count(t_field%mesh)*mesh_dim(t_field%mesh)**2, name=trim(t_field%name)) #endif - t_field%field_type = FIELD_TYPE_NORMAL - call zero(t_field) - end if + t_field%field_type = FIELD_TYPE_NORMAL + call zero(t_field) + end if end do - end do - - end subroutine allocate_remaining_fields - - subroutine sam_init(states, options, max_coplanar_id, metric, external_mesh_name) - !!< Initialise sam, with the external mesh in the supplied states. - - type(state_type), dimension(:), intent(in) :: states - integer, intent(out) :: max_coplanar_id - type(tensor_field), optional, intent(in) :: metric - character(len=FIELD_NAME_LEN), optional, intent(in) :: external_mesh_name - - ! sam_init_c variables - integer :: nonods, totele, stotel - integer, dimension(:), allocatable :: scater, atorec, gather, atosen - integer :: nscate - integer, dimension(:), pointer :: ndglno - integer, dimension(:), allocatable :: surfid, sndgln - integer :: nloc, snloc - real, dimension(:), allocatable :: metric_handle - integer :: nfields - real, dimension(:), pointer :: fields - real, dimension(1), target :: dummy - integer, dimension(10), intent(in) :: options - real :: mestp1 - real, dimension(:,:), allocatable :: xyz - - integer :: dim, i, j, nprocs - type(halo_type) :: halo - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - - ewrite(1, *) "In sam_init" - - ! Extract the external mesh and mesh field - mesh => get_external_mesh(states, external_mesh_name=external_mesh_name) - positions => extract_vector_field(states(1), "Coordinate") - dim = mesh_dim(mesh) - nonods = node_count(mesh) - totele = ele_count(mesh) - stotel = unique_surface_element_count(mesh) - nloc = mesh%shape%loc - snloc = mesh%faces%surface_mesh%shape%loc - ndglno => mesh%ndglno - allocate(sndgln(stotel * snloc)) - call getsndgln(mesh, sndgln) - allocate(surfid(unique_surface_element_count(mesh))) - call interleave_surface_ids(mesh, surfid, max_coplanar_id) - - ! Extract the level 1 halo - nprocs = getnprocs() - if(halo_count(mesh) > 0) then + end do + + end subroutine allocate_remaining_fields + + subroutine sam_init(states, options, max_coplanar_id, metric, external_mesh_name) + !!< Initialise sam, with the external mesh in the supplied states. + + type(state_type), dimension(:), intent(in) :: states + integer, intent(out) :: max_coplanar_id + type(tensor_field), optional, intent(in) :: metric + character(len=FIELD_NAME_LEN), optional, intent(in) :: external_mesh_name + + ! sam_init_c variables + integer :: nonods, totele, stotel + integer, dimension(:), allocatable :: scater, atorec, gather, atosen + integer :: nscate + integer, dimension(:), pointer :: ndglno + integer, dimension(:), allocatable :: surfid, sndgln + integer :: nloc, snloc + real, dimension(:), allocatable :: metric_handle + integer :: nfields + real, dimension(:), pointer :: fields + real, dimension(1), target :: dummy + integer, dimension(10), intent(in) :: options + real :: mestp1 + real, dimension(:,:), allocatable :: xyz + + integer :: dim, i, j, nprocs + type(halo_type) :: halo + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + + ewrite(1, *) "In sam_init" + + ! Extract the external mesh and mesh field + mesh => get_external_mesh(states, external_mesh_name=external_mesh_name) + positions => extract_vector_field(states(1), "Coordinate") + dim = mesh_dim(mesh) + nonods = node_count(mesh) + totele = ele_count(mesh) + stotel = unique_surface_element_count(mesh) + nloc = mesh%shape%loc + snloc = mesh%faces%surface_mesh%shape%loc + ndglno => mesh%ndglno + allocate(sndgln(stotel * snloc)) + call getsndgln(mesh, sndgln) + allocate(surfid(unique_surface_element_count(mesh))) + call interleave_surface_ids(mesh, surfid, max_coplanar_id) + + ! Extract the level 1 halo + nprocs = getnprocs() + if(halo_count(mesh) > 0) then halo = mesh%halos(1) assert(trailing_receives_consistent(halo)) assert(halo_valid_for_communication(halo)) @@ -1296,9 +1296,9 @@ subroutine sam_init(states, options, max_coplanar_id, metric, external_mesh_name allocate(scater(nscate)) allocate(atorec(halo_proc_count(halo) + 1)) call extract_raw_halo_data(halo, gather, atosen, scater, atorec) - else + else if(isparallel()) then - ewrite(-1, *) "Warning: sam_init called in parallel with no level one halo" + ewrite(-1, *) "Warning: sam_init called in parallel with no level one halo" end if allocate(gather(0)) allocate(atosen(nprocs + 1)) @@ -1307,442 +1307,442 @@ subroutine sam_init(states, options, max_coplanar_id, metric, external_mesh_name allocate(atorec(nprocs + 1)) atosen = 0 atorec = 0 - end if + end if - ! Form the metric - allocate(metric_handle(dim * dim * nonods)) - if(present(metric)) then + ! Form the metric + allocate(metric_handle(dim * dim * nonods)) + if(present(metric)) then metric_handle = reshape(metric%val, (/nonods * dim ** 2/)) - else + else ! Gerard: Do we really want to allocate 9 * nonods ! just for the identity? For a man worried about memory ! this is incredibly wasteful. metric_handle = 0.0 forall(i = 0:nonods - 1, j = 0:dim - 1) - metric_handle(i * dim ** 2 + 1 + j * dim) = 1.0 + metric_handle(i * dim ** 2 + 1 + j * dim) = 1.0 end forall - end if + end if - ! The field data is taken care of later - nfields = 0 - dummy = 0 - fields => dummy + ! The field data is taken care of later + nfields = 0 + dummy = 0 + fields => dummy - allocate(xyz(1:nonods,1:3)) - xyz(:,1:positions%dim)=transpose(positions%val) - xyz(:,positions%dim+1:)=0.0 + allocate(xyz(1:nonods,1:3)) + xyz(:,1:positions%dim)=transpose(positions%val) + xyz(:,positions%dim+1:)=0.0 - call get_option('/mesh_adaptivity/hr_adaptivity/functional_tolerance', mestp1, default = 0.0) + call get_option('/mesh_adaptivity/hr_adaptivity/functional_tolerance', mestp1, default = 0.0) - ewrite(1, *) "Calling sam_init_c from sam_init" - call sam_init_c(dim, nonods, totele, stotel, & - & gather, atosen, & - & scater(1:nscate), atorec, & - & size(gather), nscate, nprocs, & - & ndglno(1:totele * nloc), nloc, & - & sndgln(1:stotel * snloc), surfid(1:stotel), snloc, & - & xyz(:,1), xyz(:,2), xyz(:,3), & - & metric_handle(1:nonods * dim ** 2), fields, nfields, & - & options, mestp1) - deallocate(xyz) - ewrite(1, *) "Exited sam_init_c" + ewrite(1, *) "Calling sam_init_c from sam_init" + call sam_init_c(dim, nonods, totele, stotel, & + & gather, atosen, & + & scater(1:nscate), atorec, & + & size(gather), nscate, nprocs, & + & ndglno(1:totele * nloc), nloc, & + & sndgln(1:stotel * snloc), surfid(1:stotel), snloc, & + & xyz(:,1), xyz(:,2), xyz(:,3), & + & metric_handle(1:nonods * dim ** 2), fields, nfields, & + & options, mestp1) + deallocate(xyz) + ewrite(1, *) "Exited sam_init_c" - deallocate(sndgln) - deallocate(surfid) - deallocate(gather) - deallocate(atosen) - deallocate(scater) - deallocate(atorec) - deallocate(metric_handle) + deallocate(sndgln) + deallocate(surfid) + deallocate(gather) + deallocate(atosen) + deallocate(scater) + deallocate(atorec) + deallocate(metric_handle) - ewrite(1, *) "Exiting sam_init" + ewrite(1, *) "Exiting sam_init" - end subroutine sam_init + end subroutine sam_init - subroutine sam_add_field_scalar(field) - type(scalar_field), intent(in) :: field + subroutine sam_add_field_scalar(field) + type(scalar_field), intent(in) :: field - call sam_add_field(field%val, node_count(field)) + call sam_add_field(field%val, node_count(field)) - end subroutine sam_add_field_scalar + end subroutine sam_add_field_scalar - subroutine sam_add_field_vector(field) - type(vector_field), intent(in) :: field + subroutine sam_add_field_vector(field) + type(vector_field), intent(in) :: field - real, dimension(:), allocatable:: value - integer :: i + real, dimension(:), allocatable:: value + integer :: i - allocate( value(1:node_count(field)) ) - do i=1,field%dim + allocate( value(1:node_count(field)) ) + do i=1,field%dim value=field%val(i,:) call sam_add_field(value, node_count(field)) - end do + end do - end subroutine sam_add_field_vector + end subroutine sam_add_field_vector - subroutine sam_add_field_tensor(field) - type(tensor_field), intent(in) :: field + subroutine sam_add_field_tensor(field) + type(tensor_field), intent(in) :: field - integer :: i, j + integer :: i, j - do i=1,mesh_dim(field%mesh) + do i=1,mesh_dim(field%mesh) do j=1,mesh_dim(field%mesh) - call sam_add_field(field%val(i, j, :), node_count(field)) + call sam_add_field(field%val(i, j, :), node_count(field)) end do - end do + end do - end subroutine sam_add_field_tensor + end subroutine sam_add_field_tensor - subroutine sam_transfer_detectors(old_mesh, new_positions) - type(mesh_type), intent(in) :: old_mesh - type(vector_field), intent(inout) :: new_positions + subroutine sam_transfer_detectors(old_mesh, new_positions) + type(mesh_type), intent(in) :: old_mesh + type(vector_field), intent(inout) :: new_positions - integer :: nnodes - integer, dimension(:), allocatable :: node_ownership + integer :: nnodes + integer, dimension(:), allocatable :: node_ownership - nnodes = node_count(old_mesh) - allocate(node_ownership(nnodes)) - call sam_export_node_ownership(node_ownership, nnodes) - node_ownership = node_ownership + 1 + nnodes = node_count(old_mesh) + allocate(node_ownership(nnodes)) + call sam_export_node_ownership(node_ownership, nnodes) + node_ownership = node_ownership + 1 - call transfer_detectors(old_mesh, new_positions, node_ownership) + call transfer_detectors(old_mesh, new_positions, node_ownership) - deallocate(node_ownership) + deallocate(node_ownership) - end subroutine sam_transfer_detectors + end subroutine sam_transfer_detectors - subroutine halo_transfer_detectors(old_mesh, new_positions) - type(mesh_type), intent(in) :: old_mesh - type(vector_field), intent(inout) :: new_positions + subroutine halo_transfer_detectors(old_mesh, new_positions) + type(mesh_type), intent(in) :: old_mesh + type(vector_field), intent(inout) :: new_positions - integer :: nhalos, nnodes - integer, dimension(:), allocatable :: node_ownership - type(halo_type), pointer :: halo + integer :: nhalos, nnodes + integer, dimension(:), allocatable :: node_ownership + type(halo_type), pointer :: halo - nhalos = halo_count(old_mesh) - if(nhalos == 0) return - halo => old_mesh%halos(nhalos) + nhalos = halo_count(old_mesh) + if(nhalos == 0) return + halo => old_mesh%halos(nhalos) - nnodes = node_count(old_mesh) - allocate(node_ownership(nnodes)) - call get_node_owners(halo, node_ownership) + nnodes = node_count(old_mesh) + allocate(node_ownership(nnodes)) + call get_node_owners(halo, node_ownership) - call transfer_detectors(old_mesh, new_positions, node_ownership) + call transfer_detectors(old_mesh, new_positions, node_ownership) - deallocate(node_ownership) + deallocate(node_ownership) - end subroutine halo_transfer_detectors + end subroutine halo_transfer_detectors - subroutine transfer_detectors(old_mesh, new_positions, node_ownership) - type(mesh_type), intent(in) :: old_mesh - type(vector_field), intent(inout) :: new_positions - integer, dimension(node_count(old_mesh)) :: node_ownership + subroutine transfer_detectors(old_mesh, new_positions, node_ownership) + type(mesh_type), intent(in) :: old_mesh + type(vector_field), intent(inout) :: new_positions + integer, dimension(node_count(old_mesh)) :: node_ownership - integer :: communicator, i, j, nhalos, nprocs, & + integer :: communicator, i, j, nhalos, nprocs, & & owner, procno - type(detector_type), pointer :: next_node, node - type(halo_type), pointer :: halo - - integer, parameter :: idata_size = 2 - integer :: rdata_size - - integer, dimension(:), allocatable :: nsends, data_index - type(integer_vector), dimension(:), allocatable :: isend_data - type(real_vector), dimension(:), allocatable :: rsend_data - - integer, dimension(:), allocatable :: nreceives - type(integer_vector), dimension(:), allocatable :: ireceive_data - type(real_vector), dimension(:), allocatable :: rreceive_data - - integer :: ierr, tag - integer, dimension(:), allocatable :: requests, statuses - - nhalos = halo_count(old_mesh) - if(nhalos == 0) return - halo => old_mesh%halos(nhalos) - communicator = halo_communicator(halo) - procno = getprocno(communicator = communicator) - nprocs = halo_proc_count(halo) - - rdata_size = new_positions%dim - - allocate(nsends(nprocs)) - nsends = 0 - node => default_stat%detector_list%first - do while(associated(node)) - if(node%element > 0) then - owner = minval(node_ownership(ele_nodes(old_mesh, node%element))) - if(owner /= procno) then - nsends(owner) = nsends(owner) + 1 - end if - end if + type(detector_type), pointer :: next_node, node + type(halo_type), pointer :: halo + + integer, parameter :: idata_size = 2 + integer :: rdata_size + + integer, dimension(:), allocatable :: nsends, data_index + type(integer_vector), dimension(:), allocatable :: isend_data + type(real_vector), dimension(:), allocatable :: rsend_data + + integer, dimension(:), allocatable :: nreceives + type(integer_vector), dimension(:), allocatable :: ireceive_data + type(real_vector), dimension(:), allocatable :: rreceive_data + + integer :: ierr, tag + integer, dimension(:), allocatable :: requests, statuses + + nhalos = halo_count(old_mesh) + if(nhalos == 0) return + halo => old_mesh%halos(nhalos) + communicator = halo_communicator(halo) + procno = getprocno(communicator = communicator) + nprocs = halo_proc_count(halo) + + rdata_size = new_positions%dim + + allocate(nsends(nprocs)) + nsends = 0 + node => default_stat%detector_list%first + do while(associated(node)) + if(node%element > 0) then + owner = minval(node_ownership(ele_nodes(old_mesh, node%element))) + if(owner /= procno) then + nsends(owner) = nsends(owner) + 1 + end if + end if - node => node%next - end do - - allocate(isend_data(nprocs)) - allocate(rsend_data(nprocs)) - do i = 1, nprocs - allocate(isend_data(i)%ptr(nsends(i) * idata_size)) - allocate(rsend_data(i)%ptr(nsends(i) * rdata_size)) - end do - - allocate(data_index(nprocs)) - data_index = 0 - node => default_stat%detector_list%first - do while(associated(node)) - next_node => node%next - - if(node%element > 0) then - owner = minval(node_ownership(ele_nodes(old_mesh, node%element))) - if(owner /= procno) then - ! Pack this node for sending - - ! Integer data - isend_data(owner)%ptr(data_index(owner) * idata_size + 1) = node%id_number - ! Real data - rsend_data(owner)%ptr(data_index(owner) * rdata_size + 1:data_index(owner) * rdata_size + new_positions%dim) = node%position - - data_index(owner) = data_index(owner) + 1 - - ! Delete this node from the detector list - call delete(node, default_stat%detector_list) - end if - end if + node => node%next + end do - node => next_node - end do - deallocate(data_index) + allocate(isend_data(nprocs)) + allocate(rsend_data(nprocs)) + do i = 1, nprocs + allocate(isend_data(i)%ptr(nsends(i) * idata_size)) + allocate(rsend_data(i)%ptr(nsends(i) * rdata_size)) + end do - ewrite(2, *) "Detectors to be sent: ", sum(nsends) + allocate(data_index(nprocs)) + data_index = 0 + node => default_stat%detector_list%first + do while(associated(node)) + next_node => node%next - allocate(nreceives(nprocs)) - nreceives = invert_comms_sizes(nsends, communicator = communicator) + if(node%element > 0) then + owner = minval(node_ownership(ele_nodes(old_mesh, node%element))) + if(owner /= procno) then + ! Pack this node for sending - ewrite(2, *) "Detectors to be received: ", sum(nreceives) + ! Integer data + isend_data(owner)%ptr(data_index(owner) * idata_size + 1) = node%id_number + ! Real data + rsend_data(owner)%ptr(data_index(owner) * rdata_size + 1:data_index(owner) * rdata_size + new_positions%dim) = node%position - allocate(ireceive_data(nprocs)) - allocate(rreceive_data(nprocs)) - do i = 1, nprocs - allocate(ireceive_data(i)%ptr(nreceives(i) * idata_size)) - allocate(rreceive_data(i)%ptr(nreceives(i) * rdata_size)) - end do + data_index(owner) = data_index(owner) + 1 - ! Set up non-blocking communications - allocate(requests(nprocs * 4)) - requests = MPI_REQUEST_NULL - tag = next_mpi_tag() + ! Delete this node from the detector list + call delete(node, default_stat%detector_list) + end if + end if - do i = 1, nprocs - ! Non-blocking sends - if(nsends(i) > 0) then - call mpi_isend(isend_data(i)%ptr, nsends(i) * idata_size, getpinteger(), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_isend(rsend_data(i)%ptr, nsends(i) * rdata_size, getpreal(), i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if + node => next_node + end do + deallocate(data_index) - ! Non-blocking receives - if(nreceives(i) > 0) then - call mpi_irecv(ireceive_data(i)%ptr, nreceives(i) * idata_size, getpinteger(), i - 1, tag, communicator, requests(i + 2 * nprocs), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_irecv(rreceive_data(i)%ptr, nreceives(i) * rdata_size, getpreal(), i - 1, tag, communicator, requests(i + 3 * nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - deallocate(nsends) - do i = 1, nprocs - deallocate(isend_data(i)%ptr) - deallocate(rsend_data(i)%ptr) - end do - deallocate(isend_data) - deallocate(rsend_data) - - do i = 1, nprocs - do j = 1, nreceives(i) - ! Unpack the node - allocate(node) - - ! Integer data - node%id_number = ireceive_data(i)%ptr((j - 1) * idata_size + 1) - - ! Real data - allocate(node%position(new_positions%dim)) - node%position = rreceive_data(i)%ptr((j - 1) * rdata_size + 1:(j - 1) * rdata_size + new_positions%dim) - - ! Recoverable data, not communicated - allocate(node%local_coords(new_positions%dim + 1)) - - call insert(node, default_stat%detector_list) + ewrite(2, *) "Detectors to be sent: ", sum(nsends) + + allocate(nreceives(nprocs)) + nreceives = invert_comms_sizes(nsends, communicator = communicator) + + ewrite(2, *) "Detectors to be received: ", sum(nreceives) + + allocate(ireceive_data(nprocs)) + allocate(rreceive_data(nprocs)) + do i = 1, nprocs + allocate(ireceive_data(i)%ptr(nreceives(i) * idata_size)) + allocate(rreceive_data(i)%ptr(nreceives(i) * rdata_size)) end do - deallocate(ireceive_data(i)%ptr) - deallocate(rreceive_data(i)%ptr) - end do + ! Set up non-blocking communications + allocate(requests(nprocs * 4)) + requests = MPI_REQUEST_NULL + tag = next_mpi_tag() + + do i = 1, nprocs + ! Non-blocking sends + if(nsends(i) > 0) then + call mpi_isend(isend_data(i)%ptr, nsends(i) * idata_size, getpinteger(), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_isend(rsend_data(i)%ptr, nsends(i) * rdata_size, getpreal(), i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if - deallocate(nreceives) - deallocate(ireceive_data) - deallocate(rreceive_data) + ! Non-blocking receives + if(nreceives(i) > 0) then + call mpi_irecv(ireceive_data(i)%ptr, nreceives(i) * idata_size, getpinteger(), i - 1, tag, communicator, requests(i + 2 * nprocs), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_irecv(rreceive_data(i)%ptr, nreceives(i) * rdata_size, getpreal(), i - 1, tag, communicator, requests(i + 3 * nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do - ! Update the detector element ownership data - call search_for_detectors(default_stat%detector_list, new_positions) + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + deallocate(nsends) + do i = 1, nprocs + deallocate(isend_data(i)%ptr) + deallocate(rsend_data(i)%ptr) + end do + deallocate(isend_data) + deallocate(rsend_data) - end subroutine transfer_detectors + do i = 1, nprocs + do j = 1, nreceives(i) + ! Unpack the node + allocate(node) - function load_imbalance(count) - !!< Calculates the load imbalance metric: - !!< (Max in a domain - Mean in a domain) - !!< (----------------------------------) - !!< ( Mean nodes in a domain ) + ! Integer data + node%id_number = ireceive_data(i)%ptr((j - 1) * idata_size + 1) - integer, intent(in) :: count + ! Real data + allocate(node%position(new_positions%dim)) + node%position = rreceive_data(i)%ptr((j - 1) * rdata_size + 1:(j - 1) * rdata_size + new_positions%dim) - real :: load_imbalance + ! Recoverable data, not communicated + allocate(node%local_coords(new_positions%dim + 1)) -#ifdef HAVE_MPI - integer :: i, max_count, min_count, ierr - integer, dimension(:), allocatable :: node_counts - real :: mean - - allocate(node_counts(getnprocs())) - - call mpi_gather(count, 1, getpinteger(), node_counts, 1, getpinteger(), 0, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - if(getprocno() == 1) then - max_count = node_counts(1) - min_count = node_counts(1) - mean = node_counts(1) - do i = 2, size(node_counts) - max_count = max(max_count, node_counts(i)) - min_count = min(min_count, node_counts(i)) - mean = mean + node_counts(i) + call insert(node, default_stat%detector_list) + end do + + deallocate(ireceive_data(i)%ptr) + deallocate(rreceive_data(i)%ptr) end do - mean = mean / size(node_counts) - load_imbalance = (max_count - mean) / mean - end if - call mpi_bcast(load_imbalance, 1, getpreal(), 0, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) + deallocate(nreceives) + deallocate(ireceive_data) + deallocate(rreceive_data) + + ! Update the detector element ownership data + call search_for_detectors(default_stat%detector_list, new_positions) + + end subroutine transfer_detectors + + function load_imbalance(count) + !!< Calculates the load imbalance metric: + !!< (Max in a domain - Mean in a domain) + !!< (----------------------------------) + !!< ( Mean nodes in a domain ) + + integer, intent(in) :: count - deallocate(node_counts) + real :: load_imbalance + +#ifdef HAVE_MPI + integer :: i, max_count, min_count, ierr + integer, dimension(:), allocatable :: node_counts + real :: mean + + allocate(node_counts(getnprocs())) + + call mpi_gather(count, 1, getpinteger(), node_counts, 1, getpinteger(), 0, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + if(getprocno() == 1) then + max_count = node_counts(1) + min_count = node_counts(1) + mean = node_counts(1) + do i = 2, size(node_counts) + max_count = max(max_count, node_counts(i)) + min_count = min(min_count, node_counts(i)) + mean = mean + node_counts(i) + end do + mean = mean / size(node_counts) + load_imbalance = (max_count - mean) / mean + end if + + call mpi_bcast(load_imbalance, 1, getpreal(), 0, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + deallocate(node_counts) #else - load_imbalance = 0.0 + load_imbalance = 0.0 #endif - end function load_imbalance + end function load_imbalance - subroutine ewrite_load_imbalance(debug_level, prefix, count) - !!< ewrite the load imbalance at the supplied debug level, based upon the - !!< supplied count for this process, adding a prefix. + subroutine ewrite_load_imbalance(debug_level, prefix, count) + !!< ewrite the load imbalance at the supplied debug level, based upon the + !!< supplied count for this process, adding a prefix. - integer, intent(in) :: debug_level - character(len = *), intent(in) :: prefix - integer, intent(in) :: count + integer, intent(in) :: debug_level + character(len = *), intent(in) :: prefix + integer, intent(in) :: count - integer :: max_count, min_count - real :: mean, imbalance + integer :: max_count, min_count + real :: mean, imbalance - if(debug_level > current_debug_level) return + if(debug_level > current_debug_level) return - max_count = count - call allmax(max_count) + max_count = count + call allmax(max_count) - min_count = count - call allmin(min_count) + min_count = count + call allmin(min_count) - mean = count - call allmean(mean) + mean = count + call allmean(mean) - imbalance = load_imbalance(count) + imbalance = load_imbalance(count) - if(getprocno() == 1) then - ewrite(debug_level, *) prefix - ewrite(debug_level, *) "Mean = ", mean - ewrite(debug_level, *) "Min. = ", min_count - ewrite(debug_level, *) "Max. = ", max_count - ewrite(debug_level, *) "Imbalance = ", imbalance - end if + if(getprocno() == 1) then + ewrite(debug_level, *) prefix + ewrite(debug_level, *) "Mean = ", mean + ewrite(debug_level, *) "Min. = ", min_count + ewrite(debug_level, *) "Max. = ", max_count + ewrite(debug_level, *) "Imbalance = ", imbalance + end if - end subroutine ewrite_load_imbalance + end subroutine ewrite_load_imbalance - subroutine check_sam_linear_remap_validity(stat,name) - integer, intent(in) :: stat - character(len = * ) :: name + subroutine check_sam_linear_remap_validity(stat,name) + integer, intent(in) :: stat + character(len = * ) :: name - !! short circuit for the trivial case - if (stat==0) return + !! short circuit for the trivial case + if (stat==0) return - ewrite(0,*) "For field ", trim(name) + ewrite(0,*) "For field ", trim(name) - select case(stat) - case (REMAP_ERR_DISCONTINUOUS_CONTINUOUS) - ewrite(0,*) "Unable to redistribute discontinuous field." - case(REMAP_ERR_HIGHER_LOWER_CONTINUOUS) - ewrite(0,*) "Unable to redistribute higher order field." - case(REMAP_ERR_UNPERIODIC_PERIODIC) - ewrite(0,*) "Unable to redistribute field on periodic mesh." - case(REMAP_ERR_BUBBLE_LAGRANGE) - ewrite(0,*) "Unable to redistribute field on finite element mesh with bubble function." - case default - ewrite(0,*) "Failure to remap. This probably means a discretisation type that is not handled by sam" - end select - FLExit("This discretisation is not supported in parallel with libsam. Please consider reconfiguring with Zoltan") + select case(stat) + case (REMAP_ERR_DISCONTINUOUS_CONTINUOUS) + ewrite(0,*) "Unable to redistribute discontinuous field." + case(REMAP_ERR_HIGHER_LOWER_CONTINUOUS) + ewrite(0,*) "Unable to redistribute higher order field." + case(REMAP_ERR_UNPERIODIC_PERIODIC) + ewrite(0,*) "Unable to redistribute field on periodic mesh." + case(REMAP_ERR_BUBBLE_LAGRANGE) + ewrite(0,*) "Unable to redistribute field on finite element mesh with bubble function." + case default + ewrite(0,*) "Failure to remap. This probably means a discretisation type that is not handled by sam" + end select + FLExit("This discretisation is not supported in parallel with libsam. Please consider reconfiguring with Zoltan") - end subroutine check_sam_linear_remap_validity + end subroutine check_sam_linear_remap_validity - subroutine sam_integration_check_options + subroutine sam_integration_check_options - !!< Check libsam integration related options + !!< Check libsam integration related options - if(.not. isparallel()) then - ! Nothing to check - return - end if + if(.not. isparallel()) then + ! Nothing to check + return + end if #ifndef HAVE_ZOLTAN - ewrite(2, *) "Checking libsam integration related options" + ewrite(2, *) "Checking libsam integration related options" - if( have_option("/flredecomp") ) then - FLExit("Specification of flredecomp parameters in the options tree is not supported with libsam. Please remove or reconfigure with Zoltan") - end if + if( have_option("/flredecomp") ) then + FLExit("Specification of flredecomp parameters in the options tree is not supported with libsam. Please remove or reconfigure with Zoltan") + end if - if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")) then - FLExit("Preserving of mesh regions through adapts is not supported in parallel with libsam. Please reconfigure with Zoltan") - end if + if(have_option("/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions")) then + FLExit("Preserving of mesh regions through adapts is not supported in parallel with libsam. Please reconfigure with Zoltan") + end if - if(option_count('/geometry/mesh/from_mesh/extrude')>0) then - FLExit("Mesh extrusion is not supported in parallel with libsam. Please reconfigure with Zoltan") - end if + if(option_count('/geometry/mesh/from_mesh/extrude')>0) then + FLExit("Mesh extrusion is not supported in parallel with libsam. Please reconfigure with Zoltan") + end if - if(option_count('/geometry/mesh/from_mesh/mesh_shape')+option_count('/geometry/mesh/from_mesh/mesh_continuity')>0 .and. & - have_option('/mesh_adaptivity/hr_adaptivity')) then - ! there are meshes that change the mesh_shape or continuity - ! from this we assume: 1) there are non P1 meshes, 2) there are fields on these meshes that need to be distributed by SAM - ! neither of those are necessarily always true, but it will be the case in 98% of the cases + if(option_count('/geometry/mesh/from_mesh/mesh_shape')+option_count('/geometry/mesh/from_mesh/mesh_continuity')>0 .and. & + have_option('/mesh_adaptivity/hr_adaptivity')) then + ! there are meshes that change the mesh_shape or continuity + ! from this we assume: 1) there are non P1 meshes, 2) there are fields on these meshes that need to be distributed by SAM + ! neither of those are necessarily always true, but it will be the case in 98% of the cases - ! sam does not handle such fields + ! sam does not handle such fields - ! we allow this for non-adaptive cases - sam is then only going to be invoked during an flredecomp - if the fields - ! on the non-P1 can be represcribed they don't actually need to be handled by sam. This means flredecomp on a non-checkpoint - ! .flml will usually still work. - ewrite(0,*) "It appears you have non P1 meshes (mesh that are not linear and continuous) and are using adaptivity." - ewrite(0,*) "For this to work you need to reconfigure with Zoltan." - FLExit("Non supported discretisation for sam with parallel adaptivity.") - end if + ! we allow this for non-adaptive cases - sam is then only going to be invoked during an flredecomp - if the fields + ! on the non-P1 can be represcribed they don't actually need to be handled by sam. This means flredecomp on a non-checkpoint + ! .flml will usually still work. + ewrite(0,*) "It appears you have non P1 meshes (mesh that are not linear and continuous) and are using adaptivity." + ewrite(0,*) "For this to work you need to reconfigure with Zoltan." + FLExit("Non supported discretisation for sam with parallel adaptivity.") + end if - ewrite(2, *) "Finished checking libsam integration related options" + ewrite(2, *) "Finished checking libsam integration related options" #endif - end subroutine sam_integration_check_options + end subroutine sam_integration_check_options end module sam_integration diff --git a/assemble/Shallow_Water_Equations.F90 b/assemble/Shallow_Water_Equations.F90 index 854f88035e..bbf3cc9063 100644 --- a/assemble/Shallow_Water_Equations.F90 +++ b/assemble/Shallow_Water_Equations.F90 @@ -32,375 +32,375 @@ ! a different implementation than the one in main/Shallow_Water.F90 ! that has its own binary and schema. module shallow_water_equations - use fldebug - use global_parameters, only: OPTION_PATH_LEN - use spud - use sparse_tools - use transform_elements - use fetools - use fields - use state_module - use boundary_conditions + use fldebug + use global_parameters, only: OPTION_PATH_LEN + use spud + use sparse_tools + use transform_elements + use fetools + use fields + use state_module + use boundary_conditions - implicit none + implicit none - private + private - public :: assemble_shallow_water_projection, assemble_swe_divergence_matrix_cg,& - shallow_water_equations_check_options + public :: assemble_shallow_water_projection, assemble_swe_divergence_matrix_cg,& + shallow_water_equations_check_options - contains +contains - ! Assemble the shallow water continuity equation by adding the time derivative (\eta^{n+1}-\eta^n)/dt - ! This is based on assemble_1mat_compressible_projection_cg, but a lot simpler: - ! The density \rho is here the total water depth (bottom depth+fs elevation). Its time-derivative however - ! is the same as the free surface time derivative. Pressure is g*\eta, so drhodp is simply 1/g + ! Assemble the shallow water continuity equation by adding the time derivative (\eta^{n+1}-\eta^n)/dt + ! This is based on assemble_1mat_compressible_projection_cg, but a lot simpler: + ! The density \rho is here the total water depth (bottom depth+fs elevation). Its time-derivative however + ! is the same as the free surface time derivative. Pressure is g*\eta, so drhodp is simply 1/g - subroutine assemble_shallow_water_projection(state, cmc, rhs, dt, theta_pg, theta_divergence, reassemble_cmc_m) + subroutine assemble_shallow_water_projection(state, cmc, rhs, dt, theta_pg, theta_divergence, reassemble_cmc_m) - ! This only works for single material_phase, so just pass me the first state: - type(state_type), intent(inout) :: state - ! the lhs and rhs to add into: - type(csr_matrix), intent(inout) :: cmc - type(scalar_field), intent(inout) :: rhs + ! This only works for single material_phase, so just pass me the first state: + type(state_type), intent(inout) :: state + ! the lhs and rhs to add into: + type(csr_matrix), intent(inout) :: cmc + type(scalar_field), intent(inout) :: rhs - real, intent(in) :: dt - real, intent(in) :: theta_pg, theta_divergence - logical, intent(in) :: reassemble_cmc_m + real, intent(in) :: dt + real, intent(in) :: theta_pg, theta_divergence + logical, intent(in) :: reassemble_cmc_m - integer, dimension(:), pointer :: test_nodes - type(element_type), pointer :: test_shape - real, dimension(:), allocatable :: detwei - real, dimension(:), allocatable :: delta_p_at_quad - real :: rho0, g - integer :: ele + integer, dimension(:), pointer :: test_nodes + type(element_type), pointer :: test_shape + real, dimension(:), allocatable :: detwei + real, dimension(:), allocatable :: delta_p_at_quad + real :: rho0, g + integer :: ele - type(vector_field), pointer :: coordinate - type(scalar_field), pointer :: pressure, old_pressure + type(vector_field), pointer :: coordinate + type(scalar_field), pointer :: pressure, old_pressure - ewrite(1,*) 'Entering assemble_shallow_water_projection' + ewrite(1,*) 'Entering assemble_shallow_water_projection' - call zero(rhs) + call zero(rhs) - ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) - if(reassemble_cmc_m) then - coordinate=> extract_vector_field(state, "Coordinate") + ! only do all this if we need to make cmc (otherwise we'd be adding repeatedly) + if(reassemble_cmc_m) then + coordinate=> extract_vector_field(state, "Coordinate") - pressure => extract_scalar_field(state, "Pressure") - old_pressure => extract_scalar_field(state, "OldPressure") + pressure => extract_scalar_field(state, "Pressure") + old_pressure => extract_scalar_field(state, "OldPressure") - call get_option("/physical_parameters/gravity/magnitude", g) - ! this is the density in front of the du/dt time-derivative which at the - ! moment is hard-coded to 1.0 - rho0 = 1.0 + call get_option("/physical_parameters/gravity/magnitude", g) + ! this is the density in front of the du/dt time-derivative which at the + ! moment is hard-coded to 1.0 + rho0 = 1.0 - allocate(detwei(ele_ngi(pressure, 1)), & - delta_p_at_quad(ele_ngi(pressure, 1))) + allocate(detwei(ele_ngi(pressure, 1)), & + delta_p_at_quad(ele_ngi(pressure, 1))) - do ele=1, element_count(pressure) + do ele=1, element_count(pressure) - test_nodes=>ele_nodes(pressure, ele) + test_nodes=>ele_nodes(pressure, ele) - test_shape => ele_shape(pressure, ele) + test_shape => ele_shape(pressure, ele) - delta_p_at_quad = ele_val_at_quad(pressure, ele) - ele_val_at_quad(old_pressure, ele) + delta_p_at_quad = ele_val_at_quad(pressure, ele) - ele_val_at_quad(old_pressure, ele) - call transform_to_physical(coordinate, ele, detwei=detwei) + call transform_to_physical(coordinate, ele, detwei=detwei) - ! Time derivative: pressure correction \Phi that we are solving for is: \Phi=theta_div*theta_pg*(p^{n+1}-p^*)*dt - ! Thus time derivative lhs is (\eta^{n+1}-\eta^*)/dt = \Phi/(g*dt*dt/theta_div/theta_pg) - call addto(cmc, test_nodes, test_nodes, & - shape_shape(test_shape, test_shape, detwei)/(rho0*g*dt*dt*theta_divergence*theta_pg)) - ! Time derivative rhs: -(\eta^*-\eta^n)/dt = (p^*-p^n)/(g*dt) - call addto(rhs, test_nodes, & - -shape_rhs(test_shape, detwei*delta_p_at_quad)/(rho0*g*dt)) + ! Time derivative: pressure correction \Phi that we are solving for is: \Phi=theta_div*theta_pg*(p^{n+1}-p^*)*dt + ! Thus time derivative lhs is (\eta^{n+1}-\eta^*)/dt = \Phi/(g*dt*dt/theta_div/theta_pg) + call addto(cmc, test_nodes, test_nodes, & + shape_shape(test_shape, test_shape, detwei)/(rho0*g*dt*dt*theta_divergence*theta_pg)) + ! Time derivative rhs: -(\eta^*-\eta^n)/dt = (p^*-p^n)/(g*dt) + call addto(rhs, test_nodes, & + -shape_rhs(test_shape, detwei*delta_p_at_quad)/(rho0*g*dt)) - end do + end do + + deallocate(detwei, delta_p_at_quad) - deallocate(detwei, delta_p_at_quad) + end if - end if + end subroutine assemble_shallow_water_projection - end subroutine assemble_shallow_water_projection + subroutine assemble_swe_divergence_matrix_cg(ctp_m, state, ct_rhs) - subroutine assemble_swe_divergence_matrix_cg(ctp_m, state, ct_rhs) + ! This only works for single material_phase, so just pass me the first state: + type(state_type), intent(inout) :: state - ! This only works for single material_phase, so just pass me the first state: - type(state_type), intent(inout) :: state + ! the divergence matrix and rhs to be assembled + type(block_csr_matrix), pointer :: ctp_m + type(scalar_field), intent(inout), optional :: ct_rhs - ! the divergence matrix and rhs to be assembled - type(block_csr_matrix), pointer :: ctp_m - type(scalar_field), intent(inout), optional :: ct_rhs + ! local + type(mesh_type), pointer :: test_mesh - ! local - type(mesh_type), pointer :: test_mesh + type(vector_field), pointer :: field - type(vector_field), pointer :: field + integer, dimension(:), pointer :: test_nodes, field_nodes - integer, dimension(:), pointer :: test_nodes, field_nodes + real, dimension(:,:,:), allocatable :: ele_mat, ele_mat_bdy + type(element_type), pointer :: field_shape, test_shape + real, dimension(:,:,:), allocatable :: dfield_t, dtest_t, dbottom_t + real, dimension(:), allocatable :: detwei + real, dimension(:,:), allocatable :: normal_bdy - real, dimension(:,:,:), allocatable :: ele_mat, ele_mat_bdy - type(element_type), pointer :: field_shape, test_shape - real, dimension(:,:,:), allocatable :: dfield_t, dtest_t, dbottom_t - real, dimension(:), allocatable :: detwei - real, dimension(:,:), allocatable :: normal_bdy + real, dimension(:), allocatable :: depth_at_quad + real, dimension(:,:), allocatable :: depth_grad_at_quad - real, dimension(:), allocatable :: depth_at_quad - real, dimension(:,:), allocatable :: depth_grad_at_quad + integer :: ele, sele, dim, xdim, ngi - integer :: ele, sele, dim, xdim, ngi + type(vector_field), pointer :: coordinate, velocity + type(scalar_field), pointer :: pressure, old_pressure, bottom_depth + real :: theta, dt, g, rho0 - type(vector_field), pointer :: coordinate, velocity - type(scalar_field), pointer :: pressure, old_pressure, bottom_depth - real :: theta, dt, g, rho0 + ! integrate by parts + logical :: integrate_by_parts - ! integrate by parts - logical :: integrate_by_parts + integer, dimension(:,:), allocatable :: field_bc_type + type(vector_field) :: field_bc - integer, dimension(:,:), allocatable :: field_bc_type - type(vector_field) :: field_bc + ewrite(1,*) 'In assemble_swe_divergence_matrix_cg' - ewrite(1,*) 'In assemble_swe_divergence_matrix_cg' + coordinate=> extract_vector_field(state, "Coordinate") - coordinate=> extract_vector_field(state, "Coordinate") + pressure => extract_scalar_field(state, "Pressure") + old_pressure => extract_scalar_field(state, "OldPressure") + bottom_depth => extract_scalar_field(state, "BottomDepth") - pressure => extract_scalar_field(state, "Pressure") - old_pressure => extract_scalar_field(state, "OldPressure") - bottom_depth => extract_scalar_field(state, "BottomDepth") + velocity=>extract_vector_field(state, "Velocity") - velocity=>extract_vector_field(state, "Velocity") + ! note that unlike for compressible we adhere to the option under pressure + ! (unless DG for which we don't have a choice) + integrate_by_parts=have_option(trim(pressure%option_path)// & + &"/prognostic/spatial_discretisation/integrate_continuity_by_parts") & + &.or. have_option(trim(velocity%option_path)// & + &"/prognostic/spatial_discretisation/discontinuous_galerkin") - ! note that unlike for compressible we adhere to the option under pressure - ! (unless DG for which we don't have a choice) - integrate_by_parts=have_option(trim(pressure%option_path)// & - &"/prognostic/spatial_discretisation/integrate_continuity_by_parts") & - &.or. have_option(trim(velocity%option_path)// & - &"/prognostic/spatial_discretisation/discontinuous_galerkin") + ewrite(2,*) "SWE divergence is integrated by parts: ", integrate_by_parts - ewrite(2,*) "SWE divergence is integrated by parts: ", integrate_by_parts + ! note that this is different then compressible, as we don't have + ! a prognostic density equivalent, just treating it as a nonlinear relaxation here + call get_option(trim(velocity%option_path)// & + &"/prognostic/temporal_discretisation/relaxation", theta) + call get_option("/timestepping/timestep", dt) + call get_option("/physical_parameters/gravity/magnitude", g) + ! this is the density in front of the du/dt time-derivative which at the + ! moment is hard-coded to 1.0 + rho0 = 1.0 - ! note that this is different then compressible, as we don't have - ! a prognostic density equivalent, just treating it as a nonlinear relaxation here - call get_option(trim(velocity%option_path)// & - &"/prognostic/temporal_discretisation/relaxation", theta) - call get_option("/timestepping/timestep", dt) - call get_option("/physical_parameters/gravity/magnitude", g) - ! this is the density in front of the du/dt time-derivative which at the - ! moment is hard-coded to 1.0 - rho0 = 1.0 + test_mesh => pressure%mesh + ! the field that ctp_m is multiplied with: + field => velocity - test_mesh => pressure%mesh - ! the field that ctp_m is multiplied with: - field => velocity + if(present(ct_rhs)) call zero(ct_rhs) - if(present(ct_rhs)) call zero(ct_rhs) + ! Clear memory of arrays being designed + call zero(ctp_m) - ! Clear memory of arrays being designed - call zero(ctp_m) + ngi = ele_ngi(test_mesh, 1) + xdim = coordinate%dim + allocate(dtest_t(ele_loc(test_mesh, 1), ngi, xdim), & + dfield_t(ele_loc(field, 1), ngi, xdim), & + dbottom_t(ele_loc(bottom_depth, 1), ngi, xdim), & + ele_mat(field%dim, ele_loc(test_mesh, 1), ele_loc(field, 1)), & + detwei(ngi), & + depth_at_quad(ngi), & + depth_grad_at_quad(xdim, ngi)) - ngi = ele_ngi(test_mesh, 1) - xdim = coordinate%dim - allocate(dtest_t(ele_loc(test_mesh, 1), ngi, xdim), & - dfield_t(ele_loc(field, 1), ngi, xdim), & - dbottom_t(ele_loc(bottom_depth, 1), ngi, xdim), & - ele_mat(field%dim, ele_loc(test_mesh, 1), ele_loc(field, 1)), & - detwei(ngi), & - depth_at_quad(ngi), & - depth_grad_at_quad(xdim, ngi)) + do ele=1, element_count(test_mesh) - do ele=1, element_count(test_mesh) + test_nodes => ele_nodes(test_mesh, ele) + field_nodes => ele_nodes(field, ele) - test_nodes => ele_nodes(test_mesh, ele) - field_nodes => ele_nodes(field, ele) + test_shape => ele_shape(test_mesh, ele) + field_shape => ele_shape(field, ele) + call transform_to_physical(coordinate, ele, test_shape, dshape = dtest_t, detwei=detwei) - test_shape => ele_shape(test_mesh, ele) - field_shape => ele_shape(field, ele) - call transform_to_physical(coordinate, ele, test_shape, dshape = dtest_t, detwei=detwei) + depth_at_quad = (theta*ele_val_at_quad(pressure, ele) + & + (1-theta)*ele_val_at_quad(old_pressure, ele))/(rho0*g) + & + ele_val_at_quad(bottom_depth, ele) - depth_at_quad = (theta*ele_val_at_quad(pressure, ele) + & - (1-theta)*ele_val_at_quad(old_pressure, ele))/(rho0*g) + & - ele_val_at_quad(bottom_depth, ele) + if(integrate_by_parts) then - if(integrate_by_parts) then + ele_mat = -dshape_shape(dtest_t, field_shape, detwei*depth_at_quad) - ele_mat = -dshape_shape(dtest_t, field_shape, detwei*depth_at_quad) + else - else + ! transform the field (velocity) derivatives into physical space + call transform_to_physical(coordinate, ele, field_shape, dshape=dfield_t) + if (bottom_depth%mesh%shape==field_shape) then + dbottom_t = dfield_t + else if (bottom_depth%mesh%shape==test_shape) then + dbottom_t = dtest_t + else + call transform_to_physical(coordinate, ele, ele_shape(bottom_depth, ele), & + dshape=dbottom_t) + end if - ! transform the field (velocity) derivatives into physical space - call transform_to_physical(coordinate, ele, field_shape, dshape=dfield_t) - if (bottom_depth%mesh%shape==field_shape) then - dbottom_t = dfield_t - else if (bottom_depth%mesh%shape==test_shape) then - dbottom_t = dtest_t - else - call transform_to_physical(coordinate, ele, ele_shape(bottom_depth, ele), & - dshape=dbottom_t) - end if + assert( test_shape==pressure%mesh%shape ) + depth_grad_at_quad = (theta*ele_grad_at_quad(pressure, ele, dtest_t) + & + (1-theta)*ele_grad_at_quad(old_pressure, ele, dtest_t))/(rho0*g) + & + ele_grad_at_quad(bottom_depth, ele, dbottom_t) - assert( test_shape==pressure%mesh%shape ) - depth_grad_at_quad = (theta*ele_grad_at_quad(pressure, ele, dtest_t) + & - (1-theta)*ele_grad_at_quad(old_pressure, ele, dtest_t))/(rho0*g) + & - ele_grad_at_quad(bottom_depth, ele, dbottom_t) + ele_mat = shape_dshape(test_shape, dfield_t, detwei*depth_at_quad) + & + shape_shape_vector(test_shape, field_shape, detwei, depth_grad_at_quad) - ele_mat = shape_dshape(test_shape, dfield_t, detwei*depth_at_quad) + & - shape_shape_vector(test_shape, field_shape, detwei, depth_grad_at_quad) + end if - end if + do dim = 1, field%dim + call addto(ctp_m, 1, dim, test_nodes, field_nodes, ele_mat(dim,:,:)) + end do - do dim = 1, field%dim - call addto(ctp_m, 1, dim, test_nodes, field_nodes, ele_mat(dim,:,:)) end do + deallocate(dtest_t, dfield_t, dbottom_t, & + ele_mat, detwei, depth_at_quad, & + depth_grad_at_quad) - end do - deallocate(dtest_t, dfield_t, dbottom_t, & - ele_mat, detwei, depth_at_quad, & - depth_grad_at_quad) - - if(integrate_by_parts) then + if(integrate_by_parts) then - ngi = face_ngi(field,1) - xdim = coordinate%dim - allocate(detwei(ngi), & - depth_at_quad(ngi), & - normal_bdy(xdim, ngi)) - allocate(ele_mat_bdy(field%dim, face_loc(test_mesh, 1), face_loc(field, 1))) + ngi = face_ngi(field,1) + xdim = coordinate%dim + allocate(detwei(ngi), & + depth_at_quad(ngi), & + normal_bdy(xdim, ngi)) + allocate(ele_mat_bdy(field%dim, face_loc(test_mesh, 1), face_loc(field, 1))) - assert(surface_element_count(test_mesh)==surface_element_count(field)) - allocate(field_bc_type(field%dim, surface_element_count(field))) - call get_entire_boundary_condition(field, (/ & - "weakdirichlet ", & - "no_normal_flow", & - "internal "/), & - field_bc, field_bc_type) + assert(surface_element_count(test_mesh)==surface_element_count(field)) + allocate(field_bc_type(field%dim, surface_element_count(field))) + call get_entire_boundary_condition(field, (/ & + "weakdirichlet ", & + "no_normal_flow", & + "internal "/), & + field_bc, field_bc_type) - do sele = 1, surface_element_count(test_mesh) + do sele = 1, surface_element_count(test_mesh) - if(any(field_bc_type(:,sele)==2)& - .or.any(field_bc_type(:,sele)==3)) cycle + if(any(field_bc_type(:,sele)==2)& + .or.any(field_bc_type(:,sele)==3)) cycle - test_shape => face_shape(test_mesh, sele) - field_shape => face_shape(field, sele) + test_shape => face_shape(test_mesh, sele) + field_shape => face_shape(field, sele) - call transform_facet_to_physical(coordinate, sele, & + call transform_facet_to_physical(coordinate, sele, & & detwei_f=detwei, & & normal=normal_bdy) - depth_at_quad = (theta*face_val_at_quad(pressure, sele) + & - (1-theta)*face_val_at_quad(old_pressure, sele))/(rho0*g) + & - face_val_at_quad(bottom_depth, sele) + depth_at_quad = (theta*face_val_at_quad(pressure, sele) + & + (1-theta)*face_val_at_quad(old_pressure, sele))/(rho0*g) + & + face_val_at_quad(bottom_depth, sele) - ele_mat_bdy = shape_shape_vector(test_shape, field_shape, & - detwei*depth_at_quad, normal_bdy) + ele_mat_bdy = shape_shape_vector(test_shape, field_shape, & + detwei*depth_at_quad, normal_bdy) - do dim = 1, field%dim - if((field_bc_type(dim, sele)==1).and.present(ct_rhs)) then - call addto(ct_rhs, face_global_nodes(test_mesh, sele), & - -matmul(ele_mat_bdy(dim,:,:), & - ele_val(field_bc, dim, sele))) - else - call addto(ctp_m, 1, dim, face_global_nodes(test_mesh, sele), & - face_global_nodes(field, sele), ele_mat_bdy(dim,:,:)) - end if - end do + do dim = 1, field%dim + if((field_bc_type(dim, sele)==1).and.present(ct_rhs)) then + call addto(ct_rhs, face_global_nodes(test_mesh, sele), & + -matmul(ele_mat_bdy(dim,:,:), & + ele_val(field_bc, dim, sele))) + else + call addto(ctp_m, 1, dim, face_global_nodes(test_mesh, sele), & + face_global_nodes(field, sele), ele_mat_bdy(dim,:,:)) + end if + end do - end do + end do - call deallocate(field_bc) - deallocate(field_bc_type, depth_at_quad, detwei, ele_mat_bdy) - deallocate(normal_bdy) + call deallocate(field_bc) + deallocate(field_bc_type, depth_at_quad, detwei, ele_mat_bdy) + deallocate(normal_bdy) - end if + end if - end subroutine assemble_swe_divergence_matrix_cg + end subroutine assemble_swe_divergence_matrix_cg - subroutine shallow_water_equations_check_options + subroutine shallow_water_equations_check_options - character(len=*), dimension(1:3), parameter:: forbidden_bc_types = (/ & - "free_surface ", "bulk_formulae", & - "wind_forcing " /) - character(len=OPTION_PATH_LEN):: velocity_option_path, pressure_option_path - real:: beta - integer:: i, dim + character(len=*), dimension(1:3), parameter:: forbidden_bc_types = (/ & + "free_surface ", "bulk_formulae", & + "wind_forcing " /) + character(len=OPTION_PATH_LEN):: velocity_option_path, pressure_option_path + real:: beta + integer:: i, dim - if (.not. have_option("/material_phase/vector_field::Velocity/prognostic/equation::ShallowWater")) return + if (.not. have_option("/material_phase/vector_field::Velocity/prognostic/equation::ShallowWater")) return - ewrite(2,*) "Checking shallow water options" + ewrite(2,*) "Checking shallow water options" - call get_option("/geometry/dimension", dim) - if (dim==3) then - FLExit("With equation type ShallowWater you need a 2D mesh and configuration") - end if - if (have_option("/geometry/spherical_earth")) then - FLExit("Equation type ShallowWater is not implemented for spherical_earth") - end if - if (have_option("/geometry/ocean_boundaries")) then - FLExit("Do not specify /geometry/ocean_boundaries with equation type ShallowWater") - end if - if (.not. have_option("/physical_parameters/gravity")) then - ewrite(0,*) "Missing option /physical_parameters/gravity " // & + call get_option("/geometry/dimension", dim) + if (dim==3) then + FLExit("With equation type ShallowWater you need a 2D mesh and configuration") + end if + if (have_option("/geometry/spherical_earth")) then + FLExit("Equation type ShallowWater is not implemented for spherical_earth") + end if + if (have_option("/geometry/ocean_boundaries")) then + FLExit("Do not specify /geometry/ocean_boundaries with equation type ShallowWater") + end if + if (.not. have_option("/physical_parameters/gravity")) then + ewrite(0,*) "Missing option /physical_parameters/gravity " // & & "(you may ignore /physical_parameters/vector_field::GravityDirection)" - FLExit("With equation type Shallow water you need to specify gravity") - end if - - ! Options under /material_phase - if (option_count("/material_phase")/=1) then - FLExit("Equation type ShallowWater only works with a single material_phase") - end if - - ! These don't make sense - so let's just forbid them to avoid confusion - if (have_option("/material_phase/equation_of_state") .or. & - have_option("/material_phase/scalar_field::Density")) then - FLExit("With equation type ShallowWater you're not allowed an equation_of_state or Density field") - end if - - ! Pressure options - - pressure_option_path = "/material_phase/scalar_field::Pressure/prognostic/" - if (.not. have_option(pressure_option_path)) then - FLExit("With equation type ShallowWater you need a prognostic Pressure field") - end if - - if (have_option(trim(pressure_option_path)//"solver/iterative_method::cg")) then - ewrite(0,*) "For shallow water equations the pressure matrix is asymmetric" - ewrite(0,*) 'Therefore you should not use "cg" as the linear solver' - ewrite(0,*) 'Use "gmres" instead' - FLExit('Cannot use "cg" as linear solver for Pressure with ShallowWater') - end if - - if (.not. have_option(trim(pressure_option_path)// & - "/spatial_discretisation/continuous_galerkin")) then - ! it might also work with dg, but someone should test that - definitely won't work with cv - FLExit('Equation type ShallowWater only work with a continuous galerkin Pressure') - end if - - ! Velocity options - - velocity_option_path = "/material_phase/vector_field::Velocity/prognostic/" - if (.not. have_option(velocity_option_path)) then - FLExit("With equation type ShallowWater you need a prognostic Velocity field") - end if - - call get_option(trim(velocity_option_path)//"/spatial_discretisation/conservative_advection", beta) - if (beta>0.0) then - ewrite(0,*) "The shallow water equations are implemented in non-conservative form" - ewrite(0,*) "To be consistent with that the velocity advection term should be in non-conservative form" - FLExit("Velocity option spatial_discretisation/conservative_advection should be set to 0.0") - end if - - if (have_option(trim(velocity_option_path)//"/vertical_stabilization")) then - FLExit("With equation type ShallowWater you cannot use the option vertical_stabilization") - end if - - ! boundary conditions that don't make sense: - do i=1, size(forbidden_bc_types) - if (have_option(trim(velocity_option_path)//"/boundary_conditions/type::"// & - trim(forbidden_bc_types(i)))) then - FLExit("Can't have "//trim(forbidden_bc_types(i))//" boundary condition with ShallowWater") + FLExit("With equation type Shallow water you need to specify gravity") + end if + + ! Options under /material_phase + if (option_count("/material_phase")/=1) then + FLExit("Equation type ShallowWater only works with a single material_phase") + end if + + ! These don't make sense - so let's just forbid them to avoid confusion + if (have_option("/material_phase/equation_of_state") .or. & + have_option("/material_phase/scalar_field::Density")) then + FLExit("With equation type ShallowWater you're not allowed an equation_of_state or Density field") + end if + + ! Pressure options + + pressure_option_path = "/material_phase/scalar_field::Pressure/prognostic/" + if (.not. have_option(pressure_option_path)) then + FLExit("With equation type ShallowWater you need a prognostic Pressure field") + end if + + if (have_option(trim(pressure_option_path)//"solver/iterative_method::cg")) then + ewrite(0,*) "For shallow water equations the pressure matrix is asymmetric" + ewrite(0,*) 'Therefore you should not use "cg" as the linear solver' + ewrite(0,*) 'Use "gmres" instead' + FLExit('Cannot use "cg" as linear solver for Pressure with ShallowWater') + end if + + if (.not. have_option(trim(pressure_option_path)// & + "/spatial_discretisation/continuous_galerkin")) then + ! it might also work with dg, but someone should test that - definitely won't work with cv + FLExit('Equation type ShallowWater only work with a continuous galerkin Pressure') + end if + + ! Velocity options + + velocity_option_path = "/material_phase/vector_field::Velocity/prognostic/" + if (.not. have_option(velocity_option_path)) then + FLExit("With equation type ShallowWater you need a prognostic Velocity field") end if - end do + + call get_option(trim(velocity_option_path)//"/spatial_discretisation/conservative_advection", beta) + if (beta>0.0) then + ewrite(0,*) "The shallow water equations are implemented in non-conservative form" + ewrite(0,*) "To be consistent with that the velocity advection term should be in non-conservative form" + FLExit("Velocity option spatial_discretisation/conservative_advection should be set to 0.0") + end if + + if (have_option(trim(velocity_option_path)//"/vertical_stabilization")) then + FLExit("With equation type ShallowWater you cannot use the option vertical_stabilization") + end if + + ! boundary conditions that don't make sense: + do i=1, size(forbidden_bc_types) + if (have_option(trim(velocity_option_path)//"/boundary_conditions/type::"// & + trim(forbidden_bc_types(i)))) then + FLExit("Can't have "//trim(forbidden_bc_types(i))//" boundary condition with ShallowWater") + end if + end do - end subroutine shallow_water_equations_check_options + end subroutine shallow_water_equations_check_options end module shallow_water_equations diff --git a/assemble/Slope_limiters_DG.F90 b/assemble/Slope_limiters_DG.F90 index 485770eac1..5c89c65017 100644 --- a/assemble/Slope_limiters_DG.F90 +++ b/assemble/Slope_limiters_DG.F90 @@ -27,1650 +27,1650 @@ #include "fdebug.h" module slope_limiters_dg -use fldebug -use ieee_arithmetic -use spud -use vector_tools, only: solve -use elements -use eventcounter -use sparse_tools -use transform_elements -use fields -use state_module -use field_options, only: find_linear_parent_mesh -use vtk_interfaces -use state_fields_module -use bound_field_module -implicit none - -private -public limit_slope_dg, limit_fpn, limit_vb - -integer, parameter :: LIMITER_MINIMAL=1 -integer, parameter :: LIMITER_COCKBURN=2 -integer, parameter :: LIMITER_HERMITE_WENO=3 -integer, parameter :: LIMITER_FPN=4 -integer, parameter :: LIMITER_VB=5 - -public :: LIMITER_MINIMAL, LIMITER_COCKBURN, LIMITER_HERMITE_WENO,& - & LIMITER_FPN, LIMITER_VB + use fldebug + use ieee_arithmetic + use spud + use vector_tools, only: solve + use elements + use eventcounter + use sparse_tools + use transform_elements + use fields + use state_module + use field_options, only: find_linear_parent_mesh + use vtk_interfaces + use state_fields_module + use bound_field_module + implicit none + + private + public limit_slope_dg, limit_fpn, limit_vb + + integer, parameter :: LIMITER_MINIMAL=1 + integer, parameter :: LIMITER_COCKBURN=2 + integer, parameter :: LIMITER_HERMITE_WENO=3 + integer, parameter :: LIMITER_FPN=4 + integer, parameter :: LIMITER_VB=5 + + public :: LIMITER_MINIMAL, LIMITER_COCKBURN, LIMITER_HERMITE_WENO,& + & LIMITER_FPN, LIMITER_VB !!CockburnShuLimiter stuff -real :: TVB_factor=5.0 -real :: Limit_factor=1.1 -real, dimension(:,:,:), pointer :: alpha => null() -real, dimension(:,:), pointer :: dx2 => null(), A => null() -integer :: CSL_adapt_counter = -666 -logical :: CSL_initialised = .false. -logical :: tolerate_negative_weights + real :: TVB_factor=5.0 + real :: Limit_factor=1.1 + real, dimension(:,:,:), pointer :: alpha => null() + real, dimension(:,:), pointer :: dx2 => null(), A => null() + integer :: CSL_adapt_counter = -666 + logical :: CSL_initialised = .false. + logical :: tolerate_negative_weights !!Hermite Weno limiter stuff -real :: gam0 !power coefficient in weights -real :: eps_o !relative/absolute tolerance threshold for oscillation indicator -real :: eps_w !relative/absolute tolerance threshold for WENO weights -real :: disc_tol !Value for discontinuity test -real :: limit_tol !Do not limit if infinity norm of tracer is less than + real :: gam0 !power coefficient in weights + real :: eps_o !relative/absolute tolerance threshold for oscillation indicator + real :: eps_w !relative/absolute tolerance threshold for WENO weights + real :: disc_tol !Value for discontinuity test + real :: limit_tol !Do not limit if infinity norm of tracer is less than !this value on an element -logical :: debugging !Switch to bung out lots of debugging output -integer, parameter :: IGNORE_MISSING_POLYS=1 -integer, parameter :: REPLACE_MISSING_POLYS=2 -integer, parameter :: LOWER_ORDER=3 -integer :: missing_polys -logical :: leave_out_hermite_polynomials -logical :: has_discontinuity_detector_field -type(scalar_field), pointer :: discontinuity_detector_field -integer :: limit_count + logical :: debugging !Switch to bung out lots of debugging output + integer, parameter :: IGNORE_MISSING_POLYS=1 + integer, parameter :: REPLACE_MISSING_POLYS=2 + integer, parameter :: LOWER_ORDER=3 + integer :: missing_polys + logical :: leave_out_hermite_polynomials + logical :: has_discontinuity_detector_field + type(scalar_field), pointer :: discontinuity_detector_field + integer :: limit_count contains - subroutine limit_slope_dg(T, U, X, state, limiter) - !! Assume 1D linear elements - type(scalar_field), intent(inout) :: T - type(vector_field), intent(in) :: X, U - type(state_type), intent(inout) :: state - integer, intent(in) :: limiter - - integer :: ele, stat - type(scalar_field) :: T_limit - - !assert(mesh_dim(coordinate)==1) - !assert(field%mesh%continuity<0) - !assert(field%mesh%shape%degree==1) - - ewrite(2,*) 'subroutiune limit_slope_dg' - - select case (limiter) - case (LIMITER_MINIMAL) - T_limit=extract_scalar_field(state, trim(T%name)//"Limiter", stat=stat) - - do ele=1,element_count(T) - - if (stat==0) then - call limit_slope_ele_dg(ele, T, X, T_limit) - else - call limit_slope_ele_dg(ele, T, X) - end if - - end do - - case (LIMITER_COCKBURN) - - call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Cockburn_Shu/TVB_factor", & - &TVB_factor) - call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Cockburn_Shu/limit_factor", & - &limit_factor) - - tolerate_negative_weights = & - &have_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Cockburn_Shu/tolerate_negative_weights") - - call cockburn_shu_setup(T, X) - - do ele=1,element_count(T) - - call limit_slope_ele_cockburn_shu(ele, T, X) - - end do - - case (LIMITER_HERMITE_WENO) - - call get_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/power_coeffi& - &cient", & - & gam0) - call get_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/tolerance_th& - &reshold_oscillations", & - &eps_o) - call get_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/tolerance_th& - &reshold_weights", & - &eps_w) - call get_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/discontinuit& - &y_tolerance",disc_tol) - call get_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/limit_tolera& - &nce",limit_tol) - debugging = have_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/debugging") - missing_polys = IGNORE_MISSING_POLYS - if(have_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/& - &boundary_treatment::ignore_missing_polys"))& - & missing_polys = IGNORE_MISSING_POLYS - if(have_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/& - &boundary_treatment::replace_missing_polys"))& - & missing_polys = REPLACE_MISSING_POLYS - if(have_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/& - &boundary_treatment::lower_order")) then - missing_polys = LOWER_ORDER - end if - - leave_out_hermite_polynomials = .false. - if(have_option(trim(T%option_path)//"/prognostic/& - &spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Hermite_Weno/& - &leave_out_hermite_polynomials")) & - & leave_out_hermite_polynomials = .true. - - call allocate(T_limit, T%mesh, name="NewT") - T_limit%val = T%val - - limit_count = 0.0 - - has_discontinuity_detector_field = has_scalar_field( & + subroutine limit_slope_dg(T, U, X, state, limiter) + !! Assume 1D linear elements + type(scalar_field), intent(inout) :: T + type(vector_field), intent(in) :: X, U + type(state_type), intent(inout) :: state + integer, intent(in) :: limiter + + integer :: ele, stat + type(scalar_field) :: T_limit + + !assert(mesh_dim(coordinate)==1) + !assert(field%mesh%continuity<0) + !assert(field%mesh%shape%degree==1) + + ewrite(2,*) 'subroutiune limit_slope_dg' + + select case (limiter) + case (LIMITER_MINIMAL) + T_limit=extract_scalar_field(state, trim(T%name)//"Limiter", stat=stat) + + do ele=1,element_count(T) + + if (stat==0) then + call limit_slope_ele_dg(ele, T, X, T_limit) + else + call limit_slope_ele_dg(ele, T, X) + end if + + end do + + case (LIMITER_COCKBURN) + + call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Cockburn_Shu/TVB_factor", & + &TVB_factor) + call get_option(trim(T%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Cockburn_Shu/limit_factor", & + &limit_factor) + + tolerate_negative_weights = & + &have_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Cockburn_Shu/tolerate_negative_weights") + + call cockburn_shu_setup(T, X) + + do ele=1,element_count(T) + + call limit_slope_ele_cockburn_shu(ele, T, X) + + end do + + case (LIMITER_HERMITE_WENO) + + call get_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/power_coeffi& + &cient", & + & gam0) + call get_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/tolerance_th& + &reshold_oscillations", & + &eps_o) + call get_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/tolerance_th& + &reshold_weights", & + &eps_w) + call get_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/discontinuit& + &y_tolerance",disc_tol) + call get_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/limit_tolera& + &nce",limit_tol) + debugging = have_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/debugging") + missing_polys = IGNORE_MISSING_POLYS + if(have_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/& + &boundary_treatment::ignore_missing_polys"))& + & missing_polys = IGNORE_MISSING_POLYS + if(have_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/& + &boundary_treatment::replace_missing_polys"))& + & missing_polys = REPLACE_MISSING_POLYS + if(have_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/& + &boundary_treatment::lower_order")) then + missing_polys = LOWER_ORDER + end if + + leave_out_hermite_polynomials = .false. + if(have_option(trim(T%option_path)//"/prognostic/& + &spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Hermite_Weno/& + &leave_out_hermite_polynomials")) & + & leave_out_hermite_polynomials = .true. + + call allocate(T_limit, T%mesh, name="NewT") + T_limit%val = T%val + + limit_count = 0.0 + + has_discontinuity_detector_field = has_scalar_field( & state, "DiscontinuityDetector") - if(has_discontinuity_detector_field) then - discontinuity_detector_field & + if(has_discontinuity_detector_field) then + discontinuity_detector_field & => extract_scalar_field(state, "DiscontinuityDetector") - discontinuity_detector_field%val = 0.0 - end if + discontinuity_detector_field%val = 0.0 + end if + + do ele = 1, element_count(T) - do ele = 1, element_count(T) + call limit_slope_ele_hermite_weno(ele, T, T_limit, X, U) - call limit_slope_ele_hermite_weno(ele, T, T_limit, X, U) + end do - end do + ewrite(3,*) 'Limit count = ',limit_count - ewrite(3,*) 'Limit count = ',limit_count + T%val = T_limit%val + call deallocate(T_limit) - T%val = T_limit%val - call deallocate(T_limit) + case (LIMITER_VB) + call limit_VB(state, T) - case (LIMITER_VB) - call limit_VB(state, T) + case (LIMITER_FPN) + call limit_fpn(state, T) - case (LIMITER_FPN) - call limit_fpn(state, T) + case default + ewrite(-1,*) 'limiter = ', limiter + FLAbort('no such limiter exists') + end select - case default - ewrite(-1,*) 'limiter = ', limiter - FLAbort('no such limiter exists') - end select + ewrite(2,*) 'END subroutiune limit_slope_dg' - ewrite(2,*) 'END subroutiune limit_slope_dg' + end subroutine limit_slope_dg - end subroutine limit_slope_dg + subroutine limit_slope_ele_dg(ele, T, X, T_limit) - subroutine limit_slope_ele_dg(ele, T, X, T_limit) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: T + type(vector_field), intent(in) :: X + type(scalar_field), intent(inout), optional :: T_limit + integer, dimension(:), pointer :: neigh, T_ele + real, dimension(X%dim) :: ele_centre + real :: ele_mean, miss_val + integer :: ele_2, ni, face, face2, d, i, j, jj, miss + real, dimension(X%dim, ele_loc(X,ele)) :: X_val, X_val_2 + real, dimension(ele_loc(T,ele)) :: T_val, T_val_2 + real, dimension(X%dim, ele_face_count(T,ele)) :: neigh_centre, face_centre + real, dimension(ele_face_count(T,ele)) :: neigh_mean, face_mean + real, dimension(mesh_dim(T)+1) :: b, new_val + logical :: limit - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: T - type(vector_field), intent(in) :: X - type(scalar_field), intent(inout), optional :: T_limit - integer, dimension(:), pointer :: neigh, T_ele - real, dimension(X%dim) :: ele_centre - real :: ele_mean, miss_val - integer :: ele_2, ni, face, face2, d, i, j, jj, miss - real, dimension(X%dim, ele_loc(X,ele)) :: X_val, X_val_2 - real, dimension(ele_loc(T,ele)) :: T_val, T_val_2 - real, dimension(X%dim, ele_face_count(T,ele)) :: neigh_centre, face_centre - real, dimension(ele_face_count(T,ele)) :: neigh_mean, face_mean - real, dimension(mesh_dim(T)+1) :: b, new_val - logical :: limit + X_val=ele_val(X, ele) + T_val=ele_val(T, ele) - X_val=ele_val(X, ele) - T_val=ele_val(T, ele) + ele_centre=sum(X_val,2)/size(X_val,2) - ele_centre=sum(X_val,2)/size(X_val,2) + ele_mean=sum(T_val)/size(T_val) - ele_mean=sum(T_val)/size(T_val) + neigh=>ele_neigh(T, ele) - neigh=>ele_neigh(T, ele) + limit=.false. - limit=.false. + searchloop: do ni=1,size(neigh) - searchloop: do ni=1,size(neigh) + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- + ! These finding routines are outside the inner loop so as to allow + ! for local stack variables of the right size in + ! construct_add_diff_interface_dg. - ! These finding routines are outside the inner loop so as to allow - ! for local stack variables of the right size in - ! construct_add_diff_interface_dg. + ele_2=neigh(ni) - ele_2=neigh(ni) + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(T, ele, ele_2) + face2=ele_face(T, ele_2, ele) - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(T, ele, ele_2) - face2=ele_face(T, ele_2, ele) + face_centre(:,ni) = sum(face_val(X,face),2)/size(face_val(X,face),2) - face_centre(:,ni) = sum(face_val(X,face),2)/size(face_val(X,face),2) + face_mean(ni) = sum(face_val(T,face))/size(face_val(T,face)) - face_mean(ni) = sum(face_val(T,face))/size(face_val(T,face)) + if (ele_2<=0) then + ! External face. + cycle + end if - if (ele_2<=0) then - ! External face. - cycle - end if + X_val_2=ele_val(X, ele_2) + T_val_2=ele_val(T, ele_2) - X_val_2=ele_val(X, ele_2) - T_val_2=ele_val(T, ele_2) + neigh_centre(:,ni)=sum(X_val_2,2)/size(X_val_2,2) - neigh_centre(:,ni)=sum(X_val_2,2)/size(X_val_2,2) + neigh_mean(ni)=sum(T_val_2)/size(T_val_2) - neigh_mean(ni)=sum(T_val_2)/size(T_val_2) + if ((face_mean(ni)-ele_mean)*(face_mean(ni)-neigh_mean(ni))>0.0) then + ! Limit if face_mean does not lie between ele_mean and neigh_mean + limit=.true. - if ((face_mean(ni)-ele_mean)*(face_mean(ni)-neigh_mean(ni))>0.0) then - ! Limit if face_mean does not lie between ele_mean and neigh_mean - limit=.true. + if (face_mean(ni)>ele_mean) then + face_mean(ni) = max(ele_mean, neigh_mean(ni)) + else + face_mean(ni) = min(ele_mean, neigh_mean(ni)) + end if - if (face_mean(ni)>ele_mean) then - face_mean(ni) = max(ele_mean, neigh_mean(ni)) - else - face_mean(ni) = min(ele_mean, neigh_mean(ni)) - end if + end if - end if + end do searchloop - end do searchloop + if (present(T_limit)) then + T_ele=>ele_nodes(T_limit,ele) + call set(T_limit, T_ele, ele_mean+0.0*T_ele) + end if - if (present(T_limit)) then - T_ele=>ele_nodes(T_limit,ele) - call set(T_limit, T_ele, ele_mean+0.0*T_ele) - end if + if (.not.limit) then + return + end if - if (.not.limit) then - return - end if + d=mesh_dim(T) + new_val=ele_mean - d=mesh_dim(T) - new_val=ele_mean + do miss=1,d+1 - do miss=1,d+1 + ! If the missed side is a boundary, it is not possible to limit in + ! this direction without violating the boundary condition. + if (neigh(miss)<=0) cycle - ! If the missed side is a boundary, it is not possible to limit in - ! this direction without violating the boundary condition. - if (neigh(miss)<=0) cycle + A=0.0 + b(1)=ele_mean - A=0.0 - b(1)=ele_mean + do i=1, d+1 + ! Enforce preservation of the element mean value. + A(1,i)=1.0/(d+1) - do i=1, d+1 - ! Enforce preservation of the element mean value. - A(1,i)=1.0/(d+1) + jj=1 + do j=1,d+1 + if (j==miss) cycle + jj=jj+1 - jj=1 - do j=1,d+1 - if (j==miss) cycle - jj=jj+1 + if (i/=j) then + A(jj,i)=1.0/d + else + b(jj)=face_mean(j) + end if - if (i/=j) then - A(jj,i)=1.0/d - else - b(jj)=face_mean(j) - end if + end do - end do + end do - end do + call invert(A) + b=matmul(A,b) - call invert(A) - b=matmul(A,b) + if (maxval(abs(b-ele_mean))>maxval(abs(new_val-ele_mean))) then + !! The slope is larger than the current best guess. - if (maxval(abs(b-ele_mean))>maxval(abs(new_val-ele_mean))) then - !! The slope is larger than the current best guess. + miss_val=0.0 + do ni=1, d+1 + if (ni==miss) cycle - miss_val=0.0 - do ni=1, d+1 - if (ni==miss) cycle + miss_val=miss_val+b(ni)/d + end do - miss_val=miss_val+b(ni)/d - end do + if ((miss_val-ele_mean)*(miss_val-neigh_mean(miss))<=0.0) then + ! The slope is legal. - if ((miss_val-ele_mean)*(miss_val-neigh_mean(miss))<=0.0) then - ! The slope is legal. + new_val=b - new_val=b + end if - end if + end if - end if + end do - end do + ! Success or non-boundary failure. + T_ele=>ele_nodes(T,ele) - ! Success or non-boundary failure. - T_ele=>ele_nodes(T,ele) + call set(T, T_ele, new_val) - call set(T, T_ele, new_val) + if (present(T_limit)) then + T_ele=>ele_nodes(T_limit, ele) - if (present(T_limit)) then - T_ele=>ele_nodes(T_limit, ele) + if (all(new_val==ele_mean)) then + call set(T_limit, T_ele, 1.0+T_ele*0.0) + else + call set(T_limit, T_ele, -1.0+0.0*T_ele) + end if - if (all(new_val==ele_mean)) then - call set(T_limit, T_ele, 1.0+T_ele*0.0) - else - call set(T_limit, T_ele, -1.0+0.0*T_ele) - end if + end if + + end subroutine limit_slope_ele_dg + + subroutine cockburn_shu_setup(T,X) + type(scalar_field), intent(inout) :: T + type(vector_field), intent(in) :: X + ! + logical :: do_setup + integer :: cnt, d, i, j, ele + + do_setup = .false. + if(.not.CSL_initialised) then + CALL GetEventCounter(EVENT_ADAPTIVITY, csl_adapt_counter) + do_setup = .true. + CSL_initialised = .true. + else + CALL GetEventCounter(EVENT_ADAPTIVITY, CNT) + if(cnt.ne.csl_adapt_counter) then + do_setup= .true. + csl_adapt_counter = cnt + end if + end if - end if + if(do_setup) then - end subroutine limit_slope_ele_dg + if(associated(alpha)) then + deallocate(alpha) + alpha => null() + end if + if(associated(dx2)) then + deallocate(dx2) + dx2 => null() + end if + if(associated(A)) then + deallocate(A) + A => null() + end if + !!ATTENTION: This assumes that all elements have the same number of faces + allocate(alpha(element_count(T),ele_face_count(T,1)& + &,ele_face_count(T,1))) + allocate(dx2(element_count(T),ele_face_count(T,1))) + + d=mesh_dim(T) + allocate(A(d+1,d+1)) + + ! Initialise A with the change from face centre values to node values. + do i=1, size(A,1) + do j=1,size(A,2) + if (i==j) then + A(i,j)=0.0 + else + A(i,j)=1.0/d + end if + end do + end do + + call invert(A) + + do ele = 1, element_count(T) + call cockburn_shu_setup_ele(ele,T,X) + end do + + end if + + end subroutine cockburn_shu_setup + + subroutine cockburn_shu_setup_ele(ele, T, X) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: T + type(vector_field), intent(in) :: X + + integer, dimension(:), pointer :: neigh, x_neigh + real, dimension(X%dim) :: ele_centre, face_2_centre + real :: max_alpha, min_alpha, neg_alpha + integer :: ele_2, ni, nj, face, face_2, i, nk, ni_skip, info, nl + real, dimension(X%dim, ele_loc(X,ele)) :: X_val, X_val_2 + real, dimension(X%dim, ele_face_count(T,ele)) :: neigh_centre,& + & face_centre + real, dimension(X%dim) :: alpha1, alpha2 + real, dimension(X%dim,X%dim) :: alphamat + real, dimension(X%dim,X%dim+1) :: dx_f, dx_c + integer, dimension(mesh_dim(T)) :: face_nodes + + X_val=ele_val(X, ele) + + ele_centre=sum(X_val,2)/size(X_val,2) + + neigh=>ele_neigh(T, ele) + ! x_neigh/=t_neigh only on periodic boundaries. + x_neigh=>ele_neigh(X, ele) + + searchloop: do ni=1,size(neigh) + + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- + ele_2=neigh(ni) + + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(T, ele, ele_2) + face_nodes=face_local_nodes(T, face) + + face_centre(:,ni) = sum(X_val(:,face_nodes),2)/size(face_nodes) + + if (ele_2<=0) then + ! External face. + neigh_centre(:,ni)=face_centre(:,ni) + cycle + end if - subroutine cockburn_shu_setup(T,X) - type(scalar_field), intent(inout) :: T - type(vector_field), intent(in) :: X - ! - logical :: do_setup - integer :: cnt, d, i, j, ele - - do_setup = .false. - if(.not.CSL_initialised) then - CALL GetEventCounter(EVENT_ADAPTIVITY, csl_adapt_counter) - do_setup = .true. - CSL_initialised = .true. - else - CALL GetEventCounter(EVENT_ADAPTIVITY, CNT) - if(cnt.ne.csl_adapt_counter) then - do_setup= .true. - csl_adapt_counter = cnt - end if - end if - - if(do_setup) then - - if(associated(alpha)) then - deallocate(alpha) - alpha => null() - end if - if(associated(dx2)) then - deallocate(dx2) - dx2 => null() - end if - if(associated(A)) then - deallocate(A) - A => null() - end if - !!ATTENTION: This assumes that all elements have the same number of faces - allocate(alpha(element_count(T),ele_face_count(T,1)& - &,ele_face_count(T,1))) - allocate(dx2(element_count(T),ele_face_count(T,1))) - - d=mesh_dim(T) - allocate(A(d+1,d+1)) - - ! Initialise A with the change from face centre values to node values. - do i=1, size(A,1) - do j=1,size(A,2) - if (i==j) then - A(i,j)=0.0 - else - A(i,j)=1.0/d - end if - end do - end do - - call invert(A) - - do ele = 1, element_count(T) - call cockburn_shu_setup_ele(ele,T,X) - end do - - end if - - end subroutine cockburn_shu_setup - - subroutine cockburn_shu_setup_ele(ele, T, X) - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: T - type(vector_field), intent(in) :: X - - integer, dimension(:), pointer :: neigh, x_neigh - real, dimension(X%dim) :: ele_centre, face_2_centre - real :: max_alpha, min_alpha, neg_alpha - integer :: ele_2, ni, nj, face, face_2, i, nk, ni_skip, info, nl - real, dimension(X%dim, ele_loc(X,ele)) :: X_val, X_val_2 - real, dimension(X%dim, ele_face_count(T,ele)) :: neigh_centre,& - & face_centre - real, dimension(X%dim) :: alpha1, alpha2 - real, dimension(X%dim,X%dim) :: alphamat - real, dimension(X%dim,X%dim+1) :: dx_f, dx_c - integer, dimension(mesh_dim(T)) :: face_nodes - - X_val=ele_val(X, ele) - - ele_centre=sum(X_val,2)/size(X_val,2) - - neigh=>ele_neigh(T, ele) - ! x_neigh/=t_neigh only on periodic boundaries. - x_neigh=>ele_neigh(X, ele) - - searchloop: do ni=1,size(neigh) - - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- - ele_2=neigh(ni) - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(T, ele, ele_2) - face_nodes=face_local_nodes(T, face) - - face_centre(:,ni) = sum(X_val(:,face_nodes),2)/size(face_nodes) - - if (ele_2<=0) then - ! External face. - neigh_centre(:,ni)=face_centre(:,ni) - cycle - end if - - X_val_2=ele_val(X, ele_2) - - neigh_centre(:,ni)=sum(X_val_2,2)/size(X_val_2,2) - if (ele_2/=x_neigh(ni)) then - ! Periodic boundary case. We have to cook up the coordinate by - ! adding vectors to the face from each side. - face_2=ele_face(T, ele_2, ele) - face_2_centre = & + X_val_2=ele_val(X, ele_2) + + neigh_centre(:,ni)=sum(X_val_2,2)/size(X_val_2,2) + if (ele_2/=x_neigh(ni)) then + ! Periodic boundary case. We have to cook up the coordinate by + ! adding vectors to the face from each side. + face_2=ele_face(T, ele_2, ele) + face_2_centre = & sum(face_val(X,face_2),2)/size(face_val(X,face_2),2) - neigh_centre(:,ni)=face_centre(:,ni) + & + neigh_centre(:,ni)=face_centre(:,ni) + & (neigh_centre(:,ni) - face_2_centre) - end if - - end do searchloop - - do ni = 1, size(neigh) - dx_c(:,ni)=neigh_centre(:,ni)-ele_centre !Vectors from ni centres to - ! !ele centre - dx_f(:,ni)=face_centre(:,ni)-ele_centre !Vectors from ni face centres - !to ele centre - end do - - alpha_construction_loop: do ni = 1, size(neigh) - !Loop for constructing Delta v(m_i,K_0) as described in C&S - alphamat(:,1) = dx_c(:,ni) - - max_alpha = -1.0 - ni_skip = 0 - - choosing_best_other_face_loop: do nj = 1, size(neigh) - !Loop over the other faces to choose best one to use - !for linear basis across face - - if(nj==ni) cycle - - !Construct a linear basis using all faces except for nj - nl = 1 - do nk = 1, size(neigh) - if(nk==nj.or.nk==ni) cycle - nl = nl + 1 - alphamat(:,nl) = dx_c(:,nk) - end do - - !Solve for basis coefficients alpha - alpha2 = dx_f(:,ni) - call solve(alphamat,alpha2,info) - - if((.not.any(alpha2<0.0)).and.alpha2(1)/norm2(alpha2)>max_alpha) & - & then - alpha1 = alpha2 - ni_skip = nj - max_alpha = alpha2(1)/norm2(alpha2) - end if - - end do choosing_best_other_face_loop - - if(max_alpha<0.0) then - if(tolerate_negative_weights) then - min_alpha = huge(0.0) - ni_skip = 0 - choosing_best_other_face_neg_weights_loop: do nj = 1, size(neigh) - !Loop over the other faces to choose best one to use - !for linear basis across face - - if(nj==ni) cycle - - !Construct a linear basis using all faces except for nj - nl = 1 - do nk = 1, size(neigh) - if(nk==nj.or.nk==ni) cycle - nl = nl + 1 - alphamat(:,nl) = dx_c(:,nk) - end do - - !Solve for basis coefficients alpha - alpha2 = dx_f(:,ni) - call solve(alphamat,alpha2,info) - - neg_alpha = 0.0 - do i = 1, size(alpha2) - if(alpha2(i)<0.0) then - neg_alpha = neg_alpha + alpha2(i)**2 - end if - end do - neg_alpha = sqrt(neg_alpha) - - if(min_alpha>neg_alpha) then - alpha1 = alpha2 - ni_skip = nj - min_alpha = neg_alpha - end if - end do choosing_best_other_face_neg_weights_loop - else - FLAbort('solving for alpha failed') - end if - end if - - alpha(ele,ni,:) = 0.0 - alpha(ele,ni,ni) = alpha1(1) - nl = 1 - do nj = 1, size(neigh) - if(nj==ni.or.nj==ni_skip) cycle - nl = nl + 1 - alpha(ele,ni,nj) = alpha1(nl) - end do - - dx2(ele,ni) = norm2(dx_c(:,ni)) - - end do alpha_construction_loop - - end subroutine cockburn_shu_setup_ele - - subroutine limit_slope_ele_cockburn_shu(ele, T, X) - !!< Slope limiter according to Cockburn and Shu (2001) - !!< http://dx.doi.org/10.1023/A:1012873910884 - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: T - type(vector_field), intent(in) :: X - - integer, dimension(:), pointer :: neigh, x_neigh, T_ele - real :: ele_mean - real :: pos, neg - integer :: ele_2, ni, face - real, dimension(ele_loc(T,ele)) :: T_val, T_val_2 - real, dimension(ele_face_count(T,ele)) :: neigh_mean, face_mean - real, dimension(mesh_dim(T)+1) :: delta_v - real, dimension(mesh_dim(T)+1) :: Delta, new_val - integer, dimension(mesh_dim(T)) :: face_nodes - - T_val=ele_val(T, ele) - - ele_mean=sum(T_val)/size(T_val) - - neigh=>ele_neigh(T, ele) - ! x_neigh/=t_neigh only on periodic boundaries. - x_neigh=>ele_neigh(X, ele) - - searchloop: do ni=1,size(neigh) - - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- - ele_2=neigh(ni) - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(T, ele, ele_2) - face_nodes=face_local_nodes(T, face) - - face_mean(ni) = sum(T_val(face_nodes))/size(face_nodes) - - if (ele_2<=0) then - ! External face. - neigh_mean(ni)=face_mean(ni) - cycle - end if - - T_val_2=ele_val(T, ele_2) - - neigh_mean(ni)=sum(T_val_2)/size(T_val_2) - - end do searchloop - - delta_v = matmul(alpha(ele,:,:),neigh_mean-ele_mean) - - delta_loop: do ni=1,size(neigh) - - Delta(ni)=TVB_minmod(face_mean(ni)-ele_mean, & - Limit_factor*delta_v(ni), dx2(ele,ni)) + end if - end do delta_loop + end do searchloop - if (abs(sum(Delta))>1000.0*epsilon(0.0)) then - ! Coefficients do not sum to 0.0 + do ni = 1, size(neigh) + dx_c(:,ni)=neigh_centre(:,ni)-ele_centre !Vectors from ni centres to + ! !ele centre + dx_f(:,ni)=face_centre(:,ni)-ele_centre !Vectors from ni face centres + !to ele centre + end do - pos=sum(max(0.0, Delta)) - neg=sum(max(0.0, -Delta)) + alpha_construction_loop: do ni = 1, size(neigh) + !Loop for constructing Delta v(m_i,K_0) as described in C&S + alphamat(:,1) = dx_c(:,ni) + + max_alpha = -1.0 + ni_skip = 0 + + choosing_best_other_face_loop: do nj = 1, size(neigh) + !Loop over the other faces to choose best one to use + !for linear basis across face + + if(nj==ni) cycle + + !Construct a linear basis using all faces except for nj + nl = 1 + do nk = 1, size(neigh) + if(nk==nj.or.nk==ni) cycle + nl = nl + 1 + alphamat(:,nl) = dx_c(:,nk) + end do + + !Solve for basis coefficients alpha + alpha2 = dx_f(:,ni) + call solve(alphamat,alpha2,info) + + if((.not.any(alpha2<0.0)).and.alpha2(1)/norm2(alpha2)>max_alpha) & + & then + alpha1 = alpha2 + ni_skip = nj + max_alpha = alpha2(1)/norm2(alpha2) + end if + + end do choosing_best_other_face_loop + + if(max_alpha<0.0) then + if(tolerate_negative_weights) then + min_alpha = huge(0.0) + ni_skip = 0 + choosing_best_other_face_neg_weights_loop: do nj = 1, size(neigh) + !Loop over the other faces to choose best one to use + !for linear basis across face + + if(nj==ni) cycle + + !Construct a linear basis using all faces except for nj + nl = 1 + do nk = 1, size(neigh) + if(nk==nj.or.nk==ni) cycle + nl = nl + 1 + alphamat(:,nl) = dx_c(:,nk) + end do + + !Solve for basis coefficients alpha + alpha2 = dx_f(:,ni) + call solve(alphamat,alpha2,info) + + neg_alpha = 0.0 + do i = 1, size(alpha2) + if(alpha2(i)<0.0) then + neg_alpha = neg_alpha + alpha2(i)**2 + end if + end do + neg_alpha = sqrt(neg_alpha) + + if(min_alpha>neg_alpha) then + alpha1 = alpha2 + ni_skip = nj + min_alpha = neg_alpha + end if + end do choosing_best_other_face_neg_weights_loop + else + FLAbort('solving for alpha failed') + end if + end if - Delta = min(1.0,neg/pos)*max(0.0,Delta) & - -min(1.0,pos/neg)*max(0.0,-Delta) + alpha(ele,ni,:) = 0.0 + alpha(ele,ni,ni) = alpha1(1) + nl = 1 + do nj = 1, size(neigh) + if(nj==ni.or.nj==ni_skip) cycle + nl = nl + 1 + alpha(ele,ni,nj) = alpha1(nl) + end do - end if - - new_val=matmul(A,Delta+ele_mean) - - ! Success or non-boundary failure. - T_ele=>ele_nodes(T,ele) - - call set(T, T_ele, new_val) - - end subroutine limit_slope_ele_cockburn_shu - - !11:25 do ele_A=1,ele_count(old_position) - !11:25 call local_coords_matrix(old_position, ele_A, - ! inversion_matrices_A(:, :, ele_A)) - !11:25 end do - - !subroutine local_coords_matrix(positions, ele, mat) - !inputs global coordinates - !outputs local coordinates - - subroutine limit_slope_ele_hermite_weno(ele, T, T_limit, X, U) - !!< Hermite Weno Slope limiter - integer, intent(in) :: ele - type(scalar_field), intent(in) :: T - type(scalar_field), intent(inout) :: T_limit - type(vector_field), intent(in) :: X, U - - integer, dimension(:), pointer :: neigh, x_neigh, T_ele - real :: ele_mean, ele_mean_2 - real, dimension(ele_face_count(T,ele)) :: ele_means - real :: residual - integer :: ele_2, ni, nj, face, face_2,i, nk, info, nl - integer :: l_face, l_face_2 - real, dimension(ele_loc(T,ele)) :: T_val, T_val_2 - real, dimension(face_loc(T,1)) :: T_val_face - real, dimension(face_ngi(T,1)) :: T_face_quad - real, dimension(ele_face_count(T,ele),ele_loc(X,ele)) :: T_vals - real, dimension(ele_face_count(T,ele),X%dim, ele_loc(X,ele)) :: X_vals - real, dimension(X%dim, ele_loc(X,ele)) :: X_val - real, dimension(ele_face_count(T,ele)) :: neigh_mean, face_mean - real, dimension(ele_loc(T,ele)) :: new_val - integer, dimension(mesh_dim(T)) :: face_nodes - logical :: limit_slope - real, dimension(ele_loc(T, ele), ele_ngi(T, ele), & - &mesh_dim(T)) :: du_t - real, dimension(ele_ngi(T,ele)) :: detwei - real, dimension(ele_ngi(T,ele)) :: p_quad, T_quad - real, dimension(1+2*ele_loc(T,ele),ele_loc(T,ele)) :: Polys - real, dimension(ele_loc(T,ele)*2+1) :: Polys_o, Polys_w - real, dimension(mesh_dim(T),ele_ngi(T,ele)) :: dp_quad - logical, dimension(ele_face_count(T,ele)) :: boundaries - logical, dimension(ele_face_count(T,ele)) :: construct_Lagrange - type(element_type), pointer :: shape_T - real, dimension(ele_loc(T,ele),ele_loc(T,ele)) :: Imat - real, dimension(ele_loc(T,ele)) :: Irhs - real, dimension(ele_loc(X,ele)) :: local_coords - integer, dimension(face_loc(T,1)) :: l_face_list,l_face_list_2 - - real :: Discontinuity_indicator, inflow_integral, h - real, dimension(ele_loc(T,ele)) :: ones - integer :: discontinuity_option - real :: face_max, face_min - - if(debugging) then - ewrite(2,*) 'Limit_slope_Hermite_weno_ele' - end if - - limit_slope = .false. - - boundaries = .false. - construct_Lagrange = .true. - - T_val=ele_val(T, ele) - X_val=ele_val(X, ele) - - ele_mean=sum(T_val)/size(T_val) - - neigh=>ele_neigh(T, ele) - ! x_neigh/=t_neigh only on periodic boundaries. - x_neigh=>ele_neigh(X, ele) - - discontinuity_option = 2 - - select case(discontinuity_option) - - case (1) - !========================================================= - !Discontinuity detector using TVB condition - !Checks solution on each face is between mean values of - !ele and ele_2 - !========================================================= - do ni=1,size(neigh) - - !-------------------------------------------------------------------- - ! Find the relevant faces. - !-------------------------------------------------------------------- - ele_2=neigh(ni) - - if(ele_2<0) cycle - - T_val_2 = ele_val(T,ele_2) - face=ele_face(T, ele, ele_2) - T_val_face = face_val(T, face) - T_face_quad = face_val_at_quad(T,face) - !face_max = maxval(T_val_face) - !face_min = minval(T_val_face) - face_max = maxval(T_face_quad) - face_min = minval(T_face_quad) - ele_mean_2 = sum(T_val_2)/size(T_val_2) - - !ewrite(3,*) T_face_quad - !ewrite(3,*) T_val - !ewrite(3,*) T_val_2 - - if(face_max>max(ele_mean,ele_mean_2)+disc_tol) limit_slope = .true. - if(face_minele_nodes(Discontinuity_Detector_field,ele) - call set(Discontinuity_detector_field,T_ele,ones) - end if - end if - end do - - case (2) - - !================================================================= - !DISCONTINUITY INDICATOR, - !from http://www.gce.ucl.ac.be/~remacle/pdf/detect.pdf - !We compute the jump of the solution on upwind boundaries - !================================================================= - - !Initial value of integral of jump of solution on inflow boundaries - Discontinuity_indicator = 0.0 - !Initial value of inflow area/length - Inflow_integral = 0.0 - !We are going to increment these - - do ni=1,size(neigh) - - !-------------------------------------------------------------------- - ! Find the relevant faces. - !-------------------------------------------------------------------- - ele_2=neigh(ni) - - if(ele_2<0) cycle - - face=ele_face(T, ele, ele_2) - face_2=ele_face(T, ele_2, ele) - - call Discontinuity_indicator_face(Discontinuity_indicator, & - & Inflow_integral, & - & U,T,X,ele,face,face_2) + dx2(ele,ni) = norm2(dx_c(:,ni)) - end do + end do alpha_construction_loop - discontinuity_indicator = abs(discontinuity_indicator) - inflow_integral = abs(inflow_integral) + end subroutine cockburn_shu_setup_ele - !Compute h - h = get_H(X_val) + subroutine limit_slope_ele_cockburn_shu(ele, T, X) + !!< Slope limiter according to Cockburn and Shu (2001) + !!< http://dx.doi.org/10.1023/A:1012873910884 + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: T + type(vector_field), intent(in) :: X - !Get max norm in element of T - T_quad = ele_val_at_quad(T,ele) + integer, dimension(:), pointer :: neigh, x_neigh, T_ele + real :: ele_mean + real :: pos, neg + integer :: ele_2, ni, face + real, dimension(ele_loc(T,ele)) :: T_val, T_val_2 + real, dimension(ele_face_count(T,ele)) :: neigh_mean, face_mean + real, dimension(mesh_dim(T)+1) :: delta_v + real, dimension(mesh_dim(T)+1) :: Delta, new_val + integer, dimension(mesh_dim(T)) :: face_nodes - if(Discontinuity_Indicator>disc_tol*Inflow_integral& - &*maxval(abs(T_quad))*h) limit_slope = .true. + T_val=ele_val(T, ele) - if(has_discontinuity_detector_field) then - ones = 1.0 - T_ele=>ele_nodes(Discontinuity_Detector_field,ele) - call set(Discontinuity_detector_field,T_ele& - &,Discontinuity_Indicator*ones/inflow_integral/& - maxval(abs(T_quad)+limit_tol)/h) - end if - - case default - FLExit('no such discontinuity option') - end select - - if(limit_slope) then - ewrite(2,*) 'cjc: limiting slope' - limit_count = limit_count + 1 - - !Apply HWENO limiter - - setuploop: do ni=1,size(neigh) - - ele_2=neigh(ni) - - if (ele_2<=0) then - ! External face. - neigh_mean(ni)=face_mean(ni) - boundaries(ni) = .true. - - do nj = 1, size(neigh) - if(ni==nj) cycle - construct_Lagrange(nj) = .false. - end do - cycle - - end if - - ! Note that although face is calculated on field U, it is in fact - ! applicable to any field which shares the same mesh topology. - face=ele_face(T, ele, ele_2) - face_2=ele_face(T, ele_2, ele) - face_nodes=face_local_nodes(T, face) - - face_mean(ni) = sum(T_val(face_nodes))/size(face_nodes) - - T_val_2=ele_val(T, ele_2) - - T_vals(ni,:) = T_val_2 - X_vals(ni,:,:) = ele_val(X, ele_2) - - neigh_mean(ni)=sum(T_val_2)/size(T_val_2) - ele_means(ni) = neigh_mean(ni) - - end do setuploop - - if(any(boundaries).and.(missing_polys==LOWER_ORDER)) then - !On boundary, with this option, just project to p(n-1) - !We have only coded P1 so this projects to P0 - - new_val = sum(T_val)/size(T_val) - - else - - Polys = 0.0 - - if(debugging) then - ewrite(2,*) 'Limiting slope.' - end if - - !We store transformations (du_t, detwei) in the following way: - ! 1:size(neigh) : transformations for neighbouring element - ! size(neigh)+1 : transformations for this element - - shape_T=>ele_shape(T,ele) - - !Construct transformations for this element - call transform_to_physical(X, ele,& - & shape_T , dshape=du_t, detwei=detwei) - - !Polynomials are stored in the following way: - ! i = 1:size(neigh) : Lagrange polynomials obtained by - ! missing out the i-th neighbour - ! i = size(neigh)+1 : The existing polynomial representation - ! j = size(neigh)+1 + i, i = 1:size(neigh) : The function with same mean - ! as existing polynomial - ! with slope taken from - ! i-th neighbour - ! The latter representations are Hermite polynomials using - ! gradient information - - !Construct Lagrange polys - !Fails if non-flat elements - LagrangeP_loop: do ni = 1, size(neigh) - if(.not.construct_Lagrange(ni)) then - Polys(ni,:) = T_val - else - nl = 0 - do nj = 1, size(neigh) - if(nj==ni) cycle - nl = nl + 1 - ! - !This row requires that the mean of the polynomial over - !neighbour element nj be equal to the mean of the unlimited - !solution in that element. - ! - ! This is done by computing the local coordinates of the - ! centre of the neighbour element (only works for P1) which - ! gives you the coefficients of the local expansion which - ! give you the polynomial value at that point which is then - ! required to be equal to the current element mean. - ! - do nk = 1, size(neigh) - Imat(nl,:) = local_coords_interpolation(X,ele& - &,sum(X_vals(nj,:,:),2)/size(X_vals,3)) - end do - Irhs(nl) = ele_means(nj) - end do - !Last column sets the mean value - Imat(size(neigh),:) = 1.0/size(Imat,2) - Irhs(size(neigh)) = ele_mean - - !Solve for the Polynomial - call solve(Imat,Irhs,info) - Polys(ni,:) = Irhs - - if(debugging) then - !Do some checking - !Compute the polynomial at the quad points - !Check polynomial has mean value ele_mean in this element - if(abs(sum(Polys(ni,:)-ele_mean))>1.0e-5) then - FLAbort('failed to get the correct mean value in this element') - end if - !Check polynomial has mean value ele_means in other two elements - do nj = 1, size(neigh) - if(nj==ni) cycle - local_coords = local_coords_interpolation(X,ele& - &,sum(X_vals(nj,:,:),2)/size(X_vals,3)) - residual = sum(Polys(ni,:)*local_coords) - ele_means(nj) - if(abs(residual)>1.0e-5) then - FLAbort('failed to get the correct mean value in neighbour') - end if - end do - end if - - end if - end do LagrangeP_loop - - !Construct Hermite polys - !Fails if non-flat elements - - !Original polynomial - Polys(size(neigh)+1,:) = T_val - HermiteP_loop: do ni = 1, size(neigh) - !Mean of original values with slope of neighbouring element - nk = size(neigh)+1+ni - - ele_2=neigh(ni) - - if(ele_2<0) then - Polys(nk,:) = T_val - cycle - end if - - !face number in ele - face=ele_face(T, ele, ele_2) - !face number in ele_2 - face_2=ele_face(T, ele_2, ele) - - !local face number in ele - l_face = local_face_number(T, face) - !local face number in ele_2 - l_face_2 = local_face_number(T, face_2) - - !Local face list in ele - l_face_list = face_local_nodes(T, face) - !Local face list in ele_2 - l_face_list_2 = face_local_nodes(T, face_2) - - !T values in ele_2 - T_val_2=ele_val(T, ele_2) - - !First we "continue" the polynomial in ele_2 into ele - - !Polynomial takes same values on shared nodes - Polys(nk,l_face_list) = & - & T_val_2(l_face_list_2) - - !Compute local coordinates (relative to ele) - !of vertex in ele_2 which is opposite the face - local_coords = local_coords_interpolation(X,ele& - &,X_vals(ni,:,l_face_2)) - - !Solve 1D linear system to get polynomial value - !from - !T_val_2(l_face_2) = sum(Poly*local_coords) - !we have already computed the values on the face - !so we rearrange. - Polys(nk,l_face) = (T_val_2(l_face_2) - & - & sum(Polys(nk,l_face_list)*local_coords(l_face_list)))/ & - local_coords(l_face) + ele_mean=sum(T_val)/size(T_val) + + neigh=>ele_neigh(T, ele) + ! x_neigh/=t_neigh only on periodic boundaries. + x_neigh=>ele_neigh(X, ele) + + searchloop: do ni=1,size(neigh) + + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- + ele_2=neigh(ni) + + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(T, ele, ele_2) + face_nodes=face_local_nodes(T, face) + + face_mean(ni) = sum(T_val(face_nodes))/size(face_nodes) + + if (ele_2<=0) then + ! External face. + neigh_mean(ni)=face_mean(ni) + cycle + end if + + T_val_2=ele_val(T, ele_2) + + neigh_mean(ni)=sum(T_val_2)/size(T_val_2) - !ADD SOME DEBUGGING TESTS - - !Second we adjust the mean so that it is the same as the - !mean of the current solution in ele - Polys(nk,:) = Polys(nk,:)- & - & sum(Polys(nk,:))/size(T_val) + & - & sum(T_val)/size(T_val) - - end do HermiteP_loop - - if(debugging) then - ewrite(2,*) 'Dumping polynomials' - do ni = 1, size(neigh)*2 + 1 - ewrite(2,*) Polys(ni,:) - end do - end if - - !Compute oscillatory indicators - - do ni = 1, size(neigh)*2 + 1 - !construct the ni-th polynomial at the quadrature points - P_quad=matmul(Polys(ni,:), shape_T%n) - !construct the gradient of the ni-th polynomial at the quad points - do i = 1, mesh_dim(T) - dP_quad(i,:) = & - &matmul(Polys(ni,:), du_t(:,:,i)) - end do - - !construct the oscillator index of the ni-th polynomial - Polys_o(ni) = 0.0 - do i = 1, mesh_dim(T) - Polys_o(ni) = Polys_o(ni) + & - & sum(detwei*dP_quad(i,:)**2) - end do - Polys_o(ni) = Polys_o(ni)/& - &sum(detwei*(eps_o + P_quad)**2) - end do - - if(debugging) then - ewrite(2,*) 'Dumping oscillatory indicators' - ewrite(2,*) Polys_o - end if - - !Compute weights - do ni = 1, size(neigh)*2 + 1 - Polys_w(ni) = (eps_w + Polys_o(ni))**(-gam0) - end do - - if(missing_polys==IGNORE_MISSING_POLYS.and.any(boundaries)) then - do ni = 1, size(neigh) - if(boundaries(ni)) then - do nj = 1, size(neigh) - if(ni==nj) cycle - Polys_w(nj) = 0.0 - end do - Polys_w(size(neigh)+1+ni) = 0.0 - end if - end do - end if + end do searchloop - if(leave_out_hermite_polynomials) then - Polys_w(size(neigh)+1:2*size(neigh)+1) = 0.0 - end if + delta_v = matmul(alpha(ele,:,:),neigh_mean-ele_mean) - Polys_w = Polys_w/sum(Polys_w) + delta_loop: do ni=1,size(neigh) - if(debugging) then - ewrite(2,*) 'Dumping weights' - ewrite(2,*) Polys_w - end if + Delta(ni)=TVB_minmod(face_mean(ni)-ele_mean, & + Limit_factor*delta_v(ni), dx2(ele,ni)) - new_val = 0. - do ni = 1, size(neigh)*2 + 1 - new_val = new_val + Polys_w(ni)*Polys(ni,:) - end do + end do delta_loop - if(debugging) then - ewrite(2,*) 'new val is' - ewrite(2,*) new_val + if (abs(sum(Delta))>1000.0*epsilon(0.0)) then + ! Coefficients do not sum to 0.0 - ewrite(2,*) 'old slope was' - do i = 1, mesh_dim(T) - ewrite(2,*) maxval(matmul(T_val, du_t(:,:,i))) - end do + pos=sum(max(0.0, Delta)) + neg=sum(max(0.0, -Delta)) - ewrite(2,*) 'new slope is' - do i = 1, mesh_dim(T) - ewrite(2,*) maxval(matmul(new_val, du_t(:,:,i))) - end do - end if - end if + Delta = min(1.0,neg/pos)*max(0.0,Delta) & + -min(1.0,pos/neg)*max(0.0,-Delta) - T_ele=>ele_nodes(T,ele) - call set(T_limit, T_ele, new_val) + end if + + new_val=matmul(A,Delta+ele_mean) + + ! Success or non-boundary failure. + T_ele=>ele_nodes(T,ele) + + call set(T, T_ele, new_val) + + end subroutine limit_slope_ele_cockburn_shu + + !11:25 do ele_A=1,ele_count(old_position) + !11:25 call local_coords_matrix(old_position, ele_A, + ! inversion_matrices_A(:, :, ele_A)) + !11:25 end do + + !subroutine local_coords_matrix(positions, ele, mat) + !inputs global coordinates + !outputs local coordinates + + subroutine limit_slope_ele_hermite_weno(ele, T, T_limit, X, U) + !!< Hermite Weno Slope limiter + integer, intent(in) :: ele + type(scalar_field), intent(in) :: T + type(scalar_field), intent(inout) :: T_limit + type(vector_field), intent(in) :: X, U + + integer, dimension(:), pointer :: neigh, x_neigh, T_ele + real :: ele_mean, ele_mean_2 + real, dimension(ele_face_count(T,ele)) :: ele_means + real :: residual + integer :: ele_2, ni, nj, face, face_2,i, nk, info, nl + integer :: l_face, l_face_2 + real, dimension(ele_loc(T,ele)) :: T_val, T_val_2 + real, dimension(face_loc(T,1)) :: T_val_face + real, dimension(face_ngi(T,1)) :: T_face_quad + real, dimension(ele_face_count(T,ele),ele_loc(X,ele)) :: T_vals + real, dimension(ele_face_count(T,ele),X%dim, ele_loc(X,ele)) :: X_vals + real, dimension(X%dim, ele_loc(X,ele)) :: X_val + real, dimension(ele_face_count(T,ele)) :: neigh_mean, face_mean + real, dimension(ele_loc(T,ele)) :: new_val + integer, dimension(mesh_dim(T)) :: face_nodes + logical :: limit_slope + real, dimension(ele_loc(T, ele), ele_ngi(T, ele), & + &mesh_dim(T)) :: du_t + real, dimension(ele_ngi(T,ele)) :: detwei + real, dimension(ele_ngi(T,ele)) :: p_quad, T_quad + real, dimension(1+2*ele_loc(T,ele),ele_loc(T,ele)) :: Polys + real, dimension(ele_loc(T,ele)*2+1) :: Polys_o, Polys_w + real, dimension(mesh_dim(T),ele_ngi(T,ele)) :: dp_quad + logical, dimension(ele_face_count(T,ele)) :: boundaries + logical, dimension(ele_face_count(T,ele)) :: construct_Lagrange + type(element_type), pointer :: shape_T + real, dimension(ele_loc(T,ele),ele_loc(T,ele)) :: Imat + real, dimension(ele_loc(T,ele)) :: Irhs + real, dimension(ele_loc(X,ele)) :: local_coords + integer, dimension(face_loc(T,1)) :: l_face_list,l_face_list_2 + + real :: Discontinuity_indicator, inflow_integral, h + real, dimension(ele_loc(T,ele)) :: ones + integer :: discontinuity_option + real :: face_max, face_min + + if(debugging) then + ewrite(2,*) 'Limit_slope_Hermite_weno_ele' + end if + + limit_slope = .false. + + boundaries = .false. + construct_Lagrange = .true. + + T_val=ele_val(T, ele) + X_val=ele_val(X, ele) + + ele_mean=sum(T_val)/size(T_val) + + neigh=>ele_neigh(T, ele) + ! x_neigh/=t_neigh only on periodic boundaries. + x_neigh=>ele_neigh(X, ele) + + discontinuity_option = 2 + + select case(discontinuity_option) + + case (1) + !========================================================= + !Discontinuity detector using TVB condition + !Checks solution on each face is between mean values of + !ele and ele_2 + !========================================================= + do ni=1,size(neigh) + + !-------------------------------------------------------------------- + ! Find the relevant faces. + !-------------------------------------------------------------------- + ele_2=neigh(ni) + + if(ele_2<0) cycle + + T_val_2 = ele_val(T,ele_2) + face=ele_face(T, ele, ele_2) + T_val_face = face_val(T, face) + T_face_quad = face_val_at_quad(T,face) + !face_max = maxval(T_val_face) + !face_min = minval(T_val_face) + face_max = maxval(T_face_quad) + face_min = minval(T_face_quad) + ele_mean_2 = sum(T_val_2)/size(T_val_2) + + !ewrite(3,*) T_face_quad + !ewrite(3,*) T_val + !ewrite(3,*) T_val_2 + + if(face_max>max(ele_mean,ele_mean_2)+disc_tol) limit_slope = .true. + if(face_minele_nodes(Discontinuity_Detector_field,ele) + call set(Discontinuity_detector_field,T_ele,ones) + end if + end if + end do - end if + case (2) - end subroutine limit_slope_ele_hermite_weno + !================================================================= + !DISCONTINUITY INDICATOR, + !from http://www.gce.ucl.ac.be/~remacle/pdf/detect.pdf + !We compute the jump of the solution on upwind boundaries + !================================================================= - function TVB_minmod(a1,a2, dx) - real :: TVB_minmod - real, intent(in) :: a1, a2, dx + !Initial value of integral of jump of solution on inflow boundaries + Discontinuity_indicator = 0.0 + !Initial value of inflow area/length + Inflow_integral = 0.0 + !We are going to increment these - if (abs(a1)disc_tol*Inflow_integral& + &*maxval(abs(T_quad))*h) limit_slope = .true. - neigh=>ele_neigh(T, ele) + if(has_discontinuity_detector_field) then + ones = 1.0 + T_ele=>ele_nodes(Discontinuity_Detector_field,ele) + call set(Discontinuity_detector_field,T_ele& + &,Discontinuity_Indicator*ones/inflow_integral/& + maxval(abs(T_quad)+limit_tol)/h) + end if - neighbourloop: do ni=1,size(neigh) + case default + FLExit('no such discontinuity option') + end select + + if(limit_slope) then + ewrite(2,*) 'cjc: limiting slope' + limit_count = limit_count + 1 + + !Apply HWENO limiter + + setuploop: do ni=1,size(neigh) + + ele_2=neigh(ni) + + if (ele_2<=0) then + ! External face. + neigh_mean(ni)=face_mean(ni) + boundaries(ni) = .true. + + do nj = 1, size(neigh) + if(ni==nj) cycle + construct_Lagrange(nj) = .false. + end do + cycle + + end if + + ! Note that although face is calculated on field U, it is in fact + ! applicable to any field which shares the same mesh topology. + face=ele_face(T, ele, ele_2) + face_2=ele_face(T, ele_2, ele) + face_nodes=face_local_nodes(T, face) + + face_mean(ni) = sum(T_val(face_nodes))/size(face_nodes) + + T_val_2=ele_val(T, ele_2) + + T_vals(ni,:) = T_val_2 + X_vals(ni,:,:) = ele_val(X, ele_2) + + neigh_mean(ni)=sum(T_val_2)/size(T_val_2) + ele_means(ni) = neigh_mean(ni) + + end do setuploop + + if(any(boundaries).and.(missing_polys==LOWER_ORDER)) then + !On boundary, with this option, just project to p(n-1) + !We have only coded P1 so this projects to P0 + + new_val = sum(T_val)/size(T_val) + + else + + Polys = 0.0 + + if(debugging) then + ewrite(2,*) 'Limiting slope.' + end if + + !We store transformations (du_t, detwei) in the following way: + ! 1:size(neigh) : transformations for neighbouring element + ! size(neigh)+1 : transformations for this element + + shape_T=>ele_shape(T,ele) + + !Construct transformations for this element + call transform_to_physical(X, ele,& + & shape_T , dshape=du_t, detwei=detwei) + + !Polynomials are stored in the following way: + ! i = 1:size(neigh) : Lagrange polynomials obtained by + ! missing out the i-th neighbour + ! i = size(neigh)+1 : The existing polynomial representation + ! j = size(neigh)+1 + i, i = 1:size(neigh) : The function with same mean + ! as existing polynomial + ! with slope taken from + ! i-th neighbour + ! The latter representations are Hermite polynomials using + ! gradient information + + !Construct Lagrange polys + !Fails if non-flat elements + LagrangeP_loop: do ni = 1, size(neigh) + if(.not.construct_Lagrange(ni)) then + Polys(ni,:) = T_val + else + nl = 0 + do nj = 1, size(neigh) + if(nj==ni) cycle + nl = nl + 1 + ! + !This row requires that the mean of the polynomial over + !neighbour element nj be equal to the mean of the unlimited + !solution in that element. + ! + ! This is done by computing the local coordinates of the + ! centre of the neighbour element (only works for P1) which + ! gives you the coefficients of the local expansion which + ! give you the polynomial value at that point which is then + ! required to be equal to the current element mean. + ! + do nk = 1, size(neigh) + Imat(nl,:) = local_coords_interpolation(X,ele& + &,sum(X_vals(nj,:,:),2)/size(X_vals,3)) + end do + Irhs(nl) = ele_means(nj) + end do + !Last column sets the mean value + Imat(size(neigh),:) = 1.0/size(Imat,2) + Irhs(size(neigh)) = ele_mean + + !Solve for the Polynomial + call solve(Imat,Irhs,info) + Polys(ni,:) = Irhs + + if(debugging) then + !Do some checking + !Compute the polynomial at the quad points + !Check polynomial has mean value ele_mean in this element + if(abs(sum(Polys(ni,:)-ele_mean))>1.0e-5) then + FLAbort('failed to get the correct mean value in this element') + end if + !Check polynomial has mean value ele_means in other two elements + do nj = 1, size(neigh) + if(nj==ni) cycle + local_coords = local_coords_interpolation(X,ele& + &,sum(X_vals(nj,:,:),2)/size(X_vals,3)) + residual = sum(Polys(ni,:)*local_coords) - ele_means(nj) + if(abs(residual)>1.0e-5) then + FLAbort('failed to get the correct mean value in neighbour') + end if + end do + end if + + end if + end do LagrangeP_loop + + !Construct Hermite polys + !Fails if non-flat elements + + !Original polynomial + Polys(size(neigh)+1,:) = T_val + HermiteP_loop: do ni = 1, size(neigh) + !Mean of original values with slope of neighbouring element + nk = size(neigh)+1+ni + + ele_2=neigh(ni) + + if(ele_2<0) then + Polys(nk,:) = T_val + cycle + end if + + !face number in ele + face=ele_face(T, ele, ele_2) + !face number in ele_2 + face_2=ele_face(T, ele_2, ele) + + !local face number in ele + l_face = local_face_number(T, face) + !local face number in ele_2 + l_face_2 = local_face_number(T, face_2) + + !Local face list in ele + l_face_list = face_local_nodes(T, face) + !Local face list in ele_2 + l_face_list_2 = face_local_nodes(T, face_2) + + !T values in ele_2 + T_val_2=ele_val(T, ele_2) + + !First we "continue" the polynomial in ele_2 into ele + + !Polynomial takes same values on shared nodes + Polys(nk,l_face_list) = & + & T_val_2(l_face_list_2) + + !Compute local coordinates (relative to ele) + !of vertex in ele_2 which is opposite the face + local_coords = local_coords_interpolation(X,ele& + &,X_vals(ni,:,l_face_2)) + + !Solve 1D linear system to get polynomial value + !from + !T_val_2(l_face_2) = sum(Poly*local_coords) + !we have already computed the values on the face + !so we rearrange. + Polys(nk,l_face) = (T_val_2(l_face_2) - & + & sum(Polys(nk,l_face_list)*local_coords(l_face_list)))/ & + local_coords(l_face) - !---------------------------------------------------------------------- - ! Find the relevant faces. - !---------------------------------------------------------------------- + !ADD SOME DEBUGGING TESTS + + !Second we adjust the mean so that it is the same as the + !mean of the current solution in ele + Polys(nk,:) = Polys(nk,:)- & + & sum(Polys(nk,:))/size(T_val) + & + & sum(T_val)/size(T_val) + + end do HermiteP_loop + + if(debugging) then + ewrite(2,*) 'Dumping polynomials' + do ni = 1, size(neigh)*2 + 1 + ewrite(2,*) Polys(ni,:) + end do + end if + + !Compute oscillatory indicators + + do ni = 1, size(neigh)*2 + 1 + !construct the ni-th polynomial at the quadrature points + P_quad=matmul(Polys(ni,:), shape_T%n) + !construct the gradient of the ni-th polynomial at the quad points + do i = 1, mesh_dim(T) + dP_quad(i,:) = & + &matmul(Polys(ni,:), du_t(:,:,i)) + end do + + !construct the oscillator index of the ni-th polynomial + Polys_o(ni) = 0.0 + do i = 1, mesh_dim(T) + Polys_o(ni) = Polys_o(ni) + & + & sum(detwei*dP_quad(i,:)**2) + end do + Polys_o(ni) = Polys_o(ni)/& + &sum(detwei*(eps_o + P_quad)**2) + end do + + if(debugging) then + ewrite(2,*) 'Dumping oscillatory indicators' + ewrite(2,*) Polys_o + end if + + !Compute weights + do ni = 1, size(neigh)*2 + 1 + Polys_w(ni) = (eps_w + Polys_o(ni))**(-gam0) + end do + + if(missing_polys==IGNORE_MISSING_POLYS.and.any(boundaries)) then + do ni = 1, size(neigh) + if(boundaries(ni)) then + do nj = 1, size(neigh) + if(ni==nj) cycle + Polys_w(nj) = 0.0 + end do + Polys_w(size(neigh)+1+ni) = 0.0 + end if + end do + end if + + if(leave_out_hermite_polynomials) then + Polys_w(size(neigh)+1:2*size(neigh)+1) = 0.0 + end if + + Polys_w = Polys_w/sum(Polys_w) + + if(debugging) then + ewrite(2,*) 'Dumping weights' + ewrite(2,*) Polys_w + end if + + new_val = 0. + do ni = 1, size(neigh)*2 + 1 + new_val = new_val + Polys_w(ni)*Polys(ni,:) + end do + + if(debugging) then + ewrite(2,*) 'new val is' + ewrite(2,*) new_val + + ewrite(2,*) 'old slope was' + do i = 1, mesh_dim(T) + ewrite(2,*) maxval(matmul(T_val, du_t(:,:,i))) + end do + + ewrite(2,*) 'new slope is' + do i = 1, mesh_dim(T) + ewrite(2,*) maxval(matmul(new_val, du_t(:,:,i))) + end do + end if + end if - ! These finding routines are outside the inner loop so as to allow - ! for local stack variables of the right size in - ! construct_add_diff_interface_dg. + T_ele=>ele_nodes(T,ele) + call set(T_limit, T_ele, new_val) - ele_2=neigh(ni) + end if - if (ele_2<=0) then - ! External face. - cycle - end if + end subroutine limit_slope_ele_hermite_weno - X_val_2=ele_val(X, ele_2) - T_val_2=ele_val(T, ele_2) + function TVB_minmod(a1,a2, dx) + real :: TVB_minmod + real, intent(in) :: a1, a2, dx - ele_2_centre=sum(X_val_2,2)/size(X_val_2,2) + if (abs(a1)ele_nodes(T,ele) + ele_centre=sum(X_val,2)/size(X_val,2) - call set(T, T_ele(1), ele_mean-0.5*dx*ele_slope) - call set(T, T_ele(2), ele_mean+0.5*dx*ele_slope) + ele_mean=sum(T_val)/size(T_val) - end if + dx=X_val(1,2)-X_val(1,1) - end subroutine limit_slope_ele_dg_1d + ele_slope=(T_val(2)-T_val(1))/dx - subroutine Discontinuity_indicator_face(Discontinuity_indicator, & - & Inflow_integral, & - & U,T,X,ele,face,face_2) - real, intent(inout) :: Discontinuity_indicator, Inflow_integral - type(vector_field), intent(in) :: U,X - type(scalar_field), intent(in) :: T - integer, intent(in) :: ele, face, face_2 - ! - real, dimension(face_ngi(T,face)) :: detwei - real, dimension(mesh_dim(T),face_ngi(T,face)) :: normal - real, dimension(mesh_dim(U),face_ngi(U,face)) :: U_flux - integer, dimension(face_ngi(U,face)) :: inflow - logical :: use_mean_inflow - !stuff for local calculations - real, dimension(U%dim,ele_loc(X,ele)) :: X_val - real, dimension(face_loc(T,face)) :: T_face_val - real, dimension(U%dim,face_loc(X,face)) :: X_face_val - real, dimension(U%dim) :: centroid2face, normal_vec, Vec1, Vec2 - real, dimension(U%dim,face_loc(U,face)) :: U_face_val - real :: Area + old_ele_slope=ele_slope - X_val = ele_val(X,ele) - x_face_val = face_val(X,face) + neigh=>ele_neigh(T, ele) - use_mean_inflow = .false. + neighbourloop: do ni=1,size(neigh) - if(use_mean_inflow) then + !---------------------------------------------------------------------- + ! Find the relevant faces. + !---------------------------------------------------------------------- - !We only compute on mean inflow boundaries - !This means we can avoid transforming to physical - !only works on flat elements + ! These finding routines are outside the inner loop so as to allow + ! for local stack variables of the right size in + ! construct_add_diff_interface_dg. - !compute normals - select case (U%dim) - case (2) - Vec1 = x_face_val(:,1) - x_face_val(:,2) - normal_vec(1) = -Vec1(2) - normal_vec(2) = Vec1(1) - Area = sqrt(sum(Vec1**2)) - case (3) - Vec1 = x_face_val(:,1) - x_face_val(:,2) - Vec2 = x_face_val(:,1) - x_face_val(:,3) - normal_vec(1) = Vec1(2)*Vec2(3)-Vec1(3)*Vec2(2) - normal_vec(2) = -Vec1(1)*Vec2(3)+Vec1(3)*Vec2(1) - normal_vec(3) = Vec1(1)*Vec2(2)-Vec1(2)*Vec2(1) - Area = 0.5*sqrt(sum(normal_vec**2)) - case default - FLExit('cant handle that case - that dimension is not supported') - end select - normal_vec = normal_vec / sqrt(sum(normal_vec**2)) - centroid2face = sum(X_face_val,2)/size(X_face_val,2) - & - & sum(X_val,2)/size(X_val,2) - if(sum(normal_vec*centroid2face)<0.0) normal_vec = -normal_vec + ele_2=neigh(ni) + + if (ele_2<=0) then + ! External face. + cycle + end if + + X_val_2=ele_val(X, ele_2) + T_val_2=ele_val(T, ele_2) - !Check if have mean inflow on this faec - U_face_val = face_val(U,face) - if(sum(sum(U_face_val,2)/size(U_face_val,2)*normal_vec)<1.0e-15) then + ele_2_centre=sum(X_val_2,2)/size(X_val_2,2) - T_face_val = face_val(T,face) - face_val(T,face_2) + ele_2_mean=sum(T_val_2)/size(T_val_2) - Discontinuity_indicator = Discontinuity_indicator + & + ele_2_slope=(ele_2_mean-ele_mean)/sum(ele_2_centre-ele_centre) + + if (ele_slope*ele_2_slope<0.0) then + ! Slope sign changes + ele_slope=0.0 + exit neighbourloop + end if + + ele_slope=sign(min(abs(ele_slope),abs(ele_2_slope)), ele_slope) + + end do neighbourloop + + if (old_ele_slope/=ele_slope) then + + ! Remove high order stuff here. + T_ele=>ele_nodes(T,ele) + + call set(T, T_ele(1), ele_mean-0.5*dx*ele_slope) + call set(T, T_ele(2), ele_mean+0.5*dx*ele_slope) + + end if + + end subroutine limit_slope_ele_dg_1d + + subroutine Discontinuity_indicator_face(Discontinuity_indicator, & + & Inflow_integral, & + & U,T,X,ele,face,face_2) + real, intent(inout) :: Discontinuity_indicator, Inflow_integral + type(vector_field), intent(in) :: U,X + type(scalar_field), intent(in) :: T + integer, intent(in) :: ele, face, face_2 + ! + real, dimension(face_ngi(T,face)) :: detwei + real, dimension(mesh_dim(T),face_ngi(T,face)) :: normal + real, dimension(mesh_dim(U),face_ngi(U,face)) :: U_flux + integer, dimension(face_ngi(U,face)) :: inflow + logical :: use_mean_inflow + !stuff for local calculations + real, dimension(U%dim,ele_loc(X,ele)) :: X_val + real, dimension(face_loc(T,face)) :: T_face_val + real, dimension(U%dim,face_loc(X,face)) :: X_face_val + real, dimension(U%dim) :: centroid2face, normal_vec, Vec1, Vec2 + real, dimension(U%dim,face_loc(U,face)) :: U_face_val + real :: Area + + X_val = ele_val(X,ele) + x_face_val = face_val(X,face) + + use_mean_inflow = .false. + + if(use_mean_inflow) then + + !We only compute on mean inflow boundaries + !This means we can avoid transforming to physical + !only works on flat elements + + !compute normals + select case (U%dim) + case (2) + Vec1 = x_face_val(:,1) - x_face_val(:,2) + normal_vec(1) = -Vec1(2) + normal_vec(2) = Vec1(1) + Area = sqrt(sum(Vec1**2)) + case (3) + Vec1 = x_face_val(:,1) - x_face_val(:,2) + Vec2 = x_face_val(:,1) - x_face_val(:,3) + normal_vec(1) = Vec1(2)*Vec2(3)-Vec1(3)*Vec2(2) + normal_vec(2) = -Vec1(1)*Vec2(3)+Vec1(3)*Vec2(1) + normal_vec(3) = Vec1(1)*Vec2(2)-Vec1(2)*Vec2(1) + Area = 0.5*sqrt(sum(normal_vec**2)) + case default + FLExit('cant handle that case - that dimension is not supported') + end select + normal_vec = normal_vec / sqrt(sum(normal_vec**2)) + centroid2face = sum(X_face_val,2)/size(X_face_val,2) - & + & sum(X_val,2)/size(X_val,2) + if(sum(normal_vec*centroid2face)<0.0) normal_vec = -normal_vec + + !Check if have mean inflow on this faec + U_face_val = face_val(U,face) + if(sum(sum(U_face_val,2)/size(U_face_val,2)*normal_vec)<1.0e-15) then + + T_face_val = face_val(T,face) - face_val(T,face_2) + + Discontinuity_indicator = Discontinuity_indicator + & sum(T_face_val)/size(T_face_val)*Area - Inflow_integral = Inflow_integral + Area - end if + Inflow_integral = Inflow_integral + Area + end if - else + else - call transform_facet_to_physical( X, face,& - & detwei_f=detwei,normal=normal) + call transform_facet_to_physical( X, face,& + & detwei_f=detwei,normal=normal) - U_flux = 0.5*(face_val_at_quad(U,face)+ & - & face_val_at_quad(U,face_2)) + U_flux = 0.5*(face_val_at_quad(U,face)+ & + & face_val_at_quad(U,face_2)) - !We only compute on inflow boundaries - inflow = merge(1.0,0.0,sum(U_flux*normal,1)<0.0) + !We only compute on inflow boundaries + inflow = merge(1.0,0.0,sum(U_flux*normal,1)<0.0) - Discontinuity_indicator = & - & Discontinuity_indicator + & + Discontinuity_indicator = & + & Discontinuity_indicator + & abs(sum( (face_val_at_quad(T, face) & - face_val_at_quad(T,face_2))*detwei*inflow )) - Area = abs(sum(detwei*inflow)) - Inflow_integral = Inflow_integral + Area - end if - - end subroutine Discontinuity_indicator_face - - function get_H(X) result (h) - real, dimension(:,:), intent(in) :: X - real :: h - ! - integer :: i,j,dim - real :: a,b,c - - dim = size(X,1) - - select case(dim) - case (1) - !Just take the difference - h = abs(X(1,1)-X(1,2)) - case (2) - !Circumradius - a = sqrt(sum((X(:,2)-X(:,1))**2)) - b = sqrt(sum((X(:,3)-X(:,2))**2)) - c = sqrt(sum((X(:,1)-X(:,3))**2)) - h = a*b*c/sqrt((a+b+c)*(b+c-a)*(c+a-b)*(a+b-c)) - case (3) - !This should be circumradius too but I didn't code it - h = 0.0 - do i = 1, size(X,2) - do j = 2, size(X,2) - h = max(h,sqrt(sum( (X(:,i)-X(:,j))**2 ))) - end do - end do - case default - FLExit('dont know that dimension.') - end select - - end function get_H - - subroutine limit_vb(state, t) - !Vertex-based (not Victoria Bitter) limiter from - !Kuzmin, J. Comp. Appl. Math., 2010 - ! doi:10.1016/j.cam.2009.05.028 - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: t - ! - ! This is the limited version of the field, we have to make a copy - type(scalar_field) :: T_limit, T_max, T_min - type(mesh_type), pointer :: vertex_mesh - ! counters - integer :: ele, node - ! local numbers - integer, dimension(:), pointer :: T_ele - ! gradient scaling factor - real :: alpha - ! local field values - real, dimension(ele_loc(T,1)) :: T_val, T_val_slope, T_val_min,T_val_max - real :: Tbar - - if (.not. element_degree(T%mesh, 1)==1 .or. continuity(T%mesh)>=0) then - FLExit("The vertex based slope limiter only works for P1DG fields.") - end if - - ! Allocate copy of field - call allocate(T_limit, T%mesh,trim(T%name)//"Limited") - call set(T_limit, T) - - ! returns linear version of T%mesh (if T%mesh is periodic, so is vertex_mesh) - call find_linear_parent_mesh(state, T%mesh, vertex_mesh) - - call allocate(T_max, vertex_mesh, trim(T%name)//"LimitMax") - call allocate(T_min, vertex_mesh, trim(T%name)//"LimitMin") - - call set(T_max, -huge(0.0)) - call set(T_min, huge(0.0)) - - ! for each vertex in the mesh store the min and max values of the P1DG nodes directly surrounding it - do ele = 1, ele_count(T) - T_ele => ele_nodes(T,ele) - T_val = ele_val(T,ele) - Tbar = sum(T_val)/size(T_val) - ! we assume here T is P1DG and vertex_mesh is linear - assert( size(T_ele)==ele_loc(vertex_mesh,ele) ) - - ! do maxes - T_val_max = ele_val(T_max,ele) - do node = 1, size(T_val) - T_val_max(node) = max(T_val_max(node), Tbar) - end do - call set(T_max, ele_nodes(T_max, ele), T_val_max) - - ! do mins - T_val_min = ele_val(T_min,ele) - do node = 1, size(T_val) - T_val_min(node) = min(T_val_min(node), Tbar) - end do - call set(T_min, ele_nodes(T_min,ele), T_val_min) - end do - - ! now for each P1DG node make sure the field value is between the recorded vertex min and max - ! this is done without changing the element average (Tbar) - do ele = 1, ele_count(T) - !Set slope factor to 1 - alpha = 1. - !Get local node lists - T_ele=>ele_nodes(T,ele) - - T_val = ele_val(T,ele) - Tbar = sum(T_val)/size(T_val) - T_val_slope = T_val - Tbar - T_val_max = ele_val(T_max,ele) - T_val_min = ele_val(T_min,ele) - - !loop over nodes, adjust alpha - do node = 1, size(T_val) - !check whether to use max or min, and avoid floating point algebra errors due to round-off and underflow - if(T_val(node)>Tbar*(1.0+sign(1.0e-12,Tbar)) .and. T_val(node)-Tbar > tiny(0.0)*1e10) then - alpha = min(alpha,(T_val_max(node)-Tbar)/(T_val(node)-Tbar)) - else if(T_val(node)=0) then + FLExit("The vertex based slope limiter only works for P1DG fields.") + end if + + ! Allocate copy of field + call allocate(T_limit, T%mesh,trim(T%name)//"Limited") + call set(T_limit, T) + + ! returns linear version of T%mesh (if T%mesh is periodic, so is vertex_mesh) + call find_linear_parent_mesh(state, T%mesh, vertex_mesh) + + call allocate(T_max, vertex_mesh, trim(T%name)//"LimitMax") + call allocate(T_min, vertex_mesh, trim(T%name)//"LimitMin") + + call set(T_max, -huge(0.0)) + call set(T_min, huge(0.0)) + + ! for each vertex in the mesh store the min and max values of the P1DG nodes directly surrounding it + do ele = 1, ele_count(T) + T_ele => ele_nodes(T,ele) + T_val = ele_val(T,ele) + Tbar = sum(T_val)/size(T_val) + ! we assume here T is P1DG and vertex_mesh is linear + assert( size(T_ele)==ele_loc(vertex_mesh,ele) ) + + ! do maxes + T_val_max = ele_val(T_max,ele) + do node = 1, size(T_val) + T_val_max(node) = max(T_val_max(node), Tbar) + end do + call set(T_max, ele_nodes(T_max, ele), T_val_max) + + ! do mins + T_val_min = ele_val(T_min,ele) + do node = 1, size(T_val) + T_val_min(node) = min(T_val_min(node), Tbar) + end do + call set(T_min, ele_nodes(T_min,ele), T_val_min) + end do + + ! now for each P1DG node make sure the field value is between the recorded vertex min and max + ! this is done without changing the element average (Tbar) + do ele = 1, ele_count(T) + !Set slope factor to 1 + alpha = 1. + !Get local node lists + T_ele=>ele_nodes(T,ele) + + T_val = ele_val(T,ele) + Tbar = sum(T_val)/size(T_val) + T_val_slope = T_val - Tbar + T_val_max = ele_val(T_max,ele) + T_val_min = ele_val(T_min,ele) + + !loop over nodes, adjust alpha + do node = 1, size(T_val) + !check whether to use max or min, and avoid floating point algebra errors due to round-off and underflow + if(T_val(node)>Tbar*(1.0+sign(1.0e-12,Tbar)) .and. T_val(node)-Tbar > tiny(0.0)*1e10) then + alpha = min(alpha,(T_val_max(node)-Tbar)/(T_val(node)-Tbar)) + else if(T_val(node) get_mass_matrix(state, t%mesh) - lumped_mass => get_lumped_mass(state, t%mesh) - call allocate(inverse_lumped_mass, lumped_mass%mesh, "InverseLumpedMass") - inverse_lumped_mass%val = 1.0/lumped_mass%val + mass => get_mass_matrix(state, t%mesh) + lumped_mass => get_lumped_mass(state, t%mesh) + call allocate(inverse_lumped_mass, lumped_mass%mesh, "InverseLumpedMass") + inverse_lumped_mass%val = 1.0/lumped_mass%val - limiting_t => extract_scalar_field(state, trim(t%name)) + limiting_t => extract_scalar_field(state, trim(t%name)) ! eelist => extract_eelist(t%mesh) - call allocate(lowerbound, t%mesh, "LowerBound") - call allocate(upperbound, t%mesh, "UpperBound") - call zero(lowerbound); call zero(upperbound) + call allocate(lowerbound, t%mesh, "LowerBound") + call allocate(upperbound, t%mesh, "UpperBound") + call zero(lowerbound); call zero(upperbound) - allocate (neighbouring_nodes(ele_loc(limiting_t,1))) + allocate (neighbouring_nodes(ele_loc(limiting_t,1))) ! allocate (face_nodes(face_loc(limiting_t,1)), neighbouring_nodes(face_loc(limiting_t,1))) - if (extrapolate) then - position => extract_vector_field(state, "Coordinate") - call allocate(dg_position, position%dim, t%mesh, name="DG_Coordinate") - call remap_field(position, dg_position) - allocate (e_vec_1(position%dim),dt_t(ele_loc(limiting_t, 1), ele_ngi(limiting_t, 1), mesh_dim(limiting_t))) - allocate (grad_t(mesh_dim(limiting_t), limiting_t%mesh%shape%ngi)) - end if - - if (upwind) then - u => extract_vector_field(state, "Velocity") - end if - - ! Loop to construct an array containing the global node numbers required to compute the limiting values - ! at a node i. Only evaluated on the first timestep (and after every adapt for adaptive runs). - if (first) then - allocate (nodes_array(node_count(t),rows,columns)) - first=.false. - do node=1,node_count(limiting_t) - ele=node_ele(limiting_t, node) - nodelist => ele_nodes(limiting_t, ele) - faces => ele_faces(limiting_t, ele) - row=0 - do i=1,size(nodelist) - if (nodelist(i)==node) cycle - row=row+1 - fnodes=face_global_nodes(limiting_t,faces(i)) - do j=1,size(fnodes) - if (fnodes(j)==node) adjacent_node=j - end do - neighbouring_face = face_neigh(limiting_t, faces(i)) - neighbouring_face_nodes = face_global_nodes(limiting_t,neighbouring_face) + if (extrapolate) then + position => extract_vector_field(state, "Coordinate") + call allocate(dg_position, position%dim, t%mesh, name="DG_Coordinate") + call remap_field(position, dg_position) + allocate (e_vec_1(position%dim),dt_t(ele_loc(limiting_t, 1), ele_ngi(limiting_t, 1), mesh_dim(limiting_t))) + allocate (grad_t(mesh_dim(limiting_t), limiting_t%mesh%shape%ngi)) + end if + + if (upwind) then + u => extract_vector_field(state, "Velocity") + end if + + ! Loop to construct an array containing the global node numbers required to compute the limiting values + ! at a node i. Only evaluated on the first timestep (and after every adapt for adaptive runs). + if (first) then + allocate (nodes_array(node_count(t),rows,columns)) + first=.false. + do node=1,node_count(limiting_t) + ele=node_ele(limiting_t, node) + nodelist => ele_nodes(limiting_t, ele) + faces => ele_faces(limiting_t, ele) + row=0 + do i=1,size(nodelist) + if (nodelist(i)==node) cycle + row=row+1 + fnodes=face_global_nodes(limiting_t,faces(i)) + do j=1,size(fnodes) + if (fnodes(j)==node) adjacent_node=j + end do + neighbouring_face = face_neigh(limiting_t, faces(i)) + neighbouring_face_nodes = face_global_nodes(limiting_t,neighbouring_face) ! secnd_val=neighbouring_face_nodes(adjacent_node) ! 2nd node we want - local_face=local_face_number(limiting_t,neighbouring_face) - neighbouring_ele = face_ele(limiting_t, neighbouring_face) - neighbouring_nodes = ele_nodes(limiting_t, neighbouring_ele) + local_face=local_face_number(limiting_t,neighbouring_face) + neighbouring_ele = face_ele(limiting_t, neighbouring_face) + neighbouring_nodes = ele_nodes(limiting_t, neighbouring_ele) ! thrid_val=neighbouring_nodes(local_face) - nodes_array(node,row,1)=nodelist(i) - nodes_array(node,row,2)=neighbouring_face_nodes(adjacent_node) - nodes_array(node,row,3)=neighbouring_nodes(local_face) - end do - end do - end if - - ! Loop through the nodes and calculate the bounds for each node - do node=1,node_count(limiting_t) - ! Calculate the av. value of the tracer within the element - ele=node_ele(limiting_t, node) - nodelist => ele_nodes(limiting_t, ele) - do i=1, size(nodelist) - tracer_val(i)=node_val(limiting_t,nodelist(i)) - end do - mean_val=sum(tracer_val)/float(size(nodelist)) - ! Get the values needed for calculating the bounds - do row=1,rows - do column=1,columns - local_values(row,column)=node_val(limiting_t, nodes_array(node,row,column)) - end do - ! Adjust values depending on options - if (midpoint.and.(.not.extrapolate)) then - local_values(row,3) = (1.0-beta)*local_values(row,2)+beta*local_values(row,3) - else if (midpoint.and.extrapolate) then - local_values(row,3) = (1.0-beta)*local_values(row,2)+beta*local_values(row,3) - ! Extrapolate using the gradients of the neighbouring element to form our extra value - - ! 1st, work out the direction in which we want to extrapolate, e_vec_1 - e_vec_1=node_val(dg_position,node)-node_val(dg_position,nodes_array(node,row,1)) - ! Work out the distance to exprapolate - e_dist=sqrt(sum(e_vec_1(:)**2)) - ! Turn this into a unit vector - e_vec_1=e_vec_1/e_dist - - call transform_to_physical(dg_position, node_ele(limiting_t, nodes_array(node,row,2)), & - ele_shape(limiting_t,node_ele(limiting_t, nodes_array(node,row,2))), dshape=dt_t) - - grad_t=ele_grad_at_quad(limiting_t, node_ele(limiting_t, node), dt_t) - - ! Calculate the gradient in the desired direction - ! Note that grad_t will be the same at all gauss points in the linear element case - grad=dot_product(grad_t(1,:),e_vec_1) - - local_values(row,4) = local_values(row,2)+beta*grad*e_dist - end if - if (upwind) then - u_node=node_val(u, node) - mod_u=sqrt(dot_product(u_node,u_node)) - u_node=u_node/mod_u - e_vec_2=e_vec_1 - e_vec_1=-e_vec_1 - e_vec_3=node_val(dg_position,nodes_array(node,row,3))-node_val(dg_position,node) - e_vec_3=e_vec_3/sqrt(dot_product(e_vec_3,e_vec_3)) - cor1=dot_product(u_node,e_vec_1) - cor2=dot_product(u_node,e_vec_2) - cor3=dot_product(u_node,e_vec_3) - cor4=dot_product(u_node,e_vec_3) - if (cor1 ele_nodes(limiting_t, ele) + do i=1, size(nodelist) + tracer_val(i)=node_val(limiting_t,nodelist(i)) + end do + mean_val=sum(tracer_val)/float(size(nodelist)) + ! Get the values needed for calculating the bounds + do row=1,rows + do column=1,columns + local_values(row,column)=node_val(limiting_t, nodes_array(node,row,column)) + end do + ! Adjust values depending on options + if (midpoint.and.(.not.extrapolate)) then + local_values(row,3) = (1.0-beta)*local_values(row,2)+beta*local_values(row,3) + else if (midpoint.and.extrapolate) then + local_values(row,3) = (1.0-beta)*local_values(row,2)+beta*local_values(row,3) + ! Extrapolate using the gradients of the neighbouring element to form our extra value + + ! 1st, work out the direction in which we want to extrapolate, e_vec_1 + e_vec_1=node_val(dg_position,node)-node_val(dg_position,nodes_array(node,row,1)) + ! Work out the distance to exprapolate + e_dist=sqrt(sum(e_vec_1(:)**2)) + ! Turn this into a unit vector + e_vec_1=e_vec_1/e_dist + + call transform_to_physical(dg_position, node_ele(limiting_t, nodes_array(node,row,2)), & + ele_shape(limiting_t,node_ele(limiting_t, nodes_array(node,row,2))), dshape=dt_t) + + grad_t=ele_grad_at_quad(limiting_t, node_ele(limiting_t, node), dt_t) + + ! Calculate the gradient in the desired direction + ! Note that grad_t will be the same at all gauss points in the linear element case + grad=dot_product(grad_t(1,:),e_vec_1) + + local_values(row,4) = local_values(row,2)+beta*grad*e_dist + end if + if (upwind) then + u_node=node_val(u, node) + mod_u=sqrt(dot_product(u_node,u_node)) + u_node=u_node/mod_u + e_vec_2=e_vec_1 + e_vec_1=-e_vec_1 + e_vec_3=node_val(dg_position,nodes_array(node,row,3))-node_val(dg_position,node) + e_vec_3=e_vec_3/sqrt(dot_product(e_vec_3,e_vec_3)) + cor1=dot_product(u_node,e_vec_1) + cor2=dot_product(u_node,e_vec_2) + cor3=dot_product(u_node,e_vec_3) + cor4=dot_product(u_node,e_vec_3) + if (cor1mean_val) node_min=mean_val + call set(lowerbound, node, node_min) + call set(upperbound, node, node_max) end do - ! Calculate and set the bounds - line_max(1)=maxval(local_values(1,:)) - line_min(1)=minval(local_values(1,:)) - line_max(2)=maxval(local_values(2,:)) - line_min(2)=minval(local_values(2,:)) - node_max=minval(line_max) - node_min=maxval(line_min) - if (node_maxmean_val) node_min=mean_val - call set(lowerbound, node, node_min) - call set(upperbound, node, node_max) - end do - - call bound_field_diffuse(t, upperbound, lowerbound, mass, lumped_mass, inverse_lumped_mass) - - deallocate (neighbouring_nodes) - call deallocate(inverse_lumped_mass) - call deallocate(upperbound) - call deallocate(lowerbound) - if (extrapolate) then - call deallocate(dg_position) - deallocate (e_vec_1, dt_t, grad_t) - end if - - end subroutine limit_fpn + + call bound_field_diffuse(t, upperbound, lowerbound, mass, lumped_mass, inverse_lumped_mass) + + deallocate (neighbouring_nodes) + call deallocate(inverse_lumped_mass) + call deallocate(upperbound) + call deallocate(lowerbound) + if (extrapolate) then + call deallocate(dg_position) + deallocate (e_vec_1, dt_t, grad_t) + end if + + end subroutine limit_fpn end module slope_limiters_dg diff --git a/assemble/Solenoidal_interpolation.F90 b/assemble/Solenoidal_interpolation.F90 index 859e6607a8..2f9492a541 100644 --- a/assemble/Solenoidal_interpolation.F90 +++ b/assemble/Solenoidal_interpolation.F90 @@ -4,362 +4,362 @@ module solenoidal_interpolation_module - use fldebug - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils - use spud - use sparse_tools - use vector_tools - use tensors - use element_numbering, only: FAMILY_SIMPLEX - use transform_elements - use linked_lists - use supermesh_construction - use fetools - use fields - use state_module - use field_options, only : complete_field_path - use sparsity_patterns - use boundary_conditions - use interpolation_module - use sparse_matrices_fields - use solvers - use fefields - use dgtools - use assemble_cmc, only: assemble_cmc_dg, repair_stiff_nodes,& - zero_stiff_nodes, assemble_masslumped_cmc - use boundary_conditions_from_options - use divergence_matrix_cv, only: assemble_divergence_matrix_cv - use divergence_matrix_cg, only: assemble_divergence_matrix_cg - use momentum_cg, only: correct_masslumped_velocity, add_kmk_matrix, add_kmk_rhs, assemble_kmk_matrix - use momentum_dg, only: correct_velocity_dg - implicit none - - private - public :: solenoidal_interpolation - - interface solenoidal_interpolation - module procedure solenoidal_interpolation_state, solenoidal_interpolation_fields - end interface - - contains - - subroutine solenoidal_interpolation_state(state) - type(state_type), intent(inout) :: state - - type(vector_field), pointer :: v_field - type(vector_field), pointer :: coordinate - type(scalar_field), pointer :: s_field - type(mesh_type), pointer :: lagrange_mesh - - character(len=FIELD_NAME_LEN) :: mesh_name, update_field_name - integer :: stat, i - - coordinate => extract_vector_field(state, "Coordinate") - - do i = 1, vector_field_count(state) - v_field => extract_vector_field(state, i) - if(trim(v_field%name)=="Coordinate") cycle - - if(have_option(trim(complete_field_path(v_field%option_path, stat=stat))//& - "/enforce_discrete_properties/solenoidal/lagrange_multiplier/update_scalar_field")) then - call get_option(trim(complete_field_path(v_field%option_path, stat=stat))//& - "/enforce_discrete_properties/solenoidal/lagrange_multiplier/update_scalar_field/name", & - update_field_name) - s_field=> extract_scalar_field(state, trim(update_field_name)) - else - s_field=>null() - end if - - call get_option(trim(complete_field_path(v_field%option_path, stat=stat))//& - "/enforce_discrete_properties/solenoidal/lagrange_multiplier/mesh/name", & - mesh_name) - lagrange_mesh=>extract_mesh(state, trim(mesh_name)) - if(associated(s_field)) then - assert(s_field%mesh%name==mesh_name) - end if + use fldebug + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils + use spud + use sparse_tools + use vector_tools + use tensors + use element_numbering, only: FAMILY_SIMPLEX + use transform_elements + use linked_lists + use supermesh_construction + use fetools + use fields + use state_module + use field_options, only : complete_field_path + use sparsity_patterns + use boundary_conditions + use interpolation_module + use sparse_matrices_fields + use solvers + use fefields + use dgtools + use assemble_cmc, only: assemble_cmc_dg, repair_stiff_nodes,& + zero_stiff_nodes, assemble_masslumped_cmc + use boundary_conditions_from_options + use divergence_matrix_cv, only: assemble_divergence_matrix_cv + use divergence_matrix_cg, only: assemble_divergence_matrix_cg + use momentum_cg, only: correct_masslumped_velocity, add_kmk_matrix, add_kmk_rhs, assemble_kmk_matrix + use momentum_dg, only: correct_velocity_dg + implicit none + + private + public :: solenoidal_interpolation + + interface solenoidal_interpolation + module procedure solenoidal_interpolation_state, solenoidal_interpolation_fields + end interface + +contains + + subroutine solenoidal_interpolation_state(state) + type(state_type), intent(inout) :: state + + type(vector_field), pointer :: v_field + type(vector_field), pointer :: coordinate + type(scalar_field), pointer :: s_field + type(mesh_type), pointer :: lagrange_mesh + + character(len=FIELD_NAME_LEN) :: mesh_name, update_field_name + integer :: stat, i + + coordinate => extract_vector_field(state, "Coordinate") + + do i = 1, vector_field_count(state) + v_field => extract_vector_field(state, i) + if(trim(v_field%name)=="Coordinate") cycle + + if(have_option(trim(complete_field_path(v_field%option_path, stat=stat))//& + "/enforce_discrete_properties/solenoidal/lagrange_multiplier/update_scalar_field")) then + call get_option(trim(complete_field_path(v_field%option_path, stat=stat))//& + "/enforce_discrete_properties/solenoidal/lagrange_multiplier/update_scalar_field/name", & + update_field_name) + s_field=> extract_scalar_field(state, trim(update_field_name)) + else + s_field=>null() + end if + + call get_option(trim(complete_field_path(v_field%option_path, stat=stat))//& + "/enforce_discrete_properties/solenoidal/lagrange_multiplier/mesh/name", & + mesh_name) + lagrange_mesh=>extract_mesh(state, trim(mesh_name)) + if(associated(s_field)) then + assert(s_field%mesh%name==mesh_name) + end if + + call solenoidal_interpolation(v_field, coordinate, & + & lagrange_mesh, s_field=s_field) - call solenoidal_interpolation(v_field, coordinate, & - & lagrange_mesh, s_field=s_field) - - end do - - end subroutine solenoidal_interpolation_state + end do - subroutine solenoidal_interpolation_fields(v_field, coordinate, & - lagrange_mesh, s_field) + end subroutine solenoidal_interpolation_state - type(vector_field), intent(inout) :: coordinate - type(vector_field), intent(inout) :: v_field - type(mesh_type), intent(inout) :: lagrange_mesh + subroutine solenoidal_interpolation_fields(v_field, coordinate, & + lagrange_mesh, s_field) - type(scalar_field), pointer :: s_field + type(vector_field), intent(inout) :: coordinate + type(vector_field), intent(inout) :: v_field + type(mesh_type), intent(inout) :: lagrange_mesh - logical :: dg, lump_mass, lump_on_submesh, div_cv, div_cg, apply_kmk - integer :: dim, j - real :: dt + type(scalar_field), pointer :: s_field - type(block_csr_matrix), pointer :: ct_m - type(block_csr_matrix), pointer :: ctp_m - type(scalar_field) :: ct_rhs, kmk_rhs - type(csr_sparsity) :: ct_m_sparsity, cmc_m_sparsity - type(csr_matrix) :: cmc_m - type(block_csr_matrix) :: inverse_field_mass - type(scalar_field) :: field_lumped_mass - type(vector_field) :: inverse_field_lumped_mass_vector + logical :: dg, lump_mass, lump_on_submesh, div_cv, div_cg, apply_kmk + integer :: dim, j + real :: dt - ! This is the object of our desires: - ! lagrange is the Lagrange multiplier that - ! ensures solenoidality of the resulting interpolant - type(scalar_field) :: lagrange + type(block_csr_matrix), pointer :: ct_m + type(block_csr_matrix), pointer :: ctp_m + type(scalar_field) :: ct_rhs, kmk_rhs + type(csr_sparsity) :: ct_m_sparsity, cmc_m_sparsity + type(csr_matrix) :: cmc_m + type(block_csr_matrix) :: inverse_field_mass + type(scalar_field) :: field_lumped_mass + type(vector_field) :: inverse_field_lumped_mass_vector - ! The right hand side of this devilish equation: - type(scalar_field) :: projec_rhs + ! This is the object of our desires: + ! lagrange is the Lagrange multiplier that + ! ensures solenoidality of the resulting interpolant + type(scalar_field) :: lagrange - type(state_type) :: local_state + ! The right hand side of this devilish equation: + type(scalar_field) :: projec_rhs - character(len=OPTION_PATH_LEN) :: l_option_path + type(state_type) :: local_state - type(ilist) :: stiff_nodes_list - logical :: stiff_nodes_repair + character(len=OPTION_PATH_LEN) :: l_option_path - ! for a CG Lagrange multiplier are we testing the divergence with the CV dual - logical :: cg_lagrange_cv_test_divergence + type(ilist) :: stiff_nodes_list + logical :: stiff_nodes_repair - call insert(local_state, coordinate, "Coordinate") + ! for a CG Lagrange multiplier are we testing the divergence with the CV dual + logical :: cg_lagrange_cv_test_divergence - l_option_path=trim(complete_field_path(v_field%option_path))//"/enforce_discrete_properties/solenoidal" + call insert(local_state, coordinate, "Coordinate") - dim = mesh_dim(v_field) + l_option_path=trim(complete_field_path(v_field%option_path))//"/enforce_discrete_properties/solenoidal" - if(associated(s_field)) then - assert(trim(s_field%mesh%name) == trim(lagrange_mesh%name)) - end if + dim = mesh_dim(v_field) - dg = (continuity(v_field) < 0) + if(associated(s_field)) then + assert(trim(s_field%mesh%name) == trim(lagrange_mesh%name)) + end if - lump_mass = have_option(trim(l_option_path)//& - "/interpolated_field/discontinuous/lump_mass_matrix") & - .or. .not.dg + dg = (continuity(v_field) < 0) - lump_on_submesh = have_option(trim(l_option_path)//& - "/interpolated_field/continuous/lump_mass_matrix/use_submesh") & - .and. .not.dg + lump_mass = have_option(trim(l_option_path)//& + "/interpolated_field/discontinuous/lump_mass_matrix") & + .or. .not.dg - div_cv = have_option(trim(l_option_path) //& - &"/lagrange_multiplier/spatial_discretisation/control_volumes") - div_cg = .not.div_cv + lump_on_submesh = have_option(trim(l_option_path)//& + "/interpolated_field/continuous/lump_mass_matrix/use_submesh") & + .and. .not.dg - cg_lagrange_cv_test_divergence = have_option(trim(l_option_path) //& - &"/lagrange_multiplier/spatial_discretisation/continuous_galerkin/test_divergence_with_cv_dual") + div_cv = have_option(trim(l_option_path) //& + &"/lagrange_multiplier/spatial_discretisation/control_volumes") + div_cg = .not.div_cv - stiff_nodes_repair = have_option(trim(l_option_path) //& - &"/lagrange_multiplier/repair_stiff_nodes") + cg_lagrange_cv_test_divergence = have_option(trim(l_option_path) //& + &"/lagrange_multiplier/spatial_discretisation/continuous_galerkin/test_divergence_with_cv_dual") - apply_kmk = (continuity(lagrange_mesh) >= 0 .and. lagrange_mesh%shape%degree == 1 & - & .and. lagrange_mesh%shape%numbering%family == FAMILY_SIMPLEX .and. & - & continuity(v_field) >= 0 .and. v_field%mesh%shape%degree == 1 & - & .and. v_field%mesh%shape%numbering%family == FAMILY_SIMPLEX .and. & - & .not. have_option(trim(l_option_path) // & - & "/lagrange_multiplier/spatial_discretisation/continuous_galerkin/remove_stabilisation_term") .and. & - & .not. div_cv) + stiff_nodes_repair = have_option(trim(l_option_path) //& + &"/lagrange_multiplier/repair_stiff_nodes") - ct_m_sparsity = make_sparsity(lagrange_mesh, v_field%mesh, "DivergenceSparsity") - allocate(ct_m) - call allocate(ct_m, ct_m_sparsity, blocks=(/1, dim/), name="DivergenceMatrix") - call zero(ct_m) + apply_kmk = (continuity(lagrange_mesh) >= 0 .and. lagrange_mesh%shape%degree == 1 & + & .and. lagrange_mesh%shape%numbering%family == FAMILY_SIMPLEX .and. & + & continuity(v_field) >= 0 .and. v_field%mesh%shape%degree == 1 & + & .and. v_field%mesh%shape%numbering%family == FAMILY_SIMPLEX .and. & + & .not. have_option(trim(l_option_path) // & + & "/lagrange_multiplier/spatial_discretisation/continuous_galerkin/remove_stabilisation_term") .and. & + & .not. div_cv) - ! If CG with CV tested divergence then we need to allocate the - ! left C matrix as it is formed via testing with CV so - if (cg_lagrange_cv_test_divergence) then - allocate(ctp_m) - call allocate(ctp_m, ct_m_sparsity, blocks=(/1, dim/), name="CVTestedDivergenceMatrix") - call zero(ctp_m) - else - ctp_m => ct_m - end if + ct_m_sparsity = make_sparsity(lagrange_mesh, v_field%mesh, "DivergenceSparsity") + allocate(ct_m) + call allocate(ct_m, ct_m_sparsity, blocks=(/1, dim/), name="DivergenceMatrix") + call zero(ct_m) - call allocate(ct_rhs, lagrange_mesh, "DivergenceRHS") - call zero(ct_rhs) + ! If CG with CV tested divergence then we need to allocate the + ! left C matrix as it is formed via testing with CV so + if (cg_lagrange_cv_test_divergence) then + allocate(ctp_m) + call allocate(ctp_m, ct_m_sparsity, blocks=(/1, dim/), name="CVTestedDivergenceMatrix") + call zero(ctp_m) + else + ctp_m => ct_m + end if - cmc_m_sparsity = make_sparsity_transpose(lagrange_mesh, v_field%mesh, "LagrangeProjectionSparsity") - call allocate(cmc_m, cmc_m_sparsity, name="LagrangeProjectionMatrix") - call zero(cmc_m) + call allocate(ct_rhs, lagrange_mesh, "DivergenceRHS") + call zero(ct_rhs) - call allocate(projec_rhs, lagrange_mesh, "LagrangeProjectionRHS") - call zero(projec_rhs) + cmc_m_sparsity = make_sparsity_transpose(lagrange_mesh, v_field%mesh, "LagrangeProjectionSparsity") + call allocate(cmc_m, cmc_m_sparsity, name="LagrangeProjectionMatrix") + call zero(cmc_m) - call allocate(lagrange, lagrange_mesh, "LagrangianMultiplier") - call zero(lagrange) - lagrange%option_path = trim(l_option_path)//"/lagrange_multiplier" + call allocate(projec_rhs, lagrange_mesh, "LagrangeProjectionRHS") + call zero(projec_rhs) - if(apply_kmk) then - call allocate(kmk_rhs, lagrange_mesh, "KMKRHS") - call zero(kmk_rhs) - end if + call allocate(lagrange, lagrange_mesh, "LagrangianMultiplier") + call zero(lagrange) + lagrange%option_path = trim(l_option_path)//"/lagrange_multiplier" - if(lump_mass) then - call allocate(field_lumped_mass, v_field%mesh, "FieldLumpedMass") - call zero(field_lumped_mass) - call allocate(inverse_field_lumped_mass_vector, dim, v_field%mesh, & - "InverseFieldLumpedMassVector") - else if (.not. dg) then - FLExit("Not possible to not lump the mass if not dg.") - end if + if(apply_kmk) then + call allocate(kmk_rhs, lagrange_mesh, "KMKRHS") + call zero(kmk_rhs) + end if - if(div_cg) then if(lump_mass) then - if(lump_on_submesh) then - call assemble_divergence_matrix_cg(ct_m, local_state, ct_rhs=ct_rhs, & - test_mesh=lagrange_mesh, field=v_field, & - option_path = trim(l_option_path)//"/lagrange_multiplier") - ! now get the mass matrix lumped on the submesh - call compute_lumped_mass_on_submesh(local_state, field_lumped_mass) - - else - call assemble_divergence_matrix_cg(ct_m, local_state, ct_rhs=ct_rhs, & - test_mesh=lagrange_mesh, field=v_field, & - option_path = trim(l_option_path)//"/lagrange_multiplier", & - grad_mass_lumped = field_lumped_mass) - end if - elseif(dg) then - call assemble_divergence_matrix_cg(ct_m, local_state, ct_rhs=ct_rhs, & - test_mesh=lagrange_mesh, field=v_field, & - option_path = trim(l_option_path)//"/lagrange_multiplier") - - ! now get the dg inverse mass matrix - call construct_inverse_mass_matrix_dg(inverse_field_mass, v_field, coordinate) + call allocate(field_lumped_mass, v_field%mesh, "FieldLumpedMass") + call zero(field_lumped_mass) + call allocate(inverse_field_lumped_mass_vector, dim, v_field%mesh, & + "InverseFieldLumpedMassVector") + else if (.not. dg) then + FLExit("Not possible to not lump the mass if not dg.") + end if + + if(div_cg) then + if(lump_mass) then + if(lump_on_submesh) then + call assemble_divergence_matrix_cg(ct_m, local_state, ct_rhs=ct_rhs, & + test_mesh=lagrange_mesh, field=v_field, & + option_path = trim(l_option_path)//"/lagrange_multiplier") + ! now get the mass matrix lumped on the submesh + call compute_lumped_mass_on_submesh(local_state, field_lumped_mass) + + else + call assemble_divergence_matrix_cg(ct_m, local_state, ct_rhs=ct_rhs, & + test_mesh=lagrange_mesh, field=v_field, & + option_path = trim(l_option_path)//"/lagrange_multiplier", & + grad_mass_lumped = field_lumped_mass) + end if + elseif(dg) then + call assemble_divergence_matrix_cg(ct_m, local_state, ct_rhs=ct_rhs, & + test_mesh=lagrange_mesh, field=v_field, & + option_path = trim(l_option_path)//"/lagrange_multiplier") + + ! now get the dg inverse mass matrix + call construct_inverse_mass_matrix_dg(inverse_field_mass, v_field, coordinate) + + else + FLExit("Not possible to not lump the mass if not dg.") + end if + + ! If CG lagrange with CV tested divergence then form the other C matrix. + ! This will overwrite the ct_rhs formed above. + if (cg_lagrange_cv_test_divergence) then + + call assemble_divergence_matrix_cv(ctp_m, local_state, ct_rhs=ct_rhs, & + test_mesh=lagrange_mesh, field=v_field) + + end if + + elseif(div_cv) then + if(lump_mass) then + if(lump_on_submesh) then + call compute_lumped_mass_on_submesh(local_state, field_lumped_mass) + else + call compute_lumped_mass(coordinate, field_lumped_mass) + end if + else if(dg) then + call construct_inverse_mass_matrix_dg(inverse_field_mass, v_field, coordinate) + else + FLExit("Not possible to not lump the mass if not dg.") + end if + + call assemble_divergence_matrix_cv(ct_m, local_state, ct_rhs=ct_rhs, & + test_mesh=lagrange_mesh, field=v_field) else - FLExit("Not possible to not lump the mass if not dg.") + ! coding error + FLAbort("Unknown spatial discretisation option for the lagrange multiplier.") end if - ! If CG lagrange with CV tested divergence then form the other C matrix. - ! This will overwrite the ct_rhs formed above. - if (cg_lagrange_cv_test_divergence) then + if(lump_mass) then + call invert(field_lumped_mass) - call assemble_divergence_matrix_cv(ctp_m, local_state, ct_rhs=ct_rhs, & - test_mesh=lagrange_mesh, field=v_field) + do j=1, inverse_field_lumped_mass_vector%dim + call set(inverse_field_lumped_mass_vector, j, field_lumped_mass) + end do - end if + call apply_dirichlet_conditions_inverse_mass(inverse_field_lumped_mass_vector, v_field) - elseif(div_cv) then - if(lump_mass) then - if(lump_on_submesh) then - call compute_lumped_mass_on_submesh(local_state, field_lumped_mass) - else - call compute_lumped_mass(coordinate, field_lumped_mass) - end if + call assemble_masslumped_cmc(cmc_m, ctp_m, inverse_field_lumped_mass_vector, ct_m) else if(dg) then - call construct_inverse_mass_matrix_dg(inverse_field_mass, v_field, coordinate) + call assemble_cmc_dg(cmc_m, ctp_m, ct_m, inverse_field_mass) else - FLExit("Not possible to not lump the mass if not dg.") + FLExit("Not possible to not lump the mass if not dg.") end if - call assemble_divergence_matrix_cv(ct_m, local_state, ct_rhs=ct_rhs, & - test_mesh=lagrange_mesh, field=v_field) + if(stiff_nodes_repair) then + call repair_stiff_nodes(cmc_m, stiff_nodes_list) + end if - else - ! coding error - FLAbort("Unknown spatial discretisation option for the lagrange multiplier.") - end if + call mult(projec_rhs, ctp_m, v_field) - if(lump_mass) then - call invert(field_lumped_mass) + if(apply_kmk) then + ! a hack to make sure the appropriate meshes are available for the + ! construction of the sparsity + call insert(local_state, lagrange, name="Pressure") + call insert(local_state, v_field, name="Velocity") + call insert(local_state, lagrange, name="Pressure") + call insert(local_state, v_field, name="Velocity") + ! end of hack... you can look again now - do j=1, inverse_field_lumped_mass_vector%dim - call set(inverse_field_lumped_mass_vector, j, field_lumped_mass) - end do + ewrite(2,*) "Assembling P1-P1 stabilisation" + call assemble_kmk_matrix(local_state, lagrange_mesh, coordinate, theta_pg=1.0) + call add_kmk_matrix(local_state, cmc_m) - call apply_dirichlet_conditions_inverse_mass(inverse_field_lumped_mass_vector, v_field) + if(associated(s_field)) then + ! Should the timestep be passed in here? not sure + call get_option("/timestepping/timestep", dt) + call add_kmk_rhs(local_state, kmk_rhs, s_field, dt) + end if - call assemble_masslumped_cmc(cmc_m, ctp_m, inverse_field_lumped_mass_vector, ct_m) - else if(dg) then - call assemble_cmc_dg(cmc_m, ctp_m, ct_m, inverse_field_mass) - else - FLExit("Not possible to not lump the mass if not dg.") - end if + ! clean up our mess + call remove_scalar_field(local_state, name="Pressure") + call remove_vector_field(local_state, name="Velocity") + + call addto(projec_rhs, kmk_rhs) + end if - if(stiff_nodes_repair) then - call repair_stiff_nodes(cmc_m, stiff_nodes_list) - end if + call scale(projec_rhs, -1.0) + call addto(projec_rhs, ct_rhs) - call mult(projec_rhs, ctp_m, v_field) + call impose_reference_pressure_node(cmc_m, projec_rhs, coordinate, trim(l_option_path)//"/lagrange_multiplier") - if(apply_kmk) then - ! a hack to make sure the appropriate meshes are available for the - ! construction of the sparsity - call insert(local_state, lagrange, name="Pressure") - call insert(local_state, v_field, name="Velocity") - call insert(local_state, lagrange, name="Pressure") - call insert(local_state, v_field, name="Velocity") - ! end of hack... you can look again now + if(stiff_nodes_repair) then + call zero_stiff_nodes(projec_rhs, stiff_nodes_list) + end if - ewrite(2,*) "Assembling P1-P1 stabilisation" - call assemble_kmk_matrix(local_state, lagrange_mesh, coordinate, theta_pg=1.0) - call add_kmk_matrix(local_state, cmc_m) + call petsc_solve(lagrange, cmc_m, projec_rhs) if(associated(s_field)) then - ! Should the timestep be passed in here? not sure - call get_option("/timestepping/timestep", dt) - call add_kmk_rhs(local_state, kmk_rhs, s_field, dt) + call addto(s_field, lagrange) + end if + + if(lump_mass) then + call correct_masslumped_velocity(v_field, inverse_field_lumped_mass_vector, ct_m, lagrange) + else if(dg) then + call correct_velocity_dg(v_field, inverse_field_mass, ct_m, lagrange) + else + FLExit("Not possible to not lump the mass if not dg.") + end if + + call deallocate(ct_m_sparsity) + call deallocate(ct_m) + deallocate(ct_m) + call deallocate(ct_rhs) + call deallocate(cmc_m_sparsity) + call deallocate(cmc_m) + call deallocate(projec_rhs) + call deallocate(lagrange) + if (cg_lagrange_cv_test_divergence) then + call deallocate(ctp_m) + deallocate(ctp_m) + end if + if(apply_kmk) then + call deallocate(kmk_rhs) + end if + if(lump_mass) then + call deallocate(field_lumped_mass) + call deallocate(inverse_field_lumped_mass_vector) + else if(dg) then + call deallocate(inverse_field_mass) + else + FLExit("Not possible to not lump the mass if not dg.") end if + call deallocate(local_state) - ! clean up our mess - call remove_scalar_field(local_state, name="Pressure") - call remove_vector_field(local_state, name="Velocity") - - call addto(projec_rhs, kmk_rhs) - end if - - call scale(projec_rhs, -1.0) - call addto(projec_rhs, ct_rhs) - - call impose_reference_pressure_node(cmc_m, projec_rhs, coordinate, trim(l_option_path)//"/lagrange_multiplier") - - if(stiff_nodes_repair) then - call zero_stiff_nodes(projec_rhs, stiff_nodes_list) - end if - - call petsc_solve(lagrange, cmc_m, projec_rhs) - - if(associated(s_field)) then - call addto(s_field, lagrange) - end if - - if(lump_mass) then - call correct_masslumped_velocity(v_field, inverse_field_lumped_mass_vector, ct_m, lagrange) - else if(dg) then - call correct_velocity_dg(v_field, inverse_field_mass, ct_m, lagrange) - else - FLExit("Not possible to not lump the mass if not dg.") - end if - - call deallocate(ct_m_sparsity) - call deallocate(ct_m) - deallocate(ct_m) - call deallocate(ct_rhs) - call deallocate(cmc_m_sparsity) - call deallocate(cmc_m) - call deallocate(projec_rhs) - call deallocate(lagrange) - if (cg_lagrange_cv_test_divergence) then - call deallocate(ctp_m) - deallocate(ctp_m) - end if - if(apply_kmk) then - call deallocate(kmk_rhs) - end if - if(lump_mass) then - call deallocate(field_lumped_mass) - call deallocate(inverse_field_lumped_mass_vector) - else if(dg) then - call deallocate(inverse_field_mass) - else - FLExit("Not possible to not lump the mass if not dg.") - end if - call deallocate(local_state) - - end subroutine + end subroutine end module solenoidal_interpolation_module diff --git a/assemble/State_Matrices.F90 b/assemble/State_Matrices.F90 index 62716cedac..38a34ccdc6 100644 --- a/assemble/State_Matrices.F90 +++ b/assemble/State_Matrices.F90 @@ -26,388 +26,388 @@ ! USA #include "fdebug.h" module state_matrices_module - !!< Module containing general tools for discretising Finite Element problems. - - use global_parameters, only: FIELD_NAME_LEN - use spud - use futils, only: present_and_true - use eventcounter - use sparse_tools - use fields - use state_module - use sparsity_patterns_meshes - use field_options - use divergence_matrix_cv, only: assemble_divergence_matrix_cv - use divergence_matrix_cg, only: assemble_divergence_matrix_cg - use gradient_matrix_cg, only: assemble_gradient_matrix_cg - implicit none - - interface get_divergence_matrix_cv - module procedure get_divergence_matrix_cv_single_state, get_divergence_matrix_cv_multiple_states - end interface get_divergence_matrix_cv - - interface get_pressure_poisson_matrix - module procedure get_pressure_poisson_matrix_single_state, get_pressure_poisson_matrix_multiple_states - end interface get_pressure_poisson_matrix - - interface get_pressure_stabilisation_matrix - module procedure get_pressure_stabilisation_matrix_single_state, & - get_pressure_stabilisation_matrix_multiple_states - end interface get_pressure_stabilisation_matrix - - interface get_velocity_divergence_matrix - module procedure get_velocity_divergence_matrix_single_state, get_velocity_divergence_matrix_multiple_states - end interface get_velocity_divergence_matrix - - private - public :: get_divergence_matrix_cv, get_pressure_poisson_matrix, & - get_pressure_stabilisation_matrix, get_velocity_divergence_matrix, & - get_hydrostatic_pressure_cg_matrix, get_vertical_balance_pressure_matrix + !!< Module containing general tools for discretising Finite Element problems. + + use global_parameters, only: FIELD_NAME_LEN + use spud + use futils, only: present_and_true + use eventcounter + use sparse_tools + use fields + use state_module + use sparsity_patterns_meshes + use field_options + use divergence_matrix_cv, only: assemble_divergence_matrix_cv + use divergence_matrix_cg, only: assemble_divergence_matrix_cg + use gradient_matrix_cg, only: assemble_gradient_matrix_cg + implicit none + + interface get_divergence_matrix_cv + module procedure get_divergence_matrix_cv_single_state, get_divergence_matrix_cv_multiple_states + end interface get_divergence_matrix_cv + + interface get_pressure_poisson_matrix + module procedure get_pressure_poisson_matrix_single_state, get_pressure_poisson_matrix_multiple_states + end interface get_pressure_poisson_matrix + + interface get_pressure_stabilisation_matrix + module procedure get_pressure_stabilisation_matrix_single_state, & + get_pressure_stabilisation_matrix_multiple_states + end interface get_pressure_stabilisation_matrix + + interface get_velocity_divergence_matrix + module procedure get_velocity_divergence_matrix_single_state, get_velocity_divergence_matrix_multiple_states + end interface get_velocity_divergence_matrix + + private + public :: get_divergence_matrix_cv, get_pressure_poisson_matrix, & + get_pressure_stabilisation_matrix, get_velocity_divergence_matrix, & + get_hydrostatic_pressure_cg_matrix, get_vertical_balance_pressure_matrix contains - function get_divergence_matrix_cv_single_state(state, test_mesh, field, & - div_rhs, exclude_boundaries) result(div) - !!< extracts the cv divergence matrix from state or creates it if it doesn't find it - type(block_csr_matrix), pointer :: div - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: test_mesh - type(vector_field), intent(inout) :: field - type(scalar_field), intent(inout), optional :: div_rhs - logical, intent(in), optional :: exclude_boundaries - - type(state_type), dimension(1) :: states - - states=(/state/) - div=>get_divergence_matrix_cv(states, test_mesh, field, div_rhs, exclude_boundaries) - state = states(1) - - end function get_divergence_matrix_cv_single_state - - function get_divergence_matrix_cv_multiple_states(states, test_mesh, field, & - div_rhs, exclude_boundaries) result(div) - !!< extracts the cv divergence matrix from state or creates it if it doesn't find it - type(block_csr_matrix), pointer :: div - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: test_mesh - type(vector_field), intent(inout) :: field - type(scalar_field), intent(inout), optional :: div_rhs - logical, intent(in), optional :: exclude_boundaries - - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(block_csr_matrix) :: temp_div - type(csr_sparsity), pointer :: temp_div_sparsity - - integer, save :: last_mesh_movement = -1 - - if(present_and_true(exclude_boundaries)) then - name = trim(test_mesh%name)//trim(field%mesh%name)//"CVDivergenceMatrixNoBoundaries" - else - name = trim(test_mesh%name)//trim(field%mesh%name)//"CVDivergenceMatrix" - end if - - div => extract_block_csr_matrix(states, trim(name), stat) - - if(stat/=0) then - ! couldn't find the matrix in state so we need to allocate and assemble it - ! if div_rhs is present then we can assemble it here too (unless you're - ! excluding boundaries of course, in which case its strange you've passed in div_rhs!) - temp_div_sparsity=>get_csr_sparsity_firstorder(states, test_mesh, field%mesh) - call allocate(temp_div, temp_div_sparsity, (/1, field%dim/), name=trim(name)) - - call assemble_divergence_matrix_cv(temp_div, states(1), ct_rhs=div_rhs, & - test_mesh=test_mesh, field=field, & - exclude_boundaries=exclude_boundaries) - - call insert(states, temp_div, trim(name)) - call deallocate(temp_div) - - div => extract_block_csr_matrix(states, trim(name)) + function get_divergence_matrix_cv_single_state(state, test_mesh, field, & + div_rhs, exclude_boundaries) result(div) + !!< extracts the cv divergence matrix from state or creates it if it doesn't find it + type(block_csr_matrix), pointer :: div + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: test_mesh + type(vector_field), intent(inout) :: field + type(scalar_field), intent(inout), optional :: div_rhs + logical, intent(in), optional :: exclude_boundaries + + type(state_type), dimension(1) :: states + + states=(/state/) + div=>get_divergence_matrix_cv(states, test_mesh, field, div_rhs, exclude_boundaries) + state = states(1) + + end function get_divergence_matrix_cv_single_state + + function get_divergence_matrix_cv_multiple_states(states, test_mesh, field, & + div_rhs, exclude_boundaries) result(div) + !!< extracts the cv divergence matrix from state or creates it if it doesn't find it + type(block_csr_matrix), pointer :: div + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: test_mesh + type(vector_field), intent(inout) :: field + type(scalar_field), intent(inout), optional :: div_rhs + logical, intent(in), optional :: exclude_boundaries + + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(block_csr_matrix) :: temp_div + type(csr_sparsity), pointer :: temp_div_sparsity + + integer, save :: last_mesh_movement = -1 + + if(present_and_true(exclude_boundaries)) then + name = trim(test_mesh%name)//trim(field%mesh%name)//"CVDivergenceMatrixNoBoundaries" + else + name = trim(test_mesh%name)//trim(field%mesh%name)//"CVDivergenceMatrix" + end if + + div => extract_block_csr_matrix(states, trim(name), stat) + + if(stat/=0) then + ! couldn't find the matrix in state so we need to allocate and assemble it + ! if div_rhs is present then we can assemble it here too (unless you're + ! excluding boundaries of course, in which case its strange you've passed in div_rhs!) + temp_div_sparsity=>get_csr_sparsity_firstorder(states, test_mesh, field%mesh) + call allocate(temp_div, temp_div_sparsity, (/1, field%dim/), name=trim(name)) + + call assemble_divergence_matrix_cv(temp_div, states(1), ct_rhs=div_rhs, & + test_mesh=test_mesh, field=field, & + exclude_boundaries=exclude_boundaries) + + call insert(states, temp_div, trim(name)) + call deallocate(temp_div) + + div => extract_block_csr_matrix(states, trim(name)) + + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + else if (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) then + ! we found the matrix in state but the mesh has moved so we need to reassemble it + call assemble_divergence_matrix_cv(div, states(1), ct_rhs=div_rhs, & + test_mesh=test_mesh, field=field, & + exclude_boundaries=exclude_boundaries) + + ! and record the mesh movement index during which we've just reassembled the matrix + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + else if (present(div_rhs)) then + ! found the div matrix but div_rhs always needs to be updated so call the assembly + ! but tell it not to reassemble the div matrix. + call assemble_divergence_matrix_cv(div, states(1), ct_rhs=div_rhs, & + test_mesh=test_mesh, field=field, & + get_ct=.false., exclude_boundaries=exclude_boundaries) + + ! not updating the matrix so no need to increment the mesh movement index + end if + + end function get_divergence_matrix_cv_multiple_states + + function get_pressure_poisson_matrix_single_state(state, get_cmc) result(cmc_m) + !!< extracts the cmc matrix from state, + !!< if it fails to find it it returns get_cmc=.true. to indicate that it needs assembling + type(csr_matrix), pointer :: cmc_m + type(state_type), intent(inout) :: state + logical, intent(inout), optional :: get_cmc + + type(state_type), dimension(1) :: states + + states = (/state/) + cmc_m => get_pressure_poisson_matrix(states, get_cmc=get_cmc) + state = states(1) + + ! In multi-phase simulations, M and C^T depend on the phase volume fraction, + ! so we have to re-assemble CMC each time since PhaseVolumeFraction can change. + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + if(present(get_cmc)) get_cmc = .true. + end if + + end function get_pressure_poisson_matrix_single_state + + function get_pressure_poisson_matrix_multiple_states(states, get_cmc) result(cmc_m) + !!< extracts the cmc matrix from states, + !!< if it fails to find it it returns get_cmc=.true. to indicate that it needs assembling + type(csr_matrix), pointer :: cmc_m + type(state_type), dimension(:), intent(inout) :: states + logical, intent(inout), optional :: get_cmc + + integer :: stat + type(mesh_type), pointer :: p_mesh, u_mesh + type(csr_sparsity), pointer :: cmc_sparsity + type(csr_matrix) :: temp_cmc_m + + integer, save :: last_mesh_movement = -1 + + + if(present(get_cmc)) get_cmc = .false. + cmc_m => extract_csr_matrix(states, "PressurePoissonMatrix", stat) + + if(stat/=0) then + if(present(get_cmc)) get_cmc = .true. + + p_mesh => extract_pressure_mesh(states) + u_mesh => extract_velocity_mesh(states) + + cmc_sparsity => get_csr_sparsity_secondorder(states, p_mesh, u_mesh) - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - else if (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) then - ! we found the matrix in state but the mesh has moved so we need to reassemble it - call assemble_divergence_matrix_cv(div, states(1), ct_rhs=div_rhs, & - test_mesh=test_mesh, field=field, & - exclude_boundaries=exclude_boundaries) - - ! and record the mesh movement index during which we've just reassembled the matrix - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - else if (present(div_rhs)) then - ! found the div matrix but div_rhs always needs to be updated so call the assembly - ! but tell it not to reassemble the div matrix. - call assemble_divergence_matrix_cv(div, states(1), ct_rhs=div_rhs, & - test_mesh=test_mesh, field=field, & - get_ct=.false., exclude_boundaries=exclude_boundaries) - - ! not updating the matrix so no need to increment the mesh movement index - end if - - end function get_divergence_matrix_cv_multiple_states - - function get_pressure_poisson_matrix_single_state(state, get_cmc) result(cmc_m) - !!< extracts the cmc matrix from state, - !!< if it fails to find it it returns get_cmc=.true. to indicate that it needs assembling - type(csr_matrix), pointer :: cmc_m - type(state_type), intent(inout) :: state - logical, intent(inout), optional :: get_cmc - - type(state_type), dimension(1) :: states - - states = (/state/) - cmc_m => get_pressure_poisson_matrix(states, get_cmc=get_cmc) - state = states(1) - - ! In multi-phase simulations, M and C^T depend on the phase volume fraction, - ! so we have to re-assemble CMC each time since PhaseVolumeFraction can change. - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - if(present(get_cmc)) get_cmc = .true. - end if - - end function get_pressure_poisson_matrix_single_state - - function get_pressure_poisson_matrix_multiple_states(states, get_cmc) result(cmc_m) - !!< extracts the cmc matrix from states, - !!< if it fails to find it it returns get_cmc=.true. to indicate that it needs assembling - type(csr_matrix), pointer :: cmc_m - type(state_type), dimension(:), intent(inout) :: states - logical, intent(inout), optional :: get_cmc - - integer :: stat - type(mesh_type), pointer :: p_mesh, u_mesh - type(csr_sparsity), pointer :: cmc_sparsity - type(csr_matrix) :: temp_cmc_m + call allocate(temp_cmc_m, cmc_sparsity, name="PressurePoissonMatrix") + call insert(states, temp_cmc_m, name="PressurePoissonMatrix") + call deallocate(temp_cmc_m) - integer, save :: last_mesh_movement = -1 + cmc_m => extract_csr_matrix(states, "PressurePoissonMatrix") + else + ! We found it in state so the only thing that will affect if we need to assemble it + ! is whether the mesh has moved since we last called this subroutine. + ! The actual assembly doesn't take place here though so we don't need to do anything + ! else yet. + if(present(get_cmc)) get_cmc = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) + end if + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - if(present(get_cmc)) get_cmc = .false. - cmc_m => extract_csr_matrix(states, "PressurePoissonMatrix", stat) - - if(stat/=0) then - if(present(get_cmc)) get_cmc = .true. - - p_mesh => extract_pressure_mesh(states) - u_mesh => extract_velocity_mesh(states) - - cmc_sparsity => get_csr_sparsity_secondorder(states, p_mesh, u_mesh) - - call allocate(temp_cmc_m, cmc_sparsity, name="PressurePoissonMatrix") - call insert(states, temp_cmc_m, name="PressurePoissonMatrix") - call deallocate(temp_cmc_m) - - cmc_m => extract_csr_matrix(states, "PressurePoissonMatrix") - else - ! We found it in state so the only thing that will affect if we need to assemble it - ! is whether the mesh has moved since we last called this subroutine. - ! The actual assembly doesn't take place here though so we don't need to do anything - ! else yet. - if(present(get_cmc)) get_cmc = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) - end if - - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - - end function get_pressure_poisson_matrix_multiple_states - - function get_pressure_stabilisation_matrix_single_state(state) result(kmk_m) - !!< extracts the kmk matrix from state, - type(csr_matrix), pointer :: kmk_m - type(state_type), intent(inout) :: state + end function get_pressure_poisson_matrix_multiple_states - type(state_type), dimension(1) :: states + function get_pressure_stabilisation_matrix_single_state(state) result(kmk_m) + !!< extracts the kmk matrix from state, + type(csr_matrix), pointer :: kmk_m + type(state_type), intent(inout) :: state - states = (/state/) - kmk_m => get_pressure_stabilisation_matrix(states) - state = states(1) + type(state_type), dimension(1) :: states - end function get_pressure_stabilisation_matrix_single_state + states = (/state/) + kmk_m => get_pressure_stabilisation_matrix(states) + state = states(1) - function get_pressure_stabilisation_matrix_multiple_states(states) result(kmk_m) - !!< extracts the kmk matrix from states, - type(csr_matrix), pointer :: kmk_m - type(state_type), dimension(:), intent(inout) :: states + end function get_pressure_stabilisation_matrix_single_state - integer :: stat - type(mesh_type), pointer :: p_mesh, u_mesh - type(csr_sparsity), pointer :: cmc_sparsity - type(csr_matrix) :: temp_cmc_m + function get_pressure_stabilisation_matrix_multiple_states(states) result(kmk_m) + !!< extracts the kmk matrix from states, + type(csr_matrix), pointer :: kmk_m + type(state_type), dimension(:), intent(inout) :: states - kmk_m => extract_csr_matrix(states, "PressureStabilisationMatrix", stat) + integer :: stat + type(mesh_type), pointer :: p_mesh, u_mesh + type(csr_sparsity), pointer :: cmc_sparsity + type(csr_matrix) :: temp_cmc_m - if(stat/=0) then - p_mesh => extract_pressure_mesh(states) - u_mesh => extract_velocity_mesh(states) + kmk_m => extract_csr_matrix(states, "PressureStabilisationMatrix", stat) - cmc_sparsity => get_csr_sparsity_secondorder(states, p_mesh, u_mesh) + if(stat/=0) then + p_mesh => extract_pressure_mesh(states) + u_mesh => extract_velocity_mesh(states) - call allocate(temp_cmc_m, cmc_sparsity, name="PressureStabilisationMatrix") - call insert(states, temp_cmc_m, name="PressureStabilisationMatrix") - call deallocate(temp_cmc_m) + cmc_sparsity => get_csr_sparsity_secondorder(states, p_mesh, u_mesh) - kmk_m => extract_csr_matrix(states, "PressureStabilisationMatrix") - end if + call allocate(temp_cmc_m, cmc_sparsity, name="PressureStabilisationMatrix") + call insert(states, temp_cmc_m, name="PressureStabilisationMatrix") + call deallocate(temp_cmc_m) - end function get_pressure_stabilisation_matrix_multiple_states + kmk_m => extract_csr_matrix(states, "PressureStabilisationMatrix") + end if - function get_velocity_divergence_matrix_single_state(state, get_ct, ct_m_name) result(ct_m) - !!< extracts the ct matrix from state, - !!< if it fails to find it it returns get_ct=.true. to indicate that it needs assembling - !!< if ct_m_name is present then that name is used else a default is used. - type(block_csr_matrix), pointer :: ct_m - type(state_type), intent(inout) :: state - logical, intent(inout), optional :: get_ct - character(len=*), intent(in), optional :: ct_m_name + end function get_pressure_stabilisation_matrix_multiple_states - type(state_type), dimension(1) :: states + function get_velocity_divergence_matrix_single_state(state, get_ct, ct_m_name) result(ct_m) + !!< extracts the ct matrix from state, + !!< if it fails to find it it returns get_ct=.true. to indicate that it needs assembling + !!< if ct_m_name is present then that name is used else a default is used. + type(block_csr_matrix), pointer :: ct_m + type(state_type), intent(inout) :: state + logical, intent(inout), optional :: get_ct + character(len=*), intent(in), optional :: ct_m_name - states = (/state/) - ct_m => get_velocity_divergence_matrix(states, get_ct=get_ct, ct_m_name = ct_m_name) - state = states(1) + type(state_type), dimension(1) :: states - ! In multi-phase simulations, C^T depends on the phase volume fraction, - ! so we have to re-assemble C^T each time since PhaseVolumeFraction can change. - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - if(present(get_ct)) get_ct = .true. - end if + states = (/state/) + ct_m => get_velocity_divergence_matrix(states, get_ct=get_ct, ct_m_name = ct_m_name) + state = states(1) - end function get_velocity_divergence_matrix_single_state + ! In multi-phase simulations, C^T depends on the phase volume fraction, + ! so we have to re-assemble C^T each time since PhaseVolumeFraction can change. + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + if(present(get_ct)) get_ct = .true. + end if - function get_velocity_divergence_matrix_multiple_states(states, get_ct, ct_m_name) result(ct_m) - !!< extracts the ct matrix from states, - !!< if it fails to find it it returns get_ct=.true. to indicate that it needs assembling - !!< if ct_m_name is present then that name is used else a default is used. - type(block_csr_matrix), pointer :: ct_m - type(state_type), dimension(:), intent(inout) :: states - logical, intent(inout), optional :: get_ct - character(len=*), intent(in), optional :: ct_m_name + end function get_velocity_divergence_matrix_single_state - integer :: stat, i - type(mesh_type), pointer :: p_mesh, u_mesh - type(vector_field), pointer :: velocity - type(csr_sparsity), pointer :: ct_sparsity - type(block_csr_matrix) :: temp_ct_m - character(len=FIELD_NAME_LEN) :: l_ct_m_name + function get_velocity_divergence_matrix_multiple_states(states, get_ct, ct_m_name) result(ct_m) + !!< extracts the ct matrix from states, + !!< if it fails to find it it returns get_ct=.true. to indicate that it needs assembling + !!< if ct_m_name is present then that name is used else a default is used. + type(block_csr_matrix), pointer :: ct_m + type(state_type), dimension(:), intent(inout) :: states + logical, intent(inout), optional :: get_ct + character(len=*), intent(in), optional :: ct_m_name - integer, save :: last_mesh_movement = -1 + integer :: stat, i + type(mesh_type), pointer :: p_mesh, u_mesh + type(vector_field), pointer :: velocity + type(csr_sparsity), pointer :: ct_sparsity + type(block_csr_matrix) :: temp_ct_m + character(len=FIELD_NAME_LEN) :: l_ct_m_name - ! Form the ct_m_name dependent on interface argument - if (present(ct_m_name)) then - l_ct_m_name = trim(ct_m_name) - else - l_ct_m_name = "VelocityDivergenceMatrix" - end if + integer, save :: last_mesh_movement = -1 - if(present(get_ct)) get_ct = .false. - ct_m => extract_block_csr_matrix(states, trim(l_ct_m_name), stat) + ! Form the ct_m_name dependent on interface argument + if (present(ct_m_name)) then + l_ct_m_name = trim(ct_m_name) + else + l_ct_m_name = "VelocityDivergenceMatrix" + end if - if(stat/=0) then - if(present(get_ct)) get_ct = .true. + if(present(get_ct)) get_ct = .false. + ct_m => extract_block_csr_matrix(states, trim(l_ct_m_name), stat) - p_mesh => extract_pressure_mesh(states) - u_mesh => extract_velocity_mesh(states) - do i = 1, size(states) - velocity => extract_vector_field(states(i), "Velocity", stat) - if(stat==0) exit - end do + if(stat/=0) then + if(present(get_ct)) get_ct = .true. - ct_sparsity => get_csr_sparsity_firstorder(states, p_mesh, u_mesh) + p_mesh => extract_pressure_mesh(states) + u_mesh => extract_velocity_mesh(states) + do i = 1, size(states) + velocity => extract_vector_field(states(i), "Velocity", stat) + if(stat==0) exit + end do + + ct_sparsity => get_csr_sparsity_firstorder(states, p_mesh, u_mesh) + + call allocate(temp_ct_m, ct_sparsity, blocks=(/1,velocity%dim/), name=trim(l_ct_m_name)) + call insert(states, temp_ct_m, name=trim(l_ct_m_name)) + call deallocate(temp_ct_m) + + ct_m => extract_block_csr_matrix(states, trim(l_ct_m_name)) + else + ! just check if we need to reassemble the matrix anyway + if(present(get_ct)) get_ct = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) + end if + + ! record the last time this subroutine was called relative to movements of the mesh + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - call allocate(temp_ct_m, ct_sparsity, blocks=(/1,velocity%dim/), name=trim(l_ct_m_name)) - call insert(states, temp_ct_m, name=trim(l_ct_m_name)) - call deallocate(temp_ct_m) + end function get_velocity_divergence_matrix_multiple_states - ct_m => extract_block_csr_matrix(states, trim(l_ct_m_name)) - else - ! just check if we need to reassemble the matrix anyway - if(present(get_ct)) get_ct = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) - end if + function get_hydrostatic_pressure_cg_matrix(state, assemble_matrix) result(matrix) + !!< extracts the continuous hydrostatic pressure matrix from state, + !!< if it fails to find it it returns assemble_matrix=.true. to indicate that it needs assembling + type(csr_matrix), pointer :: matrix + type(state_type), intent(inout) :: state + logical, intent(inout), optional :: assemble_matrix - ! record the last time this subroutine was called relative to movements of the mesh - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + integer :: stat + type(scalar_field), pointer :: hp + type(csr_sparsity), pointer :: matrix_sparsity + type(csr_matrix) :: temp_matrix - end function get_velocity_divergence_matrix_multiple_states + integer, save :: last_mesh_movement = -1 - function get_hydrostatic_pressure_cg_matrix(state, assemble_matrix) result(matrix) - !!< extracts the continuous hydrostatic pressure matrix from state, - !!< if it fails to find it it returns assemble_matrix=.true. to indicate that it needs assembling - type(csr_matrix), pointer :: matrix - type(state_type), intent(inout) :: state - logical, intent(inout), optional :: assemble_matrix + if(present(assemble_matrix)) assemble_matrix = .false. + matrix => extract_csr_matrix(state, "HydrostaticPressureCGMatrix", stat) - integer :: stat - type(scalar_field), pointer :: hp - type(csr_sparsity), pointer :: matrix_sparsity - type(csr_matrix) :: temp_matrix + if(stat/=0) then + if(present(assemble_matrix)) assemble_matrix = .true. - integer, save :: last_mesh_movement = -1 - - if(present(assemble_matrix)) assemble_matrix = .false. - matrix => extract_csr_matrix(state, "HydrostaticPressureCGMatrix", stat) + hp => extract_scalar_field(state, "HydrostaticPressure") - if(stat/=0) then - if(present(assemble_matrix)) assemble_matrix = .true. + matrix_sparsity => get_csr_sparsity_firstorder(state, hp%mesh, hp%mesh) - hp => extract_scalar_field(state, "HydrostaticPressure") - - matrix_sparsity => get_csr_sparsity_firstorder(state, hp%mesh, hp%mesh) - - call allocate(temp_matrix, matrix_sparsity, name="HydrostaticPressureCGMatrix") - call insert(state, temp_matrix, name="HydrostaticPressureCGMatrix") - call deallocate(temp_matrix) + call allocate(temp_matrix, matrix_sparsity, name="HydrostaticPressureCGMatrix") + call insert(state, temp_matrix, name="HydrostaticPressureCGMatrix") + call deallocate(temp_matrix) - matrix => extract_csr_matrix(state, "HydrostaticPressureCGMatrix") - else - ! We found it in state so the only thing that will affect if we need to assemble it - ! is whether the mesh has moved since we last called this subroutine. - ! The actual assembly doesn't take place here though so we don't need to do anything - ! else yet. - if(present(assemble_matrix)) assemble_matrix = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) - end if + matrix => extract_csr_matrix(state, "HydrostaticPressureCGMatrix") + else + ! We found it in state so the only thing that will affect if we need to assemble it + ! is whether the mesh has moved since we last called this subroutine. + ! The actual assembly doesn't take place here though so we don't need to do anything + ! else yet. + if(present(assemble_matrix)) assemble_matrix = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) + end if - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end function get_hydrostatic_pressure_cg_matrix + end function get_hydrostatic_pressure_cg_matrix - function get_vertical_balance_pressure_matrix(state, assemble_matrix) result(matrix) - !!< extracts the vertical balance pressure matrix from state, - !!< if it fails to find it it returns assemble_matrix=.true. to indicate that it needs assembling - type(csr_matrix), pointer :: matrix - type(state_type), intent(inout) :: state - logical, intent(inout), optional :: assemble_matrix + function get_vertical_balance_pressure_matrix(state, assemble_matrix) result(matrix) + !!< extracts the vertical balance pressure matrix from state, + !!< if it fails to find it it returns assemble_matrix=.true. to indicate that it needs assembling + type(csr_matrix), pointer :: matrix + type(state_type), intent(inout) :: state + logical, intent(inout), optional :: assemble_matrix - integer :: stat - type(scalar_field), pointer :: vbp - type(csr_sparsity), pointer :: matrix_sparsity - type(csr_matrix) :: temp_matrix + integer :: stat + type(scalar_field), pointer :: vbp + type(csr_sparsity), pointer :: matrix_sparsity + type(csr_matrix) :: temp_matrix - integer, save :: last_mesh_movement = -1 + integer, save :: last_mesh_movement = -1 - if(present(assemble_matrix)) assemble_matrix = .false. - matrix => extract_csr_matrix(state, "VerticalBalancePressureMatrix", stat) + if(present(assemble_matrix)) assemble_matrix = .false. + matrix => extract_csr_matrix(state, "VerticalBalancePressureMatrix", stat) - if(stat/=0) then - if(present(assemble_matrix)) assemble_matrix = .true. + if(stat/=0) then + if(present(assemble_matrix)) assemble_matrix = .true. - vbp => extract_scalar_field(state, "VerticalBalancePressure") + vbp => extract_scalar_field(state, "VerticalBalancePressure") - matrix_sparsity => get_csr_sparsity_firstorder(state, vbp%mesh, vbp%mesh) + matrix_sparsity => get_csr_sparsity_firstorder(state, vbp%mesh, vbp%mesh) - call allocate(temp_matrix, matrix_sparsity, name="VerticalBalancePressureMatrix") - call insert(state, temp_matrix, name="VerticalBalancePressureMatrix") - call deallocate(temp_matrix) + call allocate(temp_matrix, matrix_sparsity, name="VerticalBalancePressureMatrix") + call insert(state, temp_matrix, name="VerticalBalancePressureMatrix") + call deallocate(temp_matrix) - matrix => extract_csr_matrix(state, "VerticalBalancePressureMatrix") - else - ! We found it in state so the only thing that will affect if we need to assemble it - ! is whether the mesh has moved since we last called this subroutine. - ! The actual assembly doesn't take place here though so we don't need to do anything - ! else yet. - if(present(assemble_matrix)) assemble_matrix = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) - end if + matrix => extract_csr_matrix(state, "VerticalBalancePressureMatrix") + else + ! We found it in state so the only thing that will affect if we need to assemble it + ! is whether the mesh has moved since we last called this subroutine. + ! The actual assembly doesn't take place here though so we don't need to do anything + ! else yet. + if(present(assemble_matrix)) assemble_matrix = (eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) + end if - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end function get_vertical_balance_pressure_matrix + end function get_vertical_balance_pressure_matrix end module state_matrices_module diff --git a/assemble/Surface_Id_Interleaving.F90 b/assemble/Surface_Id_Interleaving.F90 index e6baee1f96..71cabf1ce6 100644 --- a/assemble/Surface_Id_Interleaving.F90 +++ b/assemble/Surface_Id_Interleaving.F90 @@ -29,147 +29,147 @@ module surface_id_interleaving - use fldebug - use mpi_interfaces - use parallel_tools - use fields + use fldebug + use mpi_interfaces + use parallel_tools + use fields - implicit none + implicit none - private + private - public :: deinterleave_surface_ids, interleave_surface_ids + public :: deinterleave_surface_ids, interleave_surface_ids - interface interleave_surface_ids - module procedure interleave_surface_ids_mesh, interleave_surface_ids_vector - end interface interleave_surface_ids + interface interleave_surface_ids + module procedure interleave_surface_ids_mesh, interleave_surface_ids_vector + end interface interleave_surface_ids - interface deinterleave_surface_ids - module procedure deinterleave_surface_ids_mesh, & + interface deinterleave_surface_ids + module procedure deinterleave_surface_ids_mesh, & & deinterleave_surface_ids_vector - end interface deinterleave_surface_ids + end interface deinterleave_surface_ids contains - subroutine interleave_surface_ids_mesh(mesh, max_coplanar_id) - !!< Interleave all surface ID information for the supplied mesh, and store - !!< it on the boundary IDs + subroutine interleave_surface_ids_mesh(mesh, max_coplanar_id) + !!< Interleave all surface ID information for the supplied mesh, and store + !!< it on the boundary IDs - type(mesh_type), intent(inout) :: mesh - integer, intent(out) :: max_coplanar_id + type(mesh_type), intent(inout) :: mesh + integer, intent(out) :: max_coplanar_id - integer, dimension(surface_element_count(mesh)) :: surface_ids + integer, dimension(surface_element_count(mesh)) :: surface_ids - if(associated(mesh%faces)) then - call interleave_surface_ids(mesh, surface_ids, max_coplanar_id) - if(.not. associated(mesh%faces%boundary_ids)) allocate(mesh%faces%boundary_ids(size(surface_ids))) - mesh%faces%boundary_ids = surface_ids - if(associated(mesh%faces%coplanar_ids)) mesh%faces%coplanar_ids = 0 - end if + if(associated(mesh%faces)) then + call interleave_surface_ids(mesh, surface_ids, max_coplanar_id) + if(.not. associated(mesh%faces%boundary_ids)) allocate(mesh%faces%boundary_ids(size(surface_ids))) + mesh%faces%boundary_ids = surface_ids + if(associated(mesh%faces%coplanar_ids)) mesh%faces%coplanar_ids = 0 + end if - end subroutine interleave_surface_ids_mesh + end subroutine interleave_surface_ids_mesh - subroutine interleave_surface_ids_vector(mesh, interleaved_surface_ids, max_coplanar_id) - !!< Interleave all surface ID information for the supplied mesh. Useful for - !!< handing surface element information to external libraries that expect - !!< only one set of integers. + subroutine interleave_surface_ids_vector(mesh, interleaved_surface_ids, max_coplanar_id) + !!< Interleave all surface ID information for the supplied mesh. Useful for + !!< handing surface element information to external libraries that expect + !!< only one set of integers. - type(mesh_type), intent(in) :: mesh - ! see assert on size below - integer, dimension(:), intent(out) :: interleaved_surface_ids - ! this number needs to be stored, to be able to deinterleave afterwards: - integer, intent(out) :: max_coplanar_id + type(mesh_type), intent(in) :: mesh + ! see assert on size below + integer, dimension(:), intent(out) :: interleaved_surface_ids + ! this number needs to be stored, to be able to deinterleave afterwards: + integer, intent(out) :: max_coplanar_id #ifdef HAVE_MPI - integer :: all_max_coplanar_id + integer :: all_max_coplanar_id #endif - integer :: ierr, max_boundary_id, no_sids - - no_sids = size(interleaved_surface_ids) - ! with internal boundary facets, the interior facets are duplicated with the first - ! copy N<=unique_surface_element_count, and the second copy - ! unique_surface_element_count 0) then - assert(associated(mesh%faces)) - end if - - if(no_sids == 0) then - max_coplanar_id = 0 - else if(associated(mesh%faces%coplanar_ids)) then - max_coplanar_id = maxval(mesh%faces%coplanar_ids) - else - max_coplanar_id = 0 - end if - if(isparallel()) then + integer :: ierr, max_boundary_id, no_sids + + no_sids = size(interleaved_surface_ids) + ! with internal boundary facets, the interior facets are duplicated with the first + ! copy N<=unique_surface_element_count, and the second copy + ! unique_surface_element_count 0) then + assert(associated(mesh%faces)) + end if + + if(no_sids == 0) then + max_coplanar_id = 0 + else if(associated(mesh%faces%coplanar_ids)) then + max_coplanar_id = maxval(mesh%faces%coplanar_ids) + else + max_coplanar_id = 0 + end if + if(isparallel()) then #ifdef HAVE_MPI - ! Max. coplanar_id must be global to ensure consistent global surface ids - call mpi_allreduce(max_coplanar_id, all_max_coplanar_id, 1, getpinteger(), MPI_MAX, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - max_coplanar_id = all_max_coplanar_id + ! Max. coplanar_id must be global to ensure consistent global surface ids + call mpi_allreduce(max_coplanar_id, all_max_coplanar_id, 1, getpinteger(), MPI_MAX, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + max_coplanar_id = all_max_coplanar_id #endif - end if - - if(no_sids == 0) then - max_boundary_id = 0 - else if(associated(mesh%faces%boundary_ids)) then - max_boundary_id = maxval(mesh%faces%boundary_ids) - else - max_boundary_id = 0 - end if - - ! Check if we run over the limit of unique combinations for surface IDs - ! (not necessarily global as the check may fail on any process) - if(max_boundary_id + 1 > huge(max_coplanar_id) / max(max_coplanar_id, 1)) then - ewrite(-1, "(a,i0)") "Max coplanar ID = ", max_coplanar_id - ewrite(-1, "(a,i0)") "Max boundary ID = ", max_boundary_id - ewrite(-1, "(a,i0)") "Max integer = ", huge(max_coplanar_id) - FLAbort("Too many different coplanar and/or boundary ids") - end if - - interleaved_surface_ids = 0 - if(no_sids > 0) then - if(associated(mesh%faces%boundary_ids)) then - interleaved_surface_ids = mesh%faces%boundary_ids(1:no_sids) * (max_coplanar_id + 1) end if - if(associated(mesh%faces%coplanar_ids)) then - interleaved_surface_ids = interleaved_surface_ids + mesh%faces%coplanar_ids(1:no_sids) + + if(no_sids == 0) then + max_boundary_id = 0 + else if(associated(mesh%faces%boundary_ids)) then + max_boundary_id = maxval(mesh%faces%boundary_ids) + else + max_boundary_id = 0 + end if + + ! Check if we run over the limit of unique combinations for surface IDs + ! (not necessarily global as the check may fail on any process) + if(max_boundary_id + 1 > huge(max_coplanar_id) / max(max_coplanar_id, 1)) then + ewrite(-1, "(a,i0)") "Max coplanar ID = ", max_coplanar_id + ewrite(-1, "(a,i0)") "Max boundary ID = ", max_boundary_id + ewrite(-1, "(a,i0)") "Max integer = ", huge(max_coplanar_id) + FLAbort("Too many different coplanar and/or boundary ids") end if - end if - end subroutine interleave_surface_ids_vector + interleaved_surface_ids = 0 + if(no_sids > 0) then + if(associated(mesh%faces%boundary_ids)) then + interleaved_surface_ids = mesh%faces%boundary_ids(1:no_sids) * (max_coplanar_id + 1) + end if + if(associated(mesh%faces%coplanar_ids)) then + interleaved_surface_ids = interleaved_surface_ids + mesh%faces%coplanar_ids(1:no_sids) + end if + end if + + end subroutine interleave_surface_ids_vector - subroutine deinterleave_surface_ids_mesh(mesh, max_coplanar_id) - !!< De-interleave all surface ID information for the supplied mesh, stored - !!< on the boundary IDs + subroutine deinterleave_surface_ids_mesh(mesh, max_coplanar_id) + !!< De-interleave all surface ID information for the supplied mesh, stored + !!< on the boundary IDs - type(mesh_type), intent(inout) :: mesh - integer, intent(in) :: max_coplanar_id + type(mesh_type), intent(inout) :: mesh + integer, intent(in) :: max_coplanar_id - integer, dimension(surface_element_count(mesh)) :: boundary_ids, coplanar_ids + integer, dimension(surface_element_count(mesh)) :: boundary_ids, coplanar_ids - if(associated(mesh%faces)) then - assert(associated(mesh%faces%boundary_ids)) - call deinterleave_surface_ids(mesh%faces%boundary_ids, max_coplanar_id, boundary_ids, coplanar_ids) - mesh%faces%boundary_ids = boundary_ids - if (.not. associated(mesh%faces%coplanar_ids)) allocate(mesh%faces%coplanar_ids(surface_element_count(mesh))) - mesh%faces%coplanar_ids = coplanar_ids - end if + if(associated(mesh%faces)) then + assert(associated(mesh%faces%boundary_ids)) + call deinterleave_surface_ids(mesh%faces%boundary_ids, max_coplanar_id, boundary_ids, coplanar_ids) + mesh%faces%boundary_ids = boundary_ids + if (.not. associated(mesh%faces%coplanar_ids)) allocate(mesh%faces%coplanar_ids(surface_element_count(mesh))) + mesh%faces%coplanar_ids = coplanar_ids + end if - end subroutine deinterleave_surface_ids_mesh + end subroutine deinterleave_surface_ids_mesh - subroutine deinterleave_surface_ids_vector(interleaved_surface_ids, max_coplanar_id, boundary_ids, coplanar_ids) - !!< De-interleave the supplied interleaved surface ID information + subroutine deinterleave_surface_ids_vector(interleaved_surface_ids, max_coplanar_id, boundary_ids, coplanar_ids) + !!< De-interleave the supplied interleaved surface ID information - integer, dimension(:), intent(in) :: interleaved_surface_ids - integer, intent(in) :: max_coplanar_id - integer, dimension(size(interleaved_surface_ids)), intent(out) :: boundary_ids - integer, dimension(size(interleaved_surface_ids)), intent(out) :: coplanar_ids + integer, dimension(:), intent(in) :: interleaved_surface_ids + integer, intent(in) :: max_coplanar_id + integer, dimension(size(interleaved_surface_ids)), intent(out) :: boundary_ids + integer, dimension(size(interleaved_surface_ids)), intent(out) :: coplanar_ids - boundary_ids = interleaved_surface_ids / (max_coplanar_id + 1) - coplanar_ids = interleaved_surface_ids - boundary_ids * (max_coplanar_id + 1) + boundary_ids = interleaved_surface_ids / (max_coplanar_id + 1) + coplanar_ids = interleaved_surface_ids - boundary_ids * (max_coplanar_id + 1) - end subroutine deinterleave_surface_ids_vector + end subroutine deinterleave_surface_ids_vector end module surface_id_interleaving diff --git a/assemble/Timeloop_utilities.F90 b/assemble/Timeloop_utilities.F90 index f924ede9e9..856fb8eb5c 100644 --- a/assemble/Timeloop_utilities.F90 +++ b/assemble/Timeloop_utilities.F90 @@ -27,408 +27,408 @@ #include "fdebug.h" module timeloop_utilities - use fldebug - use spud - use global_parameters, only: simulation_start_cpu_time,& - & simulation_start_wall_time, OPTION_PATH_LEN - use parallel_tools - use fields - use state_module - use fefields - use signal_vars - use timers - implicit none - - private - - public :: copy_to_stored_values, copy_from_stored_values,& - & relax_to_nonlinear, simulation_completed, get_copied_field + use fldebug + use spud + use global_parameters, only: simulation_start_cpu_time,& + & simulation_start_wall_time, OPTION_PATH_LEN + use parallel_tools + use fields + use state_module + use fefields + use signal_vars + use timers + implicit none + + private + + public :: copy_to_stored_values, copy_from_stored_values,& + & relax_to_nonlinear, simulation_completed, get_copied_field contains - subroutine copy_to_stored_values(state, prefix) - !!< For each field, copy its value to prefixfield if prefixfield is present. - type(state_type), dimension(:), intent(inout) :: state - character(len=*), intent(in) :: prefix + subroutine copy_to_stored_values(state, prefix) + !!< For each field, copy its value to prefixfield if prefixfield is present. + type(state_type), dimension(:), intent(inout) :: state + character(len=*), intent(in) :: prefix - integer :: s, f, stat + integer :: s, f, stat - type(scalar_field) :: sfield, old_sfield - type(vector_field) :: vfield, old_vfield - type(tensor_field) :: tfield, old_tfield + type(scalar_field) :: sfield, old_sfield + type(vector_field) :: vfield, old_vfield + type(tensor_field) :: tfield, old_tfield - do s=1,size(state) + do s=1,size(state) - do f=1,scalar_field_count(state(s)) + do f=1,scalar_field_count(state(s)) - sfield=extract_scalar_field(state(s), f) + sfield=extract_scalar_field(state(s), f) - if(.not.aliased(sfield)) then + if(.not.aliased(sfield)) then - old_sfield=extract_scalar_field(state(s), trim(prefix)//sfield%name,& - & stat=stat) + old_sfield=extract_scalar_field(state(s), trim(prefix)//sfield%name,& + & stat=stat) - if ((stat==0).and.(.not.aliased(old_sfield))) then - ! In this case there is an old field to be set. + if ((stat==0).and.(.not.aliased(old_sfield))) then + ! In this case there is an old field to be set. - call set(old_sfield, sfield) + call set(old_sfield, sfield) + + end if end if - end if + end do - end do + do f=1,vector_field_count(state(s)) - do f=1,vector_field_count(state(s)) + vfield=extract_vector_field(state(s), f) - vfield=extract_vector_field(state(s), f) + if(.not.aliased(vfield)) then - if(.not.aliased(vfield)) then + ! Special case: do not copy to the coordinates + if ((vfield%name=="Coordinate")) then + cycle + end if - ! Special case: do not copy to the coordinates - if ((vfield%name=="Coordinate")) then - cycle - end if + old_vfield=extract_vector_field(state(s), trim(prefix)//vfield%name,& + & stat=stat) - old_vfield=extract_vector_field(state(s), trim(prefix)//vfield%name,& - & stat=stat) + if ((stat==0).and.(.not.aliased(old_vfield))) then + ! In this case there is an old field to be set. - if ((stat==0).and.(.not.aliased(old_vfield))) then - ! In this case there is an old field to be set. + call set(old_vfield, vfield) - call set(old_vfield, vfield) + end if end if - end if + end do - end do + do f=1,tensor_field_count(state(s)) - do f=1,tensor_field_count(state(s)) + tfield=extract_tensor_field(state(s), f) - tfield=extract_tensor_field(state(s), f) + if(.not.aliased(tfield)) then - if(.not.aliased(tfield)) then + old_tfield=extract_tensor_field(state(s), trim(prefix)//tfield%name,& + & stat=stat) - old_tfield=extract_tensor_field(state(s), trim(prefix)//tfield%name,& - & stat=stat) + if ((stat==0).and.(.not.aliased(old_tfield))) then + ! In this case there is an old field to be set. - if ((stat==0).and.(.not.aliased(old_tfield))) then - ! In this case there is an old field to be set. + call set(old_tfield, tfield) - call set(old_tfield, tfield) + end if end if - end if + end do - end do + end do - end do + end subroutine copy_to_stored_values - end subroutine copy_to_stored_values + subroutine copy_from_stored_values(state, prefix) + !!< For each field, copy its value from prefixfield if prefixfield is present. + type(state_type), dimension(:), intent(inout) :: state + character(len=*), intent(in) :: prefix - subroutine copy_from_stored_values(state, prefix) - !!< For each field, copy its value from prefixfield if prefixfield is present. - type(state_type), dimension(:), intent(inout) :: state - character(len=*), intent(in) :: prefix + integer :: s, f, stat - integer :: s, f, stat + type(scalar_field) :: sfield, old_sfield + type(vector_field) :: vfield, old_vfield + type(tensor_field) :: tfield, old_tfield - type(scalar_field) :: sfield, old_sfield - type(vector_field) :: vfield, old_vfield - type(tensor_field) :: tfield, old_tfield + do s=1,size(state) - do s=1,size(state) + do f=1,scalar_field_count(state(s)) - do f=1,scalar_field_count(state(s)) + sfield=extract_scalar_field(state(s), f) - sfield=extract_scalar_field(state(s), f) + if(.not.(have_option(trim(sfield%option_path)//"/prescribed"))) then - if(.not.(have_option(trim(sfield%option_path)//"/prescribed"))) then + if(.not.aliased(sfield)) then - if(.not.aliased(sfield)) then + ! Special case: do not copy back pressure or density or geostrophic pressure + if ((sfield%name=="Pressure").or.(sfield%name=="Density").or.(sfield%name=="GeostrophicPressure")) then + cycle + end if - ! Special case: do not copy back pressure or density or geostrophic pressure - if ((sfield%name=="Pressure").or.(sfield%name=="Density").or.(sfield%name=="GeostrophicPressure")) then - cycle - end if + old_sfield=extract_scalar_field(state(s), trim(prefix)//sfield%name,& + & stat=stat) - old_sfield=extract_scalar_field(state(s), trim(prefix)//sfield%name,& - & stat=stat) + if ((stat==0).and.(.not.aliased(old_sfield))) then + ! In this case there is an old field to be set. - if ((stat==0).and.(.not.aliased(old_sfield))) then - ! In this case there is an old field to be set. + call set(sfield, old_sfield) - call set(sfield, old_sfield) + end if - end if + end if end if - end if - - end do + end do - do f=1,vector_field_count(state(s)) + do f=1,vector_field_count(state(s)) - vfield=extract_vector_field(state(s), f) + vfield=extract_vector_field(state(s), f) - if(.not.(have_option(trim(vfield%option_path)//"/prescribed"))) then + if(.not.(have_option(trim(vfield%option_path)//"/prescribed"))) then - if(.not.aliased(vfield)) then + if(.not.aliased(vfield)) then - ! Special case: do not copy back the coordinates or the gridvelocity - if ((vfield%name=="Coordinate").or.(vfield%name=="GridVelocity")) then - cycle - end if + ! Special case: do not copy back the coordinates or the gridvelocity + if ((vfield%name=="Coordinate").or.(vfield%name=="GridVelocity")) then + cycle + end if - old_vfield=extract_vector_field(state(s), trim(prefix)//vfield%name,& - & stat=stat) + old_vfield=extract_vector_field(state(s), trim(prefix)//vfield%name,& + & stat=stat) - if ((stat==0).and.(.not.aliased(old_vfield))) then - ! In this case there is an old field to be set. - call set(vfield, old_vfield) - end if + if ((stat==0).and.(.not.aliased(old_vfield))) then + ! In this case there is an old field to be set. + call set(vfield, old_vfield) + end if - end if + end if - end if + end if - end do + end do - do f=1,tensor_field_count(state(s)) + do f=1,tensor_field_count(state(s)) - tfield=extract_tensor_field(state(s), f) + tfield=extract_tensor_field(state(s), f) - if(.not.(have_option(trim(tfield%option_path)//"/prescribed"))) then + if(.not.(have_option(trim(tfield%option_path)//"/prescribed"))) then - if(.not.aliased(tfield)) then + if(.not.aliased(tfield)) then - old_tfield=extract_tensor_field(state(s), trim(prefix)//tfield%name,& - & stat=stat) + old_tfield=extract_tensor_field(state(s), trim(prefix)//tfield%name,& + & stat=stat) - if ((stat==0).and.(.not.aliased(old_tfield))) then - ! In this case there is an old field to be set. + if ((stat==0).and.(.not.aliased(old_tfield))) then + ! In this case there is an old field to be set. - call set(tfield, old_tfield) + call set(tfield, old_tfield) - end if + end if - end if + end if - end if + end if - end do + end do - end do + end do - end subroutine copy_from_stored_values + end subroutine copy_from_stored_values - subroutine get_copied_field(fieldname, state) + subroutine get_copied_field(fieldname, state) - type(state_type), intent(in) :: state - character(len=*), intent(in) :: fieldname + type(state_type), intent(in) :: state + character(len=*), intent(in) :: fieldname - type(scalar_field), pointer :: copiedfield - type(scalar_field), pointer :: tmpfield - character(len=OPTION_PATH_LEN) :: tmpstring + type(scalar_field), pointer :: copiedfield + type(scalar_field), pointer :: tmpfield + character(len=OPTION_PATH_LEN) :: tmpstring - if(trim(fieldname)=="CopiedField") then - copiedfield=>extract_scalar_field(state, "CopiedField") - call get_option(trim(copiedfield%option_path)//"/prognostic/copy_from_field", & - tmpstring) - tmpfield=>extract_scalar_field(state, "Old"//trim(tmpstring)) - call set(copiedfield, tmpfield) - end if + if(trim(fieldname)=="CopiedField") then + copiedfield=>extract_scalar_field(state, "CopiedField") + call get_option(trim(copiedfield%option_path)//"/prognostic/copy_from_field", & + tmpstring) + tmpfield=>extract_scalar_field(state, "Old"//trim(tmpstring)) + call set(copiedfield, tmpfield) + end if - end subroutine get_copied_field + end subroutine get_copied_field - subroutine relax_to_nonlinear(state) - !!< For each field, set the nonlinearfield if present. - type(state_type), dimension(:), intent(inout) :: state + subroutine relax_to_nonlinear(state) + !!< For each field, set the nonlinearfield if present. + type(state_type), dimension(:), intent(inout) :: state - integer :: s, f, old_stat, nl_stat, stat - real :: itheta + integer :: s, f, old_stat, nl_stat, stat + real :: itheta - type(scalar_field) :: sfield, old_sfield, nl_sfield - type(vector_field) :: vfield, old_vfield, nl_vfield - type(tensor_field) :: tfield, old_tfield, nl_tfield + type(scalar_field) :: sfield, old_sfield, nl_sfield + type(vector_field) :: vfield, old_vfield, nl_vfield + type(tensor_field) :: tfield, old_tfield, nl_tfield - !For projecting velocity to continuous - type(vector_field) :: U_nl, pvelocity, X - type(vector_field), pointer :: velocity + !For projecting velocity to continuous + type(vector_field) :: U_nl, pvelocity, X + type(vector_field), pointer :: velocity - do s=1,size(state) + do s=1,size(state) - velocity=>extract_vector_field(state(s), "Velocity", stat) - if(stat==0) then - if (have_option(trim(velocity%option_path)//"/prognostic")) then - call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/relaxation", itheta, default=0.5) - else if (have_option(trim(velocity%option_path)//"/prescribed")) then - call get_option(trim(velocity%option_path)//"/prescribed/temporal_discretisation/relaxation", itheta, default=1.0) - else + velocity=>extract_vector_field(state(s), "Velocity", stat) + if(stat==0) then + if (have_option(trim(velocity%option_path)//"/prognostic")) then + call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/relaxation", itheta, default=0.5) + else if (have_option(trim(velocity%option_path)//"/prescribed")) then + call get_option(trim(velocity%option_path)//"/prescribed/temporal_discretisation/relaxation", itheta, default=1.0) + else + itheta = 0.5 + end if + else itheta = 0.5 - end if - else - itheta = 0.5 - end if + end if - do f=1,scalar_field_count(state(s)) + do f=1,scalar_field_count(state(s)) - sfield=extract_scalar_field(state(s), f) + sfield=extract_scalar_field(state(s), f) - if(.not.aliased(sfield)) then + if(.not.aliased(sfield)) then - old_sfield=extract_scalar_field(state(s), "Old"//trim(sfield%name),& - & stat=old_stat) + old_sfield=extract_scalar_field(state(s), "Old"//trim(sfield%name),& + & stat=old_stat) - nl_sfield=extract_scalar_field(state(s), "Nonlinear"//trim(sfield%name),& - & stat=nl_stat) + nl_sfield=extract_scalar_field(state(s), "Nonlinear"//trim(sfield%name),& + & stat=nl_stat) - if ((old_stat==0).and.(nl_stat==0)) then + if ((old_stat==0).and.(nl_stat==0)) then - call set(nl_sfield, sfield, old_sfield, itheta) + call set(nl_sfield, sfield, old_sfield, itheta) + + end if end if - end if + end do - end do + do f=1,vector_field_count(state(s)) - do f=1,vector_field_count(state(s)) + vfield=extract_vector_field(state(s), f) - vfield=extract_vector_field(state(s), f) + if(.not.aliased(vfield)) then - if(.not.aliased(vfield)) then + old_vfield=extract_vector_field(state(s), "Old"//trim(vfield%name),& + & stat=old_stat) - old_vfield=extract_vector_field(state(s), "Old"//trim(vfield%name),& - & stat=old_stat) + nl_vfield=extract_vector_field(state(s), "Nonlinear"//trim(vfield%name),& + & stat=nl_stat) - nl_vfield=extract_vector_field(state(s), "Nonlinear"//trim(vfield%name),& - & stat=nl_stat) + if ((old_stat==0).and.(nl_stat==0)) then - if ((old_stat==0).and.(nl_stat==0)) then + call set(nl_vfield, vfield, old_vfield, itheta) - call set(nl_vfield, vfield, old_vfield, itheta) + end if - end if + end if - end if + end do - end do + do f=1,tensor_field_count(state(s)) - do f=1,tensor_field_count(state(s)) + tfield=extract_tensor_field(state(s), f) - tfield=extract_tensor_field(state(s), f) + if(.not.aliased(tfield)) then - if(.not.aliased(tfield)) then + old_tfield=extract_tensor_field(state(s), "Old"//trim(tfield%name),& + & stat=old_stat) - old_tfield=extract_tensor_field(state(s), "Old"//trim(tfield%name),& - & stat=old_stat) + nl_tfield=extract_tensor_field(state(s), "Nonlinear"//trim(tfield%name),& + & stat=nl_stat) - nl_tfield=extract_tensor_field(state(s), "Nonlinear"//trim(tfield%name),& - & stat=nl_stat) + if ((old_stat==0).and.(nl_stat==0)) then - if ((old_stat==0).and.(nl_stat==0)) then + call set(nl_tfield, tfield, old_tfield, itheta) - call set(nl_tfield, tfield, old_tfield, itheta) + end if end if - end if - - end do + end do - end do + end do - !Compute velocity field projected to continuous for DG advection - !Not currently coded for multimaterial/phase as I don't understand - !how it works - if(has_vector_field(state(1),"ProjectedNonlinearVelocity")) then - U_nl = extract_vector_field(state(1),"NonlinearVelocity") - pvelocity = extract_vector_field(state(1),& + !Compute velocity field projected to continuous for DG advection + !Not currently coded for multimaterial/phase as I don't understand + !how it works + if(has_vector_field(state(1),"ProjectedNonlinearVelocity")) then + U_nl = extract_vector_field(state(1),"NonlinearVelocity") + pvelocity = extract_vector_field(state(1),& "ProjectedNonlinearVelocity") - X = extract_vector_field(state(1),"Coordinate") - call project_field(U_nl,pvelocity,X) - end if - - end subroutine relax_to_nonlinear - - function simulation_completed(current_time, timestep) - !!< Simulation end test routine. Tests standard timestep loop exit - !!< conditions (many listed under /timestepping). Returns .true. if these - !!< conditions are satisfied and .false. otherwise. - - real, intent(in) :: current_time - integer, intent(in), optional :: timestep - - logical :: simulation_completed - - integer :: final_timestep, i, stat - real :: current_cpu_time, time_limit, current_wall_time - - simulation_completed = .false. - - do i = 1, 5 - select case(i) - case(1) - call get_option("/timestepping/finish_time", time_limit) - if(current_time >= time_limit) then - simulation_completed = .true. - ewrite(1, *) "Finish time reached" - exit - end if - case(2) - if(present(timestep)) then - call get_option("/timestepping/final_timestep", final_timestep, stat) - if(stat == SPUD_NO_ERROR) then - if(timestep > final_timestep) then - simulation_completed = .true. - ewrite(1, *) "Passed final timestep" - exit - end if - end if - end if - case(3) - call get_option("/timestepping/cpu_time_limit", time_limit, stat) - if(stat == SPUD_NO_ERROR) then - call cpu_time(current_cpu_time) - call allmax(current_cpu_time) - if(current_cpu_time - simulation_start_cpu_time >= time_limit) then - simulation_completed = .true. - ewrite(1, *) "CPU time limit reached" - exit - end if - end if - case(4) - call get_option("/timestepping/wall_time_limit", time_limit, stat) - if(stat == SPUD_NO_ERROR) then - current_wall_time = wall_time() - call allmax(current_wall_time) - if(current_wall_time - simulation_start_wall_time >= time_limit) then - simulation_completed = .true. - ewrite(1, *) "Wall time limit reached" - exit - end if - end if - case(5) - if(SIG_INT) then - simulation_completed = .true. - ewrite(1, *) "Interrupt signal received" - exit - end if - case default - FLAbort("Invalid loop index") - end select - end do - - if(simulation_completed) then - ewrite(2, *) "simulation_completed returning .true." - else - ewrite(2, *) "simulation_completed returning .false." - end if - - end function simulation_completed + X = extract_vector_field(state(1),"Coordinate") + call project_field(U_nl,pvelocity,X) + end if + + end subroutine relax_to_nonlinear + + function simulation_completed(current_time, timestep) + !!< Simulation end test routine. Tests standard timestep loop exit + !!< conditions (many listed under /timestepping). Returns .true. if these + !!< conditions are satisfied and .false. otherwise. + + real, intent(in) :: current_time + integer, intent(in), optional :: timestep + + logical :: simulation_completed + + integer :: final_timestep, i, stat + real :: current_cpu_time, time_limit, current_wall_time + + simulation_completed = .false. + + do i = 1, 5 + select case(i) + case(1) + call get_option("/timestepping/finish_time", time_limit) + if(current_time >= time_limit) then + simulation_completed = .true. + ewrite(1, *) "Finish time reached" + exit + end if + case(2) + if(present(timestep)) then + call get_option("/timestepping/final_timestep", final_timestep, stat) + if(stat == SPUD_NO_ERROR) then + if(timestep > final_timestep) then + simulation_completed = .true. + ewrite(1, *) "Passed final timestep" + exit + end if + end if + end if + case(3) + call get_option("/timestepping/cpu_time_limit", time_limit, stat) + if(stat == SPUD_NO_ERROR) then + call cpu_time(current_cpu_time) + call allmax(current_cpu_time) + if(current_cpu_time - simulation_start_cpu_time >= time_limit) then + simulation_completed = .true. + ewrite(1, *) "CPU time limit reached" + exit + end if + end if + case(4) + call get_option("/timestepping/wall_time_limit", time_limit, stat) + if(stat == SPUD_NO_ERROR) then + current_wall_time = wall_time() + call allmax(current_wall_time) + if(current_wall_time - simulation_start_wall_time >= time_limit) then + simulation_completed = .true. + ewrite(1, *) "Wall time limit reached" + exit + end if + end if + case(5) + if(SIG_INT) then + simulation_completed = .true. + ewrite(1, *) "Interrupt signal received" + exit + end if + case default + FLAbort("Invalid loop index") + end select + end do + + if(simulation_completed) then + ewrite(2, *) "simulation_completed returning .true." + else + ewrite(2, *) "simulation_completed returning .false." + end if + + end function simulation_completed end module timeloop_utilities diff --git a/assemble/Turbine.F90 b/assemble/Turbine.F90 index 893bd019b8..fdeac0c792 100644 --- a/assemble/Turbine.F90 +++ b/assemble/Turbine.F90 @@ -28,170 +28,170 @@ module turbine - use fldebug - use spud - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN - use futils - use elements - use transform_elements - use fetools, only: shape_shape - use fields - implicit none - - private - public :: turbine_check_options, construct_turbine_interface + use fldebug + use spud + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use futils + use elements + use transform_elements + use fetools, only: shape_shape + use fields + implicit none + + private + public :: turbine_check_options, construct_turbine_interface contains - subroutine construct_turbine_interface(turbine_fluxfac, theta, dt, ele, face, face_2, ni, & - & big_m_tensor_addto, rhs_addto, X, U, velocity_bc, velocity_bc_type) - !!< Construct the DG element boundary integrals on the ni-th face of - !!< element ele. - implicit none + subroutine construct_turbine_interface(turbine_fluxfac, theta, dt, ele, face, face_2, ni, & + & big_m_tensor_addto, rhs_addto, X, U, velocity_bc, velocity_bc_type) + !!< Construct the DG element boundary integrals on the ni-th face of + !!< element ele. + implicit none - ! The turbine model - real, intent(out) :: turbine_fluxfac - real, intent(in) :: theta, dt - integer, intent(in) :: ele, face, face_2, ni - real, dimension(:,:,:,:), intent(inout) :: big_m_tensor_addto - real, dimension(:,:) :: rhs_addto - ! We pass these additional fields to save on state lookups. - type(vector_field), intent(in) :: X, U + ! The turbine model + real, intent(out) :: turbine_fluxfac + real, intent(in) :: theta, dt + integer, intent(in) :: ele, face, face_2, ni + real, dimension(:,:,:,:), intent(inout) :: big_m_tensor_addto + real, dimension(:,:) :: rhs_addto + ! We pass these additional fields to save on state lookups. + type(vector_field), intent(in) :: X, U - !! Boundary conditions associated with this interface (if any). - type(vector_field), intent(in) :: velocity_bc - integer, dimension(:,:), intent(in) :: velocity_bc_type - integer :: turbine_model + !! Boundary conditions associated with this interface (if any). + type(vector_field), intent(in) :: velocity_bc + integer, dimension(:,:), intent(in) :: velocity_bc_type + integer :: turbine_model - turbine_model = velocity_bc_type(1,face) + turbine_model = velocity_bc_type(1,face) - turbine_fluxfac=-1.0 - select case (turbine_model) - case(5) + turbine_fluxfac=-1.0 + select case (turbine_model) + case(5) turbine_fluxfac=1.0 return - case(4) + case(4) call construct_turbine_interface_penalty(theta, dt, ele, face, face_2, ni, & - & big_m_tensor_addto, rhs_addto, X, U,& - & velocity_bc) - case default + & big_m_tensor_addto, rhs_addto, X, U,& + & velocity_bc) + case default FLAbort("Unknown turbine model found.") - end select - end subroutine construct_turbine_interface - - subroutine construct_turbine_interface_penalty(theta, dt, ele, face, face_2, ni, & - & big_m_tensor_addto, rhs_addto, X, U, & - velocity_bc) - - real, intent(in) :: theta, dt - integer, intent(in) :: ele, face, face_2, ni - real, dimension(:,:,:,:), intent(inout) :: big_m_tensor_addto - real, dimension(:,:) :: rhs_addto - ! We pass these additional fields to save on state lookups. - type(vector_field), intent(in) :: X, U - !! Boundary conditions associated with this interface (if any). - type(vector_field), intent(in) :: velocity_bc - - real, dimension(face_loc(U,face),face_loc(U,face_2)) :: penalty_domain_connecting_in, penalty_domain_connecting_out - integer :: dim, i, start, finish - real, dimension(face_ngi(U,face)) :: detwei - ! Face objects and numberings. - type(element_type), pointer :: u_shape, u_shape_2 - integer, dimension(face_loc(U,face)) :: u_face_l - real, dimension(velocity_bc%dim, velocity_bc%mesh%shape%loc) :: penalty_val, penalty_val_2 - - ! Connected two domains with a penalty term - ! - ! The penalty term has the form Int_E p*phi*(\delta u_u- + u- - (delta_u+ + u+)) dE where p is the penalty parameter - ! - penalty_val=ele_val(velocity_bc, face) + end select + end subroutine construct_turbine_interface + + subroutine construct_turbine_interface_penalty(theta, dt, ele, face, face_2, ni, & + & big_m_tensor_addto, rhs_addto, X, U, & + velocity_bc) + + real, intent(in) :: theta, dt + integer, intent(in) :: ele, face, face_2, ni + real, dimension(:,:,:,:), intent(inout) :: big_m_tensor_addto + real, dimension(:,:) :: rhs_addto + ! We pass these additional fields to save on state lookups. + type(vector_field), intent(in) :: X, U + !! Boundary conditions associated with this interface (if any). + type(vector_field), intent(in) :: velocity_bc + + real, dimension(face_loc(U,face),face_loc(U,face_2)) :: penalty_domain_connecting_in, penalty_domain_connecting_out + integer :: dim, i, start, finish + real, dimension(face_ngi(U,face)) :: detwei + ! Face objects and numberings. + type(element_type), pointer :: u_shape, u_shape_2 + integer, dimension(face_loc(U,face)) :: u_face_l + real, dimension(velocity_bc%dim, velocity_bc%mesh%shape%loc) :: penalty_val, penalty_val_2 + + ! Connected two domains with a penalty term + ! + ! The penalty term has the form Int_E p*phi*(\delta u_u- + u- - (delta_u+ + u+)) dE where p is the penalty parameter + ! + penalty_val=ele_val(velocity_bc, face) #ifdef DDEBUG - ! The penalty values should be the same on both turbine sides! - penalty_val_2=ele_val(velocity_bc, face_2) - assert(all(penalty_val(1,:)==penalty_val_2(1,:))) + ! The penalty values should be the same on both turbine sides! + penalty_val_2=ele_val(velocity_bc, face_2) + assert(all(penalty_val(1,:)==penalty_val_2(1,:))) #endif - start=ele_loc(u,ele)+(ni-1)*face_loc(U, face_2)+1 - finish=start+face_loc(U, face_2)-1 - - u_shape=>face_shape(U, face) - u_shape_2=>face_shape(U, face_2) - - !---------------------------------------------------------------------- - ! Change of coordinates on face. - !---------------------------------------------------------------------- - call transform_facet_to_physical(X, face,& - & detwei_f=detwei) - - penalty_domain_connecting_in=shape_shape(U_shape, U_shape, detwei) - penalty_domain_connecting_out=shape_shape(U_shape, U_shape_2, detwei) - ! Multiply Matrix with the penalty function -- !!!to be reviewed!!! -- - do i=1, face_loc(U,face_2) - penalty_domain_connecting_in(i,:)=penalty_domain_connecting_in(i,:)*penalty_val(1,:) - penalty_domain_connecting_out(i,:)=penalty_domain_connecting_out(i,:)*penalty_val(1,:) - end do - u_face_l=face_local_nodes(U, face) - do dim = 1, u%dim - ! Insert penalty terms in matrix. - big_m_tensor_addto(dim, dim, u_face_l, u_face_l) = & - big_m_tensor_addto(dim, dim, u_face_l, u_face_l) + & - penalty_domain_connecting_in*dt*theta - - rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & - -matmul(penalty_domain_connecting_in,face_val(U,dim,face)) - - big_m_tensor_addto(dim, dim, u_face_l, start:finish) = & - big_m_tensor_addto(dim, dim, u_face_l, start:finish) - & - penalty_domain_connecting_out*dt*theta - - rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & - +matmul(penalty_domain_connecting_out,face_val(U,dim,face_2)) - end do - end subroutine construct_turbine_interface_penalty - - subroutine turbine_check_options - character(len=OPTION_PATH_LEN):: turbine_path, turbine_name, bc_name - integer :: notur, i, j - logical :: have_dirichlet_model, have_flux_dg_model, have_flux_penalty_model - - ! Don't check turbine configuration if it's not included in the model! - if (.not.have_option("/turbine_model")) return - - have_dirichlet_model=.false. - have_flux_penalty_model=.false. - have_flux_dg_model=.false. - - ! loop through turbines - notur = option_count("/turbine_model/turbine") - do i=0, notur-1 - turbine_path="/turbine_model/turbine["//int2str(i)//"]" - if (have_option(trim(turbine_path)//"/dirichlet")) then - have_dirichlet_model=.true. - ! The specified b.c.'s in the turbine model must be dirichlet boundary conditions with normal_component. - do j=1,2 - call get_option("/turbine_model/turbine["//int2str(i)//"]/dirichlet/boundary_condition_name_"//int2str(j)//"/name", bc_name) - if (.not. have_option("/material_phase[0]/vector_field::Velocity/prognostic/boundary_conditions::"//trim(bc_name)//"/type::dirichlet/align_bc_with_surface/normal_component")) then - call get_option("/turbine_model/turbine["//int2str(i)//"]/name", turbine_name) - FLExit("Error while checking the options for turbine '"//trim(turbine_name)//"': Turbine model boundary has to be dirichlet boundary conditions with a normal_component.") - end if - end do - elseif (have_option(trim(turbine_path)//"/flux/dg")) then + start=ele_loc(u,ele)+(ni-1)*face_loc(U, face_2)+1 + finish=start+face_loc(U, face_2)-1 + + u_shape=>face_shape(U, face) + u_shape_2=>face_shape(U, face_2) + + !---------------------------------------------------------------------- + ! Change of coordinates on face. + !---------------------------------------------------------------------- + call transform_facet_to_physical(X, face,& + & detwei_f=detwei) + + penalty_domain_connecting_in=shape_shape(U_shape, U_shape, detwei) + penalty_domain_connecting_out=shape_shape(U_shape, U_shape_2, detwei) + ! Multiply Matrix with the penalty function -- !!!to be reviewed!!! -- + do i=1, face_loc(U,face_2) + penalty_domain_connecting_in(i,:)=penalty_domain_connecting_in(i,:)*penalty_val(1,:) + penalty_domain_connecting_out(i,:)=penalty_domain_connecting_out(i,:)*penalty_val(1,:) + end do + u_face_l=face_local_nodes(U, face) + do dim = 1, u%dim + ! Insert penalty terms in matrix. + big_m_tensor_addto(dim, dim, u_face_l, u_face_l) = & + big_m_tensor_addto(dim, dim, u_face_l, u_face_l) + & + penalty_domain_connecting_in*dt*theta + + rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & + -matmul(penalty_domain_connecting_in,face_val(U,dim,face)) + + big_m_tensor_addto(dim, dim, u_face_l, start:finish) = & + big_m_tensor_addto(dim, dim, u_face_l, start:finish) - & + penalty_domain_connecting_out*dt*theta + + rhs_addto(dim,u_face_l) = rhs_addto(dim,u_face_l) & + +matmul(penalty_domain_connecting_out,face_val(U,dim,face_2)) + end do + end subroutine construct_turbine_interface_penalty + + subroutine turbine_check_options + character(len=OPTION_PATH_LEN):: turbine_path, turbine_name, bc_name + integer :: notur, i, j + logical :: have_dirichlet_model, have_flux_dg_model, have_flux_penalty_model + + ! Don't check turbine configuration if it's not included in the model! + if (.not.have_option("/turbine_model")) return + + have_dirichlet_model=.false. + have_flux_penalty_model=.false. + have_flux_dg_model=.false. + + ! loop through turbines + notur = option_count("/turbine_model/turbine") + do i=0, notur-1 + turbine_path="/turbine_model/turbine["//int2str(i)//"]" + if (have_option(trim(turbine_path)//"/dirichlet")) then + have_dirichlet_model=.true. + ! The specified b.c.'s in the turbine model must be dirichlet boundary conditions with normal_component. + do j=1,2 + call get_option("/turbine_model/turbine["//int2str(i)//"]/dirichlet/boundary_condition_name_"//int2str(j)//"/name", bc_name) + if (.not. have_option("/material_phase[0]/vector_field::Velocity/prognostic/boundary_conditions::"//trim(bc_name)//"/type::dirichlet/align_bc_with_surface/normal_component")) then + call get_option("/turbine_model/turbine["//int2str(i)//"]/name", turbine_name) + FLExit("Error while checking the options for turbine '"//trim(turbine_name)//"': Turbine model boundary has to be dirichlet boundary conditions with a normal_component.") + end if + end do + elseif (have_option(trim(turbine_path)//"/flux/dg")) then have_flux_dg_model=.true. - elseif (have_option(trim(turbine_path)//"/flux/penalty")) then + elseif (have_option(trim(turbine_path)//"/flux/penalty")) then have_flux_penalty_model=.true. - else - FLAbort("Unknown turbine model specified!") - end if - end do - - if (have_dirichlet_model) then - ! We need the FreeSurface field. - if (.not.have_option("/material_phase[0]/scalar_field::FreeSurface")) then - FLExit("Turbine modelling requires FreeSurface to be activated.") - end if - end if - - end subroutine turbine_check_options + else + FLAbort("Unknown turbine model specified!") + end if + end do + + if (have_dirichlet_model) then + ! We need the FreeSurface field. + if (.not.have_option("/material_phase[0]/scalar_field::FreeSurface")) then + FLExit("Turbine modelling requires FreeSurface to be activated.") + end if + end if + + end subroutine turbine_check_options end module turbine diff --git a/assemble/Upwind_Stabilisation.F90 b/assemble/Upwind_Stabilisation.F90 index 58a752b144..d0a885be02 100644 --- a/assemble/Upwind_Stabilisation.F90 +++ b/assemble/Upwind_Stabilisation.F90 @@ -27,430 +27,430 @@ #include "fdebug.h" module upwind_stabilisation - !!< This module provides routines for the upwind stabilisation of - !!< advection_diffusion equations. + !!< This module provides routines for the upwind stabilisation of + !!< advection_diffusion equations. - use spud - use vector_tools, only: inverse - use shape_functions - use metric_tools - use fields + use spud + use vector_tools, only: inverse + use shape_functions + use metric_tools + use fields - implicit none + implicit none - private + private - public :: get_upwind_options, element_upwind_stabilisation,& - & make_supg_shape, make_supg_element, supg_test_function + public :: get_upwind_options, element_upwind_stabilisation,& + & make_supg_shape, make_supg_element, supg_test_function - integer, parameter, public :: NU_BAR_OPTIMAL = 1, & - & NU_BAR_DOUBLY_ASYMPTOTIC = 2, NU_BAR_CRITICAL_RULE = 3, NU_BAR_UNITY = 4 + integer, parameter, public :: NU_BAR_OPTIMAL = 1, & + & NU_BAR_DOUBLY_ASYMPTOTIC = 2, NU_BAR_CRITICAL_RULE = 3, NU_BAR_UNITY = 4 - real, parameter :: tolerance = 1.0e-10 - ! For Pe >= this, 1.0 / tanh(pe) differs from 1.0 by <= 1.0e-10 - real, parameter :: tanh_tolerance = 11.859499013855018 + real, parameter :: tolerance = 1.0e-10 + ! For Pe >= this, 1.0 / tanh(pe) differs from 1.0 by <= 1.0e-10 + real, parameter :: tanh_tolerance = 11.859499013855018 contains - subroutine get_upwind_options(option_path, nu_bar_scheme, nu_bar_scale) - character(len = *), intent(in) :: option_path - integer, intent(out) :: nu_bar_scheme - real, intent(out) :: nu_bar_scale - - if(have_option(trim(option_path) // "/nu_bar_optimal")) then - ewrite(2, *) "nu_bar scheme: optimal" - nu_bar_scheme = NU_BAR_OPTIMAL - else if(have_option(trim(option_path) // "/nu_bar_doubly_asymptotic")) then - ewrite(2, *) "nu_bar scheme: doubly asymptotic" - nu_bar_scheme = NU_BAR_DOUBLY_ASYMPTOTIC - else if(have_option(trim(option_path) // "/nu_bar_critical_rule")) then - ewrite(2, *) "nu_bar scheme: critical rule" - nu_bar_scheme = NU_BAR_CRITICAL_RULE - else - assert(have_option(trim(option_path) // "/nu_bar_unity")) - ewrite(2, *) "nu_bar scheme: unity (xi = sign(pe))" - nu_bar_scheme = NU_BAR_UNITY - end if - - call get_option(trim(option_path) // "/nu_scale", nu_bar_scale) - assert(nu_bar_scale >= 0.0) - ewrite(2, *) "nu_bar scale factor = ", nu_bar_scale - - end subroutine get_upwind_options - - function element_upwind_stabilisation(t_shape, dshape, u_nl_q, j_mat, detwei, & - & diff_q, nu_bar_scheme, nu_bar_scale) result (stab) - !!< Calculate the upwind stabilisation on an individual element. This - !!< implements equation 2.52 in Donea & Huerta (2003): - !!< - !!< / nu - !!< | ----------- (U_nl\dot grad N_j)(U_nl\dot grad N_i) - !!< / ||U_nl||**2 - !!< - !!< Where: - !!< - !!< nu = 0.5*U*dx/d\xi - !!< - type(element_type), intent(in) :: t_shape - !! dshape is nloc x ngi x dim - real, dimension(t_shape%loc, t_shape%quadrature%ngi, t_shape%dim) :: dshape - !! u_nl_q is dim x ngi - real, dimension(t_shape%dim, t_shape%quadrature%ngi), intent(in) :: u_nl_q - !! j_mat is dim x dim x ngi - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 2)), intent(in) :: detwei - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q - integer, optional, intent(in) :: nu_bar_scheme - real, optional, intent(in) :: nu_bar_scale - - real, dimension(t_shape%loc, t_shape%loc) :: stab - - ! Local Variables - - !! This is the factor nu/||U_nl^^2|| - real, dimension(size(detwei)) :: nu_scaled - !! U_nl \dot dshape - real, dimension(t_shape%loc, size(detwei)) :: U_nl_dn - - integer :: i, j, loc, ngi - - loc = t_shape%loc - ngi = size(u_nl_q, 2) - - nu_scaled = nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q = diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - - forall(i = 1:ngi, j = 1:loc) - u_nl_dn(j, i) = dot_product(u_nl_q(:, i), dshape(j, i, :)) - end forall - - forall(i = 1:loc, j = 1:loc) - stab(i, j) = dot_product(u_nl_dn(i, :) * detwei * nu_scaled, u_nl_dn(j, :)) - end forall - - end function element_upwind_stabilisation - - function xi_optimal(u_nl_q, j_mat, diff_q) result(xi_q) - !!< Compute the directional xi factor as in equation 2.44b in Donea & - !!< Huerta (2003) - - real, dimension(:), intent(in) :: U_nl_q - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: diff_q - - real, dimension(size(u_nl_q, 1)) :: xi_q - - integer :: i - real, dimension(size(u_nl_q, 1)) :: pe - - ! Pe = u h_bar - ! ------- - ! 2 kappa - pe = 0.5 * matmul(u_nl_q, matmul(j_mat, inverse(diff_q))) - do i = 1, size(u_nl_q, 1) - if(abs(pe(i)) < tolerance) then - xi_q(i) = 0.0 - else if(pe(i) > tanh_tolerance) then - xi_q(i) = 1.0 - (1.0 / pe(i)) - else if(pe(i) < -tanh_tolerance) then - xi_q(i) = -1.0 - (1.0 / pe(i)) + subroutine get_upwind_options(option_path, nu_bar_scheme, nu_bar_scale) + character(len = *), intent(in) :: option_path + integer, intent(out) :: nu_bar_scheme + real, intent(out) :: nu_bar_scale + + if(have_option(trim(option_path) // "/nu_bar_optimal")) then + ewrite(2, *) "nu_bar scheme: optimal" + nu_bar_scheme = NU_BAR_OPTIMAL + else if(have_option(trim(option_path) // "/nu_bar_doubly_asymptotic")) then + ewrite(2, *) "nu_bar scheme: doubly asymptotic" + nu_bar_scheme = NU_BAR_DOUBLY_ASYMPTOTIC + else if(have_option(trim(option_path) // "/nu_bar_critical_rule")) then + ewrite(2, *) "nu_bar scheme: critical rule" + nu_bar_scheme = NU_BAR_CRITICAL_RULE else - xi_q(i) = (1.0 / tanh(pe(i))) - (1.0 / pe(i)) + assert(have_option(trim(option_path) // "/nu_bar_unity")) + ewrite(2, *) "nu_bar scheme: unity (xi = sign(pe))" + nu_bar_scheme = NU_BAR_UNITY end if - end do - end function xi_optimal - - function xi_doubly_asymptotic(u_nl_q, j_mat, diff_q) result(xi_q) - !!< Compute the directional xi factor using the doubly asymptotic - !!< approximation as in equation 2.29 in Donea & Huerta (2003) - - real, dimension(:), intent(in) :: U_nl_q - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: diff_q - - real, dimension(size(u_nl_q, 1)) :: xi_q - - integer :: i - real, dimension(size(u_nl_q, 1)) :: pe - - ! Pe = u h_bar - ! ------- - ! 2 kappa - pe = 0.5 * matmul(u_nl_q, matmul(j_mat, inverse(diff_q))) - - do i = 1, size(u_nl_q) - if(abs(pe(i)) <= 3.0) then - xi_q(i) = pe(i) / 3.0 - else if(pe(i) > 0.0) then - xi_q(i) = 1.0 + call get_option(trim(option_path) // "/nu_scale", nu_bar_scale) + assert(nu_bar_scale >= 0.0) + ewrite(2, *) "nu_bar scale factor = ", nu_bar_scale + + end subroutine get_upwind_options + + function element_upwind_stabilisation(t_shape, dshape, u_nl_q, j_mat, detwei, & + & diff_q, nu_bar_scheme, nu_bar_scale) result (stab) + !!< Calculate the upwind stabilisation on an individual element. This + !!< implements equation 2.52 in Donea & Huerta (2003): + !!< + !!< / nu + !!< | ----------- (U_nl\dot grad N_j)(U_nl\dot grad N_i) + !!< / ||U_nl||**2 + !!< + !!< Where: + !!< + !!< nu = 0.5*U*dx/d\xi + !!< + type(element_type), intent(in) :: t_shape + !! dshape is nloc x ngi x dim + real, dimension(t_shape%loc, t_shape%quadrature%ngi, t_shape%dim) :: dshape + !! u_nl_q is dim x ngi + real, dimension(t_shape%dim, t_shape%quadrature%ngi), intent(in) :: u_nl_q + !! j_mat is dim x dim x ngi + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 2)), intent(in) :: detwei + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q + integer, optional, intent(in) :: nu_bar_scheme + real, optional, intent(in) :: nu_bar_scale + + real, dimension(t_shape%loc, t_shape%loc) :: stab + + ! Local Variables + + !! This is the factor nu/||U_nl^^2|| + real, dimension(size(detwei)) :: nu_scaled + !! U_nl \dot dshape + real, dimension(t_shape%loc, size(detwei)) :: U_nl_dn + + integer :: i, j, loc, ngi + + loc = t_shape%loc + ngi = size(u_nl_q, 2) + + nu_scaled = nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q = diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + + forall(i = 1:ngi, j = 1:loc) + u_nl_dn(j, i) = dot_product(u_nl_q(:, i), dshape(j, i, :)) + end forall + + forall(i = 1:loc, j = 1:loc) + stab(i, j) = dot_product(u_nl_dn(i, :) * detwei * nu_scaled, u_nl_dn(j, :)) + end forall + + end function element_upwind_stabilisation + + function xi_optimal(u_nl_q, j_mat, diff_q) result(xi_q) + !!< Compute the directional xi factor as in equation 2.44b in Donea & + !!< Huerta (2003) + + real, dimension(:), intent(in) :: U_nl_q + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: diff_q + + real, dimension(size(u_nl_q, 1)) :: xi_q + + integer :: i + real, dimension(size(u_nl_q, 1)) :: pe + + ! Pe = u h_bar + ! ------- + ! 2 kappa + pe = 0.5 * matmul(u_nl_q, matmul(j_mat, inverse(diff_q))) + do i = 1, size(u_nl_q, 1) + if(abs(pe(i)) < tolerance) then + xi_q(i) = 0.0 + else if(pe(i) > tanh_tolerance) then + xi_q(i) = 1.0 - (1.0 / pe(i)) + else if(pe(i) < -tanh_tolerance) then + xi_q(i) = -1.0 - (1.0 / pe(i)) + else + xi_q(i) = (1.0 / tanh(pe(i))) - (1.0 / pe(i)) + end if + end do + + end function xi_optimal + + function xi_doubly_asymptotic(u_nl_q, j_mat, diff_q) result(xi_q) + !!< Compute the directional xi factor using the doubly asymptotic + !!< approximation as in equation 2.29 in Donea & Huerta (2003) + + real, dimension(:), intent(in) :: U_nl_q + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: diff_q + + real, dimension(size(u_nl_q, 1)) :: xi_q + + integer :: i + real, dimension(size(u_nl_q, 1)) :: pe + + ! Pe = u h_bar + ! ------- + ! 2 kappa + pe = 0.5 * matmul(u_nl_q, matmul(j_mat, inverse(diff_q))) + + do i = 1, size(u_nl_q) + if(abs(pe(i)) <= 3.0) then + xi_q(i) = pe(i) / 3.0 + else if(pe(i) > 0.0) then + xi_q(i) = 1.0 + else + xi_q(i) = -1.0 + end if + end do + + end function xi_doubly_asymptotic + + function xi_critical_rule(u_nl_q, j_mat, diff_q) result(xi_q) + !!< Compute the directional xi factor using the critical rule + !!< approximation as in equation 3.3.2 of Brookes and Hughes, Computer + !!< Methods in Applied Mechanics and Engineering 32 (1982) 199-259. + + real, dimension(:), intent(in) :: U_nl_q + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: diff_q + + real, dimension(size(u_nl_q, 1)) :: xi_q + + integer :: i + real, dimension(size(u_nl_q, 1)) :: pe + + ! Pe = u h_bar + ! ------- + ! 2 kappa + pe = 0.5 * matmul(u_nl_q, matmul(j_mat, inverse(diff_q))) + + do i = 1, size(u_nl_q) + if(abs(pe(i)) <= 1.0) then + xi_q(i) = 0.0 + else if(pe(i) > 0.0) then + xi_q(i) = 1.0 - 1.0 / pe(i) + else + xi_q(i) = -1.0 - 1.0 / pe(i) + end if + end do + + end function xi_critical_rule + + function nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q, nu_bar_scheme, nu_bar_scale) result(nu_bar_scaled) + !!< Compute the diffusion parameter nu_bar, scaled by the norm of u + !!< nu_bar / ||u_nl^^2|| + + !! dshape is nloc x ngi x dim + real, dimension(:, :, :) :: dshape + !! u_nl_q is dim x ngi + real, dimension(size(dshape, 3), size(dshape, 2)), intent(in) :: u_nl_q + !! j_mat is dim x dim x ngi + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q + integer, optional, intent(in) :: nu_bar_scheme + real, optional, intent(in) :: nu_bar_scale + + !! This is the factor nu/||u_nl^^2|| + real, dimension(size(u_nl_q, 2)) :: nu_bar_scaled + + integer :: i, lnu_bar_scheme, ngi, loc + real :: lnu_bar_scale, norm_u + + if(present(diff_q)) then + if(present(nu_bar_scheme)) then + lnu_bar_scheme = nu_bar_scheme + else + lnu_bar_scheme = NU_BAR_OPTIMAL + end if else - xi_q(i) = -1.0 + ! If we have no diffusivity then xi = sign(pe) + lnu_bar_scheme = NU_BAR_UNITY end if - end do - - end function xi_doubly_asymptotic + if(present(nu_bar_scale)) then + lnu_bar_scale = nu_bar_scale + else + lnu_bar_scale = 0.5 + end if + assert(lnu_bar_scale >= 0.0) + + loc = size(dshape, 1) + ngi = size(u_nl_q, 2) + + select case(lnu_bar_scheme) + case(NU_BAR_OPTIMAL) + do i = 1, ngi + norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) + ! Avoid divide by zeros or similar where u_nl is close to 0 + if(norm_u < tolerance) then + nu_bar_scaled(i) = 0.0 + else + nu_bar_scaled(i) = dot_product(xi_optimal(u_nl_q(:, i), j_mat(:, :, i), diff_q(:, :, i)), matmul(u_nl_q(:, i), j_mat(:, :, i))) / norm_u + end if + end do + case(NU_BAR_DOUBLY_ASYMPTOTIC) + do i = 1, ngi + norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) + ! Avoid divide by zeros or similar where u_nl is close to 0 + if(norm_u < tolerance) then + nu_bar_scaled(i) = 0.0 + else + nu_bar_scaled(i) = dot_product(xi_doubly_asymptotic(u_nl_q(:, i), j_mat(:, :, i), diff_q(:, :, i)), matmul(u_nl_q(:, i), j_mat(:, :, i))) / norm_u + end if + end do + case(NU_BAR_CRITICAL_RULE) + do i = 1, ngi + norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) + ! Avoid divide by zeros or similar where u_nl is close to 0 + if(norm_u < tolerance) then + nu_bar_scaled(i) = 0.0 + else + nu_bar_scaled(i) = dot_product(xi_critical_rule(u_nl_q(:, i), j_mat(:, :, i), diff_q(:, :, i)), matmul(u_nl_q(:, i), j_mat(:, :, i))) / norm_u + end if + end do + case(NU_BAR_UNITY) + do i = 1, ngi + norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) + ! Avoid divide by zeros or similar where u_nl is close to 0 + if(norm_u < tolerance) then + nu_bar_scaled(i) = 0.0 + else + nu_bar_scaled(i) = sum(abs(matmul(u_nl_q(:, i), j_mat(:, :, i)))) / norm_u + end if + end do + case default + ewrite(-1, *) "For nu_bar scheme: ", lnu_bar_scheme + FLAbort("Invalid nu_bar scheme") + end select + + nu_bar_scaled = nu_bar_scaled * lnu_bar_scale - function xi_critical_rule(u_nl_q, j_mat, diff_q) result(xi_q) - !!< Compute the directional xi factor using the critical rule - !!< approximation as in equation 3.3.2 of Brookes and Hughes, Computer - !!< Methods in Applied Mechanics and Engineering 32 (1982) 199-259. +#ifdef DDEBUG + if(.not. all(nu_bar_scaled >= 0.0)) then + ewrite(-1, *) "nu_bar_scaled = ", nu_bar_scaled + FLAbort("Invalid nu_bar_scaled") + end if +#endif - real, dimension(:), intent(in) :: U_nl_q - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1)), intent(in) :: diff_q + end function nu_bar_scaled_q + + function make_supg_shape(base_shape, dshape, u_nl_q, j_mat, & + & diff_q, nu_bar_scheme, nu_bar_scale) result(test_function) + !!< Construct the SUPG volume element test function. This implements + !!< equation 2.51 in Donea & Huerta (2003). + + type(element_type), target, intent(in) :: base_shape + !! dshape is nloc x ngi x dim + real, dimension(base_shape%loc, base_shape%quadrature%ngi, base_shape%dim) :: dshape + !! u_nl_q is dim x ngi + real, dimension(base_shape%dim, base_shape%quadrature%ngi), intent(in) :: u_nl_q + !! j_mat is dim x dim x ngi + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q + integer, optional, intent(in) :: nu_bar_scheme + real, optional, intent(in) :: nu_bar_scale + + type(element_type) :: test_function + + integer :: coords, degree, dim, i, j, vertices, ngi + !! This is the factor nu/||u_nl^^2|| + real, dimension(size(u_nl_q, 2)) :: nu_bar_scaled + !! u_nl \dot dshape + real, dimension(base_shape%loc, size(u_nl_q, 2)) :: u_nl_dn + type(quadrature_type), pointer :: quad + type(ele_numbering_type), pointer :: ele_num + + quad => base_shape%quadrature + + dim = base_shape%dim + vertices = base_shape%numbering%vertices + ngi = quad%ngi + coords = local_coord_count(base_shape) + degree = base_shape%degree + + ! Step 1: Generate a new shape + ele_num => & + &find_element_numbering(& + &vertices = vertices, dimension = dim, degree = degree) + call allocate(test_function, ele_num=ele_num,ngi=ngi) + + test_function%degree = degree + test_function%quadrature = quad + call incref(quad) + + test_function%dn = huge(0.0) + if (associated(test_function%n_s)) then + test_function%n_s = huge(0.0) + end if + if (associated(test_function%dn_s)) then + test_function%dn_s = huge(0.0) + end if + deallocate(test_function%spoly) + nullify(test_function%spoly) + deallocate(test_function%dspoly) + nullify(test_function%dspoly) - real, dimension(size(u_nl_q, 1)) :: xi_q + ! Step 2: Calculate the scaled nu and u dot nabla - integer :: i - real, dimension(size(u_nl_q, 1)) :: pe + nu_bar_scaled = nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q = diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - ! Pe = u h_bar - ! ------- - ! 2 kappa - pe = 0.5 * matmul(u_nl_q, matmul(j_mat, inverse(diff_q))) + forall(i = 1:ngi, j = 1:base_shape%loc) + u_nl_dn(j, i) = dot_product(u_nl_q(:, i), dshape(j, i, :)) + end forall - do i = 1, size(u_nl_q) - if(abs(pe(i)) <= 1.0) then - xi_q(i) = 0.0 - else if(pe(i) > 0.0) then - xi_q(i) = 1.0 - 1.0 / pe(i) - else - xi_q(i) = -1.0 - 1.0 / pe(i) - end if - end do + ! Step 3: Generate the test function - end function xi_critical_rule + do i = 1, base_shape%loc + test_function%n(i, :) = base_shape%n(i, :) + nu_bar_scaled * u_nl_dn(i, :) + end do - function nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q, nu_bar_scheme, nu_bar_scale) result(nu_bar_scaled) - !!< Compute the diffusion parameter nu_bar, scaled by the norm of u - !!< nu_bar / ||u_nl^^2|| + end function make_supg_shape - !! dshape is nloc x ngi x dim - real, dimension(:, :, :) :: dshape - !! u_nl_q is dim x ngi - real, dimension(size(dshape, 3), size(dshape, 2)), intent(in) :: u_nl_q - !! j_mat is dim x dim x ngi - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q - integer, optional, intent(in) :: nu_bar_scheme - real, optional, intent(in) :: nu_bar_scale + function make_supg_element(base_shape) result(test_function) + !!< Construct the SUPG volume element object. This is to be constructed + !!< outside the element loop so the actual values are set later. - !! This is the factor nu/||u_nl^^2|| - real, dimension(size(u_nl_q, 2)) :: nu_bar_scaled + type(element_type), target, intent(in) :: base_shape + type(element_type) :: test_function - integer :: i, lnu_bar_scheme, ngi, loc - real :: lnu_bar_scale, norm_u + test_function=make_element_shape(base_shape) - if(present(diff_q)) then - if(present(nu_bar_scheme)) then - lnu_bar_scheme = nu_bar_scheme - else - lnu_bar_scheme = NU_BAR_OPTIMAL + test_function%n = huge(0.0) + test_function%dn = huge(0.0) + if (associated(test_function%n_s)) then + test_function%n_s = huge(0.0) end if - else - ! If we have no diffusivity then xi = sign(pe) - lnu_bar_scheme = NU_BAR_UNITY - end if - if(present(nu_bar_scale)) then - lnu_bar_scale = nu_bar_scale - else - lnu_bar_scale = 0.5 - end if - assert(lnu_bar_scale >= 0.0) - - loc = size(dshape, 1) - ngi = size(u_nl_q, 2) - - select case(lnu_bar_scheme) - case(NU_BAR_OPTIMAL) - do i = 1, ngi - norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) - ! Avoid divide by zeros or similar where u_nl is close to 0 - if(norm_u < tolerance) then - nu_bar_scaled(i) = 0.0 - else - nu_bar_scaled(i) = dot_product(xi_optimal(u_nl_q(:, i), j_mat(:, :, i), diff_q(:, :, i)), matmul(u_nl_q(:, i), j_mat(:, :, i))) / norm_u - end if - end do - case(NU_BAR_DOUBLY_ASYMPTOTIC) - do i = 1, ngi - norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) - ! Avoid divide by zeros or similar where u_nl is close to 0 - if(norm_u < tolerance) then - nu_bar_scaled(i) = 0.0 - else - nu_bar_scaled(i) = dot_product(xi_doubly_asymptotic(u_nl_q(:, i), j_mat(:, :, i), diff_q(:, :, i)), matmul(u_nl_q(:, i), j_mat(:, :, i))) / norm_u - end if - end do - case(NU_BAR_CRITICAL_RULE) - do i = 1, ngi - norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) - ! Avoid divide by zeros or similar where u_nl is close to 0 - if(norm_u < tolerance) then - nu_bar_scaled(i) = 0.0 - else - nu_bar_scaled(i) = dot_product(xi_critical_rule(u_nl_q(:, i), j_mat(:, :, i), diff_q(:, :, i)), matmul(u_nl_q(:, i), j_mat(:, :, i))) / norm_u - end if - end do - case(NU_BAR_UNITY) - do i = 1, ngi - norm_u = dot_product(u_nl_q(:, i), u_nl_q(:, i)) - ! Avoid divide by zeros or similar where u_nl is close to 0 - if(norm_u < tolerance) then - nu_bar_scaled(i) = 0.0 - else - nu_bar_scaled(i) = sum(abs(matmul(u_nl_q(:, i), j_mat(:, :, i)))) / norm_u - end if - end do - case default - ewrite(-1, *) "For nu_bar scheme: ", lnu_bar_scheme - FLAbort("Invalid nu_bar scheme") - end select - - nu_bar_scaled = nu_bar_scaled * lnu_bar_scale - -#ifdef DDEBUG - if(.not. all(nu_bar_scaled >= 0.0)) then - ewrite(-1, *) "nu_bar_scaled = ", nu_bar_scaled - FLAbort("Invalid nu_bar_scaled") - end if -#endif - - end function nu_bar_scaled_q - - function make_supg_shape(base_shape, dshape, u_nl_q, j_mat, & - & diff_q, nu_bar_scheme, nu_bar_scale) result(test_function) - !!< Construct the SUPG volume element test function. This implements - !!< equation 2.51 in Donea & Huerta (2003). - - type(element_type), target, intent(in) :: base_shape - !! dshape is nloc x ngi x dim - real, dimension(base_shape%loc, base_shape%quadrature%ngi, base_shape%dim) :: dshape - !! u_nl_q is dim x ngi - real, dimension(base_shape%dim, base_shape%quadrature%ngi), intent(in) :: u_nl_q - !! j_mat is dim x dim x ngi - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q - integer, optional, intent(in) :: nu_bar_scheme - real, optional, intent(in) :: nu_bar_scale - - type(element_type) :: test_function - - integer :: coords, degree, dim, i, j, vertices, ngi - !! This is the factor nu/||u_nl^^2|| - real, dimension(size(u_nl_q, 2)) :: nu_bar_scaled - !! u_nl \dot dshape - real, dimension(base_shape%loc, size(u_nl_q, 2)) :: u_nl_dn - type(quadrature_type), pointer :: quad - type(ele_numbering_type), pointer :: ele_num - - quad => base_shape%quadrature - - dim = base_shape%dim - vertices = base_shape%numbering%vertices - ngi = quad%ngi - coords = local_coord_count(base_shape) - degree = base_shape%degree - - ! Step 1: Generate a new shape - ele_num => & - &find_element_numbering(& - &vertices = vertices, dimension = dim, degree = degree) - call allocate(test_function, ele_num=ele_num,ngi=ngi) - - test_function%degree = degree - test_function%quadrature = quad - call incref(quad) - - test_function%dn = huge(0.0) - if (associated(test_function%n_s)) then - test_function%n_s = huge(0.0) - end if - if (associated(test_function%dn_s)) then - test_function%dn_s = huge(0.0) - end if - deallocate(test_function%spoly) - nullify(test_function%spoly) - deallocate(test_function%dspoly) - nullify(test_function%dspoly) - - ! Step 2: Calculate the scaled nu and u dot nabla - - nu_bar_scaled = nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q = diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - - forall(i = 1:ngi, j = 1:base_shape%loc) - u_nl_dn(j, i) = dot_product(u_nl_q(:, i), dshape(j, i, :)) - end forall - - ! Step 3: Generate the test function - - do i = 1, base_shape%loc - test_function%n(i, :) = base_shape%n(i, :) + nu_bar_scaled * u_nl_dn(i, :) - end do - - end function make_supg_shape - - function make_supg_element(base_shape) result(test_function) - !!< Construct the SUPG volume element object. This is to be constructed - !!< outside the element loop so the actual values are set later. - - type(element_type), target, intent(in) :: base_shape - type(element_type) :: test_function - - test_function=make_element_shape(base_shape) - - test_function%n = huge(0.0) - test_function%dn = huge(0.0) - if (associated(test_function%n_s)) then - test_function%n_s = huge(0.0) - end if - if (associated(test_function%dn_s)) then - test_function%dn_s = huge(0.0) - end if - deallocate(test_function%spoly) - nullify(test_function%spoly) - deallocate(test_function%dspoly) - nullify(test_function%dspoly) - - end function make_supg_element - - subroutine supg_test_function(test_function, base_shape, dshape, u_nl_q, j_mat, & - & diff_q, nu_bar_scheme, nu_bar_scale) - !!< Construct the SUPG volume element test function. This implements - !!< equation 2.51 in Donea & Huerta (2003). - type(element_type), intent(inout) :: test_function - type(element_type), target, intent(in) :: base_shape - !! dshape is nloc x ngi x dim - real, dimension(base_shape%loc, base_shape%quadrature%ngi, base_shape%dim) :: dshape - !! u_nl_q is dim x ngi - real, dimension(base_shape%dim, base_shape%quadrature%ngi), intent(in) :: u_nl_q - !! j_mat is dim x dim x ngi - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat - real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q - integer, optional, intent(in) :: nu_bar_scheme - real, optional, intent(in) :: nu_bar_scale - - integer :: i, j - !! This is the factor nu/||u_nl^^2|| - real, dimension(size(u_nl_q, 2)) :: nu_bar_scaled - !! u_nl \dot dshape - real, dimension(base_shape%loc, size(u_nl_q, 2)) :: u_nl_dn - - ! Step 1: Calculate the scaled nu and u dot nabla - - nu_bar_scaled = nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q = diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) - - forall(i = 1:base_shape%quadrature%ngi, j = 1:base_shape%loc) - u_nl_dn(j, i) = dot_product(u_nl_q(:, i), dshape(j, i, :)) - end forall - - ! Step 2: Generate the test function - - do i = 1, base_shape%loc - test_function%n(i, :) = base_shape%n(i, :) + nu_bar_scaled * u_nl_dn(i, :) - end do - - end subroutine supg_test_function + if (associated(test_function%dn_s)) then + test_function%dn_s = huge(0.0) + end if + deallocate(test_function%spoly) + nullify(test_function%spoly) + deallocate(test_function%dspoly) + nullify(test_function%dspoly) + + end function make_supg_element + + subroutine supg_test_function(test_function, base_shape, dshape, u_nl_q, j_mat, & + & diff_q, nu_bar_scheme, nu_bar_scale) + !!< Construct the SUPG volume element test function. This implements + !!< equation 2.51 in Donea & Huerta (2003). + type(element_type), intent(inout) :: test_function + type(element_type), target, intent(in) :: base_shape + !! dshape is nloc x ngi x dim + real, dimension(base_shape%loc, base_shape%quadrature%ngi, base_shape%dim) :: dshape + !! u_nl_q is dim x ngi + real, dimension(base_shape%dim, base_shape%quadrature%ngi), intent(in) :: u_nl_q + !! j_mat is dim x dim x ngi + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), intent(in) :: j_mat + real, dimension(size(u_nl_q, 1), size(u_nl_q, 1), size(u_nl_q, 2)), optional, intent(in) :: diff_q + integer, optional, intent(in) :: nu_bar_scheme + real, optional, intent(in) :: nu_bar_scale + + integer :: i, j + !! This is the factor nu/||u_nl^^2|| + real, dimension(size(u_nl_q, 2)) :: nu_bar_scaled + !! u_nl \dot dshape + real, dimension(base_shape%loc, size(u_nl_q, 2)) :: u_nl_dn + + ! Step 1: Calculate the scaled nu and u dot nabla + + nu_bar_scaled = nu_bar_scaled_q(dshape, u_nl_q, j_mat, diff_q = diff_q, nu_bar_scheme = nu_bar_scheme, nu_bar_scale = nu_bar_scale) + + forall(i = 1:base_shape%quadrature%ngi, j = 1:base_shape%loc) + u_nl_dn(j, i) = dot_product(u_nl_q(:, i), dshape(j, i, :)) + end forall + + ! Step 2: Generate the test function + + do i = 1, base_shape%loc + test_function%n(i, :) = base_shape%n(i, :) + nu_bar_scaled * u_nl_dn(i, :) + end do + + end subroutine supg_test_function end module upwind_stabilisation diff --git a/assemble/Vertical_Balance_Pressure.F90 b/assemble/Vertical_Balance_Pressure.F90 index fea0922a70..54d8adb978 100644 --- a/assemble/Vertical_Balance_Pressure.F90 +++ b/assemble/Vertical_Balance_Pressure.F90 @@ -31,277 +31,277 @@ module vertical_balance_pressure - use fldebug - use elements - use parallel_tools - use spud - use sparse_tools - use transform_elements - use fetools - use parallel_fields - use fields - use profiler - use state_module - use boundary_conditions - use upwind_stabilisation - use solvers - use state_matrices_module - implicit none - - private - - public calculate_vertical_balance_pressure, & - & subtract_vertical_balance_pressure_gradient - - character(len = *), parameter, public :: vbp_name = "VerticalBalancePressure" - - contains - - subroutine calculate_vertical_balance_pressure(state) - type(state_type), intent(inout) :: state - - integer :: stat - type(scalar_field), pointer :: vbp - - type(csr_matrix), pointer :: matrix - type(scalar_field) :: rhs - logical :: assemble_matrix - - vbp => extract_scalar_field(state, vbp_name, stat = stat) - if(stat /= 0) return - - ewrite(1,*) 'In calculate_vertical_balance_pressure' - if(continuity(vbp) < 0) then - FLExit("VerticalBalancePressure requires a continuous mesh") - end if + use fldebug + use elements + use parallel_tools + use spud + use sparse_tools + use transform_elements + use fetools + use parallel_fields + use fields + use profiler + use state_module + use boundary_conditions + use upwind_stabilisation + use solvers + use state_matrices_module + implicit none + + private + + public calculate_vertical_balance_pressure, & + & subtract_vertical_balance_pressure_gradient + + character(len = *), parameter, public :: vbp_name = "VerticalBalancePressure" + +contains + + subroutine calculate_vertical_balance_pressure(state) + type(state_type), intent(inout) :: state + + integer :: stat + type(scalar_field), pointer :: vbp + + type(csr_matrix), pointer :: matrix + type(scalar_field) :: rhs + logical :: assemble_matrix + + vbp => extract_scalar_field(state, vbp_name, stat = stat) + if(stat /= 0) return + + ewrite(1,*) 'In calculate_vertical_balance_pressure' + if(continuity(vbp) < 0) then + FLExit("VerticalBalancePressure requires a continuous mesh") + end if - matrix => get_vertical_balance_pressure_matrix(state, assemble_matrix=assemble_matrix) - call allocate(rhs, vbp%mesh, "VerticalBalancePressureRHS") + matrix => get_vertical_balance_pressure_matrix(state, assemble_matrix=assemble_matrix) + call allocate(rhs, vbp%mesh, "VerticalBalancePressureRHS") - ewrite(2,*) 'assembling matrix: ', assemble_matrix + ewrite(2,*) 'assembling matrix: ', assemble_matrix - call profiler_tic(vbp, "assembly") - call assemble_vertical_balance_pressure(state, vbp, matrix, rhs, assemble_matrix) - call profiler_toc(vbp, "assembly") + call profiler_tic(vbp, "assembly") + call assemble_vertical_balance_pressure(state, vbp, matrix, rhs, assemble_matrix) + call profiler_toc(vbp, "assembly") - call petsc_solve(vbp, matrix, rhs) + call petsc_solve(vbp, matrix, rhs) - call deallocate(rhs) + call deallocate(rhs) - ewrite_minmax(vbp) + ewrite_minmax(vbp) - end subroutine calculate_vertical_balance_pressure + end subroutine calculate_vertical_balance_pressure - subroutine assemble_vertical_balance_pressure(state, vbp, matrix, rhs, assemble_matrix) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: vbp - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - logical, intent(in) :: assemble_matrix + subroutine assemble_vertical_balance_pressure(state, vbp, matrix, rhs, assemble_matrix) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: vbp + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + logical, intent(in) :: assemble_matrix - real :: gravity_magnitude - type(scalar_field), pointer :: buoyancy - type(vector_field), pointer :: coordinate, gravity - type(scalar_field) :: lbuoyancy + real :: gravity_magnitude + type(scalar_field), pointer :: buoyancy + type(vector_field), pointer :: coordinate, gravity + type(scalar_field) :: lbuoyancy - integer :: ele + integer :: ele - ewrite(1,*) 'In assemble_vertical_balance_pressure' + ewrite(1,*) 'In assemble_vertical_balance_pressure' - coordinate => extract_vector_field(state, "Coordinate") - assert(coordinate%dim == mesh_dim(vbp)) - assert(ele_count(coordinate) == ele_count(vbp)) + coordinate => extract_vector_field(state, "Coordinate") + assert(coordinate%dim == mesh_dim(vbp)) + assert(ele_count(coordinate) == ele_count(vbp)) - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") - assert(ele_count(buoyancy) == ele_count(vbp)) - ewrite_minmax(buoyancy) - call allocate(lbuoyancy, buoyancy%mesh, "VerticalBalancePressureBuoyancy") - call set(lbuoyancy, buoyancy) - call scale(lbuoyancy, gravity_magnitude) + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + buoyancy => extract_scalar_field(state, "VelocityBuoyancyDensity") + assert(ele_count(buoyancy) == ele_count(vbp)) + ewrite_minmax(buoyancy) + call allocate(lbuoyancy, buoyancy%mesh, "VerticalBalancePressureBuoyancy") + call set(lbuoyancy, buoyancy) + call scale(lbuoyancy, gravity_magnitude) - gravity => extract_vector_field(state, "GravityDirection") - assert(gravity%dim == mesh_dim(vbp)) - assert(ele_count(gravity) == ele_count(vbp)) + gravity => extract_vector_field(state, "GravityDirection") + assert(gravity%dim == mesh_dim(vbp)) + assert(ele_count(gravity) == ele_count(vbp)) - if(assemble_matrix) call zero(matrix) - call zero(rhs) + if(assemble_matrix) call zero(matrix) + call zero(rhs) - do ele = 1, element_count(vbp) - call assemble_vertical_balance_pressure_element(matrix, rhs, & - vbp, coordinate, lbuoyancy, gravity, & - ele, assemble_matrix) - end do + do ele = 1, element_count(vbp) + call assemble_vertical_balance_pressure_element(matrix, rhs, & + vbp, coordinate, lbuoyancy, gravity, & + ele, assemble_matrix) + end do - ! boundary condition stuff - call apply_dirichlet_conditions(matrix, rhs, vbp) + ! boundary condition stuff + call apply_dirichlet_conditions(matrix, rhs, vbp) - ewrite_minmax(rhs) + ewrite_minmax(rhs) - call deallocate(lbuoyancy) + call deallocate(lbuoyancy) - end subroutine assemble_vertical_balance_pressure + end subroutine assemble_vertical_balance_pressure - subroutine assemble_vertical_balance_pressure_element(matrix, rhs, & - vbp, coordinate, buoyancy, gravity, & - ele, assemble_matrix) - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs + subroutine assemble_vertical_balance_pressure_element(matrix, rhs, & + vbp, coordinate, buoyancy, gravity, & + ele, assemble_matrix) + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs - type(scalar_field), intent(in) :: vbp - type(vector_field), intent(in) :: coordinate - type(scalar_field), intent(in) :: buoyancy - type(vector_field), intent(in) :: gravity + type(scalar_field), intent(in) :: vbp + type(vector_field), intent(in) :: coordinate + type(scalar_field), intent(in) :: buoyancy + type(vector_field), intent(in) :: gravity - integer, intent(in) :: ele - logical, intent(in) :: assemble_matrix + integer, intent(in) :: ele + logical, intent(in) :: assemble_matrix - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(vbp, ele)) :: detwei - real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), mesh_dim(vbp)) :: dvbp_t - type(element_type), pointer :: vbp_shape - real, dimension(gravity%dim, ele_ngi(gravity, ele)) :: gravity_at_quad + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(vbp, ele)) :: detwei + real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), mesh_dim(vbp)) :: dvbp_t + type(element_type), pointer :: vbp_shape + real, dimension(gravity%dim, ele_ngi(gravity, ele)) :: gravity_at_quad - integer :: gi - real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), 1) :: dvbp_z + integer :: gi + real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), 1) :: dvbp_z - ! What we will be adding to the matrix and RHS - assemble these as we - ! go, so that we only do the calculations we really need - real, dimension(ele_loc(vbp, ele)) :: rhs_addto - real, dimension(ele_loc(vbp, ele), ele_loc(vbp, ele)) :: matrix_addto + ! What we will be adding to the matrix and RHS - assemble these as we + ! go, so that we only do the calculations we really need + real, dimension(ele_loc(vbp, ele)) :: rhs_addto + real, dimension(ele_loc(vbp, ele), ele_loc(vbp, ele)) :: matrix_addto #ifdef DDEBUG - assert(ele_ngi(coordinate, ele) == ele_ngi(vbp, ele)) - assert(ele_ngi(gravity, ele) == ele_ngi(vbp, ele)) - assert(ele_ngi(buoyancy, ele) == ele_ngi(vbp, ele)) + assert(ele_ngi(coordinate, ele) == ele_ngi(vbp, ele)) + assert(ele_ngi(gravity, ele) == ele_ngi(vbp, ele)) + assert(ele_ngi(buoyancy, ele) == ele_ngi(vbp, ele)) #endif - matrix_addto = 0.0 - rhs_addto = 0.0 + matrix_addto = 0.0 + rhs_addto = 0.0 - vbp_shape => ele_shape(vbp, ele) + vbp_shape => ele_shape(vbp, ele) - call transform_to_physical(coordinate, ele, vbp_shape, & - dshape=dvbp_t, detwei=detwei) + call transform_to_physical(coordinate, ele, vbp_shape, & + dshape=dvbp_t, detwei=detwei) - gravity_at_quad = ele_val_at_quad(gravity, ele) + gravity_at_quad = ele_val_at_quad(gravity, ele) - ! convert the full gradient of the shape function into a vertical - ! derivative only using the gravity direction - do gi = 1, size(gravity_at_quad, 2) - dvbp_z(:,gi,1) = matmul(dvbp_t(:,gi,:), gravity_at_quad(:,gi)) - end do + ! convert the full gradient of the shape function into a vertical + ! derivative only using the gravity direction + do gi = 1, size(gravity_at_quad, 2) + dvbp_z(:,gi,1) = matmul(dvbp_t(:,gi,:), gravity_at_quad(:,gi)) + end do - if(assemble_matrix) then + if(assemble_matrix) then - call add_matrix_element(ele, vbp, & - dvbp_z, detwei, & - matrix_addto) - end if + call add_matrix_element(ele, vbp, & + dvbp_z, detwei, & + matrix_addto) + end if - call add_buoyancy_element(ele, vbp, & - buoyancy, dvbp_z, detwei, rhs_addto) + call add_buoyancy_element(ele, vbp, & + buoyancy, dvbp_z, detwei, rhs_addto) - element_nodes => ele_nodes(vbp, ele) - if(assemble_matrix) call addto(matrix, element_nodes, element_nodes, matrix_addto) - call addto(rhs, element_nodes, rhs_addto) + element_nodes => ele_nodes(vbp, ele) + if(assemble_matrix) call addto(matrix, element_nodes, element_nodes, matrix_addto) + call addto(rhs, element_nodes, rhs_addto) - end subroutine assemble_vertical_balance_pressure_element + end subroutine assemble_vertical_balance_pressure_element - subroutine add_matrix_element(ele, vbp, & - dvbp_z, detwei, & - matrix_addto) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: vbp - real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), 1), intent(in) :: dvbp_z - real, dimension(ele_ngi(vbp, ele)), intent(in) :: detwei - real, dimension(ele_loc(vbp, ele), ele_loc(vbp, ele)), intent(inout) :: matrix_addto + subroutine add_matrix_element(ele, vbp, & + dvbp_z, detwei, & + matrix_addto) + integer, intent(in) :: ele + type(scalar_field), intent(in) :: vbp + real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), 1), intent(in) :: dvbp_z + real, dimension(ele_ngi(vbp, ele)), intent(in) :: detwei + real, dimension(ele_loc(vbp, ele), ele_loc(vbp, ele)), intent(inout) :: matrix_addto - ! element matrix - ! / - ! | (grav dot grad N_A) (grav dot grad N_B) dV - ! / - matrix_addto = matrix_addto + dshape_dot_dshape(dvbp_z, dvbp_z, detwei) + ! element matrix + ! / + ! | (grav dot grad N_A) (grav dot grad N_B) dV + ! / + matrix_addto = matrix_addto + dshape_dot_dshape(dvbp_z, dvbp_z, detwei) - end subroutine add_matrix_element + end subroutine add_matrix_element - subroutine add_buoyancy_element(ele, & - vbp, buoyancy, & - dvbp_z, detwei, rhs_addto) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: vbp - type(scalar_field), intent(in) :: buoyancy - real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), 1), intent(in) :: dvbp_z - real, dimension(ele_ngi(vbp, ele)), intent(in) :: detwei - real, dimension(ele_loc(vbp, ele)), intent(inout) :: rhs_addto + subroutine add_buoyancy_element(ele, & + vbp, buoyancy, & + dvbp_z, detwei, rhs_addto) + integer, intent(in) :: ele + type(scalar_field), intent(in) :: vbp + type(scalar_field), intent(in) :: buoyancy + real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), 1), intent(in) :: dvbp_z + real, dimension(ele_ngi(vbp, ele)), intent(in) :: detwei + real, dimension(ele_loc(vbp, ele)), intent(inout) :: rhs_addto - real, dimension(1, ele_ngi(buoyancy, ele)) :: buoyancy_at_quad + real, dimension(1, ele_ngi(buoyancy, ele)) :: buoyancy_at_quad - buoyancy_at_quad(1, :) = ele_val_at_quad(buoyancy, ele) + buoyancy_at_quad(1, :) = ele_val_at_quad(buoyancy, ele) - rhs_addto = rhs_addto + dshape_dot_vector_rhs(dvbp_z, buoyancy_at_quad, detwei) + rhs_addto = rhs_addto + dshape_dot_vector_rhs(dvbp_z, buoyancy_at_quad, detwei) - end subroutine add_buoyancy_element + end subroutine add_buoyancy_element - subroutine subtract_vertical_balance_pressure_gradient(mom_rhs, state) - !!< Subtract the VerticalBalancePressure gradient from the momentum equation - !!< RHS + subroutine subtract_vertical_balance_pressure_gradient(mom_rhs, state) + !!< Subtract the VerticalBalancePressure gradient from the momentum equation + !!< RHS - type(vector_field), intent(inout) :: mom_rhs - type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: mom_rhs + type(state_type), intent(inout) :: state - integer :: i - type(vector_field), pointer :: positions - type(scalar_field), pointer :: vbp + integer :: i + type(vector_field), pointer :: positions + type(scalar_field), pointer :: vbp - ewrite(1, *) "In subtract_vertical_balance_pressure_gradient" + ewrite(1, *) "In subtract_vertical_balance_pressure_gradient" - vbp => extract_scalar_field(state, vbp_name) + vbp => extract_scalar_field(state, vbp_name) - ! Apply to momentum equation - assert(ele_count(vbp) == ele_count(mom_rhs)) + ! Apply to momentum equation + assert(ele_count(vbp) == ele_count(mom_rhs)) - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mom_rhs%dim) - assert(ele_count(positions) == ele_count(mom_rhs)) + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mom_rhs%dim) + assert(ele_count(positions) == ele_count(mom_rhs)) - ewrite_minmax(mom_rhs) + ewrite_minmax(mom_rhs) - do i = 1, ele_count(mom_rhs) - if((continuity(mom_rhs)>=0).or.(element_owned(mom_rhs, i))) then - call subtract_given_vertical_balance_pressure_gradient_element(i, positions,vbp, mom_rhs) - end if - end do + do i = 1, ele_count(mom_rhs) + if((continuity(mom_rhs)>=0).or.(element_owned(mom_rhs, i))) then + call subtract_given_vertical_balance_pressure_gradient_element(i, positions,vbp, mom_rhs) + end if + end do - ewrite_minmax(mom_rhs) + ewrite_minmax(mom_rhs) - ewrite(1, *) "Exiting subtract_vertical_balance_pressure_gradient" + ewrite(1, *) "Exiting subtract_vertical_balance_pressure_gradient" - end subroutine subtract_vertical_balance_pressure_gradient + end subroutine subtract_vertical_balance_pressure_gradient - subroutine subtract_given_vertical_balance_pressure_gradient_element(ele, positions, vbp, mom_rhs) - !!< Subtract the element-wise contribution of the VerticalBalancePressure - !!< gradient from the momentum equation RHS + subroutine subtract_given_vertical_balance_pressure_gradient_element(ele, positions, vbp, mom_rhs) + !!< Subtract the element-wise contribution of the VerticalBalancePressure + !!< gradient from the momentum equation RHS - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: vbp - type(vector_field), intent(inout) :: mom_rhs + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: vbp + type(vector_field), intent(inout) :: mom_rhs - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), mom_rhs%dim) :: dn_t + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(vbp, ele), ele_ngi(vbp, ele), mom_rhs%dim) :: dn_t - assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) - assert(ele_ngi(vbp, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(positions, ele) == ele_ngi(mom_rhs, ele)) + assert(ele_ngi(vbp, ele) == ele_ngi(mom_rhs, ele)) - call transform_to_physical(positions, ele, ele_shape(vbp, ele), & + call transform_to_physical(positions, ele, ele_shape(vbp, ele), & & dshape = dn_t, detwei = detwei) - ! / - ! | -N_A grad vbp dV - ! / - call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_grad_at_quad(vbp, ele, dn_t), detwei)) + ! / + ! | -N_A grad vbp dV + ! / + call addto(mom_rhs, ele_nodes(mom_rhs, ele), -shape_vector_rhs(ele_shape(mom_rhs, ele), ele_grad_at_quad(vbp, ele, dn_t), detwei)) - end subroutine subtract_given_vertical_balance_pressure_gradient_element + end subroutine subtract_given_vertical_balance_pressure_gradient_element end module vertical_balance_pressure diff --git a/assemble/Vorticity_Diagnostics.F90 b/assemble/Vorticity_Diagnostics.F90 index f56c375a93..4c4315cb64 100644 --- a/assemble/Vorticity_Diagnostics.F90 +++ b/assemble/Vorticity_Diagnostics.F90 @@ -29,293 +29,293 @@ module vorticity_diagnostics - use fldebug - use coriolis_module - use fetools - use fields - use state_module - use field_derivatives - use field_options - use state_fields_module + use fldebug + use coriolis_module + use fetools + use fields + use state_module + use field_derivatives + use field_options + use state_fields_module - implicit none + implicit none - private + private - public :: calculate_vorticity, calculate_planetary_vorticity, & - & calculate_absolute_vorticity, calculate_potential_vorticity, & - & calculate_relative_potential_vorticity + public :: calculate_vorticity, calculate_planetary_vorticity, & + & calculate_absolute_vorticity, calculate_potential_vorticity, & + & calculate_relative_potential_vorticity contains - subroutine calculate_vorticity(state, vort_field) - !!< Calculate the (relative) vorticity field + subroutine calculate_vorticity(state, vort_field) + !!< Calculate the (relative) vorticity field - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: vort_field + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: vort_field - type(vector_field), pointer :: positions, v_field + type(vector_field), pointer :: positions, v_field - positions => extract_vector_field(state, "Coordinate") - v_field => extract_vector_field(state, "Velocity") + positions => extract_vector_field(state, "Coordinate") + v_field => extract_vector_field(state, "Velocity") - call curl(v_field, positions, curl_field = vort_field) + call curl(v_field, positions, curl_field = vort_field) - end subroutine calculate_vorticity + end subroutine calculate_vorticity - subroutine calculate_planetary_vorticity(state, vort_field) - !!< Calculate the planetary vorticity field + subroutine calculate_planetary_vorticity(state, vort_field) + !!< Calculate the planetary vorticity field - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: vort_field + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: vort_field - integer :: i - type(vector_field) :: positions + integer :: i + type(vector_field) :: positions - if(mesh_dim(vort_field) /= 3) then - ewrite(-1,*) "You have a mesh of dimension ",mesh_dim(vort_field) - FLExit("PlanetaryVorticity only works in 3D") - end if + if(mesh_dim(vort_field) /= 3) then + ewrite(-1,*) "You have a mesh of dimension ",mesh_dim(vort_field) + FLExit("PlanetaryVorticity only works in 3D") + end if - positions = get_nodal_coordinate_field(state, vort_field%mesh) + positions = get_nodal_coordinate_field(state, vort_field%mesh) - call zero(vort_field, U_) - call zero(vort_field, V_) - do i = 1, node_count(vort_field) - call set(vort_field, W_, i, & - sum(coriolis(spread(node_val(positions, i), 2, 1)), 1)) - end do + call zero(vort_field, U_) + call zero(vort_field, V_) + do i = 1, node_count(vort_field) + call set(vort_field, W_, i, & + sum(coriolis(spread(node_val(positions, i), 2, 1)), 1)) + end do - call deallocate(positions) + call deallocate(positions) - end subroutine calculate_planetary_vorticity + end subroutine calculate_planetary_vorticity - subroutine calculate_absolute_vorticity(state, vort_field) - !!< Calculate the absolute vorticity field + subroutine calculate_absolute_vorticity(state, vort_field) + !!< Calculate the absolute vorticity field - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: vort_field + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: vort_field - type(vector_field) :: planetary_vorticity + type(vector_field) :: planetary_vorticity - call calculate_vorticity(state, vort_field) + call calculate_vorticity(state, vort_field) - call allocate(planetary_vorticity, vort_field%dim, vort_field%mesh, "PlanetaryVorticity") - call calculate_planetary_vorticity(state, planetary_vorticity) - call addto(vort_field, planetary_vorticity) - call deallocate(planetary_vorticity) + call allocate(planetary_vorticity, vort_field%dim, vort_field%mesh, "PlanetaryVorticity") + call calculate_planetary_vorticity(state, planetary_vorticity) + call addto(vort_field, planetary_vorticity) + call deallocate(planetary_vorticity) - end subroutine calculate_absolute_vorticity + end subroutine calculate_absolute_vorticity - subroutine calculate_potential_vorticity(state, pv) - !!< Compute the Ertel potential vorticity: - !!< (f + curl u) dot grad rho' + subroutine calculate_potential_vorticity(state, pv) + !!< Compute the Ertel potential vorticity: + !!< (f + curl u) dot grad rho' - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: pv + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: pv - integer :: i - type(scalar_field), pointer :: masslump - type(scalar_field), pointer :: perturbation_density - type(vector_field), pointer :: positions, velocity + integer :: i + type(scalar_field), pointer :: masslump + type(scalar_field), pointer :: perturbation_density + type(vector_field), pointer :: positions, velocity - ewrite(1, *) "In calculate_potential_vorticity" - ewrite(2, *) "Computing PV for state " // trim(state%name) + ewrite(1, *) "In calculate_potential_vorticity" + ewrite(2, *) "Computing PV for state " // trim(state%name) - if(pv%mesh%continuity /= 0) then - ewrite(-1,*) "Your mesh, ",trim(pv%mesh%name)," is not continuous" - FLExit("PotentialVorticity requires a continuous mesh") - end if - if(mesh_dim(pv) /= 3) then - ewrite(-1,*) "Your mesh is of dimension ", mesh_dim(pv) - FLExit("PotentialVorticity only works in 3D") - end if + if(pv%mesh%continuity /= 0) then + ewrite(-1,*) "Your mesh, ",trim(pv%mesh%name)," is not continuous" + FLExit("PotentialVorticity requires a continuous mesh") + end if + if(mesh_dim(pv) /= 3) then + ewrite(-1,*) "Your mesh is of dimension ", mesh_dim(pv) + FLExit("PotentialVorticity only works in 3D") + end if - ! Extract the Coordinate field - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mesh_dim(pv)) - assert(ele_count(positions) == ele_count(pv)) + ! Extract the Coordinate field + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mesh_dim(pv)) + assert(ele_count(positions) == ele_count(pv)) - ! Extract velocity - velocity => extract_vector_field(state, "Velocity") - assert(velocity%dim == mesh_dim(pv)) - assert(ele_count(velocity) == ele_count(pv)) - ewrite_minmax(velocity) + ! Extract velocity + velocity => extract_vector_field(state, "Velocity") + assert(velocity%dim == mesh_dim(pv)) + assert(ele_count(velocity) == ele_count(pv)) + ewrite_minmax(velocity) - ! Extract perturbation density - perturbation_density => extract_scalar_field(state, "PerturbationDensity") - assert(mesh_dim(perturbation_density) == mesh_dim(pv)) - assert(ele_count(perturbation_density) == ele_count(pv)) - ewrite_minmax(perturbation_density) + ! Extract perturbation density + perturbation_density => extract_scalar_field(state, "PerturbationDensity") + assert(mesh_dim(perturbation_density) == mesh_dim(pv)) + assert(ele_count(perturbation_density) == ele_count(pv)) + ewrite_minmax(perturbation_density) - ! Assemble - call zero(pv) - do i = 1, ele_count(pv) - call assemble_potential_vorticity_element(i, pv, positions, velocity, perturbation_density) - end do - ewrite_minmax(pv) + ! Assemble + call zero(pv) + do i = 1, ele_count(pv) + call assemble_potential_vorticity_element(i, pv, positions, velocity, perturbation_density) + end do + ewrite_minmax(pv) - masslump => get_lumped_mass(state, pv%mesh) + masslump => get_lumped_mass(state, pv%mesh) - ! Solve (somewhat trivial) - pv%val = pv%val / masslump%val - ewrite_minmax(pv) + ! Solve (somewhat trivial) + pv%val = pv%val / masslump%val + ewrite_minmax(pv) - ewrite(1, *) "Exiting calculate_potential_vorticity" + ewrite(1, *) "Exiting calculate_potential_vorticity" - end subroutine calculate_potential_vorticity + end subroutine calculate_potential_vorticity - subroutine assemble_potential_vorticity_element(ele, pv, positions, velocity, perturbation_density) - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: pv - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - type(scalar_field), intent(in) :: perturbation_density + subroutine assemble_potential_vorticity_element(ele, pv, positions, velocity, perturbation_density) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: pv + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(scalar_field), intent(in) :: perturbation_density - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(pv, ele)) :: detwei - real, dimension(mesh_dim(pv), ele_ngi(pv, ele)) :: coriolis_gi, grad_theta_gi, vorticity_gi - real, dimension(ele_loc(pv, ele), ele_ngi(pv, ele), mesh_dim(pv)) :: dn_t - real, dimension(ele_loc(perturbation_density, ele), ele_ngi(perturbation_density, ele), mesh_dim(pv)) :: dtheta_t - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(pv)) :: du_t - type(element_type), pointer :: theta_shape , pv_shape, velocity_shape - - assert(ele_ngi(velocity, ele) == ele_ngi(pv, ele)) - assert(ele_ngi(perturbation_density, ele) == ele_ngi(pv, ele)) + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(pv, ele)) :: detwei + real, dimension(mesh_dim(pv), ele_ngi(pv, ele)) :: coriolis_gi, grad_theta_gi, vorticity_gi + real, dimension(ele_loc(pv, ele), ele_ngi(pv, ele), mesh_dim(pv)) :: dn_t + real, dimension(ele_loc(perturbation_density, ele), ele_ngi(perturbation_density, ele), mesh_dim(pv)) :: dtheta_t + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(pv)) :: du_t + type(element_type), pointer :: theta_shape , pv_shape, velocity_shape + + assert(ele_ngi(velocity, ele) == ele_ngi(pv, ele)) + assert(ele_ngi(perturbation_density, ele) == ele_ngi(pv, ele)) - pv_shape => ele_shape(pv, ele) - velocity_shape => ele_shape(velocity, ele) - theta_shape => ele_shape(perturbation_density, ele) + pv_shape => ele_shape(pv, ele) + velocity_shape => ele_shape(velocity, ele) + theta_shape => ele_shape(perturbation_density, ele) - call transform_to_physical(positions, ele, pv_shape, & + call transform_to_physical(positions, ele, pv_shape, & & dshape = dn_t, detwei = detwei) - if(pv_shape == velocity_shape) then - du_t = dn_t - else - call transform_to_physical(positions, ele, velocity_shape, & - & dshape = du_t) - end if - if(pv_shape == theta_shape) then - dtheta_t = dn_t - else - call transform_to_physical(positions, ele, theta_shape, & - & dshape = dtheta_t) - end if - - coriolis_gi = 0.0 - coriolis_gi(W_, :) = coriolis(ele_val_at_quad(positions, ele)) - - vorticity_gi = ele_curl_at_quad(velocity, ele, du_t) - grad_theta_gi = ele_grad_at_quad(perturbation_density, ele, dtheta_t) - - element_nodes => ele_nodes(pv, ele) - - call addto(pv, element_nodes, & + if(pv_shape == velocity_shape) then + du_t = dn_t + else + call transform_to_physical(positions, ele, velocity_shape, & + & dshape = du_t) + end if + if(pv_shape == theta_shape) then + dtheta_t = dn_t + else + call transform_to_physical(positions, ele, theta_shape, & + & dshape = dtheta_t) + end if + + coriolis_gi = 0.0 + coriolis_gi(W_, :) = coriolis(ele_val_at_quad(positions, ele)) + + vorticity_gi = ele_curl_at_quad(velocity, ele, du_t) + grad_theta_gi = ele_grad_at_quad(perturbation_density, ele, dtheta_t) + + element_nodes => ele_nodes(pv, ele) + + call addto(pv, element_nodes, & & shape_rhs(pv_shape, detwei * sum((coriolis_gi + vorticity_gi) * grad_theta_gi, 1)) & & ) - end subroutine assemble_potential_vorticity_element - - subroutine calculate_relative_potential_vorticity(state, rel_pv) - !!< Compute the value of: - !!< curl u dot grad rho' - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: rel_pv - - integer :: i - type(scalar_field), pointer :: masslump - type(scalar_field), pointer :: perturbation_density - type(vector_field), pointer :: positions, velocity - - ewrite(1, *) "In calculate_relative_potential_vorticity" - ewrite(2, *) "Computing relative PV for state " // trim(state%name) - - if(rel_pv%mesh%continuity /= 0) then - ewrite(-1,*) "Your mesh ",trim(rel_pv%mesh%name)," is not continuous" - FLExit("RelativePotentialVorticity requires a continuous mesh") - end if - - ! Extract the Coordinate field - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mesh_dim(rel_pv)) - assert(ele_count(positions) == ele_count(rel_pv)) - - ! Extract velocity - velocity => extract_vector_field(state, "Velocity") - assert(velocity%dim == mesh_dim(rel_pv)) - assert(ele_count(velocity) == ele_count(rel_pv)) - ewrite_minmax(velocity) - - ! Extract perturbation density - perturbation_density => extract_scalar_field(state, "PerturbationDensity") - assert(mesh_dim(perturbation_density) == mesh_dim(rel_pv)) - assert(ele_count(perturbation_density) == ele_count(rel_pv)) - ewrite_minmax(perturbation_density) - - ! Assemble - call zero(rel_pv) - do i = 1, ele_count(rel_pv) - call assemble_relative_potential_vorticity_element(i, rel_pv, positions, velocity, perturbation_density) - end do - ewrite_minmax(rel_pv) - - masslump => get_lumped_mass(state, rel_pv%mesh) - - ! Solve (somewhat trivial) - rel_pv%val = rel_pv%val / masslump%val - ewrite_minmax(rel_pv) - - ewrite(1, *) "Exiting calculate_relative_potential_vorticity" - - end subroutine calculate_relative_potential_vorticity - - subroutine assemble_relative_potential_vorticity_element(ele, rel_pv, positions, velocity, perturbation_density) - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: rel_pv - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - type(scalar_field), intent(in) :: perturbation_density - - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(rel_pv, ele)) :: detwei - real, dimension(mesh_dim(rel_pv), ele_ngi(rel_pv, ele)) :: grad_theta_gi, vorticity_gi - real, dimension(ele_loc(rel_pv, ele), ele_ngi(rel_pv, ele), mesh_dim(rel_pv)) :: dn_t - real, dimension(ele_loc(perturbation_density, ele), ele_ngi(perturbation_density, ele), mesh_dim(rel_pv)) :: dtheta_t - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(rel_pv)) :: du_t - type(element_type), pointer :: theta_shape, rel_pv_shape, velocity_shape - - assert(ele_ngi(velocity, ele) == ele_ngi(rel_pv, ele)) - assert(ele_ngi(perturbation_density, ele) == ele_ngi(rel_pv, ele)) - - rel_pv_shape => ele_shape(rel_pv, ele) - velocity_shape => ele_shape(velocity, ele) - theta_shape => ele_shape(perturbation_density, ele) - - call transform_to_physical(positions, ele, rel_pv_shape, & + end subroutine assemble_potential_vorticity_element + + subroutine calculate_relative_potential_vorticity(state, rel_pv) + !!< Compute the value of: + !!< curl u dot grad rho' + + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: rel_pv + + integer :: i + type(scalar_field), pointer :: masslump + type(scalar_field), pointer :: perturbation_density + type(vector_field), pointer :: positions, velocity + + ewrite(1, *) "In calculate_relative_potential_vorticity" + ewrite(2, *) "Computing relative PV for state " // trim(state%name) + + if(rel_pv%mesh%continuity /= 0) then + ewrite(-1,*) "Your mesh ",trim(rel_pv%mesh%name)," is not continuous" + FLExit("RelativePotentialVorticity requires a continuous mesh") + end if + + ! Extract the Coordinate field + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mesh_dim(rel_pv)) + assert(ele_count(positions) == ele_count(rel_pv)) + + ! Extract velocity + velocity => extract_vector_field(state, "Velocity") + assert(velocity%dim == mesh_dim(rel_pv)) + assert(ele_count(velocity) == ele_count(rel_pv)) + ewrite_minmax(velocity) + + ! Extract perturbation density + perturbation_density => extract_scalar_field(state, "PerturbationDensity") + assert(mesh_dim(perturbation_density) == mesh_dim(rel_pv)) + assert(ele_count(perturbation_density) == ele_count(rel_pv)) + ewrite_minmax(perturbation_density) + + ! Assemble + call zero(rel_pv) + do i = 1, ele_count(rel_pv) + call assemble_relative_potential_vorticity_element(i, rel_pv, positions, velocity, perturbation_density) + end do + ewrite_minmax(rel_pv) + + masslump => get_lumped_mass(state, rel_pv%mesh) + + ! Solve (somewhat trivial) + rel_pv%val = rel_pv%val / masslump%val + ewrite_minmax(rel_pv) + + ewrite(1, *) "Exiting calculate_relative_potential_vorticity" + + end subroutine calculate_relative_potential_vorticity + + subroutine assemble_relative_potential_vorticity_element(ele, rel_pv, positions, velocity, perturbation_density) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: rel_pv + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(scalar_field), intent(in) :: perturbation_density + + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(rel_pv, ele)) :: detwei + real, dimension(mesh_dim(rel_pv), ele_ngi(rel_pv, ele)) :: grad_theta_gi, vorticity_gi + real, dimension(ele_loc(rel_pv, ele), ele_ngi(rel_pv, ele), mesh_dim(rel_pv)) :: dn_t + real, dimension(ele_loc(perturbation_density, ele), ele_ngi(perturbation_density, ele), mesh_dim(rel_pv)) :: dtheta_t + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(rel_pv)) :: du_t + type(element_type), pointer :: theta_shape, rel_pv_shape, velocity_shape + + assert(ele_ngi(velocity, ele) == ele_ngi(rel_pv, ele)) + assert(ele_ngi(perturbation_density, ele) == ele_ngi(rel_pv, ele)) + + rel_pv_shape => ele_shape(rel_pv, ele) + velocity_shape => ele_shape(velocity, ele) + theta_shape => ele_shape(perturbation_density, ele) + + call transform_to_physical(positions, ele, rel_pv_shape, & & dshape = dn_t, detwei = detwei) - if(rel_pv_shape == velocity_shape) then - du_t = dn_t - else - call transform_to_physical(positions, ele, velocity_shape, & - & dshape = du_t) - end if - if(rel_pv_shape == theta_shape) then - dtheta_t = dn_t - else - call transform_to_physical(positions, ele, theta_shape, & - & dshape = dtheta_t) - end if - - vorticity_gi = ele_curl_at_quad(velocity, ele, du_t) - grad_theta_gi = ele_grad_at_quad(perturbation_density, ele, dtheta_t) - - element_nodes => ele_nodes(rel_pv, ele) - - call addto(rel_pv, element_nodes, & + if(rel_pv_shape == velocity_shape) then + du_t = dn_t + else + call transform_to_physical(positions, ele, velocity_shape, & + & dshape = du_t) + end if + if(rel_pv_shape == theta_shape) then + dtheta_t = dn_t + else + call transform_to_physical(positions, ele, theta_shape, & + & dshape = dtheta_t) + end if + + vorticity_gi = ele_curl_at_quad(velocity, ele, du_t) + grad_theta_gi = ele_grad_at_quad(perturbation_density, ele, dtheta_t) + + element_nodes => ele_nodes(rel_pv, ele) + + call addto(rel_pv, element_nodes, & & shape_rhs(rel_pv_shape, detwei * sum(vorticity_gi * grad_theta_gi, 1)) & & ) - end subroutine assemble_relative_potential_vorticity_element + end subroutine assemble_relative_potential_vorticity_element end module vorticity_diagnostics diff --git a/assemble/Zoltan_callbacks.F90 b/assemble/Zoltan_callbacks.F90 index ab242aa62b..f611d2282b 100644 --- a/assemble/Zoltan_callbacks.F90 +++ b/assemble/Zoltan_callbacks.F90 @@ -5,1295 +5,1295 @@ module zoltan_callbacks #ifdef HAVE_ZOLTAN - use zoltan - use spud - use global_parameters, only: real_size, OPTION_PATH_LEN - use fldebug - use data_structures - use mpi_interfaces - use parallel_tools, only: getrank, getnprocs, getprocno, MPI_COMM_FEMTOOLS - use sparse_tools - use element_numbering - use elements - use metric_tools - use fields - use state_module - use halos_derivation, only: ele_owner - use halos, only: halo_nowned_nodes, halo_node_owner, halo_node_owners, get_owned_nodes, halo_universal_number - use detector_data_types, only: detector_type - use zoltan_global_variables - use detector_tools - use detector_parallel - use zoltan_detectors - - implicit none - - private - - public :: zoltan_cb_owned_node_count, zoltan_cb_get_owned_nodes, zoltan_cb_pack_field_sizes,& - zoltan_cb_pack_fields, zoltan_cb_unpack_fields, zoltan_cb_pack_halo_node_sizes,& - zoltan_cb_pack_halo_nodes, zoltan_cb_unpack_halo_nodes, zoltan_cb_get_edge_list,& - zoltan_cb_get_num_edges, zoltan_cb_pack_node_sizes, zoltan_cb_pack_nodes,& - zoltan_cb_unpack_nodes, local_vertex_order + use zoltan + use spud + use global_parameters, only: real_size, OPTION_PATH_LEN + use fldebug + use data_structures + use mpi_interfaces + use parallel_tools, only: getrank, getnprocs, getprocno, MPI_COMM_FEMTOOLS + use sparse_tools + use element_numbering + use elements + use metric_tools + use fields + use state_module + use halos_derivation, only: ele_owner + use halos, only: halo_nowned_nodes, halo_node_owner, halo_node_owners, get_owned_nodes, halo_universal_number + use detector_data_types, only: detector_type + use zoltan_global_variables + use detector_tools + use detector_parallel + use zoltan_detectors + + implicit none + + private + + public :: zoltan_cb_owned_node_count, zoltan_cb_get_owned_nodes, zoltan_cb_pack_field_sizes,& + zoltan_cb_pack_fields, zoltan_cb_unpack_fields, zoltan_cb_pack_halo_node_sizes,& + zoltan_cb_pack_halo_nodes, zoltan_cb_unpack_halo_nodes, zoltan_cb_get_edge_list,& + zoltan_cb_get_num_edges, zoltan_cb_pack_node_sizes, zoltan_cb_pack_nodes,& + zoltan_cb_unpack_nodes, local_vertex_order contains - function zoltan_cb_owned_node_count(data, ierr) result(count) - integer(zoltan_int) :: count - integer(zoltan_int), dimension(*) :: data ! not used - integer(zoltan_int), intent(out) :: ierr - - ewrite(1,*) "In zoltan_cb_owned_node_count" - - count = halo_nowned_nodes(zoltan_global_zz_halo) - if (have_option("/mesh_adaptivity/hr_adaptivity/zoltan_options/zoltan_debug")) then - ewrite(1,*) "zoltan_cb_owned_node_count found: ", count, " nodes" - end if - ierr = ZOLTAN_OK - end function zoltan_cb_owned_node_count - - subroutine zoltan_cb_get_owned_nodes(data, num_gid_entries, num_lid_entries, global_ids, local_ids, wgt_dim, obj_wgts, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data ! not used - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries - integer(zoltan_int), intent(out), dimension(*) :: global_ids - integer(zoltan_int), intent(out), dimension(*) :: local_ids - integer(zoltan_int), intent(in) :: wgt_dim - real(zoltan_float), intent(out), dimension(*) :: obj_wgts - integer(zoltan_int), intent(out) :: ierr - - integer :: count, i - real(zoltan_float) :: max_obj_wgt, min_obj_wgt - - ewrite(1,*) "In zoltan_cb_get_owned_nodes" - - assert(num_gid_entries == 1) - assert(num_lid_entries == 1) - assert(wgt_dim == 1) - - count = halo_nowned_nodes(zoltan_global_zz_halo) - - call get_owned_nodes(zoltan_global_zz_halo, local_ids(1:count)) - global_ids(1:count) = halo_universal_number(zoltan_global_zz_halo, local_ids(1:count)) - - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug")) then - ewrite(1,*) "zoltan_cb_get_owned nodes found local_ids: ", local_ids(1:count) - ewrite(1,*) "zoltan_cb_get_owned nodes found global_ids: ", global_ids(1:count) - end if - - if(zoltan_global_migrate_extruded_mesh) then - ! weight the nodes according to the number of nodes in the column beneath it - do i = 1, count - obj_wgts(i) = float(row_length(zoltan_global_columns_sparsity, i)) - end do - else - do i = 1, count - obj_wgts(i) = 1.0 - end do - end if - - if(zoltan_global_field_weighted_partitions) then - max_obj_wgt = 1.0 - min_obj_wgt = 0.0 - do i = 1, count - obj_wgts(i) = node_val(zoltan_global_field_weighted_partition_values,i) - max_obj_wgt = max(max_obj_wgt, obj_wgts(i)) - min_obj_wgt = min(min_obj_wgt, obj_wgts(i)) - end do - - if((max_obj_wgt > 1.0) .OR. (min_obj_wgt < 0.0)) then - FLExit("0.0 <= FieldWeightedPartitionValues <= 1.0: condition not satisfied") - end if - - end if - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_get_owned_nodes - - subroutine zoltan_cb_get_num_edges(data, num_gid_entries, num_lid_entries, num_obj, global_ids, local_ids, num_edges, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_obj - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: local_ids - integer(zoltan_int), intent(out),dimension(*) :: num_edges - integer(zoltan_int), intent(out) :: ierr - - integer :: count - integer :: node - character (len = OPTION_PATH_LEN) :: filename - - ewrite(1,*) "In zoltan_cb_get_num_edges" - - assert(num_gid_entries == 1) - assert(num_lid_entries == 1) - - count = zoltan_global_zz_halo%nowned_nodes - assert(count == num_obj) - - do node=1,count - num_edges(node) = row_length(zoltan_global_zz_sparsity_one, local_ids(node)) - end do - - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_edge_counts")) then - write(filename, '(A,I0,A)') 'edge_counts_', getrank(),'.dat' - open(666, file = filename) - do node=1,count - write(666,*) num_edges(node) - end do - close(666) - end if - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_get_num_edges - - subroutine zoltan_cb_get_edge_list(data, num_gid_entries, num_lid_entries, num_obj, global_ids, local_ids, & - & num_edges, nbor_global_id, nbor_procs, wgt_dim, ewgts, ierr) - integer(zoltan_int), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_obj - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: local_ids - integer(zoltan_int), intent(in), dimension(*) :: num_edges - integer(zoltan_int), intent(out), dimension(*) :: nbor_global_id - integer(zoltan_int), intent(out), dimension(*) :: nbor_procs - integer(zoltan_int), intent(in) :: wgt_dim - real(zoltan_float), intent(out), dimension(*) :: ewgts - integer(zoltan_int), intent(out) :: ierr - integer :: count, err - integer :: node, i, j - integer :: head - integer, dimension(:), pointer :: neighbours - character (len = OPTION_PATH_LEN) :: filename - - ! variables for recording various element quality functional values - real :: quality, min_quality, my_min_quality - - ! variables for recording the local maximum/minimum edge weights and local 90th percentile edge weight - real(zoltan_float) :: min_weight, max_weight, ninety_weight, my_max_weight, my_min_weight - - integer, dimension(:), pointer :: my_nelist, nbor_nelist - - integer :: total_num_edges, my_num_edges - - real :: value - - ewrite(1,*) "In zoltan_cb_get_edge_list" - - assert(num_gid_entries == 1) - assert(num_lid_entries == 1) - assert(wgt_dim == 1) - - count = zoltan_global_zz_halo%nowned_nodes - assert(count == num_obj) - - my_num_edges = sum(num_edges(1:num_obj)) - - if (.NOT. zoltan_global_calculate_edge_weights) then - - ! Three reasons why we might not want to use edge-weighting: - ! - last iteration - ! hopefully the mesh is of sufficient quality by now we only - ! want to optimize the edge cut to minimize halo communication - ! - flredecomping - ! we don't need to use edge-weights as there's no adapting - ! - empty partitions - ! when load balancing with edge-weights on we couldn't avoid - ! creating empty paritions so try load balancing without them - ewgts(1:my_num_edges) = 1.0 - head = 1 - do node=1,count - ! find nodes neighbours - neighbours => row_m_ptr(zoltan_global_zz_sparsity_one, local_ids(node)) - ! check the number of neighbours matches the number of edges - assert(size(neighbours) == num_edges(node)) - ! find global ids for each neighbour - nbor_global_id(head:head+size(neighbours)-1) = halo_universal_number(zoltan_global_zz_halo, neighbours) - ! find owning proc for each neighbour - nbor_procs(head:head+size(neighbours)-1) = halo_node_owners(zoltan_global_zz_halo, neighbours) - 1 - head = head + size(neighbours) - end do - ierr = ZOLTAN_OK - return - else - call MPI_ALLREDUCE(my_num_edges,total_num_edges,1,MPI_INTEGER,MPI_SUM, & - MPI_COMM_FEMTOOLS,err) - end if + function zoltan_cb_owned_node_count(data, ierr) result(count) + integer(zoltan_int) :: count + integer(zoltan_int), dimension(*) :: data ! not used + integer(zoltan_int), intent(out) :: ierr + + ewrite(1,*) "In zoltan_cb_owned_node_count" + + count = halo_nowned_nodes(zoltan_global_zz_halo) + if (have_option("/mesh_adaptivity/hr_adaptivity/zoltan_options/zoltan_debug")) then + ewrite(1,*) "zoltan_cb_owned_node_count found: ", count, " nodes" + end if + ierr = ZOLTAN_OK + end function zoltan_cb_owned_node_count - head = 1 + subroutine zoltan_cb_get_owned_nodes(data, num_gid_entries, num_lid_entries, global_ids, local_ids, wgt_dim, obj_wgts, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data ! not used + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries + integer(zoltan_int), intent(out), dimension(*) :: global_ids + integer(zoltan_int), intent(out), dimension(*) :: local_ids + integer(zoltan_int), intent(in) :: wgt_dim + real(zoltan_float), intent(out), dimension(*) :: obj_wgts + integer(zoltan_int), intent(out) :: ierr - ! Aim is to assign high edge weights to poor quality elements - ! so that when we load balance poor quality elements are placed - ! in the centre of partitions and can be adapted + integer :: count, i + real(zoltan_float) :: max_obj_wgt, min_obj_wgt - ! loop over the nodes you own - do node=1,count + ewrite(1,*) "In zoltan_cb_get_owned_nodes" - ! find nodes neighbours - neighbours => row_m_ptr(zoltan_global_zz_sparsity_one, local_ids(node)) - - ! check the number of neighbours matches the number of edges - assert(size(neighbours) == num_edges(node)) - - ! find global ids for each neighbour - nbor_global_id(head:head+size(neighbours)-1) = halo_universal_number(zoltan_global_zz_halo, neighbours) + assert(num_gid_entries == 1) + assert(num_lid_entries == 1) + assert(wgt_dim == 1) - ! find owning proc for each neighbour - nbor_procs(head:head+size(neighbours)-1) = halo_node_owners(zoltan_global_zz_halo, neighbours) - 1 + count = halo_nowned_nodes(zoltan_global_zz_halo) - ! get elements associated with current node - my_nelist => row_m_ptr(zoltan_global_zz_nelist, local_ids(node)) - - my_min_quality = 1.0 - - ! find quality of worst element node is associated with - do i=1,size(my_nelist) - quality = minval(ele_val(zoltan_global_element_quality, my_nelist(i))) - - if (quality .LT. my_min_quality) then - my_min_quality = quality - end if - end do - - ! loop over all neighbouring nodes - do j=1,size(neighbours) - - min_quality = my_min_quality - - ! get elements associated with neighbour node - nbor_nelist => row_m_ptr(zoltan_global_zz_nelist, neighbours(j)) - - ! loop over all the elements of the neighbour node - do i=1, size(nbor_nelist) - ! determine the quality of the element - quality = minval(ele_val(zoltan_global_element_quality, nbor_nelist(i))) - - ! store the element quality if it's less (worse) than any previous elements - if (quality .LT. min_quality) then - min_quality = quality - end if - end do - - ! check if the quality is within the tolerance - if (min_quality .GT. zoltan_global_quality_tolerance) then - ! if it is - ewgts(head + j - 1) = 1.0 - else - ! if it's not - ewgts(head + j - 1) = ceiling((1.0 - min_quality) * 20) - end if - end do - - head = head + size(neighbours) - end do - - assert(head == sum(num_edges(1:num_obj))+1) - - ! calculate the local maximum edge weight - my_max_weight = maxval(ewgts(1:head-1)) - - ! calculate the local minimum edge weight - my_min_weight = minval(ewgts(1:head-1)) - - ! calculate global maximum edge weight - call MPI_ALLREDUCE(my_max_weight,max_weight,1,MPI_REAL,MPI_MAX, MPI_COMM_FEMTOOLS,err) - - ! calculate global minimum edge weight - call MPI_ALLREDUCE(my_min_weight,min_weight,1,MPI_REAL,MPI_MIN, MPI_COMM_FEMTOOLS,err) - - ! calculate the local 90th percentile edge weight - ninety_weight = max_weight * 0.90 - - ! don't want to adjust the weights if all the elements are of a similar quality - if (min_weight < ninety_weight) then - ! make the worst 10% of elements uncuttable - do i=1,head-1 - if (ewgts(i) .GT. ninety_weight) then - ewgts(i) = total_num_edges + 1 - end if - end do - end if - - if (zoltan_global_output_edge_weights) then - head = 1 - do node=1,count - neighbours => row_m_ptr(zoltan_global_zz_sparsity_one, local_ids(node)) - value = maxval(ewgts(head:head+size(neighbours)-1)) - call set(zoltan_global_max_edge_weight_on_node,local_ids(node),value) - head = head + size(neighbours) - end do - end if - - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_edge_weights")) then - write(filename, '(A,I0,A)') 'edge_weights_', getrank(),'.dat' - open(666, file = filename) - do i=1,head-1 - write(666,*) ewgts(i) - end do - close(666) - end if - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_get_edge_list - - - ! Here is how we pack nodal positions for phase one migration: - ! -------------------------------------------------------------------------------------------------------------- - ! | position | sz of lv-1 nnlist | lv-1 nnlist | sz of lv-2 nnlist | lv-2 nnlist | owners of level-2 nnlist | - ! | sz of nelist | nelist | sz of snelist | snelist | snelist ids | containing element of snelist | - ! -------------------------------------------------------------------------------------------------------------- - subroutine zoltan_cb_pack_node_sizes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, sizes, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids, local_ids - integer(zoltan_int), intent(out), dimension(*) :: sizes - integer(zoltan_int), intent(out) :: ierr - - integer :: i, node - character (len = OPTION_PATH_LEN) :: filename - - ewrite(1,*) "In zoltan_cb_pack_node_sizes" - do i=1,num_ids - node = local_ids(i) - sizes(i) = zoltan_global_zz_positions%dim * real_size + & - 1 * integer_size + row_length(zoltan_global_zz_sparsity_one, node) * integer_size + & - 1 * integer_size + row_length(zoltan_global_zz_sparsity_two, node) * integer_size * 2 + & - 1 * integer_size + row_length(zoltan_global_zz_nelist, node) * integer_size + & - 1 * integer_size + key_count(zoltan_global_old_snelist(node)) * integer_size * 3 - if(zoltan_global_preserve_mesh_regions) then - sizes(i) = sizes(i) + row_length(zoltan_global_zz_nelist, node) * integer_size + call get_owned_nodes(zoltan_global_zz_halo, local_ids(1:count)) + global_ids(1:count) = halo_universal_number(zoltan_global_zz_halo, local_ids(1:count)) + + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug")) then + ewrite(1,*) "zoltan_cb_get_owned nodes found local_ids: ", local_ids(1:count) + ewrite(1,*) "zoltan_cb_get_owned nodes found global_ids: ", global_ids(1:count) end if - if(zoltan_global_preserve_columns) then - sizes(i) = sizes(i) + integer_size + + if(zoltan_global_migrate_extruded_mesh) then + ! weight the nodes according to the number of nodes in the column beneath it + do i = 1, count + obj_wgts(i) = float(row_length(zoltan_global_columns_sparsity, i)) + end do + else + do i = 1, count + obj_wgts(i) = 1.0 + end do end if - end do - - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_node_sizes")) then - write(filename, '(A,I0,A)') 'node_sizes_', getrank(),'.dat' - open(666, file = filename) - do i=1,num_ids - write(666,*) sizes(i) - end do - close(666) - end if - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_pack_node_sizes - - - subroutine zoltan_cb_pack_nodes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, dest, sizes, idx, buf, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: local_ids - integer(zoltan_int), intent(in), dimension(*) :: dest - integer(zoltan_int), intent(in), dimension(*) :: sizes - integer(zoltan_int), intent(in), dimension(*) :: idx - integer(zoltan_int), intent(out), dimension(*) :: buf - integer(zoltan_int), intent(out) :: ierr - - integer :: i, j, node, ratio, head - - ewrite(1,*) "In zoltan_cb_pack_nodes" - ratio = real_size / integer_size - assert(int(float(real_size) / float(integer_size)) == ratio) ! that ratio really is an int - - do i=1,num_ids - head = idx(i) - node = local_ids(i) - assert(halo_universal_number(zoltan_global_zz_halo, node) == global_ids(i)) - do j=1,zoltan_global_zz_positions%dim - buf(head:head+ratio-1) = transfer(node_val(zoltan_global_zz_positions, j, node), buf(head:head+ratio-1)) - head = head + ratio + + if(zoltan_global_field_weighted_partitions) then + max_obj_wgt = 1.0 + min_obj_wgt = 0.0 + do i = 1, count + obj_wgts(i) = node_val(zoltan_global_field_weighted_partition_values,i) + max_obj_wgt = max(max_obj_wgt, obj_wgts(i)) + min_obj_wgt = min(min_obj_wgt, obj_wgts(i)) + end do + + if((max_obj_wgt > 1.0) .OR. (min_obj_wgt < 0.0)) then + FLExit("0.0 <= FieldWeightedPartitionValues <= 1.0: condition not satisfied") + end if + + end if + + ierr = ZOLTAN_OK + end subroutine zoltan_cb_get_owned_nodes + + subroutine zoltan_cb_get_num_edges(data, num_gid_entries, num_lid_entries, num_obj, global_ids, local_ids, num_edges, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_obj + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: local_ids + integer(zoltan_int), intent(out),dimension(*) :: num_edges + integer(zoltan_int), intent(out) :: ierr + + integer :: count + integer :: node + character (len = OPTION_PATH_LEN) :: filename + + ewrite(1,*) "In zoltan_cb_get_num_edges" + + assert(num_gid_entries == 1) + assert(num_lid_entries == 1) + + count = zoltan_global_zz_halo%nowned_nodes + assert(count == num_obj) + + do node=1,count + num_edges(node) = row_length(zoltan_global_zz_sparsity_one, local_ids(node)) end do - if(zoltan_global_preserve_columns) then - buf(head) = zoltan_global_universal_columns(node) - head = head + 1 + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_edge_counts")) then + write(filename, '(A,I0,A)') 'edge_counts_', getrank(),'.dat' + open(666, file = filename) + do node=1,count + write(666,*) num_edges(node) + end do + close(666) end if - buf(head) = row_length(zoltan_global_zz_sparsity_one, node) - head = head + 1 + ierr = ZOLTAN_OK + end subroutine zoltan_cb_get_num_edges + + subroutine zoltan_cb_get_edge_list(data, num_gid_entries, num_lid_entries, num_obj, global_ids, local_ids, & + & num_edges, nbor_global_id, nbor_procs, wgt_dim, ewgts, ierr) + integer(zoltan_int), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_obj + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: local_ids + integer(zoltan_int), intent(in), dimension(*) :: num_edges + integer(zoltan_int), intent(out), dimension(*) :: nbor_global_id + integer(zoltan_int), intent(out), dimension(*) :: nbor_procs + integer(zoltan_int), intent(in) :: wgt_dim + real(zoltan_float), intent(out), dimension(*) :: ewgts + integer(zoltan_int), intent(out) :: ierr + integer :: count, err + integer :: node, i, j + integer :: head + integer, dimension(:), pointer :: neighbours + character (len = OPTION_PATH_LEN) :: filename + + ! variables for recording various element quality functional values + real :: quality, min_quality, my_min_quality + + ! variables for recording the local maximum/minimum edge weights and local 90th percentile edge weight + real(zoltan_float) :: min_weight, max_weight, ninety_weight, my_max_weight, my_min_weight + + integer, dimension(:), pointer :: my_nelist, nbor_nelist + + integer :: total_num_edges, my_num_edges + + real :: value + + ewrite(1,*) "In zoltan_cb_get_edge_list" + + assert(num_gid_entries == 1) + assert(num_lid_entries == 1) + assert(wgt_dim == 1) + + count = zoltan_global_zz_halo%nowned_nodes + assert(count == num_obj) + + my_num_edges = sum(num_edges(1:num_obj)) + + if (.NOT. zoltan_global_calculate_edge_weights) then + + ! Three reasons why we might not want to use edge-weighting: + ! - last iteration + ! hopefully the mesh is of sufficient quality by now we only + ! want to optimize the edge cut to minimize halo communication + ! - flredecomping + ! we don't need to use edge-weights as there's no adapting + ! - empty partitions + ! when load balancing with edge-weights on we couldn't avoid + ! creating empty paritions so try load balancing without them + ewgts(1:my_num_edges) = 1.0 + head = 1 + do node=1,count + ! find nodes neighbours + neighbours => row_m_ptr(zoltan_global_zz_sparsity_one, local_ids(node)) + ! check the number of neighbours matches the number of edges + assert(size(neighbours) == num_edges(node)) + ! find global ids for each neighbour + nbor_global_id(head:head+size(neighbours)-1) = halo_universal_number(zoltan_global_zz_halo, neighbours) + ! find owning proc for each neighbour + nbor_procs(head:head+size(neighbours)-1) = halo_node_owners(zoltan_global_zz_halo, neighbours) - 1 + head = head + size(neighbours) + end do + ierr = ZOLTAN_OK + return + else + call MPI_ALLREDUCE(my_num_edges,total_num_edges,1,MPI_INTEGER,MPI_SUM, & + MPI_COMM_FEMTOOLS,err) + end if + + head = 1 + + ! Aim is to assign high edge weights to poor quality elements + ! so that when we load balance poor quality elements are placed + ! in the centre of partitions and can be adapted + + ! loop over the nodes you own + do node=1,count + + ! find nodes neighbours + neighbours => row_m_ptr(zoltan_global_zz_sparsity_one, local_ids(node)) + + ! check the number of neighbours matches the number of edges + assert(size(neighbours) == num_edges(node)) + + ! find global ids for each neighbour + nbor_global_id(head:head+size(neighbours)-1) = halo_universal_number(zoltan_global_zz_halo, neighbours) - buf(head:head+row_length(zoltan_global_zz_sparsity_one, node)-1) = halo_universal_number(zoltan_global_zz_halo, row_m_ptr(zoltan_global_zz_sparsity_one, node)) - head = head + row_length(zoltan_global_zz_sparsity_one, node) + ! find owning proc for each neighbour + nbor_procs(head:head+size(neighbours)-1) = halo_node_owners(zoltan_global_zz_halo, neighbours) - 1 - buf(head) = row_length(zoltan_global_zz_sparsity_two, node) - head = head + 1 + ! get elements associated with current node + my_nelist => row_m_ptr(zoltan_global_zz_nelist, local_ids(node)) - buf(head:head+row_length(zoltan_global_zz_sparsity_two, node)-1) = halo_universal_number(zoltan_global_zz_halo, row_m_ptr(zoltan_global_zz_sparsity_two, node)) - head = head + row_length(zoltan_global_zz_sparsity_two, node) + my_min_quality = 1.0 - buf(head:head+row_length(zoltan_global_zz_sparsity_two, node)-1) = halo_node_owners(zoltan_global_zz_halo, row_m_ptr(zoltan_global_zz_sparsity_two, node)) - head = head + row_length(zoltan_global_zz_sparsity_two, node) + ! find quality of worst element node is associated with + do i=1,size(my_nelist) + quality = minval(ele_val(zoltan_global_element_quality, my_nelist(i))) - buf(head) = row_length(zoltan_global_zz_nelist, node) - head = head + 1 + if (quality .LT. my_min_quality) then + my_min_quality = quality + end if + end do - buf(head:head+row_length(zoltan_global_zz_nelist,node)-1) = halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node)) - head = head + row_length(zoltan_global_zz_nelist, node) + ! loop over all neighbouring nodes + do j=1,size(neighbours) - if(zoltan_global_preserve_mesh_regions) then - ! put in the region_ids in the same amount of space as the nelist - this is complete overkill! - buf(head:head+row_length(zoltan_global_zz_nelist,node)-1) = fetch(zoltan_global_universal_element_number_to_region_id, halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node))) - head = head + row_length(zoltan_global_zz_nelist, node) + min_quality = my_min_quality + + ! get elements associated with neighbour node + nbor_nelist => row_m_ptr(zoltan_global_zz_nelist, neighbours(j)) + + ! loop over all the elements of the neighbour node + do i=1, size(nbor_nelist) + ! determine the quality of the element + quality = minval(ele_val(zoltan_global_element_quality, nbor_nelist(i))) + + ! store the element quality if it's less (worse) than any previous elements + if (quality .LT. min_quality) then + min_quality = quality + end if + end do + + ! check if the quality is within the tolerance + if (min_quality .GT. zoltan_global_quality_tolerance) then + ! if it is + ewgts(head + j - 1) = 1.0 + else + ! if it's not + ewgts(head + j - 1) = ceiling((1.0 - min_quality) * 20) + end if + end do + + head = head + size(neighbours) + end do + + assert(head == sum(num_edges(1:num_obj))+1) + + ! calculate the local maximum edge weight + my_max_weight = maxval(ewgts(1:head-1)) + + ! calculate the local minimum edge weight + my_min_weight = minval(ewgts(1:head-1)) + + ! calculate global maximum edge weight + call MPI_ALLREDUCE(my_max_weight,max_weight,1,MPI_REAL,MPI_MAX, MPI_COMM_FEMTOOLS,err) + + ! calculate global minimum edge weight + call MPI_ALLREDUCE(my_min_weight,min_weight,1,MPI_REAL,MPI_MIN, MPI_COMM_FEMTOOLS,err) + + ! calculate the local 90th percentile edge weight + ninety_weight = max_weight * 0.90 + + ! don't want to adjust the weights if all the elements are of a similar quality + if (min_weight < ninety_weight) then + ! make the worst 10% of elements uncuttable + do i=1,head-1 + if (ewgts(i) .GT. ninety_weight) then + ewgts(i) = total_num_edges + 1 + end if + end do end if - buf(head) = key_count(zoltan_global_old_snelist(node)) - head = head + 1 - buf(head:head + key_count(zoltan_global_old_snelist(node)) - 1) = set2vector(zoltan_global_old_snelist(node)) - head = head + key_count(zoltan_global_old_snelist(node)) - buf(head:head + key_count(zoltan_global_old_snelist(node)) - 1) = fetch(zoltan_global_universal_surface_number_to_surface_id, set2vector(zoltan_global_old_snelist(node))) - head = head + key_count(zoltan_global_old_snelist(node)) - buf(head:head + key_count(zoltan_global_old_snelist(node)) - 1) = fetch(zoltan_global_universal_surface_number_to_element_owner, set2vector(zoltan_global_old_snelist(node))) - head = head + key_count(zoltan_global_old_snelist(node)) - - !assert(head == idx(i) + (sizes(i)/integer_size) - 1) - end do - ierr = ZOLTAN_OK - end subroutine zoltan_cb_pack_nodes - - - subroutine zoltan_cb_unpack_nodes(data, num_gid_entries, num_ids, global_ids, sizes, idx, buf, ierr) - integer(zoltan_int), dimension(*), intent(inout) :: data - integer(zoltan_int), intent(in) :: num_gid_entries - integer(zoltan_int), intent(in) :: num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: sizes - integer(zoltan_int), intent(in), dimension(*) :: idx - integer(zoltan_int), intent(in), dimension(*), target :: buf - integer(zoltan_int), intent(out) :: ierr - - integer :: i, ratio, head, sz, j - type(integer_set) :: new_nodes_we_have_recorded, new_nodes_we_still_need, halo_nodes_we_currently_own - type(mesh_type) :: new_mesh - integer, dimension(:), pointer :: neighbours - logical :: changed - integer :: old_local_number, new_local_number, universal_number - real, dimension(zoltan_global_zz_positions%dim) :: new_coord - type(integer_hash_table) :: universal_number_to_old_owner - integer :: old_owner, new_owner - integer, dimension(:), pointer :: current_buf - integer :: rank - - ewrite(1,*) "In zoltan_cb_unpack_nodes" - ! assert new linear mesh and positions not allocated - assert(.not. associated(new_mesh%refcount)) - assert(.not. associated(zoltan_global_new_positions%refcount)) - rank = getrank() - - ! Figure out the nodes we are going to know about - call allocate(zoltan_global_new_nodes) - - ! All the nodes we currently have and still own, in universal numbering - do i=1,key_count(zoltan_global_nodes_we_are_keeping) - old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) - call insert(zoltan_global_new_nodes, halo_universal_number(zoltan_global_zz_halo, old_local_number), changed=changed) - end do - - ! All the nodes we are receiving from other people and are going to own - do i=1,num_ids - call insert(zoltan_global_new_nodes, global_ids(i)) - end do - - call allocate(universal_number_to_old_owner) - call allocate(halo_nodes_we_currently_own) - - ! All the halos of (the nodes we currently have and still own), in universal numbering - do i=1,key_count(zoltan_global_nodes_we_are_keeping) - neighbours => row_m_ptr(zoltan_global_zz_sparsity_two, fetch(zoltan_global_nodes_we_are_keeping, i)) - do j=1,size(neighbours) - universal_number = halo_universal_number(zoltan_global_zz_halo, neighbours(j)) - call insert(zoltan_global_new_nodes, universal_number, changed=changed) - if (changed) then ! so it is a halo node - old_owner = halo_node_owner(zoltan_global_zz_halo, neighbours(j)) - 1 - assert(old_owner < getnprocs()) - if (old_owner == rank) then - call insert(halo_nodes_we_currently_own, neighbours(j)) - end if - call insert(universal_number_to_old_owner, universal_number, old_owner) - end if - end do - end do - - ! We need to process these too -- nodes we own now, but will - ! not own later, and will become our halo nodes. - do i=1,key_count(halo_nodes_we_currently_own) - old_local_number = fetch(halo_nodes_we_currently_own, i) - universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) - call insert(zoltan_global_new_nodes, universal_number) - end do - - ! All the other nodes that will form the halo of the new nodes we are receiving - ratio = real_size / integer_size - do i=1,num_ids - current_buf => buf(idx(i):idx(i) + sizes(i)/integer_size) - head = ratio * zoltan_global_zz_positions%dim + 1 - if(zoltan_global_preserve_columns) then - head = head + 1 - end if - ! current_buf(head) is the size of the level-1 nnlist, which we want to skip over for now - ! we will however sum up the sizes so that we can allocate the csr sparsity later - head = head + current_buf(head) + 1 - ! now current_buf(head) is the size of the level-2 nnlist, which we want to process - ! and we will also sum up the sizes so that we can allocate the csr sparsity later - sz = current_buf(head) - do j=1,sz - universal_number = current_buf(head + j) - old_owner = current_buf(head + j + sz) - 1 - assert(old_owner < getnprocs()) - call insert(zoltan_global_new_nodes, universal_number) ! the sparsity for a node includes itself - call insert(universal_number_to_old_owner, universal_number, old_owner) - end do - end do - - ! Now zoltan_global_new_nodes implicitly defines a mapping - ! between 1 .. key_count(zoltan_global_new_nodes) [these are the new local node numbers] - ! and the universal node numbers of the nodes. - ! We're going to invert that to create the hash table of universal node numbers -> local node numbers - ! to facilitate the transfer of field information later. - call invert_set(zoltan_global_new_nodes, zoltan_global_universal_to_new_local_numbering) - - ! allocate the new objects - ! We know the number of nodes, but not the number of elements .. hmm. - ! We will allocate it with 0 elements for now, and work it out when we - ! invert the nnlist to compute an enlist later. - call allocate(new_mesh, key_count(zoltan_global_new_nodes), 0, zoltan_global_zz_mesh%shape, trim(zoltan_global_zz_mesh%name)) - new_mesh%option_path = zoltan_global_zz_mesh%option_path - if(zoltan_global_preserve_columns) then - allocate(new_mesh%columns(key_count(zoltan_global_new_nodes))) - end if - call allocate(zoltan_global_new_positions, zoltan_global_zz_positions%dim, new_mesh, trim(zoltan_global_zz_positions%name)) - zoltan_global_new_positions%option_path = zoltan_global_zz_positions%option_path - call deallocate(new_mesh) - allocate(zoltan_global_new_snelist(key_count(zoltan_global_new_nodes))) - call allocate(zoltan_global_new_snelist) - - ! aaaand unpack, recording which universal ids we have received - ! so that we can figure out which ones we haven't received yet - ! so that we can ask their old owner to send on the new details - ! a) build a set of the nodes we have recorded - ! b) from that, build a set of the nodes we haven't yet recorded - ! c) figure out who owns those nodes, so we can build the import list for zoltan - - allocate(zoltan_global_new_nelist(key_count(zoltan_global_new_nodes))) - do i=1,key_count(zoltan_global_new_nodes) - call allocate(zoltan_global_new_nelist(i)) - end do - call allocate(zoltan_global_new_elements) - call allocate(zoltan_global_new_surface_elements) - - call allocate(new_nodes_we_have_recorded) - ! Nodes we are keeping - do i=1,key_count(zoltan_global_nodes_we_are_keeping) - old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) - universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) - call insert(new_nodes_we_have_recorded, universal_number) - call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & - zoltan_global_universal_columns(old_local_number)) - end if - - ! Record the nelist information - neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) - do j=1,size(neighbours) - call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - ! don't need to do anything to zoltan_global_universal_element_number_to_region_id because we already have it - end do - - ! and record the snelist information - do j=1,key_count(zoltan_global_old_snelist(old_local_number)) - call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) - call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) - ! we don't need to add anything to the zoltan_global_universal_surface_number_to_surface_id because we already have it - end do - end do - - ! Set the positions and nelist of halo_nodes_we_currently_own - do i=1,key_count(halo_nodes_we_currently_own) - old_local_number = fetch(halo_nodes_we_currently_own, i) - universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) - call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & - zoltan_global_universal_columns(old_local_number)) - end if - - neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) - do j=1,size(neighbours) - call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - ! don't need to do anything to zoltan_global_universal_element_number_to_region_id because we already have it - end do - - call insert(new_nodes_we_have_recorded, universal_number) - - new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_number) - call insert(zoltan_global_receives(new_owner+1), universal_number) - - ! and record the snelist information - do j=1,key_count(zoltan_global_old_snelist(old_local_number)) - call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) - call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) - end do - end do - call deallocate(halo_nodes_we_currently_own) - - ! Nodes we are gaining - do i=1,num_ids - call insert(new_nodes_we_have_recorded, global_ids(i)) - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, global_ids(i)) - new_coord = 0 - head = idx(i) - do j=1,zoltan_global_zz_positions%dim - new_coord(j) = transfer(buf(head:head+ratio-1), new_coord(j)) - head = head + ratio - end do - call set(zoltan_global_new_positions, new_local_number, new_coord) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, buf(head)) - head = head + 1 - end if - - ! Record the nelist information - sz = buf(head) ! level-1 nnlist - head = head + sz + 1 - sz = buf(head) ! level-2 nnlist - head = head + 2*sz + 1 - sz = buf(head) ! nelist - do j=1,sz - call insert(zoltan_global_new_nelist(new_local_number), buf(head + j)) - call insert(zoltan_global_new_elements, buf(head + j)) - if(zoltan_global_preserve_mesh_regions) then - call insert(zoltan_global_universal_element_number_to_region_id, buf(head + j), buf(head + j + sz)) - end if - end do - if(zoltan_global_preserve_mesh_regions) then - head = head + 2*sz + 1 - else - head = head + sz + 1 - end if - - ! And record the snelist information - sz = buf(head) - do j=1,sz - call insert(zoltan_global_new_snelist(new_local_number), buf(head + j)) - call insert(zoltan_global_universal_surface_number_to_surface_id, buf(head + j), buf(head + j + sz)) - call insert(zoltan_global_universal_surface_number_to_element_owner, buf(head + j), buf(head + j + 2*sz)) - call insert(zoltan_global_new_surface_elements, buf(head + j)) - end do - head = head + 3*sz + 1 - end do - - ! At this point, there might still be nodes that we have not yet recorded but - ! we own, so we can fill them in now. - call allocate(new_nodes_we_still_need) - do i=1,key_count(zoltan_global_new_nodes) - universal_number = fetch(zoltan_global_new_nodes, i) - if (has_value(new_nodes_we_have_recorded, universal_number)) cycle - - old_owner = fetch(universal_number_to_old_owner, universal_number) - if (old_owner == rank) then - call insert(new_nodes_we_have_recorded, universal_number) - old_local_number = fetch(zoltan_global_universal_to_old_local_numbering, universal_number) - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) - call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = & - & fetch(zoltan_global_universal_to_new_local_numbering_m1d, zoltan_global_universal_columns(old_local_number)) - end if - - ! Record the nelist information - neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) - do j=1,size(neighbours) - call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - ! don't need to do anything to zoltan_global_universal_element_number_to_region_id because we already have it - end do - - ! and record the snelist information - do j=1,key_count(zoltan_global_old_snelist(old_local_number)) - call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) - call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) - ! we don't need to add anything to the zoltan_global_universal_surface_number_to_surface_id because we already have it - end do - - ! and record the node in the zoltan_global_receives - new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_number) - call insert(zoltan_global_receives(new_owner+1), universal_number) - else - call insert(new_nodes_we_still_need, universal_number) - end if - end do - - ! And build the import list ... - zoltan_global_my_num_import = key_count(new_nodes_we_still_need) - allocate(zoltan_global_my_import_procs(zoltan_global_my_num_import)) - allocate(zoltan_global_my_import_global_ids(zoltan_global_my_num_import)) - do i=1,zoltan_global_my_num_import - universal_number = fetch(new_nodes_we_still_need, i) - zoltan_global_my_import_global_ids(i) = universal_number - zoltan_global_my_import_procs(i) = fetch(universal_number_to_old_owner, universal_number) - assert(zoltan_global_my_import_procs(i) /= rank) - end do - - call deallocate(new_nodes_we_have_recorded) - call deallocate(new_nodes_we_still_need) - call deallocate(universal_number_to_old_owner) - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_unpack_nodes - - - ! Here is how we pack halo nodes for phase two migration: - ! ------------------------------------------------------------------------------------- - ! | position | new owner | size of nelist | nelist | size of snelist | - ! | snelist | surface ids | the containing volume element for each surface element | - ! ------------------------------------------------------------------------------------- - subroutine zoltan_cb_pack_halo_node_sizes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, sizes, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids, local_ids - integer(zoltan_int), intent(out), dimension(*) :: sizes - integer(zoltan_int), intent(out) :: ierr - - integer :: i, node - character (len = OPTION_PATH_LEN) :: filename - - ewrite(1,*) "In zoltan_cb_pack_halo_node_sizes" - - do i=1,num_ids - node = fetch(zoltan_global_universal_to_old_local_numbering, global_ids(i)) - sizes(i) = zoltan_global_zz_positions%dim * real_size + & - 2 * integer_size + row_length(zoltan_global_zz_nelist, node) * integer_size + & - 1 * integer_size + key_count(zoltan_global_old_snelist(node)) * 3 * integer_size - if(zoltan_global_preserve_mesh_regions) then - sizes(i) = sizes(i) + row_length(zoltan_global_zz_nelist, node) * integer_size + if (zoltan_global_output_edge_weights) then + head = 1 + do node=1,count + neighbours => row_m_ptr(zoltan_global_zz_sparsity_one, local_ids(node)) + value = maxval(ewgts(head:head+size(neighbours)-1)) + call set(zoltan_global_max_edge_weight_on_node,local_ids(node),value) + head = head + size(neighbours) + end do + end if + + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_edge_weights")) then + write(filename, '(A,I0,A)') 'edge_weights_', getrank(),'.dat' + open(666, file = filename) + do i=1,head-1 + write(666,*) ewgts(i) + end do + close(666) + end if + + ierr = ZOLTAN_OK + end subroutine zoltan_cb_get_edge_list + + + ! Here is how we pack nodal positions for phase one migration: + ! -------------------------------------------------------------------------------------------------------------- + ! | position | sz of lv-1 nnlist | lv-1 nnlist | sz of lv-2 nnlist | lv-2 nnlist | owners of level-2 nnlist | + ! | sz of nelist | nelist | sz of snelist | snelist | snelist ids | containing element of snelist | + ! -------------------------------------------------------------------------------------------------------------- + subroutine zoltan_cb_pack_node_sizes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, sizes, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids, local_ids + integer(zoltan_int), intent(out), dimension(*) :: sizes + integer(zoltan_int), intent(out) :: ierr + + integer :: i, node + character (len = OPTION_PATH_LEN) :: filename + + ewrite(1,*) "In zoltan_cb_pack_node_sizes" + do i=1,num_ids + node = local_ids(i) + sizes(i) = zoltan_global_zz_positions%dim * real_size + & + 1 * integer_size + row_length(zoltan_global_zz_sparsity_one, node) * integer_size + & + 1 * integer_size + row_length(zoltan_global_zz_sparsity_two, node) * integer_size * 2 + & + 1 * integer_size + row_length(zoltan_global_zz_nelist, node) * integer_size + & + 1 * integer_size + key_count(zoltan_global_old_snelist(node)) * integer_size * 3 + if(zoltan_global_preserve_mesh_regions) then + sizes(i) = sizes(i) + row_length(zoltan_global_zz_nelist, node) * integer_size + end if + if(zoltan_global_preserve_columns) then + sizes(i) = sizes(i) + integer_size + end if + end do + + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_node_sizes")) then + write(filename, '(A,I0,A)') 'node_sizes_', getrank(),'.dat' + open(666, file = filename) + do i=1,num_ids + write(666,*) sizes(i) + end do + close(666) end if + + ierr = ZOLTAN_OK + end subroutine zoltan_cb_pack_node_sizes + + + subroutine zoltan_cb_pack_nodes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, dest, sizes, idx, buf, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: local_ids + integer(zoltan_int), intent(in), dimension(*) :: dest + integer(zoltan_int), intent(in), dimension(*) :: sizes + integer(zoltan_int), intent(in), dimension(*) :: idx + integer(zoltan_int), intent(out), dimension(*) :: buf + integer(zoltan_int), intent(out) :: ierr + + integer :: i, j, node, ratio, head + + ewrite(1,*) "In zoltan_cb_pack_nodes" + ratio = real_size / integer_size + assert(int(float(real_size) / float(integer_size)) == ratio) ! that ratio really is an int + + do i=1,num_ids + head = idx(i) + node = local_ids(i) + assert(halo_universal_number(zoltan_global_zz_halo, node) == global_ids(i)) + do j=1,zoltan_global_zz_positions%dim + buf(head:head+ratio-1) = transfer(node_val(zoltan_global_zz_positions, j, node), buf(head:head+ratio-1)) + head = head + ratio + end do + + if(zoltan_global_preserve_columns) then + buf(head) = zoltan_global_universal_columns(node) + head = head + 1 + end if + + buf(head) = row_length(zoltan_global_zz_sparsity_one, node) + head = head + 1 + + buf(head:head+row_length(zoltan_global_zz_sparsity_one, node)-1) = halo_universal_number(zoltan_global_zz_halo, row_m_ptr(zoltan_global_zz_sparsity_one, node)) + head = head + row_length(zoltan_global_zz_sparsity_one, node) + + buf(head) = row_length(zoltan_global_zz_sparsity_two, node) + head = head + 1 + + buf(head:head+row_length(zoltan_global_zz_sparsity_two, node)-1) = halo_universal_number(zoltan_global_zz_halo, row_m_ptr(zoltan_global_zz_sparsity_two, node)) + head = head + row_length(zoltan_global_zz_sparsity_two, node) + + buf(head:head+row_length(zoltan_global_zz_sparsity_two, node)-1) = halo_node_owners(zoltan_global_zz_halo, row_m_ptr(zoltan_global_zz_sparsity_two, node)) + head = head + row_length(zoltan_global_zz_sparsity_two, node) + + buf(head) = row_length(zoltan_global_zz_nelist, node) + head = head + 1 + + buf(head:head+row_length(zoltan_global_zz_nelist,node)-1) = halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node)) + head = head + row_length(zoltan_global_zz_nelist, node) + + if(zoltan_global_preserve_mesh_regions) then + ! put in the region_ids in the same amount of space as the nelist - this is complete overkill! + buf(head:head+row_length(zoltan_global_zz_nelist,node)-1) = fetch(zoltan_global_universal_element_number_to_region_id, halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node))) + head = head + row_length(zoltan_global_zz_nelist, node) + end if + + buf(head) = key_count(zoltan_global_old_snelist(node)) + head = head + 1 + buf(head:head + key_count(zoltan_global_old_snelist(node)) - 1) = set2vector(zoltan_global_old_snelist(node)) + head = head + key_count(zoltan_global_old_snelist(node)) + buf(head:head + key_count(zoltan_global_old_snelist(node)) - 1) = fetch(zoltan_global_universal_surface_number_to_surface_id, set2vector(zoltan_global_old_snelist(node))) + head = head + key_count(zoltan_global_old_snelist(node)) + buf(head:head + key_count(zoltan_global_old_snelist(node)) - 1) = fetch(zoltan_global_universal_surface_number_to_element_owner, set2vector(zoltan_global_old_snelist(node))) + head = head + key_count(zoltan_global_old_snelist(node)) + + !assert(head == idx(i) + (sizes(i)/integer_size) - 1) + end do + ierr = ZOLTAN_OK + end subroutine zoltan_cb_pack_nodes + + + subroutine zoltan_cb_unpack_nodes(data, num_gid_entries, num_ids, global_ids, sizes, idx, buf, ierr) + integer(zoltan_int), dimension(*), intent(inout) :: data + integer(zoltan_int), intent(in) :: num_gid_entries + integer(zoltan_int), intent(in) :: num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: sizes + integer(zoltan_int), intent(in), dimension(*) :: idx + integer(zoltan_int), intent(in), dimension(*), target :: buf + integer(zoltan_int), intent(out) :: ierr + + integer :: i, ratio, head, sz, j + type(integer_set) :: new_nodes_we_have_recorded, new_nodes_we_still_need, halo_nodes_we_currently_own + type(mesh_type) :: new_mesh + integer, dimension(:), pointer :: neighbours + logical :: changed + integer :: old_local_number, new_local_number, universal_number + real, dimension(zoltan_global_zz_positions%dim) :: new_coord + type(integer_hash_table) :: universal_number_to_old_owner + integer :: old_owner, new_owner + integer, dimension(:), pointer :: current_buf + integer :: rank + + ewrite(1,*) "In zoltan_cb_unpack_nodes" + ! assert new linear mesh and positions not allocated + assert(.not. associated(new_mesh%refcount)) + assert(.not. associated(zoltan_global_new_positions%refcount)) + rank = getrank() + + ! Figure out the nodes we are going to know about + call allocate(zoltan_global_new_nodes) + + ! All the nodes we currently have and still own, in universal numbering + do i=1,key_count(zoltan_global_nodes_we_are_keeping) + old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) + call insert(zoltan_global_new_nodes, halo_universal_number(zoltan_global_zz_halo, old_local_number), changed=changed) + end do + + ! All the nodes we are receiving from other people and are going to own + do i=1,num_ids + call insert(zoltan_global_new_nodes, global_ids(i)) + end do + + call allocate(universal_number_to_old_owner) + call allocate(halo_nodes_we_currently_own) + + ! All the halos of (the nodes we currently have and still own), in universal numbering + do i=1,key_count(zoltan_global_nodes_we_are_keeping) + neighbours => row_m_ptr(zoltan_global_zz_sparsity_two, fetch(zoltan_global_nodes_we_are_keeping, i)) + do j=1,size(neighbours) + universal_number = halo_universal_number(zoltan_global_zz_halo, neighbours(j)) + call insert(zoltan_global_new_nodes, universal_number, changed=changed) + if (changed) then ! so it is a halo node + old_owner = halo_node_owner(zoltan_global_zz_halo, neighbours(j)) - 1 + assert(old_owner < getnprocs()) + if (old_owner == rank) then + call insert(halo_nodes_we_currently_own, neighbours(j)) + end if + call insert(universal_number_to_old_owner, universal_number, old_owner) + end if + end do + end do + + ! We need to process these too -- nodes we own now, but will + ! not own later, and will become our halo nodes. + do i=1,key_count(halo_nodes_we_currently_own) + old_local_number = fetch(halo_nodes_we_currently_own, i) + universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) + call insert(zoltan_global_new_nodes, universal_number) + end do + + ! All the other nodes that will form the halo of the new nodes we are receiving + ratio = real_size / integer_size + do i=1,num_ids + current_buf => buf(idx(i):idx(i) + sizes(i)/integer_size) + head = ratio * zoltan_global_zz_positions%dim + 1 + if(zoltan_global_preserve_columns) then + head = head + 1 + end if + ! current_buf(head) is the size of the level-1 nnlist, which we want to skip over for now + ! we will however sum up the sizes so that we can allocate the csr sparsity later + head = head + current_buf(head) + 1 + ! now current_buf(head) is the size of the level-2 nnlist, which we want to process + ! and we will also sum up the sizes so that we can allocate the csr sparsity later + sz = current_buf(head) + do j=1,sz + universal_number = current_buf(head + j) + old_owner = current_buf(head + j + sz) - 1 + assert(old_owner < getnprocs()) + call insert(zoltan_global_new_nodes, universal_number) ! the sparsity for a node includes itself + call insert(universal_number_to_old_owner, universal_number, old_owner) + end do + end do + + ! Now zoltan_global_new_nodes implicitly defines a mapping + ! between 1 .. key_count(zoltan_global_new_nodes) [these are the new local node numbers] + ! and the universal node numbers of the nodes. + ! We're going to invert that to create the hash table of universal node numbers -> local node numbers + ! to facilitate the transfer of field information later. + call invert_set(zoltan_global_new_nodes, zoltan_global_universal_to_new_local_numbering) + + ! allocate the new objects + ! We know the number of nodes, but not the number of elements .. hmm. + ! We will allocate it with 0 elements for now, and work it out when we + ! invert the nnlist to compute an enlist later. + call allocate(new_mesh, key_count(zoltan_global_new_nodes), 0, zoltan_global_zz_mesh%shape, trim(zoltan_global_zz_mesh%name)) + new_mesh%option_path = zoltan_global_zz_mesh%option_path if(zoltan_global_preserve_columns) then - sizes(i) = sizes(i) + integer_size + allocate(new_mesh%columns(key_count(zoltan_global_new_nodes))) end if - end do - - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_halo_node_sizes")) then - write(filename, '(A,I0,A)') 'halo_node_sizes_', getrank(),'.dat' - open(666, file = filename) - do i=1,num_ids - write(666,*) sizes(i) - end do - close(666) - end if - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_pack_halo_node_sizes - - - subroutine zoltan_cb_pack_halo_nodes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, dest, sizes, idx, buf, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: local_ids - integer(zoltan_int), intent(in), dimension(*) :: dest - integer(zoltan_int), intent(in), dimension(*) :: sizes - integer(zoltan_int), intent(in), dimension(*) :: idx - integer(zoltan_int), intent(out), dimension(*), target :: buf - integer(zoltan_int), intent(out) :: ierr - - integer :: i, j, node, ratio, head, new_owner, rank - integer, dimension(:), pointer :: current_buf - - ewrite(1,*) "In zoltan_cb_pack_halo_nodes" - ratio = real_size / integer_size - rank = getrank() - - do i=1,num_ids - current_buf => buf(idx(i):idx(i)+sizes(i)/integer_size) - head = 1 - node = fetch(zoltan_global_universal_to_old_local_numbering, global_ids(i)) - do j=1,zoltan_global_zz_positions%dim - current_buf(head:head+ratio-1) = transfer(node_val(zoltan_global_zz_positions, j, node), current_buf(head:head+ratio-1)) - head = head + ratio - end do - - if(zoltan_global_preserve_columns) then - current_buf(head) = zoltan_global_universal_columns(node) - head = head + 1 - end if - - ! Now compute the new owner - if (has_key(zoltan_global_nodes_we_are_sending, node)) then - new_owner = fetch(zoltan_global_nodes_we_are_sending, node) - else - new_owner = rank - end if - - current_buf(head) = new_owner - head = head + 1 - - current_buf(head) = row_length(zoltan_global_zz_nelist, node) - head = head + 1 - - current_buf(head:head+row_length(zoltan_global_zz_nelist, node)-1) = halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node)) - head = head + row_length(zoltan_global_zz_nelist, node) - - if(zoltan_global_preserve_mesh_regions) then - ! put in the region_ids in the same amount of space as the nelist - this is complete overkill! - current_buf(head:head+row_length(zoltan_global_zz_nelist, node)-1) = fetch(zoltan_global_universal_element_number_to_region_id, halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node))) - head = head + row_length(zoltan_global_zz_nelist, node) - end if - - current_buf(head) = key_count(zoltan_global_old_snelist(node)) - head = head + 1 - current_buf(head:head+key_count(zoltan_global_old_snelist(node))-1) = set2vector(zoltan_global_old_snelist(node)) - head = head + key_count(zoltan_global_old_snelist(node)) - current_buf(head:head+key_count(zoltan_global_old_snelist(node))-1) = fetch(zoltan_global_universal_surface_number_to_surface_id, set2vector(zoltan_global_old_snelist(node))) - head = head + key_count(zoltan_global_old_snelist(node)) - current_buf(head:head+key_count(zoltan_global_old_snelist(node))-1) = fetch(zoltan_global_universal_surface_number_to_element_owner, set2vector(zoltan_global_old_snelist(node))) - head = head + key_count(zoltan_global_old_snelist(node)) - - !assert(head == (sizes(i)/integer_size)+1) - end do - ierr = ZOLTAN_OK - end subroutine zoltan_cb_pack_halo_nodes - - - subroutine zoltan_cb_unpack_halo_nodes(data, num_gid_entries, num_ids, global_ids, sizes, idx, buf, ierr) - integer(zoltan_int), dimension(*), intent(inout) :: data - integer(zoltan_int), intent(in) :: num_gid_entries - integer(zoltan_int), intent(in) :: num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: sizes - integer(zoltan_int), intent(in), dimension(*) :: idx - integer(zoltan_int), intent(in), dimension(*), target :: buf - integer(zoltan_int), intent(out) :: ierr - - integer :: i, j - real, dimension(zoltan_global_zz_positions%dim) :: new_coord - integer :: head - integer :: ratio - integer :: new_local_number, new_owner, sz - - ewrite(1,*) "In zoltan_cb_unpack_halo_nodes" - - ratio = real_size/integer_size - - do i=1,num_ids - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, global_ids(i)) - new_coord = 0 - head = idx(i) - do j=1,zoltan_global_zz_positions%dim - new_coord(j) = transfer(buf(head:head+ratio-1), new_coord(j)) - head = head + ratio - end do - call set(zoltan_global_new_positions, new_local_number, new_coord) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, buf(head)) - head = head + 1 - end if - - new_owner = buf(head) - head = head + 1 - - ! record the nelist information - sz = buf(head) - do j=1,sz - call insert(zoltan_global_new_nelist(new_local_number), buf(head + j)) - call insert(zoltan_global_new_elements, buf(head + j)) - if(zoltan_global_preserve_mesh_regions) then - call insert(zoltan_global_universal_element_number_to_region_id, buf(head + j), buf(head + j + sz)) - end if - end do - if(zoltan_global_preserve_mesh_regions) then - head = head + 2*sz + 1 - else - head = head + sz + 1 - end if - - ! and record who owns this in the halo - call insert(zoltan_global_receives(new_owner+1), global_ids(i)) - - ! and record the snelist information - sz = buf(head) - do j=1,sz - call insert(zoltan_global_new_snelist(new_local_number), buf(head + j)) - call insert(zoltan_global_universal_surface_number_to_surface_id, buf(head + j), buf(head + j + sz)) - call insert(zoltan_global_universal_surface_number_to_element_owner, buf(head + j), buf(head + j + 2*sz)) - call insert(zoltan_global_new_surface_elements, buf(head + j)) - end do - head = head + 3*sz + 1 - end do - - ierr = ZOLTAN_OK - end subroutine zoltan_cb_unpack_halo_nodes - - - subroutine zoltan_cb_pack_field_sizes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, sizes, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids, local_ids - integer(zoltan_int), intent(out), dimension(*) :: sizes - integer(zoltan_int), intent(out) :: ierr - - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - integer :: state_no, field_no, sz, i - character (len = OPTION_PATH_LEN) :: filename - - ewrite(1,*) "In zoltan_cb_pack_field_sizes" - - allocate(zoltan_global_to_pack_detectors_list(num_ids)) - ! Allocate array containing the number of particle attributes per element - allocate(zoltan_global_attributes_per_ele(num_ids)) - zoltan_global_attributes_per_ele(:) = 0 - - ! if there are some detectors on this process - if (get_num_detector_lists() .GT. 0) then - ! create two arrays, one with the number of detectors in each element to be transferred - ! and one that holds a list of detectors to be transferred for each element - call prepare_detectors_for_packing(zoltan_global_ndets_in_ele, zoltan_global_to_pack_detectors_list, num_ids, global_ids, zoltan_global_attributes_per_ele) - end if - - ! The person doing this for mixed meshes in a few years time: this is one of the things - ! you need to change. Make it look at the loc for each element. - - sz = 0 - - do state_no=1,size(zoltan_global_source_states) - - do field_no=1,scalar_field_count(zoltan_global_source_states(state_no)) - sfield => extract_scalar_field(zoltan_global_source_states(state_no), field_no) - sz = sz + ele_loc(sfield, 1) - end do - - do field_no=1,vector_field_count(zoltan_global_source_states(state_no)) - vfield => extract_vector_field(zoltan_global_source_states(state_no), field_no) - sz = sz + ele_loc(vfield, 1) * vfield%dim - end do - - do field_no=1,tensor_field_count(zoltan_global_source_states(state_no)) - tfield => extract_tensor_field(zoltan_global_source_states(state_no), field_no) - sz = sz + ele_loc(tfield, 1) * product(tfield%dim) - end do - - end do - - - do i=1,num_ids - ! fields data + number of detectors in element + attribute_info per detector (*3 for 3 attribute types) + detector data + attributes + - ! reserve space for sz scalar values and for sending old unns of the linear mesh - sizes(i) = (sz * real_size) + real_size + (3*real_size*zoltan_global_ndets_in_ele(i)) + (zoltan_global_ndets_in_ele(i) * zoltan_global_ndata_per_det * real_size) & - + (zoltan_global_attributes_per_ele(i) * real_size) + ele_loc(zoltan_global_zz_mesh, 1) * integer_size - end do - - deallocate(zoltan_global_attributes_per_ele) - - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_field_sizes")) then - write(filename, '(A,I0,A)') 'field_sizes_', getrank(),'.dat' - open(666, file = filename) - do i=1,num_ids - write(666,*) sizes(i) - end do - close(666) - end if - - ierr = ZOLTAN_OK - - end subroutine zoltan_cb_pack_field_sizes - - - subroutine zoltan_cb_pack_fields(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, dest, sizes, idx, buf, ierr) - integer(zoltan_int), dimension(*), intent(in) :: data - integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: local_ids - integer(zoltan_int), intent(in), dimension(*) :: dest - integer(zoltan_int), intent(in), dimension(*) :: sizes - integer(zoltan_int), intent(in), dimension(*) :: idx - integer(zoltan_int), intent(out), dimension(*), target :: buf - integer(zoltan_int), intent(out) :: ierr - - real, dimension(:), allocatable :: rbuf ! easier to write reals to real memory - integer :: rhead, i, j, k, state_no, field_no, loc, sz, total_det_packed - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - integer :: old_universal_element_number, old_local_element_number, dataSize - integer, dimension(3) :: attribute_size !buffer containing the size of particle attributes - integer :: total_attributes !total number of attributes carried by a particle - - type(detector_type), pointer :: detector => null(), detector_to_delete => null() - - ewrite(1,*) "In zoltan_cb_pack_fields" - - total_det_packed=0 - do i=1,num_ids - - ! work back number of scalar values 'sz' from the formula above in zoltan_cb_pack_field_sizes - sz = (sizes(i) - ele_loc(zoltan_global_zz_mesh, old_local_element_number) * integer_size) / real_size - allocate(rbuf(sz)) - - old_universal_element_number = global_ids(i) - old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) - - rhead = 1 - - do state_no=1,size(zoltan_global_source_states) - do field_no=1,scalar_field_count(zoltan_global_source_states(state_no)) - sfield => extract_scalar_field(zoltan_global_source_states(state_no), field_no) - loc = ele_loc(sfield, old_local_element_number) - rbuf(rhead:rhead + loc - 1) = ele_val(sfield, old_local_element_number) - rhead = rhead + loc - end do - - do field_no=1,vector_field_count(zoltan_global_source_states(state_no)) - vfield => extract_vector_field(zoltan_global_source_states(state_no), field_no) - if (index(vfield%name,"Coordinate")==len_trim(vfield%name)-9) cycle - loc = ele_loc(vfield, old_local_element_number) - rbuf(rhead:rhead + loc*vfield%dim - 1) = reshape(ele_val(vfield, old_local_element_number), (/loc*vfield%dim/)) - rhead = rhead + loc * vfield%dim - end do - - do field_no=1,tensor_field_count(zoltan_global_source_states(state_no)) - tfield => extract_tensor_field(zoltan_global_source_states(state_no), field_no) - loc = ele_loc(tfield, old_local_element_number) - rbuf(rhead:rhead + loc*product(tfield%dim) - 1) & - = reshape(ele_val(tfield, old_local_element_number), (/ loc*product(tfield%dim) /)) - rhead = rhead + loc * product(tfield%dim) - end do - - end do - - ! packing the number of detectors in the element - rbuf(rhead) = zoltan_global_ndets_in_ele(i) - rhead = rhead + 1 - - if(zoltan_global_to_pack_detectors_list(i)%length /= 0) then - detector => zoltan_global_to_pack_detectors_list(i)%first - end if - - ! packing the detectors in that element - do j=1,zoltan_global_ndets_in_ele(i) - !check attribute sizes - attribute_size(1) = size(detector%attributes) - attribute_size(2) = size(detector%old_attributes) - attribute_size(3) = size(detector%old_fields) - - total_attributes = sum(attribute_size) - !pack attribute sizes - do k = 1,3 - rbuf(rhead)=attribute_size(k) - rhead=rhead+1 - end do - - !pack the detector - call pack_detector(detector, rbuf(rhead:rhead+zoltan_global_ndata_per_det-1+total_attributes), & - zoltan_global_ndims, attribute_size_in=attribute_size) - ! keep a pointer to the detector to delete - detector_to_delete => detector - ! move on our iterating pointer so it's not left on a deleted node - detector => detector%next + call allocate(zoltan_global_new_positions, zoltan_global_zz_positions%dim, new_mesh, trim(zoltan_global_zz_positions%name)) + zoltan_global_new_positions%option_path = zoltan_global_zz_positions%option_path + call deallocate(new_mesh) + allocate(zoltan_global_new_snelist(key_count(zoltan_global_new_nodes))) + call allocate(zoltan_global_new_snelist) + + ! aaaand unpack, recording which universal ids we have received + ! so that we can figure out which ones we haven't received yet + ! so that we can ask their old owner to send on the new details + ! a) build a set of the nodes we have recorded + ! b) from that, build a set of the nodes we haven't yet recorded + ! c) figure out who owns those nodes, so we can build the import list for zoltan + + allocate(zoltan_global_new_nelist(key_count(zoltan_global_new_nodes))) + do i=1,key_count(zoltan_global_new_nodes) + call allocate(zoltan_global_new_nelist(i)) + end do + call allocate(zoltan_global_new_elements) + call allocate(zoltan_global_new_surface_elements) + + call allocate(new_nodes_we_have_recorded) + ! Nodes we are keeping + do i=1,key_count(zoltan_global_nodes_we_are_keeping) + old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) + universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) + call insert(new_nodes_we_have_recorded, universal_number) + call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & + zoltan_global_universal_columns(old_local_number)) + end if + + ! Record the nelist information + neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) + do j=1,size(neighbours) + call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + ! don't need to do anything to zoltan_global_universal_element_number_to_region_id because we already have it + end do + + ! and record the snelist information + do j=1,key_count(zoltan_global_old_snelist(old_local_number)) + call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) + call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) + ! we don't need to add anything to the zoltan_global_universal_surface_number_to_surface_id because we already have it + end do + end do + + ! Set the positions and nelist of halo_nodes_we_currently_own + do i=1,key_count(halo_nodes_we_currently_own) + old_local_number = fetch(halo_nodes_we_currently_own, i) + universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) + call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & + zoltan_global_universal_columns(old_local_number)) + end if + + neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) + do j=1,size(neighbours) + call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + ! don't need to do anything to zoltan_global_universal_element_number_to_region_id because we already have it + end do + + call insert(new_nodes_we_have_recorded, universal_number) + + new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_number) + call insert(zoltan_global_receives(new_owner+1), universal_number) + + ! and record the snelist information + do j=1,key_count(zoltan_global_old_snelist(old_local_number)) + call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) + call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) + end do + end do + call deallocate(halo_nodes_we_currently_own) + + ! Nodes we are gaining + do i=1,num_ids + call insert(new_nodes_we_have_recorded, global_ids(i)) + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, global_ids(i)) + new_coord = 0 + head = idx(i) + do j=1,zoltan_global_zz_positions%dim + new_coord(j) = transfer(buf(head:head+ratio-1), new_coord(j)) + head = head + ratio + end do + call set(zoltan_global_new_positions, new_local_number, new_coord) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, buf(head)) + head = head + 1 + end if + + ! Record the nelist information + sz = buf(head) ! level-1 nnlist + head = head + sz + 1 + sz = buf(head) ! level-2 nnlist + head = head + 2*sz + 1 + sz = buf(head) ! nelist + do j=1,sz + call insert(zoltan_global_new_nelist(new_local_number), buf(head + j)) + call insert(zoltan_global_new_elements, buf(head + j)) + if(zoltan_global_preserve_mesh_regions) then + call insert(zoltan_global_universal_element_number_to_region_id, buf(head + j), buf(head + j + sz)) + end if + end do + if(zoltan_global_preserve_mesh_regions) then + head = head + 2*sz + 1 + else + head = head + sz + 1 + end if + + ! And record the snelist information + sz = buf(head) + do j=1,sz + call insert(zoltan_global_new_snelist(new_local_number), buf(head + j)) + call insert(zoltan_global_universal_surface_number_to_surface_id, buf(head + j), buf(head + j + sz)) + call insert(zoltan_global_universal_surface_number_to_element_owner, buf(head + j), buf(head + j + 2*sz)) + call insert(zoltan_global_new_surface_elements, buf(head + j)) + end do + head = head + 3*sz + 1 + end do + + ! At this point, there might still be nodes that we have not yet recorded but + ! we own, so we can fill them in now. + call allocate(new_nodes_we_still_need) + do i=1,key_count(zoltan_global_new_nodes) + universal_number = fetch(zoltan_global_new_nodes, i) + if (has_value(new_nodes_we_have_recorded, universal_number)) cycle + + old_owner = fetch(universal_number_to_old_owner, universal_number) + if (old_owner == rank) then + call insert(new_nodes_we_have_recorded, universal_number) + old_local_number = fetch(zoltan_global_universal_to_old_local_numbering, universal_number) + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) + call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = & + & fetch(zoltan_global_universal_to_new_local_numbering_m1d, zoltan_global_universal_columns(old_local_number)) + end if + + ! Record the nelist information + neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) + do j=1,size(neighbours) + call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + ! don't need to do anything to zoltan_global_universal_element_number_to_region_id because we already have it + end do + + ! and record the snelist information + do j=1,key_count(zoltan_global_old_snelist(old_local_number)) + call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) + call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) + ! we don't need to add anything to the zoltan_global_universal_surface_number_to_surface_id because we already have it + end do + + ! and record the node in the zoltan_global_receives + new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_number) + call insert(zoltan_global_receives(new_owner+1), universal_number) + else + call insert(new_nodes_we_still_need, universal_number) + end if + end do + + ! And build the import list ... + zoltan_global_my_num_import = key_count(new_nodes_we_still_need) + allocate(zoltan_global_my_import_procs(zoltan_global_my_num_import)) + allocate(zoltan_global_my_import_global_ids(zoltan_global_my_num_import)) + do i=1,zoltan_global_my_num_import + universal_number = fetch(new_nodes_we_still_need, i) + zoltan_global_my_import_global_ids(i) = universal_number + zoltan_global_my_import_procs(i) = fetch(universal_number_to_old_owner, universal_number) + assert(zoltan_global_my_import_procs(i) /= rank) + end do + + call deallocate(new_nodes_we_have_recorded) + call deallocate(new_nodes_we_still_need) + call deallocate(universal_number_to_old_owner) + + ierr = ZOLTAN_OK + end subroutine zoltan_cb_unpack_nodes + + + ! Here is how we pack halo nodes for phase two migration: + ! ------------------------------------------------------------------------------------- + ! | position | new owner | size of nelist | nelist | size of snelist | + ! | snelist | surface ids | the containing volume element for each surface element | + ! ------------------------------------------------------------------------------------- + subroutine zoltan_cb_pack_halo_node_sizes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, sizes, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids, local_ids + integer(zoltan_int), intent(out), dimension(*) :: sizes + integer(zoltan_int), intent(out) :: ierr + + integer :: i, node + character (len = OPTION_PATH_LEN) :: filename + + ewrite(1,*) "In zoltan_cb_pack_halo_node_sizes" + + do i=1,num_ids + node = fetch(zoltan_global_universal_to_old_local_numbering, global_ids(i)) + sizes(i) = zoltan_global_zz_positions%dim * real_size + & + 2 * integer_size + row_length(zoltan_global_zz_nelist, node) * integer_size + & + 1 * integer_size + key_count(zoltan_global_old_snelist(node)) * 3 * integer_size + if(zoltan_global_preserve_mesh_regions) then + sizes(i) = sizes(i) + row_length(zoltan_global_zz_nelist, node) * integer_size + end if + if(zoltan_global_preserve_columns) then + sizes(i) = sizes(i) + integer_size + end if + end do - ! delete the detector we just packed from the to_pack list - call delete(detector_to_delete, zoltan_global_to_pack_detectors_list(i)) + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_halo_node_sizes")) then + write(filename, '(A,I0,A)') 'halo_node_sizes_', getrank(),'.dat' + open(666, file = filename) + do i=1,num_ids + write(666,*) sizes(i) + end do + close(666) + end if + + ierr = ZOLTAN_OK + end subroutine zoltan_cb_pack_halo_node_sizes + + + subroutine zoltan_cb_pack_halo_nodes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, dest, sizes, idx, buf, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: local_ids + integer(zoltan_int), intent(in), dimension(*) :: dest + integer(zoltan_int), intent(in), dimension(*) :: sizes + integer(zoltan_int), intent(in), dimension(*) :: idx + integer(zoltan_int), intent(out), dimension(*), target :: buf + integer(zoltan_int), intent(out) :: ierr + + integer :: i, j, node, ratio, head, new_owner, rank + integer, dimension(:), pointer :: current_buf + + ewrite(1,*) "In zoltan_cb_pack_halo_nodes" + ratio = real_size / integer_size + rank = getrank() + + do i=1,num_ids + current_buf => buf(idx(i):idx(i)+sizes(i)/integer_size) + head = 1 + node = fetch(zoltan_global_universal_to_old_local_numbering, global_ids(i)) + do j=1,zoltan_global_zz_positions%dim + current_buf(head:head+ratio-1) = transfer(node_val(zoltan_global_zz_positions, j, node), current_buf(head:head+ratio-1)) + head = head + ratio + end do + + if(zoltan_global_preserve_columns) then + current_buf(head) = zoltan_global_universal_columns(node) + head = head + 1 + end if + + ! Now compute the new owner + if (has_key(zoltan_global_nodes_we_are_sending, node)) then + new_owner = fetch(zoltan_global_nodes_we_are_sending, node) + else + new_owner = rank + end if + + current_buf(head) = new_owner + head = head + 1 + + current_buf(head) = row_length(zoltan_global_zz_nelist, node) + head = head + 1 + + current_buf(head:head+row_length(zoltan_global_zz_nelist, node)-1) = halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node)) + head = head + row_length(zoltan_global_zz_nelist, node) + + if(zoltan_global_preserve_mesh_regions) then + ! put in the region_ids in the same amount of space as the nelist - this is complete overkill! + current_buf(head:head+row_length(zoltan_global_zz_nelist, node)-1) = fetch(zoltan_global_universal_element_number_to_region_id, halo_universal_number(zoltan_global_zz_ele_halo, row_m_ptr(zoltan_global_zz_nelist, node))) + head = head + row_length(zoltan_global_zz_nelist, node) + end if + + current_buf(head) = key_count(zoltan_global_old_snelist(node)) + head = head + 1 + current_buf(head:head+key_count(zoltan_global_old_snelist(node))-1) = set2vector(zoltan_global_old_snelist(node)) + head = head + key_count(zoltan_global_old_snelist(node)) + current_buf(head:head+key_count(zoltan_global_old_snelist(node))-1) = fetch(zoltan_global_universal_surface_number_to_surface_id, set2vector(zoltan_global_old_snelist(node))) + head = head + key_count(zoltan_global_old_snelist(node)) + current_buf(head:head+key_count(zoltan_global_old_snelist(node))-1) = fetch(zoltan_global_universal_surface_number_to_element_owner, set2vector(zoltan_global_old_snelist(node))) + head = head + key_count(zoltan_global_old_snelist(node)) + + !assert(head == (sizes(i)/integer_size)+1) + end do + ierr = ZOLTAN_OK + end subroutine zoltan_cb_pack_halo_nodes + + + subroutine zoltan_cb_unpack_halo_nodes(data, num_gid_entries, num_ids, global_ids, sizes, idx, buf, ierr) + integer(zoltan_int), dimension(*), intent(inout) :: data + integer(zoltan_int), intent(in) :: num_gid_entries + integer(zoltan_int), intent(in) :: num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: sizes + integer(zoltan_int), intent(in), dimension(*) :: idx + integer(zoltan_int), intent(in), dimension(*), target :: buf + integer(zoltan_int), intent(out) :: ierr + + integer :: i, j + real, dimension(zoltan_global_zz_positions%dim) :: new_coord + integer :: head + integer :: ratio + integer :: new_local_number, new_owner, sz + + ewrite(1,*) "In zoltan_cb_unpack_halo_nodes" + + ratio = real_size/integer_size + + do i=1,num_ids + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, global_ids(i)) + new_coord = 0 + head = idx(i) + do j=1,zoltan_global_zz_positions%dim + new_coord(j) = transfer(buf(head:head+ratio-1), new_coord(j)) + head = head + ratio + end do + call set(zoltan_global_new_positions, new_local_number, new_coord) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, buf(head)) + head = head + 1 + end if + + new_owner = buf(head) + head = head + 1 + + ! record the nelist information + sz = buf(head) + do j=1,sz + call insert(zoltan_global_new_nelist(new_local_number), buf(head + j)) + call insert(zoltan_global_new_elements, buf(head + j)) + if(zoltan_global_preserve_mesh_regions) then + call insert(zoltan_global_universal_element_number_to_region_id, buf(head + j), buf(head + j + sz)) + end if + end do + if(zoltan_global_preserve_mesh_regions) then + head = head + 2*sz + 1 + else + head = head + sz + 1 + end if + + ! and record who owns this in the halo + call insert(zoltan_global_receives(new_owner+1), global_ids(i)) + + ! and record the snelist information + sz = buf(head) + do j=1,sz + call insert(zoltan_global_new_snelist(new_local_number), buf(head + j)) + call insert(zoltan_global_universal_surface_number_to_surface_id, buf(head + j), buf(head + j + sz)) + call insert(zoltan_global_universal_surface_number_to_element_owner, buf(head + j), buf(head + j + 2*sz)) + call insert(zoltan_global_new_surface_elements, buf(head + j)) + end do + head = head + 3*sz + 1 + end do - rhead = rhead + zoltan_global_ndata_per_det+total_attributes - total_det_packed=total_det_packed+1 - end do + ierr = ZOLTAN_OK + end subroutine zoltan_cb_unpack_halo_nodes - assert(rhead==sz+1) - ! At the start, write the old unns of this element - loc = ele_loc(zoltan_global_zz_mesh, old_local_element_number) - buf(idx(i):idx(i) + loc -1) = halo_universal_number(zoltan_global_zz_halo, ele_nodes(zoltan_global_zz_mesh, old_local_element_number)) + subroutine zoltan_cb_pack_field_sizes(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, sizes, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids, local_ids + integer(zoltan_int), intent(out), dimension(*) :: sizes + integer(zoltan_int), intent(out) :: ierr - ! Determine the size of the real data in integer_size units - dataSize = sz * real_size / integer_size - assert( dataSize==size(transfer(rbuf, buf(idx(i):idx(i)+1))) ) - ! Now we know the size, we can copy in the right amount of data. - buf(idx(i) + loc:idx(i) + loc + dataSize - 1) = transfer(rbuf, buf(idx(i):idx(i)+1)) + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + integer :: state_no, field_no, sz, i + character (len = OPTION_PATH_LEN) :: filename - deallocate(rbuf) + ewrite(1,*) "In zoltan_cb_pack_field_sizes" + + allocate(zoltan_global_to_pack_detectors_list(num_ids)) + ! Allocate array containing the number of particle attributes per element + allocate(zoltan_global_attributes_per_ele(num_ids)) + zoltan_global_attributes_per_ele(:) = 0 + + ! if there are some detectors on this process + if (get_num_detector_lists() .GT. 0) then + ! create two arrays, one with the number of detectors in each element to be transferred + ! and one that holds a list of detectors to be transferred for each element + call prepare_detectors_for_packing(zoltan_global_ndets_in_ele, zoltan_global_to_pack_detectors_list, num_ids, global_ids, zoltan_global_attributes_per_ele) + end if - assert(zoltan_global_to_pack_detectors_list(i)%length == 0) + ! The person doing this for mixed meshes in a few years time: this is one of the things + ! you need to change. Make it look at the loc for each element. - end do + sz = 0 - deallocate(zoltan_global_to_pack_detectors_list) + do state_no=1,size(zoltan_global_source_states) - ewrite(2,*) "Packed ", total_det_packed, " detectors" - ewrite(1,*) "Exiting zoltan_cb_pack_fields" + do field_no=1,scalar_field_count(zoltan_global_source_states(state_no)) + sfield => extract_scalar_field(zoltan_global_source_states(state_no), field_no) + sz = sz + ele_loc(sfield, 1) + end do - ierr = ZOLTAN_OK + do field_no=1,vector_field_count(zoltan_global_source_states(state_no)) + vfield => extract_vector_field(zoltan_global_source_states(state_no), field_no) + sz = sz + ele_loc(vfield, 1) * vfield%dim + end do - end subroutine zoltan_cb_pack_fields + do field_no=1,tensor_field_count(zoltan_global_source_states(state_no)) + tfield => extract_tensor_field(zoltan_global_source_states(state_no), field_no) + sz = sz + ele_loc(tfield, 1) * product(tfield%dim) + end do + end do - function local_vertex_order(old_unns, new_gnns) - ! little auxilary function that works out the ordering of the send data - ! (which uses the old element ordering) in terms of new local (within the element) - ! node numbers of the vertices - ! old_unns are the unns of the vertices in the old ordering - ! new_gnss are the global (within the local domain) node numbers in the new ordering - integer, dimension(:), intent(in):: old_unns, new_gnns - integer, dimension(size(old_unns)):: local_vertex_order - integer:: i, j, gnn - do i=1, size(old_unns) - gnn = fetch(zoltan_global_universal_to_new_local_numbering, old_unns(i)) - do j=1, size(new_gnns) - if (new_gnns(j)==gnn) exit + do i=1,num_ids + ! fields data + number of detectors in element + attribute_info per detector (*3 for 3 attribute types) + detector data + attributes + + ! reserve space for sz scalar values and for sending old unns of the linear mesh + sizes(i) = (sz * real_size) + real_size + (3*real_size*zoltan_global_ndets_in_ele(i)) + (zoltan_global_ndets_in_ele(i) * zoltan_global_ndata_per_det * real_size) & + + (zoltan_global_attributes_per_ele(i) * real_size) + ele_loc(zoltan_global_zz_mesh, 1) * integer_size end do - if (j>size(new_gnns)) then - ! node in element send is not in receiving element - ewrite(0,*) i, gnn - ewrite(0,*) old_unns - ewrite(0,*) new_gnns - FLAbort("In zoltan redistribution: something went wrong in element reconstruction") + + deallocate(zoltan_global_attributes_per_ele) + + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/dump_field_sizes")) then + write(filename, '(A,I0,A)') 'field_sizes_', getrank(),'.dat' + open(666, file = filename) + do i=1,num_ids + write(666,*) sizes(i) + end do + close(666) end if - local_vertex_order(i) = j - end do - - end function local_vertex_order - - - subroutine zoltan_cb_unpack_fields(data, num_gid_entries, num_ids, global_ids, sizes, idx, buf, ierr) - integer(zoltan_int), dimension(*), intent(inout) :: data - integer(zoltan_int), intent(in) :: num_gid_entries - integer(zoltan_int), intent(in) :: num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer(zoltan_int), intent(in), dimension(*) :: sizes - integer(zoltan_int), intent(in), dimension(*) :: idx - integer(zoltan_int), intent(in), dimension(*), target :: buf - integer(zoltan_int), intent(out) :: ierr - - type(element_type), pointer :: eshape - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - real, dimension(:), allocatable :: rbuf ! easier to read reals - integer, dimension(:), pointer :: nodes - integer, dimension(1:ele_loc(zoltan_global_new_positions,1)):: vertex_order - integer :: rhead, i, state_no, field_no, loc, sz, dataSize, k - integer :: old_universal_element_number, new_local_element_number - integer :: ndetectors_in_ele, det, total_det_unpacked - type(detector_type), pointer :: detector => null() - type(element_type), pointer :: shape => null() - - integer, dimension(3) :: attribute_size !buffer containing the size of particle attributes - integer :: total_attributes !total number of attributes carried by a particle - - ewrite(1,*) "In zoltan_cb_unpack_fields" - - total_det_unpacked=0 - - do i=1,num_ids - - old_universal_element_number = global_ids(i) - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - - loc = ele_loc(zoltan_global_new_positions, new_local_element_number) - ! work out the order of the send data, using the unns of the vertices in the send order - ! this returns the local (within the element) node numbers of the vertices in send order - vertex_order = local_vertex_order(buf(idx(i):idx(i) + loc -1), ele_nodes(zoltan_global_new_positions, new_local_element_number)) - - ! work back number of scalar values 'sz' from the formula above in zoltan_cb_pack_field_sizes - sz = (sizes(i) - ele_loc(zoltan_global_zz_mesh, new_local_element_number) * integer_size) / real_size - allocate(rbuf(sz)) - ! Determine the size of the real data in integer_size units - dataSize = sz * real_size / integer_size - rbuf = transfer(buf(idx(i) + loc:idx(i) + loc + dataSize - 1), rbuf, sz) - - rhead = 1 - - do state_no=1, size(zoltan_global_target_states) - - do field_no=1,scalar_field_count(zoltan_global_target_states(state_no)) - sfield => extract_scalar_field(zoltan_global_target_states(state_no), field_no) - eshape => ele_shape(sfield, new_local_element_number) - nodes => ele_nodes(sfield, new_local_element_number) - loc = size(nodes) - call set(sfield, nodes(ele_local_num(vertex_order, eshape%numbering)), & + + ierr = ZOLTAN_OK + + end subroutine zoltan_cb_pack_field_sizes + + + subroutine zoltan_cb_pack_fields(data, num_gid_entries, num_lid_entries, num_ids, global_ids, local_ids, dest, sizes, idx, buf, ierr) + integer(zoltan_int), dimension(*), intent(in) :: data + integer(zoltan_int), intent(in) :: num_gid_entries, num_lid_entries, num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: local_ids + integer(zoltan_int), intent(in), dimension(*) :: dest + integer(zoltan_int), intent(in), dimension(*) :: sizes + integer(zoltan_int), intent(in), dimension(*) :: idx + integer(zoltan_int), intent(out), dimension(*), target :: buf + integer(zoltan_int), intent(out) :: ierr + + real, dimension(:), allocatable :: rbuf ! easier to write reals to real memory + integer :: rhead, i, j, k, state_no, field_no, loc, sz, total_det_packed + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + integer :: old_universal_element_number, old_local_element_number, dataSize + integer, dimension(3) :: attribute_size !buffer containing the size of particle attributes + integer :: total_attributes !total number of attributes carried by a particle + + type(detector_type), pointer :: detector => null(), detector_to_delete => null() + + ewrite(1,*) "In zoltan_cb_pack_fields" + + total_det_packed=0 + do i=1,num_ids + + ! work back number of scalar values 'sz' from the formula above in zoltan_cb_pack_field_sizes + sz = (sizes(i) - ele_loc(zoltan_global_zz_mesh, old_local_element_number) * integer_size) / real_size + allocate(rbuf(sz)) + + old_universal_element_number = global_ids(i) + old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) + + rhead = 1 + + do state_no=1,size(zoltan_global_source_states) + do field_no=1,scalar_field_count(zoltan_global_source_states(state_no)) + sfield => extract_scalar_field(zoltan_global_source_states(state_no), field_no) + loc = ele_loc(sfield, old_local_element_number) + rbuf(rhead:rhead + loc - 1) = ele_val(sfield, old_local_element_number) + rhead = rhead + loc + end do + + do field_no=1,vector_field_count(zoltan_global_source_states(state_no)) + vfield => extract_vector_field(zoltan_global_source_states(state_no), field_no) + if (index(vfield%name,"Coordinate")==len_trim(vfield%name)-9) cycle + loc = ele_loc(vfield, old_local_element_number) + rbuf(rhead:rhead + loc*vfield%dim - 1) = reshape(ele_val(vfield, old_local_element_number), (/loc*vfield%dim/)) + rhead = rhead + loc * vfield%dim + end do + + do field_no=1,tensor_field_count(zoltan_global_source_states(state_no)) + tfield => extract_tensor_field(zoltan_global_source_states(state_no), field_no) + loc = ele_loc(tfield, old_local_element_number) + rbuf(rhead:rhead + loc*product(tfield%dim) - 1) & + = reshape(ele_val(tfield, old_local_element_number), (/ loc*product(tfield%dim) /)) + rhead = rhead + loc * product(tfield%dim) + end do + + end do + + ! packing the number of detectors in the element + rbuf(rhead) = zoltan_global_ndets_in_ele(i) + rhead = rhead + 1 + + if(zoltan_global_to_pack_detectors_list(i)%length /= 0) then + detector => zoltan_global_to_pack_detectors_list(i)%first + end if + + ! packing the detectors in that element + do j=1,zoltan_global_ndets_in_ele(i) + !check attribute sizes + attribute_size(1) = size(detector%attributes) + attribute_size(2) = size(detector%old_attributes) + attribute_size(3) = size(detector%old_fields) + + total_attributes = sum(attribute_size) + !pack attribute sizes + do k = 1,3 + rbuf(rhead)=attribute_size(k) + rhead=rhead+1 + end do + + !pack the detector + call pack_detector(detector, rbuf(rhead:rhead+zoltan_global_ndata_per_det-1+total_attributes), & + zoltan_global_ndims, attribute_size_in=attribute_size) + ! keep a pointer to the detector to delete + detector_to_delete => detector + ! move on our iterating pointer so it's not left on a deleted node + detector => detector%next + + ! delete the detector we just packed from the to_pack list + call delete(detector_to_delete, zoltan_global_to_pack_detectors_list(i)) + + rhead = rhead + zoltan_global_ndata_per_det+total_attributes + total_det_packed=total_det_packed+1 + end do + + assert(rhead==sz+1) + + ! At the start, write the old unns of this element + loc = ele_loc(zoltan_global_zz_mesh, old_local_element_number) + buf(idx(i):idx(i) + loc -1) = halo_universal_number(zoltan_global_zz_halo, ele_nodes(zoltan_global_zz_mesh, old_local_element_number)) + + ! Determine the size of the real data in integer_size units + dataSize = sz * real_size / integer_size + assert( dataSize==size(transfer(rbuf, buf(idx(i):idx(i)+1))) ) + ! Now we know the size, we can copy in the right amount of data. + buf(idx(i) + loc:idx(i) + loc + dataSize - 1) = transfer(rbuf, buf(idx(i):idx(i)+1)) + + deallocate(rbuf) + + assert(zoltan_global_to_pack_detectors_list(i)%length == 0) + + end do + + deallocate(zoltan_global_to_pack_detectors_list) + + ewrite(2,*) "Packed ", total_det_packed, " detectors" + ewrite(1,*) "Exiting zoltan_cb_pack_fields" + + ierr = ZOLTAN_OK + + end subroutine zoltan_cb_pack_fields + + + function local_vertex_order(old_unns, new_gnns) + ! little auxilary function that works out the ordering of the send data + ! (which uses the old element ordering) in terms of new local (within the element) + ! node numbers of the vertices + ! old_unns are the unns of the vertices in the old ordering + ! new_gnss are the global (within the local domain) node numbers in the new ordering + integer, dimension(:), intent(in):: old_unns, new_gnns + integer, dimension(size(old_unns)):: local_vertex_order + integer:: i, j, gnn + + do i=1, size(old_unns) + gnn = fetch(zoltan_global_universal_to_new_local_numbering, old_unns(i)) + do j=1, size(new_gnns) + if (new_gnns(j)==gnn) exit + end do + if (j>size(new_gnns)) then + ! node in element send is not in receiving element + ewrite(0,*) i, gnn + ewrite(0,*) old_unns + ewrite(0,*) new_gnns + FLAbort("In zoltan redistribution: something went wrong in element reconstruction") + end if + local_vertex_order(i) = j + end do + + end function local_vertex_order + + + subroutine zoltan_cb_unpack_fields(data, num_gid_entries, num_ids, global_ids, sizes, idx, buf, ierr) + integer(zoltan_int), dimension(*), intent(inout) :: data + integer(zoltan_int), intent(in) :: num_gid_entries + integer(zoltan_int), intent(in) :: num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer(zoltan_int), intent(in), dimension(*) :: sizes + integer(zoltan_int), intent(in), dimension(*) :: idx + integer(zoltan_int), intent(in), dimension(*), target :: buf + integer(zoltan_int), intent(out) :: ierr + + type(element_type), pointer :: eshape + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + real, dimension(:), allocatable :: rbuf ! easier to read reals + integer, dimension(:), pointer :: nodes + integer, dimension(1:ele_loc(zoltan_global_new_positions,1)):: vertex_order + integer :: rhead, i, state_no, field_no, loc, sz, dataSize, k + integer :: old_universal_element_number, new_local_element_number + integer :: ndetectors_in_ele, det, total_det_unpacked + type(detector_type), pointer :: detector => null() + type(element_type), pointer :: shape => null() + + integer, dimension(3) :: attribute_size !buffer containing the size of particle attributes + integer :: total_attributes !total number of attributes carried by a particle + + ewrite(1,*) "In zoltan_cb_unpack_fields" + + total_det_unpacked=0 + + do i=1,num_ids + + old_universal_element_number = global_ids(i) + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + + loc = ele_loc(zoltan_global_new_positions, new_local_element_number) + ! work out the order of the send data, using the unns of the vertices in the send order + ! this returns the local (within the element) node numbers of the vertices in send order + vertex_order = local_vertex_order(buf(idx(i):idx(i) + loc -1), ele_nodes(zoltan_global_new_positions, new_local_element_number)) + + ! work back number of scalar values 'sz' from the formula above in zoltan_cb_pack_field_sizes + sz = (sizes(i) - ele_loc(zoltan_global_zz_mesh, new_local_element_number) * integer_size) / real_size + allocate(rbuf(sz)) + ! Determine the size of the real data in integer_size units + dataSize = sz * real_size / integer_size + rbuf = transfer(buf(idx(i) + loc:idx(i) + loc + dataSize - 1), rbuf, sz) + + rhead = 1 + + do state_no=1, size(zoltan_global_target_states) + + do field_no=1,scalar_field_count(zoltan_global_target_states(state_no)) + sfield => extract_scalar_field(zoltan_global_target_states(state_no), field_no) + eshape => ele_shape(sfield, new_local_element_number) + nodes => ele_nodes(sfield, new_local_element_number) + loc = size(nodes) + call set(sfield, nodes(ele_local_num(vertex_order, eshape%numbering)), & rbuf(rhead:rhead + loc - 1)) - rhead = rhead + loc - end do - - do field_no=1,vector_field_count(zoltan_global_target_states(state_no)) - vfield => extract_vector_field(zoltan_global_target_states(state_no), field_no) - if (index(vfield%name,"Coordinate")==len_trim(vfield%name)-9) cycle - eshape => ele_shape(vfield, new_local_element_number) - nodes => ele_nodes(vfield, new_local_element_number) - loc = size(nodes) - call set(vfield, nodes(ele_local_num(vertex_order, eshape%numbering)), & + rhead = rhead + loc + end do + + do field_no=1,vector_field_count(zoltan_global_target_states(state_no)) + vfield => extract_vector_field(zoltan_global_target_states(state_no), field_no) + if (index(vfield%name,"Coordinate")==len_trim(vfield%name)-9) cycle + eshape => ele_shape(vfield, new_local_element_number) + nodes => ele_nodes(vfield, new_local_element_number) + loc = size(nodes) + call set(vfield, nodes(ele_local_num(vertex_order, eshape%numbering)), & reshape(rbuf(rhead:rhead + loc*vfield%dim - 1), (/vfield%dim, loc/))) - rhead = rhead + loc * vfield%dim - end do - - do field_no=1,tensor_field_count(zoltan_global_target_states(state_no)) - tfield => extract_tensor_field(zoltan_global_target_states(state_no), field_no) - eshape => ele_shape(tfield, new_local_element_number) - nodes => ele_nodes(tfield, new_local_element_number) - loc = size(nodes) - call set(tfield, nodes(ele_local_num(vertex_order, eshape%numbering)), & + rhead = rhead + loc * vfield%dim + end do + + do field_no=1,tensor_field_count(zoltan_global_target_states(state_no)) + tfield => extract_tensor_field(zoltan_global_target_states(state_no), field_no) + eshape => ele_shape(tfield, new_local_element_number) + nodes => ele_nodes(tfield, new_local_element_number) + loc = size(nodes) + call set(tfield, nodes(ele_local_num(vertex_order, eshape%numbering)), & reshape(rbuf(rhead:rhead + loc*product(tfield%dim) - 1), & (/tfield%dim(1), tfield%dim(2), loc/))) - rhead = rhead + loc * product(tfield%dim) - end do + rhead = rhead + loc * product(tfield%dim) + end do - end do + end do - ndetectors_in_ele = rbuf(rhead) - rhead = rhead + 1 + ndetectors_in_ele = rbuf(rhead) + rhead = rhead + 1 - ! check if there are any detectors associated with this element - if(ndetectors_in_ele > 0) then + ! check if there are any detectors associated with this element + if(ndetectors_in_ele > 0) then - do det=1,ndetectors_in_ele - ! allocate a detector - shape=>ele_shape(zoltan_global_new_positions,1) + do det=1,ndetectors_in_ele + ! allocate a detector + shape=>ele_shape(zoltan_global_new_positions,1) - ! determine particle attribute size - do k = 1,3 - attribute_size(k) = rbuf(rhead) - rhead = rhead + 1 - end do - total_attributes = sum(attribute_size) + ! determine particle attribute size + do k = 1,3 + attribute_size(k) = rbuf(rhead) + rhead = rhead + 1 + end do + total_attributes = sum(attribute_size) - call allocate(detector, zoltan_global_ndims, local_coord_count(shape), attribute_size=attribute_size) + call allocate(detector, zoltan_global_ndims, local_coord_count(shape), attribute_size=attribute_size) - ! unpack detector information - call unpack_detector(detector, rbuf(rhead:rhead+zoltan_global_ndata_per_det-1+total_attributes), zoltan_global_ndims, & - global_to_local=zoltan_global_uen_to_new_local_numbering, coordinates=zoltan_global_new_positions, & - attribute_size_in=attribute_size) + ! unpack detector information + call unpack_detector(detector, rbuf(rhead:rhead+zoltan_global_ndata_per_det-1+total_attributes), zoltan_global_ndims, & + global_to_local=zoltan_global_uen_to_new_local_numbering, coordinates=zoltan_global_new_positions, & + attribute_size_in=attribute_size) - ! Make sure the unpacked detector is in this element - assert(new_local_element_number==detector%element) + ! Make sure the unpacked detector is in this element + assert(new_local_element_number==detector%element) - call insert(detector, zoltan_global_unpacked_detectors_list) - detector => null() + call insert(detector, zoltan_global_unpacked_detectors_list) + detector => null() - rhead = rhead + zoltan_global_ndata_per_det + total_attributes - total_det_unpacked=total_det_unpacked+1 - end do - end if + rhead = rhead + zoltan_global_ndata_per_det + total_attributes + total_det_unpacked=total_det_unpacked+1 + end do + end if - assert(rhead==sz+1) - deallocate(rbuf) - end do + assert(rhead==sz+1) + deallocate(rbuf) + end do - assert(total_det_unpacked==zoltan_global_unpacked_detectors_list%length) - ewrite(2,*) "Unpacked", zoltan_global_unpacked_detectors_list%length, "detectors" - ewrite(1,*) "Exiting zoltan_cb_unpack_fields" + assert(total_det_unpacked==zoltan_global_unpacked_detectors_list%length) + ewrite(2,*) "Unpacked", zoltan_global_unpacked_detectors_list%length, "detectors" + ewrite(1,*) "Exiting zoltan_cb_unpack_fields" - ierr = ZOLTAN_OK + ierr = ZOLTAN_OK - end subroutine zoltan_cb_unpack_fields + end subroutine zoltan_cb_unpack_fields #endif diff --git a/assemble/Zoltan_detectors.F90 b/assemble/Zoltan_detectors.F90 index 9c22df4dbd..0ff9ca31fc 100644 --- a/assemble/Zoltan_detectors.F90 +++ b/assemble/Zoltan_detectors.F90 @@ -4,127 +4,127 @@ module zoltan_detectors #ifdef HAVE_ZOLTAN - use zoltan, only: zoltan_int - use fldebug - use data_structures, only: has_key, fetch - use detector_data_types - use parallel_tools - use parallel_fields - use fields - use zoltan_global_variables, only: zoltan_global_uen_to_new_local_numbering, zoltan_global_old_local_numbering_to_uen, zoltan_global_new_positions - use detector_tools - use detector_parallel - - - implicit none - - public :: prepare_detectors_for_packing - private - - contains - - subroutine prepare_detectors_for_packing(ndets_in_ele, to_pack_detector_lists, num_ids, global_ids, attributes_per_ele) - ! Goes through all local detectors and moves the ones we want to send to the according - ! to_pack_detector_list for the element we found the detector in - integer, intent(out), dimension(:) :: ndets_in_ele - type(detector_linked_list), dimension(:), intent(inout), target :: to_pack_detector_lists - integer(zoltan_int), intent(in) :: num_ids - integer(zoltan_int), intent(in), dimension(*) :: global_ids - integer, intent(out), dimension(:) :: attributes_per_ele !Number of particle attributes per element - - integer :: i, j, det_list, new_ele_owner, total_det_to_pack, detector_uen - integer :: new_local_element_number, total_attributes - - type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() - type(detector_type), pointer :: detector => null(), detector_to_move => null() - logical :: found_det_element - - ewrite(1,*) "In prepare_detectors_for_packing" - - assert(num_ids == size(ndets_in_ele)) - assert(num_ids == size(to_pack_detector_lists)) - - ! loop through all registered detector lists - call get_registered_detector_lists(detector_list_array) - do det_list = 1, size(detector_list_array) - ! search through all the local detectors in this list - detector => detector_list_array(det_list)%ptr%first - - !Set up particle attribute parameters - total_attributes = 0 - if (associated(detector)) then - total_attributes = size(detector%attributes) + size(detector%old_attributes) + size(detector%old_fields) - end if - - detector_loop: do while (associated(detector)) - ! store the list ID with the detector, so we can map the detector back when receiving it - detector%list_id=det_list - - ! translate detector element to uen - if (.not. has_key(zoltan_global_old_local_numbering_to_uen, detector%element)) then - ewrite(-1,*) "No uen found in Zoltan for detector ", detector%id_number, " with local element number ", detector%element - FLAbort("No universal element number for detector found in Zoltan") - end if - detector_uen = fetch(zoltan_global_old_local_numbering_to_uen, detector%element) - - ! loop over all the elements we're interested in - found_det_element=.false. - element_loop: do j=1, num_ids - - ! check whether detector is in this element - if (detector_uen == global_ids(j)) then - found_det_element=.true. - - ! work out new owner - if (has_key(zoltan_global_uen_to_new_local_numbering, detector_uen)) then - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, detector_uen) - new_ele_owner = element_owner(zoltan_global_new_positions%mesh, new_local_element_number) - else - new_ele_owner = -1 - end if - - ! check whether old owner is new owner - if (new_ele_owner == getprocno()) then - ndets_in_ele(j) = 0 - detector => detector%next - else - ! If not, move detector to the pack_list for this element and - ! increment the number of detectors in that element - ndets_in_ele(j) = ndets_in_ele(j) + 1 - attributes_per_ele(j) = attributes_per_ele(j) + total_attributes - - detector_to_move => detector - detector => detector%next - - ! Update detector%element to be universal element number - ! so we can unpack to new element number - detector_to_move%element = detector_uen - - ! Move detector to list of detectors we need to pack - call move(detector_to_move, detector_list_array(det_list)%ptr, to_pack_detector_lists(j)) - detector_to_move => null() - end if - - ! We found the right element, so we can skip the others - exit element_loop - end if - end do element_loop - - ! If we didn't find an element for the detector, we have to advance it - if (.not.found_det_element) detector => detector%next - end do detector_loop - end do - - ! Sanity checks and logging - total_det_to_pack=0 - do i=1, num_ids - assert(ndets_in_ele(i) == to_pack_detector_lists(i)%length) - total_det_to_pack=total_det_to_pack+to_pack_detector_lists(i)%length - end do - ewrite(2,*) "Moved", total_det_to_pack, "detectors to to_pack_detector_lists" - ewrite(1,*) "Exiting prepare_detectors_for_packing" - - end subroutine prepare_detectors_for_packing + use zoltan, only: zoltan_int + use fldebug + use data_structures, only: has_key, fetch + use detector_data_types + use parallel_tools + use parallel_fields + use fields + use zoltan_global_variables, only: zoltan_global_uen_to_new_local_numbering, zoltan_global_old_local_numbering_to_uen, zoltan_global_new_positions + use detector_tools + use detector_parallel + + + implicit none + + public :: prepare_detectors_for_packing + private + +contains + + subroutine prepare_detectors_for_packing(ndets_in_ele, to_pack_detector_lists, num_ids, global_ids, attributes_per_ele) + ! Goes through all local detectors and moves the ones we want to send to the according + ! to_pack_detector_list for the element we found the detector in + integer, intent(out), dimension(:) :: ndets_in_ele + type(detector_linked_list), dimension(:), intent(inout), target :: to_pack_detector_lists + integer(zoltan_int), intent(in) :: num_ids + integer(zoltan_int), intent(in), dimension(*) :: global_ids + integer, intent(out), dimension(:) :: attributes_per_ele !Number of particle attributes per element + + integer :: i, j, det_list, new_ele_owner, total_det_to_pack, detector_uen + integer :: new_local_element_number, total_attributes + + type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() + type(detector_type), pointer :: detector => null(), detector_to_move => null() + logical :: found_det_element + + ewrite(1,*) "In prepare_detectors_for_packing" + + assert(num_ids == size(ndets_in_ele)) + assert(num_ids == size(to_pack_detector_lists)) + + ! loop through all registered detector lists + call get_registered_detector_lists(detector_list_array) + do det_list = 1, size(detector_list_array) + ! search through all the local detectors in this list + detector => detector_list_array(det_list)%ptr%first + + !Set up particle attribute parameters + total_attributes = 0 + if (associated(detector)) then + total_attributes = size(detector%attributes) + size(detector%old_attributes) + size(detector%old_fields) + end if + + detector_loop: do while (associated(detector)) + ! store the list ID with the detector, so we can map the detector back when receiving it + detector%list_id=det_list + + ! translate detector element to uen + if (.not. has_key(zoltan_global_old_local_numbering_to_uen, detector%element)) then + ewrite(-1,*) "No uen found in Zoltan for detector ", detector%id_number, " with local element number ", detector%element + FLAbort("No universal element number for detector found in Zoltan") + end if + detector_uen = fetch(zoltan_global_old_local_numbering_to_uen, detector%element) + + ! loop over all the elements we're interested in + found_det_element=.false. + element_loop: do j=1, num_ids + + ! check whether detector is in this element + if (detector_uen == global_ids(j)) then + found_det_element=.true. + + ! work out new owner + if (has_key(zoltan_global_uen_to_new_local_numbering, detector_uen)) then + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, detector_uen) + new_ele_owner = element_owner(zoltan_global_new_positions%mesh, new_local_element_number) + else + new_ele_owner = -1 + end if + + ! check whether old owner is new owner + if (new_ele_owner == getprocno()) then + ndets_in_ele(j) = 0 + detector => detector%next + else + ! If not, move detector to the pack_list for this element and + ! increment the number of detectors in that element + ndets_in_ele(j) = ndets_in_ele(j) + 1 + attributes_per_ele(j) = attributes_per_ele(j) + total_attributes + + detector_to_move => detector + detector => detector%next + + ! Update detector%element to be universal element number + ! so we can unpack to new element number + detector_to_move%element = detector_uen + + ! Move detector to list of detectors we need to pack + call move(detector_to_move, detector_list_array(det_list)%ptr, to_pack_detector_lists(j)) + detector_to_move => null() + end if + + ! We found the right element, so we can skip the others + exit element_loop + end if + end do element_loop + + ! If we didn't find an element for the detector, we have to advance it + if (.not.found_det_element) detector => detector%next + end do detector_loop + end do + + ! Sanity checks and logging + total_det_to_pack=0 + do i=1, num_ids + assert(ndets_in_ele(i) == to_pack_detector_lists(i)%length) + total_det_to_pack=total_det_to_pack+to_pack_detector_lists(i)%length + end do + ewrite(2,*) "Moved", total_det_to_pack, "detectors to to_pack_detector_lists" + ewrite(1,*) "Exiting prepare_detectors_for_packing" + + end subroutine prepare_detectors_for_packing #endif diff --git a/assemble/Zoltan_global_variables.F90 b/assemble/Zoltan_global_variables.F90 index d16907332b..c6c45306d0 100644 --- a/assemble/Zoltan_global_variables.F90 +++ b/assemble/Zoltan_global_variables.F90 @@ -5,100 +5,100 @@ module zoltan_global_variables #ifdef HAVE_ZOLTAN - use data_structures, only: integer_set, integer_hash_table - use global_parameters, only: OPTION_PATH_LEN - use sparse_tools, only: csr_sparsity - use fields, only: scalar_field, vector_field, mesh_type - use zoltan, only: zoltan_int, zoltan_float - use state_module, only: state_type - use halos, only: halo_type - use detector_data_types, only: detector_linked_list - - implicit none - - private - - ! Needed for zoltan_cb_owned_node_count - type(halo_type), save, pointer, public :: zoltan_global_zz_halo - - ! Needed for zoltan_cb_get_owned_nodes - type(csr_sparsity), save, public :: zoltan_global_columns_sparsity - logical, save, public :: zoltan_global_migrate_extruded_mesh - logical, save, public :: zoltan_global_field_weighted_partitions - type(scalar_field), save, public :: zoltan_global_field_weighted_partition_values - - ! Needed for zoltan_cb_get_num_edges - type(csr_sparsity), save, pointer, public :: zoltan_global_zz_sparsity_one - - ! Needed for zoltan_cb_get_edge_list - logical, save, public :: zoltan_global_calculate_edge_weights - ! elements with quality greater than this value are ok - ! those with element quality below it need to be adapted - real, save, public :: zoltan_global_quality_tolerance - type(scalar_field), save, public :: zoltan_global_element_quality - type(scalar_field), save, pointer, public :: zoltan_global_max_edge_weight_on_node - logical, save, public :: zoltan_global_output_edge_weights = .false. - type(csr_sparsity), save, pointer, public :: zoltan_global_zz_nelist - - ! Needed for zoltan_cb_pack_node_sizes - ! - added vector_field to use fields - type(vector_field), save, public :: zoltan_global_zz_positions - integer, parameter, public :: integer_size = bit_size(0_zoltan_int)/8 - logical, save, public :: zoltan_global_preserve_columns=.false. - logical, save, public :: zoltan_global_preserve_mesh_regions - type(csr_sparsity), save, pointer, public :: zoltan_global_zz_sparsity_two - type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_old_snelist - - - ! Needed for zoltan_cb_pack_nodes - type(integer_hash_table), save, public :: zoltan_global_universal_element_number_to_region_id - type(integer_hash_table), save, public :: zoltan_global_universal_surface_number_to_element_owner - type(integer_hash_table), save, public :: zoltan_global_universal_surface_number_to_surface_id - integer, dimension(:), allocatable, save, public :: zoltan_global_universal_columns - type(halo_type), save, pointer, public :: zoltan_global_zz_ele_halo - - - ! Needed for zoltan_cb_unpack_nodes - type(vector_field), save, public :: zoltan_global_new_positions - integer, save, public :: zoltan_global_new_positions_mesh_nhalos - type(mesh_type), save, public :: zoltan_global_zz_mesh - type(integer_hash_table), save, public :: zoltan_global_nodes_we_are_sending ! in old local numbers - type(integer_set), save, public :: zoltan_global_nodes_we_are_keeping ! in old local numbers - type(integer_hash_table), save, public :: zoltan_global_universal_to_new_local_numbering - type(integer_hash_table), save, public :: zoltan_global_universal_to_old_local_numbering - type(integer_set), save, public :: zoltan_global_new_nodes - type(integer_hash_table), save, public :: zoltan_global_universal_to_new_local_numbering_m1d - type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_new_snelist - type(integer_set), save, public :: zoltan_global_new_surface_elements - type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_new_nelist - type(integer_set), save, public :: zoltan_global_new_elements - integer(zoltan_int), save, dimension(:), pointer, public :: zoltan_global_my_import_procs => null() - integer(zoltan_int), save, dimension(:), pointer, public :: zoltan_global_my_import_global_ids => null() - integer(zoltan_int), save, public :: zoltan_global_my_num_import - type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_receives - - - ! Needed for prepare_detectors_for_packing - type(integer_hash_table), save, public :: zoltan_global_uen_to_new_local_numbering - type(integer_hash_table), save, public :: zoltan_global_uen_to_old_local_numbering - type(integer_hash_table), save, public :: zoltan_global_old_local_numbering_to_uen - - - ! Needed for zoltan_cb_pack_field_sizes - type(state_type), save, dimension(:), allocatable, public :: zoltan_global_source_states, zoltan_global_target_states - integer, save, dimension(:), allocatable, public :: zoltan_global_ndets_in_ele - integer, save, public :: zoltan_global_ndata_per_det - integer, dimension(:), allocatable, public :: zoltan_global_attributes_per_ele - type(detector_linked_list), dimension(:), allocatable, target, save, public :: zoltan_global_to_pack_detectors_list - - ! Needed for zoltan_cb_pack_fields - integer, save, public :: zoltan_global_ndims - - ! Needed for zoltan_cb_unpack_fields - type(detector_linked_list), target, save, public :: zoltan_global_unpacked_detectors_list - - ! Option path set based on whether being called from adaptivity or flredecomp - character(len = OPTION_PATH_LEN), save, public :: zoltan_global_base_option_path + use data_structures, only: integer_set, integer_hash_table + use global_parameters, only: OPTION_PATH_LEN + use sparse_tools, only: csr_sparsity + use fields, only: scalar_field, vector_field, mesh_type + use zoltan, only: zoltan_int, zoltan_float + use state_module, only: state_type + use halos, only: halo_type + use detector_data_types, only: detector_linked_list + + implicit none + + private + + ! Needed for zoltan_cb_owned_node_count + type(halo_type), save, pointer, public :: zoltan_global_zz_halo + + ! Needed for zoltan_cb_get_owned_nodes + type(csr_sparsity), save, public :: zoltan_global_columns_sparsity + logical, save, public :: zoltan_global_migrate_extruded_mesh + logical, save, public :: zoltan_global_field_weighted_partitions + type(scalar_field), save, public :: zoltan_global_field_weighted_partition_values + + ! Needed for zoltan_cb_get_num_edges + type(csr_sparsity), save, pointer, public :: zoltan_global_zz_sparsity_one + + ! Needed for zoltan_cb_get_edge_list + logical, save, public :: zoltan_global_calculate_edge_weights + ! elements with quality greater than this value are ok + ! those with element quality below it need to be adapted + real, save, public :: zoltan_global_quality_tolerance + type(scalar_field), save, public :: zoltan_global_element_quality + type(scalar_field), save, pointer, public :: zoltan_global_max_edge_weight_on_node + logical, save, public :: zoltan_global_output_edge_weights = .false. + type(csr_sparsity), save, pointer, public :: zoltan_global_zz_nelist + + ! Needed for zoltan_cb_pack_node_sizes + ! - added vector_field to use fields + type(vector_field), save, public :: zoltan_global_zz_positions + integer, parameter, public :: integer_size = bit_size(0_zoltan_int)/8 + logical, save, public :: zoltan_global_preserve_columns=.false. + logical, save, public :: zoltan_global_preserve_mesh_regions + type(csr_sparsity), save, pointer, public :: zoltan_global_zz_sparsity_two + type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_old_snelist + + + ! Needed for zoltan_cb_pack_nodes + type(integer_hash_table), save, public :: zoltan_global_universal_element_number_to_region_id + type(integer_hash_table), save, public :: zoltan_global_universal_surface_number_to_element_owner + type(integer_hash_table), save, public :: zoltan_global_universal_surface_number_to_surface_id + integer, dimension(:), allocatable, save, public :: zoltan_global_universal_columns + type(halo_type), save, pointer, public :: zoltan_global_zz_ele_halo + + + ! Needed for zoltan_cb_unpack_nodes + type(vector_field), save, public :: zoltan_global_new_positions + integer, save, public :: zoltan_global_new_positions_mesh_nhalos + type(mesh_type), save, public :: zoltan_global_zz_mesh + type(integer_hash_table), save, public :: zoltan_global_nodes_we_are_sending ! in old local numbers + type(integer_set), save, public :: zoltan_global_nodes_we_are_keeping ! in old local numbers + type(integer_hash_table), save, public :: zoltan_global_universal_to_new_local_numbering + type(integer_hash_table), save, public :: zoltan_global_universal_to_old_local_numbering + type(integer_set), save, public :: zoltan_global_new_nodes + type(integer_hash_table), save, public :: zoltan_global_universal_to_new_local_numbering_m1d + type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_new_snelist + type(integer_set), save, public :: zoltan_global_new_surface_elements + type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_new_nelist + type(integer_set), save, public :: zoltan_global_new_elements + integer(zoltan_int), save, dimension(:), pointer, public :: zoltan_global_my_import_procs => null() + integer(zoltan_int), save, dimension(:), pointer, public :: zoltan_global_my_import_global_ids => null() + integer(zoltan_int), save, public :: zoltan_global_my_num_import + type(integer_set), save, dimension(:), allocatable, public :: zoltan_global_receives + + + ! Needed for prepare_detectors_for_packing + type(integer_hash_table), save, public :: zoltan_global_uen_to_new_local_numbering + type(integer_hash_table), save, public :: zoltan_global_uen_to_old_local_numbering + type(integer_hash_table), save, public :: zoltan_global_old_local_numbering_to_uen + + + ! Needed for zoltan_cb_pack_field_sizes + type(state_type), save, dimension(:), allocatable, public :: zoltan_global_source_states, zoltan_global_target_states + integer, save, dimension(:), allocatable, public :: zoltan_global_ndets_in_ele + integer, save, public :: zoltan_global_ndata_per_det + integer, dimension(:), allocatable, public :: zoltan_global_attributes_per_ele + type(detector_linked_list), dimension(:), allocatable, target, save, public :: zoltan_global_to_pack_detectors_list + + ! Needed for zoltan_cb_pack_fields + integer, save, public :: zoltan_global_ndims + + ! Needed for zoltan_cb_unpack_fields + type(detector_linked_list), target, save, public :: zoltan_global_unpacked_detectors_list + + ! Option path set based on whether being called from adaptivity or flredecomp + character(len = OPTION_PATH_LEN), save, public :: zoltan_global_base_option_path #endif diff --git a/assemble/Zoltan_integration.F90 b/assemble/Zoltan_integration.F90 index d213821f16..30cd981563 100644 --- a/assemble/Zoltan_integration.F90 +++ b/assemble/Zoltan_integration.F90 @@ -4,248 +4,206 @@ module zoltan_integration #ifdef HAVE_ZOLTAN - use spud - use fldebug - use global_parameters, only: real_size, OPTION_PATH_LEN, topology_mesh_name,& + use spud + use fldebug + use global_parameters, only: real_size, OPTION_PATH_LEN, topology_mesh_name,& FIELD_NAME_LEN - use futils, only: int2str, present_and_true - use quadrature - use element_numbering, only: ele_local_num - use elements - use mpi_interfaces - use data_structures - use parallel_tools - use memory_diagnostics - use sparse_tools - use linked_lists - use halos_ownership - use parallel_fields - use transform_elements - use metric_tools - use fields - use state_module - use field_options - use vtk_interfaces - use zoltan - use halos_derivation - use halos - use sparsity_patterns_meshes - use reserve_state_module - use boundary_conditions - use detector_data_types - use boundary_conditions_from_options - use pickers - use detector_tools - use detector_parallel - use hadapt_advancing_front - use fields_halos - use populate_state_module - use surface_id_interleaving - use adapt_integration - use zoltan_global_variables - use zoltan_detectors - use zoltan_callbacks - - implicit none - - integer, save :: max_coplanar_id - - public :: zoltan_drive - private - - contains - - subroutine zoltan_drive(states, final_adapt_iteration, global_min_quality, metric, full_metric, initialise_fields, & - skip_extrusion_after, skip_extruded_mesh_migration, flredecomping, input_procs, target_procs) - - type(state_type), dimension(:), intent(inout), target :: states - logical, intent(in) :: final_adapt_iteration - ! returns the minimum element quality. When using libadapitivity (instead of mba2d/3d), - ! it is based on the minimum nodal quality where the nodal quality is computed from the - ! *maximum* quality of the adjacent elements at each node - as this is closer to libadaptivity's - ! termination criterion - real, intent(out), optional :: global_min_quality - ! the metric is the metric we base the quality functions on - type(tensor_field), intent(inout), optional :: metric - ! the full_metric is the metric we need to interpolate - type(tensor_field), intent(inout), optional :: full_metric - ! if present and true: don't bother redistributing fields that can be reinitialised - logical, intent(in), optional :: initialise_fields - ! if present and true: don't extrude meshes after decomposition - logical, intent(in), optional :: skip_extrusion_after - ! if present and true: only decompose and migrate the horizontal mesh - logical, intent(in), optional :: skip_extruded_mesh_migration - ! Are we flredecomping? If so, this should be true - logical, intent(in), optional :: flredecomping - ! If flredecomping then these values should be provided - integer, intent(in), optional :: input_procs, target_procs - - type(zoltan_struct), pointer :: zz - - logical :: changes - integer(zoltan_int) :: num_gid_entries, num_lid_entries - integer(zoltan_int), dimension(:), pointer :: p1_export_global_ids => null() - integer(zoltan_int), dimension(:), pointer :: p1_export_local_ids => null() - integer(zoltan_int), dimension(:), pointer :: p1_export_procs => null() - integer(zoltan_int) :: p1_num_import, p1_num_export - integer(zoltan_int), dimension(:), pointer :: p1_import_global_ids => null() - integer(zoltan_int), dimension(:), pointer :: p1_import_local_ids => null() - integer(zoltan_int), dimension(:), pointer :: p1_import_procs => null() - integer, save :: dumpno = 0 - - type(tensor_field) :: new_metric - type(mesh_type), pointer :: full_mesh - - integer(zoltan_int), dimension(:), pointer :: p1_export_local_ids_full => null() - integer(zoltan_int), dimension(:), pointer :: p1_export_procs_full => null() - integer(zoltan_int) :: p1_num_export_full - type(vector_field) :: zoltan_global_new_positions_m1d - real :: load_imbalance_tolerance - logical :: flredecomp - real :: minimum_quality - integer :: flredecomp_input_procs = -1, flredecomp_target_procs = -1 - - ewrite(1,*) "In zoltan_drive" - - if (.not. present(flredecomping)) then - flredecomp = .false. - else - flredecomp = flredecomping - end if - - if (flredecomp) then - ! check for required optional arguments - if (present(input_procs)) then - flredecomp_input_procs = input_procs - else - FLAbort("input_procs must be supplied when flredecomping.") - end if - if (present(target_procs)) then - flredecomp_target_procs = target_procs - else - FLAbort("target_procs must be supplied when flredecomping.") - end if - - zoltan_global_base_option_path = '/flredecomp' - else - ! check invalid optional arguments haven't been supplied - if (present(input_procs)) then - FLAbort("input_procs should only be provided when flredecomping.") - end if - if (present(target_procs)) then - FLAbort("target_procs should only be provided when flredecomping.") - end if - - zoltan_global_base_option_path = '/mesh_adaptivity/hr_adaptivity/zoltan_options' - end if - - zoltan_global_field_weighted_partitions = & - have_option(trim(zoltan_global_base_option_path) // "/field_weighted_partitions") - - call setup_module_variables(states, final_adapt_iteration, zz, flredecomp) - - call setup_quality_module_variables(metric, minimum_quality) ! this needs to be called after setup_module_variables - ! (but only on the 2d mesh with 2+1d adaptivity) - if (present(global_min_quality)) then - if (.NOT. final_adapt_iteration) then - global_min_quality = minimum_quality - else - ! On final iteration we do not calculate the minimum element quality - global_min_quality = 1.0 - end if - end if - - full_mesh => extract_mesh(states(1), trim(topology_mesh_name)) - zoltan_global_migrate_extruded_mesh = (mesh_dim(full_mesh) /= mesh_dim(zoltan_global_zz_mesh)) .and. & - .not. present_and_true(skip_extruded_mesh_migration) - - if(zoltan_global_migrate_extruded_mesh .AND. zoltan_global_field_weighted_partitions) then - ewrite(-1,*) "Cannot weight mesh partitions based upon extruded columns"// & - "and a prescribed field. Select one option only or fix the code." - FLExit("Use Weighted mesh partitions for EITHER extruded meshes or prescribed fields") - end if - - if(zoltan_global_migrate_extruded_mesh) then - call create_columns_sparsity(zoltan_global_columns_sparsity, full_mesh) - end if - - load_imbalance_tolerance = get_load_imbalance_tolerance(final_adapt_iteration) - call set_zoltan_parameters(final_adapt_iteration, flredecomp, flredecomp_target_procs, load_imbalance_tolerance, zz) - - call zoltan_load_balance(zz, changes, num_gid_entries, num_lid_entries, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, & - & load_imbalance_tolerance, flredecomp, flredecomp_input_procs, flredecomp_target_procs) - - if (.not. changes) then - ewrite(1,*) "Zoltan decided no change was necessary, exiting" - call deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_export_global_ids, p1_export_local_ids, p1_export_procs) - call cleanup_basic_module_variables(zz) - call cleanup_quality_module_variables - dumpno = dumpno + 1 + use futils, only: int2str, present_and_true + use quadrature + use element_numbering, only: ele_local_num + use elements + use mpi_interfaces + use data_structures + use parallel_tools + use memory_diagnostics + use sparse_tools + use linked_lists + use halos_ownership + use parallel_fields + use transform_elements + use metric_tools + use fields + use state_module + use field_options + use vtk_interfaces + use zoltan + use halos_derivation + use halos + use sparsity_patterns_meshes + use reserve_state_module + use boundary_conditions + use detector_data_types + use boundary_conditions_from_options + use pickers + use detector_tools + use detector_parallel + use hadapt_advancing_front + use fields_halos + use populate_state_module + use surface_id_interleaving + use adapt_integration + use zoltan_global_variables + use zoltan_detectors + use zoltan_callbacks + + implicit none + + integer, save :: max_coplanar_id + + public :: zoltan_drive + private + +contains + + subroutine zoltan_drive(states, final_adapt_iteration, global_min_quality, metric, full_metric, initialise_fields, & + skip_extrusion_after, skip_extruded_mesh_migration, flredecomping, input_procs, target_procs) + + type(state_type), dimension(:), intent(inout), target :: states + logical, intent(in) :: final_adapt_iteration + ! returns the minimum element quality. When using libadapitivity (instead of mba2d/3d), + ! it is based on the minimum nodal quality where the nodal quality is computed from the + ! *maximum* quality of the adjacent elements at each node - as this is closer to libadaptivity's + ! termination criterion + real, intent(out), optional :: global_min_quality + ! the metric is the metric we base the quality functions on + type(tensor_field), intent(inout), optional :: metric + ! the full_metric is the metric we need to interpolate + type(tensor_field), intent(inout), optional :: full_metric + ! if present and true: don't bother redistributing fields that can be reinitialised + logical, intent(in), optional :: initialise_fields + ! if present and true: don't extrude meshes after decomposition + logical, intent(in), optional :: skip_extrusion_after + ! if present and true: only decompose and migrate the horizontal mesh + logical, intent(in), optional :: skip_extruded_mesh_migration + ! Are we flredecomping? If so, this should be true + logical, intent(in), optional :: flredecomping + ! If flredecomping then these values should be provided + integer, intent(in), optional :: input_procs, target_procs + + type(zoltan_struct), pointer :: zz + + logical :: changes + integer(zoltan_int) :: num_gid_entries, num_lid_entries + integer(zoltan_int), dimension(:), pointer :: p1_export_global_ids => null() + integer(zoltan_int), dimension(:), pointer :: p1_export_local_ids => null() + integer(zoltan_int), dimension(:), pointer :: p1_export_procs => null() + integer(zoltan_int) :: p1_num_import, p1_num_export + integer(zoltan_int), dimension(:), pointer :: p1_import_global_ids => null() + integer(zoltan_int), dimension(:), pointer :: p1_import_local_ids => null() + integer(zoltan_int), dimension(:), pointer :: p1_import_procs => null() + integer, save :: dumpno = 0 + + type(tensor_field) :: new_metric + type(mesh_type), pointer :: full_mesh + + integer(zoltan_int), dimension(:), pointer :: p1_export_local_ids_full => null() + integer(zoltan_int), dimension(:), pointer :: p1_export_procs_full => null() + integer(zoltan_int) :: p1_num_export_full + type(vector_field) :: zoltan_global_new_positions_m1d + real :: load_imbalance_tolerance + logical :: flredecomp + real :: minimum_quality + integer :: flredecomp_input_procs = -1, flredecomp_target_procs = -1 + + ewrite(1,*) "In zoltan_drive" + + if (.not. present(flredecomping)) then + flredecomp = .false. + else + flredecomp = flredecomping + end if - if (final_adapt_iteration) then - ! interpolation does not interpolate in the halo regions, so we need a halo update afterwards - ! normally this happens automatically due to the subsequent zoltan migration process, however - ! if zoltan decides to not do anything we need to do it manually. We only need it in the final one - ! because interpolation does halo update the old fields before the adapt. - call halo_update(states) + if (flredecomp) then + ! check for required optional arguments + if (present(input_procs)) then + flredecomp_input_procs = input_procs + else + FLAbort("input_procs must be supplied when flredecomping.") + end if + if (present(target_procs)) then + flredecomp_target_procs = target_procs + else + FLAbort("target_procs must be supplied when flredecomping.") + end if + + zoltan_global_base_option_path = '/flredecomp' + else + ! check invalid optional arguments haven't been supplied + if (present(input_procs)) then + FLAbort("input_procs should only be provided when flredecomping.") + end if + if (present(target_procs)) then + FLAbort("target_procs should only be provided when flredecomping.") + end if + + zoltan_global_base_option_path = '/mesh_adaptivity/hr_adaptivity/zoltan_options' end if - return - end if - if(zoltan_global_migrate_extruded_mesh) then - call derive_full_export_lists(states, p1_num_export, p1_export_local_ids, p1_export_procs, & - & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full) - end if + zoltan_global_field_weighted_partitions = & + have_option(trim(zoltan_global_base_option_path) // "/field_weighted_partitions") - ! The general plan: - ! Just send the nodes you own, along with a note of their dependencies - ! The receiving process loops through all its receives and records whom - ! it needs to receive from (the OLD owner) + call setup_module_variables(states, final_adapt_iteration, zz, flredecomp) - ! It builds an import list from that, then migrates again + call setup_quality_module_variables(metric, minimum_quality) ! this needs to be called after setup_module_variables + ! (but only on the 2d mesh with 2+1d adaptivity) + if (present(global_min_quality)) then + if (.NOT. final_adapt_iteration) then + global_min_quality = minimum_quality + else + ! On final iteration we do not calculate the minimum element quality + global_min_quality = 1.0 + end if + end if - call are_we_keeping_or_sending_nodes(p1_num_export, p1_export_local_ids, p1_export_procs) + full_mesh => extract_mesh(states(1), trim(topology_mesh_name)) + zoltan_global_migrate_extruded_mesh = (mesh_dim(full_mesh) /= mesh_dim(zoltan_global_zz_mesh)) .and. & + .not. present_and_true(skip_extruded_mesh_migration) - ! Migrate here - ! for nodes I am going to own - call zoltan_migration_phase_one(zz, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) - call deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_export_global_ids, p1_export_local_ids, p1_export_procs) - ! deal with reconstructing new mesh, positions, etc. for processes who are only exporting - call deal_with_exporters - ! for halo nodes those nodes depend on - call zoltan_migration_phase_two(zz) - call deallocate_my_lists - - call reconstruct_enlist - call reconstruct_senlist - call reconstruct_halo(zz) + if(zoltan_global_migrate_extruded_mesh .AND. zoltan_global_field_weighted_partitions) then + ewrite(-1,*) "Cannot weight mesh partitions based upon extruded columns"// & + "and a prescribed field. Select one option only or fix the code." + FLExit("Use Weighted mesh partitions for EITHER extruded meshes or prescribed fields") + end if - if(zoltan_global_migrate_extruded_mesh) then - zoltan_global_new_positions_m1d = zoltan_global_new_positions ! save a reference to the horizontal mesh you've just load balanced - call copy(zoltan_global_universal_to_new_local_numbering_m1d, zoltan_global_universal_to_new_local_numbering) + if(zoltan_global_migrate_extruded_mesh) then + call create_columns_sparsity(zoltan_global_columns_sparsity, full_mesh) + end if - call cleanup_basic_module_variables(zz) - ! don't clean up the quality variables now - ! (they'll be deallocated later but we don't need to use them in the vertically_structured section - ! so we don't need to reallocate them either) - call cleanup_other_module_variables + load_imbalance_tolerance = get_load_imbalance_tolerance(final_adapt_iteration) + call set_zoltan_parameters(final_adapt_iteration, flredecomp, flredecomp_target_procs, load_imbalance_tolerance, zz) - call setup_module_variables(states, final_adapt_iteration, zz, flredecomp, mesh_name = topology_mesh_name) + call zoltan_load_balance(zz, changes, num_gid_entries, num_lid_entries, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, & + & load_imbalance_tolerance, flredecomp, flredecomp_input_procs, flredecomp_target_procs) + if (.not. changes) then + ewrite(1,*) "Zoltan decided no change was necessary, exiting" + call deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_export_global_ids, p1_export_local_ids, p1_export_procs) + call cleanup_basic_module_variables(zz) + call cleanup_quality_module_variables + dumpno = dumpno + 1 + + if (final_adapt_iteration) then + ! interpolation does not interpolate in the halo regions, so we need a halo update afterwards + ! normally this happens automatically due to the subsequent zoltan migration process, however + ! if zoltan decides to not do anything we need to do it manually. We only need it in the final one + ! because interpolation does halo update the old fields before the adapt. + call halo_update(states) + end if + return + end if - load_imbalance_tolerance = get_load_imbalance_tolerance(final_adapt_iteration) - call set_zoltan_parameters(final_adapt_iteration, flredecomp, flredecomp_target_procs, load_imbalance_tolerance, zz) + if(zoltan_global_migrate_extruded_mesh) then + call derive_full_export_lists(states, p1_num_export, p1_export_local_ids, p1_export_procs, & + & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full) + end if - call reset_zoltan_lists_full(zz, & - & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + ! The general plan: + ! Just send the nodes you own, along with a note of their dependencies + ! The receiving process loops through all its receives and records whom + ! it needs to receive from (the OLD owner) ! It builds an import list from that, then migrates again @@ -254,12 +212,11 @@ subroutine zoltan_drive(states, final_adapt_iteration, global_min_quality, metri ! Migrate here ! for nodes I am going to own call zoltan_migration_phase_one(zz, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) - + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) call deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_export_global_ids, p1_export_local_ids, p1_export_procs) - + & p1_export_global_ids, p1_export_local_ids, p1_export_procs) + ! deal with reconstructing new mesh, positions, etc. for processes who are only exporting call deal_with_exporters ! for halo nodes those nodes depend on call zoltan_migration_phase_two(zz) @@ -269,1448 +226,1491 @@ subroutine zoltan_drive(states, final_adapt_iteration, global_min_quality, metri call reconstruct_senlist call reconstruct_halo(zz) - if (.not. verify_consistent_local_element_numbering(zoltan_global_new_positions%mesh) ) then - ewrite(-1,*) "For the extruded mesh, the local element numbering of elements in the halo region" // & - "is not consistent with that of the element owner. This is likely" // & - "due to a bug in zoltan. Please report" // & - "to the fluidity mailing list" - FLExit("Need a consistent local element ordering in parallel") - end if + if(zoltan_global_migrate_extruded_mesh) then + zoltan_global_new_positions_m1d = zoltan_global_new_positions ! save a reference to the horizontal mesh you've just load balanced + call copy(zoltan_global_universal_to_new_local_numbering_m1d, zoltan_global_universal_to_new_local_numbering) + + call cleanup_basic_module_variables(zz) + ! don't clean up the quality variables now + ! (they'll be deallocated later but we don't need to use them in the vertically_structured section + ! so we don't need to reallocate them either) + call cleanup_other_module_variables + + call setup_module_variables(states, final_adapt_iteration, zz, flredecomp, mesh_name = topology_mesh_name) + + + load_imbalance_tolerance = get_load_imbalance_tolerance(final_adapt_iteration) + call set_zoltan_parameters(final_adapt_iteration, flredecomp, flredecomp_target_procs, load_imbalance_tolerance, zz) - deallocate(zoltan_global_universal_columns) - call deallocate(zoltan_global_universal_to_new_local_numbering_m1d) - end if - - ! At this point, we now have the balanced linear external mesh. - ! Get populate_state to allocate the fields and such on this new - ! mesh. - - call initialise_transfer(zz, states, zoltan_global_new_positions_m1d, metric, full_metric, new_metric, initialise_fields, skip_extrusion_after) - - ! And now transfer the field data around. - call transfer_fields(zz) - - call deallocate(zoltan_global_new_positions) - if(zoltan_global_migrate_extruded_mesh) then - call deallocate(zoltan_global_new_positions_m1d) - end if - - call finalise_transfer(states, metric, full_metric, new_metric) - - call cleanup_basic_module_variables(zz) - call cleanup_quality_module_variables - call cleanup_other_module_variables - - dumpno = dumpno + 1 - - ewrite(1,*) "Exiting zoltan_drive" - - end subroutine zoltan_drive - - subroutine setup_module_variables(states, final_adapt_iteration, zz, flredecomp, mesh_name) - type(state_type), dimension(:), intent(inout), target :: states - logical, intent(in) :: final_adapt_iteration - logical, intent(in) :: flredecomp - type(zoltan_struct), pointer, intent(out) :: zz - - type(mesh_type), pointer :: mesh_ptr - character(len=*), optional :: mesh_name - integer :: nhalos, stat - integer, dimension(:), allocatable :: owned_nodes - integer :: i, j, floc, eloc - integer, dimension(:), allocatable :: face_nodes - integer :: old_element_number, universal_element_number, face_number, universal_surface_element_number - integer, dimension(:), allocatable :: interleaved_surface_ids - - if (final_adapt_iteration) then - zoltan_global_calculate_edge_weights = .false. - else - zoltan_global_calculate_edge_weights = .true. - end if - - zoltan_global_max_edge_weight_on_node => extract_scalar_field(states(1), "MaxEdgeWeightOnNodes", stat) - if (stat == 0) then - zoltan_global_output_edge_weights = .true. - end if - - ! set quality_tolerance - if (have_option(trim(zoltan_global_base_option_path) // "/element_quality_cutoff")) then - call get_option(trim(zoltan_global_base_option_path) // "/element_quality_cutoff", zoltan_global_quality_tolerance) - ! check that the value is reasonable - if (zoltan_global_quality_tolerance < 0. .or. zoltan_global_quality_tolerance > 1.) then - FLExit("element_quality_cutoff should be between 0 and 1. Default is 0.6") - end if - else - zoltan_global_quality_tolerance = 0.6 - end if - - if(present(mesh_name)) then - zoltan_global_zz_mesh = extract_mesh(states(1), trim(mesh_name)) - else if (flredecomp) then - zoltan_global_zz_mesh = get_external_mesh(states) - else - ! This should actually be using get_external_mesh(), i.e. zoltan redistributes the mesh - ! that all other meshes are derived from. However, in the case that we extrude and use - ! generic adaptivity (not 2+1), the external horizontal mesh becomes seperated from the - ! other meshes and it's actually the 3d adapted mesh that we derive everything from. We - ! should probably actually completely remove the external horizontal mesh from the options - ! tree, and make the adapted 3d mesh the external mesh. For now we keep it around and leave - ! it in its old decomposition. - call find_mesh_to_adapt(states(1), mesh_ptr) - zoltan_global_zz_mesh = mesh_ptr - end if - call incref(zoltan_global_zz_mesh) - if (zoltan_global_zz_mesh%name=="CoordinateMesh") then - zoltan_global_zz_positions = extract_vector_field(states, "Coordinate") - else - zoltan_global_zz_positions = extract_vector_field(states, trim(zoltan_global_zz_mesh%name)//"Coordinate") - end if - call incref(zoltan_global_zz_positions) - - zoltan_global_zz_nelist => extract_nelist(zoltan_global_zz_mesh) - - zz => Zoltan_Create(halo_communicator(zoltan_global_zz_mesh)) - - nhalos = halo_count(zoltan_global_zz_mesh) - assert(nhalos == 2) - zoltan_global_zz_halo => zoltan_global_zz_mesh%halos(nhalos) - - nhalos = element_halo_count(zoltan_global_zz_mesh) - assert(nhalos >= 1) - zoltan_global_zz_ele_halo => zoltan_global_zz_mesh%element_halos(nhalos) - - zoltan_global_zz_sparsity_one => get_csr_sparsity_firstorder(states, zoltan_global_zz_mesh, zoltan_global_zz_mesh) - zoltan_global_zz_sparsity_two => get_csr_sparsity_secondorder(states, zoltan_global_zz_mesh, zoltan_global_zz_mesh) - - allocate(owned_nodes(halo_nowned_nodes(zoltan_global_zz_halo))) - call allocate(zoltan_global_universal_to_old_local_numbering) - call get_owned_nodes(zoltan_global_zz_halo, owned_nodes) - do i=1,size(owned_nodes) - call insert(zoltan_global_universal_to_old_local_numbering, halo_universal_number(zoltan_global_zz_halo, owned_nodes(i)), owned_nodes(i)) - end do - deallocate(owned_nodes) - - call allocate(zoltan_global_uen_to_old_local_numbering) - call allocate(zoltan_global_old_local_numbering_to_uen) - do i=1,ele_count(zoltan_global_zz_positions) - call insert(zoltan_global_uen_to_old_local_numbering, halo_universal_number(zoltan_global_zz_ele_halo, i), i) - call insert(zoltan_global_old_local_numbering_to_uen, i, halo_universal_number(zoltan_global_zz_ele_halo, i)) - end do - - allocate(zoltan_global_receives(halo_proc_count(zoltan_global_zz_halo))) - do i=1,size(zoltan_global_receives) - call allocate(zoltan_global_receives(i)) - end do - - ! set up zoltan_global_old_snelist - allocate(zoltan_global_old_snelist(node_count(zoltan_global_zz_positions))) - call allocate(zoltan_global_old_snelist) - call allocate(zoltan_global_universal_surface_number_to_surface_id) - call allocate(zoltan_global_universal_surface_number_to_element_owner) - allocate(interleaved_surface_ids(surface_element_count(zoltan_global_zz_positions))) - call interleave_surface_ids(zoltan_global_zz_mesh, interleaved_surface_ids, max_coplanar_id) - - ! this is another thing that needs to be generalised for mixed meshes - floc = face_loc(zoltan_global_zz_positions, 1) - eloc = ele_loc(zoltan_global_zz_positions, 1) - allocate(face_nodes(1:floc)) - - do i=1, surface_element_count(zoltan_global_zz_positions) - old_element_number = face_ele(zoltan_global_zz_positions, i) - universal_element_number = halo_universal_number(zoltan_global_zz_ele_halo, old_element_number) - face_number = local_face_number(zoltan_global_zz_positions, i) - universal_surface_element_number = (universal_element_number-1)*eloc + face_number - - call insert(zoltan_global_universal_surface_number_to_surface_id, universal_surface_element_number, interleaved_surface_ids(i)) - call insert(zoltan_global_universal_surface_number_to_element_owner, universal_surface_element_number, universal_element_number) - - face_nodes = face_global_nodes(zoltan_global_zz_mesh, i) - do j=1, floc - call insert(zoltan_global_old_snelist(face_nodes(j)), universal_surface_element_number) - end do - end do - - deallocate(interleaved_surface_ids) - deallocate(face_nodes) - - zoltan_global_preserve_mesh_regions = associated(zoltan_global_zz_mesh%region_ids) - ! this deals with the case where some processors have no elements - ! (i.e. when used to flredecomp from 1 to many processors) - call allor(zoltan_global_preserve_mesh_regions) - if(zoltan_global_preserve_mesh_regions) then - call allocate(zoltan_global_universal_element_number_to_region_id) - do i = 1, element_count(zoltan_global_zz_positions) - universal_element_number = halo_universal_number(zoltan_global_zz_ele_halo, i) - call insert(zoltan_global_universal_element_number_to_region_id, universal_element_number, zoltan_global_zz_positions%mesh%region_ids(i)) - end do - end if - - if(zoltan_global_field_weighted_partitions) then - zoltan_global_field_weighted_partition_values = extract_scalar_field(states, "FieldWeightedPartitionValues") - assert(zoltan_global_field_weighted_partition_values%mesh == zoltan_global_zz_mesh) - - if(zoltan_global_field_weighted_partition_values%mesh%name /= zoltan_global_zz_mesh%name) then - ewrite(-1,*) "FieldWeightedPartitionValues and Zoltan Global ZZ Mesh must be on the " // & - "same mesh. 99.9% of the time, this means that FieldWeightedPartitionValues " // & - "must be on the external mesh." - FLExit("FieldWeightedPartitionValues must be on the external mesh") - end if - - call incref(zoltan_global_field_weighted_partition_values) - - end if - - end subroutine setup_module_variables - - subroutine setup_quality_module_variables(metric, minimum_quality) - ! setups the field zoltan_global_element_quality (used to determine edge weights) - ! and returns minimum_quality (to be used as zoltan iteration termination criterion) - ! the metric is the metric we base the quality functions on - type(tensor_field), intent(in), optional :: metric - ! returns the minimum element quality. When using libadapitivity (instead of mba2d/3d), - ! it is based on the minimum nodal quality where the nodal quality is computed from the - ! *maximum* quality of the adjacent elements at each node - as this is closer to libadaptivity's - ! termination criterion - real, intent(out):: minimum_quality - - type(mesh_type) :: pwc_mesh - integer :: node - integer, dimension(:), pointer :: elements - logical :: use_pain_functional - - ! And the element quality measure - use_pain_functional = present(metric) .and. mesh_dim(zoltan_global_zz_mesh)==3 .and. & - .not. have_option("/mesh_adaptivity/hr_adaptivity/adaptivity_library/libmba3d") - if (use_pain_functional) then - ! with libadaptivity use the Pain functional - call element_quality_pain_p0(zoltan_global_zz_positions, metric, zoltan_global_element_quality) - ! the rest of the zoltan wrappers have been written assuming the lipnikov - ! functional where q=0 is bad and q=1 is perfect. With the pain functional, - ! q'=0 is perfect and q'=\infty is bad. Therefore map q' -> q=1/(q'+1), so - ! that we get the same behaviour - call addto(zoltan_global_element_quality, 1.0) - call invert(zoltan_global_element_quality) - else if (present(metric)) then - ! with mba2d or mba3d use the lipnikov functional: - call element_quality_p0(zoltan_global_zz_positions, metric, zoltan_global_element_quality) - else - pwc_mesh = piecewise_constant_mesh(zoltan_global_zz_mesh, "PWCMesh") - call allocate(zoltan_global_element_quality, pwc_mesh, "ElementQuality", field_type=FIELD_TYPE_CONSTANT) - call set(zoltan_global_element_quality, 1.0) - call deallocate(pwc_mesh) - end if - - minimum_quality = minval(zoltan_global_element_quality) - ewrite(1,*) "local minimum element quality = ", minimum_quality - call allmin(minimum_quality) - ewrite(1,*) "global minimum element quality = ", minimum_quality - - if (use_pain_functional) then - ! libadaptivity terminates if for all possible operations, any of the affected - ! elements have a quality that is above a threshold. This means that if an element - ! that hasn't reached the threshold yet can only be improved via operations that - ! affect a neighbour that is already good enough - it will be kept as it is. - ! Therefore we compute the best quality element adjacent to each node, and then - ! take the minimum over all nodes. The zoltan iterations termination criterion isbased - ! on this minimum, saying that if all nodes should have at least a good enough element adjacent - ! to it - as we can't guarantee that elements of worse quality adjacent to a node will - ! ever be changed by libadaptivity - minimum_quality = 1.0 - do node=1, size(zoltan_global_zz_nelist, 1) - elements => row_m_ptr(zoltan_global_zz_nelist, node) - minimum_quality = min(minimum_quality, maxval(node_val(zoltan_global_element_quality, elements))) - end do - ewrite(1,*) "local minimum achievable quality = ", minimum_quality - call allmin(minimum_quality) - ewrite(1,*) "global minimum achievable quality = ", minimum_quality - end if - - end subroutine setup_quality_module_variables - - function get_load_imbalance_tolerance(final_adapt_iteration) result(load_imbalance_tolerance) - logical, intent(in) :: final_adapt_iteration - - real, parameter :: default_load_imbalance_tolerance = 1.05 - real, parameter :: final_iteration_load_imbalance_tolerance = 1.02 - real :: load_imbalance_tolerance - - if (.NOT. final_adapt_iteration) then - ! if user has passed us the option then use the load imbalance tolerance they supplied, - ! else use the default load imbalance tolerance - call get_option(trim(zoltan_global_base_option_path) // "/load_imbalance_tolerance", load_imbalance_tolerance, & - & default = default_load_imbalance_tolerance) - - ! check the value is reasonable - if (load_imbalance_tolerance < 1.0) then - FLExit("load_imbalance_tolerance should be greater than or equal to 1. Default is 1.5") - end if - else - load_imbalance_tolerance = final_iteration_load_imbalance_tolerance - end if - - end function get_load_imbalance_tolerance - - subroutine set_zoltan_parameters(final_adapt_iteration, flredecomp, target_procs, & - & load_imbalance_tolerance, zz) - logical, intent(in) :: final_adapt_iteration - logical, intent(in) :: flredecomp - integer, intent(in) :: target_procs - real, intent(in) :: load_imbalance_tolerance - type(zoltan_struct), pointer, intent(in) :: zz - - integer(zoltan_int) :: ierr - character (len = FIELD_NAME_LEN) :: method, graph_checking_level - character (len = 10) :: string_load_imbalance_tolerance - - if (debug_level()>1) then - ierr = Zoltan_Set_Param(zz, "DEBUG_LEVEL", "1"); assert(ierr == ZOLTAN_OK) - else - ierr = Zoltan_Set_Param(zz, "DEBUG_LEVEL", "0"); assert(ierr == ZOLTAN_OK) - end if - - ! convert load_imbalance_tolerance to a string for setting the option in Zoltan - write(string_load_imbalance_tolerance, '(f6.3)' ) load_imbalance_tolerance - ierr = Zoltan_Set_Param(zz, "IMBALANCE_TOL", string_load_imbalance_tolerance); assert(ierr == ZOLTAN_OK) - ewrite(2,*) 'Initial load_imbalance_tolerance set to ', load_imbalance_tolerance - - ! For flredecomp if we are not an active process, then let's set the number of local parts to be zero - if (flredecomp) then - if (getprocno() > target_procs) then - ierr = Zoltan_Set_Param(zz, "NUM_LOCAL_PARTS", "0"); assert(ierr == ZOLTAN_OK) - else - ierr = Zoltan_Set_Param(zz, "NUM_LOCAL_PARTS", "1"); assert(ierr == ZOLTAN_OK) - end if - ierr = Zoltan_set_Param(zz, "NUM_GLOBAL_PARTS", int2str(target_procs)); assert(ierr == ZOLTAN_OK) - end if - - if (.NOT. final_adapt_iteration) then - if (have_option(trim(zoltan_global_base_option_path) // "/partitioner")) then - if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/metis")) then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PARMETIS"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the partitioner to be ParMETIS." - ! turn off graph checking unless debugging, this was filling the error file with Zoltan warnings - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then - call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) - else - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) - end if - end if - - if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/zoltan")) then - - call get_option(trim(zoltan_global_base_option_path) // "/partitioner/zoltan/method", method) - - if (trim(method) == "graph") then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the partitioner to be Zoltan-Graph." - else if (trim(method) == "hypergraph") then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "HYPERGRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "HYPERGRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the partitioner to be Zoltan-Hypergraph." - end if - - end if - - if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/scotch")) then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "SCOTCH"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the partitioner to be Scotch." - ! Probably not going to want graph checking unless debugging - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then - call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) - else - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) - end if - end if - - else - ! Use the Zoltan graph partitioner by default - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "No partitioner option set, defaulting to using Zoltan-Graph." - end if - - else - - if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner")) then - - if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/metis")) then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PARMETIS"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the final partitioner to be ParMETIS." - ! turn off graph checking unless debugging, this was filling the error file with Zoltan warnings - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then - call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) - else - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) - end if - end if - - if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/zoltan")) then - - call get_option(trim(zoltan_global_base_option_path) // "/final_partitioner/zoltan/method", method) - - if (trim(method) == "graph") then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the final partitioner to be Zoltan-Graph." - else if (trim(method) == "hypergraph") then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "HYPERGRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "HYPERGRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the final partitioner to be Zoltan-Hypergraph." - end if - - end if - - if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/scotch")) then - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "SCOTCH"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting the final partitioner to be Scotch." - ! Probably not going to want graph checking unless debugging - if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then - call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) - else - ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) - end if - end if - - else - ! Use ParMETIS by default on the final adapt iteration - ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PARMETIS"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "No final partitioner option set, defaulting to using ParMETIS." - end if - - end if - - ! Choose the appropriate partitioning method based on the current adapt iteration. - ! The default is currently to do a clean partition on all adapt iterations to produce a - ! load balanced partitioning and to limit the required number of adapts. In certain cases, - ! repartitioning or refining may lead to improved performance, and this is optional for all - ! but the final adapt iteration. - if (final_adapt_iteration) then - - ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "PARTITION"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting partitioning approach to PARTITION." - if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/metis") .OR. & - & (.NOT.(have_option(trim(zoltan_global_base_option_path) // "/final_partitioner")))) then - ! chosen to match what Sam uses - ierr = Zoltan_Set_Param(zz, "PARMETIS_METHOD", "PartKway"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting ParMETIS method to PartKway." - end if - - else - - if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/")) then - if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/partition")) then - ! Partition from scratch, not taking the current data distribution into account: - ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "PARTITION"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting partitioning approach to PARTITION." - else if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/repartition")) then - ! Partition but try to stay close to the curruent partition/distribution: - ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "REPARTITION"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting partitioning approach to REPARTITION." - else if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/refine")) then - ! Refine the current partition/distribution; assumes only small changes: - ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "REFINE"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting partitioning approach to REFINE." - end if - else - ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "PARTITION"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting partitioning approach to PARTITION." - end if - - if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/metis")) then - ! chosen to match what Sam uses - ierr = Zoltan_Set_Param(zz, "PARMETIS_METHOD", "AdaptiveRepart"); assert(ierr == ZOLTAN_OK) - ewrite(3,*) "Setting ParMETIS method to AdaptiveRepart." - ierr = Zoltan_Set_Param(zz, "PARMETIS_ITR", "100000.0"); assert(ierr == ZOLTAN_OK) - end if - - end if - - ierr = Zoltan_Set_Param(zz, "NUM_GID_ENTRIES", "1"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "NUM_LID_ENTRIES", "1"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "OBJ_WEIGHT_DIM", "1"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "EDGE_WEIGHT_DIM", "1"); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Param(zz, "RETURN_LISTS", "ALL"); assert(ierr == ZOLTAN_OK) - ! scotch and parmetis do not behave correctly when one, or more input partitions are empty - ! setting this to 2, means doing a simple scatter of contiguous chunks of vertices (ignoring - ! any weighting) before going into scotch/parmetis - ! 0 = never scatter, 1 (default) = only scatter if there is just one non-empty partition, 3 = always scatter - ! I believe this is ignored with Zoltan Hypergraph - ! empty *input* partitions should only occur with flredecomp, as we don't handle empty output partitions - ! and adaptivity never reduces the number of vertices to 0 - ierr = Zoltan_Set_Param(zz, "SCATTER_GRAPH", "2"); assert(ierr == ZOLTAN_OK) - - ierr = Zoltan_Set_Fn(zz, ZOLTAN_NUM_OBJ_FN_TYPE, zoltan_cb_owned_node_count); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_LIST_FN_TYPE, zoltan_cb_get_owned_nodes); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_NUM_EDGES_MULTI_FN_TYPE, zoltan_cb_get_num_edges); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_EDGE_LIST_MULTI_FN_TYPE, zoltan_cb_get_edge_list); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_SIZE_MULTI_FN_TYPE, zoltan_cb_pack_node_sizes); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_PACK_OBJ_MULTI_FN_TYPE, zoltan_cb_pack_nodes); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_UNPACK_OBJ_MULTI_FN_TYPE, zoltan_cb_unpack_nodes); assert(ierr == ZOLTAN_OK) - - end subroutine set_zoltan_parameters - - subroutine deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_export_global_ids, p1_export_local_ids, p1_export_procs) - - integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_import_global_ids - integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_import_local_ids - integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_import_procs - integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_export_global_ids - integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_export_local_ids - integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_export_procs - - integer(zoltan_int) :: ierr - - ! deallocates the memory which was allocated in Zoltan - ierr = Zoltan_LB_Free_Data(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + call reset_zoltan_lists_full(zz, & + & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + + ! It builds an import list from that, then migrates again + + call are_we_keeping_or_sending_nodes(p1_num_export, p1_export_local_ids, p1_export_procs) + + ! Migrate here + ! for nodes I am going to own + call zoltan_migration_phase_one(zz, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + + call deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & & p1_export_global_ids, p1_export_local_ids, p1_export_procs) - assert(ierr == ZOLTAN_OK) - end subroutine deallocate_zoltan_lists - - subroutine cleanup_basic_module_variables(zz) - ! This routine deallocates everything that is guaranteed to be allocated - ! regardless of whether Zoltan actually wants to change anything or not. - ! (except for the quality functions) - type(zoltan_struct), pointer, intent(inout) :: zz - - call deallocate(zoltan_global_universal_surface_number_to_surface_id) - call deallocate(zoltan_global_universal_surface_number_to_element_owner) - call deallocate(zoltan_global_old_snelist) - deallocate(zoltan_global_old_snelist) - call deallocate(zoltan_global_receives) - deallocate(zoltan_global_receives) - - call deallocate(zoltan_global_universal_to_old_local_numbering) - call deallocate(zoltan_global_uen_to_old_local_numbering) - call deallocate(zoltan_global_old_local_numbering_to_uen) - - zoltan_global_new_positions%refcount => null() - - call deallocate(zoltan_global_zz_mesh) - call deallocate(zoltan_global_zz_positions) - zoltan_global_zz_sparsity_one => null() - zoltan_global_zz_sparsity_two => null() - zoltan_global_zz_halo => null() - zoltan_global_zz_ele_halo => null() - call Zoltan_Destroy(zz) - - zoltan_global_preserve_columns = .false. - end subroutine cleanup_basic_module_variables - - subroutine cleanup_quality_module_variables - ! This routine deallocates the module quality fields. - call deallocate(zoltan_global_element_quality) - if(zoltan_global_migrate_extruded_mesh) then - call deallocate(zoltan_global_columns_sparsity) - end if - if(zoltan_global_field_weighted_partitions) then - call deallocate(zoltan_global_field_weighted_partition_values) - end if - - end subroutine cleanup_quality_module_variables - - subroutine cleanup_other_module_variables - call deallocate(zoltan_global_nodes_we_are_sending) - call deallocate(zoltan_global_nodes_we_are_keeping) - call deallocate(zoltan_global_universal_to_new_local_numbering) - call deallocate(zoltan_global_new_nodes) - call deallocate(zoltan_global_uen_to_new_local_numbering) - end subroutine cleanup_other_module_variables - - subroutine zoltan_load_balance(zz, changes, num_gid_entries, num_lid_entries, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, & - load_imbalance_tolerance, flredecomp, input_procs, target_procs) - - type(zoltan_struct), pointer, intent(in) :: zz - logical, intent(out) :: changes - - integer(zoltan_int), intent(out) :: num_gid_entries, num_lid_entries - integer(zoltan_int), intent(out) :: p1_num_import - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_global_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_local_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_procs - integer(zoltan_int), intent(out) :: p1_num_export - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_global_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_local_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_procs - real, intent(inout) :: load_imbalance_tolerance - logical, intent(in) :: flredecomp - integer, intent(in) :: input_procs, target_procs - - ! These variables are needed when flredecomping as we then use Zoltan_LB_Partition - integer(zoltan_int), dimension(:), pointer :: import_to_part - integer(zoltan_int), dimension(:), pointer :: export_to_part - integer(zoltan_int), dimension(:), pointer :: null_pointer => null() - - integer(zoltan_int) :: ierr - integer :: i, node - integer :: num_nodes, num_nodes_after_balance - integer :: min_num_nodes_after_balance, total_num_nodes_before_balance, total_num_nodes_after_balance - integer :: num_empty_partitions, empty_partition - character (len = 10) :: string_load_imbalance_tolerance - - ewrite(1,*) 'in zoltan_load_balance' - - num_nodes = zoltan_global_zz_halo%nowned_nodes - - ! Special case when flredecomping - don't check for empty partitions - if (flredecomp) then - - ! calculate total number of owned nodes before the load balance - call mpi_allreduce(num_nodes, total_num_nodes_before_balance, 1, getPINTEGER(), & - & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - - ! Need to use Zoltan_LB_Partition when flredecomping as NUM_LOCAL_PART and NUM_GLOBAL_PART are - ! meant to be invalid for Zoltan_LB_Balance (actually appear to be valid even then but better - ! to follow the doc) - ierr = Zoltan_LB_Partition(zz, changes, num_gid_entries, num_lid_entries, p1_num_import, p1_import_global_ids, & - & p1_import_local_ids, p1_import_procs, import_to_part, p1_num_export, p1_export_global_ids, & - & p1_export_local_ids, p1_export_procs, export_to_part) - assert(ierr == ZOLTAN_OK) - - ! calculate how many owned nodes we'd have after doing the planned load balancing - num_nodes_after_balance = num_nodes + p1_num_import - p1_num_export - - ! calculate total number of owned nodes after the load balance - call mpi_allreduce(num_nodes_after_balance, total_num_nodes_after_balance, 1, getPINTEGER(), & - & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - - if (total_num_nodes_before_balance .NE. total_num_nodes_after_balance) then - FLAbort("The total number of nodes before load balancing does not equal the total number of nodes after the load balancing.") - end if - - if (target_procs < input_procs) then - ! We're expecting some processes to have empty partitions when using flredecomp to - ! reduce the number of active processes. The plan is to calculate the number of - ! processes with an empty partition after the load balance and check this is how - ! many we'd expect to be empty - if (num_nodes_after_balance > 0) then - empty_partition = 0 - else - empty_partition = 1 - end if - call mpi_allreduce(empty_partition, num_empty_partitions, 1, getPINTEGER(), & - & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - - if (num_empty_partitions /= (input_procs - target_procs)) then - FLAbort("The correct number of processes did not have empty partitons after the load balancing.") - end if - else - ! If using flredecomp to increase the number of active processes then no process - ! should have an empty partition after the load balance - if (num_nodes_after_balance == 0) then - FLAbort("After load balancing process would have an empty partition.") - end if - end if - - if (p1_num_import>0) then - ! It appears that with gcc5 this routine crashes if p1_num_import==0 - ! not entirely sure whether this is a bug in zoltan with gcc5 or - ! whether we are indeed not suppposed to deallocate this if there are no imports - ierr = Zoltan_LB_Free_Part(null_pointer, null_pointer, null_pointer, import_to_part); assert(ierr == ZOLTAN_OK) - end if - if (p1_num_export>0) then - ! see comment above, p1_num_import -> p1_num_export - ierr = Zoltan_LB_Free_Part(null_pointer, null_pointer, null_pointer, export_to_part); assert(ierr == ZOLTAN_OK) - end if - - else - - min_num_nodes_after_balance = 0 - do while (min_num_nodes_after_balance == 0) - - ierr = Zoltan_LB_Balance(zz, changes, num_gid_entries, num_lid_entries, p1_num_import, p1_import_global_ids, & - & p1_import_local_ids, p1_import_procs, p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) - assert(ierr == ZOLTAN_OK) - - ! calculate how many owned nodes we'd have after doing the planned load balancing - num_nodes_after_balance = num_nodes + p1_num_import - p1_num_export - - ! find the minimum number of owned nodes any process would have after doing the planned load balancing - call mpi_allreduce(num_nodes_after_balance, min_num_nodes_after_balance, 1, getPINTEGER(), & - & MPI_MIN, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - if (min_num_nodes_after_balance == 0) then - ewrite(2,*) 'Empty partion would be created with load_imbalance_tolerance of', load_imbalance_tolerance - load_imbalance_tolerance = 0.95 * load_imbalance_tolerance - if (load_imbalance_tolerance < 1.075) then - - ewrite(1,*) 'Could not prevent empty partions by tightening load_imbalance_tolerance.' - ewrite(1,*) 'Attempting to load balance with no edge-weights.' - - ! Reset the load_imbalance_tolerance - ierr = Zoltan_Set_Param(zz, "IMBALANCE_TOL", "1.075"); assert(ierr == ZOLTAN_OK) - ! Turn off the edge-weight calculation - zoltan_global_calculate_edge_weights = .false. - - ierr = Zoltan_LB_Balance(zz, changes, num_gid_entries, num_lid_entries, p1_num_import, p1_import_global_ids, & - & p1_import_local_ids, p1_import_procs, p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) - assert(ierr == ZOLTAN_OK) - - ! calculate how many owned nodes we'd have after doing the planned load balancing - num_nodes_after_balance = num_nodes + p1_num_import - p1_num_export - - ! find the minimum number of owned nodes any process would have after doing the planned load balancing - call mpi_allreduce(num_nodes_after_balance, min_num_nodes_after_balance, 1, getPINTEGER(), & - & MPI_MIN, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - if (min_num_nodes_after_balance == 0) then - FLAbort("Could not stop Zoltan creating empty partitions.") - else - ewrite(-1,*) 'Load balancing was carried out without edge-weighting being applied. Mesh may not be of expected quality.' - end if - else - ! convert load_imbalance_tolerance to a string for setting the option in Zoltan - write(string_load_imbalance_tolerance, '(f6.3)' ) load_imbalance_tolerance - ierr = Zoltan_Set_Param(zz, "IMBALANCE_TOL", string_load_imbalance_tolerance); assert(ierr == ZOLTAN_OK) - - ewrite(2,*) 'Tightened load_imbalance_tolerance to ', load_imbalance_tolerance - end if - end if - end do - end if - - do i=1,p1_num_export - node = p1_export_local_ids(i) - assert(node_owned(zoltan_global_zz_halo, node)) - end do - - ewrite(1,*) 'exiting zoltan_load_balance' - - end subroutine zoltan_load_balance - - subroutine derive_full_export_lists(states, p1_num_export, p1_export_local_ids, p1_export_procs, & - & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full) - type(state_type), dimension(:), intent(inout), target :: states - integer(zoltan_int), intent(in) :: p1_num_export - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs - - integer(zoltan_int), intent(out) :: p1_num_export_full - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_local_ids_full - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_procs_full - - type(mesh_type), pointer :: full_mesh - integer :: i, column - integer, dimension(:), pointer :: column_nodes - - integer :: last_full_node - logical :: lpreserve_columns - - ewrite(1,*) 'in derive_full_export_lists' - - p1_num_export_full = 0 - do i = 1, p1_num_export - column = p1_export_local_ids(i) - p1_num_export_full = p1_num_export_full + row_length(zoltan_global_columns_sparsity, column) - end do - - allocate(p1_export_local_ids_full(p1_num_export_full)) - p1_export_local_ids_full = 0 - allocate(p1_export_procs_full(p1_num_export_full)) - p1_export_procs_full = -1 + call deal_with_exporters + ! for halo nodes those nodes depend on + call zoltan_migration_phase_two(zz) + call deallocate_my_lists + + call reconstruct_enlist + call reconstruct_senlist + call reconstruct_halo(zz) + + if (.not. verify_consistent_local_element_numbering(zoltan_global_new_positions%mesh) ) then + ewrite(-1,*) "For the extruded mesh, the local element numbering of elements in the halo region" // & + "is not consistent with that of the element owner. This is likely" // & + "due to a bug in zoltan. Please report" // & + "to the fluidity mailing list" + FLExit("Need a consistent local element ordering in parallel") + end if + + deallocate(zoltan_global_universal_columns) + call deallocate(zoltan_global_universal_to_new_local_numbering_m1d) + end if + + ! At this point, we now have the balanced linear external mesh. + ! Get populate_state to allocate the fields and such on this new + ! mesh. + + call initialise_transfer(zz, states, zoltan_global_new_positions_m1d, metric, full_metric, new_metric, initialise_fields, skip_extrusion_after) + + ! And now transfer the field data around. + call transfer_fields(zz) + + call deallocate(zoltan_global_new_positions) + if(zoltan_global_migrate_extruded_mesh) then + call deallocate(zoltan_global_new_positions_m1d) + end if + + call finalise_transfer(states, metric, full_metric, new_metric) + + call cleanup_basic_module_variables(zz) + call cleanup_quality_module_variables + call cleanup_other_module_variables + + dumpno = dumpno + 1 + + ewrite(1,*) "Exiting zoltan_drive" + + end subroutine zoltan_drive + + subroutine setup_module_variables(states, final_adapt_iteration, zz, flredecomp, mesh_name) + type(state_type), dimension(:), intent(inout), target :: states + logical, intent(in) :: final_adapt_iteration + logical, intent(in) :: flredecomp + type(zoltan_struct), pointer, intent(out) :: zz + + type(mesh_type), pointer :: mesh_ptr + character(len=*), optional :: mesh_name + integer :: nhalos, stat + integer, dimension(:), allocatable :: owned_nodes + integer :: i, j, floc, eloc + integer, dimension(:), allocatable :: face_nodes + integer :: old_element_number, universal_element_number, face_number, universal_surface_element_number + integer, dimension(:), allocatable :: interleaved_surface_ids + + if (final_adapt_iteration) then + zoltan_global_calculate_edge_weights = .false. + else + zoltan_global_calculate_edge_weights = .true. + end if + + zoltan_global_max_edge_weight_on_node => extract_scalar_field(states(1), "MaxEdgeWeightOnNodes", stat) + if (stat == 0) then + zoltan_global_output_edge_weights = .true. + end if + + ! set quality_tolerance + if (have_option(trim(zoltan_global_base_option_path) // "/element_quality_cutoff")) then + call get_option(trim(zoltan_global_base_option_path) // "/element_quality_cutoff", zoltan_global_quality_tolerance) + ! check that the value is reasonable + if (zoltan_global_quality_tolerance < 0. .or. zoltan_global_quality_tolerance > 1.) then + FLExit("element_quality_cutoff should be between 0 and 1. Default is 0.6") + end if + else + zoltan_global_quality_tolerance = 0.6 + end if + + if(present(mesh_name)) then + zoltan_global_zz_mesh = extract_mesh(states(1), trim(mesh_name)) + else if (flredecomp) then + zoltan_global_zz_mesh = get_external_mesh(states) + else + ! This should actually be using get_external_mesh(), i.e. zoltan redistributes the mesh + ! that all other meshes are derived from. However, in the case that we extrude and use + ! generic adaptivity (not 2+1), the external horizontal mesh becomes seperated from the + ! other meshes and it's actually the 3d adapted mesh that we derive everything from. We + ! should probably actually completely remove the external horizontal mesh from the options + ! tree, and make the adapted 3d mesh the external mesh. For now we keep it around and leave + ! it in its old decomposition. + call find_mesh_to_adapt(states(1), mesh_ptr) + zoltan_global_zz_mesh = mesh_ptr + end if + call incref(zoltan_global_zz_mesh) + if (zoltan_global_zz_mesh%name=="CoordinateMesh") then + zoltan_global_zz_positions = extract_vector_field(states, "Coordinate") + else + zoltan_global_zz_positions = extract_vector_field(states, trim(zoltan_global_zz_mesh%name)//"Coordinate") + end if + call incref(zoltan_global_zz_positions) + + zoltan_global_zz_nelist => extract_nelist(zoltan_global_zz_mesh) + + zz => Zoltan_Create(halo_communicator(zoltan_global_zz_mesh)) + + nhalos = halo_count(zoltan_global_zz_mesh) + assert(nhalos == 2) + zoltan_global_zz_halo => zoltan_global_zz_mesh%halos(nhalos) + + nhalos = element_halo_count(zoltan_global_zz_mesh) + assert(nhalos >= 1) + zoltan_global_zz_ele_halo => zoltan_global_zz_mesh%element_halos(nhalos) + + zoltan_global_zz_sparsity_one => get_csr_sparsity_firstorder(states, zoltan_global_zz_mesh, zoltan_global_zz_mesh) + zoltan_global_zz_sparsity_two => get_csr_sparsity_secondorder(states, zoltan_global_zz_mesh, zoltan_global_zz_mesh) + + allocate(owned_nodes(halo_nowned_nodes(zoltan_global_zz_halo))) + call allocate(zoltan_global_universal_to_old_local_numbering) + call get_owned_nodes(zoltan_global_zz_halo, owned_nodes) + do i=1,size(owned_nodes) + call insert(zoltan_global_universal_to_old_local_numbering, halo_universal_number(zoltan_global_zz_halo, owned_nodes(i)), owned_nodes(i)) + end do + deallocate(owned_nodes) + + call allocate(zoltan_global_uen_to_old_local_numbering) + call allocate(zoltan_global_old_local_numbering_to_uen) + do i=1,ele_count(zoltan_global_zz_positions) + call insert(zoltan_global_uen_to_old_local_numbering, halo_universal_number(zoltan_global_zz_ele_halo, i), i) + call insert(zoltan_global_old_local_numbering_to_uen, i, halo_universal_number(zoltan_global_zz_ele_halo, i)) + end do + + allocate(zoltan_global_receives(halo_proc_count(zoltan_global_zz_halo))) + do i=1,size(zoltan_global_receives) + call allocate(zoltan_global_receives(i)) + end do + + ! set up zoltan_global_old_snelist + allocate(zoltan_global_old_snelist(node_count(zoltan_global_zz_positions))) + call allocate(zoltan_global_old_snelist) + call allocate(zoltan_global_universal_surface_number_to_surface_id) + call allocate(zoltan_global_universal_surface_number_to_element_owner) + allocate(interleaved_surface_ids(surface_element_count(zoltan_global_zz_positions))) + call interleave_surface_ids(zoltan_global_zz_mesh, interleaved_surface_ids, max_coplanar_id) + + ! this is another thing that needs to be generalised for mixed meshes + floc = face_loc(zoltan_global_zz_positions, 1) + eloc = ele_loc(zoltan_global_zz_positions, 1) + allocate(face_nodes(1:floc)) + + do i=1, surface_element_count(zoltan_global_zz_positions) + old_element_number = face_ele(zoltan_global_zz_positions, i) + universal_element_number = halo_universal_number(zoltan_global_zz_ele_halo, old_element_number) + face_number = local_face_number(zoltan_global_zz_positions, i) + universal_surface_element_number = (universal_element_number-1)*eloc + face_number + + call insert(zoltan_global_universal_surface_number_to_surface_id, universal_surface_element_number, interleaved_surface_ids(i)) + call insert(zoltan_global_universal_surface_number_to_element_owner, universal_surface_element_number, universal_element_number) + + face_nodes = face_global_nodes(zoltan_global_zz_mesh, i) + do j=1, floc + call insert(zoltan_global_old_snelist(face_nodes(j)), universal_surface_element_number) + end do + end do + + deallocate(interleaved_surface_ids) + deallocate(face_nodes) + + zoltan_global_preserve_mesh_regions = associated(zoltan_global_zz_mesh%region_ids) + ! this deals with the case where some processors have no elements + ! (i.e. when used to flredecomp from 1 to many processors) + call allor(zoltan_global_preserve_mesh_regions) + if(zoltan_global_preserve_mesh_regions) then + call allocate(zoltan_global_universal_element_number_to_region_id) + do i = 1, element_count(zoltan_global_zz_positions) + universal_element_number = halo_universal_number(zoltan_global_zz_ele_halo, i) + call insert(zoltan_global_universal_element_number_to_region_id, universal_element_number, zoltan_global_zz_positions%mesh%region_ids(i)) + end do + end if + + if(zoltan_global_field_weighted_partitions) then + zoltan_global_field_weighted_partition_values = extract_scalar_field(states, "FieldWeightedPartitionValues") + assert(zoltan_global_field_weighted_partition_values%mesh == zoltan_global_zz_mesh) + + if(zoltan_global_field_weighted_partition_values%mesh%name /= zoltan_global_zz_mesh%name) then + ewrite(-1,*) "FieldWeightedPartitionValues and Zoltan Global ZZ Mesh must be on the " // & + "same mesh. 99.9% of the time, this means that FieldWeightedPartitionValues " // & + "must be on the external mesh." + FLExit("FieldWeightedPartitionValues must be on the external mesh") + end if + + call incref(zoltan_global_field_weighted_partition_values) + + end if + + end subroutine setup_module_variables + + subroutine setup_quality_module_variables(metric, minimum_quality) + ! setups the field zoltan_global_element_quality (used to determine edge weights) + ! and returns minimum_quality (to be used as zoltan iteration termination criterion) + ! the metric is the metric we base the quality functions on + type(tensor_field), intent(in), optional :: metric + ! returns the minimum element quality. When using libadapitivity (instead of mba2d/3d), + ! it is based on the minimum nodal quality where the nodal quality is computed from the + ! *maximum* quality of the adjacent elements at each node - as this is closer to libadaptivity's + ! termination criterion + real, intent(out):: minimum_quality + + type(mesh_type) :: pwc_mesh + integer :: node + integer, dimension(:), pointer :: elements + logical :: use_pain_functional + + ! And the element quality measure + use_pain_functional = present(metric) .and. mesh_dim(zoltan_global_zz_mesh)==3 .and. & + .not. have_option("/mesh_adaptivity/hr_adaptivity/adaptivity_library/libmba3d") + if (use_pain_functional) then + ! with libadaptivity use the Pain functional + call element_quality_pain_p0(zoltan_global_zz_positions, metric, zoltan_global_element_quality) + ! the rest of the zoltan wrappers have been written assuming the lipnikov + ! functional where q=0 is bad and q=1 is perfect. With the pain functional, + ! q'=0 is perfect and q'=\infty is bad. Therefore map q' -> q=1/(q'+1), so + ! that we get the same behaviour + call addto(zoltan_global_element_quality, 1.0) + call invert(zoltan_global_element_quality) + else if (present(metric)) then + ! with mba2d or mba3d use the lipnikov functional: + call element_quality_p0(zoltan_global_zz_positions, metric, zoltan_global_element_quality) + else + pwc_mesh = piecewise_constant_mesh(zoltan_global_zz_mesh, "PWCMesh") + call allocate(zoltan_global_element_quality, pwc_mesh, "ElementQuality", field_type=FIELD_TYPE_CONSTANT) + call set(zoltan_global_element_quality, 1.0) + call deallocate(pwc_mesh) + end if + + minimum_quality = minval(zoltan_global_element_quality) + ewrite(1,*) "local minimum element quality = ", minimum_quality + call allmin(minimum_quality) + ewrite(1,*) "global minimum element quality = ", minimum_quality + + if (use_pain_functional) then + ! libadaptivity terminates if for all possible operations, any of the affected + ! elements have a quality that is above a threshold. This means that if an element + ! that hasn't reached the threshold yet can only be improved via operations that + ! affect a neighbour that is already good enough - it will be kept as it is. + ! Therefore we compute the best quality element adjacent to each node, and then + ! take the minimum over all nodes. The zoltan iterations termination criterion isbased + ! on this minimum, saying that if all nodes should have at least a good enough element adjacent + ! to it - as we can't guarantee that elements of worse quality adjacent to a node will + ! ever be changed by libadaptivity + minimum_quality = 1.0 + do node=1, size(zoltan_global_zz_nelist, 1) + elements => row_m_ptr(zoltan_global_zz_nelist, node) + minimum_quality = min(minimum_quality, maxval(node_val(zoltan_global_element_quality, elements))) + end do + ewrite(1,*) "local minimum achievable quality = ", minimum_quality + call allmin(minimum_quality) + ewrite(1,*) "global minimum achievable quality = ", minimum_quality + end if + + end subroutine setup_quality_module_variables + + function get_load_imbalance_tolerance(final_adapt_iteration) result(load_imbalance_tolerance) + logical, intent(in) :: final_adapt_iteration - last_full_node = 1 - do i = 1, p1_num_export - column = p1_export_local_ids(i) - column_nodes => row_m_ptr(zoltan_global_columns_sparsity, column) - - p1_export_local_ids_full(last_full_node:last_full_node+size(column_nodes)-1) = column_nodes - p1_export_procs_full(last_full_node:last_full_node+size(column_nodes)-1) = p1_export_procs(i) - - last_full_node = last_full_node + size(column_nodes) - end do - assert(last_full_node-1==p1_num_export_full) - assert(all(p1_export_local_ids_full>0)) - assert(all(p1_export_procs_full>-1)) - - full_mesh => extract_mesh(states(1), trim(topology_mesh_name)) - lpreserve_columns = associated(full_mesh%columns) - call allor(lpreserve_columns) - if(lpreserve_columns) then - allocate(zoltan_global_universal_columns(node_count(full_mesh))) - zoltan_global_universal_columns = halo_universal_numbers(zoltan_global_zz_halo, full_mesh%columns) - end if - - ewrite(1,*) 'exiting derive_full_export_lists' + real, parameter :: default_load_imbalance_tolerance = 1.05 + real, parameter :: final_iteration_load_imbalance_tolerance = 1.02 + real :: load_imbalance_tolerance - end subroutine derive_full_export_lists - - subroutine reset_zoltan_lists_full(zz, & - & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) - - type(zoltan_struct), pointer, intent(in) :: zz - - integer(zoltan_int), intent(in) :: p1_num_export_full - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids_full - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs_full - - integer(zoltan_int), intent(out) :: p1_num_import - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_global_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_local_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_procs - integer(zoltan_int), intent(out) :: p1_num_export - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_global_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_local_ids - integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_procs - - integer :: i, ierr - - ewrite(1,*) 'in reset_zoltan_lists_full' - - p1_num_export = p1_num_export_full - - p1_export_local_ids => p1_export_local_ids_full - p1_export_procs => p1_export_procs_full - - allocate(p1_export_global_ids(p1_num_export)) - p1_export_global_ids = 0 - - do i=1,p1_num_export - p1_export_global_ids(i) = halo_universal_number(zoltan_global_zz_halo, p1_export_local_ids(i)) - end do - assert(all(p1_export_global_ids>0)) - - p1_num_import = 0 - p1_import_local_ids => null() - p1_import_procs => null() - p1_import_global_ids => null() - - ierr = Zoltan_Compute_Destinations(zz, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs) - assert(ierr == ZOLTAN_OK) - - zoltan_global_preserve_columns = associated(zoltan_global_zz_positions%mesh%columns) - call allor(zoltan_global_preserve_columns) - - ewrite(1,*) 'exiting reset_zoltan_lists_full' - - end subroutine reset_zoltan_lists_full - - - subroutine are_we_keeping_or_sending_nodes(p1_num_export, p1_export_local_ids, p1_export_procs) - integer(zoltan_int), intent(in) :: p1_num_export - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs - - integer :: node, i - integer, dimension(halo_nowned_nodes(zoltan_global_zz_halo)) :: owned_nodes - - call allocate(zoltan_global_nodes_we_are_sending) - call allocate(zoltan_global_nodes_we_are_keeping) - - do i=1,p1_num_export - call insert(zoltan_global_nodes_we_are_sending, p1_export_local_ids(i), p1_export_procs(i)) - end do - - call get_owned_nodes(zoltan_global_zz_halo, owned_nodes) - do i=1,size(owned_nodes) - node = owned_nodes(i) - if (.not. has_key(zoltan_global_nodes_we_are_sending, node)) then - call insert(zoltan_global_nodes_we_are_keeping, node) - end if - end do - end subroutine are_we_keeping_or_sending_nodes - - subroutine zoltan_migration_phase_one(zz, & - & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) - - type(zoltan_struct), pointer, intent(in) :: zz - - integer(zoltan_int), intent(in) :: p1_num_import - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_import_global_ids - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_import_local_ids - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_import_procs - integer(zoltan_int), intent(in) :: p1_num_export - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_global_ids - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids - integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs - - - integer(zoltan_int) :: ierr - integer(zoltan_int), dimension(:), pointer :: import_to_part, export_to_part - - ewrite(1,*) "In zoltan_migration_phase_one; objects to import: ", p1_num_import - ewrite(1,*) "In zoltan_migration_phase_one; objects to export: ", p1_num_export - import_to_part => null() - export_to_part => null() - - ierr = Zoltan_Migrate(zz, p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & - & import_to_part, p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, export_to_part) - assert(ierr == ZOLTAN_OK) - end subroutine zoltan_migration_phase_one - - subroutine deal_with_exporters - ! The unpack routine is the ones that do most of the heavy lifting - ! in reconstructing the new mesh, positions, etc. - ! But they don't get called if a process is only an exporter! - ! So we need to reconstruct the positions and nelist for the - ! nodes we own, and mark the request for the halos in the same way. - ! (The owner of one of our halo nodes might have changed, and we - ! don't know that, or who owns it, so we have to ask the old owner, - ! i.e. participate in the phase_two migration). - integer :: i, j, old_local_number, new_local_number - integer, dimension(:), pointer :: neighbours - integer :: universal_number - type(integer_set) :: halo_nodes_we_need_to_know_about - type(integer_hash_table) :: universal_number_to_old_owner - logical :: changed - integer :: old_owner, new_owner - type(mesh_type) :: new_mesh - type(integer_set) :: halo_nodes_we_currently_own - integer :: rank - - if (associated(zoltan_global_new_positions%refcount)) return - ewrite(1,*) "In deal_with_exports" - - call allocate(zoltan_global_new_nodes) - - ! Need to allocate zoltan_global_new_nodes, zoltan_global_new_elements, zoltan_global_new_positions, zoltan_global_new_nelist, zoltan_global_universal_to_new_local_numbering - do i=1,key_count(zoltan_global_nodes_we_are_keeping) - old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) - call insert(zoltan_global_new_nodes, halo_universal_number(zoltan_global_zz_halo, old_local_number), changed=changed) - end do - - call allocate(halo_nodes_we_need_to_know_about) - call allocate(halo_nodes_we_currently_own) - call allocate(universal_number_to_old_owner) - - rank = getrank() - - do i=1,key_count(zoltan_global_nodes_we_are_keeping) - old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) - neighbours => row_m_ptr(zoltan_global_zz_sparsity_two, old_local_number) - do j=1,size(neighbours) - universal_number = halo_universal_number(zoltan_global_zz_halo, neighbours(j)) - call insert(zoltan_global_new_nodes, universal_number, changed=changed) - if (changed) then - old_owner = halo_node_owner(zoltan_global_zz_halo, neighbours(j)) - 1 - if (old_owner == rank) then - call insert(halo_nodes_we_currently_own, neighbours(j)) - else - call insert(halo_nodes_we_need_to_know_about, universal_number) - end if - call insert(universal_number_to_old_owner, universal_number, old_owner) - end if - end do - end do - - ! We need to process these too -- nodes we own now, but will - ! not own later, and will become our halo nodes. - do i=1,key_count(halo_nodes_we_currently_own) - universal_number = halo_universal_number(zoltan_global_zz_halo, fetch(halo_nodes_we_currently_own, i)) - call insert(zoltan_global_new_nodes, universal_number) - end do - - call invert_set(zoltan_global_new_nodes, zoltan_global_universal_to_new_local_numbering) - call allocate(new_mesh, key_count(zoltan_global_new_nodes), 0, zoltan_global_zz_mesh%shape, trim(zoltan_global_zz_mesh%name)) - new_mesh%option_path = zoltan_global_zz_mesh%option_path - if(zoltan_global_preserve_columns) then - allocate(new_mesh%columns(key_count(zoltan_global_new_nodes))) - end if - call allocate(zoltan_global_new_positions, zoltan_global_zz_positions%dim, new_mesh, trim(zoltan_global_zz_positions%name)) - zoltan_global_new_positions%option_path = zoltan_global_zz_positions%option_path - call deallocate(new_mesh) - allocate(zoltan_global_new_snelist(key_count(zoltan_global_new_nodes))) - call allocate(zoltan_global_new_snelist) - call allocate(zoltan_global_new_surface_elements) - - allocate(zoltan_global_new_nelist(key_count(zoltan_global_new_nodes))) - do i=1,key_count(zoltan_global_new_nodes) - call allocate(zoltan_global_new_nelist(i)) - end do - call allocate(zoltan_global_new_elements) - - do i=1,key_count(zoltan_global_nodes_we_are_keeping) - old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) - universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) - call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & + if (.NOT. final_adapt_iteration) then + ! if user has passed us the option then use the load imbalance tolerance they supplied, + ! else use the default load imbalance tolerance + call get_option(trim(zoltan_global_base_option_path) // "/load_imbalance_tolerance", load_imbalance_tolerance, & + & default = default_load_imbalance_tolerance) + + ! check the value is reasonable + if (load_imbalance_tolerance < 1.0) then + FLExit("load_imbalance_tolerance should be greater than or equal to 1. Default is 1.5") + end if + else + load_imbalance_tolerance = final_iteration_load_imbalance_tolerance + end if + + end function get_load_imbalance_tolerance + + subroutine set_zoltan_parameters(final_adapt_iteration, flredecomp, target_procs, & + & load_imbalance_tolerance, zz) + logical, intent(in) :: final_adapt_iteration + logical, intent(in) :: flredecomp + integer, intent(in) :: target_procs + real, intent(in) :: load_imbalance_tolerance + type(zoltan_struct), pointer, intent(in) :: zz + + integer(zoltan_int) :: ierr + character (len = FIELD_NAME_LEN) :: method, graph_checking_level + character (len = 10) :: string_load_imbalance_tolerance + + if (debug_level()>1) then + ierr = Zoltan_Set_Param(zz, "DEBUG_LEVEL", "1"); assert(ierr == ZOLTAN_OK) + else + ierr = Zoltan_Set_Param(zz, "DEBUG_LEVEL", "0"); assert(ierr == ZOLTAN_OK) + end if + + ! convert load_imbalance_tolerance to a string for setting the option in Zoltan + write(string_load_imbalance_tolerance, '(f6.3)' ) load_imbalance_tolerance + ierr = Zoltan_Set_Param(zz, "IMBALANCE_TOL", string_load_imbalance_tolerance); assert(ierr == ZOLTAN_OK) + ewrite(2,*) 'Initial load_imbalance_tolerance set to ', load_imbalance_tolerance + + ! For flredecomp if we are not an active process, then let's set the number of local parts to be zero + if (flredecomp) then + if (getprocno() > target_procs) then + ierr = Zoltan_Set_Param(zz, "NUM_LOCAL_PARTS", "0"); assert(ierr == ZOLTAN_OK) + else + ierr = Zoltan_Set_Param(zz, "NUM_LOCAL_PARTS", "1"); assert(ierr == ZOLTAN_OK) + end if + ierr = Zoltan_set_Param(zz, "NUM_GLOBAL_PARTS", int2str(target_procs)); assert(ierr == ZOLTAN_OK) + end if + + if (.NOT. final_adapt_iteration) then + if (have_option(trim(zoltan_global_base_option_path) // "/partitioner")) then + if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/metis")) then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PARMETIS"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the partitioner to be ParMETIS." + ! turn off graph checking unless debugging, this was filling the error file with Zoltan warnings + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then + call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) + else + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) + end if + end if + + if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/zoltan")) then + + call get_option(trim(zoltan_global_base_option_path) // "/partitioner/zoltan/method", method) + + if (trim(method) == "graph") then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the partitioner to be Zoltan-Graph." + else if (trim(method) == "hypergraph") then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "HYPERGRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "HYPERGRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the partitioner to be Zoltan-Hypergraph." + end if + + end if + + if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/scotch")) then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "SCOTCH"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the partitioner to be Scotch." + ! Probably not going to want graph checking unless debugging + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then + call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) + else + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) + end if + end if + + else + ! Use the Zoltan graph partitioner by default + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "No partitioner option set, defaulting to using Zoltan-Graph." + end if + + else + + if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner")) then + + if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/metis")) then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PARMETIS"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the final partitioner to be ParMETIS." + ! turn off graph checking unless debugging, this was filling the error file with Zoltan warnings + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then + call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) + else + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) + end if + end if + + if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/zoltan")) then + + call get_option(trim(zoltan_global_base_option_path) // "/final_partitioner/zoltan/method", method) + + if (trim(method) == "graph") then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the final partitioner to be Zoltan-Graph." + else if (trim(method) == "hypergraph") then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "HYPERGRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "HYPERGRAPH_PACKAGE", "PHG"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the final partitioner to be Zoltan-Hypergraph." + end if + + end if + + if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/scotch")) then + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "SCOTCH"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting the final partitioner to be Scotch." + ! Probably not going to want graph checking unless debugging + if (have_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking")) then + call get_option(trim(zoltan_global_base_option_path) // "/zoltan_debug/graph_checking", graph_checking_level) + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", trim(graph_checking_level)); assert(ierr == ZOLTAN_OK) + else + ierr = Zoltan_Set_Param(zz, "CHECK_GRAPH", "0"); assert(ierr == ZOLTAN_OK) + end if + end if + + else + ! Use ParMETIS by default on the final adapt iteration + ierr = Zoltan_Set_Param(zz, "LB_METHOD", "GRAPH"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "GRAPH_PACKAGE", "PARMETIS"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "No final partitioner option set, defaulting to using ParMETIS." + end if + + end if + + ! Choose the appropriate partitioning method based on the current adapt iteration. + ! The default is currently to do a clean partition on all adapt iterations to produce a + ! load balanced partitioning and to limit the required number of adapts. In certain cases, + ! repartitioning or refining may lead to improved performance, and this is optional for all + ! but the final adapt iteration. + if (final_adapt_iteration) then + + ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "PARTITION"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting partitioning approach to PARTITION." + if (have_option(trim(zoltan_global_base_option_path) // "/final_partitioner/metis") .OR. & + & (.NOT.(have_option(trim(zoltan_global_base_option_path) // "/final_partitioner")))) then + ! chosen to match what Sam uses + ierr = Zoltan_Set_Param(zz, "PARMETIS_METHOD", "PartKway"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting ParMETIS method to PartKway." + end if + + else + + if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/")) then + if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/partition")) then + ! Partition from scratch, not taking the current data distribution into account: + ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "PARTITION"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting partitioning approach to PARTITION." + else if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/repartition")) then + ! Partition but try to stay close to the curruent partition/distribution: + ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "REPARTITION"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting partitioning approach to REPARTITION." + else if (have_option(trim(zoltan_global_base_option_path) // "/load_balancing_approach/refine")) then + ! Refine the current partition/distribution; assumes only small changes: + ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "REFINE"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting partitioning approach to REFINE." + end if + else + ierr = Zoltan_Set_Param(zz, "LB_APPROACH", "PARTITION"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting partitioning approach to PARTITION." + end if + + if (have_option(trim(zoltan_global_base_option_path) // "/partitioner/metis")) then + ! chosen to match what Sam uses + ierr = Zoltan_Set_Param(zz, "PARMETIS_METHOD", "AdaptiveRepart"); assert(ierr == ZOLTAN_OK) + ewrite(3,*) "Setting ParMETIS method to AdaptiveRepart." + ierr = Zoltan_Set_Param(zz, "PARMETIS_ITR", "100000.0"); assert(ierr == ZOLTAN_OK) + end if + + end if + + ierr = Zoltan_Set_Param(zz, "NUM_GID_ENTRIES", "1"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "NUM_LID_ENTRIES", "1"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "OBJ_WEIGHT_DIM", "1"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "EDGE_WEIGHT_DIM", "1"); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Param(zz, "RETURN_LISTS", "ALL"); assert(ierr == ZOLTAN_OK) + ! scotch and parmetis do not behave correctly when one, or more input partitions are empty + ! setting this to 2, means doing a simple scatter of contiguous chunks of vertices (ignoring + ! any weighting) before going into scotch/parmetis + ! 0 = never scatter, 1 (default) = only scatter if there is just one non-empty partition, 3 = always scatter + ! I believe this is ignored with Zoltan Hypergraph + ! empty *input* partitions should only occur with flredecomp, as we don't handle empty output partitions + ! and adaptivity never reduces the number of vertices to 0 + ierr = Zoltan_Set_Param(zz, "SCATTER_GRAPH", "2"); assert(ierr == ZOLTAN_OK) + + ierr = Zoltan_Set_Fn(zz, ZOLTAN_NUM_OBJ_FN_TYPE, zoltan_cb_owned_node_count); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_LIST_FN_TYPE, zoltan_cb_get_owned_nodes); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_NUM_EDGES_MULTI_FN_TYPE, zoltan_cb_get_num_edges); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_EDGE_LIST_MULTI_FN_TYPE, zoltan_cb_get_edge_list); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_SIZE_MULTI_FN_TYPE, zoltan_cb_pack_node_sizes); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_PACK_OBJ_MULTI_FN_TYPE, zoltan_cb_pack_nodes); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_UNPACK_OBJ_MULTI_FN_TYPE, zoltan_cb_unpack_nodes); assert(ierr == ZOLTAN_OK) + + end subroutine set_zoltan_parameters + + subroutine deallocate_zoltan_lists(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_export_global_ids, p1_export_local_ids, p1_export_procs) + + integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_import_global_ids + integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_import_local_ids + integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_import_procs + integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_export_global_ids + integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_export_local_ids + integer(zoltan_int), dimension(:), pointer, intent(inout) :: p1_export_procs + + integer(zoltan_int) :: ierr + + ! deallocates the memory which was allocated in Zoltan + ierr = Zoltan_LB_Free_Data(p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_export_global_ids, p1_export_local_ids, p1_export_procs) + + assert(ierr == ZOLTAN_OK) + end subroutine deallocate_zoltan_lists + + subroutine cleanup_basic_module_variables(zz) + ! This routine deallocates everything that is guaranteed to be allocated + ! regardless of whether Zoltan actually wants to change anything or not. + ! (except for the quality functions) + type(zoltan_struct), pointer, intent(inout) :: zz + + call deallocate(zoltan_global_universal_surface_number_to_surface_id) + call deallocate(zoltan_global_universal_surface_number_to_element_owner) + call deallocate(zoltan_global_old_snelist) + deallocate(zoltan_global_old_snelist) + call deallocate(zoltan_global_receives) + deallocate(zoltan_global_receives) + + call deallocate(zoltan_global_universal_to_old_local_numbering) + call deallocate(zoltan_global_uen_to_old_local_numbering) + call deallocate(zoltan_global_old_local_numbering_to_uen) + + zoltan_global_new_positions%refcount => null() + + call deallocate(zoltan_global_zz_mesh) + call deallocate(zoltan_global_zz_positions) + zoltan_global_zz_sparsity_one => null() + zoltan_global_zz_sparsity_two => null() + zoltan_global_zz_halo => null() + zoltan_global_zz_ele_halo => null() + call Zoltan_Destroy(zz) + + zoltan_global_preserve_columns = .false. + end subroutine cleanup_basic_module_variables + + subroutine cleanup_quality_module_variables + ! This routine deallocates the module quality fields. + call deallocate(zoltan_global_element_quality) + if(zoltan_global_migrate_extruded_mesh) then + call deallocate(zoltan_global_columns_sparsity) + end if + if(zoltan_global_field_weighted_partitions) then + call deallocate(zoltan_global_field_weighted_partition_values) + end if + + end subroutine cleanup_quality_module_variables + + subroutine cleanup_other_module_variables + call deallocate(zoltan_global_nodes_we_are_sending) + call deallocate(zoltan_global_nodes_we_are_keeping) + call deallocate(zoltan_global_universal_to_new_local_numbering) + call deallocate(zoltan_global_new_nodes) + call deallocate(zoltan_global_uen_to_new_local_numbering) + end subroutine cleanup_other_module_variables + + subroutine zoltan_load_balance(zz, changes, num_gid_entries, num_lid_entries, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, & + load_imbalance_tolerance, flredecomp, input_procs, target_procs) + + type(zoltan_struct), pointer, intent(in) :: zz + logical, intent(out) :: changes + + integer(zoltan_int), intent(out) :: num_gid_entries, num_lid_entries + integer(zoltan_int), intent(out) :: p1_num_import + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_global_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_local_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_procs + integer(zoltan_int), intent(out) :: p1_num_export + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_global_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_local_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_procs + real, intent(inout) :: load_imbalance_tolerance + logical, intent(in) :: flredecomp + integer, intent(in) :: input_procs, target_procs + + ! These variables are needed when flredecomping as we then use Zoltan_LB_Partition + integer(zoltan_int), dimension(:), pointer :: import_to_part + integer(zoltan_int), dimension(:), pointer :: export_to_part + integer(zoltan_int), dimension(:), pointer :: null_pointer => null() + + integer(zoltan_int) :: ierr + integer :: i, node + integer :: num_nodes, num_nodes_after_balance + integer :: min_num_nodes_after_balance, total_num_nodes_before_balance, total_num_nodes_after_balance + integer :: num_empty_partitions, empty_partition + character (len = 10) :: string_load_imbalance_tolerance + + ewrite(1,*) 'in zoltan_load_balance' + + num_nodes = zoltan_global_zz_halo%nowned_nodes + + ! Special case when flredecomping - don't check for empty partitions + if (flredecomp) then + + ! calculate total number of owned nodes before the load balance + call mpi_allreduce(num_nodes, total_num_nodes_before_balance, 1, getPINTEGER(), & + & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) + + ! Need to use Zoltan_LB_Partition when flredecomping as NUM_LOCAL_PART and NUM_GLOBAL_PART are + ! meant to be invalid for Zoltan_LB_Balance (actually appear to be valid even then but better + ! to follow the doc) + ierr = Zoltan_LB_Partition(zz, changes, num_gid_entries, num_lid_entries, p1_num_import, p1_import_global_ids, & + & p1_import_local_ids, p1_import_procs, import_to_part, p1_num_export, p1_export_global_ids, & + & p1_export_local_ids, p1_export_procs, export_to_part) + assert(ierr == ZOLTAN_OK) + + ! calculate how many owned nodes we'd have after doing the planned load balancing + num_nodes_after_balance = num_nodes + p1_num_import - p1_num_export + + ! calculate total number of owned nodes after the load balance + call mpi_allreduce(num_nodes_after_balance, total_num_nodes_after_balance, 1, getPINTEGER(), & + & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) + + if (total_num_nodes_before_balance .NE. total_num_nodes_after_balance) then + FLAbort("The total number of nodes before load balancing does not equal the total number of nodes after the load balancing.") + end if + + if (target_procs < input_procs) then + ! We're expecting some processes to have empty partitions when using flredecomp to + ! reduce the number of active processes. The plan is to calculate the number of + ! processes with an empty partition after the load balance and check this is how + ! many we'd expect to be empty + if (num_nodes_after_balance > 0) then + empty_partition = 0 + else + empty_partition = 1 + end if + call mpi_allreduce(empty_partition, num_empty_partitions, 1, getPINTEGER(), & + & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) + + if (num_empty_partitions /= (input_procs - target_procs)) then + FLAbort("The correct number of processes did not have empty partitons after the load balancing.") + end if + else + ! If using flredecomp to increase the number of active processes then no process + ! should have an empty partition after the load balance + if (num_nodes_after_balance == 0) then + FLAbort("After load balancing process would have an empty partition.") + end if + end if + + if (p1_num_import>0) then + ! It appears that with gcc5 this routine crashes if p1_num_import==0 + ! not entirely sure whether this is a bug in zoltan with gcc5 or + ! whether we are indeed not suppposed to deallocate this if there are no imports + ierr = Zoltan_LB_Free_Part(null_pointer, null_pointer, null_pointer, import_to_part); assert(ierr == ZOLTAN_OK) + end if + if (p1_num_export>0) then + ! see comment above, p1_num_import -> p1_num_export + ierr = Zoltan_LB_Free_Part(null_pointer, null_pointer, null_pointer, export_to_part); assert(ierr == ZOLTAN_OK) + end if + + else + + min_num_nodes_after_balance = 0 + do while (min_num_nodes_after_balance == 0) + + ierr = Zoltan_LB_Balance(zz, changes, num_gid_entries, num_lid_entries, p1_num_import, p1_import_global_ids, & + & p1_import_local_ids, p1_import_procs, p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + assert(ierr == ZOLTAN_OK) + + ! calculate how many owned nodes we'd have after doing the planned load balancing + num_nodes_after_balance = num_nodes + p1_num_import - p1_num_export + + ! find the minimum number of owned nodes any process would have after doing the planned load balancing + call mpi_allreduce(num_nodes_after_balance, min_num_nodes_after_balance, 1, getPINTEGER(), & + & MPI_MIN, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + if (min_num_nodes_after_balance == 0) then + ewrite(2,*) 'Empty partion would be created with load_imbalance_tolerance of', load_imbalance_tolerance + load_imbalance_tolerance = 0.95 * load_imbalance_tolerance + if (load_imbalance_tolerance < 1.075) then + + ewrite(1,*) 'Could not prevent empty partions by tightening load_imbalance_tolerance.' + ewrite(1,*) 'Attempting to load balance with no edge-weights.' + + ! Reset the load_imbalance_tolerance + ierr = Zoltan_Set_Param(zz, "IMBALANCE_TOL", "1.075"); assert(ierr == ZOLTAN_OK) + ! Turn off the edge-weight calculation + zoltan_global_calculate_edge_weights = .false. + + ierr = Zoltan_LB_Balance(zz, changes, num_gid_entries, num_lid_entries, p1_num_import, p1_import_global_ids, & + & p1_import_local_ids, p1_import_procs, p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + assert(ierr == ZOLTAN_OK) + + ! calculate how many owned nodes we'd have after doing the planned load balancing + num_nodes_after_balance = num_nodes + p1_num_import - p1_num_export + + ! find the minimum number of owned nodes any process would have after doing the planned load balancing + call mpi_allreduce(num_nodes_after_balance, min_num_nodes_after_balance, 1, getPINTEGER(), & + & MPI_MIN, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + if (min_num_nodes_after_balance == 0) then + FLAbort("Could not stop Zoltan creating empty partitions.") + else + ewrite(-1,*) 'Load balancing was carried out without edge-weighting being applied. Mesh may not be of expected quality.' + end if + else + ! convert load_imbalance_tolerance to a string for setting the option in Zoltan + write(string_load_imbalance_tolerance, '(f6.3)' ) load_imbalance_tolerance + ierr = Zoltan_Set_Param(zz, "IMBALANCE_TOL", string_load_imbalance_tolerance); assert(ierr == ZOLTAN_OK) + + ewrite(2,*) 'Tightened load_imbalance_tolerance to ', load_imbalance_tolerance + end if + end if + end do + end if + + do i=1,p1_num_export + node = p1_export_local_ids(i) + assert(node_owned(zoltan_global_zz_halo, node)) + end do + + ewrite(1,*) 'exiting zoltan_load_balance' + + end subroutine zoltan_load_balance + + subroutine derive_full_export_lists(states, p1_num_export, p1_export_local_ids, p1_export_procs, & + & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full) + type(state_type), dimension(:), intent(inout), target :: states + integer(zoltan_int), intent(in) :: p1_num_export + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs + + integer(zoltan_int), intent(out) :: p1_num_export_full + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_local_ids_full + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_procs_full + + type(mesh_type), pointer :: full_mesh + integer :: i, column + integer, dimension(:), pointer :: column_nodes + + integer :: last_full_node + logical :: lpreserve_columns + + ewrite(1,*) 'in derive_full_export_lists' + + p1_num_export_full = 0 + do i = 1, p1_num_export + column = p1_export_local_ids(i) + p1_num_export_full = p1_num_export_full + row_length(zoltan_global_columns_sparsity, column) + end do + + allocate(p1_export_local_ids_full(p1_num_export_full)) + p1_export_local_ids_full = 0 + allocate(p1_export_procs_full(p1_num_export_full)) + p1_export_procs_full = -1 + + last_full_node = 1 + do i = 1, p1_num_export + column = p1_export_local_ids(i) + column_nodes => row_m_ptr(zoltan_global_columns_sparsity, column) + + p1_export_local_ids_full(last_full_node:last_full_node+size(column_nodes)-1) = column_nodes + p1_export_procs_full(last_full_node:last_full_node+size(column_nodes)-1) = p1_export_procs(i) + + last_full_node = last_full_node + size(column_nodes) + end do + assert(last_full_node-1==p1_num_export_full) + assert(all(p1_export_local_ids_full>0)) + assert(all(p1_export_procs_full>-1)) + + full_mesh => extract_mesh(states(1), trim(topology_mesh_name)) + lpreserve_columns = associated(full_mesh%columns) + call allor(lpreserve_columns) + if(lpreserve_columns) then + allocate(zoltan_global_universal_columns(node_count(full_mesh))) + zoltan_global_universal_columns = halo_universal_numbers(zoltan_global_zz_halo, full_mesh%columns) + end if + + ewrite(1,*) 'exiting derive_full_export_lists' + + end subroutine derive_full_export_lists + + subroutine reset_zoltan_lists_full(zz, & + & p1_num_export_full, p1_export_local_ids_full, p1_export_procs_full, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + + type(zoltan_struct), pointer, intent(in) :: zz + + integer(zoltan_int), intent(in) :: p1_num_export_full + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids_full + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs_full + + integer(zoltan_int), intent(out) :: p1_num_import + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_global_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_local_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_import_procs + integer(zoltan_int), intent(out) :: p1_num_export + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_global_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_local_ids + integer(zoltan_int), dimension(:), pointer, intent(out) :: p1_export_procs + + integer :: i, ierr + + ewrite(1,*) 'in reset_zoltan_lists_full' + + p1_num_export = p1_num_export_full + + p1_export_local_ids => p1_export_local_ids_full + p1_export_procs => p1_export_procs_full + + allocate(p1_export_global_ids(p1_num_export)) + p1_export_global_ids = 0 + + do i=1,p1_num_export + p1_export_global_ids(i) = halo_universal_number(zoltan_global_zz_halo, p1_export_local_ids(i)) + end do + assert(all(p1_export_global_ids>0)) + + p1_num_import = 0 + p1_import_local_ids => null() + p1_import_procs => null() + p1_import_global_ids => null() + + ierr = Zoltan_Compute_Destinations(zz, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs) + assert(ierr == ZOLTAN_OK) + + zoltan_global_preserve_columns = associated(zoltan_global_zz_positions%mesh%columns) + call allor(zoltan_global_preserve_columns) + + ewrite(1,*) 'exiting reset_zoltan_lists_full' + + end subroutine reset_zoltan_lists_full + + + subroutine are_we_keeping_or_sending_nodes(p1_num_export, p1_export_local_ids, p1_export_procs) + integer(zoltan_int), intent(in) :: p1_num_export + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs + + integer :: node, i + integer, dimension(halo_nowned_nodes(zoltan_global_zz_halo)) :: owned_nodes + + call allocate(zoltan_global_nodes_we_are_sending) + call allocate(zoltan_global_nodes_we_are_keeping) + + do i=1,p1_num_export + call insert(zoltan_global_nodes_we_are_sending, p1_export_local_ids(i), p1_export_procs(i)) + end do + + call get_owned_nodes(zoltan_global_zz_halo, owned_nodes) + do i=1,size(owned_nodes) + node = owned_nodes(i) + if (.not. has_key(zoltan_global_nodes_we_are_sending, node)) then + call insert(zoltan_global_nodes_we_are_keeping, node) + end if + end do + end subroutine are_we_keeping_or_sending_nodes + + subroutine zoltan_migration_phase_one(zz, & + & p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs) + + type(zoltan_struct), pointer, intent(in) :: zz + + integer(zoltan_int), intent(in) :: p1_num_import + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_import_global_ids + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_import_local_ids + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_import_procs + integer(zoltan_int), intent(in) :: p1_num_export + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_global_ids + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_local_ids + integer(zoltan_int), dimension(:), pointer, intent(in) :: p1_export_procs + + + integer(zoltan_int) :: ierr + integer(zoltan_int), dimension(:), pointer :: import_to_part, export_to_part + + ewrite(1,*) "In zoltan_migration_phase_one; objects to import: ", p1_num_import + ewrite(1,*) "In zoltan_migration_phase_one; objects to export: ", p1_num_export + import_to_part => null() + export_to_part => null() + + ierr = Zoltan_Migrate(zz, p1_num_import, p1_import_global_ids, p1_import_local_ids, p1_import_procs, & + & import_to_part, p1_num_export, p1_export_global_ids, p1_export_local_ids, p1_export_procs, export_to_part) + assert(ierr == ZOLTAN_OK) + end subroutine zoltan_migration_phase_one + + subroutine deal_with_exporters + ! The unpack routine is the ones that do most of the heavy lifting + ! in reconstructing the new mesh, positions, etc. + ! But they don't get called if a process is only an exporter! + ! So we need to reconstruct the positions and nelist for the + ! nodes we own, and mark the request for the halos in the same way. + ! (The owner of one of our halo nodes might have changed, and we + ! don't know that, or who owns it, so we have to ask the old owner, + ! i.e. participate in the phase_two migration). + integer :: i, j, old_local_number, new_local_number + integer, dimension(:), pointer :: neighbours + integer :: universal_number + type(integer_set) :: halo_nodes_we_need_to_know_about + type(integer_hash_table) :: universal_number_to_old_owner + logical :: changed + integer :: old_owner, new_owner + type(mesh_type) :: new_mesh + type(integer_set) :: halo_nodes_we_currently_own + integer :: rank + + if (associated(zoltan_global_new_positions%refcount)) return + ewrite(1,*) "In deal_with_exports" + + call allocate(zoltan_global_new_nodes) + + ! Need to allocate zoltan_global_new_nodes, zoltan_global_new_elements, zoltan_global_new_positions, zoltan_global_new_nelist, zoltan_global_universal_to_new_local_numbering + do i=1,key_count(zoltan_global_nodes_we_are_keeping) + old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) + call insert(zoltan_global_new_nodes, halo_universal_number(zoltan_global_zz_halo, old_local_number), changed=changed) + end do + + call allocate(halo_nodes_we_need_to_know_about) + call allocate(halo_nodes_we_currently_own) + call allocate(universal_number_to_old_owner) + + rank = getrank() + + do i=1,key_count(zoltan_global_nodes_we_are_keeping) + old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) + neighbours => row_m_ptr(zoltan_global_zz_sparsity_two, old_local_number) + do j=1,size(neighbours) + universal_number = halo_universal_number(zoltan_global_zz_halo, neighbours(j)) + call insert(zoltan_global_new_nodes, universal_number, changed=changed) + if (changed) then + old_owner = halo_node_owner(zoltan_global_zz_halo, neighbours(j)) - 1 + if (old_owner == rank) then + call insert(halo_nodes_we_currently_own, neighbours(j)) + else + call insert(halo_nodes_we_need_to_know_about, universal_number) + end if + call insert(universal_number_to_old_owner, universal_number, old_owner) + end if + end do + end do + + ! We need to process these too -- nodes we own now, but will + ! not own later, and will become our halo nodes. + do i=1,key_count(halo_nodes_we_currently_own) + universal_number = halo_universal_number(zoltan_global_zz_halo, fetch(halo_nodes_we_currently_own, i)) + call insert(zoltan_global_new_nodes, universal_number) + end do + + call invert_set(zoltan_global_new_nodes, zoltan_global_universal_to_new_local_numbering) + call allocate(new_mesh, key_count(zoltan_global_new_nodes), 0, zoltan_global_zz_mesh%shape, trim(zoltan_global_zz_mesh%name)) + new_mesh%option_path = zoltan_global_zz_mesh%option_path + if(zoltan_global_preserve_columns) then + allocate(new_mesh%columns(key_count(zoltan_global_new_nodes))) + end if + call allocate(zoltan_global_new_positions, zoltan_global_zz_positions%dim, new_mesh, trim(zoltan_global_zz_positions%name)) + zoltan_global_new_positions%option_path = zoltan_global_zz_positions%option_path + call deallocate(new_mesh) + allocate(zoltan_global_new_snelist(key_count(zoltan_global_new_nodes))) + call allocate(zoltan_global_new_snelist) + call allocate(zoltan_global_new_surface_elements) + + allocate(zoltan_global_new_nelist(key_count(zoltan_global_new_nodes))) + do i=1,key_count(zoltan_global_new_nodes) + call allocate(zoltan_global_new_nelist(i)) + end do + call allocate(zoltan_global_new_elements) + + do i=1,key_count(zoltan_global_nodes_we_are_keeping) + old_local_number = fetch(zoltan_global_nodes_we_are_keeping, i) + universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) + call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & zoltan_global_universal_columns(old_local_number)) - end if - - neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) - do j=1,size(neighbours) - call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - ! don't need to add anything to zoltan_global_universal_element_number_to_region_id because we already have it - end do - - ! and record the snelist information - do j=1,key_count(zoltan_global_old_snelist(old_local_number)) - call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) - call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) - ! we don't need to add anything to the zoltan_global_universal_surface_number_to_surface_id because we already have it - end do - end do - - ! Set the positions and nelist of halo_nodes_we_currently_own - do i=1,key_count(halo_nodes_we_currently_own) - old_local_number = fetch(halo_nodes_we_currently_own, i) - universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) - new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) - call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) - - if(zoltan_global_preserve_columns) then - zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & + end if + + neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) + do j=1,size(neighbours) + call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + ! don't need to add anything to zoltan_global_universal_element_number_to_region_id because we already have it + end do + + ! and record the snelist information + do j=1,key_count(zoltan_global_old_snelist(old_local_number)) + call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) + call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) + ! we don't need to add anything to the zoltan_global_universal_surface_number_to_surface_id because we already have it + end do + end do + + ! Set the positions and nelist of halo_nodes_we_currently_own + do i=1,key_count(halo_nodes_we_currently_own) + old_local_number = fetch(halo_nodes_we_currently_own, i) + universal_number = halo_universal_number(zoltan_global_zz_halo, old_local_number) + new_local_number = fetch(zoltan_global_universal_to_new_local_numbering, universal_number) + call set(zoltan_global_new_positions, new_local_number, node_val(zoltan_global_zz_positions, old_local_number)) + + if(zoltan_global_preserve_columns) then + zoltan_global_new_positions%mesh%columns(new_local_number) = fetch(zoltan_global_universal_to_new_local_numbering_m1d, & zoltan_global_universal_columns(old_local_number)) - end if - - neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) - do j=1,size(neighbours) - call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) - ! don't need to add anything to zoltan_global_universal_element_number_to_region_id because we already have it - end do - - new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_number) - call insert(zoltan_global_receives(new_owner+1), universal_number) - - ! and record the snelist information - do j=1,key_count(zoltan_global_old_snelist(old_local_number)) - call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) - call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) - end do - end do - call deallocate(halo_nodes_we_currently_own) - - zoltan_global_my_num_import = key_count(halo_nodes_we_need_to_know_about) - allocate(zoltan_global_my_import_procs(zoltan_global_my_num_import)) - allocate(zoltan_global_my_import_global_ids(zoltan_global_my_num_import)) - do i=1,zoltan_global_my_num_import - universal_number = fetch(halo_nodes_we_need_to_know_about, i) - zoltan_global_my_import_global_ids(i) = universal_number - zoltan_global_my_import_procs(i) = fetch(universal_number_to_old_owner, universal_number) - assert(zoltan_global_my_import_procs(i) /= getrank()) - end do - - call deallocate(halo_nodes_we_need_to_know_about) - call deallocate(universal_number_to_old_owner) - - end subroutine deal_with_exporters - - subroutine zoltan_migration_phase_two(zz) - type(zoltan_struct), pointer, intent(in) :: zz - - integer(zoltan_int) :: ierr - integer(zoltan_int), dimension(:), pointer :: import_to_part, export_to_part, export_procs - integer(zoltan_int), dimension(:), pointer :: export_global_ids, export_local_ids, import_local_ids - integer(zoltan_int) :: num_export - - ! Register the new callback functions for packing and unpacking - ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_SIZE_MULTI_FN_TYPE, zoltan_cb_pack_halo_node_sizes); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_PACK_OBJ_MULTI_FN_TYPE, zoltan_cb_pack_halo_nodes); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_UNPACK_OBJ_MULTI_FN_TYPE, zoltan_cb_unpack_halo_nodes); assert(ierr == ZOLTAN_OK) - - import_to_part => null() - export_to_part => null() - export_global_ids => null() - export_local_ids => null() - export_procs => null() - num_export = -1 - - if (.not. associated(zoltan_global_my_import_procs)) then - ! We have nothing else to receive, but we still need to take part in - ! the communication. Set num_import to 0 - zoltan_global_my_num_import = 0 - allocate(zoltan_global_my_import_global_ids(0)) - allocate(zoltan_global_my_import_procs(0)) - end if - ewrite(1,*) "In zoltan_migration_phase_two; objects to import: ", zoltan_global_my_num_import - - ! We should be able to do: - ! import_local_ids => null() - ! from my reading of the Zoltan docs. But it actually doesn't appear to be the case. - allocate(import_local_ids(zoltan_global_my_num_import)) - if (zoltan_global_my_num_import > 0) then - import_local_ids = 666 - end if - - assert(associated(zoltan_global_my_import_global_ids)) - assert(associated(import_local_ids)) - assert(associated(zoltan_global_my_import_procs)) - assert(all(zoltan_global_my_import_procs >= 0)) - assert(all(zoltan_global_my_import_procs < getnprocs())) - ierr = Zoltan_Compute_Destinations(zz, zoltan_global_my_num_import, zoltan_global_my_import_global_ids, import_local_ids, zoltan_global_my_import_procs, & - & num_export, export_global_ids, export_local_ids, export_procs) - assert(ierr == ZOLTAN_OK) - ewrite(1,*) "In zoltan_migration_phase_two; objects to export: ", num_export - - ierr = Zoltan_Migrate(zz, zoltan_global_my_num_import, zoltan_global_my_import_global_ids, import_local_ids, zoltan_global_my_import_procs, & - & import_to_part, num_export, export_global_ids, export_local_ids, export_procs, export_to_part) - assert(ierr == ZOLTAN_OK) - - ierr = Zoltan_LB_Free_Part(export_global_ids, export_local_ids, export_procs, export_to_part) - assert(ierr == ZOLTAN_OK) - - deallocate(import_local_ids) - end subroutine zoltan_migration_phase_two - - subroutine deallocate_my_lists - deallocate(zoltan_global_my_import_global_ids) - deallocate(zoltan_global_my_import_procs) - end subroutine deallocate_my_lists - - subroutine reconstruct_enlist - type(csr_sparsity):: eelist - type(mesh_type):: temporary_mesh - type(integer_set), dimension(key_count(zoltan_global_new_elements)) :: enlists - integer :: i, j, k, expected_loc, full_elements, connected_elements - integer :: universal_number, new_local_number - type(integer_set) :: new_elements_we_actually_have - integer, dimension(:), pointer:: neigh - - ewrite(1,*) "In reconstruct_enlist" - - ! zoltan_global_new_elements currently contains the universal numbers of elements - ! we don't fully have and won't be in the final mesh. - ! So uen_to_new_local_numbering here is just temporary -- we will - ! construct the proper version later. - call invert_set(zoltan_global_new_elements, zoltan_global_uen_to_new_local_numbering) - - do i=1,key_count(zoltan_global_new_elements) - call allocate(enlists(i)) - end do - - ! Invert the nelists to give the enlists - - do i=1,key_count(zoltan_global_new_nodes) - do j=1,key_count(zoltan_global_new_nelist(i)) - universal_number = fetch(zoltan_global_new_nelist(i), j) - new_local_number = fetch(zoltan_global_uen_to_new_local_numbering, universal_number) - call insert(enlists(new_local_number), i) - end do - end do - - call deallocate(zoltan_global_uen_to_new_local_numbering) - - ! Now, some of these will be degenerate, because the halo nodes will refer - ! to elements we don't know about. We can tell these apart because they - ! are incomplete. - - full_elements = 0 - ! For mixed meshes, this should be the loc of the positions mesh - ! note we know the universal number -- fetch(zoltan_global_new_elements, i) - ! However, it's constant for now - expected_loc = zoltan_global_zz_mesh%shape%loc - - ! First, count how many we have - do i=1,key_count(zoltan_global_new_elements) - if (key_count(enlists(i)) == expected_loc) then - full_elements = full_elements + 1 - ! else - ! write(0,*) "Element ", fetch(zoltan_global_new_elements, i), " is degenerate. Dropping .." - end if - end do - - ewrite(2,*) "Found ", key_count(zoltan_global_new_elements), " possible new elements." - ewrite(2,*) "Of these, ", full_elements, " are non-degenerate." - - ! Now we construct a temporary mesh of full elements - ! This mesh is temporary because we also want to drop elements that are not connected - ! to any other elements - - call allocate(temporary_mesh, node_count(zoltan_global_new_positions), full_elements, zoltan_global_new_positions%mesh%shape, & + end if + + neighbours => row_m_ptr(zoltan_global_zz_nelist, old_local_number) + do j=1,size(neighbours) + call insert(zoltan_global_new_nelist(new_local_number), halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + call insert(zoltan_global_new_elements, halo_universal_number(zoltan_global_zz_ele_halo, neighbours(j))) + ! don't need to add anything to zoltan_global_universal_element_number_to_region_id because we already have it + end do + + new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_number) + call insert(zoltan_global_receives(new_owner+1), universal_number) + + ! and record the snelist information + do j=1,key_count(zoltan_global_old_snelist(old_local_number)) + call insert(zoltan_global_new_snelist(new_local_number), fetch(zoltan_global_old_snelist(old_local_number), j)) + call insert(zoltan_global_new_surface_elements, fetch(zoltan_global_old_snelist(old_local_number), j)) + end do + end do + call deallocate(halo_nodes_we_currently_own) + + zoltan_global_my_num_import = key_count(halo_nodes_we_need_to_know_about) + allocate(zoltan_global_my_import_procs(zoltan_global_my_num_import)) + allocate(zoltan_global_my_import_global_ids(zoltan_global_my_num_import)) + do i=1,zoltan_global_my_num_import + universal_number = fetch(halo_nodes_we_need_to_know_about, i) + zoltan_global_my_import_global_ids(i) = universal_number + zoltan_global_my_import_procs(i) = fetch(universal_number_to_old_owner, universal_number) + assert(zoltan_global_my_import_procs(i) /= getrank()) + end do + + call deallocate(halo_nodes_we_need_to_know_about) + call deallocate(universal_number_to_old_owner) + + end subroutine deal_with_exporters + + subroutine zoltan_migration_phase_two(zz) + type(zoltan_struct), pointer, intent(in) :: zz + + integer(zoltan_int) :: ierr + integer(zoltan_int), dimension(:), pointer :: import_to_part, export_to_part, export_procs + integer(zoltan_int), dimension(:), pointer :: export_global_ids, export_local_ids, import_local_ids + integer(zoltan_int) :: num_export + + ! Register the new callback functions for packing and unpacking + ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_SIZE_MULTI_FN_TYPE, zoltan_cb_pack_halo_node_sizes); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_PACK_OBJ_MULTI_FN_TYPE, zoltan_cb_pack_halo_nodes); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_UNPACK_OBJ_MULTI_FN_TYPE, zoltan_cb_unpack_halo_nodes); assert(ierr == ZOLTAN_OK) + + import_to_part => null() + export_to_part => null() + export_global_ids => null() + export_local_ids => null() + export_procs => null() + num_export = -1 + + if (.not. associated(zoltan_global_my_import_procs)) then + ! We have nothing else to receive, but we still need to take part in + ! the communication. Set num_import to 0 + zoltan_global_my_num_import = 0 + allocate(zoltan_global_my_import_global_ids(0)) + allocate(zoltan_global_my_import_procs(0)) + end if + ewrite(1,*) "In zoltan_migration_phase_two; objects to import: ", zoltan_global_my_num_import + + ! We should be able to do: + ! import_local_ids => null() + ! from my reading of the Zoltan docs. But it actually doesn't appear to be the case. + allocate(import_local_ids(zoltan_global_my_num_import)) + if (zoltan_global_my_num_import > 0) then + import_local_ids = 666 + end if + + assert(associated(zoltan_global_my_import_global_ids)) + assert(associated(import_local_ids)) + assert(associated(zoltan_global_my_import_procs)) + assert(all(zoltan_global_my_import_procs >= 0)) + assert(all(zoltan_global_my_import_procs < getnprocs())) + ierr = Zoltan_Compute_Destinations(zz, zoltan_global_my_num_import, zoltan_global_my_import_global_ids, import_local_ids, zoltan_global_my_import_procs, & + & num_export, export_global_ids, export_local_ids, export_procs) + assert(ierr == ZOLTAN_OK) + ewrite(1,*) "In zoltan_migration_phase_two; objects to export: ", num_export + + ierr = Zoltan_Migrate(zz, zoltan_global_my_num_import, zoltan_global_my_import_global_ids, import_local_ids, zoltan_global_my_import_procs, & + & import_to_part, num_export, export_global_ids, export_local_ids, export_procs, export_to_part) + assert(ierr == ZOLTAN_OK) + + ierr = Zoltan_LB_Free_Part(export_global_ids, export_local_ids, export_procs, export_to_part) + assert(ierr == ZOLTAN_OK) + + deallocate(import_local_ids) + end subroutine zoltan_migration_phase_two + + subroutine deallocate_my_lists + deallocate(zoltan_global_my_import_global_ids) + deallocate(zoltan_global_my_import_procs) + end subroutine deallocate_my_lists + + subroutine reconstruct_enlist + type(csr_sparsity):: eelist + type(mesh_type):: temporary_mesh + type(integer_set), dimension(key_count(zoltan_global_new_elements)) :: enlists + integer :: i, j, k, expected_loc, full_elements, connected_elements + integer :: universal_number, new_local_number + type(integer_set) :: new_elements_we_actually_have + integer, dimension(:), pointer:: neigh + + ewrite(1,*) "In reconstruct_enlist" + + ! zoltan_global_new_elements currently contains the universal numbers of elements + ! we don't fully have and won't be in the final mesh. + ! So uen_to_new_local_numbering here is just temporary -- we will + ! construct the proper version later. + call invert_set(zoltan_global_new_elements, zoltan_global_uen_to_new_local_numbering) + + do i=1,key_count(zoltan_global_new_elements) + call allocate(enlists(i)) + end do + + ! Invert the nelists to give the enlists + + do i=1,key_count(zoltan_global_new_nodes) + do j=1,key_count(zoltan_global_new_nelist(i)) + universal_number = fetch(zoltan_global_new_nelist(i), j) + new_local_number = fetch(zoltan_global_uen_to_new_local_numbering, universal_number) + call insert(enlists(new_local_number), i) + end do + end do + + call deallocate(zoltan_global_uen_to_new_local_numbering) + + ! Now, some of these will be degenerate, because the halo nodes will refer + ! to elements we don't know about. We can tell these apart because they + ! are incomplete. + + full_elements = 0 + ! For mixed meshes, this should be the loc of the positions mesh + ! note we know the universal number -- fetch(zoltan_global_new_elements, i) + ! However, it's constant for now + expected_loc = zoltan_global_zz_mesh%shape%loc + + ! First, count how many we have + do i=1,key_count(zoltan_global_new_elements) + if (key_count(enlists(i)) == expected_loc) then + full_elements = full_elements + 1 + ! else + ! write(0,*) "Element ", fetch(zoltan_global_new_elements, i), " is degenerate. Dropping .." + end if + end do + + ewrite(2,*) "Found ", key_count(zoltan_global_new_elements), " possible new elements." + ewrite(2,*) "Of these, ", full_elements, " are non-degenerate." + + ! Now we construct a temporary mesh of full elements + ! This mesh is temporary because we also want to drop elements that are not connected + ! to any other elements + + call allocate(temporary_mesh, node_count(zoltan_global_new_positions), full_elements, zoltan_global_new_positions%mesh%shape, & name="TemporaryZoltanMesh") - j = 1 - do i=1,key_count(zoltan_global_new_elements) - if (key_count(enlists(i)) == expected_loc) then - call set_ele_nodes(temporary_mesh, j, set2vector(enlists(i))) - j = j + 1 - end if - end do - - call add_nelist(temporary_mesh) - call extract_lists(temporary_mesh, eelist=eelist) - - connected_elements=0 - do i=1, element_count(temporary_mesh) - neigh => row_m_ptr(eelist, i) - if (any(neigh>0)) connected_elements = connected_elements + 1 - end do - - ewrite(2,*) "Of the ", full_elements, " full elements, ", connected_elements, " are connected." - - call allocate(new_elements_we_actually_have) - call allocate(zoltan_global_uen_to_new_local_numbering) - zoltan_global_new_positions%mesh%elements = connected_elements - deallocate(zoltan_global_new_positions%mesh%ndglno) - allocate(zoltan_global_new_positions%mesh%ndglno(connected_elements * expected_loc)) + j = 1 + do i=1,key_count(zoltan_global_new_elements) + if (key_count(enlists(i)) == expected_loc) then + call set_ele_nodes(temporary_mesh, j, set2vector(enlists(i))) + j = j + 1 + end if + end do + + call add_nelist(temporary_mesh) + call extract_lists(temporary_mesh, eelist=eelist) + + connected_elements=0 + do i=1, element_count(temporary_mesh) + neigh => row_m_ptr(eelist, i) + if (any(neigh>0)) connected_elements = connected_elements + 1 + end do + + ewrite(2,*) "Of the ", full_elements, " full elements, ", connected_elements, " are connected." + + call allocate(new_elements_we_actually_have) + call allocate(zoltan_global_uen_to_new_local_numbering) + zoltan_global_new_positions%mesh%elements = connected_elements + deallocate(zoltan_global_new_positions%mesh%ndglno) + allocate(zoltan_global_new_positions%mesh%ndglno(connected_elements * expected_loc)) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", connected_elements * expected_loc, name=zoltan_global_new_positions%mesh%name) + call register_allocation("mesh_type", "integer", connected_elements * expected_loc, name=zoltan_global_new_positions%mesh%name) #endif - if(zoltan_global_preserve_mesh_regions) then - allocate(zoltan_global_new_positions%mesh%region_ids(connected_elements)) - end if - - j = 1 ! index connected full elements (new local element numbering) - k = 1 ! indexes full elements - do i=1, key_count(zoltan_global_new_elements) - if (key_count(enlists(i)) == expected_loc) then - ! only for full elements - neigh => row_m_ptr(eelist, k) - if (any(neigh>0)) then - ! of these only the connected elements - universal_number = fetch(zoltan_global_new_elements, i) - call set_ele_nodes(zoltan_global_new_positions%mesh, j, set2vector(enlists(i))) - call insert(new_elements_we_actually_have, universal_number) - call insert(zoltan_global_uen_to_new_local_numbering, universal_number, j) - if(zoltan_global_preserve_mesh_regions) then - zoltan_global_new_positions%mesh%region_ids(j) = fetch(zoltan_global_universal_element_number_to_region_id, universal_number) - end if - j = j + 1 - end if - k = k + 1 - end if - end do - - assert( k==full_elements+1 ) - assert( j==connected_elements+1 ) - - do i=1,size(enlists) - call deallocate(enlists(i)) - end do - - call deallocate(temporary_mesh) - call deallocate(zoltan_global_new_nelist) - deallocate(zoltan_global_new_nelist) - - ! New elements is no longer valid, as we have lost the degenerate elements - call deallocate(zoltan_global_new_elements) - zoltan_global_new_elements = new_elements_we_actually_have - - call deallocate(zoltan_global_universal_element_number_to_region_id) - - ! Bingo! Our mesh has an enlist. - ewrite(1,*) "Exiting reconstruct_enlist" - - end subroutine reconstruct_enlist - - subroutine reconstruct_senlist - type(integer_set), dimension(key_count(zoltan_global_new_surface_elements)) :: senlists - integer :: i, j, expected_loc, full_elements - integer :: universal_number, new_local_number - type(integer_hash_table) :: universal_surface_element_to_local_numbering - integer, dimension(:), allocatable, target :: surface_ids, element_owners - type(csr_sparsity), pointer :: nnlist - - logical, dimension(key_count(zoltan_global_new_surface_elements)) :: keep_surface_element - integer, dimension(:), allocatable :: sndgln - integer :: universal_element_number - - ewrite(1,*) "In reconstruct_senlist" - - ! zoltan_global_new_surface_elements currently contains the universal numbers of surface elements - ! we don't fully have and won't be in the final mesh. - ! So universal_surface_element_to_local_numbering here is just temporary. - call invert_set(zoltan_global_new_surface_elements, universal_surface_element_to_local_numbering) - - do i=1,key_count(zoltan_global_new_surface_elements) - call allocate(senlists(i)) - end do - - ! Invert the snelists to give the senlists - - do i=1,key_count(zoltan_global_new_nodes) - do j=1,key_count(zoltan_global_new_snelist(i)) - universal_number = fetch(zoltan_global_new_snelist(i), j) - new_local_number = fetch(universal_surface_element_to_local_numbering, universal_number) - call insert(senlists(new_local_number), i) - end do - end do - - call deallocate(universal_surface_element_to_local_numbering) - - ! Now, some of these will be degenerate, because the halo nodes will refer - ! to elements we don't know about. We can tell these apart because they - ! are incomplete. - - full_elements = 0 - ! For mixed meshes, this should taken from the loc of the positions mesh - ! However, it's constant for now - expected_loc = face_loc(zoltan_global_zz_mesh, 1) - - ! First, count how many we have - nnlist => extract_nnlist(zoltan_global_new_positions%mesh) - do i=1,key_count(zoltan_global_new_surface_elements) - j = key_count(senlists(i)) - assert(j <= expected_loc) - if (j == expected_loc) then - ! We also need to check if we have the parent volume element -- - ! it's possible to get all the information for a face, without having the - ! corresponding element! - universal_number = fetch(zoltan_global_new_surface_elements, i) - universal_element_number = fetch(zoltan_global_universal_surface_number_to_element_owner, universal_number) - keep_surface_element(i) = has_key(zoltan_global_uen_to_new_local_numbering, universal_element_number) - if (keep_surface_element(i)) full_elements = full_elements + 1 - else - keep_surface_element(i) = .false. - ! write(0,*) "Surface element ", fetch(zoltan_global_new_surface_elements, i), " is degenerate. Dropping .." - ! write(0,*) "Local nodes: ", set2vector(senlists(i)) - end if - end do - - ewrite(2,*) "Found ", key_count(zoltan_global_new_surface_elements), " possible new surface elements." - ewrite(2,*) "Of these, ", full_elements, " are non-degenerate." - - ! And now fill in the non-degenerate ones - - allocate(sndgln(full_elements * expected_loc)) - allocate(surface_ids(full_elements)) - allocate(element_owners(full_elements)) - - j = 1 - do i=1,key_count(zoltan_global_new_surface_elements) - if (keep_surface_element(i)) then - universal_number = fetch(zoltan_global_new_surface_elements, i) - sndgln( (j-1)*expected_loc+1 : j*expected_loc ) = set2vector(senlists(i)) - surface_ids(j) = fetch(zoltan_global_universal_surface_number_to_surface_id, universal_number) - universal_element_number = fetch(zoltan_global_universal_surface_number_to_element_owner, universal_number) - element_owners(j) = fetch(zoltan_global_uen_to_new_local_numbering, universal_element_number) - j = j + 1 - end if - end do - assert(j == full_elements + 1) - - if (zoltan_global_zz_mesh%faces%has_discontinuous_internal_boundaries) then - ! for internal facet pairs, the surface ids are not necessarily the same (this is used in periodic meshes) - ! we need to tell add_faces which facets is on which side by supplying element ownership info - call add_faces(zoltan_global_new_positions%mesh, sndgln=sndgln, boundary_ids=surface_ids, element_owner=element_owners) - else - ! surface ids on facets pairs are assumed consistent - add_faces will copy the first of the pair it encounters - ! in sndgln on either side - the next copy in sndgln is ignored (only checked that its surface id is consistent) - call add_faces(zoltan_global_new_positions%mesh, sndgln=sndgln, boundary_ids=surface_ids, & - allow_duplicate_internal_facets=.true.) - end if - - do i=1,size(senlists) - call deallocate(senlists(i)) - end do - - ! New elements is no longer valid, as we have lost the degenerate elements - call deallocate(zoltan_global_new_surface_elements) - call deallocate(zoltan_global_universal_surface_number_to_surface_id) - call deallocate(zoltan_global_universal_surface_number_to_element_owner) - call deallocate(zoltan_global_new_snelist) - deallocate(zoltan_global_new_snelist) - - deallocate(sndgln) - deallocate(surface_ids) - deallocate(element_owners) - - call deinterleave_surface_ids(zoltan_global_new_positions%mesh, max_coplanar_id) - - ! Bingo! Our mesh has an senlist. - ewrite(1,*) "Exiting reconstruct_senlist" - end subroutine reconstruct_senlist - - subroutine reconstruct_halo(zz) - ! At this point, the receives sets have been populated with all - ! the universal node numbers we need to receive from each process. - ! So, we are going to use zoltan to invert this to compute - ! the send list for each process too. - ! Then we will allocate the l2n halo and set it. - ! Then we will chop it down to form the l1n halo, the l1e halo, and the - ! l2e halo. - ! Supply the peeps with jeeps, brick apiece, capiche? - - type(zoltan_struct), pointer, intent(in) :: zz - - integer :: num_import, num_export - integer, dimension(:), pointer :: import_global_ids, import_local_ids, import_procs - integer, dimension(:), pointer :: export_global_ids, export_local_ids, export_procs, export_to_part - integer :: ierr, i, head - type(integer_set), dimension(size(zoltan_global_receives)) :: sends - integer, dimension(size(zoltan_global_receives)) :: nreceives, nsends - integer, dimension(ele_count(zoltan_global_new_positions)) :: ele_renumber_permutation - integer, dimension(node_count(zoltan_global_new_positions)) :: node_renumber_permutation - integer :: universal_element_number, old_new_local_element_number, new_new_local_element_number - integer :: universal_node_number, old_new_local_node_number, new_new_local_node_number - - integer, dimension(ele_count(zoltan_global_new_positions)) :: old_new_region_ids - - ewrite(1,*) "In reconstruct_halo" - - num_import = 0 - do i=1,size(zoltan_global_receives) - nreceives(i) = key_count(zoltan_global_receives(i)) - num_import = num_import + nreceives(i) - end do - - allocate(import_global_ids(num_import)) - allocate(import_local_ids(num_import)) - allocate(import_procs(num_import)) - - import_local_ids = 666 - head = 1 - do i=1,size(zoltan_global_receives) - import_global_ids(head:head + nreceives(i) - 1) = set2vector(zoltan_global_receives(i)) - import_procs(head:head + nreceives(i) - 1) = i - 1 - head = head + nreceives(i) - end do - - export_global_ids => null() - export_local_ids => null() - export_procs => null() - export_to_part => null() - - ierr = Zoltan_Compute_Destinations(zz, & - & num_import, import_global_ids, import_local_ids, import_procs, & - & num_export, export_global_ids, export_local_ids, export_procs) - assert(ierr == ZOLTAN_OK) - - ! Now we know the sends too! Thanks, Zoltan! - - deallocate(import_global_ids) - deallocate(import_local_ids) - deallocate(import_procs) - - ! Now create the sends sets .. easier than pulling it straight out of Zoltan's data structures - ! as Zoltan does NOT explicitly guarantee that the sends are organised such that export_procs looks - ! like - ! [ sends to process 0 | sends to process 1 | sends to process 2 ... ] - ! If such a guarantee were available, then it would be just as easy to use that, but there - ! is no such guarantee given in the documentation ... - ! Is an appetite for destruction, slap a murder rap on this production - - do i=1,size(sends) - call allocate(sends(i)) - end do - - do i=1,num_export - call insert(sends(export_procs(i)+1), export_global_ids(i)) - end do - - do i=1,size(sends) - nsends(i) = key_count(sends(i)) - end do - - ! Allocate the halo and such - ! We had to grow dreads to change our description, two cops is on a milkbox, missin' - - allocate(zoltan_global_new_positions%mesh%halos(2)) - call allocate(zoltan_global_new_positions%mesh%halos(2), & + if(zoltan_global_preserve_mesh_regions) then + allocate(zoltan_global_new_positions%mesh%region_ids(connected_elements)) + end if + + j = 1 ! index connected full elements (new local element numbering) + k = 1 ! indexes full elements + do i=1, key_count(zoltan_global_new_elements) + if (key_count(enlists(i)) == expected_loc) then + ! only for full elements + neigh => row_m_ptr(eelist, k) + if (any(neigh>0)) then + ! of these only the connected elements + universal_number = fetch(zoltan_global_new_elements, i) + call set_ele_nodes(zoltan_global_new_positions%mesh, j, set2vector(enlists(i))) + call insert(new_elements_we_actually_have, universal_number) + call insert(zoltan_global_uen_to_new_local_numbering, universal_number, j) + if(zoltan_global_preserve_mesh_regions) then + zoltan_global_new_positions%mesh%region_ids(j) = fetch(zoltan_global_universal_element_number_to_region_id, universal_number) + end if + j = j + 1 + end if + k = k + 1 + end if + end do + + assert( k==full_elements+1 ) + assert( j==connected_elements+1 ) + + do i=1,size(enlists) + call deallocate(enlists(i)) + end do + + call deallocate(temporary_mesh) + call deallocate(zoltan_global_new_nelist) + deallocate(zoltan_global_new_nelist) + + ! New elements is no longer valid, as we have lost the degenerate elements + call deallocate(zoltan_global_new_elements) + zoltan_global_new_elements = new_elements_we_actually_have + + call deallocate(zoltan_global_universal_element_number_to_region_id) + + ! Bingo! Our mesh has an enlist. + ewrite(1,*) "Exiting reconstruct_enlist" + + end subroutine reconstruct_enlist + + subroutine reconstruct_senlist + type(integer_set), dimension(key_count(zoltan_global_new_surface_elements)) :: senlists + integer :: i, j, expected_loc, full_elements + integer :: universal_number, new_local_number + type(integer_hash_table) :: universal_surface_element_to_local_numbering + integer, dimension(:), allocatable, target :: surface_ids, element_owners + type(csr_sparsity), pointer :: nnlist + + logical, dimension(key_count(zoltan_global_new_surface_elements)) :: keep_surface_element + integer, dimension(:), allocatable :: sndgln + integer :: universal_element_number + + ewrite(1,*) "In reconstruct_senlist" + + ! zoltan_global_new_surface_elements currently contains the universal numbers of surface elements + ! we don't fully have and won't be in the final mesh. + ! So universal_surface_element_to_local_numbering here is just temporary. + call invert_set(zoltan_global_new_surface_elements, universal_surface_element_to_local_numbering) + + do i=1,key_count(zoltan_global_new_surface_elements) + call allocate(senlists(i)) + end do + + ! Invert the snelists to give the senlists + + do i=1,key_count(zoltan_global_new_nodes) + do j=1,key_count(zoltan_global_new_snelist(i)) + universal_number = fetch(zoltan_global_new_snelist(i), j) + new_local_number = fetch(universal_surface_element_to_local_numbering, universal_number) + call insert(senlists(new_local_number), i) + end do + end do + + call deallocate(universal_surface_element_to_local_numbering) + + ! Now, some of these will be degenerate, because the halo nodes will refer + ! to elements we don't know about. We can tell these apart because they + ! are incomplete. + + full_elements = 0 + ! For mixed meshes, this should taken from the loc of the positions mesh + ! However, it's constant for now + expected_loc = face_loc(zoltan_global_zz_mesh, 1) + + ! First, count how many we have + nnlist => extract_nnlist(zoltan_global_new_positions%mesh) + do i=1,key_count(zoltan_global_new_surface_elements) + j = key_count(senlists(i)) + assert(j <= expected_loc) + if (j == expected_loc) then + ! We also need to check if we have the parent volume element -- + ! it's possible to get all the information for a face, without having the + ! corresponding element! + universal_number = fetch(zoltan_global_new_surface_elements, i) + universal_element_number = fetch(zoltan_global_universal_surface_number_to_element_owner, universal_number) + keep_surface_element(i) = has_key(zoltan_global_uen_to_new_local_numbering, universal_element_number) + if (keep_surface_element(i)) full_elements = full_elements + 1 + else + keep_surface_element(i) = .false. + ! write(0,*) "Surface element ", fetch(zoltan_global_new_surface_elements, i), " is degenerate. Dropping .." + ! write(0,*) "Local nodes: ", set2vector(senlists(i)) + end if + end do + + ewrite(2,*) "Found ", key_count(zoltan_global_new_surface_elements), " possible new surface elements." + ewrite(2,*) "Of these, ", full_elements, " are non-degenerate." + + ! And now fill in the non-degenerate ones + + allocate(sndgln(full_elements * expected_loc)) + allocate(surface_ids(full_elements)) + allocate(element_owners(full_elements)) + + j = 1 + do i=1,key_count(zoltan_global_new_surface_elements) + if (keep_surface_element(i)) then + universal_number = fetch(zoltan_global_new_surface_elements, i) + sndgln( (j-1)*expected_loc+1 : j*expected_loc ) = set2vector(senlists(i)) + surface_ids(j) = fetch(zoltan_global_universal_surface_number_to_surface_id, universal_number) + universal_element_number = fetch(zoltan_global_universal_surface_number_to_element_owner, universal_number) + element_owners(j) = fetch(zoltan_global_uen_to_new_local_numbering, universal_element_number) + j = j + 1 + end if + end do + assert(j == full_elements + 1) + + if (zoltan_global_zz_mesh%faces%has_discontinuous_internal_boundaries) then + ! for internal facet pairs, the surface ids are not necessarily the same (this is used in periodic meshes) + ! we need to tell add_faces which facets is on which side by supplying element ownership info + call add_faces(zoltan_global_new_positions%mesh, sndgln=sndgln, boundary_ids=surface_ids, element_owner=element_owners) + else + ! surface ids on facets pairs are assumed consistent - add_faces will copy the first of the pair it encounters + ! in sndgln on either side - the next copy in sndgln is ignored (only checked that its surface id is consistent) + call add_faces(zoltan_global_new_positions%mesh, sndgln=sndgln, boundary_ids=surface_ids, & + allow_duplicate_internal_facets=.true.) + end if + + do i=1,size(senlists) + call deallocate(senlists(i)) + end do + + ! New elements is no longer valid, as we have lost the degenerate elements + call deallocate(zoltan_global_new_surface_elements) + call deallocate(zoltan_global_universal_surface_number_to_surface_id) + call deallocate(zoltan_global_universal_surface_number_to_element_owner) + call deallocate(zoltan_global_new_snelist) + deallocate(zoltan_global_new_snelist) + + deallocate(sndgln) + deallocate(surface_ids) + deallocate(element_owners) + + call deinterleave_surface_ids(zoltan_global_new_positions%mesh, max_coplanar_id) + + ! Bingo! Our mesh has an senlist. + ewrite(1,*) "Exiting reconstruct_senlist" + end subroutine reconstruct_senlist + + subroutine reconstruct_halo(zz) + ! At this point, the receives sets have been populated with all + ! the universal node numbers we need to receive from each process. + ! So, we are going to use zoltan to invert this to compute + ! the send list for each process too. + ! Then we will allocate the l2n halo and set it. + ! Then we will chop it down to form the l1n halo, the l1e halo, and the + ! l2e halo. + ! Supply the peeps with jeeps, brick apiece, capiche? + + type(zoltan_struct), pointer, intent(in) :: zz + + integer :: num_import, num_export + integer, dimension(:), pointer :: import_global_ids, import_local_ids, import_procs + integer, dimension(:), pointer :: export_global_ids, export_local_ids, export_procs, export_to_part + integer :: ierr, i, head + type(integer_set), dimension(size(zoltan_global_receives)) :: sends + integer, dimension(size(zoltan_global_receives)) :: nreceives, nsends + integer, dimension(ele_count(zoltan_global_new_positions)) :: ele_renumber_permutation + integer, dimension(node_count(zoltan_global_new_positions)) :: node_renumber_permutation + integer :: universal_element_number, old_new_local_element_number, new_new_local_element_number + integer :: universal_node_number, old_new_local_node_number, new_new_local_node_number + + integer, dimension(ele_count(zoltan_global_new_positions)) :: old_new_region_ids + + ewrite(1,*) "In reconstruct_halo" + + num_import = 0 + do i=1,size(zoltan_global_receives) + nreceives(i) = key_count(zoltan_global_receives(i)) + num_import = num_import + nreceives(i) + end do + + allocate(import_global_ids(num_import)) + allocate(import_local_ids(num_import)) + allocate(import_procs(num_import)) + + import_local_ids = 666 + head = 1 + do i=1,size(zoltan_global_receives) + import_global_ids(head:head + nreceives(i) - 1) = set2vector(zoltan_global_receives(i)) + import_procs(head:head + nreceives(i) - 1) = i - 1 + head = head + nreceives(i) + end do + + export_global_ids => null() + export_local_ids => null() + export_procs => null() + export_to_part => null() + + ierr = Zoltan_Compute_Destinations(zz, & + & num_import, import_global_ids, import_local_ids, import_procs, & + & num_export, export_global_ids, export_local_ids, export_procs) + assert(ierr == ZOLTAN_OK) + + ! Now we know the sends too! Thanks, Zoltan! + + deallocate(import_global_ids) + deallocate(import_local_ids) + deallocate(import_procs) + + ! Now create the sends sets .. easier than pulling it straight out of Zoltan's data structures + ! as Zoltan does NOT explicitly guarantee that the sends are organised such that export_procs looks + ! like + ! [ sends to process 0 | sends to process 1 | sends to process 2 ... ] + ! If such a guarantee were available, then it would be just as easy to use that, but there + ! is no such guarantee given in the documentation ... + ! Is an appetite for destruction, slap a murder rap on this production + + do i=1,size(sends) + call allocate(sends(i)) + end do + + do i=1,num_export + call insert(sends(export_procs(i)+1), export_global_ids(i)) + end do + + do i=1,size(sends) + nsends(i) = key_count(sends(i)) + end do + + ! Allocate the halo and such + ! We had to grow dreads to change our description, two cops is on a milkbox, missin' + + allocate(zoltan_global_new_positions%mesh%halos(2)) + call allocate(zoltan_global_new_positions%mesh%halos(2), & nsends = nsends, & nreceives = nreceives, & name = halo_name(zoltan_global_zz_halo), & @@ -1718,798 +1718,798 @@ subroutine reconstruct_halo(zz) nowned_nodes = key_count(zoltan_global_new_nodes) - num_import, & data_type = halo_data_type(zoltan_global_zz_halo)) - do i=1,size(zoltan_global_receives) - call set_halo_sends(zoltan_global_new_positions%mesh%halos(2), i, fetch(zoltan_global_universal_to_new_local_numbering, set2vector(sends(i)))) - call set_halo_receives(zoltan_global_new_positions%mesh%halos(2), i, fetch(zoltan_global_universal_to_new_local_numbering, set2vector(zoltan_global_receives(i)))) - end do - - ! Now derive all the other halos ... - ! And me teevee's always off, cause I see something truly black then - - call derive_l1_from_l2_halo(zoltan_global_new_positions%mesh, ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - call renumber_positions_trailing_receives(zoltan_global_new_positions, permutation=node_renumber_permutation) - assert(has_ownership(zoltan_global_new_positions%mesh%halos(2))) - assert(has_ownership(zoltan_global_new_positions%mesh%halos(1))) - allocate(zoltan_global_new_positions%mesh%element_halos(2)) - call derive_element_halo_from_node_halo(zoltan_global_new_positions%mesh, create_caches = .false.) - call renumber_positions_elements_trailing_receives(zoltan_global_new_positions, permutation=ele_renumber_permutation) - assert(has_ownership(zoltan_global_new_positions%mesh%halos(2))) - assert(has_ownership(zoltan_global_new_positions%mesh%halos(1))) - - if(zoltan_global_preserve_mesh_regions) then - old_new_region_ids = zoltan_global_new_positions%mesh%region_ids - end if - - ! The previous routine has renumbered all the local elements to put the element halos in - ! trailing receives status. However, we need the universal element number -> local element number - ! later in the field transfer. So we need to update our records now. - do i=1,ele_count(zoltan_global_new_positions) - universal_element_number = fetch(zoltan_global_new_elements, i) - old_new_local_element_number = i - new_new_local_element_number = ele_renumber_permutation(old_new_local_element_number) - call insert(zoltan_global_uen_to_new_local_numbering, universal_element_number, new_new_local_element_number) - if(zoltan_global_preserve_mesh_regions) then - zoltan_global_new_positions%mesh%region_ids(new_new_local_element_number) = old_new_region_ids(old_new_local_element_number) - end if - end do - ! We're also going to need the universal to new local numbering for 2+1d adaptivity - do i=1,node_count(zoltan_global_new_positions) - universal_node_number = fetch(zoltan_global_new_nodes, i) - old_new_local_node_number = i - new_new_local_node_number = node_renumber_permutation(old_new_local_node_number) - call insert(zoltan_global_universal_to_new_local_numbering, universal_node_number, new_new_local_node_number) - end do - - do i=1,halo_count(zoltan_global_new_positions) - assert(halo_verifies(zoltan_global_new_positions%mesh%halos(i), zoltan_global_new_positions)) - end do - - ! Now cleanup - - ierr = Zoltan_LB_Free_Part(export_global_ids, export_local_ids, export_procs, export_to_part) - assert(ierr == ZOLTAN_OK) - - do i=1,size(sends) - call deallocate(sends(i)) - end do - - call reorder_element_numbering(zoltan_global_new_positions) - - ewrite(1,*) "Exiting reconstruct_halo" - - end subroutine reconstruct_halo - - subroutine initialise_transfer(zz, states, zoltan_global_new_positions_m1d, metric, full_metric, new_metric, initialise_fields, skip_extrusion_after) - type(zoltan_struct), pointer, intent(in) :: zz - type(state_type), dimension(:), intent(inout), target :: states - type(vector_field), intent(inout) :: zoltan_global_new_positions_m1d - type(tensor_field), intent(inout), optional :: metric - type(tensor_field), intent(inout), optional :: full_metric - type(tensor_field), intent(out) :: new_metric - logical, intent(in), optional :: initialise_fields - logical, intent(in), optional :: skip_extrusion_after - - integer :: i - type(state_type), dimension(size(states)) :: interpolate_states - integer(zoltan_int) :: ierr - character(len=FIELD_NAME_LEN), dimension(:), allocatable :: mesh_names - type(mesh_type), pointer :: mesh - integer :: no_meshes - - ewrite(1,*) 'in initialise_transfer' - - ! Set up zoltan_global_source_states - do i=1,size(states) - call select_fields_to_interpolate(states(i), interpolate_states(i), no_positions=.true., & + do i=1,size(zoltan_global_receives) + call set_halo_sends(zoltan_global_new_positions%mesh%halos(2), i, fetch(zoltan_global_universal_to_new_local_numbering, set2vector(sends(i)))) + call set_halo_receives(zoltan_global_new_positions%mesh%halos(2), i, fetch(zoltan_global_universal_to_new_local_numbering, set2vector(zoltan_global_receives(i)))) + end do + + ! Now derive all the other halos ... + ! And me teevee's always off, cause I see something truly black then + + call derive_l1_from_l2_halo(zoltan_global_new_positions%mesh, ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + call renumber_positions_trailing_receives(zoltan_global_new_positions, permutation=node_renumber_permutation) + assert(has_ownership(zoltan_global_new_positions%mesh%halos(2))) + assert(has_ownership(zoltan_global_new_positions%mesh%halos(1))) + allocate(zoltan_global_new_positions%mesh%element_halos(2)) + call derive_element_halo_from_node_halo(zoltan_global_new_positions%mesh, create_caches = .false.) + call renumber_positions_elements_trailing_receives(zoltan_global_new_positions, permutation=ele_renumber_permutation) + assert(has_ownership(zoltan_global_new_positions%mesh%halos(2))) + assert(has_ownership(zoltan_global_new_positions%mesh%halos(1))) + + if(zoltan_global_preserve_mesh_regions) then + old_new_region_ids = zoltan_global_new_positions%mesh%region_ids + end if + + ! The previous routine has renumbered all the local elements to put the element halos in + ! trailing receives status. However, we need the universal element number -> local element number + ! later in the field transfer. So we need to update our records now. + do i=1,ele_count(zoltan_global_new_positions) + universal_element_number = fetch(zoltan_global_new_elements, i) + old_new_local_element_number = i + new_new_local_element_number = ele_renumber_permutation(old_new_local_element_number) + call insert(zoltan_global_uen_to_new_local_numbering, universal_element_number, new_new_local_element_number) + if(zoltan_global_preserve_mesh_regions) then + zoltan_global_new_positions%mesh%region_ids(new_new_local_element_number) = old_new_region_ids(old_new_local_element_number) + end if + end do + ! We're also going to need the universal to new local numbering for 2+1d adaptivity + do i=1,node_count(zoltan_global_new_positions) + universal_node_number = fetch(zoltan_global_new_nodes, i) + old_new_local_node_number = i + new_new_local_node_number = node_renumber_permutation(old_new_local_node_number) + call insert(zoltan_global_universal_to_new_local_numbering, universal_node_number, new_new_local_node_number) + end do + + do i=1,halo_count(zoltan_global_new_positions) + assert(halo_verifies(zoltan_global_new_positions%mesh%halos(i), zoltan_global_new_positions)) + end do + + ! Now cleanup + + ierr = Zoltan_LB_Free_Part(export_global_ids, export_local_ids, export_procs, export_to_part) + assert(ierr == ZOLTAN_OK) + + do i=1,size(sends) + call deallocate(sends(i)) + end do + + call reorder_element_numbering(zoltan_global_new_positions) + + ewrite(1,*) "Exiting reconstruct_halo" + + end subroutine reconstruct_halo + + subroutine initialise_transfer(zz, states, zoltan_global_new_positions_m1d, metric, full_metric, new_metric, initialise_fields, skip_extrusion_after) + type(zoltan_struct), pointer, intent(in) :: zz + type(state_type), dimension(:), intent(inout), target :: states + type(vector_field), intent(inout) :: zoltan_global_new_positions_m1d + type(tensor_field), intent(inout), optional :: metric + type(tensor_field), intent(inout), optional :: full_metric + type(tensor_field), intent(out) :: new_metric + logical, intent(in), optional :: initialise_fields + logical, intent(in), optional :: skip_extrusion_after + + integer :: i + type(state_type), dimension(size(states)) :: interpolate_states + integer(zoltan_int) :: ierr + character(len=FIELD_NAME_LEN), dimension(:), allocatable :: mesh_names + type(mesh_type), pointer :: mesh + integer :: no_meshes + + ewrite(1,*) 'in initialise_transfer' + + ! Set up zoltan_global_source_states + do i=1,size(states) + call select_fields_to_interpolate(states(i), interpolate_states(i), no_positions=.true., & first_time_step=initialise_fields) - ! Remove the current state as we've copied the bits we need - call deallocate(states(i)) - end do - - ! Interpolate the metric, too - if (present(full_metric)) then - call insert(interpolate_states(1), full_metric, "ErrorMetric") - call deallocate(full_metric) - else if (present(metric)) then - call insert(interpolate_states(1), metric, "ErrorMetric") - call deallocate(metric) - end if - - allocate( mesh_names(1:mesh_count(interpolate_states(1))) ) - no_meshes = 0 - do i=1, mesh_count(interpolate_states(1)) - mesh => extract_mesh(interpolate_states(1), i) - if (zoltan_global_migrate_extruded_mesh .and. mesh_dim(mesh)/=mesh_dim(zoltan_global_new_positions)) cycle - no_meshes = no_meshes + 1 - mesh_names(no_meshes) = mesh%name - end do - - allocate(zoltan_global_source_states(no_meshes)) - call halo_update(interpolate_states, level=1) - ! Place the fields we've picked out to interpolate onto the correct meshes of zoltan_global_source_states - call collect_fields_by_mesh(interpolate_states, mesh_names(1:no_meshes), zoltan_global_source_states) - - ! Finished with interpolate_states for setting up zoltan_global_source_states - do i=1,size(interpolate_states) - call deallocate(interpolate_states(i)) - end do - - if (mesh_periodic(zoltan_global_zz_mesh)) then - zoltan_global_new_positions%mesh%periodic = .true. - end if - - ! Start setting up states so that it can be populated with migrated fields data - - ! Put the new positions mesh into states - - if(zoltan_global_migrate_extruded_mesh) then - if (mesh_periodic(zoltan_global_zz_mesh)) then - zoltan_global_new_positions_m1d%mesh%periodic = .true. - end if - call insert(states, zoltan_global_new_positions_m1d%mesh, name = zoltan_global_new_positions_m1d%mesh%name) - call insert(states, zoltan_global_new_positions_m1d, name = zoltan_global_new_positions_m1d%name) - end if - - call insert(states, zoltan_global_new_positions%mesh, name = zoltan_global_new_positions%mesh%name) - call insert(states, zoltan_global_new_positions, name = zoltan_global_new_positions%name) - - ! Check the number of halos in our new mesh - ! Used in a few places within the Zoltan callback and detector routines - zoltan_global_new_positions_mesh_nhalos = halo_count(zoltan_global_new_positions%mesh) - assert(zoltan_global_new_positions_mesh_nhalos == 2) - - ! Allocate a new metric field on the new positions mesh and zero it - if (present(metric).or.present(full_metric)) then - call allocate(new_metric, zoltan_global_new_positions%mesh, "ErrorMetric") - call set(new_metric,spread(spread(666.0, 1, new_metric%dim(1)), 2, new_metric%dim(2))) - end if - - ! Setup meshes and fields on states - call restore_reserved_meshes(states) - call insert_derived_meshes(states, skip_extrusion=skip_extrusion_after) - call allocate_and_insert_fields(states) - call restore_reserved_fields(states) - - ! And set up zoltan_global_target_states based on states - do i=1,size(states) - call select_fields_to_interpolate(states(i), interpolate_states(i), no_positions=.true., & + ! Remove the current state as we've copied the bits we need + call deallocate(states(i)) + end do + + ! Interpolate the metric, too + if (present(full_metric)) then + call insert(interpolate_states(1), full_metric, "ErrorMetric") + call deallocate(full_metric) + else if (present(metric)) then + call insert(interpolate_states(1), metric, "ErrorMetric") + call deallocate(metric) + end if + + allocate( mesh_names(1:mesh_count(interpolate_states(1))) ) + no_meshes = 0 + do i=1, mesh_count(interpolate_states(1)) + mesh => extract_mesh(interpolate_states(1), i) + if (zoltan_global_migrate_extruded_mesh .and. mesh_dim(mesh)/=mesh_dim(zoltan_global_new_positions)) cycle + no_meshes = no_meshes + 1 + mesh_names(no_meshes) = mesh%name + end do + + allocate(zoltan_global_source_states(no_meshes)) + call halo_update(interpolate_states, level=1) + ! Place the fields we've picked out to interpolate onto the correct meshes of zoltan_global_source_states + call collect_fields_by_mesh(interpolate_states, mesh_names(1:no_meshes), zoltan_global_source_states) + + ! Finished with interpolate_states for setting up zoltan_global_source_states + do i=1,size(interpolate_states) + call deallocate(interpolate_states(i)) + end do + + if (mesh_periodic(zoltan_global_zz_mesh)) then + zoltan_global_new_positions%mesh%periodic = .true. + end if + + ! Start setting up states so that it can be populated with migrated fields data + + ! Put the new positions mesh into states + + if(zoltan_global_migrate_extruded_mesh) then + if (mesh_periodic(zoltan_global_zz_mesh)) then + zoltan_global_new_positions_m1d%mesh%periodic = .true. + end if + call insert(states, zoltan_global_new_positions_m1d%mesh, name = zoltan_global_new_positions_m1d%mesh%name) + call insert(states, zoltan_global_new_positions_m1d, name = zoltan_global_new_positions_m1d%name) + end if + + call insert(states, zoltan_global_new_positions%mesh, name = zoltan_global_new_positions%mesh%name) + call insert(states, zoltan_global_new_positions, name = zoltan_global_new_positions%name) + + ! Check the number of halos in our new mesh + ! Used in a few places within the Zoltan callback and detector routines + zoltan_global_new_positions_mesh_nhalos = halo_count(zoltan_global_new_positions%mesh) + assert(zoltan_global_new_positions_mesh_nhalos == 2) + + ! Allocate a new metric field on the new positions mesh and zero it + if (present(metric).or.present(full_metric)) then + call allocate(new_metric, zoltan_global_new_positions%mesh, "ErrorMetric") + call set(new_metric,spread(spread(666.0, 1, new_metric%dim(1)), 2, new_metric%dim(2))) + end if + + ! Setup meshes and fields on states + call restore_reserved_meshes(states) + call insert_derived_meshes(states, skip_extrusion=skip_extrusion_after) + call allocate_and_insert_fields(states) + call restore_reserved_fields(states) + + ! And set up zoltan_global_target_states based on states + do i=1,size(states) + call select_fields_to_interpolate(states(i), interpolate_states(i), no_positions=.true., & first_time_step=initialise_fields) - end do - - ! Metric will be interpolated too, it is 666.0 (for debugging purposes) at this point - if (present(metric).or.present(full_metric)) then - call insert(interpolate_states(1), new_metric, "ErrorMetric") - end if - - allocate(zoltan_global_target_states(no_meshes)) - call collect_fields_by_mesh(interpolate_states, mesh_names(1:no_meshes), zoltan_global_target_states) - - ! Finished with interpolate states for setting up zoltan_global_target_states - do i=1,size(interpolate_states) - call deallocate(interpolate_states(i)) - end do - - ! Tell Zoltan which callback functions to use for the migration - ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_SIZE_MULTI_FN_TYPE, zoltan_cb_pack_field_sizes); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_PACK_OBJ_MULTI_FN_TYPE, zoltan_cb_pack_fields); assert(ierr == ZOLTAN_OK) - ierr = Zoltan_Set_Fn(zz, ZOLTAN_UNPACK_OBJ_MULTI_FN_TYPE, zoltan_cb_unpack_fields); assert(ierr == ZOLTAN_OK) - - ewrite(1,*) 'exiting initialise_transfer' - - end subroutine initialise_transfer - - subroutine update_detector_list_element(detector_list_array) - ! Update the detector%element field for every detector left in our list - ! and check that we did not miss any in the first send - ! broadcast them if we did - type(detector_list_ptr), dimension(:), intent(inout) :: detector_list_array - - type(detector_linked_list), pointer :: detector_list => null() - type(detector_linked_list) :: detector_send_list - type(detector_type), pointer :: detector => null(), send_detector => null() - integer :: i, j, send_count, ierr - integer :: old_local_element_number, new_local_element_number, old_universal_element_number - integer, allocatable :: ndets_being_sent(:) - real, allocatable :: send_buff(:,:), recv_buff(:,:) - logical do_broadcast - type(element_type), pointer :: shape - - ewrite(1,*) "In update_detector_list_element" - - send_count=0 - - !Loop for detectors or particles with no attributes - - do j = 1, size(detector_list_array) - detector_list => detector_list_array(j)%ptr - ewrite(2,*) "Length of detector list to be updated: ", detector_list%length - - detector => detector_list%first - !Cycle if particle has attributes - if (associated(detector)) then - if (size(detector%attributes)>=1) then - cycle - end if - end if - do while (associated(detector)) - - old_local_element_number = detector%element - - if (.not. has_key(zoltan_global_old_local_numbering_to_uen, old_local_element_number)) then - ewrite(-1,*) "Zoltan can't find old element number for detector ", detector%id_number - FLAbort('Trying to update unknown detector in Zoltan') - end if - old_universal_element_number = fetch(zoltan_global_old_local_numbering_to_uen, old_local_element_number) - - if(has_key(zoltan_global_uen_to_new_local_numbering, old_universal_element_number)) then - ! Update the element number for the detector - detector%element = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - detector%local_coords = local_coords(zoltan_global_new_positions,detector%element,detector%position) - detector => detector%next - else - ! We no longer own the element containing this detector, and cannot establish its new - ! owner from the halo, because the boundary has moved too far. - ! Since we have no way of determining the new owner we are going to broadcast the detector - ! to all procs, so move it to the send list and count how many detectors we're sending. - ewrite(2,*) "Found non-local detector, initialising broadcast..." - send_count = send_count + 1 - - ! Store the old universal element number for unpacking to new local at the receive - detector%element = old_universal_element_number - detector%list_id=detector_list%id - - ! Remove detector from detector list - send_detector => detector - detector => detector%next - call move(send_detector, detector_list, detector_send_list) - end if - end do - end do - - ! Find out how many detectors each process wants to broadcast - allocate(ndets_being_sent(getnprocs())) - call mpi_allgather(send_count, 1, getPINTEGER(), ndets_being_sent, 1 , getPINTEGER(), MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - ! Check whether we have to perform broadcast, if not return - do_broadcast=.false. - if (any(ndets_being_sent > 0)) then - do_broadcast=.true. - end if - if (.not. do_broadcast) then - ewrite(1,*) "Exiting update_detector_list_element" - return - end if - ewrite(2,*) "Broadcast required, initialising..." - - ! Allocate memory for all the detectors you're going to send - allocate(send_buff(send_count,zoltan_global_ndata_per_det)) - - detector => detector_send_list%first - do i=1,send_count - ! Pack the detector information and delete from send_list (delete advances detector to detector%next) - call pack_detector(detector, send_buff(i, 1:zoltan_global_ndata_per_det), zoltan_global_ndims) - call delete(detector, detector_send_list) - end do - - ! Broadcast detectors whose new owner we can't identify - do i=1,getnprocs() - if (ndets_being_sent(i) > 0) then - - if (i == getprocno()) then - ! Broadcast the detectors you want to send - ewrite(2,*) "Broadcasting ", send_count, " detectors" - call mpi_bcast(send_buff,send_count*zoltan_global_ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - else - ! Allocate memory to receive into - allocate(recv_buff(ndets_being_sent(i),zoltan_global_ndata_per_det)) - - ! Receive broadcast - ewrite(2,*) "Receiving ", ndets_being_sent(i), " detectors from process ", i - call mpi_bcast(recv_buff,ndets_being_sent(i)*zoltan_global_ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - ! Unpack detector if you own it - do j=1,ndets_being_sent(i) - - ! Allocate and unpack the detector - shape=>ele_shape(zoltan_global_new_positions,1) - call allocate(detector, zoltan_global_ndims, local_coord_count(shape)) - call unpack_detector(detector, recv_buff(j, 1:zoltan_global_ndata_per_det), zoltan_global_ndims) - - if (has_key(zoltan_global_uen_to_new_local_numbering, detector%element)) then - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, detector%element) - if (element_owned(zoltan_global_new_positions%mesh, new_local_element_number)) then - detector%element = new_local_element_number - if (.not. allocated(detector%local_coords)) then - allocate(detector%local_coords(local_coord_count(ele_shape(zoltan_global_new_positions,1)))) - end if - detector%local_coords=local_coords(zoltan_global_new_positions,detector%element,detector%position) - call insert(detector, detector_list_array(detector%list_id)%ptr) - detector => null() - else - call delete(detector) - end if - else - call delete(detector) - end if - end do - - deallocate(recv_buff) - end if - end if - end do - - deallocate(ndets_being_sent) - deallocate(send_buff) - ewrite(1,*) "Exiting update_detector_list_element" - - end subroutine update_detector_list_element - - subroutine update_particle_list_element(detector_list_array) - ! Update the detector%element field for every particle left in our list - type(detector_list_ptr), dimension(:), intent(inout) :: detector_list_array - - type(detector_linked_list), pointer :: detector_list => null() - type(detector_linked_list) :: detector_send_list - type(detector_type), pointer :: detector => null(), send_detector => null() - integer :: i, j, send_count, ierr,k - integer :: old_local_element_number, new_local_element_number, old_universal_element_number - integer, allocatable :: ndets_being_sent(:) - real, allocatable :: send_buff(:,:), recv_buff(:,:) - logical :: do_broadcast - integer :: total_attributes - type(element_type), pointer :: shape - - ewrite(1,*) "In update_particle_list_element" - - !Loop for particles with attributes - - do j = 1, size(detector_list_array) - send_count=0 - detector_list => detector_list_array(j)%ptr - ewrite(2,*) "Length of detector list to be updated: ", detector_list%length - - if (sum(detector_list%total_attributes)==0) cycle - - detector => detector_list%first - - do while (associated(detector)) - - old_local_element_number = detector%element - - if (.not. has_key(zoltan_global_old_local_numbering_to_uen, old_local_element_number)) then - ewrite(-1,*) "Zoltan can't find old element number for particle ", detector%id_number - FLAbort('Trying to update unknown particle in Zoltan') - end if - old_universal_element_number = fetch(zoltan_global_old_local_numbering_to_uen, old_local_element_number) - - if(has_key(zoltan_global_uen_to_new_local_numbering, old_universal_element_number)) then - ! Update the element number for the particle - detector%element = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - detector%local_coords = local_coords(zoltan_global_new_positions,detector%element,detector%position) - detector => detector%next - else - ! We no longer own the element containing this particle, and cannot establish its new - ! owner from the halo, because the boundary has moved too far. - ! Since we have no way of determining the new owner we are going to broadcast the particle - ! to all procs, so move it to the send list and count how many particles we're sending. - ewrite(2,*) "Found non-local particle, initialising broadcast..." - send_count = send_count + 1 - - ! Store the old universal element number for unpacking to new local at the receive - detector%element = old_universal_element_number - detector%list_id=detector_list%id - - ! Remove detector from detector list - send_detector => detector - detector => detector%next - call move(send_detector, detector_list, detector_send_list) - end if - end do - ! Find out how many particles each process wants to broadcast - allocate(ndets_being_sent(getnprocs())) - call mpi_allgather(send_count, 1, getPINTEGER(), ndets_being_sent, 1 , getPINTEGER(), MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - ! Check whether we have to perform broadcast, if not return - do_broadcast=.false. - if (any(ndets_being_sent > 0)) then - do_broadcast=.true. - end if - if (.not. do_broadcast) then - deallocate(ndets_being_sent) - cycle - end if - - ewrite(2,*) "Broadcast required, initialising..." - - total_attributes=sum(detector_list%total_attributes) - - ! Allocate memory for all the particles you're going to send - allocate(send_buff(send_count,zoltan_global_ndata_per_det+total_attributes)) - - detector => detector_send_list%first - do i=1,send_count - ! Pack the particle information and delete from send_list (delete advances particle to detector%next) - call pack_detector(detector, send_buff(i,1:zoltan_global_ndata_per_det+total_attributes), zoltan_global_ndims, & + end do + + ! Metric will be interpolated too, it is 666.0 (for debugging purposes) at this point + if (present(metric).or.present(full_metric)) then + call insert(interpolate_states(1), new_metric, "ErrorMetric") + end if + + allocate(zoltan_global_target_states(no_meshes)) + call collect_fields_by_mesh(interpolate_states, mesh_names(1:no_meshes), zoltan_global_target_states) + + ! Finished with interpolate states for setting up zoltan_global_target_states + do i=1,size(interpolate_states) + call deallocate(interpolate_states(i)) + end do + + ! Tell Zoltan which callback functions to use for the migration + ierr = Zoltan_Set_Fn(zz, ZOLTAN_OBJ_SIZE_MULTI_FN_TYPE, zoltan_cb_pack_field_sizes); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_PACK_OBJ_MULTI_FN_TYPE, zoltan_cb_pack_fields); assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Set_Fn(zz, ZOLTAN_UNPACK_OBJ_MULTI_FN_TYPE, zoltan_cb_unpack_fields); assert(ierr == ZOLTAN_OK) + + ewrite(1,*) 'exiting initialise_transfer' + + end subroutine initialise_transfer + + subroutine update_detector_list_element(detector_list_array) + ! Update the detector%element field for every detector left in our list + ! and check that we did not miss any in the first send + ! broadcast them if we did + type(detector_list_ptr), dimension(:), intent(inout) :: detector_list_array + + type(detector_linked_list), pointer :: detector_list => null() + type(detector_linked_list) :: detector_send_list + type(detector_type), pointer :: detector => null(), send_detector => null() + integer :: i, j, send_count, ierr + integer :: old_local_element_number, new_local_element_number, old_universal_element_number + integer, allocatable :: ndets_being_sent(:) + real, allocatable :: send_buff(:,:), recv_buff(:,:) + logical do_broadcast + type(element_type), pointer :: shape + + ewrite(1,*) "In update_detector_list_element" + + send_count=0 + + !Loop for detectors or particles with no attributes + + do j = 1, size(detector_list_array) + detector_list => detector_list_array(j)%ptr + ewrite(2,*) "Length of detector list to be updated: ", detector_list%length + + detector => detector_list%first + !Cycle if particle has attributes + if (associated(detector)) then + if (size(detector%attributes)>=1) then + cycle + end if + end if + do while (associated(detector)) + + old_local_element_number = detector%element + + if (.not. has_key(zoltan_global_old_local_numbering_to_uen, old_local_element_number)) then + ewrite(-1,*) "Zoltan can't find old element number for detector ", detector%id_number + FLAbort('Trying to update unknown detector in Zoltan') + end if + old_universal_element_number = fetch(zoltan_global_old_local_numbering_to_uen, old_local_element_number) + + if(has_key(zoltan_global_uen_to_new_local_numbering, old_universal_element_number)) then + ! Update the element number for the detector + detector%element = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + detector%local_coords = local_coords(zoltan_global_new_positions,detector%element,detector%position) + detector => detector%next + else + ! We no longer own the element containing this detector, and cannot establish its new + ! owner from the halo, because the boundary has moved too far. + ! Since we have no way of determining the new owner we are going to broadcast the detector + ! to all procs, so move it to the send list and count how many detectors we're sending. + ewrite(2,*) "Found non-local detector, initialising broadcast..." + send_count = send_count + 1 + + ! Store the old universal element number for unpacking to new local at the receive + detector%element = old_universal_element_number + detector%list_id=detector_list%id + + ! Remove detector from detector list + send_detector => detector + detector => detector%next + call move(send_detector, detector_list, detector_send_list) + end if + end do + end do + + ! Find out how many detectors each process wants to broadcast + allocate(ndets_being_sent(getnprocs())) + call mpi_allgather(send_count, 1, getPINTEGER(), ndets_being_sent, 1 , getPINTEGER(), MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + ! Check whether we have to perform broadcast, if not return + do_broadcast=.false. + if (any(ndets_being_sent > 0)) then + do_broadcast=.true. + end if + if (.not. do_broadcast) then + ewrite(1,*) "Exiting update_detector_list_element" + return + end if + ewrite(2,*) "Broadcast required, initialising..." + + ! Allocate memory for all the detectors you're going to send + allocate(send_buff(send_count,zoltan_global_ndata_per_det)) + + detector => detector_send_list%first + do i=1,send_count + ! Pack the detector information and delete from send_list (delete advances detector to detector%next) + call pack_detector(detector, send_buff(i, 1:zoltan_global_ndata_per_det), zoltan_global_ndims) + call delete(detector, detector_send_list) + end do + + ! Broadcast detectors whose new owner we can't identify + do i=1,getnprocs() + if (ndets_being_sent(i) > 0) then + + if (i == getprocno()) then + ! Broadcast the detectors you want to send + ewrite(2,*) "Broadcasting ", send_count, " detectors" + call mpi_bcast(send_buff,send_count*zoltan_global_ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + else + ! Allocate memory to receive into + allocate(recv_buff(ndets_being_sent(i),zoltan_global_ndata_per_det)) + + ! Receive broadcast + ewrite(2,*) "Receiving ", ndets_being_sent(i), " detectors from process ", i + call mpi_bcast(recv_buff,ndets_being_sent(i)*zoltan_global_ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + ! Unpack detector if you own it + do j=1,ndets_being_sent(i) + + ! Allocate and unpack the detector + shape=>ele_shape(zoltan_global_new_positions,1) + call allocate(detector, zoltan_global_ndims, local_coord_count(shape)) + call unpack_detector(detector, recv_buff(j, 1:zoltan_global_ndata_per_det), zoltan_global_ndims) + + if (has_key(zoltan_global_uen_to_new_local_numbering, detector%element)) then + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, detector%element) + if (element_owned(zoltan_global_new_positions%mesh, new_local_element_number)) then + detector%element = new_local_element_number + if (.not. allocated(detector%local_coords)) then + allocate(detector%local_coords(local_coord_count(ele_shape(zoltan_global_new_positions,1)))) + end if + detector%local_coords=local_coords(zoltan_global_new_positions,detector%element,detector%position) + call insert(detector, detector_list_array(detector%list_id)%ptr) + detector => null() + else + call delete(detector) + end if + else + call delete(detector) + end if + end do + + deallocate(recv_buff) + end if + end if + end do + + deallocate(ndets_being_sent) + deallocate(send_buff) + ewrite(1,*) "Exiting update_detector_list_element" + + end subroutine update_detector_list_element + + subroutine update_particle_list_element(detector_list_array) + ! Update the detector%element field for every particle left in our list + type(detector_list_ptr), dimension(:), intent(inout) :: detector_list_array + + type(detector_linked_list), pointer :: detector_list => null() + type(detector_linked_list) :: detector_send_list + type(detector_type), pointer :: detector => null(), send_detector => null() + integer :: i, j, send_count, ierr,k + integer :: old_local_element_number, new_local_element_number, old_universal_element_number + integer, allocatable :: ndets_being_sent(:) + real, allocatable :: send_buff(:,:), recv_buff(:,:) + logical :: do_broadcast + integer :: total_attributes + type(element_type), pointer :: shape + + ewrite(1,*) "In update_particle_list_element" + + !Loop for particles with attributes + + do j = 1, size(detector_list_array) + send_count=0 + detector_list => detector_list_array(j)%ptr + ewrite(2,*) "Length of detector list to be updated: ", detector_list%length + + if (sum(detector_list%total_attributes)==0) cycle + + detector => detector_list%first + + do while (associated(detector)) + + old_local_element_number = detector%element + + if (.not. has_key(zoltan_global_old_local_numbering_to_uen, old_local_element_number)) then + ewrite(-1,*) "Zoltan can't find old element number for particle ", detector%id_number + FLAbort('Trying to update unknown particle in Zoltan') + end if + old_universal_element_number = fetch(zoltan_global_old_local_numbering_to_uen, old_local_element_number) + + if(has_key(zoltan_global_uen_to_new_local_numbering, old_universal_element_number)) then + ! Update the element number for the particle + detector%element = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + detector%local_coords = local_coords(zoltan_global_new_positions,detector%element,detector%position) + detector => detector%next + else + ! We no longer own the element containing this particle, and cannot establish its new + ! owner from the halo, because the boundary has moved too far. + ! Since we have no way of determining the new owner we are going to broadcast the particle + ! to all procs, so move it to the send list and count how many particles we're sending. + ewrite(2,*) "Found non-local particle, initialising broadcast..." + send_count = send_count + 1 + + ! Store the old universal element number for unpacking to new local at the receive + detector%element = old_universal_element_number + detector%list_id=detector_list%id + + ! Remove detector from detector list + send_detector => detector + detector => detector%next + call move(send_detector, detector_list, detector_send_list) + end if + end do + ! Find out how many particles each process wants to broadcast + allocate(ndets_being_sent(getnprocs())) + call mpi_allgather(send_count, 1, getPINTEGER(), ndets_being_sent, 1 , getPINTEGER(), MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + ! Check whether we have to perform broadcast, if not return + do_broadcast=.false. + if (any(ndets_being_sent > 0)) then + do_broadcast=.true. + end if + if (.not. do_broadcast) then + deallocate(ndets_being_sent) + cycle + end if + + ewrite(2,*) "Broadcast required, initialising..." + + total_attributes=sum(detector_list%total_attributes) + + ! Allocate memory for all the particles you're going to send + allocate(send_buff(send_count,zoltan_global_ndata_per_det+total_attributes)) + + detector => detector_send_list%first + do i=1,send_count + ! Pack the particle information and delete from send_list (delete advances particle to detector%next) + call pack_detector(detector, send_buff(i,1:zoltan_global_ndata_per_det+total_attributes), zoltan_global_ndims, & attribute_size_in=detector_list%total_attributes) - call delete(detector, detector_send_list) - end do - - ! Broadcast particles whose new owner we can't identify - do i=1,getnprocs() - if (ndets_being_sent(i) > 0) then - - if (i == getprocno()) then - ! Broadcast the particles you want to send - ewrite(2,*) "Broadcasting ", send_count, " particles" - call mpi_bcast(send_buff,send_count*(zoltan_global_ndata_per_det+total_attributes), getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - else - ! Allocate memory to receive into - allocate(recv_buff(ndets_being_sent(i),zoltan_global_ndata_per_det+total_attributes)) - - ! Receive broadcast - ewrite(2,*) "Receiving ", ndets_being_sent(i), " particles from process ", i - call mpi_bcast(recv_buff,ndets_being_sent(i)*(zoltan_global_ndata_per_det+total_attributes), getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - ! Unpack particle if you own it - do k=1,ndets_being_sent(i) - - ! Allocate and unpack the particle - shape=>ele_shape(zoltan_global_new_positions,1) - call allocate(detector, zoltan_global_ndims, local_coord_count(shape), detector_list%total_attributes) - call unpack_detector(detector, recv_buff(k, 1:zoltan_global_ndata_per_det+total_attributes), zoltan_global_ndims, & - attribute_size_in=detector_list%total_attributes) - - if (has_key(zoltan_global_uen_to_new_local_numbering, detector%element)) then - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, detector%element) - if (element_owned(zoltan_global_new_positions%mesh, new_local_element_number)) then - detector%element = new_local_element_number - if (.not. allocated(detector%local_coords)) then - allocate(detector%local_coords(local_coord_count(ele_shape(zoltan_global_new_positions,1)))) - end if - detector%local_coords=local_coords(zoltan_global_new_positions,detector%element,detector%position) - call insert(detector, detector_list_array(detector%list_id)%ptr) - detector => null() - else - call delete(detector) - end if - else - call delete(detector) - end if - end do - - deallocate(recv_buff) - end if - end if - end do - deallocate(send_buff) - deallocate(ndets_being_sent) - end do - - ewrite(1,*) "Exiting update_particle_list_element" - - end subroutine update_particle_list_element - - subroutine transfer_fields(zz) - ! OK! So, here is how this is going to work. We are going to - ! loop through every element in which you own at least one node, and note - ! that its information needs to be sent to the owners of its vertices. - ! We also have to take special care of self-sends, since they don't - ! get taken care of in the zoltan communication. - - type(zoltan_struct), pointer, intent(in) :: zz - - integer :: old_ele - integer, dimension(:), pointer :: old_local_nodes, nodes - type(element_type), pointer :: eshape - type(integer_set), dimension(halo_proc_count(zoltan_global_zz_halo)) :: sends - integer :: i, j, new_owner, universal_element_number - type(integer_set) :: self_sends - integer :: num_import, num_export - integer :: original_zoltan_global_unpacked_detectors_list_length - integer, dimension(:,:), allocatable :: vertex_order - integer, dimension(:), pointer :: import_global_ids, import_local_ids, import_procs, import_to_part - integer, dimension(:), pointer :: export_global_ids, export_local_ids, export_procs, export_to_part - integer :: head - integer(zoltan_int) :: ierr - - integer :: old_universal_element_number, new_local_element_number, old_local_element_number - integer :: state_no, field_no - type(scalar_field), pointer :: source_sfield, target_sfield - type(vector_field), pointer :: source_vfield, target_vfield - type(tensor_field), pointer :: source_tfield, target_tfield - - type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() - type(detector_type), pointer :: detector => null(), add_detector => null() - - ewrite(1,*) 'in transfer_fields' - - do i=1,size(sends) - call allocate(sends(i)) - end do - call allocate(self_sends) - - - do old_ele=1,ele_count(zoltan_global_zz_positions) - universal_element_number = halo_universal_number(zoltan_global_zz_ele_halo, old_ele) - old_local_nodes => ele_nodes(zoltan_global_zz_positions, old_ele) - if (.not. any(nodes_owned(zoltan_global_zz_halo, old_local_nodes))) cycle - do i=1,size(old_local_nodes) - if (has_value(zoltan_global_nodes_we_are_keeping, old_local_nodes(i))) then - assert(node_owned(zoltan_global_zz_halo, old_local_nodes(i))) - call insert(self_sends, universal_element_number) - else if (has_key(zoltan_global_nodes_we_are_sending, old_local_nodes(i))) then - new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_nodes(i)) - call insert(sends(new_owner+1), universal_element_number) - end if - end do - end do - - num_export = sum(key_count(sends)) - allocate(export_global_ids(num_export)) - allocate(export_procs(num_export)) - - ! allocate array for storing the number of detectors in each of the elements to be transferred - allocate(zoltan_global_ndets_in_ele(num_export)) - zoltan_global_ndets_in_ele(:) = 0 - - ! calculate the amount of data to be transferred per detector - zoltan_global_ndims = zoltan_global_zz_positions%dim - zoltan_global_ndata_per_det = detector_buffer_size(zoltan_global_ndims, .false.) - ewrite(2,*) "Amount of data to be transferred per detector: ", zoltan_global_ndata_per_det - - head = 1 - do i=1,size(sends) - export_global_ids(head:head + key_count(sends(i)) - 1) = set2vector(sends(i)) - export_procs(head:head + key_count(sends(i)) - 1) = i - 1 - head = head + key_count(sends(i)) - end do - - allocate(export_local_ids(num_export)) - export_local_ids = 666 - - import_global_ids => null() - import_local_ids => null() - import_procs => null() - import_to_part => null() - export_to_part => null() - - ierr = Zoltan_Compute_Destinations(zz, & - & num_export, export_global_ids, export_local_ids, export_procs, & - & num_import, import_global_ids, import_local_ids, import_procs) - assert(ierr == ZOLTAN_OK) - - ! Get all detector lists - call get_registered_detector_lists(detector_list_array) - - ! Log list lengths - if (get_num_detector_lists()>0) then - ewrite(2,*) "Before migrate, we have", get_num_detector_lists(), "detector lists:" - do j = 1, size(detector_list_array) - ewrite(2,*) "Detector list", j, "has", detector_list_array(j)%ptr%length, "local and ", detector_list_array(j)%ptr%total_num_det, "global detectors" - end do - end if - - ierr = Zoltan_Migrate(zz, num_import, import_global_ids, import_local_ids, import_procs, & - & import_to_part, num_export, export_global_ids, export_local_ids, export_procs, export_to_part) - - assert(ierr == ZOLTAN_OK) - - deallocate(export_local_ids) - deallocate(export_procs) - deallocate(export_global_ids) - - deallocate(zoltan_global_ndets_in_ele) - - ! update the local detectors and make sure we didn't miss any in the first send - if (get_num_detector_lists()>0) then - call update_detector_list_element(detector_list_array) - call update_particle_list_element(detector_list_array) - end if - - ! Merge in any detectors we received as part of the transfer to our detector list - detector => zoltan_global_unpacked_detectors_list%first - original_zoltan_global_unpacked_detectors_list_length = zoltan_global_unpacked_detectors_list%length - - do j=1, original_zoltan_global_unpacked_detectors_list_length - add_detector => detector - detector => detector%next - - ! move detector to the correct list - call move(add_detector, zoltan_global_unpacked_detectors_list, detector_list_array(add_detector%list_id)%ptr) - end do - - assert(zoltan_global_unpacked_detectors_list%length==0) - ewrite(2,*) "Merged", original_zoltan_global_unpacked_detectors_list_length, "detectors with local detector lists" - - ! Log list lengths - if (get_num_detector_lists()>0) then - call get_registered_detector_lists(detector_list_array) - ewrite(2,*) "After migrate and merge, we have", get_num_detector_lists(), "detector lists:" - do j = 1, size(detector_list_array) - ewrite(2,*) "Detector list", j, "has", detector_list_array(j)%ptr%length, "local and ", detector_list_array(j)%ptr%total_num_det, "global detectors" - end do - end if - - ierr = Zoltan_LB_Free_Part(import_global_ids, import_local_ids, import_procs, import_to_part) - assert(ierr == ZOLTAN_OK) - - ! for all self-send elements, establish the vertex order in the new element such - ! that it matches the local element ordering of the old element - allocate(vertex_order(1:ele_loc(zoltan_global_new_positions,1), key_count(self_sends))) - do i=1, key_count(self_sends) - old_universal_element_number = fetch(self_sends, i) - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) - ! this function takes the universal node numbers of the old element and the new global (over the local domain) - ! node numbers, to compute the vertex order - vertex_order(:,i) = local_vertex_order( & - halo_universal_number(zoltan_global_zz_halo, ele_nodes(zoltan_global_zz_positions, old_local_element_number)), & - ele_nodes(zoltan_global_new_positions, new_local_element_number)) - end do - - do state_no=1,size(zoltan_global_source_states) - assert(scalar_field_count(zoltan_global_source_states(state_no)) == scalar_field_count(zoltan_global_target_states(state_no))) - assert(vector_field_count(zoltan_global_source_states(state_no)) == vector_field_count(zoltan_global_target_states(state_no))) - assert(tensor_field_count(zoltan_global_source_states(state_no)) == tensor_field_count(zoltan_global_target_states(state_no))) - - do field_no=1,scalar_field_count(zoltan_global_source_states(state_no)) - source_sfield => extract_scalar_field(zoltan_global_source_states(state_no), field_no) - target_sfield => extract_scalar_field(zoltan_global_target_states(state_no), field_no) - assert(trim(source_sfield%name) == trim(target_sfield%name)) - - do i=1,key_count(self_sends) - old_universal_element_number = fetch(self_sends, i) - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) - eshape => ele_shape(target_sfield, new_local_element_number) - nodes => ele_nodes(target_sfield, new_local_element_number) - call set(target_sfield, nodes(ele_local_num(vertex_order(:,i), eshape%numbering)), & - ele_val(source_sfield, old_local_element_number)) - end do - end do - - do field_no=1,vector_field_count(zoltan_global_source_states(state_no)) - source_vfield => extract_vector_field(zoltan_global_source_states(state_no), field_no) - target_vfield => extract_vector_field(zoltan_global_target_states(state_no), field_no) - assert(trim(source_vfield%name) == trim(target_vfield%name)) - if (source_vfield%name == zoltan_global_new_positions%name) cycle - - do i=1,key_count(self_sends) - old_universal_element_number = fetch(self_sends, i) - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) - eshape => ele_shape(target_vfield, new_local_element_number) - nodes => ele_nodes(target_vfield, new_local_element_number) - call set(target_vfield, nodes(ele_local_num(vertex_order(:,i), eshape%numbering)), & - ele_val(source_vfield, old_local_element_number)) - end do - end do - - do field_no=1,tensor_field_count(zoltan_global_source_states(state_no)) - source_tfield => extract_tensor_field(zoltan_global_source_states(state_no), field_no) - target_tfield => extract_tensor_field(zoltan_global_target_states(state_no), field_no) - assert(trim(source_tfield%name) == trim(target_tfield%name)) - - do i=1,key_count(self_sends) - old_universal_element_number = fetch(self_sends, i) - new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) - old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) - eshape => ele_shape(target_tfield, new_local_element_number) - nodes => ele_nodes(target_tfield, new_local_element_number) - call set(target_tfield, nodes(ele_local_num(vertex_order(:,i), eshape%numbering)), & - ele_val(source_tfield, old_local_element_number)) - end do - end do - end do - - call deallocate(self_sends) - call deallocate(sends) - deallocate(vertex_order) - - call halo_update(zoltan_global_target_states) - - ewrite(1,*) 'exiting transfer_fields' - - end subroutine transfer_fields - - subroutine finalise_transfer(states, metric, full_metric, new_metric) - type(state_type), dimension(:), intent(inout), target :: states - - type(tensor_field), intent(inout), optional :: metric - type(tensor_field), intent(inout), optional :: full_metric - type(tensor_field), intent(in) :: new_metric - - integer :: i - call set_prescribed_field_values(states, exclude_interpolated = .true.) - call populate_boundary_conditions(states) - call set_boundary_conditions_values(states) - call set_dirichlet_consistent(states) - call alias_fields(states) - - if (present(full_metric)) then - full_metric = new_metric - call halo_update(full_metric) - else if (present(metric)) then - metric = new_metric - call halo_update(metric) - end if - - do i=1,size(zoltan_global_source_states) - call deallocate(zoltan_global_source_states(i)) - call deallocate(zoltan_global_target_states(i)) - end do - deallocate(zoltan_global_source_states) - deallocate(zoltan_global_target_states) - end subroutine finalise_transfer - - subroutine dump_linear_mesh - type(scalar_field) :: sends, receives, unn - integer :: i, proc - - assert(associated(zoltan_global_new_positions%refcount)) - assert(zoltan_global_new_positions%refcount%count == 1) - assert(associated(zoltan_global_new_positions%mesh%refcount)) - assert(zoltan_global_new_positions%mesh%refcount%count == 1) - - call allocate(sends, zoltan_global_new_positions%mesh, "Sends") - call zero(sends) - call allocate(receives, zoltan_global_new_positions%mesh, "Receives") - call zero(receives) - call allocate(unn, zoltan_global_new_positions%mesh, "NewUniversalNodeNumber") - call zero(unn) - - do proc=1,halo_proc_count(zoltan_global_new_positions%mesh%halos(2)) - do i=1,size(zoltan_global_new_positions%mesh%halos(2)%sends(proc)%ptr) - call set(sends, zoltan_global_new_positions%mesh%halos(2)%sends(proc)%ptr(i), 1.0) - end do - do i=1,size(zoltan_global_new_positions%mesh%halos(2)%receives(proc)%ptr) - call set(receives, zoltan_global_new_positions%mesh%halos(2)%receives(proc)%ptr(i), 1.0) - end do - end do - - do i=1,node_count(zoltan_global_new_positions) - call set(unn, i, float(halo_universal_number(zoltan_global_new_positions%mesh%halos(2), i))) - end do - - call deallocate(sends) - call deallocate(receives) - call deallocate(unn) - end subroutine dump_linear_mesh - - subroutine dump_suggested_owner(states, p1_num_export, p1_export_local_ids, p1_export_procs) - type(state_type), dimension(:), intent(inout), target :: states - integer(zoltan_int), intent(in) :: p1_num_export - integer, dimension(:), pointer, intent(in) :: p1_export_local_ids, p1_export_procs - - integer :: rank, i - type(scalar_field) :: suggested_owner, unn - type(vector_field) :: positions - - rank = getrank() - call allocate(suggested_owner, zoltan_global_zz_mesh, "SuggestedOwner") - - call set(suggested_owner, float(rank)) - do i=1,p1_num_export - call set(suggested_owner, p1_export_local_ids(i), float(p1_export_procs(i))) - end do - - call allocate(unn, zoltan_global_zz_mesh, "OldUniversalNodeNumber") - do i=1,node_count(unn) - call set(unn, i, float(halo_universal_number(zoltan_global_zz_halo, i))) - end do - - positions = get_coordinate_field(states(1), zoltan_global_zz_mesh) - call halo_update(suggested_owner) - call deallocate(positions) - call deallocate(suggested_owner) - call deallocate(unn) - - end subroutine dump_suggested_owner + call delete(detector, detector_send_list) + end do + + ! Broadcast particles whose new owner we can't identify + do i=1,getnprocs() + if (ndets_being_sent(i) > 0) then + + if (i == getprocno()) then + ! Broadcast the particles you want to send + ewrite(2,*) "Broadcasting ", send_count, " particles" + call mpi_bcast(send_buff,send_count*(zoltan_global_ndata_per_det+total_attributes), getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + else + ! Allocate memory to receive into + allocate(recv_buff(ndets_being_sent(i),zoltan_global_ndata_per_det+total_attributes)) + + ! Receive broadcast + ewrite(2,*) "Receiving ", ndets_being_sent(i), " particles from process ", i + call mpi_bcast(recv_buff,ndets_being_sent(i)*(zoltan_global_ndata_per_det+total_attributes), getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + ! Unpack particle if you own it + do k=1,ndets_being_sent(i) + + ! Allocate and unpack the particle + shape=>ele_shape(zoltan_global_new_positions,1) + call allocate(detector, zoltan_global_ndims, local_coord_count(shape), detector_list%total_attributes) + call unpack_detector(detector, recv_buff(k, 1:zoltan_global_ndata_per_det+total_attributes), zoltan_global_ndims, & + attribute_size_in=detector_list%total_attributes) + + if (has_key(zoltan_global_uen_to_new_local_numbering, detector%element)) then + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, detector%element) + if (element_owned(zoltan_global_new_positions%mesh, new_local_element_number)) then + detector%element = new_local_element_number + if (.not. allocated(detector%local_coords)) then + allocate(detector%local_coords(local_coord_count(ele_shape(zoltan_global_new_positions,1)))) + end if + detector%local_coords=local_coords(zoltan_global_new_positions,detector%element,detector%position) + call insert(detector, detector_list_array(detector%list_id)%ptr) + detector => null() + else + call delete(detector) + end if + else + call delete(detector) + end if + end do + + deallocate(recv_buff) + end if + end if + end do + deallocate(send_buff) + deallocate(ndets_being_sent) + end do + + ewrite(1,*) "Exiting update_particle_list_element" + + end subroutine update_particle_list_element + + subroutine transfer_fields(zz) + ! OK! So, here is how this is going to work. We are going to + ! loop through every element in which you own at least one node, and note + ! that its information needs to be sent to the owners of its vertices. + ! We also have to take special care of self-sends, since they don't + ! get taken care of in the zoltan communication. + + type(zoltan_struct), pointer, intent(in) :: zz + + integer :: old_ele + integer, dimension(:), pointer :: old_local_nodes, nodes + type(element_type), pointer :: eshape + type(integer_set), dimension(halo_proc_count(zoltan_global_zz_halo)) :: sends + integer :: i, j, new_owner, universal_element_number + type(integer_set) :: self_sends + integer :: num_import, num_export + integer :: original_zoltan_global_unpacked_detectors_list_length + integer, dimension(:,:), allocatable :: vertex_order + integer, dimension(:), pointer :: import_global_ids, import_local_ids, import_procs, import_to_part + integer, dimension(:), pointer :: export_global_ids, export_local_ids, export_procs, export_to_part + integer :: head + integer(zoltan_int) :: ierr + + integer :: old_universal_element_number, new_local_element_number, old_local_element_number + integer :: state_no, field_no + type(scalar_field), pointer :: source_sfield, target_sfield + type(vector_field), pointer :: source_vfield, target_vfield + type(tensor_field), pointer :: source_tfield, target_tfield + + type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() + type(detector_type), pointer :: detector => null(), add_detector => null() + + ewrite(1,*) 'in transfer_fields' + + do i=1,size(sends) + call allocate(sends(i)) + end do + call allocate(self_sends) + + + do old_ele=1,ele_count(zoltan_global_zz_positions) + universal_element_number = halo_universal_number(zoltan_global_zz_ele_halo, old_ele) + old_local_nodes => ele_nodes(zoltan_global_zz_positions, old_ele) + if (.not. any(nodes_owned(zoltan_global_zz_halo, old_local_nodes))) cycle + do i=1,size(old_local_nodes) + if (has_value(zoltan_global_nodes_we_are_keeping, old_local_nodes(i))) then + assert(node_owned(zoltan_global_zz_halo, old_local_nodes(i))) + call insert(self_sends, universal_element_number) + else if (has_key(zoltan_global_nodes_we_are_sending, old_local_nodes(i))) then + new_owner = fetch(zoltan_global_nodes_we_are_sending, old_local_nodes(i)) + call insert(sends(new_owner+1), universal_element_number) + end if + end do + end do + + num_export = sum(key_count(sends)) + allocate(export_global_ids(num_export)) + allocate(export_procs(num_export)) + + ! allocate array for storing the number of detectors in each of the elements to be transferred + allocate(zoltan_global_ndets_in_ele(num_export)) + zoltan_global_ndets_in_ele(:) = 0 + + ! calculate the amount of data to be transferred per detector + zoltan_global_ndims = zoltan_global_zz_positions%dim + zoltan_global_ndata_per_det = detector_buffer_size(zoltan_global_ndims, .false.) + ewrite(2,*) "Amount of data to be transferred per detector: ", zoltan_global_ndata_per_det + + head = 1 + do i=1,size(sends) + export_global_ids(head:head + key_count(sends(i)) - 1) = set2vector(sends(i)) + export_procs(head:head + key_count(sends(i)) - 1) = i - 1 + head = head + key_count(sends(i)) + end do + + allocate(export_local_ids(num_export)) + export_local_ids = 666 + + import_global_ids => null() + import_local_ids => null() + import_procs => null() + import_to_part => null() + export_to_part => null() + + ierr = Zoltan_Compute_Destinations(zz, & + & num_export, export_global_ids, export_local_ids, export_procs, & + & num_import, import_global_ids, import_local_ids, import_procs) + assert(ierr == ZOLTAN_OK) + + ! Get all detector lists + call get_registered_detector_lists(detector_list_array) + + ! Log list lengths + if (get_num_detector_lists()>0) then + ewrite(2,*) "Before migrate, we have", get_num_detector_lists(), "detector lists:" + do j = 1, size(detector_list_array) + ewrite(2,*) "Detector list", j, "has", detector_list_array(j)%ptr%length, "local and ", detector_list_array(j)%ptr%total_num_det, "global detectors" + end do + end if + + ierr = Zoltan_Migrate(zz, num_import, import_global_ids, import_local_ids, import_procs, & + & import_to_part, num_export, export_global_ids, export_local_ids, export_procs, export_to_part) + + assert(ierr == ZOLTAN_OK) + + deallocate(export_local_ids) + deallocate(export_procs) + deallocate(export_global_ids) + + deallocate(zoltan_global_ndets_in_ele) + + ! update the local detectors and make sure we didn't miss any in the first send + if (get_num_detector_lists()>0) then + call update_detector_list_element(detector_list_array) + call update_particle_list_element(detector_list_array) + end if + + ! Merge in any detectors we received as part of the transfer to our detector list + detector => zoltan_global_unpacked_detectors_list%first + original_zoltan_global_unpacked_detectors_list_length = zoltan_global_unpacked_detectors_list%length + + do j=1, original_zoltan_global_unpacked_detectors_list_length + add_detector => detector + detector => detector%next + + ! move detector to the correct list + call move(add_detector, zoltan_global_unpacked_detectors_list, detector_list_array(add_detector%list_id)%ptr) + end do + + assert(zoltan_global_unpacked_detectors_list%length==0) + ewrite(2,*) "Merged", original_zoltan_global_unpacked_detectors_list_length, "detectors with local detector lists" + + ! Log list lengths + if (get_num_detector_lists()>0) then + call get_registered_detector_lists(detector_list_array) + ewrite(2,*) "After migrate and merge, we have", get_num_detector_lists(), "detector lists:" + do j = 1, size(detector_list_array) + ewrite(2,*) "Detector list", j, "has", detector_list_array(j)%ptr%length, "local and ", detector_list_array(j)%ptr%total_num_det, "global detectors" + end do + end if + + ierr = Zoltan_LB_Free_Part(import_global_ids, import_local_ids, import_procs, import_to_part) + assert(ierr == ZOLTAN_OK) + + ! for all self-send elements, establish the vertex order in the new element such + ! that it matches the local element ordering of the old element + allocate(vertex_order(1:ele_loc(zoltan_global_new_positions,1), key_count(self_sends))) + do i=1, key_count(self_sends) + old_universal_element_number = fetch(self_sends, i) + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) + ! this function takes the universal node numbers of the old element and the new global (over the local domain) + ! node numbers, to compute the vertex order + vertex_order(:,i) = local_vertex_order( & + halo_universal_number(zoltan_global_zz_halo, ele_nodes(zoltan_global_zz_positions, old_local_element_number)), & + ele_nodes(zoltan_global_new_positions, new_local_element_number)) + end do + + do state_no=1,size(zoltan_global_source_states) + assert(scalar_field_count(zoltan_global_source_states(state_no)) == scalar_field_count(zoltan_global_target_states(state_no))) + assert(vector_field_count(zoltan_global_source_states(state_no)) == vector_field_count(zoltan_global_target_states(state_no))) + assert(tensor_field_count(zoltan_global_source_states(state_no)) == tensor_field_count(zoltan_global_target_states(state_no))) + + do field_no=1,scalar_field_count(zoltan_global_source_states(state_no)) + source_sfield => extract_scalar_field(zoltan_global_source_states(state_no), field_no) + target_sfield => extract_scalar_field(zoltan_global_target_states(state_no), field_no) + assert(trim(source_sfield%name) == trim(target_sfield%name)) + + do i=1,key_count(self_sends) + old_universal_element_number = fetch(self_sends, i) + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) + eshape => ele_shape(target_sfield, new_local_element_number) + nodes => ele_nodes(target_sfield, new_local_element_number) + call set(target_sfield, nodes(ele_local_num(vertex_order(:,i), eshape%numbering)), & + ele_val(source_sfield, old_local_element_number)) + end do + end do + + do field_no=1,vector_field_count(zoltan_global_source_states(state_no)) + source_vfield => extract_vector_field(zoltan_global_source_states(state_no), field_no) + target_vfield => extract_vector_field(zoltan_global_target_states(state_no), field_no) + assert(trim(source_vfield%name) == trim(target_vfield%name)) + if (source_vfield%name == zoltan_global_new_positions%name) cycle + + do i=1,key_count(self_sends) + old_universal_element_number = fetch(self_sends, i) + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) + eshape => ele_shape(target_vfield, new_local_element_number) + nodes => ele_nodes(target_vfield, new_local_element_number) + call set(target_vfield, nodes(ele_local_num(vertex_order(:,i), eshape%numbering)), & + ele_val(source_vfield, old_local_element_number)) + end do + end do + + do field_no=1,tensor_field_count(zoltan_global_source_states(state_no)) + source_tfield => extract_tensor_field(zoltan_global_source_states(state_no), field_no) + target_tfield => extract_tensor_field(zoltan_global_target_states(state_no), field_no) + assert(trim(source_tfield%name) == trim(target_tfield%name)) + + do i=1,key_count(self_sends) + old_universal_element_number = fetch(self_sends, i) + new_local_element_number = fetch(zoltan_global_uen_to_new_local_numbering, old_universal_element_number) + old_local_element_number = fetch(zoltan_global_uen_to_old_local_numbering, old_universal_element_number) + eshape => ele_shape(target_tfield, new_local_element_number) + nodes => ele_nodes(target_tfield, new_local_element_number) + call set(target_tfield, nodes(ele_local_num(vertex_order(:,i), eshape%numbering)), & + ele_val(source_tfield, old_local_element_number)) + end do + end do + end do + + call deallocate(self_sends) + call deallocate(sends) + deallocate(vertex_order) + + call halo_update(zoltan_global_target_states) + + ewrite(1,*) 'exiting transfer_fields' + + end subroutine transfer_fields + + subroutine finalise_transfer(states, metric, full_metric, new_metric) + type(state_type), dimension(:), intent(inout), target :: states + + type(tensor_field), intent(inout), optional :: metric + type(tensor_field), intent(inout), optional :: full_metric + type(tensor_field), intent(in) :: new_metric + + integer :: i + call set_prescribed_field_values(states, exclude_interpolated = .true.) + call populate_boundary_conditions(states) + call set_boundary_conditions_values(states) + call set_dirichlet_consistent(states) + call alias_fields(states) + + if (present(full_metric)) then + full_metric = new_metric + call halo_update(full_metric) + else if (present(metric)) then + metric = new_metric + call halo_update(metric) + end if + + do i=1,size(zoltan_global_source_states) + call deallocate(zoltan_global_source_states(i)) + call deallocate(zoltan_global_target_states(i)) + end do + deallocate(zoltan_global_source_states) + deallocate(zoltan_global_target_states) + end subroutine finalise_transfer + + subroutine dump_linear_mesh + type(scalar_field) :: sends, receives, unn + integer :: i, proc + + assert(associated(zoltan_global_new_positions%refcount)) + assert(zoltan_global_new_positions%refcount%count == 1) + assert(associated(zoltan_global_new_positions%mesh%refcount)) + assert(zoltan_global_new_positions%mesh%refcount%count == 1) + + call allocate(sends, zoltan_global_new_positions%mesh, "Sends") + call zero(sends) + call allocate(receives, zoltan_global_new_positions%mesh, "Receives") + call zero(receives) + call allocate(unn, zoltan_global_new_positions%mesh, "NewUniversalNodeNumber") + call zero(unn) + + do proc=1,halo_proc_count(zoltan_global_new_positions%mesh%halos(2)) + do i=1,size(zoltan_global_new_positions%mesh%halos(2)%sends(proc)%ptr) + call set(sends, zoltan_global_new_positions%mesh%halos(2)%sends(proc)%ptr(i), 1.0) + end do + do i=1,size(zoltan_global_new_positions%mesh%halos(2)%receives(proc)%ptr) + call set(receives, zoltan_global_new_positions%mesh%halos(2)%receives(proc)%ptr(i), 1.0) + end do + end do + + do i=1,node_count(zoltan_global_new_positions) + call set(unn, i, float(halo_universal_number(zoltan_global_new_positions%mesh%halos(2), i))) + end do + + call deallocate(sends) + call deallocate(receives) + call deallocate(unn) + end subroutine dump_linear_mesh + + subroutine dump_suggested_owner(states, p1_num_export, p1_export_local_ids, p1_export_procs) + type(state_type), dimension(:), intent(inout), target :: states + integer(zoltan_int), intent(in) :: p1_num_export + integer, dimension(:), pointer, intent(in) :: p1_export_local_ids, p1_export_procs + + integer :: rank, i + type(scalar_field) :: suggested_owner, unn + type(vector_field) :: positions + + rank = getrank() + call allocate(suggested_owner, zoltan_global_zz_mesh, "SuggestedOwner") + + call set(suggested_owner, float(rank)) + do i=1,p1_num_export + call set(suggested_owner, p1_export_local_ids(i), float(p1_export_procs(i))) + end do + + call allocate(unn, zoltan_global_zz_mesh, "OldUniversalNodeNumber") + do i=1,node_count(unn) + call set(unn, i, float(halo_universal_number(zoltan_global_zz_halo, i))) + end do + + positions = get_coordinate_field(states(1), zoltan_global_zz_mesh) + call halo_update(suggested_owner) + call deallocate(positions) + call deallocate(suggested_owner) + call deallocate(unn) + + end subroutine dump_suggested_owner #endif end module zoltan_integration diff --git a/assemble/qmesh.F90 b/assemble/qmesh.F90 index eb24023223..e6fa3065b5 100644 --- a/assemble/qmesh.F90 +++ b/assemble/qmesh.F90 @@ -29,207 +29,207 @@ module qmesh_module - use fldebug - use spud - use parallel_tools - use fields - use state_module - use vtk_interfaces - use field_derivatives - use form_metric_field - use edge_length_module - use tictoc - use metric_assemble + use fldebug + use spud + use parallel_tools + use fields + use state_module + use vtk_interfaces + use field_derivatives + use form_metric_field + use edge_length_module + use tictoc + use metric_assemble - implicit none + implicit none - private + private - public :: initialise_qmesh, do_adapt_mesh, qmesh, qmesh_module_check_options + public :: initialise_qmesh, do_adapt_mesh, qmesh, qmesh_module_check_options - ! Static variables set by update_adapt_mesh_times and used by do_adapt_mesh - logical, save :: last_times_initialised = .false. - real, save :: last_adapt_mesh_time - real, save :: last_adapt_mesh_cpu_time + ! Static variables set by update_adapt_mesh_times and used by do_adapt_mesh + logical, save :: last_times_initialised = .false. + real, save :: last_adapt_mesh_time + real, save :: last_adapt_mesh_cpu_time contains - subroutine initialise_qmesh - !!< Initialises the qmesh module (setting the last_adapt_mesh_*time - !!< variables) + subroutine initialise_qmesh + !!< Initialises the qmesh module (setting the last_adapt_mesh_*time + !!< variables) - call update_adapt_mesh_times + call update_adapt_mesh_times - end subroutine initialise_qmesh + end subroutine initialise_qmesh - function do_adapt_mesh(current_time, timestep) - !!< Mesh adapt test routine. Tests mesh adapt conditions. Returns true if - !!< these conditions are satisfied and false otherwise. + function do_adapt_mesh(current_time, timestep) + !!< Mesh adapt test routine. Tests mesh adapt conditions. Returns true if + !!< these conditions are satisfied and false otherwise. - real, intent(in) :: current_time - integer, intent(in) :: timestep + real, intent(in) :: current_time + integer, intent(in) :: timestep - logical :: do_adapt_mesh, dump + logical :: do_adapt_mesh, dump - integer :: int_adapt_period, i, stat - real :: real_adapt_period, current_cpu_time + integer :: int_adapt_period, i, stat + real :: real_adapt_period, current_cpu_time - do_adapt_mesh = .false. + do_adapt_mesh = .false. - do i = 1, 4 - select case(i) - case(1) - if(.not. last_times_initialised) then - ! If the last_adapt_mesh*_time variables have not been initialised, assume qmesh should be called - do_adapt_mesh = .true. - exit - end if - case(2) - call get_option("/mesh_adaptivity/hr_adaptivity/period", real_adapt_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_adapt_period == 0.0 .or. adapt_count_greater(current_time, last_adapt_mesh_time, real_adapt_period)) then - do_adapt_mesh = .true. - exit + do i = 1, 4 + select case(i) + case(1) + if(.not. last_times_initialised) then + ! If the last_adapt_mesh*_time variables have not been initialised, assume qmesh should be called + do_adapt_mesh = .true. + exit end if - end if - case(3) - call get_option("/mesh_adaptivity/hr_adaptivity/period_in_timesteps", int_adapt_period, stat) - if(stat == SPUD_NO_ERROR) then - if (int_adapt_period == 0) then - dump = .true. - else if (mod(timestep, int_adapt_period) == 0) then - dump = .true. - else - dump = .false. + case(2) + call get_option("/mesh_adaptivity/hr_adaptivity/period", real_adapt_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_adapt_period == 0.0 .or. adapt_count_greater(current_time, last_adapt_mesh_time, real_adapt_period)) then + do_adapt_mesh = .true. + exit + end if end if - if (dump) then - do_adapt_mesh = .true. - exit + case(3) + call get_option("/mesh_adaptivity/hr_adaptivity/period_in_timesteps", int_adapt_period, stat) + if(stat == SPUD_NO_ERROR) then + if (int_adapt_period == 0) then + dump = .true. + else if (mod(timestep, int_adapt_period) == 0) then + dump = .true. + else + dump = .false. + end if + if (dump) then + do_adapt_mesh = .true. + exit + end if end if - end if - case(4) - call cpu_time(current_cpu_time) - call allmax(current_cpu_time) - call get_option("/mesh_adaptivity/hr_adaptivity/cpu_period", real_adapt_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_adapt_period == 0.0 .or. adapt_count_greater(current_cpu_time, last_adapt_mesh_cpu_time, real_adapt_period)) then - do_adapt_mesh = .true. - exit + case(4) + call cpu_time(current_cpu_time) + call allmax(current_cpu_time) + call get_option("/mesh_adaptivity/hr_adaptivity/cpu_period", real_adapt_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_adapt_period == 0.0 .or. adapt_count_greater(current_cpu_time, last_adapt_mesh_cpu_time, real_adapt_period)) then + do_adapt_mesh = .true. + exit + end if end if - end if - case default - FLAbort("Invalid loop index") - end select - end do + case default + FLAbort("Invalid loop index") + end select + end do - if(do_adapt_mesh) then - ewrite(2, *) "do_adapt_mesh returning .true." - else - ewrite(2, *) "do_adapt_mesh returning .false." - end if + if(do_adapt_mesh) then + ewrite(2, *) "do_adapt_mesh returning .true." + else + ewrite(2, *) "do_adapt_mesh returning .false." + end if - contains + contains - pure function adapt_count_greater(later_time, earlier_time, adapt_period) - !!< Return if the total number of adapts at time later_time is greater - !!< than the total number of adapts at time earlier_time. + pure function adapt_count_greater(later_time, earlier_time, adapt_period) + !!< Return if the total number of adapts at time later_time is greater + !!< than the total number of adapts at time earlier_time. - real, intent(in) :: later_time - real, intent(in) :: earlier_time - real, intent(in) :: adapt_period + real, intent(in) :: later_time + real, intent(in) :: earlier_time + real, intent(in) :: adapt_period - logical :: adapt_count_greater + logical :: adapt_count_greater - adapt_count_greater = (floor(later_time / adapt_period) > floor(earlier_time / adapt_period)) + adapt_count_greater = (floor(later_time / adapt_period) > floor(earlier_time / adapt_period)) - end function adapt_count_greater + end function adapt_count_greater - end function do_adapt_mesh + end function do_adapt_mesh - subroutine update_adapt_mesh_times - !!< Update the last_dump_*time variables. + subroutine update_adapt_mesh_times + !!< Update the last_dump_*time variables. - last_times_initialised = .true. - call get_option("/timestepping/current_time", last_adapt_mesh_time) - call cpu_time(last_adapt_mesh_cpu_time) - call allmax(last_adapt_mesh_cpu_time) + last_times_initialised = .true. + call get_option("/timestepping/current_time", last_adapt_mesh_time) + call cpu_time(last_adapt_mesh_cpu_time) + call allmax(last_adapt_mesh_cpu_time) - end subroutine update_adapt_mesh_times + end subroutine update_adapt_mesh_times - subroutine qmesh(state, metric, remesh) + subroutine qmesh(state, metric, remesh) - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(inout) :: metric - logical, optional, intent(out) :: remesh + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(inout) :: metric + logical, optional, intent(out) :: remesh - logical :: debug_metric - integer, save :: adapt_count = 0 - type(scalar_field) :: edge_len - type(vector_field), pointer :: position_field + logical :: debug_metric + integer, save :: adapt_count = 0 + type(scalar_field) :: edge_len + type(vector_field), pointer :: position_field - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - call tictoc_clear(TICTOC_ID_ASSEMBLE_METRIC) - call tic(TICTOC_ID_ASSEMBLE_METRIC) + call tictoc_clear(TICTOC_ID_ASSEMBLE_METRIC) + call tic(TICTOC_ID_ASSEMBLE_METRIC) - call assemble_metric(state, metric) + call assemble_metric(state, metric) - call toc(TICTOC_ID_ASSEMBLE_METRIC) - call tictoc_report(2, TICTOC_ID_ASSEMBLE_METRIC) + call toc(TICTOC_ID_ASSEMBLE_METRIC) + call tictoc_report(2, TICTOC_ID_ASSEMBLE_METRIC) - if (debug_metric) then - position_field => extract_vector_field(state(1), "Coordinate") + if (debug_metric) then + position_field => extract_vector_field(state(1), "Coordinate") - call allocate(edge_len, metric%mesh, "Desired edge lengths") - call get_edge_lengths(metric, edge_len) - call vtk_write_fields("final_metric", adapt_count, position_field, position_field%mesh, sfields=(/edge_len/), tfields=(/metric/)) - call deallocate(edge_len) + call allocate(edge_len, metric%mesh, "Desired edge lengths") + call get_edge_lengths(metric, edge_len) + call vtk_write_fields("final_metric", adapt_count, position_field, position_field%mesh, sfields=(/edge_len/), tfields=(/metric/)) + call deallocate(edge_len) - adapt_count = adapt_count + 1 - endif + adapt_count = adapt_count + 1 + endif - call update_adapt_mesh_times + call update_adapt_mesh_times - if(present(remesh)) remesh = .true. + if(present(remesh)) remesh = .true. - end subroutine qmesh + end subroutine qmesh - subroutine qmesh_module_check_options - !!< Check mesh timing related options + subroutine qmesh_module_check_options + !!< Check mesh timing related options - integer :: int_adapt_period, stat - real :: real_adapt_period + integer :: int_adapt_period, stat + real :: real_adapt_period - if(.not. have_option("/mesh_adaptivity/hr_adaptivity")) then - ! Nothing to check - return - end if + if(.not. have_option("/mesh_adaptivity/hr_adaptivity")) then + ! Nothing to check + return + end if - ewrite(2, *) "Checking mesh adapt interval options" + ewrite(2, *) "Checking mesh adapt interval options" - call get_option("/mesh_adaptivity/hr_adaptivity/period", real_adapt_period, stat) - if(stat == 0) then - if(real_adapt_period < 0.0) then - FLExit("Adapt period cannot be negative") - end if - else - call get_option("/mesh_adaptivity/hr_adaptivity/period_in_timesteps", int_adapt_period, stat) + call get_option("/mesh_adaptivity/hr_adaptivity/period", real_adapt_period, stat) if(stat == 0) then - if(int_adapt_period < 0) then - FLExit("Adapt period cannot be negative") - end if + if(real_adapt_period < 0.0) then + FLExit("Adapt period cannot be negative") + end if else - FLExit("Adapt period must be specified (in either simulated time or timesteps)") + call get_option("/mesh_adaptivity/hr_adaptivity/period_in_timesteps", int_adapt_period, stat) + if(stat == 0) then + if(int_adapt_period < 0) then + FLExit("Adapt period cannot be negative") + end if + else + FLExit("Adapt period must be specified (in either simulated time or timesteps)") + end if end if - end if - call get_option("/mesh_adaptivity/hr_adaptivity/cpu_dump_period", real_adapt_period, stat) - if(stat == 0 .and. real_adapt_period < 0.0) then - FLExit("CPU adapt period cannot be negative") - end if + call get_option("/mesh_adaptivity/hr_adaptivity/cpu_dump_period", real_adapt_period, stat) + if(stat == 0 .and. real_adapt_period < 0.0) then + FLExit("CPU adapt period cannot be negative") + end if - ewrite(2, *) "Finished checking mesh adapt interval options" + ewrite(2, *) "Finished checking mesh adapt interval options" - end subroutine qmesh_module_check_options + end subroutine qmesh_module_check_options end module qmesh_module diff --git a/assemble/tests/test_adapt_mesh.F90 b/assemble/tests/test_adapt_mesh.F90 index f9f7b7bd88..36b2f65a71 100644 --- a/assemble/tests/test_adapt_mesh.F90 +++ b/assemble/tests/test_adapt_mesh.F90 @@ -29,77 +29,77 @@ subroutine test_adapt_mesh - use fldebug - use adapt_integration - use field_options - use fields - use metric_assemble - use spud - use state_module - use unittest_tools - use vtk_interfaces - use populate_state_module, only: compute_domain_statistics + use fldebug + use adapt_integration + use field_options + use fields + use metric_assemble + use spud + use state_module + use unittest_tools + use vtk_interfaces + use populate_state_module, only: compute_domain_statistics - implicit none + implicit none - type(mesh_type), pointer :: mesh - type(scalar_field) :: pressure - type(state_type) :: state, state_array(1), state_read - type(vector_field) :: output_mesh_field, velocity - type(vector_field), pointer :: input_mesh_field - type(tensor_field) :: metric + type(mesh_type), pointer :: mesh + type(scalar_field) :: pressure + type(state_type) :: state, state_array(1), state_read + type(vector_field) :: output_mesh_field, velocity + type(vector_field), pointer :: input_mesh_field + type(tensor_field) :: metric - integer :: i, stat + integer :: i, stat - call vtk_read_state("data/pseudo2d.vtu", state_read) + call vtk_read_state("data/pseudo2d.vtu", state_read) - input_mesh_field => extract_vector_field(state_read, "Coordinate") + input_mesh_field => extract_vector_field(state_read, "Coordinate") - mesh => input_mesh_field%mesh - mesh%name = "CoordinateMesh" - call add_faces(mesh) + mesh => input_mesh_field%mesh + mesh%name = "CoordinateMesh" + call add_faces(mesh) - call insert(state, mesh, "CoordinateMesh") - call insert(state, input_mesh_field, "Coordinate") + call insert(state, mesh, "CoordinateMesh") + call insert(state, input_mesh_field, "Coordinate") - call deallocate(state_read) + call deallocate(state_read) - mesh => extract_mesh(state, "CoordinateMesh") - input_mesh_field => extract_vector_field(state, "Coordinate") + mesh => extract_mesh(state, "CoordinateMesh") + input_mesh_field => extract_vector_field(state, "Coordinate") - call allocate(pressure, mesh, "Pressure") - call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") + call allocate(pressure, mesh, "Pressure") + call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") - do i = 1, node_count(mesh) - call set(pressure, i, input_mesh_field%val(1,i) ** 2.0) - call set(velocity, i, node_val(input_mesh_field, i)) - end do + do i = 1, node_count(mesh) + call set(pressure, i, input_mesh_field%val(1,i) ** 2.0) + call set(velocity, i, node_val(input_mesh_field, i)) + end do - call adaptivity_options(state, pressure, 1.0, .false.) + call adaptivity_options(state, pressure, 1.0, .false.) - call insert(state, pressure, "Pressure") - call insert(state, velocity, "Velocity") - call deallocate(pressure) - call deallocate(velocity) + call insert(state, pressure, "Pressure") + call insert(state, velocity, "Velocity") + call deallocate(pressure) + call deallocate(velocity) - call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call adaptivity_bounds(state, 0.01, 1.0, name="CoordinateMesh") + call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call adaptivity_bounds(state, 0.01, 1.0, name="CoordinateMesh") - call allocate(metric, mesh, "Metric") - state_array(1) = state - call compute_domain_statistics(state_array) - call assemble_metric(state_array, metric) + call allocate(metric, mesh, "Metric") + state_array(1) = state + call compute_domain_statistics(state_array) + call assemble_metric(state_array, metric) - call adapt_mesh(input_mesh_field, metric, output_mesh_field) - call report_test("[adapt_mesh]", .false., .false., "adapt_mesh failure") + call adapt_mesh(input_mesh_field, metric, output_mesh_field) + call report_test("[adapt_mesh]", .false., .false., "adapt_mesh failure") - call vtk_write_fields("data/test_adapt_mesh_out", position = output_mesh_field, model = output_mesh_field%mesh) + call vtk_write_fields("data/test_adapt_mesh_out", position = output_mesh_field, model = output_mesh_field%mesh) - call deallocate(output_mesh_field) - call deallocate(metric) - call deallocate(state) + call deallocate(output_mesh_field) + call deallocate(metric) + call deallocate(state) - call report_test_no_references() + call report_test_no_references() end subroutine test_adapt_mesh diff --git a/assemble/tests/test_adapt_mesh_mba3d.F90 b/assemble/tests/test_adapt_mesh_mba3d.F90 index 2243caafe3..4ddaadec8f 100644 --- a/assemble/tests/test_adapt_mesh_mba3d.F90 +++ b/assemble/tests/test_adapt_mesh_mba3d.F90 @@ -29,80 +29,80 @@ subroutine test_adapt_mesh_mba3d - use field_options - use fields - use limit_metric_module - use mba3d_integration - use metric_assemble - use mesh_files - use spud - use state_module - use unittest_tools - use vtk_interfaces - - implicit none + use field_options + use fields + use limit_metric_module + use mba3d_integration + use metric_assemble + use mesh_files + use spud + use state_module + use unittest_tools + use vtk_interfaces + + implicit none #ifdef HAVE_MBA_3D - type(mesh_type), pointer :: mesh - type(scalar_field) :: pressure - type(state_type) :: state, state_array(1), state_read - type(vector_field) :: output_mesh_field, velocity - type(vector_field), target :: input_mesh_field - type(tensor_field) :: metric + type(mesh_type), pointer :: mesh + type(scalar_field) :: pressure + type(state_type) :: state, state_array(1), state_read + type(vector_field) :: output_mesh_field, velocity + type(vector_field), target :: input_mesh_field + type(tensor_field) :: metric - integer :: expected_eles, i, stat + integer :: expected_eles, i, stat - input_mesh_field = read_mesh_files("data/cube_unstructured", quad_degree = 1, format="gmsh") + input_mesh_field = read_mesh_files("data/cube_unstructured", quad_degree = 1, format="gmsh") - mesh => input_mesh_field%mesh - mesh%name = "CoordinateMesh" + mesh => input_mesh_field%mesh + mesh%name = "CoordinateMesh" - call insert(state, mesh, "CoordinateMesh") - call insert(state, mesh, "Mesh") - call insert(state, input_mesh_field, "Coordinate") + call insert(state, mesh, "CoordinateMesh") + call insert(state, mesh, "Mesh") + call insert(state, input_mesh_field, "Coordinate") - call deallocate(state_read) + call deallocate(state_read) - mesh => extract_mesh(state, "CoordinateMesh") + mesh => extract_mesh(state, "CoordinateMesh") - call allocate(pressure, mesh, "Pressure") - call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") + call allocate(pressure, mesh, "Pressure") + call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") - do i = 1, node_count(mesh) - call set(pressure, i, input_mesh_field%val(1,i) ** 2.0) - call set(velocity, i, node_val(input_mesh_field, i)) - end do + do i = 1, node_count(mesh) + call set(pressure, i, input_mesh_field%val(1,i) ** 2.0) + call set(velocity, i, node_val(input_mesh_field, i)) + end do - call adaptivity_options(state, pressure, 0.1, .false.) + call adaptivity_options(state, pressure, 0.1, .false.) - call insert(state, pressure, "Pressure") - call insert(state, velocity, "Velocity") - call deallocate(pressure) - call deallocate(velocity) + call insert(state, pressure, "Pressure") + call insert(state, velocity, "Velocity") + call deallocate(pressure) + call deallocate(velocity) - call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call adaptivity_bounds(state, 0.01, 1.0) + call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call adaptivity_bounds(state, 0.01, 1.0) - call allocate(metric, mesh, "Metric") - state_array(1) = state - call assemble_metric(state_array, metric) + call allocate(metric, mesh, "Metric") + state_array(1) = state + call assemble_metric(state_array, metric) - call adapt_mesh_mba3d(input_mesh_field, metric, output_mesh_field) - call report_test("[adapt_mesh_mba3d]", .false., .false., "adapt_mesh_mba3d failure") - expected_eles = expected_elements(input_mesh_field, metric) - call report_test("[expected_elements]", abs(float(ele_count(output_mesh_field) - expected_eles) / float(expected_eles)) > 0.25, .false., "Incorrect output mesh element count") + call adapt_mesh_mba3d(input_mesh_field, metric, output_mesh_field) + call report_test("[adapt_mesh_mba3d]", .false., .false., "adapt_mesh_mba3d failure") + expected_eles = expected_elements(input_mesh_field, metric) + call report_test("[expected_elements]", abs(float(ele_count(output_mesh_field) - expected_eles) / float(expected_eles)) > 0.25, .false., "Incorrect output mesh element count") - call vtk_write_fields("data/test_adapt_mesh_mb3d_out", 0, output_mesh_field, output_mesh_field%mesh) + call vtk_write_fields("data/test_adapt_mesh_mb3d_out", 0, output_mesh_field, output_mesh_field%mesh) - call deallocate(input_mesh_field) - call deallocate(output_mesh_field) - call deallocate(metric) - call deallocate(state) + call deallocate(input_mesh_field) + call deallocate(output_mesh_field) + call deallocate(metric) + call deallocate(state) - call report_test_no_references() + call report_test_no_references() #else - call report_test("[dummy]", .false., .false., "Dummy") + call report_test("[dummy]", .false., .false., "Dummy") #endif end subroutine test_adapt_mesh_mba3d diff --git a/assemble/tests/test_adapt_state_3d.F90 b/assemble/tests/test_adapt_state_3d.F90 index 18b46cd1b3..ddb82a869b 100644 --- a/assemble/tests/test_adapt_state_3d.F90 +++ b/assemble/tests/test_adapt_state_3d.F90 @@ -29,97 +29,97 @@ subroutine test_adapt_state_3d - use fldebug - use adapt_state_module - use field_options - use fields - use metric_assemble - use reserve_state_module - use spud - use state_module - use unittest_tools - use vtk_interfaces - use global_parameters - use populate_state_module, only: compute_domain_statistics + use fldebug + use adapt_state_module + use field_options + use fields + use metric_assemble + use reserve_state_module + use spud + use state_module + use unittest_tools + use vtk_interfaces + use global_parameters + use populate_state_module, only: compute_domain_statistics - implicit none + implicit none - type(mesh_type), pointer :: mesh - type(scalar_field) :: pressure - type(state_type) :: state, state_array(1), state_read - type(vector_field) :: velocity - type(vector_field), pointer :: mesh_field - type(tensor_field) :: metric + type(mesh_type), pointer :: mesh + type(scalar_field) :: pressure + type(state_type) :: state, state_array(1), state_read + type(vector_field) :: velocity + type(vector_field), pointer :: mesh_field + type(tensor_field) :: metric - integer :: i, stat + integer :: i, stat - call vtk_read_state("data/pseudo2d.vtu", state_read) + call vtk_read_state("data/pseudo2d.vtu", state_read) - mesh_field => extract_vector_field(state_read, "Coordinate") + mesh_field => extract_vector_field(state_read, "Coordinate") - mesh => extract_mesh(state_read, "Mesh") - mesh%name = "CoordinateMesh" - mesh%option_path = "/geometry/mesh" - call add_faces(mesh) - mesh_field%mesh = mesh + mesh => extract_mesh(state_read, "Mesh") + mesh%name = "CoordinateMesh" + mesh%option_path = "/geometry/mesh" + call add_faces(mesh) + mesh_field%mesh = mesh - call insert(state, mesh, "CoordinateMesh") - call insert(state, mesh_field, "Coordinate") + call insert(state, mesh, "CoordinateMesh") + call insert(state, mesh_field, "Coordinate") - adaptivity_mesh_name = "CoordinateMesh" - topology_mesh_name = "CoordinateMesh" + adaptivity_mesh_name = "CoordinateMesh" + topology_mesh_name = "CoordinateMesh" - call deallocate(state_read) + call deallocate(state_read) - mesh_field => extract_vector_field(state, "Coordinate") - mesh => extract_mesh(state, "CoordinateMesh") + mesh_field => extract_vector_field(state, "Coordinate") + mesh => extract_mesh(state, "CoordinateMesh") - call allocate(pressure, mesh, "Pressure") - call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") + call allocate(pressure, mesh, "Pressure") + call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") - do i = 1, node_count(mesh) - call set(pressure, i, mesh_field%val(1,i) ** 2.0) - call set(velocity, i, node_val(mesh_field, i)) - end do + do i = 1, node_count(mesh) + call set(pressure, i, mesh_field%val(1,i) ** 2.0) + call set(velocity, i, node_val(mesh_field, i)) + end do - call adaptivity_options(state, pressure, 1.0, .false.) + call adaptivity_options(state, pressure, 1.0, .false.) - call insert(state, pressure, "Pressure") - call insert(state, velocity, "Velocity") - call deallocate(pressure) - call deallocate(velocity) + call insert(state, pressure, "Pressure") + call insert(state, velocity, "Velocity") + call deallocate(pressure) + call deallocate(velocity) - state_array(1) = state - call compute_domain_statistics(state_array) - call create_reserve_state(state_array) + state_array(1) = state + call compute_domain_statistics(state_array) + call create_reserve_state(state_array) - call set_option_attribute("/geometry/mesh/name", "CoordinateMesh", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call add_option("/geometry/mesh/from_file", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) + call set_option_attribute("/geometry/mesh/name", "CoordinateMesh", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call add_option("/geometry/mesh/from_file", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) - call set_option_attribute("/material_phase/name", "MaterialPhase", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) + call set_option_attribute("/material_phase/name", "MaterialPhase", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) - call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) + call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) - call set_option("/geometry/dimension", 3, stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call adaptivity_bounds(state_array(1), 0.01, 1.0, name = "CoordinateMesh") + call set_option("/geometry/dimension", 3, stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call adaptivity_bounds(state_array(1), 0.01, 1.0, name = "CoordinateMesh") - call allocate(metric, mesh, "Metric") - call assemble_metric(state_array, metric) + call allocate(metric, mesh, "Metric") + call assemble_metric(state_array, metric) - call adapt_state(state_array, metric) - call report_test("[adapt_state]", .false., .false., "adapt_state failure") - state = state_array(1) + call adapt_state(state_array, metric) + call report_test("[adapt_state]", .false., .false., "adapt_state failure") + state = state_array(1) - mesh_field => extract_vector_field(state, "Coordinate") - call vtk_write_fields("data/test_adapt_state_3d_out", 0, mesh_field, mesh_field%mesh) + mesh_field => extract_vector_field(state, "Coordinate") + call vtk_write_fields("data/test_adapt_state_3d_out", 0, mesh_field, mesh_field%mesh) - call deallocate(state) + call deallocate(state) - call report_test_no_references() + call report_test_no_references() end subroutine test_adapt_state_3d diff --git a/assemble/tests/test_adapt_state_unittest.F90 b/assemble/tests/test_adapt_state_unittest.F90 index aa47be5763..9f56145259 100644 --- a/assemble/tests/test_adapt_state_unittest.F90 +++ b/assemble/tests/test_adapt_state_unittest.F90 @@ -29,79 +29,79 @@ subroutine test_adapt_state_unittest - use adapt_state_unittest_module - use field_options - use fields - use metric_assemble - use reserve_state_module - use spud - use state_module - use unittest_tools - use vtk_interfaces - use populate_state_module, only: compute_domain_statistics + use adapt_state_unittest_module + use field_options + use fields + use metric_assemble + use reserve_state_module + use spud + use state_module + use unittest_tools + use vtk_interfaces + use populate_state_module, only: compute_domain_statistics - implicit none + implicit none - type(mesh_type), pointer :: mesh - type(scalar_field) :: pressure - type(state_type) :: state, state_array(1), state_read - type(vector_field) :: velocity - type(vector_field), pointer :: mesh_field - type(tensor_field) :: metric + type(mesh_type), pointer :: mesh + type(scalar_field) :: pressure + type(state_type) :: state, state_array(1), state_read + type(vector_field) :: velocity + type(vector_field), pointer :: mesh_field + type(tensor_field) :: metric - integer :: i + integer :: i - call vtk_read_state("data/pseudo2d.vtu", state_read) + call vtk_read_state("data/pseudo2d.vtu", state_read) - mesh_field => extract_vector_field(state_read, "Coordinate") + mesh_field => extract_vector_field(state_read, "Coordinate") - mesh => extract_mesh(state_read, "Mesh") - mesh%name = "CoordinateMesh" - mesh%option_path = "/geometry/mesh" - call add_faces(mesh) - mesh_field%mesh = mesh + mesh => extract_mesh(state_read, "Mesh") + mesh%name = "CoordinateMesh" + mesh%option_path = "/geometry/mesh" + call add_faces(mesh) + mesh_field%mesh = mesh - call insert(state, mesh, "CoordinateMesh") - call insert(state, mesh_field, "Coordinate") + call insert(state, mesh, "CoordinateMesh") + call insert(state, mesh_field, "Coordinate") - call deallocate(state_read) + call deallocate(state_read) - mesh_field => extract_vector_field(state, "Coordinate") - mesh => extract_mesh(state, "CoordinateMesh") + mesh_field => extract_vector_field(state, "Coordinate") + mesh => extract_mesh(state, "CoordinateMesh") - call allocate(pressure, mesh, "Pressure") - call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") + call allocate(pressure, mesh, "Pressure") + call allocate(velocity, mesh_dim(mesh), mesh, "Velocity") - do i = 1, node_count(mesh) - call set(pressure, i, mesh_field%val(1,i) ** 2.0) - call set(velocity, i, node_val(mesh_field, i)) - end do + do i = 1, node_count(mesh) + call set(pressure, i, mesh_field%val(1,i) ** 2.0) + call set(velocity, i, node_val(mesh_field, i)) + end do - call adaptivity_options(state, pressure, 1.0, .false.) + call adaptivity_options(state, pressure, 1.0, .false.) - call insert(state, pressure, "Pressure") - call insert(state, velocity, "Velocity") - call deallocate(pressure) - call deallocate(velocity) + call insert(state, pressure, "Pressure") + call insert(state, velocity, "Velocity") + call deallocate(pressure) + call deallocate(velocity) - state_array(1) = state - call compute_domain_statistics(state_array) + state_array(1) = state + call compute_domain_statistics(state_array) - call adaptivity_bounds(state_array(1), 0.01, 1.0, name = "CoordinateMesh") + call adaptivity_bounds(state_array(1), 0.01, 1.0, name = "CoordinateMesh") - call allocate(metric, mesh, "Metric") - call assemble_metric(state_array, metric) + call allocate(metric, mesh, "Metric") + call assemble_metric(state_array, metric) - call adapt_state_unittest(state_array, metric) - call report_test("[adapt_state_unittest]", .false., .false., "adapt_state_unittest failure") - state = state_array(1) + call adapt_state_unittest(state_array, metric) + call report_test("[adapt_state_unittest]", .false., .false., "adapt_state_unittest failure") + state = state_array(1) - mesh_field => extract_vector_field(state, "Coordinate") - call vtk_write_fields("data/test_adapt_state_unittest_out", 0, mesh_field, mesh_field%mesh) + mesh_field => extract_vector_field(state, "Coordinate") + call vtk_write_fields("data/test_adapt_state_unittest_out", 0, mesh_field, mesh_field%mesh) - call deallocate(state) - call deallocate(metric) + call deallocate(state) + call deallocate(metric) - call report_test_no_references() + call report_test_no_references() end subroutine test_adapt_state_unittest diff --git a/assemble/tests/test_bound_field_p1dg.F90 b/assemble/tests/test_bound_field_p1dg.F90 index 78b2f47b9b..2f832456df 100644 --- a/assemble/tests/test_bound_field_p1dg.F90 +++ b/assemble/tests/test_bound_field_p1dg.F90 @@ -1,58 +1,58 @@ subroutine test_bound_field_p1dg - use populate_state_module - use fields - use state_module - use spud - use state_fields_module - use sparse_tools - use bound_field_module - use vtk_interfaces - use unittest_tools - - implicit none - - type(state_type), dimension(:), pointer :: states - type(scalar_field), pointer :: u, max_bound, min_bound, lumped_mass - type(scalar_field) :: inverse_lumped_mass - type(csr_matrix), pointer :: mass - type(vector_field), pointer :: x - integer :: ele - integer, dimension(:), pointer :: nodes - integer :: node - logical :: fail - - call load_options("data/bound_field.flml") - call populate_state(states) - - u => extract_scalar_field(states(1), "Unbounded") - max_bound => extract_scalar_field(states(1), "MaxBound") - min_bound => extract_scalar_field(states(1), "MinBound") - - do ele=1,ele_count(u) - nodes => ele_nodes(u, ele) - call set(u, nodes(1), 1.2) - end do - - mass => get_mass_matrix(states, u%mesh) - lumped_mass => get_lumped_mass(states, u%mesh) - - call allocate(inverse_lumped_mass, lumped_mass%mesh, "InverseLumpedMass") - inverse_lumped_mass%val = 1.0/lumped_mass%val - - x => extract_vector_field(states(1), "Coordinate") - - call vtk_write_fields("data/bounding", 0, x, u%mesh, sfields=(/u/)) - call bound_field_diffuse(u, max_bound, min_bound, mass, lumped_mass, inverse_lumped_mass) - call vtk_write_fields("data/bounding", 1, x, u%mesh, sfields=(/u/)) - - fail = .false. - do node=1,node_count(u) - if (node_val(u, node) > 1.0) then - fail = .true. - end if - end do - - call report_test("[bound_field_p1dg]", fail, .false., "") + use populate_state_module + use fields + use state_module + use spud + use state_fields_module + use sparse_tools + use bound_field_module + use vtk_interfaces + use unittest_tools + + implicit none + + type(state_type), dimension(:), pointer :: states + type(scalar_field), pointer :: u, max_bound, min_bound, lumped_mass + type(scalar_field) :: inverse_lumped_mass + type(csr_matrix), pointer :: mass + type(vector_field), pointer :: x + integer :: ele + integer, dimension(:), pointer :: nodes + integer :: node + logical :: fail + + call load_options("data/bound_field.flml") + call populate_state(states) + + u => extract_scalar_field(states(1), "Unbounded") + max_bound => extract_scalar_field(states(1), "MaxBound") + min_bound => extract_scalar_field(states(1), "MinBound") + + do ele=1,ele_count(u) + nodes => ele_nodes(u, ele) + call set(u, nodes(1), 1.2) + end do + + mass => get_mass_matrix(states, u%mesh) + lumped_mass => get_lumped_mass(states, u%mesh) + + call allocate(inverse_lumped_mass, lumped_mass%mesh, "InverseLumpedMass") + inverse_lumped_mass%val = 1.0/lumped_mass%val + + x => extract_vector_field(states(1), "Coordinate") + + call vtk_write_fields("data/bounding", 0, x, u%mesh, sfields=(/u/)) + call bound_field_diffuse(u, max_bound, min_bound, mass, lumped_mass, inverse_lumped_mass) + call vtk_write_fields("data/bounding", 1, x, u%mesh, sfields=(/u/)) + + fail = .false. + do node=1,node_count(u) + if (node_val(u, node) > 1.0) then + fail = .true. + end if + end do + + call report_test("[bound_field_p1dg]", fail, .false., "") end subroutine test_bound_field_p1dg diff --git a/assemble/tests/test_cg_interpolation.F90 b/assemble/tests/test_cg_interpolation.F90 index 2f4cb955b0..101e8e0ab7 100644 --- a/assemble/tests/test_cg_interpolation.F90 +++ b/assemble/tests/test_cg_interpolation.F90 @@ -2,61 +2,61 @@ subroutine test_cg_interpolation - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use adapt_state_module - use field_derivatives - use vtk_interfaces - use conservative_interpolation_module - use global_parameters - use interpolation_module - use unittest_tools - implicit none - - type(state_type), dimension(:), pointer :: states_old => null() - type(state_type), dimension(:), pointer :: states_new => null() - type(vector_field), pointer :: x_old, x_new - type(scalar_field), pointer :: intp_old, intp_new - type(state_type), dimension(1) :: interpolation_state_old, interpolation_state_new - logical :: fail - real :: old_integral, new_integral - - call load_options("data/cg_interpolation_A.flml") - call populate_state(states_old) - call clear_options - call load_options("data/cg_interpolation_B.flml") - call populate_state(states_new) - - intp_old => extract_scalar_field(states_old(1), "CgInterpolant") - x_old => extract_vector_field(states_old(1), "Coordinate") - call insert(interpolation_state_old(1), intp_old, "CgInterpolant") - call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") - call insert(interpolation_state_old(1), x_old, "Coordinate") - - intp_new => extract_scalar_field(states_new(1), "CgInterpolant") - x_new => extract_vector_field(states_new(1), "Coordinate") - call insert(interpolation_state_new(1), intp_new, "CgInterpolant") - call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") - call insert(interpolation_state_new(1), x_new, "Coordinate") - - call vtk_write_state("data/cg_interpolation", 0, state=states_old) - - old_integral = field_integral(intp_old, x_old) - - call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new(1)) - call deallocate(interpolation_state_old(1)) - call deallocate(interpolation_state_new(1)) - new_integral = field_integral(intp_new, x_new) - call vtk_write_state("data/cg_interpolation", 1, state=states_new) - - fail = abs(old_integral - new_integral) > epsilon(0.0_4) - call report_test("[cg interpolation: conservative]", fail, .false., "Should be conservative!") - - - call deallocate(states_old(1)) - call deallocate(states_new(1)) + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use adapt_state_module + use field_derivatives + use vtk_interfaces + use conservative_interpolation_module + use global_parameters + use interpolation_module + use unittest_tools + implicit none + + type(state_type), dimension(:), pointer :: states_old => null() + type(state_type), dimension(:), pointer :: states_new => null() + type(vector_field), pointer :: x_old, x_new + type(scalar_field), pointer :: intp_old, intp_new + type(state_type), dimension(1) :: interpolation_state_old, interpolation_state_new + logical :: fail + real :: old_integral, new_integral + + call load_options("data/cg_interpolation_A.flml") + call populate_state(states_old) + call clear_options + call load_options("data/cg_interpolation_B.flml") + call populate_state(states_new) + + intp_old => extract_scalar_field(states_old(1), "CgInterpolant") + x_old => extract_vector_field(states_old(1), "Coordinate") + call insert(interpolation_state_old(1), intp_old, "CgInterpolant") + call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") + call insert(interpolation_state_old(1), x_old, "Coordinate") + + intp_new => extract_scalar_field(states_new(1), "CgInterpolant") + x_new => extract_vector_field(states_new(1), "Coordinate") + call insert(interpolation_state_new(1), intp_new, "CgInterpolant") + call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") + call insert(interpolation_state_new(1), x_new, "Coordinate") + + call vtk_write_state("data/cg_interpolation", 0, state=states_old) + + old_integral = field_integral(intp_old, x_old) + + call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new(1)) + call deallocate(interpolation_state_old(1)) + call deallocate(interpolation_state_new(1)) + new_integral = field_integral(intp_new, x_new) + call vtk_write_state("data/cg_interpolation", 1, state=states_new) + + fail = abs(old_integral - new_integral) > epsilon(0.0_4) + call report_test("[cg interpolation: conservative]", fail, .false., "Should be conservative!") + + + call deallocate(states_old(1)) + call deallocate(states_new(1)) end subroutine test_cg_interpolation diff --git a/assemble/tests/test_dg_diffusion.F90 b/assemble/tests/test_dg_diffusion.F90 index e5eef3bb35..b641477e7e 100644 --- a/assemble/tests/test_dg_diffusion.F90 +++ b/assemble/tests/test_dg_diffusion.F90 @@ -1,37 +1,37 @@ subroutine test_dg_diffusion - use spud - use populate_state_module - use global_parameters - use state_module - use unittest_tools - use vtk_interfaces - use advection_diffusion_dg - use sparsity_patterns - implicit none + use spud + use populate_state_module + use global_parameters + use state_module + use unittest_tools + use vtk_interfaces + use advection_diffusion_dg + use sparsity_patterns + implicit none - type(state_type), dimension(:), pointer :: states => null() + type(state_type), dimension(:), pointer :: states => null() - type(csr_matrix) :: big_m, mass - type(csr_sparsity) :: sparsity - type(scalar_field) :: rhs, tracer + type(csr_matrix) :: big_m, mass + type(csr_sparsity) :: sparsity + type(scalar_field) :: rhs, tracer - call load_options("test_dg_diffusion_1d.flml") - call populate_state(states) - call allocate_and_insert_auxilliary_fields(states) + call load_options("test_dg_diffusion_1d.flml") + call populate_state(states) + call allocate_and_insert_auxilliary_fields(states) - tracer = extract_scalar_field(states(1), "Tracer") + tracer = extract_scalar_field(states(1), "Tracer") - call allocate(rhs, tracer%mesh, "RHS") + call allocate(rhs, tracer%mesh, "RHS") - sparsity = make_sparsity_transpose(tracer%mesh, tracer%mesh, "Sparsity") + sparsity = make_sparsity_transpose(tracer%mesh, tracer%mesh, "Sparsity") - call allocate(big_m, sparsity, name="Big_m") - call allocate(mass, sparsity, name="Mass") + call allocate(big_m, sparsity, name="Big_m") + call allocate(mass, sparsity, name="Mass") - call construct_advection_diffusion_dg(big_m, rhs, "Tracer",& - & states(1), mass) + call construct_advection_diffusion_dg(big_m, rhs, "Tracer",& + & states(1), mass) - call mmwrite("diffusion.mm", big_m) - call mmwrite("mass.mm", mass) + call mmwrite("diffusion.mm", big_m) + call mmwrite("mass.mm", mass) end subroutine test_dg_diffusion diff --git a/assemble/tests/test_dg_interpolation.F90 b/assemble/tests/test_dg_interpolation.F90 index 9c3559e1e6..916b369905 100644 --- a/assemble/tests/test_dg_interpolation.F90 +++ b/assemble/tests/test_dg_interpolation.F90 @@ -2,75 +2,75 @@ subroutine test_dg_interpolation - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use adapt_state_module - use field_derivatives - use vtk_interfaces - use conservative_interpolation_module - use global_parameters - use interpolation_module - use unittest_tools - use slope_limiters_dg - implicit none + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use adapt_state_module + use field_derivatives + use vtk_interfaces + use conservative_interpolation_module + use global_parameters + use interpolation_module + use unittest_tools + use slope_limiters_dg + implicit none - type(state_type), dimension(:), pointer :: states_old => null() - type(state_type), dimension(:), pointer :: states_new => null() - type(vector_field), pointer :: x_old, x_new - type(scalar_field), pointer :: intp_old, intp_new - type(state_type), dimension(1) :: interpolation_state_old, interpolation_state_new - logical :: fail - real :: old_integral, new_integral - integer :: stat + type(state_type), dimension(:), pointer :: states_old => null() + type(state_type), dimension(:), pointer :: states_new => null() + type(vector_field), pointer :: x_old, x_new + type(scalar_field), pointer :: intp_old, intp_new + type(state_type), dimension(1) :: interpolation_state_old, interpolation_state_new + logical :: fail + real :: old_integral, new_integral + integer :: stat - call load_options("data/dg_interpolation_A.flml") - call populate_state(states_old) - call clear_options - call load_options("data/dg_interpolation_B.flml") - call populate_state(states_new) + call load_options("data/dg_interpolation_A.flml") + call populate_state(states_old) + call clear_options + call load_options("data/dg_interpolation_B.flml") + call populate_state(states_new) - intp_old => extract_scalar_field(states_old(1), "DgInterpolant") - x_old => extract_vector_field(states_old(1), "Coordinate") - call insert(interpolation_state_old(1), intp_old, "DgInterpolant") - call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") - call insert(interpolation_state_old(1), x_old, "Coordinate") + intp_old => extract_scalar_field(states_old(1), "DgInterpolant") + x_old => extract_vector_field(states_old(1), "Coordinate") + call insert(interpolation_state_old(1), intp_old, "DgInterpolant") + call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") + call insert(interpolation_state_old(1), x_old, "Coordinate") - intp_new => extract_scalar_field(states_new(1), "DgInterpolant") - x_new => extract_vector_field(states_new(1), "Coordinate") - call insert(interpolation_state_new(1), intp_new, "DgInterpolant") - call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") - call insert(interpolation_state_new(1), x_new, "Coordinate") + intp_new => extract_scalar_field(states_new(1), "DgInterpolant") + x_new => extract_vector_field(states_new(1), "Coordinate") + call insert(interpolation_state_new(1), intp_new, "DgInterpolant") + call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") + call insert(interpolation_state_new(1), x_new, "Coordinate") - call vtk_write_state("data/dg_interpolation", 0, state=states_old) + call vtk_write_state("data/dg_interpolation", 0, state=states_old) - old_integral = field_integral(intp_old, x_old) + old_integral = field_integral(intp_old, x_old) - call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new(1)) - call set_option(trim(intp_new%option_path)//"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Cockburn_Shu/TVB_factor", & - &5.0,stat=stat) + call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new(1)) + call set_option(trim(intp_new%option_path)//"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Cockburn_Shu/TVB_factor", & + &5.0,stat=stat) - call set_option(trim(intp_new%option_path)// & - &"/prognostic/spatial_discretisation/& - &discontinuous_galerkin/slope_limiter::Cockburn_Shu/limit_factor", & - &1.1,stat=stat) + call set_option(trim(intp_new%option_path)// & + &"/prognostic/spatial_discretisation/& + &discontinuous_galerkin/slope_limiter::Cockburn_Shu/limit_factor", & + &1.1,stat=stat) ! call limit_slope_dg(inTp_new, dummy_vfield, & ! & X_new, states_new(1), limiter=LIMITER_COCKBURN) - call deallocate(interpolation_state_old(1)) - call deallocate(interpolation_state_new(1)) - new_integral = field_integral(intp_new, x_new) - call vtk_write_state("data/dg_interpolation", 1, state=states_new) + call deallocate(interpolation_state_old(1)) + call deallocate(interpolation_state_new(1)) + new_integral = field_integral(intp_new, x_new) + call vtk_write_state("data/dg_interpolation", 1, state=states_new) - fail = abs(old_integral - new_integral) > epsilon(0.0_4) - call report_test("[dg interpolation: conservative]", fail, .false., "Should be conservative!") + fail = abs(old_integral - new_integral) > epsilon(0.0_4) + call report_test("[dg interpolation: conservative]", fail, .false., "Should be conservative!") - call deallocate(states_old(1)) - call deallocate(states_new(1)) + call deallocate(states_old(1)) + call deallocate(states_new(1)) end subroutine test_dg_interpolation diff --git a/assemble/tests/test_dg_interpolation_quads.F90 b/assemble/tests/test_dg_interpolation_quads.F90 index 374470713b..0224e63baa 100644 --- a/assemble/tests/test_dg_interpolation_quads.F90 +++ b/assemble/tests/test_dg_interpolation_quads.F90 @@ -2,64 +2,64 @@ subroutine test_dg_interpolation_quads - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use adapt_state_module - use field_derivatives - use vtk_interfaces - use conservative_interpolation_module - use global_parameters - use interpolation_module - use unittest_tools - implicit none + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use adapt_state_module + use field_derivatives + use vtk_interfaces + use conservative_interpolation_module + use global_parameters + use interpolation_module + use unittest_tools + implicit none - type(state_type), dimension(:), pointer :: states_old => null() - type(state_type), dimension(:), pointer :: states_new => null() - type(vector_field), pointer :: x_old, x_new - type(scalar_field), pointer :: intp_old, intp_new - type(state_type), dimension(1) :: interpolation_state_old, interpolation_state_new - logical :: fail - real :: old_integral, new_integral + type(state_type), dimension(:), pointer :: states_old => null() + type(state_type), dimension(:), pointer :: states_new => null() + type(vector_field), pointer :: x_old, x_new + type(scalar_field), pointer :: intp_old, intp_new + type(state_type), dimension(1) :: interpolation_state_old, interpolation_state_new + logical :: fail + real :: old_integral, new_integral - call load_options("data/dg_interpolation_quads_A.flml") - call populate_state(states_old) - call clear_options - call load_options("data/dg_interpolation_quads_B.flml") - call populate_state(states_new) + call load_options("data/dg_interpolation_quads_A.flml") + call populate_state(states_old) + call clear_options + call load_options("data/dg_interpolation_quads_B.flml") + call populate_state(states_new) - intp_old => extract_scalar_field(states_old(1), "DgInterpolant") - x_old => extract_vector_field(states_old(1), "Coordinate") - call insert(interpolation_state_old(1), intp_old, "DgInterpolant") - call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") - call insert(interpolation_state_old(1), x_old, "Coordinate") + intp_old => extract_scalar_field(states_old(1), "DgInterpolant") + x_old => extract_vector_field(states_old(1), "Coordinate") + call insert(interpolation_state_old(1), intp_old, "DgInterpolant") + call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") + call insert(interpolation_state_old(1), x_old, "Coordinate") - intp_new => extract_scalar_field(states_new(1), "DgInterpolant") - x_new => extract_vector_field(states_new(1), "Coordinate") - call insert(interpolation_state_new(1), intp_new, "DgInterpolant") - call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") - call insert(interpolation_state_new(1), x_new, "Coordinate") + intp_new => extract_scalar_field(states_new(1), "DgInterpolant") + x_new => extract_vector_field(states_new(1), "Coordinate") + call insert(interpolation_state_new(1), intp_new, "DgInterpolant") + call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") + call insert(interpolation_state_new(1), x_new, "Coordinate") - call vtk_write_state("data/dg_interpolation_quads", 0, state=states_old) + call vtk_write_state("data/dg_interpolation_quads", 0, state=states_old) - old_integral = field_integral(intp_old, x_old) + old_integral = field_integral(intp_old, x_old) - call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new(1)) - call deallocate(interpolation_state_old(1)) - call deallocate(interpolation_state_new(1)) - new_integral = field_integral(intp_new, x_new) - call vtk_write_state("data/dg_interpolation_quads", 1, state=states_new) + call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new(1)) + call deallocate(interpolation_state_old(1)) + call deallocate(interpolation_state_new(1)) + new_integral = field_integral(intp_new, x_new) + call vtk_write_state("data/dg_interpolation_quads", 1, state=states_new) - write(0,*) "old_integral: ", old_integral - write(0,*) "new_integral: ", new_integral + write(0,*) "old_integral: ", old_integral + write(0,*) "new_integral: ", new_integral - fail = abs(old_integral - new_integral) > epsilon(0.0_4) - call report_test("[dg interpolation: conservative]", fail, .false., "Should be conservative!") + fail = abs(old_integral - new_integral) > epsilon(0.0_4) + call report_test("[dg interpolation: conservative]", fail, .false., "Should be conservative!") - call deallocate(states_old(1)) - call deallocate(states_new(1)) + call deallocate(states_old(1)) + call deallocate(states_new(1)) end subroutine test_dg_interpolation_quads diff --git a/assemble/tests/test_dg_interpolation_sa.F90 b/assemble/tests/test_dg_interpolation_sa.F90 index 07c0dfe5b0..cf4f850b94 100644 --- a/assemble/tests/test_dg_interpolation_sa.F90 +++ b/assemble/tests/test_dg_interpolation_sa.F90 @@ -2,79 +2,79 @@ subroutine test_dg_interpolation_sa - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use field_derivatives - use conservative_interpolation_module - use interpolation_module - use supermesh_assembly - use unittest_tools - - implicit none - - integer :: i - logical :: fail - real :: old_integral, new_integral - type(state_type), dimension(:), pointer :: states_old, states_new, & - & states_new_2 - type(vector_field), pointer :: x_old, x_new - type(scalar_field), pointer :: intp_old, intp_new, intp_new_2 - type(state_type), dimension(1) :: interpolation_state_old, & - & interpolation_state_new, interpolation_state_new_2 - - call load_options("data/dg_interpolation_A.flml") - call populate_state(states_old) - call clear_options() - call load_options("data/dg_interpolation_B.flml") - call populate_state(states_new) - call populate_state(states_new_2) - call clear_options() - - intp_old => extract_scalar_field(states_old(1), "DgInterpolant") - x_old => extract_vector_field(states_old(1), "Coordinate") - call insert(interpolation_state_old(1), intp_old, "DgInterpolant") - call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") - call insert(interpolation_state_old(1), x_old, "Coordinate") - - intp_new => extract_scalar_field(states_new(1), "DgInterpolant") - x_new => extract_vector_field(states_new(1), "Coordinate") - call insert(interpolation_state_new(1), intp_new, "DgInterpolant") - call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") - call insert(interpolation_state_new(1), x_new, "Coordinate") - - intp_new_2 => extract_scalar_field(states_new(1), "DgInterpolant") - call insert(interpolation_state_new_2(1), intp_new_2, "DgInterpolant") - call insert(interpolation_state_new_2(1), intp_new_2%mesh, "Mesh") - call insert(interpolation_state_new_2(1), x_new, "Coordinate") - - old_integral = field_integral(intp_old, x_old) - - call galerkin_projection_scalars(interpolation_state_old, x_old, interpolation_state_new, x_new) - call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new_2(1)) - call deallocate(interpolation_state_old(1)) - call deallocate(interpolation_state_new(1)) - call deallocate(interpolation_state_new_2(1)) - - new_integral = field_integral(intp_new, x_new) - - call report_test("[Same result as interpolation_galerkin]", intp_new%val .fne. intp_new_2%val, .false., "Result differs from that returned by interpolation_galerkin") - - fail = abs(old_integral - new_integral) > epsilon(0.0_4) - call report_test("[dg interpolation: conservative]", fail, .false., "Should be conservative!") - - do i = 1, size(states_old) - call deallocate(states_old(i)) - call deallocate(states_new(i)) - call deallocate(states_new_2(i)) - end do - deallocate(states_old) - deallocate(states_new) - deallocate(states_new_2) - - call report_test_no_references() + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use field_derivatives + use conservative_interpolation_module + use interpolation_module + use supermesh_assembly + use unittest_tools + + implicit none + + integer :: i + logical :: fail + real :: old_integral, new_integral + type(state_type), dimension(:), pointer :: states_old, states_new, & + & states_new_2 + type(vector_field), pointer :: x_old, x_new + type(scalar_field), pointer :: intp_old, intp_new, intp_new_2 + type(state_type), dimension(1) :: interpolation_state_old, & + & interpolation_state_new, interpolation_state_new_2 + + call load_options("data/dg_interpolation_A.flml") + call populate_state(states_old) + call clear_options() + call load_options("data/dg_interpolation_B.flml") + call populate_state(states_new) + call populate_state(states_new_2) + call clear_options() + + intp_old => extract_scalar_field(states_old(1), "DgInterpolant") + x_old => extract_vector_field(states_old(1), "Coordinate") + call insert(interpolation_state_old(1), intp_old, "DgInterpolant") + call insert(interpolation_state_old(1), intp_old%mesh, "Mesh") + call insert(interpolation_state_old(1), x_old, "Coordinate") + + intp_new => extract_scalar_field(states_new(1), "DgInterpolant") + x_new => extract_vector_field(states_new(1), "Coordinate") + call insert(interpolation_state_new(1), intp_new, "DgInterpolant") + call insert(interpolation_state_new(1), intp_new%mesh, "Mesh") + call insert(interpolation_state_new(1), x_new, "Coordinate") + + intp_new_2 => extract_scalar_field(states_new(1), "DgInterpolant") + call insert(interpolation_state_new_2(1), intp_new_2, "DgInterpolant") + call insert(interpolation_state_new_2(1), intp_new_2%mesh, "Mesh") + call insert(interpolation_state_new_2(1), x_new, "Coordinate") + + old_integral = field_integral(intp_old, x_old) + + call galerkin_projection_scalars(interpolation_state_old, x_old, interpolation_state_new, x_new) + call interpolation_galerkin(interpolation_state_old(1), interpolation_state_new_2(1)) + call deallocate(interpolation_state_old(1)) + call deallocate(interpolation_state_new(1)) + call deallocate(interpolation_state_new_2(1)) + + new_integral = field_integral(intp_new, x_new) + + call report_test("[Same result as interpolation_galerkin]", intp_new%val .fne. intp_new_2%val, .false., "Result differs from that returned by interpolation_galerkin") + + fail = abs(old_integral - new_integral) > epsilon(0.0_4) + call report_test("[dg interpolation: conservative]", fail, .false., "Should be conservative!") + + do i = 1, size(states_old) + call deallocate(states_old(i)) + call deallocate(states_new(i)) + call deallocate(states_new_2(i)) + end do + deallocate(states_old) + deallocate(states_new) + deallocate(states_new_2) + + call report_test_no_references() end subroutine test_dg_interpolation_sa diff --git a/assemble/tests/test_empty_populate_state.F90 b/assemble/tests/test_empty_populate_state.F90 index 312b2da6a1..159d6005f6 100644 --- a/assemble/tests/test_empty_populate_state.F90 +++ b/assemble/tests/test_empty_populate_state.F90 @@ -1,27 +1,27 @@ subroutine test_empty_populate_state - use spud - use populate_state_module - use global_parameters - use state_module - use unittest_tools - use vtk_interfaces - implicit none + use spud + use populate_state_module + use global_parameters + use state_module + use unittest_tools + use vtk_interfaces + implicit none - type(state_type), dimension(:), pointer :: states => null() - logical :: fail + type(state_type), dimension(:), pointer :: states => null() + logical :: fail - is_active_process = .false. - no_active_processes = 0 - call load_options("data/empty-mesh.flml") - call populate_state(states) + is_active_process = .false. + no_active_processes = 0 + call load_options("data/empty-mesh.flml") + call populate_state(states) - call report_test("[empty populate state]", .false., .false., "Crashing is failing") + call report_test("[empty populate state]", .false., .false., "Crashing is failing") - fail = (scalar_field_count(states(1)) == 0) - call report_test("[empty populate state]", fail, .false., "Should have scalar fields") + fail = (scalar_field_count(states(1)) == 0) + call report_test("[empty populate state]", fail, .false., "Should have scalar fields") - fail = (vector_field_count(states(1)) == 0) - call report_test("[empty populate state]", fail, .false., "Should have vector fields") + fail = (vector_field_count(states(1)) == 0) + call report_test("[empty populate state]", fail, .false., "Should have vector fields") - call vtk_write_state("data/empty_populate_state", state=states) + call vtk_write_state("data/empty_populate_state", state=states) end subroutine test_empty_populate_state diff --git a/assemble/tests/test_geostrophic_pressure.F90 b/assemble/tests/test_geostrophic_pressure.F90 index 30873216fe..8b3ff7c625 100644 --- a/assemble/tests/test_geostrophic_pressure.F90 +++ b/assemble/tests/test_geostrophic_pressure.F90 @@ -29,133 +29,133 @@ subroutine test_geostrophic_pressure - use field_options - use elements - use fields - use fldebug - use geostrophic_pressure - use solvers - use spud - use state_module - use unittest_tools - use vtk_interfaces - - implicit none - - integer :: i, stat - logical :: fail - real :: gp_zero_point, y_zero_point, z_zero_point - real, dimension(:), allocatable :: pos - type(element_type) :: gp_shape - type(mesh_type) :: gp_mesh - type(mesh_type), pointer :: mesh - type(scalar_field) :: gp, buoyancy - type(state_type) :: state - type(vector_field) :: gravity_direction, positions_remap, velocity - type(vector_field), pointer :: positions - - call vtk_read_state("data/pseudo2d.vtu", state) - - positions => extract_vector_field(state, "Coordinate") - mesh => positions%mesh - ! 3D test - assert(mesh_dim(mesh) == 3) - call set_option("/geometry/dimension", 3, stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - - allocate(pos(positions%dim)) - - gp_shape = make_element_shape(ele_shape(mesh, 1), degree = 2) - gp_mesh = make_mesh(mesh, shape = gp_shape) - call deallocate(gp_shape) - call allocate(gp, gp_mesh, gp_name) - call deallocate(gp_mesh) - call zero(gp) - call set_solver_options(gp, ksptype = "cg", pctype = "mg", atol = epsilon(0.0), rtol = 0.0, max_its = 2000, start_from_zero = .false.) - call insert(state, gp, gp%name) - - ! Hydrostatic balance - call allocate(buoyancy, mesh, "VelocityBuoyancyDensity", field_type = FIELD_TYPE_CONSTANT) - call set(buoyancy, 1.0) - call insert(state, buoyancy, buoyancy%name) - call deallocate(buoyancy) - - call set_option("/physical_parameters/gravity/magnitude", 1.0, stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - - call allocate(gravity_direction, mesh_dim(mesh), mesh, "GravityDirection", field_type = FIELD_TYPE_CONSTANT) - call set(gravity_direction, (/0.0, 0.0, 1.0/)) - call insert(state, gravity_direction, gravity_direction%name) - call deallocate(gravity_direction) - - call calculate_geostrophic_pressure(state, gp, & - & assemble_matrix = .true., include_buoyancy = .true., include_coriolis = .false., reference_node = 1) - - call allocate(positions_remap, positions%dim, gp%mesh, "Positions") - call remap_field(positions, positions_remap) - - fail = .false. - gp_zero_point = minval(gp%val) - z_zero_point = minval(positions_remap%val(3,:)) - do i = 1, node_count(gp) - pos = node_val(positions_remap, i) - if(fnequals(node_val(gp, i) - gp_zero_point, pos(3) - z_zero_point, tol = 1.0e-10)) then - ewrite(-1, *) "Error: ", abs((node_val(gp, i) - gp_zero_point) - (pos(3) - z_zero_point)) - fail = .true. - exit - end if - end do - call report_test("[Hydrostatic balance]", fail, .false., "Incorrect solution") - - ! Geostrophic balance - call set_option("/physical_parameters/coriolis/f_plane/f", 1.0, stat) - assert(stat == SPUD_NEW_KEY_WARNING) - - call allocate(velocity, mesh_dim(mesh), mesh, "Velocity", field_type = FIELD_TYPE_CONSTANT) - call set(velocity, (/-1.0, 0.0, 0.0/)) - call insert(state, velocity, velocity%name) - call insert(state, velocity%mesh, trim(velocity%name) // "Mesh") - call deallocate(velocity) - - call calculate_geostrophic_pressure(state, gp, & - & velocity_name = velocity%name, assemble_matrix = .false., include_buoyancy = .false., include_coriolis = .true.) - - fail = .false. - gp_zero_point = minval(gp%val) - y_zero_point = minval(positions_remap%val(2,:)) - do i = 1, node_count(gp) - pos = node_val(positions_remap, i) - if(fnequals(node_val(gp, i) - gp_zero_point, pos(2) - y_zero_point, tol = 1.0e-10)) then - ewrite(-1, *) "Error: ", abs((node_val(gp, i) - gp_zero_point) - (pos(2) - y_zero_point)) - fail = .true. - exit - end if - end do - call report_test("[Geostrophic balance]", fail, .false., "Incorrect solution") - - ! Thermal wind balance - call calculate_geostrophic_pressure(state, gp, & - & velocity_name = velocity%name, assemble_matrix = .false., include_buoyancy = .true., include_coriolis = .true.) - - fail = .false. - gp_zero_point = minval(gp%val) - y_zero_point = minval(positions_remap%val(2,:)) - do i = 1, node_count(gp) - pos = node_val(positions_remap, i) - if(fnequals(node_val(gp, i) - gp_zero_point, (pos(2) - y_zero_point) + (pos(3) - z_zero_point), tol = 1.0e-10)) then - ewrite(-1, *) "Error: ", abs((node_val(gp, i) - gp_zero_point) - ((pos(2) - y_zero_point) + (pos(3) - z_zero_point))) - fail = .true. - exit - end if - end do - call report_test("[Thermal wind balance]", fail, .false., "Incorrect solution") - - call deallocate(positions_remap) - - call deallocate(gp) - call deallocate(state) - deallocate(pos) - - call report_test_no_references() + use field_options + use elements + use fields + use fldebug + use geostrophic_pressure + use solvers + use spud + use state_module + use unittest_tools + use vtk_interfaces + + implicit none + + integer :: i, stat + logical :: fail + real :: gp_zero_point, y_zero_point, z_zero_point + real, dimension(:), allocatable :: pos + type(element_type) :: gp_shape + type(mesh_type) :: gp_mesh + type(mesh_type), pointer :: mesh + type(scalar_field) :: gp, buoyancy + type(state_type) :: state + type(vector_field) :: gravity_direction, positions_remap, velocity + type(vector_field), pointer :: positions + + call vtk_read_state("data/pseudo2d.vtu", state) + + positions => extract_vector_field(state, "Coordinate") + mesh => positions%mesh + ! 3D test + assert(mesh_dim(mesh) == 3) + call set_option("/geometry/dimension", 3, stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + + allocate(pos(positions%dim)) + + gp_shape = make_element_shape(ele_shape(mesh, 1), degree = 2) + gp_mesh = make_mesh(mesh, shape = gp_shape) + call deallocate(gp_shape) + call allocate(gp, gp_mesh, gp_name) + call deallocate(gp_mesh) + call zero(gp) + call set_solver_options(gp, ksptype = "cg", pctype = "mg", atol = epsilon(0.0), rtol = 0.0, max_its = 2000, start_from_zero = .false.) + call insert(state, gp, gp%name) + + ! Hydrostatic balance + call allocate(buoyancy, mesh, "VelocityBuoyancyDensity", field_type = FIELD_TYPE_CONSTANT) + call set(buoyancy, 1.0) + call insert(state, buoyancy, buoyancy%name) + call deallocate(buoyancy) + + call set_option("/physical_parameters/gravity/magnitude", 1.0, stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + + call allocate(gravity_direction, mesh_dim(mesh), mesh, "GravityDirection", field_type = FIELD_TYPE_CONSTANT) + call set(gravity_direction, (/0.0, 0.0, 1.0/)) + call insert(state, gravity_direction, gravity_direction%name) + call deallocate(gravity_direction) + + call calculate_geostrophic_pressure(state, gp, & + & assemble_matrix = .true., include_buoyancy = .true., include_coriolis = .false., reference_node = 1) + + call allocate(positions_remap, positions%dim, gp%mesh, "Positions") + call remap_field(positions, positions_remap) + + fail = .false. + gp_zero_point = minval(gp%val) + z_zero_point = minval(positions_remap%val(3,:)) + do i = 1, node_count(gp) + pos = node_val(positions_remap, i) + if(fnequals(node_val(gp, i) - gp_zero_point, pos(3) - z_zero_point, tol = 1.0e-10)) then + ewrite(-1, *) "Error: ", abs((node_val(gp, i) - gp_zero_point) - (pos(3) - z_zero_point)) + fail = .true. + exit + end if + end do + call report_test("[Hydrostatic balance]", fail, .false., "Incorrect solution") + + ! Geostrophic balance + call set_option("/physical_parameters/coriolis/f_plane/f", 1.0, stat) + assert(stat == SPUD_NEW_KEY_WARNING) + + call allocate(velocity, mesh_dim(mesh), mesh, "Velocity", field_type = FIELD_TYPE_CONSTANT) + call set(velocity, (/-1.0, 0.0, 0.0/)) + call insert(state, velocity, velocity%name) + call insert(state, velocity%mesh, trim(velocity%name) // "Mesh") + call deallocate(velocity) + + call calculate_geostrophic_pressure(state, gp, & + & velocity_name = velocity%name, assemble_matrix = .false., include_buoyancy = .false., include_coriolis = .true.) + + fail = .false. + gp_zero_point = minval(gp%val) + y_zero_point = minval(positions_remap%val(2,:)) + do i = 1, node_count(gp) + pos = node_val(positions_remap, i) + if(fnequals(node_val(gp, i) - gp_zero_point, pos(2) - y_zero_point, tol = 1.0e-10)) then + ewrite(-1, *) "Error: ", abs((node_val(gp, i) - gp_zero_point) - (pos(2) - y_zero_point)) + fail = .true. + exit + end if + end do + call report_test("[Geostrophic balance]", fail, .false., "Incorrect solution") + + ! Thermal wind balance + call calculate_geostrophic_pressure(state, gp, & + & velocity_name = velocity%name, assemble_matrix = .false., include_buoyancy = .true., include_coriolis = .true.) + + fail = .false. + gp_zero_point = minval(gp%val) + y_zero_point = minval(positions_remap%val(2,:)) + do i = 1, node_count(gp) + pos = node_val(positions_remap, i) + if(fnequals(node_val(gp, i) - gp_zero_point, (pos(2) - y_zero_point) + (pos(3) - z_zero_point), tol = 1.0e-10)) then + ewrite(-1, *) "Error: ", abs((node_val(gp, i) - gp_zero_point) - ((pos(2) - y_zero_point) + (pos(3) - z_zero_point))) + fail = .true. + exit + end if + end do + call report_test("[Thermal wind balance]", fail, .false., "Incorrect solution") + + call deallocate(positions_remap) + + call deallocate(gp) + call deallocate(state) + deallocate(pos) + + call report_test_no_references() end subroutine test_geostrophic_pressure diff --git a/assemble/tests/test_lagrangian_remap.F90 b/assemble/tests/test_lagrangian_remap.F90 index 6da422aa75..99723a4b65 100644 --- a/assemble/tests/test_lagrangian_remap.F90 +++ b/assemble/tests/test_lagrangian_remap.F90 @@ -1,50 +1,50 @@ subroutine test_lagrangian_remap - use lagrangian_remap - use fields - use spud - use populate_state_module - use vtk_interfaces - use state_module - use solvers + use lagrangian_remap + use fields + use spud + use populate_state_module + use vtk_interfaces + use state_module + use solvers - implicit none + implicit none - type(state_type), dimension(:), pointer :: states - type(vector_field), pointer :: velocity, coordinate - type(scalar_field), dimension(1) :: new_fields, old_fields - real :: dt - integer :: i + type(state_type), dimension(:), pointer :: states + type(vector_field), pointer :: velocity, coordinate + type(scalar_field), dimension(1) :: new_fields, old_fields + real :: dt + integer :: i - call load_options("data/explicit-hyperc-shear-input.flml") - call populate_state(states) + call load_options("data/explicit-hyperc-shear-input.flml") + call populate_state(states) - call get_option("/timestepping/timestep", dt) + call get_option("/timestepping/timestep", dt) - velocity => extract_vector_field(states(1), "Velocity") - coordinate => extract_vector_field(states(1), "Coordinate") + velocity => extract_vector_field(states(1), "Velocity") + coordinate => extract_vector_field(states(1), "Coordinate") - old_fields(1) = extract_scalar_field(states(1), "MaterialVolumeFraction") + old_fields(1) = extract_scalar_field(states(1), "MaterialVolumeFraction") - call allocate(new_fields(1), old_fields(1)%mesh, name="NewMaterialVolumeFraction") - new_fields(1)%option_path = "/field/prognostic/galerkin_projection/continuous" - call set_solver_options(new_fields(1), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - new_fields(1)%option_path = "/field/prognostic/lagrangian_remap" - call set_solver_options(new_fields(1), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - new_fields(1)%option_path = "/field" - call set(new_fields(1), old_fields(1)) + call allocate(new_fields(1), old_fields(1)%mesh, name="NewMaterialVolumeFraction") + new_fields(1)%option_path = "/field/prognostic/galerkin_projection/continuous" + call set_solver_options(new_fields(1), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + new_fields(1)%option_path = "/field/prognostic/lagrangian_remap" + call set_solver_options(new_fields(1), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + new_fields(1)%option_path = "/field" + call set(new_fields(1), old_fields(1)) - do i = 0, 3000 + do i = 0, 3000 ! if(mod(i,10)==0) then call vtk_write_fields(filename="data/lagrangian_remap", index=i, position=coordinate, model=coordinate%mesh, & - sfields=(/old_fields(1), new_fields(1)/), vfields=(/velocity/)) + sfields=(/old_fields(1), new_fields(1)/), vfields=(/velocity/)) ! end if - call lagrangian_advection(coordinate, velocity, dt, & - old_fields, new_fields) + call lagrangian_advection(coordinate, velocity, dt, & + old_fields, new_fields) - call set(old_fields(1), new_fields(1)) - end do + call set(old_fields(1), new_fields(1)) + end do - call deallocate(new_fields(1)) + call deallocate(new_fields(1)) end subroutine test_lagrangian_remap diff --git a/assemble/tests/test_legacy_cv_faces.F90 b/assemble/tests/test_legacy_cv_faces.F90 index a6d631f524..9d9643f197 100644 --- a/assemble/tests/test_legacy_cv_faces.F90 +++ b/assemble/tests/test_legacy_cv_faces.F90 @@ -1,76 +1,76 @@ subroutine test_legacy_cv_faces - use legacy_cv_numbering - use legacy_cv_shape_functions + use legacy_cv_numbering + use legacy_cv_shape_functions - implicit none + implicit none - integer :: optelm, eletyp, seletyp, ngi, sngi, nloc, snloc, svngi - integer, dimension(:,:), allocatable :: neiloc - real, dimension(:,:), allocatable :: svn, svnlx, svnly, m - real, dimension(:), allocatable :: svweigh - logical :: d3, dcyl, redquad + integer :: optelm, eletyp, seletyp, ngi, sngi, nloc, snloc, svngi + integer, dimension(:,:), allocatable :: neiloc + real, dimension(:,:), allocatable :: svn, svnlx, svnly, m + real, dimension(:), allocatable :: svweigh + logical :: d3, dcyl, redquad - integer i + integer i - redquad = .false. - optelm = 1 ! linear triangles + redquad = .false. + optelm = 1 ! linear triangles - call setelm(eletyp, ngi, nloc, optelm, seletyp, sngi, snloc, svngi, d3, dcyl, redquad) + call setelm(eletyp, ngi, nloc, optelm, seletyp, sngi, snloc, svngi, d3, dcyl, redquad) - allocate(neiloc(nloc, svngi), svn(nloc, svngi), svnlx(nloc, svngi), svnly(nloc, svngi),& - svweigh(svngi), m(nloc, ngi)) - call shapesv(eletyp, neiloc, ngi, nloc, svngi, svn, svnlx, svnly, svweigh, m) + allocate(neiloc(nloc, svngi), svn(nloc, svngi), svnlx(nloc, svngi), svnly(nloc, svngi),& + svweigh(svngi), m(nloc, ngi)) + call shapesv(eletyp, neiloc, ngi, nloc, svngi, svn, svnlx, svnly, svweigh, m) - write(0,*) 'p1p1' - do i = 1, size(svn,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p1%n(:,gi) = ', svn(:,i) - write(0,*) 'dim = 1' - write(0,*) 'cv_p1p1%dn(:,gi,dim) = ', svnlx(:,i) - write(0,*) 'cv_p1p1%quadrature%weight(gi) = ', svweigh(i) - end do + write(0,*) 'p1p1' + do i = 1, size(svn,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p1%n(:,gi) = ', svn(:,i) + write(0,*) 'dim = 1' + write(0,*) 'cv_p1p1%dn(:,gi,dim) = ', svnlx(:,i) + write(0,*) 'cv_p1p1%quadrature%weight(gi) = ', svweigh(i) + end do - deallocate(neiloc, svn, svnlx, svnly, svweigh, m) + deallocate(neiloc, svn, svnlx, svnly, svweigh, m) - optelm = 5 ! linear tets + optelm = 5 ! linear tets - call setelm(eletyp, ngi, nloc, optelm, seletyp, sngi, snloc, svngi, d3, dcyl, redquad) + call setelm(eletyp, ngi, nloc, optelm, seletyp, sngi, snloc, svngi, d3, dcyl, redquad) - allocate(neiloc(nloc, svngi), svn(nloc, svngi), svnlx(nloc, svngi), svnly(nloc, svngi),& - svweigh(svngi), m(nloc, ngi)) - call shapesv(eletyp, neiloc, ngi, nloc, svngi, svn, svnlx, svnly, svweigh, m) + allocate(neiloc(nloc, svngi), svn(nloc, svngi), svnlx(nloc, svngi), svnly(nloc, svngi),& + svweigh(svngi), m(nloc, ngi)) + call shapesv(eletyp, neiloc, ngi, nloc, svngi, svn, svnlx, svnly, svweigh, m) - write(0,*) 'p1p1_tet' - do i = 1, size(svn,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p1_tet%n(:,gi) = ', svn(:,i) - write(0,*) 'dim = 1' - write(0,*) 'cv_p1p1_tet%dn(:,gi,dim) = ', svnlx(:,i) - write(0,*) 'dim = 2' - write(0,*) 'cv_p1p1_tet%dn(:,gi,dim) = ', svnly(:,i) - write(0,*) 'cv_p1p1_tet%quadrature%weight(gi) = ', svweigh(i) - end do + write(0,*) 'p1p1_tet' + do i = 1, size(svn,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p1_tet%n(:,gi) = ', svn(:,i) + write(0,*) 'dim = 1' + write(0,*) 'cv_p1p1_tet%dn(:,gi,dim) = ', svnlx(:,i) + write(0,*) 'dim = 2' + write(0,*) 'cv_p1p1_tet%dn(:,gi,dim) = ', svnly(:,i) + write(0,*) 'cv_p1p1_tet%quadrature%weight(gi) = ', svweigh(i) + end do - optelm = 2 ! quadratic triangles + optelm = 2 ! quadratic triangles - call setelm(eletyp, ngi, nloc, optelm, seletyp, sngi, snloc, svngi, d3, dcyl, redquad) + call setelm(eletyp, ngi, nloc, optelm, seletyp, sngi, snloc, svngi, d3, dcyl, redquad) - allocate(neiloc(nloc, svngi), svn(nloc, svngi), svnlx(nloc, svngi), svnly(nloc, svngi),& - svweigh(svngi), m(nloc, ngi)) - call shapesv(eletyp, neiloc, ngi, nloc, svngi, svn, svnlx, svnly, svweigh, m) + allocate(neiloc(nloc, svngi), svn(nloc, svngi), svnlx(nloc, svngi), svnly(nloc, svngi),& + svweigh(svngi), m(nloc, ngi)) + call shapesv(eletyp, neiloc, ngi, nloc, svngi, svn, svnlx, svnly, svweigh, m) - write(0,*) 'p2p2' - do i = 1, size(svn,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p2p2%n(:,gi) = ', svn(:,i) - write(0,*) 'dim = 1' - write(0,*) 'cv_p2p2%dn(:,gi,dim) = ', svnlx(:,i) - write(0,*) 'cv_p2p2%quadrature%weight(gi) = ', svweigh(i) - end do + write(0,*) 'p2p2' + do i = 1, size(svn,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p2p2%n(:,gi) = ', svn(:,i) + write(0,*) 'dim = 1' + write(0,*) 'cv_p2p2%dn(:,gi,dim) = ', svnlx(:,i) + write(0,*) 'cv_p2p2%quadrature%weight(gi) = ', svweigh(i) + end do - deallocate(neiloc, svn, svnlx, svnly, svweigh, m) + deallocate(neiloc, svn, svnlx, svnly, svweigh, m) - write(0,*) 'ending' + write(0,*) 'ending' end subroutine test_legacy_cv_faces diff --git a/assemble/tests/test_matrix_free.F90 b/assemble/tests/test_matrix_free.F90 index eb4216d807..9ca1bcf690 100644 --- a/assemble/tests/test_matrix_free.F90 +++ b/assemble/tests/test_matrix_free.F90 @@ -2,324 +2,324 @@ #include "fdebug.h" subroutine test_matrix_free - use unittest_tools - use solvers - use fields - use state_module - use elements - use sparse_tools - use mesh_files - use vtk_interfaces - implicit none - - logical :: fail=.false., warn=.false. - - type(state_type) :: state - type(vector_field), target:: positions - type(scalar_field) :: psi - type(mesh_type) :: psi_mesh - type(mesh_type), pointer :: x_mesh - type(element_type) :: psi_shape - type(quadrature_type) :: quad - integer :: dim - integer :: quad_degree=4 - - interface - function rhs_func(X) - ! A function which evaluates the right hand side at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - - call set_global_debug_level(3) - - positions=read_mesh_files("data/cube_unstructured", & - quad_degree=QUAD_DEGREE, format="gmsh") - x_mesh => positions%mesh - - call insert(state, positions, name="Coordinate") - call insert(state, positions%mesh, "Coordinate_mesh") - - ! Shape functions for psi - dim=mesh_dim(positions) - quad=make_quadrature(vertices = dim+1, dim =dim, degree=quad_degree) - - psi_shape=make_element_shape(vertices = dim+1, dim =dim, degree=2, quad=quad) - psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) - - call insert(state, psi_mesh, "Psi_Mesh") - call allocate(psi, psi_mesh, "Psi") - call insert(state, psi, "Psi") - - call run_model(state, rhs_func) - - call vtk_write_fields('test', 0, positions, positions%mesh, & - sfields=(/ psi /) ) - - call report_test("[id matrix solve]", fail, warn, "Solving Ix = b should yield x == b.") + use unittest_tools + use solvers + use fields + use state_module + use elements + use sparse_tools + use mesh_files + use vtk_interfaces + implicit none + + logical :: fail=.false., warn=.false. + + type(state_type) :: state + type(vector_field), target:: positions + type(scalar_field) :: psi + type(mesh_type) :: psi_mesh + type(mesh_type), pointer :: x_mesh + type(element_type) :: psi_shape + type(quadrature_type) :: quad + integer :: dim + integer :: quad_degree=4 + + interface + function rhs_func(X) + ! A function which evaluates the right hand side at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface + + call set_global_debug_level(3) + + positions=read_mesh_files("data/cube_unstructured", & + quad_degree=QUAD_DEGREE, format="gmsh") + x_mesh => positions%mesh + + call insert(state, positions, name="Coordinate") + call insert(state, positions%mesh, "Coordinate_mesh") + + ! Shape functions for psi + dim=mesh_dim(positions) + quad=make_quadrature(vertices = dim+1, dim =dim, degree=quad_degree) + + psi_shape=make_element_shape(vertices = dim+1, dim =dim, degree=2, quad=quad) + psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) + + call insert(state, psi_mesh, "Psi_Mesh") + call allocate(psi, psi_mesh, "Psi") + call insert(state, psi, "Psi") + + call run_model(state, rhs_func) + + call vtk_write_fields('test', 0, positions, positions%mesh, & + sfields=(/ psi /) ) + + call report_test("[id matrix solve]", fail, warn, "Solving Ix = b should yield x == b.") end subroutine test_matrix_free subroutine run_model(state, rhs_func) - use unittest_tools - use solvers - use fields - use state_module - use elements - use sparse_tools - use mesh_files - use sparsity_patterns - implicit none - type(state_type), intent(inout) :: state - interface - function rhs_func(X) + use unittest_tools + use solvers + use fields + use state_module + use elements + use sparse_tools + use mesh_files + use sparsity_patterns + implicit none + type(state_type), intent(inout) :: state + interface + function rhs_func(X) ! A function which evaluates the right hand side at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface - type(vector_field), pointer :: positions - type(scalar_field), pointer :: psi + type(vector_field), pointer :: positions + type(scalar_field), pointer :: psi - ! We form and solve the equation A*psi=rhs - type(csr_matrix) :: A - type(csr_sparsity) :: A_sparsity - type(scalar_field) :: RHS - integer :: ele + ! We form and solve the equation A*psi=rhs + type(csr_matrix) :: A + type(csr_sparsity) :: A_sparsity + type(scalar_field) :: RHS + integer :: ele - ! Extract the required fields from state. - positions=>extract_vector_field(state, "Coordinate") - psi=>extract_scalar_field(state, "Psi") + ! Extract the required fields from state. + positions=>extract_vector_field(state, "Coordinate") + psi=>extract_scalar_field(state, "Psi") - ! Calculate the sparsity of A based on the connectivity of psi. - A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') - call allocate(A, A_sparsity) + ! Calculate the sparsity of A based on the connectivity of psi. + A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') + call allocate(A, A_sparsity) - call zero(A) + call zero(A) - call allocate(rhs, psi%mesh, "RHS") - call zero(rhs) + call allocate(rhs, psi%mesh, "RHS") + call zero(rhs) - ! Assemble A element by element. - do ele=1, element_count(psi) - call assemble_element_contribution(A, rhs, positions, psi, rhs_func,& - & ele) - end do + ! Assemble A element by element. + do ele=1, element_count(psi) + call assemble_element_contribution(A, rhs, positions, psi, rhs_func,& + & ele) + end do - ewrite(1,*) 'sum A', sum(A%val), maxval(A%val) + ewrite(1,*) 'sum A', sum(A%val), maxval(A%val) - ! It is necessary to fix the value of one node in the solution. - ! We choose node 1. - call set(A, 1, 1, INFINITY) + ! It is necessary to fix the value of one node in the solution. + ! We choose node 1. + call set(A, 1, 1, INFINITY) - ewrite(1,*) 'sum A', sum(A%val), maxval(A%val) + ewrite(1,*) 'sum A', sum(A%val), maxval(A%val) - psi%options%abs_error = 1.0e-8 + psi%options%abs_error = 1.0e-8 - psi%options%max_its = 10000 + psi%options%max_its = 10000 - !call set_solver_options(psi, & - ! ksptype="cg", pctype="sor", atol=1.0e-8, rtol=1.0e-8, max_its=1000, & - ! start_from_zero=.true.) + !call set_solver_options(psi, & + ! ksptype="cg", pctype="sor", atol=1.0e-8, rtol=1.0e-8, max_its=1000, & + ! start_from_zero=.true.) - call zero(psi) + call zero(psi) - ewrite(1,*) maxval(rhs%val) + ewrite(1,*) maxval(rhs%val) - !call petsc_solve(psi,A,rhs) - call petsc_solve_matrix_free(psi, A, rhs) + !call petsc_solve(psi,A,rhs) + call petsc_solve_matrix_free(psi, A, rhs) - call deallocate(A) - call deallocate(A_sparsity) - call deallocate(rhs) + call deallocate(A) + call deallocate(A_sparsity) + call deallocate(rhs) end subroutine run_model subroutine assemble_element_contribution(A, rhs, positions, psi, rhs_func& - &, ele) - use unittest_tools - use solvers - use fields - use state_module - use elements - use sparse_tools - use mesh_files - implicit none - type(csr_matrix), intent(inout) :: A - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - interface - function rhs_func(X) - ! A function which evaluates the right hand side at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - integer, intent(in) :: ele - - ! Locations of quadrature points - real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad - ! Derivatives of shape function: - real, dimension(ele_loc(psi,ele), & - ele_ngi(psi,ele), positions%dim) :: dshape_psi - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of psi element. - integer, dimension(:), pointer :: ele_psi - ! Shape functions. - type(element_type), pointer :: shape_psi - ! Local Laplacian matrix - real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat - ! Local right hand side. - real, dimension(ele_loc(psi, ele)) :: lrhs - - ele_psi=>ele_nodes(psi, ele) - shape_psi=>ele_shape(psi, ele) - - ! Locations of quadrature points. - X_quad=ele_val_at_quad(positions, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& - & detwei=detwei) - - ! Local assembly: - psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei) - - lrhs=shape_rhs(shape_psi, rhs_func(X_quad)*detwei) - - ! Global assembly: - call addto(A, ele_psi, ele_psi, psi_mat) - - call addto(rhs, ele_psi, lrhs) +&, ele) + use unittest_tools + use solvers + use fields + use state_module + use elements + use sparse_tools + use mesh_files + implicit none + type(csr_matrix), intent(inout) :: A + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + interface + function rhs_func(X) + ! A function which evaluates the right hand side at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface + integer, intent(in) :: ele + + ! Locations of quadrature points + real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad + ! Derivatives of shape function: + real, dimension(ele_loc(psi,ele), & + ele_ngi(psi,ele), positions%dim) :: dshape_psi + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of psi element. + integer, dimension(:), pointer :: ele_psi + ! Shape functions. + type(element_type), pointer :: shape_psi + ! Local Laplacian matrix + real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat + ! Local right hand side. + real, dimension(ele_loc(psi, ele)) :: lrhs + + ele_psi=>ele_nodes(psi, ele) + shape_psi=>ele_shape(psi, ele) + + ! Locations of quadrature points. + X_quad=ele_val_at_quad(positions, ele) + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& + & detwei=detwei) + + ! Local assembly: + psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei) + + lrhs=shape_rhs(shape_psi, rhs_func(X_quad)*detwei) + + ! Global assembly: + call addto(A, ele_psi, ele_psi, psi_mat) + + call addto(rhs, ele_psi, lrhs) end subroutine assemble_element_contribution function rhs_func(X) - ! Right hand side function for laplacian operator. - ! - ! Each column of X is interpretted as a position at which RHS should be - ! evaluated. - use fetools - implicit none - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - real, parameter :: PI=4.0*atan(1.0) - integer :: i,dim + ! Right hand side function for laplacian operator. + ! + ! Each column of X is interpretted as a position at which RHS should be + ! evaluated. + use fetools + implicit none + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + real, parameter :: PI=4.0*atan(1.0) + integer :: i,dim - dim=size(X,1) + dim=size(X,1) - rhs_func=2*(dim-1+0.25)*PI*cos(0.5*PI*X(1,:)) + rhs_func=2*(dim-1+0.25)*PI*cos(0.5*PI*X(1,:)) - do i=2,dim - rhs_func=rhs_func*cos(PI*X(i,:)) - end do + do i=2,dim + rhs_func=rhs_func*cos(PI*X(i,:)) + end do - rhs_func=rhs_func+0.5*PI*sin(0.5*PI*X(1,:)) + rhs_func=rhs_func+0.5*PI*sin(0.5*PI*X(1,:)) end function rhs_func subroutine petsc_solve_matrix_free(x, matrix, rhs) - !!< Solve a linear system - use fields - use sparse_tools - use solvers - use petsc_tools - use matrix_free_solvers - - use petsc - implicit none + !!< Solve a linear system + use fields + use sparse_tools + use solvers + use petsc_tools + use matrix_free_solvers + + use petsc + implicit none #include "petsc_legacy.h" - type(scalar_field), intent(inout) :: x - type(scalar_field), intent(in) :: rhs - type(csr_matrix), intent(in) :: matrix - integer, dimension(:), allocatable :: petsc_numbering - KSP :: ksp - Mat :: Amat, Pmat - Vec :: y, b - PCType :: pctype = PCNONE - KSPType :: ksptype = KSPCG - PC :: pc - PetscReal rtol, atol, dtol - PetscInt max_its - PetscErrorCode :: ierr - KSPConvergedReason :: reason - - integer literations,i - logical :: lstartfromzero=.true. - - assert(size(x%val)==size(rhs%val)) - assert(size(x%val)==size(matrix,2)) - assert(size(rhs%val)==size(matrix,1)) - - ! call allocate(petsc_numbering, & - ! size(rhs%val), 1) - - allocate(petsc_numbering(size(rhs%val)) ) - petsc_numbering = -1 - do i = 1, size(rhs%val) - petsc_numbering(i) = i - end do - - !set up preconditioner matrix - Pmat = csr2petsc(matrix)!,petsc_numbering) - !Amat = csr2petsc(matrix,petsc_numbering) - - !set up matrix-free matrix - call petsc_mult_setup(Pmat) - call MatCreateShell(MPI_COMM_SELF,size(rhs%val),size(rhs%val), & - size(rhs%val),size(rhs%val),PETSC_NULL_INTEGER,Amat,ierr) - call MatShellSetOperation(AMat,MATOP_MULT,petsc_mult,ierr) - - !set up KSP - call KSPCreate(MPI_COMM_SELF, ksp, ierr) - call KSPSetOperators(ksp, amat, pmat, DIFFERENT_NONZERO_PATTERN, ierr) - call KSPGetPC(ksp, pc, ierr) - pctype=PCNONE - ksptype=KSPCG - call PCSetType(pc, pctype, ierr) - call KSPSetType(ksp, ksptype, ierr) - dtol=PETSC_DEFAULT_DOUBLE_PRECISION - max_its = 1000 - rtol =1.0e-7 - atol =1.0e-7 - - call KSPSetInitialGuessNonzero(ksp, PETSC_FALSE, ierr) - call KSPSetUp(ksp, ierr) - - call VecCreateSeq(MPI_COMM_SELF,size(rhs%val), b, ierr) - - call VecDuplicate(b, y, ierr) - - ! copy array into PETSc vecs - call VecSetValues(b, size(rhs%val), & - petsc_numbering(1:size(rhs%val)), & - rhs%val( 1:size(rhs%val) ), INSERT_VALUES, ierr) - - call VecSetValues(y, size(rhs%val), & - petsc_numbering(1:size(rhs%val)), & - rhs%val( 1:size(rhs%val) )*0.0, INSERT_VALUES, ierr) - - ! the solve and convergence check - call KSPSolve(ksp, b, y, ierr) - call KSPGetConvergedReason(ksp, reason, ierr) - call KSPGetIterationNumber(ksp, literations, ierr) - - ewrite(1,*) reason, literations - - ! Copy back the result using the petsc numbering: - !call petsc2field(y, petsc_numbering, x) - - ! destroy all PETSc objects and the petsc_numbering - !call petsc_solve_destroy(y, A, b, ksp, petsc_numbering) + type(scalar_field), intent(inout) :: x + type(scalar_field), intent(in) :: rhs + type(csr_matrix), intent(in) :: matrix + integer, dimension(:), allocatable :: petsc_numbering + KSP :: ksp + Mat :: Amat, Pmat + Vec :: y, b + PCType :: pctype = PCNONE + KSPType :: ksptype = KSPCG + PC :: pc + PetscReal rtol, atol, dtol + PetscInt max_its + PetscErrorCode :: ierr + KSPConvergedReason :: reason + + integer literations,i + logical :: lstartfromzero=.true. + + assert(size(x%val)==size(rhs%val)) + assert(size(x%val)==size(matrix,2)) + assert(size(rhs%val)==size(matrix,1)) + + ! call allocate(petsc_numbering, & + ! size(rhs%val), 1) + + allocate(petsc_numbering(size(rhs%val)) ) + petsc_numbering = -1 + do i = 1, size(rhs%val) + petsc_numbering(i) = i + end do + + !set up preconditioner matrix + Pmat = csr2petsc(matrix)!,petsc_numbering) + !Amat = csr2petsc(matrix,petsc_numbering) + + !set up matrix-free matrix + call petsc_mult_setup(Pmat) + call MatCreateShell(MPI_COMM_SELF,size(rhs%val),size(rhs%val), & + size(rhs%val),size(rhs%val),PETSC_NULL_INTEGER,Amat,ierr) + call MatShellSetOperation(AMat,MATOP_MULT,petsc_mult,ierr) + + !set up KSP + call KSPCreate(MPI_COMM_SELF, ksp, ierr) + call KSPSetOperators(ksp, amat, pmat, DIFFERENT_NONZERO_PATTERN, ierr) + call KSPGetPC(ksp, pc, ierr) + pctype=PCNONE + ksptype=KSPCG + call PCSetType(pc, pctype, ierr) + call KSPSetType(ksp, ksptype, ierr) + dtol=PETSC_DEFAULT_DOUBLE_PRECISION + max_its = 1000 + rtol =1.0e-7 + atol =1.0e-7 + + call KSPSetInitialGuessNonzero(ksp, PETSC_FALSE, ierr) + call KSPSetUp(ksp, ierr) + + call VecCreateSeq(MPI_COMM_SELF,size(rhs%val), b, ierr) + + call VecDuplicate(b, y, ierr) + + ! copy array into PETSc vecs + call VecSetValues(b, size(rhs%val), & + petsc_numbering(1:size(rhs%val)), & + rhs%val( 1:size(rhs%val) ), INSERT_VALUES, ierr) + + call VecSetValues(y, size(rhs%val), & + petsc_numbering(1:size(rhs%val)), & + rhs%val( 1:size(rhs%val) )*0.0, INSERT_VALUES, ierr) + + ! the solve and convergence check + call KSPSolve(ksp, b, y, ierr) + call KSPGetConvergedReason(ksp, reason, ierr) + call KSPGetIterationNumber(ksp, literations, ierr) + + ewrite(1,*) reason, literations + + ! Copy back the result using the petsc numbering: + !call petsc2field(y, petsc_numbering, x) + + ! destroy all PETSc objects and the petsc_numbering + !call petsc_solve_destroy(y, A, b, ksp, petsc_numbering) end subroutine petsc_solve_matrix_free diff --git a/assemble/tests/test_mba_supermesh.F90 b/assemble/tests/test_mba_supermesh.F90 index b6e233d5cc..6f7f62fa8b 100644 --- a/assemble/tests/test_mba_supermesh.F90 +++ b/assemble/tests/test_mba_supermesh.F90 @@ -1,92 +1,92 @@ subroutine test_mba_supermesh - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use adapt_state_module - use field_derivatives - use vtk_interfaces - use solenoidal_interpolation_module - use global_parameters - use supermesh_construction - implicit none - - interface - function id(X) result(m) - real, dimension(:), intent(in) :: X - real, dimension(size(X), size(X)) :: m - end function id - end interface - - interface - function nid(X) result(m) - real, dimension(:), intent(in) :: X - real, dimension(size(X), size(X)) :: m - end function nid - end interface - - type(state_type), dimension(:), pointer :: states_A => null() - type(state_type), dimension(:), pointer :: states_B => null() - type(tensor_field) :: metric - type(mesh_type), pointer :: mesh_A, mesh_B - type(vector_field), pointer :: x_A, x_B - type(supermesh) :: sup - - call load_options("data/solenoidal_interpolation_A.flml") - call populate_state(states_A) - call populate_state(states_B) - - mesh_A => extract_mesh(states_A(1), "VelocityMesh") - x_A => extract_vector_field(states_A(1), "Coordinate") - - call allocate(metric, mesh_A, "Metric") - - call set_from_function(metric, id, x_A) - call adapt_state(states_A, metric) - - mesh_B => extract_mesh(states_B(1), "VelocityMesh") - x_B => extract_vector_field(states_B(1), "Coordinate") - - call allocate(metric, mesh_B, "Metric") - - call set_from_function(metric, nid, x_B) - call adapt_state(states_B, metric) - - call vtk_write_state("data/mba_supermesh", 0, state=states_A) - call vtk_write_state("data/mba_supermesh", 1, state=states_B) - - x_A => extract_vector_field(states_A(1), "Coordinate") - x_B => extract_vector_field(states_B(1), "Coordinate") - sup = construct_supermesh(x_A, x_B) - call vtk_write_fields("data/mba_supermesh", 2, sup%positions, sup%positions%mesh) - - call deallocate(states_A(1)) - call deallocate(states_B(1)) - call deallocate(sup) + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use adapt_state_module + use field_derivatives + use vtk_interfaces + use solenoidal_interpolation_module + use global_parameters + use supermesh_construction + implicit none + + interface + function id(X) result(m) + real, dimension(:), intent(in) :: X + real, dimension(size(X), size(X)) :: m + end function id + end interface + + interface + function nid(X) result(m) + real, dimension(:), intent(in) :: X + real, dimension(size(X), size(X)) :: m + end function nid + end interface + + type(state_type), dimension(:), pointer :: states_A => null() + type(state_type), dimension(:), pointer :: states_B => null() + type(tensor_field) :: metric + type(mesh_type), pointer :: mesh_A, mesh_B + type(vector_field), pointer :: x_A, x_B + type(supermesh) :: sup + + call load_options("data/solenoidal_interpolation_A.flml") + call populate_state(states_A) + call populate_state(states_B) + + mesh_A => extract_mesh(states_A(1), "VelocityMesh") + x_A => extract_vector_field(states_A(1), "Coordinate") + + call allocate(metric, mesh_A, "Metric") + + call set_from_function(metric, id, x_A) + call adapt_state(states_A, metric) + + mesh_B => extract_mesh(states_B(1), "VelocityMesh") + x_B => extract_vector_field(states_B(1), "Coordinate") + + call allocate(metric, mesh_B, "Metric") + + call set_from_function(metric, nid, x_B) + call adapt_state(states_B, metric) + + call vtk_write_state("data/mba_supermesh", 0, state=states_A) + call vtk_write_state("data/mba_supermesh", 1, state=states_B) + + x_A => extract_vector_field(states_A(1), "Coordinate") + x_B => extract_vector_field(states_B(1), "Coordinate") + sup = construct_supermesh(x_A, x_B) + call vtk_write_fields("data/mba_supermesh", 2, sup%positions, sup%positions%mesh) + + call deallocate(states_A(1)) + call deallocate(states_B(1)) + call deallocate(sup) end subroutine test_mba_supermesh function id(X) result(m) - real, dimension(:), intent(in) :: X - real, dimension(size(X), size(X)) :: m - integer :: i - - m = 0.0 - do i=1,size(X) - m(i,i) = 1.0 - end do + real, dimension(:), intent(in) :: X + real, dimension(size(X), size(X)) :: m + integer :: i + + m = 0.0 + do i=1,size(X) + m(i,i) = 1.0 + end do end function id function nid(X) result(m) - real, dimension(:), intent(in) :: X - real, dimension(size(X), size(X)) :: m - integer :: i - - m = 0.0 - do i=1,size(X) - m(i,i) = i - end do + real, dimension(:), intent(in) :: X + real, dimension(size(X), size(X)) :: m + integer :: i + + m = 0.0 + do i=1,size(X) + m(i,i) = i + end do end function nid diff --git a/assemble/tests/test_potential_vorticity.F90 b/assemble/tests/test_potential_vorticity.F90 index d204541048..b44f9fa0ba 100644 --- a/assemble/tests/test_potential_vorticity.F90 +++ b/assemble/tests/test_potential_vorticity.F90 @@ -29,75 +29,75 @@ subroutine test_potential_vorticity - use fields - use fldebug - use state_module - use unittest_tools - use vorticity_diagnostics - use vtk_interfaces - use spud - - implicit none - - character(len = 64) :: buffer - integer :: i, stat - real :: max_val - real, dimension(3) :: pos - type(mesh_type), pointer :: mesh - type(scalar_field) :: perturbation_density, pv - type(state_type) :: state - type(vector_field) :: velocity - type(vector_field), pointer :: positions - - call vtk_read_state("data/cube-itv5.vtu", state) - - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == 3) - mesh => positions%mesh - - call set_option("/geometry/dimension", 3, stat=stat) - call set_option("/physical_parameters/coriolis/f_plane/f", 1.0, stat=stat) - - call allocate(velocity, positions%dim, mesh, "Velocity") - call zero(velocity) - do i = 1, node_count(velocity) - pos = node_val(positions, i) - call set(velocity, i, 0.5 * (/-pos(2), pos(1), 0.0/)) - end do - call insert(state, velocity, velocity%name) - - call allocate(perturbation_density, mesh, "PerturbationDensity") - call zero(perturbation_density) - do i = 1, node_count(perturbation_density) - pos = node_val(positions, i) - call set(perturbation_density, i, -pos(3)) - end do - call insert(state, perturbation_density, perturbation_density%name) - - call allocate(pv, mesh, "PotentialVorticity") - call calculate_potential_vorticity(state, pv) - - call vtk_write_fields("data/test_potential_vorticity_out", & - & position = positions, model = mesh, & - & sfields = (/perturbation_density, pv/), & - & vfields = (/velocity/)) - - call deallocate(velocity) - call deallocate(perturbation_density) - - max_val = 0.0 - do i = 1, node_count(pv) - max_val = max(max_val, abs(node_val(pv, i) + 2.0)) - end do - - write(buffer, *) max_val - call report_test("[PV == -2.0]", & - & fnequals(max_val, 0.0, tol = 100.0 * spacing(2.0)), .false., & - & "PV /= -2.0 - Max. abs. diff: " // buffer) - - call deallocate(pv) - call deallocate(state) - - call report_test_no_references() + use fields + use fldebug + use state_module + use unittest_tools + use vorticity_diagnostics + use vtk_interfaces + use spud + + implicit none + + character(len = 64) :: buffer + integer :: i, stat + real :: max_val + real, dimension(3) :: pos + type(mesh_type), pointer :: mesh + type(scalar_field) :: perturbation_density, pv + type(state_type) :: state + type(vector_field) :: velocity + type(vector_field), pointer :: positions + + call vtk_read_state("data/cube-itv5.vtu", state) + + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == 3) + mesh => positions%mesh + + call set_option("/geometry/dimension", 3, stat=stat) + call set_option("/physical_parameters/coriolis/f_plane/f", 1.0, stat=stat) + + call allocate(velocity, positions%dim, mesh, "Velocity") + call zero(velocity) + do i = 1, node_count(velocity) + pos = node_val(positions, i) + call set(velocity, i, 0.5 * (/-pos(2), pos(1), 0.0/)) + end do + call insert(state, velocity, velocity%name) + + call allocate(perturbation_density, mesh, "PerturbationDensity") + call zero(perturbation_density) + do i = 1, node_count(perturbation_density) + pos = node_val(positions, i) + call set(perturbation_density, i, -pos(3)) + end do + call insert(state, perturbation_density, perturbation_density%name) + + call allocate(pv, mesh, "PotentialVorticity") + call calculate_potential_vorticity(state, pv) + + call vtk_write_fields("data/test_potential_vorticity_out", & + & position = positions, model = mesh, & + & sfields = (/perturbation_density, pv/), & + & vfields = (/velocity/)) + + call deallocate(velocity) + call deallocate(perturbation_density) + + max_val = 0.0 + do i = 1, node_count(pv) + max_val = max(max_val, abs(node_val(pv, i) + 2.0)) + end do + + write(buffer, *) max_val + call report_test("[PV == -2.0]", & + & fnequals(max_val, 0.0, tol = 100.0 * spacing(2.0)), .false., & + & "PV /= -2.0 - Max. abs. diff: " // buffer) + + call deallocate(pv) + call deallocate(state) + + call report_test_no_references() end subroutine test_potential_vorticity diff --git a/assemble/tests/test_pressure_solve.F90 b/assemble/tests/test_pressure_solve.F90 index a688c035a3..c4d173f52a 100644 --- a/assemble/tests/test_pressure_solve.F90 +++ b/assemble/tests/test_pressure_solve.F90 @@ -2,91 +2,91 @@ !! WE SOLVE MINUS LAPLACE EQUATION! #include "fdebug.h" - subroutine test_pressure_solve - - use unittest_tools - use solvers - use fields - use state_module - use elements - use sparse_tools - use mesh_files - use vtk_interfaces - use boundary_conditions - use global_parameters, only: OPTION_PATH_LEN - use free_surface_module - use petsc - implicit none +subroutine test_pressure_solve + + use unittest_tools + use solvers + use fields + use state_module + use elements + use sparse_tools + use mesh_files + use vtk_interfaces + use boundary_conditions + use global_parameters, only: OPTION_PATH_LEN + use free_surface_module + use petsc + implicit none #include "petsc_legacy.h" - logical :: fail=.false., warn=.false. + logical :: fail=.false., warn=.false. - type(state_type) :: state,state_in - type(vector_field), target:: positions - type(scalar_field) :: psi, DistanceToTop - type(mesh_type) :: psi_mesh - type(mesh_type), pointer :: x_mesh - type(element_type) :: psi_shape - type(quadrature_type) :: quad - integer :: quad_degree=4 - integer, parameter:: DIM=3 - real :: eps0 - real, dimension(DIM), parameter:: LENGTH=(/ 1.0, 1.0, 1.0 /) - integer, dimension(DIM), parameter:: WAVENUMBER=(/ 2, 2 , 0 /) - character(len=OPTION_PATH_LEN) solver_option_path - integer :: unit,io1 + type(state_type) :: state,state_in + type(vector_field), target:: positions + type(scalar_field) :: psi, DistanceToTop + type(mesh_type) :: psi_mesh + type(mesh_type), pointer :: x_mesh + type(element_type) :: psi_shape + type(quadrature_type) :: quad + integer :: quad_degree=4 + integer, parameter:: DIM=3 + real :: eps0 + real, dimension(DIM), parameter:: LENGTH=(/ 1.0, 1.0, 1.0 /) + integer, dimension(DIM), parameter:: WAVENUMBER=(/ 2, 2 , 0 /) + character(len=OPTION_PATH_LEN) solver_option_path + integer :: unit,io1 - namelist/epsilon_data/eps0 + namelist/epsilon_data/eps0 - call set_global_debug_level(3) + call set_global_debug_level(3) - unit = free_unit() - open(unit=unit, file="epsilon.dat", status='old', & - iostat=io1) + unit = free_unit() + open(unit=unit, file="epsilon.dat", status='old', & + iostat=io1) - if(io1.ne.0) then - ewrite(-1,*) 'Looked for ', "epsilon.dat" - FLExit('Could not read from .dat file') - end if + if(io1.ne.0) then + ewrite(-1,*) 'Looked for ', "epsilon.dat" + FLExit('Could not read from .dat file') + end if - read(unit, epsilon_data) - close(unit) + read(unit, epsilon_data) + close(unit) - positions=read_mesh_files("cube_unstructured", & - quad_degree=QUAD_DEGREE, format="gmsh") + positions=read_mesh_files("cube_unstructured", & + quad_degree=QUAD_DEGREE, format="gmsh") - !call vtk_read_state("cube-1_1.vtu", state_in, quad_degree) - !positions=extract_vector_field(state_in,name="Coordinate") + !call vtk_read_state("cube-1_1.vtu", state_in, quad_degree) + !positions=extract_vector_field(state_in,name="Coordinate") - !positions=read_mesh_files("test_laplacian.1", & - ! quad_degree=QUAD_DEGREE, format="gmsh") - x_mesh => positions%mesh + !positions=read_mesh_files("test_laplacian.1", & + ! quad_degree=QUAD_DEGREE, format="gmsh") + x_mesh => positions%mesh - call insert(state, positions, name="Coordinate") - call insert(state, positions%mesh, "Coordinate_mesh") + call insert(state, positions, name="Coordinate") + call insert(state, positions%mesh, "Coordinate_mesh") - ! Shape functions for psi - assert(dim==mesh_dim(positions)) - quad=make_quadrature(vertices = dim+1, dim =dim, degree=quad_degree) + ! Shape functions for psi + assert(dim==mesh_dim(positions)) + quad=make_quadrature(vertices = dim+1, dim =dim, degree=quad_degree) - psi_shape=make_element_shape(vertices = dim+1, dim =dim, degree=1, quad=quad) - psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) + psi_shape=make_element_shape(vertices = dim+1, dim =dim, degree=1, quad=quad) + psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) - call insert(state, psi_mesh, "Psi_Mesh") - call allocate(psi, psi_mesh, "Psi") - call allocate(DistanceToTop, psi_mesh, "DistanceToTop") - call add_boundary_condition(DistanceToTop,"top","surface",(/1/) ) + call insert(state, psi_mesh, "Psi_Mesh") + call allocate(psi, psi_mesh, "Psi") + call allocate(DistanceToTop, psi_mesh, "DistanceToTop") + call add_boundary_condition(DistanceToTop,"top","surface",(/1/) ) - call insert(state, psi, "Psi") - call insert(state, DistanceToTop,"DistanceToTop") + call insert(state, psi, "Psi") + call insert(state, DistanceToTop,"DistanceToTop") - call run_model(state) + call run_model(state) - call report_test("[id matrix solve]", fail, warn, "Solving Ix = b should yield x == b.") + call report_test("[id matrix solve]", fail, warn, "Solving Ix = b should yield x == b.") - contains +contains - subroutine run_model(state) + subroutine run_model(state) use global_parameters, only: PYTHON_FUNC_LEN use unittest_tools use solvers @@ -135,11 +135,11 @@ subroutine run_model(state) FLExit('DistanceToTop is not present') end if call get_boundary_condition(topdis,1,& - surface_element_list=top_surface_element_list) + surface_element_list=top_surface_element_list) call create_surface_mesh(top_surface_mesh, & - top_surface_node_list, psi%mesh, & - top_surface_element_list, name="PsiTopSurfaceMesh") - !======================= + top_surface_node_list, psi%mesh, & + top_surface_element_list, name="PsiTopSurfaceMesh") + !======================= !Calculate the sparsity of A based on the connectivity of psi. A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') @@ -157,12 +157,12 @@ subroutine run_model(state) inquire(file="exact.py",exist=file_exists) if (.not.file_exists) then - ewrite(-1,*) "Looking for file", "exact.py" - FLExit('Couldnt find file') + ewrite(-1,*) "Looking for file", "exact.py" + FLExit('Couldnt find file') end if unit=free_unit() open(unit, file="exact.py", action="read",& - & status="old") + & status="old") read(unit, '(a)', end=43) func ! Read all the lines of the file and put in newlines between them. do @@ -177,9 +177,9 @@ subroutine run_model(state) solver_option_path="" call set_solver_options(solver_option_path, "my_solver", & - ksptype=KSPPREONLY, PCTYPE="mg", & - rtol=1.0e-100, atol=1.0e-30, max_its=1000, & - start_from_zero=.true.) + ksptype=KSPPREONLY, PCTYPE="mg", & + rtol=1.0e-100, atol=1.0e-30, max_its=1000, & + start_from_zero=.true.) exact%val = exact%val - exact%val(top_surface_node_list(1)) exact%val(top_surface_node_list(1)) = 0.0 @@ -191,35 +191,35 @@ subroutine run_model(state) ! supplying the prolongator to petsc_solve makes 'mg' ! use the vertical_lumping option vprolongator = & - vertical_prolongator_from_free_surface(state, psi%mesh) + vertical_prolongator_from_free_surface(state, psi%mesh) call set_solver_options(psi, & - ksptype="cg", pctype="mg", & - atol=1.0e-100, rtol=1.0e-20, max_its=1000, & - start_from_zero=.true.) + ksptype="cg", pctype="mg", & + atol=1.0e-100, rtol=1.0e-20, max_its=1000, & + start_from_zero=.true.) ewrite(1,*) 'with vertical lumping and internal smoother' call petsc_solve(psi, A, rhs, prolongator=vprolongator, & - & exact=exact, surface_node_list=top_surface_node_list) + & exact=exact, surface_node_list=top_surface_node_list) ewrite(1,*) 'with vertical lumping, no additive smoother' call petsc_solve(psi, A, rhs, prolongator=vprolongator, & - & exact=exact) + & exact=exact) ewrite(1,*) 'without vertical lumping' call petsc_solve(psi, A, rhs, & - & exact=exact) + & exact=exact) !error%val = psi%val-exact%val !call vtk_write_fields('test', 0, positions, positions%mesh, & ! sfields=(/ psi, rhs, exact, error /) ) - end subroutine run_model + end subroutine run_model - subroutine get_laplacian(A,positions,psi,H0,vertical) + subroutine get_laplacian(A,positions,psi,H0,vertical) implicit none type(csr_matrix), intent(inout) :: A type(vector_field), intent(in) :: positions @@ -239,83 +239,83 @@ subroutine get_laplacian(A,positions,psi,H0,vertical) do ele = 1, element_count(psi) if(present(H0)) then call assemble_laplacian_element_contribution(& - &A, positions, psi, ele, lvertical, H0) + &A, positions, psi, ele, lvertical, H0) else call assemble_laplacian_element_contribution(& - &A, positions, psi, ele, lvertical) + &A, positions, psi, ele, lvertical) end if end do - end subroutine get_laplacian - -subroutine assemble_laplacian_element_contribution(A, positions, psi, ele, & - vertical,H0) - use unittest_tools - use solvers - use fields - use state_module - use elements - use sparse_tools - use mesh_files - implicit none - type(csr_matrix), intent(inout) :: A - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - logical, intent(in) :: vertical - type(scalar_field), optional, intent(in) :: H0 - integer, intent(in) :: ele - - ! Locations of quadrature points - real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad - ! H0 at quadrature points - real, dimension(ele_ngi(positions,ele)) :: H0_quad - ! Derivatives of shape function: - real, dimension(ele_loc(psi,ele), & - ele_ngi(psi,ele), positions%dim) :: dshape_psi - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of psi element. - integer, dimension(:), pointer :: ele_psi - ! Shape functions. - type(element_type), pointer :: shape_psi - ! Local Laplacian matrix - real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat - ! tensor - real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: & - tau_quad - integer :: i - - ele_psi=>ele_nodes(psi, ele) - shape_psi=>ele_shape(psi, ele) - - !tau_quad = 0.0 - !tau_quad(3,3,:) = 1.0 - !if(.not.vertical .or. positions%dim==2) then - ! tau_quad(1,1,:) = 1.0 - ! tau_quad(2,2,:) = 1.0 - !end if - - ! Locations of quadrature points. - X_quad=ele_val_at_quad(positions, ele) - - ! value of H0 at quadrature points - if(present(H0)) then - H0_quad=ele_val_at_quad(H0, ele) - else - H0_quad = 1.0 - end if - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& - & detwei=detwei) - - ! Local assembly: - !psi_mat=dshape_tensor_dshape(dshape_psi, tau_quad, dshape_psi, detwei) - psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei*H0_quad) - - ! Global assembly: - call addto(A, ele_psi, ele_psi, psi_mat) - -end subroutine assemble_laplacian_element_contribution - - end subroutine test_pressure_solve + end subroutine get_laplacian + + subroutine assemble_laplacian_element_contribution(A, positions, psi, ele, & + vertical,H0) + use unittest_tools + use solvers + use fields + use state_module + use elements + use sparse_tools + use mesh_files + implicit none + type(csr_matrix), intent(inout) :: A + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + logical, intent(in) :: vertical + type(scalar_field), optional, intent(in) :: H0 + integer, intent(in) :: ele + + ! Locations of quadrature points + real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad + ! H0 at quadrature points + real, dimension(ele_ngi(positions,ele)) :: H0_quad + ! Derivatives of shape function: + real, dimension(ele_loc(psi,ele), & + ele_ngi(psi,ele), positions%dim) :: dshape_psi + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of psi element. + integer, dimension(:), pointer :: ele_psi + ! Shape functions. + type(element_type), pointer :: shape_psi + ! Local Laplacian matrix + real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat + ! tensor + real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: & + tau_quad + integer :: i + + ele_psi=>ele_nodes(psi, ele) + shape_psi=>ele_shape(psi, ele) + + !tau_quad = 0.0 + !tau_quad(3,3,:) = 1.0 + !if(.not.vertical .or. positions%dim==2) then + ! tau_quad(1,1,:) = 1.0 + ! tau_quad(2,2,:) = 1.0 + !end if + + ! Locations of quadrature points. + X_quad=ele_val_at_quad(positions, ele) + + ! value of H0 at quadrature points + if(present(H0)) then + H0_quad=ele_val_at_quad(H0, ele) + else + H0_quad = 1.0 + end if + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& + & detwei=detwei) + + ! Local assembly: + !psi_mat=dshape_tensor_dshape(dshape_psi, tau_quad, dshape_psi, detwei) + psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei*H0_quad) + + ! Global assembly: + call addto(A, ele_psi, ele_psi, psi_mat) + + end subroutine assemble_laplacian_element_contribution + +end subroutine test_pressure_solve diff --git a/assemble/tests/test_relative_potential_vorticity.F90 b/assemble/tests/test_relative_potential_vorticity.F90 index 51b6f7ff1f..b52d37d7be 100644 --- a/assemble/tests/test_relative_potential_vorticity.F90 +++ b/assemble/tests/test_relative_potential_vorticity.F90 @@ -30,71 +30,71 @@ subroutine test_relative_potential_vorticity - use fields - use fldebug - use state_module - use unittest_tools - use vorticity_diagnostics - use vtk_interfaces - - implicit none - - character(len = 64) :: buffer - integer :: i - real :: max_val - real, dimension(3) :: pos - type(mesh_type), pointer :: mesh - type(scalar_field) :: perturbation_density, rel_pv - type(state_type) :: state - type(vector_field) :: velocity - type(vector_field), pointer :: positions - - call vtk_read_state("data/cube-itv5.vtu", state) - - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == 3) - mesh => positions%mesh - - call allocate(velocity, positions%dim, mesh, "Velocity") - call zero(velocity) - do i = 1, node_count(velocity) - pos = node_val(positions, i) - call set(velocity, i, 0.5 * (/-pos(2), pos(1), 0.0/)) - end do - call insert(state, velocity, velocity%name) - - call allocate(perturbation_density, mesh, "PerturbationDensity") - call zero(perturbation_density) - do i = 1, node_count(perturbation_density) - pos = node_val(positions, i) - call set(perturbation_density, i, -pos(3)) - end do - call insert(state, perturbation_density, perturbation_density%name) - - call allocate(rel_pv, mesh, "RelativePotentialVorticity") - call calculate_relative_potential_vorticity(state, rel_pv) - - call vtk_write_fields("data/test_relative_potential_vorticity_out", & - & position = positions, model = mesh, & - & sfields = (/perturbation_density, rel_pv/), & - & vfields = (/velocity/)) - - call deallocate(velocity) - call deallocate(perturbation_density) - - max_val = 0.0 - do i = 1, node_count(rel_pv) - max_val = max(max_val, abs(node_val(rel_pv, i) + 1.0)) - end do - - write(buffer, *) max_val - call report_test("[Rel. PV == -1.0]", & - & max_val .fne. 0.0, .false., & - & "Rel. PV /= -1.0 - Max. abs. diff: " // buffer) - - call deallocate(rel_pv) - call deallocate(state) - - call report_test_no_references() + use fields + use fldebug + use state_module + use unittest_tools + use vorticity_diagnostics + use vtk_interfaces + + implicit none + + character(len = 64) :: buffer + integer :: i + real :: max_val + real, dimension(3) :: pos + type(mesh_type), pointer :: mesh + type(scalar_field) :: perturbation_density, rel_pv + type(state_type) :: state + type(vector_field) :: velocity + type(vector_field), pointer :: positions + + call vtk_read_state("data/cube-itv5.vtu", state) + + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == 3) + mesh => positions%mesh + + call allocate(velocity, positions%dim, mesh, "Velocity") + call zero(velocity) + do i = 1, node_count(velocity) + pos = node_val(positions, i) + call set(velocity, i, 0.5 * (/-pos(2), pos(1), 0.0/)) + end do + call insert(state, velocity, velocity%name) + + call allocate(perturbation_density, mesh, "PerturbationDensity") + call zero(perturbation_density) + do i = 1, node_count(perturbation_density) + pos = node_val(positions, i) + call set(perturbation_density, i, -pos(3)) + end do + call insert(state, perturbation_density, perturbation_density%name) + + call allocate(rel_pv, mesh, "RelativePotentialVorticity") + call calculate_relative_potential_vorticity(state, rel_pv) + + call vtk_write_fields("data/test_relative_potential_vorticity_out", & + & position = positions, model = mesh, & + & sfields = (/perturbation_density, rel_pv/), & + & vfields = (/velocity/)) + + call deallocate(velocity) + call deallocate(perturbation_density) + + max_val = 0.0 + do i = 1, node_count(rel_pv) + max_val = max(max_val, abs(node_val(rel_pv, i) + 1.0)) + end do + + write(buffer, *) max_val + call report_test("[Rel. PV == -1.0]", & + & max_val .fne. 0.0, .false., & + & "Rel. PV /= -1.0 - Max. abs. diff: " // buffer) + + call deallocate(rel_pv) + call deallocate(state) + + call report_test_no_references() end subroutine test_relative_potential_vorticity diff --git a/assemble/tests/test_sam_integration.F90 b/assemble/tests/test_sam_integration.F90 index b7de33af31..5bd33a6a1e 100644 --- a/assemble/tests/test_sam_integration.F90 +++ b/assemble/tests/test_sam_integration.F90 @@ -1,53 +1,53 @@ subroutine test_sam_integration - use fldebug - use fields - use mesh_files - use conservative_interpolation_module - use unittest_tools - use state_module - use vtk_interfaces - use sam_integration - use spud - use reference_counting - use populate_state_module - implicit none - - type(vector_field) :: test_field_v - type(scalar_field), pointer :: ptr_field_s - type(vector_field), pointer :: ptr_field_v - type(mesh_type), pointer :: mesh_ptr - type(state_type), dimension(:), pointer :: states - logical :: fail - integer, dimension(10) :: options - integer :: stat - - call load_options("data/sam_integration.flml") - call populate_state(states) - - mesh_ptr => extract_mesh(states(1), "VelocityMesh") - call allocate(test_field_v, 3, mesh_ptr, "TestVector") - call set(test_field_v, (/2.0, 3.0, 4.0/)) - test_field_v%option_path = "/material_phase[0]/vector_field::TestVector" - call set_option("/geometry/dimension", 3, stat=stat) - call set_option("/material_phase[0]/vector_field::TestVector/name", "TestVector", stat=stat) - call set_option("/material_phase[0]/vector_field::TestVector/prognostic", "1.0", stat=stat) - call set_option("/material_phase[0]/vector_field::TestVector/prognostic/mesh[0]/name", "CoordinateMesh", stat=stat) - call insert(states(1), test_field_v, "TestVector") - call deallocate(test_field_v) - - call vtk_write_state("data/sam_integration", 0, state=states) - - options = (/0, 4, 1, 1, 1, 1, 0, 0, 0, 0/) - call sam_drive(states, options) - - call vtk_write_state("data/sam_integration", 1, state=states) - - ptr_field_s => extract_scalar_field(states(1), "TestScalar") - fail = (node_val(ptr_field_s, 1) /= 1.0) - call report_test("[sam_integration scalar]", fail, .false., "Keep a constant scalar field.") - - ptr_field_v => extract_vector_field(states(1), "TestVector") - fail = any(node_val(ptr_field_v, 1) /= (/2.0, 3.0, 4.0/)) - call report_test("[sam_integration vector]", fail, .false., "Keep a constant vector field.") + use fldebug + use fields + use mesh_files + use conservative_interpolation_module + use unittest_tools + use state_module + use vtk_interfaces + use sam_integration + use spud + use reference_counting + use populate_state_module + implicit none + + type(vector_field) :: test_field_v + type(scalar_field), pointer :: ptr_field_s + type(vector_field), pointer :: ptr_field_v + type(mesh_type), pointer :: mesh_ptr + type(state_type), dimension(:), pointer :: states + logical :: fail + integer, dimension(10) :: options + integer :: stat + + call load_options("data/sam_integration.flml") + call populate_state(states) + + mesh_ptr => extract_mesh(states(1), "VelocityMesh") + call allocate(test_field_v, 3, mesh_ptr, "TestVector") + call set(test_field_v, (/2.0, 3.0, 4.0/)) + test_field_v%option_path = "/material_phase[0]/vector_field::TestVector" + call set_option("/geometry/dimension", 3, stat=stat) + call set_option("/material_phase[0]/vector_field::TestVector/name", "TestVector", stat=stat) + call set_option("/material_phase[0]/vector_field::TestVector/prognostic", "1.0", stat=stat) + call set_option("/material_phase[0]/vector_field::TestVector/prognostic/mesh[0]/name", "CoordinateMesh", stat=stat) + call insert(states(1), test_field_v, "TestVector") + call deallocate(test_field_v) + + call vtk_write_state("data/sam_integration", 0, state=states) + + options = (/0, 4, 1, 1, 1, 1, 0, 0, 0, 0/) + call sam_drive(states, options) + + call vtk_write_state("data/sam_integration", 1, state=states) + + ptr_field_s => extract_scalar_field(states(1), "TestScalar") + fail = (node_val(ptr_field_s, 1) /= 1.0) + call report_test("[sam_integration scalar]", fail, .false., "Keep a constant scalar field.") + + ptr_field_v => extract_vector_field(states(1), "TestVector") + fail = any(node_val(ptr_field_v, 1) /= (/2.0, 3.0, 4.0/)) + call report_test("[sam_integration vector]", fail, .false., "Keep a constant vector field.") end subroutine test_sam_integration diff --git a/assemble/tests/test_sam_integration_2d.F90 b/assemble/tests/test_sam_integration_2d.F90 index 6448515b27..d985b32ec8 100644 --- a/assemble/tests/test_sam_integration_2d.F90 +++ b/assemble/tests/test_sam_integration_2d.F90 @@ -1,52 +1,52 @@ subroutine test_sam_integration_2d - use fields - use mesh_files - use conservative_interpolation_module - use unittest_tools - use state_module - use vtk_interfaces - use sam_integration - use spud - use reference_counting - use populate_state_module - implicit none - - type(vector_field) :: test_field_v - type(scalar_field), pointer :: ptr_field_s - type(vector_field), pointer :: ptr_field_v - type(mesh_type), pointer :: mesh_ptr - type(state_type), dimension(:), pointer :: states - logical :: fail - integer, dimension(10) :: options - integer :: stat - - call load_options("data/sam_integration_2d.flml") - call populate_state(states) - - mesh_ptr => extract_mesh(states(1), "VelocityMesh") - call allocate(test_field_v, 2, mesh_ptr, "TestVector") - call set(test_field_v, (/2.0, 3.0/)) - test_field_v%option_path = "/material_phase[0]/vector_field::TestVector" - call set_option("/geometry/dimension", 2, stat=stat) - call set_option("/material_phase[0]/vector_field::TestVector/name", "TestVector", stat=stat) - call set_option("/material_phase[0]/vector_field::TestVector/prognostic", "1.0", stat=stat) - call set_option("/material_phase[0]/vector_field::TestVector/prognostic/mesh[0]/name", "CoordinateMesh", stat=stat) - call insert(states(1), test_field_v, "TestVector") - call deallocate(test_field_v) - - call vtk_write_state("data/sam_integration", 0, state=states) - - options = (/0, 4, 1, 1, 1, 1, 0, 0, 0, 0/) - call sam_drive(states, options) - - call vtk_write_state("data/sam_integration", 1, state=states) - - ptr_field_s => extract_scalar_field(states(1), "TestScalar") - fail = (node_val(ptr_field_s, 1) /= 1.0) - call report_test("[sam_integration scalar]", fail, .false., "Keep a constant scalar field.") - - ptr_field_v => extract_vector_field(states(1), "TestVector") - fail = any(node_val(ptr_field_v, 1) /= (/2.0, 3.0/)) - call report_test("[sam_integration vector]", fail, .false., "Keep a constant vector field.") + use fields + use mesh_files + use conservative_interpolation_module + use unittest_tools + use state_module + use vtk_interfaces + use sam_integration + use spud + use reference_counting + use populate_state_module + implicit none + + type(vector_field) :: test_field_v + type(scalar_field), pointer :: ptr_field_s + type(vector_field), pointer :: ptr_field_v + type(mesh_type), pointer :: mesh_ptr + type(state_type), dimension(:), pointer :: states + logical :: fail + integer, dimension(10) :: options + integer :: stat + + call load_options("data/sam_integration_2d.flml") + call populate_state(states) + + mesh_ptr => extract_mesh(states(1), "VelocityMesh") + call allocate(test_field_v, 2, mesh_ptr, "TestVector") + call set(test_field_v, (/2.0, 3.0/)) + test_field_v%option_path = "/material_phase[0]/vector_field::TestVector" + call set_option("/geometry/dimension", 2, stat=stat) + call set_option("/material_phase[0]/vector_field::TestVector/name", "TestVector", stat=stat) + call set_option("/material_phase[0]/vector_field::TestVector/prognostic", "1.0", stat=stat) + call set_option("/material_phase[0]/vector_field::TestVector/prognostic/mesh[0]/name", "CoordinateMesh", stat=stat) + call insert(states(1), test_field_v, "TestVector") + call deallocate(test_field_v) + + call vtk_write_state("data/sam_integration", 0, state=states) + + options = (/0, 4, 1, 1, 1, 1, 0, 0, 0, 0/) + call sam_drive(states, options) + + call vtk_write_state("data/sam_integration", 1, state=states) + + ptr_field_s => extract_scalar_field(states(1), "TestScalar") + fail = (node_val(ptr_field_s, 1) /= 1.0) + call report_test("[sam_integration scalar]", fail, .false., "Keep a constant scalar field.") + + ptr_field_v => extract_vector_field(states(1), "TestVector") + fail = any(node_val(ptr_field_v, 1) /= (/2.0, 3.0/)) + call report_test("[sam_integration vector]", fail, .false., "Keep a constant vector field.") end subroutine test_sam_integration_2d diff --git a/assemble/tests/test_solenoidal_interpolation.F90 b/assemble/tests/test_solenoidal_interpolation.F90 index 27eb777824..a91c7e815a 100644 --- a/assemble/tests/test_solenoidal_interpolation.F90 +++ b/assemble/tests/test_solenoidal_interpolation.F90 @@ -3,106 +3,106 @@ subroutine test_solenoidal_interpolation - use fldebug - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use adapt_state_module - use field_derivatives - use vtk_interfaces - use solenoidal_interpolation_module - use global_parameters - use interpolation_module - use unittest_tools - use reference_counting - use diagnostic_fields_wrapper - - implicit none - - type(state_type), dimension(:), pointer :: states_old => null() - type(state_type), dimension(:), pointer :: states_new => null() - type(mesh_type), pointer :: u_mesh - type(vector_field), pointer :: u_old, u_new, x_old, x_new - type(scalar_field), pointer :: p_new, p_old - type(scalar_field), pointer :: div_new, div_old - type(state_type) :: interpolation_state_old, interpolation_state_new - logical :: fail - - call test_solenoidal_interpolation_file_A_to_B(file_A = "solenoidal_interpolation_A", & - file_B = "solenoidal_interpolation_B", & - div_name = "FiniteElementDivergence") - - call test_solenoidal_interpolation_file_A_to_B(file_A = "solenoidal_interpolation_press_cg_test_div_cv_A", & - file_B = "solenoidal_interpolation_press_cg_test_div_cv_B", & - div_name = "ControlVolumeDivergence") - - contains - - subroutine test_solenoidal_interpolation_file_A_to_B(file_A, file_B, div_name) - - character(len=*), intent(in) :: file_A, file_B, div_name - - ewrite(1,*) "Testing solenoidal interpolation between flml files: " - ewrite(1,*) " 1/ ",trim(file_A)//".flml" - ewrite(1,*) " 2/ ",trim(file_B)//".flml" - ewrite(1,*) "Using the divergence field: ",trim(div_name) - - call load_options("data/"//trim(file_A)//".flml") - call populate_state(states_old) - call clear_options - call load_options("data/"//trim(file_B)//".flml") - call populate_state(states_new) - - u_mesh => extract_mesh(states_old(1), "VelocityMesh") - u_old => extract_vector_field(states_old(1), "Velocity") - x_old => extract_vector_field(states_old(1), "Coordinate") - p_old => extract_scalar_field(states_old(1), "Pressure") - div_old => extract_scalar_field(states_old(1), trim(div_name)) - - u_new => extract_vector_field(states_new(1), "Velocity") - x_new => extract_vector_field(states_new(1), "Coordinate") - p_new => extract_scalar_field(states_new(1), "Pressure") - div_new => extract_scalar_field(states_new(1), trim(div_name)) - - call insert(interpolation_state_old, u_old, "Velocity") - call insert(interpolation_state_old, u_old%mesh, "Mesh") - call insert(interpolation_state_old, x_old, "Coordinate") - call insert(interpolation_state_new, u_new, "Velocity") - call insert(interpolation_state_new, u_new%mesh, "Mesh") - call insert(interpolation_state_new, x_new, "Coordinate") - call linear_interpolation(interpolation_state_old, interpolation_state_new) - call deallocate(interpolation_state_old) - call deallocate(interpolation_state_new) - - call calculate_diagnostic_variables(states_old) - - ewrite(1,*) "Initial max value of velocity divergence",maxval(div_old) - - call calculate_diagnostic_variables(states_new) - - ewrite(1,*) "After linear interpolation max value of velocity divergence",maxval(div_new) - - call vtk_write_state("data/"//trim(file_B), 0, state=states_old) - call vtk_write_state("data/"//trim(file_B), 1, state=states_new) - - call solenoidal_interpolation(u_new, x_new, p_new%mesh, p_new) - - call calculate_diagnostic_variables(states_new) - - ewrite(1,*) "After solenoidal interpolation max value of velocity divergence",maxval(div_new) - - call vtk_write_state("data/"//trim(file_B), 2, state=states_new) - - fail = maxval(div_new) > epsilon(0.0_4) - call report_test("[solenoidal interpolation: divergence free]", fail, .false., "Should be divergence-free!") - - call deallocate(states_old(1)) - call deallocate(states_new(1)) - call print_references(-1) - call clear_options + use fldebug + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use adapt_state_module + use field_derivatives + use vtk_interfaces + use solenoidal_interpolation_module + use global_parameters + use interpolation_module + use unittest_tools + use reference_counting + use diagnostic_fields_wrapper + + implicit none + + type(state_type), dimension(:), pointer :: states_old => null() + type(state_type), dimension(:), pointer :: states_new => null() + type(mesh_type), pointer :: u_mesh + type(vector_field), pointer :: u_old, u_new, x_old, x_new + type(scalar_field), pointer :: p_new, p_old + type(scalar_field), pointer :: div_new, div_old + type(state_type) :: interpolation_state_old, interpolation_state_new + logical :: fail + + call test_solenoidal_interpolation_file_A_to_B(file_A = "solenoidal_interpolation_A", & + file_B = "solenoidal_interpolation_B", & + div_name = "FiniteElementDivergence") + + call test_solenoidal_interpolation_file_A_to_B(file_A = "solenoidal_interpolation_press_cg_test_div_cv_A", & + file_B = "solenoidal_interpolation_press_cg_test_div_cv_B", & + div_name = "ControlVolumeDivergence") + +contains + + subroutine test_solenoidal_interpolation_file_A_to_B(file_A, file_B, div_name) + + character(len=*), intent(in) :: file_A, file_B, div_name + + ewrite(1,*) "Testing solenoidal interpolation between flml files: " + ewrite(1,*) " 1/ ",trim(file_A)//".flml" + ewrite(1,*) " 2/ ",trim(file_B)//".flml" + ewrite(1,*) "Using the divergence field: ",trim(div_name) + + call load_options("data/"//trim(file_A)//".flml") + call populate_state(states_old) + call clear_options + call load_options("data/"//trim(file_B)//".flml") + call populate_state(states_new) + + u_mesh => extract_mesh(states_old(1), "VelocityMesh") + u_old => extract_vector_field(states_old(1), "Velocity") + x_old => extract_vector_field(states_old(1), "Coordinate") + p_old => extract_scalar_field(states_old(1), "Pressure") + div_old => extract_scalar_field(states_old(1), trim(div_name)) + + u_new => extract_vector_field(states_new(1), "Velocity") + x_new => extract_vector_field(states_new(1), "Coordinate") + p_new => extract_scalar_field(states_new(1), "Pressure") + div_new => extract_scalar_field(states_new(1), trim(div_name)) + + call insert(interpolation_state_old, u_old, "Velocity") + call insert(interpolation_state_old, u_old%mesh, "Mesh") + call insert(interpolation_state_old, x_old, "Coordinate") + call insert(interpolation_state_new, u_new, "Velocity") + call insert(interpolation_state_new, u_new%mesh, "Mesh") + call insert(interpolation_state_new, x_new, "Coordinate") + call linear_interpolation(interpolation_state_old, interpolation_state_new) + call deallocate(interpolation_state_old) + call deallocate(interpolation_state_new) + + call calculate_diagnostic_variables(states_old) + + ewrite(1,*) "Initial max value of velocity divergence",maxval(div_old) + + call calculate_diagnostic_variables(states_new) + + ewrite(1,*) "After linear interpolation max value of velocity divergence",maxval(div_new) + + call vtk_write_state("data/"//trim(file_B), 0, state=states_old) + call vtk_write_state("data/"//trim(file_B), 1, state=states_new) + + call solenoidal_interpolation(u_new, x_new, p_new%mesh, p_new) + + call calculate_diagnostic_variables(states_new) + + ewrite(1,*) "After solenoidal interpolation max value of velocity divergence",maxval(div_new) + + call vtk_write_state("data/"//trim(file_B), 2, state=states_new) + + fail = maxval(div_new) > epsilon(0.0_4) + call report_test("[solenoidal interpolation: divergence free]", fail, .false., "Should be divergence-free!") + + call deallocate(states_old(1)) + call deallocate(states_new(1)) + call print_references(-1) + call clear_options end subroutine test_solenoidal_interpolation_file_A_to_B diff --git a/assemble/tests/test_sort_states_by_mesh.F90 b/assemble/tests/test_sort_states_by_mesh.F90 index d028a187e6..16d6e02516 100644 --- a/assemble/tests/test_sort_states_by_mesh.F90 +++ b/assemble/tests/test_sort_states_by_mesh.F90 @@ -2,53 +2,53 @@ subroutine test_sort_states_by_mesh - use fields - use populate_state_module - use spud - use state_module - use form_metric_field - use metric_assemble - use adapt_state_module - use field_derivatives - use vtk_interfaces - use conservative_interpolation_module - use global_parameters - use interpolation_module - use unittest_tools - implicit none - - type(state_type), dimension(:), pointer :: states => null() - type(state_type), dimension(:), allocatable :: sorted_states - integer :: state, sfield - type(scalar_field), pointer :: sfield_A, sfield_B - logical :: fail - - call load_options("data/cg_interpolation_A.flml") - call populate_state(states) - - call sort_states_by_mesh(states, sorted_states) - - fail = .false. - do state=1,size(sorted_states) - do sfield=2,scalar_field_count(sorted_states(state)) - sfield_A => extract_scalar_field(sorted_states(state), sfield-1) - sfield_B => extract_scalar_field(sorted_states(state), sfield) - fail = fail .or. (sfield_A%mesh%refcount%id /= sfield_B%mesh%refcount%id) - end do - end do - - call report_test("[sort_states_by_mesh]", fail, .false., "Ah, whatever") - - do state = 1, size(states) - call deallocate(states(state)) - end do - deallocate(states) - - do state = 1, size(sorted_states) - call deallocate(sorted_states(state)) - end do - deallocate(sorted_states) - - call report_test_no_references() + use fields + use populate_state_module + use spud + use state_module + use form_metric_field + use metric_assemble + use adapt_state_module + use field_derivatives + use vtk_interfaces + use conservative_interpolation_module + use global_parameters + use interpolation_module + use unittest_tools + implicit none + + type(state_type), dimension(:), pointer :: states => null() + type(state_type), dimension(:), allocatable :: sorted_states + integer :: state, sfield + type(scalar_field), pointer :: sfield_A, sfield_B + logical :: fail + + call load_options("data/cg_interpolation_A.flml") + call populate_state(states) + + call sort_states_by_mesh(states, sorted_states) + + fail = .false. + do state=1,size(sorted_states) + do sfield=2,scalar_field_count(sorted_states(state)) + sfield_A => extract_scalar_field(sorted_states(state), sfield-1) + sfield_B => extract_scalar_field(sorted_states(state), sfield) + fail = fail .or. (sfield_A%mesh%refcount%id /= sfield_B%mesh%refcount%id) + end do + end do + + call report_test("[sort_states_by_mesh]", fail, .false., "Ah, whatever") + + do state = 1, size(states) + call deallocate(states(state)) + end do + deallocate(states) + + do state = 1, size(sorted_states) + call deallocate(sorted_states(state)) + end do + deallocate(sorted_states) + + call report_test_no_references() end subroutine test_sort_states_by_mesh diff --git a/assemble/tests/test_strip_level_2_halo.F90 b/assemble/tests/test_strip_level_2_halo.F90 index 479ec7626a..6eaebd9e36 100644 --- a/assemble/tests/test_strip_level_2_halo.F90 +++ b/assemble/tests/test_strip_level_2_halo.F90 @@ -29,226 +29,226 @@ subroutine test_strip_level_2_halo - use fldebug - use fields - use halos - use parallel_tools - use mesh_files - use reserve_state_module - use sam_integration - use spud - use state_module - use unittest_tools - - implicit none + use fldebug + use fields + use halos + use parallel_tools + use mesh_files + use reserve_state_module + use sam_integration + use spud + use state_module + use unittest_tools + + implicit none #ifdef HAVE_ADAPTIVITY - interface - subroutine flstriph2(nnodes, nprivatenodes, nprocs, & + interface + subroutine flstriph2(nnodes, nprivatenodes, nprocs, & & volumeenlist, nvolumeelems, nloc, & & surfaceenlist, surfaceids, nsurfaceelems, snloc, & & x, y, z, & & fields, nfields, fstride, & & metric, & & scatter, nscatter) - implicit none - integer, intent(inout) :: nnodes - integer, intent(in) :: nprivatenodes - integer, intent(in) :: nprocs - integer, intent(inout) :: nvolumeelems - integer, intent(in) :: nloc - integer, dimension(nvolumeelems * nloc), intent(inout) :: volumeenlist - integer, intent(inout) :: nsurfaceelems - integer, intent(in) :: snloc - integer, dimension(nsurfaceelems * snloc), intent(inout) :: surfaceenlist - integer, dimension(nsurfaceelems), intent(inout) :: surfaceids - real, dimension(nnodes), intent(inout) :: x - real, dimension(nnodes), intent(inout) :: y - real, dimension(nnodes), intent(inout) :: z - integer, intent(inout) :: nfields - integer, intent(inout) :: fstride - real, dimension(nnodes * nfields * fstride), intent(inout) :: fields - real, dimension(nnodes * 9), intent(inout) :: metric - integer, intent(inout) :: nscatter - integer, dimension(nscatter), intent(inout) :: scatter - end subroutine flstriph2 - end interface - - integer :: dim, i, j, new_nsurfaceelems, stat - integer, dimension(:), allocatable :: new_scatter, new_surfaceenlist, new_surfaceids, nreceives - type(halo_type), pointer :: halo - type(mesh_type), pointer :: mesh - type(state_type) :: state, state_array(1) - type(vector_field), target :: mesh_field - - ! flstriph2 variables - integer :: nnodes, nprivatenodes, nprocs - integer, dimension(:), allocatable :: volumeenlist - integer :: nvolumeelems, nloc - integer, dimension(:), allocatable :: surfaceenlist, surfaceids - integer :: nsurfaceelems, snloc - real, dimension(:), allocatable :: x, y, z, input_fields - integer :: nfields, fstride - real, dimension(:), allocatable :: metric - integer, dimension(:), allocatable :: scatter - integer :: nscatter - - mesh_field = read_mesh_files("data/cube-parallel_0", quad_degree = 1, format="gmsh") - call read_halos("data/cube-parallel", mesh_field) - assert(halo_count(mesh_field) > 0) - halo => mesh_field%mesh%halos(1) - - mesh => mesh_field%mesh - - assert(mesh_dim(mesh_field) == 3) - dim = mesh_dim(mesh_field) - - nnodes = node_count(mesh) - nprivatenodes = halo_nowned_nodes(halo) - nprocs = halo_proc_count(halo) - - nvolumeelems = ele_count(mesh) - assert(nvolumeelems > 0) - nloc = ele_loc(mesh, 1) + implicit none + integer, intent(inout) :: nnodes + integer, intent(in) :: nprivatenodes + integer, intent(in) :: nprocs + integer, intent(inout) :: nvolumeelems + integer, intent(in) :: nloc + integer, dimension(nvolumeelems * nloc), intent(inout) :: volumeenlist + integer, intent(inout) :: nsurfaceelems + integer, intent(in) :: snloc + integer, dimension(nsurfaceelems * snloc), intent(inout) :: surfaceenlist + integer, dimension(nsurfaceelems), intent(inout) :: surfaceids + real, dimension(nnodes), intent(inout) :: x + real, dimension(nnodes), intent(inout) :: y + real, dimension(nnodes), intent(inout) :: z + integer, intent(inout) :: nfields + integer, intent(inout) :: fstride + real, dimension(nnodes * nfields * fstride), intent(inout) :: fields + real, dimension(nnodes * 9), intent(inout) :: metric + integer, intent(inout) :: nscatter + integer, dimension(nscatter), intent(inout) :: scatter + end subroutine flstriph2 + end interface + + integer :: dim, i, j, new_nsurfaceelems, stat + integer, dimension(:), allocatable :: new_scatter, new_surfaceenlist, new_surfaceids, nreceives + type(halo_type), pointer :: halo + type(mesh_type), pointer :: mesh + type(state_type) :: state, state_array(1) + type(vector_field), target :: mesh_field + + ! flstriph2 variables + integer :: nnodes, nprivatenodes, nprocs + integer, dimension(:), allocatable :: volumeenlist + integer :: nvolumeelems, nloc + integer, dimension(:), allocatable :: surfaceenlist, surfaceids + integer :: nsurfaceelems, snloc + real, dimension(:), allocatable :: x, y, z, input_fields + integer :: nfields, fstride + real, dimension(:), allocatable :: metric + integer, dimension(:), allocatable :: scatter + integer :: nscatter + + mesh_field = read_mesh_files("data/cube-parallel_0", quad_degree = 1, format="gmsh") + call read_halos("data/cube-parallel", mesh_field) + assert(halo_count(mesh_field) > 0) + halo => mesh_field%mesh%halos(1) + + mesh => mesh_field%mesh + + assert(mesh_dim(mesh_field) == 3) + dim = mesh_dim(mesh_field) + + nnodes = node_count(mesh) + nprivatenodes = halo_nowned_nodes(halo) + nprocs = halo_proc_count(halo) + + nvolumeelems = ele_count(mesh) + assert(nvolumeelems > 0) + nloc = ele_loc(mesh, 1) #ifdef DDEBUG - do i = 2, nvolumeelems - assert(ele_loc(mesh, i) == nloc) - end do + do i = 2, nvolumeelems + assert(ele_loc(mesh, i) == nloc) + end do #endif - allocate(volumeenlist(nvolumeelems * nloc)) - volumeenlist = mesh%ndglno + allocate(volumeenlist(nvolumeelems * nloc)) + volumeenlist = mesh%ndglno - nsurfaceelems = surface_element_count(mesh) - assert(nsurfaceelems > 0) - snloc = face_loc(mesh, 1) + nsurfaceelems = surface_element_count(mesh) + assert(nsurfaceelems > 0) + snloc = face_loc(mesh, 1) #ifdef DDEBUG - do i = 2, nsurfaceelems - assert(face_loc(mesh, i) == snloc) - end do + do i = 2, nsurfaceelems + assert(face_loc(mesh, i) == snloc) + end do #endif - allocate(surfaceenlist(nsurfaceelems * snloc)) - call getsndgln(mesh, surfaceenlist) - allocate(surfaceids(nsurfaceelems)) - if(associated(mesh%faces%boundary_ids)) then - surfaceids = mesh%faces%boundary_ids - else - surfaceids = 0 - end if - - allocate(x(nnodes)) - allocate(y(nnodes)) - allocate(z(nnodes)) - x = mesh_field%val(1,:) - y = mesh_field%val(2,:) - z = mesh_field%val(3,:) - - nfields = 0 - fstride = nnodes - allocate(input_fields(nfields * fstride)) - if(size(input_fields) > 0) then - input_fields = 0 - end if - - allocate(metric(nnodes * dim ** 2)) - ! Construct a unit matrix - metric = 0.0 - do i = 1, nnodes - do j = 1, dim - metric((i - 1) * dim ** 2 + (j - 1) * dim + j) = 1.0 - end do - end do - - nscatter = halo_all_receives_count(halo) - allocate(scatter(nscatter)) - allocate(nreceives(halo_proc_count(halo))) - call extract_all_halo_receives(halo, scatter, nreceives) - deallocate(nreceives) - - call flstriph2(nnodes, nprivatenodes, nprocs, & - & volumeenlist, nvolumeelems, nloc, & - & surfaceenlist, surfaceids, nsurfaceelems, snloc, & - & x, y, z, & - & input_fields, nfields, fstride, & - & metric, & - & scatter, nscatter) - - call report_test("[nprivatenodes unchanged]", nprivatenodes /= halo_nowned_nodes(halo), .false., "flstriph2 has changed nprivatenodes") - call report_test("[nprocs unchanged]", nprocs /= halo_proc_count(halo), .false., "flstriph2 has changed nprocs") - call report_test("[nloc unchanged]", nloc /= ele_loc(mesh, 1), .false., "flstriph2 has changed nloc") - call report_test("[snloc unchanged]", snloc /= face_loc(mesh, 1), .false., "flstriph2 has changed snloc") - call report_test("[nscatter unchanged]", nscatter /= halo_all_receives_count(halo), .false., "flstriph2 has changed nscatter") - - call insert(state, mesh, "CoordinateMesh") - call insert(state, mesh_field, "Coordinate") - - call add_option("/geometry/mesh", stat = stat) - call set_option_attribute("/geometry/mesh/name", "CoordinateMesh", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call add_option("/geometry/mesh/from_file", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - - call deallocate(mesh_field) - - state_array(1) = state - call create_reserve_state(state_array) - - call strip_level_2_halo(state_array) - state = state_array(1) - - mesh => extract_mesh(state, "CoordinateMesh") - call report_test("[Same node count]", nnodes /= node_count(mesh), .false., "Node counts returned by strip_level_2_halo and flstriph2 are different") - call report_test("[Same element count]", nvolumeelems /= ele_count(mesh), .false., "Element counts returned by strip_level_2_halo and flstriph2 are different") - call report_test("[Same element numbering]", any(mesh%ndglno /= volumeenlist(1:nvolumeelems * nloc)), .false., "Element numberings returned by strip_level_2_halo and flstriph2 are different") - - allocate(new_surfaceenlist(surface_element_count(mesh) * face_loc(mesh, 1))) - allocate(new_surfaceids(surface_element_count(mesh))) - call getsndgln(mesh, new_surfaceenlist) - assert(associated(mesh%faces%boundary_ids)) - new_surfaceids = mesh%faces%boundary_ids - ! Strip off the surface elements with ID 0 added by add_faces - new_nsurfaceelems = 0 - do i = 1, surface_element_count(mesh) - if(new_surfaceids(i) /= 0) then - new_nsurfaceelems = new_nsurfaceelems + 1 - new_surfaceenlist((new_nsurfaceelems - 1) * face_loc(mesh, 1) + 1:new_nsurfaceelems * face_loc(mesh, 1)) = new_surfaceenlist((i - 1) * face_loc(mesh, 1) + 1:i * face_loc(mesh, 1)) - new_surfaceids(new_nsurfaceelems) = new_surfaceids(i) - end if - end do - call report_test("[Same surface element count]", nsurfaceelems /= new_nsurfaceelems, .false., "Surface element counts returned by strip_level_2_halo and flstriph2 are different") - call report_test("[Same surface element numbering]", any(new_surfaceenlist(1:new_nsurfaceelems * face_loc(mesh, 1)) /= surfaceenlist(1:nsurfaceelems * snloc)), .false., "Surface element numberings returned by strip_level_2_halo and flstriph2 are different") - call report_test("[Same surface IDs]", any(new_surfaceids(1:new_nsurfaceelems) /= surfaceids(1:nsurfaceelems)), .false., "Surface IDs returned by strip_level_2_halo and flstriph2 are different") - deallocate(new_surfaceenlist) - deallocate(new_surfaceids) - - mesh_field = extract_vector_field(state, "Coordinate") - assert(mesh_dim(mesh_field) == 3) - call report_test("[Same x coordinates]", any(mesh_field%val(1,:) /= x(1:nnodes)), .false., "x coordinates returned by strip_level_2_halo and flstriph2 are different") - call report_test("[Same y coordinates]", any(mesh_field%val(2,:) /= y(1:nnodes)), .false., "y coordinates returned by strip_level_2_halo and flstriph2 are different") - call report_test("[Same z coordinates]", any(mesh_field%val(3,:) /= z(1:nnodes)), .false., "z coordinates returned by strip_level_2_halo and flstriph2 are different") - - call report_test("[Same number of level 1 receive nodes]", halo_all_receives_count(mesh_field%mesh%halos(1)) /= nscatter, .false., "Number of level 1 receive nodes returned by strip_level_2_halo and flstriph2 are different") - allocate(new_scatter(halo_all_receives_count(mesh_field%mesh%halos(1)))) - allocate(nreceives(halo_proc_count(mesh_field%mesh%halos(1)))) - call extract_all_halo_receives(mesh_field%mesh%halos(1), new_scatter, nreceives) - deallocate(nreceives) - call report_test("[Same level 1 receive nodes]", any(new_scatter /= scatter(1:nscatter)), .false., "Level 1 receive nodes returned by strip_level_2_halo and flstriph2 are different") - deallocate(new_scatter) - - deallocate(volumeenlist) - deallocate(surfaceenlist) - deallocate(surfaceids) - deallocate(x) - deallocate(y) - deallocate(z) - deallocate(scatter) - deallocate(input_fields) - deallocate(metric) - - call deallocate(state) - - call report_test_no_references() + allocate(surfaceenlist(nsurfaceelems * snloc)) + call getsndgln(mesh, surfaceenlist) + allocate(surfaceids(nsurfaceelems)) + if(associated(mesh%faces%boundary_ids)) then + surfaceids = mesh%faces%boundary_ids + else + surfaceids = 0 + end if + + allocate(x(nnodes)) + allocate(y(nnodes)) + allocate(z(nnodes)) + x = mesh_field%val(1,:) + y = mesh_field%val(2,:) + z = mesh_field%val(3,:) + + nfields = 0 + fstride = nnodes + allocate(input_fields(nfields * fstride)) + if(size(input_fields) > 0) then + input_fields = 0 + end if + + allocate(metric(nnodes * dim ** 2)) + ! Construct a unit matrix + metric = 0.0 + do i = 1, nnodes + do j = 1, dim + metric((i - 1) * dim ** 2 + (j - 1) * dim + j) = 1.0 + end do + end do + + nscatter = halo_all_receives_count(halo) + allocate(scatter(nscatter)) + allocate(nreceives(halo_proc_count(halo))) + call extract_all_halo_receives(halo, scatter, nreceives) + deallocate(nreceives) + + call flstriph2(nnodes, nprivatenodes, nprocs, & + & volumeenlist, nvolumeelems, nloc, & + & surfaceenlist, surfaceids, nsurfaceelems, snloc, & + & x, y, z, & + & input_fields, nfields, fstride, & + & metric, & + & scatter, nscatter) + + call report_test("[nprivatenodes unchanged]", nprivatenodes /= halo_nowned_nodes(halo), .false., "flstriph2 has changed nprivatenodes") + call report_test("[nprocs unchanged]", nprocs /= halo_proc_count(halo), .false., "flstriph2 has changed nprocs") + call report_test("[nloc unchanged]", nloc /= ele_loc(mesh, 1), .false., "flstriph2 has changed nloc") + call report_test("[snloc unchanged]", snloc /= face_loc(mesh, 1), .false., "flstriph2 has changed snloc") + call report_test("[nscatter unchanged]", nscatter /= halo_all_receives_count(halo), .false., "flstriph2 has changed nscatter") + + call insert(state, mesh, "CoordinateMesh") + call insert(state, mesh_field, "Coordinate") + + call add_option("/geometry/mesh", stat = stat) + call set_option_attribute("/geometry/mesh/name", "CoordinateMesh", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call add_option("/geometry/mesh/from_file", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + + call deallocate(mesh_field) + + state_array(1) = state + call create_reserve_state(state_array) + + call strip_level_2_halo(state_array) + state = state_array(1) + + mesh => extract_mesh(state, "CoordinateMesh") + call report_test("[Same node count]", nnodes /= node_count(mesh), .false., "Node counts returned by strip_level_2_halo and flstriph2 are different") + call report_test("[Same element count]", nvolumeelems /= ele_count(mesh), .false., "Element counts returned by strip_level_2_halo and flstriph2 are different") + call report_test("[Same element numbering]", any(mesh%ndglno /= volumeenlist(1:nvolumeelems * nloc)), .false., "Element numberings returned by strip_level_2_halo and flstriph2 are different") + + allocate(new_surfaceenlist(surface_element_count(mesh) * face_loc(mesh, 1))) + allocate(new_surfaceids(surface_element_count(mesh))) + call getsndgln(mesh, new_surfaceenlist) + assert(associated(mesh%faces%boundary_ids)) + new_surfaceids = mesh%faces%boundary_ids + ! Strip off the surface elements with ID 0 added by add_faces + new_nsurfaceelems = 0 + do i = 1, surface_element_count(mesh) + if(new_surfaceids(i) /= 0) then + new_nsurfaceelems = new_nsurfaceelems + 1 + new_surfaceenlist((new_nsurfaceelems - 1) * face_loc(mesh, 1) + 1:new_nsurfaceelems * face_loc(mesh, 1)) = new_surfaceenlist((i - 1) * face_loc(mesh, 1) + 1:i * face_loc(mesh, 1)) + new_surfaceids(new_nsurfaceelems) = new_surfaceids(i) + end if + end do + call report_test("[Same surface element count]", nsurfaceelems /= new_nsurfaceelems, .false., "Surface element counts returned by strip_level_2_halo and flstriph2 are different") + call report_test("[Same surface element numbering]", any(new_surfaceenlist(1:new_nsurfaceelems * face_loc(mesh, 1)) /= surfaceenlist(1:nsurfaceelems * snloc)), .false., "Surface element numberings returned by strip_level_2_halo and flstriph2 are different") + call report_test("[Same surface IDs]", any(new_surfaceids(1:new_nsurfaceelems) /= surfaceids(1:nsurfaceelems)), .false., "Surface IDs returned by strip_level_2_halo and flstriph2 are different") + deallocate(new_surfaceenlist) + deallocate(new_surfaceids) + + mesh_field = extract_vector_field(state, "Coordinate") + assert(mesh_dim(mesh_field) == 3) + call report_test("[Same x coordinates]", any(mesh_field%val(1,:) /= x(1:nnodes)), .false., "x coordinates returned by strip_level_2_halo and flstriph2 are different") + call report_test("[Same y coordinates]", any(mesh_field%val(2,:) /= y(1:nnodes)), .false., "y coordinates returned by strip_level_2_halo and flstriph2 are different") + call report_test("[Same z coordinates]", any(mesh_field%val(3,:) /= z(1:nnodes)), .false., "z coordinates returned by strip_level_2_halo and flstriph2 are different") + + call report_test("[Same number of level 1 receive nodes]", halo_all_receives_count(mesh_field%mesh%halos(1)) /= nscatter, .false., "Number of level 1 receive nodes returned by strip_level_2_halo and flstriph2 are different") + allocate(new_scatter(halo_all_receives_count(mesh_field%mesh%halos(1)))) + allocate(nreceives(halo_proc_count(mesh_field%mesh%halos(1)))) + call extract_all_halo_receives(mesh_field%mesh%halos(1), new_scatter, nreceives) + deallocate(nreceives) + call report_test("[Same level 1 receive nodes]", any(new_scatter /= scatter(1:nscatter)), .false., "Level 1 receive nodes returned by strip_level_2_halo and flstriph2 are different") + deallocate(new_scatter) + + deallocate(volumeenlist) + deallocate(surfaceenlist) + deallocate(surfaceids) + deallocate(x) + deallocate(y) + deallocate(z) + deallocate(scatter) + deallocate(input_fields) + deallocate(metric) + + call deallocate(state) + + call report_test_no_references() #else - call report_test("[test disabled]", .false., .true., "Test compiled without sam support") + call report_test("[test disabled]", .false., .true., "Test compiled without sam support") #endif end subroutine test_strip_level_2_halo diff --git a/assemble/tests/test_vertical_extrapolation.F90 b/assemble/tests/test_vertical_extrapolation.F90 index 67b9471f57..fe350a83c2 100644 --- a/assemble/tests/test_vertical_extrapolation.F90 +++ b/assemble/tests/test_vertical_extrapolation.F90 @@ -1,118 +1,118 @@ subroutine test_vertical_extrapolation() -use quadrature -use elements -use fields -use state_module -use mesh_files -use boundary_conditions -use vertical_extrapolation_module -use fields_calculations -use vtk_interfaces -use unittest_tools -implicit none - - character, parameter:: NEWLINE_CHAR=achar(10) - ! vertically constant: - character(len=*), parameter:: PYTHON_FUNCTION1= & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])" - ! the mesh files should have the top surface marked with boundary id 1 - integer, dimension(1), parameter:: TOP_BOUNDARY_IDS=(/ 2 /) - integer, parameter:: QUAD_DEGREE=4, NVERTICES=4, DIM=3 - integer, parameter:: POLY_DEGREE=2 ! degree of fields we're integrating - - logical fail - real l2error - - call test_vertical_extrapolation_from_file("data/cube_prismatic", & - PYTHON_FUNCTION1, l2error) - fail= l2error>1e-10 - call report_test("[test_vertical_extrapolation_prismatic]", fail, .false., & - "Too large error in vertical extrapolation on prismatic mesh.") - - call test_vertical_extrapolation_from_file("data/cube_unstructured", & - PYTHON_FUNCTION1, l2error) - fail= l2error>1e-3 - call report_test("[test_vertical_extrapolation_unstructured]", fail, .false., & - "Too large error in vertical extrapolation on unstructured mesh.") + use quadrature + use elements + use fields + use state_module + use mesh_files + use boundary_conditions + use vertical_extrapolation_module + use fields_calculations + use vtk_interfaces + use unittest_tools + implicit none + + character, parameter:: NEWLINE_CHAR=achar(10) + ! vertically constant: + character(len=*), parameter:: PYTHON_FUNCTION1= & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])" + ! the mesh files should have the top surface marked with boundary id 1 + integer, dimension(1), parameter:: TOP_BOUNDARY_IDS=(/ 2 /) + integer, parameter:: QUAD_DEGREE=4, NVERTICES=4, DIM=3 + integer, parameter:: POLY_DEGREE=2 ! degree of fields we're integrating + + logical fail + real l2error + + call test_vertical_extrapolation_from_file("data/cube_prismatic", & + PYTHON_FUNCTION1, l2error) + fail= l2error>1e-10 + call report_test("[test_vertical_extrapolation_prismatic]", fail, .false., & + "Too large error in vertical extrapolation on prismatic mesh.") + + call test_vertical_extrapolation_from_file("data/cube_unstructured", & + PYTHON_FUNCTION1, l2error) + fail= l2error>1e-3 + call report_test("[test_vertical_extrapolation_unstructured]", fail, .false., & + "Too large error in vertical extrapolation on unstructured mesh.") contains -subroutine test_vertical_extrapolation_from_file(mesh_file, & - python_function, l2error) -character(len=*), intent(in):: mesh_file -character(len=*), intent(in):: python_function -real, intent(out):: l2error - - type(vector_field), target:: positions, bc_positions, vertical_normal - type(scalar_field) to_field, from_field, error_field, from_surface_field - type(mesh_type), pointer:: x_mesh, surface_mesh - type(mesh_type) dg_quad_mesh - type(element_type) quad_shape - type(quadrature_type) quad - integer, dimension(:), pointer:: surface_element_list - integer:: i, sele - - positions=read_mesh_files(mesh_file, quad_degree=QUAD_DEGREE, format="gmsh") - x_mesh => positions%mesh - - ! we're going to extrapolate downwards onto a quadratic DG field: - quad=x_mesh%shape%quadrature - quad_shape=make_element_shape(NVERTICES, DIM, POLY_DEGREE, quad) - dg_quad_mesh=make_mesh(x_mesh, shape=quad_shape, continuity=-1, & - name="DGMesh") - call allocate(to_field, dg_quad_mesh, name="ToField") - - ! set the function on the top of the mesh: - call add_boundary_condition(to_field, "Top", type="Dummy", & - boundary_ids=TOP_BOUNDARY_IDS ) - call get_boundary_condition(to_field, "Top", & - surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - call allocate(from_surface_field, surface_mesh, name="FromSurfaceField") - call allocate(bc_positions, DIM, surface_mesh, name="BCPositions") - call remap_field_to_surface(positions, bc_positions, surface_element_list) - call set_from_python_function(from_surface_field, python_function, bc_positions, & - time=0.0) - ! map values of from_surface_field on faces of from_field - call allocate(from_field, dg_quad_mesh, name="FromField") - ! make sure other values are not used: - call set(from_field, huge(0.0)) - do i=1, size(surface_element_list) - sele=surface_element_list(i) - call set(from_field, face_global_nodes(dg_quad_mesh, i), & - ele_val(from_surface_field, i)) - end do - - call allocate(vertical_normal, positions%dim, x_mesh, & - field_type=FIELD_TYPE_CONSTANT, name="VerticalNormal") - call set(vertical_normal, (/ 0., 0., -1. /) ) - - call VerticalExtrapolation(from_field, to_field, positions, & - vertical_normal, surface_element_list) - - call allocate(error_field, dg_quad_mesh, name="ErrorField") - ! first set it to the reference solution using the same python function - call set_from_python_function(error_field, python_function, positions, & - time=0.0) - ! then subtract the found solution: - call addto(error_field, to_field, scale=-1.0) + subroutine test_vertical_extrapolation_from_file(mesh_file, & + python_function, l2error) + character(len=*), intent(in):: mesh_file + character(len=*), intent(in):: python_function + real, intent(out):: l2error + + type(vector_field), target:: positions, bc_positions, vertical_normal + type(scalar_field) to_field, from_field, error_field, from_surface_field + type(mesh_type), pointer:: x_mesh, surface_mesh + type(mesh_type) dg_quad_mesh + type(element_type) quad_shape + type(quadrature_type) quad + integer, dimension(:), pointer:: surface_element_list + integer:: i, sele + + positions=read_mesh_files(mesh_file, quad_degree=QUAD_DEGREE, format="gmsh") + x_mesh => positions%mesh + + ! we're going to extrapolate downwards onto a quadratic DG field: + quad=x_mesh%shape%quadrature + quad_shape=make_element_shape(NVERTICES, DIM, POLY_DEGREE, quad) + dg_quad_mesh=make_mesh(x_mesh, shape=quad_shape, continuity=-1, & + name="DGMesh") + call allocate(to_field, dg_quad_mesh, name="ToField") + + ! set the function on the top of the mesh: + call add_boundary_condition(to_field, "Top", type="Dummy", & + boundary_ids=TOP_BOUNDARY_IDS ) + call get_boundary_condition(to_field, "Top", & + surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + call allocate(from_surface_field, surface_mesh, name="FromSurfaceField") + call allocate(bc_positions, DIM, surface_mesh, name="BCPositions") + call remap_field_to_surface(positions, bc_positions, surface_element_list) + call set_from_python_function(from_surface_field, python_function, bc_positions, & + time=0.0) + ! map values of from_surface_field on faces of from_field + call allocate(from_field, dg_quad_mesh, name="FromField") + ! make sure other values are not used: + call set(from_field, huge(0.0)) + do i=1, size(surface_element_list) + sele=surface_element_list(i) + call set(from_field, face_global_nodes(dg_quad_mesh, i), & + ele_val(from_surface_field, i)) + end do + + call allocate(vertical_normal, positions%dim, x_mesh, & + field_type=FIELD_TYPE_CONSTANT, name="VerticalNormal") + call set(vertical_normal, (/ 0., 0., -1. /) ) + + call VerticalExtrapolation(from_field, to_field, positions, & + vertical_normal, surface_element_list) + + call allocate(error_field, dg_quad_mesh, name="ErrorField") + ! first set it to the reference solution using the same python function + call set_from_python_function(error_field, python_function, positions, & + time=0.0) + ! then subtract the found solution: + call addto(error_field, to_field, scale=-1.0) ! call vtk_write_fields(mesh_file, 0, & ! positions, dg_quad_mesh, sfields=(/ from_field, to_field, error_field /)) - l2error=norm2(error_field, positions) - print *, l2error + l2error=norm2(error_field, positions) + print *, l2error - call deallocate(to_field) - call deallocate(from_field) - call deallocate(from_surface_field) - call deallocate(error_field) - call deallocate(bc_positions) - call deallocate(vertical_normal) + call deallocate(to_field) + call deallocate(from_field) + call deallocate(from_surface_field) + call deallocate(error_field) + call deallocate(bc_positions) + call deallocate(vertical_normal) -end subroutine test_vertical_extrapolation_from_file + end subroutine test_vertical_extrapolation_from_file end subroutine test_vertical_extrapolation diff --git a/assemble/tests/test_vertical_integration.F90 b/assemble/tests/test_vertical_integration.F90 index 174a5494cc..fbdbb0a893 100644 --- a/assemble/tests/test_vertical_integration.F90 +++ b/assemble/tests/test_vertical_integration.F90 @@ -1,156 +1,156 @@ subroutine test_vertical_integration() -use quadrature -use elements -use fields -use state_module -use mesh_files -use boundary_conditions -use vertical_extrapolation_module -use fields_calculations -use vtk_interfaces -use unittest_tools -implicit none - - character, parameter:: NEWLINE_CHAR=achar(10) - ! vertically constant: - character(len=*), parameter:: PYTHON_FUNCTION1= & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])" - ! function with vertical derivative: - character(len=*), parameter:: PYTHON_FUNCTION2= & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])*math.cos(math.pi*X[2])" - ! its vertical derivative (note gravity is in -X[2] direction): - character(len=*), parameter:: PYTHON_FUNCTION_DERIVATIVE= & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return math.pi*math.cos(math.pi*X[0])*math.sin(math.pi*X[1])*math.sin(math.pi*X[2])" - ! the mesh files should have the top surface marked with boundary id 1 - integer, dimension(1), parameter:: TOP_BOUNDARY_IDS=(/ 1 /) - integer, parameter:: QUAD_DEGREE=4, NVERTICES=4, DIM=3 - integer, parameter:: POLY_DEGREE=2 ! degree of fields we're integrating - real, dimension(1:DIM), parameter:: DOWN=(/ 0.0, 0.0, -1.0 /) - - logical fail - real l2error - - call test_vertical_integration_from_file("data/cube_prismatic", & - PYTHON_FUNCTION1, l2error=l2error) - fail= l2error>1e-10 - call report_test("[test_vertical_integration_prismatic]", fail, .false., & - "Too large error in vertical integration on prismatic mesh.") - - call test_vertical_integration_from_file("data/cube_unstructured", & - PYTHON_FUNCTION1, l2error=l2error) - fail= l2error>2e-3 - call report_test("[test_vertical_integration_unstructured]", fail, .false., & - "Too large error in vertical integration on unstructured mesh.") - - call test_vertical_integration_from_file("data/cube_prismatic", & - PYTHON_FUNCTION2, python_function_derivative=PYTHON_FUNCTION_DERIVATIVE, & - l2error=l2error) - fail= l2error>1e-3 - call report_test("[test_vertical_integration_prismatic_gradient]", fail, .false., & - "Too large error in vertical integration on prismatic mesh.") - - call test_vertical_integration_from_file("data/cube_unstructured", & - PYTHON_FUNCTION2, python_function_derivative=PYTHON_FUNCTION_DERIVATIVE, & - l2error=l2error) - fail= l2error>5e-3 - call report_test("[test_vertical_integration_unstructured_gradient]", fail, .false., & - "Too large error in vertical integration on unstructured mesh.") + use quadrature + use elements + use fields + use state_module + use mesh_files + use boundary_conditions + use vertical_extrapolation_module + use fields_calculations + use vtk_interfaces + use unittest_tools + implicit none + + character, parameter:: NEWLINE_CHAR=achar(10) + ! vertically constant: + character(len=*), parameter:: PYTHON_FUNCTION1= & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])" + ! function with vertical derivative: + character(len=*), parameter:: PYTHON_FUNCTION2= & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])*math.cos(math.pi*X[2])" + ! its vertical derivative (note gravity is in -X[2] direction): + character(len=*), parameter:: PYTHON_FUNCTION_DERIVATIVE= & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return math.pi*math.cos(math.pi*X[0])*math.sin(math.pi*X[1])*math.sin(math.pi*X[2])" + ! the mesh files should have the top surface marked with boundary id 1 + integer, dimension(1), parameter:: TOP_BOUNDARY_IDS=(/ 1 /) + integer, parameter:: QUAD_DEGREE=4, NVERTICES=4, DIM=3 + integer, parameter:: POLY_DEGREE=2 ! degree of fields we're integrating + real, dimension(1:DIM), parameter:: DOWN=(/ 0.0, 0.0, -1.0 /) + + logical fail + real l2error + + call test_vertical_integration_from_file("data/cube_prismatic", & + PYTHON_FUNCTION1, l2error=l2error) + fail= l2error>1e-10 + call report_test("[test_vertical_integration_prismatic]", fail, .false., & + "Too large error in vertical integration on prismatic mesh.") + + call test_vertical_integration_from_file("data/cube_unstructured", & + PYTHON_FUNCTION1, l2error=l2error) + fail= l2error>2e-3 + call report_test("[test_vertical_integration_unstructured]", fail, .false., & + "Too large error in vertical integration on unstructured mesh.") + + call test_vertical_integration_from_file("data/cube_prismatic", & + PYTHON_FUNCTION2, python_function_derivative=PYTHON_FUNCTION_DERIVATIVE, & + l2error=l2error) + fail= l2error>1e-3 + call report_test("[test_vertical_integration_prismatic_gradient]", fail, .false., & + "Too large error in vertical integration on prismatic mesh.") + + call test_vertical_integration_from_file("data/cube_unstructured", & + PYTHON_FUNCTION2, python_function_derivative=PYTHON_FUNCTION_DERIVATIVE, & + l2error=l2error) + fail= l2error>5e-3 + call report_test("[test_vertical_integration_unstructured_gradient]", fail, .false., & + "Too large error in vertical integration on unstructured mesh.") contains -subroutine test_vertical_integration_from_file(mesh_file, & - python_function, python_function_derivative, & - l2error) -character(len=*), intent(in):: mesh_file -character(len=*), intent(in):: python_function -character(len=*), optional, intent(in):: python_function_derivative -real, intent(out):: l2error - - type(state_type) state - type(vector_field), target:: positions, vertical_normal, bc_positions - type(scalar_field) to_field, from_field, error_field, rhs - type(mesh_type), pointer:: x_mesh, surface_mesh - type(mesh_type) dg_quad_mesh - type(element_type) quad_shape - type(quadrature_type) quad - integer, dimension(:), pointer:: surface_element_list - - ! vertical integration() needs a "Coordinate" and "GravityDirection" field - positions = read_mesh_files(mesh_file, quad_degree=QUAD_DEGREE, format="gmsh") - x_mesh => positions%mesh - - call allocate(vertical_normal, mesh_dim(x_mesh), x_mesh, & - name="GravityDirection", & - field_type=FIELD_TYPE_CONSTANT) - call set(vertical_normal, DOWN) - - call insert(state, positions, name="Coordinate") - call insert(state, vertical_normal, name="GravityDirection") - - ! we're going to integrate downwards over an quadratic DG field: - quad=x_mesh%shape%quadrature - quad_shape=make_element_shape(NVERTICES, DIM, POLY_DEGREE, quad) - dg_quad_mesh=make_mesh(x_mesh, shape=quad_shape, continuity=-1, & - name="DGMesh") - call deallocate(quad_shape) - call allocate(to_field, dg_quad_mesh, name="ToField") - - ! set the function on the top of the mesh: - call add_boundary_condition(to_field, "Top", type="Dummy", & - boundary_ids=TOP_BOUNDARY_IDS ) - call get_boundary_condition(to_field, "Top", & - surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - call allocate(from_field, surface_mesh, name="FromField") - call allocate(bc_positions, DIM, surface_mesh, name="BCPositions") - call remap_field_to_surface(positions, bc_positions, surface_element_list) - call set_from_python_function(from_field, python_function, bc_positions, & - time=0.0) - - if (present(python_function_derivative)) then - call allocate(rhs, dg_quad_mesh) - call set_from_python_function(rhs, python_function_derivative, & - positions, time=0.0) - - call vertical_integration(from_field, to_field, positions, & - vertical_normal, surface_element_list, rhs=rhs) - else - call vertical_integration(from_field, to_field, positions, & - vertical_normal, surface_element_list) - end if - - call allocate(error_field, dg_quad_mesh, name="ErrorField") - ! first set it to the reference solution using the same python function - call set_from_python_function(error_field, python_function, positions, & - time=0.0) - ! then subtract the found solution: - call addto(error_field, to_field, scale=-1.0) - - !call vtk_write_fields(mesh_file, 0, & - ! positions, dg_quad_mesh, sfields=(/ to_field, error_field /)) - - l2error=norm2(error_field, positions) - print *, l2error - - call deallocate(state) - call deallocate(vertical_normal) - call deallocate(to_field) - call deallocate(from_field) - call deallocate(error_field) - call deallocate(bc_positions) - if (present(python_function_derivative)) then - call deallocate(rhs) - end if - - call deallocate(positions) - call deallocate(dg_quad_mesh) - -end subroutine test_vertical_integration_from_file + subroutine test_vertical_integration_from_file(mesh_file, & + python_function, python_function_derivative, & + l2error) + character(len=*), intent(in):: mesh_file + character(len=*), intent(in):: python_function + character(len=*), optional, intent(in):: python_function_derivative + real, intent(out):: l2error + + type(state_type) state + type(vector_field), target:: positions, vertical_normal, bc_positions + type(scalar_field) to_field, from_field, error_field, rhs + type(mesh_type), pointer:: x_mesh, surface_mesh + type(mesh_type) dg_quad_mesh + type(element_type) quad_shape + type(quadrature_type) quad + integer, dimension(:), pointer:: surface_element_list + + ! vertical integration() needs a "Coordinate" and "GravityDirection" field + positions = read_mesh_files(mesh_file, quad_degree=QUAD_DEGREE, format="gmsh") + x_mesh => positions%mesh + + call allocate(vertical_normal, mesh_dim(x_mesh), x_mesh, & + name="GravityDirection", & + field_type=FIELD_TYPE_CONSTANT) + call set(vertical_normal, DOWN) + + call insert(state, positions, name="Coordinate") + call insert(state, vertical_normal, name="GravityDirection") + + ! we're going to integrate downwards over an quadratic DG field: + quad=x_mesh%shape%quadrature + quad_shape=make_element_shape(NVERTICES, DIM, POLY_DEGREE, quad) + dg_quad_mesh=make_mesh(x_mesh, shape=quad_shape, continuity=-1, & + name="DGMesh") + call deallocate(quad_shape) + call allocate(to_field, dg_quad_mesh, name="ToField") + + ! set the function on the top of the mesh: + call add_boundary_condition(to_field, "Top", type="Dummy", & + boundary_ids=TOP_BOUNDARY_IDS ) + call get_boundary_condition(to_field, "Top", & + surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + call allocate(from_field, surface_mesh, name="FromField") + call allocate(bc_positions, DIM, surface_mesh, name="BCPositions") + call remap_field_to_surface(positions, bc_positions, surface_element_list) + call set_from_python_function(from_field, python_function, bc_positions, & + time=0.0) + + if (present(python_function_derivative)) then + call allocate(rhs, dg_quad_mesh) + call set_from_python_function(rhs, python_function_derivative, & + positions, time=0.0) + + call vertical_integration(from_field, to_field, positions, & + vertical_normal, surface_element_list, rhs=rhs) + else + call vertical_integration(from_field, to_field, positions, & + vertical_normal, surface_element_list) + end if + + call allocate(error_field, dg_quad_mesh, name="ErrorField") + ! first set it to the reference solution using the same python function + call set_from_python_function(error_field, python_function, positions, & + time=0.0) + ! then subtract the found solution: + call addto(error_field, to_field, scale=-1.0) + + !call vtk_write_fields(mesh_file, 0, & + ! positions, dg_quad_mesh, sfields=(/ to_field, error_field /)) + + l2error=norm2(error_field, positions) + print *, l2error + + call deallocate(state) + call deallocate(vertical_normal) + call deallocate(to_field) + call deallocate(from_field) + call deallocate(error_field) + call deallocate(bc_positions) + if (present(python_function_derivative)) then + call deallocate(rhs) + end if + + call deallocate(positions) + call deallocate(dg_quad_mesh) + + end subroutine test_vertical_integration_from_file end subroutine test_vertical_integration diff --git a/assemble/tests/test_vertical_prolongation_operator.F90 b/assemble/tests/test_vertical_prolongation_operator.F90 index a056b206ab..2aa3a1acbf 100644 --- a/assemble/tests/test_vertical_prolongation_operator.F90 +++ b/assemble/tests/test_vertical_prolongation_operator.F90 @@ -1,110 +1,110 @@ subroutine test_vertical_prolongation_operator() -use quadrature -use sparse_tools -use elements -use fields -use state_module -use mesh_files -use boundary_conditions -use vertical_extrapolation_module -use fields_calculations -use vtk_interfaces -use unittest_tools -implicit none - - character, parameter:: NEWLINE_CHAR=achar(10) - ! vertically constant: - character(len=*), parameter:: PYTHON_FUNCTION1= & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])" - ! the mesh files should have the top surface marked with boundary id 1 - integer, dimension(1), parameter:: TOP_BOUNDARY_IDS=(/ 1 /) - integer, parameter:: QUAD_DEGREE=4, NVERTICES=4, DIM=3 - integer, parameter:: POLY_DEGREE=2 ! degree of fields we're integrating - - logical fail - real l2error - - call test_vertical_prolongation_from_file("data/cube_prismatic", & - PYTHON_FUNCTION1, l2error) - fail= l2error>1e-10 - call report_test("[test_vertical_prolongation_prismatic]", fail, .false., & - "Too large error in vertical prolongation on prismatic mesh.") - - call test_vertical_prolongation_from_file("data/cube_unstructured", & - PYTHON_FUNCTION1, l2error) - fail= l2error>1e-3 - call report_test("[test_vertical_prolongation_unstructured]", fail, .false., & - "Too large error in vertical prolongation on unstructured mesh.") + use quadrature + use sparse_tools + use elements + use fields + use state_module + use mesh_files + use boundary_conditions + use vertical_extrapolation_module + use fields_calculations + use vtk_interfaces + use unittest_tools + implicit none + + character, parameter:: NEWLINE_CHAR=achar(10) + ! vertically constant: + character(len=*), parameter:: PYTHON_FUNCTION1= & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return math.cos(math.pi*X[0])*math.sin(math.pi*X[1])" + ! the mesh files should have the top surface marked with boundary id 1 + integer, dimension(1), parameter:: TOP_BOUNDARY_IDS=(/ 1 /) + integer, parameter:: QUAD_DEGREE=4, NVERTICES=4, DIM=3 + integer, parameter:: POLY_DEGREE=2 ! degree of fields we're integrating + + logical fail + real l2error + + call test_vertical_prolongation_from_file("data/cube_prismatic", & + PYTHON_FUNCTION1, l2error) + fail= l2error>1e-10 + call report_test("[test_vertical_prolongation_prismatic]", fail, .false., & + "Too large error in vertical prolongation on prismatic mesh.") + + call test_vertical_prolongation_from_file("data/cube_unstructured", & + PYTHON_FUNCTION1, l2error) + fail= l2error>1e-3 + call report_test("[test_vertical_prolongation_unstructured]", fail, .false., & + "Too large error in vertical prolongation on unstructured mesh.") contains -subroutine test_vertical_prolongation_from_file(mesh_file, & - python_function, l2error) -character(len=*), intent(in):: mesh_file -character(len=*), intent(in):: python_function -real, intent(out):: l2error - - type(vector_field), target:: positions, bc_positions, vertical_normal - type(scalar_field) to_field, from_field, error_field - type(mesh_type), pointer:: x_mesh, surface_mesh - type(mesh_type) quad_mesh - type(element_type) quad_shape - type(quadrature_type) quad - type(csr_matrix) prolongator - integer, dimension(:), pointer:: surface_element_list - - positions=read_mesh_files(mesh_file, quad_degree=QUAD_DEGREE, format="gmsh") - x_mesh => positions%mesh - - ! we're going to extrapolate downwards onto a quadratic field: - quad=x_mesh%shape%quadrature - quad_shape=make_element_shape(NVERTICES, DIM, POLY_DEGREE, quad) - quad_mesh=make_mesh(x_mesh, shape=quad_shape, name="Mesh") - call allocate(to_field, quad_mesh, name="ToField") - - ! set the function on the top of the mesh: - call add_boundary_condition(to_field, "Top", type="Dummy", & - boundary_ids=TOP_BOUNDARY_IDS ) - call get_boundary_condition(to_field, "Top", & - surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - call allocate(from_field, surface_mesh, name="FromField") - call allocate(bc_positions, DIM, surface_mesh, name="BCPositions") - call remap_field_to_surface(positions, bc_positions, surface_element_list) - call set_from_python_function(from_field, python_function, bc_positions, & - time=0.0) - call allocate(vertical_normal, positions%dim, x_mesh, & - field_type=FIELD_TYPE_CONSTANT, name="VerticalNormal") - call set(vertical_normal, (/ 0., 0., -1. /) ) - - prolongator=VerticalProlongationOperator(quad_mesh, positions, & - vertical_normal, surface_element_list, & - surface_mesh=surface_mesh) - call mult(to_field%val, prolongator, from_field%val) - - call allocate(error_field, quad_mesh, name="ErrorField") - ! first set it to the reference solution using the same python function - call set_from_python_function(error_field, python_function, positions, & - time=0.0) - ! then subtract the found solution: - call addto(error_field, to_field, scale=-1.0) - - !call vtk_write_fields(mesh_file, 0, & - ! positions, quad_mesh, sfields=(/ to_field, error_field /)) - - l2error=norm2(error_field, positions) - print *, l2error - - call deallocate(vertical_normal) - call deallocate(to_field) - call deallocate(from_field) - call deallocate(error_field) - call deallocate(bc_positions) - call deallocate(prolongator) - -end subroutine test_vertical_prolongation_from_file + subroutine test_vertical_prolongation_from_file(mesh_file, & + python_function, l2error) + character(len=*), intent(in):: mesh_file + character(len=*), intent(in):: python_function + real, intent(out):: l2error + + type(vector_field), target:: positions, bc_positions, vertical_normal + type(scalar_field) to_field, from_field, error_field + type(mesh_type), pointer:: x_mesh, surface_mesh + type(mesh_type) quad_mesh + type(element_type) quad_shape + type(quadrature_type) quad + type(csr_matrix) prolongator + integer, dimension(:), pointer:: surface_element_list + + positions=read_mesh_files(mesh_file, quad_degree=QUAD_DEGREE, format="gmsh") + x_mesh => positions%mesh + + ! we're going to extrapolate downwards onto a quadratic field: + quad=x_mesh%shape%quadrature + quad_shape=make_element_shape(NVERTICES, DIM, POLY_DEGREE, quad) + quad_mesh=make_mesh(x_mesh, shape=quad_shape, name="Mesh") + call allocate(to_field, quad_mesh, name="ToField") + + ! set the function on the top of the mesh: + call add_boundary_condition(to_field, "Top", type="Dummy", & + boundary_ids=TOP_BOUNDARY_IDS ) + call get_boundary_condition(to_field, "Top", & + surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + call allocate(from_field, surface_mesh, name="FromField") + call allocate(bc_positions, DIM, surface_mesh, name="BCPositions") + call remap_field_to_surface(positions, bc_positions, surface_element_list) + call set_from_python_function(from_field, python_function, bc_positions, & + time=0.0) + call allocate(vertical_normal, positions%dim, x_mesh, & + field_type=FIELD_TYPE_CONSTANT, name="VerticalNormal") + call set(vertical_normal, (/ 0., 0., -1. /) ) + + prolongator=VerticalProlongationOperator(quad_mesh, positions, & + vertical_normal, surface_element_list, & + surface_mesh=surface_mesh) + call mult(to_field%val, prolongator, from_field%val) + + call allocate(error_field, quad_mesh, name="ErrorField") + ! first set it to the reference solution using the same python function + call set_from_python_function(error_field, python_function, positions, & + time=0.0) + ! then subtract the found solution: + call addto(error_field, to_field, scale=-1.0) + + !call vtk_write_fields(mesh_file, 0, & + ! positions, quad_mesh, sfields=(/ to_field, error_field /)) + + l2error=norm2(error_field, positions) + print *, l2error + + call deallocate(vertical_normal) + call deallocate(to_field) + call deallocate(from_field) + call deallocate(error_field) + call deallocate(bc_positions) + call deallocate(prolongator) + + end subroutine test_vertical_prolongation_from_file end subroutine test_vertical_prolongation_operator diff --git a/debug/Debug.F90 b/debug/Debug.F90 index 25431217ad..b7554c09a0 100644 --- a/debug/Debug.F90 +++ b/debug/Debug.F90 @@ -28,119 +28,119 @@ #include "fdebug.h" module fldebug - !!< This module allows pure fortran programs to use the fdebug.h headers. + !!< This module allows pure fortran programs to use the fdebug.h headers. - use fldebug_parameters + use fldebug_parameters - implicit none + implicit none - interface write_minmax - module procedure write_minmax_real_array, write_minmax_integer_array - end interface + interface write_minmax + module procedure write_minmax_real_array, write_minmax_integer_array + end interface contains - function debug_unit(priority) - !!< Decide where to send output based on the level of the error. + function debug_unit(priority) + !!< Decide where to send output based on the level of the error. - integer :: debug_unit - integer, intent(in) :: priority + integer :: debug_unit + integer, intent(in) :: priority - if (priority<1) then - debug_unit=debug_error_unit - else - debug_unit=debug_log_unit - end if + if (priority<1) then + debug_unit=debug_error_unit + else + debug_unit=debug_log_unit + end if - end function debug_unit + end function debug_unit - function debug_level() - ! Simply return the current debug level. This makes the debug level - ! effectively global. - use fldebug_parameters - implicit none - integer :: debug_level + function debug_level() + ! Simply return the current debug level. This makes the debug level + ! effectively global. + use fldebug_parameters + implicit none + integer :: debug_level - debug_level=current_debug_level + debug_level=current_debug_level - end function debug_level + end function debug_level - SUBROUTINE FLAbort_pinpoint(ErrorStr, FromFile, LineNumber) + SUBROUTINE FLAbort_pinpoint(ErrorStr, FromFile, LineNumber) - CHARACTER*(*) ErrorStr, FromFile - INTEGER LineNumber - LOGICAL UsingMPI - INTEGER IERR + CHARACTER*(*) ErrorStr, FromFile + INTEGER LineNumber + LOGICAL UsingMPI + INTEGER IERR #ifdef HAVE_MPI #include #endif #ifdef HAVE_MPI - CALL MPI_INITIALIZED(UsingMPI, IERR) + CALL MPI_INITIALIZED(UsingMPI, IERR) #endif - ewrite(-1,FMT='(A)') "*** FLUIDITY ERROR ***" - ewrite(-1,FMT='(3A,I5,A)') "Source location: (",FromFile,",",LineNumber,")" - ewrite(-1,FMT='(2A)') "Error message: ",ErrorStr - ewrite(-1,FMT='(A)') "Backtrace will follow if it is available:" - call fprint_backtrace() - ewrite(-1,FMT='(A)') "Use addr2line -e
to decipher." - ewrite(-1,FMT='(A)') "Error is terminal." + ewrite(-1,FMT='(A)') "*** FLUIDITY ERROR ***" + ewrite(-1,FMT='(3A,I5,A)') "Source location: (",FromFile,",",LineNumber,")" + ewrite(-1,FMT='(2A)') "Error message: ",ErrorStr + ewrite(-1,FMT='(A)') "Backtrace will follow if it is available:" + call fprint_backtrace() + ewrite(-1,FMT='(A)') "Use addr2line -e
to decipher." + ewrite(-1,FMT='(A)') "Error is terminal." #ifdef HAVE_MPI - IF(UsingMPI) THEN - !mpi_comm_femtools not required here. - CALL MPI_ABORT(MPI_COMM_WORLD, MPI_ERR_OTHER, IERR) - END IF + IF(UsingMPI) THEN + !mpi_comm_femtools not required here. + CALL MPI_ABORT(MPI_COMM_WORLD, MPI_ERR_OTHER, IERR) + END IF #endif - STOP - END SUBROUTINE FLAbort_pinpoint + STOP + END SUBROUTINE FLAbort_pinpoint - SUBROUTINE FLExit_pinpoint(ErrorStr, FromFile, LineNumber) + SUBROUTINE FLExit_pinpoint(ErrorStr, FromFile, LineNumber) - CHARACTER*(*) ErrorStr, FromFile - INTEGER LineNumber - LOGICAL UsingMPI - INTEGER IERR + CHARACTER*(*) ErrorStr, FromFile + INTEGER LineNumber + LOGICAL UsingMPI + INTEGER IERR #ifdef HAVE_MPI #include #endif #ifdef HAVE_MPI - CALL MPI_INITIALIZED(UsingMPI, IERR) + CALL MPI_INITIALIZED(UsingMPI, IERR) #endif - ewrite(-1,FMT='(A)') "*** ERROR ***" + ewrite(-1,FMT='(A)') "*** ERROR ***" #ifndef NDEBUG - ewrite(-1,FMT='(3A,I5,A)') "Source location: (",FromFile,",",LineNumber,")" + ewrite(-1,FMT='(3A,I5,A)') "Source location: (",FromFile,",",LineNumber,")" #endif - ewrite(-1,FMT='(2A)') "Error message: ",ErrorStr + ewrite(-1,FMT='(2A)') "Error message: ",ErrorStr #ifdef HAVE_MPI - IF(UsingMPI) THEN - !mpi_comm_femtools not required here. - CALL MPI_ABORT(MPI_COMM_WORLD, MPI_ERR_OTHER, IERR) - END IF + IF(UsingMPI) THEN + !mpi_comm_femtools not required here. + CALL MPI_ABORT(MPI_COMM_WORLD, MPI_ERR_OTHER, IERR) + END IF #endif - STOP - END SUBROUTINE FLExit_pinpoint + STOP + END SUBROUTINE FLExit_pinpoint - subroutine write_minmax_real_array(array, array_expression) - ! the array to print its min and max of - real, dimension(:), intent(in):: array - ! the actual array expression in the code - character(len=*), intent(in):: array_expression + subroutine write_minmax_real_array(array, array_expression) + ! the array to print its min and max of + real, dimension(:), intent(in):: array + ! the actual array expression in the code + character(len=*), intent(in):: array_expression - ewrite(2,*) "Min, max of "//array_expression//" = ",minval(array), maxval(array) + ewrite(2,*) "Min, max of "//array_expression//" = ",minval(array), maxval(array) - end subroutine write_minmax_real_array + end subroutine write_minmax_real_array - subroutine write_minmax_integer_array(array, array_expression) - ! the array to print its min and max of - integer, dimension(:), intent(in):: array - ! the actual array expression in the code - character(len=*), intent(in):: array_expression + subroutine write_minmax_integer_array(array, array_expression) + ! the array to print its min and max of + integer, dimension(:), intent(in):: array + ! the actual array expression in the code + character(len=*), intent(in):: array_expression - ewrite(2,*) "Min, max of "//array_expression//" = ",minval(array), maxval(array) + ewrite(2,*) "Min, max of "//array_expression//" = ",minval(array), maxval(array) - end subroutine write_minmax_integer_array + end subroutine write_minmax_integer_array end module fldebug diff --git a/debug/Debug_Parameters.F90 b/debug/Debug_Parameters.F90 index d3f2d0f6ba..65b41e81b9 100644 --- a/debug/Debug_Parameters.F90 +++ b/debug/Debug_Parameters.F90 @@ -27,16 +27,16 @@ ! USA module fldebug_parameters - !!< Debug specific global parameters + !!< Debug specific global parameters - implicit none + implicit none - !------------------------------------------------------------------------ - ! Parameters controlling diagnostic output. - !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + ! Parameters controlling diagnostic output. + !------------------------------------------------------------------------ - integer, save :: current_debug_level=1, global_debug_level=1 - !! These defaults are an assumption which may not be true on all platforms. - integer, save :: debug_error_unit=0, debug_log_unit=6 + integer, save :: current_debug_level=1, global_debug_level=1 + !! These defaults are an assumption which may not be true on all platforms. + integer, save :: debug_error_unit=0, debug_log_unit=6 end module fldebug_parameters diff --git a/debug/Diagnostic_Output.F90 b/debug/Diagnostic_Output.F90 index 861f2ce31d..fb97fedd0e 100644 --- a/debug/Diagnostic_Output.F90 +++ b/debug/Diagnostic_Output.F90 @@ -29,53 +29,53 @@ ! modules because these routines are designed to be callable from C. subroutine set_debug_level(level) - ! Temporarily set the verbosity of the program. - use fldebug_parameters - implicit none - integer, intent(in) :: level + ! Temporarily set the verbosity of the program. + use fldebug_parameters + implicit none + integer, intent(in) :: level - current_debug_level=level + current_debug_level=level end subroutine set_debug_level subroutine set_global_debug_level(level) - ! Set the global verbosity of the program. - use fldebug_parameters - implicit none - integer, intent(in) :: level + ! Set the global verbosity of the program. + use fldebug_parameters + implicit none + integer, intent(in) :: level - global_debug_level=level - current_debug_level=global_debug_level + global_debug_level=level + current_debug_level=global_debug_level end subroutine set_global_debug_level subroutine reset_debug_level - ! Temporarily set the verbosity of the program. - use fldebug_parameters - implicit none + ! Temporarily set the verbosity of the program. + use fldebug_parameters + implicit none - current_debug_level=global_debug_level + current_debug_level=global_debug_level end subroutine reset_debug_level function debug_level() - ! Simply return the current debug level. This makes the debug level - ! effectively global. - use fldebug_parameters - implicit none - integer :: debug_level + ! Simply return the current debug level. This makes the debug level + ! effectively global. + use fldebug_parameters + implicit none + integer :: debug_level - debug_level=current_debug_level + debug_level=current_debug_level end function debug_level function get_global_debug_level() - ! Simply return the global debug level. This makes the debug level - ! effectively global. - use fldebug_parameters - implicit none - integer :: get_global_debug_level + ! Simply return the global debug level. This makes the debug level + ! effectively global. + use fldebug_parameters + implicit none + integer :: get_global_debug_level - get_global_debug_level=global_debug_level + get_global_debug_level=global_debug_level end function get_global_debug_level diff --git a/diagnostics/Binary_Operators.F90 b/diagnostics/Binary_Operators.F90 index 6ea728ee32..6b4f6eb026 100644 --- a/diagnostics/Binary_Operators.F90 +++ b/diagnostics/Binary_Operators.F90 @@ -29,118 +29,118 @@ module binary_operators - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use spud - use fields - use state_module - use field_options - use diagnostic_source_fields + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use spud + use fields + use state_module + use field_options + use diagnostic_source_fields - implicit none + implicit none - private + private - public :: calculate_scalar_sum, calculate_scalar_difference, & - & calculate_vector_sum, calculate_vector_difference, & - & calculate_tensor_difference + public :: calculate_scalar_sum, calculate_scalar_difference, & + & calculate_vector_sum, calculate_vector_difference, & + & calculate_tensor_difference contains - subroutine calculate_scalar_sum(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_sum(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - type(scalar_field), pointer :: source_field_1, source_field_2 + type(scalar_field), pointer :: source_field_1, source_field_2 - source_field_1 => scalar_source_field(state, s_field, index = 1) - source_field_2 => scalar_source_field(state, s_field, index = 2) + source_field_1 => scalar_source_field(state, s_field, index = 1) + source_field_2 => scalar_source_field(state, s_field, index = 2) - call remap_field(source_field_1, s_field) - call addto(s_field, source_field_2) + call remap_field(source_field_1, s_field) + call addto(s_field, source_field_2) - end subroutine calculate_scalar_sum + end subroutine calculate_scalar_sum - subroutine calculate_scalar_difference(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_difference(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - character(len = OPTION_PATH_LEN) :: path - type(scalar_field), pointer :: source_field_1, source_field_2 + character(len = OPTION_PATH_LEN) :: path + type(scalar_field), pointer :: source_field_1, source_field_2 - source_field_1 => scalar_source_field(state, s_field, index = 1) - source_field_2 => scalar_source_field(state, s_field, index = 2) + source_field_1 => scalar_source_field(state, s_field, index = 1) + source_field_2 => scalar_source_field(state, s_field, index = 2) - call remap_field(source_field_1, s_field) - call addto(s_field, source_field_2, scale = -1.0) + call remap_field(source_field_1, s_field) + call addto(s_field, source_field_2, scale = -1.0) - path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/absolute_difference")) then - s_field%val = abs(s_field%val) - end if + path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + if(have_option(trim(path) // "/absolute_difference")) then + s_field%val = abs(s_field%val) + end if - end subroutine calculate_scalar_difference + end subroutine calculate_scalar_difference - subroutine calculate_vector_sum(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_vector_sum(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - type(vector_field), pointer :: source_field_1, source_field_2 + type(vector_field), pointer :: source_field_1, source_field_2 - source_field_1 => vector_source_field(state, v_field, index = 1) - source_field_2 => vector_source_field(state, v_field, index = 2) + source_field_1 => vector_source_field(state, v_field, index = 1) + source_field_2 => vector_source_field(state, v_field, index = 2) - call remap_field(source_field_1, v_field) - call addto(v_field, source_field_2) + call remap_field(source_field_1, v_field) + call addto(v_field, source_field_2) - end subroutine calculate_vector_sum + end subroutine calculate_vector_sum - subroutine calculate_vector_difference(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_vector_difference(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - character(len = OPTION_PATH_LEN) :: path - integer :: i - type(vector_field), pointer :: source_field_1, source_field_2 + character(len = OPTION_PATH_LEN) :: path + integer :: i + type(vector_field), pointer :: source_field_1, source_field_2 - source_field_1 => vector_source_field(state, v_field, index = 1) - source_field_2 => vector_source_field(state, v_field, index = 2) + source_field_1 => vector_source_field(state, v_field, index = 1) + source_field_2 => vector_source_field(state, v_field, index = 2) - call remap_field(source_field_1, v_field) - call addto(v_field, source_field_2, scale = -1.0) + call remap_field(source_field_1, v_field) + call addto(v_field, source_field_2, scale = -1.0) - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/absolute_difference")) then - do i = 1, v_field%dim - v_field%val(i,:) = abs(v_field%val(i,:)) - end do - end if + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + if(have_option(trim(path) // "/absolute_difference")) then + do i = 1, v_field%dim + v_field%val(i,:) = abs(v_field%val(i,:)) + end do + end if - end subroutine calculate_vector_difference + end subroutine calculate_vector_difference - subroutine calculate_tensor_difference(state, t_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: t_field + subroutine calculate_tensor_difference(state, t_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: t_field - character(len = OPTION_PATH_LEN) :: path - integer :: i, j - type(tensor_field), pointer :: source_field_1, source_field_2 + character(len = OPTION_PATH_LEN) :: path + integer :: i, j + type(tensor_field), pointer :: source_field_1, source_field_2 - source_field_1 => tensor_source_field(state, t_field, index = 1) - source_field_2 => tensor_source_field(state, t_field, index = 2) + source_field_1 => tensor_source_field(state, t_field, index = 1) + source_field_2 => tensor_source_field(state, t_field, index = 2) - call remap_field(source_field_1, t_field) - call addto(t_field, source_field_2, scale = -1.0) + call remap_field(source_field_1, t_field) + call addto(t_field, source_field_2, scale = -1.0) - path = trim(complete_field_path(t_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/absolute_difference")) then - do i = 1, t_field%dim(1) - do j = 1, t_field%dim(2) - t_field%val(i,j,:) = abs(t_field%val(i,j,:)) - end do - end do - end if + path = trim(complete_field_path(t_field%option_path)) // "/algorithm" + if(have_option(trim(path) // "/absolute_difference")) then + do i = 1, t_field%dim(1) + do j = 1, t_field%dim(2) + t_field%val(i,j,:) = abs(t_field%val(i,j,:)) + end do + end do + end if - end subroutine calculate_tensor_difference + end subroutine calculate_tensor_difference end module binary_operators diff --git a/diagnostics/Diagnostic_Fields_Interfaces.F90 b/diagnostics/Diagnostic_Fields_Interfaces.F90 index ae94636dca..e8e7e34f6e 100644 --- a/diagnostics/Diagnostic_Fields_Interfaces.F90 +++ b/diagnostics/Diagnostic_Fields_Interfaces.F90 @@ -29,297 +29,297 @@ subroutine calculate_diagnostic_variables_multiple(states, states_size, exclude_nonrecalculated) - use fldebug - use fields - use state_module - use diagnostic_fields_new, only : calculate_diagnostic_variables_internal => calculate_diagnostic_variables + use fldebug + use fields + use state_module + use diagnostic_fields_new, only : calculate_diagnostic_variables_internal => calculate_diagnostic_variables - implicit none + implicit none - integer, intent(in) :: states_size + integer, intent(in) :: states_size - type(state_type), dimension(states_size), intent(inout) :: states - logical, intent(in) :: exclude_nonrecalculated + type(state_type), dimension(states_size), intent(inout) :: states + logical, intent(in) :: exclude_nonrecalculated - call calculate_diagnostic_variables_internal(states, exclude_nonrecalculated = exclude_nonrecalculated) + call calculate_diagnostic_variables_internal(states, exclude_nonrecalculated = exclude_nonrecalculated) end subroutine calculate_diagnostic_variables_multiple subroutine calculate_diagnostic_variable_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, stat) - use fldebug - use fields - use state_module - use diagnostic_fields_new, only: calculate_diagnostic_variable - - implicit none - - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - character(len = algorithm_len), intent(in) :: algorithm - integer, pointer :: stat - - integer :: lstat - - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable(states, state_index, s_field, stat = lstat) - else - call calculate_diagnostic_variable(states, state_index, s_field, algorithm = algorithm, stat = lstat) - end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable(states, state_index, s_field) - else - call calculate_diagnostic_variable(states, state_index, s_field, algorithm = algorithm) - end if - end if + use fldebug + use fields + use state_module + use diagnostic_fields_new, only: calculate_diagnostic_variable -end subroutine calculate_diagnostic_variable_scalar - -subroutine calculate_diagnostic_variable_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, stat) - - use fldebug - use fields - use state_module - use diagnostic_fields_new, only: calculate_diagnostic_variable - - implicit none - - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - character(len = algorithm_len), intent(in) :: algorithm - integer, pointer :: stat - - integer :: lstat - - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable(states, state_index, v_field, stat = lstat) - else - call calculate_diagnostic_variable(states, state_index, v_field, algorithm = algorithm, stat = lstat) - end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable(states, state_index, v_field) - else - call calculate_diagnostic_variable(states, state_index, v_field, algorithm = algorithm) - end if - end if + implicit none -end subroutine calculate_diagnostic_variable_vector - -subroutine calculate_diagnostic_variable_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, stat) + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len - use fldebug - use fields - use state_module - use diagnostic_fields_new, only: calculate_diagnostic_variable - - implicit none - - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - character(len = algorithm_len), intent(in) :: algorithm - integer, pointer :: stat - - integer :: lstat - - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable(states, state_index, t_field, stat = lstat) - else - call calculate_diagnostic_variable(states, state_index, t_field, algorithm = algorithm, stat = lstat) - end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable(states, state_index, t_field) - else - call calculate_diagnostic_variable(states, state_index, t_field, algorithm = algorithm) - end if - end if + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + character(len = algorithm_len), intent(in) :: algorithm + integer, pointer :: stat -end subroutine calculate_diagnostic_variable_tensor + integer :: lstat + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable(states, state_index, s_field, stat = lstat) + else + call calculate_diagnostic_variable(states, state_index, s_field, algorithm = algorithm, stat = lstat) + end if + stat = lstat + else + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable(states, state_index, s_field) + else + call calculate_diagnostic_variable(states, state_index, s_field, algorithm = algorithm) + end if + end if -subroutine calculate_diagnostic_variable_dep_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, dep_states_mask, stat) +end subroutine calculate_diagnostic_variable_scalar - use fldebug - use fields - use state_module - use diagnostic_fields_new, only: calculate_diagnostic_variable_dep +subroutine calculate_diagnostic_variable_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, stat) - implicit none + use fldebug + use fields + use state_module + use diagnostic_fields_new, only: calculate_diagnostic_variable - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len + implicit none - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - character(len = algorithm_len), intent(in) :: algorithm - type(state_type), dimension(:), pointer :: dep_states_mask + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len - integer, pointer :: stat + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + character(len = algorithm_len), intent(in) :: algorithm + integer, pointer :: stat - integer :: lstat + integer :: lstat - if(associated(dep_states_mask)) then - if(associated(stat)) then + if(associated(stat)) then if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, s_field, dep_states_mask=dep_states_mask, stat = lstat) + call calculate_diagnostic_variable(states, state_index, v_field, stat = lstat) else - call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = lstat) + call calculate_diagnostic_variable(states, state_index, v_field, algorithm = algorithm, stat = lstat) end if stat = lstat - else + else if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, s_field, dep_states_mask=dep_states_mask) + call calculate_diagnostic_variable(states, state_index, v_field) else - call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm, dep_states_mask=dep_states_mask) + call calculate_diagnostic_variable(states, state_index, v_field, algorithm = algorithm) end if - end if - else - if(associated(stat)) then + end if + +end subroutine calculate_diagnostic_variable_vector + +subroutine calculate_diagnostic_variable_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, stat) + + use fldebug + use fields + use state_module + use diagnostic_fields_new, only: calculate_diagnostic_variable + + implicit none + + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + character(len = algorithm_len), intent(in) :: algorithm + integer, pointer :: stat + + integer :: lstat + + if(associated(stat)) then if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, s_field, stat = lstat) + call calculate_diagnostic_variable(states, state_index, t_field, stat = lstat) else - call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm, stat = lstat) + call calculate_diagnostic_variable(states, state_index, t_field, algorithm = algorithm, stat = lstat) end if stat = lstat - else + else if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, s_field) + call calculate_diagnostic_variable(states, state_index, t_field) else - call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm) + call calculate_diagnostic_variable(states, state_index, t_field, algorithm = algorithm) end if - end if - end if + end if +end subroutine calculate_diagnostic_variable_tensor -end subroutine calculate_diagnostic_variable_dep_scalar -subroutine calculate_diagnostic_variable_dep_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, dep_states_mask, stat) +subroutine calculate_diagnostic_variable_dep_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, dep_states_mask, stat) - use fldebug - use fields - use state_module - use diagnostic_fields_new, only: calculate_diagnostic_variable_dep + use fldebug + use fields + use state_module + use diagnostic_fields_new, only: calculate_diagnostic_variable_dep - implicit none + implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - character(len = algorithm_len), intent(in) :: algorithm - type(state_type), dimension(:), pointer :: dep_states_mask - integer, pointer :: stat + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + character(len = algorithm_len), intent(in) :: algorithm + type(state_type), dimension(:), pointer :: dep_states_mask - integer :: lstat + integer, pointer :: stat - if(associated(dep_states_mask)) then - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, v_field, dep_states_mask=dep_states_mask, stat = lstat) + integer :: lstat + + if(associated(dep_states_mask)) then + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, s_field, dep_states_mask=dep_states_mask, stat = lstat) + else + call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = lstat) + end if + stat = lstat else - call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = lstat) + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, s_field, dep_states_mask=dep_states_mask) + else + call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm, dep_states_mask=dep_states_mask) + end if end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, v_field, dep_states_mask=dep_states_mask) + else + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, s_field, stat = lstat) + else + call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm, stat = lstat) + end if + stat = lstat else - call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm, dep_states_mask=dep_states_mask) + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, s_field) + else + call calculate_diagnostic_variable_dep(states, state_index, s_field, algorithm = algorithm) + end if end if - end if - else - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, v_field, stat = lstat) + end if + + +end subroutine calculate_diagnostic_variable_dep_scalar + +subroutine calculate_diagnostic_variable_dep_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, dep_states_mask, stat) + + use fldebug + use fields + use state_module + use diagnostic_fields_new, only: calculate_diagnostic_variable_dep + + implicit none + + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + character(len = algorithm_len), intent(in) :: algorithm + type(state_type), dimension(:), pointer :: dep_states_mask + integer, pointer :: stat + + integer :: lstat + + if(associated(dep_states_mask)) then + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, v_field, dep_states_mask=dep_states_mask, stat = lstat) + else + call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = lstat) + end if + stat = lstat else - call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm, stat = lstat) + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, v_field, dep_states_mask=dep_states_mask) + else + call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm, dep_states_mask=dep_states_mask) + end if end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, v_field) + else + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, v_field, stat = lstat) + else + call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm, stat = lstat) + end if + stat = lstat else - call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm) + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, v_field) + else + call calculate_diagnostic_variable_dep(states, state_index, v_field, algorithm = algorithm) + end if end if - end if - end if + end if end subroutine calculate_diagnostic_variable_dep_vector subroutine calculate_diagnostic_variable_dep_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, dep_states_mask, stat) - use fldebug - use fields - use state_module - use diagnostic_fields_new, only: calculate_diagnostic_variable_dep - - implicit none - - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - character(len = algorithm_len), intent(in) :: algorithm - type(state_type), dimension(:), pointer :: dep_states_mask - integer, pointer :: stat - - integer :: lstat - - if(associated(dep_states_mask)) then - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, t_field, dep_states_mask=dep_states_mask, stat = lstat) + use fldebug + use fields + use state_module + use diagnostic_fields_new, only: calculate_diagnostic_variable_dep + + implicit none + + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + character(len = algorithm_len), intent(in) :: algorithm + type(state_type), dimension(:), pointer :: dep_states_mask + integer, pointer :: stat + + integer :: lstat + + if(associated(dep_states_mask)) then + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, t_field, dep_states_mask=dep_states_mask, stat = lstat) + else + call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = lstat) + end if + stat = lstat else - call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = lstat) + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, t_field, dep_states_mask=dep_states_mask) + else + call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm, dep_states_mask=dep_states_mask) + end if end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, t_field, dep_states_mask=dep_states_mask) - else - call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm, dep_states_mask=dep_states_mask) - end if - end if - else - if(associated(stat)) then - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, t_field, stat = lstat) - else - call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm, stat = lstat) - end if - stat = lstat - else - if(len_trim(algorithm) == 0) then - call calculate_diagnostic_variable_dep(states, state_index, t_field) + else + if(associated(stat)) then + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, t_field, stat = lstat) + else + call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm, stat = lstat) + end if + stat = lstat else - call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm) + if(len_trim(algorithm) == 0) then + call calculate_diagnostic_variable_dep(states, state_index, t_field) + else + call calculate_diagnostic_variable_dep(states, state_index, t_field, algorithm = algorithm) + end if end if - end if - end if + end if end subroutine calculate_diagnostic_variable_dep_tensor diff --git a/diagnostics/Diagnostic_Source_Fields.F90 b/diagnostics/Diagnostic_Source_Fields.F90 index 63fcb5a0d7..2747c02a62 100644 --- a/diagnostics/Diagnostic_Source_Fields.F90 +++ b/diagnostics/Diagnostic_Source_Fields.F90 @@ -29,506 +29,506 @@ module diagnostic_source_fields - use global_parameters, only : OPTION_PATH_LEN - use spud - use fldebug - use futils, only: int2str, tokenize - use fields - use state_module - use field_options + use global_parameters, only : OPTION_PATH_LEN + use spud + use fldebug + use futils, only: int2str, tokenize + use fields + use state_module + use field_options - implicit none + implicit none - private + private - public :: scalar_source_field, vector_source_field, tensor_source_field, check_source_mesh_derivative + public :: scalar_source_field, vector_source_field, tensor_source_field, check_source_mesh_derivative - interface scalar_source_field - module procedure scalar_source_field_scalar_single, & + interface scalar_source_field + module procedure scalar_source_field_scalar_single, & & scalar_source_field_vector_single, scalar_source_field_tensor_single, & & scalar_source_field_path_single, scalar_source_field_scalar_multiple, & & scalar_source_field_vector_multiple, & & scalar_source_field_tensor_multiple, scalar_source_field_path_multiple - end interface scalar_source_field + end interface scalar_source_field - interface vector_source_field - module procedure vector_source_field_scalar_single, & + interface vector_source_field + module procedure vector_source_field_scalar_single, & & vector_source_field_vector_single, vector_source_field_tensor_single, & & vector_source_field_path_single, vector_source_field_scalar_multiple, & & vector_source_field_vector_multiple, & & vector_source_field_tensor_multiple, vector_source_field_path_multiple - end interface vector_source_field + end interface vector_source_field - interface tensor_source_field - module procedure tensor_source_field_scalar_single, & + interface tensor_source_field + module procedure tensor_source_field_scalar_single, & & tensor_source_field_vector_single, tensor_source_field_tensor_single, & & tensor_source_field_path_single, tensor_source_field_scalar_multiple, & & tensor_source_field_vector_multiple, & & tensor_source_field_tensor_multiple, tensor_source_field_path_multiple - end interface tensor_source_field + end interface tensor_source_field - interface check_source_mesh_derivative - module procedure check_source_mesh_derivative_scalar, check_source_mesh_derivative_vector - end interface check_source_mesh_derivative + interface check_source_mesh_derivative + module procedure check_source_mesh_derivative_scalar, check_source_mesh_derivative_vector + end interface check_source_mesh_derivative contains - function source_field_component(path, index) - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index + function source_field_component(path, index) + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index - character(len = 2) :: source_field_component + character(len = 2) :: source_field_component - integer :: component, stat + integer :: component, stat - if(present(index)) then - assert(any(index == (/1, 2/))) - call get_option(trim(path) // "/algorithm/source_field_" // int2str(index) // "_component", component, stat) - else - call get_option(trim(path) // "/algorithm/source_field_component", component, stat) - end if - if(stat == SPUD_NO_ERROR) then - ! Allow truncation if necessary, as that can't be valid - source_field_component = "%" // int2str(component) - else - source_field_component = "" - end if + if(present(index)) then + assert(any(index == (/1, 2/))) + call get_option(trim(path) // "/algorithm/source_field_" // int2str(index) // "_component", component, stat) + else + call get_option(trim(path) // "/algorithm/source_field_component", component, stat) + end if + if(stat == SPUD_NO_ERROR) then + ! Allow truncation if necessary, as that can't be valid + source_field_component = "%" // int2str(component) + else + source_field_component = "" + end if - end function source_field_component + end function source_field_component - function source_field_name(path, index) - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index + function source_field_name(path, index) + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index - character(len = OPTION_PATH_LEN) :: source_field_name + character(len = OPTION_PATH_LEN) :: source_field_name - if(present(index)) then - assert(any(index == (/1, 2/))) - call get_option(trim(path) // "/algorithm/source_field_" // int2str(index) // "_name", source_field_name) - else - call get_option(trim(path) // "/algorithm/source_field_name", source_field_name) - end if + if(present(index)) then + assert(any(index == (/1, 2/))) + call get_option(trim(path) // "/algorithm/source_field_" // int2str(index) // "_name", source_field_name) + else + call get_option(trim(path) // "/algorithm/source_field_name", source_field_name) + end if - end function source_field_name + end function source_field_name - function scalar_source_field_scalar_single(state, s_field, index, allocated) result(source_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(in) :: s_field - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_scalar_single(state, s_field, index, allocated) result(source_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(in) :: s_field + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(state, s_field%option_path, index = index, allocated = allocated) + source_field => scalar_source_field(state, s_field%option_path, index = index, allocated = allocated) - end function scalar_source_field_scalar_single + end function scalar_source_field_scalar_single - function scalar_source_field_vector_single(state, v_field, index, allocated) result(source_field) - type(state_type), intent(in) :: state - type(vector_field), intent(in) :: v_field - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_vector_single(state, v_field, index, allocated) result(source_field) + type(state_type), intent(in) :: state + type(vector_field), intent(in) :: v_field + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(state, v_field%option_path, index = index, allocated = allocated) + source_field => scalar_source_field(state, v_field%option_path, index = index, allocated = allocated) - end function scalar_source_field_vector_single + end function scalar_source_field_vector_single - function scalar_source_field_tensor_single(state, t_field, index, allocated) result(source_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(in) :: t_field - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_tensor_single(state, t_field, index, allocated) result(source_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(in) :: t_field + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(state, t_field%option_path, index = index, allocated = allocated) + source_field => scalar_source_field(state, t_field%option_path, index = index, allocated = allocated) - end function scalar_source_field_tensor_single + end function scalar_source_field_tensor_single - function scalar_source_field_path_single(state, path, index, allocated) result(source_field) - type(state_type), intent(in) :: state - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_path_single(state, path, index, allocated) result(source_field) + type(state_type), intent(in) :: state + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: lpath, name + character(len = OPTION_PATH_LEN) :: lpath, name - lpath = complete_field_path(path) - name = source_field_name(lpath, index = index) - if(present(allocated)) then - source_field => extract_scalar_field(state, trim(name) // source_field_component(lpath, index = index), allocated = allocated) - else - source_field => extract_scalar_field(state, name) - end if + lpath = complete_field_path(path) + name = source_field_name(lpath, index = index) + if(present(allocated)) then + source_field => extract_scalar_field(state, trim(name) // source_field_component(lpath, index = index), allocated = allocated) + else + source_field => extract_scalar_field(state, name) + end if - end function scalar_source_field_path_single + end function scalar_source_field_path_single - function scalar_source_field_scalar_multiple(states, state_index, s_field, index, allocated) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(in) :: s_field - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_scalar_multiple(states, state_index, s_field, index, allocated) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(in) :: s_field + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(states, state_index, s_field%option_path, index = index, allocated = allocated) + source_field => scalar_source_field(states, state_index, s_field%option_path, index = index, allocated = allocated) - end function scalar_source_field_scalar_multiple + end function scalar_source_field_scalar_multiple - function scalar_source_field_vector_multiple(states, state_index, v_field, index, allocated) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(vector_field), intent(in) :: v_field - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_vector_multiple(states, state_index, v_field, index, allocated) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(vector_field), intent(in) :: v_field + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(states, state_index, v_field%option_path, index = index, allocated = allocated) + source_field => scalar_source_field(states, state_index, v_field%option_path, index = index, allocated = allocated) - end function scalar_source_field_vector_multiple + end function scalar_source_field_vector_multiple - function scalar_source_field_tensor_multiple(states, state_index, t_field, index, allocated) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(in) :: t_field - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_tensor_multiple(states, state_index, t_field, index, allocated) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(in) :: t_field + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(states, state_index, t_field%option_path, index = index, allocated = allocated) + source_field => scalar_source_field(states, state_index, t_field%option_path, index = index, allocated = allocated) - end function scalar_source_field_tensor_multiple + end function scalar_source_field_tensor_multiple - function scalar_source_field_path_multiple(states, state_index, path, index, allocated) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index - logical, optional, intent(out) :: allocated + function scalar_source_field_path_multiple(states, state_index, path, index, allocated) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index + logical, optional, intent(out) :: allocated - type(scalar_field), pointer :: source_field + type(scalar_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: lpath, name - character(len = OPTION_PATH_LEN), dimension(:), allocatable :: split_name - integer :: lstate_index + character(len = OPTION_PATH_LEN) :: lpath, name + character(len = OPTION_PATH_LEN), dimension(:), allocatable :: split_name + integer :: lstate_index - nullify(source_field) + nullify(source_field) - lpath = complete_field_path(path) - name = source_field_name(lpath, index = index) - call tokenize(trim(name), split_name, "::") - select case(size(split_name)) - case(1) - assert(state_index > 0 .and. state_index <= size(states)) - lstate_index = state_index - case(2) - lstate_index = 1 - do while(trim(states(lstate_index)%name) /= trim(split_name(1))) - lstate_index = lstate_index + 1 - end do - if(lstate_index > size(states)) then - ewrite(-1, *) "For source field name " // trim(name) - FLExit("State named " // trim(split_name(1)) // " not found") - end if - case default - ewrite(-1, *) "For source field name " // trim(name) - FLExit("Invalid source field name") - end select + lpath = complete_field_path(path) + name = source_field_name(lpath, index = index) + call tokenize(trim(name), split_name, "::") + select case(size(split_name)) + case(1) + assert(state_index > 0 .and. state_index <= size(states)) + lstate_index = state_index + case(2) + lstate_index = 1 + do while(trim(states(lstate_index)%name) /= trim(split_name(1))) + lstate_index = lstate_index + 1 + end do + if(lstate_index > size(states)) then + ewrite(-1, *) "For source field name " // trim(name) + FLExit("State named " // trim(split_name(1)) // " not found") + end if + case default + ewrite(-1, *) "For source field name " // trim(name) + FLExit("Invalid source field name") + end select - if(present(allocated)) then - source_field => extract_scalar_field(states(lstate_index), trim(split_name(size(split_name))) // source_field_component(lpath, index = index), allocated = allocated) - else - source_field => extract_scalar_field(states(lstate_index), split_name(size(split_name))) - end if + if(present(allocated)) then + source_field => extract_scalar_field(states(lstate_index), trim(split_name(size(split_name))) // source_field_component(lpath, index = index), allocated = allocated) + else + source_field => extract_scalar_field(states(lstate_index), split_name(size(split_name))) + end if - deallocate(split_name) + deallocate(split_name) - end function scalar_source_field_path_multiple + end function scalar_source_field_path_multiple - function vector_source_field_scalar_single(state, s_field, index) result(source_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(in) :: s_field - integer, optional, intent(in) :: index + function vector_source_field_scalar_single(state, s_field, index) result(source_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(in) :: s_field + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(state, s_field%option_path, index = index) + source_field => vector_source_field(state, s_field%option_path, index = index) - end function vector_source_field_scalar_single + end function vector_source_field_scalar_single - function vector_source_field_vector_single(state, v_field, index) result(source_field) - type(state_type), intent(in) :: state - type(vector_field), intent(in) :: v_field - integer, optional, intent(in) :: index + function vector_source_field_vector_single(state, v_field, index) result(source_field) + type(state_type), intent(in) :: state + type(vector_field), intent(in) :: v_field + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(state, v_field%option_path, index = index) + source_field => vector_source_field(state, v_field%option_path, index = index) - end function vector_source_field_vector_single + end function vector_source_field_vector_single - function vector_source_field_tensor_single(state, t_field, index) result(source_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(in) :: t_field - integer, optional, intent(in) :: index + function vector_source_field_tensor_single(state, t_field, index) result(source_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(in) :: t_field + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(state, t_field%option_path, index = index) + source_field => vector_source_field(state, t_field%option_path, index = index) - end function vector_source_field_tensor_single + end function vector_source_field_tensor_single - function vector_source_field_path_single(state, path, index) result(source_field) - type(state_type), intent(in) :: state - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index + function vector_source_field_path_single(state, path, index) result(source_field) + type(state_type), intent(in) :: state + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: name + character(len = OPTION_PATH_LEN) :: name - name = source_field_name(complete_field_path(path), index = index) - source_field => extract_vector_field(state, name) + name = source_field_name(complete_field_path(path), index = index) + source_field => extract_vector_field(state, name) - end function vector_source_field_path_single + end function vector_source_field_path_single - function vector_source_field_scalar_multiple(states, state_index, s_field, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(in) :: s_field - integer, optional, intent(in) :: index + function vector_source_field_scalar_multiple(states, state_index, s_field, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(in) :: s_field + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(states, state_index, s_field%option_path, index = index) + source_field => vector_source_field(states, state_index, s_field%option_path, index = index) - end function vector_source_field_scalar_multiple + end function vector_source_field_scalar_multiple - function vector_source_field_vector_multiple(states, state_index, v_field, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(vector_field), intent(in) :: v_field - integer, optional, intent(in) :: index + function vector_source_field_vector_multiple(states, state_index, v_field, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(vector_field), intent(in) :: v_field + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(states, state_index, v_field%option_path, index = index) + source_field => vector_source_field(states, state_index, v_field%option_path, index = index) - end function vector_source_field_vector_multiple + end function vector_source_field_vector_multiple - function vector_source_field_tensor_multiple(states, state_index, t_field, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(in) :: t_field - integer, optional, intent(in) :: index + function vector_source_field_tensor_multiple(states, state_index, t_field, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(in) :: t_field + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(states, state_index, t_field%option_path, index = index) + source_field => vector_source_field(states, state_index, t_field%option_path, index = index) - end function vector_source_field_tensor_multiple + end function vector_source_field_tensor_multiple - function vector_source_field_path_multiple(states, state_index, path, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index + function vector_source_field_path_multiple(states, state_index, path, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: name - character(len = OPTION_PATH_LEN), dimension(:), allocatable :: split_name - integer :: lstate_index + character(len = OPTION_PATH_LEN) :: name + character(len = OPTION_PATH_LEN), dimension(:), allocatable :: split_name + integer :: lstate_index - nullify(source_field) + nullify(source_field) - name = source_field_name(complete_field_path(path), index = index) - call tokenize(trim(name), split_name, "::") - select case(size(split_name)) - case(1) - assert(state_index > 0 .and. state_index <= size(states)) - lstate_index = state_index - case(2) - lstate_index = 1 - do while(trim(states(lstate_index)%name) /= trim(split_name(1))) - lstate_index = lstate_index + 1 - end do - if(lstate_index > size(states)) then - ewrite(-1, *) "For source field name " // trim(name) - FLExit("State named " // trim(split_name(1)) // " not found") - end if - case default - ewrite(-1, *) "For source field name " // trim(name) - FLExit("Invalid source field name") - end select + name = source_field_name(complete_field_path(path), index = index) + call tokenize(trim(name), split_name, "::") + select case(size(split_name)) + case(1) + assert(state_index > 0 .and. state_index <= size(states)) + lstate_index = state_index + case(2) + lstate_index = 1 + do while(trim(states(lstate_index)%name) /= trim(split_name(1))) + lstate_index = lstate_index + 1 + end do + if(lstate_index > size(states)) then + ewrite(-1, *) "For source field name " // trim(name) + FLExit("State named " // trim(split_name(1)) // " not found") + end if + case default + ewrite(-1, *) "For source field name " // trim(name) + FLExit("Invalid source field name") + end select - source_field => extract_vector_field(states(lstate_index), split_name(size(split_name))) + source_field => extract_vector_field(states(lstate_index), split_name(size(split_name))) - deallocate(split_name) + deallocate(split_name) - end function vector_source_field_path_multiple + end function vector_source_field_path_multiple - function tensor_source_field_scalar_single(state, s_field, index) result(source_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(in) :: s_field - integer, optional, intent(in) :: index + function tensor_source_field_scalar_single(state, s_field, index) result(source_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(in) :: s_field + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(state, s_field%option_path, index = index) + source_field => tensor_source_field(state, s_field%option_path, index = index) - end function tensor_source_field_scalar_single + end function tensor_source_field_scalar_single - function tensor_source_field_vector_single(state, v_field, index) result(source_field) - type(state_type), intent(in) :: state - type(vector_field), intent(in) :: v_field - integer, optional, intent(in) :: index + function tensor_source_field_vector_single(state, v_field, index) result(source_field) + type(state_type), intent(in) :: state + type(vector_field), intent(in) :: v_field + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(state, v_field%option_path, index = index) + source_field => tensor_source_field(state, v_field%option_path, index = index) - end function tensor_source_field_vector_single + end function tensor_source_field_vector_single - function tensor_source_field_tensor_single(state, t_field, index) result(source_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(in) :: t_field - integer, optional, intent(in) :: index + function tensor_source_field_tensor_single(state, t_field, index) result(source_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(in) :: t_field + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(state, t_field%option_path, index = index) + source_field => tensor_source_field(state, t_field%option_path, index = index) - end function tensor_source_field_tensor_single + end function tensor_source_field_tensor_single - function tensor_source_field_path_single(state, path, index) result(source_field) - type(state_type), intent(in) :: state - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index + function tensor_source_field_path_single(state, path, index) result(source_field) + type(state_type), intent(in) :: state + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: name + character(len = OPTION_PATH_LEN) :: name - name = source_field_name(complete_field_path(path), index = index) - source_field => extract_tensor_field(state, name) + name = source_field_name(complete_field_path(path), index = index) + source_field => extract_tensor_field(state, name) - end function tensor_source_field_path_single + end function tensor_source_field_path_single - function tensor_source_field_scalar_multiple(states, state_index, s_field, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(in) :: s_field - integer, optional, intent(in) :: index + function tensor_source_field_scalar_multiple(states, state_index, s_field, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(in) :: s_field + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(states, state_index, s_field%option_path, index = index) + source_field => tensor_source_field(states, state_index, s_field%option_path, index = index) - end function tensor_source_field_scalar_multiple + end function tensor_source_field_scalar_multiple - function tensor_source_field_vector_multiple(states, state_index, v_field, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(vector_field), intent(in) :: v_field - integer, optional, intent(in) :: index + function tensor_source_field_vector_multiple(states, state_index, v_field, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(vector_field), intent(in) :: v_field + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(states, state_index, v_field%option_path, index = index) + source_field => tensor_source_field(states, state_index, v_field%option_path, index = index) - end function tensor_source_field_vector_multiple + end function tensor_source_field_vector_multiple - function tensor_source_field_tensor_multiple(states, state_index, t_field, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(in) :: t_field - integer, optional, intent(in) :: index + function tensor_source_field_tensor_multiple(states, state_index, t_field, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(in) :: t_field + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(states, state_index, t_field%option_path, index = index) + source_field => tensor_source_field(states, state_index, t_field%option_path, index = index) - end function tensor_source_field_tensor_multiple + end function tensor_source_field_tensor_multiple - function tensor_source_field_path_multiple(states, state_index, path, index) result(source_field) - type(state_type), dimension(:), intent(in) :: states - integer, intent(in) :: state_index - character(len = *), intent(in) :: path - integer, optional, intent(in) :: index + function tensor_source_field_path_multiple(states, state_index, path, index) result(source_field) + type(state_type), dimension(:), intent(in) :: states + integer, intent(in) :: state_index + character(len = *), intent(in) :: path + integer, optional, intent(in) :: index - type(tensor_field), pointer :: source_field + type(tensor_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: name - character(len = OPTION_PATH_LEN), dimension(:), allocatable :: split_name - integer :: lstate_index + character(len = OPTION_PATH_LEN) :: name + character(len = OPTION_PATH_LEN), dimension(:), allocatable :: split_name + integer :: lstate_index - nullify(source_field) + nullify(source_field) - name = source_field_name(complete_field_path(path), index = index) - call tokenize(trim(name), split_name, "::") - select case(size(split_name)) - case(1) - assert(state_index > 0 .and. state_index <= size(states)) - lstate_index = state_index - case(2) - lstate_index = 1 - do while(trim(states(lstate_index)%name) /= trim(split_name(1))) - lstate_index = lstate_index + 1 - end do - if(lstate_index > size(states)) then - ewrite(-1, *) "For source field name " // trim(name) - FLExit("State named " // trim(split_name(1)) // " not found") - end if - case default - ewrite(-1, *) "For source field name " // trim(name) - FLExit("Invalid source field name") - end select + name = source_field_name(complete_field_path(path), index = index) + call tokenize(trim(name), split_name, "::") + select case(size(split_name)) + case(1) + assert(state_index > 0 .and. state_index <= size(states)) + lstate_index = state_index + case(2) + lstate_index = 1 + do while(trim(states(lstate_index)%name) /= trim(split_name(1))) + lstate_index = lstate_index + 1 + end do + if(lstate_index > size(states)) then + ewrite(-1, *) "For source field name " // trim(name) + FLExit("State named " // trim(split_name(1)) // " not found") + end if + case default + ewrite(-1, *) "For source field name " // trim(name) + FLExit("Invalid source field name") + end select - source_field => extract_tensor_field(states(lstate_index), split_name(size(split_name))) + source_field => extract_tensor_field(states(lstate_index), split_name(size(split_name))) - deallocate(split_name) + deallocate(split_name) - end function tensor_source_field_path_multiple + end function tensor_source_field_path_multiple - subroutine check_source_mesh_derivative_scalar(source_field, algorithm) - ! Auxilary routine that checks if the source field is not on a discontinuous mesh - type(scalar_field), intent(in):: source_field - character(len=*), intent(in):: algorithm + subroutine check_source_mesh_derivative_scalar(source_field, algorithm) + ! Auxilary routine that checks if the source field is not on a discontinuous mesh + type(scalar_field), intent(in):: source_field + character(len=*), intent(in):: algorithm - call check_derivative_mesh(source_field%mesh, source_field%name, algorithm) + call check_derivative_mesh(source_field%mesh, source_field%name, algorithm) - end subroutine check_source_mesh_derivative_scalar + end subroutine check_source_mesh_derivative_scalar - subroutine check_source_mesh_derivative_vector(source_field, algorithm) - ! Auxilary routine that checks if the source field is not on a discontinuous mesh - type(vector_field), intent(in):: source_field - character(len=*), intent(in):: algorithm + subroutine check_source_mesh_derivative_vector(source_field, algorithm) + ! Auxilary routine that checks if the source field is not on a discontinuous mesh + type(vector_field), intent(in):: source_field + character(len=*), intent(in):: algorithm - call check_derivative_mesh(source_field%mesh, source_field%name, algorithm) + call check_derivative_mesh(source_field%mesh, source_field%name, algorithm) - end subroutine check_source_mesh_derivative_vector + end subroutine check_source_mesh_derivative_vector - subroutine check_derivative_mesh(source_mesh, source_field_name, algorithm) - type(mesh_type), intent(in):: source_mesh - character(len=*), intent(in):: source_field_name, algorithm + subroutine check_derivative_mesh(source_mesh, source_field_name, algorithm) + type(mesh_type), intent(in):: source_mesh + character(len=*), intent(in):: source_field_name, algorithm - if (source_mesh%continuity<0) then - ewrite(-1,*) "For diagnostic algorithm ", trim(algorithm) - ewrite(-1,*) "need to take the derivative of field: ", trim(source_field_name) - ewrite(-1,*) "which is on a discontinuous mesh. The code does not support this." - ewrite(-1,*) "Please use a galerkin_projection first to derive a continuous approximation" - ewrite(-1,*) "of this field on which the diagnostic algorithm can then be applied." - FLExit("Diagnostic algorithm does not support discontinuous fields") - end if + if (source_mesh%continuity<0) then + ewrite(-1,*) "For diagnostic algorithm ", trim(algorithm) + ewrite(-1,*) "need to take the derivative of field: ", trim(source_field_name) + ewrite(-1,*) "which is on a discontinuous mesh. The code does not support this." + ewrite(-1,*) "Please use a galerkin_projection first to derive a continuous approximation" + ewrite(-1,*) "of this field on which the diagnostic algorithm can then be applied." + FLExit("Diagnostic algorithm does not support discontinuous fields") + end if - end subroutine check_derivative_mesh + end subroutine check_derivative_mesh end module diagnostic_source_fields diff --git a/diagnostics/Differential_Operators.F90 b/diagnostics/Differential_Operators.F90 index 52d10f2b79..aef71256bd 100644 --- a/diagnostics/Differential_Operators.F90 +++ b/diagnostics/Differential_Operators.F90 @@ -29,869 +29,869 @@ module differential_operator_diagnostics - use fldebug - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use vector_tools, only: solve - use quadrature - use elements - use spud - use sparse_tools - use eventcounter - use fetools - use fields - use state_module - use field_options - use diagnostic_source_fields - use field_derivatives - use sparse_matrices_fields - use sparsity_patterns_meshes - use state_fields_module - use divergence_matrix_cg - use solvers - use geostrophic_pressure - - implicit none - - private - - public :: calculate_grad, calculate_div, calculate_curl, calculate_perp, & - & calculate_hessian, calculate_grad_vector, & - & calculate_curl_2d, calculate_finite_element_divergence, & - & calculate_finite_element_divergence_transpose, & - & calculate_scalar_advection, calculate_scalar_laplacian, & - & calculate_vector_advection, calculate_vector_laplacian + use fldebug + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use vector_tools, only: solve + use quadrature + use elements + use spud + use sparse_tools + use eventcounter + use fetools + use fields + use state_module + use field_options + use diagnostic_source_fields + use field_derivatives + use sparse_matrices_fields + use sparsity_patterns_meshes + use state_fields_module + use divergence_matrix_cg + use solvers + use geostrophic_pressure + + implicit none + + private + + public :: calculate_grad, calculate_div, calculate_curl, calculate_perp, & + & calculate_hessian, calculate_grad_vector, & + & calculate_curl_2d, calculate_finite_element_divergence, & + & calculate_finite_element_divergence_transpose, & + & calculate_scalar_advection, calculate_scalar_laplacian, & + & calculate_vector_advection, calculate_vector_laplacian contains - subroutine calculate_grad(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_grad(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field + + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions + + source_field => scalar_source_field(state, v_field) + if (source_field%mesh%continuity<0 .and. .not. (v_field%mesh%continuity<0)) then + ewrite(-1,*) "For diagnostic algorithm (grad)" + ewrite(-1,*) "You are trying to take the derivative of field: ", trim(source_field%name) + ewrite(-1,*) "which is on a discontinuous mesh. and store it on: ", trim(v_field%name) + ewrite(-1,*) "which is continuous. The code does not support this." + ewrite(-1,*) "Please change the diagnostic field discretisation to discontinuous" + ewrite(-1,*) "or use a galerkin_projection first to derive a continuous approximation" + ewrite(-1,*) "of the source field." + FLExit("Diagnostic algorithm does not support taking continuous gradients of discontinuous fields") + end if - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions + positions => extract_vector_field(state, "Coordinate") - source_field => scalar_source_field(state, v_field) - if (source_field%mesh%continuity<0 .and. .not. (v_field%mesh%continuity<0)) then - ewrite(-1,*) "For diagnostic algorithm (grad)" - ewrite(-1,*) "You are trying to take the derivative of field: ", trim(source_field%name) - ewrite(-1,*) "which is on a discontinuous mesh. and store it on: ", trim(v_field%name) - ewrite(-1,*) "which is continuous. The code does not support this." - ewrite(-1,*) "Please change the diagnostic field discretisation to discontinuous" - ewrite(-1,*) "or use a galerkin_projection first to derive a continuous approximation" - ewrite(-1,*) "of the source field." - FLExit("Diagnostic algorithm does not support taking continuous gradients of discontinuous fields") - end if + call grad(source_field, positions, v_field) - positions => extract_vector_field(state, "Coordinate") + end subroutine calculate_grad - call grad(source_field, positions, v_field) + subroutine calculate_grad_vector(state, t_field) + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field - end subroutine calculate_grad + type(vector_field), pointer :: source_field + type(vector_field), pointer :: positions - subroutine calculate_grad_vector(state, t_field) - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field + positions => extract_vector_field(state, "Coordinate") + source_field => vector_source_field(state, t_field) + if (source_field%mesh%continuity<0 .and. .not. (t_field%mesh%continuity<0)) then + ewrite(-1,*) "For diagnostic algorithm (grad)" + ewrite(-1,*) "You are trying to take the derivative of field: ", trim(source_field%name) + ewrite(-1,*) "which is on a discontinuous mesh. and store it on: ", trim(t_field%name) + ewrite(-1,*) "which is continuous. The code does not support this." + ewrite(-1,*) "Please change the diagnostic field discretisation to discontinuous" + ewrite(-1,*) "or use a galerkin_projection first to derive a continuous approximation" + ewrite(-1,*) "of the source field." + FLExit("Diagnostic algorithm does not support taking continuous gradients of discontinuous fields") + end if - type(vector_field), pointer :: source_field - type(vector_field), pointer :: positions + call grad(source_field, positions, t_field) - positions => extract_vector_field(state, "Coordinate") - source_field => vector_source_field(state, t_field) - if (source_field%mesh%continuity<0 .and. .not. (t_field%mesh%continuity<0)) then - ewrite(-1,*) "For diagnostic algorithm (grad)" - ewrite(-1,*) "You are trying to take the derivative of field: ", trim(source_field%name) - ewrite(-1,*) "which is on a discontinuous mesh. and store it on: ", trim(t_field%name) - ewrite(-1,*) "which is continuous. The code does not support this." - ewrite(-1,*) "Please change the diagnostic field discretisation to discontinuous" - ewrite(-1,*) "or use a galerkin_projection first to derive a continuous approximation" - ewrite(-1,*) "of the source field." - FLExit("Diagnostic algorithm does not support taking continuous gradients of discontinuous fields") - end if + end subroutine calculate_grad_vector - call grad(source_field, positions, t_field) + subroutine calculate_hessian(state, t_field) + ! Compute Hessian of a scalar field + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field - end subroutine calculate_grad_vector + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions - subroutine calculate_hessian(state, t_field) - ! Compute Hessian of a scalar field - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field + positions => extract_vector_field(state, "Coordinate") + source_field => scalar_source_field(state, t_field) - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions + call check_source_mesh_derivative(source_field, "hessian") - positions => extract_vector_field(state, "Coordinate") - source_field => scalar_source_field(state, t_field) + call compute_hessian(source_field, positions, t_field) - call check_source_mesh_derivative(source_field, "hessian") + end subroutine calculate_hessian - call compute_hessian(source_field, positions, t_field) + subroutine calculate_div(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - end subroutine calculate_hessian + type(vector_field), pointer :: positions, source_field - subroutine calculate_div(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + source_field => vector_source_field(state, s_field) - type(vector_field), pointer :: positions, source_field + positions => extract_vector_field(state, "Coordinate") - source_field => vector_source_field(state, s_field) + call check_source_mesh_derivative(source_field, "div") - positions => extract_vector_field(state, "Coordinate") + call div(source_field, positions, s_field) - call check_source_mesh_derivative(source_field, "div") + end subroutine calculate_div - call div(source_field, positions, s_field) + subroutine calculate_finite_element_divergence(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - end subroutine calculate_div + character(len = OPTION_PATH_LEN) :: path + type(block_csr_matrix), pointer :: ct_m + type(csr_sparsity), pointer :: divergence_sparsity + type(csr_matrix), pointer :: mass + type(scalar_field) :: ctfield, ct_rhs + type(scalar_field), pointer :: masslump + type(vector_field), pointer :: positions, source_field + logical :: using_divergence_matrix_cache - subroutine calculate_finite_element_divergence(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + source_field => vector_source_field(state, s_field) + path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - character(len = OPTION_PATH_LEN) :: path - type(block_csr_matrix), pointer :: ct_m - type(csr_sparsity), pointer :: divergence_sparsity - type(csr_matrix), pointer :: mass - type(scalar_field) :: ctfield, ct_rhs - type(scalar_field), pointer :: masslump - type(vector_field), pointer :: positions, source_field - logical :: using_divergence_matrix_cache + using_divergence_matrix_cache = use_divergence_matrix_cache(state) + if(using_divergence_matrix_cache) then + ct_m => extract_block_csr_matrix(state, trim(s_field%name) // "DivergenceMatrix") + call incref(ct_m) + ct_rhs = extract_scalar_field(state, trim(s_field%name) // "DivergenceRHS") + call incref(ct_rhs) + else + positions => extract_vector_field(state, "Coordinate") + + divergence_sparsity => get_csr_sparsity_firstorder(state, s_field%mesh, source_field%mesh) + allocate(ct_m) + call allocate(ct_m, divergence_sparsity, (/1, source_field%dim/), name = "DivergenceMatrix" ) + call allocate(ct_rhs, s_field%mesh, name = "CTRHS") + + call assemble_divergence_matrix_cg(ct_m, state, ct_rhs = ct_rhs, & + & test_mesh = s_field%mesh, field = source_field, & + & option_path = path) + call insert(state, ct_m, trim(s_field%name) // "DivergenceMatrix") + call insert(state, ct_rhs, trim(s_field%name) // "DivergenceRHS") + end if - source_field => vector_source_field(state, s_field) - path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + call allocate(ctfield, s_field%mesh, name = "CTField") + call mult(ctfield, ct_m, source_field) + call addto(ctfield, ct_rhs, -1.0) + call deallocate(ct_rhs) - using_divergence_matrix_cache = use_divergence_matrix_cache(state) - if(using_divergence_matrix_cache) then - ct_m => extract_block_csr_matrix(state, trim(s_field%name) // "DivergenceMatrix") - call incref(ct_m) - ct_rhs = extract_scalar_field(state, trim(s_field%name) // "DivergenceRHS") - call incref(ct_rhs) - else - positions => extract_vector_field(state, "Coordinate") + if(have_option(trim(path) // "/lump_mass")) then + masslump => get_lumped_mass(state, s_field%mesh) + s_field%val = ctfield%val / masslump%val + else + mass => get_mass_matrix(state, s_field%mesh) + call petsc_solve(s_field, mass, ctfield, option_path = path) + end if - divergence_sparsity => get_csr_sparsity_firstorder(state, s_field%mesh, source_field%mesh) - allocate(ct_m) - call allocate(ct_m, divergence_sparsity, (/1, source_field%dim/), name = "DivergenceMatrix" ) - call allocate(ct_rhs, s_field%mesh, name = "CTRHS") + call deallocate(ct_m) + if(.not.using_divergence_matrix_cache)then + deallocate(ct_m) + end if + call deallocate(ctfield) - call assemble_divergence_matrix_cg(ct_m, state, ct_rhs = ct_rhs, & - & test_mesh = s_field%mesh, field = source_field, & - & option_path = path) - call insert(state, ct_m, trim(s_field%name) // "DivergenceMatrix") - call insert(state, ct_rhs, trim(s_field%name) // "DivergenceRHS") - end if + contains - call allocate(ctfield, s_field%mesh, name = "CTField") - call mult(ctfield, ct_m, source_field) - call addto(ctfield, ct_rhs, -1.0) - call deallocate(ct_rhs) + function use_divergence_matrix_cache(state) result(use_cache) + type(state_type), intent(in) :: state - if(have_option(trim(path) // "/lump_mass")) then - masslump => get_lumped_mass(state, s_field%mesh) - s_field%val = ctfield%val / masslump%val - else - mass => get_mass_matrix(state, s_field%mesh) - call petsc_solve(s_field, mass, ctfield, option_path = path) - end if + logical :: use_cache - call deallocate(ct_m) - if(.not.using_divergence_matrix_cache)then - deallocate(ct_m) - end if - call deallocate(ctfield) + integer, save :: last_mesh_movement = -1 - contains + if(has_block_csr_matrix(state, trim(s_field%name) // "DivergenceMatrix")) then + use_cache = (last_mesh_movement == eventcount(EVENT_MESH_MOVEMENT)) + else + use_cache = .false. + end if - function use_divergence_matrix_cache(state) result(use_cache) - type(state_type), intent(in) :: state + if(use_cache) then + ewrite(2, *) "Using cached divergence matrix" + else + ewrite(2, *) "Not using cached divergence matrix" + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end if + + end function use_divergence_matrix_cache + + end subroutine calculate_finite_element_divergence + + subroutine calculate_finite_element_divergence_transpose(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field - logical :: use_cache + character(len = FIELD_NAME_LEN) :: bcfield_name + character(len = OPTION_PATH_LEN) :: path + type(cmc_matrices) :: matrices + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: bcfield - integer, save :: last_mesh_movement = -1 + source_field => scalar_source_field(state, v_field) - if(has_block_csr_matrix(state, trim(s_field%name) // "DivergenceMatrix")) then - use_cache = (last_mesh_movement == eventcount(EVENT_MESH_MOVEMENT)) + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + if(have_option(trim(path) // "/bc_field")) then + call get_option(trim(path) // "/bc_field/name", bcfield_name) + bcfield => extract_vector_field(state, bcfield_name) + call allocate(matrices, state, v_field, source_field, bcfield = bcfield, option_path = path, add_cmc = .false.) else - use_cache = .false. + call allocate(matrices, state, v_field, source_field, option_path = path, add_cmc = .false.) end if - if(use_cache) then - ewrite(2, *) "Using cached divergence matrix" - else - ewrite(2, *) "Not using cached divergence matrix" - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + call compute_conservative(matrices, v_field, source_field) + call deallocate(matrices) + + end subroutine calculate_finite_element_divergence_transpose + + subroutine calculate_perp(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field + + character(len = OPTION_PATH_LEN) :: path + integer :: i + type(csr_matrix), pointer :: mass + type(scalar_field), pointer :: masslump + type(scalar_field), pointer :: source_field + type(vector_field) :: rhs + type(vector_field), pointer :: positions + + write(1, *) "In calculate_perp" + + source_field => scalar_source_field(state, v_field) + ewrite(2, *) "Calculating perp of field: " // trim(source_field%name) + ewrite(2, *) "On mesh: " // trim(source_field%mesh%name) + ewrite(2, *) "Diagnostic field: " // trim(v_field%name) + ewrite(2, *) "On mesh: " // trim(v_field%mesh%name) + + if(v_field%dim /= 2) then + FLExit("Can only calculate perp in 2D") end if - end function use_divergence_matrix_cache + call check_source_mesh_derivative(source_field, "perp") - end subroutine calculate_finite_element_divergence + positions => extract_vector_field(state, "Coordinate") + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + + if(have_option(trim(path) // "/lump_mass")) then + masslump => get_lumped_mass(state, v_field%mesh) + call zero(v_field) + do i = 1, ele_count(v_field) + call assemble_perp_ele(i, positions, source_field, v_field) + end do + do i = 1, v_field%dim + v_field%val(i,:) = v_field%val(i,:) / masslump%val + end do + else + select case(continuity(v_field)) + case(0) + if(.not. have_option(trim(path) // "/solver")) then + FLExit("For continuous perp, must supply solver options when not lumping mass") + end if + mass => get_mass_matrix(state, v_field%mesh) + call allocate(rhs, v_field%dim, v_field%mesh, "PerpRHS") + call zero(rhs) + do i = 1, ele_count(rhs) + call assemble_perp_ele(i, positions, source_field, rhs) + end do + call petsc_solve(v_field, mass, rhs, option_path = path) + call deallocate(rhs) + case(-1) + do i = 1, ele_count(v_field) + call solve_perp_ele(i, positions, source_field, v_field) + end do + case default + ewrite(-1, *) "For mesh continuity: ", continuity(v_field) + FLAbort("Unrecognised mesh continuity") + end select + end if - subroutine calculate_finite_element_divergence_transpose(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field + contains - character(len = FIELD_NAME_LEN) :: bcfield_name - character(len = OPTION_PATH_LEN) :: path - type(cmc_matrices) :: matrices - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: bcfield + subroutine assemble_perp_ele(ele, positions, source, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source + type(vector_field), intent(inout) :: rhs - source_field => scalar_source_field(state, v_field) + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(positions%dim, ele_ngi(source, ele)) :: grad_source_gi + real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/bc_field")) then - call get_option(trim(path) // "/bc_field/name", bcfield_name) - bcfield => extract_vector_field(state, bcfield_name) - call allocate(matrices, state, v_field, source_field, bcfield = bcfield, option_path = path, add_cmc = .false.) - else - call allocate(matrices, state, v_field, source_field, option_path = path, add_cmc = .false.) - end if + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - call compute_conservative(matrices, v_field, source_field) - call deallocate(matrices) + grad_source_gi = ele_grad_at_quad(source, ele, dshape) - end subroutine calculate_finite_element_divergence_transpose + call addto(rhs, 1, ele_nodes(rhs, ele), & + & shape_rhs(ele_shape(rhs, ele), grad_source_gi(2,:) * detwei)) + call addto(rhs, 2, ele_nodes(rhs, ele), & + & shape_rhs(ele_shape(rhs, ele), -grad_source_gi(1,:) * detwei)) - subroutine calculate_perp(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field + end subroutine assemble_perp_ele - character(len = OPTION_PATH_LEN) :: path - integer :: i - type(csr_matrix), pointer :: mass - type(scalar_field), pointer :: masslump - type(scalar_field), pointer :: source_field - type(vector_field) :: rhs - type(vector_field), pointer :: positions + subroutine solve_perp_ele(ele, positions, source, perp) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source + type(vector_field), intent(inout) :: perp - write(1, *) "In calculate_perp" + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(positions%dim, ele_ngi(source, ele)) :: grad_source_gi + real, dimension(ele_loc(perp, ele), perp%dim) :: little_rhs + real, dimension(ele_loc(perp, ele), ele_loc(perp, ele)) :: little_mass + real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape + type(element_type), pointer :: shape - source_field => scalar_source_field(state, v_field) - ewrite(2, *) "Calculating perp of field: " // trim(source_field%name) - ewrite(2, *) "On mesh: " // trim(source_field%mesh%name) - ewrite(2, *) "Diagnostic field: " // trim(v_field%name) - ewrite(2, *) "On mesh: " // trim(v_field%mesh%name) + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - if(v_field%dim /= 2) then - FLExit("Can only calculate perp in 2D") - end if + grad_source_gi = ele_grad_at_quad(source, ele, dshape) - call check_source_mesh_derivative(source_field, "perp") + shape => ele_shape(perp, ele) - positions => extract_vector_field(state, "Coordinate") - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + little_mass = shape_shape(shape, shape, detwei) + little_rhs(:, 1) = shape_rhs(shape, grad_source_gi(2,:) * detwei) + little_rhs(:, 2) = shape_rhs(shape, -grad_source_gi(1,:) * detwei) - if(have_option(trim(path) // "/lump_mass")) then - masslump => get_lumped_mass(state, v_field%mesh) - call zero(v_field) - do i = 1, ele_count(v_field) - call assemble_perp_ele(i, positions, source_field, v_field) - end do - do i = 1, v_field%dim - v_field%val(i,:) = v_field%val(i,:) / masslump%val - end do - else - select case(continuity(v_field)) - case(0) - if(.not. have_option(trim(path) // "/solver")) then - FLExit("For continuous perp, must supply solver options when not lumping mass") - end if - mass => get_mass_matrix(state, v_field%mesh) - call allocate(rhs, v_field%dim, v_field%mesh, "PerpRHS") - call zero(rhs) - do i = 1, ele_count(rhs) - call assemble_perp_ele(i, positions, source_field, rhs) - end do - call petsc_solve(v_field, mass, rhs, option_path = path) - call deallocate(rhs) - case(-1) - do i = 1, ele_count(v_field) - call solve_perp_ele(i, positions, source_field, v_field) - end do - case default - ewrite(-1, *) "For mesh continuity: ", continuity(v_field) - FLAbort("Unrecognised mesh continuity") - end select - end if - - contains - - subroutine assemble_perp_ele(ele, positions, source, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source - type(vector_field), intent(inout) :: rhs + call solve(little_mass, little_rhs) - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(positions%dim, ele_ngi(source, ele)) :: grad_source_gi - real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape + call set(perp, ele_nodes(perp, ele), transpose(little_rhs)) - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + end subroutine solve_perp_ele - grad_source_gi = ele_grad_at_quad(source, ele, dshape) + end subroutine calculate_perp - call addto(rhs, 1, ele_nodes(rhs, ele), & - & shape_rhs(ele_shape(rhs, ele), grad_source_gi(2,:) * detwei)) - call addto(rhs, 2, ele_nodes(rhs, ele), & - & shape_rhs(ele_shape(rhs, ele), -grad_source_gi(1,:) * detwei)) + subroutine calculate_curl_2d(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - end subroutine assemble_perp_ele + character(len = OPTION_PATH_LEN) :: path + integer :: i + type(csr_matrix), pointer :: mass + type(scalar_field), pointer :: masslump + type(scalar_field) :: rhs + type(vector_field), pointer :: positions, source_field - subroutine solve_perp_ele(ele, positions, source, perp) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source - type(vector_field), intent(inout) :: perp + ewrite(1, *) "In calculate_curl_2d" - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(positions%dim, ele_ngi(source, ele)) :: grad_source_gi - real, dimension(ele_loc(perp, ele), perp%dim) :: little_rhs - real, dimension(ele_loc(perp, ele), ele_loc(perp, ele)) :: little_mass - real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape - type(element_type), pointer :: shape + source_field => vector_source_field(state, s_field) + ewrite(2, *) "Calculating curl of field: " // trim(source_field%name) + ewrite(2, *) "On mesh: " // trim(source_field%mesh%name) + ewrite(2, *) "Diagnostic field: " // trim(s_field%name) + ewrite(2, *) "On mesh: " // trim(s_field%mesh%name) - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + if(source_field%dim /= 2) then + FLExit("Can only calculate 2D curl in 2D") + end if - grad_source_gi = ele_grad_at_quad(source, ele, dshape) + if(continuity(s_field)==-1 .and. continuity(source_field)==-1) then + ewrite(-1,*) "If you want to compute the 2d curl of a DG vector field, "// & + "the diagnostic field itself should be on a continuous mesh." + FLExit("Cannot compute 2D curl of DG field onto a DG mesh") + end if - shape => ele_shape(perp, ele) + positions => extract_vector_field(state, "Coordinate") + path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + if(have_option(trim(path) // "/lump_mass")) then + masslump => get_lumped_mass(state, s_field%mesh) - little_mass = shape_shape(shape, shape, detwei) - little_rhs(:, 1) = shape_rhs(shape, grad_source_gi(2,:) * detwei) - little_rhs(:, 2) = shape_rhs(shape, -grad_source_gi(1,:) * detwei) + call zero(s_field) + call assemble_rhs(positions, source_field, s_field) - call solve(little_mass, little_rhs) + s_field%val = s_field%val / masslump%val + else + select case(continuity(s_field)) + case(0) + if(.not. have_option(trim(path) // "/solver")) then + FLExit("For continuous curl, must supply solver options when not lumping mass") + end if + mass => get_mass_matrix(state, s_field%mesh) + call allocate(rhs, s_field%mesh, "CurlRHS") + call zero(rhs) + call assemble_rhs(positions, source_field, rhs) + + call zero(s_field) + + call petsc_solve(s_field, mass, rhs, option_path = path) + call deallocate(rhs) + case(-1) + do i = 1, ele_count(s_field) + call solve_curl_ele(i, positions, source_field, s_field) + end do + case default + ewrite(-1, *) "For mesh continuity: ", continuity(s_field) + FLAbort("Unrecognised mesh continuity") + end select + end if - call set(perp, ele_nodes(perp, ele), transpose(little_rhs)) + ewrite_minmax(s_field) - end subroutine solve_perp_ele + ewrite(1, *) "Exiting calculate_curl_2d" - end subroutine calculate_perp + contains - subroutine calculate_curl_2d(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + subroutine assemble_rhs(positions, source, rhs) + type(vector_field), intent(in) :: positions, source + type(scalar_field), intent(inout) :: rhs - character(len = OPTION_PATH_LEN) :: path - integer :: i - type(csr_matrix), pointer :: mass - type(scalar_field), pointer :: masslump - type(scalar_field) :: rhs - type(vector_field), pointer :: positions, source_field + integer :: ele, sele - ewrite(1, *) "In calculate_curl_2d" + select case (continuity(source)) + case (0) + do ele = 1, ele_count(rhs) + call assemble_curl_ele(ele, positions, source, rhs) + end do + case (-1) + do ele = 1, ele_count(rhs) + call assemble_curl_ele_dg(ele, positions, source, rhs) + end do + do sele = 1, surface_element_count(rhs) + call assemble_curl_sele_dg(sele, positions, source, rhs) + end do + case default + ewrite(-1, *) "For mesh continuity: ", continuity(source) + FLAbort("Unrecognised mesh continuity") + end select - source_field => vector_source_field(state, s_field) - ewrite(2, *) "Calculating curl of field: " // trim(source_field%name) - ewrite(2, *) "On mesh: " // trim(source_field%mesh%name) - ewrite(2, *) "Diagnostic field: " // trim(s_field%name) - ewrite(2, *) "On mesh: " // trim(s_field%mesh%name) + end subroutine assemble_rhs - if(source_field%dim /= 2) then - FLExit("Can only calculate 2D curl in 2D") - end if + subroutine assemble_curl_ele(ele, positions, source, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source + type(scalar_field), intent(inout) :: rhs - if(continuity(s_field)==-1 .and. continuity(source_field)==-1) then - ewrite(-1,*) "If you want to compute the 2d curl of a DG vector field, "// & - "the diagnostic field itself should be on a continuous mesh." - FLExit("Cannot compute 2D curl of DG field onto a DG mesh") - end if + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape - positions => extract_vector_field(state, "Coordinate") - path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/lump_mass")) then - masslump => get_lumped_mass(state, s_field%mesh) + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - call zero(s_field) - call assemble_rhs(positions, source_field, s_field) + call addto(rhs, ele_nodes(rhs, ele), & + & shape_rhs(ele_shape(rhs, ele), & + & ele_2d_curl_at_quad(source, ele, dshape) * detwei)) - s_field%val = s_field%val / masslump%val - else - select case(continuity(s_field)) - case(0) - if(.not. have_option(trim(path) // "/solver")) then - FLExit("For continuous curl, must supply solver options when not lumping mass") - end if - mass => get_mass_matrix(state, s_field%mesh) - call allocate(rhs, s_field%mesh, "CurlRHS") - call zero(rhs) - call assemble_rhs(positions, source_field, rhs) - - call zero(s_field) - - call petsc_solve(s_field, mass, rhs, option_path = path) - call deallocate(rhs) - case(-1) - do i = 1, ele_count(s_field) - call solve_curl_ele(i, positions, source_field, s_field) - end do - case default - ewrite(-1, *) "For mesh continuity: ", continuity(s_field) - FLAbort("Unrecognised mesh continuity") - end select - end if - - ewrite_minmax(s_field) - - ewrite(1, *) "Exiting calculate_curl_2d" - - contains - - subroutine assemble_rhs(positions, source, rhs) - type(vector_field), intent(in) :: positions, source - type(scalar_field), intent(inout) :: rhs - - integer :: ele, sele - - select case (continuity(source)) - case (0) - do ele = 1, ele_count(rhs) - call assemble_curl_ele(ele, positions, source, rhs) - end do - case (-1) - do ele = 1, ele_count(rhs) - call assemble_curl_ele_dg(ele, positions, source, rhs) - end do - do sele = 1, surface_element_count(rhs) - call assemble_curl_sele_dg(sele, positions, source, rhs) - end do - case default - ewrite(-1, *) "For mesh continuity: ", continuity(source) - FLAbort("Unrecognised mesh continuity") - end select - - end subroutine assemble_rhs - - subroutine assemble_curl_ele(ele, positions, source, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source - type(scalar_field), intent(inout) :: rhs + end subroutine assemble_curl_ele - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape + subroutine assemble_curl_ele_dg(ele, positions, source, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source + type(scalar_field), intent(inout) :: rhs - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), positions%dim) :: dshape, skew_dshape - call addto(rhs, ele_nodes(rhs, ele), & - & shape_rhs(ele_shape(rhs, ele), & - & ele_2d_curl_at_quad(source, ele, dshape) * detwei)) + call transform_to_physical(positions, ele, ele_shape(rhs, ele), & + & dshape = dshape, detwei = detwei) - end subroutine assemble_curl_ele + ! this computes *minus* the skew, as we integrate by parts + skew_dshape(:,:,1) = dshape(:,:,2) + skew_dshape(:,:,2) = -dshape(:,:,1) - subroutine assemble_curl_ele_dg(ele, positions, source, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source - type(scalar_field), intent(inout) :: rhs + call addto(rhs, ele_nodes(rhs, ele), & + & dshape_dot_vector_rhs(skew_dshape, ele_val_at_quad(source, ele) , detwei)) - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), positions%dim) :: dshape, skew_dshape + end subroutine assemble_curl_ele_dg - call transform_to_physical(positions, ele, ele_shape(rhs, ele), & - & dshape = dshape, detwei = detwei) + subroutine assemble_curl_sele_dg(sele, positions, source, rhs) + integer, intent(in) :: sele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source + type(scalar_field), intent(inout) :: rhs - ! this computes *minus* the skew, as we integrate by parts - skew_dshape(:,:,1) = dshape(:,:,2) - skew_dshape(:,:,2) = -dshape(:,:,1) + real, dimension(face_ngi(positions,sele)) :: detwei + real, dimension(positions%dim, size(detwei)) :: face_normals, face_tangents - call addto(rhs, ele_nodes(rhs, ele), & - & dshape_dot_vector_rhs(skew_dshape, ele_val_at_quad(source, ele) , detwei)) + call transform_facet_to_physical(positions, sele, detwei, face_normals) + face_tangents(1,:) = -face_normals(2,:) + face_tangents(2,:) = face_normals(1,:) - end subroutine assemble_curl_ele_dg + ! work around for gfortran bug http://gcc.gnu.org/bugzilla/show_bug.cgi?id=57798 + ! if you put the product below directly in the sum(..,dim=1) you get a segfault on 4.8.1 + face_tangents = face_tangents*face_val_at_quad(source, sele) - subroutine assemble_curl_sele_dg(sele, positions, source, rhs) - integer, intent(in) :: sele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source - type(scalar_field), intent(inout) :: rhs + call addto(rhs, face_global_nodes(rhs, sele), & + & shape_rhs(face_shape(rhs, sele), detwei* & + & sum(face_tangents, dim=1))) - real, dimension(face_ngi(positions,sele)) :: detwei - real, dimension(positions%dim, size(detwei)) :: face_normals, face_tangents + end subroutine assemble_curl_sele_dg - call transform_facet_to_physical(positions, sele, detwei, face_normals) - face_tangents(1,:) = -face_normals(2,:) - face_tangents(2,:) = face_normals(1,:) + subroutine solve_curl_ele(ele, positions, source, curl) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source + type(scalar_field), intent(inout) :: curl - ! work around for gfortran bug http://gcc.gnu.org/bugzilla/show_bug.cgi?id=57798 - ! if you put the product below directly in the sum(..,dim=1) you get a segfault on 4.8.1 - face_tangents = face_tangents*face_val_at_quad(source, sele) + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(curl, ele)) :: little_rhs + real, dimension(ele_loc(curl, ele), ele_loc(curl, ele)) :: little_mass + real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape + type(element_type), pointer :: shape - call addto(rhs, face_global_nodes(rhs, sele), & - & shape_rhs(face_shape(rhs, sele), detwei* & - & sum(face_tangents, dim=1))) + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - end subroutine assemble_curl_sele_dg + shape => ele_shape(curl, ele) - subroutine solve_curl_ele(ele, positions, source, curl) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source - type(scalar_field), intent(inout) :: curl + little_mass = shape_shape(shape, shape, detwei) + little_rhs = shape_rhs(shape, ele_2d_curl_at_quad(source, ele, dshape) * detwei) - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(curl, ele)) :: little_rhs - real, dimension(ele_loc(curl, ele), ele_loc(curl, ele)) :: little_mass - real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape - type(element_type), pointer :: shape + call solve(little_mass, little_rhs) - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + call set(curl, ele_nodes(curl, ele), little_rhs) - shape => ele_shape(curl, ele) + end subroutine solve_curl_ele - little_mass = shape_shape(shape, shape, detwei) - little_rhs = shape_rhs(shape, ele_2d_curl_at_quad(source, ele, dshape) * detwei) + end subroutine calculate_curl_2d - call solve(little_mass, little_rhs) + subroutine calculate_curl(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field - call set(curl, ele_nodes(curl, ele), little_rhs) + character(len = OPTION_PATH_LEN) :: path + integer :: i + type(csr_matrix), pointer :: mass + type(scalar_field), pointer :: masslump + type(vector_field) :: rhs + type(vector_field), pointer :: positions, source_field - end subroutine solve_curl_ele + ewrite(1, *) "In calculate_curl" - end subroutine calculate_curl_2d + source_field => vector_source_field(state, v_field) + ewrite(2, *) "Calculating curl of field: " // trim(source_field%name) + ewrite(2, *) "On mesh: " // trim(source_field%mesh%name) + ewrite(2, *) "Diagnostic field: " // trim(v_field%name) + ewrite(2, *) "On mesh: " // trim(v_field%mesh%name) - subroutine calculate_curl(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field + if(source_field%dim /= 3) then + FLExit("Can only calculate curl in 3D") + end if - character(len = OPTION_PATH_LEN) :: path - integer :: i - type(csr_matrix), pointer :: mass - type(scalar_field), pointer :: masslump - type(vector_field) :: rhs - type(vector_field), pointer :: positions, source_field + call check_source_mesh_derivative(source_field, "curl") - ewrite(1, *) "In calculate_curl" + positions => extract_vector_field(state, "Coordinate") + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + if(have_option(trim(path) // "/lump_mass")) then + masslump => get_lumped_mass(state, v_field%mesh) + call zero(v_field) + do i = 1, ele_count(v_field) + call assemble_curl_ele(i, positions, source_field, v_field) + end do + do i = 1, v_field%dim + v_field%val(i,:) = v_field%val(i,:) / masslump%val + end do + else + select case(continuity(v_field)) + case(0) + if(.not. have_option(trim(path) // "/solver")) then + FLExit("For continuous curl, must supply solver options when not lumping mass") + end if + mass => get_mass_matrix(state, v_field%mesh) + call allocate(rhs, v_field%dim, v_field%mesh, "CurlRHS") + call zero(rhs) + do i = 1, ele_count(rhs) + call assemble_curl_ele(i, positions, source_field, rhs) + end do + call petsc_solve(v_field, mass, rhs, option_path = path) + call deallocate(rhs) + case(-1) + do i = 1, ele_count(v_field) + call solve_curl_ele(i, positions, source_field, v_field) + end do + case default + ewrite(-1, *) "For mesh continuity: ", continuity(v_field) + FLAbort("Unrecognised mesh continuity") + end select + end if - source_field => vector_source_field(state, v_field) - ewrite(2, *) "Calculating curl of field: " // trim(source_field%name) - ewrite(2, *) "On mesh: " // trim(source_field%mesh%name) - ewrite(2, *) "Diagnostic field: " // trim(v_field%name) - ewrite(2, *) "On mesh: " // trim(v_field%mesh%name) + ewrite_minmax(v_field) - if(source_field%dim /= 3) then - FLExit("Can only calculate curl in 3D") - end if + ewrite(1, *) "Exiting calculate_curl" - call check_source_mesh_derivative(source_field, "curl") + contains - positions => extract_vector_field(state, "Coordinate") - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/lump_mass")) then - masslump => get_lumped_mass(state, v_field%mesh) - call zero(v_field) - do i = 1, ele_count(v_field) - call assemble_curl_ele(i, positions, source_field, v_field) - end do - do i = 1, v_field%dim - v_field%val(i,:) = v_field%val(i,:) / masslump%val - end do - else - select case(continuity(v_field)) - case(0) - if(.not. have_option(trim(path) // "/solver")) then - FLExit("For continuous curl, must supply solver options when not lumping mass") - end if - mass => get_mass_matrix(state, v_field%mesh) - call allocate(rhs, v_field%dim, v_field%mesh, "CurlRHS") - call zero(rhs) - do i = 1, ele_count(rhs) - call assemble_curl_ele(i, positions, source_field, rhs) - end do - call petsc_solve(v_field, mass, rhs, option_path = path) - call deallocate(rhs) - case(-1) - do i = 1, ele_count(v_field) - call solve_curl_ele(i, positions, source_field, v_field) - end do - case default - ewrite(-1, *) "For mesh continuity: ", continuity(v_field) - FLAbort("Unrecognised mesh continuity") - end select - end if - - ewrite_minmax(v_field) - - ewrite(1, *) "Exiting calculate_curl" - - contains - - subroutine assemble_curl_ele(ele, positions, source, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source - type(vector_field), intent(inout) :: rhs + subroutine assemble_curl_ele(ele, positions, source, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source + type(vector_field), intent(inout) :: rhs - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - call addto(rhs, ele_nodes(rhs, ele), & - & shape_vector_rhs(ele_shape(rhs, ele), & - & ele_curl_at_quad(source, ele, dshape), detwei)) + call addto(rhs, ele_nodes(rhs, ele), & + & shape_vector_rhs(ele_shape(rhs, ele), & + & ele_curl_at_quad(source, ele, dshape), detwei)) - end subroutine assemble_curl_ele + end subroutine assemble_curl_ele - subroutine solve_curl_ele(ele, positions, source, curl) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source - type(vector_field), intent(inout) :: curl + subroutine solve_curl_ele(ele, positions, source, curl) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source + type(vector_field), intent(inout) :: curl - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(curl, ele), curl%dim) :: little_rhs - real, dimension(ele_loc(curl, ele), ele_loc(curl, ele)) :: little_mass - real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape - type(element_type), pointer :: shape + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(curl, ele), curl%dim) :: little_rhs + real, dimension(ele_loc(curl, ele), ele_loc(curl, ele)) :: little_mass + real, dimension(ele_loc(source, ele), ele_ngi(source, ele), positions%dim) :: dshape + type(element_type), pointer :: shape - call transform_to_physical(positions, ele, ele_shape(source, ele), & - & dshape = dshape, detwei = detwei) + call transform_to_physical(positions, ele, ele_shape(source, ele), & + & dshape = dshape, detwei = detwei) - shape => ele_shape(curl, ele) + shape => ele_shape(curl, ele) - little_mass = shape_shape(shape, shape, detwei) - little_rhs = transpose(shape_vector_rhs(shape, & - & ele_curl_at_quad(source, ele, dshape), detwei)) + little_mass = shape_shape(shape, shape, detwei) + little_rhs = transpose(shape_vector_rhs(shape, & + & ele_curl_at_quad(source, ele, dshape), detwei)) - call solve(little_mass, little_rhs) + call solve(little_mass, little_rhs) - call set(curl, ele_nodes(curl, ele), transpose(little_rhs)) + call set(curl, ele_nodes(curl, ele), transpose(little_rhs)) - end subroutine solve_curl_ele + end subroutine solve_curl_ele - end subroutine calculate_curl + end subroutine calculate_curl - subroutine calculate_scalar_advection(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_advection(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - integer :: stat - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions, velocity + integer :: stat + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions, velocity - source_field => scalar_source_field(state, s_field) + source_field => scalar_source_field(state, s_field) - velocity => extract_vector_field(state, "Velocity", stat = stat) - if(stat /= 0) then - ewrite(0, *) "For field " // trim(s_field%name) - ewrite(0, *) "Warning: Calculating advection with no velocity" - call zero(s_field) - return - end if + velocity => extract_vector_field(state, "Velocity", stat = stat) + if(stat /= 0) then + ewrite(0, *) "For field " // trim(s_field%name) + ewrite(0, *) "Warning: Calculating advection with no velocity" + call zero(s_field) + return + end if - call check_source_mesh_derivative(source_field, "scalar_advection") + call check_source_mesh_derivative(source_field, "scalar_advection") - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") - call u_dot_nabla(velocity, source_field, positions, s_field) + call u_dot_nabla(velocity, source_field, positions, s_field) - end subroutine calculate_scalar_advection + end subroutine calculate_scalar_advection - subroutine calculate_vector_advection(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_vector_advection(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - integer :: stat - type(vector_field), pointer :: positions, source_field, velocity + integer :: stat + type(vector_field), pointer :: positions, source_field, velocity - source_field => vector_source_field(state, v_field) + source_field => vector_source_field(state, v_field) - velocity => extract_vector_field(state, "Velocity", stat = stat) - if(stat /= 0) then - ewrite(0, *) "For field " // trim(v_field%name) - ewrite(0, *) "Warning: Calculating advection with no velocity" - call zero(v_field) - return - end if + velocity => extract_vector_field(state, "Velocity", stat = stat) + if(stat /= 0) then + ewrite(0, *) "For field " // trim(v_field%name) + ewrite(0, *) "Warning: Calculating advection with no velocity" + call zero(v_field) + return + end if - call check_source_mesh_derivative(source_field, "vector_advection") + call check_source_mesh_derivative(source_field, "vector_advection") - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") - call u_dot_nabla(velocity, source_field, positions, v_field) + call u_dot_nabla(velocity, source_field, positions, v_field) - end subroutine calculate_vector_advection + end subroutine calculate_vector_advection - subroutine calculate_vector_laplacian(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_vector_laplacian(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field - integer :: i, j - type(scalar_field) :: source_field_comp, v_field_comp - type(scalar_field), pointer :: masslump - type(vector_field), pointer :: positions, source_field + integer :: i, j + type(scalar_field) :: source_field_comp, v_field_comp + type(scalar_field), pointer :: masslump + type(vector_field), pointer :: positions, source_field - ewrite(1, *) "In calculate_vector_laplacian" - ewrite(2, *) "Computing laplacian for field " // trim(v_field%name) + ewrite(1, *) "In calculate_vector_laplacian" + ewrite(2, *) "Computing laplacian for field " // trim(v_field%name) - source_field => vector_source_field(state, v_field) - assert(ele_count(source_field) == ele_count(v_field)) - assert(source_field%dim == v_field%dim) - ewrite_minmax(source_field) + source_field => vector_source_field(state, v_field) + assert(ele_count(source_field) == ele_count(v_field)) + assert(source_field%dim == v_field%dim) + ewrite_minmax(source_field) - call check_source_mesh_derivative(source_field, "vector_laplacian") + call check_source_mesh_derivative(source_field, "vector_laplacian") - positions => extract_vector_field(state, "Coordinate") - assert(ele_count(positions) == ele_count(v_field)) + positions => extract_vector_field(state, "Coordinate") + assert(ele_count(positions) == ele_count(v_field)) - call zero(v_field) - do i = 1, ele_count(v_field) - call assemble_vector_laplacian_ele(i, v_field, positions, source_field) - end do - do i = 1, v_field%dim - v_field_comp = extract_scalar_field(v_field, i) - source_field_comp = extract_scalar_field(source_field, i) - do j = 1, surface_element_count(v_field) - ! This could be made more efficent by assembling all components at the - ! same time - call assemble_scalar_laplacian_face(j, v_field_comp, positions, source_field_comp) + call zero(v_field) + do i = 1, ele_count(v_field) + call assemble_vector_laplacian_ele(i, v_field, positions, source_field) + end do + do i = 1, v_field%dim + v_field_comp = extract_scalar_field(v_field, i) + source_field_comp = extract_scalar_field(source_field, i) + do j = 1, surface_element_count(v_field) + ! This could be made more efficent by assembling all components at the + ! same time + call assemble_scalar_laplacian_face(j, v_field_comp, positions, source_field_comp) + end do end do - end do - ewrite_minmax(v_field) + ewrite_minmax(v_field) - masslump => get_lumped_mass(state, v_field%mesh) + masslump => get_lumped_mass(state, v_field%mesh) - do i = 1, v_field%dim - v_field%val(i,:) = v_field%val(i,:) / masslump%val - end do - ewrite_minmax(v_field) + do i = 1, v_field%dim + v_field%val(i,:) = v_field%val(i,:) / masslump%val + end do + ewrite_minmax(v_field) - ewrite(1, *) "Exiting calculate_vector_laplacian" + ewrite(1, *) "Exiting calculate_vector_laplacian" - end subroutine calculate_vector_laplacian + end subroutine calculate_vector_laplacian - subroutine assemble_vector_laplacian_ele(ele, v_field, positions, source_field) - integer, intent(in) :: ele - type(vector_field), intent(inout) :: v_field - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source_field + subroutine assemble_vector_laplacian_ele(ele, v_field, positions, source_field) + integer, intent(in) :: ele + type(vector_field), intent(inout) :: v_field + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source_field - integer :: i, j - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(v_field, ele)) :: detwei - real, dimension(source_field%dim, ele_ngi(source_field, ele)) :: grad_gi - real, dimension(ele_loc(source_field, ele), ele_ngi(source_field, ele), source_field%dim) :: dn_t + integer :: i, j + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(v_field, ele)) :: detwei + real, dimension(source_field%dim, ele_ngi(source_field, ele)) :: grad_gi + real, dimension(ele_loc(source_field, ele), ele_ngi(source_field, ele), source_field%dim) :: dn_t - assert(ele_ngi(positions, ele) == ele_ngi(v_field, ele)) - assert(ele_ngi(source_field, ele) == ele_ngi(v_field, ele)) + assert(ele_ngi(positions, ele) == ele_ngi(v_field, ele)) + assert(ele_ngi(source_field, ele) == ele_ngi(v_field, ele)) - call transform_to_physical(positions, ele, ele_shape(source_field, ele), & + call transform_to_physical(positions, ele, ele_shape(source_field, ele), & & dshape = dn_t, detwei = detwei) - element_nodes => ele_nodes(v_field, ele) + element_nodes => ele_nodes(v_field, ele) - do i = 1, source_field%dim - do j = 1, source_field%dim - grad_gi(j, :) = matmul(ele_val(source_field, i, ele), dn_t(:, :, j)) - end do + do i = 1, source_field%dim + do j = 1, source_field%dim + grad_gi(j, :) = matmul(ele_val(source_field, i, ele), dn_t(:, :, j)) + end do - call addto(v_field, i, element_nodes, -dshape_dot_vector_rhs(dn_t, grad_gi, detwei)) - end do + call addto(v_field, i, element_nodes, -dshape_dot_vector_rhs(dn_t, grad_gi, detwei)) + end do - end subroutine assemble_vector_laplacian_ele + end subroutine assemble_vector_laplacian_ele - subroutine assemble_scalar_laplacian_face(face, s_field, positions, source_field) - integer, intent(in) :: face - type(scalar_field), intent(inout) :: s_field - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source_field + subroutine assemble_scalar_laplacian_face(face, s_field, positions, source_field) + integer, intent(in) :: face + type(scalar_field), intent(inout) :: s_field + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source_field - integer :: ele, i, j - real, dimension(face_ngi(s_field, face)) :: detwei, grad_sgi_n - real, dimension(positions%dim, face_ngi(s_field, face)) :: grad_sgi, normal - real, dimension(ele_loc(s_field, face_ele(source_field, face)), face_ngi(s_field, face), positions%dim) :: dshape_face - real, dimension(ele_loc(s_field, face_ele(source_field, face))) :: s_ele_val - type(element_type), pointer :: fshape, source_shape, positions_shape + integer :: ele, i, j + real, dimension(face_ngi(s_field, face)) :: detwei, grad_sgi_n + real, dimension(positions%dim, face_ngi(s_field, face)) :: grad_sgi, normal + real, dimension(ele_loc(s_field, face_ele(source_field, face)), face_ngi(s_field, face), positions%dim) :: dshape_face + real, dimension(ele_loc(s_field, face_ele(source_field, face))) :: s_ele_val + type(element_type), pointer :: fshape, source_shape, positions_shape - ele = face_ele(s_field, face) + ele = face_ele(s_field, face) - positions_shape => ele_shape(positions, ele) - fshape => face_shape(s_field, face) + positions_shape => ele_shape(positions, ele) + fshape => face_shape(s_field, face) - source_shape => ele_shape(source_field, ele) + source_shape => ele_shape(source_field, ele) - call transform_facet_to_physical(positions, face, source_shape, dshape_face, & + call transform_facet_to_physical(positions, face, source_shape, dshape_face, & & detwei_f = detwei, normal = normal) - s_ele_val = ele_val(source_field, ele) - forall(i = 1:positions%dim, j = 1:face_ngi(s_field, face)) - grad_sgi(i, j) = dot_product(s_ele_val, dshape_face(:, j, i)) - end forall + s_ele_val = ele_val(source_field, ele) + forall(i = 1:positions%dim, j = 1:face_ngi(s_field, face)) + grad_sgi(i, j) = dot_product(s_ele_val, dshape_face(:, j, i)) + end forall - do i = 1, face_ngi(s_field, face) - grad_sgi_n = dot_product(grad_sgi(:, i), normal(:, i)) - end do + do i = 1, face_ngi(s_field, face) + grad_sgi_n = dot_product(grad_sgi(:, i), normal(:, i)) + end do - call addto(s_field, face_global_nodes(s_field, face), shape_rhs(fshape, detwei * grad_sgi_n)) + call addto(s_field, face_global_nodes(s_field, face), shape_rhs(fshape, detwei * grad_sgi_n)) - end subroutine assemble_scalar_laplacian_face + end subroutine assemble_scalar_laplacian_face - subroutine calculate_scalar_laplacian(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_laplacian(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - integer :: i - type(scalar_field), pointer :: masslump, source_field - type(vector_field), pointer :: positions + integer :: i + type(scalar_field), pointer :: masslump, source_field + type(vector_field), pointer :: positions - ewrite(1, *) "In calculate_scalar_laplacian" - ewrite(2, *) "Computing laplacian for field " // trim(s_field%name) + ewrite(1, *) "In calculate_scalar_laplacian" + ewrite(2, *) "Computing laplacian for field " // trim(s_field%name) - source_field => scalar_source_field(state, s_field) - assert(ele_count(source_field) == ele_count(s_field)) - assert(mesh_dim(source_field) == mesh_dim(s_field)) - ewrite_minmax(source_field) + source_field => scalar_source_field(state, s_field) + assert(ele_count(source_field) == ele_count(s_field)) + assert(mesh_dim(source_field) == mesh_dim(s_field)) + ewrite_minmax(source_field) - call check_source_mesh_derivative(source_field, "scalar_laplacian") + call check_source_mesh_derivative(source_field, "scalar_laplacian") - positions => extract_vector_field(state, "Coordinate") - assert(ele_count(positions) == ele_count(s_field)) + positions => extract_vector_field(state, "Coordinate") + assert(ele_count(positions) == ele_count(s_field)) - call zero(s_field) - do i = 1, ele_count(s_field) - call assemble_scalar_laplacian_ele(i, s_field, positions, source_field) - end do - do i = 1, surface_element_count(s_field) - call assemble_scalar_laplacian_face(i, s_field, positions, source_field) - end do - ewrite_minmax(s_field) + call zero(s_field) + do i = 1, ele_count(s_field) + call assemble_scalar_laplacian_ele(i, s_field, positions, source_field) + end do + do i = 1, surface_element_count(s_field) + call assemble_scalar_laplacian_face(i, s_field, positions, source_field) + end do + ewrite_minmax(s_field) - masslump => get_lumped_mass(state, s_field%mesh) + masslump => get_lumped_mass(state, s_field%mesh) - s_field%val = s_field%val / masslump%val - ewrite_minmax(s_field) + s_field%val = s_field%val / masslump%val + ewrite_minmax(s_field) - ewrite(1, *) "Exiting calculate_scalar_laplacian" + ewrite(1, *) "Exiting calculate_scalar_laplacian" - end subroutine calculate_scalar_laplacian + end subroutine calculate_scalar_laplacian - subroutine assemble_scalar_laplacian_ele(ele, s_field, positions, source_field) - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: s_field - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source_field + subroutine assemble_scalar_laplacian_ele(ele, s_field, positions, source_field) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: s_field + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source_field - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(s_field, ele)) :: detwei - real, dimension(ele_loc(source_field, ele), ele_ngi(source_field, ele), mesh_dim(source_field)) :: dn_t + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(s_field, ele)) :: detwei + real, dimension(ele_loc(source_field, ele), ele_ngi(source_field, ele), mesh_dim(source_field)) :: dn_t - assert(ele_ngi(positions, ele) == ele_ngi(s_field, ele)) - assert(ele_ngi(source_field, ele) == ele_ngi(s_field, ele)) + assert(ele_ngi(positions, ele) == ele_ngi(s_field, ele)) + assert(ele_ngi(source_field, ele) == ele_ngi(s_field, ele)) - call transform_to_physical(positions, ele, ele_shape(source_field, ele), & + call transform_to_physical(positions, ele, ele_shape(source_field, ele), & & dshape = dn_t, detwei = detwei) - element_nodes => ele_nodes(s_field, ele) + element_nodes => ele_nodes(s_field, ele) - call addto(s_field, element_nodes, -dshape_dot_vector_rhs(dn_t, ele_grad_at_quad(source_field, ele, dn_t), detwei)) + call addto(s_field, element_nodes, -dshape_dot_vector_rhs(dn_t, ele_grad_at_quad(source_field, ele, dn_t), detwei)) - end subroutine assemble_scalar_laplacian_ele + end subroutine assemble_scalar_laplacian_ele end module differential_operator_diagnostics diff --git a/diagnostics/Field_Copies.F90 b/diagnostics/Field_Copies.F90 index 8256d598d2..04e9516ac1 100644 --- a/diagnostics/Field_Copies.F90 +++ b/diagnostics/Field_Copies.F90 @@ -29,595 +29,595 @@ module field_copies_diagnostics - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use spud - use fldebug - use vector_tools, only: solve - use sparse_tools - use transform_elements - use fetools - use fields - use state_module - use field_options - use diagnostic_source_fields - use sparse_matrices_fields - use solvers - use smoothing_module - use sparsity_patterns_meshes - use state_fields_module - - implicit none - - private - - public :: calculate_scalar_copy, calculate_vector_copy, calculate_tensor_copy - public :: calculate_extract_scalar_component - public :: calculate_scalar_galerkin_projection, calculate_vector_galerkin_projection - public :: calculate_helmholtz_smoothed_scalar, calculate_helmholtz_smoothed_vector, calculate_helmholtz_smoothed_tensor - public :: calculate_lumped_mass_smoothed_scalar, calculate_lumped_mass_smoothed_vector - public :: calculate_lumped_mass_smoothed_tensor - public :: calculate_helmholtz_anisotropic_smoothed_scalar, calculate_helmholtz_anisotropic_smoothed_vector - public :: calculate_helmholtz_anisotropic_smoothed_tensor + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use spud + use fldebug + use vector_tools, only: solve + use sparse_tools + use transform_elements + use fetools + use fields + use state_module + use field_options + use diagnostic_source_fields + use sparse_matrices_fields + use solvers + use smoothing_module + use sparsity_patterns_meshes + use state_fields_module + + implicit none + + private + + public :: calculate_scalar_copy, calculate_vector_copy, calculate_tensor_copy + public :: calculate_extract_scalar_component + public :: calculate_scalar_galerkin_projection, calculate_vector_galerkin_projection + public :: calculate_helmholtz_smoothed_scalar, calculate_helmholtz_smoothed_vector, calculate_helmholtz_smoothed_tensor + public :: calculate_lumped_mass_smoothed_scalar, calculate_lumped_mass_smoothed_vector + public :: calculate_lumped_mass_smoothed_tensor + public :: calculate_helmholtz_anisotropic_smoothed_scalar, calculate_helmholtz_anisotropic_smoothed_vector + public :: calculate_helmholtz_anisotropic_smoothed_tensor contains - subroutine calculate_scalar_copy(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(scalar_field), pointer :: source_field - integer :: stat - - source_field => scalar_source_field(state, s_field) + subroutine calculate_scalar_copy(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - call remap_field(source_field, s_field, stat) - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_discontinuous_continuous_remap")) then - FLExit("In the scalar_copy diagnostic algorithm: remapping from a discontinuous mesh to a continuous mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_unperiodic_periodic_remap")) then - FLExit("In the scalar_copy diagnostic algorithm: remapping from an unperiodic to a periodic mesh isn't allowed.") + type(scalar_field), pointer :: source_field + integer :: stat + + source_field => scalar_source_field(state, s_field) + + call remap_field(source_field, s_field, stat) + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_discontinuous_continuous_remap")) then + FLExit("In the scalar_copy diagnostic algorithm: remapping from a discontinuous mesh to a continuous mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_unperiodic_periodic_remap")) then + FLExit("In the scalar_copy diagnostic algorithm: remapping from an unperiodic to a periodic mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then + if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_higher_lower_continuous_remap")) then + FLExit("In the scalar_copy diagnostic algorithm: remapping from a higher order continuous mesh to a lower order continuous mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_BUBBLE_LAGRANGE) then + if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_bubble_lagrange_remap")) then + FLExit("In the scalar_copy diagnostic algorithm: remapping from a bubble mesh to a lagrange mesh isn't allowed.") + end if end if - else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then - if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_higher_lower_continuous_remap")) then - FLExit("In the scalar_copy diagnostic algorithm: remapping from a higher order continuous mesh to a lower order continuous mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_BUBBLE_LAGRANGE) then - if(.not.have_option(trim(complete_field_path(s_field%option_path))//"/algorithm/allow_bubble_lagrange_remap")) then - FLExit("In the scalar_copy diagnostic algorithm: remapping from a bubble mesh to a lagrange mesh isn't allowed.") - end if - end if - - - end subroutine calculate_scalar_copy - subroutine calculate_vector_copy(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field - type(vector_field), pointer :: source_field - integer :: stat + end subroutine calculate_scalar_copy - source_field => vector_source_field(state, v_field) + subroutine calculate_vector_copy(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - call remap_field(source_field, v_field, stat) - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_discontinuous_continuous_remap")) then - FLExit("In the vector_copy diagnostic algorithm: remapping from a discontinuous mesh to a continuous mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_unperiodic_periodic_remap")) then - FLExit("In the vector_copy diagnostic algorithm: remapping from an unperiodic to a periodic mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then - if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_higher_lower_continuous_remap")) then - FLExit("In the vector_copy diagnostic algorithm: remapping from a higher order continuous mesh to a lower order continuous mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_BUBBLE_LAGRANGE) then - if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_bubble_lagrange_remap")) then - FLExit("In the vector_copy diagnostic algorithm: remapping from a bubble mesh to a lagrange mesh isn't allowed.") + type(vector_field), pointer :: source_field + integer :: stat + + source_field => vector_source_field(state, v_field) + + call remap_field(source_field, v_field, stat) + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_discontinuous_continuous_remap")) then + FLExit("In the vector_copy diagnostic algorithm: remapping from a discontinuous mesh to a continuous mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_unperiodic_periodic_remap")) then + FLExit("In the vector_copy diagnostic algorithm: remapping from an unperiodic to a periodic mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then + if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_higher_lower_continuous_remap")) then + FLExit("In the vector_copy diagnostic algorithm: remapping from a higher order continuous mesh to a lower order continuous mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_BUBBLE_LAGRANGE) then + if(.not.have_option(trim(complete_field_path(v_field%option_path))//"/algorithm/allow_bubble_lagrange_remap")) then + FLExit("In the vector_copy diagnostic algorithm: remapping from a bubble mesh to a lagrange mesh isn't allowed.") + end if end if - end if - - end subroutine calculate_vector_copy - - subroutine calculate_tensor_copy(state, t_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: t_field - - type(tensor_field), pointer :: source_field - integer :: stat - source_field => tensor_source_field(state, t_field) - - call remap_field(source_field, t_field, stat) - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_discontinuous_continuous_remap")) then - FLExit("In the tensor_copy diagnostic algorithm: remapping from a discontinuous mesh to a continuous mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_unperiodic_periodic_remap")) then - FLExit("In the tensor_copy diagnostic algorithm: remapping from an unperiodic to a periodic mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then - if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_higher_lower_continuous_remap")) then - FLExit("In the tensor_copy diagnostic algorithm: remapping from a higher order continuous mesh to a lower order continuous mesh isn't allowed.") - end if - else if(stat==REMAP_ERR_BUBBLE_LAGRANGE) then - if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_bubble_lagrange_remap")) then - FLExit("In the tensor_copy diagnostic algorithm: remapping from a bubble mesh to a lagrange mesh isn't allowed.") + end subroutine calculate_vector_copy + + subroutine calculate_tensor_copy(state, t_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: t_field + + type(tensor_field), pointer :: source_field + integer :: stat + + source_field => tensor_source_field(state, t_field) + + call remap_field(source_field, t_field, stat) + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_discontinuous_continuous_remap")) then + FLExit("In the tensor_copy diagnostic algorithm: remapping from a discontinuous mesh to a continuous mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_unperiodic_periodic_remap")) then + FLExit("In the tensor_copy diagnostic algorithm: remapping from an unperiodic to a periodic mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then + if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_higher_lower_continuous_remap")) then + FLExit("In the tensor_copy diagnostic algorithm: remapping from a higher order continuous mesh to a lower order continuous mesh isn't allowed.") + end if + else if(stat==REMAP_ERR_BUBBLE_LAGRANGE) then + if(.not.have_option(trim(complete_field_path(t_field%option_path))//"/algorithm/allow_bubble_lagrange_remap")) then + FLExit("In the tensor_copy diagnostic algorithm: remapping from a bubble mesh to a lagrange mesh isn't allowed.") + end if end if - end if - end subroutine calculate_tensor_copy + end subroutine calculate_tensor_copy - subroutine calculate_extract_scalar_component(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_extract_scalar_component(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - logical :: allocated - type(scalar_field), pointer :: source_field + logical :: allocated + type(scalar_field), pointer :: source_field - source_field => scalar_source_field(state, s_field, allocated = allocated) - call remap_field(source_field, s_field) - if(allocated) deallocate(source_field) + source_field => scalar_source_field(state, s_field, allocated = allocated) + call remap_field(source_field, s_field) + if(allocated) deallocate(source_field) - end subroutine calculate_extract_scalar_component + end subroutine calculate_extract_scalar_component - subroutine calculate_scalar_galerkin_projection(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_galerkin_projection(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions - source_field => scalar_source_field(state, s_field) - positions => extract_vector_field(state, "Coordinate") + source_field => scalar_source_field(state, s_field) + positions => extract_vector_field(state, "Coordinate") - select case(continuity(s_field)) - case(0) - call gp_continuous - case(-1) - call gp_discontinuous - case default - ewrite(-1, *) "For mesh continuity", continuity(s_field) - FLAbort("Unrecognised mesh continuity") - end select + select case(continuity(s_field)) + case(0) + call gp_continuous + case(-1) + call gp_discontinuous + case default + ewrite(-1, *) "For mesh continuity", continuity(s_field) + FLAbort("Unrecognised mesh continuity") + end select - contains + contains - subroutine gp_continuous - type(csr_matrix) :: mass - type(csr_sparsity), pointer :: sparsity - type(scalar_field) :: rhs + subroutine gp_continuous + type(csr_matrix) :: mass + type(csr_sparsity), pointer :: sparsity + type(scalar_field) :: rhs - integer :: i + integer :: i - sparsity => get_csr_sparsity_firstorder(state, s_field%mesh, s_field%mesh) - call allocate(mass, sparsity, name = "MassMatrix") - call allocate(rhs, s_field%mesh, "RHS") + sparsity => get_csr_sparsity_firstorder(state, s_field%mesh, s_field%mesh) + call allocate(mass, sparsity, name = "MassMatrix") + call allocate(rhs, s_field%mesh, "RHS") - call zero(mass) - call zero(rhs) - do i = 1, ele_count(s_field) - call assemble_gp_ele(i, s_field, positions, source_field, mass, rhs) - end do + call zero(mass) + call zero(rhs) + do i = 1, ele_count(s_field) + call assemble_gp_ele(i, s_field, positions, source_field, mass, rhs) + end do - call petsc_solve(s_field, mass, rhs, & - & option_path = trim(complete_field_path(s_field%option_path)) // "/algorithm") + call petsc_solve(s_field, mass, rhs, & + & option_path = trim(complete_field_path(s_field%option_path)) // "/algorithm") - call deallocate(mass) - call deallocate(rhs) + call deallocate(mass) + call deallocate(rhs) - end subroutine gp_continuous + end subroutine gp_continuous - subroutine assemble_gp_ele(ele, s_field, positions, source_field, mass, rhs) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: s_field - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source_field - type(csr_matrix), intent(inout) :: mass - type(scalar_field), intent(inout) :: rhs + subroutine assemble_gp_ele(ele, s_field, positions, source_field, mass, rhs) + integer, intent(in) :: ele + type(scalar_field), intent(in) :: s_field + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source_field + type(csr_matrix), intent(inout) :: mass + type(scalar_field), intent(inout) :: rhs - integer, dimension(:), pointer :: nodes - real, dimension(ele_ngi(s_field, ele)) :: detwei - type(element_type), pointer :: shape + integer, dimension(:), pointer :: nodes + real, dimension(ele_ngi(s_field, ele)) :: detwei + type(element_type), pointer :: shape - shape => ele_shape(s_field, ele) + shape => ele_shape(s_field, ele) - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - nodes => ele_nodes(s_field, ele) + nodes => ele_nodes(s_field, ele) - call addto(mass, nodes, nodes, shape_shape(shape, shape, detwei)) - call addto(rhs, nodes, shape_rhs(shape, detwei * ele_val_at_quad(source_field, ele))) + call addto(mass, nodes, nodes, shape_shape(shape, shape, detwei)) + call addto(rhs, nodes, shape_rhs(shape, detwei * ele_val_at_quad(source_field, ele))) - end subroutine assemble_gp_ele + end subroutine assemble_gp_ele - subroutine gp_discontinuous - integer :: i + subroutine gp_discontinuous + integer :: i - do i = 1, ele_count(s_field) - call solve_gp_ele(i, s_field, positions, source_field) - end do + do i = 1, ele_count(s_field) + call solve_gp_ele(i, s_field, positions, source_field) + end do - end subroutine gp_discontinuous + end subroutine gp_discontinuous - subroutine solve_gp_ele(ele, s_field, positions, source_field) - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: s_field - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: source_field + subroutine solve_gp_ele(ele, s_field, positions, source_field) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: s_field + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: source_field - integer, dimension(:), pointer :: nodes - real, dimension(ele_loc(s_field, ele)) :: little_rhs - real, dimension(ele_loc(s_field, ele), ele_loc(s_field, ele)) :: little_mass - real, dimension(ele_ngi(s_field, ele)) :: detwei - type(element_type), pointer :: shape + integer, dimension(:), pointer :: nodes + real, dimension(ele_loc(s_field, ele)) :: little_rhs + real, dimension(ele_loc(s_field, ele), ele_loc(s_field, ele)) :: little_mass + real, dimension(ele_ngi(s_field, ele)) :: detwei + type(element_type), pointer :: shape - shape => ele_shape(s_field, ele) + shape => ele_shape(s_field, ele) - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - little_mass = shape_shape(shape, shape, detwei) - little_rhs = shape_rhs(shape, detwei * ele_val_at_quad(source_field, ele)) - call solve(little_mass, little_rhs) + little_mass = shape_shape(shape, shape, detwei) + little_rhs = shape_rhs(shape, detwei * ele_val_at_quad(source_field, ele)) + call solve(little_mass, little_rhs) - nodes => ele_nodes(s_field, ele) + nodes => ele_nodes(s_field, ele) - call set(s_field, nodes, little_rhs) + call set(s_field, nodes, little_rhs) - end subroutine solve_gp_ele + end subroutine solve_gp_ele - end subroutine calculate_scalar_galerkin_projection + end subroutine calculate_scalar_galerkin_projection - subroutine calculate_vector_galerkin_projection(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_vector_galerkin_projection(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field - type(vector_field), pointer :: source_field - type(vector_field), pointer :: positions + type(vector_field), pointer :: source_field + type(vector_field), pointer :: positions - source_field => vector_source_field(state, v_field) - positions => extract_vector_field(state, "Coordinate") + source_field => vector_source_field(state, v_field) + positions => extract_vector_field(state, "Coordinate") - select case(continuity(v_field)) - case(0) - call gp_continuous - case(-1) - call gp_discontinuous - case default - ewrite(-1, *) "For mesh continuity", continuity(v_field) - FLAbort("Unrecognised mesh continuity") - end select + select case(continuity(v_field)) + case(0) + call gp_continuous + case(-1) + call gp_discontinuous + case default + ewrite(-1, *) "For mesh continuity", continuity(v_field) + FLAbort("Unrecognised mesh continuity") + end select - contains + contains - subroutine gp_continuous - type(csr_matrix) :: mass - type(csr_sparsity), pointer :: sparsity - type(vector_field) :: rhs + subroutine gp_continuous + type(csr_matrix) :: mass + type(csr_sparsity), pointer :: sparsity + type(vector_field) :: rhs - integer :: i + integer :: i - sparsity => get_csr_sparsity_firstorder(state, v_field%mesh, v_field%mesh) - call allocate(mass, sparsity, name = "MassMatrix") - call allocate(rhs, v_field%dim, v_field%mesh, "RHS") + sparsity => get_csr_sparsity_firstorder(state, v_field%mesh, v_field%mesh) + call allocate(mass, sparsity, name = "MassMatrix") + call allocate(rhs, v_field%dim, v_field%mesh, "RHS") - call zero(mass) - call zero(rhs) - do i = 1, ele_count(v_field) - call assemble_gp_ele(i, v_field, positions, source_field, mass, rhs) - end do + call zero(mass) + call zero(rhs) + do i = 1, ele_count(v_field) + call assemble_gp_ele(i, v_field, positions, source_field, mass, rhs) + end do - call petsc_solve(v_field, mass, rhs, & - & option_path = trim(complete_field_path(v_field%option_path)) // "/algorithm") + call petsc_solve(v_field, mass, rhs, & + & option_path = trim(complete_field_path(v_field%option_path)) // "/algorithm") - call deallocate(mass) - call deallocate(rhs) + call deallocate(mass) + call deallocate(rhs) - end subroutine gp_continuous + end subroutine gp_continuous - subroutine assemble_gp_ele(ele, v_field, positions, source_field, mass, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: v_field - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source_field - type(csr_matrix), intent(inout) :: mass - type(vector_field), intent(inout) :: rhs + subroutine assemble_gp_ele(ele, v_field, positions, source_field, mass, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: v_field + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source_field + type(csr_matrix), intent(inout) :: mass + type(vector_field), intent(inout) :: rhs - integer, dimension(:), pointer :: nodes - real, dimension(ele_ngi(v_field, ele)) :: detwei - type(element_type), pointer :: shape + integer, dimension(:), pointer :: nodes + real, dimension(ele_ngi(v_field, ele)) :: detwei + type(element_type), pointer :: shape - shape => ele_shape(v_field, ele) + shape => ele_shape(v_field, ele) - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - nodes => ele_nodes(v_field, ele) + nodes => ele_nodes(v_field, ele) - call addto(mass, nodes, nodes, shape_shape(shape, shape, detwei)) - call addto(rhs, nodes, shape_vector_rhs(shape, ele_val_at_quad(source_field, ele), detwei)) + call addto(mass, nodes, nodes, shape_shape(shape, shape, detwei)) + call addto(rhs, nodes, shape_vector_rhs(shape, ele_val_at_quad(source_field, ele), detwei)) - end subroutine assemble_gp_ele + end subroutine assemble_gp_ele - subroutine gp_discontinuous - integer :: i + subroutine gp_discontinuous + integer :: i - do i = 1, ele_count(v_field) - call solve_gp_ele(i, v_field, positions, source_field) - end do + do i = 1, ele_count(v_field) + call solve_gp_ele(i, v_field, positions, source_field) + end do - end subroutine gp_discontinuous + end subroutine gp_discontinuous - subroutine solve_gp_ele(ele, v_field, positions, source_field) - integer, intent(in) :: ele - type(vector_field), intent(inout) :: v_field - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: source_field + subroutine solve_gp_ele(ele, v_field, positions, source_field) + integer, intent(in) :: ele + type(vector_field), intent(inout) :: v_field + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: source_field - integer, dimension(:), pointer :: nodes - real, dimension(ele_loc(v_field, ele), source_field%dim) :: little_rhs - real, dimension(ele_loc(v_field, ele), ele_loc(v_field, ele)) :: little_mass - real, dimension(ele_ngi(v_field, ele)) :: detwei - type(element_type), pointer :: shape + integer, dimension(:), pointer :: nodes + real, dimension(ele_loc(v_field, ele), source_field%dim) :: little_rhs + real, dimension(ele_loc(v_field, ele), ele_loc(v_field, ele)) :: little_mass + real, dimension(ele_ngi(v_field, ele)) :: detwei + type(element_type), pointer :: shape - shape => ele_shape(v_field, ele) + shape => ele_shape(v_field, ele) - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - little_mass = shape_shape(shape, shape, detwei) - little_rhs = transpose(shape_vector_rhs(shape, ele_val_at_quad(source_field, ele), detwei) ) - call solve(little_mass, little_rhs) + little_mass = shape_shape(shape, shape, detwei) + little_rhs = transpose(shape_vector_rhs(shape, ele_val_at_quad(source_field, ele), detwei) ) + call solve(little_mass, little_rhs) - nodes => ele_nodes(v_field, ele) + nodes => ele_nodes(v_field, ele) - call set(v_field, nodes, transpose(little_rhs)) + call set(v_field, nodes, transpose(little_rhs)) - end subroutine solve_gp_ele + end subroutine solve_gp_ele - end subroutine calculate_vector_galerkin_projection + end subroutine calculate_vector_galerkin_projection - subroutine calculate_helmholtz_smoothed_scalar(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_helmholtz_smoothed_scalar(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - character(len = OPTION_PATH_LEN) :: path - logical :: allocated - real :: alpha - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions + character(len = OPTION_PATH_LEN) :: path + logical :: allocated + real :: alpha + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions - ewrite(1, *) "In calculate_helmholtz_smoothed_scalar" + ewrite(1, *) "In calculate_helmholtz_smoothed_scalar" - source_field => scalar_source_field(state, s_field, allocated = allocated) - positions => extract_vector_field(state, "Coordinate") + source_field => scalar_source_field(state, s_field, allocated = allocated) + positions => extract_vector_field(state, "Coordinate") - path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - call get_option(trim(path) // "/smoothing_scale_factor", alpha) - ewrite(2, *) "alpha = ", alpha + path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + call get_option(trim(path) // "/smoothing_scale_factor", alpha) + ewrite(2, *) "alpha = ", alpha - ewrite_minmax(source_field) - call smooth_scalar(source_field, positions, s_field, alpha, path) - ewrite_minmax(s_field) + ewrite_minmax(source_field) + call smooth_scalar(source_field, positions, s_field, alpha, path) + ewrite_minmax(s_field) - if(allocated) deallocate(source_field) + if(allocated) deallocate(source_field) - ewrite(1, *) "Exiting calculate_helmholtz_smoothed_scalar" + ewrite(1, *) "Exiting calculate_helmholtz_smoothed_scalar" - end subroutine calculate_helmholtz_smoothed_scalar + end subroutine calculate_helmholtz_smoothed_scalar - subroutine calculate_helmholtz_smoothed_vector(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_helmholtz_smoothed_vector(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - character(len = OPTION_PATH_LEN) :: path - real :: alpha - type(vector_field), pointer :: source_field, positions + character(len = OPTION_PATH_LEN) :: path + real :: alpha + type(vector_field), pointer :: source_field, positions - ewrite(1, *) "In calculate_helmholtz_smoothed_vector" + ewrite(1, *) "In calculate_helmholtz_smoothed_vector" - source_field => vector_source_field(state, v_field) - positions => extract_vector_field(state, "Coordinate") + source_field => vector_source_field(state, v_field) + positions => extract_vector_field(state, "Coordinate") - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - call get_option(trim(path) // "/smoothing_scale_factor", alpha) - ewrite(2, *) "alpha = ", alpha + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + call get_option(trim(path) // "/smoothing_scale_factor", alpha) + ewrite(2, *) "alpha = ", alpha - call smooth_vector(source_field, positions, v_field, alpha, path) - ewrite_minmax(v_field) + call smooth_vector(source_field, positions, v_field, alpha, path) + ewrite_minmax(v_field) - ewrite(1, *) "Exiting calculate_helmholtz_smoothed_vector" + ewrite(1, *) "Exiting calculate_helmholtz_smoothed_vector" - end subroutine calculate_helmholtz_smoothed_vector + end subroutine calculate_helmholtz_smoothed_vector - subroutine calculate_helmholtz_smoothed_tensor(state, t_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: t_field + subroutine calculate_helmholtz_smoothed_tensor(state, t_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: t_field - character(len = OPTION_PATH_LEN) :: path - real :: alpha - type(vector_field), pointer :: positions - type(tensor_field), pointer :: source_field + character(len = OPTION_PATH_LEN) :: path + real :: alpha + type(vector_field), pointer :: positions + type(tensor_field), pointer :: source_field - ewrite(1, *) "In calculate_helmholtz_smoothed_tensor" + ewrite(1, *) "In calculate_helmholtz_smoothed_tensor" - positions => extract_vector_field(state, "Coordinate") - source_field => tensor_source_field(state, t_field) + positions => extract_vector_field(state, "Coordinate") + source_field => tensor_source_field(state, t_field) - path = trim(complete_field_path(t_field%option_path)) // "/algorithm" - call get_option(trim(path) // "/smoothing_scale_factor", alpha) - ewrite(2, *) "alpha = ", alpha - call smooth_tensor(source_field, positions, t_field, alpha, path) + path = trim(complete_field_path(t_field%option_path)) // "/algorithm" + call get_option(trim(path) // "/smoothing_scale_factor", alpha) + ewrite(2, *) "alpha = ", alpha + call smooth_tensor(source_field, positions, t_field, alpha, path) - ewrite_minmax(source_field) - ewrite_minmax(t_field) + ewrite_minmax(source_field) + ewrite_minmax(t_field) - ewrite(1, *) "Exiting calculate_helmholtz_smoothed_tensor" + ewrite(1, *) "Exiting calculate_helmholtz_smoothed_tensor" - end subroutine calculate_helmholtz_smoothed_tensor + end subroutine calculate_helmholtz_smoothed_tensor - subroutine calculate_helmholtz_anisotropic_smoothed_scalar(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_helmholtz_anisotropic_smoothed_scalar(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - character(len = OPTION_PATH_LEN) :: path - logical :: allocated - real :: alpha - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions + character(len = OPTION_PATH_LEN) :: path + logical :: allocated + real :: alpha + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions - ewrite(1, *) "In calculate_helmholtz_anisotropic_smoothed_scalar" + ewrite(1, *) "In calculate_helmholtz_anisotropic_smoothed_scalar" - positions => extract_vector_field(state, "Coordinate") - source_field => scalar_source_field(state, s_field, allocated = allocated) + positions => extract_vector_field(state, "Coordinate") + source_field => scalar_source_field(state, s_field, allocated = allocated) - path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - call get_option(trim(path) // "/smoothing_scale_factor", alpha) - ewrite(2, *) "alpha = ", alpha - call anisotropic_smooth_scalar(source_field, positions, s_field, alpha, path) + path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + call get_option(trim(path) // "/smoothing_scale_factor", alpha) + ewrite(2, *) "alpha = ", alpha + call anisotropic_smooth_scalar(source_field, positions, s_field, alpha, path) - ewrite_minmax(source_field) - ewrite_minmax(s_field) + ewrite_minmax(source_field) + ewrite_minmax(s_field) - if(allocated) deallocate(source_field) + if(allocated) deallocate(source_field) - ewrite(1, *) "Exiting calculate_helmholtz_anisotropic_smoothed_scalar" + ewrite(1, *) "Exiting calculate_helmholtz_anisotropic_smoothed_scalar" - end subroutine calculate_helmholtz_anisotropic_smoothed_scalar + end subroutine calculate_helmholtz_anisotropic_smoothed_scalar - subroutine calculate_helmholtz_anisotropic_smoothed_vector(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_helmholtz_anisotropic_smoothed_vector(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - character(len = OPTION_PATH_LEN) :: path - real :: alpha - type(vector_field), pointer :: positions, source_field + character(len = OPTION_PATH_LEN) :: path + real :: alpha + type(vector_field), pointer :: positions, source_field - ewrite(1, *) "In calculate_helmholtz_anisotropic_smoothed_vector" + ewrite(1, *) "In calculate_helmholtz_anisotropic_smoothed_vector" - positions => extract_vector_field(state, "Coordinate") - source_field => vector_source_field(state, v_field) + positions => extract_vector_field(state, "Coordinate") + source_field => vector_source_field(state, v_field) - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - call get_option(trim(path) // "/smoothing_scale_factor", alpha) - ewrite(2, *) "alpha = ", alpha - call anisotropic_smooth_vector(source_field, positions, v_field, alpha, path) + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + call get_option(trim(path) // "/smoothing_scale_factor", alpha) + ewrite(2, *) "alpha = ", alpha + call anisotropic_smooth_vector(source_field, positions, v_field, alpha, path) - ewrite_minmax(source_field) - ewrite_minmax(v_field) + ewrite_minmax(source_field) + ewrite_minmax(v_field) - ewrite(1, *) "Exiting calculate_helmholtz_anisotropic_smoothed_vector" + ewrite(1, *) "Exiting calculate_helmholtz_anisotropic_smoothed_vector" - end subroutine calculate_helmholtz_anisotropic_smoothed_vector + end subroutine calculate_helmholtz_anisotropic_smoothed_vector - subroutine calculate_helmholtz_anisotropic_smoothed_tensor(state, t_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: t_field + subroutine calculate_helmholtz_anisotropic_smoothed_tensor(state, t_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: t_field - character(len = OPTION_PATH_LEN) :: path - real :: alpha - type(vector_field), pointer :: positions - type(tensor_field), pointer :: source_field + character(len = OPTION_PATH_LEN) :: path + real :: alpha + type(vector_field), pointer :: positions + type(tensor_field), pointer :: source_field - ewrite(1, *) "In calculate_helmholtz_anisotropic_smoothed_tensor" + ewrite(1, *) "In calculate_helmholtz_anisotropic_smoothed_tensor" - positions => extract_vector_field(state, "Coordinate") - source_field => tensor_source_field(state, t_field) + positions => extract_vector_field(state, "Coordinate") + source_field => tensor_source_field(state, t_field) - path = trim(complete_field_path(t_field%option_path)) // "/algorithm" - call get_option(trim(path) // "/smoothing_scale_factor", alpha) - ewrite(2, *) "alpha = ", alpha - call anisotropic_smooth_tensor(source_field, positions, t_field, alpha, path) + path = trim(complete_field_path(t_field%option_path)) // "/algorithm" + call get_option(trim(path) // "/smoothing_scale_factor", alpha) + ewrite(2, *) "alpha = ", alpha + call anisotropic_smooth_tensor(source_field, positions, t_field, alpha, path) - ewrite_minmax(source_field) - ewrite_minmax(t_field) + ewrite_minmax(source_field) + ewrite_minmax(t_field) - ewrite(1, *) "Exiting calculate_helmholtz_anisotropic_smoothed_tensor" + ewrite(1, *) "Exiting calculate_helmholtz_anisotropic_smoothed_tensor" - end subroutine calculate_helmholtz_anisotropic_smoothed_tensor + end subroutine calculate_helmholtz_anisotropic_smoothed_tensor - subroutine calculate_lumped_mass_smoothed_scalar(state, s_field) + subroutine calculate_lumped_mass_smoothed_scalar(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field - type(scalar_field), pointer :: source_field, lumpedmass - type(scalar_field) :: inverse_lumpedmass - type(csr_matrix), pointer :: mass - logical :: allocated + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field + type(scalar_field), pointer :: source_field, lumpedmass + type(scalar_field) :: inverse_lumpedmass + type(csr_matrix), pointer :: mass + logical :: allocated - ewrite(1, *) "In calculate_lumped_mass_smoothed_scalar" + ewrite(1, *) "In calculate_lumped_mass_smoothed_scalar" - source_field => scalar_source_field(state, s_field, allocated = allocated) + source_field => scalar_source_field(state, s_field, allocated = allocated) - ! Apply smoothing filter - call allocate(inverse_lumpedmass, source_field%mesh, "InverseLumpedMass") - mass => get_mass_matrix(state, source_field%mesh) - lumpedmass => get_lumped_mass(state, source_field%mesh) - call invert(lumpedmass, inverse_lumpedmass) - call mult( s_field, mass, source_field) - call scale(s_field, inverse_lumpedmass) ! the averaging operator is [inv(ML)*M*] - call deallocate(inverse_lumpedmass) - if(allocated) deallocate(source_field) + ! Apply smoothing filter + call allocate(inverse_lumpedmass, source_field%mesh, "InverseLumpedMass") + mass => get_mass_matrix(state, source_field%mesh) + lumpedmass => get_lumped_mass(state, source_field%mesh) + call invert(lumpedmass, inverse_lumpedmass) + call mult( s_field, mass, source_field) + call scale(s_field, inverse_lumpedmass) ! the averaging operator is [inv(ML)*M*] + call deallocate(inverse_lumpedmass) + if(allocated) deallocate(source_field) - ewrite(1, *) "Exiting calculate_lumped_mass_smoothed_scalar" + ewrite(1, *) "Exiting calculate_lumped_mass_smoothed_scalar" - end subroutine calculate_lumped_mass_smoothed_scalar + end subroutine calculate_lumped_mass_smoothed_scalar - subroutine calculate_lumped_mass_smoothed_vector(state, v_field) + subroutine calculate_lumped_mass_smoothed_vector(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field - type(vector_field), pointer :: source_field - type(scalar_field), pointer :: lumpedmass - type(scalar_field) :: inverse_lumpedmass - type(csr_matrix), pointer :: mass + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field + type(vector_field), pointer :: source_field + type(scalar_field), pointer :: lumpedmass + type(scalar_field) :: inverse_lumpedmass + type(csr_matrix), pointer :: mass - ewrite(1, *) "In calculate_lumped_mass_smoothed_vector" + ewrite(1, *) "In calculate_lumped_mass_smoothed_vector" - source_field => vector_source_field(state, v_field) + source_field => vector_source_field(state, v_field) - ! Apply smoothing filter - call allocate(inverse_lumpedmass, source_field%mesh, "InverseLumpedMass") - mass => get_mass_matrix(state, source_field%mesh) - lumpedmass => get_lumped_mass(state, source_field%mesh) - call invert(lumpedmass, inverse_lumpedmass) - call mult( v_field, mass, source_field) - call scale(v_field, inverse_lumpedmass) ! the averaging operator is [inv(ML)*M*] - call deallocate(inverse_lumpedmass) + ! Apply smoothing filter + call allocate(inverse_lumpedmass, source_field%mesh, "InverseLumpedMass") + mass => get_mass_matrix(state, source_field%mesh) + lumpedmass => get_lumped_mass(state, source_field%mesh) + call invert(lumpedmass, inverse_lumpedmass) + call mult( v_field, mass, source_field) + call scale(v_field, inverse_lumpedmass) ! the averaging operator is [inv(ML)*M*] + call deallocate(inverse_lumpedmass) - ewrite(1, *) "Exiting calculate_lumped_mass_smoothed_vector" + ewrite(1, *) "Exiting calculate_lumped_mass_smoothed_vector" - end subroutine calculate_lumped_mass_smoothed_vector + end subroutine calculate_lumped_mass_smoothed_vector - subroutine calculate_lumped_mass_smoothed_tensor(state, t_field) + subroutine calculate_lumped_mass_smoothed_tensor(state, t_field) - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field - type(tensor_field), pointer :: source_field - type(scalar_field), pointer :: lumpedmass - type(scalar_field) :: inverse_lumpedmass - type(csr_matrix), pointer :: mass + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field + type(tensor_field), pointer :: source_field + type(scalar_field), pointer :: lumpedmass + type(scalar_field) :: inverse_lumpedmass + type(csr_matrix), pointer :: mass - ewrite(1, *) "In calculate_lumped_mass_smoothed_tensor" + ewrite(1, *) "In calculate_lumped_mass_smoothed_tensor" - source_field => tensor_source_field(state, t_field) + source_field => tensor_source_field(state, t_field) - ! Apply smoothing filter - call allocate(inverse_lumpedmass, source_field%mesh, "InverseLumpedMass") - mass => get_mass_matrix(state, source_field%mesh) - lumpedmass => get_lumped_mass(state, source_field%mesh) - call invert(lumpedmass, inverse_lumpedmass) - ! IS IT POSSIBLE TO MULTIPLY CSR_MATRIX BY TENSOR FIELD? - ! SEE Sparse_Matrices_Fields/csr_mult_vector_vector - !call mult( t_field, mass, source_field) - call scale(t_field, inverse_lumpedmass) ! the averaging operator is [inv(ML)*M*] - call deallocate(inverse_lumpedmass) + ! Apply smoothing filter + call allocate(inverse_lumpedmass, source_field%mesh, "InverseLumpedMass") + mass => get_mass_matrix(state, source_field%mesh) + lumpedmass => get_lumped_mass(state, source_field%mesh) + call invert(lumpedmass, inverse_lumpedmass) + ! IS IT POSSIBLE TO MULTIPLY CSR_MATRIX BY TENSOR FIELD? + ! SEE Sparse_Matrices_Fields/csr_mult_vector_vector + !call mult( t_field, mass, source_field) + call scale(t_field, inverse_lumpedmass) ! the averaging operator is [inv(ML)*M*] + call deallocate(inverse_lumpedmass) - ewrite(1, *) "Exiting calculate_lumped_mass_smoothed_tensor" + ewrite(1, *) "Exiting calculate_lumped_mass_smoothed_tensor" - end subroutine calculate_lumped_mass_smoothed_tensor + end subroutine calculate_lumped_mass_smoothed_tensor end module field_copies_diagnostics diff --git a/diagnostics/Mass_Matrix_Diagnostics.F90 b/diagnostics/Mass_Matrix_Diagnostics.F90 index ce9f0a7ccd..36dab8034d 100644 --- a/diagnostics/Mass_Matrix_Diagnostics.F90 +++ b/diagnostics/Mass_Matrix_Diagnostics.F90 @@ -44,7 +44,7 @@ module mass_matrix_diagnostics private public :: calculate_finite_element_lumped_mass_matrix, & - calculate_control_volume_mass_matrix + calculate_control_volume_mass_matrix contains diff --git a/diagnostics/Mesh_Diagnostics.F90 b/diagnostics/Mesh_Diagnostics.F90 index a8304b2a67..aeab566099 100644 --- a/diagnostics/Mesh_Diagnostics.F90 +++ b/diagnostics/Mesh_Diagnostics.F90 @@ -28,142 +28,142 @@ module mesh_diagnostics - use fldebug - use spud - use global_parameters, only: FIELD_NAME_LEN - use halos_numbering - use fields - use state_module - use field_options - use mesh_quality - use diagnostic_source_fields + use fldebug + use spud + use global_parameters, only: FIELD_NAME_LEN + use halos_numbering + use fields + use state_module + use field_options + use mesh_quality + use diagnostic_source_fields - implicit none + implicit none - private + private - public :: calculate_column_ids, calculate_universal_column_ids - public :: calculate_mesh_quality, calculate_region_ids + public :: calculate_column_ids, calculate_universal_column_ids + public :: calculate_mesh_quality, calculate_region_ids contains - subroutine calculate_column_ids(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_column_ids(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - ewrite(1, *) "In calculate_column_ids" + ewrite(1, *) "In calculate_column_ids" - if(.not.associated(s_field%mesh%columns)) then - if(have_option(trim(s_field%mesh%option_path)//"/from_mesh/extrude")) then - FLAbort("No columns associated with an extruded mesh.") - else - FLExit("Requested column_id output on non-extruded mesh.") + if(.not.associated(s_field%mesh%columns)) then + if(have_option(trim(s_field%mesh%option_path)//"/from_mesh/extrude")) then + FLAbort("No columns associated with an extruded mesh.") + else + FLExit("Requested column_id output on non-extruded mesh.") + end if end if - end if - - call set_all(s_field, float(s_field%mesh%columns)) - - ewrite(1, *) "Exiting calculate_column_ids" - - end subroutine calculate_column_ids - subroutine calculate_universal_column_ids(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(mesh_type), pointer :: from_mesh - character(len=FIELD_NAME_LEN) :: from_mesh_name - integer :: nhalos - - ewrite(1, *) "In calculate_universal_column_ids" - - if(.not.associated(s_field%mesh%columns)) then - if(have_option(trim(s_field%mesh%option_path)//"/from_mesh/extrude")) then - FLAbort("No columns associated with an extruded mesh.") - else - FLExit("Requested column_id output on non-extruded mesh.") - end if - end if - - call get_option(trim(s_field%mesh%option_path)//"/from_mesh/mesh/name", from_mesh_name) - from_mesh => extract_mesh(state, trim(from_mesh_name)) - nhalos = halo_count(s_field) - if(nhalos>0) then - call set_all(s_field, float(halo_universal_numbers(from_mesh%halos(nhalos), s_field%mesh%columns))) - else call set_all(s_field, float(s_field%mesh%columns)) - end if - ewrite(1, *) "Exiting calculate_universal_column_ids" + ewrite(1, *) "Exiting calculate_column_ids" - end subroutine calculate_universal_column_ids + end subroutine calculate_column_ids - subroutine calculate_mesh_quality(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_universal_column_ids(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - type(vector_field), pointer :: positions + type(mesh_type), pointer :: from_mesh + character(len=FIELD_NAME_LEN) :: from_mesh_name + integer :: nhalos - integer :: measure - character(len=FIELD_NAME_LEN) :: measure_name + ewrite(1, *) "In calculate_universal_column_ids" - positions => extract_vector_field(state,"Coordinate") + if(.not.associated(s_field%mesh%columns)) then + if(have_option(trim(s_field%mesh%option_path)//"/from_mesh/extrude")) then + FLAbort("No columns associated with an extruded mesh.") + else + FLExit("Requested column_id output on non-extruded mesh.") + end if + end if - if (element_count(s_field) /= node_count(s_field)) then - FLAbort("Mesh quality measures must be on a P0 mesh") - end if + call get_option(trim(s_field%mesh%option_path)//"/from_mesh/mesh/name", from_mesh_name) + from_mesh => extract_mesh(state, trim(from_mesh_name)) + nhalos = halo_count(s_field) + if(nhalos>0) then + call set_all(s_field, float(halo_universal_numbers(from_mesh%halos(nhalos), s_field%mesh%columns))) + else + call set_all(s_field, float(s_field%mesh%columns)) + end if - call get_option(trim(complete_field_path(trim(s_field%option_path))) // & - "/algorithm[0]/quality_function/name", measure_name) + ewrite(1, *) "Exiting calculate_universal_column_ids" - select case(trim(measure_name)) - case("radius_ratio") - measure=VTK_QUALITY_RADIUS_RATIO - case("aspect_ratio") - measure=VTK_QUALITY_ASPECT_RATIO - case("aspect_frobenius") - measure=VTK_QUALITY_ASPECT_FROBENIUS - case("edge_ratio") - measure=VTK_QUALITY_EDGE_RATIO - case("condition") - measure=VTK_QUALITY_CONDITION - case("min_angle") - measure=VTK_QUALITY_MIN_ANGLE - case("max_angle") - measure=VTK_QUALITY_MAX_ANGLE - case("shape") - measure=VTK_QUALITY_SHAPE - case("min_angl") - measure=VTK_QUALITY_SHAPE_AND_SIZE - case("area_or_volume") - measure=VTK_QUALITY_AREA - case default - FLAbort("Unknown quality function for "//trim(s_field%name) ) - end select + end subroutine calculate_universal_column_ids - call get_mesh_quality(positions, s_field, measure) + subroutine calculate_mesh_quality(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - end subroutine calculate_mesh_quality + type(vector_field), pointer :: positions - subroutine calculate_region_ids(state, s_field) + integer :: measure + character(len=FIELD_NAME_LEN) :: measure_name - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + positions => extract_vector_field(state,"Coordinate") - ewrite(1, *) "In calculate_region_ids" + if (element_count(s_field) /= node_count(s_field)) then + FLAbort("Mesh quality measures must be on a P0 mesh") + end if - if(.not.associated(s_field%mesh%region_ids)) then - FLAbort("No region ids stored on mesh.") - end if + call get_option(trim(complete_field_path(trim(s_field%option_path))) // & + "/algorithm[0]/quality_function/name", measure_name) + + select case(trim(measure_name)) + case("radius_ratio") + measure=VTK_QUALITY_RADIUS_RATIO + case("aspect_ratio") + measure=VTK_QUALITY_ASPECT_RATIO + case("aspect_frobenius") + measure=VTK_QUALITY_ASPECT_FROBENIUS + case("edge_ratio") + measure=VTK_QUALITY_EDGE_RATIO + case("condition") + measure=VTK_QUALITY_CONDITION + case("min_angle") + measure=VTK_QUALITY_MIN_ANGLE + case("max_angle") + measure=VTK_QUALITY_MAX_ANGLE + case("shape") + measure=VTK_QUALITY_SHAPE + case("min_angl") + measure=VTK_QUALITY_SHAPE_AND_SIZE + case("area_or_volume") + measure=VTK_QUALITY_AREA + case default + FLAbort("Unknown quality function for "//trim(s_field%name) ) + end select + + call get_mesh_quality(positions, s_field, measure) + + end subroutine calculate_mesh_quality + + subroutine calculate_region_ids(state, s_field) + + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + + ewrite(1, *) "In calculate_region_ids" + + if(.not.associated(s_field%mesh%region_ids)) then + FLAbort("No region ids stored on mesh.") + end if - if(.not.(s_field%mesh%shape%degree==0 .and. s_field%mesh%continuity<0)) then - FLExit("Diagnostic region_ids field should be on a P0(DG) mesh") - end if + if(.not.(s_field%mesh%shape%degree==0 .and. s_field%mesh%continuity<0)) then + FLExit("Diagnostic region_ids field should be on a P0(DG) mesh") + end if - call set_all(s_field, float(s_field%mesh%region_ids)) + call set_all(s_field, float(s_field%mesh%region_ids)) - ewrite(1, *) "Exiting calculate_region_ids" + ewrite(1, *) "Exiting calculate_region_ids" - end subroutine calculate_region_ids + end subroutine calculate_region_ids end module mesh_diagnostics diff --git a/diagnostics/Metric_Diagnostics.F90 b/diagnostics/Metric_Diagnostics.F90 index 8265855428..e29127d989 100644 --- a/diagnostics/Metric_Diagnostics.F90 +++ b/diagnostics/Metric_Diagnostics.F90 @@ -28,106 +28,106 @@ module metric_diagnostics - use fldebug - use quicksort - use spud - use vector_tools - use metric_tools - use fields - use state_module - use field_options - use conformity_measurement - use diagnostic_source_fields - use edge_length_module - use field_derivatives - use form_metric_field - - implicit none - - private - - public :: calculate_scalar_edge_lengths, calculate_field_tolerance, & - & calculate_eigenvalues_symmetric + use fldebug + use quicksort + use spud + use vector_tools + use metric_tools + use fields + use state_module + use field_options + use conformity_measurement + use diagnostic_source_fields + use edge_length_module + use field_derivatives + use form_metric_field + + implicit none + + private + + public :: calculate_scalar_edge_lengths, calculate_field_tolerance, & + & calculate_eigenvalues_symmetric contains - subroutine calculate_field_tolerance(state, t_field) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: t_field + subroutine calculate_field_tolerance(state, t_field) + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: t_field - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions - type(tensor_field) :: mesh_metric, hessian - logical :: allocated - integer :: node, p, stat + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions + type(tensor_field) :: mesh_metric, hessian + logical :: allocated + integer :: node, p, stat - ewrite(1, *) "In calculate_field_tolerance" + ewrite(1, *) "In calculate_field_tolerance" - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") - call compute_mesh_metric(positions, mesh_metric) + call compute_mesh_metric(positions, mesh_metric) - source_field => scalar_source_field(state, t_field, allocated = allocated) + source_field => scalar_source_field(state, t_field, allocated = allocated) - call allocate(hessian, source_field%mesh, "Hessian") - call compute_hessian(source_field, positions, hessian) - call get_option(trim(complete_field_path(t_field%option_path)) // "/algorithm/p_norm", p, stat = stat) - if(stat == SPUD_NO_ERROR) call p_norm_scale_metric(hessian, p) + call allocate(hessian, source_field%mesh, "Hessian") + call compute_hessian(source_field, positions, hessian) + call get_option(trim(complete_field_path(t_field%option_path)) // "/algorithm/p_norm", p, stat = stat) + if(stat == SPUD_NO_ERROR) call p_norm_scale_metric(hessian, p) - assert(hessian%mesh == mesh_metric%mesh) - assert(hessian%mesh == t_field%mesh) - do node = 1, node_count(mesh_metric) - call set(t_field, node, matmul(inverse(node_val(mesh_metric, node)), absolutify_tensor(node_val(hessian, node)))) - end do + assert(hessian%mesh == mesh_metric%mesh) + assert(hessian%mesh == t_field%mesh) + do node = 1, node_count(mesh_metric) + call set(t_field, node, matmul(inverse(node_val(mesh_metric, node)), absolutify_tensor(node_val(hessian, node)))) + end do - if(allocated) deallocate(source_field) - call deallocate(hessian) - call deallocate(mesh_metric) + if(allocated) deallocate(source_field) + call deallocate(hessian) + call deallocate(mesh_metric) - ewrite(1, *) "Exiting calculate_field_tolerance" + ewrite(1, *) "Exiting calculate_field_tolerance" - end subroutine calculate_field_tolerance + end subroutine calculate_field_tolerance - subroutine calculate_scalar_edge_lengths(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_edge_lengths(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - type(tensor_field) :: metric - type(vector_field), pointer :: positions => null() + type(tensor_field) :: metric + type(vector_field), pointer :: positions => null() - positions => extract_vector_field(state, "Coordinate") - assert(positions%mesh == s_field%mesh) + positions => extract_vector_field(state, "Coordinate") + assert(positions%mesh == s_field%mesh) - call compute_mesh_metric(positions, metric) - call get_edge_lengths(metric, s_field) + call compute_mesh_metric(positions, metric) + call get_edge_lengths(metric, s_field) - call deallocate(metric) + call deallocate(metric) - end subroutine calculate_scalar_edge_lengths + end subroutine calculate_scalar_edge_lengths - subroutine calculate_eigenvalues_symmetric(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_eigenvalues_symmetric(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - integer :: i - integer, dimension(v_field%dim) :: permutation - real, dimension(v_field%dim) :: evals - real, dimension(v_field%dim, v_field%dim) :: evecs - type(tensor_field), pointer :: source_field + integer :: i + integer, dimension(v_field%dim) :: permutation + real, dimension(v_field%dim) :: evals + real, dimension(v_field%dim, v_field%dim) :: evecs + type(tensor_field), pointer :: source_field - source_field => tensor_source_field(state, v_field) - if(.not. source_field%mesh == v_field%mesh) then - ewrite(-1, *) trim(v_field%name) // " mesh: " // trim(v_field%mesh%name) - ewrite(-1, *) trim(source_field%name) // " mesh: " // trim(source_field%mesh%name) - FLExit("Eigendecomposition mesh must match source tensor field mesh") - end if + source_field => tensor_source_field(state, v_field) + if(.not. source_field%mesh == v_field%mesh) then + ewrite(-1, *) trim(v_field%name) // " mesh: " // trim(v_field%mesh%name) + ewrite(-1, *) trim(source_field%name) // " mesh: " // trim(source_field%mesh%name) + FLExit("Eigendecomposition mesh must match source tensor field mesh") + end if - do i = 1, node_count(source_field) - call eigendecomposition_symmetric(node_val(source_field, i), evecs, evals) - call qsort(evals, permutation) - call set(v_field, i, evals(permutation)) - end do + do i = 1, node_count(source_field) + call eigendecomposition_symmetric(node_val(source_field, i), evecs, evals) + call qsort(evals, permutation) + call set(v_field, i, evals(permutation)) + end do - end subroutine calculate_eigenvalues_symmetric + end subroutine calculate_eigenvalues_symmetric end module metric_diagnostics diff --git a/diagnostics/Momentum_Diagnostics.F90 b/diagnostics/Momentum_Diagnostics.F90 index 541d4e999b..784bef2e03 100644 --- a/diagnostics/Momentum_Diagnostics.F90 +++ b/diagnostics/Momentum_Diagnostics.F90 @@ -29,571 +29,571 @@ module momentum_diagnostics - use fldebug - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use spud - use sparse_tools - use fetools - use fields - use state_module - use boundary_conditions - use coriolis_module, only : two_omega => coriolis - use field_options - use diagnostic_source_fields - use field_derivatives - use solvers - use sparsity_patterns_meshes - use state_fields_module - use sediment, only : get_n_sediment_fields, get_sediment_item - use geostrophic_pressure - use multimaterial_module - - implicit none - - private - - public :: calculate_strain_rate, calculate_bulk_viscosity, calculate_strain_rate_second_invariant, & - calculate_sediment_concentration_dependent_viscosity, & - calculate_buoyancy, calculate_coriolis, calculate_tensor_second_invariant, & - calculate_imposed_material_velocity_source, & - calculate_imposed_material_velocity_absorption, & - calculate_scalar_potential, calculate_projection_scalar_potential, & - calculate_geostrophic_velocity, calculate_viscous_dissipation + use fldebug + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use spud + use sparse_tools + use fetools + use fields + use state_module + use boundary_conditions + use coriolis_module, only : two_omega => coriolis + use field_options + use diagnostic_source_fields + use field_derivatives + use solvers + use sparsity_patterns_meshes + use state_fields_module + use sediment, only : get_n_sediment_fields, get_sediment_item + use geostrophic_pressure + use multimaterial_module + + implicit none + + private + + public :: calculate_strain_rate, calculate_bulk_viscosity, calculate_strain_rate_second_invariant, & + calculate_sediment_concentration_dependent_viscosity, & + calculate_buoyancy, calculate_coriolis, calculate_tensor_second_invariant, & + calculate_imposed_material_velocity_source, & + calculate_imposed_material_velocity_absorption, & + calculate_scalar_potential, calculate_projection_scalar_potential, & + calculate_geostrophic_velocity, calculate_viscous_dissipation contains - subroutine calculate_strain_rate(state, t_field) - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field + subroutine calculate_strain_rate(state, t_field) + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field - type(vector_field), pointer :: source_field - type(vector_field), pointer :: positions + type(vector_field), pointer :: source_field + type(vector_field), pointer :: positions - positions => extract_vector_field(state, "Coordinate") - source_field => vector_source_field(state, t_field) + positions => extract_vector_field(state, "Coordinate") + source_field => vector_source_field(state, t_field) - call check_source_mesh_derivative(source_field, "strain_rate") + call check_source_mesh_derivative(source_field, "strain_rate") - call strain_rate(source_field, positions, t_field) + call strain_rate(source_field, positions, t_field) - end subroutine calculate_strain_rate + end subroutine calculate_strain_rate - subroutine calculate_strain_rate_second_invariant(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_strain_rate_second_invariant(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - type(vector_field), pointer :: positions - type(vector_field), pointer :: velocity + type(vector_field), pointer :: positions + type(vector_field), pointer :: velocity - type(tensor_field) :: strain_rate_tensor + type(tensor_field) :: strain_rate_tensor - ewrite(1,*) 'In calculate_strain_rate_second_invariant' - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "IteratedVelocity") + ewrite(1,*) 'In calculate_strain_rate_second_invariant' + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "IteratedVelocity") - ! Allocate strain_rate tensor: - call allocate(strain_rate_tensor, s_field%mesh, name="strain_rate_II") + ! Allocate strain_rate tensor: + call allocate(strain_rate_tensor, s_field%mesh, name="strain_rate_II") - call check_source_mesh_derivative(velocity, "strain_rate_second_invariant") + call check_source_mesh_derivative(velocity, "strain_rate_second_invariant") - ! Calculate strain_rate and second invariant: - call strain_rate(velocity, positions, strain_rate_tensor) - call tensor_second_invariant(strain_rate_tensor, s_field) + ! Calculate strain_rate and second invariant: + call strain_rate(velocity, positions, strain_rate_tensor) + call tensor_second_invariant(strain_rate_tensor, s_field) - ! Clean-up: - call deallocate(strain_rate_tensor) + ! Clean-up: + call deallocate(strain_rate_tensor) - ! Prin min and max: - ewrite_minmax(s_field) + ! Prin min and max: + ewrite_minmax(s_field) - end subroutine calculate_strain_rate_second_invariant + end subroutine calculate_strain_rate_second_invariant - subroutine calculate_sediment_concentration_dependent_viscosity(state, t_field) - ! calculates viscosity based upon total sediment concentration - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field + subroutine calculate_sediment_concentration_dependent_viscosity(state, t_field) + ! calculates viscosity based upon total sediment concentration + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field - type(scalar_field_pointer), dimension(:), allocatable :: sediment_concs - type(tensor_field), pointer :: zero_conc_viscosity - type(scalar_field) :: rhs - integer :: sediment_classes, i + type(scalar_field_pointer), dimension(:), allocatable :: sediment_concs + type(tensor_field), pointer :: zero_conc_viscosity + type(scalar_field) :: rhs + integer :: sediment_classes, i - ewrite(1,*) 'In calculate_sediment_concentration_dependent_viscosity' + ewrite(1,*) 'In calculate_sediment_concentration_dependent_viscosity' - sediment_classes = get_n_sediment_fields() + sediment_classes = get_n_sediment_fields() - if (sediment_classes > 0) then - allocate(sediment_concs(sediment_classes)) + if (sediment_classes > 0) then + allocate(sediment_concs(sediment_classes)) - call get_sediment_item(state, 1, sediment_concs(1)%ptr) + call get_sediment_item(state, 1, sediment_concs(1)%ptr) - call allocate(rhs, sediment_concs(1)%ptr%mesh, name="Rhs") - call set(rhs, 1.0) + call allocate(rhs, sediment_concs(1)%ptr%mesh, name="Rhs") + call set(rhs, 1.0) - ! get sediment concentrations and remove c/0.65 from rhs - do i=1, sediment_classes - call get_sediment_item(state, i, sediment_concs(i)%ptr) - call addto(rhs, sediment_concs(i)%ptr, scale=-(1.0/0.65)) - end do + ! get sediment concentrations and remove c/0.65 from rhs + do i=1, sediment_classes + call get_sediment_item(state, i, sediment_concs(i)%ptr) + call addto(rhs, sediment_concs(i)%ptr, scale=-(1.0/0.65)) + end do - ! raise rhs to power of -1.625 - do i = 1, node_count(rhs) - call set(rhs, i, node_val(rhs, i)**(-1.625)) - end do + ! raise rhs to power of -1.625 + do i = 1, node_count(rhs) + call set(rhs, i, node_val(rhs, i)**(-1.625)) + end do - ! check for presence of ZeroSedimentConcentrationViscosity field - if (.not. has_tensor_field(state, "ZeroSedimentConcentrationViscosity")) then - FLExit("You must specify an zero sediment concentration viscosity to be able & - &to calculate sediment concentration dependent viscosity field values") - endif - zero_conc_viscosity => extract_tensor_field(state, 'ZeroSedimentConcentrationViscosity') + ! check for presence of ZeroSedimentConcentrationViscosity field + if (.not. has_tensor_field(state, "ZeroSedimentConcentrationViscosity")) then + FLExit("You must specify an zero sediment concentration viscosity to be able & + &to calculate sediment concentration dependent viscosity field values") + endif + zero_conc_viscosity => extract_tensor_field(state, 'ZeroSedimentConcentrationViscosity') - call set(t_field, zero_conc_viscosity) - call scale(t_field, rhs) - ewrite_minmax(t_field) + call set(t_field, zero_conc_viscosity) + call scale(t_field, rhs) + ewrite_minmax(t_field) - deallocate(sediment_concs) - call deallocate(rhs) - else - ewrite(1,*) 'No sediment in problem definition' - end if - end subroutine calculate_sediment_concentration_dependent_viscosity - - subroutine calculate_tensor_second_invariant(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field - - type(tensor_field), pointer :: source_field - - source_field => tensor_source_field(state, s_field) - - call tensor_second_invariant(source_field, s_field) - - end subroutine calculate_tensor_second_invariant + deallocate(sediment_concs) + call deallocate(rhs) + else + ewrite(1,*) 'No sediment in problem definition' + end if + end subroutine calculate_sediment_concentration_dependent_viscosity + + subroutine calculate_tensor_second_invariant(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field + + type(tensor_field), pointer :: source_field + + source_field => tensor_source_field(state, s_field) + + call tensor_second_invariant(source_field, s_field) + + end subroutine calculate_tensor_second_invariant + + subroutine calculate_viscous_dissipation(state, s_field) + ! A routine to calculate the viscous dissipation. Currently + ! assumes a constant viscosity tensor: + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field + + type(vector_field), pointer :: positions + type(vector_field), pointer :: velocity + type(tensor_field), pointer :: viscosity + + type(scalar_field) :: velocity_divergence + type(scalar_field) :: viscosity_component, viscosity_component_remap + type(tensor_field) :: strain_rate_tensor + + integer :: dim1, dim2, node + real :: val + + ewrite(1,*) 'In calculate_viscous_dissipation' + + ! Extract velocity field from state - will be used to calculate strain- + ! rate tensor: + velocity => extract_vector_field(state, "NonlinearVelocity") + ! Check velocity field is not on a discontinous mesh: + call check_source_mesh_derivative(velocity, "Viscous_Dissipation") + + ! Extract positions field from state: + positions => extract_vector_field(state, "Coordinate") + + ! Allocate and initialize strain rate tensor: + call allocate(strain_rate_tensor, s_field%mesh, "Strain_Rate_VD") + call zero(strain_rate_tensor) + + ! Calculate strain rate tensor: + call strain_rate(velocity, positions, strain_rate_tensor) + + ! Calculate velocity divergence for correct definition of stress: + call allocate(velocity_divergence, s_field%mesh, 'Velocity_divergence') + call div(velocity, positions, velocity_divergence) + ewrite_minmax(velocity_divergence) + + ! Extract viscosity from state and remap to s_field mesh: + viscosity => extract_tensor_field(state, "Viscosity") + ! Extract first component of viscosity tensor from full tensor: + !*** This is not ideal - only valid for constant viscosity tensors + !*** though they can still vary spatially and temporally. + viscosity_component = extract_scalar_field(viscosity,1,1) + call allocate(viscosity_component_remap, s_field%mesh, "RemappedViscosityComponent") + call remap_field(viscosity_component, viscosity_component_remap) + + ! Calculate viscous dissipation (scalar s_field): + do node=1,node_count(s_field) + val = 0. + do dim1 = 1, velocity%dim + do dim2 = 1, velocity%dim + if(dim1==dim2) then + ! Add divergence of velocity term to diagonal only: + val = val + 2.*node_val(viscosity_component_remap, node) * & + & (node_val(strain_rate_tensor,dim1,dim2,node) - & + & 1./3. * node_val(velocity_divergence, node))**2 + else + val = val + 2.*node_val(viscosity_component_remap, node) * & + & node_val(strain_rate_tensor,dim1,dim2,node)**2 + end if + end do + end do + call set(s_field, node, val) + end do + + ewrite_minmax(s_field) + + ! Deallocate: + call deallocate(strain_rate_tensor) + call deallocate(viscosity_component_remap) + call deallocate(velocity_divergence) + + end subroutine calculate_viscous_dissipation + + subroutine calculate_bulk_viscosity(states, t_field) + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), intent(inout) :: t_field + + character(len = OPTION_PATH_LEN) :: mean_type + + call get_option(trim(complete_field_path(trim(t_field%option_path))) // & + "/algorithm[0]/mean/name", mean_type, default="arithmetic") + + call calculate_bulk_property(states, t_field, "MaterialViscosity", & + & mean_type = mean_type, momentum_diagnostic = .true.) - subroutine calculate_viscous_dissipation(state, s_field) - ! A routine to calculate the viscous dissipation. Currently - ! assumes a constant viscosity tensor: - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + end subroutine calculate_bulk_viscosity - type(vector_field), pointer :: positions - type(vector_field), pointer :: velocity - type(tensor_field), pointer :: viscosity + subroutine calculate_imposed_material_velocity_source(states, state_index, v_field) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field - type(scalar_field) :: velocity_divergence - type(scalar_field) :: viscosity_component, viscosity_component_remap - type(tensor_field) :: strain_rate_tensor + logical :: prescribed + integer :: i, stat + type(vector_field), pointer :: absorption, mat_vel - integer :: dim1, dim2, node - real :: val + call zero(v_field) - ewrite(1,*) 'In calculate_viscous_dissipation' + do i = 1, size(states) - ! Extract velocity field from state - will be used to calculate strain- - ! rate tensor: - velocity => extract_vector_field(state, "NonlinearVelocity") - ! Check velocity field is not on a discontinous mesh: - call check_source_mesh_derivative(velocity, "Viscous_Dissipation") + mat_vel => extract_vector_field(states(i), "MaterialVelocity", stat) - ! Extract positions field from state: - positions => extract_vector_field(state, "Coordinate") - - ! Allocate and initialize strain rate tensor: - call allocate(strain_rate_tensor, s_field%mesh, "Strain_Rate_VD") - call zero(strain_rate_tensor) - - ! Calculate strain rate tensor: - call strain_rate(velocity, positions, strain_rate_tensor) - - ! Calculate velocity divergence for correct definition of stress: - call allocate(velocity_divergence, s_field%mesh, 'Velocity_divergence') - call div(velocity, positions, velocity_divergence) - ewrite_minmax(velocity_divergence) - - ! Extract viscosity from state and remap to s_field mesh: - viscosity => extract_tensor_field(state, "Viscosity") - ! Extract first component of viscosity tensor from full tensor: - !*** This is not ideal - only valid for constant viscosity tensors - !*** though they can still vary spatially and temporally. - viscosity_component = extract_scalar_field(viscosity,1,1) - call allocate(viscosity_component_remap, s_field%mesh, "RemappedViscosityComponent") - call remap_field(viscosity_component, viscosity_component_remap) - - ! Calculate viscous dissipation (scalar s_field): - do node=1,node_count(s_field) - val = 0. - do dim1 = 1, velocity%dim - do dim2 = 1, velocity%dim - if(dim1==dim2) then - ! Add divergence of velocity term to diagonal only: - val = val + 2.*node_val(viscosity_component_remap, node) * & - & (node_val(strain_rate_tensor,dim1,dim2,node) - & - & 1./3. * node_val(velocity_divergence, node))**2 - else - val = val + 2.*node_val(viscosity_component_remap, node) * & - & node_val(strain_rate_tensor,dim1,dim2,node)**2 - end if - end do - end do - call set(s_field, node, val) - end do - - ewrite_minmax(s_field) - - ! Deallocate: - call deallocate(strain_rate_tensor) - call deallocate(viscosity_component_remap) - call deallocate(velocity_divergence) - - end subroutine calculate_viscous_dissipation - - subroutine calculate_bulk_viscosity(states, t_field) - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), intent(inout) :: t_field - - character(len = OPTION_PATH_LEN) :: mean_type - - call get_option(trim(complete_field_path(trim(t_field%option_path))) // & - "/algorithm[0]/mean/name", mean_type, default="arithmetic") - - call calculate_bulk_property(states, t_field, "MaterialViscosity", & - & mean_type = mean_type, momentum_diagnostic = .true.) + if(stat==0) then - end subroutine calculate_bulk_viscosity + call add_scaled_material_property(states(i), v_field, mat_vel, & + momentum_diagnostic=.true.) - subroutine calculate_imposed_material_velocity_source(states, state_index, v_field) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field + else + ! alternatively use the Velocity field from the state - logical :: prescribed - integer :: i, stat - type(vector_field), pointer :: absorption, mat_vel + mat_vel => extract_vector_field(states(i), "Velocity", stat) - call zero(v_field) + if(stat==0) then + prescribed = have_option(trim(mat_vel%option_path)//"/prescribed") - do i = 1, size(states) + if(prescribed.and.(.not.aliased(mat_vel))) then + ! but make sure it's prescribed and not aliased - mat_vel => extract_vector_field(states(i), "MaterialVelocity", stat) + call add_scaled_material_property(states(i), v_field, mat_vel, & + momentum_diagnostic=.true.) - if(stat==0) then + end if - call add_scaled_material_property(states(i), v_field, mat_vel, & - momentum_diagnostic=.true.) + end if - else - ! alternatively use the Velocity field from the state + end if - mat_vel => extract_vector_field(states(i), "Velocity", stat) + end do - if(stat==0) then - prescribed = have_option(trim(mat_vel%option_path)//"/prescribed") + absorption => extract_vector_field(states(state_index), "VelocityAbsorption") + call scale(v_field, absorption) - if(prescribed.and.(.not.aliased(mat_vel))) then - ! but make sure it's prescribed and not aliased + end subroutine calculate_imposed_material_velocity_source - call add_scaled_material_property(states(i), v_field, mat_vel, & - momentum_diagnostic=.true.) + subroutine calculate_imposed_material_velocity_absorption(states, v_field) + type(state_type), dimension(:), intent(inout) :: states + type(vector_field), intent(inout) :: v_field - end if + logical :: prescribed + integer :: i, stat + real :: dt + real, dimension(v_field%dim) :: factor + type(vector_field) :: temp_abs + type(vector_field), pointer :: mat_vel - end if + call get_option("/timestepping/timestep", dt) + call get_option(trim(complete_field_path(trim(v_field%option_path))) // & + "/algorithm[0]/relaxation_factor", factor, default=spread(1.0, 1, v_field%dim)) - end if + call allocate(temp_abs, v_field%dim, v_field%mesh, "TemporaryAbsorption", & + field_type=FIELD_TYPE_CONSTANT) + call set(temp_abs, factor/dt) - end do + call zero(v_field) - absorption => extract_vector_field(states(state_index), "VelocityAbsorption") - call scale(v_field, absorption) + do i = 1, size(states) - end subroutine calculate_imposed_material_velocity_source + mat_vel => extract_vector_field(states(i), "MaterialVelocity", stat) - subroutine calculate_imposed_material_velocity_absorption(states, v_field) - type(state_type), dimension(:), intent(inout) :: states - type(vector_field), intent(inout) :: v_field + if(stat==0) then - logical :: prescribed - integer :: i, stat - real :: dt - real, dimension(v_field%dim) :: factor - type(vector_field) :: temp_abs - type(vector_field), pointer :: mat_vel + call add_scaled_material_property(states(i), v_field, temp_abs, & + momentum_diagnostic=.true.) - call get_option("/timestepping/timestep", dt) - call get_option(trim(complete_field_path(trim(v_field%option_path))) // & - "/algorithm[0]/relaxation_factor", factor, default=spread(1.0, 1, v_field%dim)) + else + ! alternatively use the Velocity field from the state - call allocate(temp_abs, v_field%dim, v_field%mesh, "TemporaryAbsorption", & - field_type=FIELD_TYPE_CONSTANT) - call set(temp_abs, factor/dt) + mat_vel => extract_vector_field(states(i), "Velocity", stat) - call zero(v_field) + if(stat==0) then + prescribed = have_option(trim(mat_vel%option_path)//"/prescribed") - do i = 1, size(states) + if(prescribed.and.(.not.aliased(mat_vel))) then + ! but make sure it's prescribed and not aliased - mat_vel => extract_vector_field(states(i), "MaterialVelocity", stat) + call add_scaled_material_property(states(i), v_field, temp_abs, & + momentum_diagnostic=.true.) - if(stat==0) then + end if - call add_scaled_material_property(states(i), v_field, temp_abs, & - momentum_diagnostic=.true.) + end if - else - ! alternatively use the Velocity field from the state + end if - mat_vel => extract_vector_field(states(i), "Velocity", stat) + end do - if(stat==0) then - prescribed = have_option(trim(mat_vel%option_path)//"/prescribed") + call deallocate(temp_abs) - if(prescribed.and.(.not.aliased(mat_vel))) then - ! but make sure it's prescribed and not aliased + end subroutine calculate_imposed_material_velocity_absorption - call add_scaled_material_property(states(i), v_field, temp_abs, & - momentum_diagnostic=.true.) + subroutine calculate_buoyancy(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - end if + integer :: i, stat + real :: gravity_magnitude + type(scalar_field), pointer :: buoyancy_density + type(vector_field), pointer :: gravity - end if + ewrite(1, *) "In calculate_buoyancy" + buoyancy_density => extract_scalar_field(state, "VelocityBuoyancyDensity", stat = stat) + if(stat /= 0) then + ewrite(0, *) "Warning: Cannot calculate Buoyancy without VelocityBuoyancyDensity field" + call zero(v_field) + ewrite(1, *) "Exiting calculate_buoyancy" + return end if + ewrite_minmax(buoyancy_density) + + gravity => extract_vector_field(state, "GravityDirection", stat = stat) + if(stat /= 0) then + ewrite(0, *) "Warning: Cannot calculate Buoyancy without GravityDirection field" + call zero(v_field) + ewrite(1, *) "Exiting calculate_buoyancy" + return + end if + ewrite_minmax(gravity) - end do - - call deallocate(temp_abs) - - end subroutine calculate_imposed_material_velocity_absorption - - subroutine calculate_buoyancy(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + ewrite(2, *) "Gravity magnitude = ", gravity_magnitude - integer :: i, stat - real :: gravity_magnitude - type(scalar_field), pointer :: buoyancy_density - type(vector_field), pointer :: gravity + if(.not. v_field%mesh == buoyancy_density%mesh) then + ewrite(-1, *) "VelocityBuoyancyDensity mesh: " // trim(buoyancy_density%mesh%name) + FLExit("Buoyancy must be on the VelocityBuoyancyDensity mesh") + end if - ewrite(1, *) "In calculate_buoyancy" + do i = 1, node_count(v_field) + call set(v_field, i, node_val(gravity, i) * node_val(buoyancy_density, i) * gravity_magnitude) + end do - buoyancy_density => extract_scalar_field(state, "VelocityBuoyancyDensity", stat = stat) - if(stat /= 0) then - ewrite(0, *) "Warning: Cannot calculate Buoyancy without VelocityBuoyancyDensity field" - call zero(v_field) ewrite(1, *) "Exiting calculate_buoyancy" - return - end if - ewrite_minmax(buoyancy_density) - - gravity => extract_vector_field(state, "GravityDirection", stat = stat) - if(stat /= 0) then - ewrite(0, *) "Warning: Cannot calculate Buoyancy without GravityDirection field" - call zero(v_field) - ewrite(1, *) "Exiting calculate_buoyancy" - return - end if - ewrite_minmax(gravity) - - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - ewrite(2, *) "Gravity magnitude = ", gravity_magnitude - if(.not. v_field%mesh == buoyancy_density%mesh) then - ewrite(-1, *) "VelocityBuoyancyDensity mesh: " // trim(buoyancy_density%mesh%name) - FLExit("Buoyancy must be on the VelocityBuoyancyDensity mesh") - end if + end subroutine calculate_buoyancy - do i = 1, node_count(v_field) - call set(v_field, i, node_val(gravity, i) * node_val(buoyancy_density, i) * gravity_magnitude) - end do + subroutine calculate_coriolis(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field - ewrite(1, *) "Exiting calculate_buoyancy" + character(len = OPTION_PATH_LEN) :: base_path - end subroutine calculate_buoyancy + base_path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - subroutine calculate_coriolis(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field - - character(len = OPTION_PATH_LEN) :: base_path - - base_path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - - if(have_option(trim(base_path) // "/consistent_interpolation")) then - call compute_coriolis_ci(state, v_field) - else if(have_option(trim(base_path) // "/galerkin_projection")) then - if(have_option(trim(base_path) // "/galerkin_projection/lump_mass")) then - call compute_coriolis_gp_lumped(state, v_field) + if(have_option(trim(base_path) // "/consistent_interpolation")) then + call compute_coriolis_ci(state, v_field) + else if(have_option(trim(base_path) // "/galerkin_projection")) then + if(have_option(trim(base_path) // "/galerkin_projection/lump_mass")) then + call compute_coriolis_gp_lumped(state, v_field) + else + call compute_coriolis_gp(state, v_field, option_path = trim(base_path) // "/galerkin_projection") + end if else - call compute_coriolis_gp(state, v_field, option_path = trim(base_path) // "/galerkin_projection") + FLAbort("Failed to determine interpolation method") end if - else - FLAbort("Failed to determine interpolation method") - end if - end subroutine calculate_coriolis + end subroutine calculate_coriolis - subroutine compute_coriolis_ci(state, coriolis) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: coriolis + subroutine compute_coriolis_ci(state, coriolis) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: coriolis - integer :: i - type(vector_field) :: positions, velocity_remap - type(vector_field), pointer :: velocity + integer :: i + type(vector_field) :: positions, velocity_remap + type(vector_field), pointer :: velocity - positions = get_nodal_coordinate_field(state, coriolis%mesh) - velocity => extract_vector_field(state, "Velocity") + positions = get_nodal_coordinate_field(state, coriolis%mesh) + velocity => extract_vector_field(state, "Velocity") - if(velocity%mesh == coriolis%mesh) then - velocity_remap = velocity - call incref(velocity_remap) - else - call allocate(velocity_remap, velocity%dim, coriolis%mesh, "VelocityRemap") - call remap_field(velocity, velocity_remap) - end if + if(velocity%mesh == coriolis%mesh) then + velocity_remap = velocity + call incref(velocity_remap) + else + call allocate(velocity_remap, velocity%dim, coriolis%mesh, "VelocityRemap") + call remap_field(velocity, velocity_remap) + end if - do i = 1, node_count(coriolis) - call set(coriolis, i, coriolis_val(node_val(positions, i), node_val(velocity_remap, i))) - end do + do i = 1, node_count(coriolis) + call set(coriolis, i, coriolis_val(node_val(positions, i), node_val(velocity_remap, i))) + end do - call deallocate(positions) - call deallocate(velocity_remap) + call deallocate(positions) + call deallocate(velocity_remap) - end subroutine compute_coriolis_ci + end subroutine compute_coriolis_ci - subroutine compute_coriolis_gp(state, coriolis, option_path) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: coriolis - character(len = *), optional, intent(in) :: option_path + subroutine compute_coriolis_gp(state, coriolis, option_path) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: coriolis + character(len = *), optional, intent(in) :: option_path - integer :: i - type(csr_matrix), pointer :: mass - type(vector_field) :: rhs - type(vector_field), pointer :: positions, velocity + integer :: i + type(csr_matrix), pointer :: mass + type(vector_field) :: rhs + type(vector_field), pointer :: positions, velocity - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") - mass => get_mass_matrix(state, coriolis%mesh) - call allocate(rhs, coriolis%dim, coriolis%mesh, "CoriolisRhs") + mass => get_mass_matrix(state, coriolis%mesh) + call allocate(rhs, coriolis%dim, coriolis%mesh, "CoriolisRhs") - call zero(rhs) - do i = 1, ele_count(rhs) - call assemble_coriolis_ele(i, positions, velocity, rhs) - end do + call zero(rhs) + do i = 1, ele_count(rhs) + call assemble_coriolis_ele(i, positions, velocity, rhs) + end do - call petsc_solve(coriolis, mass, rhs, option_path = option_path) + call petsc_solve(coriolis, mass, rhs, option_path = option_path) - call deallocate(rhs) + call deallocate(rhs) - end subroutine compute_coriolis_gp + end subroutine compute_coriolis_gp - subroutine compute_coriolis_gp_lumped(state, coriolis) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: coriolis + subroutine compute_coriolis_gp_lumped(state, coriolis) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: coriolis - integer :: i - type(scalar_field), pointer :: masslump - type(vector_field), pointer :: positions, velocity + integer :: i + type(scalar_field), pointer :: masslump + type(vector_field), pointer :: positions, velocity - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") - masslump => get_lumped_mass(state, coriolis%mesh) + masslump => get_lumped_mass(state, coriolis%mesh) - call zero(coriolis) - do i = 1, ele_count(coriolis) - call assemble_coriolis_ele(i, positions, velocity, coriolis) - end do + call zero(coriolis) + do i = 1, ele_count(coriolis) + call assemble_coriolis_ele(i, positions, velocity, coriolis) + end do - do i = 1, coriolis%dim - coriolis%val(i,:) = coriolis%val(i,:) / masslump%val - end do + do i = 1, coriolis%dim + coriolis%val(i,:) = coriolis%val(i,:) / masslump%val + end do - end subroutine compute_coriolis_gp_lumped + end subroutine compute_coriolis_gp_lumped - subroutine assemble_coriolis_ele(ele, positions, velocity, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - type(vector_field), intent(inout) :: rhs + subroutine assemble_coriolis_ele(ele, positions, velocity, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(vector_field), intent(inout) :: rhs - real, dimension(ele_ngi(rhs, ele)) :: detwei + real, dimension(ele_ngi(rhs, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - call addto(rhs, ele_nodes(rhs, ele), & + call addto(rhs, ele_nodes(rhs, ele), & & shape_vector_rhs(ele_shape(rhs, ele), & - & coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(velocity, ele)), & + & coriolis_val(ele_val_at_quad(positions, ele), ele_val_at_quad(velocity, ele)), & & detwei)) - end subroutine assemble_coriolis_ele + end subroutine assemble_coriolis_ele - subroutine calculate_scalar_potential(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_scalar_potential(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - type(vector_field), pointer :: source_field + type(vector_field), pointer :: source_field - source_field => vector_source_field(state, s_field) - call geopressure_decomposition(state, source_field, s_field, & + source_field => vector_source_field(state, s_field) + call geopressure_decomposition(state, source_field, s_field, & & option_path = trim(complete_field_path(s_field%option_path)) // "/algorithm") - end subroutine calculate_scalar_potential + end subroutine calculate_scalar_potential - subroutine calculate_projection_scalar_potential(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_projection_scalar_potential(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field - character(len = OPTION_PATH_LEN) :: bcfield_name, path - type(scalar_field), pointer :: gp - type(vector_field), pointer :: bcfield, source_field + character(len = OPTION_PATH_LEN) :: bcfield_name, path + type(scalar_field), pointer :: gp + type(vector_field), pointer :: bcfield, source_field - source_field => vector_source_field(state, s_field, index = 1) + source_field => vector_source_field(state, s_field, index = 1) - path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - if(have_option(trim(path) // "/bc_field")) then - call get_option(trim(path) // "/bc_field/name", bcfield_name) - bcfield => extract_vector_field(state, bcfield_name) - else - bcfield => source_field - end if + if(have_option(trim(path) // "/bc_field")) then + call get_option(trim(path) // "/bc_field/name", bcfield_name) + bcfield => extract_vector_field(state, bcfield_name) + else + bcfield => source_field + end if - if(have_option(trim(path) // "/source_field_2_name")) then - gp => scalar_source_field(state, s_field, index = 2) - call projection_decomposition(state, source_field, s_field, & - & bcfield = bcfield, gp = gp, option_path = path) - else - call projection_decomposition(state, source_field, s_field, & - & bcfield = bcfield, option_path = path) - end if + if(have_option(trim(path) // "/source_field_2_name")) then + gp => scalar_source_field(state, s_field, index = 2) + call projection_decomposition(state, source_field, s_field, & + & bcfield = bcfield, gp = gp, option_path = path) + else + call projection_decomposition(state, source_field, s_field, & + & bcfield = bcfield, option_path = path) + end if - end subroutine calculate_projection_scalar_potential + end subroutine calculate_projection_scalar_potential - subroutine calculate_geostrophic_velocity(state, v_field) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field + subroutine calculate_geostrophic_velocity(state, v_field) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field - character(len = OPTION_PATH_LEN) :: path - integer :: stat - real :: scale_factor - type(scalar_field), pointer :: source_field - type(cmc_matrices) :: matrices - type(vector_field), pointer :: velocity + character(len = OPTION_PATH_LEN) :: path + integer :: stat + real :: scale_factor + type(scalar_field), pointer :: source_field + type(cmc_matrices) :: matrices + type(vector_field), pointer :: velocity - source_field => scalar_source_field(state, v_field) - velocity => extract_vector_field(state, "Velocity") - path = trim(complete_field_path(v_field%option_path)) // "/algorithm" - call allocate(matrices, state, velocity, source_field, option_path = path, add_cmc = .false.) + source_field => scalar_source_field(state, v_field) + velocity => extract_vector_field(state, "Velocity") + path = trim(complete_field_path(v_field%option_path)) // "/algorithm" + call allocate(matrices, state, velocity, source_field, option_path = path, add_cmc = .false.) - call geostrophic_velocity(matrices, state, v_field, source_field) + call geostrophic_velocity(matrices, state, v_field, source_field) - call deallocate(matrices) + call deallocate(matrices) - call get_option(trim(path) // "/scale_factor", scale_factor, stat = stat) - if(stat == SPUD_NO_ERROR) call scale(v_field, scale_factor) + call get_option(trim(path) // "/scale_factor", scale_factor, stat = stat) + if(stat == SPUD_NO_ERROR) call scale(v_field, scale_factor) - end subroutine calculate_geostrophic_velocity + end subroutine calculate_geostrophic_velocity end module momentum_diagnostics diff --git a/diagnostics/Multiphase_Diagnostics.F90 b/diagnostics/Multiphase_Diagnostics.F90 index 28153e10b8..86d07face2 100644 --- a/diagnostics/Multiphase_Diagnostics.F90 +++ b/diagnostics/Multiphase_Diagnostics.F90 @@ -46,181 +46,181 @@ module multiphase_diagnostics public :: calculate_particle_reynolds_number, calculate_apparent_density - contains - - subroutine calculate_particle_reynolds_number(states, state_index, s_field) - !!< Calculates the particle Reynolds number, (vfrac_f*density_f * |u_f - u_p| * d)/viscosity_f - !!< where the subscripts _f and _p denote the fluid and particle phases respectively, - !!< and d is the particle diameter - - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index ! Index of the particle phase in states - type(scalar_field), intent(inout) :: s_field ! Particle Reynolds number field - - !! Sub-options of the diagnostic field - real :: dia ! Particle diameter - character(len = OPTION_PATH_LEN) :: pd_field_name !name of scalar field that defines particle diameter (can be the sauter mean dia) - type(scalar_field), pointer :: pd_scalar_field ! scalar field referring to particle diameter - logical :: have_constant_pd ! checks if the particle diameter is a constant or not - character(len = OPTION_PATH_LEN) :: continuous_phase_name - - !! Other local variables - integer :: i, continuous_state_index - - ! Velocities of the continuous and particle phases - type(vector_field), pointer :: u_continuous, u_particle - type(vector_field), pointer :: x - type(tensor_field), pointer :: viscosity - type(scalar_field), pointer :: density, vfrac - - ! Counters over the elements and Gauss points - integer :: ele, gi - ! Transformed quadrature weights. - real, dimension(ele_ngi(s_field, 1)) :: detwei - - ! Field values at each quadrature point. - real, dimension(ele_ngi(s_field, 1)) :: particle_re_gi - real, dimension(mesh_dim(s_field), ele_ngi(s_field, 1)) :: u_continuous_gi, u_particle_gi - real, dimension(mesh_dim(s_field), mesh_dim(s_field), ele_ngi(s_field, 1)) :: viscosity_gi - real, dimension(ele_ngi(s_field, 1)) :: density_gi, vfrac_gi - real, dimension(ele_ngi(s_field, 1)) :: d_gi ! particle diameter at the Gauss points - - real, dimension(:), allocatable :: magnitude ! |v_f - v_p| - - ! Current element global node numbers. - integer, dimension(:), pointer :: particle_re_nodes - ! Current particle_re element shape - type(element_type), pointer :: particle_re_shape - - ! Local particle_re matrix on the current element. - real, dimension(ele_loc(s_field, 1),ele_loc(s_field, 1)) :: particle_re_mat - - - ewrite(1,*) 'Entering calculate_particle_reynolds_number' - - ! Get sub-options from under the diagnostic field in the options tree - if(have_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_diameter')) then - call get_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_diameter', dia) - have_constant_pd = .true. - else if(have_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_dia_use_scalar_field')) then - call get_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_dia_use_scalar_field', pd_field_name) - pd_scalar_field => extract_scalar_field(states(state_index), pd_field_name) - have_constant_pd = .false. +contains + + subroutine calculate_particle_reynolds_number(states, state_index, s_field) + !!< Calculates the particle Reynolds number, (vfrac_f*density_f * |u_f - u_p| * d)/viscosity_f + !!< where the subscripts _f and _p denote the fluid and particle phases respectively, + !!< and d is the particle diameter + + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index ! Index of the particle phase in states + type(scalar_field), intent(inout) :: s_field ! Particle Reynolds number field + + !! Sub-options of the diagnostic field + real :: dia ! Particle diameter + character(len = OPTION_PATH_LEN) :: pd_field_name !name of scalar field that defines particle diameter (can be the sauter mean dia) + type(scalar_field), pointer :: pd_scalar_field ! scalar field referring to particle diameter + logical :: have_constant_pd ! checks if the particle diameter is a constant or not + character(len = OPTION_PATH_LEN) :: continuous_phase_name + + !! Other local variables + integer :: i, continuous_state_index + + ! Velocities of the continuous and particle phases + type(vector_field), pointer :: u_continuous, u_particle + type(vector_field), pointer :: x + type(tensor_field), pointer :: viscosity + type(scalar_field), pointer :: density, vfrac + + ! Counters over the elements and Gauss points + integer :: ele, gi + ! Transformed quadrature weights. + real, dimension(ele_ngi(s_field, 1)) :: detwei + + ! Field values at each quadrature point. + real, dimension(ele_ngi(s_field, 1)) :: particle_re_gi + real, dimension(mesh_dim(s_field), ele_ngi(s_field, 1)) :: u_continuous_gi, u_particle_gi + real, dimension(mesh_dim(s_field), mesh_dim(s_field), ele_ngi(s_field, 1)) :: viscosity_gi + real, dimension(ele_ngi(s_field, 1)) :: density_gi, vfrac_gi + real, dimension(ele_ngi(s_field, 1)) :: d_gi ! particle diameter at the Gauss points + + real, dimension(:), allocatable :: magnitude ! |v_f - v_p| + + ! Current element global node numbers. + integer, dimension(:), pointer :: particle_re_nodes + ! Current particle_re element shape + type(element_type), pointer :: particle_re_shape + + ! Local particle_re matrix on the current element. + real, dimension(ele_loc(s_field, 1),ele_loc(s_field, 1)) :: particle_re_mat + + + ewrite(1,*) 'Entering calculate_particle_reynolds_number' + + ! Get sub-options from under the diagnostic field in the options tree + if(have_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_diameter')) then + call get_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_diameter', dia) + have_constant_pd = .true. + else if(have_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_dia_use_scalar_field')) then + call get_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/particle_dia_use_scalar_field', pd_field_name) + pd_scalar_field => extract_scalar_field(states(state_index), pd_field_name) + have_constant_pd = .false. + end if + call get_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/continuous_phase_name', continuous_phase_name) + + ! Find the index of the continuous phase in states + do i = 1, size(states) + if(trim(states(i)%name) == continuous_phase_name) then + continuous_state_index = i end if - call get_option(trim(s_field%option_path)//'/diagnostic/algorithm::particle_reynolds_number/continuous_phase_name', continuous_phase_name) - - ! Find the index of the continuous phase in states - do i = 1, size(states) - if(trim(states(i)%name) == continuous_phase_name) then - continuous_state_index = i - end if - end do - - ! Zero particle Reynolds number field - call zero(s_field) - - u_continuous => extract_vector_field(states(continuous_state_index), "Velocity") - u_particle => extract_vector_field(states(state_index), "Velocity") - x => extract_vector_field(states(state_index), "Coordinate") - if(have_option(trim(states(continuous_state_index)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then - viscosity => extract_tensor_field(states(continuous_state_index),"BackgroundViscosity") + end do + + ! Zero particle Reynolds number field + call zero(s_field) + + u_continuous => extract_vector_field(states(continuous_state_index), "Velocity") + u_particle => extract_vector_field(states(state_index), "Velocity") + x => extract_vector_field(states(state_index), "Coordinate") + if(have_option(trim(states(continuous_state_index)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then + viscosity => extract_tensor_field(states(continuous_state_index),"BackgroundViscosity") + else + viscosity => extract_tensor_field(states(continuous_state_index), "Viscosity") + end if + density => extract_scalar_field(states(continuous_state_index), "Density") + vfrac => extract_scalar_field(states(continuous_state_index), "PhaseVolumeFraction") + + ! Loop through and integrate over each element + do ele = 1, element_count(s_field) + + allocate(magnitude(ele_ngi(u_continuous,ele))) + + particle_re_nodes => ele_nodes(s_field, ele) + particle_re_shape => ele_shape(s_field, ele) + + call transform_to_physical(x, ele, detwei = detwei) + + ! Calculate the particle_re number at each quadrature point. + u_particle_gi = ele_val_at_quad(u_particle, ele) + u_continuous_gi = ele_val_at_quad(u_continuous, ele) + viscosity_gi = ele_val_at_quad(viscosity, ele) + density_gi = ele_val_at_quad(density, ele) + vfrac_gi = ele_val_at_quad(vfrac, ele) + + ! Compute the particle diameter at the Gauss points + if(have_constant_pd) then + d_gi = dia else - viscosity => extract_tensor_field(states(continuous_state_index), "Viscosity") + d_gi = ele_val_at_quad(pd_scalar_field, ele) end if - density => extract_scalar_field(states(continuous_state_index), "Density") - vfrac => extract_scalar_field(states(continuous_state_index), "PhaseVolumeFraction") - - ! Loop through and integrate over each element - do ele = 1, element_count(s_field) - - allocate(magnitude(ele_ngi(u_continuous,ele))) - - particle_re_nodes => ele_nodes(s_field, ele) - particle_re_shape => ele_shape(s_field, ele) - call transform_to_physical(x, ele, detwei = detwei) - - ! Calculate the particle_re number at each quadrature point. - u_particle_gi = ele_val_at_quad(u_particle, ele) - u_continuous_gi = ele_val_at_quad(u_continuous, ele) - viscosity_gi = ele_val_at_quad(viscosity, ele) - density_gi = ele_val_at_quad(density, ele) - vfrac_gi = ele_val_at_quad(vfrac, ele) - - ! Compute the particle diameter at the Gauss points - if(have_constant_pd) then - d_gi = dia - else - d_gi = ele_val_at_quad(pd_scalar_field, ele) - end if - - do gi = 1, ele_ngi(u_continuous, ele) - magnitude(gi) = norm2(u_continuous_gi(:,gi) - u_particle_gi(:,gi)) - end do + do gi = 1, ele_ngi(u_continuous, ele) + magnitude(gi) = norm2(u_continuous_gi(:,gi) - u_particle_gi(:,gi)) + end do - ! Compute the particle Reynolds number - ! (Assumes isotropic viscosity for now) - particle_re_gi = (vfrac_gi*density_gi*magnitude*d_gi) / viscosity_gi(1,1,:) + ! Compute the particle Reynolds number + ! (Assumes isotropic viscosity for now) + particle_re_gi = (vfrac_gi*density_gi*magnitude*d_gi) / viscosity_gi(1,1,:) - ! Invert the mass matrix to get the particle_re value at each node - particle_re_mat = matmul(inverse(shape_shape(particle_re_shape, particle_re_shape, detwei)), & - shape_shape(particle_re_shape, particle_re_shape, detwei*particle_re_gi)) + ! Invert the mass matrix to get the particle_re value at each node + particle_re_mat = matmul(inverse(shape_shape(particle_re_shape, particle_re_shape, detwei)), & + shape_shape(particle_re_shape, particle_re_shape, detwei*particle_re_gi)) - ! (Taken from the GridReynoldsNumber field above) - ! particle_re is inherently discontinuous. In the case where a continuous - ! mesh is provided for particle_re, the following takes the safest option - ! of taking the maximum value at a node. - s_field%val(particle_re_nodes) = max(s_field%val(particle_re_nodes), sum(particle_re_mat,2)) + ! (Taken from the GridReynoldsNumber field above) + ! particle_re is inherently discontinuous. In the case where a continuous + ! mesh is provided for particle_re, the following takes the safest option + ! of taking the maximum value at a node. + s_field%val(particle_re_nodes) = max(s_field%val(particle_re_nodes), sum(particle_re_mat,2)) - deallocate(magnitude) + deallocate(magnitude) - end do + end do - ewrite(1,*) 'Exiting calculate_particle_reynolds_number' + ewrite(1,*) 'Exiting calculate_particle_reynolds_number' - end subroutine calculate_particle_reynolds_number + end subroutine calculate_particle_reynolds_number - subroutine calculate_apparent_density(states, state_index, s_field) - !!< Calculates the apparent density (density * vfrac) - !!< for the material_phase in states[state_index]. + subroutine calculate_apparent_density(states, state_index, s_field) + !!< Calculates the apparent density (density * vfrac) + !!< for the material_phase in states[state_index]. - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field ! Apparent density field + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field ! Apparent density field - !! Local variables - integer :: stat + !! Local variables + integer :: stat - ! Velocities of the continuous and particle phases - type(scalar_field), pointer :: density, vfrac + ! Velocities of the continuous and particle phases + type(scalar_field), pointer :: density, vfrac - type(scalar_field) :: temp_vfrac, temp_density + type(scalar_field) :: temp_vfrac, temp_density - ewrite(1,*) 'Entering calculate_apparent_density' + ewrite(1,*) 'Entering calculate_apparent_density' - density => extract_scalar_field(states(state_index), "Density") - vfrac => extract_scalar_field(states(state_index), "PhaseVolumeFraction", stat) - if(stat /= 0) then - ! PhaseVolumeFraction field not present, so exit with an error. - FLExit("A PhaseVolumeFraction field is required to compute the apparent density.") - end if + density => extract_scalar_field(states(state_index), "Density") + vfrac => extract_scalar_field(states(state_index), "PhaseVolumeFraction", stat) + if(stat /= 0) then + ! PhaseVolumeFraction field not present, so exit with an error. + FLExit("A PhaseVolumeFraction field is required to compute the apparent density.") + end if - call allocate(temp_vfrac, s_field%mesh, "TempPhaseVolumeFraction") - call allocate(temp_density, s_field%mesh, "TempDensity") + call allocate(temp_vfrac, s_field%mesh, "TempPhaseVolumeFraction") + call allocate(temp_density, s_field%mesh, "TempDensity") - ! Remap the original fields to the mesh provided by the apparent density field - call remap_field(vfrac, temp_vfrac) - call remap_field(density, temp_density) + ! Remap the original fields to the mesh provided by the apparent density field + call remap_field(vfrac, temp_vfrac) + call remap_field(density, temp_density) - ! Multiply the remapped PhaseVolumeFraction and Density fields together node-wise - call set(s_field, temp_density) - call scale(s_field, temp_vfrac) + ! Multiply the remapped PhaseVolumeFraction and Density fields together node-wise + call set(s_field, temp_density) + call scale(s_field, temp_vfrac) - call deallocate(temp_vfrac) - call deallocate(temp_density) + call deallocate(temp_vfrac) + call deallocate(temp_density) - ewrite(1,*) 'Exiting calculate_apparent_density' + ewrite(1,*) 'Exiting calculate_apparent_density' - end subroutine calculate_apparent_density + end subroutine calculate_apparent_density end module multiphase_diagnostics diff --git a/diagnostics/Parallel_Diagnostics.F90 b/diagnostics/Parallel_Diagnostics.F90 index 0c96a50c5c..420750417f 100644 --- a/diagnostics/Parallel_Diagnostics.F90 +++ b/diagnostics/Parallel_Diagnostics.F90 @@ -2,130 +2,130 @@ module parallel_diagnostics - use fldebug - use elements - use fields - use halos + use fldebug + use elements + use fields + use halos - implicit none + implicit none - private + private - public :: calculate_node_halo, calculate_universal_numbering, & - & calculate_element_halo, calculate_element_ownership, & - & calculate_element_universal_numbering + public :: calculate_node_halo, calculate_universal_numbering, & + & calculate_element_halo, calculate_element_ownership, & + & calculate_element_universal_numbering contains - subroutine calculate_node_halo(s_field) - type(scalar_field), intent(inout) :: s_field + subroutine calculate_node_halo(s_field) + type(scalar_field), intent(inout) :: s_field - integer :: i, j + integer :: i, j - call zero(s_field) - do i = halo_count(s_field), 1, -1 - do j = 1, halo_proc_count(s_field%mesh%halos(i)) - call set(s_field, halo_sends(s_field%mesh%halos(i), j), spread(float(i), 1, halo_send_count(s_field%mesh%halos(i), j))) - call set(s_field, halo_receives(s_field%mesh%halos(i), j), spread(-float(i), 1, halo_receive_count(s_field%mesh%halos(i), j))) + call zero(s_field) + do i = halo_count(s_field), 1, -1 + do j = 1, halo_proc_count(s_field%mesh%halos(i)) + call set(s_field, halo_sends(s_field%mesh%halos(i), j), spread(float(i), 1, halo_send_count(s_field%mesh%halos(i), j))) + call set(s_field, halo_receives(s_field%mesh%halos(i), j), spread(-float(i), 1, halo_receive_count(s_field%mesh%halos(i), j))) + end do end do - end do - end subroutine calculate_node_halo - - subroutine calculate_universal_numbering(s_field) - type(scalar_field), intent(inout) :: s_field - - integer :: i, nhalos - type(halo_type), pointer :: halo - - nhalos = halo_count(s_field) - if(nhalos > 0) then - halo => s_field%mesh%halos(nhalos) - do i = 1, node_count(s_field) - call set(s_field, i, float(halo_universal_number(halo, i))) - end do - else - do i = 1, node_count(s_field) - call set(s_field, i, float(i)) - end do - end if - - end subroutine calculate_universal_numbering - - subroutine calculate_element_halo(s_field) - type(scalar_field), intent(inout) :: s_field - - integer :: i, j - type(element_type), pointer :: shape - - assert(ele_count(s_field) > 0) - shape => ele_shape(s_field, 1) - if(shape%degree /= 0) then - FLExit("element_halo diagnostic requires a degree 0 mesh") - end if - - call zero(s_field) - do i = element_halo_count(s_field), 1, -1 - do j = 1, halo_proc_count(s_field%mesh%element_halos(i)) - call set(s_field, halo_sends(s_field%mesh%element_halos(i), j), spread(float(i), 1, halo_send_count(s_field%mesh%element_halos(i), j))) - call set(s_field, halo_receives(s_field%mesh%element_halos(i), j), spread(-float(i), 1, halo_receive_count(s_field%mesh%element_halos(i), j))) - end do - end do - - end subroutine calculate_element_halo - - subroutine calculate_element_ownership(s_field) - type(scalar_field), intent(inout) :: s_field - - integer :: i, nhalos - type(element_type), pointer :: shape - type(halo_type), pointer :: ele_halo - - assert(ele_count(s_field) > 0) - shape => ele_shape(s_field, 1) - if(shape%degree /= 0) then - FLExit("element_halo_ownership diagnostic requires a degree 0 mesh") - end if - assert(node_count(s_field) == ele_count(s_field)) - - nhalos = element_halo_count(s_field) - if(nhalos > 0) then - ele_halo => s_field%mesh%element_halos(nhalos) - do i = 1, node_count(s_field) - call set(s_field, i, float(halo_node_owner(ele_halo, i))) - end do - else - call set(s_field, 1.0) - end if - - end subroutine calculate_element_ownership - - subroutine calculate_element_universal_numbering(s_field) - type(scalar_field), intent(inout) :: s_field - - integer :: i, nhalos - type(element_type), pointer :: shape - type(halo_type), pointer :: ele_halo - - assert(ele_count(s_field) > 0) - shape => ele_shape(s_field, 1) - if(shape%degree /= 0) then - FLExit("element_universal_numbering diagnostic requires a degree 0 mesh") - end if - assert(node_count(s_field) == ele_count(s_field)) - - nhalos = element_halo_count(s_field) - if(nhalos > 0) then - ele_halo => s_field%mesh%element_halos(nhalos) - do i = 1, node_count(s_field) - call set(s_field, i, float(halo_universal_number(ele_halo, i))) - end do - else - do i = 1, node_count(s_field) - call set(s_field, i, float(i)) + end subroutine calculate_node_halo + + subroutine calculate_universal_numbering(s_field) + type(scalar_field), intent(inout) :: s_field + + integer :: i, nhalos + type(halo_type), pointer :: halo + + nhalos = halo_count(s_field) + if(nhalos > 0) then + halo => s_field%mesh%halos(nhalos) + do i = 1, node_count(s_field) + call set(s_field, i, float(halo_universal_number(halo, i))) + end do + else + do i = 1, node_count(s_field) + call set(s_field, i, float(i)) + end do + end if + + end subroutine calculate_universal_numbering + + subroutine calculate_element_halo(s_field) + type(scalar_field), intent(inout) :: s_field + + integer :: i, j + type(element_type), pointer :: shape + + assert(ele_count(s_field) > 0) + shape => ele_shape(s_field, 1) + if(shape%degree /= 0) then + FLExit("element_halo diagnostic requires a degree 0 mesh") + end if + + call zero(s_field) + do i = element_halo_count(s_field), 1, -1 + do j = 1, halo_proc_count(s_field%mesh%element_halos(i)) + call set(s_field, halo_sends(s_field%mesh%element_halos(i), j), spread(float(i), 1, halo_send_count(s_field%mesh%element_halos(i), j))) + call set(s_field, halo_receives(s_field%mesh%element_halos(i), j), spread(-float(i), 1, halo_receive_count(s_field%mesh%element_halos(i), j))) + end do end do - end if - end subroutine calculate_element_universal_numbering + end subroutine calculate_element_halo + + subroutine calculate_element_ownership(s_field) + type(scalar_field), intent(inout) :: s_field + + integer :: i, nhalos + type(element_type), pointer :: shape + type(halo_type), pointer :: ele_halo + + assert(ele_count(s_field) > 0) + shape => ele_shape(s_field, 1) + if(shape%degree /= 0) then + FLExit("element_halo_ownership diagnostic requires a degree 0 mesh") + end if + assert(node_count(s_field) == ele_count(s_field)) + + nhalos = element_halo_count(s_field) + if(nhalos > 0) then + ele_halo => s_field%mesh%element_halos(nhalos) + do i = 1, node_count(s_field) + call set(s_field, i, float(halo_node_owner(ele_halo, i))) + end do + else + call set(s_field, 1.0) + end if + + end subroutine calculate_element_ownership + + subroutine calculate_element_universal_numbering(s_field) + type(scalar_field), intent(inout) :: s_field + + integer :: i, nhalos + type(element_type), pointer :: shape + type(halo_type), pointer :: ele_halo + + assert(ele_count(s_field) > 0) + shape => ele_shape(s_field, 1) + if(shape%degree /= 0) then + FLExit("element_universal_numbering diagnostic requires a degree 0 mesh") + end if + assert(node_count(s_field) == ele_count(s_field)) + + nhalos = element_halo_count(s_field) + if(nhalos > 0) then + ele_halo => s_field%mesh%element_halos(nhalos) + do i = 1, node_count(s_field) + call set(s_field, i, float(halo_universal_number(ele_halo, i))) + end do + else + do i = 1, node_count(s_field) + call set(s_field, i, float(i)) + end do + end if + + end subroutine calculate_element_universal_numbering end module parallel_diagnostics diff --git a/diagnostics/Python_Diagnostics.F90 b/diagnostics/Python_Diagnostics.F90 index c9300d5c53..724082f239 100644 --- a/diagnostics/Python_Diagnostics.F90 +++ b/diagnostics/Python_Diagnostics.F90 @@ -29,192 +29,192 @@ module python_diagnostics - use fldebug - use global_parameters, only : PYTHON_FUNC_LEN, OPTION_PATH_LEN - use spud - use fields - use python_state - use state_module + use fldebug + use global_parameters, only : PYTHON_FUNC_LEN, OPTION_PATH_LEN + use spud + use fields + use python_state + use state_module - implicit none + implicit none - private + private - public :: calculate_scalar_python_diagnostic, & - & calculate_vector_python_diagnostic, calculate_tensor_python_diagnostic + public :: calculate_scalar_python_diagnostic, & + & calculate_vector_python_diagnostic, calculate_tensor_python_diagnostic contains - subroutine calculate_scalar_python_diagnostic(states, state_index, s_field, current_time, dt) - !!< Set a field from Python - !!< So add the whole state and make a variable with the diagnostic - !!< field available to the interpreter + subroutine calculate_scalar_python_diagnostic(states, state_index, s_field, current_time, dt) + !!< Set a field from Python + !!< So add the whole state and make a variable with the diagnostic + !!< field available to the interpreter - type(state_type), dimension(:), target, intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - real, intent(in) :: current_time - real, intent(in) :: dt + type(state_type), dimension(:), target, intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + real, intent(in) :: current_time + real, intent(in) :: dt #ifdef HAVE_NUMPY - character(len = PYTHON_FUNC_LEN) :: pycode - character(len = 30) :: buffer - character(len = OPTION_PATH_LEN) :: material_phase_support - type(state_type), pointer :: this_state + character(len = PYTHON_FUNC_LEN) :: pycode + character(len = 30) :: buffer + character(len = OPTION_PATH_LEN) :: material_phase_support + type(state_type), pointer :: this_state - ewrite(2,*) 'in calculate_scalar_python_diagnostic' - ! Clean up to make sure that nothing else interferes - call python_reset() + ewrite(2,*) 'in calculate_scalar_python_diagnostic' + ! Clean up to make sure that nothing else interferes + call python_reset() - call get_option(trim(s_field%option_path)& + call get_option(trim(s_field%option_path)& //"/diagnostic/algorithm/material_phase_support",material_phase_support) - ewrite(2,*) 'material_phase_support: '//trim(material_phase_support) - select case(material_phase_support) - case("single") - call python_add_state(states(state_index)) + ewrite(2,*) 'material_phase_support: '//trim(material_phase_support) + select case(material_phase_support) + case("single") + call python_add_state(states(state_index)) - case ("multiple") - call python_add_states(states) - this_state=>states(state_index) - call python_run_string("state = states['"//trim(this_state%name)//"']") + case ("multiple") + call python_add_states(states) + this_state=>states(state_index) + call python_run_string("state = states['"//trim(this_state%name)//"']") - case default - ewrite(0,*) trim(material_phase_support)& + case default + ewrite(0,*) trim(material_phase_support)& //" is not a valid value for material_phase_support" - FLExit("Options file error") - end select + FLExit("Options file error") + end select - call python_run_string("field = state.scalar_fields['"//trim(s_field%name)//"']") - write(buffer,*) current_time - call python_run_string("time="//trim(buffer)) - write(buffer,*) dt - call python_run_string("dt="//trim(buffer)) + call python_run_string("field = state.scalar_fields['"//trim(s_field%name)//"']") + write(buffer,*) current_time + call python_run_string("time="//trim(buffer)) + write(buffer,*) dt + call python_run_string("dt="//trim(buffer)) - ! And finally run the user's codey - call get_option(trim(s_field%option_path)//"/diagnostic/algorithm",pycode) - call python_run_string(trim(pycode)) + ! And finally run the user's codey + call get_option(trim(s_field%option_path)//"/diagnostic/algorithm",pycode) + call python_run_string(trim(pycode)) - ! Cleanup - call python_reset() + ! Cleanup + call python_reset() #else - FLAbort("Python diagnostic fields require NumPy, which cannot be located.") + FLAbort("Python diagnostic fields require NumPy, which cannot be located.") #endif - ewrite(2,*) 'leaving calculate_scalar_python_diagnostic' + ewrite(2,*) 'leaving calculate_scalar_python_diagnostic' - end subroutine calculate_scalar_python_diagnostic + end subroutine calculate_scalar_python_diagnostic - subroutine calculate_vector_python_diagnostic(states, state_index, v_field, current_time, dt) - !!< Set a field from Python - !!< So add the whole state and make a variable with the diagnostic - !!< field available to the interpreter + subroutine calculate_vector_python_diagnostic(states, state_index, v_field, current_time, dt) + !!< Set a field from Python + !!< So add the whole state and make a variable with the diagnostic + !!< field available to the interpreter - type(state_type), dimension(:), target, intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - real, intent(in) :: current_time - real, intent(in) :: dt + type(state_type), dimension(:), target, intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + real, intent(in) :: current_time + real, intent(in) :: dt #ifdef HAVE_NUMPY - character(len = PYTHON_FUNC_LEN) :: pycode - character(len = 30) :: buffer - character(len = OPTION_PATH_LEN) :: material_phase_support - type(state_type), pointer :: this_state + character(len = PYTHON_FUNC_LEN) :: pycode + character(len = 30) :: buffer + character(len = OPTION_PATH_LEN) :: material_phase_support + type(state_type), pointer :: this_state - ! Clean up to make sure that nothing else interferes - call python_reset() + ! Clean up to make sure that nothing else interferes + call python_reset() - call get_option(trim(v_field%option_path)& + call get_option(trim(v_field%option_path)& //"/diagnostic/algorithm/material_phase_support",material_phase_support) - select case(material_phase_support) - case("single") - call python_add_state(states(state_index)) + select case(material_phase_support) + case("single") + call python_add_state(states(state_index)) - case ("multiple") - call python_add_states(states) - this_state=>states(state_index) - call python_run_string("state = states['"//trim(this_state%name)//"']") + case ("multiple") + call python_add_states(states) + this_state=>states(state_index) + call python_run_string("state = states['"//trim(this_state%name)//"']") - case default - ewrite(0,*) trim(material_phase_support)& + case default + ewrite(0,*) trim(material_phase_support)& //" is not a valid value for material_phase_support" - FLExit("Options file error") - end select + FLExit("Options file error") + end select - call python_run_string("field = state.vector_fields['"//trim(v_field%name)//"']") - write(buffer,*) current_time - call python_run_string("time="//trim(buffer)) - write(buffer,*) dt - call python_run_string("dt="//trim(buffer)) + call python_run_string("field = state.vector_fields['"//trim(v_field%name)//"']") + write(buffer,*) current_time + call python_run_string("time="//trim(buffer)) + write(buffer,*) dt + call python_run_string("dt="//trim(buffer)) - ! And finally run the user's code - call get_option(trim(v_field%option_path)//"/diagnostic/algorithm",pycode) - call python_run_string(trim(pycode)) + ! And finally run the user's code + call get_option(trim(v_field%option_path)//"/diagnostic/algorithm",pycode) + call python_run_string(trim(pycode)) - ! Cleanup - call python_reset() + ! Cleanup + call python_reset() #else - FLAbort("Python diagnostic fields require NumPy, which cannot be located.") + FLAbort("Python diagnostic fields require NumPy, which cannot be located.") #endif - end subroutine calculate_vector_python_diagnostic + end subroutine calculate_vector_python_diagnostic - subroutine calculate_tensor_python_diagnostic(states, state_index, t_field, current_time, dt) - !!< Set a field from Python - !!< So add the whole state and make a variable with the diagnostic - !!< field available to the interpreter + subroutine calculate_tensor_python_diagnostic(states, state_index, t_field, current_time, dt) + !!< Set a field from Python + !!< So add the whole state and make a variable with the diagnostic + !!< field available to the interpreter - type(state_type), dimension(:), target, intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - real, intent(in) :: current_time - real, intent(in) :: dt + type(state_type), dimension(:), target, intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + real, intent(in) :: current_time + real, intent(in) :: dt #ifdef HAVE_NUMPY - character(len = PYTHON_FUNC_LEN) :: pycode - character(len = 30) :: buffer - character(len = OPTION_PATH_LEN) :: material_phase_support - type(state_type), pointer :: this_state + character(len = PYTHON_FUNC_LEN) :: pycode + character(len = 30) :: buffer + character(len = OPTION_PATH_LEN) :: material_phase_support + type(state_type), pointer :: this_state - ! Clean up to make sure that nothing else interferes - call python_reset() + ! Clean up to make sure that nothing else interferes + call python_reset() - call get_option(trim(t_field%option_path)& + call get_option(trim(t_field%option_path)& //"/diagnostic/algorithm/material_phase_support",material_phase_support) - select case(material_phase_support) - case("single") - call python_add_state(states(state_index)) + select case(material_phase_support) + case("single") + call python_add_state(states(state_index)) - case ("multiple") - call python_add_states(states) - this_state=>states(state_index) - call python_run_string("state = states['"//trim(this_state%name)//"']") + case ("multiple") + call python_add_states(states) + this_state=>states(state_index) + call python_run_string("state = states['"//trim(this_state%name)//"']") - case default - ewrite(0,*) trim(material_phase_support)& + case default + ewrite(0,*) trim(material_phase_support)& //" is not a valid value for material_phase_support" - FLExit("Options file error") - end select + FLExit("Options file error") + end select - call python_run_string("field = state.tensor_fields['"//trim(t_field%name)//"']") - write(buffer,*) current_time - call python_run_string("time="//trim(buffer)) - write(buffer,*) dt - call python_run_string("dt="//trim(buffer)) + call python_run_string("field = state.tensor_fields['"//trim(t_field%name)//"']") + write(buffer,*) current_time + call python_run_string("time="//trim(buffer)) + write(buffer,*) dt + call python_run_string("dt="//trim(buffer)) - ! And finally run the user's code - call get_option(trim(t_field%option_path)//"/diagnostic/algorithm",pycode) - call python_run_string(trim(pycode)) + ! And finally run the user's code + call get_option(trim(t_field%option_path)//"/diagnostic/algorithm",pycode) + call python_run_string(trim(pycode)) - ! Cleanup - call python_reset() + ! Cleanup + call python_reset() #else - FLAbort("Python diagnostic fields require NumPy, which cannot be located.") + FLAbort("Python diagnostic fields require NumPy, which cannot be located.") #endif - end subroutine calculate_tensor_python_diagnostic + end subroutine calculate_tensor_python_diagnostic end module python_diagnostics diff --git a/diagnostics/Simple_Diagnostics.F90 b/diagnostics/Simple_Diagnostics.F90 index 04d4e60543..355e4ed15d 100644 --- a/diagnostics/Simple_Diagnostics.F90 +++ b/diagnostics/Simple_Diagnostics.F90 @@ -29,562 +29,562 @@ module simple_diagnostics - use fldebug - use global_parameters, only : timestep, OPTION_PATH_LEN - use spud - use futils - use parallel_tools - use fields - use state_module - use field_options - use diagnostic_source_fields - use vtk_cache_module - use initialise_fields_module - use state_fields_module - use pickers_inquire - use surface_integrals - - implicit none - - interface initialise_diagnostic_from_checkpoint - module procedure initialise_diagnostic_scalar_from_checkpoint, & - initialise_diagnostic_vector_from_checkpoint, & - initialise_diagnostic_tensor_from_checkpoint - end interface - - private - - public :: calculate_temporalmax_scalar, calculate_temporalmax_vector, calculate_temporalmin, calculate_l2norm, & - calculate_time_averaged_scalar, calculate_time_averaged_vector, & - calculate_time_averaged_scalar_squared, & - calculate_time_averaged_vector_times_scalar, calculate_period_averaged_scalar, & - calculate_subtract_average, calculate_subtract_point_value, calculate_subtract_surface_average - - ! for the period_averaged_scalar routine - real, save :: last_output_time - integer, save :: n_times_added + use fldebug + use global_parameters, only : timestep, OPTION_PATH_LEN + use spud + use futils + use parallel_tools + use fields + use state_module + use field_options + use diagnostic_source_fields + use vtk_cache_module + use initialise_fields_module + use state_fields_module + use pickers_inquire + use surface_integrals + + implicit none + + interface initialise_diagnostic_from_checkpoint + module procedure initialise_diagnostic_scalar_from_checkpoint, & + initialise_diagnostic_vector_from_checkpoint, & + initialise_diagnostic_tensor_from_checkpoint + end interface + + private + + public :: calculate_temporalmax_scalar, calculate_temporalmax_vector, calculate_temporalmin, calculate_l2norm, & + calculate_time_averaged_scalar, calculate_time_averaged_vector, & + calculate_time_averaged_scalar_squared, & + calculate_time_averaged_vector_times_scalar, calculate_period_averaged_scalar, & + calculate_subtract_average, calculate_subtract_point_value, calculate_subtract_surface_average + + ! for the period_averaged_scalar routine + real, save :: last_output_time + integer, save :: n_times_added contains - subroutine calculate_temporalmax_scalar(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: position - character(len = OPTION_PATH_LEN) :: path - integer :: i - real :: val, current_time, spin_up_time - source_field => scalar_source_field(state, s_field) - assert(node_count(s_field) == node_count(source_field)) - position => extract_vector_field(state, "Coordinate") - - if(timestep==0) then - path=trim(complete_field_path(s_field%option_path)) // "/algorithm/initial_condition" - if (have_option(trim(path))) then - call zero(s_field) - call initialise_field_over_regions(s_field, path, position) - else - call set(s_field,source_field) - end if - return - end if - if(have_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time")) then - call get_option("/timestepping/current_time", current_time) - call get_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time", spin_up_time) - if (current_time vector_source_field(state, v_field) - assert(node_count(v_field) == node_count(source_field)) - position => extract_vector_field(state, "Coordinate") - - if(timestep==0) then - path=trim(complete_field_path(v_field%option_path)) // "/algorithm/initial_condition" - if (have_option(trim(path))) then - call zero(v_field) - call initialise_field_over_regions(v_field, path, position) - else - call set(v_field,source_field) - end if - return - end if - if(have_option(trim(complete_field_path(v_field%option_path)) // "/algorithm/spin_up_time")) then - call get_option("/timestepping/current_time", current_time) - call get_option(trim(complete_field_path(v_field%option_path)) // "/algorithm/spin_up_time", spin_up_time) - if (current_time scalar_source_field(state, s_field) + assert(node_count(s_field) == node_count(source_field)) + position => extract_vector_field(state, "Coordinate") + + if(timestep==0) then + path=trim(complete_field_path(s_field%option_path)) // "/algorithm/initial_condition" + if (have_option(trim(path))) then + call zero(s_field) + call initialise_field_over_regions(s_field, path, position) + else + call set(s_field,source_field) + end if + return + end if + if(have_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time")) then + call get_option("/timestepping/current_time", current_time) + call get_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time", spin_up_time) + if (current_time vector_source_field(state, v_field) + assert(node_count(v_field) == node_count(source_field)) + position => extract_vector_field(state, "Coordinate") + + if(timestep==0) then + path=trim(complete_field_path(v_field%option_path)) // "/algorithm/initial_condition" + if (have_option(trim(path))) then + call zero(v_field) + call initialise_field_over_regions(v_field, path, position) + else + call set(v_field,source_field) + end if + return + end if + if(have_option(trim(complete_field_path(v_field%option_path)) // "/algorithm/spin_up_time")) then + call get_option("/timestepping/current_time", current_time) + call get_option(trim(complete_field_path(v_field%option_path)) // "/algorithm/spin_up_time", spin_up_time) + if (current_time scalar_source_field(state, s_field) - assert(node_count(s_field) == node_count(source_field)) - position => extract_vector_field(state, "Coordinate") - - if(timestep==0) then - path=trim(complete_field_path(s_field%option_path)) // "/algorithm/initial_condition" - if (have_option(trim(path))) then - call zero(s_field) - call initialise_field_over_regions(s_field, path, position) - else - call set(s_field,source_field) - end if - return - end if - if(have_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time")) then - call get_option("/timestepping/current_time", current_time) - call get_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time", spin_up_time) - if (current_time scalar_source_field(state, s_field) + assert(node_count(s_field) == node_count(source_field)) + position => extract_vector_field(state, "Coordinate") + + if(timestep==0) then + path=trim(complete_field_path(s_field%option_path)) // "/algorithm/initial_condition" + if (have_option(trim(path))) then + call zero(s_field) + call initialise_field_over_regions(s_field, path, position) + else + call set(s_field,source_field) + end if + return + end if + if(have_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time")) then + call get_option("/timestepping/current_time", current_time) + call get_option(trim(complete_field_path(s_field%option_path)) // "/algorithm/spin_up_time", spin_up_time) + if (current_time vector_source_field(state, s_field) - allocate(val(source_field%dim)) + subroutine calculate_l2norm(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + type(vector_field), pointer :: source_field + integer :: i,j + real, dimension(:), allocatable :: val + real :: res + source_field => vector_source_field(state, s_field) + allocate(val(source_field%dim)) assert(node_count(s_field) == node_count(source_field)) do i=1,node_count(s_field) - val = node_val(source_field,i) - - res = 0 - do j=1,source_field%dim - res=res+val(j)**2 - end do - res=sqrt(res) - call set(s_field,i,res) - end do - deallocate(val) - end subroutine calculate_l2norm - - subroutine calculate_time_averaged_scalar(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(scalar_field), pointer :: source_field - real :: a, b, spin_up_time, current_time, dt - integer :: stat - logical :: absolute_vals=.false. - - if (timestep==0) then - last_output_time = 0.0 - call initialise_diagnostic_from_checkpoint(s_field) - return - end if - - call get_option("/timestepping/current_time", current_time) - call get_option("/timestepping/timestep", dt) - - absolute_vals=have_option(trim(s_field%option_path)//"/diagnostic/algorithm/absolute_values") - call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) - if (stat /=0) spin_up_time=0. - - source_field => scalar_source_field(state, s_field) - if(absolute_vals) source_field%val = abs(source_field%val) - - if (current_time>spin_up_time) then - a = (current_time-spin_up_time-dt)/(current_time-spin_up_time) - b = dt/(current_time-spin_up_time) - ! s_field = a*s_field + b*source_field - call scale(s_field, a) - call addto(s_field, source_field, b) - else - call set(s_field, source_field) - end if - end subroutine calculate_time_averaged_scalar - - subroutine calculate_period_averaged_scalar(state, s_field) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field - - type(scalar_field) :: cumulative_value - type(scalar_field), pointer :: source_field, running_tot - real :: current_time, averaging_period, nt - integer :: stat - - if (timestep==0) then - last_output_time = 0.0 - n_times_added = 0 - running_tot => extract_scalar_field(state,"AveCumulativeValue",stat) - if (stat .ne. 0) then - ewrite(-1,*) "You haven't set up a field call AveCumulativeValue for the time-averaged scalar diagnostic to use." - ewrite(-1,*) "I'm going to make one for you, but this will *not* work with adaptivity and checkpointing" - ewrite(-1,*) "If you need these features, stop the run and add a scalar field called AveCumulativeValue as a diagnostic, set via internal function" - call allocate(cumulative_value, s_field%mesh, "AveCumulativeValue") - call zero(cumulative_value) - call insert(state, cumulative_value, cumulative_value%name) - call deallocate(cumulative_value) - call initialise_diagnostic_from_checkpoint(s_field) + val = node_val(source_field,i) + + res = 0 + do j=1,source_field%dim + res=res+val(j)**2 + end do + res=sqrt(res) + call set(s_field,i,res) + end do + deallocate(val) + end subroutine calculate_l2norm + + subroutine calculate_time_averaged_scalar(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + + type(scalar_field), pointer :: source_field + real :: a, b, spin_up_time, current_time, dt + integer :: stat + logical :: absolute_vals=.false. + + if (timestep==0) then + last_output_time = 0.0 + call initialise_diagnostic_from_checkpoint(s_field) + return + end if + + call get_option("/timestepping/current_time", current_time) + call get_option("/timestepping/timestep", dt) + + absolute_vals=have_option(trim(s_field%option_path)//"/diagnostic/algorithm/absolute_values") + call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) + if (stat /=0) spin_up_time=0. + + source_field => scalar_source_field(state, s_field) + if(absolute_vals) source_field%val = abs(source_field%val) + + if (current_time>spin_up_time) then + a = (current_time-spin_up_time-dt)/(current_time-spin_up_time) + b = dt/(current_time-spin_up_time) + ! s_field = a*s_field + b*source_field + call scale(s_field, a) + call addto(s_field, source_field, b) + else + call set(s_field, source_field) + end if + end subroutine calculate_time_averaged_scalar + + subroutine calculate_period_averaged_scalar(state, s_field) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field + + type(scalar_field) :: cumulative_value + type(scalar_field), pointer :: source_field, running_tot + real :: current_time, averaging_period, nt + integer :: stat + + if (timestep==0) then + last_output_time = 0.0 + n_times_added = 0 + running_tot => extract_scalar_field(state,"AveCumulativeValue",stat) + if (stat .ne. 0) then + ewrite(-1,*) "You haven't set up a field call AveCumulativeValue for the time-averaged scalar diagnostic to use." + ewrite(-1,*) "I'm going to make one for you, but this will *not* work with adaptivity and checkpointing" + ewrite(-1,*) "If you need these features, stop the run and add a scalar field called AveCumulativeValue as a diagnostic, set via internal function" + call allocate(cumulative_value, s_field%mesh, "AveCumulativeValue") + call zero(cumulative_value) + call insert(state, cumulative_value, cumulative_value%name) + call deallocate(cumulative_value) + call initialise_diagnostic_from_checkpoint(s_field) + end if + return + end if + + call get_option("/timestepping/current_time", current_time) + call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/averaging_period",averaging_period) + + source_field => scalar_source_field(state, s_field) + running_tot => extract_scalar_field(state,"AveCumulativeValue") + if (current_time < averaging_period*(floor(last_output_time / averaging_period)+1.)) then + call addto(running_tot,source_field) + n_times_added = n_times_added+1 + else + nt = n_times_added + call scale(running_tot, 1./nt) + call set(s_field,running_tot) + last_output_time = current_time + n_times_added = 0 + call zero(running_tot) + call addto(running_tot,source_field) + n_times_added = n_times_added+1 + end if + end subroutine calculate_period_averaged_scalar + + subroutine calculate_time_averaged_vector(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field + + type(vector_field), pointer :: source_field + real :: a, b, spin_up_time, current_time, dt + integer :: stat + logical :: absolute_vals + + if (timestep==0) then + call initialise_diagnostic_from_checkpoint(v_field) + return + end if + + call get_option("/timestepping/current_time", current_time) + call get_option("/timestepping/timestep", dt) + + absolute_vals=have_option(trim(v_field%option_path)//"/diagnostic/algorithm/absolute_values") + call get_option(trim(v_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) + if (stat /=0) spin_up_time=0. + source_field => vector_source_field(state, v_field) + if(absolute_vals) source_field%val = abs(source_field%val) + + if (current_time>spin_up_time) then + a = (current_time-spin_up_time-dt)/(current_time-spin_up_time); b = dt/(current_time-spin_up_time) + ! v_field = a*v_field + b*source_field + call scale(v_field, a) + call addto(v_field, source_field, b) + else + call set(v_field, source_field) + end if + end subroutine calculate_time_averaged_vector + + subroutine calculate_time_averaged_scalar_squared(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + + type(scalar_field), pointer :: source_field + type(scalar_field) :: l_field + real :: a, b, spin_up_time, current_time, dt + integer :: stat + + if (timestep==0) then + call initialise_diagnostic_from_checkpoint(s_field) + return + end if + + call get_option("/timestepping/current_time", current_time) + call get_option("/timestepping/timestep", dt) + + call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) + if (stat /=0) spin_up_time=0. + source_field => scalar_source_field(state, s_field) + + call allocate(l_field, source_field%mesh, "LocalField") + call set(l_field, source_field) + call scale(l_field, source_field) + + if (current_time>spin_up_time) then + a = (current_time-spin_up_time-dt)/(current_time-spin_up_time); b = dt/(current_time-spin_up_time) + ! s_field = a*s_field + b*source_field**2 + call scale(s_field, a) + call addto(s_field, l_field, b) + else + call set(s_field, l_field) + end if + call deallocate(l_field) + end subroutine calculate_time_averaged_scalar_squared + + subroutine calculate_time_averaged_vector_times_scalar(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field + + type(vector_field), pointer :: v_source_field + type(scalar_field), pointer :: s_source_field + type(vector_field) :: l_field + real :: a, b, spin_up_time, current_time, dt + integer :: stat + + if (timestep==0) then + call initialise_diagnostic_from_checkpoint(v_field) + return + end if + + call get_option("/timestepping/current_time", current_time) + call get_option("/timestepping/timestep", dt) + + call get_option(trim(v_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) + if (stat /=0) spin_up_time=0. + v_source_field => vector_source_field(state, v_field, index=1) + s_source_field => scalar_source_field(state, v_field, index=2) + + call allocate(l_field, v_source_field%dim, v_source_field%mesh, "LocalField") + call set(l_field, v_source_field) + call scale(l_field, s_source_field) + + if (current_time>spin_up_time) then + a = (current_time-spin_up_time-dt)/(current_time-spin_up_time); b = dt/(current_time-spin_up_time) + ! v_field = a*v_field + b*v_source_field*s_source_field + call scale(v_field, a) + call addto(v_field, l_field, b) + else + call set(v_field, l_field) end if - return - end if - - call get_option("/timestepping/current_time", current_time) - call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/averaging_period",averaging_period) - - source_field => scalar_source_field(state, s_field) - running_tot => extract_scalar_field(state,"AveCumulativeValue") - if (current_time < averaging_period*(floor(last_output_time / averaging_period)+1.)) then - call addto(running_tot,source_field) - n_times_added = n_times_added+1 - else - nt = n_times_added - call scale(running_tot, 1./nt) - call set(s_field,running_tot) - last_output_time = current_time - n_times_added = 0 - call zero(running_tot) - call addto(running_tot,source_field) - n_times_added = n_times_added+1 - end if - end subroutine calculate_period_averaged_scalar - - subroutine calculate_time_averaged_vector(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field - - type(vector_field), pointer :: source_field - real :: a, b, spin_up_time, current_time, dt - integer :: stat - logical :: absolute_vals - - if (timestep==0) then - call initialise_diagnostic_from_checkpoint(v_field) - return - end if - - call get_option("/timestepping/current_time", current_time) - call get_option("/timestepping/timestep", dt) - - absolute_vals=have_option(trim(v_field%option_path)//"/diagnostic/algorithm/absolute_values") - call get_option(trim(v_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) - if (stat /=0) spin_up_time=0. - source_field => vector_source_field(state, v_field) - if(absolute_vals) source_field%val = abs(source_field%val) - - if (current_time>spin_up_time) then - a = (current_time-spin_up_time-dt)/(current_time-spin_up_time); b = dt/(current_time-spin_up_time) - ! v_field = a*v_field + b*source_field - call scale(v_field, a) - call addto(v_field, source_field, b) - else - call set(v_field, source_field) - end if - end subroutine calculate_time_averaged_vector - - subroutine calculate_time_averaged_scalar_squared(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(scalar_field), pointer :: source_field - type(scalar_field) :: l_field - real :: a, b, spin_up_time, current_time, dt - integer :: stat - - if (timestep==0) then - call initialise_diagnostic_from_checkpoint(s_field) - return - end if - - call get_option("/timestepping/current_time", current_time) - call get_option("/timestepping/timestep", dt) - - call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) - if (stat /=0) spin_up_time=0. - source_field => scalar_source_field(state, s_field) - - call allocate(l_field, source_field%mesh, "LocalField") - call set(l_field, source_field) - call scale(l_field, source_field) - - if (current_time>spin_up_time) then - a = (current_time-spin_up_time-dt)/(current_time-spin_up_time); b = dt/(current_time-spin_up_time) - ! s_field = a*s_field + b*source_field**2 - call scale(s_field, a) - call addto(s_field, l_field, b) - else - call set(s_field, l_field) - end if - call deallocate(l_field) - end subroutine calculate_time_averaged_scalar_squared - - subroutine calculate_time_averaged_vector_times_scalar(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field - - type(vector_field), pointer :: v_source_field - type(scalar_field), pointer :: s_source_field - type(vector_field) :: l_field - real :: a, b, spin_up_time, current_time, dt - integer :: stat - - if (timestep==0) then - call initialise_diagnostic_from_checkpoint(v_field) - return - end if - - call get_option("/timestepping/current_time", current_time) - call get_option("/timestepping/timestep", dt) - - call get_option(trim(v_field%option_path)//"/diagnostic/algorithm/spin_up_time", spin_up_time, stat) - if (stat /=0) spin_up_time=0. - v_source_field => vector_source_field(state, v_field, index=1) - s_source_field => scalar_source_field(state, v_field, index=2) - - call allocate(l_field, v_source_field%dim, v_source_field%mesh, "LocalField") - call set(l_field, v_source_field) - call scale(l_field, s_source_field) - - if (current_time>spin_up_time) then - a = (current_time-spin_up_time-dt)/(current_time-spin_up_time); b = dt/(current_time-spin_up_time) - ! v_field = a*v_field + b*v_source_field*s_source_field - call scale(v_field, a) - call addto(v_field, l_field, b) - else - call set(v_field, l_field) - end if - call deallocate(l_field) - end subroutine calculate_time_averaged_vector_times_scalar - - subroutine calculate_subtract_average(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(vector_field), pointer :: positions - type(scalar_field), pointer :: source_field - real :: average - integer :: stat - - source_field => scalar_source_field(state, s_field) - call remap_field(source_field, s_field, stat) - if (stat/=0) then - FLExit("In subtract_average diagnostic, the source field is on a different mesh and cannot be remapped.") - end if - - positions => extract_vector_field(state, "Coordinate") - average = field_integral(s_field, positions) / mesh_integral(positions) - call addto(s_field, -average) - - end subroutine calculate_subtract_average - - subroutine calculate_subtract_point_value(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(vector_field), pointer :: positions - type(scalar_field), pointer :: source_field - real, dimension(:), allocatable :: coords, lcoords - real :: point_value - integer :: stat, ele - logical :: found - - source_field => scalar_source_field(state, s_field) - call remap_field(source_field, s_field, stat) - if (stat/=0) then - FLExit("In subtract_point_value diagnostic, the source field is on a different mesh and cannot be remapped.") - end if - - positions => extract_vector_field(state, "Coordinate") - allocate(coords(1:positions%dim), lcoords(1:positions%dim+1)) - call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/coordinates", coords) - call picker_inquire(positions, coords, ele, lcoords, global=.true.) - found = ele>0 - if (found) then - point_value = eval_field(ele, s_field, lcoords) - else - point_value = 0.0 - end if - deallocate(coords, lcoords) - - if (IsParallel()) then - ! picker_inquire with global=.true., is a bit dumb: it negotiates to ensure - ! only one processes returns with ele>0 - but then throws away the winning - ! process number, so we can't do a bcast - use allsum instead - call allsum(point_value) - ! more importantly we don't know whether any process has found this location - ! so let's confirm that here - call allor(found) - end if - - if (.not. found) then - FLExit("In subtract_point_value, specified coordinates not found within domain") - end if - - call addto(s_field, -point_value) - - end subroutine calculate_subtract_point_value - - subroutine calculate_subtract_surface_average(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - - type(vector_field), pointer :: positions - type(scalar_field), pointer :: source_field - character(len = OPTION_PATH_LEN) :: option_path - integer, dimension(:), allocatable:: surface_ids - integer, dimension(2) :: shape_option - real :: surface_average - integer :: stat - - source_field => scalar_source_field(state, s_field) - call remap_field(source_field, s_field, stat) - if (stat/=0) then - FLExit("In subtract_surface_average diagnostic, the source field is on a different mesh and cannot be remapped.") - end if - - option_path = trim(s_field%option_path)//"/diagnostic/algorithm" - shape_option=option_shape(trim(option_path)//"/surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option(trim(option_path)//"/surface_ids", surface_ids) - - positions => extract_vector_field(state, "Coordinate") - surface_average = surface_integral(source_field, positions, surface_ids, normalise=.True.) - call addto(s_field, -surface_average) - - end subroutine calculate_subtract_surface_average - - subroutine initialise_diagnostic_scalar_from_checkpoint(s_field) - type(scalar_field), intent(inout) :: s_field - - type(scalar_field), pointer :: read_field - character(len = OPTION_PATH_LEN) :: filename - logical :: checkpoint_exists - integer :: i - integer :: stat - - stat = 1 - - do i = 1, option_count("/geometry/mesh") - if(have_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name")) then - call get_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name", filename, stat) - ewrite(2,*) "mesh from file: ", trim(filename) + call deallocate(l_field) + end subroutine calculate_time_averaged_vector_times_scalar + + subroutine calculate_subtract_average(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + + type(vector_field), pointer :: positions + type(scalar_field), pointer :: source_field + real :: average + integer :: stat + + source_field => scalar_source_field(state, s_field) + call remap_field(source_field, s_field, stat) + if (stat/=0) then + FLExit("In subtract_average diagnostic, the source field is on a different mesh and cannot be remapped.") end if - end do - if (stat /= 0) return - - if(isparallel()) then - filename = parallel_filename(trim_file_extension(filename), ".vtu") - else - filename = trim(filename) // ".vtu" - end if - inquire(file=trim(filename), exist=checkpoint_exists) - - if (checkpoint_exists) then - read_field => vtk_cache_read_scalar_field(filename, trim(s_field%name)) - call set(s_field, read_field) - end if - - end subroutine initialise_diagnostic_scalar_from_checkpoint - - subroutine initialise_diagnostic_vector_from_checkpoint(v_field) - type(vector_field), intent(inout) :: v_field - - type(vector_field), pointer :: read_field - character(len = OPTION_PATH_LEN) :: filename - logical :: checkpoint_exists - integer :: i - integer :: stat - - stat = 1 - - do i = 1, option_count("/geometry/mesh") - if(have_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name")) then - call get_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name", filename , stat) - ewrite(2,*) "mesh from file: ", trim(filename) + + positions => extract_vector_field(state, "Coordinate") + average = field_integral(s_field, positions) / mesh_integral(positions) + call addto(s_field, -average) + + end subroutine calculate_subtract_average + + subroutine calculate_subtract_point_value(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + + type(vector_field), pointer :: positions + type(scalar_field), pointer :: source_field + real, dimension(:), allocatable :: coords, lcoords + real :: point_value + integer :: stat, ele + logical :: found + + source_field => scalar_source_field(state, s_field) + call remap_field(source_field, s_field, stat) + if (stat/=0) then + FLExit("In subtract_point_value diagnostic, the source field is on a different mesh and cannot be remapped.") + end if + + positions => extract_vector_field(state, "Coordinate") + allocate(coords(1:positions%dim), lcoords(1:positions%dim+1)) + call get_option(trim(s_field%option_path)//"/diagnostic/algorithm/coordinates", coords) + call picker_inquire(positions, coords, ele, lcoords, global=.true.) + found = ele>0 + if (found) then + point_value = eval_field(ele, s_field, lcoords) + else + point_value = 0.0 + end if + deallocate(coords, lcoords) + + if (IsParallel()) then + ! picker_inquire with global=.true., is a bit dumb: it negotiates to ensure + ! only one processes returns with ele>0 - but then throws away the winning + ! process number, so we can't do a bcast - use allsum instead + call allsum(point_value) + ! more importantly we don't know whether any process has found this location + ! so let's confirm that here + call allor(found) + end if + + if (.not. found) then + FLExit("In subtract_point_value, specified coordinates not found within domain") + end if + + call addto(s_field, -point_value) + + end subroutine calculate_subtract_point_value + + subroutine calculate_subtract_surface_average(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + + type(vector_field), pointer :: positions + type(scalar_field), pointer :: source_field + character(len = OPTION_PATH_LEN) :: option_path + integer, dimension(:), allocatable:: surface_ids + integer, dimension(2) :: shape_option + real :: surface_average + integer :: stat + + source_field => scalar_source_field(state, s_field) + call remap_field(source_field, s_field, stat) + if (stat/=0) then + FLExit("In subtract_surface_average diagnostic, the source field is on a different mesh and cannot be remapped.") + end if + + option_path = trim(s_field%option_path)//"/diagnostic/algorithm" + shape_option=option_shape(trim(option_path)//"/surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option(trim(option_path)//"/surface_ids", surface_ids) + + positions => extract_vector_field(state, "Coordinate") + surface_average = surface_integral(source_field, positions, surface_ids, normalise=.True.) + call addto(s_field, -surface_average) + + end subroutine calculate_subtract_surface_average + + subroutine initialise_diagnostic_scalar_from_checkpoint(s_field) + type(scalar_field), intent(inout) :: s_field + + type(scalar_field), pointer :: read_field + character(len = OPTION_PATH_LEN) :: filename + logical :: checkpoint_exists + integer :: i + integer :: stat + + stat = 1 + + do i = 1, option_count("/geometry/mesh") + if(have_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name")) then + call get_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name", filename, stat) + ewrite(2,*) "mesh from file: ", trim(filename) + end if + end do + if (stat /= 0) return + + if(isparallel()) then + filename = parallel_filename(trim_file_extension(filename), ".vtu") + else + filename = trim(filename) // ".vtu" end if - end do - if (stat /= 0) return - - if(isparallel()) then - filename = parallel_filename(trim_file_extension(filename), ".vtu") - else - filename = trim(filename) // ".vtu" - end if - inquire(file=trim(filename), exist=checkpoint_exists) - - if (checkpoint_exists) then - read_field => vtk_cache_read_vector_field(filename, trim(v_field%name)) - call set(v_field, read_field) - end if - - end subroutine initialise_diagnostic_vector_from_checkpoint - - subroutine initialise_diagnostic_tensor_from_checkpoint(t_field) - type(tensor_field), intent(inout) :: t_field - - type(tensor_field), pointer :: read_field - character(len = OPTION_PATH_LEN) :: filename - logical :: checkpoint_exists - integer :: i - integer :: stat - - stat = 1 - - do i = 1, option_count("/geometry/mesh") - if(have_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name")) then - call get_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name", filename, stat) - ewrite(2,*) "mesh from file: ", trim(filename) + inquire(file=trim(filename), exist=checkpoint_exists) + + if (checkpoint_exists) then + read_field => vtk_cache_read_scalar_field(filename, trim(s_field%name)) + call set(s_field, read_field) end if - end do - if (stat /= 0) return - if(isparallel()) then - filename = parallel_filename(trim_file_extension(filename), ".vtu") - else - filename = trim(filename) // ".vtu" - end if - inquire(file=trim(filename), exist=checkpoint_exists) + end subroutine initialise_diagnostic_scalar_from_checkpoint + + subroutine initialise_diagnostic_vector_from_checkpoint(v_field) + type(vector_field), intent(inout) :: v_field + + type(vector_field), pointer :: read_field + character(len = OPTION_PATH_LEN) :: filename + logical :: checkpoint_exists + integer :: i + integer :: stat + + stat = 1 + + do i = 1, option_count("/geometry/mesh") + if(have_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name")) then + call get_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name", filename , stat) + ewrite(2,*) "mesh from file: ", trim(filename) + end if + end do + if (stat /= 0) return + + if(isparallel()) then + filename = parallel_filename(trim_file_extension(filename), ".vtu") + else + filename = trim(filename) // ".vtu" + end if + inquire(file=trim(filename), exist=checkpoint_exists) - if (checkpoint_exists) then - read_field => vtk_cache_read_tensor_field(filename, trim(t_field%name)) - call set(t_field, read_field) - end if + if (checkpoint_exists) then + read_field => vtk_cache_read_vector_field(filename, trim(v_field%name)) + call set(v_field, read_field) + end if + + end subroutine initialise_diagnostic_vector_from_checkpoint + + subroutine initialise_diagnostic_tensor_from_checkpoint(t_field) + type(tensor_field), intent(inout) :: t_field + + type(tensor_field), pointer :: read_field + character(len = OPTION_PATH_LEN) :: filename + logical :: checkpoint_exists + integer :: i + integer :: stat + + stat = 1 + + do i = 1, option_count("/geometry/mesh") + if(have_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name")) then + call get_option("/geometry/mesh["//int2str(i)//"]/from_file/file_name", filename, stat) + ewrite(2,*) "mesh from file: ", trim(filename) + end if + end do + if (stat /= 0) return + + if(isparallel()) then + filename = parallel_filename(trim_file_extension(filename), ".vtu") + else + filename = trim(filename) // ".vtu" + end if + inquire(file=trim(filename), exist=checkpoint_exists) + + if (checkpoint_exists) then + read_field => vtk_cache_read_tensor_field(filename, trim(t_field%name)) + call set(t_field, read_field) + end if - end subroutine initialise_diagnostic_tensor_from_checkpoint + end subroutine initialise_diagnostic_tensor_from_checkpoint - end module simple_diagnostics +end module simple_diagnostics diff --git a/diagnostics/Surface.F90 b/diagnostics/Surface.F90 index 472b5aeef8..5774bbff03 100644 --- a/diagnostics/Surface.F90 +++ b/diagnostics/Surface.F90 @@ -29,80 +29,80 @@ module surface_diagnostics - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use spud - use fields - use state_module - use field_options - use diagnostic_source_fields - use sediment, only: surface_horizontal_divergence - use surface_integrals + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use spud + use fields + use state_module + use field_options + use diagnostic_source_fields + use sediment, only: surface_horizontal_divergence + use surface_integrals - implicit none + implicit none - private + private - public :: calculate_grad_normal, calculate_surface_horizontal_divergence + public :: calculate_grad_normal, calculate_surface_horizontal_divergence contains - subroutine calculate_grad_normal(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_grad_normal(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - type(scalar_field), pointer :: source_field - type(vector_field), pointer :: positions + type(scalar_field), pointer :: source_field + type(vector_field), pointer :: positions - character(len = OPTION_PATH_LEN) :: base_path - integer, dimension(2) :: nsurface_ids - integer, dimension(:), allocatable :: surface_ids + character(len = OPTION_PATH_LEN) :: base_path + integer, dimension(2) :: nsurface_ids + integer, dimension(:), allocatable :: surface_ids - source_field => scalar_source_field(state, s_field) - positions => extract_vector_field(state, "Coordinate") + source_field => scalar_source_field(state, s_field) + positions => extract_vector_field(state, "Coordinate") - base_path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - if(have_option(trim(base_path) // "/surface_ids")) then - nsurface_ids = option_shape(trim(base_path) // "/surface_ids") - assert(nsurface_ids(1) >= 0) - allocate(surface_ids(nsurface_ids(1))) - call get_option(trim(base_path) // "/surface_ids", surface_ids) + base_path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + if(have_option(trim(base_path) // "/surface_ids")) then + nsurface_ids = option_shape(trim(base_path) // "/surface_ids") + assert(nsurface_ids(1) >= 0) + allocate(surface_ids(nsurface_ids(1))) + call get_option(trim(base_path) // "/surface_ids", surface_ids) - call surface_gradient_normal(source_field, positions, s_field, surface_ids = surface_ids) + call surface_gradient_normal(source_field, positions, s_field, surface_ids = surface_ids) - deallocate(surface_ids) - else - call surface_gradient_normal(source_field, positions, s_field) - end if + deallocate(surface_ids) + else + call surface_gradient_normal(source_field, positions, s_field) + end if - end subroutine calculate_grad_normal + end subroutine calculate_grad_normal -subroutine calculate_surface_horizontal_divergence(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field + subroutine calculate_surface_horizontal_divergence(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field - type(vector_field), pointer :: source_field - type(vector_field), pointer :: positions + type(vector_field), pointer :: source_field + type(vector_field), pointer :: positions - character(len = OPTION_PATH_LEN) :: base_path - integer, dimension(2) :: nsurface_ids - integer, dimension(:), allocatable :: surface_ids + character(len = OPTION_PATH_LEN) :: base_path + integer, dimension(2) :: nsurface_ids + integer, dimension(:), allocatable :: surface_ids - source_field => vector_source_field(state, s_field) - positions => extract_vector_field(state, "Coordinate") + source_field => vector_source_field(state, s_field) + positions => extract_vector_field(state, "Coordinate") - base_path = trim(complete_field_path(s_field%option_path)) // "/algorithm" + base_path = trim(complete_field_path(s_field%option_path)) // "/algorithm" - nsurface_ids = option_shape(trim(base_path) // "/surface_ids") - assert(nsurface_ids(1) >= 0) - allocate(surface_ids(nsurface_ids(1))) - call get_option(trim(base_path) // "/surface_ids", surface_ids) + nsurface_ids = option_shape(trim(base_path) // "/surface_ids") + assert(nsurface_ids(1) >= 0) + allocate(surface_ids(nsurface_ids(1))) + call get_option(trim(base_path) // "/surface_ids", surface_ids) - call surface_horizontal_divergence(source_field, positions, s_field, surface_ids = surface_ids) + call surface_horizontal_divergence(source_field, positions, s_field, surface_ids = surface_ids) - deallocate(surface_ids) + deallocate(surface_ids) - end subroutine calculate_surface_horizontal_divergence + end subroutine calculate_surface_horizontal_divergence end module surface_diagnostics diff --git a/diagnostics/Tidal_Diagnostics.F90 b/diagnostics/Tidal_Diagnostics.F90 index e9ee711f5d..6accce6fc6 100644 --- a/diagnostics/Tidal_Diagnostics.F90 +++ b/diagnostics/Tidal_Diagnostics.F90 @@ -29,287 +29,287 @@ module tidal_diagnostics - use fldebug - use global_parameters, only : timestep, OPTION_PATH_LEN, current_time - use spud - use futils - use vector_tools, only: solve - use fields - use state_module - use field_options - use diagnostic_source_fields - use initialise_fields_module - use state_fields_module - use tidal_module - use write_state_module, only: do_write_state - - implicit none - - private - - public :: calculate_free_surface_history, calculate_tidal_harmonics - - ! Module level variables - 'cos we have both the free surface history and - ! harmonic analyses to get options from - integer, save :: nLevels_ - integer, save :: when_to_calculate_ - logical, save :: calc_diag_at_ - -type harmonic_field - type(scalar_field) , pointer :: s_field - character(len=OPTION_PATH_LEN) :: name ! name of scalar field - integer :: sigmaIndex ! 0 == constant consituent C0, -1 == Residual - character(len=OPTION_PATH_LEN) :: target ! 'Amplitude' or 'Phase' -end type harmonic_field + use fldebug + use global_parameters, only : timestep, OPTION_PATH_LEN, current_time + use spud + use futils + use vector_tools, only: solve + use fields + use state_module + use field_options + use diagnostic_source_fields + use initialise_fields_module + use state_fields_module + use tidal_module + use write_state_module, only: do_write_state + + implicit none + + private + + public :: calculate_free_surface_history, calculate_tidal_harmonics + + ! Module level variables - 'cos we have both the free surface history and + ! harmonic analyses to get options from + integer, save :: nLevels_ + integer, save :: when_to_calculate_ + logical, save :: calc_diag_at_ + + type harmonic_field + type(scalar_field) , pointer :: s_field + character(len=OPTION_PATH_LEN) :: name ! name of scalar field + integer :: sigmaIndex ! 0 == constant consituent C0, -1 == Residual + character(len=OPTION_PATH_LEN) :: target ! 'Amplitude' or 'Phase' + end type harmonic_field contains -function get_number_of_harmonic_fields(state) result(N) + function get_number_of_harmonic_fields(state) result(N) + + type(state_type) :: state + + integer :: N + character(len = OPTION_PATH_LEN) :: lalgorithm, base_path + type(scalar_field), pointer :: iter_field + integer :: ii + + N = 0 + + do ii=1,scalar_field_count(state) + iter_field => extract_scalar_field(state,ii) + if (trim(iter_field%option_path)=='')then + cycle + end if + base_path = trim(complete_field_path(iter_field%option_path)) // '/algorithm/' + if (have_option(trim(base_path) // 'name')) then + call get_option(trim(base_path) // 'name', lalgorithm, default = "Internal") + if (trim(lalgorithm)=='tidal_harmonics') then + N = N + 1 + end if + end if + end do - type(state_type) :: state + end function - integer :: N - character(len = OPTION_PATH_LEN) :: lalgorithm, base_path - type(scalar_field), pointer :: iter_field - integer :: ii + subroutine calculate_free_surface_history(state, s_field) - N = 0 + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: s_field + type(scalar_field), pointer :: hist_fs_field + type(scalar_field), pointer :: fs_field + character(len=OPTION_PATH_LEN) :: base_path + integer :: stride, new_snapshot_index, levels, stat, timestep_counter + real :: spin_up_time, current_time, timestep + real, dimension(:), allocatable :: saved_snapshots_times - do ii=1,scalar_field_count(state) - iter_field => extract_scalar_field(state,ii) - if (trim(iter_field%option_path)=='')then - cycle - end if - base_path = trim(complete_field_path(iter_field%option_path)) // '/algorithm/' - if (have_option(trim(base_path) // 'name')) then - call get_option(trim(base_path) // 'name', lalgorithm, default = "Internal") - if (trim(lalgorithm)=='tidal_harmonics') then - N = N + 1 - end if - end if - end do + ewrite(3,*) 'in free_surface_history_diagnostics' -end function + fs_field => extract_scalar_field(state,"FreeSurface",stat) + call halo_update(fs_field) -subroutine calculate_free_surface_history(state, s_field) + if(stat /= 0) then + FLExit('I do not have a FreeSurface field so can not calculate diagnostics on it. Please switch on the FreeSurface diagnostic.') + return + end if - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: s_field - type(scalar_field), pointer :: hist_fs_field - type(scalar_field), pointer :: fs_field - character(len=OPTION_PATH_LEN) :: base_path - integer :: stride, new_snapshot_index, levels, stat, timestep_counter - real :: spin_up_time, current_time, timestep - real, dimension(:), allocatable :: saved_snapshots_times +! get history options + base_path=trim(complete_field_path(s_field%option_path)) // "/algorithm/" + + ! levels: the number of levels which will be saved. Too old levels will be overwritten by new ones. + call get_option(trim(base_path) // "levels", levels, default=50) + levels=max(levels,0) + ! Set it for checkpointing, etc + call set_option(trim(base_path) // "levels", levels, stat) + nLevels_ = levels + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + + ! The internal timestep counter of calculate_free_surface_history. + if (have_option(trim(base_path) // "timestep_counter")) then + call get_option(trim(base_path) // "timestep_counter", timestep_counter) + timestep_counter=timestep_counter+1 + else + timestep_counter=0 + end if + ! Lets save the current timestep_counter in the option tree. + call set_option(trim(base_path) // "timestep_counter", timestep_counter,stat) + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + + ! stride: Defines how many timesteps shall be skipped between two history snapshots. + call get_option(trim(base_path) // "stride", stride, default=50) + ! Set it for checkpointing in the future + call set_option(trim(base_path) // "stride", stride, stat) + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + + ! When to calculate + if (have_option(trim(base_path)//"/calculation_period")) then + call get_option(trim(base_path)//"/calculation_period",when_to_calculate_) + calc_diag_at_ = .true. + else + calc_diag_at_ = .false. + end if - ewrite(3,*) 'in free_surface_history_diagnostics' - fs_field => extract_scalar_field(state,"FreeSurface",stat) - call halo_update(fs_field) + call get_option(trim(base_path)//"spin_up_time", spin_up_time, default=0.0) + call get_option("/timestepping/current_time", current_time) + call get_option("/timestepping/timestep", timestep) + ! Spin up time is measured from the start of the simulation, not the start + ! time (hence no start time in here). + ! Note this is after the options check above as we add options to the tree if + ! they aren't there and they are needed in tidal_harmonics diagnostics + if(current_time+timestep extract_scalar_field(state,'harmonic'//int2str(new_snapshot_index)) - call set(hist_fs_field,fs_field) - deallocate(saved_snapshots_times) -end subroutine calculate_free_surface_history - - -subroutine calculate_tidal_harmonics(state, s_field) - type(state_type), intent(in) :: state - type(scalar_field), intent(in) :: s_field - type(harmonic_field), dimension(:), allocatable :: harmonic_fields - real, dimension(:), allocatable :: sigma - integer, save :: last_update=-1, nohfs=-1, M=-1 - logical :: ignoretimestep - real, dimension(:), allocatable :: saved_snapshots_times - integer :: i, current_snapshot_index - - - ! Check dump period - if we're about to dump output, calculate, regardless of - ! other options - if (.not. do_write_state(current_time, timestep+1)) then - ! Note: diagnostics are done at the end of the timestemp, dumps at the - ! begining. Hence the +1 on the timestep number above - we're - ! anticipating a dump at the start of the next timestep - ! Now check if the user wants a timestep - if (calc_diag_at_) then - if (.not. mod(timestep,when_to_calculate_+1) == 0) then - return ! it's not time to calculate - end if - else - return - end if - end if - - ! Only if Harmonics weren't already calculated in this timestep - if (last_update/=timestep) then - ewrite(3,*) "In tidal_harmonics" - allocate(harmonic_fields(get_number_of_harmonic_fields(state))) - allocate(sigma(nLevels_)) - - last_update=timestep - call getFreeSurfaceHistoryData(state, ignoretimestep, saved_snapshots_times, current_snapshot_index) - if (.not. ignoretimestep) then - ! Initialize the harmonic fields and frequencies if not already done. - call getHarmonicFields(state, harmonic_fields, nohfs, sigma, M) - ewrite(4,*) 'Frequencies to analyse:' - do i=1,M - ewrite(4,*) sigma(i) - end do - ! Calculate harmonics and update (all!) harmonic fields - call update_harmonic_fields(state, saved_snapshots_times, size(saved_snapshots_times), current_snapshot_index, sigma, M, harmonic_fields, nohfs) + ! get index where we want to save the new snapshot. + new_snapshot_index=mod(timestep_counter/stride,levels)+1 + + ! Save current free surface field in the history. + ! Note: Since diagnositcs are executed after the solving step, we actually save the fields at current_time+timestep + saved_snapshots_times(new_snapshot_index)=current_time+timestep + call set_option(trim(base_path) // "saved_snapshots_times", saved_snapshots_times, stat) + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + ewrite(4,*) 'Filling history level: ', min(timestep_counter/stride+1,levels), '/', levels + + ! lets copy a snapshot of freesurface to s_field(new_snapshot_index) + hist_fs_field => extract_scalar_field(state,'harmonic'//int2str(new_snapshot_index)) + call set(hist_fs_field,fs_field) + deallocate(saved_snapshots_times) + end subroutine calculate_free_surface_history + + + subroutine calculate_tidal_harmonics(state, s_field) + type(state_type), intent(in) :: state + type(scalar_field), intent(in) :: s_field + type(harmonic_field), dimension(:), allocatable :: harmonic_fields + real, dimension(:), allocatable :: sigma + integer, save :: last_update=-1, nohfs=-1, M=-1 + logical :: ignoretimestep + real, dimension(:), allocatable :: saved_snapshots_times + integer :: i, current_snapshot_index + + + ! Check dump period - if we're about to dump output, calculate, regardless of + ! other options + if (.not. do_write_state(current_time, timestep+1)) then + ! Note: diagnostics are done at the end of the timestemp, dumps at the + ! begining. Hence the +1 on the timestep number above - we're + ! anticipating a dump at the start of the next timestep + ! Now check if the user wants a timestep + if (calc_diag_at_) then + if (.not. mod(timestep,when_to_calculate_+1) == 0) then + return ! it's not time to calculate + end if + else + return + end if + end if + + ! Only if Harmonics weren't already calculated in this timestep + if (last_update/=timestep) then + ewrite(3,*) "In tidal_harmonics" + allocate(harmonic_fields(get_number_of_harmonic_fields(state))) + allocate(sigma(nLevels_)) + + last_update=timestep + call getFreeSurfaceHistoryData(state, ignoretimestep, saved_snapshots_times, current_snapshot_index) + if (.not. ignoretimestep) then + ! Initialize the harmonic fields and frequencies if not already done. + call getHarmonicFields(state, harmonic_fields, nohfs, sigma, M) + ewrite(4,*) 'Frequencies to analyse:' + do i=1,M + ewrite(4,*) sigma(i) + end do + ! Calculate harmonics and update (all!) harmonic fields + call update_harmonic_fields(state, saved_snapshots_times, size(saved_snapshots_times), current_snapshot_index, sigma, M, harmonic_fields, nohfs) + end if + deallocate(harmonic_fields) + deallocate(sigma) + end if + + if (allocated(saved_snapshots_times)) then + deallocate(saved_snapshots_times) + end if + + + end subroutine calculate_tidal_harmonics + + subroutine getFreeSurfaceHistoryData(state, ignoretimestep, saved_snapshots_times, current_snapshot_index) + type(state_type), intent(in) :: state + real, dimension(:), allocatable, intent(out) :: saved_snapshots_times + logical, intent(out) :: ignoretimestep + integer, intent(out) :: current_snapshot_index + character(len = OPTION_PATH_LEN) :: free_surface_history_path + integer :: timestep_counter, stride, levels, stat + type(scalar_field), pointer :: fshistory_sfield + + ignoretimestep=.false. + ! Find free_surface_history diagonstic field + fshistory_sfield => extract_scalar_field(state, 'FreeSurfaceHistory') + free_surface_history_path = trim(complete_field_path(fshistory_sfield%option_path)) // '/algorithm/' + + ! get information from free_surface_history diagnostic and check if the harmonic analysis needs to be calculated at this timestep + ! These options should be available here, because we ran calculate_free_surface_history() as a dependency before + call get_option(trim(free_surface_history_path) // "timestep_counter", timestep_counter) + call get_option(trim(free_surface_history_path) // "stride", stride) + call get_option(trim(free_surface_history_path) // "levels", levels) + + if( mod(timestep_counter,stride)/=0) then + ewrite(4,*) 'Do nothing in this timestep.' + ignoretimestep=.true. + return + end if + if(timestep_counter/stride+1 .lt. levels) then + ewrite(4,*) 'Do nothing until levels are filled up.' + ignoretimestep=.true. + return + end if + + allocate(saved_snapshots_times(levels)) + if (have_option(trim(free_surface_history_path) // "saved_snapshots_times")) then + call get_option(trim(free_surface_history_path) // "saved_snapshots_times", saved_snapshots_times) + else + call set_option(trim(free_surface_history_path) //"saved_snapshots_times", saved_snapshots_times,stat) end if - deallocate(harmonic_fields) - deallocate(sigma) - end if - - if (allocated(saved_snapshots_times)) then - deallocate(saved_snapshots_times) - end if - - -end subroutine calculate_tidal_harmonics - -subroutine getFreeSurfaceHistoryData(state, ignoretimestep, saved_snapshots_times, current_snapshot_index) - type(state_type), intent(in) :: state - real, dimension(:), allocatable, intent(out) :: saved_snapshots_times - logical, intent(out) :: ignoretimestep - integer, intent(out) :: current_snapshot_index - character(len = OPTION_PATH_LEN) :: free_surface_history_path - integer :: timestep_counter, stride, levels, stat - type(scalar_field), pointer :: fshistory_sfield - - ignoretimestep=.false. - ! Find free_surface_history diagonstic field - fshistory_sfield => extract_scalar_field(state, 'FreeSurfaceHistory') - free_surface_history_path = trim(complete_field_path(fshistory_sfield%option_path)) // '/algorithm/' - - ! get information from free_surface_history diagnostic and check if the harmonic analysis needs to be calculated at this timestep - ! These options should be available here, because we ran calculate_free_surface_history() as a dependency before - call get_option(trim(free_surface_history_path) // "timestep_counter", timestep_counter) - call get_option(trim(free_surface_history_path) // "stride", stride) - call get_option(trim(free_surface_history_path) // "levels", levels) - - if( mod(timestep_counter,stride)/=0) then - ewrite(4,*) 'Do nothing in this timestep.' - ignoretimestep=.true. - return - end if - if(timestep_counter/stride+1 .lt. levels) then - ewrite(4,*) 'Do nothing until levels are filled up.' - ignoretimestep=.true. - return - end if - - allocate(saved_snapshots_times(levels)) - if (have_option(trim(free_surface_history_path) // "saved_snapshots_times")) then - call get_option(trim(free_surface_history_path) // "saved_snapshots_times", saved_snapshots_times) - else - call set_option(trim(free_surface_history_path) //"saved_snapshots_times", saved_snapshots_times,stat) - end if - current_snapshot_index=mod(timestep_counter/stride,levels)+1 -end subroutine getFreeSurfaceHistoryData - - -subroutine getHarmonicFields(state, harmonic_fields, nohfs, sigma, M) - type(state_type), intent(in) :: state - type(harmonic_field), dimension(:), intent(inout) :: harmonic_fields - real, dimension(:), intent(inout) :: sigma - integer, intent(inout) :: nohfs, M - - character(len = OPTION_PATH_LEN) :: lalgorithm, base_path, constituent_name, target - integer :: i, ii - real :: freq - type(scalar_field), pointer :: iter_field - - nohfs=0 ! number of harmonic_fields - M=0 ! number of sigmas - ! Get desired constituents from the optione tree - s_field_loop: do ii=1,scalar_field_count(state) - iter_field => extract_scalar_field(state,ii) - if (trim(iter_field%option_path)=='')then - cycle - end if - base_path = trim(complete_field_path(iter_field%option_path)) // '/algorithm/' - if (have_option(trim(base_path) // 'name')) then - call get_option(trim(base_path) // 'name', lalgorithm, default = "Internal") - if (trim(lalgorithm)=='tidal_harmonics') then + current_snapshot_index=mod(timestep_counter/stride,levels)+1 + end subroutine getFreeSurfaceHistoryData + + + subroutine getHarmonicFields(state, harmonic_fields, nohfs, sigma, M) + type(state_type), intent(in) :: state + type(harmonic_field), dimension(:), intent(inout) :: harmonic_fields + real, dimension(:), intent(inout) :: sigma + integer, intent(inout) :: nohfs, M + + character(len = OPTION_PATH_LEN) :: lalgorithm, base_path, constituent_name, target + integer :: i, ii + real :: freq + type(scalar_field), pointer :: iter_field + + nohfs=0 ! number of harmonic_fields + M=0 ! number of sigmas + ! Get desired constituents from the optione tree + s_field_loop: do ii=1,scalar_field_count(state) + iter_field => extract_scalar_field(state,ii) + if (trim(iter_field%option_path)=='')then + cycle + end if + base_path = trim(complete_field_path(iter_field%option_path)) // '/algorithm/' + if (have_option(trim(base_path) // 'name')) then + call get_option(trim(base_path) // 'name', lalgorithm, default = "Internal") + if (trim(lalgorithm)=='tidal_harmonics') then nohfs=nohfs+1 if (nohfs>size(harmonic_fields)) then FLAbort('We found more tidal_harmonic fields than the space we allocated. Please report this as a bug') @@ -325,7 +325,7 @@ subroutine getHarmonicFields(state, harmonic_fields, nohfs, sigma, M) elseif (trim(constituent_name)=='Residual') then harmonic_fields(nohfs)%sigmaIndex=-1 harmonic_fields(nohfs)%target='' - ! Includes prescribed and custom frequencies: + ! Includes prescribed and custom frequencies: else call get_option(trim(base_path) // 'target', target) harmonic_fields(nohfs)%target=target @@ -333,186 +333,186 @@ subroutine getHarmonicFields(state, harmonic_fields, nohfs, sigma, M) call get_option(trim(base_path) // '/constituent', freq) do i=1,M - if (abs(sigma(i)-freq) <= 1.0E-14) then - harmonic_fields(nohfs)%sigmaIndex=i - cycle s_field_loop - end if + if (abs(sigma(i)-freq) <= 1.0E-14) then + harmonic_fields(nohfs)%sigmaIndex=i + cycle s_field_loop + end if end do ! Frequency was not found, so lets add it to sigma M=M+1 if (M>size(sigma)) then - FLExit('More frequencies than there are saved levels. Increase the number of levels (at least 2 times the number of frequencies)') + FLExit('More frequencies than there are saved levels. Increase the number of levels (at least 2 times the number of frequencies)') end if sigma(M) = freq harmonic_fields(nohfs)%sigmaIndex=M end if - end if - end if - end do s_field_loop - ewrite(4,*) 'Found ', nohfs, ' constituents to analyse.' - ewrite(4,*) 'Found ', M, ' frequencies to analyse.' - - if ( M .le. 0 ) then - FLExit("Internal error in calculate_tidal_harmonics(). No harmonic constituents were found in option tree.") - end if + end if + end if + end do s_field_loop + ewrite(4,*) 'Found ', nohfs, ' constituents to analyse.' + ewrite(4,*) 'Found ', M, ' frequencies to analyse.' + + if ( M .le. 0 ) then + FLExit("Internal error in calculate_tidal_harmonics(). No harmonic constituents were found in option tree.") + end if ! check which constituent we want to calculate ! call update_harmonic_analysis(state, levels, current_snapshot_index, saved_snapshots_times, sigma, M, s_field, myconstituent_id, target) -end subroutine getHarmonicFields - -subroutine update_harmonic_fields(state, snapshots_times, N, current_snapshot_index, sigma, M, harmonic_fields, nohfs) - type(state_type), intent(in) :: state - integer, intent(in) :: nohfs, M, N, current_snapshot_index ! M = size(sigma), N = size(snapshots_times) - type(harmonic_field), dimension(:), intent(in) :: harmonic_fields - real, dimension(:), intent(in) :: sigma, snapshots_times - real, dimension(:,:), allocatable :: harmonic_A ! for solving Ax=b system - real, dimension(:), allocatable :: harmonic_x, harmonic_b, harmonic_time_series_vals_at_node - integer :: i, ii, stat, node, nonodes - logical :: forceC0toZero - real :: residual - type(scalar_field), pointer :: harmonic_current + end subroutine getHarmonicFields + + subroutine update_harmonic_fields(state, snapshots_times, N, current_snapshot_index, sigma, M, harmonic_fields, nohfs) + type(state_type), intent(in) :: state + integer, intent(in) :: nohfs, M, N, current_snapshot_index ! M = size(sigma), N = size(snapshots_times) + type(harmonic_field), dimension(:), intent(in) :: harmonic_fields + real, dimension(:), intent(in) :: sigma, snapshots_times + real, dimension(:,:), allocatable :: harmonic_A ! for solving Ax=b system + real, dimension(:), allocatable :: harmonic_x, harmonic_b, harmonic_time_series_vals_at_node + integer :: i, ii, stat, node, nonodes + logical :: forceC0toZero + real :: residual + type(scalar_field), pointer :: harmonic_current ! - allocate(harmonic_A(2*M+1,2*M+1)) - allocate(harmonic_x(2*M+1)) - allocate(harmonic_b(2*M+1)) - allocate(harmonic_time_series_vals_at_node(N)) - - ! Set this to .True. if you want to force C0 to 0 - forceC0toZero = .False. - - ! Loop over all nodes of the mesh - harmonic_current => extract_scalar_field(state, 'harmonic1', stat) - nonodes=node_count(harmonic_current) - do node = 1,nonodes - !Extract the free surface elevations at the current node - do i = 1,N - harmonic_current => extract_scalar_field(state,'harmonic'//int2str(i),stat) - harmonic_time_series_vals_at_node(i) = node_val(harmonic_current,node) - end do - - !Form and invert the least squares system (Unsorted version) - call harmonic_analysis_at_single_node(N,snapshots_times,harmonic_time_series_vals_at_node,M,sigma,& - harmonic_A,harmonic_x,harmonic_b, forceC0toZero) - ! Calculate residual - harmonic_current => extract_scalar_field(state,'harmonic'//int2str(current_snapshot_index),stat) - residual=node_val(harmonic_current,node) - residual=residual-harmonic_x(1) - do ii=1,M - residual=residual-harmonic_x(1+ii)*cos(2*3.141592654*sigma(ii)*snapshots_times(current_snapshot_index)) - residual=residual-harmonic_x(1+M+ii)*sin(2*3.141592654*sigma(ii)*snapshots_times(current_snapshot_index)) - end do + allocate(harmonic_A(2*M+1,2*M+1)) + allocate(harmonic_x(2*M+1)) + allocate(harmonic_b(2*M+1)) + allocate(harmonic_time_series_vals_at_node(N)) + + ! Set this to .True. if you want to force C0 to 0 + forceC0toZero = .False. + + ! Loop over all nodes of the mesh + harmonic_current => extract_scalar_field(state, 'harmonic1', stat) + nonodes=node_count(harmonic_current) + do node = 1,nonodes + !Extract the free surface elevations at the current node + do i = 1,N + harmonic_current => extract_scalar_field(state,'harmonic'//int2str(i),stat) + harmonic_time_series_vals_at_node(i) = node_val(harmonic_current,node) + end do - call save_harmonic_x_in_fields(harmonic_x, residual, M, harmonic_fields, nohfs, node) - - end do ! node loop - deallocate(harmonic_A) - deallocate(harmonic_x) - deallocate(harmonic_b) - deallocate(harmonic_time_series_vals_at_node) - - end subroutine update_harmonic_fields - - -subroutine save_harmonic_x_in_fields(harmonic_x, residual, M, harmonic_fields, nohfs, node) - real, dimension(:), intent(in) :: harmonic_x - real, intent(in) :: residual - type(harmonic_field), dimension(:), intent(in) :: harmonic_fields - integer, intent(in) :: nohfs, M, node - integer :: i, MM - real :: result - type(scalar_field), pointer :: harmonic_current - ! Loop over harmonic diagnostic fields - do i=1,nohfs - harmonic_current=>harmonic_fields(i)%s_field - MM=harmonic_fields(i)%sigmaIndex - - ! Check if we want the C0 constituent - if (MM==0) then - call set(harmonic_current, node, harmonic_x(1)) - - ! Check if we want the residual - elseif (MM==-1) then - call set(harmonic_current, node, residual) - end if + !Form and invert the least squares system (Unsorted version) + call harmonic_analysis_at_single_node(N,snapshots_times,harmonic_time_series_vals_at_node,M,sigma,& + harmonic_A,harmonic_x,harmonic_b, forceC0toZero) + ! Calculate residual + harmonic_current => extract_scalar_field(state,'harmonic'//int2str(current_snapshot_index),stat) + residual=node_val(harmonic_current,node) + residual=residual-harmonic_x(1) + do ii=1,M + residual=residual-harmonic_x(1+ii)*cos(2*3.141592654*sigma(ii)*snapshots_times(current_snapshot_index)) + residual=residual-harmonic_x(1+M+ii)*sin(2*3.141592654*sigma(ii)*snapshots_times(current_snapshot_index)) + end do - !stick the amplitude and phase into something that will be output - if (harmonic_fields(i)%target=='Amplitude') then - call set( harmonic_current, node, sqrt( harmonic_x(MM+1)**2 + harmonic_x(MM+1+M)**2 ) ) - elseif (harmonic_fields(i)%target=='Phase') then - result = atan2(harmonic_x(MM+1+M),harmonic_x(MM+1)) - !*180.0/pi - !if (phase < 0.0) phase = phase + 360.0 - call set( harmonic_current, node, result ) - end if - end do -end subroutine save_harmonic_x_in_fields + call save_harmonic_x_in_fields(harmonic_x, residual, M, harmonic_fields, nohfs, node) + + end do ! node loop + deallocate(harmonic_A) + deallocate(harmonic_x) + deallocate(harmonic_b) + deallocate(harmonic_time_series_vals_at_node) + + end subroutine update_harmonic_fields + + + subroutine save_harmonic_x_in_fields(harmonic_x, residual, M, harmonic_fields, nohfs, node) + real, dimension(:), intent(in) :: harmonic_x + real, intent(in) :: residual + type(harmonic_field), dimension(:), intent(in) :: harmonic_fields + integer, intent(in) :: nohfs, M, node + integer :: i, MM + real :: result + type(scalar_field), pointer :: harmonic_current + ! Loop over harmonic diagnostic fields + do i=1,nohfs + harmonic_current=>harmonic_fields(i)%s_field + MM=harmonic_fields(i)%sigmaIndex + + ! Check if we want the C0 constituent + if (MM==0) then + call set(harmonic_current, node, harmonic_x(1)) + + ! Check if we want the residual + elseif (MM==-1) then + call set(harmonic_current, node, residual) + end if + + !stick the amplitude and phase into something that will be output + if (harmonic_fields(i)%target=='Amplitude') then + call set( harmonic_current, node, sqrt( harmonic_x(MM+1)**2 + harmonic_x(MM+1+M)**2 ) ) + elseif (harmonic_fields(i)%target=='Phase') then + result = atan2(harmonic_x(MM+1+M),harmonic_x(MM+1)) + !*180.0/pi + !if (phase < 0.0) phase = phase + 360.0 + call set( harmonic_current, node, result ) + end if + end do + end subroutine save_harmonic_x_in_fields ! !!!!!!! - subroutine harmonic_analysis_at_single_node(N,harmonic_times_reordered,harmonic_time_series_vals_at_node,M,sigma,& - harmonic_A,harmonic_x,harmonic_b, forceC0toZero) - real, intent(in) :: harmonic_times_reordered(:),harmonic_time_series_vals_at_node(:),sigma(:) - real, intent(inout) :: harmonic_A(:,:),harmonic_x(:),harmonic_b(:) - integer, intent(in) :: M,N - logical, optional, intent(in) :: forceC0toZero - real :: C_k, S_k, CC_jk, SS_jk, SC_jk, CS_kj - real :: pi = 3.141592654 - integer :: i, j, k, stat + subroutine harmonic_analysis_at_single_node(N,harmonic_times_reordered,harmonic_time_series_vals_at_node,M,sigma,& + harmonic_A,harmonic_x,harmonic_b, forceC0toZero) + real, intent(in) :: harmonic_times_reordered(:),harmonic_time_series_vals_at_node(:),sigma(:) + real, intent(inout) :: harmonic_A(:,:),harmonic_x(:),harmonic_b(:) + integer, intent(in) :: M,N + logical, optional, intent(in) :: forceC0toZero + real :: C_k, S_k, CC_jk, SS_jk, SC_jk, CS_kj + real :: pi = 3.141592654 + integer :: i, j, k, stat ! For the least squares system - harmonic_A(1,1) = N + harmonic_A(1,1) = N ! Need the C_k and S_k for first row/column - j = 1 - do k = 1,M - C_k = 0.0 - S_k = 0.0 - do i = 1,N - C_k = C_k + cos(2.*pi*sigma(k)*harmonic_times_reordered(i)) - S_k = S_k + sin(2.*pi*sigma(k)*harmonic_times_reordered(i)) - end do - harmonic_A(1,k+1) = C_k - harmonic_A(1,k+1+M) = S_k - harmonic_A(k+1,1) = C_k - harmonic_A(k+1+M,1) = S_k - end do + j = 1 + do k = 1,M + C_k = 0.0 + S_k = 0.0 + do i = 1,N + C_k = C_k + cos(2.*pi*sigma(k)*harmonic_times_reordered(i)) + S_k = S_k + sin(2.*pi*sigma(k)*harmonic_times_reordered(i)) + end do + harmonic_A(1,k+1) = C_k + harmonic_A(1,k+1+M) = S_k + harmonic_A(k+1,1) = C_k + harmonic_A(k+1+M,1) = S_k + end do ! rest of the rows and columns of the matrix - do j = 1,M + do j = 1,M do k = 1,M - CC_jk = 0.0 - SS_jk = 0.0 - SC_jk = 0.0 - do i = 1,N - CC_jk = CC_jk + cos(2.*pi*sigma(k)*harmonic_times_reordered(i))*cos(2.*pi*sigma(j)*harmonic_times_reordered(i)) - SS_jk = SS_jk + sin(2.*pi*sigma(k)*harmonic_times_reordered(i))*sin(2.*pi*sigma(j)*harmonic_times_reordered(i)) - SC_jk = SC_jk + cos(2.*pi*sigma(k)*harmonic_times_reordered(i))*sin(2.*pi*sigma(j)*harmonic_times_reordered(i)) - end do - CS_kj = SC_jk - harmonic_A(j+1,k+1) = CC_jk ! top left quadrant - harmonic_A(j+1+M,k+1+M) = SS_jk ! bottom right quadrant - harmonic_A(j+1+M,k+1) = SC_jk ! bottom left quadrant - harmonic_A(k+1,j+1+M) = SC_jk ! top right quadrant (swap order we fill up matrix as CS_kj.eq.SC_jk, CS_kj.ne.SC_kj) + CC_jk = 0.0 + SS_jk = 0.0 + SC_jk = 0.0 + do i = 1,N + CC_jk = CC_jk + cos(2.*pi*sigma(k)*harmonic_times_reordered(i))*cos(2.*pi*sigma(j)*harmonic_times_reordered(i)) + SS_jk = SS_jk + sin(2.*pi*sigma(k)*harmonic_times_reordered(i))*sin(2.*pi*sigma(j)*harmonic_times_reordered(i)) + SC_jk = SC_jk + cos(2.*pi*sigma(k)*harmonic_times_reordered(i))*sin(2.*pi*sigma(j)*harmonic_times_reordered(i)) + end do + CS_kj = SC_jk + harmonic_A(j+1,k+1) = CC_jk ! top left quadrant + harmonic_A(j+1+M,k+1+M) = SS_jk ! bottom right quadrant + harmonic_A(j+1+M,k+1) = SC_jk ! bottom left quadrant + harmonic_A(k+1,j+1+M) = SC_jk ! top right quadrant (swap order we fill up matrix as CS_kj.eq.SC_jk, CS_kj.ne.SC_kj) end do - end do - if(present_and_true(forceC0toZero)) then - harmonic_A(1,2:2*M+1)=0.0 - harmonic_A(2:2*M+1,1)=0.0 - end if + end do + if(present_and_true(forceC0toZero)) then + harmonic_A(1,2:2*M+1)=0.0 + harmonic_A(2:2*M+1,1)=0.0 + end if ! now the rhs vector - harmonic_b(1:2*M+1) = 0.0 - if(.not. present_and_true(forceC0toZero)) then + harmonic_b(1:2*M+1) = 0.0 + if(.not. present_and_true(forceC0toZero)) then do i = 1,N harmonic_b(1) = harmonic_b(1) + harmonic_time_series_vals_at_node(i) end do - end if - do j = 1,M - do i = 1,N - harmonic_b(j+1) = harmonic_b(j+1) + harmonic_time_series_vals_at_node(i)*cos(2.*pi*sigma(j)*harmonic_times_reordered(i)) - harmonic_b(j+1+M) = harmonic_b(j+1+M) + harmonic_time_series_vals_at_node(i)*sin(2.*pi*sigma(j)*harmonic_times_reordered(i)) - end do - end do + end if + do j = 1,M + do i = 1,N + harmonic_b(j+1) = harmonic_b(j+1) + harmonic_time_series_vals_at_node(i)*cos(2.*pi*sigma(j)*harmonic_times_reordered(i)) + harmonic_b(j+1+M) = harmonic_b(j+1+M) + harmonic_time_series_vals_at_node(i)*sin(2.*pi*sigma(j)*harmonic_times_reordered(i)) + end do + end do ! solve the system - call solve(harmonic_A, harmonic_b, stat) ! Solve Ax=b, note that b will be overwritten - harmonic_x = harmonic_b + call solve(harmonic_A, harmonic_b, stat) ! Solve Ax=b, note that b will be overwritten + harmonic_x = harmonic_b - end subroutine harmonic_analysis_at_single_node + end subroutine harmonic_analysis_at_single_node end module tidal_diagnostics diff --git a/error_measures/Anisotropic_ZZ.F90 b/error_measures/Anisotropic_ZZ.F90 index 44a0f6ed9a..c16b326665 100644 --- a/error_measures/Anisotropic_ZZ.F90 +++ b/error_measures/Anisotropic_ZZ.F90 @@ -6,469 +6,469 @@ module anisotropic_zz_module ! If you understand the algorithm, the code is trivial, ! but not vice versa! - use spud - use fldebug - use global_parameters - use quicksort - use sparse_tools - use vector_tools - use tensors - use unittest_tools, only: get_mat_diag, is_nan - use adjacency_lists - use transform_elements - use fetools - use metric_tools - use fields - use state_module - use field_options - use meshdiagnostics - use vtk_interfaces - use merge_tensors - use vtk_interfaces - use halos - use limit_metric_module - use conformity_measurement - use sparsity_patterns - use diagnostic_fields - use edge_length_module - use bounding_box_metric - use form_metric_field - - implicit none - - private - - public :: compute_anisotropic_zz_metric, compute_g_hat, form_anisotropic_zz_metric, get_jacobian_azz - - contains - - subroutine form_anisotropic_zz_metric(state, metric) - type(state_type), dimension(:), intent(in) :: state - type(tensor_field), intent(inout) :: metric - - type(state_type) :: azz_fields - type(scalar_field) :: field_s - type(tensor_field) :: tmp_metric - type(vector_field), pointer :: positions - integer :: i, j - - logical :: debug_metric - integer, save :: adaptcnt = 0 - character(len=100) :: buf - type(scalar_field) :: edgelen - - do i=1,size(state) - do j=1,scalar_field_count(state(i)) - field_s = extract_scalar_field(state(i), j) - if (aliased(field_s)) cycle - if (have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/anisotropic_zienkiewicz_zhu")) then - call insert(azz_fields, field_s, trim(field_s%name)) - end if + use spud + use fldebug + use global_parameters + use quicksort + use sparse_tools + use vector_tools + use tensors + use unittest_tools, only: get_mat_diag, is_nan + use adjacency_lists + use transform_elements + use fetools + use metric_tools + use fields + use state_module + use field_options + use meshdiagnostics + use vtk_interfaces + use merge_tensors + use vtk_interfaces + use halos + use limit_metric_module + use conformity_measurement + use sparsity_patterns + use diagnostic_fields + use edge_length_module + use bounding_box_metric + use form_metric_field + + implicit none + + private + + public :: compute_anisotropic_zz_metric, compute_g_hat, form_anisotropic_zz_metric, get_jacobian_azz + +contains + + subroutine form_anisotropic_zz_metric(state, metric) + type(state_type), dimension(:), intent(in) :: state + type(tensor_field), intent(inout) :: metric + + type(state_type) :: azz_fields + type(scalar_field) :: field_s + type(tensor_field) :: tmp_metric + type(vector_field), pointer :: positions + integer :: i, j + + logical :: debug_metric + integer, save :: adaptcnt = 0 + character(len=100) :: buf + type(scalar_field) :: edgelen + + do i=1,size(state) + do j=1,scalar_field_count(state(i)) + field_s = extract_scalar_field(state(i), j) + if (aliased(field_s)) cycle + if (have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/anisotropic_zienkiewicz_zhu")) then + call insert(azz_fields, field_s, trim(field_s%name)) + end if + end do end do - end do - if (scalar_field_count(azz_fields) == 0) return + if (scalar_field_count(azz_fields) == 0) return - call allocate(tmp_metric, metric%mesh, "TemporaryMetric") - call zero(tmp_metric) + call allocate(tmp_metric, metric%mesh, "TemporaryMetric") + call zero(tmp_metric) - positions => extract_vector_field(state(1), "Coordinate") - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - if (debug_metric) then - call allocate(edgelen, metric%mesh, "EdgeLengths") - end if - - do i=1,scalar_field_count(azz_fields) - write(buf, '(i0)') i - field_s = extract_scalar_field(azz_fields, i) - call halo_update(field_s) - call compute_anisotropic_zz_metric(field_s, positions, tmp_metric) + positions => extract_vector_field(state(1), "Coordinate") + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") if (debug_metric) then - call get_edge_lengths(tmp_metric, edgelen) - call vtk_write_fieldS(trim("azz_metric_unbounded") // trim(buf), adaptcnt, positions, positions%mesh, & - sfields=(/field_s, edgelen/), tfields=(/tmp_metric/)) + call allocate(edgelen, metric%mesh, "EdgeLengths") end if - call bound_metric(tmp_metric, state(1)) + + do i=1,scalar_field_count(azz_fields) + write(buf, '(i0)') i + field_s = extract_scalar_field(azz_fields, i) + call halo_update(field_s) + call compute_anisotropic_zz_metric(field_s, positions, tmp_metric) + if (debug_metric) then + call get_edge_lengths(tmp_metric, edgelen) + call vtk_write_fieldS(trim("azz_metric_unbounded") // trim(buf), adaptcnt, positions, positions%mesh, & + sfields=(/field_s, edgelen/), tfields=(/tmp_metric/)) + end if + call bound_metric(tmp_metric, state(1)) + if (debug_metric) then + call get_edge_lengths(tmp_metric, edgelen) + call vtk_write_fieldS(trim("azz_metric_bounded") // trim(buf), adaptcnt, positions, positions%mesh, & + sfields=(/field_s, edgelen/), tfields=(/tmp_metric/)) + end if + call merge_tensor_fields(metric, tmp_metric) + end do + + call deallocate(azz_fields) + call deallocate(tmp_metric) + if (debug_metric) then - call get_edge_lengths(tmp_metric, edgelen) - call vtk_write_fieldS(trim("azz_metric_bounded") // trim(buf), adaptcnt, positions, positions%mesh, & - sfields=(/field_s, edgelen/), tfields=(/tmp_metric/)) + call deallocate(edgelen) end if - call merge_tensor_fields(metric, tmp_metric) - end do - - call deallocate(azz_fields) - call deallocate(tmp_metric) - - if (debug_metric) then - call deallocate(edgelen) - end if - adaptcnt = adaptcnt + 1 - - call halo_update(metric) - - end subroutine form_anisotropic_zz_metric - - subroutine compute_anisotropic_zz_metric(field, positions, metric, eta_estimate) - type(scalar_field), intent(in) :: field - type(vector_field), intent(inout) :: positions - type(tensor_field), intent(inout) :: metric - real, intent(out), optional :: eta_estimate - - type(mesh_type) :: pwc_mesh - type(tensor_field) :: pwc_metric - - integer :: ele - real :: tau - character(len=OPTION_PATH_LEN) :: path - real :: eta, ele_eta - - integer :: patch_count, max_patch_count, sum_patch_count - - path = trim(complete_field_path(trim(field%option_path))) // "/adaptivity_options/anisotropic_zienkiewicz_zhu" - call get_option(trim(path) // "/tau", tau) - ewrite(1,*) "Using tau = ", tau - assert(tau > 0.0) - - call add_nelist(positions%mesh) - - assert(field%mesh%shape%degree == 1) - assert(associated(metric%val)) - - call zero(metric) - - ! Build the P0 metric - pwc_mesh = piecewise_constant_mesh(metric%mesh, "PiecewiseConstantMesh") - call allocate(pwc_metric, pwc_mesh, "PiecewiseConstantMetric") - - max_patch_count = 0 - sum_patch_count = 0 - eta = 0.0 - do ele=1,ele_count(positions) - call anisotropic_zz_element_metric(field, positions, pwc_metric, tau, ele, ele_eta, patch_count=patch_count) - max_patch_count = max(max_patch_count, patch_count) - sum_patch_count = sum_patch_count + patch_count - eta = eta + ele_eta - end do - eta = sqrt(eta) - if (present(eta_estimate)) then - eta_estimate = eta - end if - - ewrite(1,*) "Current mesh error estimate: ", eta - ewrite(2,*) "Max patch count: ", max_patch_count - ewrite(2,*) "Avg patch count: ", float(sum_patch_count)/ele_count(positions) - - ! Project to P1 here - call project_p0_metric_p1(positions, pwc_metric, metric) - - call deallocate(pwc_metric) - call deallocate(pwc_mesh) - end subroutine compute_anisotropic_zz_metric - - subroutine anisotropic_zz_element_metric(field, positions, pwc_metric, tau, ele, eta, patch_count) - type(scalar_field), intent(in) :: field - type(vector_field), intent(in) :: positions - type(tensor_field), intent(inout) :: pwc_metric - real, intent(in) :: tau - integer, intent(in) :: ele - real, intent(out) :: eta - integer, intent(out), optional :: patch_count - - real, dimension(positions%dim) :: lambda_k, g_evals, sorted_g_evals, out_evals, out_edges - real, dimension(positions%dim, positions%dim) :: g_hat, m_k, out_k, rt_k, vt_k, g_evecs, & - & sorted_g_evecs, out_evecs, g, j_k - real :: patch_volume, transformed_patch_volume - integer, dimension(positions%dim) :: sorted_idx - integer :: i, dim - real, parameter :: omega = 1.0 - real :: gamma, ele_vol, weight - real :: sum_eta - real :: dim_error - real, dimension(positions%dim) :: evec - - dim = positions%dim - ! Compute volume of ideal element - if (dim == 2) then - gamma = 3.0*sqrt(3.0) / 4.0 - weight = 1.0/3.0 ! 1/h**2, where h is ideal element length - else - gamma = 8.0 / (9.0 * sqrt(3.0)) - weight = 1.0 / (2 * sqrt(2.0/3.0))**2 - end if - - ! (a) and (b): compute g_hat - g_hat = compute_g_hat(field, positions, ele_shape(pwc_metric, ele), ele, patch_vol=patch_volume, patch_count=patch_count) - j_k = get_jacobian_azz(positions, ele) - call svd(j_k, rt_k, lambda_k, vt_k) - m_k = matmul(matmul(rt_k, get_mat_diag(1.0/(lambda_k**2))), transpose(rt_k)) - - ! (e): compute transformed patch volume - transformed_patch_volume = patch_volume / product(lambda_k) - assert(transformed_patch_volume > gamma) - - ! (f): sorted eigenvalue decomposition of g_hat, in descending order - call eigendecomposition_symmetric(g_hat, g_evecs, g_evals) - call qsort(g_evals, sorted_idx) - - dim = positions%dim - forall(i=1:dim) - sorted_g_evals(i) = g_evals(sorted_idx(dim - i + 1)) - sorted_g_evecs(:, i) = g_evecs(:, sorted_idx(dim - i + 1)) - end forall - - ! Compute error estimator - sum_eta = 0.0 - g = g_hat * patch_volume - ele_vol = simplex_volume(positions, ele) - do i=1,dim - evec = rt_k(:, i) - dim_error = lambda_k(i)**2 * dot_product(matmul(evec, g), evec) - sum_eta = sum_eta + dim_error - end do - eta = (sum_eta * (1.0/product(lambda_k))**(2.0/dim)) - assert(.not. is_nan(eta)) - - ! step (g): compute r - out_evecs = compute_out_evecs(sorted_g_evecs) - - ! and compute lambda - out_edges = compute_edge_lengths(tau, ele_count(positions), transformed_patch_volume, sorted_g_evals) - assert(all(out_edges > 0.0)) - out_evals = eigenvalue_from_edge_length(out_edges) - - call eigenrecomposition(out_k, out_evecs, out_evals) - - out_k = weight * (omega * out_k + (1.0-omega)*m_k) - - call set(pwc_metric, ele, out_k) - end subroutine anisotropic_zz_element_metric - - function compute_edge_lengths(tau, eles, vol, g_evals) result(edges) - real, intent(in) :: tau - integer, intent(in) :: eles - real, intent(in) :: vol - real, dimension(:), intent(in) :: g_evals - real, dimension(size(g_evals)) :: edges, modified_g_evals, min_g - real :: factor_a, factor_b, factor_c - real, dimension(size(domain_bbox,1)) :: domain_width - real :: max_length - - integer :: dim, i, j - - dim = size(g_evals) - - ! FIXME: make this more general by computing - ! max_length as the diameter of the domain. - assert(bounding_box_initialised) - do i = 1, size(domain_bbox,1) - domain_width(i) = abs(domain_bbox(i,2)-domain_bbox(i,1)) - end do - max_length = maxval(domain_width) - factor_a = ((tau**2) / (dim*eles*vol))**(1.0/dim) - assert(factor_a > 0.0) - min_g = (max_length / factor_a)**(-1.0 * dim) - modified_g_evals = max(g_evals, min_g) - - do i=1,dim - j = dim - i + 1 - ! take a deep breath: - factor_b = 1.0/sqrt(modified_g_evals(j)) - factor_c = (product(modified_g_evals))**((dim - 2.0) / (2.0*dim*dim)) - if (dim == 2) then - assert(factor_c == 1.0) + adaptcnt = adaptcnt + 1 + + call halo_update(metric) + + end subroutine form_anisotropic_zz_metric + + subroutine compute_anisotropic_zz_metric(field, positions, metric, eta_estimate) + type(scalar_field), intent(in) :: field + type(vector_field), intent(inout) :: positions + type(tensor_field), intent(inout) :: metric + real, intent(out), optional :: eta_estimate + + type(mesh_type) :: pwc_mesh + type(tensor_field) :: pwc_metric + + integer :: ele + real :: tau + character(len=OPTION_PATH_LEN) :: path + real :: eta, ele_eta + + integer :: patch_count, max_patch_count, sum_patch_count + + path = trim(complete_field_path(trim(field%option_path))) // "/adaptivity_options/anisotropic_zienkiewicz_zhu" + call get_option(trim(path) // "/tau", tau) + ewrite(1,*) "Using tau = ", tau + assert(tau > 0.0) + + call add_nelist(positions%mesh) + + assert(field%mesh%shape%degree == 1) + assert(associated(metric%val)) + + call zero(metric) + + ! Build the P0 metric + pwc_mesh = piecewise_constant_mesh(metric%mesh, "PiecewiseConstantMesh") + call allocate(pwc_metric, pwc_mesh, "PiecewiseConstantMetric") + + max_patch_count = 0 + sum_patch_count = 0 + eta = 0.0 + do ele=1,ele_count(positions) + call anisotropic_zz_element_metric(field, positions, pwc_metric, tau, ele, ele_eta, patch_count=patch_count) + max_patch_count = max(max_patch_count, patch_count) + sum_patch_count = sum_patch_count + patch_count + eta = eta + ele_eta + end do + eta = sqrt(eta) + if (present(eta_estimate)) then + eta_estimate = eta end if - assert(factor_b > 0.0) - assert(factor_c > 0.0) - edges(i) = factor_a * factor_b * factor_c - if (is_nan(edges(i)) .or. edges(i) > max_length) then - edges(i) = max_length + ewrite(1,*) "Current mesh error estimate: ", eta + ewrite(2,*) "Max patch count: ", max_patch_count + ewrite(2,*) "Avg patch count: ", float(sum_patch_count)/ele_count(positions) + + ! Project to P1 here + call project_p0_metric_p1(positions, pwc_metric, metric) + + call deallocate(pwc_metric) + call deallocate(pwc_mesh) + end subroutine compute_anisotropic_zz_metric + + subroutine anisotropic_zz_element_metric(field, positions, pwc_metric, tau, ele, eta, patch_count) + type(scalar_field), intent(in) :: field + type(vector_field), intent(in) :: positions + type(tensor_field), intent(inout) :: pwc_metric + real, intent(in) :: tau + integer, intent(in) :: ele + real, intent(out) :: eta + integer, intent(out), optional :: patch_count + + real, dimension(positions%dim) :: lambda_k, g_evals, sorted_g_evals, out_evals, out_edges + real, dimension(positions%dim, positions%dim) :: g_hat, m_k, out_k, rt_k, vt_k, g_evecs, & + & sorted_g_evecs, out_evecs, g, j_k + real :: patch_volume, transformed_patch_volume + integer, dimension(positions%dim) :: sorted_idx + integer :: i, dim + real, parameter :: omega = 1.0 + real :: gamma, ele_vol, weight + real :: sum_eta + real :: dim_error + real, dimension(positions%dim) :: evec + + dim = positions%dim + ! Compute volume of ideal element + if (dim == 2) then + gamma = 3.0*sqrt(3.0) / 4.0 + weight = 1.0/3.0 ! 1/h**2, where h is ideal element length + else + gamma = 8.0 / (9.0 * sqrt(3.0)) + weight = 1.0 / (2 * sqrt(2.0/3.0))**2 end if - end do - end function compute_edge_lengths - - function compute_out_evecs(g_evecs) result(out_evecs) - real, dimension(:, :), intent(in) :: g_evecs - real, dimension(size(g_evecs, 1), size(g_evecs, 1)) :: out_evecs - integer :: dim - integer :: i, j - - dim = size(g_evecs, 1) - do i=1,dim - j = dim - i + 1 - out_evecs(:, i) = g_evecs(:, j) - end do - end function compute_out_evecs - - function compute_g_hat(field, positions, pwc_shape, ele, patch_vol, patch_count) result(g_hat) - type(scalar_field), intent(in) :: field - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: pwc_shape - integer, intent(in) :: ele - real, optional, intent(out) :: patch_vol - integer, optional, intent(out) :: patch_count - - real, dimension(positions%dim) :: recovered_gradient - real, dimension(positions%dim, ele_ngi(field, ele)) :: error_at_quad - real, dimension(positions%dim, positions%dim) :: g, g_hat, g_int - real, dimension(positions%dim, ele_loc(field, ele)) :: r - - - integer :: i, neighbour - real :: patch_volume - integer :: gi, idim, jdim - integer :: dim, loc, ngi - logical, dimension(ele_count(positions)) :: seen_elements - real, dimension(:, :), allocatable :: ele_gradient, detwei - real, dimension(:, :, :, :), allocatable :: dm_t - integer :: patch_size - integer, dimension(:), allocatable :: patch_elements - integer, dimension(:), pointer :: neighbours, nodes - integer :: j - - ! Oh! For the want of a fecking set union in Fortran. - - ! Let's compute the patch around. - - seen_elements = .false. - nodes => ele_nodes(positions, ele) - assert(associated(positions%mesh%adj_lists)) - assert(associated(positions%mesh%adj_lists%nelist)) - do i=1,ele_loc(positions, ele) - neighbours => row_m_ptr(positions%mesh%adj_lists%nelist, nodes(i)) - do j=1,size(neighbours) - seen_elements(neighbours(j)) = .true. + + ! (a) and (b): compute g_hat + g_hat = compute_g_hat(field, positions, ele_shape(pwc_metric, ele), ele, patch_vol=patch_volume, patch_count=patch_count) + j_k = get_jacobian_azz(positions, ele) + call svd(j_k, rt_k, lambda_k, vt_k) + m_k = matmul(matmul(rt_k, get_mat_diag(1.0/(lambda_k**2))), transpose(rt_k)) + + ! (e): compute transformed patch volume + transformed_patch_volume = patch_volume / product(lambda_k) + assert(transformed_patch_volume > gamma) + + ! (f): sorted eigenvalue decomposition of g_hat, in descending order + call eigendecomposition_symmetric(g_hat, g_evecs, g_evals) + call qsort(g_evals, sorted_idx) + + dim = positions%dim + forall(i=1:dim) + sorted_g_evals(i) = g_evals(sorted_idx(dim - i + 1)) + sorted_g_evecs(:, i) = g_evecs(:, sorted_idx(dim - i + 1)) + end forall + + ! Compute error estimator + sum_eta = 0.0 + g = g_hat * patch_volume + ele_vol = simplex_volume(positions, ele) + do i=1,dim + evec = rt_k(:, i) + dim_error = lambda_k(i)**2 * dot_product(matmul(evec, g), evec) + sum_eta = sum_eta + dim_error end do - end do - - patch_size = count(seen_elements) - - if (present(patch_count)) then - patch_count = patch_size - end if - - allocate(patch_elements(patch_size)) - j = 1 - do i=1,size(seen_elements) - if (seen_elements(i)) then - patch_elements(j) = i - j = j + 1 - if (j == patch_size + 1) then - exit - end if - end if - end do - - dim = positions%dim - loc = ele_loc(field, ele) - ngi = ele_ngi(field, ele) - - allocate(detwei(patch_size, ngi)) - allocate(dm_t(patch_size, loc, ngi, dim)) - allocate(ele_gradient(patch_size, dim)) - - ! and compute their shape function derivatives etc. - ! Note: this is grossly inefficient, but I don't see how to do it any better - ! yet. - do i=1,size(patch_elements) - neighbour = patch_elements(i) - assert(neighbour <= ele_count(field)) - call transform_to_physical(positions, neighbour, & - ele_shape(field, neighbour), & - detwei=detwei(i, :), dshape=dm_t(i, :, :, :)) - end do - - ! Step (a): compute recovered gradient - recovered_gradient = 0.0 - patch_volume = 0.0 - do i=1,size(patch_elements) - neighbour = patch_elements(i) - patch_volume = patch_volume + sum(detwei(i, :)) - - r = dshape_rhs(dm_t(i, :, :, :), detwei(i, :)) - ele_gradient(i, :) = matmul(r, ele_val(field, neighbour)) / sum(detwei(i, :)) - - ! and now do a weighted average to recover the approximate gradient: - recovered_gradient = recovered_gradient + sum(detwei(i, :)) * ele_gradient(i,:) - end do - recovered_gradient = recovered_gradient / patch_volume - - ! Step (b): compute e_k and g_k and g_hat_k - g = 0.0 - do i=1,size(patch_elements) - neighbour = patch_elements(i) - error_at_quad = spread(recovered_gradient, 2, size(error_at_quad, 2)) - & - matmul(reshape(ele_gradient(i, :), (/dim, 1/)), pwc_shape%n) - - do gi=1,ngi - forall(idim=1:dim,jdim=1:dim) - g_int(idim, jdim) = error_at_quad(idim, gi) * error_at_quad(jdim, gi) - end forall - g = g + g_int * detwei(i, gi) + eta = (sum_eta * (1.0/product(lambda_k))**(2.0/dim)) + assert(.not. is_nan(eta)) + + ! step (g): compute r + out_evecs = compute_out_evecs(sorted_g_evecs) + + ! and compute lambda + out_edges = compute_edge_lengths(tau, ele_count(positions), transformed_patch_volume, sorted_g_evals) + assert(all(out_edges > 0.0)) + out_evals = eigenvalue_from_edge_length(out_edges) + + call eigenrecomposition(out_k, out_evecs, out_evals) + + out_k = weight * (omega * out_k + (1.0-omega)*m_k) + + call set(pwc_metric, ele, out_k) + end subroutine anisotropic_zz_element_metric + + function compute_edge_lengths(tau, eles, vol, g_evals) result(edges) + real, intent(in) :: tau + integer, intent(in) :: eles + real, intent(in) :: vol + real, dimension(:), intent(in) :: g_evals + real, dimension(size(g_evals)) :: edges, modified_g_evals, min_g + real :: factor_a, factor_b, factor_c + real, dimension(size(domain_bbox,1)) :: domain_width + real :: max_length + + integer :: dim, i, j + + dim = size(g_evals) + + ! FIXME: make this more general by computing + ! max_length as the diameter of the domain. + assert(bounding_box_initialised) + do i = 1, size(domain_bbox,1) + domain_width(i) = abs(domain_bbox(i,2)-domain_bbox(i,1)) end do - end do - g_hat = g / patch_volume - - if (present(patch_vol)) then - patch_vol = patch_volume - end if - end function compute_g_hat - - function get_jacobian_azz(positions, ele) result(J) - !! This returns the jacobian of the affine map mapping from - !! the ideal element used in these calculations, which - !! is the element inscribed on the unit circle/sphere. - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - real, dimension(mesh_dim(positions), mesh_dim(positions)) :: J, mapped_pos, ideal_pos, ideal_pos_inv - integer :: dim - real, dimension(mesh_dim(positions), ele_loc(positions, ele)) :: val - real, dimension(mesh_dim(positions)) :: t_k - integer :: i - - real :: a, b, c - - val = ele_val(positions, ele) - dim = mesh_dim(positions) - if (dim == 2) then - J(1, 1) = (val(1, 2) - val(1, 1))/sqrt(3.0) - J(1, 2) = (2*val(1, 3) - val(1, 1) - val(1, 2))/3.0 - J(2, 1) = (val(2, 2) - val(2, 1))/sqrt(3.0) - J(2, 2) = (2*val(2, 3) - val(2, 1) - val(2, 2))/3.0 - else - ! We are trying to compute the Jacobian mapping - ! the ideal element to the element we have, see? - ! So, something like: - ! (physical coords) = J * (ideal coords) + translation - ! here, we write down the locations of 3 points of the tet - ! in ideal coordinates: - a = sqrt(2.0/3.0); b = sqrt(2.0)/3.0; c = 1.0/3.0 - ideal_pos(:, 1) = (/-a, -b, -c/) - ideal_pos(:, 2) = (/a, -b, -c/) - ideal_pos(:, 3) = (/0.0, 2.0*b, -c/) - - ! And its inverse, symbolically calculated thanks to sympy: - ideal_pos_inv(:, 1) = (/-0.5/a, 0.5/a, 0.0/) - ideal_pos_inv(:, 2) = (/(-1.0/6.0)/b, (-1.0/6.0)/b, (1.0/3.0)/b/) - ideal_pos_inv(:, 3) = (/(-1.0/3.0)/c, (-1.0/3.0)/c, (-1.0/3.0)/c/) - - ! We compute the translation taking the centre to the origin: + max_length = maxval(domain_width) + factor_a = ((tau**2) / (dim*eles*vol))**(1.0/dim) + assert(factor_a > 0.0) + min_g = (max_length / factor_a)**(-1.0 * dim) + modified_g_evals = max(g_evals, min_g) + do i=1,dim - t_k(i) = sum(val(i, :)) / 4.0 + j = dim - i + 1 + ! take a deep breath: + factor_b = 1.0/sqrt(modified_g_evals(j)) + factor_c = (product(modified_g_evals))**((dim - 2.0) / (2.0*dim*dim)) + if (dim == 2) then + assert(factor_c == 1.0) + end if + + assert(factor_b > 0.0) + assert(factor_c > 0.0) + edges(i) = factor_a * factor_b * factor_c + if (is_nan(edges(i)) .or. edges(i) > max_length) then + edges(i) = max_length + end if end do + end function compute_edge_lengths + + function compute_out_evecs(g_evecs) result(out_evecs) + real, dimension(:, :), intent(in) :: g_evecs + real, dimension(size(g_evecs, 1), size(g_evecs, 1)) :: out_evecs + integer :: dim + integer :: i, j - ! And then perform the inverse translation: + dim = size(g_evecs, 1) do i=1,dim - mapped_pos(:, i) = val(:, i) - t_k + j = dim - i + 1 + out_evecs(:, i) = g_evecs(:, j) + end do + end function compute_out_evecs + + function compute_g_hat(field, positions, pwc_shape, ele, patch_vol, patch_count) result(g_hat) + type(scalar_field), intent(in) :: field + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: pwc_shape + integer, intent(in) :: ele + real, optional, intent(out) :: patch_vol + integer, optional, intent(out) :: patch_count + + real, dimension(positions%dim) :: recovered_gradient + real, dimension(positions%dim, ele_ngi(field, ele)) :: error_at_quad + real, dimension(positions%dim, positions%dim) :: g, g_hat, g_int + real, dimension(positions%dim, ele_loc(field, ele)) :: r + + + integer :: i, neighbour + real :: patch_volume + integer :: gi, idim, jdim + integer :: dim, loc, ngi + logical, dimension(ele_count(positions)) :: seen_elements + real, dimension(:, :), allocatable :: ele_gradient, detwei + real, dimension(:, :, :, :), allocatable :: dm_t + integer :: patch_size + integer, dimension(:), allocatable :: patch_elements + integer, dimension(:), pointer :: neighbours, nodes + integer :: j + + ! Oh! For the want of a fecking set union in Fortran. + + ! Let's compute the patch around. + + seen_elements = .false. + nodes => ele_nodes(positions, ele) + assert(associated(positions%mesh%adj_lists)) + assert(associated(positions%mesh%adj_lists%nelist)) + do i=1,ele_loc(positions, ele) + neighbours => row_m_ptr(positions%mesh%adj_lists%nelist, nodes(i)) + do j=1,size(neighbours) + seen_elements(neighbours(j)) = .true. + end do end do - ! And now we have the eqn: - ! J * (ideal_coords) = (physical coords) - translation - ! so, to solve this, we multiply on the right by - ! the inverse of the ideal coordinates matrix: - J = matmul(mapped_pos, ideal_pos_inv) - end if - end function get_jacobian_azz + patch_size = count(seen_elements) + + if (present(patch_count)) then + patch_count = patch_size + end if + + allocate(patch_elements(patch_size)) + j = 1 + do i=1,size(seen_elements) + if (seen_elements(i)) then + patch_elements(j) = i + j = j + 1 + if (j == patch_size + 1) then + exit + end if + end if + end do + + dim = positions%dim + loc = ele_loc(field, ele) + ngi = ele_ngi(field, ele) + + allocate(detwei(patch_size, ngi)) + allocate(dm_t(patch_size, loc, ngi, dim)) + allocate(ele_gradient(patch_size, dim)) + + ! and compute their shape function derivatives etc. + ! Note: this is grossly inefficient, but I don't see how to do it any better + ! yet. + do i=1,size(patch_elements) + neighbour = patch_elements(i) + assert(neighbour <= ele_count(field)) + call transform_to_physical(positions, neighbour, & + ele_shape(field, neighbour), & + detwei=detwei(i, :), dshape=dm_t(i, :, :, :)) + end do + + ! Step (a): compute recovered gradient + recovered_gradient = 0.0 + patch_volume = 0.0 + do i=1,size(patch_elements) + neighbour = patch_elements(i) + patch_volume = patch_volume + sum(detwei(i, :)) + + r = dshape_rhs(dm_t(i, :, :, :), detwei(i, :)) + ele_gradient(i, :) = matmul(r, ele_val(field, neighbour)) / sum(detwei(i, :)) + + ! and now do a weighted average to recover the approximate gradient: + recovered_gradient = recovered_gradient + sum(detwei(i, :)) * ele_gradient(i,:) + end do + recovered_gradient = recovered_gradient / patch_volume + + ! Step (b): compute e_k and g_k and g_hat_k + g = 0.0 + do i=1,size(patch_elements) + neighbour = patch_elements(i) + error_at_quad = spread(recovered_gradient, 2, size(error_at_quad, 2)) - & + matmul(reshape(ele_gradient(i, :), (/dim, 1/)), pwc_shape%n) + + do gi=1,ngi + forall(idim=1:dim,jdim=1:dim) + g_int(idim, jdim) = error_at_quad(idim, gi) * error_at_quad(jdim, gi) + end forall + g = g + g_int * detwei(i, gi) + end do + end do + g_hat = g / patch_volume + + if (present(patch_vol)) then + patch_vol = patch_volume + end if + end function compute_g_hat + + function get_jacobian_azz(positions, ele) result(J) + !! This returns the jacobian of the affine map mapping from + !! the ideal element used in these calculations, which + !! is the element inscribed on the unit circle/sphere. + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + real, dimension(mesh_dim(positions), mesh_dim(positions)) :: J, mapped_pos, ideal_pos, ideal_pos_inv + integer :: dim + real, dimension(mesh_dim(positions), ele_loc(positions, ele)) :: val + real, dimension(mesh_dim(positions)) :: t_k + integer :: i + + real :: a, b, c + + val = ele_val(positions, ele) + dim = mesh_dim(positions) + if (dim == 2) then + J(1, 1) = (val(1, 2) - val(1, 1))/sqrt(3.0) + J(1, 2) = (2*val(1, 3) - val(1, 1) - val(1, 2))/3.0 + J(2, 1) = (val(2, 2) - val(2, 1))/sqrt(3.0) + J(2, 2) = (2*val(2, 3) - val(2, 1) - val(2, 2))/3.0 + else + ! We are trying to compute the Jacobian mapping + ! the ideal element to the element we have, see? + ! So, something like: + ! (physical coords) = J * (ideal coords) + translation + ! here, we write down the locations of 3 points of the tet + ! in ideal coordinates: + a = sqrt(2.0/3.0); b = sqrt(2.0)/3.0; c = 1.0/3.0 + ideal_pos(:, 1) = (/-a, -b, -c/) + ideal_pos(:, 2) = (/a, -b, -c/) + ideal_pos(:, 3) = (/0.0, 2.0*b, -c/) + + ! And its inverse, symbolically calculated thanks to sympy: + ideal_pos_inv(:, 1) = (/-0.5/a, 0.5/a, 0.0/) + ideal_pos_inv(:, 2) = (/(-1.0/6.0)/b, (-1.0/6.0)/b, (1.0/3.0)/b/) + ideal_pos_inv(:, 3) = (/(-1.0/3.0)/c, (-1.0/3.0)/c, (-1.0/3.0)/c/) + + ! We compute the translation taking the centre to the origin: + do i=1,dim + t_k(i) = sum(val(i, :)) / 4.0 + end do + + ! And then perform the inverse translation: + do i=1,dim + mapped_pos(:, i) = val(:, i) - t_k + end do + + ! And now we have the eqn: + ! J * (ideal_coords) = (physical coords) - translation + ! so, to solve this, we multiply on the right by + ! the inverse of the ideal coordinates matrix: + J = matmul(mapped_pos, ideal_pos_inv) + end if + end function get_jacobian_azz end module anisotropic_zz_module diff --git a/error_measures/Anisotropic_gradation_metric.F90 b/error_measures/Anisotropic_gradation_metric.F90 index db7b38202f..8923d3a03d 100644 --- a/error_measures/Anisotropic_gradation_metric.F90 +++ b/error_measures/Anisotropic_gradation_metric.F90 @@ -2,188 +2,188 @@ module anisotropic_gradation - use spud - use fldebug - use sparse_tools - use vector_tools - use adjacency_lists - use linked_lists - use unittest_tools, only: operator(.fne.) - use metric_tools - use fields - use state_module - use initialise_fields_module - use merge_tensors - use gradation_metric - use form_metric_field, only: bound_metric - - implicit none - - private - - public :: initialise_anisotropic_gradation - public :: form_anisotropic_gradation_metric - - logical, public :: use_anisotropic_gradation = .true. - - contains - - subroutine initialise_anisotropic_gradation - use_anisotropic_gradation = have_option("/mesh_adaptivity/hr_adaptivity/anisotropic_gradation") - end subroutine - - subroutine form_anisotropic_gradation_metric(metric, positions, state, noits, gamma_field) - type(tensor_field), intent(inout), target :: metric - type(vector_field), intent(in) :: positions - type(state_type), intent(in) :: state - integer, optional, intent(out) :: noits - type(tensor_field), optional, intent(in) :: gamma_field - - type(tensor_field) :: gamma - type(csr_sparsity), pointer :: nnlist_sparsity - type(csr_matrix) :: nnlist - type(elist) :: edge_list - - integer :: count, global_its, end_marker, p, q - logical :: changed_p, changed_q, is_constant - real :: dist - - type(mesh_type), pointer :: mesh - character(len=*), parameter :: path = "/mesh_adaptivity/hr_adaptivity/anisotropic_gradation/tensor_field::Gamma" - - real, dimension(positions%dim, positions%dim) :: val_gamma, val_p, val_q, grad, const_gamma, prev_grad - - integer :: stat - - ewrite(2,*) "Using anisotropic gradation algorithm" - mesh => metric%mesh - - if (present(gamma_field)) then - gamma = gamma_field - is_constant = (gamma%field_type == FIELD_TYPE_CONSTANT) - else - is_constant = (have_option(path // "/anisotropic_symmetric/constant")) - if (is_constant) then - call allocate(gamma, mesh, "Gamma", field_type=FIELD_TYPE_CONSTANT) - else - call allocate(gamma, mesh, "Gamma") - end if - call initialise_field(gamma, path, positions) - end if + use spud + use fldebug + use sparse_tools + use vector_tools + use adjacency_lists + use linked_lists + use unittest_tools, only: operator(.fne.) + use metric_tools + use fields + use state_module + use initialise_fields_module + use merge_tensors + use gradation_metric + use form_metric_field, only: bound_metric - const_gamma = node_val(gamma, 1) + implicit none - ! The same as the old gradation algorithm. We store whether a pair of nodes - ! is in the edge_list by marking nnlist(i, j) < 0 if it is not in the list - ! and > 0 if it is. + private - nnlist_sparsity => extract_nnlist(mesh) - call allocate(nnlist, sparsity=nnlist_sparsity, type=CSR_INTEGER, name="NodeNodeList") - nnlist%ival = -1 - call construct_edge_list(mesh, nnlist, edge_list) + public :: initialise_anisotropic_gradation + public :: form_anisotropic_gradation_metric - end_marker = edge_list%length - global_its = 0 + logical, public :: use_anisotropic_gradation = .true. - do while (edge_list%length /= 0) +contains - end_marker = end_marker - 1 - if (end_marker == 0) then - global_its = global_its + 1 - end_marker = edge_list%length - end if + subroutine initialise_anisotropic_gradation + use_anisotropic_gradation = have_option("/mesh_adaptivity/hr_adaptivity/anisotropic_gradation") + end subroutine - changed_p = .false. - changed_q = .false. + subroutine form_anisotropic_gradation_metric(metric, positions, state, noits, gamma_field) + type(tensor_field), intent(inout), target :: metric + type(vector_field), intent(in) :: positions + type(state_type), intent(in) :: state + integer, optional, intent(out) :: noits + type(tensor_field), optional, intent(in) :: gamma_field - call wrap_pop(nnlist, edge_list, p, q, count) + type(tensor_field) :: gamma + type(csr_sparsity), pointer :: nnlist_sparsity + type(csr_matrix) :: nnlist + type(elist) :: edge_list - dist = distance(positions, p, q) + integer :: count, global_its, end_marker, p, q + logical :: changed_p, changed_q, is_constant + real :: dist - val_p = edge_lengths_from_metric(node_val(metric, p)) - val_q = edge_lengths_from_metric(node_val(metric, q)) + type(mesh_type), pointer :: mesh + character(len=*), parameter :: path = "/mesh_adaptivity/hr_adaptivity/anisotropic_gradation/tensor_field::Gamma" - if (is_constant) then - val_gamma = const_gamma - else - val_gamma = (node_val(gamma, p) + node_val(gamma, q)) / 2.0 - end if - prev_grad = (val_q - val_p) / dist + real, dimension(positions%dim, positions%dim) :: val_gamma, val_p, val_q, grad, const_gamma, prev_grad - grad = anisotropic_min(prev_grad, val_gamma) - changed_q = (prev_grad .fne. grad) - if (changed_q) then - val_q = dist * grad + val_p - call set(metric, q, metric_from_edge_lengths(val_q)) - end if + integer :: stat - if (is_constant) then - val_gamma = const_gamma + ewrite(2,*) "Using anisotropic gradation algorithm" + mesh => metric%mesh + + if (present(gamma_field)) then + gamma = gamma_field + is_constant = (gamma%field_type == FIELD_TYPE_CONSTANT) else - val_gamma = (node_val(gamma, p) + node_val(gamma, q)) / 2.0 + is_constant = (have_option(path // "/anisotropic_symmetric/constant")) + if (is_constant) then + call allocate(gamma, mesh, "Gamma", field_type=FIELD_TYPE_CONSTANT) + else + call allocate(gamma, mesh, "Gamma") + end if + call initialise_field(gamma, path, positions) end if - prev_grad = (val_p - val_q) / dist - grad = anisotropic_min(prev_grad, val_gamma) - changed_p = (prev_grad .fne. grad) - if (changed_p) then - val_p = dist * grad + val_q - call set(metric, p, metric_from_edge_lengths(val_p)) + const_gamma = node_val(gamma, 1) + + ! The same as the old gradation algorithm. We store whether a pair of nodes + ! is in the edge_list by marking nnlist(i, j) < 0 if it is not in the list + ! and > 0 if it is. + + nnlist_sparsity => extract_nnlist(mesh) + call allocate(nnlist, sparsity=nnlist_sparsity, type=CSR_INTEGER, name="NodeNodeList") + nnlist%ival = -1 + call construct_edge_list(mesh, nnlist, edge_list) + + end_marker = edge_list%length + global_its = 0 + + do while (edge_list%length /= 0) + + end_marker = end_marker - 1 + if (end_marker == 0) then + global_its = global_its + 1 + end_marker = edge_list%length + end if + + changed_p = .false. + changed_q = .false. + + call wrap_pop(nnlist, edge_list, p, q, count) + + dist = distance(positions, p, q) + + val_p = edge_lengths_from_metric(node_val(metric, p)) + val_q = edge_lengths_from_metric(node_val(metric, q)) + + if (is_constant) then + val_gamma = const_gamma + else + val_gamma = (node_val(gamma, p) + node_val(gamma, q)) / 2.0 + end if + prev_grad = (val_q - val_p) / dist + + grad = anisotropic_min(prev_grad, val_gamma) + changed_q = (prev_grad .fne. grad) + if (changed_q) then + val_q = dist * grad + val_p + call set(metric, q, metric_from_edge_lengths(val_q)) + end if + + if (is_constant) then + val_gamma = const_gamma + else + val_gamma = (node_val(gamma, p) + node_val(gamma, q)) / 2.0 + end if + + prev_grad = (val_p - val_q) / dist + grad = anisotropic_min(prev_grad, val_gamma) + changed_p = (prev_grad .fne. grad) + if (changed_p) then + val_p = dist * grad + val_q + call set(metric, p, metric_from_edge_lengths(val_p)) + end if + + if (changed_p) then + call tag_edges(nnlist, edge_list, p, q, count) + end if + if (changed_q) then + call tag_edges(nnlist, edge_list, q, p, count) + end if + end do + + if (present(noits)) then + noits = global_its end if - if (changed_p) then - call tag_edges(nnlist, edge_list, p, q, count) + if (.not. present(gamma_field)) then + call deallocate(gamma) end if - if (changed_q) then - call tag_edges(nnlist, edge_list, q, p, count) + call deallocate(nnlist) + + call bound_metric(metric, state, stat=stat) + end subroutine + + function anisotropic_min(tensor1, tensor2) result(tensor3) + real, dimension(:, :), intent(in) :: tensor1, tensor2 + real, dimension(size(tensor1, 1), size(tensor1, 1)) :: tensor3, F, T, Finv, evecs + real, dimension(size(tensor1, 1)) :: evals, ones + integer :: i, dim + + dim = size(tensor1, 1) + ones = 1 + + if (all(tensor2 == 0.0)) then + call eigendecomposition_symmetric(tensor1, evecs, evals) + do i=1,dim + evals(i) = min(evals(i), 0.0) + end do + call eigenrecomposition(tensor3, evecs, evals) + return end if - end do - - if (present(noits)) then - noits = global_its - end if - if (.not. present(gamma_field)) then - call deallocate(gamma) - end if - call deallocate(nnlist) + ! So we are dealing with the non-degenerate case. - call bound_metric(metric, state, stat=stat) - end subroutine + call eigendecomposition_symmetric(tensor2, evecs, evals) + F = get_deformation_matrix(tensor2, evecs, evals) + Finv = inverse(F) - function anisotropic_min(tensor1, tensor2) result(tensor3) - real, dimension(:, :), intent(in) :: tensor1, tensor2 - real, dimension(size(tensor1, 1), size(tensor1, 1)) :: tensor3, F, T, Finv, evecs - real, dimension(size(tensor1, 1)) :: evals, ones - integer :: i, dim + T = transpose(Finv) + tensor3 = matmul(matmul(T, tensor1), transpose(T)) + call eigendecomposition_symmetric(tensor3, evecs, evals) - dim = size(tensor1, 1) - ones = 1 - - if (all(tensor2 == 0.0)) then - call eigendecomposition_symmetric(tensor1, evecs, evals) - do i=1,dim - evals(i) = min(evals(i), 0.0) - end do + evals = min(evals, ones) call eigenrecomposition(tensor3, evecs, evals) - return - end if - - ! So we are dealing with the non-degenerate case. - - call eigendecomposition_symmetric(tensor2, evecs, evals) - F = get_deformation_matrix(tensor2, evecs, evals) - Finv = inverse(F) - - T = transpose(Finv) - tensor3 = matmul(matmul(T, tensor1), transpose(T)) - call eigendecomposition_symmetric(tensor3, evecs, evals) - - evals = min(evals, ones) - call eigenrecomposition(tensor3, evecs, evals) - T = F - tensor3 = matmul(matmul(transpose(T), tensor3), T) - end function + T = F + tensor3 = matmul(matmul(transpose(T), tensor3), T) + end function end module anisotropic_gradation diff --git a/error_measures/Aspect_ratios.F90 b/error_measures/Aspect_ratios.F90 index f68d038502..866bc438cf 100644 --- a/error_measures/Aspect_ratios.F90 +++ b/error_measures/Aspect_ratios.F90 @@ -2,95 +2,95 @@ module aspect_ratios_module - use spud - use fldebug - use vector_tools - use metric_tools - use fields + use spud + use fldebug + use vector_tools + use metric_tools + use fields - implicit none + implicit none - private + private - public :: bound_metric_aspect_ratio, get_aspect_ratios + public :: bound_metric_aspect_ratio, get_aspect_ratios - interface bound_metric_aspect_ratio - module procedure bound_metric_aspect_ratio_options, & + interface bound_metric_aspect_ratio + module procedure bound_metric_aspect_ratio_options, & & bound_metric_aspect_ratio_ratio - end interface bound_metric_aspect_ratio + end interface bound_metric_aspect_ratio contains - subroutine bound_metric_aspect_ratio_options(metric) - !!< Apply a metric aspect ratio bound + subroutine bound_metric_aspect_ratio_options(metric) + !!< Apply a metric aspect ratio bound - type(tensor_field), intent(inout) :: metric + type(tensor_field), intent(inout) :: metric - integer :: stat - real :: aspect_ratio_bound + integer :: stat + real :: aspect_ratio_bound - call get_option("/mesh_adaptivity/hr_adaptivity/aspect_ratio_bound", aspect_ratio_bound, stat = stat) - if(stat /= SPUD_NO_ERROR) then - ewrite(1, *) "No aspect ratio bound" - return - end if + call get_option("/mesh_adaptivity/hr_adaptivity/aspect_ratio_bound", aspect_ratio_bound, stat = stat) + if(stat /= SPUD_NO_ERROR) then + ewrite(1, *) "No aspect ratio bound" + return + end if - if(aspect_ratio_bound <= 0.0) then - FLExit("Aspect ratio bound must be positive") - end if + if(aspect_ratio_bound <= 0.0) then + FLExit("Aspect ratio bound must be positive") + end if - call bound_metric_aspect_ratio(metric, aspect_ratio_bound) + call bound_metric_aspect_ratio(metric, aspect_ratio_bound) - end subroutine bound_metric_aspect_ratio_options + end subroutine bound_metric_aspect_ratio_options - subroutine bound_metric_aspect_ratio_ratio(metric, aspect_ratio_bound) - !!< Apply a metric aspect ratio bound + subroutine bound_metric_aspect_ratio_ratio(metric, aspect_ratio_bound) + !!< Apply a metric aspect ratio bound - type(tensor_field), intent(inout) :: metric - real, intent(in) :: aspect_ratio_bound + type(tensor_field), intent(inout) :: metric + real, intent(in) :: aspect_ratio_bound - integer :: i - real :: evals_ratio_bound - real, dimension(metric%dim(1)) :: evals - real, dimension(metric%dim(1), metric%dim(2)) :: evecs + integer :: i + real :: evals_ratio_bound + real, dimension(metric%dim(1)) :: evals + real, dimension(metric%dim(1), metric%dim(2)) :: evecs - ewrite(1, *) "In bound_metric_aspect_ratio_ratio" + ewrite(1, *) "In bound_metric_aspect_ratio_ratio" - ewrite(2, *) "Aspect ratio bound: ", aspect_ratio_bound - assert(aspect_ratio_bound > 0.0) + ewrite(2, *) "Aspect ratio bound: ", aspect_ratio_bound + assert(aspect_ratio_bound > 0.0) - if(aspect_ratio_bound < 1.0) then - evals_ratio_bound = aspect_ratio_bound ** 2 - else - evals_ratio_bound = (1.0 / aspect_ratio_bound) ** 2 - end if - ewrite(2, *) "Eigenvalues ratio bound: ", evals_ratio_bound + if(aspect_ratio_bound < 1.0) then + evals_ratio_bound = aspect_ratio_bound ** 2 + else + evals_ratio_bound = (1.0 / aspect_ratio_bound) ** 2 + end if + ewrite(2, *) "Eigenvalues ratio bound: ", evals_ratio_bound - do i = 1, node_count(metric) - call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) - evals = max(evals, evals_ratio_bound * maxval(evals)) - call eigenrecomposition(metric%val(:, :, i), evecs, evals) - end do + do i = 1, node_count(metric) + call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) + evals = max(evals, evals_ratio_bound * maxval(evals)) + call eigenrecomposition(metric%val(:, :, i), evecs, evals) + end do - ewrite(1, *) "Exiting bound_metric_aspect_ratio_ratio" + ewrite(1, *) "Exiting bound_metric_aspect_ratio_ratio" - end subroutine bound_metric_aspect_ratio_ratio + end subroutine bound_metric_aspect_ratio_ratio - subroutine get_aspect_ratios(metric, field) - !!< Given a metric, calculate the desired edge length - !!< at each node. - type(tensor_field), intent(in) :: metric - type(scalar_field), intent(inout) :: field - integer :: i, dim - real, dimension(mesh_dim(metric%mesh), mesh_dim(metric%mesh)) :: evectors - real, dimension(mesh_dim(metric%mesh)) :: evalues + subroutine get_aspect_ratios(metric, field) + !!< Given a metric, calculate the desired edge length + !!< at each node. + type(tensor_field), intent(in) :: metric + type(scalar_field), intent(inout) :: field + integer :: i, dim + real, dimension(mesh_dim(metric%mesh), mesh_dim(metric%mesh)) :: evectors + real, dimension(mesh_dim(metric%mesh)) :: evalues - dim = mesh_dim(metric%mesh) + dim = mesh_dim(metric%mesh) - do i=1,metric%mesh%nodes - call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) - field%val(i) = aspect_ratio(abs(evalues)) - end do - end subroutine get_aspect_ratios + do i=1,metric%mesh%nodes + call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) + field%val(i) = aspect_ratio(abs(evalues)) + end do + end subroutine get_aspect_ratios end module aspect_ratios_module diff --git a/error_measures/Assemble_metric.F90 b/error_measures/Assemble_metric.F90 index ab8116ebc4..72595094d6 100644 --- a/error_measures/Assemble_metric.F90 +++ b/error_measures/Assemble_metric.F90 @@ -2,396 +2,396 @@ module metric_assemble - use spud - use fldebug - use global_parameters, only: domain_bbox - use mpi_interfaces, only: mpi_allreduce - use parallel_tools - use sparse_tools - use quadrature - use elements - use metric_tools - use fields - use state_module - use field_options, only: get_coordinate_field - use vtk_interfaces - use merge_tensors - use halos - use surfacelabels - use node_boundary, only: initialise_boundcount - use field_derivatives - use form_metric_field - use edge_length_module - use aspect_ratios_module - use initialise_fields_module, only: initialise_field - use hadapt_advancing_front, only: create_columns_sparsity - use project_metric_to_surface_module, only: project_metric_to_surface - use interpolation_metric - use goals - use gradation_metric - use goal_metric - use bounding_box_metric - use boundary_metric - use geometric_constraints_metric - use limit_metric_module - use metric_advection - use anisotropic_gradation - use richardson_metric_module - use anisotropic_zz_module - use reference_meshes - use hadapt_metric_based_extrude, only: get_1d_mesh, recombine_metric, get_1d_tensor - - implicit none - - private - public :: assemble_metric, apply_vertical_gradation, apply_horizontal_gradation - - contains - - subroutine assemble_metric(state, error_metric) - !!< This routine drives the metric assembly logic, which is contained in - !!< other modules. - - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(inout) :: error_metric - - integer :: i, stat - - type(vector_field), pointer :: positions - integer, save :: adaptcnt = 0 - character(len=20) :: buf - logical :: debug_metric, vertically_structured_adaptivity, split_gradation - type(tensor_field), pointer :: max_tensor - - ewrite(2,*) "+: Assembling metric" - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - ! is this metric going to be collapsed in the vertical to do horizontal adaptivity with it? - vertically_structured_adaptivity = have_option("/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity") - ! are we waiting until later to apply the gradation? - split_gradation = have_option("/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/split_gradation") - - do i=1,size(state) - positions => extract_vector_field(state(i), "Coordinate", stat=stat) - if (stat == 0) exit - end do - - max_tensor => extract_tensor_field(state(1), "MinMetricEigenbound") - - if (debug_metric) then - do i=1,size(state) - write(buf, '(i0)') i + use spud + use fldebug + use global_parameters, only: domain_bbox + use mpi_interfaces, only: mpi_allreduce + use parallel_tools + use sparse_tools + use quadrature + use elements + use metric_tools + use fields + use state_module + use field_options, only: get_coordinate_field + use vtk_interfaces + use merge_tensors + use halos + use surfacelabels + use node_boundary, only: initialise_boundcount + use field_derivatives + use form_metric_field + use edge_length_module + use aspect_ratios_module + use initialise_fields_module, only: initialise_field + use hadapt_advancing_front, only: create_columns_sparsity + use project_metric_to_surface_module, only: project_metric_to_surface + use interpolation_metric + use goals + use gradation_metric + use goal_metric + use bounding_box_metric + use boundary_metric + use geometric_constraints_metric + use limit_metric_module + use metric_advection + use anisotropic_gradation + use richardson_metric_module + use anisotropic_zz_module + use reference_meshes + use hadapt_metric_based_extrude, only: get_1d_mesh, recombine_metric, get_1d_tensor + + implicit none + + private + public :: assemble_metric, apply_vertical_gradation, apply_horizontal_gradation + +contains + + subroutine assemble_metric(state, error_metric) + !!< This routine drives the metric assembly logic, which is contained in + !!< other modules. + + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(inout) :: error_metric + + integer :: i, stat + + type(vector_field), pointer :: positions + integer, save :: adaptcnt = 0 + character(len=20) :: buf + logical :: debug_metric, vertically_structured_adaptivity, split_gradation + type(tensor_field), pointer :: max_tensor + + ewrite(2,*) "+: Assembling metric" + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") + ! is this metric going to be collapsed in the vertical to do horizontal adaptivity with it? + vertically_structured_adaptivity = have_option("/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity") + ! are we waiting until later to apply the gradation? + split_gradation = have_option("/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/split_gradation") - call vtk_write_state(trim("metric_input_") // trim(buf),& - & adaptcnt, state=(/state(i)/)) + do i=1,size(state) + positions => extract_vector_field(state(i), "Coordinate", stat=stat) + if (stat == 0) exit end do - adaptcnt = adaptcnt + 1 - end if - call zero(error_metric) + max_tensor => extract_tensor_field(state(1), "MinMetricEigenbound") - call initialise_boundcount(error_metric%mesh, positions) + if (debug_metric) then + do i=1,size(state) + write(buf, '(i0)') i + + call vtk_write_state(trim("metric_input_") // trim(buf),& + & adaptcnt, state=(/state(i)/)) + end do + adaptcnt = adaptcnt + 1 + end if - call initialise_interpolation_metric - call initialise_goal_metric - call initialise_gradation_metric - call initialise_anisotropic_gradation - call initialise_bounding_box_metric - call initialise_boundary_metric - call initialise_geometric_constraints_metric - call initialise_metric_advection - call initialise_richardson_number_metric + call zero(error_metric) - if (use_goal_metric) then + call initialise_boundcount(error_metric%mesh, positions) + + call initialise_interpolation_metric + call initialise_goal_metric + call initialise_gradation_metric + call initialise_anisotropic_gradation + call initialise_bounding_box_metric + call initialise_boundary_metric + call initialise_geometric_constraints_metric + call initialise_metric_advection + call initialise_richardson_number_metric + + if (use_goal_metric) then ! ***** Note that the following interface causes issues with the Intel compiler. Changed for now as a workaround ****** ! call form_goal_metric(state, error_metric) - call form_goal_metric_generic(state, error_metric) + call form_goal_metric_generic(state, error_metric) ! ***** End of Intel compiler workaround ***** - call halo_update(error_metric) - else if (use_interpolation_metric) then - call form_interpolation_metric(state, error_metric) - call halo_update(error_metric) - call form_anisotropic_zz_metric(state, error_metric) - end if + call halo_update(error_metric) + else if (use_interpolation_metric) then + call form_interpolation_metric(state, error_metric) + call halo_update(error_metric) + call form_anisotropic_zz_metric(state, error_metric) + end if - if (use_richardson_number_metric) then - call form_richardson_number_metric(state, error_metric) - call halo_update(error_metric) - end if + if (use_richardson_number_metric) then + call form_richardson_number_metric(state, error_metric) + call halo_update(error_metric) + end if - if (use_boundary_metric) then - call form_boundary_metric(error_metric, positions) - call halo_update(error_metric) - end if + if (use_boundary_metric) then + call form_boundary_metric(error_metric, positions) + call halo_update(error_metric) + end if - call enforce_reference_meshes(state, positions, error_metric) + call enforce_reference_meshes(state, positions, error_metric) - if (use_geometric_constraints_metric) then - call form_geometric_constraints_metric(error_metric, state(1)) - call halo_update(error_metric) - end if + if (use_geometric_constraints_metric) then + call form_geometric_constraints_metric(error_metric, state(1)) + call halo_update(error_metric) + end if - ! gradation might be left until the metric is split into horizontal and vertical components - if(.not.split_gradation) then + ! gradation might be left until the metric is split into horizontal and vertical components + if(.not.split_gradation) then - call apply_gradation(error_metric, positions, state(1)) + call apply_gradation(error_metric, positions, state(1)) - end if + end if - if (use_metric_advection) then - call form_advection_metric(error_metric, state(1)) - call halo_update(error_metric) - end if + if (use_metric_advection) then + call form_advection_metric(error_metric, state(1)) + call halo_update(error_metric) + end if - if (use_bounding_box_metric) then - call form_bounding_box_metric(positions, error_metric, max_tensor) - call halo_update(error_metric) - end if + if (use_bounding_box_metric) then + call form_bounding_box_metric(positions, error_metric, max_tensor) + call halo_update(error_metric) + end if - call bound_metric_aspect_ratio(error_metric) - ! for vertically structured, the limiting should happen after the vertical collapsing - if (.not. vertically_structured_adaptivity) then - call limit_metric(positions, error_metric) - end if - call halo_update(error_metric) + call bound_metric_aspect_ratio(error_metric) + ! for vertically structured, the limiting should happen after the vertical collapsing + if (.not. vertically_structured_adaptivity) then + call limit_metric(positions, error_metric) + end if + call halo_update(error_metric) - end subroutine assemble_metric + end subroutine assemble_metric - subroutine apply_gradation(error_metric, positions, state, gamma) - type(tensor_field), intent(inout) :: error_metric - type(vector_field), intent(in) :: positions - type(state_type), intent(in) :: state - type(tensor_field), intent(in), optional :: gamma + subroutine apply_gradation(error_metric, positions, state, gamma) + type(tensor_field), intent(inout) :: error_metric + type(vector_field), intent(in) :: positions + type(state_type), intent(in) :: state + type(tensor_field), intent(in), optional :: gamma - integer :: noits, grad_count + integer :: noits, grad_count #ifdef HAVE_MPI - include 'mpif.h' - integer::noits_max, ierr + include 'mpif.h' + integer::noits_max, ierr #endif - if (use_anisotropic_gradation) then - call form_anisotropic_gradation_metric(error_metric, positions, state, gamma_field=gamma) - else if (use_gradation_metric) then - if (.not. isparallel()) then - call form_gradation_metric(positions, error_metric) - else - noits = 2 - grad_count = 0 - do while ((noits.gt.1).and.(grad_count.le.3)) - call form_gradation_metric(positions, error_metric, noits) - call halo_update(error_metric) - grad_count = grad_count + 1 + if (use_anisotropic_gradation) then + call form_anisotropic_gradation_metric(error_metric, positions, state, gamma_field=gamma) + else if (use_gradation_metric) then + if (.not. isparallel()) then + call form_gradation_metric(positions, error_metric) + else + noits = 2 + grad_count = 0 + do while ((noits.gt.1).and.(grad_count.le.3)) + call form_gradation_metric(positions, error_metric, noits) + call halo_update(error_metric) + grad_count = grad_count + 1 #ifdef HAVE_MPI - CALL MPI_Allreduce (noits, noits_max, 1, getpinteger(), MPI_MAX, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - noits = noits_max + CALL MPI_Allreduce (noits, noits_max, 1, getpinteger(), MPI_MAX, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + noits = noits_max #endif - end do + end do + end if end if - end if - end subroutine apply_gradation + end subroutine apply_gradation - subroutine apply_horizontal_gradation(state, horizontal_metric, full_metric, horizontal_positions) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: horizontal_metric - type(tensor_field), intent(in) :: full_metric - type(vector_field), intent(in) :: horizontal_positions + subroutine apply_horizontal_gradation(state, horizontal_metric, full_metric, horizontal_positions) + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: horizontal_metric + type(tensor_field), intent(in) :: full_metric + type(vector_field), intent(in) :: horizontal_positions - logical :: is_constant - type(tensor_field) :: full_gamma, horizontal_gamma - character(len=*), parameter :: path = "/mesh_adaptivity/hr_adaptivity/anisotropic_gradation/tensor_field::Gamma" - type(vector_field) :: full_positions + logical :: is_constant + type(tensor_field) :: full_gamma, horizontal_gamma + character(len=*), parameter :: path = "/mesh_adaptivity/hr_adaptivity/anisotropic_gradation/tensor_field::Gamma" + type(vector_field) :: full_positions - type(tensor_field), pointer :: min_bound, max_bound - type(tensor_field) :: horizontal_min_bound, horizontal_max_bound + type(tensor_field), pointer :: min_bound, max_bound + type(tensor_field) :: horizontal_min_bound, horizontal_max_bound - if(.not.(use_anisotropic_gradation.or.use_gradation_metric)) return + if(.not.(use_anisotropic_gradation.or.use_gradation_metric)) return - ewrite(1,*) 'in apply_horizontal_gradation' - - if (use_anisotropic_gradation) then - is_constant = have_option(path//"/anisotropic_symmetric/constant") - if (is_constant) then - call allocate(full_gamma, full_metric%mesh, "Gamma", field_type=FIELD_TYPE_CONSTANT) - else - call allocate(full_gamma, full_metric%mesh, "Gamma") - end if + ewrite(1,*) 'in apply_horizontal_gradation' - full_positions = get_coordinate_field(state, full_metric%mesh) - call initialise_field(full_gamma, path, full_positions) + if (use_anisotropic_gradation) then + is_constant = have_option(path//"/anisotropic_symmetric/constant") + if (is_constant) then + call allocate(full_gamma, full_metric%mesh, "Gamma", field_type=FIELD_TYPE_CONSTANT) + else + call allocate(full_gamma, full_metric%mesh, "Gamma") + end if - call project_metric_to_surface(full_gamma, horizontal_positions, horizontal_gamma) + full_positions = get_coordinate_field(state, full_metric%mesh) + call initialise_field(full_gamma, path, full_positions) - call apply_gradation(horizontal_metric, horizontal_positions, state, gamma=horizontal_gamma) + call project_metric_to_surface(full_gamma, horizontal_positions, horizontal_gamma) - call deallocate(full_gamma) - call deallocate(horizontal_gamma) - call deallocate(full_positions) + call apply_gradation(horizontal_metric, horizontal_positions, state, gamma=horizontal_gamma) - else - call apply_gradation(horizontal_metric, horizontal_positions, state) - end if + call deallocate(full_gamma) + call deallocate(horizontal_gamma) + call deallocate(full_positions) - if(use_anisotropic_gradation) then - ! bounding the metric won't have happened yet because the min and max - ! eigenbounds are the wrong size... so do it now! - ! (min and max refer to edge lengths, not eigenvalues) - min_bound => extract_tensor_field(state, "MaxMetricEigenbound") - max_bound => extract_tensor_field(state, "MinMetricEigenbound") - - call project_metric_to_surface(min_bound, horizontal_positions, horizontal_min_bound) - call project_metric_to_surface(max_bound, horizontal_positions, horizontal_max_bound) - - call bound_metric(horizontal_metric, horizontal_min_bound, horizontal_max_bound) - - call deallocate(horizontal_min_bound) - call deallocate(horizontal_max_bound) - end if - - end subroutine apply_horizontal_gradation - - subroutine apply_vertical_gradation(state, full_metric, full_positions, horizontal_positions) - type(state_type), intent(in) :: state - type(vector_field), intent(in) :: full_positions - type(tensor_field), intent(inout) :: full_metric - type(vector_field), intent(in) :: horizontal_positions - - integer :: column, node, i - type(csr_sparsity) :: back_columns - type(element_type) :: oned_shape - type(quadrature_type) :: oned_quad - integer :: quadrature_degree - integer, parameter :: loc=2 - type(vector_field) :: oned_positions - type(tensor_field) :: oned_metric - - logical :: is_constant - type(tensor_field) :: full_gamma, oned_gamma - character(len=*), parameter :: gamma_path = "/mesh_adaptivity/hr_adaptivity/anisotropic_gradation/tensor_field::Gamma" - character(len=*), parameter :: path = "/mesh_adaptivity/hr_adaptivity/" - - type(tensor_field) :: min_edge, max_edge - type(tensor_field) :: min_bound, max_bound - type(tensor_field) :: oned_min_bound, oned_max_bound - - if(.not.(use_anisotropic_gradation.or.use_gradation_metric)) return - - ewrite(1,*) 'in apply_vertical_gradation' - - call get_option("/geometry/quadrature/degree", quadrature_degree) - oned_quad = make_quadrature(vertices=loc, dim=1, degree=quadrature_degree) - oned_shape = make_element_shape(vertices=loc, dim=1, degree=1, quad=oned_quad) - call deallocate(oned_quad) - - call create_columns_sparsity(back_columns, full_positions%mesh) - - if (use_anisotropic_gradation) then - ! unfortunately there are a few things that we need that would normally be in state - ! but aren't at this stage... so allocate them and initialise them ourselves now - is_constant = have_option(gamma_path//"/anisotropic_symmetric/constant") - if (is_constant) then - call allocate(full_gamma, full_metric%mesh, "Gamma", field_type=FIELD_TYPE_CONSTANT) else - call allocate(full_gamma, full_metric%mesh, "Gamma") + call apply_gradation(horizontal_metric, horizontal_positions, state) end if - call initialise_field(full_gamma, gamma_path, full_positions) - - is_constant = (have_option(path // "/tensor_field::MinimumEdgeLengths/anisotropic_symmetric/constant")) - if (is_constant) then - call allocate(min_edge, full_metric%mesh, "MinimumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) - call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", full_positions) - call allocate(min_bound, full_metric%mesh, "MaxMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) - call set(min_bound, eigenvalue_from_edge_length(node_val(min_edge, 1))) - else - call allocate(min_edge, full_metric%mesh, "MinimumEdgeLengths") - call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", full_positions) - call allocate(min_bound, full_metric%mesh, "MaxMetricEigenbound") - do node=1,node_count(full_metric%mesh) - call set(min_bound, node, eigenvalue_from_edge_length(node_val(min_edge, node))) - end do - end if + if(use_anisotropic_gradation) then + ! bounding the metric won't have happened yet because the min and max + ! eigenbounds are the wrong size... so do it now! + ! (min and max refer to edge lengths, not eigenvalues) + min_bound => extract_tensor_field(state, "MaxMetricEigenbound") + max_bound => extract_tensor_field(state, "MinMetricEigenbound") - call deallocate(min_edge) + call project_metric_to_surface(min_bound, horizontal_positions, horizontal_min_bound) + call project_metric_to_surface(max_bound, horizontal_positions, horizontal_max_bound) - is_constant = (have_option(path // "/tensor_field::MaximumEdgeLengths/anisotropic_symmetric/constant")) - if (is_constant) then - call allocate(max_edge, full_metric%mesh, "MaximumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) - call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", full_positions) - call allocate(max_bound, full_metric%mesh, "MinMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) - call set(max_bound, eigenvalue_from_edge_length(node_val(max_edge, 1))) - else - call allocate(max_edge, full_metric%mesh, "MaximumEdgeLengths") - call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", full_positions) - call allocate(max_bound, full_metric%mesh, "MinMetricEigenbound") - do node=1,node_count(full_metric%mesh) - call set(max_bound, node, eigenvalue_from_edge_length(node_val(max_edge, node))) - end do - end if + call bound_metric(horizontal_metric, horizontal_min_bound, horizontal_max_bound) - if (mesh_periodic(full_metric)) then - do i=1, mesh_dim(full_metric) - if (minval(max_edge%val(i,i,:))<0.33*(domain_bbox(i,2)-domain_bbox(i,1))) then - ewrite(0,*) "WARNING: Your MaximumEdgeLengths size is bigger than a third of the domain size." - ewrite(0,*) "With periodic adaptivity this is probably not safe." - end if - end do + call deallocate(horizontal_min_bound) + call deallocate(horizontal_max_bound) end if - call deallocate(max_edge) + end subroutine apply_horizontal_gradation + + subroutine apply_vertical_gradation(state, full_metric, full_positions, horizontal_positions) + type(state_type), intent(in) :: state + type(vector_field), intent(in) :: full_positions + type(tensor_field), intent(inout) :: full_metric + type(vector_field), intent(in) :: horizontal_positions + + integer :: column, node, i + type(csr_sparsity) :: back_columns + type(element_type) :: oned_shape + type(quadrature_type) :: oned_quad + integer :: quadrature_degree + integer, parameter :: loc=2 + type(vector_field) :: oned_positions + type(tensor_field) :: oned_metric + + logical :: is_constant + type(tensor_field) :: full_gamma, oned_gamma + character(len=*), parameter :: gamma_path = "/mesh_adaptivity/hr_adaptivity/anisotropic_gradation/tensor_field::Gamma" + character(len=*), parameter :: path = "/mesh_adaptivity/hr_adaptivity/" + + type(tensor_field) :: min_edge, max_edge + type(tensor_field) :: min_bound, max_bound + type(tensor_field) :: oned_min_bound, oned_max_bound + + if(.not.(use_anisotropic_gradation.or.use_gradation_metric)) return + + ewrite(1,*) 'in apply_vertical_gradation' + + call get_option("/geometry/quadrature/degree", quadrature_degree) + oned_quad = make_quadrature(vertices=loc, dim=1, degree=quadrature_degree) + oned_shape = make_element_shape(vertices=loc, dim=1, degree=1, quad=oned_quad) + call deallocate(oned_quad) + + call create_columns_sparsity(back_columns, full_positions%mesh) + + if (use_anisotropic_gradation) then + ! unfortunately there are a few things that we need that would normally be in state + ! but aren't at this stage... so allocate them and initialise them ourselves now + is_constant = have_option(gamma_path//"/anisotropic_symmetric/constant") + if (is_constant) then + call allocate(full_gamma, full_metric%mesh, "Gamma", field_type=FIELD_TYPE_CONSTANT) + else + call allocate(full_gamma, full_metric%mesh, "Gamma") + end if + + call initialise_field(full_gamma, gamma_path, full_positions) + + is_constant = (have_option(path // "/tensor_field::MinimumEdgeLengths/anisotropic_symmetric/constant")) + if (is_constant) then + call allocate(min_edge, full_metric%mesh, "MinimumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) + call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", full_positions) + call allocate(min_bound, full_metric%mesh, "MaxMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) + call set(min_bound, eigenvalue_from_edge_length(node_val(min_edge, 1))) + else + call allocate(min_edge, full_metric%mesh, "MinimumEdgeLengths") + call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", full_positions) + call allocate(min_bound, full_metric%mesh, "MaxMetricEigenbound") + do node=1,node_count(full_metric%mesh) + call set(min_bound, node, eigenvalue_from_edge_length(node_val(min_edge, node))) + end do + end if + + call deallocate(min_edge) + + is_constant = (have_option(path // "/tensor_field::MaximumEdgeLengths/anisotropic_symmetric/constant")) + if (is_constant) then + call allocate(max_edge, full_metric%mesh, "MaximumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) + call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", full_positions) + call allocate(max_bound, full_metric%mesh, "MinMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) + call set(max_bound, eigenvalue_from_edge_length(node_val(max_edge, 1))) + else + call allocate(max_edge, full_metric%mesh, "MaximumEdgeLengths") + call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", full_positions) + call allocate(max_bound, full_metric%mesh, "MinMetricEigenbound") + do node=1,node_count(full_metric%mesh) + call set(max_bound, node, eigenvalue_from_edge_length(node_val(max_edge, node))) + end do + end if + + if (mesh_periodic(full_metric)) then + do i=1, mesh_dim(full_metric) + if (minval(max_edge%val(i,i,:))<0.33*(domain_bbox(i,2)-domain_bbox(i,1))) then + ewrite(0,*) "WARNING: Your MaximumEdgeLengths size is bigger than a third of the domain size." + ewrite(0,*) "With periodic adaptivity this is probably not safe." + end if + end do + end if + + call deallocate(max_edge) - end if + end if - do column=1,node_count(horizontal_positions) - if(use_anisotropic_gradation) then - call get_1d_mesh(column, full_positions, back_columns, full_metric, oned_shape, oned_positions) + do column=1,node_count(horizontal_positions) + if(use_anisotropic_gradation) then + call get_1d_mesh(column, full_positions, back_columns, full_metric, oned_shape, oned_positions) - call allocate(oned_metric, oned_positions%mesh, "1DMetric") - call allocate(oned_gamma, oned_positions%mesh, "1DGamma", field_type=full_gamma%field_type) - call get_1d_tensor(column, full_metric, oned_metric, back_columns) - call get_1d_tensor(column, full_gamma, oned_gamma, back_columns) + call allocate(oned_metric, oned_positions%mesh, "1DMetric") + call allocate(oned_gamma, oned_positions%mesh, "1DGamma", field_type=full_gamma%field_type) + call get_1d_tensor(column, full_metric, oned_metric, back_columns) + call get_1d_tensor(column, full_gamma, oned_gamma, back_columns) - call apply_gradation(oned_metric, oned_positions, state, gamma=oned_gamma) + call apply_gradation(oned_metric, oned_positions, state, gamma=oned_gamma) - call deallocate(oned_gamma) + call deallocate(oned_gamma) - ! bounding the metric won't have happened yet because the min and max - ! eigenbounds are the wrong size (and they weren't in state)... so do it now! - ! (min and max refer to edge lengths, not eigenvalues) - call allocate(oned_min_bound, oned_positions%mesh, "1DMaxMetricEigenbound", field_type=min_bound%field_type) - call allocate(oned_max_bound, oned_positions%mesh, "1DMinMetricEigenbound", field_type=max_bound%field_type) - call get_1d_tensor(column, min_bound, oned_min_bound, back_columns) - call get_1d_tensor(column, max_bound, oned_max_bound, back_columns) + ! bounding the metric won't have happened yet because the min and max + ! eigenbounds are the wrong size (and they weren't in state)... so do it now! + ! (min and max refer to edge lengths, not eigenvalues) + call allocate(oned_min_bound, oned_positions%mesh, "1DMaxMetricEigenbound", field_type=min_bound%field_type) + call allocate(oned_max_bound, oned_positions%mesh, "1DMinMetricEigenbound", field_type=max_bound%field_type) + call get_1d_tensor(column, min_bound, oned_min_bound, back_columns) + call get_1d_tensor(column, max_bound, oned_max_bound, back_columns) - call bound_metric(oned_metric, oned_min_bound, oned_max_bound) + call bound_metric(oned_metric, oned_min_bound, oned_max_bound) - call deallocate(oned_min_bound) - call deallocate(oned_max_bound) - else - call get_1d_mesh(column, full_positions, back_columns, full_metric, oned_shape, oned_positions) + call deallocate(oned_min_bound) + call deallocate(oned_max_bound) + else + call get_1d_mesh(column, full_positions, back_columns, full_metric, oned_shape, oned_positions) - call allocate(oned_metric, oned_positions%mesh, "1DMetric") + call allocate(oned_metric, oned_positions%mesh, "1DMetric") - call get_1d_tensor(column, full_metric, oned_metric, back_columns) + call get_1d_tensor(column, full_metric, oned_metric, back_columns) - call apply_gradation(oned_metric, oned_positions, state) - end if + call apply_gradation(oned_metric, oned_positions, state) + end if - call recombine_metric(full_metric, column, oned_metric, back_columns) + call recombine_metric(full_metric, column, oned_metric, back_columns) - call deallocate(oned_positions) - call deallocate(oned_metric) - end do + call deallocate(oned_positions) + call deallocate(oned_metric) + end do - if (use_anisotropic_gradation) then - call deallocate(full_gamma) - call deallocate(min_bound) - call deallocate(max_bound) - end if - call deallocate(back_columns) - call deallocate(oned_shape) + if (use_anisotropic_gradation) then + call deallocate(full_gamma) + call deallocate(min_bound) + call deallocate(max_bound) + end if + call deallocate(back_columns) + call deallocate(oned_shape) - end subroutine apply_vertical_gradation + end subroutine apply_vertical_gradation end module metric_assemble diff --git a/error_measures/Boundary_metric.F90 b/error_measures/Boundary_metric.F90 index 5f41184e98..bb8b9aaa83 100644 --- a/error_measures/Boundary_metric.F90 +++ b/error_measures/Boundary_metric.F90 @@ -2,42 +2,42 @@ module boundary_metric - use global_parameters, only: domain_bbox - use unittest_tools, only: get_mat_diag - use fields - use node_boundary, only: initialise_boundcount, node_lies_on_boundary + use global_parameters, only: domain_bbox + use unittest_tools, only: get_mat_diag + use fields + use node_boundary, only: initialise_boundcount, node_lies_on_boundary - implicit none + implicit none - private + private - public :: initialise_boundary_metric, form_boundary_metric + public :: initialise_boundary_metric, form_boundary_metric - logical, public, save :: use_boundary_metric = .false. + logical, public, save :: use_boundary_metric = .false. - contains +contains - subroutine initialise_boundary_metric - use_boundary_metric = .false. - end subroutine + subroutine initialise_boundary_metric + use_boundary_metric = .false. + end subroutine - subroutine form_boundary_metric(error_metric, positions) - type(tensor_field), intent(inout) :: error_metric - type(vector_field), intent(in) :: positions - integer :: i, node - real, dimension(positions%dim) :: domain_width + subroutine form_boundary_metric(error_metric, positions) + type(tensor_field), intent(inout) :: error_metric + type(vector_field), intent(in) :: positions + integer :: i, node + real, dimension(positions%dim) :: domain_width - call initialise_boundcount(error_metric%mesh, positions) + call initialise_boundcount(error_metric%mesh, positions) - do i=1,positions%dim - domain_width(i) = abs(domain_bbox(i,2)-domain_bbox(i,1)) - end do + do i=1,positions%dim + domain_width(i) = abs(domain_bbox(i,2)-domain_bbox(i,1)) + end do - do node=1,node_count(error_metric) - if (node_lies_on_boundary(node)) then - error_metric%val(:, :, node) = get_mat_diag(domain_width) - end if - end do - end subroutine form_boundary_metric + do node=1,node_count(error_metric) + if (node_lies_on_boundary(node)) then + error_metric%val(:, :, node) = get_mat_diag(domain_width) + end if + end do + end subroutine form_boundary_metric end module boundary_metric diff --git a/error_measures/Bounding_box_metric.F90 b/error_measures/Bounding_box_metric.F90 index 4a27175b93..56563e0100 100644 --- a/error_measures/Bounding_box_metric.F90 +++ b/error_measures/Bounding_box_metric.F90 @@ -7,84 +7,84 @@ module bounding_box_metric !!< for the domain. Adaptivity really, really !!< doesn't like it, otherwise. - use spud - use fldebug - use global_parameters, only: domain_bbox - use unittest_tools - use metric_tools - use fields - use vtk_interfaces - use edge_length_module - use merge_tensors - - implicit none - - private - - public :: initialise_bounding_box_metric, form_bounding_box_metric,& - use_bounding_box_metric, bounding_box_initialised - - logical, save :: use_bounding_box_metric = .true. - logical, save :: bounding_box_initialised = .false. - real :: width_factor = 2.0 - - contains - - subroutine initialise_bounding_box_metric - - if (.not. bounding_box_initialised) then - use_bounding_box_metric = .true. - if (have_option("/mesh_adaptivity/hr_adaptivity/bounding_box_factor")) then - call get_option("/mesh_adaptivity/hr_adaptivity/bounding_box_factor", width_factor) - else - width_factor = 2.0 + use spud + use fldebug + use global_parameters, only: domain_bbox + use unittest_tools + use metric_tools + use fields + use vtk_interfaces + use edge_length_module + use merge_tensors + + implicit none + + private + + public :: initialise_bounding_box_metric, form_bounding_box_metric,& + use_bounding_box_metric, bounding_box_initialised + + logical, save :: use_bounding_box_metric = .true. + logical, save :: bounding_box_initialised = .false. + real :: width_factor = 2.0 + +contains + + subroutine initialise_bounding_box_metric + + if (.not. bounding_box_initialised) then + use_bounding_box_metric = .true. + if (have_option("/mesh_adaptivity/hr_adaptivity/bounding_box_factor")) then + call get_option("/mesh_adaptivity/hr_adaptivity/bounding_box_factor", width_factor) + else + width_factor = 2.0 + end if + bounding_box_initialised = .true. end if - bounding_box_initialised = .true. - end if - - end subroutine initialise_bounding_box_metric - - subroutine form_bounding_box_metric(positions, error_metric, max_metric) - type(tensor_field), intent(inout) :: error_metric !!< The metric formed so far - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: max_metric - - real, dimension(positions%dim, positions%dim) :: domain_metric - integer :: i - integer, save :: adaptcnt = 0 - real, dimension(positions%dim) :: domain_width - - type(scalar_field) :: edgelen - logical :: debug_metric - real, dimension(positions%dim, positions%dim) :: max_metric_nodes - - ewrite(2,*) "++: Constraining metric to bounding box" - - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - - do i = 1, positions%dim - domain_width(i) = abs(domain_bbox(i,2) - domain_bbox(i,1)) - end do - domain_width = width_factor * domain_width - domain_width = eigenvalue_from_edge_length(domain_width) - - ! Now make the diagonal matrix out of it and merge. - do i=1,error_metric%mesh%nodes - domain_metric = get_mat_diag(domain_width) ! domain_metric might change in merge_tensor - call merge_tensor(error_metric%val(:, :, i), domain_metric) - max_metric_nodes = node_val(max_metric, i) - call merge_tensor(error_metric%val(:, :, i), max_metric_nodes) - end do - - if (debug_metric) then - call allocate(edgelen, error_metric%mesh, "Desired edge lengths") - call get_edge_lengths(error_metric, edgelen) - call vtk_write_fields("bounding_box", adaptcnt, positions, positions%mesh, & - sfields=(/edgelen/), tfields=(/error_metric, max_metric/)) - call deallocate(edgelen) - endif - - adaptcnt = adaptcnt + 1 - end subroutine form_bounding_box_metric + + end subroutine initialise_bounding_box_metric + + subroutine form_bounding_box_metric(positions, error_metric, max_metric) + type(tensor_field), intent(inout) :: error_metric !!< The metric formed so far + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: max_metric + + real, dimension(positions%dim, positions%dim) :: domain_metric + integer :: i + integer, save :: adaptcnt = 0 + real, dimension(positions%dim) :: domain_width + + type(scalar_field) :: edgelen + logical :: debug_metric + real, dimension(positions%dim, positions%dim) :: max_metric_nodes + + ewrite(2,*) "++: Constraining metric to bounding box" + + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") + + do i = 1, positions%dim + domain_width(i) = abs(domain_bbox(i,2) - domain_bbox(i,1)) + end do + domain_width = width_factor * domain_width + domain_width = eigenvalue_from_edge_length(domain_width) + + ! Now make the diagonal matrix out of it and merge. + do i=1,error_metric%mesh%nodes + domain_metric = get_mat_diag(domain_width) ! domain_metric might change in merge_tensor + call merge_tensor(error_metric%val(:, :, i), domain_metric) + max_metric_nodes = node_val(max_metric, i) + call merge_tensor(error_metric%val(:, :, i), max_metric_nodes) + end do + + if (debug_metric) then + call allocate(edgelen, error_metric%mesh, "Desired edge lengths") + call get_edge_lengths(error_metric, edgelen) + call vtk_write_fields("bounding_box", adaptcnt, positions, positions%mesh, & + sfields=(/edgelen/), tfields=(/error_metric, max_metric/)) + call deallocate(edgelen) + endif + + adaptcnt = adaptcnt + 1 + end subroutine form_bounding_box_metric end module bounding_box_metric diff --git a/error_measures/Conformity_measurement.F90 b/error_measures/Conformity_measurement.F90 index 1de24d7dc7..4bb71791ec 100644 --- a/error_measures/Conformity_measurement.F90 +++ b/error_measures/Conformity_measurement.F90 @@ -7,79 +7,79 @@ module conformity_measurement !! International Journal for Numerical Methods in Engineering !! 2004, vol 61, issue 15 - use vector_tools - use sparse_tools - use transform_elements - use unittest_tools - use fetools - use metric_tools - use fields - use state_module - use fefields - use meshdiagnostics - use merge_tensors - use limit_metric_module - - implicit none - - private - public :: elemental_metric, compute_mesh_conformity, insert_mesh_conformity, & - & compute_mesh_metric, metric_ratio_bounds, project_p0_metric_p1 - - contains - - function elemental_metric(metric, positions, ele) result(m) - type(tensor_field), intent(in) :: metric - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - real, dimension(metric%dim(1), metric%dim(2)) :: m - real, dimension(metric%dim(1), metric%dim(2), ele_ngi(metric, ele)) :: A - real, dimension(ele_ngi(metric, ele)) :: detwei - type(element_type), pointer :: t_shape - integer :: i, j, dim - - t_shape => ele_shape(metric, ele) - - call transform_to_physical(positions, ele, detwei=detwei) - - A = ele_val_at_quad(metric, ele) - - dim = positions%dim - do i=1,dim - do j=1,dim - m(i, j) = dot_product(A(i, j, :), detwei) + use vector_tools + use sparse_tools + use transform_elements + use unittest_tools + use fetools + use metric_tools + use fields + use state_module + use fefields + use meshdiagnostics + use merge_tensors + use limit_metric_module + + implicit none + + private + public :: elemental_metric, compute_mesh_conformity, insert_mesh_conformity, & + & compute_mesh_metric, metric_ratio_bounds, project_p0_metric_p1 + +contains + + function elemental_metric(metric, positions, ele) result(m) + type(tensor_field), intent(in) :: metric + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + real, dimension(metric%dim(1), metric%dim(2)) :: m + real, dimension(metric%dim(1), metric%dim(2), ele_ngi(metric, ele)) :: A + real, dimension(ele_ngi(metric, ele)) :: detwei + type(element_type), pointer :: t_shape + integer :: i, j, dim + + t_shape => ele_shape(metric, ele) + + call transform_to_physical(positions, ele, detwei=detwei) + + A = ele_val_at_quad(metric, ele) + + dim = positions%dim + do i=1,dim + do j=1,dim + m(i, j) = dot_product(A(i, j, :), detwei) + end do end do - end do - ! sum(detwei) is the volume. + ! sum(detwei) is the volume. - m = m / sum(detwei) + m = m / sum(detwei) - end function elemental_metric + end function elemental_metric - subroutine compute_mesh_conformity(metric, positions, conformity) - type(tensor_field), intent(in) :: metric - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: conformity + subroutine compute_mesh_conformity(metric, positions, conformity) + type(tensor_field), intent(in) :: metric + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: conformity - integer :: ele - real, dimension(positions%dim, positions%dim) :: A, B, R, invA, invB, I + integer :: ele + real, dimension(positions%dim, positions%dim) :: A, B, R, invA, invB, I - ! conformity is a piecewise constant scalar field: - assert(ele_loc(conformity, 1) == 1) + ! conformity is a piecewise constant scalar field: + assert(ele_loc(conformity, 1) == 1) - I = get_matrix_identity(positions%dim) + I = get_matrix_identity(positions%dim) - do ele=1,ele_count(positions) - A = simplex_tensor(positions, ele) - B = elemental_metric(metric, positions, ele) - invA = A; call invert(A) - invB = B; call invert(B) + do ele=1,ele_count(positions) + A = simplex_tensor(positions, ele) + B = elemental_metric(metric, positions, ele) + invA = A; call invert(A) + invB = B; call invert(B) - R = matmul(invA, B) + matmul(invB, A) - 2 * I - call set(conformity, ele, frob(R)) - end do - end subroutine compute_mesh_conformity + R = matmul(invA, B) + matmul(invB, A) - 2 * I + call set(conformity, ele, frob(R)) + end do + end subroutine compute_mesh_conformity ! subroutine compute_mesh_metric(positions, mesh_metric) ! type(vector_field), intent(in) :: positions @@ -118,155 +118,155 @@ end subroutine compute_mesh_conformity ! call deallocate(lumped_mass) ! end subroutine compute_mesh_metric - function frob(R) - real, dimension(:, :), intent(in) :: R - real :: frob - - real, dimension(size(R, 1), size(R, 2)) :: X - integer :: i - real :: trace - - X = matmul(transpose(R), R) - trace = 0.0 - do i=1,size(R, 1) - trace = trace + X(i, i) - end do - frob = sqrt(trace) - end function frob - - subroutine insert_mesh_conformity(state, error_metric) - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(in), target, optional :: error_metric - - type(scalar_field) :: conformity - type(vector_field), pointer :: positions - type(tensor_field), pointer :: metric - - if (present(error_metric)) then - metric => error_metric - else - metric => extract_tensor_field(state(1), "ErrorMetric") - end if - - positions => extract_vector_field(state(1), "Coordinate") - - conformity = piecewise_constant_field(positions%mesh, "MeshConformity") - call compute_mesh_conformity(metric, positions, conformity) - call insert(state(1), conformity, "MeshConformity") - call deallocate(conformity) - end subroutine insert_mesh_conformity - - function metric_ratio_bounds(positions, metric) result(minmax) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric - - real, dimension(2) :: minmax - - integer :: ele - real, dimension(2) :: ele_minmax - real, dimension(metric%dim(1), metric%dim(2)) :: A, B - - assert(ele_count(positions) > 0) - A = edge_length_from_eigenvalue(simplex_tensor(positions, 1)) - B = edge_length_from_eigenvalue(elemental_metric(metric, positions, 1)) - minmax = anisotropic_ratio(A, B) - - do ele = 2, ele_count(positions) - A = edge_length_from_eigenvalue(simplex_tensor(positions, ele)) - B = edge_length_from_eigenvalue(elemental_metric(metric, positions, ele)) - ele_minmax = anisotropic_ratio(A, B) - minmax(1) = min(minmax(1), ele_minmax(1)) - minmax(2) = max(minmax(2), ele_minmax(2)) - end do - - end function metric_ratio_bounds - - function anisotropic_ratio(tensor1, tensor2) result(minmax) - real, dimension(:, :), intent(in) :: tensor1, tensor2 - real, dimension(2) :: minmax ! (/min, max/) of ratios of edge lengths - real, dimension(size(tensor1, 1), size(tensor1, 1)) :: F, T, Finv, evecs, tensor3 - real, dimension(size(tensor1, 1)) :: evals - integer :: dim - - dim = size(tensor1, 1) - - call eigendecomposition_symmetric(tensor2, evecs, evals) - F = get_deformation_matrix(tensor2, evecs, evals) - Finv = inverse(F) - - T = transpose(Finv) - tensor3 = matmul(matmul(T, tensor1), transpose(T)) - call eigendecomposition_symmetric(tensor3, evecs, evals) - - minmax = (/minval(evals), maxval(evals)/) - - end function anisotropic_ratio - - subroutine compute_mesh_metric(mesh, metric) - type(vector_field), intent(in) :: mesh - type(tensor_field), intent(out) :: metric - - type(tensor_field) :: pwc_metric - type(mesh_type) :: pwc_mesh - integer :: ele - - call allocate(metric, mesh%mesh, "MeshSizingMetric") - pwc_mesh = piecewise_constant_mesh(mesh%mesh, "PiecewiseConstantMesh") - call allocate(pwc_metric, pwc_mesh, "PWCMeshSizingMetric") - - do ele=1,ele_count(mesh) - call set(pwc_metric, ele, simplex_tensor(mesh, ele)) - end do - - call project_p0_metric_p1(mesh, pwc_metric, metric, target=ele_count(mesh)) - call deallocate(pwc_metric) - call deallocate(pwc_mesh) - end subroutine compute_mesh_metric - - subroutine project_p0_metric_p1(positions, pwc_metric, metric, target) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: pwc_metric - type(tensor_field), intent(inout) :: metric - integer, intent(in), optional :: target - - integer :: node - integer :: ele - integer, dimension(:), pointer :: eles - integer :: i - real, dimension(positions%dim, positions%dim) :: tmp_metric - integer :: dim - real :: sum_vol, ele_vol - integer :: pwc_xpct, metric_xpct - real :: beta - type(csr_sparsity), pointer :: nelist - - dim = mesh_dim(positions) - nelist => extract_nelist(metric) - - do node=1,node_count(metric) - tmp_metric = 0.0 - eles => row_m_ptr(nelist, node) - sum_vol = 0.0 - do i=1,size(eles) - ele = eles(i) - ele_vol = simplex_volume(positions, ele) - sum_vol = sum_vol + ele_vol - tmp_metric = tmp_metric + ele_vol * node_val(pwc_metric, ele) + function frob(R) + real, dimension(:, :), intent(in) :: R + real :: frob + + real, dimension(size(R, 1), size(R, 2)) :: X + integer :: i + real :: trace + + X = matmul(transpose(R), R) + trace = 0.0 + do i=1,size(R, 1) + trace = trace + X(i, i) + end do + frob = sqrt(trace) + end function frob + + subroutine insert_mesh_conformity(state, error_metric) + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(in), target, optional :: error_metric + + type(scalar_field) :: conformity + type(vector_field), pointer :: positions + type(tensor_field), pointer :: metric + + if (present(error_metric)) then + metric => error_metric + else + metric => extract_tensor_field(state(1), "ErrorMetric") + end if + + positions => extract_vector_field(state(1), "Coordinate") + + conformity = piecewise_constant_field(positions%mesh, "MeshConformity") + call compute_mesh_conformity(metric, positions, conformity) + call insert(state(1), conformity, "MeshConformity") + call deallocate(conformity) + end subroutine insert_mesh_conformity + + function metric_ratio_bounds(positions, metric) result(minmax) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric + + real, dimension(2) :: minmax + + integer :: ele + real, dimension(2) :: ele_minmax + real, dimension(metric%dim(1), metric%dim(2)) :: A, B + + assert(ele_count(positions) > 0) + A = edge_length_from_eigenvalue(simplex_tensor(positions, 1)) + B = edge_length_from_eigenvalue(elemental_metric(metric, positions, 1)) + minmax = anisotropic_ratio(A, B) + + do ele = 2, ele_count(positions) + A = edge_length_from_eigenvalue(simplex_tensor(positions, ele)) + B = edge_length_from_eigenvalue(elemental_metric(metric, positions, ele)) + ele_minmax = anisotropic_ratio(A, B) + minmax(1) = min(minmax(1), ele_minmax(1)) + minmax(2) = max(minmax(2), ele_minmax(2)) + end do + + end function metric_ratio_bounds + + function anisotropic_ratio(tensor1, tensor2) result(minmax) + real, dimension(:, :), intent(in) :: tensor1, tensor2 + real, dimension(2) :: minmax ! (/min, max/) of ratios of edge lengths + real, dimension(size(tensor1, 1), size(tensor1, 1)) :: F, T, Finv, evecs, tensor3 + real, dimension(size(tensor1, 1)) :: evals + integer :: dim + + dim = size(tensor1, 1) + + call eigendecomposition_symmetric(tensor2, evecs, evals) + F = get_deformation_matrix(tensor2, evecs, evals) + Finv = inverse(F) + + T = transpose(Finv) + tensor3 = matmul(matmul(T, tensor1), transpose(T)) + call eigendecomposition_symmetric(tensor3, evecs, evals) + + minmax = (/minval(evals), maxval(evals)/) + + end function anisotropic_ratio + + subroutine compute_mesh_metric(mesh, metric) + type(vector_field), intent(in) :: mesh + type(tensor_field), intent(out) :: metric + + type(tensor_field) :: pwc_metric + type(mesh_type) :: pwc_mesh + integer :: ele + + call allocate(metric, mesh%mesh, "MeshSizingMetric") + pwc_mesh = piecewise_constant_mesh(mesh%mesh, "PiecewiseConstantMesh") + call allocate(pwc_metric, pwc_mesh, "PWCMeshSizingMetric") + + do ele=1,ele_count(mesh) + call set(pwc_metric, ele, simplex_tensor(mesh, ele)) + end do + + call project_p0_metric_p1(mesh, pwc_metric, metric, target=ele_count(mesh)) + call deallocate(pwc_metric) + call deallocate(pwc_mesh) + end subroutine compute_mesh_metric + + subroutine project_p0_metric_p1(positions, pwc_metric, metric, target) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: pwc_metric + type(tensor_field), intent(inout) :: metric + integer, intent(in), optional :: target + + integer :: node + integer :: ele + integer, dimension(:), pointer :: eles + integer :: i + real, dimension(positions%dim, positions%dim) :: tmp_metric + integer :: dim + real :: sum_vol, ele_vol + integer :: pwc_xpct, metric_xpct + real :: beta + type(csr_sparsity), pointer :: nelist + + dim = mesh_dim(positions) + nelist => extract_nelist(metric) + + do node=1,node_count(metric) + tmp_metric = 0.0 + eles => row_m_ptr(nelist, node) + sum_vol = 0.0 + do i=1,size(eles) + ele = eles(i) + ele_vol = simplex_volume(positions, ele) + sum_vol = sum_vol + ele_vol + tmp_metric = tmp_metric + ele_vol * node_val(pwc_metric, ele) + end do + tmp_metric = tmp_metric / sum_vol + call set(metric, node, tmp_metric) end do - tmp_metric = tmp_metric / sum_vol - call set(metric, node, tmp_metric) - end do - - if (present(target)) then - pwc_xpct = target - else - pwc_xpct = expected_elements(positions, pwc_metric) * 1.25 - end if - metric_xpct = expected_elements(positions, metric) - beta = ((1.0 / metric_xpct) * pwc_xpct) ** (2.0 / dim) - call scale(metric, beta) - - end subroutine project_p0_metric_p1 + + if (present(target)) then + pwc_xpct = target + else + pwc_xpct = expected_elements(positions, pwc_metric) * 1.25 + end if + metric_xpct = expected_elements(positions, metric) + beta = ((1.0 / metric_xpct) * pwc_xpct) ** (2.0 / dim) + call scale(metric, beta) + + end subroutine project_p0_metric_p1 end module conformity_measurement diff --git a/error_measures/Edge_lengths.F90 b/error_measures/Edge_lengths.F90 index 59af776c9e..1753838a7f 100644 --- a/error_measures/Edge_lengths.F90 +++ b/error_measures/Edge_lengths.F90 @@ -2,105 +2,105 @@ module edge_length_module - use fldebug - use vector_tools - use unittest_tools - use metric_tools - use fields - - implicit none - - private - - public :: get_edge_lengths, get_directional_edge_lengths - - interface get_edge_lengths - module procedure get_edge_lengths_field, get_edge_lengths_tensor, get_edge_lengths_ele - end interface - - contains - - subroutine get_edge_lengths_field(metric, field) - !!< Given a metric, calculate the desired edge length - !!< at each node. - type(tensor_field), intent(in) :: metric - type(scalar_field), intent(inout) :: field - integer :: i, j, dim - real, dimension(mesh_dim(metric%mesh), mesh_dim(metric%mesh)) :: evectors - real, dimension(mesh_dim(metric%mesh)) :: evalues, desired_lengths - - dim = mesh_dim(metric%mesh) - - do i=1,metric%mesh%nodes - call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) - desired_lengths = -1.0 - do j=1,dim - if (evalues(j) /= 0.0) then - desired_lengths(j) = 1.0/sqrt(abs(evalues(j))) ! compute the desired edge length in each direction - end if + use fldebug + use vector_tools + use unittest_tools + use metric_tools + use fields + + implicit none + + private + + public :: get_edge_lengths, get_directional_edge_lengths + + interface get_edge_lengths + module procedure get_edge_lengths_field, get_edge_lengths_tensor, get_edge_lengths_ele + end interface + +contains + + subroutine get_edge_lengths_field(metric, field) + !!< Given a metric, calculate the desired edge length + !!< at each node. + type(tensor_field), intent(in) :: metric + type(scalar_field), intent(inout) :: field + integer :: i, j, dim + real, dimension(mesh_dim(metric%mesh), mesh_dim(metric%mesh)) :: evectors + real, dimension(mesh_dim(metric%mesh)) :: evalues, desired_lengths + + dim = mesh_dim(metric%mesh) + + do i=1,metric%mesh%nodes + call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) + desired_lengths = -1.0 + do j=1,dim + if (evalues(j) /= 0.0) then + desired_lengths(j) = 1.0/sqrt(abs(evalues(j))) ! compute the desired edge length in each direction + end if + end do + field%val(i) = sum(desired_lengths, mask=(desired_lengths > 0.0)) / dim ! now take the average end do - field%val(i) = sum(desired_lengths, mask=(desired_lengths > 0.0)) / dim ! now take the average - end do - - ewrite(2,*) "maxval(edgelengths) == ", maxval(field%val) - ewrite(2,*) "maxloc(edgelengths) == ", maxloc(field%val) - ewrite(2,*) "minval(edgelengths) == ", minval(field%val) - ewrite(2,*) "minloc(edgelengths) == ", minloc(field%val) - end subroutine get_edge_lengths_field - - subroutine get_edge_lengths_tensor(metric, tensor) - !!< Replace the eigenvalues with the edge length corresponding to those - !!< eigenvalues. - type(tensor_field), intent(in) :: metric - type(tensor_field), intent(inout) :: tensor - real, dimension(mesh_dim(metric%mesh), mesh_dim(metric%mesh)) :: evectors - real, dimension(mesh_dim(metric%mesh)) :: evalues - - integer :: i - - do i=1,metric%mesh%nodes - call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) - evalues = edge_length_from_eigenvalue(evalues) - call eigenrecomposition(tensor%val(:, :, i), evectors, evalues) - end do - end subroutine get_edge_lengths_tensor - - subroutine get_edge_lengths_ele(mesh, coordinates, ele, edge_lengths) - !!< Given an element, calculate the desired edge length at each node. - type(mesh_type), intent(in) :: mesh - type(vector_field), intent(in) :: coordinates - integer, intent(in) :: ele - real, dimension(mesh_dim(mesh), mesh_dim(mesh), ele_ngi(mesh, 1)), intent(inout) :: edge_lengths - real, dimension(mesh_dim(mesh), mesh_dim(mesh)) :: ele_tensor - - ele_tensor = simplex_tensor(coordinates, ele) - edge_lengths = spread(edge_length_from_eigenvalue(ele_tensor), 3, size(edge_lengths, 3)) - - end subroutine get_edge_lengths_ele - - subroutine get_directional_edge_lengths(metric, field, vec) - !!< Get the edge lengths of metric - !!< in the direction of the vector vec. - - type(tensor_field), intent(in) :: metric - type(scalar_field), intent(inout) :: field - real, dimension(metric%dim(1)), intent(in) :: vec - real, dimension(metric%dim(1)) :: evals - real, dimension(metric%dim(1), metric%dim(2)) :: evecs - real :: len - - integer :: i, j, dim - - dim = metric%dim(1) - - do i=1,metric%mesh%nodes - call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) - len = 0.0 - do j=1,dim - len = len + abs(dot_product(vec, evecs(:, j))) * evals(j) + + ewrite(2,*) "maxval(edgelengths) == ", maxval(field%val) + ewrite(2,*) "maxloc(edgelengths) == ", maxloc(field%val) + ewrite(2,*) "minval(edgelengths) == ", minval(field%val) + ewrite(2,*) "minloc(edgelengths) == ", minloc(field%val) + end subroutine get_edge_lengths_field + + subroutine get_edge_lengths_tensor(metric, tensor) + !!< Replace the eigenvalues with the edge length corresponding to those + !!< eigenvalues. + type(tensor_field), intent(in) :: metric + type(tensor_field), intent(inout) :: tensor + real, dimension(mesh_dim(metric%mesh), mesh_dim(metric%mesh)) :: evectors + real, dimension(mesh_dim(metric%mesh)) :: evalues + + integer :: i + + do i=1,metric%mesh%nodes + call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) + evalues = edge_length_from_eigenvalue(evalues) + call eigenrecomposition(tensor%val(:, :, i), evectors, evalues) + end do + end subroutine get_edge_lengths_tensor + + subroutine get_edge_lengths_ele(mesh, coordinates, ele, edge_lengths) + !!< Given an element, calculate the desired edge length at each node. + type(mesh_type), intent(in) :: mesh + type(vector_field), intent(in) :: coordinates + integer, intent(in) :: ele + real, dimension(mesh_dim(mesh), mesh_dim(mesh), ele_ngi(mesh, 1)), intent(inout) :: edge_lengths + real, dimension(mesh_dim(mesh), mesh_dim(mesh)) :: ele_tensor + + ele_tensor = simplex_tensor(coordinates, ele) + edge_lengths = spread(edge_length_from_eigenvalue(ele_tensor), 3, size(edge_lengths, 3)) + + end subroutine get_edge_lengths_ele + + subroutine get_directional_edge_lengths(metric, field, vec) + !!< Get the edge lengths of metric + !!< in the direction of the vector vec. + + type(tensor_field), intent(in) :: metric + type(scalar_field), intent(inout) :: field + real, dimension(metric%dim(1)), intent(in) :: vec + real, dimension(metric%dim(1)) :: evals + real, dimension(metric%dim(1), metric%dim(2)) :: evecs + real :: len + + integer :: i, j, dim + + dim = metric%dim(1) + + do i=1,metric%mesh%nodes + call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) + len = 0.0 + do j=1,dim + len = len + abs(dot_product(vec, evecs(:, j))) * evals(j) + end do + field%val(i) = edge_length_from_eigenvalue(len) end do - field%val(i) = edge_length_from_eigenvalue(len) - end do - end subroutine get_directional_edge_lengths + end subroutine get_directional_edge_lengths end module edge_length_module diff --git a/error_measures/Field_preprocessing.F90 b/error_measures/Field_preprocessing.F90 index 9c5f2300be..a892c6248d 100644 --- a/error_measures/Field_preprocessing.F90 +++ b/error_measures/Field_preprocessing.F90 @@ -2,20 +2,20 @@ module field_preprocessing_module - use spud - use global_parameters - use fields - use smoothing_module - use field_options + use spud + use global_parameters + use fields + use smoothing_module + use field_options - implicit none + implicit none - private - public :: preprocess_field + private + public :: preprocess_field - contains +contains - subroutine preprocess_field(field_in, positions, field_out) + subroutine preprocess_field(field_in, positions, field_out) !! Do whatever actions are specified in the flml. !! Currently, only a Helmholtz smoother is available. @@ -27,19 +27,19 @@ subroutine preprocess_field(field_in, positions, field_out) integer :: stat have_helmholtz_smoother = have_option(trim(complete_field_path(trim(field_in%option_path), stat=stat)) & - // "/adaptivity_options/preprocessing/helmholtz_smoother") + // "/adaptivity_options/preprocessing/helmholtz_smoother") if (.not. have_helmholtz_smoother) then - field_out = field_in - call incref(field_out) - return + field_out = field_in + call incref(field_out) + return else if (have_helmholtz_smoother) then - call apply_helmholtz_smoother(field_in, positions, field_out) + call apply_helmholtz_smoother(field_in, positions, field_out) end if - end subroutine preprocess_field + end subroutine preprocess_field - subroutine apply_helmholtz_smoother(field_in, positions, field_out) + subroutine apply_helmholtz_smoother(field_in, positions, field_out) type(scalar_field), intent(inout) :: field_in type(vector_field), intent(in) :: positions type(scalar_field), intent(out) :: field_out @@ -47,13 +47,13 @@ subroutine apply_helmholtz_smoother(field_in, positions, field_out) character(len=OPTION_PATH_LEN) :: path call get_option(trim(complete_field_path(trim(field_in%option_path))) & - & // "/adaptivity_options/preprocessing/helmholtz_smoother/smoothing_scale_factor", alpha) + & // "/adaptivity_options/preprocessing/helmholtz_smoother/smoothing_scale_factor", alpha) call allocate(field_out, field_in%mesh, "Smoothed" // trim(field_in%name)) call zero(field_out) path = trim(complete_field_path(trim(field_in%option_path))) // "/adaptivity_options/preprocessing/helmholtz_smoother" call smooth_scalar(field_in, positions, field_out, alpha, path=path) - end subroutine apply_helmholtz_smoother + end subroutine apply_helmholtz_smoother end module field_preprocessing_module diff --git a/error_measures/Form_metric.F90 b/error_measures/Form_metric.F90 index ff5ea022fa..b99855c3cc 100644 --- a/error_measures/Form_metric.F90 +++ b/error_measures/Form_metric.F90 @@ -3,249 +3,249 @@ module form_metric_field - use fldebug - use vector_tools - use global_parameters, only : OPTION_PATH_LEN - use futils, only: int2str - use spud - use unittest_tools - use metric_tools - use fields - use merge_tensors - use state_module - use vtk_interfaces, only: vtk_write_fields - use recovery_estimator - use field_options - - implicit none - - interface bound_metric - module procedure bound_metric_anisotropic, bound_metric_minmax - end interface - - interface form_metric - module procedure form_metric_state, form_metric_weight - end interface - - private - public :: form_metric, bound_metric, p_norm_scale_metric - - contains - - subroutine form_metric_state(state, hessian, field) - !!< Form the metric for the field field, storing it in hessian. - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: hessian - type(scalar_field), intent(inout) :: field - - type(scalar_field), pointer :: adweit - - integer :: idx, dim - logical :: allocated - - idx = index(trim(field%name), "%") - if (idx == 0) then - adweit => extract_scalar_field(state, trim(field%name) // "InterpolationErrorBound") - allocated = .false. - else - read(field%name(idx+1:len_trim(field%name)), *) dim - adweit => extract_scalar_field(state, field%name(1:idx-1) // "InterpolationErrorBound%" // int2str(dim), allocated=allocated) - end if - - call form_metric(hessian, field, adweit, state) - - if (allocated) then - deallocate(adweit) - end if - - end subroutine form_metric_state - - subroutine form_metric_weight(hessian, field, adweit, state) - !!< Form the metric for the field field, storing it in hessian. - type(tensor_field), intent(inout) :: hessian - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: adweit - type(state_type), intent(in) :: state - - integer :: p, stat - - if (have_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure")) then - ewrite(2,*) "Forming relative metric" - call relative_metric(hessian, field, adweit) - else - ewrite(2,*) "Forming absolute metric" - - call get_p_norm(field, p, stat) - if(stat == 0) then - ewrite(2, *) "Norm degree: ", p - call absolute_metric(hessian, adweit, p) + use fldebug + use vector_tools + use global_parameters, only : OPTION_PATH_LEN + use futils, only: int2str + use spud + use unittest_tools + use metric_tools + use fields + use merge_tensors + use state_module + use vtk_interfaces, only: vtk_write_fields + use recovery_estimator + use field_options + + implicit none + + interface bound_metric + module procedure bound_metric_anisotropic, bound_metric_minmax + end interface + + interface form_metric + module procedure form_metric_state, form_metric_weight + end interface + + private + public :: form_metric, bound_metric, p_norm_scale_metric + +contains + + subroutine form_metric_state(state, hessian, field) + !!< Form the metric for the field field, storing it in hessian. + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: hessian + type(scalar_field), intent(inout) :: field + + type(scalar_field), pointer :: adweit + + integer :: idx, dim + logical :: allocated + + idx = index(trim(field%name), "%") + if (idx == 0) then + adweit => extract_scalar_field(state, trim(field%name) // "InterpolationErrorBound") + allocated = .false. else - ewrite(2, *) "Norm degree: inf" - call absolute_metric(hessian, adweit) + read(field%name(idx+1:len_trim(field%name)), *) dim + adweit => extract_scalar_field(state, field%name(1:idx-1) // "InterpolationErrorBound%" // int2str(dim), allocated=allocated) end if - end if - ewrite(2,*) "Bounding metric" - call bound_metric(hessian, state) + call form_metric(hessian, field, adweit, state) - contains - - subroutine get_p_norm(field, p, stat) - type(scalar_field), intent(in) :: field - integer, intent(out) :: p - integer, intent(out) :: stat + if (allocated) then + deallocate(adweit) + end if - character(len = OPTION_PATH_LEN) :: option_path + end subroutine form_metric_state - stat = 0 + subroutine form_metric_weight(hessian, field, adweit, state) + !!< Form the metric for the field field, storing it in hessian. + type(tensor_field), intent(inout) :: hessian + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: adweit + type(state_type), intent(in) :: state - option_path = complete_field_path(field%option_path, stat = stat) - if(stat /= 0) return + integer :: p, stat - call get_option(trim(option_path) // "/adaptivity_options/absolute_measure/p_norm", p, stat = stat) + if (have_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure")) then + ewrite(2,*) "Forming relative metric" + call relative_metric(hessian, field, adweit) + else + ewrite(2,*) "Forming absolute metric" + + call get_p_norm(field, p, stat) + if(stat == 0) then + ewrite(2, *) "Norm degree: ", p + call absolute_metric(hessian, adweit, p) + else + ewrite(2, *) "Norm degree: inf" + call absolute_metric(hessian, adweit) + end if + end if - end subroutine get_p_norm + ewrite(2,*) "Bounding metric" + call bound_metric(hessian, state) - end subroutine form_metric_weight + contains - subroutine absolute_metric(metric, adweit, p) - !!< Construct the metric using the absolute error formulation. - type(tensor_field), intent(inout) :: metric - type(scalar_field), intent(in) :: adweit - !! Norm degree. Defaults to inf-norm. - integer, optional, intent(in) :: p + subroutine get_p_norm(field, p, stat) + type(scalar_field), intent(in) :: field + integer, intent(out) :: p + integer, intent(out) :: stat - integer :: i + character(len = OPTION_PATH_LEN) :: option_path - if(present(p)) call p_norm_scale_metric(metric, p) + stat = 0 - do i = 1, node_count(metric) - call set(metric, i, node_val(metric, i) / node_val(adweit, i)) - end do + option_path = complete_field_path(field%option_path, stat = stat) + if(stat /= 0) return - end subroutine absolute_metric + call get_option(trim(option_path) // "/adaptivity_options/absolute_measure/p_norm", p, stat = stat) - subroutine p_norm_scale_metric(metric, p) - !!< Apply the p-norm scaling to the metric, as in Chen Sun and Zu, - !!< Mathematics of Computation, Volume 76, Number 257, January 2007, - !!< pp. 179-204 + end subroutine get_p_norm - type(tensor_field), intent(inout) :: metric - integer, intent(in) :: p + end subroutine form_metric_weight - real :: m_det - real, dimension(mesh_dim(metric), mesh_dim(metric)) :: evecs - real, dimension(mesh_dim(metric)) :: evals - integer :: i, j, n + subroutine absolute_metric(metric, adweit, p) + !!< Construct the metric using the absolute error formulation. + type(tensor_field), intent(inout) :: metric + type(scalar_field), intent(in) :: adweit + !! Norm degree. Defaults to inf-norm. + integer, optional, intent(in) :: p - assert(p > 0) + integer :: i - n = mesh_dim(metric) + if(present(p)) call p_norm_scale_metric(metric, p) - do i = 1, node_count(metric) - ! We really need det(metric) to be positive here - ! This happens again in bound_metric, but it doesn't hurt to do it twice - ! (Patrick assures me eigenrecompositions are cheap) - call eigendecomposition_symmetric(node_val(metric, i), evecs, evals) - do j = 1, n - evals(j) = abs(evals(j)) + do i = 1, node_count(metric) + call set(metric, i, node_val(metric, i) / node_val(adweit, i)) end do - call eigenrecomposition(metric%val(:, :, i), evecs, evals) - m_det = 1.0 - do j = 1, size(evals) - m_det = m_det * evals(j) - end do - m_det = max(m_det, epsilon(0.0)) - - call set(metric, i, node_val(metric, i) * (m_det ** (-1.0 / (2.0 * p + n)))) - end do - - end subroutine p_norm_scale_metric - - subroutine relative_metric(hessian, field, adweit) - !!< Construct the metric using the relative error formulation. - type(tensor_field), intent(inout) :: hessian - type(scalar_field), intent(in) :: field, adweit - integer :: i, idx, dim - real :: maxfield, minpsi - real, dimension(mesh_dim(field%mesh)) :: minpsi_vector - - idx = index(field%name, "%") - if (idx == 0) then - call get_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure/tolerance", minpsi) - else - read(field%name(idx+1:len(field%name)), *) dim - call get_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure/tolerance", minpsi_vector) - minpsi = minpsi_vector(dim) - end if - - if (have_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure/use_global_max")) then - call field_stats(field, max=maxfield) - do i=1,hessian%mesh%nodes - hessian%val(:, :, i) = hessian%val(:, :, i) / (node_val(adweit, i) * max(maxfield, minpsi)) - end do - else - do i=1,hessian%mesh%nodes - hessian%val(:, :, i) = hessian%val(:, :, i) / (node_val(adweit, i) * max(abs(node_val(field, i)), minpsi)) + end subroutine absolute_metric + + subroutine p_norm_scale_metric(metric, p) + !!< Apply the p-norm scaling to the metric, as in Chen Sun and Zu, + !!< Mathematics of Computation, Volume 76, Number 257, January 2007, + !!< pp. 179-204 + + type(tensor_field), intent(inout) :: metric + integer, intent(in) :: p + + real :: m_det + real, dimension(mesh_dim(metric), mesh_dim(metric)) :: evecs + real, dimension(mesh_dim(metric)) :: evals + integer :: i, j, n + + assert(p > 0) + + n = mesh_dim(metric) + + do i = 1, node_count(metric) + ! We really need det(metric) to be positive here + ! This happens again in bound_metric, but it doesn't hurt to do it twice + ! (Patrick assures me eigenrecompositions are cheap) + call eigendecomposition_symmetric(node_val(metric, i), evecs, evals) + do j = 1, n + evals(j) = abs(evals(j)) + end do + call eigenrecomposition(metric%val(:, :, i), evecs, evals) + + m_det = 1.0 + do j = 1, size(evals) + m_det = m_det * evals(j) + end do + m_det = max(m_det, epsilon(0.0)) + + call set(metric, i, node_val(metric, i) * (m_det ** (-1.0 / (2.0 * p + n)))) end do - end if - end subroutine relative_metric - subroutine bound_metric_anisotropic(hessian, state, stat) - !!< Implement the anisotropic edge length bounds. - type(tensor_field), intent(inout) :: hessian - type(state_type), intent(in) :: state - integer, optional :: stat + end subroutine p_norm_scale_metric + + subroutine relative_metric(hessian, field, adweit) + !!< Construct the metric using the relative error formulation. + type(tensor_field), intent(inout) :: hessian + type(scalar_field), intent(in) :: field, adweit + integer :: i, idx, dim + real :: maxfield, minpsi + real, dimension(mesh_dim(field%mesh)) :: minpsi_vector - type(tensor_field), pointer :: min_bound, max_bound + idx = index(field%name, "%") + if (idx == 0) then + call get_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure/tolerance", minpsi) + else + read(field%name(idx+1:len(field%name)), *) dim + call get_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure/tolerance", minpsi_vector) + minpsi = minpsi_vector(dim) + end if + + if (have_adapt_opt(trim(field%option_path), "/adaptivity_options/relative_measure/use_global_max")) then + call field_stats(field, max=maxfield) + do i=1,hessian%mesh%nodes + hessian%val(:, :, i) = hessian%val(:, :, i) / (node_val(adweit, i) * max(maxfield, minpsi)) + end do + else + do i=1,hessian%mesh%nodes + hessian%val(:, :, i) = hessian%val(:, :, i) / (node_val(adweit, i) * max(abs(node_val(field, i)), minpsi)) + end do + end if + end subroutine relative_metric - ! min and max refer to edge lengths, not eigenvalues + subroutine bound_metric_anisotropic(hessian, state, stat) + !!< Implement the anisotropic edge length bounds. + type(tensor_field), intent(inout) :: hessian + type(state_type), intent(in) :: state + integer, optional :: stat - if(present(stat)) stat = 0 + type(tensor_field), pointer :: min_bound, max_bound - min_bound => extract_tensor_field(state, "MaxMetricEigenbound", stat=stat) - max_bound => extract_tensor_field(state, "MinMetricEigenbound", stat=stat) - if(present(stat)) then - if(stat/=0) return - end if - if(any(min_bound%dim /= hessian%dim).or.any(max_bound%dim /= hessian%dim)) then + ! min and max refer to edge lengths, not eigenvalues + + if(present(stat)) stat = 0 + + min_bound => extract_tensor_field(state, "MaxMetricEigenbound", stat=stat) + max_bound => extract_tensor_field(state, "MinMetricEigenbound", stat=stat) if(present(stat)) then - stat = 1 - return - else - FLAbort("Incompatible tensor dimensions") + if(stat/=0) return + end if + if(any(min_bound%dim /= hessian%dim).or.any(max_bound%dim /= hessian%dim)) then + if(present(stat)) then + stat = 1 + return + else + FLAbort("Incompatible tensor dimensions") + end if end if - end if - call bound_metric(hessian, min_bound, max_bound) + call bound_metric(hessian, min_bound, max_bound) - end subroutine bound_metric_anisotropic + end subroutine bound_metric_anisotropic - subroutine bound_metric_minmax(hessian, min_bound, max_bound) - !!< Implement the anisotropic edge length bounds. - type(tensor_field), intent(inout) :: hessian - type(tensor_field), intent(in) :: min_bound, max_bound + subroutine bound_metric_minmax(hessian, min_bound, max_bound) + !!< Implement the anisotropic edge length bounds. + type(tensor_field), intent(inout) :: hessian + type(tensor_field), intent(in) :: min_bound, max_bound - real, dimension(hessian%dim(1), hessian%dim(2)) :: max_tensor, min_tensor, evecs - real, dimension(hessian%dim(1)) :: evals - integer :: i, j + real, dimension(hessian%dim(1), hessian%dim(2)) :: max_tensor, min_tensor, evecs + real, dimension(hessian%dim(1)) :: evals + integer :: i, j - ! min and max refer to edge lengths, not eigenvalues - do i=1,node_count(hessian) - call eigendecomposition_symmetric(hessian%val(:, :, i), evecs, evals) - do j=1,hessian%dim(1) - evals(j) = abs(evals(j)) - end do - call eigenrecomposition(hessian%val(:, :, i), evecs, evals) - assert(all(evals >= 0.0)) + ! min and max refer to edge lengths, not eigenvalues + do i=1,node_count(hessian) + call eigendecomposition_symmetric(hessian%val(:, :, i), evecs, evals) + do j=1,hessian%dim(1) + evals(j) = abs(evals(j)) + end do + call eigenrecomposition(hessian%val(:, :, i), evecs, evals) + assert(all(evals >= 0.0)) - max_tensor = node_val(max_bound, i) - min_tensor = node_val(min_bound, i) - call merge_tensor(hessian%val(:, :, i), max_tensor) - call merge_tensor(hessian%val(:, :, i), min_tensor, aniso_min=.true.) - end do + max_tensor = node_val(max_bound, i) + min_tensor = node_val(min_bound, i) + call merge_tensor(hessian%val(:, :, i), max_tensor) + call merge_tensor(hessian%val(:, :, i), min_tensor, aniso_min=.true.) + end do - end subroutine bound_metric_minmax + end subroutine bound_metric_minmax end module form_metric_field diff --git a/error_measures/Geometric_constraints_metric.F90 b/error_measures/Geometric_constraints_metric.F90 index 72a746d295..10774ecb5c 100644 --- a/error_measures/Geometric_constraints_metric.F90 +++ b/error_measures/Geometric_constraints_metric.F90 @@ -4,114 +4,114 @@ module geometric_constraints_metric !!< This module wraps Gerard's geometric constraints !!< code and applied it during metric formation. - use spud - use fldebug - use mpi_interfaces, only: mpi_allreduce - use parallel_tools - use metric_tools - use fields - use state_module - use field_options - use vtk_interfaces - use merge_tensors - use edge_length_module - use halos - use surfacelabels, only: FindGeometryConstraints - use node_boundary - use form_metric_field - use gradation_metric - - implicit none - - private - public :: use_geometric_constraints_metric,& - initialise_geometric_constraints_metric,& - form_geometric_constraints_metric - - logical :: use_geometric_constraints_metric = .false. - logical :: geometric_constraints_initialised = .false. - - contains - - subroutine initialise_geometric_constraints_metric - use_geometric_constraints_metric = .false. - if (have_option("/mesh_adaptivity/hr_adaptivity/geometric_constraints")) then - use_geometric_constraints_metric = .true. - end if - geometric_constraints_initialised = .true. - end subroutine initialise_geometric_constraints_metric - - subroutine form_geometric_constraints_metric(error_metric, state) - type(tensor_field), intent(inout) :: error_metric !!< The metric formed so far - type(state_type), intent(in) :: state - - integer :: dim - - type(vector_field) :: metric_positions - real, dimension(error_metric%dim(1) * error_metric%dim(2) * node_count(error_metric)) :: geometric_edge_lengths_raw - type(tensor_field) :: geometric_edge_lengths - integer :: snloc, nselements - integer :: noits, grad_count - - type(scalar_field) :: edgelen, geometric_edgelen - integer, save :: adaptcnt = 0 + use spud + use fldebug + use mpi_interfaces, only: mpi_allreduce + use parallel_tools + use metric_tools + use fields + use state_module + use field_options + use vtk_interfaces + use merge_tensors + use edge_length_module + use halos + use surfacelabels, only: FindGeometryConstraints + use node_boundary + use form_metric_field + use gradation_metric + + implicit none + + private + public :: use_geometric_constraints_metric,& + initialise_geometric_constraints_metric,& + form_geometric_constraints_metric + + logical :: use_geometric_constraints_metric = .false. + logical :: geometric_constraints_initialised = .false. + +contains + + subroutine initialise_geometric_constraints_metric + use_geometric_constraints_metric = .false. + if (have_option("/mesh_adaptivity/hr_adaptivity/geometric_constraints")) then + use_geometric_constraints_metric = .true. + end if + geometric_constraints_initialised = .true. + end subroutine initialise_geometric_constraints_metric + + subroutine form_geometric_constraints_metric(error_metric, state) + type(tensor_field), intent(inout) :: error_metric !!< The metric formed so far + type(state_type), intent(in) :: state + + integer :: dim + + type(vector_field) :: metric_positions + real, dimension(error_metric%dim(1) * error_metric%dim(2) * node_count(error_metric)) :: geometric_edge_lengths_raw + type(tensor_field) :: geometric_edge_lengths + integer :: snloc, nselements + integer :: noits, grad_count + + type(scalar_field) :: edgelen, geometric_edgelen + integer, save :: adaptcnt = 0 #ifdef HAVE_MPI - include 'mpif.h' - integer::noits_max, ierr + include 'mpif.h' + integer::noits_max, ierr #endif - logical :: debug_metric + logical :: debug_metric - if(.not.use_geometric_constraints_metric) then - return - end if + if(.not.use_geometric_constraints_metric) then + return + end if - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - snloc = face_loc(error_metric%mesh, 1) - nselements = surface_element_count(error_metric%mesh) + snloc = face_loc(error_metric%mesh, 1) + nselements = surface_element_count(error_metric%mesh) - dim = error_metric%dim(1) - ewrite(2,*) "++: Applying geometric constraints" + dim = error_metric%dim(1) + ewrite(2,*) "++: Applying geometric constraints" - metric_positions = get_coordinate_field(state, error_metric%mesh) - call FindGeometryConstraints(metric_positions, geometric_edge_lengths_raw) + metric_positions = get_coordinate_field(state, error_metric%mesh) + call FindGeometryConstraints(metric_positions, geometric_edge_lengths_raw) - geometric_edge_lengths = wrap_tensor_field(error_metric%mesh, geometric_edge_lengths_raw, "GeometricEdgeLengths") + geometric_edge_lengths = wrap_tensor_field(error_metric%mesh, geometric_edge_lengths_raw, "GeometricEdgeLengths") - call bound_metric(geometric_edge_lengths, state) - if (.not. isparallel()) then - call form_gradation_metric(metric_positions, geometric_edge_lengths) - else - noits = 2 - grad_count = 0 - do while ((noits.gt.1).and.(grad_count.le.3)) - call form_gradation_metric(metric_positions, geometric_edge_lengths, noits) - call halo_update(error_metric) - grad_count = grad_count + 1 + call bound_metric(geometric_edge_lengths, state) + if (.not. isparallel()) then + call form_gradation_metric(metric_positions, geometric_edge_lengths) + else + noits = 2 + grad_count = 0 + do while ((noits.gt.1).and.(grad_count.le.3)) + call form_gradation_metric(metric_positions, geometric_edge_lengths, noits) + call halo_update(error_metric) + grad_count = grad_count + 1 #ifdef HAVE_MPI - CALL MPI_Allreduce (noits, noits_max, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_FEMTOOLS, ierr) - noits = noits_max + CALL MPI_Allreduce (noits, noits_max, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_FEMTOOLS, ierr) + noits = noits_max #endif - end do - end if - - if (debug_metric) then - call allocate(edgelen, error_metric%mesh, "Desired edge lengths") - call allocate(geometric_edgelen, error_metric%mesh, "Geometric edge lengths") - call get_edge_lengths(geometric_edge_lengths, geometric_edgelen) - call get_edge_lengths(error_metric, edgelen) - call vtk_write_fields(trim("geometric_constraints_metric"), adaptcnt, metric_positions, metric_positions%mesh, & - sfields=(/edgelen, geometric_edgelen/), tfields=(/error_metric, geometric_edge_lengths/)) - call deallocate(edgelen) - call deallocate(geometric_edgelen) - adaptcnt = adaptcnt + 1 - end if - call merge_tensor_fields(error_metric, geometric_edge_lengths) - - call deallocate(geometric_edge_lengths) - call deallocate(metric_positions) - - end subroutine form_geometric_constraints_metric + end do + end if + + if (debug_metric) then + call allocate(edgelen, error_metric%mesh, "Desired edge lengths") + call allocate(geometric_edgelen, error_metric%mesh, "Geometric edge lengths") + call get_edge_lengths(geometric_edge_lengths, geometric_edgelen) + call get_edge_lengths(error_metric, edgelen) + call vtk_write_fields(trim("geometric_constraints_metric"), adaptcnt, metric_positions, metric_positions%mesh, & + sfields=(/edgelen, geometric_edgelen/), tfields=(/error_metric, geometric_edge_lengths/)) + call deallocate(edgelen) + call deallocate(geometric_edgelen) + adaptcnt = adaptcnt + 1 + end if + call merge_tensor_fields(error_metric, geometric_edge_lengths) + + call deallocate(geometric_edge_lengths) + call deallocate(metric_positions) + + end subroutine form_geometric_constraints_metric end module geometric_constraints_metric diff --git a/error_measures/Goal_metric.F90 b/error_measures/Goal_metric.F90 index a04ebd9a0d..79e1b62245 100644 --- a/error_measures/Goal_metric.F90 +++ b/error_measures/Goal_metric.F90 @@ -4,378 +4,378 @@ module goal_metric !!< Simple goal-based metric formation. - use fldebug - use global_parameters, only: dt, FIELD_NAME_LEN, OPTION_PATH_LEN - use futils, only: count_chars, multiindex - use vector_tools - use elements - use spud - use transform_elements, only: transform_to_physical - use fetools, only: shape_shape - use metric_tools, only: error_bound_name - use fields - use edge_length_module, only: get_edge_lengths - use state_module, only: state_type, extract_scalar_field, extract_vector_field, insert - use merge_tensors, only: merge_tensor_fields - use vtk_interfaces, only: vtk_write_fields - use field_derivatives, only: compute_hessian - use form_metric_field, only: form_metric - use goals - use gradation_metric, only: form_gradation_metric - - implicit none - - !! Use goal-based metric method, or - !! the standard user-defined weights? - logical :: use_goal_metric = .false. - - !! How much error should we tolerate in the goal? - !! If goal_rel_tolerance /= 0.0, then use that as a relative - !! tolerance, otherwise use goal_tolerance. - real, public :: goal_tolerance - real, public :: goal_rel_tolerance = 0.0 - character(len=OPTION_PATH_LEN), public :: goal_name - - !! What state variables does the goal depend on? - !! The gradient of the goal with respect to - !! each dependency must be available from goal_grad. - character(len=FIELD_NAME_LEN), dimension(:), pointer, public :: goal_deps => null() - - interface form_goal_metric - module procedure form_goal_metric_generic, form_goal_metric_specific - end interface - - private - - public :: initialise_goal_metric, form_goal_metric, use_goal_metric,& - form_goal_metric_generic - - contains - - subroutine initialise_goal_metric - integer, dimension(:), allocatable :: indices - character(len=OPTION_PATH_LEN) :: name, deps - integer :: i, nchild, idx, c - - if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity")) then - ! We have the option. Let's set up goal-based adaptivity. Exciting! - use_goal_metric = .true. - - ! Get the tolerance, either relative or absolute. - if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/relative_tolerance")) then - call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/relative_tolerance", goal_rel_tolerance) - else if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/absolute_tolerance")) then - call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/absolute_tolerance", goal_tolerance) - else - FLExit("Must specify either an absolute tolerance or a relative tolerance for goal based adaptivity.") + use fldebug + use global_parameters, only: dt, FIELD_NAME_LEN, OPTION_PATH_LEN + use futils, only: count_chars, multiindex + use vector_tools + use elements + use spud + use transform_elements, only: transform_to_physical + use fetools, only: shape_shape + use metric_tools, only: error_bound_name + use fields + use edge_length_module, only: get_edge_lengths + use state_module, only: state_type, extract_scalar_field, extract_vector_field, insert + use merge_tensors, only: merge_tensor_fields + use vtk_interfaces, only: vtk_write_fields + use field_derivatives, only: compute_hessian + use form_metric_field, only: form_metric + use goals + use gradation_metric, only: form_gradation_metric + + implicit none + + !! Use goal-based metric method, or + !! the standard user-defined weights? + logical :: use_goal_metric = .false. + + !! How much error should we tolerate in the goal? + !! If goal_rel_tolerance /= 0.0, then use that as a relative + !! tolerance, otherwise use goal_tolerance. + real, public :: goal_tolerance + real, public :: goal_rel_tolerance = 0.0 + character(len=OPTION_PATH_LEN), public :: goal_name + + !! What state variables does the goal depend on? + !! The gradient of the goal with respect to + !! each dependency must be available from goal_grad. + character(len=FIELD_NAME_LEN), dimension(:), pointer, public :: goal_deps => null() + + interface form_goal_metric + module procedure form_goal_metric_generic, form_goal_metric_specific + end interface + + private + + public :: initialise_goal_metric, form_goal_metric, use_goal_metric,& + form_goal_metric_generic + +contains + + subroutine initialise_goal_metric + integer, dimension(:), allocatable :: indices + character(len=OPTION_PATH_LEN) :: name, deps + integer :: i, nchild, idx, c + + if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity")) then + ! We have the option. Let's set up goal-based adaptivity. Exciting! + use_goal_metric = .true. + + ! Get the tolerance, either relative or absolute. + if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/relative_tolerance")) then + call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/relative_tolerance", goal_rel_tolerance) + else if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/absolute_tolerance")) then + call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/absolute_tolerance", goal_tolerance) + else + FLExit("Must specify either an absolute tolerance or a relative tolerance for goal based adaptivity.") + end if + + ! We need to find out which goal we actually want ... + call get_number_of_children("/mesh_adaptivity/hr_adaptivity/goal_based& + &_adaptivity",nchild) + do i=0,nchild-1 + call get_child_name("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity", i, name) + idx = index(trim(name), "tolerance") + if (idx == 0) then + goal_name = trim(name) + exit + end if + end do + + ! Once we have the goal, find out what fields in state it depends on + if (.not. associated(goal_deps)) then + call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/" // trim(goal_name) & + & // "/dependencies", deps) + + ! deps == "NonlinearVelocity%1 NonlinearVelocity%2 NonlinearVelocity%3" for example + + c = count_chars(trim(deps), " ") + allocate(goal_deps(c + 1)) + allocate(indices(c + 2)) + + if (c == 0) then + goal_deps(1) = trim(deps) + else + indices(1) = 0 + indices(2:c+1) = multiindex(trim(deps), " ") + indices(c+2) = len_trim(deps) + 1 + + do i=1,c+1 + goal_deps(i) = deps(indices(i) + 1:indices(i+1) - 1) + end do + end if + end if end if - ! We need to find out which goal we actually want ... - call get_number_of_children("/mesh_adaptivity/hr_adaptivity/goal_based& - &_adaptivity",nchild) - do i=0,nchild-1 - call get_child_name("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity", i, name) - idx = index(trim(name), "tolerance") - if (idx == 0) then - goal_name = trim(name) - exit - end if - end do - - ! Once we have the goal, find out what fields in state it depends on - if (.not. associated(goal_deps)) then - call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/" // trim(goal_name) & - & // "/dependencies", deps) - - ! deps == "NonlinearVelocity%1 NonlinearVelocity%2 NonlinearVelocity%3" for example - - c = count_chars(trim(deps), " ") - allocate(goal_deps(c + 1)) - allocate(indices(c + 2)) - - if (c == 0) then - goal_deps(1) = trim(deps) - else - indices(1) = 0 - indices(2:c+1) = multiindex(trim(deps), " ") - indices(c+2) = len_trim(deps) + 1 - - do i=1,c+1 - goal_deps(i) = deps(indices(i) + 1:indices(i+1) - 1) - end do - end if - end if - end if - - if (allocated(indices)) then - deallocate(indices) - end if - end subroutine initialise_goal_metric - - subroutine form_goal_metric_generic(state, metric) - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(inout) :: metric - - ! number of nonlinear iterations to perform, when applicable - integer :: iters, i - type(tensor_field) :: tmp_metric - type(vector_field), pointer :: positions - - select case(goal_name) - case("enstrophy_goal") - call form_goal_metric_specific(state, metric, goal_enstrophy, goal_enstrophy_grad) - case("temperature_gradient_goal") - call form_goal_metric_specific(state, metric, goal_temp, goal_temp_grad) - case("les_goal") - call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_goal/nonlinear_iterations", iters, default=3) - call form_goal_metric_specific(state, metric, goal_les_velocity, goal_les_velocity_grad) - if (iters > 0) then - positions => extract_vector_field(state(1), "Coordinate") - call form_gradation_metric(positions, metric) - call allocate(tmp_metric, metric%mesh, "TmpMetric") - do i=1,iters - call insert(state(1), metric, "MeshSizingMetric") - call form_goal_metric(state, tmp_metric, goal_les_velocity, goal_les_velocity_grad) - call form_gradation_metric(positions, tmp_metric) - metric%val = tmp_metric%val - end do - call deallocate(tmp_metric) + if (allocated(indices)) then + deallocate(indices) end if - case("les_squared_goal") - call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_squared_goal/nonlinear_iterations", iters, default=5) - call form_goal_metric_specific(state, metric, goal_les_velocity_squared, goal_les_velocity_squared_grad) - if (iters > 0) then - positions => extract_vector_field(state(1), "Coordinate") - call form_gradation_metric(positions, metric) - call allocate(tmp_metric, metric%mesh, "TmpMetric") - do i=1,iters - call insert(state(1), metric, "MeshSizingMetric") - call form_goal_metric(state, tmp_metric, goal_les_velocity_squared, goal_les_velocity_squared_grad) - call form_gradation_metric(positions, tmp_metric) - metric%val = tmp_metric%val - end do - call deallocate(tmp_metric) + end subroutine initialise_goal_metric + + subroutine form_goal_metric_generic(state, metric) + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(inout) :: metric + + ! number of nonlinear iterations to perform, when applicable + integer :: iters, i + type(tensor_field) :: tmp_metric + type(vector_field), pointer :: positions + + select case(goal_name) + case("enstrophy_goal") + call form_goal_metric_specific(state, metric, goal_enstrophy, goal_enstrophy_grad) + case("temperature_gradient_goal") + call form_goal_metric_specific(state, metric, goal_temp, goal_temp_grad) + case("les_goal") + call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_goal/nonlinear_iterations", iters, default=3) + call form_goal_metric_specific(state, metric, goal_les_velocity, goal_les_velocity_grad) + if (iters > 0) then + positions => extract_vector_field(state(1), "Coordinate") + call form_gradation_metric(positions, metric) + call allocate(tmp_metric, metric%mesh, "TmpMetric") + do i=1,iters + call insert(state(1), metric, "MeshSizingMetric") + call form_goal_metric(state, tmp_metric, goal_les_velocity, goal_les_velocity_grad) + call form_gradation_metric(positions, tmp_metric) + metric%val = tmp_metric%val + end do + call deallocate(tmp_metric) + end if + case("les_squared_goal") + call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_squared_goal/nonlinear_iterations", iters, default=5) + call form_goal_metric_specific(state, metric, goal_les_velocity_squared, goal_les_velocity_squared_grad) + if (iters > 0) then + positions => extract_vector_field(state(1), "Coordinate") + call form_gradation_metric(positions, metric) + call allocate(tmp_metric, metric%mesh, "TmpMetric") + do i=1,iters + call insert(state(1), metric, "MeshSizingMetric") + call form_goal_metric(state, tmp_metric, goal_les_velocity_squared, goal_les_velocity_squared_grad) + call form_gradation_metric(positions, tmp_metric) + metric%val = tmp_metric%val + end do + call deallocate(tmp_metric) + end if + case("higher_order_les_goal") + call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_goal/nonlinear_iterations", iters, default=3) + call form_goal_metric_specific(state, metric, goal_les_velocity_4th, goal_les_velocity_4th_grad) + if (iters > 0) then + positions => extract_vector_field(state(1), "Coordinate") + call form_gradation_metric(positions, metric) + call allocate(tmp_metric, metric%mesh, "TmpMetric") + do i=1,iters + call insert(state(1), metric, "MeshSizingMetric") + call form_goal_metric(state, tmp_metric, goal_les_velocity_4th, goal_les_velocity_4th_grad) + call form_gradation_metric(positions, tmp_metric) + metric%val = tmp_metric%val + end do + call deallocate(tmp_metric) + end if + end select + end subroutine form_goal_metric_generic + + subroutine form_goal_metric_specific(state, metric, goal, goal_grad) + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(inout) :: metric + !! This function computes the goal, given the state + !! of the system. + interface + function goal(state) + use state_module, only:state_type + real :: goal + type(state_type), dimension(:), intent(in) :: state + end function goal + end interface + + !! This function computes the gradient of the goal + !! with respect to a particular dependency, at a particular point. + interface + subroutine goal_grad(state, dep, adj) + use fields_data_types, only:scalar_field + use state_module, only: state_type + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + end subroutine goal_grad + end interface + + character(len=FIELD_NAME_LEN) :: dep + integer :: i + type(tensor_field) :: dep_hessian, adj_hessian, tmp_metric + type(scalar_field) :: dep_err_field, adj_err_field, adj_field + type(scalar_field), pointer :: dep_field + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions, velocity + integer :: stat + logical :: allocated + type(scalar_field) :: edgelen + integer, save :: adaptcnt = 0 + character(len=20) :: buf + + ! At the moment all the fields have to be on the same mesh. + positions => extract_vector_field(state(1), "Coordinate") + velocity => extract_vector_field(state(1), "Velocity", stat=stat) + if (stat == 0) then + mesh => velocity%mesh + else + mesh => positions%mesh end if - case("higher_order_les_goal") - call get_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_goal/nonlinear_iterations", iters, default=3) - call form_goal_metric_specific(state, metric, goal_les_velocity_4th, goal_les_velocity_4th_grad) - if (iters > 0) then - positions => extract_vector_field(state(1), "Coordinate") - call form_gradation_metric(positions, metric) - call allocate(tmp_metric, metric%mesh, "TmpMetric") - do i=1,iters - call insert(state(1), metric, "MeshSizingMetric") - call form_goal_metric(state, tmp_metric, goal_les_velocity_4th, goal_les_velocity_4th_grad) - call form_gradation_metric(positions, tmp_metric) - metric%val = tmp_metric%val - end do - call deallocate(tmp_metric) + call allocate(dep_hessian, mesh, "Hessian") + call allocate(adj_hessian, mesh, "Adjoint Hessian") + call allocate(tmp_metric, mesh, "Accumulated Adjoint Hessian") + call allocate(adj_field, mesh, "Adjoint") + call allocate(dep_err_field, mesh, "Error field") + call allocate(adj_err_field, mesh, "Adjoint error field") + call allocate(edgelen, mesh, "Desired edge lengths") + call zero(metric) + call zero(tmp_metric) + + write(buf, '(i0)') adaptcnt + + if (goal_rel_tolerance /= 0.0) then + goal_tolerance = goal_rel_tolerance * goal(state) end if - end select - end subroutine form_goal_metric_generic - - subroutine form_goal_metric_specific(state, metric, goal, goal_grad) - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(inout) :: metric - !! This function computes the goal, given the state - !! of the system. - interface - function goal(state) - use state_module, only:state_type - real :: goal - type(state_type), dimension(:), intent(in) :: state - end function goal - end interface - - !! This function computes the gradient of the goal - !! with respect to a particular dependency, at a particular point. - interface - subroutine goal_grad(state, dep, adj) - use fields_data_types, only:scalar_field - use state_module, only: state_type - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - end subroutine goal_grad - end interface - - character(len=FIELD_NAME_LEN) :: dep - integer :: i - type(tensor_field) :: dep_hessian, adj_hessian, tmp_metric - type(scalar_field) :: dep_err_field, adj_err_field, adj_field - type(scalar_field), pointer :: dep_field - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions, velocity - integer :: stat - logical :: allocated - type(scalar_field) :: edgelen - integer, save :: adaptcnt = 0 - character(len=20) :: buf - - ! At the moment all the fields have to be on the same mesh. - positions => extract_vector_field(state(1), "Coordinate") - velocity => extract_vector_field(state(1), "Velocity", stat=stat) - if (stat == 0) then - mesh => velocity%mesh - else - mesh => positions%mesh - end if - call allocate(dep_hessian, mesh, "Hessian") - call allocate(adj_hessian, mesh, "Adjoint Hessian") - call allocate(tmp_metric, mesh, "Accumulated Adjoint Hessian") - call allocate(adj_field, mesh, "Adjoint") - call allocate(dep_err_field, mesh, "Error field") - call allocate(adj_err_field, mesh, "Adjoint error field") - call allocate(edgelen, mesh, "Desired edge lengths") - call zero(metric) - call zero(tmp_metric) - - write(buf, '(i0)') adaptcnt - - if (goal_rel_tolerance /= 0.0) then - goal_tolerance = goal_rel_tolerance * goal(state) - end if - - ! Loop over dependent variables of goal. - do i=1,size(goal_deps) - dep = goal_deps(i) - dep_field => extract_scalar_field(state(1), dep, allocated=allocated) - - ! Compute "adjoint" solution. - call compute_adjoint(goal_grad, state, dep, adj_field) + + ! Loop over dependent variables of goal. + do i=1,size(goal_deps) + dep = goal_deps(i) + dep_field => extract_scalar_field(state(1), dep, allocated=allocated) + + ! Compute "adjoint" solution. + call compute_adjoint(goal_grad, state, dep, adj_field) #ifdef GOAL_DEBUG - call vtk_write_fields("goal_adjoint_" // trim(buf), i, positions, mesh, sfields=(/dep_field, adj_field/)) + call vtk_write_fields("goal_adjoint_" // trim(buf), i, positions, mesh, sfields=(/dep_field, adj_field/)) #endif - ! Compute Hessians. - call compute_hessian(dep_field, positions, dep_hessian) + ! Compute Hessians. + call compute_hessian(dep_field, positions, dep_hessian) #ifdef GOAL_DEBUG - call get_edge_lengths(dep_hessian, edgelen) - call vtk_write_fields("goal_fhessian_" // trim(buf), i, positions, mesh, sfields=(/dep_field, edgelen/), tfields=(/dep_hessian/)) + call get_edge_lengths(dep_hessian, edgelen) + call vtk_write_fields("goal_fhessian_" // trim(buf), i, positions, mesh, sfields=(/dep_field, edgelen/), tfields=(/dep_hessian/)) #endif - call compute_hessian(adj_field, positions, adj_hessian) + call compute_hessian(adj_field, positions, adj_hessian) #ifdef GOAL_DEBUG - call get_edge_lengths(adj_hessian, edgelen) - call vtk_write_fields("goal_bhessian_" // trim(buf), i, positions, mesh, sfields=(/adj_field, edgelen/), tfields=(/adj_hessian/)) + call get_edge_lengths(adj_hessian, edgelen) + call vtk_write_fields("goal_bhessian_" // trim(buf), i, positions, mesh, sfields=(/adj_field, edgelen/), tfields=(/adj_hessian/)) #endif - ! Compute forward error field. - call compute_err_field(dep_field, dep_hessian, positions, adj_err_field) + ! Compute forward error field. + call compute_err_field(dep_field, dep_hessian, positions, adj_err_field) #ifdef GOAL_DEBUG - call vtk_write_fields("goal_berrfield_" // trim(buf), i, positions, mesh, sfields=(/adj_err_field/)) + call vtk_write_fields("goal_berrfield_" // trim(buf), i, positions, mesh, sfields=(/adj_err_field/)) #endif - call compute_err_field(adj_field, adj_hessian, positions, dep_err_field) + call compute_err_field(adj_field, adj_hessian, positions, dep_err_field) #ifdef GOAL_DEBUG - call vtk_write_fields("goal_ferrfield_" // trim(buf), i, positions, mesh, sfields=(/dep_err_field/)) + call vtk_write_fields("goal_ferrfield_" // trim(buf), i, positions, mesh, sfields=(/dep_err_field/)) #endif - ! Form metric. - call insert(state(1), dep_err_field, error_bound_name(trim(dep_field%name))) - call form_metric(state(1), dep_hessian, dep_field) + ! Form metric. + call insert(state(1), dep_err_field, error_bound_name(trim(dep_field%name))) + call form_metric(state(1), dep_hessian, dep_field) #ifdef GOAL_DEBUG - call get_edge_lengths(dep_hessian, edgelen) - call vtk_write_fields("goal_fmetric_" // trim(buf), i, positions, mesh, sfields=(/dep_field, edgelen/), tfields=(/dep_hessian/)) + call get_edge_lengths(dep_hessian, edgelen) + call vtk_write_fields("goal_fmetric_" // trim(buf), i, positions, mesh, sfields=(/dep_field, edgelen/), tfields=(/dep_hessian/)) #endif - call insert(state(1), adj_err_field, error_bound_name(trim(adj_field%name))) - call form_metric(state(1), adj_hessian, adj_field) + call insert(state(1), adj_err_field, error_bound_name(trim(adj_field%name))) + call form_metric(state(1), adj_hessian, adj_field) #ifdef GOAL_DEBUG - call get_edge_lengths(adj_hessian, edgelen) - call vtk_write_fields("goal_bmetric_" // trim(buf), i, positions, mesh, sfields=(/adj_field, edgelen/), tfields=(/adj_hessian/)) + call get_edge_lengths(adj_hessian, edgelen) + call vtk_write_fields("goal_bmetric_" // trim(buf), i, positions, mesh, sfields=(/adj_field, edgelen/), tfields=(/adj_hessian/)) #endif - ! Merge. - call merge_tensor_fields(metric, dep_hessian) + ! Merge. + call merge_tensor_fields(metric, dep_hessian) #ifdef GOAL_DEBUG - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("final_goal_fmetric_" // trim(buf), i, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("final_goal_fmetric_" // trim(buf), i, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) #endif - call merge_tensor_fields(tmp_metric, adj_hessian) + call merge_tensor_fields(tmp_metric, adj_hessian) #ifdef GOAL_DEBUG - call get_edge_lengths(tmp_metric, edgelen) - call vtk_write_fields("final_goal_bmetric_" // trim(buf), i, positions, mesh, sfields=(/edgelen/), tfields=(/tmp_metric/)) + call get_edge_lengths(tmp_metric, edgelen) + call vtk_write_fields("final_goal_bmetric_" // trim(buf), i, positions, mesh, sfields=(/edgelen/), tfields=(/tmp_metric/)) #endif - if (allocated) deallocate(dep_field) - end do - adaptcnt = adaptcnt + 1 + if (allocated) deallocate(dep_field) + end do + adaptcnt = adaptcnt + 1 - call merge_tensor_fields(metric, tmp_metric, aniso_min=.true.) + call merge_tensor_fields(metric, tmp_metric, aniso_min=.true.) #ifdef GOAL_DEBUG call get_edge_lengths(metric, edgelen) call vtk_write_fields("final_goal_metric_" // trim(buf), i, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) #endif - call deallocate(dep_hessian) - call deallocate(adj_hessian) - call deallocate(tmp_metric) - call deallocate(adj_field) - call deallocate(dep_err_field) - call deallocate(adj_err_field) - call deallocate(edgelen) - end subroutine form_goal_metric_specific - - subroutine compute_adjoint(goal_grad, state, dep, adj_field) - type(state_type), dimension(:), intent(in) :: state - character(len=FIELD_NAME_LEN), intent(in) :: dep - type(scalar_field), intent(inout) :: adj_field - !! This function computes the gradient of the goal - !! with respect to a particular dependency, at a particular point. - interface - subroutine goal_grad(state, dep, adj) - use fields_data_types, only: scalar_field - use state_module, only: state_type - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - end subroutine goal_grad - end interface - - call goal_grad(state, dep, adj_field) - adj_field%val = adj_field%val * dt - end subroutine compute_adjoint - - subroutine compute_err_field(field, hessian, positions, err_field) - type(scalar_field), intent(in) :: field - type(tensor_field), intent(in) :: hessian - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: err_field - - type(mesh_type) :: mesh - type(patch_type) :: patch - integer :: node, nnode, i - type(element_type), pointer :: t_shape, x_shape - real, dimension(hessian%dim(1), hessian%dim(2)) :: avg_hessian, evecs - real, dimension(hessian%dim(1)) :: edge, evals - - real :: err - - mesh = field%mesh - call add_nelist(mesh) - t_shape => ele_shape(field, 1) - x_shape => ele_shape(positions, 1) - - do node=1,node_count(mesh) - patch = get_patch_node(mesh, node, level=1) - err = 0.0 - - ! estimate residual. - do i=1,patch%count - nnode = patch%elements(i) - edge = node_val(positions, node) - node_val(positions, nnode) - avg_hessian = (node_val(hessian, node) + node_val(hessian, nnode)) / 2.0 - call eigendecomposition_symmetric(avg_hessian, evecs, evals) - evals = abs(evals) - call eigenrecomposition(avg_hessian, evecs, evals) - err = max(err, dot_product(edge, matmul(avg_hessian, edge))) + call deallocate(dep_hessian) + call deallocate(adj_hessian) + call deallocate(tmp_metric) + call deallocate(adj_field) + call deallocate(dep_err_field) + call deallocate(adj_err_field) + call deallocate(edgelen) + end subroutine form_goal_metric_specific + + subroutine compute_adjoint(goal_grad, state, dep, adj_field) + type(state_type), dimension(:), intent(in) :: state + character(len=FIELD_NAME_LEN), intent(in) :: dep + type(scalar_field), intent(inout) :: adj_field + !! This function computes the gradient of the goal + !! with respect to a particular dependency, at a particular point. + interface + subroutine goal_grad(state, dep, adj) + use fields_data_types, only: scalar_field + use state_module, only: state_type + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + end subroutine goal_grad + end interface + + call goal_grad(state, dep, adj_field) + adj_field%val = adj_field%val * dt + end subroutine compute_adjoint + + subroutine compute_err_field(field, hessian, positions, err_field) + type(scalar_field), intent(in) :: field + type(tensor_field), intent(in) :: hessian + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: err_field + + type(mesh_type) :: mesh + type(patch_type) :: patch + integer :: node, nnode, i + type(element_type), pointer :: t_shape, x_shape + real, dimension(hessian%dim(1), hessian%dim(2)) :: avg_hessian, evecs + real, dimension(hessian%dim(1)) :: edge, evals + + real :: err + + mesh = field%mesh + call add_nelist(mesh) + t_shape => ele_shape(field, 1) + x_shape => ele_shape(positions, 1) + + do node=1,node_count(mesh) + patch = get_patch_node(mesh, node, level=1) + err = 0.0 + + ! estimate residual. + do i=1,patch%count + nnode = patch%elements(i) + edge = node_val(positions, node) - node_val(positions, nnode) + avg_hessian = (node_val(hessian, node) + node_val(hessian, nnode)) / 2.0 + call eigendecomposition_symmetric(avg_hessian, evecs, evals) + evals = abs(evals) + call eigenrecomposition(avg_hessian, evecs, evals) + err = max(err, dot_product(edge, matmul(avg_hessian, edge))) + end do + + if (err == 0.0) then + err_field%val(node) = 1.0e10 + else + err_field%val(node) = goal_tolerance / (node_count(mesh) * err) + end if + deallocate(patch%elements) end do - - if (err == 0.0) then - err_field%val(node) = 1.0e10 - else - err_field%val(node) = goal_tolerance / (node_count(mesh) * err) - end if - deallocate(patch%elements) - end do - end subroutine compute_err_field + end subroutine compute_err_field end module goal_metric diff --git a/error_measures/Goals.F90 b/error_measures/Goals.F90 index 4a2fca8f8a..7e08a114f5 100644 --- a/error_measures/Goals.F90 +++ b/error_measures/Goals.F90 @@ -4,801 +4,801 @@ module goals !!< A repository of goals and their gradients, !!< suitable for use with goal-based optimisation. - use fldebug - use vector_tools - use elements - use spud - use tensors, only: tensormul - use fetools - use unittest_tools, only: get_matrix_identity - use fields - use state_module - use fefields - use field_derivatives, only: grad, curl - - implicit none - - public :: goal_temp, goal_temp_grad, & - & goal_enstrophy, goal_enstrophy_grad, & - & goal_les_velocity, goal_les_velocity_grad, & - & goal_les_velocity_squared, goal_les_velocity_squared_grad, & - & goal_les_velocity_4th, goal_les_velocity_4th_grad, & - & compute_goals - private - - contains - - subroutine compute_goals(state) - ! Check to see what goals are requested - ! and print them out per timestep - type(state_type), dimension(:), intent(in) :: state - real :: acctim - real :: goal_val - - call get_option("/timestepping/current_time", acctim) - - if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/enstrophy_goal")) then - goal_val = goal_enstrophy(state) - ewrite(1,*) "enstrophy_goal at time ", acctim, ": ", goal_val - end if - - if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/temperature_gradient_goal")) then - goal_val = goal_temp(state) - ewrite(1,*) "temperature_gradient_goal at time ", acctim, ": ", goal_val - end if - - if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_goal")) then - goal_val = goal_les_velocity(state) - ewrite(1,*) "les_goal at time ", acctim, ": ", goal_val - end if - - if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/higher_order_les_goal")) then - goal_val = goal_les_velocity_4th(state) - ewrite(1,*) "higher_order_les_goal at time ", acctim, ": ", goal_val - end if - - end subroutine compute_goals - - function goal_temp(state) - ! Basic sample goal: - ! int( transpose(grad(T)) . kappa . grad(T) ) dV. - ! kappa is a matrix that weights gradients - ! in certain directions more than others. - type(state_type), dimension(:), intent(in) :: state - real :: goal_temp - - integer :: ele, ngi - real, dimension(:), allocatable :: detwei, result - real, dimension(:, :, :), allocatable :: dn_t - type(scalar_field), pointer :: temp - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - real, dimension(:, :), allocatable :: kappa - real, dimension(:), allocatable :: vec - - temp => extract_scalar_field(state(1), "Temperature") - positions => extract_vector_field(state(1), "Coordinate") - - allocate(detwei(ele_ngi(temp, 1)), result(ele_ngi(temp, 1))) - allocate(dn_t(ele_loc(temp, 1), ele_ngi(temp, 1), positions%dim)) - allocate(kappa(positions%dim, positions%dim)) - allocate(vec(positions%dim)) - t_shape => ele_shape(temp, 1) - - goal_temp = 0.0 - - kappa = get_matrix_identity(size(kappa, 1)) - - do ele=1,ele_count(temp) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - do ngi=1,ele_ngi(temp, 1) - vec = matmul(ele_val(temp, ele), dn_t(:, ngi, :)) ! grad(T) - result(ngi) = dot_product(vec, matmul(kappa, vec)) - end do + use fldebug + use vector_tools + use elements + use spud + use tensors, only: tensormul + use fetools + use unittest_tools, only: get_matrix_identity + use fields + use state_module + use fefields + use field_derivatives, only: grad, curl + + implicit none + + public :: goal_temp, goal_temp_grad, & + & goal_enstrophy, goal_enstrophy_grad, & + & goal_les_velocity, goal_les_velocity_grad, & + & goal_les_velocity_squared, goal_les_velocity_squared_grad, & + & goal_les_velocity_4th, goal_les_velocity_4th_grad, & + & compute_goals + private + +contains + + subroutine compute_goals(state) + ! Check to see what goals are requested + ! and print them out per timestep + type(state_type), dimension(:), intent(in) :: state + real :: acctim + real :: goal_val + + call get_option("/timestepping/current_time", acctim) + + if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/enstrophy_goal")) then + goal_val = goal_enstrophy(state) + ewrite(1,*) "enstrophy_goal at time ", acctim, ": ", goal_val + end if + + if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/temperature_gradient_goal")) then + goal_val = goal_temp(state) + ewrite(1,*) "temperature_gradient_goal at time ", acctim, ": ", goal_val + end if + + if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/les_goal")) then + goal_val = goal_les_velocity(state) + ewrite(1,*) "les_goal at time ", acctim, ": ", goal_val + end if + + if (have_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/higher_order_les_goal")) then + goal_val = goal_les_velocity_4th(state) + ewrite(1,*) "higher_order_les_goal at time ", acctim, ": ", goal_val + end if + + end subroutine compute_goals + + function goal_temp(state) + ! Basic sample goal: + ! int( transpose(grad(T)) . kappa . grad(T) ) dV. + ! kappa is a matrix that weights gradients + ! in certain directions more than others. + type(state_type), dimension(:), intent(in) :: state + real :: goal_temp + + integer :: ele, ngi + real, dimension(:), allocatable :: detwei, result + real, dimension(:, :, :), allocatable :: dn_t + type(scalar_field), pointer :: temp + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + real, dimension(:, :), allocatable :: kappa + real, dimension(:), allocatable :: vec - goal_temp = goal_temp + dot_product(result, detwei) - end do - - deallocate(detwei) - deallocate(dn_t) - deallocate(kappa) - deallocate(vec) - end function goal_temp - - subroutine goal_temp_grad(state, dep, adj) - ! The derivative of the goal with respect to - ! whatever variables it depends on. - ! Here it only depends on "Temperature", so - ! other variables are ignored. - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - type(scalar_field), pointer :: temp - integer :: ele, loc, ngi - integer, dimension(:), pointer :: nodelist - real, dimension(ele_ngi(adj, 1)) :: detwei - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA - real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa - - call zero(adj) - - if (dep(1:11) == "Temperature") then temp => extract_scalar_field(state(1), "Temperature") - else if (dep(1:14) == "OldTemperature") then - temp => extract_scalar_field(state(1), "OldTemperature") - else - return - end if + positions => extract_vector_field(state(1), "Coordinate") - positions => extract_vector_field(state(1), "Coordinate") - t_shape => ele_shape(adj, 1) + allocate(detwei(ele_ngi(temp, 1)), result(ele_ngi(temp, 1))) + allocate(dn_t(ele_loc(temp, 1), ele_ngi(temp, 1), positions%dim)) + allocate(kappa(positions%dim, positions%dim)) + allocate(vec(positions%dim)) + t_shape => ele_shape(temp, 1) - kappa = get_matrix_identity(size(kappa, 1)) + goal_temp = 0.0 - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - do loc=1,ele_loc(adj, ele) - do ngi=1,ele_ngi(adj,ele) - tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) - end do - end do + kappa = get_matrix_identity(size(kappa, 1)) - ! tmpA now represents grad(N_i) . kappa . grad(N_i) + do ele=1,ele_count(temp) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(temp, nodelist(loc)) + do ngi=1,ele_ngi(temp, 1) + vec = matmul(ele_val(temp, ele), dn_t(:, ngi, :)) ! grad(T) + result(ngi) = dot_product(vec, matmul(kappa, vec)) + end do + + goal_temp = goal_temp + dot_product(result, detwei) end do - ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) - - call addto(adj, ele_nodes(adj, ele), 2.0 * matmul(tmpA, detwei)) - end do - - end subroutine goal_temp_grad - - function goal_enstrophy(state) - ! Compute the enstrophy of the system: - ! 1/2 * int(|curl(velocity)|**2) dV. - type(state_type), dimension(:), intent(in) :: state - real :: goal_enstrophy - - integer :: ele, node - real, dimension(:), allocatable :: detwei - type(scalar_field) :: vorticity - type(vector_field), pointer :: positions, velocity - type(element_type), pointer :: t_shape - - positions => extract_vector_field(state(1), "Coordinate") - velocity => extract_vector_field(state(1), "Velocity") - call allocate(vorticity, velocity%mesh, "|Vorticity|**2") - - call curl(velocity, positions, curl_norm=vorticity) - do node=1,node_count(vorticity) - vorticity%val(node) = vorticity%val(node)**2 - end do - - allocate(detwei(ele_ngi(vorticity, 1))) - t_shape => ele_shape(vorticity, 1) - - goal_enstrophy = 0.0 - - do ele=1,ele_count(vorticity) - call transform_to_physical(positions, ele, detwei=detwei) - goal_enstrophy = goal_enstrophy + dot_product(ele_val_at_quad(vorticity, ele), detwei) - end do - - goal_enstrophy = goal_enstrophy * 0.5 - - deallocate(detwei) - call deallocate(vorticity) - end function goal_enstrophy - - subroutine goal_enstrophy_grad(state, dep, adj) - ! The derivative of the goal with respect to - ! whatever variables it depends on. - ! Here it depends on "Velocity[123]". - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - - type(vector_field), pointer :: positions, velocity - type(element_type), pointer :: t_shape - integer :: ele, node, j, i - real, dimension(ele_ngi(adj, 1)) :: detwei - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t - type(mesh_type) :: mesh - ! curdim: which component of velocity are we processing - ! odima, odimb: the other components of velocity - ! curloc: the index of the current node in the list of nodes - ! associated with a particular element, i.e. where does it appear - ! in the local list of nodes - integer :: curdim, curloc, odima, odimb - integer, dimension(:), pointer :: e_n ! ele_nodes(mesh, ele) - type(patch_type) :: patch - real, dimension(ele_ngi(adj, 1)) :: r - - call zero(adj) - if (dep(1:8) /= "Velocity") then - return - end if - - mesh = adj%mesh - call add_nelist(mesh) - - read(dep(10:10), *) curdim ! Velocity1 -> 1 etc. - if (curdim == 1) then - odima = 2 - odimb = 3 - else if (curdim == 2) then - odima = 1 - odimb = 3 - else - odima = 1 - odimb = 2 - end if - - positions => extract_vector_field(state(1), "Coordinate") - velocity => extract_vector_field(state(1), "Velocity") - t_shape => ele_shape(adj, 1) - - do node=1,node_count(adj) - patch = get_patch_ele(mesh, node, level=1) - do j=1,patch%count - ele = patch%elements(j) - e_n => ele_nodes(mesh, ele) - do i=1,ele_loc(mesh, ele) - if (node == e_n(i)) then - curloc = i - exit - end if - end do - - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - r = 2 * node_val(velocity, curdim, node) * dn_t(curloc, :, odima)**2 - r = r + 2 * node_val(velocity, curdim, node) * dn_t(curloc, :, odimb)**2 - r = r - node_val(velocity, odima, node) * (dn_t(curloc, :, curdim) * dn_t(curloc, :, odima)) - r = r - node_val(velocity, odimb, node) * (dn_t(curloc, :, curdim) * dn_t(curloc, :, odimb)) - r = 0.5 * r - call addto(adj, node, dot_product(r, detwei)) + deallocate(detwei) + deallocate(dn_t) + deallocate(kappa) + deallocate(vec) + end function goal_temp + + subroutine goal_temp_grad(state, dep, adj) + ! The derivative of the goal with respect to + ! whatever variables it depends on. + ! Here it only depends on "Temperature", so + ! other variables are ignored. + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + type(scalar_field), pointer :: temp + integer :: ele, loc, ngi + integer, dimension(:), pointer :: nodelist + real, dimension(ele_ngi(adj, 1)) :: detwei + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA + real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa + + call zero(adj) + + if (dep(1:11) == "Temperature") then + temp => extract_scalar_field(state(1), "Temperature") + else if (dep(1:14) == "OldTemperature") then + temp => extract_scalar_field(state(1), "OldTemperature") + else + return + end if + + positions => extract_vector_field(state(1), "Coordinate") + t_shape => ele_shape(adj, 1) + + kappa = get_matrix_identity(size(kappa, 1)) + + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + do loc=1,ele_loc(adj, ele) + do ngi=1,ele_ngi(adj,ele) + tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) + end do + end do + + ! tmpA now represents grad(N_i) . kappa . grad(N_i) + + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(temp, nodelist(loc)) + end do + + ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) + + call addto(adj, ele_nodes(adj, ele), 2.0 * matmul(tmpA, detwei)) end do - end do - - end subroutine goal_enstrophy_grad - - !! LES goal-based error measures - function goal_les_temp(state) - ! int( transpose(grad(T)) . kappa . grad(T) ) dV. - ! kappa is the LES matrix. - type(state_type), dimension(:), intent(in) :: state - real :: goal_les_temp - - integer :: ele, ngi - real, dimension(:), allocatable :: detwei, result - real, dimension(:, :, :), allocatable :: dn_t - type(scalar_field), pointer :: temp - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - real, dimension(:, :), allocatable :: kappa - real, dimension(:), allocatable :: vec - type(vector_field), pointer :: nvelocity, gvelocity - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - integer :: stat, i - - temp => extract_scalar_field(state(1), "Temperature") - positions => extract_vector_field(state(1), "Coordinate") - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - allocate(detwei(ele_ngi(temp, 1)), result(ele_ngi(temp, 1))) - allocate(dn_t(ele_loc(temp, 1), ele_ngi(temp, 1), positions%dim)) - allocate(kappa(positions%dim, positions%dim)) - allocate(vec(positions%dim)) - t_shape => ele_shape(temp, 1) - - goal_les_temp = 0.0 - - if (stat /= 0) then ! MeshSizingMetric not found - do ele=1,ele_count(temp) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - do ngi=1,ele_ngi(temp, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) - vec = matmul(ele_val(temp, ele), dn_t(:, ngi, :)) ! grad(T) - result(ngi) = dot_product(vec, matmul(kappa, vec)) - end do + end subroutine goal_temp_grad + + function goal_enstrophy(state) + ! Compute the enstrophy of the system: + ! 1/2 * int(|curl(velocity)|**2) dV. + type(state_type), dimension(:), intent(in) :: state + real :: goal_enstrophy + + integer :: ele, node + real, dimension(:), allocatable :: detwei + type(scalar_field) :: vorticity + type(vector_field), pointer :: positions, velocity + type(element_type), pointer :: t_shape - goal_les_temp = goal_les_temp + dot_product(result, detwei) + positions => extract_vector_field(state(1), "Coordinate") + velocity => extract_vector_field(state(1), "Velocity") + call allocate(vorticity, velocity%mesh, "|Vorticity|**2") + + call curl(velocity, positions, curl_norm=vorticity) + do node=1,node_count(vorticity) + vorticity%val(node) = vorticity%val(node)**2 end do - else - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(temp, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(temp) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(temp, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(temp, 1) - call invert(mesh_size_tensor) - - do ngi=1,ele_ngi(temp, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) - vec = matmul(ele_val(temp, ele), dn_t(:, ngi, :)) ! grad(T) - result(ngi) = dot_product(vec, matmul(kappa, vec)) - end do - - goal_les_temp = goal_les_temp + dot_product(result, detwei) + + allocate(detwei(ele_ngi(vorticity, 1))) + t_shape => ele_shape(vorticity, 1) + + goal_enstrophy = 0.0 + + do ele=1,ele_count(vorticity) + call transform_to_physical(positions, ele, detwei=detwei) + goal_enstrophy = goal_enstrophy + dot_product(ele_val_at_quad(vorticity, ele), detwei) end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) - end if - - goal_les_temp = goal_les_temp * 0.5 - - deallocate(detwei) - deallocate(dn_t) - deallocate(kappa) - deallocate(vec) - end function goal_les_temp - - function goal_les_velocity(state) - ! 0.5 * int( transpose(grad(T)) . kappa . grad(T) ) dV. - ! kappa is the LES matrix. - type(state_type), dimension(:), intent(in) :: state - real :: goal_les_velocity - - integer :: ele, ngi - real, dimension(:), allocatable :: detwei, result - real, dimension(:, :, :), allocatable :: dn_t - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - real, dimension(:, :), allocatable :: kappa - real, dimension(:), allocatable :: vec - type(vector_field), pointer :: nvelocity, gvelocity - integer :: i - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - integer :: stat - - positions => extract_vector_field(state(1), "Coordinate") - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - allocate(detwei(ele_ngi(nvelocity, 1)), result(ele_ngi(nvelocity, 1))) - allocate(dn_t(ele_loc(nvelocity, 1), ele_ngi(nvelocity, 1), positions%dim)) - allocate(kappa(positions%dim, positions%dim)) - allocate(vec(positions%dim)) - t_shape => ele_shape(nvelocity, 1) - - goal_les_velocity = 0.0 - - if (stat /= 0) then ! MeshSizingMetric not found - do ele=1,ele_count(nvelocity) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - - do ngi=1,ele_ngi(nvelocity, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) - result(ngi) = 0.0 - do i=1,nvelocity%dim - vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) - result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) - end do - end do - - goal_les_velocity = goal_les_velocity + dot_product(result, detwei) + + goal_enstrophy = goal_enstrophy * 0.5 + + deallocate(detwei) + call deallocate(vorticity) + end function goal_enstrophy + + subroutine goal_enstrophy_grad(state, dep, adj) + ! The derivative of the goal with respect to + ! whatever variables it depends on. + ! Here it depends on "Velocity[123]". + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + + type(vector_field), pointer :: positions, velocity + type(element_type), pointer :: t_shape + integer :: ele, node, j, i + real, dimension(ele_ngi(adj, 1)) :: detwei + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t + type(mesh_type) :: mesh + ! curdim: which component of velocity are we processing + ! odima, odimb: the other components of velocity + ! curloc: the index of the current node in the list of nodes + ! associated with a particular element, i.e. where does it appear + ! in the local list of nodes + integer :: curdim, curloc, odima, odimb + integer, dimension(:), pointer :: e_n ! ele_nodes(mesh, ele) + type(patch_type) :: patch + real, dimension(ele_ngi(adj, 1)) :: r + + call zero(adj) + if (dep(1:8) /= "Velocity") then + return + end if + + mesh = adj%mesh + call add_nelist(mesh) + + read(dep(10:10), *) curdim ! Velocity1 -> 1 etc. + if (curdim == 1) then + odima = 2 + odimb = 3 + else if (curdim == 2) then + odima = 1 + odimb = 3 + else + odima = 1 + odimb = 2 + end if + + positions => extract_vector_field(state(1), "Coordinate") + velocity => extract_vector_field(state(1), "Velocity") + t_shape => ele_shape(adj, 1) + + do node=1,node_count(adj) + patch = get_patch_ele(mesh, node, level=1) + do j=1,patch%count + ele = patch%elements(j) + e_n => ele_nodes(mesh, ele) + do i=1,ele_loc(mesh, ele) + if (node == e_n(i)) then + curloc = i + exit + end if + end do + + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + r = 2 * node_val(velocity, curdim, node) * dn_t(curloc, :, odima)**2 + r = r + 2 * node_val(velocity, curdim, node) * dn_t(curloc, :, odimb)**2 + r = r - node_val(velocity, odima, node) * (dn_t(curloc, :, curdim) * dn_t(curloc, :, odima)) + r = r - node_val(velocity, odimb, node) * (dn_t(curloc, :, curdim) * dn_t(curloc, :, odimb)) + r = 0.5 * r + call addto(adj, node, dot_product(r, detwei)) + end do end do - else + + end subroutine goal_enstrophy_grad + + !! LES goal-based error measures + function goal_les_temp(state) + ! int( transpose(grad(T)) . kappa . grad(T) ) dV. + ! kappa is the LES matrix. + type(state_type), dimension(:), intent(in) :: state + real :: goal_les_temp + + integer :: ele, ngi + real, dimension(:), allocatable :: detwei, result + real, dimension(:, :, :), allocatable :: dn_t + type(scalar_field), pointer :: temp + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + real, dimension(:, :), allocatable :: kappa + real, dimension(:), allocatable :: vec + type(vector_field), pointer :: nvelocity, gvelocity + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + integer :: stat, i + + temp => extract_scalar_field(state(1), "Temperature") + positions => extract_vector_field(state(1), "Coordinate") + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) + + allocate(detwei(ele_ngi(temp, 1)), result(ele_ngi(temp, 1))) + allocate(dn_t(ele_loc(temp, 1), ele_ngi(temp, 1), positions%dim)) + allocate(kappa(positions%dim, positions%dim)) + allocate(vec(positions%dim)) + t_shape => ele_shape(temp, 1) + + goal_les_temp = 0.0 + + if (stat /= 0) then ! MeshSizingMetric not found + do ele=1,ele_count(temp) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + do ngi=1,ele_ngi(temp, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) + vec = matmul(ele_val(temp, ele), dn_t(:, ngi, :)) ! grad(T) + result(ngi) = dot_product(vec, matmul(kappa, vec)) + end do + + goal_les_temp = goal_les_temp + dot_product(result, detwei) + end do + else + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(temp, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(temp) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(temp, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(temp, 1) + call invert(mesh_size_tensor) + + do ngi=1,ele_ngi(temp, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) + vec = matmul(ele_val(temp, ele), dn_t(:, ngi, :)) ! grad(T) + result(ngi) = dot_product(vec, matmul(kappa, vec)) + end do + + goal_les_temp = goal_les_temp + dot_product(result, detwei) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) + end if + + goal_les_temp = goal_les_temp * 0.5 + + deallocate(detwei) + deallocate(dn_t) + deallocate(kappa) + deallocate(vec) + end function goal_les_temp + + function goal_les_velocity(state) + ! 0.5 * int( transpose(grad(T)) . kappa . grad(T) ) dV. + ! kappa is the LES matrix. + type(state_type), dimension(:), intent(in) :: state + real :: goal_les_velocity + + integer :: ele, ngi + real, dimension(:), allocatable :: detwei, result + real, dimension(:, :, :), allocatable :: dn_t + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + real, dimension(:, :), allocatable :: kappa + real, dimension(:), allocatable :: vec + type(vector_field), pointer :: nvelocity, gvelocity + integer :: i + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + integer :: stat + + positions => extract_vector_field(state(1), "Coordinate") + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) + + allocate(detwei(ele_ngi(nvelocity, 1)), result(ele_ngi(nvelocity, 1))) + allocate(dn_t(ele_loc(nvelocity, 1), ele_ngi(nvelocity, 1), positions%dim)) + allocate(kappa(positions%dim, positions%dim)) + allocate(vec(positions%dim)) + t_shape => ele_shape(nvelocity, 1) + + goal_les_velocity = 0.0 + + if (stat /= 0) then ! MeshSizingMetric not found + do ele=1,ele_count(nvelocity) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + + do ngi=1,ele_ngi(nvelocity, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) + result(ngi) = 0.0 + do i=1,nvelocity%dim + vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) + result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) + end do + end do + + goal_les_velocity = goal_les_velocity + dot_product(result, detwei) + end do + else + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(nvelocity) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) + + do ngi=1,ele_ngi(nvelocity, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) + result(ngi) = 0.0 + do i=1,nvelocity%dim + vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) + result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) + end do + end do + + goal_les_velocity = goal_les_velocity + dot_product(result, detwei) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) + end if + + goal_les_velocity = goal_les_velocity * 0.5 + + deallocate(detwei) + deallocate(result) + deallocate(dn_t) + deallocate(kappa) + deallocate(vec) + end function goal_les_velocity + + function les_tensor(nvelocity, gvelocity, dn_t, ele, gi, size_tensor) result(kappa) + !! Get the LES tensor at gauss point gi for element ele. + type(vector_field), intent(in) :: gvelocity, nvelocity + real, dimension(:, :, :), intent(in) :: dn_t + real, dimension(3, 3) :: kappa + real, dimension(3, 3), optional, intent(in) :: size_tensor + integer, intent(in) :: ele, gi + + real, dimension(ele_ngi(nvelocity, ele)) :: mxx, mxy, mxz, myy, myz, mzz ! ugh + + if (present(size_tensor)) then + mxx(gi) = size_tensor(1, 1) + mxy(gi) = size_tensor(1, 2) + mxz(gi) = size_tensor(1, 3) + myy(gi) = size_tensor(2, 2) + myz(gi) = size_tensor(2, 3) + mzz(gi) = size_tensor(3, 3) + else + call SIZEGIELETENS(dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), ele_loc(nvelocity, ele), & + & ele_ngi(nvelocity, ele), gi, MXX(gi), MXY(gi), MXZ(gi), MYY(gi), MYZ(gi), MZZ(gi)) + end if + + call LESVIS(node_count(nvelocity), ele_count(nvelocity), ele_loc(nvelocity, ele), & + & nvelocity%mesh%ndglno, ele_ngi(nvelocity, ele), ele, gi, & + & dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), & + & nvelocity%val(1,:), nvelocity%val(2,:), nvelocity%val(3,:), & + & gvelocity%val(1,:), gvelocity%val(2,:), gvelocity%val(3,:), & + & MXX, MXY, MXZ, MYY, MYZ, MZZ) + + kappa(1, 1) = mxx(gi) + kappa(1, 2) = mxy(gi) + kappa(2, 1) = mxy(gi) + kappa(1, 3) = mxz(gi) + kappa(3, 1) = mxz(gi) + kappa(2, 2) = myy(gi) + kappa(2, 3) = myz(gi) + kappa(3, 2) = myz(gi) + kappa(3, 3) = mzz(gi) + end function les_tensor + + function les_tensor_d(nvelocity, gvelocity, dn_t, ele, gi, nodes, dim, size_tensor) result(kappa) + !! Get the derivative of the LES tensor at gauss point gi for element ele, + !! with respect to dimension dim. + type(vector_field), intent(in) :: gvelocity, nvelocity + real, dimension(:, :, :), intent(in) :: dn_t + real, dimension(3, 3) :: kappa + real, dimension(3, 3), optional, intent(in) :: size_tensor + integer, dimension(:), intent(in) :: nodes + integer, intent(in) :: ele, gi, dim + real, dimension(node_count(nvelocity)) :: nud, nvd, nwd + + real :: mxx, mxy, mxz, myy, myz, mzz ! ugh + real :: mxxd, mxyd, mxzd, myyd, myzd, mzzd ! ugh + real :: lenxx, lenxy, lenxz, lenyy, lenyz, lenzz ! ugh + + if (present(size_tensor)) then + lenxx = size_tensor(1, 1) + lenxy = size_tensor(1, 2) + lenxz = size_tensor(1, 3) + lenyy = size_tensor(2, 2) + lenyz = size_tensor(2, 3) + lenzz = size_tensor(3, 3) + else + call sizegieletens(dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), ele_loc(nvelocity, ele), & + & ele_ngi(nvelocity, ele), gi, lenxx, lenxy, lenxz, lenyy, lenyz, lenzz) + end if + + ! set nud, nvd, nwd + ! these tell the derivative routine what to differentiate against + + nud = 0.0 + nvd = 0.0 + nwd = 0.0 + + select case(dim) + case(1) + nud(nodes) = 1.0 + case(2) + nvd(nodes) = 1.0 + case(3) + nvd(nodes) = 1.0 + end select + + call lesvis_d(node_count(nvelocity), ele_count(nvelocity), ele_loc(nvelocity, ele), & + & nvelocity%mesh%ndglno, ele_ngi(nvelocity, ele), ele, gi, & + & dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), & + & nvelocity%val(1,:), nud, nvelocity%val(2,:), nvd, nvelocity%val(3,:), nwd, & + & gvelocity%val(1,:), gvelocity%val(2,:), gvelocity%val(3,:), & + & lenxx, lenxy, lenxz, lenyy, lenyz, lenzz, & + & mxx, mxxd, mxy, mxyd, mxz, mxzd, myy, myyd, myz, myzd, mzz, mzzd) + + kappa(1, 1) = mxxd + kappa(1, 2) = mxyd + kappa(2, 1) = mxyd + kappa(1, 3) = mxzd + kappa(3, 1) = mxzd + kappa(2, 2) = myyd + kappa(2, 3) = myzd + kappa(3, 2) = myzd + kappa(3, 3) = mzzd + end function les_tensor_d + + subroutine goal_les_velocity_grad(state, dep, adj) + ! The derivative of the goal with respect to + ! whatever variables it depends on. + ! Here it only depends on "NonlinearVelocity", so + ! other variables are ignored. + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + type(scalar_field), pointer :: field + integer :: ele, loc, ngi + integer, dimension(:), pointer :: nodelist + real, dimension(ele_ngi(adj, 1)) :: detwei + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA, tmpB + real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa, kappa_d + type(vector_field), pointer :: nvelocity, gvelocity + integer :: idx, dim + logical :: allocated + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + integer :: stat, i + + call zero(adj) + ! String parsing in Fortran + ! is such a pain + ! it's unreal + idx = index(dep, "%") + if (idx == 0) then + return + end if + read(dep(idx+1:idx+1), *) dim + + if (dep(1:idx-1) == "NonlinearVelocity" .or. dep(1:idx-1) == "OldNonlinearVelocity") then + field => extract_scalar_field(state(1), trim(dep), allocated=allocated) + else + return + end if + + positions => extract_vector_field(state(1), "Coordinate") + t_shape => ele_shape(adj, 1) + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(nvelocity) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) - - do ngi=1,ele_ngi(nvelocity, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) - result(ngi) = 0.0 - do i=1,nvelocity%dim - vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) - result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) - end do - end do - - goal_les_velocity = goal_les_velocity + dot_product(result, detwei) + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + if (stat /= 0) then + kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1) + else + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) + + kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim, size_tensor=mesh_size_tensor) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1, size_tensor=mesh_size_tensor) + end if + + do ngi=1,ele_ngi(adj,ele) + do loc=1,ele_loc(adj, ele) + tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) + tmpB(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa_d, dn_t(loc, ngi, :))) + end do + end do + + ! tmpA now represents grad(N_i) . kappa . grad(N_i) + ! tmpB now represents grad(N_i) . kappa_d . grad(N_i) + + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) + tmpB(loc, :) = tmpB(loc, :) * 0.5 * (node_val(field, nodelist(loc)))**2 + end do + + ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) + ! tmpB now represents 1/2 * grad(U_i) . kappa_d . grad(U_i) + + call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) + call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) end do deallocate(mesh_size_tensor) deallocate(mesh_size_tensor_ele) - end if - - goal_les_velocity = goal_les_velocity * 0.5 - - deallocate(detwei) - deallocate(result) - deallocate(dn_t) - deallocate(kappa) - deallocate(vec) - end function goal_les_velocity - - function les_tensor(nvelocity, gvelocity, dn_t, ele, gi, size_tensor) result(kappa) - !! Get the LES tensor at gauss point gi for element ele. - type(vector_field), intent(in) :: gvelocity, nvelocity - real, dimension(:, :, :), intent(in) :: dn_t - real, dimension(3, 3) :: kappa - real, dimension(3, 3), optional, intent(in) :: size_tensor - integer, intent(in) :: ele, gi - - real, dimension(ele_ngi(nvelocity, ele)) :: mxx, mxy, mxz, myy, myz, mzz ! ugh - - if (present(size_tensor)) then - mxx(gi) = size_tensor(1, 1) - mxy(gi) = size_tensor(1, 2) - mxz(gi) = size_tensor(1, 3) - myy(gi) = size_tensor(2, 2) - myz(gi) = size_tensor(2, 3) - mzz(gi) = size_tensor(3, 3) - else - call SIZEGIELETENS(dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), ele_loc(nvelocity, ele), & - & ele_ngi(nvelocity, ele), gi, MXX(gi), MXY(gi), MXZ(gi), MYY(gi), MYZ(gi), MZZ(gi)) - end if - - call LESVIS(node_count(nvelocity), ele_count(nvelocity), ele_loc(nvelocity, ele), & - & nvelocity%mesh%ndglno, ele_ngi(nvelocity, ele), ele, gi, & - & dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), & - & nvelocity%val(1,:), nvelocity%val(2,:), nvelocity%val(3,:), & - & gvelocity%val(1,:), gvelocity%val(2,:), gvelocity%val(3,:), & - & MXX, MXY, MXZ, MYY, MYZ, MZZ) - - kappa(1, 1) = mxx(gi) - kappa(1, 2) = mxy(gi) - kappa(2, 1) = mxy(gi) - kappa(1, 3) = mxz(gi) - kappa(3, 1) = mxz(gi) - kappa(2, 2) = myy(gi) - kappa(2, 3) = myz(gi) - kappa(3, 2) = myz(gi) - kappa(3, 3) = mzz(gi) - end function les_tensor - - function les_tensor_d(nvelocity, gvelocity, dn_t, ele, gi, nodes, dim, size_tensor) result(kappa) - !! Get the derivative of the LES tensor at gauss point gi for element ele, - !! with respect to dimension dim. - type(vector_field), intent(in) :: gvelocity, nvelocity - real, dimension(:, :, :), intent(in) :: dn_t - real, dimension(3, 3) :: kappa - real, dimension(3, 3), optional, intent(in) :: size_tensor - integer, dimension(:), intent(in) :: nodes - integer, intent(in) :: ele, gi, dim - real, dimension(node_count(nvelocity)) :: nud, nvd, nwd - - real :: mxx, mxy, mxz, myy, myz, mzz ! ugh - real :: mxxd, mxyd, mxzd, myyd, myzd, mzzd ! ugh - real :: lenxx, lenxy, lenxz, lenyy, lenyz, lenzz ! ugh - - if (present(size_tensor)) then - lenxx = size_tensor(1, 1) - lenxy = size_tensor(1, 2) - lenxz = size_tensor(1, 3) - lenyy = size_tensor(2, 2) - lenyz = size_tensor(2, 3) - lenzz = size_tensor(3, 3) - else - call sizegieletens(dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), ele_loc(nvelocity, ele), & - & ele_ngi(nvelocity, ele), gi, lenxx, lenxy, lenxz, lenyy, lenyz, lenzz) - end if - - ! set nud, nvd, nwd - ! these tell the derivative routine what to differentiate against - - nud = 0.0 - nvd = 0.0 - nwd = 0.0 - - select case(dim) - case(1) - nud(nodes) = 1.0 - case(2) - nvd(nodes) = 1.0 - case(3) - nvd(nodes) = 1.0 - end select - - call lesvis_d(node_count(nvelocity), ele_count(nvelocity), ele_loc(nvelocity, ele), & - & nvelocity%mesh%ndglno, ele_ngi(nvelocity, ele), ele, gi, & - & dn_t(:, :, 1), dn_t(:, :, 2), dn_t(:, :, 3), & - & nvelocity%val(1,:), nud, nvelocity%val(2,:), nvd, nvelocity%val(3,:), nwd, & - & gvelocity%val(1,:), gvelocity%val(2,:), gvelocity%val(3,:), & - & lenxx, lenxy, lenxz, lenyy, lenyz, lenzz, & - & mxx, mxxd, mxy, mxyd, mxz, mxzd, myy, myyd, myz, myzd, mzz, mzzd) - - kappa(1, 1) = mxxd - kappa(1, 2) = mxyd - kappa(2, 1) = mxyd - kappa(1, 3) = mxzd - kappa(3, 1) = mxzd - kappa(2, 2) = myyd - kappa(2, 3) = myzd - kappa(3, 2) = myzd - kappa(3, 3) = mzzd - end function les_tensor_d - - subroutine goal_les_velocity_grad(state, dep, adj) - ! The derivative of the goal with respect to - ! whatever variables it depends on. - ! Here it only depends on "NonlinearVelocity", so - ! other variables are ignored. - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - type(scalar_field), pointer :: field - integer :: ele, loc, ngi - integer, dimension(:), pointer :: nodelist - real, dimension(ele_ngi(adj, 1)) :: detwei - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA, tmpB - real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa, kappa_d - type(vector_field), pointer :: nvelocity, gvelocity - integer :: idx, dim - logical :: allocated - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - integer :: stat, i - - call zero(adj) - ! String parsing in Fortran - ! is such a pain - ! it's unreal - idx = index(dep, "%") - if (idx == 0) then - return - end if - read(dep(idx+1:idx+1), *) dim - if (dep(1:idx-1) == "NonlinearVelocity" .or. dep(1:idx-1) == "OldNonlinearVelocity") then - field => extract_scalar_field(state(1), trim(dep), allocated=allocated) - else - return - end if - - positions => extract_vector_field(state(1), "Coordinate") - t_shape => ele_shape(adj, 1) - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - if (stat /= 0) then - kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1) + if (allocated) then + deallocate(field) + end if + end subroutine goal_les_velocity_grad + + subroutine goal_les_temp_grad(state, dep, adj) + ! The derivative of the goal with respect to + ! whatever variables it depends on. + ! Here it only depends on "Temperature", so + ! other variables are ignored. + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + type(scalar_field), pointer :: temp + integer :: ele, loc, ngi + integer, dimension(:), pointer :: nodelist + real, dimension(ele_ngi(adj, 1)) :: detwei + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA + real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa + type(vector_field), pointer :: nvelocity, gvelocity + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + integer :: stat, i + + call zero(adj) + if (trim(dep) == "Temperature") then + temp => extract_scalar_field(state(1), "Temperature") + else if (trim(dep) == "OldTemperature") then + temp => extract_scalar_field(state(1), "OldTemperature") else - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) - - kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim, size_tensor=mesh_size_tensor) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1, size_tensor=mesh_size_tensor) + return end if - do ngi=1,ele_ngi(adj,ele) - do loc=1,ele_loc(adj, ele) - tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) - tmpB(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa_d, dn_t(loc, ngi, :))) - end do - end do + positions => extract_vector_field(state(1), "Coordinate") + t_shape => ele_shape(adj, 1) + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - ! tmpA now represents grad(N_i) . kappa . grad(N_i) - ! tmpB now represents grad(N_i) . kappa_d . grad(N_i) - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) - tmpB(loc, :) = tmpB(loc, :) * 0.5 * (node_val(field, nodelist(loc)))**2 - end do + if (stat /= 0) then ! MeshSizingMetric not there + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + do ngi=1,ele_ngi(adj,ele) - ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) - ! tmpB now represents 1/2 * grad(U_i) . kappa_d . grad(U_i) - - call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) - call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) - end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) - - if (allocated) then - deallocate(field) - end if - end subroutine goal_les_velocity_grad - - subroutine goal_les_temp_grad(state, dep, adj) - ! The derivative of the goal with respect to - ! whatever variables it depends on. - ! Here it only depends on "Temperature", so - ! other variables are ignored. - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - type(scalar_field), pointer :: temp - integer :: ele, loc, ngi - integer, dimension(:), pointer :: nodelist - real, dimension(ele_ngi(adj, 1)) :: detwei - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA - real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa - type(vector_field), pointer :: nvelocity, gvelocity - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - integer :: stat, i - - call zero(adj) - if (trim(dep) == "Temperature") then - temp => extract_scalar_field(state(1), "Temperature") - else if (trim(dep) == "OldTemperature") then - temp => extract_scalar_field(state(1), "OldTemperature") - else - return - end if - - positions => extract_vector_field(state(1), "Coordinate") - t_shape => ele_shape(adj, 1) - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - - if (stat /= 0) then ! MeshSizingMetric not there - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - do ngi=1,ele_ngi(adj,ele) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) + do loc=1,ele_loc(adj, ele) + tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) + end do + end do - do loc=1,ele_loc(adj, ele) - tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) - end do - end do + ! tmpA now represents grad(N_i) . kappa . grad(N_i) - ! tmpA now represents grad(N_i) . kappa . grad(N_i) + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(temp, nodelist(loc)) + end do - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(temp, nodelist(loc)) - end do + ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) - ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) + call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) + end do + else + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) - end do - else - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) + do ngi=1,ele_ngi(adj,ele) - do ngi=1,ele_ngi(adj,ele) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) + do loc=1,ele_loc(adj, ele) + tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) + end do + end do - do loc=1,ele_loc(adj, ele) - tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) - end do - end do + ! tmpA now represents grad(N_i) . kappa . grad(N_i) - ! tmpA now represents grad(N_i) . kappa . grad(N_i) + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(temp, nodelist(loc)) + end do - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(temp, nodelist(loc)) - end do + ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) - ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) + call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) + end if - call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) - end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) - end if - - end subroutine goal_les_temp_grad - - subroutine sizegieletens(nx,ny,nz,nloc,ngi,gi, & - & tensxx,tensxy,tensxz,tensyy,tensyz,tenszz ) - integer nloc,ngi - integer gi - real tensxx,tensxy,tensxz,tensyy,tensyz,tenszz - real nx(nloc,ngi),ny(nloc,ngi),nz(nloc,ngi) - - real rn - real udl,vdl,wdl - integer iloc - - tensxx=0.0 - tensxy=0.0 - tensxz=0.0 - tensyy=0.0 - tensyz=0.0 - tenszz=0.0 - do 350 iloc=1,nloc - rn=nx(iloc,gi)**2+ny(iloc,gi)**2+nz(iloc,gi)**2 - udl=1.*nx(iloc,gi)/rn - vdl=1.*ny(iloc,gi)/rn - wdl=1.*nz(iloc,gi)/rn - - tensxx=tensxx + udl*udl - tensxy=tensxy + udl*vdl - tensxz=tensxz + udl*wdl - tensyy=tensyy + vdl*vdl - tensyz=tensyz + vdl*wdl - tenszz=tenszz + wdl*wdl -350 continue - return - end subroutine - - subroutine lesvis(nonods,totele,nloc,vondgl, ngi, ele,gi, & - & nx,ny,nz, & - & nu,nv,nw, ug,vg,wg, & - & mxxdtw,mxydtw,mxzdtw, & - & myydtw,myzdtw,mzzdtw) - integer nonods,totele,nloc,ngi, ele,gi - integer vondgl(totele*nloc) - real nx(nloc,ngi),ny(nloc,ngi),nz(nloc,ngi) - real nu(nonods),nv(nonods),nw(nonods) - real ug(nonods),vg(nonods),wg(nonods) - real mxxdtw(ngi),mxydtw(ngi),mxzdtw(ngi),myydtw(ngi) - real myzdtw(ngi),mzzdtw(ngi) - real sxxgi,sxygi,sxzgi,syygi,syzgi,szzgi,syxgi,szxgi,szygi - real vis,cs2,fourcs - real velud,velvd,velwd - integer l,iglv - sxxgi=0. - sxygi=0. - sxzgi=0. - syygi=0. - syzgi=0. - szzgi=0. - do 374 l=1,nloc - iglv=vondgl((ele-1)*nloc+l) + end subroutine goal_les_temp_grad + + subroutine sizegieletens(nx,ny,nz,nloc,ngi,gi, & + & tensxx,tensxy,tensxz,tensyy,tensyz,tenszz ) + integer nloc,ngi + integer gi + real tensxx,tensxy,tensxz,tensyy,tensyz,tenszz + real nx(nloc,ngi),ny(nloc,ngi),nz(nloc,ngi) + + real rn + real udl,vdl,wdl + integer iloc + + tensxx=0.0 + tensxy=0.0 + tensxz=0.0 + tensyy=0.0 + tensyz=0.0 + tenszz=0.0 + do 350 iloc=1,nloc + rn=nx(iloc,gi)**2+ny(iloc,gi)**2+nz(iloc,gi)**2 + udl=1.*nx(iloc,gi)/rn + vdl=1.*ny(iloc,gi)/rn + wdl=1.*nz(iloc,gi)/rn + + tensxx=tensxx + udl*udl + tensxy=tensxy + udl*vdl + tensxz=tensxz + udl*wdl + tensyy=tensyy + vdl*vdl + tensyz=tensyz + vdl*wdl + tenszz=tenszz + wdl*wdl +350 continue + return + end subroutine + + subroutine lesvis(nonods,totele,nloc,vondgl, ngi, ele,gi, & + & nx,ny,nz, & + & nu,nv,nw, ug,vg,wg, & + & mxxdtw,mxydtw,mxzdtw, & + & myydtw,myzdtw,mzzdtw) + integer nonods,totele,nloc,ngi, ele,gi + integer vondgl(totele*nloc) + real nx(nloc,ngi),ny(nloc,ngi),nz(nloc,ngi) + real nu(nonods),nv(nonods),nw(nonods) + real ug(nonods),vg(nonods),wg(nonods) + real mxxdtw(ngi),mxydtw(ngi),mxzdtw(ngi),myydtw(ngi) + real myzdtw(ngi),mzzdtw(ngi) + real sxxgi,sxygi,sxzgi,syygi,syzgi,szzgi,syxgi,szxgi,szygi + real vis,cs2,fourcs + real velud,velvd,velwd + integer l,iglv + sxxgi=0. + sxygi=0. + sxzgi=0. + syygi=0. + syzgi=0. + szzgi=0. + do 374 l=1,nloc + iglv=vondgl((ele-1)*nloc+l) velud=nu(iglv)-ug(iglv) velvd=nv(iglv)-vg(iglv) velwd=nw(iglv)-wg(iglv) @@ -808,23 +808,23 @@ subroutine lesvis(nonods,totele,nloc,vondgl, ngi, ele,gi, & syygi = syygi + ny(l,gi)*velvd syzgi = syzgi + 0.5*(nz(l,gi)*velvd+ny(l,gi)*velwd) szzgi = szzgi + nz(l,gi)*velwd -374 continue - syxgi=sxygi - szxgi=sxzgi - szygi=syzgi - vis=sqrt(2.* (sxxgi*sxxgi + sxygi*sxygi + sxzgi*sxzgi & - & + syxgi*syxgi + syygi*syygi + syzgi*syzgi & - & + szxgi*szxgi + szygi*szygi + szzgi*szzgi)) - cs2=0.1**2 - fourcs=4.*cs2 - mxxdtw(gi) = fourcs*vis*mxxdtw(gi) - mxydtw(gi) = fourcs*vis*mxydtw(gi) - mxzdtw(gi) = fourcs*vis*mxzdtw(gi) - myydtw(gi) = fourcs*vis*myydtw(gi) - myzdtw(gi) = fourcs*vis*myzdtw(gi) - mzzdtw(gi) = fourcs*vis*mzzdtw(gi) - return - end subroutine +374 continue + syxgi=sxygi + szxgi=sxzgi + szygi=syzgi + vis=sqrt(2.* (sxxgi*sxxgi + sxygi*sxygi + sxzgi*sxzgi & + & + syxgi*syxgi + syygi*syygi + syzgi*syzgi & + & + szxgi*szxgi + szygi*szygi + szzgi*szzgi)) + cs2=0.1**2 + fourcs=4.*cs2 + mxxdtw(gi) = fourcs*vis*mxxdtw(gi) + mxydtw(gi) = fourcs*vis*mxydtw(gi) + mxzdtw(gi) = fourcs*vis*mxzdtw(gi) + myydtw(gi) = fourcs*vis*myydtw(gi) + myzdtw(gi) = fourcs*vis*myzdtw(gi) + mzzdtw(gi) = fourcs*vis*mzzdtw(gi) + return + end subroutine ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 2.2.3 (r2178) - 11/14/2007 15:07 @@ -833,592 +833,592 @@ subroutine lesvis(nonods,totele,nloc,vondgl, ngi, ele,gi, & ! variations of output variables: mxzdtw mxydtw mxxdtw myzdtw ! myydtw mzzdtw ! with respect to input variables: nu nv nw -subroutine lesvis_d(nonods, totele, nloc, vondgl, ngi, ele, gi, nx, ny, & -& nz, nu, nud, nv, nvd, nw, nwd, ug, vg, wg, lenxx, lenxy, lenxz, lenyy& -& , lenyz, lenzz, mxxdtw, mxxdtwd, mxydtw, mxydtwd, mxzdtw, mxzdtwd, & -& myydtw, myydtwd, myzdtw, myzdtwd, mzzdtw, mzzdtwd) - implicit none - integer, intent(in) :: nonods, totele, nloc, ngi, ele, gi - integer, intent(in) :: vondgl(totele*nloc) - real, intent(in) :: nx(nloc, ngi), ny(nloc, ngi), nz(nloc, ngi) - real, intent(in) :: nu(nonods), nv(nonods), nw(nonods) - real, intent(in) :: nud(nonods), nvd(nonods), nwd(nonods) - real, intent(in) :: ug(nonods), vg(nonods), wg(nonods) - real, intent(in) :: lenxx, lenxy, lenxz, lenyy - real, intent(in) :: lenyz, lenzz - real, intent(out) :: mxxdtw, mxydtw, mxzdtw, myydtw - real, intent(out) :: mxxdtwd, mxydtwd, mxzdtwd, myydtwd - real, intent(out) :: myzdtw, mzzdtw - real, intent(out) :: myzdtwd, mzzdtwd - real :: sxxgi, sxygi, sxzgi, syygi, syzgi, szzgi, syxgi, szxgi, szygi - real :: sxxgid, sxygid, sxzgid, syygid, syzgid, szzgid, syxgid, szxgid& -& , szygid - real :: vis, cs2, fourcs - real :: visd - real :: velud, velvd, velwd - real :: veludd, velvdd, velwdd - integer :: l, iglv - real :: arg1 - real :: arg1d - intrinsic sqrt - sxxgi = 0. - sxygi = 0. - sxzgi = 0. - syygi = 0. - syzgi = 0. - szzgi = 0. - syygid = 0.0 - sxygid = 0.0 - sxxgid = 0.0 - szzgid = 0.0 - syzgid = 0.0 - sxzgid = 0.0 - do l=1,nloc - iglv = vondgl((ele-1)*nloc+l) - veludd = nud(iglv) - velud = nu(iglv) - ug(iglv) - velvdd = nvd(iglv) - velvd = nv(iglv) - vg(iglv) - velwdd = nwd(iglv) - velwd = nw(iglv) - wg(iglv) - sxxgid = sxxgid + nx(l, gi)*veludd - sxxgi = sxxgi + nx(l, gi)*velud - sxygid = sxygid + 0.5*(ny(l, gi)*veludd+nx(l, gi)*velvdd) - sxygi = sxygi + 0.5*(ny(l, gi)*velud+nx(l, gi)*velvd) - sxzgid = sxzgid + 0.5*(nz(l, gi)*veludd+nx(l, gi)*velwdd) - sxzgi = sxzgi + 0.5*(nz(l, gi)*velud+nx(l, gi)*velwd) - syygid = syygid + ny(l, gi)*velvdd - syygi = syygi + ny(l, gi)*velvd - syzgid = syzgid + 0.5*(nz(l, gi)*velvdd+ny(l, gi)*velwdd) - syzgi = syzgi + 0.5*(nz(l, gi)*velvd+ny(l, gi)*velwd) - szzgid = szzgid + nz(l, gi)*velwdd - szzgi = szzgi + nz(l, gi)*velwd - end do - syxgid = sxygid - syxgi = sxygi - szxgid = sxzgid - szxgi = sxzgi - szygid = syzgid - szygi = syzgi - arg1d = 2.*(sxxgid*sxxgi+sxxgi*sxxgid+sxygid*sxygi+sxygi*sxygid+sxzgid& -& *sxzgi+sxzgi*sxzgid+syxgid*syxgi+syxgi*syxgid+syygid*syygi+syygi*& -& syygid+syzgid*syzgi+syzgi*syzgid+szxgid*szxgi+szxgi*szxgid+szygid*& -& szygi+szygi*szygid+szzgid*szzgi+szzgi*szzgid) - arg1 = 2.*(sxxgi*sxxgi+sxygi*sxygi+sxzgi*sxzgi+syxgi*syxgi+syygi*syygi& -& +syzgi*syzgi+szxgi*szxgi+szygi*szygi+szzgi*szzgi) - if (arg1 .eq. 0.0) then - visd = 0.0 - else - visd = arg1d/(2.0*sqrt(arg1)) - end if - vis = sqrt(arg1) - cs2 = 0.1**2 - fourcs = 4.*cs2 - mxxdtwd = fourcs*lenxx*visd - mxxdtw = fourcs*vis*lenxx - mxydtwd = fourcs*lenxy*visd - mxydtw = fourcs*vis*lenxy - mxzdtwd = fourcs*lenxz*visd - mxzdtw = fourcs*vis*lenxz - myydtwd = fourcs*lenyy*visd - myydtw = fourcs*vis*lenyy - myzdtwd = fourcs*lenyz*visd - myzdtw = fourcs*vis*lenyz - mzzdtwd = fourcs*lenzz*visd - mzzdtw = fourcs*vis*lenzz - return -end subroutine lesvis_d - - function goal_les_velocity_4th(state) - ! 0.5 * int( transpose(grad(T)) . kappa . grad(T) dv) - - ! 0.5 * int( transpose(grad(T)_h) . kappa . grad(T)_h dV). - ! kappa is the LES matrix. - type(state_type), dimension(:), intent(in) :: state - real :: goal_les_velocity_4th - - integer :: ele, ngi - real, dimension(:), allocatable :: detwei, result - real, dimension(:, :, :), allocatable :: derivs - real, dimension(:, :, :), allocatable :: dn_t - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - real, dimension(:, :), allocatable :: kappa - real, dimension(:), allocatable :: vec - type(vector_field), pointer :: nvelocity, gvelocity - integer :: i - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - type(vector_field), dimension(3) :: grad_h_vel - integer :: stat - - positions => extract_vector_field(state(1), "Coordinate") - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - allocate(detwei(ele_ngi(nvelocity, 1)), result(ele_ngi(nvelocity, 1)), derivs(positions%dim, positions%dim, ele_ngi(nvelocity, 1))) - allocate(dn_t(ele_loc(nvelocity, 1), ele_ngi(nvelocity, 1), positions%dim)) - allocate(kappa(positions%dim, positions%dim)) - allocate(vec(positions%dim)) - - do i=1,nvelocity%dim - call allocate(grad_h_vel(i), nvelocity%dim, nvelocity%mesh, "GradientNonlinearVelocity") - end do - call grad(nvelocity, positions, grad_h_vel) - - t_shape => ele_shape(nvelocity, 1) - - goal_les_velocity_4th = 0.0 - - if (stat /= 0) then ! MeshSizingMetric not found - do ele=1,ele_count(nvelocity) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - do i=1,positions%dim - derivs(i, :, :) = ele_val_at_quad(grad_h_vel(i), ele) - end do - - do ngi=1,ele_ngi(nvelocity, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) - result(ngi) = 0.0 - do i=1,nvelocity%dim - vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) - result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) - end do - - do i=1,nvelocity%dim - vec = derivs(i, :, ngi) - result(ngi) = result(ngi) - dot_product(vec, matmul(kappa, vec)) - end do - end do - - goal_les_velocity_4th = goal_les_velocity_4th + dot_product(result, detwei) + subroutine lesvis_d(nonods, totele, nloc, vondgl, ngi, ele, gi, nx, ny, & + & nz, nu, nud, nv, nvd, nw, nwd, ug, vg, wg, lenxx, lenxy, lenxz, lenyy& + & , lenyz, lenzz, mxxdtw, mxxdtwd, mxydtw, mxydtwd, mxzdtw, mxzdtwd, & + & myydtw, myydtwd, myzdtw, myzdtwd, mzzdtw, mzzdtwd) + implicit none + integer, intent(in) :: nonods, totele, nloc, ngi, ele, gi + integer, intent(in) :: vondgl(totele*nloc) + real, intent(in) :: nx(nloc, ngi), ny(nloc, ngi), nz(nloc, ngi) + real, intent(in) :: nu(nonods), nv(nonods), nw(nonods) + real, intent(in) :: nud(nonods), nvd(nonods), nwd(nonods) + real, intent(in) :: ug(nonods), vg(nonods), wg(nonods) + real, intent(in) :: lenxx, lenxy, lenxz, lenyy + real, intent(in) :: lenyz, lenzz + real, intent(out) :: mxxdtw, mxydtw, mxzdtw, myydtw + real, intent(out) :: mxxdtwd, mxydtwd, mxzdtwd, myydtwd + real, intent(out) :: myzdtw, mzzdtw + real, intent(out) :: myzdtwd, mzzdtwd + real :: sxxgi, sxygi, sxzgi, syygi, syzgi, szzgi, syxgi, szxgi, szygi + real :: sxxgid, sxygid, sxzgid, syygid, syzgid, szzgid, syxgid, szxgid& + & , szygid + real :: vis, cs2, fourcs + real :: visd + real :: velud, velvd, velwd + real :: veludd, velvdd, velwdd + integer :: l, iglv + real :: arg1 + real :: arg1d + intrinsic sqrt + sxxgi = 0. + sxygi = 0. + sxzgi = 0. + syygi = 0. + syzgi = 0. + szzgi = 0. + syygid = 0.0 + sxygid = 0.0 + sxxgid = 0.0 + szzgid = 0.0 + syzgid = 0.0 + sxzgid = 0.0 + do l=1,nloc + iglv = vondgl((ele-1)*nloc+l) + veludd = nud(iglv) + velud = nu(iglv) - ug(iglv) + velvdd = nvd(iglv) + velvd = nv(iglv) - vg(iglv) + velwdd = nwd(iglv) + velwd = nw(iglv) - wg(iglv) + sxxgid = sxxgid + nx(l, gi)*veludd + sxxgi = sxxgi + nx(l, gi)*velud + sxygid = sxygid + 0.5*(ny(l, gi)*veludd+nx(l, gi)*velvdd) + sxygi = sxygi + 0.5*(ny(l, gi)*velud+nx(l, gi)*velvd) + sxzgid = sxzgid + 0.5*(nz(l, gi)*veludd+nx(l, gi)*velwdd) + sxzgi = sxzgi + 0.5*(nz(l, gi)*velud+nx(l, gi)*velwd) + syygid = syygid + ny(l, gi)*velvdd + syygi = syygi + ny(l, gi)*velvd + syzgid = syzgid + 0.5*(nz(l, gi)*velvdd+ny(l, gi)*velwdd) + syzgi = syzgi + 0.5*(nz(l, gi)*velvd+ny(l, gi)*velwd) + szzgid = szzgid + nz(l, gi)*velwdd + szzgi = szzgi + nz(l, gi)*velwd end do - else - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(nvelocity) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) - - do i=1,positions%dim - derivs(i, :, :) = ele_val_at_quad(grad_h_vel(i), ele) - end do - - do ngi=1,ele_ngi(nvelocity, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) - result(ngi) = 0.0 - do i=1,nvelocity%dim - vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) - result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) - end do - - do i=1,nvelocity%dim - vec = derivs(i, :, ngi) - result(ngi) = result(ngi) - dot_product(vec, matmul(kappa, vec)) - end do - end do - - goal_les_velocity_4th = goal_les_velocity_4th + dot_product(result, detwei) - end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) - end if - - goal_les_velocity_4th = goal_les_velocity_4th * 0.5 - - deallocate(detwei) - deallocate(dn_t) - deallocate(kappa) - deallocate(result) - deallocate(vec) - deallocate(derivs) - do i=1,nvelocity%dim - call deallocate(grad_h_vel(i)) - end do - end function goal_les_velocity_4th - - subroutine goal_les_velocity_4th_grad(state, dep, adj) - ! The derivative of the goal with respect to - ! whatever variables it depends on. - ! Here it only depends on "NonlinearVelocity", so - ! other variables are ignored. - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - type(scalar_field), pointer :: field - integer :: ele, loc, ngi - integer, dimension(:), pointer :: nodelist - real, dimension(ele_ngi(adj, 1)) :: detwei - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA, tmpB - real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa, kappa_d - real, dimension(ele_loc(adj, 1), ele_loc(adj, 1)) :: ss - real, dimension(ele_loc(adj, 1)) :: result, ones - type(vector_field), pointer :: nvelocity, gvelocity - integer :: idx, dim - logical :: allocated - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - type(vector_field) :: grad_h_vel - integer :: stat, i - real, dimension(mesh_dim(adj), ele_loc(adj, 1), ele_loc(adj, 1)) :: r - real, dimension(mesh_dim(adj), ele_loc(adj, 1)) :: r_grad_ele - type(scalar_field) :: lumped_mass - - - call zero(adj) - ! String parsing in Fortran - ! is such a pain - ! it's unreal - idx = index(dep, "%") - if (idx == 0) then - return - end if - read(dep(idx+1:len(dep)), *) dim - - if (dep(1:idx-1) == "NonlinearVelocity" .or. dep(1:idx-1) == "OldNonlinearVelocity") then - field => extract_scalar_field(state(1), trim(dep), allocated=allocated) - else + syxgid = sxygid + syxgi = sxygi + szxgid = sxzgid + szxgi = sxzgi + szygid = syzgid + szygi = syzgi + arg1d = 2.*(sxxgid*sxxgi+sxxgi*sxxgid+sxygid*sxygi+sxygi*sxygid+sxzgid& + & *sxzgi+sxzgi*sxzgid+syxgid*syxgi+syxgi*syxgid+syygid*syygi+syygi*& + & syygid+syzgid*syzgi+syzgi*syzgid+szxgid*szxgi+szxgi*szxgid+szygid*& + & szygi+szygi*szygid+szzgid*szzgi+szzgi*szzgid) + arg1 = 2.*(sxxgi*sxxgi+sxygi*sxygi+sxzgi*sxzgi+syxgi*syxgi+syygi*syygi& + & +syzgi*syzgi+szxgi*szxgi+szygi*szygi+szzgi*szzgi) + if (arg1 .eq. 0.0) then + visd = 0.0 + else + visd = arg1d/(2.0*sqrt(arg1)) + end if + vis = sqrt(arg1) + cs2 = 0.1**2 + fourcs = 4.*cs2 + mxxdtwd = fourcs*lenxx*visd + mxxdtw = fourcs*vis*lenxx + mxydtwd = fourcs*lenxy*visd + mxydtw = fourcs*vis*lenxy + mxzdtwd = fourcs*lenxz*visd + mxzdtw = fourcs*vis*lenxz + myydtwd = fourcs*lenyy*visd + myydtw = fourcs*vis*lenyy + myzdtwd = fourcs*lenyz*visd + myzdtw = fourcs*vis*lenyz + mzzdtwd = fourcs*lenzz*visd + mzzdtw = fourcs*vis*lenzz return - end if - - positions => extract_vector_field(state(1), "Coordinate") - t_shape => ele_shape(adj, 1) - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - dim = nvelocity%dim - ones = 1.0 - - call allocate(grad_h_vel, nvelocity%dim, nvelocity%mesh, "GradientNonlinearVelocity") - call allocate(lumped_mass, nvelocity%mesh, "LumpedMass") - call grad(field, positions, grad_h_vel) - call compute_lumped_mass(positions, lumped_mass) - - if (stat /= 0) then ! MeshSizingMetric not there - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1) - ss = shape_shape(t_shape, t_shape, detwei) - - do ngi=1,ele_ngi(adj,ele) - do loc=1,ele_loc(adj, ele) - tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) - tmpB(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa_d, dn_t(loc, ngi, :))) - end do - end do - - ! tmpA now represents grad(N_i) . kappa . grad(N_i) - ! tmpB now represents grad(N_i) . kappa_d . grad(N_i) - - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) - tmpB(loc, :) = tmpB(loc, :) * 0.5 * (node_val(field, nodelist(loc)))**2 - end do - - ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) - ! tmpB now represents 1/2 * grad(U_i) . kappa_d . grad(U_i) - - call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) - call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) - - ! And now the terms that give the higher order. - do loc=1,ele_loc(adj, ele) - result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & - & matmul(kappa_d, node_val(grad_h_vel, nodelist(loc)))) - end do - - call addto(adj, ele_nodes(adj, ele), -0.5 * result) - - r = shape_dshape(t_shape, dn_t, detwei) - r_grad_ele = tensormul(r, ones, 3) - - do i=1,size(r_grad_ele, 1) - r_grad_ele(i, :) = r_grad_ele(i, :) / ele_val(lumped_mass, ele) - end do - - do loc=1,ele_loc(adj, ele) - result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & - & matmul(kappa, r_grad_ele(:, loc))) - end do - - call addto(adj, ele_nodes(adj, ele), -1.0 * result) + end subroutine lesvis_d + + function goal_les_velocity_4th(state) + ! 0.5 * int( transpose(grad(T)) . kappa . grad(T) dv) - + ! 0.5 * int( transpose(grad(T)_h) . kappa . grad(T)_h dV). + ! kappa is the LES matrix. + type(state_type), dimension(:), intent(in) :: state + real :: goal_les_velocity_4th + + integer :: ele, ngi + real, dimension(:), allocatable :: detwei, result + real, dimension(:, :, :), allocatable :: derivs + real, dimension(:, :, :), allocatable :: dn_t + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + real, dimension(:, :), allocatable :: kappa + real, dimension(:), allocatable :: vec + type(vector_field), pointer :: nvelocity, gvelocity + integer :: i + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + type(vector_field), dimension(3) :: grad_h_vel + integer :: stat + + positions => extract_vector_field(state(1), "Coordinate") + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) + + allocate(detwei(ele_ngi(nvelocity, 1)), result(ele_ngi(nvelocity, 1)), derivs(positions%dim, positions%dim, ele_ngi(nvelocity, 1))) + allocate(dn_t(ele_loc(nvelocity, 1), ele_ngi(nvelocity, 1), positions%dim)) + allocate(kappa(positions%dim, positions%dim)) + allocate(vec(positions%dim)) + + do i=1,nvelocity%dim + call allocate(grad_h_vel(i), nvelocity%dim, nvelocity%mesh, "GradientNonlinearVelocity") end do - else - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) - - kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim, size_tensor=mesh_size_tensor) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1, size_tensor=mesh_size_tensor) - ss = shape_shape(t_shape, t_shape, detwei) - - do ngi=1,ele_ngi(adj,ele) - do loc=1,ele_loc(adj, ele) - tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) - tmpB(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa_d, dn_t(loc, ngi, :))) - end do - end do - - ! tmpA now represents grad(N_i) . kappa . grad(N_i) - ! tmpB now represents grad(N_i) . kappa_d . grad(N_i) - - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) - tmpB(loc, :) = tmpB(loc, :) * 0.5 * (node_val(field, nodelist(loc)))**2 - end do - - ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) - ! tmpB now represents 1/2 * grad(U_i) . kappa_d . grad(U_i) - - call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) - call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) - - ! And now the terms that give the higher order. - do loc=1,ele_loc(adj, ele) - result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & - & matmul(kappa_d, node_val(grad_h_vel, nodelist(loc)))) - end do - - call addto(adj, ele_nodes(adj, ele), -0.5 * result) - - r = shape_dshape(t_shape, dn_t, detwei) - r_grad_ele = tensormul(r, ones, 3) - - do i=1,size(r_grad_ele, 1) - r_grad_ele(i, :) = r_grad_ele(i, :) / ele_val(lumped_mass, ele) - end do - - do loc=1,ele_loc(adj, ele) - result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & - & matmul(kappa, r_grad_ele(:, loc))) - end do - - call addto(adj, ele_nodes(adj, ele), -1.0 * result) - end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) - end if - - call deallocate(grad_h_vel) - call deallocate(lumped_mass) - if (allocated) then - deallocate(field) - end if - end subroutine goal_les_velocity_4th_grad - - function goal_les_velocity_squared(state) - ! 0.5 * int( |kappa . grad(T)|^2 ) dV. - ! kappa is the LES matrix. - type(state_type), dimension(:), intent(in) :: state - real :: goal_les_velocity_squared - - integer :: ele, ngi - real, dimension(:), allocatable :: detwei, result - real, dimension(:, :, :), allocatable :: dn_t - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - real, dimension(:, :), allocatable :: kappa - real, dimension(:), allocatable :: vec - type(vector_field), pointer :: nvelocity, gvelocity - integer :: i - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - integer :: stat - - positions => extract_vector_field(state(1), "Coordinate") - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - allocate(detwei(ele_ngi(nvelocity, 1)), result(ele_ngi(nvelocity, 1))) - allocate(dn_t(ele_loc(nvelocity, 1), ele_ngi(nvelocity, 1), positions%dim)) - allocate(kappa(positions%dim, positions%dim)) - allocate(vec(positions%dim)) - t_shape => ele_shape(nvelocity, 1) - - goal_les_velocity_squared = 0.0 - - if (stat /= 0) then ! MeshSizingMetric not found - do ele=1,ele_count(nvelocity) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - - do ngi=1,ele_ngi(nvelocity, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) - result(ngi) = 0.0 - do i=1,nvelocity%dim - vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) - vec = matmul(kappa, vec) - result(ngi) = result(ngi) + norm2(vec)**2 - end do - end do - - goal_les_velocity_squared = goal_les_velocity_squared + dot_product(result, detwei) - end do - else - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(nvelocity) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) - - do ngi=1,ele_ngi(nvelocity, 1) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) - result(ngi) = 0.0 - do i=1,nvelocity%dim - vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) - vec = matmul(kappa, vec) - result(ngi) = result(ngi) + norm2(vec)**2 - end do - end do - - goal_les_velocity_squared = goal_les_velocity_squared + dot_product(result, detwei) - end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) - end if - - goal_les_velocity_squared = goal_les_velocity_squared * 0.5 - - deallocate(detwei) - deallocate(result) - deallocate(dn_t) - deallocate(kappa) - deallocate(vec) - end function goal_les_velocity_squared - - subroutine goal_les_velocity_squared_grad(state, dep, adj) - ! The derivative of the goal with respect to - ! whatever variables it depends on. - ! Here it only depends on "NonlinearVelocity", so - ! other variables are ignored. - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: dep - type(scalar_field), intent(inout) :: adj - - type(vector_field), pointer :: positions - type(element_type), pointer :: t_shape - type(scalar_field), pointer :: field - integer :: ele, loc, ngi - integer, dimension(:), pointer :: nodelist - real, dimension(ele_ngi(adj, 1)) :: detwei - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t - real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA, tmpB - real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa, kappa_d - real, dimension(mesh_dim(adj)) :: tmp_vector - type(vector_field), pointer :: nvelocity, gvelocity - integer :: idx, dim - logical :: allocated - type(tensor_field), pointer :: mesh_metric - real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele - real, dimension(:, :), allocatable :: mesh_size_tensor - integer :: stat, i - - call zero(adj) - ! String parsing in Fortran - ! is such a pain - ! it's unreal - idx = index(dep, "%") - if (idx == 0) then - return - end if - read(dep(idx+1:idx+1), *) dim + call grad(nvelocity, positions, grad_h_vel) - if (dep(1:idx-1) == "NonlinearVelocity" .or. dep(1:idx-1) == "OldNonlinearVelocity") then - field => extract_scalar_field(state(1), trim(dep), allocated=allocated) - else - return - end if - - positions => extract_vector_field(state(1), "Coordinate") - t_shape => ele_shape(adj, 1) - nvelocity => extract_vector_field(state(1), "NonlinearVelocity") - gvelocity => extract_vector_field(state(1), "GridVelocity") - mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - - allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) - allocate(mesh_size_tensor(positions%dim, positions%dim)) - do ele=1,ele_count(adj) - nodelist => ele_nodes(adj, ele) - call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) - - if (stat /= 0) then - kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1) + t_shape => ele_shape(nvelocity, 1) + + goal_les_velocity_4th = 0.0 + + if (stat /= 0) then ! MeshSizingMetric not found + do ele=1,ele_count(nvelocity) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + do i=1,positions%dim + derivs(i, :, :) = ele_val_at_quad(grad_h_vel(i), ele) + end do + + do ngi=1,ele_ngi(nvelocity, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) + result(ngi) = 0.0 + do i=1,nvelocity%dim + vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) + result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) + end do + + do i=1,nvelocity%dim + vec = derivs(i, :, ngi) + result(ngi) = result(ngi) - dot_product(vec, matmul(kappa, vec)) + end do + end do + + goal_les_velocity_4th = goal_les_velocity_4th + dot_product(result, detwei) + end do else - mesh_size_tensor_ele = ele_val(mesh_metric, ele) - mesh_size_tensor = 0.0 - do i=1,ele_loc(positions, 1) - mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) - end do - mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) - call invert(mesh_size_tensor) - - kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim, size_tensor=mesh_size_tensor) - kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1, size_tensor=mesh_size_tensor) + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(nvelocity) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) + + do i=1,positions%dim + derivs(i, :, :) = ele_val_at_quad(grad_h_vel(i), ele) + end do + + do ngi=1,ele_ngi(nvelocity, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) + result(ngi) = 0.0 + do i=1,nvelocity%dim + vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) + result(ngi) = result(ngi) + dot_product(vec, matmul(kappa, vec)) + end do + + do i=1,nvelocity%dim + vec = derivs(i, :, ngi) + result(ngi) = result(ngi) - dot_product(vec, matmul(kappa, vec)) + end do + end do + + goal_les_velocity_4th = goal_les_velocity_4th + dot_product(result, detwei) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) end if - do ngi=1,ele_ngi(adj,ele) - do loc=1,ele_loc(adj, ele) - tmp_vector = matmul(kappa, dn_t(loc, ngi, :)) - tmpA(loc, ngi) = dot_product(tmp_vector, tmp_vector) - tmpB(loc, ngi) = dot_product(tmp_vector, matmul(kappa_d, dn_t(loc, ngi, :))) - end do + goal_les_velocity_4th = goal_les_velocity_4th * 0.5 + + deallocate(detwei) + deallocate(dn_t) + deallocate(kappa) + deallocate(result) + deallocate(vec) + deallocate(derivs) + do i=1,nvelocity%dim + call deallocate(grad_h_vel(i)) end do + end function goal_les_velocity_4th + + subroutine goal_les_velocity_4th_grad(state, dep, adj) + ! The derivative of the goal with respect to + ! whatever variables it depends on. + ! Here it only depends on "NonlinearVelocity", so + ! other variables are ignored. + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + type(scalar_field), pointer :: field + integer :: ele, loc, ngi + integer, dimension(:), pointer :: nodelist + real, dimension(ele_ngi(adj, 1)) :: detwei + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA, tmpB + real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa, kappa_d + real, dimension(ele_loc(adj, 1), ele_loc(adj, 1)) :: ss + real, dimension(ele_loc(adj, 1)) :: result, ones + type(vector_field), pointer :: nvelocity, gvelocity + integer :: idx, dim + logical :: allocated + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + type(vector_field) :: grad_h_vel + integer :: stat, i + real, dimension(mesh_dim(adj), ele_loc(adj, 1), ele_loc(adj, 1)) :: r + real, dimension(mesh_dim(adj), ele_loc(adj, 1)) :: r_grad_ele + type(scalar_field) :: lumped_mass + + + call zero(adj) + ! String parsing in Fortran + ! is such a pain + ! it's unreal + idx = index(dep, "%") + if (idx == 0) then + return + end if + read(dep(idx+1:len(dep)), *) dim - ! tmpA now represents (kappa x gradN) dot (kappa x gradN) - ! tmpA now represents (kappa x gradN) dot (kappa_d x gradN) + if (dep(1:idx-1) == "NonlinearVelocity" .or. dep(1:idx-1) == "OldNonlinearVelocity") then + field => extract_scalar_field(state(1), trim(dep), allocated=allocated) + else + return + end if - do loc=1,ele_loc(adj, ele) - tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) * 2 - tmpB(loc, :) = tmpB(loc, :) * 2 * (node_val(field, nodelist(loc)))**2 - end do + positions => extract_vector_field(state(1), "Coordinate") + t_shape => ele_shape(adj, 1) + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) + dim = nvelocity%dim + ones = 1.0 + + call allocate(grad_h_vel, nvelocity%dim, nvelocity%mesh, "GradientNonlinearVelocity") + call allocate(lumped_mass, nvelocity%mesh, "LumpedMass") + call grad(field, positions, grad_h_vel) + call compute_lumped_mass(positions, lumped_mass) + + if (stat /= 0) then ! MeshSizingMetric not there + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1) + ss = shape_shape(t_shape, t_shape, detwei) + + do ngi=1,ele_ngi(adj,ele) + do loc=1,ele_loc(adj, ele) + tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) + tmpB(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa_d, dn_t(loc, ngi, :))) + end do + end do + + ! tmpA now represents grad(N_i) . kappa . grad(N_i) + ! tmpB now represents grad(N_i) . kappa_d . grad(N_i) + + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) + tmpB(loc, :) = tmpB(loc, :) * 0.5 * (node_val(field, nodelist(loc)))**2 + end do + + ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) + ! tmpB now represents 1/2 * grad(U_i) . kappa_d . grad(U_i) + + call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) + call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) + + ! And now the terms that give the higher order. + do loc=1,ele_loc(adj, ele) + result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & + & matmul(kappa_d, node_val(grad_h_vel, nodelist(loc)))) + end do + + call addto(adj, ele_nodes(adj, ele), -0.5 * result) + + r = shape_dshape(t_shape, dn_t, detwei) + r_grad_ele = tensormul(r, ones, 3) + + do i=1,size(r_grad_ele, 1) + r_grad_ele(i, :) = r_grad_ele(i, :) / ele_val(lumped_mass, ele) + end do + + do loc=1,ele_loc(adj, ele) + result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & + & matmul(kappa, r_grad_ele(:, loc))) + end do + + call addto(adj, ele_nodes(adj, ele), -1.0 * result) + end do + else + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) + + kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim, size_tensor=mesh_size_tensor) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1, size_tensor=mesh_size_tensor) + ss = shape_shape(t_shape, t_shape, detwei) + + do ngi=1,ele_ngi(adj,ele) + do loc=1,ele_loc(adj, ele) + tmpA(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa, dn_t(loc, ngi, :))) + tmpB(loc, ngi) = dot_product(dn_t(loc, ngi, :), matmul(kappa_d, dn_t(loc, ngi, :))) + end do + end do + + ! tmpA now represents grad(N_i) . kappa . grad(N_i) + ! tmpB now represents grad(N_i) . kappa_d . grad(N_i) + + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) + tmpB(loc, :) = tmpB(loc, :) * 0.5 * (node_val(field, nodelist(loc)))**2 + end do + + ! tmpA now represents T_i . (grad(N_i) . kappa . grad(N_i)) + ! tmpB now represents 1/2 * grad(U_i) . kappa_d . grad(U_i) + + call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) + call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) + + ! And now the terms that give the higher order. + do loc=1,ele_loc(adj, ele) + result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & + & matmul(kappa_d, node_val(grad_h_vel, nodelist(loc)))) + end do + + call addto(adj, ele_nodes(adj, ele), -0.5 * result) + + r = shape_dshape(t_shape, dn_t, detwei) + r_grad_ele = tensormul(r, ones, 3) + + do i=1,size(r_grad_ele, 1) + r_grad_ele(i, :) = r_grad_ele(i, :) / ele_val(lumped_mass, ele) + end do + + do loc=1,ele_loc(adj, ele) + result(loc) = ss(loc, loc) * dot_product(node_val(grad_h_vel, nodelist(loc)), & + & matmul(kappa, r_grad_ele(:, loc))) + end do + + call addto(adj, ele_nodes(adj, ele), -1.0 * result) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) + end if + + call deallocate(grad_h_vel) + call deallocate(lumped_mass) + if (allocated) then + deallocate(field) + end if + end subroutine goal_les_velocity_4th_grad + + function goal_les_velocity_squared(state) + ! 0.5 * int( |kappa . grad(T)|^2 ) dV. + ! kappa is the LES matrix. + type(state_type), dimension(:), intent(in) :: state + real :: goal_les_velocity_squared + + integer :: ele, ngi + real, dimension(:), allocatable :: detwei, result + real, dimension(:, :, :), allocatable :: dn_t + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + real, dimension(:, :), allocatable :: kappa + real, dimension(:), allocatable :: vec + type(vector_field), pointer :: nvelocity, gvelocity + integer :: i + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + integer :: stat + + positions => extract_vector_field(state(1), "Coordinate") + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) + + allocate(detwei(ele_ngi(nvelocity, 1)), result(ele_ngi(nvelocity, 1))) + allocate(dn_t(ele_loc(nvelocity, 1), ele_ngi(nvelocity, 1), positions%dim)) + allocate(kappa(positions%dim, positions%dim)) + allocate(vec(positions%dim)) + t_shape => ele_shape(nvelocity, 1) + + goal_les_velocity_squared = 0.0 + + if (stat /= 0) then ! MeshSizingMetric not found + do ele=1,ele_count(nvelocity) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + + do ngi=1,ele_ngi(nvelocity, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi) + result(ngi) = 0.0 + do i=1,nvelocity%dim + vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) + vec = matmul(kappa, vec) + result(ngi) = result(ngi) + norm2(vec)**2 + end do + end do + + goal_les_velocity_squared = goal_les_velocity_squared + dot_product(result, detwei) + end do + else + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(nvelocity) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) + + do ngi=1,ele_ngi(nvelocity, 1) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, ngi, size_tensor=mesh_size_tensor) + result(ngi) = 0.0 + do i=1,nvelocity%dim + vec = matmul(ele_val(nvelocity, i, ele), dn_t(:, ngi, :)) + vec = matmul(kappa, vec) + result(ngi) = result(ngi) + norm2(vec)**2 + end do + end do + + goal_les_velocity_squared = goal_les_velocity_squared + dot_product(result, detwei) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) + end if - ! tmpA now represents 2 * u_i * tmpA - ! tmpB now represents 2 * u_i**2 * tmpB + goal_les_velocity_squared = goal_les_velocity_squared * 0.5 + + deallocate(detwei) + deallocate(result) + deallocate(dn_t) + deallocate(kappa) + deallocate(vec) + end function goal_les_velocity_squared + + subroutine goal_les_velocity_squared_grad(state, dep, adj) + ! The derivative of the goal with respect to + ! whatever variables it depends on. + ! Here it only depends on "NonlinearVelocity", so + ! other variables are ignored. + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: dep + type(scalar_field), intent(inout) :: adj + + type(vector_field), pointer :: positions + type(element_type), pointer :: t_shape + type(scalar_field), pointer :: field + integer :: ele, loc, ngi + integer, dimension(:), pointer :: nodelist + real, dimension(ele_ngi(adj, 1)) :: detwei + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1), mesh_dim(adj)) :: dn_t + real, dimension(ele_loc(adj, 1), ele_ngi(adj, 1)) :: tmpA, tmpB + real, dimension(mesh_dim(adj), mesh_dim(adj)) :: kappa, kappa_d + real, dimension(mesh_dim(adj)) :: tmp_vector + type(vector_field), pointer :: nvelocity, gvelocity + integer :: idx, dim + logical :: allocated + type(tensor_field), pointer :: mesh_metric + real, dimension(:, :, :), allocatable :: mesh_size_tensor_ele + real, dimension(:, :), allocatable :: mesh_size_tensor + integer :: stat, i + + call zero(adj) + ! String parsing in Fortran + ! is such a pain + ! it's unreal + idx = index(dep, "%") + if (idx == 0) then + return + end if + read(dep(idx+1:idx+1), *) dim + + if (dep(1:idx-1) == "NonlinearVelocity" .or. dep(1:idx-1) == "OldNonlinearVelocity") then + field => extract_scalar_field(state(1), trim(dep), allocated=allocated) + else + return + end if - call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) - call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) - end do - deallocate(mesh_size_tensor) - deallocate(mesh_size_tensor_ele) + positions => extract_vector_field(state(1), "Coordinate") + t_shape => ele_shape(adj, 1) + nvelocity => extract_vector_field(state(1), "NonlinearVelocity") + gvelocity => extract_vector_field(state(1), "GridVelocity") + mesh_metric => extract_tensor_field(state(1), "MeshSizingMetric", stat=stat) - if (allocated) then - deallocate(field) - end if - end subroutine goal_les_velocity_squared_grad + allocate(mesh_size_tensor_ele(positions%dim, positions%dim, ele_loc(positions, 1))) + allocate(mesh_size_tensor(positions%dim, positions%dim)) + do ele=1,ele_count(adj) + nodelist => ele_nodes(adj, ele) + call transform_to_physical(positions, ele, t_shape, dshape=dn_t, detwei=detwei) + + if (stat /= 0) then + kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1) + else + mesh_size_tensor_ele = ele_val(mesh_metric, ele) + mesh_size_tensor = 0.0 + do i=1,ele_loc(positions, 1) + mesh_size_tensor = mesh_size_tensor + mesh_size_tensor_ele(:, :, i) + end do + mesh_size_tensor = mesh_size_tensor / ele_loc(positions, 1) + call invert(mesh_size_tensor) + + kappa_d = les_tensor_d(nvelocity, gvelocity, dn_t, ele, 1, nodelist, dim, size_tensor=mesh_size_tensor) + kappa = les_tensor(nvelocity, gvelocity, dn_t, ele, 1, size_tensor=mesh_size_tensor) + end if + + do ngi=1,ele_ngi(adj,ele) + do loc=1,ele_loc(adj, ele) + tmp_vector = matmul(kappa, dn_t(loc, ngi, :)) + tmpA(loc, ngi) = dot_product(tmp_vector, tmp_vector) + tmpB(loc, ngi) = dot_product(tmp_vector, matmul(kappa_d, dn_t(loc, ngi, :))) + end do + end do + + ! tmpA now represents (kappa x gradN) dot (kappa x gradN) + ! tmpA now represents (kappa x gradN) dot (kappa_d x gradN) + + do loc=1,ele_loc(adj, ele) + tmpA(loc, :) = tmpA(loc, :) * node_val(field, nodelist(loc)) * 2 + tmpB(loc, :) = tmpB(loc, :) * 2 * (node_val(field, nodelist(loc)))**2 + end do + + ! tmpA now represents 2 * u_i * tmpA + ! tmpB now represents 2 * u_i**2 * tmpB + + call addto(adj, ele_nodes(adj, ele), matmul(tmpA, detwei)) + call addto(adj, ele_nodes(adj, ele), matmul(tmpB, detwei)) + end do + deallocate(mesh_size_tensor) + deallocate(mesh_size_tensor_ele) + + if (allocated) then + deallocate(field) + end if + end subroutine goal_les_velocity_squared_grad end module goals diff --git a/error_measures/Gradation_metric.F90 b/error_measures/Gradation_metric.F90 index df89aeb98a..4e8481cb2f 100644 --- a/error_measures/Gradation_metric.F90 +++ b/error_measures/Gradation_metric.F90 @@ -9,657 +9,657 @@ module gradation_metric !!< "Anisotropic mesh gradation control", Li et. al, !!< 13th International Meshing Roundtable, 2004 - use fldebug - use spud - use vector_tools - use sparse_tools - use unittest_tools - use adjacency_lists - use linked_lists - use metric_tools - use fields - use vtk_interfaces - use node_boundary - use edge_length_module - use field_derivatives - - implicit none - - ! These are the DEFAULTS ONLY IF YOU DON'T CALL - ! initialise_gradation_metric. - ! initialise_gradation_metric changes them for real code. - ! Bottom line: if you want to change whether gradation is used - ! or the gradation constant, CHANGE THE VALUES in INITIALISE_GRADATION_METRIC - logical :: use_gradation_metric = .false. - real :: gamma0 = 1.5 !!< Gamma is a measure of the smoothness of the transition - !!< an edge. Gamma0 is the maximum allowed value for gamma. - - real :: theta1 = 0.01 !!< Theta1 is the maximum angle we deem to be noise in the - !!< misalignment of the metric tensors at distance 1.0. - real :: theta0 = 0.35 !!< Theta0 is the maximum angle we deem to be noise in the - !!< misalignment of the metric tensors at distance 0.0. - integer :: max_rot_its = 8 - real :: domain_scale - - private - - public :: initialise_gradation_metric, form_gradation_metric, use_gradation_metric,& - construct_edge_list, tag_edges, wrap_pop, match_up_ellipsoids, match_up_vectors,& - rotate_vec, warp_directions - - contains - - subroutine initialise_gradation_metric - - use_gradation_metric=have_option("/mesh_adaptivity/hr_adaptivity/enable_gradation") - - if (have_option("/mesh_adaptivity/hr_adaptivity/enable_gradation/gradation_parameter")) then - call get_option("/mesh_adaptivity/hr_adaptivity/enable_gradation/gradation_parameter", gamma0) - else - gamma0 = 1.5 - end if - - ewrite(2,*) 'gradation: ', use_gradation_metric, gamma0 - - end subroutine initialise_gradation_metric - - subroutine form_gradation_metric(positions, error_metric, noits) - type(tensor_field), intent(inout) :: error_metric !!< The metric formed so far - type(vector_field), intent(in) :: positions - integer, intent(out), optional :: noits - - type(csr_matrix) :: nnlist !!< Node-node adjacency list - type(csr_sparsity), pointer :: nn_sparsity !!< Node-node adjacency list sparsity - type(elist) :: edgelist !!< Linked list of edges - type(mesh_type) :: mesh - integer :: p, q !! the nodes - real, dimension(error_metric%dim(1), error_metric%dim(2)) :: vec_P, vec_Q ! eigenvectors - real, dimension(error_metric%dim(1)) :: val_P, val_Q ! the eigenvalues - logical :: vals_changed_P, vals_changed_Q !!< have P or Q changed? If so need to reform - logical :: vecs_changed_P, vecs_changed_Q !!< the metric and update any surrounding nodes. - - integer :: boundcount_P, boundcount_Q, expected_boundcount - logical :: do_warp_directions - - integer :: dim, count - - integer :: global_its, end_marker ! count how many sweeps this involves - - type(scalar_field) :: edgelen - integer, save :: adaptcnt = 0 + use fldebug + use spud + use vector_tools + use sparse_tools + use unittest_tools + use adjacency_lists + use linked_lists + use metric_tools + use fields + use vtk_interfaces + use node_boundary + use edge_length_module + use field_derivatives + + implicit none + + ! These are the DEFAULTS ONLY IF YOU DON'T CALL + ! initialise_gradation_metric. + ! initialise_gradation_metric changes them for real code. + ! Bottom line: if you want to change whether gradation is used + ! or the gradation constant, CHANGE THE VALUES in INITIALISE_GRADATION_METRIC + logical :: use_gradation_metric = .false. + real :: gamma0 = 1.5 !!< Gamma is a measure of the smoothness of the transition + !!< an edge. Gamma0 is the maximum allowed value for gamma. + + real :: theta1 = 0.01 !!< Theta1 is the maximum angle we deem to be noise in the + !!< misalignment of the metric tensors at distance 1.0. + real :: theta0 = 0.35 !!< Theta0 is the maximum angle we deem to be noise in the + !!< misalignment of the metric tensors at distance 0.0. + integer :: max_rot_its = 8 + real :: domain_scale + + private + + public :: initialise_gradation_metric, form_gradation_metric, use_gradation_metric,& + construct_edge_list, tag_edges, wrap_pop, match_up_ellipsoids, match_up_vectors,& + rotate_vec, warp_directions + +contains + + subroutine initialise_gradation_metric + + use_gradation_metric=have_option("/mesh_adaptivity/hr_adaptivity/enable_gradation") + + if (have_option("/mesh_adaptivity/hr_adaptivity/enable_gradation/gradation_parameter")) then + call get_option("/mesh_adaptivity/hr_adaptivity/enable_gradation/gradation_parameter", gamma0) + else + gamma0 = 1.5 + end if + + ewrite(2,*) 'gradation: ', use_gradation_metric, gamma0 + + end subroutine initialise_gradation_metric + + subroutine form_gradation_metric(positions, error_metric, noits) + type(tensor_field), intent(inout) :: error_metric !!< The metric formed so far + type(vector_field), intent(in) :: positions + integer, intent(out), optional :: noits + + type(csr_matrix) :: nnlist !!< Node-node adjacency list + type(csr_sparsity), pointer :: nn_sparsity !!< Node-node adjacency list sparsity + type(elist) :: edgelist !!< Linked list of edges + type(mesh_type) :: mesh + integer :: p, q !! the nodes + real, dimension(error_metric%dim(1), error_metric%dim(2)) :: vec_P, vec_Q ! eigenvectors + real, dimension(error_metric%dim(1)) :: val_P, val_Q ! the eigenvalues + logical :: vals_changed_P, vals_changed_Q !!< have P or Q changed? If so need to reform + logical :: vecs_changed_P, vecs_changed_Q !!< the metric and update any surrounding nodes. + + integer :: boundcount_P, boundcount_Q, expected_boundcount + logical :: do_warp_directions + + integer :: dim, count + + integer :: global_its, end_marker ! count how many sweeps this involves + + type(scalar_field) :: edgelen + integer, save :: adaptcnt = 0 #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - integer :: stepcount - type(scalar_field) :: nodefield + integer :: stepcount + type(scalar_field) :: nodefield #endif - logical :: debug_metric + logical :: debug_metric - dim = error_metric%dim(1) - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") + dim = error_metric%dim(1) + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - ewrite(2,*) "++: Applying gradation" + ewrite(2,*) "++: Applying gradation" - mesh = error_metric%mesh - domain_scale = domain_length_scale(positions) - call initialise_boundcount(mesh, positions) + mesh = error_metric%mesh + domain_scale = domain_length_scale(positions) + call initialise_boundcount(mesh, positions) #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "domain_scale == ", domain_scale + write(0,*) "domain_scale == ", domain_scale #endif - if (domain_is_2d()) then - expected_boundcount = 1 - else - expected_boundcount = 0 - end if + if (domain_is_2d()) then + expected_boundcount = 1 + else + expected_boundcount = 0 + end if - !! Here I describe a convention I use in the nnlist. - !! Normally the val array of the CSR matrix doesn't exist - !! (as the value doesn't really matter). Here I set - !! (i,j) to < 0 if (i,j) is NOT in the linked list of edges, - !! and > 0 if it IS in the linked list of edges. - !! |(i,j)| is the number of times it's been checked + 1. + !! Here I describe a convention I use in the nnlist. + !! Normally the val array of the CSR matrix doesn't exist + !! (as the value doesn't really matter). Here I set + !! (i,j) to < 0 if (i,j) is NOT in the linked list of edges, + !! and > 0 if it IS in the linked list of edges. + !! |(i,j)| is the number of times it's been checked + 1. - nn_sparsity => extract_nnlist(mesh) - call allocate(nnlist, nn_sparsity, type=CSR_INTEGER) - nnlist%ival = -1 + nn_sparsity => extract_nnlist(mesh) + call allocate(nnlist, nn_sparsity, type=CSR_INTEGER) + nnlist%ival = -1 - call construct_edge_list(mesh, nnlist, edgelist) + call construct_edge_list(mesh, nnlist, edgelist) - if (debug_metric) then - call allocate(edgelen, error_metric%mesh, "Desired edge lengths") - end if + if (debug_metric) then + call allocate(edgelen, error_metric%mesh, "Desired edge lengths") + end if - ! OK. So now we have the edge list. + ! OK. So now we have the edge list. #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - stepcount = 0 - call allocate(nodefield, error_metric%mesh, "Node number") - call get_node_field(error_metric%mesh, nodefield) + stepcount = 0 + call allocate(nodefield, error_metric%mesh, "Node number") + call get_node_field(error_metric%mesh, nodefield) #endif - end_marker = edgelist%length - global_its = 0 + end_marker = edgelist%length + global_its = 0 - do while (edgelist%length /= 0) + do while (edgelist%length /= 0) - ! Count the number of sweeps through the mesh. - end_marker = end_marker - 1 - if (end_marker == 0) then - global_its = global_its + 1 - end_marker = edgelist%length - end if + ! Count the number of sweeps through the mesh. + end_marker = end_marker - 1 + if (end_marker == 0) then + global_its = global_its + 1 + end_marker = edgelist%length + end if - call wrap_pop(nnlist, edgelist, p, q, count) ! fetch the nodes + call wrap_pop(nnlist, edgelist, p, q, count) ! fetch the nodes #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "----------------------------------------------------" - write(0,*) "stepcount == ", stepcount - write(0,*) "(p, q) == (", p, ", ", q, ")" + write(0,*) "----------------------------------------------------" + write(0,*) "stepcount == ", stepcount + write(0,*) "(p, q) == (", p, ", ", q, ")" #endif - call eigendecomposition_symmetric(node_val(error_metric, p), vec_P, val_P) ! decompose - call eigendecomposition_symmetric(node_val(error_metric, q), vec_Q, val_Q) + call eigendecomposition_symmetric(node_val(error_metric, p), vec_P, val_P) ! decompose + call eigendecomposition_symmetric(node_val(error_metric, q), vec_Q, val_Q) #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - call check_basis(vec_P) - call check_basis(vec_Q) - write(0,*) "Input P:" - call write_matrix(node_val(error_metric, p), "P") - call write_matrix(vec_P, "vec_P") - call write_vector(val_P, "val_P") - write(0,*) "Input Q:" - call write_matrix(node_val(error_metric, q), "Q") - call write_matrix(vec_Q, "vec_Q") - call write_vector(val_Q, "val_Q") + call check_basis(vec_P) + call check_basis(vec_Q) + write(0,*) "Input P:" + call write_matrix(node_val(error_metric, p), "P") + call write_matrix(vec_P, "vec_P") + call write_vector(val_P, "val_P") + write(0,*) "Input Q:" + call write_matrix(node_val(error_metric, q), "Q") + call write_matrix(vec_Q, "vec_Q") + call write_vector(val_Q, "val_Q") #endif - vecs_changed_P = .false. ; vecs_changed_Q = .false. + vecs_changed_P = .false. ; vecs_changed_Q = .false. - boundcount_P = node_boundary_count(p) - boundcount_Q = node_boundary_count(q) + boundcount_P = node_boundary_count(p) + boundcount_Q = node_boundary_count(q) - do_warp_directions = .false. + do_warp_directions = .false. #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "boundcount_P == ", boundcount_P - write(0,*) "boundcount_Q == ", boundcount_Q - write(0,*) "do_warp_directions == ", do_warp_directions + write(0,*) "boundcount_P == ", boundcount_P + write(0,*) "boundcount_Q == ", boundcount_Q + write(0,*) "do_warp_directions == ", do_warp_directions #endif - if (do_warp_directions) then - call warp_directions(vec_P, val_P, vecs_changed_P, vec_Q, val_Q, vecs_changed_Q, distance(positions, p, q)) - end if + if (do_warp_directions) then + call warp_directions(vec_P, val_P, vecs_changed_P, vec_Q, val_Q, vecs_changed_Q, distance(positions, p, q)) + end if #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "P after warping:" - call write_matrix(vec_P, "vec_P") - write(0,*) "Q after warping:" - call write_matrix(vec_Q, "vec_Q") - write(0,*) "vecs_changed_P == ", vecs_changed_P, "vecs_changed_Q == ", vecs_changed_Q - call check_basis(vec_P) - call check_basis(vec_Q) + write(0,*) "P after warping:" + call write_matrix(vec_P, "vec_P") + write(0,*) "Q after warping:" + call write_matrix(vec_Q, "vec_Q") + write(0,*) "vecs_changed_P == ", vecs_changed_P, "vecs_changed_Q == ", vecs_changed_Q + call check_basis(vec_P) + call check_basis(vec_Q) #endif - vals_changed_P = .false. ; vals_changed_Q = .false. - call reduce_edgelen(node_val(error_metric, p), vec_P, val_P, vals_changed_P, & - node_val(error_metric, q), vec_Q, val_Q, vals_changed_Q, & - positions, p, q) + vals_changed_P = .false. ; vals_changed_Q = .false. + call reduce_edgelen(node_val(error_metric, p), vec_P, val_P, vals_changed_P, & + node_val(error_metric, q), vec_Q, val_Q, vals_changed_Q, & + positions, p, q) #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "P after reducing:" - call write_vector(val_P, "val_P") - write(0,*) "Q after reducing:" - call write_vector(val_Q, "val_Q") - write(0,*) "vals_changed_P == ", vals_changed_P, "vals_changed_Q == ", vals_changed_Q + write(0,*) "P after reducing:" + call write_vector(val_P, "val_P") + write(0,*) "Q after reducing:" + call write_vector(val_Q, "val_Q") + write(0,*) "vals_changed_P == ", vals_changed_P, "vals_changed_Q == ", vals_changed_Q #endif - if (vals_changed_P) then - call eigenrecomposition(error_metric%val(:, :, p), vec_P, val_P) - call tag_edges(nnlist, edgelist, p, q, count) - end if - if (vals_changed_Q) then - call eigenrecomposition(error_metric%val(:, :, q), vec_Q, val_Q) - call tag_edges(nnlist, edgelist, q, p, count) - end if - if (count <= max_rot_its) then ! honour directional changes for the first 4 sweeps - if (vecs_changed_P) then - call eigenrecomposition(error_metric%val(:, :, p), vec_P, val_P) - call tag_edges(nnlist, edgelist, p, q, count) - end if - if (vecs_changed_Q) then - call eigenrecomposition(error_metric%val(:, :, q), vec_Q, val_Q) - call tag_edges(nnlist, edgelist, q, p, count) - end if - end if + if (vals_changed_P) then + call eigenrecomposition(error_metric%val(:, :, p), vec_P, val_P) + call tag_edges(nnlist, edgelist, p, q, count) + end if + if (vals_changed_Q) then + call eigenrecomposition(error_metric%val(:, :, q), vec_Q, val_Q) + call tag_edges(nnlist, edgelist, q, p, count) + end if + if (count <= max_rot_its) then ! honour directional changes for the first 4 sweeps + if (vecs_changed_P) then + call eigenrecomposition(error_metric%val(:, :, p), vec_P, val_P) + call tag_edges(nnlist, edgelist, p, q, count) + end if + if (vecs_changed_Q) then + call eigenrecomposition(error_metric%val(:, :, q), vec_Q, val_Q) + call tag_edges(nnlist, edgelist, q, p, count) + end if + end if #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - call check_metric(error_metric) - call get_edge_lengths(error_metric, edgelen) - call vtk_write_fields("data/gradation_debug", stepcount, positions, positions%mesh, & - sfields=(/nodefield, edgelen/), tfields=(/error_metric/)) - stepcount = stepcount + 1 + call check_metric(error_metric) + call get_edge_lengths(error_metric, edgelen) + call vtk_write_fields("data/gradation_debug", stepcount, positions, positions%mesh, & + sfields=(/nodefield, edgelen/), tfields=(/error_metric/)) + stepcount = stepcount + 1 #endif - end do + end do - call deallocate(nnlist) + call deallocate(nnlist) - if (debug_metric) then - call get_edge_lengths(error_metric, edgelen) - call vtk_write_fields(trim("gradation_metric"), adaptcnt, positions, positions%mesh, & - sfields=(/edgelen/), tfields=(/error_metric/)) - call deallocate(edgelen) - adaptcnt = adaptcnt + 1 - endif + if (debug_metric) then + call get_edge_lengths(error_metric, edgelen) + call vtk_write_fields(trim("gradation_metric"), adaptcnt, positions, positions%mesh, & + sfields=(/edgelen/), tfields=(/error_metric/)) + call deallocate(edgelen) + adaptcnt = adaptcnt + 1 + endif #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - call deallocate(nodefield) + call deallocate(nodefield) #endif - ewrite(2,*) "Finished gradation algorithm: global iterations == ", global_its - if (present(noits)) noits = global_its - end subroutine form_gradation_metric - - subroutine wrap_pop(nnlist, edgelist, p, q, count) - !!< Wrap the pop() routine of the linked list. I want - !!< to tag in nnlist that that edge is not in the list anymore. - type(csr_matrix), intent(inout) :: nnlist - type(elist), intent(inout) :: edgelist - integer, intent(out) :: p, q, count - - call spop(edgelist, p, q) - count = ival(nnlist, p, q) - call set(nnlist, p, q, -1 * count) - call set(nnlist, q, p, -1 * count) - end subroutine - - subroutine tag_edges(nnlist, edgelist, p, q, count) - !!< Insert all nodes connected to p into the edge list, - !!< except the one you just checked, - !!< if they're not already there. - type(csr_matrix), intent(inout) :: nnlist - type(elist), intent(inout) :: edgelist - integer, intent(in) :: p, q, count - - integer :: j - integer, dimension(:), pointer :: cola - - cola => row_m_ptr(nnlist, p) - !write(0,*) "Tagging all edges connected to ", p, "that are not", q, "." - - do j=1,row_length(nnlist,p) - if (cola(j) == q) cycle - call add_to_edge_list(nnlist, edgelist, p, cola(j), count) - end do - end subroutine tag_edges - - subroutine construct_edge_list(mesh, nnlist, edgelist) - !! From the node-node adjacency list, construct a linked - !! list of edges. - type(mesh_type), intent(in) :: mesh - type(csr_matrix), intent(inout) :: nnlist - type(elist), intent(out) :: edgelist - - integer :: i,j, rowlen - integer, dimension(:), pointer :: cola - - do i=1,mesh%nodes - rowlen = row_length(nnlist, i) - cola => row_m_ptr(nnlist, i) - do j=1,rowlen - call add_to_edge_list(nnlist, edgelist, i, cola(j), 0) - end do - end do - - end subroutine construct_edge_list - - subroutine add_to_edge_list(nnlist, edgelist, i, j, count) - type(csr_matrix), intent(inout) :: nnlist - type(elist), intent(inout) :: edgelist - integer, intent(in) :: i, j, count - - if (i == j) return - if (ival(nnlist, i, j) < 0) then - call insert(edgelist, i, j) - call set(nnlist, i, j, count + 1) - call set(nnlist, j, i, count + 1) - end if - end subroutine add_to_edge_list - - subroutine compute_omega(vec_P, perm_P, vec_Q, perm_Q, dist, idx, omega, angle) - !!< Compute omega, the maximum angle we deem to be noise between two - !!< nodes separated by dist. - real, dimension(:, :), intent(in) :: vec_P, vec_Q - integer, dimension(size(vec_P, 1)), intent(in) :: perm_P, perm_Q - real, intent(in) :: dist - integer, intent(out) :: idx - real, intent(out) :: omega - real, intent(out) :: angle - - integer :: i, dim - real :: curangle, maxangle - - idx = 0 - maxangle = 0.0 - dim = size(perm_P) - - do i=1,dim - curangle = get_angle(vec_P(:, perm_Q(i)), vec_Q(:, perm_P(i))) - if (curangle > maxangle) then - maxangle = curangle - idx = i + ewrite(2,*) "Finished gradation algorithm: global iterations == ", global_its + if (present(noits)) noits = global_its + end subroutine form_gradation_metric + + subroutine wrap_pop(nnlist, edgelist, p, q, count) + !!< Wrap the pop() routine of the linked list. I want + !!< to tag in nnlist that that edge is not in the list anymore. + type(csr_matrix), intent(inout) :: nnlist + type(elist), intent(inout) :: edgelist + integer, intent(out) :: p, q, count + + call spop(edgelist, p, q) + count = ival(nnlist, p, q) + call set(nnlist, p, q, -1 * count) + call set(nnlist, q, p, -1 * count) + end subroutine + + subroutine tag_edges(nnlist, edgelist, p, q, count) + !!< Insert all nodes connected to p into the edge list, + !!< except the one you just checked, + !!< if they're not already there. + type(csr_matrix), intent(inout) :: nnlist + type(elist), intent(inout) :: edgelist + integer, intent(in) :: p, q, count + + integer :: j + integer, dimension(:), pointer :: cola + + cola => row_m_ptr(nnlist, p) + !write(0,*) "Tagging all edges connected to ", p, "that are not", q, "." + + do j=1,row_length(nnlist,p) + if (cola(j) == q) cycle + call add_to_edge_list(nnlist, edgelist, p, cola(j), count) + end do + end subroutine tag_edges + + subroutine construct_edge_list(mesh, nnlist, edgelist) + !! From the node-node adjacency list, construct a linked + !! list of edges. + type(mesh_type), intent(in) :: mesh + type(csr_matrix), intent(inout) :: nnlist + type(elist), intent(out) :: edgelist + + integer :: i,j, rowlen + integer, dimension(:), pointer :: cola + + do i=1,mesh%nodes + rowlen = row_length(nnlist, i) + cola => row_m_ptr(nnlist, i) + do j=1,rowlen + call add_to_edge_list(nnlist, edgelist, i, cola(j), 0) + end do + end do + + end subroutine construct_edge_list + + subroutine add_to_edge_list(nnlist, edgelist, i, j, count) + type(csr_matrix), intent(inout) :: nnlist + type(elist), intent(inout) :: edgelist + integer, intent(in) :: i, j, count + + if (i == j) return + if (ival(nnlist, i, j) < 0) then + call insert(edgelist, i, j) + call set(nnlist, i, j, count + 1) + call set(nnlist, j, i, count + 1) end if - end do + end subroutine add_to_edge_list + + subroutine compute_omega(vec_P, perm_P, vec_Q, perm_Q, dist, idx, omega, angle) + !!< Compute omega, the maximum angle we deem to be noise between two + !!< nodes separated by dist. + real, dimension(:, :), intent(in) :: vec_P, vec_Q + integer, dimension(size(vec_P, 1)), intent(in) :: perm_P, perm_Q + real, intent(in) :: dist + integer, intent(out) :: idx + real, intent(out) :: omega + real, intent(out) :: angle - angle = maxangle + integer :: i, dim + real :: curangle, maxangle - omega = theta0 + (theta1 - theta0) * dist / domain_scale - if (omega < 0.0) omega = 0.0 - end subroutine compute_omega + idx = 0 + maxangle = 0.0 + dim = size(perm_P) - subroutine warp_directions(vec_P, val_P, changed_P, vec_Q, val_Q, changed_Q, dist) - !!< Given two metric tensors, - !!< modify the directions of their eigenvectors to be more aligned, - !!< while respecting anisotropism. + do i=1,dim + curangle = get_angle(vec_P(:, perm_Q(i)), vec_Q(:, perm_P(i))) + if (curangle > maxangle) then + maxangle = curangle + idx = i + end if + end do - real, dimension(:, :), intent(inout) :: vec_P, vec_Q - real, dimension(size(vec_P, 1)), intent(in) :: val_P, val_Q - logical, intent(inout) :: changed_P, changed_Q - real, intent(in) :: dist + angle = maxangle - integer, dimension(size(vec_P, 1)), target :: perm_P, perm_Q ! contains the permutation matching up vectors - ! which old ones correspond to the new ones - real :: omega, angle, angle_P, angle_Q - integer :: dim, idx, i + omega = theta0 + (theta1 - theta0) * dist / domain_scale + if (omega < 0.0) omega = 0.0 + end subroutine compute_omega - dim = size(vec_P, 1) + subroutine warp_directions(vec_P, val_P, changed_P, vec_Q, val_Q, changed_Q, dist) + !!< Given two metric tensors, + !!< modify the directions of their eigenvectors to be more aligned, + !!< while respecting anisotropism. - !write(0,*) "Starting warp_directions" + real, dimension(:, :), intent(inout) :: vec_P, vec_Q + real, dimension(size(vec_P, 1)), intent(in) :: val_P, val_Q + logical, intent(inout) :: changed_P, changed_Q + real, intent(in) :: dist - if (metric_isotropic(val_P) .and. metric_isotropic(val_Q)) then - if (val_P(1) >= val_Q(1)) then - vec_Q = vec_P - else - vec_P = vec_Q + integer, dimension(size(vec_P, 1)), target :: perm_P, perm_Q ! contains the permutation matching up vectors + ! which old ones correspond to the new ones + real :: omega, angle, angle_P, angle_Q + integer :: dim, idx, i + + dim = size(vec_P, 1) + + !write(0,*) "Starting warp_directions" + + if (metric_isotropic(val_P) .and. metric_isotropic(val_Q)) then + if (val_P(1) >= val_Q(1)) then + vec_Q = vec_P + else + vec_P = vec_Q + end if + return end if - return - end if - if (metric_isotropic(val_P)) then - vec_P = vec_Q - return - end if + if (metric_isotropic(val_P)) then + vec_P = vec_Q + return + end if - if (metric_isotropic(val_Q)) then - vec_Q = vec_P - return - end if + if (metric_isotropic(val_Q)) then + vec_Q = vec_P + return + end if - if (vec_P .feq. vec_Q) return + if (vec_P .feq. vec_Q) return - do i=1,dim - call match_up_ellipsoids(vec_P, val_P, perm_P, vec_Q, val_Q, perm_Q) - call compute_omega(vec_P, perm_P, vec_Q, perm_Q, dist, idx, omega, angle) + do i=1,dim + call match_up_ellipsoids(vec_P, val_P, perm_P, vec_Q, val_Q, perm_Q) + call compute_omega(vec_P, perm_P, vec_Q, perm_Q, dist, idx, omega, angle) #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - call write_matrix(vec_P, "vec_P") - call write_matrix(vec_Q, "vec_Q") - write(0,*) "perm_P == ", perm_P - write(0,*) "perm_Q == ", perm_Q - write(0,*) "omega == ", omega - write(0,*) "angle == ", angle - write(0,*) "dist == ", dist + call write_matrix(vec_P, "vec_P") + call write_matrix(vec_Q, "vec_Q") + write(0,*) "perm_P == ", perm_P + write(0,*) "perm_Q == ", perm_Q + write(0,*) "omega == ", omega + write(0,*) "angle == ", angle + write(0,*) "dist == ", dist #endif - if (angle < omega) then - if (angle < 0.01) cycle - angle_P = (aspect_ratio(val_Q) / (aspect_ratio(val_Q) + aspect_ratio(val_P))) * angle - angle_Q = (aspect_ratio(val_P) / (aspect_ratio(val_Q) + aspect_ratio(val_P))) * angle - call rotate_vec(vec_P, perm_P, vec_Q, perm_Q, idx, angle_P) - call rotate_vec(vec_Q, perm_Q, vec_P, perm_P, idx, angle_Q) - changed_P = .true. ; changed_Q = .true. - end if - end do - end subroutine warp_directions - - subroutine rotate_vec(vec_A, perm_A, vec_B, perm_B, idx, angle) - real, dimension(:, :), intent(inout) :: vec_A, vec_B - integer, dimension(size(vec_A, 1)), intent(in) :: perm_A, perm_B - real, intent(in) :: angle - integer, intent(in) :: idx - real, dimension(size(vec_A, 1), size(vec_A, 1)) :: mat - real, dimension(size(vec_A, 1)) :: cross, tmpvec - integer :: dim - real :: angle_2d, in_angle, cur_angle - - dim = size(vec_A, 1) - - if (dim == 2) then - angle_2d = get_angle_2d(vec_A(:, perm_B(idx)), vec_B(:, perm_A(idx))) - if (angle_2d < 0.0) then - angle_2d = -1 * angle - else - angle_2d = angle - end if - mat(1, 1) = cos(angle_2d) ; mat(1, 2) = -sin(angle_2d) - mat(2, 1) = sin(angle_2d) ; mat(2, 2) = cos(angle_2d) - vec_A = matmul(mat, vec_A) - else if (dim == 3) then - in_angle = get_angle(vec_A(:, perm_B(idx)), vec_B(:, perm_A(idx))) - cross = cross_product(vec_A(:, perm_B(idx)), vec_B(:, perm_A(idx))) ; cross = cross / norm(cross) - mat = get_rotation_matrix_cross(cross, angle) - tmpvec = matmul(mat, vec_A(:, perm_B(idx))) - cur_angle = get_angle(tmpvec, vec_B(:, perm_A(idx))) - if (cur_angle > in_angle) then ! got it the wrong way round - mat = get_rotation_matrix_cross(-1 * cross, angle) + if (angle < omega) then + if (angle < 0.01) cycle + angle_P = (aspect_ratio(val_Q) / (aspect_ratio(val_Q) + aspect_ratio(val_P))) * angle + angle_Q = (aspect_ratio(val_P) / (aspect_ratio(val_Q) + aspect_ratio(val_P))) * angle + call rotate_vec(vec_P, perm_P, vec_Q, perm_Q, idx, angle_P) + call rotate_vec(vec_Q, perm_Q, vec_P, perm_P, idx, angle_Q) + changed_P = .true. ; changed_Q = .true. + end if + end do + end subroutine warp_directions + + subroutine rotate_vec(vec_A, perm_A, vec_B, perm_B, idx, angle) + real, dimension(:, :), intent(inout) :: vec_A, vec_B + integer, dimension(size(vec_A, 1)), intent(in) :: perm_A, perm_B + real, intent(in) :: angle + integer, intent(in) :: idx + real, dimension(size(vec_A, 1), size(vec_A, 1)) :: mat + real, dimension(size(vec_A, 1)) :: cross, tmpvec + integer :: dim + real :: angle_2d, in_angle, cur_angle + + dim = size(vec_A, 1) + + if (dim == 2) then + angle_2d = get_angle_2d(vec_A(:, perm_B(idx)), vec_B(:, perm_A(idx))) + if (angle_2d < 0.0) then + angle_2d = -1 * angle + else + angle_2d = angle + end if + mat(1, 1) = cos(angle_2d) ; mat(1, 2) = -sin(angle_2d) + mat(2, 1) = sin(angle_2d) ; mat(2, 2) = cos(angle_2d) + vec_A = matmul(mat, vec_A) + else if (dim == 3) then + in_angle = get_angle(vec_A(:, perm_B(idx)), vec_B(:, perm_A(idx))) + cross = cross_product(vec_A(:, perm_B(idx)), vec_B(:, perm_A(idx))) ; cross = cross / norm(cross) + mat = get_rotation_matrix_cross(cross, angle) + tmpvec = matmul(mat, vec_A(:, perm_B(idx))) + cur_angle = get_angle(tmpvec, vec_B(:, perm_A(idx))) + if (cur_angle > in_angle) then ! got it the wrong way round + mat = get_rotation_matrix_cross(-1 * cross, angle) + end if + vec_A = matmul(mat, vec_A) end if - vec_A = matmul(mat, vec_A) - end if - end subroutine rotate_vec + end subroutine rotate_vec - subroutine match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) - !!< We match up vectors by matching up each angle in turn. - real, dimension(:, :), intent(in) :: vec_P, vec_Q - integer, dimension(:), intent(out) :: permutation_P, permutation_Q + subroutine match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) + !!< We match up vectors by matching up each angle in turn. + real, dimension(:, :), intent(in) :: vec_P, vec_Q + integer, dimension(:), intent(out) :: permutation_P, permutation_Q - integer, dimension(2) :: idx - real, dimension(size(vec_P, 2), (size(vec_Q, 2))) :: angle_matrix + integer, dimension(2) :: idx + real, dimension(size(vec_P, 2), (size(vec_Q, 2))) :: angle_matrix - integer :: i, j, k, count_P, count_Q, dim, stat + integer :: i, j, k, count_P, count_Q, dim, stat - dim = size(vec_P, 1) - count_P = size(vec_P, 2) - count_Q = size(vec_Q, 2) + dim = size(vec_P, 1) + count_P = size(vec_P, 2) + count_Q = size(vec_Q, 2) - permutation_P = 0 - permutation_Q = 0 + permutation_P = 0 + permutation_Q = 0 - ! construct a record of the angles between each of the eigenvectors. + ! construct a record of the angles between each of the eigenvectors. - do i=1,count_P - do j=1,count_Q - angle_matrix(i, j) = get_angle(vec_P(:, i), vec_Q(:, j)) + do i=1,count_P + do j=1,count_Q + angle_matrix(i, j) = get_angle(vec_P(:, i), vec_Q(:, j)) + end do end do - end do - - ! now loop over and find the closest pair. - - do k=1,count_P - idx = minloc(angle_matrix); i = idx(1); j = idx(2) - angle_matrix(i, :) = huge(0.0); angle_matrix(:, j) = huge(0.0) - permutation_P(k) = j; permutation_Q(k) = i - end do - - stat = 0 - if (size(permutation_P) == dim .and. size(permutation_Q) == dim) then - call check_perm(permutation_P, stat) - call check_perm(permutation_Q, stat) - end if - - if (stat /= 0) then - call write_matrix(vec_P, "vec_P") - call write_matrix(vec_Q, "vec_Q") - call write_vector(permutation_P, "perm_P") - call write_vector(permutation_Q, "perm_Q") - FLAbort("Permutation not correct!") - end if - end subroutine match_up_vectors - - subroutine match_up_ellipsoids(vec_P, val_P, perm_P, vec_Q, val_Q, perm_Q) - !!< Match up the index of the biggest eigenvalue with the biggest eigenvalue, - !!< the next biggest with the next biggest, etc. - real, dimension(:, :), intent(in) :: vec_P, vec_Q - real, dimension(:), intent(in) :: val_P, val_Q - integer, dimension(size(val_P)), intent(out) :: perm_P, perm_Q - real, dimension(size(val_P)) :: lval_P, lval_Q - real, dimension(size(val_P), size(val_P) - 1) :: equatorial_basis_P, equatorial_basis_Q - integer, dimension(size(val_P) - 1) :: eq_perm_P, eq_perm_Q - integer :: i, dim, biggest_loc(1), j - integer :: stat - - dim = size(val_P) - - if (metric_spheroid(val_P) .and. metric_spheroid(val_Q)) then - perm_Q(1) = get_polar_index(val_P) - perm_P(1) = get_polar_index(val_Q) - - j = 1 - do i=1,dim - if (i /= perm_Q(1)) then - equatorial_basis_P(:, j) = vec_P(:, i) - eq_perm_P(j) = i - j = j + 1 - end if + + ! now loop over and find the closest pair. + + do k=1,count_P + idx = minloc(angle_matrix); i = idx(1); j = idx(2) + angle_matrix(i, :) = huge(0.0); angle_matrix(:, j) = huge(0.0) + permutation_P(k) = j; permutation_Q(k) = i end do - j = 1 + stat = 0 + if (size(permutation_P) == dim .and. size(permutation_Q) == dim) then + call check_perm(permutation_P, stat) + call check_perm(permutation_Q, stat) + end if + + if (stat /= 0) then + call write_matrix(vec_P, "vec_P") + call write_matrix(vec_Q, "vec_Q") + call write_vector(permutation_P, "perm_P") + call write_vector(permutation_Q, "perm_Q") + FLAbort("Permutation not correct!") + end if + end subroutine match_up_vectors + + subroutine match_up_ellipsoids(vec_P, val_P, perm_P, vec_Q, val_Q, perm_Q) + !!< Match up the index of the biggest eigenvalue with the biggest eigenvalue, + !!< the next biggest with the next biggest, etc. + real, dimension(:, :), intent(in) :: vec_P, vec_Q + real, dimension(:), intent(in) :: val_P, val_Q + integer, dimension(size(val_P)), intent(out) :: perm_P, perm_Q + real, dimension(size(val_P)) :: lval_P, lval_Q + real, dimension(size(val_P), size(val_P) - 1) :: equatorial_basis_P, equatorial_basis_Q + integer, dimension(size(val_P) - 1) :: eq_perm_P, eq_perm_Q + integer :: i, dim, biggest_loc(1), j + integer :: stat + + dim = size(val_P) + + if (metric_spheroid(val_P) .and. metric_spheroid(val_Q)) then + perm_Q(1) = get_polar_index(val_P) + perm_P(1) = get_polar_index(val_Q) + + j = 1 + do i=1,dim + if (i /= perm_Q(1)) then + equatorial_basis_P(:, j) = vec_P(:, i) + eq_perm_P(j) = i + j = j + 1 + end if + end do + + j = 1 + do i=1,dim + if (i /= perm_P(1)) then + equatorial_basis_Q(:, j) = vec_Q(:, i) + eq_perm_Q(j) = i + j = j + 1 + end if + end do + + call match_up_vectors(equatorial_basis_P, perm_P(2:), equatorial_basis_Q, perm_Q(2:)) + + do i=1,dim-1 + perm_P(i+1) = eq_perm_Q(perm_P(i+1)) + perm_Q(i+1) = eq_perm_P(perm_Q(i+1)) + end do + + return + end if + + lval_P = val_P; lval_Q = val_Q + do i=1,dim - if (i /= perm_P(1)) then - equatorial_basis_Q(:, j) = vec_Q(:, i) - eq_perm_Q(j) = i - j = j + 1 - end if + biggest_loc = maxloc(lval_P) + perm_Q(i) = biggest_loc(1) + lval_P(biggest_loc(1)) = 0.0 + + biggest_loc = maxloc(lval_Q) + perm_P(i) = biggest_loc(1) + lval_Q(biggest_loc(1)) = 0.0 end do - call match_up_vectors(equatorial_basis_P, perm_P(2:), equatorial_basis_Q, perm_Q(2:)) + stat = 0 + call check_perm(perm_P, stat) + call check_perm(perm_Q, stat) + if (stat /= 0) then + call write_vector(val_P, "val_P") + call write_vector(val_Q, "val_Q") + call write_matrix(vec_P, "vec_P") + call write_matrix(vec_Q, "vec_Q") + call write_vector(perm_P, "perm_P") + call write_vector(perm_Q, "perm_Q") + FLAbort("Permutation not correct!") + end if + end subroutine match_up_ellipsoids + + subroutine reduce_edgelen(mat_P, vec_P, val_P, changed_P, mat_Q, vec_Q, val_Q, changed_Q, positions, p, q) + !!< Reduce the edge lengths to smoothen the mesh, according to section + !!< 3.3 of the referenced paper (with modifications). + real, dimension(:, :), intent(in) :: mat_P, mat_Q + real, dimension(size(mat_P, 1), size(mat_P, 1)), intent(in) :: vec_P, vec_Q + real, dimension(size(mat_P, 1)), intent(inout) :: val_P, val_Q + logical, intent(inout) :: changed_P, changed_Q + type(vector_field), intent(in) :: positions + integer, intent(in) :: p, q + + real, dimension(size(mat_Q, 1)) :: edgelen_P, edgelen_Q + integer, dimension(size(mat_Q, 1)) :: perm_P, perm_Q + integer :: i, dim + real :: gamma, dist, tmp + + dim = size(mat_P, 1) - do i=1,dim-1 - perm_P(i+1) = eq_perm_Q(perm_P(i+1)) - perm_Q(i+1) = eq_perm_P(perm_Q(i+1)) + do i=1,dim + edgelen_P(i) = edge_length_from_eigenvalue(val_P(i)) + edgelen_Q(i) = edge_length_from_eigenvalue(val_Q(i)) end do - return - end if - - lval_P = val_P; lval_Q = val_Q - - do i=1,dim - biggest_loc = maxloc(lval_P) - perm_Q(i) = biggest_loc(1) - lval_P(biggest_loc(1)) = 0.0 - - biggest_loc = maxloc(lval_Q) - perm_P(i) = biggest_loc(1) - lval_Q(biggest_loc(1)) = 0.0 - end do - - stat = 0 - call check_perm(perm_P, stat) - call check_perm(perm_Q, stat) - if (stat /= 0) then - call write_vector(val_P, "val_P") - call write_vector(val_Q, "val_Q") - call write_matrix(vec_P, "vec_P") - call write_matrix(vec_Q, "vec_Q") - call write_vector(perm_P, "perm_P") - call write_vector(perm_Q, "perm_Q") - FLAbort("Permutation not correct!") - end if - end subroutine match_up_ellipsoids - - subroutine reduce_edgelen(mat_P, vec_P, val_P, changed_P, mat_Q, vec_Q, val_Q, changed_Q, positions, p, q) - !!< Reduce the edge lengths to smoothen the mesh, according to section - !!< 3.3 of the referenced paper (with modifications). - real, dimension(:, :), intent(in) :: mat_P, mat_Q - real, dimension(size(mat_P, 1), size(mat_P, 1)), intent(in) :: vec_P, vec_Q - real, dimension(size(mat_P, 1)), intent(inout) :: val_P, val_Q - logical, intent(inout) :: changed_P, changed_Q - type(vector_field), intent(in) :: positions - integer, intent(in) :: p, q - - real, dimension(size(mat_Q, 1)) :: edgelen_P, edgelen_Q - integer, dimension(size(mat_Q, 1)) :: perm_P, perm_Q - integer :: i, dim - real :: gamma, dist, tmp - - dim = size(mat_P, 1) - - do i=1,dim - edgelen_P(i) = edge_length_from_eigenvalue(val_P(i)) - edgelen_Q(i) = edge_length_from_eigenvalue(val_Q(i)) - end do - - call match_up_vectors(vec_P, perm_P, vec_Q, perm_Q) - dist = distance(positions, p, q) + call match_up_vectors(vec_P, perm_P, vec_Q, perm_Q) + dist = distance(positions, p, q) #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "perm_P == ", perm_P - write(0,*) "perm_Q == ", perm_Q - call write_vector(edgelen_P, "edgelen_P") - call write_vector(edgelen_Q, "edgelen_Q") + write(0,*) "perm_P == ", perm_P + write(0,*) "perm_Q == ", perm_Q + call write_vector(edgelen_P, "edgelen_P") + call write_vector(edgelen_Q, "edgelen_Q") #endif - do i=1,dim - gamma = get_gamma(edgelen_P(perm_Q(i)), vec_P(:, perm_Q(i)), edgelen_Q(perm_P(i)), vec_Q(:, perm_P(i)), dist) + do i=1,dim + gamma = get_gamma(edgelen_P(perm_Q(i)), vec_P(:, perm_Q(i)), edgelen_Q(perm_P(i)), vec_Q(:, perm_P(i)), dist) #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "gamma == ", gamma, "; gamma0 == ", gamma0 - call write_vector(edgelen_P, "edgelen_P") - call write_vector(edgelen_Q, "edgelen_Q") + write(0,*) "gamma == ", gamma, "; gamma0 == ", gamma0 + call write_vector(edgelen_P, "edgelen_P") + call write_vector(edgelen_Q, "edgelen_Q") #endif - if (gamma .fgt. gamma0) then - if (edgelen_P(perm_Q(i)) > edgelen_Q(perm_P(i))) then + if (gamma .fgt. gamma0) then + if (edgelen_P(perm_Q(i)) > edgelen_Q(perm_P(i))) then #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "reducing edge length ", perm_Q(i), " of P." - write(0,*) "old value == ", edgelen_P(perm_Q(i)) + write(0,*) "reducing edge length ", perm_Q(i), " of P." + write(0,*) "old value == ", edgelen_P(perm_Q(i)) #endif - tmp = edgelen_P(perm_Q(i)) - edgelen_P(perm_Q(i)) = dist * log(gamma0) + edgelen_Q(perm_P(i)) - if (tmp .fne. edgelen_P(perm_Q(i))) changed_P = .true. + tmp = edgelen_P(perm_Q(i)) + edgelen_P(perm_Q(i)) = dist * log(gamma0) + edgelen_Q(perm_P(i)) + if (tmp .fne. edgelen_P(perm_Q(i))) changed_P = .true. #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "new value == ", edgelen_P(perm_Q(i)) + write(0,*) "new value == ", edgelen_P(perm_Q(i)) #endif - else + else #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "reducing edge length ", perm_P(i), " of Q." - write(0,*) "old value == ", edgelen_Q(perm_P(i)) + write(0,*) "reducing edge length ", perm_P(i), " of Q." + write(0,*) "old value == ", edgelen_Q(perm_P(i)) #endif - tmp = edgelen_Q(perm_P(i)) - edgelen_Q(perm_P(i)) = distance(positions, p, q) * log(gamma0) + edgelen_P(perm_Q(i)) - if (tmp .fne. edgelen_Q(perm_P(i))) changed_Q = .true. + tmp = edgelen_Q(perm_P(i)) + edgelen_Q(perm_P(i)) = distance(positions, p, q) * log(gamma0) + edgelen_P(perm_Q(i)) + if (tmp .fne. edgelen_Q(perm_P(i))) changed_Q = .true. #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - write(0,*) "new value == ", edgelen_Q(perm_P(i)) + write(0,*) "new value == ", edgelen_Q(perm_P(i)) #endif - end if - end if - end do + end if + end if + end do - do i=1,dim - val_P(i) = eigenvalue_from_edge_length(edgelen_P(i)) - val_Q(i) = eigenvalue_from_edge_length(edgelen_Q(i)) - end do + do i=1,dim + val_P(i) = eigenvalue_from_edge_length(edgelen_P(i)) + val_Q(i) = eigenvalue_from_edge_length(edgelen_Q(i)) + end do #ifdef EXTRA_SPECIAL_GRADATION_DEBUGGING - call write_vector(val_P, "P output eigenvalues") - call write_vector(val_Q, "Q output eigenvalues") + call write_vector(val_P, "P output eigenvalues") + call write_vector(val_Q, "Q output eigenvalues") #endif - end subroutine reduce_edgelen - - function get_gamma(h_P, v_P, h_Q, v_Q, dist) result(gamma) - !!< Gamma is the mesh size gradation measure, - !!< a measure of how quickly the desired edge length changes - !!< when going from node p to node q. - !!< See section 2 of the referenced paper. - real, intent(in) :: h_P, h_Q, dist - real, dimension(:), intent(in) :: v_P, v_Q - real :: gamma - - gamma = exp(abs(h_P - h_Q) / dist) - !gamma = gamma + (1 - gamma) * (1 - dot_product(v_P, v_Q)) - end function get_gamma + end subroutine reduce_edgelen + + function get_gamma(h_P, v_P, h_Q, v_Q, dist) result(gamma) + !!< Gamma is the mesh size gradation measure, + !!< a measure of how quickly the desired edge length changes + !!< when going from node p to node q. + !!< See section 2 of the referenced paper. + real, intent(in) :: h_P, h_Q, dist + real, dimension(:), intent(in) :: v_P, v_Q + real :: gamma + + gamma = exp(abs(h_P - h_Q) / dist) + !gamma = gamma + (1 - gamma) * (1 - dot_product(v_P, v_Q)) + end function get_gamma end module gradation_metric diff --git a/error_measures/Huang_metric.F90 b/error_measures/Huang_metric.F90 index 583bb8aea1..719c048442 100644 --- a/error_measures/Huang_metric.F90 +++ b/error_measures/Huang_metric.F90 @@ -3,185 +3,185 @@ module huang_metric_module ! 10.1016/j.jcp.2004.10.024 - use fldebug - use vector_tools - use global_parameters, only: domain_volume, OPTION_PATH_LEN - use spud - use unittest_tools, only: is_nan - use metric_tools - use transform_elements - use fields - use state_module - use vtk_interfaces - use field_options - use form_metric_field - - implicit none - - type(tensor_field), save :: m_hessian - type(vector_field), pointer :: m_coordinate - real :: m_gamma, m_sigma - - private - public :: form_huang_metric - - contains - - subroutine form_huang_metric(hessian, field, coordinate, weight) - type(tensor_field), intent(inout) :: hessian - type(scalar_field), intent(in) :: field - type(vector_field), intent(in), target :: coordinate - real, intent(in) :: weight - - integer :: n, m, l, p, q - integer, dimension(2) :: tmp - real :: gamma, sigma, alpha, eps, power_A, power_B, power_C - integer :: node - real, dimension(hessian%dim(1), hessian%dim(2)) :: identity, abs_h, metric - character(len=OPTION_PATH_LEN) :: path - - assert(field%mesh%shape%degree == 1) ! this can be generalised, but currently I don't have the time - - m_coordinate => coordinate - - n = mesh_dim(field) - l = field%mesh%shape%degree + 1 - p = 1 - - path = trim(complete_field_path(trim(field%option_path))) // "/adaptivity_options/huang_metric" - call get_option(trim(path) // "/seminorm", tmp) - m = tmp(1) - q = tmp(2) - - eps = weight - gamma = (real(n) / q) + (2 - m) - power_A = 1 + real((n * (p - 1)))/(p * gamma) + max(0.0, real(n)/(p*gamma) - 1) - assert(domain_volume > 0) - sigma = (2 ** power_A) * domain_volume - m_sigma = sigma - - identity = get_matrix_identity(n) - power_B = (1.0/n) * ((2.0/gamma) - 1) - power_C = real(n) / (l - m) - - do node=1,node_count(hessian) - abs_h = absolutify(node_val(hessian, node)) - call set(hessian, node, abs_h) - end do + use fldebug + use vector_tools + use global_parameters, only: domain_volume, OPTION_PATH_LEN + use spud + use unittest_tools, only: is_nan + use metric_tools + use transform_elements + use fields + use state_module + use vtk_interfaces + use field_options + use form_metric_field + + implicit none + + type(tensor_field), save :: m_hessian + type(vector_field), pointer :: m_coordinate + real :: m_gamma, m_sigma + + private + public :: form_huang_metric + +contains + + subroutine form_huang_metric(hessian, field, coordinate, weight) + type(tensor_field), intent(inout) :: hessian + type(scalar_field), intent(in) :: field + type(vector_field), intent(in), target :: coordinate + real, intent(in) :: weight + + integer :: n, m, l, p, q + integer, dimension(2) :: tmp + real :: gamma, sigma, alpha, eps, power_A, power_B, power_C + integer :: node + real, dimension(hessian%dim(1), hessian%dim(2)) :: identity, abs_h, metric + character(len=OPTION_PATH_LEN) :: path + + assert(field%mesh%shape%degree == 1) ! this can be generalised, but currently I don't have the time + + m_coordinate => coordinate + + n = mesh_dim(field) + l = field%mesh%shape%degree + 1 + p = 1 + + path = trim(complete_field_path(trim(field%option_path))) // "/adaptivity_options/huang_metric" + call get_option(trim(path) // "/seminorm", tmp) + m = tmp(1) + q = tmp(2) + + eps = weight + gamma = (real(n) / q) + (2 - m) + power_A = 1 + real((n * (p - 1)))/(p * gamma) + max(0.0, real(n)/(p*gamma) - 1) + assert(domain_volume > 0) + sigma = (2 ** power_A) * domain_volume + m_sigma = sigma + + identity = get_matrix_identity(n) + power_B = (1.0/n) * ((2.0/gamma) - 1) + power_C = real(n) / (l - m) + + do node=1,node_count(hessian) + abs_h = absolutify(node_val(hessian, node)) + call set(hessian, node, abs_h) + end do - m_hessian = hessian - m_gamma = gamma + m_hessian = hessian + m_gamma = gamma - alpha = find_root(beta, 0.05, 2.5, 1.0e-6) + alpha = find_root(beta, 0.05, 2.5, 1.0e-6) - do node=1,node_count(hessian) - abs_h = node_val(hessian, node) + do node=1,node_count(hessian) + abs_h = node_val(hessian, node) - metric = ((1.0/sigma) * ((alpha / eps)**power_C))**(2.0/n) * & - (det(identity + (1.0/alpha) * abs_h) ** power_B) * & - (identity + (1.0/alpha) * abs_h) * 4 + metric = ((1.0/sigma) * ((alpha / eps)**power_C))**(2.0/n) * & + (det(identity + (1.0/alpha) * abs_h) ** power_B) * & + (identity + (1.0/alpha) * abs_h) * 4 - call set(hessian, node, metric) - end do + call set(hessian, node, metric) + end do - contains + contains function find_root(func, x0, x1, eps) result(root) - real, intent(in) :: x0, x1, eps - real :: root - interface - function func(alpha) result(output) - real, intent(in) :: alpha - real :: output - end function func - end interface - - real :: fnminus, fn, fnplus - real :: xnminus, xn, xnplus - - xnminus = x0 - xn = x1 - fnminus = func(x0) - fn = func(x1) - - if (abs(fnminus) < eps) then - root = xnminus - return - end if - if (abs(fn) < eps) then - root = xn - return - end if - - if (fnminus * fn < 0) then - do while(.true.) - xnplus = (fn*xnminus - fnminus*xn) / (fn - fnminus) - fnplus = func(xnplus) - if (abs(fnplus) < eps) then - root = xnplus - return - end if - - if (sign(1.0, fnplus) == sign(1.0, fnminus)) then - fnminus = fnplus - xnminus = xnplus - else - fn = fnplus - xn = xnplus - end if - end do - else - do while(.true.) - xnplus = xn - ( (xn - xnminus) / (fn - fnminus) ) * fn - assert(.not. is_nan(xnplus)) - fnplus = func(xnplus) - if (abs(fnplus) < eps) then - root = xnplus - return - end if - - xnminus = xn; fnminus = fn - xn = xnplus; fn = fnplus - end do - end if + real, intent(in) :: x0, x1, eps + real :: root + interface + function func(alpha) result(output) + real, intent(in) :: alpha + real :: output + end function func + end interface + + real :: fnminus, fn, fnplus + real :: xnminus, xn, xnplus + + xnminus = x0 + xn = x1 + fnminus = func(x0) + fn = func(x1) + + if (abs(fnminus) < eps) then + root = xnminus + return + end if + if (abs(fn) < eps) then + root = xn + return + end if + + if (fnminus * fn < 0) then + do while(.true.) + xnplus = (fn*xnminus - fnminus*xn) / (fn - fnminus) + fnplus = func(xnplus) + if (abs(fnplus) < eps) then + root = xnplus + return + end if + + if (sign(1.0, fnplus) == sign(1.0, fnminus)) then + fnminus = fnplus + xnminus = xnplus + else + fn = fnplus + xn = xnplus + end if + end do + else + do while(.true.) + xnplus = xn - ( (xn - xnminus) / (fn - fnminus) ) * fn + assert(.not. is_nan(xnplus)) + fnplus = func(xnplus) + if (abs(fnplus) < eps) then + root = xnplus + return + end if + + xnminus = xn; fnminus = fn + xn = xnplus; fn = fnplus + end do + end if end function find_root function absolutify(hessian) result(abs_h) - real, dimension(:, :), intent(in) :: hessian - real, dimension(size(hessian, 1), size(hessian, 2)) :: abs_h, evecs - real, dimension(size(hessian, 1)) :: evals + real, dimension(:, :), intent(in) :: hessian + real, dimension(size(hessian, 1), size(hessian, 2)) :: abs_h, evecs + real, dimension(size(hessian, 1)) :: evals - call eigendecomposition_symmetric(hessian, evecs, evals) - evals = abs(evals) - call eigenrecomposition(abs_h, evecs, evals) + call eigendecomposition_symmetric(hessian, evecs, evals) + evals = abs(evals) + call eigenrecomposition(abs_h, evecs, evals) end function absolutify - end subroutine form_huang_metric - - function beta(alpha) result(p) - real, intent(in) :: alpha - real :: p - real, dimension(ele_ngi(m_hessian, 1)) :: detwei, integrand_s - real, dimension(m_hessian%dim(1), m_hessian%dim(2), ele_ngi(m_hessian, 1)) :: integrand_t, id - integer :: j, ele - - do j=1,ele_ngi(m_hessian, 1) - id(:, :, j) = get_matrix_identity(m_hessian%dim(1)) - end do - - p = 0 - do ele=1,ele_count(m_hessian) - integrand_t = (ele_val_at_quad(m_hessian, ele) / alpha) + id + end subroutine form_huang_metric + + function beta(alpha) result(p) + real, intent(in) :: alpha + real :: p + real, dimension(ele_ngi(m_hessian, 1)) :: detwei, integrand_s + real, dimension(m_hessian%dim(1), m_hessian%dim(2), ele_ngi(m_hessian, 1)) :: integrand_t, id + integer :: j, ele + do j=1,ele_ngi(m_hessian, 1) - integrand_s(j) = det(integrand_t(:, :, j)) ** (1.0/m_gamma) + id(:, :, j) = get_matrix_identity(m_hessian%dim(1)) end do - call transform_to_physical(m_coordinate, ele, detwei=detwei) - p = p + dot_product(integrand_s, detwei) - end do + p = 0 + do ele=1,ele_count(m_hessian) + integrand_t = (ele_val_at_quad(m_hessian, ele) / alpha) + id + do j=1,ele_ngi(m_hessian, 1) + integrand_s(j) = det(integrand_t(:, :, j)) ** (1.0/m_gamma) + end do + + call transform_to_physical(m_coordinate, ele, detwei=detwei) + p = p + dot_product(integrand_s, detwei) + end do - write(0,*) "alpha: ", alpha, "; \int rho: ", p, "; sigma: ", m_sigma, "; output: ", p - m_sigma - p = p - m_sigma + write(0,*) "alpha: ", alpha, "; \int rho: ", p, "; sigma: ", m_sigma, "; output: ", p - m_sigma + p = p - m_sigma - end function beta + end function beta end module huang_metric_module diff --git a/error_measures/Interpolation_error.F90 b/error_measures/Interpolation_error.F90 index 4950d1a401..0b38ba7dbf 100644 --- a/error_measures/Interpolation_error.F90 +++ b/error_measures/Interpolation_error.F90 @@ -2,128 +2,128 @@ module interpolation_error - use elements - use transform_elements, only: transform_to_physical - use fields - use vtk_interfaces, only: vtk_write_fields - implicit none - - private - - public :: compute_interpolation_error_l2, compute_interpolation_error_inf,& - compute_interpolation_error_h1 - - contains - - function compute_interpolation_error_l2(solution, field, positions) result(l2) - !!< Compute the l2-norm of the error between the function solution - !!< and its interpolant field. - interface - function solution(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function solution - end interface - type(scalar_field), intent(in) :: field - type(vector_field), intent(in) :: positions - type(element_type), pointer :: shape_field - real :: l2, ele_int - type(scalar_field) :: debug - - integer :: ele - real, dimension(ele_ngi(positions,1)) :: detwei - - debug = piecewise_constant_field(field%mesh, "L2 error") - - l2 = 0.0 - shape_field => ele_shape(field, 1) - - do ele=1,element_count(field) - call transform_to_physical(positions, ele, detwei=detwei) - ele_int = dot_product((abs(function_val_at_quad_scalar(solution, positions, ele) - ele_val_at_quad(field, ele)))**2, detwei) - debug%val(ele) = ele_int - l2 = l2 + ele_int - end do - l2 = sqrt(l2) - - call vtk_write_fields("l2_error", 0, positions, field%mesh, sfields=(/debug/)) - - end function compute_interpolation_error_l2 - - function compute_interpolation_error_inf(solution, field, positions) result(maxn) - !!< Compute the inf-norm of the error between the function solution - !!< and its interpolant field. - interface - function solution(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function solution - end interface - type(scalar_field), intent(in) :: field - type(vector_field), intent(in) :: positions - real :: maxn, current_max - type(scalar_field) :: debug - - integer :: ele - - debug = piecewise_constant_field(field%mesh, "Inf error") - - maxn = 0.0 - - do ele=1,element_count(field) - current_max = maxval(abs(function_val_at_quad_scalar(solution, positions, ele) - ele_val_at_quad(field, ele))) - debug%val(ele) = current_max - maxn = max(maxn, current_max) - end do - - call vtk_write_fields("inf_error", 0, positions, field%mesh, sfields=(/debug/)) - - end function compute_interpolation_error_inf - - function compute_interpolation_error_h1(gradsoln, field, positions) result(h1) - !!< Compute the h1-norm of the error between the function gradsoln - !!< and its interpolant field. - interface - function gradsoln(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: gradsoln - end function gradsoln - end interface - type(scalar_field), intent(in) :: field - type(vector_field), intent(in) :: positions - type(element_type), pointer :: shape_field - real :: h1, ele_int - type(scalar_field) :: debug - real, dimension(ele_loc(field,1), ele_ngi(field, 1), positions%dim) :: dm_t - real, dimension(positions%dim, ele_ngi(field, 1)) :: grad_at_quad - real, dimension(ele_ngi(field, 1)) :: err_at_quad - integer :: dim - - - integer :: ele - real, dimension(ele_ngi(positions,1)) :: detwei - - debug = piecewise_constant_field(field%mesh, "H1 error") - - h1 = 0.0 - shape_field => ele_shape(field, 1) - - do ele=1,element_count(field) - grad_at_quad = function_val_at_quad(gradsoln, positions, ele) - call transform_to_physical(positions, ele, shape_field, dshape=dm_t, detwei=detwei) - ele_int = 0.0 - do dim=1,positions%dim - err_at_quad = (grad_at_quad(dim, :) - matmul(ele_val(field, ele), dm_t(:, :, dim)))**2 - ele_int = ele_int + dot_product(err_at_quad, detwei) + use elements + use transform_elements, only: transform_to_physical + use fields + use vtk_interfaces, only: vtk_write_fields + implicit none + + private + + public :: compute_interpolation_error_l2, compute_interpolation_error_inf,& + compute_interpolation_error_h1 + +contains + + function compute_interpolation_error_l2(solution, field, positions) result(l2) + !!< Compute the l2-norm of the error between the function solution + !!< and its interpolant field. + interface + function solution(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function solution + end interface + type(scalar_field), intent(in) :: field + type(vector_field), intent(in) :: positions + type(element_type), pointer :: shape_field + real :: l2, ele_int + type(scalar_field) :: debug + + integer :: ele + real, dimension(ele_ngi(positions,1)) :: detwei + + debug = piecewise_constant_field(field%mesh, "L2 error") + + l2 = 0.0 + shape_field => ele_shape(field, 1) + + do ele=1,element_count(field) + call transform_to_physical(positions, ele, detwei=detwei) + ele_int = dot_product((abs(function_val_at_quad_scalar(solution, positions, ele) - ele_val_at_quad(field, ele)))**2, detwei) + debug%val(ele) = ele_int + l2 = l2 + ele_int end do - debug%val(ele) = ele_int - h1 = h1 + ele_int - end do - h1 = sqrt(h1) + l2 = sqrt(l2) - call vtk_write_fields("h1_error", 0, positions, field%mesh, sfields=(/debug/)) - call deallocate(debug) + call vtk_write_fields("l2_error", 0, positions, field%mesh, sfields=(/debug/)) - end function compute_interpolation_error_h1 + end function compute_interpolation_error_l2 + + function compute_interpolation_error_inf(solution, field, positions) result(maxn) + !!< Compute the inf-norm of the error between the function solution + !!< and its interpolant field. + interface + function solution(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function solution + end interface + type(scalar_field), intent(in) :: field + type(vector_field), intent(in) :: positions + real :: maxn, current_max + type(scalar_field) :: debug + + integer :: ele + + debug = piecewise_constant_field(field%mesh, "Inf error") + + maxn = 0.0 + + do ele=1,element_count(field) + current_max = maxval(abs(function_val_at_quad_scalar(solution, positions, ele) - ele_val_at_quad(field, ele))) + debug%val(ele) = current_max + maxn = max(maxn, current_max) + end do + + call vtk_write_fields("inf_error", 0, positions, field%mesh, sfields=(/debug/)) + + end function compute_interpolation_error_inf + + function compute_interpolation_error_h1(gradsoln, field, positions) result(h1) + !!< Compute the h1-norm of the error between the function gradsoln + !!< and its interpolant field. + interface + function gradsoln(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: gradsoln + end function gradsoln + end interface + type(scalar_field), intent(in) :: field + type(vector_field), intent(in) :: positions + type(element_type), pointer :: shape_field + real :: h1, ele_int + type(scalar_field) :: debug + real, dimension(ele_loc(field,1), ele_ngi(field, 1), positions%dim) :: dm_t + real, dimension(positions%dim, ele_ngi(field, 1)) :: grad_at_quad + real, dimension(ele_ngi(field, 1)) :: err_at_quad + integer :: dim + + + integer :: ele + real, dimension(ele_ngi(positions,1)) :: detwei + + debug = piecewise_constant_field(field%mesh, "H1 error") + + h1 = 0.0 + shape_field => ele_shape(field, 1) + + do ele=1,element_count(field) + grad_at_quad = function_val_at_quad(gradsoln, positions, ele) + call transform_to_physical(positions, ele, shape_field, dshape=dm_t, detwei=detwei) + ele_int = 0.0 + do dim=1,positions%dim + err_at_quad = (grad_at_quad(dim, :) - matmul(ele_val(field, ele), dm_t(:, :, dim)))**2 + ele_int = ele_int + dot_product(err_at_quad, detwei) + end do + debug%val(ele) = ele_int + h1 = h1 + ele_int + end do + h1 = sqrt(h1) + + call vtk_write_fields("h1_error", 0, positions, field%mesh, sfields=(/debug/)) + call deallocate(debug) + + end function compute_interpolation_error_h1 end module interpolation_error diff --git a/error_measures/Interpolation_metric.F90 b/error_measures/Interpolation_metric.F90 index 7b1aa46758..013c99b9e3 100644 --- a/error_measures/Interpolation_metric.F90 +++ b/error_measures/Interpolation_metric.F90 @@ -7,245 +7,245 @@ module interpolation_metric !!< finite element calculations", Pain et. al, !!< Comput. Methods Apll. Mech Engrg. 190 (2001) 3771-3796 - use spud - use fldebug - use metric_tools - use parallel_fields - use fields - use state_module - use vtk_interfaces - use merge_tensors - use halos - use field_derivatives - use field_options - use form_metric_field - use edge_length_module - use aspect_ratios_module - use field_preprocessing_module - use project_metric_to_surface_module - - implicit none - - logical :: use_interpolation_metric - - private - public :: use_interpolation_metric, initialise_interpolation_metric,& - form_interpolation_metric - - contains - - subroutine initialise_interpolation_metric - !!< For now we always want to use this metric. - use_interpolation_metric = .true. - end subroutine initialise_interpolation_metric - - subroutine form_interpolation_metric(state, error_metric) - type(state_type), intent(inout), dimension(:) :: state - type(tensor_field), intent(inout) :: error_metric - - type(tensor_field) :: tmp_tensor - integer :: i, j, k, l - type(scalar_field) :: edgelen, aspect_ratios - type(scalar_field) :: adweit_s - type(vector_field) :: adweit_v - type(tensor_field) :: adweit_t - - integer, save :: adaptcnt = 0 - character(len=20) :: buf - type(vector_field), pointer :: positions - - type(scalar_field) :: field_s, preprocessed_field_s - type(vector_field) :: field_v - type(tensor_field) :: field_t - - type(state_type) :: fields_state, weights_state - type(scalar_field), pointer, dimension(:) :: fields_list, weights_list - integer :: dim - logical :: debug_metric, align_metric_vertically - - ! First let's get the fields that are actually being used. - ! If the error is set to the special value 0.0, it means ignore that field - ! for the purposes of computing the metric for adaptivity. - - positions => extract_vector_field(state(1), "Coordinate") - dim = error_metric%dim(1) - debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") - ! is this metric going to be collapsed in the vertical to do horizontal adaptivity with it? - align_metric_vertically = have_option("/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/vertically_align_metric") - - do i=1,size(state) - do j=1,scalar_field_count(state(i)) - field_s = extract_scalar_field(state(i), j) - if (aliased(field_s)) then - cycle - end if - - if (have_adapt_opt(trim(field_s%option_path), "/adaptivity_options") & - & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/no_interpolation_measure") & - & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/anisotropic_zienkiewicz_zhu")) then - call preprocess_field(field_s, positions, preprocessed_field_s) - call insert(fields_state, preprocessed_field_s, trim(state(i)%name)//"::"//trim(field_s%name)) - call deallocate(preprocessed_field_s) - adweit_s = extract_scalar_field(state(i), trim(field_s%name) // "InterpolationErrorBound") - call insert(weights_state, adweit_s, trim(state(i)%name)//"::"//trim(adweit_s%name)) - end if - end do + use spud + use fldebug + use metric_tools + use parallel_fields + use fields + use state_module + use vtk_interfaces + use merge_tensors + use halos + use field_derivatives + use field_options + use form_metric_field + use edge_length_module + use aspect_ratios_module + use field_preprocessing_module + use project_metric_to_surface_module + + implicit none + + logical :: use_interpolation_metric + + private + public :: use_interpolation_metric, initialise_interpolation_metric,& + form_interpolation_metric + +contains + + subroutine initialise_interpolation_metric + !!< For now we always want to use this metric. + use_interpolation_metric = .true. + end subroutine initialise_interpolation_metric + + subroutine form_interpolation_metric(state, error_metric) + type(state_type), intent(inout), dimension(:) :: state + type(tensor_field), intent(inout) :: error_metric + + type(tensor_field) :: tmp_tensor + integer :: i, j, k, l + type(scalar_field) :: edgelen, aspect_ratios + type(scalar_field) :: adweit_s + type(vector_field) :: adweit_v + type(tensor_field) :: adweit_t + + integer, save :: adaptcnt = 0 + character(len=20) :: buf + type(vector_field), pointer :: positions + + type(scalar_field) :: field_s, preprocessed_field_s + type(vector_field) :: field_v + type(tensor_field) :: field_t + + type(state_type) :: fields_state, weights_state + type(scalar_field), pointer, dimension(:) :: fields_list, weights_list + integer :: dim + logical :: debug_metric, align_metric_vertically + + ! First let's get the fields that are actually being used. + ! If the error is set to the special value 0.0, it means ignore that field + ! for the purposes of computing the metric for adaptivity. + + positions => extract_vector_field(state(1), "Coordinate") + dim = error_metric%dim(1) + debug_metric = have_option("/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages") + ! is this metric going to be collapsed in the vertical to do horizontal adaptivity with it? + align_metric_vertically = have_option("/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity/vertically_align_metric") + + do i=1,size(state) + do j=1,scalar_field_count(state(i)) + field_s = extract_scalar_field(state(i), j) + if (aliased(field_s)) then + cycle + end if - do j=1,vector_field_count(state(i)) - field_v = extract_vector_field(state(i), j) - if (aliased(field_v)) then - cycle - end if - - if (have_adapt_opt(trim(field_v%option_path), "/adaptivity_options") & - & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/no_interpolation_measure")) then - adweit_v = extract_vector_field(state(i), trim(field_v%name) // "InterpolationErrorBound") - do k=1,field_v%dim - adweit_s = extract_scalar_field(adweit_v, k) - if (minval(adweit_s) > 0.0) then - field_s = extract_scalar_field(field_v, k) - call preprocess_field(field_s, positions, preprocessed_field_s) - call insert(fields_state, preprocessed_field_s, trim(state(i)%name)//"::"//trim(field_s%name)) - call insert(weights_state, adweit_s, trim(state(i)%name)//"::"//trim(adweit_s%name)) - call deallocate(preprocessed_field_s) + if (have_adapt_opt(trim(field_s%option_path), "/adaptivity_options") & + & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/no_interpolation_measure") & + & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/anisotropic_zienkiewicz_zhu")) then + call preprocess_field(field_s, positions, preprocessed_field_s) + call insert(fields_state, preprocessed_field_s, trim(state(i)%name)//"::"//trim(field_s%name)) + call deallocate(preprocessed_field_s) + adweit_s = extract_scalar_field(state(i), trim(field_s%name) // "InterpolationErrorBound") + call insert(weights_state, adweit_s, trim(state(i)%name)//"::"//trim(adweit_s%name)) + end if + end do + + do j=1,vector_field_count(state(i)) + field_v = extract_vector_field(state(i), j) + if (aliased(field_v)) then + cycle + end if + + if (have_adapt_opt(trim(field_v%option_path), "/adaptivity_options") & + & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/no_interpolation_measure")) then + adweit_v = extract_vector_field(state(i), trim(field_v%name) // "InterpolationErrorBound") + do k=1,field_v%dim + adweit_s = extract_scalar_field(adweit_v, k) + if (minval(adweit_s) > 0.0) then + field_s = extract_scalar_field(field_v, k) + call preprocess_field(field_s, positions, preprocessed_field_s) + call insert(fields_state, preprocessed_field_s, trim(state(i)%name)//"::"//trim(field_s%name)) + call insert(weights_state, adweit_s, trim(state(i)%name)//"::"//trim(adweit_s%name)) + call deallocate(preprocessed_field_s) + end if + end do + end if + end do + + do j=1,tensor_field_count(state(i)) + field_t = extract_tensor_field(state(i), j) + if (aliased(field_t)) then + cycle end if - end do - end if - end do - do j=1,tensor_field_count(state(i)) - field_t = extract_tensor_field(state(i), j) - if (aliased(field_t)) then - cycle - end if - - if (have_adapt_opt(trim(field_t%option_path), "/adaptivity_options") & - & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/no_interpolation_measure")) then - adweit_t = extract_tensor_field(state(i), trim(field_t%name) // "InterpolationErrorBound") - do k=1,field_t%dim(1) - do l=1,field_t%dim(2) - adweit_s = extract_scalar_field(adweit_t, k, l) - if (minval(adweit_s) > 0.0) then - field_s = extract_scalar_field(field_t, k, l) - call preprocess_field(field_s, positions, preprocessed_field_s) - call insert(fields_state, preprocessed_field_s, trim(state(i)%name)//"::"//trim(field_s%name)) - call insert(weights_state, adweit_s, trim(state(i)%name)//"::"//trim(adweit_s%name)) - call deallocate(preprocessed_field_s) - end if - end do - end do - end if + if (have_adapt_opt(trim(field_t%option_path), "/adaptivity_options") & + & .and. .not. have_adapt_opt(trim(field_s%option_path), "/adaptivity_options/no_interpolation_measure")) then + adweit_t = extract_tensor_field(state(i), trim(field_t%name) // "InterpolationErrorBound") + do k=1,field_t%dim(1) + do l=1,field_t%dim(2) + adweit_s = extract_scalar_field(adweit_t, k, l) + if (minval(adweit_s) > 0.0) then + field_s = extract_scalar_field(field_t, k, l) + call preprocess_field(field_s, positions, preprocessed_field_s) + call insert(fields_state, preprocessed_field_s, trim(state(i)%name)//"::"//trim(field_s%name)) + call insert(weights_state, adweit_s, trim(state(i)%name)//"::"//trim(adweit_s%name)) + call deallocate(preprocessed_field_s) + end if + end do + end do + end if + end do end do - end do - - call collapse_state(fields_state, fields_list) - call collapse_state(weights_state, weights_list) - - if (size(fields_list) == 0) then - ewrite(1,*) "Interpolation metric doing nothing" - return - end if - - ! If we have more than one scalar field, we'll need to compute each individual - ! metric and convolve the two. We need some memory to store the second metric. - if (size(fields_list) > 1) then - call allocate(tmp_tensor, error_metric%mesh, "Tmp") - end if - - if (debug_metric) then - call allocate(edgelen, positions%mesh, "Desired edge lengths") - call allocate(aspect_ratios, positions%mesh, "Metric aspect ratio") - endif - - ewrite(2,*) "++: Forming interpolation metric" - - call halo_update(fields_list(1)) - call compute_hessian(fields_list(1), positions, error_metric) - - if (align_metric_vertically) then - ! state only used for "GravityDirection", so state(1) is fine - call vertically_align_metric(state(1), error_metric) - end if - - ewrite(2,*) "++: Hessian", 1, "formed" - - if (debug_metric) then - call get_edge_lengths(error_metric, edgelen) - call vtk_write_fields(trim("interpolation_metric_hessian_1"), adaptcnt, positions, positions%mesh, & - sfields=(/fields_list(1), edgelen/), tfields=(/error_metric/)) - endif - - call form_metric(error_metric, fields_list(1), weights_list(1), state(1)) - ewrite(2,*) "++: Metric", 1, "formed" - - if (debug_metric) then - call get_edge_lengths(error_metric, edgelen) - call get_aspect_ratios(error_metric, aspect_ratios) - call vtk_write_fields(trim("interpolation_metric_metric_1"), adaptcnt, positions, positions%mesh, & - sfields=(/fields_list(1), edgelen, aspect_ratios/), tfields=(/error_metric/)) - endif - - ! Now loop through the rest, construct each individual metric and merge with the first. - do i=2,size(fields_list) - write(buf, '(i0)') i - call halo_update(fields_list(i)) - call compute_hessian(fields_list(i), positions, tmp_tensor) - ewrite(2,*) "++: Hessian", i, "formed" - if (align_metric_vertically) then - ! state only used for "GravityDirection", so state(1) is fine - call vertically_align_metric(state(1), tmp_tensor) + call collapse_state(fields_state, fields_list) + call collapse_state(weights_state, weights_list) + + if (size(fields_list) == 0) then + ewrite(1,*) "Interpolation metric doing nothing" + return + end if + + ! If we have more than one scalar field, we'll need to compute each individual + ! metric and convolve the two. We need some memory to store the second metric. + if (size(fields_list) > 1) then + call allocate(tmp_tensor, error_metric%mesh, "Tmp") end if if (debug_metric) then - call get_edge_lengths(tmp_tensor, edgelen) - call vtk_write_fields(trim("interpolation_metric_hessian_") // trim(buf), adaptcnt, positions, positions%mesh, & - sfields=(/fields_list(i), edgelen/), tfields=(/tmp_tensor/)) + call allocate(edgelen, positions%mesh, "Desired edge lengths") + call allocate(aspect_ratios, positions%mesh, "Metric aspect ratio") endif - call form_metric(tmp_tensor, fields_list(i), weights_list(i), state(1)) - ewrite(2,*) "++: Metric", i, "formed" + ewrite(2,*) "++: Forming interpolation metric" + + call halo_update(fields_list(1)) + call compute_hessian(fields_list(1), positions, error_metric) + + if (align_metric_vertically) then + ! state only used for "GravityDirection", so state(1) is fine + call vertically_align_metric(state(1), error_metric) + end if + + ewrite(2,*) "++: Hessian", 1, "formed" if (debug_metric) then - call get_edge_lengths(tmp_tensor, edgelen) - call get_aspect_ratios(tmp_tensor, aspect_ratios) - call vtk_write_fields(trim("interpolation_metric_metric_") // trim(buf), adaptcnt, positions, positions%mesh, & - sfields=(/fields_list(i), edgelen, aspect_ratios/), tfields=(/tmp_tensor/)) + call get_edge_lengths(error_metric, edgelen) + call vtk_write_fields(trim("interpolation_metric_hessian_1"), adaptcnt, positions, positions%mesh, & + sfields=(/fields_list(1), edgelen/), tfields=(/error_metric/)) endif - call merge_tensor_fields(error_metric, tmp_tensor) - ewrite(2,*) "++: Metric", i, "merged" + call form_metric(error_metric, fields_list(1), weights_list(1), state(1)) + ewrite(2,*) "++: Metric", 1, "formed" if (debug_metric) then - call get_edge_lengths(error_metric, edgelen) - call get_aspect_ratios(error_metric, aspect_ratios) - call vtk_write_fields(trim("interpolation_metric_merge_") // trim(buf), adaptcnt, positions, positions%mesh, & - sfields=(/fields_list(i), edgelen, aspect_ratios/), tfields=(/error_metric/)) + call get_edge_lengths(error_metric, edgelen) + call get_aspect_ratios(error_metric, aspect_ratios) + call vtk_write_fields(trim("interpolation_metric_metric_1"), adaptcnt, positions, positions%mesh, & + sfields=(/fields_list(1), edgelen, aspect_ratios/), tfields=(/error_metric/)) endif - end do - call check_metric(error_metric) + ! Now loop through the rest, construct each individual metric and merge with the first. + do i=2,size(fields_list) + write(buf, '(i0)') i + call halo_update(fields_list(i)) + call compute_hessian(fields_list(i), positions, tmp_tensor) + ewrite(2,*) "++: Hessian", i, "formed" + + if (align_metric_vertically) then + ! state only used for "GravityDirection", so state(1) is fine + call vertically_align_metric(state(1), tmp_tensor) + end if + + if (debug_metric) then + call get_edge_lengths(tmp_tensor, edgelen) + call vtk_write_fields(trim("interpolation_metric_hessian_") // trim(buf), adaptcnt, positions, positions%mesh, & + sfields=(/fields_list(i), edgelen/), tfields=(/tmp_tensor/)) + endif + + call form_metric(tmp_tensor, fields_list(i), weights_list(i), state(1)) + ewrite(2,*) "++: Metric", i, "formed" + + if (debug_metric) then + call get_edge_lengths(tmp_tensor, edgelen) + call get_aspect_ratios(tmp_tensor, aspect_ratios) + call vtk_write_fields(trim("interpolation_metric_metric_") // trim(buf), adaptcnt, positions, positions%mesh, & + sfields=(/fields_list(i), edgelen, aspect_ratios/), tfields=(/tmp_tensor/)) + endif + + call merge_tensor_fields(error_metric, tmp_tensor) + ewrite(2,*) "++: Metric", i, "merged" + + if (debug_metric) then + call get_edge_lengths(error_metric, edgelen) + call get_aspect_ratios(error_metric, aspect_ratios) + call vtk_write_fields(trim("interpolation_metric_merge_") // trim(buf), adaptcnt, positions, positions%mesh, & + sfields=(/fields_list(i), edgelen, aspect_ratios/), tfields=(/error_metric/)) + endif + end do + + call check_metric(error_metric) - if (size(fields_list) > 1) then - call deallocate(tmp_tensor) - end if + if (size(fields_list) > 1) then + call deallocate(tmp_tensor) + end if - deallocate(fields_list) - deallocate(weights_list) - call deallocate(fields_state) - call deallocate(weights_state) + deallocate(fields_list) + deallocate(weights_list) + call deallocate(fields_state) + call deallocate(weights_state) - if (debug_metric) then - call get_edge_lengths(error_metric, edgelen) - call get_aspect_ratios(error_metric, aspect_ratios) - call vtk_write_fields(trim("interpolation_metric_final"), adaptcnt, positions, positions%mesh, & - sfields=(/edgelen, aspect_ratios/), tfields=(/error_metric/)) - call deallocate(edgelen) - call deallocate(aspect_ratios) - endif + if (debug_metric) then + call get_edge_lengths(error_metric, edgelen) + call get_aspect_ratios(error_metric, aspect_ratios) + call vtk_write_fields(trim("interpolation_metric_final"), adaptcnt, positions, positions%mesh, & + sfields=(/edgelen, aspect_ratios/), tfields=(/error_metric/)) + call deallocate(edgelen) + call deallocate(aspect_ratios) + endif - adaptcnt = adaptcnt + 1 + adaptcnt = adaptcnt + 1 - end subroutine form_interpolation_metric + end subroutine form_interpolation_metric end module interpolation_metric diff --git a/error_measures/Limit_metric.F90 b/error_measures/Limit_metric.F90 index e0258e1fb0..2de3389756 100644 --- a/error_measures/Limit_metric.F90 +++ b/error_measures/Limit_metric.F90 @@ -2,268 +2,268 @@ module limit_metric_module - use fldebug - use vector_tools, only : determinant => det - use futils, only: present_and_true - use elements - use spud - use parallel_tools - use parallel_fields - use fields - use meshdiagnostics + use fldebug + use vector_tools, only : determinant => det + use futils, only: present_and_true + use elements + use spud + use parallel_tools + use parallel_fields + use fields + use meshdiagnostics - implicit none + implicit none - private + private - public :: limit_metric, limit_metric_elements, expected_elements, & - & expected_nodes, determinant, limit_metric_module_check_options + public :: limit_metric, limit_metric_elements, expected_elements, & + & expected_nodes, determinant, limit_metric_module_check_options - interface expected_nodes - module procedure expected_nodes_expected_elements, expected_nodes_metric - end interface expected_nodes + interface expected_nodes + module procedure expected_nodes_expected_elements, expected_nodes_metric + end interface expected_nodes - interface limit_metric - module procedure limit_metric_nodes_options, limit_metric_nodes_minmax, & + interface limit_metric + module procedure limit_metric_nodes_options, limit_metric_nodes_minmax, & & limit_metric_nodes_target - end interface limit_metric + end interface limit_metric - interface limit_metric_elements - module procedure limit_metric_elements_minmax, limit_metric_elements_target - end interface limit_metric_elements + interface limit_metric_elements + module procedure limit_metric_elements_minmax, limit_metric_elements_target + end interface limit_metric_elements contains - subroutine limit_metric_nodes_options(positions, metric) - type(tensor_field), intent(inout) :: metric - type(vector_field), intent(in) :: positions + subroutine limit_metric_nodes_options(positions, metric) + type(tensor_field), intent(inout) :: metric + type(vector_field), intent(in) :: positions - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" - integer :: max_nodes, min_nodes, nodes, stat - real :: increase_tolerance + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + integer :: max_nodes, min_nodes, nodes, stat + real :: increase_tolerance - call mesh_stats(positions, nodes = nodes) + call mesh_stats(positions, nodes = nodes) - call get_option(base_path // "/minimum_number_of_nodes", min_nodes, default = 1) - if(have_option(base_path // "/minimum_number_of_nodes/per_process")) then - min_nodes = min_nodes * getnprocs() - end if - call get_option(base_path // "/maximum_number_of_nodes", max_nodes, default = 100000) - if(have_option(base_path // "/maximum_number_of_nodes/per_process")) then - max_nodes = max_nodes * getnprocs() - end if - call get_option(base_path // "/max_node_increase", increase_tolerance, stat = stat) - if(stat == SPUD_NO_ERROR) then - max_nodes = min(max_nodes, int(nodes * increase_tolerance)) - end if + call get_option(base_path // "/minimum_number_of_nodes", min_nodes, default = 1) + if(have_option(base_path // "/minimum_number_of_nodes/per_process")) then + min_nodes = min_nodes * getnprocs() + end if + call get_option(base_path // "/maximum_number_of_nodes", max_nodes, default = 100000) + if(have_option(base_path // "/maximum_number_of_nodes/per_process")) then + max_nodes = max_nodes * getnprocs() + end if + call get_option(base_path // "/max_node_increase", increase_tolerance, stat = stat) + if(stat == SPUD_NO_ERROR) then + max_nodes = min(max_nodes, int(nodes * increase_tolerance)) + end if + + call limit_metric(positions, metric, min_nodes, max_nodes) + + end subroutine limit_metric_nodes_options + + subroutine limit_metric_nodes_minmax(positions, metric, min_nodes, max_nodes) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(inout) :: metric + integer, intent(in) :: min_nodes + integer, intent(in) :: max_nodes - call limit_metric(positions, metric, min_nodes, max_nodes) + integer :: elements, max_eles, min_eles, nodes + ! The ratio of elements to nodes + real :: eles_per_node + + assert(min_nodes > 0) + assert(max_nodes >= min_nodes) + + call mesh_stats(positions, nodes = nodes, elements = elements) + + ! FIXME: maybe a better way to do this? + eles_per_node = float(elements) / float(nodes) + + min_eles = eles_per_node * min_nodes + max_eles = eles_per_node * max_nodes + + if(min_eles < 0) then + ewrite(-1, *) "Minimum elements: ", min_eles + FLAbort("Invalid minimum number of elements") + end if + if(max_eles < 0) then + ewrite(-1, *) "Maximum elements: ", max_eles + FLAbort("Invalid maximum number of elements") + end if + + call limit_metric_elements(positions, metric, min_eles, max_eles) + + end subroutine limit_metric_nodes_minmax + + subroutine limit_metric_elements_minmax(positions, metric, min_eles, max_eles) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(inout) :: metric + integer, intent(in) :: min_eles + integer, intent(in) :: max_eles + + integer :: expected_eles + ! the scaling factor to divide the metric by + real :: beta + + expected_eles = expected_elements(positions, metric, global = .true.) + + if(expected_eles > max_eles) then + beta = ((1.0 / expected_eles) * max_eles) ** (2.0 / positions%dim) + ewrite(2,*) "Scaling factor to conform to maximum node limit: ", beta + call scale(metric, beta) + else if(expected_eles < min_eles) then + beta = ((1.0 / expected_eles) * min_eles) ** (2.0 / positions%dim) + ewrite(2,*) "Scaling factor to conform to minimum node limit: ", beta + call scale(metric, beta) + end if + + end subroutine limit_metric_elements_minmax + + subroutine limit_metric_nodes_target(positions, metric, target_nodes) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(inout) :: metric + integer, intent(in) :: target_nodes + + call limit_metric(positions, metric, min_nodes = target_nodes, max_nodes = target_nodes) + + end subroutine limit_metric_nodes_target + + subroutine limit_metric_elements_target(positions, metric, target_eles) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(inout) :: metric + integer, intent(in) :: target_eles + + call limit_metric_elements(positions, metric, min_eles = target_eles, max_eles = target_eles) + + end subroutine limit_metric_elements_target + + function expected_elements(old_positions, metric, global) result(xpct) + type(vector_field), intent(in) :: old_positions + type(tensor_field), intent(in) :: metric + !! If present and .true., calculate the global number of expected elements + logical, optional, intent(in) :: global + integer :: ele + real, dimension(mesh_dim(metric), mesh_dim(metric)) :: avg_metric + real :: sumvol, det + integer :: xpct + real :: gamma + + logical :: lglobal + + lglobal = present_and_true(global) + + sumvol = 0.0 + + ! Gamma is the volume of an optimal element + ! (in metric space) + select case(mesh_dim(metric)) + case(3) + gamma = 1.0 / sqrt(72.0) + case(2) + gamma = sqrt(3.0) / 4.0 + case(1) + gamma = 1.0 + case default + FLAbort("Invalid dimension") + end select + + do ele=1,ele_count(old_positions) + if(lglobal) then + if(.not. element_owned(old_positions, ele)) cycle + end if + avg_metric = sum(ele_val(metric, ele), 3) / ele_loc(metric, ele) + det = determinant(avg_metric) + sumvol = sumvol + abs(sqrt(det) * simplex_volume(old_positions, ele)) + end do + if(lglobal) call allsum(sumvol) + + if(sumvol < 0.0) then + ewrite(-1, *) "Total volume in metric space: ", sumvol + FLAbort("Negative volume") + end if + if((sumvol/gamma)>=huge(xpct)) then + ewrite(-1, *) "ERROR: The error metric & + & indicates that number of elements required is ", sumvol/gamma + ewrite(-1, *) "If this is what you want then, great, congratulations, & + &this is a record. Please ask the developers to get rid of this & + &32bit integer that's causing trouble. Otherwise, please review your & + &error targets" + FLExit("integer overflow") + end if + xpct = int(sumvol / gamma) + if (xpct == 0) xpct = 1 - end subroutine limit_metric_nodes_options - - subroutine limit_metric_nodes_minmax(positions, metric, min_nodes, max_nodes) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(inout) :: metric - integer, intent(in) :: min_nodes - integer, intent(in) :: max_nodes - - integer :: elements, max_eles, min_eles, nodes - ! The ratio of elements to nodes - real :: eles_per_node - - assert(min_nodes > 0) - assert(max_nodes >= min_nodes) - - call mesh_stats(positions, nodes = nodes, elements = elements) - - ! FIXME: maybe a better way to do this? - eles_per_node = float(elements) / float(nodes) - - min_eles = eles_per_node * min_nodes - max_eles = eles_per_node * max_nodes - - if(min_eles < 0) then - ewrite(-1, *) "Minimum elements: ", min_eles - FLAbort("Invalid minimum number of elements") - end if - if(max_eles < 0) then - ewrite(-1, *) "Maximum elements: ", max_eles - FLAbort("Invalid maximum number of elements") - end if - - call limit_metric_elements(positions, metric, min_eles, max_eles) - - end subroutine limit_metric_nodes_minmax - - subroutine limit_metric_elements_minmax(positions, metric, min_eles, max_eles) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(inout) :: metric - integer, intent(in) :: min_eles - integer, intent(in) :: max_eles - - integer :: expected_eles - ! the scaling factor to divide the metric by - real :: beta - - expected_eles = expected_elements(positions, metric, global = .true.) - - if(expected_eles > max_eles) then - beta = ((1.0 / expected_eles) * max_eles) ** (2.0 / positions%dim) - ewrite(2,*) "Scaling factor to conform to maximum node limit: ", beta - call scale(metric, beta) - else if(expected_eles < min_eles) then - beta = ((1.0 / expected_eles) * min_eles) ** (2.0 / positions%dim) - ewrite(2,*) "Scaling factor to conform to minimum node limit: ", beta - call scale(metric, beta) - end if - - end subroutine limit_metric_elements_minmax - - subroutine limit_metric_nodes_target(positions, metric, target_nodes) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(inout) :: metric - integer, intent(in) :: target_nodes - - call limit_metric(positions, metric, min_nodes = target_nodes, max_nodes = target_nodes) - - end subroutine limit_metric_nodes_target - - subroutine limit_metric_elements_target(positions, metric, target_eles) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(inout) :: metric - integer, intent(in) :: target_eles - - call limit_metric_elements(positions, metric, min_eles = target_eles, max_eles = target_eles) - - end subroutine limit_metric_elements_target - - function expected_elements(old_positions, metric, global) result(xpct) - type(vector_field), intent(in) :: old_positions - type(tensor_field), intent(in) :: metric - !! If present and .true., calculate the global number of expected elements - logical, optional, intent(in) :: global - integer :: ele - real, dimension(mesh_dim(metric), mesh_dim(metric)) :: avg_metric - real :: sumvol, det - integer :: xpct - real :: gamma - - logical :: lglobal - - lglobal = present_and_true(global) - - sumvol = 0.0 - - ! Gamma is the volume of an optimal element - ! (in metric space) - select case(mesh_dim(metric)) - case(3) - gamma = 1.0 / sqrt(72.0) - case(2) - gamma = sqrt(3.0) / 4.0 - case(1) - gamma = 1.0 - case default - FLAbort("Invalid dimension") - end select - - do ele=1,ele_count(old_positions) - if(lglobal) then - if(.not. element_owned(old_positions, ele)) cycle + if(xpct < 0) then + ewrite(-1, *) "Expected elements: ", xpct + FLAbort("Invalid number of expected elements") end if - avg_metric = sum(ele_val(metric, ele), 3) / ele_loc(metric, ele) - det = determinant(avg_metric) - sumvol = sumvol + abs(sqrt(det) * simplex_volume(old_positions, ele)) - end do - if(lglobal) call allsum(sumvol) - - if(sumvol < 0.0) then - ewrite(-1, *) "Total volume in metric space: ", sumvol - FLAbort("Negative volume") - end if - if((sumvol/gamma)>=huge(xpct)) then - ewrite(-1, *) "ERROR: The error metric & - & indicates that number of elements required is ", sumvol/gamma - ewrite(-1, *) "If this is what you want then, great, congratulations, & - &this is a record. Please ask the developers to get rid of this & - &32bit integer that's causing trouble. Otherwise, please review your & - &error targets" - FLExit("integer overflow") - end if - xpct = int(sumvol / gamma) - if (xpct == 0) xpct = 1 - - if(xpct < 0) then - ewrite(-1, *) "Expected elements: ", xpct - FLAbort("Invalid number of expected elements") - end if - if (lglobal) then - ewrite(2, *) "Expected global n/o elements: ", xpct - else - ewrite(2, *) "Expected n/o elements: ", xpct - end if - - end function expected_elements - - function expected_nodes_expected_elements(old_positions, expected_eles, global) result(expected_nods) - !!< Return the expected number of nodes based upon the supplied expected - !!< number of elements - - type(vector_field), intent(in) :: old_positions - integer, intent(in) :: expected_eles - !! If present and .true., calculate the global number of expected elements - logical, optional, intent(in) :: global - - integer :: elements, expected_nods, nodes - - if(present_and_true(global)) then - call mesh_stats(old_positions, nodes = nodes, elements = elements) - else - nodes = node_count(old_positions) - elements = ele_count(old_positions) - end if - - ! FIXME: maybe a better way to do this? - expected_nods = (float(nodes) / float(elements)) * expected_eles - - end function expected_nodes_expected_elements - - function expected_nodes_metric(old_positions, metric, global) result(expected_nods) - !!< Return the expected number of nodes based upon the supplied metric - - type(vector_field), intent(in) :: old_positions - type(tensor_field), intent(in) :: metric - !! If present and .true., calculate the global number of expected elements - logical, optional, intent(in) :: global - - integer :: expected_nods - - integer :: expected_eles - - expected_eles = expected_elements(old_positions, metric, global) - expected_nods = expected_nodes(old_positions, expected_eles, global) - - end function expected_nodes_metric - - subroutine limit_metric_module_check_options() - !!< Check metric limiting specific options - - character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" - integer :: max_nodes, min_nodes, stat - - if(.not. have_option(base_path)) then - ! Nothing to check - return - end if - - call get_option(base_path // "/minimum_number_of_nodes", min_nodes, default = 0) - call get_option(base_path // "/maximum_number_of_nodes", max_nodes, stat = stat) - if(stat /= SPUD_NO_ERROR) then - FLExit("Maximum number of nodes must be specified when using hr mesh adaptivity") - else if(min_nodes > max_nodes) then - FLExit("The minimum number of nodes cannot be greater than the maximum number of nodes") - end if - - end subroutine limit_metric_module_check_options + if (lglobal) then + ewrite(2, *) "Expected global n/o elements: ", xpct + else + ewrite(2, *) "Expected n/o elements: ", xpct + end if + + end function expected_elements + + function expected_nodes_expected_elements(old_positions, expected_eles, global) result(expected_nods) + !!< Return the expected number of nodes based upon the supplied expected + !!< number of elements + + type(vector_field), intent(in) :: old_positions + integer, intent(in) :: expected_eles + !! If present and .true., calculate the global number of expected elements + logical, optional, intent(in) :: global + + integer :: elements, expected_nods, nodes + + if(present_and_true(global)) then + call mesh_stats(old_positions, nodes = nodes, elements = elements) + else + nodes = node_count(old_positions) + elements = ele_count(old_positions) + end if + + ! FIXME: maybe a better way to do this? + expected_nods = (float(nodes) / float(elements)) * expected_eles + + end function expected_nodes_expected_elements + + function expected_nodes_metric(old_positions, metric, global) result(expected_nods) + !!< Return the expected number of nodes based upon the supplied metric + + type(vector_field), intent(in) :: old_positions + type(tensor_field), intent(in) :: metric + !! If present and .true., calculate the global number of expected elements + logical, optional, intent(in) :: global + + integer :: expected_nods + + integer :: expected_eles + + expected_eles = expected_elements(old_positions, metric, global) + expected_nods = expected_nodes(old_positions, expected_eles, global) + + end function expected_nodes_metric + + subroutine limit_metric_module_check_options() + !!< Check metric limiting specific options + + character(len = *), parameter :: base_path = "/mesh_adaptivity/hr_adaptivity" + integer :: max_nodes, min_nodes, stat + + if(.not. have_option(base_path)) then + ! Nothing to check + return + end if + + call get_option(base_path // "/minimum_number_of_nodes", min_nodes, default = 0) + call get_option(base_path // "/maximum_number_of_nodes", max_nodes, stat = stat) + if(stat /= SPUD_NO_ERROR) then + FLExit("Maximum number of nodes must be specified when using hr mesh adaptivity") + else if(min_nodes > max_nodes) then + FLExit("The minimum number of nodes cannot be greater than the maximum number of nodes") + end if + + end subroutine limit_metric_module_check_options end module limit_metric_module diff --git a/error_measures/Mba_adapt.F90 b/error_measures/Mba_adapt.F90 index ac1c87ccaa..771ec2902a 100644 --- a/error_measures/Mba_adapt.F90 +++ b/error_measures/Mba_adapt.F90 @@ -1,138 +1,138 @@ #include "fdebug.h" module mba_adapt_module - use fldebug - use eventcounter - use metric_tools - use fields - use state_module - use meshdiagnostics - use vtk_interfaces - use node_boundary - use interpolation_module - use limit_metric_module + use fldebug + use eventcounter + use metric_tools + use fields + use state_module + use meshdiagnostics + use vtk_interfaces + use node_boundary + use interpolation_module + use limit_metric_module #ifdef HAVE_MBA_2D - use mba2d_module + use mba2d_module #endif - implicit none + implicit none - private + private - public :: mba_adapt, CrvFunction_ani, snap_positions, face_basis + public :: mba_adapt, CrvFunction_ani, snap_positions, face_basis - contains +contains - subroutine mba_adapt(state, metric) - type(state_type), intent(inout) :: state - type(tensor_field), intent(in) :: metric + subroutine mba_adapt(state, metric) + type(state_type), intent(inout) :: state + type(tensor_field), intent(in) :: metric #ifdef HAVE_MBA_2D - type(mesh_type), pointer :: xmesh - type(vector_field), pointer :: positions - - integer :: nonods, mxnods, stotel, mxface, totele, maxele - real, dimension(:, :), allocatable :: pos - integer, dimension(:, :), allocatable :: ipf - integer, dimension(:, :), allocatable :: ipe - real, dimension(:, :), allocatable :: parcrv - integer, dimension(:), allocatable :: ipv - integer, dimension(:), allocatable :: iFnc - integer, dimension(:), allocatable :: lbE - real, dimension(:, :), allocatable :: tmp_metric - integer :: i, j - real :: rQuality - integer :: ierr, maxWr, maxWi - real, dimension(:), allocatable :: rW - integer, dimension(:), allocatable :: iW - integer :: status - type(state_type) :: new_state - type(mesh_type) :: new_mesh - type(scalar_field), dimension(scalar_field_count(state)) :: new_scalar - type(vector_field), dimension(vector_field_count(state)-1) :: new_vector - type(tensor_field), dimension(tensor_field_count(state)) :: new_tensor - type(vector_field) :: new_positions - type(scalar_field), pointer :: old_scalar - type(vector_field), pointer :: old_vector - type(tensor_field), pointer :: old_tensor - integer :: npv - integer :: xpctel - - assert(all(metric%dim == 2)) - - positions => extract_vector_field(state, "Coordinate") - xmesh => extract_mesh(state, "Mesh") - call initialise_boundcount(xmesh, positions) - - if (.not. has_faces(xmesh)) then - call add_faces(xmesh) - end if - - ! Patrick, is this right? -Stephan - mxnods = 50000 - - nonods = node_count(xmesh) - totele = ele_count(xmesh) - stotel = surface_element_count(xmesh) - mxface = int(max((float(mxnods) / float(nonods)) * stotel * 1.2, 10000.0)) - maxele = int(max((float(mxnods) / float(nonods)) * totele * 1.2, 10000.0)) - xpctel = max(expected_elements(positions, metric), 5) - - allocate(pos(2, mxnods)) - pos = 0.0 - do i=1,2 - pos(i, 1:nonods) = positions%val(i,:) - end do - - allocate(ipf(4, mxface)) - ipf = 0 - do i=1,stotel - ipf(1:2, i) = face_global_nodes(xmesh, i) - ipf(3, i) = 0 - end do - ipf(4, 1:stotel) = xmesh%faces%boundary_ids - - allocate(ipe(3, maxele)) - ipe = 0 - do i=1,totele - ipe(:, i) = ele_nodes(xmesh, i) - end do - - npv = count(boundcount > 1) - allocate(ipv(npv)) - j = 1 - do i=1,nonods - if (boundcount(i) > 1) then - ipv(j) = i - j = j + 1 + type(mesh_type), pointer :: xmesh + type(vector_field), pointer :: positions + + integer :: nonods, mxnods, stotel, mxface, totele, maxele + real, dimension(:, :), allocatable :: pos + integer, dimension(:, :), allocatable :: ipf + integer, dimension(:, :), allocatable :: ipe + real, dimension(:, :), allocatable :: parcrv + integer, dimension(:), allocatable :: ipv + integer, dimension(:), allocatable :: iFnc + integer, dimension(:), allocatable :: lbE + real, dimension(:, :), allocatable :: tmp_metric + integer :: i, j + real :: rQuality + integer :: ierr, maxWr, maxWi + real, dimension(:), allocatable :: rW + integer, dimension(:), allocatable :: iW + integer :: status + type(state_type) :: new_state + type(mesh_type) :: new_mesh + type(scalar_field), dimension(scalar_field_count(state)) :: new_scalar + type(vector_field), dimension(vector_field_count(state)-1) :: new_vector + type(tensor_field), dimension(tensor_field_count(state)) :: new_tensor + type(vector_field) :: new_positions + type(scalar_field), pointer :: old_scalar + type(vector_field), pointer :: old_vector + type(tensor_field), pointer :: old_tensor + integer :: npv + integer :: xpctel + + assert(all(metric%dim == 2)) + + positions => extract_vector_field(state, "Coordinate") + xmesh => extract_mesh(state, "Mesh") + call initialise_boundcount(xmesh, positions) + + if (.not. has_faces(xmesh)) then + call add_faces(xmesh) end if - end do - allocate(parcrv(2, mxface)) - parcrv = 0 + ! Patrick, is this right? -Stephan + mxnods = 50000 - allocate(iFnc(mxface)) - iFnc = 0 + nonods = node_count(xmesh) + totele = ele_count(xmesh) + stotel = surface_element_count(xmesh) + mxface = int(max((float(mxnods) / float(nonods)) * stotel * 1.2, 10000.0)) + maxele = int(max((float(mxnods) / float(nonods)) * totele * 1.2, 10000.0)) + xpctel = max(expected_elements(positions, metric), 5) - allocate(lbE(maxele)) - lbE = 1 + allocate(pos(2, mxnods)) + pos = 0.0 + do i=1,2 + pos(i, 1:nonods) = positions%val(i,:) + end do + + allocate(ipf(4, mxface)) + ipf = 0 + do i=1,stotel + ipf(1:2, i) = face_global_nodes(xmesh, i) + ipf(3, i) = 0 + end do + ipf(4, 1:stotel) = xmesh%faces%boundary_ids + + allocate(ipe(3, maxele)) + ipe = 0 + do i=1,totele + ipe(:, i) = ele_nodes(xmesh, i) + end do + + npv = count(boundcount > 1) + allocate(ipv(npv)) + j = 1 + do i=1,nonods + if (boundcount(i) > 1) then + ipv(j) = i + j = j + 1 + end if + end do + + allocate(parcrv(2, mxface)) + parcrv = 0 + + allocate(iFnc(mxface)) + iFnc = 0 - allocate(tmp_metric(3, mxnods)) - tmp_metric = 0.0 - do i=1,nonods - tmp_metric(1, i) = metric%val(1, 1, i) - tmp_metric(2, i) = metric%val(2, 2, i) - tmp_metric(3, i) = metric%val(1, 2, i) - end do + allocate(lbE(maxele)) + lbE = 1 - maxWr = (4 * mxnods + 10 * nonods + mxface + maxele) * 1.2 - maxWi = (6 * mxnods + 10 * nonods + 19 * mxface + 11 * maxele + 12 * totele) * 1.2 - allocate(rW(maxWr)) - allocate(iW(maxWi)) + allocate(tmp_metric(3, mxnods)) + tmp_metric = 0.0 + do i=1,nonods + tmp_metric(1, i) = metric%val(1, 1, i) + tmp_metric(2, i) = metric%val(2, 2, i) + tmp_metric(3, i) = metric%val(1, 2, i) + end do + + maxWr = (4 * mxnods + 10 * nonods + mxface + maxele) * 1.2 + maxWi = (6 * mxnods + 10 * nonods + 19 * mxface + 11 * maxele + 12 * totele) * 1.2 + allocate(rW(maxWr)) + allocate(iW(maxWi)) - status = 1 + status = 1 - CALL mbaNodal( & + CALL mbaNodal( & nonods, mxnods, stotel, mxface, totele, maxele, npv, & pos, ipf, ipe, ipv, & CrvFunction_ani, parcrv, iFnc, & @@ -144,182 +144,182 @@ subroutine mba_adapt(state, metric) maxWr, maxWi, rW, iW, & 10, ierr) - call incrementeventcounter(EVENT_ADAPTIVITY) - call incrementeventcounter(EVENT_MESH_MOVEMENT) - - ! Hooray! You didn't crash. Congratulations. Now let's assemble the output and interpolate. - - call allocate(new_mesh, nonods, totele, ele_shape(xmesh, 1), "Mesh") - new_mesh%ndglno = reshape(IPE(:, 1:totele), (/size(new_mesh%ndglno)/)) - call insert(new_state, new_mesh, "Mesh") - call deallocate(new_mesh) - - call allocate(new_positions, 2, new_mesh, "Coordinate") - call set_all(new_positions, pos(:, 1:nonods)) - call snap_positions(positions, new_positions) - call insert(new_state, new_positions, "Coordinate") - call deallocate(new_positions) - - do i=1,scalar_field_count(state) - old_scalar => extract_scalar_field(state, i) - call allocate(new_scalar(i), new_mesh, trim(old_scalar%name)) - call zero(new_scalar(i)) - call insert(new_state, new_scalar(i), trim(old_scalar%name)) - call deallocate(new_scalar(i)) - end do - - j = 1 - do i=1,vector_field_count(state) - old_vector => extract_vector_field(state, i) - if (trim(old_vector%name) == "Coordinate") then - cycle - end if - call allocate(new_vector(j), 2, new_mesh, trim(old_vector%name)) - call zero(new_vector(j)) - call insert(new_state, new_vector(j), trim(old_vector%name)) - call deallocate(new_vector(j)) - j = j + 1 - end do - - do i=1,tensor_field_count(state) - old_tensor => extract_tensor_field(state, i) - call allocate(new_tensor(i), new_mesh, trim(old_tensor%name)) - call zero(new_tensor(i)) - call insert(new_state, new_tensor(i), trim(old_tensor%name)) - call deallocate(new_tensor(i)) - end do - - call vtk_write_state("new_state", 0, state=(/new_state/)) - call linear_interpolation(state, new_state) - - deallocate(pos) - deallocate(ipf) - deallocate(ipe) - deallocate(ipv) - deallocate(parcrv) - deallocate(iFnc) - deallocate(lbE) - deallocate(rW) - deallocate(iW) - deallocate(tmp_metric) - - call deallocate(state) - state = new_state + call incrementeventcounter(EVENT_ADAPTIVITY) + call incrementeventcounter(EVENT_MESH_MOVEMENT) + + ! Hooray! You didn't crash. Congratulations. Now let's assemble the output and interpolate. + + call allocate(new_mesh, nonods, totele, ele_shape(xmesh, 1), "Mesh") + new_mesh%ndglno = reshape(IPE(:, 1:totele), (/size(new_mesh%ndglno)/)) + call insert(new_state, new_mesh, "Mesh") + call deallocate(new_mesh) + + call allocate(new_positions, 2, new_mesh, "Coordinate") + call set_all(new_positions, pos(:, 1:nonods)) + call snap_positions(positions, new_positions) + call insert(new_state, new_positions, "Coordinate") + call deallocate(new_positions) + + do i=1,scalar_field_count(state) + old_scalar => extract_scalar_field(state, i) + call allocate(new_scalar(i), new_mesh, trim(old_scalar%name)) + call zero(new_scalar(i)) + call insert(new_state, new_scalar(i), trim(old_scalar%name)) + call deallocate(new_scalar(i)) + end do + + j = 1 + do i=1,vector_field_count(state) + old_vector => extract_vector_field(state, i) + if (trim(old_vector%name) == "Coordinate") then + cycle + end if + call allocate(new_vector(j), 2, new_mesh, trim(old_vector%name)) + call zero(new_vector(j)) + call insert(new_state, new_vector(j), trim(old_vector%name)) + call deallocate(new_vector(j)) + j = j + 1 + end do + + do i=1,tensor_field_count(state) + old_tensor => extract_tensor_field(state, i) + call allocate(new_tensor(i), new_mesh, trim(old_tensor%name)) + call zero(new_tensor(i)) + call insert(new_state, new_tensor(i), trim(old_tensor%name)) + call deallocate(new_tensor(i)) + end do + + call vtk_write_state("new_state", 0, state=(/new_state/)) + call linear_interpolation(state, new_state) + + deallocate(pos) + deallocate(ipf) + deallocate(ipe) + deallocate(ipv) + deallocate(parcrv) + deallocate(iFnc) + deallocate(lbE) + deallocate(rW) + deallocate(iW) + deallocate(tmp_metric) + + call deallocate(state) + state = new_state #else - FLExit("You called mba_adapt but haven't compiled with the mba library.") + FLExit("You called mba_adapt but haven't compiled with the mba library.") #endif - end subroutine mba_adapt - - subroutine CrvFunction_ani(tc, xyc, iFnc) - real tc, xyc(2) - integer :: iFnc - - return - end subroutine - - ! Try to snap the positions of new nodes to the positions - ! of old nodes. libmba, for example, maps domains to the - ! square [0.1, 0.9]^2. This mapping back and forth causes small - ! errors in the positions that screws up various things. - ! Let's put them back .. - ! The inputs to this are the linear topological meshes - ! created by the adaptivity library - subroutine snap_positions(old_positions, new_positions) - type(vector_field), intent(inout) :: old_positions - type(vector_field), intent(inout) :: new_positions - - real, dimension(node_count(new_positions)) :: map - integer :: node_new, ele_old, node_old, loc, i, j, dim - integer, dimension(:), pointer :: ele_nodes_old, ele_faces_old - real :: snap_dist, ele_dist - logical, dimension(node_count(old_positions)) :: used_old - integer :: face_old - real, dimension(old_positions%dim, old_positions%dim-1) :: basis - real, dimension(old_positions%dim) :: proj - - used_old = .false. - loc = ele_loc(old_positions, 1) - map = get_element_mapping(old_positions, new_positions) - dim = new_positions%dim - if (.not. has_faces(old_positions%mesh)) then - call add_faces(old_positions%mesh) - end if - - nodeloop: do node_new=1,node_count(new_positions) - ele_old = map(node_new) - ele_nodes_old => ele_nodes(old_positions, ele_old) - ele_faces_old => ele_faces(old_positions, ele_old) - ele_dist = huge(0.0) - do i=1,loc - do j=i+1,loc - ele_dist = min(ele_dist, norm2(node_val(old_positions, ele_nodes_old(i)) - node_val(old_positions, ele_nodes_old(j)))) - end do - end do + end subroutine mba_adapt + + subroutine CrvFunction_ani(tc, xyc, iFnc) + real tc, xyc(2) + integer :: iFnc + + return + end subroutine + + ! Try to snap the positions of new nodes to the positions + ! of old nodes. libmba, for example, maps domains to the + ! square [0.1, 0.9]^2. This mapping back and forth causes small + ! errors in the positions that screws up various things. + ! Let's put them back .. + ! The inputs to this are the linear topological meshes + ! created by the adaptivity library + subroutine snap_positions(old_positions, new_positions) + type(vector_field), intent(inout) :: old_positions + type(vector_field), intent(inout) :: new_positions + + real, dimension(node_count(new_positions)) :: map + integer :: node_new, ele_old, node_old, loc, i, j, dim + integer, dimension(:), pointer :: ele_nodes_old, ele_faces_old + real :: snap_dist, ele_dist + logical, dimension(node_count(old_positions)) :: used_old + integer :: face_old + real, dimension(old_positions%dim, old_positions%dim-1) :: basis + real, dimension(old_positions%dim) :: proj + + used_old = .false. + loc = ele_loc(old_positions, 1) + map = get_element_mapping(old_positions, new_positions) + dim = new_positions%dim + if (.not. has_faces(old_positions%mesh)) then + call add_faces(old_positions%mesh) + end if + + nodeloop: do node_new=1,node_count(new_positions) + ele_old = map(node_new) + ele_nodes_old => ele_nodes(old_positions, ele_old) + ele_faces_old => ele_faces(old_positions, ele_old) + ele_dist = huge(0.0) + do i=1,loc + do j=i+1,loc + ele_dist = min(ele_dist, norm2(node_val(old_positions, ele_nodes_old(i)) - node_val(old_positions, ele_nodes_old(j)))) + end do + end do - snap_dist = ele_dist / 1.0e3 + snap_dist = ele_dist / 1.0e3 - ! Snap to nodes - do i=1,loc - node_old = ele_nodes_old(i) - if (norm2(node_val(new_positions, node_new) - node_val(old_positions, node_old)) < snap_dist .and. .not. used_old(node_old)) then - used_old(node_old) = .true. - do j=1,dim - new_positions%val(j,node_new) = old_positions%val(j,node_old) - end do - cycle nodeloop - end if + ! Snap to nodes + do i=1,loc + node_old = ele_nodes_old(i) + if (norm2(node_val(new_positions, node_new) - node_val(old_positions, node_old)) < snap_dist .and. .not. used_old(node_old)) then + used_old(node_old) = .true. + do j=1,dim + new_positions%val(j,node_new) = old_positions%val(j,node_old) + end do + cycle nodeloop + end if - end do + end do - ! Snap to faces - do i=1,loc - face_old = ele_faces_old(i) - basis = face_basis(old_positions, face_old) - proj = project_to_subspace(node_val(new_positions, node_new), basis) - if (norm2(node_val(new_positions, node_new) - proj) < snap_dist) then - do j=1,dim - new_positions%val(j,node_new) = proj(j) + ! Snap to faces + do i=1,loc + face_old = ele_faces_old(i) + basis = face_basis(old_positions, face_old) + proj = project_to_subspace(node_val(new_positions, node_new), basis) + if (norm2(node_val(new_positions, node_new) - proj) < snap_dist) then + do j=1,dim + new_positions%val(j,node_new) = proj(j) + end do + cycle nodeloop + end if end do - cycle nodeloop - end if - end do - end do nodeloop - end subroutine snap_positions - - ! Get the basis of the subspace containing the face of an element -- only works - ! for linear positions. - function face_basis(positions, face) result(basis) - type(vector_field), intent(in) :: positions - integer, intent(in) :: face - real, dimension(positions%dim, positions%dim-1) :: basis - - real, dimension(positions%dim, face_loc(positions, face)) :: pos - integer :: i, j - real, dimension(positions%dim) :: tmp_vec - integer :: dim - - dim = positions%dim - - pos = face_val(positions, face) - - ! Get edge vectors and normalise - do i=1,dim-1 - basis(:, i) = pos(:, i) - pos(:, i+1) - basis(:, i) = basis(:, i) / norm2(basis(:, i)) - end do - - ! Orthogonalise - if (dim > 2) then - do i=2,dim - tmp_vec = basis(:, i) - do j=1,i-1 - tmp_vec = tmp_vec - (dot_product(basis(:, j), tmp_vec) * basis(:, j)) - end do - basis(:, i) = tmp_vec / norm2(tmp_vec) + end do nodeloop + end subroutine snap_positions + + ! Get the basis of the subspace containing the face of an element -- only works + ! for linear positions. + function face_basis(positions, face) result(basis) + type(vector_field), intent(in) :: positions + integer, intent(in) :: face + real, dimension(positions%dim, positions%dim-1) :: basis + + real, dimension(positions%dim, face_loc(positions, face)) :: pos + integer :: i, j + real, dimension(positions%dim) :: tmp_vec + integer :: dim + + dim = positions%dim + + pos = face_val(positions, face) + + ! Get edge vectors and normalise + do i=1,dim-1 + basis(:, i) = pos(:, i) - pos(:, i+1) + basis(:, i) = basis(:, i) / norm2(basis(:, i)) end do - end if - call check_basis(basis) - end function face_basis + ! Orthogonalise + if (dim > 2) then + do i=2,dim + tmp_vec = basis(:, i) + do j=1,i-1 + tmp_vec = tmp_vec - (dot_product(basis(:, j), tmp_vec) * basis(:, j)) + end do + basis(:, i) = tmp_vec / norm2(tmp_vec) + end do + end if + + call check_basis(basis) + end function face_basis end module mba_adapt_module diff --git a/error_measures/Metric_advection.F90 b/error_measures/Metric_advection.F90 index 4fc91e0c7f..9b91e0ecd6 100644 --- a/error_measures/Metric_advection.F90 +++ b/error_measures/Metric_advection.F90 @@ -28,772 +28,772 @@ module metric_advection - use fldebug - use vector_tools - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str - use elements - use spud - use parallel_tools - use sparse_tools - use shape_functions - use cv_faces - use transform_elements - use fetools - use unittest_tools - use fields - use state_module - use vtk_interfaces - use sparse_matrices_fields - use solvers - use boundary_conditions - use merge_tensors - use edge_length_module - use sparsity_patterns - use cv_shape_functions - use field_options, only: get_coordinate_field - use cvtools - use cv_options - use cv_upwind_values - use cv_face_values, only: theta_val, evaluate_face_val - use sparsity_patterns_meshes - use fefields, only: compute_cv_mass - use state_fields_module, only: get_cv_mass - use diagnostic_variables, only: field_tag - use diagnostic_fields, only: calculate_diagnostic_variable - use form_metric_field - use populate_state_module - use adaptive_timestepping - - implicit none - - private - public :: form_advection_metric, initialise_metric_advection, use_metric_advection - - logical :: use_metric_advection + use fldebug + use vector_tools + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str + use elements + use spud + use parallel_tools + use sparse_tools + use shape_functions + use cv_faces + use transform_elements + use fetools + use unittest_tools + use fields + use state_module + use vtk_interfaces + use sparse_matrices_fields + use solvers + use boundary_conditions + use merge_tensors + use edge_length_module + use sparsity_patterns + use cv_shape_functions + use field_options, only: get_coordinate_field + use cvtools + use cv_options + use cv_upwind_values + use cv_face_values, only: theta_val, evaluate_face_val + use sparsity_patterns_meshes + use fefields, only: compute_cv_mass + use state_fields_module, only: get_cv_mass + use diagnostic_variables, only: field_tag + use diagnostic_fields, only: calculate_diagnostic_variable + use form_metric_field + use populate_state_module + use adaptive_timestepping + + implicit none + + private + public :: form_advection_metric, initialise_metric_advection, use_metric_advection + + logical :: use_metric_advection contains - subroutine initialise_metric_advection - if (have_option("/mesh_adaptivity/hr_adaptivity/metric_advection")) then - use_metric_advection = .true. - else - use_metric_advection = .false. - end if - end subroutine initialise_metric_advection - - function expand_idx(i, j, dim) result(k) - integer, intent(in) :: i, j, dim - integer :: k - - k = i + dim * (j - 1) - end function expand_idx - - subroutine form_advection_metric(tfield, state) - !! Name of the field to be solved for. - type(tensor_field), intent(inout) :: tfield - !! Collection of fields defining system state. - type(state_type), intent(inout) :: state - - ! Coordinate field - type(vector_field), pointer :: x - type(vector_field) :: x_tfield - - - ! LHS equation matrix. - type(csr_matrix) :: M, A_m - ! sparsity structure to construct the matrices with - type(csr_sparsity), pointer :: mesh_sparsity - - ! Change in tfield over one timestep. - ! Right hand side vector, cv mass matrix, - ! locally iterated field (for advection iterations) - ! and local old field (for subcycling) - type(tensor_field) :: rhs, advit_tfield, delta_tfield, accum_tfield - type(tensor_field) :: l_tfield, tmp_tfield - type(scalar_field), pointer :: t_cvmass - type(scalar_field) :: cvmass - - ! local copy of option_path for solution field - character(len=OPTION_PATH_LEN) :: option_path - - ! number of advection iterations and subcycles - integer :: rk_iterations, adv_iterations, no_subcycles - ! iterators - integer :: rk_it, adv_it, i, sub, j, period_in_timesteps - ! time (to output to file), timestep, iterations tolerance, subcycling timestep - real :: actual_dt, adapt_dt, sub_dt - real :: max_cfl, scale_adv - - ! degree of quadrature to use on each control volume face - integer :: quaddegree - ! control volume face information - type(cv_faces_type) :: cvfaces - ! control volume shape function for volume and boundary - type(element_type) :: u_cvshape, u_cvbdyshape - type(element_type) :: x_cvshape, x_cvbdyshape - type(element_type) :: t_cvshape, t_cvbdyshape - - ! options wrappers for tfield - type(cv_options_type) :: tfield_options - - ! success indicators? - integer :: stat - ! type of courant number we want to use - character(len=FIELD_NAME_LEN) :: cfl_type - ! the courant number field - type(scalar_field) :: cfl_no - ! nonlinear and grid velocities - type(vector_field), pointer :: nu, ug - ! relative velocity - type(vector_field) :: relu - ! assume explicitness? - logical :: explicit - ! if we're subcycling how fast can we go? - real :: max_sub_cfl - ! construct the matrices - logical :: getmat - - logical :: output_subcycle_vtus, output_final_vtus - type(scalar_field) :: edgelen - integer, save :: adaptcnt = 0 - - ewrite(1,*) 'in metric advection' - - ! extract lots of fields: - ! the actual thing we're trying to solve for - option_path="/mesh_adaptivity/hr_adaptivity/metric_advection" - - ! now we can get the options for these fields - ! handily wrapped in a new type... - tfield_options=get_cv_options(option_path, tfield%mesh%shape%numbering%family, mesh_dim(tfield)) - - output_subcycle_vtus = have_option(trim(option_path)//"/output/output_subcycle_vtus") - output_final_vtus = have_option(trim(option_path)//"/output/output_final_vtus") - - ! extract fields from state - nu=>extract_vector_field(state, "NonlinearVelocity") - ug=>extract_vector_field(state, "GridVelocity") - x=>extract_vector_field(state, "Coordinate") - x_tfield = get_coordinate_field(state, tfield%mesh) - - ! find relative velocity - call allocate(relu, nu%dim, nu%mesh, "RelativeVelocity") - call set(relu, nu) - call addto(relu, ug, -1.0) - - if(output_subcycle_vtus.or.output_final_vtus) then - call allocate(edgelen, tfield%mesh, "Edge lengths") - end if - - ! create control volume shape functions - call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) - cvfaces=find_cv_faces(vertices=ele_vertices(tfield, 1), & - dimension=tfield%mesh%shape%dim, & - polydegree=tfield%mesh%shape%degree, & - quaddegree=quaddegree) - u_cvshape=make_cv_element_shape(cvfaces, nu%mesh%shape) - x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) - t_cvshape=make_cv_element_shape(cvfaces, tfield%mesh%shape) - u_cvbdyshape=make_cvbdy_element_shape(cvfaces, nu%mesh%faces%shape) - x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) - t_cvbdyshape=make_cvbdy_element_shape(cvfaces, tfield%mesh%faces%shape) - - ! get the mesh sparsity for the matrices - mesh_sparsity=>get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) - - ! allocate the lhs matrix - call allocate(M, mesh_sparsity, name="MetricMatrix") - call allocate(A_m, mesh_sparsity, name="MetricAdvectionMatrix") - - ! allocate the rhs of the equation - call allocate(rhs, tfield%mesh, name="MetricAdvectionRHS") - - ! allocate a field to store the subcycling iterations in - call allocate(l_tfield, tfield%mesh, name="LocalMetric") - call set(l_tfield, tfield) - ! allocate a field to use to merge with the main field - call allocate(tmp_tfield, tfield%mesh, name="TempMetric") - call zero(tmp_tfield) - ! allocate a field to store the locally iterated values in - call allocate(advit_tfield, tfield%mesh, name="AdvIteratedMetric") - call set(advit_tfield, tfield) - ! allocate a field to store the accumulated Runge-Kutta slope in - call allocate(accum_tfield, tfield%mesh, name="AccumAdvectedMetric") - call zero(accum_tfield) - ! allocate a field to store the change between the old and new values - call allocate(delta_tfield, tfield%mesh, name="Delta_Metric") - call zero(delta_tfield) ! Impose zero initial guess. - ! Ensure delta_tfield inherits options from mesh_adaptivity - delta_tfield%option_path = option_path - - explicit = have_option(trim(option_path)//"/explicit") - - ! find out how many iterations we'll be doing - rk_iterations =1 -! ! Runge-Kutta 4 -! rk_iterations = 4 + subroutine initialise_metric_advection + if (have_option("/mesh_adaptivity/hr_adaptivity/metric_advection")) then + use_metric_advection = .true. + else + use_metric_advection = .false. + end if + end subroutine initialise_metric_advection + + function expand_idx(i, j, dim) result(k) + integer, intent(in) :: i, j, dim + integer :: k + + k = i + dim * (j - 1) + end function expand_idx + + subroutine form_advection_metric(tfield, state) + !! Name of the field to be solved for. + type(tensor_field), intent(inout) :: tfield + !! Collection of fields defining system state. + type(state_type), intent(inout) :: state + + ! Coordinate field + type(vector_field), pointer :: x + type(vector_field) :: x_tfield + + + ! LHS equation matrix. + type(csr_matrix) :: M, A_m + ! sparsity structure to construct the matrices with + type(csr_sparsity), pointer :: mesh_sparsity + + ! Change in tfield over one timestep. + ! Right hand side vector, cv mass matrix, + ! locally iterated field (for advection iterations) + ! and local old field (for subcycling) + type(tensor_field) :: rhs, advit_tfield, delta_tfield, accum_tfield + type(tensor_field) :: l_tfield, tmp_tfield + type(scalar_field), pointer :: t_cvmass + type(scalar_field) :: cvmass + + ! local copy of option_path for solution field + character(len=OPTION_PATH_LEN) :: option_path + + ! number of advection iterations and subcycles + integer :: rk_iterations, adv_iterations, no_subcycles + ! iterators + integer :: rk_it, adv_it, i, sub, j, period_in_timesteps + ! time (to output to file), timestep, iterations tolerance, subcycling timestep + real :: actual_dt, adapt_dt, sub_dt + real :: max_cfl, scale_adv + + ! degree of quadrature to use on each control volume face + integer :: quaddegree + ! control volume face information + type(cv_faces_type) :: cvfaces + ! control volume shape function for volume and boundary + type(element_type) :: u_cvshape, u_cvbdyshape + type(element_type) :: x_cvshape, x_cvbdyshape + type(element_type) :: t_cvshape, t_cvbdyshape + + ! options wrappers for tfield + type(cv_options_type) :: tfield_options + + ! success indicators? + integer :: stat + ! type of courant number we want to use + character(len=FIELD_NAME_LEN) :: cfl_type + ! the courant number field + type(scalar_field) :: cfl_no + ! nonlinear and grid velocities + type(vector_field), pointer :: nu, ug + ! relative velocity + type(vector_field) :: relu + ! assume explicitness? + logical :: explicit + ! if we're subcycling how fast can we go? + real :: max_sub_cfl + ! construct the matrices + logical :: getmat + + logical :: output_subcycle_vtus, output_final_vtus + type(scalar_field) :: edgelen + integer, save :: adaptcnt = 0 + + ewrite(1,*) 'in metric advection' + + ! extract lots of fields: + ! the actual thing we're trying to solve for + option_path="/mesh_adaptivity/hr_adaptivity/metric_advection" + + ! now we can get the options for these fields + ! handily wrapped in a new type... + tfield_options=get_cv_options(option_path, tfield%mesh%shape%numbering%family, mesh_dim(tfield)) + + output_subcycle_vtus = have_option(trim(option_path)//"/output/output_subcycle_vtus") + output_final_vtus = have_option(trim(option_path)//"/output/output_final_vtus") + + ! extract fields from state + nu=>extract_vector_field(state, "NonlinearVelocity") + ug=>extract_vector_field(state, "GridVelocity") + x=>extract_vector_field(state, "Coordinate") + x_tfield = get_coordinate_field(state, tfield%mesh) + + ! find relative velocity + call allocate(relu, nu%dim, nu%mesh, "RelativeVelocity") + call set(relu, nu) + call addto(relu, ug, -1.0) + + if(output_subcycle_vtus.or.output_final_vtus) then + call allocate(edgelen, tfield%mesh, "Edge lengths") + end if - call get_option(trim(option_path)//"/temporal_discretisation& - &/control_volumes/number_advection_iterations", & - adv_iterations, default=1) - - ! get the timestep information - call get_option("/timestepping/timestep", actual_dt) - call get_option("/mesh_adaptivity/hr_adaptivity/period", adapt_dt, stat) - if (stat /= 0) then - call get_option("/mesh_adaptivity/hr_adaptivity/period_in_timesteps", period_in_timesteps) - adapt_dt = period_in_timesteps * actual_dt - end if - - call get_option(trim(option_path)//"/temporal_discretisation& - &/scale_advection_time", scale_adv, default=1.1) - adapt_dt = adapt_dt*scale_adv - - no_subcycles = 1 - ! are we subcycling? - call get_option(trim(option_path)//"/temporal_discretisation& - &/number_advection_subcycles", no_subcycles, stat=stat) - if(stat/=0) then - ! have not specified a number of subcycles but perhaps we're using a - ! courant number definition? - call get_option(trim(option_path)//"/temporal_discretisation/maximum_courant_number_per_subcycle", & - max_sub_cfl) - call get_option(trim(option_path)//"/temporal_discretisation/maximum_courant_number_per_subcycle/courant_number[0]/name", cfl_type) - call allocate(cfl_no, tfield%mesh, "CourantNumber") - call calculate_diagnostic_variable(state, trim(cfl_type), cfl_no, dt=adapt_dt, & - & option_path=trim(option_path)//"/temporal_discretisation/maximum_courant_number_per_subcycle/courant_number[0]") - max_cfl = maxval(cfl_no%val) - call allmax(max_cfl) - ewrite(2,*) "max_cfl = ", max_cfl - call deallocate(cfl_no) + ! create control volume shape functions + call get_option("/geometry/quadrature/controlvolume_surface_degree", & + quaddegree, default=1) + cvfaces=find_cv_faces(vertices=ele_vertices(tfield, 1), & + dimension=tfield%mesh%shape%dim, & + polydegree=tfield%mesh%shape%degree, & + quaddegree=quaddegree) + u_cvshape=make_cv_element_shape(cvfaces, nu%mesh%shape) + x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) + t_cvshape=make_cv_element_shape(cvfaces, tfield%mesh%shape) + u_cvbdyshape=make_cvbdy_element_shape(cvfaces, nu%mesh%faces%shape) + x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) + t_cvbdyshape=make_cvbdy_element_shape(cvfaces, tfield%mesh%faces%shape) + + ! get the mesh sparsity for the matrices + mesh_sparsity=>get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) + + ! allocate the lhs matrix + call allocate(M, mesh_sparsity, name="MetricMatrix") + call allocate(A_m, mesh_sparsity, name="MetricAdvectionMatrix") + + ! allocate the rhs of the equation + call allocate(rhs, tfield%mesh, name="MetricAdvectionRHS") + + ! allocate a field to store the subcycling iterations in + call allocate(l_tfield, tfield%mesh, name="LocalMetric") + call set(l_tfield, tfield) + ! allocate a field to use to merge with the main field + call allocate(tmp_tfield, tfield%mesh, name="TempMetric") + call zero(tmp_tfield) + ! allocate a field to store the locally iterated values in + call allocate(advit_tfield, tfield%mesh, name="AdvIteratedMetric") + call set(advit_tfield, tfield) + ! allocate a field to store the accumulated Runge-Kutta slope in + call allocate(accum_tfield, tfield%mesh, name="AccumAdvectedMetric") + call zero(accum_tfield) + ! allocate a field to store the change between the old and new values + call allocate(delta_tfield, tfield%mesh, name="Delta_Metric") + call zero(delta_tfield) ! Impose zero initial guess. + ! Ensure delta_tfield inherits options from mesh_adaptivity + delta_tfield%option_path = option_path + + explicit = have_option(trim(option_path)//"/explicit") - no_subcycles=ceiling(max_cfl/max_sub_cfl) - end if + ! find out how many iterations we'll be doing + rk_iterations =1 +! ! Runge-Kutta 4 +! rk_iterations = 4 - sub_dt=adapt_dt/real(no_subcycles) + call get_option(trim(option_path)//"/temporal_discretisation& + &/control_volumes/number_advection_iterations", & + adv_iterations, default=1) - ! find the cv mass that is used for the time term derivative - t_cvmass => get_cv_mass(state, tfield%mesh) - ewrite_minmax(t_cvmass) + ! get the timestep information + call get_option("/timestepping/timestep", actual_dt) + call get_option("/mesh_adaptivity/hr_adaptivity/period", adapt_dt, stat) + if (stat /= 0) then + call get_option("/mesh_adaptivity/hr_adaptivity/period_in_timesteps", period_in_timesteps) + adapt_dt = period_in_timesteps * actual_dt + end if - call allocate(cvmass, tfield%mesh, "LocalCVMass") - call set(cvmass, t_cvmass) - ewrite_minmax(cvmass) + call get_option(trim(option_path)//"/temporal_discretisation& + &/scale_advection_time", scale_adv, default=1.1) + adapt_dt = adapt_dt*scale_adv + + no_subcycles = 1 + ! are we subcycling? + call get_option(trim(option_path)//"/temporal_discretisation& + &/number_advection_subcycles", no_subcycles, stat=stat) + if(stat/=0) then + ! have not specified a number of subcycles but perhaps we're using a + ! courant number definition? + call get_option(trim(option_path)//"/temporal_discretisation/maximum_courant_number_per_subcycle", & + max_sub_cfl) + call get_option(trim(option_path)//"/temporal_discretisation/maximum_courant_number_per_subcycle/courant_number[0]/name", cfl_type) + call allocate(cfl_no, tfield%mesh, "CourantNumber") + call calculate_diagnostic_variable(state, trim(cfl_type), cfl_no, dt=adapt_dt, & + & option_path=trim(option_path)//"/temporal_discretisation/maximum_courant_number_per_subcycle/courant_number[0]") + max_cfl = maxval(cfl_no%val) + call allmax(max_cfl) + ewrite(2,*) "max_cfl = ", max_cfl + call deallocate(cfl_no) - ewrite(2,*) 'no_subcycles = ', no_subcycles - ewrite(2,*) 'rk_iterations = ', rk_iterations - ewrite(2,*) 'adv_iterations = ', adv_iterations - do sub=1,no_subcycles + no_subcycles=ceiling(max_cfl/max_sub_cfl) + end if - call zero(accum_tfield) + sub_dt=adapt_dt/real(no_subcycles) + + ! find the cv mass that is used for the time term derivative + t_cvmass => get_cv_mass(state, tfield%mesh) + ewrite_minmax(t_cvmass) + + call allocate(cvmass, tfield%mesh, "LocalCVMass") + call set(cvmass, t_cvmass) + ewrite_minmax(cvmass) + + ewrite(2,*) 'no_subcycles = ', no_subcycles + ewrite(2,*) 'rk_iterations = ', rk_iterations + ewrite(2,*) 'adv_iterations = ', adv_iterations + do sub=1,no_subcycles + + call zero(accum_tfield) + + do rk_it = 1, rk_iterations + + do adv_it = 1, adv_iterations + getmat=(adv_it==1).and.(sub==1).and.(rk_it==1) + + ! record the value of tfield since the previous iteration + + if(explicit) then + call set(cvmass, t_cvmass) + else + call zero(M) + call addto_diag(M, t_cvmass) + end if + call zero(rhs) + + ! If we've passed the first iteration/subcycle so we have A_m don't enter the next step. + ! Also if we're using first order upwinding (and not using a spatially varying theta + ! - limit_theta) so there's no need to assemble the + ! nonlinear rhs (assuming we've enforced pivot theta = theta as cv_options should do) + ! then just multiply things out + if(getmat.or.(tfield_options%facevalue/=CV_FACEVALUE_FIRSTORDERUPWIND).or.(tfield_options%limit_theta)) then + ! we need the matrix (probably the first iteration/subcycle) or we need + ! the nonlinear rhs (if we're not using first order upwinding) or we're + ! using a spatially varying theta that has to be multiplied into the + ! assembly... + ! so go into assembly + call assemble_advection_m_cv(A_m, rhs, & + advit_tfield, l_tfield, tfield_options, & + cvfaces, x_cvshape, x_cvbdyshape, & + u_cvshape, u_cvbdyshape, t_cvshape, t_cvbdyshape, & + state, relu, x, x_tfield, & + getmat, sub_dt, rk_it, delta_tfield) + end if + + ! assemble it all into a coherent equation + call assemble_field_eqn_cv(M, A_m, cvmass, rhs, & + advit_tfield, l_tfield, & + sub_dt, explicit, tfield_options) + + if(explicit) then + do i = 1, delta_tfield%dim(1) + do j = 1, delta_tfield%dim(2) + delta_tfield%val(i,j,:) = rhs%val(i,j,:)/cvmass%val(:) + end do + end do + else + call zero(delta_tfield) ! Impose zero initial guess. + ! Solve for the change in T. + call petsc_solve(delta_tfield, M, rhs, symmetric=.true.) + end if + + call set(advit_tfield, l_tfield) + call addto(advit_tfield, delta_tfield, sub_dt) + + end do ! advection iterations + + if(rk_iterations > 1) then + call addto(accum_tfield, delta_tfield, rk_coeff(adv_it)) + end if + + end do ! runge-kutta iterations + + if(rk_iterations>1) then + call addto(l_tfield, accum_tfield, sub_dt / 6.0) + else + call set(l_tfield, advit_tfield) + end if + + call set(tmp_tfield, l_tfield) + call merge_tensor_fields(tfield, tmp_tfield) + + if(output_subcycle_vtus) then + call get_edge_lengths(l_tfield, edgelen) + call vtk_write_fields(trim("advected_metric_subcycle_")//int2str(adaptcnt), (sub-1), x, x%mesh, & + sfields=(/edgelen/), tfields=(/l_tfield/)) + end if + + end do ! subcycle loop + + call bound_metric(tfield, state) + + if(output_final_vtus) then + call get_edge_lengths(tfield, edgelen) + call vtk_write_fields(trim("advected_metric_final"), adaptcnt, x, x%mesh, & + sfields=(/edgelen/), tfields=(/tfield/)) + end if - do rk_it = 1, rk_iterations - - do adv_it = 1, adv_iterations - getmat=(adv_it==1).and.(sub==1).and.(rk_it==1) - - ! record the value of tfield since the previous iteration - - if(explicit) then - call set(cvmass, t_cvmass) - else - call zero(M) - call addto_diag(M, t_cvmass) - end if - call zero(rhs) - - ! If we've passed the first iteration/subcycle so we have A_m don't enter the next step. - ! Also if we're using first order upwinding (and not using a spatially varying theta - ! - limit_theta) so there's no need to assemble the - ! nonlinear rhs (assuming we've enforced pivot theta = theta as cv_options should do) - ! then just multiply things out - if(getmat.or.(tfield_options%facevalue/=CV_FACEVALUE_FIRSTORDERUPWIND).or.(tfield_options%limit_theta)) then - ! we need the matrix (probably the first iteration/subcycle) or we need - ! the nonlinear rhs (if we're not using first order upwinding) or we're - ! using a spatially varying theta that has to be multiplied into the - ! assembly... - ! so go into assembly - call assemble_advection_m_cv(A_m, rhs, & - advit_tfield, l_tfield, tfield_options, & - cvfaces, x_cvshape, x_cvbdyshape, & - u_cvshape, u_cvbdyshape, t_cvshape, t_cvbdyshape, & - state, relu, x, x_tfield, & - getmat, sub_dt, rk_it, delta_tfield) - end if - - ! assemble it all into a coherent equation - call assemble_field_eqn_cv(M, A_m, cvmass, rhs, & - advit_tfield, l_tfield, & - sub_dt, explicit, tfield_options) - - if(explicit) then - do i = 1, delta_tfield%dim(1) - do j = 1, delta_tfield%dim(2) - delta_tfield%val(i,j,:) = rhs%val(i,j,:)/cvmass%val(:) - end do - end do - else - call zero(delta_tfield) ! Impose zero initial guess. - ! Solve for the change in T. - call petsc_solve(delta_tfield, M, rhs, symmetric=.true.) - end if + if(output_subcycle_vtus.or.output_final_vtus) then + adaptcnt = adaptcnt + 1 + call deallocate(edgelen) + end if - call set(advit_tfield, l_tfield) - call addto(advit_tfield, delta_tfield, sub_dt) + call deallocate(tmp_tfield) + call deallocate(l_tfield) + call deallocate(delta_tfield) + call deallocate(advit_tfield) + call deallocate(accum_tfield) + call deallocate(rhs) + call deallocate(M) + call deallocate(A_m) + call deallocate(u_cvbdyshape) + call deallocate(x_cvbdyshape) + call deallocate(t_cvbdyshape) + call deallocate(u_cvshape) + call deallocate(x_cvshape) + call deallocate(t_cvshape) + call deallocate(cvfaces) + call deallocate(relu) + call deallocate(x_tfield) + call deallocate(cvmass) + + end subroutine form_advection_metric + ! end of solution wrapping subroutines + !************************************************************************ + !************************************************************************ + ! equation wrapping subroutines + subroutine assemble_field_eqn_cv(M, A_m, cvmass, rhs, & + tfield, oldtfield, & + dt, explicit, tfield_options) + + ! This subroutine assembles the equation + ! M(T^{n+1}-T^{n})/\Delta T = rhs + ! for control volumes. + ! By the time you get here M should already contain the mass + ! components (and if back compatible the diffusional components) + ! of the equation. + + ! inputs/outputs: + ! lhs matrix + type(csr_matrix), intent(inout) :: M + ! matrix containing advective terms - to be incorporated + ! into M during this subroutine + type(csr_matrix), intent(inout) :: A_m + type(scalar_field), intent(inout) :: cvmass + ! rhs of equation + type(tensor_field), intent(inout) :: rhs + ! the field we are solving for + type(tensor_field), intent(inout) :: tfield, oldtfield + ! the timestep + real, intent(in) :: dt + ! we're explicit! + logical, intent(in) :: explicit + ! options wrappers for tfield + type(cv_options_type), intent(in) :: tfield_options + + ! local memory: + ! for all equation types: + ! product of A_m and oldtfield + type(scalar_field) :: A_mT_old + + type(scalar_field) :: oldtfield_scomp + + integer :: i, j + + ! allocate some memory for assembly + call allocate(A_mT_old, rhs%mesh, name="A_mT_oldProduct" ) + + do i=1,oldtfield%dim(1) + do j=i,oldtfield%dim(2) + ! construct rhs + oldtfield_scomp = extract_scalar_field(oldtfield, i, j) + call mult(A_mT_old, A_m, oldtfield_scomp) + call addto(rhs, i, j, A_mT_old, -1.0) + if (j /= i) then + call addto(rhs, j, i, A_mT_old, -1.0) + end if + end do + end do - end do ! advection iterations + if((tfield_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND).and.& + (.not.tfield_options%limit_theta))then + ! in this case the pivot solution is first order upwinding so + ! A_m is all we need (i.e. we assume the rhs has been zeroed) + ! also we're not using a spatially varying theta so A_m has been + ! assembled excluding it (so it needs to be multiplied in now) - if(rk_iterations > 1) then - call addto(accum_tfield, delta_tfield, rk_coeff(adv_it)) - end if + ! [M + dt*theta*A_m](T^{n+1}-T^{n})/dt = rhs - A_m*T^{n} - end do ! runge-kutta iterations + ! construct M + if(.not.explicit) then + call addto(M, A_m, tfield_options%theta*dt) + end if - if(rk_iterations>1) then - call addto(l_tfield, accum_tfield, sub_dt / 6.0) else - call set(l_tfield, advit_tfield) - end if - call set(tmp_tfield, l_tfield) - call merge_tensor_fields(tfield, tmp_tfield) + ! [M + dt*A_m](T^{n+1}-T^{n})/dt = rhs - A_m*T^{n} + + ! construct M + if(.not.explicit) then + call addto(M, A_m, dt) + end if - if(output_subcycle_vtus) then - call get_edge_lengths(l_tfield, edgelen) - call vtk_write_fields(trim("advected_metric_subcycle_")//int2str(adaptcnt), (sub-1), x, x%mesh, & - sfields=(/edgelen/), tfields=(/l_tfield/)) end if - end do ! subcycle loop - - call bound_metric(tfield, state) - - if(output_final_vtus) then - call get_edge_lengths(tfield, edgelen) - call vtk_write_fields(trim("advected_metric_final"), adaptcnt, x, x%mesh, & - sfields=(/edgelen/), tfields=(/tfield/)) - end if - - if(output_subcycle_vtus.or.output_final_vtus) then - adaptcnt = adaptcnt + 1 - call deallocate(edgelen) - end if - - call deallocate(tmp_tfield) - call deallocate(l_tfield) - call deallocate(delta_tfield) - call deallocate(advit_tfield) - call deallocate(accum_tfield) - call deallocate(rhs) - call deallocate(M) - call deallocate(A_m) - call deallocate(u_cvbdyshape) - call deallocate(x_cvbdyshape) - call deallocate(t_cvbdyshape) - call deallocate(u_cvshape) - call deallocate(x_cvshape) - call deallocate(t_cvshape) - call deallocate(cvfaces) - call deallocate(relu) - call deallocate(x_tfield) - call deallocate(cvmass) - - end subroutine form_advection_metric - ! end of solution wrapping subroutines - !************************************************************************ - !************************************************************************ - ! equation wrapping subroutines - subroutine assemble_field_eqn_cv(M, A_m, cvmass, rhs, & - tfield, oldtfield, & - dt, explicit, tfield_options) - - ! This subroutine assembles the equation - ! M(T^{n+1}-T^{n})/\Delta T = rhs - ! for control volumes. - ! By the time you get here M should already contain the mass - ! components (and if back compatible the diffusional components) - ! of the equation. - - ! inputs/outputs: - ! lhs matrix - type(csr_matrix), intent(inout) :: M - ! matrix containing advective terms - to be incorporated - ! into M during this subroutine - type(csr_matrix), intent(inout) :: A_m - type(scalar_field), intent(inout) :: cvmass - ! rhs of equation - type(tensor_field), intent(inout) :: rhs - ! the field we are solving for - type(tensor_field), intent(inout) :: tfield, oldtfield - ! the timestep - real, intent(in) :: dt - ! we're explicit! - logical, intent(in) :: explicit - ! options wrappers for tfield - type(cv_options_type), intent(in) :: tfield_options - - ! local memory: - ! for all equation types: - ! product of A_m and oldtfield - type(scalar_field) :: A_mT_old - - type(scalar_field) :: oldtfield_scomp - - integer :: i, j - - ! allocate some memory for assembly - call allocate(A_mT_old, rhs%mesh, name="A_mT_oldProduct" ) - - do i=1,oldtfield%dim(1) - do j=i,oldtfield%dim(2) - ! construct rhs - oldtfield_scomp = extract_scalar_field(oldtfield, i, j) - call mult(A_mT_old, A_m, oldtfield_scomp) - call addto(rhs, i, j, A_mT_old, -1.0) - if (j /= i) then - call addto(rhs, j, i, A_mT_old, -1.0) - end if - end do - end do + call deallocate(A_mT_old) + + end subroutine assemble_field_eqn_cv + + !************************************************************************ + !************************************************************************ + ! assembly subroutines + subroutine assemble_advection_m_cv(A_m, rhs, & + tfield, oldtfield, tfield_options, & + cvfaces, x_cvshape, x_cvbdyshape, & + u_cvshape, u_cvbdyshape, t_cvshape, t_cvbdyshape, & + state, relu, x, x_tfield, getmat, dt, rk_it, delta_tfield) + + ! This subroutine assembles the advection matrix and rhs for + ! control volume field equations such that: + ! A_m = div(\rho u T) - (1-beta)*T*div(\rho u) + + ! inputs/outputs: + ! the advection matrix + type(csr_matrix), intent(inout) :: A_m + ! the rhs of the control volume field eqn + type(tensor_field), intent(inout) :: rhs + + ! the field being solved for + type(tensor_field), intent(inout), target :: tfield + ! previous time level of the field being solved for + type(tensor_field), intent(inout) :: oldtfield, delta_tfield + ! a type containing all the tfield options + type(cv_options_type), intent(in) :: tfield_options + + ! information about cv faces + type(cv_faces_type), intent(in) :: cvfaces + ! shape functions for region and surface + type(element_type), intent(in) :: x_cvshape, x_cvbdyshape + type(element_type), intent(in) :: u_cvshape, u_cvbdyshape + type(element_type), intent(in) :: t_cvshape, t_cvbdyshape + ! bucket full of fields + type(state_type), intent(inout) :: state + ! the relative velocity + type(vector_field), intent(in) :: relu + ! the coordinates + type(vector_field), intent(inout) :: x, x_tfield + ! logical indicating if the matrix should be constructed + ! or if it exists already from a previous iteration + logical, intent(in) :: getmat + ! timestep + real, intent(in) :: dt + ! which runge kutta iteration are we on + integer, intent(in) :: rk_it + + ! local memory: + ! allocatable memory for coordinates, velocity, normals, determinants, nodes + ! and the cfl number at the gauss pts and nodes + real, dimension(:,:), allocatable :: x_ele + real, dimension(:,:), allocatable :: x_f, u_f + real, dimension(:,:), allocatable :: normal + real, dimension(:), allocatable :: detwei + real, dimension(:), allocatable :: normgi + integer, dimension(:), pointer :: nodes, x_nodes, upwind_nodes + real, dimension(:), allocatable :: cfl_ele + + ! allocatable memory for the values of the field at the nodes + ! and on the boundary + real, dimension(:), allocatable :: tfield_ele, oldtfield_ele + + ! some memory used in assembly of the face values + real :: tfield_theta_val, tfield_pivot_val + real :: tfield_face_val, oldtfield_face_val + + ! logical array indicating if a face has already been visited by the opposing node + logical, dimension(:), allocatable :: notvisited + + ! loop integers + integer :: ele, iloc, oloc, face, gi, ggi + + + ! mesh sparsity for upwind value matrices + type(csr_sparsity), pointer :: mesh_sparsity + ! upwind value matrices for the fields and densities + type(csr_matrix) :: tfield_upwind, & + oldtfield_upwind + + ! incoming or outgoing flow + real :: udotn, income + logical :: inflow + ! time and face discretisation + real :: ptheta, ftheta, beta + + type(scalar_field) :: tfield_scomp, oldtfield_scomp + + real, dimension(:,:), allocatable :: mat_local + real, dimension(:,:,:), allocatable :: rhs_local + + integer :: i, j, dimi, dimj + + ewrite(2,*) 'assemble_advection_m_cv' + + ! allocate upwind value matrices + mesh_sparsity=>get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) + + call allocate(tfield_upwind, mesh_sparsity, name="TFieldUpwindValues") + call allocate(oldtfield_upwind, mesh_sparsity, name="OldTFieldUpwindValues") + + ! allocate memory for assembly + allocate(x_ele(x%dim,ele_loc(x,1)), & + x_f(x%dim, x_cvshape%ngi), & + u_f(relu%dim, u_cvshape%ngi), & + detwei(x_cvshape%ngi), & + normal(x%dim, x_cvshape%ngi), & + normgi(x%dim)) + allocate(cfl_ele(ele_loc(tfield,1)), & + tfield_ele(ele_loc(tfield,1)), & + oldtfield_ele(ele_loc(oldtfield,1))) + allocate(notvisited(x_cvshape%ngi)) + allocate(mat_local(ele_loc(tfield,1), ele_loc(tfield,1)), & + rhs_local(tfield%dim(1), tfield%dim(2), ele_loc(tfield,1))) + + ! Clear memory of arrays being designed + if(getmat) call zero(A_m) + + if((tfield_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND).and.& + (.not.tfield_options%limit_theta))then + dimi = 1 + dimj = 1 + else + dimi = tfield%dim(1) + dimj = tfield%dim(2) + end if - if((tfield_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND).and.& - (.not.tfield_options%limit_theta))then - ! in this case the pivot solution is first order upwinding so - ! A_m is all we need (i.e. we assume the rhs has been zeroed) - ! also we're not using a spatially varying theta so A_m has been - ! assembled excluding it (so it needs to be multiplied in now) + do i=1,dimi + do j=i,dimj - ! [M + dt*theta*A_m](T^{n+1}-T^{n})/dt = rhs - A_m*T^{n} + tfield_scomp = extract_scalar_field(tfield, i, j) + oldtfield_scomp = extract_scalar_field(oldtfield, i, j) - ! construct M - if(.not.explicit) then - call addto(M, A_m, tfield_options%theta*dt) - end if + ! does the field need upwind values + if(need_upwind_values(tfield_options)) then - else + call find_upwind_values(state, x_tfield, tfield_scomp, tfield_upwind, & + oldtfield_scomp, oldtfield_upwind, & + option_path=trim(tfield%option_path)) - ! [M + dt*A_m](T^{n+1}-T^{n})/dt = rhs - A_m*T^{n} + else - ! construct M - if(.not.explicit) then - call addto(M, A_m, dt) - end if + call zero(tfield_upwind) + call zero(oldtfield_upwind) - end if - - call deallocate(A_mT_old) - - end subroutine assemble_field_eqn_cv - - !************************************************************************ - !************************************************************************ - ! assembly subroutines - subroutine assemble_advection_m_cv(A_m, rhs, & - tfield, oldtfield, tfield_options, & - cvfaces, x_cvshape, x_cvbdyshape, & - u_cvshape, u_cvbdyshape, t_cvshape, t_cvbdyshape, & - state, relu, x, x_tfield, getmat, dt, rk_it, delta_tfield) - - ! This subroutine assembles the advection matrix and rhs for - ! control volume field equations such that: - ! A_m = div(\rho u T) - (1-beta)*T*div(\rho u) - - ! inputs/outputs: - ! the advection matrix - type(csr_matrix), intent(inout) :: A_m - ! the rhs of the control volume field eqn - type(tensor_field), intent(inout) :: rhs - - ! the field being solved for - type(tensor_field), intent(inout), target :: tfield - ! previous time level of the field being solved for - type(tensor_field), intent(inout) :: oldtfield, delta_tfield - ! a type containing all the tfield options - type(cv_options_type), intent(in) :: tfield_options - - ! information about cv faces - type(cv_faces_type), intent(in) :: cvfaces - ! shape functions for region and surface - type(element_type), intent(in) :: x_cvshape, x_cvbdyshape - type(element_type), intent(in) :: u_cvshape, u_cvbdyshape - type(element_type), intent(in) :: t_cvshape, t_cvbdyshape - ! bucket full of fields - type(state_type), intent(inout) :: state - ! the relative velocity - type(vector_field), intent(in) :: relu - ! the coordinates - type(vector_field), intent(inout) :: x, x_tfield - ! logical indicating if the matrix should be constructed - ! or if it exists already from a previous iteration - logical, intent(in) :: getmat - ! timestep - real, intent(in) :: dt - ! which runge kutta iteration are we on - integer, intent(in) :: rk_it - - ! local memory: - ! allocatable memory for coordinates, velocity, normals, determinants, nodes - ! and the cfl number at the gauss pts and nodes - real, dimension(:,:), allocatable :: x_ele - real, dimension(:,:), allocatable :: x_f, u_f - real, dimension(:,:), allocatable :: normal - real, dimension(:), allocatable :: detwei - real, dimension(:), allocatable :: normgi - integer, dimension(:), pointer :: nodes, x_nodes, upwind_nodes - real, dimension(:), allocatable :: cfl_ele - - ! allocatable memory for the values of the field at the nodes - ! and on the boundary - real, dimension(:), allocatable :: tfield_ele, oldtfield_ele - - ! some memory used in assembly of the face values - real :: tfield_theta_val, tfield_pivot_val - real :: tfield_face_val, oldtfield_face_val - - ! logical array indicating if a face has already been visited by the opposing node - logical, dimension(:), allocatable :: notvisited - - ! loop integers - integer :: ele, iloc, oloc, face, gi, ggi - - - ! mesh sparsity for upwind value matrices - type(csr_sparsity), pointer :: mesh_sparsity - ! upwind value matrices for the fields and densities - type(csr_matrix) :: tfield_upwind, & - oldtfield_upwind - - ! incoming or outgoing flow - real :: udotn, income - logical :: inflow - ! time and face discretisation - real :: ptheta, ftheta, beta - - type(scalar_field) :: tfield_scomp, oldtfield_scomp - - real, dimension(:,:), allocatable :: mat_local - real, dimension(:,:,:), allocatable :: rhs_local - - integer :: i, j, dimi, dimj - - ewrite(2,*) 'assemble_advection_m_cv' - - ! allocate upwind value matrices - mesh_sparsity=>get_csr_sparsity_firstorder(state, tfield%mesh, tfield%mesh) - - call allocate(tfield_upwind, mesh_sparsity, name="TFieldUpwindValues") - call allocate(oldtfield_upwind, mesh_sparsity, name="OldTFieldUpwindValues") - - ! allocate memory for assembly - allocate(x_ele(x%dim,ele_loc(x,1)), & - x_f(x%dim, x_cvshape%ngi), & - u_f(relu%dim, u_cvshape%ngi), & - detwei(x_cvshape%ngi), & - normal(x%dim, x_cvshape%ngi), & - normgi(x%dim)) - allocate(cfl_ele(ele_loc(tfield,1)), & - tfield_ele(ele_loc(tfield,1)), & - oldtfield_ele(ele_loc(oldtfield,1))) - allocate(notvisited(x_cvshape%ngi)) - allocate(mat_local(ele_loc(tfield,1), ele_loc(tfield,1)), & - rhs_local(tfield%dim(1), tfield%dim(2), ele_loc(tfield,1))) - - ! Clear memory of arrays being designed - if(getmat) call zero(A_m) - - if((tfield_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND).and.& - (.not.tfield_options%limit_theta))then - dimi = 1 - dimj = 1 - else - dimi = tfield%dim(1) - dimj = tfield%dim(2) - end if - - do i=1,dimi - do j=i,dimj - - tfield_scomp = extract_scalar_field(tfield, i, j) - oldtfield_scomp = extract_scalar_field(oldtfield, i, j) - - ! does the field need upwind values - if(need_upwind_values(tfield_options)) then - - call find_upwind_values(state, x_tfield, tfield_scomp, tfield_upwind, & - oldtfield_scomp, oldtfield_upwind, & - option_path=trim(tfield%option_path)) - - else - - call zero(tfield_upwind) - call zero(oldtfield_upwind) - - end if - - ! some temporal discretisation options for clarity - ptheta = tfield_options%ptheta - beta = tfield_options%beta - - ! loop over elements - do ele=1, element_count(tfield) - x_ele=ele_val(x, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - u_f=ele_val_at_quad(relu, ele, u_cvshape) - nodes=>ele_nodes(tfield, ele) - x_nodes=>ele_nodes(x_tfield, ele) - if((tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& - (tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then - upwind_nodes=>x_nodes - else - upwind_nodes=>nodes - end if - - ! find determinant and unorientated normal - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) - - cfl_ele = 1.0 - - tfield_ele = ele_val(tfield_scomp, ele) - oldtfield_ele = ele_val(oldtfield_scomp, ele) - - notvisited=.true. - - mat_local = 0.0 - rhs_local = 0.0 - - ! loop over nodes within this element - do iloc = 1, tfield%mesh%shape%loc - - ! loop over cv faces internal to this element - do face = 1, cvfaces%faces - - ! is this a face neighbouring iloc? - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) - - ! loop over gauss points on face - do gi = 1, cvfaces%shape%ngi - - ! global gauss pt index - ggi = (face-1)*cvfaces%shape%ngi + gi - - ! have we been here before? - if(notvisited(ggi)) then - notvisited(ggi)=.false. - - ! correct the orientation of the normal so it points away from iloc - normgi=orientate_cvsurf_normgi(node_val(x_tfield, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - - ! calculate u.n - udotn=dot_product(u_f(:,ggi), normgi(:)) - - inflow = (udotn<=0.0) - - income = merge(1.0,0.0,inflow) - - if((tfield_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND).and.& - (.not.tfield_options%limit_theta))then - ! if we need the matrix then assemble it now - assert((i==1).and.(j==1).and.getmat) - - mat_local(iloc, oloc) = mat_local(iloc, oloc) & - + detwei(ggi)*udotn*income - mat_local(oloc, iloc) = mat_local(oloc, iloc) & - + detwei(ggi)*(-udotn)*(1.-income) - mat_local(iloc, iloc) = mat_local(iloc, iloc) & - + detwei(ggi)*udotn*(1.0-income) & - - (1.-beta)*detwei(ggi)*udotn - mat_local(oloc, oloc) = mat_local(oloc, oloc) & - + detwei(ggi)*(-udotn)*income & - - (1.-beta)*detwei(ggi)*(-udotn) - - else - ! calculate the iterated pivot value (so far only does first order upwind) - ! which will be subtracted out from the rhs such that with an increasing number - ! of iterations the true implicit lhs pivot is cancelled out (if it converges!) - tfield_pivot_val = income*tfield_ele(oloc) + (1.-income)*tfield_ele(iloc) - - ! evaluate the nonlinear face value that will go into the rhs - ! this is the value that you choose the discretisation for and - ! that will become the dominant term once convergence is achieved - call evaluate_face_val(tfield_face_val, oldtfield_face_val, & - iloc, oloc, ggi, upwind_nodes, & - t_cvshape, & - tfield_ele, oldtfield_ele, & - tfield_upwind, oldtfield_upwind, & - inflow, cfl_ele, & - tfield_options) - - ! perform the time discretisation - tfield_theta_val=theta_val(iloc, oloc, & - tfield_face_val, & - oldtfield_face_val, & - tfield_options%theta, dt, udotn, & - x_ele, tfield_options%limit_theta, & - tfield_ele, oldtfield_ele, & - ftheta=ftheta) - - rhs_local(i, j, iloc) = rhs_local(i, j, iloc) & - + ptheta*udotn*detwei(ggi)*tfield_pivot_val & - - udotn*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*udotn*oldtfield_ele(iloc) - - if(j/=i) then - rhs_local(j, i, iloc) = rhs_local(j, i, iloc) & - + ptheta*udotn*detwei(ggi)*tfield_pivot_val & - - udotn*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*udotn*oldtfield_ele(iloc) - end if - - rhs_local(i, j, oloc) = rhs_local(i, j, oloc) & - + ptheta*(-udotn)*detwei(ggi)*tfield_pivot_val & - - (-udotn)*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-udotn)*oldtfield_ele(oloc) - - if(j/=i) then - rhs_local(j, i, oloc) = rhs_local(j, i, oloc) & - + ptheta*(-udotn)*detwei(ggi)*tfield_pivot_val & - - (-udotn)*detwei(ggi)*tfield_theta_val & - + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-udotn)*oldtfield_ele(oloc) - end if - - ! if we need the matrix then assemble it now - if(getmat .and. i == 1 .and. j == 1) then - mat_local(iloc, oloc) = mat_local(iloc, oloc) & - + ptheta*detwei(ggi)*udotn*income - mat_local(oloc, iloc) = mat_local(oloc, iloc) & - + ptheta*detwei(ggi)*(-udotn)*(1.-income) - mat_local(iloc, iloc) = mat_local(iloc, iloc) & - + ptheta*detwei(ggi)*udotn*(1.0-income) & - - ftheta*(1.-beta)*detwei(ggi)*udotn - mat_local(oloc, oloc) = mat_local(oloc, oloc) & - + ptheta*detwei(ggi)*(-udotn)*income & - - ftheta*(1.-beta)*detwei(ggi)*(-udotn) - - end if - - end if - - end if ! notvisited - end do ! gi - end if ! neiloc - end do ! face - end do ! iloc - - if(getmat.and.(i==1).and.(j==1)) then - call addto(A_m, nodes, nodes, mat_local) - end if - - if((tfield_options%facevalue/=CV_FACEVALUE_FIRSTORDERUPWIND).or.& - (tfield_options%limit_theta))then - call addto(rhs, nodes, rhs_local) - end if - end do ! ele - end do ! j - end do ! i + end if + + ! some temporal discretisation options for clarity + ptheta = tfield_options%ptheta + beta = tfield_options%beta + + ! loop over elements + do ele=1, element_count(tfield) + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + u_f=ele_val_at_quad(relu, ele, u_cvshape) + nodes=>ele_nodes(tfield, ele) + x_nodes=>ele_nodes(x_tfield, ele) + if((tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_POINT).or.& + (tfield_options%upwind_scheme==CV_UPWINDVALUE_PROJECT_GRAD)) then + upwind_nodes=>x_nodes + else + upwind_nodes=>nodes + end if + + ! find determinant and unorientated normal + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) + + cfl_ele = 1.0 + + tfield_ele = ele_val(tfield_scomp, ele) + oldtfield_ele = ele_val(oldtfield_scomp, ele) + + notvisited=.true. + + mat_local = 0.0 + rhs_local = 0.0 + + ! loop over nodes within this element + do iloc = 1, tfield%mesh%shape%loc + + ! loop over cv faces internal to this element + do face = 1, cvfaces%faces + + ! is this a face neighbouring iloc? + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) + + ! loop over gauss points on face + do gi = 1, cvfaces%shape%ngi + + ! global gauss pt index + ggi = (face-1)*cvfaces%shape%ngi + gi + + ! have we been here before? + if(notvisited(ggi)) then + notvisited(ggi)=.false. + + ! correct the orientation of the normal so it points away from iloc + normgi=orientate_cvsurf_normgi(node_val(x_tfield, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + + ! calculate u.n + udotn=dot_product(u_f(:,ggi), normgi(:)) + + inflow = (udotn<=0.0) + + income = merge(1.0,0.0,inflow) + + if((tfield_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND).and.& + (.not.tfield_options%limit_theta))then + ! if we need the matrix then assemble it now + assert((i==1).and.(j==1).and.getmat) + + mat_local(iloc, oloc) = mat_local(iloc, oloc) & + + detwei(ggi)*udotn*income + mat_local(oloc, iloc) = mat_local(oloc, iloc) & + + detwei(ggi)*(-udotn)*(1.-income) + mat_local(iloc, iloc) = mat_local(iloc, iloc) & + + detwei(ggi)*udotn*(1.0-income) & + - (1.-beta)*detwei(ggi)*udotn + mat_local(oloc, oloc) = mat_local(oloc, oloc) & + + detwei(ggi)*(-udotn)*income & + - (1.-beta)*detwei(ggi)*(-udotn) + + else + ! calculate the iterated pivot value (so far only does first order upwind) + ! which will be subtracted out from the rhs such that with an increasing number + ! of iterations the true implicit lhs pivot is cancelled out (if it converges!) + tfield_pivot_val = income*tfield_ele(oloc) + (1.-income)*tfield_ele(iloc) + + ! evaluate the nonlinear face value that will go into the rhs + ! this is the value that you choose the discretisation for and + ! that will become the dominant term once convergence is achieved + call evaluate_face_val(tfield_face_val, oldtfield_face_val, & + iloc, oloc, ggi, upwind_nodes, & + t_cvshape, & + tfield_ele, oldtfield_ele, & + tfield_upwind, oldtfield_upwind, & + inflow, cfl_ele, & + tfield_options) + + ! perform the time discretisation + tfield_theta_val=theta_val(iloc, oloc, & + tfield_face_val, & + oldtfield_face_val, & + tfield_options%theta, dt, udotn, & + x_ele, tfield_options%limit_theta, & + tfield_ele, oldtfield_ele, & + ftheta=ftheta) + + rhs_local(i, j, iloc) = rhs_local(i, j, iloc) & + + ptheta*udotn*detwei(ggi)*tfield_pivot_val & + - udotn*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*udotn*oldtfield_ele(iloc) + + if(j/=i) then + rhs_local(j, i, iloc) = rhs_local(j, i, iloc) & + + ptheta*udotn*detwei(ggi)*tfield_pivot_val & + - udotn*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*udotn*oldtfield_ele(iloc) + end if + + rhs_local(i, j, oloc) = rhs_local(i, j, oloc) & + + ptheta*(-udotn)*detwei(ggi)*tfield_pivot_val & + - (-udotn)*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-udotn)*oldtfield_ele(oloc) + + if(j/=i) then + rhs_local(j, i, oloc) = rhs_local(j, i, oloc) & + + ptheta*(-udotn)*detwei(ggi)*tfield_pivot_val & + - (-udotn)*detwei(ggi)*tfield_theta_val & + + (1.-ftheta)*(1.-beta)*detwei(ggi)*(-udotn)*oldtfield_ele(oloc) + end if + + ! if we need the matrix then assemble it now + if(getmat .and. i == 1 .and. j == 1) then + mat_local(iloc, oloc) = mat_local(iloc, oloc) & + + ptheta*detwei(ggi)*udotn*income + mat_local(oloc, iloc) = mat_local(oloc, iloc) & + + ptheta*detwei(ggi)*(-udotn)*(1.-income) + mat_local(iloc, iloc) = mat_local(iloc, iloc) & + + ptheta*detwei(ggi)*udotn*(1.0-income) & + - ftheta*(1.-beta)*detwei(ggi)*udotn + mat_local(oloc, oloc) = mat_local(oloc, oloc) & + + ptheta*detwei(ggi)*(-udotn)*income & + - ftheta*(1.-beta)*detwei(ggi)*(-udotn) + + end if + + end if + + end if ! notvisited + end do ! gi + end if ! neiloc + end do ! face + end do ! iloc + + if(getmat.and.(i==1).and.(j==1)) then + call addto(A_m, nodes, nodes, mat_local) + end if + + if((tfield_options%facevalue/=CV_FACEVALUE_FIRSTORDERUPWIND).or.& + (tfield_options%limit_theta))then + call addto(rhs, nodes, rhs_local) + end if + end do ! ele + end do ! j + end do ! i ! deallocate(detwei) ! u_shape=>ele_shape(relu, 1) @@ -852,157 +852,157 @@ subroutine assemble_advection_m_cv(A_m, rhs, & ! ! call deallocate(bounded_U_nl_J) - call deallocate(tfield_upwind) - call deallocate(oldtfield_upwind) + call deallocate(tfield_upwind) + call deallocate(oldtfield_upwind) - deallocate(x_ele, x_f, detwei, normal, normgi, u_f) - deallocate(cfl_ele, tfield_ele, oldtfield_ele) - deallocate(notvisited) + deallocate(x_ele, x_f, detwei, normal, normgi, u_f) + deallocate(cfl_ele, tfield_ele, oldtfield_ele) + deallocate(notvisited) - contains + contains - function frob(R) - real, dimension(:, :), intent(in) :: R - real :: frob + function frob(R) + real, dimension(:, :), intent(in) :: R + real :: frob - real, dimension(size(R, 1), size(R, 2)) :: X - integer :: i - real :: trace + real, dimension(size(R, 1), size(R, 2)) :: X + integer :: i + real :: trace - X = matmul(transpose(R), R) - trace = 0.0 - do i=1,size(R, 1) - trace = trace + X(i, i) - end do - frob = sqrt(trace) - end function frob - - function anisotropic_min_abs(tensor1, tensor2) result(tensor3) - real, dimension(:, :), intent(in) :: tensor1, tensor2 - real, dimension(size(tensor1, 1), size(tensor1, 1)) :: tensor3, F, T, Finv, evecs - real, dimension(size(tensor1, 1)) :: evals - integer :: i, dim - real :: e_sign, e_abs - - dim = size(tensor1, 1) - - if (all(tensor2 == 0.0)) then - call eigendecomposition_symmetric(tensor1, evecs, evals) - do i=1,dim - evals(i) = min(evals(i), 0.0) - end do - call eigenrecomposition(tensor3, evecs, evals) - return - end if + X = matmul(transpose(R), R) + trace = 0.0 + do i=1,size(R, 1) + trace = trace + X(i, i) + end do + frob = sqrt(trace) + end function frob + + function anisotropic_min_abs(tensor1, tensor2) result(tensor3) + real, dimension(:, :), intent(in) :: tensor1, tensor2 + real, dimension(size(tensor1, 1), size(tensor1, 1)) :: tensor3, F, T, Finv, evecs + real, dimension(size(tensor1, 1)) :: evals + integer :: i, dim + real :: e_sign, e_abs - ! So we are dealing with the non-degenerate case. + dim = size(tensor1, 1) - call eigendecomposition_symmetric(tensor2, evecs, evals) - F = get_deformation_matrix(tensor2, evecs, evals) - Finv = inverse(F) + if (all(tensor2 == 0.0)) then + call eigendecomposition_symmetric(tensor1, evecs, evals) + do i=1,dim + evals(i) = min(evals(i), 0.0) + end do + call eigenrecomposition(tensor3, evecs, evals) + return + end if + + ! So we are dealing with the non-degenerate case. + + call eigendecomposition_symmetric(tensor2, evecs, evals) + F = get_deformation_matrix(tensor2, evecs, evals) + Finv = inverse(F) + + T = transpose(Finv) + tensor3 = matmul(matmul(T, tensor1), transpose(T)) + call eigendecomposition_symmetric(tensor3, evecs, evals) + + do i=1,dim + e_sign = sign(1.0, evals(i)) + e_abs = abs(evals(i)) + evals(i) = min(e_abs, 1.0) * e_sign + end do + call eigenrecomposition(tensor3, evecs, evals) + T = F + tensor3 = matmul(matmul(transpose(T), tensor3), T) + end function + + + end subroutine assemble_advection_m_cv + ! end of assembly subroutines + !************************************************************************ + + function rk_coeff(i) + ! RK4 coefficients + integer, intent(in) :: i + real :: rk_coeff + + select case(i) + case(1) + rk_coeff = 1.0 + case(2) + rk_coeff = 2.0 + case(3) + rk_coeff = 2.0 + case(4) + rk_coeff = 1.0 + end select + + end function + + subroutine insert_bounded_velocity_jacobian(state) + type(state_type), intent(inout) :: state + + type(tensor_field) :: U_nl_J, rhs + type(vector_field), pointer :: U_nl, X + real, dimension(:), allocatable :: detwei + real, dimension(:, :, :), allocatable :: U_nl_J_q, du_t, tensor_rhs + real, dimension(:, :), allocatable :: little_mass_matrix + integer :: ele, i, j, dim, loc, ngi + type(scalar_field) :: lumped_mass + type(element_type), pointer :: u_shape + + U_nl => extract_vector_field(state, "NonlinearVelocity") + X => extract_vector_field(state, "Coordinate") + u_shape => ele_shape(U_nl, 1) + dim = U_nl%dim + loc = ele_loc(U_nl, 1) + ngi = ele_ngi(U_nl, 1) + call allocate(U_nl_J, U_nl%mesh, "VelocityJacobian") + call zero(U_nl_J) + call allocate(rhs, U_nl%mesh, "VelocityJacobianRHS") + call zero(rhs) + call allocate(lumped_mass, U_nl%mesh, "LumpedMass") + call zero(lumped_mass) + + allocate(detwei(ngi)) + allocate(U_nl_J_q(dim, dim, ngi)) + allocate(du_t(loc, ngi, dim)) + allocate(little_mass_matrix(loc, loc)) + allocate(tensor_rhs(dim, dim, loc)) + + do ele=1,ele_count(U_nl) + call transform_to_physical(X, ele, u_shape , dshape=du_t, detwei=detwei) + little_mass_matrix = shape_shape(u_shape, u_shape, detwei) + call addto(lumped_mass, ele_nodes(U_nl, ele), sum(little_mass_matrix, 2)) + + U_nl_J_q = ele_jacobian_at_quad(U_nl, ele, du_t) + tensor_rhs = shape_tensor_rhs(u_shape, U_nl_J_q, detwei) + call addto(rhs, ele_nodes(U_nl, ele), tensor_rhs) + end do - T = transpose(Finv) - tensor3 = matmul(matmul(T, tensor1), transpose(T)) - call eigendecomposition_symmetric(tensor3, evecs, evals) + if (U_nl%mesh%shape%degree /= 1) then + ewrite(-1,*) "You need to write the code to do the full Galerkin projection here." + ewrite(-1,*) "It's easy. Instead of lumping the mass, just form the full mass matrix" + ewrite(-1,*) "and call petsc_solve." + FLExit("bounded_velocity_jacobian not available for non P1 velocities") + end if do i=1,dim - e_sign = sign(1.0, evals(i)) - e_abs = abs(evals(i)) - evals(i) = min(e_abs, 1.0) * e_sign - end do - call eigenrecomposition(tensor3, evecs, evals) - T = F - tensor3 = matmul(matmul(transpose(T), tensor3), T) - end function - - - end subroutine assemble_advection_m_cv - ! end of assembly subroutines - !************************************************************************ - - function rk_coeff(i) - ! RK4 coefficients - integer, intent(in) :: i - real :: rk_coeff - - select case(i) - case(1) - rk_coeff = 1.0 - case(2) - rk_coeff = 2.0 - case(3) - rk_coeff = 2.0 - case(4) - rk_coeff = 1.0 - end select - - end function - - subroutine insert_bounded_velocity_jacobian(state) - type(state_type), intent(inout) :: state - - type(tensor_field) :: U_nl_J, rhs - type(vector_field), pointer :: U_nl, X - real, dimension(:), allocatable :: detwei - real, dimension(:, :, :), allocatable :: U_nl_J_q, du_t, tensor_rhs - real, dimension(:, :), allocatable :: little_mass_matrix - integer :: ele, i, j, dim, loc, ngi - type(scalar_field) :: lumped_mass - type(element_type), pointer :: u_shape - - U_nl => extract_vector_field(state, "NonlinearVelocity") - X => extract_vector_field(state, "Coordinate") - u_shape => ele_shape(U_nl, 1) - dim = U_nl%dim - loc = ele_loc(U_nl, 1) - ngi = ele_ngi(U_nl, 1) - call allocate(U_nl_J, U_nl%mesh, "VelocityJacobian") - call zero(U_nl_J) - call allocate(rhs, U_nl%mesh, "VelocityJacobianRHS") - call zero(rhs) - call allocate(lumped_mass, U_nl%mesh, "LumpedMass") - call zero(lumped_mass) - - allocate(detwei(ngi)) - allocate(U_nl_J_q(dim, dim, ngi)) - allocate(du_t(loc, ngi, dim)) - allocate(little_mass_matrix(loc, loc)) - allocate(tensor_rhs(dim, dim, loc)) - - do ele=1,ele_count(U_nl) - call transform_to_physical(X, ele, u_shape , dshape=du_t, detwei=detwei) - little_mass_matrix = shape_shape(u_shape, u_shape, detwei) - call addto(lumped_mass, ele_nodes(U_nl, ele), sum(little_mass_matrix, 2)) - - U_nl_J_q = ele_jacobian_at_quad(U_nl, ele, du_t) - tensor_rhs = shape_tensor_rhs(u_shape, U_nl_J_q, detwei) - call addto(rhs, ele_nodes(U_nl, ele), tensor_rhs) - end do - - if (U_nl%mesh%shape%degree /= 1) then - ewrite(-1,*) "You need to write the code to do the full Galerkin projection here." - ewrite(-1,*) "It's easy. Instead of lumping the mass, just form the full mass matrix" - ewrite(-1,*) "and call petsc_solve." - FLExit("bounded_velocity_jacobian not available for non P1 velocities") - end if - - do i=1,dim - do j=1,dim - U_nl_J%val(i, j, :) = rhs%val(i, j, :) * (1.0 / lumped_mass%val) + do j=1,dim + U_nl_J%val(i, j, :) = rhs%val(i, j, :) * (1.0 / lumped_mass%val) + end do end do - end do - call deallocate(rhs) + call deallocate(rhs) - call insert(state, U_nl_J, "VelocityJacobian") - call deallocate(U_nl_J) + call insert(state, U_nl_J, "VelocityJacobian") + call deallocate(U_nl_J) - call deallocate(lumped_mass) + call deallocate(lumped_mass) - deallocate(detwei) - deallocate(U_nl_J_q) - deallocate(du_t) - deallocate(little_mass_matrix) - deallocate(tensor_rhs) + deallocate(detwei) + deallocate(U_nl_J_q) + deallocate(du_t) + deallocate(little_mass_matrix) + deallocate(tensor_rhs) - end subroutine insert_bounded_velocity_jacobian + end subroutine insert_bounded_velocity_jacobian end module metric_advection diff --git a/error_measures/Project_metric_to_surface.F90 b/error_measures/Project_metric_to_surface.F90 index 43ec3fa644..9990a54c21 100644 --- a/error_measures/Project_metric_to_surface.F90 +++ b/error_measures/Project_metric_to_surface.F90 @@ -2,306 +2,306 @@ module project_metric_to_surface_module - use fldebug - use quicksort - use spud - use sparse_tools - use vector_tools - use transform_elements - use fetools - use fields - use merge_tensors - use state_module - use vtk_interfaces - use hadapt_advancing_front - use boundary_conditions - use field_options - use edge_length_module - - implicit none - - private - public :: project_metric_to_surface, vertically_align_metric, incorporate_bathymetric_metric - contains - - subroutine project_metric_to_surface(volume_metric, h_mesh, surface_metric) - !! Given a volume metric, project the metric up the columns to the surface mesh - type(tensor_field), intent(in) :: volume_metric - type(vector_field), intent(in) :: h_mesh - type(tensor_field), intent(out) :: surface_metric - - type(csr_sparsity):: columns - integer :: column - real, dimension(mesh_dim(volume_metric), mesh_dim(volume_metric)) :: tmp_metric - real, dimension(mesh_dim(volume_metric)-1, mesh_dim(volume_metric)-1) :: tmp_smetric - - call allocate(surface_metric, h_mesh%mesh, "Surface"//trim(volume_metric%name), field_type=volume_metric%field_type) - - if(volume_metric%field_type==FIELD_TYPE_CONSTANT) then - tmp_metric = node_val(volume_metric, 1) - tmp_smetric = reduce_metric_dimension(tmp_metric) - call set(surface_metric, tmp_smetric) - else - call create_columns_sparsity(columns, volume_metric%mesh) - - do column=1,node_count(h_mesh) - call merge_up_columns(volume_metric, columns, column, tmp_metric) - tmp_smetric = reduce_metric_dimension(tmp_metric) - call set(surface_metric, column, tmp_smetric) - end do - - call deallocate(columns) - end if + use fldebug + use quicksort + use spud + use sparse_tools + use vector_tools + use transform_elements + use fetools + use fields + use merge_tensors + use state_module + use vtk_interfaces + use hadapt_advancing_front + use boundary_conditions + use field_options + use edge_length_module + + implicit none + + private + public :: project_metric_to_surface, vertically_align_metric, incorporate_bathymetric_metric +contains + + subroutine project_metric_to_surface(volume_metric, h_mesh, surface_metric) + !! Given a volume metric, project the metric up the columns to the surface mesh + type(tensor_field), intent(in) :: volume_metric + type(vector_field), intent(in) :: h_mesh + type(tensor_field), intent(out) :: surface_metric + + type(csr_sparsity):: columns + integer :: column + real, dimension(mesh_dim(volume_metric), mesh_dim(volume_metric)) :: tmp_metric + real, dimension(mesh_dim(volume_metric)-1, mesh_dim(volume_metric)-1) :: tmp_smetric + + call allocate(surface_metric, h_mesh%mesh, "Surface"//trim(volume_metric%name), field_type=volume_metric%field_type) + + if(volume_metric%field_type==FIELD_TYPE_CONSTANT) then + tmp_metric = node_val(volume_metric, 1) + tmp_smetric = reduce_metric_dimension(tmp_metric) + call set(surface_metric, tmp_smetric) + else + call create_columns_sparsity(columns, volume_metric%mesh) + + do column=1,node_count(h_mesh) + call merge_up_columns(volume_metric, columns, column, tmp_metric) + tmp_smetric = reduce_metric_dimension(tmp_metric) + call set(surface_metric, column, tmp_smetric) + end do + + call deallocate(columns) + end if - contains + contains subroutine merge_up_columns(volume_metric, columns, column, tmp_metric) - !! Descend down the column, merging as you go - type(tensor_field), intent(in) :: volume_metric - type(csr_sparsity), intent(in) :: columns - integer, intent(in) :: column - real, dimension(:, :), intent(out) :: tmp_metric - - integer, dimension(:), pointer :: column_nodes - integer :: column_len - integer :: node - real, dimension(mesh_dim(volume_metric), mesh_dim(volume_metric)) :: tmp_val - - column_nodes => row_m_ptr(columns, column) - column_len = row_length(columns, column) - - tmp_metric = node_val(volume_metric, column_nodes(1)) - do node=2,column_len - tmp_val = node_val(volume_metric, column_nodes(node)) - call merge_tensor(tmp_metric, tmp_val) - end do + !! Descend down the column, merging as you go + type(tensor_field), intent(in) :: volume_metric + type(csr_sparsity), intent(in) :: columns + integer, intent(in) :: column + real, dimension(:, :), intent(out) :: tmp_metric + + integer, dimension(:), pointer :: column_nodes + integer :: column_len + integer :: node + real, dimension(mesh_dim(volume_metric), mesh_dim(volume_metric)) :: tmp_val + + column_nodes => row_m_ptr(columns, column) + column_len = row_length(columns, column) + + tmp_metric = node_val(volume_metric, column_nodes(1)) + do node=2,column_len + tmp_val = node_val(volume_metric, column_nodes(node)) + call merge_tensor(tmp_metric, tmp_val) + end do end subroutine merge_up_columns - end subroutine project_metric_to_surface + end subroutine project_metric_to_surface - function reduce_metric_dimension(volume_metric, normal) result(surface_metric) - !! Given a (e.g.) 3D metric, squash it down to a 2D metric - real, dimension(:, :), intent(in) :: volume_metric - real, dimension(:), intent(in), optional :: normal + function reduce_metric_dimension(volume_metric, normal) result(surface_metric) + !! Given a (e.g.) 3D metric, squash it down to a 2D metric + real, dimension(:, :), intent(in) :: volume_metric + real, dimension(:), intent(in), optional :: normal - real, dimension(size(volume_metric, 1)-1, size(volume_metric, 2)-1) :: surface_metric + real, dimension(size(volume_metric, 1)-1, size(volume_metric, 2)-1) :: surface_metric - integer :: vdim, sdim + integer :: vdim, sdim - real, dimension(:), allocatable :: tangent1, tangent2, tangent1_dir - real :: project + real, dimension(:), allocatable :: tangent1, tangent2, tangent1_dir + real :: project - real, dimension(size(volume_metric, 1), size(volume_metric, 2)) :: rotated_metric, & - rotation_matrix - assert(size(volume_metric, 1)==size(volume_metric, 2)) + real, dimension(size(volume_metric, 1), size(volume_metric, 2)) :: rotated_metric, & + rotation_matrix + assert(size(volume_metric, 1)==size(volume_metric, 2)) - vdim = size(volume_metric, 1) - sdim = vdim - 1 + vdim = size(volume_metric, 1) + sdim = vdim - 1 - if(present(normal)) then + if(present(normal)) then - allocate(tangent1(size(normal)), tangent2(size(normal)), tangent1_dir(size(normal))) - tangent1 = 0.0 - tangent2 = 0.0 - rotation_matrix = 0.0 + allocate(tangent1(size(normal)), tangent2(size(normal)), tangent1_dir(size(normal))) + tangent1 = 0.0 + tangent2 = 0.0 + rotation_matrix = 0.0 - if(vdim>1) then + if(vdim>1) then - ! we want the 1st tangent to align with the x axis - ! which we assume is the first index - ! NOTE: this clearly won't work for normals that are in the x-direction - tangent1_dir = 0.0 - tangent1_dir(1) = 1.0 + ! we want the 1st tangent to align with the x axis + ! which we assume is the first index + ! NOTE: this clearly won't work for normals that are in the x-direction + tangent1_dir = 0.0 + tangent1_dir(1) = 1.0 - project = dot_product(normal, tangent1_dir) - tangent1 = tangent1_dir - project*normal + project = dot_product(normal, tangent1_dir) + tangent1 = tangent1_dir - project*normal - tangent1 = tangent1/sqrt(sum(tangent1**2)) + tangent1 = tangent1/sqrt(sum(tangent1**2)) - rotation_matrix(:,1) = tangent1 + rotation_matrix(:,1) = tangent1 - if(vdim>2) then + if(vdim>2) then - tangent2 = cross_product(normal, tangent1) - ! we want the 2nd tangent to align with the y axis - ! which we assume is the second index - if(tangent2(2)<0.0) tangent2 = -tangent2 + tangent2 = cross_product(normal, tangent1) + ! we want the 2nd tangent to align with the y axis + ! which we assume is the second index + if(tangent2(2)<0.0) tangent2 = -tangent2 - rotation_matrix(:,2) = tangent2 - end if - end if + rotation_matrix(:,2) = tangent2 + end if + end if - rotation_matrix(:,vdim) = normal + rotation_matrix(:,vdim) = normal - rotated_metric = matmul(transpose(rotation_matrix), matmul(volume_metric, rotation_matrix)) + rotated_metric = matmul(transpose(rotation_matrix), matmul(volume_metric, rotation_matrix)) - else - rotated_metric = volume_metric - end if + else + rotated_metric = volume_metric + end if - surface_metric = rotated_metric(1:sdim, 1:sdim) + surface_metric = rotated_metric(1:sdim, 1:sdim) - end function reduce_metric_dimension + end function reduce_metric_dimension - subroutine vertically_align_metric(state, error_metric) - !!< This separates out the metric projected to the horizontal plane (1 or 2D), - !!< and the metric projected in the vertical (gravity) direction, and combines - !!< this 1 or 2D hor. metric and 1D vert. metric back into a full resp. 2 or 3D metric. - !!< This ensures that for large aspect ratio problems the horizontal and vertical - !!< metric are completely independent. Typically the metric for large aspect ratio - !!< problems already decomposes in an (almost) vertical eigenvector and 2 horizontal - !!< ones, however even the slightest tilt causes vertical error bounds to be "leaked" - !!< into the horizontal leading to unexpected strict horizontal bounds. - type(state_type), intent(in):: state - type(tensor_field), intent(inout):: error_metric + subroutine vertically_align_metric(state, error_metric) + !!< This separates out the metric projected to the horizontal plane (1 or 2D), + !!< and the metric projected in the vertical (gravity) direction, and combines + !!< this 1 or 2D hor. metric and 1D vert. metric back into a full resp. 2 or 3D metric. + !!< This ensures that for large aspect ratio problems the horizontal and vertical + !!< metric are completely independent. Typically the metric for large aspect ratio + !!< problems already decomposes in an (almost) vertical eigenvector and 2 horizontal + !!< ones, however even the slightest tilt causes vertical error bounds to be "leaked" + !!< into the horizontal leading to unexpected strict horizontal bounds. + type(state_type), intent(in):: state + type(tensor_field), intent(inout):: error_metric - type(vector_field):: down_here - type(vector_field), pointer:: down - integer:: i, stat + type(vector_field):: down_here + type(vector_field), pointer:: down + integer:: i, stat - down => extract_vector_field(state, "GravityDirection", stat=stat) + down => extract_vector_field(state, "GravityDirection", stat=stat) - if (stat /= 0) return + if (stat /= 0) return - call allocate(down_here, down%dim, error_metric%mesh, "GravityDirectionOnCoordinateMesh") - call remap_field(down, down_here) + call allocate(down_here, down%dim, error_metric%mesh, "GravityDirectionOnCoordinateMesh") + call remap_field(down, down_here) - do i=1, node_count(error_metric) + do i=1, node_count(error_metric) - call set( error_metric, i, vertically_align_metric_node( & - node_val(error_metric, i), & - node_val(down_here, i) ) ) + call set( error_metric, i, vertically_align_metric_node( & + node_val(error_metric, i), & + node_val(down_here, i) ) ) - end do + end do - call deallocate(down_here) + call deallocate(down_here) - end subroutine vertically_align_metric + end subroutine vertically_align_metric - function vertically_align_metric_node(metric, down) result (projected_metric) - real, dimension(:,:):: metric - real, dimension(:):: down - real, dimension(1:size(down), 1:size(down)):: projected_metric + function vertically_align_metric_node(metric, down) result (projected_metric) + real, dimension(:,:):: metric + real, dimension(:):: down + real, dimension(1:size(down), 1:size(down)):: projected_metric - real, dimension(1:size(down), 1:size(down)):: pv, ph - integer:: i + real, dimension(1:size(down), 1:size(down)):: pv, ph + integer:: i - ! vertical projection - pv = outer_product( down, down ) + ! vertical projection + pv = outer_product( down, down ) - ! ph = identity -pv - ph=-pv - forall(i=1:size(down)) ph(i,i)=ph(i,i)+1.0 + ! ph = identity -pv + ph=-pv + forall(i=1:size(down)) ph(i,i)=ph(i,i)+1.0 - projected_metric=matmul( ph, matmul(metric, ph)) + matmul( pv, matmul(metric, pv)) + projected_metric=matmul( ph, matmul(metric, ph)) + matmul( pv, matmul(metric, pv)) - end function vertically_align_metric_node + end function vertically_align_metric_node - subroutine incorporate_bathymetric_metric(state, volume_metric, surface_positions, surface_metric) - type(state_type), intent(in) :: state - type(tensor_field), intent(in) :: volume_metric - type(vector_field), intent(in) :: surface_positions ! only passed in for debugging output - type(tensor_field), intent(inout) :: surface_metric + subroutine incorporate_bathymetric_metric(state, volume_metric, surface_positions, surface_metric) + type(state_type), intent(in) :: state + type(tensor_field), intent(in) :: volume_metric + type(vector_field), intent(in) :: surface_positions ! only passed in for debugging output + type(tensor_field), intent(inout) :: surface_metric - type(scalar_field), pointer :: bottomdis - integer, dimension(:), pointer :: surface_element_list - type(mesh_type), pointer :: surface_mesh - type(mesh_type) :: bottom_metric_mesh - type(vector_field) :: normal + type(scalar_field), pointer :: bottomdis + integer, dimension(:), pointer :: surface_element_list + type(mesh_type), pointer :: surface_mesh + type(mesh_type) :: bottom_metric_mesh + type(vector_field) :: normal - type(vector_field) :: coordinate - real, dimension(mesh_dim(volume_metric), face_ngi(volume_metric, 1)) :: normal_bdy - real, dimension(face_ngi(volume_metric, 1)) :: detwei_bdy - real, dimension(mesh_dim(volume_metric)) :: n + type(vector_field) :: coordinate + real, dimension(mesh_dim(volume_metric), face_ngi(volume_metric, 1)) :: normal_bdy + real, dimension(face_ngi(volume_metric, 1)) :: detwei_bdy + real, dimension(mesh_dim(volume_metric)) :: n - integer, dimension(:), allocatable :: base_volume_index - type(tensor_field) :: tmp_metric + integer, dimension(:), allocatable :: base_volume_index + type(tensor_field) :: tmp_metric - integer :: i, sele + integer :: i, sele - type(scalar_field) :: edge_lengths - integer, save :: adaptcnt=0 + type(scalar_field) :: edge_lengths + integer, save :: adaptcnt=0 - ewrite(1,*) 'Entering incorporate_bathymetric_metric' + ewrite(1,*) 'Entering incorporate_bathymetric_metric' - bottomdis => extract_scalar_field(state, "DistanceToBottom") - call get_boundary_condition(bottomdis, 1, surface_mesh = surface_mesh, & - surface_element_list = surface_element_list) + bottomdis => extract_scalar_field(state, "DistanceToBottom") + call get_boundary_condition(bottomdis, 1, surface_mesh = surface_mesh, & + surface_element_list = surface_element_list) - bottom_metric_mesh = make_mesh(surface_mesh, shape = face_shape(volume_metric, 1), & - continuity = continuity(volume_metric)) + bottom_metric_mesh = make_mesh(surface_mesh, shape = face_shape(volume_metric, 1), & + continuity = continuity(volume_metric)) - call allocate(normal, mesh_dim(volume_metric), bottom_metric_mesh, "BottomNormals") - call zero(normal) + call allocate(normal, mesh_dim(volume_metric), bottom_metric_mesh, "BottomNormals") + call zero(normal) - call deallocate(bottom_metric_mesh) + call deallocate(bottom_metric_mesh) - allocate(base_volume_index(node_count(normal))) - base_volume_index = 0 + allocate(base_volume_index(node_count(normal))) + base_volume_index = 0 - coordinate = get_coordinate_field(state, volume_metric%mesh) + coordinate = get_coordinate_field(state, volume_metric%mesh) - do i = 1, size(surface_element_list) - sele = surface_element_list(i) + do i = 1, size(surface_element_list) + sele = surface_element_list(i) - call transform_facet_to_physical(coordinate, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) + call transform_facet_to_physical(coordinate, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) - call addto(normal, ele_nodes(normal, i), & - shape_vector_rhs(ele_shape(normal, i), normal_bdy, detwei_bdy)) + call addto(normal, ele_nodes(normal, i), & + shape_vector_rhs(ele_shape(normal, i), normal_bdy, detwei_bdy)) - ! record the volume node numbers of each node in the bottom mesh - ! (this will get overwritten by the same value if continuous, as we expect) - base_volume_index(ele_nodes(normal, i)) = face_global_nodes(volume_metric, sele) - end do + ! record the volume node numbers of each node in the bottom mesh + ! (this will get overwritten by the same value if continuous, as we expect) + base_volume_index(ele_nodes(normal, i)) = face_global_nodes(volume_metric, sele) + end do - assert(all(base_volume_index > 0)) + assert(all(base_volume_index > 0)) - assert(associated(volume_metric%mesh%columns)) + assert(associated(volume_metric%mesh%columns)) - call allocate(tmp_metric, surface_metric%mesh, "TemporarySurfaceMetric") - call zero(tmp_metric) + call allocate(tmp_metric, surface_metric%mesh, "TemporarySurfaceMetric") + call zero(tmp_metric) - assert(node_count(tmp_metric)==node_count(normal)) + assert(node_count(tmp_metric)==node_count(normal)) - do i = 1, node_count(normal) - ! get node normal - n=node_val(normal,i) - ! normalise it - n=n/sqrt(sum(n**2)) + do i = 1, node_count(normal) + ! get node normal + n=node_val(normal,i) + ! normalise it + n=n/sqrt(sum(n**2)) - call set(tmp_metric, volume_metric%mesh%columns(base_volume_index(i)), & - reduce_metric_dimension(node_val(volume_metric, base_volume_index(i)), n)) + call set(tmp_metric, volume_metric%mesh%columns(base_volume_index(i)), & + reduce_metric_dimension(node_val(volume_metric, base_volume_index(i)), n)) - end do + end do - if (have_option('/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages')) then - call allocate(edge_lengths, tmp_metric%mesh, "EdgeLengths") + if (have_option('/mesh_adaptivity/hr_adaptivity/debug/write_metric_stages')) then + call allocate(edge_lengths, tmp_metric%mesh, "EdgeLengths") - call get_edge_lengths(tmp_metric, edge_lengths) - call vtk_write_fields('bathymetric_metric', adaptcnt, & - surface_positions, surface_positions%mesh, & - sfields=(/ edge_lengths /), tfields=(/ tmp_metric /) ) + call get_edge_lengths(tmp_metric, edge_lengths) + call vtk_write_fields('bathymetric_metric', adaptcnt, & + surface_positions, surface_positions%mesh, & + sfields=(/ edge_lengths /), tfields=(/ tmp_metric /) ) - call get_edge_lengths(surface_metric, edge_lengths) - call vtk_write_fields('initial_horizontal_metric', adaptcnt, & - surface_positions, surface_positions%mesh, & - sfields=(/ edge_lengths /), tfields=(/ surface_metric /) ) + call get_edge_lengths(surface_metric, edge_lengths) + call vtk_write_fields('initial_horizontal_metric', adaptcnt, & + surface_positions, surface_positions%mesh, & + sfields=(/ edge_lengths /), tfields=(/ surface_metric /) ) - adaptcnt=adaptcnt+1 + adaptcnt=adaptcnt+1 - call deallocate(edge_lengths) - end if + call deallocate(edge_lengths) + end if - call merge_tensor_fields(surface_metric, tmp_metric) + call merge_tensor_fields(surface_metric, tmp_metric) - call deallocate(tmp_metric) - call deallocate(normal) - call deallocate(coordinate) + call deallocate(tmp_metric) + call deallocate(normal) + call deallocate(coordinate) - ewrite(2,*) 'Leaving incorporate_bathymetric_metric' + ewrite(2,*) 'Leaving incorporate_bathymetric_metric' - end subroutine incorporate_bathymetric_metric + end subroutine incorporate_bathymetric_metric end module project_metric_to_surface_module diff --git a/error_measures/Recovery_estimator.F90 b/error_measures/Recovery_estimator.F90 index 510adc761f..014ca49f66 100644 --- a/error_measures/Recovery_estimator.F90 +++ b/error_measures/Recovery_estimator.F90 @@ -9,46 +9,46 @@ module recovery_estimator !!< The elementwise error is then estimated as !!< int(|G(u_x) - grad(u_x)|^2) over the element. - use elements - use transform_elements, only: transform_to_physical - use fields - use field_derivatives, only: grad - implicit none + use elements + use transform_elements, only: transform_to_physical + use fields + use field_derivatives, only: grad + implicit none - private + private - public :: form_recovery_estimator + public :: form_recovery_estimator - contains +contains - subroutine form_recovery_estimator(infield, positions, estimator) - type(scalar_field), intent(in) :: infield - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: estimator ! piecewise constant basis + subroutine form_recovery_estimator(infield, positions, estimator) + type(scalar_field), intent(in) :: infield + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: estimator ! piecewise constant basis - type(vector_field) :: grad_infield - real, dimension(ele_ngi(infield, 1)) :: detwei - real, dimension(ele_loc(infield, 1), ele_ngi(infield, 1), mesh_dim(infield)) :: dt_t - real, dimension(ele_ngi(infield, 1)) :: r - type(element_type), pointer :: t_shape - integer :: ele, dim + type(vector_field) :: grad_infield + real, dimension(ele_ngi(infield, 1)) :: detwei + real, dimension(ele_loc(infield, 1), ele_ngi(infield, 1), mesh_dim(infield)) :: dt_t + real, dimension(ele_ngi(infield, 1)) :: r + type(element_type), pointer :: t_shape + integer :: ele, dim - call zero(estimator) + call zero(estimator) - call allocate(grad_infield, mesh_dim(infield), infield%mesh, "Gradient") - call grad(infield, positions, grad_infield) + call allocate(grad_infield, mesh_dim(infield), infield%mesh, "Gradient") + call grad(infield, positions, grad_infield) - t_shape => ele_shape(infield, 1) + t_shape => ele_shape(infield, 1) - do ele=1,element_count(infield) - call transform_to_physical(positions, ele, t_shape, dshape=dt_t, detwei=detwei) - do dim=1,mesh_dim(infield) - r = (matmul(ele_val(grad_infield, dim, ele), t_shape%n) - matmul(ele_val(infield, ele), dt_t(:, :, dim)))**2 - call addto(estimator, ele, dot_product(r, detwei)) + do ele=1,element_count(infield) + call transform_to_physical(positions, ele, t_shape, dshape=dt_t, detwei=detwei) + do dim=1,mesh_dim(infield) + r = (matmul(ele_val(grad_infield, dim, ele), t_shape%n) - matmul(ele_val(infield, ele), dt_t(:, :, dim)))**2 + call addto(estimator, ele, dot_product(r, detwei)) + end do end do - end do - call deallocate(grad_infield) - end subroutine form_recovery_estimator + call deallocate(grad_infield) + end subroutine form_recovery_estimator end module recovery_estimator diff --git a/error_measures/Reference_Meshes.F90 b/error_measures/Reference_Meshes.F90 index a8b2d9c6d3..db47b6ad55 100644 --- a/error_measures/Reference_Meshes.F90 +++ b/error_measures/Reference_Meshes.F90 @@ -2,83 +2,83 @@ module reference_meshes - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use futils, only: int2str - use spud - use fields - use state_module - use field_options, only: get_coordinate_field - use merge_tensors - use conformity_measurement - use interpolation_module + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use futils, only: int2str + use spud + use fields + use state_module + use field_options, only: get_coordinate_field + use merge_tensors + use conformity_measurement + use interpolation_module - implicit none + implicit none - private + private - public :: enforce_reference_meshes + public :: enforce_reference_meshes contains - subroutine enforce_reference_meshes(states, metric_positions, metric) - type(state_type), dimension(:), intent(in) :: states - type(vector_field), intent(in) :: metric_positions - type(tensor_field), intent(inout) :: metric + subroutine enforce_reference_meshes(states, metric_positions, metric) + type(state_type), dimension(:), intent(in) :: states + type(vector_field), intent(in) :: metric_positions + type(tensor_field), intent(inout) :: metric - character(len = *), parameter :: base_name = "/mesh_adaptivity/hr_adaptivity/reference_mesh" - character(len = OPTION_PATH_LEN) :: mesh_name - integer :: i, nreference_meshes - logical :: minimum - type(mesh_type), pointer :: mesh => null() - type(vector_field) :: reference_positions + character(len = *), parameter :: base_name = "/mesh_adaptivity/hr_adaptivity/reference_mesh" + character(len = OPTION_PATH_LEN) :: mesh_name + integer :: i, nreference_meshes + logical :: minimum + type(mesh_type), pointer :: mesh => null() + type(vector_field) :: reference_positions - ewrite(1, *) "In enforce_reference_meshes" + ewrite(1, *) "In enforce_reference_meshes" - nreference_meshes = option_count(base_name) - ewrite(2, *) "Number of reference meshes: ", nreference_meshes - if(nreference_meshes == 0) return + nreference_meshes = option_count(base_name) + ewrite(2, *) "Number of reference meshes: ", nreference_meshes + if(nreference_meshes == 0) return - do i = 0, nreference_meshes - 1 - call get_option(base_name // "[" // int2str(i) // "]" // "/mesh_name", mesh_name) - ewrite(2, *) "Enforcing reference mesh: " // trim(mesh_name) - assert(size(states) > 0) - mesh => extract_mesh(states(1), mesh_name) - reference_positions = get_coordinate_field(states(1), mesh) + do i = 0, nreference_meshes - 1 + call get_option(base_name // "[" // int2str(i) // "]" // "/mesh_name", mesh_name) + ewrite(2, *) "Enforcing reference mesh: " // trim(mesh_name) + assert(size(states) > 0) + mesh => extract_mesh(states(1), mesh_name) + reference_positions = get_coordinate_field(states(1), mesh) - minimum = have_option(base_name // "[" // int2str(i) // "]" // "/minimum") + minimum = have_option(base_name // "[" // int2str(i) // "]" // "/minimum") #ifdef DDEBUG - if(.not. minimum) then - assert(have_option(base_name // "[" // int2str(i) // "]" // "/maximum")) - end if + if(.not. minimum) then + assert(have_option(base_name // "[" // int2str(i) // "]" // "/maximum")) + end if #endif - ewrite(2, *) "Reference mesh is a minimum?", minimum + ewrite(2, *) "Reference mesh is a minimum?", minimum - call enforce_reference_mesh(metric_positions, reference_positions, metric, minimum) + call enforce_reference_mesh(metric_positions, reference_positions, metric, minimum) - call deallocate(reference_positions) - end do + call deallocate(reference_positions) + end do - ewrite(1, *) "Exiting enforce_reference_meshes" + ewrite(1, *) "Exiting enforce_reference_meshes" - end subroutine enforce_reference_meshes + end subroutine enforce_reference_meshes - subroutine enforce_reference_mesh(metric_positions, reference_positions, metric, minimum) - type(vector_field), intent(in) :: metric_positions - type(vector_field), intent(in) :: reference_positions - type(tensor_field), intent(inout) :: metric - logical, intent(in) :: minimum + subroutine enforce_reference_mesh(metric_positions, reference_positions, metric, minimum) + type(vector_field), intent(in) :: metric_positions + type(vector_field), intent(in) :: reference_positions + type(tensor_field), intent(inout) :: metric + logical, intent(in) :: minimum - type(tensor_field) :: mesh_metric, interpolated_mesh_metric + type(tensor_field) :: mesh_metric, interpolated_mesh_metric - call compute_mesh_metric(reference_positions, mesh_metric) - call allocate(interpolated_mesh_metric, metric_positions%mesh, "MetricCoordinate") - call linear_interpolation(mesh_metric, reference_positions, interpolated_mesh_metric, metric_positions) - call merge_tensor_fields(metric, interpolated_mesh_metric, .not. minimum) + call compute_mesh_metric(reference_positions, mesh_metric) + call allocate(interpolated_mesh_metric, metric_positions%mesh, "MetricCoordinate") + call linear_interpolation(mesh_metric, reference_positions, interpolated_mesh_metric, metric_positions) + call merge_tensor_fields(metric, interpolated_mesh_metric, .not. minimum) - call deallocate(mesh_metric) - call deallocate(interpolated_mesh_metric) + call deallocate(mesh_metric) + call deallocate(interpolated_mesh_metric) - end subroutine enforce_reference_mesh + end subroutine enforce_reference_mesh end module reference_meshes diff --git a/error_measures/Richardson_metric.F90 b/error_measures/Richardson_metric.F90 index ccd3b9e557..9accb800f0 100644 --- a/error_measures/Richardson_metric.F90 +++ b/error_measures/Richardson_metric.F90 @@ -2,163 +2,163 @@ module richardson_metric_module - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use spud - use vector_tools - use unittest_tools - use metric_tools - use fields - use edge_length_module - use state_module - use field_options - use limit_metric_module - use merge_tensors + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use spud + use vector_tools + use unittest_tools + use metric_tools + use fields + use edge_length_module + use state_module + use field_options + use limit_metric_module + use merge_tensors - implicit none + implicit none - private + private - public :: initialise_richardson_number_metric, form_richardson_number_metric + public :: initialise_richardson_number_metric, form_richardson_number_metric - logical, public :: use_richardson_number_metric = .false. + logical, public :: use_richardson_number_metric = .false. contains - subroutine initialise_richardson_number_metric + subroutine initialise_richardson_number_metric - use_richardson_number_metric = option_count("/material_phase/scalar_field::RichardsonNumber" // & + use_richardson_number_metric = option_count("/material_phase/scalar_field::RichardsonNumber" // & & "/diagnostic/adaptivity_options/richardson_number_metric") > 0 - end subroutine initialise_richardson_number_metric + end subroutine initialise_richardson_number_metric - subroutine form_richardson_number_metric(states, metric) - type(state_type), dimension(:), intent(in) :: states - type(tensor_field), intent(inout) :: metric + subroutine form_richardson_number_metric(states, metric) + type(state_type), dimension(:), intent(in) :: states + type(tensor_field), intent(inout) :: metric - character(len = OPTION_PATH_LEN) :: base_path - integer :: i, stat - real :: ri_min, ri_max, h_min, h_max - type(scalar_field), pointer :: ri - type(scalar_field) :: ri_metric - type(tensor_field) :: ri_metric_tensor + character(len = OPTION_PATH_LEN) :: base_path + integer :: i, stat + real :: ri_min, ri_max, h_min, h_max + type(scalar_field), pointer :: ri + type(scalar_field) :: ri_metric + type(tensor_field) :: ri_metric_tensor - do i = 1, size(states) - ri => extract_scalar_field(states(i), "RichardsonNumber", stat) - if(stat /= SPUD_NO_ERROR) cycle - base_path = trim(complete_field_path(ri%option_path)) // "/adaptivity_options/richardson_number_metric" - if(.not. have_option(base_path)) cycle + do i = 1, size(states) + ri => extract_scalar_field(states(i), "RichardsonNumber", stat) + if(stat /= SPUD_NO_ERROR) cycle + base_path = trim(complete_field_path(ri%option_path)) // "/adaptivity_options/richardson_number_metric" + if(.not. have_option(base_path)) cycle - call get_option(trim(base_path) // "/min_ri", ri_min, default = 0.0) - call get_option(trim(base_path) // "/max_ri", ri_max) - call get_option(trim(base_path) // "/min_edge_length", h_min) - call get_option(trim(base_path) // "/max_edge_length", h_max) + call get_option(trim(base_path) // "/min_ri", ri_min, default = 0.0) + call get_option(trim(base_path) // "/max_ri", ri_max) + call get_option(trim(base_path) // "/min_edge_length", h_min) + call get_option(trim(base_path) // "/max_edge_length", h_max) - call form_richardson_number_metric_internal(states(i), metric, ri_metric, ri_min, ri_max, h_min, h_max) + call form_richardson_number_metric_internal(states(i), metric, ri_metric, ri_min, ri_max, h_min, h_max) #ifdef DDEBUG - call form_anisotropic_metric_from_isotropic_metric(ri_metric, ri_metric_tensor) - call check_metric(ri_metric_tensor) - call deallocate(ri_metric_tensor) + call form_anisotropic_metric_from_isotropic_metric(ri_metric, ri_metric_tensor) + call check_metric(ri_metric_tensor) + call deallocate(ri_metric_tensor) #endif - if(have_option(trim(base_path) // "/anisotropy_preserving_merge")) then - ewrite(2, *) "Using anisotropy preserving metric merge" - call merge_isotropic_anisotropic_metrics(ri_metric, metric) - else - ewrite(2, *) "Using direct metric merge" - call form_anisotropic_metric_from_isotropic_metric(ri_metric, ri_metric_tensor) - call merge_tensor_fields(metric, ri_metric_tensor) - call deallocate(ri_metric_tensor) - end if - call deallocate(ri_metric) - end do + if(have_option(trim(base_path) // "/anisotropy_preserving_merge")) then + ewrite(2, *) "Using anisotropy preserving metric merge" + call merge_isotropic_anisotropic_metrics(ri_metric, metric) + else + ewrite(2, *) "Using direct metric merge" + call form_anisotropic_metric_from_isotropic_metric(ri_metric, ri_metric_tensor) + call merge_tensor_fields(metric, ri_metric_tensor) + call deallocate(ri_metric_tensor) + end if + call deallocate(ri_metric) + end do #ifdef DDEBUG - call check_metric(metric) + call check_metric(metric) #endif - end subroutine form_richardson_number_metric - - subroutine form_richardson_number_metric_internal(state, metric, ri_metric, ri_min, ri_max, h_min, h_max) - !! Form a length scale by a linear scaling with RichardsonNumber. - !! If ri <= ri_min, then let h = h_min - !! If ri >= ri_max, then let h = h_max - !! Else, do a linear fit. - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: metric - type(scalar_field), intent(out) :: ri_metric - real, intent(in) :: ri_min, ri_max, h_min, h_max - - type(scalar_field), pointer :: richardson_number - integer :: node - real :: eigenval, ri, h, m - - ewrite(1, *) "In form_richardson_number_metric_internal" - - call allocate(ri_metric, metric%mesh, "RichardsonNumberMetric") - call zero(ri_metric) - - richardson_number => extract_scalar_field(state, "RichardsonNumber") - - do node=1,node_count(metric) - ri = node_val(richardson_number, node) - if (ri <= ri_min) then - h = h_min - else if (ri >= ri_max) then - h = h_max - else - m = (h_max - h_min) / (ri_max - ri_min) - h = m * (ri - ri_max) + h_max - end if - if(is_nan(h)) then - ! Oops, seems we have a NaN in our Richardson number - let's assume we - ! need a maximum edge length here - h = h_max - end if + end subroutine form_richardson_number_metric + + subroutine form_richardson_number_metric_internal(state, metric, ri_metric, ri_min, ri_max, h_min, h_max) + !! Form a length scale by a linear scaling with RichardsonNumber. + !! If ri <= ri_min, then let h = h_min + !! If ri >= ri_max, then let h = h_max + !! Else, do a linear fit. + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: metric + type(scalar_field), intent(out) :: ri_metric + real, intent(in) :: ri_min, ri_max, h_min, h_max + + type(scalar_field), pointer :: richardson_number + integer :: node + real :: eigenval, ri, h, m + + ewrite(1, *) "In form_richardson_number_metric_internal" + + call allocate(ri_metric, metric%mesh, "RichardsonNumberMetric") + call zero(ri_metric) + + richardson_number => extract_scalar_field(state, "RichardsonNumber") + + do node=1,node_count(metric) + ri = node_val(richardson_number, node) + if (ri <= ri_min) then + h = h_min + else if (ri >= ri_max) then + h = h_max + else + m = (h_max - h_min) / (ri_max - ri_min) + h = m * (ri - ri_max) + h_max + end if + if(is_nan(h)) then + ! Oops, seems we have a NaN in our Richardson number - let's assume we + ! need a maximum edge length here + h = h_max + end if #ifdef DDEBUG - if(h <= 0.0) then - ewrite(-1, *) "Edge length: ", h - FLAbort("Negative edge length") - end if + if(h <= 0.0) then + ewrite(-1, *) "Edge length: ", h + FLAbort("Negative edge length") + end if #endif - eigenval = eigenvalue_from_edge_length(h) - call set(ri_metric, node, eigenval) - end do + eigenval = eigenvalue_from_edge_length(h) + call set(ri_metric, node, eigenval) + end do - ewrite(1, *) "Exiting form_richardson_number_metric_internal" + ewrite(1, *) "Exiting form_richardson_number_metric_internal" - end subroutine form_richardson_number_metric_internal + end subroutine form_richardson_number_metric_internal - subroutine merge_isotropic_anisotropic_metrics(isotropic, anisotropic) - type(scalar_field), intent(in) :: isotropic - type(tensor_field), intent(inout) :: anisotropic + subroutine merge_isotropic_anisotropic_metrics(isotropic, anisotropic) + type(scalar_field), intent(in) :: isotropic + type(tensor_field), intent(inout) :: anisotropic - integer :: i - real :: isotropic_edge_length - real, dimension(mesh_dim(anisotropic)) :: anisotropic_edge_lengths, eigenvals - real, dimension(mesh_dim(anisotropic), mesh_dim(anisotropic)) :: eigenvecs - type(scalar_field) :: edge_lengths + integer :: i + real :: isotropic_edge_length + real, dimension(mesh_dim(anisotropic)) :: anisotropic_edge_lengths, eigenvals + real, dimension(mesh_dim(anisotropic), mesh_dim(anisotropic)) :: eigenvecs + type(scalar_field) :: edge_lengths - assert(isotropic%mesh == anisotropic%mesh) + assert(isotropic%mesh == anisotropic%mesh) - call allocate(edge_lengths, anisotropic%mesh, "EdgeLengths") - call get_edge_lengths(anisotropic, edge_lengths) + call allocate(edge_lengths, anisotropic%mesh, "EdgeLengths") + call get_edge_lengths(anisotropic, edge_lengths) - do i = 1, node_count(isotropic) - call eigendecomposition_symmetric(node_val(anisotropic, i), eigenvecs, eigenvals) - anisotropic_edge_lengths = edge_length_from_eigenvalue(eigenvals) - isotropic_edge_length = edge_length_from_eigenvalue(node_val(isotropic, i)) - if(node_val(edge_lengths, i) > isotropic_edge_length) then - anisotropic_edge_lengths = anisotropic_edge_lengths * (isotropic_edge_length / node_val(edge_lengths, i)) - eigenvals = eigenvalue_from_edge_length(anisotropic_edge_lengths) - call eigenrecomposition(anisotropic%val(:, :, i), eigenvecs, eigenvals) - end if - end do + do i = 1, node_count(isotropic) + call eigendecomposition_symmetric(node_val(anisotropic, i), eigenvecs, eigenvals) + anisotropic_edge_lengths = edge_length_from_eigenvalue(eigenvals) + isotropic_edge_length = edge_length_from_eigenvalue(node_val(isotropic, i)) + if(node_val(edge_lengths, i) > isotropic_edge_length) then + anisotropic_edge_lengths = anisotropic_edge_lengths * (isotropic_edge_length / node_val(edge_lengths, i)) + eigenvals = eigenvalue_from_edge_length(anisotropic_edge_lengths) + call eigenrecomposition(anisotropic%val(:, :, i), eigenvecs, eigenvals) + end if + end do - call deallocate(edge_lengths) + call deallocate(edge_lengths) - end subroutine merge_isotropic_anisotropic_metrics + end subroutine merge_isotropic_anisotropic_metrics end module richardson_metric_module diff --git a/error_measures/tests/compute_anisotropic_gradation.F90 b/error_measures/tests/compute_anisotropic_gradation.F90 index 99501465bb..439c9391c7 100644 --- a/error_measures/tests/compute_anisotropic_gradation.F90 +++ b/error_measures/tests/compute_anisotropic_gradation.F90 @@ -1,53 +1,53 @@ subroutine compute_anisotropic_gradation - use mesh_files - use anisotropic_gradation - use mba_adapt_module - use state_module - use vtk_interfaces - - type(vector_field) :: positions - type(tensor_field) :: metric, gamma - real, dimension(2, 2) :: id, nid - type(state_type) :: state - - interface - function set_gamma(pos) - real, dimension(:) :: pos - real, dimension(size(pos), size(pos)) :: set_gamma - end function - end interface - - positions = read_mesh_files("data/laplacian_grid.2", quad_degree=4, format="gmsh") - call insert(state, positions, "Coordinate") - call insert(state, positions%mesh, "Mesh") - call allocate(metric, positions%mesh, "Metric") - - id = reshape((/1.0, 0.0, 0.0, 1.0/), (/2, 2/)) - nid = reshape((/0.1, 0.0, 0.0, 5.0/), (/2, 2/)) - - call set(metric, id) ! an isotropic edge length of 0.01 - call set(metric, 1, id * 1000000) ! an isotropic edge length of 0.001 - - call allocate(gamma, positions%mesh, "Gamma", FIELD_TYPE_NORMAL) - call set_from_function(gamma, set_gamma, positions) - - call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) - call vtk_write_state("data/anisotropic_gradation", 0, state=(/state/)) - call mba_adapt(state, metric) - call vtk_write_state("data/anisotropic_gradation", 1, state=(/state/)) + use mesh_files + use anisotropic_gradation + use mba_adapt_module + use state_module + use vtk_interfaces + + type(vector_field) :: positions + type(tensor_field) :: metric, gamma + real, dimension(2, 2) :: id, nid + type(state_type) :: state + + interface + function set_gamma(pos) + real, dimension(:) :: pos + real, dimension(size(pos), size(pos)) :: set_gamma + end function + end interface + + positions = read_mesh_files("data/laplacian_grid.2", quad_degree=4, format="gmsh") + call insert(state, positions, "Coordinate") + call insert(state, positions%mesh, "Mesh") + call allocate(metric, positions%mesh, "Metric") + + id = reshape((/1.0, 0.0, 0.0, 1.0/), (/2, 2/)) + nid = reshape((/0.1, 0.0, 0.0, 5.0/), (/2, 2/)) + + call set(metric, id) ! an isotropic edge length of 0.01 + call set(metric, 1, id * 1000000) ! an isotropic edge length of 0.001 + + call allocate(gamma, positions%mesh, "Gamma", FIELD_TYPE_NORMAL) + call set_from_function(gamma, set_gamma, positions) + + call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) + call vtk_write_state("data/anisotropic_gradation", 0, state=(/state/)) + call mba_adapt(state, metric) + call vtk_write_state("data/anisotropic_gradation", 1, state=(/state/)) end subroutine compute_anisotropic_gradation function set_gamma(pos) - real, dimension(:) :: pos - real, dimension(size(pos), size(pos)) :: set_gamma - real :: x, y + real, dimension(:) :: pos + real, dimension(size(pos), size(pos)) :: set_gamma + real :: x, y - x = pos(1); y = pos(2) + x = pos(1); y = pos(2) - set_gamma = 0.0 - set_gamma(1, 1) = max(x, 0.01) - !set_gamma(2, 2) = max(1 - x, 0.01) - set_gamma(2, 2) = 1.0 + set_gamma = 0.0 + set_gamma(1, 1) = max(x, 0.01) + !set_gamma(2, 2) = max(1 - x, 0.01) + set_gamma(2, 2) = 1.0 end function diff --git a/error_measures/tests/compute_chimney_adapt.F90 b/error_measures/tests/compute_chimney_adapt.F90 index 2cdeac6504..e501ed7e0b 100644 --- a/error_measures/tests/compute_chimney_adapt.F90 +++ b/error_measures/tests/compute_chimney_adapt.F90 @@ -11,128 +11,128 @@ subroutine compute_chimney_adapt #define VEL_SQ .false. #define NADAPT 1 - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - use field_options - use smoothing_module - implicit none - - type(state_type) :: state, dummy(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: porosity, permeability - type(scalar_field), pointer :: porosity_old, permeability_old - type(tensor_field), pointer :: metric - type(tensor_field) :: tmp_metric - type(scalar_field) :: edgelen - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - integer :: i, stat - real, dimension(3, 3)::alpha=(/0.001, 0.0, 0.0/, /0.0, 0.001, 0.0/,/0.0, 0.0, 0.001/) - - interface - function solution(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - interface - function gradsoln(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: gradsoln - end function - end interface - - call vtk_read_state("/home/gormo/reservoir.vtu", state) - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - porosity => extract_scalar_field(state, "porosity") - permeability => extract_scalar_field(state, "permeability") - - call adaptivity_options(state, porosity, TEMP_ERROR, TEMP_REL, TEMP_MIN) - porosity_old = porosity - call smooth_scalar(porosity_old, positions, porosity, alpha) - - call adaptivity_options(state, permeability, TEMP_ERROR, TEMP_REL, TEMP_MIN) - permeability_old = permeability - call smooth_scalar(permeability_old, positions, permeability, alpha) - - call allocate(tmp_metric, mesh, "Metric") - call insert(state, tmp_metric, "Metric") - call deallocate(tmp_metric) - metric => extract_tensor_field(state, "Metric") - - opts%min_edge_length = 0.002 - opts%max_edge_length = 10.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 0.00001; hminxy = 0.0; hminxz = 0.0; hminyy = 0.00001; hminyz = 0.0; hminzz = 0.00001 - hmaxxx = 0.5; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 0.5; hmaxyz = 0.0; hmaxzz = 0.4 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts - - call set_option("/mesh_adaptivity/hr_adaptivity/geometric_constraints", 1.3, stat=stat) - - dummy(1) = state - call assemble_metric(dummy, metric, opts) - state = dummy(1) - call allocate(edgelen, mesh, "Edge lengths") - call get_edge_lengths(metric, edgelen) - call insert(state, edgelen, "Edge lengths") - call deallocate(edgelen) - call vtk_write_state("data/chimney_adapt", 0, state=(/state/)) - call adapt_state(state, metric) - - do i=1,NADAPT-1 - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - porosity => extract_scalar_field(state, "porosity") - permeability => extract_scalar_field(state, "permeability") - - call adaptivity_options(state, porosity, TEMP_ERROR, TEMP_REL, TEMP_MIN) - call adaptivity_options(state, permeability, TEMP_ERROR, TEMP_REL, TEMP_MIN) - - call deallocate(metric); call allocate(metric, mesh, "Metric") - dummy(1) = state - call assemble_metric(dummy, metric, opts) - state = dummy(1) - call vtk_write_state("/tmp/reservoir_adapt", i, state=(/state/)) - call adapt_state(state, metric) - end do - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - - porosity => extract_scalar_field(state, "porosity") - permeability => extract_scalar_field(state, "permeability") - - call vtk_write_state("/tmp/reservoir_adapt", NADAPT, state=(/state/)) + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + use field_options + use smoothing_module + implicit none + + type(state_type) :: state, dummy(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: porosity, permeability + type(scalar_field), pointer :: porosity_old, permeability_old + type(tensor_field), pointer :: metric + type(tensor_field) :: tmp_metric + type(scalar_field) :: edgelen + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + integer :: i, stat + real, dimension(3, 3)::alpha=(/0.001, 0.0, 0.0/, /0.0, 0.001, 0.0/,/0.0, 0.0, 0.001/) + + interface + function solution(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + interface + function gradsoln(pos) + real, dimension(:) :: pos + real, dimension(size(pos)) :: gradsoln + end function + end interface + + call vtk_read_state("/home/gormo/reservoir.vtu", state) + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + porosity => extract_scalar_field(state, "porosity") + permeability => extract_scalar_field(state, "permeability") + + call adaptivity_options(state, porosity, TEMP_ERROR, TEMP_REL, TEMP_MIN) + porosity_old = porosity + call smooth_scalar(porosity_old, positions, porosity, alpha) + + call adaptivity_options(state, permeability, TEMP_ERROR, TEMP_REL, TEMP_MIN) + permeability_old = permeability + call smooth_scalar(permeability_old, positions, permeability, alpha) + + call allocate(tmp_metric, mesh, "Metric") + call insert(state, tmp_metric, "Metric") + call deallocate(tmp_metric) + metric => extract_tensor_field(state, "Metric") + + opts%min_edge_length = 0.002 + opts%max_edge_length = 10.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 0.00001; hminxy = 0.0; hminxz = 0.0; hminyy = 0.00001; hminyz = 0.0; hminzz = 0.00001 + hmaxxx = 0.5; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 0.5; hmaxyz = 0.0; hmaxzz = 0.4 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts + + call set_option("/mesh_adaptivity/hr_adaptivity/geometric_constraints", 1.3, stat=stat) + + dummy(1) = state + call assemble_metric(dummy, metric, opts) + state = dummy(1) + call allocate(edgelen, mesh, "Edge lengths") + call get_edge_lengths(metric, edgelen) + call insert(state, edgelen, "Edge lengths") + call deallocate(edgelen) + call vtk_write_state("data/chimney_adapt", 0, state=(/state/)) + call adapt_state(state, metric) + + do i=1,NADAPT-1 + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + porosity => extract_scalar_field(state, "porosity") + permeability => extract_scalar_field(state, "permeability") + + call adaptivity_options(state, porosity, TEMP_ERROR, TEMP_REL, TEMP_MIN) + call adaptivity_options(state, permeability, TEMP_ERROR, TEMP_REL, TEMP_MIN) + + call deallocate(metric); call allocate(metric, mesh, "Metric") + dummy(1) = state + call assemble_metric(dummy, metric, opts) + state = dummy(1) + call vtk_write_state("/tmp/reservoir_adapt", i, state=(/state/)) + call adapt_state(state, metric) + end do + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + + porosity => extract_scalar_field(state, "porosity") + permeability => extract_scalar_field(state, "permeability") + + call vtk_write_state("/tmp/reservoir_adapt", NADAPT, state=(/state/)) end subroutine compute_chimney_adapt diff --git a/error_measures/tests/compute_compare_interpolation.F90 b/error_measures/tests/compute_compare_interpolation.F90 index 76f2dbf84f..dec14f999a 100644 --- a/error_measures/tests/compute_compare_interpolation.F90 +++ b/error_measures/tests/compute_compare_interpolation.F90 @@ -1,212 +1,212 @@ subroutine compute_compare_interpolation - use fields - use mesh_files - use conservative_interpolation_module - use unittest_tools - use interpolation_module - use supermesh_construction - use vtk_interfaces - use futils - use vector_tools - use solvers - implicit none - - interface - function field_func_const(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_linear(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_quadratic(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_cubic(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_tophat(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_peaks(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - type(vector_field) :: positionsA, positionsB - type(scalar_field), dimension(2) :: c_fieldA, c_fieldB - type(scalar_field), dimension(2) :: l_fieldA, l_fieldB - type(scalar_field), dimension(2) :: analytical_fields - real, dimension(2) :: c_integral, l_integral - real, dimension(2) :: c_maxval, c_minval, l_maxval, l_minval - real, dimension(2) :: c_l2err, l_l2err - integer :: field, field_count - integer :: i - - positionsA = read_mesh_files("data/input.1", quad_degree=4, format="gmsh") - - field_count = 2 - - do field=1,field_count - call allocate(c_fieldA(field), positionsA%mesh, "Field" // int2str(field)) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" - call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_bounded" - call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" - call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) - call allocate(l_fieldA(field), positionsA%mesh, "Field" // int2str(field)) - end do - - call set_from_function(c_fieldA(1), field_func_tophat, positionsA) - call set_from_function(l_fieldA(1), field_func_tophat, positionsA) - call set_from_function(c_fieldA(2), field_func_peaks, positionsA) - call set_from_function(l_fieldA(2), field_func_peaks, positionsA) - - call vtk_write_fields("conservative_interpolation", 0, positionsA, positionsA%mesh, sfields=c_fieldA) - call vtk_write_fields("linear_interpolation", 0, positionsA, positionsA%mesh, sfields=l_fieldA) - - do i=1,99 - write(0,'(a, i0)') "loop: ", i - positionsB = read_mesh_files("data/input." // int2str(i+1), quad_degree=4, format="gmsh") - do field=1,field_count - call allocate(c_fieldB(field), positionsB%mesh, "Field" // int2str(field)) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" - call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_bounded" - call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" - call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) - call allocate(l_fieldB(field), positionsB%mesh, "Field" // int2str(field)) - end do - - call conservative_interpolation_bounded(c_fieldA, positionsA, c_fieldB, positionsB) - call linear_interpolation(l_fieldA, positionsA, l_fieldB, positionsB) - do field=1,field_count - c_integral(field) = field_integral(c_fieldB(field), positionsB) - l_integral(field) = field_integral(l_fieldB(field), positionsB) - call deallocate(c_fieldA(field)) - c_fieldA(field) = c_fieldB(field) - call deallocate(l_fieldA(field)) - l_fieldA(field) = l_fieldB(field) - end do - write(0,*) "integrals: ", i, c_integral, l_integral - - call deallocate(positionsA) - positionsA = positionsB - call vtk_write_fields("conservative_interpolation", i, positionsB, positionsB%mesh, sfields=c_fieldB) - call vtk_write_fields("linear_interpolation", i, positionsB, positionsB%mesh, sfields=l_fieldB) - - do field=1,field_count - c_maxval(field) = maxval(c_fieldB(field)) - c_minval(field) = minval(c_fieldB(field)) - l_maxval(field) = maxval(l_fieldB(field)) - l_minval(field) = minval(l_fieldB(field)) - end do - write(0,*) "maxval: ", i, c_maxval, l_maxval - write(0,*) "minval: ", i, c_minval, l_minval - - call allocate(analytical_fields(1), positionsB%mesh, "AnalyticalField1") - call allocate(analytical_fields(2), positionsB%mesh, "AnalyticalField2") - call set_from_function(analytical_fields(1), field_func_tophat, positionsB) - call set_from_function(analytical_fields(2), field_func_peaks, positionsB) - - do field=1,field_count - call addto(analytical_fields(field), c_fieldB(field), -1.0) - c_l2err(field) = norm2(analytical_fields(field), positionsB) - end do - - call set_from_function(analytical_fields(1), field_func_tophat, positionsB) - call set_from_function(analytical_fields(2), field_func_peaks, positionsB) - - do field=1,field_count - call addto(analytical_fields(field), l_fieldB(field), -1.0) - l_l2err(field) = norm2(analytical_fields(field), positionsB) - end do - - write(0,*) "l2err: ", i, c_l2err, l_l2err - - call deallocate(analytical_fields(1)) - call deallocate(analytical_fields(2)) - end do + use fields + use mesh_files + use conservative_interpolation_module + use unittest_tools + use interpolation_module + use supermesh_construction + use vtk_interfaces + use futils + use vector_tools + use solvers + implicit none + + interface + function field_func_const(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_linear(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_quadratic(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_cubic(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_tophat(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_peaks(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + type(vector_field) :: positionsA, positionsB + type(scalar_field), dimension(2) :: c_fieldA, c_fieldB + type(scalar_field), dimension(2) :: l_fieldA, l_fieldB + type(scalar_field), dimension(2) :: analytical_fields + real, dimension(2) :: c_integral, l_integral + real, dimension(2) :: c_maxval, c_minval, l_maxval, l_minval + real, dimension(2) :: c_l2err, l_l2err + integer :: field, field_count + integer :: i + + positionsA = read_mesh_files("data/input.1", quad_degree=4, format="gmsh") + + field_count = 2 + + do field=1,field_count + call allocate(c_fieldA(field), positionsA%mesh, "Field" // int2str(field)) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" + call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_bounded" + call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" + call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) + call allocate(l_fieldA(field), positionsA%mesh, "Field" // int2str(field)) + end do + + call set_from_function(c_fieldA(1), field_func_tophat, positionsA) + call set_from_function(l_fieldA(1), field_func_tophat, positionsA) + call set_from_function(c_fieldA(2), field_func_peaks, positionsA) + call set_from_function(l_fieldA(2), field_func_peaks, positionsA) + + call vtk_write_fields("conservative_interpolation", 0, positionsA, positionsA%mesh, sfields=c_fieldA) + call vtk_write_fields("linear_interpolation", 0, positionsA, positionsA%mesh, sfields=l_fieldA) + + do i=1,99 + write(0,'(a, i0)') "loop: ", i + positionsB = read_mesh_files("data/input." // int2str(i+1), quad_degree=4, format="gmsh") + do field=1,field_count + call allocate(c_fieldB(field), positionsB%mesh, "Field" // int2str(field)) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" + call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_bounded" + call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" + call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) + call allocate(l_fieldB(field), positionsB%mesh, "Field" // int2str(field)) + end do + + call conservative_interpolation_bounded(c_fieldA, positionsA, c_fieldB, positionsB) + call linear_interpolation(l_fieldA, positionsA, l_fieldB, positionsB) + do field=1,field_count + c_integral(field) = field_integral(c_fieldB(field), positionsB) + l_integral(field) = field_integral(l_fieldB(field), positionsB) + call deallocate(c_fieldA(field)) + c_fieldA(field) = c_fieldB(field) + call deallocate(l_fieldA(field)) + l_fieldA(field) = l_fieldB(field) + end do + write(0,*) "integrals: ", i, c_integral, l_integral + + call deallocate(positionsA) + positionsA = positionsB + call vtk_write_fields("conservative_interpolation", i, positionsB, positionsB%mesh, sfields=c_fieldB) + call vtk_write_fields("linear_interpolation", i, positionsB, positionsB%mesh, sfields=l_fieldB) + + do field=1,field_count + c_maxval(field) = maxval(c_fieldB(field)) + c_minval(field) = minval(c_fieldB(field)) + l_maxval(field) = maxval(l_fieldB(field)) + l_minval(field) = minval(l_fieldB(field)) + end do + write(0,*) "maxval: ", i, c_maxval, l_maxval + write(0,*) "minval: ", i, c_minval, l_minval + + call allocate(analytical_fields(1), positionsB%mesh, "AnalyticalField1") + call allocate(analytical_fields(2), positionsB%mesh, "AnalyticalField2") + call set_from_function(analytical_fields(1), field_func_tophat, positionsB) + call set_from_function(analytical_fields(2), field_func_peaks, positionsB) + + do field=1,field_count + call addto(analytical_fields(field), c_fieldB(field), -1.0) + c_l2err(field) = norm2(analytical_fields(field), positionsB) + end do + + call set_from_function(analytical_fields(1), field_func_tophat, positionsB) + call set_from_function(analytical_fields(2), field_func_peaks, positionsB) + + do field=1,field_count + call addto(analytical_fields(field), l_fieldB(field), -1.0) + l_l2err(field) = norm2(analytical_fields(field), positionsB) + end do + + write(0,*) "l2err: ", i, c_l2err, l_l2err + + call deallocate(analytical_fields(1)) + call deallocate(analytical_fields(2)) + end do end subroutine compute_compare_interpolation function field_func_const(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 1.0 + f = 1.0 end function field_func_const function field_func_linear(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1) + 3 + f = pos(1) + 3 end function field_func_linear function field_func_quadratic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 42 * pos(1)**2 + 2.0 * pos(2)**2 + 3.0 + f = 42 * pos(1)**2 + 2.0 * pos(2)**2 + 3.0 end function field_func_quadratic function field_func_cubic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 500.0 * pos(2)**3 + 201.0 * pos(1)**2 + 94.0 * pos(2) + 3.0 + f = 500.0 * pos(2)**3 + 201.0 * pos(1)**2 + 94.0 * pos(2) + 3.0 end function field_func_cubic function field_func_tophat(pos) result(f) - use vector_tools - real, dimension(:), intent(in) :: pos - real :: f - real, parameter :: PI=4.0*atan(1.0) - - real :: r - r = norm2(pos - (/0.0, 0.0/)) - if (r < 0.7) then - f = 1.0 - else - f = 0.0 - end if + use vector_tools + real, dimension(:), intent(in) :: pos + real :: f + real, parameter :: PI=4.0*atan(1.0) + + real :: r + r = norm2(pos - (/0.0, 0.0/)) + if (r < 0.7) then + f = 1.0 + else + f = 0.0 + end if end function field_func_tophat function field_func_peaks(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f - real, parameter :: PI=4.0*atan(1.0) - real :: x, y + real, dimension(:), intent(in) :: pos + real :: f + real, parameter :: PI=4.0*atan(1.0) + real :: x, y - x = pos(1); y = pos(2) + x = pos(1); y = pos(2) - f = 3 * (1-x)**2 * exp(-x**2 - (y+1)**2) - f = f - 10 * ((x/5) - x**3 - y**5 ) * exp(-x**2 -y**2) - f = f - (1.0/3) * exp(-(x+1)**2 -y**2) + f = 3 * (1-x)**2 * exp(-x**2 - (y+1)**2) + f = f - 10 * ((x/5) - x**3 - y**5 ) * exp(-x**2 -y**2) + f = f - (1.0/3) * exp(-(x+1)**2 -y**2) end function field_func_peaks diff --git a/error_measures/tests/compute_compare_interpolation_3d.F90 b/error_measures/tests/compute_compare_interpolation_3d.F90 index 2d27f6bc48..c5705e640f 100644 --- a/error_measures/tests/compute_compare_interpolation_3d.F90 +++ b/error_measures/tests/compute_compare_interpolation_3d.F90 @@ -1,183 +1,183 @@ subroutine compute_compare_interpolation_3d - use fields - use mesh_files - use conservative_interpolation_module - use unittest_tools - use interpolation_module - use supermesh_construction - use vtk_interfaces - use futils - use vector_tools - use solvers - implicit none - - interface - function field_func_const(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_linear(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_quadratic(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_cubic(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_tophat(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - interface - function field_func_peaks(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - - type(vector_field) :: positionsA, positionsB - type(scalar_field), dimension(2) :: c_fieldA, c_fieldB - type(scalar_field), dimension(2) :: l_fieldA, l_fieldB - real :: c_integral, l_integral - integer :: field, field_count - integer :: i - - positionsA = read_mesh_files("data/cube.1", quad_degree=4, format="gmsh") - - field_count = 2 - - do field=1,field_count - call allocate(c_fieldA(field), positionsA%mesh, "Field" // int2str(field)) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" - call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_bounded" - call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" - call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) - call allocate(l_fieldA(field), positionsA%mesh, "Field" // int2str(field)) - end do - - call set_from_function(c_fieldA(1), field_func_tophat, positionsA) - call set_from_function(l_fieldA(1), field_func_tophat, positionsA) - call set_from_function(c_fieldA(2), field_func_peaks, positionsA) - call set_from_function(l_fieldA(2), field_func_peaks, positionsA) - - call vtk_write_fields("conservative_interpolation", 0, positionsA, positionsA%mesh, sfields=c_fieldA) - call vtk_write_fields("linear_interpolation", 0, positionsA, positionsA%mesh, sfields=l_fieldA) - do field=1,field_count - c_integral = field_integral(c_fieldA(field), positionsA) - l_integral = field_integral(l_fieldA(field), positionsA) - write(0,*) "field: ", field, c_integral, l_integral - end do - - do i=1,1 - write(0,'(a, i0)') "loop: ", i - positionsB = read_mesh_files("data/cube." // int2str(i+1), quad_degree=4, format="gmsh") - do field=1,field_count - call allocate(c_fieldB(field), positionsB%mesh, "Field" // int2str(field)) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" - call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_bounded" - call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" - call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) - call allocate(l_fieldB(field), positionsB%mesh, "Field" // int2str(field)) - end do - - call cg_interpolation_galerkin_scalars_onfly(c_fieldA, positionsA, c_fieldB, positionsB) - call linear_interpolation(l_fieldA, positionsA, l_fieldB, positionsB) - do field=1,field_count - c_integral = field_integral(c_fieldB(field), positionsB) - l_integral = field_integral(l_fieldB(field), positionsB) + use fields + use mesh_files + use conservative_interpolation_module + use unittest_tools + use interpolation_module + use supermesh_construction + use vtk_interfaces + use futils + use vector_tools + use solvers + implicit none + + interface + function field_func_const(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_linear(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_quadratic(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_cubic(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_tophat(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + interface + function field_func_peaks(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + + type(vector_field) :: positionsA, positionsB + type(scalar_field), dimension(2) :: c_fieldA, c_fieldB + type(scalar_field), dimension(2) :: l_fieldA, l_fieldB + real :: c_integral, l_integral + integer :: field, field_count + integer :: i + + positionsA = read_mesh_files("data/cube.1", quad_degree=4, format="gmsh") + + field_count = 2 + + do field=1,field_count + call allocate(c_fieldA(field), positionsA%mesh, "Field" // int2str(field)) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" + call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_bounded" + call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" + call set_solver_options(c_fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + c_fieldA(field)%option_path = "/c_fieldA" // int2str(field) + call allocate(l_fieldA(field), positionsA%mesh, "Field" // int2str(field)) + end do + + call set_from_function(c_fieldA(1), field_func_tophat, positionsA) + call set_from_function(l_fieldA(1), field_func_tophat, positionsA) + call set_from_function(c_fieldA(2), field_func_peaks, positionsA) + call set_from_function(l_fieldA(2), field_func_peaks, positionsA) + + call vtk_write_fields("conservative_interpolation", 0, positionsA, positionsA%mesh, sfields=c_fieldA) + call vtk_write_fields("linear_interpolation", 0, positionsA, positionsA%mesh, sfields=l_fieldA) + do field=1,field_count + c_integral = field_integral(c_fieldA(field), positionsA) + l_integral = field_integral(l_fieldA(field), positionsA) write(0,*) "field: ", field, c_integral, l_integral - call deallocate(c_fieldA(field)) - c_fieldA(field) = c_fieldB(field) - call deallocate(l_fieldA(field)) - l_fieldA(field) = l_fieldB(field) - end do - - call deallocate(positionsA) - positionsA = positionsB - call vtk_write_fields("conservative_interpolation", i, positionsB, positionsB%mesh, sfields=c_fieldB) - call vtk_write_fields("linear_interpolation", i, positionsB, positionsB%mesh, sfields=l_fieldB) - end do + end do + + do i=1,1 + write(0,'(a, i0)') "loop: ", i + positionsB = read_mesh_files("data/cube." // int2str(i+1), quad_degree=4, format="gmsh") + do field=1,field_count + call allocate(c_fieldB(field), positionsB%mesh, "Field" // int2str(field)) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_galerkin" + call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_bounded" + call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) // "/prognostic/conservative_interpolation_sobolev" + call set_solver_options(c_fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + c_fieldB(field)%option_path = "/c_fieldB" // int2str(field) + call allocate(l_fieldB(field), positionsB%mesh, "Field" // int2str(field)) + end do + + call cg_interpolation_galerkin_scalars_onfly(c_fieldA, positionsA, c_fieldB, positionsB) + call linear_interpolation(l_fieldA, positionsA, l_fieldB, positionsB) + do field=1,field_count + c_integral = field_integral(c_fieldB(field), positionsB) + l_integral = field_integral(l_fieldB(field), positionsB) + write(0,*) "field: ", field, c_integral, l_integral + call deallocate(c_fieldA(field)) + c_fieldA(field) = c_fieldB(field) + call deallocate(l_fieldA(field)) + l_fieldA(field) = l_fieldB(field) + end do + + call deallocate(positionsA) + positionsA = positionsB + call vtk_write_fields("conservative_interpolation", i, positionsB, positionsB%mesh, sfields=c_fieldB) + call vtk_write_fields("linear_interpolation", i, positionsB, positionsB%mesh, sfields=l_fieldB) + end do end subroutine compute_compare_interpolation_3d function field_func_const(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 1.0 + f = 1.0 end function field_func_const function field_func_linear(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 85 * pos(1) + 23 * pos(2) + f = 85 * pos(1) + 23 * pos(2) end function field_func_linear function field_func_quadratic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 42 * pos(1)**2 + 2.0 * pos(2)**2 + 3.0 + f = 42 * pos(1)**2 + 2.0 * pos(2)**2 + 3.0 end function field_func_quadratic function field_func_cubic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 500.0 * pos(2)**3 + 201.0 * pos(1)**2 + 94.0 * pos(2) + 3.0 + f = 500.0 * pos(2)**3 + 201.0 * pos(1)**2 + 94.0 * pos(2) + 3.0 end function field_func_cubic function field_func_tophat(pos) result(f) - use vector_tools - real, dimension(:), intent(in) :: pos - real :: f - real, parameter :: PI=4.0*atan(1.0) - - real :: r - r = norm2(pos(:2) - (/0.0, 0.0/)) - if (r < 0.7) then - f = 1.0 - else - f = 0.0 - end if - f = 1.0 + use vector_tools + real, dimension(:), intent(in) :: pos + real :: f + real, parameter :: PI=4.0*atan(1.0) + + real :: r + r = norm2(pos(:2) - (/0.0, 0.0/)) + if (r < 0.7) then + f = 1.0 + else + f = 0.0 + end if + f = 1.0 end function field_func_tophat function field_func_peaks(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f - real, parameter :: PI=4.0*atan(1.0) - real :: x, y + real, dimension(:), intent(in) :: pos + real :: f + real, parameter :: PI=4.0*atan(1.0) + real :: x, y - x = pos(1); y = pos(2) + x = pos(1); y = pos(2) - f = 3 * (1-x)**2 * exp(-x**2 - (y+1)**2) - f = f - 10 * ((x/5) - x**3 - y**5 ) * exp(-x**2 -y**2) - f = f - (1.0/3) * exp(-(x+1)**2 -y**2) + f = 3 * (1-x)**2 * exp(-x**2 - (y+1)**2) + f = f - 10 * ((x/5) - x**3 - y**5 ) * exp(-x**2 -y**2) + f = f - (1.0/3) * exp(-(x+1)**2 -y**2) end function field_func_peaks diff --git a/error_measures/tests/compute_driven_cavity_adapt.F90 b/error_measures/tests/compute_driven_cavity_adapt.F90 index 13e1da769f..0025082890 100644 --- a/error_measures/tests/compute_driven_cavity_adapt.F90 +++ b/error_measures/tests/compute_driven_cavity_adapt.F90 @@ -2,64 +2,64 @@ subroutine compute_driven_cavity_adapt - use unittest_tools - use metric_assemble - use fields - use state_module - use vtk_interfaces - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use field_options - implicit none + use unittest_tools + use metric_assemble + use fields + use state_module + use vtk_interfaces + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use field_options + implicit none - type(state_type) :: state(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(vector_field), pointer :: velocity - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp + type(state_type) :: state(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(vector_field), pointer :: velocity + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp - call vtk_read_state("data/driven_cavity_58.vtu", state(1)) - mesh => extract_mesh(state(1), "Mesh") - positions => extract_vector_field(state(1), "Coordinate") - velocity => extract_vector_field(state(1), "Velocity") + call vtk_read_state("data/driven_cavity_58.vtu", state(1)) + mesh => extract_mesh(state(1), "Mesh") + positions => extract_vector_field(state(1), "Coordinate") + velocity => extract_vector_field(state(1), "Velocity") - call adaptivity_options(state(1), velocity, (/0.00125, 0.00125, 0.0/), .false.) - call allocate(metric, mesh, "ErrorMetric") + call adaptivity_options(state(1), velocity, (/0.00125, 0.00125, 0.0/), .false.) + call allocate(metric, mesh, "ErrorMetric") - opts%min_edge_length = 0.01 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 0.002; hminxy = 0.0; hminxz = 0.0; hminyy = 0.002; hminyz = 0.0; hminzz = 0.005 - hmaxxx = 0.1; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 0.1; hmaxyz = 0.0; hmaxzz = 0.02 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.01 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 0.002; hminxy = 0.0; hminxz = 0.0; hminyy = 0.002; hminyz = 0.0; hminzz = 0.005 + hmaxxx = 0.1; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 0.1; hmaxyz = 0.0; hmaxzz = 0.02 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - call assemble_metric(state, metric, opts) - call vtk_write_state("data/driven_cavity_adapt", 0, state=state) - call adapt_state(state(1), metric) - call vtk_write_state("data/driven_cavity_adapt", 1, state=state) + call assemble_metric(state, metric, opts) + call vtk_write_state("data/driven_cavity_adapt", 0, state=state) + call adapt_state(state(1), metric) + call vtk_write_state("data/driven_cavity_adapt", 1, state=state) - call deallocate(metric) - call deallocate(state(1)) + call deallocate(metric) + call deallocate(state(1)) end subroutine compute_driven_cavity_adapt diff --git a/error_measures/tests/compute_enstrophy_goal.F90 b/error_measures/tests/compute_enstrophy_goal.F90 index 7e6fb410eb..b1c937d968 100644 --- a/error_measures/tests/compute_enstrophy_goal.F90 +++ b/error_measures/tests/compute_enstrophy_goal.F90 @@ -1,112 +1,112 @@ subroutine compute_enstrophy_goal - use global_parameters, only: current_debug_level, pseudo2d_coord + use global_parameters, only: current_debug_level, pseudo2d_coord ! use metric_assemble - use goal_metric - use goals - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - implicit none + use goal_metric + use goals + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + implicit none - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: temperature - type(vector_field), pointer :: velocity - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - integer :: i + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: temperature + type(vector_field), pointer :: velocity + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + integer :: i - goal_tolerance = 0.5e-5 - allocate(goal_deps(3)) - goal_deps(1) = "Velocity1" - goal_deps(2) = "Velocity2" - goal_deps(3) = "Velocity3" + goal_tolerance = 0.5e-5 + allocate(goal_deps(3)) + goal_deps(1) = "Velocity1" + goal_deps(2) = "Velocity2" + goal_deps(3) = "Velocity3" - pseudo2d_coord = 2 - call vtk_read_state("data/lock_exchange.vtu", state) - dt = 0.005 + pseudo2d_coord = 2 + call vtk_read_state("data/lock_exchange.vtu", state) + dt = 0.005 - mesh => extract_mesh(state, "Mesh") + mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - call allocate(metric, mesh, "Metric") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.0005 - opts%max_edge_length = 2.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 - hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.0005 + opts%max_edge_length = 2.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 + hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.2 - state_array(1) = state - write(0,*) "goal_enstrophy(state) == ", goal_enstrophy(state_array) - call form_goal_metric(state_array, metric, goal_enstrophy, goal_enstrophy_grad, opts) - call form_gradation_metric(positions, metric) - call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - temperature => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/temperature/), & - vfields=(/velocity/)) + gamma0 = 1.2 + state_array(1) = state + write(0,*) "goal_enstrophy(state) == ", goal_enstrophy(state_array) + call form_goal_metric(state_array, metric, goal_enstrophy, goal_enstrophy_grad, opts) + call form_gradation_metric(positions, metric) + call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + temperature => extract_scalar_field(state, "Temperature") + call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/temperature/), & + vfields=(/velocity/)) - do i=1,0 - write(0,*) "i == ", i - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - temperature => extract_scalar_field(state, "Temperature") - call deallocate(metric); call allocate(metric, mesh, "Metric") - state_array(1) = state - call form_goal_metric(state_array, metric, goal_enstrophy, goal_enstrophy_grad, opts) - call form_gradation_metric(positions, metric) - call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/temperature/), & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - end do + do i=1,0 + write(0,*) "i == ", i + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + temperature => extract_scalar_field(state, "Temperature") + call deallocate(metric); call allocate(metric, mesh, "Metric") + state_array(1) = state + call form_goal_metric(state_array, metric, goal_enstrophy, goal_enstrophy_grad, opts) + call form_gradation_metric(positions, metric) + call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/temperature/), & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + end do - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - temperature => extract_scalar_field(state, "Temperature") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + temperature => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/temperature/), vfields=(/velocity/)) + call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/temperature/), vfields=(/velocity/)) - state_array(1) = state - write(0,*) "goal_enstrophy(state) == ", goal_enstrophy(state_array) + state_array(1) = state + write(0,*) "goal_enstrophy(state) == ", goal_enstrophy(state_array) - deallocate(goal_deps) + deallocate(goal_deps) end subroutine compute_enstrophy_goal diff --git a/error_measures/tests/compute_hessian_error.F90 b/error_measures/tests/compute_hessian_error.F90 index 83172be5d9..cb8f1e2185 100644 --- a/error_measures/tests/compute_hessian_error.F90 +++ b/error_measures/tests/compute_hessian_error.F90 @@ -2,108 +2,108 @@ subroutine compute_hessian_error - use mesh_files - use field_derivatives - use fields - use matrix_norms - use vtk_interfaces - use global_parameters - use state_module - implicit none + use mesh_files + use field_derivatives + use fields + use matrix_norms + use vtk_interfaces + use global_parameters + use state_module + implicit none ! type(quadrature_type) :: quad ! type(element_type) :: x_shape - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(tensor_field) :: hessian, ex_hessian - type(state_type) :: state - integer :: i, node - - real :: h - - interface - function exact_field(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val - end function exact_field - end interface - - interface - function exact_hessian(pos) result(hess) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos), size(pos)) :: hess - end function exact_hessian - end interface + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(tensor_field) :: hessian, ex_hessian + type(state_type) :: state + integer :: i, node + + real :: h + + interface + function exact_field(pos) result(val) + real, dimension(:), intent(in) :: pos + real :: val + end function exact_field + end interface + + interface + function exact_hessian(pos) result(hess) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos), size(pos)) :: hess + end function exact_hessian + end interface ! quad = make_quadrature(vertices = DIMENSION+1, dim =DIMENSION, degree=8) ! x_shape = make_element_shape(vertices = DIMENSION+1, dim =DIMENSION, degree=1, quad=quad) ! positions = read_mesh_files("data/square.1", x_shape, format="gmsh") - pseudo2d_coord = 3 - - call vtk_read_state("data/stretchedjack-itv20.vtu", state) - positions => extract_vector_field(state, "Coordinate") - - call allocate(field, positions%mesh, "Field") - call allocate(hessian, positions%mesh, "Hessian") - call allocate(ex_hessian, positions%mesh, "Exact Hessian") - - call set_from_function(field, exact_field, positions) - call set_from_function(ex_hessian, exact_hessian, positions) - - call compute_hessian_qf(field, positions, hessian) - if (pseudo2d_coord /= 0) then - do node=1,node_count(hessian) - hessian%val(pseudo2d_coord, :, node) = 0.0 - hessian%val(:, pseudo2d_coord, node) = 0.0 - end do - end if - - do i=1,node_count(positions) - hessian%val(:, :, i) = hessian%val(:, :, i) - ex_hessian%val(:, :, i) - end do - - h = sqrt(1.0 / ele_count(positions)) ! Area / elements - - write(0,*) "h: ", h - write(0,*) "-------------- QF ---------------" - write(0,*) "one: ", one_norm(hessian) - write(0,*) "two: ", two_norm(hessian) - write(0,*) "inf: ", inf_norm(hessian) - - call compute_hessian_eqf(field, positions, hessian) - if (pseudo2d_coord /= 0) then - do node=1,node_count(hessian) - hessian%val(pseudo2d_coord, :, node) = 0.0 - hessian%val(:, pseudo2d_coord, node) = 0.0 - end do - end if - - do i=1,node_count(positions) - hessian%val(:, :, i) = hessian%val(:, :, i) - ex_hessian%val(:, :, i) - end do - - write(0,*) "-------------- EQF ---------------" - write(0,*) "one: ", one_norm(hessian) - write(0,*) "two: ", two_norm(hessian) - write(0,*) "inf: ", inf_norm(hessian) - - call compute_hessian_var(field, positions, hessian) - if (pseudo2d_coord /= 0) then - do node=1,node_count(hessian) - hessian%val(pseudo2d_coord, :, node) = 0.0 - hessian%val(:, pseudo2d_coord, node) = 0.0 - end do - end if - - do i=1,node_count(positions) - hessian%val(:, :, i) = hessian%val(:, :, i) - ex_hessian%val(:, :, i) - end do - - write(0,*) "-------------- VAR ---------------" - write(0,*) "one: ", one_norm(hessian) - write(0,*) "two: ", two_norm(hessian) - write(0,*) "inf: ", inf_norm(hessian) + pseudo2d_coord = 3 + + call vtk_read_state("data/stretchedjack-itv20.vtu", state) + positions => extract_vector_field(state, "Coordinate") + + call allocate(field, positions%mesh, "Field") + call allocate(hessian, positions%mesh, "Hessian") + call allocate(ex_hessian, positions%mesh, "Exact Hessian") + + call set_from_function(field, exact_field, positions) + call set_from_function(ex_hessian, exact_hessian, positions) + + call compute_hessian_qf(field, positions, hessian) + if (pseudo2d_coord /= 0) then + do node=1,node_count(hessian) + hessian%val(pseudo2d_coord, :, node) = 0.0 + hessian%val(:, pseudo2d_coord, node) = 0.0 + end do + end if + + do i=1,node_count(positions) + hessian%val(:, :, i) = hessian%val(:, :, i) - ex_hessian%val(:, :, i) + end do + + h = sqrt(1.0 / ele_count(positions)) ! Area / elements + + write(0,*) "h: ", h + write(0,*) "-------------- QF ---------------" + write(0,*) "one: ", one_norm(hessian) + write(0,*) "two: ", two_norm(hessian) + write(0,*) "inf: ", inf_norm(hessian) + + call compute_hessian_eqf(field, positions, hessian) + if (pseudo2d_coord /= 0) then + do node=1,node_count(hessian) + hessian%val(pseudo2d_coord, :, node) = 0.0 + hessian%val(:, pseudo2d_coord, node) = 0.0 + end do + end if + + do i=1,node_count(positions) + hessian%val(:, :, i) = hessian%val(:, :, i) - ex_hessian%val(:, :, i) + end do + + write(0,*) "-------------- EQF ---------------" + write(0,*) "one: ", one_norm(hessian) + write(0,*) "two: ", two_norm(hessian) + write(0,*) "inf: ", inf_norm(hessian) + + call compute_hessian_var(field, positions, hessian) + if (pseudo2d_coord /= 0) then + do node=1,node_count(hessian) + hessian%val(pseudo2d_coord, :, node) = 0.0 + hessian%val(:, pseudo2d_coord, node) = 0.0 + end do + end if + + do i=1,node_count(positions) + hessian%val(:, :, i) = hessian%val(:, :, i) - ex_hessian%val(:, :, i) + end do + + write(0,*) "-------------- VAR ---------------" + write(0,*) "one: ", one_norm(hessian) + write(0,*) "two: ", two_norm(hessian) + write(0,*) "inf: ", inf_norm(hessian) end subroutine compute_hessian_error !function exact_field(pos) result(val) @@ -130,23 +130,23 @@ end subroutine compute_hessian_error !end function exact_hessian function exact_field(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val - real :: x, y, z + real, dimension(:), intent(in) :: pos + real :: val + real :: x, y, z - x = pos(1); y = pos(2); z = pos(3) - val = exp(-100 * ((x - 0.5)**2 + (y - 0.5)**2)) + x = pos(1); y = pos(2); z = pos(3) + val = exp(-100 * ((x - 0.5)**2 + (y - 0.5)**2)) end function exact_field function exact_hessian(pos) result(hess) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos), size(pos)) :: hess - real :: x, y, z - x = pos(1); y = pos(2); z = pos(3) - - hess = 0.0 - hess(1, 1) = 40000*(x - 0.5)**2*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) - 200*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) - hess(1, 2) = 40000*(x - 0.5)*(y - 0.5)*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) - hess(2, 1) = hess(1, 2) - hess(2, 2) = 40000*(y - 0.5)**2*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) - 200*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos), size(pos)) :: hess + real :: x, y, z + x = pos(1); y = pos(2); z = pos(3) + + hess = 0.0 + hess(1, 1) = 40000*(x - 0.5)**2*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) - 200*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) + hess(1, 2) = 40000*(x - 0.5)*(y - 0.5)*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) + hess(2, 1) = hess(1, 2) + hess(2, 2) = 40000*(y - 0.5)**2*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) - 200*exp(-100*((y - 0.5)**2 + (x - 0.5)**2)) end function exact_hessian diff --git a/error_measures/tests/compute_interpolation_error_adapt.F90 b/error_measures/tests/compute_interpolation_error_adapt.F90 index 4e7a01d0f1..fc942f0a6c 100644 --- a/error_measures/tests/compute_interpolation_error_adapt.F90 +++ b/error_measures/tests/compute_interpolation_error_adapt.F90 @@ -1,144 +1,144 @@ subroutine compute_interpolation_error_adapt #define ERROR 0.025 - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(scalar_field), pointer :: field_ptr - type(tensor_field) :: metric, hessian - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - real :: inf, l2, h1 - integer :: i - - interface - function solution(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - interface - function gradsoln(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: gradsoln - end function - end interface - - pseudo2d_coord = 3 - call vtk_read_state("data/mymesh.vtu", state) - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") - call zero(field) - call set_from_function(field, solution, positions) - call insert(state, field, "Field") - field_ptr => extract_scalar_field(state, "Field") - - call allocate(metric, mesh, "Metric") - call allocate(hessian, mesh, "Hessian") - - opts%min_edge_length = 0.0005 - opts%max_edge_length = 2.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 0.0005; hminxy = 0.0; hminxz = 0.0; hminyy = 0.0005; hminyz = 0.0; hminzz = 0.00025 - hmaxxx = 1.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0; hmaxyz = 0.0; hmaxzz = 0.002 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts - - gamma0 = 2.5 - use_gradation_metric = .true. - gradation_initialised = .true. - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/interpolation_error_adapted", 0, positions, mesh, & - sfields=(/field/), tfields=(/metric/)) - call adapt_state(state, metric) - - do i=1,3 - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - field_ptr => extract_scalar_field(state, "Field") - call set_from_function(field_ptr, solution, positions) - call deallocate(metric); call allocate(metric, mesh, "Metric") - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/interpolation_error_adapted", i, positions, mesh, & - sfields=(/field_ptr/)) - call adapt_state(state, metric) - end do - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - field_ptr => extract_scalar_field(state, "Field") - - write(0,*) ele_ngi(field_ptr, 1) - call set_from_function(field_ptr, solution, positions) - inf = compute_interpolation_error_inf(solution, field_ptr, positions) - l2 = compute_interpolation_error_l2(solution, field_ptr, positions) - h1 = compute_interpolation_error_h1(gradsoln, field_ptr, positions) - call vtk_write_fields("data/interpolation_error_adapted", 4, positions, mesh, sfields=(/field_ptr/)) - write(0,*) "inf: (", mesh%nodes, ", ", inf, ")" - write(0,*) "l2: (", mesh%nodes, ", ", l2, ")" - write(0,*) "h1: (", mesh%nodes, ", ", h1, ")" + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(scalar_field), pointer :: field_ptr + type(tensor_field) :: metric, hessian + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + real :: inf, l2, h1 + integer :: i + + interface + function solution(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + interface + function gradsoln(pos) + real, dimension(:) :: pos + real, dimension(size(pos)) :: gradsoln + end function + end interface + + pseudo2d_coord = 3 + call vtk_read_state("data/mymesh.vtu", state) + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") + call zero(field) + call set_from_function(field, solution, positions) + call insert(state, field, "Field") + field_ptr => extract_scalar_field(state, "Field") + + call allocate(metric, mesh, "Metric") + call allocate(hessian, mesh, "Hessian") + + opts%min_edge_length = 0.0005 + opts%max_edge_length = 2.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 0.0005; hminxy = 0.0; hminxz = 0.0; hminyy = 0.0005; hminyz = 0.0; hminzz = 0.00025 + hmaxxx = 1.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0; hmaxyz = 0.0; hmaxzz = 0.002 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts + + gamma0 = 2.5 + use_gradation_metric = .true. + gradation_initialised = .true. + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/interpolation_error_adapted", 0, positions, mesh, & + sfields=(/field/), tfields=(/metric/)) + call adapt_state(state, metric) + + do i=1,3 + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + field_ptr => extract_scalar_field(state, "Field") + call set_from_function(field_ptr, solution, positions) + call deallocate(metric); call allocate(metric, mesh, "Metric") + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/interpolation_error_adapted", i, positions, mesh, & + sfields=(/field_ptr/)) + call adapt_state(state, metric) + end do + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + field_ptr => extract_scalar_field(state, "Field") + + write(0,*) ele_ngi(field_ptr, 1) + call set_from_function(field_ptr, solution, positions) + inf = compute_interpolation_error_inf(solution, field_ptr, positions) + l2 = compute_interpolation_error_l2(solution, field_ptr, positions) + h1 = compute_interpolation_error_h1(gradsoln, field_ptr, positions) + call vtk_write_fields("data/interpolation_error_adapted", 4, positions, mesh, sfields=(/field_ptr/)) + write(0,*) "inf: (", mesh%nodes, ", ", inf, ")" + write(0,*) "l2: (", mesh%nodes, ", ", l2, ")" + write(0,*) "h1: (", mesh%nodes, ", ", h1, ")" end subroutine compute_interpolation_error_adapt function solution(pos) - real :: solution - real, dimension(:) :: pos - real :: x,y,z - real, parameter :: PI=4.0*atan(1.0) - x = pos(1); y = pos(2); z = pos(3) + real :: solution + real, dimension(:) :: pos + real :: x,y,z + real, parameter :: PI=4.0*atan(1.0) + x = pos(1); y = pos(2); z = pos(3) - solution = cos(11*PI*x) + sin(PI*(2*y + 1)/2)/PI + solution = cos(11*PI*x) + sin(PI*(2*y + 1)/2)/PI end function solution function gradsoln(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: gradsoln - real :: x, y, z, dx, dy, dz - - x = pos(1); y = pos(2); z = pos(3) - dx = 2*x*y - 20.0*sech(10.0*(sin(5.0*y) - 2.0*x))**2 - dy = 50.0*cos(5.0*y)*sech(10.0*(sin(5.0*y) - 2.0*x))**2 + 3*y**2 + x**2 - dz = 0.0 - gradsoln(1) = dx; gradsoln(2) = dy; gradsoln(3) = dz + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: gradsoln + real :: x, y, z, dx, dy, dz + + x = pos(1); y = pos(2); z = pos(3) + dx = 2*x*y - 20.0*sech(10.0*(sin(5.0*y) - 2.0*x))**2 + dy = 50.0*cos(5.0*y)*sech(10.0*(sin(5.0*y) - 2.0*x))**2 + 3*y**2 + x**2 + dz = 0.0 + gradsoln(1) = dx; gradsoln(2) = dy; gradsoln(3) = dz end function gradsoln function sech(x) - real, intent(in) :: x - real :: sech + real, intent(in) :: x + real :: sech - sech = 1.0 / cosh(x) + sech = 1.0 / cosh(x) end function sech diff --git a/error_measures/tests/compute_interpolation_error_noadapt.F90 b/error_measures/tests/compute_interpolation_error_noadapt.F90 index 48e51a7ace..4a4b2827d6 100644 --- a/error_measures/tests/compute_interpolation_error_noadapt.F90 +++ b/error_measures/tests/compute_interpolation_error_noadapt.F90 @@ -1,76 +1,76 @@ subroutine compute_interpolation_error_noadapt - use metric_assemble - use adapt_state_module - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - implicit none + use metric_assemble + use adapt_state_module + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - real :: inf, l2, h1 + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + real :: inf, l2, h1 - interface - function solution(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - interface - function gradsoln(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: gradsoln - end function - end interface + interface + function solution(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + interface + function gradsoln(pos) + real, dimension(:) :: pos + real, dimension(size(pos)) :: gradsoln + end function + end interface - call vtk_read_state("data/1x1square.vtu", state) + call vtk_read_state("data/1x1square.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") - call set_from_function(field, solution, positions) + call set_from_function(field, solution, positions) - inf = compute_interpolation_error_inf(solution, field, positions) - l2 = compute_interpolation_error_l2(solution, field, positions) - h1 = compute_interpolation_error_h1(gradsoln, field, positions) - write(0,*) "inf: (", mesh%nodes, ", ", inf, ")" - write(0,*) "l2: (", mesh%nodes, ", ", l2, ")" - write(0,*) "h1: (", mesh%nodes, ", ", h1, ")" + inf = compute_interpolation_error_inf(solution, field, positions) + l2 = compute_interpolation_error_l2(solution, field, positions) + h1 = compute_interpolation_error_h1(gradsoln, field, positions) + write(0,*) "inf: (", mesh%nodes, ", ", inf, ")" + write(0,*) "l2: (", mesh%nodes, ", ", l2, ")" + write(0,*) "h1: (", mesh%nodes, ", ", h1, ")" end subroutine compute_interpolation_error_noadapt function solution(pos) - real :: solution - real, dimension(:) :: pos - x = pos(1); y = pos(2); z = pos(3) + real :: solution + real, dimension(:) :: pos + x = pos(1); y = pos(2); z = pos(3) - solution = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) + 4.0 + solution = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) + 4.0 end function solution function gradsoln(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: gradsoln - real :: x, y, z, dx, dy, dz + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: gradsoln + real :: x, y, z, dx, dy, dz - x = pos(1); y = pos(2); z = pos(3) - dx = 2*x*y - 20.0*sech(10.0*(sin(5.0*y) - 2.0*x))**2 - dy = 50.0*cos(5.0*y)*sech(10.0*(sin(5.0*y) - 2.0*x))**2 + 3*y**2 + x**2 - dz = 0.0 - gradsoln(1) = dx; gradsoln(2) = dy; gradsoln(3) = dz + x = pos(1); y = pos(2); z = pos(3) + dx = 2*x*y - 20.0*sech(10.0*(sin(5.0*y) - 2.0*x))**2 + dy = 50.0*cos(5.0*y)*sech(10.0*(sin(5.0*y) - 2.0*x))**2 + 3*y**2 + x**2 + dz = 0.0 + gradsoln(1) = dx; gradsoln(2) = dy; gradsoln(3) = dz end function gradsoln function sech(x) - real, intent(in) :: x - real :: sech + real, intent(in) :: x + real :: sech - sech = 1.0 / cosh(x) + sech = 1.0 / cosh(x) end function sech diff --git a/error_measures/tests/compute_les_temp_goal.F90 b/error_measures/tests/compute_les_temp_goal.F90 index f60caa314a..cac7a224b9 100644 --- a/error_measures/tests/compute_les_temp_goal.F90 +++ b/error_measures/tests/compute_les_temp_goal.F90 @@ -1,110 +1,110 @@ subroutine compute_les_temp_goal - use global_parameters, only: current_debug_level, pseudo2d_coord + use global_parameters, only: current_debug_level, pseudo2d_coord ! use metric_assemble - use goal_metric - use goals - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - implicit none + use goal_metric + use goals + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + implicit none - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: les - type(vector_field), pointer :: velocity - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - integer :: i + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: les + type(vector_field), pointer :: velocity + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + integer :: i - goal_rel_tolerance = 0.025 - allocate(goal_deps(1)) - goal_deps(1) = "Temperature" + goal_rel_tolerance = 0.025 + allocate(goal_deps(1)) + goal_deps(1) = "Temperature" - pseudo2d_coord = 2 - call vtk_read_state("data/lock_exchange.vtu", state) - dt = 0.005 + pseudo2d_coord = 2 + call vtk_read_state("data/lock_exchange.vtu", state) + dt = 0.005 - mesh => extract_mesh(state, "Mesh") + mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - call allocate(metric, mesh, "Metric") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.0005 - opts%max_edge_length = 2.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 - hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.0005 + opts%max_edge_length = 2.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 + hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.5 - state_array(1) = state - write(0,*) "goal_les_temp(state) == ", goal_les_temp(state_array) - call form_goal_metric(state_array, metric, goal_les_temp, goal_les_temp_grad, opts) - call form_gradation_metric(positions, metric) - call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - les => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/les/), & - vfields=(/velocity/)) + gamma0 = 1.5 + state_array(1) = state + write(0,*) "goal_les_temp(state) == ", goal_les_temp(state_array) + call form_goal_metric(state_array, metric, goal_les_temp, goal_les_temp_grad, opts) + call form_gradation_metric(positions, metric) + call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + les => extract_scalar_field(state, "Temperature") + call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/les/), & + vfields=(/velocity/)) - do i=1,0 - write(0,*) "i == ", i - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - les => extract_scalar_field(state, "Temperature") - call deallocate(metric); call allocate(metric, mesh, "Metric") - state_array(1) = state - call form_goal_metric(state_array, metric, goal_les_temp, goal_les_temp_grad, opts) - call form_gradation_metric(positions, metric) - call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/les/), & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - end do + do i=1,0 + write(0,*) "i == ", i + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + les => extract_scalar_field(state, "Temperature") + call deallocate(metric); call allocate(metric, mesh, "Metric") + state_array(1) = state + call form_goal_metric(state_array, metric, goal_les_temp, goal_les_temp_grad, opts) + call form_gradation_metric(positions, metric) + call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/les/), & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + end do - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - les => extract_scalar_field(state, "Temperature") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + les => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/les/), vfields=(/velocity/)) + call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/les/), vfields=(/velocity/)) - state_array(1) = state - write(0,*) "goal_les_temp(state) == ", goal_les_temp(state_array) + state_array(1) = state + write(0,*) "goal_les_temp(state) == ", goal_les_temp(state_array) - deallocate(goal_deps) + deallocate(goal_deps) end subroutine compute_les_temp_goal diff --git a/error_measures/tests/compute_les_velocity_goal.F90 b/error_measures/tests/compute_les_velocity_goal.F90 index f4a704c521..cea10ef06f 100644 --- a/error_measures/tests/compute_les_velocity_goal.F90 +++ b/error_measures/tests/compute_les_velocity_goal.F90 @@ -1,117 +1,117 @@ subroutine compute_les_velocity_goal - use global_parameters, only: current_debug_level, pseudo2d_coord + use global_parameters, only: current_debug_level, pseudo2d_coord ! use metric_assemble - use goal_metric - use goals - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - implicit none + use goal_metric + use goals + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + implicit none - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: les - type(vector_field), pointer :: velocity - type(scalar_field) :: edgelen - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - integer :: i + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: les + type(vector_field), pointer :: velocity + type(scalar_field) :: edgelen + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + integer :: i - goal_rel_tolerance = 0.20 - allocate(goal_deps(3)) - goal_deps(1) = "NonlinearVelocity%1" - goal_deps(2) = "NonlinearVelocity%2" - goal_deps(3) = "NonlinearVelocity%3" + goal_rel_tolerance = 0.20 + allocate(goal_deps(3)) + goal_deps(1) = "NonlinearVelocity%1" + goal_deps(2) = "NonlinearVelocity%2" + goal_deps(3) = "NonlinearVelocity%3" - pseudo2d_coord = 2 - call vtk_read_state("data/lock_exchange.vtu", state) - dt = 0.025 + pseudo2d_coord = 2 + call vtk_read_state("data/lock_exchange.vtu", state) + dt = 0.025 - mesh => extract_mesh(state, "Mesh") + mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - call allocate(metric, mesh, "Metric") - call allocate(edgelen, mesh, "Edge lengths") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + call allocate(metric, mesh, "Metric") + call allocate(edgelen, mesh, "Edge lengths") - opts%min_edge_length = 0.0005 - opts%max_edge_length = 2.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 - hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.0005 + opts%max_edge_length = 2.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 + hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.5 - state_array(1) = state - write(0,*) "goal_les_velocity(state) == ", goal_les_velocity(state_array) - call form_goal_metric(state_array, metric, goal_les_velocity, goal_les_velocity_grad, opts) - call form_gradation_metric(positions, metric) - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, sfields=(/edgelen/), & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - les => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/les/), & - vfields=(/velocity/)) + gamma0 = 1.5 + state_array(1) = state + write(0,*) "goal_les_velocity(state) == ", goal_les_velocity(state_array) + call form_goal_metric(state_array, metric, goal_les_velocity, goal_les_velocity_grad, opts) + call form_gradation_metric(positions, metric) + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, sfields=(/edgelen/), & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + les => extract_scalar_field(state, "Temperature") + call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/les/), & + vfields=(/velocity/)) - do i=1,10 - write(0,*) "i == ", i - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - les => extract_scalar_field(state, "Temperature") - call deallocate(metric); call allocate(metric, mesh, "Metric") - call deallocate(edgelen); call allocate(edgelen, mesh, "Edge lengths") - state_array(1) = state - call form_goal_metric(state_array, metric, goal_les_velocity, goal_les_velocity_grad, opts) - call form_gradation_metric(positions, metric) - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/les, edgelen/), & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - end do + do i=1,10 + write(0,*) "i == ", i + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + les => extract_scalar_field(state, "Temperature") + call deallocate(metric); call allocate(metric, mesh, "Metric") + call deallocate(edgelen); call allocate(edgelen, mesh, "Edge lengths") + state_array(1) = state + call form_goal_metric(state_array, metric, goal_les_velocity, goal_les_velocity_grad, opts) + call form_gradation_metric(positions, metric) + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/les, edgelen/), & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + end do - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - les => extract_scalar_field(state, "Temperature") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + les => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/les/), vfields=(/velocity/)) + call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/les/), vfields=(/velocity/)) - state_array(1) = state - write(0,*) "goal_les_velocity(state) == ", goal_les_velocity(state_array) + state_array(1) = state + write(0,*) "goal_les_velocity(state) == ", goal_les_velocity(state_array) - deallocate(goal_deps) + deallocate(goal_deps) end subroutine compute_les_velocity_goal diff --git a/error_measures/tests/compute_mesh_conformity.F90 b/error_measures/tests/compute_mesh_conformity.F90 index 416c15c73b..fdceb8486c 100644 --- a/error_measures/tests/compute_mesh_conformity.F90 +++ b/error_measures/tests/compute_mesh_conformity.F90 @@ -2,70 +2,70 @@ subroutine compute_mesh_conformity - use global_parameters, only: current_debug_level, pseudo2d_coord - use unittest_tools - use metric_assemble - use edge_length_module - use fields - use state_module - use vtk_interfaces - use adapt_state_module - use form_metric_field - use conformity_measurement - use field_options + use global_parameters, only: current_debug_level, pseudo2d_coord + use unittest_tools + use metric_assemble + use edge_length_module + use fields + use state_module + use vtk_interfaces + use adapt_state_module + use form_metric_field + use conformity_measurement + use field_options #ifdef HAVE_MPI - use mpi + use mpi #endif - implicit none + implicit none - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: pressure, edgelen - type(tensor_field) :: metric - type(metric_options) :: opts + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: pressure, edgelen + type(tensor_field) :: metric + type(metric_options) :: opts - integer :: i - real :: x, y, z + integer :: i + real :: x, y, z - current_debug_level = 0 - pseudo2d_coord = 3 + current_debug_level = 0 + pseudo2d_coord = 3 - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(pressure, mesh, "Pressure") - call allocate(edgelen, mesh, "Edge lengths") - call allocate(metric, mesh, "Metric") + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(pressure, mesh, "Pressure") + call allocate(edgelen, mesh, "Edge lengths") + call allocate(metric, mesh, "Metric") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) ! if (x == 0.0) pressure%val(i) = 0.0 ! if (x <= 3.0) pressure%val(i) = x * 1.0e6 ! ramp up .. rapidly ! if (x > 3.0) pressure%val(i) = 3.0 * 1.0e6 - pressure%val(i) = x * x - end do + pressure%val(i) = x * x + end do - call adaptivity_options(state, pressure, 0.05, .false.) + call adaptivity_options(state, pressure, 0.05, .false.) - call insert(state, pressure, "Pressure") - positions => extract_vector_field(state, "Coordinate") + call insert(state, pressure, "Pressure") + positions => extract_vector_field(state, "Coordinate") - opts%min_edge_length = 0.01 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. + opts%min_edge_length = 0.01 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. - state_array(1) = state - call assemble_metric(state_array, metric, opts) - call insert_mesh_conformity(state_array, metric) - call remove_scalar_field(state_array(1), "Pressure") - call remove_scalar_field(state_array(1), "PressureInterpolationErrorBound") - call vtk_write_state("data/mesh_conformity", 0, state=state_array) + state_array(1) = state + call assemble_metric(state_array, metric, opts) + call insert_mesh_conformity(state_array, metric) + call remove_scalar_field(state_array(1), "Pressure") + call remove_scalar_field(state_array(1), "PressureInterpolationErrorBound") + call vtk_write_state("data/mesh_conformity", 0, state=state_array) - call deallocate(metric) - call deallocate(state) + call deallocate(metric) + call deallocate(state) end subroutine compute_mesh_conformity diff --git a/error_measures/tests/compute_temperature_goal.F90 b/error_measures/tests/compute_temperature_goal.F90 index 690a860399..253aa22646 100644 --- a/error_measures/tests/compute_temperature_goal.F90 +++ b/error_measures/tests/compute_temperature_goal.F90 @@ -1,110 +1,110 @@ subroutine compute_temperature_goal - use global_parameters, only: current_debug_level, pseudo2d_coord + use global_parameters, only: current_debug_level, pseudo2d_coord ! use metric_assemble - use goal_metric - use goals - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - implicit none + use goal_metric + use goals + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + implicit none - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: temperature - type(vector_field), pointer :: velocity - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - integer :: i + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: temperature + type(vector_field), pointer :: velocity + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + integer :: i - goal_rel_tolerance = 0.025 - allocate(goal_deps(1)) - goal_deps(1) = "Temperature" + goal_rel_tolerance = 0.025 + allocate(goal_deps(1)) + goal_deps(1) = "Temperature" - pseudo2d_coord = 2 - call vtk_read_state("data/lock_exchange.vtu", state) - dt = 0.005 + pseudo2d_coord = 2 + call vtk_read_state("data/lock_exchange.vtu", state) + dt = 0.005 - mesh => extract_mesh(state, "Mesh") + mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - call allocate(metric, mesh, "Metric") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.0005 - opts%max_edge_length = 2.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 - hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.0005 + opts%max_edge_length = 2.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 5.0E-04; hminxy = 0.0; hminxz = 0.0; hminyy = 2.0E-04; hminyz = 0.0; hminzz = 5.0E-04 + hmaxxx = 1.0E-01; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0E-02; hmaxyz = 0.0; hmaxzz = 2.0E-02 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.2 - state_array(1) = state - write(0,*) "goal_temp(state) == ", goal_temp(state_array) - call form_goal_metric(state_array, metric, goal_temp, goal_temp_grad, opts) - call form_gradation_metric(positions, metric) - call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - temperature => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/temperature/), & - vfields=(/velocity/)) + gamma0 = 1.2 + state_array(1) = state + write(0,*) "goal_temp(state) == ", goal_temp(state_array) + call form_goal_metric(state_array, metric, goal_temp, goal_temp_grad, opts) + call form_gradation_metric(positions, metric) + call vtk_write_fields("data/goal_error_adapted", 0, positions, mesh, & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + temperature => extract_scalar_field(state, "Temperature") + call vtk_write_fields("data/goal_error_adapted", 1, positions, mesh, sfields=(/temperature/), & + vfields=(/velocity/)) - do i=1,0 - write(0,*) "i == ", i - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - temperature => extract_scalar_field(state, "Temperature") - call deallocate(metric); call allocate(metric, mesh, "Metric") - state_array(1) = state - call form_goal_metric(state_array, metric, goal_temp, goal_temp_grad, opts) - call form_gradation_metric(positions, metric) - call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/temperature/), & - vfields=(/velocity/), tfields=(/metric/)) - call adapt_state(state, metric) - end do + do i=1,0 + write(0,*) "i == ", i + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + temperature => extract_scalar_field(state, "Temperature") + call deallocate(metric); call allocate(metric, mesh, "Metric") + state_array(1) = state + call form_goal_metric(state_array, metric, goal_temp, goal_temp_grad, opts) + call form_gradation_metric(positions, metric) + call vtk_write_fields("data/goal_error_adapted", i+1, positions, mesh, sfields=(/temperature/), & + vfields=(/velocity/), tfields=(/metric/)) + call adapt_state(state, metric) + end do - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - temperature => extract_scalar_field(state, "Temperature") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + temperature => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/temperature/), vfields=(/velocity/)) + call vtk_write_fields("data/goal_error_adapted", i+2, positions, mesh, sfields=(/temperature/), vfields=(/velocity/)) - state_array(1) = state - write(0,*) "goal_temp(state) == ", goal_temp(state_array) + state_array(1) = state + write(0,*) "goal_temp(state) == ", goal_temp(state_array) - deallocate(goal_deps) + deallocate(goal_deps) end subroutine compute_temperature_goal diff --git a/error_measures/tests/test_adaptivity.F90 b/error_measures/tests/test_adaptivity.F90 index 6521cf9e1f..1f53091bef 100644 --- a/error_measures/tests/test_adaptivity.F90 +++ b/error_measures/tests/test_adaptivity.F90 @@ -2,98 +2,98 @@ subroutine test_adaptivity - use global_parameters, only: current_debug_level - use node_boundary, only: pseudo2d_coord - use unittest_tools - use metric_assemble - use edge_length_module - use fields - use state_module - use vtk_interfaces - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use field_options - use populate_state_module, only: compute_domain_statistics - implicit none + use global_parameters, only: current_debug_level + use node_boundary, only: pseudo2d_coord + use unittest_tools + use metric_assemble + use edge_length_module + use fields + use state_module + use vtk_interfaces + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use field_options + use populate_state_module, only: compute_domain_statistics + implicit none #ifdef HAVE_MPI - include "mpif.h" + include "mpif.h" #endif - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions, velocity_pointer - type(vector_field) :: velocity - type(scalar_field) :: pressure, edgelen - type(tensor_field) :: metric + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions, velocity_pointer + type(vector_field) :: velocity + type(scalar_field) :: pressure, edgelen + type(tensor_field) :: metric - integer :: i - real :: x, y, z + integer :: i + real :: x, y, z - current_debug_level = 0 - pseudo2d_coord = 3 + current_debug_level = 0 + pseudo2d_coord = 3 - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - call add_faces(mesh) - positions => extract_vector_field(state, "Coordinate") - ! Update mesh descriptor on positons - positions%mesh=mesh + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + call add_faces(mesh) + positions => extract_vector_field(state, "Coordinate") + ! Update mesh descriptor on positons + positions%mesh=mesh - call allocate(pressure, mesh, "Pressure") - call allocate(velocity, 3, mesh, "Velocity") + call allocate(pressure, mesh, "Pressure") + call allocate(velocity, 3, mesh, "Velocity") - call allocate(metric, mesh, "Metric") + call allocate(metric, mesh, "Metric") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) ! if (x == 0.0) pressure%val(i) = 0.0 ! if (x <= 3.0) pressure%val(i) = x * 1.0e6 ! ramp up .. rapidly ! if (x > 3.0) pressure%val(i) = 3.0 * 1.0e6 - pressure%val(i) = x * x - velocity%val(1,i) = x - velocity%val(2,i) = y - velocity%val(3,i) = z - end do + pressure%val(i) = x * x + velocity%val(1,i) = x + velocity%val(2,i) = y + velocity%val(3,i) = z + end do - call adaptivity_options(state, pressure, 1.0, .false.) + call adaptivity_options(state, pressure, 1.0, .false.) - call insert(state, pressure, "Pressure") - call insert(state, velocity, "Velocity") - call deallocate(pressure) - call deallocate(velocity) + call insert(state, pressure, "Pressure") + call insert(state, velocity, "Velocity") + call deallocate(pressure) + call deallocate(velocity) - positions => extract_vector_field(state, "Coordinate") + positions => extract_vector_field(state, "Coordinate") - call adaptivity_bounds(state, 0.01, 1.0) + call adaptivity_bounds(state, 0.01, 1.0) - state_array(1) = state - call compute_domain_statistics(state_array) + state_array(1) = state + call compute_domain_statistics(state_array) - call assemble_metric(state_array, metric) + call assemble_metric(state_array, metric) - call allocate(edgelen, mesh, "Edge lengths") - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/adapt", 0, positions, mesh, sfields=(/edgelen/), vfields=(/velocity/), tfields=(/metric/)) - call deallocate(edgelen) + call allocate(edgelen, mesh, "Edge lengths") + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/adapt", 0, positions, mesh, sfields=(/edgelen/), vfields=(/velocity/), tfields=(/metric/)) + call deallocate(edgelen) - call adapt_state(state, metric) + call adapt_state(state, metric) - call report_test("[adaptivity runs]", .false., .false., "Congratulations! & - & You didn't crash.") + call report_test("[adaptivity runs]", .false., .false., "Congratulations! & + & You didn't crash.") - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity_pointer => extract_vector_field(state, "Velocity") - call vtk_write_fields("data/adapt", 1, positions, mesh, vfields=(/velocity_pointer/)) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity_pointer => extract_vector_field(state, "Velocity") + call vtk_write_fields("data/adapt", 1, positions, mesh, vfields=(/velocity_pointer/)) - call report_test("[adaptivity output]", .false., .false., "Congratulations! & - & The output from adaptivity might even be OK if you get this far.") + call report_test("[adaptivity output]", .false., .false., "Congratulations! & + & The output from adaptivity might even be OK if you get this far.") - call deallocate(metric) - call deallocate(state) + call deallocate(metric) + call deallocate(state) - call report_test_no_references() + call report_test_no_references() end subroutine test_adaptivity diff --git a/error_measures/tests/test_anisotropic_adaptivity.F90 b/error_measures/tests/test_anisotropic_adaptivity.F90 index 49bbd0890d..8a107549ff 100644 --- a/error_measures/tests/test_anisotropic_adaptivity.F90 +++ b/error_measures/tests/test_anisotropic_adaptivity.F90 @@ -1,93 +1,93 @@ subroutine test_anisotropic_adaptivity - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - implicit none + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(vector_field) :: gradient - type(scalar_field), pointer :: ptr_field - type(tensor_field) :: metric, hessian - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - logical :: fail = .false., warn = .false. - integer :: i, nhsamp - real :: x, y, z - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(vector_field) :: gradient + type(scalar_field), pointer :: ptr_field + type(tensor_field) :: metric, hessian + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + logical :: fail = .false., warn = .false. + integer :: i, nhsamp + real :: x, y, z + integer :: ierr - pseudo2d_coord = 3 - call vtk_read_state("data/1x1square.vtu", state) + pseudo2d_coord = 3 + call vtk_read_state("data/1x1square.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") - call allocate(gradient, 3, mesh, "Gradient") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") + call allocate(gradient, 3, mesh, "Gradient") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) - end do - field%val = field%val + 4.0 + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) + end do + field%val = field%val + 4.0 - call grad(field, positions, gradient) - call vtk_write_fields("data/anisotropic_adapt", 9, positions, mesh, & - sfields=(/field/), vfields=(/gradient/)) + call grad(field, positions, gradient) + call vtk_write_fields("data/anisotropic_adapt", 9, positions, mesh, & + sfields=(/field/), vfields=(/gradient/)) - call insert(state, field, "Field") - call allocate(metric, mesh, "Metric") - call allocate(hessian, mesh, "Hessian") + call insert(state, field, "Field") + call allocate(metric, mesh, "Metric") + call allocate(hessian, mesh, "Hessian") - opts%min_edge_length = 0.01 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 - hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.01 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 + hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.5 - use_gradation_metric = .true. - gradation_initialised = .true. - call compute_hessian(field, positions, hessian) - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/anisotropic_adapt", 0, positions, mesh, & - sfields=(/field/), vfields=(/gradient/), tfields=(/hessian, metric/)) - call adapt_state(state, metric) + gamma0 = 1.5 + use_gradation_metric = .true. + gradation_initialised = .true. + call compute_hessian(field, positions, hessian) + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/anisotropic_adapt", 0, positions, mesh, & + sfields=(/field/), vfields=(/gradient/), tfields=(/hessian, metric/)) + call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - ptr_field => extract_scalar_field(state, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + ptr_field => extract_scalar_field(state, "Field") - call vtk_write_fields("data/anisotropic_adapt", 1, positions, mesh, sfields=(/ptr_field/)) + call vtk_write_fields("data/anisotropic_adapt", 1, positions, mesh, sfields=(/ptr_field/)) end subroutine test_anisotropic_adaptivity diff --git a/error_measures/tests/test_anisotropic_adaptivity_two.F90 b/error_measures/tests/test_anisotropic_adaptivity_two.F90 index 69e0913815..d32b15fbd7 100644 --- a/error_measures/tests/test_anisotropic_adaptivity_two.F90 +++ b/error_measures/tests/test_anisotropic_adaptivity_two.F90 @@ -1,86 +1,86 @@ subroutine test_anisotropic_adaptivity_two - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use mpi - use gradation_metric - implicit none + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use mpi + use gradation_metric + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(scalar_field), pointer :: ptr_field - type(tensor_field) :: metric, hessian - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - logical :: fail = .false., warn = .false. - integer :: i, nhsamp - real :: x, y, z - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(scalar_field), pointer :: ptr_field + type(tensor_field) :: metric, hessian + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + logical :: fail = .false., warn = .false. + integer :: i, nhsamp + real :: x, y, z + integer :: ierr - pseudo2d_coord = 3 - call vtk_read_state("data/anisotropic_adapt_1.vtu", state) + pseudo2d_coord = 3 + call vtk_read_state("data/anisotropic_adapt_1.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - ptr_field => extract_scalar_field(state, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + ptr_field => extract_scalar_field(state, "Field") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - ptr_field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) - end do - ptr_field%val = ptr_field%val + 4.0 - call allocate(metric, mesh, "Metric") - call allocate(hessian, mesh, "Hessian") + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + ptr_field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) + end do + ptr_field%val = ptr_field%val + 4.0 + call allocate(metric, mesh, "Metric") + call allocate(hessian, mesh, "Hessian") - opts%min_edge_length = 0.005 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 - hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.005 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 + hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.5 - use_gradation_metric = .true. - gradation_initialised = .true. + gamma0 = 1.5 + use_gradation_metric = .true. + gradation_initialised = .true. - call assemble_metric((/state/), metric, opts) - call compute_hessian(ptr_field, positions, hessian) - call vtk_write_fields("data/anisotropic_adapt", 2, positions, mesh, sfields=(/ptr_field/), tfields=(/hessian, metric/)) - call adapt_state(state, metric) + call assemble_metric((/state/), metric, opts) + call compute_hessian(ptr_field, positions, hessian) + call vtk_write_fields("data/anisotropic_adapt", 2, positions, mesh, sfields=(/ptr_field/), tfields=(/hessian, metric/)) + call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - ptr_field => extract_scalar_field(state, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + ptr_field => extract_scalar_field(state, "Field") - call vtk_write_fields("data/anisotropic_adapt", 3, positions, mesh, sfields=(/ptr_field/)) + call vtk_write_fields("data/anisotropic_adapt", 3, positions, mesh, sfields=(/ptr_field/)) end subroutine test_anisotropic_adaptivity_two diff --git a/error_measures/tests/test_anisotropic_bounds_equivalence.F90 b/error_measures/tests/test_anisotropic_bounds_equivalence.F90 index ff99c5821b..374c649c4d 100644 --- a/error_measures/tests/test_anisotropic_bounds_equivalence.F90 +++ b/error_measures/tests/test_anisotropic_bounds_equivalence.F90 @@ -1,86 +1,86 @@ subroutine test_anisotropic_bounds_equivalence - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_module - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - implicit none + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_module + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(tensor_field) :: metric_iso, metric_aniso - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - logical :: fail - integer :: i, nhsamp - real :: x, y, z + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(tensor_field) :: metric_iso, metric_aniso + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + logical :: fail + integer :: i, nhsamp + real :: x, y, z - pseudo2d_coord = 3 - call vtk_read_state("data/1x1square-delaunay.vtu", state) + pseudo2d_coord = 3 + call vtk_read_state("data/1x1square-delaunay.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = (y-0.5)**3 - end do - call insert(state, field, "Field") - call allocate(metric_iso, mesh, "Metric") - call allocate(metric_aniso, mesh, "Metric") + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = (y-0.5)**3 + end do + call insert(state, field, "Field") + call allocate(metric_iso, mesh, "Metric") + call allocate(metric_aniso, mesh, "Metric") - opts%min_edge_length = 0.001 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 0.001; hminxy = 0.0; hminxz = 0.0; hminyy = 0.001; hminyz = 0.0; hminzz = 0.001 - hmaxxx = 1.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0; hmaxyz = 0.0; hmaxzz = 1.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.001 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 0.001; hminxy = 0.0; hminxz = 0.0; hminyy = 0.001; hminyz = 0.0; hminzz = 0.001 + hmaxxx = 1.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 1.0; hmaxyz = 0.0; hmaxzz = 1.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 2.0 - use_gradation_metric = .false. - gradation_initialised = .true. - call assemble_metric((/state/), metric_iso, opts) - opts%use_anisotropic_edge_length = .true. - call assemble_metric((/state/), metric_aniso, opts) + gamma0 = 2.0 + use_gradation_metric = .false. + gradation_initialised = .true. + call assemble_metric((/state/), metric_iso, opts) + opts%use_anisotropic_edge_length = .true. + call assemble_metric((/state/), metric_aniso, opts) - fail = .false. - do i=1,mesh%nodes - if (metric_iso%val(:, :, i) .fne. metric_aniso%val(:, :, i)) then - fail = .true. - end if - end do + fail = .false. + do i=1,mesh%nodes + if (metric_iso%val(:, :, i) .fne. metric_aniso%val(:, :, i)) then + fail = .true. + end if + end do - call report_test("[anisotropic bounds equivalence]", fail, .false., & - & "Forming the metric with isotropic and anisotropic bounds & - & should give the same results in this case.") + call report_test("[anisotropic bounds equivalence]", fail, .false., & + & "Forming the metric with isotropic and anisotropic bounds & + & should give the same results in this case.") end subroutine test_anisotropic_bounds_equivalence diff --git a/error_measures/tests/test_anisotropic_gradation.F90 b/error_measures/tests/test_anisotropic_gradation.F90 index 6a0df1ab0b..d85e8789e0 100644 --- a/error_measures/tests/test_anisotropic_gradation.F90 +++ b/error_measures/tests/test_anisotropic_gradation.F90 @@ -1,65 +1,65 @@ subroutine test_anisotropic_gradation - use mesh_files - use anisotropic_gradation - use vtk_interfaces - use metric_assemble - use unittest_tools - use adapt_state_module - use state_module - use mpi - use edge_length_module - use gradation_metric - use surfacelabels - implicit none + use mesh_files + use anisotropic_gradation + use vtk_interfaces + use metric_assemble + use unittest_tools + use adapt_state_module + use state_module + use mpi + use edge_length_module + use gradation_metric + use surfacelabels + implicit none - type(vector_field) :: positions - type(tensor_field) :: metric, gamma - integer :: node - real, dimension(3, 3) :: id, nid, answer - logical :: fail + type(vector_field) :: positions + type(tensor_field) :: metric, gamma + integer :: node + real, dimension(3, 3) :: id, nid, answer + logical :: fail - positions = read_mesh_files("data/tet", quad_degree=4, format="gmsh") - call allocate(metric, positions%mesh, "Metric") + positions = read_mesh_files("data/tet", quad_degree=4, format="gmsh") + call allocate(metric, positions%mesh, "Metric") - id = reshape((/1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0/), (/3, 3/)) + id = reshape((/1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0/), (/3, 3/)) - call set(metric, id * 4) ! an isotropic edge length of 0.5 - call set(metric, 1, id) ! an isotropic edge length of 1.0 + call set(metric, id * 4) ! an isotropic edge length of 0.5 + call set(metric, 1, id) ! an isotropic edge length of 1.0 - call allocate(gamma, positions%mesh, "Gamma", FIELD_TYPE_CONSTANT) - call zero(gamma) ! a gradient of 0.0 + call allocate(gamma, positions%mesh, "Gamma", FIELD_TYPE_CONSTANT) + call zero(gamma) ! a gradient of 0.0 - call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) - fail = .false. - do node=1,node_count(metric) - if (any(node_val(metric, node) /= id * 4)) then - fail = .true. - end if - end do - call report_test("[anisotropic gradation]", fail, .false., "A bound of one on the ratio => constant field.") + call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) + fail = .false. + do node=1,node_count(metric) + if (any(node_val(metric, node) /= id * 4)) then + fail = .true. + end if + end do + call report_test("[anisotropic gradation]", fail, .false., "A bound of one on the ratio => constant field.") - call set(metric, id * 4) ! an isotropic edge length of 0.5 - call set(metric, 1, id) ! an isotropic edge length of 1.0 - call set(gamma, id) ! a gradient of 1.0 - call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) ! this should leave it unchanged - fail = .false. - if (any(node_val(metric, 1) /= id)) then - fail = .true. - end if - if (any(node_val(metric, 2) /= id * 4)) then - fail = .true. - end if - call report_test("[anisotropic gradation]", fail, .false., "This particular set of inputs should be left unchanged.") + call set(metric, id * 4) ! an isotropic edge length of 0.5 + call set(metric, 1, id) ! an isotropic edge length of 1.0 + call set(gamma, id) ! a gradient of 1.0 + call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) ! this should leave it unchanged + fail = .false. + if (any(node_val(metric, 1) /= id)) then + fail = .true. + end if + if (any(node_val(metric, 2) /= id * 4)) then + fail = .true. + end if + call report_test("[anisotropic gradation]", fail, .false., "This particular set of inputs should be left unchanged.") - call set(metric, id * 4) ! an isotropic edge length of 0.5 - call set(metric, 1, id) ! an isotropic edge length of 1.0 - nid = id; nid(3, 3) = 1000 ! constant edge lengths in x and y, "no" bound in z - call set(gamma, nid) - call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) - answer = reshape((/4.0, 0.0, 0.0, 0.0, 4.0, 0.0, 0.0, 0.0, 1.0/), (/3, 3/)) - fail = (node_val(metric, 1) .fne. answer) - write(0,*) "node_val(metric, 1) == ", node_val(metric, 1) - call report_test("[anisotropic gradation]", fail, .false., "X and Y values should be changed but the Z value should not.") + call set(metric, id * 4) ! an isotropic edge length of 0.5 + call set(metric, 1, id) ! an isotropic edge length of 1.0 + nid = id; nid(3, 3) = 1000 ! constant edge lengths in x and y, "no" bound in z + call set(gamma, nid) + call form_anisotropic_gradation_metric(metric, positions, gamma_field=gamma) + answer = reshape((/4.0, 0.0, 0.0, 0.0, 4.0, 0.0, 0.0, 0.0, 1.0/), (/3, 3/)) + fail = (node_val(metric, 1) .fne. answer) + write(0,*) "node_val(metric, 1) == ", node_val(metric, 1) + call report_test("[anisotropic gradation]", fail, .false., "X and Y values should be changed but the Z value should not.") end subroutine test_anisotropic_gradation diff --git a/error_measures/tests/test_anisotropic_zz.F90 b/error_measures/tests/test_anisotropic_zz.F90 index 711aa8b13c..eb0acda72a 100644 --- a/error_measures/tests/test_anisotropic_zz.F90 +++ b/error_measures/tests/test_anisotropic_zz.F90 @@ -1,120 +1,120 @@ #include "fdebug.h" subroutine test_anisotropic_zz - use fields - use anisotropic_zz_module - use mba_adapt_module - use mesh_files - use vtk_interfaces - use edge_length_module - use bounding_box_metric - use field_options - use state_module - use form_metric_field - use interpolation_error - use huang_metric_module - use populate_state_module - use adapt_state_module - use global_parameters - implicit none - - type(vector_field) :: positions - type(scalar_field) :: u - type(state_type) :: state - type(tensor_field) :: metric - integer :: loop, stat - logical :: fail - real :: h1 - real :: eta, tau - interface - function solution(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val - end function solution - end interface - interface - function gradsoln(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: gradsoln - end function gradsoln - end interface - - call set_global_debug_level(2) - - positions = read_mesh_files("data/unit_metric", quad_degree=4, format="gmsh") - call initialise_bounding_box_metric(positions) - call insert(state, positions, "Coordinate") - call deallocate(positions) - - adaptivity_mesh_name = "Mesh" - - call compute_domain_statistics((/state/)) - - tau = 0.8 - - do loop=1,10 - - state%name = "StateNameHere" - positions = extract_vector_field(state, "Coordinate") - if (.not. has_faces(positions%mesh)) then - call add_faces(positions%mesh) - end if - call insert(state, positions%mesh, "Mesh") - call insert(state, positions%mesh, "CoordinateMesh") - call allocate(u, positions%mesh, "U") - call set_from_function(u, solution, positions) - u%option_path = "/fields/u" - call set_option("/fields/u/prognostic/adaptivity_options/anisotropic_zienkiewicz_zhu/tau", tau, stat=stat) - call set_option("/fields/u/prognostic/adaptivity_options/huang_metric/seminorm", (/1, 2/), stat=stat) - call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat=stat) - - call allocate(metric, positions%mesh, "Metric") - call zero(metric) - - call compute_anisotropic_zz_metric(u, positions, metric, eta_estimate=eta) + use fields + use anisotropic_zz_module + use mba_adapt_module + use mesh_files + use vtk_interfaces + use edge_length_module + use bounding_box_metric + use field_options + use state_module + use form_metric_field + use interpolation_error + use huang_metric_module + use populate_state_module + use adapt_state_module + use global_parameters + implicit none + + type(vector_field) :: positions + type(scalar_field) :: u + type(state_type) :: state + type(tensor_field) :: metric + integer :: loop, stat + logical :: fail + real :: h1 + real :: eta, tau + interface + function solution(pos) result(val) + real, dimension(:), intent(in) :: pos + real :: val + end function solution + end interface + interface + function gradsoln(pos) + real, dimension(:) :: pos + real, dimension(size(pos)) :: gradsoln + end function gradsoln + end interface + + call set_global_debug_level(2) + + positions = read_mesh_files("data/unit_metric", quad_degree=4, format="gmsh") + call initialise_bounding_box_metric(positions) + call insert(state, positions, "Coordinate") + call deallocate(positions) + + adaptivity_mesh_name = "Mesh" + + call compute_domain_statistics((/state/)) + + tau = 0.8 + + do loop=1,10 + + state%name = "StateNameHere" + positions = extract_vector_field(state, "Coordinate") + if (.not. has_faces(positions%mesh)) then + call add_faces(positions%mesh) + end if + call insert(state, positions%mesh, "Mesh") + call insert(state, positions%mesh, "CoordinateMesh") + call allocate(u, positions%mesh, "U") + call set_from_function(u, solution, positions) + u%option_path = "/fields/u" + call set_option("/fields/u/prognostic/adaptivity_options/anisotropic_zienkiewicz_zhu/tau", tau, stat=stat) + call set_option("/fields/u/prognostic/adaptivity_options/huang_metric/seminorm", (/1, 2/), stat=stat) + call set_option("/mesh_adaptivity/hr_adaptivity/maximum_number_of_nodes", 100000, stat=stat) + + call allocate(metric, positions%mesh, "Metric") + call zero(metric) + + call compute_anisotropic_zz_metric(u, positions, metric, eta_estimate=eta) ! call compute_hessian(u, positions, metric) ! call form_huang_metric(metric, u, positions, tau) - h1 = compute_interpolation_error_h1(gradsoln, u, positions) - ewrite(2,*) "h1: ", h1 - call adaptivity_bounds(state, 0.000001, 10.0) - call bound_metric(metric, state) + h1 = compute_interpolation_error_h1(gradsoln, u, positions) + ewrite(2,*) "h1: ", h1 + call adaptivity_bounds(state, 0.000001, 10.0) + call bound_metric(metric, state) - call deallocate(u) + call deallocate(u) - call adapt_state(state, metric) + call adapt_state(state, metric) - positions = extract_vector_field(state, "Coordinate") - call allocate(u, positions%mesh, "U") - call set_from_function(u, solution, positions) - call vtk_write_fields("anisotropic_zz", loop, positions, positions%mesh, sfields=(/u/)) - call deallocate(u) + positions = extract_vector_field(state, "Coordinate") + call allocate(u, positions%mesh, "U") + call set_from_function(u, solution, positions) + call vtk_write_fields("anisotropic_zz", loop, positions, positions%mesh, sfields=(/u/)) + call deallocate(u) - end do + end do - fail = ((eta - tau)/tau > 0.01) - call report_test("[anisotropic_zz]", fail, .false., "") + fail = ((eta - tau)/tau > 0.01) + call report_test("[anisotropic_zz]", fail, .false., "") end subroutine test_anisotropic_zz function solution(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val + real, dimension(:), intent(in) :: pos + real :: val - real :: x, y + real :: x, y - x = pos(1); y = pos(2) - !val = (4-4*exp(-100.*x)-4*(1-exp(-100.))*x)*y*(1-y) - val = (x-0.5)**2 + (y-0.5)**2 + x = pos(1); y = pos(2) + !val = (4-4*exp(-100.*x)-4*(1-exp(-100.))*x)*y*(1-y) + val = (x-0.5)**2 + (y-0.5)**2 end function solution function gradsoln(pos) result(val) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: val - - real :: x, y - x = pos(1); y = pos(2) - val(1) = 2*(x - 0.5) - val(2) = 2*(y - 0.5) - !val(1) = (400.0*exp(-(100.0*x)) - 4.0)*(1.0 - y)*y - !val(2) = (-4*exp(-(100.0*x)) - 4.0*x + 4)*(1 - y) - (-4*exp(-(100.0*x)) - 4.0*x + 4)*y + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: val + + real :: x, y + x = pos(1); y = pos(2) + val(1) = 2*(x - 0.5) + val(2) = 2*(y - 0.5) + !val(1) = (400.0*exp(-(100.0*x)) - 4.0)*(1.0 - y)*y + !val(2) = (-4*exp(-(100.0*x)) - 4.0*x + 4)*(1 - y) - (-4*exp(-(100.0*x)) - 4.0*x + 4)*y end function gradsoln diff --git a/error_measures/tests/test_anisotropic_zz_3d.F90 b/error_measures/tests/test_anisotropic_zz_3d.F90 index 7614003030..e35ad528a6 100644 --- a/error_measures/tests/test_anisotropic_zz_3d.F90 +++ b/error_measures/tests/test_anisotropic_zz_3d.F90 @@ -1,115 +1,115 @@ #include "fdebug.h" subroutine test_anisotropic_zz_3d - use fields - use anisotropic_zz_module - use mesh_files - use vtk_interfaces - use solvers - use edge_length_module - use bounding_box_metric - use field_options - use state_module - use form_metric_field - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use interpolation_error - implicit none - - type(vector_field) :: positions - type(scalar_field) :: u - type(state_type) :: state - type(tensor_field) :: metric - integer :: loop, stat - character(len=255) :: path - logical :: fail - real :: tau, eta, h1 - interface - function solution(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val - end function solution - end interface - interface - function gradsoln(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: gradsoln - end function gradsoln - end interface - - call set_global_debug_level(2) - - positions = read_mesh_files("data/cube_anisotropic", quad_degree=4, format="gmsh") - call initialise_bounding_box_metric(positions) - call insert(state, positions, "Coordinate") - call insert(state, positions%mesh, "Mesh") - call deallocate(positions) - - tau = 1.0 - - do loop=1,10 - - positions = extract_vector_field(state, "Coordinate") - call insert(state, positions%mesh, "Mesh") - call allocate(u, positions%mesh, "U") - call set_from_function(u, solution, positions) - u%option_path = "/fields/u" - call set_option("/fields/u/prognostic/adaptivity_options/anisotropic_zienkiewicz_zhu/tau", tau, stat=stat) - path = "/fields/u/prognostic/adaptivity_options/anisotropic_zz" - call set_solver_options(path, ksptype='cg', pctype='sor', rtol=1.0e-8, max_its=10000) - - call allocate(metric, positions%mesh, "Metric") - call zero(metric) - - call compute_anisotropic_zz_metric(u, positions, metric, eta_estimate=eta) - h1 = compute_interpolation_error_h1(gradsoln, u, positions) - ewrite(2,*) "h1: ", h1 - if (eta > 0.75*tau .and. eta < 1.25*tau .and. loop /= 1) then - exit - end if - call adaptivity_bounds(state, 0.000001, 1.0) - call bound_metric(metric, state) - - call insert(state, u, "U") - call deallocate(u) - call set_global_debug_level(0) - call adapt_state(state, metric) - call set_global_debug_level(2) - call deallocate(metric) - u = extract_scalar_field(state, "U") - positions = extract_vector_field(state, "Coordinate") - call set_from_function(u, solution, positions) - call vtk_write_state("data/anisotropic_zz_3d", loop, state=(/state/)) - end do - - fail = (ele_count(positions) > 300) - call report_test("[anisotropic_zz]", fail, .false., "") + use fields + use anisotropic_zz_module + use mesh_files + use vtk_interfaces + use solvers + use edge_length_module + use bounding_box_metric + use field_options + use state_module + use form_metric_field + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use interpolation_error + implicit none + + type(vector_field) :: positions + type(scalar_field) :: u + type(state_type) :: state + type(tensor_field) :: metric + integer :: loop, stat + character(len=255) :: path + logical :: fail + real :: tau, eta, h1 + interface + function solution(pos) result(val) + real, dimension(:), intent(in) :: pos + real :: val + end function solution + end interface + interface + function gradsoln(pos) + real, dimension(:) :: pos + real, dimension(size(pos)) :: gradsoln + end function gradsoln + end interface + + call set_global_debug_level(2) + + positions = read_mesh_files("data/cube_anisotropic", quad_degree=4, format="gmsh") + call initialise_bounding_box_metric(positions) + call insert(state, positions, "Coordinate") + call insert(state, positions%mesh, "Mesh") + call deallocate(positions) + + tau = 1.0 + + do loop=1,10 + + positions = extract_vector_field(state, "Coordinate") + call insert(state, positions%mesh, "Mesh") + call allocate(u, positions%mesh, "U") + call set_from_function(u, solution, positions) + u%option_path = "/fields/u" + call set_option("/fields/u/prognostic/adaptivity_options/anisotropic_zienkiewicz_zhu/tau", tau, stat=stat) + path = "/fields/u/prognostic/adaptivity_options/anisotropic_zz" + call set_solver_options(path, ksptype='cg', pctype='sor', rtol=1.0e-8, max_its=10000) + + call allocate(metric, positions%mesh, "Metric") + call zero(metric) + + call compute_anisotropic_zz_metric(u, positions, metric, eta_estimate=eta) + h1 = compute_interpolation_error_h1(gradsoln, u, positions) + ewrite(2,*) "h1: ", h1 + if (eta > 0.75*tau .and. eta < 1.25*tau .and. loop /= 1) then + exit + end if + call adaptivity_bounds(state, 0.000001, 1.0) + call bound_metric(metric, state) + + call insert(state, u, "U") + call deallocate(u) + call set_global_debug_level(0) + call adapt_state(state, metric) + call set_global_debug_level(2) + call deallocate(metric) + u = extract_scalar_field(state, "U") + positions = extract_vector_field(state, "Coordinate") + call set_from_function(u, solution, positions) + call vtk_write_state("data/anisotropic_zz_3d", loop, state=(/state/)) + end do + + fail = (ele_count(positions) > 300) + call report_test("[anisotropic_zz]", fail, .false., "") end subroutine test_anisotropic_zz_3d function solution(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val + real, dimension(:), intent(in) :: pos + real :: val - real :: x, y, z - real, parameter :: eps=0.01 + real :: x, y, z + real, parameter :: eps=0.01 - x = pos(1); y = pos(2); z = pos(3) - !val = (x-0.5)**2 + (y-0.5)**2 + (z-0.5)**2 + x = pos(1); y = pos(2); z = pos(3) + !val = (x-0.5)**2 + (y-0.5)**2 + (z-0.5)**2 - val = exp(-x/eps) + exp(-y/eps) + exp(-z/eps) + val = exp(-x/eps) + exp(-y/eps) + exp(-z/eps) end function solution function gradsoln(pos) result(val) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: val - real :: x, y, z - real, parameter :: eps=0.01 - x = pos(1); y = pos(2); z = pos(3) - - !val(1) = 2*(x-0.5) - !val(2) = 2*(y-0.5) - !val(3) = 2*(z-0.5) - val(1) = -exp(-(x/eps))/eps - val(2) = -exp(-(y/eps))/eps - val(3) = -exp(-(z/eps))/eps + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: val + real :: x, y, z + real, parameter :: eps=0.01 + x = pos(1); y = pos(2); z = pos(3) + + !val(1) = 2*(x-0.5) + !val(2) = 2*(y-0.5) + !val(3) = 2*(z-0.5) + val(1) = -exp(-(x/eps))/eps + val(2) = -exp(-(y/eps))/eps + val(3) = -exp(-(z/eps))/eps end function gradsoln diff --git a/error_measures/tests/test_anisotropically_bounded_metric.F90 b/error_measures/tests/test_anisotropically_bounded_metric.F90 index c8f3235d71..efa2b9bc04 100644 --- a/error_measures/tests/test_anisotropically_bounded_metric.F90 +++ b/error_measures/tests/test_anisotropically_bounded_metric.F90 @@ -1,86 +1,86 @@ subroutine test_anisotropically_bounded_metric - use metric_assemble - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use mpi - implicit none + use metric_assemble + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use mpi + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field), pointer :: pressure_field - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - logical :: fail = .false., warn = .false. - integer :: i, nhsamp - real :: x, y, z - real :: max_eigenbound, min_eigenbound - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field), pointer :: pressure_field + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + logical :: fail = .false., warn = .false. + integer :: i, nhsamp + real :: x, y, z + real :: max_eigenbound, min_eigenbound + integer :: ierr - call MPI_init(ierr) + call MPI_init(ierr) - call vtk_read_state("data/test_spr.vtu", state) + call vtk_read_state("data/test_spr.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - pressure_field => extract_scalar_field(state, "Pressure") + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + pressure_field => extract_scalar_field(state, "Pressure") - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = 10.0 * x * x + 0.5 * y * y - end do + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = 10.0 * x * x + 0.5 * y * y + end do - call insert(state, pressure_field, "Pressure") + call insert(state, pressure_field, "Pressure") - call allocate(metric, mesh, "Metric") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.1 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 - hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.1 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 + hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - ! the corresponding eigenbounds are: - max_eigenbound = 1.0 - min_eigenbound = 0.25 + ! the corresponding eigenbounds are: + max_eigenbound = 1.0 + min_eigenbound = 0.25 - metric%val = 0.0 - call bound_metric(metric, pressure_field, position_field, opts) + metric%val = 0.0 + call bound_metric(metric, pressure_field, position_field, opts) - fail = .false. - do i=1,mesh%nodes - if (metric%val(:, :, i) .fne. get_mat_diag(eigenvalue_from_edge_length((/hmaxxx(1), hmaxyy(1), hmaxzz(1)/)))) fail = .true. - end do + fail = .false. + do i=1,mesh%nodes + if (metric%val(:, :, i) .fne. get_mat_diag(eigenvalue_from_edge_length((/hmaxxx(1), hmaxyy(1), hmaxzz(1)/)))) fail = .true. + end do - call report_test("[anisotropic bounds deal with zero]", fail, warn, "Zero hessian should give max edge length bounds.") + call report_test("[anisotropic bounds deal with zero]", fail, warn, "Zero hessian should give max edge length bounds.") - call MPI_finalize(ierr) + call MPI_finalize(ierr) end subroutine test_anisotropically_bounded_metric diff --git a/error_measures/tests/test_aspect_ratio.F90 b/error_measures/tests/test_aspect_ratio.F90 index ace7502c2c..7d7ae38598 100644 --- a/error_measures/tests/test_aspect_ratio.F90 +++ b/error_measures/tests/test_aspect_ratio.F90 @@ -1,30 +1,30 @@ subroutine test_aspect_ratio - use metric_tools - use unittest_tools - use vector_tools - implicit none + use metric_tools + use unittest_tools + use vector_tools + implicit none - real, dimension(3, 3) :: mat, vecs - real, dimension(3) :: vals, isotropic_vals, anisotropic_vals - logical :: fail + real, dimension(3, 3) :: mat, vecs + real, dimension(3) :: vals, isotropic_vals, anisotropic_vals + logical :: fail - mat = random_posdef_matrix(3) - call eigendecomposition_symmetric(mat, vecs, vals) + mat = random_posdef_matrix(3) + call eigendecomposition_symmetric(mat, vecs, vals) - isotropic_vals = 1.0 - call eigenrecomposition(mat, vecs, eigenvalue_from_edge_length(isotropic_vals)) + isotropic_vals = 1.0 + call eigenrecomposition(mat, vecs, eigenvalue_from_edge_length(isotropic_vals)) - fail = .false. - if (.not. fequals(aspect_ratio(mat), 1.0)) fail = .true. - call report_test("[aspect ratio 1]", fail, .false., "Aspect ratio known value.") + fail = .false. + if (.not. fequals(aspect_ratio(mat), 1.0)) fail = .true. + call report_test("[aspect ratio 1]", fail, .false., "Aspect ratio known value.") - anisotropic_vals(1) = 1.0 - anisotropic_vals(2) = 2.0 - anisotropic_vals(3) = 3.0 - call eigenrecomposition(mat, vecs, eigenvalue_from_edge_length(anisotropic_vals)) + anisotropic_vals(1) = 1.0 + anisotropic_vals(2) = 2.0 + anisotropic_vals(3) = 3.0 + call eigenrecomposition(mat, vecs, eigenvalue_from_edge_length(anisotropic_vals)) - fail = .false. - if (aspect_ratio(anisotropic_vals) .fne. 1.0/sqrt(3.0)) fail = .true. - call report_test("[aspect ratio 2]", fail, .false., "Aspect ratio known value.") + fail = .false. + if (aspect_ratio(anisotropic_vals) .fne. 1.0/sqrt(3.0)) fail = .true. + call report_test("[aspect ratio 2]", fail, .false., "Aspect ratio known value.") end subroutine test_aspect_ratio diff --git a/error_measures/tests/test_assemble_metric.F90 b/error_measures/tests/test_assemble_metric.F90 index 723f0ab422..1db39b6758 100644 --- a/error_measures/tests/test_assemble_metric.F90 +++ b/error_measures/tests/test_assemble_metric.F90 @@ -1,65 +1,65 @@ subroutine test_assemble_metric - use metric_assemble - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use mpi + use metric_assemble + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use mpi - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field), pointer :: pressure_field - type(tensor_field) :: metric - type(metric_options) :: opts - logical :: fail = .false., warn = .false. - integer :: i, j - real :: x, y, z - real :: max_eigenbound, min_eigenbound - real, dimension(3) :: evalues - real, dimension(3,3) :: evectors - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field), pointer :: pressure_field + type(tensor_field) :: metric + type(metric_options) :: opts + logical :: fail = .false., warn = .false. + integer :: i, j + real :: x, y, z + real :: max_eigenbound, min_eigenbound + real, dimension(3) :: evalues + real, dimension(3,3) :: evectors + integer :: ierr - call vtk_read_state("data/test_spr.vtu", state) + call vtk_read_state("data/test_spr.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - pressure_field => extract_scalar_field(state, "Pressure") + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + pressure_field => extract_scalar_field(state, "Pressure") - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = 0.5 * x * x + 0.5 * y * y - end do + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = 0.5 * x * x + 0.5 * y * y + end do - call allocate(metric, mesh, "Metric") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.1 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - ! the corresponding eigenbounds are: - max_eigenbound = 1.0/(opts%min_edge_length * opts%min_edge_length) - min_eigenbound = 1.0/(opts%max_edge_length * opts%max_edge_length) + opts%min_edge_length = 0.1 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + ! the corresponding eigenbounds are: + max_eigenbound = 1.0/(opts%min_edge_length * opts%min_edge_length) + min_eigenbound = 1.0/(opts%max_edge_length * opts%max_edge_length) - call assemble_metric((/state/), metric, opts) + call assemble_metric((/state/), metric, opts) - do i=1,mesh%nodes - call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) - do j=1,3 - if (evalues(j) .flt. min_eigenbound) then - print *, "min: i == ", i, "; j == ", j, "; evalue == ", evalues(j), "; min_eigenbound == ", min_eigenbound - fail = .true. - end if - if (evalues(j) .fgt. max_eigenbound) then - print *, "max: i == ", i, "; j == ", j, "; evalue == ", evalues(j) - fail = .true. - end if - end do - end do + do i=1,mesh%nodes + call eigendecomposition_symmetric(node_val(metric, i), evectors, evalues) + do j=1,3 + if (evalues(j) .flt. min_eigenbound) then + print *, "min: i == ", i, "; j == ", j, "; evalue == ", evalues(j), "; min_eigenbound == ", min_eigenbound + fail = .true. + end if + if (evalues(j) .fgt. max_eigenbound) then + print *, "max: i == ", i, "; j == ", j, "; evalue == ", evalues(j) + fail = .true. + end if + end do + end do - call report_test("[eigenbounds]", fail, warn, "Eigenvalues should lie between the bounds set by the options.") - call vtk_write_fields("data/metric", 0, position_field, mesh, sfields=(/pressure_field/), tfields=(/metric/)) + call report_test("[eigenbounds]", fail, warn, "Eigenvalues should lie between the bounds set by the options.") + call vtk_write_fields("data/metric", 0, position_field, mesh, sfields=(/pressure_field/), tfields=(/metric/)) end subroutine test_assemble_metric diff --git a/error_measures/tests/test_backstep.F90 b/error_measures/tests/test_backstep.F90 index d3dba208a1..4f2838fa1f 100644 --- a/error_measures/tests/test_backstep.F90 +++ b/error_measures/tests/test_backstep.F90 @@ -2,73 +2,73 @@ subroutine test_backstep - use global_parameters, only: current_debug_level - use unittest_tools - use metric_assemble - use edge_length_module - use fields - use state_module - use vtk_interfaces - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field + use global_parameters, only: current_debug_level + use unittest_tools + use metric_assemble + use edge_length_module + use fields + use state_module + use vtk_interfaces + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field #ifdef HAVE_MPI - use mpi + use mpi #endif - implicit none + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: field - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: i, nhsamp - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: field + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: i, nhsamp + integer :: ierr - call vtk_read_state("data/backstep.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - field => extract_scalar_field(state, "Temperature") - call allocate(metric, mesh, "Metric") + call vtk_read_state("data/backstep.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + field => extract_scalar_field(state, "Temperature") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.01 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 0.01; hminxy = 0.0; hminxz = 0.0; hminyy = 0.2; hminyz = 0.0; hminzz = 0.01 - hmaxxx = 7.5; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 2.5; hmaxyz = 0.0; hmaxzz = 2.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.01 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 0.01; hminxy = 0.0; hminxz = 0.0; hminyy = 0.2; hminyz = 0.0; hminzz = 0.01 + hmaxxx = 7.5; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 2.5; hmaxyz = 0.0; hmaxzz = 2.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - call dprintf(-1, "%p\n$", state%scalar_fields(2)) - call dprintf(-1, "%p\n$", state%scalar_fields(2)%val) - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/backstep", 0, positions, mesh, sfields=(/field/), tfields=(/metric/)) - call adapt_state(state, metric) + call dprintf(-1, "%p\n$", state%scalar_fields(2)) + call dprintf(-1, "%p\n$", state%scalar_fields(2)%val) + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/backstep", 0, positions, mesh, sfields=(/field/), tfields=(/metric/)) + call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - field => extract_scalar_field(state, "Temperature") - call vtk_write_fields("data/backstep", 1, positions, mesh, sfields=(/field/)) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + field => extract_scalar_field(state, "Temperature") + call vtk_write_fields("data/backstep", 1, positions, mesh, sfields=(/field/)) - call deallocate(metric) - call deallocate(state) + call deallocate(metric) + call deallocate(state) end subroutine test_backstep diff --git a/error_measures/tests/test_bound_metric_isotropic.F90 b/error_measures/tests/test_bound_metric_isotropic.F90 index f5dd69d88c..feb3c5e9f8 100644 --- a/error_measures/tests/test_bound_metric_isotropic.F90 +++ b/error_measures/tests/test_bound_metric_isotropic.F90 @@ -1,60 +1,60 @@ subroutine test_bound_metric_isotropic - use node_boundary, only: pseudo2d_coord - use metric_assemble - use adapt_state_module - use fields - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use field_options - implicit none - include "mpif.h" - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(tensor_field) :: hessian - logical :: fail - integer :: i - real :: x, y, z - - pseudo2d_coord = 3 - call vtk_read_state("data/1x1square-delaunay.vtu", state) - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = 0.0 - end do - - call adaptivity_options(state, field, 1.0, .false.) - - call allocate(hessian, mesh, "Hessian") - - call adaptivity_bounds(state, 0.01, 1.0) - - call zero(hessian) - call bound_metric(hessian, state) - - fail = .false. - do i=1,mesh%nodes - if (hessian%val(:, :, i) .fne. get_mat_diag((/1.0, 1.0, 1.0/))) then - fail = .true. - end if - end do - - call report_test("[bound metric isotropic]", fail, .false., & - & "Bounding the zero hessian should give the maximum edge length & - & in all directions.") + use node_boundary, only: pseudo2d_coord + use metric_assemble + use adapt_state_module + use fields + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use field_options + implicit none + include "mpif.h" + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(tensor_field) :: hessian + logical :: fail + integer :: i + real :: x, y, z + + pseudo2d_coord = 3 + call vtk_read_state("data/1x1square-delaunay.vtu", state) + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = 0.0 + end do + + call adaptivity_options(state, field, 1.0, .false.) + + call allocate(hessian, mesh, "Hessian") + + call adaptivity_bounds(state, 0.01, 1.0) + + call zero(hessian) + call bound_metric(hessian, state) + + fail = .false. + do i=1,mesh%nodes + if (hessian%val(:, :, i) .fne. get_mat_diag((/1.0, 1.0, 1.0/))) then + fail = .true. + end if + end do + + call report_test("[bound metric isotropic]", fail, .false., & + & "Bounding the zero hessian should give the maximum edge length & + & in all directions.") end subroutine test_bound_metric_isotropic diff --git a/error_measures/tests/test_boundary_layer_adaptivity.F90 b/error_measures/tests/test_boundary_layer_adaptivity.F90 index ccad187f3b..c068ecd69a 100644 --- a/error_measures/tests/test_boundary_layer_adaptivity.F90 +++ b/error_measures/tests/test_boundary_layer_adaptivity.F90 @@ -1,87 +1,87 @@ subroutine test_boundary_layer_adaptivity - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use field_options - implicit none + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use field_options + implicit none - type(state_type) :: state(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(vector_field) :: gradient - type(scalar_field), pointer :: ptr_field - type(tensor_field) :: metric, hessian - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - logical :: fail = .false., warn = .false. - integer :: i, nhsamp - real :: x, y, z - integer :: ierr + type(state_type) :: state(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(vector_field) :: gradient + type(scalar_field), pointer :: ptr_field + type(tensor_field) :: metric, hessian + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + logical :: fail = .false., warn = .false. + integer :: i, nhsamp + real :: x, y, z + integer :: ierr - pseudo2d_coord = 3 - call vtk_read_state("data/1x1square-delaunay.vtu", state(1)) + pseudo2d_coord = 3 + call vtk_read_state("data/1x1square-delaunay.vtu", state(1)) - mesh => extract_mesh(state(1), "Mesh") - positions => extract_vector_field(state(1), "Coordinate") - call allocate(field, mesh, "Field") + mesh => extract_mesh(state(1), "Mesh") + positions => extract_vector_field(state(1), "Coordinate") + call allocate(field, mesh, "Field") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = tanh(50.0 * x) - end do - call adaptivity_options(state(1), field, 0.01, .false.) + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = tanh(50.0 * x) + end do + call adaptivity_options(state(1), field, 0.01, .false.) - call insert(state(1), field, "Field") - call allocate(metric, mesh, "Metric") + call insert(state(1), field, "Field") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.001 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 - hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.001 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 + hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 2.0 - use_gradation_metric = .false. - gradation_initialised = .true. - call assemble_metric(state, metric, opts) - call vtk_write_fields("data/boundary_layer_adapt", 0, positions, mesh, & - sfields=(/field/), tfields=(/metric/)) - call adapt_state(state(1), metric) + gamma0 = 2.0 + use_gradation_metric = .false. + gradation_initialised = .true. + call assemble_metric(state, metric, opts) + call vtk_write_fields("data/boundary_layer_adapt", 0, positions, mesh, & + sfields=(/field/), tfields=(/metric/)) + call adapt_state(state(1), metric) - mesh => extract_mesh(state(1), "Mesh") - positions => extract_vector_field(state(1), "Coordinate") - ptr_field => extract_scalar_field(state(1), "Field") + mesh => extract_mesh(state(1), "Mesh") + positions => extract_vector_field(state(1), "Coordinate") + ptr_field => extract_scalar_field(state(1), "Field") - call vtk_write_fields("data/boundary_layer_adapt", 1, positions, mesh, sfields=(/ptr_field/)) + call vtk_write_fields("data/boundary_layer_adapt", 1, positions, mesh, sfields=(/ptr_field/)) end subroutine test_boundary_layer_adaptivity diff --git a/error_measures/tests/test_boundary_layer_adaptivity_two.F90 b/error_measures/tests/test_boundary_layer_adaptivity_two.F90 index 3c09a5d76f..3d642771b9 100644 --- a/error_measures/tests/test_boundary_layer_adaptivity_two.F90 +++ b/error_measures/tests/test_boundary_layer_adaptivity_two.F90 @@ -1,85 +1,85 @@ subroutine test_boundary_layer_adaptivity_two - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_module - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - implicit none + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_module + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(vector_field) :: gradient - type(scalar_field), pointer :: ptr_field - type(tensor_field) :: metric, hessian - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - logical :: fail = .false., warn = .false. - integer :: i, nhsamp - real :: x, y, z - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(vector_field) :: gradient + type(scalar_field), pointer :: ptr_field + type(tensor_field) :: metric, hessian + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + logical :: fail = .false., warn = .false. + integer :: i, nhsamp + real :: x, y, z + integer :: ierr - pseudo2d_coord = 3 - call vtk_read_state("data/1x1square-delaunay.vtu", state) + pseudo2d_coord = 3 + call vtk_read_state("data/1x1square-delaunay.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = tanh(50 * (x-0.5)) - end do + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = tanh(50 * (x-0.5)) + end do - call insert(state, field, "Field") - call allocate(metric, mesh, "Metric") + call insert(state, field, "Field") + call allocate(metric, mesh, "Metric") - opts%min_edge_length = 0.001 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 - hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.001 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 + hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 2.0 - use_gradation_metric = .false. - gradation_initialised = .true. - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/boundary_layer_adapt_two", 0, positions, mesh, & - sfields=(/field/), tfields=(/metric/)) - call adapt_state(state, metric) + gamma0 = 2.0 + use_gradation_metric = .false. + gradation_initialised = .true. + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/boundary_layer_adapt_two", 0, positions, mesh, & + sfields=(/field/), tfields=(/metric/)) + call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - ptr_field => extract_scalar_field(state, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + ptr_field => extract_scalar_field(state, "Field") - call vtk_write_fields("data/boundary_layer_adapt_two", 1, positions, mesh, sfields=(/ptr_field/)) + call vtk_write_fields("data/boundary_layer_adapt_two", 1, positions, mesh, sfields=(/ptr_field/)) end subroutine test_boundary_layer_adaptivity_two diff --git a/error_measures/tests/test_compute_g_hat.F90 b/error_measures/tests/test_compute_g_hat.F90 index 988be6682f..477f07e06f 100644 --- a/error_measures/tests/test_compute_g_hat.F90 +++ b/error_measures/tests/test_compute_g_hat.F90 @@ -1,49 +1,49 @@ subroutine test_compute_g_hat - use fields - use sparse_tools - use adjacency_lists - use mesh_files - use anisotropic_zz_module - use unittest_tools - implicit none - - type(scalar_field) :: field - type(vector_field) :: positions - type(mesh_type) :: pwc_mesh - integer :: ele - real, dimension(2,2) :: g_hat - logical :: fail - - interface - function linear_func(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val - end function linear_func - end interface - - positions = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") - call add_nelist(positions%mesh) - pwc_mesh = piecewise_constant_mesh(positions%mesh, "PiecewiseConstantPlease") - call allocate(field, positions%mesh, "Field") - call set_from_function(field, linear_func, positions) - - fail = .false. - do ele=1,ele_count(positions) - g_hat = compute_g_hat(field, positions, ele_shape(pwc_mesh, ele), ele) - fail = fail .or. (any(abs(g_hat) > epsilon(0.0))) - end do - - call report_test("[compute g_hat]", fail, .false., "For a linear function, recovered gradient should be the same") + use fields + use sparse_tools + use adjacency_lists + use mesh_files + use anisotropic_zz_module + use unittest_tools + implicit none + + type(scalar_field) :: field + type(vector_field) :: positions + type(mesh_type) :: pwc_mesh + integer :: ele + real, dimension(2,2) :: g_hat + logical :: fail + + interface + function linear_func(pos) result(val) + real, dimension(:), intent(in) :: pos + real :: val + end function linear_func + end interface + + positions = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") + call add_nelist(positions%mesh) + pwc_mesh = piecewise_constant_mesh(positions%mesh, "PiecewiseConstantPlease") + call allocate(field, positions%mesh, "Field") + call set_from_function(field, linear_func, positions) + + fail = .false. + do ele=1,ele_count(positions) + g_hat = compute_g_hat(field, positions, ele_shape(pwc_mesh, ele), ele) + fail = fail .or. (any(abs(g_hat) > epsilon(0.0))) + end do + + call report_test("[compute g_hat]", fail, .false., "For a linear function, recovered gradient should be the same") end subroutine test_compute_g_hat function linear_func(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val + real, dimension(:), intent(in) :: pos + real :: val - real :: x, y - x = pos(1); y = pos(2) - val = x + y + real :: x, y + x = pos(1); y = pos(2) + val = x + y end function linear_func diff --git a/error_measures/tests/test_construct_edge_list.F90 b/error_measures/tests/test_construct_edge_list.F90 index d0668f022b..e11c9a89fd 100644 --- a/error_measures/tests/test_construct_edge_list.F90 +++ b/error_measures/tests/test_construct_edge_list.F90 @@ -1,53 +1,53 @@ subroutine test_construct_edge_list - use elements - use state_module - use linked_lists - use sparse_tools - use fields - use gradation_metric - use unittest_tools - use adjacency_lists - use vtk_interfaces - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(csr_sparsity), pointer :: nn_sparsity - type(csr_matrix) :: nnlist - type(elist) :: edgelist - logical :: fail - integer :: correct_size - - call vtk_read_state("data/cube.vtu", state) - mesh => extract_mesh(state, "Mesh") - - nn_sparsity => extract_nnlist(mesh) - call allocate(nnlist, nn_sparsity, type=CSR_INTEGER) - nnlist%ival = -1 - - call construct_edge_list(mesh, nnlist, edgelist) - - correct_size = (size(nnlist%ival)) / 2 ! the number of nonzero - ! entries in the upper - ! triangle of the matrix - fail = .false. - if (edgelist%length /= correct_size) then - write(0,*) "edgelist%length == ", edgelist%length - write(0,*) "correct_size == ", correct_size - fail = .true. - end if - - call report_test("[edgelist size]", fail, .false., "Edgelist should be the & - & correct size.") - - fail = .false. - if (any(nnlist%ival == -1)) fail = .true. - call report_test("[edgelist complete]", fail, .false., "Edgelist should & - & have every edge in it.") - - deallocate(nnlist%ival) - call flush_list(edgelist) - call deallocate(state) + use elements + use state_module + use linked_lists + use sparse_tools + use fields + use gradation_metric + use unittest_tools + use adjacency_lists + use vtk_interfaces + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(csr_sparsity), pointer :: nn_sparsity + type(csr_matrix) :: nnlist + type(elist) :: edgelist + logical :: fail + integer :: correct_size + + call vtk_read_state("data/cube.vtu", state) + mesh => extract_mesh(state, "Mesh") + + nn_sparsity => extract_nnlist(mesh) + call allocate(nnlist, nn_sparsity, type=CSR_INTEGER) + nnlist%ival = -1 + + call construct_edge_list(mesh, nnlist, edgelist) + + correct_size = (size(nnlist%ival)) / 2 ! the number of nonzero + ! entries in the upper + ! triangle of the matrix + fail = .false. + if (edgelist%length /= correct_size) then + write(0,*) "edgelist%length == ", edgelist%length + write(0,*) "correct_size == ", correct_size + fail = .true. + end if + + call report_test("[edgelist size]", fail, .false., "Edgelist should be the & + & correct size.") + + fail = .false. + if (any(nnlist%ival == -1)) fail = .true. + call report_test("[edgelist complete]", fail, .false., "Edgelist should & + & have every edge in it.") + + deallocate(nnlist%ival) + call flush_list(edgelist) + call deallocate(state) end subroutine test_construct_edge_list diff --git a/error_measures/tests/test_cubic_interpolation.F90 b/error_measures/tests/test_cubic_interpolation.F90 index f7bf9f046d..583e7f1015 100644 --- a/error_measures/tests/test_cubic_interpolation.F90 +++ b/error_measures/tests/test_cubic_interpolation.F90 @@ -1,69 +1,69 @@ subroutine test_cubic_interpolation - use fields - use state_module - use interpolation_module - use vtk_interfaces - use unittest_tools - implicit none + use fields + use state_module + use interpolation_module + use vtk_interfaces + use unittest_tools + implicit none - type(state_type) :: state_3, state_5 - type(mesh_type), pointer :: old_mesh, new_mesh - type(vector_field), pointer :: old_position, new_position - type(scalar_field), dimension(3) :: old_fields, new_fields - integer :: node, i - real :: x, y, z - real, dimension(3) :: pos - logical :: fail - character(len=20) :: buf + type(state_type) :: state_3, state_5 + type(mesh_type), pointer :: old_mesh, new_mesh + type(vector_field), pointer :: old_position, new_position + type(scalar_field), dimension(3) :: old_fields, new_fields + integer :: node, i + real :: x, y, z + real, dimension(3) :: pos + logical :: fail + character(len=20) :: buf - call vtk_read_state("data/cube-itv3.vtu", state_3) - call vtk_read_state("data/cube-itv5.vtu", state_5) + call vtk_read_state("data/cube-itv3.vtu", state_3) + call vtk_read_state("data/cube-itv5.vtu", state_5) - old_mesh => extract_mesh(state_3, "Mesh") - new_mesh => extract_mesh(state_5, "Mesh") - old_position => extract_vector_field(state_3, "Coordinate") - new_position => extract_vector_field(state_5, "Coordinate") + old_mesh => extract_mesh(state_3, "Mesh") + new_mesh => extract_mesh(state_5, "Mesh") + old_position => extract_vector_field(state_3, "Coordinate") + new_position => extract_vector_field(state_5, "Coordinate") - do i=1,3 - write(buf, '(i0)') i - call allocate(old_fields(i), old_mesh, "Temperature" // trim(buf)) - call allocate(new_fields(i), new_mesh, "Temperature" // trim(buf)) - end do + do i=1,3 + write(buf, '(i0)') i + call allocate(old_fields(i), old_mesh, "Temperature" // trim(buf)) + call allocate(new_fields(i), new_mesh, "Temperature" // trim(buf)) + end do - do node=1,node_count(old_mesh) - pos = node_val(old_position, node) - x = pos(1) ; y = pos(2) ; z = pos(3) - old_fields(1)%val(node) = x**3 - old_fields(2)%val(node) = x**2 - old_fields(3)%val(node) = x - end do + do node=1,node_count(old_mesh) + pos = node_val(old_position, node) + x = pos(1) ; y = pos(2) ; z = pos(3) + old_fields(1)%val(node) = x**3 + old_fields(2)%val(node) = x**2 + old_fields(3)%val(node) = x + end do - call cubic_interpolation(old_fields, old_position, new_fields, new_position) + call cubic_interpolation(old_fields, old_position, new_fields, new_position) - call vtk_write_fields("data/cubic_interpolation", 0, old_position, old_mesh, sfields=old_fields, vfields=(/old_position/)) - call vtk_write_fields("data/cubic_interpolation", 1, new_position, new_mesh, sfields=new_fields, vfields=(/new_position/)) + call vtk_write_fields("data/cubic_interpolation", 0, old_position, old_mesh, sfields=old_fields, vfields=(/old_position/)) + call vtk_write_fields("data/cubic_interpolation", 1, new_position, new_mesh, sfields=new_fields, vfields=(/new_position/)) - fail = .false. - do node=1,node_count(new_mesh) - pos = node_val(new_position, node) - x = pos(1) ; y = pos(2) ; z = pos(3) - if (.not. fequals(node_val(new_fields(1), node), x**3, 0.05)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(1), node) == ", node_val(new_fields(1), node) - fail = .true. - end if - if (.not. fequals(node_val(new_fields(2), node), x**2, 0.05)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(2), node) == ", node_val(new_fields(2), node) - fail = .true. - end if - if (.not. fequals(node_val(new_fields(3), node), x, 0.05)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(3), node) == ", node_val(new_fields(3), node) - fail = .true. - end if - end do - call report_test("[cubic interpolation]", fail, .false., "All nodal values should be exact.") + fail = .false. + do node=1,node_count(new_mesh) + pos = node_val(new_position, node) + x = pos(1) ; y = pos(2) ; z = pos(3) + if (.not. fequals(node_val(new_fields(1), node), x**3, 0.05)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(1), node) == ", node_val(new_fields(1), node) + fail = .true. + end if + if (.not. fequals(node_val(new_fields(2), node), x**2, 0.05)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(2), node) == ", node_val(new_fields(2), node) + fail = .true. + end if + if (.not. fequals(node_val(new_fields(3), node), x, 0.05)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(3), node) == ", node_val(new_fields(3), node) + fail = .true. + end if + end do + call report_test("[cubic interpolation]", fail, .false., "All nodal values should be exact.") end subroutine test_cubic_interpolation diff --git a/error_measures/tests/test_directional_gradation.F90 b/error_measures/tests/test_directional_gradation.F90 index e5b6a90f0b..b626d5f2ad 100644 --- a/error_measures/tests/test_directional_gradation.F90 +++ b/error_measures/tests/test_directional_gradation.F90 @@ -1,98 +1,98 @@ subroutine test_directional_gradation - use gradation_metric - use unittest_tools - use state_module - use vtk_interfaces - use vector_tools - use metric_tools - use edge_length_module - implicit none - - integer :: i - type(tensor_field) :: metric - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: edgelen - real :: pi, edgelen_val - real, dimension(3) :: evals - real, dimension(3, 3) :: evecs, rotmat - logical :: fail - real :: ang_sum, abs_ang_sum - real, dimension(50) :: rand_angle - - call vtk_read_state("data/anisotropic.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - - call allocate(metric, mesh, "Error metric") - call allocate(edgelen, mesh, "Desired edge lengths") - - pi = 4.0 * atan(1.0) - ang_sum = 0.0 - abs_ang_sum = 0.0 - - rand_angle = (/1.34709966759, 0.311742316029, 10.2424266028, 10.7693084058, -0.936104796565, -0.506890236888, 5.3967205881, & - -8.29583306098, 6.7317160712, 11.3374319432, 14.8021552737, -6.30494787702, -6.37278249459, -13.2016459733, -12.1030066266, & - 5.22772243646, -9.59888033136, -1.46060726774, -2.31689708218, 10.94115068, 6.83609523304, 10.6183307185, -4.90686553471, & - -6.24381839029, -11.4155691205, 5.89798704379, 13.2602266611, 11.1242519935, -12.1051829544, 6.99237904103, 12.5013449907, & - -13.7481918613, 6.35625870005, 12.9701054974, -5.86275722242, -5.35945709316, -5.66120593237, -5.44199708288, -1.96228646539, & - -7.14006554468, -14.8433497271, -2.24701922775, -11.7559198616, -14.499166861, -10.908333849, 4.11292104312, 7.56519137309, & - 7.15819852375, -10.3970222832, 1.53848011904/) - - do i=1,mesh%nodes - evals = (/0.10, 0.25, 0.25/) - evals = eigenvalue_from_edge_length(evals) - - evecs = get_matrix_identity(3) - rotmat = get_rotation_matrix_cross(-1 * evecs(:, 3), rand_angle(i) * pi / 180.0) - evecs = matmul(rotmat, evecs) - call eigenrecomposition(metric%val(:, :, i), evecs, evals) - - ang_sum = ang_sum + rand_angle(i) - abs_ang_sum = abs_ang_sum + abs(rand_angle(i)) - end do - - !write(0,*) "avg ang_sum: ", (ang_sum / mesh%nodes) - !write(0,*) "avg abs_ang_sum: ", (abs_ang_sum / mesh%nodes) - !write(0,*) "mesh%nodes == ", mesh%nodes - - call get_edge_lengths(metric, edgelen) - edgelen_val = edgelen%val(1) ! constant - call vtk_write_fields("data/directional_gradation", 0, positions, mesh, & - sfields=(/edgelen/), & - vfields=(/positions/), & - tfields=(/metric/)) - - call form_gradation_metric(positions, metric) - - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/directional_gradation", 1, positions, mesh, & - sfields=(/edgelen/), & - vfields=(/positions/), & - tfields=(/metric/)) - - fail = .false. - do i=1,mesh%nodes - if (edgelen%val(i) .fne. edgelen_val) fail = .true. - call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) - if (get_angle(dominant_eigenvector(evecs, evals), (/1.0, 0.0, 0.0/)) > 0.10) then - write(0,*) "i == ", i - call write_matrix(metric%val(:, :, i), "metric") - call write_matrix(evecs, "eigenvectors") - call write_vector(evals, "eigenvalues") - write(0,*) "dominant_eigenvector(evecs, evals) == ", dominant_eigenvector(evecs, evals) - write(0,*) "angle == ", get_angle(dominant_eigenvector(evecs, evals), (/1.0, 0.0, 0.0/)) - fail = .true. - end if - end do - - call report_test("[directional gradation]", fail, .false., & - "The metric field should have constant unchanged edge length, & - & and its principal eigenvector should be (1, 0, 0).") - - call deallocate(metric) - call deallocate(edgelen) + use gradation_metric + use unittest_tools + use state_module + use vtk_interfaces + use vector_tools + use metric_tools + use edge_length_module + implicit none + + integer :: i + type(tensor_field) :: metric + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: edgelen + real :: pi, edgelen_val + real, dimension(3) :: evals + real, dimension(3, 3) :: evecs, rotmat + logical :: fail + real :: ang_sum, abs_ang_sum + real, dimension(50) :: rand_angle + + call vtk_read_state("data/anisotropic.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + + call allocate(metric, mesh, "Error metric") + call allocate(edgelen, mesh, "Desired edge lengths") + + pi = 4.0 * atan(1.0) + ang_sum = 0.0 + abs_ang_sum = 0.0 + + rand_angle = (/1.34709966759, 0.311742316029, 10.2424266028, 10.7693084058, -0.936104796565, -0.506890236888, 5.3967205881, & + -8.29583306098, 6.7317160712, 11.3374319432, 14.8021552737, -6.30494787702, -6.37278249459, -13.2016459733, -12.1030066266, & + 5.22772243646, -9.59888033136, -1.46060726774, -2.31689708218, 10.94115068, 6.83609523304, 10.6183307185, -4.90686553471, & + -6.24381839029, -11.4155691205, 5.89798704379, 13.2602266611, 11.1242519935, -12.1051829544, 6.99237904103, 12.5013449907, & + -13.7481918613, 6.35625870005, 12.9701054974, -5.86275722242, -5.35945709316, -5.66120593237, -5.44199708288, -1.96228646539, & + -7.14006554468, -14.8433497271, -2.24701922775, -11.7559198616, -14.499166861, -10.908333849, 4.11292104312, 7.56519137309, & + 7.15819852375, -10.3970222832, 1.53848011904/) + + do i=1,mesh%nodes + evals = (/0.10, 0.25, 0.25/) + evals = eigenvalue_from_edge_length(evals) + + evecs = get_matrix_identity(3) + rotmat = get_rotation_matrix_cross(-1 * evecs(:, 3), rand_angle(i) * pi / 180.0) + evecs = matmul(rotmat, evecs) + call eigenrecomposition(metric%val(:, :, i), evecs, evals) + + ang_sum = ang_sum + rand_angle(i) + abs_ang_sum = abs_ang_sum + abs(rand_angle(i)) + end do + + !write(0,*) "avg ang_sum: ", (ang_sum / mesh%nodes) + !write(0,*) "avg abs_ang_sum: ", (abs_ang_sum / mesh%nodes) + !write(0,*) "mesh%nodes == ", mesh%nodes + + call get_edge_lengths(metric, edgelen) + edgelen_val = edgelen%val(1) ! constant + call vtk_write_fields("data/directional_gradation", 0, positions, mesh, & + sfields=(/edgelen/), & + vfields=(/positions/), & + tfields=(/metric/)) + + call form_gradation_metric(positions, metric) + + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/directional_gradation", 1, positions, mesh, & + sfields=(/edgelen/), & + vfields=(/positions/), & + tfields=(/metric/)) + + fail = .false. + do i=1,mesh%nodes + if (edgelen%val(i) .fne. edgelen_val) fail = .true. + call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) + if (get_angle(dominant_eigenvector(evecs, evals), (/1.0, 0.0, 0.0/)) > 0.10) then + write(0,*) "i == ", i + call write_matrix(metric%val(:, :, i), "metric") + call write_matrix(evecs, "eigenvectors") + call write_vector(evals, "eigenvalues") + write(0,*) "dominant_eigenvector(evecs, evals) == ", dominant_eigenvector(evecs, evals) + write(0,*) "angle == ", get_angle(dominant_eigenvector(evecs, evals), (/1.0, 0.0, 0.0/)) + fail = .true. + end if + end do + + call report_test("[directional gradation]", fail, .false., & + "The metric field should have constant unchanged edge length, & + & and its principal eigenvector should be (1, 0, 0).") + + call deallocate(metric) + call deallocate(edgelen) end subroutine test_directional_gradation diff --git a/error_measures/tests/test_directional_gradation_annulus.F90 b/error_measures/tests/test_directional_gradation_annulus.F90 index 4a3529f43f..c6168a0488 100644 --- a/error_measures/tests/test_directional_gradation_annulus.F90 +++ b/error_measures/tests/test_directional_gradation_annulus.F90 @@ -1,95 +1,95 @@ subroutine test_directional_gradation_annulus - use gradation_metric - use unittest_tools - use state_module - use vtk_interfaces - use vector_tools - use metric_tools - use edge_length_module - implicit none - - integer :: i - type(tensor_field) :: metric - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: edgelen - real :: x, y, z, pi, rand, rand2, sign - real, dimension(3) :: evals - real, dimension(3, 3) :: evecs, rotmat - logical :: fail - - call vtk_read_state("data/squashed_annulus.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - - call allocate(metric, mesh, "Error metric") - call allocate(edgelen, mesh, "Desired edge lengths") - - pi = 4.0 * atan(1.0) - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - - call random_number(rand) - call random_number(rand2) - if (rand2 > 0.5) then - sign = 1.0 - else - sign = -1.0 - end if - evals = (/0.10, 0.25, 0.25/) - evals = eigenvalue_from_edge_length(evals) - - ! Make the metric point radially - evecs(:, 1) = (/x, y, 0.0/) - evecs(:, 2) = (/-y, x, 0.0/) - evecs(:, 3) = (/0.0, 0.0, 1.0/) - - rotmat = get_rotation_matrix_cross(-1 * evecs(:, 3), sign * rand * pi / 24.0) - evecs = matmul(rotmat, evecs) - - call eigenrecomposition(metric%val(:, :, i), evecs, evals) - end do - - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/directional_gradation_annulus", 0, positions, mesh, & - sfields=(/edgelen/), & - tfields=(/metric/)) - - call form_gradation_metric(positions, metric) - - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/directional_gradation_annulus", 1, positions, mesh, & - sfields=(/edgelen/), & - tfields=(/metric/)) - - fail = .false. - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - - call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) - if (get_angle(dominant_eigenvector(evecs, evals), (/x, y, 0.0/)) > 0.4) then - write(0,*) "i == ", i - call write_matrix(metric%val(:, :, i), "metric") - call write_matrix(evecs, "eigenvectors") - call write_vector(evals, "eigenvalues") - write(0,*) "dominant_eigenvector(evecs, evals) == ", dominant_eigenvector(evecs, evals) - write(0,*) "angle == ", get_angle(dominant_eigenvector(evecs, evals), (/x, y, 0.0/)) - fail = .true. - end if - end do - - call report_test("[directional gradation on the annulus]", fail, .false., & - "The metric field should have constant unchanged edge length, & - & and its principal eigenvector should be radial.") - - call deallocate(metric) - call deallocate(edgelen) + use gradation_metric + use unittest_tools + use state_module + use vtk_interfaces + use vector_tools + use metric_tools + use edge_length_module + implicit none + + integer :: i + type(tensor_field) :: metric + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: edgelen + real :: x, y, z, pi, rand, rand2, sign + real, dimension(3) :: evals + real, dimension(3, 3) :: evecs, rotmat + logical :: fail + + call vtk_read_state("data/squashed_annulus.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + + call allocate(metric, mesh, "Error metric") + call allocate(edgelen, mesh, "Desired edge lengths") + + pi = 4.0 * atan(1.0) + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + + call random_number(rand) + call random_number(rand2) + if (rand2 > 0.5) then + sign = 1.0 + else + sign = -1.0 + end if + evals = (/0.10, 0.25, 0.25/) + evals = eigenvalue_from_edge_length(evals) + + ! Make the metric point radially + evecs(:, 1) = (/x, y, 0.0/) + evecs(:, 2) = (/-y, x, 0.0/) + evecs(:, 3) = (/0.0, 0.0, 1.0/) + + rotmat = get_rotation_matrix_cross(-1 * evecs(:, 3), sign * rand * pi / 24.0) + evecs = matmul(rotmat, evecs) + + call eigenrecomposition(metric%val(:, :, i), evecs, evals) + end do + + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/directional_gradation_annulus", 0, positions, mesh, & + sfields=(/edgelen/), & + tfields=(/metric/)) + + call form_gradation_metric(positions, metric) + + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/directional_gradation_annulus", 1, positions, mesh, & + sfields=(/edgelen/), & + tfields=(/metric/)) + + fail = .false. + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + + call eigendecomposition_symmetric(metric%val(:, :, i), evecs, evals) + if (get_angle(dominant_eigenvector(evecs, evals), (/x, y, 0.0/)) > 0.4) then + write(0,*) "i == ", i + call write_matrix(metric%val(:, :, i), "metric") + call write_matrix(evecs, "eigenvectors") + call write_vector(evals, "eigenvalues") + write(0,*) "dominant_eigenvector(evecs, evals) == ", dominant_eigenvector(evecs, evals) + write(0,*) "angle == ", get_angle(dominant_eigenvector(evecs, evals), (/x, y, 0.0/)) + fail = .true. + end if + end do + + call report_test("[directional gradation on the annulus]", fail, .false., & + "The metric field should have constant unchanged edge length, & + & and its principal eigenvector should be radial.") + + call deallocate(metric) + call deallocate(edgelen) end subroutine test_directional_gradation_annulus diff --git a/error_measures/tests/test_elementwise_error_adaptivity.F90 b/error_measures/tests/test_elementwise_error_adaptivity.F90 index e4cc7542c0..562a4b5e64 100644 --- a/error_measures/tests/test_elementwise_error_adaptivity.F90 +++ b/error_measures/tests/test_elementwise_error_adaptivity.F90 @@ -1,100 +1,100 @@ subroutine test_elementwise_error_adaptivity - use global_parameters, only: current_debug_level, pseudo2d_coord - use metric_assemble - use adapt_state_module - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - implicit none + use global_parameters, only: current_debug_level, pseudo2d_coord + use metric_assemble + use adapt_state_module + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(scalar_field), pointer :: ptr_field - type(tensor_field) :: metric, hessian - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - type(vector_field) :: analytical_grad, postprocessed_grad, difference_grad - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: i, nhsamp - real :: x, y, z - integer :: ierr + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(scalar_field), pointer :: ptr_field + type(tensor_field) :: metric, hessian + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + type(vector_field) :: analytical_grad, postprocessed_grad, difference_grad + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: i, nhsamp + real :: x, y, z + integer :: ierr - pseudo2d_coord = 3 - call vtk_read_state("data/2x2square-veryfine.vtu", state) + pseudo2d_coord = 3 + call vtk_read_state("data/2x2square-veryfine.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") - call allocate(analytical_grad, 3, mesh, "Analytical gradient") - call allocate(postprocessed_grad, 3, mesh, "Postprocessed gradient") - call allocate(difference_grad, 3, mesh, "Analytical - Postprocessed") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") + call allocate(analytical_grad, 3, mesh, "Analytical gradient") + call allocate(postprocessed_grad, 3, mesh, "Postprocessed gradient") + call allocate(difference_grad, 3, mesh, "Analytical - Postprocessed") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) - analytical_grad%val(1,i) = (2.0*x*y - 20.0 / (cosh(10.0*(sin(5.0*y) - 2.0*x))**2)) - analytical_grad%val(2,i) = 50.0*cos(5.0*y) / & - & (cosh(10.0*(sin(5.0*y) - 2.0*x))**2) + 3*y**2 + x**2 - analytical_grad%val(3,i) = 0.0 - end do - field%val = field%val + 4.0 + analytical_grad%val(1,i) = (2.0*x*y - 20.0 / (cosh(10.0*(sin(5.0*y) - 2.0*x))**2)) + analytical_grad%val(2,i) = 50.0*cos(5.0*y) / & + & (cosh(10.0*(sin(5.0*y) - 2.0*x))**2) + 3*y**2 + x**2 + analytical_grad%val(3,i) = 0.0 + end do + field%val = field%val + 4.0 - call grad(field, positions, postprocessed_grad) - call vector_field_difference(analytical_grad, postprocessed_grad, difference_grad) + call grad(field, positions, postprocessed_grad) + call vector_field_difference(analytical_grad, postprocessed_grad, difference_grad) - call insert(state, field, "Field") - call allocate(metric, mesh, "Metric") - call allocate(hessian, mesh, "Hessian") + call insert(state, field, "Field") + call allocate(metric, mesh, "Metric") + call allocate(hessian, mesh, "Hessian") - opts%min_edge_length = 0.01 - opts%max_edge_length = 1.0 - opts%use_anisotropic_edge_length = .false. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 - hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts + opts%min_edge_length = 0.01 + opts%max_edge_length = 1.0 + opts%use_anisotropic_edge_length = .false. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 20.0; hminxy = 0.0; hminxz = 0.0; hminyy = 50.0; hminyz = 0.0; hminzz = 10.0 + hmaxxx = 5000.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 150.0; hmaxyz = 0.0; hmaxzz = 500.0 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts - gamma0 = 1.5 - use_gradation_metric = .true. - gradation_initialised = .true. - call compute_hessian(field, positions, hessian) - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/elementwise_error", 0, positions, mesh, & - sfields=(/field/), & - vfields=(/analytical_grad, postprocessed_grad, difference_grad/), & - tfields=(/hessian, metric/)) - call adapt_state(state, metric) + gamma0 = 1.5 + use_gradation_metric = .true. + gradation_initialised = .true. + call compute_hessian(field, positions, hessian) + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/elementwise_error", 0, positions, mesh, & + sfields=(/field/), & + vfields=(/analytical_grad, postprocessed_grad, difference_grad/), & + tfields=(/hessian, metric/)) + call adapt_state(state, metric) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - ptr_field => extract_scalar_field(state, "Field") + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + ptr_field => extract_scalar_field(state, "Field") - call vtk_write_fields("data/elementwise_error", 1, positions, mesh, sfields=(/ptr_field/)) + call vtk_write_fields("data/elementwise_error", 1, positions, mesh, sfields=(/ptr_field/)) end subroutine test_elementwise_error_adaptivity diff --git a/error_measures/tests/test_form_metric.F90 b/error_measures/tests/test_form_metric.F90 index 43cc988260..bef7159b51 100644 --- a/error_measures/tests/test_form_metric.F90 +++ b/error_measures/tests/test_form_metric.F90 @@ -1,80 +1,80 @@ subroutine test_form_metric - use form_metric_field - use vtk_interfaces - use state_module - use fields - use unittest_tools - use field_options - use spud - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(tensor_field) :: metric - type(scalar_field) :: field - type(vector_field), pointer :: position_field - real, dimension(3, 3) :: id - integer :: i - logical :: fail, warn - - id = get_matrix_identity(3) - - call vtk_read_state("data/test_spr.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - - call allocate(field, mesh, "Pressure") - call allocate(metric, mesh, "Metric") - - call adaptivity_bounds(state, 1.0, 1.0) - - metric%val = 0.0 - do i=1,mesh%nodes - field%val(i) = 1.0 - metric%val(1, 1, i) = 0.5 - metric%val(2, 2, i) = 1.0 - metric%val(3, 3, i) = 1.0 - end do - - call adaptivity_options(state, field, 1.0, .false.) - - fail = .false. - warn = .false. - - call form_metric(state, metric, field) - - do i=1,mesh%nodes - if (.not. mat_zero(id - metric%val(:, :, i))) then - fail = .true. - print *, "i == ", i - print *, metric%val(:, :, i) - end if - end do - - call report_test("[metric is identity]", fail, warn, "The returned metric should be the identity matrix.") - - metric%val = 0.0 - do i=1,mesh%nodes - field%val(i) = 1.0 - metric%val(1, 1, i) = 2.0 - metric%val(2, 2, i) = 1.0 - metric%val(3, 3, i) = 1.0 - end do - - fail = .false. - warn = .false. - - call form_metric(state, metric, field) - - do i=1,mesh%nodes - if (.not. mat_zero(id - metric%val(:, :, i))) then - fail = .true. - print *, "i == ", i - print *, metric%val(:, :, i) - end if - end do - - call report_test("[metric is identity]", fail, warn, "The returned metric should be the identity matrix.") + use form_metric_field + use vtk_interfaces + use state_module + use fields + use unittest_tools + use field_options + use spud + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(tensor_field) :: metric + type(scalar_field) :: field + type(vector_field), pointer :: position_field + real, dimension(3, 3) :: id + integer :: i + logical :: fail, warn + + id = get_matrix_identity(3) + + call vtk_read_state("data/test_spr.vtu", state) + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + + call allocate(field, mesh, "Pressure") + call allocate(metric, mesh, "Metric") + + call adaptivity_bounds(state, 1.0, 1.0) + + metric%val = 0.0 + do i=1,mesh%nodes + field%val(i) = 1.0 + metric%val(1, 1, i) = 0.5 + metric%val(2, 2, i) = 1.0 + metric%val(3, 3, i) = 1.0 + end do + + call adaptivity_options(state, field, 1.0, .false.) + + fail = .false. + warn = .false. + + call form_metric(state, metric, field) + + do i=1,mesh%nodes + if (.not. mat_zero(id - metric%val(:, :, i))) then + fail = .true. + print *, "i == ", i + print *, metric%val(:, :, i) + end if + end do + + call report_test("[metric is identity]", fail, warn, "The returned metric should be the identity matrix.") + + metric%val = 0.0 + do i=1,mesh%nodes + field%val(i) = 1.0 + metric%val(1, 1, i) = 2.0 + metric%val(2, 2, i) = 1.0 + metric%val(3, 3, i) = 1.0 + end do + + fail = .false. + warn = .false. + + call form_metric(state, metric, field) + + do i=1,mesh%nodes + if (.not. mat_zero(id - metric%val(:, :, i))) then + fail = .true. + print *, "i == ", i + print *, metric%val(:, :, i) + end if + end do + + call report_test("[metric is identity]", fail, warn, "The returned metric should be the identity matrix.") end subroutine test_form_metric diff --git a/error_measures/tests/test_geometric_constraints.F90 b/error_measures/tests/test_geometric_constraints.F90 index dd5fadfdcb..333a3feff9 100644 --- a/error_measures/tests/test_geometric_constraints.F90 +++ b/error_measures/tests/test_geometric_constraints.F90 @@ -1,33 +1,33 @@ subroutine test_geometric_constraints - use fields - use mesh_files - use unittest_tools - use geometric_constraints_metric - use vtk_interfaces - implicit none + use fields + use mesh_files + use unittest_tools + use geometric_constraints_metric + use vtk_interfaces + implicit none - type(vector_field), target :: X - type(mesh_type), pointer :: mesh - type(tensor_field) :: metric - real, dimension(3, 3) :: init - logical :: fail - real :: a, b - integer :: stat + type(vector_field), target :: X + type(mesh_type), pointer :: mesh + type(tensor_field) :: metric + real, dimension(3, 3) :: init + logical :: fail + real :: a, b + integer :: stat - X=read_mesh_files("data/tet", quad_degree=4, format="gmsh") - mesh => X%mesh + X=read_mesh_files("data/tet", quad_degree=4, format="gmsh") + mesh => X%mesh - call allocate(metric, mesh, "ErrorMetric") - init = get_matrix_identity(3) / 100**2 - call set(metric, init) + call allocate(metric, mesh, "ErrorMetric") + init = get_matrix_identity(3) / 100**2 + call set(metric, init) - use_geometric_constraints_metric = .true. + use_geometric_constraints_metric = .true. - call vtk_write_fields("data/geometric_constraints", 0, X, mesh, tfields=(/metric/)) + call vtk_write_fields("data/geometric_constraints", 0, X, mesh, tfields=(/metric/)) - call form_geometric_constraints_metric(X, metric) + call form_geometric_constraints_metric(X, metric) - call vtk_write_fields("data/geometric_constraints", 1, X, mesh, tfields=(/metric/)) + call vtk_write_fields("data/geometric_constraints", 1, X, mesh, tfields=(/metric/)) end subroutine test_geometric_constraints diff --git a/error_measures/tests/test_get_angle.F90 b/error_measures/tests/test_get_angle.F90 index e9333cbef8..afcb0e0e69 100644 --- a/error_measures/tests/test_get_angle.F90 +++ b/error_measures/tests/test_get_angle.F90 @@ -1,79 +1,79 @@ subroutine test_get_angle - use metric_tools - use unittest_tools - implicit none + use metric_tools + use unittest_tools + implicit none - real, dimension(3) :: vecA, vecB - real :: angle, angle2, pi - logical :: fail - integer :: i - character(len=20) :: buf + real, dimension(3) :: vecA, vecB + real :: angle, angle2, pi + logical :: fail + integer :: i + character(len=20) :: buf - pi = 4.0*atan(1.0) + pi = 4.0*atan(1.0) - vecA = (/1.0, 0.0, 0.0/) - vecB = (/0.0, 1.0, 0.0/) - angle = get_angle(vecA, vecB) + vecA = (/1.0, 0.0, 0.0/) + vecB = (/0.0, 1.0, 0.0/) + angle = get_angle(vecA, vecB) - fail = .false. - if (.not. fequals(angle, pi / 2.0)) fail = .true. - call report_test("[get angle orthogonal]", fail, .false., "These vectors are orthogonal.") + fail = .false. + if (.not. fequals(angle, pi / 2.0)) fail = .true. + call report_test("[get angle orthogonal]", fail, .false., "These vectors are orthogonal.") - vecA = (/1.0, 0.0, 0.0/) - vecB = (/1.0/sqrt(2.0), 1.0/sqrt(2.0), 0.0/) - angle = get_angle(vecA, vecB) + vecA = (/1.0, 0.0, 0.0/) + vecB = (/1.0/sqrt(2.0), 1.0/sqrt(2.0), 0.0/) + angle = get_angle(vecA, vecB) - fail = .false. - if (.not. fequals(angle, pi / 4.0)) fail = .true. - call report_test("[get angle 45 degrees]", fail, .false., "These vectors are at 45 degrees.") + fail = .false. + if (.not. fequals(angle, pi / 4.0)) fail = .true. + call report_test("[get angle 45 degrees]", fail, .false., "These vectors are at 45 degrees.") - ! We want get_angle to ignore the sign of the vector, you see. + ! We want get_angle to ignore the sign of the vector, you see. - vecA = (/1.0, 0.0, 0.0/) - vecB = (/-1.0/sqrt(2.0), -1.0/sqrt(2.0), 0.0/) - angle = get_angle(vecA, vecB) + vecA = (/1.0, 0.0, 0.0/) + vecB = (/-1.0/sqrt(2.0), -1.0/sqrt(2.0), 0.0/) + angle = get_angle(vecA, vecB) - fail = .false. - if (.not. fequals(angle, pi / 4.0)) fail = .true. - call report_test("[get angle 45 degrees]", fail, .false., "These vectors are at 45 degrees.") + fail = .false. + if (.not. fequals(angle, pi / 4.0)) fail = .true. + call report_test("[get angle 45 degrees]", fail, .false., "These vectors are at 45 degrees.") - do i=1,5 - write(buf, '(i0)') i + do i=1,5 + write(buf, '(i0)') i - vecA = random_vector(3) - vecB = random_vector(3) - angle = get_angle(vecA, vecB) - angle2 = get_angle(vecA, -1 * vecB) + vecA = random_vector(3) + vecB = random_vector(3) + angle = get_angle(vecA, vecB) + angle2 = get_angle(vecA, -1 * vecB) - fail = .false. - if (.not. fequals(angle, angle2)) fail = .true. - call report_test("[get angle ignores sign " // trim(buf) // "]", & - fail, .false., "The angle computation should lie within [0, Pi/2].") + fail = .false. + if (.not. fequals(angle, angle2)) fail = .true. + call report_test("[get angle ignores sign " // trim(buf) // "]", & + fail, .false., "The angle computation should lie within [0, Pi/2].") - angle = get_angle(vecA, vecB) - angle2 = get_angle(vecB, vecA) - fail = .false. - if (.not. fequals(angle, angle2)) fail = .true. - call report_test("[get angle is commutative " // trim(buf) // "]", & - fail, .false., "The angle computation should be commutative.") - end do + angle = get_angle(vecA, vecB) + angle2 = get_angle(vecB, vecA) + fail = .false. + if (.not. fequals(angle, angle2)) fail = .true. + call report_test("[get angle is commutative " // trim(buf) // "]", & + fail, .false., "The angle computation should be commutative.") + end do - vecA = (/0.0, 1.0, 0.0/) - vecB = (/-0.10398997059599775217E+00, -0.99457834584081084017E+00, 0.0/) - angle = get_angle(vecA, vecB) + vecA = (/0.0, 1.0, 0.0/) + vecB = (/-0.10398997059599775217E+00, -0.99457834584081084017E+00, 0.0/) + angle = get_angle(vecA, vecB) - fail = .false. - if (is_nan(angle)) fail = .true. - call report_test("[get angle nan]", fail, .false., "Angle computation should never return NaN.") + fail = .false. + if (is_nan(angle)) fail = .true. + call report_test("[get angle nan]", fail, .false., "Angle computation should never return NaN.") - vecA = (/-0.24842986328315525002E+00, 0.96862714938199356851E+00, -0.66369050939521093482E-02/) - vecB = (/-0.24842986326122473706E+00, 0.96862714929648652262E+00, -0.66369183942164558174E-02/) - angle = get_angle(vecA, vecB) + vecA = (/-0.24842986328315525002E+00, 0.96862714938199356851E+00, -0.66369050939521093482E-02/) + vecB = (/-0.24842986326122473706E+00, 0.96862714929648652262E+00, -0.66369183942164558174E-02/) + angle = get_angle(vecA, vecB) - fail = .false. - if (is_nan(angle)) fail = .true. - call report_test("[get angle nan]", fail, .false., "Angle computation should never return NaN.") + fail = .false. + if (is_nan(angle)) fail = .true. + call report_test("[get angle nan]", fail, .false., "Angle computation should never return NaN.") end subroutine test_get_angle diff --git a/error_measures/tests/test_get_deformation_matrix.F90 b/error_measures/tests/test_get_deformation_matrix.F90 index f3b149de43..574d340dda 100644 --- a/error_measures/tests/test_get_deformation_matrix.F90 +++ b/error_measures/tests/test_get_deformation_matrix.F90 @@ -1,46 +1,46 @@ subroutine test_get_deformation_matrix - use merge_tensors - use vector_tools - use unittest_tools - implicit none - - logical :: fail, warn - real, dimension(3, 3) :: F, Finv, M, I, I2, tmp - integer :: j - character(len=20) :: buf - - ! I2 is the identity matrix. - I2 = get_matrix_identity(3) - - fail = .false.; warn = .false. - F = get_deformation_matrix(I2) - tmp = F - I2 - if (.not. mat_zero(tmp)) fail = .true. - call report_test("[get_deformation_matrix identity]", fail, warn, "F(I) == I") - - do j=1,5 - fail = .false.; warn = .false. - write(buf,'(i0)') j - - M = random_posdef_matrix(3) - - F = get_deformation_matrix(M) - - Finv = F - call invert(Finv) - - ! M should == F^T * F - tmp = matmul(transpose(F), F) - tmp = tmp - M ! should be 0 - if (.not. mat_zero(tmp)) fail = .true. - call report_test("[get_deformation_matrix " // trim(buf) // " equality]", fail, warn, "M should equal F^T * F") - - ! F^-T * M * F^-1 should be the identity. - I = matmul(matmul(transpose(Finv), M), Finv) - tmp = I - I2 - if (.not. mat_zero(tmp)) fail = .true. - call report_test("[get_deformation_matrix " // trim(buf) // " inverse]", fail, warn, "F^-T * M * F^-1 should be the identity") - end do + use merge_tensors + use vector_tools + use unittest_tools + implicit none + + logical :: fail, warn + real, dimension(3, 3) :: F, Finv, M, I, I2, tmp + integer :: j + character(len=20) :: buf + + ! I2 is the identity matrix. + I2 = get_matrix_identity(3) + + fail = .false.; warn = .false. + F = get_deformation_matrix(I2) + tmp = F - I2 + if (.not. mat_zero(tmp)) fail = .true. + call report_test("[get_deformation_matrix identity]", fail, warn, "F(I) == I") + + do j=1,5 + fail = .false.; warn = .false. + write(buf,'(i0)') j + + M = random_posdef_matrix(3) + + F = get_deformation_matrix(M) + + Finv = F + call invert(Finv) + + ! M should == F^T * F + tmp = matmul(transpose(F), F) + tmp = tmp - M ! should be 0 + if (.not. mat_zero(tmp)) fail = .true. + call report_test("[get_deformation_matrix " // trim(buf) // " equality]", fail, warn, "M should equal F^T * F") + + ! F^-T * M * F^-1 should be the identity. + I = matmul(matmul(transpose(Finv), M), Finv) + tmp = I - I2 + if (.not. mat_zero(tmp)) fail = .true. + call report_test("[get_deformation_matrix " // trim(buf) // " inverse]", fail, warn, "F^-T * M * F^-1 should be the identity") + end do end subroutine test_get_deformation_matrix diff --git a/error_measures/tests/test_get_jacobian_azz_3d.F90 b/error_measures/tests/test_get_jacobian_azz_3d.F90 index 5c1a929558..016056638f 100644 --- a/error_measures/tests/test_get_jacobian_azz_3d.F90 +++ b/error_measures/tests/test_get_jacobian_azz_3d.F90 @@ -1,54 +1,54 @@ subroutine test_get_jacobian_azz_3d - use fields - use mesh_files - use anisotropic_zz_module - use vector_tools - use metric_tools - use unittest_tools - use limit_metric_module - use meshdiagnostics - implicit none - - type(vector_field) :: positions - real, dimension(3, 3) :: j_k, invj_k - real, dimension(3, 4) :: new_pos, old_pos - logical :: fail - real :: edge_length, ideal_edge_length - integer :: iloc, jloc - real :: transformed_volume - real :: ideal_volume - real, dimension(3) :: t_k - integer :: i - - positions = read_mesh_files("data/tet", quad_degree=4, format="gmsh") - old_pos = ele_val(positions, 1) - j_k = get_jacobian_azz(positions, 1) - invj_k = inverse(j_k) - do i=1,3 - t_k(i) = sum(old_pos(i, :)) - end do - t_k = t_k/4.0 - do i=1,4 - old_pos(:, i) = old_pos(:, i) - t_k - end do - new_pos = apply_transform(ele_val(positions, 1), invj_k) - - ideal_edge_length = 2 * sqrt(2.0/3.0) - fail = .false. - do iloc=1,ele_loc(positions, 1) - do jloc=iloc+1,ele_loc(positions, 1) - edge_length = norm2(new_pos(:, iloc) - new_pos(:, jloc)) - fail = fail .or. (edge_length .fne. ideal_edge_length) - end do - end do - - call report_test("[get_jacobian_azz_3d edge lengths]", fail, .false., "Edge lengths should be 2*sqrt(2.0/3.0)") - - transformed_volume = simplex_volume(positions, 1) * determinant(invj_k) - ideal_volume = 8.0 / (9.0 * sqrt(3.0)) - fail = (transformed_volume .fne. ideal_volume) - - call report_test("[get_jacobian_azz_3d volume]", fail, .false., "Volume should be 8.0/(9.0*sqrt(3.0))") + use fields + use mesh_files + use anisotropic_zz_module + use vector_tools + use metric_tools + use unittest_tools + use limit_metric_module + use meshdiagnostics + implicit none + + type(vector_field) :: positions + real, dimension(3, 3) :: j_k, invj_k + real, dimension(3, 4) :: new_pos, old_pos + logical :: fail + real :: edge_length, ideal_edge_length + integer :: iloc, jloc + real :: transformed_volume + real :: ideal_volume + real, dimension(3) :: t_k + integer :: i + + positions = read_mesh_files("data/tet", quad_degree=4, format="gmsh") + old_pos = ele_val(positions, 1) + j_k = get_jacobian_azz(positions, 1) + invj_k = inverse(j_k) + do i=1,3 + t_k(i) = sum(old_pos(i, :)) + end do + t_k = t_k/4.0 + do i=1,4 + old_pos(:, i) = old_pos(:, i) - t_k + end do + new_pos = apply_transform(ele_val(positions, 1), invj_k) + + ideal_edge_length = 2 * sqrt(2.0/3.0) + fail = .false. + do iloc=1,ele_loc(positions, 1) + do jloc=iloc+1,ele_loc(positions, 1) + edge_length = norm2(new_pos(:, iloc) - new_pos(:, jloc)) + fail = fail .or. (edge_length .fne. ideal_edge_length) + end do + end do + + call report_test("[get_jacobian_azz_3d edge lengths]", fail, .false., "Edge lengths should be 2*sqrt(2.0/3.0)") + + transformed_volume = simplex_volume(positions, 1) * determinant(invj_k) + ideal_volume = 8.0 / (9.0 * sqrt(3.0)) + fail = (transformed_volume .fne. ideal_volume) + + call report_test("[get_jacobian_azz_3d volume]", fail, .false., "Volume should be 8.0/(9.0*sqrt(3.0))") end subroutine test_get_jacobian_azz_3d diff --git a/error_measures/tests/test_get_rotation_matrix.F90 b/error_measures/tests/test_get_rotation_matrix.F90 index c20ac2a517..7dfe34350b 100644 --- a/error_measures/tests/test_get_rotation_matrix.F90 +++ b/error_measures/tests/test_get_rotation_matrix.F90 @@ -1,99 +1,99 @@ subroutine test_get_rotation_matrix - use quadrature - use metric_tools - use unittest_tools - use vector_tools - implicit none - - real, dimension(3) :: a3, b3, out3 - real, dimension(3, 3) :: mat3 - - real, dimension(2) :: a2, b2, out2 - real, dimension(2, 2) :: mat2 - - logical :: fail - integer :: i, j - character(len=20) :: buf - - do i=1,5 - write(buf,'(i0)') i - - a3 = random_vector(3) ; a3 = a3 / norm(a3) - b3 = random_vector(3) ; b3 = b3 / norm(b3) - mat3 = get_rotation_matrix(a3, b3) - - out3 = matmul(mat3, a3) - - fail = .false. - do j=1,3 - if (.not. fequals(out3(j), b3(j))) fail = .true. - end do - call report_test("[rotation matrix 3d]", fail, .false., "If the rotation matrix & - & is supposed to map a -> b, it had better map a -> b.") - - fail = .false. - if (det(mat3) /= 1.0) fail = .false. - call report_test("[rotation matrix 3d det]", fail, .false., "Rotation matrices & - & have unitary determinant.") - end do - - do i=1,5 - write(buf,'(i0)') i - - a2 = random_vector(2) ; a2 = a2 / norm(a2) - b2 = random_vector(2) ; b2 = b2 / norm(b2) - mat2 = get_rotation_matrix(a2, b2) - - out2 = matmul(mat2, a2) - - fail = .false. - do j=1,2 - if (.not. fequals(out2(j), b2(j))) fail = .true. - end do - call report_test("[rotation matrix 2d]", fail, .false., "If the rotation matrix & - & is supposed to map a -> b, it had better map a -> b.") - - fail = .false. - if (det(mat2) /= 1.0) fail = .false. - call report_test("[rotation matrix 2d det]", fail, .false., "Rotation matrices & - & have unitary determinant.") - end do - - a3 = (/1.0, 0.0, 0.0/) - b3 = a3 - mat3 = get_rotation_matrix(a3, b3) - - fail = .false. - if (is_nan(mat3(1,1))) fail = .true. - call report_test("[rotation matrix NaN]", fail, .false., "Rotation matrices & - & should not return NaN.") - - a3 = (/0.647603843384180, 0.605624220172685, -0.462416009643120/) - b3 = -1 * a3 - mat3 = get_rotation_matrix(a3, b3) - - fail = .false. - if (is_nan(mat3(1,1))) fail = .true. - call report_test("[rotation matrix NaN]", fail, .false., "Rotation matrices & - & should not return NaN.") - - a3 = (/0.98686556700264593811E+00, -0.16149555124340336798E+00, 0.39420290632705429906E-02/) - b3 = (/0.98686556608677455937E+00, -0.16149555683264460448E+00, 0.39420293687526817075E-02/) - mat3 = get_rotation_matrix(a3, b3) - - fail = .false. - if (is_nan(mat3(1,1))) fail = .true. - call report_test("[rotation matrix NaN]", fail, .false., "Rotation matrices & - & should not return NaN.") - - a3 = (/0.0, 1.0, 0.0/) - b3 = (/0.0, 1.0/sqrt(2.0), 1.0/sqrt(2.0)/) - mat3 = get_rotation_matrix(a3, b3) - - fail = .false. - if (det(mat3) .fne. 1.0) fail = .true. - call report_test("[rotation matrix determinant]", fail, .false., "Rotation & - & matrices have determinant one.") + use quadrature + use metric_tools + use unittest_tools + use vector_tools + implicit none + + real, dimension(3) :: a3, b3, out3 + real, dimension(3, 3) :: mat3 + + real, dimension(2) :: a2, b2, out2 + real, dimension(2, 2) :: mat2 + + logical :: fail + integer :: i, j + character(len=20) :: buf + + do i=1,5 + write(buf,'(i0)') i + + a3 = random_vector(3) ; a3 = a3 / norm(a3) + b3 = random_vector(3) ; b3 = b3 / norm(b3) + mat3 = get_rotation_matrix(a3, b3) + + out3 = matmul(mat3, a3) + + fail = .false. + do j=1,3 + if (.not. fequals(out3(j), b3(j))) fail = .true. + end do + call report_test("[rotation matrix 3d]", fail, .false., "If the rotation matrix & + & is supposed to map a -> b, it had better map a -> b.") + + fail = .false. + if (det(mat3) /= 1.0) fail = .false. + call report_test("[rotation matrix 3d det]", fail, .false., "Rotation matrices & + & have unitary determinant.") + end do + + do i=1,5 + write(buf,'(i0)') i + + a2 = random_vector(2) ; a2 = a2 / norm(a2) + b2 = random_vector(2) ; b2 = b2 / norm(b2) + mat2 = get_rotation_matrix(a2, b2) + + out2 = matmul(mat2, a2) + + fail = .false. + do j=1,2 + if (.not. fequals(out2(j), b2(j))) fail = .true. + end do + call report_test("[rotation matrix 2d]", fail, .false., "If the rotation matrix & + & is supposed to map a -> b, it had better map a -> b.") + + fail = .false. + if (det(mat2) /= 1.0) fail = .false. + call report_test("[rotation matrix 2d det]", fail, .false., "Rotation matrices & + & have unitary determinant.") + end do + + a3 = (/1.0, 0.0, 0.0/) + b3 = a3 + mat3 = get_rotation_matrix(a3, b3) + + fail = .false. + if (is_nan(mat3(1,1))) fail = .true. + call report_test("[rotation matrix NaN]", fail, .false., "Rotation matrices & + & should not return NaN.") + + a3 = (/0.647603843384180, 0.605624220172685, -0.462416009643120/) + b3 = -1 * a3 + mat3 = get_rotation_matrix(a3, b3) + + fail = .false. + if (is_nan(mat3(1,1))) fail = .true. + call report_test("[rotation matrix NaN]", fail, .false., "Rotation matrices & + & should not return NaN.") + + a3 = (/0.98686556700264593811E+00, -0.16149555124340336798E+00, 0.39420290632705429906E-02/) + b3 = (/0.98686556608677455937E+00, -0.16149555683264460448E+00, 0.39420293687526817075E-02/) + mat3 = get_rotation_matrix(a3, b3) + + fail = .false. + if (is_nan(mat3(1,1))) fail = .true. + call report_test("[rotation matrix NaN]", fail, .false., "Rotation matrices & + & should not return NaN.") + + a3 = (/0.0, 1.0, 0.0/) + b3 = (/0.0, 1.0/sqrt(2.0), 1.0/sqrt(2.0)/) + mat3 = get_rotation_matrix(a3, b3) + + fail = .false. + if (det(mat3) .fne. 1.0) fail = .true. + call report_test("[rotation matrix determinant]", fail, .false., "Rotation & + & matrices have determinant one.") end subroutine test_get_rotation_matrix diff --git a/error_measures/tests/test_gradation.F90 b/error_measures/tests/test_gradation.F90 index 7e9c6725d9..710609f42a 100644 --- a/error_measures/tests/test_gradation.F90 +++ b/error_measures/tests/test_gradation.F90 @@ -1,113 +1,113 @@ subroutine test_gradation - use vtk_interfaces - use metric_assemble - use unittest_tools - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use state_module - use mpi - use edge_length_module - use gradation_metric - use field_derivatives - use form_metric_field - use fields - use global_parameters, only: pseudo2d_coord - use surfacelabels - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: field - type(scalar_field), pointer :: field_ptr - type(tensor_field) :: metric - type(metric_options) :: opts - type(anisotropic_edge_options), target :: edge_opts - real, dimension(4), target :: xhsamp, yhsamp, zhsamp - real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz - real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz - integer :: nhsamp - logical :: fail - integer :: i - - interface - function func(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val - end function func - end interface - - pseudo2d_coord = 3 - - fail = .false. - - call vtk_read_state("data/gradation_input.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - - call allocate(field, mesh, "Field") - call allocate(metric, mesh, "Metric") - call set_from_function(field, func, positions) - - field%options%relative = .false. - field%options%error = 0.01 - field%options%min_psi = 0.1 - - opts%min_edge_length = 0.0001 - opts%max_edge_length = 2.0 - opts%use_anisotropic_edge_length = .true. - xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 - xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 - xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 - xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 - hminxx = 0.0001; hminxy = 0.0; hminxz = 0.0; hminyy = 0.0001; hminyz = 0.0; hminzz = 0.01 - hmaxxx = 2.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 2.0; hmaxyz = 0.0; hmaxzz = 0.02 - nhsamp = 4 - edge_opts%no_samp = NHSAMP - edge_opts%x => XHSAMP(1:NHSAMP) - edge_opts%y => YHSAMP(1:NHSAMP) - edge_opts%z => ZHSAMP(1:NHSAMP) - edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) - edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) - edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) - edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) - edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) - edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) - opts%anisotropic_edge_opts => edge_opts - - call insert(state, field, "Field") - - use_gradation_metric = .true. ; gamma0 = 1.1; gradation_initialised = .true. - call assemble_metric((/state/), metric, opts) - call vtk_write_fields("data/gradation_adapt", 0, positions, mesh, & - sfields=(/field/)) - call adapt_state(state, metric) - - do i=1,6 - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - field_ptr => extract_scalar_field(state, "Field") - field_ptr%options%relative = .false. - field_ptr%options%error = 0.01 - field_ptr%options%min_psi = 0.1 - - call set_from_function(field_ptr, func, positions) - call deallocate(metric); call allocate(metric, mesh, "Metric") - call assemble_metric((/state/), metric, opts) - call adapt_state(state, metric) - end do - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - field_ptr => extract_scalar_field(state, "Field") - call vtk_write_fields("data/gradation_adapt", 1, positions, mesh, sfields=(/field_ptr/)) - - call report_test("[gradation]", .false., .false., "Gradation runs. That's enough for now.") + use vtk_interfaces + use metric_assemble + use unittest_tools + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use state_module + use mpi + use edge_length_module + use gradation_metric + use field_derivatives + use form_metric_field + use fields + use global_parameters, only: pseudo2d_coord + use surfacelabels + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: field + type(scalar_field), pointer :: field_ptr + type(tensor_field) :: metric + type(metric_options) :: opts + type(anisotropic_edge_options), target :: edge_opts + real, dimension(4), target :: xhsamp, yhsamp, zhsamp + real, dimension(4), target :: hminxx, hminxy, hminxz, hminyy, hminyz, hminzz + real, dimension(4), target :: hmaxxx, hmaxxy, hmaxxz, hmaxyy, hmaxyz, hmaxzz + integer :: nhsamp + logical :: fail + integer :: i + + interface + function func(pos) result(val) + real, dimension(:), intent(in) :: pos + real :: val + end function func + end interface + + pseudo2d_coord = 3 + + fail = .false. + + call vtk_read_state("data/gradation_input.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + + call allocate(field, mesh, "Field") + call allocate(metric, mesh, "Metric") + call set_from_function(field, func, positions) + + field%options%relative = .false. + field%options%error = 0.01 + field%options%min_psi = 0.1 + + opts%min_edge_length = 0.0001 + opts%max_edge_length = 2.0 + opts%use_anisotropic_edge_length = .true. + xhsamp(1) = 0.0; yhsamp(1) = 0.0; zhsamp(1) = 0.0 + xhsamp(2) = 1.0; yhsamp(2) = 0.0; zhsamp(2) = 1.0 + xhsamp(3) = 1.0; yhsamp(3) = 1.0; zhsamp(3) = 0.0 + xhsamp(4) = 0.0; yhsamp(4) = 1.0; zhsamp(4) = 1.0 + hminxx = 0.0001; hminxy = 0.0; hminxz = 0.0; hminyy = 0.0001; hminyz = 0.0; hminzz = 0.01 + hmaxxx = 2.0; hmaxxy = 0.0; hmaxxz = 0.0; hmaxyy = 2.0; hmaxyz = 0.0; hmaxzz = 0.02 + nhsamp = 4 + edge_opts%no_samp = NHSAMP + edge_opts%x => XHSAMP(1:NHSAMP) + edge_opts%y => YHSAMP(1:NHSAMP) + edge_opts%z => ZHSAMP(1:NHSAMP) + edge_opts%hminxx => HMINXX(1:NHSAMP); edge_opts%hmaxxx => HMAXXX(1:NHSAMP) + edge_opts%hminxy => HMINXY(1:NHSAMP); edge_opts%hmaxxy => HMAXXY(1:NHSAMP) + edge_opts%hminxz => HMINXZ(1:NHSAMP); edge_opts%hmaxxz => HMAXXZ(1:NHSAMP) + edge_opts%hminyy => HMINYY(1:NHSAMP); edge_opts%hmaxyy => HMAXYY(1:NHSAMP) + edge_opts%hminyz => HMINYZ(1:NHSAMP); edge_opts%hmaxyz => HMAXYZ(1:NHSAMP) + edge_opts%hminzz => HMINZZ(1:NHSAMP); edge_opts%hmaxzz => HMAXZZ(1:NHSAMP) + opts%anisotropic_edge_opts => edge_opts + + call insert(state, field, "Field") + + use_gradation_metric = .true. ; gamma0 = 1.1; gradation_initialised = .true. + call assemble_metric((/state/), metric, opts) + call vtk_write_fields("data/gradation_adapt", 0, positions, mesh, & + sfields=(/field/)) + call adapt_state(state, metric) + + do i=1,6 + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + field_ptr => extract_scalar_field(state, "Field") + field_ptr%options%relative = .false. + field_ptr%options%error = 0.01 + field_ptr%options%min_psi = 0.1 + + call set_from_function(field_ptr, func, positions) + call deallocate(metric); call allocate(metric, mesh, "Metric") + call assemble_metric((/state/), metric, opts) + call adapt_state(state, metric) + end do + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + field_ptr => extract_scalar_field(state, "Field") + call vtk_write_fields("data/gradation_adapt", 1, positions, mesh, sfields=(/field_ptr/)) + + call report_test("[gradation]", .false., .false., "Gradation runs. That's enough for now.") end subroutine test_gradation function func(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val + real, dimension(:), intent(in) :: pos + real :: val - val = tanh(25.0 * (pos(1) + 1)) + val = tanh(25.0 * (pos(1) + 1)) end function func diff --git a/error_measures/tests/test_initialise_goal_metric.F90 b/error_measures/tests/test_initialise_goal_metric.F90 index 3a167af365..35b2b0c140 100644 --- a/error_measures/tests/test_initialise_goal_metric.F90 +++ b/error_measures/tests/test_initialise_goal_metric.F90 @@ -1,70 +1,70 @@ subroutine test_initialise_goal_metric - use unittest_tools - use goal_metric - use populate_state_module - use spud - implicit none + use unittest_tools + use goal_metric + use populate_state_module + use spud + implicit none - logical :: fail - integer :: stat + logical :: fail + integer :: stat - call add_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity", stat=stat) - call add_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/enstrophy_goal", stat=stat) - call set_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/enstrophy_goal/dependencies", & - & "Velocity%1 Velocity%2 Velocity%3", stat=stat) - call set_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/relative_tolerance", 0.10, stat=stat) + call add_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity", stat=stat) + call add_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/enstrophy_goal", stat=stat) + call set_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/enstrophy_goal/dependencies", & + & "Velocity%1 Velocity%2 Velocity%3", stat=stat) + call set_option("/mesh_adaptivity/hr_adaptivity/goal_based_adaptivity/relative_tolerance", 0.10, stat=stat) - call initialise_goal_metric + call initialise_goal_metric - if (goal_rel_tolerance /= 0.1) then - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "Get the relative tolerance correctly") + if (goal_rel_tolerance /= 0.1) then + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "Get the relative tolerance correctly") - if (use_goal_metric .eqv. .false.) then - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "We should use goal-based adaptivity") + if (use_goal_metric .eqv. .false.) then + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "We should use goal-based adaptivity") - if (goal_name /= "enstrophy_goal") then - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "We are using the enstrophy goal") + if (goal_name /= "enstrophy_goal") then + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "We are using the enstrophy goal") - if (size(goal_deps) /= 3) then - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "Enstrophy has 3 dependencies") + if (size(goal_deps) /= 3) then + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "Enstrophy has 3 dependencies") - if (trim(goal_deps(1)) /= "Velocity%1") then - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "The first dependency is Velocity%1.") + if (trim(goal_deps(1)) /= "Velocity%1") then + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "The first dependency is Velocity%1.") - if (trim(goal_deps(2)) /= "Velocity%2") then - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "The second dependency is Velocity%2.") + if (trim(goal_deps(2)) /= "Velocity%2") then + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "The second dependency is Velocity%2.") - if (trim(goal_deps(3)) /= "Velocity%3") then - write(0,*) "trim(goal_deps(3)) == ", trim(goal_deps(3)) - fail = .true. - else - fail = .false. - end if - call report_test("[initialise_goal_metric]", fail, .false., "The third dependency is Velocity%3.") + if (trim(goal_deps(3)) /= "Velocity%3") then + write(0,*) "trim(goal_deps(3)) == ", trim(goal_deps(3)) + fail = .true. + else + fail = .false. + end if + call report_test("[initialise_goal_metric]", fail, .false., "The third dependency is Velocity%3.") end subroutine test_initialise_goal_metric diff --git a/error_measures/tests/test_isotropic_gradation.F90 b/error_measures/tests/test_isotropic_gradation.F90 index e72ddde624..4be94012b9 100644 --- a/error_measures/tests/test_isotropic_gradation.F90 +++ b/error_measures/tests/test_isotropic_gradation.F90 @@ -1,94 +1,94 @@ subroutine test_isotropic_gradation - use vtk_interfaces - use metric_assemble - use unittest_tools - use adapt_state_module - use state_module - use mpi - use edge_length_module - use gradation_metric - use global_parameters, only: pseudo2d_coord - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(tensor_field) :: metric - type(scalar_field) :: edgelen - integer :: i, ierr - logical :: fail - real :: x, y, z - real, dimension(3, 3) :: x_metric, other_metric - - pseudo2d_coord = 3 - - gamma0 = 1.0 - - x_metric(1, :) = (/100.0, 0.0, 0.0/) - x_metric(2, :) = (/0.0, 100.0, 0.0/) - x_metric(3, :) = (/0.0, 0.0, 100.0/) - - other_metric = x_metric / 25.0 ! 5 times as big - - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - - call allocate(metric, mesh, "Metric") - call allocate(edgelen, mesh, "Edge lengths") - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - if (x == 0.0) then - metric%val(:, :, i) = x_metric - else - metric%val(:, :, i) = other_metric - end if - end do - - - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/gradation_isotropic", 0, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) - call form_gradation_metric(positions, metric) - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/gradation_isotropic", 1, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) - - fail = .false. - do i=1,mesh%nodes - if (edgelen%val(i) .fne. 0.1) fail = .true. - end do - call report_test("[isotropic gradation 1]", fail, .false., "Gradation applied with a smoothening factor of 1.0 & - & should give a constant edge length field.") - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - if (x == 0.0) then - metric%val(:, :, i) = x_metric - else - metric%val(:, :, i) = other_metric - end if - end do - - gamma0 = 1.1 - call form_gradation_metric(positions, metric) - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/gradation_isotropic", 2, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) - - fail = .false. - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - if (x == 0.0 .and. (edgelen%val(i) .fne. 0.1)) fail = .true. - if (x > 0.0 .and. x < 1.25 .and. edgelen%val(i) > 0.3) fail = .true. - if (x >= 5.0 .and. (edgelen%val(i) .fne. 0.5)) fail = .true. - end do - call report_test("[isotropic gradation 2]", fail, .false., "Gradation applied with a smoothening factor of 1.1 & - & should give a smoothly varying edge length field.") + use vtk_interfaces + use metric_assemble + use unittest_tools + use adapt_state_module + use state_module + use mpi + use edge_length_module + use gradation_metric + use global_parameters, only: pseudo2d_coord + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(tensor_field) :: metric + type(scalar_field) :: edgelen + integer :: i, ierr + logical :: fail + real :: x, y, z + real, dimension(3, 3) :: x_metric, other_metric + + pseudo2d_coord = 3 + + gamma0 = 1.0 + + x_metric(1, :) = (/100.0, 0.0, 0.0/) + x_metric(2, :) = (/0.0, 100.0, 0.0/) + x_metric(3, :) = (/0.0, 0.0, 100.0/) + + other_metric = x_metric / 25.0 ! 5 times as big + + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + + call allocate(metric, mesh, "Metric") + call allocate(edgelen, mesh, "Edge lengths") + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + if (x == 0.0) then + metric%val(:, :, i) = x_metric + else + metric%val(:, :, i) = other_metric + end if + end do + + + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/gradation_isotropic", 0, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) + call form_gradation_metric(positions, metric) + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/gradation_isotropic", 1, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) + + fail = .false. + do i=1,mesh%nodes + if (edgelen%val(i) .fne. 0.1) fail = .true. + end do + call report_test("[isotropic gradation 1]", fail, .false., "Gradation applied with a smoothening factor of 1.0 & + & should give a constant edge length field.") + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + if (x == 0.0) then + metric%val(:, :, i) = x_metric + else + metric%val(:, :, i) = other_metric + end if + end do + + gamma0 = 1.1 + call form_gradation_metric(positions, metric) + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/gradation_isotropic", 2, positions, mesh, sfields=(/edgelen/), tfields=(/metric/)) + + fail = .false. + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + if (x == 0.0 .and. (edgelen%val(i) .fne. 0.1)) fail = .true. + if (x > 0.0 .and. x < 1.25 .and. edgelen%val(i) > 0.3) fail = .true. + if (x >= 5.0 .and. (edgelen%val(i) .fne. 0.5)) fail = .true. + end do + call report_test("[isotropic gradation 2]", fail, .false., "Gradation applied with a smoothening factor of 1.1 & + & should give a smoothly varying edge length field.") end subroutine test_isotropic_gradation diff --git a/error_measures/tests/test_laplacian.F90 b/error_measures/tests/test_laplacian.F90 index e8918a2216..78d7d0a342 100644 --- a/error_measures/tests/test_laplacian.F90 +++ b/error_measures/tests/test_laplacian.F90 @@ -1,107 +1,107 @@ subroutine test_laplacian - use quadrature - use mesh_files - use fields - use FEtools - use elements - use sparse_tools - use vtk_interfaces - use transform_elements - use sparsity_patterns - use solvers - use state_module - use adapt_state_module - use unittest_tools - use field_derivatives, only: compute_hessian - use interpolation_module, only: linear_interpolation - use node_boundary, only: deallocate_boundcount - use vector_tools - - implicit none - - type(vector_field), target :: positions - type(scalar_field), target :: psi, rhs, soln, load - type(mesh_type) :: psi_mesh - integer :: degree, quad_degree - integer :: meshes - integer :: solution_mesh, mesh - type(element_type), target :: psi_shape - type(state_type), dimension(:), pointer :: state - - interface - function rhs_func(X) - ! A function which evaluates the right hand side at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - interface - function solution(X) - real, dimension(:), intent(in) :: X - real :: solution - end function solution - end interface - interface - function loaddata(X) - real, dimension(:), intent(in) :: X - real :: loaddata - end function loaddata - end interface - ! Arguments for handling the command line - character(len=256) :: filename, buf - - filename = "data/laplacian_grid" - degree = 1 - quad_degree=2*degree - ! meshes is the number of meshes to compare computed residuals on. - ! by convention, the higher the number, the finer it is. - ! the problem is solved on the chosen grid and the residuals are computed - ! both ways on the finer meshes. - meshes = 2 - solution_mesh = 2 - - allocate(state(meshes)) - - do mesh=1,meshes - write(buf, '(i0)') mesh - positions=read_mesh_files(trim(trim(filename) // "." // trim(buf)), quad_degree=quad_degree, format="gmsh") - call insert(state(mesh), positions, "Coordinate") - call deallocate(positions) - - ! Shape functions for psi - psi_shape=make_element_shape(vertices=mesh_dim(positions)+1, dim=mesh_dim(positions), degree=degree, & - quad=positions%mesh%shape%quadrature) - psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) - call deallocate(psi_shape) - call insert(state(mesh), psi_mesh, "Mesh") - call deallocate(psi_mesh) - call allocate(psi, psi_mesh, "ForwardSolution") - call zero(psi) - call insert(state(mesh), psi, "ForwardSolution") - call deallocate(psi) - call allocate(rhs, psi_mesh, "RightHandSide") - call set_rhs(rhs, positions, rhs_func) - call insert(state(mesh), rhs, "RightHandSide") - call deallocate(rhs) - call allocate(load, psi_mesh, "LoadData") - call set_from_function(load, loaddata, positions) - call insert(state(mesh), load, "LoadData") - call deallocate(load) - call allocate(soln, psi_mesh, "AnalyticalSolution") - call set_from_function(soln, solution, positions) - call insert(state(mesh), soln, "AnalyticalSolution") - call deallocate(soln) - end do - - ! Do the actual finite element calculation. - call run_model(state(solution_mesh)) - call analyse_output(state(solution_mesh), solution) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Below: Patrick's residual estimation code - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use quadrature + use mesh_files + use fields + use FEtools + use elements + use sparse_tools + use vtk_interfaces + use transform_elements + use sparsity_patterns + use solvers + use state_module + use adapt_state_module + use unittest_tools + use field_derivatives, only: compute_hessian + use interpolation_module, only: linear_interpolation + use node_boundary, only: deallocate_boundcount + use vector_tools + + implicit none + + type(vector_field), target :: positions + type(scalar_field), target :: psi, rhs, soln, load + type(mesh_type) :: psi_mesh + integer :: degree, quad_degree + integer :: meshes + integer :: solution_mesh, mesh + type(element_type), target :: psi_shape + type(state_type), dimension(:), pointer :: state + + interface + function rhs_func(X) + ! A function which evaluates the right hand side at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface + interface + function solution(X) + real, dimension(:), intent(in) :: X + real :: solution + end function solution + end interface + interface + function loaddata(X) + real, dimension(:), intent(in) :: X + real :: loaddata + end function loaddata + end interface + ! Arguments for handling the command line + character(len=256) :: filename, buf + + filename = "data/laplacian_grid" + degree = 1 + quad_degree=2*degree + ! meshes is the number of meshes to compare computed residuals on. + ! by convention, the higher the number, the finer it is. + ! the problem is solved on the chosen grid and the residuals are computed + ! both ways on the finer meshes. + meshes = 2 + solution_mesh = 2 + + allocate(state(meshes)) + + do mesh=1,meshes + write(buf, '(i0)') mesh + positions=read_mesh_files(trim(trim(filename) // "." // trim(buf)), quad_degree=quad_degree, format="gmsh") + call insert(state(mesh), positions, "Coordinate") + call deallocate(positions) + + ! Shape functions for psi + psi_shape=make_element_shape(vertices=mesh_dim(positions)+1, dim=mesh_dim(positions), degree=degree, & + quad=positions%mesh%shape%quadrature) + psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) + call deallocate(psi_shape) + call insert(state(mesh), psi_mesh, "Mesh") + call deallocate(psi_mesh) + call allocate(psi, psi_mesh, "ForwardSolution") + call zero(psi) + call insert(state(mesh), psi, "ForwardSolution") + call deallocate(psi) + call allocate(rhs, psi_mesh, "RightHandSide") + call set_rhs(rhs, positions, rhs_func) + call insert(state(mesh), rhs, "RightHandSide") + call deallocate(rhs) + call allocate(load, psi_mesh, "LoadData") + call set_from_function(load, loaddata, positions) + call insert(state(mesh), load, "LoadData") + call deallocate(load) + call allocate(soln, psi_mesh, "AnalyticalSolution") + call set_from_function(soln, solution, positions) + call insert(state(mesh), soln, "AnalyticalSolution") + call deallocate(soln) + end do + + ! Do the actual finite element calculation. + call run_model(state(solution_mesh)) + call analyse_output(state(solution_mesh), solution) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Below: Patrick's residual estimation code + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! soln_A => extract_scalar_field(state(solution_mesh), "Forward solution") ! positions_A => extract_vector_field(state(solution_mesh), "Coordinate") @@ -116,349 +116,349 @@ end function loaddata ! call zz_residual(state(mesh)) ! end do - if (degree<=2.0) then - ! Output to a vtk file. - do mesh=solution_mesh,meshes - call vtk_write_state(trim(filename), index=mesh, state=(/state(mesh)/)) - end do - end if + if (degree<=2.0) then + ! Output to a vtk file. + do mesh=solution_mesh,meshes + call vtk_write_state(trim(filename), index=mesh, state=(/state(mesh)/)) + end do + end if contains - subroutine run_model(state) - type(state_type), intent(in) :: state + subroutine run_model(state) + type(state_type), intent(in) :: state - type(csr_matrix) :: A - type(scalar_field), pointer :: psi, rhs + type(csr_matrix) :: A + type(scalar_field), pointer :: psi, rhs - call assemble_equations(state, A) + call assemble_equations(state, A) - psi => extract_scalar_field(state, "ForwardSolution") - rhs => extract_scalar_field(state, "RightHandSide") + psi => extract_scalar_field(state, "ForwardSolution") + rhs => extract_scalar_field(state, "RightHandSide") - call set_debug_level(3) - call zero(psi) - call set_solver_options(psi, ksptype='cg', pctype="sor", rtol=1e-7) - call petsc_solve(psi, A, rhs) + call set_debug_level(3) + call zero(psi) + call set_solver_options(psi, ksptype='cg', pctype="sor", rtol=1e-7) + call petsc_solve(psi, A, rhs) - ! since A_ij=\int \nabla N_i \nabla N_j we actually wanted to solve - ! -A psi=rhs - call scale(psi, -1.0) + ! since A_ij=\int \nabla N_i \nabla N_j we actually wanted to solve + ! -A psi=rhs + call scale(psi, -1.0) - call deallocate(A) + call deallocate(A) - end subroutine run_model + end subroutine run_model - subroutine assemble_equations(state, A) - type(state_type), intent(in) :: state - type(csr_matrix), intent(out) :: A + subroutine assemble_equations(state, A) + type(state_type), intent(in) :: state + type(csr_matrix), intent(out) :: A - ! We form and solve the equation A*psi=b - type(vector_field), pointer :: positions - type(scalar_field), pointer :: psi, rhs - type(csr_sparsity) :: A_sparsity - integer :: ele + ! We form and solve the equation A*psi=b + type(vector_field), pointer :: positions + type(scalar_field), pointer :: psi, rhs + type(csr_sparsity) :: A_sparsity + integer :: ele - positions => extract_vector_field(state, "Coordinate") - psi => extract_scalar_field(state, "ForwardSolution") - rhs => extract_scalar_field(state, "RightHandSide") + positions => extract_vector_field(state, "Coordinate") + psi => extract_scalar_field(state, "ForwardSolution") + rhs => extract_scalar_field(state, "RightHandSide") - ! Calculate the sparsity of A based on the connectivity of psi. - A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') - call allocate(A, A_sparsity) - call zero(A) + ! Calculate the sparsity of A based on the connectivity of psi. + A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') + call allocate(A, A_sparsity) + call zero(A) - ! Assemble A element by element. - do ele=1, element_count(psi) - call assemble_element_contribution(A, positions, psi, ele) - end do + ! Assemble A element by element. + do ele=1, element_count(psi) + call assemble_element_contribution(A, positions, psi, ele) + end do - call set(A, find_zero_zero(positions, psi%mesh), find_zero_zero(positions, psi%mesh), INFINITY) + call set(A, find_zero_zero(positions, psi%mesh), find_zero_zero(positions, psi%mesh), INFINITY) - end subroutine assemble_equations + end subroutine assemble_equations - subroutine assemble_element_contribution(A, positions, psi, ele) - type(csr_matrix), intent(inout) :: A - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - integer, intent(in) :: ele + subroutine assemble_element_contribution(A, positions, psi, ele) + type(csr_matrix), intent(inout) :: A + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + integer, intent(in) :: ele - ! Locations of quadrature points - real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad - ! Derivatives of shape function: - real, dimension(ele_loc(psi,ele), & + ! Locations of quadrature points + real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad + ! Derivatives of shape function: + real, dimension(ele_loc(psi,ele), & ele_ngi(psi,ele), positions%dim) :: dshape_psi - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of psi element. - integer, dimension(:), pointer :: ele_psi - ! Shape functions. - type(element_type), pointer :: shape_psi - - ele_psi=>ele_nodes(psi, ele) - shape_psi=>ele_shape(psi, ele) - - ! Locations of quadrature points. - X_quad=ele_val_at_quad(positions, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& - & detwei=detwei) - - ! Matrix entry: - call addto(A, ele_psi, ele_psi, & - dshape_dot_dshape(dshape_psi, dshape_psi, detwei)) - - end subroutine assemble_element_contribution - - subroutine set_rhs(rhs, positions, rhs_func) - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - interface - function rhs_func(X) - ! A function which evaluates the right hand side at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - ! Locations of quadrature points - real, dimension(positions%dim,ele_ngi(positions,1)) :: X_quad - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,1)) :: detwei - ! Node numbers of rhs element. - integer, dimension(:), pointer :: ele_rhs - ! Shape functions. - type(element_type), pointer :: shape_psi - integer :: ele - - call zero(rhs) - - do ele=1,ele_count(rhs) - ele_rhs=>ele_nodes(rhs, ele) - shape_psi=>ele_shape(rhs, ele) - X_quad=ele_val_at_quad(positions, ele) - call transform_to_physical(positions, ele, detwei=detwei) - call addto(rhs, ele_rhs, shape_rhs(shape_psi, detwei * rhs_func(X_quad))) - end do - end subroutine set_rhs - - subroutine analyse_output(state, solution) - type(state_type), intent(inout) :: state - interface - function solution(X) - real, dimension(:), intent(in) :: X - real :: solution - end function solution - end interface - - type(scalar_field), pointer :: psi, soln - type(scalar_field) :: err - type(vector_field), pointer :: positions - ! Coordinate transform * quadrature weights. - real, dimension(:), allocatable :: detwei - ! Shape functions. - type(element_type), pointer :: shape_psi - integer :: ele - real :: integral_error - logical :: fail - - positions => extract_vector_field(state, "Coordinate") - - psi => extract_scalar_field(state, "ForwardSolution") - soln => extract_scalar_field(state, "AnalyticalSolution") - - ! Compute the error in the solution - call allocate(err, psi%mesh, "Error") - err%val = psi%val - soln%val - call insert(state, err, "Error") - call deallocate(err) - - allocate(detwei(ele_ngi(positions, 1))) - - integral_error = 0.0 - do ele=1,ele_count(err) + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of psi element. + integer, dimension(:), pointer :: ele_psi + ! Shape functions. + type(element_type), pointer :: shape_psi + + ele_psi=>ele_nodes(psi, ele) shape_psi=>ele_shape(psi, ele) - call transform_to_physical(positions, ele, detwei=detwei) - integral_error = integral_error + dot_product(detwei, ele_val_at_quad(err, ele)) - end do - - deallocate(detwei) - - fail = (integral_error > 0.1) - call report_test("[laplacian]", fail, .false., "The error in the Laplacian simulation has increased .. ") - end subroutine analyse_output - - subroutine discrete_residual(state) - type(state_type), intent(inout) :: state - - type(csr_matrix) :: A - type(scalar_field) :: discrete_residual_field, soln_residual - type(scalar_field), pointer :: psi, rhs, soln - type(vector_field), pointer :: positions - - psi => extract_scalar_field(state, "Forward solution") - rhs => extract_scalar_field(state, "Right-hand side") - soln => extract_scalar_field(state, "Analytical solution") - - positions => extract_vector_field(state, "Coordinate") - - call assemble_equations(state, A) - call allocate(discrete_residual_field, psi%mesh, "DiscreteResidual") - call zero(discrete_residual_field) - call allocate(soln_residual, psi%mesh, "DiscreteAnalyticalResidual") - call zero(soln_residual) - - call mult(discrete_residual_field%val, A, psi%val) - call mult(soln_residual%val, A, soln%val) - - discrete_residual_field%val = discrete_residual_field%val - rhs%val - soln_residual%val = soln_residual%val - rhs%val - call insert(state, discrete_residual_field, "DiscreteResidual") - call deallocate(discrete_residual_field) - call insert(state, soln_residual, "DiscreteAnalyticalResidual") - call deallocate(soln_residual) - call deallocate(A) - end subroutine discrete_residual - - subroutine zz_residual(state) - type(state_type), intent(inout) :: state - - type(tensor_field) :: hessian - type(scalar_field) :: zz_residual_field, soln_residual - - type(scalar_field), pointer :: psi, load, soln - type(vector_field), pointer :: positions - - psi => extract_scalar_field(state, "ForwardSolution") - soln => extract_scalar_field(state, "AnalyticalSolution") - load => extract_scalar_field(state, "LoadData") - positions => extract_vector_field(state, "Coordinate") + ! Locations of quadrature points. + X_quad=ele_val_at_quad(positions, ele) - call allocate(hessian, psi%mesh, "Hessian") - call allocate(zz_residual_field, psi%mesh, "ZZResidual") - call allocate(soln_residual, psi%mesh, "ZZAnalyticalResidual") + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& + & detwei=detwei) - call compute_hessian(psi, positions, hessian) - call trace(hessian, zz_residual_field) + ! Matrix entry: + call addto(A, ele_psi, ele_psi, & + dshape_dot_dshape(dshape_psi, dshape_psi, detwei)) - call compute_hessian(soln, positions, hessian) - call trace(hessian, soln_residual) + end subroutine assemble_element_contribution + + subroutine set_rhs(rhs, positions, rhs_func) + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + interface + function rhs_func(X) + ! A function which evaluates the right hand side at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface + ! Locations of quadrature points + real, dimension(positions%dim,ele_ngi(positions,1)) :: X_quad + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,1)) :: detwei + ! Node numbers of rhs element. + integer, dimension(:), pointer :: ele_rhs + ! Shape functions. + type(element_type), pointer :: shape_psi + integer :: ele + + call zero(rhs) + + do ele=1,ele_count(rhs) + ele_rhs=>ele_nodes(rhs, ele) + shape_psi=>ele_shape(rhs, ele) + X_quad=ele_val_at_quad(positions, ele) + call transform_to_physical(positions, ele, detwei=detwei) + call addto(rhs, ele_rhs, shape_rhs(shape_psi, detwei * rhs_func(X_quad))) + end do + end subroutine set_rhs + + subroutine analyse_output(state, solution) + type(state_type), intent(inout) :: state + interface + function solution(X) + real, dimension(:), intent(in) :: X + real :: solution + end function solution + end interface + + type(scalar_field), pointer :: psi, soln + type(scalar_field) :: err + type(vector_field), pointer :: positions + ! Coordinate transform * quadrature weights. + real, dimension(:), allocatable :: detwei + ! Shape functions. + type(element_type), pointer :: shape_psi + integer :: ele + real :: integral_error + logical :: fail + + positions => extract_vector_field(state, "Coordinate") + + psi => extract_scalar_field(state, "ForwardSolution") + soln => extract_scalar_field(state, "AnalyticalSolution") + + ! Compute the error in the solution + call allocate(err, psi%mesh, "Error") + err%val = psi%val - soln%val + call insert(state, err, "Error") + call deallocate(err) + + allocate(detwei(ele_ngi(positions, 1))) + + integral_error = 0.0 + do ele=1,ele_count(err) + shape_psi=>ele_shape(psi, ele) + call transform_to_physical(positions, ele, detwei=detwei) + integral_error = integral_error + dot_product(detwei, ele_val_at_quad(err, ele)) + end do + + deallocate(detwei) + + fail = (integral_error > 0.1) + call report_test("[laplacian]", fail, .false., "The error in the Laplacian simulation has increased .. ") + end subroutine analyse_output + + subroutine discrete_residual(state) + type(state_type), intent(inout) :: state + + type(csr_matrix) :: A + type(scalar_field) :: discrete_residual_field, soln_residual + type(scalar_field), pointer :: psi, rhs, soln + type(vector_field), pointer :: positions + + psi => extract_scalar_field(state, "Forward solution") + rhs => extract_scalar_field(state, "Right-hand side") + soln => extract_scalar_field(state, "Analytical solution") + + positions => extract_vector_field(state, "Coordinate") + + call assemble_equations(state, A) + + call allocate(discrete_residual_field, psi%mesh, "DiscreteResidual") + call zero(discrete_residual_field) + call allocate(soln_residual, psi%mesh, "DiscreteAnalyticalResidual") + call zero(soln_residual) + + call mult(discrete_residual_field%val, A, psi%val) + call mult(soln_residual%val, A, soln%val) + + discrete_residual_field%val = discrete_residual_field%val - rhs%val + soln_residual%val = soln_residual%val - rhs%val + call insert(state, discrete_residual_field, "DiscreteResidual") + call deallocate(discrete_residual_field) + call insert(state, soln_residual, "DiscreteAnalyticalResidual") + call deallocate(soln_residual) + call deallocate(A) + end subroutine discrete_residual + + subroutine zz_residual(state) + type(state_type), intent(inout) :: state + + type(tensor_field) :: hessian + type(scalar_field) :: zz_residual_field, soln_residual + + type(scalar_field), pointer :: psi, load, soln + type(vector_field), pointer :: positions + + psi => extract_scalar_field(state, "ForwardSolution") + soln => extract_scalar_field(state, "AnalyticalSolution") + load => extract_scalar_field(state, "LoadData") + positions => extract_vector_field(state, "Coordinate") + + call allocate(hessian, psi%mesh, "Hessian") + call allocate(zz_residual_field, psi%mesh, "ZZResidual") + call allocate(soln_residual, psi%mesh, "ZZAnalyticalResidual") + + call compute_hessian(psi, positions, hessian) + call trace(hessian, zz_residual_field) - zz_residual_field%val = - 1 * zz_residual_field%val - load%val - soln_residual%val = -1 * soln_residual%val - load%val + call compute_hessian(soln, positions, hessian) + call trace(hessian, soln_residual) + + zz_residual_field%val = - 1 * zz_residual_field%val - load%val + soln_residual%val = -1 * soln_residual%val - load%val - call insert(state, zz_residual_field, "ZZResidual") - call insert(state, soln_residual, "ZZAnalyticalResidual") - call deallocate(zz_residual_field) - call deallocate(soln_residual) + call insert(state, zz_residual_field, "ZZResidual") + call insert(state, soln_residual, "ZZAnalyticalResidual") + call deallocate(zz_residual_field) + call deallocate(soln_residual) - call deallocate_boundcount - call deallocate(hessian) - end subroutine zz_residual + call deallocate_boundcount + call deallocate(hessian) + end subroutine zz_residual - subroutine interpolate_fields(inpositions, infield, outpositions, outfield) - type(vector_field), intent(in) :: inpositions, outpositions - type(scalar_field), intent(in) :: infield - type(scalar_field), intent(inout) :: outfield + subroutine interpolate_fields(inpositions, infield, outpositions, outfield) + type(vector_field), intent(in) :: inpositions, outpositions + type(scalar_field), intent(in) :: infield + type(scalar_field), intent(inout) :: outfield - type(state_type) :: state_in, state_out - type(vector_field) :: inpositions_mapped, outpositions_mapped + type(state_type) :: state_in, state_out + type(vector_field) :: inpositions_mapped, outpositions_mapped - call nullify(state_in) - call nullify(state_out) + call nullify(state_in) + call nullify(state_out) - call allocate(inpositions_mapped, inpositions%dim, infield%mesh, "Coordinate") - call remap_field(inpositions, inpositions_mapped) - call allocate(outpositions_mapped, outpositions%dim, outfield%mesh, "Coordinate") - call remap_field(outpositions, outpositions_mapped) + call allocate(inpositions_mapped, inpositions%dim, infield%mesh, "Coordinate") + call remap_field(inpositions, inpositions_mapped) + call allocate(outpositions_mapped, outpositions%dim, outfield%mesh, "Coordinate") + call remap_field(outpositions, outpositions_mapped) - call insert(state_in, inpositions_mapped, "Coordinate") - call insert(state_in, infield, trim(infield%name)) - call insert(state_in, infield%mesh, "Mesh") + call insert(state_in, inpositions_mapped, "Coordinate") + call insert(state_in, infield, trim(infield%name)) + call insert(state_in, infield%mesh, "Mesh") - call insert(state_out, outpositions_mapped, "Coordinate") - call insert(state_out, outfield, trim(outfield%name)) - call insert(state_out, outfield%mesh, "Mesh") + call insert(state_out, outpositions_mapped, "Coordinate") + call insert(state_out, outfield, trim(outfield%name)) + call insert(state_out, outfield%mesh, "Mesh") - call linear_interpolation(state_in, state_out) + call linear_interpolation(state_in, state_out) - call deallocate(state_in) - call deallocate(state_out) - call deallocate(inpositions_mapped) - call deallocate(outpositions_mapped) - end subroutine interpolate_fields + call deallocate(state_in) + call deallocate(state_out) + call deallocate(inpositions_mapped) + call deallocate(outpositions_mapped) + end subroutine interpolate_fields - function find_zero_zero(positions, mesh) result(node) - ! find the node *closest* to (0,0) - integer :: node - type(vector_field), intent(in) :: positions - type(mesh_type), intent(in) :: mesh + function find_zero_zero(positions, mesh) result(node) + ! find the node *closest* to (0,0) + integer :: node + type(vector_field), intent(in) :: positions + type(mesh_type), intent(in) :: mesh - type(vector_field) :: p_model - real min_distance - integer :: i + type(vector_field) :: p_model + real min_distance + integer :: i - call allocate(p_model, positions%dim, mesh, "Coordinate") - call remap_field(positions, p_model) + call allocate(p_model, positions%dim, mesh, "Coordinate") + call remap_field(positions, p_model) - node = 0 - min_distance=huge(1.0) + node = 0 + min_distance=huge(1.0) - do i=1,node_count(p_model) - if (norm2(node_val(p_model, i)) extract_mesh(state_3, "Mesh") - new_mesh => extract_mesh(state_5, "Mesh") - old_position => extract_vector_field(state_3, "Coordinate") - new_position => extract_vector_field(state_5, "Coordinate") + old_mesh => extract_mesh(state_3, "Mesh") + new_mesh => extract_mesh(state_5, "Mesh") + old_position => extract_vector_field(state_3, "Coordinate") + new_position => extract_vector_field(state_5, "Coordinate") - do i=1,3 - write(buf, '(i0)') i - call allocate(old_fields(i), old_mesh, "Temperature" // trim(buf)) - call insert(state_3, old_fields(i), old_fields(i)%name) - call deallocate(old_fields(i)) + do i=1,3 + write(buf, '(i0)') i + call allocate(old_fields(i), old_mesh, "Temperature" // trim(buf)) + call insert(state_3, old_fields(i), old_fields(i)%name) + call deallocate(old_fields(i)) - call allocate(new_fields(i), new_mesh, "Temperature" // trim(buf)) - call insert(state_5, new_fields(i), new_fields(i)%name) - call deallocate(new_fields(i)) - end do + call allocate(new_fields(i), new_mesh, "Temperature" // trim(buf)) + call insert(state_5, new_fields(i), new_fields(i)%name) + call deallocate(new_fields(i)) + end do - call allocate(old_tensor, old_mesh, "Viscosity") - call insert(state_3, old_tensor, "Viscosity") - call deallocate(old_tensor) + call allocate(old_tensor, old_mesh, "Viscosity") + call insert(state_3, old_tensor, "Viscosity") + call deallocate(old_tensor) - call allocate(new_tensor, new_mesh, "Viscosity") - call insert(state_5, new_tensor, "Viscosity") - call deallocate(new_tensor) + call allocate(new_tensor, new_mesh, "Viscosity") + call insert(state_5, new_tensor, "Viscosity") + call deallocate(new_tensor) - call allocate(old_vector, 3, old_mesh, "Velocity") - call insert(state_3, old_vector, "Velocity") - call deallocate(old_vector) + call allocate(old_vector, 3, old_mesh, "Velocity") + call insert(state_3, old_vector, "Velocity") + call deallocate(old_vector) - call allocate(new_vector, 3, new_mesh, "Velocity") - call insert(state_5, new_vector, "Velocity") - call deallocate(new_vector) + call allocate(new_vector, 3, new_mesh, "Velocity") + call insert(state_5, new_vector, "Velocity") + call deallocate(new_vector) - do node=1,node_count(old_mesh) - pos = node_val(old_position, node) - x = pos(1) ; y = pos(2) ; z = pos(3) - old_fields(1)%val(node) = x - old_fields(2)%val(node) = y - old_fields(3)%val(node) = x + y - old_tensor%val(:, :, node) = 0.0 - old_tensor%val(1, 1, node) = x - old_tensor%val(2, 2, node) = y - old_tensor%val(3, 3, node) = z - old_vector%val(1,node) = x - old_vector%val(2,node) = y - old_vector%val(3,node) = z - end do + do node=1,node_count(old_mesh) + pos = node_val(old_position, node) + x = pos(1) ; y = pos(2) ; z = pos(3) + old_fields(1)%val(node) = x + old_fields(2)%val(node) = y + old_fields(3)%val(node) = x + y + old_tensor%val(:, :, node) = 0.0 + old_tensor%val(1, 1, node) = x + old_tensor%val(2, 2, node) = y + old_tensor%val(3, 3, node) = z + old_vector%val(1,node) = x + old_vector%val(2,node) = y + old_vector%val(3,node) = z + end do - call linear_interpolation(state_3, state_5) + call linear_interpolation(state_3, state_5) - call vtk_write_fields("data/linear_interpolation", 0, old_position, old_mesh, sfields=old_fields, vfields=(/old_position/)) - call vtk_write_fields("data/linear_interpolation", 1, new_position, new_mesh, sfields=new_fields, vfields=(/new_position/)) + call vtk_write_fields("data/linear_interpolation", 0, old_position, old_mesh, sfields=old_fields, vfields=(/old_position/)) + call vtk_write_fields("data/linear_interpolation", 1, new_position, new_mesh, sfields=new_fields, vfields=(/new_position/)) - fail = .false. - do node=1,node_count(new_mesh) - pos = node_val(new_position, node) - x = pos(1) ; y = pos(2) ; z = pos(3) - if (.not. fequals(node_val(new_fields(1), node), x, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(1), node) == ", node_val(new_fields(1), node) - write(0,*) "x**2 == ", x**2 - fail = .true. - end if - if (.not. fequals(node_val(new_fields(2), node), y, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(2), node) == ", node_val(new_fields(2), node) - write(0,*) "y**2 == ", y**2 - fail = .true. - end if - if (.not. fequals(node_val(new_fields(3), node), x + y, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(3), node) == ", node_val(new_fields(3), node) - write(0,*) "x**2 + y**2 == ", x**2 + y**2 - fail = .true. - end if - if (.not. fequals(node_val(new_vector, 1, node), x, 0.01)) then - write(0,*) "node == ", node - fail = .true. - end if - if (.not. fequals(node_val(new_vector, 2, node), y, 0.01)) then - write(0,*) "node == ", node - fail = .true. - end if - if (.not. fequals(node_val(new_vector, 3, node), z, 0.01)) then - write(0,*) "node == ", node - fail = .true. - end if - matrix = node_val(new_tensor, node) - if (.not. fequals(matrix(1, 1), x, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_tensor, node) == ", node_val(new_tensor, node) - write(0,*) "x == ", x - fail = .true. - end if - if (.not. fequals(matrix(2, 2), y, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_tensor, node) == ", node_val(new_tensor, node) - write(0,*) "y == ", y - fail = .true. - end if - if (.not. fequals(matrix(3, 3), z, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_tensor, node) == ", node_val(new_tensor, node) - write(0,*) "z == ", z - fail = .true. - end if - end do - call report_test("[linear interpolation]", fail, .false., "All nodal values should be exact.") + fail = .false. + do node=1,node_count(new_mesh) + pos = node_val(new_position, node) + x = pos(1) ; y = pos(2) ; z = pos(3) + if (.not. fequals(node_val(new_fields(1), node), x, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(1), node) == ", node_val(new_fields(1), node) + write(0,*) "x**2 == ", x**2 + fail = .true. + end if + if (.not. fequals(node_val(new_fields(2), node), y, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(2), node) == ", node_val(new_fields(2), node) + write(0,*) "y**2 == ", y**2 + fail = .true. + end if + if (.not. fequals(node_val(new_fields(3), node), x + y, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(3), node) == ", node_val(new_fields(3), node) + write(0,*) "x**2 + y**2 == ", x**2 + y**2 + fail = .true. + end if + if (.not. fequals(node_val(new_vector, 1, node), x, 0.01)) then + write(0,*) "node == ", node + fail = .true. + end if + if (.not. fequals(node_val(new_vector, 2, node), y, 0.01)) then + write(0,*) "node == ", node + fail = .true. + end if + if (.not. fequals(node_val(new_vector, 3, node), z, 0.01)) then + write(0,*) "node == ", node + fail = .true. + end if + matrix = node_val(new_tensor, node) + if (.not. fequals(matrix(1, 1), x, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_tensor, node) == ", node_val(new_tensor, node) + write(0,*) "x == ", x + fail = .true. + end if + if (.not. fequals(matrix(2, 2), y, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_tensor, node) == ", node_val(new_tensor, node) + write(0,*) "y == ", y + fail = .true. + end if + if (.not. fequals(matrix(3, 3), z, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_tensor, node) == ", node_val(new_tensor, node) + write(0,*) "z == ", z + fail = .true. + end if + end do + call report_test("[linear interpolation]", fail, .false., "All nodal values should be exact.") end subroutine test_linear_interpolation diff --git a/error_measures/tests/test_match_up_ellipsoids.F90 b/error_measures/tests/test_match_up_ellipsoids.F90 index 98a82b4f51..e897357695 100644 --- a/error_measures/tests/test_match_up_ellipsoids.F90 +++ b/error_measures/tests/test_match_up_ellipsoids.F90 @@ -1,30 +1,30 @@ subroutine test_match_up_ellipsoids - use gradation_metric - use unittest_tools - implicit none + use gradation_metric + use unittest_tools + implicit none - real, dimension(3, 3) :: vec_P, vec_Q - real, dimension(3) :: val_P, val_Q - integer, dimension(3) :: perm_P, perm_Q - logical :: fail + real, dimension(3, 3) :: vec_P, vec_Q + real, dimension(3) :: val_P, val_Q + integer, dimension(3) :: perm_P, perm_Q + logical :: fail - vec_P(1, :) = (/0.00000000000000000000E+00, 0.36972895530693085375E-01, -0.99931626875382983943E+00/) - vec_P(2, :) = (/0.00000000000000000000E+00, -0.99931626875382983943E+00, -0.36972895530693078436E-01/) - vec_P(3, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) + vec_P(1, :) = (/0.00000000000000000000E+00, 0.36972895530693085375E-01, -0.99931626875382983943E+00/) + vec_P(2, :) = (/0.00000000000000000000E+00, -0.99931626875382983943E+00, -0.36972895530693078436E-01/) + vec_P(3, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) - vec_Q(1, :) = (/0.36972895530693432320E-01, 0.00000000000000000000E+00, -0.99931626875382983943E+00/) - vec_Q(2, :) = (/-0.99931626875382972841E+00, 0.00000000000000000000E+00, -0.36972895530693432320E-01/) - vec_Q(3, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) + vec_Q(1, :) = (/0.36972895530693432320E-01, 0.00000000000000000000E+00, -0.99931626875382983943E+00/) + vec_Q(2, :) = (/-0.99931626875382972841E+00, 0.00000000000000000000E+00, -0.36972895530693432320E-01/) + vec_Q(3, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) - val_P = (/0.16000000000000000000E+02, 0.16000000000000003553E+02, 0.10000000000000000000E+03/) - val_Q = (/0.15999999999999998224E+02, 0.16000000000000000000E+02, 0.10000000000000000000E+03/) + val_P = (/0.16000000000000000000E+02, 0.16000000000000003553E+02, 0.10000000000000000000E+03/) + val_Q = (/0.15999999999999998224E+02, 0.16000000000000000000E+02, 0.10000000000000000000E+03/) - call match_up_ellipsoids(vec_P, val_P, perm_P, vec_Q, val_Q, perm_Q) + call match_up_ellipsoids(vec_P, val_P, perm_P, vec_Q, val_Q, perm_Q) - fail = .false. - if (perm_Q(2) == perm_Q(3)) fail = .true. - call report_test("[match up ellipsoids]", fail, .false., & - "Previous bugs should not happen again.") + fail = .false. + if (perm_Q(2) == perm_Q(3)) fail = .true. + call report_test("[match up ellipsoids]", fail, .false., & + "Previous bugs should not happen again.") end subroutine test_match_up_ellipsoids diff --git a/error_measures/tests/test_match_up_vectors.F90 b/error_measures/tests/test_match_up_vectors.F90 index 1300c0e8a5..f3a2b392fa 100644 --- a/error_measures/tests/test_match_up_vectors.F90 +++ b/error_measures/tests/test_match_up_vectors.F90 @@ -1,109 +1,109 @@ subroutine test_match_up_vectors - use metric_tools - use gradation_metric - use unittest_tools - use vector_tools - implicit none - - real, dimension(3, 3) :: P, Q, vec_P, vec_Q - real, dimension(3) :: eigenvals - integer, dimension(3) :: permutation_P, permutation_Q - real, dimension(3, 1) :: vec_P_short - integer, dimension(1) :: perm_P_short - integer :: stat - - logical :: fail - integer :: i, j - character(len=20) :: buf - - vec_P = get_matrix_identity(3) - - vec_Q(:, 1) = (/1.0, 0.0, 0.0/) - vec_Q(:, 2) = (/0.0, 1.0, -0.1/) ; vec_Q(:, 2) = vec_Q(:, 2) / norm(vec_Q(:, 2)) - vec_Q(:, 3) = (/0.0, 0.1, 1.0/) ; vec_Q(:, 3) = vec_Q(:, 3) / norm(vec_Q(:, 3)) - - call eigenrecomposition(P, vec_P, (/1.0, 1.0, 1.0/)) - call eigenrecomposition(Q, vec_Q, (/1.0, 1.0, 1.0/)) - - call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) - - fail = .false. - do j=1,3 - if (permutation_P(j) /= permutation_Q(j)) fail = .true. - end do - call report_test("[match up known vectors]", fail, .false., "Any reasonable & - & algorithm for matching up vectors must yield the identity & - & permutation in this case.") - - vec_Q = get_matrix_identity(3) - vec_Q(:, 3) = vec_Q(:, 2) - vec_Q(:, 2) = vec_Q(:, 1) - vec_Q(:, 1) = (/0.0, 0.0, 1.0/) - - call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) - - fail = .false. - do j=1,3 - if (permutation_P(j) == 1 .and. permutation_Q(j) /= 3) fail = .true. - if (permutation_P(j) == 2 .and. permutation_Q(j) /= 1) fail = .true. - if (permutation_P(j) == 3 .and. permutation_Q(j) /= 2) fail = .true. - end do - call report_test("[match up known vectors]", fail, .false., "Any reasonable & - & algorithm for matching up vectors must yield the (3, 1, 2) & - & permutation in this case.") - - vec_P_short(:, 1) = (/0.0, 0.0, 1.0/) - vec_Q = get_matrix_identity(3) - call match_up_vectors(vec_P_short, perm_P_short, vec_Q, permutation_Q) - fail = .false. - if (perm_P_short(1) /= 3) fail = .true. - if (permutation_Q(1) /= 1) fail = .true. - call report_test("[match up known vectors]", fail, .false., "Match up vectors & - & should work for just one vector, too.") - - do i=1,5 - write(buf, '(i0)') i - - P = random_posdef_matrix(3) - Q = random_posdef_matrix(3) - call eigendecomposition(P, vec_P, eigenvals) - call eigendecomposition(Q, vec_Q, eigenvals) - - call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) - - fail = .false. - if (sum(permutation_P) /= 6) fail = .true. ! 1 + 2 + 3 = 6 - if (sum(permutation_Q) /= 6) fail = .true. ! 1 + 2 + 3 = 6 - if (product(permutation_P) /= 6) fail = .true. ! 1 * 2 * 3 = 6 - if (product(permutation_Q) /= 6) fail = .true. ! 1 * 2 * 3 = 6 - call report_test("[match up vectors gives a permutation " // trim(buf) // "]", fail, .false., "Matching up & - & vectors should give a permutation.") - end do - - vec_P(1, :) = (/0.96864848337775710796E+00, -0.24842986328315525002E+00, -0.16488417400240069823E-02/) - vec_P(2, :) = (/0.24843533494648231685E+00, 0.96862714938199356851E+00, 0.64288280535788229486E-02/) - vec_P(3, :) = (/0.00000000000000000000E+00, -0.66369050939521093482E-02, 0.99997797550284772683E+00/) - - vec_Q(1, :) = (/0.96864848337775721898E+00, -0.24842986326122473706E+00, -0.16488450442796352084E-02/) - vec_Q(2, :) = (/0.24843533494648234461E+00, 0.96862714929648652262E+00, 0.64288409368597095039E-02/) - vec_Q(3, :) = (/0.00000000000000000000E+00, -0.66369183942164558174E-02, 0.99997797541457311699E+00/) - - fail = .false. - call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) - call check_perm(permutation_P, stat) - if (stat /= 0) then - fail = .true. - call write_vector(permutation_P, "perm_P") - end if - - call check_perm(permutation_Q, stat) - if (stat /= 0) then - fail = .true. - call write_vector(permutation_Q, "perm_Q") - end if - - call report_test("[match up vectors regression]", fail, .false., "Previous bugs & - & shouldn't happen again.") + use metric_tools + use gradation_metric + use unittest_tools + use vector_tools + implicit none + + real, dimension(3, 3) :: P, Q, vec_P, vec_Q + real, dimension(3) :: eigenvals + integer, dimension(3) :: permutation_P, permutation_Q + real, dimension(3, 1) :: vec_P_short + integer, dimension(1) :: perm_P_short + integer :: stat + + logical :: fail + integer :: i, j + character(len=20) :: buf + + vec_P = get_matrix_identity(3) + + vec_Q(:, 1) = (/1.0, 0.0, 0.0/) + vec_Q(:, 2) = (/0.0, 1.0, -0.1/) ; vec_Q(:, 2) = vec_Q(:, 2) / norm(vec_Q(:, 2)) + vec_Q(:, 3) = (/0.0, 0.1, 1.0/) ; vec_Q(:, 3) = vec_Q(:, 3) / norm(vec_Q(:, 3)) + + call eigenrecomposition(P, vec_P, (/1.0, 1.0, 1.0/)) + call eigenrecomposition(Q, vec_Q, (/1.0, 1.0, 1.0/)) + + call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) + + fail = .false. + do j=1,3 + if (permutation_P(j) /= permutation_Q(j)) fail = .true. + end do + call report_test("[match up known vectors]", fail, .false., "Any reasonable & + & algorithm for matching up vectors must yield the identity & + & permutation in this case.") + + vec_Q = get_matrix_identity(3) + vec_Q(:, 3) = vec_Q(:, 2) + vec_Q(:, 2) = vec_Q(:, 1) + vec_Q(:, 1) = (/0.0, 0.0, 1.0/) + + call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) + + fail = .false. + do j=1,3 + if (permutation_P(j) == 1 .and. permutation_Q(j) /= 3) fail = .true. + if (permutation_P(j) == 2 .and. permutation_Q(j) /= 1) fail = .true. + if (permutation_P(j) == 3 .and. permutation_Q(j) /= 2) fail = .true. + end do + call report_test("[match up known vectors]", fail, .false., "Any reasonable & + & algorithm for matching up vectors must yield the (3, 1, 2) & + & permutation in this case.") + + vec_P_short(:, 1) = (/0.0, 0.0, 1.0/) + vec_Q = get_matrix_identity(3) + call match_up_vectors(vec_P_short, perm_P_short, vec_Q, permutation_Q) + fail = .false. + if (perm_P_short(1) /= 3) fail = .true. + if (permutation_Q(1) /= 1) fail = .true. + call report_test("[match up known vectors]", fail, .false., "Match up vectors & + & should work for just one vector, too.") + + do i=1,5 + write(buf, '(i0)') i + + P = random_posdef_matrix(3) + Q = random_posdef_matrix(3) + call eigendecomposition(P, vec_P, eigenvals) + call eigendecomposition(Q, vec_Q, eigenvals) + + call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) + + fail = .false. + if (sum(permutation_P) /= 6) fail = .true. ! 1 + 2 + 3 = 6 + if (sum(permutation_Q) /= 6) fail = .true. ! 1 + 2 + 3 = 6 + if (product(permutation_P) /= 6) fail = .true. ! 1 * 2 * 3 = 6 + if (product(permutation_Q) /= 6) fail = .true. ! 1 * 2 * 3 = 6 + call report_test("[match up vectors gives a permutation " // trim(buf) // "]", fail, .false., "Matching up & + & vectors should give a permutation.") + end do + + vec_P(1, :) = (/0.96864848337775710796E+00, -0.24842986328315525002E+00, -0.16488417400240069823E-02/) + vec_P(2, :) = (/0.24843533494648231685E+00, 0.96862714938199356851E+00, 0.64288280535788229486E-02/) + vec_P(3, :) = (/0.00000000000000000000E+00, -0.66369050939521093482E-02, 0.99997797550284772683E+00/) + + vec_Q(1, :) = (/0.96864848337775721898E+00, -0.24842986326122473706E+00, -0.16488450442796352084E-02/) + vec_Q(2, :) = (/0.24843533494648234461E+00, 0.96862714929648652262E+00, 0.64288409368597095039E-02/) + vec_Q(3, :) = (/0.00000000000000000000E+00, -0.66369183942164558174E-02, 0.99997797541457311699E+00/) + + fail = .false. + call match_up_vectors(vec_P, permutation_P, vec_Q, permutation_Q) + call check_perm(permutation_P, stat) + if (stat /= 0) then + fail = .true. + call write_vector(permutation_P, "perm_P") + end if + + call check_perm(permutation_Q, stat) + if (stat /= 0) then + fail = .true. + call write_vector(permutation_Q, "perm_Q") + end if + + call report_test("[match up vectors regression]", fail, .false., "Previous bugs & + & shouldn't happen again.") end subroutine test_match_up_vectors diff --git a/error_measures/tests/test_mba_adapt.F90 b/error_measures/tests/test_mba_adapt.F90 index ca73a93c20..bf02e2d4a6 100644 --- a/error_measures/tests/test_mba_adapt.F90 +++ b/error_measures/tests/test_mba_adapt.F90 @@ -2,82 +2,82 @@ subroutine test_mba_adapt - use unittest_tools - use metric_assemble - use edge_length_module - use fields - use state_module - use vtk_interfaces - use mba_adapt_module - use form_metric_field - use field_options - use spud - implicit none + use unittest_tools + use metric_assemble + use edge_length_module + use fields + use state_module + use vtk_interfaces + use mba_adapt_module + use form_metric_field + use field_options + use spud + implicit none #ifdef HAVE_MPI - include "mpif.h" + include "mpif.h" #endif #ifdef HAVE_MBA - type(state_type) :: state, state_array(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions, velocity_pointer - type(vector_field) :: velocity - type(scalar_field) :: pressure, edgelen - type(tensor_field) :: metric - - integer :: i, stat - real :: x, y - - call vtk_read_state("data/mms_a.vtu", state) - mesh => extract_mesh(state, "Mesh") - call add_faces(mesh) - positions => extract_vector_field(state, "Coordinate") - call allocate(pressure, mesh, "Pressure") - call allocate(velocity, 2, mesh, "Velocity") - call allocate(edgelen, mesh, "Edge lengths") - call allocate(metric, mesh, "Metric") - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - pressure%val(i) = x * x - velocity%val(1,i) = x - velocity%val(2,i) = y - end do - - call adaptivity_options(state, pressure, 0.001, .false.) - - call insert(state, pressure, "Pressure") - call insert(state, velocity, "Velocity") - positions => extract_vector_field(state, "Coordinate") - - call set_option("/mesh_adaptivity/hr_adaptivity/constant_size_constraint/minimum_edge_length", 0.01, stat=stat) - call set_option("/mesh_adaptivity/hr_adaptivity/constant_size_constraint/maximum_edge_length", 1.0, stat=stat) - - state_array(1) = state - !call assemble_metric(state_array, metric) - metric%val = 0.0 - metric%val(1, 1, :) = 1.0; metric%val(2, 2, :) = 1.0 - call get_edge_lengths(metric, edgelen) - call vtk_write_state("data/2d_adapt", 0, state=(/state/)) - call mba_adapt(state, metric) - - call report_test("[adaptivity runs]", .false., .false., "Congratulations! & - & You didn't crash.") - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity_pointer => extract_vector_field(state, "Velocity") - call vtk_write_state("data/2d_adapt", 1, state=(/state/)) + type(state_type) :: state, state_array(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions, velocity_pointer + type(vector_field) :: velocity + type(scalar_field) :: pressure, edgelen + type(tensor_field) :: metric + + integer :: i, stat + real :: x, y + + call vtk_read_state("data/mms_a.vtu", state) + mesh => extract_mesh(state, "Mesh") + call add_faces(mesh) + positions => extract_vector_field(state, "Coordinate") + call allocate(pressure, mesh, "Pressure") + call allocate(velocity, 2, mesh, "Velocity") + call allocate(edgelen, mesh, "Edge lengths") + call allocate(metric, mesh, "Metric") + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + pressure%val(i) = x * x + velocity%val(1,i) = x + velocity%val(2,i) = y + end do + + call adaptivity_options(state, pressure, 0.001, .false.) + + call insert(state, pressure, "Pressure") + call insert(state, velocity, "Velocity") + positions => extract_vector_field(state, "Coordinate") + + call set_option("/mesh_adaptivity/hr_adaptivity/constant_size_constraint/minimum_edge_length", 0.01, stat=stat) + call set_option("/mesh_adaptivity/hr_adaptivity/constant_size_constraint/maximum_edge_length", 1.0, stat=stat) + + state_array(1) = state + !call assemble_metric(state_array, metric) + metric%val = 0.0 + metric%val(1, 1, :) = 1.0; metric%val(2, 2, :) = 1.0 + call get_edge_lengths(metric, edgelen) + call vtk_write_state("data/2d_adapt", 0, state=(/state/)) + call mba_adapt(state, metric) + + call report_test("[adaptivity runs]", .false., .false., "Congratulations! & + & You didn't crash.") + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity_pointer => extract_vector_field(state, "Velocity") + call vtk_write_state("data/2d_adapt", 1, state=(/state/)) #endif - call report_test("[adaptivity output]", .false., .false., "Congratulations! & - & The output from adaptivity might even be OK if you get this far.") + call report_test("[adaptivity output]", .false., .false., "Congratulations! & + & The output from adaptivity might even be OK if you get this far.") #ifdef HAVE_MBA - call deallocate(metric) - call deallocate(state) + call deallocate(metric) + call deallocate(state) #endif end subroutine test_mba_adapt diff --git a/error_measures/tests/test_merge_tensors.F90 b/error_measures/tests/test_merge_tensors.F90 index 63a285753e..aad02fa52f 100644 --- a/error_measures/tests/test_merge_tensors.F90 +++ b/error_measures/tests/test_merge_tensors.F90 @@ -1,216 +1,216 @@ subroutine test_merge_tensors - use merge_tensors - use vector_tools - use unittest_tools + use merge_tensors + use vector_tools + use unittest_tools - real, dimension(2, 2) :: tensor1, tensor2 - real, dimension(3, 3) :: tensor3, tensor4, tensor5, evecs - real, dimension(3) :: evals - real :: rand1, rand2 - integer :: i, j - logical :: fail = .false., warn = .false. + real, dimension(2, 2) :: tensor1, tensor2 + real, dimension(3, 3) :: tensor3, tensor4, tensor5, evecs + real, dimension(3) :: evals + real :: rand1, rand2 + integer :: i, j + logical :: fail = .false., warn = .false. - tensor3(1, :) = (/0.44444444444444443910E-10, -0.50465783670179635238E-10, -0.61349817493813233242E-10/) - tensor3(2, :) = (/-0.50465783670179635238E-10, 0.44444444444444443910E-10, 0.76850819455089155588E-10/) - tensor3(3, :) = (/-0.61349817493813233242E-10, 0.76850819455089155588E-10, 0.25000000000000007974E-04/) - tensor4(1, :) = (/0.71326666461061381599E-09, 0.17461636435229589495E-09, -0.86585670292680812475E-08/) - tensor4(2, :) = (/0.17461636435229589495E-09, 0.16746373209124310592E-09, -0.84640035445143090179E-09/) - tensor4(3, :) = (/-0.86585670292680795931E-08, -0.84640035445143193577E-09, 0.25153686650982690250E-04/) - call merge_tensor(tensor3, tensor4) - ! Passing is not crashing. + tensor3(1, :) = (/0.44444444444444443910E-10, -0.50465783670179635238E-10, -0.61349817493813233242E-10/) + tensor3(2, :) = (/-0.50465783670179635238E-10, 0.44444444444444443910E-10, 0.76850819455089155588E-10/) + tensor3(3, :) = (/-0.61349817493813233242E-10, 0.76850819455089155588E-10, 0.25000000000000007974E-04/) + tensor4(1, :) = (/0.71326666461061381599E-09, 0.17461636435229589495E-09, -0.86585670292680812475E-08/) + tensor4(2, :) = (/0.17461636435229589495E-09, 0.16746373209124310592E-09, -0.84640035445143090179E-09/) + tensor4(3, :) = (/-0.86585670292680795931E-08, -0.84640035445143193577E-09, 0.25153686650982690250E-04/) + call merge_tensor(tensor3, tensor4) + ! Passing is not crashing. - tensor1(1, :) = (/1.0, 0.0/) - tensor1(2, :) = (/0.0, 2.0/) + tensor1(1, :) = (/1.0, 0.0/) + tensor1(2, :) = (/0.0, 2.0/) - tensor2(1, :) = (/2.0, 0.0/) - tensor2(2, :) = (/0.0, 1.0/) + tensor2(1, :) = (/2.0, 0.0/) + tensor2(2, :) = (/0.0, 1.0/) - call merge_tensor(tensor1, tensor2) - if (.not. fequals(tensor1(1, 1), 2.0)) fail = .true. - if (.not. fequals(tensor1(1, 2), 0.0)) fail = .true. - if (.not. fequals(tensor1(2, 1), 0.0)) fail = .true. - if (.not. fequals(tensor1(2, 2), 2.0)) fail = .true. + call merge_tensor(tensor1, tensor2) + if (.not. fequals(tensor1(1, 1), 2.0)) fail = .true. + if (.not. fequals(tensor1(1, 2), 0.0)) fail = .true. + if (.not. fequals(tensor1(2, 1), 0.0)) fail = .true. + if (.not. fequals(tensor1(2, 2), 2.0)) fail = .true. - ! if eigenvectors are aligned, the eigenvalues of the result should just be the max of the two inputs - call report_test("[merge tensors: 1]", fail, warn, "Merging of tensors is not 2*I.") + ! if eigenvectors are aligned, the eigenvalues of the result should just be the max of the two inputs + call report_test("[merge tensors: 1]", fail, warn, "Merging of tensors is not 2*I.") - fail = .false. - warn = .false. + fail = .false. + warn = .false. - tensor1(1, :) = (/1.0, 0.0/) - tensor1(2, :) = (/0.0, 1.0/) + tensor1(1, :) = (/1.0, 0.0/) + tensor1(2, :) = (/0.0, 1.0/) - tensor2(1, :) = (/3.0/2, 1.0/2/) - tensor2(2, :) = (/1.0/2, 3.0/2/) + tensor2(1, :) = (/3.0/2, 1.0/2/) + tensor2(2, :) = (/1.0/2, 3.0/2/) - ! merging with I should be the identity operation if minimum eigenvalue of A is >= 1 - call merge_tensor(tensor1, tensor2) + ! merging with I should be the identity operation if minimum eigenvalue of A is >= 1 + call merge_tensor(tensor1, tensor2) - if (.not. fequals(tensor1(1, 1), tensor2(1, 1))) fail = .true. - if (.not. fequals(tensor1(1, 2), tensor2(1, 2))) fail = .true. - if (.not. fequals(tensor1(2, 1), tensor2(2, 1))) fail = .true. - if (.not. fequals(tensor1(2, 2), tensor2(2, 2))) fail = .true. + if (.not. fequals(tensor1(1, 1), tensor2(1, 1))) fail = .true. + if (.not. fequals(tensor1(1, 2), tensor2(1, 2))) fail = .true. + if (.not. fequals(tensor1(2, 1), tensor2(2, 1))) fail = .true. + if (.not. fequals(tensor1(2, 2), tensor2(2, 2))) fail = .true. - call report_test("[merge tensors: 2]", fail, warn, & - "If max eigenvalue of A is >= 1, merging with identity is the identity operation.") + call report_test("[merge tensors: 2]", fail, warn, & + "If max eigenvalue of A is >= 1, merging with identity is the identity operation.") - fail = .false. - warn = .false. + fail = .false. + warn = .false. - tensor3(1, :) = (/100.0, 0.0, 0.0/) - tensor3(2, :) = (/0.0, 100.0, 0.0/) - tensor3(3, :) = (/0.0, 0.0, 100.0/) + tensor3(1, :) = (/100.0, 0.0, 0.0/) + tensor3(2, :) = (/0.0, 100.0, 0.0/) + tensor3(3, :) = (/0.0, 0.0, 100.0/) - tensor4 = tensor3 - tensor5 = tensor3 + tensor4 = tensor3 + tensor5 = tensor3 - call merge_tensor(tensor3, tensor4) + call merge_tensor(tensor3, tensor4) - do i=1,3 - do j=1,3 - if (.not. fequals(tensor3(i, j), tensor5(i, j))) fail = .true. - end do - end do + do i=1,3 + do j=1,3 + if (.not. fequals(tensor3(i, j), tensor5(i, j))) fail = .true. + end do + end do - call report_test("[merge tensors: 3]", fail, warn, "Merging identical metrics should yield the metric back.") + call report_test("[merge tensors: 3]", fail, warn, "Merging identical metrics should yield the metric back.") - fail = .false. - warn = .false. + fail = .false. + warn = .false. - tensor3 = random_posdef_matrix(3) - tensor4 = tensor3 - tensor5 = tensor3 + tensor3 = random_posdef_matrix(3) + tensor4 = tensor3 + tensor5 = tensor3 - call merge_tensor(tensor3, tensor4) + call merge_tensor(tensor3, tensor4) - do i=1,3 - do j=1,3 - if (.not. fequals(tensor3(i, j), tensor5(i, j))) fail = .true. - end do - end do + do i=1,3 + do j=1,3 + if (.not. fequals(tensor3(i, j), tensor5(i, j))) fail = .true. + end do + end do - call report_test("[merge tensors: 4]", fail, warn, "Merging identical metrics should yield the metric back.") + call report_test("[merge tensors: 4]", fail, warn, "Merging identical metrics should yield the metric back.") - fail = .false. - warn = .false. + fail = .false. + warn = .false. - tensor3(1, :) = (/1.00467, 0.00162196, -0.24383/) - tensor3(2, :) = (/0.00162196, 6.2432, -1.98199/) - tensor3(3, :) = (/-0.24383, -1.98199, 14.4226/) + tensor3(1, :) = (/1.00467, 0.00162196, -0.24383/) + tensor3(2, :) = (/0.00162196, 6.2432, -1.98199/) + tensor3(3, :) = (/-0.24383, -1.98199, 14.4226/) - tensor4(1, :) = (/4.05543, 0.0983953, 0.643409/) - tensor4(2, :) = (/0.0983953, 1.34818, -0.989943/) - tensor4(3, :) = (/0.643409, -0.989943, 4.09606/) + tensor4(1, :) = (/4.05543, 0.0983953, 0.643409/) + tensor4(2, :) = (/0.0983953, 1.34818, -0.989943/) + tensor4(3, :) = (/0.643409, -0.989943, 4.09606/) - !call merge_tensor(tensor3, tensor4) + !call merge_tensor(tensor3, tensor4) - tensor4(1, :) = (/3.11438, 1.37323, -2.03115/) - tensor4(2, :) = (/1.37323, 10.2941, 10.1273/) - tensor4(3, :) = (/-2.03115, 10.1273, 15.8707/) + tensor4(1, :) = (/3.11438, 1.37323, -2.03115/) + tensor4(2, :) = (/1.37323, 10.2941, 10.1273/) + tensor4(3, :) = (/-2.03115, 10.1273, 15.8707/) - do i=1,3 - do j=1,3 - if (.not. fequals(tensor3(i, j), tensor4(i, j))) fail = .true. - end do - end do + do i=1,3 + do j=1,3 + if (.not. fequals(tensor3(i, j), tensor4(i, j))) fail = .true. + end do + end do - !call report_test("[merge tensors: 5]", fail, warn, "Previous bugs should not happen again.") + !call report_test("[merge tensors: 5]", fail, warn, "Previous bugs should not happen again.") - fail = .false. - warn = .false. + fail = .false. + warn = .false. - tensor3(1, :) = (/4.42362, 0.409988, -0.491779/) - tensor3(2, :) = (/0.409988, 5.55217, -2.27999/) - tensor3(3, :) = (/-0.491779, -2.27999, 7.35012/) + tensor3(1, :) = (/4.42362, 0.409988, -0.491779/) + tensor3(2, :) = (/0.409988, 5.55217, -2.27999/) + tensor3(3, :) = (/-0.491779, -2.27999, 7.35012/) - tensor4(1, :) = (/6.35559, -0.789674, -0.0779207/) - tensor4(2, :) = (/-0.789674, 2.75034, 0.084052/) - tensor4(3, :) = (/-0.0779207, 0.084052, 1.11065/) + tensor4(1, :) = (/6.35559, -0.789674, -0.0779207/) + tensor4(2, :) = (/-0.789674, 2.75034, 0.084052/) + tensor4(3, :) = (/-0.0779207, 0.084052, 1.11065/) - !call merge_tensor(tensor3, tensor4) + !call merge_tensor(tensor3, tensor4) - tensor4(1, :) = (/17.0109, 3.62308, 1.0516/) - tensor4(2, :) = (/3.62308, 4.66043, 5.45704/) - tensor4(3, :) = (/1.0516, 5.45704, 9.01446/) + tensor4(1, :) = (/17.0109, 3.62308, 1.0516/) + tensor4(2, :) = (/3.62308, 4.66043, 5.45704/) + tensor4(3, :) = (/1.0516, 5.45704, 9.01446/) - do i=1,3 - do j=1,3 - if (.not. fequals(tensor3(i, j), tensor4(i, j))) fail = .true. - end do - end do + do i=1,3 + do j=1,3 + if (.not. fequals(tensor3(i, j), tensor4(i, j))) fail = .true. + end do + end do - !call report_test("[merge tensors: 6]", fail, warn, "Previous bugs should not happen again.") + !call report_test("[merge tensors: 6]", fail, warn, "Previous bugs should not happen again.") - fail = .false. - warn = .false. + fail = .false. + warn = .false. - call random_number(rand1) - tensor3 = get_mat_diag((/rand1, rand1, rand1/)) + call random_number(rand1) + tensor3 = get_mat_diag((/rand1, rand1, rand1/)) - call random_number(rand2) - tensor4 = get_mat_diag((/rand2, rand2, rand2/)) + call random_number(rand2) + tensor4 = get_mat_diag((/rand2, rand2, rand2/)) - call merge_tensor(tensor3, tensor4) - if (.not. mat_diag(tensor3)) fail = .true. + call merge_tensor(tensor3, tensor4) + if (.not. mat_diag(tensor3)) fail = .true. - rand1 = max(rand1, rand2) - do i=1,3 - if (.not. fequals(tensor3(i, i), rand1)) fail = .true. - end do + rand1 = max(rand1, rand2) + do i=1,3 + if (.not. fequals(tensor3(i, i), rand1)) fail = .true. + end do - call report_test("[merge tensors: 5]", fail, warn, "Merging diagonal matrices should yield a diagonal matrix back.") + call report_test("[merge tensors: 5]", fail, warn, "Merging diagonal matrices should yield a diagonal matrix back.") - fail = .false. - warn = .false. - tensor3(1, :) = (/0.10017100417445532479E+01, -0.16978728026906123386E-03, -0.37497787153930919518E-05/) - tensor3(2, :) = (/-0.16978728026906123386E-03, 0.10000168579045705108E+01, 0.37230946659257456045E-06/) - tensor3(3, :) = (/-0.37497787153935256327E-05, 0.37230946659257456045E-06, 0.10000000082225128928E+01/) + fail = .false. + warn = .false. + tensor3(1, :) = (/0.10017100417445532479E+01, -0.16978728026906123386E-03, -0.37497787153930919518E-05/) + tensor3(2, :) = (/-0.16978728026906123386E-03, 0.10000168579045705108E+01, 0.37230946659257456045E-06/) + tensor3(3, :) = (/-0.37497787153935256327E-05, 0.37230946659257456045E-06, 0.10000000082225128928E+01/) - call eigendecomposition_symmetric(tensor3, evecs, evals) + call eigendecomposition_symmetric(tensor3, evecs, evals) - tensor4 = get_matrix_identity(3) - tensor5 = tensor3 + tensor4 = get_matrix_identity(3) + tensor5 = tensor3 - call merge_tensor(tensor3, tensor4) - call eigendecomposition_symmetric(tensor3, evecs, evals) + call merge_tensor(tensor3, tensor4) + call eigendecomposition_symmetric(tensor3, evecs, evals) - do i=1,3 - do j=1,3 - if (.not. fequals(tensor3(i, i), tensor5(i, i))) fail = .true. - end do - end do + do i=1,3 + do j=1,3 + if (.not. fequals(tensor3(i, i), tensor5(i, i))) fail = .true. + end do + end do - call report_test("[merge tensors: 6]", fail, warn, "Merging tensors with all eigenvalues > 1 with the identity should be the & - & identity operation.") + call report_test("[merge tensors: 6]", fail, warn, "Merging tensors with all eigenvalues > 1 with the identity should be the & + & identity operation.") - tensor1(1, :) = (/1.0, 0.0/) - tensor1(2, :) = (/0.0, 1.0/) - tensor2(1, :) = (/0.0, 0.0/) - tensor2(2, :) = (/0.0, 0.0/) + tensor1(1, :) = (/1.0, 0.0/) + tensor1(2, :) = (/0.0, 1.0/) + tensor2(1, :) = (/0.0, 0.0/) + tensor2(2, :) = (/0.0, 0.0/) - call merge_tensor(tensor1, tensor2) + call merge_tensor(tensor1, tensor2) - fail = .false. - if (tensor1 .fne. get_mat_diag((/1.0, 1.0/))) then - fail = .true. - end if + fail = .false. + if (tensor1 .fne. get_mat_diag((/1.0, 1.0/))) then + fail = .true. + end if - call report_test("[merge tensors: 7]", fail, warn, "Merging a tensor with the zero tensor should be & - & a no-op.") + call report_test("[merge tensors: 7]", fail, warn, "Merging a tensor with the zero tensor should be & + & a no-op.") - tensor1(1, :) = (/0.0, 0.0/) - tensor1(2, :) = (/0.0, 0.0/) - tensor2(1, :) = (/1.0, 0.0/) - tensor2(2, :) = (/0.0, 1.0/) + tensor1(1, :) = (/0.0, 0.0/) + tensor1(2, :) = (/0.0, 0.0/) + tensor2(1, :) = (/1.0, 0.0/) + tensor2(2, :) = (/0.0, 1.0/) - call merge_tensor(tensor1, tensor2) + call merge_tensor(tensor1, tensor2) - fail = .false. - if (tensor1 .fne. get_mat_diag((/1.0, 1.0/))) then - fail = .true. - end if + fail = .false. + if (tensor1 .fne. get_mat_diag((/1.0, 1.0/))) then + fail = .true. + end if - call report_test("[merge tensors: 8]", fail, warn, "Merging the zero tensor should be assignment.") + call report_test("[merge tensors: 8]", fail, warn, "Merging the zero tensor should be assignment.") end subroutine test_merge_tensors diff --git a/error_measures/tests/test_mesh_conformity.F90 b/error_measures/tests/test_mesh_conformity.F90 index 7748fe0237..9acbadb8bc 100644 --- a/error_measures/tests/test_mesh_conformity.F90 +++ b/error_measures/tests/test_mesh_conformity.F90 @@ -1,43 +1,43 @@ subroutine test_mesh_conformity - use fields - use mesh_files - use unittest_tools - use conformity_measurement - implicit none - - type(vector_field), target :: X - type(mesh_type), pointer :: mesh - type(tensor_field) :: metric - type(scalar_field) :: conformity - logical :: fail - real :: a, b - - X=read_mesh_files("data/eqtriangle.1", format="gmsh", quad_degree=4) - mesh => X%mesh - - call allocate(metric, mesh, "ErrorMetric", field_type=FIELD_TYPE_CONSTANT) - call set(metric, get_matrix_identity(X%dim)) - - conformity = piecewise_constant_field(mesh, "MeshConformity") - - call compute_mesh_conformity(metric, X, conformity) - - fail = (node_val(conformity, 1) > 1e-7) - call report_test("[test_mesh_conformity]", fail, .false., "Perfect meshes give zero.") - - call set(metric, 2 * get_matrix_identity(X%dim)) - call compute_mesh_conformity(metric, X, conformity) - fail = (node_val(conformity, 1) .fne. (1 / sqrt(2.0))) - call report_test("[test_mesh_conformity]", fail, .false., "Double the length scale: 1/sqrt(2.0)") - - call set(metric, 10 * get_matrix_identity(X%dim)) - call compute_mesh_conformity(metric, X, conformity) - a = node_val(conformity, 1) - call set(metric, 0.1 * get_matrix_identity(X%dim)) - call compute_mesh_conformity(metric, X, conformity) - b = node_val(conformity, 1) - - fail = (a .fne. b) - call report_test("[test_mesh_conformity]", fail, .false., "Too big and too short should be the same") + use fields + use mesh_files + use unittest_tools + use conformity_measurement + implicit none + + type(vector_field), target :: X + type(mesh_type), pointer :: mesh + type(tensor_field) :: metric + type(scalar_field) :: conformity + logical :: fail + real :: a, b + + X=read_mesh_files("data/eqtriangle.1", format="gmsh", quad_degree=4) + mesh => X%mesh + + call allocate(metric, mesh, "ErrorMetric", field_type=FIELD_TYPE_CONSTANT) + call set(metric, get_matrix_identity(X%dim)) + + conformity = piecewise_constant_field(mesh, "MeshConformity") + + call compute_mesh_conformity(metric, X, conformity) + + fail = (node_val(conformity, 1) > 1e-7) + call report_test("[test_mesh_conformity]", fail, .false., "Perfect meshes give zero.") + + call set(metric, 2 * get_matrix_identity(X%dim)) + call compute_mesh_conformity(metric, X, conformity) + fail = (node_val(conformity, 1) .fne. (1 / sqrt(2.0))) + call report_test("[test_mesh_conformity]", fail, .false., "Double the length scale: 1/sqrt(2.0)") + + call set(metric, 10 * get_matrix_identity(X%dim)) + call compute_mesh_conformity(metric, X, conformity) + a = node_val(conformity, 1) + call set(metric, 0.1 * get_matrix_identity(X%dim)) + call compute_mesh_conformity(metric, X, conformity) + b = node_val(conformity, 1) + + fail = (a .fne. b) + call report_test("[test_mesh_conformity]", fail, .false., "Too big and too short should be the same") end subroutine test_mesh_conformity diff --git a/error_measures/tests/test_metric_advection.F90 b/error_measures/tests/test_metric_advection.F90 index a9aea7e54c..d04ff196b7 100644 --- a/error_measures/tests/test_metric_advection.F90 +++ b/error_measures/tests/test_metric_advection.F90 @@ -5,129 +5,129 @@ subroutine test_metric_advection #define NADAPT 5 - use global_parameters, only: new_options - use metric_assemble - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use state_module - use vtk_interfaces - use vector_tools - use unittest_tools - use edge_length_module - use gradation_metric - use mpi - use interpolation_error - use field_options - implicit none - - type(state_type) :: state, dummy(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions, velocity - type(vector_field) :: velocity_real, grid_velocity - type(scalar_field), pointer :: field_ptr - type(tensor_field) :: metric - type(scalar_field) :: field - integer :: i, stat - - interface - function solution(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface - interface - function velocity_func(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: velocity_func - end function - end interface - - call vtk_read_state("data/test_metric_advection/mesh.vtu", state) - call load_options("data/test_metric_advection/settings.flml") - call set_option("/mesh_adaptivity/hr_adaptivity/metric_advection/iterations", 0) - call adaptivity_bounds(state, 0.001, 0.05) - - mesh => extract_mesh(state, "Mesh") - call add_faces(mesh) - positions => extract_vector_field(state, "Coordinate") - - call allocate(velocity_real, 3, mesh, "NonlinearVelocity") - call set_from_function(velocity_real, velocity_func, positions) - call insert(state, velocity_real, "NonlinearVelocity") - call deallocate(velocity_real) - - call allocate(grid_velocity, 3, mesh, "GridVelocity") - call zero(grid_velocity) - call insert(state, grid_velocity, "GridVelocity") - call deallocate(grid_velocity) - - velocity => extract_vector_field(state, "NonlinearVelocity") - call allocate(field, mesh, "Field") - call set_from_function(field, solution, positions) - - call adaptivity_options(state, field, FIELD_ERROR, FIELD_REL, FIELD_MIN) - call insert(state, field, "Field") - - call allocate(metric, mesh, "Metric") - dummy(1) = state - call assemble_metric(dummy, metric) - state = dummy(1) - call adapt_state(state, metric) - - do i=1,NADAPT-1 - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "NonlinearVelocity") - field_ptr => extract_scalar_field(state, "Field") - call set_from_function(field_ptr, solution, positions) - - call adaptivity_options(state, field_ptr, FIELD_ERROR, FIELD_REL, FIELD_MIN) - call adaptivity_bounds(state, 0.001, 0.05) - - call deallocate(metric); call allocate(metric, mesh, "Metric") - dummy(1) = state - call assemble_metric(dummy, metric) - state = dummy(1) - call adapt_state(state, metric) - end do - - call vtk_write_state("data/metric_advection", 0, state=(/state/)) - call set_option("/mesh_adaptivity/hr_adaptivity/metric_advection/iterations", 5) - - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "NonlinearVelocity") - field_ptr => extract_scalar_field(state, "Field") - call set_from_function(field_ptr, solution, positions) - - call adaptivity_options(state, field_ptr, FIELD_ERROR, FIELD_REL, FIELD_MIN) - call adaptivity_bounds(state, 0.001, 0.05) - - call deallocate(metric); call allocate(metric, mesh, "Metric") - dummy(1) = state - call assemble_metric(dummy, metric) - state = dummy(1) - call adapt_state(state, metric) - call vtk_write_state("data/metric_advection", 1, state=(/state/)) + use global_parameters, only: new_options + use metric_assemble + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use state_module + use vtk_interfaces + use vector_tools + use unittest_tools + use edge_length_module + use gradation_metric + use mpi + use interpolation_error + use field_options + implicit none + + type(state_type) :: state, dummy(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions, velocity + type(vector_field) :: velocity_real, grid_velocity + type(scalar_field), pointer :: field_ptr + type(tensor_field) :: metric + type(scalar_field) :: field + integer :: i, stat + + interface + function solution(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface + interface + function velocity_func(pos) + real, dimension(:) :: pos + real, dimension(size(pos)) :: velocity_func + end function + end interface + + call vtk_read_state("data/test_metric_advection/mesh.vtu", state) + call load_options("data/test_metric_advection/settings.flml") + call set_option("/mesh_adaptivity/hr_adaptivity/metric_advection/iterations", 0) + call adaptivity_bounds(state, 0.001, 0.05) + + mesh => extract_mesh(state, "Mesh") + call add_faces(mesh) + positions => extract_vector_field(state, "Coordinate") + + call allocate(velocity_real, 3, mesh, "NonlinearVelocity") + call set_from_function(velocity_real, velocity_func, positions) + call insert(state, velocity_real, "NonlinearVelocity") + call deallocate(velocity_real) + + call allocate(grid_velocity, 3, mesh, "GridVelocity") + call zero(grid_velocity) + call insert(state, grid_velocity, "GridVelocity") + call deallocate(grid_velocity) + + velocity => extract_vector_field(state, "NonlinearVelocity") + call allocate(field, mesh, "Field") + call set_from_function(field, solution, positions) + + call adaptivity_options(state, field, FIELD_ERROR, FIELD_REL, FIELD_MIN) + call insert(state, field, "Field") + + call allocate(metric, mesh, "Metric") + dummy(1) = state + call assemble_metric(dummy, metric) + state = dummy(1) + call adapt_state(state, metric) + + do i=1,NADAPT-1 + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "NonlinearVelocity") + field_ptr => extract_scalar_field(state, "Field") + call set_from_function(field_ptr, solution, positions) + + call adaptivity_options(state, field_ptr, FIELD_ERROR, FIELD_REL, FIELD_MIN) + call adaptivity_bounds(state, 0.001, 0.05) + + call deallocate(metric); call allocate(metric, mesh, "Metric") + dummy(1) = state + call assemble_metric(dummy, metric) + state = dummy(1) + call adapt_state(state, metric) + end do + + call vtk_write_state("data/metric_advection", 0, state=(/state/)) + call set_option("/mesh_adaptivity/hr_adaptivity/metric_advection/iterations", 5) + + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "NonlinearVelocity") + field_ptr => extract_scalar_field(state, "Field") + call set_from_function(field_ptr, solution, positions) + + call adaptivity_options(state, field_ptr, FIELD_ERROR, FIELD_REL, FIELD_MIN) + call adaptivity_bounds(state, 0.001, 0.05) + + call deallocate(metric); call allocate(metric, mesh, "Metric") + dummy(1) = state + call assemble_metric(dummy, metric) + state = dummy(1) + call adapt_state(state, metric) + call vtk_write_state("data/metric_advection", 1, state=(/state/)) end subroutine test_metric_advection function solution(pos) result(val) - real, dimension(:), intent(in) :: pos - real :: val + real, dimension(:), intent(in) :: pos + real :: val - val = tanh(50.0 * (pos(1) - 0.5)) + val = tanh(50.0 * (pos(1) - 0.5)) end function solution function velocity_func(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: velocity_func - - velocity_func = 0.0 - if (pos(1) >= 0.5) then - velocity_func(1) = 0.3 * pos(2)**2 - end if - if (pos(2) == 1.0) then - velocity_func(1) = 0.0 - end if + real, dimension(:) :: pos + real, dimension(size(pos)) :: velocity_func + + velocity_func = 0.0 + if (pos(1) >= 0.5) then + velocity_func(1) = 0.3 * pos(2)**2 + end if + if (pos(2) == 1.0) then + velocity_func(1) = 0.0 + end if end function velocity_func diff --git a/error_measures/tests/test_metric_isotropic.F90 b/error_measures/tests/test_metric_isotropic.F90 index ded100c0a5..8eda2650a3 100644 --- a/error_measures/tests/test_metric_isotropic.F90 +++ b/error_measures/tests/test_metric_isotropic.F90 @@ -1,32 +1,32 @@ subroutine test_metric_isotropic - use metric_tools - use unittest_tools - use vector_tools - implicit none + use metric_tools + use unittest_tools + use vector_tools + implicit none - real, dimension(3, 3) :: mat, vecs - real, dimension(3) :: vals, isotropic_vals, anisotropic_vals - logical :: fail + real, dimension(3, 3) :: mat, vecs + real, dimension(3) :: vals, isotropic_vals, anisotropic_vals + logical :: fail - mat = random_posdef_matrix(3) - call eigendecomposition_symmetric(mat, vecs, vals) + mat = random_posdef_matrix(3) + call eigendecomposition_symmetric(mat, vecs, vals) - isotropic_vals = 1.0 - call eigenrecomposition(mat, vecs, isotropic_vals) + isotropic_vals = 1.0 + call eigenrecomposition(mat, vecs, isotropic_vals) - fail = .false. - if (.not. metric_isotropic(mat)) fail = .true. - call report_test("[isotropic metric]", fail, .false., "isotropic_metric should & - & report true for an isotropic metric.") + fail = .false. + if (.not. metric_isotropic(mat)) fail = .true. + call report_test("[isotropic metric]", fail, .false., "isotropic_metric should & + & report true for an isotropic metric.") - anisotropic_vals(1) = 1.0 - anisotropic_vals(2) = 2.0 - anisotropic_vals(3) = 3.0 - call eigenrecomposition(mat, vecs, anisotropic_vals) + anisotropic_vals(1) = 1.0 + anisotropic_vals(2) = 2.0 + anisotropic_vals(3) = 3.0 + call eigenrecomposition(mat, vecs, anisotropic_vals) - fail = .false. - if (metric_isotropic(mat)) fail = .true. - call report_test("[anisotropic metric]", fail, .false., "isotropic_metric should & - & report false for an anisotropic metric.") + fail = .false. + if (metric_isotropic(mat)) fail = .true. + call report_test("[anisotropic metric]", fail, .false., "isotropic_metric should & + & report false for an anisotropic metric.") end subroutine test_metric_isotropic diff --git a/error_measures/tests/test_metric_spheroid.F90 b/error_measures/tests/test_metric_spheroid.F90 index 433a99b767..47e6b50f3a 100644 --- a/error_measures/tests/test_metric_spheroid.F90 +++ b/error_measures/tests/test_metric_spheroid.F90 @@ -1,72 +1,72 @@ subroutine test_metric_spheroid - use metric_tools - use unittest_tools - use vector_tools - implicit none + use metric_tools + use unittest_tools + use vector_tools + implicit none - real, dimension(3, 3) :: mat, vecs - real, dimension(3) :: vals, spheroid_vals, nonspheroid_vals - integer :: idx - logical :: fail + real, dimension(3, 3) :: mat, vecs + real, dimension(3) :: vals, spheroid_vals, nonspheroid_vals + integer :: idx + logical :: fail - mat = random_posdef_matrix(3) - call eigendecomposition_symmetric(mat, vecs, vals) + mat = random_posdef_matrix(3) + call eigendecomposition_symmetric(mat, vecs, vals) - spheroid_vals = 1.0; spheroid_vals(1) = 0.5 - call eigenrecomposition(mat, vecs, spheroid_vals) + spheroid_vals = 1.0; spheroid_vals(1) = 0.5 + call eigenrecomposition(mat, vecs, spheroid_vals) - fail = .false. - if (metric_spheroid(mat)) fail = .true. - call report_test("[spheroid metric]", fail, .false., "spheroid_metric should & + fail = .false. + if (metric_spheroid(mat)) fail = .true. + call report_test("[spheroid metric]", fail, .false., "spheroid_metric should & & report false for a flattened spheroid metric.") - fail = .false. - idx = get_spheroid_index(mat, vecs, spheroid_vals) - if (idx == 1) fail = .true. - call report_test("[spheroid index]", fail, .false., "get_spheroid_index should & + fail = .false. + idx = get_spheroid_index(mat, vecs, spheroid_vals) + if (idx == 1) fail = .true. + call report_test("[spheroid index]", fail, .false., "get_spheroid_index should & & not return 1.") - fail = .false. - idx = get_polar_index(spheroid_vals) - if (idx /= 1) fail = .true. - call report_test("[polar index]", fail, .false., "get_polar_index should & + fail = .false. + idx = get_polar_index(spheroid_vals) + if (idx /= 1) fail = .true. + call report_test("[polar index]", fail, .false., "get_polar_index should & & not return 1.") - ! ---------- + ! ---------- - mat = random_posdef_matrix(3) - call eigendecomposition_symmetric(mat, vecs, vals) + mat = random_posdef_matrix(3) + call eigendecomposition_symmetric(mat, vecs, vals) - spheroid_vals = 1.0; spheroid_vals(1) = 1.5 - call eigenrecomposition(mat, vecs, spheroid_vals) + spheroid_vals = 1.0; spheroid_vals(1) = 1.5 + call eigenrecomposition(mat, vecs, spheroid_vals) - fail = .false. - if (.not. metric_spheroid(spheroid_vals)) fail = .true. - call report_test("[spheroid metric]", fail, .false., "spheroid_metric should & + fail = .false. + if (.not. metric_spheroid(spheroid_vals)) fail = .true. + call report_test("[spheroid metric]", fail, .false., "spheroid_metric should & & report true for a spheroid metric.") - fail = .false. - idx = get_spheroid_index(mat, vecs, spheroid_vals) - if (idx == 1) fail = .true. - call report_test("[spheroid index]", fail, .false., "get_spheroid_index should & + fail = .false. + idx = get_spheroid_index(mat, vecs, spheroid_vals) + if (idx == 1) fail = .true. + call report_test("[spheroid index]", fail, .false., "get_spheroid_index should & & not return 1.") - fail = .false. - idx = get_polar_index(spheroid_vals) - if (idx /= 1) fail = .true. - call report_test("[polar index]", fail, .false., "get_polar_index should & + fail = .false. + idx = get_polar_index(spheroid_vals) + if (idx /= 1) fail = .true. + call report_test("[polar index]", fail, .false., "get_polar_index should & & not return 1.") - ! ----------- + ! ----------- - nonspheroid_vals(1) = 1.0 - nonspheroid_vals(2) = 2.0 - nonspheroid_vals(3) = 3.0 - call eigenrecomposition(mat, vecs, nonspheroid_vals) + nonspheroid_vals(1) = 1.0 + nonspheroid_vals(2) = 2.0 + nonspheroid_vals(3) = 3.0 + call eigenrecomposition(mat, vecs, nonspheroid_vals) - fail = .false. - if (metric_spheroid(mat)) fail = .true. - call report_test("[nonspheroid metric]", fail, .false., "spheroid_metric should & + fail = .false. + if (metric_spheroid(mat)) fail = .true. + call report_test("[nonspheroid metric]", fail, .false., "spheroid_metric should & & report false for a nonspheroid metric.") end subroutine test_metric_spheroid diff --git a/error_measures/tests/test_project_metric_to_surface.F90 b/error_measures/tests/test_project_metric_to_surface.F90 index a2d276823a..115a4ca583 100644 --- a/error_measures/tests/test_project_metric_to_surface.F90 +++ b/error_measures/tests/test_project_metric_to_surface.F90 @@ -1,47 +1,47 @@ subroutine test_project_metric_to_surface - use hadapt_extrude - use hadapt_advancing_front - use hadapt_metric_based_extrude - use fields - use spud - use unittest_tools - use vtk_interfaces - use sparse_tools - use project_metric_to_surface_module - implicit none - - type(vector_field) :: h_mesh - integer :: stat - logical :: fail - - type(vector_field) :: out_mesh - type(tensor_field) :: volume_metric, surface_metric - real :: top_depth - integer :: node - real, dimension(1, 1) :: value - - call set_option("/geometry/quadrature/degree", 4, stat=stat) - call set_option("/geometry/mesh::CoordinateMesh/from_mesh/extrude/regions[0]/bottom_depth/constant", 1.0, stat=stat) - call set_option("/geometry/mesh::CoordinateMesh/from_mesh/extrude/regions[0]/sizing_function/constant", 0.5, stat=stat) - - top_depth = 0.0 - call compute_z_nodes(h_mesh, 1.0, (/0.0, 0.0/), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=0.5) - call set(h_mesh, node_count(h_mesh), (/1.0/)) - call add_nelist(h_mesh%mesh) - - call extrude(h_mesh, "/geometry/mesh", out_mesh) - - call allocate(volume_metric, out_mesh%mesh, "VolumeMetric") - do node=1,node_count(volume_metric) - call set(volume_metric, node, reshape( (/2.0, 0.0, 0.0, 1.0 /), (/2, 2/))) - end do - - call project_metric_to_surface(volume_metric, h_mesh, surface_metric) - fail = .false. - do node=1,node_count(surface_metric) - value = node_val(surface_metric, node) - fail = fail .or. (value(1, 1) .fne. 2.0) - end do - call report_test("[project_metric_to_surface]", fail, .false., "should be 2.0 everywhere") + use hadapt_extrude + use hadapt_advancing_front + use hadapt_metric_based_extrude + use fields + use spud + use unittest_tools + use vtk_interfaces + use sparse_tools + use project_metric_to_surface_module + implicit none + + type(vector_field) :: h_mesh + integer :: stat + logical :: fail + + type(vector_field) :: out_mesh + type(tensor_field) :: volume_metric, surface_metric + real :: top_depth + integer :: node + real, dimension(1, 1) :: value + + call set_option("/geometry/quadrature/degree", 4, stat=stat) + call set_option("/geometry/mesh::CoordinateMesh/from_mesh/extrude/regions[0]/bottom_depth/constant", 1.0, stat=stat) + call set_option("/geometry/mesh::CoordinateMesh/from_mesh/extrude/regions[0]/sizing_function/constant", 0.5, stat=stat) + + top_depth = 0.0 + call compute_z_nodes(h_mesh, 1.0, (/0.0, 0.0/), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=0.5) + call set(h_mesh, node_count(h_mesh), (/1.0/)) + call add_nelist(h_mesh%mesh) + + call extrude(h_mesh, "/geometry/mesh", out_mesh) + + call allocate(volume_metric, out_mesh%mesh, "VolumeMetric") + do node=1,node_count(volume_metric) + call set(volume_metric, node, reshape( (/2.0, 0.0, 0.0, 1.0 /), (/2, 2/))) + end do + + call project_metric_to_surface(volume_metric, h_mesh, surface_metric) + fail = .false. + do node=1,node_count(surface_metric) + value = node_val(surface_metric, node) + fail = fail .or. (value(1, 1) .fne. 2.0) + end do + call report_test("[project_metric_to_surface]", fail, .false., "should be 2.0 everywhere") end subroutine test_project_metric_to_surface diff --git a/error_measures/tests/test_project_to_subspace.F90 b/error_measures/tests/test_project_to_subspace.F90 index 258524f500..d88e465f08 100644 --- a/error_measures/tests/test_project_to_subspace.F90 +++ b/error_measures/tests/test_project_to_subspace.F90 @@ -1,64 +1,64 @@ subroutine test_project_to_subspace - use metric_tools - use unittest_tools - implicit none + use metric_tools + use unittest_tools + implicit none - real, dimension(3) :: a, b, c, d, e - real, dimension(3, 2) :: basis - logical :: fail - integer :: i - character(len=20) :: buf + real, dimension(3) :: a, b, c, d, e + real, dimension(3, 2) :: basis + logical :: fail + integer :: i + character(len=20) :: buf - a = (/1.0, 1.0, 1.0/) ! the vector to project - b = (/1.0, 0.0, 0.0/) ! basis vectors - c = (/0.0, 1.0, 0.0/) - e = (/1.0, 1.0, 0.0/) ! the correct answer + a = (/1.0, 1.0, 1.0/) ! the vector to project + b = (/1.0, 0.0, 0.0/) ! basis vectors + c = (/0.0, 1.0, 0.0/) + e = (/1.0, 1.0, 0.0/) ! the correct answer - basis(:, 1) = b; basis(:, 2) = c + basis(:, 1) = b; basis(:, 2) = c - d = project_to_subspace(a, basis) + d = project_to_subspace(a, basis) - fail = .false. - if (d .fne. e) fail = .true. - call report_test("[project to subspace known values]", fail, .false., "Projecting & - & should give known good values.") + fail = .false. + if (d .fne. e) fail = .true. + call report_test("[project to subspace known values]", fail, .false., "Projecting & + & should give known good values.") - a = (/0.0, 0.0, 1.0/) ! a is orthogonal to basis - e = (/0.0, 0.0, 0.0/) + a = (/0.0, 0.0, 1.0/) ! a is orthogonal to basis + e = (/0.0, 0.0, 0.0/) - d = project_to_subspace(a, basis) + d = project_to_subspace(a, basis) - fail = .false. - if (d .fne. e) fail = .true. - call report_test("[project to subspace known values]", fail, .false., "Projecting & - & should give known good values.") + fail = .false. + if (d .fne. e) fail = .true. + call report_test("[project to subspace known values]", fail, .false., "Projecting & + & should give known good values.") - a = (/1.0, 1.0, 0.0/) ! this is now in the subspace - e = (/1.0, 1.0, 0.0/) + a = (/1.0, 1.0, 0.0/) ! this is now in the subspace + e = (/1.0, 1.0, 0.0/) - d = project_to_subspace(a, basis) + d = project_to_subspace(a, basis) - fail = .false. - if (d .fne. e) fail = .true. - call report_test("[project to subspace known values]", fail, .false., "Projecting & - & should give known good values.") + fail = .false. + if (d .fne. e) fail = .true. + call report_test("[project to subspace known values]", fail, .false., "Projecting & + & should give known good values.") - do i=1,5 - write(buf, '(i0)') i + do i=1,5 + write(buf, '(i0)') i - a = random_vector(3) - b = random_vector(3) ; b = b / norm(b) - c = random_vector(3) - c = c - dot_product(c, b) * b ; c = c / norm(c) - basis(:, 1) = b; basis(:, 2) = c + a = random_vector(3) + b = random_vector(3) ; b = b / norm(b) + c = random_vector(3) + c = c - dot_product(c, b) * b ; c = c / norm(c) + basis(:, 1) = b; basis(:, 2) = c - d = project_to_subspace(a, basis) - e = project_to_subspace(d, basis) + d = project_to_subspace(a, basis) + e = project_to_subspace(d, basis) - fail = .false. - if (d .fne. e) fail = .true. - call report_test("[project to subspace idempotent " // trim(buf) // "]", fail, .false., & - "Projecting to a subspace is an idempotent linear operation.") - end do + fail = .false. + if (d .fne. e) fail = .true. + call report_test("[project to subspace idempotent " // trim(buf) // "]", fail, .false., & + "Projecting to a subspace is an idempotent linear operation.") + end do end subroutine test_project_to_subspace diff --git a/error_measures/tests/test_pseudo2d_gradation.F90 b/error_measures/tests/test_pseudo2d_gradation.F90 index 463a92ee16..ff41b791b3 100644 --- a/error_measures/tests/test_pseudo2d_gradation.F90 +++ b/error_measures/tests/test_pseudo2d_gradation.F90 @@ -1,90 +1,90 @@ subroutine test_pseudo2d_gradation - use vtk_interfaces - use field_derivatives - use unittest_tools - use state_module - use global_parameters, only: pseudo2d_coord - use gradation_metric - use form_metric_field - use metric_tools - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field) :: pressure_field, node_field - type(tensor_field) :: hessian - integer :: i, j - logical :: fail - real :: x, y, z, angle - real, dimension(3, 3) :: evecs - real, dimension(3) :: evals, domvec - - pseudo2d_coord = 3 - - call vtk_read_state("data/squat_cube_front.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(pressure_field, mesh, "Pressure") - call allocate(node_field, mesh, "Node numbering") - call allocate(hessian, mesh, "Hessian") - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - pressure_field%val(i) = x * x - end do - - call get_node_field(mesh, node_field) - - call compute_hessian(pressure_field, positions, hessian) - call vtk_write_fields("data/pseudo2d_gradation", 0, positions, mesh, sfields=(/pressure_field, node_field/), tfields=(/hessian/)) - - ! At this point the tensors are slightly misaligned due to numerical errors - ! in computing the hessian. We want out gradation algorithm to fix that. - - do i=1,mesh%nodes - call eigendecomposition_symmetric(hessian%val(:, :, i), evecs, evals) - do j=1,3 - if (evals(j) == 0.0) evals(j) = minval(evals, mask=(evals /= 0.0)) - end do - call eigenrecomposition(hessian%val(:, :, i), evecs, evals) - end do - - call vtk_write_fields("data/pseudo2d_gradation", 1, positions, mesh, sfields=(/pressure_field, node_field/), tfields=(/hessian/)) - - gamma0 = huge(0.0) ! don't change eigenvalues, only eigenvectors - call form_gradation_metric(positions, hessian) - - call vtk_write_fields("data/pseudo2d_gradation", 2, positions, mesh, sfields=(/pressure_field, node_field/), tfields=(/hessian/)) - - fail = .false. - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - - if (x == minval(positions%val(1,:)) .or. x == maxval(positions%val(1,:))) cycle - if (y == minval(positions%val(2,:)) .or. y == maxval(positions%val(2,:))) cycle - - call eigendecomposition_symmetric(hessian%val(:, :, i), evecs, evals) - domvec = dominant_eigenvector(evecs, evals) - angle = get_angle(domvec, (/1.0, 0.0, 0.0/)) - if (angle > 0.17453292519943295) then ! 20 degrees - write(0,*) "i == ", i - call write_vector(domvec, "Dominant eigenvector") - call write_vector(node_val(positions, i), "Position") - write(0,*) "Angle with x axis:", angle - fail = .true. - end if - end do - - call report_test("[gradation of a hessian]", fail, .false., "Pass!") - - call deallocate(hessian) - call deallocate(pressure_field) - call deallocate(state) + use vtk_interfaces + use field_derivatives + use unittest_tools + use state_module + use global_parameters, only: pseudo2d_coord + use gradation_metric + use form_metric_field + use metric_tools + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field) :: pressure_field, node_field + type(tensor_field) :: hessian + integer :: i, j + logical :: fail + real :: x, y, z, angle + real, dimension(3, 3) :: evecs + real, dimension(3) :: evals, domvec + + pseudo2d_coord = 3 + + call vtk_read_state("data/squat_cube_front.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(pressure_field, mesh, "Pressure") + call allocate(node_field, mesh, "Node numbering") + call allocate(hessian, mesh, "Hessian") + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + pressure_field%val(i) = x * x + end do + + call get_node_field(mesh, node_field) + + call compute_hessian(pressure_field, positions, hessian) + call vtk_write_fields("data/pseudo2d_gradation", 0, positions, mesh, sfields=(/pressure_field, node_field/), tfields=(/hessian/)) + + ! At this point the tensors are slightly misaligned due to numerical errors + ! in computing the hessian. We want out gradation algorithm to fix that. + + do i=1,mesh%nodes + call eigendecomposition_symmetric(hessian%val(:, :, i), evecs, evals) + do j=1,3 + if (evals(j) == 0.0) evals(j) = minval(evals, mask=(evals /= 0.0)) + end do + call eigenrecomposition(hessian%val(:, :, i), evecs, evals) + end do + + call vtk_write_fields("data/pseudo2d_gradation", 1, positions, mesh, sfields=(/pressure_field, node_field/), tfields=(/hessian/)) + + gamma0 = huge(0.0) ! don't change eigenvalues, only eigenvectors + call form_gradation_metric(positions, hessian) + + call vtk_write_fields("data/pseudo2d_gradation", 2, positions, mesh, sfields=(/pressure_field, node_field/), tfields=(/hessian/)) + + fail = .false. + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + + if (x == minval(positions%val(1,:)) .or. x == maxval(positions%val(1,:))) cycle + if (y == minval(positions%val(2,:)) .or. y == maxval(positions%val(2,:))) cycle + + call eigendecomposition_symmetric(hessian%val(:, :, i), evecs, evals) + domvec = dominant_eigenvector(evecs, evals) + angle = get_angle(domvec, (/1.0, 0.0, 0.0/)) + if (angle > 0.17453292519943295) then ! 20 degrees + write(0,*) "i == ", i + call write_vector(domvec, "Dominant eigenvector") + call write_vector(node_val(positions, i), "Position") + write(0,*) "Angle with x axis:", angle + fail = .true. + end if + end do + + call report_test("[gradation of a hessian]", fail, .false., "Pass!") + + call deallocate(hessian) + call deallocate(pressure_field) + call deallocate(state) end subroutine test_pseudo2d_gradation diff --git a/error_measures/tests/test_pseudo_supermesh.F90 b/error_measures/tests/test_pseudo_supermesh.F90 index 7f37a09b2d..fa486d7938 100644 --- a/error_measures/tests/test_pseudo_supermesh.F90 +++ b/error_measures/tests/test_pseudo_supermesh.F90 @@ -1,48 +1,48 @@ subroutine test_pseudo_supermesh - use fields - use unittest_tools - use pseudo_supermesh - use state_module - use vtk_interfaces - use reference_counting - implicit none - - type(vector_field), target :: X_init, X_supermesh - type(state_type) :: vtk_state - logical :: fail - integer :: no_refs - character(len=255), dimension(2) :: strings - - strings(1) = "data/pseudo_supermesh_0.vtu" - strings(2) = "data/pseudo_supermesh_1.vtu" - - call vtk_read_state(strings(1), vtk_state) - X_init = extract_vector_field(vtk_state, "Coordinate") - - call add_faces(X_init%mesh) - ! add_faces() replaces mesh%shape, so we need to swap out the mesh already - ! stored in state in order not to mess up the refcounts - call insert(vtk_state, X_init%mesh, X_init%mesh%name) - - call compute_pseudo_supermesh(strings, & - & X_init, X_supermesh) - - call vtk_write_fields("data/pseudo_supermesh", 2, X_supermesh, X_supermesh%mesh) - - fail = (X_supermesh%refcount%count /= 1) - call report_test("[supermesh refcount]", fail, .false., "") - - fail = (X_init%refcount%count /= 1) - call report_test("[initial mesh refcount]", fail, .false., "") - - call deallocate(vtk_state) - call deallocate(X_supermesh) - - ! ensure all references have been dropped now - no_refs = count_references() - fail = (no_refs /= 0) - call report_test("[zero final refcount]", fail, .false., "") - call print_references(-1) ! this should output nothing if the test passed + use fields + use unittest_tools + use pseudo_supermesh + use state_module + use vtk_interfaces + use reference_counting + implicit none + + type(vector_field), target :: X_init, X_supermesh + type(state_type) :: vtk_state + logical :: fail + integer :: no_refs + character(len=255), dimension(2) :: strings + + strings(1) = "data/pseudo_supermesh_0.vtu" + strings(2) = "data/pseudo_supermesh_1.vtu" + + call vtk_read_state(strings(1), vtk_state) + X_init = extract_vector_field(vtk_state, "Coordinate") + + call add_faces(X_init%mesh) + ! add_faces() replaces mesh%shape, so we need to swap out the mesh already + ! stored in state in order not to mess up the refcounts + call insert(vtk_state, X_init%mesh, X_init%mesh%name) + + call compute_pseudo_supermesh(strings, & + & X_init, X_supermesh) + + call vtk_write_fields("data/pseudo_supermesh", 2, X_supermesh, X_supermesh%mesh) + + fail = (X_supermesh%refcount%count /= 1) + call report_test("[supermesh refcount]", fail, .false., "") + + fail = (X_init%refcount%count /= 1) + call report_test("[initial mesh refcount]", fail, .false., "") + + call deallocate(vtk_state) + call deallocate(X_supermesh) + + ! ensure all references have been dropped now + no_refs = count_references() + fail = (no_refs /= 0) + call report_test("[zero final refcount]", fail, .false., "") + call print_references(-1) ! this should output nothing if the test passed end subroutine test_pseudo_supermesh diff --git a/error_measures/tests/test_quadratic_interpolation.F90 b/error_measures/tests/test_quadratic_interpolation.F90 index c1652887d2..91710f0297 100644 --- a/error_measures/tests/test_quadratic_interpolation.F90 +++ b/error_measures/tests/test_quadratic_interpolation.F90 @@ -1,72 +1,72 @@ subroutine test_quadratic_interpolation - use fields - use state_module - use interpolation_module - use vtk_interfaces - use unittest_tools - implicit none + use fields + use state_module + use interpolation_module + use vtk_interfaces + use unittest_tools + implicit none - type(state_type) :: state_3, state_5 - type(mesh_type), pointer :: old_mesh, new_mesh - type(vector_field), pointer :: old_position, new_position - type(scalar_field), dimension(3) :: old_fields, new_fields - integer :: node, i - real :: x, y, z - real, dimension(3) :: pos - logical :: fail - character(len=20) :: buf + type(state_type) :: state_3, state_5 + type(mesh_type), pointer :: old_mesh, new_mesh + type(vector_field), pointer :: old_position, new_position + type(scalar_field), dimension(3) :: old_fields, new_fields + integer :: node, i + real :: x, y, z + real, dimension(3) :: pos + logical :: fail + character(len=20) :: buf - call vtk_read_state("data/cube-itv3.vtu", state_3) - call vtk_read_state("data/cube-itv5.vtu", state_5) + call vtk_read_state("data/cube-itv3.vtu", state_3) + call vtk_read_state("data/cube-itv5.vtu", state_5) - old_mesh => extract_mesh(state_3, "Mesh") - new_mesh => extract_mesh(state_5, "Mesh") - old_position => extract_vector_field(state_3, "Coordinate") - new_position => extract_vector_field(state_5, "Coordinate") + old_mesh => extract_mesh(state_3, "Mesh") + new_mesh => extract_mesh(state_5, "Mesh") + old_position => extract_vector_field(state_3, "Coordinate") + new_position => extract_vector_field(state_5, "Coordinate") - do i=1,3 - write(buf, '(i0)') i - call allocate(old_fields(i), old_mesh, "Temperature" // trim(buf)) - call allocate(new_fields(i), new_mesh, "Temperature" // trim(buf)) - end do + do i=1,3 + write(buf, '(i0)') i + call allocate(old_fields(i), old_mesh, "Temperature" // trim(buf)) + call allocate(new_fields(i), new_mesh, "Temperature" // trim(buf)) + end do - do node=1,node_count(old_mesh) - pos = node_val(old_position, node) - x = pos(1) ; y = pos(2) ; z = pos(3) - old_fields(1)%val(node) = x**2 - old_fields(2)%val(node) = y**2 - old_fields(3)%val(node) = x**2 + y**2 - end do + do node=1,node_count(old_mesh) + pos = node_val(old_position, node) + x = pos(1) ; y = pos(2) ; z = pos(3) + old_fields(1)%val(node) = x**2 + old_fields(2)%val(node) = y**2 + old_fields(3)%val(node) = x**2 + y**2 + end do - call quadratic_interpolation(old_fields, old_position, new_fields, new_position) + call quadratic_interpolation(old_fields, old_position, new_fields, new_position) - call vtk_write_fields("data/quadratic_interpolation", 0, old_position, old_mesh, sfields=old_fields, vfields=(/old_position/)) - call vtk_write_fields("data/quadratic_interpolation", 1, new_position, new_mesh, sfields=new_fields, vfields=(/new_position/)) + call vtk_write_fields("data/quadratic_interpolation", 0, old_position, old_mesh, sfields=old_fields, vfields=(/old_position/)) + call vtk_write_fields("data/quadratic_interpolation", 1, new_position, new_mesh, sfields=new_fields, vfields=(/new_position/)) - fail = .false. - do node=1,node_count(new_mesh) - pos = node_val(new_position, node) - x = pos(1) ; y = pos(2) ; z = pos(3) - if (.not. fequals(node_val(new_fields(1), node), x**2, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(1), node) == ", node_val(new_fields(1), node) - write(0,*) "x**2 == ", x**2 - fail = .true. - end if - if (.not. fequals(node_val(new_fields(2), node), y**2, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(2), node) == ", node_val(new_fields(2), node) - write(0,*) "y**2 == ", y**2 - fail = .true. - end if - if (.not. fequals(node_val(new_fields(3), node), x**2 + y**2, 0.01)) then - write(0,*) "node == ", node - write(0,*) "node_val(new_fields(3), node) == ", node_val(new_fields(3), node) - write(0,*) "x**2 + y**2 == ", x**2 + y**2 - fail = .true. - end if - end do - call report_test("[quadratic interpolation]", fail, .false., "All nodal values should be exact.") + fail = .false. + do node=1,node_count(new_mesh) + pos = node_val(new_position, node) + x = pos(1) ; y = pos(2) ; z = pos(3) + if (.not. fequals(node_val(new_fields(1), node), x**2, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(1), node) == ", node_val(new_fields(1), node) + write(0,*) "x**2 == ", x**2 + fail = .true. + end if + if (.not. fequals(node_val(new_fields(2), node), y**2, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(2), node) == ", node_val(new_fields(2), node) + write(0,*) "y**2 == ", y**2 + fail = .true. + end if + if (.not. fequals(node_val(new_fields(3), node), x**2 + y**2, 0.01)) then + write(0,*) "node == ", node + write(0,*) "node_val(new_fields(3), node) == ", node_val(new_fields(3), node) + write(0,*) "x**2 + y**2 == ", x**2 + y**2 + fail = .true. + end if + end do + call report_test("[quadratic interpolation]", fail, .false., "All nodal values should be exact.") end subroutine test_quadratic_interpolation diff --git a/error_measures/tests/test_recovery_estimator.F90 b/error_measures/tests/test_recovery_estimator.F90 index 9894f41df3..76836e8a92 100644 --- a/error_measures/tests/test_recovery_estimator.F90 +++ b/error_measures/tests/test_recovery_estimator.F90 @@ -1,43 +1,43 @@ subroutine test_recovery_estimator - use global_parameters, only: current_debug_level, pseudo2d_coord - use vtk_interfaces - use fields - use sparsity_patterns - use state_module - use unittest_tools - use recovery_estimator - use transform_elements - use field_derivatives - implicit none - - type(state_type) :: state - type(scalar_field) :: elementwise - type(vector_field), pointer :: positions - type(mesh_type), pointer :: mesh - type(scalar_field) :: field - integer :: i - real :: x, y, z - - call vtk_read_state("data/1x1square.vtu", state) - positions => extract_vector_field(state, "Coordinate") - mesh => extract_mesh(state, "Mesh") - call allocate(field, mesh, "Field") - elementwise = piecewise_constant_field(state%meshes(1), "Recovery error estimator") - - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) - field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) - end do - field%val = field%val + 4.0 - - call form_recovery_estimator(field, positions, elementwise) - - call vtk_write_fields("data/recovery_estimator", 0, positions, mesh, sfields=(/elementwise/)) - - call report_test("[recovery estimator]", .false., .false., "If it doesn't crash you're on to a winner") - - call deallocate(state) + use global_parameters, only: current_debug_level, pseudo2d_coord + use vtk_interfaces + use fields + use sparsity_patterns + use state_module + use unittest_tools + use recovery_estimator + use transform_elements + use field_derivatives + implicit none + + type(state_type) :: state + type(scalar_field) :: elementwise + type(vector_field), pointer :: positions + type(mesh_type), pointer :: mesh + type(scalar_field) :: field + integer :: i + real :: x, y, z + + call vtk_read_state("data/1x1square.vtu", state) + positions => extract_vector_field(state, "Coordinate") + mesh => extract_mesh(state, "Mesh") + call allocate(field, mesh, "Field") + elementwise = piecewise_constant_field(state%meshes(1), "Recovery error estimator") + + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) + field%val(i) = y * x**2 + y**3 + tanh(10.0 * (sin(5.0*y) - 2.0*x)) + end do + field%val = field%val + 4.0 + + call form_recovery_estimator(field, positions, elementwise) + + call vtk_write_fields("data/recovery_estimator", 0, positions, mesh, sfields=(/elementwise/)) + + call report_test("[recovery estimator]", .false., .false., "If it doesn't crash you're on to a winner") + + call deallocate(state) end subroutine test_recovery_estimator diff --git a/error_measures/tests/test_rotate_vec.F90 b/error_measures/tests/test_rotate_vec.F90 index 8cc5bd810a..a71f80181a 100644 --- a/error_measures/tests/test_rotate_vec.F90 +++ b/error_measures/tests/test_rotate_vec.F90 @@ -1,43 +1,43 @@ subroutine test_rotate_vec - use gradation_metric - use metric_tools, only: get_angle - use unittest_tools - implicit none + use gradation_metric + use metric_tools, only: get_angle + use unittest_tools + implicit none - real, dimension(3, 3) :: vec_P, vec_Q - integer, dimension(3) :: perm_P, perm_Q - integer :: idx - real :: angle - real :: in_angle, out_angle - logical :: fail + real, dimension(3, 3) :: vec_P, vec_Q + integer, dimension(3) :: perm_P, perm_Q + integer :: idx + real :: angle + real :: in_angle, out_angle + logical :: fail - vec_P(1, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) - vec_P(2, :) = (/0.00000000000000000000E+00, 0.00000000000000000000E+00, 0.10000000000000000000E+01/) - vec_P(3, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) + vec_P(1, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) + vec_P(2, :) = (/0.00000000000000000000E+00, 0.00000000000000000000E+00, 0.10000000000000000000E+01/) + vec_P(3, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) - vec_Q(1, :) = (/0.00000000000000000000E+00, 0.55115565036679803335E+00, -0.83440245030126314330E+00/) - vec_Q(2, :) = (/0.00000000000000000000E+00, -0.83440245030126314330E+00, -0.55115565036679803335E+00/) - vec_Q(3, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) + vec_Q(1, :) = (/0.00000000000000000000E+00, 0.55115565036679803335E+00, -0.83440245030126314330E+00/) + vec_Q(2, :) = (/0.00000000000000000000E+00, -0.83440245030126314330E+00, -0.55115565036679803335E+00/) + vec_Q(3, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) - perm_P = (/3, 2, 1/) - perm_Q = (/3, 1, 2/) + perm_P = (/3, 2, 1/) + perm_Q = (/3, 1, 2/) - idx = 1 - angle = 0.351727550700944 + idx = 1 + angle = 0.351727550700944 - in_angle = get_angle(vec_P(:, 3), vec_Q(:, 3)) + in_angle = get_angle(vec_P(:, 3), vec_Q(:, 3)) - call rotate_vec(vec_Q, perm_Q, vec_P, perm_P, idx, -1 * angle) + call rotate_vec(vec_Q, perm_Q, vec_P, perm_P, idx, -1 * angle) - out_angle = get_angle(vec_P(:, 3), vec_Q(:, 3)) + out_angle = get_angle(vec_P(:, 3), vec_Q(:, 3)) - fail = .false. - if (out_angle .fgt. in_angle) then - fail = .true. - write(0,*) "in_angle == ", in_angle - write(0,*) "out_angle == ", out_angle - end if - call report_test("[rotate vec]", fail, .false., "Rotating vectors is supposed to bring them closer together!") + fail = .false. + if (out_angle .fgt. in_angle) then + fail = .true. + write(0,*) "in_angle == ", in_angle + write(0,*) "out_angle == ", out_angle + end if + call report_test("[rotate vec]", fail, .false., "Rotating vectors is supposed to bring them closer together!") end subroutine test_rotate_vec diff --git a/error_measures/tests/test_simplex_tensor.F90 b/error_measures/tests/test_simplex_tensor.F90 index 8e7f2b7ae3..5440f7e126 100644 --- a/error_measures/tests/test_simplex_tensor.F90 +++ b/error_measures/tests/test_simplex_tensor.F90 @@ -1,30 +1,30 @@ subroutine test_simplex_tensor - use fields - use mesh_files - use unittest_tools - use conformity_measurement - use metric_tools - implicit none + use fields + use mesh_files + use unittest_tools + use conformity_measurement + use metric_tools + implicit none - type(vector_field) :: X_1, X_2 - real, dimension(1, 1) :: m_1 - real, dimension(2, 2) :: m_2, c_2 - logical :: fail - X_1=read_mesh_files("data/interval-0.0-1.0-1.0", quad_degree=4, format="gmsh") + type(vector_field) :: X_1, X_2 + real, dimension(1, 1) :: m_1 + real, dimension(2, 2) :: m_2, c_2 + logical :: fail + X_1=read_mesh_files("data/interval-0.0-1.0-1.0", quad_degree=4, format="gmsh") - m_1 = simplex_tensor(X_1, 1) + m_1 = simplex_tensor(X_1, 1) - fail = (m_1(1, 1) /= 1.0) - call report_test("[test_simplex_tensor]", fail, .false., "") + fail = (m_1(1, 1) /= 1.0) + call report_test("[test_simplex_tensor]", fail, .false., "") - call deallocate(X_1) - X_2=read_mesh_files("data/triangle.1", quad_degree=4, format="gmsh") + call deallocate(X_1) + X_2=read_mesh_files("data/triangle.1", quad_degree=4, format="gmsh") - m_2 = simplex_tensor(X_2, 1) - c_2(1,:) = (/0.75, 0.0/) - c_2(2,:) = (/0.0, 1.0/) + m_2 = simplex_tensor(X_2, 1) + c_2(1,:) = (/0.75, 0.0/) + c_2(2,:) = (/0.0, 1.0/) - fail = (m_2 .fne. c_2) - call report_test("[test_simplex_tensor]", fail, .false., "") + fail = (m_2 .fne. c_2) + call report_test("[test_simplex_tensor]", fail, .false., "") end subroutine test_simplex_tensor diff --git a/error_measures/tests/test_simplex_tensor_edgelens.F90 b/error_measures/tests/test_simplex_tensor_edgelens.F90 index 243baad89e..06fa44000d 100644 --- a/error_measures/tests/test_simplex_tensor_edgelens.F90 +++ b/error_measures/tests/test_simplex_tensor_edgelens.F90 @@ -1,26 +1,26 @@ subroutine test_simplex_tensor_edgelens - use fields - use mesh_files - use transform_elements - use meshdiagnostics - use conformity_measurement - use vector_tools - use unittest_tools - use metric_tools - implicit none - - integer :: ele - type(vector_field) :: positions - - positions = read_mesh_files("data/laplacian_grid.3", quad_degree=4, format="gmsh") - - do ele=1,ele_count(positions) - call transform_ele(positions, ele) - end do - - contains - subroutine transform_ele(positions, ele) + use fields + use mesh_files + use transform_elements + use meshdiagnostics + use conformity_measurement + use vector_tools + use unittest_tools + use metric_tools + implicit none + + integer :: ele + type(vector_field) :: positions + + positions = read_mesh_files("data/laplacian_grid.3", quad_degree=4, format="gmsh") + + do ele=1,ele_count(positions) + call transform_ele(positions, ele) + end do + +contains + subroutine transform_ele(positions, ele) type(vector_field), intent(inout) :: positions integer, intent(in) :: ele @@ -36,18 +36,18 @@ subroutine transform_ele(positions, ele) tens = simplex_tensor(positions, ele, power=0.5) do loc=1,ele_loc(positions, ele) - t_pos(:, loc) = matmul(tens, pos(:, loc)) + t_pos(:, loc) = matmul(tens, pos(:, loc)) end do fail = .false. do iloc=1,ele_loc(positions, ele) - do jloc=iloc+1,ele_loc(positions, ele) - edge_length = norm2(t_pos(:, iloc) - t_pos(:, jloc)) - fail = fail .or. fnequals(edge_length, 1.0, tol = 201.0 * epsilon(0.0)) - end do + do jloc=iloc+1,ele_loc(positions, ele) + edge_length = norm2(t_pos(:, iloc) - t_pos(:, jloc)) + fail = fail .or. fnequals(edge_length, 1.0, tol = 201.0 * epsilon(0.0)) + end do end do call report_test("[simplex_tensor]", fail, .false., "Edge lengths should be 1, na ja?") - end subroutine + end subroutine end subroutine test_simplex_tensor_edgelens diff --git a/error_measures/tests/test_temperature_goal.F90 b/error_measures/tests/test_temperature_goal.F90 index 632eafd8f9..0722db2e6b 100644 --- a/error_measures/tests/test_temperature_goal.F90 +++ b/error_measures/tests/test_temperature_goal.F90 @@ -1,42 +1,42 @@ subroutine test_temperature_goal - use goals - use state_module - use vtk_interfaces - use unittest_tools - use futils - use fields - implicit none - - type(state_type) :: state(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - type(scalar_field), pointer :: temperature - real :: goal_val - logical :: fail - - interface - function temperature_func(X) result(temp) - real, dimension(:), intent(in) :: X - real :: temp - end function temperature_func - end interface - - call vtk_read_state("data/lock_exchange.vtu", state(1)) - mesh => extract_mesh(state(1), "Mesh") - positions => extract_vector_field(state(1), "Coordinate") - temperature => extract_scalar_field(state(1), "Temperature") - - call set_from_function(temperature, temperature_func, positions) - - goal_val = goal_temp(state) - fail = fnequals(goal_val, 3 * 0.8 * 0.1 * 0.001, tol = 1.0e-10) - call report_test("[goal_temp]", fail, .false., "Give the right answer") + use goals + use state_module + use vtk_interfaces + use unittest_tools + use futils + use fields + implicit none + + type(state_type) :: state(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + type(scalar_field), pointer :: temperature + real :: goal_val + logical :: fail + + interface + function temperature_func(X) result(temp) + real, dimension(:), intent(in) :: X + real :: temp + end function temperature_func + end interface + + call vtk_read_state("data/lock_exchange.vtu", state(1)) + mesh => extract_mesh(state(1), "Mesh") + positions => extract_vector_field(state(1), "Coordinate") + temperature => extract_scalar_field(state(1), "Temperature") + + call set_from_function(temperature, temperature_func, positions) + + goal_val = goal_temp(state) + fail = fnequals(goal_val, 3 * 0.8 * 0.1 * 0.001, tol = 1.0e-10) + call report_test("[goal_temp]", fail, .false., "Give the right answer") end subroutine test_temperature_goal function temperature_func(X) result(temp) - real, dimension(:), intent(in) :: X - real :: temp + real, dimension(:), intent(in) :: X + real :: temp - temp = X(1) + X(2) + X(3) + temp = X(1) + X(2) + X(3) end function temperature_func diff --git a/error_measures/tests/test_temperature_goal_grad.F90 b/error_measures/tests/test_temperature_goal_grad.F90 index ed3a5a5d46..ec82efbb44 100644 --- a/error_measures/tests/test_temperature_goal_grad.F90 +++ b/error_measures/tests/test_temperature_goal_grad.F90 @@ -1,59 +1,59 @@ subroutine test_temperature_goal_grad - use goals - use state_module - use vtk_interfaces - use unittest_tools - use futils - use fields - use mesh_files - implicit none - - type(state_type) :: state(1) - type(mesh_type), pointer :: mesh - type(vector_field), target :: positions - type(scalar_field) :: temperature, sensitivity - logical :: fail - integer :: node - - interface - function temperature_func(X) result(temp) - real, dimension(:), intent(in) :: X - real :: temp - end function temperature_func - end interface - - positions = read_mesh_files("data/interval-0.0-1.0-1.0", quad_degree=4, format="gmsh") - mesh => positions%mesh - call allocate(temperature, mesh, "Temperature") - call allocate(sensitivity, mesh, "TemperatureSensitivity") - call set_from_function(temperature, temperature_func, positions) - - call insert(state(1), positions, "Coordinate") - call deallocate(positions) - call insert(state(1), temperature, "Temperature") - call deallocate(temperature) - - call goal_temp_grad(state, "Temperature", sensitivity) - - ! In this case, sensitivity should = 2 * temperature - - fail = .false. - do node=1,node_count(mesh) - if (node_val(sensitivity, node) .fne. 2 * node_val(temperature, node)) then - write(0,*) "node == ", node - write(0,*) "node_val(temperature, node) == ", node_val(temperature, node) - write(0,*) "node_val(sensitivity, node) == ", node_val(sensitivity, node) - fail = .true. - end if - end do - - call report_test("[goal_temp_grad]", fail, .false., "Give the right answer") + use goals + use state_module + use vtk_interfaces + use unittest_tools + use futils + use fields + use mesh_files + implicit none + + type(state_type) :: state(1) + type(mesh_type), pointer :: mesh + type(vector_field), target :: positions + type(scalar_field) :: temperature, sensitivity + logical :: fail + integer :: node + + interface + function temperature_func(X) result(temp) + real, dimension(:), intent(in) :: X + real :: temp + end function temperature_func + end interface + + positions = read_mesh_files("data/interval-0.0-1.0-1.0", quad_degree=4, format="gmsh") + mesh => positions%mesh + call allocate(temperature, mesh, "Temperature") + call allocate(sensitivity, mesh, "TemperatureSensitivity") + call set_from_function(temperature, temperature_func, positions) + + call insert(state(1), positions, "Coordinate") + call deallocate(positions) + call insert(state(1), temperature, "Temperature") + call deallocate(temperature) + + call goal_temp_grad(state, "Temperature", sensitivity) + + ! In this case, sensitivity should = 2 * temperature + + fail = .false. + do node=1,node_count(mesh) + if (node_val(sensitivity, node) .fne. 2 * node_val(temperature, node)) then + write(0,*) "node == ", node + write(0,*) "node_val(temperature, node) == ", node_val(temperature, node) + write(0,*) "node_val(sensitivity, node) == ", node_val(sensitivity, node) + fail = .true. + end if + end do + + call report_test("[goal_temp_grad]", fail, .false., "Give the right answer") end subroutine test_temperature_goal_grad function temperature_func(X) result(temp) - real, dimension(:), intent(in) :: X - real :: temp + real, dimension(:), intent(in) :: X + real :: temp - temp = X(1) + 0.5 + temp = X(1) + 0.5 end function temperature_func diff --git a/error_measures/tests/test_vector_field_adaptivity.F90 b/error_measures/tests/test_vector_field_adaptivity.F90 index 2f82750dd6..c836d1690f 100644 --- a/error_measures/tests/test_vector_field_adaptivity.F90 +++ b/error_measures/tests/test_vector_field_adaptivity.F90 @@ -2,85 +2,85 @@ subroutine test_vector_field_adaptivity - use global_parameters, only: current_debug_level - use node_boundary, only: pseudo2d_coord - use unittest_tools - use metric_assemble - use edge_length_module - use fields - use state_module - use vtk_interfaces - use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest - use form_metric_field - use field_options - use spud - use populate_state_module, only: compute_domain_statistics - implicit none + use global_parameters, only: current_debug_level + use node_boundary, only: pseudo2d_coord + use unittest_tools + use metric_assemble + use edge_length_module + use fields + use state_module + use vtk_interfaces + use adapt_state_unittest_module, only : adapt_state => adapt_state_unittest + use form_metric_field + use field_options + use spud + use populate_state_module, only: compute_domain_statistics + implicit none #ifdef HAVE_MPI - include "mpif.h" + include "mpif.h" #endif - type(state_type) :: state(1) - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions, vfield_pointer - type(vector_field) :: vfield, vfield_weight - type(scalar_field) :: edgelen - type(tensor_field) :: metric + type(state_type) :: state(1) + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions, vfield_pointer + type(vector_field) :: vfield, vfield_weight + type(scalar_field) :: edgelen + type(tensor_field) :: metric - integer :: i, stat - real :: x, y, z + integer :: i, stat + real :: x, y, z - current_debug_level = 0 - pseudo2d_coord = 3 + current_debug_level = 0 + pseudo2d_coord = 3 - call vtk_read_state("data/pseudo2d.vtu", state(1)) - mesh => extract_mesh(state(1), "Mesh") - call add_faces(mesh) - positions => extract_vector_field(state(1), "Coordinate") - ! Update mesh descriptor on positons - positions%mesh=mesh + call vtk_read_state("data/pseudo2d.vtu", state(1)) + mesh => extract_mesh(state(1), "Mesh") + call add_faces(mesh) + positions => extract_vector_field(state(1), "Coordinate") + ! Update mesh descriptor on positons + positions%mesh=mesh - call allocate(vfield, 3, mesh, "VField") - call allocate(vfield_weight, 3, mesh, "VFieldInterpolationErrorBound", field_type=FIELD_TYPE_CONSTANT) - call allocate(edgelen, mesh, "Edge lengths") - call allocate(metric, mesh, "Metric") + call allocate(vfield, 3, mesh, "VField") + call allocate(vfield_weight, 3, mesh, "VFieldInterpolationErrorBound", field_type=FIELD_TYPE_CONSTANT) + call allocate(edgelen, mesh, "Edge lengths") + call allocate(metric, mesh, "Metric") - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) - vfield%val(1,i) = x - vfield%val(2,i) = y - vfield%val(3,i) = z - end do + vfield%val(1,i) = x + vfield%val(2,i) = y + vfield%val(3,i) = z + end do - call compute_domain_statistics(state) + call compute_domain_statistics(state) - vfield%option_path = "/whatever" - call add_option("/whatever/virtual/adaptivity_options/absolute_measure", stat=stat) + vfield%option_path = "/whatever" + call add_option("/whatever/virtual/adaptivity_options/absolute_measure", stat=stat) - call set(vfield_weight, (/1.0, 1.0, 1.0/)) + call set(vfield_weight, (/1.0, 1.0, 1.0/)) - call insert(state(1), vfield, "VField") - call insert(state(1), vfield_weight, "VFieldInterpolationErrorBound") - positions => extract_vector_field(state(1), "Coordinate") + call insert(state(1), vfield, "VField") + call insert(state(1), vfield_weight, "VFieldInterpolationErrorBound") + positions => extract_vector_field(state(1), "Coordinate") - call adaptivity_bounds(state(1), 0.01, 1.0) + call adaptivity_bounds(state(1), 0.01, 1.0) - call assemble_metric(state, metric) - call get_edge_lengths(metric, edgelen) - call vtk_write_fields("data/vfield_adapt", 0, positions, mesh, sfields=(/edgelen/), vfields=(/vfield, vfield_weight/), tfields=(/metric/)) - call adapt_state(state(1), metric) + call assemble_metric(state, metric) + call get_edge_lengths(metric, edgelen) + call vtk_write_fields("data/vfield_adapt", 0, positions, mesh, sfields=(/edgelen/), vfields=(/vfield, vfield_weight/), tfields=(/metric/)) + call adapt_state(state(1), metric) - call report_test("[adaptivity runs]", .false., .false., "Congratulations! & - & You didn't crash.") + call report_test("[adaptivity runs]", .false., .false., "Congratulations! & + & You didn't crash.") - mesh => extract_mesh(state(1), "Mesh") - positions => extract_vector_field(state(1), "Coordinate") - vfield_pointer => extract_vector_field(state(1), "VField") - call vtk_write_fields("data/vfield_adapt", 1, positions, mesh, vfields=(/vfield_pointer/)) + mesh => extract_mesh(state(1), "Mesh") + positions => extract_vector_field(state(1), "Coordinate") + vfield_pointer => extract_vector_field(state(1), "VField") + call vtk_write_fields("data/vfield_adapt", 1, positions, mesh, vfields=(/vfield_pointer/)) - call report_test("[adaptivity output]", .false., .false., "Congratulations! & - & The output from adaptivity might even be OK if you get this far.") + call report_test("[adaptivity output]", .false., .false., "Congratulations! & + & The output from adaptivity might even be OK if you get this far.") end subroutine test_vector_field_adaptivity diff --git a/error_measures/tests/test_warp_directions.F90 b/error_measures/tests/test_warp_directions.F90 index b20dbfb289..4c35cb56f6 100644 --- a/error_measures/tests/test_warp_directions.F90 +++ b/error_measures/tests/test_warp_directions.F90 @@ -1,46 +1,46 @@ subroutine test_warp_directions - use gradation_metric - use metric_tools - use unittest_tools - use vector_tools - implicit none - - real, dimension(3, 3) :: P, Q, vec_P, vec_Q - real, dimension(3) :: val_P, val_Q - logical :: changed_P, changed_Q - real :: dist - - logical :: fail - - vec_P(1, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) - vec_P(2, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) - vec_P(3, :) = (/0.00000000000000000000E+00, 0.00000000000000000000E+00, 0.10000000000000000000E+01/) - val_P = (/0.16000000000000000000E+02, 0.16000000000000000000E+02, 0.10000000000000000000E+05/) - - vec_Q(1, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) - vec_Q(2, :) = (/0.00000000000000000000E+00, 0.00000000000000000000E+00, 0.10000000000000000000E+01/) - vec_Q(3, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) - val_Q = (/0.16000000000000000000E+02, 0.16000000000000000000E+02, 0.10000000000000000000E+05/) - - dist = 0.320156213733379 - - P = vec_P ; Q = vec_Q - changed_P = .false. ; changed_Q = .false. - call warp_directions(vec_P, val_P, changed_P, vec_Q, val_Q, changed_Q, dist) - - fail = .false. - if (changed_P) then - write(0,*) "P has changed!" - fail = .true. - end if - - if (changed_Q) then - write(0,*) "Q has changed!" - fail = .true. - end if - - call report_test("[warp_directions spheroids]", fail, .false., & - "Warping these matrices should not change Q.") + use gradation_metric + use metric_tools + use unittest_tools + use vector_tools + implicit none + + real, dimension(3, 3) :: P, Q, vec_P, vec_Q + real, dimension(3) :: val_P, val_Q + logical :: changed_P, changed_Q + real :: dist + + logical :: fail + + vec_P(1, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) + vec_P(2, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) + vec_P(3, :) = (/0.00000000000000000000E+00, 0.00000000000000000000E+00, 0.10000000000000000000E+01/) + val_P = (/0.16000000000000000000E+02, 0.16000000000000000000E+02, 0.10000000000000000000E+05/) + + vec_Q(1, :) = (/0.10000000000000000000E+01, 0.00000000000000000000E+00, 0.00000000000000000000E+00/) + vec_Q(2, :) = (/0.00000000000000000000E+00, 0.00000000000000000000E+00, 0.10000000000000000000E+01/) + vec_Q(3, :) = (/0.00000000000000000000E+00, 0.10000000000000000000E+01, 0.00000000000000000000E+00/) + val_Q = (/0.16000000000000000000E+02, 0.16000000000000000000E+02, 0.10000000000000000000E+05/) + + dist = 0.320156213733379 + + P = vec_P ; Q = vec_Q + changed_P = .false. ; changed_Q = .false. + call warp_directions(vec_P, val_P, changed_P, vec_Q, val_Q, changed_Q, dist) + + fail = .false. + if (changed_P) then + write(0,*) "P has changed!" + fail = .true. + end if + + if (changed_Q) then + write(0,*) "Q has changed!" + fail = .true. + end if + + call report_test("[warp_directions spheroids]", fail, .false., & + "Warping these matrices should not change Q.") end subroutine test_warp_directions diff --git a/femtools/Adaptive_Timestepping.F90 b/femtools/Adaptive_Timestepping.F90 index edffc1bea8..28e709a6bc 100644 --- a/femtools/Adaptive_Timestepping.F90 +++ b/femtools/Adaptive_Timestepping.F90 @@ -28,207 +28,207 @@ #include "fdebug.h" module adaptive_timestepping - !!< Contains new style adaptive timestepping routines + !!< Contains new style adaptive timestepping routines - use fldebug - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use spud - use unittest_tools - use fields - use state_module - use field_options - use signal_vars, only : SIG_INT - use diagnostic_fields + use fldebug + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use spud + use unittest_tools + use fields + use state_module + use field_options + use signal_vars, only : SIG_INT + use diagnostic_fields - implicit none + implicit none - private + private - public :: adaptive_timestepping_check_options, & - & calc_cflnumber_field_based_dt, cflnumber_field_based_dt + public :: adaptive_timestepping_check_options, & + & calc_cflnumber_field_based_dt, cflnumber_field_based_dt contains - subroutine calc_cflnumber_field_based_dt(state, dt, force_calculation) - !!< Calculates a new dt based on the supplied state, using options defined - !!< in the options tree - - type(state_type), dimension(:), intent(inout) :: state - real, intent(inout) :: dt - ! If not present or == .false., CFL number fields will be extracted from all - ! states containing one, and will only be calculated for states containing - ! no CFL number field. If == .true., CFL number fields will be calculated - ! for all states. - logical, optional, intent(in) :: force_calculation - - character(len = FIELD_NAME_LEN) :: cfl_type, mesh_name - character(len = *), parameter :: base_path = "/timestepping/adaptive_timestep" - integer :: i, stat, cfl_stat - logical :: lforce_calculation, calculate_cflnumber - real :: max_cfl, max_dt, min_dt, increase_tolerance - real, dimension(:), allocatable :: guess_dt - type(scalar_field), pointer :: cflnumber_field - type(vector_field), pointer :: velocity_field - type(mesh_type), pointer :: mesh - - ewrite(1, *) "In calc_cflnumber_field_based_dt" - - if(present(force_calculation)) then - lforce_calculation = force_calculation - else - lforce_calculation = .false. - end if - - call get_option(base_path // "/requested_cfl", max_cfl) - call get_option(base_path // "/minimum_timestep", min_dt, default = tiny(0.0)) - call get_option(base_path // "/maximum_timestep", max_dt, default = huge(0.0)) - call get_option(base_path // "/increase_tolerance", increase_tolerance, default = huge(0.0) * epsilon(0.0)) - ! what type of cfl number are we using? - call get_option(base_path//"/courant_number[0]/name", cfl_type) - call get_option(base_path//"/courant_number[0]/mesh[0]/name", mesh_name, stat=stat) - if (stat==0) then - mesh => extract_mesh(state(1), mesh_name) - else - mesh => extract_velocity_mesh(state) - end if - - allocate(guess_dt(size(state))) - guess_dt(:) = dt ! store all our attempts at creating a new dt (then choose the minimum of them) - - do i = 1, size(state) - velocity_field=>extract_vector_field(state(i), "Velocity", stat) - if((stat==0).and.(.not.aliased(velocity_field))) then - - calculate_cflnumber = .true. - if(.not. lforce_calculation) then - ! see if the courant number has already been calculated (requires things to stay in the right order) - cflnumber_field=>extract_scalar_field(state(i), trim(cfl_type), cfl_stat) - if(cfl_stat==0) then - ! check the mesh is the same as the requested one - calculate_cflnumber=.not.(cflnumber_field%mesh==mesh) - else - ! we have to evaluate it anyway - calculate_cflnumber = .true. - end if - end if - if(calculate_cflnumber) then - allocate(cflnumber_field) - call allocate(cflnumber_field, mesh, trim(cfl_type)) - call calculate_diagnostic_variable(state(i), trim(cfl_type), cflnumber_field, & - & option_path = trim(base_path)//"/courant_number[0]") - end if - - guess_dt(i) = cflnumber_field_based_dt(cflnumber_field, dt, max_cfl, min_dt, max_dt, increase_tolerance) - - if(calculate_cflnumber) then - call deallocate(cflnumber_field) - deallocate(cflnumber_field) - end if + subroutine calc_cflnumber_field_based_dt(state, dt, force_calculation) + !!< Calculates a new dt based on the supplied state, using options defined + !!< in the options tree + + type(state_type), dimension(:), intent(inout) :: state + real, intent(inout) :: dt + ! If not present or == .false., CFL number fields will be extracted from all + ! states containing one, and will only be calculated for states containing + ! no CFL number field. If == .true., CFL number fields will be calculated + ! for all states. + logical, optional, intent(in) :: force_calculation + + character(len = FIELD_NAME_LEN) :: cfl_type, mesh_name + character(len = *), parameter :: base_path = "/timestepping/adaptive_timestep" + integer :: i, stat, cfl_stat + logical :: lforce_calculation, calculate_cflnumber + real :: max_cfl, max_dt, min_dt, increase_tolerance + real, dimension(:), allocatable :: guess_dt + type(scalar_field), pointer :: cflnumber_field + type(vector_field), pointer :: velocity_field + type(mesh_type), pointer :: mesh + + ewrite(1, *) "In calc_cflnumber_field_based_dt" + + if(present(force_calculation)) then + lforce_calculation = force_calculation + else + lforce_calculation = .false. + end if + + call get_option(base_path // "/requested_cfl", max_cfl) + call get_option(base_path // "/minimum_timestep", min_dt, default = tiny(0.0)) + call get_option(base_path // "/maximum_timestep", max_dt, default = huge(0.0)) + call get_option(base_path // "/increase_tolerance", increase_tolerance, default = huge(0.0) * epsilon(0.0)) + ! what type of cfl number are we using? + call get_option(base_path//"/courant_number[0]/name", cfl_type) + call get_option(base_path//"/courant_number[0]/mesh[0]/name", mesh_name, stat=stat) + if (stat==0) then + mesh => extract_mesh(state(1), mesh_name) else - guess_dt(i) = huge(0.0) ! this is risky in the case of no velocity field at all (is this possible?) + mesh => extract_velocity_mesh(state) end if - end do - dt = minval(guess_dt) ! be safe... use the minimum timestep of all the phases + allocate(guess_dt(size(state))) + guess_dt(:) = dt ! store all our attempts at creating a new dt (then choose the minimum of them) - deallocate(guess_dt) + do i = 1, size(state) + velocity_field=>extract_vector_field(state(i), "Velocity", stat) + if((stat==0).and.(.not.aliased(velocity_field))) then - if(have_option(base_path // "/minimum_timestep/terminate_if_reached")) then - if(dt <= min_dt + spacing(min_dt)) then - ewrite(0, *) "Minimum timestep reached - terminating" - SIG_INT = .true. + calculate_cflnumber = .true. + if(.not. lforce_calculation) then + ! see if the courant number has already been calculated (requires things to stay in the right order) + cflnumber_field=>extract_scalar_field(state(i), trim(cfl_type), cfl_stat) + if(cfl_stat==0) then + ! check the mesh is the same as the requested one + calculate_cflnumber=.not.(cflnumber_field%mesh==mesh) + else + ! we have to evaluate it anyway + calculate_cflnumber = .true. + end if + end if + if(calculate_cflnumber) then + allocate(cflnumber_field) + call allocate(cflnumber_field, mesh, trim(cfl_type)) + call calculate_diagnostic_variable(state(i), trim(cfl_type), cflnumber_field, & + & option_path = trim(base_path)//"/courant_number[0]") + end if + + guess_dt(i) = cflnumber_field_based_dt(cflnumber_field, dt, max_cfl, min_dt, max_dt, increase_tolerance) + + if(calculate_cflnumber) then + call deallocate(cflnumber_field) + deallocate(cflnumber_field) + end if + else + guess_dt(i) = huge(0.0) ! this is risky in the case of no velocity field at all (is this possible?) + end if + end do + + dt = minval(guess_dt) ! be safe... use the minimum timestep of all the phases + + deallocate(guess_dt) + + if(have_option(base_path // "/minimum_timestep/terminate_if_reached")) then + if(dt <= min_dt + spacing(min_dt)) then + ewrite(0, *) "Minimum timestep reached - terminating" + SIG_INT = .true. + end if end if - end if - ewrite(1, *) "Exiting calc_cflnumber_field_based_dt" + ewrite(1, *) "Exiting calc_cflnumber_field_based_dt" - end subroutine calc_cflnumber_field_based_dt + end subroutine calc_cflnumber_field_based_dt - function cflnumber_field_based_dt(cflnumber_field, current_dt, max_cfl_requested, min_dt, max_dt, increase_tolerance) result(dt) - !!< Calculates a new dt based on the supplied CFLNumber field + function cflnumber_field_based_dt(cflnumber_field, current_dt, max_cfl_requested, min_dt, max_dt, increase_tolerance) result(dt) + !!< Calculates a new dt based on the supplied CFLNumber field - type(scalar_field), intent(in) :: cflnumber_field - real, intent(in) :: current_dt - real, intent(in) :: max_cfl_requested - real, intent(in) :: min_dt - real, intent(in) :: max_dt - real, intent(in) :: increase_tolerance + type(scalar_field), intent(in) :: cflnumber_field + real, intent(in) :: current_dt + real, intent(in) :: max_cfl_requested + real, intent(in) :: min_dt + real, intent(in) :: max_dt + real, intent(in) :: increase_tolerance - real :: dt + real :: dt - real :: max_cfl_number + real :: max_cfl_number - assert(current_dt > 0.0) - assert(max_cfl_requested > 0.0) - assert(min_dt > 0.0) - assert(max_dt > min_dt) - assert(increase_tolerance > 1.0) + assert(current_dt > 0.0) + assert(max_cfl_requested > 0.0) + assert(min_dt > 0.0) + assert(max_dt > min_dt) + assert(increase_tolerance > 1.0) - call field_stats(cflnumber_field, max = max_cfl_number) - ewrite(2, *) "Max CFL Number: ", max_cfl_number + call field_stats(cflnumber_field, max = max_cfl_number) + ewrite(2, *) "Max CFL Number: ", max_cfl_number - if(max_cfl_number == 0.0) then - dt = huge(0.0) - else - dt = (current_dt * max_cfl_requested) / max_cfl_number - end if + if(max_cfl_number == 0.0) then + dt = huge(0.0) + else + dt = (current_dt * max_cfl_requested) / max_cfl_number + end if - dt = max(dt, min_dt) - dt = min(dt, max_dt) - dt = min(dt, current_dt * increase_tolerance) + dt = max(dt, min_dt) + dt = min(dt, max_dt) + dt = min(dt, current_dt * increase_tolerance) - ewrite(2, *) "cflnumber_field_based_dt returning: ", dt + ewrite(2, *) "cflnumber_field_based_dt returning: ", dt - end function cflnumber_field_based_dt + end function cflnumber_field_based_dt - subroutine adaptive_timestepping_check_options - !!< Checks new style adaptive timestepping related options + subroutine adaptive_timestepping_check_options + !!< Checks new style adaptive timestepping related options - character(len = OPTION_PATH_LEN) :: base_path - integer :: stat - real :: max_cfl, max_dt, min_dt, increase_tolerance + character(len = OPTION_PATH_LEN) :: base_path + integer :: stat + real :: max_cfl, max_dt, min_dt, increase_tolerance - base_path = "/timestepping/adaptive_timestep" + base_path = "/timestepping/adaptive_timestep" - if(.not. have_option(trim(base_path))) then - ! Nothing to check - return - end if + if(.not. have_option(trim(base_path))) then + ! Nothing to check + return + end if - ewrite(2, *) "Checking adaptive timestepping options" + ewrite(2, *) "Checking adaptive timestepping options" - call get_option(trim(base_path) // "/requested_cfl", max_cfl, stat) - if(stat /= SPUD_NO_ERROR) then - FLExit("Target CFL number required for adaptive timestepping") - end if - if(max_cfl <= 0.0) then - FLExit("Maximum adaptive timestepping CFL number must be positive") - end if + call get_option(trim(base_path) // "/requested_cfl", max_cfl, stat) + if(stat /= SPUD_NO_ERROR) then + FLExit("Target CFL number required for adaptive timestepping") + end if + if(max_cfl <= 0.0) then + FLExit("Maximum adaptive timestepping CFL number must be positive") + end if - call get_option(trim(base_path) // "/minimum_timestep", min_dt, stat) - if(stat == SPUD_NO_ERROR) then - if(min_dt < 0.0) then - FLExit("Minimum timestep size cannot be negative") + call get_option(trim(base_path) // "/minimum_timestep", min_dt, stat) + if(stat == SPUD_NO_ERROR) then + if(min_dt < 0.0) then + FLExit("Minimum timestep size cannot be negative") + end if + else + min_dt = 0.0 end if - else - min_dt = 0.0 - end if - call get_option(trim(base_path) // "/maximum_timestep", max_dt, stat) - if(stat == SPUD_NO_ERROR) then - if(max_dt < min_dt) then - FLExit("Maximum timestep size must be larger than minimum timestep size") + call get_option(trim(base_path) // "/maximum_timestep", max_dt, stat) + if(stat == SPUD_NO_ERROR) then + if(max_dt < min_dt) then + FLExit("Maximum timestep size must be larger than minimum timestep size") + end if end if - end if - call get_option(trim(base_path) // "/increase_tolerance", increase_tolerance, stat) - if(stat == SPUD_NO_ERROR) then - if(increase_tolerance < 1.0) then - FLExit("Adaptive timestepping increase tolerance must be >= 1.0") + call get_option(trim(base_path) // "/increase_tolerance", increase_tolerance, stat) + if(stat == SPUD_NO_ERROR) then + if(increase_tolerance < 1.0) then + FLExit("Adaptive timestepping increase tolerance must be >= 1.0") + end if end if - end if - ewrite(2, *) "Finished checking adaptive timestepping options" + ewrite(2, *) "Finished checking adaptive timestepping options" - end subroutine adaptive_timestepping_check_options + end subroutine adaptive_timestepping_check_options end module adaptive_timestepping diff --git a/femtools/Adaptive_interpolation.F90 b/femtools/Adaptive_interpolation.F90 index d8add3a579..08121bd51e 100644 --- a/femtools/Adaptive_interpolation.F90 +++ b/femtools/Adaptive_interpolation.F90 @@ -2,40 +2,40 @@ module adaptive_interpolation_module - use fldebug - use vector_tools - use quadrature - use futils - use elements - use spud - use quicksort - use sparse_tools - use tensors - use sparse_tools - use transform_elements - use adjacency_lists - use unittest_tools - use linked_lists - use supermesh_construction - use fetools - use intersection_finder_module - use fields - use meshdiagnostics - use sparsity_patterns - use vtk_interfaces - use sparse_matrices_fields - use solvers - implicit none - - integer :: max_ai_degree=14 - - private - public :: adaptive_interpolation, max_ai_degree - - contains - ! Interpolate a field onto new_positions in such a way that the L2 error squared - ! of the projection is less than error_tolerance. - subroutine adaptive_interpolation(old_field, old_positions, new_field, new_positions, error_tolerance, achieved_error, no_refinements) + use fldebug + use vector_tools + use quadrature + use futils + use elements + use spud + use quicksort + use sparse_tools + use tensors + use sparse_tools + use transform_elements + use adjacency_lists + use unittest_tools + use linked_lists + use supermesh_construction + use fetools + use intersection_finder_module + use fields + use meshdiagnostics + use sparsity_patterns + use vtk_interfaces + use sparse_matrices_fields + use solvers + implicit none + + integer :: max_ai_degree=14 + + private + public :: adaptive_interpolation, max_ai_degree + +contains + ! Interpolate a field onto new_positions in such a way that the L2 error squared + ! of the projection is less than error_tolerance. + subroutine adaptive_interpolation(old_field, old_positions, new_field, new_positions, error_tolerance, achieved_error, no_refinements) type(scalar_field), intent(in) :: old_field type(vector_field), intent(in) :: old_positions type(scalar_field), intent(inout) :: new_field @@ -77,68 +77,68 @@ subroutine adaptive_interpolation(old_field, old_positions, new_field, new_posit map_BA = intersection_finder(new_positions, old_positions) if (associated(new_field%mesh%region_ids)) then - deallocate(new_field%mesh%region_ids) + deallocate(new_field%mesh%region_ids) end if allocate(new_field%mesh%region_ids(ele_count(new_field))) new_field%mesh%region_ids = -10000 do p=1,max_ai_degree - shape_fns(p) = make_element_shape(vertices=ele_loc(new_positions, 1), dim=dim, degree=p, quad=supermesh_quad) + shape_fns(p) = make_element_shape(vertices=ele_loc(new_positions, 1), dim=dim, degree=p, quad=supermesh_quad) end do allocate(element_value(shape_fns(max_ai_degree)%loc)) domain_volume = 0.0 do ele_A=1,ele_count(old_positions) - call local_coords_matrix(old_positions, ele_A, inversion_matrices_A(:, :, ele_A)) - domain_volume = domain_volume + simplex_volume(old_positions, ele_A) + call local_coords_matrix(old_positions, ele_A, inversion_matrices_A(:, :, ele_A)) + domain_volume = domain_volume + simplex_volume(old_positions, ele_A) end do do ele_B=1,ele_count(new_positions) - call local_coords_matrix(new_positions, ele_B, inversion_matrix_B) - p = element_degree(new_field, ele_B) - - call construct_supermesh(new_positions, ele_B, old_positions, map_BA(ele_B), supermesh_shape, supermesh) - call galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_fns(p), new_positions, ele_B, & - & inversion_matrix_B, supermesh, element_value(1:shape_fns(p)%loc)) - ele_volume = simplex_volume(new_positions, ele_B) - ele_tol = error_tolerance * (ele_volume / domain_volume) - ewrite(3,*) "ele_B: ", ele_B, "; ele_tol: ", ele_tol - call compute_projection_error(old_field, old_positions, shape_fns(p), element_value(1:shape_fns(p)%loc), & - & new_positions, ele_B, & - & supermesh, inversion_matrices_A, inversion_matrix_B, ele_error) - ewrite(3,*) " p: ", p, "; ele_error: ", ele_error - do while (ele_error > ele_tol) - p = p + 1 - if (p > max_ai_degree) then - ewrite(0,*) "Warning: cannot refine element ", ele_B, " to degree ", p - exit - end if - no_refinements = no_refinements + 1 - call galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_fns(p), new_positions, ele_B, & - & inversion_matrix_B, supermesh, element_value(1:shape_fns(p)%loc)) - call compute_projection_error(old_field, old_positions, shape_fns(p), element_value(1:shape_fns(p)%loc), & - & new_positions, ele_B, & - & supermesh, inversion_matrices_A, inversion_matrix_B, ele_error) - ewrite(3,*) " p: ", p, "; ele_error: ", ele_error - end do - - achieved_error = achieved_error + ele_error - new_field%mesh%region_ids(ele_B) = min(p, max_ai_degree) - !write(0,*) "ele_B: ", ele_B, "; p: ", min(p, max_ai_degree - 1) - - call deallocate(supermesh) + call local_coords_matrix(new_positions, ele_B, inversion_matrix_B) + p = element_degree(new_field, ele_B) + + call construct_supermesh(new_positions, ele_B, old_positions, map_BA(ele_B), supermesh_shape, supermesh) + call galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_fns(p), new_positions, ele_B, & + & inversion_matrix_B, supermesh, element_value(1:shape_fns(p)%loc)) + ele_volume = simplex_volume(new_positions, ele_B) + ele_tol = error_tolerance * (ele_volume / domain_volume) + ewrite(3,*) "ele_B: ", ele_B, "; ele_tol: ", ele_tol + call compute_projection_error(old_field, old_positions, shape_fns(p), element_value(1:shape_fns(p)%loc), & + & new_positions, ele_B, & + & supermesh, inversion_matrices_A, inversion_matrix_B, ele_error) + ewrite(3,*) " p: ", p, "; ele_error: ", ele_error + do while (ele_error > ele_tol) + p = p + 1 + if (p > max_ai_degree) then + ewrite(0,*) "Warning: cannot refine element ", ele_B, " to degree ", p + exit + end if + no_refinements = no_refinements + 1 + call galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_fns(p), new_positions, ele_B, & + & inversion_matrix_B, supermesh, element_value(1:shape_fns(p)%loc)) + call compute_projection_error(old_field, old_positions, shape_fns(p), element_value(1:shape_fns(p)%loc), & + & new_positions, ele_B, & + & supermesh, inversion_matrices_A, inversion_matrix_B, ele_error) + ewrite(3,*) " p: ", p, "; ele_error: ", ele_error + end do + + achieved_error = achieved_error + ele_error + new_field%mesh%region_ids(ele_B) = min(p, max_ai_degree) + !write(0,*) "ele_B: ", ele_B, "; p: ", min(p, max_ai_degree - 1) + + call deallocate(supermesh) end do call deallocate(supermesh_shape) call deallocate(supermesh_quad) do ele_B=1,ele_count(new_positions) - call deallocate(map_BA(ele_B)) + call deallocate(map_BA(ele_B)) end do - end subroutine adaptive_interpolation + end subroutine adaptive_interpolation - subroutine galerkin_projection_ele(old_field, inversion_matrices_A, shape_B, new_positions, ele_B, & - & inversion_matrix_B, supermesh, element_value, stat) + subroutine galerkin_projection_ele(old_field, inversion_matrices_A, shape_B, new_positions, ele_B, & + & inversion_matrix_B, supermesh, element_value, stat) type(scalar_field), intent(in) :: old_field type(vector_field), intent(in) :: new_positions real, dimension(:, :, :), intent(in) :: inversion_matrices_A @@ -182,67 +182,67 @@ subroutine galerkin_projection_ele(old_field, inversion_matrices_A, shape_B, new little_rhs = 0.0 do ele_C=1,ele_count(supermesh) - ele_A = ele_region_id(supermesh, ele_C) - shape_A => ele_shape(old_field, ele_A) - inversion_matrix_A = inversion_matrices_A(:, :, ele_A) - - intersection_val_at_quad = ele_val_at_quad(supermesh, ele_C) - pos_at_quad_B(1:dim, :) = intersection_val_at_quad - pos_at_quad_B(dim+1, :) = 1.0 - pos_at_quad_B = matmul(inversion_matrix_B, pos_at_quad_B) - - pos_at_quad_A(1:dim, :) = intersection_val_at_quad - pos_at_quad_A(dim+1, :) = 1.0 - pos_at_quad_A = matmul(inversion_matrix_A, pos_at_quad_A) - - call transform_to_physical(supermesh, ele_C, detwei_C) - vols_C = vols_C + sum(detwei_C) - - if (shape_B%degree==0) then - basis_at_quad_B = 1.0 - elseif (shape_B%degree==1) then - basis_at_quad_B = pos_at_quad_B - else - do j=1,ele_ngi(supermesh, ele_C) - basis_at_quad_B(:, j) = eval_shape(shape_B, pos_at_quad_B(:, j)) - end do - end if - - if (shape_A%degree==0) then - basis_at_quad_A = 1.0 - elseif (shape_A%degree==1) then - basis_at_quad_A = pos_at_quad_A - else - do j=1,ele_ngi(supermesh, ele_C) - basis_at_quad_A(:, j) = eval_shape(shape_A, pos_at_quad_A(:, j)) - end do - end if - - little_mixed_mass_matrix = 0.0 - little_mixed_mass_matrix_int = 0.0 - do j=1,ele_ngi(supermesh, ele_C) - forall (k=1:shape_B%loc,l=1:ele_loc(old_field, ele_A)) - little_mixed_mass_matrix_int(k, l) = basis_at_quad_B(k, j) * basis_at_quad_A(l, j) - end forall - little_mixed_mass_matrix = little_mixed_mass_matrix + little_mixed_mass_matrix_int * detwei_C(j) - end do - - little_rhs = little_rhs + matmul(little_mixed_mass_matrix, ele_val(old_field, ele_A)) - end do - - if (abs(vol_B - vols_C)/vol_B > 0.01) then - stat = 1 - return - else - stat = 0 - call solve(little_mass_matrix, little_rhs) - element_value(1:shape_B%loc) = little_rhs - end if - - end subroutine galerkin_projection_ele - - subroutine galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_fn, new_positions, ele_B, & - & inversion_matrix_B, supermesh, element_value) + ele_A = ele_region_id(supermesh, ele_C) + shape_A => ele_shape(old_field, ele_A) + inversion_matrix_A = inversion_matrices_A(:, :, ele_A) + + intersection_val_at_quad = ele_val_at_quad(supermesh, ele_C) + pos_at_quad_B(1:dim, :) = intersection_val_at_quad + pos_at_quad_B(dim+1, :) = 1.0 + pos_at_quad_B = matmul(inversion_matrix_B, pos_at_quad_B) + + pos_at_quad_A(1:dim, :) = intersection_val_at_quad + pos_at_quad_A(dim+1, :) = 1.0 + pos_at_quad_A = matmul(inversion_matrix_A, pos_at_quad_A) + + call transform_to_physical(supermesh, ele_C, detwei_C) + vols_C = vols_C + sum(detwei_C) + + if (shape_B%degree==0) then + basis_at_quad_B = 1.0 + elseif (shape_B%degree==1) then + basis_at_quad_B = pos_at_quad_B + else + do j=1,ele_ngi(supermesh, ele_C) + basis_at_quad_B(:, j) = eval_shape(shape_B, pos_at_quad_B(:, j)) + end do + end if + + if (shape_A%degree==0) then + basis_at_quad_A = 1.0 + elseif (shape_A%degree==1) then + basis_at_quad_A = pos_at_quad_A + else + do j=1,ele_ngi(supermesh, ele_C) + basis_at_quad_A(:, j) = eval_shape(shape_A, pos_at_quad_A(:, j)) + end do + end if + + little_mixed_mass_matrix = 0.0 + little_mixed_mass_matrix_int = 0.0 + do j=1,ele_ngi(supermesh, ele_C) + forall (k=1:shape_B%loc,l=1:ele_loc(old_field, ele_A)) + little_mixed_mass_matrix_int(k, l) = basis_at_quad_B(k, j) * basis_at_quad_A(l, j) + end forall + little_mixed_mass_matrix = little_mixed_mass_matrix + little_mixed_mass_matrix_int * detwei_C(j) + end do + + little_rhs = little_rhs + matmul(little_mixed_mass_matrix, ele_val(old_field, ele_A)) + end do + + if (abs(vol_B - vols_C)/vol_B > 0.01) then + stat = 1 + return + else + stat = 0 + call solve(little_mass_matrix, little_rhs) + element_value(1:shape_B%loc) = little_rhs + end if + + end subroutine galerkin_projection_ele + + subroutine galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_fn, new_positions, ele_B, & + & inversion_matrix_B, supermesh, element_value) type(scalar_field), intent(in) :: old_field type(vector_field), intent(in) :: new_positions real, dimension(:, :, :), intent(in) :: inversion_matrices_A @@ -256,10 +256,10 @@ subroutine galerkin_projection_ele_exact(old_field, inversion_matrices_A, shape_ call galerkin_projection_ele(old_field, inversion_matrices_A, shape_fn, new_positions, ele_B, inversion_matrix_B, supermesh, element_value, stat) if (stat /= 0) then - call intersector_set_exactness(.true.) - call galerkin_projection_ele(old_field, inversion_matrices_A, shape_fn, new_positions, ele_B, inversion_matrix_B, supermesh, element_value, stat) - call intersector_set_exactness(.false.) + call intersector_set_exactness(.true.) + call galerkin_projection_ele(old_field, inversion_matrices_A, shape_fn, new_positions, ele_B, inversion_matrix_B, supermesh, element_value, stat) + call intersector_set_exactness(.false.) end if - end subroutine galerkin_projection_ele_exact + end subroutine galerkin_projection_ele_exact end module adaptive_interpolation_module diff --git a/femtools/Adjacency_Lists.F90 b/femtools/Adjacency_Lists.F90 index d9c1180f05..c861c1b489 100644 --- a/femtools/Adjacency_Lists.F90 +++ b/femtools/Adjacency_Lists.F90 @@ -27,77 +27,77 @@ #include "fdebug.h" module adjacency_lists - ! ********************************************************************** - !! Module to construct mesh adjacency lists. - use FLDebug - use futils - use sparse_tools - use element_numbering - use fields_data_types - use fields_base - implicit none + ! ********************************************************************** + !! Module to construct mesh adjacency lists. + use FLDebug + use futils + use sparse_tools + use element_numbering + use fields_data_types + use fields_base + implicit none - interface MakeLists - module procedure MakeLists_Dynamic, MakeLists_Mesh - end interface + interface MakeLists + module procedure MakeLists_Dynamic, MakeLists_Mesh + end interface - private + private - public :: MakeLists, nodele, findcommonelements, makeeelist + public :: MakeLists, nodele, findcommonelements, makeeelist contains -SUBROUTINE NODELE(NONODS,FINDELE,COLELE, & - NCOLEL,MXNCOLEL, & - TOTELE,NLOC,NDGLNO) + SUBROUTINE NODELE(NONODS,FINDELE,COLELE, & + NCOLEL,MXNCOLEL, & + TOTELE,NLOC,NDGLNO) - Implicit None + Implicit None - ! This sub calculates the node to element list FINDELE,COLELE - INTEGER, Intent(In)::NONODS, MXNCOLEL - INTEGER, Intent(Out)::NCOLEL,COLELE(MXNCOLEL),FINDELE(NONODS+1) - INTEGER, intent(in)::TOTELE,NLOC,NDGLNO(TOTELE*NLOC) + ! This sub calculates the node to element list FINDELE,COLELE + INTEGER, Intent(In)::NONODS, MXNCOLEL + INTEGER, Intent(Out)::NCOLEL,COLELE(MXNCOLEL),FINDELE(NONODS+1) + INTEGER, intent(in)::TOTELE,NLOC,NDGLNO(TOTELE*NLOC) - ! Local variables... - INTEGER NOD,ELE,ILOC,COUNT, iNod - Integer, Allocatable::NList(:), InList(:) + ! Local variables... + INTEGER NOD,ELE,ILOC,COUNT, iNod + Integer, Allocatable::NList(:), InList(:) - Allocate(NList(Nonods)) - Allocate(InList(Nonods)) + Allocate(NList(Nonods)) + Allocate(InList(Nonods)) - DO NOD=1,NONODS - NLIST(NOD)=0 - INLIST(NOD)=0 - END DO + DO NOD=1,NONODS + NLIST(NOD)=0 + INLIST(NOD)=0 + END DO - DO ELE=1,TOTELE - DO ILOC=1,NLOC - INOD=NDGLNO((ELE-1)*NLOC+ILOC) - NLIST(INOD)=NLIST(INOD)+1 ! number of elements inod is part of - END DO - END DO + DO ELE=1,TOTELE + DO ILOC=1,NLOC + INOD=NDGLNO((ELE-1)*NLOC+ILOC) + NLIST(INOD)=NLIST(INOD)+1 ! number of elements inod is part of + END DO + END DO - COUNT=0 - DO NOD=1,NONODS - FINDELE(NOD)=COUNT+1 - COUNT=COUNT+NLIST(NOD) - END DO - FINDELE(NONODS+1)=COUNT+1 - NCOLEL=COUNT + COUNT=0 + DO NOD=1,NONODS + FINDELE(NOD)=COUNT+1 + COUNT=COUNT+NLIST(NOD) + END DO + FINDELE(NONODS+1)=COUNT+1 + NCOLEL=COUNT - DO ELE=1,TOTELE - DO ILOC=1,NLOC - INOD=NDGLNO((ELE-1)*NLOC+ILOC) - INLIST(INOD)=INLIST(INOD)+1 - COLELE(FINDELE(INOD)-1+INLIST(INOD))=ELE - END DO - END DO + DO ELE=1,TOTELE + DO ILOC=1,NLOC + INOD=NDGLNO((ELE-1)*NLOC+ILOC) + INLIST(INOD)=INLIST(INOD)+1 + COLELE(FINDELE(INOD)-1+INLIST(INOD))=ELE + END DO + END DO - Deallocate(NList, InList) + Deallocate(NList, InList) - RETURN -END SUBROUTINE NODELE + RETURN + END SUBROUTINE NODELE @@ -107,869 +107,869 @@ END SUBROUTINE NODELE - ! ************************************************************************** + ! ************************************************************************** - Subroutine MakeEEList_old(Nonods,Totele,NLoc,& - D3, & - ENList, & - NEList, lgthNEList, NEListBasePtr, & - EEList) + Subroutine MakeEEList_old(Nonods,Totele,NLoc,& + D3, & + ENList, & + NEList, lgthNEList, NEListBasePtr, & + EEList) - !! This subroutine returns ordered list of elements connected to 'ele' - !! Zero entry indicates a free boundary, ie. on the surface + !! This subroutine returns ordered list of elements connected to 'ele' + !! Zero entry indicates a free boundary, ie. on the surface - Implicit None + Implicit None - Integer, Intent(In)::Nonods, Totele, NLoc - Logical, Intent(In)::D3 - Integer, Intent(In)::ENList(totele*nloc) - Integer, intent(In)::lgthNEList, NEList(lgthNElist), NEListBasePtr(Nonods+1) + Integer, Intent(In)::Nonods, Totele, NLoc + Logical, Intent(In)::D3 + Integer, Intent(In)::ENList(totele*nloc) + Integer, intent(In)::lgthNEList, NEList(lgthNElist), NEListBasePtr(Nonods+1) - Integer, Intent(Out)::EEList(Totele*NLoc) + Integer, Intent(Out)::EEList(Totele*NLoc) - Integer, Allocatable::LocalElements(:), LocalNodes(:), n(:) - ! Local... - Integer Ele, ILoc, EEmark, ErrMark - Integer ComEle, OppNode, i, p, OtherNode + Integer, Allocatable::LocalElements(:), LocalNodes(:), n(:) + ! Local... + Integer Ele, ILoc, EEmark, ErrMark + Integer ComEle, OppNode, i, p, OtherNode - ewrite(3, *) "Inside Subroutine MakeEEList_old" + ewrite(3, *) "Inside Subroutine MakeEEList_old" - Allocate(LocalElements(10000)) + Allocate(LocalElements(10000)) - Allocate(LocalNodes(NLoc)) - Allocate(n(NLoc-1)) + Allocate(LocalNodes(NLoc)) + Allocate(n(NLoc-1)) - !Check NElist before we start - do i=1,lgthNEList - if(NEList(i).eq.0) then - ewrite(-1,*) 'NEList zero:',i,NEList(i) - FLAbort("Dieing") - end if - end do + !Check NElist before we start + do i=1,lgthNEList + if(NEList(i).eq.0) then + ewrite(-1,*) 'NEList zero:',i,NEList(i) + FLAbort("Dieing") + end if + end do - EEmark = 1 + EEmark = 1 - Do ele=1,Totele + Do ele=1,Totele - do iLoc=1,NLoc - LocalNodes(iLoc) = ENList((ele-1)*nloc+iLoc) - end do + do iLoc=1,NLoc + LocalNodes(iLoc) = ENList((ele-1)*nloc+iLoc) + end do - Call LocalElementsNods(Nonods, Nloc, & + Call LocalElementsNods(Nonods, Nloc, & NEList, NEListBasePtr, lgthNEList, & LocalNodes, & 10000, LocalElements, p) - ErrMark = 0 + ErrMark = 0 - if(D3) Then + if(D3) Then - OppNode = LocalNodes(1) - n(1) = LocalNodes(2) - n(2) = LocalNodes(3) - n(3) = LocalNodes(4) + OppNode = LocalNodes(1) + n(1) = LocalNodes(2) + n(2) = LocalNodes(3) + n(3) = LocalNodes(4) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - OppNode = LocalNodes(2) - n(1) = LocalNodes(3) - n(2) = LocalNodes(4) - n(3) = LocalNodes(1) + OppNode = LocalNodes(2) + n(1) = LocalNodes(3) + n(2) = LocalNodes(4) + n(3) = LocalNodes(1) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - OppNode = LocalNodes(3) - n(1) = LocalNodes(4) - n(2) = LocalNodes(1) - n(3) = LocalNodes(2) + OppNode = LocalNodes(3) + n(1) = LocalNodes(4) + n(2) = LocalNodes(1) + n(3) = LocalNodes(2) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - OppNode = LocalNodes(4) - n(1) = LocalNodes(1) - n(2) = LocalNodes(2) - n(3) = LocalNodes(3) + OppNode = LocalNodes(4) + n(1) = LocalNodes(1) + n(2) = LocalNodes(2) + n(3) = LocalNodes(3) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - if(ErrMark.eq.4.and.totele/=1) then - ewrite(-1,*) '...all surface eles zero..', ele - FLAbort("dieing") - end if + if(ErrMark.eq.4.and.totele/=1) then + ewrite(-1,*) '...all surface eles zero..', ele + FLAbort("dieing") + end if - Elseif (nloc==2) then - ! 1D - ! Note that nloc==2 is very unsafe but will do pending a complete - ! rewrite of adjacency_lists. - call MakeEEList1D(Nonods,Totele,NLoc,& + Elseif (nloc==2) then + ! 1D + ! Note that nloc==2 is very unsafe but will do pending a complete + ! rewrite of adjacency_lists. + call MakeEEList1D(Nonods,Totele,NLoc,& ENList, & NEList, lgthNEList, NEListBasePtr, & EEList) - else - ! now 2d + else + ! now 2d - OppNode = LocalNodes(1) - n(1) = LocalNodes(2) - n(2) = LocalNodes(3) + OppNode = LocalNodes(1) + n(1) = LocalNodes(2) + n(2) = LocalNodes(3) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - OppNode = LocalNodes(2) - n(1) = LocalNodes(3) - n(2) = LocalNodes(1) + OppNode = LocalNodes(2) + n(1) = LocalNodes(3) + n(2) = LocalNodes(1) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - OppNode = LocalNodes(3) - n(1) = LocalNodes(1) - n(2) = LocalNodes(2) + OppNode = LocalNodes(3) + n(1) = LocalNodes(1) + n(2) = LocalNodes(2) - Call match_list(Totele, Nloc, & + Call match_list(Totele, Nloc, & D3, & ENList, & OppNode, n, & LocalElements, p, & ComEle, OtherNode) - EEList(EEmark) = ComEle - EEmark = EEmark + 1 - - if(ComEle.eq.0) then - ErrMark = ErrMark+1 - end if - - if(ErrMark.eq.4.and.totele/=1 ) then - ewrite(3,*) '...all sur eles zero..', ele - stop 4445 - end if + EEList(EEmark) = ComEle + EEmark = EEmark + 1 - End if + if(ComEle.eq.0) then + ErrMark = ErrMark+1 + end if - End Do + if(ErrMark.eq.4.and.totele/=1 ) then + ewrite(3,*) '...all sur eles zero..', ele + stop 4445 + end if - Deallocate(LocalElements, LocalNodes, n) + End if - ewrite(3, *) "At end of subroutine MakeEEList_old" + End Do - Return - End Subroutine MakeEEList_old + Deallocate(LocalElements, LocalNodes, n) - Subroutine MakeEEList1D(Nonods,Totele,NLoc,& - ENList, & - NEList, lgthNEList, NEListBasePtr, & - EEList) + ewrite(3, *) "At end of subroutine MakeEEList_old" - !! This subroutine returns ordered list of elements connected to 'ele' - !! Zero entry indicates a free boundary, ie. on the surface + Return + End Subroutine MakeEEList_old - Implicit None + Subroutine MakeEEList1D(Nonods,Totele,NLoc,& + ENList, & + NEList, lgthNEList, NEListBasePtr, & + EEList) - Integer, Intent(In)::Nonods, Totele, NLoc - Integer, Intent(In)::ENList(totele*nloc) - Integer, intent(In)::lgthNEList, NEList(lgthNElist), NEListBasePtr(Nonods+1) + !! This subroutine returns ordered list of elements connected to 'ele' + !! Zero entry indicates a free boundary, ie. on the surface - Integer, Intent(Out)::EEList(Totele*NLoc) + Implicit None - integer :: ele, ele2, node, i, j, EEMark - integer, dimension(nloc) :: ele_nodes, ele2_nodes - ! This is inefficient but it is assumed this will only be used for tests. - integer, dimension(:), allocatable :: node_eles + Integer, Intent(In)::Nonods, Totele, NLoc + Integer, Intent(In)::ENList(totele*nloc) + Integer, intent(In)::lgthNEList, NEList(lgthNElist), NEListBasePtr(Nonods+1) - EEList=0 + Integer, Intent(Out)::EEList(Totele*NLoc) - do ele=1,totele - ele_nodes=ENList((ele-1)*nloc+1:ele*nloc) + integer :: ele, ele2, node, i, j, EEMark + integer, dimension(nloc) :: ele_nodes, ele2_nodes + ! This is inefficient but it is assumed this will only be used for tests. + integer, dimension(:), allocatable :: node_eles - do i=1,size(ele_nodes) - node=ele_nodes(i) - allocate(node_eles(NEListBasePtr(node+1)-NEListBasePtr(node))) - node_eles=NEList(NEListBasePtr(node):NEListBasePtr(node+1)-1) + EEList=0 - do j=1, size(node_eles) - ele2=node_eles(j) - ele2_nodes=ENList((ele2-1)*nloc+1:ele2*nloc) + do ele=1,totele + ele_nodes=ENList((ele-1)*nloc+1:ele*nloc) - if (ele/=ele2) then - if (any(ele_nodes(1)==ele2_nodes)) then - EEMark=1 - else - EEMark=2 - end if - EEList((ele-1)*nloc+EEMark)=ele2 - end if + do i=1,size(ele_nodes) + node=ele_nodes(i) + allocate(node_eles(NEListBasePtr(node+1)-NEListBasePtr(node))) + node_eles=NEList(NEListBasePtr(node):NEListBasePtr(node+1)-1) - end do - deallocate(node_eles) - end do + do j=1, size(node_eles) + ele2=node_eles(j) + ele2_nodes=ENList((ele2-1)*nloc+1:ele2*nloc) - end do + if (ele/=ele2) then + if (any(ele_nodes(1)==ele2_nodes)) then + EEMark=1 + else + EEMark=2 + end if + EEList((ele-1)*nloc+EEMark)=ele2 + end if - end Subroutine MakeEEList1D - - ! **************************************************************** - - Subroutine LocalElementsNods(Nonods, NLoc, & - NEList, NEListBasePtr, lgthNEList, & - LocalNodes, & - biglgth, LocalElements, p) - - ! this subroutine gives list of all elements connected to the entries of LocalNodes + end do + deallocate(node_eles) + end do + end do - Implicit None + end Subroutine MakeEEList1D - Integer, intent(in)::Nonods, NLoc - Integer, Intent(In)::lgthNEList, NEListBasePtr(Nonods+1), NEList(lgthNEList) - Integer, INtent(In)::LocalNodes(NLoc) + ! **************************************************************** - Integer, Intent(In)::biglgth - Integer, Intent(Out)::p, LocalElements(biglgth) - Integer i, iLoc, iNod,ptr + Subroutine LocalElementsNods(Nonods, NLoc, & + NEList, NEListBasePtr, lgthNEList, & + LocalNodes, & + biglgth, LocalElements, p) - ! local... + ! this subroutine gives list of all elements connected to the entries of LocalNodes - Logical Inserted - ! Find elements each of these nodes is connected to, and search these eles only.. - ! Need to remove the duplications.. + Implicit None + Integer, intent(in)::Nonods, NLoc + Integer, Intent(In)::lgthNEList, NEListBasePtr(Nonods+1), NEList(lgthNEList) + Integer, INtent(In)::LocalNodes(NLoc) - p=0 + Integer, Intent(In)::biglgth + Integer, Intent(Out)::p, LocalElements(biglgth) + Integer i, iLoc, iNod,ptr - Do iLoc=1,NLoc - ! Loop over the local nodes.. + ! local... - iNod = LocalNodes(iLoc) + Logical Inserted - if(iNod.gt.Nonods) then - ewrite(3,*) 'Node out of range' - stop 886 - end if + ! Find elements each of these nodes is connected to, and search these eles only.. + ! Need to remove the duplications.. - Do ptr = NEListBasePtr(iNod), NEListBasePtr(iNod+1) - 1 + p=0 - If(p.eq.0) then - p = p+1 - LocalElements(p) = NEList(ptr) - Else + Do iLoc=1,NLoc + ! Loop over the local nodes.. - Inserted = .False. + iNod = LocalNodes(iLoc) - do i=1,p - if(LocalElements(i).eq.NEList(ptr)) then - inserted = .True. - end if - end do + if(iNod.gt.Nonods) then + ewrite(3,*) 'Node out of range' + stop 886 + end if - if(.not.Inserted) then - p = p+1 - if(p.gt.biglgth) then - ewrite(3,*) 'p out of bounds',p,biglgth - stop 887 - end if - LocalElements(p) = NEList(ptr) - End IF - End If - End Do - End Do - Return - end Subroutine LocalElementsNods + Do ptr = NEListBasePtr(iNod), NEListBasePtr(iNod+1) - 1 + + If(p.eq.0) then + p = p+1 + LocalElements(p) = NEList(ptr) + Else + + Inserted = .False. + + do i=1,p + if(LocalElements(i).eq.NEList(ptr)) then + inserted = .True. + end if + end do + + if(.not.Inserted) then + p = p+1 + if(p.gt.biglgth) then + ewrite(3,*) 'p out of bounds',p,biglgth + stop 887 + end if + LocalElements(p) = NEList(ptr) + End IF + End If + End Do + End Do + + Return + end Subroutine LocalElementsNods + + ! ********************************************************* + + Subroutine match_list(Totele, Nloc, & + D3, & + ndglno, & + OppNode, n, & + TestList, lgthTestList, & + Element, OtherNode) + + Implicit None + + Integer, Intent(in)::Totele, NLoc, ndglno(totele*nloc) + Logical, INtent(In)::D3 + Integer, Intent(In)::OppNode, n(NLoc-1) + Integer, Intent(In)::lgthTestList, TestList(lgthTestList) + Integer, Intent(Out)::Element, OtherNode + ! Local... + Integer ele, iptr + Integer i + Integer n1, n2, n3 + Logical FirstNode, SecondNode, ThirdNode, Matched + + Logical, Allocatable::UsedNodes(:) + Integer, Allocatable::m(:) + + Allocate(UsedNodes(Nloc)) + Allocate(m(Nloc)) + + If(D3) Then + n1 = n(1) + n2 = n(2) + n3 = n(3) + ! oppNode forms 4th (or 3rd in 2d) entry.. + Else + n1 = n(1) + n2 = n(2) + End if + + + Element = 0 + + do iptr=1,lgthTestList + ele = TestList(iptr) ! this is element to try... + + ! put nodes of element being tried in array.. + do i=1,NLoc + m(i) = ndglno((ele-1)*nloc+i) + UsedNodes(i) = .False. + end do - ! ********************************************************* + FirstNode = .False. + SecondNode = .False. + ThirdNode = .False. ! only use for 3d + Matched = .False. + ! match three of the nodes of element + + ! orders and sorting... complete match + + ! first node... + do i=1,NLoc + if (n1.eq.m(i)) then + ! ewrite(3,*) 'Match on first node:',i,n1,m(i) + UsedNodes(i) = .True. + FirstNode = .True. + exit + end if + end do - Subroutine match_list(Totele, Nloc, & - D3, & - ndglno, & - OppNode, n, & - TestList, lgthTestList, & - Element, OtherNode) + !if one node doesn't match then its not correct element.. - Implicit None + if(FirstNode) then ! now look for a second one... - Integer, Intent(in)::Totele, NLoc, ndglno(totele*nloc) - Logical, INtent(In)::D3 - Integer, Intent(In)::OppNode, n(NLoc-1) - Integer, Intent(In)::lgthTestList, TestList(lgthTestList) - Integer, Intent(Out)::Element, OtherNode - ! Local... - Integer ele, iptr - Integer i - Integer n1, n2, n3 - Logical FirstNode, SecondNode, ThirdNode, Matched + do i=1,Nloc + if ((n2.eq.m(i)).AND.(.not.UsedNodes(i))) then + UsedNodes(i) = .True. + SecondNode = .True. + exit + end if + end do - Logical, Allocatable::UsedNodes(:) - Integer, Allocatable::m(:) + end if - Allocate(UsedNodes(Nloc)) - Allocate(m(Nloc)) + ! if 3D then look for 2nd and 3rd Node, 2D just a second node.. - If(D3) Then - n1 = n(1) - n2 = n(2) - n3 = n(3) - ! oppNode forms 4th (or 3rd in 2d) entry.. - Else - n1 = n(1) - n2 = n(2) - End if + if(D3) Then + if(SecondNode) then ! now look for a second one..., only go in here is firstnode= T - Element = 0 + do i=1,NLoc + if ((n3.eq.m(i)).AND.(.not.UsedNodes(i))) then + UsedNodes(i) = .True. + ThirdNode = .True. + exit + end if + end do - do iptr=1,lgthTestList - ele = TestList(iptr) ! this is element to try... - - ! put nodes of element being tried in array.. - do i=1,NLoc - m(i) = ndglno((ele-1)*nloc+i) - UsedNodes(i) = .False. - end do + end if - FirstNode = .False. - SecondNode = .False. - ThirdNode = .False. ! only use for 3d - Matched = .False. - ! match three of the nodes of element + if(ThirdNode) then ! need choice of one node when reach this loop.. - ! orders and sorting... complete match - - ! first node... - do i=1,NLoc - if (n1.eq.m(i)) then - ! ewrite(3,*) 'Match on first node:',i,n1,m(i) - UsedNodes(i) = .True. - FirstNode = .True. - exit - end if - end do - - !if one node doesn't match then its not correct element.. - - if(FirstNode) then ! now look for a second one... - - do i=1,Nloc - if ((n2.eq.m(i)).AND.(.not.UsedNodes(i))) then - UsedNodes(i) = .True. - SecondNode = .True. - exit - end if - end do - - end if - - ! if 3D then look for 2nd and 3rd Node, 2D just a second node.. - - if(D3) Then - - if(SecondNode) then ! now look for a second one..., only go in here is firstnode= T - - do i=1,NLoc - if ((n3.eq.m(i)).AND.(.not.UsedNodes(i))) then - UsedNodes(i) = .True. - ThirdNode = .True. - exit - end if - end do - - end if - - if(ThirdNode) then ! need choice of one node when reach this loop.. - - do i=1,NLoc ! filter to find correct node.. - - if(.not.(UsedNodes(i))) then - - if (OppNode.eq.m(i)) then - ! all 4 nodes in.. found the element - ! ewrite(3,*) 'element - but original one:',l,ele - ! if equal then continue as in current element.. - Element = 0 - else - ! this is different so is the correct answer.. - ! ewrite(3,*) 'element - new:',l,ele - Element = ele - OtherNode = m(i) - Matched = .True. - exit ! does this work? - end if - end if - end do + do i=1,NLoc ! filter to find correct node.. - end if + if(.not.(UsedNodes(i))) then - Else + if (OppNode.eq.m(i)) then + ! all 4 nodes in.. found the element + ! ewrite(3,*) 'element - but original one:',l,ele + ! if equal then continue as in current element.. + Element = 0 + else + ! this is different so is the correct answer.. + ! ewrite(3,*) 'element - new:',l,ele + Element = ele + OtherNode = m(i) + Matched = .True. + exit ! does this work? + end if + end if + end do - if(SecondNode) then ! need choice of one node when reach this loop.. - - do i=1,NLoc ! filter to find correct node.. + end if - if(.not.(UsedNodes(i))) then - - if (OppNode.eq.m(i)) then - ! all 4 nodes in.. found the element - ! ewrite(3,*) 'element - but original one:',i,ele - ! if equal then continue as in current element.. - Element = 0 - else - ! this is different so is the correct answer.. - ! ewrite(3,*) 'element - new:',l,ele - Element = ele - OtherNode = m(i) - Matched = .True. - exit ! does this work? - end if - end if - end do - - end if + Else - End IF + if(SecondNode) then ! need choice of one node when reach this loop.. - ! ewrite(3,*) 'matched:',Matched - If(Matched) exit + do i=1,NLoc ! filter to find correct node.. - end do + if(.not.(UsedNodes(i))) then - ! ewrite(3,*) 'Final matched element:',ele + if (OppNode.eq.m(i)) then + ! all 4 nodes in.. found the element + ! ewrite(3,*) 'element - but original one:',i,ele + ! if equal then continue as in current element.. + Element = 0 + else + ! this is different so is the correct answer.. + ! ewrite(3,*) 'element - new:',l,ele + Element = ele + OtherNode = m(i) + Matched = .True. + exit ! does this work? + end if + end if + end do - !print *,'Nodes are n:',n1,n2,n3, OppNode ! these two lists should be different.. - !print *,'Nodes are m:',m - ! ewrite(3,*) 'OtherNode:',OtherNode - ! ewrite(3,*) '****************************************' + end if - Deallocate(UsedNodes, m) + End IF - return - End Subroutine match_list + ! ewrite(3,*) 'matched:',Matched + If(Matched) exit - ! *************************************************************** - subroutine MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList,& - & NNList, EEList) - ! Dynamic version of Makelists which returns csr_sparsitys as adjacency - ! graphs. This version of MakeLists only returns the arrays - ! you ask for. - ! - Integer, Intent(In)::nonods, Totele, NLoc - Integer, Intent(In)::NdGlNo(Totele*NLoc) - Logical, Intent(In)::D3 + end do - type(csr_sparsity), intent(out), optional :: NEList, NNList, EEList + ! ewrite(3,*) 'Final matched element:',ele - ! We need an NEList even if we're not making one. - type(csr_sparsity) :: lNEList - integer :: i - integer :: lgthNEList - Logical ISSUE + !print *,'Nodes are n:',n1,n2,n3, OppNode ! these two lists should be different.. + !print *,'Nodes are m:',m + ! ewrite(3,*) 'OtherNode:',OtherNode + ! ewrite(3,*) '****************************************' - ! Note that the NEList is needed to calculate EEList. - if (present(NEList).or.present(EEList)) then - - ! Form node to element list +++++++++++++++++++++ + Deallocate(UsedNodes, m) - ! Allocate provably enough space. - call allocate(lNEList, rows=nonods, columns=totele, & + return + End Subroutine match_list + + ! *************************************************************** + subroutine MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList,& + & NNList, EEList) + ! Dynamic version of Makelists which returns csr_sparsitys as adjacency + ! graphs. This version of MakeLists only returns the arrays + ! you ask for. + ! + Integer, Intent(In)::nonods, Totele, NLoc + Integer, Intent(In)::NdGlNo(Totele*NLoc) + Logical, Intent(In)::D3 + + type(csr_sparsity), intent(out), optional :: NEList, NNList, EEList + + ! We need an NEList even if we're not making one. + type(csr_sparsity) :: lNEList + integer :: i + integer :: lgthNEList + Logical ISSUE + + ! Note that the NEList is needed to calculate EEList. + if (present(NEList).or.present(EEList)) then + + ! Form node to element list +++++++++++++++++++++ + + ! Allocate provably enough space. + call allocate(lNEList, rows=nonods, columns=totele, & entries=totele*nloc, diag=.false., name='NEListSparsity') - CALL NODELE(NONODS,lNElist%findrm,lNEList%colm,& + CALL NODELE(NONODS,lNElist%findrm,lNEList%colm,& lgthNEList, totele*nloc,& TOTELE,NLOC,NDGLNO) - !ASSERT(lNEList%findrm(nonods+1)==lgthnelist+1) - end if + !ASSERT(lNEList%findrm(nonods+1)==lgthnelist+1) + end if - if (present(EEList)) then + if (present(EEList)) then - ! ++++++++++++++++++++++++++++++++++++++++++++ - ! Form E-E List - call allocate(EEList, rows=totele, columns=totele, & + ! ++++++++++++++++++++++++++++++++++++++++++++ + ! Form E-E List + call allocate(EEList, rows=totele, columns=totele, & entries=totele*nloc, diag=.false., name='EEListSparsity') - Call MakeEEList_old(Nonods,Totele,NLoc,& + Call MakeEEList_old(Nonods,Totele,NLoc,& D3, ndglno,& lNEList%colm, lgthNEList, lNEList%findrm, & EEList%colm) - forall (i=1:totele+1) - EEList%findrm(i)=nloc*(i-1)+1 - end forall + forall (i=1:totele+1) + EEList%findrm(i)=nloc*(i-1)+1 + end forall - end if + end if - ! Use or deallocate the temporary node:element list. - if (present(NEList)) then - NEList=lNEList - else if (present(EEList)) then - call deallocate(lNEList) - end if + ! Use or deallocate the temporary node:element list. + if (present(NEList)) then + NEList=lNEList + else if (present(EEList)) then + call deallocate(lNEList) + end if - if (present(NNList)) then + if (present(NNList)) then - ! +++++++++++++++++++++++++++++++++++++++++ - !Form NN List + ! +++++++++++++++++++++++++++++++++++++++++ + !Form NN List - ! This uses the dynamically allocated version from the sparse_tools - ! module instead if the partially static MakeNNList. - call POSINM(NNList, TOTELE, nonods, nloc, ndglno,& + ! This uses the dynamically allocated version from the sparse_tools + ! module instead if the partially static MakeNNList. + call POSINM(NNList, TOTELE, nonods, nloc, ndglno,& nonods, nloc, ndglno, diag=.false., name='NNListSparsity') - end if - - ! ++++++++++++++++++++++++++++++++++++++++++ - ! do some checking.. - - ISSUE = .false. - - if (present(NNList)) then - if(any(NNList%colm.gt.Nonods)) then - ewrite(3,*) 'problem with NNlist' - ISSUE = .true. - end if - end if - - if (present(NEList)) then - if (any(NEList%colm.gt.Totele)) then - ewrite(3,*) 'problem with NElist' - ISSUE = .true. - end if - end if - - if (present(EEList)) then - if(any(EEList%colm.gt.Totele)) then - ewrite(3,*) 'problem with EElist' - ISSUE = .true. - end if - end if - - if(ISSUE) then - stop 96788 - end if - - end subroutine MakeLists_Dynamic - - subroutine MakeLists_Mesh(mesh, NEList, NNList, EEList) - !!< Use the new mesh type. - type(mesh_type), intent(in) :: mesh - type(csr_sparsity), intent(out), optional :: NEList, NNList, EEList - - type(csr_sparsity) lNEList - integer :: nonods, totele, nloc - integer, dimension(:), pointer :: ndglno - logical :: d3 - - nonods = mesh%nodes - totele = mesh%elements - nloc = mesh%shape%loc - ndglno => mesh%ndglno - d3 = (mesh%shape%dim == 3) - - if (mesh%continuity < 0) then - ewrite(0,*) "Warning: asking for adjacency lists of discontinuous mesh" - if (present(EElist)) then - FLAbort("and you asked for the eelist.") end if - end if - if (present(NEList) .and. present(NNList) .and. present(EEList)) then - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=NEList,& - & NNList=NNList, EEList=EEList) - return - end if + ! ++++++++++++++++++++++++++++++++++++++++++ + ! do some checking.. - if (present(NEList) .and. present(NNList)) then - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=NEList,& - & NNList=NNList) - return - end if + ISSUE = .false. - if (present(EEList)) then - ! we need to also construct at least NEList if (present(NNList)) then - ! also construct NNList - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, & - & NNList=NNList, NEList=lNEList) - else - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=lNEList) + if(any(NNList%colm.gt.Nonods)) then + ewrite(3,*) 'problem with NNlist' + ISSUE = .true. + end if end if - ewrite(1,*) 'Using the new MakeEElist' - call MakeEEList(EEList, mesh, lNEList) + if (present(NEList)) then - NEList=lNEList - else - call deallocate(lNEList) + if (any(NEList%colm.gt.Totele)) then + ewrite(3,*) 'problem with NElist' + ISSUE = .true. + end if end if - return - end if - if (present(NEList)) then - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=NEList) - return - end if + if (present(EEList)) then + if(any(EEList%colm.gt.Totele)) then + ewrite(3,*) 'problem with EElist' + ISSUE = .true. + end if + end if - if (present(NNList)) then - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NNList=NNList) - return - end if + if(ISSUE) then + stop 96788 + end if - if (present(EEList)) then - call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, EEList=EEList) - return - end if + end subroutine MakeLists_Dynamic - end subroutine MakeLists_Mesh + subroutine MakeLists_Mesh(mesh, NEList, NNList, EEList) + !!< Use the new mesh type. + type(mesh_type), intent(in) :: mesh + type(csr_sparsity), intent(out), optional :: NEList, NNList, EEList - subroutine MakeEEList(EEList, mesh, NEList) - !!< For a given mesh and Node-Element list calculate the - !!< Element-Element list. + type(csr_sparsity) lNEList + integer :: nonods, totele, nloc + integer, dimension(:), pointer :: ndglno + logical :: d3 - type(csr_sparsity), intent(out):: EEList - type(mesh_type), intent(in):: mesh - type(csr_sparsity), intent(in):: NEList + nonods = mesh%nodes + totele = mesh%elements + nloc = mesh%shape%loc + ndglno => mesh%ndglno + d3 = (mesh%shape%dim == 3) - integer, dimension(:), pointer:: cols - integer adj_ele, ele, noboundaries, nloc, j + if (mesh%continuity < 0) then + ewrite(0,*) "Warning: asking for adjacency lists of discontinuous mesh" + if (present(EElist)) then + FLAbort("and you asked for the eelist.") + end if + end if + + if (present(NEList) .and. present(NNList) .and. present(EEList)) then + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=NEList,& + & NNList=NNList, EEList=EEList) + return + end if + + if (present(NEList) .and. present(NNList)) then + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=NEList,& + & NNList=NNList) + return + end if + + if (present(EEList)) then + ! we need to also construct at least NEList + if (present(NNList)) then + ! also construct NNList + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, & + & NNList=NNList, NEList=lNEList) + else + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=lNEList) + end if + ewrite(1,*) 'Using the new MakeEElist' + call MakeEEList(EEList, mesh, lNEList) + if (present(NEList)) then + NEList=lNEList + else + call deallocate(lNEList) + end if + return + end if + + if (present(NEList)) then + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NEList=NEList) + return + end if + + if (present(NNList)) then + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, NNList=NNList) + return + end if + + if (present(EEList)) then + call MakeLists_Dynamic(Nonods, Totele, Nloc, NDGLNO, D3, EEList=EEList) + return + end if + + end subroutine MakeLists_Mesh + + subroutine MakeEEList(EEList, mesh, NEList) + !!< For a given mesh and Node-Element list calculate the + !!< Element-Element list. + + type(csr_sparsity), intent(out):: EEList + type(mesh_type), intent(in):: mesh + type(csr_sparsity), intent(in):: NEList + + integer, dimension(:), pointer:: cols + integer adj_ele, ele, noboundaries, nloc, j #ifdef DDEBUG - integer, dimension(:), allocatable :: debug_common_elements - integer :: no_found + integer, dimension(:), allocatable :: debug_common_elements + integer :: no_found #endif - ! Number of element boundaries. - noboundaries=mesh%shape%numbering%boundaries - if (mesh%elements<=0) then - call allocate(EEList, rows=0, columns=0, entries=0, name='EEListSparsity') - return - end if - nloc=size(mesh%ndglno)/mesh%elements + ! Number of element boundaries. + noboundaries=mesh%shape%numbering%boundaries + if (mesh%elements<=0) then + call allocate(EEList, rows=0, columns=0, entries=0, name='EEListSparsity') + return + end if + nloc=size(mesh%ndglno)/mesh%elements - call allocate(EEList, rows=mesh%elements, columns=mesh%elements, & + call allocate(EEList, rows=mesh%elements, columns=mesh%elements, & entries=mesh%elements*noboundaries, name='EEListSparsity') - EEList%findrm=(/ (1+ele*noboundaries, ele=0, mesh%elements) /) + EEList%findrm=(/ (1+ele*noboundaries, ele=0, mesh%elements) /) - do ele=1, mesh%elements - cols => row_m_ptr(EEList, ele) - assert(size(cols) == noboundaries) - do j=1, noboundaries - ! fill in element on the other side of face j: - call find_adjacent_element(ele, adj_ele, NEList, & + do ele=1, mesh%elements + cols => row_m_ptr(EEList, ele) + assert(size(cols) == noboundaries) + do j=1, noboundaries + ! fill in element on the other side of face j: + call find_adjacent_element(ele, adj_ele, NEList, & nodes=mesh%ndglno((ele-1)*nloc+ & boundary_numbering(mesh%shape%numbering, j) & ) ) #ifdef DDEBUG - if(adj_ele >= 0) then + if(adj_ele >= 0) then #endif - ! Found an adjacent element, or no adjacent elements (a boundary) - cols(j) = adj_ele + ! Found an adjacent element, or no adjacent elements (a boundary) + cols(j) = adj_ele #ifdef DDEBUG - else - ! Encountered an error - ewrite(-1, *) "For element ", ele, " with boundary ", mesh%ndglno((ele - 1) * nloc + & + else + ! Encountered an error + ewrite(-1, *) "For element ", ele, " with boundary ", mesh%ndglno((ele - 1) * nloc + & & boundary_numbering(mesh%shape%numbering, j)) - allocate(debug_common_elements(0)) - call findcommonelements(debug_common_elements, no_found, nelist, & + allocate(debug_common_elements(0)) + call findcommonelements(debug_common_elements, no_found, nelist, & & nodes = mesh%ndglno((ele - 1) * nloc + & & boundary_numbering(mesh%shape%numbering, j) & & )) - ewrite(-1, *) "Number of common elements: ", no_found - deallocate(debug_common_elements) - allocate(debug_common_elements(no_found)) - call findcommonelements(debug_common_elements, no_found, nelist, & + ewrite(-1, *) "Number of common elements: ", no_found + deallocate(debug_common_elements) + allocate(debug_common_elements(no_found)) + call findcommonelements(debug_common_elements, no_found, nelist, & & nodes = mesh%ndglno((ele - 1) * nloc + & & boundary_numbering(mesh%shape%numbering, j) & & )) - ewrite(-1, *) "Common elements: ", debug_common_elements - deallocate(debug_common_elements) - FLExit("Invalid NEList! Something wrong with the mesh?") - end if + ewrite(-1, *) "Common elements: ", debug_common_elements + deallocate(debug_common_elements) + FLExit("Invalid NEList! Something wrong with the mesh?") + end if #endif - end do - - end do - - contains - - subroutine find_adjacent_element(ele, adj_ele, nelist, nodes) - !!< Using nelist find an element adjacent to ele with boundary nodes - !!< nodes. Returns negative adj_ele on error. Error checking requires a - !!< debugging build. - - !! The element for which we are seeking a neighbour - integer, intent(in) :: ele - !! The neighbour found - integer, intent(out) :: adj_ele - !! Node-Element list - type(csr_sparsity), intent(in) :: nelist - !! Boundary nodes on element ele - integer, dimension(:), intent(in) :: nodes - - integer, dimension(:), pointer :: elements1 - integer :: i, j, candidate_ele - - ! Use an uninitialised integer_vector type, as the null initialisations - ! have a cost and are not required here - type uninit_integer_vector - integer, dimension(:), pointer :: ptr - end type uninit_integer_vector - type(uninit_integer_vector), dimension(size(nodes) - 1) :: row_idx - - ! All elements connected to node nodes(1). One of these will be ele, and - ! (if the boundary nodes are not on the domain boundary) one will be the - ! adjacent element. - elements1 => row_m_ptr(nelist, nodes(1)) - ! Cache the elements connected to nodes(2:). ele and (if the boundary - ! nodes are not on the domain boundary) the adjacent element will appear - ! in all of these. - do i = 2, size(nodes) - row_idx(i - 1)%ptr => row_m_ptr(nelist, nodes(i)) + end do + end do - adj_ele = 0 - ele_loop: do i = 1, size(elements1) - candidate_ele = elements1(i) - if(candidate_ele == ele) cycle ele_loop ! Ignore the query element - ! See if this element borders all other nodes - do j = 2, size(nodes) - ! If candidate_ele is not in all row_idx, nodes are not boundary - ! nodes for candidate_ele, and it isn't the adjacent element. - if(.not. any(row_idx(j - 1)%ptr == candidate_ele)) cycle ele_loop + contains + + subroutine find_adjacent_element(ele, adj_ele, nelist, nodes) + !!< Using nelist find an element adjacent to ele with boundary nodes + !!< nodes. Returns negative adj_ele on error. Error checking requires a + !!< debugging build. + + !! The element for which we are seeking a neighbour + integer, intent(in) :: ele + !! The neighbour found + integer, intent(out) :: adj_ele + !! Node-Element list + type(csr_sparsity), intent(in) :: nelist + !! Boundary nodes on element ele + integer, dimension(:), intent(in) :: nodes + + integer, dimension(:), pointer :: elements1 + integer :: i, j, candidate_ele + + ! Use an uninitialised integer_vector type, as the null initialisations + ! have a cost and are not required here + type uninit_integer_vector + integer, dimension(:), pointer :: ptr + end type uninit_integer_vector + type(uninit_integer_vector), dimension(size(nodes) - 1) :: row_idx + + ! All elements connected to node nodes(1). One of these will be ele, and + ! (if the boundary nodes are not on the domain boundary) one will be the + ! adjacent element. + elements1 => row_m_ptr(nelist, nodes(1)) + ! Cache the elements connected to nodes(2:). ele and (if the boundary + ! nodes are not on the domain boundary) the adjacent element will appear + ! in all of these. + do i = 2, size(nodes) + row_idx(i - 1)%ptr => row_m_ptr(nelist, nodes(i)) end do + adj_ele = 0 + ele_loop: do i = 1, size(elements1) + candidate_ele = elements1(i) + if(candidate_ele == ele) cycle ele_loop ! Ignore the query element + ! See if this element borders all other nodes + do j = 2, size(nodes) + ! If candidate_ele is not in all row_idx, nodes are not boundary + ! nodes for candidate_ele, and it isn't the adjacent element. + if(.not. any(row_idx(j - 1)%ptr == candidate_ele)) cycle ele_loop + end do + #ifdef DDEBUG - if(adj_ele > 0) then - ! We've found more than one adjacent element. We're in trouble. - adj_ele = -1 - return - end if + if(adj_ele > 0) then + ! We've found more than one adjacent element. We're in trouble. + adj_ele = -1 + return + end if #endif - adj_ele = candidate_ele + adj_ele = candidate_ele #ifndef DDEBUG - ! We've found the adjacent element. We're done. - return + ! We've found the adjacent element. We're done. + return #endif - end do ele_loop + end do ele_loop - end subroutine find_adjacent_element + end subroutine find_adjacent_element - end subroutine MakeEEList + end subroutine MakeEEList - subroutine FindCommonElements(elements, n, NEList, nodes) - !!< Using NEList find the elements that border all given nodes - !! The elements found, and their number n: - integer, dimension(:), intent(out):: elements - !! NOTE: The caller of this routine *has to* - !! check that the returned number of elements n <= size(elements) - !! As I can't give a useful error message here - !! about what (presumably) is wrong with the mesh - integer, intent(out):: n - !! Node-Element list: - type(csr_sparsity), intent(in):: NEList - !! The 'given' nodes: - integer, dimension(:), intent(in):: nodes + subroutine FindCommonElements(elements, n, NEList, nodes) + !!< Using NEList find the elements that border all given nodes + !! The elements found, and their number n: + integer, dimension(:), intent(out):: elements + !! NOTE: The caller of this routine *has to* + !! check that the returned number of elements n <= size(elements) + !! As I can't give a useful error message here + !! about what (presumably) is wrong with the mesh + integer, intent(out):: n + !! Node-Element list: + type(csr_sparsity), intent(in):: NEList + !! The 'given' nodes: + integer, dimension(:), intent(in):: nodes - integer, dimension(:), pointer:: elements1 - integer i, j, ele + integer, dimension(:), pointer:: elements1 + integer i, j, ele - type(integer_vector), dimension(size(nodes)-1) :: row_idx + type(integer_vector), dimension(size(nodes)-1) :: row_idx - ! we'll loop over all elements bordering nodes(1) - elements1 => row_m_ptr( NEList, nodes(1) ) + ! we'll loop over all elements bordering nodes(1) + elements1 => row_m_ptr( NEList, nodes(1) ) - do j=2,size(nodes) - row_idx(j-1)%ptr => row_m_ptr(NEList, nodes(j)) - end do + do j=2,size(nodes) + row_idx(j-1)%ptr => row_m_ptr(NEList, nodes(j)) + end do - n=0 - ele_loop: do i=1, size(elements1) - ele=elements1(i) - ! see if this element borders all other nodes - do j=2, size(nodes) - if (.not. any( row_idx(j-1)%ptr==ele )) cycle ele_loop - end do + n=0 + ele_loop: do i=1, size(elements1) + ele=elements1(i) + ! see if this element borders all other nodes + do j=2, size(nodes) + if (.not. any( row_idx(j-1)%ptr==ele )) cycle ele_loop + end do - ! if so we have found a common element - n=n+1 - if (n<=size(elements)) elements(n)=ele + ! if so we have found a common element + n=n+1 + if (n<=size(elements)) elements(n)=ele - end do ele_loop + end do ele_loop - end subroutine FindCommonElements + end subroutine FindCommonElements end module adjacency_lists diff --git a/femtools/AuxilaryOptions.F90 b/femtools/AuxilaryOptions.F90 index b4b3c2a730..b739b98658 100644 --- a/femtools/AuxilaryOptions.F90 +++ b/femtools/AuxilaryOptions.F90 @@ -29,74 +29,74 @@ module AuxilaryOptions contains - SUBROUTINE HAVE_FS_TIDAL_OPTIONS(GOT_TIDAL) - use FLDebug - IMPLICIT NONE - LOGICAL GOT_TIDAL + SUBROUTINE HAVE_FS_TIDAL_OPTIONS(GOT_TIDAL) + use FLDebug + IMPLICIT NONE + LOGICAL GOT_TIDAL - CHARACTER*4096 data_file + CHARACTER*4096 data_file - data_file = ' ' - data_file(1:19) = 'FSoptions.dat' + data_file = ' ' + data_file(1:19) = 'FSoptions.dat' - INQUIRE(file=data_file,exist=GOT_TIDAL) + INQUIRE(file=data_file,exist=GOT_TIDAL) - IF(GOT_TIDAL) then - ewrite(3,*) 'Found a TIDAL option file - MDP',GOT_TIDAL - else - ewrite(3,*) 'Did not find a TIDAL option file - MDP',GOT_TIDAL - end if - return - end SUBROUTINE HAVE_FS_TIDAL_OPTIONS + IF(GOT_TIDAL) then + ewrite(3,*) 'Found a TIDAL option file - MDP',GOT_TIDAL + else + ewrite(3,*) 'Did not find a TIDAL option file - MDP',GOT_TIDAL + end if + return + end SUBROUTINE HAVE_FS_TIDAL_OPTIONS - ! DECIDES WHETHER TO APPLY SURFACE HEAT FLUXES, AND READS IN - ! SOME CONTROLLING PARAMETERS - SUBROUTINE HAVE_FS_EQTIDAL_OPTIONS(GOT_EQUIL_TIDE,WHICH_TIDE,prime_meridian,YOUR_SCFACTH0) - use FLDebug - IMPLICIT NONE - LOGICAL GOT_EQUIL_TIDE - INTEGER WHICH_TIDE(12) - REAL prime_meridian, YOUR_SCFACTH0 - CHARACTER*4096 data_file + ! DECIDES WHETHER TO APPLY SURFACE HEAT FLUXES, AND READS IN + ! SOME CONTROLLING PARAMETERS + SUBROUTINE HAVE_FS_EQTIDAL_OPTIONS(GOT_EQUIL_TIDE,WHICH_TIDE,prime_meridian,YOUR_SCFACTH0) + use FLDebug + IMPLICIT NONE + LOGICAL GOT_EQUIL_TIDE + INTEGER WHICH_TIDE(12) + REAL prime_meridian, YOUR_SCFACTH0 + CHARACTER*4096 data_file - data_file = ' ' - data_file(1:19) = 'EQTDop.dat' + data_file = ' ' + data_file(1:19) = 'EQTDop.dat' - INQUIRE(file=data_file,exist=GOT_EQUIL_TIDE) - WHICH_TIDE(1:12) = 0 - IF(GOT_EQUIL_TIDE) then - ewrite(3,*) 'Found an equilibrium TIDAL option file - MDP',GOT_EQUIL_TIDE -998 FORMAT(I9) -999 FORMAT(1E15.7) - data_file = ' ' - data_file(1:13) = 'EQTDop.dat' + INQUIRE(file=data_file,exist=GOT_EQUIL_TIDE) + WHICH_TIDE(1:12) = 0 + IF(GOT_EQUIL_TIDE) then + ewrite(3,*) 'Found an equilibrium TIDAL option file - MDP',GOT_EQUIL_TIDE +998 FORMAT(I9) +999 FORMAT(1E15.7) + data_file = ' ' + data_file(1:13) = 'EQTDop.dat' - OPEN(556,status='unknown',file=data_file) - READ(556,998) WHICH_TIDE(1) - READ(556,998) WHICH_TIDE(2) - READ(556,998) WHICH_TIDE(3) - READ(556,998) WHICH_TIDE(4) - READ(556,998) WHICH_TIDE(5) - READ(556,998) WHICH_TIDE(6) - READ(556,998) WHICH_TIDE(7) - READ(556,998) WHICH_TIDE(8) - READ(556,998) WHICH_TIDE(9) - READ(556,998) WHICH_TIDE(10) - READ(556,998) WHICH_TIDE(11) - READ(556,998) WHICH_TIDE(12) - READ(556,999) prime_meridian - READ(556,999) YOUR_SCFACTH0 - CLOSE(556) - ewrite(3,*) 'WHICH_TIDE=',WHICH_TIDE - ewrite(3,*) 'prime_meridian = ',prime_meridian - ewrite(3,*) 'YOUR_SCFACTH0=',YOUR_SCFACTH0 - CLOSE(556) - ELSE - ewrite(3,*) 'Did not find an equilibrium TIDAL option file - MDP',GOT_EQUIL_TIDE - prime_meridian = 0.0 - YOUR_SCFACTH0 = 1.0 - ENDIF - RETURN - END SUBROUTINE HAVE_FS_EQTIDAL_OPTIONS + OPEN(556,status='unknown',file=data_file) + READ(556,998) WHICH_TIDE(1) + READ(556,998) WHICH_TIDE(2) + READ(556,998) WHICH_TIDE(3) + READ(556,998) WHICH_TIDE(4) + READ(556,998) WHICH_TIDE(5) + READ(556,998) WHICH_TIDE(6) + READ(556,998) WHICH_TIDE(7) + READ(556,998) WHICH_TIDE(8) + READ(556,998) WHICH_TIDE(9) + READ(556,998) WHICH_TIDE(10) + READ(556,998) WHICH_TIDE(11) + READ(556,998) WHICH_TIDE(12) + READ(556,999) prime_meridian + READ(556,999) YOUR_SCFACTH0 + CLOSE(556) + ewrite(3,*) 'WHICH_TIDE=',WHICH_TIDE + ewrite(3,*) 'prime_meridian = ',prime_meridian + ewrite(3,*) 'YOUR_SCFACTH0=',YOUR_SCFACTH0 + CLOSE(556) + ELSE + ewrite(3,*) 'Did not find an equilibrium TIDAL option file - MDP',GOT_EQUIL_TIDE + prime_meridian = 0.0 + YOUR_SCFACTH0 = 1.0 + ENDIF + RETURN + END SUBROUTINE HAVE_FS_EQTIDAL_OPTIONS end module AuxilaryOptions diff --git a/femtools/Bound_field.F90 b/femtools/Bound_field.F90 index cb9272dd73..0bd5a99ec2 100644 --- a/femtools/Bound_field.F90 +++ b/femtools/Bound_field.F90 @@ -29,339 +29,339 @@ module bound_field_module - use FLDebug - use spud - use global_parameters, only : FIELD_NAME_LEN - use quicksort - use parallel_tools - use sparse_tools - use transform_elements - use fetools - use parallel_fields - use fields - use field_options - use sparse_matrices_fields - use sparsity_patterns - use halos - implicit none - - integer, parameter, public :: FUNCTIONAL_VEC_L2=0, & - FUNCTIONAL_LUMPED_VEC_L2=1, & - FUNCTIONAL_FUNC_L2=2 - - private - - public :: bound_field, bound_field_diffuse - - contains - - subroutine bound_field(field, max_bound, min_bound, & - mass, lumpedmass, inverse_lumpedmass, & - bounded_soln, positions) - - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: max_bound, min_bound - type(csr_matrix), intent(in) :: mass - type(scalar_field), intent(inout) :: lumpedmass - type(scalar_field), intent(in) :: inverse_lumpedmass, bounded_soln - type(vector_field), intent(in) :: positions - - character(len=FIELD_NAME_LEN) :: algorithm_type - integer :: statp - - call get_option(trim(complete_field_path(field%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/name", & - algorithm_type, default="Diffuse") - ! have to give it a default as this is unit tested - - select case(algorithm_type) - case("Diffuse") - call bound_field_diffuse(field, max_bound, min_bound, & - mass, lumpedmass, inverse_lumpedmass) - case default - FLAbort("Unknown bounding algorithm selected") - end select - - end subroutine bound_field - - subroutine bound_field_diffuse(field, max_bound, min_bound, & - mass, lumpedmass, inverse_lumpedmass) - - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: max_bound, min_bound - type(csr_matrix), intent(in) :: mass - type(scalar_field), intent(in) :: lumpedmass, inverse_lumpedmass - - integer :: j, k, iters, node, statp - real :: bound_tol, repair_tol - real :: field_node_val, max_bound_node_val, min_bound_node_val - real :: lumpedmass_node_val, lump_ratio, target_change - integer :: target_node - type(scalar_field) :: deviation, diffused, increase_capacity, decrease_capacity - integer, dimension(:), allocatable :: increase_capacity_idx, decrease_capacity_idx, & - deviation_idx - real :: maxdeviation, mindeviation - real :: local_decrease_cap, local_increase_cap, local_deviation - real :: total_decrease_cap, total_increase_cap, total_deviation - - ewrite(1,*) 'In bound_field_diffuse' - - call allocate(deviation, field%mesh, "BoundedDeviation") - call allocate(diffused, field%mesh, "DiffusedDeviation") - - call get_option(trim(complete_field_path(field%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/boundedness_iterations", & - & iters, default=1000) - - call get_option(trim(complete_field_path(field%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/boundedness_iterations/tolerance", & - & bound_tol, default=epsilon(0.0)) - - ! Iterate! - iterloop: do k=1,iters - - ! Step 1. Compute deviation - call zero(deviation) - do node=1,node_count(field) - field_node_val = node_val(field, node) - max_bound_node_val = node_val(max_bound, node) - min_bound_node_val = node_val(min_bound, node) - if (field_node_val > max_bound_node_val) then - call set(deviation, node, field_node_val - max_bound_node_val) - else if (field_node_val < min_bound_node_val) then - call set(deviation, node, field_node_val - min_bound_node_val) - end if - end do - - maxdeviation = maxval(deviation) - call allmax(maxdeviation) - mindeviation = minval(deviation) - call allmin(mindeviation) - - if (maxdeviation < bound_tol .and. mindeviation > -bound_tol) then - exit iterloop - end if - - ! Step 2. Diffuse! - call mult(diffused, mass, deviation) - call scale(diffused, inverse_lumpedmass) - - ! Step 3. Update! - call addto(diffused, deviation, -1.0) - call addto(field, diffused, 2.0) - - call halo_update(field, 1, verbose=.false.) - end do iterloop - - ewrite(2,*) "Bounded interpolation for field ", trim(field%name), " took ", k, " iterations" - ewrite(2,*) "Before final diffusion:" - ewrite(2,*) "maxval(deviation): ", maxval(deviation), "; minval(deviation): ", minval(deviation) - - if(have_option(trim(complete_field_path(field%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/repair_deviations")) then + use FLDebug + use spud + use global_parameters, only : FIELD_NAME_LEN + use quicksort + use parallel_tools + use sparse_tools + use transform_elements + use fetools + use parallel_fields + use fields + use field_options + use sparse_matrices_fields + use sparsity_patterns + use halos + implicit none + + integer, parameter, public :: FUNCTIONAL_VEC_L2=0, & + FUNCTIONAL_LUMPED_VEC_L2=1, & + FUNCTIONAL_FUNC_L2=2 + + private + + public :: bound_field, bound_field_diffuse + +contains + + subroutine bound_field(field, max_bound, min_bound, & + mass, lumpedmass, inverse_lumpedmass, & + bounded_soln, positions) + + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: max_bound, min_bound + type(csr_matrix), intent(in) :: mass + type(scalar_field), intent(inout) :: lumpedmass + type(scalar_field), intent(in) :: inverse_lumpedmass, bounded_soln + type(vector_field), intent(in) :: positions + + character(len=FIELD_NAME_LEN) :: algorithm_type + integer :: statp call get_option(trim(complete_field_path(field%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/repair_deviations/tolerance", & - & repair_tol, default=epsilon(0.0)) - - ! If we reached the maximum number of iterations or we still have deviations, then the time has come - ! to perform surgery. We shuffle the remaining deviation (hopefully small!) - ! around without regard to physical locality. Hopefully the user has - ! specified enough iterations so that this is 1e-10 range .. - if ((k>iters) .or. (maxdeviation > repair_tol) .or. (mindeviation < -repair_tol)) then - ! Here, increase_capacity is the capacity to absorb increases, - ! and decrease_capacity is the capacity to absorb decreases. - ewrite(2,*) 'Repairing deviations' - - call allocate(increase_capacity, field%mesh, "IncreaseAbsorptionCapacity") - call allocate(decrease_capacity, field%mesh, "DecreaseAbsorptionCapacity") - allocate(increase_capacity_idx(node_count(field))) - allocate(decrease_capacity_idx(node_count(field))) - allocate(deviation_idx(node_count(field))) - - call zero(deviation) - call zero(increase_capacity) - call zero(decrease_capacity) - do node=1,node_count(field) - if(.not.node_owned(field,node)) cycle - field_node_val = node_val(field, node) - max_bound_node_val = node_val(max_bound, node) - min_bound_node_val = node_val(min_bound, node) - if (field_node_val > max_bound_node_val) then - call set(deviation, node, field_node_val - max_bound_node_val) - ! here we intentionally ignore the full decrease_capacity of this node - ! (which would be = -min_bound_node_val + field_node_val) in order - ! to get the sharpest interpolation possible... i.e. overshoots are only - ! taken down to the max_bound rather than allowing their full capacity down - ! to the min_bound to be used (this could lead to a solution that's more diffuse - ! than the lumped bounded solution) - call set(decrease_capacity, node, field_node_val - max_bound_node_val) - else if (field_node_val < min_bound_node_val) then - call set(deviation, node, field_node_val - min_bound_node_val) - ! here we intentionally ignore the full increase_capacity of this node - ! (which would be = max_bound_node_val - field_node_val) in order - ! to get the sharpest interpolation possible... i.e. overshoots are only - ! taken down to the max_bound rather than allowing their full capacity down - ! to the min_bound to be used (this could lead to a solution that's more diffuse - ! than the lumped bounded solution) - call set(increase_capacity, node, -(field_node_val - min_bound_node_val)) - else - call set(increase_capacity, node, max_bound_node_val - field_node_val) - call set(decrease_capacity, node,-min_bound_node_val + field_node_val) - end if - end do - -#ifdef DDEBUG - local_increase_cap = sum(increase_capacity%val*lumpedmass%val) - local_decrease_cap = sum(decrease_capacity%val*lumpedmass%val) - local_deviation = sum(abs(deviation%val)*lumpedmass%val) - ewrite(2,*) 'local_deviation = ', local_deviation - ewrite(2,*) 'local_decrease_cap+local_increase_cap = ', local_decrease_cap+local_increase_cap - - if(isparallel()) then - total_increase_cap = local_increase_cap - call allsum(total_increase_cap) - total_decrease_cap = local_decrease_cap - call allsum(total_decrease_cap) - total_deviation = local_deviation - call allsum(total_deviation) - - ewrite(2,*) 'total_deviation = ', total_deviation - ewrite(2,*) 'total_decrease_cap+total_increase_cap = ', total_decrease_cap+total_increase_cap - end if - - if(local_deviation>local_decrease_cap+local_increase_cap) then - ewrite(0,*) 'local_deviation = ', local_deviation - ewrite(0,*) 'local_decrease_cap+local_increase_cap = ', local_decrease_cap+local_increase_cap - - if(isparallel()) then - ewrite(0,*) 'total_deviation = ', total_deviation - ewrite(0,*) 'total_decrease_cap+total_increase_cap = ', total_decrease_cap+total_increase_cap - - if(total_deviation<=total_increase_cap+total_decrease_cap) then - ewrite(0,*) 'Enough capacity globally... should parallelise the repairing of deviations' - else - ewrite(0,*) 'Not enough capacity globally either... oh dear.' - end if - end if + & "/galerkin_projection/continuous/bounded[0]/name", & + algorithm_type, default="Diffuse") + ! have to give it a default as this is unit tested + + select case(algorithm_type) + case("Diffuse") + call bound_field_diffuse(field, max_bound, min_bound, & + mass, lumpedmass, inverse_lumpedmass) + case default + FLAbort("Unknown bounding algorithm selected") + end select + + end subroutine bound_field + + subroutine bound_field_diffuse(field, max_bound, min_bound, & + mass, lumpedmass, inverse_lumpedmass) + + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: max_bound, min_bound + type(csr_matrix), intent(in) :: mass + type(scalar_field), intent(in) :: lumpedmass, inverse_lumpedmass + + integer :: j, k, iters, node, statp + real :: bound_tol, repair_tol + real :: field_node_val, max_bound_node_val, min_bound_node_val + real :: lumpedmass_node_val, lump_ratio, target_change + integer :: target_node + type(scalar_field) :: deviation, diffused, increase_capacity, decrease_capacity + integer, dimension(:), allocatable :: increase_capacity_idx, decrease_capacity_idx, & + deviation_idx + real :: maxdeviation, mindeviation + real :: local_decrease_cap, local_increase_cap, local_deviation + real :: total_decrease_cap, total_increase_cap, total_deviation + + ewrite(1,*) 'In bound_field_diffuse' + + call allocate(deviation, field%mesh, "BoundedDeviation") + call allocate(diffused, field%mesh, "DiffusedDeviation") - ewrite(0,*) "Warning: insufficient capacity to repair deviations. Will try my best." - end if -#endif + call get_option(trim(complete_field_path(field%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/boundedness_iterations", & + & iters, default=1000) - ! sort into increasing order - call qsort(increase_capacity%val, increase_capacity_idx) - call qsort(decrease_capacity%val, decrease_capacity_idx) - call qsort(abs(deviation%val), deviation_idx) - - ! Now we can distribute stuff around. - - ! starting with the largest deviation - deviation_loop: do j=node_count(field),1,-1 - node = deviation_idx(j) - if(.not.node_owned(field, node)) cycle - lumpedmass_node_val = node_val(lumpedmass, node) - k = node_count(field)+1 - do while((node_val(deviation, node) > repair_tol).and.& - (k>1)) - k = k - 1 - ! Choose the node with the largest capacity - ! (at least at the start since we don't reorder once we get going)... - target_node = increase_capacity_idx(k) - if(.not.node_owned(field,target_node)) cycle - if(node_val(increase_capacity, target_node) max_bound_node_val) then - call set(deviation, target_node, field_node_val - max_bound_node_val) - call set(increase_capacity, target_node, 0.0) - ! see note above about setting of the decrease_capacity - call set(decrease_capacity, node, field_node_val - max_bound_node_val) + call set(deviation, node, field_node_val - max_bound_node_val) else if (field_node_val < min_bound_node_val) then - call set(deviation, target_node, field_node_val - min_bound_node_val) - ! see note above about setting of the increase_capacity - call set(increase_capacity, node, -(field_node_val - min_bound_node_val)) - call set(decrease_capacity, target_node, 0.0) - else - call set(deviation, target_node, 0.0) - call set(increase_capacity, target_node, max_bound_node_val - field_node_val) - call set(decrease_capacity, target_node,-min_bound_node_val + field_node_val) + call set(deviation, node, field_node_val - min_bound_node_val) end if - end do + end do + + maxdeviation = maxval(deviation) + call allmax(maxdeviation) + mindeviation = minval(deviation) + call allmin(mindeviation) + + if (maxdeviation < bound_tol .and. mindeviation > -bound_tol) then + exit iterloop + end if + + ! Step 2. Diffuse! + call mult(diffused, mass, deviation) + call scale(diffused, inverse_lumpedmass) + + ! Step 3. Update! + call addto(diffused, deviation, -1.0) + call addto(field, diffused, 2.0) + + call halo_update(field, 1, verbose=.false.) + end do iterloop + + ewrite(2,*) "Bounded interpolation for field ", trim(field%name), " took ", k, " iterations" + ewrite(2,*) "Before final diffusion:" + ewrite(2,*) "maxval(deviation): ", maxval(deviation), "; minval(deviation): ", minval(deviation) + + if(have_option(trim(complete_field_path(field%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/repair_deviations")) then + + call get_option(trim(complete_field_path(field%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/repair_deviations/tolerance", & + & repair_tol, default=epsilon(0.0)) + + ! If we reached the maximum number of iterations or we still have deviations, then the time has come + ! to perform surgery. We shuffle the remaining deviation (hopefully small!) + ! around without regard to physical locality. Hopefully the user has + ! specified enough iterations so that this is 1e-10 range .. + if ((k>iters) .or. (maxdeviation > repair_tol) .or. (mindeviation < -repair_tol)) then + ! Here, increase_capacity is the capacity to absorb increases, + ! and decrease_capacity is the capacity to absorb decreases. + ewrite(2,*) 'Repairing deviations' + + call allocate(increase_capacity, field%mesh, "IncreaseAbsorptionCapacity") + call allocate(decrease_capacity, field%mesh, "DecreaseAbsorptionCapacity") + allocate(increase_capacity_idx(node_count(field))) + allocate(decrease_capacity_idx(node_count(field))) + allocate(deviation_idx(node_count(field))) + + call zero(deviation) + call zero(increase_capacity) + call zero(decrease_capacity) + do node=1,node_count(field) + if(.not.node_owned(field,node)) cycle + field_node_val = node_val(field, node) + max_bound_node_val = node_val(max_bound, node) + min_bound_node_val = node_val(min_bound, node) + if (field_node_val > max_bound_node_val) then + call set(deviation, node, field_node_val - max_bound_node_val) + ! here we intentionally ignore the full decrease_capacity of this node + ! (which would be = -min_bound_node_val + field_node_val) in order + ! to get the sharpest interpolation possible... i.e. overshoots are only + ! taken down to the max_bound rather than allowing their full capacity down + ! to the min_bound to be used (this could lead to a solution that's more diffuse + ! than the lumped bounded solution) + call set(decrease_capacity, node, field_node_val - max_bound_node_val) + else if (field_node_val < min_bound_node_val) then + call set(deviation, node, field_node_val - min_bound_node_val) + ! here we intentionally ignore the full increase_capacity of this node + ! (which would be = max_bound_node_val - field_node_val) in order + ! to get the sharpest interpolation possible... i.e. overshoots are only + ! taken down to the max_bound rather than allowing their full capacity down + ! to the min_bound to be used (this could lead to a solution that's more diffuse + ! than the lumped bounded solution) + call set(increase_capacity, node, -(field_node_val - min_bound_node_val)) + else + call set(increase_capacity, node, max_bound_node_val - field_node_val) + call set(decrease_capacity, node,-min_bound_node_val + field_node_val) + end if + end do - k = node_count(field) - do while((node_val(deviation, node) < -repair_tol).and.& - (k>1)) - k = k - 1 - target_node = decrease_capacity_idx(k) - if(.not.node_owned(field, target_node)) cycle - if(node_val(decrease_capacity, target_node) max_bound_node_val) then - call set(deviation, target_node, field_node_val - max_bound_node_val) - call set(increase_capacity, target_node, 0.0) - ! see note above about setting of the decrease_capacity - call set(decrease_capacity, node, field_node_val - max_bound_node_val) - else if (field_node_val < min_bound_node_val) then - call set(deviation, target_node, field_node_val - min_bound_node_val) - ! see note above about setting of the increase_capacity - call set(increase_capacity, node, -(field_node_val - min_bound_node_val)) - call set(decrease_capacity, target_node, 0.0) - else - call set(deviation, target_node, 0.0) - call set(increase_capacity, target_node, max_bound_node_val - field_node_val) - call set(decrease_capacity, target_node,-min_bound_node_val + field_node_val) + ewrite(0,*) "Warning: insufficient capacity to repair deviations. Will try my best." end if - end do - - end do deviation_loop +#endif - call deallocate(increase_capacity) - call deallocate(decrease_capacity) - deallocate(increase_capacity_idx) - deallocate(decrease_capacity_idx) - deallocate(deviation_idx) + ! sort into increasing order + call qsort(increase_capacity%val, increase_capacity_idx) + call qsort(decrease_capacity%val, decrease_capacity_idx) + call qsort(abs(deviation%val), deviation_idx) + + ! Now we can distribute stuff around. + + ! starting with the largest deviation + deviation_loop: do j=node_count(field),1,-1 + node = deviation_idx(j) + if(.not.node_owned(field, node)) cycle + lumpedmass_node_val = node_val(lumpedmass, node) + k = node_count(field)+1 + do while((node_val(deviation, node) > repair_tol).and.& + (k>1)) + k = k - 1 + ! Choose the node with the largest capacity + ! (at least at the start since we don't reorder once we get going)... + target_node = increase_capacity_idx(k) + if(.not.node_owned(field,target_node)) cycle + if(node_val(increase_capacity, target_node) max_bound_node_val) then + call set(deviation, target_node, field_node_val - max_bound_node_val) + call set(increase_capacity, target_node, 0.0) + ! see note above about setting of the decrease_capacity + call set(decrease_capacity, node, field_node_val - max_bound_node_val) + else if (field_node_val < min_bound_node_val) then + call set(deviation, target_node, field_node_val - min_bound_node_val) + ! see note above about setting of the increase_capacity + call set(increase_capacity, node, -(field_node_val - min_bound_node_val)) + call set(decrease_capacity, target_node, 0.0) + else + call set(deviation, target_node, 0.0) + call set(increase_capacity, target_node, max_bound_node_val - field_node_val) + call set(decrease_capacity, target_node,-min_bound_node_val + field_node_val) + end if + end do + + k = node_count(field) + do while((node_val(deviation, node) < -repair_tol).and.& + (k>1)) + k = k - 1 + target_node = decrease_capacity_idx(k) + if(.not.node_owned(field, target_node)) cycle + if(node_val(decrease_capacity, target_node) max_bound_node_val) then + call set(deviation, target_node, field_node_val - max_bound_node_val) + call set(increase_capacity, target_node, 0.0) + ! see note above about setting of the decrease_capacity + call set(decrease_capacity, node, field_node_val - max_bound_node_val) + else if (field_node_val < min_bound_node_val) then + call set(deviation, target_node, field_node_val - min_bound_node_val) + ! see note above about setting of the increase_capacity + call set(increase_capacity, node, -(field_node_val - min_bound_node_val)) + call set(decrease_capacity, target_node, 0.0) + else + call set(deviation, target_node, 0.0) + call set(increase_capacity, target_node, max_bound_node_val - field_node_val) + call set(decrease_capacity, target_node,-min_bound_node_val + field_node_val) + end if + end do + + end do deviation_loop + + call deallocate(increase_capacity) + call deallocate(decrease_capacity) + deallocate(increase_capacity_idx) + deallocate(decrease_capacity_idx) + deallocate(deviation_idx) + + end if end if - end if - - call deallocate(diffused) - call deallocate(deviation) + call deallocate(diffused) + call deallocate(deviation) - ! have only done 1st order halo updates until now, so finish with a full update - call halo_update(field) + ! have only done 1st order halo updates until now, so finish with a full update + call halo_update(field) - end subroutine bound_field_diffuse + end subroutine bound_field_diffuse end module bound_field_module diff --git a/femtools/Boundary_Conditions.F90 b/femtools/Boundary_Conditions.F90 index e42de27a76..938cecd928 100644 --- a/femtools/Boundary_Conditions.F90 +++ b/femtools/Boundary_Conditions.F90 @@ -26,2483 +26,2483 @@ ! USA #include "fdebug.h" module boundary_conditions - use fldebug - use spud - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use data_structures - use futils - use parallel_tools - use sparse_tools - use fetools, only : INFINITY - use fields - use sparse_tools_petsc - use state_module - - implicit none - - interface add_boundary_condition - module procedure add_scalar_boundary_condition, & - add_vector_boundary_condition - end interface add_boundary_condition - - interface remove_boundary_condition - module procedure remove_scalar_boundary_condition, & - remove_vector_boundary_condition - end interface remove_boundary_condition - - interface add_boundary_condition_surface_elements - module procedure add_scalar_boundary_condition_surface_elements, & - add_vector_boundary_condition_surface_elements - end interface add_boundary_condition_surface_elements - - interface get_boundary_condition - module procedure get_scalar_boundary_condition_by_number, & - get_vector_boundary_condition_by_number, & - get_scalar_boundary_condition_by_name, & - get_vector_boundary_condition_by_name - end interface - - interface insert_surface_field - module procedure insert_scalar_surface_field, & - insert_vector_surface_field, insert_scalar_surface_field_by_name, & - insert_vector_surface_field_by_name, & - insert_vector_scalar_surface_field, & - insert_vector_scalar_surface_field_by_name - end interface - - interface extract_surface_field - module procedure extract_scalar_surface_field_by_number, & - extract_vector_surface_field_by_number, & - extract_scalar_surface_field_by_name, & - extract_vector_surface_field_by_name - end interface - - interface extract_scalar_surface_field - module procedure extract_vector_scalar_surface_field, & - extract_vector_scalar_surface_field_by_name - end interface extract_scalar_surface_field - - interface has_surface_field - module procedure has_scalar_surface_field_by_bc_number, & - has_vector_surface_field_by_bc_number, & - has_scalar_surface_field_by_bc_name, & - has_vector_surface_field_by_bc_name - end interface - - interface has_scalar_surface_field - module procedure vector_has_scalar_surface_field_by_bc_number, & - vector_has_scalar_surface_field_by_bc_name - end interface has_scalar_surface_field - - interface get_boundary_condition_count - module procedure get_scalar_boundary_condition_count, & - get_vector_boundary_condition_count - end interface - - interface get_entire_boundary_condition - module procedure get_entire_scalar_boundary_condition, & - get_entire_vector_boundary_condition - end interface - - interface get_boundary_condition_nodes - module procedure get_scalar_boundary_condition_nodes, & - get_vector_boundary_condition_nodes - end interface - - interface set_reference_node - module procedure set_reference_node_scalar, set_reference_node_vector_petsc - end interface set_reference_node - - interface has_boundary_condition - module procedure has_boundary_condition_scalar, & - has_boundary_condition_vector - end interface has_boundary_condition - - interface has_boundary_condition_name - module procedure has_boundary_condition_name_scalar, & - has_boundary_condition_name_vector - end interface has_boundary_condition_name - - interface set_dirichlet_consistent - module procedure set_dirichlet_consistent, set_dirichlet_consistent_scalar, & - set_dirichlet_consistent_vector - end interface - - interface apply_dirichlet_conditions - module procedure apply_dirichlet_conditions_scalar, & - apply_dirichlet_conditions_scalar_lumped, & - apply_dirichlet_conditions_vector, & - apply_dirichlet_conditions_vector_petsc_csr, & - apply_dirichlet_conditions_vector_component, & - apply_dirichlet_conditions_vector_lumped, & - apply_dirichlet_conditions_vector_component_lumped - end interface apply_dirichlet_conditions - - interface zero_dirichlet_rows - module procedure zero_dirichlet_rows_vector - end interface zero_dirichlet_rows - - private - public add_boundary_condition, add_boundary_condition_surface_elements, & - get_boundary_condition, get_boundary_condition_count, & - insert_surface_field, extract_surface_field, has_surface_field, & - extract_scalar_surface_field, get_entire_boundary_condition, & - has_scalar_surface_field, get_boundary_condition_nodes, & - get_dg_surface_mesh, has_boundary_condition, has_boundary_condition_name, & - set_reference_node, & - get_periodic_boundary_condition, remove_boundary_condition, & - set_dirichlet_consistent, apply_dirichlet_conditions, & - derive_collapsed_bcs, & - collect_vector_dirichlet_conditions, zero_dirichlet_rows + use fldebug + use spud + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use data_structures + use futils + use parallel_tools + use sparse_tools + use fetools, only : INFINITY + use fields + use sparse_tools_petsc + use state_module + + implicit none + + interface add_boundary_condition + module procedure add_scalar_boundary_condition, & + add_vector_boundary_condition + end interface add_boundary_condition + + interface remove_boundary_condition + module procedure remove_scalar_boundary_condition, & + remove_vector_boundary_condition + end interface remove_boundary_condition + + interface add_boundary_condition_surface_elements + module procedure add_scalar_boundary_condition_surface_elements, & + add_vector_boundary_condition_surface_elements + end interface add_boundary_condition_surface_elements + + interface get_boundary_condition + module procedure get_scalar_boundary_condition_by_number, & + get_vector_boundary_condition_by_number, & + get_scalar_boundary_condition_by_name, & + get_vector_boundary_condition_by_name + end interface + + interface insert_surface_field + module procedure insert_scalar_surface_field, & + insert_vector_surface_field, insert_scalar_surface_field_by_name, & + insert_vector_surface_field_by_name, & + insert_vector_scalar_surface_field, & + insert_vector_scalar_surface_field_by_name + end interface + + interface extract_surface_field + module procedure extract_scalar_surface_field_by_number, & + extract_vector_surface_field_by_number, & + extract_scalar_surface_field_by_name, & + extract_vector_surface_field_by_name + end interface + + interface extract_scalar_surface_field + module procedure extract_vector_scalar_surface_field, & + extract_vector_scalar_surface_field_by_name + end interface extract_scalar_surface_field + + interface has_surface_field + module procedure has_scalar_surface_field_by_bc_number, & + has_vector_surface_field_by_bc_number, & + has_scalar_surface_field_by_bc_name, & + has_vector_surface_field_by_bc_name + end interface + + interface has_scalar_surface_field + module procedure vector_has_scalar_surface_field_by_bc_number, & + vector_has_scalar_surface_field_by_bc_name + end interface has_scalar_surface_field + + interface get_boundary_condition_count + module procedure get_scalar_boundary_condition_count, & + get_vector_boundary_condition_count + end interface + + interface get_entire_boundary_condition + module procedure get_entire_scalar_boundary_condition, & + get_entire_vector_boundary_condition + end interface + + interface get_boundary_condition_nodes + module procedure get_scalar_boundary_condition_nodes, & + get_vector_boundary_condition_nodes + end interface + + interface set_reference_node + module procedure set_reference_node_scalar, set_reference_node_vector_petsc + end interface set_reference_node + + interface has_boundary_condition + module procedure has_boundary_condition_scalar, & + has_boundary_condition_vector + end interface has_boundary_condition + + interface has_boundary_condition_name + module procedure has_boundary_condition_name_scalar, & + has_boundary_condition_name_vector + end interface has_boundary_condition_name + + interface set_dirichlet_consistent + module procedure set_dirichlet_consistent, set_dirichlet_consistent_scalar, & + set_dirichlet_consistent_vector + end interface + + interface apply_dirichlet_conditions + module procedure apply_dirichlet_conditions_scalar, & + apply_dirichlet_conditions_scalar_lumped, & + apply_dirichlet_conditions_vector, & + apply_dirichlet_conditions_vector_petsc_csr, & + apply_dirichlet_conditions_vector_component, & + apply_dirichlet_conditions_vector_lumped, & + apply_dirichlet_conditions_vector_component_lumped + end interface apply_dirichlet_conditions + + interface zero_dirichlet_rows + module procedure zero_dirichlet_rows_vector + end interface zero_dirichlet_rows + + private + public add_boundary_condition, add_boundary_condition_surface_elements, & + get_boundary_condition, get_boundary_condition_count, & + insert_surface_field, extract_surface_field, has_surface_field, & + extract_scalar_surface_field, get_entire_boundary_condition, & + has_scalar_surface_field, get_boundary_condition_nodes, & + get_dg_surface_mesh, has_boundary_condition, has_boundary_condition_name, & + set_reference_node, & + get_periodic_boundary_condition, remove_boundary_condition, & + set_dirichlet_consistent, apply_dirichlet_conditions, & + derive_collapsed_bcs, & + collect_vector_dirichlet_conditions, zero_dirichlet_rows contains - subroutine add_scalar_boundary_condition(field, name, type, boundary_ids, & - option_path, suppress_warnings) - !!< Add boundary condition to scalar field - type(scalar_field), intent(inout):: field - !! all things should have a name - character(len=*), intent(in):: name - !! type can be any of: ... - character(len=*), intent(in):: type - !! boundary ids indicating the part of the surface to apply this b.c. to - integer, dimension(:), intent(in):: boundary_ids - !! path to options for this b.c. in the options tree - character(len=*), optional, intent(in) :: option_path - !! suppress warnings about non-existant surface ids: - logical, intent(in), optional:: suppress_warnings - - logical, dimension(1:size(boundary_ids)):: boundary_id_used - integer, dimension(:), allocatable:: surface_element_list - integer i, ele_count - - assert(associated(field%mesh%faces)) - - allocate( surface_element_list(1:surface_element_count(field)) ) - - ! generate list of surface elements where this b.c. is applied - ele_count=0 - boundary_id_used=.false. - do i=1, surface_element_count(field) - if (any(boundary_ids==surface_element_id(field, i))) then - ele_count=ele_count+1 - surface_element_list(ele_count)=i - where (boundary_ids==surface_element_id(field, i)) - boundary_id_used=.true. - end where + subroutine add_scalar_boundary_condition(field, name, type, boundary_ids, & + option_path, suppress_warnings) + !!< Add boundary condition to scalar field + type(scalar_field), intent(inout):: field + !! all things should have a name + character(len=*), intent(in):: name + !! type can be any of: ... + character(len=*), intent(in):: type + !! boundary ids indicating the part of the surface to apply this b.c. to + integer, dimension(:), intent(in):: boundary_ids + !! path to options for this b.c. in the options tree + character(len=*), optional, intent(in) :: option_path + !! suppress warnings about non-existant surface ids: + logical, intent(in), optional:: suppress_warnings + + logical, dimension(1:size(boundary_ids)):: boundary_id_used + integer, dimension(:), allocatable:: surface_element_list + integer i, ele_count + + assert(associated(field%mesh%faces)) + + allocate( surface_element_list(1:surface_element_count(field)) ) + + ! generate list of surface elements where this b.c. is applied + ele_count=0 + boundary_id_used=.false. + do i=1, surface_element_count(field) + if (any(boundary_ids==surface_element_id(field, i))) then + ele_count=ele_count+1 + surface_element_list(ele_count)=i + where (boundary_ids==surface_element_id(field, i)) + boundary_id_used=.true. + end where + end if + end do + + if (.not. IsParallel() .and. .not. all(boundary_id_used) .and. .not. present_and_true(suppress_warnings)) then + ewrite(0,*) "WARNING: for boundary condition: ", trim(name) + ewrite(0,*) "added to field: ", trim(field%name) + ewrite(0,*) "The following boundary ids were specified, but they don't appear in the surface mesh:" + ewrite(0,*) pack(boundary_ids, mask=.not. boundary_id_used) end if - end do - - if (.not. IsParallel() .and. .not. all(boundary_id_used) .and. .not. present_and_true(suppress_warnings)) then - ewrite(0,*) "WARNING: for boundary condition: ", trim(name) - ewrite(0,*) "added to field: ", trim(field%name) - ewrite(0,*) "The following boundary ids were specified, but they don't appear in the surface mesh:" - ewrite(0,*) pack(boundary_ids, mask=.not. boundary_id_used) - end if - - call add_scalar_boundary_condition_surface_elements(field, name, type, & - surface_element_list(1:ele_count), option_path=option_path) - - deallocate(surface_element_list) - - end subroutine add_scalar_boundary_condition - - subroutine add_scalar_boundary_condition_surface_elements(field, name, type, surface_element_list, & - option_path) - !!< Add boundary condition to scalar field - type(scalar_field), intent(inout):: field - !! all things should have a name - character(len=*), intent(in):: name - !! type can be any of: ... - character(len=*), intent(in):: type - !! list of surface elements where this b.c. is to be applied - integer, dimension(:), intent(in):: surface_element_list - !! path to options for this b.c. in the options tree - character(len=*), optional, intent(in) :: option_path - - type(scalar_boundary_condition), pointer:: tmp_boundary_condition(:) - integer nobcs - - assert(associated(field%mesh%faces)) - - if (.not. associated(field%bc%boundary_condition)) then - allocate(field%bc%boundary_condition(1)) - nobcs=1 - else - nobcs=size(field%bc%boundary_condition)+1 - ! save existing b.c.'s - tmp_boundary_condition => field%bc%boundary_condition - ! allocate new array with 1 new entry - allocate(field%bc%boundary_condition(nobcs)) - ! copy back existing entries - field%bc%boundary_condition(1:nobcs-1)=tmp_boundary_condition - ! deallocate old b.c. array - deallocate(tmp_boundary_condition) - end if - - call allocate(field%bc%boundary_condition(nobcs), field%mesh, & - surface_element_list=surface_element_list, & - name=name, type=type) - - if (present(option_path)) then - field%bc%boundary_condition(nobcs)%option_path=option_path - end if - - end subroutine add_scalar_boundary_condition_surface_elements - - subroutine add_vector_boundary_condition(field, name, type, boundary_ids, & - applies, option_path, suppress_warnings) - !!< Add boundary condition to vector field - type(vector_field), intent(inout):: field - !! all things should have a name - character(len=*), intent(in):: name - !! type can be any of: ... - character(len=*), intent(in):: type - !! boundary ids indicating the part of the surface to apply this b.c. to - integer, dimension(:), intent(in):: boundary_ids - !! boundary condition only applies to component with applies==.true. - logical, dimension(:), intent(in), optional:: applies - !! path to options for this b.c. in the options tree - character(len=*), optional, intent(in) :: option_path - !! suppress warnings about non-existant surface ids: - logical, intent(in), optional:: suppress_warnings - - logical, dimension(1:size(boundary_ids)):: boundary_id_used - integer, dimension(:), allocatable:: surface_element_list - integer i, ele_count - - assert(associated(field%mesh%faces)) - - allocate( surface_element_list(1:surface_element_count(field)) ) - - ! generate list of surface elements where this b.c. is applied - ele_count=0 - boundary_id_used=.false. - do i=1, surface_element_count(field) - if (any(boundary_ids==surface_element_id(field, i))) then - ele_count=ele_count+1 - surface_element_list(ele_count)=i - where (boundary_ids==surface_element_id(field, i)) - boundary_id_used=.true. - end where + + call add_scalar_boundary_condition_surface_elements(field, name, type, & + surface_element_list(1:ele_count), option_path=option_path) + + deallocate(surface_element_list) + + end subroutine add_scalar_boundary_condition + + subroutine add_scalar_boundary_condition_surface_elements(field, name, type, surface_element_list, & + option_path) + !!< Add boundary condition to scalar field + type(scalar_field), intent(inout):: field + !! all things should have a name + character(len=*), intent(in):: name + !! type can be any of: ... + character(len=*), intent(in):: type + !! list of surface elements where this b.c. is to be applied + integer, dimension(:), intent(in):: surface_element_list + !! path to options for this b.c. in the options tree + character(len=*), optional, intent(in) :: option_path + + type(scalar_boundary_condition), pointer:: tmp_boundary_condition(:) + integer nobcs + + assert(associated(field%mesh%faces)) + + if (.not. associated(field%bc%boundary_condition)) then + allocate(field%bc%boundary_condition(1)) + nobcs=1 + else + nobcs=size(field%bc%boundary_condition)+1 + ! save existing b.c.'s + tmp_boundary_condition => field%bc%boundary_condition + ! allocate new array with 1 new entry + allocate(field%bc%boundary_condition(nobcs)) + ! copy back existing entries + field%bc%boundary_condition(1:nobcs-1)=tmp_boundary_condition + ! deallocate old b.c. array + deallocate(tmp_boundary_condition) end if - end do - if (.not. IsParallel() .and. .not. all(boundary_id_used) .and. .not. present_and_true(suppress_warnings)) then - ewrite(0,*) "WARNING: for boundary condition: ", trim(name) - ewrite(0,*) "added to field: ", trim(field%name) - ewrite(0,*) "The following boundary ids were specified, but they don't appear in the surface mesh:" - ewrite(0,*) pack(boundary_ids, mask=.not. boundary_id_used) - end if + call allocate(field%bc%boundary_condition(nobcs), field%mesh, & + surface_element_list=surface_element_list, & + name=name, type=type) + + if (present(option_path)) then + field%bc%boundary_condition(nobcs)%option_path=option_path + end if + + end subroutine add_scalar_boundary_condition_surface_elements + + subroutine add_vector_boundary_condition(field, name, type, boundary_ids, & + applies, option_path, suppress_warnings) + !!< Add boundary condition to vector field + type(vector_field), intent(inout):: field + !! all things should have a name + character(len=*), intent(in):: name + !! type can be any of: ... + character(len=*), intent(in):: type + !! boundary ids indicating the part of the surface to apply this b.c. to + integer, dimension(:), intent(in):: boundary_ids + !! boundary condition only applies to component with applies==.true. + logical, dimension(:), intent(in), optional:: applies + !! path to options for this b.c. in the options tree + character(len=*), optional, intent(in) :: option_path + !! suppress warnings about non-existant surface ids: + logical, intent(in), optional:: suppress_warnings + + logical, dimension(1:size(boundary_ids)):: boundary_id_used + integer, dimension(:), allocatable:: surface_element_list + integer i, ele_count + + assert(associated(field%mesh%faces)) + + allocate( surface_element_list(1:surface_element_count(field)) ) + + ! generate list of surface elements where this b.c. is applied + ele_count=0 + boundary_id_used=.false. + do i=1, surface_element_count(field) + if (any(boundary_ids==surface_element_id(field, i))) then + ele_count=ele_count+1 + surface_element_list(ele_count)=i + where (boundary_ids==surface_element_id(field, i)) + boundary_id_used=.true. + end where + end if + end do + + if (.not. IsParallel() .and. .not. all(boundary_id_used) .and. .not. present_and_true(suppress_warnings)) then + ewrite(0,*) "WARNING: for boundary condition: ", trim(name) + ewrite(0,*) "added to field: ", trim(field%name) + ewrite(0,*) "The following boundary ids were specified, but they don't appear in the surface mesh:" + ewrite(0,*) pack(boundary_ids, mask=.not. boundary_id_used) + end if - call add_vector_boundary_condition_surface_elements(field, name, type, & - surface_element_list(1:ele_count), applies=applies, option_path=option_path) + call add_vector_boundary_condition_surface_elements(field, name, type, & + surface_element_list(1:ele_count), applies=applies, option_path=option_path) - deallocate(surface_element_list) + deallocate(surface_element_list) - end subroutine add_vector_boundary_condition + end subroutine add_vector_boundary_condition - subroutine add_vector_boundary_condition_surface_elements(field, name, type, surface_element_list, & + subroutine add_vector_boundary_condition_surface_elements(field, name, type, surface_element_list, & applies, option_path) - !!< Add boundary condition to vector field - type(vector_field), intent(inout):: field - !! all things should have a name - character(len=*), intent(in):: name - !! type can be any of: ... - character(len=*), intent(in):: type - !! list of surface elements where this b.c. is to be applied - integer, dimension(:), intent(in):: surface_element_list - !! boundary condition only applies to component with applies==.true. - logical, dimension(:), intent(in), optional:: applies - !! path to options for this b.c. in the options tree - character(len=*), optional, intent(in) :: option_path - - type(vector_boundary_condition), pointer:: tmp_boundary_condition(:) - integer nobcs - - assert(associated(field%mesh%faces)) - - if (.not. associated(field%bc%boundary_condition)) then - allocate(field%bc%boundary_condition(1)) - nobcs=1 - else - nobcs=size(field%bc%boundary_condition)+1 - ! save existing b.c.'s - tmp_boundary_condition => field%bc%boundary_condition - ! allocate new array with 1 new entry - allocate(field%bc%boundary_condition(nobcs)) - ! copy back existing entries - field%bc%boundary_condition(1:nobcs-1)=tmp_boundary_condition - ! deallocate old b.c. array - deallocate(tmp_boundary_condition) - end if - - call allocate(field%bc%boundary_condition(nobcs), field%mesh, & - surface_element_list=surface_element_list, & - name=name, type=type, applies=applies) - - if (present(option_path)) then - field%bc%boundary_condition(nobcs)%option_path=option_path - end if - - end subroutine add_vector_boundary_condition_surface_elements - - subroutine remove_scalar_boundary_condition(field, name) - !!< Removed boundary condition from scalar field - type(scalar_field), intent(inout):: field - character(len=*), intent(in):: name - - type(scalar_boundary_condition), pointer:: tmp_boundary_condition(:) - integer:: i, nobcs - - if (associated(field%bc%boundary_condition)) then - nobcs=size(field%bc%boundary_condition) - do i=1, nobcs - if (field%bc%boundary_condition(i)%name==name) then - call deallocate(field%bc%boundary_condition(i)) - ! save existing b.c.'s - tmp_boundary_condition => field%bc%boundary_condition - ! allocate new array with 1 less entry - allocate(field%bc%boundary_condition(nobcs-1)) - ! copy back existing ones, except the i-th - field%bc%boundary_condition(1:i-1)=tmp_boundary_condition(1:i-1) - field%bc%boundary_condition(i:)=tmp_boundary_condition(i+1:) - ! deallocate the old bcs array - deallocate( tmp_boundary_condition ) - return - end if - end do - end if - ewrite(-1,*) 'In remove_scalar_boundary_condition' - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") - - end subroutine remove_scalar_boundary_condition - - subroutine remove_vector_boundary_condition(field, name) - !!< Removed boundary condition from vector field - type(vector_field), intent(inout):: field - character(len=*), intent(in):: name - - type(vector_boundary_condition), pointer:: tmp_boundary_condition(:) - integer:: i, nobcs - - if (associated(field%bc%boundary_condition)) then - nobcs=size(field%bc%boundary_condition) - do i=1, nobcs - if (field%bc%boundary_condition(i)%name==name) then - call deallocate(field%bc%boundary_condition(i)) - ! save existing b.c.'s - tmp_boundary_condition => field%bc%boundary_condition - ! allocate new array with 1 less entry - allocate(field%bc%boundary_condition(nobcs-1)) - ! copy back existing ones, except the i-th - field%bc%boundary_condition(1:i-1)=tmp_boundary_condition(1:i-1) - field%bc%boundary_condition(i:)=tmp_boundary_condition(i+1:) - ! deallocate the old bcs array - deallocate( tmp_boundary_condition ) - return - end if - end do - end if - ewrite(-1,*) 'In remove_vector_boundary_condition' - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") - - end subroutine remove_vector_boundary_condition - - subroutine insert_scalar_surface_field(field, n, surface_field) - !!< Adds a surface_field to a boundary condition: a field over the - !!< part of the surface mesh that this b.c. applies to. This can be used - !!< to store b.c. values - !! field to add surface_field to - type(scalar_field), intent(in):: field - !! add to n-th b.c. - integer, intent(in):: n - !! field to insert, callers of this routine should deallocate their copy - !! of this field afterwards. - type(scalar_field), intent(in):: surface_field - - type(scalar_field), dimension(:), pointer:: tmp_surface_fields - type(scalar_boundary_condition), pointer:: bc - integer i - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if (.not. associated(bc%surface_fields)) then - allocate(bc%surface_fields(1)) - i=1 - else - ! save existing surface fields - tmp_surface_fields => bc%surface_fields - ! allocate one extra - i=size(bc%surface_fields)+1 - allocate(bc%surface_fields(i)) - ! copy back existing surface fields - bc%surface_fields(1:i-1)=tmp_surface_fields - end if - - bc%surface_fields(i)=surface_field - - ! To remain consistent with insert_field for state we incref here - ! so users of this routine should deallocate their copy of the - ! surface_field. - call incref(surface_field) - - end subroutine insert_scalar_surface_field - - subroutine insert_vector_surface_field(field, n, surface_field) - !!< Adds a surface_field to a boundary condition: a field over the - !!< part of the surface mesh that this b.c. applies to. This can be used - !!< to store b.c. values - !! field to add surface_field to - type(vector_field), intent(in):: field - !! add to n-th b.c. - integer, intent(in):: n - !! field to insert, callers of this routine should deallocate their copy - !! of this field afterwards. - type(vector_field), intent(in):: surface_field - - type(vector_field), dimension(:), pointer:: tmp_surface_fields - type(vector_boundary_condition), pointer:: bc - integer i - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if (.not. associated(bc%surface_fields)) then - allocate(bc%surface_fields(1)) - i=1 - else - ! save existing surface fields - tmp_surface_fields => bc%surface_fields - ! allocate one extra - i=size(bc%surface_fields)+1 - allocate(bc%surface_fields(i)) - ! copy back existing surface fields - bc%surface_fields(1:i-1)=tmp_surface_fields - end if - - bc%surface_fields(i)=surface_field - - ! To remain consistent with insert_field for state we incref here - ! so users of this routine should deallocate their copy of the - ! surface_field. - call incref(surface_field) - - end subroutine insert_vector_surface_field - - subroutine insert_vector_scalar_surface_field(field, n, surface_field) - !!< Adds a surface_field to a boundary condition: a field over the - !!< part of the surface mesh that this b.c. applies to. This can be used - !!< to store b.c. values - !! field to add surface_field to - type(vector_field), intent(in):: field - !! add to n-th b.c. - integer, intent(in):: n - !! field to insert, callers of this routine should deallocate their copy - !! of this field afterwards. - type(scalar_field), intent(in):: surface_field - - type(scalar_field), dimension(:), pointer:: tmp_surface_fields - type(vector_boundary_condition), pointer:: bc - integer i - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if (.not. associated(bc%scalar_surface_fields)) then - allocate(bc%scalar_surface_fields(1)) - i=1 - else - ! save existing surface fields - tmp_surface_fields => bc%scalar_surface_fields - ! allocate one extra - i=size(bc%scalar_surface_fields)+1 - allocate(bc%scalar_surface_fields(i)) - ! copy back existing surface fields - bc%scalar_surface_fields(1:i-1)=tmp_surface_fields - end if - - bc%scalar_surface_fields(i)=surface_field - - ! To remain consistent with insert_field for state we incref here - ! so users of this routine should deallocate their copy of the - ! surface_field. - call incref(surface_field) - - end subroutine insert_vector_scalar_surface_field - - subroutine insert_scalar_surface_field_by_name(field, name, surface_field) - !!< Adds a surface_field to a boundary condition: a field over the - !!< part of the surface mesh that this b.c. applies to. This can be used - !!< to store b.c. values - type(scalar_field), intent(in):: field - !! add to b.c. with name: - character(len=*), intent(in):: name - !! field to insert, callers of this routine should deallocate their copy - !! of this field afterwards. - type(scalar_field), intent(in):: surface_field - - integer i - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then - call insert_scalar_surface_field(field, i, surface_field) - return + !!< Add boundary condition to vector field + type(vector_field), intent(inout):: field + !! all things should have a name + character(len=*), intent(in):: name + !! type can be any of: ... + character(len=*), intent(in):: type + !! list of surface elements where this b.c. is to be applied + integer, dimension(:), intent(in):: surface_element_list + !! boundary condition only applies to component with applies==.true. + logical, dimension(:), intent(in), optional:: applies + !! path to options for this b.c. in the options tree + character(len=*), optional, intent(in) :: option_path + + type(vector_boundary_condition), pointer:: tmp_boundary_condition(:) + integer nobcs + + assert(associated(field%mesh%faces)) + + if (.not. associated(field%bc%boundary_condition)) then + allocate(field%bc%boundary_condition(1)) + nobcs=1 + else + nobcs=size(field%bc%boundary_condition)+1 + ! save existing b.c.'s + tmp_boundary_condition => field%bc%boundary_condition + ! allocate new array with 1 new entry + allocate(field%bc%boundary_condition(nobcs)) + ! copy back existing entries + field%bc%boundary_condition(1:nobcs-1)=tmp_boundary_condition + ! deallocate old b.c. array + deallocate(tmp_boundary_condition) end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Hasta la vista") - - end subroutine insert_scalar_surface_field_by_name - - subroutine insert_vector_surface_field_by_name(field, name, surface_field) - !!< Adds a surface_field to a boundary condition: a field over the - !!< part of the surface mesh that this b.c. applies to. This can be used - !!< to store b.c. values - type(vector_field), intent(in):: field - !! add to b.c. with name: - character(len=*), intent(in):: name - !! field to insert, callers of this routine should deallocate their copy - !! of this field afterwards. - type(vector_field), intent(in):: surface_field - - integer i - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then - call insert_vector_surface_field(field, i, surface_field) - return - end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Hasta la vista") - - end subroutine insert_vector_surface_field_by_name - - subroutine insert_vector_scalar_surface_field_by_name(field, name, surface_field) - !!< Adds a surface_field to a boundary condition: a field over the - !!< part of the surface mesh that this b.c. applies to. This can be used - !!< to store b.c. values - type(vector_field), intent(in):: field - !! add to b.c. with name: - character(len=*), intent(in):: name - !! field to insert, callers of this routine should deallocate their copy - !! of this field afterwards. - type(scalar_field), intent(in):: surface_field - - integer i - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then - call insert_vector_scalar_surface_field(field, i, surface_field) - return + + call allocate(field%bc%boundary_condition(nobcs), field%mesh, & + surface_element_list=surface_element_list, & + name=name, type=type, applies=applies) + + if (present(option_path)) then + field%bc%boundary_condition(nobcs)%option_path=option_path end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Hasta la vista") - - end subroutine insert_vector_scalar_surface_field_by_name - - function extract_scalar_surface_field_by_number(field, n, name, stat) result (surface_field) - !!< Extracts one of the surface_fields by name of the n-th b.c. of field - type(scalar_field), pointer:: surface_field - type(scalar_field), intent(in):: field - integer, intent(in):: n - character(len=*), intent(in):: name - integer, intent(out), optional:: stat - - type(scalar_boundary_condition), pointer:: bc - integer i - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if(present(stat)) then - stat = 0 - end if - - if (associated(bc%surface_fields)) then - do i=1, size(bc%surface_fields) - if (bc%surface_fields(i)%name==name) then - surface_field => bc%surface_fields(i) - return - end if - end do - end if - if (present(stat)) then - stat = 1 - else - ewrite(-1, '(a," is not a surface_field of boundary condition n=",i0," of field ",a)') trim(name), n, trim(field%name) + end subroutine add_vector_boundary_condition_surface_elements + + subroutine remove_scalar_boundary_condition(field, name) + !!< Removed boundary condition from scalar field + type(scalar_field), intent(inout):: field + character(len=*), intent(in):: name + + type(scalar_boundary_condition), pointer:: tmp_boundary_condition(:) + integer:: i, nobcs + + if (associated(field%bc%boundary_condition)) then + nobcs=size(field%bc%boundary_condition) + do i=1, nobcs + if (field%bc%boundary_condition(i)%name==name) then + call deallocate(field%bc%boundary_condition(i)) + ! save existing b.c.'s + tmp_boundary_condition => field%bc%boundary_condition + ! allocate new array with 1 less entry + allocate(field%bc%boundary_condition(nobcs-1)) + ! copy back existing ones, except the i-th + field%bc%boundary_condition(1:i-1)=tmp_boundary_condition(1:i-1) + field%bc%boundary_condition(i:)=tmp_boundary_condition(i+1:) + ! deallocate the old bcs array + deallocate( tmp_boundary_condition ) + return + end if + end do + end if + ewrite(-1,*) 'In remove_scalar_boundary_condition' + ewrite(-1,*) 'Unknown boundary condition: ', name FLAbort("Sorry!") - end if - - end function extract_scalar_surface_field_by_number - - function extract_vector_surface_field_by_number(field, n, name, stat) result (surface_field) - !!< Extracts one of the surface_fields by name of the n-th b.c. of field - type(vector_field), pointer:: surface_field - type(vector_field), intent(in):: field - integer, intent(in):: n - character(len=*), intent(in):: name - integer, intent(out), optional:: stat - - type(vector_boundary_condition), pointer:: bc - integer i - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if(present(stat)) then - stat = 0 - end if - - if (associated(bc%surface_fields)) then - do i=1, size(bc%surface_fields) - if (bc%surface_fields(i)%name==name) then - surface_field => bc%surface_fields(i) - return - end if - end do - end if - if (present(stat)) then - stat = 1 - else - ewrite(-1, '(a," is not a surface_field of boundary condition n=",i0," of field ",a)') trim(name), n, trim(field%name) + end subroutine remove_scalar_boundary_condition + + subroutine remove_vector_boundary_condition(field, name) + !!< Removed boundary condition from vector field + type(vector_field), intent(inout):: field + character(len=*), intent(in):: name + + type(vector_boundary_condition), pointer:: tmp_boundary_condition(:) + integer:: i, nobcs + + if (associated(field%bc%boundary_condition)) then + nobcs=size(field%bc%boundary_condition) + do i=1, nobcs + if (field%bc%boundary_condition(i)%name==name) then + call deallocate(field%bc%boundary_condition(i)) + ! save existing b.c.'s + tmp_boundary_condition => field%bc%boundary_condition + ! allocate new array with 1 less entry + allocate(field%bc%boundary_condition(nobcs-1)) + ! copy back existing ones, except the i-th + field%bc%boundary_condition(1:i-1)=tmp_boundary_condition(1:i-1) + field%bc%boundary_condition(i:)=tmp_boundary_condition(i+1:) + ! deallocate the old bcs array + deallocate( tmp_boundary_condition ) + return + end if + end do + end if + ewrite(-1,*) 'In remove_vector_boundary_condition' + ewrite(-1,*) 'Unknown boundary condition: ', name FLAbort("Sorry!") - end if - - end function extract_vector_surface_field_by_number - - function extract_vector_scalar_surface_field(field, n, name, stat) result (surface_field) - !!< Extracts one of the surface_fields by name of the n-th b.c. of field - type(scalar_field), pointer:: surface_field - type(vector_field), intent(in):: field - integer, intent(in):: n - character(len=*), intent(in):: name - integer, intent(out), optional:: stat - - type(vector_boundary_condition), pointer:: bc - integer i - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if (present(stat)) then - stat = 0 - end if - - if (associated(bc%scalar_surface_fields)) then - do i=1, size(bc%scalar_surface_fields) - if (bc%scalar_surface_fields(i)%name==name) then - surface_field => bc%scalar_surface_fields(i) - return - end if + + end subroutine remove_vector_boundary_condition + + subroutine insert_scalar_surface_field(field, n, surface_field) + !!< Adds a surface_field to a boundary condition: a field over the + !!< part of the surface mesh that this b.c. applies to. This can be used + !!< to store b.c. values + !! field to add surface_field to + type(scalar_field), intent(in):: field + !! add to n-th b.c. + integer, intent(in):: n + !! field to insert, callers of this routine should deallocate their copy + !! of this field afterwards. + type(scalar_field), intent(in):: surface_field + + type(scalar_field), dimension(:), pointer:: tmp_surface_fields + type(scalar_boundary_condition), pointer:: bc + integer i + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (.not. associated(bc%surface_fields)) then + allocate(bc%surface_fields(1)) + i=1 + else + ! save existing surface fields + tmp_surface_fields => bc%surface_fields + ! allocate one extra + i=size(bc%surface_fields)+1 + allocate(bc%surface_fields(i)) + ! copy back existing surface fields + bc%surface_fields(1:i-1)=tmp_surface_fields + end if + + bc%surface_fields(i)=surface_field + + ! To remain consistent with insert_field for state we incref here + ! so users of this routine should deallocate their copy of the + ! surface_field. + call incref(surface_field) + + end subroutine insert_scalar_surface_field + + subroutine insert_vector_surface_field(field, n, surface_field) + !!< Adds a surface_field to a boundary condition: a field over the + !!< part of the surface mesh that this b.c. applies to. This can be used + !!< to store b.c. values + !! field to add surface_field to + type(vector_field), intent(in):: field + !! add to n-th b.c. + integer, intent(in):: n + !! field to insert, callers of this routine should deallocate their copy + !! of this field afterwards. + type(vector_field), intent(in):: surface_field + + type(vector_field), dimension(:), pointer:: tmp_surface_fields + type(vector_boundary_condition), pointer:: bc + integer i + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (.not. associated(bc%surface_fields)) then + allocate(bc%surface_fields(1)) + i=1 + else + ! save existing surface fields + tmp_surface_fields => bc%surface_fields + ! allocate one extra + i=size(bc%surface_fields)+1 + allocate(bc%surface_fields(i)) + ! copy back existing surface fields + bc%surface_fields(1:i-1)=tmp_surface_fields + end if + + bc%surface_fields(i)=surface_field + + ! To remain consistent with insert_field for state we incref here + ! so users of this routine should deallocate their copy of the + ! surface_field. + call incref(surface_field) + + end subroutine insert_vector_surface_field + + subroutine insert_vector_scalar_surface_field(field, n, surface_field) + !!< Adds a surface_field to a boundary condition: a field over the + !!< part of the surface mesh that this b.c. applies to. This can be used + !!< to store b.c. values + !! field to add surface_field to + type(vector_field), intent(in):: field + !! add to n-th b.c. + integer, intent(in):: n + !! field to insert, callers of this routine should deallocate their copy + !! of this field afterwards. + type(scalar_field), intent(in):: surface_field + + type(scalar_field), dimension(:), pointer:: tmp_surface_fields + type(vector_boundary_condition), pointer:: bc + integer i + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (.not. associated(bc%scalar_surface_fields)) then + allocate(bc%scalar_surface_fields(1)) + i=1 + else + ! save existing surface fields + tmp_surface_fields => bc%scalar_surface_fields + ! allocate one extra + i=size(bc%scalar_surface_fields)+1 + allocate(bc%scalar_surface_fields(i)) + ! copy back existing surface fields + bc%scalar_surface_fields(1:i-1)=tmp_surface_fields + end if + + bc%scalar_surface_fields(i)=surface_field + + ! To remain consistent with insert_field for state we incref here + ! so users of this routine should deallocate their copy of the + ! surface_field. + call incref(surface_field) + + end subroutine insert_vector_scalar_surface_field + + subroutine insert_scalar_surface_field_by_name(field, name, surface_field) + !!< Adds a surface_field to a boundary condition: a field over the + !!< part of the surface mesh that this b.c. applies to. This can be used + !!< to store b.c. values + type(scalar_field), intent(in):: field + !! add to b.c. with name: + character(len=*), intent(in):: name + !! field to insert, callers of this routine should deallocate their copy + !! of this field afterwards. + type(scalar_field), intent(in):: surface_field + + integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + call insert_scalar_surface_field(field, i, surface_field) + return + end if end do - end if + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Hasta la vista") + + end subroutine insert_scalar_surface_field_by_name + + subroutine insert_vector_surface_field_by_name(field, name, surface_field) + !!< Adds a surface_field to a boundary condition: a field over the + !!< part of the surface mesh that this b.c. applies to. This can be used + !!< to store b.c. values + type(vector_field), intent(in):: field + !! add to b.c. with name: + character(len=*), intent(in):: name + !! field to insert, callers of this routine should deallocate their copy + !! of this field afterwards. + type(vector_field), intent(in):: surface_field + + integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + call insert_vector_surface_field(field, i, surface_field) + return + end if + end do + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Hasta la vista") + + end subroutine insert_vector_surface_field_by_name + + subroutine insert_vector_scalar_surface_field_by_name(field, name, surface_field) + !!< Adds a surface_field to a boundary condition: a field over the + !!< part of the surface mesh that this b.c. applies to. This can be used + !!< to store b.c. values + type(vector_field), intent(in):: field + !! add to b.c. with name: + character(len=*), intent(in):: name + !! field to insert, callers of this routine should deallocate their copy + !! of this field afterwards. + type(scalar_field), intent(in):: surface_field + + integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + call insert_vector_scalar_surface_field(field, i, surface_field) + return + end if + end do + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Hasta la vista") - if(present(stat)) then - stat=1 - else - ewrite(-1, '(a," is not a surface_field of boundary condition n=",i0," of field ",a)') trim(name), n, trim(field%name) - FLAbort("Sorry!") - end if + end subroutine insert_vector_scalar_surface_field_by_name - end function extract_vector_scalar_surface_field + function extract_scalar_surface_field_by_number(field, n, name, stat) result (surface_field) + !!< Extracts one of the surface_fields by name of the n-th b.c. of field + type(scalar_field), pointer:: surface_field + type(scalar_field), intent(in):: field + integer, intent(in):: n + character(len=*), intent(in):: name + integer, intent(out), optional:: stat - function extract_scalar_surface_field_by_name(field, bc_name, name, stat) result (surface_field) - !!< Extracts one of the surface_fields of the b.c. 'bc_name' by name of field - type(scalar_field), pointer:: surface_field - type(scalar_field), intent(in):: field - character(len=*), intent(in):: bc_name, name - integer, intent(out), optional:: stat + type(scalar_boundary_condition), pointer:: bc + integer i - integer i + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) - if (present(stat)) then - stat = 0 - end if + if(present(stat)) then + stat = 0 + end if - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==bc_name) then - surface_field => extract_scalar_surface_field_by_number(field, i, name, stat) - return + if (associated(bc%surface_fields)) then + do i=1, size(bc%surface_fields) + if (bc%surface_fields(i)%name==name) then + surface_field => bc%surface_fields(i) + return + end if + end do end if - end do - if (present(stat)) then - stat = 1 - else - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") - end if + if (present(stat)) then + stat = 1 + else + ewrite(-1, '(a," is not a surface_field of boundary condition n=",i0," of field ",a)') trim(name), n, trim(field%name) + FLAbort("Sorry!") + end if - end function extract_scalar_surface_field_by_name + end function extract_scalar_surface_field_by_number - function extract_vector_surface_field_by_name(field, bc_name, name, stat) result (surface_field) - !!< Extracts one of the surface_fields of the b.c. 'bc_name' by name of field - type(vector_field), pointer:: surface_field - type(vector_field), intent(in):: field - character(len=*), intent(in):: bc_name, name - integer, intent(out), optional:: stat + function extract_vector_surface_field_by_number(field, n, name, stat) result (surface_field) + !!< Extracts one of the surface_fields by name of the n-th b.c. of field + type(vector_field), pointer:: surface_field + type(vector_field), intent(in):: field + integer, intent(in):: n + character(len=*), intent(in):: name + integer, intent(out), optional:: stat - integer i + type(vector_boundary_condition), pointer:: bc + integer i - if (present(stat)) then - stat=0 - end if + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==bc_name) then - surface_field => extract_vector_surface_field_by_number(field, i, name, stat) - return + if(present(stat)) then + stat = 0 end if - end do - if (present(stat)) then - stat = 1 - else - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") - end if + if (associated(bc%surface_fields)) then + do i=1, size(bc%surface_fields) + if (bc%surface_fields(i)%name==name) then + surface_field => bc%surface_fields(i) + return + end if + end do + end if + + if (present(stat)) then + stat = 1 + else + ewrite(-1, '(a," is not a surface_field of boundary condition n=",i0," of field ",a)') trim(name), n, trim(field%name) + FLAbort("Sorry!") + end if - end function extract_vector_surface_field_by_name + end function extract_vector_surface_field_by_number - function extract_vector_scalar_surface_field_by_name(field, bc_name, name, stat) result (surface_field) - !!< Extracts one of the surface_fields of the b.c. 'bc_name' by name of field - type(scalar_field), pointer:: surface_field - type(vector_field), intent(in):: field - character(len=*), intent(in):: bc_name, name - integer, intent(out), optional:: stat + function extract_vector_scalar_surface_field(field, n, name, stat) result (surface_field) + !!< Extracts one of the surface_fields by name of the n-th b.c. of field + type(scalar_field), pointer:: surface_field + type(vector_field), intent(in):: field + integer, intent(in):: n + character(len=*), intent(in):: name + integer, intent(out), optional:: stat - integer i + type(vector_boundary_condition), pointer:: bc + integer i - if (present(stat)) then - stat = 0 - end if + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==bc_name) then - surface_field => extract_vector_scalar_surface_field(field, i, name, stat) - return + if (present(stat)) then + stat = 0 end if - end do - if (present(stat)) then - stat = 1 - else - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") - end if + if (associated(bc%scalar_surface_fields)) then + do i=1, size(bc%scalar_surface_fields) + if (bc%scalar_surface_fields(i)%name==name) then + surface_field => bc%scalar_surface_fields(i) + return + end if + end do + end if + + if(present(stat)) then + stat=1 + else + ewrite(-1, '(a," is not a surface_field of boundary condition n=",i0," of field ",a)') trim(name), n, trim(field%name) + FLAbort("Sorry!") + end if + + end function extract_vector_scalar_surface_field + + function extract_scalar_surface_field_by_name(field, bc_name, name, stat) result (surface_field) + !!< Extracts one of the surface_fields of the b.c. 'bc_name' by name of field + type(scalar_field), pointer:: surface_field + type(scalar_field), intent(in):: field + character(len=*), intent(in):: bc_name, name + integer, intent(out), optional:: stat + + integer i + + if (present(stat)) then + stat = 0 + end if + + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==bc_name) then + surface_field => extract_scalar_surface_field_by_number(field, i, name, stat) + return + end if + end do + + if (present(stat)) then + stat = 1 + else + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Sorry!") + end if - end function extract_vector_scalar_surface_field_by_name + end function extract_scalar_surface_field_by_name - function has_scalar_surface_field_by_bc_number(field, n, name) - !!< Tells whether a surface_field with the given is present - logical :: has_scalar_surface_field_by_bc_number - type(scalar_field), intent(in):: field - integer, intent(in):: n - character(len=*), intent(in):: name + function extract_vector_surface_field_by_name(field, bc_name, name, stat) result (surface_field) + !!< Extracts one of the surface_fields of the b.c. 'bc_name' by name of field + type(vector_field), pointer:: surface_field + type(vector_field), intent(in):: field + character(len=*), intent(in):: bc_name, name + integer, intent(out), optional:: stat - type(scalar_boundary_condition), pointer:: bc - integer i + integer i - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) + if (present(stat)) then + stat=0 + end if - if (associated(bc%surface_fields)) then - do i=1, size(bc%surface_fields) - if (bc%surface_fields(i)%name==name) then - has_scalar_surface_field_by_bc_number=.true. - return - end if + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==bc_name) then + surface_field => extract_vector_surface_field_by_number(field, i, name, stat) + return + end if end do - end if - has_scalar_surface_field_by_bc_number=.false. + if (present(stat)) then + stat = 1 + else + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Sorry!") + end if - end function has_scalar_surface_field_by_bc_number + end function extract_vector_surface_field_by_name - function has_vector_surface_field_by_bc_number(field, n, name) - !!< Tells whether a surface_field with the given is present - logical :: has_vector_surface_field_by_bc_number - type(vector_field), intent(in):: field - integer, intent(in):: n - character(len=*), intent(in):: name + function extract_vector_scalar_surface_field_by_name(field, bc_name, name, stat) result (surface_field) + !!< Extracts one of the surface_fields of the b.c. 'bc_name' by name of field + type(scalar_field), pointer:: surface_field + type(vector_field), intent(in):: field + character(len=*), intent(in):: bc_name, name + integer, intent(out), optional:: stat - type(vector_boundary_condition), pointer:: bc - integer i + integer i - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) + if (present(stat)) then + stat = 0 + end if - if (associated(bc%surface_fields)) then - do i=1, size(bc%surface_fields) - if (bc%surface_fields(i)%name==name) then - has_vector_surface_field_by_bc_number=.true. - return - end if + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==bc_name) then + surface_field => extract_vector_scalar_surface_field(field, i, name, stat) + return + end if end do - end if - has_vector_surface_field_by_bc_number=.false. + if (present(stat)) then + stat = 1 + else + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Sorry!") + end if + + end function extract_vector_scalar_surface_field_by_name + + function has_scalar_surface_field_by_bc_number(field, n, name) + !!< Tells whether a surface_field with the given is present + logical :: has_scalar_surface_field_by_bc_number + type(scalar_field), intent(in):: field + integer, intent(in):: n + character(len=*), intent(in):: name + + type(scalar_boundary_condition), pointer:: bc + integer i + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (associated(bc%surface_fields)) then + do i=1, size(bc%surface_fields) + if (bc%surface_fields(i)%name==name) then + has_scalar_surface_field_by_bc_number=.true. + return + end if + end do + end if + + has_scalar_surface_field_by_bc_number=.false. + + end function has_scalar_surface_field_by_bc_number - end function has_vector_surface_field_by_bc_number + function has_vector_surface_field_by_bc_number(field, n, name) + !!< Tells whether a surface_field with the given is present + logical :: has_vector_surface_field_by_bc_number + type(vector_field), intent(in):: field + integer, intent(in):: n + character(len=*), intent(in):: name - function vector_has_scalar_surface_field_by_bc_number(field, n, name) - !!< Tells whether a surface_field with the given is present - logical :: vector_has_scalar_surface_field_by_bc_number - type(vector_field), intent(in):: field - integer, intent(in):: n - character(len=*), intent(in):: name + type(vector_boundary_condition), pointer:: bc + integer i - type(vector_boundary_condition), pointer:: bc - integer i + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (associated(bc%surface_fields)) then + do i=1, size(bc%surface_fields) + if (bc%surface_fields(i)%name==name) then + has_vector_surface_field_by_bc_number=.true. + return + end if + end do + end if - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) + has_vector_surface_field_by_bc_number=.false. - if (associated(bc%scalar_surface_fields)) then - do i=1, size(bc%scalar_surface_fields) - if (bc%scalar_surface_fields(i)%name==name) then - vector_has_scalar_surface_field_by_bc_number=.true. - return - end if + end function has_vector_surface_field_by_bc_number + + function vector_has_scalar_surface_field_by_bc_number(field, n, name) + !!< Tells whether a surface_field with the given is present + logical :: vector_has_scalar_surface_field_by_bc_number + type(vector_field), intent(in):: field + integer, intent(in):: n + character(len=*), intent(in):: name + + type(vector_boundary_condition), pointer:: bc + integer i + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (associated(bc%scalar_surface_fields)) then + do i=1, size(bc%scalar_surface_fields) + if (bc%scalar_surface_fields(i)%name==name) then + vector_has_scalar_surface_field_by_bc_number=.true. + return + end if + end do + end if + + vector_has_scalar_surface_field_by_bc_number=.false. + + end function vector_has_scalar_surface_field_by_bc_number + + function has_scalar_surface_field_by_bc_name(field, bc_name, name) + !!< Tells whether a surface_field with the given name is present + !!< If the bc_name does not exist an error is given + logical :: has_scalar_surface_field_by_bc_name + type(scalar_field), intent(in):: field + character(len=*), intent(in):: bc_name, name + + integer i + + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==bc_name) then + has_scalar_surface_field_by_bc_name = has_scalar_surface_field_by_bc_number(field, i, name) + return + end if end do - end if - vector_has_scalar_surface_field_by_bc_number=.false. + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Sorry!") + + end function has_scalar_surface_field_by_bc_name - end function vector_has_scalar_surface_field_by_bc_number + function has_vector_surface_field_by_bc_name(field, bc_name, name) + !!< Tells whether a surface_field with the given name is present + !!< If the bc_name does not exist an error is given + logical :: has_vector_surface_field_by_bc_name + type(vector_field), intent(in):: field + character(len=*), intent(in):: bc_name, name - function has_scalar_surface_field_by_bc_name(field, bc_name, name) - !!< Tells whether a surface_field with the given name is present - !!< If the bc_name does not exist an error is given - logical :: has_scalar_surface_field_by_bc_name - type(scalar_field), intent(in):: field - character(len=*), intent(in):: bc_name, name + integer i - integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==bc_name) then + has_vector_surface_field_by_bc_name = has_vector_surface_field_by_bc_number(field, i, name) + return + end if + end do - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==bc_name) then - has_scalar_surface_field_by_bc_name = has_scalar_surface_field_by_bc_number(field, i, name) - return + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Sorry!") + + end function has_vector_surface_field_by_bc_name + + function vector_has_scalar_surface_field_by_bc_name(field, bc_name, name) + !!< Tells whether a scalar surface_field with the given name is present under a vector field bc + !!< If the bc_name does not exist an error is given + logical :: vector_has_scalar_surface_field_by_bc_name + type(vector_field), intent(in):: field + character(len=*), intent(in):: bc_name, name + + integer i + + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==bc_name) then + vector_has_scalar_surface_field_by_bc_name = vector_has_scalar_surface_field_by_bc_number(field, i, name) + return + end if + end do + + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Sorry!") + + end function vector_has_scalar_surface_field_by_bc_name + + integer function get_scalar_boundary_condition_count(field) + !!< Get number of boundary conditions of a scalar field + type(scalar_field), intent(in):: field + + if (associated(field%bc%boundary_condition)) then + get_scalar_boundary_condition_count=size(field%bc%boundary_condition) + else + get_scalar_boundary_condition_count=0 + end if + + end function get_scalar_boundary_condition_count + + integer function get_vector_boundary_condition_count(field) + !!< Get number of boundary conditions of a scalar field + type(vector_field), intent(in):: field + + if (associated(field%bc%boundary_condition)) then + get_vector_boundary_condition_count=size(field%bc%boundary_condition) + else + get_vector_boundary_condition_count=0 + end if + + end function get_vector_boundary_condition_count + + subroutine get_scalar_boundary_condition_by_number(field, n, name, type, & + surface_element_list, surface_node_list, surface_mesh, & + option_path) + !!< Get boundary condition of a scalar field + type(scalar_field), intent(in):: field + !! which boundary condition + integer, intent(in):: n + !! name of the b.c. + character(len=*), intent(out), optional:: name + !! type of b.c., any of: ... + character(len=*), intent(out), optional:: type + !! pointer to list of surface elements where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_element_list + !! pointer to list of surface nodes where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_node_list + !! surface mesh on which surface fields can be allocated + type(mesh_type), pointer, optional:: surface_mesh + !! option_path for the bc + character(len=*), intent(out), optional:: option_path + + type(scalar_boundary_condition), pointer:: bc + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (present(name)) then + name=bc%name end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") + if (present(type)) then + type=bc%type + end if - end function has_scalar_surface_field_by_bc_name + if (present(surface_element_list)) then + surface_element_list => bc%surface_element_list + end if - function has_vector_surface_field_by_bc_name(field, bc_name, name) - !!< Tells whether a surface_field with the given name is present - !!< If the bc_name does not exist an error is given - logical :: has_vector_surface_field_by_bc_name - type(vector_field), intent(in):: field - character(len=*), intent(in):: bc_name, name + if (present(surface_node_list)) then + surface_node_list => bc%surface_node_list + end if - integer i + if (present(surface_mesh)) then + surface_mesh => bc%surface_mesh + end if - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==bc_name) then - has_vector_surface_field_by_bc_name = has_vector_surface_field_by_bc_number(field, i, name) - return + if (present(option_path)) then + option_path = bc%option_path end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") + end subroutine get_scalar_boundary_condition_by_number + + subroutine get_vector_boundary_condition_by_number(field, n, name, type, & + surface_element_list, surface_node_list, applies, surface_mesh, & + option_path) + !!< Get boundary condition of a vector field + type(vector_field), intent(in):: field + !! which boundary condition + integer, intent(in):: n + !! name of the b.c. + character(len=*), intent(out), optional:: name + !! type of b.c., any of: ... + character(len=*), intent(out), optional:: type + !! pointer to list of surface elements where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_element_list + !! pointer to list of surface nodes where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_node_list + !! vector components to which this b.c. applies + logical, dimension(:), intent(out), optional:: applies + !! surface mesh on which surface fields can be allocated + type(mesh_type), pointer, optional:: surface_mesh + !! option_path for the bc + character(len=*), intent(out), optional:: option_path + + type(vector_boundary_condition), pointer:: bc + + assert(n>=1 .and. n<=size(field%bc%boundary_condition)) + bc => field%bc%boundary_condition(n) + + if (present(name)) then + name=bc%name + end if - end function has_vector_surface_field_by_bc_name + if (present(type)) then + type=bc%type + end if - function vector_has_scalar_surface_field_by_bc_name(field, bc_name, name) - !!< Tells whether a scalar surface_field with the given name is present under a vector field bc - !!< If the bc_name does not exist an error is given - logical :: vector_has_scalar_surface_field_by_bc_name - type(vector_field), intent(in):: field - character(len=*), intent(in):: bc_name, name + if (present(surface_element_list)) then + surface_element_list => bc%surface_element_list + end if - integer i + if (present(surface_node_list)) then + surface_node_list => bc%surface_node_list + end if - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==bc_name) then - vector_has_scalar_surface_field_by_bc_name = vector_has_scalar_surface_field_by_bc_number(field, i, name) - return + if (present(applies)) then + applies=bc%applies(1:size(applies)) end if - end do - - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Sorry!") - - end function vector_has_scalar_surface_field_by_bc_name - - integer function get_scalar_boundary_condition_count(field) - !!< Get number of boundary conditions of a scalar field - type(scalar_field), intent(in):: field - - if (associated(field%bc%boundary_condition)) then - get_scalar_boundary_condition_count=size(field%bc%boundary_condition) - else - get_scalar_boundary_condition_count=0 - end if - - end function get_scalar_boundary_condition_count - - integer function get_vector_boundary_condition_count(field) - !!< Get number of boundary conditions of a scalar field - type(vector_field), intent(in):: field - - if (associated(field%bc%boundary_condition)) then - get_vector_boundary_condition_count=size(field%bc%boundary_condition) - else - get_vector_boundary_condition_count=0 - end if - - end function get_vector_boundary_condition_count - - subroutine get_scalar_boundary_condition_by_number(field, n, name, type, & - surface_element_list, surface_node_list, surface_mesh, & - option_path) - !!< Get boundary condition of a scalar field - type(scalar_field), intent(in):: field - !! which boundary condition - integer, intent(in):: n - !! name of the b.c. - character(len=*), intent(out), optional:: name - !! type of b.c., any of: ... - character(len=*), intent(out), optional:: type - !! pointer to list of surface elements where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_element_list - !! pointer to list of surface nodes where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_node_list - !! surface mesh on which surface fields can be allocated - type(mesh_type), pointer, optional:: surface_mesh - !! option_path for the bc - character(len=*), intent(out), optional:: option_path - - type(scalar_boundary_condition), pointer:: bc - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if (present(name)) then - name=bc%name - end if - - if (present(type)) then - type=bc%type - end if - - if (present(surface_element_list)) then - surface_element_list => bc%surface_element_list - end if - - if (present(surface_node_list)) then - surface_node_list => bc%surface_node_list - end if - - if (present(surface_mesh)) then - surface_mesh => bc%surface_mesh - end if - - if (present(option_path)) then - option_path = bc%option_path - end if - - end subroutine get_scalar_boundary_condition_by_number - - subroutine get_vector_boundary_condition_by_number(field, n, name, type, & - surface_element_list, surface_node_list, applies, surface_mesh, & - option_path) - !!< Get boundary condition of a vector field - type(vector_field), intent(in):: field - !! which boundary condition - integer, intent(in):: n - !! name of the b.c. - character(len=*), intent(out), optional:: name - !! type of b.c., any of: ... - character(len=*), intent(out), optional:: type - !! pointer to list of surface elements where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_element_list - !! pointer to list of surface nodes where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_node_list - !! vector components to which this b.c. applies - logical, dimension(:), intent(out), optional:: applies - !! surface mesh on which surface fields can be allocated - type(mesh_type), pointer, optional:: surface_mesh - !! option_path for the bc - character(len=*), intent(out), optional:: option_path - - type(vector_boundary_condition), pointer:: bc - - assert(n>=1 .and. n<=size(field%bc%boundary_condition)) - bc => field%bc%boundary_condition(n) - - if (present(name)) then - name=bc%name - end if - - if (present(type)) then - type=bc%type - end if - - if (present(surface_element_list)) then - surface_element_list => bc%surface_element_list - end if - - if (present(surface_node_list)) then - surface_node_list => bc%surface_node_list - end if - - if (present(applies)) then - applies=bc%applies(1:size(applies)) - end if - - if (present(surface_mesh)) then - surface_mesh => bc%surface_mesh - end if - - if (present(option_path)) then - option_path = bc%option_path - end if - - end subroutine get_vector_boundary_condition_by_number - - subroutine get_scalar_boundary_condition_by_name(field, name, & - type, surface_node_list, surface_element_list, surface_mesh, & - option_path) - !!< Get boundary condition of a scalar field - type(scalar_field), intent(in):: field - !! which boundary condition - character(len=*), intent(in):: name - !! type of b.c., any of: ... - character(len=*), intent(out), optional:: type - !! pointer to list of surface elements where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_element_list - !! pointer to list of surface nodes where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_node_list - !! surface mesh on which surface fields can be allocated - type(mesh_type), pointer, optional:: surface_mesh - !! option_path for the bc - character(len=*), intent(out), optional:: option_path - - integer i - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then - call get_scalar_boundary_condition_by_number(field, i, & - type=type, surface_element_list=surface_element_list, & - surface_node_list=surface_node_list, & - surface_mesh=surface_mesh, & - option_path=option_path) - return + + if (present(surface_mesh)) then + surface_mesh => bc%surface_mesh end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Hasta la vista") - - end subroutine get_scalar_boundary_condition_by_name - - subroutine get_vector_boundary_condition_by_name(field, name, & - type, surface_element_list, surface_node_list, applies, surface_mesh, & - option_path) - !!< Get boundary condition of a vector field - type(vector_field), intent(in):: field - !! which boundary condition - character(len=*), intent(in):: name - !! type of b.c., any of: ... - character(len=*), intent(out), optional:: type - !! pointer to list of surface elements where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_element_list - !! pointer to list of surface nodes where this b.c. is applied - integer, dimension(:), pointer, optional:: surface_node_list - !! vector components to which this b.c. applies - logical, dimension(:), intent(out), optional:: applies - !! surface mesh on which surface fields can be allocated - type(mesh_type), pointer, optional:: surface_mesh - !! option_path for the bc - character(len=*), intent(out), optional:: option_path - - integer i - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then - call get_vector_boundary_condition_by_number(field, i, & - type, surface_element_list=surface_element_list, & - surface_node_list=surface_node_list, & - applies=applies, surface_mesh=surface_mesh, & - option_path=option_path) - return + + if (present(option_path)) then + option_path = bc%option_path end if - end do - ewrite(-1,*) 'Unknown boundary condition: ', name - FLAbort("Hasta la vista") - end subroutine get_vector_boundary_condition_by_name + end subroutine get_vector_boundary_condition_by_number + + subroutine get_scalar_boundary_condition_by_name(field, name, & + type, surface_node_list, surface_element_list, surface_mesh, & + option_path) + !!< Get boundary condition of a scalar field + type(scalar_field), intent(in):: field + !! which boundary condition + character(len=*), intent(in):: name + !! type of b.c., any of: ... + character(len=*), intent(out), optional:: type + !! pointer to list of surface elements where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_element_list + !! pointer to list of surface nodes where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_node_list + !! surface mesh on which surface fields can be allocated + type(mesh_type), pointer, optional:: surface_mesh + !! option_path for the bc + character(len=*), intent(out), optional:: option_path + + integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + call get_scalar_boundary_condition_by_number(field, i, & + type=type, surface_element_list=surface_element_list, & + surface_node_list=surface_node_list, & + surface_mesh=surface_mesh, & + option_path=option_path) + return + end if + end do + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Hasta la vista") + + end subroutine get_scalar_boundary_condition_by_name + + subroutine get_vector_boundary_condition_by_name(field, name, & + type, surface_element_list, surface_node_list, applies, surface_mesh, & + option_path) + !!< Get boundary condition of a vector field + type(vector_field), intent(in):: field + !! which boundary condition + character(len=*), intent(in):: name + !! type of b.c., any of: ... + character(len=*), intent(out), optional:: type + !! pointer to list of surface elements where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_element_list + !! pointer to list of surface nodes where this b.c. is applied + integer, dimension(:), pointer, optional:: surface_node_list + !! vector components to which this b.c. applies + logical, dimension(:), intent(out), optional:: applies + !! surface mesh on which surface fields can be allocated + type(mesh_type), pointer, optional:: surface_mesh + !! option_path for the bc + character(len=*), intent(out), optional:: option_path + + integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + call get_vector_boundary_condition_by_number(field, i, & + type, surface_element_list=surface_element_list, & + surface_node_list=surface_node_list, & + applies=applies, surface_mesh=surface_mesh, & + option_path=option_path) + return + end if + end do + ewrite(-1,*) 'Unknown boundary condition: ', name + FLAbort("Hasta la vista") + + end subroutine get_vector_boundary_condition_by_name + + subroutine get_periodic_boundary_condition(mesh, periodic_bc_list) + !!< Gets a list of the surface elements which are periodic - subroutine get_periodic_boundary_condition(mesh, periodic_bc_list) - !!< Gets a list of the surface elements which are periodic + !! mesh on which periodicness is to be evaluated + type(mesh_type), intent(inout):: mesh + !! For each surface_element returns true for periodic boundaries + !! or false, if not: + logical, dimension(:), intent(out):: periodic_bc_list - !! mesh on which periodicness is to be evaluated - type(mesh_type), intent(inout):: mesh - !! For each surface_element returns true for periodic boundaries - !! or false, if not: - logical, dimension(:), intent(out):: periodic_bc_list + integer sele - integer sele + integer, dimension(:), pointer :: neigh + integer :: l_face_number, ele - integer, dimension(:), pointer :: neigh - integer :: l_face_number, ele + periodic_bc_list = .false. - periodic_bc_list = .false. + do sele = 1, surface_element_count(mesh) + l_face_number = local_face_number(mesh, sele) + ele=face_ele(mesh, sele) + neigh => ele_neigh(mesh, ele) - do sele = 1, surface_element_count(mesh) - l_face_number = local_face_number(mesh, sele) - ele=face_ele(mesh, sele) - neigh => ele_neigh(mesh, ele) + if(neigh(l_face_number)>0) then - if(neigh(l_face_number)>0) then + periodic_bc_list(sele)=.true. - periodic_bc_list(sele)=.true. + end if + end do + end subroutine get_periodic_boundary_condition + + subroutine get_entire_scalar_boundary_condition(field, & + types, boundary_value, bc_type_list, bc_number_list, boundary_second_value) + !!< Gets the boundary conditions on the entire surface mesh for all + !!< bc types requested + + !! field of which boundary conditions are retrieved + type(scalar_field), intent(in), target :: field + !! list of bc types you want (others are ignored) + character(len=*), dimension(:), intent(in):: types + !! A field over the entire surface containing the boundary values + !! for the bcs of the type requested. This field is defined on a + !! dg surface mesh so that it can deal with discontinuities between + !! differen boundary conditions. + !! The ordering of the (surface) elements in this mesh is the same + !! as the ordering of the surface elements (faces) of the given + !! field. + !! This field should be deallocated after use. + type(scalar_field), intent(out):: boundary_value + !! For each surface_element returns the position in the types argument list, + !! thus identifying the applied boundary condition type, + !! or zero, if no bc of the requested types are applied to this face: + integer, dimension(:), intent(out):: bc_type_list + !! For each surface_element returns the number of the boundary condition, + !! which can be used to extract further information + !! BC can be set for each component separately, so ndim x surface_element_count() + integer, dimension(:), intent(out), optional:: bc_number_list + !! A second field over the entire surface containing another associated + !! boundary values for the robin type BC. + !! This field should be deallocated after use. + type(scalar_field), intent(out), optional :: boundary_second_value + + type(scalar_field), pointer:: surface_field + type(scalar_field), pointer:: surface_field_second_value + type(mesh_type), pointer:: surface_mesh, volume_mesh + character(len=FIELD_NAME_LEN) bctype + character(len=1024) name + integer, dimension(:), pointer:: surface_element_list + integer i, j, k, sele + + integer, dimension(:), pointer :: neigh + integer :: l_face_number, ele + + volume_mesh => field%mesh + surface_mesh => get_dg_surface_mesh(volume_mesh) + + call allocate(boundary_value, surface_mesh, name=trim(field%name)//"EntireBC") + call zero(boundary_value) + bc_type_list=0 + + if (present(boundary_second_value)) then + call allocate(boundary_second_value, surface_mesh, name=trim(field%name)//"EntireBCSecondValue") + call zero(boundary_second_value) end if - end do - - end subroutine get_periodic_boundary_condition - - subroutine get_entire_scalar_boundary_condition(field, & - types, boundary_value, bc_type_list, bc_number_list, boundary_second_value) - !!< Gets the boundary conditions on the entire surface mesh for all - !!< bc types requested - - !! field of which boundary conditions are retrieved - type(scalar_field), intent(in), target :: field - !! list of bc types you want (others are ignored) - character(len=*), dimension(:), intent(in):: types - !! A field over the entire surface containing the boundary values - !! for the bcs of the type requested. This field is defined on a - !! dg surface mesh so that it can deal with discontinuities between - !! differen boundary conditions. - !! The ordering of the (surface) elements in this mesh is the same - !! as the ordering of the surface elements (faces) of the given - !! field. - !! This field should be deallocated after use. - type(scalar_field), intent(out):: boundary_value - !! For each surface_element returns the position in the types argument list, - !! thus identifying the applied boundary condition type, - !! or zero, if no bc of the requested types are applied to this face: - integer, dimension(:), intent(out):: bc_type_list - !! For each surface_element returns the number of the boundary condition, - !! which can be used to extract further information - !! BC can be set for each component separately, so ndim x surface_element_count() - integer, dimension(:), intent(out), optional:: bc_number_list - !! A second field over the entire surface containing another associated - !! boundary values for the robin type BC. - !! This field should be deallocated after use. - type(scalar_field), intent(out), optional :: boundary_second_value - - type(scalar_field), pointer:: surface_field - type(scalar_field), pointer:: surface_field_second_value - type(mesh_type), pointer:: surface_mesh, volume_mesh - character(len=FIELD_NAME_LEN) bctype - character(len=1024) name - integer, dimension(:), pointer:: surface_element_list - integer i, j, k, sele - - integer, dimension(:), pointer :: neigh - integer :: l_face_number, ele - - volume_mesh => field%mesh - surface_mesh => get_dg_surface_mesh(volume_mesh) - - call allocate(boundary_value, surface_mesh, name=trim(field%name)//"EntireBC") - call zero(boundary_value) - bc_type_list=0 - - if (present(boundary_second_value)) then - call allocate(boundary_second_value, surface_mesh, name=trim(field%name)//"EntireBCSecondValue") - call zero(boundary_second_value) - end if - - do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_element_list=surface_element_list,name=name) - - ! see if we're interested in this one, if not skip it - do j=1, size(types) - if (trim(types(j))==trim(bctype)) exit - end do - if (j>size(types)) cycle - - if (associated(field%bc%boundary_condition(i)%surface_fields)) then - ! extract 1st surface field - surface_field => field%bc%boundary_condition(i)%surface_fields(1) - ! extract 2nd surface field if needed for robin BC type - if (trim(bctype) == 'robin') then - if (present(boundary_second_value)) then - if (size(field%bc%boundary_condition(i)%surface_fields) > 1) then - surface_field_second_value => field%bc%boundary_condition(i)%surface_fields(2) - else - FLAbort('Boundary condition surface_fields not off sufficient size for assigning robin second boundary value') - end if - else - FLAbort('Robin boundary condition cannot be assigned without the optional argument boundary_second_value') - end if - else - nullify(surface_field_second_value) - end if - else - nullify(surface_field) - nullify(surface_field_second_value) - end if - - do k=1, size(surface_element_list) - sele=surface_element_list(k) - - if (bc_type_list(sele)/=0) then - ewrite(0,*) 'Requested types:', types - ewrite(0,*) 'Of these boundary condition types only one may be applied' - ewrite(0,*) 'to each surface element.' - ewrite(0,*) 'Surface element nr.:', sele - ewrite(0,*) 'has types', types(bc_type_list(sele)), bctype - ewrite(0,*) 'on field: ', field%name - ewrite(0,*) 'with name: ',name - FLAbort("Can't have that.") - end if - bc_type_list(sele)=j - if (present(bc_number_list)) then - bc_number_list(sele)=i - end if - - if (associated(surface_field)) then - call set(boundary_value, ele_nodes(surface_mesh, sele), & - ele_val(surface_field, k)) - end if - - if (associated(surface_field_second_value)) then - call set(boundary_second_value, ele_nodes(surface_mesh, sele), & - ele_val(surface_field_second_value, k)) - end if - - end do - end do - - ! now let's search for internal bcs (this includes periodic boundaries) - do j=1, size(types) - if (trim(types(j))=="internal") exit - end do - if (j<=size(types)) then - do sele = 1, surface_element_count(field) - ele = face_ele(field, sele) - l_face_number = local_face_number(field, sele) - neigh => ele_neigh(field, ele) - - if(neigh(l_face_number)>0) then - - if (bc_type_list(sele)==0) then - ! an internal (or periodic) boundary condition only - ! gets assigned if no other boundary condition type - ! has been assigned to this surface element - bc_type_list(sele)=j - end if - - end if + + do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_element_list=surface_element_list,name=name) + + ! see if we're interested in this one, if not skip it + do j=1, size(types) + if (trim(types(j))==trim(bctype)) exit + end do + if (j>size(types)) cycle + + if (associated(field%bc%boundary_condition(i)%surface_fields)) then + ! extract 1st surface field + surface_field => field%bc%boundary_condition(i)%surface_fields(1) + ! extract 2nd surface field if needed for robin BC type + if (trim(bctype) == 'robin') then + if (present(boundary_second_value)) then + if (size(field%bc%boundary_condition(i)%surface_fields) > 1) then + surface_field_second_value => field%bc%boundary_condition(i)%surface_fields(2) + else + FLAbort('Boundary condition surface_fields not off sufficient size for assigning robin second boundary value') + end if + else + FLAbort('Robin boundary condition cannot be assigned without the optional argument boundary_second_value') + end if + else + nullify(surface_field_second_value) + end if + else + nullify(surface_field) + nullify(surface_field_second_value) + end if + + do k=1, size(surface_element_list) + sele=surface_element_list(k) + + if (bc_type_list(sele)/=0) then + ewrite(0,*) 'Requested types:', types + ewrite(0,*) 'Of these boundary condition types only one may be applied' + ewrite(0,*) 'to each surface element.' + ewrite(0,*) 'Surface element nr.:', sele + ewrite(0,*) 'has types', types(bc_type_list(sele)), bctype + ewrite(0,*) 'on field: ', field%name + ewrite(0,*) 'with name: ',name + FLAbort("Can't have that.") + end if + bc_type_list(sele)=j + if (present(bc_number_list)) then + bc_number_list(sele)=i + end if + + if (associated(surface_field)) then + call set(boundary_value, ele_nodes(surface_mesh, sele), & + ele_val(surface_field, k)) + end if + + if (associated(surface_field_second_value)) then + call set(boundary_second_value, ele_nodes(surface_mesh, sele), & + ele_val(surface_field_second_value, k)) + end if + + end do end do - end if - - end subroutine get_entire_scalar_boundary_condition - - subroutine get_entire_vector_boundary_condition(field, & - types, boundary_value, bc_type_list, bc_number_list) - !!< Gets the boundary conditions on the entire surface mesh for all - !!< bc types requested - - !! field of which boundary conditions are retrieved - type(vector_field), intent(in), target :: field - !! list of bc types you want (others are ignored) - character(len=*), dimension(:), intent(in):: types - !! A field over the entire surface containing the boundary values - !! for the bcs of the type requested. This field is defined on a - !! dg surface mesh so that it can deal with discontinuities between - !! differen boundary conditions. - !! The ordering of the (surface) elements in this mesh is the same - !! as the ordering of the surface elements (faces) of the given - !! field. - !! This field should be deallocated after use. - type(vector_field), intent(out):: boundary_value - !! For each surface_element returns the position in the types argument list, - !! thus identifying the applied boundary condition type, - !! or zero, if no bc of the requested types are applied to this face. - !! BC can be set for each component separately, so ndim x surface_element_count() - integer, dimension(:,:), intent(out):: bc_type_list - !! For each surface_element returns the number of the boundary condition, - !! which can be used to extract further information - !! BC can be set for each component separately, so ndim x surface_element_count() - integer, dimension(:,:), intent(out), optional:: bc_number_list - - type(vector_field), pointer:: surface_field - type(mesh_type), pointer:: surface_mesh, volume_mesh - character(len=FIELD_NAME_LEN) bctype - integer, dimension(:), pointer:: surface_element_list - logical, dimension(field%dim):: applies - integer i, j, k, n, sele - - integer, dimension(:), pointer :: neigh - integer :: l_face_number, ele - - volume_mesh => field%mesh - surface_mesh => get_dg_surface_mesh(volume_mesh) - - call allocate(boundary_value, field%dim, surface_mesh, & - name=trim(field%name)//"EntireBC") - call zero(boundary_value) - bc_type_list=0 - - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, applies=applies, & - surface_element_list=surface_element_list) - - ! see if we're interested in this one, if not skip it - do j=1, size(types) - if (trim(types(j))==trim(bctype)) exit - end do - if (j>size(types)) cycle - - if (associated(field%bc%boundary_condition(i)%surface_fields)) then - ! extract 1st surface field - surface_field => field%bc%boundary_condition(i)%surface_fields(1) - else - nullify(surface_field) - end if - - faceloop: do k=1, size(surface_element_list) - sele=surface_element_list(k) - - do n=1, field%dim - if (applies(n)) then - if (bc_type_list(n, sele)/=0) then - ewrite(0,*) 'Requested types:', types - ewrite(0,*) 'Of these boundary condition types' - ewrite(0,*) 'only one may be applied' - ewrite(0,*) 'to each surface element.' - ewrite(0,*) 'Surface element nr.:', sele - ewrite(0,*) 'Component nr:', n - ewrite(0,*) 'has types', types(bc_type_list(j, sele)), bctype - FLAbort("Can't have that.") - end if - bc_type_list(n, sele)=j - if (present(bc_number_list)) then - bc_number_list(n,sele)=i - end if - - if (associated(surface_field)) then - call set(boundary_value, n, ele_nodes(surface_mesh, sele), & - ele_val(surface_field, n, k)) - end if - end if - end do - - end do faceloop - end do bcloop - - ! now let's search for internal bcs (this includes periodic boundaries) - do j=1, size(types) - if (trim(types(j))=="internal") exit - end do - if (j<=size(types)) then - do sele = 1, surface_element_count(field) - ele = face_ele(field, sele) - l_face_number = local_face_number(field, sele) - neigh => ele_neigh(field, ele) - - if(neigh(l_face_number)>0) then - - if (all(bc_type_list(:,sele)==0)) then - ! an internal (or periodic) boundary condition only - ! gets assigned if no other boundary condition type - ! has been assigned to this surface element - bc_type_list(:,sele)=j - end if - - end if + + ! now let's search for internal bcs (this includes periodic boundaries) + do j=1, size(types) + if (trim(types(j))=="internal") exit end do - end if - - end subroutine get_entire_vector_boundary_condition - - function get_dg_surface_mesh(mesh) - !! Returns a pointer a DG version of the entire surface mesh - !! This DG surface mesh can be used to store boundary condition values on - !! so it can deal with discontinuities in boundary condition values. - !! If this dg surface mesh does not yet exist, it's created here. It - !! will be cached on the mesh for later calls to this routine and only - !! be deallocated upon deallocation of the entire mesh. - !! - !! Even in the case that the mesh is DG itself, it may still require a new dg surface mesh - !! as the original surface mesh may not be dg at corners (which would prevent different - !! bcs from being applied on elements either side of the corner). Therefore, to be - !! safe a new one is created. - type(mesh_type), intent(inout):: mesh - type(mesh_type), pointer:: get_dg_surface_mesh - - if (.not. has_faces(mesh)) then - FLAbort("A mesh%faces structure is needed for get_dg_surface_mesh") - end if - - if (.not. associated(mesh%faces%dg_surface_mesh)) then - allocate(mesh%faces%dg_surface_mesh) - mesh%faces%dg_surface_mesh=make_mesh(mesh%faces%surface_mesh, mesh%faces%shape, & - continuity=-1, name=trim(mesh%name)//"DGSurfaceMesh") - end if - - get_dg_surface_mesh => mesh%faces%dg_surface_mesh - - end function get_dg_surface_mesh - - subroutine get_scalar_boundary_condition_nodes(field, types, bc_type_node_list) - ! gets the boundary conditions on the entire surface mesh for all - ! bc types requested - ! field of which boundary conditions are retrieved - type(scalar_field), intent(in):: field - ! bc type you want (others are ignored) - character(len=*), dimension(:), intent(in):: types - ! list of nodes on which boundary condition is applied - integer, dimension(:), intent(out):: bc_type_node_list - - integer, dimension(:), pointer:: surface_node_list - integer i, j, l_face_number, sele, ele - integer, dimension(:), pointer :: neigh - - bc_type_node_list=0 - - do i=1, get_boundary_condition_count(field) - do j=1, size(types) - if (types(j)==field%bc%boundary_condition(i)%type) exit - end do - - if (j>size(types)) cycle - - call get_boundary_condition(field, i, & - surface_node_list=surface_node_list) - - if(any((bc_type_node_list(surface_node_list)/=0) .and. & - (bc_type_node_list(surface_node_list)/=j))) then + if (j<=size(types)) then + do sele = 1, surface_element_count(field) + ele = face_ele(field, sele) + l_face_number = local_face_number(field, sele) + neigh => ele_neigh(field, ele) + + if(neigh(l_face_number)>0) then + + if (bc_type_list(sele)==0) then + ! an internal (or periodic) boundary condition only + ! gets assigned if no other boundary condition type + ! has been assigned to this surface element + bc_type_list(sele)=j + end if + + end if + end do + end if + + end subroutine get_entire_scalar_boundary_condition + + subroutine get_entire_vector_boundary_condition(field, & + types, boundary_value, bc_type_list, bc_number_list) + !!< Gets the boundary conditions on the entire surface mesh for all + !!< bc types requested + + !! field of which boundary conditions are retrieved + type(vector_field), intent(in), target :: field + !! list of bc types you want (others are ignored) + character(len=*), dimension(:), intent(in):: types + !! A field over the entire surface containing the boundary values + !! for the bcs of the type requested. This field is defined on a + !! dg surface mesh so that it can deal with discontinuities between + !! differen boundary conditions. + !! The ordering of the (surface) elements in this mesh is the same + !! as the ordering of the surface elements (faces) of the given + !! field. + !! This field should be deallocated after use. + type(vector_field), intent(out):: boundary_value + !! For each surface_element returns the position in the types argument list, + !! thus identifying the applied boundary condition type, + !! or zero, if no bc of the requested types are applied to this face. + !! BC can be set for each component separately, so ndim x surface_element_count() + integer, dimension(:,:), intent(out):: bc_type_list + !! For each surface_element returns the number of the boundary condition, + !! which can be used to extract further information + !! BC can be set for each component separately, so ndim x surface_element_count() + integer, dimension(:,:), intent(out), optional:: bc_number_list + + type(vector_field), pointer:: surface_field + type(mesh_type), pointer:: surface_mesh, volume_mesh + character(len=FIELD_NAME_LEN) bctype + integer, dimension(:), pointer:: surface_element_list + logical, dimension(field%dim):: applies + integer i, j, k, n, sele + + integer, dimension(:), pointer :: neigh + integer :: l_face_number, ele + + volume_mesh => field%mesh + surface_mesh => get_dg_surface_mesh(volume_mesh) + + call allocate(boundary_value, field%dim, surface_mesh, & + name=trim(field%name)//"EntireBC") + call zero(boundary_value) + bc_type_list=0 + + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, applies=applies, & + surface_element_list=surface_element_list) + + ! see if we're interested in this one, if not skip it + do j=1, size(types) + if (trim(types(j))==trim(bctype)) exit + end do + if (j>size(types)) cycle + + if (associated(field%bc%boundary_condition(i)%surface_fields)) then + ! extract 1st surface field + surface_field => field%bc%boundary_condition(i)%surface_fields(1) + else + nullify(surface_field) + end if + + faceloop: do k=1, size(surface_element_list) + sele=surface_element_list(k) + + do n=1, field%dim + if (applies(n)) then + if (bc_type_list(n, sele)/=0) then + ewrite(0,*) 'Requested types:', types + ewrite(0,*) 'Of these boundary condition types' + ewrite(0,*) 'only one may be applied' + ewrite(0,*) 'to each surface element.' + ewrite(0,*) 'Surface element nr.:', sele + ewrite(0,*) 'Component nr:', n + ewrite(0,*) 'has types', types(bc_type_list(j, sele)), bctype + FLAbort("Can't have that.") + end if + bc_type_list(n, sele)=j + if (present(bc_number_list)) then + bc_number_list(n,sele)=i + end if + + if (associated(surface_field)) then + call set(boundary_value, n, ele_nodes(surface_mesh, sele), & + ele_val(surface_field, n, k)) + end if + end if + end do + + end do faceloop + end do bcloop + + ! now let's search for internal bcs (this includes periodic boundaries) + do j=1, size(types) + if (trim(types(j))=="internal") exit + end do + if (j<=size(types)) then + do sele = 1, surface_element_count(field) + ele = face_ele(field, sele) + l_face_number = local_face_number(field, sele) + neigh => ele_neigh(field, ele) + + if(neigh(l_face_number)>0) then + + if (all(bc_type_list(:,sele)==0)) then + ! an internal (or periodic) boundary condition only + ! gets assigned if no other boundary condition type + ! has been assigned to this surface element + bc_type_list(:,sele)=j + end if + + end if + end do + end if + + end subroutine get_entire_vector_boundary_condition + + function get_dg_surface_mesh(mesh) + !! Returns a pointer a DG version of the entire surface mesh + !! This DG surface mesh can be used to store boundary condition values on + !! so it can deal with discontinuities in boundary condition values. + !! If this dg surface mesh does not yet exist, it's created here. It + !! will be cached on the mesh for later calls to this routine and only + !! be deallocated upon deallocation of the entire mesh. + !! + !! Even in the case that the mesh is DG itself, it may still require a new dg surface mesh + !! as the original surface mesh may not be dg at corners (which would prevent different + !! bcs from being applied on elements either side of the corner). Therefore, to be + !! safe a new one is created. + type(mesh_type), intent(inout):: mesh + type(mesh_type), pointer:: get_dg_surface_mesh + + if (.not. has_faces(mesh)) then + FLAbort("A mesh%faces structure is needed for get_dg_surface_mesh") + end if + + if (.not. associated(mesh%faces%dg_surface_mesh)) then + allocate(mesh%faces%dg_surface_mesh) + mesh%faces%dg_surface_mesh=make_mesh(mesh%faces%surface_mesh, mesh%faces%shape, & + continuity=-1, name=trim(mesh%name)//"DGSurfaceMesh") + end if + + get_dg_surface_mesh => mesh%faces%dg_surface_mesh + + end function get_dg_surface_mesh + + subroutine get_scalar_boundary_condition_nodes(field, types, bc_type_node_list) + ! gets the boundary conditions on the entire surface mesh for all + ! bc types requested + ! field of which boundary conditions are retrieved + type(scalar_field), intent(in):: field + ! bc type you want (others are ignored) + character(len=*), dimension(:), intent(in):: types + ! list of nodes on which boundary condition is applied + integer, dimension(:), intent(out):: bc_type_node_list + + integer, dimension(:), pointer:: surface_node_list + integer i, j, l_face_number, sele, ele + integer, dimension(:), pointer :: neigh + + bc_type_node_list=0 + + do i=1, get_boundary_condition_count(field) + do j=1, size(types) + if (types(j)==field%bc%boundary_condition(i)%type) exit + end do + + if (j>size(types)) cycle + + call get_boundary_condition(field, i, & + surface_node_list=surface_node_list) + + if(any((bc_type_node_list(surface_node_list)/=0) .and. & + (bc_type_node_list(surface_node_list)/=j))) then ewrite(0,*) 'Requested types:', types ewrite(0,*) 'Of these boundary condition types only one' ewrite(0,*) 'may be applied to each node.' FLAbort("Sorry!") - end if + end if - bc_type_node_list(surface_node_list) = j + bc_type_node_list(surface_node_list) = j - end do + end do - ! now let's search for internal bcs (this includes periodic boundaries) + ! now let's search for internal bcs (this includes periodic boundaries) do j=1, size(types) - if (trim(types(j))=="internal") exit + if (trim(types(j))=="internal") exit end do if (j<=size(types)) then - do sele = 1, surface_element_count(field) - ele = face_ele(field, sele) - l_face_number = local_face_number(field, sele) - neigh => ele_neigh(field, ele) - - if(neigh(l_face_number)>0) then - - if (all((bc_type_node_list(face_global_nodes(field, sele))==0).or.& - (bc_type_node_list(face_global_nodes(field, sele))==j))) then - ! an internal (or periodic) boundary condition only - ! gets assigned if no other boundary condition type - ! has been assigned to these surface nodes (that isn't itself - ! an internal (or periodic) boundary condition) - bc_type_node_list(face_global_nodes(field, sele))=j - end if + do sele = 1, surface_element_count(field) + ele = face_ele(field, sele) + l_face_number = local_face_number(field, sele) + neigh => ele_neigh(field, ele) + + if(neigh(l_face_number)>0) then + + if (all((bc_type_node_list(face_global_nodes(field, sele))==0).or.& + (bc_type_node_list(face_global_nodes(field, sele))==j))) then + ! an internal (or periodic) boundary condition only + ! gets assigned if no other boundary condition type + ! has been assigned to these surface nodes (that isn't itself + ! an internal (or periodic) boundary condition) + bc_type_node_list(face_global_nodes(field, sele))=j + end if - end if - end do + end if + end do end if - end subroutine get_scalar_boundary_condition_nodes - - subroutine get_vector_boundary_condition_nodes(field, types, bc_type_node_list) - ! gets the boundary conditions on the entire surface mesh for all - ! bc types requested - ! field of which boundary conditions are retrieved - type(vector_field), intent(in):: field - ! bc type you want (others are ignored) - character(len=*), dimension(:), intent(in):: types - ! list of nodes on which boundary condition is applied - integer, dimension(:,:), intent(out):: bc_type_node_list - - logical, dimension(field%dim):: applies - integer, dimension(:), pointer:: surface_node_list - integer i, j, k, ele, sele, l_face_number - integer, dimension(:), pointer :: neigh - - bc_type_node_list=0 - - do i=1, get_boundary_condition_count(field) - do j=1, size(types) - if (types(j)==field%bc%boundary_condition(i)%type) exit - end do - - if (j>size(types)) cycle - - call get_boundary_condition(field, i, & - surface_node_list=surface_node_list, & - applies=applies) - - do k = 1, field%dim - if(applies(k)) then - if(any((bc_type_node_list(k,surface_node_list)/=0) .and. & - (bc_type_node_list(k,surface_node_list)/=j))) then - ewrite(0,*) 'Requested types:', types - ewrite(0,*) 'Of these boundary condition types only one' - ewrite(0,*) 'may be applied to each node.' - FLAbort("Sorry!") - end if + end subroutine get_scalar_boundary_condition_nodes + + subroutine get_vector_boundary_condition_nodes(field, types, bc_type_node_list) + ! gets the boundary conditions on the entire surface mesh for all + ! bc types requested + ! field of which boundary conditions are retrieved + type(vector_field), intent(in):: field + ! bc type you want (others are ignored) + character(len=*), dimension(:), intent(in):: types + ! list of nodes on which boundary condition is applied + integer, dimension(:,:), intent(out):: bc_type_node_list - bc_type_node_list(k,surface_node_list) = j - end if - end do + logical, dimension(field%dim):: applies + integer, dimension(:), pointer:: surface_node_list + integer i, j, k, ele, sele, l_face_number + integer, dimension(:), pointer :: neigh - end do + bc_type_node_list=0 + + do i=1, get_boundary_condition_count(field) + do j=1, size(types) + if (types(j)==field%bc%boundary_condition(i)%type) exit + end do + + if (j>size(types)) cycle + + call get_boundary_condition(field, i, & + surface_node_list=surface_node_list, & + applies=applies) + + do k = 1, field%dim + if(applies(k)) then + if(any((bc_type_node_list(k,surface_node_list)/=0) .and. & + (bc_type_node_list(k,surface_node_list)/=j))) then + ewrite(0,*) 'Requested types:', types + ewrite(0,*) 'Of these boundary condition types only one' + ewrite(0,*) 'may be applied to each node.' + FLAbort("Sorry!") + end if + + bc_type_node_list(k,surface_node_list) = j + end if + end do + + end do ! now let's search for internal bcs (this includes periodic boundaries) do j=1, size(types) - if (trim(types(j))=="internal") exit + if (trim(types(j))=="internal") exit end do if (j<=size(types)) then - do sele = 1, surface_element_count(field) - ele = face_ele(field, sele) - l_face_number = local_face_number(field, sele) - neigh => ele_neigh(field, ele) - - if(neigh(l_face_number)>0) then - - if (all((bc_type_node_list(:,face_global_nodes(field, sele))==0).or.& - (bc_type_node_list(:,face_global_nodes(field, sele))==j))) then - ! an internal (or periodic) boundary condition only - ! gets assigned if no other boundary condition type - ! has been assigned to these surface nodes (that isn't itself - ! an internal (or periodic) boundary condition) - bc_type_node_list(:,face_global_nodes(field, sele))=j + do sele = 1, surface_element_count(field) + ele = face_ele(field, sele) + l_face_number = local_face_number(field, sele) + neigh => ele_neigh(field, ele) + + if(neigh(l_face_number)>0) then + + if (all((bc_type_node_list(:,face_global_nodes(field, sele))==0).or.& + (bc_type_node_list(:,face_global_nodes(field, sele))==j))) then + ! an internal (or periodic) boundary condition only + ! gets assigned if no other boundary condition type + ! has been assigned to these surface nodes (that isn't itself + ! an internal (or periodic) boundary condition) + bc_type_node_list(:,face_global_nodes(field, sele))=j + end if + end if + end do + end if - end if - end do + end subroutine get_vector_boundary_condition_nodes + + subroutine set_reference_node_scalar(matrix, node, rhs, reference_value, reference_node_owned) + !!< Sets a reference node for which the value is fixed in the equation + !!< This is typically done for a Poisson equation with all Neumann + !!< bcs to eliminate the spurious freedom of adding a constant value + !!< to the solution. + type(csr_matrix), intent(inout) :: matrix + integer, intent(in):: node + !! if rhs is not provided, you have to make sure the rhs at + !! the reference node has the right value, usually 0, yourself: + type(scalar_field), optional, intent(inout) :: rhs + !! by default the field gets set to 0 at the reference node + real, optional, intent(in) :: reference_value + !! in parallel all processes need to call this routine, only one + !! of them actually sets the reference node - this processor should + !! call with reference_node_owned=.true., other processes with reference_node_owned=.false. + !! if reference_node_owned is not present, we will assume that only process with rank 0 + !! owns and thus sets the reference node + logical, optional, intent(in) :: reference_node_owned + + logical:: lnode_owned + + if (present(reference_node_owned)) then + lnode_owned = reference_node_owned + else + lnode_owned = GetProcNo()==1 end if - end subroutine get_vector_boundary_condition_nodes - - subroutine set_reference_node_scalar(matrix, node, rhs, reference_value, reference_node_owned) - !!< Sets a reference node for which the value is fixed in the equation - !!< This is typically done for a Poisson equation with all Neumann - !!< bcs to eliminate the spurious freedom of adding a constant value - !!< to the solution. - type(csr_matrix), intent(inout) :: matrix - integer, intent(in):: node - !! if rhs is not provided, you have to make sure the rhs at - !! the reference node has the right value, usually 0, yourself: - type(scalar_field), optional, intent(inout) :: rhs - !! by default the field gets set to 0 at the reference node - real, optional, intent(in) :: reference_value - !! in parallel all processes need to call this routine, only one - !! of them actually sets the reference node - this processor should - !! call with reference_node_owned=.true., other processes with reference_node_owned=.false. - !! if reference_node_owned is not present, we will assume that only process with rank 0 - !! owns and thus sets the reference node - logical, optional, intent(in) :: reference_node_owned - - logical:: lnode_owned - - if (present(reference_node_owned)) then - lnode_owned = reference_node_owned - else - lnode_owned = GetProcNo()==1 - end if - - if (.not. lnode_owned) then - ! Other processors still need to have the inactive mask, even if - ! it's empty. - call initialise_inactive(matrix) - return - end if - - call set_inactive(matrix, node) - - if (present(rhs)) then - if (present(reference_value)) then - call set(rhs, node, reference_value) - else - call set(rhs, node, 0.0) - end if - end if - - end subroutine set_reference_node_scalar - - subroutine set_reference_node_vector_petsc(matrix, node, rhs, mask, reference_value, reference_node_owned) - !!< Sets a reference node for which the value is fixed in the equation - !!< This is typically done for a Poisson equation with all Neumann - !!< bcs to eliminate the spurious freedom of adding a constant value - !!< to the solution. - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(in):: node - !! if rhs is not provided, you have to make sure the rhs at - !! the reference node has the right value, usually 0, yourself: - type(vector_field), optional, intent(inout) :: rhs - !! mask returns true for blocks in which the reference node is to be set - !! (false for those in which it will not be set) - logical, dimension(blocks(matrix, 1)), intent(in) :: mask - !! by default the field gets set to 0 at the reference node - real, dimension(blocks(matrix,1)), optional, intent(in) :: reference_value - !! in parallel all processes need to call this routine, only one - !! of them actually sets the reference node - this processor should - !! call with reference_node_owned=.true., other processes with reference_node_owned=.false. - !! if reference_node_owned is not present, we will assume that only process with rank 0 - !! owns and thus sets the reference node - logical, optional, intent(in) :: reference_node_owned - - logical:: lnode_owned - - !! iterator - integer :: k - - if (present(reference_node_owned)) then - lnode_owned = reference_node_owned - else - lnode_owned = GetProcNo()==1 - end if - - if (.not. lnode_owned) return - - assert(blocks(matrix,1)==blocks(matrix,2)) - do k = 1, blocks(matrix, 1) - if(mask(k)) then - call addto_diag(matrix, k, k, node, INFINITY) + if (.not. lnode_owned) then + ! Other processors still need to have the inactive mask, even if + ! it's empty. + call initialise_inactive(matrix) + return end if - end do - if ((present(rhs)).and.(present(reference_value))) then - assert(rhs%dim==blocks(matrix,1)) - call addto(rhs, node, reference_value*INFINITY) - end if + call set_inactive(matrix, node) - end subroutine set_reference_node_vector_petsc + if (present(rhs)) then + if (present(reference_value)) then + call set(rhs, node, reference_value) + else + call set(rhs, node, 0.0) + end if + end if - logical function has_boundary_condition_scalar(field, type) - !!< logical function that tells whether any of the bcs of a field - !!< is of type 'type' - type(scalar_field), intent(in):: field - character(len=*), intent(in):: type + end subroutine set_reference_node_scalar + + subroutine set_reference_node_vector_petsc(matrix, node, rhs, mask, reference_value, reference_node_owned) + !!< Sets a reference node for which the value is fixed in the equation + !!< This is typically done for a Poisson equation with all Neumann + !!< bcs to eliminate the spurious freedom of adding a constant value + !!< to the solution. + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(in):: node + !! if rhs is not provided, you have to make sure the rhs at + !! the reference node has the right value, usually 0, yourself: + type(vector_field), optional, intent(inout) :: rhs + !! mask returns true for blocks in which the reference node is to be set + !! (false for those in which it will not be set) + logical, dimension(blocks(matrix, 1)), intent(in) :: mask + !! by default the field gets set to 0 at the reference node + real, dimension(blocks(matrix,1)), optional, intent(in) :: reference_value + !! in parallel all processes need to call this routine, only one + !! of them actually sets the reference node - this processor should + !! call with reference_node_owned=.true., other processes with reference_node_owned=.false. + !! if reference_node_owned is not present, we will assume that only process with rank 0 + !! owns and thus sets the reference node + logical, optional, intent(in) :: reference_node_owned + + logical:: lnode_owned + + !! iterator + integer :: k + + if (present(reference_node_owned)) then + lnode_owned = reference_node_owned + else + lnode_owned = GetProcNo()==1 + end if - type(scalar_boundary_condition), pointer :: this_bc - integer i + if (.not. lnode_owned) return - if (.not.associated(field%bc%boundary_condition)) then - has_boundary_condition_scalar=.false. - return - end if + assert(blocks(matrix,1)==blocks(matrix,2)) + do k = 1, blocks(matrix, 1) + if(mask(k)) then + call addto_diag(matrix, k, k, node, INFINITY) + end if + end do + + if ((present(rhs)).and.(present(reference_value))) then + assert(rhs%dim==blocks(matrix,1)) + call addto(rhs, node, reference_value*INFINITY) + end if + + end subroutine set_reference_node_vector_petsc - bcloop: do i=1, size(field%bc%boundary_condition) - this_bc=>field%bc%boundary_condition(i) + logical function has_boundary_condition_scalar(field, type) + !!< logical function that tells whether any of the bcs of a field + !!< is of type 'type' + type(scalar_field), intent(in):: field + character(len=*), intent(in):: type - if (this_bc%type==type) then + type(scalar_boundary_condition), pointer :: this_bc + integer i - has_boundary_condition_scalar=.true. + if (.not.associated(field%bc%boundary_condition)) then + has_boundary_condition_scalar=.false. return + end if - end if + bcloop: do i=1, size(field%bc%boundary_condition) + this_bc=>field%bc%boundary_condition(i) - end do bcloop + if (this_bc%type==type) then - has_boundary_condition_scalar=.false. + has_boundary_condition_scalar=.true. + return - end function has_boundary_condition_scalar + end if - logical function has_boundary_condition_vector(field, type) - !!< logical function that tells whether any of the bcs of a field - !!< is of type 'type' - type(vector_field), intent(in):: field - character(len=*), intent(in):: type + end do bcloop - type(vector_boundary_condition), pointer :: this_bc - integer i + has_boundary_condition_scalar=.false. - if (.not.associated(field%bc%boundary_condition)) then - has_boundary_condition_vector=.false. - return - end if + end function has_boundary_condition_scalar - bcloop: do i=1, size(field%bc%boundary_condition) - this_bc=>field%bc%boundary_condition(i) + logical function has_boundary_condition_vector(field, type) + !!< logical function that tells whether any of the bcs of a field + !!< is of type 'type' + type(vector_field), intent(in):: field + character(len=*), intent(in):: type - if (this_bc%type==type) then + type(vector_boundary_condition), pointer :: this_bc + integer i - has_boundary_condition_vector=.true. + if (.not.associated(field%bc%boundary_condition)) then + has_boundary_condition_vector=.false. return + end if - end if + bcloop: do i=1, size(field%bc%boundary_condition) + this_bc=>field%bc%boundary_condition(i) - end do bcloop + if (this_bc%type==type) then - has_boundary_condition_vector=.false. + has_boundary_condition_vector=.true. + return - end function has_boundary_condition_vector + end if - logical function has_boundary_condition_name_scalar(field, name) - !!< logical function that tells whether any of the bcs of a field - !!< has the name 'name' - type(scalar_field), intent(in):: field - character(len=*), intent(in):: name + end do bcloop - type(scalar_boundary_condition), pointer :: this_bc - integer i + has_boundary_condition_vector=.false. - if (.not.associated(field%bc%boundary_condition)) then - has_boundary_condition_name_scalar=.false. - return - end if + end function has_boundary_condition_vector - bcloop: do i=1, size(field%bc%boundary_condition) - this_bc=>field%bc%boundary_condition(i) + logical function has_boundary_condition_name_scalar(field, name) + !!< logical function that tells whether any of the bcs of a field + !!< has the name 'name' + type(scalar_field), intent(in):: field + character(len=*), intent(in):: name - if (this_bc%name==name) then + type(scalar_boundary_condition), pointer :: this_bc + integer i - has_boundary_condition_name_scalar=.true. + if (.not.associated(field%bc%boundary_condition)) then + has_boundary_condition_name_scalar=.false. return + end if - end if + bcloop: do i=1, size(field%bc%boundary_condition) + this_bc=>field%bc%boundary_condition(i) - end do bcloop + if (this_bc%name==name) then - has_boundary_condition_name_scalar=.false. + has_boundary_condition_name_scalar=.true. + return - end function has_boundary_condition_name_scalar + end if - logical function has_boundary_condition_name_vector(field, name) - !!< logical function that tells whether any of the bcs of a field - !!< has the name 'name' - type(vector_field), intent(in):: field - character(len=*), intent(in):: name + end do bcloop - type(vector_boundary_condition), pointer :: this_bc - integer i + has_boundary_condition_name_scalar=.false. - if (.not.associated(field%bc%boundary_condition)) then - has_boundary_condition_name_vector=.false. - return - end if + end function has_boundary_condition_name_scalar - bcloop: do i=1, size(field%bc%boundary_condition) - this_bc=>field%bc%boundary_condition(i) + logical function has_boundary_condition_name_vector(field, name) + !!< logical function that tells whether any of the bcs of a field + !!< has the name 'name' + type(vector_field), intent(in):: field + character(len=*), intent(in):: name - if (this_bc%name==name) then + type(vector_boundary_condition), pointer :: this_bc + integer i - has_boundary_condition_name_vector=.true. + if (.not.associated(field%bc%boundary_condition)) then + has_boundary_condition_name_vector=.false. return + end if - end if + bcloop: do i=1, size(field%bc%boundary_condition) + this_bc=>field%bc%boundary_condition(i) - end do bcloop + if (this_bc%name==name) then - has_boundary_condition_name_vector=.false. + has_boundary_condition_name_vector=.true. + return - end function has_boundary_condition_name_vector + end if - subroutine set_dirichlet_consistent(states) - !!< Once the fields and boundary conditions have been set, force the - !!< boundary values of the fields to be consistent with any Dirichlet - !!< conditions specified. - type(state_type), dimension(:), intent(in):: states + end do bcloop - type(scalar_field), pointer:: sfield - type(vector_field), pointer:: vfield + has_boundary_condition_name_vector=.false. - character(len=OPTION_PATH_LEN) field_path - integer :: p, nphases, f, nfields + end function has_boundary_condition_name_vector - ewrite(1,*) "In set_dirichlet_consistent" + subroutine set_dirichlet_consistent(states) + !!< Once the fields and boundary conditions have been set, force the + !!< boundary values of the fields to be consistent with any Dirichlet + !!< conditions specified. + type(state_type), dimension(:), intent(in):: states - nphases = size(states) - do p = 0, nphases-1 + type(scalar_field), pointer:: sfield + type(vector_field), pointer:: vfield - ! Scalar fields: - nfields = scalar_field_count(states(p+1)) - do f = 1, nfields - sfield => extract_scalar_field(states(p+1),f) - field_path=sfield%option_path - if (.not. have_option(trim(field_path)//'/prognostic')) cycle + character(len=OPTION_PATH_LEN) field_path + integer :: p, nphases, f, nfields - ! only prognostic fields from here: - call set_dirichlet_consistent_scalar(sfield) + ewrite(1,*) "In set_dirichlet_consistent" - end do + nphases = size(states) + do p = 0, nphases-1 - ! Vector fields: + ! Scalar fields: + nfields = scalar_field_count(states(p+1)) + do f = 1, nfields + sfield => extract_scalar_field(states(p+1),f) + field_path=sfield%option_path + if (.not. have_option(trim(field_path)//'/prognostic')) cycle - nfields = vector_field_count(states(p+1)) - do f = 1, nfields - vfield => extract_vector_field(states(p+1), f) - field_path=vfield%option_path - if (.not. have_option(trim(field_path)//'/prognostic')) cycle + ! only prognostic fields from here: + call set_dirichlet_consistent_scalar(sfield) - ! only prognostic fields from here: - call set_dirichlet_consistent_vector(vfield) + end do - end do + ! Vector fields: - end do + nfields = vector_field_count(states(p+1)) + do f = 1, nfields + vfield => extract_vector_field(states(p+1), f) + field_path=vfield%option_path + if (.not. have_option(trim(field_path)//'/prognostic')) cycle - end subroutine set_dirichlet_consistent + ! only prognostic fields from here: + call set_dirichlet_consistent_vector(vfield) + + end do + + end do - subroutine set_dirichlet_consistent_scalar(field) - !!< Force the values of the boundary nodes of a scalar field to the - !!< dirichlet boundary condition values. - type(scalar_field), intent(inout) :: field + end subroutine set_dirichlet_consistent - type(scalar_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - character(len=OPTION_PATH_LEN):: bc_option_path - character(len=FIELD_NAME_LEN):: bc_type - integer :: i, b + subroutine set_dirichlet_consistent_scalar(field) + !!< Force the values of the boundary nodes of a scalar field to the + !!< dirichlet boundary condition values. + type(scalar_field), intent(inout) :: field - do b=1, get_boundary_condition_count(field) - call get_boundary_condition(field, b, & - type=bc_type, option_path=bc_option_path, & - surface_node_list=surface_node_list) + type(scalar_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + character(len=OPTION_PATH_LEN):: bc_option_path + character(len=FIELD_NAME_LEN):: bc_type + integer :: i, b + do b=1, get_boundary_condition_count(field) + call get_boundary_condition(field, b, & + type=bc_type, option_path=bc_option_path, & + surface_node_list=surface_node_list) - if ((bc_type/="dirichlet").and.(bc_type/="weakdirichlet")) cycle - ! Weak dirichlet bcs do not have consistent bcs by default. - if (bc_type=="weakdirichlet".and. & + if ((bc_type/="dirichlet").and.(bc_type/="weakdirichlet")) cycle + + ! Weak dirichlet bcs do not have consistent bcs by default. + if (bc_type=="weakdirichlet".and. & .not.have_option(trim(bc_option_path)//& "/type[0]/apply_weakly/boundary_overwrites_initial_condition"))& - & then - cycle - end if + & then + cycle + end if - surface_field => extract_surface_field(field, b, "value") + surface_field => extract_surface_field(field, b, "value") - do i=1,size(surface_node_list) - call set(field, surface_node_list(i), & - node_val(surface_field, i)) - end do + do i=1,size(surface_node_list) + call set(field, surface_node_list(i), & + node_val(surface_field, i)) + end do - end do + end do - end subroutine set_dirichlet_consistent_scalar + end subroutine set_dirichlet_consistent_scalar - subroutine set_dirichlet_consistent_vector(field) - !!< Force the values of the boundary nodes of a vector field to the - !!< dirichlet boundary condition values. - type(vector_field), intent(inout) :: field + subroutine set_dirichlet_consistent_vector(field) + !!< Force the values of the boundary nodes of a vector field to the + !!< dirichlet boundary condition values. + type(vector_field), intent(inout) :: field - type(vector_field), pointer:: surface_field, normal, tangent_1, tangent_2 - integer, dimension(:), pointer:: surface_node_list - character(len=OPTION_PATH_LEN):: bc_option_path - character(len=FIELD_NAME_LEN):: bc_type - real, dimension(1:field%dim, 1:field%dim):: rotation_mat - real, dimension(1:field%dim):: rotated_vector - logical, dimension(1:field%dim):: applies - logical:: rotated - integer :: i, b, d + type(vector_field), pointer:: surface_field, normal, tangent_1, tangent_2 + integer, dimension(:), pointer:: surface_node_list + character(len=OPTION_PATH_LEN):: bc_option_path + character(len=FIELD_NAME_LEN):: bc_type + real, dimension(1:field%dim, 1:field%dim):: rotation_mat + real, dimension(1:field%dim):: rotated_vector + logical, dimension(1:field%dim):: applies + logical:: rotated + integer :: i, b, d - do b=1, get_boundary_condition_count(field) + do b=1, get_boundary_condition_count(field) - call get_boundary_condition(field, b, & - type=bc_type, option_path=bc_option_path, & - surface_node_list=surface_node_list, & - applies=applies) + call get_boundary_condition(field, b, & + type=bc_type, option_path=bc_option_path, & + surface_node_list=surface_node_list, & + applies=applies) - if ((bc_type/="dirichlet").and.(bc_type/="weakdirichlet")) cycle + if ((bc_type/="dirichlet").and.(bc_type/="weakdirichlet")) cycle - ! Weak dirichlet bcs do not have consistent bcs by default. - if (bc_type=="weakdirichlet".and. & + ! Weak dirichlet bcs do not have consistent bcs by default. + if (bc_type=="weakdirichlet".and. & .not.have_option(trim(bc_option_path)//& "/type[0]/apply_weakly/boundary_overwrites_initial_condition"))& - & then - cycle - end if - - surface_field => extract_surface_field(field, b, "value") - - rotated=have_option(trim(bc_option_path)//'/type[0]/align_bc_with_surface') - if (rotated) then - - normal => extract_surface_field(field, b, "normal") - tangent_1 => extract_surface_field(field, b, "tangent1") - tangent_2 => extract_surface_field(field, b, "tangent2") - - do i=1, size(surface_node_list) - rotation_mat(:,1)=node_val(normal, i) - if (field%dim>1) then - rotation_mat(:,2)=node_val(tangent_1, i) - end if - if (field%dim>2) then - rotation_mat(:,3)=node_val(tangent_2, i) - end if - ! first we rotate the existing vector into (normal, tangent1/2) coordinates - rotated_vector=matmul( node_val(field, surface_node_list(i)), & - rotation_mat ) - ! overwrite those components where the bc is applied - do d=1, field%dim - if (applies(d)) then - rotated_vector(d)=node_val(surface_field, d, i) - end if - end do - ! and rotate back to x,y,z coordinates - call set(field, surface_node_list(i), & - matmul( rotation_mat, rotated_vector )) - end do + & then + cycle + end if - else + surface_field => extract_surface_field(field, b, "value") - ! non-rotated, cartesian aligned case + rotated=have_option(trim(bc_option_path)//'/type[0]/align_bc_with_surface') + if (rotated) then - ! Loop over possible dimensions. - do d=1, field%dim - if (.not. applies(d)) cycle + normal => extract_surface_field(field, b, "normal") + tangent_1 => extract_surface_field(field, b, "tangent1") + tangent_2 => extract_surface_field(field, b, "tangent2") do i=1, size(surface_node_list) - call set(field, d, surface_node_list(i), & - node_val(surface_field, d, i)) + rotation_mat(:,1)=node_val(normal, i) + if (field%dim>1) then + rotation_mat(:,2)=node_val(tangent_1, i) + end if + if (field%dim>2) then + rotation_mat(:,3)=node_val(tangent_2, i) + end if + ! first we rotate the existing vector into (normal, tangent1/2) coordinates + rotated_vector=matmul( node_val(field, surface_node_list(i)), & + rotation_mat ) + ! overwrite those components where the bc is applied + do d=1, field%dim + if (applies(d)) then + rotated_vector(d)=node_val(surface_field, d, i) + end if + end do + ! and rotate back to x,y,z coordinates + call set(field, surface_node_list(i), & + matmul( rotation_mat, rotated_vector )) end do - end do - end if + else - end do + ! non-rotated, cartesian aligned case - end subroutine set_dirichlet_consistent_vector + ! Loop over possible dimensions. + do d=1, field%dim + if (.not. applies(d)) cycle - subroutine apply_dirichlet_conditions_scalar(matrix, rhs, field, dt) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by matrix and rhs. - !!< - !!< If dt is supplied, this assumes that boundary - !!< conditions are applied in rate of change form. - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(scalar_field), intent(in) :: field - real, optional, intent(in) :: dt + do i=1, size(surface_node_list) + call set(field, d, surface_node_list(i), & + node_val(surface_field, d, i)) + end do + end do - type(scalar_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - character(len=FIELD_NAME_LEN):: bctype - integer :: i,j + end if - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list) + end do - if (bctype/="dirichlet") cycle bcloop + end subroutine set_dirichlet_consistent_vector - call set_inactive(matrix, surface_node_list) + subroutine apply_dirichlet_conditions_scalar(matrix, rhs, field, dt) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by matrix and rhs. + !!< + !!< If dt is supplied, this assumes that boundary + !!< conditions are applied in rate of change form. + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(scalar_field), intent(in) :: field + real, optional, intent(in) :: dt - surface_field => extract_surface_field(field, i, "value") + type(scalar_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + character(len=FIELD_NAME_LEN):: bctype + integer :: i,j - if (present(dt)) then - do j=1, size(surface_node_list) - call set(rhs, surface_node_list(j), & - (node_val(surface_field, j)- & + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list) + + if (bctype/="dirichlet") cycle bcloop + + call set_inactive(matrix, surface_node_list) + + surface_field => extract_surface_field(field, i, "value") + + if (present(dt)) then + do j=1, size(surface_node_list) + call set(rhs, surface_node_list(j), & + (node_val(surface_field, j)- & node_val(field, surface_node_list(j)) & - )/dt) - end do - else - do j=1, size(surface_node_list) - call set(rhs, surface_node_list(j), & - node_val(surface_field, j)) - end do - end if + )/dt) + end do + else + do j=1, size(surface_node_list) + call set(rhs, surface_node_list(j), & + node_val(surface_field, j)) + end do + end if - end do bcloop + end do bcloop - end subroutine apply_dirichlet_conditions_scalar + end subroutine apply_dirichlet_conditions_scalar - subroutine apply_dirichlet_conditions_scalar_lumped(lhs, rhs, field, dt) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by lhs and rhs. lhs is the diagonal of the normal matrix - !!< so this is only useful for fully explicit problems. - !!< - !!< This assumes that boundary conditions are applied in rate of change - !!< form. - type(scalar_field), intent(inout) :: lhs - type(scalar_field), intent(inout) :: rhs - type(scalar_field), intent(in) :: field - real, intent(in) :: dt + subroutine apply_dirichlet_conditions_scalar_lumped(lhs, rhs, field, dt) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by lhs and rhs. lhs is the diagonal of the normal matrix + !!< so this is only useful for fully explicit problems. + !!< + !!< This assumes that boundary conditions are applied in rate of change + !!< form. + type(scalar_field), intent(inout) :: lhs + type(scalar_field), intent(inout) :: rhs + type(scalar_field), intent(in) :: field + real, intent(in) :: dt - type(scalar_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - character(len=FIELD_NAME_LEN):: bctype - integer :: i,j + type(scalar_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + character(len=FIELD_NAME_LEN):: bctype + integer :: i,j - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list) + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list) - if (bctype/="dirichlet") cycle bcloop + if (bctype/="dirichlet") cycle bcloop - surface_field => extract_surface_field(field, i, "value") + surface_field => extract_surface_field(field, i, "value") - do j=1,size(surface_node_list) - call set(rhs, surface_node_list(j), & + do j=1,size(surface_node_list) + call set(rhs, surface_node_list(j), & ((node_val(surface_field, j)- & - node_val(field, surface_node_list(j)) & - ) /dt)*INFINITY) + node_val(field, surface_node_list(j)) & + ) /dt)*INFINITY) - call set(lhs, surface_node_list(j), & + call set(lhs, surface_node_list(j), & INFINITY) - end do + end do - end do bcloop + end do bcloop + + end subroutine apply_dirichlet_conditions_scalar_lumped + + subroutine apply_dirichlet_conditions_vector(matrix, rhs, field, dt) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by matrix and rhs. + !!< + !!< This assumes that boundary conditions are applied in rate of change + !!< form and that the matrix has dim x dim blocks. + type(block_csr_matrix), intent(inout) :: matrix + type(vector_field), intent(inout), optional :: rhs + type(vector_field), intent(in) :: field + real, intent(in), optional :: dt + + type(scalar_field) :: rhscomponent, bccomponent + type(csr_matrix) :: matrixcomponent + + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + type(vector_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + integer :: i,j,k + + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) + + if (bctype/="dirichlet") cycle bcloop + + surface_field => extract_surface_field(field, i, "value") + + do j=1,size(surface_node_list) + do k = 1, field%dim + if(applies(k)) then + + if(present(rhs)) then + rhscomponent = extract_scalar_field_from_vector_field(rhs, k) + bccomponent = extract_scalar_field_from_vector_field(surface_field, k) + + if(present(dt)) then + call set(rhscomponent, & + surface_node_list(j), & + ((node_val(bccomponent,j)& + -node_val(field, k, surface_node_list(j)) & + ) /dt)*INFINITY) + else + call set(rhscomponent, & + surface_node_list(j), & + node_val(bccomponent,j)*INFINITY) + end if + end if + + matrixcomponent = block(matrix, k, k) + call set_diag(matrixcomponent, surface_node_list(j), & + INFINITY) + end if + end do + end do - end subroutine apply_dirichlet_conditions_scalar_lumped + end do bcloop + + end subroutine apply_dirichlet_conditions_vector + + subroutine collect_vector_dirichlet_conditions(field, boundary_row_set, rhs, dt) + ! returns for each component of the vector field an integer set of those nodes + ! to which a strong dirichlet boundary condition is applied. + type(vector_field), intent(in) :: field + type(integer_set), dimension(field%dim), intent(out):: boundary_row_set + ! if supplied the boundary condition value is set in the corresponding + ! rows of the 'rhs' field (should be allocated beforehand) + type(vector_field), intent(inout), optional :: rhs + ! if 'dt' is provided, assume the equation is solved in acceleration form, so + ! that the rhs values are (current_value-bc_val)/dt + ! current_value is obtained from 'field' + real, intent(in), optional :: dt + + type(scalar_field) :: rhscomponent, bccomponent + + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + type(vector_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + integer :: i,j,k + + do k=1, field%dim + call allocate(boundary_row_set(k)) + end do - subroutine apply_dirichlet_conditions_vector(matrix, rhs, field, dt) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by matrix and rhs. - !!< - !!< This assumes that boundary conditions are applied in rate of change - !!< form and that the matrix has dim x dim blocks. - type(block_csr_matrix), intent(inout) :: matrix - type(vector_field), intent(inout), optional :: rhs - type(vector_field), intent(in) :: field - real, intent(in), optional :: dt + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) + + if (bctype/="dirichlet") cycle bcloop + + surface_field => extract_surface_field(field, i, "value") + + do j=1,size(surface_node_list) + do k = 1, field%dim + if(applies(k)) then + + if(present(rhs)) then + rhscomponent = extract_scalar_field_from_vector_field(rhs, k) + bccomponent = extract_scalar_field_from_vector_field(surface_field, k) + + if(present(dt)) then + call set(rhscomponent, & + surface_node_list(j), & + (node_val(bccomponent,j)& + -node_val(field, k, surface_node_list(j)) & + )/dt) + else + call set(rhscomponent, & + surface_node_list(j), & + node_val(bccomponent,j)) + end if + end if + call insert(boundary_row_set(k), surface_node_list(j)) + + end if + end do + end do - type(scalar_field) :: rhscomponent, bccomponent - type(csr_matrix) :: matrixcomponent + end do bcloop - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - type(vector_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - integer :: i,j,k + end subroutine collect_vector_dirichlet_conditions - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) + subroutine zero_dirichlet_rows_vector(field, rhs) + !!< Zero the rows corresponding to dirichlet boundary conditions + !!< This can be used when the lhs matrix already had dirichlet bcs + !!< applied (zeroing corresponding rows and columns) + !!< and only a homogeneous boundary condition is required. + type(vector_field), intent(in):: field + type(vector_field), intent(inout):: rhs - if (bctype/="dirichlet") cycle bcloop + type(integer_set), dimension(field%dim) :: boundary_row_set + integer :: i, j - surface_field => extract_surface_field(field, i, "value") + call collect_vector_dirichlet_conditions(field, boundary_row_set) + do i=1, field%dim + do j=1, key_count(boundary_row_set(i)) + call set(rhs, i, fetch(boundary_row_set(i), j), 0.0) + end do + call deallocate(boundary_row_set(i)) + end do - do j=1,size(surface_node_list) - do k = 1, field%dim - if(applies(k)) then + end subroutine zero_dirichlet_rows_vector - if(present(rhs)) then - rhscomponent = extract_scalar_field_from_vector_field(rhs, k) - bccomponent = extract_scalar_field_from_vector_field(surface_field, k) - - if(present(dt)) then - call set(rhscomponent, & - surface_node_list(j), & - ((node_val(bccomponent,j)& - -node_val(field, k, surface_node_list(j)) & - ) /dt)*INFINITY) - else - call set(rhscomponent, & - surface_node_list(j), & - node_val(bccomponent,j)*INFINITY) - end if - end if - - matrixcomponent = block(matrix, k, k) - call set_diag(matrixcomponent, surface_node_list(j), & - INFINITY) - end if - end do - end do + subroutine apply_dirichlet_conditions_vector_petsc_csr(matrix, rhs, field, dt) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by matrix and rhs. + !!< + !!< This assumes that boundary conditions are applied in rate of change + !!< form and that the matrix has dim x dim blocks. + type(petsc_csr_matrix), intent(inout) :: matrix + type(vector_field), intent(inout), optional :: rhs + type(vector_field), intent(in) :: field + real, intent(in), optional :: dt - end do bcloop + type(integer_set), dimension(field%dim):: boundary_row_set + integer:: i - end subroutine apply_dirichlet_conditions_vector + call collect_vector_dirichlet_conditions(field, boundary_row_set, rhs=rhs, dt=dt) - subroutine collect_vector_dirichlet_conditions(field, boundary_row_set, rhs, dt) - ! returns for each component of the vector field an integer set of those nodes - ! to which a strong dirichlet boundary condition is applied. - type(vector_field), intent(in) :: field - type(integer_set), dimension(field%dim), intent(out):: boundary_row_set - ! if supplied the boundary condition value is set in the corresponding - ! rows of the 'rhs' field (should be allocated beforehand) - type(vector_field), intent(inout), optional :: rhs - ! if 'dt' is provided, assume the equation is solved in acceleration form, so - ! that the rhs values are (current_value-bc_val)/dt - ! current_value is obtained from 'field' - real, intent(in), optional :: dt + call lift_boundary_conditions(matrix, boundary_row_set, rhs=rhs) - type(scalar_field) :: rhscomponent, bccomponent + do i=1, field%dim + call deallocate(boundary_row_set(i)) + end do - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - type(vector_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - integer :: i,j,k + end subroutine apply_dirichlet_conditions_vector_petsc_csr - do k=1, field%dim - call allocate(boundary_row_set(k)) - end do + subroutine apply_dirichlet_conditions_vector_component(matrix, rhs, field, dt, dim) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by matrix and rhs. + !!< + !!< This assumes that boundary conditions are applied in rate of change + !!< form and that the matrix has dim x dim blocks. + type(csr_matrix), intent(inout) :: matrix + type(vector_field), intent(inout), optional :: rhs + type(vector_field), intent(in) :: field + real, intent(in), optional :: dt + integer, intent(in) :: dim - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) + type(scalar_field) :: rhscomponent, bccomponent - if (bctype/="dirichlet") cycle bcloop + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + type(vector_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + integer :: i,j - surface_field => extract_surface_field(field, i, "value") + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) - do j=1,size(surface_node_list) - do k = 1, field%dim - if(applies(k)) then + if (bctype/="dirichlet") cycle bcloop - if(present(rhs)) then - rhscomponent = extract_scalar_field_from_vector_field(rhs, k) - bccomponent = extract_scalar_field_from_vector_field(surface_field, k) - - if(present(dt)) then - call set(rhscomponent, & - surface_node_list(j), & - (node_val(bccomponent,j)& - -node_val(field, k, surface_node_list(j)) & - )/dt) - else - call set(rhscomponent, & - surface_node_list(j), & - node_val(bccomponent,j)) - end if - end if - call insert(boundary_row_set(k), surface_node_list(j)) + surface_field => extract_surface_field(field, i, "value") - end if - end do - end do + do j=1,size(surface_node_list) - end do bcloop + if(applies(dim)) then - end subroutine collect_vector_dirichlet_conditions + call set_diag(matrix, surface_node_list(j),& + INFINITY) - subroutine zero_dirichlet_rows_vector(field, rhs) - !!< Zero the rows corresponding to dirichlet boundary conditions - !!< This can be used when the lhs matrix already had dirichlet bcs - !!< applied (zeroing corresponding rows and columns) - !!< and only a homogeneous boundary condition is required. - type(vector_field), intent(in):: field - type(vector_field), intent(inout):: rhs + if(present(rhs)) then + rhscomponent = extract_scalar_field_from_vector_field(rhs, dim) + bccomponent = extract_scalar_field_from_vector_field(surface_field, dim) - type(integer_set), dimension(field%dim) :: boundary_row_set - integer :: i, j + if(present(dt)) then + call set(rhscomponent, & + surface_node_list(j), & + ((node_val(bccomponent, j) & + -node_val(field,dim,surface_node_list(j)) & + ) /dt)*INFINITY) + else + call set(rhscomponent, & + surface_node_list(j), & + node_val(bccomponent, j)*INFINITY) + end if - call collect_vector_dirichlet_conditions(field, boundary_row_set) - do i=1, field%dim - do j=1, key_count(boundary_row_set(i)) - call set(rhs, i, fetch(boundary_row_set(i), j), 0.0) - end do - call deallocate(boundary_row_set(i)) - end do - - end subroutine zero_dirichlet_rows_vector - - subroutine apply_dirichlet_conditions_vector_petsc_csr(matrix, rhs, field, dt) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by matrix and rhs. - !!< - !!< This assumes that boundary conditions are applied in rate of change - !!< form and that the matrix has dim x dim blocks. - type(petsc_csr_matrix), intent(inout) :: matrix - type(vector_field), intent(inout), optional :: rhs - type(vector_field), intent(in) :: field - real, intent(in), optional :: dt - - type(integer_set), dimension(field%dim):: boundary_row_set - integer:: i - - call collect_vector_dirichlet_conditions(field, boundary_row_set, rhs=rhs, dt=dt) - - call lift_boundary_conditions(matrix, boundary_row_set, rhs=rhs) - - do i=1, field%dim - call deallocate(boundary_row_set(i)) - end do - - end subroutine apply_dirichlet_conditions_vector_petsc_csr - - subroutine apply_dirichlet_conditions_vector_component(matrix, rhs, field, dt, dim) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by matrix and rhs. - !!< - !!< This assumes that boundary conditions are applied in rate of change - !!< form and that the matrix has dim x dim blocks. - type(csr_matrix), intent(inout) :: matrix - type(vector_field), intent(inout), optional :: rhs - type(vector_field), intent(in) :: field - real, intent(in), optional :: dt - integer, intent(in) :: dim - - type(scalar_field) :: rhscomponent, bccomponent - - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - type(vector_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - integer :: i,j - - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) - - if (bctype/="dirichlet") cycle bcloop - - surface_field => extract_surface_field(field, i, "value") - - do j=1,size(surface_node_list) - - if(applies(dim)) then - - call set_diag(matrix, surface_node_list(j),& - INFINITY) - - if(present(rhs)) then - rhscomponent = extract_scalar_field_from_vector_field(rhs, dim) - bccomponent = extract_scalar_field_from_vector_field(surface_field, dim) - - if(present(dt)) then - call set(rhscomponent, & - surface_node_list(j), & - ((node_val(bccomponent, j) & - -node_val(field,dim,surface_node_list(j)) & - ) /dt)*INFINITY) - else - call set(rhscomponent, & - surface_node_list(j), & - node_val(bccomponent, j)*INFINITY) - end if + end if end if + end do - end if - end do - - end do bcloop + end do bcloop - end subroutine apply_dirichlet_conditions_vector_component + end subroutine apply_dirichlet_conditions_vector_component - subroutine apply_dirichlet_conditions_vector_lumped(lhs, rhs, field, dt) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by lhs and rhs. lhs is the diagonal of the normal matrix. - !!< - !!< This assumes that boundary conditions are applied in rate of change - !!< form. - type(vector_field), intent(inout) :: lhs - type(vector_field), intent(inout), optional :: rhs - type(vector_field), intent(in) :: field - real, intent(in), optional :: dt + subroutine apply_dirichlet_conditions_vector_lumped(lhs, rhs, field, dt) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by lhs and rhs. lhs is the diagonal of the normal matrix. + !!< + !!< This assumes that boundary conditions are applied in rate of change + !!< form. + type(vector_field), intent(inout) :: lhs + type(vector_field), intent(inout), optional :: rhs + type(vector_field), intent(in) :: field + real, intent(in), optional :: dt - type(scalar_field) :: rhscomponent, bccomponent, lhscomponent + type(scalar_field) :: rhscomponent, bccomponent, lhscomponent - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - type(vector_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - integer :: i,j,k + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + type(vector_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + integer :: i,j,k - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) - if (bctype/="dirichlet") cycle bcloop + if (bctype/="dirichlet") cycle bcloop - surface_field => extract_surface_field(field, i, "value") + surface_field => extract_surface_field(field, i, "value") - do j=1,size(surface_node_list) - do k = 1, field%dim - if(applies(k)) then + do j=1,size(surface_node_list) + do k = 1, field%dim + if(applies(k)) then - lhscomponent = extract_scalar_field_from_vector_field(lhs, k) + lhscomponent = extract_scalar_field_from_vector_field(lhs, k) - if(present(rhs)) then - rhscomponent = extract_scalar_field_from_vector_field(rhs, k) - bccomponent = extract_scalar_field_from_vector_field(surface_field, k) + if(present(rhs)) then + rhscomponent = extract_scalar_field_from_vector_field(rhs, k) + bccomponent = extract_scalar_field_from_vector_field(surface_field, k) - if(present(dt)) then - call set(rhscomponent, & - surface_node_list(j), & - ((node_val(bccomponent,j)& - -node_val(field,k,surface_node_list(j)) & - ) /dt)*INFINITY) - else - call set(rhscomponent, & - surface_node_list(j), & - node_val(bccomponent,j)*INFINITY) - end if + if(present(dt)) then + call set(rhscomponent, & + surface_node_list(j), & + ((node_val(bccomponent,j)& + -node_val(field,k,surface_node_list(j)) & + ) /dt)*INFINITY) + else + call set(rhscomponent, & + surface_node_list(j), & + node_val(bccomponent,j)*INFINITY) + end if - end if + end if - call set(lhscomponent, surface_node_list(j),& - INFINITY) - end if + call set(lhscomponent, surface_node_list(j),& + INFINITY) + end if + end do end do - end do - end do bcloop + end do bcloop + + end subroutine apply_dirichlet_conditions_vector_lumped - end subroutine apply_dirichlet_conditions_vector_lumped + subroutine apply_dirichlet_conditions_vector_component_lumped(lhs, rhs, field, dt, dim) + !!< Apply dirichlet boundary conditions from field to the problem + !!< defined by lhs and rhs. lhs is the diagonal of the normal matrix + !!< so this is only useful for fully explicit problems. + !!< + !!< This assumes that boundary conditions are applied in rate of change + !!< form. + type(scalar_field), intent(inout) :: lhs + type(vector_field), intent(inout), optional :: rhs + type(vector_field), intent(in) :: field + real, intent(in), optional :: dt + integer, intent(in) :: dim - subroutine apply_dirichlet_conditions_vector_component_lumped(lhs, rhs, field, dt, dim) - !!< Apply dirichlet boundary conditions from field to the problem - !!< defined by lhs and rhs. lhs is the diagonal of the normal matrix - !!< so this is only useful for fully explicit problems. - !!< - !!< This assumes that boundary conditions are applied in rate of change - !!< form. - type(scalar_field), intent(inout) :: lhs - type(vector_field), intent(inout), optional :: rhs - type(vector_field), intent(in) :: field - real, intent(in), optional :: dt - integer, intent(in) :: dim + type(scalar_field) :: rhscomponent, bccomponent - type(scalar_field) :: rhscomponent, bccomponent + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + type(vector_field), pointer:: surface_field + integer, dimension(:), pointer:: surface_node_list + integer :: i,j - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - type(vector_field), pointer:: surface_field - integer, dimension(:), pointer:: surface_node_list - integer :: i,j + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) + if (bctype/="dirichlet") cycle bcloop - if (bctype/="dirichlet") cycle bcloop + surface_field => extract_surface_field(field, i, "value") - surface_field => extract_surface_field(field, i, "value") + do j=1,size(surface_node_list) - do j=1,size(surface_node_list) + if(applies(dim)) then - if(applies(dim)) then + if(present(rhs)) then + bccomponent = extract_scalar_field_from_vector_field(surface_field, dim) + rhscomponent = extract_scalar_field_from_vector_field(rhs, dim) - if(present(rhs)) then - bccomponent = extract_scalar_field_from_vector_field(surface_field, dim) - rhscomponent = extract_scalar_field_from_vector_field(rhs, dim) + if(present(dt)) then + call set(rhscomponent, & + surface_node_list(j), & + ((node_val(bccomponent,j) & + -node_val(field, dim, surface_node_list(j)) & + ) /dt)*INFINITY) + else + call set(rhscomponent, & + surface_node_list(j), & + node_val(bccomponent,j)*INFINITY) - if(present(dt)) then - call set(rhscomponent, & - surface_node_list(j), & - ((node_val(bccomponent,j) & - -node_val(field, dim, surface_node_list(j)) & - ) /dt)*INFINITY) - else - call set(rhscomponent, & - surface_node_list(j), & - node_val(bccomponent,j)*INFINITY) + end if - end if + end if + call set(lhs, surface_node_list(j),& + INFINITY) end if + end do + + end do bcloop + + end subroutine apply_dirichlet_conditions_vector_component_lumped + + subroutine derive_collapsed_bcs(input_states, collapsed_states, bctype) + !!< For the collapsed state collapsed_states, containing the collapsed + !!< components of fields in input_states, copy across the component + !!< boundary conditions. + + type(state_type), dimension(:), intent(in) :: input_states + type(state_type), dimension(size(input_states)), intent(inout) :: collapsed_states + character(len = *), optional, intent(in) :: bctype + + character(len = FIELD_NAME_LEN) :: bcname, lbctype, v_field_comp_name + character(len = OPTION_PATH_LEN) :: bcoption_path + integer :: i, j, k, l + integer, dimension(:), allocatable :: bccount + integer, dimension(:), pointer :: bcsurface_element_list + logical, dimension(:), allocatable :: bcapplies + type(mesh_type), pointer :: bcsurface_mesh + type(scalar_field) :: bcvalue_comp + type(scalar_field), target :: v_field_comp_wrap + type(scalar_field_pointer), dimension(:), allocatable :: v_field_comps + type(vector_field), pointer :: bcvalue, v_field + + ewrite(1, *) "In derive_collapsed_bcs" + + do i = 1, size(input_states) + v_field_loop: do j = 1, vector_field_count(input_states(i)) + v_field => extract_vector_field(input_states(i), j) + if(trim(v_field%name) == "Coordinate") cycle + ewrite(2, *) "For vector field " // trim(v_field%name) // ", bc count = ", get_boundary_condition_count(v_field) + if(get_boundary_condition_count(v_field) == 0) cycle v_field_loop + + allocate(v_field_comps(v_field%dim)) + do k = 1, v_field%dim + v_field_comp_name = trim(input_states(i)%vector_names(j)) // "%" // int2str(k) + v_field_comps(k)%ptr => extract_scalar_field(collapsed_states(i), v_field_comp_name) + + if(.not. associated(v_field_comps(k)%ptr%bc)) then + ! This scalar field has no bc field (probably a borrowed + ! reference). Wrap it so that it isn't a borrowed reference. + ! Wrapping is cheaper than a copy here. + v_field_comp_wrap = wrap_scalar_field(v_field_comps(k)%ptr%mesh, v_field_comps(k)%ptr%val, & + v_field_comps(k)%ptr%name, val_stride=v_field_comps(k)%ptr%val_stride) + v_field_comp_wrap%option_path = v_field%option_path + call insert(collapsed_states(i), v_field_comp_wrap, v_field_comp_name) + call deallocate(v_field_comp_wrap) + v_field_comps(k)%ptr => extract_scalar_field(collapsed_states(i), v_field_comp_name) + end if + + assert(associated(v_field_comps(k)%ptr%bc)) + end do + + allocate(bcapplies(v_field%dim)) + allocate(bccount(v_field%dim)) + bccount = 0 + bc_loop: do k = 1, get_boundary_condition_count(v_field) + + call get_boundary_condition(v_field, k, name = bcname, type = lbctype, & + & surface_element_list = bcsurface_element_list, applies = bcapplies, & + & surface_mesh = bcsurface_mesh, option_path = bcoption_path) + if(present(bctype)) then + if(lbctype /= bctype) cycle bc_loop + end if + bcvalue => extract_surface_field(v_field, k, "value") + ewrite(2, *) "Collapsing vector bc " // trim(bcname) // " for field " // trim(v_field%name) + + ewrite_minmax(bcvalue) + bc_dim_loop: do l = 1, v_field%dim + if(.not. bcapplies(l)) cycle bc_dim_loop + + call add_boundary_condition_surface_elements(v_field_comps(l)%ptr, bcname, bctype, & + & bcsurface_element_list, option_path = bcoption_path) + + call allocate(bcvalue_comp, bcsurface_mesh, name = "value") + call set(bcvalue_comp, extract_scalar_field(bcvalue, l)) + bccount(l) = bccount(l) + 1 + call insert_surface_field(v_field_comps(l)%ptr, bccount(l), bcvalue_comp) + call deallocate(bcvalue_comp) + end do bc_dim_loop + + end do bc_loop + deallocate(bcapplies) + deallocate(bccount) + + deallocate(v_field_comps) + end do v_field_loop + end do + + ewrite(1, *) "Exiting derive_collapsed_bcs" - call set(lhs, surface_node_list(j),& - INFINITY) - end if - end do - - end do bcloop - - end subroutine apply_dirichlet_conditions_vector_component_lumped - - subroutine derive_collapsed_bcs(input_states, collapsed_states, bctype) - !!< For the collapsed state collapsed_states, containing the collapsed - !!< components of fields in input_states, copy across the component - !!< boundary conditions. - - type(state_type), dimension(:), intent(in) :: input_states - type(state_type), dimension(size(input_states)), intent(inout) :: collapsed_states - character(len = *), optional, intent(in) :: bctype - - character(len = FIELD_NAME_LEN) :: bcname, lbctype, v_field_comp_name - character(len = OPTION_PATH_LEN) :: bcoption_path - integer :: i, j, k, l - integer, dimension(:), allocatable :: bccount - integer, dimension(:), pointer :: bcsurface_element_list - logical, dimension(:), allocatable :: bcapplies - type(mesh_type), pointer :: bcsurface_mesh - type(scalar_field) :: bcvalue_comp - type(scalar_field), target :: v_field_comp_wrap - type(scalar_field_pointer), dimension(:), allocatable :: v_field_comps - type(vector_field), pointer :: bcvalue, v_field - - ewrite(1, *) "In derive_collapsed_bcs" - - do i = 1, size(input_states) - v_field_loop: do j = 1, vector_field_count(input_states(i)) - v_field => extract_vector_field(input_states(i), j) - if(trim(v_field%name) == "Coordinate") cycle - ewrite(2, *) "For vector field " // trim(v_field%name) // ", bc count = ", get_boundary_condition_count(v_field) - if(get_boundary_condition_count(v_field) == 0) cycle v_field_loop - - allocate(v_field_comps(v_field%dim)) - do k = 1, v_field%dim - v_field_comp_name = trim(input_states(i)%vector_names(j)) // "%" // int2str(k) - v_field_comps(k)%ptr => extract_scalar_field(collapsed_states(i), v_field_comp_name) - - if(.not. associated(v_field_comps(k)%ptr%bc)) then - ! This scalar field has no bc field (probably a borrowed - ! reference). Wrap it so that it isn't a borrowed reference. - ! Wrapping is cheaper than a copy here. - v_field_comp_wrap = wrap_scalar_field(v_field_comps(k)%ptr%mesh, v_field_comps(k)%ptr%val, & - v_field_comps(k)%ptr%name, val_stride=v_field_comps(k)%ptr%val_stride) - v_field_comp_wrap%option_path = v_field%option_path - call insert(collapsed_states(i), v_field_comp_wrap, v_field_comp_name) - call deallocate(v_field_comp_wrap) - v_field_comps(k)%ptr => extract_scalar_field(collapsed_states(i), v_field_comp_name) - end if - - assert(associated(v_field_comps(k)%ptr%bc)) - end do - - allocate(bcapplies(v_field%dim)) - allocate(bccount(v_field%dim)) - bccount = 0 - bc_loop: do k = 1, get_boundary_condition_count(v_field) - - call get_boundary_condition(v_field, k, name = bcname, type = lbctype, & - & surface_element_list = bcsurface_element_list, applies = bcapplies, & - & surface_mesh = bcsurface_mesh, option_path = bcoption_path) - if(present(bctype)) then - if(lbctype /= bctype) cycle bc_loop - end if - bcvalue => extract_surface_field(v_field, k, "value") - ewrite(2, *) "Collapsing vector bc " // trim(bcname) // " for field " // trim(v_field%name) - - ewrite_minmax(bcvalue) - bc_dim_loop: do l = 1, v_field%dim - if(.not. bcapplies(l)) cycle bc_dim_loop - - call add_boundary_condition_surface_elements(v_field_comps(l)%ptr, bcname, bctype, & - & bcsurface_element_list, option_path = bcoption_path) - - call allocate(bcvalue_comp, bcsurface_mesh, name = "value") - call set(bcvalue_comp, extract_scalar_field(bcvalue, l)) - bccount(l) = bccount(l) + 1 - call insert_surface_field(v_field_comps(l)%ptr, bccount(l), bcvalue_comp) - call deallocate(bcvalue_comp) - end do bc_dim_loop - - end do bc_loop - deallocate(bcapplies) - deallocate(bccount) - - deallocate(v_field_comps) - end do v_field_loop - end do - - ewrite(1, *) "Exiting derive_collapsed_bcs" - - end subroutine derive_collapsed_bcs + end subroutine derive_collapsed_bcs end module boundary_conditions diff --git a/femtools/CGAL_Tools.F90 b/femtools/CGAL_Tools.F90 index 77a3904ff7..00106da1cf 100644 --- a/femtools/CGAL_Tools.F90 +++ b/femtools/CGAL_Tools.F90 @@ -1,50 +1,50 @@ #include "fdebug.h" module cgal_tools - use fldebug - use fields - use element_numbering - implicit none + use fldebug + use fields + use element_numbering + implicit none - interface - subroutine convex_hull_area_3d(nodes, sz, area) - integer, intent(in) :: sz - real, dimension(sz*3), intent(in) :: nodes - real, intent(out) :: area - end subroutine convex_hull_area_3d - end interface + interface + subroutine convex_hull_area_3d(nodes, sz, area) + integer, intent(in) :: sz + real, dimension(sz*3), intent(in) :: nodes + real, intent(out) :: area + end subroutine convex_hull_area_3d + end interface - private + private - public :: convex_hull_area + public :: convex_hull_area - contains +contains - function convex_hull_area(positions) result(area) - type(vector_field), intent(in) :: positions - real :: area + function convex_hull_area(positions) result(area) + type(vector_field), intent(in) :: positions + real :: area #ifndef HAVE_LIBCGAL - FLAbort("Called a routine which depends on CGAL without CGAL") - area = 0.0 * positions%dim + FLAbort("Called a routine which depends on CGAL without CGAL") + area = 0.0 * positions%dim #else - real, dimension(positions%dim * node_count(positions)) :: nodes - integer :: head, i + real, dimension(positions%dim * node_count(positions)) :: nodes + integer :: head, i - if (positions%dim /= 3) then - FLExit("Sorry, have only written the CGAL for 3D. But the 2D generalisation is easy!") - end if + if (positions%dim /= 3) then + FLExit("Sorry, have only written the CGAL for 3D. But the 2D generalisation is easy!") + end if - if (positions%mesh%shape%degree /= 1 .or. positions%mesh%shape%numbering%family /= FAMILY_SIMPLEX) then - FLExit("Sorry, only have CGAL support for linear tets") - end if + if (positions%mesh%shape%degree /= 1 .or. positions%mesh%shape%numbering%family /= FAMILY_SIMPLEX) then + FLExit("Sorry, only have CGAL support for linear tets") + end if - head = 1 - do i=1,node_count(positions) - nodes(head:head+positions%dim-1) = node_val(positions, i) - head = head + positions%dim - end do + head = 1 + do i=1,node_count(positions) + nodes(head:head+positions%dim-1) = node_val(positions, i) + head = head + positions%dim + end do - call convex_hull_area_3d(nodes, node_count(positions), area) + call convex_hull_area_3d(nodes, node_count(positions), area) #endif - end function convex_hull_area + end function convex_hull_area end module cgal_tools diff --git a/femtools/CVTools.F90 b/femtools/CVTools.F90 index 17d1c4ec6d..881ee1b6b7 100644 --- a/femtools/CVTools.F90 +++ b/femtools/CVTools.F90 @@ -26,240 +26,240 @@ ! USA #include "fdebug.h" module cvtools - !!< Module containing general tools for discretising Control Volume problems. + !!< Module containing general tools for discretising Control Volume problems. - use spud - use fldebug - use vector_tools - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str - use state_module - use field_options, only: complete_field_path + use spud + use fldebug + use vector_tools + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str + use state_module + use field_options, only: complete_field_path - implicit none + implicit none - interface clean_deferred_deletion - module procedure clean_deferred_deletion_single_state, clean_deferred_deletion_multiple_states - end interface + interface clean_deferred_deletion + module procedure clean_deferred_deletion_single_state, clean_deferred_deletion_multiple_states + end interface - private - public :: orientate_cvsurf_normgi, & - clean_deferred_deletion, & - complete_cv_field_path + private + public :: orientate_cvsurf_normgi, & + clean_deferred_deletion, & + complete_cv_field_path contains - character(len=OPTION_PATH_LEN) function complete_cv_field_path(path) - !!< Auxillary function to add control_volumes/legacy_mixed_cv_cg/coupled_cv - !!< to field option path. + character(len=OPTION_PATH_LEN) function complete_cv_field_path(path) + !!< Auxillary function to add control_volumes/legacy_mixed_cv_cg/coupled_cv + !!< to field option path. - character(len=*), intent(in) :: path - integer :: stat + character(len=*), intent(in) :: path + integer :: stat - if (have_option(trim(complete_field_path(path, stat=stat)) // & - &"/spatial_discretisation/control_volumes")) then + if (have_option(trim(complete_field_path(path, stat=stat)) // & + &"/spatial_discretisation/control_volumes")) then - complete_cv_field_path=trim(complete_field_path(path, stat=stat)) // & - &"/spatial_discretisation/control_volumes" + complete_cv_field_path=trim(complete_field_path(path, stat=stat)) // & + &"/spatial_discretisation/control_volumes" - elseif (have_option(trim(complete_field_path(path, stat=stat)) // & - &"/spatial_discretisation/legacy_mixed_cv_cg")) then + elseif (have_option(trim(complete_field_path(path, stat=stat)) // & + &"/spatial_discretisation/legacy_mixed_cv_cg")) then - complete_cv_field_path=trim(complete_field_path(path, stat=stat)) // & - &"/spatial_discretisation/legacy_mixed_cv_cg" + complete_cv_field_path=trim(complete_field_path(path, stat=stat)) // & + &"/spatial_discretisation/legacy_mixed_cv_cg" - elseif (have_option(trim(complete_field_path(path, stat=stat)) // & - &"/spatial_discretisation/coupled_cv")) then + elseif (have_option(trim(complete_field_path(path, stat=stat)) // & + &"/spatial_discretisation/coupled_cv")) then - complete_cv_field_path=trim(complete_field_path(path, stat=stat)) // & - &"/spatial_discretisation/coupled_cv" + complete_cv_field_path=trim(complete_field_path(path, stat=stat)) // & + &"/spatial_discretisation/coupled_cv" - else + else - complete_cv_field_path=path(1:len_trim(path)) + complete_cv_field_path=path(1:len_trim(path)) - end if + end if - end function complete_cv_field_path + end function complete_cv_field_path - function orientate_cvsurf_normgi(X, X_f, normgi) result(normgi_f) - ! This subroutine corrects the orientation of a cv face normal - ! relative to a set of nodal coordinates so that it points away from - ! that node - ! This is useful as there is no easy automatic orientation for cv face - ! normals as they point in different directions when looking from different - ! control volumes. + function orientate_cvsurf_normgi(X, X_f, normgi) result(normgi_f) + ! This subroutine corrects the orientation of a cv face normal + ! relative to a set of nodal coordinates so that it points away from + ! that node + ! This is useful as there is no easy automatic orientation for cv face + ! normals as they point in different directions when looking from different + ! control volumes. - ! unorientated normal - real, dimension(:) :: normgi - ! result - real, dimension(size(normgi)) :: normgi_f - ! node and gauss pt. locations respectively. - real, dimension (:), intent(in) :: X, X_f - ! Outward pointing not necessarily normal vector. - real, dimension(3) :: outv + ! unorientated normal + real, dimension(:) :: normgi + ! result + real, dimension(size(normgi)) :: normgi_f + ! node and gauss pt. locations respectively. + real, dimension (:), intent(in) :: X, X_f + ! Outward pointing not necessarily normal vector. + real, dimension(3) :: outv - integer :: ldim, i + integer :: ldim, i - ldim = size(normgi) + ldim = size(normgi) - ! Outv is the vector from the gauss pt to the node. - forall(i=1:ldim) - outv(i) = X_f(i)-X(i) - end forall + ! Outv is the vector from the gauss pt to the node. + forall(i=1:ldim) + outv(i) = X_f(i)-X(i) + end forall - ! Set correct orientation. - normgi=normgi*dot_product(normgi, outv(1:ldim) ) + ! Set correct orientation. + normgi=normgi*dot_product(normgi, outv(1:ldim) ) - ! normalise - normgi_f=normgi/sqrt(sum(normgi**2)) + ! normalise + normgi_f=normgi/sqrt(sum(normgi**2)) - end function orientate_cvsurf_normgi + end function orientate_cvsurf_normgi - subroutine clean_deferred_deletion_single_state(state) - type(state_type), intent(inout) :: state + subroutine clean_deferred_deletion_single_state(state) + type(state_type), intent(inout) :: state - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - call clean_deferred_deletion(states) - state = states(1) + states = (/state/) + call clean_deferred_deletion(states) + state = states(1) - end subroutine clean_deferred_deletion_single_state + end subroutine clean_deferred_deletion_single_state - subroutine clean_deferred_deletion_multiple_states(state) + subroutine clean_deferred_deletion_multiple_states(state) - ! this subroutine cleans up state of any inserted control volume - ! matrices whose deletion was deferred to speed up the subroutine + ! this subroutine cleans up state of any inserted control volume + ! matrices whose deletion was deferred to speed up the subroutine - type(state_type), dimension(:), intent(inout) :: state + type(state_type), dimension(:), intent(inout) :: state - integer :: i, f, mesh, mesh_cnt, prefix, prefix_cnt, stat - logical :: delete - character(len=OPTION_PATH_LEN) :: option_path + integer :: i, f, mesh, mesh_cnt, prefix, prefix_cnt, stat + logical :: delete + character(len=OPTION_PATH_LEN) :: option_path - character(len=255), dimension(2), parameter :: & - matrix_prefixes = (/ " ", & - "Reflected" /) - character(len=FIELD_NAME_LEN) :: mesh_name, mesh_name2 + character(len=255), dimension(2), parameter :: & + matrix_prefixes = (/ " ", & + "Reflected" /) + character(len=FIELD_NAME_LEN) :: mesh_name, mesh_name2 - mesh_cnt = option_count("/geometry/mesh") - prefix_cnt = size(matrix_prefixes) + mesh_cnt = option_count("/geometry/mesh") + prefix_cnt = size(matrix_prefixes) - do i = 1, size(state) + do i = 1, size(state) - do prefix = 1, prefix_cnt + do prefix = 1, prefix_cnt - do mesh = 0, mesh_cnt-1 + do mesh = 0, mesh_cnt-1 - call get_option("/geometry/mesh["//int2str(mesh)//"]/name", mesh_name) + call get_option("/geometry/mesh["//int2str(mesh)//"]/name", mesh_name) - if (has_csr_matrix(state(i), & - trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindElements")) then + if (has_csr_matrix(state(i), & + trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindElements")) then - delete = .true. - field_loop: do f = 1, size(state(i)%scalar_fields) - call get_option(trim(state(i)%scalar_fields(f)%ptr%option_path)//"/prognostic/mesh/name", mesh_name2, stat) + delete = .true. + field_loop: do f = 1, size(state(i)%scalar_fields) + call get_option(trim(state(i)%scalar_fields(f)%ptr%option_path)//"/prognostic/mesh/name", mesh_name2, stat) - if(stat==0) then - if(trim(mesh_name2)==trim(mesh_name)) then + if(stat==0) then + if(trim(mesh_name2)==trim(mesh_name)) then - option_path = trim(complete_cv_field_path(state(i)%scalar_fields(f)%ptr%option_path)) + option_path = trim(complete_cv_field_path(state(i)%scalar_fields(f)%ptr%option_path)) - if(have_option(trim(option_path)//"/face_value[0]/limit_face_value")) then - option_path = trim(option_path)//"/face_value[0]/limit_face_value/limiter[0]" - else - option_path = trim(option_path)//"/face_value[0]" - end if + if(have_option(trim(option_path)//"/face_value[0]/limit_face_value")) then + option_path = trim(option_path)//"/face_value[0]/limit_face_value/limiter[0]" + else + option_path = trim(option_path)//"/face_value[0]" + end if - if(have_option(trim(option_path)//"/project_upwind_from_gradient")) then - option_path = trim(option_path)//"/project_upwind_from_gradient/bound_projected_value_locally" - else - option_path = trim(option_path)//"/project_upwind_from_point" - end if + if(have_option(trim(option_path)//"/project_upwind_from_gradient")) then + option_path = trim(option_path)//"/project_upwind_from_gradient/bound_projected_value_locally" + else + option_path = trim(option_path)//"/project_upwind_from_point" + end if - if(have_option(trim(option_path)//& - "/store_upwind_elements")) then - if((trim(matrix_prefixes(prefix))=="Reflected")) then - if(have_option(trim(option_path)//& - "/reflect_off_domain_boundaries")) then - delete = .false. - exit field_loop - end if - else - if(.not.have_option(trim(option_path)//& - "/reflect_off_domain_boundaries")) then - delete = .false. - exit field_loop - end if - end if - end if - end if - end if - end do field_loop + if(have_option(trim(option_path)//& + "/store_upwind_elements")) then + if((trim(matrix_prefixes(prefix))=="Reflected")) then + if(have_option(trim(option_path)//& + "/reflect_off_domain_boundaries")) then + delete = .false. + exit field_loop + end if + else + if(.not.have_option(trim(option_path)//& + "/reflect_off_domain_boundaries")) then + delete = .false. + exit field_loop + end if + end if + end if + end if + end if + end do field_loop - if (delete) then + if (delete) then - call remove_csr_matrix(state(i), trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindElements") + call remove_csr_matrix(state(i), trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindElements") - end if + end if - end if + end if - if (has_block_csr_matrix(state(i), & - trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindQuadrature")) then - delete = .true. - field_loop2: do f = 1, size(state(i)%scalar_fields) + if (has_block_csr_matrix(state(i), & + trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindQuadrature")) then + delete = .true. + field_loop2: do f = 1, size(state(i)%scalar_fields) - call get_option(trim(state(i)%scalar_fields(f)%ptr%option_path)//"/prognostic/mesh/name", mesh_name2, stat) + call get_option(trim(state(i)%scalar_fields(f)%ptr%option_path)//"/prognostic/mesh/name", mesh_name2, stat) - if(stat==0) then - if(trim(mesh_name2)==trim(mesh_name)) then + if(stat==0) then + if(trim(mesh_name2)==trim(mesh_name)) then - option_path = trim(complete_cv_field_path(state(i)%scalar_fields(f)%ptr%option_path)) + option_path = trim(complete_cv_field_path(state(i)%scalar_fields(f)%ptr%option_path)) - if(have_option(trim(option_path)//"/face_value[0]/limit_face_value")) then - option_path = trim(option_path)//"/face_value[0]/limit_face_value/limiter[0]" - else - option_path = trim(option_path)//"/face_value[0]" - end if + if(have_option(trim(option_path)//"/face_value[0]/limit_face_value")) then + option_path = trim(option_path)//"/face_value[0]/limit_face_value/limiter[0]" + else + option_path = trim(option_path)//"/face_value[0]" + end if - option_path = trim(option_path)//"/project_upwind_from_point" ! not possible to store quadratures with gradient based method - - if(have_option(trim(option_path)//& - "/store_upwind_elements/store_upwind_quadrature")) then - if((trim(matrix_prefixes(prefix))=="Reflected")) then - if(have_option(trim(option_path)//& - "/reflect_off_domain_boundaries")) then - delete = .false. - exit field_loop2 - end if - else - if(.not.have_option(trim(option_path)//& - "/reflect_off_domain_boundaries")) then - delete = .false. - exit field_loop2 - end if - end if - end if - end if - end if - end do field_loop2 + option_path = trim(option_path)//"/project_upwind_from_point" ! not possible to store quadratures with gradient based method - if (delete) then + if(have_option(trim(option_path)//& + "/store_upwind_elements/store_upwind_quadrature")) then + if((trim(matrix_prefixes(prefix))=="Reflected")) then + if(have_option(trim(option_path)//& + "/reflect_off_domain_boundaries")) then + delete = .false. + exit field_loop2 + end if + else + if(.not.have_option(trim(option_path)//& + "/reflect_off_domain_boundaries")) then + delete = .false. + exit field_loop2 + end if + end if + end if + end if + end if + end do field_loop2 - call remove_block_csr_matrix(state(i), trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindQuadrature") + if (delete) then - end if + call remove_block_csr_matrix(state(i), trim(matrix_prefixes(prefix))//trim(mesh_name)//"CVUpwindQuadrature") - end if + end if - end do + end if - end do + end do - end do + end do + + end do - end subroutine clean_deferred_deletion_multiple_states + end subroutine clean_deferred_deletion_multiple_states end module cvtools diff --git a/femtools/CV_Face_Values.F90 b/femtools/CV_Face_Values.F90 index 50e83ca9ae..1cde156b92 100644 --- a/femtools/CV_Face_Values.F90 +++ b/femtools/CV_Face_Values.F90 @@ -26,297 +26,297 @@ ! USA #include "fdebug.h" module cv_face_values - !!< Module containing general tools for discretising Control Volume problems. - use spud - use fldebug - use sparse_tools - use element_numbering - use vector_tools - use elements - use cv_faces - use transform_elements - use fields - use state_module - use cv_shape_functions - use cv_options - use field_derivatives, only: grad - - implicit none - - real, private, parameter :: tolerance=tiny(0.0) - - private - public :: cv_facevalue_integer, & - evaluate_face_val, & - theta_val, & - couple_face_value + !!< Module containing general tools for discretising Control Volume problems. + use spud + use fldebug + use sparse_tools + use element_numbering + use vector_tools + use elements + use cv_faces + use transform_elements + use fields + use state_module + use cv_shape_functions + use cv_options + use field_derivatives, only: grad + + implicit none + + real, private, parameter :: tolerance=tiny(0.0) + + private + public :: cv_facevalue_integer, & + evaluate_face_val, & + theta_val, & + couple_face_value contains - subroutine evaluate_face_val(face_val, old_face_val, & - iloc, oloc, ggi, nodes, & - cvshape, & - field_ele, old_field_ele, & - upwind_values, old_upwind_values, & - inflow, cfl_ele, & - cv_options, save_pos) - - ! given a discretisation type calculate the face value for a field - - ! output: - real, intent(out) :: face_val, old_face_val - - ! input: - integer, intent(in) :: iloc, oloc, ggi - integer, dimension(:) :: nodes - type(element_type) :: cvshape - real, dimension(:) :: field_ele, old_field_ele - type(csr_matrix), intent(in) :: upwind_values, old_upwind_values - logical, intent(in) :: inflow - real, dimension(:), intent(in) :: cfl_ele - type(cv_options_type), intent(in) :: cv_options ! a wrapper type to pass in all the options for control volumes - integer, intent(inout), optional :: save_pos - - ! local memory: - real :: upwind_val, donor_val, downwind_val - real :: old_upwind_val, old_donor_val, old_downwind_val - real :: cfl_donor - real :: potential, old_potential - real :: target_upwind, old_target_upwind, target_downwind, old_target_downwind - real :: income=0.0 - integer :: l_save_pos - - if(present(save_pos)) then - l_save_pos=save_pos ! an attempt at optimising the val calls by saving the matrix position - else - l_save_pos = 0 - end if - - select case(cv_options%facevalue) - case (CV_FACEVALUE_FIRSTORDERUPWIND) - - income = merge(1.0,0.0,inflow) - - donor_val = income*field_ele(oloc) + (1.-income)*field_ele(iloc) - old_donor_val = income*old_field_ele(oloc) + (1.-income)*old_field_ele(iloc) - - face_val = donor_val - old_face_val = old_donor_val - - case (CV_FACEVALUE_TRAPEZOIDAL) - - face_val = 0.5*(field_ele(oloc) + field_ele(iloc)) - old_face_val = 0.5*(old_field_ele(oloc) + old_field_ele(iloc)) - - case (CV_FACEVALUE_FINITEELEMENT) - - face_val = dot_product(cvshape%n(:,ggi), field_ele) - old_face_val = dot_product(cvshape%n(:,ggi), old_field_ele) - - case (CV_FACEVALUE_HYPERC) - - income = merge(1.0,0.0,inflow) - - cfl_donor = income*cfl_ele(oloc) + (1.-income)*cfl_ele(iloc) - - downwind_val = income*field_ele(iloc) + (1.-income)*field_ele(oloc) - donor_val = income*field_ele(oloc) + (1.-income)*field_ele(iloc) - if(inflow) then - upwind_val = val(upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) - ! save_pos should save the value of csr_pos in this call + subroutine evaluate_face_val(face_val, old_face_val, & + iloc, oloc, ggi, nodes, & + cvshape, & + field_ele, old_field_ele, & + upwind_values, old_upwind_values, & + inflow, cfl_ele, & + cv_options, save_pos) + + ! given a discretisation type calculate the face value for a field + + ! output: + real, intent(out) :: face_val, old_face_val + + ! input: + integer, intent(in) :: iloc, oloc, ggi + integer, dimension(:) :: nodes + type(element_type) :: cvshape + real, dimension(:) :: field_ele, old_field_ele + type(csr_matrix), intent(in) :: upwind_values, old_upwind_values + logical, intent(in) :: inflow + real, dimension(:), intent(in) :: cfl_ele + type(cv_options_type), intent(in) :: cv_options ! a wrapper type to pass in all the options for control volumes + integer, intent(inout), optional :: save_pos + + ! local memory: + real :: upwind_val, donor_val, downwind_val + real :: old_upwind_val, old_donor_val, old_downwind_val + real :: cfl_donor + real :: potential, old_potential + real :: target_upwind, old_target_upwind, target_downwind, old_target_downwind + real :: income=0.0 + integer :: l_save_pos + + if(present(save_pos)) then + l_save_pos=save_pos ! an attempt at optimising the val calls by saving the matrix position else - upwind_val = val(upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) + l_save_pos = 0 end if - old_downwind_val = income*old_field_ele(iloc) + (1.-income)*old_field_ele(oloc) - old_donor_val = income*old_field_ele(oloc) + (1.-income)*old_field_ele(iloc) - if(inflow) then - old_upwind_val = val(old_upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) - ! and as inflow is the same it should reuse it in this call - ! (similarly for all uses below) - else - old_upwind_val = val(old_upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) - end if + select case(cv_options%facevalue) + case (CV_FACEVALUE_FIRSTORDERUPWIND) - face_val = hyperc_val(upwind_val, donor_val, downwind_val, cfl_donor) - old_face_val = hyperc_val(old_upwind_val, old_donor_val, & - old_downwind_val, cfl_donor) + income = merge(1.0,0.0,inflow) - case (CV_FACEVALUE_ULTRAC) + donor_val = income*field_ele(oloc) + (1.-income)*field_ele(iloc) + old_donor_val = income*old_field_ele(oloc) + (1.-income)*old_field_ele(iloc) - income = merge(1.0,0.0,inflow) + face_val = donor_val + old_face_val = old_donor_val - cfl_donor = income*cfl_ele(oloc) + (1.-income)*cfl_ele(iloc) + case (CV_FACEVALUE_TRAPEZOIDAL) - downwind_val = income*field_ele(iloc) + (1.-income)*field_ele(oloc) - donor_val = income*field_ele(oloc) + (1.-income)*field_ele(iloc) - if(inflow) then - upwind_val = val(upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) - else - upwind_val = val(upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) - end if + face_val = 0.5*(field_ele(oloc) + field_ele(iloc)) + old_face_val = 0.5*(old_field_ele(oloc) + old_field_ele(iloc)) - old_downwind_val = income*old_field_ele(iloc) + (1.-income)*old_field_ele(oloc) - old_donor_val = income*old_field_ele(oloc) + (1.-income)*old_field_ele(iloc) - if(inflow) then - old_upwind_val = val(old_upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) - else - old_upwind_val = val(old_upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) - end if + case (CV_FACEVALUE_FINITEELEMENT) - if(downwind_valcv_options%target_max-tolerance) then - if(downwind_valcv_options%target_max-tolerance) then - if(old_downwind_valcv_options%target_max-tolerance) then + if(downwind_valcv_options%target_max-tolerance) then + if(old_downwind_val0.0).and.((nvd_donor)<1.0)) then hyperc_val = upwind_val+& - (min(1.0, max((nvd_donor/cfl_donor), nvd_donor)))*nvd_denom + (min(1.0, max((nvd_donor/cfl_donor), nvd_donor)))*nvd_denom else hyperc_val = donor_val end if end function hyperc_val - function limit_val(upwind_val, donor_val, downwind_val, face_val, & - limiter, cfl_donor, limiter_slopes) - - ! given an upwind, downwind, donor and face value and the slopes of the limiter - ! decide if the face value needs to be limited and do so if necessary - - real, intent(in) :: upwind_val, donor_val, downwind_val, face_val, cfl_donor - integer, intent(in) :: limiter - real, dimension(2), intent(in) :: limiter_slopes + function limit_val(upwind_val, donor_val, downwind_val, face_val, & + limiter, cfl_donor, limiter_slopes) - real :: limit_val + ! given an upwind, downwind, donor and face value and the slopes of the limiter + ! decide if the face value needs to be limited and do so if necessary - real :: nvd_denom, nvd_donor, nvd_face + real, intent(in) :: upwind_val, donor_val, downwind_val, face_val, cfl_donor + integer, intent(in) :: limiter + real, dimension(2), intent(in) :: limiter_slopes - limit_val = 0.0 + real :: limit_val - nvd_denom = sign(max(abs(downwind_val-upwind_val),tolerance),& - downwind_val-upwind_val) - nvd_donor = (donor_val-upwind_val)/nvd_denom - nvd_face = (face_val-upwind_val)/nvd_denom + real :: nvd_denom, nvd_donor, nvd_face - select case(limiter) - case(CV_LIMITER_SWEBY) + limit_val = 0.0 - if(((nvd_donor)>0.0).and.((nvd_donor)<1.0)) then - limit_val = upwind_val+& - (min(1.0, (limiter_slopes(2)*nvd_donor), & - max(nvd_face, limiter_slopes(1)*nvd_donor)))*nvd_denom - else - limit_val = donor_val - end if - - case(CV_LIMITER_ULTIMATE) - - if(((nvd_donor)>0.0).and.((nvd_donor)<1.0)) then - limit_val = upwind_val+& - (min(1.0, nvd_donor/cfl_donor, & - max(nvd_face, nvd_donor)))*nvd_denom + nvd_denom = sign(max(abs(downwind_val-upwind_val),tolerance),& + downwind_val-upwind_val) + nvd_donor = (donor_val-upwind_val)/nvd_denom + nvd_face = (face_val-upwind_val)/nvd_denom + + select case(limiter) + case(CV_LIMITER_SWEBY) + + if(((nvd_donor)>0.0).and.((nvd_donor)<1.0)) then + limit_val = upwind_val+& + (min(1.0, (limiter_slopes(2)*nvd_donor), & + max(nvd_face, limiter_slopes(1)*nvd_donor)))*nvd_denom + else + limit_val = donor_val + end if + + case(CV_LIMITER_ULTIMATE) + + if(((nvd_donor)>0.0).and.((nvd_donor)<1.0)) then + limit_val = upwind_val+& + (min(1.0, nvd_donor/cfl_donor, & + max(nvd_face, nvd_donor)))*nvd_denom + else + limit_val = donor_val + end if + + end select + + end function limit_val + + subroutine couple_face_value(face_val, old_face_val, & + sibling_face_val, old_sibling_face_val, & + field_ele, old_field_ele, & + sibling_field_ele, old_sibling_field_ele, & + upwind_values, old_upwind_values, & + inflow, iloc, oloc, nodes, cfl_ele, & + cv_options, save_pos) + + real, intent(inout) :: face_val, old_face_val + real, intent(in) :: sibling_face_val, old_sibling_face_val + logical, intent(in) :: inflow + integer, intent(in) :: iloc, oloc + integer, dimension(:) :: nodes + + real, dimension(:), intent(in) :: cfl_ele, field_ele, old_field_ele, sibling_field_ele, old_sibling_field_ele + type(csr_matrix), intent(in) :: upwind_values, old_upwind_values + type(cv_options_type), intent(in) :: cv_options ! a wrapper type to pass in all the options for control volumes + integer, intent(inout), optional :: save_pos + + ! local memory + real :: income, cfl_donor + real :: downwind_val, donor_val, upwind_val + real :: old_downwind_val, old_donor_val, old_upwind_val + real :: sibling_downwind_val, sibling_donor_val + real :: old_sibling_downwind_val, old_sibling_donor_val + real, dimension(2) :: parent_target_vals, old_parent_target_vals + integer :: l_save_pos + + if(present(save_pos)) then + l_save_pos = save_pos else - limit_val = donor_val + l_save_pos = 0 end if - end select - - end function limit_val - - subroutine couple_face_value(face_val, old_face_val, & - sibling_face_val, old_sibling_face_val, & - field_ele, old_field_ele, & - sibling_field_ele, old_sibling_field_ele, & - upwind_values, old_upwind_values, & - inflow, iloc, oloc, nodes, cfl_ele, & - cv_options, save_pos) - - real, intent(inout) :: face_val, old_face_val - real, intent(in) :: sibling_face_val, old_sibling_face_val - logical, intent(in) :: inflow - integer, intent(in) :: iloc, oloc - integer, dimension(:) :: nodes - - real, dimension(:), intent(in) :: cfl_ele, field_ele, old_field_ele, sibling_field_ele, old_sibling_field_ele - type(csr_matrix), intent(in) :: upwind_values, old_upwind_values - type(cv_options_type), intent(in) :: cv_options ! a wrapper type to pass in all the options for control volumes - integer, intent(inout), optional :: save_pos - - ! local memory - real :: income, cfl_donor - real :: downwind_val, donor_val, upwind_val - real :: old_downwind_val, old_donor_val, old_upwind_val - real :: sibling_downwind_val, sibling_donor_val - real :: old_sibling_downwind_val, old_sibling_donor_val - real, dimension(2) :: parent_target_vals, old_parent_target_vals - integer :: l_save_pos - - if(present(save_pos)) then - l_save_pos = save_pos - else - l_save_pos = 0 - end if - - income = merge(1.0,0.0,inflow) + income = merge(1.0,0.0,inflow) - cfl_donor = income*cfl_ele(oloc) + (1.-income)*cfl_ele(iloc) + cfl_donor = income*cfl_ele(oloc) + (1.-income)*cfl_ele(iloc) - downwind_val = income*field_ele(iloc) + (1.-income)*field_ele(oloc) + downwind_val = income*field_ele(iloc) + (1.-income)*field_ele(oloc) - donor_val = income*field_ele(oloc) + (1.-income)*field_ele(iloc) + donor_val = income*field_ele(oloc) + (1.-income)*field_ele(iloc) - sibling_downwind_val = income*sibling_field_ele(iloc) + (1.-income)*sibling_field_ele(oloc) + sibling_downwind_val = income*sibling_field_ele(iloc) + (1.-income)*sibling_field_ele(oloc) - sibling_donor_val = income*sibling_field_ele(oloc) + (1.-income)*sibling_field_ele(iloc) + sibling_donor_val = income*sibling_field_ele(oloc) + (1.-income)*sibling_field_ele(iloc) - if(inflow) then - upwind_val = val(upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) - else - upwind_val = val(upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) - end if + if(inflow) then + upwind_val = val(upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) + else + upwind_val = val(upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) + end if - parent_target_vals = (/cv_options%sum_target_max, cv_options%sum_target_min/) + parent_target_vals = (/cv_options%sum_target_max, cv_options%sum_target_min/) - face_val = limit_val_coupled(upwind_val, donor_val, downwind_val, face_val, & - sibling_donor_val, sibling_face_val, & - parent_target_vals, & - cv_options%limiter, cfl_donor, cv_options%limiter_slopes) + face_val = limit_val_coupled(upwind_val, donor_val, downwind_val, face_val, & + sibling_donor_val, sibling_face_val, & + parent_target_vals, & + cv_options%limiter, cfl_donor, cv_options%limiter_slopes) - old_downwind_val = income*old_field_ele(iloc) + (1.-income)*old_field_ele(oloc) + old_downwind_val = income*old_field_ele(iloc) + (1.-income)*old_field_ele(oloc) - old_donor_val = income*old_field_ele(oloc) + (1.-income)*old_field_ele(iloc) + old_donor_val = income*old_field_ele(oloc) + (1.-income)*old_field_ele(iloc) - old_sibling_downwind_val = income*old_sibling_field_ele(iloc) + (1.-income)*old_sibling_field_ele(oloc) + old_sibling_downwind_val = income*old_sibling_field_ele(iloc) + (1.-income)*old_sibling_field_ele(oloc) - old_sibling_donor_val = income*old_sibling_field_ele(oloc) + (1.-income)*old_sibling_field_ele(iloc) + old_sibling_donor_val = income*old_sibling_field_ele(oloc) + (1.-income)*old_sibling_field_ele(iloc) - if(inflow) then - old_upwind_val = val(old_upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) - else - old_upwind_val = val(old_upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) - end if + if(inflow) then + old_upwind_val = val(old_upwind_values, nodes(oloc), nodes(iloc), save_pos=l_save_pos) + else + old_upwind_val = val(old_upwind_values, nodes(iloc), nodes(oloc), save_pos=l_save_pos) + end if - old_parent_target_vals = (/cv_options%sum_target_max, cv_options%sum_target_min/) + old_parent_target_vals = (/cv_options%sum_target_max, cv_options%sum_target_min/) - old_face_val = limit_val_coupled(old_upwind_val, old_donor_val, old_downwind_val, old_face_val, & - old_sibling_donor_val, old_sibling_face_val, & - old_parent_target_vals, & - cv_options%limiter, cfl_donor, cv_options%limiter_slopes) + old_face_val = limit_val_coupled(old_upwind_val, old_donor_val, old_downwind_val, old_face_val, & + old_sibling_donor_val, old_sibling_face_val, & + old_parent_target_vals, & + cv_options%limiter, cfl_donor, cv_options%limiter_slopes) - if(present(save_pos)) then - save_pos = l_save_pos - end if + if(present(save_pos)) then + save_pos = l_save_pos + end if - end subroutine couple_face_value + end subroutine couple_face_value - function limit_val_coupled(upwind_val, donor_val, downwind_val, face_val, & - sibling_donor_val, sibling_face_val, & - parent_target_vals, & - limiter, cfl_donor, limiter_slopes) + function limit_val_coupled(upwind_val, donor_val, downwind_val, face_val, & + sibling_donor_val, sibling_face_val, & + parent_target_vals, & + limiter, cfl_donor, limiter_slopes) - ! given an upwind, downwind, donor and face value of a field and its sibling - ! decide if the field face value needs to be limited and do so if necessary + ! given an upwind, downwind, donor and face value of a field and its sibling + ! decide if the field face value needs to be limited and do so if necessary - real, intent(in) :: upwind_val, donor_val, downwind_val, face_val, cfl_donor - real, intent(in) :: sibling_donor_val, sibling_face_val - real, dimension(2), intent(in) :: parent_target_vals - integer, intent(in) :: limiter - real, dimension(2), intent(in) :: limiter_slopes + real, intent(in) :: upwind_val, donor_val, downwind_val, face_val, cfl_donor + real, intent(in) :: sibling_donor_val, sibling_face_val + real, dimension(2), intent(in) :: parent_target_vals + integer, intent(in) :: limiter + real, dimension(2), intent(in) :: limiter_slopes - real :: limit_val_coupled + real :: limit_val_coupled - real :: nvd_denom, nvd_donor, nvd_face - real :: nvd_sibling_donor, nvd_sibling_face - real, dimension(2) :: nvd_parent_targets + real :: nvd_denom, nvd_donor, nvd_face + real :: nvd_sibling_donor, nvd_sibling_face + real, dimension(2) :: nvd_parent_targets - real, dimension(2) :: monotonicity_bounds - real, dimension(2) :: downwind_lines, limited_lines - real :: upwind_line + real, dimension(2) :: monotonicity_bounds + real, dimension(2) :: downwind_lines, limited_lines + real :: upwind_line - limit_val_coupled = 0.0 + limit_val_coupled = 0.0 - nvd_denom = sign(max(abs(downwind_val-upwind_val),tolerance),& - downwind_val-upwind_val) + nvd_denom = sign(max(abs(downwind_val-upwind_val),tolerance),& + downwind_val-upwind_val) - nvd_donor = (donor_val-upwind_val)/nvd_denom - nvd_face = (face_val-upwind_val)/nvd_denom + nvd_donor = (donor_val-upwind_val)/nvd_denom + nvd_face = (face_val-upwind_val)/nvd_denom - nvd_sibling_donor = (sibling_donor_val-upwind_val)/nvd_denom - nvd_sibling_face = (sibling_face_val-upwind_val)/nvd_denom - nvd_parent_targets = (parent_target_vals-2.*upwind_val)/nvd_denom + nvd_sibling_donor = (sibling_donor_val-upwind_val)/nvd_denom + nvd_sibling_face = (sibling_face_val-upwind_val)/nvd_denom + nvd_parent_targets = (parent_target_vals-2.*upwind_val)/nvd_denom - downwind_lines = nvd_parent_targets - nvd_sibling_face - monotonicity_bounds = nvd_parent_targets-nvd_sibling_donor - upwind_line = nvd_donor + nvd_sibling_donor - nvd_sibling_face + downwind_lines = nvd_parent_targets - nvd_sibling_face + monotonicity_bounds = nvd_parent_targets-nvd_sibling_donor + upwind_line = nvd_donor + nvd_sibling_donor - nvd_sibling_face - select case(limiter) - case(CV_LIMITER_SWEBY) + select case(limiter) + case(CV_LIMITER_SWEBY) - limited_lines = limiter_slopes(2)*(nvd_donor + nvd_sibling_donor - nvd_parent_targets) & - + nvd_parent_targets - nvd_sibling_face + limited_lines = limiter_slopes(2)*(nvd_donor + nvd_sibling_donor - nvd_parent_targets) & + + nvd_parent_targets - nvd_sibling_face - case default ! unless Sweby is specified use ULTIMATE (even if limiter type is NONE) + case default ! unless Sweby is specified use ULTIMATE (even if limiter type is NONE) - limited_lines = (1./cfl_donor)*(nvd_donor + nvd_sibling_donor - nvd_parent_targets) & - + nvd_parent_targets - nvd_sibling_face - end select + limited_lines = (1./cfl_donor)*(nvd_donor + nvd_sibling_donor - nvd_parent_targets) & + + nvd_parent_targets - nvd_sibling_face + end select - if((nvd_donor>minval(monotonicity_bounds)).and.& - (nvd_donorminval(monotonicity_bounds)).and.& + (nvd_donorCV_LINE_MAX_DEGREE) then - FLExit('Invalid control volume degree') - else - cv_temp_list=>cv_line_face_temp - cvbdy_temp_list=> cv_point_bdy_temp - end if - case default - - FLExit('Invalid control volume type.') + function find_cv_faces(vertices, dimension, polydegree, quaddegree, quadngi) result (cvfaces) + ! Return the element numbering type for an element in dimension + ! dimensions with vertices vertices and degree polynomial bases. + ! + ! If no suitable numbering is available, return a null pointer. + type(face_corner_template), dimension(:), pointer :: cv_temp_list, cvbdy_temp_list + type(face_corner_template), pointer :: cv_temp, cvbdy_temp + type(cv_faces_type) :: cvfaces + integer, intent(in) :: vertices, dimension, polydegree + integer, intent(in), optional :: quaddegree, quadngi + + type(quadrature_type) :: face_quad + + if (.not.initialised) call locate_controlvolume_corners + + select case(dimension) + case(1) + select case (vertices) + case (2) + !Line segments + if (polydegree>CV_LINE_MAX_DEGREE) then + FLExit('Invalid control volume degree') + else + cv_temp_list=>cv_line_face_temp + cvbdy_temp_list=> cv_point_bdy_temp + end if + case default + + FLExit('Invalid control volume type.') + + end select + + case(2) + select case (vertices) + case (3) + !Triangles + if (polydegree>CV_TRI_MAX_DEGREE) then + FLExit('Invalid control volume degree.') + else + cv_temp_list=>cv_tri_face_temp + cvbdy_temp_list=>cv_line_bdy_temp + end if + + case (4) + !Quads + if (polydegree>CV_QUAD_MAX_DEGREE) then + FLExit('Invalid control volume degree.') + else + cv_temp_list=>cv_quad_face_temp + cvbdy_temp_list=>cv_line_bdy_temp + end if + + case default + + FLExit('Invalid control volume type.') + + end select + + case(3) + + select case (vertices) + case (4) + !Tets + if (polydegree>CV_TET_MAX_DEGREE) then + FLExit('Invalid control volume degree.') + else + cv_temp_list=>cv_tet_face_temp + cvbdy_temp_list=>cv_tet_bdy_temp + end if + + case(8) + !Hexes + if (polydegree>CV_HEX_MAX_DEGREE) then + FLExit('Invalid control volume degree.') + else + cv_temp_list=>cv_hex_face_temp + cvbdy_temp_list=>cv_hex_bdy_temp + end if + + case default + + FLExit('Invalid control volume type.') + + end select + + case default + + FLExit('Invalid control volume type.') end select - case(2) - select case (vertices) - case (3) - !Triangles - if (polydegree>CV_TRI_MAX_DEGREE) then - FLExit('Invalid control volume degree.') - else - cv_temp_list=>cv_tri_face_temp - cvbdy_temp_list=>cv_line_bdy_temp - end if - - case (4) - !Quads - if (polydegree>CV_QUAD_MAX_DEGREE) then - FLExit('Invalid control volume degree.') - else - cv_temp_list=>cv_quad_face_temp - cvbdy_temp_list=>cv_line_bdy_temp - end if - - case default - - FLExit('Invalid control volume type.') - - end select - - case(3) - - select case (vertices) - case (4) - !Tets - if (polydegree>CV_TET_MAX_DEGREE) then - FLExit('Invalid control volume degree.') - else - cv_temp_list=>cv_tet_face_temp - cvbdy_temp_list=>cv_tet_bdy_temp - end if - - case(8) - !Hexes - if (polydegree>CV_HEX_MAX_DEGREE) then - FLExit('Invalid control volume degree.') - else - cv_temp_list=>cv_hex_face_temp - cvbdy_temp_list=>cv_hex_bdy_temp - end if - - case default - - FLExit('Invalid control volume type.') - - end select - - case default - - FLExit('Invalid control volume type.') - - end select - - cv_temp=>cv_temp_list(minloc(cv_temp_list%degree, dim=1,& - mask=cv_temp_list%degree>=polydegree)) - cvbdy_temp=>cvbdy_temp_list(minloc(cvbdy_temp_list%degree, dim=1,& - mask=cvbdy_temp_list%degree>=polydegree)) - - ! Now we can start putting together the face info. - call allocate(cvfaces, cv_temp%nodes, cvbdy_temp%nodes, cv_temp%faces, cvbdy_temp%faces, & - cv_temp%coords, cvbdy_temp%coords, & - cv_temp%ncorn) - cvfaces%vertices=cv_temp%vertices - cvfaces%nodes=cv_temp%nodes - cvfaces%svertices=cvbdy_temp%vertices - cvfaces%snodes=cvbdy_temp%nodes - cvfaces%coords=cv_temp%coords - cvfaces%scoords=cvbdy_temp%coords - cvfaces%faces=cv_temp%faces - cvfaces%sfaces=cvbdy_temp%faces - cvfaces%dim=dimension - cvfaces%degree=polydegree - - call expand_cv_faces_template(cvfaces, cv_temp, cvbdy_temp) - - if(present(quaddegree)) then - face_quad=make_quadrature(vertices=size(cvfaces%corners, 3),dim=(cvfaces%dim-1), & - degree=quaddegree) - elseif(present(quadngi)) then - face_quad=make_quadrature(vertices=size(cvfaces%corners, 3),dim=(cvfaces%dim-1), & - ngi=quadngi) - else - ! code error - FLAbort('Must specifiy either quaddegree or quadngi') - end if - - cvfaces%shape=make_element_shape(vertices=size(cvfaces%corners, 3), dim=(cvfaces%dim-1), & - degree=1, quad=face_quad, & - type=ELEMENT_LAGRANGIAN) - - call deallocate(face_quad) - - end function find_cv_faces - - subroutine allocate_cv_faces_type(cvfaces, nodes, snodes, faces, sfaces, coords, scoords, & - ncorn, stat) - !!< Allocate memory for a quadrature type. Note that this is done - !!< automatically in make_quadrature. - type(cv_faces_type), intent(inout) :: cvfaces - !! nodes is the number of nodes - integer, intent(in) :: nodes, snodes, faces, sfaces, ncorn, coords, scoords - !! Stat returns zero for successful completion and nonzero otherwise. - integer, intent(out), optional :: stat - - integer :: lstat - - allocate(cvfaces%corners(faces,coords,ncorn), cvfaces%neiloc(nodes,faces), & - cvfaces%scorners(sfaces,scoords,ncorn), cvfaces%sneiloc(snodes,sfaces), & - stat=lstat) - - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Error allocating cvfaces") - end if - - end subroutine allocate_cv_faces_type - - subroutine deallocate_cv_faces_type(cvfaces,stat) - !! The cvloc type to be deallocated. - type(cv_faces_type), intent(inout) :: cvfaces - !! Stat returns zero for successful completion and nonzero otherwise. - integer, intent(out), optional :: stat - - integer :: lstat, tstat - - lstat=0 - tstat=0 - - deallocate(cvfaces%corners, cvfaces%neiloc, & - cvfaces%scorners, cvfaces%sneiloc, stat = tstat) - lstat=max(tstat,lstat) - call deallocate(cvfaces%shape, stat= tstat) - lstat=max(tstat,lstat) - - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Error deallocating cvfaces") - end if - - end subroutine deallocate_cv_faces_type + cv_temp=>cv_temp_list(minloc(cv_temp_list%degree, dim=1,& + mask=cv_temp_list%degree>=polydegree)) + cvbdy_temp=>cvbdy_temp_list(minloc(cvbdy_temp_list%degree, dim=1,& + mask=cvbdy_temp_list%degree>=polydegree)) + + ! Now we can start putting together the face info. + call allocate(cvfaces, cv_temp%nodes, cvbdy_temp%nodes, cv_temp%faces, cvbdy_temp%faces, & + cv_temp%coords, cvbdy_temp%coords, & + cv_temp%ncorn) + cvfaces%vertices=cv_temp%vertices + cvfaces%nodes=cv_temp%nodes + cvfaces%svertices=cvbdy_temp%vertices + cvfaces%snodes=cvbdy_temp%nodes + cvfaces%coords=cv_temp%coords + cvfaces%scoords=cvbdy_temp%coords + cvfaces%faces=cv_temp%faces + cvfaces%sfaces=cvbdy_temp%faces + cvfaces%dim=dimension + cvfaces%degree=polydegree + + call expand_cv_faces_template(cvfaces, cv_temp, cvbdy_temp) + + if(present(quaddegree)) then + face_quad=make_quadrature(vertices=size(cvfaces%corners, 3),dim=(cvfaces%dim-1), & + degree=quaddegree) + elseif(present(quadngi)) then + face_quad=make_quadrature(vertices=size(cvfaces%corners, 3),dim=(cvfaces%dim-1), & + ngi=quadngi) + else + ! code error + FLAbort('Must specifiy either quaddegree or quadngi') + end if + + cvfaces%shape=make_element_shape(vertices=size(cvfaces%corners, 3), dim=(cvfaces%dim-1), & + degree=1, quad=face_quad, & + type=ELEMENT_LAGRANGIAN) + + call deallocate(face_quad) + + end function find_cv_faces + + subroutine allocate_cv_faces_type(cvfaces, nodes, snodes, faces, sfaces, coords, scoords, & + ncorn, stat) + !!< Allocate memory for a quadrature type. Note that this is done + !!< automatically in make_quadrature. + type(cv_faces_type), intent(inout) :: cvfaces + !! nodes is the number of nodes + integer, intent(in) :: nodes, snodes, faces, sfaces, ncorn, coords, scoords + !! Stat returns zero for successful completion and nonzero otherwise. + integer, intent(out), optional :: stat + + integer :: lstat + + allocate(cvfaces%corners(faces,coords,ncorn), cvfaces%neiloc(nodes,faces), & + cvfaces%scorners(sfaces,scoords,ncorn), cvfaces%sneiloc(snodes,sfaces), & + stat=lstat) + + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Error allocating cvfaces") + end if + + end subroutine allocate_cv_faces_type + + subroutine deallocate_cv_faces_type(cvfaces,stat) + !! The cvloc type to be deallocated. + type(cv_faces_type), intent(inout) :: cvfaces + !! Stat returns zero for successful completion and nonzero otherwise. + integer, intent(out), optional :: stat + + integer :: lstat, tstat + + lstat=0 + tstat=0 + + deallocate(cvfaces%corners, cvfaces%neiloc, & + cvfaces%scorners, cvfaces%sneiloc, stat = tstat) + lstat=max(tstat,lstat) + call deallocate(cvfaces%shape, stat= tstat) + lstat=max(tstat,lstat) + + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Error deallocating cvfaces") + end if + + end subroutine deallocate_cv_faces_type !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine locate_controlvolume_corners - ! Fill the values in in element_numbering. + subroutine locate_controlvolume_corners + ! Fill the values in in element_numbering. - ! make sure this is idempotent. - if (initialised) return - initialised=.true. + ! make sure this is idempotent. + if (initialised) return + initialised=.true. - call construct_cv_tet_face_permutations - call construct_cv_tet_face_templates - call construct_cv_tet_bdy_permutations - call construct_cv_tet_bdy_templates + call construct_cv_tet_face_permutations + call construct_cv_tet_face_templates + call construct_cv_tet_bdy_permutations + call construct_cv_tet_bdy_templates - call construct_cv_hex_face_permutations - call construct_cv_hex_face_templates - call construct_cv_hex_bdy_permutations - call construct_cv_hex_bdy_templates + call construct_cv_hex_face_permutations + call construct_cv_hex_face_templates + call construct_cv_hex_bdy_permutations + call construct_cv_hex_bdy_templates - call construct_cv_tri_face_permutations - call construct_cv_tri_face_templates + call construct_cv_tri_face_permutations + call construct_cv_tri_face_templates - call construct_cv_quad_face_permutations - call construct_cv_quad_face_templates + call construct_cv_quad_face_permutations + call construct_cv_quad_face_templates - call construct_cv_line_bdy_permutations - call construct_cv_line_bdy_templates + call construct_cv_line_bdy_permutations + call construct_cv_line_bdy_templates - call construct_cv_line_face_permutations - call construct_cv_line_face_templates - call construct_cv_point_bdy_permutations - call construct_cv_point_bdy_templates + call construct_cv_line_face_permutations + call construct_cv_line_face_templates + call construct_cv_point_bdy_permutations + call construct_cv_point_bdy_templates - end subroutine locate_controlvolume_corners + end subroutine locate_controlvolume_corners !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_tet_face_templates - ! Construct list of available templates. - integer :: i - real, dimension(7) :: coords - - coords=0.0 - - cv_tet_face_temp%dimension=3 - cv_tet_face_temp%vertices=4 - cv_tet_face_temp%ncorn=4 - cv_tet_face_temp%coords=4 - - i=0 - - !---------------------------------------------------------------------- - ! Linear tet - i=i+1 - ! One generator per face. - allocate(cv_tet_face_temp(i)%generator(6)) - - cv_tet_face_temp(i)%faces=6 - cv_tet_face_temp(i)%degree=1 - cv_tet_face_temp(i)%nodes=4 - coords(1)=0.25 - coords(2)=0.333333333333333333333333333333333 - coords(3)=0.5 - cv_tet_face_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_tet_face_templates + ! Construct list of available templates. + integer :: i + real, dimension(7) :: coords + + coords=0.0 + + cv_tet_face_temp%dimension=3 + cv_tet_face_temp%vertices=4 + cv_tet_face_temp%ncorn=4 + cv_tet_face_temp%coords=4 + + i=0 + + !---------------------------------------------------------------------- + ! Linear tet + i=i+1 + ! One generator per face. + allocate(cv_tet_face_temp(i)%generator(6)) + + cv_tet_face_temp(i)%faces=6 + cv_tet_face_temp(i)%degree=1 + cv_tet_face_temp(i)%nodes=4 + coords(1)=0.25 + coords(2)=0.333333333333333333333333333333333 + coords(3)=0.5 + cv_tet_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_tet_face_permutations(1), & nodes=(/1,2/), & coords=coords) - cv_tet_face_temp(i)%generator(2)=make_face_generator( & + cv_tet_face_temp(i)%generator(2)=make_face_generator( & permutation=cv_tet_face_permutations(2), & nodes=(/2,3/), & coords=coords) - cv_tet_face_temp(i)%generator(3)=make_face_generator( & + cv_tet_face_temp(i)%generator(3)=make_face_generator( & permutation=cv_tet_face_permutations(3), & nodes=(/1,3/), & coords=coords) - cv_tet_face_temp(i)%generator(4)=make_face_generator( & + cv_tet_face_temp(i)%generator(4)=make_face_generator( & permutation=cv_tet_face_permutations(4), & nodes=(/1,4/), & coords=coords) - cv_tet_face_temp(i)%generator(5)=make_face_generator( & + cv_tet_face_temp(i)%generator(5)=make_face_generator( & permutation=cv_tet_face_permutations(5), & nodes=(/2,4/), & coords=coords) - cv_tet_face_temp(i)%generator(6)=make_face_generator( & + cv_tet_face_temp(i)%generator(6)=make_face_generator( & permutation=cv_tet_face_permutations(6), & nodes=(/3,4/), & coords=coords) - !---------------------------------------------------------------------- - ! Quadratic tet - i=i+1 - ! One generator per face. - allocate(cv_tet_face_temp(i)%generator(24)) - - cv_tet_face_temp(i)%faces=24 - cv_tet_face_temp(i)%degree=2 - cv_tet_face_temp(i)%nodes=10 - coords(1)=0.125 - coords(2)=0.166666666666666666666666666666666 - coords(3)=0.25 - coords(4)=0.333333333333333333333333333333333 - coords(5)=0.625 - coords(6)=0.666666666666666666666666666666666 - coords(7)=0.75 - cv_tet_face_temp(i)%generator(1)=make_face_generator( & + !---------------------------------------------------------------------- + ! Quadratic tet + i=i+1 + ! One generator per face. + allocate(cv_tet_face_temp(i)%generator(24)) + + cv_tet_face_temp(i)%faces=24 + cv_tet_face_temp(i)%degree=2 + cv_tet_face_temp(i)%nodes=10 + coords(1)=0.125 + coords(2)=0.166666666666666666666666666666666 + coords(3)=0.25 + coords(4)=0.333333333333333333333333333333333 + coords(5)=0.625 + coords(6)=0.666666666666666666666666666666666 + coords(7)=0.75 + cv_tet_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_tet_face_permutations(7), & nodes=(/1,2/), & coords=coords) - cv_tet_face_temp(i)%generator(2)=make_face_generator( & + cv_tet_face_temp(i)%generator(2)=make_face_generator( & permutation=cv_tet_face_permutations(8), & nodes=(/1,4/), & coords=coords) - cv_tet_face_temp(i)%generator(3)=make_face_generator( & + cv_tet_face_temp(i)%generator(3)=make_face_generator( & permutation=cv_tet_face_permutations(9), & nodes=(/1,7/), & coords=coords) - cv_tet_face_temp(i)%generator(4)=make_face_generator( & + cv_tet_face_temp(i)%generator(4)=make_face_generator( & permutation=cv_tet_face_permutations(10), & nodes=(/2,3/), & coords=coords) - cv_tet_face_temp(i)%generator(5)=make_face_generator( & + cv_tet_face_temp(i)%generator(5)=make_face_generator( & permutation=cv_tet_face_permutations(11), & nodes=(/3,5/), & coords=coords) - cv_tet_face_temp(i)%generator(6)=make_face_generator( & + cv_tet_face_temp(i)%generator(6)=make_face_generator( & permutation=cv_tet_face_permutations(12), & nodes=(/3,8/), & coords=coords) - cv_tet_face_temp(i)%generator(7)=make_face_generator( & + cv_tet_face_temp(i)%generator(7)=make_face_generator( & permutation=cv_tet_face_permutations(13), & nodes=(/4,6/), & coords=coords) - cv_tet_face_temp(i)%generator(8)=make_face_generator( & + cv_tet_face_temp(i)%generator(8)=make_face_generator( & permutation=cv_tet_face_permutations(14), & nodes=(/5,6/), & coords=coords) - cv_tet_face_temp(i)%generator(9)=make_face_generator( & + cv_tet_face_temp(i)%generator(9)=make_face_generator( & permutation=cv_tet_face_permutations(15), & nodes=(/6,9/), & coords=coords) - cv_tet_face_temp(i)%generator(10)=make_face_generator( & + cv_tet_face_temp(i)%generator(10)=make_face_generator( & permutation=cv_tet_face_permutations(16), & nodes=(/7,10/), & coords=coords) - cv_tet_face_temp(i)%generator(11)=make_face_generator( & + cv_tet_face_temp(i)%generator(11)=make_face_generator( & permutation=cv_tet_face_permutations(17), & nodes=(/8,10/), & coords=coords) - cv_tet_face_temp(i)%generator(12)=make_face_generator( & + cv_tet_face_temp(i)%generator(12)=make_face_generator( & permutation=cv_tet_face_permutations(18), & nodes=(/9,10/), & coords=coords) - cv_tet_face_temp(i)%generator(13)=make_face_generator( & + cv_tet_face_temp(i)%generator(13)=make_face_generator( & permutation=cv_tet_face_permutations(19), & nodes=(/2,7/), & coords=coords) - cv_tet_face_temp(i)%generator(14)=make_face_generator( & + cv_tet_face_temp(i)%generator(14)=make_face_generator( & permutation=cv_tet_face_permutations(20), & nodes=(/2,8/), & coords=coords) - cv_tet_face_temp(i)%generator(15)=make_face_generator( & + cv_tet_face_temp(i)%generator(15)=make_face_generator( & permutation=cv_tet_face_permutations(21), & nodes=(/7,8/), & coords=coords) - cv_tet_face_temp(i)%generator(16)=make_face_generator( & + cv_tet_face_temp(i)%generator(16)=make_face_generator( & permutation=cv_tet_face_permutations(22), & nodes=(/5,8/), & coords=coords) - cv_tet_face_temp(i)%generator(17)=make_face_generator( & + cv_tet_face_temp(i)%generator(17)=make_face_generator( & permutation=cv_tet_face_permutations(23), & nodes=(/5,9/), & coords=coords) - cv_tet_face_temp(i)%generator(18)=make_face_generator( & + cv_tet_face_temp(i)%generator(18)=make_face_generator( & permutation=cv_tet_face_permutations(24), & nodes=(/8,9/), & coords=coords) - cv_tet_face_temp(i)%generator(19)=make_face_generator( & + cv_tet_face_temp(i)%generator(19)=make_face_generator( & permutation=cv_tet_face_permutations(25), & nodes=(/4,7/), & coords=coords) - cv_tet_face_temp(i)%generator(20)=make_face_generator( & + cv_tet_face_temp(i)%generator(20)=make_face_generator( & permutation=cv_tet_face_permutations(26), & nodes=(/4,9/), & coords=coords) - cv_tet_face_temp(i)%generator(21)=make_face_generator( & + cv_tet_face_temp(i)%generator(21)=make_face_generator( & permutation=cv_tet_face_permutations(27), & nodes=(/7,9/), & coords=coords) - cv_tet_face_temp(i)%generator(22)=make_face_generator( & + cv_tet_face_temp(i)%generator(22)=make_face_generator( & permutation=cv_tet_face_permutations(28), & nodes=(/2,4/), & coords=coords) - cv_tet_face_temp(i)%generator(23)=make_face_generator( & + cv_tet_face_temp(i)%generator(23)=make_face_generator( & permutation=cv_tet_face_permutations(29), & nodes=(/2,5/), & coords=coords) - cv_tet_face_temp(i)%generator(24)=make_face_generator( & + cv_tet_face_temp(i)%generator(24)=make_face_generator( & permutation=cv_tet_face_permutations(30), & nodes=(/4,5/), & coords=coords) - end subroutine construct_cv_tet_face_templates + end subroutine construct_cv_tet_face_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_tri_face_templates - ! Construct list of available templates. - integer :: i - real, dimension(5) :: coords - - coords=0.0 - - cv_tri_face_temp%dimension=2 - cv_tri_face_temp%vertices=3 - cv_tri_face_temp%ncorn=2 - cv_tri_face_temp%coords=3 - - i=0 - - !---------------------------------------------------------------------- - ! Linear triangle - i=i+1 - ! One generator per face. - allocate(cv_tri_face_temp(i)%generator(3)) - - cv_tri_face_temp(i)%faces=3 - cv_tri_face_temp(i)%degree=1 - cv_tri_face_temp(i)%nodes=3 - coords(1)=0.333333333333333333333333333333333 - coords(2)=0.5 - cv_tri_face_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_tri_face_templates + ! Construct list of available templates. + integer :: i + real, dimension(5) :: coords + + coords=0.0 + + cv_tri_face_temp%dimension=2 + cv_tri_face_temp%vertices=3 + cv_tri_face_temp%ncorn=2 + cv_tri_face_temp%coords=3 + + i=0 + + !---------------------------------------------------------------------- + ! Linear triangle + i=i+1 + ! One generator per face. + allocate(cv_tri_face_temp(i)%generator(3)) + + cv_tri_face_temp(i)%faces=3 + cv_tri_face_temp(i)%degree=1 + cv_tri_face_temp(i)%nodes=3 + coords(1)=0.333333333333333333333333333333333 + coords(2)=0.5 + cv_tri_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_tri_face_permutations(1), & nodes=(/1,2/), & coords=coords) - cv_tri_face_temp(i)%generator(2)=make_face_generator( & + cv_tri_face_temp(i)%generator(2)=make_face_generator( & permutation=cv_tri_face_permutations(2), & nodes=(/2,3/), & coords=coords) - cv_tri_face_temp(i)%generator(3)=make_face_generator( & + cv_tri_face_temp(i)%generator(3)=make_face_generator( & permutation=cv_tri_face_permutations(3), & nodes=(/1,3/), & coords=coords) - !---------------------------------------------------------------------- - ! Quadratic triangle - i=i+1 - ! One generator per face. - allocate(cv_tri_face_temp(i)%generator(9)) - - cv_tri_face_temp(i)%faces=9 - cv_tri_face_temp(i)%degree=2 - cv_tri_face_temp(i)%nodes=6 - coords(1)=0.166666666666666666666666666666666 - coords(2)=0.25 - coords(3)=0.333333333333333333333333333333333 - coords(4)=0.666666666666666666666666666666666 - coords(5)=0.75 - cv_tri_face_temp(i)%generator(1)=make_face_generator( & + !---------------------------------------------------------------------- + ! Quadratic triangle + i=i+1 + ! One generator per face. + allocate(cv_tri_face_temp(i)%generator(9)) + + cv_tri_face_temp(i)%faces=9 + cv_tri_face_temp(i)%degree=2 + cv_tri_face_temp(i)%nodes=6 + coords(1)=0.166666666666666666666666666666666 + coords(2)=0.25 + coords(3)=0.333333333333333333333333333333333 + coords(4)=0.666666666666666666666666666666666 + coords(5)=0.75 + cv_tri_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_tri_face_permutations(4), & nodes=(/1,2/), & coords=coords) - cv_tri_face_temp(i)%generator(2)=make_face_generator( & + cv_tri_face_temp(i)%generator(2)=make_face_generator( & permutation=cv_tri_face_permutations(5), & nodes=(/1,4/), & coords=coords) - cv_tri_face_temp(i)%generator(3)=make_face_generator( & + cv_tri_face_temp(i)%generator(3)=make_face_generator( & permutation=cv_tri_face_permutations(6), & nodes=(/2,3/), & coords=coords) - cv_tri_face_temp(i)%generator(4)=make_face_generator( & + cv_tri_face_temp(i)%generator(4)=make_face_generator( & permutation=cv_tri_face_permutations(7), & nodes=(/3,5/), & coords=coords) - cv_tri_face_temp(i)%generator(5)=make_face_generator( & + cv_tri_face_temp(i)%generator(5)=make_face_generator( & permutation=cv_tri_face_permutations(8), & nodes=(/5,6/), & coords=coords) - cv_tri_face_temp(i)%generator(6)=make_face_generator( & + cv_tri_face_temp(i)%generator(6)=make_face_generator( & permutation=cv_tri_face_permutations(9), & nodes=(/4,6/), & coords=coords) - cv_tri_face_temp(i)%generator(7)=make_face_generator( & + cv_tri_face_temp(i)%generator(7)=make_face_generator( & permutation=cv_tri_face_permutations(10), & nodes=(/2,4/), & coords=coords) - cv_tri_face_temp(i)%generator(8)=make_face_generator( & + cv_tri_face_temp(i)%generator(8)=make_face_generator( & permutation=cv_tri_face_permutations(11), & nodes=(/2,5/), & coords=coords) - cv_tri_face_temp(i)%generator(9)=make_face_generator( & + cv_tri_face_temp(i)%generator(9)=make_face_generator( & permutation=cv_tri_face_permutations(12), & nodes=(/4,5/), & coords=coords) - end subroutine construct_cv_tri_face_templates + end subroutine construct_cv_tri_face_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_line_face_templates - ! Construct list of available templates. - integer :: i - real, dimension(5) :: coords - - coords=0.0 - - cv_line_face_temp%dimension=1 - cv_line_face_temp%vertices=2 - cv_line_face_temp%ncorn=1 - cv_line_face_temp%coords=2 - - i=0 - - !---------------------------------------------------------------------- - ! Linear line - i=i+1 - ! One generator per face. - allocate(cv_line_face_temp(i)%generator(1)) - - cv_line_face_temp(i)%faces=1 - cv_line_face_temp(i)%degree=1 - cv_line_face_temp(i)%nodes=2 - coords(1)=0.5 - cv_line_face_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_line_face_templates + ! Construct list of available templates. + integer :: i + real, dimension(5) :: coords + + coords=0.0 + + cv_line_face_temp%dimension=1 + cv_line_face_temp%vertices=2 + cv_line_face_temp%ncorn=1 + cv_line_face_temp%coords=2 + + i=0 + + !---------------------------------------------------------------------- + ! Linear line + i=i+1 + ! One generator per face. + allocate(cv_line_face_temp(i)%generator(1)) + + cv_line_face_temp(i)%faces=1 + cv_line_face_temp(i)%degree=1 + cv_line_face_temp(i)%nodes=2 + coords(1)=0.5 + cv_line_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_line_face_permutations(1), & nodes=(/1,2/), & coords=coords) - end subroutine construct_cv_line_face_templates + end subroutine construct_cv_line_face_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_hex_face_templates - ! Construct list of available templates. - integer :: i - real, dimension(4) :: coords - - coords=0.0 - - cv_hex_face_temp%dimension=3 - cv_hex_face_temp%vertices=8 - cv_hex_face_temp%ncorn=4 - cv_hex_face_temp%coords=3 - - i=0 - - !---------------------------------------------------------------------- - ! Tri-Linear hex - i=i+1 - ! One generator per face. - allocate(cv_hex_face_temp(i)%generator(12)) - - cv_hex_face_temp(i)%faces=12 - cv_hex_face_temp(i)%degree=1 - cv_hex_face_temp(i)%nodes=8 - coords(1)=1.0 - cv_hex_face_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_hex_face_templates + ! Construct list of available templates. + integer :: i + real, dimension(4) :: coords + + coords=0.0 + + cv_hex_face_temp%dimension=3 + cv_hex_face_temp%vertices=8 + cv_hex_face_temp%ncorn=4 + cv_hex_face_temp%coords=3 + + i=0 + + !---------------------------------------------------------------------- + ! Tri-Linear hex + i=i+1 + ! One generator per face. + allocate(cv_hex_face_temp(i)%generator(12)) + + cv_hex_face_temp(i)%faces=12 + cv_hex_face_temp(i)%degree=1 + cv_hex_face_temp(i)%nodes=8 + coords(1)=1.0 + cv_hex_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_hex_face_permutations(1), & nodes=(/1,3/), & coords=coords) - cv_hex_face_temp(i)%generator(2)=make_face_generator( & + cv_hex_face_temp(i)%generator(2)=make_face_generator( & permutation=cv_hex_face_permutations(2), & nodes=(/2,4/), & coords=coords) - cv_hex_face_temp(i)%generator(3)=make_face_generator( & + cv_hex_face_temp(i)%generator(3)=make_face_generator( & permutation=cv_hex_face_permutations(3), & nodes=(/1,2/), & coords=coords) - cv_hex_face_temp(i)%generator(4)=make_face_generator( & + cv_hex_face_temp(i)%generator(4)=make_face_generator( & permutation=cv_hex_face_permutations(4), & nodes=(/3,4/), & coords=coords) - cv_hex_face_temp(i)%generator(5)=make_face_generator( & + cv_hex_face_temp(i)%generator(5)=make_face_generator( & permutation=cv_hex_face_permutations(5), & nodes=(/1,5/), & coords=coords) - cv_hex_face_temp(i)%generator(6)=make_face_generator( & + cv_hex_face_temp(i)%generator(6)=make_face_generator( & permutation=cv_hex_face_permutations(6), & nodes=(/2,6/), & coords=coords) - cv_hex_face_temp(i)%generator(7)=make_face_generator( & + cv_hex_face_temp(i)%generator(7)=make_face_generator( & permutation=cv_hex_face_permutations(7), & nodes=(/3,7/), & coords=coords) - cv_hex_face_temp(i)%generator(8)=make_face_generator( & + cv_hex_face_temp(i)%generator(8)=make_face_generator( & permutation=cv_hex_face_permutations(8), & nodes=(/4,8/), & coords=coords) - cv_hex_face_temp(i)%generator(9)=make_face_generator( & + cv_hex_face_temp(i)%generator(9)=make_face_generator( & permutation=cv_hex_face_permutations(9), & nodes=(/5,7/), & coords=coords) - cv_hex_face_temp(i)%generator(10)=make_face_generator( & + cv_hex_face_temp(i)%generator(10)=make_face_generator( & permutation=cv_hex_face_permutations(10), & nodes=(/6,8/), & coords=coords) - cv_hex_face_temp(i)%generator(11)=make_face_generator( & + cv_hex_face_temp(i)%generator(11)=make_face_generator( & permutation=cv_hex_face_permutations(11), & nodes=(/5,6/), & coords=coords) - cv_hex_face_temp(i)%generator(12)=make_face_generator( & + cv_hex_face_temp(i)%generator(12)=make_face_generator( & permutation=cv_hex_face_permutations(12), & nodes=(/7,8/), & coords=coords) - end subroutine construct_cv_hex_face_templates + end subroutine construct_cv_hex_face_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_quad_face_templates - ! Construct list of available templates. - integer :: i - real, dimension(4) :: coords - - coords=0.0 - - cv_quad_face_temp%dimension=2 - cv_quad_face_temp%vertices=4 - cv_quad_face_temp%ncorn=2 - cv_quad_face_temp%coords=2 - - i=0 - - !---------------------------------------------------------------------- - ! Tri-Linear quad - i=i+1 - ! One generator per face. - allocate(cv_quad_face_temp(i)%generator(4)) - - cv_quad_face_temp(i)%faces=4 - cv_quad_face_temp(i)%degree=1 - cv_quad_face_temp(i)%nodes=4 - coords(1)=1.0 - cv_quad_face_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_quad_face_templates + ! Construct list of available templates. + integer :: i + real, dimension(4) :: coords + + coords=0.0 + + cv_quad_face_temp%dimension=2 + cv_quad_face_temp%vertices=4 + cv_quad_face_temp%ncorn=2 + cv_quad_face_temp%coords=2 + + i=0 + + !---------------------------------------------------------------------- + ! Tri-Linear quad + i=i+1 + ! One generator per face. + allocate(cv_quad_face_temp(i)%generator(4)) + + cv_quad_face_temp(i)%faces=4 + cv_quad_face_temp(i)%degree=1 + cv_quad_face_temp(i)%nodes=4 + coords(1)=1.0 + cv_quad_face_temp(i)%generator(1)=make_face_generator( & permutation=cv_quad_face_permutations(1), & nodes=(/1,2/), & coords=coords) - cv_quad_face_temp(i)%generator(2)=make_face_generator( & + cv_quad_face_temp(i)%generator(2)=make_face_generator( & permutation=cv_quad_face_permutations(2), & nodes=(/3,4/), & coords=coords) - cv_quad_face_temp(i)%generator(3)=make_face_generator( & + cv_quad_face_temp(i)%generator(3)=make_face_generator( & permutation=cv_quad_face_permutations(3), & nodes=(/1,3/), & coords=coords) - cv_quad_face_temp(i)%generator(4)=make_face_generator( & + cv_quad_face_temp(i)%generator(4)=make_face_generator( & permutation=cv_quad_face_permutations(4), & nodes=(/2,4/), & coords=coords) - end subroutine construct_cv_quad_face_templates + end subroutine construct_cv_quad_face_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_tet_bdy_templates - ! Construct list of available templates. - integer :: i - real, dimension(7) :: coords - - coords=0.0 - - cv_tet_bdy_temp%dimension=2 - cv_tet_bdy_temp%vertices=3 - cv_tet_bdy_temp%ncorn=4 - cv_tet_bdy_temp%coords=3 - - i=0 - - !---------------------------------------------------------------------- - ! Linear tet boundary - i=i+1 - ! One generator per face. - allocate(cv_tet_bdy_temp(i)%generator(3)) - - cv_tet_bdy_temp(i)%faces=3 - cv_tet_bdy_temp(i)%degree=1 - cv_tet_bdy_temp(i)%nodes=3 - coords(1)=0.333333333333333333333333333333333 - coords(2)=0.5 - coords(3)=1.0 - cv_tet_bdy_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_tet_bdy_templates + ! Construct list of available templates. + integer :: i + real, dimension(7) :: coords + + coords=0.0 + + cv_tet_bdy_temp%dimension=2 + cv_tet_bdy_temp%vertices=3 + cv_tet_bdy_temp%ncorn=4 + cv_tet_bdy_temp%coords=3 + + i=0 + + !---------------------------------------------------------------------- + ! Linear tet boundary + i=i+1 + ! One generator per face. + allocate(cv_tet_bdy_temp(i)%generator(3)) + + cv_tet_bdy_temp(i)%faces=3 + cv_tet_bdy_temp(i)%degree=1 + cv_tet_bdy_temp(i)%nodes=3 + coords(1)=0.333333333333333333333333333333333 + coords(2)=0.5 + coords(3)=1.0 + cv_tet_bdy_temp(i)%generator(1)=make_face_generator( & permutation=cv_tet_bdy_permutations(1), & nodes=(/1,1/), & coords=coords) - cv_tet_bdy_temp(i)%generator(2)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(2)=make_face_generator( & permutation=cv_tet_bdy_permutations(2), & nodes=(/2,2/), & coords=coords) - cv_tet_bdy_temp(i)%generator(3)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(3)=make_face_generator( & permutation=cv_tet_bdy_permutations(3), & nodes=(/3,3/), & coords=coords) - !---------------------------------------------------------------------- - ! Quadratic tet boundary - i=i+1 - ! One generator per face. - ! (Multiple faces per node to allow non-quadrilateral shapes) - allocate(cv_tet_bdy_temp(i)%generator(9)) - - cv_tet_bdy_temp(i)%faces=9 ! should only be 6 but 3 are fictitious to account for non-quadrilateral shapes - cv_tet_bdy_temp(i)%degree=2 - cv_tet_bdy_temp(i)%nodes=6 - coords(1)=0.166666666666666666666666666666666 - coords(2)=0.25 - coords(3)=0.333333333333333333333333333333333 - coords(4)=0.5 - coords(5)=0.666666666666666666666666666666666 - coords(6)=0.75 - coords(7)=1.0 - cv_tet_bdy_temp(i)%generator(1)=make_face_generator( & + !---------------------------------------------------------------------- + ! Quadratic tet boundary + i=i+1 + ! One generator per face. + ! (Multiple faces per node to allow non-quadrilateral shapes) + allocate(cv_tet_bdy_temp(i)%generator(9)) + + cv_tet_bdy_temp(i)%faces=9 ! should only be 6 but 3 are fictitious to account for non-quadrilateral shapes + cv_tet_bdy_temp(i)%degree=2 + cv_tet_bdy_temp(i)%nodes=6 + coords(1)=0.166666666666666666666666666666666 + coords(2)=0.25 + coords(3)=0.333333333333333333333333333333333 + coords(4)=0.5 + coords(5)=0.666666666666666666666666666666666 + coords(6)=0.75 + coords(7)=1.0 + cv_tet_bdy_temp(i)%generator(1)=make_face_generator( & permutation=cv_tet_bdy_permutations(4), & nodes=(/1,1/), & coords=coords) - cv_tet_bdy_temp(i)%generator(2)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(2)=make_face_generator( & permutation=cv_tet_bdy_permutations(5), & nodes=(/2,2/), & coords=coords) - cv_tet_bdy_temp(i)%generator(3)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(3)=make_face_generator( & permutation=cv_tet_bdy_permutations(6), & nodes=(/2,2/), & coords=coords) - cv_tet_bdy_temp(i)%generator(4)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(4)=make_face_generator( & permutation=cv_tet_bdy_permutations(7), & nodes=(/3,3/), & coords=coords) - cv_tet_bdy_temp(i)%generator(5)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(5)=make_face_generator( & permutation=cv_tet_bdy_permutations(8), & nodes=(/4,4/), & coords=coords) - cv_tet_bdy_temp(i)%generator(6)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(6)=make_face_generator( & permutation=cv_tet_bdy_permutations(9), & nodes=(/4,4/), & coords=coords) - cv_tet_bdy_temp(i)%generator(7)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(7)=make_face_generator( & permutation=cv_tet_bdy_permutations(10), & nodes=(/5,5/), & coords=coords) - cv_tet_bdy_temp(i)%generator(8)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(8)=make_face_generator( & permutation=cv_tet_bdy_permutations(11), & nodes=(/5,5/), & coords=coords) - cv_tet_bdy_temp(i)%generator(9)=make_face_generator( & + cv_tet_bdy_temp(i)%generator(9)=make_face_generator( & permutation=cv_tet_bdy_permutations(12), & nodes=(/6,6/), & coords=coords) - end subroutine construct_cv_tet_bdy_templates + end subroutine construct_cv_tet_bdy_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_line_bdy_templates - ! Construct list of available templates. - integer :: i - real, dimension(4) :: coords - - coords=0.0 - - cv_line_bdy_temp%dimension=1 - cv_line_bdy_temp%vertices=2 - cv_line_bdy_temp%ncorn=2 - cv_line_bdy_temp%coords=2 - - i=0 - - !---------------------------------------------------------------------- - ! Linear line boundary - i=i+1 - ! One generator per face. - allocate(cv_line_bdy_temp(i)%generator(2)) - - cv_line_bdy_temp(i)%faces=2 - cv_line_bdy_temp(i)%degree=1 - cv_line_bdy_temp(i)%nodes=2 - coords(1)=0.5 - coords(2)=1.0 - cv_line_bdy_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_line_bdy_templates + ! Construct list of available templates. + integer :: i + real, dimension(4) :: coords + + coords=0.0 + + cv_line_bdy_temp%dimension=1 + cv_line_bdy_temp%vertices=2 + cv_line_bdy_temp%ncorn=2 + cv_line_bdy_temp%coords=2 + + i=0 + + !---------------------------------------------------------------------- + ! Linear line boundary + i=i+1 + ! One generator per face. + allocate(cv_line_bdy_temp(i)%generator(2)) + + cv_line_bdy_temp(i)%faces=2 + cv_line_bdy_temp(i)%degree=1 + cv_line_bdy_temp(i)%nodes=2 + coords(1)=0.5 + coords(2)=1.0 + cv_line_bdy_temp(i)%generator(1)=make_face_generator( & permutation=cv_line_bdy_permutations(1), & nodes=(/1,1/), & coords=coords) - cv_line_bdy_temp(i)%generator(2)=make_face_generator( & + cv_line_bdy_temp(i)%generator(2)=make_face_generator( & permutation=cv_line_bdy_permutations(2), & nodes=(/2,2/), & coords=coords) - !---------------------------------------------------------------------- - ! Quadratic line boundary - i=i+1 - ! One generator per face. - allocate(cv_line_bdy_temp(i)%generator(3)) + !---------------------------------------------------------------------- + ! Quadratic line boundary + i=i+1 + ! One generator per face. + allocate(cv_line_bdy_temp(i)%generator(3)) - cv_line_bdy_temp(i)%faces=3 - cv_line_bdy_temp(i)%degree=2 - cv_line_bdy_temp(i)%nodes=3 - coords(1)=0.25 - coords(2)=0.75 - coords(3)=1.0 - cv_line_bdy_temp(i)%generator(1)=make_face_generator( & + cv_line_bdy_temp(i)%faces=3 + cv_line_bdy_temp(i)%degree=2 + cv_line_bdy_temp(i)%nodes=3 + coords(1)=0.25 + coords(2)=0.75 + coords(3)=1.0 + cv_line_bdy_temp(i)%generator(1)=make_face_generator( & permutation=cv_line_bdy_permutations(3), & nodes=(/1,1/), & coords=coords) - cv_line_bdy_temp(i)%generator(2)=make_face_generator( & + cv_line_bdy_temp(i)%generator(2)=make_face_generator( & permutation=cv_line_bdy_permutations(4), & nodes=(/2,2/), & coords=coords) - cv_line_bdy_temp(i)%generator(3)=make_face_generator( & + cv_line_bdy_temp(i)%generator(3)=make_face_generator( & permutation=cv_line_bdy_permutations(5), & nodes=(/3,3/), & coords=coords) - end subroutine construct_cv_line_bdy_templates + end subroutine construct_cv_line_bdy_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_point_bdy_templates - ! Construct list of available templates. - integer :: i - real, dimension(4) :: coords - - coords=0.0 - - cv_point_bdy_temp%dimension=0 - cv_point_bdy_temp%vertices=1 - cv_point_bdy_temp%ncorn=1 - cv_point_bdy_temp%coords=1 - - i=0 - - !---------------------------------------------------------------------- - ! Linear line boundary - i=i+1 - ! One generator per face. - allocate(cv_point_bdy_temp(i)%generator(1)) - - cv_point_bdy_temp(i)%faces=1 - cv_point_bdy_temp(i)%degree=1 - cv_point_bdy_temp(i)%nodes=1 - coords(1)=1.0 - cv_point_bdy_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_point_bdy_templates + ! Construct list of available templates. + integer :: i + real, dimension(4) :: coords + + coords=0.0 + + cv_point_bdy_temp%dimension=0 + cv_point_bdy_temp%vertices=1 + cv_point_bdy_temp%ncorn=1 + cv_point_bdy_temp%coords=1 + + i=0 + + !---------------------------------------------------------------------- + ! Linear line boundary + i=i+1 + ! One generator per face. + allocate(cv_point_bdy_temp(i)%generator(1)) + + cv_point_bdy_temp(i)%faces=1 + cv_point_bdy_temp(i)%degree=1 + cv_point_bdy_temp(i)%nodes=1 + coords(1)=1.0 + cv_point_bdy_temp(i)%generator(1)=make_face_generator( & permutation=cv_point_bdy_permutations(1), & nodes=(/1,1/), & coords=coords) - end subroutine construct_cv_point_bdy_templates + end subroutine construct_cv_point_bdy_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_hex_bdy_templates - ! Construct list of available templates. - integer :: i - real, dimension(4) :: coords - - coords=0.0 - - cv_hex_bdy_temp%dimension=2 - cv_hex_bdy_temp%vertices=4 - cv_hex_bdy_temp%ncorn=4 - cv_hex_bdy_temp%coords=2 - - i=0 - - !---------------------------------------------------------------------- - ! Tri-Linear hex boundary - i=i+1 - ! One generator per face. - allocate(cv_hex_bdy_temp(i)%generator(4)) - - cv_hex_bdy_temp(i)%faces=4 - cv_hex_bdy_temp(i)%degree=1 - cv_hex_bdy_temp(i)%nodes=4 - coords(1)=1.0 - cv_hex_bdy_temp(i)%generator(1)=make_face_generator( & + subroutine construct_cv_hex_bdy_templates + ! Construct list of available templates. + integer :: i + real, dimension(4) :: coords + + coords=0.0 + + cv_hex_bdy_temp%dimension=2 + cv_hex_bdy_temp%vertices=4 + cv_hex_bdy_temp%ncorn=4 + cv_hex_bdy_temp%coords=2 + + i=0 + + !---------------------------------------------------------------------- + ! Tri-Linear hex boundary + i=i+1 + ! One generator per face. + allocate(cv_hex_bdy_temp(i)%generator(4)) + + cv_hex_bdy_temp(i)%faces=4 + cv_hex_bdy_temp(i)%degree=1 + cv_hex_bdy_temp(i)%nodes=4 + coords(1)=1.0 + cv_hex_bdy_temp(i)%generator(1)=make_face_generator( & permutation=cv_hex_bdy_permutations(1), & nodes=(/1,1/), & coords=coords) - cv_hex_bdy_temp(i)%generator(2)=make_face_generator( & + cv_hex_bdy_temp(i)%generator(2)=make_face_generator( & permutation=cv_hex_bdy_permutations(2), & nodes=(/2,2/), & coords=coords) - cv_hex_bdy_temp(i)%generator(3)=make_face_generator( & + cv_hex_bdy_temp(i)%generator(3)=make_face_generator( & permutation=cv_hex_bdy_permutations(3), & nodes=(/3,3/), & coords=coords) - cv_hex_bdy_temp(i)%generator(4)=make_face_generator( & + cv_hex_bdy_temp(i)%generator(4)=make_face_generator( & permutation=cv_hex_bdy_permutations(4), & nodes=(/4,4/), & coords=coords) - end subroutine construct_cv_hex_bdy_templates + end subroutine construct_cv_hex_bdy_templates !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_tet_face_permutations + subroutine construct_cv_tet_face_permutations - ! linear faces + ! linear faces - allocate(cv_tet_face_permutations(1)%p(4,4)) + allocate(cv_tet_face_permutations(1)%p(4,4)) - cv_tet_face_permutations(1)%p=reshape((/& + cv_tet_face_permutations(1)%p=reshape((/& 3, 3, 0, 0, & 2, 2, 2, 0, & 2, 2, 0, 2, & 1, 1, 1, 1/),(/4,4/)) - allocate(cv_tet_face_permutations(2)%p(4,4)) + allocate(cv_tet_face_permutations(2)%p(4,4)) - cv_tet_face_permutations(2)%p=reshape((/& + cv_tet_face_permutations(2)%p=reshape((/& 2, 2, 2, 0, & 0, 3, 3, 0, & 1, 1, 1, 1, & 0, 2, 2, 2/),(/4,4/)) - allocate(cv_tet_face_permutations(3)%p(4,4)) + allocate(cv_tet_face_permutations(3)%p(4,4)) - cv_tet_face_permutations(3)%p=reshape((/& + cv_tet_face_permutations(3)%p=reshape((/& 2, 2, 2, 0, & 3, 0, 3, 0, & 1, 1, 1, 1, & 2, 0, 2, 2/),(/4,4/)) - allocate(cv_tet_face_permutations(4)%p(4,4)) + allocate(cv_tet_face_permutations(4)%p(4,4)) - cv_tet_face_permutations(4)%p=reshape((/& + cv_tet_face_permutations(4)%p=reshape((/& 3, 0, 0, 3, & 2, 2, 0, 2, & 2, 0, 2, 2, & 1, 1, 1, 1/),(/4,4/)) - allocate(cv_tet_face_permutations(5)%p(4,4)) + allocate(cv_tet_face_permutations(5)%p(4,4)) - cv_tet_face_permutations(5)%p=reshape((/& + cv_tet_face_permutations(5)%p=reshape((/& 2, 2, 0, 2, & 0, 3, 0, 3, & 1, 1, 1, 1, & 0, 2, 2, 2/),(/4,4/)) - allocate(cv_tet_face_permutations(6)%p(4,4)) + allocate(cv_tet_face_permutations(6)%p(4,4)) - cv_tet_face_permutations(6)%p=reshape((/& + cv_tet_face_permutations(6)%p=reshape((/& 1, 1, 1, 1, & 0, 2, 2, 2, & 2, 0, 2, 2, & 0, 0, 3, 3/),(/4,4/)) - ! end of linear faces + ! end of linear faces - ! quadratic faces + ! quadratic faces - allocate(cv_tet_face_permutations(7)%p(4,4)) + allocate(cv_tet_face_permutations(7)%p(4,4)) - cv_tet_face_permutations(7)%p=reshape((/& + cv_tet_face_permutations(7)%p=reshape((/& 7, 3, 0, 0, & 6, 2, 2, 0, & 6, 2, 0, 2, & 5, 1, 1, 1/),(/4,4/)) ! 1,2 - allocate(cv_tet_face_permutations(8)%p(4,4)) + allocate(cv_tet_face_permutations(8)%p(4,4)) - cv_tet_face_permutations(8)%p=reshape((/& + cv_tet_face_permutations(8)%p=reshape((/& 6, 2, 2, 0, & 7, 0, 3, 0, & 5, 1, 1, 1, & 6, 0, 2, 2/),(/4,4/)) ! 1,4 - allocate(cv_tet_face_permutations(9)%p(4,4)) + allocate(cv_tet_face_permutations(9)%p(4,4)) - cv_tet_face_permutations(9)%p=reshape((/& + cv_tet_face_permutations(9)%p=reshape((/& 7, 0, 0, 3, & 6, 2, 0, 2, & 6, 0, 2, 2, & 5, 1, 1, 1/),(/4,4/)) ! 1,7 - allocate(cv_tet_face_permutations(10)%p(4,4)) + allocate(cv_tet_face_permutations(10)%p(4,4)) - cv_tet_face_permutations(10)%p=reshape((/& + cv_tet_face_permutations(10)%p=reshape((/& 3, 7, 0, 0, & 2, 6, 2, 0, & 2, 6, 0, 2, & 1, 5, 1, 1/),(/4,4/)) ! 2,3 - allocate(cv_tet_face_permutations(11)%p(4,4)) + allocate(cv_tet_face_permutations(11)%p(4,4)) - cv_tet_face_permutations(11)%p=reshape((/& + cv_tet_face_permutations(11)%p=reshape((/& 2, 6, 2, 0, & 0, 7, 3, 0, & 1, 5, 1, 1, & 0, 6, 2, 2/),(/4,4/)) ! 3,5 - allocate(cv_tet_face_permutations(12)%p(4,4)) + allocate(cv_tet_face_permutations(12)%p(4,4)) - cv_tet_face_permutations(12)%p=reshape((/& + cv_tet_face_permutations(12)%p=reshape((/& 0, 7, 0, 3, & 2, 6, 0, 2, & 0, 6, 2, 2, & 1, 5, 1, 1/),(/4,4/)) ! 3,8 - allocate(cv_tet_face_permutations(13)%p(4,4)) + allocate(cv_tet_face_permutations(13)%p(4,4)) - cv_tet_face_permutations(13)%p=reshape((/& + cv_tet_face_permutations(13)%p=reshape((/& 3, 0, 7, 0, & 2, 2, 6, 0, & 2, 0, 6, 2, & 1, 1, 5, 1/),(/4,4/)) ! 4,6 - allocate(cv_tet_face_permutations(14)%p(4,4)) + allocate(cv_tet_face_permutations(14)%p(4,4)) - cv_tet_face_permutations(14)%p=reshape((/& + cv_tet_face_permutations(14)%p=reshape((/& 2, 2, 6, 0, & 0, 3, 7, 0, & 1, 1, 5, 1, & 0, 2, 6, 2/),(/4,4/)) ! 5,6 - allocate(cv_tet_face_permutations(15)%p(4,4)) + allocate(cv_tet_face_permutations(15)%p(4,4)) - cv_tet_face_permutations(15)%p=reshape((/& + cv_tet_face_permutations(15)%p=reshape((/& 0, 0, 7, 3, & 2, 0, 6, 2, & 0, 2, 6, 2, & 1, 1, 5, 1/),(/4,4/)) ! 6,9 - allocate(cv_tet_face_permutations(16)%p(4,4)) + allocate(cv_tet_face_permutations(16)%p(4,4)) - cv_tet_face_permutations(16)%p=reshape((/& + cv_tet_face_permutations(16)%p=reshape((/& 3, 0, 0, 7, & 2, 2, 0, 6, & 2, 0, 2, 6, & 1, 1, 1, 5/),(/4,4/)) ! 7,10 - allocate(cv_tet_face_permutations(17)%p(4,4)) + allocate(cv_tet_face_permutations(17)%p(4,4)) - cv_tet_face_permutations(17)%p=reshape((/& + cv_tet_face_permutations(17)%p=reshape((/& 2, 2, 0, 6, & 0, 3, 0, 7, & 1, 1, 1, 5, & 0, 2, 2, 6/),(/4,4/)) ! 8,10 - allocate(cv_tet_face_permutations(18)%p(4,4)) + allocate(cv_tet_face_permutations(18)%p(4,4)) - cv_tet_face_permutations(18)%p=reshape((/& + cv_tet_face_permutations(18)%p=reshape((/& 0, 0, 3, 7, & 2, 0, 2, 6, & 0, 2, 2, 6, & 1, 1, 1, 5/),(/4,4/)) ! 9,10 - allocate(cv_tet_face_permutations(19)%p(4,4)) + allocate(cv_tet_face_permutations(19)%p(4,4)) - cv_tet_face_permutations(19)%p=reshape((/& + cv_tet_face_permutations(19)%p=reshape((/& 6, 2, 0, 2, & 4, 4, 0, 4, & 5, 1, 1, 1, & 3, 3, 3, 3/),(/4,4/)) ! 2,7 - allocate(cv_tet_face_permutations(20)%p(4,4)) + allocate(cv_tet_face_permutations(20)%p(4,4)) - cv_tet_face_permutations(20)%p=reshape((/& + cv_tet_face_permutations(20)%p=reshape((/& 4, 4, 0, 4, & 2, 6, 0, 2, & 3, 3, 3, 3, & 1, 5, 1, 1/),(/4,4/)) ! 2,8 - allocate(cv_tet_face_permutations(21)%p(4,4)) + allocate(cv_tet_face_permutations(21)%p(4,4)) - cv_tet_face_permutations(21)%p=reshape((/& + cv_tet_face_permutations(21)%p=reshape((/& 2, 2, 0, 6, & 4, 4, 0, 4, & 1, 1, 1, 5, & 3, 3, 3, 3/),(/4,4/)) ! 7,8 - allocate(cv_tet_face_permutations(22)%p(4,4)) + allocate(cv_tet_face_permutations(22)%p(4,4)) - cv_tet_face_permutations(22)%p=reshape((/& + cv_tet_face_permutations(22)%p=reshape((/& 0, 6, 2, 2, & 0, 4, 4, 4, & 1, 5, 1, 1, & 3, 3, 3, 3/),(/4,4/)) ! 5,8 - allocate(cv_tet_face_permutations(23)%p(4,4)) + allocate(cv_tet_face_permutations(23)%p(4,4)) - cv_tet_face_permutations(23)%p=reshape((/& + cv_tet_face_permutations(23)%p=reshape((/& 0, 4, 4, 4, & 0, 2, 6, 2, & 3, 3, 3, 3, & 1, 1, 5, 1/),(/4,4/)) ! 5,9 - allocate(cv_tet_face_permutations(24)%p(4,4)) + allocate(cv_tet_face_permutations(24)%p(4,4)) - cv_tet_face_permutations(24)%p=reshape((/& + cv_tet_face_permutations(24)%p=reshape((/& 0, 2, 2, 6, & 0, 4, 4, 4, & 1, 1, 1, 5, & 3, 3, 3, 3/),(/4,4/)) ! 8,9 - allocate(cv_tet_face_permutations(25)%p(4,4)) + allocate(cv_tet_face_permutations(25)%p(4,4)) - cv_tet_face_permutations(25)%p=reshape((/& + cv_tet_face_permutations(25)%p=reshape((/& 6, 0, 2, 2, & 4, 0, 4, 4, & 5, 1, 1, 1, & 3, 3, 3, 3/),(/4,4/)) ! 4,7 - allocate(cv_tet_face_permutations(26)%p(4,4)) + allocate(cv_tet_face_permutations(26)%p(4,4)) - cv_tet_face_permutations(26)%p=reshape((/& + cv_tet_face_permutations(26)%p=reshape((/& 4, 0, 4, 4, & 2, 0, 6, 2, & 3, 3, 3, 3, & 1, 1, 5, 1/),(/4,4/)) ! 4,9 - allocate(cv_tet_face_permutations(27)%p(4,4)) + allocate(cv_tet_face_permutations(27)%p(4,4)) - cv_tet_face_permutations(27)%p=reshape((/& + cv_tet_face_permutations(27)%p=reshape((/& 2, 0, 2, 6, & 4, 0, 4, 4, & 1, 1, 1, 5, & 3, 3, 3, 3/),(/4,4/)) ! 7,9 - allocate(cv_tet_face_permutations(28)%p(4,4)) + allocate(cv_tet_face_permutations(28)%p(4,4)) - cv_tet_face_permutations(28)%p=reshape((/& + cv_tet_face_permutations(28)%p=reshape((/& 6, 2, 2, 0, & 4, 4, 4, 0, & 5, 1, 1, 1, & 3, 3, 3, 3/),(/4,4/)) ! 2,4 - allocate(cv_tet_face_permutations(29)%p(4,4)) + allocate(cv_tet_face_permutations(29)%p(4,4)) - cv_tet_face_permutations(29)%p=reshape((/& + cv_tet_face_permutations(29)%p=reshape((/& 4, 4, 4, 0, & 2, 6, 2, 0, & 3, 3, 3, 3, & 1, 5, 1, 1/),(/4,4/)) ! 2,5 - allocate(cv_tet_face_permutations(30)%p(4,4)) + allocate(cv_tet_face_permutations(30)%p(4,4)) - cv_tet_face_permutations(30)%p=reshape((/& + cv_tet_face_permutations(30)%p=reshape((/& 2, 2, 6, 0, & 4, 4, 4, 0, & 1, 1, 5, 1, & 3, 3, 3, 3/),(/4,4/)) ! 4,5 - ! end of quadratic faces + ! end of quadratic faces - end subroutine construct_cv_tet_face_permutations + end subroutine construct_cv_tet_face_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_tri_face_permutations + subroutine construct_cv_tri_face_permutations - ! linear faces + ! linear faces - allocate(cv_tri_face_permutations(1)%p(3,2)) + allocate(cv_tri_face_permutations(1)%p(3,2)) - cv_tri_face_permutations(1)%p=reshape((/& + cv_tri_face_permutations(1)%p=reshape((/& 1, 1, 1, & 2, 2, 0/),(/3,2/)) - allocate(cv_tri_face_permutations(2)%p(3,2)) + allocate(cv_tri_face_permutations(2)%p(3,2)) - cv_tri_face_permutations(2)%p=reshape((/& + cv_tri_face_permutations(2)%p=reshape((/& 1, 1, 1, & 0, 2, 2/),(/3,2/)) - allocate(cv_tri_face_permutations(3)%p(3,2)) + allocate(cv_tri_face_permutations(3)%p(3,2)) - cv_tri_face_permutations(3)%p=reshape((/& + cv_tri_face_permutations(3)%p=reshape((/& 1, 1, 1, & 2, 0, 2/),(/3,2/)) - ! end of linear faces + ! end of linear faces - ! quadratic faces + ! quadratic faces - allocate(cv_tri_face_permutations(4)%p(3,2)) + allocate(cv_tri_face_permutations(4)%p(3,2)) - cv_tri_face_permutations(4)%p=reshape((/& + cv_tri_face_permutations(4)%p=reshape((/& 5, 2, 0, & 4, 1, 1/),(/3,2/)) - allocate(cv_tri_face_permutations(5)%p(3,2)) + allocate(cv_tri_face_permutations(5)%p(3,2)) - cv_tri_face_permutations(5)%p=reshape((/& + cv_tri_face_permutations(5)%p=reshape((/& 4, 1, 1, & 5, 0, 2/),(/3,2/)) - allocate(cv_tri_face_permutations(6)%p(3,2)) + allocate(cv_tri_face_permutations(6)%p(3,2)) - cv_tri_face_permutations(6)%p=reshape((/& + cv_tri_face_permutations(6)%p=reshape((/& 2, 5, 0, & 1, 4, 1/),(/3,2/)) - allocate(cv_tri_face_permutations(7)%p(3,2)) + allocate(cv_tri_face_permutations(7)%p(3,2)) - cv_tri_face_permutations(7)%p=reshape((/& + cv_tri_face_permutations(7)%p=reshape((/& 1, 4, 1, & 0, 5, 2/),(/3,2/)) - allocate(cv_tri_face_permutations(8)%p(3,2)) + allocate(cv_tri_face_permutations(8)%p(3,2)) - cv_tri_face_permutations(8)%p=reshape((/& + cv_tri_face_permutations(8)%p=reshape((/& 0, 2, 5, & 1, 1, 4/),(/3,2/)) - allocate(cv_tri_face_permutations(9)%p(3,2)) + allocate(cv_tri_face_permutations(9)%p(3,2)) - cv_tri_face_permutations(9)%p=reshape((/& + cv_tri_face_permutations(9)%p=reshape((/& 2, 0, 5, & 1, 1, 4/),(/3,2/)) - allocate(cv_tri_face_permutations(10)%p(3,2)) + allocate(cv_tri_face_permutations(10)%p(3,2)) - cv_tri_face_permutations(10)%p=reshape((/& + cv_tri_face_permutations(10)%p=reshape((/& 4, 1, 1, & 3, 3, 3/),(/3,2/)) - allocate(cv_tri_face_permutations(11)%p(3,2)) + allocate(cv_tri_face_permutations(11)%p(3,2)) - cv_tri_face_permutations(11)%p=reshape((/& + cv_tri_face_permutations(11)%p=reshape((/& 3, 3, 3, & 1, 4, 1/),(/3,2/)) - allocate(cv_tri_face_permutations(12)%p(3,2)) + allocate(cv_tri_face_permutations(12)%p(3,2)) - cv_tri_face_permutations(12)%p=reshape((/& + cv_tri_face_permutations(12)%p=reshape((/& 3, 3, 3, & 1, 1, 4/),(/3,2/)) - ! end of quadratic faces + ! end of quadratic faces - end subroutine construct_cv_tri_face_permutations + end subroutine construct_cv_tri_face_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_line_face_permutations + subroutine construct_cv_line_face_permutations - allocate(cv_line_face_permutations(1)%p(2,1)) + allocate(cv_line_face_permutations(1)%p(2,1)) - cv_line_face_permutations(1)%p=reshape((/& + cv_line_face_permutations(1)%p=reshape((/& 1, 1/),(/2,1/)) - end subroutine construct_cv_line_face_permutations + end subroutine construct_cv_line_face_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_hex_face_permutations + subroutine construct_cv_hex_face_permutations - allocate(cv_hex_face_permutations(1)%p(3,4)) + allocate(cv_hex_face_permutations(1)%p(3,4)) - cv_hex_face_permutations(1)%p=reshape((/& + cv_hex_face_permutations(1)%p=reshape((/& -1, 0, -1, & 0, 0, -1, & -1, 0, 0, & 0, 0, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(2)%p(3,4)) + allocate(cv_hex_face_permutations(2)%p(3,4)) - cv_hex_face_permutations(2)%p=reshape((/& + cv_hex_face_permutations(2)%p=reshape((/& 0, 0, -1, & 1, 0, -1, & 0, 0, 0, & 1, 0, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(3)%p(3,4)) + allocate(cv_hex_face_permutations(3)%p(3,4)) - cv_hex_face_permutations(3)%p=reshape((/& + cv_hex_face_permutations(3)%p=reshape((/& 0, -1, -1, & 0, 0, -1, & 0, -1, 0, & 0, 0, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(4)%p(3,4)) + allocate(cv_hex_face_permutations(4)%p(3,4)) - cv_hex_face_permutations(4)%p=reshape((/& + cv_hex_face_permutations(4)%p=reshape((/& 0, 0, -1, & 0, 1, -1, & 0, 0, 0, & 0, 1, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(5)%p(3,4)) + allocate(cv_hex_face_permutations(5)%p(3,4)) - cv_hex_face_permutations(5)%p=reshape((/& + cv_hex_face_permutations(5)%p=reshape((/& -1, -1, 0, & 0, -1, 0, & -1, 0, 0, & 0, 0, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(6)%p(3,4)) + allocate(cv_hex_face_permutations(6)%p(3,4)) - cv_hex_face_permutations(6)%p=reshape((/& + cv_hex_face_permutations(6)%p=reshape((/& 0, -1, 0, & 1, -1, 0, & 0, 0, 0, & 1, 0, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(7)%p(3,4)) + allocate(cv_hex_face_permutations(7)%p(3,4)) - cv_hex_face_permutations(7)%p=reshape((/& + cv_hex_face_permutations(7)%p=reshape((/& -1, 0, 0, & 0, 0, 0, & -1, 1, 0, & 0, 1, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(8)%p(3,4)) + allocate(cv_hex_face_permutations(8)%p(3,4)) - cv_hex_face_permutations(8)%p=reshape((/& + cv_hex_face_permutations(8)%p=reshape((/& 0, 0, 0, & 1, 0, 0, & 0, 1, 0, & 1, 1, 0/),(/3,4/)) - allocate(cv_hex_face_permutations(9)%p(3,4)) + allocate(cv_hex_face_permutations(9)%p(3,4)) - cv_hex_face_permutations(9)%p=reshape((/& + cv_hex_face_permutations(9)%p=reshape((/& -1, 0, 0, & 0, 0, 0, & -1, 0, 1, & 0, 0, 1/),(/3,4/)) - allocate(cv_hex_face_permutations(10)%p(3,4)) + allocate(cv_hex_face_permutations(10)%p(3,4)) - cv_hex_face_permutations(10)%p=reshape((/& + cv_hex_face_permutations(10)%p=reshape((/& 0, 0, 0, & 1, 0, 0, & 0, 0, 1, & 1, 0, 1/),(/3,4/)) - allocate(cv_hex_face_permutations(11)%p(3,4)) + allocate(cv_hex_face_permutations(11)%p(3,4)) - cv_hex_face_permutations(11)%p=reshape((/& + cv_hex_face_permutations(11)%p=reshape((/& 0, -1, 0, & 0, 0, 0, & 0, -1, 1, & 0, 0, 1/),(/3,4/)) - allocate(cv_hex_face_permutations(12)%p(3,4)) + allocate(cv_hex_face_permutations(12)%p(3,4)) - cv_hex_face_permutations(12)%p=reshape((/& + cv_hex_face_permutations(12)%p=reshape((/& 0, 0, 0, & 0, 1, 0, & 0, 0, 1, & 0, 1, 1/),(/3,4/)) - end subroutine construct_cv_hex_face_permutations + end subroutine construct_cv_hex_face_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_quad_face_permutations + subroutine construct_cv_quad_face_permutations - allocate(cv_quad_face_permutations(1)%p(2,2)) + allocate(cv_quad_face_permutations(1)%p(2,2)) - cv_quad_face_permutations(1)%p=reshape((/& + cv_quad_face_permutations(1)%p=reshape((/& -1, 0, & 0, 0/),(/2,2/)) - allocate(cv_quad_face_permutations(2)%p(2,2)) + allocate(cv_quad_face_permutations(2)%p(2,2)) - cv_quad_face_permutations(2)%p=reshape((/& + cv_quad_face_permutations(2)%p=reshape((/& 0, 0, & 1, 0/),(/2,2/)) - allocate(cv_quad_face_permutations(3)%p(2,2)) + allocate(cv_quad_face_permutations(3)%p(2,2)) - cv_quad_face_permutations(3)%p=reshape((/& + cv_quad_face_permutations(3)%p=reshape((/& 0, -1, & 0, 0/),(/2,2/)) - allocate(cv_quad_face_permutations(4)%p(2,2)) + allocate(cv_quad_face_permutations(4)%p(2,2)) - cv_quad_face_permutations(4)%p=reshape((/& + cv_quad_face_permutations(4)%p=reshape((/& 0, 0, & 0, 1/),(/2,2/)) - end subroutine construct_cv_quad_face_permutations + end subroutine construct_cv_quad_face_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_tet_bdy_permutations + subroutine construct_cv_tet_bdy_permutations - ! linear + ! linear - allocate(cv_tet_bdy_permutations(1)%p(3,4)) + allocate(cv_tet_bdy_permutations(1)%p(3,4)) - cv_tet_bdy_permutations(1)%p=reshape((/& + cv_tet_bdy_permutations(1)%p=reshape((/& 3, 0, 0, & 2, 2, 0, & 2, 0, 2, & 1, 1, 1/),(/3,4/)) - allocate(cv_tet_bdy_permutations(2)%p(3,4)) + allocate(cv_tet_bdy_permutations(2)%p(3,4)) - cv_tet_bdy_permutations(2)%p=reshape((/& + cv_tet_bdy_permutations(2)%p=reshape((/& 2, 2, 0, & 0, 3, 0, & 1, 1, 1, & 0, 2, 2/),(/3,4/)) - allocate(cv_tet_bdy_permutations(3)%p(3,4)) + allocate(cv_tet_bdy_permutations(3)%p(3,4)) - cv_tet_bdy_permutations(3)%p=reshape((/& + cv_tet_bdy_permutations(3)%p=reshape((/& 2, 0, 2, & 1, 1, 1, & 0, 0, 3, & 0, 2, 2/),(/3,4/)) - ! end of linear + ! end of linear - ! quadratic + ! quadratic - allocate(cv_tet_bdy_permutations(4)%p(3,4)) + allocate(cv_tet_bdy_permutations(4)%p(3,4)) - cv_tet_bdy_permutations(4)%p=reshape((/& + cv_tet_bdy_permutations(4)%p=reshape((/& 7, 0, 0, & 6, 2, 0, & 6, 0, 2, & 5, 1, 1/),(/3,4/)) !1 - allocate(cv_tet_bdy_permutations(5)%p(3,4)) + allocate(cv_tet_bdy_permutations(5)%p(3,4)) - cv_tet_bdy_permutations(5)%p=reshape((/& + cv_tet_bdy_permutations(5)%p=reshape((/& 5, 1, 1, & 6, 2, 0, & 3, 3, 3, & 4, 4, 0/),(/3,4/)) !2 - allocate(cv_tet_bdy_permutations(6)%p(3,4)) + allocate(cv_tet_bdy_permutations(6)%p(3,4)) - cv_tet_bdy_permutations(6)%p=reshape((/& + cv_tet_bdy_permutations(6)%p=reshape((/& 3, 3, 3, & 4, 4, 0, & 1, 5, 1, & 2, 6, 0/),(/3,4/)) !2 - allocate(cv_tet_bdy_permutations(7)%p(3,4)) + allocate(cv_tet_bdy_permutations(7)%p(3,4)) - cv_tet_bdy_permutations(7)%p=reshape((/& + cv_tet_bdy_permutations(7)%p=reshape((/& 0, 7, 0, & 2, 6, 0, & 0, 6, 2, & 1, 5, 1/),(/3,4/)) !3 - allocate(cv_tet_bdy_permutations(8)%p(3,4)) + allocate(cv_tet_bdy_permutations(8)%p(3,4)) - cv_tet_bdy_permutations(8)%p=reshape((/& + cv_tet_bdy_permutations(8)%p=reshape((/& 5, 1, 1, & 6, 0, 2, & 3, 3, 3, & 4, 0, 4/),(/3,4/)) !4 - allocate(cv_tet_bdy_permutations(9)%p(3,4)) + allocate(cv_tet_bdy_permutations(9)%p(3,4)) - cv_tet_bdy_permutations(9)%p=reshape((/& + cv_tet_bdy_permutations(9)%p=reshape((/& 3, 3, 3, & 4, 0, 4, & 1, 1, 5, & 2, 0, 6/),(/3,4/)) !4 - allocate(cv_tet_bdy_permutations(10)%p(3,4)) + allocate(cv_tet_bdy_permutations(10)%p(3,4)) - cv_tet_bdy_permutations(10)%p=reshape((/& + cv_tet_bdy_permutations(10)%p=reshape((/& 1, 5, 1, & 0, 6, 2, & 3, 3, 3, & 0, 4, 4/),(/3,4/)) !5 - allocate(cv_tet_bdy_permutations(11)%p(3,4)) + allocate(cv_tet_bdy_permutations(11)%p(3,4)) - cv_tet_bdy_permutations(11)%p=reshape((/& + cv_tet_bdy_permutations(11)%p=reshape((/& 3, 3, 3, & 0, 4, 4, & 1, 1, 5, & 0, 2, 6/),(/3,4/)) !5 - allocate(cv_tet_bdy_permutations(12)%p(3,4)) + allocate(cv_tet_bdy_permutations(12)%p(3,4)) - cv_tet_bdy_permutations(12)%p=reshape((/& + cv_tet_bdy_permutations(12)%p=reshape((/& 0, 0, 7, & 2, 0, 6, & 0, 2, 6, & 1, 1, 5/),(/3,4/)) !6 - ! end of quadratic + ! end of quadratic - end subroutine construct_cv_tet_bdy_permutations + end subroutine construct_cv_tet_bdy_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_line_bdy_permutations + subroutine construct_cv_line_bdy_permutations - ! linear - allocate(cv_line_bdy_permutations(1)%p(2,2)) + ! linear + allocate(cv_line_bdy_permutations(1)%p(2,2)) - cv_line_bdy_permutations(1)%p=reshape((/& + cv_line_bdy_permutations(1)%p=reshape((/& 2, 0, & 1, 1/),(/2,2/)) - allocate(cv_line_bdy_permutations(2)%p(2,2)) + allocate(cv_line_bdy_permutations(2)%p(2,2)) - cv_line_bdy_permutations(2)%p=reshape((/& + cv_line_bdy_permutations(2)%p=reshape((/& 1, 1, & 0, 2/),(/2,2/)) - ! end of linear + ! end of linear - ! quadratic - allocate(cv_line_bdy_permutations(3)%p(2,2)) + ! quadratic + allocate(cv_line_bdy_permutations(3)%p(2,2)) - cv_line_bdy_permutations(3)%p=reshape((/& + cv_line_bdy_permutations(3)%p=reshape((/& 3, 0, & 2, 1/),(/2,2/)) - allocate(cv_line_bdy_permutations(4)%p(2,2)) + allocate(cv_line_bdy_permutations(4)%p(2,2)) - cv_line_bdy_permutations(4)%p=reshape((/& + cv_line_bdy_permutations(4)%p=reshape((/& 2, 1, & 1, 2/),(/2,2/)) - allocate(cv_line_bdy_permutations(5)%p(2,2)) + allocate(cv_line_bdy_permutations(5)%p(2,2)) - cv_line_bdy_permutations(5)%p=reshape((/& + cv_line_bdy_permutations(5)%p=reshape((/& 1, 2, & 0, 3/),(/2,2/)) - ! end of quadratic + ! end of quadratic - end subroutine construct_cv_line_bdy_permutations + end subroutine construct_cv_line_bdy_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_point_bdy_permutations + subroutine construct_cv_point_bdy_permutations - allocate(cv_point_bdy_permutations(1)%p(1,1)) + allocate(cv_point_bdy_permutations(1)%p(1,1)) - cv_point_bdy_permutations(1)%p=reshape((/& + cv_point_bdy_permutations(1)%p=reshape((/& 1/),(/1,1/)) - end subroutine construct_cv_point_bdy_permutations + end subroutine construct_cv_point_bdy_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - subroutine construct_cv_hex_bdy_permutations + subroutine construct_cv_hex_bdy_permutations - allocate(cv_hex_bdy_permutations(1)%p(2,4)) + allocate(cv_hex_bdy_permutations(1)%p(2,4)) - cv_hex_bdy_permutations(1)%p=reshape((/& + cv_hex_bdy_permutations(1)%p=reshape((/& -1, -1, & 0, -1, & -1, 0, & 0, 0/),(/2,4/)) - allocate(cv_hex_bdy_permutations(2)%p(2,4)) + allocate(cv_hex_bdy_permutations(2)%p(2,4)) - cv_hex_bdy_permutations(2)%p=reshape((/& + cv_hex_bdy_permutations(2)%p=reshape((/& 0, -1, & 1, -1, & 0, 0, & 1, 0/),(/2,4/)) - allocate(cv_hex_bdy_permutations(3)%p(2,4)) + allocate(cv_hex_bdy_permutations(3)%p(2,4)) - cv_hex_bdy_permutations(3)%p=reshape((/& + cv_hex_bdy_permutations(3)%p=reshape((/& -1, 0, & 0, 0, & -1, 1, & 0, 1/),(/2,4/)) - allocate(cv_hex_bdy_permutations(4)%p(2,4)) + allocate(cv_hex_bdy_permutations(4)%p(2,4)) - cv_hex_bdy_permutations(4)%p=reshape((/& + cv_hex_bdy_permutations(4)%p=reshape((/& 0, 0, & 1, 0, & 0, 1, & 1, 1/),(/2,4/)) - end subroutine construct_cv_hex_bdy_permutations + end subroutine construct_cv_hex_bdy_permutations !< ------------------------------------------------- >! !< ------------------------------------------------- >! - function make_face_generator(permutation, nodes, coords) result (generator) - !!< Function hiding the fact that generators are dynamically sized. - type(face_generator_type) :: generator - type(corner_permutation_type), intent(in) :: permutation - integer, dimension(:), intent(in) :: nodes - real, dimension(:), intent(in) :: coords + function make_face_generator(permutation, nodes, coords) result (generator) + !!< Function hiding the fact that generators are dynamically sized. + type(face_generator_type) :: generator + type(corner_permutation_type), intent(in) :: permutation + integer, dimension(:), intent(in) :: nodes + real, dimension(:), intent(in) :: coords - generator%permutation=>permutation%p - allocate(generator%coords(size(coords))) - generator%nodes=nodes - generator%coords=coords + generator%permutation=>permutation%p + allocate(generator%coords(size(coords))) + generator%nodes=nodes + generator%coords=coords - end function make_face_generator + end function make_face_generator - subroutine expand_cv_faces_template(cvfaces, cv_temp, cvbdy_temp) - ! Expand the given template into the cvfaces provided. - type(cv_faces_type), intent(inout) :: cvfaces - type(face_corner_template), intent(in) :: cv_temp, cvbdy_temp + subroutine expand_cv_faces_template(cvfaces, cv_temp, cvbdy_temp) + ! Expand the given template into the cvfaces provided. + type(cv_faces_type), intent(inout) :: cvfaces + type(face_corner_template), intent(in) :: cv_temp, cvbdy_temp - integer :: i, j, k - type(face_generator_type), pointer :: lgen + integer :: i, j, k + type(face_generator_type), pointer :: lgen - cvfaces%corners=0.0 - cvfaces%neiloc=0 + cvfaces%corners=0.0 + cvfaces%neiloc=0 - do i=1,size(cv_temp%generator) - lgen=>cv_temp%generator(i) + do i=1,size(cv_temp%generator) + lgen=>cv_temp%generator(i) - ! Permute coordinates and insert into cvloc%corners - forall(j=1:size(lgen%permutation,1), & + ! Permute coordinates and insert into cvloc%corners + forall(j=1:size(lgen%permutation,1), & k=1:size(lgen%permutation,2), & lgen%permutation(j,k)/=0) - ! The permutation stores both the permutation order and (for - ! quads and hexs) the sign of the coordinate. + ! The permutation stores both the permutation order and (for + ! quads and hexs) the sign of the coordinate. cvfaces%corners(i,j,k)=sign(lgen%coords(abs(lgen%permutation(j,k))),& - & real(lgen%permutation(j,k))) - end forall + & real(lgen%permutation(j,k))) + end forall - cvfaces%neiloc(lgen%nodes(1),i)=lgen%nodes(2) - cvfaces%neiloc(lgen%nodes(2),i)=lgen%nodes(1) + cvfaces%neiloc(lgen%nodes(1),i)=lgen%nodes(2) + cvfaces%neiloc(lgen%nodes(2),i)=lgen%nodes(1) - end do + end do - cvfaces%scorners=0.0 - cvfaces%sneiloc=0 + cvfaces%scorners=0.0 + cvfaces%sneiloc=0 - do i=1,size(cvbdy_temp%generator) - lgen=>cvbdy_temp%generator(i) + do i=1,size(cvbdy_temp%generator) + lgen=>cvbdy_temp%generator(i) - ! Permute coordinates and insert into cvloc%corners - forall(j=1:size(lgen%permutation,1), & + ! Permute coordinates and insert into cvloc%corners + forall(j=1:size(lgen%permutation,1), & k=1:size(lgen%permutation,2), & lgen%permutation(j,k)/=0) - ! The permutation stores both the permutation order and (for - ! quads and hexs) the sign of the coordinate. - cvfaces%scorners(i,j,k)=sign(lgen%coords(abs(lgen%permutation(j,k))),& - & real(lgen%permutation(j,k))) - end forall + ! The permutation stores both the permutation order and (for + ! quads and hexs) the sign of the coordinate. + cvfaces%scorners(i,j,k)=sign(lgen%coords(abs(lgen%permutation(j,k))),& + & real(lgen%permutation(j,k))) + end forall - cvfaces%sneiloc(lgen%nodes(1),i)=lgen%nodes(2) + cvfaces%sneiloc(lgen%nodes(1),i)=lgen%nodes(2) - end do + end do - end subroutine expand_cv_faces_template + end subroutine expand_cv_faces_template end module cv_faces diff --git a/femtools/CV_Fields.F90 b/femtools/CV_Fields.F90 index 6b4c387de4..a0e5e19940 100644 --- a/femtools/CV_Fields.F90 +++ b/femtools/CV_Fields.F90 @@ -26,142 +26,142 @@ ! USA #include "fdebug.h" module cv_fields - !!< Module containing general tools for discretising Control Volume problems. - use spud - use fldebug - use global_parameters, only: FIELD_NAME_LEN - use fields - use state_module - use cvtools - use diagnostic_fields + !!< Module containing general tools for discretising Control Volume problems. + use spud + use fldebug + use global_parameters, only: FIELD_NAME_LEN + use fields + use state_module + use cvtools + use diagnostic_fields - implicit none + implicit none - private - public :: cv_disc_get_cfl_no + private + public :: cv_disc_get_cfl_no contains - subroutine cv_disc_get_cfl_no(field_option_path, state, mesh, cfl_no, density_option_path) - !!< This subroutine returns the cfl number (if needed) - !!< based on the option paths provided. - !!< If it is not required it returns a constant field. - !!< this subroutine allocates a field... please deallocate after! - - !! option paths used to determine if a cfl no is needed for field - character(len=*), dimension(:), intent(in) :: field_option_path - ! bucket full of fields - type(state_type), intent(inout) :: state - ! mesh to allocate the cfl_no on - type(mesh_type), intent(inout) :: mesh - !! a scalar field for the cfl no.... still to be allocated - type(scalar_field), intent(inout) :: cfl_no - !! option path used to determine if a cfl no is needed for density - character(len=*), dimension(:), optional, intent(in) :: density_option_path - - character(len=FIELD_NAME_LEN) :: cfl_type - integer :: f, cfl_stat, stat - ! somewhere to put strings temporarily - character(len=FIELD_NAME_LEN) :: tmpstring - integer :: nfields - - nfields = size(field_option_path) - if(present(density_option_path)) then - ! this allows multiple grouped fields to be evaluated at once - ! (mostly used for coupled_cv) - assert(nfields==size(density_option_path)) - end if - - ! hmmm, do we need a cfl no.? - ! there are three reasons we might... - ! the field or density discretisation might need it - ! or we might need it to subcycle - ! at the moment these all have to use the same definition - ! of the courant number - cfl_type="start" - cfl_stat=1 - - do f = 1, nfields - ! check to see if the field discretisation requires a courant number - call get_option(trim(complete_cv_field_path(field_option_path(f)))//& - "/face_value[0]/courant_number[0]/name", & - tmpstring, stat) - if(stat==0) then - if(trim(cfl_type)=="start") then - cfl_type=tmpstring - cfl_stat=stat - elseif(trim(cfl_type)/=trim(tmpstring)) then - ewrite(-1,*) "Attempting to discretise two fields using different courant numbers." - FLExit("This is not currently supported.") - end if - end if - + subroutine cv_disc_get_cfl_no(field_option_path, state, mesh, cfl_no, density_option_path) + !!< This subroutine returns the cfl number (if needed) + !!< based on the option paths provided. + !!< If it is not required it returns a constant field. + !!< this subroutine allocates a field... please deallocate after! + + !! option paths used to determine if a cfl no is needed for field + character(len=*), dimension(:), intent(in) :: field_option_path + ! bucket full of fields + type(state_type), intent(inout) :: state + ! mesh to allocate the cfl_no on + type(mesh_type), intent(inout) :: mesh + !! a scalar field for the cfl no.... still to be allocated + type(scalar_field), intent(inout) :: cfl_no + !! option path used to determine if a cfl no is needed for density + character(len=*), dimension(:), optional, intent(in) :: density_option_path + + character(len=FIELD_NAME_LEN) :: cfl_type + integer :: f, cfl_stat, stat + ! somewhere to put strings temporarily + character(len=FIELD_NAME_LEN) :: tmpstring + integer :: nfields + + nfields = size(field_option_path) if(present(density_option_path)) then - ! check to see if the density discretisation requires a courant number - call get_option(trim(complete_cv_field_path(density_option_path(f)))//& - "/face_value[0]/courant_number[0]/name", & - tmpstring, stat) - if(stat==0) then - if(trim(cfl_type)=="start") then - cfl_type=tmpstring - cfl_stat=stat - elseif(trim(cfl_type)/=trim(tmpstring)) then - ewrite(-1,*) "Attempting to discretise two fields using different courant numbers." - FLExit("This is not currently supported.") - end if - end if - end if - - ! check to see if we need the courant number to subcycle with - call get_option(trim(field_option_path(f))//& - "/prognostic/temporal_discretisation& - &/control_volumes/maximum_courant_number_per_subcycle& - &/courant_number[0]/name", & - tmpstring, stat) - if(stat==0) then - if(trim(cfl_type)=="start") then - cfl_type=tmpstring - cfl_stat=stat - elseif(trim(cfl_type)/=trim(tmpstring)) then - ewrite(-1,*) "Attempting to discretise face values "//& - "using a "//trim(cfl_type)//" courant number" - ewrite(-1,*) "and to subcycle "//& - "using a "//trim(tmpstring)//" courant number." - FLExit("This is not currently supported.") - end if + ! this allows multiple grouped fields to be evaluated at once + ! (mostly used for coupled_cv) + assert(nfields==size(density_option_path)) end if - ! check to see if we need the courant number for the limiter - call get_option(trim(complete_cv_field_path(field_option_path(f)))//& - "/face_value[0]/limit_face_value/limiter[0]& - &/courant_number[0]/name", & - tmpstring, stat) - if(stat==0) then - if(trim(cfl_type)=="start") then - cfl_type=tmpstring - cfl_stat=stat - elseif(trim(cfl_type)/=trim(tmpstring)) then - ewrite(-1,*) "Attempting to discretise face values or subcycle"//& - "using a "//trim(cfl_type)//" courant number" - ewrite(-1,*) "and to limit "//& - "using a "//trim(tmpstring)//" courant number." - FLExit("This is not currently supported.") - end if + ! hmmm, do we need a cfl no.? + ! there are three reasons we might... + ! the field or density discretisation might need it + ! or we might need it to subcycle + ! at the moment these all have to use the same definition + ! of the courant number + cfl_type="start" + cfl_stat=1 + + do f = 1, nfields + ! check to see if the field discretisation requires a courant number + call get_option(trim(complete_cv_field_path(field_option_path(f)))//& + "/face_value[0]/courant_number[0]/name", & + tmpstring, stat) + if(stat==0) then + if(trim(cfl_type)=="start") then + cfl_type=tmpstring + cfl_stat=stat + elseif(trim(cfl_type)/=trim(tmpstring)) then + ewrite(-1,*) "Attempting to discretise two fields using different courant numbers." + FLExit("This is not currently supported.") + end if + end if + + if(present(density_option_path)) then + ! check to see if the density discretisation requires a courant number + call get_option(trim(complete_cv_field_path(density_option_path(f)))//& + "/face_value[0]/courant_number[0]/name", & + tmpstring, stat) + if(stat==0) then + if(trim(cfl_type)=="start") then + cfl_type=tmpstring + cfl_stat=stat + elseif(trim(cfl_type)/=trim(tmpstring)) then + ewrite(-1,*) "Attempting to discretise two fields using different courant numbers." + FLExit("This is not currently supported.") + end if + end if + end if + + ! check to see if we need the courant number to subcycle with + call get_option(trim(field_option_path(f))//& + "/prognostic/temporal_discretisation& + &/control_volumes/maximum_courant_number_per_subcycle& + &/courant_number[0]/name", & + tmpstring, stat) + if(stat==0) then + if(trim(cfl_type)=="start") then + cfl_type=tmpstring + cfl_stat=stat + elseif(trim(cfl_type)/=trim(tmpstring)) then + ewrite(-1,*) "Attempting to discretise face values "//& + "using a "//trim(cfl_type)//" courant number" + ewrite(-1,*) "and to subcycle "//& + "using a "//trim(tmpstring)//" courant number." + FLExit("This is not currently supported.") + end if + end if + + ! check to see if we need the courant number for the limiter + call get_option(trim(complete_cv_field_path(field_option_path(f)))//& + "/face_value[0]/limit_face_value/limiter[0]& + &/courant_number[0]/name", & + tmpstring, stat) + if(stat==0) then + if(trim(cfl_type)=="start") then + cfl_type=tmpstring + cfl_stat=stat + elseif(trim(cfl_type)/=trim(tmpstring)) then + ewrite(-1,*) "Attempting to discretise face values or subcycle"//& + "using a "//trim(cfl_type)//" courant number" + ewrite(-1,*) "and to limit "//& + "using a "//trim(tmpstring)//" courant number." + FLExit("This is not currently supported.") + end if + end if + + end do + + if (cfl_stat==0) then + ! otherwise we want to calculate a node centred field of the cfl number + call allocate(cfl_no, mesh, "CourantNumber") + call calculate_diagnostic_variable(state, trim(cfl_type), cfl_no, & + &option_path=trim(complete_cv_field_path(field_option_path(1)))//"/face_value[0]/courant_number[0]") + else + ! if we don't need a cfl number then just set it all to 1 + call allocate(cfl_no, mesh, "CourantNumber", field_type=FIELD_TYPE_CONSTANT) + call set(cfl_no, 1.0) end if - end do - - if (cfl_stat==0) then - ! otherwise we want to calculate a node centred field of the cfl number - call allocate(cfl_no, mesh, "CourantNumber") - call calculate_diagnostic_variable(state, trim(cfl_type), cfl_no, & - &option_path=trim(complete_cv_field_path(field_option_path(1)))//"/face_value[0]/courant_number[0]") - else - ! if we don't need a cfl number then just set it all to 1 - call allocate(cfl_no, mesh, "CourantNumber", field_type=FIELD_TYPE_CONSTANT) - call set(cfl_no, 1.0) - end if - - end subroutine cv_disc_get_cfl_no + end subroutine cv_disc_get_cfl_no end module cv_fields diff --git a/femtools/CV_Options.F90 b/femtools/CV_Options.F90 index 2c540243a9..89aab32cc9 100644 --- a/femtools/CV_Options.F90 +++ b/femtools/CV_Options.F90 @@ -26,42 +26,42 @@ ! USA #include "fdebug.h" module cv_options - !!< Module containing general tools for discretising Control Volume problems. - use spud - use fldebug - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN - use futils - use element_numbering, only: FAMILY_SIMPLEX, FAMILY_CUBE - use field_options, only: complete_field_path - use cvtools, only: complete_cv_field_path - - implicit none - - integer, parameter, public :: CV_FACEVALUE_NONE=0, & - CV_FACEVALUE_FIRSTORDERUPWIND=1, & - CV_FACEVALUE_TRAPEZOIDAL=2, & - CV_FACEVALUE_FINITEELEMENT=3, & - CV_FACEVALUE_HYPERC=4, & - CV_FACEVALUE_ULTRAC=5, & - CV_FACEVALUE_POTENTIALULTRAC=6, & - CV_FACEVALUE_FIRSTORDERDOWNWIND=7 - - integer, parameter, public :: CV_DIFFUSION_NONE=0, & - CV_DIFFUSION_BASSIREBAY=1, & - CV_DIFFUSION_ELEMENTGRADIENT=2 - - integer, parameter, public :: CV_DOWNWIND_PROJECTION_NODE=1, & - CV_DONOR_PROJECTION_NODE=2 - - integer, parameter, public :: CV_LIMITER_NONE=0, & - CV_LIMITER_SWEBY=1, & - CV_LIMITER_ULTIMATE=2 - - integer, public, parameter :: CV_UPWINDVALUE_NONE=0, & - CV_UPWINDVALUE_PROJECT_POINT=1, & - CV_UPWINDVALUE_PROJECT_GRAD=2, & - CV_UPWINDVALUE_LOCAL=3, & - CV_UPWINDVALUE_STRUCTURED=4 + !!< Module containing general tools for discretising Control Volume problems. + use spud + use fldebug + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use futils + use element_numbering, only: FAMILY_SIMPLEX, FAMILY_CUBE + use field_options, only: complete_field_path + use cvtools, only: complete_cv_field_path + + implicit none + + integer, parameter, public :: CV_FACEVALUE_NONE=0, & + CV_FACEVALUE_FIRSTORDERUPWIND=1, & + CV_FACEVALUE_TRAPEZOIDAL=2, & + CV_FACEVALUE_FINITEELEMENT=3, & + CV_FACEVALUE_HYPERC=4, & + CV_FACEVALUE_ULTRAC=5, & + CV_FACEVALUE_POTENTIALULTRAC=6, & + CV_FACEVALUE_FIRSTORDERDOWNWIND=7 + + integer, parameter, public :: CV_DIFFUSION_NONE=0, & + CV_DIFFUSION_BASSIREBAY=1, & + CV_DIFFUSION_ELEMENTGRADIENT=2 + + integer, parameter, public :: CV_DOWNWIND_PROJECTION_NODE=1, & + CV_DONOR_PROJECTION_NODE=2 + + integer, parameter, public :: CV_LIMITER_NONE=0, & + CV_LIMITER_SWEBY=1, & + CV_LIMITER_ULTIMATE=2 + + integer, public, parameter :: CV_UPWINDVALUE_NONE=0, & + CV_UPWINDVALUE_PROJECT_POINT=1, & + CV_UPWINDVALUE_PROJECT_GRAD=2, & + CV_UPWINDVALUE_LOCAL=3, & + CV_UPWINDVALUE_STRUCTURED=4 type cv_options_type ! this is a wrapper type to pass around all the options a control @@ -91,276 +91,276 @@ module cv_options end type cv_options_type - private - public :: cv_options_type, get_cv_options, & - cv_projection_node, cv_facevalue_integer + private + public :: cv_options_type, get_cv_options, & + cv_projection_node, cv_facevalue_integer contains - function get_cv_options(option_path, element_family, dim, coefficient_field) result(cv_options) - - ! This function retrieves all current control volume - ! discretisation options wrapped in a cv_options_type. - - ! Defaults deal with the case where nonprognostic fields - ! are passed in. - - character(len=*), intent(in) :: option_path - integer, intent(in) :: element_family, dim - logical, intent(in), optional :: coefficient_field - type(cv_options_type) :: cv_options - - character(len=FIELD_NAME_LEN) :: tmpstring - integer :: stat - - ! spatial discretisation options - call get_option(trim(complete_cv_field_path(option_path))//& - "/face_value[0]/name", & - tmpstring) - cv_options%facevalue = cv_facevalue_integer(tmpstring) - - call get_option(trim(complete_cv_field_path(option_path))//& - "/diffusion_scheme[0]/name", & - tmpstring, default="None") - cv_options%diffusionscheme = cv_diffusionscheme_integer(tmpstring) - - cv_options%limit_facevalue = have_option(trim(complete_cv_field_path(option_path))//& - "/face_value[0]/limit_face_value") - - call get_option(trim(complete_cv_field_path(option_path))//& - "/face_value[0]/limit_face_value/limiter[0]/name", & - tmpstring, default="None") - cv_options%limiter = cv_limiter_integer(tmpstring) - - call get_option(trim(complete_cv_field_path(option_path))//& - '/face_value[0]/target_maximum', & - cv_options%target_max, default=1.0) - call get_option(trim(complete_cv_field_path(option_path))//& - '/face_value[0]/target_minimum', & - cv_options%target_min, default=0.0) - - call get_option(trim(complete_cv_field_path(option_path))//& - '/parent_sum/target_maximum', & - cv_options%sum_target_max, default=1.0) - call get_option(trim(complete_cv_field_path(option_path))//& - '/parent_sum/target_minimum', & - cv_options%sum_target_min, default=0.0) - - cv_options%hyperc_switch = have_option(trim(complete_cv_field_path(option_path))//& - "/face_value[0]/switch_to_hyperc") - cv_options%potential_flux = have_option(trim(complete_cv_field_path(option_path))//& - "/face_value[0]/use_potential_flux") - - ! temporal discretisation options - cv_options%limit_theta = have_option(trim(complete_field_path(option_path, stat=stat))//& - "/temporal_discretisation& - &/control_volumes/limit_theta") - call get_option(trim(complete_field_path(option_path, stat=stat))//& - "/temporal_discretisation& - &/theta", cv_options%theta) - if (cv_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND) then + function get_cv_options(option_path, element_family, dim, coefficient_field) result(cv_options) + + ! This function retrieves all current control volume + ! discretisation options wrapped in a cv_options_type. + + ! Defaults deal with the case where nonprognostic fields + ! are passed in. + + character(len=*), intent(in) :: option_path + integer, intent(in) :: element_family, dim + logical, intent(in), optional :: coefficient_field + type(cv_options_type) :: cv_options + + character(len=FIELD_NAME_LEN) :: tmpstring + integer :: stat + + ! spatial discretisation options + call get_option(trim(complete_cv_field_path(option_path))//& + "/face_value[0]/name", & + tmpstring) + cv_options%facevalue = cv_facevalue_integer(tmpstring) + + call get_option(trim(complete_cv_field_path(option_path))//& + "/diffusion_scheme[0]/name", & + tmpstring, default="None") + cv_options%diffusionscheme = cv_diffusionscheme_integer(tmpstring) + + cv_options%limit_facevalue = have_option(trim(complete_cv_field_path(option_path))//& + "/face_value[0]/limit_face_value") + + call get_option(trim(complete_cv_field_path(option_path))//& + "/face_value[0]/limit_face_value/limiter[0]/name", & + tmpstring, default="None") + cv_options%limiter = cv_limiter_integer(tmpstring) + + call get_option(trim(complete_cv_field_path(option_path))//& + '/face_value[0]/target_maximum', & + cv_options%target_max, default=1.0) + call get_option(trim(complete_cv_field_path(option_path))//& + '/face_value[0]/target_minimum', & + cv_options%target_min, default=0.0) + + call get_option(trim(complete_cv_field_path(option_path))//& + '/parent_sum/target_maximum', & + cv_options%sum_target_max, default=1.0) + call get_option(trim(complete_cv_field_path(option_path))//& + '/parent_sum/target_minimum', & + cv_options%sum_target_min, default=0.0) + + cv_options%hyperc_switch = have_option(trim(complete_cv_field_path(option_path))//& + "/face_value[0]/switch_to_hyperc") + cv_options%potential_flux = have_option(trim(complete_cv_field_path(option_path))//& + "/face_value[0]/use_potential_flux") + + ! temporal discretisation options + cv_options%limit_theta = have_option(trim(complete_field_path(option_path, stat=stat))//& + "/temporal_discretisation& + &/control_volumes/limit_theta") call get_option(trim(complete_field_path(option_path, stat=stat))//& - "/temporal_discretisation& - &/control_volumes/pivot_theta", & - cv_options%ptheta, stat=stat) - if(stat==0) then - if(cv_options%ptheta/=cv_options%theta) then - ewrite(-1,*) "Found a different pivot_theta and theta for the field with" - ewrite(-1,*) "option_path: "//trim(option_path) - ewrite(-1,*) "This field uses first order upwinding." - ewrite(-1,*) "As the pivot is also first order upwinding theta and" - ewrite(-1,*) "pivot theta should be the same." - FLExit("Switch off pivot_theta or set it to be the same as theta.") - end if + "/temporal_discretisation& + &/theta", cv_options%theta) + if (cv_options%facevalue==CV_FACEVALUE_FIRSTORDERUPWIND) then + call get_option(trim(complete_field_path(option_path, stat=stat))//& + "/temporal_discretisation& + &/control_volumes/pivot_theta", & + cv_options%ptheta, stat=stat) + if(stat==0) then + if(cv_options%ptheta/=cv_options%theta) then + ewrite(-1,*) "Found a different pivot_theta and theta for the field with" + ewrite(-1,*) "option_path: "//trim(option_path) + ewrite(-1,*) "This field uses first order upwinding." + ewrite(-1,*) "As the pivot is also first order upwinding theta and" + ewrite(-1,*) "pivot theta should be the same." + FLExit("Switch off pivot_theta or set it to be the same as theta.") + end if + else + ! the pivot is a first order upwind value value too so + ! the pivot theta should be the same + cv_options%ptheta = cv_options%theta + end if else - ! the pivot is a first order upwind value value too so - ! the pivot theta should be the same - cv_options%ptheta = cv_options%theta + call get_option(trim(complete_field_path(option_path, stat=stat))//& + "/temporal_discretisation& + &/control_volumes/pivot_theta", & + cv_options%ptheta, default=1.0) end if - else - call get_option(trim(complete_field_path(option_path, stat=stat))//& - "/temporal_discretisation& - &/control_volumes/pivot_theta", & - cv_options%ptheta, default=1.0) - end if - if(present_and_true(coefficient_field)) then - ! if these options are for a field that just a coefficient to the main - ! equation then this isn't need. - ! initialise it to something insane to make sure it will be noticed if used. - cv_options%beta = -666.0 - else - call get_option(trim(complete_field_path(option_path, stat=stat))//& - "/spatial_discretisation& - &/conservative_advection", & - cv_options%beta) - end if - call get_option(trim(complete_cv_field_path(option_path))//& - '/face_value[0]/limit_face_value/limiter[0]/slopes& - &/lower', cv_options%limiter_slopes(1), default=1.0) - call get_option(trim(complete_cv_field_path(option_path))//& - '/face_value[0]/limit_face_value/limiter[0]/slopes& - &/upper', cv_options%limiter_slopes(2), default=2.0) - - cv_options%upwind_scheme=cv_upwind_scheme(option_path, element_family, dim) - - end function get_cv_options - - integer function cv_facevalue_integer(face_discretisation) - - character(len=*) :: face_discretisation - - select case(trim(face_discretisation)) - case ("FirstOrderUpwind") - cv_facevalue_integer = CV_FACEVALUE_FIRSTORDERUPWIND - case ("Trapezoidal") - cv_facevalue_integer = CV_FACEVALUE_TRAPEZOIDAL - case ("FiniteElement") - cv_facevalue_integer = CV_FACEVALUE_FINITEELEMENT - case ( "HyperC" ) - cv_facevalue_integer = CV_FACEVALUE_HYPERC - case ( "UltraC" ) - cv_facevalue_integer = CV_FACEVALUE_ULTRAC - case ( "PotentialUltraC" ) - cv_facevalue_integer = CV_FACEVALUE_POTENTIALULTRAC - case ("FirstOrderDownwind") - cv_facevalue_integer = CV_FACEVALUE_FIRSTORDERDOWNWIND - case ("None") - cv_facevalue_integer = CV_FACEVALUE_NONE - case default - FLAbort("Unknown control volume face value scheme.") - end select - - end function cv_facevalue_integer - - integer function cv_diffusionscheme_integer(face_discretisation) - - character(len=*) :: face_discretisation - - select case(trim(face_discretisation)) - case ("BassiRebay") - cv_diffusionscheme_integer = CV_DIFFUSION_BASSIREBAY - case ("ElementGradient") - cv_diffusionscheme_integer = CV_DIFFUSION_ELEMENTGRADIENT - case ("None") - cv_diffusionscheme_integer = CV_DIFFUSION_NONE - case default - FLAbort("Unknown control volume diffusion scheme.") - end select - - end function cv_diffusionscheme_integer - - integer function cv_limiter_integer(limiter_name) - - character(len=*) :: limiter_name - - select case(trim(limiter_name)) - case ("None") - cv_limiter_integer = CV_LIMITER_NONE - case ("Sweby") - cv_limiter_integer = CV_LIMITER_SWEBY - case ("Ultimate") - cv_limiter_integer = CV_LIMITER_ULTIMATE - case default - FLAbort("Unknown control volume face value limiter option.") - end select - - end function cv_limiter_integer - - integer function cv_projection_node(option_path) - - character(len=*) :: option_path - - if((have_option(trim(complete_cv_field_path(option_path))//& - &"/face_value[0]/limit_face_value/limiter[0]"//& - &"/project_upwind_value_from_gradient"//& - &"/project_from_downwind_value")).or.& - (have_option(trim(complete_cv_field_path(option_path))//& - &"/face_value[0]"//& - &"/project_upwind_value_from_gradient"//& - &"/project_from_downwind_value"))) then - - cv_projection_node = CV_DOWNWIND_PROJECTION_NODE - - else if((have_option(trim(complete_cv_field_path(option_path))//& - &"/face_value[0]/limit_face_value/limiter[0]"//& - &"/project_upwind_value_from_gradient"//& - &"/project_from_donor_value")).or.& - (have_option(trim(complete_cv_field_path(option_path))//& - &"/face_value[0]"//& - &"/project_upwind_value_from_gradient"//& - &"/project_from_donor_value"))) then - - cv_projection_node = CV_DONOR_PROJECTION_NODE - - else - FLAbort("Unknown projection_node") - end if - - end function cv_projection_node - - function cv_upwind_scheme(option_path, element_family, dim) result(upwind_scheme) - - character(len=*), intent(in) :: option_path - integer, intent(in) :: element_family, dim - integer :: upwind_scheme - - character(len=OPTION_PATH_LEN) :: spatial_discretisation_path, upwind_value_path - logical :: project_point, project_grad, local, structured - - spatial_discretisation_path = trim(complete_cv_field_path(option_path)) - - if(have_option(trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value")) then - upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value/limiter[0]" - else - upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]" - end if - - ! do we want to project to the upwind value from a point? - project_point = have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_point') - - ! do we want to project to the upwind value using the gradient? - project_grad = have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_gradient') - - ! do we want to use local values as the upwind value? - local = have_option(trim(upwind_value_path)//& - '/locally_bound_upwind_value') - - ! do we want to use pseudo-structured values as the upwind value? - structured = have_option(trim(upwind_value_path)//& - '/pseudo_structured_upwind_value') - - ! in case none (or both) selected default to family type selection - select case(element_family) - case (FAMILY_SIMPLEX) ! use projection except in 1d - if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then - if(dim==1) then - local = .true. - else - project_point = .true. - end if + if(present_and_true(coefficient_field)) then + ! if these options are for a field that just a coefficient to the main + ! equation then this isn't need. + ! initialise it to something insane to make sure it will be noticed if used. + cv_options%beta = -666.0 + else + call get_option(trim(complete_field_path(option_path, stat=stat))//& + "/spatial_discretisation& + &/conservative_advection", & + cv_options%beta) + end if + call get_option(trim(complete_cv_field_path(option_path))//& + '/face_value[0]/limit_face_value/limiter[0]/slopes& + &/lower', cv_options%limiter_slopes(1), default=1.0) + call get_option(trim(complete_cv_field_path(option_path))//& + '/face_value[0]/limit_face_value/limiter[0]/slopes& + &/upper', cv_options%limiter_slopes(2), default=2.0) + + cv_options%upwind_scheme=cv_upwind_scheme(option_path, element_family, dim) + + end function get_cv_options + + integer function cv_facevalue_integer(face_discretisation) + + character(len=*) :: face_discretisation + + select case(trim(face_discretisation)) + case ("FirstOrderUpwind") + cv_facevalue_integer = CV_FACEVALUE_FIRSTORDERUPWIND + case ("Trapezoidal") + cv_facevalue_integer = CV_FACEVALUE_TRAPEZOIDAL + case ("FiniteElement") + cv_facevalue_integer = CV_FACEVALUE_FINITEELEMENT + case ( "HyperC" ) + cv_facevalue_integer = CV_FACEVALUE_HYPERC + case ( "UltraC" ) + cv_facevalue_integer = CV_FACEVALUE_ULTRAC + case ( "PotentialUltraC" ) + cv_facevalue_integer = CV_FACEVALUE_POTENTIALULTRAC + case ("FirstOrderDownwind") + cv_facevalue_integer = CV_FACEVALUE_FIRSTORDERDOWNWIND + case ("None") + cv_facevalue_integer = CV_FACEVALUE_NONE + case default + FLAbort("Unknown control volume face value scheme.") + end select + + end function cv_facevalue_integer + + integer function cv_diffusionscheme_integer(face_discretisation) + + character(len=*) :: face_discretisation + + select case(trim(face_discretisation)) + case ("BassiRebay") + cv_diffusionscheme_integer = CV_DIFFUSION_BASSIREBAY + case ("ElementGradient") + cv_diffusionscheme_integer = CV_DIFFUSION_ELEMENTGRADIENT + case ("None") + cv_diffusionscheme_integer = CV_DIFFUSION_NONE + case default + FLAbort("Unknown control volume diffusion scheme.") + end select + + end function cv_diffusionscheme_integer + + integer function cv_limiter_integer(limiter_name) + + character(len=*) :: limiter_name + + select case(trim(limiter_name)) + case ("None") + cv_limiter_integer = CV_LIMITER_NONE + case ("Sweby") + cv_limiter_integer = CV_LIMITER_SWEBY + case ("Ultimate") + cv_limiter_integer = CV_LIMITER_ULTIMATE + case default + FLAbort("Unknown control volume face value limiter option.") + end select + + end function cv_limiter_integer + + integer function cv_projection_node(option_path) + + character(len=*) :: option_path + + if((have_option(trim(complete_cv_field_path(option_path))//& + &"/face_value[0]/limit_face_value/limiter[0]"//& + &"/project_upwind_value_from_gradient"//& + &"/project_from_downwind_value")).or.& + (have_option(trim(complete_cv_field_path(option_path))//& + &"/face_value[0]"//& + &"/project_upwind_value_from_gradient"//& + &"/project_from_downwind_value"))) then + + cv_projection_node = CV_DOWNWIND_PROJECTION_NODE + + else if((have_option(trim(complete_cv_field_path(option_path))//& + &"/face_value[0]/limit_face_value/limiter[0]"//& + &"/project_upwind_value_from_gradient"//& + &"/project_from_donor_value")).or.& + (have_option(trim(complete_cv_field_path(option_path))//& + &"/face_value[0]"//& + &"/project_upwind_value_from_gradient"//& + &"/project_from_donor_value"))) then + + cv_projection_node = CV_DONOR_PROJECTION_NODE + + else + FLAbort("Unknown projection_node") + end if + + end function cv_projection_node + + function cv_upwind_scheme(option_path, element_family, dim) result(upwind_scheme) + + character(len=*), intent(in) :: option_path + integer, intent(in) :: element_family, dim + integer :: upwind_scheme + + character(len=OPTION_PATH_LEN) :: spatial_discretisation_path, upwind_value_path + logical :: project_point, project_grad, local, structured + + spatial_discretisation_path = trim(complete_cv_field_path(option_path)) + + if(have_option(trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value")) then + upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value/limiter[0]" + else + upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]" end if - case (FAMILY_CUBE) ! use local - if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then - local=.true. + + ! do we want to project to the upwind value from a point? + project_point = have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_point') + + ! do we want to project to the upwind value using the gradient? + project_grad = have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_gradient') + + ! do we want to use local values as the upwind value? + local = have_option(trim(upwind_value_path)//& + '/locally_bound_upwind_value') + + ! do we want to use pseudo-structured values as the upwind value? + structured = have_option(trim(upwind_value_path)//& + '/pseudo_structured_upwind_value') + + ! in case none (or both) selected default to family type selection + select case(element_family) + case (FAMILY_SIMPLEX) ! use projection except in 1d + if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then + if(dim==1) then + local = .true. + else + project_point = .true. + end if + end if + case (FAMILY_CUBE) ! use local + if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then + local=.true. + end if + case default + FLAbort('Illegal element family') + end select + + if(project_point) then + upwind_scheme = CV_UPWINDVALUE_PROJECT_POINT + else if(project_grad) then + upwind_scheme = CV_UPWINDVALUE_PROJECT_GRAD + else if(local) then + upwind_scheme = CV_UPWINDVALUE_LOCAL + else if(structured) then + upwind_scheme = CV_UPWINDVALUE_STRUCTURED + else + upwind_scheme = CV_UPWINDVALUE_NONE end if - case default - FLAbort('Illegal element family') - end select - - if(project_point) then - upwind_scheme = CV_UPWINDVALUE_PROJECT_POINT - else if(project_grad) then - upwind_scheme = CV_UPWINDVALUE_PROJECT_GRAD - else if(local) then - upwind_scheme = CV_UPWINDVALUE_LOCAL - else if(structured) then - upwind_scheme = CV_UPWINDVALUE_STRUCTURED - else - upwind_scheme = CV_UPWINDVALUE_NONE - end if - - end function cv_upwind_scheme + + end function cv_upwind_scheme end module cv_options diff --git a/femtools/CV_Shape_Functions.F90 b/femtools/CV_Shape_Functions.F90 index 469b18f4df..092e33f7f4 100644 --- a/femtools/CV_Shape_Functions.F90 +++ b/femtools/CV_Shape_Functions.F90 @@ -27,18 +27,18 @@ #include "fdebug.h" module cv_shape_functions - !!< Generate shape functions for elements of arbitrary polynomial degree. - use FLDebug - use shape_functions - use cv_faces, only: cv_faces_type - implicit none + !!< Generate shape functions for elements of arbitrary polynomial degree. + use FLDebug + use shape_functions + use cv_faces, only: cv_faces_type + implicit none - private - public :: make_cv_element_shape, make_cvbdy_element_shape + private + public :: make_cv_element_shape, make_cvbdy_element_shape contains - function make_cv_element_shape(cvfaces, parentshape, type, stat) result (shape) + function make_cv_element_shape(cvfaces, parentshape, type, stat) result (shape) type(element_type) :: shape @@ -60,14 +60,14 @@ function make_cv_element_shape(cvfaces, parentshape, type, stat) result (shape) if(present(stat)) stat = 0 if(present(type)) then - ltype = type + ltype = type else - ltype = ELEMENT_CONTROLVOLUME_SURFACE + ltype = ELEMENT_CONTROLVOLUME_SURFACE end if ! some useful numbers ngi = cvfaces%shape%ngi*cvfaces%faces - ! number of gauss points in parent element + ! number of gauss points in parent element loc = cvfaces%vertices ! vertices of parent element coords = cvfaces%coords ! number of canonical coordinates in parent element faces = cvfaces%faces ! number of faces @@ -82,95 +82,95 @@ function make_cv_element_shape(cvfaces, parentshape, type, stat) result (shape) allocate( dl(ngi, fdim, coords) ) do i = 1, coords - gi = 1 - do j = 1, faces - ! work out the parent quadrature using a face shape function - ! and the coordinates of the corners - quad%l(gi:gi+cvfaces%shape%ngi-1,i) = & - matmul(cvfaces%corners(j,i,:), & - cvfaces%shape%n(:,:)) - - do k = 1, fdim - ! at the same time may as well work out the transformation - ! matrix between the parent and face coordinates - dl(gi:gi+cvfaces%shape%ngi-1,k,i) = & - matmul(cvfaces%corners(j,i,:), & - cvfaces%shape%dn(:,:,k)) - end do - quad%weight(gi:gi+cvfaces%shape%ngi-1)= & - cvfaces%shape%quadrature%weight(:) - - gi = gi + cvfaces%shape%ngi - end do + gi = 1 + do j = 1, faces + ! work out the parent quadrature using a face shape function + ! and the coordinates of the corners + quad%l(gi:gi+cvfaces%shape%ngi-1,i) = & + matmul(cvfaces%corners(j,i,:), & + cvfaces%shape%n(:,:)) + + do k = 1, fdim + ! at the same time may as well work out the transformation + ! matrix between the parent and face coordinates + dl(gi:gi+cvfaces%shape%ngi-1,k,i) = & + matmul(cvfaces%corners(j,i,:), & + cvfaces%shape%dn(:,:,k)) + end do + quad%weight(gi:gi+cvfaces%shape%ngi-1)= & + cvfaces%shape%quadrature%weight(:) + + gi = gi + cvfaces%shape%ngi + end do end do select case(ltype) - case(ELEMENT_CONTROLVOLUME_SURFACE) + case(ELEMENT_CONTROLVOLUME_SURFACE) - ! create an element based on the parent quadrature - ! our final shape function will be almost identical but have a lower dimension of derivatives - ! evaluated across the faces - tempshape=make_element_shape(vertices=loc, dim=dim, & - degree=parentshape%degree, quad=quad, & - type=parentshape%numbering%type) + ! create an element based on the parent quadrature + ! our final shape function will be almost identical but have a lower dimension of derivatives + ! evaluated across the faces + tempshape=make_element_shape(vertices=loc, dim=dim, & + degree=parentshape%degree, quad=quad, & + type=parentshape%numbering%type) - ! start converting the lagrangian element into a control volume surface element - ! another useful number - nodes = tempshape%numbering%nodes - ! Get the local numbering of our element - ele_num=>find_element_numbering(loc, & - dim, parentshape%degree, type=parentshape%numbering%type) + ! start converting the lagrangian element into a control volume surface element + ! another useful number + nodes = tempshape%numbering%nodes + ! Get the local numbering of our element + ele_num=>find_element_numbering(loc, & + dim, parentshape%degree, type=parentshape%numbering%type) - if (.not.associated(ele_num)) then - if (present(stat)) then - stat=1 - return - else - FLAbort('Element numbering unavailable') - end if - end if + if (.not.associated(ele_num)) then + if (present(stat)) then + stat=1 + return + else + FLAbort('Element numbering unavailable') + end if + end if - call allocate(element=shape, ele_num=ele_num, ngi=ngi, type = ELEMENT_CONTROLVOLUME_SURFACE) + call allocate(element=shape, ele_num=ele_num, ngi=ngi, type = ELEMENT_CONTROLVOLUME_SURFACE) - shape%numbering=>ele_num + shape%numbering=>ele_num - shape%quadrature=quad - call incref(quad) + shape%quadrature=quad + call incref(quad) - shape%degree=parentshape%degree + shape%degree=parentshape%degree - shape%n = tempshape%n + shape%n = tempshape%n - ! construct the derivatives of the control volume surface shape function - ! by performing a change of variables on the lagrangian derivatives - do i = 1, nodes - do j = 1, ngi - ! here we throw away one of our co-ordinates if using simplex elements - shape%dn(i,j,:) = matmul(dl(j,:,1:dim), tempshape%dn(i,j,:)) - end do - end do + ! construct the derivatives of the control volume surface shape function + ! by performing a change of variables on the lagrangian derivatives + do i = 1, nodes + do j = 1, ngi + ! here we throw away one of our co-ordinates if using simplex elements + shape%dn(i,j,:) = matmul(dl(j,:,1:dim), tempshape%dn(i,j,:)) + end do + end do - call deallocate( tempshape ) + call deallocate( tempshape ) - case(ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + case(ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - ! create a lagrangian element based on the parent quadrature - shape=make_element_shape(vertices=loc, dim=dim, & - degree=parentshape%degree, quad=quad, & - type=parentshape%numbering%type) + ! create a lagrangian element based on the parent quadrature + shape=make_element_shape(vertices=loc, dim=dim, & + degree=parentshape%degree, quad=quad, & + type=parentshape%numbering%type) - case default + case default - FLAbort ('Unsupported control volume element type') + FLAbort ('Unsupported control volume element type') end select call deallocate( quad ) deallocate( dl ) - end function make_cv_element_shape + end function make_cv_element_shape - function make_cvbdy_element_shape(cvfaces, parentshape, type, stat) result (shape) + function make_cvbdy_element_shape(cvfaces, parentshape, type, stat) result (shape) type(element_type) :: shape @@ -192,14 +192,14 @@ function make_cvbdy_element_shape(cvfaces, parentshape, type, stat) result (shap if(present(stat)) stat = 0 if(present(type)) then - ltype = type + ltype = type else - ltype = ELEMENT_CONTROLVOLUME_SURFACE + ltype = ELEMENT_CONTROLVOLUME_SURFACE end if ! some useful numbers ngi = cvfaces%shape%ngi*cvfaces%sfaces - ! number of gauss points in parent element + ! number of gauss points in parent element loc = cvfaces%svertices ! vertices of parent element coords = cvfaces%scoords ! number of canonical coordinates in parent element faces = cvfaces%sfaces ! number of faces @@ -214,92 +214,92 @@ function make_cvbdy_element_shape(cvfaces, parentshape, type, stat) result (shap allocate( dl(ngi, fdim, coords) ) do i = 1, coords - gi = 1 - do j = 1, faces - ! work out the parent quadrature using a face shape function - ! and the coordinates of the corners - quad%l(gi:gi+cvfaces%shape%ngi-1,i) = & - matmul(cvfaces%scorners(j,i,:), & - cvfaces%shape%n(:,:)) - do k = 1, fdim - ! at the same time may as well work out the transformation - ! matrix between the parent and face coordinates - dl(gi:gi+cvfaces%shape%ngi-1,k,i) = & - matmul(cvfaces%scorners(j,i,:), & - cvfaces%shape%dn(:,:,k)) - end do - quad%weight(gi:gi+cvfaces%shape%ngi-1)= & - cvfaces%shape%quadrature%weight(:) - - gi = gi + cvfaces%shape%ngi - end do + gi = 1 + do j = 1, faces + ! work out the parent quadrature using a face shape function + ! and the coordinates of the corners + quad%l(gi:gi+cvfaces%shape%ngi-1,i) = & + matmul(cvfaces%scorners(j,i,:), & + cvfaces%shape%n(:,:)) + do k = 1, fdim + ! at the same time may as well work out the transformation + ! matrix between the parent and face coordinates + dl(gi:gi+cvfaces%shape%ngi-1,k,i) = & + matmul(cvfaces%scorners(j,i,:), & + cvfaces%shape%dn(:,:,k)) + end do + quad%weight(gi:gi+cvfaces%shape%ngi-1)= & + cvfaces%shape%quadrature%weight(:) + + gi = gi + cvfaces%shape%ngi + end do end do select case(ltype) - case(ELEMENT_CONTROLVOLUME_SURFACE) + case(ELEMENT_CONTROLVOLUME_SURFACE) - ! create an element based on the parent quadrature - ! our final shape function will be almost identical but have a lower dimension of derivatives - ! evaluated across the faces - tempshape=make_element_shape(vertices=loc, dim=dim, & - degree=parentshape%degree, quad=quad, & - type=parentshape%numbering%type) + ! create an element based on the parent quadrature + ! our final shape function will be almost identical but have a lower dimension of derivatives + ! evaluated across the faces + tempshape=make_element_shape(vertices=loc, dim=dim, & + degree=parentshape%degree, quad=quad, & + type=parentshape%numbering%type) - ! start converting the lagrangian element into a control volume surface element + ! start converting the lagrangian element into a control volume surface element - ! another useful number - nodes = tempshape%numbering%nodes - ! Get the local numbering of our element - ele_num=>find_element_numbering(loc, & - dim, parentshape%degree, type=parentshape%numbering%type) + ! another useful number + nodes = tempshape%numbering%nodes + ! Get the local numbering of our element + ele_num=>find_element_numbering(loc, & + dim, parentshape%degree, type=parentshape%numbering%type) - if (.not.associated(ele_num)) then - if (present(stat)) then - stat=1 - return - else - FLAbort('Element numbering unavailable') - end if - end if + if (.not.associated(ele_num)) then + if (present(stat)) then + stat=1 + return + else + FLAbort('Element numbering unavailable') + end if + end if - call allocate(element=shape, ele_num=ele_num, ngi=ngi, type=ELEMENT_CONTROLVOLUMEBDY_SURFACE) + call allocate(element=shape, ele_num=ele_num, ngi=ngi, type=ELEMENT_CONTROLVOLUMEBDY_SURFACE) - shape%numbering=>ele_num + shape%numbering=>ele_num - shape%quadrature=quad - call incref(quad) + shape%quadrature=quad + call incref(quad) - shape%degree=parentshape%degree + shape%degree=parentshape%degree - shape%n = tempshape%n + shape%n = tempshape%n - ! construct the derivatives of the control volume surface shape function - ! by performing a change of variables on the lagrangian derivatives - do i = 1, nodes - do j = 1, ngi - ! here we throw away one of our co-ordinates if using simplex elements - shape%dn(i,j,:) = matmul(dl(j,:,1:dim), tempshape%dn(i,j,:)) - end do - end do + ! construct the derivatives of the control volume surface shape function + ! by performing a change of variables on the lagrangian derivatives + do i = 1, nodes + do j = 1, ngi + ! here we throw away one of our co-ordinates if using simplex elements + shape%dn(i,j,:) = matmul(dl(j,:,1:dim), tempshape%dn(i,j,:)) + end do + end do - call deallocate( tempshape ) + call deallocate( tempshape ) - case(ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) + case(ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES) - ! create a lagrangian element based on the parent quadrature - shape=make_element_shape(vertices=loc, dim=dim, & - degree=parentshape%degree, quad=quad, & - type=parentshape%numbering%type) + ! create a lagrangian element based on the parent quadrature + shape=make_element_shape(vertices=loc, dim=dim, & + degree=parentshape%degree, quad=quad, & + type=parentshape%numbering%type) - case default + case default - FLAbort ('Unsupported control volume element type') + FLAbort ('Unsupported control volume element type') end select call deallocate( quad ) deallocate( dl ) - end function make_cvbdy_element_shape + end function make_cvbdy_element_shape end module cv_shape_functions diff --git a/femtools/CV_Upwind_Values.F90 b/femtools/CV_Upwind_Values.F90 index d81c883dd1..c7fb4d6f1f 100644 --- a/femtools/CV_Upwind_Values.F90 +++ b/femtools/CV_Upwind_Values.F90 @@ -26,458 +26,458 @@ ! USA #include "fdebug.h" module cv_upwind_values - !!< Module containing general tools for discretising Control Volume problems. - use fldebug - use vector_tools, only: norm2, cross_product, scalar_triple_product - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use quadrature - use element_numbering, only: FAMILY_SIMPLEX, FAMILY_CUBE - use elements - use spud - use sparse_tools - use cv_faces - use transform_elements, only: transform_cvsurf_facet_to_physical, transform_facet_to_physical - use fetools, only: INFINITY, shape_vector_rhs - use fields - use state_module - use cv_shape_functions, only: make_cvbdy_element_shape - use cvtools, only: complete_cv_field_path - use cv_options - use boundary_conditions, only: get_periodic_boundary_condition, & -get_entire_boundary_condition, & -get_boundary_condition_nodes - use field_derivatives, only: grad - - implicit none - - ! critical distance to project out of element - real, private, parameter :: c_distance=0.001 - real, private, parameter :: tolerance=tiny(0.0) - - interface find_upwind_values - module procedure find_upwind_values_single_state, find_upwind_values_multiple_states - end interface - - interface need_upwind_values - module procedure need_upwind_values_option_path, need_upwind_values_cv_options_type - end interface - - private - public :: need_upwind_values, & - find_upwind_values, & - calculate_boundary_normals, & - couple_upwind_values + !!< Module containing general tools for discretising Control Volume problems. + use fldebug + use vector_tools, only: norm2, cross_product, scalar_triple_product + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use quadrature + use element_numbering, only: FAMILY_SIMPLEX, FAMILY_CUBE + use elements + use spud + use sparse_tools + use cv_faces + use transform_elements, only: transform_cvsurf_facet_to_physical, transform_facet_to_physical + use fetools, only: INFINITY, shape_vector_rhs + use fields + use state_module + use cv_shape_functions, only: make_cvbdy_element_shape + use cvtools, only: complete_cv_field_path + use cv_options + use boundary_conditions, only: get_periodic_boundary_condition, & + get_entire_boundary_condition, & + get_boundary_condition_nodes + use field_derivatives, only: grad + + implicit none + + ! critical distance to project out of element + real, private, parameter :: c_distance=0.001 + real, private, parameter :: tolerance=tiny(0.0) + + interface find_upwind_values + module procedure find_upwind_values_single_state, find_upwind_values_multiple_states + end interface + + interface need_upwind_values + module procedure need_upwind_values_option_path, need_upwind_values_cv_options_type + end interface + + private + public :: need_upwind_values, & + find_upwind_values, & + calculate_boundary_normals, & + couple_upwind_values contains - logical function need_upwind_values_option_path(option_path) result (need_upwind_values) - ! This function checks whether a field with option_path requires the calculation of - ! upwind values its control volume spatial discretisation. - - character(len=*), intent(in) :: option_path - - - need_upwind_values = ((have_option(trim(complete_cv_field_path(option_path))//& - "/face_value[0]/limit_face_value")).or.& - (have_option(trim(complete_cv_field_path(option_path))//& - "/face_value::HyperC")).or.& - (have_option(trim(complete_cv_field_path(option_path))//& - "/face_value::UltraC")).or.& - (have_option(trim(complete_cv_field_path(option_path))//& - "/face_value::PotentialUltraC"))) - - end function need_upwind_values_option_path - - logical function need_upwind_values_cv_options_type(options) result (need_upwind_values) - ! This function checks whether a field with option_path requires the calculation of - ! upwind values its control volume spatial discretisation. - - type(cv_options_type), intent(in) :: options - - need_upwind_values = (options%limit_facevalue.or.& - (options%facevalue==CV_FACEVALUE_HYPERC).or.& - (options%facevalue==CV_FACEVALUE_ULTRAC).or.& - (options%facevalue==CV_FACEVALUE_POTENTIALULTRAC)) - - end function need_upwind_values_cv_options_type - - subroutine find_upwind_values_single_state(state, x_field, field, upwind_values, & - old_field, old_upwind_values, & - defer_deletion, option_path) - ! This subroutine wraps the various methods for calculating upwind values. - ! It returns a csr matrix (which must be allocated before) with the upwind - ! values for each node pair. - - ! bucket full of fields - type(state_type), intent(inout) :: state - ! the coordinates on a mesh similar (i.e. not the same when periodic) to the field - type(vector_field), intent(inout) :: x_field - ! the field and its previous timelevel that we're interested in - type(scalar_field), intent(inout) :: field, old_field - ! the matrices of upwind and old upwind values - type(csr_matrix), intent(inout) :: upwind_values, old_upwind_values - ! do we want to temporarily insert the upwind elements and quadrature matrices - ! into state so that other calls from this subroutine can use them? - logical, optional :: defer_deletion - ! for back compatibility pass in an option_path in case field is - ! locally wrapped or allocated - character(len=*), optional :: option_path - - type(state_type), dimension(1) :: states - - states = (/state/) - call find_upwind_values(states, x_field, field, upwind_values, & - old_field, old_upwind_values, & - defer_deletion=defer_deletion, option_path=option_path) - state = states(1) - - end subroutine find_upwind_values_single_state - - subroutine find_upwind_values_multiple_states(state, x_field, field, upwind_values, & - old_field, old_upwind_values, & - defer_deletion, option_path) - ! This subroutine wraps the various methods for calculating upwind values. - ! It returns a csr matrix (which must be allocated before) with the upwind - ! values for each node pair. - - ! bucket full of fields - type(state_type), dimension(:), intent(inout) :: state - ! the coordinates on a mesh similar (i.e. not the same when periodic) to the field - type(vector_field), intent(inout) :: x_field - ! the field and its previous timelevel that we're interested in - type(scalar_field), intent(inout) :: field, old_field - ! the matrices of upwind and old upwind values - type(csr_matrix), intent(inout) :: upwind_values, old_upwind_values - ! do we want to temporarily insert the upwind elements and quadrature matrices - ! into state so that other calls from this subroutine can use them? - logical, optional :: defer_deletion - ! for back compatibility pass in an option_path in case field is - ! locally wrapped or allocated - character(len=*), optional :: option_path - - ! a matrix containing the elements where the upwind values are projected from - type(csr_matrix), pointer :: upwind_elements - ! a matrix containing the quadrature within the elements where the - ! upwind values are projected from - type(block_csr_matrix), pointer :: upwind_quadrature - ! we will need the coordinates if we have to calculate upwind_elements - type(vector_field), pointer :: x - - ! logicals controlling the type of upwind value and whether we save them - logical :: project_point, project_grad, local, structured, l_defer_deletion, reflect, bound - ! success indicator - integer :: stat - ! a local option path for back compatibility - character(len=OPTION_PATH_LEN) :: l_option_path, spatial_discretisation_path, upwind_value_path - ! prefix upwind matrices that have been reflected off domain boundaries - character(len=FIELD_NAME_LEN) :: matrix_prefix - ! which node are we projecting from? - integer :: projection_node - - ewrite(1, *) "In find_upwind_values" - ewrite(2, *) "For field ", trim(field%name), " on sparsity from mesh ", trim(x_field%mesh%name) - - projection_node=0 ! initialise - - ! get the local option path - if(present(option_path)) then - l_option_path = option_path - else - l_option_path = trim(field%option_path) - end if - - spatial_discretisation_path = trim(complete_cv_field_path(l_option_path)) - - if(have_option(trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value")) then - upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value/limiter[0]" - else - upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]" - end if - - ! do we want to project to the upwind value from a point? - project_point = have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_point') - - ! do we want to project to the upwind value using the gradient? - project_grad = have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_gradient') - - ! do we want to use local values as the upwind value? - local = have_option(trim(upwind_value_path)//& - '/locally_bound_upwind_value') - - ! do we want to use pseudo-structured values as the upwind value? - structured = have_option(trim(upwind_value_path)//& - '/pseudo_structured_upwind_value') - - ! do we want to reflect the upwind values off the domain boundaries? - reflect = ((have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_point& - &/reflect_off_domain_boundaries')).or.& - (have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_gradient& - &/reflect_off_domain_boundaries'))) - ! do we want to bound the projected upwind values off those surrounding the upwind - ! element? - bound = ((have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_point& - &/bound_projected_value_locally')).or.& - (have_option(trim(upwind_value_path)//& - '/project_upwind_value_from_gradient& - &/bound_projected_value_locally'))) - - ! in case none (or both) selected default to family type selection - select case(field%mesh%shape%numbering%family) - case (FAMILY_SIMPLEX) ! use projection unless 1d - if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then - if(mesh_dim(field)==1) then - ewrite(2,*) "using simplex elements on a 1d mesh but haven't selected an upwind value method" - ewrite(2,*) 'defaulting to locally bound value' - local = .true. - else - ewrite(2,*) "using simplex elements but haven't selected an upwind value method" - ewrite(2,*) 'defaulting to projection from a point' - project_point = .true. - end if + logical function need_upwind_values_option_path(option_path) result (need_upwind_values) + ! This function checks whether a field with option_path requires the calculation of + ! upwind values its control volume spatial discretisation. + + character(len=*), intent(in) :: option_path + + + need_upwind_values = ((have_option(trim(complete_cv_field_path(option_path))//& + "/face_value[0]/limit_face_value")).or.& + (have_option(trim(complete_cv_field_path(option_path))//& + "/face_value::HyperC")).or.& + (have_option(trim(complete_cv_field_path(option_path))//& + "/face_value::UltraC")).or.& + (have_option(trim(complete_cv_field_path(option_path))//& + "/face_value::PotentialUltraC"))) + + end function need_upwind_values_option_path + + logical function need_upwind_values_cv_options_type(options) result (need_upwind_values) + ! This function checks whether a field with option_path requires the calculation of + ! upwind values its control volume spatial discretisation. + + type(cv_options_type), intent(in) :: options + + need_upwind_values = (options%limit_facevalue.or.& + (options%facevalue==CV_FACEVALUE_HYPERC).or.& + (options%facevalue==CV_FACEVALUE_ULTRAC).or.& + (options%facevalue==CV_FACEVALUE_POTENTIALULTRAC)) + + end function need_upwind_values_cv_options_type + + subroutine find_upwind_values_single_state(state, x_field, field, upwind_values, & + old_field, old_upwind_values, & + defer_deletion, option_path) + ! This subroutine wraps the various methods for calculating upwind values. + ! It returns a csr matrix (which must be allocated before) with the upwind + ! values for each node pair. + + ! bucket full of fields + type(state_type), intent(inout) :: state + ! the coordinates on a mesh similar (i.e. not the same when periodic) to the field + type(vector_field), intent(inout) :: x_field + ! the field and its previous timelevel that we're interested in + type(scalar_field), intent(inout) :: field, old_field + ! the matrices of upwind and old upwind values + type(csr_matrix), intent(inout) :: upwind_values, old_upwind_values + ! do we want to temporarily insert the upwind elements and quadrature matrices + ! into state so that other calls from this subroutine can use them? + logical, optional :: defer_deletion + ! for back compatibility pass in an option_path in case field is + ! locally wrapped or allocated + character(len=*), optional :: option_path + + type(state_type), dimension(1) :: states + + states = (/state/) + call find_upwind_values(states, x_field, field, upwind_values, & + old_field, old_upwind_values, & + defer_deletion=defer_deletion, option_path=option_path) + state = states(1) + + end subroutine find_upwind_values_single_state + + subroutine find_upwind_values_multiple_states(state, x_field, field, upwind_values, & + old_field, old_upwind_values, & + defer_deletion, option_path) + ! This subroutine wraps the various methods for calculating upwind values. + ! It returns a csr matrix (which must be allocated before) with the upwind + ! values for each node pair. + + ! bucket full of fields + type(state_type), dimension(:), intent(inout) :: state + ! the coordinates on a mesh similar (i.e. not the same when periodic) to the field + type(vector_field), intent(inout) :: x_field + ! the field and its previous timelevel that we're interested in + type(scalar_field), intent(inout) :: field, old_field + ! the matrices of upwind and old upwind values + type(csr_matrix), intent(inout) :: upwind_values, old_upwind_values + ! do we want to temporarily insert the upwind elements and quadrature matrices + ! into state so that other calls from this subroutine can use them? + logical, optional :: defer_deletion + ! for back compatibility pass in an option_path in case field is + ! locally wrapped or allocated + character(len=*), optional :: option_path + + ! a matrix containing the elements where the upwind values are projected from + type(csr_matrix), pointer :: upwind_elements + ! a matrix containing the quadrature within the elements where the + ! upwind values are projected from + type(block_csr_matrix), pointer :: upwind_quadrature + ! we will need the coordinates if we have to calculate upwind_elements + type(vector_field), pointer :: x + + ! logicals controlling the type of upwind value and whether we save them + logical :: project_point, project_grad, local, structured, l_defer_deletion, reflect, bound + ! success indicator + integer :: stat + ! a local option path for back compatibility + character(len=OPTION_PATH_LEN) :: l_option_path, spatial_discretisation_path, upwind_value_path + ! prefix upwind matrices that have been reflected off domain boundaries + character(len=FIELD_NAME_LEN) :: matrix_prefix + ! which node are we projecting from? + integer :: projection_node + + ewrite(1, *) "In find_upwind_values" + ewrite(2, *) "For field ", trim(field%name), " on sparsity from mesh ", trim(x_field%mesh%name) + + projection_node=0 ! initialise + + ! get the local option path + if(present(option_path)) then + l_option_path = option_path + else + l_option_path = trim(field%option_path) end if - case (FAMILY_CUBE) ! use local - if(project_point) then - FLExit("Not possible to project from a point on cube meshes") + + spatial_discretisation_path = trim(complete_cv_field_path(l_option_path)) + + if(have_option(trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value")) then + upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]/limit_face_value/limiter[0]" + else + upwind_value_path = trim(spatial_discretisation_path)//"/face_value[0]" end if - if(project_grad.and.bound) then - FLExit("Not possible to bound locally on cube meshes") + + ! do we want to project to the upwind value from a point? + project_point = have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_point') + + ! do we want to project to the upwind value using the gradient? + project_grad = have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_gradient') + + ! do we want to use local values as the upwind value? + local = have_option(trim(upwind_value_path)//& + '/locally_bound_upwind_value') + + ! do we want to use pseudo-structured values as the upwind value? + structured = have_option(trim(upwind_value_path)//& + '/pseudo_structured_upwind_value') + + ! do we want to reflect the upwind values off the domain boundaries? + reflect = ((have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_point& + &/reflect_off_domain_boundaries')).or.& + (have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_gradient& + &/reflect_off_domain_boundaries'))) + ! do we want to bound the projected upwind values off those surrounding the upwind + ! element? + bound = ((have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_point& + &/bound_projected_value_locally')).or.& + (have_option(trim(upwind_value_path)//& + '/project_upwind_value_from_gradient& + &/bound_projected_value_locally'))) + + ! in case none (or both) selected default to family type selection + select case(field%mesh%shape%numbering%family) + case (FAMILY_SIMPLEX) ! use projection unless 1d + if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then + if(mesh_dim(field)==1) then + ewrite(2,*) "using simplex elements on a 1d mesh but haven't selected an upwind value method" + ewrite(2,*) 'defaulting to locally bound value' + local = .true. + else + ewrite(2,*) "using simplex elements but haven't selected an upwind value method" + ewrite(2,*) 'defaulting to projection from a point' + project_point = .true. + end if + end if + case (FAMILY_CUBE) ! use local + if(project_point) then + FLExit("Not possible to project from a point on cube meshes") + end if + if(project_grad.and.bound) then + FLExit("Not possible to bound locally on cube meshes") + end if + if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then + ewrite(2,*) "using cube elements but haven't selected an upwind value method" + ewrite(2,*) "defaulting to a locally bound value" + local=.true. + end if + case default + ! most likely a code error + FLAbort('Illegal element family') + end select + + ! do we want to defer the deletion of the matrices + if(present(defer_deletion)) then + l_defer_deletion=defer_deletion + else + l_defer_deletion=.false. end if - if((.not.project_point).and.(.not.local).and.(.not.project_grad).and.(.not.structured)) then - ewrite(2,*) "using cube elements but haven't selected an upwind value method" - ewrite(2,*) "defaulting to a locally bound value" - local=.true. + + ! prefix the matrix name if reflected + matrix_prefix = "" + if(reflect) then + matrix_prefix="Reflected" end if - case default - ! most likely a code error - FLAbort('Illegal element family') - end select - - ! do we want to defer the deletion of the matrices - if(present(defer_deletion)) then - l_defer_deletion=defer_deletion - else - l_defer_deletion=.false. - end if - - ! prefix the matrix name if reflected - matrix_prefix = "" - if(reflect) then - matrix_prefix="Reflected" - end if - - select case(field%field_type) - case (FIELD_TYPE_CONSTANT) - - ! constant fields are really easy... just set all the upwind values to the constant value - call calculate_upwind_values_constant(field, upwind_values, & - old_field, old_upwind_values) - - case default - ! do we want to project from a point? - if(project_point) then - - upwind_elements=>extract_csr_matrix(state, & - trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements", stat) - if(stat==0) then - ! element matrix in state - - upwind_quadrature=>extract_block_csr_matrix(state, & - trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindQuadrature", stat) - if(stat==0) then - ! both matrices in state - - call calculate_upwind_values_project(upwind_elements, upwind_quadrature, x_field, & - field, upwind_values, old_field, old_upwind_values, & - bound) - - else - ! no quadrature matrix in state - - x=>extract_vector_field(state(1), "Coordinate") - - if (l_defer_deletion.or.& - have_option(trim(upwind_value_path)//"/project_upwind_value_from_point& - &/store_upwind_elements/store_upwind_quadrature")) then - ! we want to save the quadrature matrix + select case(field%field_type) + case (FIELD_TYPE_CONSTANT) - allocate(upwind_quadrature) - call allocate(upwind_quadrature, upwind_values%sparsity, & - (/1, field%mesh%shape%loc/), & - name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindQuadrature") + ! constant fields are really easy... just set all the upwind values to the constant value + call calculate_upwind_values_constant(field, upwind_values, & + old_field, old_upwind_values) - call calculate_upwind_quadrature_project(x,x_field,upwind_elements, & - upwind_quadrature=upwind_quadrature, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound) + case default + ! do we want to project from a point? + if(project_point) then - call insert(state, upwind_quadrature, trim(upwind_quadrature%name)) + upwind_elements=>extract_csr_matrix(state, & + trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements", stat) + if(stat==0) then + ! element matrix in state - call deallocate(upwind_quadrature) - deallocate(upwind_quadrature) + upwind_quadrature=>extract_block_csr_matrix(state, & + trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindQuadrature", stat) + if(stat==0) then + ! both matrices in state - else - ! don't even calculate the quadrature matrix + call calculate_upwind_values_project(upwind_elements, upwind_quadrature, x_field, & + field, upwind_values, old_field, old_upwind_values, & + bound) - call calculate_upwind_quadrature_project(x,x_field,upwind_elements, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound) + else + ! no quadrature matrix in state - end if - end if - else - ! no element matrix in state, may as well make both now + x=>extract_vector_field(state(1), "Coordinate") - x=>extract_vector_field(state(1), "Coordinate") + if (l_defer_deletion.or.& + have_option(trim(upwind_value_path)//"/project_upwind_value_from_point& + &/store_upwind_elements/store_upwind_quadrature")) then + ! we want to save the quadrature matrix - if (l_defer_deletion.or.& - have_option(trim(upwind_value_path)//"/project_upwind_value_from_point& - &/store_upwind_elements")) then - ! we want to save the element matrix - allocate(upwind_elements) - call allocate(upwind_elements, upwind_values%sparsity, & - type=CSR_INTEGER, & - name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements") + allocate(upwind_quadrature) + call allocate(upwind_quadrature, upwind_values%sparsity, & + (/1, field%mesh%shape%loc/), & + name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindQuadrature") - if (l_defer_deletion.or.& - have_option(trim(upwind_value_path)//"/project_upwind_value_from_point& - &/store_upwind_elements/store_upwind_quadrature")) then - ! we want to save both matrices + call calculate_upwind_quadrature_project(x,x_field,upwind_elements, & + upwind_quadrature=upwind_quadrature, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound) - allocate(upwind_quadrature) - call allocate(upwind_quadrature, upwind_values%sparsity, & - (/1, field%mesh%shape%loc/), & - name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindQuadrature") + call insert(state, upwind_quadrature, trim(upwind_quadrature%name)) - call calculate_all_upwind_project(x, x_field, upwind_elements=upwind_elements, & - upwind_quadrature=upwind_quadrature, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound) + call deallocate(upwind_quadrature) + deallocate(upwind_quadrature) - call insert(state, upwind_quadrature, trim(upwind_quadrature%name)) + else + ! don't even calculate the quadrature matrix - call deallocate(upwind_quadrature) - deallocate(upwind_quadrature) + call calculate_upwind_quadrature_project(x,x_field,upwind_elements, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound) - else - ! we want to save the element matrix but not the quadrature + end if + end if + else + ! no element matrix in state, may as well make both now - call calculate_all_upwind_project(x, x_field, upwind_elements=upwind_elements, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound) + x=>extract_vector_field(state(1), "Coordinate") - end if + if (l_defer_deletion.or.& + have_option(trim(upwind_value_path)//"/project_upwind_value_from_point& + &/store_upwind_elements")) then + ! we want to save the element matrix - call insert(state, upwind_elements, trim(upwind_elements%name)) + allocate(upwind_elements) + call allocate(upwind_elements, upwind_values%sparsity, & + type=CSR_INTEGER, & + name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements") - call deallocate(upwind_elements) - deallocate(upwind_elements) + if (l_defer_deletion.or.& + have_option(trim(upwind_value_path)//"/project_upwind_value_from_point& + &/store_upwind_elements/store_upwind_quadrature")) then + ! we want to save both matrices - else - ! we don't want anything but the values + allocate(upwind_quadrature) + call allocate(upwind_quadrature, upwind_values%sparsity, & + (/1, field%mesh%shape%loc/), & + name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindQuadrature") - call calculate_all_upwind_project(x, x_field, field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound) + call calculate_all_upwind_project(x, x_field, upwind_elements=upwind_elements, & + upwind_quadrature=upwind_quadrature, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound) - end if + call insert(state, upwind_quadrature, trim(upwind_quadrature%name)) - end if + call deallocate(upwind_quadrature) + deallocate(upwind_quadrature) - ! we don't want to project from a point, shall we use the gradient instead? - else if(project_grad) then + else + ! we want to save the element matrix but not the quadrature - projection_node=cv_projection_node(trim(l_option_path)) - x=>extract_vector_field(state(1), "Coordinate") + call calculate_all_upwind_project(x, x_field, upwind_elements=upwind_elements, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound) - if(bound) then - ! we need to know about upwind_elements so we can bound... do we have them in state? - upwind_elements=>extract_csr_matrix(state, & - trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements", stat) - if(stat==0) then - ! element matrix in state - call calculate_upwind_values_project_grad(x, x_field, upwind_elements=upwind_elements, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound, projection_node=projection_node) + end if - else - ! no element matrix in state... do we want to save it for next time? - if (l_defer_deletion.or.& - have_option(trim(upwind_value_path)//"/project_upwind_value_from_gradient& - &/bound_projected_value_locally/store_upwind_elements")) then - ! yes - allocate(upwind_elements) - call allocate(upwind_elements, upwind_values%sparsity, & - type=CSR_INTEGER, & - name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements") + call insert(state, upwind_elements, trim(upwind_elements%name)) - call calculate_all_upwind_project_grad(x, x_field, upwind_elements=upwind_elements, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound, projection_node=projection_node) + call deallocate(upwind_elements) + deallocate(upwind_elements) - call insert(state, upwind_elements, trim(upwind_elements%name)) + else + ! we don't want anything but the values - call deallocate(upwind_elements) - deallocate(upwind_elements) + call calculate_all_upwind_project(x, x_field, field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound) - else - ! no - call calculate_all_upwind_project_grad(x, x_field, & - field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound, projection_node=projection_node) + end if end if - end if - else + ! we don't want to project from a point, shall we use the gradient instead? + else if(project_grad) then + + projection_node=cv_projection_node(trim(l_option_path)) + x=>extract_vector_field(state(1), "Coordinate") + + if(bound) then + ! we need to know about upwind_elements so we can bound... do we have them in state? + upwind_elements=>extract_csr_matrix(state, & + trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements", stat) + if(stat==0) then + ! element matrix in state + call calculate_upwind_values_project_grad(x, x_field, upwind_elements=upwind_elements, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound, projection_node=projection_node) + + else + ! no element matrix in state... do we want to save it for next time? + if (l_defer_deletion.or.& + have_option(trim(upwind_value_path)//"/project_upwind_value_from_gradient& + &/bound_projected_value_locally/store_upwind_elements")) then + ! yes + allocate(upwind_elements) + call allocate(upwind_elements, upwind_values%sparsity, & + type=CSR_INTEGER, & + name=trim(matrix_prefix)//trim(field%mesh%name)//"CVUpwindElements") + + call calculate_all_upwind_project_grad(x, x_field, upwind_elements=upwind_elements, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound, projection_node=projection_node) + + call insert(state, upwind_elements, trim(upwind_elements%name)) + + call deallocate(upwind_elements) + deallocate(upwind_elements) + + else + ! no + call calculate_all_upwind_project_grad(x, x_field, & + field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound, projection_node=projection_node) + + end if + end if - ! we're not bounding so there's no need to worry about upwind_elements - call calculate_all_upwind_project_grad(x, x_field, field=field, upwind_values=upwind_values, & - old_field=old_field, old_upwind_values=old_upwind_values, & - reflect=reflect, bound=bound, projection_node=projection_node) + else - end if + ! we're not bounding so there's no need to worry about upwind_elements + call calculate_all_upwind_project_grad(x, x_field, field=field, upwind_values=upwind_values, & + old_field=old_field, old_upwind_values=old_upwind_values, & + reflect=reflect, bound=bound, projection_node=projection_node) - ! ok, we don't want to project at all, so do we want to use local values? - else if(local) then + end if - call calculate_upwind_values_local(field, upwind_values, old_field, old_upwind_values) + ! ok, we don't want to project at all, so do we want to use local values? + else if(local) then - ! a completely new way... let's try pseudo-structured - else if(structured) then + call calculate_upwind_values_local(field, upwind_values, old_field, old_upwind_values) - call calculate_upwind_values_structured(x_field, field, upwind_values, & - old_field, old_upwind_values) + ! a completely new way... let's try pseudo-structured + else if(structured) then - ! no, um, something's gone wrong here then! - else + call calculate_upwind_values_structured(x_field, field, upwind_values, & + old_field, old_upwind_values) - ! most likely a developer issue as new options are added out of sync with code - FLAbort("Unknown upwind value calculation method.") + ! no, um, something's gone wrong here then! + else - end if + ! most likely a developer issue as new options are added out of sync with code + FLAbort("Unknown upwind value calculation method.") + + end if - end select + end select - ewrite(1, *) "Exiting find_upwind_values" + ewrite(1, *) "Exiting find_upwind_values" - end subroutine find_upwind_values_multiple_states + end subroutine find_upwind_values_multiple_states - subroutine calculate_upwind_values_constant(field, upwind_values, & - old_field, old_upwind_values) + subroutine calculate_upwind_values_constant(field, upwind_values, & + old_field, old_upwind_values) ! just set the upwind values to the constant field values ! should only be called for FIELD_TYPE_CONSTANT fields @@ -490,405 +490,405 @@ subroutine calculate_upwind_values_constant(field, upwind_values, & end subroutine calculate_upwind_values_constant - subroutine calculate_all_upwind_project(x, x_field, upwind_elements, upwind_quadrature, & - field, upwind_values, old_field, old_upwind_values, & - reflect, bound) - - ! project from a node pair to an upwind value when we have no information available at - ! all... i.e. we need to calculate which element the upwind value is in, then we need to - ! work out its quadrature, then we need to actually find the value and possibly bound it. - - ! coordinates - type(vector_field), intent(inout) :: x, x_field - - type(csr_matrix), intent(inout), optional :: upwind_elements - type(block_csr_matrix), intent(inout), optional :: upwind_quadrature - - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: old_field - type(csr_matrix), intent(inout) :: upwind_values - type(csr_matrix), intent(inout) :: old_upwind_values - logical, intent(in) :: reflect, bound - - ! local memory: - ! allocatable memory - integer, dimension(:), pointer :: nodes, eles, x_eles - ! loop integers - integer :: i, j, k, ele, l_ele, dim, local_coord, i_field - - ! the coordinates of a pt just upwind of the node pair - real, dimension(mesh_dim(field)) :: xc, xc_vector - ! element node coordinates - ! we only consider the vertices coordinates if higher order - real, dimension(mesh_dim(x), x%mesh%shape%numbering%vertices) :: x_ele - integer, dimension(x%mesh%shape%numbering%vertices):: vertices - integer, dimension(:), pointer :: x_nodes - real, dimension(mesh_dim(x_field), ele_loc(x_field, 1)) :: x_field_ele - ! simplex volume coordinates - real, dimension(field%mesh%shape%quadrature%vertices) :: coords, l_coords - ! element field node values - real, dimension(field%mesh%shape%loc) :: field_ele - ! the global node numbers of an element - integer, dimension(:), pointer :: field_nodes - ! the upwind value - real :: upwind_value - - real, dimension(field%mesh%shape%loc) :: l_shape - - ! a vector field of normals if we're reflecting - type(vector_field) :: normals - ! a logical list saying which nodes are on the boundary - logical, dimension(:), allocatable :: on_boundary - ! which bc are on which nodes - integer, dimension(:), allocatable :: field_bc_type - - logical :: upwind_elements_present, upwind_quadrature_present - - integer :: save_pos=0 ! saves the position in the matrix for optimisation - - ewrite(1, *) "In calculate_all_upwind_project" - ! the projected point values upwind value matrix is on the x_field mesh - ! which cannot be periodic - - upwind_elements_present=.false. - upwind_quadrature_present=.false. - - ! zero everything we have - call zero(upwind_values) - call zero(old_upwind_values) - if(present(upwind_elements)) then - call zero(upwind_elements) - upwind_elements_present=.true. - end if - if(present(upwind_quadrature)) then - call zero(upwind_quadrature) - upwind_quadrature_present=.true. - end if - - call allocate(normals, mesh_dim(x_field), x_field%mesh, name="NormalsToBoundary") - call zero(normals) - allocate(on_boundary(node_count(x_field))) - on_boundary=.false. - if(reflect) then - ! work out what the domain normals are - call calculate_boundary_normals(field%mesh, x, & - normals, on_boundary) - end if - - allocate(field_bc_type(node_count(field))) - field_bc_type = 0 - ! create the node to element list - call add_nelist(x_field%mesh) - if(mesh_periodic(field)) then - call add_nelist(field%mesh) - call get_boundary_condition_nodes(field, (/"internal"/), field_bc_type) - end if - - dim = mesh_dim(field) - if((dim/=1).and.(dim/=2).and.(dim/=3)) then - FLExit("Unsupported control volume dimension.") - end if - - ! loop over the nodes - do i = 1, size(upwind_values,1) - ! find the neighbouring nodes using the matrix sparsity (of the unperiodic coordinate mesh!) - ! FIXME: the matrix sparsity is not the same as the mesh connectivity for - ! cube meshes! - ! (not very important for projection as it only works on simplex meshes) - nodes => row_m_ptr(upwind_values, i) - if (size(nodes) == 0) cycle - ! find the neighbouring elements using the node to element list - x_eles => node_neigh(x_field, i) + subroutine calculate_all_upwind_project(x, x_field, upwind_elements, upwind_quadrature, & + field, upwind_values, old_field, old_upwind_values, & + reflect, bound) + + ! project from a node pair to an upwind value when we have no information available at + ! all... i.e. we need to calculate which element the upwind value is in, then we need to + ! work out its quadrature, then we need to actually find the value and possibly bound it. + + ! coordinates + type(vector_field), intent(inout) :: x, x_field + + type(csr_matrix), intent(inout), optional :: upwind_elements + type(block_csr_matrix), intent(inout), optional :: upwind_quadrature + + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: old_field + type(csr_matrix), intent(inout) :: upwind_values + type(csr_matrix), intent(inout) :: old_upwind_values + logical, intent(in) :: reflect, bound + + ! local memory: + ! allocatable memory + integer, dimension(:), pointer :: nodes, eles, x_eles + ! loop integers + integer :: i, j, k, ele, l_ele, dim, local_coord, i_field + + ! the coordinates of a pt just upwind of the node pair + real, dimension(mesh_dim(field)) :: xc, xc_vector + ! element node coordinates + ! we only consider the vertices coordinates if higher order + real, dimension(mesh_dim(x), x%mesh%shape%numbering%vertices) :: x_ele + integer, dimension(x%mesh%shape%numbering%vertices):: vertices + integer, dimension(:), pointer :: x_nodes + real, dimension(mesh_dim(x_field), ele_loc(x_field, 1)) :: x_field_ele + ! simplex volume coordinates + real, dimension(field%mesh%shape%quadrature%vertices) :: coords, l_coords + ! element field node values + real, dimension(field%mesh%shape%loc) :: field_ele + ! the global node numbers of an element + integer, dimension(:), pointer :: field_nodes + ! the upwind value + real :: upwind_value + + real, dimension(field%mesh%shape%loc) :: l_shape + + ! a vector field of normals if we're reflecting + type(vector_field) :: normals + ! a logical list saying which nodes are on the boundary + logical, dimension(:), allocatable :: on_boundary + ! which bc are on which nodes + integer, dimension(:), allocatable :: field_bc_type + + logical :: upwind_elements_present, upwind_quadrature_present + + integer :: save_pos=0 ! saves the position in the matrix for optimisation + + ewrite(1, *) "In calculate_all_upwind_project" + ! the projected point values upwind value matrix is on the x_field mesh + ! which cannot be periodic + + upwind_elements_present=.false. + upwind_quadrature_present=.false. + + ! zero everything we have + call zero(upwind_values) + call zero(old_upwind_values) + if(present(upwind_elements)) then + call zero(upwind_elements) + upwind_elements_present=.true. + end if + if(present(upwind_quadrature)) then + call zero(upwind_quadrature) + upwind_quadrature_present=.true. + end if + + call allocate(normals, mesh_dim(x_field), x_field%mesh, name="NormalsToBoundary") + call zero(normals) + allocate(on_boundary(node_count(x_field))) + on_boundary=.false. + if(reflect) then + ! work out what the domain normals are + call calculate_boundary_normals(field%mesh, x, & + normals, on_boundary) + end if + + allocate(field_bc_type(node_count(field))) + field_bc_type = 0 + ! create the node to element list + call add_nelist(x_field%mesh) if(mesh_periodic(field)) then - local_coord = local_coords(x_field, x_eles(1), i) - field_nodes=>ele_nodes(field, x_eles(1)) - i_field = field_nodes(local_coord) - eles => node_neigh(field, i_field) - else - i_field = i - eles => x_eles + call add_nelist(field%mesh) + call get_boundary_condition_nodes(field, (/"internal"/), field_bc_type) end if - ! loop over the neighbouring nodes - do j = 1, size(nodes) - if(nodes(j)==i) cycle ! skip the node that's the same as the i node - - ! find the vector connecting to the point just upwind of the node pair - ! (also deals with reflection) - xc_vector=project_upwind(i, nodes(j), x_field, & - on_boundary, normals) - - if(field_bc_type(i_field)==0) then - xc = node_val(x_field, i) + xc_vector - end if - - l_coords = infinity - l_ele = eles(1) - - ! loop over neighbouring elements working out which one contains - ! (or nearly contains) xc - do k = 1, size(eles) - ele = eles(k) - if(x%mesh%shape%degree == 1) then - x_ele = ele_val(x, ele) - else - ! only extract the coordinates of the vertices in this case - x_nodes => ele_nodes(x, ele) - vertices = local_vertices(x%mesh%shape%numbering) - x_ele = node_val(x, x_nodes(vertices)) - end if - - if(field_bc_type(i_field)==1) then - ! find the local node number so we can add the vector - ! pointing at the upwind point to the coordinates at - ! that node - ! (this is done this way in case we're periodic and on - ! a boundary) - x_field_ele=ele_val(x_field, ele) - local_coord = local_coords(field, ele, i_field) - xc = x_field_ele(:,local_coord) + xc_vector - end if - - select case(dim) - case(2) - coords=calculate_area_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele - case(3) - coords=calculate_volume_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele - end select - - if(sum(coords) row_m_ptr(upwind_values, i) + if (size(nodes) == 0) cycle + ! find the neighbouring elements using the node to element list + x_eles => node_neigh(x_field, i) + if(mesh_periodic(field)) then + local_coord = local_coords(x_field, x_eles(1), i) + field_nodes=>ele_nodes(field, x_eles(1)) + i_field = field_nodes(local_coord) + eles => node_neigh(field, i_field) + else + i_field = i + eles => x_eles + end if + ! loop over the neighbouring nodes + do j = 1, size(nodes) + if(nodes(j)==i) cycle ! skip the node that's the same as the i node + + ! find the vector connecting to the point just upwind of the node pair + ! (also deals with reflection) + xc_vector=project_upwind(i, nodes(j), x_field, & + on_boundary, normals) + + if(field_bc_type(i_field)==0) then + xc = node_val(x_field, i) + xc_vector + end if + + l_coords = infinity + l_ele = eles(1) + + ! loop over neighbouring elements working out which one contains + ! (or nearly contains) xc + do k = 1, size(eles) + ele = eles(k) + if(x%mesh%shape%degree == 1) then + x_ele = ele_val(x, ele) + else + ! only extract the coordinates of the vertices in this case + x_nodes => ele_nodes(x, ele) + vertices = local_vertices(x%mesh%shape%numbering) + x_ele = node_val(x, x_nodes(vertices)) + end if + + if(field_bc_type(i_field)==1) then + ! find the local node number so we can add the vector + ! pointing at the upwind point to the coordinates at + ! that node + ! (this is done this way in case we're periodic and on + ! a boundary) + x_field_ele=ele_val(x_field, ele) + local_coord = local_coords(field, ele, i_field) + xc = x_field_ele(:,local_coord) + xc_vector + end if + + select case(dim) + case(2) + coords=calculate_area_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele + case(3) + coords=calculate_volume_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele + end select + + if(sum(coords) row_m_ptr(upwind_values, i) - - if(mesh_periodic(field)) then - x_eles=>node_neigh(x_field, i) - local_coord = local_coords(x_field, x_eles(1), i) - field_nodes=>ele_nodes(field, x_eles(1)) - i_field = field_nodes(local_coord) - else - i_field = i - end if - do j = 1, size(nodes) - if(nodes(j)==i) cycle - - ! find the vector connecting to the point just upwind of the node pair - ! (also deals with reflection) - xc_vector=project_upwind(i, nodes(j), x_field, & - on_boundary, normals) - - l_ele=ival(upwind_elements,i,nodes(j)) - if(x%mesh%shape%degree == 1) then - x_ele = ele_val(x, l_ele) - else - ! only extract the coordinates of the vertices in this case - x_nodes => ele_nodes(x, l_ele) - vertices = local_vertices(x%mesh%shape%numbering) - x_ele = node_val(x, x_nodes(vertices)) - end if - - if(field_bc_type(i_field)==1) then - ! find the local node number so we can add the vector - ! pointing at the upwind point to the coordinates at - ! that node - ! (this is done this way in case we're periodic and on - ! a boundary) - x_field_ele=ele_val(x_field, l_ele) - local_coord = local_coords(field, l_ele, i_field) - xc = x_field_ele(:,local_coord) + xc_vector - else - xc = node_val(x_field, i) + xc_vector - end if - - select case(dim) - case(2) - l_coords=calculate_area_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele - case(3) - l_coords=calculate_volume_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele - end select - - do k = 1, size(l_coords) - l_coords(k) = max(0.0, l_coords(k)) - end do - l_coords = l_coords/sum(l_coords) - - l_shape = eval_shape(field%mesh%shape, l_coords) - - if(upwind_quadrature_present) then - do k = 1, size(l_shape) - call set(upwind_quadrature, 1, k, i, nodes(j), l_shape(k), save_pos=save_pos) - end do - end if - - field_ele=ele_val(field, l_ele) - upwind_value=dot_product(l_shape,field_ele) - upwind_value=node_val(field, i_field) + (1./c_distance)*(upwind_value-node_val(field, i_field)) - if(bound) then - upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) - end if - call set(upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) - - field_ele=ele_val(old_field, l_ele) - upwind_value=dot_product(l_shape,field_ele) - upwind_value=node_val(old_field, i_field) + (1./c_distance)*(upwind_value-node_val(old_field, i_field)) - if(bound) then - upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) - end if - call set(old_upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) - - end do - end do - - call deallocate(normals) - deallocate(field_bc_type) - - end subroutine calculate_upwind_quadrature_project - - subroutine calculate_upwind_values_project(upwind_elements, upwind_quadrature, x_field, & - field, upwind_values, & - old_field, old_upwind_values, & - bound) + + call deallocate(normals) + deallocate(field_bc_type) + + ewrite(1, *) "Exiting calculate_all_upwind_project" + + end subroutine calculate_all_upwind_project + + subroutine calculate_upwind_quadrature_project(x,x_field,upwind_elements, upwind_quadrature, & + field, upwind_values, old_field, old_upwind_values, & + reflect, bound) + ! project from a node pair to an upwind value when we have the upwind_elements available + ! ... i.e. we need to work out each elements its quadrature, then we need to actually + ! find the value and possibly bound it. + + ! coordinates + type(vector_field), intent(inout) :: x, x_field + type(csr_matrix), intent(in) :: upwind_elements + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: old_field + type(csr_matrix), intent(inout) :: upwind_values + type(csr_matrix), intent(inout) :: old_upwind_values + + type(block_csr_matrix), intent(inout), optional :: upwind_quadrature + logical, intent(in) :: reflect, bound + + ! local memory: + ! integer loops + integer :: i, j, k, l_ele, dim, local_coord, i_field + ! allocatable memory + integer, dimension(:), pointer :: nodes, x_eles + + ! the coordinates of a pt just upwind of the node pair + real, dimension(x%dim) :: xc, xc_vector + ! we only consider the vertices coordinates if higher order + real, dimension(mesh_dim(x), x%mesh%shape%numbering%vertices) :: x_ele + integer, dimension(x%mesh%shape%numbering%vertices):: vertices + integer, dimension(:), pointer :: x_nodes + real, dimension(x_field%dim, ele_loc(x_field, 1)) :: x_field_ele + real, dimension(field%mesh%shape%quadrature%vertices) :: l_coords + real, dimension(field%mesh%shape%loc) :: field_ele + integer, dimension(:), pointer :: field_nodes + real :: upwind_value + + real, dimension(field%mesh%shape%loc) :: l_shape + + type(vector_field) :: normals + logical, dimension(:), allocatable :: on_boundary + ! which bc are on which nodes + integer, dimension(:), allocatable :: field_bc_type + + logical :: upwind_quadrature_present + + integer :: save_pos=0 ! saves the position in the matrix for optimisation + + ewrite(2,*) 'in calculate_upwind_quadrature_project' + ! the projected point values upwind value matrix is on the x_field mesh + ! which cannot be periodic + + upwind_quadrature_present=.false. + + ! zero everything we have + call zero(upwind_values) + call zero(old_upwind_values) + if(present(upwind_quadrature)) then + call zero(upwind_quadrature) + upwind_quadrature_present=.true. + end if + + dim = mesh_dim(field) + if((dim/=1).and.(dim/=2).and.(dim/=3)) then + FLExit("Unsupported control volume dimension.") + end if + + call allocate(normals, mesh_dim(x_field), x_field%mesh, name="NormalsToBoundary") + call zero(normals) + allocate(on_boundary(node_count(x_field))) + on_boundary=.false. + if(reflect) then + call calculate_boundary_normals(field%mesh, x, & + normals, on_boundary) + end if + + allocate(field_bc_type(node_count(field))) + field_bc_type = 0 + if(mesh_periodic(field)) then + call add_nelist(x_field%mesh) + call get_boundary_condition_nodes(field, (/"internal"/), field_bc_type) + end if + + do i = 1, size(upwind_values, 1) + ! find the neighbouring nodes using the matrix sparsity of the unperiodic mesh + ! FIXME: the matrix sparsity is not the same as the mesh connectivity for + ! cube meshes! + ! (not very important for projection as it only works on simplex meshes) + nodes => row_m_ptr(upwind_values, i) + + if(mesh_periodic(field)) then + x_eles=>node_neigh(x_field, i) + local_coord = local_coords(x_field, x_eles(1), i) + field_nodes=>ele_nodes(field, x_eles(1)) + i_field = field_nodes(local_coord) + else + i_field = i + end if + do j = 1, size(nodes) + if(nodes(j)==i) cycle + + ! find the vector connecting to the point just upwind of the node pair + ! (also deals with reflection) + xc_vector=project_upwind(i, nodes(j), x_field, & + on_boundary, normals) + + l_ele=ival(upwind_elements,i,nodes(j)) + if(x%mesh%shape%degree == 1) then + x_ele = ele_val(x, l_ele) + else + ! only extract the coordinates of the vertices in this case + x_nodes => ele_nodes(x, l_ele) + vertices = local_vertices(x%mesh%shape%numbering) + x_ele = node_val(x, x_nodes(vertices)) + end if + + if(field_bc_type(i_field)==1) then + ! find the local node number so we can add the vector + ! pointing at the upwind point to the coordinates at + ! that node + ! (this is done this way in case we're periodic and on + ! a boundary) + x_field_ele=ele_val(x_field, l_ele) + local_coord = local_coords(field, l_ele, i_field) + xc = x_field_ele(:,local_coord) + xc_vector + else + xc = node_val(x_field, i) + xc_vector + end if + + select case(dim) + case(2) + l_coords=calculate_area_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele + case(3) + l_coords=calculate_volume_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele + end select + + do k = 1, size(l_coords) + l_coords(k) = max(0.0, l_coords(k)) + end do + l_coords = l_coords/sum(l_coords) + + l_shape = eval_shape(field%mesh%shape, l_coords) + + if(upwind_quadrature_present) then + do k = 1, size(l_shape) + call set(upwind_quadrature, 1, k, i, nodes(j), l_shape(k), save_pos=save_pos) + end do + end if + + field_ele=ele_val(field, l_ele) + upwind_value=dot_product(l_shape,field_ele) + upwind_value=node_val(field, i_field) + (1./c_distance)*(upwind_value-node_val(field, i_field)) + if(bound) then + upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + end if + call set(upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) + + field_ele=ele_val(old_field, l_ele) + upwind_value=dot_product(l_shape,field_ele) + upwind_value=node_val(old_field, i_field) + (1./c_distance)*(upwind_value-node_val(old_field, i_field)) + if(bound) then + upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + end if + call set(old_upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) + + end do + end do + + call deallocate(normals) + deallocate(field_bc_type) + + end subroutine calculate_upwind_quadrature_project + + subroutine calculate_upwind_values_project(upwind_elements, upwind_quadrature, x_field, & + field, upwind_values, & + old_field, old_upwind_values, & + bound) ! project from a node pair to an upwind value when we have the upwind_elements and ! the upwind_quadrature available... i.e. we only need to ! find the value and possibly bound it. @@ -924,25 +924,25 @@ subroutine calculate_upwind_values_project(upwind_elements, upwind_quadrature, x call zero(old_upwind_values) if(mesh_periodic(field)) then - call add_nelist(x_field%mesh) + call add_nelist(x_field%mesh) end if do i = 1, size(upwind_values, 1) - ! find the neighbouring nodes using the matrix sparsity - ! FIXME: the matrix sparsity is not the same as the mesh connectivity for - ! cube meshes! - ! (not very important for projection as it only works on simplex meshes) + ! find the neighbouring nodes using the matrix sparsity + ! FIXME: the matrix sparsity is not the same as the mesh connectivity for + ! cube meshes! + ! (not very important for projection as it only works on simplex meshes) nodes => row_m_ptr(upwind_values, i) if (size(nodes) == 0) cycle if(mesh_periodic(field)) then - x_eles=>node_neigh(x_field, i) - local_coord = local_coords(x_field, x_eles(1), i) - field_nodes=>ele_nodes(field, x_eles(1)) - i_field = field_nodes(local_coord) + x_eles=>node_neigh(x_field, i) + local_coord = local_coords(x_field, x_eles(1), i) + field_nodes=>ele_nodes(field, x_eles(1)) + i_field = field_nodes(local_coord) else - i_field = i + i_field = i end if do j = 1, size(nodes) if(nodes(j)==i) cycle @@ -965,7 +965,7 @@ subroutine calculate_upwind_values_project(upwind_elements, upwind_quadrature, x upwind_value=dot_product(l_shape,field_ele) upwind_value=node_val(old_field, i_field) + (1./c_distance)*(upwind_value-node_val(old_field, i_field)) if(bound) then - upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) end if call set(old_upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) @@ -974,406 +974,406 @@ subroutine calculate_upwind_values_project(upwind_elements, upwind_quadrature, x end subroutine calculate_upwind_values_project - subroutine calculate_all_upwind_project_grad(x, x_field, upwind_elements, & - field, upwind_values, old_field, old_upwind_values, & - reflect, bound, projection_node) - - ! project from a node pair to an upwind value using the interpolated gradient of the fi. - - ! coordinates - type(vector_field), intent(inout) :: x, x_field - - type(csr_matrix), intent(inout), optional :: upwind_elements - - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: old_field - type(csr_matrix), intent(inout) :: upwind_values - type(csr_matrix), intent(inout) :: old_upwind_values - logical, intent(in) :: reflect, bound - integer, intent(in) :: projection_node - - ! local memory: - ! allocatable memory - integer, dimension(:), pointer :: nodes, eles, x_eles, field_nodes - ! loop integers - integer :: i, j, k, ele, l_ele, dim, local_coord, i_field, j_field - - ! the coordinates of a pt just upwind of the node pair and the vector - ! in the direction of projection - real, dimension(x%dim) :: xc, xc_vector, d - ! the gradients of the field and old_field at the donor node - real, dimension(x%dim) :: grad_c, old_grad_c - ! element node coordinates - ! we only consider the vertices coordinates if higher order - real, dimension(mesh_dim(x), x%mesh%shape%numbering%vertices) :: x_ele - integer, dimension(x%mesh%shape%numbering%vertices):: vertices - integer, dimension(:), pointer :: x_nodes - real, dimension(x_field%dim, ele_loc(x_field, 1)) :: x_field_ele - ! simplex volume coordinates - real, dimension(x%mesh%shape%loc) :: coords, l_coords - ! element field node values - real, dimension(field%mesh%shape%loc) :: field_ele - ! the upwind value - real :: upwind_value, old_upwind_value - - ! a vector field of normals if we're reflecting - type(vector_field) :: normals - ! a logical list saying which nodes are on the boundary - logical, dimension(:), allocatable :: on_boundary - ! which bc are on which nodes - integer, dimension(:), allocatable :: field_bc_type - - ! gradients - type(vector_field) :: grad_field, grad_old_field - - logical :: upwind_elements_present - - integer :: save_pos=0 ! saves the position in the matrix for optimisation - - ewrite(2,*) 'in calculate_all_upwind_project_grad' - ! the projected gradient values upwind value matrix is on the x_field mesh - ! which cannot be periodic - - upwind_elements_present=.false. - - ! zero everything we have - call zero(upwind_values) - call zero(old_upwind_values) - if(present(upwind_elements)) then - call zero(upwind_elements) - upwind_elements_present=.true. - end if - - dim = mesh_dim(field) - if((dim/=1).and.(dim/=2).and.(dim/=3)) then - FLExit("Unsupported control volume dimension.") - end if - - call allocate(normals, dim, x_field%mesh, name="NormalsToBoundary") - call zero(normals) - allocate(on_boundary(node_count(x_field))) - on_boundary=.false. - if(reflect) then - ! work out what the domain normals are - call calculate_boundary_normals(field%mesh, x, & - normals, on_boundary) - end if - - call allocate(grad_field, dim, field%mesh, name="FieldGradient") - call zero(grad_field) - call grad(field, x, grad_field) - - call allocate(grad_old_field, dim, field%mesh, name="OldFieldGradient") - call zero(grad_old_field) - call grad(old_field, x, grad_old_field) - - allocate(field_bc_type(node_count(field))) - field_bc_type=0 - if(bound.or.mesh_periodic(field)) then - ! create the node to element list - call add_nelist(x_field%mesh) - if(bound.and.mesh_periodic(field)) then - call add_nelist(field%mesh) - call get_boundary_condition_nodes(field, (/"internal"/), field_bc_type) - end if - end if - eles => null() - xc = 0.0 - xc_vector = 0.0 - - ! loop over the nodes - do i = 1, size(upwind_values,1) - ! find the neighbouring nodes using the matrix sparsity - ! FIXME: the matrix sparsity is not the same as the mesh connectivity for - ! cube meshes! - nodes => row_m_ptr(upwind_values, i) - if(bound.or.mesh_periodic(field)) then - ! find the neighbouring elements using the node to element list - x_eles => node_neigh(x_field, i) - if(mesh_periodic(field)) then - local_coord = local_coords(x_field, x_eles(1), i) - field_nodes=>ele_nodes(field, x_eles(1)) - i_field = field_nodes(local_coord) - if(bound) then - eles => node_neigh(field, i_field) - end if - else - i_field = i - if(bound) then - eles => x_eles - end if - end if - else - i_field = i + subroutine calculate_all_upwind_project_grad(x, x_field, upwind_elements, & + field, upwind_values, old_field, old_upwind_values, & + reflect, bound, projection_node) + + ! project from a node pair to an upwind value using the interpolated gradient of the fi. + + ! coordinates + type(vector_field), intent(inout) :: x, x_field + + type(csr_matrix), intent(inout), optional :: upwind_elements + + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: old_field + type(csr_matrix), intent(inout) :: upwind_values + type(csr_matrix), intent(inout) :: old_upwind_values + logical, intent(in) :: reflect, bound + integer, intent(in) :: projection_node + + ! local memory: + ! allocatable memory + integer, dimension(:), pointer :: nodes, eles, x_eles, field_nodes + ! loop integers + integer :: i, j, k, ele, l_ele, dim, local_coord, i_field, j_field + + ! the coordinates of a pt just upwind of the node pair and the vector + ! in the direction of projection + real, dimension(x%dim) :: xc, xc_vector, d + ! the gradients of the field and old_field at the donor node + real, dimension(x%dim) :: grad_c, old_grad_c + ! element node coordinates + ! we only consider the vertices coordinates if higher order + real, dimension(mesh_dim(x), x%mesh%shape%numbering%vertices) :: x_ele + integer, dimension(x%mesh%shape%numbering%vertices):: vertices + integer, dimension(:), pointer :: x_nodes + real, dimension(x_field%dim, ele_loc(x_field, 1)) :: x_field_ele + ! simplex volume coordinates + real, dimension(x%mesh%shape%loc) :: coords, l_coords + ! element field node values + real, dimension(field%mesh%shape%loc) :: field_ele + ! the upwind value + real :: upwind_value, old_upwind_value + + ! a vector field of normals if we're reflecting + type(vector_field) :: normals + ! a logical list saying which nodes are on the boundary + logical, dimension(:), allocatable :: on_boundary + ! which bc are on which nodes + integer, dimension(:), allocatable :: field_bc_type + + ! gradients + type(vector_field) :: grad_field, grad_old_field + + logical :: upwind_elements_present + + integer :: save_pos=0 ! saves the position in the matrix for optimisation + + ewrite(2,*) 'in calculate_all_upwind_project_grad' + ! the projected gradient values upwind value matrix is on the x_field mesh + ! which cannot be periodic + + upwind_elements_present=.false. + + ! zero everything we have + call zero(upwind_values) + call zero(old_upwind_values) + if(present(upwind_elements)) then + call zero(upwind_elements) + upwind_elements_present=.true. end if - ! loop over the neighbouring nodes - do j = 1, size(nodes) - if(nodes(j)==i) cycle ! skip the node that's the same as the i node - ! i is considered as the donor node and j is considered to be the downwind - ! (although we don't actually know this yet) - d=project_vector(i, nodes(j), x_field, & - on_boundary, normals) ! d is the vector between the donor and downwind nodes + dim = mesh_dim(field) + if((dim/=1).and.(dim/=2).and.(dim/=3)) then + FLExit("Unsupported control volume dimension.") + end if - grad_c = node_val(grad_field, i_field) ! the gradient at the donor node - old_grad_c = node_val(grad_old_field, i_field) ! the old gradient at the donor node + call allocate(normals, dim, x_field%mesh, name="NormalsToBoundary") + call zero(normals) + allocate(on_boundary(node_count(x_field))) + on_boundary=.false. + if(reflect) then + ! work out what the domain normals are + call calculate_boundary_normals(field%mesh, x, & + normals, on_boundary) + end if - if(bound) then + call allocate(grad_field, dim, field%mesh, name="FieldGradient") + call zero(grad_field) + call grad(field, x, grad_field) - ! find the vecotr connecting to the point just upwind of the node pair - ! (also deals with reflection) - xc_vector=project_upwind(i, nodes(j), x_field, & - on_boundary, normals) + call allocate(grad_old_field, dim, field%mesh, name="OldFieldGradient") + call zero(grad_old_field) + call grad(old_field, x, grad_old_field) - if(field_bc_type(i_field)==0) then - xc = node_val(x_field, i) + xc_vector + allocate(field_bc_type(node_count(field))) + field_bc_type=0 + if(bound.or.mesh_periodic(field)) then + ! create the node to element list + call add_nelist(x_field%mesh) + if(bound.and.mesh_periodic(field)) then + call add_nelist(field%mesh) + call get_boundary_condition_nodes(field, (/"internal"/), field_bc_type) + end if + end if + eles => null() + xc = 0.0 + xc_vector = 0.0 + + ! loop over the nodes + do i = 1, size(upwind_values,1) + ! find the neighbouring nodes using the matrix sparsity + ! FIXME: the matrix sparsity is not the same as the mesh connectivity for + ! cube meshes! + nodes => row_m_ptr(upwind_values, i) + if(bound.or.mesh_periodic(field)) then + ! find the neighbouring elements using the node to element list + x_eles => node_neigh(x_field, i) + if(mesh_periodic(field)) then + local_coord = local_coords(x_field, x_eles(1), i) + field_nodes=>ele_nodes(field, x_eles(1)) + i_field = field_nodes(local_coord) + if(bound) then + eles => node_neigh(field, i_field) + end if + else + i_field = i + if(bound) then + eles => x_eles + end if end if + else + i_field = i + end if + ! loop over the neighbouring nodes + do j = 1, size(nodes) + if(nodes(j)==i) cycle ! skip the node that's the same as the i node + ! i is considered as the donor node and j is considered to be the downwind + ! (although we don't actually know this yet) - l_coords = infinity - l_ele = eles(1) + d=project_vector(i, nodes(j), x_field, & + on_boundary, normals) ! d is the vector between the donor and downwind nodes - ! loop over neighbouring elements working out which one contains - ! (or nearly contains) xc - do k = 1, size(eles) - ele = eles(k) - if(x%mesh%shape%degree == 1) then - x_ele = ele_val(x, ele) - else - ! only extract the coordinates of the vertices in this case - x_nodes => ele_nodes(x, ele) - vertices = local_vertices(x%mesh%shape%numbering) - x_ele = node_val(x, x_nodes(vertices)) + grad_c = node_val(grad_field, i_field) ! the gradient at the donor node + old_grad_c = node_val(grad_old_field, i_field) ! the old gradient at the donor node + + if(bound) then + + ! find the vecotr connecting to the point just upwind of the node pair + ! (also deals with reflection) + xc_vector=project_upwind(i, nodes(j), x_field, & + on_boundary, normals) + + if(field_bc_type(i_field)==0) then + xc = node_val(x_field, i) + xc_vector end if - if(field_bc_type(i_field)==1) then - ! find the local node number so we can add the vector - ! pointing at the upwind point to the coordinates at - ! that node - ! (this is done this way in case we're periodic and on - ! a boundary) - x_field_ele=ele_val(x_field, ele) - local_coord = local_coords(field, ele, i_field) - xc = x_field_ele(:,local_coord) + xc_vector + l_coords = infinity + l_ele = eles(1) + + ! loop over neighbouring elements working out which one contains + ! (or nearly contains) xc + do k = 1, size(eles) + ele = eles(k) + if(x%mesh%shape%degree == 1) then + x_ele = ele_val(x, ele) + else + ! only extract the coordinates of the vertices in this case + x_nodes => ele_nodes(x, ele) + vertices = local_vertices(x%mesh%shape%numbering) + x_ele = node_val(x, x_nodes(vertices)) + end if + + if(field_bc_type(i_field)==1) then + ! find the local node number so we can add the vector + ! pointing at the upwind point to the coordinates at + ! that node + ! (this is done this way in case we're periodic and on + ! a boundary) + x_field_ele=ele_val(x_field, ele) + local_coord = local_coords(field, ele, i_field) + xc = x_field_ele(:,local_coord) + xc_vector + end if + + select case(dim) + case(2) + coords=calculate_area_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele + case(3) + coords=calculate_volume_coordinates(x_ele, xc) ! only makes sense with linear coordinates in x_ele + end select + + if(sum(coords) node_neigh(x_field, nodes(j)) + local_coord = local_coords(x_field, x_eles(1), nodes(j)) + field_nodes=>ele_nodes(field, x_eles(1)) + j_field = field_nodes(local_coord) + else + j_field = j end if - end do + ! project from downwind node (Jasak et al., 1999) + upwind_value=node_val(field, j_field)-2.0*dot_product(d, grad_c) + old_upwind_value=node_val(old_field, j_field)-2.0*dot_product(d, old_grad_c) + case(CV_DONOR_PROJECTION_NODE) + ! or project from donor node + upwind_value=node_val(field, i_field)-dot_product(d, grad_c) + old_upwind_value=node_val(old_field, i_field)-dot_product(d, old_grad_c) + end select - if(upwind_elements_present) then - call set(upwind_elements, i, nodes(j), l_ele, save_pos=save_pos) + if(bound) then + ! calculate neighbouring values: + field_ele=ele_val(field, l_ele) + ! bound it relative to the surrounding values + upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + + ! and for the old field + field_ele=ele_val(old_field, l_ele) + ! bound it relative to the surrounding values + old_upwind_value = max(min(old_upwind_value, maxval(field_ele)), minval(field_ele)) end if + ! set in the matrix + call set(upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) + call set(old_upwind_values, i, nodes(j), old_upwind_value, save_pos=save_pos) - end if + end do + end do - select case(projection_node) - case(CV_DOWNWIND_PROJECTION_NODE) - if(mesh_periodic(field)) then - x_eles => node_neigh(x_field, nodes(j)) - local_coord = local_coords(x_field, x_eles(1), nodes(j)) - field_nodes=>ele_nodes(field, x_eles(1)) - j_field = field_nodes(local_coord) - else - j_field = j - end if - ! project from downwind node (Jasak et al., 1999) - upwind_value=node_val(field, j_field)-2.0*dot_product(d, grad_c) - old_upwind_value=node_val(old_field, j_field)-2.0*dot_product(d, old_grad_c) - case(CV_DONOR_PROJECTION_NODE) - ! or project from donor node - upwind_value=node_val(field, i_field)-dot_product(d, grad_c) - old_upwind_value=node_val(old_field, i_field)-dot_product(d, old_grad_c) - end select - - if(bound) then - ! calculate neighbouring values: - field_ele=ele_val(field, l_ele) - ! bound it relative to the surrounding values - upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + call deallocate(normals) + call deallocate(grad_field) + call deallocate(grad_old_field) + deallocate(field_bc_type) - ! and for the old field - field_ele=ele_val(old_field, l_ele) - ! bound it relative to the surrounding values - old_upwind_value = max(min(old_upwind_value, maxval(field_ele)), minval(field_ele)) - end if - ! set in the matrix - call set(upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) - call set(old_upwind_values, i, nodes(j), old_upwind_value, save_pos=save_pos) + end subroutine calculate_all_upwind_project_grad + + subroutine calculate_upwind_values_project_grad(x, x_field, upwind_elements, & + field, upwind_values, old_field, old_upwind_values, & + reflect, bound, projection_node) + + ! project from a node pair to an upwind value using the interpolated gradient of the fi. + + ! coordinates + type(vector_field), intent(inout) :: x, x_field + + type(csr_matrix), intent(in) :: upwind_elements + + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: old_field + type(csr_matrix), intent(inout) :: upwind_values + type(csr_matrix), intent(inout) :: old_upwind_values + logical, intent(in) :: reflect, bound + integer, intent(in) :: projection_node + + ! local memory: + ! allocatable memory + integer, dimension(:), pointer :: nodes, field_nodes, x_eles + ! loop integers + integer :: i, j, l_ele, dim, local_coord, i_field, j_field + + ! the vector in the direction of projection + real, dimension(x%dim) :: d + ! the gradients of the field and old_field at the donor node + real, dimension(x%dim) :: grad_c, old_grad_c + ! element field node values + real, dimension(field%mesh%shape%loc) :: field_ele + ! the upwind value + real :: upwind_value, old_upwind_value + + ! a vector field of normals if we're reflecting + type(vector_field) :: normals + ! a logical list saying which nodes are on the boundary + logical, dimension(:), allocatable :: on_boundary + + ! gradients + type(vector_field) :: grad_field, grad_old_field + + integer :: save_pos=0 ! saves the position in the matrix for optimisation + + ewrite(2,*) 'in calculate_upwind_values_project_grad' + ! the projected gradient values upwind value matrix is on the x_field mesh + ! which cannot be periodic + + ! zero everything we have + call zero(upwind_values) + call zero(old_upwind_values) + + dim = mesh_dim(field) + if((dim/=1).and.(dim/=2).and.(dim/=3)) then + FLExit("Unsupported control volume dimension.") + end if + + call allocate(normals, dim, x_field%mesh, name="NormalsToBoundary") + call zero(normals) + allocate(on_boundary(node_count(x_field))) + on_boundary=.false. + if(reflect) then + ! work out what the domain normals are + call calculate_boundary_normals(field%mesh, x, & + normals, on_boundary) + end if - end do - end do - - call deallocate(normals) - call deallocate(grad_field) - call deallocate(grad_old_field) - deallocate(field_bc_type) - - end subroutine calculate_all_upwind_project_grad - - subroutine calculate_upwind_values_project_grad(x, x_field, upwind_elements, & - field, upwind_values, old_field, old_upwind_values, & - reflect, bound, projection_node) - - ! project from a node pair to an upwind value using the interpolated gradient of the fi. - - ! coordinates - type(vector_field), intent(inout) :: x, x_field - - type(csr_matrix), intent(in) :: upwind_elements - - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: old_field - type(csr_matrix), intent(inout) :: upwind_values - type(csr_matrix), intent(inout) :: old_upwind_values - logical, intent(in) :: reflect, bound - integer, intent(in) :: projection_node - - ! local memory: - ! allocatable memory - integer, dimension(:), pointer :: nodes, field_nodes, x_eles - ! loop integers - integer :: i, j, l_ele, dim, local_coord, i_field, j_field - - ! the vector in the direction of projection - real, dimension(x%dim) :: d - ! the gradients of the field and old_field at the donor node - real, dimension(x%dim) :: grad_c, old_grad_c - ! element field node values - real, dimension(field%mesh%shape%loc) :: field_ele - ! the upwind value - real :: upwind_value, old_upwind_value - - ! a vector field of normals if we're reflecting - type(vector_field) :: normals - ! a logical list saying which nodes are on the boundary - logical, dimension(:), allocatable :: on_boundary - - ! gradients - type(vector_field) :: grad_field, grad_old_field - - integer :: save_pos=0 ! saves the position in the matrix for optimisation - - ewrite(2,*) 'in calculate_upwind_values_project_grad' - ! the projected gradient values upwind value matrix is on the x_field mesh - ! which cannot be periodic - - ! zero everything we have - call zero(upwind_values) - call zero(old_upwind_values) - - dim = mesh_dim(field) - if((dim/=1).and.(dim/=2).and.(dim/=3)) then - FLExit("Unsupported control volume dimension.") - end if - - call allocate(normals, dim, x_field%mesh, name="NormalsToBoundary") - call zero(normals) - allocate(on_boundary(node_count(x_field))) - on_boundary=.false. - if(reflect) then - ! work out what the domain normals are - call calculate_boundary_normals(field%mesh, x, & - normals, on_boundary) - end if - - if(mesh_periodic(field)) then - call add_nelist(x_field%mesh) - end if - - call allocate(grad_field, dim, field%mesh, name="FieldGradient") - call zero(grad_field) - call grad(field, x, grad_field) - - call allocate(grad_old_field, dim, field%mesh, name="OldFieldGradient") - call zero(grad_old_field) - call grad(old_field, x, grad_old_field) - - ! loop over the nodes - do i = 1, size(upwind_values,1) - ! find the neighbouring nodes using the matrix sparsity - ! FIXME: the matrix sparsity is not the same as the mesh connectivity for - ! cube meshes! - ! (not very important for projection as it only works on simplex meshes) - nodes => row_m_ptr(upwind_values, i) if(mesh_periodic(field)) then - ! find the neighbouring elements using the node to element list - x_eles => node_neigh(x_field, i) - local_coord = local_coords(x_field, x_eles(1), i) - field_nodes=>ele_nodes(field, x_eles(1)) - i_field = field_nodes(local_coord) - else - i_field = i + call add_nelist(x_field%mesh) end if - ! loop over the neighbouring nodes - do j = 1, size(nodes) - if(nodes(j)==i) cycle ! skip the node that's the same as the i node - ! i is considered as the donor node and j is considered to be the downwind - ! (although we don't actually know this yet) + call allocate(grad_field, dim, field%mesh, name="FieldGradient") + call zero(grad_field) + call grad(field, x, grad_field) - d=project_vector(i, nodes(j), x_field, & - on_boundary, normals) ! d is the vector between the donor and downwind nodes + call allocate(grad_old_field, dim, field%mesh, name="OldFieldGradient") + call zero(grad_old_field) + call grad(old_field, x, grad_old_field) - grad_c = node_val(grad_field, i_field) ! the gradient at the donor node - old_grad_c = node_val(grad_old_field, i_field) ! the old gradient at the donor node + ! loop over the nodes + do i = 1, size(upwind_values,1) + ! find the neighbouring nodes using the matrix sparsity + ! FIXME: the matrix sparsity is not the same as the mesh connectivity for + ! cube meshes! + ! (not very important for projection as it only works on simplex meshes) + nodes => row_m_ptr(upwind_values, i) + if(mesh_periodic(field)) then + ! find the neighbouring elements using the node to element list + x_eles => node_neigh(x_field, i) + local_coord = local_coords(x_field, x_eles(1), i) + field_nodes=>ele_nodes(field, x_eles(1)) + i_field = field_nodes(local_coord) + else + i_field = i + end if - select case(projection_node) - case(CV_DOWNWIND_PROJECTION_NODE) - ! project from downwind node (Jasak et al., 1999) - if(mesh_periodic(field)) then - x_eles => node_neigh(x_field, nodes(j)) - local_coord = local_coords(x_field, x_eles(1), nodes(j)) - field_nodes=>ele_nodes(field, x_eles(1)) - j_field = field_nodes(local_coord) - else - j_field = j - end if - upwind_value=node_val(field, j_field)-2.0*dot_product(d, grad_c) - old_upwind_value=node_val(old_field, j_field)-2.0*dot_product(d, old_grad_c) - case(CV_DONOR_PROJECTION_NODE) - ! or project from donor node - upwind_value=node_val(field, i_field)-dot_product(d, grad_c) - old_upwind_value=node_val(old_field, i_field)-dot_product(d, old_grad_c) - end select - - if(bound) then - ! which element are we in? - l_ele=ival(upwind_elements,i,nodes(j)) + ! loop over the neighbouring nodes + do j = 1, size(nodes) + if(nodes(j)==i) cycle ! skip the node that's the same as the i node + ! i is considered as the donor node and j is considered to be the downwind + ! (although we don't actually know this yet) + + d=project_vector(i, nodes(j), x_field, & + on_boundary, normals) ! d is the vector between the donor and downwind nodes + + grad_c = node_val(grad_field, i_field) ! the gradient at the donor node + old_grad_c = node_val(grad_old_field, i_field) ! the old gradient at the donor node + + select case(projection_node) + case(CV_DOWNWIND_PROJECTION_NODE) + ! project from downwind node (Jasak et al., 1999) + if(mesh_periodic(field)) then + x_eles => node_neigh(x_field, nodes(j)) + local_coord = local_coords(x_field, x_eles(1), nodes(j)) + field_nodes=>ele_nodes(field, x_eles(1)) + j_field = field_nodes(local_coord) + else + j_field = j + end if + upwind_value=node_val(field, j_field)-2.0*dot_product(d, grad_c) + old_upwind_value=node_val(old_field, j_field)-2.0*dot_product(d, old_grad_c) + case(CV_DONOR_PROJECTION_NODE) + ! or project from donor node + upwind_value=node_val(field, i_field)-dot_product(d, grad_c) + old_upwind_value=node_val(old_field, i_field)-dot_product(d, old_grad_c) + end select - ! calculate neighbouring values: - field_ele=ele_val(field, l_ele) - ! bound it relative to the surrounding values - upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + if(bound) then + ! which element are we in? + l_ele=ival(upwind_elements,i,nodes(j)) - ! and for the old field - field_ele=ele_val(old_field, l_ele) - ! bound it relative to the surrounding values - old_upwind_value = max(min(old_upwind_value, maxval(field_ele)), minval(field_ele)) - end if - ! set in the matrix - call set(upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) - call set(old_upwind_values, i, nodes(j), old_upwind_value, save_pos=save_pos) + ! calculate neighbouring values: + field_ele=ele_val(field, l_ele) + ! bound it relative to the surrounding values + upwind_value = max(min(upwind_value, maxval(field_ele)), minval(field_ele)) + + ! and for the old field + field_ele=ele_val(old_field, l_ele) + ! bound it relative to the surrounding values + old_upwind_value = max(min(old_upwind_value, maxval(field_ele)), minval(field_ele)) + end if + ! set in the matrix + call set(upwind_values, i, nodes(j), upwind_value, save_pos=save_pos) + call set(old_upwind_values, i, nodes(j), old_upwind_value, save_pos=save_pos) + end do end do - end do - call deallocate(normals) - call deallocate(grad_field) - call deallocate(grad_old_field) + call deallocate(normals) + call deallocate(grad_field) + call deallocate(grad_old_field) - end subroutine calculate_upwind_values_project_grad + end subroutine calculate_upwind_values_project_grad - subroutine calculate_upwind_values_local(field, upwind_values, & - old_field, old_upwind_values) + subroutine calculate_upwind_values_local(field, upwind_values, & + old_field, old_upwind_values) ! use the local values surrounding a node pair to calculate the ! upwind value (choose the min or max depending on the gradient ! between the node pair) @@ -1387,8 +1387,8 @@ subroutine calculate_upwind_values_local(field, upwind_values, & integer, dimension(:), pointer :: nodes integer :: save_pos=0 ! saves the position in the matrix for optimisation - ! this is of dubious benefit here as the value setting is potentially - ! different for current and old values + ! this is of dubious benefit here as the value setting is potentially + ! different for current and old values ewrite(2,*) 'in calculate_upwind_values_local' ! the local values upwind value matrix is on the field mesh ! which may be periodic @@ -1400,11 +1400,11 @@ subroutine calculate_upwind_values_local(field, upwind_values, & ! loop over nodes do i = 1, size(upwind_values, 1) - ! find the neighbouring nodes using the matrix sparsity - ! FIXME: the matrix sparsity is not the same as the mesh connectivity for - ! cube meshes! - ! (this could potentially be very important for local upwind values - ! as unnconected values may be used) + ! find the neighbouring nodes using the matrix sparsity + ! FIXME: the matrix sparsity is not the same as the mesh connectivity for + ! cube meshes! + ! (this could potentially be very important for local upwind values + ! as unnconected values may be used) nodes => row_m_ptr(upwind_values, i) ! loop over neighbouring nodes do j = 1, size(nodes) @@ -1414,27 +1414,27 @@ subroutine calculate_upwind_values_local(field, upwind_values, & ! test gradient between nodes and calculate min or max of neighbouring node values if(node_val(field, i) row_m_ptr(upwind_values, i) ! loop over neighbouring nodes @@ -1488,21 +1488,21 @@ subroutine calculate_upwind_values_structured(x_field, field, upwind_values, & do k = 1, size(nodes) - ! don't try anything with the downwind or donor nodes themselves - if((nodes(k)==nodes(j)).or.(nodes(k)==i)) cycle + ! don't try anything with the downwind or donor nodes themselves + if((nodes(k)==nodes(j)).or.(nodes(k)==i)) cycle - ! get the vector connecting the possible upwind and donor nodes - vector2 = node_val(x_field, nodes(k))-node_val(x_field, i) - vector2 = vector2/norm2(vector2) ! normalise + ! get the vector connecting the possible upwind and donor nodes + vector2 = node_val(x_field, nodes(k))-node_val(x_field, i) + vector2 = vector2/norm2(vector2) ! normalise - ! take dot product - dp = dot_product(vector1, vector2) + ! take dot product + dp = dot_product(vector1, vector2) - ! we want to get the dot product that's as close to -1 as possible - if (dp < l_dp) then - l_dp = dp - l_upwind_node = nodes(k) - end if + ! we want to get the dot product that's as close to -1 as possible + if (dp < l_dp) then + l_dp = dp + l_upwind_node = nodes(k) + end if end do @@ -1516,369 +1516,369 @@ subroutine calculate_upwind_values_structured(x_field, field, upwind_values, & end subroutine calculate_upwind_values_structured - subroutine calculate_boundary_normals(mesh, x, & - normals, on_boundary, & - surface_ids) + subroutine calculate_boundary_normals(mesh, x, & + normals, on_boundary, & + surface_ids) - ! calculate the outward pointing normals from the domain boundary - ! and as a bonus tells you which nodes are on the boundary + ! calculate the outward pointing normals from the domain boundary + ! and as a bonus tells you which nodes are on the boundary - type(mesh_type), intent(inout) :: mesh - type(vector_field), intent(in) :: x ! coordinates - type(vector_field), intent(inout) :: normals - logical, dimension(:), intent(inout) :: on_boundary - ! an optional argument to specify on which surface ids the normal should be calculated - integer, dimension(:), intent(in), optional :: surface_ids + type(mesh_type), intent(inout) :: mesh + type(vector_field), intent(in) :: x ! coordinates + type(vector_field), intent(inout) :: normals + logical, dimension(:), intent(inout) :: on_boundary + ! an optional argument to specify on which surface ids the normal should be calculated + integer, dimension(:), intent(in), optional :: surface_ids - integer :: sele, iloc, k - integer, dimension(face_loc(mesh,1)) :: nodes_bdy - real, dimension(x%dim,face_ngi(x,1)) :: normal_bdy - real, dimension(face_ngi(x, 1)) :: detwei_bdy + integer :: sele, iloc, k + integer, dimension(face_loc(mesh,1)) :: nodes_bdy + real, dimension(x%dim,face_ngi(x,1)) :: normal_bdy + real, dimension(face_ngi(x, 1)) :: detwei_bdy - logical, dimension(:), allocatable :: field_bc_type + logical, dimension(:), allocatable :: field_bc_type - real :: normnormal + real :: normnormal - allocate(field_bc_type(surface_element_count(mesh))) - call get_periodic_boundary_condition(mesh, field_bc_type) + allocate(field_bc_type(surface_element_count(mesh))) + call get_periodic_boundary_condition(mesh, field_bc_type) - ! calculate the normals at the nodes - do sele = 1, surface_element_count(mesh) + ! calculate the normals at the nodes + do sele = 1, surface_element_count(mesh) - if(field_bc_type(sele)) cycle + if(field_bc_type(sele)) cycle - if(present(surface_ids)) then - if(.not.any(surface_ids==surface_element_id(mesh, sele))) cycle - end if + if(present(surface_ids)) then + if(.not.any(surface_ids==surface_element_id(mesh, sele))) cycle + end if - nodes_bdy=face_global_nodes(normals, sele) + nodes_bdy=face_global_nodes(normals, sele) - on_boundary(nodes_bdy) = .true. + on_boundary(nodes_bdy) = .true. - call transform_facet_to_physical(x, sele, & + call transform_facet_to_physical(x, sele, & detwei_f=detwei_bdy, normal=normal_bdy) - call addto(normals, nodes_bdy, & - shape_vector_rhs(face_shape(normals, sele), normal_bdy, detwei_bdy)) + call addto(normals, nodes_bdy, & + shape_vector_rhs(face_shape(normals, sele), normal_bdy, detwei_bdy)) - end do ! sele + end do ! sele - ! normalise the normals - do iloc = 1, node_count(normals) + ! normalise the normals + do iloc = 1, node_count(normals) - if(.not.on_boundary(iloc)) cycle + if(.not.on_boundary(iloc)) cycle - normnormal = 0.0 - do k = 1, mesh_dim(normals) - normnormal = normnormal + node_val(normals, k, iloc)**2 - end do - normnormal = sqrt(normnormal) - - call set(normals, iloc, node_val(normals,iloc)/max(normnormal, tolerance)) - - end do ! iloc - - end subroutine calculate_boundary_normals - - pure function project_upwind(i, j, x_field, & - on_boundary, normals) result(xc) - - ! for a given node pair calculate the vector connecting to the coordinates of a point - ! just upwind - - integer, intent(in) :: i, j - type(vector_field), intent(in) :: x_field - logical, dimension(:), intent(in) :: on_boundary - type(vector_field), intent(in) :: normals - - real, dimension(x_field%dim) :: xc - - integer :: k - real, dimension(3,3) :: t_matrix, t_matrix_T - real, dimension(3) :: n, vx, t2, t1, ref_vx - - if(on_boundary(i)) then ! this is only true if you're on the boundary and have - ! requested that upwind values be reflected off it - ! fill in zeros in case this is 2d - n = 0.0 - vx = 0.0 - do k = 1, x_field%dim - n(k) = normals%val(k,i) ! extract the normal - vx(k) = (x_field%val(k,i) & - -x_field%val(k,j)) ! extract the vector between the nodes - end do - t2 = cross_product(n, vx) ! find the perpendicular surface tangent - if(norm2(t2)<(1.e-5)*norm2(vx)) then ! if the node pair is almost perpendicular to the surface - do k = 1, x_field%dim ! then just reflect straight back - xc(k) = c_distance*(x_field%val(k,j) & - -x_field%val(k,i)) + normnormal = 0.0 + do k = 1, mesh_dim(normals) + normnormal = normnormal + node_val(normals, k, iloc)**2 end do - else - t2 = t2/norm2(t2) ! normalise the surface tangent - t1 = cross_product(n, -t2) ! get the orthogonal surface tangent - ! you now have a coordinate system on the surface so - ! create the reflected transformation matrix - t_matrix(1,:) = -n ! the minus reflects the coordinate system back into the mesh - t_matrix(2,:) = t1 - t_matrix(3,:) = t2 - ! create the transposed unreflected transformation matrix - t_matrix_T(:,1) = n - t_matrix_T(:,2) = t1 - t_matrix_T(:,3) = t2 - - ! transform into the reflect coordinate system then immediately transform back to the original - ! coordinates - ref_vx=matmul(t_matrix_T, matmul(t_matrix, vx)) + normnormal = sqrt(normnormal) + + call set(normals, iloc, node_val(normals,iloc)/max(normnormal, tolerance)) + + end do ! iloc + + end subroutine calculate_boundary_normals + + pure function project_upwind(i, j, x_field, & + on_boundary, normals) result(xc) + + ! for a given node pair calculate the vector connecting to the coordinates of a point + ! just upwind + + integer, intent(in) :: i, j + type(vector_field), intent(in) :: x_field + logical, dimension(:), intent(in) :: on_boundary + type(vector_field), intent(in) :: normals + + real, dimension(x_field%dim) :: xc + + integer :: k + real, dimension(3,3) :: t_matrix, t_matrix_T + real, dimension(3) :: n, vx, t2, t1, ref_vx + + if(on_boundary(i)) then ! this is only true if you're on the boundary and have + ! requested that upwind values be reflected off it + ! fill in zeros in case this is 2d + n = 0.0 + vx = 0.0 do k = 1, x_field%dim - ! find the vector to upwind coordinates - xc(k) = c_distance*(ref_vx(k)) + n(k) = normals%val(k,i) ! extract the normal + vx(k) = (x_field%val(k,i) & + -x_field%val(k,j)) ! extract the vector between the nodes end do - end if - else ! else just find the point outside the mesh (if you're actually on the boundary) - ! then (later) you'll just find the nearest element to this - ! and use the values from that - do k = 1, x_field%dim - ! find the vector to upwind coordinates - xc(k) = -c_distance*(x_field%val(k,j) & - -x_field%val(k,i)) - end do - end if - - end function project_upwind - - pure function project_vector(i, j, x, & - on_boundary, normals) result(d) - - ! for a given node pair calculate the direction of an upwind point - - integer, intent(in) :: i, j - type(vector_field), intent(in) :: x - logical, dimension(:), intent(in) :: on_boundary - type(vector_field), intent(in) :: normals - - real, dimension(x%dim) :: d ! d is the vector between the donor and downwind nodes - - integer :: k - real, dimension(3,3) :: t_matrix, t_matrix_T - real, dimension(3) :: n, vx, t2, t1, ref_vx - - if(on_boundary(i)) then ! this is only true if you're on the boundary and have - ! requested that upwind values be reflected off it - ! fill in zeros in case this is 2d - n = 0.0 - vx = 0.0 - do k = 1, x%dim - n(k) = normals%val(k,i) ! extract the normal - vx(k) = (x%val(k,i) & - -x%val(k,j)) ! extract the vector between the nodes - end do - t2 = cross_product(n, vx) ! find the perpendicular surface tangent - if(norm2(t2)<(1.e-5)*norm2(vx)) then ! if the node pair is almost perpendicular to the surface - do k = 1, x%dim ! then just reflect straight back - d(k) = x%val(k,j)-x%val(k,i) - end do - else - t2 = t2/norm2(t2) ! normalise the surface tangent - t1 = cross_product(n, -t2) ! get the orthogonal surface tangent - ! you now have a coordinate system on the surface so - ! create the reflected transformation matrix - t_matrix(1,:) = -n ! the minus reflects the coordinate system back into the mesh - t_matrix(2,:) = t1 - t_matrix(3,:) = t2 - ! create the transposed unreflected transformation matrix - t_matrix_T(:,1) = n - t_matrix_T(:,2) = t1 - t_matrix_T(:,3) = t2 - - ! transform into the reflect coordinate system then immediately transform back to the original - ! coordinates - ref_vx=matmul(t_matrix_T, matmul(t_matrix, vx)) - do k = 1, x%dim - d(k) = ref_vx(k) + t2 = cross_product(n, vx) ! find the perpendicular surface tangent + if(norm2(t2)<(1.e-5)*norm2(vx)) then ! if the node pair is almost perpendicular to the surface + do k = 1, x_field%dim ! then just reflect straight back + xc(k) = c_distance*(x_field%val(k,j) & + -x_field%val(k,i)) + end do + else + t2 = t2/norm2(t2) ! normalise the surface tangent + t1 = cross_product(n, -t2) ! get the orthogonal surface tangent + ! you now have a coordinate system on the surface so + ! create the reflected transformation matrix + t_matrix(1,:) = -n ! the minus reflects the coordinate system back into the mesh + t_matrix(2,:) = t1 + t_matrix(3,:) = t2 + ! create the transposed unreflected transformation matrix + t_matrix_T(:,1) = n + t_matrix_T(:,2) = t1 + t_matrix_T(:,3) = t2 + + ! transform into the reflect coordinate system then immediately transform back to the original + ! coordinates + ref_vx=matmul(t_matrix_T, matmul(t_matrix, vx)) + do k = 1, x_field%dim + ! find the vector to upwind coordinates + xc(k) = c_distance*(ref_vx(k)) + end do + end if + else ! else just find the point outside the mesh (if you're actually on the boundary) + ! then (later) you'll just find the nearest element to this + ! and use the values from that + do k = 1, x_field%dim + ! find the vector to upwind coordinates + xc(k) = -c_distance*(x_field%val(k,j) & + -x_field%val(k,i)) end do - end if - else ! else just find the point outside the mesh (if you're actually on the boundary) - ! then (later) you'll just project to an upwind value outside... bounding won't be possible - do k = 1, x%dim - d(k) = x%val(k,j)-x%val(k,i) - end do - end if + end if - end function project_vector + end function project_upwind - pure function calculate_volume_coordinates(x_ele, xc) result(coords) + pure function project_vector(i, j, x, & + on_boundary, normals) result(d) - ! calculate the volume coordinates for simplex elements (tetrahedra) - ! this is useful as they're the same as linear quadrature + ! for a given node pair calculate the direction of an upwind point - real, dimension(:,:), intent(in) :: x_ele - real, dimension(:), intent(in) :: xc + integer, intent(in) :: i, j + type(vector_field), intent(in) :: x + logical, dimension(:), intent(in) :: on_boundary + type(vector_field), intent(in) :: normals - real, dimension(4) :: coords + real, dimension(x%dim) :: d ! d is the vector between the donor and downwind nodes - real, dimension(3) :: x1, x2, x3, x4 - real :: vol + integer :: k + real, dimension(3,3) :: t_matrix, t_matrix_T + real, dimension(3) :: n, vx, t2, t1, ref_vx - x1 = x_ele(:,1) - x2 = x_ele(:,2) - x3 = x_ele(:,3) - x4 = x_ele(:,4) + if(on_boundary(i)) then ! this is only true if you're on the boundary and have + ! requested that upwind values be reflected off it + ! fill in zeros in case this is 2d + n = 0.0 + vx = 0.0 + do k = 1, x%dim + n(k) = normals%val(k,i) ! extract the normal + vx(k) = (x%val(k,i) & + -x%val(k,j)) ! extract the vector between the nodes + end do + t2 = cross_product(n, vx) ! find the perpendicular surface tangent + if(norm2(t2)<(1.e-5)*norm2(vx)) then ! if the node pair is almost perpendicular to the surface + do k = 1, x%dim ! then just reflect straight back + d(k) = x%val(k,j)-x%val(k,i) + end do + else + t2 = t2/norm2(t2) ! normalise the surface tangent + t1 = cross_product(n, -t2) ! get the orthogonal surface tangent + ! you now have a coordinate system on the surface so + ! create the reflected transformation matrix + t_matrix(1,:) = -n ! the minus reflects the coordinate system back into the mesh + t_matrix(2,:) = t1 + t_matrix(3,:) = t2 + ! create the transposed unreflected transformation matrix + t_matrix_T(:,1) = n + t_matrix_T(:,2) = t1 + t_matrix_T(:,3) = t2 + + ! transform into the reflect coordinate system then immediately transform back to the original + ! coordinates + ref_vx=matmul(t_matrix_T, matmul(t_matrix, vx)) + do k = 1, x%dim + d(k) = ref_vx(k) + end do + end if + else ! else just find the point outside the mesh (if you're actually on the boundary) + ! then (later) you'll just project to an upwind value outside... bounding won't be possible + do k = 1, x%dim + d(k) = x%val(k,j)-x%val(k,i) + end do + end if - vol = calculate_simplex_volume() + end function project_vector - x1 = xc + pure function calculate_volume_coordinates(x_ele, xc) result(coords) - coords(1) = calculate_simplex_volume() + ! calculate the volume coordinates for simplex elements (tetrahedra) + ! this is useful as they're the same as linear quadrature - x1 = x_ele(:,1) - x2 = xc + real, dimension(:,:), intent(in) :: x_ele + real, dimension(:), intent(in) :: xc - coords(2) = calculate_simplex_volume() + real, dimension(4) :: coords - x2 = x_ele(:,2) - x3 = xc + real, dimension(3) :: x1, x2, x3, x4 + real :: vol - coords(3) = calculate_simplex_volume() + x1 = x_ele(:,1) + x2 = x_ele(:,2) + x3 = x_ele(:,3) + x4 = x_ele(:,4) - x3 = x_ele(:,3) - x4 = xc + vol = calculate_simplex_volume() - coords(4) = calculate_simplex_volume() + x1 = xc - coords = coords/vol + coords(1) = calculate_simplex_volume() - contains + x1 = x_ele(:,1) + x2 = xc - pure function calculate_simplex_volume() result(svol) + coords(2) = calculate_simplex_volume() - ! for a given set of nodes, calculate the volume + x2 = x_ele(:,2) + x3 = xc - real :: svol + coords(3) = calculate_simplex_volume() - real, dimension(3) :: vector1, vector2, vector3 + x3 = x_ele(:,3) + x4 = xc - vector1 = x2-x1 - vector2 = x3-x1 - vector3 = x4-x1 + coords(4) = calculate_simplex_volume() - svol = scalar_triple_product(vector1, vector2, vector3) - svol = abs(svol) -! svol = svol/6.0 ! this would make the volume correct - ! but as it gets cancelled out later - ! this is ommitted + coords = coords/vol + contains - end function calculate_simplex_volume + pure function calculate_simplex_volume() result(svol) - end function calculate_volume_coordinates + ! for a given set of nodes, calculate the volume - function calculate_area_coordinates(x_ele, xc) result(coords) + real :: svol - ! calculate the area coordinates for simplex elements (triangles) - ! this is useful as they're the same as linear quadrature + real, dimension(3) :: vector1, vector2, vector3 - real, dimension(:,:), intent(in) :: x_ele - real, dimension(:), intent(in) :: xc + vector1 = x2-x1 + vector2 = x3-x1 + vector3 = x4-x1 - real, dimension(3) :: coords + svol = scalar_triple_product(vector1, vector2, vector3) + svol = abs(svol) +! svol = svol/6.0 ! this would make the volume correct + ! but as it gets cancelled out later + ! this is ommitted - real, dimension(2) :: x1, x2, x3 - real :: area - x1 = x_ele(:,1) - x2 = x_ele(:,2) - x3 = x_ele(:,3) + end function calculate_simplex_volume - area = calculate_simplex_area() + end function calculate_volume_coordinates - x1 = xc + function calculate_area_coordinates(x_ele, xc) result(coords) - coords(1) = calculate_simplex_area() + ! calculate the area coordinates for simplex elements (triangles) + ! this is useful as they're the same as linear quadrature - x1 = x_ele(:,1) - x2 = xc + real, dimension(:,:), intent(in) :: x_ele + real, dimension(:), intent(in) :: xc - coords(2) = calculate_simplex_area() + real, dimension(3) :: coords - x2 = x_ele(:,2) - x3 = xc + real, dimension(2) :: x1, x2, x3 + real :: area - coords(3) = calculate_simplex_area() + x1 = x_ele(:,1) + x2 = x_ele(:,2) + x3 = x_ele(:,3) - coords = coords/area + area = calculate_simplex_area() - contains + x1 = xc - pure function calculate_simplex_area() result(sarea) + coords(1) = calculate_simplex_area() - ! for a given set of nodes, calculate the volume + x1 = x_ele(:,1) + x2 = xc - real :: sarea + coords(2) = calculate_simplex_area() - real, dimension(3) :: vector1, vector2, vector3 + x2 = x_ele(:,2) + x3 = xc - vector1 = 0.0 - vector2 = 0.0 + coords(3) = calculate_simplex_area() - vector1(1:2) = x2-x1 - vector2(1:2) = x3-x1 + coords = coords/area - vector3 = cross_product(vector1, vector2) - sarea = norm2(vector3) -! sarea = 0.5*sarea ! this would make the area correct - ! but as it gets cancelled out later - ! this is ommitted + contains - end function calculate_simplex_area + pure function calculate_simplex_area() result(sarea) - end function calculate_area_coordinates + ! for a given set of nodes, calculate the volume - subroutine couple_upwind_values(upwind_values, old_upwind_values, cv_options) + real :: sarea - type(csr_matrix), intent(inout), dimension(:) :: upwind_values - type(csr_matrix), intent(inout), dimension(:) :: old_upwind_values - type(cv_options_type), dimension(:), intent(in) :: cv_options ! a wrapper type to pass in all the options for control volumes + real, dimension(3) :: vector1, vector2, vector3 - integer :: i, j, f, nfields, save_pos - integer, dimension(:), pointer :: nodes - real, dimension(size(upwind_values)) :: vals, old_vals + vector1 = 0.0 + vector2 = 0.0 - nfields = size(upwind_values) - save_pos = 0 + vector1(1:2) = x2-x1 + vector2(1:2) = x3-x1 - if(nfields>1) then - do i = 1, size(upwind_values(1), 1) - nodes => row_m_ptr(upwind_values(1), i) - do j = 1, size(nodes) + vector3 = cross_product(vector1, vector2) + sarea = norm2(vector3) +! sarea = 0.5*sarea ! this would make the area correct + ! but as it gets cancelled out later + ! this is ommitted - do f = 1, nfields - vals(f) = val(upwind_values(f), i, nodes(j), save_pos=save_pos) - old_vals(f) = val(old_upwind_values(f), i, nodes(j), save_pos=save_pos) - end do + end function calculate_simplex_area - do f = 2, nfields + end function calculate_area_coordinates - if (sum(vals(1:f))>cv_options(f)%sum_target_max) then - vals(f) = cv_options(f)%sum_target_max-sum(vals(1:f-1)) - call set(upwind_values(f), i, nodes(j), vals(f), save_pos=save_pos) - else if (sum(vals(1:f))cv_options(f)%sum_target_max) then - old_vals(f) = cv_options(f)%sum_target_max-sum(old_vals(1:f-1)) - call set(old_upwind_values(f), i, nodes(j), old_vals(f), save_pos=save_pos) - else if (sum(old_vals(1:f))1) then + do i = 1, size(upwind_values(1), 1) + nodes => row_m_ptr(upwind_values(1), i) + do j = 1, size(nodes) + + do f = 1, nfields + vals(f) = val(upwind_values(f), i, nodes(j), save_pos=save_pos) + old_vals(f) = val(old_upwind_values(f), i, nodes(j), save_pos=save_pos) + end do + + do f = 2, nfields + + if (sum(vals(1:f))>cv_options(f)%sum_target_max) then + vals(f) = cv_options(f)%sum_target_max-sum(vals(1:f-1)) + call set(upwind_values(f), i, nodes(j), vals(f), save_pos=save_pos) + else if (sum(vals(1:f))cv_options(f)%sum_target_max) then + old_vals(f) = cv_options(f)%sum_target_max-sum(old_vals(1:f-1)) + call set(old_upwind_values(f), i, nodes(j), old_vals(f), save_pos=save_pos) + else if (sum(old_vals(1:f)) 0) - - if(present(postfix)) then - lpostfix = postfix - else - lpostfix = "checkpoint" - end if - - static_dete = option_count("/io/detectors/static_detector") - lagrangian_dete = option_count("/io/detectors/lagrangian_detector") - det_arrays = option_count("/io/detectors/detector_array") - array_dete_lag = 0 - - do i = 1, det_arrays - path = "/io/detectors/detector_array[" // int2str(i - 1) // "]" - if(have_option(trim(path) // "/lagrangian")) then - call get_option(trim(path) // "/number_of_detectors", j) - array_dete_lag = array_dete_lag + j - end if - end do - total_dete_lag = lagrangian_dete + array_dete_lag - if(total_dete_lag == 0) then - ewrite(1, *) "No Lagrangian detectors - not checkpointing detectors" - ewrite(1, *) "Exiting checkpoint_detectors" - return - end if - - ! Construct a new detector checkpoint filename - detectors_cp_filename = trim(prefix) - if(present(cp_no)) detectors_cp_filename = trim(detectors_cp_filename) // "_" // int2str(cp_no) - detectors_cp_filename = trim(detectors_cp_filename) // "_" // trim(lpostfix) + type(vector_field), pointer :: vfield -!!!!! Writing of position detectors before checkpointing in serial !!!!! + integer(KIND=MPI_OFFSET_KIND) :: location_to_write, offset + integer, ALLOCATABLE, DIMENSION(:) :: status + integer :: nints, realsize, dimen, total_num_det, number_total_columns + real, dimension(:), allocatable :: buffer - if(getprocno() == 1) then - det_unit = free_unit() + ewrite(1, *) "Checkpointing detectors" - ! Write the detectors positions of the Lagrangian detectors into the - ! checkpoint detector file in binary format + assert(len_trim(prefix) > 0) - ! Before writing the positions, we write a header that contains the names - ! of the groups of detectors in the order that they were read + if(present(postfix)) then + lpostfix = postfix + else + lpostfix = "checkpoint" + end if + + static_dete = option_count("/io/detectors/static_detector") + lagrangian_dete = option_count("/io/detectors/lagrangian_detector") + det_arrays = option_count("/io/detectors/detector_array") + array_dete_lag = 0 - open(unit = det_unit, & - & file = trim(detectors_cp_filename) // '_det.groups', & - & action = "write") - do i = 1, size(default_stat%detector_group_names) - write(det_unit,'(a,i0)') & - & default_stat%detector_group_names(i), default_stat%number_det_in_each_group(i) + do i = 1, det_arrays + path = "/io/detectors/detector_array[" // int2str(i - 1) // "]" + if(have_option(trim(path) // "/lagrangian")) then + call get_option(trim(path) // "/number_of_detectors", j) + array_dete_lag = array_dete_lag + j + end if end do - close(det_unit) + total_dete_lag = lagrangian_dete + array_dete_lag + if(total_dete_lag == 0) then + ewrite(1, *) "No Lagrangian detectors - not checkpointing detectors" + ewrite(1, *) "Exiting checkpoint_detectors" + return + end if - end if + ! Construct a new detector checkpoint filename + detectors_cp_filename = trim(prefix) + if(present(cp_no)) detectors_cp_filename = trim(detectors_cp_filename) // "_" // int2str(cp_no) + detectors_cp_filename = trim(detectors_cp_filename) // "_" // trim(lpostfix) - !!< Writes detector last position into detectors file using MPI output - ! commands so that when running in parallel all processors can write at the same time information into the file at the right location. +!!!!! Writing of position detectors before checkpointing in serial !!!!! - call MPI_FILE_OPEN(MPI_COMM_FEMTOOLS, trim(detectors_cp_filename) // '_det.positions.dat', MPI_MODE_CREATE + MPI_MODE_RDWR, MPI_INFO_NULL, fhdet, IERROR) + if(getprocno() == 1) then + det_unit = free_unit() - ewrite(1,*) "after opening the IERROR is:", IERROR + ! Write the detectors positions of the Lagrangian detectors into the + ! checkpoint detector file in binary format - allocate( status(MPI_STATUS_SIZE) ) + ! Before writing the positions, we write a header that contains the names + ! of the groups of detectors in the order that they were read - call MPI_TYPE_EXTENT(getpreal(), realsize, ierror) + open(unit = det_unit, & + & file = trim(detectors_cp_filename) // '_det.groups', & + & action = "write") + do i = 1, size(default_stat%detector_group_names) + write(det_unit,'(a,i0)') & + & default_stat%detector_group_names(i), default_stat%number_det_in_each_group(i) + end do + close(det_unit) - vfield => extract_vector_field(state(1),"Velocity") + end if - dimen=vfield%dim + !!< Writes detector last position into detectors file using MPI output + ! commands so that when running in parallel all processors can write at the same time information into the file at the right location. - total_num_det = 0 + call MPI_FILE_OPEN(MPI_COMM_FEMTOOLS, trim(detectors_cp_filename) // '_det.positions.dat', MPI_MODE_CREATE + MPI_MODE_RDWR, MPI_INFO_NULL, fhdet, IERROR) - do i =1, size(default_stat%number_det_in_each_group) + ewrite(1,*) "after opening the IERROR is:", IERROR - total_num_det=total_num_det+default_stat%number_det_in_each_group(i) + allocate( status(MPI_STATUS_SIZE) ) - end do + call MPI_TYPE_EXTENT(getpreal(), realsize, ierror) - number_total_columns=total_num_det*dimen + vfield => extract_vector_field(state(1),"Velocity") - node => default_stat%detector_list%first + dimen=vfield%dim - location_to_write=0 + total_num_det = 0 - positionloop_cp: do i=1, default_stat%detector_list%length - offset = location_to_write+(node%id_number-1)*size(node%position)*realsize - ewrite(1,*) "after file set view position IERROR is:", IERROR + do i =1, size(default_stat%number_det_in_each_group) - allocate(buffer(size(node%position))) - buffer=node%position - nints=size(node%position) + total_num_det=total_num_det+default_stat%number_det_in_each_group(i) - call MPI_FILE_WRITE_AT(fhdet,offset,buffer,nints,getpreal(),status,IERROR) + end do + + number_total_columns=total_num_det*dimen - ewrite(1,*) "after sync position IERROR is:", IERROR - deallocate(buffer) - node => node%next - end do positionloop_cp + node => default_stat%detector_list%first - call update_detectors_options(trim(detectors_cp_filename) // "_det", "binary") + location_to_write=0 - if (fhdet/=0) then - call MPI_FILE_CLOSE(fhdet, IERROR) - if (IERROR/=0) then - ewrite(0,*) "Warning: failed to close .detector checkpoint file open with mpi_file_open" - end if - end if + positionloop_cp: do i=1, default_stat%detector_list%length + offset = location_to_write+(node%id_number-1)*size(node%position)*realsize + ewrite(1,*) "after file set view position IERROR is:", IERROR - ewrite(1, *) "Exiting detectors" + allocate(buffer(size(node%position))) + buffer=node%position + nints=size(node%position) - end subroutine checkpoint_detectors + call MPI_FILE_WRITE_AT(fhdet,offset,buffer,nints,getpreal(),status,IERROR) - subroutine update_detectors_options(filename,format) + ewrite(1,*) "after sync position IERROR is:", IERROR + deallocate(buffer) + node => node%next + end do positionloop_cp - !!< Updates the initial options of the detectors (options tree in diamond) + call update_detectors_options(trim(detectors_cp_filename) // "_det", "binary") - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: format + if (fhdet/=0) then + call MPI_FILE_CLOSE(fhdet, IERROR) + if (IERROR/=0) then + ewrite(0,*) "Warning: failed to close .detector checkpoint file open with mpi_file_open" + end if + end if - integer :: stat, i, python_or_file_dete, python_functions_or_files, static_dete, lagrangian_dete - character(len = FIELD_NAME_LEN), dimension(:), allocatable :: type_detectors - character(len = 254) :: temp_string + ewrite(1, *) "Exiting detectors" - static_dete = option_count("/io/detectors/static_detector") - lagrangian_dete = option_count("/io/detectors/lagrangian_detector") - python_functions_or_files = option_count("/io/detectors/detector_array") - python_or_file_dete = 0 + end subroutine checkpoint_detectors - do i = 0, static_dete-1 - call delete_option("/io/detectors/static_detector[" // int2str(0) // "]") - end do + subroutine update_detectors_options(filename,format) - do i = 0, static_dete-1 - temp_string=default_stat%detector_group_names(i+1) + !!< Updates the initial options of the detectors (options tree in diamond) + + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: format - ewrite(1,*) 'In update_detectors_options static det loop' - ewrite(1,*) temp_string + integer :: stat, i, python_or_file_dete, python_functions_or_files, static_dete, lagrangian_dete + character(len = FIELD_NAME_LEN), dimension(:), allocatable :: type_detectors + character(len = 254) :: temp_string - call set_option_attribute("/io/detectors/static_detector::" // trim(temp_string) // "/from_checkpoint_file/file_name", trim(filename), stat) + static_dete = option_count("/io/detectors/static_detector") + lagrangian_dete = option_count("/io/detectors/lagrangian_detector") + python_functions_or_files = option_count("/io/detectors/detector_array") + python_or_file_dete = 0 - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + do i = 0, static_dete-1 + call delete_option("/io/detectors/static_detector[" // int2str(0) // "]") + end do + + do i = 0, static_dete-1 + temp_string=default_stat%detector_group_names(i+1) + + ewrite(1,*) 'In update_detectors_options static det loop' + ewrite(1,*) temp_string + + call set_option_attribute("/io/detectors/static_detector::" // trim(temp_string) // "/from_checkpoint_file/file_name", trim(filename), stat) + + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then FLAbort("Failed to set detectors options filename when checkpointing detectors with option path " // "/io/detectors/static_detector") - end if + end if - call set_option("/io/detectors/static_detector::" // trim(temp_string) // "/from_checkpoint_file/format/", trim(format), stat) + call set_option("/io/detectors/static_detector::" // trim(temp_string) // "/from_checkpoint_file/format/", trim(format), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then FLAbort("Failed to set detectors options format when checkpointing detectors with option path " // "/io/detectors/static_detector") - end if - end do + end if + end do - do i = 0, lagrangian_dete-1 - call delete_option("/io/detectors/lagrangian_detector[" // int2str(0) // "]") - end do + do i = 0, lagrangian_dete-1 + call delete_option("/io/detectors/lagrangian_detector[" // int2str(0) // "]") + end do - do i = 0, lagrangian_dete-1 + do i = 0, lagrangian_dete-1 - temp_string=default_stat%detector_group_names(i+1+static_dete) + temp_string=default_stat%detector_group_names(i+1+static_dete) - call set_option_attribute("/io/detectors/lagrangian_detector::" // trim(temp_string) // "/from_checkpoint_file/file_name", trim(filename), stat) + call set_option_attribute("/io/detectors/lagrangian_detector::" // trim(temp_string) // "/from_checkpoint_file/file_name", trim(filename), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then FLAbort("Failed to set detectors options filename when checkpointing detectors with option path " // "/io/detectors/lagrangian_detector") - end if + end if - call set_option("/io/detectors/lagrangian_detector::" // trim(temp_string) // "/from_checkpoint_file/format/", trim(format), stat) + call set_option("/io/detectors/lagrangian_detector::" // trim(temp_string) // "/from_checkpoint_file/format/", trim(format), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then FLAbort("Failed to set detectors options format when checkpointing detectors with option path " // "/io/detectors/lagrangian_detector") - end if - end do + end if + end do - allocate(type_detectors(python_functions_or_files)) + allocate(type_detectors(python_functions_or_files)) - do i = 0, python_functions_or_files-1 + do i = 0, python_functions_or_files-1 if (have_option("/io/detectors/detector_array[" // int2str(0) // "]"//"/lagrangian")) then - type_detectors(i+1)='LAGRANGIAN' + type_detectors(i+1)='LAGRANGIAN' else - type_detectors(i+1)='STATIC' + type_detectors(i+1)='STATIC' end if call delete_option("/io/detectors/detector_array[" // int2str(0) // "]") - end do + end do - do i = 0, python_functions_or_files-1 - temp_string=default_stat%detector_group_names(i+1+static_dete+lagrangian_dete) + do i = 0, python_functions_or_files-1 + temp_string=default_stat%detector_group_names(i+1+static_dete+lagrangian_dete) - ewrite(1,*) 'In update_detectors_options' - ewrite(1,*) temp_string + ewrite(1,*) 'In update_detectors_options' + ewrite(1,*) temp_string - ewrite(1,*) 'In update_detectors_options' - ewrite(1,*) temp_string + ewrite(1,*) 'In update_detectors_options' + ewrite(1,*) temp_string - call set_option("/io/detectors/detector_array::" // trim(temp_string) // "/number_of_detectors/", & - & default_stat%number_det_in_each_group(i+1+static_dete+lagrangian_dete), stat = stat) + call set_option("/io/detectors/detector_array::" // trim(temp_string) // "/number_of_detectors/", & + & default_stat%number_det_in_each_group(i+1+static_dete+lagrangian_dete), stat = stat) - ewrite(1,*) 'In update_detectors_options' - ewrite(1,*) default_stat%number_det_in_each_group(i+1+static_dete+lagrangian_dete) + ewrite(1,*) 'In update_detectors_options' + ewrite(1,*) default_stat%number_det_in_each_group(i+1+static_dete+lagrangian_dete) - assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) - ewrite(1,*) 'In update_detectors_options' - ewrite(1,*) default_stat%number_det_in_each_group(i+1+static_dete+lagrangian_dete) + ewrite(1,*) 'In update_detectors_options' + ewrite(1,*) default_stat%number_det_in_each_group(i+1+static_dete+lagrangian_dete) - if (type_detectors(i+1)=='LAGRANGIAN') then - call add_option("/io/detectors/detector_array::" // trim(temp_string) // "/lagrangian", stat = stat) - assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) - else - call add_option("/io/detectors/detector_array::" // trim(temp_string) // "/static", stat = stat) - assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) - end if + if (type_detectors(i+1)=='LAGRANGIAN') then + call add_option("/io/detectors/detector_array::" // trim(temp_string) // "/lagrangian", stat = stat) + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + else + call add_option("/io/detectors/detector_array::" // trim(temp_string) // "/static", stat = stat) + assert(any(stat == (/SPUD_NO_ERROR, SPUD_NEW_KEY_WARNING/))) + end if - call set_option_attribute("/io/detectors/detector_array::" // trim(temp_string) // "/from_checkpoint_file/file_name", trim(filename), stat) + call set_option_attribute("/io/detectors/detector_array::" // trim(temp_string) // "/from_checkpoint_file/file_name", trim(filename), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then FLAbort("Failed to set detectors options filename when checkpointing detectors with option path " // "io/detectors/detector_array") - end if + end if - call set_option("/io/detectors/detector_array::" // trim(temp_string) // "/from_checkpoint_file/format/", trim(format), stat) + call set_option("/io/detectors/detector_array::" // trim(temp_string) // "/from_checkpoint_file/format/", trim(format), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then FLAbort("Failed to set detectors options format when checkpointing detectors with option path " // "/io/detectors/detector_array") - end if - end do - - deallocate(type_detectors) - - end subroutine update_detectors_options - - subroutine checkpoint_state(state, prefix, postfix, cp_no, keep_initial_data, number_of_partitions) - !!< Checkpoint state. - - type(state_type), dimension(:), intent(in) :: state - character(len = *), intent(in) :: prefix - character(len = *), optional, intent(in) :: postfix - integer, optional, intent(in) :: cp_no - !! If present and .true.: do not checkpoint fields that can be reinitialsed and do not - !! checkpoint extruded meshes if the extrusion can be repeated using the initial sizing_function, - !! i.e. if this run has not been started with a checkpointed extruded mesh (extrude/checkpoint_from_file) - logical, optional, intent(in) :: keep_initial_data - !! If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions - - call checkpoint_meshes(state, prefix, postfix, cp_no, keep_initial_data=keep_initial_data, number_of_partitions=number_of_partitions) - call checkpoint_fields(state, prefix, postfix, cp_no, keep_initial_data=keep_initial_data, number_of_partitions=number_of_partitions) - - end subroutine checkpoint_state - - subroutine checkpoint_meshes(state, prefix, postfix, cp_no, keep_initial_data, number_of_partitions) - !!< Checkpoint the meshes in state. Outputs to mesh files with names: - !!< [prefix]_[mesh_name][_cp_no][_postfix][_process].[extention] - !!< where cp_no is optional and the process number is added in parallel. - !!< Also outputs a .halo file if running in parallel. - - type(state_type), dimension(:), intent(in) :: state - character(len = *), intent(in) :: prefix - character(len = *), optional, intent(in) :: postfix - integer, optional, intent(in) :: cp_no - ! if present and true: do not checkpoint extruded meshes that can be re-extruded - logical, optional, intent(in) :: keep_initial_data - !! If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions - - type(vector_field), pointer:: position - character(len = FIELD_NAME_LEN) :: mesh_name, mesh_format - character(len = OPTION_PATH_LEN) :: mesh_path, mesh_filename - integer :: i, n_meshes, stat1, stat2, nparts - type(mesh_type), pointer :: mesh, external_mesh - logical :: from_file, extruded - - assert(len_trim(prefix) > 0) - - if (present(number_of_partitions)) then - nparts = number_of_partitions - else - nparts = getnprocs() - end if - - n_meshes = option_count("/geometry/mesh") - do i = 0, n_meshes - 1 - ! Dump each mesh listed under /geometry/mesh that is from_file - mesh_path = "/geometry/mesh[" // int2str(i) // "]" - - from_file = have_option(trim(mesh_path) // "/from_file") - extruded = have_option(trim(mesh_path) // "/from_mesh/extrude") .and. & - .not. (present_and_true(keep_initial_data) .and. & - .not. have_option(trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file")) - - if(from_file .or. extruded) then - ! Find the mesh (looking in first state) - call get_option(trim(mesh_path) // "/name", mesh_name) - mesh => extract_mesh(state(1), trim(mesh_name)) - - ewrite(2, *) "Checkpointing mesh " // trim(mesh_name) - - ! Construct a new mesh filename - mesh_filename = trim(prefix) // "_" // trim(mesh%name) - if(present(cp_no)) mesh_filename = trim(mesh_filename) // "_" // int2str(cp_no) - if(present_and_nonempty(postfix)) mesh_filename = trim(mesh_filename) // "_" // trim(postfix) - - ! Update the options tree (required for options tree checkpointing) - if (from_file) then - call set_option_attribute(trim(mesh_path) // "/from_file/file_name", trim(mesh_filename)) - call get_option(trim(mesh_path) // "/from_file/format/name", mesh_format) - else if (extruded) then - - ! the mesh format is determined from the external mesh - external_mesh => get_external_mesh(state) - call get_option(trim(external_mesh%option_path) // "/from_file/format/name", mesh_format) - - call set_option_attribute(trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file/format/name", trim(mesh_format), stat=stat1) - call set_option_attribute(trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file/file_name", trim(mesh_filename), stat=stat2) - if ((stat1/=SPUD_NO_ERROR .and. stat1/=SPUD_NEW_KEY_WARNING) .or. & - & (stat2/=SPUD_NO_ERROR .and. stat2/=SPUD_NEW_KEY_WARNING)) then - FLAbort("Failed to modify extrude options for checkpointing.") - end if - end if - - ! Write out the mesh using a suitable coordinate field - if (mesh%name=="CoordinateMesh") then - if (have_option("/mesh_adaptivity/mesh_movement/free_surface")) then - ! we don't want/need to checkpoint the moved mesh, as the mesh movement will again be applied after the restart - ! based on the checkpointed FreeSurface field. - position => extract_vector_field(state(1), "OriginalCoordinate", stat=stat1) - if (stat1/=0) then - ! some cases (e.g. flredecomp) OriginalCoordinate doesn't exist - position => extract_vector_field(state(1), "Coordinate") - end if - else - position => extract_vector_field(state(1), "Coordinate") - end if - else - position => extract_vector_field(state(1), trim(mesh%name)//"Coordinate") - end if - - if(nparts > 1) then - call write_mesh_files(parallel_filename(mesh_filename), mesh_format, position, number_of_partitions=number_of_partitions) - ! Write out the halos - ewrite(2, *) "Checkpointing halos" - call write_halos(mesh_filename, mesh, number_of_partitions=number_of_partitions) - else - ! Write out the mesh - call write_mesh_files(mesh_filename, mesh_format, position, number_of_partitions=number_of_partitions) - end if + end if + end do + deallocate(type_detectors) + + end subroutine update_detectors_options + + subroutine checkpoint_state(state, prefix, postfix, cp_no, keep_initial_data, number_of_partitions) + !!< Checkpoint state. + + type(state_type), dimension(:), intent(in) :: state + character(len = *), intent(in) :: prefix + character(len = *), optional, intent(in) :: postfix + integer, optional, intent(in) :: cp_no + !! If present and .true.: do not checkpoint fields that can be reinitialsed and do not + !! checkpoint extruded meshes if the extrusion can be repeated using the initial sizing_function, + !! i.e. if this run has not been started with a checkpointed extruded mesh (extrude/checkpoint_from_file) + logical, optional, intent(in) :: keep_initial_data + !! If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions + + call checkpoint_meshes(state, prefix, postfix, cp_no, keep_initial_data=keep_initial_data, number_of_partitions=number_of_partitions) + call checkpoint_fields(state, prefix, postfix, cp_no, keep_initial_data=keep_initial_data, number_of_partitions=number_of_partitions) + + end subroutine checkpoint_state + + subroutine checkpoint_meshes(state, prefix, postfix, cp_no, keep_initial_data, number_of_partitions) + !!< Checkpoint the meshes in state. Outputs to mesh files with names: + !!< [prefix]_[mesh_name][_cp_no][_postfix][_process].[extention] + !!< where cp_no is optional and the process number is added in parallel. + !!< Also outputs a .halo file if running in parallel. + + type(state_type), dimension(:), intent(in) :: state + character(len = *), intent(in) :: prefix + character(len = *), optional, intent(in) :: postfix + integer, optional, intent(in) :: cp_no + ! if present and true: do not checkpoint extruded meshes that can be re-extruded + logical, optional, intent(in) :: keep_initial_data + !! If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions + + type(vector_field), pointer:: position + character(len = FIELD_NAME_LEN) :: mesh_name, mesh_format + character(len = OPTION_PATH_LEN) :: mesh_path, mesh_filename + integer :: i, n_meshes, stat1, stat2, nparts + type(mesh_type), pointer :: mesh, external_mesh + logical :: from_file, extruded + + assert(len_trim(prefix) > 0) + + if (present(number_of_partitions)) then + nparts = number_of_partitions + else + nparts = getnprocs() end if - end do - - end subroutine checkpoint_meshes - - subroutine checkpoint_fields(state, prefix, postfix, cp_no, keep_initial_data, number_of_partitions) - !!< Checkpoint the fields in state. Outputs to vtu files with names: - !!< [prefix]_[_state name]_[mesh_name][_cp_no][_postfix][_process].vtu - !!< where the state name is added if multiple states are passed, cp_no is - !!< optional and the process number is added in parallel. - - type(state_type), dimension(:), intent(in) :: state - character(len = *), intent(in) :: prefix - character(len = *), optional, intent(in) :: postfix - integer, optional, intent(in) :: cp_no - ! if present and true: do not checkpoint fields that can be reinitialised - logical, optional, intent(in) :: keep_initial_data - !! If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions - - character(len = OPTION_PATH_LEN) :: vtu_filename - integer :: i, j, k, nparts, n_ps_fields_on_mesh, n_pv_fields_on_mesh, n_pt_fields_on_mesh - type(mesh_type), pointer :: mesh - type(scalar_field), pointer :: s_field - type(scalar_field), dimension(:), allocatable :: ps_fields_on_mesh - type(vector_field), pointer :: positions, v_field - type(vector_field), dimension(:), allocatable :: pv_fields_on_mesh - type(tensor_field), pointer :: t_field - type(tensor_field), dimension(:), allocatable :: pt_fields_on_mesh - - integer :: stat - - assert(len_trim(prefix) > 0) - - if (present(number_of_partitions)) then - nparts = number_of_partitions - else - nparts = getnprocs() - end if - - do i = 1, size(state) - if (have_option("/mesh_adaptivity/mesh_movement/free_surface")) then - ! we don't want/need to checkpoint the moved mesh, as the mesh movement will again be applied after the restart - ! based on the checkpointed FreeSurface field. - positions => extract_vector_field(state(i), "OriginalCoordinate", stat=stat) - if (stat/=0) then - ! some cases (e.g. flredecomp) OriginalCoordinate doesn't exist - positions => extract_vector_field(state(1), "Coordinate") - end if + n_meshes = option_count("/geometry/mesh") + do i = 0, n_meshes - 1 + ! Dump each mesh listed under /geometry/mesh that is from_file + mesh_path = "/geometry/mesh[" // int2str(i) // "]" + + from_file = have_option(trim(mesh_path) // "/from_file") + extruded = have_option(trim(mesh_path) // "/from_mesh/extrude") .and. & + .not. (present_and_true(keep_initial_data) .and. & + .not. have_option(trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file")) + + if(from_file .or. extruded) then + ! Find the mesh (looking in first state) + call get_option(trim(mesh_path) // "/name", mesh_name) + mesh => extract_mesh(state(1), trim(mesh_name)) + + ewrite(2, *) "Checkpointing mesh " // trim(mesh_name) + + ! Construct a new mesh filename + mesh_filename = trim(prefix) // "_" // trim(mesh%name) + if(present(cp_no)) mesh_filename = trim(mesh_filename) // "_" // int2str(cp_no) + if(present_and_nonempty(postfix)) mesh_filename = trim(mesh_filename) // "_" // trim(postfix) + + ! Update the options tree (required for options tree checkpointing) + if (from_file) then + call set_option_attribute(trim(mesh_path) // "/from_file/file_name", trim(mesh_filename)) + call get_option(trim(mesh_path) // "/from_file/format/name", mesh_format) + else if (extruded) then + + ! the mesh format is determined from the external mesh + external_mesh => get_external_mesh(state) + call get_option(trim(external_mesh%option_path) // "/from_file/format/name", mesh_format) + + call set_option_attribute(trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file/format/name", trim(mesh_format), stat=stat1) + call set_option_attribute(trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file/file_name", trim(mesh_filename), stat=stat2) + if ((stat1/=SPUD_NO_ERROR .and. stat1/=SPUD_NEW_KEY_WARNING) .or. & + & (stat2/=SPUD_NO_ERROR .and. stat2/=SPUD_NEW_KEY_WARNING)) then + FLAbort("Failed to modify extrude options for checkpointing.") + end if + end if + + ! Write out the mesh using a suitable coordinate field + if (mesh%name=="CoordinateMesh") then + if (have_option("/mesh_adaptivity/mesh_movement/free_surface")) then + ! we don't want/need to checkpoint the moved mesh, as the mesh movement will again be applied after the restart + ! based on the checkpointed FreeSurface field. + position => extract_vector_field(state(1), "OriginalCoordinate", stat=stat1) + if (stat1/=0) then + ! some cases (e.g. flredecomp) OriginalCoordinate doesn't exist + position => extract_vector_field(state(1), "Coordinate") + end if + else + position => extract_vector_field(state(1), "Coordinate") + end if + else + position => extract_vector_field(state(1), trim(mesh%name)//"Coordinate") + end if + + if(nparts > 1) then + call write_mesh_files(parallel_filename(mesh_filename), mesh_format, position, number_of_partitions=number_of_partitions) + ! Write out the halos + ewrite(2, *) "Checkpointing halos" + call write_halos(mesh_filename, mesh, number_of_partitions=number_of_partitions) + else + ! Write out the mesh + call write_mesh_files(mesh_filename, mesh_format, position, number_of_partitions=number_of_partitions) + end if + + end if + + end do + + end subroutine checkpoint_meshes + + subroutine checkpoint_fields(state, prefix, postfix, cp_no, keep_initial_data, number_of_partitions) + !!< Checkpoint the fields in state. Outputs to vtu files with names: + !!< [prefix]_[_state name]_[mesh_name][_cp_no][_postfix][_process].vtu + !!< where the state name is added if multiple states are passed, cp_no is + !!< optional and the process number is added in parallel. + + type(state_type), dimension(:), intent(in) :: state + character(len = *), intent(in) :: prefix + character(len = *), optional, intent(in) :: postfix + integer, optional, intent(in) :: cp_no + ! if present and true: do not checkpoint fields that can be reinitialised + logical, optional, intent(in) :: keep_initial_data + !! If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions + + character(len = OPTION_PATH_LEN) :: vtu_filename + integer :: i, j, k, nparts, n_ps_fields_on_mesh, n_pv_fields_on_mesh, n_pt_fields_on_mesh + type(mesh_type), pointer :: mesh + type(scalar_field), pointer :: s_field + type(scalar_field), dimension(:), allocatable :: ps_fields_on_mesh + type(vector_field), pointer :: positions, v_field + type(vector_field), dimension(:), allocatable :: pv_fields_on_mesh + type(tensor_field), pointer :: t_field + type(tensor_field), dimension(:), allocatable :: pt_fields_on_mesh + + integer :: stat + + assert(len_trim(prefix) > 0) + + if (present(number_of_partitions)) then + nparts = number_of_partitions else - if (have_option("/mesh_adaptivity/mesh_movement")) then - ! for other mesh movement schemes we should probably write out the "moved" mesh to retain that information - ! However if the checkpointed mesh is not the "CoordinateMesh", it will have its own MeshNameCoordinate field - ! that hasn't moved; leading to a failure to restart from the checkpoint. This is only one of the possible problems - ! generally this functionality is untested. - ewrite(0,*) "WARNING: using mesh_movement with checkpointing is untested and likely broken." - end if - positions => extract_vector_field(state(i), "Coordinate") + nparts = getnprocs() end if - do j = 1, size(state(i)%meshes) - mesh => state(i)%meshes(j)%ptr - - ! Construct a new field checkpoint filename - vtu_filename = trim(prefix) - if(size(state) > 1) vtu_filename = trim(vtu_filename) // "_" // trim(state(i)%name) - vtu_filename = trim(vtu_filename) // "_" // trim(mesh%name) - if(present(cp_no)) vtu_filename = trim(vtu_filename) // "_" // int2str(cp_no) - if(present_and_nonempty(postfix)) vtu_filename = trim(vtu_filename) // "_" // trim(postfix) - if(nparts > 1) then - vtu_filename = trim(vtu_filename) // ".pvtu" - else - vtu_filename = trim(vtu_filename) // ".vtu" - end if - - if(associated(state(i)%scalar_fields)) then - allocate(ps_fields_on_mesh(size(state(i)%scalar_fields))) - else - allocate(ps_fields_on_mesh(0)) - end if - if(associated(state(i)%vector_fields)) then - allocate(pv_fields_on_mesh(size(state(i)%vector_fields))) - else - allocate(pv_fields_on_mesh(0)) - end if - if(associated(state(i)%tensor_fields)) then - allocate(pt_fields_on_mesh(size(state(i)%tensor_fields))) - else - allocate(pt_fields_on_mesh(0)) - end if - n_ps_fields_on_mesh = 0 - n_pv_fields_on_mesh = 0 - n_pt_fields_on_mesh = 0 - - if(associated(state(i)%scalar_fields)) then - do k = 1, size(state(i)%scalar_fields) - s_field => state(i)%scalar_fields(k)%ptr - ! If the mesh names match - if(trim(s_field%mesh%name) == trim(mesh%name)) then - ! and the meshes are the same - if(s_field%mesh == mesh) then - ! and either the field is prognostic, prescribed and interpolated, or diagnostic and checkpointed - if(have_option(trim(s_field%option_path) // "/prognostic") & - & .or. (have_option(trim(s_field%option_path) // "/prescribed") & - & .and. interpolate_field(s_field)) & - & .or. have_option(trim(s_field%option_path) // "/diagnostic/output/checkpoint")) then - ! but not aliased - if(.not. aliased(s_field)) then - - if(have_option(trim(complete_field_path(s_field%option_path)) // "/exclude_from_checkpointing")) cycle - ! needs_initial_mesh indicates the field is from_file (i.e. we're dealing with a checkpoint) - if(present_and_true(keep_initial_data) .and. (.not. needs_initial_mesh(s_field) .and. .not. have_option(trim(s_field%option_path) // "/diagnostic/output/checkpoint"))) cycle - - ewrite(2, *) "Checkpointing scalar field " // trim(s_field%name) // " in state " // trim(state(i)%name) & - & // "on the " // trim(mesh%name) - - n_ps_fields_on_mesh = n_ps_fields_on_mesh + 1 - ps_fields_on_mesh(n_ps_fields_on_mesh) = s_field - - if(have_option(trim(s_field%option_path) // "/prognostic")) then - ewrite(2, *) "Updating initial conditions for " // trim(s_field%name) - call update_initial_condition_options(trim(s_field%option_path), trim(vtu_filename), "vtu") - else if (have_option(trim(s_field%option_path) // "/prescribed").and. & - & interpolate_field(s_field)) then - ewrite(2, *) "Updating values for " // trim(s_field%name) - call update_value_options(trim(s_field%option_path), trim(vtu_filename), "vtu") - else if (have_option(trim(s_field%option_path) // "/diagnostic/output/checkpoint").and. & - & interpolate_field(s_field)) then - ewrite(2, *) "... diagnostic field" - else - FLAbort("Can only checkpoint prognostic or prescribed (with interpolation options) fields.") - end if + + do i = 1, size(state) + if (have_option("/mesh_adaptivity/mesh_movement/free_surface")) then + ! we don't want/need to checkpoint the moved mesh, as the mesh movement will again be applied after the restart + ! based on the checkpointed FreeSurface field. + positions => extract_vector_field(state(i), "OriginalCoordinate", stat=stat) + if (stat/=0) then + ! some cases (e.g. flredecomp) OriginalCoordinate doesn't exist + positions => extract_vector_field(state(1), "Coordinate") + end if + else + if (have_option("/mesh_adaptivity/mesh_movement")) then + ! for other mesh movement schemes we should probably write out the "moved" mesh to retain that information + ! However if the checkpointed mesh is not the "CoordinateMesh", it will have its own MeshNameCoordinate field + ! that hasn't moved; leading to a failure to restart from the checkpoint. This is only one of the possible problems + ! generally this functionality is untested. + ewrite(0,*) "WARNING: using mesh_movement with checkpointing is untested and likely broken." + end if + positions => extract_vector_field(state(i), "Coordinate") + end if + do j = 1, size(state(i)%meshes) + mesh => state(i)%meshes(j)%ptr + + ! Construct a new field checkpoint filename + vtu_filename = trim(prefix) + if(size(state) > 1) vtu_filename = trim(vtu_filename) // "_" // trim(state(i)%name) + vtu_filename = trim(vtu_filename) // "_" // trim(mesh%name) + if(present(cp_no)) vtu_filename = trim(vtu_filename) // "_" // int2str(cp_no) + if(present_and_nonempty(postfix)) vtu_filename = trim(vtu_filename) // "_" // trim(postfix) + if(nparts > 1) then + vtu_filename = trim(vtu_filename) // ".pvtu" + else + vtu_filename = trim(vtu_filename) // ".vtu" + end if + + if(associated(state(i)%scalar_fields)) then + allocate(ps_fields_on_mesh(size(state(i)%scalar_fields))) + else + allocate(ps_fields_on_mesh(0)) + end if + if(associated(state(i)%vector_fields)) then + allocate(pv_fields_on_mesh(size(state(i)%vector_fields))) + else + allocate(pv_fields_on_mesh(0)) + end if + if(associated(state(i)%tensor_fields)) then + allocate(pt_fields_on_mesh(size(state(i)%tensor_fields))) + else + allocate(pt_fields_on_mesh(0)) + end if + n_ps_fields_on_mesh = 0 + n_pv_fields_on_mesh = 0 + n_pt_fields_on_mesh = 0 + + if(associated(state(i)%scalar_fields)) then + do k = 1, size(state(i)%scalar_fields) + s_field => state(i)%scalar_fields(k)%ptr + ! If the mesh names match + if(trim(s_field%mesh%name) == trim(mesh%name)) then + ! and the meshes are the same + if(s_field%mesh == mesh) then + ! and either the field is prognostic, prescribed and interpolated, or diagnostic and checkpointed + if(have_option(trim(s_field%option_path) // "/prognostic") & + & .or. (have_option(trim(s_field%option_path) // "/prescribed") & + & .and. interpolate_field(s_field)) & + & .or. have_option(trim(s_field%option_path) // "/diagnostic/output/checkpoint")) then + ! but not aliased + if(.not. aliased(s_field)) then + + if(have_option(trim(complete_field_path(s_field%option_path)) // "/exclude_from_checkpointing")) cycle + ! needs_initial_mesh indicates the field is from_file (i.e. we're dealing with a checkpoint) + if(present_and_true(keep_initial_data) .and. (.not. needs_initial_mesh(s_field) .and. .not. have_option(trim(s_field%option_path) // "/diagnostic/output/checkpoint"))) cycle + + ewrite(2, *) "Checkpointing scalar field " // trim(s_field%name) // " in state " // trim(state(i)%name) & + & // "on the " // trim(mesh%name) + + n_ps_fields_on_mesh = n_ps_fields_on_mesh + 1 + ps_fields_on_mesh(n_ps_fields_on_mesh) = s_field + + if(have_option(trim(s_field%option_path) // "/prognostic")) then + ewrite(2, *) "Updating initial conditions for " // trim(s_field%name) + call update_initial_condition_options(trim(s_field%option_path), trim(vtu_filename), "vtu") + else if (have_option(trim(s_field%option_path) // "/prescribed").and. & + & interpolate_field(s_field)) then + ewrite(2, *) "Updating values for " // trim(s_field%name) + call update_value_options(trim(s_field%option_path), trim(vtu_filename), "vtu") + else if (have_option(trim(s_field%option_path) // "/diagnostic/output/checkpoint").and. & + & interpolate_field(s_field)) then + ewrite(2, *) "... diagnostic field" + else + FLAbort("Can only checkpoint prognostic or prescribed (with interpolation options) fields.") + end if + end if + end if + end if end if - end if - end if + end do end if - end do - end if - - if(associated(state(i)%vector_fields)) then - do k = 1, size(state(i)%vector_fields) - v_field => state(i)%vector_fields(k)%ptr - ! If the mesh names match - if(trim(v_field%mesh%name) == trim(mesh%name)) then - ! and the meshes are the same - if(v_field%mesh == mesh) then - ! and either the field is prognostic, prescribed and interpolated, or diagnostic and checkpointed - if(have_option(trim(v_field%option_path) // "/prognostic") & - & .or. (have_option(trim(v_field%option_path) // "/prescribed") & - & .and. interpolate_field(v_field)) & - & .or. have_option(trim(v_field%option_path) // "/diagnostic/output/checkpoint")) then - ! but not aliased - if(.not. aliased(v_field)) then - - if(have_option(trim(complete_field_path(v_field%option_path)) // "/exclude_from_checkpointing")) cycle - ! needs_initial_mesh indicates the field is from_file (i.e. we're dealing with a checkpoint) - if(present_and_true(keep_initial_data) .and. (.not. needs_initial_mesh(v_field) .and. .not. have_option(trim(v_field%option_path) // "/diagnostic/output/checkpoint"))) cycle - - ewrite(2, *) "Checkpointing vector field " // trim(v_field%name) // " in state " // trim(state(i)%name) & - & // "on the " // trim(mesh%name) - - n_pv_fields_on_mesh = n_pv_fields_on_mesh + 1 - pv_fields_on_mesh(n_pv_fields_on_mesh) = v_field - - if(have_option(trim(v_field%option_path) // "/prognostic")) then - ewrite(2, *) "Updating initial conditions for " // trim(v_field%name) - call update_initial_condition_options(trim(v_field%option_path), trim(vtu_filename), "vtu") - else if (have_option(trim(v_field%option_path) // "/prescribed").and. & - & interpolate_field(v_field)) then - ewrite(2, *) "Updating values for " // trim(v_field%name) - call update_value_options(trim(v_field%option_path), trim(vtu_filename), "vtu") - else if (have_option(trim(v_field%option_path) // "/diagnostic/output/checkpoint").and. & - & interpolate_field(v_field)) then - ewrite(2, *) "... diagnostic field" - else - FLAbort("Can only checkpoint prognostic or prescribed (with interpolation options) fields.") - end if + + if(associated(state(i)%vector_fields)) then + do k = 1, size(state(i)%vector_fields) + v_field => state(i)%vector_fields(k)%ptr + ! If the mesh names match + if(trim(v_field%mesh%name) == trim(mesh%name)) then + ! and the meshes are the same + if(v_field%mesh == mesh) then + ! and either the field is prognostic, prescribed and interpolated, or diagnostic and checkpointed + if(have_option(trim(v_field%option_path) // "/prognostic") & + & .or. (have_option(trim(v_field%option_path) // "/prescribed") & + & .and. interpolate_field(v_field)) & + & .or. have_option(trim(v_field%option_path) // "/diagnostic/output/checkpoint")) then + ! but not aliased + if(.not. aliased(v_field)) then + + if(have_option(trim(complete_field_path(v_field%option_path)) // "/exclude_from_checkpointing")) cycle + ! needs_initial_mesh indicates the field is from_file (i.e. we're dealing with a checkpoint) + if(present_and_true(keep_initial_data) .and. (.not. needs_initial_mesh(v_field) .and. .not. have_option(trim(v_field%option_path) // "/diagnostic/output/checkpoint"))) cycle + + ewrite(2, *) "Checkpointing vector field " // trim(v_field%name) // " in state " // trim(state(i)%name) & + & // "on the " // trim(mesh%name) + + n_pv_fields_on_mesh = n_pv_fields_on_mesh + 1 + pv_fields_on_mesh(n_pv_fields_on_mesh) = v_field + + if(have_option(trim(v_field%option_path) // "/prognostic")) then + ewrite(2, *) "Updating initial conditions for " // trim(v_field%name) + call update_initial_condition_options(trim(v_field%option_path), trim(vtu_filename), "vtu") + else if (have_option(trim(v_field%option_path) // "/prescribed").and. & + & interpolate_field(v_field)) then + ewrite(2, *) "Updating values for " // trim(v_field%name) + call update_value_options(trim(v_field%option_path), trim(vtu_filename), "vtu") + else if (have_option(trim(v_field%option_path) // "/diagnostic/output/checkpoint").and. & + & interpolate_field(v_field)) then + ewrite(2, *) "... diagnostic field" + else + FLAbort("Can only checkpoint prognostic or prescribed (with interpolation options) fields.") + end if + end if + end if + end if end if - end if - end if + end do end if - end do - end if - - if(associated(state(i)%tensor_fields)) then - do k = 1, size(state(i)%tensor_fields) - t_field => state(i)%tensor_fields(k)%ptr - ! If the mesh names match - if(trim(t_field%mesh%name) == trim(mesh%name)) then - ! and the meshes are the same - if(t_field%mesh == mesh) then - ! and either the field is prognostic, prescribed and interpolated, or diagnostic and checkpointed - if(have_option(trim(t_field%option_path) // "/prognostic") & - & .or. (have_option(trim(t_field%option_path) // "/prescribed") & - & .and. interpolate_field(t_field)) & - & .or. have_option(trim(t_field%option_path) // "/diagnostic/output/checkpoint")) then - ! but not aliased - if(.not. aliased(t_field)) then - - if(have_option(trim(complete_field_path(t_field%option_path)) // "/exclude_from_checkpointing")) cycle - ! needs_initial_mesh indicates the field is from_file (i.e. we're dealing with a checkpoint) - if(present_and_true(keep_initial_data) .and. (.not. needs_initial_mesh(t_field) .and. .not. have_option(trim(t_field%option_path) // "/diagnostic/output/checkpoint"))) cycle - - ewrite(2, *) "Checkpointing tensor field " // trim(t_field%name) // " in state " // trim(state(i)%name) & - & // "on the " // trim(mesh%name) - - n_pt_fields_on_mesh = n_pt_fields_on_mesh + 1 - pt_fields_on_mesh(n_pt_fields_on_mesh) = t_field - - if(have_option(trim(t_field%option_path) // "/prognostic")) then - ewrite(2, *) "Updating initial conditions for " // trim(t_field%name) - call update_initial_condition_options(trim(t_field%option_path), trim(vtu_filename), "vtu") - else if (have_option(trim(t_field%option_path) // "/prescribed").and. & - & interpolate_field(t_field)) then - ewrite(2, *) "Updating values for " // trim(t_field%name) - call update_value_options(trim(t_field%option_path), trim(vtu_filename), "vtu") - else if (have_option(trim(t_field%option_path) // "/diagnostic/output/checkpoint").and. & - & interpolate_field(t_field)) then - ewrite(2, *) "... diagnostic field" - else - FLAbort("Can only checkpoint prognostic or prescribed (with interpolation options) fields.") - end if + + if(associated(state(i)%tensor_fields)) then + do k = 1, size(state(i)%tensor_fields) + t_field => state(i)%tensor_fields(k)%ptr + ! If the mesh names match + if(trim(t_field%mesh%name) == trim(mesh%name)) then + ! and the meshes are the same + if(t_field%mesh == mesh) then + ! and either the field is prognostic, prescribed and interpolated, or diagnostic and checkpointed + if(have_option(trim(t_field%option_path) // "/prognostic") & + & .or. (have_option(trim(t_field%option_path) // "/prescribed") & + & .and. interpolate_field(t_field)) & + & .or. have_option(trim(t_field%option_path) // "/diagnostic/output/checkpoint")) then + ! but not aliased + if(.not. aliased(t_field)) then + + if(have_option(trim(complete_field_path(t_field%option_path)) // "/exclude_from_checkpointing")) cycle + ! needs_initial_mesh indicates the field is from_file (i.e. we're dealing with a checkpoint) + if(present_and_true(keep_initial_data) .and. (.not. needs_initial_mesh(t_field) .and. .not. have_option(trim(t_field%option_path) // "/diagnostic/output/checkpoint"))) cycle + + ewrite(2, *) "Checkpointing tensor field " // trim(t_field%name) // " in state " // trim(state(i)%name) & + & // "on the " // trim(mesh%name) + + n_pt_fields_on_mesh = n_pt_fields_on_mesh + 1 + pt_fields_on_mesh(n_pt_fields_on_mesh) = t_field + + if(have_option(trim(t_field%option_path) // "/prognostic")) then + ewrite(2, *) "Updating initial conditions for " // trim(t_field%name) + call update_initial_condition_options(trim(t_field%option_path), trim(vtu_filename), "vtu") + else if (have_option(trim(t_field%option_path) // "/prescribed").and. & + & interpolate_field(t_field)) then + ewrite(2, *) "Updating values for " // trim(t_field%name) + call update_value_options(trim(t_field%option_path), trim(vtu_filename), "vtu") + else if (have_option(trim(t_field%option_path) // "/diagnostic/output/checkpoint").and. & + & interpolate_field(t_field)) then + ewrite(2, *) "... diagnostic field" + else + FLAbort("Can only checkpoint prognostic or prescribed (with interpolation options) fields.") + end if + end if + end if + end if end if - end if - end if + end do end if - end do - end if - if(n_ps_fields_on_mesh + n_pv_fields_on_mesh + n_pt_fields_on_mesh > 0) then - call vtk_write_fields(vtu_filename, position = positions, model = mesh, & - & sfields = ps_fields_on_mesh(:n_ps_fields_on_mesh), vfields = pv_fields_on_mesh(:n_pv_fields_on_mesh), & - & tfields = pt_fields_on_mesh(:n_pt_fields_on_mesh), number_of_partitions=number_of_partitions, stat=stat) - end if - - deallocate(ps_fields_on_mesh) - deallocate(pv_fields_on_mesh) - deallocate(pt_fields_on_mesh) + if(n_ps_fields_on_mesh + n_pv_fields_on_mesh + n_pt_fields_on_mesh > 0) then + call vtk_write_fields(vtu_filename, position = positions, model = mesh, & + & sfields = ps_fields_on_mesh(:n_ps_fields_on_mesh), vfields = pv_fields_on_mesh(:n_pv_fields_on_mesh), & + & tfields = pt_fields_on_mesh(:n_pt_fields_on_mesh), number_of_partitions=number_of_partitions, stat=stat) + end if + + deallocate(ps_fields_on_mesh) + deallocate(pv_fields_on_mesh) + deallocate(pt_fields_on_mesh) + end do end do - end do - contains + contains - subroutine update_initial_condition_options(path, filename, format) - !!< Updates the initial condition options for a prognostic field with - !!< options path path + subroutine update_initial_condition_options(path, filename, format) + !!< Updates the initial condition options for a prognostic field with + !!< options path path - character(len = *), intent(in) :: path - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: format + character(len = *), intent(in) :: path + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: format - integer :: stat, ic, nics + integer :: stat, ic, nics - nics = option_count(trim(path) // "/prognostic/initial_condition") - do ic = 0, nics-1 ! do while seemed to break, don't know why - call delete_option(trim(path) // "/prognostic/initial_condition[" // int2str(0) // "]") - end do - call set_option_attribute(trim(path) // "/prognostic/initial_condition::WholeMesh/from_file/file_name", trim(filename), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then - FLAbort("Failed to set initial condition filename when checkpointing field with option path " // trim(path)) - end if - call set_option_attribute(trim(path) // "/prognostic/initial_condition::WholeMesh/from_file/format/name", trim(format), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then - FLAbort("Failed to set initial condition format when checkpointing field with option path " // trim(path)) - end if + nics = option_count(trim(path) // "/prognostic/initial_condition") + do ic = 0, nics-1 ! do while seemed to break, don't know why + call delete_option(trim(path) // "/prognostic/initial_condition[" // int2str(0) // "]") + end do + call set_option_attribute(trim(path) // "/prognostic/initial_condition::WholeMesh/from_file/file_name", trim(filename), stat) + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + FLAbort("Failed to set initial condition filename when checkpointing field with option path " // trim(path)) + end if + call set_option_attribute(trim(path) // "/prognostic/initial_condition::WholeMesh/from_file/format/name", trim(format), stat) + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then + FLAbort("Failed to set initial condition format when checkpointing field with option path " // trim(path)) + end if - end subroutine update_initial_condition_options + end subroutine update_initial_condition_options - subroutine update_value_options(path, filename, format) - !!< Updates the value options for a prescribed field with - !!< options path path + subroutine update_value_options(path, filename, format) + !!< Updates the value options for a prescribed field with + !!< options path path - character(len = *), intent(in) :: path - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: format + character(len = *), intent(in) :: path + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: format - integer :: stat, value, nvalues + integer :: stat, value, nvalues - nvalues = option_count(trim(path) // "/prescribed/value") - do value = 0, nvalues-1 - call delete_option(trim(path) // "/prescribed/value[" // int2str(0) // "]") - end do - call set_option_attribute(trim(path) // "/prescribed/value::WholeMesh/from_file/file_name", trim(filename), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then - FLAbort("Failed to set value filename when checkpointing field with option path " // trim(path)) - end if - call set_option_attribute(trim(path) // "/prescribed/value::WholeMesh/from_file/format/name", trim(format), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then - FLAbort("Failed to set value format when checkpointing field with option path " // trim(path)) - end if + nvalues = option_count(trim(path) // "/prescribed/value") + do value = 0, nvalues-1 + call delete_option(trim(path) // "/prescribed/value[" // int2str(0) // "]") + end do + call set_option_attribute(trim(path) // "/prescribed/value::WholeMesh/from_file/file_name", trim(filename), stat) + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + FLAbort("Failed to set value filename when checkpointing field with option path " // trim(path)) + end if + call set_option_attribute(trim(path) // "/prescribed/value::WholeMesh/from_file/format/name", trim(format), stat) + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING) then + FLAbort("Failed to set value format when checkpointing field with option path " // trim(path)) + end if - end subroutine update_value_options + end subroutine update_value_options - end subroutine checkpoint_fields + end subroutine checkpoint_fields - subroutine checkpoint_options(prefix, postfix, cp_no, protect_simulation_name) - !!< Checkpoint the entire options tree. Outputs to an FLML file with name: - !!< [prefix][_cp_no][_postfix].flml - !!< where cp_no is optional. - !!< Note that the simulation name in the checkpointed FLML file has, by - !!< default, "_checkpoint" appended to it. + subroutine checkpoint_options(prefix, postfix, cp_no, protect_simulation_name) + !!< Checkpoint the entire options tree. Outputs to an FLML file with name: + !!< [prefix][_cp_no][_postfix].flml + !!< where cp_no is optional. + !!< Note that the simulation name in the checkpointed FLML file has, by + !!< default, "_checkpoint" appended to it. - character(len = *), intent(in) :: prefix - character(len = *), intent(in) :: postfix - integer, optional, intent(in) :: cp_no - !! If present and .false., do not protect the simulation_name when - !! checkpointing the options tree - logical, optional, intent(in) :: protect_simulation_name + character(len = *), intent(in) :: prefix + character(len = *), intent(in) :: postfix + integer, optional, intent(in) :: cp_no + !! If present and .false., do not protect the simulation_name when + !! checkpointing the options tree + logical, optional, intent(in) :: protect_simulation_name - character(len = OPTION_PATH_LEN) :: simulation_name, options_file_filename - logical :: lprotect_simulation_name + character(len = OPTION_PATH_LEN) :: simulation_name, options_file_filename + logical :: lprotect_simulation_name - ewrite(2, *) "Checkpointing options tree" + ewrite(2, *) "Checkpointing options tree" - assert(len_trim(prefix) > 0) + assert(len_trim(prefix) > 0) - lprotect_simulation_name = .not. present_and_false(protect_simulation_name) + lprotect_simulation_name = .not. present_and_false(protect_simulation_name) - if(lprotect_simulation_name) then - call get_option("/simulation_name", simulation_name) + if(lprotect_simulation_name) then + call get_option("/simulation_name", simulation_name) - ! Temporarily change the simulation name. This is used to protect - ! checkpointed files (as these will necessarily themselves have - ! checkpointing enabled). - call set_option("/simulation_name", trim(simulation_name) // "_checkpoint") - end if + ! Temporarily change the simulation name. This is used to protect + ! checkpointed files (as these will necessarily themselves have + ! checkpointing enabled). + call set_option("/simulation_name", trim(simulation_name) // "_checkpoint") + end if - ! Construct a new options file filename - options_file_filename = trim(prefix) - if(present(cp_no)) options_file_filename = trim(options_file_filename) // "_" // int2str(cp_no) - if(present_and_nonempty(postfix)) options_file_filename = trim(options_file_filename) // "_" // trim(postfix) - options_file_filename = trim(options_file_filename) // ".flml" + ! Construct a new options file filename + options_file_filename = trim(prefix) + if(present(cp_no)) options_file_filename = trim(options_file_filename) // "_" // int2str(cp_no) + if(present_and_nonempty(postfix)) options_file_filename = trim(options_file_filename) // "_" // trim(postfix) + options_file_filename = trim(options_file_filename) // ".flml" - call write_options(options_file_filename) + call write_options(options_file_filename) - if(lprotect_simulation_name) then - ! Revert the simulation name - call set_option("/simulation_name", trim(simulation_name)) - end if + if(lprotect_simulation_name) then + ! Revert the simulation name + call set_option("/simulation_name", trim(simulation_name)) + end if - end subroutine checkpoint_options + end subroutine checkpoint_options - subroutine checkpoint_check_options - !!< Check checkpointing related options + subroutine checkpoint_check_options + !!< Check checkpointing related options - integer :: cp_period, stat + integer :: cp_period, stat - if(.not. have_option("/io/checkpointing")) then - ! Nothing to check - return - end if + if(.not. have_option("/io/checkpointing")) then + ! Nothing to check + return + end if - ewrite(2, *) "Checking checkpointing options" + ewrite(2, *) "Checking checkpointing options" #ifndef HAVE_VTK - ewrite(0, *) "Warning: Checkpointing is enabled, but Fluidity has been compiled without VTK support" + ewrite(0, *) "Warning: Checkpointing is enabled, but Fluidity has been compiled without VTK support" #endif - call get_option("/io/checkpointing/checkpoint_period_in_dumps", cp_period, stat) - if(stat /= 0) then - FLExit("Checkpoint period (in dumps) required for checkpointing") - end if - if(cp_period < 0) then - FLExit("Checkpoint period (in dumps) cannot be negative") - end if + call get_option("/io/checkpointing/checkpoint_period_in_dumps", cp_period, stat) + if(stat /= 0) then + FLExit("Checkpoint period (in dumps) required for checkpointing") + end if + if(cp_period < 0) then + FLExit("Checkpoint period (in dumps) cannot be negative") + end if - ewrite(2, *) "Finished checking checkpointing options" + ewrite(2, *) "Finished checking checkpointing options" - end subroutine checkpoint_check_options + end subroutine checkpoint_check_options end module checkpoint diff --git a/femtools/Colouring.F90 b/femtools/Colouring.F90 index b4038034b9..3b08781516 100644 --- a/femtools/Colouring.F90 +++ b/femtools/Colouring.F90 @@ -27,231 +27,231 @@ #include "fdebug.h" module colouring - use fldebug - use data_structures - use global_parameters, only : topology_mesh_name, NUM_COLOURINGS, & - COLOURING_CG1, COLOURING_DG0, COLOURING_DG2, & - COLOURING_DG1 - use sparse_tools - use fields - use state_module, only : state_type, extract_mesh - use field_options, only : find_linear_parent_mesh - use sparsity_patterns_meshes, only : get_csr_sparsity_secondorder, & - get_csr_sparsity_firstorder - implicit none + use fldebug + use data_structures + use global_parameters, only : topology_mesh_name, NUM_COLOURINGS, & + COLOURING_CG1, COLOURING_DG0, COLOURING_DG2, & + COLOURING_DG1 + use sparse_tools + use fields + use state_module, only : state_type, extract_mesh + use field_options, only : find_linear_parent_mesh + use sparsity_patterns_meshes, only : get_csr_sparsity_secondorder, & + get_csr_sparsity_firstorder + implicit none - private + private - public :: colour_sparsity, verify_colour_sparsity, verify_colour_ispsparsity - public :: colour_sets, get_mesh_colouring, mat_sparsity_to_isp_sparsity + public :: colour_sparsity, verify_colour_sparsity, verify_colour_ispsparsity + public :: colour_sets, get_mesh_colouring, mat_sparsity_to_isp_sparsity contains - ! Converts the matrix sparsity to an isp sparsity which can then be coloured to reduce the number - ! of function evaluations needed to compute a (sparse) Jacobian via differencing. - ! This function returns S^T*S if S is the given sparsity matrix. - ! The resulting sparsity matrix is symmetric. - function mat_sparsity_to_isp_sparsity(sparsity_in) result(sparsity_out) - type(csr_sparsity), intent(in) :: sparsity_in - type(csr_sparsity) :: sparsity_out - type(csr_sparsity) :: sparsity_in_T + ! Converts the matrix sparsity to an isp sparsity which can then be coloured to reduce the number + ! of function evaluations needed to compute a (sparse) Jacobian via differencing. + ! This function returns S^T*S if S is the given sparsity matrix. + ! The resulting sparsity matrix is symmetric. + function mat_sparsity_to_isp_sparsity(sparsity_in) result(sparsity_out) + type(csr_sparsity), intent(in) :: sparsity_in + type(csr_sparsity) :: sparsity_out + type(csr_sparsity) :: sparsity_in_T - sparsity_in_T=transpose(sparsity_in) - sparsity_out=matmul(sparsity_in_T, sparsity_in) - call deallocate(sparsity_in_T) + sparsity_in_T=transpose(sparsity_in) + sparsity_out=matmul(sparsity_in_T, sparsity_in) + call deallocate(sparsity_in_T) - end function mat_sparsity_to_isp_sparsity + end function mat_sparsity_to_isp_sparsity - ! Return a colouring of a mesh that is thread safe for a particular - ! assembly type. All elements with the same colour in the returned - ! colouring are safe to assemble concurrently. - ! - ! For a given mesh topology there are four possible colourings - ! - ! o Level 1 node: For CG assembly - ! [COLOURING_CG1] - ! o Level 0 element: For DG assembly without viscosity - ! [COLOURING_DG0] - ! o Level 1 element: For assembly with cjc's trace elements - ! [COLOURING_DG1] - ! o Level 2 element: For DG assembly with viscosity - ! [COLOURING_DG2] - ! - ! These colourings don't change between adapts, so we cache them on - ! the topology mesh on first construction and subsequently pull - ! them out of the cache. - subroutine get_mesh_colouring(state, mesh, colouring_type, colouring) - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh - integer, intent(in) :: colouring_type - type(integer_set), dimension(:), pointer, intent(out) :: colouring - type(mesh_type), pointer :: topology - integer :: i + ! Return a colouring of a mesh that is thread safe for a particular + ! assembly type. All elements with the same colour in the returned + ! colouring are safe to assemble concurrently. + ! + ! For a given mesh topology there are four possible colourings + ! + ! o Level 1 node: For CG assembly + ! [COLOURING_CG1] + ! o Level 0 element: For DG assembly without viscosity + ! [COLOURING_DG0] + ! o Level 1 element: For assembly with cjc's trace elements + ! [COLOURING_DG1] + ! o Level 2 element: For DG assembly with viscosity + ! [COLOURING_DG2] + ! + ! These colourings don't change between adapts, so we cache them on + ! the topology mesh on first construction and subsequently pull + ! them out of the cache. + subroutine get_mesh_colouring(state, mesh, colouring_type, colouring) + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh + integer, intent(in) :: colouring_type + type(integer_set), dimension(:), pointer, intent(out) :: colouring + type(mesh_type), pointer :: topology + integer :: i - topology => extract_mesh(state, topology_mesh_name) + topology => extract_mesh(state, topology_mesh_name) - colouring => topology%colourings(colouring_type)%sets - if (associated(colouring)) return + colouring => topology%colourings(colouring_type)%sets + if (associated(colouring)) return - ! If we reach here then the colouring has not yet been constructed. + ! If we reach here then the colouring has not yet been constructed. #ifdef _OPENMP - ! Use the sparsity patterns to find the dependency stencil. - ! Greedily colour the sparsity graph - ! Map this colouring back onto elements - p0_mesh = piecewise_constant_mesh(topology, "P0Mesh") + ! Use the sparsity patterns to find the dependency stencil. + ! Greedily colour the sparsity graph + ! Map this colouring back onto elements + p0_mesh = piecewise_constant_mesh(topology, "P0Mesh") - select case(colouring_type) - case(COLOURING_CG1) - ! Level 1 node - sparsity => get_csr_sparsity_secondorder(state, p0_mesh, topology) - case(COLOURING_DG0) - ! Easy, just one colour - ! So nothing to do here. - case(COLOURING_DG2) - ! Level 2 element - sparsity => get_csr_sparsity_secondorder(state, p0_mesh, p0_mesh) - case(COLOURING_DG1) - ! Level 1 element - sparsity => get_csr_sparsity_firstorder(state, p0_mesh, p0_mesh) - case default - FLAbort('Invalid colouring type specified') - end select - ! Colour the resulting sparsity - ! Need to special case for DG_NO_VISCOSITY - if ( colouring_type .eq. COLOURING_DG0 ) then - allocate(colouring(1)) - call allocate(colouring) - do i=1, element_count(mesh) - call insert(colouring(1), i) - end do - else - call colour_sparsity(sparsity, p0_mesh, element_colours, ncolours) - allocate(colouring(ncolours)) - colouring = colour_sets(sparsity, element_colours, ncolours) - call deallocate(element_colours) - end if - call deallocate(p0_mesh) - topology%colourings(colouring_type)%sets => colouring + select case(colouring_type) + case(COLOURING_CG1) + ! Level 1 node + sparsity => get_csr_sparsity_secondorder(state, p0_mesh, topology) + case(COLOURING_DG0) + ! Easy, just one colour + ! So nothing to do here. + case(COLOURING_DG2) + ! Level 2 element + sparsity => get_csr_sparsity_secondorder(state, p0_mesh, p0_mesh) + case(COLOURING_DG1) + ! Level 1 element + sparsity => get_csr_sparsity_firstorder(state, p0_mesh, p0_mesh) + case default + FLAbort('Invalid colouring type specified') + end select + ! Colour the resulting sparsity + ! Need to special case for DG_NO_VISCOSITY + if ( colouring_type .eq. COLOURING_DG0 ) then + allocate(colouring(1)) + call allocate(colouring) + do i=1, element_count(mesh) + call insert(colouring(1), i) + end do + else + call colour_sparsity(sparsity, p0_mesh, element_colours, ncolours) + allocate(colouring(ncolours)) + colouring = colour_sets(sparsity, element_colours, ncolours) + call deallocate(element_colours) + end if + call deallocate(p0_mesh) + topology%colourings(colouring_type)%sets => colouring #else - allocate(colouring(1)) - call allocate(colouring) - do i=1, element_count(mesh) - call insert(colouring(1), i) - end do - topology%colourings(colouring_type)%sets => colouring + allocate(colouring(1)) + call allocate(colouring) + do i=1, element_count(mesh) + call insert(colouring(1), i) + end do + topology%colourings(colouring_type)%sets => colouring #endif - end subroutine get_mesh_colouring + end subroutine get_mesh_colouring - ! This routine colours a graph using the greedy approach. - ! It takes as argument the sparsity of the adjacency matrix of the graph - ! (i.e. the matrix is node X nodes and symmetric for undirected graphs). - subroutine colour_sparsity(sparsity, mesh, node_colour, no_colours) - type(csr_sparsity), intent(in) :: sparsity - type(mesh_type), intent(inout) :: mesh - type(scalar_field), intent(out) :: node_colour - integer, intent(out) :: no_colours + ! This routine colours a graph using the greedy approach. + ! It takes as argument the sparsity of the adjacency matrix of the graph + ! (i.e. the matrix is node X nodes and symmetric for undirected graphs). + subroutine colour_sparsity(sparsity, mesh, node_colour, no_colours) + type(csr_sparsity), intent(in) :: sparsity + type(mesh_type), intent(inout) :: mesh + type(scalar_field), intent(out) :: node_colour + integer, intent(out) :: no_colours - integer, dimension(:), pointer:: cols - type(integer_set) :: neigh_colours - integer :: i, node + integer, dimension(:), pointer:: cols + type(integer_set) :: neigh_colours + integer :: i, node - call allocate(node_colour, mesh, "NodeColouring") + call allocate(node_colour, mesh, "NodeColouring") - ! Set the first node colour - call set(node_colour, 1, 1.0) - no_colours = 1 + ! Set the first node colour + call set(node_colour, 1, 1.0) + no_colours = 1 - ! Colour remaining nodes. - do node=2, size(sparsity,1) - call allocate(neigh_colours) - ! Determine colour of neighbours. - cols => row_m_ptr(sparsity, node) - do i=1, size(cols) - if(cols(i) row_m_ptr(sparsity, node) + do i=1, size(cols) + if(cols(i)no_colours) then - no_colours = i - end if - exit - end if - end do - call deallocate(neigh_colours) - end do + ! Find the lowest unused colour in neighbourhood. + do i=1, no_colours+1 + if(.not.has_value(neigh_colours, i)) then + call set(node_colour, node, float(i)) + if(i>no_colours) then + no_colours = i + end if + exit + end if + end do + call deallocate(neigh_colours) + end do - end subroutine colour_sparsity + end subroutine colour_sparsity - ! Checks if a sparsity colouring is valid. - function verify_colour_sparsity(sparsity, node_colour) result(valid) - type(csr_sparsity), intent(in) :: sparsity - type(scalar_field), intent(in) :: node_colour - logical :: valid - integer :: i, node - real :: my_colour - integer, dimension(:), pointer:: cols + ! Checks if a sparsity colouring is valid. + function verify_colour_sparsity(sparsity, node_colour) result(valid) + type(csr_sparsity), intent(in) :: sparsity + type(scalar_field), intent(in) :: node_colour + logical :: valid + integer :: i, node + real :: my_colour + integer, dimension(:), pointer:: cols - valid=.true. - do node=1, size(sparsity, 1) - cols => row_m_ptr(sparsity, node) - my_colour=node_val(node_colour, node) - ! Each nonzero column is a neighbour of node, so lets make sure that they do not have the same colour. - do i=1, size(cols) - if (cols(i) row_m_ptr(sparsity, node) + my_colour=node_val(node_colour, node) + ! Each nonzero column is a neighbour of node, so lets make sure that they do not have the same colour. + do i=1, size(cols) + if (cols(i) row_m_ptr(mat_sparsity, row) - do i=1, size(cols) - if (has_value(neigh_colours, nint(node_val(node_colour, cols(i))))) then - valid=.false. - end if - call insert(neigh_colours, nint(node_val(node_colour,cols(i)))) + valid=.true. + do row=1, size(mat_sparsity, 1) + call allocate(neigh_colours) + cols => row_m_ptr(mat_sparsity, row) + do i=1, size(cols) + if (has_value(neigh_colours, nint(node_val(node_colour, cols(i))))) then + valid=.false. + end if + call insert(neigh_colours, nint(node_val(node_colour,cols(i)))) + end do + call deallocate(neigh_colours) end do - call deallocate(neigh_colours) - end do - end function verify_colour_ispsparsity + end function verify_colour_ispsparsity - ! with above colour_sparsity, we get map:node_id --> colour - ! now we want map: colour --> node_ids - function colour_sets(sparsity, node_colour, no_colours) result(clr_sets) - type(csr_sparsity), intent(in) :: sparsity - type(scalar_field), intent(in) :: node_colour - integer, intent(in) :: no_colours - type(integer_set), dimension(no_colours) :: clr_sets - integer :: node + ! with above colour_sparsity, we get map:node_id --> colour + ! now we want map: colour --> node_ids + function colour_sets(sparsity, node_colour, no_colours) result(clr_sets) + type(csr_sparsity), intent(in) :: sparsity + type(scalar_field), intent(in) :: node_colour + integer, intent(in) :: no_colours + type(integer_set), dimension(no_colours) :: clr_sets + integer :: node - call allocate(clr_sets) - do node=1, size(sparsity, 1) - call insert(clr_sets(nint(node_val(node_colour, node))), node) - end do + call allocate(clr_sets) + do node=1, size(sparsity, 1) + call insert(clr_sets(nint(node_val(node_colour, node))), node) + end do - end function colour_sets + end function colour_sets end module colouring diff --git a/femtools/Conservative_interpolation.F90 b/femtools/Conservative_interpolation.F90 index 937f3b3b1f..d290e2ce53 100644 --- a/femtools/Conservative_interpolation.F90 +++ b/femtools/Conservative_interpolation.F90 @@ -4,1113 +4,1113 @@ module conservative_interpolation_module - use FLDebug - use vector_tools - use global_parameters, only : FIELD_NAME_LEN, OPTION_PATH_LEN - use quadrature - use futils - use element_numbering, only: FAMILY_SIMPLEX - use elements - use spud - use data_structures - use sparse_tools - use tensors - use transform_elements - use adjacency_lists - use unittest_tools - use linked_lists - use tetrahedron_intersection_module - use supermesh_construction - use fetools - use parallel_fields, only: node_owned - use intersection_finder_module - use fields - use state_module - use field_options, only: complete_field_path - use meshdiagnostics - use sparsity_patterns - use vtk_interfaces - use halos - use boundary_conditions - use interpolation_module - use sparse_matrices_fields - use solvers - use bound_field_module - use diagnostic_fields - implicit none - - interface interpolation_galerkin - module procedure interpolation_galerkin_scalars, interpolation_galerkin_single_state, & - interpolation_galerkin_multiple_states - end interface - - interface grandy_projection - module procedure grandy_projection_scalars, grandy_projection_multiple_states - end interface - - public :: interpolation_galerkin, grandy_projection - - private + use FLDebug + use vector_tools + use global_parameters, only : FIELD_NAME_LEN, OPTION_PATH_LEN + use quadrature + use futils + use element_numbering, only: FAMILY_SIMPLEX + use elements + use spud + use data_structures + use sparse_tools + use tensors + use transform_elements + use adjacency_lists + use unittest_tools + use linked_lists + use tetrahedron_intersection_module + use supermesh_construction + use fetools + use parallel_fields, only: node_owned + use intersection_finder_module + use fields + use state_module + use field_options, only: complete_field_path + use meshdiagnostics + use sparsity_patterns + use vtk_interfaces + use halos + use boundary_conditions + use interpolation_module + use sparse_matrices_fields + use solvers + use bound_field_module + use diagnostic_fields + implicit none + + interface interpolation_galerkin + module procedure interpolation_galerkin_scalars, interpolation_galerkin_single_state, & + interpolation_galerkin_multiple_states + end interface + + interface grandy_projection + module procedure grandy_projection_scalars, grandy_projection_multiple_states + end interface + + public :: interpolation_galerkin, grandy_projection + + private #ifdef DUMP_SUPERMESH_INTERSECTIONS - integer :: dump_idx + integer :: dump_idx #endif - contains +contains - subroutine galerkin_projection_inner_loop(ele_B, little_mass_matrix, detJ, local_rhs, conservation_tolerance, stat, & - field_counts, old_fields, old_position, new_fields, new_position, & - map_BA, inversion_matrices_A, supermesh_shape) + subroutine galerkin_projection_inner_loop(ele_B, little_mass_matrix, detJ, local_rhs, conservation_tolerance, stat, & + field_counts, old_fields, old_position, new_fields, new_position, & + map_BA, inversion_matrices_A, supermesh_shape) - integer, intent(in) :: ele_B - real, dimension(:,:,:), intent(inout) :: little_mass_matrix - real, dimension(:), intent(out) :: detJ - real, dimension(:,:,:), intent(inout) :: local_rhs - real, intent(in) :: conservation_tolerance - integer, intent(out) :: stat + integer, intent(in) :: ele_B + real, dimension(:,:,:), intent(inout) :: little_mass_matrix + real, dimension(:), intent(out) :: detJ + real, dimension(:,:,:), intent(inout) :: local_rhs + real, intent(in) :: conservation_tolerance + integer, intent(out) :: stat - integer, dimension(:), intent(in) :: field_counts + integer, dimension(:), intent(in) :: field_counts - type(scalar_field), dimension(:,:), intent(in) :: old_fields - type(vector_field), intent(in) :: old_position + type(scalar_field), dimension(:,:), intent(in) :: old_fields + type(vector_field), intent(in) :: old_position - type(scalar_field), dimension(:,:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position + type(scalar_field), dimension(:,:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position - type(ilist), dimension(:), intent(in) :: map_BA - real, dimension(:, :, :) :: inversion_matrices_A - type(element_type), intent(inout) :: supermesh_shape + type(ilist), dimension(:), intent(in) :: map_BA + real, dimension(:, :, :) :: inversion_matrices_A + type(element_type), intent(inout) :: supermesh_shape - real, dimension(ele_loc(new_position, ele_B), ele_loc(new_position, ele_B)) :: inversion_matrix_B, inversion_matrix_A - real, dimension(ele_ngi(new_position, ele_B)) :: detwei_B - real, dimension(supermesh_shape%ngi) :: detwei_C - type(inode), pointer :: llnode + real, dimension(ele_loc(new_position, ele_B), ele_loc(new_position, ele_B)) :: inversion_matrix_B, inversion_matrix_A + real, dimension(ele_ngi(new_position, ele_B)) :: detwei_B + real, dimension(supermesh_shape%ngi) :: detwei_C + type(inode), pointer :: llnode - real :: vol_B, vols_C - integer :: ele_A, ele_C, nloc, dim, j, k, l, field, mesh, mesh_count - type(vector_field) :: intersection - type(element_type), pointer :: B_shape + real :: vol_B, vols_C + integer :: ele_A, ele_C, nloc, dim, j, k, l, field, mesh, mesh_count + type(vector_field) :: intersection + type(element_type), pointer :: B_shape - real, dimension(new_position%dim+1, supermesh_shape%ngi) :: pos_at_quad_B, pos_at_quad_A, tmp_pos_at_quad - real, dimension(size(local_rhs, 3), supermesh_shape%ngi) :: basis_at_quad_B, basis_at_quad_A - real, dimension(size(local_rhs, 3),size(local_rhs, 3)) :: mat, mat_int + real, dimension(new_position%dim+1, supermesh_shape%ngi) :: pos_at_quad_B, pos_at_quad_A, tmp_pos_at_quad + real, dimension(size(local_rhs, 3), supermesh_shape%ngi) :: basis_at_quad_B, basis_at_quad_A + real, dimension(size(local_rhs, 3),size(local_rhs, 3)) :: mat, mat_int - real, dimension(new_position%dim, supermesh_shape%ngi) :: intersection_val_at_quad - real, dimension(new_position%dim, new_position%dim, ele_ngi(new_position, 1)) :: invJ - real, dimension(new_position%dim, ele_loc(new_position, ele_B)) :: pos_B + real, dimension(new_position%dim, supermesh_shape%ngi) :: intersection_val_at_quad + real, dimension(new_position%dim, new_position%dim, ele_ngi(new_position, 1)) :: invJ + real, dimension(new_position%dim, ele_loc(new_position, ele_B)) :: pos_B - type(plane_type), dimension(4) :: planes_B - type(tet_type) :: tet_A, tet_B - integer :: lstat - logical :: empty_intersection + type(plane_type), dimension(4) :: planes_B + type(tet_type) :: tet_A, tet_B + integer :: lstat + logical :: empty_intersection - real, dimension(size(local_rhs, 3)) :: tmp_local_rhs, tmp_ele_val + real, dimension(size(local_rhs, 3)) :: tmp_local_rhs, tmp_ele_val - local_rhs = 0.0 + local_rhs = 0.0 - mesh_count = size(field_counts) - dim = mesh_dim(new_position) + mesh_count = size(field_counts) + dim = mesh_dim(new_position) - if (dim == 3) then - tet_B%V = ele_val(new_position, ele_B) - planes_B = get_planes(tet_B) - else - pos_B = ele_val(new_position, ele_B) - end if + if (dim == 3) then + tet_B%V = ele_val(new_position, ele_B) + planes_B = get_planes(tet_B) + else + pos_B = ele_val(new_position, ele_B) + end if - ! First thing: assemble and invert the inversion matrix. - call local_coords_matrix(new_position, ele_B, inversion_matrix_B) - inversion_matrix_B = transpose(inversion_matrix_B) + ! First thing: assemble and invert the inversion matrix. + call local_coords_matrix(new_position, ele_B, inversion_matrix_B) + inversion_matrix_B = transpose(inversion_matrix_B) - ! Second thing: assemble the mass matrix of B on the left. - call compute_inverse_jacobian(new_position, ele_B, invJ=invJ, detJ=detJ, detwei=detwei_B) + ! Second thing: assemble the mass matrix of B on the left. + call compute_inverse_jacobian(new_position, ele_B, invJ=invJ, detJ=detJ, detwei=detwei_B) - do mesh = 1, mesh_count - if(field_counts(mesh)>0) then - B_shape => ele_shape(new_fields(mesh,1),1) - nloc = B_shape%loc - little_mass_matrix(mesh, :nloc, :nloc) = shape_shape(B_shape, B_shape, detwei_B) - end if - end do - - ! llnode is looping over the intersecting elements for this ele_B - llnode => map_BA(ele_B)%firstnode - - vol_B = sum(detwei_B) - vols_C = 0.0 - - ! loop over the intersecting elements - do while (associated(llnode)) - ele_A = llnode%value - ! but we only need that mapping for this ele_B now, so just compute it now - if (dim == 3 .and. (intersector_exactness .eqv. .false.)) then - tet_A%V = ele_val(old_position, ele_A) - call intersect_tets(tet_A, planes_B, supermesh_shape, stat=lstat, output=intersection) - if (lstat == 1) then - llnode => llnode%next - cycle - end if - else - intersection = intersect_elements(old_position, ele_A, pos_B, supermesh_shape, empty_intersection=empty_intersection) - if (empty_intersection) then - llnode => llnode%next - cycle - end if - end if + do mesh = 1, mesh_count + if(field_counts(mesh)>0) then + B_shape => ele_shape(new_fields(mesh,1),1) + nloc = B_shape%loc + little_mass_matrix(mesh, :nloc, :nloc) = shape_shape(B_shape, B_shape, detwei_B) + end if + end do + + ! llnode is looping over the intersecting elements for this ele_B + llnode => map_BA(ele_B)%firstnode + + vol_B = sum(detwei_B) + vols_C = 0.0 + + ! loop over the intersecting elements + do while (associated(llnode)) + ele_A = llnode%value + ! but we only need that mapping for this ele_B now, so just compute it now + if (dim == 3 .and. (intersector_exactness .eqv. .false.)) then + tet_A%V = ele_val(old_position, ele_A) + call intersect_tets(tet_A, planes_B, supermesh_shape, stat=lstat, output=intersection) + if (lstat == 1) then + llnode => llnode%next + cycle + end if + else + intersection = intersect_elements(old_position, ele_A, pos_B, supermesh_shape, empty_intersection=empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if + end if #ifdef DUMP_SUPERMESH_INTERSECTIONS - if (ele_count(intersection) /= 0) then - call vtk_write_fields("intersection", dump_idx, intersection, intersection%mesh) - dump_idx = dump_idx + 1 - end if + if (ele_count(intersection) /= 0) then + call vtk_write_fields("intersection", dump_idx, intersection, intersection%mesh) + dump_idx = dump_idx + 1 + end if #endif - ! Loop over the supermesh elements, evaluate the basis functions at the - ! quadrature points and integrate. - do ele_C=1,ele_count(intersection) - intersection_val_at_quad = ele_val_at_quad(intersection, ele_C) - ! Compute the local coordinates in ele_B of the quadrature points of ele_C: - tmp_pos_at_quad(1:dim, :) = intersection_val_at_quad - tmp_pos_at_quad(dim+1, :) = 1.0 + ! Loop over the supermesh elements, evaluate the basis functions at the + ! quadrature points and integrate. + do ele_C=1,ele_count(intersection) + intersection_val_at_quad = ele_val_at_quad(intersection, ele_C) + ! Compute the local coordinates in ele_B of the quadrature points of ele_C: + tmp_pos_at_quad(1:dim, :) = intersection_val_at_quad + tmp_pos_at_quad(dim+1, :) = 1.0 #ifdef INLINE_MATMUL - forall (j=1:dim+1) - forall (k=1:supermesh_shape%ngi) - pos_at_quad_B(j, k) = sum(inversion_matrix_B(:, j) * tmp_pos_at_quad(:, k)) - end forall - end forall + forall (j=1:dim+1) + forall (k=1:supermesh_shape%ngi) + pos_at_quad_B(j, k) = sum(inversion_matrix_B(:, j) * tmp_pos_at_quad(:, k)) + end forall + end forall #else - pos_at_quad_B = matmul(inversion_matrix_B, tmp_pos_at_quad) + pos_at_quad_B = matmul(inversion_matrix_B, tmp_pos_at_quad) #endif - ! Compute the local coordinates in ele_A of the quadrature points of ele_C: - tmp_pos_at_quad(1:dim, :) = intersection_val_at_quad - tmp_pos_at_quad(dim+1, :) = 1.0 + ! Compute the local coordinates in ele_A of the quadrature points of ele_C: + tmp_pos_at_quad(1:dim, :) = intersection_val_at_quad + tmp_pos_at_quad(dim+1, :) = 1.0 #ifdef INLINE_MATMUL - inversion_matrix_A = transpose(inversion_matrices_A(:, :, ele_A)) - forall (j=1:dim+1) - forall (k=1:supermesh_shape%ngi) - pos_at_quad_A(j, k) = sum(inversion_matrix_A(:, j) * tmp_pos_at_quad(:, k)) - end forall - end forall + inversion_matrix_A = transpose(inversion_matrices_A(:, :, ele_A)) + forall (j=1:dim+1) + forall (k=1:supermesh_shape%ngi) + pos_at_quad_A(j, k) = sum(inversion_matrix_A(:, j) * tmp_pos_at_quad(:, k)) + end forall + end forall #else - pos_at_quad_A = matmul(inversion_matrices_A(:, :, ele_A), tmp_pos_at_quad) + pos_at_quad_A = matmul(inversion_matrices_A(:, :, ele_A), tmp_pos_at_quad) #endif - call transform_to_physical(intersection, ele_C, detwei_C) - - vols_C = vols_C + sum(detwei_C) - - do mesh = 1, mesh_count - if(field_counts(mesh)>0) then - B_shape => ele_shape(new_fields(mesh,1),1) - nloc = B_shape%loc - ! This is an inlined eval_shape, optimised for P0 and P1 - ! Evaluate the basis functions at the local coordinates - basis_at_quad_A = 0.0 - basis_at_quad_B = 0.0 - if (element_degree(new_fields(mesh,1),ele_B)==0) then - basis_at_quad_A(:nloc,:) = 1.0 - basis_at_quad_B(:nloc,:) = 1.0 - elseif (element_degree(new_fields(mesh,1),ele_B)==1) then - basis_at_quad_A(:nloc,:) = pos_at_quad_A - basis_at_quad_B(:nloc,:) = pos_at_quad_B - else - do j=1,ele_ngi(intersection, ele_C) - basis_at_quad_A(:nloc, j) = eval_shape(B_shape, pos_at_quad_A(:, j)) - basis_at_quad_B(:nloc, j) = eval_shape(B_shape, pos_at_quad_B(:, j)) - end do - end if + call transform_to_physical(intersection, ele_C, detwei_C) + + vols_C = vols_C + sum(detwei_C) + + do mesh = 1, mesh_count + if(field_counts(mesh)>0) then + B_shape => ele_shape(new_fields(mesh,1),1) + nloc = B_shape%loc + ! This is an inlined eval_shape, optimised for P0 and P1 + ! Evaluate the basis functions at the local coordinates + basis_at_quad_A = 0.0 + basis_at_quad_B = 0.0 + if (element_degree(new_fields(mesh,1),ele_B)==0) then + basis_at_quad_A(:nloc,:) = 1.0 + basis_at_quad_B(:nloc,:) = 1.0 + elseif (element_degree(new_fields(mesh,1),ele_B)==1) then + basis_at_quad_A(:nloc,:) = pos_at_quad_A + basis_at_quad_B(:nloc,:) = pos_at_quad_B + else + do j=1,ele_ngi(intersection, ele_C) + basis_at_quad_A(:nloc, j) = eval_shape(B_shape, pos_at_quad_A(:, j)) + basis_at_quad_B(:nloc, j) = eval_shape(B_shape, pos_at_quad_B(:, j)) + end do + end if - ! Combined outer_product and tensormul_3_1 to see if it is faster. - ! This is sort of like a mixed shape_shape. - ! Here we assemble a little local part of the mixed mass matrix. - mat = 0.0 - mat_int = 0.0 - do j=1,ele_ngi(intersection, ele_C) - forall (k=1:nloc,l=1:nloc) - mat(k, l) = mat(k, l) + detwei_C(j) * basis_at_quad_B(k, j) * basis_at_quad_A(l, j) - end forall - end do + ! Combined outer_product and tensormul_3_1 to see if it is faster. + ! This is sort of like a mixed shape_shape. + ! Here we assemble a little local part of the mixed mass matrix. + mat = 0.0 + mat_int = 0.0 + do j=1,ele_ngi(intersection, ele_C) + forall (k=1:nloc,l=1:nloc) + mat(k, l) = mat(k, l) + detwei_C(j) * basis_at_quad_B(k, j) * basis_at_quad_A(l, j) + end forall + end do - ! And now we apply that to the field to give the RHS contribution to the Galerkin - ! projection. - do field=1,field_counts(mesh) + ! And now we apply that to the field to give the RHS contribution to the Galerkin + ! projection. + do field=1,field_counts(mesh) #ifdef INLINE_MATMUL - tmp_ele_val(:nloc) = ele_val(old_fields(mesh,field), ele_A) - forall (j=1:nloc) - tmp_local_rhs(j) = sum(mat(j, :nloc) * tmp_ele_val(:nloc)) - end forall - local_rhs(mesh,field,:nloc) = local_rhs(mesh,field,:nloc) + tmp_local_rhs(:nloc) + tmp_ele_val(:nloc) = ele_val(old_fields(mesh,field), ele_A) + forall (j=1:nloc) + tmp_local_rhs(j) = sum(mat(j, :nloc) * tmp_ele_val(:nloc)) + end forall + local_rhs(mesh,field,:nloc) = local_rhs(mesh,field,:nloc) + tmp_local_rhs(:nloc) #else - local_rhs(mesh,field,:nloc) = local_rhs(mesh,field,:nloc) +& - matmul(mat(:nloc,:nloc), ele_val(old_fields(mesh,field), ele_A)) + local_rhs(mesh,field,:nloc) = local_rhs(mesh,field,:nloc) +& + matmul(mat(:nloc,:nloc), ele_val(old_fields(mesh,field), ele_A)) #endif + end do + end if end do - end if - end do - end do + end do - llnode => llnode%next - call deallocate(intersection) - end do + llnode => llnode%next + call deallocate(intersection) + end do - ! Check for supermeshing failures. - if (abs(vol_B - vols_C)/vol_B > conservation_tolerance .and. & + ! Check for supermeshing failures. + if (abs(vol_B - vols_C)/vol_B > conservation_tolerance .and. & #ifdef DOUBLEP - & abs(vol_B - vols_C) > 100.0 * 1.0e-12) then + & abs(vol_B - vols_C) > 100.0 * 1.0e-12) then #else - & abs(vol_B - vols_C) > 100.0 * epsilon(0.0)) then + & abs(vol_B - vols_C) > 100.0 * epsilon(0.0)) then #endif - ewrite(0,*) 'sum(detwei_B) = ', vol_B, ', all sum(detwei_C) = ', vols_C - stat = 1 - else - stat = 0 - end if - - end subroutine galerkin_projection_inner_loop - - subroutine interpolation_galerkin_scalars(old_fields_state, old_position, new_fields_state, new_position, map_BA, force_bounded) - type(state_type), dimension(:), intent(in) :: old_fields_state - type(vector_field), intent(in) :: old_position - - type(state_type), dimension(:), intent(inout) :: new_fields_state - type(vector_field), intent(in) :: new_position - type(ilist), dimension(:), intent(in), optional, target :: map_BA - logical, intent(in), optional :: force_bounded - - integer :: ele_B - integer :: ele_A - integer :: name, no_names, priority, f, field, field2, max_field_count - - type(scalar_field), dimension(:,:), allocatable :: old_fields, new_fields - integer, dimension(size(old_fields_state)) :: field_counts - - type(scalar_field), dimension(:,:), allocatable :: named_fields, named_rhs - character(len=FIELD_NAME_LEN), dimension(:), allocatable :: field_names - integer, dimension(:), allocatable :: named_counts, priorities, named_indices - integer, dimension(:,:), allocatable :: tmp_named_indices - - ! We want to compute the mixed mass matrix M^{BA}. - ! But that's huge. So, we compute a part of a row (not even the whole row) - ! and multiply it by a part of the solution on the old mesh A - ! to get a component of the RHS of the matrix we want to solve. - real, dimension(:,:,:), allocatable :: local_rhs - real, dimension(:,:), allocatable :: little_rhs - type(scalar_field), dimension(:,:), allocatable :: rhs - ! For each element in B, we will need to identify the local coordinates in B - ! of the positions of the gauss points of all its children C elements. - ! So we'll need to assemble and invert that matrix (the global-to-local inversion matrix): - real, dimension(ele_loc(new_position, 1), ele_loc(new_position, 1), ele_count(old_position)) :: inversion_matrices_A - real, dimension(:,:,:), allocatable :: little_mass_matrix - real, dimension(:,:,:), allocatable :: little_inverse_mass_matrix, little_inverse_mass_matrix_copy - - integer :: dim - type(ilist), dimension(:), pointer :: lmap_BA - type(quadrature_type) :: supermesh_quad - type(element_type) :: supermesh_shape - real :: int_old, int_new, cons_err, current_time - logical, dimension(size(old_fields_state)) :: dg - - type(csr_matrix), dimension(:), allocatable :: M_B - type(csr_sparsity) :: M_B_sparsity - type(scalar_field), dimension(:), allocatable :: M_B_L - type(scalar_field) :: inverse_M_B_L - - ! Boundedness stuff - logical, dimension(:,:), allocatable :: bounded, lumped - logical, dimension(:), allocatable :: coupled - type(scalar_field) :: bounded_soln, max_bound, min_bound - type(csr_sparsity), pointer :: nnlist - integer :: node_B - integer, dimension(:), pointer :: patch - - real :: upper_bound, lower_bound - integer, dimension(:), pointer :: ele_nodes_B - integer :: stat, statp - logical :: l_apply_globally, u_apply_globally - - logical :: l_force_bounded - - integer :: max_loc, max_degree, nloc - integer :: mesh, mesh_count - - real :: conservation_tolerance, tmp_tol - - type(element_type), pointer :: shape_B - real, dimension(ele_ngi(new_position, 1)) :: detJ - integer :: j - - logical :: new_positions_simplicial - type(integer_set), dimension(:,:), allocatable :: bc_nodes - character(len=FIELD_NAME_LEN) :: bctype - integer, dimension(:), pointer :: surface_node_list - logical, dimension(:, :), allocatable :: force_bc - integer :: bc - - logical :: not_halo_2_element - - ewrite(1, *) "In interpolation_galerkin_scalars" - - stat = 0 - if(present(force_bounded)) then - l_force_bounded = force_bounded - else - l_force_bounded = .false. - end if - - ! Linear positions -- definitely linear positions. - assert(old_position%mesh%shape%degree == 1) - assert(continuity(old_position) >= 0) - assert(continuity(new_position) >= 0) - - mesh_count = size(old_fields_state) - max_field_count = 0 - field_counts = 0 - do mesh = 1, mesh_count - field_counts(mesh) = scalar_field_count(old_fields_state(mesh)) - max_field_count = max(max_field_count, scalar_field_count(old_fields_state(mesh))) - end do - allocate(bounded(mesh_count, max_field_count)) - bounded = .false. - allocate(lumped(mesh_count, max_field_count)) - lumped = .false. - allocate(old_fields(mesh_count, max_field_count)) - allocate(new_fields(mesh_count, max_field_count)) - allocate(force_bc(mesh_count, max_field_count)) - allocate(bc_nodes(mesh_count, max_field_count)) - - shape_B => ele_shape(new_position, 1) - new_positions_simplicial = (shape_B%numbering%family == FAMILY_SIMPLEX) - - dim = mesh_dim(new_position) - - dg = .false. - max_degree = 0 - max_loc = 0 - conservation_tolerance = 1.0 - do mesh = 1, size(old_fields_state) - if(field_counts(mesh)>0) then - - do field = 1, field_counts(mesh) - old_fields(mesh, field) = extract_scalar_field(old_fields_state(mesh), field) - new_fields(mesh, field) = extract_scalar_field(new_fields_state(mesh), field) - call zero(new_fields(mesh, field)) - bounded(mesh, field) = l_force_bounded.or.& - have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & - "/galerkin_projection/continuous/bounded[0]") - lumped(mesh, field) = have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & - "/galerkin_projection/continuous/lump_mass_matrix") - call get_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & - "/galerkin_projection/supermesh_conservation/tolerance", tmp_tol, default = 0.001) - ! Let's check for a relative area/volume loss of 0.1% if none is specified - conservation_tolerance = min(conservation_tolerance, tmp_tol) - - force_bc(mesh, field) = have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) & - & // "/galerkin_projection/honour_strong_boundary_conditions") - if (force_bc(mesh, field)) then - - if (.not. has_boundary_condition(new_fields(mesh, field), "dirichlet")) then - ewrite(0, *) "Warning: For field: " // trim(new_fields(mesh, field)%name) - ewrite(0, *) "Warning: Asked to honour strong boundary conditions through the Galerkin projection without any such BCs" - end if + ewrite(0,*) 'sum(detwei_B) = ', vol_B, ', all sum(detwei_C) = ', vols_C + stat = 1 + else + stat = 0 + end if - call set_dirichlet_consistent(new_fields(mesh, field)) + end subroutine galerkin_projection_inner_loop + + subroutine interpolation_galerkin_scalars(old_fields_state, old_position, new_fields_state, new_position, map_BA, force_bounded) + type(state_type), dimension(:), intent(in) :: old_fields_state + type(vector_field), intent(in) :: old_position + + type(state_type), dimension(:), intent(inout) :: new_fields_state + type(vector_field), intent(in) :: new_position + type(ilist), dimension(:), intent(in), optional, target :: map_BA + logical, intent(in), optional :: force_bounded + + integer :: ele_B + integer :: ele_A + integer :: name, no_names, priority, f, field, field2, max_field_count + + type(scalar_field), dimension(:,:), allocatable :: old_fields, new_fields + integer, dimension(size(old_fields_state)) :: field_counts + + type(scalar_field), dimension(:,:), allocatable :: named_fields, named_rhs + character(len=FIELD_NAME_LEN), dimension(:), allocatable :: field_names + integer, dimension(:), allocatable :: named_counts, priorities, named_indices + integer, dimension(:,:), allocatable :: tmp_named_indices + + ! We want to compute the mixed mass matrix M^{BA}. + ! But that's huge. So, we compute a part of a row (not even the whole row) + ! and multiply it by a part of the solution on the old mesh A + ! to get a component of the RHS of the matrix we want to solve. + real, dimension(:,:,:), allocatable :: local_rhs + real, dimension(:,:), allocatable :: little_rhs + type(scalar_field), dimension(:,:), allocatable :: rhs + ! For each element in B, we will need to identify the local coordinates in B + ! of the positions of the gauss points of all its children C elements. + ! So we'll need to assemble and invert that matrix (the global-to-local inversion matrix): + real, dimension(ele_loc(new_position, 1), ele_loc(new_position, 1), ele_count(old_position)) :: inversion_matrices_A + real, dimension(:,:,:), allocatable :: little_mass_matrix + real, dimension(:,:,:), allocatable :: little_inverse_mass_matrix, little_inverse_mass_matrix_copy + + integer :: dim + type(ilist), dimension(:), pointer :: lmap_BA + type(quadrature_type) :: supermesh_quad + type(element_type) :: supermesh_shape + real :: int_old, int_new, cons_err, current_time + logical, dimension(size(old_fields_state)) :: dg + + type(csr_matrix), dimension(:), allocatable :: M_B + type(csr_sparsity) :: M_B_sparsity + type(scalar_field), dimension(:), allocatable :: M_B_L + type(scalar_field) :: inverse_M_B_L + + ! Boundedness stuff + logical, dimension(:,:), allocatable :: bounded, lumped + logical, dimension(:), allocatable :: coupled + type(scalar_field) :: bounded_soln, max_bound, min_bound + type(csr_sparsity), pointer :: nnlist + integer :: node_B + integer, dimension(:), pointer :: patch + + real :: upper_bound, lower_bound + integer, dimension(:), pointer :: ele_nodes_B + integer :: stat, statp + logical :: l_apply_globally, u_apply_globally + + logical :: l_force_bounded + + integer :: max_loc, max_degree, nloc + integer :: mesh, mesh_count + + real :: conservation_tolerance, tmp_tol + + type(element_type), pointer :: shape_B + real, dimension(ele_ngi(new_position, 1)) :: detJ + integer :: j + + logical :: new_positions_simplicial + type(integer_set), dimension(:,:), allocatable :: bc_nodes + character(len=FIELD_NAME_LEN) :: bctype + integer, dimension(:), pointer :: surface_node_list + logical, dimension(:, :), allocatable :: force_bc + integer :: bc + + logical :: not_halo_2_element + + ewrite(1, *) "In interpolation_galerkin_scalars" + + stat = 0 + if(present(force_bounded)) then + l_force_bounded = force_bounded + else + l_force_bounded = .false. + end if + + ! Linear positions -- definitely linear positions. + assert(old_position%mesh%shape%degree == 1) + assert(continuity(old_position) >= 0) + assert(continuity(new_position) >= 0) + + mesh_count = size(old_fields_state) + max_field_count = 0 + field_counts = 0 + do mesh = 1, mesh_count + field_counts(mesh) = scalar_field_count(old_fields_state(mesh)) + max_field_count = max(max_field_count, scalar_field_count(old_fields_state(mesh))) + end do + allocate(bounded(mesh_count, max_field_count)) + bounded = .false. + allocate(lumped(mesh_count, max_field_count)) + lumped = .false. + allocate(old_fields(mesh_count, max_field_count)) + allocate(new_fields(mesh_count, max_field_count)) + allocate(force_bc(mesh_count, max_field_count)) + allocate(bc_nodes(mesh_count, max_field_count)) + + shape_B => ele_shape(new_position, 1) + new_positions_simplicial = (shape_B%numbering%family == FAMILY_SIMPLEX) + + dim = mesh_dim(new_position) + + dg = .false. + max_degree = 0 + max_loc = 0 + conservation_tolerance = 1.0 + do mesh = 1, size(old_fields_state) + if(field_counts(mesh)>0) then - call allocate(bc_nodes(mesh, field)) - do bc=1, get_boundary_condition_count(new_fields(mesh, field)) - call get_boundary_condition(new_fields(mesh, field), bc, type=bctype, surface_node_list=surface_node_list) - if (trim(bctype) == "dirichlet") then - call insert(bc_nodes(mesh, field), surface_node_list) - end if + do field = 1, field_counts(mesh) + old_fields(mesh, field) = extract_scalar_field(old_fields_state(mesh), field) + new_fields(mesh, field) = extract_scalar_field(new_fields_state(mesh), field) + call zero(new_fields(mesh, field)) + bounded(mesh, field) = l_force_bounded.or.& + have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & + "/galerkin_projection/continuous/bounded[0]") + lumped(mesh, field) = have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & + "/galerkin_projection/continuous/lump_mass_matrix") + call get_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & + "/galerkin_projection/supermesh_conservation/tolerance", tmp_tol, default = 0.001) + ! Let's check for a relative area/volume loss of 0.1% if none is specified + conservation_tolerance = min(conservation_tolerance, tmp_tol) + + force_bc(mesh, field) = have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) & + & // "/galerkin_projection/honour_strong_boundary_conditions") + if (force_bc(mesh, field)) then + + if (.not. has_boundary_condition(new_fields(mesh, field), "dirichlet")) then + ewrite(0, *) "Warning: For field: " // trim(new_fields(mesh, field)%name) + ewrite(0, *) "Warning: Asked to honour strong boundary conditions through the Galerkin projection without any such BCs" + end if + + call set_dirichlet_consistent(new_fields(mesh, field)) + + call allocate(bc_nodes(mesh, field)) + do bc=1, get_boundary_condition_count(new_fields(mesh, field)) + call get_boundary_condition(new_fields(mesh, field), bc, type=bctype, surface_node_list=surface_node_list) + if (trim(bctype) == "dirichlet") then + call insert(bc_nodes(mesh, field), surface_node_list) + end if + end do + end if end do - end if - end do - dg(mesh) = (continuity(new_fields(mesh,1)) < 0) - if(dg(mesh)) then - bounded(mesh,:) = .false. ! not possible to have a bounded or lumped dg field - lumped(mesh,:) = .false. ! so just to make sure set it to false - end if + dg(mesh) = (continuity(new_fields(mesh,1)) < 0) + if(dg(mesh)) then + bounded(mesh,:) = .false. ! not possible to have a bounded or lumped dg field + lumped(mesh,:) = .false. ! so just to make sure set it to false + end if - max_degree = max(max_degree, element_degree(new_fields(mesh,1), 1)) - max_loc = max(max_loc, ele_loc(new_fields(mesh,1), 1)) + max_degree = max(max_degree, element_degree(new_fields(mesh,1), 1)) + max_loc = max(max_loc, ele_loc(new_fields(mesh,1), 1)) - end if - end do - - allocate(local_rhs(mesh_count, max_field_count, max_loc)) - allocate(little_mass_matrix(mesh_count, max_loc, max_loc)) - - if (any(dg).and.new_positions_simplicial) then - allocate(little_inverse_mass_matrix(mesh_count, max_loc, max_loc)) - allocate(little_inverse_mass_matrix_copy(mesh_count, max_loc, max_loc)) - little_inverse_mass_matrix = 0.0 - do mesh=1,mesh_count - if((field_counts(mesh)>0).and.dg(mesh)) then - shape_B => ele_shape(new_fields(mesh, 1), 1) - nloc = ele_loc(new_fields(mesh, 1), 1) - little_inverse_mass_matrix(mesh, :nloc, :nloc) = shape_shape(shape_B, shape_B, shape_B%quadrature%weight) - call invert(little_inverse_mass_matrix(mesh, :nloc, :nloc)) - end if + end if end do - end if - allocate(little_rhs(max_loc, max_field_count)) + allocate(local_rhs(mesh_count, max_field_count, max_loc)) + allocate(little_mass_matrix(mesh_count, max_loc, max_loc)) + + if (any(dg).and.new_positions_simplicial) then + allocate(little_inverse_mass_matrix(mesh_count, max_loc, max_loc)) + allocate(little_inverse_mass_matrix_copy(mesh_count, max_loc, max_loc)) + little_inverse_mass_matrix = 0.0 + do mesh=1,mesh_count + if((field_counts(mesh)>0).and.dg(mesh)) then + shape_B => ele_shape(new_fields(mesh, 1), 1) + nloc = ele_loc(new_fields(mesh, 1), 1) + little_inverse_mass_matrix(mesh, :nloc, :nloc) = shape_shape(shape_B, shape_B, shape_B%quadrature%weight) + call invert(little_inverse_mass_matrix(mesh, :nloc, :nloc)) + end if + end do + end if - if(any(.not.dg)) then - ! if any meshes are not dg then we need a lhs matrix and a global rhs + allocate(little_rhs(max_loc, max_field_count)) - allocate(rhs(mesh_count, max_field_count)) - allocate(M_B(mesh_count)) - allocate(M_B_L(mesh_count)) + if(any(.not.dg)) then + ! if any meshes are not dg then we need a lhs matrix and a global rhs - do mesh = 1, mesh_count - if(.not.dg(mesh)) then - if(field_counts(mesh)>0) then - do field = 1, field_counts(mesh) - call allocate(rhs(mesh,field), new_fields(mesh,field)%mesh, name = trim(new_fields(mesh,field)%name)//"RHS") - call zero(rhs(mesh,field)) - end do + allocate(rhs(mesh_count, max_field_count)) + allocate(M_B(mesh_count)) + allocate(M_B_L(mesh_count)) - if(.not.all(lumped(mesh,1:field_counts(mesh)))) then - M_B_sparsity = make_sparsity(new_fields(mesh,1)%mesh, new_fields(mesh,1)%mesh, name="MassMatrixBSparsity") + do mesh = 1, mesh_count + if(.not.dg(mesh)) then + if(field_counts(mesh)>0) then + do field = 1, field_counts(mesh) + call allocate(rhs(mesh,field), new_fields(mesh,field)%mesh, name = trim(new_fields(mesh,field)%name)//"RHS") + call zero(rhs(mesh,field)) + end do - call allocate(M_B(mesh), M_B_sparsity, & - name=trim(new_fields(mesh,1)%mesh%name)//"MassMatrixB") - call zero(M_B(mesh)) + if(.not.all(lumped(mesh,1:field_counts(mesh)))) then + M_B_sparsity = make_sparsity(new_fields(mesh,1)%mesh, new_fields(mesh,1)%mesh, name="MassMatrixBSparsity") - call deallocate(M_B_sparsity) - end if + call allocate(M_B(mesh), M_B_sparsity, & + name=trim(new_fields(mesh,1)%mesh%name)//"MassMatrixB") + call zero(M_B(mesh)) - if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then - call allocate(M_B_L(mesh), new_fields(mesh,1)%mesh, & - name=trim(new_fields(mesh,1)%mesh%name)//"LumpedMassMatrixB") - call zero(M_B_L(mesh)) + call deallocate(M_B_sparsity) + end if + + if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then + call allocate(M_B_L(mesh), new_fields(mesh,1)%mesh, & + name=trim(new_fields(mesh,1)%mesh%name)//"LumpedMassMatrixB") + call zero(M_B_L(mesh)) + end if + end if end if - end if - end if - end do + end do - end if + end if - supermesh_quad = make_quadrature(vertices=ele_loc(new_position, 1), dim=dim, degree=max(max_degree+max_degree, 1)) - supermesh_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=1, quad=supermesh_quad) + supermesh_quad = make_quadrature(vertices=ele_loc(new_position, 1), dim=dim, degree=max(max_degree+max_degree, 1)) + supermesh_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=1, quad=supermesh_quad) - call intersector_set_dimension(dim) - if (present(map_BA)) then - lmap_BA => map_BA - else - allocate(lmap_BA(ele_count(new_position))) - lmap_BA = intersection_finder(new_position, old_position) - end if + call intersector_set_dimension(dim) + if (present(map_BA)) then + lmap_BA => map_BA + else + allocate(lmap_BA(ele_count(new_position))) + lmap_BA = intersection_finder(new_position, old_position) + end if - do ele_A=1,ele_count(old_position) - call local_coords_matrix(old_position, ele_A, inversion_matrices_A(:, :, ele_A)) - end do + do ele_A=1,ele_count(old_position) + call local_coords_matrix(old_position, ele_A, inversion_matrices_A(:, :, ele_A)) + end do #ifdef DUMP_SUPERMESH_INTERSECTIONS - call system("rm intersection*.vtu") - dump_idx = 0 + call system("rm intersection*.vtu") + dump_idx = 0 #endif - ewrite(1, *) "Entering supermeshing loop" - - do ele_B=1,ele_count(new_position) + ewrite(1, *) "Entering supermeshing loop" - ! halo 2 elements are inconsistent after an adapt, and assembling over these is unneccesary, so we skip - ! anything without any owned nodes (i.e. in halo 2) - not_halo_2_element = .false. - nloc = ele_loc(new_position, ele_B) - ele_nodes_B => ele_nodes(new_position, ele_B) + do ele_B=1,ele_count(new_position) - do j = 1, nloc - if (node_owned(new_position, ele_nodes_B(j))) then - not_halo_2_element = .true. - exit - end if - end do + ! halo 2 elements are inconsistent after an adapt, and assembling over these is unneccesary, so we skip + ! anything without any owned nodes (i.e. in halo 2) + not_halo_2_element = .false. + nloc = ele_loc(new_position, ele_B) + ele_nodes_B => ele_nodes(new_position, ele_B) - if (not_halo_2_element) then + do j = 1, nloc + if (node_owned(new_position, ele_nodes_B(j))) then + not_halo_2_element = .true. + exit + end if + end do - call galerkin_projection_inner_loop(ele_B, little_mass_matrix, detJ, local_rhs, conservation_tolerance, stat, & - field_counts, old_fields, old_position, new_fields, new_position, & - lmap_BA, inversion_matrices_A, supermesh_shape) + if (not_halo_2_element) then - if (stat /= 0) then - ! Uhoh! We haven't found all the mass for ele_B :-/ - ! The intersector has missed something (almost certainly due to - ! finite precision arithmetic). Geometry is hard! - ! So let's go all arbitrary precision on its ass. - ! Data, Warp 0! -#ifdef HAVE_LIBCGAL - ewrite(0,*) "Using CGAL to try to fix conservation error" - call intersector_set_exactness(.true.) - call galerkin_projection_inner_loop(ele_B, little_mass_matrix, detJ, local_rhs, conservation_tolerance, stat, & + call galerkin_projection_inner_loop(ele_B, little_mass_matrix, detJ, local_rhs, conservation_tolerance, stat, & field_counts, old_fields, old_position, new_fields, new_position, & lmap_BA, inversion_matrices_A, supermesh_shape) - if(stat/=0) then - ewrite(0,*) "Sorry, CGAL failed to fix conservation error." - end if - call intersector_set_exactness(.false.) + + if (stat /= 0) then + ! Uhoh! We haven't found all the mass for ele_B :-/ + ! The intersector has missed something (almost certainly due to + ! finite precision arithmetic). Geometry is hard! + ! So let's go all arbitrary precision on its ass. + ! Data, Warp 0! +#ifdef HAVE_LIBCGAL + ewrite(0,*) "Using CGAL to try to fix conservation error" + call intersector_set_exactness(.true.) + call galerkin_projection_inner_loop(ele_B, little_mass_matrix, detJ, local_rhs, conservation_tolerance, stat, & + field_counts, old_fields, old_position, new_fields, new_position, & + lmap_BA, inversion_matrices_A, supermesh_shape) + if(stat/=0) then + ewrite(0,*) "Sorry, CGAL failed to fix conservation error." + end if + call intersector_set_exactness(.false.) #else - ewrite(0,*) "Warning: it appears a supermesh intersection wasn't found resulting in a conservation error." - ewrite(0,*) "Recompile with CGAL if you want to try to fix it." + ewrite(0,*) "Warning: it appears a supermesh intersection wasn't found resulting in a conservation error." + ewrite(0,*) "Recompile with CGAL if you want to try to fix it." #endif - end if + end if - do mesh = 1, mesh_count - if(field_counts(mesh)>0) then - nloc = ele_loc(new_fields(mesh,1),1) - ele_nodes_B => ele_nodes(new_fields(mesh,1), ele_B) - if(dg(mesh)) then - little_rhs = 0.0 - do field=1,field_counts(mesh) - little_rhs(:nloc, field) = local_rhs(mesh,field,:nloc) - end do - - if (any(force_bc(mesh,1:field_counts(mesh)))) then - little_inverse_mass_matrix_copy=little_inverse_mass_matrix - end if - - if (new_positions_simplicial) then - do field=1,field_counts(mesh) - if (force_bc(mesh,field)) then - if (any(has_value(bc_nodes(mesh,field), ele_nodes_B))) then - local_rhs(mesh, field, :nloc)=local_rhs(mesh, field, :nloc)-matmul( little_mass_matrix(mesh,:nloc,:nloc)*abs(detJ(1)), ele_val(new_fields(mesh,field), ele_B) ) - little_inverse_mass_matrix = little_inverse_mass_matrix_copy - do j=1, nloc - if (has_value(bc_nodes(mesh,field), ele_nodes_B(j))) then - little_inverse_mass_matrix(mesh, j,:)=0.0 - little_inverse_mass_matrix(mesh, :,j)=0.0 - little_inverse_mass_matrix(mesh, j,j)=1.0 - local_rhs(mesh, field, j)=node_val(new_fields(mesh,field), ele_nodes_B(j)) - end if - end do - end if - end if + do mesh = 1, mesh_count + if(field_counts(mesh)>0) then + nloc = ele_loc(new_fields(mesh,1),1) + ele_nodes_B => ele_nodes(new_fields(mesh,1), ele_B) + if(dg(mesh)) then + little_rhs = 0.0 + do field=1,field_counts(mesh) + little_rhs(:nloc, field) = local_rhs(mesh,field,:nloc) + end do + + if (any(force_bc(mesh,1:field_counts(mesh)))) then + little_inverse_mass_matrix_copy=little_inverse_mass_matrix + end if + + if (new_positions_simplicial) then + do field=1,field_counts(mesh) + if (force_bc(mesh,field)) then + if (any(has_value(bc_nodes(mesh,field), ele_nodes_B))) then + local_rhs(mesh, field, :nloc)=local_rhs(mesh, field, :nloc)-matmul( little_mass_matrix(mesh,:nloc,:nloc)*abs(detJ(1)), ele_val(new_fields(mesh,field), ele_B) ) + little_inverse_mass_matrix = little_inverse_mass_matrix_copy + do j=1, nloc + if (has_value(bc_nodes(mesh,field), ele_nodes_B(j))) then + little_inverse_mass_matrix(mesh, j,:)=0.0 + little_inverse_mass_matrix(mesh, :,j)=0.0 + little_inverse_mass_matrix(mesh, j,j)=1.0 + local_rhs(mesh, field, j)=node_val(new_fields(mesh,field), ele_nodes_B(j)) + end if + end do + end if + end if #ifdef INLINE_MATMUL - forall (j=1:nloc) - little_rhs(j, field) = sum(little_inverse_mass_matrix(mesh, j, :nloc) * local_rhs(mesh, field, :nloc)) - end forall - little_rhs(:nloc, field) = little_rhs(:nloc, field) / abs(detJ(1)) + forall (j=1:nloc) + little_rhs(j, field) = sum(little_inverse_mass_matrix(mesh, j, :nloc) * local_rhs(mesh, field, :nloc)) + end forall + little_rhs(:nloc, field) = little_rhs(:nloc, field) / abs(detJ(1)) #else - little_rhs(:nloc, field) = matmul(little_inverse_mass_matrix(mesh, :nloc, :nloc) / abs(detJ(1)), little_rhs(:nloc, field)) + little_rhs(:nloc, field) = matmul(little_inverse_mass_matrix(mesh, :nloc, :nloc) / abs(detJ(1)), little_rhs(:nloc, field)) #endif - end do - else - call solve(little_mass_matrix(mesh,:nloc,:nloc), little_rhs(:nloc,:field_counts(mesh))) - end if + end do + else + call solve(little_mass_matrix(mesh,:nloc,:nloc), little_rhs(:nloc,:field_counts(mesh))) + end if - if (any(force_bc(mesh,1:field_counts(mesh)))) then - little_inverse_mass_matrix=little_inverse_mass_matrix_copy - end if + if (any(force_bc(mesh,1:field_counts(mesh)))) then + little_inverse_mass_matrix=little_inverse_mass_matrix_copy + end if - do field = 1, field_counts(mesh) - call set(new_fields(mesh,field), ele_nodes_B, little_rhs(:nloc, field)) - end do + do field = 1, field_counts(mesh) + call set(new_fields(mesh,field), ele_nodes_B, little_rhs(:nloc, field)) + end do - else + else - do field=1,field_counts(mesh) - call addto(rhs(mesh,field), ele_nodes_B, local_rhs(mesh,field,:nloc)) - end do + do field=1,field_counts(mesh) + call addto(rhs(mesh,field), ele_nodes_B, local_rhs(mesh,field,:nloc)) + end do - if(.not.all(lumped(mesh,1:field_counts(mesh)))) then - call addto(M_B(mesh), ele_nodes_B, ele_nodes_B, little_mass_matrix(mesh,:nloc,:nloc)) - end if + if(.not.all(lumped(mesh,1:field_counts(mesh)))) then + call addto(M_B(mesh), ele_nodes_B, ele_nodes_B, little_mass_matrix(mesh,:nloc,:nloc)) + end if - if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then - call addto(M_B_L(mesh), ele_nodes_B, sum(little_mass_matrix(mesh,:nloc,:nloc), 2)) - end if - end if - end if + if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then + call addto(M_B_L(mesh), ele_nodes_B, sum(little_mass_matrix(mesh,:nloc,:nloc), 2)) + end if + end if + end if - end do + end do + end if + + end do + + ewrite(1, *) "Supermeshing complete" + + if (.not. present(map_BA)) then + do ele_B=1,ele_count(new_position) + call deallocate(lmap_BA(ele_B)) + end do + deallocate(lmap_BA) end if - end do + do mesh = 1, mesh_count + if(field_counts(mesh)>0) then + if(.not.dg(mesh)) then + + if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then + call allocate(inverse_M_B_L, M_B_L(mesh)%mesh, "InverseLumpedMass") + call invert(M_B_L(mesh), inverse_M_B_L) + call halo_update(inverse_M_B_L) + end if + + do field=1,field_counts(mesh) + if(lumped(mesh,field)) then + call set(new_fields(mesh, field), rhs(mesh, field)) + call scale(new_fields(mesh,field), inverse_M_B_L) + call halo_update(new_fields(mesh,field)) + else + if (force_bc(mesh, field)) then + call apply_dirichlet_conditions(M_B(mesh), rhs(mesh, field), new_fields(mesh, field)) + end if + call petsc_solve(new_fields(mesh, field), M_B(mesh), rhs(mesh, field), & + & option_path=trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) & + & // "/galerkin_projection/continuous") + if (force_bc(mesh, field)) then + ! clean up the rows made inactive for the strong bcs + call reset_inactive(M_B(mesh)) + end if + end if + end do - ewrite(1, *) "Supermeshing complete" + if(any(bounded(mesh,:))) then - if (.not. present(map_BA)) then - do ele_B=1,ele_count(new_position) - call deallocate(lmap_BA(ele_B)) - end do - deallocate(lmap_BA) - end if - - do mesh = 1, mesh_count - if(field_counts(mesh)>0) then - if(.not.dg(mesh)) then - - if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then - call allocate(inverse_M_B_L, M_B_L(mesh)%mesh, "InverseLumpedMass") - call invert(M_B_L(mesh), inverse_M_B_L) - call halo_update(inverse_M_B_L) - end if - - do field=1,field_counts(mesh) - if(lumped(mesh,field)) then - call set(new_fields(mesh, field), rhs(mesh, field)) - call scale(new_fields(mesh,field), inverse_M_B_L) - call halo_update(new_fields(mesh,field)) - else - if (force_bc(mesh, field)) then - call apply_dirichlet_conditions(M_B(mesh), rhs(mesh, field), new_fields(mesh, field)) - end if - call petsc_solve(new_fields(mesh, field), M_B(mesh), rhs(mesh, field), & - & option_path=trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) & - & // "/galerkin_projection/continuous") - if (force_bc(mesh, field)) then - ! clean up the rows made inactive for the strong bcs - call reset_inactive(M_B(mesh)) - end if - end if - end do + nnlist => extract_nnlist(new_fields(mesh,1)) - if(any(bounded(mesh,:))) then + ! Ok. All that above was more or less the same as Galerkin projection. Here is + ! where we bound. - nnlist => extract_nnlist(new_fields(mesh,1)) + ! to be able to couple the fields together we first need to group the fields by name + ! and order them by priority + ! so... let's get the priorities + allocate(priorities(field_counts(mesh))) + priorities = 0 + do field = 1, field_counts(mesh) + call get_option(trim(new_fields(mesh,field)%option_path)//"/prognostic/priority", priorities(field), default=0) + end do - ! Ok. All that above was more or less the same as Galerkin projection. Here is - ! where we bound. + ! let's allocate some space (too much in fact but it's our best guess) for the counts of each name + allocate(named_counts(field_counts(mesh))) + named_counts = 0 + ! the names themselves + allocate(field_names(field_counts(mesh))) + field_names = "" + ! the indices of each name + allocate(tmp_named_indices(field_counts(mesh), field_counts(mesh))) + tmp_named_indices = 0 + + ! now loop through the fields collecting the actual number of fields with the same + ! names and where they are located (their indices) in the current lists + f = 0 + do field=1,field_counts(mesh) + if(bounded(mesh,field)) then + if(any(new_fields(mesh,field)%name==field_names(:sum(named_counts)))) cycle + f = f + 1 + field_names(f) = trim(new_fields(mesh,field)%name) + named_counts(f) = 1 + tmp_named_indices(f,named_counts(f)) = field + do field2=1,field_counts(mesh) + if(field==field2) cycle + if(trim(new_fields(mesh,field2)%name)==field_names(f)) then + named_counts(f) = named_counts(f) + 1 + tmp_named_indices(f,named_counts(f)) = field2 + end if + enddo + end if + end do + no_names = f + + ! allocate the real space for them (still too much to avoid ragged arrays) + allocate(named_fields(no_names, maxval(named_counts))) + allocate(named_rhs(no_names, maxval(named_counts))) + allocate(named_indices(maxval(named_counts))) + + do name = 1, no_names + ! sort out their indices in order of priority + f = 0 + named_indices = 0 + do priority = maxval(priorities), minval(priorities), -1 + do field = 1, named_counts(name) + if(priorities(tmp_named_indices(name,field))==priority) then + f = f + 1 + named_indices(f) = tmp_named_indices(name, field) + end if + end do + end do + + ! and finally put them into a new list of fields sorted by name + do field = 1, named_counts(name) + named_fields(name, field) = new_fields(mesh, named_indices(field)) + named_rhs(name, field) = rhs(mesh, named_indices(field)) + end do + end do - ! to be able to couple the fields together we first need to group the fields by name - ! and order them by priority - ! so... let's get the priorities - allocate(priorities(field_counts(mesh))) - priorities = 0 - do field = 1, field_counts(mesh) - call get_option(trim(new_fields(mesh,field)%option_path)//"/prognostic/priority", priorities(field), default=0) - end do + do name = 1, no_names - ! let's allocate some space (too much in fact but it's our best guess) for the counts of each name - allocate(named_counts(field_counts(mesh))) - named_counts = 0 - ! the names themselves - allocate(field_names(field_counts(mesh))) - field_names = "" - ! the indices of each name - allocate(tmp_named_indices(field_counts(mesh), field_counts(mesh))) - tmp_named_indices = 0 - - ! now loop through the fields collecting the actual number of fields with the same - ! names and where they are located (their indices) in the current lists - f = 0 - do field=1,field_counts(mesh) - if(bounded(mesh,field)) then - if(any(new_fields(mesh,field)%name==field_names(:sum(named_counts)))) cycle - f = f + 1 - field_names(f) = trim(new_fields(mesh,field)%name) - named_counts(f) = 1 - tmp_named_indices(f,named_counts(f)) = field - do field2=1,field_counts(mesh) - if(field==field2) cycle - if(trim(new_fields(mesh,field2)%name)==field_names(f)) then - named_counts(f) = named_counts(f) + 1 - tmp_named_indices(f,named_counts(f)) = field2 - end if - enddo - end if - end do - no_names = f - - ! allocate the real space for them (still too much to avoid ragged arrays) - allocate(named_fields(no_names, maxval(named_counts))) - allocate(named_rhs(no_names, maxval(named_counts))) - allocate(named_indices(maxval(named_counts))) - - do name = 1, no_names - ! sort out their indices in order of priority - f = 0 - named_indices = 0 - do priority = maxval(priorities), minval(priorities), -1 - do field = 1, named_counts(name) - if(priorities(tmp_named_indices(name,field))==priority) then - f = f + 1 - named_indices(f) = tmp_named_indices(name, field) - end if - end do - end do - - ! and finally put them into a new list of fields sorted by name - do field = 1, named_counts(name) - named_fields(name, field) = new_fields(mesh, named_indices(field)) - named_rhs(name, field) = rhs(mesh, named_indices(field)) - end do - end do + allocate(coupled(named_counts(name))) + coupled = .false. + do field = 1, named_counts(name) + coupled(field) = have_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/bounds/upper_bound/coupled") + end do - do name = 1, no_names + do field=1,named_counts(name) - allocate(coupled(named_counts(name))) - coupled = .false. - do field = 1, named_counts(name) - coupled(field) = have_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/bounds/upper_bound/coupled") - end do + ewrite(2,*) 'Bounding field:', trim(named_fields(name,field)%name) - do field=1,named_counts(name) + ! Step 0. Compute bounds + call get_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/bounds/upper_bound", & + & upper_bound, default=huge(0.0)*epsilon(0.0)) - ewrite(2,*) 'Bounding field:', trim(named_fields(name,field)%name) + u_apply_globally = have_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/bounds/upper_bound/apply_globally") - ! Step 0. Compute bounds - call get_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/bounds/upper_bound", & - & upper_bound, default=huge(0.0)*epsilon(0.0)) + call get_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/bounds/lower_bound", & + & lower_bound, default=-huge(0.0)*epsilon(0.0)) - u_apply_globally = have_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/bounds/upper_bound/apply_globally") + l_apply_globally = have_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & + & "/galerkin_projection/continuous/bounded[0]/bounds/lower_bound/apply_globally") - call get_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/bounds/lower_bound", & - & lower_bound, default=-huge(0.0)*epsilon(0.0)) + if((.not.u_apply_globally).or.(coupled(field))) then + call allocate(max_bound, named_fields(name,1)%mesh, "MaxBound") + else + call allocate(max_bound, named_fields(name,1)%mesh, "MaxBound", field_type=FIELD_TYPE_CONSTANT) + end if - l_apply_globally = have_option(trim(complete_field_path(named_fields(name,field)%option_path, stat=statp))// & - & "/galerkin_projection/continuous/bounded[0]/bounds/lower_bound/apply_globally") + if(.not.l_apply_globally) then + call allocate(min_bound, named_fields(name,1)%mesh, "MinBound") + else + call allocate(min_bound, named_fields(name,1)%mesh, "MinBound", field_type=FIELD_TYPE_CONSTANT) + end if - if((.not.u_apply_globally).or.(coupled(field))) then - call allocate(max_bound, named_fields(name,1)%mesh, "MaxBound") - else - call allocate(max_bound, named_fields(name,1)%mesh, "MaxBound", field_type=FIELD_TYPE_CONSTANT) - end if + call set(max_bound, upper_bound) + if(coupled(field)) then + do field2 = 1, field-1 + if(coupled(field2)) call addto(max_bound, named_fields(name,field2), -1.0) + end do + end if - if(.not.l_apply_globally) then - call allocate(min_bound, named_fields(name,1)%mesh, "MinBound") - else - call allocate(min_bound, named_fields(name,1)%mesh, "MinBound", field_type=FIELD_TYPE_CONSTANT) - end if + call set(min_bound, lower_bound) - call set(max_bound, upper_bound) - if(coupled(field)) then - do field2 = 1, field-1 - if(coupled(field2)) call addto(max_bound, named_fields(name,field2), -1.0) - end do - end if + call allocate(bounded_soln, named_fields(name,1)%mesh, "BoundedSolution") + call set(bounded_soln, named_rhs(name,field)) + call scale(bounded_soln, inverse_M_B_L) + call halo_update(bounded_soln) - call set(min_bound, lower_bound) + do node_B=1,node_count(named_fields(name,1)%mesh) + patch => row_m_ptr(nnlist, node_B) + if(.not.u_apply_globally) then + call set(max_bound, node_B, max(min(maxval(bounded_soln%val(patch)), & + node_val(max_bound, node_B)), & + lower_bound)) + end if + if(.not.l_apply_globally) then + call set(min_bound, node_B, max(min(minval(bounded_soln%val(patch)), & + node_val(max_bound, node_B)), & + lower_bound)) + end if + end do - call allocate(bounded_soln, named_fields(name,1)%mesh, "BoundedSolution") - call set(bounded_soln, named_rhs(name,field)) - call scale(bounded_soln, inverse_M_B_L) - call halo_update(bounded_soln) + call halo_update(max_bound) + ewrite_minmax(max_bound) - do node_B=1,node_count(named_fields(name,1)%mesh) - patch => row_m_ptr(nnlist, node_B) - if(.not.u_apply_globally) then - call set(max_bound, node_B, max(min(maxval(bounded_soln%val(patch)), & - node_val(max_bound, node_B)), & - lower_bound)) - end if - if(.not.l_apply_globally) then - call set(min_bound, node_B, max(min(minval(bounded_soln%val(patch)), & - node_val(max_bound, node_B)), & - lower_bound)) - end if - end do + call halo_update(min_bound) + ewrite_minmax(min_bound) - call halo_update(max_bound) - ewrite_minmax(max_bound) + call bound_field(named_fields(name, field), max_bound, min_bound, & + M_B(mesh), M_B_L(mesh), inverse_M_B_L, bounded_soln, & + new_position) - call halo_update(min_bound) - ewrite_minmax(min_bound) - call bound_field(named_fields(name, field), max_bound, min_bound, & - M_B(mesh), M_B_L(mesh), inverse_M_B_L, bounded_soln, & - new_position) + call deallocate(max_bound) + call deallocate(min_bound) + call deallocate(bounded_soln) + end do - call deallocate(max_bound) - call deallocate(min_bound) - call deallocate(bounded_soln) + deallocate(coupled) - end do + end do - deallocate(coupled) + deallocate(priorities) + deallocate(named_counts) + deallocate(field_names) + deallocate(tmp_named_indices) + deallocate(named_fields) + deallocate(named_rhs) + deallocate(named_indices) - end do + end if + + if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then + call deallocate(inverse_M_B_L) + call deallocate(M_B_L(mesh)) + end if - deallocate(priorities) - deallocate(named_counts) - deallocate(field_names) - deallocate(tmp_named_indices) - deallocate(named_fields) - deallocate(named_rhs) - deallocate(named_indices) - - end if - - if(any(bounded(mesh,:)).or.any(lumped(mesh,:))) then - call deallocate(inverse_M_B_L) - call deallocate(M_B_L(mesh)) - end if - - end if - - do field = 1, field_counts(mesh) - if(have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & - "/galerkin_projection/supermesh_conservation/print_field_integral")) then - int_old = field_integral(old_fields(mesh,field), old_position) - int_new = field_integral(new_fields(mesh,field), new_position) - cons_err = abs(int_old-int_new)/abs(int_old) - ewrite(2,*) "relative change in field integral: ", cons_err, " for field ", trim(new_fields(mesh,field)%name) - call get_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & - "/galerkin_projection/supermesh_conservation/print_field_integral/tolerance", & - tmp_tol) - if (cons_err > tmp_tol) then - call get_option("/timestepping/current_time", current_time) - ewrite(0,*) "Warning: relative conservation error: ", cons_err, " for field ", trim(old_fields(mesh,field)%name), " at time: ", current_time - call vtk_write_fields(trim(new_fields(mesh,field)%name)//"_conservation_error", 0, old_position, old_fields(mesh,field)%mesh, sfields=(/old_fields(mesh,field)/)) - call vtk_write_fields(trim(new_fields(mesh,field)%name)//"_conservation_error", 1, new_position, new_fields(mesh,field)%mesh, sfields=(/new_fields(mesh,field)/)) end if - end if - end do - end if + do field = 1, field_counts(mesh) + if(have_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & + "/galerkin_projection/supermesh_conservation/print_field_integral")) then + int_old = field_integral(old_fields(mesh,field), old_position) + int_new = field_integral(new_fields(mesh,field), new_position) + cons_err = abs(int_old-int_new)/abs(int_old) + ewrite(2,*) "relative change in field integral: ", cons_err, " for field ", trim(new_fields(mesh,field)%name) + call get_option(trim(complete_field_path(new_fields(mesh,field)%option_path, stat=statp)) // & + "/galerkin_projection/supermesh_conservation/print_field_integral/tolerance", & + tmp_tol) + if (cons_err > tmp_tol) then + call get_option("/timestepping/current_time", current_time) + ewrite(0,*) "Warning: relative conservation error: ", cons_err, " for field ", trim(old_fields(mesh,field)%name), " at time: ", current_time + call vtk_write_fields(trim(new_fields(mesh,field)%name)//"_conservation_error", 0, old_position, old_fields(mesh,field)%mesh, sfields=(/old_fields(mesh,field)/)) + call vtk_write_fields(trim(new_fields(mesh,field)%name)//"_conservation_error", 1, new_position, new_fields(mesh,field)%mesh, sfields=(/new_fields(mesh,field)/)) + end if + end if + end do + + end if + + end do + + call deallocate(supermesh_shape) + call deallocate(supermesh_quad) - end do - - call deallocate(supermesh_shape) - call deallocate(supermesh_quad) - - do mesh = 1, mesh_count - if(field_counts(mesh)>0) then - if(.not.dg(mesh)) then - if(.not.all(lumped(mesh,1:field_counts(mesh)))) then - call deallocate(M_B(mesh)) - end if - do field = 1, field_counts(mesh) - call deallocate(rhs(mesh,field)) - if (force_bc(mesh, field)) then - call deallocate(bc_nodes(mesh, field)) + do mesh = 1, mesh_count + if(field_counts(mesh)>0) then + if(.not.dg(mesh)) then + if(.not.all(lumped(mesh,1:field_counts(mesh)))) then + call deallocate(M_B(mesh)) + end if + do field = 1, field_counts(mesh) + call deallocate(rhs(mesh,field)) + if (force_bc(mesh, field)) then + call deallocate(bc_nodes(mesh, field)) + end if + end do end if - end do - end if + end if + end do + if(any(.not.dg).and.(max_field_count>0)) then + deallocate(M_B) + deallocate(M_B_L) + deallocate(rhs) end if - end do - if(any(.not.dg).and.(max_field_count>0)) then - deallocate(M_B) - deallocate(M_B_L) - deallocate(rhs) - end if - deallocate(bounded) - deallocate(old_fields) - deallocate(new_fields) - deallocate(local_rhs) - deallocate(little_mass_matrix) - deallocate(force_bc) - deallocate(bc_nodes) - if(any(dg).and.new_positions_simplicial) then - deallocate(little_inverse_mass_matrix) - deallocate(little_inverse_mass_matrix_copy) - end if - deallocate(little_rhs) + deallocate(bounded) + deallocate(old_fields) + deallocate(new_fields) + deallocate(local_rhs) + deallocate(little_mass_matrix) + deallocate(force_bc) + deallocate(bc_nodes) + if(any(dg).and.new_positions_simplicial) then + deallocate(little_inverse_mass_matrix) + deallocate(little_inverse_mass_matrix_copy) + end if + deallocate(little_rhs) - call finalise_tet_intersector + call finalise_tet_intersector - ewrite(1, *) "Exiting interpolation_galerkin_scalars" + ewrite(1, *) "Exiting interpolation_galerkin_scalars" - end subroutine interpolation_galerkin_scalars + end subroutine interpolation_galerkin_scalars - subroutine interpolation_galerkin_single_state(old_state, new_state, map_BA) - type(state_type), intent(inout) :: old_state, new_state - type(ilist), dimension(:), intent(in), optional :: map_BA + subroutine interpolation_galerkin_single_state(old_state, new_state, map_BA) + type(state_type), intent(inout) :: old_state, new_state + type(ilist), dimension(:), intent(in), optional :: map_BA - type(state_type), dimension(1) :: old_states, new_states + type(state_type), dimension(1) :: old_states, new_states - old_states = (/old_state/) - new_states = (/new_state/) - call interpolation_galerkin(old_states, new_states, map_BA=map_BA) - old_state = old_states(1) - new_state = new_states(1) + old_states = (/old_state/) + new_states = (/new_state/) + call interpolation_galerkin(old_states, new_states, map_BA=map_BA) + old_state = old_states(1) + new_state = new_states(1) - end subroutine interpolation_galerkin_single_state + end subroutine interpolation_galerkin_single_state - subroutine interpolation_galerkin_multiple_states(old_states, new_states, map_BA) - type(state_type), dimension(:), intent(inout) :: old_states, new_states - type(ilist), dimension(:), intent(in), optional :: map_BA + subroutine interpolation_galerkin_multiple_states(old_states, new_states, map_BA) + type(state_type), dimension(:), intent(inout) :: old_states, new_states + type(ilist), dimension(:), intent(in), optional :: map_BA - type(state_type), dimension(size(old_states)) :: old_fields_state, new_fields_state - type(vector_field), pointer :: old_position, new_position - integer :: i + type(state_type), dimension(size(old_states)) :: old_fields_state, new_fields_state + type(vector_field), pointer :: old_position, new_position + integer :: i - ewrite(1, *) "In interpolation_galerkin_multiple_states" + ewrite(1, *) "In interpolation_galerkin_multiple_states" - call collapse_fields_in_state(old_states, old_fields_state) - call collapse_fields_in_state(new_states, new_fields_state) - call derive_collapsed_bcs(new_states, new_fields_state, bctype = "dirichlet") + call collapse_fields_in_state(old_states, old_fields_state) + call collapse_fields_in_state(new_states, new_fields_state) + call derive_collapsed_bcs(new_states, new_fields_state, bctype = "dirichlet") - old_position => extract_vector_field(old_states(1), "Coordinate") - new_position => extract_vector_field(new_states(1), "Coordinate") + old_position => extract_vector_field(old_states(1), "Coordinate") + new_position => extract_vector_field(new_states(1), "Coordinate") - call interpolation_galerkin_scalars(old_fields_state, old_position, new_fields_state, new_position, map_BA=map_BA) + call interpolation_galerkin_scalars(old_fields_state, old_position, new_fields_state, new_position, map_BA=map_BA) - do i = 1, size(old_fields_state) - call deallocate(old_fields_state(i)) - call deallocate(new_fields_state(i)) - end do + do i = 1, size(old_fields_state) + call deallocate(old_fields_state(i)) + call deallocate(new_fields_state(i)) + end do - ewrite(1, *) "Exiting interpolation_galerkin_multiple_states" - - end subroutine interpolation_galerkin_multiple_states + ewrite(1, *) "Exiting interpolation_galerkin_multiple_states" - subroutine grandy_projection_multiple_states(old_states, new_states, map_BA) - type(state_type), dimension(:), intent(inout) :: old_states, new_states - type(ilist), dimension(:), intent(in), optional :: map_BA + end subroutine interpolation_galerkin_multiple_states - type(state_type), dimension(size(old_states)) :: old_fields_state, new_fields_state - type(scalar_field), dimension(:), pointer :: old_fields, new_fields - type(vector_field), pointer :: old_position, new_position - integer :: i - - ewrite(1, *) "In grandy_projection_multiple_states" - - call collapse_fields_in_state(old_states, old_fields_state) - call collapse_fields_in_state(new_states, new_fields_state) - call collapse_state(old_fields_state, old_fields) - call collapse_state(new_fields_state, new_fields) - - old_position => extract_vector_field(old_states(1), "Coordinate") - new_position => extract_vector_field(new_states(1), "Coordinate") - - call grandy_projection_scalars(old_fields, old_position, new_fields, new_position, map_BA=map_BA) - - do i = 1, size(old_fields_state) - call deallocate(old_fields_state(i)) - call deallocate(new_fields_state(i)) - end do - - deallocate(old_fields) - deallocate(new_fields) - - ewrite(1, *) "Exiting grandy_projection_multiple_states" - - end subroutine grandy_projection_multiple_states - - subroutine grandy_projection_scalars(old_fields, old_position, new_fields, new_position, map_BA) - !!< Grandy, 1999. - !!< 10.1006/jcph.1998.6125 - type(scalar_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(in) :: old_position - type(vector_field), intent(in) :: new_position - type(scalar_field), dimension(:), intent(inout) :: new_fields + subroutine grandy_projection_multiple_states(old_states, new_states, map_BA) + type(state_type), dimension(:), intent(inout) :: old_states, new_states + type(ilist), dimension(:), intent(in), optional :: map_BA - integer :: ele_A, ele_B, ele_C - real :: vol_A, vol_B, vol_C - integer :: dim + type(state_type), dimension(size(old_states)) :: old_fields_state, new_fields_state + type(scalar_field), dimension(:), pointer :: old_fields, new_fields + type(vector_field), pointer :: old_position, new_position + integer :: i - type(ilist), dimension(:), intent(in), optional, target :: map_BA - type(ilist), dimension(:), pointer :: lmap_BA - type(inode), pointer :: llnode + ewrite(1, *) "In grandy_projection_multiple_states" - type(vector_field) :: intersection - type(quadrature_type) :: supermesh_quad - type(element_type) :: supermesh_shape + call collapse_fields_in_state(old_states, old_fields_state) + call collapse_fields_in_state(new_states, new_fields_state) + call collapse_state(old_fields_state, old_fields) + call collapse_state(new_fields_state, new_fields) - real, dimension(size(old_fields)) :: integral_A, integral_B - real, dimension(ele_ngi(old_fields(1), 1)) :: detwei_A + old_position => extract_vector_field(old_states(1), "Coordinate") + new_position => extract_vector_field(new_states(1), "Coordinate") - type(scalar_field), dimension(size(old_fields)) :: pwc_B + call grandy_projection_scalars(old_fields, old_position, new_fields, new_position, map_BA=map_BA) - integer :: field, field_cnt - type(state_type) :: projection_state - character(len=OPTION_PATH_LEN) :: old_path - integer :: stat - real, dimension(new_position%dim, ele_loc(new_position, 1)) :: pos_B - logical :: empty_intersection + do i = 1, size(old_fields_state) + call deallocate(old_fields_state(i)) + call deallocate(new_fields_state(i)) + end do - field_cnt = size(old_fields) - dim = mesh_dim(new_position) + deallocate(old_fields) + deallocate(new_fields) + ewrite(1, *) "Exiting grandy_projection_multiple_states" - ! Linear positions -- definitely linear positions. - assert(old_position%mesh%shape%degree == 1) - assert(continuity(old_position) >= 0) - assert(continuity(new_position) >= 0) - do field=1,field_cnt - pwc_B(field) = piecewise_constant_field(new_position%mesh, trim(old_fields(field)%name) // "PWC") - call zero(pwc_B(field)) - end do + end subroutine grandy_projection_multiple_states - supermesh_quad = make_quadrature(vertices=ele_loc(new_position, 1), dim=dim, degree=1) - supermesh_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=1, quad=supermesh_quad) + subroutine grandy_projection_scalars(old_fields, old_position, new_fields, new_position, map_BA) + !!< Grandy, 1999. + !!< 10.1006/jcph.1998.6125 + type(scalar_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(in) :: old_position + type(vector_field), intent(in) :: new_position + type(scalar_field), dimension(:), intent(inout) :: new_fields - call intersector_set_dimension(dim) - if (present(map_BA)) then - lmap_BA => map_BA - else - allocate(lmap_BA(ele_count(new_position))) - lmap_BA = intersection_finder(new_position, old_position) - end if + integer :: ele_A, ele_B, ele_C + real :: vol_A, vol_B, vol_C + integer :: dim - do ele_B=1,ele_count(new_position) - llnode => lmap_BA(ele_B)%firstnode - integral_B = 0.0 - vol_B = simplex_volume(new_position, ele_B) - pos_B = ele_val(new_position, ele_B) + type(ilist), dimension(:), intent(in), optional, target :: map_BA + type(ilist), dimension(:), pointer :: lmap_BA + type(inode), pointer :: llnode - do while(associated(llnode)) - ele_A = llnode%value - vol_A = simplex_volume(old_position, ele_A) - integral_A = 0.0 + type(vector_field) :: intersection + type(quadrature_type) :: supermesh_quad + type(element_type) :: supermesh_shape - call transform_to_physical(old_position, ele_A, detwei_A) - - do field=1,field_cnt - integral_A(field) = dot_product(ele_val_at_quad(old_fields(field), ele_A), detwei_A) - end do - - intersection = intersect_elements(old_position, ele_A, pos_B, supermesh_shape, empty_intersection=empty_intersection) - if (empty_intersection) then - llnode => llnode%next - cycle - end if - - do ele_C=1,ele_count(intersection) - vol_C = simplex_volume(intersection, ele_C) - do field=1,field_cnt - integral_B(field) = integral_B(field) + integral_A(field)*(vol_C/vol_A) - end do - end do - - do field=1,field_cnt - call set(pwc_B(field), ele_B, integral_B(field) / vol_B) - end do - - call deallocate(intersection) - - llnode => llnode%next - end do - end do + real, dimension(size(old_fields)) :: integral_A, integral_B + real, dimension(ele_ngi(old_fields(1), 1)) :: detwei_A - call deallocate(supermesh_shape) - call deallocate(supermesh_quad) + type(scalar_field), dimension(size(old_fields)) :: pwc_B - ! Now call the Galerkin projection routines to translate from P0 to Pn. + integer :: field, field_cnt + type(state_type) :: projection_state + character(len=OPTION_PATH_LEN) :: old_path + integer :: stat + real, dimension(new_position%dim, ele_loc(new_position, 1)) :: pos_B + logical :: empty_intersection - do field=1,field_cnt - call insert(projection_state, pwc_B(field), trim(new_fields(field)%name)) - call insert(projection_state, new_position, "Coordinate") + field_cnt = size(old_fields) + dim = mesh_dim(new_position) - old_path = new_fields(field)%option_path - new_fields(field)%option_path = "/temporary" - call set_option("/temporary/diagnostic/source_field_name", trim(new_fields(field)%name), stat=stat) - call set_solver_options("/temporary/diagnostic", ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) - call zero(new_fields(field)) - call calculate_galerkin_projection(projection_state, new_fields(field)) - call delete_option("/temporary") - new_fields(field)%option_path = old_path - call deallocate(projection_state) - call deallocate(pwc_B(field)) - end do + ! Linear positions -- definitely linear positions. + assert(old_position%mesh%shape%degree == 1) + assert(continuity(old_position) >= 0) + assert(continuity(new_position) >= 0) + do field=1,field_cnt + pwc_B(field) = piecewise_constant_field(new_position%mesh, trim(old_fields(field)%name) // "PWC") + call zero(pwc_B(field)) + end do + + supermesh_quad = make_quadrature(vertices=ele_loc(new_position, 1), dim=dim, degree=1) + supermesh_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=1, quad=supermesh_quad) + + call intersector_set_dimension(dim) + if (present(map_BA)) then + lmap_BA => map_BA + else + allocate(lmap_BA(ele_count(new_position))) + lmap_BA = intersection_finder(new_position, old_position) + end if - if (.not. present(map_BA)) then do ele_B=1,ele_count(new_position) - call deallocate(lmap_BA(ele_B)) + llnode => lmap_BA(ele_B)%firstnode + integral_B = 0.0 + vol_B = simplex_volume(new_position, ele_B) + pos_B = ele_val(new_position, ele_B) + + do while(associated(llnode)) + ele_A = llnode%value + vol_A = simplex_volume(old_position, ele_A) + integral_A = 0.0 + + call transform_to_physical(old_position, ele_A, detwei_A) + + do field=1,field_cnt + integral_A(field) = dot_product(ele_val_at_quad(old_fields(field), ele_A), detwei_A) + end do + + intersection = intersect_elements(old_position, ele_A, pos_B, supermesh_shape, empty_intersection=empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if + + do ele_C=1,ele_count(intersection) + vol_C = simplex_volume(intersection, ele_C) + do field=1,field_cnt + integral_B(field) = integral_B(field) + integral_A(field)*(vol_C/vol_A) + end do + end do + + do field=1,field_cnt + call set(pwc_B(field), ele_B, integral_B(field) / vol_B) + end do + + call deallocate(intersection) + + llnode => llnode%next + end do end do - deallocate(lmap_BA) - end if - end subroutine grandy_projection_scalars + call deallocate(supermesh_shape) + call deallocate(supermesh_quad) + + ! Now call the Galerkin projection routines to translate from P0 to Pn. + + do field=1,field_cnt + call insert(projection_state, pwc_B(field), trim(new_fields(field)%name)) + call insert(projection_state, new_position, "Coordinate") + + old_path = new_fields(field)%option_path + new_fields(field)%option_path = "/temporary" + call set_option("/temporary/diagnostic/source_field_name", trim(new_fields(field)%name), stat=stat) + call set_solver_options("/temporary/diagnostic", ksptype='cg', pctype='eisenstat', rtol=1.0e-10, max_its=20000) + call zero(new_fields(field)) + call calculate_galerkin_projection(projection_state, new_fields(field)) + call delete_option("/temporary") + new_fields(field)%option_path = old_path + + call deallocate(projection_state) + call deallocate(pwc_B(field)) + end do + + if (.not. present(map_BA)) then + do ele_B=1,ele_count(new_position) + call deallocate(lmap_BA(ele_B)) + end do + deallocate(lmap_BA) + end if + + end subroutine grandy_projection_scalars end module conservative_interpolation_module diff --git a/femtools/Coordinates.F90 b/femtools/Coordinates.F90 index fadd7024de..39e3f757d0 100644 --- a/femtools/Coordinates.F90 +++ b/femtools/Coordinates.F90 @@ -28,1437 +28,1437 @@ #include "fdebug.h" module Coordinates - use fldebug - use iso_c_binding - use global_parameters - use futils, only: int2str - use vector_tools - use spud - use parallel_tools, only: isparallel - use halos_base - use sparse_tools - use parallel_fields, only: zero_non_owned - use fields - use sparse_tools_petsc - use state_module - use halos - - implicit none - - private - - real, parameter:: rad_to_deg = 180.0/pi - real, parameter:: deg_to_rad = pi/180.0 - - public:: & - LongitudeLatitude, & - spherical_polar_2_cartesian, cartesian_2_spherical_polar, & - spherical_polar_2_cartesian_c, cartesian_2_spherical_polar_c, & - ll2r3_rotate, & - lon_lat_height_2_spherical_polar, spherical_polar_2_lon_lat_height, & - lon_lat_height_2_cartesian, cartesian_2_lon_lat_height, & - lon_lat_height_2_cartesian_c, cartesian_2_lon_lat_height_c, & - vector_spherical_polar_2_cartesian, vector_cartesian_2_spherical_polar, & - vector_lon_lat_height_2_cartesian, vector_cartesian_2_lon_lat_height, & - vector_lon_lat_height_2_cartesian_c, vector_cartesian_2_lon_lat_height_c, & - tensor_spherical_polar_2_cartesian, & - higher_order_sphere_projection, & - radial_inward_normal_at_quad_ele, radial_inward_normal_at_quad_face, & - rotate_diagonal_to_sphere_gi, rotate_diagonal_to_sphere_face, & - rotate_ct_m_sphere, rotate_momentum_to_sphere, & - rotate_velocity_sphere, rotate_velocity_back_sphere, & - Coordinates_check_options - - interface LongitudeLatitude - module procedure LongitudeLatitude_single, LongitudeLatitude_multiple - end interface - - interface spherical_polar_2_cartesian - module procedure spherical_polar_2_cartesian, & - spherical_polar_2_cartesian_field - end interface - - interface cartesian_2_spherical_polar - module procedure cartesian_2_spherical_polar, & - cartesian_2_spherical_polar_field - end interface - - interface vector_spherical_polar_2_cartesian - module procedure vector_spherical_polar_2_cartesian, & - vector_spherical_polar_2_cartesian_field - end interface - - interface vector_cartesian_2_spherical_polar - module procedure vector_cartesian_2_spherical_polar, & - vector_cartesian_2_spherical_polar_field - end interface + use fldebug + use iso_c_binding + use global_parameters + use futils, only: int2str + use vector_tools + use spud + use parallel_tools, only: isparallel + use halos_base + use sparse_tools + use parallel_fields, only: zero_non_owned + use fields + use sparse_tools_petsc + use state_module + use halos + + implicit none + + private + + real, parameter:: rad_to_deg = 180.0/pi + real, parameter:: deg_to_rad = pi/180.0 + + public:: & + LongitudeLatitude, & + spherical_polar_2_cartesian, cartesian_2_spherical_polar, & + spherical_polar_2_cartesian_c, cartesian_2_spherical_polar_c, & + ll2r3_rotate, & + lon_lat_height_2_spherical_polar, spherical_polar_2_lon_lat_height, & + lon_lat_height_2_cartesian, cartesian_2_lon_lat_height, & + lon_lat_height_2_cartesian_c, cartesian_2_lon_lat_height_c, & + vector_spherical_polar_2_cartesian, vector_cartesian_2_spherical_polar, & + vector_lon_lat_height_2_cartesian, vector_cartesian_2_lon_lat_height, & + vector_lon_lat_height_2_cartesian_c, vector_cartesian_2_lon_lat_height_c, & + tensor_spherical_polar_2_cartesian, & + higher_order_sphere_projection, & + radial_inward_normal_at_quad_ele, radial_inward_normal_at_quad_face, & + rotate_diagonal_to_sphere_gi, rotate_diagonal_to_sphere_face, & + rotate_ct_m_sphere, rotate_momentum_to_sphere, & + rotate_velocity_sphere, rotate_velocity_back_sphere, & + Coordinates_check_options + + interface LongitudeLatitude + module procedure LongitudeLatitude_single, LongitudeLatitude_multiple + end interface + + interface spherical_polar_2_cartesian + module procedure spherical_polar_2_cartesian, & + spherical_polar_2_cartesian_field + end interface + + interface cartesian_2_spherical_polar + module procedure cartesian_2_spherical_polar, & + cartesian_2_spherical_polar_field + end interface + + interface vector_spherical_polar_2_cartesian + module procedure vector_spherical_polar_2_cartesian, & + vector_spherical_polar_2_cartesian_field + end interface + + interface vector_cartesian_2_spherical_polar + module procedure vector_cartesian_2_spherical_polar, & + vector_cartesian_2_spherical_polar_field + end interface contains - subroutine LongitudeLatitude_single(xyz, longitude, latitude) - real, dimension(:), intent(in):: xyz - real, intent(out):: longitude, latitude - real r - - assert( size(xyz)==3 ) - r = sqrt(sum(xyz**2)) - if(r<1.0) then - ! May need to include a tolerance here - write(0, *) "XYZ = ", xyz - ewrite(-1,*) "Unit vector r on Earth's surface is of size, ", r - FLAbort("Coordinate doesn't appear to be on the Earth's surface") - end if + subroutine LongitudeLatitude_single(xyz, longitude, latitude) + real, dimension(:), intent(in):: xyz + real, intent(out):: longitude, latitude + real r + + assert( size(xyz)==3 ) + r = sqrt(sum(xyz**2)) + if(r<1.0) then + ! May need to include a tolerance here + write(0, *) "XYZ = ", xyz + ewrite(-1,*) "Unit vector r on Earth's surface is of size, ", r + FLAbort("Coordinate doesn't appear to be on the Earth's surface") + end if - longitude = rad_to_deg*atan2(xyz(2), xyz(1)) - latitude = 90.0 - rad_to_deg*acos(xyz(3)/r) + longitude = rad_to_deg*atan2(xyz(2), xyz(1)) + latitude = 90.0 - rad_to_deg*acos(xyz(3)/r) - end subroutine LongitudeLatitude_single + end subroutine LongitudeLatitude_single - subroutine LongitudeLatitude_multiple(xyz, longitude, latitude) - real, dimension(:,:), intent(in):: xyz - real, dimension(:), intent(out):: longitude, latitude + subroutine LongitudeLatitude_multiple(xyz, longitude, latitude) + real, dimension(:,:), intent(in):: xyz + real, dimension(:), intent(out):: longitude, latitude - integer i + integer i - do i=1, size(xyz,2) - call LongitudeLatitude_single( xyz(:,i), & + do i=1, size(xyz,2) + call LongitudeLatitude_single( xyz(:,i), & longitude(i), latitude(i)) - end do + end do + + end subroutine LongitudeLatitude_multiple + + elemental subroutine ll2r3_rotate(longitude, latitude, u, v, r3u, r3v, r3w) + real, intent(in)::longitude, latitude, u, v + real, intent(out)::r3u, r3v, r3w + real t + + r3w = v*cos(deg_to_rad*latitude) + t = v*sin(deg_to_rad*latitude) + + r3v = u*cos(deg_to_rad*longitude) - t*sin(deg_to_rad*longitude) + r3u = -(u*sin(deg_to_rad*longitude) + t*cos(deg_to_rad*longitude)) + + end subroutine ll2r3_rotate + + subroutine spherical_polar_2_cartesian(radius,theta,phi,x,y,z) + !Subroutine for calculation of Cartesian coordinates from spherical-polar + ! coordinates. + implicit none + + real, intent(in) :: radius !Distance from centre of sphere + real, intent(in) :: theta !Polar angle, in radians + real, intent(in) :: phi !Azimuthal angle, in radians + real, intent(out) :: x,y,z !Cartesian coordinates + + x = radius*sin(theta)*cos(phi) + y = radius*sin(theta)*sin(phi) + z = radius*cos(theta) - end subroutine LongitudeLatitude_multiple + end subroutine spherical_polar_2_cartesian + + subroutine spherical_polar_2_cartesian_c(radius,theta,phi,x,y,z) bind(c) + !C-inter-operable subroutine for calculation of Cartesian coordinates + ! from spherical-polar coordinates. + implicit none + + real(kind=c_double) :: radius !Distance from centre of sphere + real(kind=c_double) :: theta !Polar angle, in radians + real(kind=c_double) :: phi !Azimuthal angle, in radians + real(kind=c_double) :: x,y,z !Cartesian coordinates + + real :: radius_f + real :: theta_f + real :: phi_f + real :: x_f,y_f,z_f - elemental subroutine ll2r3_rotate(longitude, latitude, u, v, r3u, r3v, r3w) - real, intent(in)::longitude, latitude, u, v - real, intent(out)::r3u, r3v, r3w - real t + !Cast input variables to Fortran intrinsic types. + radius_f = real(radius) + theta_f = real(theta) + phi_f = real(phi) + + !Convert coordinates + call spherical_polar_2_cartesian(radius_f,theta_f,phi_f,x_f,y_f,z_f) + + !Cast output variables to C-inter-operable types. + x = real(x_f, kind=c_double) + y = real(y_f, kind=c_double) + z = real(z_f, kind=c_double) + + end subroutine spherical_polar_2_cartesian_c + + subroutine cartesian_2_spherical_polar(x,y,z,radius,theta,phi) + !Subroutine for calculation of spherical-polar coordinates from cartesian. + implicit none + + real, intent(in) :: x,y,z !cartesian coordinates + real, intent(out) :: radius !Distance from centre of sphere + real, intent(out) :: theta !Polar angle, in radians + real, intent(out) :: phi !Azimuthal angle, in radians + + radius = sqrt(x**2 + y**2 + z**2) + theta = acos(z/radius) + phi = atan2(y,x) + + end subroutine cartesian_2_spherical_polar + + subroutine cartesian_2_spherical_polar_c(x, y, z, radius, theta, phi) bind(c) + !C-inter-operable subroutine for calculation of spherical-polar coordinates + ! from Cartesian coordinates. + implicit none + + real(kind=c_double) :: x,y,z !cartesian coordinates + real(kind=c_double) :: radius !Distance from centre of sphere + real(kind=c_double) :: theta !Polar angle, in radians + real(kind=c_double) :: phi !Azimuthal angle, in radians + + real :: x_f,y_f,z_f + real :: radius_f + real :: theta_f + real :: phi_f + + !Cast input variables to fortran intrinsic types. + x_f = real(x) + y_f = real(y) + z_f = real(z) + + !Convert coordinates + call cartesian_2_spherical_polar(x_f, y_f, z_f, radius_f, theta_f, phi_f) + + !Cast output variables to C-inter-operable types. + radius = real(radius_f, kind=c_double) + theta = real(theta_f, kind=c_double) + phi = real(phi_f, kind=c_double) + + end subroutine cartesian_2_spherical_polar_c + + subroutine spherical_polar_2_cartesian_field(spherical_polar_coordinate_field, & + cartesian_coordinate_field) + !Subroutine for conversion of a spherical-polar coordinate field into a cartesian + ! coordinate field. + implicit none + + type(vector_field) :: spherical_polar_coordinate_field + type(vector_field) :: cartesian_coordinate_field + integer :: node + real, dimension(3) :: XYZ, RTP !arrays containing a single node's position vector + ! in cartesian & spherical-polar bases + + do node=1,node_count(spherical_polar_coordinate_field) + RTP = node_val(spherical_polar_coordinate_field, node) + call spherical_polar_2_cartesian(RTP(1), RTP(2), RTP(3), XYZ(1), XYZ(2), XYZ(3)) + call set(cartesian_coordinate_field, node, XYZ) + enddo + + end subroutine spherical_polar_2_cartesian_field + + subroutine cartesian_2_spherical_polar_field(cartesian_coordinate_field, & + spherical_polar_coordinate_field) + !Subroutine for conversion of a cartesian coordinate field into a spherical-polar + ! coordinate field. + implicit none + + type(vector_field) :: cartesian_coordinate_field + type(vector_field) :: spherical_polar_coordinate_field + integer :: node + real, dimension(3) :: XYZ, RTP !arrays containing a single node's position vector + ! components in cartesian & spherical-polar bases + + do node=1,node_count(cartesian_coordinate_field) + XYZ = node_val(cartesian_coordinate_field, node) + call cartesian_2_spherical_polar(XYZ(1), XYZ(2), XYZ(3), RTP(1), RTP(2), RTP(3)) + call set(spherical_polar_coordinate_field, node, RTP) + enddo + + end subroutine cartesian_2_spherical_polar_field + + subroutine lon_lat_height_2_spherical_polar(longitude, latitude, height, & + radius, theta, phi, & + referenceRadius) + !Subroutine for conversion of longitude-latitude-height coordinates on a + ! sphere to spherical-polar coordinates. Longitude and latitude must be + ! in degrees, polar coordinates are returned into radians + implicit none + + real, intent(in) :: longitude !in degrees + real, intent(in) :: latitude !in degrees + real, intent(in) :: height + real, intent(out) :: radius !Distance from centre of sphere + real, intent(out) :: theta !Polar angle, in radians + real, intent(out) :: phi !Azimuthal angle, in radians + real, intent(in), optional :: referenceRadius !Distance form the centre of + ! the sphere to its surface + real :: pi + + pi=4*atan(1.0) + + !Convert longitude to azimuthal angle and latitude in polar angle; in radians. + phi = longitude*pi/180. + theta = (90.- latitude)*pi/180. + + !Convert height to distance from origin + ! Check if referenceRadius is present. If not use default value + ! of surface radius, available in global_parameters module + if(present(referenceRadius)) then + radius = height + referenceRadius + else + radius = height + surface_radius + endif + + end subroutine lon_lat_height_2_spherical_polar + + subroutine spherical_polar_2_lon_lat_height(radius, theta, phi, & + longitude, latitude, height, & + referenceRadius) + !Subroutine for conversion of spherical-polar coordinates to + ! longitude-latitude-height coordinates. The polar coordinates must + ! be given in radians. Longitude and latitude are returned in + ! degrees. If referenceRadius is specified, height is measured as the + ! radial distance relative to that radius, ie it is the distance relative to the + ! surface of the sphere. if referenceRadius is absent height is the distance + ! from the center of the sphere. + implicit none + + real, intent(in) :: radius !Distance from centre of sphere + real, intent(in) :: theta !Polar angle, in radians + real, intent(in) :: phi !Azimuthal angle, in radians + real, intent(out) :: longitude !in degrees + real, intent(out) :: latitude !in degrees + real, intent(out) :: height + real, intent(in), optional :: referenceRadius !distance form the centre of + ! the sphere to its surface + real :: pi + + pi=4*atan(1.0) + + longitude = phi*180.0/pi + latitude = (pi/2 - theta)*180.0/pi + + !If referenceRadius is present, subtract it from the radial distance + if(present(referenceRadius)) then + height = radius - referenceRadius + else + height = radius - surface_radius + endif + + end subroutine spherical_polar_2_lon_lat_height + + subroutine lon_lat_height_2_cartesian(longitude, latitude, height, & + x, y, z, & + referenceRadius) + !Subroutine for conversion of longitude-latitude-height coordinates into + ! Cartesian coordinates. If referenceRadius is specified, height is measured + ! as the radial distance relative to that radius, i.e. it is the distance + ! relative to the surface of the sphere. + implicit none + + real, intent(in) :: longitude !in degrees + real, intent(in) :: latitude !in degrees + real, intent(in) :: height + real, intent(out) :: x,y,z !Cartesian coordinates + real, intent(in), optional :: referenceRadius + + real :: radius !Distance from centre of sphere + real :: theta !Polar angle, in radians + real :: phi !Azimuthal angle, in radians + + !Convert longitude-latitude-height into spherical-polar coordinates. + ! Check if referenceRadius is present. If not use default value + ! of surface radius, available in global_parameters module + if(present(referenceRadius)) then + call lon_lat_height_2_spherical_polar(longitude, latitude, height, & + radius, theta, phi, & + referenceRadius) + else + call lon_lat_height_2_spherical_polar(longitude, latitude, height, & + radius, theta, phi, & + surface_radius) + endif + + + !convert spherical-polar coordinates to Cartesian + call spherical_polar_2_cartesian(radius,theta,phi,x,y,z) + + end subroutine lon_lat_height_2_cartesian + + subroutine lon_lat_height_2_cartesian_c(longitude, latitude, height, & + x, y, z, & + referenceRadius) bind(c) + !C-inter-operable subroutine for conversion of longitude-latitude-height into + ! spherical-polar coordinates. referenceRadius must be specified, i.e. height + ! is always measured as the radial distance relative to that radius and denotes + ! the distance from the surface of the sphere. + implicit none + + real(kind=c_double) :: longitude !Longitude, in radians. + real(kind=c_double) :: latitude !Latitude, in radians. + real(kind=c_double) :: height !Distance from surface of sphere. + real(kind=c_double) :: x,y,z !Cartesian coordinates. + real(kind=c_double) :: referenceRadius !Sphere radius. + + real :: longitude_f + real :: latitude_f + real :: height_f + real :: x_f,y_f,z_f + real :: referenceRadius_f + + !Cast input variables to Fortran intrinsic types. + longitude_f = real(longitude) + latitude_f = real(latitude) + height_f = real(height) + referenceRadius_f = real(referenceRadius) + + !Convert coordinates + call lon_lat_height_2_cartesian(longitude_f, latitude_f, height_f, & + x_f, y_f, z_f, & + referenceRadius_f) + + !Cast output variables to C-inter-operable types. + x = real(x_f, kind=c_double) + y = real(y_f, kind=c_double) + z = real(z_f, kind=c_double) + + end subroutine lon_lat_height_2_cartesian_c + + subroutine cartesian_2_lon_lat_height(x, y, z, longitude, latitude, height, & + referenceRadius) + !Subroutine for conversion of Cartesian coordinates into longitude-latitude-height + ! If referenceRadius is specified, height is measures as the radial distance relative + ! to that radius. + implicit none + + real, intent(in) :: x,y,z !Cartesian coordinates + real, intent(out) :: longitude !in degrees + real, intent(out) :: latitude !in degrees + real, intent(out) :: height + real, intent(in), optional :: referenceRadius + real :: radius !Distance from centre of sphere + real :: theta !Polar angle, in radians + real :: phi !Azimuthal angle, in radians + + !convert Cartesian coordinates to spherical-polar + call cartesian_2_spherical_polar(x,y,z,radius,theta,phi) + + !Convert polar angle into latitude and azimuthal angle into longitude; in radians. + if(present(referenceRadius)) then + call spherical_polar_2_lon_lat_height(radius, theta, phi, & + longitude, latitude, height, & + referenceRadius) + else + call spherical_polar_2_lon_lat_height(radius, theta, phi, & + longitude, latitude, height) + endif + + + end subroutine cartesian_2_lon_lat_height + + subroutine cartesian_2_lon_lat_height_c(x, y, z, longitude, latitude, height, & + referenceRadius) bind(c) + !C-inter-operable subroutine for conversion of Cartesian coordinates into + ! longitude-latitude-height. + implicit none + + real(kind=c_double) :: x,y,z !Cartesian coordinates + real(kind=c_double) :: longitude !in degrees + real(kind=c_double) :: latitude !in degrees + real(kind=c_double) :: height + real(kind=c_double) :: referenceRadius + + real :: x_f,y_f,z_f + real :: longitude_f + real :: latitude_f + real :: height_f + real :: referenceRadius_f + + !Cast input variables to Fortran intrinsic types. + x_f = real(x) + y_f = real(y) + z_f = real(z) + + referenceRadius_f = real(referenceRadius) + + !Convert coordinates + call cartesian_2_lon_lat_height(x_f, y_f, z_f, longitude_f, latitude_f, height_f, & + referenceRadius_f) + + !Cast output variables to C-inter-operable types. + longitude = real(longitude_f, kind=c_double) + latitude = real(latitude_f, kind=c_double) + height = real(height_f, kind=c_double) + + end subroutine cartesian_2_lon_lat_height_c + + subroutine transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) + !Subroutine calculating transformation matrix for spherical-polar to/from Cartesian + ! tensor transformations. The routine also returns the transposed transformation matrix + implicit none + + real, intent(in) :: xCoord !x-component of position vector + real, intent(in) :: yCoord !y-component of position vector + real, intent(in) :: zCoord !z-component of position vector + real, dimension(3,3), intent(out) :: R !Transformation matrix + real, dimension(3,3), intent(out) :: RT !Transposed transformation matrix + + real :: radius !Distance from centre of sphere + real :: theta !Polar angle, in radians + real :: phi !Azimuthal angle, in radians + + !Calculate position-vector components in spherical-polar basis + call cartesian_2_spherical_polar(xCoord, yCoord, zCoord, radius, theta, phi) + + R(1,1)=sin(theta)*cos(phi) + R(1,2)=sin(theta)*sin(phi) + R(1,3)=cos(theta) + R(2,1)=cos(theta)*cos(phi) + R(2,2)=cos(theta)*sin(phi) + R(2,3)=-sin(theta) + R(3,1)=-sin(phi) + R(3,2)=cos(phi) + R(3,3)=0.0 + + RT = TRANSPOSE(R) + + end subroutine transformation_matrix_cartesian_2_spherical_polar + + subroutine vector_spherical_polar_2_cartesian(radial, polar, azimuthal, & + radius, theta, phi, & + xComp, yComp, zComp, & + xCoord, yCoord, zCoord) + !Subroutine for vector change of basis: from spherical-polar to cartesian. The + ! coordinates of the position vector are also transformed + implicit none + + real, intent(in) :: radial !Radial component of vector + real, intent(in) :: polar !Polar component of vector + real, intent(in) :: azimuthal !Azimuthal component of vector + real, intent(in) :: radius !Distance from centre of sphere + real, intent(in) :: theta !Polar angle, in radians + real, intent(in) :: phi !Azimuthal angle, in radians + real, intent(out) :: xComp !1st vector component in cartesian basis + real, intent(out) :: yComp !2nd vector component in cartesian basis + real, intent(out) :: zComp !3rd vector component in cartesian basis + real, intent(out) :: xCoord !1st vector component of position vector in cartesian basis + real, intent(out) :: yCoord !2nd vector component of position vector in cartesian basis + real, intent(out) :: zCoord !3rd vector component of position vector in cartesian basis + + real, dimension(3) :: cartesianComponents + real, dimension(3,3) :: R !Transformation matrix + real, dimension(3,3) :: RT !Transposed transformation matrix + + !Calculate position-vector components in cartesian system + call spherical_polar_2_cartesian(radius, theta, phi, xCoord, yCoord, zCoord) + + !Calculate transformation matrix + call transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) + + !Evaluate vector components in Cartesian basis + cartesianComponents = matmul(RT,(/radial, polar, azimuthal/)) + xComp = cartesianComponents(1) + yComp = cartesianComponents(2) + zComp = cartesianComponents(3) + + end subroutine vector_spherical_polar_2_cartesian + + subroutine vector_cartesian_2_spherical_polar(xComp, yComp, zComp, & + xCoord, yCoord, zCoord, & + radial, polar, azimuthal, & + radius, theta, phi) + !Subroutine for vector change of basis: from Cartesian to spherical-polar. The + ! coordinates of the position vector are also transformed + implicit none + + real, intent(in) :: xComp !1st vector component in cartesian basis + real, intent(in) :: yComp !2nd vector component in cartesian basis + real, intent(in) :: zComp !3rd vector component in cartesian basis + real, intent(in) :: xCoord !1st vector component of position vector in cartesian basis + real, intent(in) :: yCoord !2nd vector component of position vector in cartesian basis + real, intent(in) :: zCoord !3rd vector component of position vector in cartesian basis + real, intent(out) :: radial !Radial component of vector + real, intent(out) :: polar !Polar component of vector + real, intent(out) :: azimuthal !Azimuthal component of vector + real, intent(out) :: radius !Distance from centre of sphere + real, intent(out) :: theta !Polar angle, in radians + real, intent(out) :: phi !Azimuthal angle, in radians + + real, dimension(3) :: sphericalPolarComponents + real, dimension(3,3) :: R !Transformation matrix + real, dimension(3,3) :: RT !Transposed transformation matrix + + !Calculate position-vector components in spherical-polar system + call cartesian_2_spherical_polar(xCoord, yCoord, zCoord, radius, theta, phi) + + !Calculate transformation matrix + call transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) + + !Evaluate vector components in spherical-polar basis + sphericalPolarComponents = matmul(R,(/xComp, yComp, zComp/)) + radial = sphericalPolarComponents(1) + polar = sphericalPolarComponents(2) + azimuthal = sphericalPolarComponents(3) + + end subroutine vector_cartesian_2_spherical_polar + + subroutine vector_lon_lat_height_2_cartesian(zonalComponent,& + meridionalComponent,& + verticalComponent, & + longitude, & + latitude, & + height, & + xComp, yComp, zComp, & + xCoord, yCoord, zCoord, & + referenceRadius) + !Subroutine for change of basis of a vector from meridional-zonal-vertical + ! components to cartesian components. + implicit none + + real, intent(in) :: zonalComponent !Vector component tangential to parallel + real, intent(in) :: meridionalComponent !Vector component tangential to meridian + real, intent(in) :: verticalComponent !Vecor component in the vertical (radial) + real, intent(in) :: longitude + real, intent(in) :: latitude + real, intent(in) :: height + real, intent(out) :: xComp !1st vector component in cartesian basis + real, intent(out) :: yComp !2nd vector component in cartesian basis + real, intent(out) :: zComp !3rd vector component in cartesian basis + real, intent(out) :: xCoord !1st vector component of position vector + ! in Cartesian basis + real, intent(out) :: yCoord !2nd vector component of position vector + ! in Cartesian basis + real, intent(out) :: zCoord !3rd vector component of position vector + ! in Cartesian basis + real, intent(in), optional :: referenceRadius + real :: radial !Radial component of vector + real :: polar !Polar component of vector + real :: azimuthal !Azimuthal component of vector + real :: radius !Distance from centre of sphere + real :: theta !Polar angle, in radians + real :: phi !Azimuthal angle, in radians + + !Convert zonal-meridional-vertical components to spherical-polar + azimuthal = zonalComponent + polar = -meridionalComponent + radial = verticalComponent + !Convert longitude-latitude-height to spherical-polar. + ! If referenceRadius is present then pass that to coordinate conversion routine, + ! height then is the radial distance of a point from the sphere with radius= + ! referenceRadius. Otherwise height is simply the distance from the Cartesian + ! coordinate origin. + if(present(referenceRadius)) then + call lon_lat_height_2_spherical_polar(longitude, latitude, height, & + radius, theta, phi, & + referenceRadius) + else + call lon_lat_height_2_spherical_polar(longitude, latitude, height, & + radius, theta, phi) + endif + !convert spherical-polar components to cartesian. + call vector_spherical_polar_2_cartesian(radial, polar, azimuthal, & + radius, theta, phi, & + xComp, yComp, zComp, & + xCoord, yCoord, zCoord) + + end subroutine vector_lon_lat_height_2_cartesian + + subroutine vector_cartesian_2_lon_lat_height(xComp, yComp, zComp, & + xCoord, yCoord, zCoord, & + zonalComponent,& + meridionalComponent,& + verticalComponent, & + longitude, & + latitude, & + height, & + referenceRadius) + !Subroutine for change of basis of a vector from cartesian to + ! meridional-zonal-vertical. + implicit none + + real, intent(in) :: xComp !1st vector component in cartesian basis + real, intent(in) :: yComp !2nd vector component in cartesian basis + real, intent(in) :: zComp !3rd vector component in cartesian basis + real, intent(in) :: xCoord !1st vector component of position vector + ! in Cartesian basis + real, intent(in) :: yCoord !2nd vector component of position vector + ! in Cartesian basis + real, intent(in) :: zCoord !3rd vector component of position vector + ! in Cartesian basis + real, intent(out) :: zonalComponent !Vector component tangential to parallel + real, intent(out) :: meridionalComponent !Vector component tangential to meridian + real, intent(out) :: verticalComponent !Vector component in the vertical (radial) + real, intent(out) :: longitude + real, intent(out) :: latitude + real, intent(out) :: height + real, intent(in), optional :: referenceRadius + real :: radial !Radial component of vector + real :: polar !Polar component of vector + real :: azimuthal !Azimuthal component of vector + real :: radius !Distance from centre of sphere + real :: theta !Polar angle, in radians + real :: phi !Azimuthal angle, in radians + + !Convert cartesian components to spherical-polar + call vector_cartesian_2_spherical_polar(xComp, yComp, zComp, & + xCoord, yCoord, zCoord, & + radial, polar, azimuthal, & + radius, theta, phi) + !Convert cartesian coordinates to longitude-latitude-radius + if(present(referenceRadius)) then + call cartesian_2_lon_lat_height(xCoord, yCoord, zCoord, & + longitude, latitude, height, & + referenceRadius) + else + call cartesian_2_lon_lat_height(xCoord, yCoord, zCoord, & + longitude, latitude, height) + endif + !Convert spherical-polar components to zonal-meridional-vertical + zonalComponent = azimuthal + meridionalComponent = -polar + verticalComponent = radial + + end subroutine vector_cartesian_2_lon_lat_height + + subroutine vector_lon_lat_height_2_cartesian_c(zonalComponent,& + meridionalComponent,& + verticalComponent, & + longitude, & + latitude, & + height, & + xComp, yComp, zComp, & + xCoord, yCoord, zCoord, & + referenceRadius) bind(c) + !C-interoperable subroutine for change of basis of a vector from + ! meridional-zonal-vertical components to cartesian components. Note that + ! unlike the Fortran version of the present routine, referenceRadius is + ! a mandatory argument. + implicit none + + real(kind=c_double), intent(in) :: zonalComponent !Vector component tangential + ! to parallel + real(kind=c_double), intent(in) :: meridionalComponent !Vector component tangential + ! to meridian + real(kind=c_double), intent(in) :: verticalComponent !Vecor component in the + ! vertical (radial) + real(kind=c_double), intent(in) :: longitude + real(kind=c_double), intent(in) :: latitude + real(kind=c_double), intent(in) :: height + real(kind=c_double), intent(out) :: xComp !1st vector component in + ! cartesian basis + real(kind=c_double), intent(out) :: yComp !2nd vector component in + ! cartesian basis + real(kind=c_double), intent(out) :: zComp !3rd vector component in + ! cartesian basis + real(kind=c_double), intent(out) :: xCoord !1st vector component of + ! position vector in cartesian basis + real(kind=c_double), intent(out) :: yCoord !2nd vector component of + ! position vector in cartesian basis + real(kind=c_double), intent(out) :: zCoord !3rd vector component of + ! position vector in cartesian basis + real(kind=c_double), intent(in) :: referenceRadius + + real :: zonalComponent_f !Vector component tangential to parallel + real :: meridionalComponent_f !Vector component tangential to meridian + real :: verticalComponent_f !Vecor component in the vertical (radial) + real :: longitude_f + real :: latitude_f + real :: height_f + real :: xComp_f !1st vector component in cartesian basis + real :: yComp_f !2nd vector component in cartesian basis + real :: zComp_f !3rd vector component in cartesian basis + real :: xCoord_f !1st vector component of position vector in cartesian basis + real :: yCoord_f !2nd vector component of position vector in cartesian basis + real :: zCoord_f !3rd vector component of position vector in cartesian basis + real :: referenceRadius_f + + !Convert C-types in to Fortran intrinsic types. + zonalComponent_f = real(zonalComponent) + meridionalComponent_f = real(meridionalComponent) + verticalComponent_f = real(verticalComponent) + longitude_f = real(longitude) + latitude_f = real(latitude) + height_f = real(height) + referenceRadius_f = real(referenceRadius) + + !Convert coordinates and components. + call vector_lon_lat_height_2_cartesian(zonalComponent_f,& + meridionalComponent_f,& + verticalComponent_f, & + longitude_f, & + latitude_f, & + height_f, & + xComp_f, yComp_f, zComp_f, & + xCoord_f, yCoord_f, zCoord_f, & + referenceRadius_f) + + !Convert Fortran intrinsic types to C-types. + xComp = real(xComp_f, kind=c_double) + yComp = real(yComp_f, kind=c_double) + zComp = real(zComp_f, kind=c_double) + xCoord = real(xCoord_f, kind=c_double) + yCoord = real(yCoord_f, kind=c_double) + zCoord = real(zCoord_f, kind=c_double) + + end subroutine vector_lon_lat_height_2_cartesian_c + + subroutine vector_cartesian_2_lon_lat_height_c(xComp, yComp, zComp, & + xCoord, yCoord, zCoord, & + zonalComponent,& + meridionalComponent,& + verticalComponent, & + longitude, & + latitude, & + height, & + referenceRadius) bind (c) + !C inter-operable subroutine for change of basis of a vector from Cartesian to + ! meridional-zonal-vertical. Note that + ! unlike the Fortran version of the present routine, referenceRadius is + ! a mandatory argument. + implicit none + + real(kind=c_double), intent(in) :: xComp !1st vector component in + ! cartesian basis + real(kind=c_double), intent(in) :: yComp !2nd vector component in + ! cartesian basis + real(kind=c_double), intent(in) :: zComp !3rd vector component in + ! cartesian basis + real(kind=c_double), intent(in) :: xCoord !1st vector component of position + ! vector in Cartesian basis + real(kind=c_double), intent(in) :: yCoord !2nd vector component of position + ! vector in Cartesian basis + real(kind=c_double), intent(in) :: zCoord !3rd vector component of position + ! vector in Cartesian basis + real(kind=c_double), intent(out) :: zonalComponent !Vector component tangential + ! to parallel + real(kind=c_double), intent(out) :: meridionalComponent !Vector component tangential + ! to meridian + real(kind=c_double), intent(out) :: verticalComponent !Vector component in the + ! vertical (radial) + real(kind=c_double), intent(out) :: longitude + real(kind=c_double), intent(out) :: latitude + real(kind=c_double), intent(out) :: height + real(kind=c_double), intent(in) :: referenceRadius + + real :: xComp_f !1st vector component in cartesian basis + real :: yComp_f !2nd vector component in cartesian basis + real :: zComp_f !3rd vector component in cartesian basis + real :: xCoord_f !1st vector component of position vector + ! in Cartesian basis + real :: yCoord_f !2nd vector component of position vector + ! in Cartesian basis + real :: zCoord_f !3rd vector component of position vector + ! in Cartesian basis + real :: zonalComponent_f !Vector component tangential to parallel + real :: meridionalComponent_f !Vector component tangential to meridian + real :: verticalComponent_f !Vector component in the vertical (radial) + real :: longitude_f + real :: latitude_f + real :: height_f + real :: referenceRadius_f + + !Convert C-types in to Fortran intrinsic types. + xComp_f = real(xComp) + yComp_f = real(yComp) + zComp_f = real(zComp) + xCoord_f = real(xCoord) + yCoord_f = real(yCoord) + zCoord_f = real(zCoord) + referenceRadius_f = real(referenceRadius) + + !Convert coordinates and components. + call vector_cartesian_2_lon_lat_height(xComp_f, yComp_f, zComp_f, & + xCoord_f, yCoord_f, zCoord_f, & + zonalComponent_f, & + meridionalComponent_f, & + verticalComponent_f, & + longitude_f, & + latitude_f, & + height_f, & + referenceRadius_f) + + !Convert Fortran intrinsic types to C-types. + zonalComponent = real(zonalComponent_f, kind=c_double) + meridionalComponent = real(meridionalComponent_f, kind=c_double) + verticalComponent = real(verticalComponent_f, kind=c_double) + longitude = real(longitude_f, kind=c_double) + latitude = real(latitude_f, kind=c_double) + height = real(height_f, kind=c_double) + + end subroutine vector_cartesian_2_lon_lat_height_c + + subroutine vector_spherical_polar_2_cartesian_field(spherical_polar_vector_field, & + spherical_polar_coordinate_field, & + cartesian_vector_field, & + cartesian_coordinate_field) + !Subroutine for change of basis of a cartesian vector field into a spherical-polar + ! vector field. This routine also converts and returns the position vector component + ! fields + implicit none + + type(vector_field) :: spherical_polar_vector_field + type(vector_field) :: spherical_polar_coordinate_field + type(vector_field) :: cartesian_vector_field + type(vector_field) :: cartesian_coordinate_field + integer :: node + real, dimension(3) :: XYZ, RTP !arrays containing a signel node's position vector + ! in cartesian & spherical-polar bases + real, dimension(3) :: cartesianComponents, sphericalPolarComponents + + assert(node_count(spherical_polar_coordinate_field) == node_count(cartesian_coordinate_field)) + + do node=1,node_count(spherical_polar_coordinate_field) + RTP = node_val(spherical_polar_coordinate_field, node) + sphericalPolarComponents = node_val(spherical_polar_vector_field, node) + call vector_spherical_polar_2_cartesian(sphericalPolarComponents(1), & + sphericalPolarComponents(2), & + sphericalPolarComponents(3), & + RTP(1), RTP(2), RTP(3), & + cartesianComponents(1), & + cartesianComponents(2), & + cartesianComponents(3), & + XYZ(1), XYZ(2), XYZ(3)) + call set(cartesian_coordinate_field, node, XYZ) + call set(cartesian_vector_field, node, cartesianComponents) + enddo + end subroutine vector_spherical_polar_2_cartesian_field + + subroutine vector_cartesian_2_spherical_polar_field(cartesian_vector_field, & + cartesian_coordinate_field, & + spherical_polar_vector_field, & + spherical_polar_coordinate_field) + !Subroutine for change of basis of a cartesian vector field into a spherical-polar + ! vector field. This routine also converts and returns the position vector component + ! fields + implicit none + + type(vector_field) :: cartesian_vector_field + type(vector_field) :: cartesian_coordinate_field + type(vector_field) :: spherical_polar_vector_field + type(vector_field) :: spherical_polar_coordinate_field + integer :: node + real, dimension(3) :: XYZ, RTP !arrays containing a signel node's position vector + ! in cartesian & spherical-polar bases + real, dimension(3) :: cartesianComponents, sphericalPolarComponents + + assert(node_count(spherical_polar_coordinate_field) == node_count(cartesian_coordinate_field) ) + + do node=1,node_count(spherical_polar_coordinate_field) + XYZ = node_val(cartesian_coordinate_field, node) + cartesianComponents = node_val(cartesian_vector_field, node) + call vector_cartesian_2_spherical_polar(cartesianComponents(1), & + cartesianComponents(2), & + cartesianComponents(3), & + XYZ(1), XYZ(2), XYZ(3), & + sphericalPolarComponents(1), & + sphericalPolarComponents(2), & + sphericalPolarComponents(3), & + RTP(1), RTP(2), RTP(3)) + call set(spherical_polar_coordinate_field, node, RTP) + call set(spherical_polar_vector_field, node, sphericalPolarComponents) + enddo + end subroutine vector_cartesian_2_spherical_polar_field + + subroutine tensor_spherical_polar_2_cartesian(sphericalPolarComponents, & + radius, theta, phi, & + cartesianComponents, & + xCoord, yCoord, zCoord) + !Subroutine for tensor change of basis: From spherical-polar to cartesian. The + ! coordinates of the position vector are also transformed. The tensor must + ! be a 3x3 tensor. + implicit none + + real, intent(in), dimension(3,3) :: sphericalPolarComponents !Tensor + ! components in spherical-polar basis + real, intent(in) :: radius !Distance from centre of sphere + real, intent(in) :: theta !Polar angle, in radians + real, intent(in) :: phi !Azimuthal angle, in radians + real, intent(out), dimension(3,3) :: cartesianComponents !Tensor + ! components in Cartesian bisis + real, intent(out) :: xCoord !1st vector component of position vector + ! in cartesian basis + real, intent(out) :: yCoord !2nd vector component of position vector + ! in cartesian basis + real, intent(out) :: zCoord !3rd vector component of position vector + ! in cartesian basis + + real, dimension(3,3) :: R !Transformation matrix + real, dimension(3,3) :: RT !Transposed transformation matrix + + !Calculate position-vector components in cartesian system + call spherical_polar_2_cartesian(radius, theta, phi, xCoord, yCoord, zCoord) + + !Calculate transformation matrix + call transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) + + !Evaluate vector components in Cartesian basis + cartesianComponents = matmul(matmul(RT, sphericalPolarComponents), R) + + end subroutine tensor_spherical_polar_2_cartesian + + subroutine higher_order_sphere_projection(positions, s_positions) + !!< Given a P1 'positions' field and a Pn 's_positions' field, bends the + !!< elements of the 's_positions' field onto the sphere + type(vector_field), intent(inout):: positions + type(vector_field), intent(inout):: s_positions + + real rold, rnew + integer i + + type(scalar_field):: radius, s_radius + real, dimension(positions%dim):: xyz + + ewrite(1,*) 'In higher_order_sphere_projection' + + call allocate(s_radius, s_positions%mesh, "HigherOrderRadius") + radius=magnitude(positions) + call remap_field(radius, s_radius) + + ! then bend by adjusting to the linearly interpolated radius + do i=1, node_count(s_positions) + xyz=node_val(s_positions, i) + rold=sqrt(sum(xyz**2)) + rnew=node_val(s_radius, i) + call set(s_positions, i, xyz*rnew/rold) + end do + + call deallocate(s_radius) + call deallocate(radius) - r3w = v*cos(deg_to_rad*latitude) - t = v*sin(deg_to_rad*latitude) + end subroutine higher_order_sphere_projection - r3v = u*cos(deg_to_rad*longitude) - t*sin(deg_to_rad*longitude) - r3u = -(u*sin(deg_to_rad*longitude) + t*cos(deg_to_rad*longitude)) + function radial_inward_normal_at_quad_ele(positions, ele_number) result(quad_val) + ! Return the direction of gravity at the quadrature points of and element. + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele_number + real, dimension(positions%dim,ele_ngi(positions,ele_number)) :: X_quad, quad_val + integer :: i,j + + X_quad=ele_val_at_quad(positions, ele_number) + + do j=1,ele_ngi(positions,ele_number) + do i=1,positions%dim + quad_val(i,j)=-X_quad(i,j)/sqrt(sum(X_quad(:,j)**2)) + end do + end do + + end function radial_inward_normal_at_quad_ele + + function radial_inward_normal_at_quad_face(positions, face_number) result(quad_val) + ! Return the direction of gravity at the quadrature points of and element. + type(vector_field), intent(in) :: positions + integer, intent(in) :: face_number + real, dimension(positions%dim,face_ngi(positions,face_number)) :: X_quad, quad_val + integer :: i,j + + X_quad=face_val_at_quad(positions, face_number) + + do j=1,face_ngi(positions,face_number) + do i=1,positions%dim + quad_val(i,j)=-X_quad(i,j)/sqrt(sum(X_quad(:,j)**2)) + end do + end do - end subroutine ll2r3_rotate + end function radial_inward_normal_at_quad_face - subroutine spherical_polar_2_cartesian(radius,theta,phi,x,y,z) - !Subroutine for calculation of Cartesian coordinates from spherical-polar - ! coordinates. - implicit none + function rotate_diagonal_to_sphere_gi(positions, ele_number, diagonal) result(quad_val) + ! Given the diagonal of a tensor in cartesian coordinates, this function + ! transforms the tensor components to a spherical-polar basis. This result + ! is given by R(diagonal)R^T where R is the matrix of Eigen vectors of the + ! spherical-polar basis, expressed in the cartesian basis. + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele_number + real, dimension(positions%dim,ele_ngi(positions,ele_number)), intent(in) :: diagonal + real, dimension(positions%dim,ele_ngi(positions,ele_number)) :: X_quad + real, dimension(positions%dim,positions%dim) :: R, RT + real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele_number)) :: diagonal_T, quad_val + real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle + integer :: i - real, intent(in) :: radius !Distance from centre of sphere - real, intent(in) :: theta !Polar angle, in radians - real, intent(in) :: phi !Azimuthal angle, in radians - real, intent(out) :: x,y,z !Cartesian coordinates + assert(positions%dim==3) - x = radius*sin(theta)*cos(phi) - y = radius*sin(theta)*sin(phi) - z = radius*cos(theta) + X_quad=ele_val_at_quad(positions, ele_number) - end subroutine spherical_polar_2_cartesian - - subroutine spherical_polar_2_cartesian_c(radius,theta,phi,x,y,z) bind(c) - !C-inter-operable subroutine for calculation of Cartesian coordinates - ! from spherical-polar coordinates. - implicit none - - real(kind=c_double) :: radius !Distance from centre of sphere - real(kind=c_double) :: theta !Polar angle, in radians - real(kind=c_double) :: phi !Azimuthal angle, in radians - real(kind=c_double) :: x,y,z !Cartesian coordinates - - real :: radius_f - real :: theta_f - real :: phi_f - real :: x_f,y_f,z_f - - !Cast input variables to Fortran intrinsic types. - radius_f = real(radius) - theta_f = real(theta) - phi_f = real(phi) - - !Convert coordinates - call spherical_polar_2_cartesian(radius_f,theta_f,phi_f,x_f,y_f,z_f) - - !Cast output variables to C-inter-operable types. - x = real(x_f, kind=c_double) - y = real(y_f, kind=c_double) - z = real(z_f, kind=c_double) - - end subroutine spherical_polar_2_cartesian_c - - subroutine cartesian_2_spherical_polar(x,y,z,radius,theta,phi) - !Subroutine for calculation of spherical-polar coordinates from cartesian. - implicit none - - real, intent(in) :: x,y,z !cartesian coordinates - real, intent(out) :: radius !Distance from centre of sphere - real, intent(out) :: theta !Polar angle, in radians - real, intent(out) :: phi !Azimuthal angle, in radians - - radius = sqrt(x**2 + y**2 + z**2) - theta = acos(z/radius) - phi = atan2(y,x) - - end subroutine cartesian_2_spherical_polar - - subroutine cartesian_2_spherical_polar_c(x, y, z, radius, theta, phi) bind(c) - !C-inter-operable subroutine for calculation of spherical-polar coordinates - ! from Cartesian coordinates. - implicit none - - real(kind=c_double) :: x,y,z !cartesian coordinates - real(kind=c_double) :: radius !Distance from centre of sphere - real(kind=c_double) :: theta !Polar angle, in radians - real(kind=c_double) :: phi !Azimuthal angle, in radians - - real :: x_f,y_f,z_f - real :: radius_f - real :: theta_f - real :: phi_f - - !Cast input variables to fortran intrinsic types. - x_f = real(x) - y_f = real(y) - z_f = real(z) - - !Convert coordinates - call cartesian_2_spherical_polar(x_f, y_f, z_f, radius_f, theta_f, phi_f) - - !Cast output variables to C-inter-operable types. - radius = real(radius_f, kind=c_double) - theta = real(theta_f, kind=c_double) - phi = real(phi_f, kind=c_double) - - end subroutine cartesian_2_spherical_polar_c - - subroutine spherical_polar_2_cartesian_field(spherical_polar_coordinate_field, & - cartesian_coordinate_field) - !Subroutine for conversion of a spherical-polar coordinate field into a cartesian - ! coordinate field. - implicit none - - type(vector_field) :: spherical_polar_coordinate_field - type(vector_field) :: cartesian_coordinate_field - integer :: node - real, dimension(3) :: XYZ, RTP !arrays containing a single node's position vector - ! in cartesian & spherical-polar bases - - do node=1,node_count(spherical_polar_coordinate_field) - RTP = node_val(spherical_polar_coordinate_field, node) - call spherical_polar_2_cartesian(RTP(1), RTP(2), RTP(3), XYZ(1), XYZ(2), XYZ(3)) - call set(cartesian_coordinate_field, node, XYZ) - enddo - - end subroutine spherical_polar_2_cartesian_field - - subroutine cartesian_2_spherical_polar_field(cartesian_coordinate_field, & - spherical_polar_coordinate_field) - !Subroutine for conversion of a cartesian coordinate field into a spherical-polar - ! coordinate field. - implicit none - - type(vector_field) :: cartesian_coordinate_field - type(vector_field) :: spherical_polar_coordinate_field - integer :: node - real, dimension(3) :: XYZ, RTP !arrays containing a single node's position vector - ! components in cartesian & spherical-polar bases - - do node=1,node_count(cartesian_coordinate_field) - XYZ = node_val(cartesian_coordinate_field, node) - call cartesian_2_spherical_polar(XYZ(1), XYZ(2), XYZ(3), RTP(1), RTP(2), RTP(3)) - call set(spherical_polar_coordinate_field, node, RTP) - enddo - - end subroutine cartesian_2_spherical_polar_field - - subroutine lon_lat_height_2_spherical_polar(longitude, latitude, height, & - radius, theta, phi, & - referenceRadius) - !Subroutine for conversion of longitude-latitude-height coordinates on a - ! sphere to spherical-polar coordinates. Longitude and latitude must be - ! in degrees, polar coordinates are returned into radians - implicit none - - real, intent(in) :: longitude !in degrees - real, intent(in) :: latitude !in degrees - real, intent(in) :: height - real, intent(out) :: radius !Distance from centre of sphere - real, intent(out) :: theta !Polar angle, in radians - real, intent(out) :: phi !Azimuthal angle, in radians - real, intent(in), optional :: referenceRadius !Distance form the centre of - ! the sphere to its surface - real :: pi - - pi=4*atan(1.0) - - !Convert longitude to azimuthal angle and latitude in polar angle; in radians. - phi = longitude*pi/180. - theta = (90.- latitude)*pi/180. - - !Convert height to distance from origin - ! Check if referenceRadius is present. If not use default value - ! of surface radius, available in global_parameters module - if(present(referenceRadius)) then - radius = height + referenceRadius - else - radius = height + surface_radius - endif - - end subroutine lon_lat_height_2_spherical_polar - - subroutine spherical_polar_2_lon_lat_height(radius, theta, phi, & - longitude, latitude, height, & - referenceRadius) - !Subroutine for conversion of spherical-polar coordinates to - ! longitude-latitude-height coordinates. The polar coordinates must - ! be given in radians. Longitude and latitude are returned in - ! degrees. If referenceRadius is specified, height is measured as the - ! radial distance relative to that radius, ie it is the distance relative to the - ! surface of the sphere. if referenceRadius is absent height is the distance - ! from the center of the sphere. - implicit none - - real, intent(in) :: radius !Distance from centre of sphere - real, intent(in) :: theta !Polar angle, in radians - real, intent(in) :: phi !Azimuthal angle, in radians - real, intent(out) :: longitude !in degrees - real, intent(out) :: latitude !in degrees - real, intent(out) :: height - real, intent(in), optional :: referenceRadius !distance form the centre of - ! the sphere to its surface - real :: pi - - pi=4*atan(1.0) - - longitude = phi*180.0/pi - latitude = (pi/2 - theta)*180.0/pi - - !If referenceRadius is present, subtract it from the radial distance - if(present(referenceRadius)) then - height = radius - referenceRadius - else - height = radius - surface_radius - endif - - end subroutine spherical_polar_2_lon_lat_height - - subroutine lon_lat_height_2_cartesian(longitude, latitude, height, & - x, y, z, & - referenceRadius) - !Subroutine for conversion of longitude-latitude-height coordinates into - ! Cartesian coordinates. If referenceRadius is specified, height is measured - ! as the radial distance relative to that radius, i.e. it is the distance - ! relative to the surface of the sphere. - implicit none - - real, intent(in) :: longitude !in degrees - real, intent(in) :: latitude !in degrees - real, intent(in) :: height - real, intent(out) :: x,y,z !Cartesian coordinates - real, intent(in), optional :: referenceRadius - - real :: radius !Distance from centre of sphere - real :: theta !Polar angle, in radians - real :: phi !Azimuthal angle, in radians - - !Convert longitude-latitude-height into spherical-polar coordinates. - ! Check if referenceRadius is present. If not use default value - ! of surface radius, available in global_parameters module - if(present(referenceRadius)) then - call lon_lat_height_2_spherical_polar(longitude, latitude, height, & - radius, theta, phi, & - referenceRadius) - else - call lon_lat_height_2_spherical_polar(longitude, latitude, height, & - radius, theta, phi, & - surface_radius) - endif - - - !convert spherical-polar coordinates to Cartesian - call spherical_polar_2_cartesian(radius,theta,phi,x,y,z) - - end subroutine lon_lat_height_2_cartesian - - subroutine lon_lat_height_2_cartesian_c(longitude, latitude, height, & - x, y, z, & - referenceRadius) bind(c) - !C-inter-operable subroutine for conversion of longitude-latitude-height into - ! spherical-polar coordinates. referenceRadius must be specified, i.e. height - ! is always measured as the radial distance relative to that radius and denotes - ! the distance from the surface of the sphere. - implicit none - - real(kind=c_double) :: longitude !Longitude, in radians. - real(kind=c_double) :: latitude !Latitude, in radians. - real(kind=c_double) :: height !Distance from surface of sphere. - real(kind=c_double) :: x,y,z !Cartesian coordinates. - real(kind=c_double) :: referenceRadius !Sphere radius. - - real :: longitude_f - real :: latitude_f - real :: height_f - real :: x_f,y_f,z_f - real :: referenceRadius_f - - !Cast input variables to Fortran intrinsic types. - longitude_f = real(longitude) - latitude_f = real(latitude) - height_f = real(height) - referenceRadius_f = real(referenceRadius) - - !Convert coordinates - call lon_lat_height_2_cartesian(longitude_f, latitude_f, height_f, & - x_f, y_f, z_f, & - referenceRadius_f) - - !Cast output variables to C-inter-operable types. - x = real(x_f, kind=c_double) - y = real(y_f, kind=c_double) - z = real(z_f, kind=c_double) - - end subroutine lon_lat_height_2_cartesian_c - - subroutine cartesian_2_lon_lat_height(x, y, z, longitude, latitude, height, & - referenceRadius) - !Subroutine for conversion of Cartesian coordinates into longitude-latitude-height - ! If referenceRadius is specified, height is measures as the radial distance relative - ! to that radius. - implicit none - - real, intent(in) :: x,y,z !Cartesian coordinates - real, intent(out) :: longitude !in degrees - real, intent(out) :: latitude !in degrees - real, intent(out) :: height - real, intent(in), optional :: referenceRadius - real :: radius !Distance from centre of sphere - real :: theta !Polar angle, in radians - real :: phi !Azimuthal angle, in radians - - !convert Cartesian coordinates to spherical-polar - call cartesian_2_spherical_polar(x,y,z,radius,theta,phi) - - !Convert polar angle into latitude and azimuthal angle into longitude; in radians. - if(present(referenceRadius)) then - call spherical_polar_2_lon_lat_height(radius, theta, phi, & - longitude, latitude, height, & - referenceRadius) - else - call spherical_polar_2_lon_lat_height(radius, theta, phi, & - longitude, latitude, height) - endif - - - end subroutine cartesian_2_lon_lat_height - - subroutine cartesian_2_lon_lat_height_c(x, y, z, longitude, latitude, height, & - referenceRadius) bind(c) - !C-inter-operable subroutine for conversion of Cartesian coordinates into - ! longitude-latitude-height. - implicit none - - real(kind=c_double) :: x,y,z !Cartesian coordinates - real(kind=c_double) :: longitude !in degrees - real(kind=c_double) :: latitude !in degrees - real(kind=c_double) :: height - real(kind=c_double) :: referenceRadius - - real :: x_f,y_f,z_f - real :: longitude_f - real :: latitude_f - real :: height_f - real :: referenceRadius_f - - !Cast input variables to Fortran intrinsic types. - x_f = real(x) - y_f = real(y) - z_f = real(z) - - referenceRadius_f = real(referenceRadius) - - !Convert coordinates - call cartesian_2_lon_lat_height(x_f, y_f, z_f, longitude_f, latitude_f, height_f, & - referenceRadius_f) - - !Cast output variables to C-inter-operable types. - longitude = real(longitude_f, kind=c_double) - latitude = real(latitude_f, kind=c_double) - height = real(height_f, kind=c_double) - - end subroutine cartesian_2_lon_lat_height_c - - subroutine transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) - !Subroutine calculating transformation matrix for spherical-polar to/from Cartesian - ! tensor transformations. The routine also returns the transposed transformation matrix - implicit none - - real, intent(in) :: xCoord !x-component of position vector - real, intent(in) :: yCoord !y-component of position vector - real, intent(in) :: zCoord !z-component of position vector - real, dimension(3,3), intent(out) :: R !Transformation matrix - real, dimension(3,3), intent(out) :: RT !Transposed transformation matrix - - real :: radius !Distance from centre of sphere - real :: theta !Polar angle, in radians - real :: phi !Azimuthal angle, in radians - - !Calculate position-vector components in spherical-polar basis - call cartesian_2_spherical_polar(xCoord, yCoord, zCoord, radius, theta, phi) - - R(1,1)=sin(theta)*cos(phi) - R(1,2)=sin(theta)*sin(phi) - R(1,3)=cos(theta) - R(2,1)=cos(theta)*cos(phi) - R(2,2)=cos(theta)*sin(phi) - R(2,3)=-sin(theta) - R(3,1)=-sin(phi) - R(3,2)=cos(phi) - R(3,3)=0.0 - - RT = TRANSPOSE(R) - - end subroutine transformation_matrix_cartesian_2_spherical_polar - - subroutine vector_spherical_polar_2_cartesian(radial, polar, azimuthal, & - radius, theta, phi, & - xComp, yComp, zComp, & - xCoord, yCoord, zCoord) - !Subroutine for vector change of basis: from spherical-polar to cartesian. The - ! coordinates of the position vector are also transformed - implicit none - - real, intent(in) :: radial !Radial component of vector - real, intent(in) :: polar !Polar component of vector - real, intent(in) :: azimuthal !Azimuthal component of vector - real, intent(in) :: radius !Distance from centre of sphere - real, intent(in) :: theta !Polar angle, in radians - real, intent(in) :: phi !Azimuthal angle, in radians - real, intent(out) :: xComp !1st vector component in cartesian basis - real, intent(out) :: yComp !2nd vector component in cartesian basis - real, intent(out) :: zComp !3rd vector component in cartesian basis - real, intent(out) :: xCoord !1st vector component of position vector in cartesian basis - real, intent(out) :: yCoord !2nd vector component of position vector in cartesian basis - real, intent(out) :: zCoord !3rd vector component of position vector in cartesian basis - - real, dimension(3) :: cartesianComponents - real, dimension(3,3) :: R !Transformation matrix - real, dimension(3,3) :: RT !Transposed transformation matrix - - !Calculate position-vector components in cartesian system - call spherical_polar_2_cartesian(radius, theta, phi, xCoord, yCoord, zCoord) - - !Calculate transformation matrix - call transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) - - !Evaluate vector components in Cartesian basis - cartesianComponents = matmul(RT,(/radial, polar, azimuthal/)) - xComp = cartesianComponents(1) - yComp = cartesianComponents(2) - zComp = cartesianComponents(3) - - end subroutine vector_spherical_polar_2_cartesian - - subroutine vector_cartesian_2_spherical_polar(xComp, yComp, zComp, & - xCoord, yCoord, zCoord, & - radial, polar, azimuthal, & - radius, theta, phi) - !Subroutine for vector change of basis: from Cartesian to spherical-polar. The - ! coordinates of the position vector are also transformed - implicit none - - real, intent(in) :: xComp !1st vector component in cartesian basis - real, intent(in) :: yComp !2nd vector component in cartesian basis - real, intent(in) :: zComp !3rd vector component in cartesian basis - real, intent(in) :: xCoord !1st vector component of position vector in cartesian basis - real, intent(in) :: yCoord !2nd vector component of position vector in cartesian basis - real, intent(in) :: zCoord !3rd vector component of position vector in cartesian basis - real, intent(out) :: radial !Radial component of vector - real, intent(out) :: polar !Polar component of vector - real, intent(out) :: azimuthal !Azimuthal component of vector - real, intent(out) :: radius !Distance from centre of sphere - real, intent(out) :: theta !Polar angle, in radians - real, intent(out) :: phi !Azimuthal angle, in radians - - real, dimension(3) :: sphericalPolarComponents - real, dimension(3,3) :: R !Transformation matrix - real, dimension(3,3) :: RT !Transposed transformation matrix - - !Calculate position-vector components in spherical-polar system - call cartesian_2_spherical_polar(xCoord, yCoord, zCoord, radius, theta, phi) - - !Calculate transformation matrix - call transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) - - !Evaluate vector components in spherical-polar basis - sphericalPolarComponents = matmul(R,(/xComp, yComp, zComp/)) - radial = sphericalPolarComponents(1) - polar = sphericalPolarComponents(2) - azimuthal = sphericalPolarComponents(3) - - end subroutine vector_cartesian_2_spherical_polar - - subroutine vector_lon_lat_height_2_cartesian(zonalComponent,& - meridionalComponent,& - verticalComponent, & - longitude, & - latitude, & - height, & - xComp, yComp, zComp, & - xCoord, yCoord, zCoord, & - referenceRadius) - !Subroutine for change of basis of a vector from meridional-zonal-vertical - ! components to cartesian components. - implicit none - - real, intent(in) :: zonalComponent !Vector component tangential to parallel - real, intent(in) :: meridionalComponent !Vector component tangential to meridian - real, intent(in) :: verticalComponent !Vecor component in the vertical (radial) - real, intent(in) :: longitude - real, intent(in) :: latitude - real, intent(in) :: height - real, intent(out) :: xComp !1st vector component in cartesian basis - real, intent(out) :: yComp !2nd vector component in cartesian basis - real, intent(out) :: zComp !3rd vector component in cartesian basis - real, intent(out) :: xCoord !1st vector component of position vector - ! in Cartesian basis - real, intent(out) :: yCoord !2nd vector component of position vector - ! in Cartesian basis - real, intent(out) :: zCoord !3rd vector component of position vector - ! in Cartesian basis - real, intent(in), optional :: referenceRadius - real :: radial !Radial component of vector - real :: polar !Polar component of vector - real :: azimuthal !Azimuthal component of vector - real :: radius !Distance from centre of sphere - real :: theta !Polar angle, in radians - real :: phi !Azimuthal angle, in radians - - !Convert zonal-meridional-vertical components to spherical-polar - azimuthal = zonalComponent - polar = -meridionalComponent - radial = verticalComponent - !Convert longitude-latitude-height to spherical-polar. - ! If referenceRadius is present then pass that to coordinate conversion routine, - ! height then is the radial distance of a point from the sphere with radius= - ! referenceRadius. Otherwise height is simply the distance from the Cartesian - ! coordinate origin. - if(present(referenceRadius)) then - call lon_lat_height_2_spherical_polar(longitude, latitude, height, & - radius, theta, phi, & - referenceRadius) - else - call lon_lat_height_2_spherical_polar(longitude, latitude, height, & - radius, theta, phi) - endif - !convert spherical-polar components to cartesian. - call vector_spherical_polar_2_cartesian(radial, polar, azimuthal, & - radius, theta, phi, & - xComp, yComp, zComp, & - xCoord, yCoord, zCoord) - - end subroutine vector_lon_lat_height_2_cartesian - - subroutine vector_cartesian_2_lon_lat_height(xComp, yComp, zComp, & - xCoord, yCoord, zCoord, & - zonalComponent,& - meridionalComponent,& - verticalComponent, & - longitude, & - latitude, & - height, & - referenceRadius) - !Subroutine for change of basis of a vector from cartesian to - ! meridional-zonal-vertical. - implicit none - - real, intent(in) :: xComp !1st vector component in cartesian basis - real, intent(in) :: yComp !2nd vector component in cartesian basis - real, intent(in) :: zComp !3rd vector component in cartesian basis - real, intent(in) :: xCoord !1st vector component of position vector - ! in Cartesian basis - real, intent(in) :: yCoord !2nd vector component of position vector - ! in Cartesian basis - real, intent(in) :: zCoord !3rd vector component of position vector - ! in Cartesian basis - real, intent(out) :: zonalComponent !Vector component tangential to parallel - real, intent(out) :: meridionalComponent !Vector component tangential to meridian - real, intent(out) :: verticalComponent !Vector component in the vertical (radial) - real, intent(out) :: longitude - real, intent(out) :: latitude - real, intent(out) :: height - real, intent(in), optional :: referenceRadius - real :: radial !Radial component of vector - real :: polar !Polar component of vector - real :: azimuthal !Azimuthal component of vector - real :: radius !Distance from centre of sphere - real :: theta !Polar angle, in radians - real :: phi !Azimuthal angle, in radians - - !Convert cartesian components to spherical-polar - call vector_cartesian_2_spherical_polar(xComp, yComp, zComp, & - xCoord, yCoord, zCoord, & - radial, polar, azimuthal, & - radius, theta, phi) - !Convert cartesian coordinates to longitude-latitude-radius - if(present(referenceRadius)) then - call cartesian_2_lon_lat_height(xCoord, yCoord, zCoord, & - longitude, latitude, height, & - referenceRadius) - else - call cartesian_2_lon_lat_height(xCoord, yCoord, zCoord, & - longitude, latitude, height) - endif - !Convert spherical-polar components to zonal-meridional-vertical - zonalComponent = azimuthal - meridionalComponent = -polar - verticalComponent = radial - - end subroutine vector_cartesian_2_lon_lat_height - - subroutine vector_lon_lat_height_2_cartesian_c(zonalComponent,& - meridionalComponent,& - verticalComponent, & - longitude, & - latitude, & - height, & - xComp, yComp, zComp, & - xCoord, yCoord, zCoord, & - referenceRadius) bind(c) - !C-interoperable subroutine for change of basis of a vector from - ! meridional-zonal-vertical components to cartesian components. Note that - ! unlike the Fortran version of the present routine, referenceRadius is - ! a mandatory argument. - implicit none - - real(kind=c_double), intent(in) :: zonalComponent !Vector component tangential - ! to parallel - real(kind=c_double), intent(in) :: meridionalComponent !Vector component tangential - ! to meridian - real(kind=c_double), intent(in) :: verticalComponent !Vecor component in the - ! vertical (radial) - real(kind=c_double), intent(in) :: longitude - real(kind=c_double), intent(in) :: latitude - real(kind=c_double), intent(in) :: height - real(kind=c_double), intent(out) :: xComp !1st vector component in - ! cartesian basis - real(kind=c_double), intent(out) :: yComp !2nd vector component in - ! cartesian basis - real(kind=c_double), intent(out) :: zComp !3rd vector component in - ! cartesian basis - real(kind=c_double), intent(out) :: xCoord !1st vector component of - ! position vector in cartesian basis - real(kind=c_double), intent(out) :: yCoord !2nd vector component of - ! position vector in cartesian basis - real(kind=c_double), intent(out) :: zCoord !3rd vector component of - ! position vector in cartesian basis - real(kind=c_double), intent(in) :: referenceRadius - - real :: zonalComponent_f !Vector component tangential to parallel - real :: meridionalComponent_f !Vector component tangential to meridian - real :: verticalComponent_f !Vecor component in the vertical (radial) - real :: longitude_f - real :: latitude_f - real :: height_f - real :: xComp_f !1st vector component in cartesian basis - real :: yComp_f !2nd vector component in cartesian basis - real :: zComp_f !3rd vector component in cartesian basis - real :: xCoord_f !1st vector component of position vector in cartesian basis - real :: yCoord_f !2nd vector component of position vector in cartesian basis - real :: zCoord_f !3rd vector component of position vector in cartesian basis - real :: referenceRadius_f - - !Convert C-types in to Fortran intrinsic types. - zonalComponent_f = real(zonalComponent) - meridionalComponent_f = real(meridionalComponent) - verticalComponent_f = real(verticalComponent) - longitude_f = real(longitude) - latitude_f = real(latitude) - height_f = real(height) - referenceRadius_f = real(referenceRadius) - - !Convert coordinates and components. - call vector_lon_lat_height_2_cartesian(zonalComponent_f,& - meridionalComponent_f,& - verticalComponent_f, & - longitude_f, & - latitude_f, & - height_f, & - xComp_f, yComp_f, zComp_f, & - xCoord_f, yCoord_f, zCoord_f, & - referenceRadius_f) - - !Convert Fortran intrinsic types to C-types. - xComp = real(xComp_f, kind=c_double) - yComp = real(yComp_f, kind=c_double) - zComp = real(zComp_f, kind=c_double) - xCoord = real(xCoord_f, kind=c_double) - yCoord = real(yCoord_f, kind=c_double) - zCoord = real(zCoord_f, kind=c_double) - - end subroutine vector_lon_lat_height_2_cartesian_c - - subroutine vector_cartesian_2_lon_lat_height_c(xComp, yComp, zComp, & - xCoord, yCoord, zCoord, & - zonalComponent,& - meridionalComponent,& - verticalComponent, & - longitude, & - latitude, & - height, & - referenceRadius) bind (c) - !C inter-operable subroutine for change of basis of a vector from Cartesian to - ! meridional-zonal-vertical. Note that - ! unlike the Fortran version of the present routine, referenceRadius is - ! a mandatory argument. - implicit none - - real(kind=c_double), intent(in) :: xComp !1st vector component in - ! cartesian basis - real(kind=c_double), intent(in) :: yComp !2nd vector component in - ! cartesian basis - real(kind=c_double), intent(in) :: zComp !3rd vector component in - ! cartesian basis - real(kind=c_double), intent(in) :: xCoord !1st vector component of position - ! vector in Cartesian basis - real(kind=c_double), intent(in) :: yCoord !2nd vector component of position - ! vector in Cartesian basis - real(kind=c_double), intent(in) :: zCoord !3rd vector component of position - ! vector in Cartesian basis - real(kind=c_double), intent(out) :: zonalComponent !Vector component tangential - ! to parallel - real(kind=c_double), intent(out) :: meridionalComponent !Vector component tangential - ! to meridian - real(kind=c_double), intent(out) :: verticalComponent !Vector component in the - ! vertical (radial) - real(kind=c_double), intent(out) :: longitude - real(kind=c_double), intent(out) :: latitude - real(kind=c_double), intent(out) :: height - real(kind=c_double), intent(in) :: referenceRadius - - real :: xComp_f !1st vector component in cartesian basis - real :: yComp_f !2nd vector component in cartesian basis - real :: zComp_f !3rd vector component in cartesian basis - real :: xCoord_f !1st vector component of position vector - ! in Cartesian basis - real :: yCoord_f !2nd vector component of position vector - ! in Cartesian basis - real :: zCoord_f !3rd vector component of position vector - ! in Cartesian basis - real :: zonalComponent_f !Vector component tangential to parallel - real :: meridionalComponent_f !Vector component tangential to meridian - real :: verticalComponent_f !Vector component in the vertical (radial) - real :: longitude_f - real :: latitude_f - real :: height_f - real :: referenceRadius_f - - !Convert C-types in to Fortran intrinsic types. - xComp_f = real(xComp) - yComp_f = real(yComp) - zComp_f = real(zComp) - xCoord_f = real(xCoord) - yCoord_f = real(yCoord) - zCoord_f = real(zCoord) - referenceRadius_f = real(referenceRadius) - - !Convert coordinates and components. - call vector_cartesian_2_lon_lat_height(xComp_f, yComp_f, zComp_f, & - xCoord_f, yCoord_f, zCoord_f, & - zonalComponent_f, & - meridionalComponent_f, & - verticalComponent_f, & - longitude_f, & - latitude_f, & - height_f, & - referenceRadius_f) - - !Convert Fortran intrinsic types to C-types. - zonalComponent = real(zonalComponent_f, kind=c_double) - meridionalComponent = real(meridionalComponent_f, kind=c_double) - verticalComponent = real(verticalComponent_f, kind=c_double) - longitude = real(longitude_f, kind=c_double) - latitude = real(latitude_f, kind=c_double) - height = real(height_f, kind=c_double) - - end subroutine vector_cartesian_2_lon_lat_height_c - - subroutine vector_spherical_polar_2_cartesian_field(spherical_polar_vector_field, & - spherical_polar_coordinate_field, & - cartesian_vector_field, & - cartesian_coordinate_field) - !Subroutine for change of basis of a cartesian vector field into a spherical-polar - ! vector field. This routine also converts and returns the position vector component - ! fields - implicit none - - type(vector_field) :: spherical_polar_vector_field - type(vector_field) :: spherical_polar_coordinate_field - type(vector_field) :: cartesian_vector_field - type(vector_field) :: cartesian_coordinate_field - integer :: node - real, dimension(3) :: XYZ, RTP !arrays containing a signel node's position vector - ! in cartesian & spherical-polar bases - real, dimension(3) :: cartesianComponents, sphericalPolarComponents - - assert(node_count(spherical_polar_coordinate_field) == node_count(cartesian_coordinate_field)) - - do node=1,node_count(spherical_polar_coordinate_field) - RTP = node_val(spherical_polar_coordinate_field, node) - sphericalPolarComponents = node_val(spherical_polar_vector_field, node) - call vector_spherical_polar_2_cartesian(sphericalPolarComponents(1), & - sphericalPolarComponents(2), & - sphericalPolarComponents(3), & - RTP(1), RTP(2), RTP(3), & - cartesianComponents(1), & - cartesianComponents(2), & - cartesianComponents(3), & - XYZ(1), XYZ(2), XYZ(3)) - call set(cartesian_coordinate_field, node, XYZ) - call set(cartesian_vector_field, node, cartesianComponents) - enddo - end subroutine vector_spherical_polar_2_cartesian_field - - subroutine vector_cartesian_2_spherical_polar_field(cartesian_vector_field, & - cartesian_coordinate_field, & - spherical_polar_vector_field, & - spherical_polar_coordinate_field) - !Subroutine for change of basis of a cartesian vector field into a spherical-polar - ! vector field. This routine also converts and returns the position vector component - ! fields - implicit none - - type(vector_field) :: cartesian_vector_field - type(vector_field) :: cartesian_coordinate_field - type(vector_field) :: spherical_polar_vector_field - type(vector_field) :: spherical_polar_coordinate_field - integer :: node - real, dimension(3) :: XYZ, RTP !arrays containing a signel node's position vector - ! in cartesian & spherical-polar bases - real, dimension(3) :: cartesianComponents, sphericalPolarComponents - - assert(node_count(spherical_polar_coordinate_field) == node_count(cartesian_coordinate_field) ) - - do node=1,node_count(spherical_polar_coordinate_field) - XYZ = node_val(cartesian_coordinate_field, node) - cartesianComponents = node_val(cartesian_vector_field, node) - call vector_cartesian_2_spherical_polar(cartesianComponents(1), & - cartesianComponents(2), & - cartesianComponents(3), & - XYZ(1), XYZ(2), XYZ(3), & - sphericalPolarComponents(1), & - sphericalPolarComponents(2), & - sphericalPolarComponents(3), & - RTP(1), RTP(2), RTP(3)) - call set(spherical_polar_coordinate_field, node, RTP) - call set(spherical_polar_vector_field, node, sphericalPolarComponents) - enddo - end subroutine vector_cartesian_2_spherical_polar_field - - subroutine tensor_spherical_polar_2_cartesian(sphericalPolarComponents, & - radius, theta, phi, & - cartesianComponents, & - xCoord, yCoord, zCoord) - !Subroutine for tensor change of basis: From spherical-polar to cartesian. The - ! coordinates of the position vector are also transformed. The tensor must - ! be a 3x3 tensor. - implicit none - - real, intent(in), dimension(3,3) :: sphericalPolarComponents !Tensor - ! components in spherical-polar basis - real, intent(in) :: radius !Distance from centre of sphere - real, intent(in) :: theta !Polar angle, in radians - real, intent(in) :: phi !Azimuthal angle, in radians - real, intent(out), dimension(3,3) :: cartesianComponents !Tensor - ! components in Cartesian bisis - real, intent(out) :: xCoord !1st vector component of position vector - ! in cartesian basis - real, intent(out) :: yCoord !2nd vector component of position vector - ! in cartesian basis - real, intent(out) :: zCoord !3rd vector component of position vector - ! in cartesian basis - - real, dimension(3,3) :: R !Transformation matrix - real, dimension(3,3) :: RT !Transposed transformation matrix - - !Calculate position-vector components in cartesian system - call spherical_polar_2_cartesian(radius, theta, phi, xCoord, yCoord, zCoord) - - !Calculate transformation matrix - call transformation_matrix_cartesian_2_spherical_polar(xCoord, yCoord, zCoord, R, RT) - - !Evaluate vector components in Cartesian basis - cartesianComponents = matmul(matmul(RT, sphericalPolarComponents), R) - - end subroutine tensor_spherical_polar_2_cartesian - - subroutine higher_order_sphere_projection(positions, s_positions) - !!< Given a P1 'positions' field and a Pn 's_positions' field, bends the - !!< elements of the 's_positions' field onto the sphere - type(vector_field), intent(inout):: positions - type(vector_field), intent(inout):: s_positions - - real rold, rnew - integer i - - type(scalar_field):: radius, s_radius - real, dimension(positions%dim):: xyz - - ewrite(1,*) 'In higher_order_sphere_projection' - - call allocate(s_radius, s_positions%mesh, "HigherOrderRadius") - radius=magnitude(positions) - call remap_field(radius, s_radius) - - ! then bend by adjusting to the linearly interpolated radius - do i=1, node_count(s_positions) - xyz=node_val(s_positions, i) - rold=sqrt(sum(xyz**2)) - rnew=node_val(s_radius, i) - call set(s_positions, i, xyz*rnew/rold) - end do - - call deallocate(s_radius) - call deallocate(radius) - - end subroutine higher_order_sphere_projection - - function radial_inward_normal_at_quad_ele(positions, ele_number) result(quad_val) - ! Return the direction of gravity at the quadrature points of and element. - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele_number - real, dimension(positions%dim,ele_ngi(positions,ele_number)) :: X_quad, quad_val - integer :: i,j - - X_quad=ele_val_at_quad(positions, ele_number) - - do j=1,ele_ngi(positions,ele_number) + diagonal_T=0.0 do i=1,positions%dim - quad_val(i,j)=-X_quad(i,j)/sqrt(sum(X_quad(:,j)**2)) + diagonal_T(i,i,:)=diagonal(i,:) end do - end do - end function radial_inward_normal_at_quad_ele + do i=1,ele_ngi(positions,ele_number) + ! Calculate the spherical-polar coordinates of the point + call cartesian_2_spherical_polar(X_quad(1,i), X_quad(2,i), X_quad(3,i), radius, theta, phi) - function radial_inward_normal_at_quad_face(positions, face_number) result(quad_val) - ! Return the direction of gravity at the quadrature points of and element. - type(vector_field), intent(in) :: positions - integer, intent(in) :: face_number - real, dimension(positions%dim,face_ngi(positions,face_number)) :: X_quad, quad_val - integer :: i,j + R(1,1)=-sin(phi) + R(1,2)=cos(theta)*cos(phi) + R(1,3)=sin(theta)*cos(phi) + R(2,1)=cos(phi) + R(2,2)=cos(theta)*sin(phi) + R(2,3)=sin(theta)*sin(phi) + R(3,1)=0 + R(3,2)=-sin(theta) + R(3,3)=cos(theta) - X_quad=face_val_at_quad(positions, face_number) + RT=R + call invert(RT) + quad_val(:,:,i)=matmul((matmul(R,diagonal_T(:,:,i))),RT) - do j=1,face_ngi(positions,face_number) + end do + + end function rotate_diagonal_to_sphere_gi + + function rotate_diagonal_to_sphere_face(positions, face_number, diagonal) result(quad_val) + ! Given the diagonal of a tensor in cartesian coordinates, this function + ! transforms the tensor components to a spherical-polar basis. This result + ! is given by R(diagonal)R^T ! where R is the matrix of Eigen vectors of the + ! spherical-polar basis, expressed in the cartesian basis. + type(vector_field), intent(in) :: positions + integer, intent(in) :: face_number + real, dimension(positions%dim,face_ngi(positions,face_number)), intent(in) :: diagonal + real, dimension(positions%dim,face_ngi(positions,face_number)) :: X_quad + real, dimension(positions%dim,positions%dim) :: R, RT + real, dimension(positions%dim,positions%dim,face_ngi(positions,face_number)) :: diagonal_T, quad_val + real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle + integer :: i + + assert(positions%dim==3) + + X_quad=face_val_at_quad(positions, face_number) + + diagonal_T=0.0 do i=1,positions%dim - quad_val(i,j)=-X_quad(i,j)/sqrt(sum(X_quad(:,j)**2)) + diagonal_T(i,i,:)=diagonal(i,:) end do - end do - - end function radial_inward_normal_at_quad_face - - function rotate_diagonal_to_sphere_gi(positions, ele_number, diagonal) result(quad_val) - ! Given the diagonal of a tensor in cartesian coordinates, this function - ! transforms the tensor components to a spherical-polar basis. This result - ! is given by R(diagonal)R^T where R is the matrix of Eigen vectors of the - ! spherical-polar basis, expressed in the cartesian basis. - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele_number - real, dimension(positions%dim,ele_ngi(positions,ele_number)), intent(in) :: diagonal - real, dimension(positions%dim,ele_ngi(positions,ele_number)) :: X_quad - real, dimension(positions%dim,positions%dim) :: R, RT - real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele_number)) :: diagonal_T, quad_val - real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle - integer :: i - - assert(positions%dim==3) - - X_quad=ele_val_at_quad(positions, ele_number) - - diagonal_T=0.0 - do i=1,positions%dim - diagonal_T(i,i,:)=diagonal(i,:) - end do - - do i=1,ele_ngi(positions,ele_number) - ! Calculate the spherical-polar coordinates of the point - call cartesian_2_spherical_polar(X_quad(1,i), X_quad(2,i), X_quad(3,i), radius, theta, phi) - - R(1,1)=-sin(phi) - R(1,2)=cos(theta)*cos(phi) - R(1,3)=sin(theta)*cos(phi) - R(2,1)=cos(phi) - R(2,2)=cos(theta)*sin(phi) - R(2,3)=sin(theta)*sin(phi) - R(3,1)=0 - R(3,2)=-sin(theta) - R(3,3)=cos(theta) - - RT=R - call invert(RT) - quad_val(:,:,i)=matmul((matmul(R,diagonal_T(:,:,i))),RT) - - end do - - end function rotate_diagonal_to_sphere_gi - - function rotate_diagonal_to_sphere_face(positions, face_number, diagonal) result(quad_val) - ! Given the diagonal of a tensor in cartesian coordinates, this function - ! transforms the tensor components to a spherical-polar basis. This result - ! is given by R(diagonal)R^T ! where R is the matrix of Eigen vectors of the - ! spherical-polar basis, expressed in the cartesian basis. - type(vector_field), intent(in) :: positions - integer, intent(in) :: face_number - real, dimension(positions%dim,face_ngi(positions,face_number)), intent(in) :: diagonal - real, dimension(positions%dim,face_ngi(positions,face_number)) :: X_quad - real, dimension(positions%dim,positions%dim) :: R, RT - real, dimension(positions%dim,positions%dim,face_ngi(positions,face_number)) :: diagonal_T, quad_val - real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle - integer :: i - - assert(positions%dim==3) - - X_quad=face_val_at_quad(positions, face_number) - - diagonal_T=0.0 - do i=1,positions%dim - diagonal_T(i,i,:)=diagonal(i,:) - end do - - do i=1,face_ngi(positions,face_number) - ! Calculate the spherical-polar coordinates of the point - call cartesian_2_spherical_polar(X_quad(1,i), X_quad(2,i), X_quad(3,i), radius, theta, phi) - - R(1,1)=-sin(phi) - R(1,2)=cos(theta)*cos(phi) - R(1,3)=sin(theta)*cos(phi) - R(2,1)=cos(phi) - R(2,2)=cos(theta)*sin(phi) - R(2,3)=sin(theta)*sin(phi) - R(3,1)=0 - R(3,2)=-sin(theta) - R(3,3)=cos(theta) - - RT=R - call invert(RT) - quad_val(:,:,i)=matmul((matmul(R,diagonal_T(:,:,i))),RT) - - end do - - end function rotate_diagonal_to_sphere_face - - subroutine rotate_ct_m_sphere(state, ct_m, u) - - type(block_csr_matrix), intent(inout):: ct_m - type(vector_field), intent(in) :: u - - type(vector_field) :: sphere_normal, sphere_tangent1, sphere_tangent2 - integer, dimension(:), pointer:: rowcol - real, dimension(u%dim, u%dim):: local_rotation - real, dimension(u%dim):: ct_xyz, ct_rot - real, dimension(:), pointer:: rowval - integer:: node, i, j, k, rotated_node - - type(state_type), intent(in) :: state - type(vector_field), pointer :: position - type(vector_field) :: u_position - real, dimension(u%dim) :: x, node_normal, node_tangent1, node_tangent2 - real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle - - ewrite(1,*) "Inside rotate_ct_m_sphere" - - assert( all(blocks(ct_m) == (/ 1, u%dim /)) ) - - position => extract_vector_field(state, "Coordinate") - call allocate(u_position, u%dim, u%mesh, name="VelocityCoordinate") - call remap_field(position, u_position) - - if (associated(u%mesh%halos)) then - call halo_update(u_position) - end if - - assert(u%dim==3) - - call allocate(sphere_normal, u%dim, u%mesh, name="sphere_normal") - call allocate(sphere_tangent1, u%dim, u%mesh, name="sphere_tangent1") - call allocate(sphere_tangent2, u%dim, u%mesh, name="sphere_tangent2") - - do node=1, node_count(u) - - !Extract the cartesian coordinates of the node. - x=node_val(u_position, node) - - !Calculate spherical-polar coordinates. - call cartesian_2_spherical_polar(x(1),x(2),x(3),radius,theta,phi) - - node_normal=(/sin(theta)*cos(phi),sin(theta)*sin(phi),cos(theta)/) - node_tangent1=(/-sin(phi),cos(phi),0.0/) - node_tangent2=(/cos(theta)*cos(phi),cos(theta)*sin(phi),-sin(theta)/) - - call set(sphere_normal, node, node_normal) - call set(sphere_tangent1, node, node_tangent1) - call set(sphere_tangent2, node, node_tangent2) - - end do - - if (associated(u%mesh%halos)) then - call halo_update(sphere_normal) - call halo_update(sphere_tangent1) - call halo_update(sphere_tangent2) - end if - - do i=1, size(ct_m, 1) - rowcol => row_m_ptr(ct_m, i) - do j=1, size(rowcol) - rotated_node=rowcol(j) - ! construct local rotation matrix - local_rotation(1,:)=node_val(sphere_tangent1, rotated_node) - local_rotation(2,:)=node_val(sphere_tangent2, rotated_node) - local_rotation(3,:)=node_val(sphere_normal, rotated_node) - - ! look up ct_m values of row i, column rowcol(j) in xyz orientation - do k=1, blocks(ct_m,2) - rowval => row_val_ptr(ct_m, 1, k, i) - ct_xyz(k)=rowval(j) - end do - ! rotate to tangent1, tangent2, normal orientation - ct_rot=matmul( local_rotation, ct_xyz) - ! put back in the matrix - do k=1, blocks(ct_m,2) - rowval => row_val_ptr(ct_m, 1, k, i) - rowval(j)=ct_rot(k) - end do + + do i=1,face_ngi(positions,face_number) + ! Calculate the spherical-polar coordinates of the point + call cartesian_2_spherical_polar(X_quad(1,i), X_quad(2,i), X_quad(3,i), radius, theta, phi) + + R(1,1)=-sin(phi) + R(1,2)=cos(theta)*cos(phi) + R(1,3)=sin(theta)*cos(phi) + R(2,1)=cos(phi) + R(2,2)=cos(theta)*sin(phi) + R(2,3)=sin(theta)*sin(phi) + R(3,1)=0 + R(3,2)=-sin(theta) + R(3,3)=cos(theta) + + RT=R + call invert(RT) + quad_val(:,:,i)=matmul((matmul(R,diagonal_T(:,:,i))),RT) + end do - end do - - call deallocate(u_position) - call deallocate(sphere_normal) - call deallocate(sphere_tangent1) - call deallocate(sphere_tangent2) - - end subroutine rotate_ct_m_sphere - - subroutine rotate_momentum_to_sphere(big_m, rhs, u, state, dg) - - type(petsc_csr_matrix), intent(inout):: big_m - type(vector_field), intent(inout):: rhs - type(vector_field), intent(inout):: u - type(state_type), intent(inout):: state - logical, intent(in) :: dg - - type(petsc_csr_matrix), pointer:: rotation_sphere - type(petsc_csr_matrix):: rotated_big_m - type(vector_field):: result - integer :: stat - - ewrite(1,*) "Inside rotate_momentum_to_sphere" - - rotation_sphere => extract_petsc_csr_matrix(state, "RotationMatrixSphere", stat=stat) - - if (stat/=0) then - allocate(rotation_sphere) - call create_rotation_matrix_sphere(rotation_sphere, u, state) - call insert(state, rotation_sphere, "RotationMatrixSphere") - end if - - ! rotate big_m: - call ptap(rotated_big_m, big_m, rotation_sphere) - - ! rotate rhs: - ! need to have separate copy of the field, because of intent(out) and intent(in) - ! of mult_T call, as result%val points at the same space as rhs%val, this directly - ! puts the result in rhs as well - result=rhs - call mult_T(result, rotation_sphere, rhs) - if (dg) then - ! We have just poluted the halo rows of the rhs. This is incorrect - ! in the dg case due to the non-local assembly system employed. - call zero_non_owned(rhs) - end if - ! rotate u: - if (dg) then - call zero_non_owned(u) - end if - result=u ! same story - call mult_T(result, rotation_sphere, u) - - ! throw out unrotated big_m and replace with rotated: - call deallocate(big_m) - big_m=rotated_big_m - - if (stat/=0) then - call deallocate(rotation_sphere) - deallocate(rotation_sphere) - end if - - end subroutine rotate_momentum_to_sphere - - subroutine create_rotation_matrix_sphere(rotation_sphere, u, state) - - type(petsc_csr_matrix), intent(out):: rotation_sphere - type(vector_field), intent(in):: u - type(state_type), intent(in) :: state - - type(halo_type), pointer:: halo - type(vector_field) :: sphere_normal, sphere_tangent1, sphere_tangent2 - real, dimension(u%dim) :: x, node_normal, node_tangent1, node_tangent2 - real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle - real, dimension(u%dim, u%dim):: local_rotation - integer, dimension(:), allocatable:: dnnz, onnz - integer:: node, nodes, mynodes - logical:: parallel - - type(vector_field), pointer :: position - type(vector_field) :: u_position - - ewrite(1,*) "Inside create_rotation_matrix_sphere" - - nodes=node_count(u) - if (associated(u%mesh%halos)) then - halo => u%mesh%halos(1) - mynodes=halo_nowned_nodes(halo) - else - nullify(halo) - mynodes=nodes - end if - parallel=IsParallel() - - allocate(dnnz(1:mynodes*u%dim), onnz(1:mynodes*u%dim)) - onnz=0 - ! default is just a 1.0 on the diagonal (no rotation) - dnnz=1 - - do node=1, mynodes - if (any(dnnz(node:node+(u%dim-1)*mynodes:mynodes)>1)) then - FLExit("Two rotated specifications for the same node.") + + end function rotate_diagonal_to_sphere_face + + subroutine rotate_ct_m_sphere(state, ct_m, u) + + type(block_csr_matrix), intent(inout):: ct_m + type(vector_field), intent(in) :: u + + type(vector_field) :: sphere_normal, sphere_tangent1, sphere_tangent2 + integer, dimension(:), pointer:: rowcol + real, dimension(u%dim, u%dim):: local_rotation + real, dimension(u%dim):: ct_xyz, ct_rot + real, dimension(:), pointer:: rowval + integer:: node, i, j, k, rotated_node + + type(state_type), intent(in) :: state + type(vector_field), pointer :: position + type(vector_field) :: u_position + real, dimension(u%dim) :: x, node_normal, node_tangent1, node_tangent2 + real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle + + ewrite(1,*) "Inside rotate_ct_m_sphere" + + assert( all(blocks(ct_m) == (/ 1, u%dim /)) ) + + position => extract_vector_field(state, "Coordinate") + call allocate(u_position, u%dim, u%mesh, name="VelocityCoordinate") + call remap_field(position, u_position) + + if (associated(u%mesh%halos)) then + call halo_update(u_position) end if - dnnz( node:node+(u%dim-1)*mynodes:mynodes)=u%dim - end do - call allocate(rotation_sphere, nodes, nodes, & - dnnz, onnz, (/ u%dim, u%dim /), "RotationMatrixSphere", halo=halo) + assert(u%dim==3) + + call allocate(sphere_normal, u%dim, u%mesh, name="sphere_normal") + call allocate(sphere_tangent1, u%dim, u%mesh, name="sphere_tangent1") + call allocate(sphere_tangent2, u%dim, u%mesh, name="sphere_tangent2") + + do node=1, node_count(u) + + !Extract the cartesian coordinates of the node. + x=node_val(u_position, node) + + !Calculate spherical-polar coordinates. + call cartesian_2_spherical_polar(x(1),x(2),x(3),radius,theta,phi) + + node_normal=(/sin(theta)*cos(phi),sin(theta)*sin(phi),cos(theta)/) + node_tangent1=(/-sin(phi),cos(phi),0.0/) + node_tangent2=(/cos(theta)*cos(phi),cos(theta)*sin(phi),-sin(theta)/) + + call set(sphere_normal, node, node_normal) + call set(sphere_tangent1, node, node_tangent1) + call set(sphere_tangent2, node, node_tangent2) + + end do + + if (associated(u%mesh%halos)) then + call halo_update(sphere_normal) + call halo_update(sphere_tangent1) + call halo_update(sphere_tangent2) + end if + + do i=1, size(ct_m, 1) + rowcol => row_m_ptr(ct_m, i) + do j=1, size(rowcol) + rotated_node=rowcol(j) + ! construct local rotation matrix + local_rotation(1,:)=node_val(sphere_tangent1, rotated_node) + local_rotation(2,:)=node_val(sphere_tangent2, rotated_node) + local_rotation(3,:)=node_val(sphere_normal, rotated_node) + + ! look up ct_m values of row i, column rowcol(j) in xyz orientation + do k=1, blocks(ct_m,2) + rowval => row_val_ptr(ct_m, 1, k, i) + ct_xyz(k)=rowval(j) + end do + ! rotate to tangent1, tangent2, normal orientation + ct_rot=matmul( local_rotation, ct_xyz) + ! put back in the matrix + do k=1, blocks(ct_m,2) + rowval => row_val_ptr(ct_m, 1, k, i) + rowval(j)=ct_rot(k) + end do + end do + end do + + call deallocate(u_position) + call deallocate(sphere_normal) + call deallocate(sphere_tangent1) + call deallocate(sphere_tangent2) + + end subroutine rotate_ct_m_sphere + + subroutine rotate_momentum_to_sphere(big_m, rhs, u, state, dg) + + type(petsc_csr_matrix), intent(inout):: big_m + type(vector_field), intent(inout):: rhs + type(vector_field), intent(inout):: u + type(state_type), intent(inout):: state + logical, intent(in) :: dg + + type(petsc_csr_matrix), pointer:: rotation_sphere + type(petsc_csr_matrix):: rotated_big_m + type(vector_field):: result + integer :: stat + + ewrite(1,*) "Inside rotate_momentum_to_sphere" + + rotation_sphere => extract_petsc_csr_matrix(state, "RotationMatrixSphere", stat=stat) + + if (stat/=0) then + allocate(rotation_sphere) + call create_rotation_matrix_sphere(rotation_sphere, u, state) + call insert(state, rotation_sphere, "RotationMatrixSphere") + end if - position => extract_vector_field(state, "Coordinate") - call allocate(u_position, u%dim, u%mesh, name="VelocityCoordinate") - call remap_field(position, u_position) + ! rotate big_m: + call ptap(rotated_big_m, big_m, rotation_sphere) + + ! rotate rhs: + ! need to have separate copy of the field, because of intent(out) and intent(in) + ! of mult_T call, as result%val points at the same space as rhs%val, this directly + ! puts the result in rhs as well + result=rhs + call mult_T(result, rotation_sphere, rhs) + if (dg) then + ! We have just poluted the halo rows of the rhs. This is incorrect + ! in the dg case due to the non-local assembly system employed. + call zero_non_owned(rhs) + end if + ! rotate u: + if (dg) then + call zero_non_owned(u) + end if + result=u ! same story + call mult_T(result, rotation_sphere, u) - call allocate(sphere_normal, u%dim, u%mesh, name="sphere_normal") - call allocate(sphere_tangent1, u%dim, u%mesh, name="sphere_tangent1") - call allocate(sphere_tangent2, u%dim, u%mesh, name="sphere_tangent2") + ! throw out unrotated big_m and replace with rotated: + call deallocate(big_m) + big_m=rotated_big_m - do node=1, mynodes + if (stat/=0) then + call deallocate(rotation_sphere) + deallocate(rotation_sphere) + end if - !Extract the cartesian coordinates of the node. - x=node_val(u_position, node) + end subroutine rotate_momentum_to_sphere - !Calculate spherical-polar coordinates. - call cartesian_2_spherical_polar(x(1),x(2),x(3),radius,theta,phi) + subroutine create_rotation_matrix_sphere(rotation_sphere, u, state) - node_normal=(/sin(theta)*cos(phi),sin(theta)*sin(phi),cos(theta)/) - node_tangent1=(/-sin(phi),cos(phi),0.0/) - node_tangent2=(/cos(theta)*cos(phi),cos(theta)*sin(phi),-sin(theta)/) + type(petsc_csr_matrix), intent(out):: rotation_sphere + type(vector_field), intent(in):: u + type(state_type), intent(in) :: state - call set(sphere_normal, node, node_normal) - call set(sphere_tangent1, node, node_tangent1) - call set(sphere_tangent2, node, node_tangent2) + type(halo_type), pointer:: halo + type(vector_field) :: sphere_normal, sphere_tangent1, sphere_tangent2 + real, dimension(u%dim) :: x, node_normal, node_tangent1, node_tangent2 + real :: radius, theta, phi !distance form origin, polar angle, azimuthal angle + real, dimension(u%dim, u%dim):: local_rotation + integer, dimension(:), allocatable:: dnnz, onnz + integer:: node, nodes, mynodes + logical:: parallel - end do + type(vector_field), pointer :: position + type(vector_field) :: u_position - do node=1, mynodes - local_rotation(:,1)=node_val(sphere_tangent1, node) - local_rotation(:,2)=node_val(sphere_tangent2, node) - local_rotation(:,3)=node_val(sphere_normal, node) + ewrite(1,*) "Inside create_rotation_matrix_sphere" - call addto(rotation_sphere, node, node, local_rotation) - end do + nodes=node_count(u) + if (associated(u%mesh%halos)) then + halo => u%mesh%halos(1) + mynodes=halo_nowned_nodes(halo) + else + nullify(halo) + mynodes=nodes + end if + parallel=IsParallel() + + allocate(dnnz(1:mynodes*u%dim), onnz(1:mynodes*u%dim)) + onnz=0 + ! default is just a 1.0 on the diagonal (no rotation) + dnnz=1 + + do node=1, mynodes + if (any(dnnz(node:node+(u%dim-1)*mynodes:mynodes)>1)) then + FLExit("Two rotated specifications for the same node.") + end if + dnnz( node:node+(u%dim-1)*mynodes:mynodes)=u%dim + end do - call assemble(rotation_sphere) + call allocate(rotation_sphere, nodes, nodes, & + dnnz, onnz, (/ u%dim, u%dim /), "RotationMatrixSphere", halo=halo) - call deallocate(u_position) - call deallocate(sphere_normal) - call deallocate(sphere_tangent1) - call deallocate(sphere_tangent2) + position => extract_vector_field(state, "Coordinate") + call allocate(u_position, u%dim, u%mesh, name="VelocityCoordinate") + call remap_field(position, u_position) - end subroutine create_rotation_matrix_sphere + call allocate(sphere_normal, u%dim, u%mesh, name="sphere_normal") + call allocate(sphere_tangent1, u%dim, u%mesh, name="sphere_tangent1") + call allocate(sphere_tangent2, u%dim, u%mesh, name="sphere_tangent2") - subroutine rotate_velocity_sphere(vfield, state) + do node=1, mynodes - type(vector_field), intent(inout):: vfield - type(state_type), intent(inout):: state + !Extract the cartesian coordinates of the node. + x=node_val(u_position, node) - type(vector_field), pointer:: u - type(vector_field):: result - type(petsc_csr_matrix), pointer:: rotation_sphere - integer :: stat + !Calculate spherical-polar coordinates. + call cartesian_2_spherical_polar(x(1),x(2),x(3),radius,theta,phi) - rotation_sphere => extract_petsc_csr_matrix(state, "RotationMatrixSphere", stat=stat) - if (stat/=0) then - allocate(rotation_sphere) - u => extract_vector_field(state, "Velocity") - call create_rotation_matrix_sphere(rotation_sphere, u, state) - call insert(state, rotation_sphere, "RotationMatrixSphere") - end if + node_normal=(/sin(theta)*cos(phi),sin(theta)*sin(phi),cos(theta)/) + node_tangent1=(/-sin(phi),cos(phi),0.0/) + node_tangent2=(/cos(theta)*cos(phi),cos(theta)*sin(phi),-sin(theta)/) - result=vfield ! see note in rotate_momentum_equation - call mult_T(result, rotation_sphere, vfield) + call set(sphere_normal, node, node_normal) + call set(sphere_tangent1, node, node_tangent1) + call set(sphere_tangent2, node, node_tangent2) - if (stat/=0) then - call deallocate(rotation_sphere) - deallocate(rotation_sphere) - end if + end do - end subroutine rotate_velocity_sphere + do node=1, mynodes + local_rotation(:,1)=node_val(sphere_tangent1, node) + local_rotation(:,2)=node_val(sphere_tangent2, node) + local_rotation(:,3)=node_val(sphere_normal, node) - subroutine rotate_velocity_back_sphere(vfield, state) + call addto(rotation_sphere, node, node, local_rotation) + end do - type(vector_field), intent(inout):: vfield - type(state_type), intent(inout):: state + call assemble(rotation_sphere) - type(vector_field), pointer:: u - type(vector_field):: result - type(petsc_csr_matrix), pointer:: rotation_sphere - integer :: stat + call deallocate(u_position) + call deallocate(sphere_normal) + call deallocate(sphere_tangent1) + call deallocate(sphere_tangent2) - rotation_sphere => extract_petsc_csr_matrix(state, "RotationMatrixSphere", stat=stat) - if (stat/=0) then - allocate(rotation_sphere) - u => extract_vector_field(state, "Velocity") - call create_rotation_matrix_sphere(rotation_sphere, u, state) - call insert(state, rotation_sphere, "RotationMatrixSphere") - end if + end subroutine create_rotation_matrix_sphere - result=vfield ! see note in rotate_momentum_equation - call mult(result, rotation_sphere, vfield) + subroutine rotate_velocity_sphere(vfield, state) - if (stat/=0) then - call deallocate(rotation_sphere) - deallocate(rotation_sphere) - end if + type(vector_field), intent(inout):: vfield + type(state_type), intent(inout):: state - end subroutine rotate_velocity_back_sphere + type(vector_field), pointer:: u + type(vector_field):: result + type(petsc_csr_matrix), pointer:: rotation_sphere + integer :: stat - ! Coordinates options checking - subroutine Coordinates_check_options + rotation_sphere => extract_petsc_csr_matrix(state, "RotationMatrixSphere", stat=stat) + if (stat/=0) then + allocate(rotation_sphere) + u => extract_vector_field(state, "Velocity") + call create_rotation_matrix_sphere(rotation_sphere, u, state) + call insert(state, rotation_sphere, "RotationMatrixSphere") + end if - integer :: nmat, m + result=vfield ! see note in rotate_momentum_equation + call mult_T(result, rotation_sphere, vfield) - ! Pressure stabilisation does not currently work with a p2 or higher - ! coordinate fields. Check that this term is not enabled and, if it is, - ! exit. - nmat = option_count("/material_phase") - do m = 0, nmat-1 - if (have_option('/geometry/spherical_earth/superparametric_mapping/') & - .and. have_option("/material_phase["//int2str(m)//"]/scalar_field::Pressure/"// & - "prognostic/spatial_discretisation/continuous_galerkin") & - .and. .not.have_option("/material_phase["//int2str(m)// & - "]/scalar_field::Pressure/prognostic/spatial_discretisation/"// & - "continuous_galerkin/remove_stabilisation_term")) then - ewrite(-1,*) "Pressure stabilisation does not currently work with 2nd order or higher coordinate meshes. Please enable" - ewrite(-1,*) "remove_stabilisation_term under the spatial discretisation tab of your pressure field. Things should work" - ewrite(-1,*) "nicely then. Thanks!" - FLExit("Pressure stabilisation is not currently compatible with coordinate fields of order >1.") + if (stat/=0) then + call deallocate(rotation_sphere) + deallocate(rotation_sphere) end if - end do - end subroutine Coordinates_check_options + end subroutine rotate_velocity_sphere + + subroutine rotate_velocity_back_sphere(vfield, state) + + type(vector_field), intent(inout):: vfield + type(state_type), intent(inout):: state + + type(vector_field), pointer:: u + type(vector_field):: result + type(petsc_csr_matrix), pointer:: rotation_sphere + integer :: stat + + rotation_sphere => extract_petsc_csr_matrix(state, "RotationMatrixSphere", stat=stat) + if (stat/=0) then + allocate(rotation_sphere) + u => extract_vector_field(state, "Velocity") + call create_rotation_matrix_sphere(rotation_sphere, u, state) + call insert(state, rotation_sphere, "RotationMatrixSphere") + end if + + result=vfield ! see note in rotate_momentum_equation + call mult(result, rotation_sphere, vfield) + + if (stat/=0) then + call deallocate(rotation_sphere) + deallocate(rotation_sphere) + end if + + end subroutine rotate_velocity_back_sphere + + ! Coordinates options checking + subroutine Coordinates_check_options + + integer :: nmat, m + + ! Pressure stabilisation does not currently work with a p2 or higher + ! coordinate fields. Check that this term is not enabled and, if it is, + ! exit. + nmat = option_count("/material_phase") + do m = 0, nmat-1 + if (have_option('/geometry/spherical_earth/superparametric_mapping/') & + .and. have_option("/material_phase["//int2str(m)//"]/scalar_field::Pressure/"// & + "prognostic/spatial_discretisation/continuous_galerkin") & + .and. .not.have_option("/material_phase["//int2str(m)// & + "]/scalar_field::Pressure/prognostic/spatial_discretisation/"// & + "continuous_galerkin/remove_stabilisation_term")) then + ewrite(-1,*) "Pressure stabilisation does not currently work with 2nd order or higher coordinate meshes. Please enable" + ewrite(-1,*) "remove_stabilisation_term under the spatial discretisation tab of your pressure field. Things should work" + ewrite(-1,*) "nicely then. Thanks!" + FLExit("Pressure stabilisation is not currently compatible with coordinate fields of order >1.") + end if + end do + + end subroutine Coordinates_check_options end module Coordinates diff --git a/femtools/DG_interpolation.F90 b/femtools/DG_interpolation.F90 index 10af64bf1b..f4cef61df1 100644 --- a/femtools/DG_interpolation.F90 +++ b/femtools/DG_interpolation.F90 @@ -2,228 +2,228 @@ module dg_interpolation_module - use vector_tools - use quadrature - use futils - use spud - use sparse_tools - use tensors - use transform_elements - use adjacency_lists - use unittest_tools - use linked_lists - use supermesh_construction - use fetools - use intersection_finder_module - use fields - use meshdiagnostics - use sparsity_patterns - use state_module - use vtk_interfaces - use interpolation_module - use sparse_matrices_fields - use solvers - implicit none - - private - public :: dg_interpolation_galerkin_supermesh_free - - interface dg_interpolation_galerkin_supermesh_free - module procedure dg_interpolation_galerkin_scalars_supermesh_free, dg_interpolation_galerkin_state_supermesh_free - end interface - - contains - - subroutine dg_interpolation_galerkin_scalars_supermesh_free(old_fields, old_position, new_fields, new_position, map_BA) - type(scalar_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(in) :: old_position - - type(scalar_field), dimension(:), intent(inout), target :: new_fields - type(vector_field), intent(in) :: new_position - type(ilist), dimension(:), intent(in), optional, target :: map_BA - - integer :: ele_B - integer :: ele_A - integer :: j, k, l, field, field_count - real, dimension(:), allocatable :: detwei_B - - ! We want to compute the mixed mass matrix M^{BA}. - ! But that's huge. So, we compute a part of a row (not even the whole row) - ! and multiply it by a part of the solution on the old mesh A - ! to get a component of the RHS of the matrix we want to solve. - real, dimension(ele_loc(new_fields(1), 1), ele_loc(new_fields(1), 1)) :: mat_int - real, dimension(ele_loc(new_fields(1), 1)) :: val_A - real, dimension(ele_loc(new_fields(1), 1), size(new_fields)) :: rhs - ! For each element in B, we will need to identify the local coordinates in B - ! of the positions of the gauss points of all its children C elements. - ! So we'll need to assemble and invert that matrix (the global-to-local inversion matrix): - real, dimension(ele_loc(new_position, 1), ele_loc(new_position, 1)) :: inversion_matrix_B, inversion_matrix_A - real, dimension(ele_loc(new_position, 1), ele_loc(new_position, 1), ele_count(old_position)) :: inversion_matrices_A - real, dimension(ele_loc(new_fields(1), 1), ele_loc(new_fields(1), 1)) :: mat, little_mass_matrix - - real, dimension(:, :), allocatable :: pos_at_quad_A - real, dimension(:, :), allocatable :: basis_at_quad_B, basis_at_quad_A - integer :: nloc - logical :: P1 - integer :: dim - type(ilist), dimension(:), pointer :: lmap_BA - type(inode), pointer :: llnode - type(quadrature_type) :: new_quad, old_quad - type(mesh_type), pointer :: B_mesh - integer :: ngi - type(element_type) :: new_shape, old_shape, new_position_inc_quad_shape - type(vector_field) :: new_position_inc_quad - - ! Linear positions -- definitely linear positions. - assert(old_position%mesh%shape%degree == 1) - assert(continuity(old_position) >= 0) - assert(continuity(new_position) >= 0) - - field_count = size(old_fields) - nloc = ele_loc(new_fields(1), 1) - dim = new_position%dim - - B_mesh => new_fields(1)%mesh - old_shape = new_fields(1)%mesh%shape - - new_quad = make_quadrature(vertices=ele_loc(new_position, 1), dim=dim, degree=8) - new_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=old_shape%degree, quad=new_quad) - ngi = new_shape%ngi - - ! I can't believe how ugly this is - someone please write a "swap-out ngi" - ! routine - new_position_inc_quad_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=new_position%mesh%shape%degree, quad=new_quad) - new_position_inc_quad = new_position - new_position_inc_quad%mesh%shape = new_position_inc_quad_shape - - assert(continuity(new_fields(1)) < 0) - P1 = (new_shape%degree == 1) - call intersector_set_dimension(dim) - if (present(map_BA)) then - lmap_BA => map_BA - else - allocate(lmap_BA(ele_count(new_position_inc_quad))) - lmap_BA = intersection_finder(new_position_inc_quad, old_position) - end if - - old_quad = B_mesh%shape%quadrature - B_mesh%shape = new_shape - - do field=1,field_count - call zero(new_fields(field)) - end do - - allocate(pos_at_quad_A(new_position_inc_quad%dim+1, ngi)) - allocate(basis_at_quad_A(nloc, ngi)) - allocate(basis_at_quad_B(nloc, ngi)) - allocate(detwei_B(ngi)) - - do ele_A=1,ele_count(old_position) - call local_coords_matrix(old_position, ele_A, inversion_matrices_A(:, :, ele_A)) - end do - - do ele_B=1,ele_count(new_position_inc_quad) - - ! First thing: assemble and invert the inversion matrix. - call local_coords_matrix(new_position_inc_quad, ele_B, inversion_matrix_B) - - ! Second thing: assemble the mass matrix of B on the left. - call transform_to_physical(new_position_inc_quad, ele_B, detwei=detwei_B) - little_mass_matrix = shape_shape(new_shape, new_shape, detwei_B) - - llnode => lmap_BA(ele_B)%firstnode - rhs = 0 - - do while (associated(llnode)) - ele_A = llnode%value - inversion_matrix_A = inversion_matrices_A(:, :, ele_A) - - basis_at_quad_B = new_shape%n - - pos_at_quad_A(1:dim, :) = ele_val_at_quad(new_position_inc_quad, ele_B) - pos_at_quad_A(dim+1, :) = 1.0 - pos_at_quad_A = matmul(inversion_matrix_A, pos_at_quad_A) - - ! Evaluate the basis functions at the local coordinates - if (P1) then - do j=1,ngi - ! Check if it's inside the element or not - if (min(minval(pos_at_quad_A(:, j)), minval(1 - pos_at_quad_A(:, j))) >= 0.0) then - basis_at_quad_A(:, j) = pos_at_quad_A(:, j) - else - basis_at_quad_A(:, j) = 0.0 - end if - end do - else - do j=1,ngi - if (min(minval(pos_at_quad_A(:, j)), minval(1 - pos_at_quad_A(:, j))) >= 0.0) then - basis_at_quad_A(:, j) = eval_shape(new_shape, pos_at_quad_A(:, j)) - else - basis_at_quad_A(:, j) = 0.0 - end if - end do - end if - - ! Combined outer_product and tensormul_3_1 to see if it is faster. - mat = 0.0 - do j=1,ngi - forall (k=1:nloc,l=1:nloc) - mat_int(k, l) = basis_at_quad_B(k, j) * basis_at_quad_A(l, j) - end forall - mat = mat + mat_int * detwei_B(j) - end do - - do field=1,field_count - val_A = ele_val(old_fields(field), ele_A) - rhs(:, field) = rhs(:, field) + matmul(mat, val_A) - end do - - llnode => llnode%next - end do + use vector_tools + use quadrature + use futils + use spud + use sparse_tools + use tensors + use transform_elements + use adjacency_lists + use unittest_tools + use linked_lists + use supermesh_construction + use fetools + use intersection_finder_module + use fields + use meshdiagnostics + use sparsity_patterns + use state_module + use vtk_interfaces + use interpolation_module + use sparse_matrices_fields + use solvers + implicit none + + private + public :: dg_interpolation_galerkin_supermesh_free + + interface dg_interpolation_galerkin_supermesh_free + module procedure dg_interpolation_galerkin_scalars_supermesh_free, dg_interpolation_galerkin_state_supermesh_free + end interface + +contains + + subroutine dg_interpolation_galerkin_scalars_supermesh_free(old_fields, old_position, new_fields, new_position, map_BA) + type(scalar_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(in) :: old_position + + type(scalar_field), dimension(:), intent(inout), target :: new_fields + type(vector_field), intent(in) :: new_position + type(ilist), dimension(:), intent(in), optional, target :: map_BA + + integer :: ele_B + integer :: ele_A + integer :: j, k, l, field, field_count + real, dimension(:), allocatable :: detwei_B + + ! We want to compute the mixed mass matrix M^{BA}. + ! But that's huge. So, we compute a part of a row (not even the whole row) + ! and multiply it by a part of the solution on the old mesh A + ! to get a component of the RHS of the matrix we want to solve. + real, dimension(ele_loc(new_fields(1), 1), ele_loc(new_fields(1), 1)) :: mat_int + real, dimension(ele_loc(new_fields(1), 1)) :: val_A + real, dimension(ele_loc(new_fields(1), 1), size(new_fields)) :: rhs + ! For each element in B, we will need to identify the local coordinates in B + ! of the positions of the gauss points of all its children C elements. + ! So we'll need to assemble and invert that matrix (the global-to-local inversion matrix): + real, dimension(ele_loc(new_position, 1), ele_loc(new_position, 1)) :: inversion_matrix_B, inversion_matrix_A + real, dimension(ele_loc(new_position, 1), ele_loc(new_position, 1), ele_count(old_position)) :: inversion_matrices_A + real, dimension(ele_loc(new_fields(1), 1), ele_loc(new_fields(1), 1)) :: mat, little_mass_matrix + + real, dimension(:, :), allocatable :: pos_at_quad_A + real, dimension(:, :), allocatable :: basis_at_quad_B, basis_at_quad_A + integer :: nloc + logical :: P1 + integer :: dim + type(ilist), dimension(:), pointer :: lmap_BA + type(inode), pointer :: llnode + type(quadrature_type) :: new_quad, old_quad + type(mesh_type), pointer :: B_mesh + integer :: ngi + type(element_type) :: new_shape, old_shape, new_position_inc_quad_shape + type(vector_field) :: new_position_inc_quad + + ! Linear positions -- definitely linear positions. + assert(old_position%mesh%shape%degree == 1) + assert(continuity(old_position) >= 0) + assert(continuity(new_position) >= 0) + + field_count = size(old_fields) + nloc = ele_loc(new_fields(1), 1) + dim = new_position%dim + + B_mesh => new_fields(1)%mesh + old_shape = new_fields(1)%mesh%shape + + new_quad = make_quadrature(vertices=ele_loc(new_position, 1), dim=dim, degree=8) + new_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=old_shape%degree, quad=new_quad) + ngi = new_shape%ngi + + ! I can't believe how ugly this is - someone please write a "swap-out ngi" + ! routine + new_position_inc_quad_shape = make_element_shape(vertices=ele_loc(new_position, 1), dim=dim, degree=new_position%mesh%shape%degree, quad=new_quad) + new_position_inc_quad = new_position + new_position_inc_quad%mesh%shape = new_position_inc_quad_shape + + assert(continuity(new_fields(1)) < 0) + P1 = (new_shape%degree == 1) + call intersector_set_dimension(dim) + if (present(map_BA)) then + lmap_BA => map_BA + else + allocate(lmap_BA(ele_count(new_position_inc_quad))) + lmap_BA = intersection_finder(new_position_inc_quad, old_position) + end if + + old_quad = B_mesh%shape%quadrature + B_mesh%shape = new_shape - call solve(little_mass_matrix, rhs) do field=1,field_count - call set(new_fields(field), ele_nodes(new_fields(field), ele_B), rhs(:, field)) + call zero(new_fields(field)) + end do + + allocate(pos_at_quad_A(new_position_inc_quad%dim+1, ngi)) + allocate(basis_at_quad_A(nloc, ngi)) + allocate(basis_at_quad_B(nloc, ngi)) + allocate(detwei_B(ngi)) + + do ele_A=1,ele_count(old_position) + call local_coords_matrix(old_position, ele_A, inversion_matrices_A(:, :, ele_A)) end do - end do - if (.not. present(map_BA)) then do ele_B=1,ele_count(new_position_inc_quad) - call deallocate(lmap_BA(ele_B)) + + ! First thing: assemble and invert the inversion matrix. + call local_coords_matrix(new_position_inc_quad, ele_B, inversion_matrix_B) + + ! Second thing: assemble the mass matrix of B on the left. + call transform_to_physical(new_position_inc_quad, ele_B, detwei=detwei_B) + little_mass_matrix = shape_shape(new_shape, new_shape, detwei_B) + + llnode => lmap_BA(ele_B)%firstnode + rhs = 0 + + do while (associated(llnode)) + ele_A = llnode%value + inversion_matrix_A = inversion_matrices_A(:, :, ele_A) + + basis_at_quad_B = new_shape%n + + pos_at_quad_A(1:dim, :) = ele_val_at_quad(new_position_inc_quad, ele_B) + pos_at_quad_A(dim+1, :) = 1.0 + pos_at_quad_A = matmul(inversion_matrix_A, pos_at_quad_A) + + ! Evaluate the basis functions at the local coordinates + if (P1) then + do j=1,ngi + ! Check if it's inside the element or not + if (min(minval(pos_at_quad_A(:, j)), minval(1 - pos_at_quad_A(:, j))) >= 0.0) then + basis_at_quad_A(:, j) = pos_at_quad_A(:, j) + else + basis_at_quad_A(:, j) = 0.0 + end if + end do + else + do j=1,ngi + if (min(minval(pos_at_quad_A(:, j)), minval(1 - pos_at_quad_A(:, j))) >= 0.0) then + basis_at_quad_A(:, j) = eval_shape(new_shape, pos_at_quad_A(:, j)) + else + basis_at_quad_A(:, j) = 0.0 + end if + end do + end if + + ! Combined outer_product and tensormul_3_1 to see if it is faster. + mat = 0.0 + do j=1,ngi + forall (k=1:nloc,l=1:nloc) + mat_int(k, l) = basis_at_quad_B(k, j) * basis_at_quad_A(l, j) + end forall + mat = mat + mat_int * detwei_B(j) + end do + + do field=1,field_count + val_A = ele_val(old_fields(field), ele_A) + rhs(:, field) = rhs(:, field) + matmul(mat, val_A) + end do + + llnode => llnode%next + end do + + call solve(little_mass_matrix, rhs) + do field=1,field_count + call set(new_fields(field), ele_nodes(new_fields(field), ele_B), rhs(:, field)) + end do end do - deallocate(lmap_BA) - end if - deallocate(pos_at_quad_A) - deallocate(detwei_B) + if (.not. present(map_BA)) then + do ele_B=1,ele_count(new_position_inc_quad) + call deallocate(lmap_BA(ele_B)) + end do + deallocate(lmap_BA) + end if + + deallocate(pos_at_quad_A) + deallocate(detwei_B) - B_mesh%shape = old_shape - call deallocate(new_quad) - call deallocate(new_shape) + B_mesh%shape = old_shape + call deallocate(new_quad) + call deallocate(new_shape) - end subroutine dg_interpolation_galerkin_scalars_supermesh_free + end subroutine dg_interpolation_galerkin_scalars_supermesh_free - subroutine dg_interpolation_galerkin_state_supermesh_free(old_state, new_state, map_BA) - type(state_type), intent(inout) :: old_state, new_state + subroutine dg_interpolation_galerkin_state_supermesh_free(old_state, new_state, map_BA) + type(state_type), intent(inout) :: old_state, new_state - type(scalar_field), dimension(:), pointer :: old_fields, new_fields - type(vector_field), pointer :: old_position, new_position - type(ilist), dimension(:), intent(in), optional :: map_BA + type(scalar_field), dimension(:), pointer :: old_fields, new_fields + type(vector_field), pointer :: old_position, new_position + type(ilist), dimension(:), intent(in), optional :: map_BA - call collapse_state(old_state, old_fields) - call collapse_state(new_state, new_fields) + call collapse_state(old_state, old_fields) + call collapse_state(new_state, new_fields) - old_position => extract_vector_field(old_state, "Coordinate") - new_position => extract_vector_field(new_state, "Coordinate") + old_position => extract_vector_field(old_state, "Coordinate") + new_position => extract_vector_field(new_state, "Coordinate") - if(present(map_BA)) then - call dg_interpolation_galerkin_scalars_supermesh_free(old_fields, old_position, new_fields, new_position, map_BA=map_BA) - else - call dg_interpolation_galerkin_scalars_supermesh_free(old_fields, old_position, new_fields, new_position) - end if + if(present(map_BA)) then + call dg_interpolation_galerkin_scalars_supermesh_free(old_fields, old_position, new_fields, new_position, map_BA=map_BA) + else + call dg_interpolation_galerkin_scalars_supermesh_free(old_fields, old_position, new_fields, new_position) + end if - deallocate(old_fields) - deallocate(new_fields) + deallocate(old_fields) + deallocate(new_fields) - end subroutine dg_interpolation_galerkin_state_supermesh_free + end subroutine dg_interpolation_galerkin_state_supermesh_free end module dg_interpolation_module diff --git a/femtools/Data_structures.F90 b/femtools/Data_structures.F90 index c9422003f7..772a47ad24 100644 --- a/femtools/Data_structures.F90 +++ b/femtools/Data_structures.F90 @@ -2,58 +2,58 @@ module data_structures - use integer_set_module - use integer_hash_table_module + use integer_set_module + use integer_hash_table_module - implicit none + implicit none - interface invert_set - module procedure invert_set_vector, invert_set_iset - end interface invert_set + interface invert_set + module procedure invert_set_vector, invert_set_iset + end interface invert_set contains - subroutine invert_set_vector(vector, ihash) - ! A vector (/n1, n2, .../) implicitly defines a map - ! 1 -> n1 - ! 2 -> n2 - ! ... + subroutine invert_set_vector(vector, ihash) + ! A vector (/n1, n2, .../) implicitly defines a map + ! 1 -> n1 + ! 2 -> n2 + ! ... - ! Here we invert it to give the hash table that maps - ! n1 -> 1 - ! n2 -> 2 - ! ... + ! Here we invert it to give the hash table that maps + ! n1 -> 1 + ! n2 -> 2 + ! ... - integer, dimension(:), intent(in) :: vector - type(integer_hash_table), intent(out) :: ihash + integer, dimension(:), intent(in) :: vector + type(integer_hash_table), intent(out) :: ihash - integer :: i + integer :: i - call allocate(ihash) - do i = 1, size(vector) - call insert(ihash, vector(i), i) - end do + call allocate(ihash) + do i = 1, size(vector) + call insert(ihash, vector(i), i) + end do - end subroutine invert_set_vector + end subroutine invert_set_vector - subroutine invert_set_iset(iset, ihash) - ! A set {n1, n2, ...} implicitly defines a map - ! 1 -> n1 - ! 2 -> n2 - ! ... + subroutine invert_set_iset(iset, ihash) + ! A set {n1, n2, ...} implicitly defines a map + ! 1 -> n1 + ! 2 -> n2 + ! ... - ! Here we invert it to give the hash table that maps - ! n1 -> 1 - ! n2 -> 2 + ! Here we invert it to give the hash table that maps + ! n1 -> 1 + ! n2 -> 2 - type(integer_set), intent(in) :: iset - type(integer_hash_table), intent(out) :: ihash - integer :: i + type(integer_set), intent(in) :: iset + type(integer_hash_table), intent(out) :: ihash + integer :: i - call allocate(ihash) - do i=1,key_count(iset) - call insert(ihash, fetch(iset, i), i) - end do - end subroutine invert_set_iset + call allocate(ihash) + do i=1,key_count(iset) + call insert(ihash, fetch(iset, i), i) + end do + end subroutine invert_set_iset end module data_structures diff --git a/femtools/Detector_Data_Types.F90 b/femtools/Detector_Data_Types.F90 index 5f2c223970..2edbfd5561 100644 --- a/femtools/Detector_Data_Types.F90 +++ b/femtools/Detector_Data_Types.F90 @@ -29,186 +29,186 @@ module detector_data_types - use fldebug - use global_parameters, only : FIELD_NAME_LEN - - implicit none - - private - - public :: detector_type, rk_gs_parameters, detector_linked_list, & - detector_list_ptr, stringlist, attr_names_type, attr_write_type, field_phase_type, & - allocate, deallocate - - type stringlist - !!< Container type for a list of strings. - character(len=FIELD_NAME_LEN), dimension(:), pointer :: ptr - end type stringlist - - type attr_names_type - !< A bundling of names of scalar, vector, and tensor attributes. - character(len=FIELD_NAME_LEN), dimension(:), allocatable :: s, v, t - !! The array length of each individual attribute. - !! A value of 0 indicates a scalar attribute, otherwise it is - !! array-valued with the specified dimension. - integer, dimension(:), allocatable :: sn, vn, tn - end type attr_names_type - - type field_phase_type - !< A bundling of material_phase number for each - !! scalar, vector, and tensor field that is to be - !! included on particles. - integer, dimension(:), allocatable :: s, v, t - end type field_phase_type - - type attr_write_type - !< A bundling of whether to include attributes in - !! the output file, grouped by scalar, vector, and tensor to match - !! other attribute-related datatypes. - logical, dimension(:), allocatable :: s, v, t - end type attr_write_type - - interface allocate - module procedure allocate_attr_names, allocate_field_phases - end interface allocate - - interface deallocate - module procedure deallocate_attr_names - end interface deallocate - - !! Type for caching detector position and search information. - type detector_type - !! Physical location of the detector. - real, dimension(:), allocatable :: position - !! Element number in which the detector lies. - integer :: element - !! Local coordinates of the detector in that element. - real, dimension(:), allocatable :: local_coords - !! Identification number indicating the order in which the detectors are read - integer :: id_number - !! Identification number indicating parent processor when detector was created - integer :: proc_id - !! ID of the parent list, needed for Zoltan to map the detector back - integer :: list_id - !! RK timestepping stages (first index is stage no., second index is dim) - real, dimension(:,:), allocatable :: k - !! RK update destination vector (size dim) - real, dimension(:), allocatable :: update_vector - !! Attributes carried by particles. - real, dimension(:), allocatable :: attributes - !! Attributes carried by particles at the previous timestep. - real, dimension(:), allocatable :: old_attributes - !! Interpolated field values at the particle position at the previous timestep. - real, dimension(:), allocatable :: old_fields - !! Have we completed the search? - logical :: search_complete - !! Pointers for detector linked lists - type (detector_type), pointer :: next=> null() - type (detector_type), pointer :: previous=> null() - !! Pointers to temporary linked lists used during spawning and deleting. - !! These lists are used to form temporary linked lists within Particle_Diagnostics.F90 - !! Temporary linked lists are created per control volume to allow for easy looping - !! over particle within that control volume during spawning and deleting. - type (detector_type), pointer :: temp_next => null() - type (detector_type), pointer :: temp_previous => null() - end type detector_type - - ! Parameters for lagrangian detector movement - type rk_gs_parameters - !! Runge-Kutta Guided Search parameters - integer :: n_stages, n_subcycles - !! Timestep_weights give the weights of temporal positions - real, allocatable, dimension(:) :: timestep_weights - !! Timestep_nodes give the locations of temporal positions - real, allocatable, dimension(:) :: timestep_nodes - !! Stage_matrix gives the weights to RK function values - real, allocatable, dimension(:,:) :: stage_matrix - real :: search_tolerance - end type rk_gs_parameters - - type detector_linked_list - !! Doubly linked list implementation - integer :: length=0 - TYPE (detector_type), pointer :: first => null() - TYPE (detector_type), pointer :: last => null() - - !! Internal ID used for packing/unpacking detectors - integer :: id ! IDs are counted from 1 - integer :: proc_part_count = 0!Counter for the number of particles spawned on the current processor - - !! Parameters for lagrangian movement (n_stages, stage_matrix, etc) - type(rk_gs_parameters), pointer :: move_parameters => null() - logical :: move_with_mesh = .false. - - !! List of scalar/vector fields to include in detector output - type(stringlist), dimension(:), allocatable :: sfield_list - type(stringlist), dimension(:), allocatable :: vfield_list - integer :: num_sfields = 0 ! Total number of scalar fields across all phases - integer :: num_vfields = 0 ! Total number of vector fields across all phases - - !! Total number of parameters which are stored on particles. First dimension indicates - !! number of attributes stored, second dimension indicates number of old_attributes - !! stored, third dimension indicates number of old_fields stored. - integer, dimension(3) :: total_attributes - !! Whether attributes should be written or not - type(attr_write_type) :: attr_write - !! Names of attributes and fields stored in a particle subgroup - type(attr_names_type) :: attr_names, old_attr_names, field_names, old_field_names - !! The phase of each field that is used in particle attribute calculations - type(field_phase_type) :: field_phases, old_field_phases - - !! I/O parameters - logical :: write_nan_outside = .false. - integer(kind=8) :: h5_id = -1 ! H5hut output identifier - integer :: total_num_det = 0 ! Global number of detectors in this list - end type detector_linked_list - - type detector_list_ptr - type(detector_linked_list), pointer :: ptr - end type detector_list_ptr + use fldebug + use global_parameters, only : FIELD_NAME_LEN + + implicit none + + private + + public :: detector_type, rk_gs_parameters, detector_linked_list, & + detector_list_ptr, stringlist, attr_names_type, attr_write_type, field_phase_type, & + allocate, deallocate + + type stringlist + !!< Container type for a list of strings. + character(len=FIELD_NAME_LEN), dimension(:), pointer :: ptr + end type stringlist + + type attr_names_type + !< A bundling of names of scalar, vector, and tensor attributes. + character(len=FIELD_NAME_LEN), dimension(:), allocatable :: s, v, t + !! The array length of each individual attribute. + !! A value of 0 indicates a scalar attribute, otherwise it is + !! array-valued with the specified dimension. + integer, dimension(:), allocatable :: sn, vn, tn + end type attr_names_type + + type field_phase_type + !< A bundling of material_phase number for each + !! scalar, vector, and tensor field that is to be + !! included on particles. + integer, dimension(:), allocatable :: s, v, t + end type field_phase_type + + type attr_write_type + !< A bundling of whether to include attributes in + !! the output file, grouped by scalar, vector, and tensor to match + !! other attribute-related datatypes. + logical, dimension(:), allocatable :: s, v, t + end type attr_write_type + + interface allocate + module procedure allocate_attr_names, allocate_field_phases + end interface allocate + + interface deallocate + module procedure deallocate_attr_names + end interface deallocate + + !! Type for caching detector position and search information. + type detector_type + !! Physical location of the detector. + real, dimension(:), allocatable :: position + !! Element number in which the detector lies. + integer :: element + !! Local coordinates of the detector in that element. + real, dimension(:), allocatable :: local_coords + !! Identification number indicating the order in which the detectors are read + integer :: id_number + !! Identification number indicating parent processor when detector was created + integer :: proc_id + !! ID of the parent list, needed for Zoltan to map the detector back + integer :: list_id + !! RK timestepping stages (first index is stage no., second index is dim) + real, dimension(:,:), allocatable :: k + !! RK update destination vector (size dim) + real, dimension(:), allocatable :: update_vector + !! Attributes carried by particles. + real, dimension(:), allocatable :: attributes + !! Attributes carried by particles at the previous timestep. + real, dimension(:), allocatable :: old_attributes + !! Interpolated field values at the particle position at the previous timestep. + real, dimension(:), allocatable :: old_fields + !! Have we completed the search? + logical :: search_complete + !! Pointers for detector linked lists + type (detector_type), pointer :: next=> null() + type (detector_type), pointer :: previous=> null() + !! Pointers to temporary linked lists used during spawning and deleting. + !! These lists are used to form temporary linked lists within Particle_Diagnostics.F90 + !! Temporary linked lists are created per control volume to allow for easy looping + !! over particle within that control volume during spawning and deleting. + type (detector_type), pointer :: temp_next => null() + type (detector_type), pointer :: temp_previous => null() + end type detector_type + + ! Parameters for lagrangian detector movement + type rk_gs_parameters + !! Runge-Kutta Guided Search parameters + integer :: n_stages, n_subcycles + !! Timestep_weights give the weights of temporal positions + real, allocatable, dimension(:) :: timestep_weights + !! Timestep_nodes give the locations of temporal positions + real, allocatable, dimension(:) :: timestep_nodes + !! Stage_matrix gives the weights to RK function values + real, allocatable, dimension(:,:) :: stage_matrix + real :: search_tolerance + end type rk_gs_parameters + + type detector_linked_list + !! Doubly linked list implementation + integer :: length=0 + TYPE (detector_type), pointer :: first => null() + TYPE (detector_type), pointer :: last => null() + + !! Internal ID used for packing/unpacking detectors + integer :: id ! IDs are counted from 1 + integer :: proc_part_count = 0!Counter for the number of particles spawned on the current processor + + !! Parameters for lagrangian movement (n_stages, stage_matrix, etc) + type(rk_gs_parameters), pointer :: move_parameters => null() + logical :: move_with_mesh = .false. + + !! List of scalar/vector fields to include in detector output + type(stringlist), dimension(:), allocatable :: sfield_list + type(stringlist), dimension(:), allocatable :: vfield_list + integer :: num_sfields = 0 ! Total number of scalar fields across all phases + integer :: num_vfields = 0 ! Total number of vector fields across all phases + + !! Total number of parameters which are stored on particles. First dimension indicates + !! number of attributes stored, second dimension indicates number of old_attributes + !! stored, third dimension indicates number of old_fields stored. + integer, dimension(3) :: total_attributes + !! Whether attributes should be written or not + type(attr_write_type) :: attr_write + !! Names of attributes and fields stored in a particle subgroup + type(attr_names_type) :: attr_names, old_attr_names, field_names, old_field_names + !! The phase of each field that is used in particle attribute calculations + type(field_phase_type) :: field_phases, old_field_phases + + !! I/O parameters + logical :: write_nan_outside = .false. + integer(kind=8) :: h5_id = -1 ! H5hut output identifier + integer :: total_num_det = 0 ! Global number of detectors in this list + end type detector_linked_list + + type detector_list_ptr + type(detector_linked_list), pointer :: ptr + end type detector_list_ptr contains - !> Allocate the attribute name type, given an array of - !! the number of scalar, vector, and tensor components. - subroutine allocate_attr_names(attr_names, counts) - type(attr_names_type), intent(out) :: attr_names - integer, dimension(3), intent(in) :: counts - - allocate(attr_names%s(counts(1))) - allocate(attr_names%v(counts(2))) - allocate(attr_names%t(counts(3))) - - allocate(attr_names%sn(counts(1))) - allocate(attr_names%vn(counts(2))) - allocate(attr_names%tn(counts(3))) - - attr_names%sn(:) = 0 - attr_names%vn(:) = 0 - attr_names%tn(:) = 0 - end subroutine allocate_attr_names - - !> Allocate the field phase type, given an array of - !! the number of scalar, vector, and tensor components. - subroutine allocate_field_phases(field_phases, counts) - type(field_phase_type), intent(out) :: field_phases - integer, dimension(3), intent(in) :: counts - - allocate(field_phases%s(counts(1))) - allocate(field_phases%v(counts(2))) - allocate(field_phases%t(counts(3))) - end subroutine allocate_field_phases - - subroutine deallocate_attr_names(attr_names) - type(attr_names_type), intent(inout) :: attr_names - - deallocate(attr_names%s) - deallocate(attr_names%v) - deallocate(attr_names%t) - - deallocate(attr_names%sn) - deallocate(attr_names%vn) - deallocate(attr_names%tn) - end subroutine deallocate_attr_names + !> Allocate the attribute name type, given an array of + !! the number of scalar, vector, and tensor components. + subroutine allocate_attr_names(attr_names, counts) + type(attr_names_type), intent(out) :: attr_names + integer, dimension(3), intent(in) :: counts + + allocate(attr_names%s(counts(1))) + allocate(attr_names%v(counts(2))) + allocate(attr_names%t(counts(3))) + + allocate(attr_names%sn(counts(1))) + allocate(attr_names%vn(counts(2))) + allocate(attr_names%tn(counts(3))) + + attr_names%sn(:) = 0 + attr_names%vn(:) = 0 + attr_names%tn(:) = 0 + end subroutine allocate_attr_names + + !> Allocate the field phase type, given an array of + !! the number of scalar, vector, and tensor components. + subroutine allocate_field_phases(field_phases, counts) + type(field_phase_type), intent(out) :: field_phases + integer, dimension(3), intent(in) :: counts + + allocate(field_phases%s(counts(1))) + allocate(field_phases%v(counts(2))) + allocate(field_phases%t(counts(3))) + end subroutine allocate_field_phases + + subroutine deallocate_attr_names(attr_names) + type(attr_names_type), intent(inout) :: attr_names + + deallocate(attr_names%s) + deallocate(attr_names%v) + deallocate(attr_names%t) + + deallocate(attr_names%sn) + deallocate(attr_names%vn) + deallocate(attr_names%tn) + end subroutine deallocate_attr_names end module detector_data_types diff --git a/femtools/Detector_Move_Lagrangian.F90 b/femtools/Detector_Move_Lagrangian.F90 index 38f7eeb08f..7e3ebf55be 100644 --- a/femtools/Detector_Move_Lagrangian.F90 +++ b/femtools/Detector_Move_Lagrangian.F90 @@ -28,416 +28,416 @@ #include "fdebug.h" module detector_move_lagrangian - use spud - use fldebug - use global_parameters, only: OPTION_PATH_LEN - use integer_hash_table_module - use halo_data_types - use parallel_tools - use halos_base - use parallel_fields - use transform_elements - use fields - use state_module - use detector_data_types - use detector_tools - use detector_parallel + use spud + use fldebug + use global_parameters, only: OPTION_PATH_LEN + use integer_hash_table_module + use halo_data_types + use parallel_tools + use halos_base + use parallel_fields + use transform_elements + use fields + use state_module + use detector_data_types + use detector_tools + use detector_parallel - implicit none + implicit none - private + private - public :: move_lagrangian_detectors, read_detector_move_options + public :: move_lagrangian_detectors, read_detector_move_options - character(len=OPTION_PATH_LEN), parameter :: rk_gs_path="/lagrangian_timestepping/explicit_runge_kutta_guided_search" + character(len=OPTION_PATH_LEN), parameter :: rk_gs_path="/lagrangian_timestepping/explicit_runge_kutta_guided_search" contains - subroutine read_detector_move_options(detector_list, detector_path) - ! Subroutine to allocate the detector parameters, - ! including RK stages and update vector - type(detector_linked_list), intent(inout) :: detector_list - character(len=*), intent(in) :: detector_path - - type(rk_gs_parameters), pointer :: parameters - integer :: i,j,k - real, allocatable, dimension(:) :: stage_weights - integer, dimension(2) :: option_rank - - if (associated(detector_list%move_parameters)) then - deallocate(detector_list%move_parameters) - end if - allocate(detector_list%move_parameters) - parameters => detector_list%move_parameters - - if(have_option(trim(detector_path)//"/lagrangian_timestepping")) then - - call get_option(trim(detector_path)//"/lagrangian_timestepping/subcycles",parameters%n_subcycles) - call get_option(trim(detector_path)//"/lagrangian_timestepping/search_tolerance",parameters%search_tolerance) - - ! Forward Euler options - if (have_option(trim(detector_path)//"/lagrangian_timestepping/forward_euler_guided_search")) then - parameters%n_stages = 1 - allocate(parameters%timestep_weights(parameters%n_stages)) - parameters%timestep_weights = 1.0 - allocate(parameters%timestep_nodes(parameters%n_stages)) - parameters%timestep_nodes = 0.0 - end if - - ! Parameters for classical Runge-Kutta - if (have_option(trim(detector_path)//"/lagrangian_timestepping/rk4_guided_search")) then - parameters%n_stages = 4 - allocate(stage_weights(parameters%n_stages*(parameters%n_stages-1)/2)) - stage_weights = (/0.5, 0., 0.5, 0., 0., 1./) - allocate(parameters%stage_matrix(parameters%n_stages,parameters%n_stages)) - parameters%stage_matrix = 0. - k = 0 - do i = 1, parameters%n_stages - do j = 1, parameters%n_stages - if(i>j) then - k = k + 1 - parameters%stage_matrix(i,j) = stage_weights(k) - end if - end do - end do - allocate(parameters%timestep_weights(parameters%n_stages)) - parameters%timestep_weights = (/ 1./6., 1./3., 1./3., 1./6. /) - allocate(parameters%timestep_nodes(parameters%n_stages)) - parameters%timestep_nodes = (/ 0., 1./2., 1./2., 1. /) - end if - - ! Generic Runge-Kutta options - if (have_option(trim(detector_path)//trim(rk_gs_path))) then - call get_option(trim(detector_path)//trim(rk_gs_path)//"/n_stages",parameters%n_stages) - - ! Allocate and read stage_matrix from options - allocate(stage_weights(parameters%n_stages*(parameters%n_stages-1)/2)) - option_rank = option_shape(trim(detector_path)//trim(rk_gs_path)//"/stage_weights") - if (option_rank(2).ne.-1) then - FLExit('Stage Array wrong rank') - end if - if (option_rank(1).ne.size(stage_weights)) then - ewrite(-1,*) 'size expected was', size(stage_weights) - ewrite(-1,*) 'size actually was', option_rank(1) - FLExit('Stage Array wrong size') - end if - call get_option(trim(detector_path)//trim(rk_gs_path)//"/stage_weights",stage_weights) - allocate(parameters%stage_matrix(parameters%n_stages,parameters%n_stages)) - parameters%stage_matrix = 0. - k = 0 - do i = 1, parameters%n_stages - do j = 1, parameters%n_stages - if(i>j) then - k = k + 1 - parameters%stage_matrix(i,j) = stage_weights(k) - end if - end do - end do - - ! Allocate and read timestep_weights from options - allocate(parameters%timestep_weights(parameters%n_stages)) - option_rank = option_shape(trim(detector_path)//trim(rk_gs_path)//"/timestep_weights") - if (option_rank(2).ne.-1) then - FLExit('Timestep Array wrong rank') - end if - if (option_rank(1).ne.size(parameters%timestep_weights)) then - FLExit('Timestep Array wrong size') - end if - call get_option(trim(detector_path)//trim(rk_gs_path)//"/timestep_weights",parameters%timestep_weights) - - ! Allocate and set timestep_nodes - allocate(parameters%timestep_nodes(parameters%n_stages)) - parameters%timestep_nodes= 0. - do i = 1, parameters%n_stages - do j = 1, parameters%n_stages - parameters%timestep_nodes(i)=parameters%timestep_nodes(i) + parameters%stage_matrix(i,j) - end do - end do - - end if - - else - ewrite(-1,*) "Found lagrangian detectors, but no timstepping options" - FLExit('No lagrangian timestepping specified') - end if - - end subroutine read_detector_move_options - - subroutine move_lagrangian_detectors(state, detector_list, dt) - type(state_type), dimension(:), intent(in) :: state - type(detector_linked_list), intent(inout) :: detector_list - real, intent(in) :: dt - - type(rk_gs_parameters), pointer :: parameters - type(vector_field), pointer :: vfield, vfield_old, xfield - type(vector_field) :: vfield_stage - type(detector_linked_list), dimension(:), allocatable :: send_list_array - integer :: k, all_send_lists_empty, nprocs, stage, cycle - real :: rk_dt - - ewrite(1,*) "In move_lagrangian_detectors" - ewrite(2,*) "Detector list", detector_list%id, "has", detector_list%length, & + subroutine read_detector_move_options(detector_list, detector_path) + ! Subroutine to allocate the detector parameters, + ! including RK stages and update vector + type(detector_linked_list), intent(inout) :: detector_list + character(len=*), intent(in) :: detector_path + + type(rk_gs_parameters), pointer :: parameters + integer :: i,j,k + real, allocatable, dimension(:) :: stage_weights + integer, dimension(2) :: option_rank + + if (associated(detector_list%move_parameters)) then + deallocate(detector_list%move_parameters) + end if + allocate(detector_list%move_parameters) + parameters => detector_list%move_parameters + + if(have_option(trim(detector_path)//"/lagrangian_timestepping")) then + + call get_option(trim(detector_path)//"/lagrangian_timestepping/subcycles",parameters%n_subcycles) + call get_option(trim(detector_path)//"/lagrangian_timestepping/search_tolerance",parameters%search_tolerance) + + ! Forward Euler options + if (have_option(trim(detector_path)//"/lagrangian_timestepping/forward_euler_guided_search")) then + parameters%n_stages = 1 + allocate(parameters%timestep_weights(parameters%n_stages)) + parameters%timestep_weights = 1.0 + allocate(parameters%timestep_nodes(parameters%n_stages)) + parameters%timestep_nodes = 0.0 + end if + + ! Parameters for classical Runge-Kutta + if (have_option(trim(detector_path)//"/lagrangian_timestepping/rk4_guided_search")) then + parameters%n_stages = 4 + allocate(stage_weights(parameters%n_stages*(parameters%n_stages-1)/2)) + stage_weights = (/0.5, 0., 0.5, 0., 0., 1./) + allocate(parameters%stage_matrix(parameters%n_stages,parameters%n_stages)) + parameters%stage_matrix = 0. + k = 0 + do i = 1, parameters%n_stages + do j = 1, parameters%n_stages + if(i>j) then + k = k + 1 + parameters%stage_matrix(i,j) = stage_weights(k) + end if + end do + end do + allocate(parameters%timestep_weights(parameters%n_stages)) + parameters%timestep_weights = (/ 1./6., 1./3., 1./3., 1./6. /) + allocate(parameters%timestep_nodes(parameters%n_stages)) + parameters%timestep_nodes = (/ 0., 1./2., 1./2., 1. /) + end if + + ! Generic Runge-Kutta options + if (have_option(trim(detector_path)//trim(rk_gs_path))) then + call get_option(trim(detector_path)//trim(rk_gs_path)//"/n_stages",parameters%n_stages) + + ! Allocate and read stage_matrix from options + allocate(stage_weights(parameters%n_stages*(parameters%n_stages-1)/2)) + option_rank = option_shape(trim(detector_path)//trim(rk_gs_path)//"/stage_weights") + if (option_rank(2).ne.-1) then + FLExit('Stage Array wrong rank') + end if + if (option_rank(1).ne.size(stage_weights)) then + ewrite(-1,*) 'size expected was', size(stage_weights) + ewrite(-1,*) 'size actually was', option_rank(1) + FLExit('Stage Array wrong size') + end if + call get_option(trim(detector_path)//trim(rk_gs_path)//"/stage_weights",stage_weights) + allocate(parameters%stage_matrix(parameters%n_stages,parameters%n_stages)) + parameters%stage_matrix = 0. + k = 0 + do i = 1, parameters%n_stages + do j = 1, parameters%n_stages + if(i>j) then + k = k + 1 + parameters%stage_matrix(i,j) = stage_weights(k) + end if + end do + end do + + ! Allocate and read timestep_weights from options + allocate(parameters%timestep_weights(parameters%n_stages)) + option_rank = option_shape(trim(detector_path)//trim(rk_gs_path)//"/timestep_weights") + if (option_rank(2).ne.-1) then + FLExit('Timestep Array wrong rank') + end if + if (option_rank(1).ne.size(parameters%timestep_weights)) then + FLExit('Timestep Array wrong size') + end if + call get_option(trim(detector_path)//trim(rk_gs_path)//"/timestep_weights",parameters%timestep_weights) + + ! Allocate and set timestep_nodes + allocate(parameters%timestep_nodes(parameters%n_stages)) + parameters%timestep_nodes= 0. + do i = 1, parameters%n_stages + do j = 1, parameters%n_stages + parameters%timestep_nodes(i)=parameters%timestep_nodes(i) + parameters%stage_matrix(i,j) + end do + end do + + end if + + else + ewrite(-1,*) "Found lagrangian detectors, but no timstepping options" + FLExit('No lagrangian timestepping specified') + end if + + end subroutine read_detector_move_options + + subroutine move_lagrangian_detectors(state, detector_list, dt) + type(state_type), dimension(:), intent(in) :: state + type(detector_linked_list), intent(inout) :: detector_list + real, intent(in) :: dt + + type(rk_gs_parameters), pointer :: parameters + type(vector_field), pointer :: vfield, vfield_old, xfield + type(vector_field) :: vfield_stage + type(detector_linked_list), dimension(:), allocatable :: send_list_array + integer :: k, all_send_lists_empty, nprocs, stage, cycle + real :: rk_dt + + ewrite(1,*) "In move_lagrangian_detectors" + ewrite(2,*) "Detector list", detector_list%id, "has", detector_list%length, & "local and", detector_list%total_num_det, "global detectors" - parameters => detector_list%move_parameters + parameters => detector_list%move_parameters - ! Pull some information from state - xfield => extract_vector_field(state(1),"Coordinate") - vfield => extract_vector_field(state(1),"Velocity") - vfield_old => extract_vector_field(state(1),"OldVelocity") + ! Pull some information from state + xfield => extract_vector_field(state(1),"Coordinate") + vfield => extract_vector_field(state(1),"Velocity") + vfield_old => extract_vector_field(state(1),"OldVelocity") - ! velocity interpolate at time-level of each stage - call allocate(vfield_stage, vfield%dim, vfield%mesh, "StagedVelocity") + ! velocity interpolate at time-level of each stage + call allocate(vfield_stage, vfield%dim, vfield%mesh, "StagedVelocity") - ! We allocate a sendlist for every processor - nprocs=getnprocs() - allocate(send_list_array(nprocs)) + ! We allocate a sendlist for every processor + nprocs=getnprocs() + allocate(send_list_array(nprocs)) - ! Allocate det%k and det%update_vector - call allocate_rk_guided_search(detector_list, xfield%dim, parameters%n_stages) - rk_dt = dt/parameters%n_subcycles + ! Allocate det%k and det%update_vector + call allocate_rk_guided_search(detector_list, xfield%dim, parameters%n_stages) + rk_dt = dt/parameters%n_subcycles - subcycling_loop: do cycle = 1, parameters%n_subcycles - RKstages_loop: do stage = 1, parameters%n_stages + subcycling_loop: do cycle = 1, parameters%n_subcycles + RKstages_loop: do stage = 1, parameters%n_stages - ! interpolate velocity at time-level of this stage: - call set(vfield_stage, vfield, vfield_old, parameters%timestep_nodes(stage)) + ! interpolate velocity at time-level of this stage: + call set(vfield_stage, vfield, vfield_old, parameters%timestep_nodes(stage)) - ! Compute the update vector - call set_stage(detector_list, vfield_stage, rk_dt, stage) + ! Compute the update vector + call set_stage(detector_list, vfield_stage, rk_dt, stage) - ! This loop continues until all detectors have completed their - ! timestep this is measured by checking if the send and receive - ! lists are empty in all processors - detector_timestepping_loop: do + ! This loop continues until all detectors have completed their + ! timestep this is measured by checking if the send and receive + ! lists are empty in all processors + detector_timestepping_loop: do - !Detectors leaving the domain from non-owned elements - !are entering a domain on another processor rather - !than leaving the physical domain. In this subroutine - !such detectors are removed from the detector list - !and added to the send_list_array - call move_detectors_guided_search(detector_list,& + !Detectors leaving the domain from non-owned elements + !are entering a domain on another processor rather + !than leaving the physical domain. In this subroutine + !such detectors are removed from the detector list + !and added to the send_list_array + call move_detectors_guided_search(detector_list,& xfield,send_list_array,parameters%search_tolerance) - ! Work out whether all send lists are empty, in which case exit. - all_send_lists_empty=0 - do k=1, nprocs - if (send_list_array(k)%length/=0) then - all_send_lists_empty=1 - end if - end do - call allmax(all_send_lists_empty) - if (all_send_lists_empty==0) exit - - !This call serialises send_list_array, sends it, - !receives serialised receive_list_array, and unserialises that. - call exchange_detectors(state(1),detector_list, send_list_array, & - include_update_vector=.true.) - - end do detector_timestepping_loop - end do RKstages_loop - end do subcycling_loop - - call deallocate(vfield_stage) - - deallocate(send_list_array) - - ! Make sure all local detectors are owned and distribute the ones that - ! stoppped moving in a halo element - call distribute_detectors(state(1), detector_list) - - ! This needs to be called after distribute_detectors because the exchange - ! routine serialises det%k and det%update_vector if it finds the RK-GS option - call deallocate_rk_guided_search(detector_list) - - ewrite(2,*) "After moving and distributing we have", detector_list%length, & + ! Work out whether all send lists are empty, in which case exit. + all_send_lists_empty=0 + do k=1, nprocs + if (send_list_array(k)%length/=0) then + all_send_lists_empty=1 + end if + end do + call allmax(all_send_lists_empty) + if (all_send_lists_empty==0) exit + + !This call serialises send_list_array, sends it, + !receives serialised receive_list_array, and unserialises that. + call exchange_detectors(state(1),detector_list, send_list_array, & + include_update_vector=.true.) + + end do detector_timestepping_loop + end do RKstages_loop + end do subcycling_loop + + call deallocate(vfield_stage) + + deallocate(send_list_array) + + ! Make sure all local detectors are owned and distribute the ones that + ! stoppped moving in a halo element + call distribute_detectors(state(1), detector_list) + + ! This needs to be called after distribute_detectors because the exchange + ! routine serialises det%k and det%update_vector if it finds the RK-GS option + call deallocate_rk_guided_search(detector_list) + + ewrite(2,*) "After moving and distributing we have", detector_list%length, & "local and", detector_list%total_num_det, "global detectors" - ewrite(1,*) "Exiting move_lagrangian_detectors" - - end subroutine move_lagrangian_detectors - - subroutine allocate_rk_guided_search(detector_list, dim, n_stages) - ! Allocate the RK stages and update vector - type(detector_linked_list), intent(inout) :: detector_list - integer, intent(in) :: n_stages, dim - type(detector_type), pointer :: det0 - - det0 => detector_list%first - do while (associated(det0)) - if(allocated(det0%k)) then - deallocate(det0%k) - end if - if(allocated(det0%update_vector)) then - deallocate(det0%update_vector) - end if - allocate(det0%k(n_stages,dim)) - det0%k = 0. - allocate(det0%update_vector(dim)) - det0%update_vector=0. - det0 => det0%next - end do - - end subroutine allocate_rk_guided_search - - subroutine deallocate_rk_guided_search(detector_list) - ! Deallocate the RK stages and update vector - type(detector_linked_list), intent(inout) :: detector_list - - type(detector_type), pointer :: det0 - integer :: j0 - - det0 => detector_list%first - do j0=1, detector_list%length - if(allocated(det0%k)) then - deallocate(det0%k) - end if - if(allocated(det0%update_vector)) then - deallocate(det0%update_vector) - end if - det0 => det0%next - end do - end subroutine deallocate_rk_guided_search - - subroutine set_stage(detector_list, vfield, dt0, stage0) - ! Compute the vector to search for in the next RK stage - ! If this is the last stage, update detector position - type(detector_linked_list), intent(inout) :: detector_list - type(vector_field), intent(in) :: vfield - real, intent(in) :: dt0 - integer, intent(in) :: stage0 - - type(rk_gs_parameters), pointer :: parameters - type(detector_type), pointer :: det0 - integer :: j0 - - parameters => detector_list%move_parameters - - det0 => detector_list%first - do while (associated(det0)) - - det0%search_complete = .false. - if(stage0.eq.1) then - det0%update_vector = det0%position - end if - - ! stage vector is computed by evaluating velocity at current position - det0%k(stage0,:)= eval_field(det0%element, vfield, det0%local_coords) - if(stage0 detector_list%first + do while (associated(det0)) + if(allocated(det0%k)) then + deallocate(det0%k) + end if + if(allocated(det0%update_vector)) then + deallocate(det0%update_vector) + end if + allocate(det0%k(n_stages,dim)) + det0%k = 0. + allocate(det0%update_vector(dim)) + det0%update_vector=0. + det0 => det0%next + end do + + end subroutine allocate_rk_guided_search + + subroutine deallocate_rk_guided_search(detector_list) + ! Deallocate the RK stages and update vector + type(detector_linked_list), intent(inout) :: detector_list + + type(detector_type), pointer :: det0 + integer :: j0 + + det0 => detector_list%first + do j0=1, detector_list%length + if(allocated(det0%k)) then + deallocate(det0%k) + end if + if(allocated(det0%update_vector)) then + deallocate(det0%update_vector) + end if + det0 => det0%next + end do + end subroutine deallocate_rk_guided_search + + subroutine set_stage(detector_list, vfield, dt0, stage0) + ! Compute the vector to search for in the next RK stage + ! If this is the last stage, update detector position + type(detector_linked_list), intent(inout) :: detector_list + type(vector_field), intent(in) :: vfield + real, intent(in) :: dt0 + integer, intent(in) :: stage0 + + type(rk_gs_parameters), pointer :: parameters + type(detector_type), pointer :: det0 + integer :: j0 + + parameters => detector_list%move_parameters + + det0 => detector_list%first + do while (associated(det0)) + + det0%search_complete = .false. + if(stage0.eq.1) then + det0%update_vector = det0%position + end if + + ! stage vector is computed by evaluating velocity at current position + det0%k(stage0,:)= eval_field(det0%element, vfield, det0%local_coords) + if(stage0 det0%next - end do - end subroutine set_stage - - - subroutine move_detectors_guided_search(detector_list,xfield,send_list_array,search_tolerance) - !Subroutine to find the element containing the update vector: - ! - Detectors leaving the computational domain are set to DELETE - ! - Detectors leaving the processor domain are added to the list - ! of detectors to communicate to the other processor. - ! This works by searching for the element containing the next point - ! in the RK through element faces. - ! This is done by computing the local coordinates of the target point, - ! finding the local coordinate closest to -infinity - ! and moving to the element through that face. - type(detector_linked_list), intent(inout) :: detector_list - type(detector_linked_list), dimension(:), intent(inout) :: send_list_array - type(vector_field), pointer, intent(in) :: xfield - real, intent(in) :: search_tolerance - - type(detector_type), pointer :: det0, det_send, det_next - real, dimension(mesh_dim(xfield)+1) :: arrival_local_coords - integer, dimension(:), pointer :: neigh_list - integer :: neigh, proc_local_number, deleted_detectors - logical :: make_delete - - deleted_detectors=0 - - !Loop over all the detectors - det0 => detector_list%first - do while (associated(det0)) - - !Only move Lagrangian detectors - if (.not.det0%search_complete) then - search_loop: do - - !Compute the local coordinates of the arrival point with respect to this element - arrival_local_coords=local_coords(xfield,det0%element,det0%update_vector) - if (minval(arrival_local_coords)>-search_tolerance) then - !the arrival point is in this element - det0%search_complete = .true. - !move on to the next detector - det0%local_coords = arrival_local_coords - det0 => det0%next - exit search_loop - end if - - !The arrival point is not in this element, try to get closer to it by - !searching in the coordinate direction in which it is furthest away - neigh = minval(minloc(arrival_local_coords)) - neigh_list=>ele_neigh(xfield,det0%element) - if (neigh_list(neigh)>0) then - !the neighbouring element is also on this domain - !so update the element and try again - det0%element = neigh_list(neigh) - else - !check if this element is owned (to decide where - !to send particles leaving the processor domain) - if (element_owned(xfield,det0%element)) then - !this face goes outside of the computational domain - !try all of the faces with negative local coordinate - !just in case we went through a corner - make_delete=.true. - face_search: do neigh = 1, size(arrival_local_coords) - if (arrival_local_coords(neigh)<-search_tolerance.and.neigh_list(neigh)>0) then - make_delete = .false. - det0%element = neigh_list(neigh) - exit face_search - end if - end do face_search - if (make_delete) then - ewrite(1,*) "WARNING: detector attempted to leave computational & - &domain; deleting detector, detector ID:", det0%id_number, "detector element:", det0%element - call remove(det0, detector_list) - deleted_detectors=deleted_detectors+1 - det_next => det0%next - call deallocate(det0) - det0 => det_next - det_next => null() - exit search_loop - end if - else - det_send => det0 - det0 => det0%next - !this face goes into another computational domain - proc_local_number=element_owner(xfield%mesh,det_send%element) - - call move(det_send, detector_list, send_list_array(proc_local_number)) - !move on to the next detector - exit search_loop - end if - end if - end do search_loop - else - !move on to the next detector - det0 => det0%next - end if - end do - call allsum(deleted_detectors) - detector_list%total_num_det = detector_list%total_num_det-deleted_detectors - end subroutine move_detectors_guided_search + end do + det0%position = det0%update_vector + end if + det0 => det0%next + end do + end subroutine set_stage + + + subroutine move_detectors_guided_search(detector_list,xfield,send_list_array,search_tolerance) + !Subroutine to find the element containing the update vector: + ! - Detectors leaving the computational domain are set to DELETE + ! - Detectors leaving the processor domain are added to the list + ! of detectors to communicate to the other processor. + ! This works by searching for the element containing the next point + ! in the RK through element faces. + ! This is done by computing the local coordinates of the target point, + ! finding the local coordinate closest to -infinity + ! and moving to the element through that face. + type(detector_linked_list), intent(inout) :: detector_list + type(detector_linked_list), dimension(:), intent(inout) :: send_list_array + type(vector_field), pointer, intent(in) :: xfield + real, intent(in) :: search_tolerance + + type(detector_type), pointer :: det0, det_send, det_next + real, dimension(mesh_dim(xfield)+1) :: arrival_local_coords + integer, dimension(:), pointer :: neigh_list + integer :: neigh, proc_local_number, deleted_detectors + logical :: make_delete + + deleted_detectors=0 + + !Loop over all the detectors + det0 => detector_list%first + do while (associated(det0)) + + !Only move Lagrangian detectors + if (.not.det0%search_complete) then + search_loop: do + + !Compute the local coordinates of the arrival point with respect to this element + arrival_local_coords=local_coords(xfield,det0%element,det0%update_vector) + if (minval(arrival_local_coords)>-search_tolerance) then + !the arrival point is in this element + det0%search_complete = .true. + !move on to the next detector + det0%local_coords = arrival_local_coords + det0 => det0%next + exit search_loop + end if + + !The arrival point is not in this element, try to get closer to it by + !searching in the coordinate direction in which it is furthest away + neigh = minval(minloc(arrival_local_coords)) + neigh_list=>ele_neigh(xfield,det0%element) + if (neigh_list(neigh)>0) then + !the neighbouring element is also on this domain + !so update the element and try again + det0%element = neigh_list(neigh) + else + !check if this element is owned (to decide where + !to send particles leaving the processor domain) + if (element_owned(xfield,det0%element)) then + !this face goes outside of the computational domain + !try all of the faces with negative local coordinate + !just in case we went through a corner + make_delete=.true. + face_search: do neigh = 1, size(arrival_local_coords) + if (arrival_local_coords(neigh)<-search_tolerance.and.neigh_list(neigh)>0) then + make_delete = .false. + det0%element = neigh_list(neigh) + exit face_search + end if + end do face_search + if (make_delete) then + ewrite(1,*) "WARNING: detector attempted to leave computational & + &domain; deleting detector, detector ID:", det0%id_number, "detector element:", det0%element + call remove(det0, detector_list) + deleted_detectors=deleted_detectors+1 + det_next => det0%next + call deallocate(det0) + det0 => det_next + det_next => null() + exit search_loop + end if + else + det_send => det0 + det0 => det0%next + !this face goes into another computational domain + proc_local_number=element_owner(xfield%mesh,det_send%element) + + call move(det_send, detector_list, send_list_array(proc_local_number)) + !move on to the next detector + exit search_loop + end if + end if + end do search_loop + else + !move on to the next detector + det0 => det0%next + end if + end do + call allsum(deleted_detectors) + detector_list%total_num_det = detector_list%total_num_det-deleted_detectors + end subroutine move_detectors_guided_search end module detector_move_lagrangian diff --git a/femtools/Detector_Parallel.F90 b/femtools/Detector_Parallel.F90 index bc43a3cb3d..fb03611709 100644 --- a/femtools/Detector_Parallel.F90 +++ b/femtools/Detector_Parallel.F90 @@ -28,497 +28,497 @@ #include "fdebug.h" module detector_parallel - use spud - use fldebug - use futils, only: int2str, present_and_true - use integer_hash_table_module - use mpi_interfaces - use elements - use parallel_tools - use parallel_fields - use fields - use state_module - use halos - use detector_data_types - use pickers - use detector_tools - - implicit none - - private - - public :: distribute_detectors, exchange_detectors, register_detector_list, & - get_num_detector_lists, get_registered_detector_lists, & - deallocate_detector_list_array, sync_detector_coordinates - - type(detector_list_ptr), dimension(:), allocatable, target, save :: detector_list_array - integer :: num_detector_lists = 0 - - type detector_buffer - !!< Container type for MPI data buffers - real, dimension(:,:), pointer :: ptr - end type detector_buffer + use spud + use fldebug + use futils, only: int2str, present_and_true + use integer_hash_table_module + use mpi_interfaces + use elements + use parallel_tools + use parallel_fields + use fields + use state_module + use halos + use detector_data_types + use pickers + use detector_tools + + implicit none + + private + + public :: distribute_detectors, exchange_detectors, register_detector_list, & + get_num_detector_lists, get_registered_detector_lists, & + deallocate_detector_list_array, sync_detector_coordinates + + type(detector_list_ptr), dimension(:), allocatable, target, save :: detector_list_array + integer :: num_detector_lists = 0 + + type detector_buffer + !!< Container type for MPI data buffers + real, dimension(:,:), pointer :: ptr + end type detector_buffer contains - subroutine register_detector_list(detector_list) - ! Register a detector list, so that adaptivity and Zoltan will distribute detectors on adapts - ! This adds a pointer to the given detector list to detector_list_array and assign detector list ID - type(detector_linked_list), target, intent(inout) :: detector_list - - type(detector_list_ptr), dimension(:), allocatable :: tmp_list_array - integer :: i, old_size - - ! Allocate a new detector list - if (allocated(detector_list_array)) then - old_size = size(detector_list_array) - allocate(tmp_list_array(old_size+1)) - do i=1, old_size - tmp_list_array(i)%ptr=>detector_list_array(i)%ptr - end do - deallocate(detector_list_array) - allocate(detector_list_array(old_size+1)) - do i=1, old_size - detector_list_array(i)%ptr=>tmp_list_array(i)%ptr - end do - detector_list_array(old_size+1)%ptr=>detector_list - else - ! Allocate and return first detector list - allocate(detector_list_array(1)) - detector_list_array(1)%ptr=>detector_list - end if - - ! Advance counter and assign list ID - num_detector_lists=num_detector_lists+1 - detector_list%id=num_detector_lists - - end subroutine register_detector_list - - subroutine get_registered_detector_lists(all_registered_lists) - ! Return a pointer to a lists of pointers to all registered detector lists - type(detector_list_ptr), dimension(:), pointer, intent(out) :: all_registered_lists - - all_registered_lists=>detector_list_array - end subroutine get_registered_detector_lists - - function get_num_detector_lists() - ! Return the number of registered detector lists - integer :: get_num_detector_lists - - get_num_detector_lists=num_detector_lists - end function get_num_detector_lists - - subroutine deallocate_detector_list_array() - type(detector_list_ptr), dimension(:), pointer :: detector_lists - integer :: i - - if (allocated(detector_list_array)) then - call get_registered_detector_lists(detector_lists) - do i=1, get_num_detector_lists() - call deallocate(detector_lists(i)%ptr) - end do - deallocate(detector_list_array) - num_detector_lists = 0 - end if - - end subroutine deallocate_detector_list_array - - subroutine distribute_detectors(state, detector_list, positions) - ! Loop over all the detectors in the list and check that I own the element they are in. - ! If not, they need to be sent to the processor owner before adaptivity happens - type(state_type), intent(in) :: state - type(detector_linked_list), intent(inout) :: detector_list - type(vector_field), optional, target, intent(in) :: positions - - type(detector_linked_list), dimension(:), allocatable :: send_list_array - type(detector_linked_list) :: detector_bcast_list, lost_detectors_list - type(detector_type), pointer :: detector, node_to_send, bcast_detector - type(vector_field), pointer :: xfield - integer :: i, k, nprocs, all_send_lists_empty, processor_owner, bcast_count, & - ierr, ndata_per_det, bcast_rounds, round, accept_detector - integer, dimension(:), allocatable :: ndets_being_bcast - real, allocatable :: send_buff(:), recv_buff(:) - type(element_type), pointer :: shape - - ewrite(2,*) "In distribute_detectors" - if (present(positions)) then - xfield => positions - else - xfield => extract_vector_field(state,"Coordinate") - end if - ! We allocate a point-to-point sendlist for every processor - nprocs=getnprocs() - if (nprocs==1) return - allocate(send_list_array(nprocs)) - bcast_count=0 - - detector => detector_list%first - do while (associated(detector)) - - if (detector%element>0) then - ! If we know the element get the owner and send point-to-point - processor_owner=element_owner(xfield%mesh,detector%element) - - if (processor_owner/= getprocno()) then - node_to_send => detector - detector => detector%next - - call move(node_to_send, detector_list, send_list_array(processor_owner)) - else - detector => detector%next - end if - else - ! If we dont know the element we will need to broadcast - ewrite(2,*) "Found non-local detector, triggering broadcast..." - bcast_count = bcast_count + 1 - - ! Move detector to broadcast detector list - bcast_detector => detector - detector => detector%next - call move(bcast_detector, detector_list, detector_bcast_list) - end if - end do - - ! Exchange detectors if there are any detectors to exchange - ! via the point-to-point sendlists - all_send_lists_empty=0 - do k=1, nprocs - if (send_list_array(k)%length/=0) then - all_send_lists_empty=1 - end if - end do - call allmax(all_send_lists_empty) - if (all_send_lists_empty/=0) then - call exchange_detectors(state,detector_list,send_list_array, positions) - end if - - ! Make sure send lists are empty and deallocate them - do k=1, nprocs - assert(send_list_array(k)%length==0) - end do - deallocate(send_list_array) - - ! Sanity check - detector => detector_list%first - do while (associated(detector)) - assert(element_owner(xfield%mesh,detector%element)==getprocno()) - detector=>detector%next - end do - - ! Find out how many unknown detectors each process wants to broadcast - allocate(ndets_being_bcast(getnprocs())) - call mpi_allgather(bcast_count, 1, getPINTEGER(), ndets_being_bcast, 1 , getPINTEGER(), MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - ! If there are no unknown detectors exit - if (all(ndets_being_bcast == 0)) then - return - else - ewrite(2,*) "Broadcast required, initialising..." - - ! If there are unknown detectors we need to broadcast. - ! Since we can not be sure whether any processor will accept a detector - ! we broadcast one at a time so we can make sure somebody accepted it. - ! If there are no takers we keep the detector with element -1, - ! becasue it has gone out of the domain, and this will be caught at a later stage. - bcast_rounds = maxval(ndets_being_bcast) - call allmax(bcast_rounds) - do round=1, bcast_rounds - ndata_per_det = detector_buffer_size(xfield%dim,.false., attribute_size=detector_list%total_attributes) - - ! Broadcast detectors whose new owner we can't identify - do i=1,getnprocs() - if (ndets_being_bcast(i) >= round) then - - if (i == getprocno() .and. bcast_count>=round) then - ! Allocate memory for the detector we're going to send - allocate(send_buff(ndata_per_det)) - - ! Pack the first detector from the bcast_list - detector=>detector_bcast_list%first - call pack_detector(detector, send_buff(1:ndata_per_det), xfield%dim, attribute_size_in=detector_list%total_attributes) - call delete(detector, detector_bcast_list) - - ! Broadcast the detectors you want to send - ewrite(2,*) "Broadcasting detector" - call mpi_bcast(send_buff,ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - ! This allmax matches the one below - accept_detector = 0 - call allmax(accept_detector) - - ! If we're the sender and nobody accepted the detector - ! we keep it, to deal with it later in the I/O routines - if (accept_detector == 0 .and. i == getprocno()) then - ewrite(2,*) "WARNING: Could not find processor for detector. Detector is probably outside the domain!" - - ! Unpack detector again and put in a temporary lost_detectors_list - shape=>ele_shape(xfield,1) - detector=>null() - call allocate(detector, xfield%dim, local_coord_count(shape), detector_list%total_attributes) - call unpack_detector(detector, send_buff(1:ndata_per_det), xfield%dim, attribute_size_in=detector_list%total_attributes) - call insert(detector, lost_detectors_list) - end if - - deallocate(send_buff) - else - ! Allocate memory to receive into - allocate(recv_buff(ndata_per_det)) - - ! Receive broadcast - ewrite(2,*) "Receiving detector from process ", i - call mpi_bcast(recv_buff,ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - ! Allocate and unpack the detector - shape=>ele_shape(xfield,1) - detector=>null() - call allocate(detector, xfield%dim, local_coord_count(shape),detector_list%total_attributes ) - call unpack_detector(detector, recv_buff(1:ndata_per_det), xfield%dim, attribute_size_in=detector_list%total_attributes) - - ! Try to find the detector position locally - call picker_inquire(xfield, detector%position, detector%element, detector%local_coords, global=.false.) - if (detector%element>0) then - ! We found a new home... - call insert(detector, detector_list) - accept_detector = 1 - ewrite(2,*) "Accepted detector" - else - call delete(detector) - accept_detector = 0 - ewrite(2,*) "Rejected detector" - end if - - ! This allmax matches the one above - call allmax(accept_detector) - deallocate(recv_buff) - end if - end if - end do - end do - - ! Now move the lost detectors into our list again - call move_all(lost_detectors_list, detector_list) - assert(lost_detectors_list%length==0) - end if - - ewrite(2,*) "Finished broadcast" - - end subroutine distribute_detectors - - subroutine exchange_detectors(state, detector_list, send_list_array, positions, & + subroutine register_detector_list(detector_list) + ! Register a detector list, so that adaptivity and Zoltan will distribute detectors on adapts + ! This adds a pointer to the given detector list to detector_list_array and assign detector list ID + type(detector_linked_list), target, intent(inout) :: detector_list + + type(detector_list_ptr), dimension(:), allocatable :: tmp_list_array + integer :: i, old_size + + ! Allocate a new detector list + if (allocated(detector_list_array)) then + old_size = size(detector_list_array) + allocate(tmp_list_array(old_size+1)) + do i=1, old_size + tmp_list_array(i)%ptr=>detector_list_array(i)%ptr + end do + deallocate(detector_list_array) + allocate(detector_list_array(old_size+1)) + do i=1, old_size + detector_list_array(i)%ptr=>tmp_list_array(i)%ptr + end do + detector_list_array(old_size+1)%ptr=>detector_list + else + ! Allocate and return first detector list + allocate(detector_list_array(1)) + detector_list_array(1)%ptr=>detector_list + end if + + ! Advance counter and assign list ID + num_detector_lists=num_detector_lists+1 + detector_list%id=num_detector_lists + + end subroutine register_detector_list + + subroutine get_registered_detector_lists(all_registered_lists) + ! Return a pointer to a lists of pointers to all registered detector lists + type(detector_list_ptr), dimension(:), pointer, intent(out) :: all_registered_lists + + all_registered_lists=>detector_list_array + end subroutine get_registered_detector_lists + + function get_num_detector_lists() + ! Return the number of registered detector lists + integer :: get_num_detector_lists + + get_num_detector_lists=num_detector_lists + end function get_num_detector_lists + + subroutine deallocate_detector_list_array() + type(detector_list_ptr), dimension(:), pointer :: detector_lists + integer :: i + + if (allocated(detector_list_array)) then + call get_registered_detector_lists(detector_lists) + do i=1, get_num_detector_lists() + call deallocate(detector_lists(i)%ptr) + end do + deallocate(detector_list_array) + num_detector_lists = 0 + end if + + end subroutine deallocate_detector_list_array + + subroutine distribute_detectors(state, detector_list, positions) + ! Loop over all the detectors in the list and check that I own the element they are in. + ! If not, they need to be sent to the processor owner before adaptivity happens + type(state_type), intent(in) :: state + type(detector_linked_list), intent(inout) :: detector_list + type(vector_field), optional, target, intent(in) :: positions + + type(detector_linked_list), dimension(:), allocatable :: send_list_array + type(detector_linked_list) :: detector_bcast_list, lost_detectors_list + type(detector_type), pointer :: detector, node_to_send, bcast_detector + type(vector_field), pointer :: xfield + integer :: i, k, nprocs, all_send_lists_empty, processor_owner, bcast_count, & + ierr, ndata_per_det, bcast_rounds, round, accept_detector + integer, dimension(:), allocatable :: ndets_being_bcast + real, allocatable :: send_buff(:), recv_buff(:) + type(element_type), pointer :: shape + + ewrite(2,*) "In distribute_detectors" + if (present(positions)) then + xfield => positions + else + xfield => extract_vector_field(state,"Coordinate") + end if + ! We allocate a point-to-point sendlist for every processor + nprocs=getnprocs() + if (nprocs==1) return + allocate(send_list_array(nprocs)) + bcast_count=0 + + detector => detector_list%first + do while (associated(detector)) + + if (detector%element>0) then + ! If we know the element get the owner and send point-to-point + processor_owner=element_owner(xfield%mesh,detector%element) + + if (processor_owner/= getprocno()) then + node_to_send => detector + detector => detector%next + + call move(node_to_send, detector_list, send_list_array(processor_owner)) + else + detector => detector%next + end if + else + ! If we dont know the element we will need to broadcast + ewrite(2,*) "Found non-local detector, triggering broadcast..." + bcast_count = bcast_count + 1 + + ! Move detector to broadcast detector list + bcast_detector => detector + detector => detector%next + call move(bcast_detector, detector_list, detector_bcast_list) + end if + end do + + ! Exchange detectors if there are any detectors to exchange + ! via the point-to-point sendlists + all_send_lists_empty=0 + do k=1, nprocs + if (send_list_array(k)%length/=0) then + all_send_lists_empty=1 + end if + end do + call allmax(all_send_lists_empty) + if (all_send_lists_empty/=0) then + call exchange_detectors(state,detector_list,send_list_array, positions) + end if + + ! Make sure send lists are empty and deallocate them + do k=1, nprocs + assert(send_list_array(k)%length==0) + end do + deallocate(send_list_array) + + ! Sanity check + detector => detector_list%first + do while (associated(detector)) + assert(element_owner(xfield%mesh,detector%element)==getprocno()) + detector=>detector%next + end do + + ! Find out how many unknown detectors each process wants to broadcast + allocate(ndets_being_bcast(getnprocs())) + call mpi_allgather(bcast_count, 1, getPINTEGER(), ndets_being_bcast, 1 , getPINTEGER(), MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + ! If there are no unknown detectors exit + if (all(ndets_being_bcast == 0)) then + return + else + ewrite(2,*) "Broadcast required, initialising..." + + ! If there are unknown detectors we need to broadcast. + ! Since we can not be sure whether any processor will accept a detector + ! we broadcast one at a time so we can make sure somebody accepted it. + ! If there are no takers we keep the detector with element -1, + ! becasue it has gone out of the domain, and this will be caught at a later stage. + bcast_rounds = maxval(ndets_being_bcast) + call allmax(bcast_rounds) + do round=1, bcast_rounds + ndata_per_det = detector_buffer_size(xfield%dim,.false., attribute_size=detector_list%total_attributes) + + ! Broadcast detectors whose new owner we can't identify + do i=1,getnprocs() + if (ndets_being_bcast(i) >= round) then + + if (i == getprocno() .and. bcast_count>=round) then + ! Allocate memory for the detector we're going to send + allocate(send_buff(ndata_per_det)) + + ! Pack the first detector from the bcast_list + detector=>detector_bcast_list%first + call pack_detector(detector, send_buff(1:ndata_per_det), xfield%dim, attribute_size_in=detector_list%total_attributes) + call delete(detector, detector_bcast_list) + + ! Broadcast the detectors you want to send + ewrite(2,*) "Broadcasting detector" + call mpi_bcast(send_buff,ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + ! This allmax matches the one below + accept_detector = 0 + call allmax(accept_detector) + + ! If we're the sender and nobody accepted the detector + ! we keep it, to deal with it later in the I/O routines + if (accept_detector == 0 .and. i == getprocno()) then + ewrite(2,*) "WARNING: Could not find processor for detector. Detector is probably outside the domain!" + + ! Unpack detector again and put in a temporary lost_detectors_list + shape=>ele_shape(xfield,1) + detector=>null() + call allocate(detector, xfield%dim, local_coord_count(shape), detector_list%total_attributes) + call unpack_detector(detector, send_buff(1:ndata_per_det), xfield%dim, attribute_size_in=detector_list%total_attributes) + call insert(detector, lost_detectors_list) + end if + + deallocate(send_buff) + else + ! Allocate memory to receive into + allocate(recv_buff(ndata_per_det)) + + ! Receive broadcast + ewrite(2,*) "Receiving detector from process ", i + call mpi_bcast(recv_buff,ndata_per_det, getPREAL(), i-1, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + ! Allocate and unpack the detector + shape=>ele_shape(xfield,1) + detector=>null() + call allocate(detector, xfield%dim, local_coord_count(shape),detector_list%total_attributes ) + call unpack_detector(detector, recv_buff(1:ndata_per_det), xfield%dim, attribute_size_in=detector_list%total_attributes) + + ! Try to find the detector position locally + call picker_inquire(xfield, detector%position, detector%element, detector%local_coords, global=.false.) + if (detector%element>0) then + ! We found a new home... + call insert(detector, detector_list) + accept_detector = 1 + ewrite(2,*) "Accepted detector" + else + call delete(detector) + accept_detector = 0 + ewrite(2,*) "Rejected detector" + end if + + ! This allmax matches the one above + call allmax(accept_detector) + deallocate(recv_buff) + end if + end if + end do + end do + + ! Now move the lost detectors into our list again + call move_all(lost_detectors_list, detector_list) + assert(lost_detectors_list%length==0) + end if + + ewrite(2,*) "Finished broadcast" + + end subroutine distribute_detectors + + subroutine exchange_detectors(state, detector_list, send_list_array, positions, & include_update_vector) - ! This subroutine serialises send_list_array, sends it, - ! receives serialised detectors from all procs and unpacks them. - type(state_type), intent(in) :: state - type(detector_linked_list), intent(inout) :: detector_list - ! the assumption is here that we only send detectors located in element that we know about - ! in the largest element halo - type(detector_linked_list), dimension(:), intent(inout) :: send_list_array - type(vector_field), optional, target, intent(in) :: positions - ! if present and true also exchange the detectors' update vector and k matrix - logical, intent(in), optional :: include_update_vector - - - type(detector_buffer), dimension(:), allocatable :: send_buffer, recv_buffer - type(detector_type), pointer :: detector, detector_received - type(vector_field), pointer :: xfield - type(halo_type), pointer :: ele_halo - type(integer_hash_table) :: ele_numbering_inverse - integer :: j, dim, count, n_stages, target_proc, receive_proc, & - det_size, ndet_to_send, ndet_received, & - halo_level, nprocs, IERROR - integer, parameter ::TAG=12 - integer, dimension(:), allocatable :: sendRequest, status - logical :: have_update_vector - - ewrite(2,*) "In exchange_detectors" - - ! We want a sendlist for every processor - nprocs=getnprocs() - assert(size(send_list_array)==nprocs) - - if (present(positions)) then - xfield => positions - else - xfield => extract_vector_field(state,"Coordinate") - end if - dim=xfield%dim - allocate( sendRequest(nprocs) ) - sendRequest = MPI_REQUEST_NULL - - ! Get the element halo - halo_level = element_halo_count(xfield%mesh) - if (halo_level /= 0) then - ele_halo => xfield%mesh%element_halos(halo_level) - else - ewrite(-1,*) "In exchange_detectors: No element halo found to translate detector%element" - FLAbort("Exchanging detectors requires halo_level > 0") - end if - - ! Get buffer size, depending on whether RK update vector and K matrix need sending - have_update_vector = present_and_true(include_update_vector) - if (have_update_vector) then - n_stages=detector_list%move_parameters%n_stages - det_size=detector_buffer_size(dim,have_update_vector,n_stages, attribute_size=detector_list%total_attributes) - else - det_size=detector_buffer_size(dim,have_update_vector, attribute_size=detector_list%total_attributes) - end if - - ! Send to all procs - allocate(send_buffer(nprocs)) - do target_proc=1, nprocs - ndet_to_send=send_list_array(target_proc)%length - ! if we don't know any elements owned by target_proc - we shouldn't have anything to send - if (halo_receive_count(ele_halo, target_proc)==0) then - ! check that this is the case - if (ndet_to_send>0) then - FLAbort('send_list_array should only send detectors to known elements.') + ! This subroutine serialises send_list_array, sends it, + ! receives serialised detectors from all procs and unpacks them. + type(state_type), intent(in) :: state + type(detector_linked_list), intent(inout) :: detector_list + ! the assumption is here that we only send detectors located in element that we know about + ! in the largest element halo + type(detector_linked_list), dimension(:), intent(inout) :: send_list_array + type(vector_field), optional, target, intent(in) :: positions + ! if present and true also exchange the detectors' update vector and k matrix + logical, intent(in), optional :: include_update_vector + + + type(detector_buffer), dimension(:), allocatable :: send_buffer, recv_buffer + type(detector_type), pointer :: detector, detector_received + type(vector_field), pointer :: xfield + type(halo_type), pointer :: ele_halo + type(integer_hash_table) :: ele_numbering_inverse + integer :: j, dim, count, n_stages, target_proc, receive_proc, & + det_size, ndet_to_send, ndet_received, & + halo_level, nprocs, IERROR + integer, parameter ::TAG=12 + integer, dimension(:), allocatable :: sendRequest, status + logical :: have_update_vector + + ewrite(2,*) "In exchange_detectors" + + ! We want a sendlist for every processor + nprocs=getnprocs() + assert(size(send_list_array)==nprocs) + + if (present(positions)) then + xfield => positions + else + xfield => extract_vector_field(state,"Coordinate") + end if + dim=xfield%dim + allocate( sendRequest(nprocs) ) + sendRequest = MPI_REQUEST_NULL + + ! Get the element halo + halo_level = element_halo_count(xfield%mesh) + if (halo_level /= 0) then + ele_halo => xfield%mesh%element_halos(halo_level) + else + ewrite(-1,*) "In exchange_detectors: No element halo found to translate detector%element" + FLAbort("Exchanging detectors requires halo_level > 0") + end if + + ! Get buffer size, depending on whether RK update vector and K matrix need sending + have_update_vector = present_and_true(include_update_vector) + if (have_update_vector) then + n_stages=detector_list%move_parameters%n_stages + det_size=detector_buffer_size(dim,have_update_vector,n_stages, attribute_size=detector_list%total_attributes) + else + det_size=detector_buffer_size(dim,have_update_vector, attribute_size=detector_list%total_attributes) + end if + + ! Send to all procs + allocate(send_buffer(nprocs)) + do target_proc=1, nprocs + ndet_to_send=send_list_array(target_proc)%length + ! if we don't know any elements owned by target_proc - we shouldn't have anything to send + if (halo_receive_count(ele_halo, target_proc)==0) then + ! check that this is the case + if (ndet_to_send>0) then + FLAbort('send_list_array should only send detectors to known elements.') + end if + cycle end if - cycle - end if - allocate(send_buffer(target_proc)%ptr(ndet_to_send,det_size)) + allocate(send_buffer(target_proc)%ptr(ndet_to_send,det_size)) - if (ndet_to_send>0) then - ewrite(2,*) " Sending", ndet_to_send, "detectors to process", target_proc - end if + if (ndet_to_send>0) then + ewrite(2,*) " Sending", ndet_to_send, "detectors to process", target_proc + end if - detector => send_list_array(target_proc)%first - if (ndet_to_send>0) then - j=1 - do while (associated(detector)) + detector => send_list_array(target_proc)%first + if (ndet_to_send>0) then + j=1 + do while (associated(detector)) - ! translate detector element to universal element - assert(detector%element>0) - detector%element = halo_universal_number(ele_halo, detector%element) + ! translate detector element to universal element + assert(detector%element>0) + detector%element = halo_universal_number(ele_halo, detector%element) - if (have_update_vector) then - call pack_detector(detector, send_buffer(target_proc)%ptr(j,1:det_size), dim, nstages=n_stages, & + if (have_update_vector) then + call pack_detector(detector, send_buffer(target_proc)%ptr(j,1:det_size), dim, nstages=n_stages, & attribute_size_in=detector_list%total_attributes) - else - call pack_detector(detector, send_buffer(target_proc)%ptr(j,1:det_size), dim, & + else + call pack_detector(detector, send_buffer(target_proc)%ptr(j,1:det_size), dim, & attribute_size_in=detector_list%total_attributes) - end if - - ! delete also advances detector - call delete(detector, send_list_array(target_proc)) - j = j+1 - end do - end if - - ! getprocno() returns the rank of the processor + 1, hence target_proc-1 - call MPI_ISEND(send_buffer(target_proc)%ptr,size(send_buffer(target_proc)%ptr(:,:)), & - & getpreal(), target_proc-1, TAG, MPI_COMM_FEMTOOLS, sendRequest(target_proc), IERROR) - assert(ierror == MPI_SUCCESS) - - end do - - allocate( status(MPI_STATUS_SIZE) ) - call get_universal_numbering_inverse(ele_halo, ele_numbering_inverse) - - ! Receive from all procs - allocate(recv_buffer(nprocs)) - do receive_proc=1, nprocs - ! this should predict whether to expect a message: - if (halo_send_count(ele_halo, receive_proc)==0) cycle - - call MPI_PROBE(receive_proc-1, TAG, MPI_COMM_FEMTOOLS, status(:), IERROR) - assert(ierror == MPI_SUCCESS) - - call MPI_GET_COUNT(status(:), getpreal(), count, IERROR) - assert(ierror == MPI_SUCCESS) - - ndet_received=count/det_size - allocate(recv_buffer(receive_proc)%ptr(ndet_received,det_size)) - - if (ndet_received>0) then - ewrite(2,*) " Receiving", ndet_received, "detectors from process", receive_proc - end if - - call MPI_Recv(recv_buffer(receive_proc)%ptr,count, getpreal(), status(MPI_SOURCE), TAG, MPI_COMM_FEMTOOLS, MPI_STATUS_IGNORE, IERROR) - assert(ierror == MPI_SUCCESS) - - do j=1, ndet_received - allocate(detector_received) - - ! Unpack routine uses ele_numbering_inverse to translate universal element - ! back to local detector element - if (have_update_vector) then - call unpack_detector(detector_received,recv_buffer(receive_proc)%ptr(j,1:det_size),dim, & - global_to_local=ele_numbering_inverse,coordinates=xfield,nstages=n_stages, & - attribute_size_in=detector_list%total_attributes) - else - call unpack_detector(detector_received,recv_buffer(receive_proc)%ptr(j,1:det_size),dim, & - global_to_local=ele_numbering_inverse,coordinates=xfield, & - attribute_size_in=detector_list%total_attributes) - end if - - call insert(detector_received, detector_list) - end do - end do - - call MPI_WAITALL(nprocs, sendRequest, MPI_STATUSES_IGNORE, IERROR) - assert(ierror == MPI_SUCCESS) - - ! Deallocate buffers after exchange - do target_proc=1, nprocs - if (halo_receive_count(ele_halo, target_proc)>0) then - deallocate(send_buffer(target_proc)%ptr) - end if - if (halo_send_count(ele_halo, target_proc)>0) then - deallocate(recv_buffer(target_proc)%ptr) - end if - end do - deallocate(send_buffer) - deallocate(recv_buffer) - - call deallocate(ele_numbering_inverse) - - ewrite(2,*) "Exiting exchange_detectors" - - end subroutine exchange_detectors - - subroutine sync_detector_coordinates(state, reinterpolate_all) - ! Re-synchronise the physical and local (parametric) coordinates - ! of all detectors detectors in all lists after mesh movement. - type(state_type), intent(in) :: state - ! if present and true, assume the local coordinates corresponds to the correct detector position - ! and reinterpolate the physical detector%position from the Coordinate field - ! if false (default), this is done only for those detector lists with the move_with_mesh option which - ! thereby automatically move with the mesh. For detectors in other lists we assume the _physical_ coordinates - ! are correct and we search which element they are located in and recompute the local coordinates - logical, optional, intent(in) :: reinterpolate_all - - type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() - type(vector_field), pointer :: coordinate_field => null() - type(detector_type), pointer :: detector - integer :: i - - ! Re-evaluate detector coordinates for every detector in all lists - if (get_num_detector_lists()>0) then - coordinate_field=>extract_vector_field(state,"Coordinate") - call get_registered_detector_lists(detector_list_array) - do i = 1, size(detector_list_array) - - ! In order to let detectors drift with the mesh - ! we update det%position from the parametric coordinates - if (present_and_true(reinterpolate_all) .or. detector_list_array(i)%ptr%move_with_mesh) then - detector=>detector_list_array(i)%ptr%first - do while (associated(detector)) - detector%position=detector_value(coordinate_field, detector) - detector=>detector%next - end do - ! By default update detector element and local_coords from position - else - ! local search first - call search_for_detectors(detector_list_array(i)%ptr, coordinate_field) - ! in parallel, change ownership and search those not found locally: - call distribute_detectors(state, detector_list_array(i)%ptr) - end if - end do - end if - - end subroutine sync_detector_coordinates + end if + + ! delete also advances detector + call delete(detector, send_list_array(target_proc)) + j = j+1 + end do + end if + + ! getprocno() returns the rank of the processor + 1, hence target_proc-1 + call MPI_ISEND(send_buffer(target_proc)%ptr,size(send_buffer(target_proc)%ptr(:,:)), & + & getpreal(), target_proc-1, TAG, MPI_COMM_FEMTOOLS, sendRequest(target_proc), IERROR) + assert(ierror == MPI_SUCCESS) + + end do + + allocate( status(MPI_STATUS_SIZE) ) + call get_universal_numbering_inverse(ele_halo, ele_numbering_inverse) + + ! Receive from all procs + allocate(recv_buffer(nprocs)) + do receive_proc=1, nprocs + ! this should predict whether to expect a message: + if (halo_send_count(ele_halo, receive_proc)==0) cycle + + call MPI_PROBE(receive_proc-1, TAG, MPI_COMM_FEMTOOLS, status(:), IERROR) + assert(ierror == MPI_SUCCESS) + + call MPI_GET_COUNT(status(:), getpreal(), count, IERROR) + assert(ierror == MPI_SUCCESS) + + ndet_received=count/det_size + allocate(recv_buffer(receive_proc)%ptr(ndet_received,det_size)) + + if (ndet_received>0) then + ewrite(2,*) " Receiving", ndet_received, "detectors from process", receive_proc + end if + + call MPI_Recv(recv_buffer(receive_proc)%ptr,count, getpreal(), status(MPI_SOURCE), TAG, MPI_COMM_FEMTOOLS, MPI_STATUS_IGNORE, IERROR) + assert(ierror == MPI_SUCCESS) + + do j=1, ndet_received + allocate(detector_received) + + ! Unpack routine uses ele_numbering_inverse to translate universal element + ! back to local detector element + if (have_update_vector) then + call unpack_detector(detector_received,recv_buffer(receive_proc)%ptr(j,1:det_size),dim, & + global_to_local=ele_numbering_inverse,coordinates=xfield,nstages=n_stages, & + attribute_size_in=detector_list%total_attributes) + else + call unpack_detector(detector_received,recv_buffer(receive_proc)%ptr(j,1:det_size),dim, & + global_to_local=ele_numbering_inverse,coordinates=xfield, & + attribute_size_in=detector_list%total_attributes) + end if + + call insert(detector_received, detector_list) + end do + end do + + call MPI_WAITALL(nprocs, sendRequest, MPI_STATUSES_IGNORE, IERROR) + assert(ierror == MPI_SUCCESS) + + ! Deallocate buffers after exchange + do target_proc=1, nprocs + if (halo_receive_count(ele_halo, target_proc)>0) then + deallocate(send_buffer(target_proc)%ptr) + end if + if (halo_send_count(ele_halo, target_proc)>0) then + deallocate(recv_buffer(target_proc)%ptr) + end if + end do + deallocate(send_buffer) + deallocate(recv_buffer) + + call deallocate(ele_numbering_inverse) + + ewrite(2,*) "Exiting exchange_detectors" + + end subroutine exchange_detectors + + subroutine sync_detector_coordinates(state, reinterpolate_all) + ! Re-synchronise the physical and local (parametric) coordinates + ! of all detectors detectors in all lists after mesh movement. + type(state_type), intent(in) :: state + ! if present and true, assume the local coordinates corresponds to the correct detector position + ! and reinterpolate the physical detector%position from the Coordinate field + ! if false (default), this is done only for those detector lists with the move_with_mesh option which + ! thereby automatically move with the mesh. For detectors in other lists we assume the _physical_ coordinates + ! are correct and we search which element they are located in and recompute the local coordinates + logical, optional, intent(in) :: reinterpolate_all + + type(detector_list_ptr), dimension(:), pointer :: detector_list_array => null() + type(vector_field), pointer :: coordinate_field => null() + type(detector_type), pointer :: detector + integer :: i + + ! Re-evaluate detector coordinates for every detector in all lists + if (get_num_detector_lists()>0) then + coordinate_field=>extract_vector_field(state,"Coordinate") + call get_registered_detector_lists(detector_list_array) + do i = 1, size(detector_list_array) + + ! In order to let detectors drift with the mesh + ! we update det%position from the parametric coordinates + if (present_and_true(reinterpolate_all) .or. detector_list_array(i)%ptr%move_with_mesh) then + detector=>detector_list_array(i)%ptr%first + do while (associated(detector)) + detector%position=detector_value(coordinate_field, detector) + detector=>detector%next + end do + ! By default update detector element and local_coords from position + else + ! local search first + call search_for_detectors(detector_list_array(i)%ptr, coordinate_field) + ! in parallel, change ownership and search those not found locally: + call distribute_detectors(state, detector_list_array(i)%ptr) + end if + end do + end if + + end subroutine sync_detector_coordinates end module detector_parallel diff --git a/femtools/Detector_Tools.F90 b/femtools/Detector_Tools.F90 index d02b265cd7..8d16f1ff50 100644 --- a/femtools/Detector_Tools.F90 +++ b/femtools/Detector_Tools.F90 @@ -28,1190 +28,1190 @@ #include "fdebug.h" module detector_tools - use spud - use fldebug - use iso_c_binding, only: C_NULL_CHAR - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str - use elements, only: local_coord_count - use embed_python - use integer_hash_table_module - use parallel_tools - use parallel_fields, only: element_owned - use transform_elements - use fields - use state_module, only: state_type, extract_scalar_field, aliased, & - & extract_vector_field, extract_tensor_field - use field_options - use detector_data_types - use pickers - - implicit none - - private - - public :: insert, allocate, deallocate, copy, move, move_all, remove, & - delete, delete_all, pack_detector, unpack_detector, & - detector_value, set_detector_coords_from_python, & - detector_buffer_size, set_particle_scalar_attribute_from_python, & - set_particle_scalar_attribute_from_python_fields, & - set_particle_vector_attribute_from_python, & - set_particle_vector_attribute_from_python_fields, & - set_particle_tensor_attribute_from_python, & - set_particle_tensor_attribute_from_python_fields, & - evaluate_particle_fields, temp_list_insert, & - temp_list_deallocate, temp_list_remove - - interface insert - module procedure insert_into_detector_list - end interface - - ! Removes detector from a list without deallocating it - interface remove - module procedure remove_detector_from_list - end interface - - ! Removes detector from a list and deallocates it - interface delete - module procedure delete_detector - end interface - - ! Deletes all detectors from a given list - interface delete_all - module procedure delete_all_detectors - end interface - - ! Move detector from one list to another - interface move - module procedure move_detector - end interface - - ! Move all detectors in a list from one that list to another - interface move_all - module procedure move_all_detectors - end interface - - interface copy - module procedure detector_copy - end interface - - interface allocate - module procedure detector_allocate_from_params, detector_allocate_from_detector - end interface - - interface deallocate - module procedure detector_deallocate, detector_list_deallocate - end interface - - ! Evaluate field at the location of the detector. - interface detector_value - module procedure detector_value_scalar, detector_value_vector - end interface + use spud + use fldebug + use iso_c_binding, only: C_NULL_CHAR + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str + use elements, only: local_coord_count + use embed_python + use integer_hash_table_module + use parallel_tools + use parallel_fields, only: element_owned + use transform_elements + use fields + use state_module, only: state_type, extract_scalar_field, aliased, & + & extract_vector_field, extract_tensor_field + use field_options + use detector_data_types + use pickers + + implicit none + + private + + public :: insert, allocate, deallocate, copy, move, move_all, remove, & + delete, delete_all, pack_detector, unpack_detector, & + detector_value, set_detector_coords_from_python, & + detector_buffer_size, set_particle_scalar_attribute_from_python, & + set_particle_scalar_attribute_from_python_fields, & + set_particle_vector_attribute_from_python, & + set_particle_vector_attribute_from_python_fields, & + set_particle_tensor_attribute_from_python, & + set_particle_tensor_attribute_from_python_fields, & + evaluate_particle_fields, temp_list_insert, & + temp_list_deallocate, temp_list_remove + + interface insert + module procedure insert_into_detector_list + end interface + + ! Removes detector from a list without deallocating it + interface remove + module procedure remove_detector_from_list + end interface + + ! Removes detector from a list and deallocates it + interface delete + module procedure delete_detector + end interface + + ! Deletes all detectors from a given list + interface delete_all + module procedure delete_all_detectors + end interface + + ! Move detector from one list to another + interface move + module procedure move_detector + end interface + + ! Move all detectors in a list from one that list to another + interface move_all + module procedure move_all_detectors + end interface + + interface copy + module procedure detector_copy + end interface + + interface allocate + module procedure detector_allocate_from_params, detector_allocate_from_detector + end interface + + interface deallocate + module procedure detector_deallocate, detector_list_deallocate + end interface + + ! Evaluate field at the location of the detector. + interface detector_value + module procedure detector_value_scalar, detector_value_vector + end interface contains - subroutine detector_allocate_from_params(new_detector, ndims, local_coord_count, attribute_size) - type(detector_type), pointer, intent(out) :: new_detector - integer, intent(in) :: ndims, local_coord_count - integer, dimension(3), optional, intent(in) :: attribute_size !array to hold size of attributes - - assert(.not. associated(new_detector)) - - ! allocate the memory for the new detector - if (.not. associated(new_detector)) then - allocate(new_detector) - end if - allocate(new_detector%position(ndims)) - allocate(new_detector%local_coords(local_coord_count)) - if (present(attribute_size)) then - allocate(new_detector%attributes(attribute_size(1))) - allocate(new_detector%old_attributes(attribute_size(2))) - allocate(new_detector%old_fields(attribute_size(3))) - else - ! match the behaviour of create_single_detector, with empty attribute arrays - allocate(new_detector%attributes(0)) - allocate(new_detector%old_attributes(0)) - allocate(new_detector%old_fields(0)) - end if - - assert(associated(new_detector)) - - end subroutine detector_allocate_from_params - - subroutine detector_allocate_from_detector(new_detector, old_detector) - type(detector_type), pointer, intent(in) :: old_detector - type(detector_type), pointer, intent(out) :: new_detector - - integer :: ndims, local_coord_count - integer, dimension(3) :: attribute_size !array to hold size of attributes - - ndims = size(old_detector%position) - local_coord_count = size(old_detector%local_coords) - attribute_size(1) = size(old_detector%attributes) - attribute_size(2) = size(old_detector%old_attributes) - attribute_size(3) = size(old_detector%old_fields) - - ! allocate the memory for the new detector - call detector_allocate_from_params(new_detector, ndims, local_coord_count, attribute_size) - - end subroutine detector_allocate_from_detector - - subroutine detector_deallocate(detector) - type(detector_type), pointer :: detector - - if(associated(detector)) then - if(allocated(detector%local_coords)) then - deallocate(detector%local_coords) - end if - if(allocated(detector%position)) then - deallocate(detector%position) - end if - if(allocated(detector%k)) then - deallocate(detector%k) - end if - if(allocated(detector%update_vector)) then - deallocate(detector%update_vector) - end if - if(allocated(detector%attributes)) then - deallocate(detector%attributes) - end if - if(allocated(detector%old_attributes)) then - deallocate(detector%old_attributes) - end if - if(allocated(detector%old_fields)) then - deallocate(detector%old_fields) - end if - detector%next => null() - detector%previous => null() - detector%temp_next => null() - detector%temp_previous => null() - deallocate(detector) - end if - detector => null() - - end subroutine detector_deallocate - - subroutine detector_list_deallocate(detector_list) - type(detector_linked_list), pointer :: detector_list - - type(rk_gs_parameters), pointer :: parameters - - ! Delete detectors - if (detector_list%length > 0) then - call delete_all(detector_list) - end if - - ! Deallocate list information - if (allocated(detector_list%sfield_list)) then - deallocate(detector_list%sfield_list) - end if - if (allocated(detector_list%vfield_list)) then - deallocate(detector_list%vfield_list) - end if - - ! Deallocate move_parameters - parameters => detector_list%move_parameters - if (associated(parameters)) then - if (allocated(parameters%timestep_weights)) then - deallocate(parameters%timestep_weights) - end if - if (allocated(parameters%stage_matrix)) then - deallocate(parameters%stage_matrix) - end if - end if - - end subroutine detector_list_deallocate - - subroutine temp_list_deallocate(detector_list) - ! Removes all detectors from the temporary list - - type(detector_linked_list), pointer :: detector_list - type(detector_type), pointer :: detector - type(detector_type), pointer :: temp_detector - - if (detector_list%length==0) return - - detector => detector_list%first - do while (associated(detector)) - temp_detector => detector - detector => detector%temp_next - call temp_list_remove(temp_detector, detector_list) - end do - - end subroutine temp_list_deallocate - - subroutine detector_copy(new_detector, old_detector) - ! Copies all the information from the old detector to - ! the new detector - type(detector_type), pointer, intent(in) :: old_detector - type(detector_type), pointer :: new_detector - - new_detector%position = old_detector%position - new_detector%element = old_detector%element - new_detector%id_number = old_detector%id_number - new_detector%local_coords=old_detector%local_coords - - end subroutine detector_copy - - subroutine insert_into_detector_list(detector, current_list) - ! Inserts detector at the end of a list - type(detector_linked_list), intent(inout) :: current_list - type(detector_type), pointer :: detector - - if (current_list%length == 0) then - current_list%first => detector - current_list%last => detector - current_list%first%previous => null() - current_list%last%next => null() - current_list%length = 1 - else - detector%previous => current_list%last - current_list%last%next => detector - current_list%last => detector - current_list%last%next => null() - current_list%length = current_list%length+1 - end if - - end subroutine insert_into_detector_list - - subroutine temp_list_insert(detector, current_list) - ! Inserts detector at the end of a temporary detector list - ! i.e. a list of detectors that is linked via the temp_next - ! and temp_previous pointers - type(detector_linked_list), intent(inout) :: current_list - type(detector_type), pointer :: detector - - if (current_list%length == 0) then - current_list%first => detector - current_list%last => detector - current_list%first%temp_previous => null() - current_list%last%temp_next => null() - current_list%length = 1 - else - detector%temp_previous => current_list%last - current_list%last%temp_next => detector - current_list%last => detector - current_list%last%temp_next => null() - current_list%length = current_list%length+1 - end if - - end subroutine temp_list_insert - - subroutine remove_detector_from_list(detector, detector_list) - !! Removes the detector from the list, - !! but does not deallocated it - type(detector_linked_list), intent(inout) :: detector_list - type(detector_type), pointer :: detector - - if (detector_list%length==1) then - detector_list%first => null() - detector_list%last => null() - else - if (associated(detector%previous)) then - detector%previous%next => detector%next - else - detector_list%first => detector%next - end if - - if (associated(detector%next)) then - detector%next%previous => detector%previous - else - detector_list%last => detector%previous - end if - end if - - detector_list%length = detector_list%length-1 - - end subroutine remove_detector_from_list - - subroutine temp_list_remove(detector, detector_list) - !! Removes the detector from the temporary detector list, - !! but does not deallocated it - type(detector_linked_list), intent(inout) :: detector_list - type(detector_type), pointer :: detector - - if (detector_list%length==1) then - detector_list%first => null() - detector_list%last => null() - else - if (associated(detector%temp_previous)) then - detector%temp_previous%temp_next => detector%temp_next - else - detector_list%first => detector%temp_next - end if - - if (associated(detector%temp_next)) then - detector%temp_next%temp_previous => detector%temp_previous - else - detector_list%last => detector%temp_previous - end if - end if - detector_list%length = detector_list%length-1 - - end subroutine temp_list_remove - - subroutine delete_detector(detector, detector_list) - ! Removes and deallocates the given detector - ! and outputs the next detector in the list as detector - type(detector_type), pointer :: detector - type(detector_linked_list), intent(inout), optional :: detector_list - - type(detector_type), pointer :: temp_detector - - if (present(detector_list)) then - temp_detector => detector - detector => detector%next - call remove(temp_detector, detector_list) - call deallocate(temp_detector) - else - call deallocate(detector) - end if - - end subroutine delete_detector - - subroutine move_detector(detector, from_list, to_list) - ! Move detector from one list to the other - type(detector_linked_list), intent(inout) :: from_list - type(detector_type), pointer :: detector - type(detector_linked_list), intent(inout) :: to_list - - call remove(detector, from_list) - call insert(detector, to_list) - - end subroutine move_detector - - subroutine move_all_detectors(from_list,to_list) - ! Move all detectors from one list to the other - type(detector_linked_list), intent(inout) :: from_list - type(detector_linked_list), intent(inout) :: to_list - type(detector_type), pointer :: detector - - do while (associated(from_list%first)) - detector => from_list%first - call move(detector, from_list, to_list) - end do - - end subroutine move_all_detectors - - subroutine delete_all_detectors(detector_list) - ! Remove and deallocate all detectors in a list - type(detector_linked_list), intent(inout) :: detector_list - type(detector_type), pointer :: detector - - detector => detector_list%first - do while (associated(detector)) - call delete(detector,detector_list) - end do - - end subroutine delete_all_detectors - - function detector_buffer_size(ndims, have_update_vector, nstages, attribute_size) - ! Returns the number of reals we need to pack a detector - integer, intent(in) :: ndims - logical, intent(in) :: have_update_vector - integer, intent(in), optional :: nstages - integer :: detector_buffer_size, det_params - integer, dimension(3), optional, intent(in) :: attribute_size !array to hold size of attributes - - det_params = 3 !size of basic detector fields: detector element, id_number and proc_id - - ! common to everything is a position + basic fields - detector_buffer_size = ndims + det_params - - if (present(attribute_size)) then - detector_buffer_size = detector_buffer_size + sum(attribute_size) - end if - - if (have_update_vector) then - ! update vector adds ndims + nstages*ndims - detector_buffer_size = detector_buffer_size + (nstages + 1)*ndims - else - ! otherwise, there's a list id - detector_buffer_size = detector_buffer_size + 1 - end if - - end function detector_buffer_size - - subroutine pack_detector(detector,buff,ndims,nstages, attribute_size_in) - ! Packs (serialises) detector into buff - ! Basic fields are: element, position, id_number and type - ! If nstages is given, the detector is still moving - ! and we also pack update_vector and k - type(detector_type), pointer, intent(in) :: detector - real, dimension(:), intent(out) :: buff - integer, intent(in) :: ndims - integer, intent(in), optional :: nstages - integer, dimension(3), optional, intent(in) :: attribute_size_in - - integer :: det_params, buf_pos - integer, dimension(3) :: attribute_size - - assert(size(detector%position) == ndims) - - !Set size of basic detector fields: detector element, id_number, proc_id - det_params = 3 - attribute_size(:) = 0 - - if (present(attribute_size_in)) then - attribute_size = attribute_size_in - end if - - ! ensure buffer is big enough to receive this detector - assert(size(buff) >= ndims + det_params + sum(attribute_size)) - - ! Basic fields: ndims+det_params - buff(1:ndims) = detector%position - buff(ndims+1) = detector%element - buff(ndims+2) = detector%id_number - buff(ndims+3) = detector%proc_id - - buf_pos = ndims + det_params - - if (attribute_size(1) /= 0) then - buff(buf_pos + 1:buf_pos + attribute_size(1)) = detector%attributes - buf_pos = buf_pos + attribute_size(1) - end if - if (attribute_size(2) /= 0) then - buff(buf_pos + 1:buf_pos + attribute_size(2)) = detector%old_attributes - buf_pos = buf_pos + attribute_size(2) - end if - if (attribute_size(3) /= 0) then - buff(buf_pos + 1:buf_pos + attribute_size(3)) = detector%old_fields - buf_pos = buf_pos + attribute_size(3) - end if - - ! Lagrangian advection fields: (nstages+1)*ndims - if (present(nstages)) then - assert(size(buff) == (nstages+2)*ndims + det_params + sum(attribute_size)) - assert(allocated(detector%update_vector)) - assert(allocated(detector%k)) - - buff(buf_pos + 1:buf_pos + ndims) = detector%update_vector - buf_pos = buf_pos + ndims - - buff(buf_pos + 1:buf_pos + nstages*ndims) = reshape(detector%k, (/nstages*ndims/)) - else - assert(size(buff) == ndims + det_params + sum(attribute_size) + 1) - buff(buf_pos + 1) = detector%list_id - end if - end subroutine pack_detector - - subroutine unpack_detector(detector,buff,ndims,global_to_local,coordinates,nstages,attribute_size_in) - ! Unpacks the detector from buff and fills in the blanks - type(detector_type), pointer :: detector - real, dimension(:), intent(in) :: buff - integer, intent(in) :: ndims - type(integer_hash_table), intent(in), optional :: global_to_local - type(vector_field), intent(in), optional :: coordinates - integer, intent(in), optional :: nstages - integer, dimension(3), optional, intent(in) :: attribute_size_in - - integer :: det_params, buf_pos - integer, dimension(3) :: attribute_size - !Set size of basic detector fields, being detector element, id_number - det_params = 3 - attribute_size(:) = 0 - - ! we default to assuming there are no attributes, - ! but this can be overridden by the caller - if (present(attribute_size_in)) then - attribute_size = attribute_size_in - end if - - ! allocate some arrays that we might not have - ! set up beforehand - if (.not. allocated(detector%position)) then - allocate(detector%position(ndims)) - end if - - if (.not. allocated(detector%attributes)) then - allocate(detector%attributes(attribute_size(1))) - allocate(detector%old_attributes(attribute_size(2))) - allocate(detector%old_fields(attribute_size(3))) - end if - - ! Basic fields: ndims+4 - detector%position = buff(1:ndims) - detector%element = buff(ndims+1) - detector%id_number = buff(ndims+2) - detector%proc_id = buff(ndims+3) - - buf_pos = ndims + det_params - - ! unpack attributes if necessary - if (attribute_size(1) /= 0) then - detector%attributes = buff(buf_pos + 1:buf_pos + attribute_size(1)) - buf_pos = buf_pos + attribute_size(1) - end if - if (attribute_size(2) /= 0) then - detector%old_attributes = buff(buf_pos + 1:buf_pos + attribute_size(2)) - buf_pos = buf_pos + attribute_size(2) - end if - if (attribute_size(3) /= 0) then - detector%old_fields = buff(buf_pos + 1:buf_pos + attribute_size(3)) - buf_pos = buf_pos + attribute_size(3) - end if - - ! Reconstruct element number if global-to-local mapping is given - if (present(global_to_local)) then - assert(has_key(global_to_local, detector%element)) - detector%element=fetch(global_to_local,detector%element) - - ! Update local coordinates if coordinate field is given - if (present(coordinates)) then - if (.not. allocated(detector%local_coords)) then - allocate(detector%local_coords(local_coord_count(ele_shape(coordinates,1)))) - end if - detector%local_coords=local_coords(coordinates,detector%element,detector%position) - end if - end if - - ! Lagrangian advection fields: (nstages+1)*ndims - if (present(nstages)) then - assert(size(buff) == (nstages+2)*ndims + det_params + sum(attribute_size)) - - ! update_vector, dimension(ndim) - if (.not. allocated(detector%update_vector)) then - allocate(detector%update_vector(ndims)) - end if - detector%update_vector = buff(buf_pos + 1:buf_pos + ndims) - buf_pos = buf_pos + ndims - - ! k, dimension(nstages:ndim) - if (.not. allocated(detector%k)) then - allocate(detector%k(nstages,ndims)) - end if - detector%k = reshape(buff(buf_pos + 1:buf_pos + nstages*ndims), & - (/nstages,ndims/)) - - ! If update_vector still exists, we're not done moving - detector%search_complete=.false. - else - assert(size(buff) == ndims + det_params + sum(attribute_size) + 1) - - detector%list_id = buff(buf_pos + 1) - detector%search_complete = .true. - end if - - end subroutine unpack_detector - - function detector_value_scalar(sfield, detector) result(value) - !!< Evaluate field at the location of the detector. - real :: value - type(scalar_field), intent(in) :: sfield - type(detector_type), intent(in) :: detector - - assert(detector%element>0) - value = eval_field(detector%element, sfield, detector%local_coords) - - end function detector_value_scalar - - function detector_value_vector(vfield, detector) result(value) - !!< Evaluate field at the location of the detector. - type(vector_field), intent(in) :: vfield - type(detector_type), intent(in) :: detector - real, dimension(vfield%dim) :: value - - assert(detector%element>0) - value = eval_field(detector%element, vfield, detector%local_coords) - - end function detector_value_vector - - subroutine set_detector_coords_from_python(values, ndete, func, time) - !!< Given a list of positions and a time, evaluate the python function - !!< specified in the string func at those points. - real, dimension(:,:), target, intent(inout) :: values - !! Func may contain any python at all but the following function must - !! be defined: - !! def val(t) - !! where t is the time. The result must be a float. - character(len=*), intent(in) :: func - real :: time - - real, dimension(:), pointer :: lvx,lvy,lvz - real, dimension(0), target :: zero - integer :: stat, dim, ndete - - call get_option("/geometry/dimension",dim) - - lvx=>values(1,:) - lvy=>zero - lvz=>zero - if(dim>1) then - lvy=>values(2,:) - if(dim>2) then - lvz => values(3,:) - end if - end if - - call set_detectors_from_python(func, len(func), dim, & - ndete, time, dim, & - lvx, lvy, lvz, stat) + subroutine detector_allocate_from_params(new_detector, ndims, local_coord_count, attribute_size) + type(detector_type), pointer, intent(out) :: new_detector + integer, intent(in) :: ndims, local_coord_count + integer, dimension(3), optional, intent(in) :: attribute_size !array to hold size of attributes + + assert(.not. associated(new_detector)) + + ! allocate the memory for the new detector + if (.not. associated(new_detector)) then + allocate(new_detector) + end if + allocate(new_detector%position(ndims)) + allocate(new_detector%local_coords(local_coord_count)) + if (present(attribute_size)) then + allocate(new_detector%attributes(attribute_size(1))) + allocate(new_detector%old_attributes(attribute_size(2))) + allocate(new_detector%old_fields(attribute_size(3))) + else + ! match the behaviour of create_single_detector, with empty attribute arrays + allocate(new_detector%attributes(0)) + allocate(new_detector%old_attributes(0)) + allocate(new_detector%old_fields(0)) + end if + + assert(associated(new_detector)) + + end subroutine detector_allocate_from_params + + subroutine detector_allocate_from_detector(new_detector, old_detector) + type(detector_type), pointer, intent(in) :: old_detector + type(detector_type), pointer, intent(out) :: new_detector + + integer :: ndims, local_coord_count + integer, dimension(3) :: attribute_size !array to hold size of attributes + + ndims = size(old_detector%position) + local_coord_count = size(old_detector%local_coords) + attribute_size(1) = size(old_detector%attributes) + attribute_size(2) = size(old_detector%old_attributes) + attribute_size(3) = size(old_detector%old_fields) + + ! allocate the memory for the new detector + call detector_allocate_from_params(new_detector, ndims, local_coord_count, attribute_size) + + end subroutine detector_allocate_from_detector + + subroutine detector_deallocate(detector) + type(detector_type), pointer :: detector + + if(associated(detector)) then + if(allocated(detector%local_coords)) then + deallocate(detector%local_coords) + end if + if(allocated(detector%position)) then + deallocate(detector%position) + end if + if(allocated(detector%k)) then + deallocate(detector%k) + end if + if(allocated(detector%update_vector)) then + deallocate(detector%update_vector) + end if + if(allocated(detector%attributes)) then + deallocate(detector%attributes) + end if + if(allocated(detector%old_attributes)) then + deallocate(detector%old_attributes) + end if + if(allocated(detector%old_fields)) then + deallocate(detector%old_fields) + end if + detector%next => null() + detector%previous => null() + detector%temp_next => null() + detector%temp_previous => null() + deallocate(detector) + end if + detector => null() + + end subroutine detector_deallocate + + subroutine detector_list_deallocate(detector_list) + type(detector_linked_list), pointer :: detector_list + + type(rk_gs_parameters), pointer :: parameters + + ! Delete detectors + if (detector_list%length > 0) then + call delete_all(detector_list) + end if + + ! Deallocate list information + if (allocated(detector_list%sfield_list)) then + deallocate(detector_list%sfield_list) + end if + if (allocated(detector_list%vfield_list)) then + deallocate(detector_list%vfield_list) + end if + + ! Deallocate move_parameters + parameters => detector_list%move_parameters + if (associated(parameters)) then + if (allocated(parameters%timestep_weights)) then + deallocate(parameters%timestep_weights) + end if + if (allocated(parameters%stage_matrix)) then + deallocate(parameters%stage_matrix) + end if + end if + + end subroutine detector_list_deallocate + + subroutine temp_list_deallocate(detector_list) + ! Removes all detectors from the temporary list + + type(detector_linked_list), pointer :: detector_list + type(detector_type), pointer :: detector + type(detector_type), pointer :: temp_detector + + if (detector_list%length==0) return + + detector => detector_list%first + do while (associated(detector)) + temp_detector => detector + detector => detector%temp_next + call temp_list_remove(temp_detector, detector_list) + end do - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - - end subroutine set_detector_coords_from_python - - !> Evaluate a set of fields on particles - subroutine evaluate_particle_fields(npart, state, ele, lcoords, names, phases, counts, vals, dim) - !! Number of particles - integer, intent(in) :: npart - !! Model state structure - type(state_type), dimension(:), intent(in) :: state - !! Elements containing particles - integer, dimension(:), intent(in) :: ele - !! Local coordinates of particles in elements - real, dimension(:,:), intent(in) :: lcoords - !! Names of fields to be evaluated - type(attr_names_type), intent(in) :: names - !! Phases of each field - type(field_phase_type), intent(in) :: phases - !! Scalar/vector/tensor counts of each field - integer, dimension(3), intent(in) :: counts - !! Output array - real, dimension(:,:), intent(out) :: vals - !! Geometric dimension - integer, intent(in) :: dim - - integer :: i, j - integer :: field_idx, phase - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - - field_idx = 1 - - ! scalar fields - do i = 1, counts(1) - phase = phases%s(i) - sfield => extract_scalar_field(state(phase), names%s(i)) - - do j = 1, npart - vals(field_idx,j) = eval_field(ele(j), sfield, lcoords(:,j)) + end subroutine temp_list_deallocate + + subroutine detector_copy(new_detector, old_detector) + ! Copies all the information from the old detector to + ! the new detector + type(detector_type), pointer, intent(in) :: old_detector + type(detector_type), pointer :: new_detector + + new_detector%position = old_detector%position + new_detector%element = old_detector%element + new_detector%id_number = old_detector%id_number + new_detector%local_coords=old_detector%local_coords + + end subroutine detector_copy + + subroutine insert_into_detector_list(detector, current_list) + ! Inserts detector at the end of a list + type(detector_linked_list), intent(inout) :: current_list + type(detector_type), pointer :: detector + + if (current_list%length == 0) then + current_list%first => detector + current_list%last => detector + current_list%first%previous => null() + current_list%last%next => null() + current_list%length = 1 + else + detector%previous => current_list%last + current_list%last%next => detector + current_list%last => detector + current_list%last%next => null() + current_list%length = current_list%length+1 + end if + + end subroutine insert_into_detector_list + + subroutine temp_list_insert(detector, current_list) + ! Inserts detector at the end of a temporary detector list + ! i.e. a list of detectors that is linked via the temp_next + ! and temp_previous pointers + type(detector_linked_list), intent(inout) :: current_list + type(detector_type), pointer :: detector + + if (current_list%length == 0) then + current_list%first => detector + current_list%last => detector + current_list%first%temp_previous => null() + current_list%last%temp_next => null() + current_list%length = 1 + else + detector%temp_previous => current_list%last + current_list%last%temp_next => detector + current_list%last => detector + current_list%last%temp_next => null() + current_list%length = current_list%length+1 + end if + + end subroutine temp_list_insert + + subroutine remove_detector_from_list(detector, detector_list) + !! Removes the detector from the list, + !! but does not deallocated it + type(detector_linked_list), intent(inout) :: detector_list + type(detector_type), pointer :: detector + + if (detector_list%length==1) then + detector_list%first => null() + detector_list%last => null() + else + if (associated(detector%previous)) then + detector%previous%next => detector%next + else + detector_list%first => detector%next + end if + + if (associated(detector%next)) then + detector%next%previous => detector%previous + else + detector_list%last => detector%previous + end if + end if + + detector_list%length = detector_list%length-1 + + end subroutine remove_detector_from_list + + subroutine temp_list_remove(detector, detector_list) + !! Removes the detector from the temporary detector list, + !! but does not deallocated it + type(detector_linked_list), intent(inout) :: detector_list + type(detector_type), pointer :: detector + + if (detector_list%length==1) then + detector_list%first => null() + detector_list%last => null() + else + if (associated(detector%temp_previous)) then + detector%temp_previous%temp_next => detector%temp_next + else + detector_list%first => detector%temp_next + end if + + if (associated(detector%temp_next)) then + detector%temp_next%temp_previous => detector%temp_previous + else + detector_list%last => detector%temp_previous + end if + end if + detector_list%length = detector_list%length-1 + + end subroutine temp_list_remove + + subroutine delete_detector(detector, detector_list) + ! Removes and deallocates the given detector + ! and outputs the next detector in the list as detector + type(detector_type), pointer :: detector + type(detector_linked_list), intent(inout), optional :: detector_list + + type(detector_type), pointer :: temp_detector + + if (present(detector_list)) then + temp_detector => detector + detector => detector%next + call remove(temp_detector, detector_list) + call deallocate(temp_detector) + else + call deallocate(detector) + end if + + end subroutine delete_detector + + subroutine move_detector(detector, from_list, to_list) + ! Move detector from one list to the other + type(detector_linked_list), intent(inout) :: from_list + type(detector_type), pointer :: detector + type(detector_linked_list), intent(inout) :: to_list + + call remove(detector, from_list) + call insert(detector, to_list) + + end subroutine move_detector + + subroutine move_all_detectors(from_list,to_list) + ! Move all detectors from one list to the other + type(detector_linked_list), intent(inout) :: from_list + type(detector_linked_list), intent(inout) :: to_list + type(detector_type), pointer :: detector + + do while (associated(from_list%first)) + detector => from_list%first + call move(detector, from_list, to_list) end do - field_idx = field_idx + 1 - end do + end subroutine move_all_detectors + + subroutine delete_all_detectors(detector_list) + ! Remove and deallocate all detectors in a list + type(detector_linked_list), intent(inout) :: detector_list + type(detector_type), pointer :: detector + + detector => detector_list%first + do while (associated(detector)) + call delete(detector,detector_list) + end do - ! vector fields - do i = 1, counts(2) - phase = phases%v(i) - vfield => extract_vector_field(state(phase), names%v(i)) + end subroutine delete_all_detectors + + function detector_buffer_size(ndims, have_update_vector, nstages, attribute_size) + ! Returns the number of reals we need to pack a detector + integer, intent(in) :: ndims + logical, intent(in) :: have_update_vector + integer, intent(in), optional :: nstages + integer :: detector_buffer_size, det_params + integer, dimension(3), optional, intent(in) :: attribute_size !array to hold size of attributes + + det_params = 3 !size of basic detector fields: detector element, id_number and proc_id + + ! common to everything is a position + basic fields + detector_buffer_size = ndims + det_params + + if (present(attribute_size)) then + detector_buffer_size = detector_buffer_size + sum(attribute_size) + end if + + if (have_update_vector) then + ! update vector adds ndims + nstages*ndims + detector_buffer_size = detector_buffer_size + (nstages + 1)*ndims + else + ! otherwise, there's a list id + detector_buffer_size = detector_buffer_size + 1 + end if + + end function detector_buffer_size + + subroutine pack_detector(detector,buff,ndims,nstages, attribute_size_in) + ! Packs (serialises) detector into buff + ! Basic fields are: element, position, id_number and type + ! If nstages is given, the detector is still moving + ! and we also pack update_vector and k + type(detector_type), pointer, intent(in) :: detector + real, dimension(:), intent(out) :: buff + integer, intent(in) :: ndims + integer, intent(in), optional :: nstages + integer, dimension(3), optional, intent(in) :: attribute_size_in + + integer :: det_params, buf_pos + integer, dimension(3) :: attribute_size + + assert(size(detector%position) == ndims) + + !Set size of basic detector fields: detector element, id_number, proc_id + det_params = 3 + attribute_size(:) = 0 + + if (present(attribute_size_in)) then + attribute_size = attribute_size_in + end if + + ! ensure buffer is big enough to receive this detector + assert(size(buff) >= ndims + det_params + sum(attribute_size)) + + ! Basic fields: ndims+det_params + buff(1:ndims) = detector%position + buff(ndims+1) = detector%element + buff(ndims+2) = detector%id_number + buff(ndims+3) = detector%proc_id + + buf_pos = ndims + det_params + + if (attribute_size(1) /= 0) then + buff(buf_pos + 1:buf_pos + attribute_size(1)) = detector%attributes + buf_pos = buf_pos + attribute_size(1) + end if + if (attribute_size(2) /= 0) then + buff(buf_pos + 1:buf_pos + attribute_size(2)) = detector%old_attributes + buf_pos = buf_pos + attribute_size(2) + end if + if (attribute_size(3) /= 0) then + buff(buf_pos + 1:buf_pos + attribute_size(3)) = detector%old_fields + buf_pos = buf_pos + attribute_size(3) + end if + + ! Lagrangian advection fields: (nstages+1)*ndims + if (present(nstages)) then + assert(size(buff) == (nstages+2)*ndims + det_params + sum(attribute_size)) + assert(allocated(detector%update_vector)) + assert(allocated(detector%k)) + + buff(buf_pos + 1:buf_pos + ndims) = detector%update_vector + buf_pos = buf_pos + ndims + + buff(buf_pos + 1:buf_pos + nstages*ndims) = reshape(detector%k, (/nstages*ndims/)) + else + assert(size(buff) == ndims + det_params + sum(attribute_size) + 1) + buff(buf_pos + 1) = detector%list_id + end if + end subroutine pack_detector + + subroutine unpack_detector(detector,buff,ndims,global_to_local,coordinates,nstages,attribute_size_in) + ! Unpacks the detector from buff and fills in the blanks + type(detector_type), pointer :: detector + real, dimension(:), intent(in) :: buff + integer, intent(in) :: ndims + type(integer_hash_table), intent(in), optional :: global_to_local + type(vector_field), intent(in), optional :: coordinates + integer, intent(in), optional :: nstages + integer, dimension(3), optional, intent(in) :: attribute_size_in + + integer :: det_params, buf_pos + integer, dimension(3) :: attribute_size + !Set size of basic detector fields, being detector element, id_number + det_params = 3 + attribute_size(:) = 0 + + ! we default to assuming there are no attributes, + ! but this can be overridden by the caller + if (present(attribute_size_in)) then + attribute_size = attribute_size_in + end if + + ! allocate some arrays that we might not have + ! set up beforehand + if (.not. allocated(detector%position)) then + allocate(detector%position(ndims)) + end if + + if (.not. allocated(detector%attributes)) then + allocate(detector%attributes(attribute_size(1))) + allocate(detector%old_attributes(attribute_size(2))) + allocate(detector%old_fields(attribute_size(3))) + end if + + ! Basic fields: ndims+4 + detector%position = buff(1:ndims) + detector%element = buff(ndims+1) + detector%id_number = buff(ndims+2) + detector%proc_id = buff(ndims+3) + + buf_pos = ndims + det_params + + ! unpack attributes if necessary + if (attribute_size(1) /= 0) then + detector%attributes = buff(buf_pos + 1:buf_pos + attribute_size(1)) + buf_pos = buf_pos + attribute_size(1) + end if + if (attribute_size(2) /= 0) then + detector%old_attributes = buff(buf_pos + 1:buf_pos + attribute_size(2)) + buf_pos = buf_pos + attribute_size(2) + end if + if (attribute_size(3) /= 0) then + detector%old_fields = buff(buf_pos + 1:buf_pos + attribute_size(3)) + buf_pos = buf_pos + attribute_size(3) + end if + + ! Reconstruct element number if global-to-local mapping is given + if (present(global_to_local)) then + assert(has_key(global_to_local, detector%element)) + detector%element=fetch(global_to_local,detector%element) + + ! Update local coordinates if coordinate field is given + if (present(coordinates)) then + if (.not. allocated(detector%local_coords)) then + allocate(detector%local_coords(local_coord_count(ele_shape(coordinates,1)))) + end if + detector%local_coords=local_coords(coordinates,detector%element,detector%position) + end if + end if + + ! Lagrangian advection fields: (nstages+1)*ndims + if (present(nstages)) then + assert(size(buff) == (nstages+2)*ndims + det_params + sum(attribute_size)) + + ! update_vector, dimension(ndim) + if (.not. allocated(detector%update_vector)) then + allocate(detector%update_vector(ndims)) + end if + detector%update_vector = buff(buf_pos + 1:buf_pos + ndims) + buf_pos = buf_pos + ndims + + ! k, dimension(nstages:ndim) + if (.not. allocated(detector%k)) then + allocate(detector%k(nstages,ndims)) + end if + detector%k = reshape(buff(buf_pos + 1:buf_pos + nstages*ndims), & + (/nstages,ndims/)) + + ! If update_vector still exists, we're not done moving + detector%search_complete=.false. + else + assert(size(buff) == ndims + det_params + sum(attribute_size) + 1) + + detector%list_id = buff(buf_pos + 1) + detector%search_complete = .true. + end if + + end subroutine unpack_detector + + function detector_value_scalar(sfield, detector) result(value) + !!< Evaluate field at the location of the detector. + real :: value + type(scalar_field), intent(in) :: sfield + type(detector_type), intent(in) :: detector + + assert(detector%element>0) + value = eval_field(detector%element, sfield, detector%local_coords) + + end function detector_value_scalar + + function detector_value_vector(vfield, detector) result(value) + !!< Evaluate field at the location of the detector. + type(vector_field), intent(in) :: vfield + type(detector_type), intent(in) :: detector + real, dimension(vfield%dim) :: value + + assert(detector%element>0) + value = eval_field(detector%element, vfield, detector%local_coords) + + end function detector_value_vector + + subroutine set_detector_coords_from_python(values, ndete, func, time) + !!< Given a list of positions and a time, evaluate the python function + !!< specified in the string func at those points. + real, dimension(:,:), target, intent(inout) :: values + !! Func may contain any python at all but the following function must + !! be defined: + !! def val(t) + !! where t is the time. The result must be a float. + character(len=*), intent(in) :: func + real :: time + + real, dimension(:), pointer :: lvx,lvy,lvz + real, dimension(0), target :: zero + integer :: stat, dim, ndete + + call get_option("/geometry/dimension",dim) + + lvx=>values(1,:) + lvy=>zero + lvz=>zero + if(dim>1) then + lvy=>values(2,:) + if(dim>2) then + lvz => values(3,:) + end if + end if + + call set_detectors_from_python(func, len(func), dim, & + ndete, time, dim, & + lvx, lvy, lvz, stat) - do j = 1, npart - vals(field_idx:field_idx+dim-1,j) = eval_field(ele(j), vfield, lcoords(:,j)) + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + + end subroutine set_detector_coords_from_python + + !> Evaluate a set of fields on particles + subroutine evaluate_particle_fields(npart, state, ele, lcoords, names, phases, counts, vals, dim) + !! Number of particles + integer, intent(in) :: npart + !! Model state structure + type(state_type), dimension(:), intent(in) :: state + !! Elements containing particles + integer, dimension(:), intent(in) :: ele + !! Local coordinates of particles in elements + real, dimension(:,:), intent(in) :: lcoords + !! Names of fields to be evaluated + type(attr_names_type), intent(in) :: names + !! Phases of each field + type(field_phase_type), intent(in) :: phases + !! Scalar/vector/tensor counts of each field + integer, dimension(3), intent(in) :: counts + !! Output array + real, dimension(:,:), intent(out) :: vals + !! Geometric dimension + integer, intent(in) :: dim + + integer :: i, j + integer :: field_idx, phase + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + + field_idx = 1 + + ! scalar fields + do i = 1, counts(1) + phase = phases%s(i) + sfield => extract_scalar_field(state(phase), names%s(i)) + + do j = 1, npart + vals(field_idx,j) = eval_field(ele(j), sfield, lcoords(:,j)) + end do + + field_idx = field_idx + 1 end do - field_idx = field_idx + dim - end do + ! vector fields + do i = 1, counts(2) + phase = phases%v(i) + vfield => extract_vector_field(state(phase), names%v(i)) - ! tensor fields - do i = 1, counts(3) - phase = phases%t(i) - tfield => extract_tensor_field(state(phase), names%t(i)) + do j = 1, npart + vals(field_idx:field_idx+dim-1,j) = eval_field(ele(j), vfield, lcoords(:,j)) + end do - do j = 1, npart - vals(field_idx:field_idx+dim**2-1,j) = reshape( & - eval_field(ele(j), tfield, lcoords(:,j)), & - [ dim**2 ]) + field_idx = field_idx + dim end do - field_idx = field_idx + dim**2 - end do - end subroutine evaluate_particle_fields - - !> Given the particle position and time, evaluate the specified python function for a group of particles - !! specified in the string func at that location. - subroutine set_particle_scalar_attribute_from_python(attributes, positions, natt, func, time, dt, is_array) - !! (natt x nparts) array of calculated attribute values - real, dimension(:,:), intent(out) :: attributes - !! Current particle positions - real, dimension(:,:), target, intent(in) :: positions - !! Array dimension of this attribute - integer, intent(in) :: natt - !! Func may contain any python at all but the following function must - !! be defined:: - !! def val(X,t,dt) - !! where X is position and t is the time. The result must be a float. - character(len=*), intent(in) :: func - !! Current simulation time - real, intent(in) :: time - !! Current simulation timestep - real, intent(in) :: dt - !! Whether this is an array-valued attribute - logical, intent(in) :: is_array - - real, dimension(:), pointer :: lvx, lvy, lvz - real, dimension(0), target :: zero - integer :: stat, dim - - dim = size(positions, 1) - select case(dim) - case(1) - lvx=>positions(1,:) - lvy=>zero - lvz=>zero - case(2) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>zero - case(3) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>positions(3,:) - end select - - if (is_array) then - ! call interface with additional array dimension argument - call set_scalar_particles_from_python(func, len(func), dim, & - size(attributes,2), natt, lvx, lvy, lvz, time, dt, attributes, stat) - else - call set_scalar_particles_from_python(func, len(func), dim, & - size(attributes,2), lvx, lvy, lvz, time, dt, attributes, stat) - end if - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - end subroutine set_particle_scalar_attribute_from_python - - !> Given a particle position, time and field values, evaluate the python function - !! specified in the string func at that location. - subroutine set_particle_scalar_attribute_from_python_fields(particle_list, state, positions, lcoords, ele, natt, & - attributes, old_attr_names, old_attr_counts, old_attr_Dims, old_attributes, field_names, field_counts, old_field_names, & - old_field_counts, func, time, dt, is_array) - !! Particle list for which to evaluate the function - type(detector_linked_list), intent(in) :: particle_list - !! Model state structure - type(state_type), dimension(:), intent(in) :: state - !! Current particle positions - real, dimension(:,:), target, intent(in) :: positions - !! Local coordinates of particle positions - real, dimension(:,:), intent(in) :: lcoords - !! Elements containing particles - integer, dimension(:), intent(in) :: ele - !! Array dimension of this attribute - integer, intent(in) :: natt - !! Attribute values to set - real, dimension(:,:), intent(out) :: attributes - !! Names of attributes stored from the previous timestep - character, dimension(:,:), intent(in) :: old_attr_names - !! Number of each of scalar, vector, tensor old attributes - integer, dimension(3), intent(in) :: old_attr_counts - !! Array dimensions of old attributes - integer, dimension(:), intent(in) :: old_attr_dims - !! Attribute values from the previous timestep - real, dimension(:,:), intent(in) :: old_attributes - !! Names of fields that are to be passed to Python - character, dimension(:,:), intent(in) :: field_names - !! Number of each of scalar, vector, tensor fields - integer, dimension(3), intent(in) :: field_counts - !! Names of old fields that are to be passed to Python - character, dimension(:,:), intent(in) :: old_field_names - !! Number of each of salar, vector, tensor old fields - integer, dimension(3), intent(in) :: old_field_counts - !! Func may contain any python at all but the following function must - !! be defined:: - !! def val(X,t,dt,fields) - !! where X is position t is the time, and fields is a dictionary where fields["FieldName"] and fields["OldFieldName" store - !! the interpolated value of "FieldName" at the particle position at the current and previous time levels, and fields["OldAttributeName"] stores the attribute - !! value at the previous time level. The result must be a float. - character(len=*), intent(in) :: func - !! Current model time - real, intent(in) :: time - !! Current model timestep - real, intent(in) :: dt - !! Whether this is an array-valued attribute - logical, intent(in) :: is_array - - ! locals - integer :: i - integer :: dim, stat - integer :: nparts - real, dimension(:), pointer :: lvx, lvy, lvz - real, dimension(0), target :: zero - real, allocatable, dimension(:,:) :: field_vals, old_field_vals - type(detector_type), pointer :: particle - - nparts = size(attributes, 2) - dim = size(positions, 1) - select case(dim) - case(1) - lvx=>positions(1,:) - lvy=>zero - lvz=>zero - case(2) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>zero - case(3) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>positions(3,:) - end select + ! tensor fields + do i = 1, counts(3) + phase = phases%t(i) + tfield => extract_tensor_field(state(phase), names%t(i)) - ! allocate space to hold fields and old fields - allocate(field_vals(field_counts(1) + dim*field_counts(2) + dim**2*field_counts(3), nparts)) - allocate(old_field_vals(old_field_counts(1) + dim*old_field_counts(2) + dim**2*old_field_counts(3), nparts)) + do j = 1, npart + vals(field_idx:field_idx+dim**2-1,j) = reshape( & + eval_field(ele(j), tfield, lcoords(:,j)), & + [ dim**2 ]) + end do - call evaluate_particle_fields(nparts, state, ele, lcoords, & + field_idx = field_idx + dim**2 + end do + end subroutine evaluate_particle_fields + + !> Given the particle position and time, evaluate the specified python function for a group of particles + !! specified in the string func at that location. + subroutine set_particle_scalar_attribute_from_python(attributes, positions, natt, func, time, dt, is_array) + !! (natt x nparts) array of calculated attribute values + real, dimension(:,:), intent(out) :: attributes + !! Current particle positions + real, dimension(:,:), target, intent(in) :: positions + !! Array dimension of this attribute + integer, intent(in) :: natt + !! Func may contain any python at all but the following function must + !! be defined:: + !! def val(X,t,dt) + !! where X is position and t is the time. The result must be a float. + character(len=*), intent(in) :: func + !! Current simulation time + real, intent(in) :: time + !! Current simulation timestep + real, intent(in) :: dt + !! Whether this is an array-valued attribute + logical, intent(in) :: is_array + + real, dimension(:), pointer :: lvx, lvy, lvz + real, dimension(0), target :: zero + integer :: stat, dim + + dim = size(positions, 1) + select case(dim) + case(1) + lvx=>positions(1,:) + lvy=>zero + lvz=>zero + case(2) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>zero + case(3) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>positions(3,:) + end select + + if (is_array) then + ! call interface with additional array dimension argument + call set_scalar_particles_from_python(func, len(func), dim, & + size(attributes,2), natt, lvx, lvy, lvz, time, dt, attributes, stat) + else + call set_scalar_particles_from_python(func, len(func), dim, & + size(attributes,2), lvx, lvy, lvz, time, dt, attributes, stat) + end if + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + end subroutine set_particle_scalar_attribute_from_python + + !> Given a particle position, time and field values, evaluate the python function + !! specified in the string func at that location. + subroutine set_particle_scalar_attribute_from_python_fields(particle_list, state, positions, lcoords, ele, natt, & + attributes, old_attr_names, old_attr_counts, old_attr_Dims, old_attributes, field_names, field_counts, old_field_names, & + old_field_counts, func, time, dt, is_array) + !! Particle list for which to evaluate the function + type(detector_linked_list), intent(in) :: particle_list + !! Model state structure + type(state_type), dimension(:), intent(in) :: state + !! Current particle positions + real, dimension(:,:), target, intent(in) :: positions + !! Local coordinates of particle positions + real, dimension(:,:), intent(in) :: lcoords + !! Elements containing particles + integer, dimension(:), intent(in) :: ele + !! Array dimension of this attribute + integer, intent(in) :: natt + !! Attribute values to set + real, dimension(:,:), intent(out) :: attributes + !! Names of attributes stored from the previous timestep + character, dimension(:,:), intent(in) :: old_attr_names + !! Number of each of scalar, vector, tensor old attributes + integer, dimension(3), intent(in) :: old_attr_counts + !! Array dimensions of old attributes + integer, dimension(:), intent(in) :: old_attr_dims + !! Attribute values from the previous timestep + real, dimension(:,:), intent(in) :: old_attributes + !! Names of fields that are to be passed to Python + character, dimension(:,:), intent(in) :: field_names + !! Number of each of scalar, vector, tensor fields + integer, dimension(3), intent(in) :: field_counts + !! Names of old fields that are to be passed to Python + character, dimension(:,:), intent(in) :: old_field_names + !! Number of each of salar, vector, tensor old fields + integer, dimension(3), intent(in) :: old_field_counts + !! Func may contain any python at all but the following function must + !! be defined:: + !! def val(X,t,dt,fields) + !! where X is position t is the time, and fields is a dictionary where fields["FieldName"] and fields["OldFieldName" store + !! the interpolated value of "FieldName" at the particle position at the current and previous time levels, and fields["OldAttributeName"] stores the attribute + !! value at the previous time level. The result must be a float. + character(len=*), intent(in) :: func + !! Current model time + real, intent(in) :: time + !! Current model timestep + real, intent(in) :: dt + !! Whether this is an array-valued attribute + logical, intent(in) :: is_array + + ! locals + integer :: i + integer :: dim, stat + integer :: nparts + real, dimension(:), pointer :: lvx, lvy, lvz + real, dimension(0), target :: zero + real, allocatable, dimension(:,:) :: field_vals, old_field_vals + type(detector_type), pointer :: particle + + nparts = size(attributes, 2) + dim = size(positions, 1) + select case(dim) + case(1) + lvx=>positions(1,:) + lvy=>zero + lvz=>zero + case(2) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>zero + case(3) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>positions(3,:) + end select + + ! allocate space to hold fields and old fields + allocate(field_vals(field_counts(1) + dim*field_counts(2) + dim**2*field_counts(3), nparts)) + allocate(old_field_vals(old_field_counts(1) + dim*old_field_counts(2) + dim**2*old_field_counts(3), nparts)) + + call evaluate_particle_fields(nparts, state, ele, lcoords, & particle_list%field_names, particle_list%field_phases, field_counts, & field_vals, dim) - ! copy old fields off particles - particle => particle_list%first - do i = 1, nparts - old_field_vals(:,i) = particle%old_fields(:) - particle => particle%next - end do + ! copy old fields off particles + particle => particle_list%first + do i = 1, nparts + old_field_vals(:,i) = particle%old_fields(:) + particle => particle%next + end do - call set_scalar_particles_from_python_fields(func, len(func), dim, nparts, natt, & + call set_scalar_particles_from_python_fields(func, len(func), dim, nparts, natt, & lvx, lvy, lvz, time, dt, field_counts, field_names, field_vals, old_field_counts, old_field_names, & old_field_vals, old_attr_counts, old_attr_names, old_attr_dims, old_attributes, is_array, attributes, stat) - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - - deallocate(field_vals) - deallocate(old_field_vals) - end subroutine set_particle_scalar_attribute_from_python_fields - - !> Given the particle position and time, evaluate the specified python function for a group of particles - !! specified in the string func at that location. - subroutine set_particle_vector_attribute_from_python(attributes, positions, natt, func, time, dt, is_array) - !! Attribute values to set - real, dimension(:,:), intent(out) :: attributes - !! Current particle positions - real, dimension(:,:), target, intent(in) :: positions - !! Array dimension of this attribute - integer, intent(in) :: natt - !! Func may contain any python at all but the following function must - !! be defined:: - !! def val(X,t,dt) - !! where X is position and t is the time. The result must be a float. - character(len=*), intent(in) :: func - !! Current simulation time - real, intent(in) :: time - !! Curretn simulation timestep - real, intent(in) :: dt - !! Whether this is an array-valued attribute - logical, intent(in) :: is_array - - real, dimension(:), pointer :: lvx,lvy,lvz - real, dimension(0), target :: zero - integer :: stat, dim - - dim = size(positions, 1) - select case(dim) - case(1) - lvx=>positions(1,:) - lvy=>zero - lvz=>zero - case(2) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>zero - case(3) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>positions(3,:) - end select - - if (is_array) then - ! call interface with additional array dimension argumetn - call set_vector_particles_from_python(func, len(func), dim, & + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + + deallocate(field_vals) + deallocate(old_field_vals) + end subroutine set_particle_scalar_attribute_from_python_fields + + !> Given the particle position and time, evaluate the specified python function for a group of particles + !! specified in the string func at that location. + subroutine set_particle_vector_attribute_from_python(attributes, positions, natt, func, time, dt, is_array) + !! Attribute values to set + real, dimension(:,:), intent(out) :: attributes + !! Current particle positions + real, dimension(:,:), target, intent(in) :: positions + !! Array dimension of this attribute + integer, intent(in) :: natt + !! Func may contain any python at all but the following function must + !! be defined:: + !! def val(X,t,dt) + !! where X is position and t is the time. The result must be a float. + character(len=*), intent(in) :: func + !! Current simulation time + real, intent(in) :: time + !! Curretn simulation timestep + real, intent(in) :: dt + !! Whether this is an array-valued attribute + logical, intent(in) :: is_array + + real, dimension(:), pointer :: lvx,lvy,lvz + real, dimension(0), target :: zero + integer :: stat, dim + + dim = size(positions, 1) + select case(dim) + case(1) + lvx=>positions(1,:) + lvy=>zero + lvz=>zero + case(2) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>zero + case(3) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>positions(3,:) + end select + + if (is_array) then + ! call interface with additional array dimension argumetn + call set_vector_particles_from_python(func, len(func), dim, & size(attributes,2), natt, lvx, lvy, lvz, time, dt, attributes, stat) - else - call set_vector_particles_from_python(func, len(func), dim, & + else + call set_vector_particles_from_python(func, len(func), dim, & size(attributes,2), lvx, lvy, lvz, time, dt, attributes, stat) - end if - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - end subroutine set_particle_vector_attribute_from_python - - !> Given a particle position, time and field values, evaluate the python function - !! specified in the string func at that location. - subroutine set_particle_vector_attribute_from_python_fields(particle_list, state, positions, lcoords, ele, natt, & - attributes, old_attr_names, old_attr_counts, old_attr_dims, old_attributes, field_names, field_counts, old_field_names, & - old_field_counts, func, time, dt, is_array) - !! Particle list for which to evaluate the function - type(detector_linked_list), intent(in) :: particle_list - !! Model state structure - type(state_type), dimension(:), intent(in) :: state - !! Current particle positions - real, dimension(:,:), target, intent(in) :: positions - !! Local coordinates of particle positions - real, dimension(:,:), intent(in) :: lcoords - !! Elements containing particles - integer, dimension(:), intent(in) :: ele - !! Array dimnesion of this attribute - integer, intent(in) :: natt - !! Attribute values to set - real, dimension(:,:), intent(out) :: attributes - !! Names of attributes stored from the previous timestep - character, dimension(:,:), intent(in) :: old_attr_names - !! Number of each of scalar, vector, tensor old attributes - integer, dimension(3), intent(in) :: old_attr_counts - !! Array dimensions of old attributes - integer, dimension(:), intent(in) :: old_attr_dims - !! Attribute values from the previous timestep - real, dimension(:,:), intent(in) :: old_attributes - !! Names of fields that are to be passed to Python - character, dimension(:,:), intent(in) :: field_names - !! Number of each of scalar, vector, tensor fields - integer, dimension(3), intent(in) :: field_counts - !! Names of old fields that are to be passed to Python - character, dimension(:,:), intent(in) :: old_field_names - !! Number of each of salar, vector, tensor old fields - integer, dimension(3), intent(in) :: old_field_counts - !! Func may contain any python at all but the following function must - !! be defined:: - !! def val(X,t,dt,fields) - !! where X is position t is the time, and fields is a dictionary where fields["FieldName"] and fields["OldFieldName" store - !! the interpolated value of "FieldName" at the particle position at the current and previous time levels, and fields["OldAttributeName"] stores the attribute - !! value at the previous time level. The result must be a float. - character(len=*), intent(in) :: func - !! Current model time - real, intent(in) :: time - !! Current model timestep - real, intent(in) :: dt - !! Whether this is an array-valued attribute - logical, intent(in) :: is_array - - ! locals - integer :: i - integer :: dim, stat - integer :: nparts - real, dimension(:), pointer :: lvx, lvy, lvz - real, dimension(0), target :: zero - real, allocatable, dimension(:,:) :: field_vals, old_field_vals - type(detector_type), pointer :: particle - - nparts = size(attributes, 2) - dim = size(positions, 1) - select case(dim) - case(1) - lvx=>positions(1,:) - lvy=>zero - lvz=>zero - case(2) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>zero - case(3) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>positions(3,:) - end select - - ! allocate space to hold fields and old fields - allocate(field_vals(field_counts(1) + dim*field_counts(2) + dim**2*field_counts(3), nparts)) - allocate(old_field_vals(old_field_counts(1) + dim*old_field_counts(2) + dim**2*old_field_counts(3), nparts)) - - call evaluate_particle_fields(nparts, state, ele, lcoords, & + end if + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + end subroutine set_particle_vector_attribute_from_python + + !> Given a particle position, time and field values, evaluate the python function + !! specified in the string func at that location. + subroutine set_particle_vector_attribute_from_python_fields(particle_list, state, positions, lcoords, ele, natt, & + attributes, old_attr_names, old_attr_counts, old_attr_dims, old_attributes, field_names, field_counts, old_field_names, & + old_field_counts, func, time, dt, is_array) + !! Particle list for which to evaluate the function + type(detector_linked_list), intent(in) :: particle_list + !! Model state structure + type(state_type), dimension(:), intent(in) :: state + !! Current particle positions + real, dimension(:,:), target, intent(in) :: positions + !! Local coordinates of particle positions + real, dimension(:,:), intent(in) :: lcoords + !! Elements containing particles + integer, dimension(:), intent(in) :: ele + !! Array dimnesion of this attribute + integer, intent(in) :: natt + !! Attribute values to set + real, dimension(:,:), intent(out) :: attributes + !! Names of attributes stored from the previous timestep + character, dimension(:,:), intent(in) :: old_attr_names + !! Number of each of scalar, vector, tensor old attributes + integer, dimension(3), intent(in) :: old_attr_counts + !! Array dimensions of old attributes + integer, dimension(:), intent(in) :: old_attr_dims + !! Attribute values from the previous timestep + real, dimension(:,:), intent(in) :: old_attributes + !! Names of fields that are to be passed to Python + character, dimension(:,:), intent(in) :: field_names + !! Number of each of scalar, vector, tensor fields + integer, dimension(3), intent(in) :: field_counts + !! Names of old fields that are to be passed to Python + character, dimension(:,:), intent(in) :: old_field_names + !! Number of each of salar, vector, tensor old fields + integer, dimension(3), intent(in) :: old_field_counts + !! Func may contain any python at all but the following function must + !! be defined:: + !! def val(X,t,dt,fields) + !! where X is position t is the time, and fields is a dictionary where fields["FieldName"] and fields["OldFieldName" store + !! the interpolated value of "FieldName" at the particle position at the current and previous time levels, and fields["OldAttributeName"] stores the attribute + !! value at the previous time level. The result must be a float. + character(len=*), intent(in) :: func + !! Current model time + real, intent(in) :: time + !! Current model timestep + real, intent(in) :: dt + !! Whether this is an array-valued attribute + logical, intent(in) :: is_array + + ! locals + integer :: i + integer :: dim, stat + integer :: nparts + real, dimension(:), pointer :: lvx, lvy, lvz + real, dimension(0), target :: zero + real, allocatable, dimension(:,:) :: field_vals, old_field_vals + type(detector_type), pointer :: particle + + nparts = size(attributes, 2) + dim = size(positions, 1) + select case(dim) + case(1) + lvx=>positions(1,:) + lvy=>zero + lvz=>zero + case(2) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>zero + case(3) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>positions(3,:) + end select + + ! allocate space to hold fields and old fields + allocate(field_vals(field_counts(1) + dim*field_counts(2) + dim**2*field_counts(3), nparts)) + allocate(old_field_vals(old_field_counts(1) + dim*old_field_counts(2) + dim**2*old_field_counts(3), nparts)) + + call evaluate_particle_fields(nparts, state, ele, lcoords, & particle_list%field_names, particle_list%field_phases, field_counts, & field_vals, dim) - ! copy old fields off particles - particle => particle_list%first - do i = 1, nparts - old_field_vals(:,i) = particle%old_fields(:) - particle => particle%next - end do + ! copy old fields off particles + particle => particle_list%first + do i = 1, nparts + old_field_vals(:,i) = particle%old_fields(:) + particle => particle%next + end do - call set_vector_particles_from_python_fields(func, len(func), dim, nparts, natt, & + call set_vector_particles_from_python_fields(func, len(func), dim, nparts, natt, & lvx, lvy, lvz, time, dt, field_counts, field_names, field_vals, old_field_counts, old_field_names, & old_field_vals, old_attr_counts, old_attr_names, old_attr_dims, old_attributes, is_array, attributes, stat) - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - - deallocate(field_vals) - deallocate(old_field_vals) - end subroutine set_particle_vector_attribute_from_python_fields - - !> Given the particle position and time, evaluate the specified python function for a group of particles - !! specified in the string func at that location. - subroutine set_particle_tensor_attribute_from_python(attributes, positions, natt, func, time, dt, is_array) - !! Attribute values to set - real, dimension(:,:), intent(inout) :: attributes - !! Current particle positions - real, dimension(:,:), target, intent(in) :: positions - !! Array dimension of this attribute - integer, intent(in) :: natt - !! Func may contain any python at all but the following function must - !! be defined:: - !! def val(X,t,dt) - !! where X is position and t is the time. The result must be a float. - character(len=*), intent(in) :: func - !! Current simulation time - real, intent(in) :: time - !! Curretn simulation timestep - real, intent(in) :: dt - !! Whether this is an array-valued attribute - logical, intent(in) :: is_array - - real, dimension(:), pointer :: lvx,lvy,lvz - real, dimension(0), target :: zero - real, dimension(:,:,:,:), allocatable :: tensor_res - integer :: dim - integer :: nparts - integer :: stat - - nparts = size(attributes, 2) - dim = size(positions, 1) - select case(dim) - case(1) - lvx=>positions(1,:) - lvy=>zero - lvz=>zero - case(2) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>zero - case(3) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>positions(3,:) - end select - - allocate(tensor_res(dim,dim,natt,nparts)) - if (is_array) then - call set_tensor_particles_from_python(func, len(func), dim, & + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + + deallocate(field_vals) + deallocate(old_field_vals) + end subroutine set_particle_vector_attribute_from_python_fields + + !> Given the particle position and time, evaluate the specified python function for a group of particles + !! specified in the string func at that location. + subroutine set_particle_tensor_attribute_from_python(attributes, positions, natt, func, time, dt, is_array) + !! Attribute values to set + real, dimension(:,:), intent(inout) :: attributes + !! Current particle positions + real, dimension(:,:), target, intent(in) :: positions + !! Array dimension of this attribute + integer, intent(in) :: natt + !! Func may contain any python at all but the following function must + !! be defined:: + !! def val(X,t,dt) + !! where X is position and t is the time. The result must be a float. + character(len=*), intent(in) :: func + !! Current simulation time + real, intent(in) :: time + !! Curretn simulation timestep + real, intent(in) :: dt + !! Whether this is an array-valued attribute + logical, intent(in) :: is_array + + real, dimension(:), pointer :: lvx,lvy,lvz + real, dimension(0), target :: zero + real, dimension(:,:,:,:), allocatable :: tensor_res + integer :: dim + integer :: nparts + integer :: stat + + nparts = size(attributes, 2) + dim = size(positions, 1) + select case(dim) + case(1) + lvx=>positions(1,:) + lvy=>zero + lvz=>zero + case(2) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>zero + case(3) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>positions(3,:) + end select + + allocate(tensor_res(dim,dim,natt,nparts)) + if (is_array) then + call set_tensor_particles_from_python(func, len(func), dim, & nparts, natt, lvx, lvy, lvz, time, dt, tensor_res, stat) - else - call set_tensor_particles_from_python(func, len(func), dim, & + else + call set_tensor_particles_from_python(func, len(func), dim, & nparts, lvx, lvy, lvz, time, dt, tensor_res, stat) - end if - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - - ! convert tensor to array of attributes - attributes(:,:) = reshape(tensor_res, [natt * dim**2, nparts]) - deallocate(tensor_res) - end subroutine set_particle_tensor_attribute_from_python - !> Given a particle position, time and field values, evaluate the python function - !! specified in the string func at that location. - subroutine set_particle_tensor_attribute_from_python_fields(particle_list, state, positions, lcoords, ele, natt, & - attributes, old_attr_names, old_attr_counts, old_attr_dims, old_attributes, field_names, field_counts, old_field_names, & - old_field_counts, func, time, dt, is_array) - !! Particle list for which to evaluate the function - type(detector_linked_list), intent(in) :: particle_list - !! Model state structure - type(state_type), dimension(:), intent(in) :: state - !! Current particle positions - real, dimension(:,:), target, intent(in) :: positions - !! Local coordinates of particle positions - real, dimension(:,:), intent(in) :: lcoords - !! Elements containing particles - integer, dimension(:), intent(in) :: ele - !! Array dimension of this attribute - integer, intent(in) :: natt - !! Attribute values to set - real, dimension(:,:), intent(out) :: attributes - !! Names of attributes stored from the previous timestep - character, dimension(:,:), intent(in) :: old_attr_names - !! Number of each of scalar, vector, tensor old attributes - integer, dimension(3), intent(in) :: old_attr_counts - !! Array dimensions of old attributes - integer, dimension(:), intent(in) :: old_attr_dims - !! Attribute values from the previous timestep - real, dimension(:,:), intent(in) :: old_attributes - !! Names of fields that are to be passed to Python - character, dimension(:,:), intent(in) :: field_names - !! Number of each of scalar, vector, tensor fields - integer, dimension(3), intent(in) :: field_counts - !! Names of old fields that are to be passed to Python - character, dimension(:,:), intent(in) :: old_field_names - !! Number of each of salar, vector, tensor old fields - integer, dimension(3), intent(in) :: old_field_counts - !! Func may contain any python at all but the following function must - !! be defined:: - !! def val(X,t,dt,fields) - !! where X is position t is the time, and fields is a dictionary where fields["FieldName"] and fields["OldFieldName" store - !! the interpolated value of "FieldName" at the particle position at the current and previous time levels, and fields["OldAttributeName"] stores the attribute - !! value at the previous time level. The result must be a float. - character(len=*), intent(in) :: func - !! Current model time - real, intent(in) :: time - !! Current model timestep - real, intent(in) :: dt - !! Whether this is an array-valued attribute - logical, intent(in) :: is_array - - ! locals - integer :: i - integer :: dim, stat - integer :: nparts - real, dimension(:), pointer :: lvx, lvy, lvz - real, dimension(0), target :: zero - real, allocatable, dimension(:,:) :: field_vals, old_field_vals - type(detector_type), pointer :: particle - real, dimension(:,:,:,:), allocatable :: tensor_res - - nparts = size(attributes, 2) - dim = size(positions, 1) - select case(dim) - case(1) - lvx=>positions(1,:) - lvy=>zero - lvz=>zero - case(2) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>zero - case(3) - lvx=>positions(1,:) - lvy=>positions(2,:) - lvz=>positions(3,:) - end select - - ! allocate space to hold fields and old fields - allocate(field_vals(field_counts(1) + dim*field_counts(2) + dim**2*field_counts(3), nparts)) - allocate(old_field_vals(old_field_counts(1) + dim*old_field_counts(2) + dim**2*old_field_counts(3), nparts)) - - call evaluate_particle_fields(nparts, state, ele, lcoords, & + end if + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + + ! convert tensor to array of attributes + attributes(:,:) = reshape(tensor_res, [natt * dim**2, nparts]) + deallocate(tensor_res) + end subroutine set_particle_tensor_attribute_from_python + !> Given a particle position, time and field values, evaluate the python function + !! specified in the string func at that location. + subroutine set_particle_tensor_attribute_from_python_fields(particle_list, state, positions, lcoords, ele, natt, & + attributes, old_attr_names, old_attr_counts, old_attr_dims, old_attributes, field_names, field_counts, old_field_names, & + old_field_counts, func, time, dt, is_array) + !! Particle list for which to evaluate the function + type(detector_linked_list), intent(in) :: particle_list + !! Model state structure + type(state_type), dimension(:), intent(in) :: state + !! Current particle positions + real, dimension(:,:), target, intent(in) :: positions + !! Local coordinates of particle positions + real, dimension(:,:), intent(in) :: lcoords + !! Elements containing particles + integer, dimension(:), intent(in) :: ele + !! Array dimension of this attribute + integer, intent(in) :: natt + !! Attribute values to set + real, dimension(:,:), intent(out) :: attributes + !! Names of attributes stored from the previous timestep + character, dimension(:,:), intent(in) :: old_attr_names + !! Number of each of scalar, vector, tensor old attributes + integer, dimension(3), intent(in) :: old_attr_counts + !! Array dimensions of old attributes + integer, dimension(:), intent(in) :: old_attr_dims + !! Attribute values from the previous timestep + real, dimension(:,:), intent(in) :: old_attributes + !! Names of fields that are to be passed to Python + character, dimension(:,:), intent(in) :: field_names + !! Number of each of scalar, vector, tensor fields + integer, dimension(3), intent(in) :: field_counts + !! Names of old fields that are to be passed to Python + character, dimension(:,:), intent(in) :: old_field_names + !! Number of each of salar, vector, tensor old fields + integer, dimension(3), intent(in) :: old_field_counts + !! Func may contain any python at all but the following function must + !! be defined:: + !! def val(X,t,dt,fields) + !! where X is position t is the time, and fields is a dictionary where fields["FieldName"] and fields["OldFieldName" store + !! the interpolated value of "FieldName" at the particle position at the current and previous time levels, and fields["OldAttributeName"] stores the attribute + !! value at the previous time level. The result must be a float. + character(len=*), intent(in) :: func + !! Current model time + real, intent(in) :: time + !! Current model timestep + real, intent(in) :: dt + !! Whether this is an array-valued attribute + logical, intent(in) :: is_array + + ! locals + integer :: i + integer :: dim, stat + integer :: nparts + real, dimension(:), pointer :: lvx, lvy, lvz + real, dimension(0), target :: zero + real, allocatable, dimension(:,:) :: field_vals, old_field_vals + type(detector_type), pointer :: particle + real, dimension(:,:,:,:), allocatable :: tensor_res + + nparts = size(attributes, 2) + dim = size(positions, 1) + select case(dim) + case(1) + lvx=>positions(1,:) + lvy=>zero + lvz=>zero + case(2) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>zero + case(3) + lvx=>positions(1,:) + lvy=>positions(2,:) + lvz=>positions(3,:) + end select + + ! allocate space to hold fields and old fields + allocate(field_vals(field_counts(1) + dim*field_counts(2) + dim**2*field_counts(3), nparts)) + allocate(old_field_vals(old_field_counts(1) + dim*old_field_counts(2) + dim**2*old_field_counts(3), nparts)) + + call evaluate_particle_fields(nparts, state, ele, lcoords, & particle_list%field_names, particle_list%field_phases, field_counts, & field_vals, dim) - ! copy old fields off particles - particle => particle_list%first - do i = 1, nparts - old_field_vals(:,i) = particle%old_fields(:) - particle => particle%next - end do + ! copy old fields off particles + particle => particle_list%first + do i = 1, nparts + old_field_vals(:,i) = particle%old_fields(:) + particle => particle%next + end do - allocate(tensor_res(dim,dim,natt,nparts)) + allocate(tensor_res(dim,dim,natt,nparts)) - call set_tensor_particles_from_python_fields(func, len(func), dim, nparts, natt, & + call set_tensor_particles_from_python_fields(func, len(func), dim, nparts, natt, & lvx, lvy, lvz, time, dt, field_counts, field_names, field_vals, old_field_counts, old_field_names, & old_field_vals, old_attr_counts, old_attr_names, old_attr_dims, old_attributes, is_array, tensor_res, stat) - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1 , *) trim(func) - FLExit("Dying") - end if - - ! convert tensor to array of attributes - attributes(:,:) = reshape(tensor_res, [natt * dim**2, nparts]) - - deallocate(tensor_res) - deallocate(field_vals) - deallocate(old_field_vals) - end subroutine set_particle_tensor_attribute_from_python_fields + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1 , *) trim(func) + FLExit("Dying") + end if + + ! convert tensor to array of attributes + attributes(:,:) = reshape(tensor_res, [natt * dim**2, nparts]) + + deallocate(tensor_res) + deallocate(field_vals) + deallocate(old_field_vals) + end subroutine set_particle_tensor_attribute_from_python_fields end module detector_tools diff --git a/femtools/Dgtools.F90 b/femtools/Dgtools.F90 index bec051856f..b65bab7aa6 100644 --- a/femtools/Dgtools.F90 +++ b/femtools/Dgtools.F90 @@ -2,669 +2,669 @@ module dgtools -use fldebug -use vector_tools -use futils, only: present_and_true, present_and_false -use elements -use halos_base -use sparse_tools -use fields_data_types -use sparsity_patterns -use transform_elements -use FETools -use fields -use boundary_conditions, only: get_boundary_condition_nodes - -implicit none - -private - -public :: local_node_map, get_dg_inverse_mass_matrix, get_lumped_mass,& - & dg_add_mass, dg_apply_mass, construct_inverse_mass_matrix_dg + use fldebug + use vector_tools + use futils, only: present_and_true, present_and_false + use elements + use halos_base + use sparse_tools + use fields_data_types + use sparsity_patterns + use transform_elements + use FETools + use fields + use boundary_conditions, only: get_boundary_condition_nodes + + implicit none + + private + + public :: local_node_map, get_dg_inverse_mass_matrix, get_lumped_mass,& + & dg_add_mass, dg_apply_mass, construct_inverse_mass_matrix_dg !! Parameters choosing how dirichlet boundary conditions are set -integer, public, parameter :: DIRICHLET_NONE=0, & - DIRICHLET_ONES_ON_DIAGONAL=1, & - & DIRICHLET_BIG_SPRING=2, & - & DIRICHLET_WEAK=3 - -interface get_dg_inverse_mass_matrix - module procedure csr_get_dg_inverse_mass_matrix, & - dcsr_get_dg_inverse_mass_matrix, & - csr_dg_inverse_mass_from_mass -end interface - -interface get_lumped_mass - module procedure dcsr_get_lumped_mass -end interface - -interface dg_apply_mass - module procedure csr_dg_apply_mass_scalar, block_csr_dg_apply_mass_vector -end interface - -interface dg_add_mass - module procedure csr_dg_add_mass -end interface - -interface construct_inverse_mass_matrix_dg - module procedure construct_inverse_mass_matrix_dg_scalar, & - construct_inverse_mass_matrix_dg_vector -end interface + integer, public, parameter :: DIRICHLET_NONE=0, & + DIRICHLET_ONES_ON_DIAGONAL=1, & + & DIRICHLET_BIG_SPRING=2, & + & DIRICHLET_WEAK=3 + + interface get_dg_inverse_mass_matrix + module procedure csr_get_dg_inverse_mass_matrix, & + dcsr_get_dg_inverse_mass_matrix, & + csr_dg_inverse_mass_from_mass + end interface + + interface get_lumped_mass + module procedure dcsr_get_lumped_mass + end interface + + interface dg_apply_mass + module procedure csr_dg_apply_mass_scalar, block_csr_dg_apply_mass_vector + end interface + + interface dg_add_mass + module procedure csr_dg_add_mass + end interface + + interface construct_inverse_mass_matrix_dg + module procedure construct_inverse_mass_matrix_dg_scalar, & + construct_inverse_mass_matrix_dg_vector + end interface contains - function local_node_map(m, m_f, bdy, bdy_2) result(local_glno) - ! Fill in the number map for the DG double element. - type(element_type), intent(in) :: m, m_f - integer, dimension(m_f%loc) :: bdy, bdy_2 - integer, dimension(m%loc,2) :: local_glno - - integer :: i,j - - local_glno=0 - - ! First m_f%loc places are for the bdy between the elements. - forall(i=1:m_f%loc) - local_glno(bdy(i),1)=i - end forall - - ! Remaining spots go to elements. - j=m_f%loc - do i=1, m%loc - if(local_glno(i,1)==0) then - j=j+1 - local_glno(i,1)=j - end if - end do - - ASSERT(j==m%loc) - - ! First m_f%loc places are for the bdy between the elements. - forall(i=1:m_f%loc) - local_glno(bdy_2(i),2)=i - end forall - - ! Remaining spots go to elements. - j=m%loc - do i=1, m%loc - if(local_glno(i,2)==0) then - j=j+1 - local_glno(i,2)=j - end if - end do - - ASSERT(j==2*m%loc-m_f%loc) - - end function local_node_map - - subroutine csr_get_dg_inverse_mass_matrix(inverse_mass, dg_mesh, & - & positions, density, dirichlet_list, dirichlet_flag, & - & absorption_factor, allocate_matrix) - type(csr_matrix), intent(inout) :: inverse_mass - type(mesh_type), intent(inout) :: dg_mesh - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in), optional, target :: density - integer, dimension(:), intent(in), optional :: dirichlet_list - integer, intent(in), optional :: dirichlet_flag - type(scalar_field), intent(in), optional :: absorption_factor - logical, intent(in), optional :: allocate_matrix - - !locals - integer :: ele - real, dimension(:), allocatable :: factor_at_quad - logical, dimension(:), allocatable :: internal_dirichlet_list - integer, dimension(:), pointer :: e_nodes - integer :: l_dirichlet_flag - type(csr_sparsity) :: sparsity - - if(present(dirichlet_flag)) then - l_dirichlet_flag = dirichlet_flag - else - l_dirichlet_flag = DIRICHLET_NONE - end if - - if(l_dirichlet_flag.ne.DIRICHLET_NONE) then - if(present(dirichlet_list)) then - allocate( internal_dirichlet_list( node_count(dg_mesh) ) ) - internal_dirichlet_list = .false. - internal_dirichlet_list(dirichlet_list) = .true. - end if - end if - - if(l_dirichlet_flag==DIRICHLET_BIG_SPRING) then - ewrite(2,*) 'INFINITY = ', INFINITY - ewrite(2,*) 'sqrt(INFINITY) = ', sqrt(INFINITY) - end if - - if (.not. present_and_false(allocate_matrix)) then - assert(dg_mesh%continuity==-1) + function local_node_map(m, m_f, bdy, bdy_2) result(local_glno) + ! Fill in the number map for the DG double element. + type(element_type), intent(in) :: m, m_f + integer, dimension(m_f%loc) :: bdy, bdy_2 + integer, dimension(m%loc,2) :: local_glno + + integer :: i,j - sparsity=make_sparsity_dg_mass(dg_mesh) + local_glno=0 - call allocate(inverse_mass, sparsity, name="DGInverseMass") + ! First m_f%loc places are for the bdy between the elements. + forall(i=1:m_f%loc) + local_glno(bdy(i),1)=i + end forall - ! Drop the extra reference to sparsity. - call deallocate(sparsity) - end if + ! Remaining spots go to elements. + j=m_f%loc + do i=1, m%loc + if(local_glno(i,1)==0) then + j=j+1 + local_glno(i,1)=j + end if + end do - allocate( factor_at_quad(1:ele_ngi(positions,1)) ) + ASSERT(j==m%loc) - do ele = 1, dg_mesh%elements + ! First m_f%loc places are for the bdy between the elements. + forall(i=1:m_f%loc) + local_glno(bdy_2(i),2)=i + end forall - if (present(density)) then - factor_at_quad=ele_val_at_quad(density, ele) - else - factor_at_quad=1.0 - end if - if (present(absorption_factor)) then - factor_at_quad=factor_at_quad* & - ele_val_at_quad(absorption_factor, ele) - end if + ! Remaining spots go to elements. + j=m%loc + do i=1, m%loc + if(local_glno(i,2)==0) then + j=j+1 + local_glno(i,2)=j + end if + end do - if(present(dirichlet_list).and. & - & (l_dirichlet_flag.ne.DIRICHLET_NONE)) then - e_nodes => ele_nodes(dg_mesh,ele) - call csr_assemble_local_dg_inverse_mass_matrix(inverse_mass, & + ASSERT(j==2*m%loc-m_f%loc) + + end function local_node_map + + subroutine csr_get_dg_inverse_mass_matrix(inverse_mass, dg_mesh, & + & positions, density, dirichlet_list, dirichlet_flag, & + & absorption_factor, allocate_matrix) + type(csr_matrix), intent(inout) :: inverse_mass + type(mesh_type), intent(inout) :: dg_mesh + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in), optional, target :: density + integer, dimension(:), intent(in), optional :: dirichlet_list + integer, intent(in), optional :: dirichlet_flag + type(scalar_field), intent(in), optional :: absorption_factor + logical, intent(in), optional :: allocate_matrix + + !locals + integer :: ele + real, dimension(:), allocatable :: factor_at_quad + logical, dimension(:), allocatable :: internal_dirichlet_list + integer, dimension(:), pointer :: e_nodes + integer :: l_dirichlet_flag + type(csr_sparsity) :: sparsity + + if(present(dirichlet_flag)) then + l_dirichlet_flag = dirichlet_flag + else + l_dirichlet_flag = DIRICHLET_NONE + end if + + if(l_dirichlet_flag.ne.DIRICHLET_NONE) then + if(present(dirichlet_list)) then + allocate( internal_dirichlet_list( node_count(dg_mesh) ) ) + internal_dirichlet_list = .false. + internal_dirichlet_list(dirichlet_list) = .true. + end if + end if + + if(l_dirichlet_flag==DIRICHLET_BIG_SPRING) then + ewrite(2,*) 'INFINITY = ', INFINITY + ewrite(2,*) 'sqrt(INFINITY) = ', sqrt(INFINITY) + end if + + if (.not. present_and_false(allocate_matrix)) then + assert(dg_mesh%continuity==-1) + + sparsity=make_sparsity_dg_mass(dg_mesh) + + call allocate(inverse_mass, sparsity, name="DGInverseMass") + + ! Drop the extra reference to sparsity. + call deallocate(sparsity) + end if + + allocate( factor_at_quad(1:ele_ngi(positions,1)) ) + + do ele = 1, dg_mesh%elements + + if (present(density)) then + factor_at_quad=ele_val_at_quad(density, ele) + else + factor_at_quad=1.0 + end if + if (present(absorption_factor)) then + factor_at_quad=factor_at_quad* & + ele_val_at_quad(absorption_factor, ele) + end if + + if(present(dirichlet_list).and. & + & (l_dirichlet_flag.ne.DIRICHLET_NONE)) then + e_nodes => ele_nodes(dg_mesh,ele) + call csr_assemble_local_dg_inverse_mass_matrix(inverse_mass, & dg_mesh,positions, factor_at_quad, ele,& internal_dirichlet_list(e_nodes), l_dirichlet_flag) - else - call csr_assemble_local_dg_inverse_mass_matrix(inverse_mass, & + else + call csr_assemble_local_dg_inverse_mass_matrix(inverse_mass, & dg_mesh,positions, factor_at_quad, ele) - end if - - end do - - end subroutine csr_get_dg_inverse_mass_matrix - - subroutine csr_assemble_local_dg_inverse_mass_matrix(inverse_mass, & - dg_mesh,positions, factor_at_quad, ele, & - dirichlet_list, dirichlet_flag) - type(csr_matrix), intent(inout) :: inverse_mass - type(mesh_type), intent(in) :: dg_mesh - type(vector_field), intent(in) :: positions - ! a scalar factor to be integrated with the mass matrix: - ! / - ! M_ij=| factor(x) N_i(x) N_j(x) dx - ! / - real, dimension(:), intent(in) :: factor_at_quad - integer, intent(in) :: ele - logical, dimension(:), intent(in), optional :: dirichlet_list - integer, intent(in), optional :: dirichlet_flag - - !local variables - real, dimension(ele_loc(dg_mesh,ele),ele_loc(dg_mesh,ele)) :: local_mass - real, dimension(dg_mesh%shape%ngi) :: detwei - integer, dimension(:), pointer :: ele_dg - type(element_type), pointer :: shape_dg,shape_X - integer :: i - - !assemble local mass matrix - ele_dg=>ele_nodes(dg_mesh, ele) - shape_dg=>ele_shape(dg_mesh, ele) - shape_X=>ele_shape(positions, ele) - - call transform_to_physical(positions,ele,detwei=detwei) - detwei=detwei*factor_at_quad - local_mass = shape_shape(shape_dg,shape_dg,detwei) - - if(present(dirichlet_list)) then - do i = 1, size(dirichlet_list) - if(dirichlet_list(i)) then - select case(dirichlet_flag) - case (DIRICHLET_NONE) - case (DIRICHLET_ONES_ON_DIAGONAL) - local_mass(:,i) = 0. - local_mass(i,:) = 0. - local_mass(i,i) = 1. - case (DIRICHLET_BIG_SPRING) - local_mass(i,i) = sqrt(INFINITY) - case default - FLAbort('bad dirichlet flag') - end select - end if - end do - end if - - call invert(local_mass) - - call set(inverse_mass,ele_dg,ele_dg,local_mass) - - end subroutine csr_assemble_local_dg_inverse_mass_matrix - - subroutine dcsr_get_dg_inverse_mass_matrix(inverse_mass,dg_mesh, & - & positions, density,dirichlet_list,dirichlet_flag, & - & absorption_factor) - type(mesh_type), intent(inout) :: dg_mesh - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in), optional, target :: density - type(dynamic_csr_matrix), intent(inout) :: inverse_mass - integer, dimension(:), intent(in), optional :: dirichlet_list - integer, intent(in), optional :: dirichlet_flag - type(scalar_field), intent(in), optional :: absorption_factor - - !locals - integer :: ele - real, dimension(:), allocatable :: factor_at_quad - logical, dimension(:), allocatable :: internal_dirichlet_list - integer, dimension(:), pointer :: e_nodes - integer :: l_dirichlet_flag - - if(present(dirichlet_flag)) then - l_dirichlet_flag = dirichlet_flag - else - l_dirichlet_flag = 0 - end if - - if(l_dirichlet_flag.ne.DIRICHLET_NONE) then - if(present(dirichlet_list)) then - allocate( internal_dirichlet_list( node_count(dg_mesh) ) ) - internal_dirichlet_list = .false. - internal_dirichlet_list(dirichlet_list) = .true. - end if - end if - - assert(dg_mesh%continuity==-1) - - allocate( factor_at_quad(1:ele_ngi(density,1)) ) - - do ele = 1, dg_mesh%elements - - if (present(density)) then - factor_at_quad=ele_val_at_quad(density, ele) - else - factor_at_quad=1.0 - end if - if (present(absorption_factor)) then - factor_at_quad=factor_at_quad* & - ele_val_at_quad(absorption_factor, ele) - end if - - if(present(dirichlet_list).and. & - & (l_dirichlet_flag.ne.DIRICHLET_NONE)) then - e_nodes => ele_nodes(dg_mesh,ele) - call assemble_local_dg_inverse_mass_matrix(inverse_mass, & + end if + + end do + + end subroutine csr_get_dg_inverse_mass_matrix + + subroutine csr_assemble_local_dg_inverse_mass_matrix(inverse_mass, & + dg_mesh,positions, factor_at_quad, ele, & + dirichlet_list, dirichlet_flag) + type(csr_matrix), intent(inout) :: inverse_mass + type(mesh_type), intent(in) :: dg_mesh + type(vector_field), intent(in) :: positions + ! a scalar factor to be integrated with the mass matrix: + ! / + ! M_ij=| factor(x) N_i(x) N_j(x) dx + ! / + real, dimension(:), intent(in) :: factor_at_quad + integer, intent(in) :: ele + logical, dimension(:), intent(in), optional :: dirichlet_list + integer, intent(in), optional :: dirichlet_flag + + !local variables + real, dimension(ele_loc(dg_mesh,ele),ele_loc(dg_mesh,ele)) :: local_mass + real, dimension(dg_mesh%shape%ngi) :: detwei + integer, dimension(:), pointer :: ele_dg + type(element_type), pointer :: shape_dg,shape_X + integer :: i + + !assemble local mass matrix + ele_dg=>ele_nodes(dg_mesh, ele) + shape_dg=>ele_shape(dg_mesh, ele) + shape_X=>ele_shape(positions, ele) + + call transform_to_physical(positions,ele,detwei=detwei) + detwei=detwei*factor_at_quad + local_mass = shape_shape(shape_dg,shape_dg,detwei) + + if(present(dirichlet_list)) then + do i = 1, size(dirichlet_list) + if(dirichlet_list(i)) then + select case(dirichlet_flag) + case (DIRICHLET_NONE) + case (DIRICHLET_ONES_ON_DIAGONAL) + local_mass(:,i) = 0. + local_mass(i,:) = 0. + local_mass(i,i) = 1. + case (DIRICHLET_BIG_SPRING) + local_mass(i,i) = sqrt(INFINITY) + case default + FLAbort('bad dirichlet flag') + end select + end if + end do + end if + + call invert(local_mass) + + call set(inverse_mass,ele_dg,ele_dg,local_mass) + + end subroutine csr_assemble_local_dg_inverse_mass_matrix + + subroutine dcsr_get_dg_inverse_mass_matrix(inverse_mass,dg_mesh, & + & positions, density,dirichlet_list,dirichlet_flag, & + & absorption_factor) + type(mesh_type), intent(inout) :: dg_mesh + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in), optional, target :: density + type(dynamic_csr_matrix), intent(inout) :: inverse_mass + integer, dimension(:), intent(in), optional :: dirichlet_list + integer, intent(in), optional :: dirichlet_flag + type(scalar_field), intent(in), optional :: absorption_factor + + !locals + integer :: ele + real, dimension(:), allocatable :: factor_at_quad + logical, dimension(:), allocatable :: internal_dirichlet_list + integer, dimension(:), pointer :: e_nodes + integer :: l_dirichlet_flag + + if(present(dirichlet_flag)) then + l_dirichlet_flag = dirichlet_flag + else + l_dirichlet_flag = 0 + end if + + if(l_dirichlet_flag.ne.DIRICHLET_NONE) then + if(present(dirichlet_list)) then + allocate( internal_dirichlet_list( node_count(dg_mesh) ) ) + internal_dirichlet_list = .false. + internal_dirichlet_list(dirichlet_list) = .true. + end if + end if + + assert(dg_mesh%continuity==-1) + + allocate( factor_at_quad(1:ele_ngi(density,1)) ) + + do ele = 1, dg_mesh%elements + + if (present(density)) then + factor_at_quad=ele_val_at_quad(density, ele) + else + factor_at_quad=1.0 + end if + if (present(absorption_factor)) then + factor_at_quad=factor_at_quad* & + ele_val_at_quad(absorption_factor, ele) + end if + + if(present(dirichlet_list).and. & + & (l_dirichlet_flag.ne.DIRICHLET_NONE)) then + e_nodes => ele_nodes(dg_mesh,ele) + call assemble_local_dg_inverse_mass_matrix(inverse_mass, & dg_mesh,positions,factor_at_quad,ele,& internal_dirichlet_list(e_nodes), l_dirichlet_flag) - else - call assemble_local_dg_inverse_mass_matrix(inverse_mass, & + else + call assemble_local_dg_inverse_mass_matrix(inverse_mass, & dg_mesh,positions,factor_at_quad,ele) - end if - end do - - end subroutine dcsr_get_dg_inverse_mass_matrix - - subroutine assemble_local_dg_inverse_mass_matrix(inverse_dynamic_mass, & - dg_mesh,positions,factor_at_quad,ele,dirichlet_list,dirichlet_flag) - type(dynamic_csr_matrix), intent(inout) :: inverse_dynamic_mass - type(mesh_type), intent(in) :: dg_mesh - type(vector_field), intent(in) :: positions - ! a scalar factor to be integrated with the mass matrix: - ! / - ! M_ij=| factor(x) N_i(x) N_j(x) dx - ! / - real, dimension(:), intent(in) :: factor_at_quad - integer, intent(in) :: ele - logical, dimension(:), intent(in), optional :: dirichlet_list - integer, intent(in), optional :: dirichlet_flag - - !local variables - real, dimension(ele_loc(dg_mesh,ele),ele_loc(dg_mesh,ele)) :: local_mass - real, dimension(dg_mesh%shape%ngi) :: detwei - integer, dimension(:), pointer :: ele_dg - type(element_type), pointer :: shape_dg,shape_X - integer :: i - - !assemble local mass matrix - ele_dg=>ele_nodes(dg_mesh, ele) - shape_dg=>ele_shape(dg_mesh, ele) - shape_X=>ele_shape(positions, ele) - - call transform_to_physical(positions, ele,detwei=detwei) - local_mass = shape_shape(shape_dg,shape_dg,detwei*factor_at_quad) - - if(present(dirichlet_list)) then - do i = 1, size(dirichlet_list) - if(dirichlet_list(i)) then - select case(dirichlet_flag) - case (DIRICHLET_NONE) - case (DIRICHLET_ONES_ON_DIAGONAL) - local_mass(:,i) = 0. - local_mass(i,:) = 0. - local_mass(i,i) = 1. - case (DIRICHLET_BIG_SPRING) - local_mass(i,i) = sqrt(INFINITY) - case default - FLAbort('bad dirichlet flag') - end select - end if - end do - end if - - call invert(local_mass) - - call set(inverse_dynamic_mass,ele_dg,ele_dg,local_mass) - - end subroutine assemble_local_dg_inverse_mass_matrix - - function dcsr_get_lumped_mass(mesh, & - & positions,dirichlet_list,dirichlet_flag) result (mass) - type(mesh_type), intent(in) :: mesh - type(vector_field), intent(in) :: positions - type(dynamic_csr_matrix) :: mass - integer, dimension(:), intent(in), optional :: dirichlet_list - integer, intent(in), optional :: dirichlet_flag - - !locals - integer :: ele - logical, dimension(:), allocatable :: internal_dirichlet_list - integer, dimension(:), pointer :: e_nodes - integer :: l_dirichlet_flag - - if(present(dirichlet_flag)) then - l_dirichlet_flag = dirichlet_flag - else - l_dirichlet_flag = 0 - end if - - if(present(dirichlet_list).and.(l_dirichlet_flag.ne.0)) then - allocate( internal_dirichlet_list( node_count(mesh) ) ) - internal_dirichlet_list = .false. - internal_dirichlet_list(dirichlet_list) = .true. - end if - - call allocate(mass, mesh%nodes, mesh%nodes) - - do ele = 1, mesh%elements - - if(present(dirichlet_list).and.(dirichlet_flag.ne.0)) then - e_nodes => ele_nodes(mesh,ele) - call dcsr_assemble_local_lumped_mass(mass, & + end if + end do + + end subroutine dcsr_get_dg_inverse_mass_matrix + + subroutine assemble_local_dg_inverse_mass_matrix(inverse_dynamic_mass, & + dg_mesh,positions,factor_at_quad,ele,dirichlet_list,dirichlet_flag) + type(dynamic_csr_matrix), intent(inout) :: inverse_dynamic_mass + type(mesh_type), intent(in) :: dg_mesh + type(vector_field), intent(in) :: positions + ! a scalar factor to be integrated with the mass matrix: + ! / + ! M_ij=| factor(x) N_i(x) N_j(x) dx + ! / + real, dimension(:), intent(in) :: factor_at_quad + integer, intent(in) :: ele + logical, dimension(:), intent(in), optional :: dirichlet_list + integer, intent(in), optional :: dirichlet_flag + + !local variables + real, dimension(ele_loc(dg_mesh,ele),ele_loc(dg_mesh,ele)) :: local_mass + real, dimension(dg_mesh%shape%ngi) :: detwei + integer, dimension(:), pointer :: ele_dg + type(element_type), pointer :: shape_dg,shape_X + integer :: i + + !assemble local mass matrix + ele_dg=>ele_nodes(dg_mesh, ele) + shape_dg=>ele_shape(dg_mesh, ele) + shape_X=>ele_shape(positions, ele) + + call transform_to_physical(positions, ele,detwei=detwei) + local_mass = shape_shape(shape_dg,shape_dg,detwei*factor_at_quad) + + if(present(dirichlet_list)) then + do i = 1, size(dirichlet_list) + if(dirichlet_list(i)) then + select case(dirichlet_flag) + case (DIRICHLET_NONE) + case (DIRICHLET_ONES_ON_DIAGONAL) + local_mass(:,i) = 0. + local_mass(i,:) = 0. + local_mass(i,i) = 1. + case (DIRICHLET_BIG_SPRING) + local_mass(i,i) = sqrt(INFINITY) + case default + FLAbort('bad dirichlet flag') + end select + end if + end do + end if + + call invert(local_mass) + + call set(inverse_dynamic_mass,ele_dg,ele_dg,local_mass) + + end subroutine assemble_local_dg_inverse_mass_matrix + + function dcsr_get_lumped_mass(mesh, & + & positions,dirichlet_list,dirichlet_flag) result (mass) + type(mesh_type), intent(in) :: mesh + type(vector_field), intent(in) :: positions + type(dynamic_csr_matrix) :: mass + integer, dimension(:), intent(in), optional :: dirichlet_list + integer, intent(in), optional :: dirichlet_flag + + !locals + integer :: ele + logical, dimension(:), allocatable :: internal_dirichlet_list + integer, dimension(:), pointer :: e_nodes + integer :: l_dirichlet_flag + + if(present(dirichlet_flag)) then + l_dirichlet_flag = dirichlet_flag + else + l_dirichlet_flag = 0 + end if + + if(present(dirichlet_list).and.(l_dirichlet_flag.ne.0)) then + allocate( internal_dirichlet_list( node_count(mesh) ) ) + internal_dirichlet_list = .false. + internal_dirichlet_list(dirichlet_list) = .true. + end if + + call allocate(mass, mesh%nodes, mesh%nodes) + + do ele = 1, mesh%elements + + if(present(dirichlet_list).and.(dirichlet_flag.ne.0)) then + e_nodes => ele_nodes(mesh,ele) + call dcsr_assemble_local_lumped_mass(mass, & mesh,positions,ele,internal_dirichlet_list(e_nodes), & l_dirichlet_flag) - else - call dcsr_assemble_local_lumped_mass(mass, & + else + call dcsr_assemble_local_lumped_mass(mass, & mesh,positions,ele) - end if - end do - - end function dcsr_get_lumped_mass - - subroutine dcsr_assemble_local_lumped_mass(mass, & - mesh,positions,ele,dirichlet_list,dirichlet_flag) - integer, intent(in) :: ele - type(dynamic_csr_matrix), intent(inout) :: mass - type(mesh_type), intent(in) :: mesh - type(vector_field), intent(in) :: positions - logical, dimension(:), intent(in), optional :: dirichlet_list - integer, intent(in), optional :: dirichlet_flag - - !local variables - real, dimension(ele_loc(mesh,ele),ele_loc(mesh,ele)) :: local_mass - real, dimension(mesh%shape%ngi) :: detwei - integer, dimension(:), pointer :: ele_dg - type(element_type), pointer :: shape_dg,shape_X - integer :: i - - !assemble local mass matrix - ele_dg=>ele_nodes(mesh, ele) - shape_dg=>ele_shape(mesh, ele) - shape_X=>ele_shape(positions, ele) - call transform_to_physical(positions, ele, detwei=detwei) - local_mass = shape_shape(shape_dg,shape_dg,detwei) - - if(present(dirichlet_list)) then - do i = 1, size(dirichlet_list) - if(dirichlet_list(i)) then - select case(dirichlet_flag) - case (DIRICHLET_NONE) - case (DIRICHLET_ONES_ON_DIAGONAL) - local_mass(:,i) = 0. - local_mass(i,:) = 0. - local_mass(i,i) = 1. - case (DIRICHLET_BIG_SPRING) - local_mass(i,i) = sqrt(INFINITY) - case default - FLAbort('bad dirichlet flag') - end select - end if - end do - end if - - do i = 1, ele_loc(mesh,ele) - call set(mass,ele_dg(i),ele_dg(i),sum(local_mass(i,:))) - end do - - end subroutine dcsr_assemble_local_lumped_mass - - subroutine csr_dg_inverse_mass_from_mass(inv_mass, mass, only_owned_elements) - !!< Put the inverse of mass into inv_mass. This is short-circuited by - !!< knowing that mass is DG. - type(csr_matrix), intent(inout) :: inv_mass - type(csr_matrix), intent(in) :: mass - !! if present and true, only computed inverse mass for owned elements, the rest of inv_mass is zeroed - !! this means that after multiplication with this matrix, you need to halo_update: - logical, intent(in), optional :: only_owned_elements - - integer :: row, colm_pos, nloc, last_row - - row=1 - colm_pos=0 - - if (present_and_true(only_owned_elements) .and. associated(mass%sparsity%row_halo)) then - last_row = halo_nowned_nodes(mass%sparsity%row_halo) - else - last_row = size(mass,1) - end if - - do - if(row>last_row) exit - nloc=row_length(mass, row) - inv_mass%val(colm_pos+1:colm_pos+nloc**2) & - = reshape(& - & inverse(& - & reshape(mass%val(colm_pos+1:colm_pos+nloc**2), & - & (/nloc,nloc/))& - & ), & - & (/nloc*nloc/)) + end if + end do - row=row+nloc - colm_pos=colm_pos+nloc**2 - end do + end function dcsr_get_lumped_mass + + subroutine dcsr_assemble_local_lumped_mass(mass, & + mesh,positions,ele,dirichlet_list,dirichlet_flag) + integer, intent(in) :: ele + type(dynamic_csr_matrix), intent(inout) :: mass + type(mesh_type), intent(in) :: mesh + type(vector_field), intent(in) :: positions + logical, dimension(:), intent(in), optional :: dirichlet_list + integer, intent(in), optional :: dirichlet_flag + + !local variables + real, dimension(ele_loc(mesh,ele),ele_loc(mesh,ele)) :: local_mass + real, dimension(mesh%shape%ngi) :: detwei + integer, dimension(:), pointer :: ele_dg + type(element_type), pointer :: shape_dg,shape_X + integer :: i + + !assemble local mass matrix + ele_dg=>ele_nodes(mesh, ele) + shape_dg=>ele_shape(mesh, ele) + shape_X=>ele_shape(positions, ele) + call transform_to_physical(positions, ele, detwei=detwei) + local_mass = shape_shape(shape_dg,shape_dg,detwei) + + if(present(dirichlet_list)) then + do i = 1, size(dirichlet_list) + if(dirichlet_list(i)) then + select case(dirichlet_flag) + case (DIRICHLET_NONE) + case (DIRICHLET_ONES_ON_DIAGONAL) + local_mass(:,i) = 0. + local_mass(i,:) = 0. + local_mass(i,i) = 1. + case (DIRICHLET_BIG_SPRING) + local_mass(i,i) = sqrt(INFINITY) + case default + FLAbort('bad dirichlet flag') + end select + end if + end do + end if - if (present_and_true(only_owned_elements) .and. associated(mass%sparsity%row_halo)) then - ! rest is zeroed - inv_mass%val(colm_pos+1:)=0.0 - end if + do i = 1, ele_loc(mesh,ele) + call set(mass,ele_dg(i),ele_dg(i),sum(local_mass(i,:))) + end do + + end subroutine dcsr_assemble_local_lumped_mass + + subroutine csr_dg_inverse_mass_from_mass(inv_mass, mass, only_owned_elements) + !!< Put the inverse of mass into inv_mass. This is short-circuited by + !!< knowing that mass is DG. + type(csr_matrix), intent(inout) :: inv_mass + type(csr_matrix), intent(in) :: mass + !! if present and true, only computed inverse mass for owned elements, the rest of inv_mass is zeroed + !! this means that after multiplication with this matrix, you need to halo_update: + logical, intent(in), optional :: only_owned_elements - end subroutine csr_dg_inverse_mass_from_mass + integer :: row, colm_pos, nloc, last_row - subroutine csr_dg_apply_mass_scalar(mass, field) - !!< return field=mass*field. This is basically an optimised in-place - !!< matrix multiply. - type(csr_matrix), intent(in) :: mass - type(scalar_field), intent(inout) :: field + row=1 + colm_pos=0 - integer :: row, colm_pos, nloc + if (present_and_true(only_owned_elements) .and. associated(mass%sparsity%row_halo)) then + last_row = halo_nowned_nodes(mass%sparsity%row_halo) + else + last_row = size(mass,1) + end if + + do + if(row>last_row) exit + nloc=row_length(mass, row) + inv_mass%val(colm_pos+1:colm_pos+nloc**2) & + = reshape(& + & inverse(& + & reshape(mass%val(colm_pos+1:colm_pos+nloc**2), & + & (/nloc,nloc/))& + & ), & + & (/nloc*nloc/)) + + row=row+nloc + colm_pos=colm_pos+nloc**2 + end do - row=0 - colm_pos=0 + if (present_and_true(only_owned_elements) .and. associated(mass%sparsity%row_halo)) then + ! rest is zeroed + inv_mass%val(colm_pos+1:)=0.0 + end if - do - if(row>=size(mass,1)) exit - nloc=row_length(mass, row+1) + end subroutine csr_dg_inverse_mass_from_mass - field%val(row+1:row+nloc) = & + subroutine csr_dg_apply_mass_scalar(mass, field) + !!< return field=mass*field. This is basically an optimised in-place + !!< matrix multiply. + type(csr_matrix), intent(in) :: mass + type(scalar_field), intent(inout) :: field + + integer :: row, colm_pos, nloc + + row=0 + colm_pos=0 + + do + if(row>=size(mass,1)) exit + nloc=row_length(mass, row+1) + + field%val(row+1:row+nloc) = & matmul(reshape(mass%val(colm_pos+1:colm_pos+nloc**2), & - & (/nloc,nloc/)), & - & field%val(row+1:row+nloc)) - - row=row+nloc - colm_pos=colm_pos+nloc**2 - end do - - end subroutine csr_dg_apply_mass_scalar - - subroutine block_csr_dg_apply_mass_vector(block_mass, v_field) - type(block_csr_matrix), intent(in) :: block_mass - type(vector_field), intent(in) :: v_field - ! - integer :: i - type(csr_matrix) :: mass_comp - type(scalar_field) :: s_field - ! - do i = 1, v_field%dim - mass_comp = block(block_mass,i,i) - s_field = extract_scalar_field_from_vector_field(v_field,i) - call dg_apply_mass(mass_comp,s_field) - end do - end subroutine block_csr_dg_apply_mass_vector - - subroutine csr_dg_add_mass(matrix, mass) - !!< Add mass to matrix. This is an optimised addto operation. - type(csr_matrix), intent(inout) :: matrix - type(csr_matrix), intent(in) :: mass - - integer :: row, colm_pos, nloc - - row=0 - colm_pos=0 - - do - if(row>=size(mass,1)) exit - nloc=row_length(mass, row+1) - - call addto(matrix, row_m_ptr(mass, row+1), row_m_ptr(mass, row+1), & - reshape(mass%val(colm_pos+1:colm_pos+nloc**2), & - & (/nloc,nloc/))) - - row=row+nloc - colm_pos=colm_pos+nloc**2 - end do - - end subroutine csr_dg_add_mass - - subroutine construct_inverse_mass_matrix_dg_scalar(inverse_mass, sfield, x) - !! This constructs the inverse mass matrix for a scalar field, - !! using options and bcs attached to the field. - type(csr_matrix), intent(out):: inverse_mass - type(scalar_field), intent(inout) :: sfield - type(vector_field), intent(inout) :: x - - integer, allocatable, dimension(:) :: sfield_bc_type - integer, allocatable, dimension(:) :: dirichlet_list - logical :: dirichlet - integer i, count - - ewrite(1,*) 'Construct the DG inverse mass matrix for a scalar field' - - allocate(sfield_bc_type(node_count(sfield))) - call get_boundary_condition_nodes(sfield, (/"dirichlet"/), sfield_bc_type) - if(any(sfield_bc_type==1)) then - dirichlet = .true. - else - dirichlet = .false. - end if - - if (dirichlet) then - - allocate(dirichlet_list(sum(sfield_bc_type))) - count = 0 - do i = 1, size(sfield_bc_type) - if(sfield_bc_type(i)==1) then - count = count + 1 - dirichlet_list(count) = i - end if + & (/nloc,nloc/)), & + & field%val(row+1:row+nloc)) + + row=row+nloc + colm_pos=colm_pos+nloc**2 end do - call get_dg_inverse_mass_matrix(inverse_mass,sfield%mesh, & - x, & - dirichlet_list=dirichlet_list, & - dirichlet_flag=DIRICHLET_BIG_SPRING) + end subroutine csr_dg_apply_mass_scalar + + subroutine block_csr_dg_apply_mass_vector(block_mass, v_field) + type(block_csr_matrix), intent(in) :: block_mass + type(vector_field), intent(in) :: v_field + ! + integer :: i + type(csr_matrix) :: mass_comp + type(scalar_field) :: s_field + ! + do i = 1, v_field%dim + mass_comp = block(block_mass,i,i) + s_field = extract_scalar_field_from_vector_field(v_field,i) + call dg_apply_mass(mass_comp,s_field) + end do + end subroutine block_csr_dg_apply_mass_vector - deallocate(dirichlet_list) + subroutine csr_dg_add_mass(matrix, mass) + !!< Add mass to matrix. This is an optimised addto operation. + type(csr_matrix), intent(inout) :: matrix + type(csr_matrix), intent(in) :: mass - else + integer :: row, colm_pos, nloc - ! the mass matrix has no dirichlet modifications - call get_dg_inverse_mass_matrix(inverse_mass,sfield%mesh, & - x) + row=0 + colm_pos=0 - end if + do + if(row>=size(mass,1)) exit + nloc=row_length(mass, row+1) - end subroutine construct_inverse_mass_matrix_dg_scalar + call addto(matrix, row_m_ptr(mass, row+1), row_m_ptr(mass, row+1), & + reshape(mass%val(colm_pos+1:colm_pos+nloc**2), & + & (/nloc,nloc/))) - subroutine construct_inverse_mass_matrix_dg_vector(inverse_mass, vfield, x) - !! This constructs the inverse mass matrix for all components - !! of a vector field, using options and bcs attached to the - !! field. This version is a bit slow (computes transform_to_physical - !! and inverses u%dim times, when diagonal mass blocks are different) - type(block_csr_matrix), intent(out):: inverse_mass - type(vector_field), intent(inout) :: vfield, x + row=row+nloc + colm_pos=colm_pos+nloc**2 + end do - type(csr_sparsity):: sparsity - type(csr_matrix):: inverse_mass_block - integer, allocatable, dimension(:,:) :: vfield_bc_type - integer, allocatable, dimension(:) :: dirichlet_list - logical :: dirichlet - integer i, dim, count + end subroutine csr_dg_add_mass - ewrite(1,*) 'Construct the DG inverse mass matrix for a vector field' + subroutine construct_inverse_mass_matrix_dg_scalar(inverse_mass, sfield, x) + !! This constructs the inverse mass matrix for a scalar field, + !! using options and bcs attached to the field. + type(csr_matrix), intent(out):: inverse_mass + type(scalar_field), intent(inout) :: sfield + type(vector_field), intent(inout) :: x - allocate(vfield_bc_type(vfield%dim, node_count(vfield))) - call get_boundary_condition_nodes(vfield, (/"dirichlet"/), vfield_bc_type) - if(any(vfield_bc_type==1)) then - dirichlet = .true. - else - dirichlet = .false. - end if + integer, allocatable, dimension(:) :: sfield_bc_type + integer, allocatable, dimension(:) :: dirichlet_list + logical :: dirichlet + integer i, count - if (dirichlet) then + ewrite(1,*) 'Construct the DG inverse mass matrix for a scalar field' - assert(vfield%mesh%continuity==-1) - sparsity=make_sparsity_dg_mass(vfield%mesh) - call allocate(inverse_mass, sparsity, (/ vfield%dim, vfield%dim /), & - name="DGInverseMass", diagonal=.true.) - ! Drop the extra reference to sparsity. - call deallocate(sparsity) + allocate(sfield_bc_type(node_count(sfield))) + call get_boundary_condition_nodes(sfield, (/"dirichlet"/), sfield_bc_type) + if(any(sfield_bc_type==1)) then + dirichlet = .true. + else + dirichlet = .false. + end if - do dim=1, vfield%dim + if (dirichlet) then - allocate(dirichlet_list(sum(vfield_bc_type(dim,:)))) + allocate(dirichlet_list(sum(sfield_bc_type))) count = 0 - do i = 1, size(vfield_bc_type(dim,:)) - if(vfield_bc_type(dim,i)==1) then - count = count + 1 - dirichlet_list(count) = i + do i = 1, size(sfield_bc_type) + if(sfield_bc_type(i)==1) then + count = count + 1 + dirichlet_list(count) = i end if end do - inverse_mass_block=block(inverse_mass, dim, dim) - call get_dg_inverse_mass_matrix(inverse_mass_block,vfield%mesh, & - x, & - dirichlet_list=dirichlet_list, & - dirichlet_flag=DIRICHLET_BIG_SPRING, & - allocate_matrix=.false.) + call get_dg_inverse_mass_matrix(inverse_mass,sfield%mesh, & + x, & + dirichlet_list=dirichlet_list, & + dirichlet_flag=DIRICHLET_BIG_SPRING) + + deallocate(dirichlet_list) + + else + + ! the mass matrix has no dirichlet modifications + call get_dg_inverse_mass_matrix(inverse_mass,sfield%mesh, & + x) + + end if + + end subroutine construct_inverse_mass_matrix_dg_scalar + + subroutine construct_inverse_mass_matrix_dg_vector(inverse_mass, vfield, x) + !! This constructs the inverse mass matrix for all components + !! of a vector field, using options and bcs attached to the + !! field. This version is a bit slow (computes transform_to_physical + !! and inverses u%dim times, when diagonal mass blocks are different) + type(block_csr_matrix), intent(out):: inverse_mass + type(vector_field), intent(inout) :: vfield, x + + type(csr_sparsity):: sparsity + type(csr_matrix):: inverse_mass_block + integer, allocatable, dimension(:,:) :: vfield_bc_type + integer, allocatable, dimension(:) :: dirichlet_list + logical :: dirichlet + integer i, dim, count + + ewrite(1,*) 'Construct the DG inverse mass matrix for a vector field' + + allocate(vfield_bc_type(vfield%dim, node_count(vfield))) + call get_boundary_condition_nodes(vfield, (/"dirichlet"/), vfield_bc_type) + if(any(vfield_bc_type==1)) then + dirichlet = .true. + else + dirichlet = .false. + end if + + if (dirichlet) then + + assert(vfield%mesh%continuity==-1) + sparsity=make_sparsity_dg_mass(vfield%mesh) + call allocate(inverse_mass, sparsity, (/ vfield%dim, vfield%dim /), & + name="DGInverseMass", diagonal=.true.) + ! Drop the extra reference to sparsity. + call deallocate(sparsity) + + do dim=1, vfield%dim + + allocate(dirichlet_list(sum(vfield_bc_type(dim,:)))) + count = 0 + do i = 1, size(vfield_bc_type(dim,:)) + if(vfield_bc_type(dim,i)==1) then + count = count + 1 + dirichlet_list(count) = i + end if + end do + + inverse_mass_block=block(inverse_mass, dim, dim) + call get_dg_inverse_mass_matrix(inverse_mass_block,vfield%mesh, & + x, & + dirichlet_list=dirichlet_list, & + dirichlet_flag=DIRICHLET_BIG_SPRING, & + allocate_matrix=.false.) + + deallocate(dirichlet_list) - deallocate(dirichlet_list) - - end do + end do - else + else - ! the mass matrix is the same for all components - assert(vfield%mesh%continuity==-1) - sparsity=make_sparsity_dg_mass(vfield%mesh) - call allocate(inverse_mass, sparsity, (/ vfield%dim, vfield%dim /), & - name="DGInverseMass", diagonal=.true., equal_diagonal_blocks=.true.) - ! Drop the extra reference to sparsity. - call deallocate(sparsity) + ! the mass matrix is the same for all components + assert(vfield%mesh%continuity==-1) + sparsity=make_sparsity_dg_mass(vfield%mesh) + call allocate(inverse_mass, sparsity, (/ vfield%dim, vfield%dim /), & + name="DGInverseMass", diagonal=.true., equal_diagonal_blocks=.true.) + ! Drop the extra reference to sparsity. + call deallocate(sparsity) - inverse_mass_block=block(inverse_mass, 1,1) - call get_dg_inverse_mass_matrix(inverse_mass_block,vfield%mesh, & - x) + inverse_mass_block=block(inverse_mass, 1,1) + call get_dg_inverse_mass_matrix(inverse_mass_block,vfield%mesh, & + x) - end if + end if - end subroutine construct_inverse_mass_matrix_dg_vector + end subroutine construct_inverse_mass_matrix_dg_vector end module dgtools diff --git a/femtools/Diagnostic_Fields.F90 b/femtools/Diagnostic_Fields.F90 index ee1211fcf8..9da31a19e0 100644 --- a/femtools/Diagnostic_Fields.F90 +++ b/femtools/Diagnostic_Fields.F90 @@ -28,1665 +28,1665 @@ #include "fdebug.h" module diagnostic_fields - !!< A module to calculate diagnostic fields. - - use fldebug - use global_parameters, only:FIELD_NAME_LEN, current_time, OPTION_PATH_LEN - use futils - use spud - use Vector_Tools - use parallel_tools - use quicksort - use sparse_tools - use CV_Faces - use fetools - use unittest_tools - use fields - use state_module - use halos - use boundary_conditions - use field_derivatives - use field_options - use sparse_matrices_fields - use fefields, only: compute_lumped_mass, compute_cv_mass - use MeshDiagnostics - use CV_Shape_Functions, only: make_cv_element_shape, make_cvbdy_element_shape - use CVTools - use cv_options - use CV_Upwind_Values - use CV_Face_Values, only: evaluate_face_val, theta_val - use sparsity_patterns - use sparsity_patterns_meshes - use solvers - use state_fields_module - use interpolation_module - use streamfunction - - implicit none - - private - - public :: insert_diagnostic_field, calculate_diagnostic_variable - public :: calculate_cfl_number, calculate_galerkin_projection - - interface calculate_diagnostic_variable - module procedure calculate_scalar_diagnostic_variable_single_state, & - & calculate_scalar_diagnostic_variable_multiple_states, & - & calculate_vector_diagnostic_variable_single_state, & - & calculate_vector_diagnostic_variable_multiple_states, & - & calculate_tensor_diagnostic_variable_single_state, & - & calculate_tensor_diagnostic_variable_multiple_states - end interface - - interface calculate_absolute_difference - module procedure calculate_absolute_difference_scalar, calculate_absolute_difference_vector - end interface - - interface calculate_galerkin_projection - module procedure calculate_galerkin_projection_scalar, calculate_galerkin_projection_vector, & - calculate_galerkin_projection_tensor - end interface + !!< A module to calculate diagnostic fields. + + use fldebug + use global_parameters, only:FIELD_NAME_LEN, current_time, OPTION_PATH_LEN + use futils + use spud + use Vector_Tools + use parallel_tools + use quicksort + use sparse_tools + use CV_Faces + use fetools + use unittest_tools + use fields + use state_module + use halos + use boundary_conditions + use field_derivatives + use field_options + use sparse_matrices_fields + use fefields, only: compute_lumped_mass, compute_cv_mass + use MeshDiagnostics + use CV_Shape_Functions, only: make_cv_element_shape, make_cvbdy_element_shape + use CVTools + use cv_options + use CV_Upwind_Values + use CV_Face_Values, only: evaluate_face_val, theta_val + use sparsity_patterns + use sparsity_patterns_meshes + use solvers + use state_fields_module + use interpolation_module + use streamfunction + + implicit none + + private + + public :: insert_diagnostic_field, calculate_diagnostic_variable + public :: calculate_cfl_number, calculate_galerkin_projection + + interface calculate_diagnostic_variable + module procedure calculate_scalar_diagnostic_variable_single_state, & + & calculate_scalar_diagnostic_variable_multiple_states, & + & calculate_vector_diagnostic_variable_single_state, & + & calculate_vector_diagnostic_variable_multiple_states, & + & calculate_tensor_diagnostic_variable_single_state, & + & calculate_tensor_diagnostic_variable_multiple_states + end interface + + interface calculate_absolute_difference + module procedure calculate_absolute_difference_scalar, calculate_absolute_difference_vector + end interface + + interface calculate_galerkin_projection + module procedure calculate_galerkin_projection_scalar, calculate_galerkin_projection_vector, & + calculate_galerkin_projection_tensor + end interface contains - subroutine insert_diagnostic_field(state, d_field_name, & - & d_field_mesh, d_field_rank, stat) - !!< Insert a new diagnostic field of specified rank into state - - type(state_type), intent(inout) :: state - character(len = *), intent(in) :: d_field_name - type(mesh_type), intent(inout) :: d_field_mesh - integer, intent(in) :: d_field_rank - integer, intent(out), optional :: stat - - type(scalar_field), pointer :: s_field - type(tensor_field), pointer :: t_field - type(vector_field), pointer :: v_field - - select case(d_field_rank) - case(0) - allocate(s_field) - call allocate(s_field, d_field_mesh, d_field_name) - call calculate_diagnostic_variable(state, d_field_name, s_field, & - & stat) - if(.not. present_and_zero(stat)) then - call insert(state, s_field, d_field_name) - end if - call deallocate(s_field) - deallocate(s_field) - case(1) - allocate(v_field) - call allocate(v_field, mesh_dim(d_field_mesh), d_field_mesh, & - & d_field_name) - call calculate_diagnostic_variable(state, d_field_name, v_field, & - & stat) - if(.not. present_and_zero(stat)) then - call insert(state, v_field, d_field_name) - end if - call deallocate(v_field) - deallocate(v_field) - case(2) - allocate(t_field) - call allocate(t_field, d_field_mesh, d_field_name) - call calculate_diagnostic_variable(state, d_field_name, t_field, & - & stat) - if(.not. present_and_zero(stat)) then - call insert(state, t_field, d_field_name) - end if - call deallocate(t_field) - deallocate(t_field) - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic field rank") - end if - end select - - end subroutine insert_diagnostic_field - - subroutine calculate_scalar_diagnostic_variable_single_state(state, d_field_name, d_field, stat, dt, option_path) - !!< Calculate the specified scalar diagnostic field d_field_name from state - !!< and return the field in d_field. - - type(state_type), intent(inout) :: state - character(len = *), intent(in) :: d_field_name - type(scalar_field), intent(inout) ::d_field - integer, optional, intent(out) :: stat - real, intent(in), optional :: dt - character(len=*), intent(in), optional :: option_path - - select case(d_field_name) - - case("CFLNumber") - call calculate_cfl_number(state, d_field, dt=dt) - - case("ControlVolumeCFLNumber") - call calculate_courant_number_cv(state, d_field, dt=dt) - - case("DG_CourantNumber") - call calculate_courant_number_DG(state, d_field, dt=dt) - - case("CVMaterialDensityCFLNumber") - call calculate_matdens_courant_number_cv(state, d_field, dt=dt) - - case("GridReynoldsNumber") - call calculate_grid_reynolds_number(state, d_field) - - case("GridPecletNumber") - call calculate_grid_peclet_number(state, d_field) - - case("HorizontalVelocityDivergence") - call calculate_horizontal_velocity_divergence(state, d_field, stat) - - case("KineticEnergyDensity") - call calculate_ke_density(state, d_field, stat) - - case("GravitationalPotentialEnergyDensity") - call calculate_pe_density(state, d_field, stat) - - case("IsopycnalCoordinate") - call calculate_isopycnal_coordinate(state, d_field, stat) - - case("BackgroundPotentialEnergyDensity") - call calculate_back_pe_density(state, d_field, stat) - - case("HorizontalStreamFunction") - call calculate_horizontal_streamfunction(state, d_field) - - case("StreamFunction") - call calculate_stream_function_2d(state, d_field, stat) + subroutine insert_diagnostic_field(state, d_field_name, & + & d_field_mesh, d_field_rank, stat) + !!< Insert a new diagnostic field of specified rank into state - CASE("MultiplyConnectedStreamFunction") - call calculate_stream_function_multipath_2d(state, d_field) + type(state_type), intent(inout) :: state + character(len = *), intent(in) :: d_field_name + type(mesh_type), intent(inout) :: d_field_mesh + integer, intent(in) :: d_field_rank + integer, intent(out), optional :: stat + + type(scalar_field), pointer :: s_field + type(tensor_field), pointer :: t_field + type(vector_field), pointer :: v_field + + select case(d_field_rank) + case(0) + allocate(s_field) + call allocate(s_field, d_field_mesh, d_field_name) + call calculate_diagnostic_variable(state, d_field_name, s_field, & + & stat) + if(.not. present_and_zero(stat)) then + call insert(state, s_field, d_field_name) + end if + call deallocate(s_field) + deallocate(s_field) + case(1) + allocate(v_field) + call allocate(v_field, mesh_dim(d_field_mesh), d_field_mesh, & + & d_field_name) + call calculate_diagnostic_variable(state, d_field_name, v_field, & + & stat) + if(.not. present_and_zero(stat)) then + call insert(state, v_field, d_field_name) + end if + call deallocate(v_field) + deallocate(v_field) + case(2) + allocate(t_field) + call allocate(t_field, d_field_mesh, d_field_name) + call calculate_diagnostic_variable(state, d_field_name, t_field, & + & stat) + if(.not. present_and_zero(stat)) then + call insert(state, t_field, d_field_name) + end if + call deallocate(t_field) + deallocate(t_field) + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic field rank") + end if + end select + + end subroutine insert_diagnostic_field + + subroutine calculate_scalar_diagnostic_variable_single_state(state, d_field_name, d_field, stat, dt, option_path) + !!< Calculate the specified scalar diagnostic field d_field_name from state + !!< and return the field in d_field. + + type(state_type), intent(inout) :: state + character(len = *), intent(in) :: d_field_name + type(scalar_field), intent(inout) ::d_field + integer, optional, intent(out) :: stat + real, intent(in), optional :: dt + character(len=*), intent(in), optional :: option_path - case("Time") - call set(d_field, current_time) + select case(d_field_name) - case("VelocityDivergence") - call calculate_velocity_divergence(state, d_field, stat) + case("CFLNumber") + call calculate_cfl_number(state, d_field, dt=dt) - case("Speed") - call calculate_speed(state, d_field, stat) + case("ControlVolumeCFLNumber") + call calculate_courant_number_cv(state, d_field, dt=dt) - case("DiffusiveDissipation") - call calculate_diffusive_dissipation(state, d_field, stat) + case("DG_CourantNumber") + call calculate_courant_number_DG(state, d_field, dt=dt) - case("RichardsonNumber") - call calculate_richardson_number_new(state, d_field) + case("CVMaterialDensityCFLNumber") + call calculate_matdens_courant_number_cv(state, d_field, dt=dt) - case("AbsoluteDifference") - call calculate_absolute_difference(state, d_field) + case("GridReynoldsNumber") + call calculate_grid_reynolds_number(state, d_field) - case("GalerkinProjection") - call calculate_galerkin_projection(state, d_field) + case("GridPecletNumber") + call calculate_grid_peclet_number(state, d_field) - case("UniversalNumber") - call calculate_universal_number(d_field) + case("HorizontalVelocityDivergence") + call calculate_horizontal_velocity_divergence(state, d_field, stat) - case("NodeOwner") - call calculate_node_owner(d_field) + case("KineticEnergyDensity") + call calculate_ke_density(state, d_field, stat) - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic scalar field name supplied") - end if + case("GravitationalPotentialEnergyDensity") + call calculate_pe_density(state, d_field, stat) - end select + case("IsopycnalCoordinate") + call calculate_isopycnal_coordinate(state, d_field, stat) - end subroutine calculate_scalar_diagnostic_variable_single_state + case("BackgroundPotentialEnergyDensity") + call calculate_back_pe_density(state, d_field, stat) - subroutine calculate_scalar_diagnostic_variable_multiple_states(state, d_field_name, d_field, stat) - !!< Calculate the specified scalar diagnostic field d_field_name from - !!< the supplied states and return the field in d_field. + case("HorizontalStreamFunction") + call calculate_horizontal_streamfunction(state, d_field) - type(state_type), dimension(:), intent(in) :: state - character(len = *), intent(in) :: d_field_name - type(scalar_field), intent(inout) :: d_field - integer, optional, intent(out) :: stat + case("StreamFunction") + call calculate_stream_function_2d(state, d_field, stat) - select case(d_field_name) + CASE("MultiplyConnectedStreamFunction") + call calculate_stream_function_multipath_2d(state, d_field) - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic scalar field name supplied") - end if + case("Time") + call set(d_field, current_time) - end select + case("VelocityDivergence") + call calculate_velocity_divergence(state, d_field, stat) - end subroutine calculate_scalar_diagnostic_variable_multiple_states + case("Speed") + call calculate_speed(state, d_field, stat) - subroutine calculate_vector_diagnostic_variable_single_state(state, d_field_name, & - & d_field, stat) - !!< Calculate the specified vector diagnostic field d_field_name from - !!< state and return the field in d_field. + case("DiffusiveDissipation") + call calculate_diffusive_dissipation(state, d_field, stat) - type(state_type), intent(inout) :: state - character(len = *), intent(in) :: d_field_name - type(vector_field), intent(inout) :: d_field - integer, optional, intent(out) :: stat + case("RichardsonNumber") + call calculate_richardson_number_new(state, d_field) - select case(d_field_name) + case("AbsoluteDifference") + call calculate_absolute_difference(state, d_field) - ! Inner element fields + case("GalerkinProjection") + call calculate_galerkin_projection(state, d_field) - case("InnerElementFullVelocity") - call calculate_sgs_full_velocity(state, d_field, stat) + case("UniversalNumber") + call calculate_universal_number(d_field) - case("InnerElementFullVorticity") - call calculate_sgs_full_vorticity(state, d_field, stat) + case("NodeOwner") + call calculate_node_owner(d_field) - case("InnerElementVorticity") - call calculate_sgs_vorticity(state, d_field, stat) + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic scalar field name supplied") + end if - case("DgMappedVelocity") - call calculate_dg_mapped_cg_velocity(state, d_field, stat) + end select - case("DgMappedVorticity") - call calculate_dg_mapped_cg_vorticity(state, d_field, stat) + end subroutine calculate_scalar_diagnostic_variable_single_state - ! Inner element fields end + subroutine calculate_scalar_diagnostic_variable_multiple_states(state, d_field_name, d_field, stat) + !!< Calculate the specified scalar diagnostic field d_field_name from + !!< the supplied states and return the field in d_field. - case("LinearMomentum") - call calculate_linear_momentum(state, d_field) + type(state_type), dimension(:), intent(in) :: state + character(len = *), intent(in) :: d_field_name + type(scalar_field), intent(inout) :: d_field + integer, optional, intent(out) :: stat - case("AbsoluteDifference") - call calculate_absolute_difference(state, d_field) + select case(d_field_name) - case("BedShearStress") - call calculate_bed_shear_stress(state, d_field) + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic scalar field name supplied") + end if - case("MaxBedShearStress") - call calculate_max_bed_shear_stress(state, d_field) + end select - case("GalerkinProjection") - call calculate_galerkin_projection(state, d_field) + end subroutine calculate_scalar_diagnostic_variable_multiple_states - case("DiagnosticCoordinate") - call calculate_diagnostic_coordinate_field(state, d_field) + subroutine calculate_vector_diagnostic_variable_single_state(state, d_field_name, & + & d_field, stat) + !!< Calculate the specified vector diagnostic field d_field_name from + !!< state and return the field in d_field. - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic vector field name supplied") - end if + type(state_type), intent(inout) :: state + character(len = *), intent(in) :: d_field_name + type(vector_field), intent(inout) :: d_field + integer, optional, intent(out) :: stat + + select case(d_field_name) - end select + ! Inner element fields - end subroutine calculate_vector_diagnostic_variable_single_state + case("InnerElementFullVelocity") + call calculate_sgs_full_velocity(state, d_field, stat) - subroutine calculate_vector_diagnostic_variable_multiple_states(state, d_field_name, d_field, stat) - !!< Calculate the specified vector diagnostic field d_field_name from - !!< the supplied states and return the field in d_field. + case("InnerElementFullVorticity") + call calculate_sgs_full_vorticity(state, d_field, stat) - type(state_type), dimension(:), intent(in) :: state - character(len = *), intent(in) :: d_field_name - type(vector_field), intent(inout) ::d_field - integer, optional, intent(out) :: stat + case("InnerElementVorticity") + call calculate_sgs_vorticity(state, d_field, stat) - select case(d_field_name) + case("DgMappedVelocity") + call calculate_dg_mapped_cg_velocity(state, d_field, stat) - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic vector field name supplied") - end if + case("DgMappedVorticity") + call calculate_dg_mapped_cg_vorticity(state, d_field, stat) - end select + ! Inner element fields end - end subroutine calculate_vector_diagnostic_variable_multiple_states + case("LinearMomentum") + call calculate_linear_momentum(state, d_field) - subroutine calculate_tensor_diagnostic_variable_single_state(state, d_field_name, & - & d_field, stat) - !!< Calculate the specified tensor diagnostic field d_field_name from - !!< state and return the field in d_field. + case("AbsoluteDifference") + call calculate_absolute_difference(state, d_field) - type(state_type), intent(in) :: state - character(len = *), intent(in) :: d_field_name - type(tensor_field), intent(inout) :: d_field - integer, optional, intent(out) :: stat + case("BedShearStress") + call calculate_bed_shear_stress(state, d_field) - select case(d_field_name) + case("MaxBedShearStress") + call calculate_max_bed_shear_stress(state, d_field) - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic tensor field name supplied") - end if + case("GalerkinProjection") + call calculate_galerkin_projection(state, d_field) - end select + case("DiagnosticCoordinate") + call calculate_diagnostic_coordinate_field(state, d_field) - end subroutine calculate_tensor_diagnostic_variable_single_state + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic vector field name supplied") + end if + + end select - subroutine calculate_tensor_diagnostic_variable_multiple_states(state, d_field_name, d_field, stat) - !!< Calculate the specified tensor diagnostic field d_field_name from - !!< the supplied states and return the field in d_field. + end subroutine calculate_vector_diagnostic_variable_single_state - type(state_type), dimension(:), intent(in) :: state - character(len = *), intent(in) :: d_field_name - type(tensor_field), intent(inout) ::d_field - integer, optional, intent(out) :: stat + subroutine calculate_vector_diagnostic_variable_multiple_states(state, d_field_name, d_field, stat) + !!< Calculate the specified vector diagnostic field d_field_name from + !!< the supplied states and return the field in d_field. + + type(state_type), dimension(:), intent(in) :: state + character(len = *), intent(in) :: d_field_name + type(vector_field), intent(inout) ::d_field + integer, optional, intent(out) :: stat + + select case(d_field_name) + + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic vector field name supplied") + end if + + end select + + end subroutine calculate_vector_diagnostic_variable_multiple_states + + subroutine calculate_tensor_diagnostic_variable_single_state(state, d_field_name, & + & d_field, stat) + !!< Calculate the specified tensor diagnostic field d_field_name from + !!< state and return the field in d_field. + + type(state_type), intent(in) :: state + character(len = *), intent(in) :: d_field_name + type(tensor_field), intent(inout) :: d_field + integer, optional, intent(out) :: stat + + select case(d_field_name) + + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic tensor field name supplied") + end if + + end select + + end subroutine calculate_tensor_diagnostic_variable_single_state + + subroutine calculate_tensor_diagnostic_variable_multiple_states(state, d_field_name, d_field, stat) + !!< Calculate the specified tensor diagnostic field d_field_name from + !!< the supplied states and return the field in d_field. + + type(state_type), dimension(:), intent(in) :: state + character(len = *), intent(in) :: d_field_name + type(tensor_field), intent(inout) ::d_field + integer, optional, intent(out) :: stat + + select case(d_field_name) + + case default + if(present(stat)) then + stat = 1 + return + else + FLExit("Invalid diagnostic tensor field name supplied") + end if + + end select - select case(d_field_name) - - case default - if(present(stat)) then - stat = 1 - return - else - FLExit("Invalid diagnostic tensor field name supplied") - end if - - end select - - end subroutine calculate_tensor_diagnostic_variable_multiple_states - - subroutine calculate_CFL_number(State, CFL, dt) - !! Calculate the CFL number as a field. - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: cfl - real, intent(in), optional :: dt - - type(vector_field), pointer :: U, X - real :: l_dt - integer :: ele, gi - ! Transformed quadrature weights. - real, dimension(ele_ngi(CFL, 1)) :: detwei - ! Inverse of the local coordinate change matrix. - real, dimension(mesh_dim(CFL), mesh_dim(CFL), ele_ngi(CFL, 1)) :: invJ - ! velocity/dx at each quad point. - real, dimension(mesh_dim(CFL), ele_ngi(CFL, 1)) :: CFL_q - ! current element global node numbers. - integer, dimension(:), pointer :: ele_cfl - ! local cfl matrix on the current element. - real, dimension(ele_loc(CFL, 1),ele_loc(CFL, 1)) :: CFL_mat - ! current CFL element shape - type(element_type), pointer :: CFL_shape - - U=>extract_vector_field(state, "Velocity") - X=>extract_vector_field(state, "Coordinate") - - if(present(dt)) then - l_dt = dt - else - call get_option("/timestepping/timestep",l_dt) - end if - assert(allfequals(l_dt)) - - call zero(cfl) - - do ele=1, element_count(CFL) - ele_CFL=>ele_nodes(CFL, ele) - CFL_shape=>ele_shape(CFL, ele) - - call compute_inverse_jacobian(X, ele, detwei=detwei, invJ=invJ) - - ! Calculate the CFL number at each quadrature point. - ! The matmul is the transpose of what I originally thought it should - ! be. I don't understand why it's this way round but the results - ! appear correct. -dham - CFL_q=ele_val_at_quad(U, ele) - do gi=1, size(detwei) - CFL_q(:,gi)=l_dt*matmul(CFL_q(:,gi), invJ(:,:,gi)) - end do - - ! Project onto the basis functions to recover CFL at each node. - CFL_mat=matmul(inverse(shape_shape(CFL_shape, CFL_shape, detwei)), & + end subroutine calculate_tensor_diagnostic_variable_multiple_states + + subroutine calculate_CFL_number(State, CFL, dt) + !! Calculate the CFL number as a field. + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: cfl + real, intent(in), optional :: dt + + type(vector_field), pointer :: U, X + real :: l_dt + integer :: ele, gi + ! Transformed quadrature weights. + real, dimension(ele_ngi(CFL, 1)) :: detwei + ! Inverse of the local coordinate change matrix. + real, dimension(mesh_dim(CFL), mesh_dim(CFL), ele_ngi(CFL, 1)) :: invJ + ! velocity/dx at each quad point. + real, dimension(mesh_dim(CFL), ele_ngi(CFL, 1)) :: CFL_q + ! current element global node numbers. + integer, dimension(:), pointer :: ele_cfl + ! local cfl matrix on the current element. + real, dimension(ele_loc(CFL, 1),ele_loc(CFL, 1)) :: CFL_mat + ! current CFL element shape + type(element_type), pointer :: CFL_shape + + U=>extract_vector_field(state, "Velocity") + X=>extract_vector_field(state, "Coordinate") + + if(present(dt)) then + l_dt = dt + else + call get_option("/timestepping/timestep",l_dt) + end if + assert(allfequals(l_dt)) + + call zero(cfl) + + do ele=1, element_count(CFL) + ele_CFL=>ele_nodes(CFL, ele) + CFL_shape=>ele_shape(CFL, ele) + + call compute_inverse_jacobian(X, ele, detwei=detwei, invJ=invJ) + + ! Calculate the CFL number at each quadrature point. + ! The matmul is the transpose of what I originally thought it should + ! be. I don't understand why it's this way round but the results + ! appear correct. -dham + CFL_q=ele_val_at_quad(U, ele) + do gi=1, size(detwei) + CFL_q(:,gi)=l_dt*matmul(CFL_q(:,gi), invJ(:,:,gi)) + end do + + ! Project onto the basis functions to recover CFL at each node. + CFL_mat=matmul(inverse(shape_shape(CFL_shape, CFL_shape, detwei)), & shape_shape(CFL_shape, CFL_shape, & - & detwei*maxval(abs(CFL_q),1))) - - ! CFL is inherently discontinuous. In the case where a continuous - ! mesh is provided for CFL, the following takes the safest option - ! of taking the maximum value at a node. - CFL%val(ele_CFL)=max(CFL%val(ele_CFL), sum(CFL_mat,2)) - - end do - - !call halo_max(cfl) - - end subroutine calculate_CFL_number - - subroutine calculate_grid_reynolds_number(State, GRN) - !! Calculate the grid reynolds number as a field. - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: grn - - type(vector_field), pointer :: U, X - integer :: ele, gi, stat, a, b - ! Transformed quadrature weights. - real, dimension(ele_ngi(GRN, 1)) :: detwei - ! Inverse of the local coordinate change matrix. - real, dimension(mesh_dim(GRN), mesh_dim(GRN), ele_ngi(GRN, 1)) :: J - ! velocity/dx at each quad point. - real, dimension(mesh_dim(GRN), ele_ngi(GRN, 1)) :: GRN_q - ! viscosity at each quad point - real, dimension(mesh_dim(GRN), mesh_dim(GRN), ele_ngi(GRN,1)) :: vis_q - ! density at each quad point - real, dimension(ele_ngi(GRN,1)) :: den_q - ! current element global node numbers. - integer, dimension(:), pointer :: ele_grn - ! local grn matrix on the current element. - real, dimension(ele_loc(GRN, 1),ele_loc(GRN, 1)) :: GRN_mat - ! current GRN element shape - type(element_type), pointer :: GRN_shape - type(tensor_field), pointer :: viscosity - type(scalar_field), pointer :: density - logical :: include_density_field, use_stress_form - - U=>extract_vector_field(state, "Velocity") - X=>extract_vector_field(state, "Coordinate") - - call zero(grn) - - viscosity => extract_tensor_field(state,'Viscosity') - - include_density_field = have_option(trim(GRN%option_path)//'/diagnostic/include_density_field') - - if (include_density_field) then - density => extract_scalar_field(state,'Density', stat = stat) - if (stat /= 0) then - FLExit('To include the Density field in the Grid Reynolds number calculation Density must exist in the material_phase state') - end if - end if - - if (have_option(trim(U%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/stress_terms/stress_form") .or. & - have_option(trim(U%option_path)//& - &"/prognostic/spatial_discretisation/continuous_galerkin"//& - &"/stress_terms/partial_stress_form")) then - use_stress_form = .true. - else - use_stress_form = .false. - end if - - do ele=1, element_count(GRN) - ele_GRN=>ele_nodes(GRN, ele) - GRN_shape=>ele_shape(GRN, ele) - - call compute_jacobian(X, ele, J=J, detwei=detwei) - - ! Calculate the GRN number at each quadrature point. - ! The matmul is as given by dham - GRN_q=ele_val_at_quad(U, ele) - vis_q=ele_val_at_quad(viscosity, ele) - - ! for full and partial stress form we need to set the off diagonal terms of the viscosity tensor to zero - ! to be able to invert it - if (use_stress_form) then - do a=1,size(vis_q,1) - do b=1,size(vis_q,2) - if(a.eq.b) cycle - vis_q(a,b,:) = 0.0 - end do - end do - end if - - do gi=1, size(detwei) - GRN_q(:,gi)=matmul(GRN_q(:,gi), J(:,:,gi)) - GRN_q(:,gi)=matmul(inverse(vis_q(:,:,gi)), GRN_q(:,gi)) - end do - - ! include the density field if required also at the quad point - if (include_density_field) then - den_q=ele_val_at_quad(density, ele) - do gi=1,size(detwei) - GRN_q(:,gi)=den_q(gi)*GRN_q(:,gi) - end do - end if - - ! Project onto the basis functions to recover GRN at each node. - GRN_mat=matmul(inverse(shape_shape(GRN_shape, GRN_shape, detwei)), & + & detwei*maxval(abs(CFL_q),1))) + + ! CFL is inherently discontinuous. In the case where a continuous + ! mesh is provided for CFL, the following takes the safest option + ! of taking the maximum value at a node. + CFL%val(ele_CFL)=max(CFL%val(ele_CFL), sum(CFL_mat,2)) + + end do + + !call halo_max(cfl) + + end subroutine calculate_CFL_number + + subroutine calculate_grid_reynolds_number(State, GRN) + !! Calculate the grid reynolds number as a field. + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: grn + + type(vector_field), pointer :: U, X + integer :: ele, gi, stat, a, b + ! Transformed quadrature weights. + real, dimension(ele_ngi(GRN, 1)) :: detwei + ! Inverse of the local coordinate change matrix. + real, dimension(mesh_dim(GRN), mesh_dim(GRN), ele_ngi(GRN, 1)) :: J + ! velocity/dx at each quad point. + real, dimension(mesh_dim(GRN), ele_ngi(GRN, 1)) :: GRN_q + ! viscosity at each quad point + real, dimension(mesh_dim(GRN), mesh_dim(GRN), ele_ngi(GRN,1)) :: vis_q + ! density at each quad point + real, dimension(ele_ngi(GRN,1)) :: den_q + ! current element global node numbers. + integer, dimension(:), pointer :: ele_grn + ! local grn matrix on the current element. + real, dimension(ele_loc(GRN, 1),ele_loc(GRN, 1)) :: GRN_mat + ! current GRN element shape + type(element_type), pointer :: GRN_shape + type(tensor_field), pointer :: viscosity + type(scalar_field), pointer :: density + logical :: include_density_field, use_stress_form + + U=>extract_vector_field(state, "Velocity") + X=>extract_vector_field(state, "Coordinate") + + call zero(grn) + + viscosity => extract_tensor_field(state,'Viscosity') + + include_density_field = have_option(trim(GRN%option_path)//'/diagnostic/include_density_field') + + if (include_density_field) then + density => extract_scalar_field(state,'Density', stat = stat) + if (stat /= 0) then + FLExit('To include the Density field in the Grid Reynolds number calculation Density must exist in the material_phase state') + end if + end if + + if (have_option(trim(U%option_path)//& + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/stress_terms/stress_form") .or. & + have_option(trim(U%option_path)//& + &"/prognostic/spatial_discretisation/continuous_galerkin"//& + &"/stress_terms/partial_stress_form")) then + use_stress_form = .true. + else + use_stress_form = .false. + end if + + do ele=1, element_count(GRN) + ele_GRN=>ele_nodes(GRN, ele) + GRN_shape=>ele_shape(GRN, ele) + + call compute_jacobian(X, ele, J=J, detwei=detwei) + + ! Calculate the GRN number at each quadrature point. + ! The matmul is as given by dham + GRN_q=ele_val_at_quad(U, ele) + vis_q=ele_val_at_quad(viscosity, ele) + + ! for full and partial stress form we need to set the off diagonal terms of the viscosity tensor to zero + ! to be able to invert it + if (use_stress_form) then + do a=1,size(vis_q,1) + do b=1,size(vis_q,2) + if(a.eq.b) cycle + vis_q(a,b,:) = 0.0 + end do + end do + end if + + do gi=1, size(detwei) + GRN_q(:,gi)=matmul(GRN_q(:,gi), J(:,:,gi)) + GRN_q(:,gi)=matmul(inverse(vis_q(:,:,gi)), GRN_q(:,gi)) + end do + + ! include the density field if required also at the quad point + if (include_density_field) then + den_q=ele_val_at_quad(density, ele) + do gi=1,size(detwei) + GRN_q(:,gi)=den_q(gi)*GRN_q(:,gi) + end do + end if + + ! Project onto the basis functions to recover GRN at each node. + GRN_mat=matmul(inverse(shape_shape(GRN_shape, GRN_shape, detwei)), & shape_shape(GRN_shape, GRN_shape, & - & detwei*maxval(abs(GRN_q),1))) - - ! GRN is inherently discontinuous. In the case where a continuous - ! mesh is provided for GRN, the following takes the safest option - ! of taking the maximum value at a node. - GRN%val(ele_GRN)=max(GRN%val(ele_GRN), sum(GRN_mat,2)) - - end do - - end subroutine calculate_grid_reynolds_number - - subroutine calculate_grid_peclet_number(State, GPN) - !! Calculate the grid peclet number as a field. - !! Basically a rehash of the grid reynolds number calculation - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: gpn - - type(vector_field), pointer :: U, X - integer :: ele, gi, stat - ! Transformed quadrature weights. - real, dimension(ele_ngi(GPN, 1)) :: detwei - ! Inverse of the local coordinate change matrix. - real, dimension(mesh_dim(GPN), mesh_dim(GPN), ele_ngi(GPN, 1)) :: J - ! velocity/dx at each quad point. - real, dimension(mesh_dim(GPN), ele_ngi(GPN, 1)) :: GPN_q - real, dimension(mesh_dim(GPN), mesh_dim(GPN), ele_ngi(GPN,1)) :: diffus_q - ! current element global node numbers. - integer, dimension(:), pointer :: ele_gpn - ! local grn matrix on the current element. - real, dimension(ele_loc(GPN, 1),ele_loc(GPN, 1)) :: GPN_mat - ! current GPN element shape - type(element_type), pointer :: GPN_shape - type(tensor_field), pointer :: diffusivity - character(len=FIELD_NAME_LEN) :: field_name - - U=>extract_vector_field(state, "Velocity") - X=>extract_vector_field(state, "Coordinate") - - call zero(gpn) - - call get_option(trim(GPN%option_path)//"/diagnostic/field_name", field_name) - - diffusivity => extract_tensor_field(state,trim(field_name)//'Diffusivity& - &',stat=stat) - - if(stat/=0) then - - FLExit("Can't calculate Peclet number, no diffusivity") - else - - do ele=1, element_count(GPN) - ele_GPN=>ele_nodes(GPN, ele) - GPN_shape=>ele_shape(GPN, ele) - - call compute_jacobian(X, ele, J=J, detwei=detwei) - - ! Calculate the GPN number at each quadrature point. - ! The matmul is as given by dham - GPN_q=ele_val_at_quad(U, ele) - diffus_q=ele_val_at_quad(diffusivity, ele) - do gi=1, size(detwei) - GPN_q(:,gi)=matmul(GPN_q(:,gi), J(:,:,gi)) - GPN_q(:,gi)=matmul(inverse(diffus_q(:,:,gi)), GPN_q(:,gi)) - end do - - ! Project onto the basis functions to recover GPN at each node. - GPN_mat=matmul(inverse(shape_shape(GPN_shape, GPN_shape, detwei)), & - shape_shape(GPN_shape, GPN_shape, & + & detwei*maxval(abs(GRN_q),1))) + + ! GRN is inherently discontinuous. In the case where a continuous + ! mesh is provided for GRN, the following takes the safest option + ! of taking the maximum value at a node. + GRN%val(ele_GRN)=max(GRN%val(ele_GRN), sum(GRN_mat,2)) + + end do + + end subroutine calculate_grid_reynolds_number + + subroutine calculate_grid_peclet_number(State, GPN) + !! Calculate the grid peclet number as a field. + !! Basically a rehash of the grid reynolds number calculation + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: gpn + + type(vector_field), pointer :: U, X + integer :: ele, gi, stat + ! Transformed quadrature weights. + real, dimension(ele_ngi(GPN, 1)) :: detwei + ! Inverse of the local coordinate change matrix. + real, dimension(mesh_dim(GPN), mesh_dim(GPN), ele_ngi(GPN, 1)) :: J + ! velocity/dx at each quad point. + real, dimension(mesh_dim(GPN), ele_ngi(GPN, 1)) :: GPN_q + real, dimension(mesh_dim(GPN), mesh_dim(GPN), ele_ngi(GPN,1)) :: diffus_q + ! current element global node numbers. + integer, dimension(:), pointer :: ele_gpn + ! local grn matrix on the current element. + real, dimension(ele_loc(GPN, 1),ele_loc(GPN, 1)) :: GPN_mat + ! current GPN element shape + type(element_type), pointer :: GPN_shape + type(tensor_field), pointer :: diffusivity + character(len=FIELD_NAME_LEN) :: field_name + + U=>extract_vector_field(state, "Velocity") + X=>extract_vector_field(state, "Coordinate") + + call zero(gpn) + + call get_option(trim(GPN%option_path)//"/diagnostic/field_name", field_name) + + diffusivity => extract_tensor_field(state,trim(field_name)//'Diffusivity& + &',stat=stat) + + if(stat/=0) then + + FLExit("Can't calculate Peclet number, no diffusivity") + else + + do ele=1, element_count(GPN) + ele_GPN=>ele_nodes(GPN, ele) + GPN_shape=>ele_shape(GPN, ele) + + call compute_jacobian(X, ele, J=J, detwei=detwei) + + ! Calculate the GPN number at each quadrature point. + ! The matmul is as given by dham + GPN_q=ele_val_at_quad(U, ele) + diffus_q=ele_val_at_quad(diffusivity, ele) + do gi=1, size(detwei) + GPN_q(:,gi)=matmul(GPN_q(:,gi), J(:,:,gi)) + GPN_q(:,gi)=matmul(inverse(diffus_q(:,:,gi)), GPN_q(:,gi)) + end do + + ! Project onto the basis functions to recover GPN at each node. + GPN_mat=matmul(inverse(shape_shape(GPN_shape, GPN_shape, detwei)), & + shape_shape(GPN_shape, GPN_shape, & & detwei*maxval(abs(GPN_q),1))) - ! GRN is inherently discontinuous. In the case where a continuous - ! mesh is provided for GRN, the following takes the safest option - ! of taking the maximum value at a node. - GPN%val(ele_GPN)=max(GPN%val(ele_GPN), sum(GPN_mat,2)) + ! GRN is inherently discontinuous. In the case where a continuous + ! mesh is provided for GRN, the following takes the safest option + ! of taking the maximum value at a node. + GPN%val(ele_GPN)=max(GPN%val(ele_GPN), sum(GPN_mat,2)) - end do + end do - end if + end if - end subroutine calculate_grid_peclet_number + end subroutine calculate_grid_peclet_number - subroutine calculate_horizontal_velocity_divergence(state, hveld_field, stat) - !!< Calculate the horizontal velocity divergence field + subroutine calculate_horizontal_velocity_divergence(state, hveld_field, stat) + !!< Calculate the horizontal velocity divergence field - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: hveld_field - integer, intent(out), optional :: stat + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: hveld_field + integer, intent(out), optional :: stat - integer :: i - type(vector_field) :: hvel_field - type(vector_field), pointer :: g_direction_field, positions, vel_field + integer :: i + type(vector_field) :: hvel_field + type(vector_field), pointer :: g_direction_field, positions, vel_field - do i = 1, 3 - select case(i) - case(1) - g_direction_field => extract_vector_field(state, "GravityDirection", & + do i = 1, 3 + select case(i) + case(1) + g_direction_field => extract_vector_field(state, "GravityDirection", & & stat) - case(2) - positions => extract_vector_field(state, "Coordinate", stat) - case(3) - vel_field => extract_vector_field(state, "Velocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return - end if - end do + case(2) + positions => extract_vector_field(state, "Coordinate", stat) + case(3) + vel_field => extract_vector_field(state, "Velocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do - call allocate(hvel_field, mesh_dim(vel_field%mesh), vel_field%mesh, & + call allocate(hvel_field, mesh_dim(vel_field%mesh), vel_field%mesh, & & "HorizontalVelocity") - if (continuity(vel_field)<0 .or. & - element_degree(vel_field,1)/=element_degree(g_direction_field,1)) then - FLExit("HorizontalVelocityDivergence does not work for discontinuous or higher order fields.") - end if + if (continuity(vel_field)<0 .or. & + element_degree(vel_field,1)/=element_degree(g_direction_field,1)) then + FLExit("HorizontalVelocityDivergence does not work for discontinuous or higher order fields.") + end if - do i = 1, node_count(hvel_field) - call set(hvel_field, i, node_val(vel_field, i) - & - & dot_product(node_val(vel_field, i), & - & node_val(g_direction_field, i)) * node_val(g_direction_field, i)) - end do + do i = 1, node_count(hvel_field) + call set(hvel_field, i, node_val(vel_field, i) - & + & dot_product(node_val(vel_field, i), & + & node_val(g_direction_field, i)) * node_val(g_direction_field, i)) + end do - call div(hvel_field, positions, hveld_field) + call div(hvel_field, positions, hveld_field) - call deallocate(hvel_field) + call deallocate(hvel_field) - end subroutine calculate_horizontal_velocity_divergence + end subroutine calculate_horizontal_velocity_divergence - subroutine calculate_ke_density(state, ke_density_field, stat) - !!< Calculate the kinetic energy density field - !!< Beware what your "Density" is! + subroutine calculate_ke_density(state, ke_density_field, stat) + !!< Calculate the kinetic energy density field + !!< Beware what your "Density" is! - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: ke_density_field - integer, intent(out), optional :: stat + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: ke_density_field + integer, intent(out), optional :: stat - integer :: i - type(scalar_field), pointer :: rho_field - type(vector_field), pointer :: vel_field + integer :: i + type(scalar_field), pointer :: rho_field + type(vector_field), pointer :: vel_field + + do i = 1, 2 + select case(i) + case(1) + rho_field => extract_scalar_field(state, "Density", stat) + case(2) + vel_field => extract_vector_field(state, "Velocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do - do i = 1, 2 - select case(i) - case(1) - rho_field => extract_scalar_field(state, "Density", stat) - case(2) - vel_field => extract_vector_field(state, "Velocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return + if(present(stat) .and. (.not. rho_field%mesh == ke_density_field%mesh & + & .or. .not. vel_field%mesh == ke_density_field%mesh)) then + stat = 1 + return + else + assert(rho_field%mesh == ke_density_field%mesh) + assert(vel_field%mesh == ke_density_field%mesh) end if - end do - if(present(stat) .and. (.not. rho_field%mesh == ke_density_field%mesh & - & .or. .not. vel_field%mesh == ke_density_field%mesh)) then - stat = 1 - return - else - assert(rho_field%mesh == ke_density_field%mesh) - assert(vel_field%mesh == ke_density_field%mesh) - end if - - call zero(ke_density_field) - do i = 1, node_count(ke_density_field) - call set(ke_density_field, i, & - & 0.5 * node_val(rho_field, i) * norm2(node_val(vel_field, i))**2) - end do - - end subroutine calculate_ke_density - - subroutine calculate_pe_density(state, pe_density_field, stat) - !!< Calculate the gravitational potential energy density field - !!< Currently assumes a constant gravity field - !!< Beware what your "Density" is! - - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: pe_density_field - integer, intent(out), optional :: stat - - integer :: i - real :: g - real, dimension(mesh_dim(pe_density_field)) :: g_direction, zero_point - type(scalar_field), pointer :: rho_field - type(vector_field), pointer :: positions, positions_remap - - do i = 1, 5 - select case(i) - case(1) - call get_option("/physical_parameters/gravity/magnitude", g, stat) - case(2) - call get_option( & + call zero(ke_density_field) + do i = 1, node_count(ke_density_field) + call set(ke_density_field, i, & + & 0.5 * node_val(rho_field, i) * norm2(node_val(vel_field, i))**2) + end do + + end subroutine calculate_ke_density + + subroutine calculate_pe_density(state, pe_density_field, stat) + !!< Calculate the gravitational potential energy density field + !!< Currently assumes a constant gravity field + !!< Beware what your "Density" is! + + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: pe_density_field + integer, intent(out), optional :: stat + + integer :: i + real :: g + real, dimension(mesh_dim(pe_density_field)) :: g_direction, zero_point + type(scalar_field), pointer :: rho_field + type(vector_field), pointer :: positions, positions_remap + + do i = 1, 5 + select case(i) + case(1) + call get_option("/physical_parameters/gravity/magnitude", g, stat) + case(2) + call get_option( & &"/physical_parameters/gravity/" // & & "vector_field::GravityDirection/prescribed/value[0]/constant", & & g_direction, stat) ! assuming only 1 g_direction as this - ! subroutine isn't set up to support a varying - ! gravity direction over the mesh - need to - ! modify this to get it working with - ! region_ids but assuming this isn't a - ! priority as it's assumed constant already - case(3) - call get_option( & + ! subroutine isn't set up to support a varying + ! gravity direction over the mesh - need to + ! modify this to get it working with + ! region_ids but assuming this isn't a + ! priority as it's assumed constant already + case(3) + call get_option( & & trim(pe_density_field%option_path) // "/diagnostic/zero_point", & & zero_point, stat) - case(4) - positions => extract_vector_field(state, "Coordinate", stat) - case(5) - rho_field => extract_scalar_field(state, "Density", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return - end if - end do - - if(present(stat) .and. (.not. rho_field%mesh == pe_density_field%mesh)) then - stat = 1 - return - else - assert(rho_field%mesh == pe_density_field%mesh) - end if - - if(positions%mesh == pe_density_field%mesh) then - positions_remap => positions - else - allocate(positions_remap) - call allocate(positions_remap, mesh_dim(pe_density_field%mesh), & - & pe_density_field%mesh, "Coordinate") - call remap_field(positions, positions_remap) - end if - - g_direction = g_direction / norm2(g_direction) - - call zero(pe_density_field) - do i = 1, node_count(pe_density_field) - call set(pe_density_field, i, node_val(rho_field, i) * (-1.0) * & - g * dot_product(g_direction, node_val(positions_remap, i) - zero_point)) - end do - - if(.not. positions%mesh == pe_density_field%mesh) then - call deallocate(positions_remap) - deallocate(positions_remap) - end if - - end subroutine calculate_pe_density - - subroutine calculate_isopycnal_coordinate(state, isopycnal_coordinate, stat) - !!< Calculate the isopycnal coordinate - !!< You must be using control volumes for temperature - !!< You need to set up a prescribed diagnostic scalar field called Width - !!< which describes the width of your domain as a function of height - !!< Assumes gravity is in y-direction in 2D, z-direction in 3D - - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: isopycnal_coordinate - integer, intent(out), optional :: stat - - integer, dimension(:), allocatable :: index, index2 - integer :: i, j, k, lstat - real :: z_star, volume, volume_k, volume_rho - type(scalar_field), pointer :: rho_field - type(scalar_field) :: lumped_mass, lumped_mass_depth - type(vector_field), pointer :: Xfield - type(vector_field) :: Xfield_depth - type(mesh_type), pointer :: mesh - character(len = FIELD_NAME_LEN) :: fine_mesh_name - - rho_field => extract_scalar_field(state, "Density", lstat) - - Xfield => extract_vector_field(state, "Coordinate") - call get_option(trim(isopycnal_coordinate%option_path)//"/diagnostic/fine_mesh/name",fine_mesh_name) - mesh => extract_mesh(state,fine_mesh_name) - Xfield_depth = get_coordinate_field(state, mesh) - - allocate(index(1:node_count(rho_field))) - allocate(index2(1:node_count(Xfield_depth))) - - ! reorder density from smallest to largest - call qsort(rho_field%val, index) - - ! reorder vertical coordinate - call qsort(Xfield_depth%val(Xfield_depth%dim,:), index2) - - call allocate(lumped_mass, rho_field%mesh, name="LumpedMass") - call allocate(lumped_mass_depth, mesh, name="LumpedMassDepth") - - call zero(lumped_mass) - call zero(lumped_mass_depth) - - call compute_lumped_mass(Xfield, lumped_mass) - call compute_lumped_mass(Xfield_depth, lumped_mass_depth) - - - j = 1 - volume = 0.0 - z_star = 0.0 - do i=node_count(rho_field),1,-1 - volume_rho = node_val(lumped_mass,index(i)) - do k = j, node_count(Xfield_depth) - if (volume > volume_rho) exit - volume_k = node_val(lumped_mass_depth,index2(k)) - volume = volume + volume_k - z_star = z_star + node_val(Xfield_depth,Xfield_depth%dim,index2(k))*volume_k + case(4) + positions => extract_vector_field(state, "Coordinate", stat) + case(5) + rho_field => extract_scalar_field(state, "Density", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if end do - call set(isopycnal_coordinate,index(i),z_star/volume) - j = min(k, node_count(Xfield_depth)) - volume = volume - volume_rho ! left over volume from redistribution - z_star = node_val(Xfield_depth,Xfield_depth%dim,index2(j))*volume - end do - - call deallocate(lumped_mass) - call deallocate(lumped_mass_depth) - call deallocate(Xfield_depth) - deallocate(index) - deallocate(index2) - - end subroutine calculate_isopycnal_coordinate - - subroutine calculate_back_pe_density(state, back_pe_density_field, stat) - !!< Calculate background potential energy density - !!< You must have isopycnal_coordinate - !!< You must be using control volumes for temperature - - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: back_pe_density_field - integer, intent(out), optional :: stat - integer :: lstat, i - - real :: g - type(scalar_field), pointer :: rho_field - type(scalar_field), pointer :: isopycnal_coordinate - - rho_field => extract_scalar_field(state, "Density", lstat) - if (lstat /= 0) then - if (present(stat)) then - stat = lstat - else - FLExit("Need density") - end if - end if - isopycnal_coordinate => extract_scalar_field(state, "IsopycnalCoordinate", lstat) - if (lstat /= 0) then - if (present(stat)) then - stat = lstat + if(present(stat) .and. (.not. rho_field%mesh == pe_density_field%mesh)) then + stat = 1 + return else - FLExit("Need isopycnal coordinate") + assert(rho_field%mesh == pe_density_field%mesh) end if - end if - call get_option("/physical_parameters/gravity/magnitude", g, lstat) - if (lstat /= 0) then - if (present(stat)) then - stat = lstat + if(positions%mesh == pe_density_field%mesh) then + positions_remap => positions else - FLExit("Need gravity") + allocate(positions_remap) + call allocate(positions_remap, mesh_dim(pe_density_field%mesh), & + & pe_density_field%mesh, "Coordinate") + call remap_field(positions, positions_remap) end if - end if - - call zero(back_pe_density_field) - do i = 1, node_count(back_pe_density_field) - call set(back_pe_density_field, i, node_val(rho_field, i) * & - & g * node_val(isopycnal_coordinate,i)) - end do - - end subroutine calculate_back_pe_density - - subroutine calculate_horizontal_streamfunction(state, psi) - !!< Calculate the horizontal stream function psi where: - !!< \partial_x \psi = -v - !!< \partial_y \psi = u - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: psi - - integer :: i - type(csr_matrix) :: matrix - type(csr_sparsity), pointer :: sparsity - type(scalar_field) :: rhs - type(vector_field), pointer :: gravity_direction, positions, velocity - - ewrite(1, *) "In calculate_horizontal_streamfunction" - ewrite(2, *) "Computing horizontal stream function for state " // trim(state%name) - - if(psi%mesh%continuity /= 0) then - FLExit("HorizontalStreamFunction requires a continuous mesh") - end if - if(mesh_dim(psi%mesh) /= 3) then - FLExit("HorizontalStreamFunction only works in 3D") - end if - - ! Extract the Coordinate field - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mesh_dim(psi)) - assert(ele_count(positions) == ele_count(psi)) - - ! Extract velocity - velocity => extract_vector_field(state, "Velocity") - assert(velocity%dim == mesh_dim(psi)) - assert(ele_count(velocity) == ele_count(psi)) - ewrite_minmax(velocity) - - ! Extract gravity direction - gravity_direction => extract_vector_field(state, "GravityDirection") - assert(gravity_direction%dim == mesh_dim(psi)) - assert(ele_count(gravity_direction) == ele_count(psi)) - - ! Allocate / extract from state - sparsity => get_csr_sparsity_firstorder(state, psi%mesh, psi%mesh) - call allocate(matrix, sparsity, name = trim(psi%name) // "Matrix") - call allocate(rhs, psi%mesh, trim(psi%name) // "Rhs") - - ! Assemble - call zero(matrix) - call zero(rhs) - do i = 1, ele_count(rhs) - call assemble_horizontal_streamfunction_element(i, psi, matrix, rhs, positions, velocity, gravity_direction) - end do - ewrite_minmax(rhs) - - ! Boundary conditions - apply strong Dirichlet boundary condition of zero - ! on all surfaces for now - do i = 1, surface_element_count(rhs) - call addto_diag(matrix, face_global_nodes(rhs, i), spread(INFINITY, 1, face_loc(rhs, i))) - end do - - ! Solve - call petsc_solve(psi, matrix, rhs) - ewrite_minmax(psi) - - ! Deallocate - call deallocate(matrix) - call deallocate(rhs) - - ewrite(1, *) "Exiting calculate_horizontal_streamfunction" - - end subroutine calculate_horizontal_streamfunction - - subroutine assemble_horizontal_streamfunction_element(ele, psi, matrix, rhs, positions, velocity, gravity_direction) - integer, intent(in) :: ele - type(scalar_field), intent(in) :: psi - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - type(vector_field), intent(in) :: gravity_direction - - integer :: i, j - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(psi, ele)) :: detwei, vorticity_h_gi - real, dimension(mesh_dim(psi), ele_ngi(psi, ele)) :: gravity_direction_gi, vorticity_gi - real, dimension(ele_loc(psi, ele), ele_ngi(psi, ele), mesh_dim(psi)) :: dn_t_h - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(psi)) :: du_t - type(element_type), pointer :: psi_shape, velocity_shape - - assert(ele_ngi(velocity, ele) == ele_ngi(psi, ele)) - assert(ele_ngi(gravity_direction, ele) == ele_ngi(psi, ele)) - - psi_shape => ele_shape(psi, ele) - velocity_shape => ele_shape(velocity, ele) - - call transform_to_physical(positions, ele, psi_shape, dshape = dn_t_h, detwei = detwei) - if(psi_shape == velocity_shape) then - du_t = dn_t_h - else - call transform_to_physical(positions, ele, velocity_shape, dshape = du_t) - end if - - gravity_direction_gi = ele_val_at_quad(gravity_direction, ele) - - forall(i = 1:size(dn_t_h, 1), j = 1:size(dn_t_h, 2)) - dn_t_h(i, j, :) = dn_t_h(i, j, :) - dot_product(dn_t_h(i, j, :), gravity_direction_gi(:, j)) * gravity_direction_gi(:, j) - end forall - - vorticity_gi = ele_curl_at_quad(velocity, ele, du_t) - do i = 1, size(vorticity_h_gi) - vorticity_h_gi(i) = -dot_product(vorticity_gi(:, i), gravity_direction_gi(:, i)) - end do - - element_nodes => ele_nodes(psi, ele) - - call addto(matrix, element_nodes, element_nodes, dshape_dot_dshape(dn_t_h, dn_t_h, detwei)) - call addto(rhs, element_nodes, shape_rhs(psi_shape, detwei * vorticity_h_gi)) - - end subroutine assemble_horizontal_streamfunction_element - - subroutine calculate_sgs_full_velocity(state, sgs_full, stat) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: sgs_full - integer, intent(out), optional :: stat - - integer :: i - type(vector_field), pointer :: v_field, sgs_component - - do i = 1, 2 - select case(i) - case(1) - sgs_component => extract_vector_field(state, "VelocityInnerElement", stat) - case(2) - v_field => extract_vector_field(state, "Velocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return + + g_direction = g_direction / norm2(g_direction) + + call zero(pe_density_field) + do i = 1, node_count(pe_density_field) + call set(pe_density_field, i, node_val(rho_field, i) * (-1.0) * & + g * dot_product(g_direction, node_val(positions_remap, i) - zero_point)) + end do + + if(.not. positions%mesh == pe_density_field%mesh) then + call deallocate(positions_remap) + deallocate(positions_remap) end if - end do - call remap_field(from_field = v_field , to_field = sgs_full) - call addto(sgs_full,sgs_component) + end subroutine calculate_pe_density + + subroutine calculate_isopycnal_coordinate(state, isopycnal_coordinate, stat) + !!< Calculate the isopycnal coordinate + !!< You must be using control volumes for temperature + !!< You need to set up a prescribed diagnostic scalar field called Width + !!< which describes the width of your domain as a function of height + !!< Assumes gravity is in y-direction in 2D, z-direction in 3D - end subroutine calculate_sgs_full_velocity + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: isopycnal_coordinate + integer, intent(out), optional :: stat + + integer, dimension(:), allocatable :: index, index2 + integer :: i, j, k, lstat + real :: z_star, volume, volume_k, volume_rho + type(scalar_field), pointer :: rho_field + type(scalar_field) :: lumped_mass, lumped_mass_depth + type(vector_field), pointer :: Xfield + type(vector_field) :: Xfield_depth + type(mesh_type), pointer :: mesh + character(len = FIELD_NAME_LEN) :: fine_mesh_name + + rho_field => extract_scalar_field(state, "Density", lstat) + + Xfield => extract_vector_field(state, "Coordinate") + call get_option(trim(isopycnal_coordinate%option_path)//"/diagnostic/fine_mesh/name",fine_mesh_name) + mesh => extract_mesh(state,fine_mesh_name) + Xfield_depth = get_coordinate_field(state, mesh) + + allocate(index(1:node_count(rho_field))) + allocate(index2(1:node_count(Xfield_depth))) + + ! reorder density from smallest to largest + call qsort(rho_field%val, index) + + ! reorder vertical coordinate + call qsort(Xfield_depth%val(Xfield_depth%dim,:), index2) + + call allocate(lumped_mass, rho_field%mesh, name="LumpedMass") + call allocate(lumped_mass_depth, mesh, name="LumpedMassDepth") + + call zero(lumped_mass) + call zero(lumped_mass_depth) + + call compute_lumped_mass(Xfield, lumped_mass) + call compute_lumped_mass(Xfield_depth, lumped_mass_depth) + + + j = 1 + volume = 0.0 + z_star = 0.0 + do i=node_count(rho_field),1,-1 + volume_rho = node_val(lumped_mass,index(i)) + do k = j, node_count(Xfield_depth) + if (volume > volume_rho) exit + volume_k = node_val(lumped_mass_depth,index2(k)) + volume = volume + volume_k + z_star = z_star + node_val(Xfield_depth,Xfield_depth%dim,index2(k))*volume_k + end do + call set(isopycnal_coordinate,index(i),z_star/volume) + j = min(k, node_count(Xfield_depth)) + volume = volume - volume_rho ! left over volume from redistribution + z_star = node_val(Xfield_depth,Xfield_depth%dim,index2(j))*volume + end do - subroutine calculate_sgs_full_vorticity(state, vort_field, stat) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: vort_field - integer, intent(out), optional :: stat + call deallocate(lumped_mass) + call deallocate(lumped_mass_depth) + call deallocate(Xfield_depth) + deallocate(index) + deallocate(index2) - integer :: i - type(vector_field), pointer :: positions, v_field + end subroutine calculate_isopycnal_coordinate - do i = 1, 2 - select case(i) - case(1) - positions => extract_vector_field(state, "Coordinate", stat) - case(2) - v_field => extract_vector_field(state, "InnerElementFullVelocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return + subroutine calculate_back_pe_density(state, back_pe_density_field, stat) + !!< Calculate background potential energy density + !!< You must have isopycnal_coordinate + !!< You must be using control volumes for temperature + + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: back_pe_density_field + integer, intent(out), optional :: stat + integer :: lstat, i + + real :: g + type(scalar_field), pointer :: rho_field + type(scalar_field), pointer :: isopycnal_coordinate + + rho_field => extract_scalar_field(state, "Density", lstat) + if (lstat /= 0) then + if (present(stat)) then + stat = lstat + else + FLExit("Need density") + end if end if - end do - call curl(v_field, positions, curl_field = vort_field) + isopycnal_coordinate => extract_scalar_field(state, "IsopycnalCoordinate", lstat) + if (lstat /= 0) then + if (present(stat)) then + stat = lstat + else + FLExit("Need isopycnal coordinate") + end if + end if - end subroutine calculate_sgs_full_vorticity + call get_option("/physical_parameters/gravity/magnitude", g, lstat) + if (lstat /= 0) then + if (present(stat)) then + stat = lstat + else + FLExit("Need gravity") + end if + end if - subroutine calculate_sgs_vorticity(state, vort_field, stat) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: vort_field - integer, intent(out), optional :: stat + call zero(back_pe_density_field) + do i = 1, node_count(back_pe_density_field) + call set(back_pe_density_field, i, node_val(rho_field, i) * & + & g * node_val(isopycnal_coordinate,i)) + end do - integer :: i - type(vector_field), pointer :: positions, v_field + end subroutine calculate_back_pe_density - do i = 1, 2 - select case(i) - case(1) - positions => extract_vector_field(state, "Coordinate", stat) - case(2) - v_field => extract_vector_field(state, "VelocityInnerElement", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return + subroutine calculate_horizontal_streamfunction(state, psi) + !!< Calculate the horizontal stream function psi where: + !!< \partial_x \psi = -v + !!< \partial_y \psi = u + + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: psi + + integer :: i + type(csr_matrix) :: matrix + type(csr_sparsity), pointer :: sparsity + type(scalar_field) :: rhs + type(vector_field), pointer :: gravity_direction, positions, velocity + + ewrite(1, *) "In calculate_horizontal_streamfunction" + ewrite(2, *) "Computing horizontal stream function for state " // trim(state%name) + + if(psi%mesh%continuity /= 0) then + FLExit("HorizontalStreamFunction requires a continuous mesh") + end if + if(mesh_dim(psi%mesh) /= 3) then + FLExit("HorizontalStreamFunction only works in 3D") end if - end do - call curl(v_field, positions, curl_field = vort_field) + ! Extract the Coordinate field + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mesh_dim(psi)) + assert(ele_count(positions) == ele_count(psi)) - end subroutine calculate_sgs_vorticity + ! Extract velocity + velocity => extract_vector_field(state, "Velocity") + assert(velocity%dim == mesh_dim(psi)) + assert(ele_count(velocity) == ele_count(psi)) + ewrite_minmax(velocity) + + ! Extract gravity direction + gravity_direction => extract_vector_field(state, "GravityDirection") + assert(gravity_direction%dim == mesh_dim(psi)) + assert(ele_count(gravity_direction) == ele_count(psi)) + + ! Allocate / extract from state + sparsity => get_csr_sparsity_firstorder(state, psi%mesh, psi%mesh) + call allocate(matrix, sparsity, name = trim(psi%name) // "Matrix") + call allocate(rhs, psi%mesh, trim(psi%name) // "Rhs") + + ! Assemble + call zero(matrix) + call zero(rhs) + do i = 1, ele_count(rhs) + call assemble_horizontal_streamfunction_element(i, psi, matrix, rhs, positions, velocity, gravity_direction) + end do + ewrite_minmax(rhs) - subroutine calculate_dg_mapped_cg_velocity(state, dg_field, stat) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: dg_field - integer, intent(out), optional :: stat + ! Boundary conditions - apply strong Dirichlet boundary condition of zero + ! on all surfaces for now + do i = 1, surface_element_count(rhs) + call addto_diag(matrix, face_global_nodes(rhs, i), spread(INFINITY, 1, face_loc(rhs, i))) + end do - integer :: i - type(vector_field), pointer :: positions, v_field + ! Solve + call petsc_solve(psi, matrix, rhs) + ewrite_minmax(psi) - do i = 1, 2 - select case(i) - case(1) - positions => extract_vector_field(state, "Coordinate", stat) - case(2) - v_field => extract_vector_field(state, "Velocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return + ! Deallocate + call deallocate(matrix) + call deallocate(rhs) + + ewrite(1, *) "Exiting calculate_horizontal_streamfunction" + + end subroutine calculate_horizontal_streamfunction + + subroutine assemble_horizontal_streamfunction_element(ele, psi, matrix, rhs, positions, velocity, gravity_direction) + integer, intent(in) :: ele + type(scalar_field), intent(in) :: psi + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + type(vector_field), intent(in) :: gravity_direction + + integer :: i, j + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(psi, ele)) :: detwei, vorticity_h_gi + real, dimension(mesh_dim(psi), ele_ngi(psi, ele)) :: gravity_direction_gi, vorticity_gi + real, dimension(ele_loc(psi, ele), ele_ngi(psi, ele), mesh_dim(psi)) :: dn_t_h + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(psi)) :: du_t + type(element_type), pointer :: psi_shape, velocity_shape + + assert(ele_ngi(velocity, ele) == ele_ngi(psi, ele)) + assert(ele_ngi(gravity_direction, ele) == ele_ngi(psi, ele)) + + psi_shape => ele_shape(psi, ele) + velocity_shape => ele_shape(velocity, ele) + + call transform_to_physical(positions, ele, psi_shape, dshape = dn_t_h, detwei = detwei) + if(psi_shape == velocity_shape) then + du_t = dn_t_h + else + call transform_to_physical(positions, ele, velocity_shape, dshape = du_t) end if - end do - call remap_field(from_field = v_field , to_field = dg_field) + gravity_direction_gi = ele_val_at_quad(gravity_direction, ele) - end subroutine calculate_dg_mapped_cg_velocity + forall(i = 1:size(dn_t_h, 1), j = 1:size(dn_t_h, 2)) + dn_t_h(i, j, :) = dn_t_h(i, j, :) - dot_product(dn_t_h(i, j, :), gravity_direction_gi(:, j)) * gravity_direction_gi(:, j) + end forall - subroutine calculate_dg_mapped_cg_vorticity(state, vort_field, stat) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: vort_field - integer, intent(out), optional :: stat + vorticity_gi = ele_curl_at_quad(velocity, ele, du_t) + do i = 1, size(vorticity_h_gi) + vorticity_h_gi(i) = -dot_product(vorticity_gi(:, i), gravity_direction_gi(:, i)) + end do - integer :: i - type(vector_field), pointer :: positions, v_field + element_nodes => ele_nodes(psi, ele) - do i = 1, 2 - select case(i) - case(1) - positions => extract_vector_field(state, "Coordinate", stat) - case(2) - v_field => extract_vector_field(state, "DgMappedVelocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return - end if - end do + call addto(matrix, element_nodes, element_nodes, dshape_dot_dshape(dn_t_h, dn_t_h, detwei)) + call addto(rhs, element_nodes, shape_rhs(psi_shape, detwei * vorticity_h_gi)) - call curl(v_field, positions, curl_field = vort_field) + end subroutine assemble_horizontal_streamfunction_element - end subroutine calculate_dg_mapped_cg_vorticity + subroutine calculate_sgs_full_velocity(state, sgs_full, stat) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: sgs_full + integer, intent(out), optional :: stat - subroutine calculate_speed(state, speed_field, stat) - !!< Calculate the speed field + integer :: i + type(vector_field), pointer :: v_field, sgs_component + + do i = 1, 2 + select case(i) + case(1) + sgs_component => extract_vector_field(state, "VelocityInnerElement", stat) + case(2) + v_field => extract_vector_field(state, "Velocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: speed_field - integer, intent(out), optional :: stat - integer :: lstat + call remap_field(from_field = v_field , to_field = sgs_full) + call addto(sgs_full,sgs_component) - integer :: i - type(vector_field), pointer :: vel_field + end subroutine calculate_sgs_full_velocity - vel_field => extract_vector_field(state, "Velocity", lstat) - if (lstat /= 0) then - if (present(stat)) then - stat = lstat - else - FLExit("Need Velocity") + subroutine calculate_sgs_full_vorticity(state, vort_field, stat) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: vort_field + integer, intent(out), optional :: stat + + integer :: i + type(vector_field), pointer :: positions, v_field + + do i = 1, 2 + select case(i) + case(1) + positions => extract_vector_field(state, "Coordinate", stat) + case(2) + v_field => extract_vector_field(state, "InnerElementFullVelocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do + + call curl(v_field, positions, curl_field = vort_field) + + end subroutine calculate_sgs_full_vorticity + + subroutine calculate_sgs_vorticity(state, vort_field, stat) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: vort_field + integer, intent(out), optional :: stat + + integer :: i + type(vector_field), pointer :: positions, v_field + + do i = 1, 2 + select case(i) + case(1) + positions => extract_vector_field(state, "Coordinate", stat) + case(2) + v_field => extract_vector_field(state, "VelocityInnerElement", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do + + call curl(v_field, positions, curl_field = vort_field) + + end subroutine calculate_sgs_vorticity + + subroutine calculate_dg_mapped_cg_velocity(state, dg_field, stat) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: dg_field + integer, intent(out), optional :: stat + + integer :: i + type(vector_field), pointer :: positions, v_field + + do i = 1, 2 + select case(i) + case(1) + positions => extract_vector_field(state, "Coordinate", stat) + case(2) + v_field => extract_vector_field(state, "Velocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do + + call remap_field(from_field = v_field , to_field = dg_field) + + end subroutine calculate_dg_mapped_cg_velocity + + subroutine calculate_dg_mapped_cg_vorticity(state, vort_field, stat) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: vort_field + integer, intent(out), optional :: stat + + integer :: i + type(vector_field), pointer :: positions, v_field + + do i = 1, 2 + select case(i) + case(1) + positions => extract_vector_field(state, "Coordinate", stat) + case(2) + v_field => extract_vector_field(state, "DgMappedVelocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do + + call curl(v_field, positions, curl_field = vort_field) + + end subroutine calculate_dg_mapped_cg_vorticity + + subroutine calculate_speed(state, speed_field, stat) + !!< Calculate the speed field + + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: speed_field + integer, intent(out), optional :: stat + integer :: lstat + + integer :: i + type(vector_field), pointer :: vel_field + + vel_field => extract_vector_field(state, "Velocity", lstat) + if (lstat /= 0) then + if (present(stat)) then + stat = lstat + else + FLExit("Need Velocity") + end if end if - end if - call zero(speed_field) - do i = 1, node_count(speed_field) - call set(speed_field, i, norm2(node_val(vel_field, i))) - end do + call zero(speed_field) + do i = 1, node_count(speed_field) + call set(speed_field, i, norm2(node_val(vel_field, i))) + end do - end subroutine calculate_speed + end subroutine calculate_speed - subroutine calculate_diffusive_dissipation(state, diffusive_dissipation_field, stat) - !!< Calculate -2*kappa*g*drho_dy - !!< this can be used to calculate diffusive dissipation - !!< 2D at the moment - !!< it probably should be generalised - !!< currently assumes a constant gravity field - !!< also assumes an isotropic diffusivity + subroutine calculate_diffusive_dissipation(state, diffusive_dissipation_field, stat) + !!< Calculate -2*kappa*g*drho_dy + !!< this can be used to calculate diffusive dissipation + !!< 2D at the moment + !!< it probably should be generalised + !!< currently assumes a constant gravity field + !!< also assumes an isotropic diffusivity - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: diffusive_dissipation_field - integer, intent(out), optional :: stat + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: diffusive_dissipation_field + integer, intent(out), optional :: stat - integer :: i - real :: g - type(scalar_field), pointer :: rho_field - type(vector_field), pointer :: positions - type(scalar_field), dimension(1) :: drho_dy + integer :: i + real :: g + type(scalar_field), pointer :: rho_field + type(vector_field), pointer :: positions + type(scalar_field), dimension(1) :: drho_dy - rho_field => extract_scalar_field(state, "Density", stat) - positions => extract_vector_field(state, "Coordinate", stat) + rho_field => extract_scalar_field(state, "Density", stat) + positions => extract_vector_field(state, "Coordinate", stat) - if(present_and_nonzero(stat)) then - return - end if + if(present_and_nonzero(stat)) then + return + end if - call get_option("/physical_parameters/gravity/magnitude", g, stat) + call get_option("/physical_parameters/gravity/magnitude", g, stat) - call allocate(drho_dy(1), rho_field%mesh, "DRhoDy") + call allocate(drho_dy(1), rho_field%mesh, "DRhoDy") - call differentiate_field(rho_field, & - & positions, (/.false., .true./), drho_dy) + call differentiate_field(rho_field, & + & positions, (/.false., .true./), drho_dy) - call zero(diffusive_dissipation_field) - do i = 1, node_count(diffusive_dissipation_field) - call set(diffusive_dissipation_field, i, -g * node_val(drho_dy(1),i)) - end do + call zero(diffusive_dissipation_field) + do i = 1, node_count(diffusive_dissipation_field) + call set(diffusive_dissipation_field, i, -g * node_val(drho_dy(1),i)) + end do - call deallocate(drho_dy(1)) + call deallocate(drho_dy(1)) - end subroutine calculate_diffusive_dissipation + end subroutine calculate_diffusive_dissipation - subroutine calculate_richardson_number_old(state, richardson_number_field) - !!< Calculate the Richardson number field - !!< Defined in Turner, Buoyancy Effects in Fluids, p.12 as - !!< Ri = \frac{N^2}{(\frac{\partial u}{\partial z})^2+(\frac{\partial v}{\partial z})^2} - !!< with N^2 = -\frac{g}{\rho_0}\frac{\partial \rho}{\partial z} - !!< currently assumes a constant gravity field + subroutine calculate_richardson_number_old(state, richardson_number_field) + !!< Calculate the Richardson number field + !!< Defined in Turner, Buoyancy Effects in Fluids, p.12 as + !!< Ri = \frac{N^2}{(\frac{\partial u}{\partial z})^2+(\frac{\partial v}{\partial z})^2} + !!< with N^2 = -\frac{g}{\rho_0}\frac{\partial \rho}{\partial z} + !!< currently assumes a constant gravity field - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: richardson_number_field + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: richardson_number_field #ifdef DDEBUG - integer :: stat - type(vector_field), pointer :: gravity_direction + integer :: stat + type(vector_field), pointer :: gravity_direction #endif - integer :: i - real :: g - type(scalar_field), pointer :: pert_rho_field - type(vector_field), pointer :: positions, vel_field - type(scalar_field), dimension(1) :: du_dz - type(scalar_field), dimension(1) :: dv_dz - type(scalar_field), dimension(1) :: drho_dz - - positions => extract_vector_field(state, "Coordinate") - vel_field => extract_vector_field(state, "Velocity") - pert_rho_field => extract_scalar_field(state, "PerturbationDensity") - - call get_option("/physical_parameters/gravity/magnitude", g) + integer :: i + real :: g + type(scalar_field), pointer :: pert_rho_field + type(vector_field), pointer :: positions, vel_field + type(scalar_field), dimension(1) :: du_dz + type(scalar_field), dimension(1) :: dv_dz + type(scalar_field), dimension(1) :: drho_dz + + positions => extract_vector_field(state, "Coordinate") + vel_field => extract_vector_field(state, "Velocity") + pert_rho_field => extract_scalar_field(state, "PerturbationDensity") + + call get_option("/physical_parameters/gravity/magnitude", g) #ifdef DDEBUG - gravity_direction => extract_vector_field(state, "GravityDirection", stat) - if(stat == 0) then - select case(gravity_direction%dim) - case(3) - assert(all(abs(gravity_direction%val(1,:)) < epsilon(0.0))) - assert(all(abs(gravity_direction%val(2,:)) < epsilon(0.0))) - assert(all(abs(gravity_direction%val(3,:) + 1.0) < epsilon(0.0))) - case(2) - assert(all(abs(gravity_direction%val(1,:)) < epsilon(0.0))) - assert(all(abs(gravity_direction%val(2,:) + 1.0) < epsilon(0.0))) - case default - FLAbort("Invalid dimension") - end select - end if + gravity_direction => extract_vector_field(state, "GravityDirection", stat) + if(stat == 0) then + select case(gravity_direction%dim) + case(3) + assert(all(abs(gravity_direction%val(1,:)) < epsilon(0.0))) + assert(all(abs(gravity_direction%val(2,:)) < epsilon(0.0))) + assert(all(abs(gravity_direction%val(3,:) + 1.0) < epsilon(0.0))) + case(2) + assert(all(abs(gravity_direction%val(1,:)) < epsilon(0.0))) + assert(all(abs(gravity_direction%val(2,:) + 1.0) < epsilon(0.0))) + case default + FLAbort("Invalid dimension") + end select + end if #endif - assert(positions%mesh == richardson_number_field%mesh) - assert(vel_field%mesh == richardson_number_field%mesh) - assert(pert_rho_field%mesh == richardson_number_field%mesh) + assert(positions%mesh == richardson_number_field%mesh) + assert(vel_field%mesh == richardson_number_field%mesh) + assert(pert_rho_field%mesh == richardson_number_field%mesh) - select case(positions%dim) - case(3) - call allocate(du_dz(1), vel_field%mesh, "DuDz") - call allocate(dv_dz(1), vel_field%mesh, "DvDz") - call allocate(drho_dz(1), pert_rho_field%mesh, "DRhoDz") + select case(positions%dim) + case(3) + call allocate(du_dz(1), vel_field%mesh, "DuDz") + call allocate(dv_dz(1), vel_field%mesh, "DvDz") + call allocate(drho_dz(1), pert_rho_field%mesh, "DRhoDz") - call differentiate_field(extract_scalar_field(vel_field, 1), & + call differentiate_field(extract_scalar_field(vel_field, 1), & & positions, (/.false., .false., .true./), du_dz) - call differentiate_field(extract_scalar_field(vel_field, 2), & + call differentiate_field(extract_scalar_field(vel_field, 2), & & positions, (/.false., .false., .true./), dv_dz) - call differentiate_field(pert_rho_field, & + call differentiate_field(pert_rho_field, & & positions, (/.false., .false., .true./), drho_dz) - call zero(richardson_number_field) - do i = 1, node_count(richardson_number_field) - call set(richardson_number_field, i, -g * node_val(drho_dz(1),i) / & - & (node_val(du_dz(1),i) ** 2 + node_val(dv_dz(1),i) ** 2)) - end do - - call deallocate(du_dz(1)) - call deallocate(dv_dz(1)) - call deallocate(drho_dz(1)) - case(2) - ! Actually dy - call allocate(du_dz(1), vel_field%mesh, "DuDz") - call allocate(drho_dz(1), pert_rho_field%mesh, "DRhoDz") - call differentiate_field(extract_scalar_field(vel_field, 1), & + call zero(richardson_number_field) + do i = 1, node_count(richardson_number_field) + call set(richardson_number_field, i, -g * node_val(drho_dz(1),i) / & + & (node_val(du_dz(1),i) ** 2 + node_val(dv_dz(1),i) ** 2)) + end do + + call deallocate(du_dz(1)) + call deallocate(dv_dz(1)) + call deallocate(drho_dz(1)) + case(2) + ! Actually dy + call allocate(du_dz(1), vel_field%mesh, "DuDz") + call allocate(drho_dz(1), pert_rho_field%mesh, "DRhoDz") + call differentiate_field(extract_scalar_field(vel_field, 1), & & positions, (/.false., .true./), du_dz) - call differentiate_field(pert_rho_field, & + call differentiate_field(pert_rho_field, & & positions, (/.false., .true./), drho_dz) - call zero(richardson_number_field) - do i = 1, node_count(richardson_number_field) - call set(richardson_number_field, i, -g * node_val(drho_dz(1),i) / & - & (node_val(du_dz(1),i) ** 2)) - end do - - call deallocate(du_dz(1)) - call deallocate(drho_dz(1)) - case default - FLAbort("Invalid dimension") - end select - - end subroutine calculate_richardson_number_old - - subroutine calculate_richardson_number_new(state, ri) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: ri - - integer :: i - real :: g - type(scalar_field), pointer :: masslump, perturbation_density - type(vector_field), pointer :: gravity_direction, positions, velocity - - ewrite(1, *) "In calculate_richardson_number" - ewrite(2, *) "Computing shear Richardson number for state " // trim(state%name) - - if(ri%mesh%continuity /= 0) then - FLExit("RichardsonNumber requires a continuous mesh") - end if - - ! Extract the Coordinate field - positions => extract_vector_field(state, "Coordinate") - assert(positions%dim == mesh_dim(ri)) - assert(ele_count(positions) == ele_count(ri)) - - ! Extract velocity - velocity => extract_vector_field(state, "Velocity") - assert(velocity%dim == mesh_dim(ri)) - assert(ele_count(velocity) == ele_count(ri)) - ewrite_minmax(velocity) - - ! Extract gravity - gravity_direction => extract_vector_field(state, "GravityDirection") - assert(gravity_direction%dim == mesh_dim(gravity_direction)) - assert(ele_count(gravity_direction) == ele_count(gravity_direction)) - call get_option("/physical_parameters/gravity/magnitude", g) - - ! Extract perturbation density - perturbation_density => extract_scalar_field(state, "PerturbationDensity") - ewrite_minmax(perturbation_density) - - ! Assemble - call zero(ri) - do i = 1, ele_count(ri) - call assemble_richardson_number_element(i, ri, positions, velocity, g, perturbation_density) - end do - ewrite_minmax(ri) - - masslump => get_lumped_mass(state, ri%mesh) - - ! Solve (somewhat trivial) - ri%val = ri%val / masslump%val - ewrite_minmax(ri) - - end subroutine calculate_richardson_number_new - - subroutine assemble_richardson_number_element(ele, ri, positions, velocity, g, perturbation_density) - integer, intent(in) :: ele - type(scalar_field), intent(inout) :: ri - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity - real, intent(in) :: g - type(scalar_field), intent(in) :: perturbation_density - - integer :: dim, i - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(ri, ele)) :: denomenator_gi, detwei - real, dimension(mesh_dim(ri), ele_ngi(ri, ele)) :: grad_theta_gi - real, dimension(ele_loc(ri, ele), ele_ngi(ri, ele), mesh_dim(ri)) :: dn_t - real, dimension(ele_loc(perturbation_density, ele), ele_ngi(perturbation_density, ele), mesh_dim(ri)) :: dtheta_t - real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(ri)) :: du_t - type(element_type), pointer :: theta_shape, ri_shape, velocity_shape - - assert(ele_ngi(velocity, ele) == ele_ngi(ri, ele)) - assert(ele_ngi(perturbation_density, ele) == ele_ngi(ri, ele)) - - dim = mesh_dim(ri) - - ri_shape => ele_shape(ri, ele) - velocity_shape => ele_shape(velocity, ele) - theta_shape => ele_shape(perturbation_density, ele) - - call transform_to_physical(positions, ele, ri_shape, & + call zero(richardson_number_field) + do i = 1, node_count(richardson_number_field) + call set(richardson_number_field, i, -g * node_val(drho_dz(1),i) / & + & (node_val(du_dz(1),i) ** 2)) + end do + + call deallocate(du_dz(1)) + call deallocate(drho_dz(1)) + case default + FLAbort("Invalid dimension") + end select + + end subroutine calculate_richardson_number_old + + subroutine calculate_richardson_number_new(state, ri) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: ri + + integer :: i + real :: g + type(scalar_field), pointer :: masslump, perturbation_density + type(vector_field), pointer :: gravity_direction, positions, velocity + + ewrite(1, *) "In calculate_richardson_number" + ewrite(2, *) "Computing shear Richardson number for state " // trim(state%name) + + if(ri%mesh%continuity /= 0) then + FLExit("RichardsonNumber requires a continuous mesh") + end if + + ! Extract the Coordinate field + positions => extract_vector_field(state, "Coordinate") + assert(positions%dim == mesh_dim(ri)) + assert(ele_count(positions) == ele_count(ri)) + + ! Extract velocity + velocity => extract_vector_field(state, "Velocity") + assert(velocity%dim == mesh_dim(ri)) + assert(ele_count(velocity) == ele_count(ri)) + ewrite_minmax(velocity) + + ! Extract gravity + gravity_direction => extract_vector_field(state, "GravityDirection") + assert(gravity_direction%dim == mesh_dim(gravity_direction)) + assert(ele_count(gravity_direction) == ele_count(gravity_direction)) + call get_option("/physical_parameters/gravity/magnitude", g) + + ! Extract perturbation density + perturbation_density => extract_scalar_field(state, "PerturbationDensity") + ewrite_minmax(perturbation_density) + + ! Assemble + call zero(ri) + do i = 1, ele_count(ri) + call assemble_richardson_number_element(i, ri, positions, velocity, g, perturbation_density) + end do + ewrite_minmax(ri) + + masslump => get_lumped_mass(state, ri%mesh) + + ! Solve (somewhat trivial) + ri%val = ri%val / masslump%val + ewrite_minmax(ri) + + end subroutine calculate_richardson_number_new + + subroutine assemble_richardson_number_element(ele, ri, positions, velocity, g, perturbation_density) + integer, intent(in) :: ele + type(scalar_field), intent(inout) :: ri + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity + real, intent(in) :: g + type(scalar_field), intent(in) :: perturbation_density + + integer :: dim, i + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(ri, ele)) :: denomenator_gi, detwei + real, dimension(mesh_dim(ri), ele_ngi(ri, ele)) :: grad_theta_gi + real, dimension(ele_loc(ri, ele), ele_ngi(ri, ele), mesh_dim(ri)) :: dn_t + real, dimension(ele_loc(perturbation_density, ele), ele_ngi(perturbation_density, ele), mesh_dim(ri)) :: dtheta_t + real, dimension(ele_loc(velocity, ele), ele_ngi(velocity, ele), mesh_dim(ri)) :: du_t + type(element_type), pointer :: theta_shape, ri_shape, velocity_shape + + assert(ele_ngi(velocity, ele) == ele_ngi(ri, ele)) + assert(ele_ngi(perturbation_density, ele) == ele_ngi(ri, ele)) + + dim = mesh_dim(ri) + + ri_shape => ele_shape(ri, ele) + velocity_shape => ele_shape(velocity, ele) + theta_shape => ele_shape(perturbation_density, ele) + + call transform_to_physical(positions, ele, ri_shape, & & dshape = dn_t, detwei = detwei) - if(ri_shape == velocity_shape) then - du_t = dn_t - else - call transform_to_physical(positions, ele, velocity_shape, dshape = du_t) - end if - if(theta_shape == velocity_shape) then - dtheta_t = dn_t - else - call transform_to_physical(positions, ele, theta_shape, dshape = dtheta_t) - end if - - grad_theta_gi = ele_grad_at_quad(perturbation_density, ele, dtheta_t) - - denomenator_gi = 0.0 - do i = 1, dim - 1 - denomenator_gi = denomenator_gi + (matmul(ele_val(velocity, i, ele), du_t(:, :, dim)) ** 2) - end do - - element_nodes => ele_nodes(ri, ele) - - call addto(ri, element_nodes, & + if(ri_shape == velocity_shape) then + du_t = dn_t + else + call transform_to_physical(positions, ele, velocity_shape, dshape = du_t) + end if + if(theta_shape == velocity_shape) then + dtheta_t = dn_t + else + call transform_to_physical(positions, ele, theta_shape, dshape = dtheta_t) + end if + + grad_theta_gi = ele_grad_at_quad(perturbation_density, ele, dtheta_t) + + denomenator_gi = 0.0 + do i = 1, dim - 1 + denomenator_gi = denomenator_gi + (matmul(ele_val(velocity, i, ele), du_t(:, :, dim)) ** 2) + end do + + element_nodes => ele_nodes(ri, ele) + + call addto(ri, element_nodes, & ! Note well: if \frac{d\theta}{dz} and ! ((\frac{du}{dz})^2 + \frac{dv}{dz})^2 are zero, then we pick up a value ! of NaN here & shape_rhs(ri_shape, -detwei * g * grad_theta_gi(dim, :) / denomenator_gi) & & ) - end subroutine assemble_richardson_number_element + end subroutine assemble_richardson_number_element - subroutine calculate_stream_function_2d(state, streamfunc, stat) - !!< Calculate the stream function for a - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: streamfunc - integer, intent(out), optional :: stat + subroutine calculate_stream_function_2d(state, streamfunc, stat) + !!< Calculate the stream function for a + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: streamfunc + integer, intent(out), optional :: stat + + integer :: i, lstat, ele + type(vector_field), pointer :: X, U + type(csr_sparsity) :: psi_sparsity + type(csr_matrix) :: psi_mat + type(scalar_field) :: rhs + + do i = 1, 2 + select case(i) + case(1) + X => extract_vector_field(state, "Coordinate", stat) + case(2) + U => extract_vector_field(state, "Velocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return + end if + end do - integer :: i, lstat, ele - type(vector_field), pointer :: X, U - type(csr_sparsity) :: psi_sparsity - type(csr_matrix) :: psi_mat - type(scalar_field) :: rhs + assert(X%dim==2) + ! No discontinuous stream functions. + assert(continuity(streamfunc)>=0) - do i = 1, 2 - select case(i) - case(1) - X => extract_vector_field(state, "Coordinate", stat) - case(2) - U => extract_vector_field(state, "Velocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return - end if - end do - - assert(X%dim==2) - ! No discontinuous stream functions. - assert(continuity(streamfunc)>=0) - - psi_sparsity = extract_csr_sparsity(state, & - & "StreamFunctionSparsity", lstat) - if (lstat/=0) then - psi_sparsity = make_sparsity(streamfunc%mesh, streamfunc%mesh, & + psi_sparsity = extract_csr_sparsity(state, & + & "StreamFunctionSparsity", lstat) + if (lstat/=0) then + psi_sparsity = make_sparsity(streamfunc%mesh, streamfunc%mesh, & "StreamFunctionSparsity") - else - call incref(psi_sparsity) - end if + else + call incref(psi_sparsity) + end if - call allocate(psi_mat, psi_sparsity, name="StreamFunctionMatrix") + call allocate(psi_mat, psi_sparsity, name="StreamFunctionMatrix") - call zero(psi_mat) - call allocate(rhs, streamfunc%mesh, "StreamFunctionRHS") - call zero(rhs) + call zero(psi_mat) + call allocate(rhs, streamfunc%mesh, "StreamFunctionRHS") + call zero(rhs) - do ele=1, element_count(streamfunc) + do ele=1, element_count(streamfunc) - call calculate_streamfunc_ele(psi_mat, rhs, ele, X, U) + call calculate_streamfunc_ele(psi_mat, rhs, ele, X, U) - end do + end do - call petsc_solve(streamfunc, psi_mat, rhs) + call petsc_solve(streamfunc, psi_mat, rhs) - call deallocate(rhs) - call deallocate(psi_mat) - call deallocate(psi_sparsity) + call deallocate(rhs) + call deallocate(psi_mat) + call deallocate(psi_sparsity) - contains + contains - subroutine calculate_streamfunc_ele(psi_mat, rhs, ele, X, U) - type(csr_matrix), intent(inout) :: psi_mat - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: X,U - integer, intent(in) :: ele + subroutine calculate_streamfunc_ele(psi_mat, rhs, ele, X, U) + type(csr_matrix), intent(inout) :: psi_mat + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: X,U + integer, intent(in) :: ele - ! Transformed gradient function for velocity. - real, dimension(ele_loc(U, ele), ele_ngi(U, ele), mesh_dim(U)) :: du_t - ! Ditto for the stream function, psi - real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), mesh_dim(rhs))& - & :: dpsi_t + ! Transformed gradient function for velocity. + real, dimension(ele_loc(U, ele), ele_ngi(U, ele), mesh_dim(U)) :: du_t + ! Ditto for the stream function, psi + real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), mesh_dim(rhs))& + & :: dpsi_t - ! Local vorticity_matrix - real, dimension(2, ele_loc(rhs, ele), ele_loc(U, ele)) ::& - & lvorticity_mat - ! Local vorticity - real, dimension(ele_loc(rhs, ele)) :: lvorticity + ! Local vorticity_matrix + real, dimension(2, ele_loc(rhs, ele), ele_loc(U, ele)) ::& + & lvorticity_mat + ! Local vorticity + real, dimension(ele_loc(rhs, ele)) :: lvorticity - ! Variable transform times quadrature weights. - real, dimension(ele_ngi(U,ele)) :: detwei + ! Variable transform times quadrature weights. + real, dimension(ele_ngi(U,ele)) :: detwei - type(element_type), pointer :: U_shape, psi_shape - integer, dimension(:), pointer :: psi_ele, neigh - integer :: i, ni, face + type(element_type), pointer :: U_shape, psi_shape + integer, dimension(:), pointer :: psi_ele, neigh + integer :: i, ni, face - U_shape=> ele_shape(U, ele) - psi_shape=> ele_shape(rhs, ele) - psi_ele=>ele_nodes(rhs, ele) + U_shape=> ele_shape(U, ele) + psi_shape=> ele_shape(rhs, ele) + psi_ele=>ele_nodes(rhs, ele) - ! Transform U derivatives and weights into physical space. - call transform_to_physical(X, ele, U_shape, dshape=du_t, detwei=detwei) - ! Ditto psi. - call transform_to_physical(X, ele, psi_shape, dshape=dpsi_t) + ! Transform U derivatives and weights into physical space. + call transform_to_physical(X, ele, U_shape, dshape=du_t, detwei=detwei) + ! Ditto psi. + call transform_to_physical(X, ele, psi_shape, dshape=dpsi_t) - call addto(psi_mat, psi_ele, psi_ele, & - -dshape_dot_dshape(dpsi_t, dpsi_t, detwei)) + call addto(psi_mat, psi_ele, psi_ele, & + -dshape_dot_dshape(dpsi_t, dpsi_t, detwei)) - lvorticity_mat=shape_curl_shape_2d(psi_shape, du_t, detwei) + lvorticity_mat=shape_curl_shape_2d(psi_shape, du_t, detwei) - lvorticity=0.0 - do i=1,2 - lvorticity=lvorticity & - +matmul(lvorticity_mat(i,:,:), ele_val(U, i, ele)) - end do + lvorticity=0.0 + do i=1,2 + lvorticity=lvorticity & + +matmul(lvorticity_mat(i,:,:), ele_val(U, i, ele)) + end do - call addto(rhs, psi_ele, lvorticity) + call addto(rhs, psi_ele, lvorticity) - neigh=>ele_neigh(U, ele) + neigh=>ele_neigh(U, ele) + + neighbourloop: do ni=1,size(neigh) + ! Find boundaries. + if (neigh(ni)<=0) then + + face=ele_face(rhs, ele, neigh(ni)) + + ! Strong dirichlet condition (currently the only thing supported) + call addto_diag(psi_mat, & + face_global_nodes(rhs, face), & + spread(INFINITY, 1, face_loc(rhs,face))) + end if + end do neighbourloop + + end subroutine calculate_streamfunc_ele - neighbourloop: do ni=1,size(neigh) - ! Find boundaries. - if (neigh(ni)<=0) then + end subroutine calculate_stream_function_2d - face=ele_face(rhs, ele, neigh(ni)) + subroutine calculate_velocity_divergence(state, div_u, stat) + !!< Calculate div u for diagnosing continuity issues. + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: div_u + integer, intent(out), optional :: stat - ! Strong dirichlet condition (currently the only thing supported) - call addto_diag(psi_mat, & - face_global_nodes(rhs, face), & - spread(INFINITY, 1, face_loc(rhs,face))) + integer :: i + type(vector_field), pointer :: positions, v_field + + do i = 1, 2 + select case(i) + case(1) + positions => extract_vector_field(state, "Coordinate", stat) + case(2) + v_field => extract_vector_field(state, "Velocity", stat) + case default + FLAbort("Invalid loop index") + end select + if(present_and_nonzero(stat)) then + return end if - end do neighbourloop + end do - end subroutine calculate_streamfunc_ele + call div(v_field, positions, div_u) - end subroutine calculate_stream_function_2d + end subroutine calculate_velocity_divergence - subroutine calculate_velocity_divergence(state, div_u, stat) - !!< Calculate div u for diagnosing continuity issues. - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: div_u - integer, intent(out), optional :: stat + subroutine calculate_courant_number_dg(state, courant, dt) + !!< Calculate courant number for DG velocity fields + !!< == positive fluxes of unit function into element + !!< *dt/volume of element - integer :: i - type(vector_field), pointer :: positions, v_field + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: courant + real, intent(in), optional :: dt + ! + type(vector_field), pointer :: u, x + real :: l_dt + integer :: ele, stat - do i = 1, 2 - select case(i) - case(1) - positions => extract_vector_field(state, "Coordinate", stat) - case(2) - v_field => extract_vector_field(state, "Velocity", stat) - case default - FLAbort("Invalid loop index") - end select - if(present_and_nonzero(stat)) then - return + u=>extract_vector_field(state, "NonlinearVelocity",stat) + if(stat.ne.0) then + u=>extract_vector_field(state, "Velocity",stat) + if(stat.ne.0) then + FLExit('Missing velocity field!') + end if end if - end do - - call div(v_field, positions, div_u) - - end subroutine calculate_velocity_divergence - - subroutine calculate_courant_number_dg(state, courant, dt) - !!< Calculate courant number for DG velocity fields - !!< == positive fluxes of unit function into element - !!< *dt/volume of element - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: courant - real, intent(in), optional :: dt - ! - type(vector_field), pointer :: u, x - real :: l_dt - integer :: ele, stat - - u=>extract_vector_field(state, "NonlinearVelocity",stat) - if(stat.ne.0) then - u=>extract_vector_field(state, "Velocity",stat) - if(stat.ne.0) then - FLExit('Missing velocity field!') - end if - end if - x=>extract_vector_field(state, "Coordinate") - - if(present(dt)) then - l_dt = dt - else - call get_option("/timestepping/timestep",l_dt) - end if - - call zero(courant) - - do ele = 1, element_count(courant) - call calculate_courant_number_dg_ele(courant,x,u,ele,l_dt) - end do - - ! the courant values at the edge of the halo are going to be incorrect - ! this matters when computing the max courant number - call halo_update(courant) - - end subroutine calculate_courant_number_dg - - subroutine calculate_courant_number_dg_ele(courant,x,u,ele,dt) - type(vector_field), intent(in) :: x, u - type(scalar_field), intent(inout) :: courant - real, intent(in) :: dt - integer, intent(in) :: ele - ! - real :: Vol - real :: Flux - integer :: ni, ele_2, face, face_2 - integer, dimension(:), pointer :: neigh - real, dimension(ele_ngi(u,ele)) :: detwei - real, dimension(face_ngi(u,1)) :: detwei_f - real, dimension(U%dim, face_ngi(U, 1)) :: normal, U_f_quad - real, dimension(face_ngi(U,1)) :: flux_quad - integer, dimension(:), pointer :: u_ele - real :: val - real, dimension(ele_loc(u,ele)) :: Vals - ! - !Get element volume - call transform_to_physical(X, ele, detwei=detwei) - Vol = sum(detwei) - - !Get fluxes - Flux = 0.0 - neigh=>ele_neigh(U, ele) - do ni = 1, size(neigh) - ele_2=neigh(ni) - face=ele_face(U, ele, ele_2) - if(ele_2<0.0) then - face_2 = face - else - face_2=ele_face(U, ele_2, ele) - end if - - U_f_quad =0.5*(face_val_at_quad(U, face)& - & +face_val_at_quad(U, face_2)) - - call transform_facet_to_physical(X, face, & - & detwei_f=detwei_f,& - & normal=normal) - - Flux_quad = -sum(U_f_quad*normal,1) - Flux_quad = max(Flux_quad,0.0) - - Flux = Flux + sum(Flux_quad*detwei_f) - end do - - u_ele => ele_nodes(U,ele) - - Val = Flux/Vol*dt - Vals = Val - call set(Courant,U_ele,Vals) - - end subroutine calculate_courant_number_dg_ele + x=>extract_vector_field(state, "Coordinate") + + if(present(dt)) then + l_dt = dt + else + call get_option("/timestepping/timestep",l_dt) + end if + + call zero(courant) + + do ele = 1, element_count(courant) + call calculate_courant_number_dg_ele(courant,x,u,ele,l_dt) + end do + + ! the courant values at the edge of the halo are going to be incorrect + ! this matters when computing the max courant number + call halo_update(courant) + + end subroutine calculate_courant_number_dg + + subroutine calculate_courant_number_dg_ele(courant,x,u,ele,dt) + type(vector_field), intent(in) :: x, u + type(scalar_field), intent(inout) :: courant + real, intent(in) :: dt + integer, intent(in) :: ele + ! + real :: Vol + real :: Flux + integer :: ni, ele_2, face, face_2 + integer, dimension(:), pointer :: neigh + real, dimension(ele_ngi(u,ele)) :: detwei + real, dimension(face_ngi(u,1)) :: detwei_f + real, dimension(U%dim, face_ngi(U, 1)) :: normal, U_f_quad + real, dimension(face_ngi(U,1)) :: flux_quad + integer, dimension(:), pointer :: u_ele + real :: val + real, dimension(ele_loc(u,ele)) :: Vals + ! + !Get element volume + call transform_to_physical(X, ele, detwei=detwei) + Vol = sum(detwei) + + !Get fluxes + Flux = 0.0 + neigh=>ele_neigh(U, ele) + do ni = 1, size(neigh) + ele_2=neigh(ni) + face=ele_face(U, ele, ele_2) + if(ele_2<0.0) then + face_2 = face + else + face_2=ele_face(U, ele_2, ele) + end if + + U_f_quad =0.5*(face_val_at_quad(U, face)& + & +face_val_at_quad(U, face_2)) + + call transform_facet_to_physical(X, face, & + & detwei_f=detwei_f,& + & normal=normal) + + Flux_quad = -sum(U_f_quad*normal,1) + Flux_quad = max(Flux_quad,0.0) + + Flux = Flux + sum(Flux_quad*detwei_f) + end do + + u_ele => ele_nodes(U,ele) + + Val = Flux/Vol*dt + Vals = Val + call set(Courant,U_ele,Vals) + + end subroutine calculate_courant_number_dg_ele subroutine calculate_courant_number_cv(state, courant, dt) @@ -1734,9 +1734,9 @@ subroutine calculate_courant_number_cv(state, courant, dt) if(move_mesh) ug=>extract_vector_field(state, "GridVelocity") if(present(dt)) then - l_dt = dt + l_dt = dt else - call get_option("/timestepping/timestep",l_dt) + call get_option("/timestepping/timestep",l_dt) end if call zero(courant) @@ -1749,209 +1749,209 @@ subroutine calculate_courant_number_cv(state, courant, dt) if(courant%mesh%shape%degree /= 0) then - call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + call get_option("/geometry/quadrature/controlvolume_surface_degree", & + quaddegree, default=1) - cvfaces=find_cv_faces(vertices=ele_vertices(courant,1), & - dimension=mesh_dim(courant), & - polydegree=courant%mesh%shape%degree, & - quaddegree=quaddegree) + cvfaces=find_cv_faces(vertices=ele_vertices(courant,1), & + dimension=mesh_dim(courant), & + polydegree=courant%mesh%shape%degree, & + quaddegree=quaddegree) - u_cvshape=make_cv_element_shape(cvfaces, u%mesh%shape) - x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) + u_cvshape=make_cv_element_shape(cvfaces, u%mesh%shape) + x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) - allocate(x_ele(x%dim,ele_loc(x,1)), & - x_f(x%dim, x_cvshape%ngi), & - u_f(u%dim, u_cvshape%ngi), & - detwei(x_cvshape%ngi), & - normal(x%dim, x_cvshape%ngi), & - normgi(x%dim)) - allocate(notvisited(x_cvshape%ngi)) + allocate(x_ele(x%dim,ele_loc(x,1)), & + x_f(x%dim, x_cvshape%ngi), & + u_f(u%dim, u_cvshape%ngi), & + detwei(x_cvshape%ngi), & + normal(x%dim, x_cvshape%ngi), & + normgi(x%dim)) + allocate(notvisited(x_cvshape%ngi)) - if(move_mesh) then - ug_cvshape=make_cv_element_shape(cvfaces, ug%mesh%shape) - allocate(ug_f(ug%dim, ug_cvshape%ngi)) - end if + if(move_mesh) then + ug_cvshape=make_cv_element_shape(cvfaces, ug%mesh%shape) + allocate(ug_f(ug%dim, ug_cvshape%ngi)) + end if - do ele=1, element_count(courant) - x_ele=ele_val(x, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - u_f=ele_val_at_quad(u, ele, u_cvshape) - if(move_mesh) ug_f = ele_val_at_quad(ug, ele, ug_cvshape) - nodes=>ele_nodes(courant, ele) - x_nodes=>ele_nodes(x_courant, ele) + do ele=1, element_count(courant) + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + u_f=ele_val_at_quad(u, ele, u_cvshape) + if(move_mesh) ug_f = ele_val_at_quad(ug, ele, ug_cvshape) + nodes=>ele_nodes(courant, ele) + x_nodes=>ele_nodes(x_courant, ele) - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) - notvisited=.true. + notvisited=.true. - do iloc = 1, courant%mesh%shape%loc + do iloc = 1, courant%mesh%shape%loc - do face = 1, cvfaces%faces + do face = 1, cvfaces%faces - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) - do gi = 1, cvfaces%shape%ngi + do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - ! have we been here before? - if(notvisited(ggi)) then - notvisited(ggi)=.false. + ! have we been here before? + if(notvisited(ggi)) then + notvisited(ggi)=.false. - normgi=orientate_cvsurf_normgi(node_val(x_courant, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + normgi=orientate_cvsurf_normgi(node_val(x_courant, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - if(move_mesh) then - udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi) - else - udotn=dot_product(u_f(:,ggi), normgi) - end if + if(move_mesh) then + udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi) + else + udotn=dot_product(u_f(:,ggi), normgi) + end if - if(udotn>0.0) then - income=0.0 - else - income=1.0 - end if + if(udotn>0.0) then + income=0.0 + else + income=1.0 + end if - call addto(courant, nodes(iloc), abs(udotn)*(1.-income)*detwei(ggi)) - call addto(courant, nodes(oloc), abs(udotn)*income*detwei(ggi)) ! notvisited + call addto(courant, nodes(iloc), abs(udotn)*(1.-income)*detwei(ggi)) + call addto(courant, nodes(oloc), abs(udotn)*income*detwei(ggi)) ! notvisited - end if ! notvisited + end if ! notvisited - end do + end do - end if + end if + end do end do - end do - end do - - u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) - x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) + end do - allocate(x_ele_bdy(x%dim,face_loc(x,1)), & - u_bdy_f(u%dim, u_cvbdyshape%ngi), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi)) - allocate(nodes_bdy(face_loc(courant, 1))) - allocate(courant_bc_type(surface_element_count(courant))) + u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) + x_cvbdyshape=make_cvbdy_element_shape(cvfaces, x%mesh%faces%shape) - if(move_mesh) then - ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) - allocate(ug_bdy_f(ug%dim, ug_cvbdyshape%ngi)) - end if + allocate(x_ele_bdy(x%dim,face_loc(x,1)), & + u_bdy_f(u%dim, u_cvbdyshape%ngi), & + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi)) + allocate(nodes_bdy(face_loc(courant, 1))) + allocate(courant_bc_type(surface_element_count(courant))) - ! get the fields over the surface containing the bcs - call get_entire_boundary_condition(courant, (/"internal"/), courant_bc, courant_bc_type) + if(move_mesh) then + ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) + allocate(ug_bdy_f(ug%dim, ug_cvbdyshape%ngi)) + end if - do sele=1,surface_element_count(courant) + ! get the fields over the surface containing the bcs + call get_entire_boundary_condition(courant, (/"internal"/), courant_bc, courant_bc_type) - if(courant_bc_type(sele)==1) cycle + do sele=1,surface_element_count(courant) - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - nodes_bdy=face_global_nodes(courant, sele) + if(courant_bc_type(sele)==1) cycle - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + nodes_bdy=face_global_nodes(courant, sele) - u_bdy_f=face_val_at_quad(u, sele, u_cvbdyshape) - if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) - do iloc = 1, courant%mesh%faces%shape%loc + u_bdy_f=face_val_at_quad(u, sele, u_cvbdyshape) + if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) - do face = 1, cvfaces%sfaces + do iloc = 1, courant%mesh%faces%shape%loc - if(cvfaces%sneiloc(iloc,face)/=0) then + do face = 1, cvfaces%sfaces - do gi = 1, cvfaces%shape%ngi + if(cvfaces%sneiloc(iloc,face)/=0) then - ggi = (face-1)*cvfaces%shape%ngi + gi + do gi = 1, cvfaces%shape%ngi - if(move_mesh) then - udotn=dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) - else - udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) - end if + ggi = (face-1)*cvfaces%shape%ngi + gi - if(udotn>0.0) then - income=0.0 - else - income=1.0 - end if + if(move_mesh) then + udotn=dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) + else + udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) + end if - call addto(courant, nodes_bdy(iloc), abs(udotn)*(1.0-income)*detwei_bdy(ggi)) + if(udotn>0.0) then + income=0.0 + else + income=1.0 + end if - end do + call addto(courant, nodes_bdy(iloc), abs(udotn)*(1.0-income)*detwei_bdy(ggi)) - end if + end do - end do + end if - end do + end do - end do + end do - deallocate(x_ele, x_f, u_f, detwei, normal, normgi) - deallocate(x_ele_bdy, u_bdy_f, detwei_bdy, normal_bdy) - deallocate(nodes_bdy) - deallocate(notvisited) - call deallocate(x_cvbdyshape) - call deallocate(u_cvbdyshape) - call deallocate(x_cvshape) - call deallocate(u_cvshape) - call deallocate(cvfaces) - call deallocate(courant_bc) + end do - if(move_mesh) then - call deallocate(ug_cvshape) - call deallocate(ug_cvbdyshape) - deallocate(ug_f, ug_bdy_f) - end if + deallocate(x_ele, x_f, u_f, detwei, normal, normgi) + deallocate(x_ele_bdy, u_bdy_f, detwei_bdy, normal_bdy) + deallocate(nodes_bdy) + deallocate(notvisited) + call deallocate(x_cvbdyshape) + call deallocate(u_cvbdyshape) + call deallocate(x_cvshape) + call deallocate(u_cvshape) + call deallocate(cvfaces) + call deallocate(courant_bc) + + if(move_mesh) then + call deallocate(ug_cvshape) + call deallocate(ug_cvbdyshape) + deallocate(ug_f, ug_bdy_f) + end if else - allocate(detwei(face_ngi(courant, 1)), & - u_f(u%dim, face_ngi(u, 1)), & - normal(x%dim, face_ngi(courant, 1))) + allocate(detwei(face_ngi(courant, 1)), & + u_f(u%dim, face_ngi(u, 1)), & + normal(x%dim, face_ngi(courant, 1))) - do ele = 1, element_count(courant) + do ele = 1, element_count(courant) - nodes=>ele_nodes(courant, ele) - assert(size(nodes)==1) + nodes=>ele_nodes(courant, ele) + assert(size(nodes)==1) - neigh=>ele_neigh(courant, ele) + neigh=>ele_neigh(courant, ele) - do ni= 1, size(neigh) + do ni= 1, size(neigh) - face = ele_face(courant, ele, neigh(ni)) + face = ele_face(courant, ele, neigh(ni)) - if(neigh(ni)>0) then - ! internal face - face_2=ele_face(courant, neigh(ni), ele) - else - ! external face - face_2 = face - end if + if(neigh(ni)>0) then + ! internal face + face_2=ele_face(courant, neigh(ni), ele) + else + ! external face + face_2 = face + end if - call transform_facet_to_physical(x, face, detwei_f=detwei, normal=normal) + call transform_facet_to_physical(x, face, detwei_f=detwei, normal=normal) - ! if velocity is dg then use a trapezoidal rule (otherwise this will - ! all cancel out to give the face value) - u_f = 0.5*(face_val_at_quad(u, face) + face_val_at_quad(u, face_2)) - if(move_mesh) then - u_f = u_f - face_val_at_quad(ug, face) - end if + ! if velocity is dg then use a trapezoidal rule (otherwise this will + ! all cancel out to give the face value) + u_f = 0.5*(face_val_at_quad(u, face) + face_val_at_quad(u, face_2)) + if(move_mesh) then + u_f = u_f - face_val_at_quad(ug, face) + end if - call addto(courant, nodes(1), & - sum(sum(u_f*normal,1)*merge(1.0,0.0,.not.(sum(u_f*normal,1)<0.0))*detwei)) + call addto(courant, nodes(1), & + sum(sum(u_f*normal,1)*merge(1.0,0.0,.not.(sum(u_f*normal,1)<0.0))*detwei)) - end do + end do - end do + end do end if @@ -2002,11 +2002,11 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) type(csr_sparsity) :: mesh_sparsity type(csr_matrix) :: matdens_upwind, oldmatdens_upwind real, dimension(:), allocatable :: matdens_ele, oldmatdens_ele, & - cfl_ele + cfl_ele integer, dimension(:), allocatable :: matdens_bc_type type(scalar_field) :: matdens_bc real, dimension(:), allocatable :: matdens_ele_bdy, oldmatdens_ele_bdy, & - ghost_matdens_ele_bdy, ghost_oldmatdens_ele_bdy + ghost_matdens_ele_bdy, ghost_oldmatdens_ele_bdy type(state_type), dimension(1) :: state_array ! logical array indicating if a face has already been visited by the opposing node @@ -2028,7 +2028,7 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) matdens=>extract_scalar_field(state, "MaterialDensity") oldmatdens=>extract_scalar_field(state, "OldMaterialDensity", stat) if(stat/=0) then - oldmatdens=>matdens + oldmatdens=>matdens end if matdens_options=get_cv_options(matdens%option_path, matdens%mesh%shape%numbering%family, mesh_dim(matdens)) @@ -2040,13 +2040,13 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) call allocate(cfl_no, matdens%mesh, "CourantNumber") call get_option(trim(complete_cv_field_path(matdens%option_path))//& - "/face_value[0]/courant_number[0]/name", & - cfl_type, stat) + "/face_value[0]/courant_number[0]/name", & + cfl_type, stat) if(stat==0) then select case(trim(cfl_type)) - case("CVMaterialDenstiyCFLNumber") + case("CVMaterialDenstiyCFLNumber") FLAbort("You can't use the field you're in the process of creating!") - case default + case default ! otherwise we want to calculate a node centred field of the cfl number call calculate_diagnostic_variable(state, trim(cfl_type), cfl_no) end select @@ -2064,53 +2064,53 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) ! does the density field need upwind values? if(need_upwind_values(matdens_options)) then - state_array(1) = state ! a hack to let find_upwind_values accept a single state + state_array(1) = state ! a hack to let find_upwind_values accept a single state - call find_upwind_values(state_array, x_courant, matdens, matdens_upwind, & - oldmatdens, oldmatdens_upwind & - ) + call find_upwind_values(state_array, x_courant, matdens, matdens_upwind, & + oldmatdens, oldmatdens_upwind & + ) else - call zero(matdens_upwind) - call zero(oldmatdens_upwind) + call zero(matdens_upwind) + call zero(oldmatdens_upwind) end if if(present(dt)) then - l_dt = dt + l_dt = dt else - call get_option("/timestepping/timestep",l_dt) + call get_option("/timestepping/timestep",l_dt) end if call get_option("/geometry/quadrature/controlvolume_surface_degree", & - quaddegree, default=1) + quaddegree, default=1) call zero(courant) cvfaces=find_cv_faces(vertices=ele_vertices(courant,1), & - dimension=mesh_dim(courant), & - polydegree=courant%mesh%shape%degree, & - quaddegree=quaddegree) + dimension=mesh_dim(courant), & + polydegree=courant%mesh%shape%degree, & + quaddegree=quaddegree) u_cvshape=make_cv_element_shape(cvfaces, u%mesh%shape) x_cvshape=make_cv_element_shape(cvfaces, x%mesh%shape) t_cvshape=make_cv_element_shape(cvfaces, matdens%mesh%shape) allocate(x_ele(x%dim, ele_loc(x,1)), & - x_f(x%dim, x_cvshape%ngi), & - u_f(u%dim, u_cvshape%ngi), & - detwei(x_cvshape%ngi), & - normal(x%dim, x_cvshape%ngi), & - normgi(x%dim)) + x_f(x%dim, x_cvshape%ngi), & + u_f(u%dim, u_cvshape%ngi), & + detwei(x_cvshape%ngi), & + normal(x%dim, x_cvshape%ngi), & + normgi(x%dim)) allocate(cfl_ele(ele_loc(cfl_no, 1)), & - matdens_ele(ele_loc(matdens, 1)), & - oldmatdens_ele(ele_loc(matdens, 1))) + matdens_ele(ele_loc(matdens, 1)), & + oldmatdens_ele(ele_loc(matdens, 1))) allocate(notvisited(x_cvshape%ngi)) if(move_mesh) then - ug_cvshape = make_cv_element_shape(cvfaces, ug%mesh%shape) - allocate(ug_f(ug%dim, ug_cvshape%ngi)) + ug_cvshape = make_cv_element_shape(cvfaces, ug%mesh%shape) + allocate(ug_f(ug%dim, ug_cvshape%ngi)) end if call allocate(cvmass, courant%mesh, "CV mass") @@ -2118,86 +2118,86 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) cvmass%val = cvmass%val*(matdens_options%theta*matdens%val+(1.0-matdens_options%theta)*oldmatdens%val) do ele=1, element_count(courant) - x_ele=ele_val(x, ele) - x_f=ele_val_at_quad(x, ele, x_cvshape) - u_f=ele_val_at_quad(u, ele, u_cvshape) - if(move_mesh) ug_f = ele_val_at_quad(ug, ele, ug_cvshape) - nodes=>ele_nodes(courant, ele) - x_nodes=>ele_nodes(x_courant, ele) + x_ele=ele_val(x, ele) + x_f=ele_val_at_quad(x, ele, x_cvshape) + u_f=ele_val_at_quad(u, ele, u_cvshape) + if(move_mesh) ug_f = ele_val_at_quad(ug, ele, ug_cvshape) + nodes=>ele_nodes(courant, ele) + x_nodes=>ele_nodes(x_courant, ele) - call transform_cvsurf_to_physical(x_ele, x_cvshape, & - detwei, normal, cvfaces) + call transform_cvsurf_to_physical(x_ele, x_cvshape, & + detwei, normal, cvfaces) - matdens_ele = ele_val(matdens, ele) - oldmatdens_ele = ele_val(oldmatdens, ele) + matdens_ele = ele_val(matdens, ele) + oldmatdens_ele = ele_val(oldmatdens, ele) - cfl_ele = ele_val(cfl_no, ele) + cfl_ele = ele_val(cfl_no, ele) - notvisited=.true. + notvisited=.true. - do iloc = 1, courant%mesh%shape%loc + do iloc = 1, courant%mesh%shape%loc - do face = 1, cvfaces%faces + do face = 1, cvfaces%faces - if(cvfaces%neiloc(iloc, face) /= 0) then - oloc = cvfaces%neiloc(iloc, face) + if(cvfaces%neiloc(iloc, face) /= 0) then + oloc = cvfaces%neiloc(iloc, face) - do gi = 1, cvfaces%shape%ngi + do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - ! have we been here before? - if(notvisited(ggi)) then - notvisited(ggi)=.false. + ! have we been here before? + if(notvisited(ggi)) then + notvisited(ggi)=.false. - normgi=orientate_cvsurf_normgi(node_val(x_courant, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) + normgi=orientate_cvsurf_normgi(node_val(x_courant, x_nodes(iloc)),x_f(:,ggi),normal(:,ggi)) - if(move_mesh) then - udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi) - else - udotn=dot_product(u_f(:,ggi), normgi) - end if + if(move_mesh) then + udotn=dot_product((u_f(:,ggi)-ug_f(:,ggi)), normgi) + else + udotn=dot_product(u_f(:,ggi), normgi) + end if - inflow = (udotn<=0.0) + inflow = (udotn<=0.0) - income = merge(1.0,0.0,inflow) + income = merge(1.0,0.0,inflow) - select case (matdens%field_type) - case(FIELD_TYPE_CONSTANT) + select case (matdens%field_type) + case(FIELD_TYPE_CONSTANT) - matdens_face_val = matdens_ele(iloc) - oldmatdens_face_val = oldmatdens_ele(iloc) + matdens_face_val = matdens_ele(iloc) + oldmatdens_face_val = oldmatdens_ele(iloc) - case default + case default - call evaluate_face_val(matdens_face_val, oldmatdens_face_val, & - iloc, oloc, ggi, nodes, & - t_cvshape,& - matdens_ele, oldmatdens_ele, & - matdens_upwind, oldmatdens_upwind, & - inflow, cfl_ele, & - matdens_options) + call evaluate_face_val(matdens_face_val, oldmatdens_face_val, & + iloc, oloc, ggi, nodes, & + t_cvshape,& + matdens_ele, oldmatdens_ele, & + matdens_upwind, oldmatdens_upwind, & + inflow, cfl_ele, & + matdens_options) - end select + end select - matdens_theta_val=theta_val(iloc, oloc, & - matdens_face_val, & - oldmatdens_face_val, & - matdens_options%theta, l_dt, udotn, & - x_ele, matdens_options%limit_theta, & - matdens_ele, oldmatdens_ele) + matdens_theta_val=theta_val(iloc, oloc, & + matdens_face_val, & + oldmatdens_face_val, & + matdens_options%theta, l_dt, udotn, & + x_ele, matdens_options%limit_theta, & + matdens_ele, oldmatdens_ele) - call addto(courant, nodes(iloc), abs(udotn)*(1.-income)*detwei(ggi)*matdens_theta_val) - call addto(courant, nodes(oloc), abs(udotn)*income*detwei(ggi)*matdens_theta_val) ! notvisited + call addto(courant, nodes(iloc), abs(udotn)*(1.-income)*detwei(ggi)*matdens_theta_val) + call addto(courant, nodes(oloc), abs(udotn)*income*detwei(ggi)*matdens_theta_val) ! notvisited - end if ! notvisited + end if ! notvisited - end do + end do - end if - end do - end do + end if + end do + end do end do u_cvbdyshape=make_cvbdy_element_shape(cvfaces, u%mesh%faces%shape) @@ -2205,97 +2205,97 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) t_cvbdyshape=make_cvbdy_element_shape(cvfaces, matdens%mesh%faces%shape) allocate(x_ele_bdy(x%dim,face_loc(x,1)), & - u_bdy_f(u%dim, u_cvbdyshape%ngi), & - detwei_bdy(x_cvbdyshape%ngi), & - normal_bdy(x%dim, x_cvbdyshape%ngi), & - matdens_ele_bdy(face_loc(matdens,1)), & - oldmatdens_ele_bdy(face_loc(oldmatdens,1)), & - ghost_matdens_ele_bdy(face_loc(matdens,1)), & - ghost_oldmatdens_ele_bdy(face_loc(oldmatdens,1))) + u_bdy_f(u%dim, u_cvbdyshape%ngi), & + detwei_bdy(x_cvbdyshape%ngi), & + normal_bdy(x%dim, x_cvbdyshape%ngi), & + matdens_ele_bdy(face_loc(matdens,1)), & + oldmatdens_ele_bdy(face_loc(oldmatdens,1)), & + ghost_matdens_ele_bdy(face_loc(matdens,1)), & + ghost_oldmatdens_ele_bdy(face_loc(oldmatdens,1))) allocate(matdens_bc_type(surface_element_count(matdens)), & - nodes_bdy(face_loc(courant,1))) + nodes_bdy(face_loc(courant,1))) if(move_mesh) then - ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) - allocate(ug_bdy_f(ug%dim, ug_cvbdyshape%ngi)) + ug_cvbdyshape=make_cvbdy_element_shape(cvfaces, ug%mesh%faces%shape) + allocate(ug_bdy_f(ug%dim, ug_cvbdyshape%ngi)) end if ! get the fields over the surface containing the bcs call get_entire_boundary_condition(matdens, (/"weakdirichlet", & - "internal "/), matdens_bc, matdens_bc_type) + "internal "/), matdens_bc, matdens_bc_type) do sele=1,surface_element_count(courant) - if(matdens_bc_type(sele)==2) cycle + if(matdens_bc_type(sele)==2) cycle - ele = face_ele(x, sele) - x_ele = ele_val(x, ele) - x_ele_bdy = face_val(x, sele) - nodes_bdy=face_global_nodes(courant, sele) + ele = face_ele(x, sele) + x_ele = ele_val(x, ele) + x_ele_bdy = face_val(x, sele) + nodes_bdy=face_global_nodes(courant, sele) - call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & - x_cvbdyshape, normal_bdy, detwei_bdy) + call transform_cvsurf_facet_to_physical(x_ele, x_ele_bdy, & + x_cvbdyshape, normal_bdy, detwei_bdy) - u_bdy_f=face_val_at_quad(u, sele, u_cvbdyshape) - if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) + u_bdy_f=face_val_at_quad(u, sele, u_cvbdyshape) + if(move_mesh) ug_bdy_f=face_val_at_quad(ug, sele, ug_cvbdyshape) - ! deal with bcs for tdensity - if(matdens_bc_type(sele)==1) then - ghost_matdens_ele_bdy=ele_val(matdens_bc, sele) - else - ghost_matdens_ele_bdy=face_val(matdens, sele) - end if + ! deal with bcs for tdensity + if(matdens_bc_type(sele)==1) then + ghost_matdens_ele_bdy=ele_val(matdens_bc, sele) + else + ghost_matdens_ele_bdy=face_val(matdens, sele) + end if - if(matdens_bc_type(sele)==1) then - ghost_oldmatdens_ele_bdy=ele_val(matdens_bc, sele) ! not considering time varying bcs yet - else - ghost_oldmatdens_ele_bdy=face_val(oldmatdens, sele) - end if + if(matdens_bc_type(sele)==1) then + ghost_oldmatdens_ele_bdy=ele_val(matdens_bc, sele) ! not considering time varying bcs yet + else + ghost_oldmatdens_ele_bdy=face_val(oldmatdens, sele) + end if - matdens_ele_bdy=face_val(matdens, sele) - oldmatdens_ele_bdy=face_val(oldmatdens, sele) + matdens_ele_bdy=face_val(matdens, sele) + oldmatdens_ele_bdy=face_val(oldmatdens, sele) - do iloc = 1, courant%mesh%faces%shape%loc + do iloc = 1, courant%mesh%faces%shape%loc - do face = 1, cvfaces%sfaces + do face = 1, cvfaces%sfaces - if(cvfaces%sneiloc(iloc,face)/=0) then + if(cvfaces%sneiloc(iloc,face)/=0) then - do gi = 1, cvfaces%shape%ngi + do gi = 1, cvfaces%shape%ngi - ggi = (face-1)*cvfaces%shape%ngi + gi + ggi = (face-1)*cvfaces%shape%ngi + gi - if(move_mesh) then - udotn=dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) - else - udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) - end if + if(move_mesh) then + udotn=dot_product((u_bdy_f(:,ggi)-ug_bdy_f(:,ggi)), normal_bdy(:,ggi)) + else + udotn=dot_product(u_bdy_f(:,ggi), normal_bdy(:,ggi)) + end if - if(udotn>0.0) then - income=0.0 - else - income=1.0 - end if + if(udotn>0.0) then + income=0.0 + else + income=1.0 + end if - ! as we're on the boundary it's not possible to use high order methods so just - ! default to the pivotted solution method (first order upwinding) - ! if the flow is incoming then use the bc ghost values - ! if the flow is outgoing then use the surface nodes value + ! as we're on the boundary it's not possible to use high order methods so just + ! default to the pivotted solution method (first order upwinding) + ! if the flow is incoming then use the bc ghost values + ! if the flow is outgoing then use the surface nodes value - matdens_face_val = income*ghost_matdens_ele_bdy(iloc) + (1.-income)*matdens_ele_bdy(iloc) - oldmatdens_face_val = income*ghost_oldmatdens_ele_bdy(iloc) + (1.-income)*oldmatdens_ele_bdy(iloc) + matdens_face_val = income*ghost_matdens_ele_bdy(iloc) + (1.-income)*matdens_ele_bdy(iloc) + oldmatdens_face_val = income*ghost_oldmatdens_ele_bdy(iloc) + (1.-income)*oldmatdens_ele_bdy(iloc) - matdens_theta_val = matdens_options%theta*matdens_face_val + (1.-matdens_options%theta)*oldmatdens_face_val + matdens_theta_val = matdens_options%theta*matdens_face_val + (1.-matdens_options%theta)*oldmatdens_face_val - call addto(courant, nodes_bdy(iloc), abs(udotn)*(1.0-income)*detwei_bdy(ggi)*matdens_theta_val) + call addto(courant, nodes_bdy(iloc), abs(udotn)*(1.0-income)*detwei_bdy(ggi)*matdens_theta_val) - end do + end do - end if + end if - end do + end do - end do + end do end do @@ -2320,9 +2320,9 @@ subroutine calculate_matdens_courant_number_cv(state, courant, dt) call deallocate(mesh_sparsity) if(move_mesh) then - call deallocate(ug_cvshape) - call deallocate(ug_cvbdyshape) - deallocate(ug_f, ug_bdy_f) + call deallocate(ug_cvshape) + call deallocate(ug_cvbdyshape) + deallocate(ug_f, ug_bdy_f) end if end subroutine calculate_matdens_courant_number_cv @@ -2339,11 +2339,11 @@ subroutine calculate_linear_momentum(state, momentum) density => extract_scalar_field(state, "Density") if(.not.density%mesh==momentum%mesh) then - allocate(tmpdensity) - call allocate(tmpdensity, momentum%mesh, "TmpDensity") - call remap_field(density, tmpdensity) + allocate(tmpdensity) + call allocate(tmpdensity, momentum%mesh, "TmpDensity") + call remap_field(density, tmpdensity) else - tmpdensity => density + tmpdensity => density end if velocity => extract_vector_field(state, "Velocity") @@ -2352,8 +2352,8 @@ subroutine calculate_linear_momentum(state, momentum) call scale(momentum, tmpdensity) if(.not.density%mesh==momentum%mesh) then - call deallocate(tmpdensity) - deallocate(tmpdensity) + call deallocate(tmpdensity) + deallocate(tmpdensity) end if end subroutine calculate_linear_momentum @@ -2378,46 +2378,46 @@ subroutine calculate_absolute_difference_scalar(state, difference) field_a => extract_scalar_field(state, trim(field_name_a)) if(mesh_compatible(field_a%mesh, difference%mesh)) then - remap_field_a=.false. - l_field_a=>field_a + remap_field_a=.false. + l_field_a=>field_a else - remap_field_a=.true. - allocate(l_field_a) - call allocate(l_field_a, difference%mesh, trim(field_a%name)) - call zero(l_field_a) + remap_field_a=.true. + allocate(l_field_a) + call allocate(l_field_a, difference%mesh, trim(field_a%name)) + call zero(l_field_a) - field_coordinate => get_external_coordinate_field(state, field_a%mesh) - difference_coordinate => get_external_coordinate_field(state, difference%mesh) + field_coordinate => get_external_coordinate_field(state, field_a%mesh) + difference_coordinate => get_external_coordinate_field(state, difference%mesh) - call linear_interpolation(field_a, field_coordinate, l_field_a, difference_coordinate) + call linear_interpolation(field_a, field_coordinate, l_field_a, difference_coordinate) end if field_b => extract_scalar_field(state, trim(field_name_b)) if(mesh_compatible(field_b%mesh, difference%mesh)) then - remap_field_b=.false. - l_field_b=>field_b + remap_field_b=.false. + l_field_b=>field_b else - remap_field_b=.true. - allocate(l_field_b) - call allocate(l_field_b, difference%mesh, trim(field_b%name)) - call zero(l_field_b) + remap_field_b=.true. + allocate(l_field_b) + call allocate(l_field_b, difference%mesh, trim(field_b%name)) + call zero(l_field_b) - field_coordinate => get_external_coordinate_field(state, field_b%mesh) - difference_coordinate => get_external_coordinate_field(state, difference%mesh) + field_coordinate => get_external_coordinate_field(state, field_b%mesh) + difference_coordinate => get_external_coordinate_field(state, difference%mesh) - call linear_interpolation(field_b, field_coordinate, l_field_b, difference_coordinate) + call linear_interpolation(field_b, field_coordinate, l_field_b, difference_coordinate) end if if (have_option(trim(difference%option_path)//"/diagnostic/relative_to_average")) then - call field_stats(l_field_a, max=max_a) - call field_stats(l_field_a, min=min_a) - av_a = (max_a+min_a)/2.0 - call field_stats(l_field_b, max=max_b) - call field_stats(l_field_b, min=min_b) - av_b = (max_b+min_b)/2.0 - av_diff = av_a-av_b + call field_stats(l_field_a, max=max_a) + call field_stats(l_field_a, min=min_a) + av_a = (max_a+min_a)/2.0 + call field_stats(l_field_b, max=max_b) + call field_stats(l_field_b, min=min_b) + av_b = (max_b+min_b)/2.0 + av_diff = av_a-av_b else - av_diff = 0.0 + av_diff = 0.0 end if call set(difference, l_field_a) @@ -2427,21 +2427,21 @@ subroutine calculate_absolute_difference_scalar(state, difference) difference%val = abs(difference%val) if (have_option(trim(difference%option_path)//"/diagnostic/ignore_boundaries")) then - if (associated(difference%mesh%faces%surface_node_list)) then - if (size(difference%mesh%faces%surface_node_list)>0) then - call set(difference, difference%mesh%faces%surface_node_list, & - spread(0.0, 1, size(difference%mesh%faces%surface_node_list))) - end if - end if + if (associated(difference%mesh%faces%surface_node_list)) then + if (size(difference%mesh%faces%surface_node_list)>0) then + call set(difference, difference%mesh%faces%surface_node_list, & + spread(0.0, 1, size(difference%mesh%faces%surface_node_list))) + end if + end if end if if(remap_field_a) then - call deallocate(l_field_a) - deallocate(l_field_a) + call deallocate(l_field_a) + deallocate(l_field_a) end if if(remap_field_b) then - call deallocate(l_field_b) - deallocate(l_field_b) + call deallocate(l_field_b) + deallocate(l_field_b) end if end subroutine calculate_absolute_difference_scalar @@ -2469,49 +2469,49 @@ subroutine calculate_absolute_difference_vector(state, difference) field_a => extract_vector_field(state, trim(field_name_a)) if(mesh_compatible(field_a%mesh, difference%mesh)) then - remap_field_a=.false. - l_field_a=>field_a + remap_field_a=.false. + l_field_a=>field_a else - remap_field_a=.true. - allocate(l_field_a) - call allocate(l_field_a, field_a%dim, difference%mesh, trim(field_a%name)) - call zero(l_field_a) + remap_field_a=.true. + allocate(l_field_a) + call allocate(l_field_a, field_a%dim, difference%mesh, trim(field_a%name)) + call zero(l_field_a) - field_coordinate => get_external_coordinate_field(state, field_a%mesh) - difference_coordinate => get_external_coordinate_field(state, difference%mesh) + field_coordinate => get_external_coordinate_field(state, field_a%mesh) + difference_coordinate => get_external_coordinate_field(state, difference%mesh) - call linear_interpolation(field_a, field_coordinate, l_field_a, difference_coordinate) + call linear_interpolation(field_a, field_coordinate, l_field_a, difference_coordinate) end if field_b => extract_vector_field(state, trim(field_name_b)) if(mesh_compatible(field_b%mesh, difference%mesh)) then - remap_field_b=.false. - l_field_b=>field_b + remap_field_b=.false. + l_field_b=>field_b else - remap_field_b=.true. - allocate(l_field_b) - call allocate(l_field_b, field_b%dim, difference%mesh, trim(field_b%name)) - call zero(l_field_b) + remap_field_b=.true. + allocate(l_field_b) + call allocate(l_field_b, field_b%dim, difference%mesh, trim(field_b%name)) + call zero(l_field_b) - field_coordinate => get_external_coordinate_field(state, field_b%mesh) - difference_coordinate => get_external_coordinate_field(state, difference%mesh) + field_coordinate => get_external_coordinate_field(state, field_b%mesh) + difference_coordinate => get_external_coordinate_field(state, difference%mesh) - call linear_interpolation(field_b, field_coordinate, l_field_b, difference_coordinate) + call linear_interpolation(field_b, field_coordinate, l_field_b, difference_coordinate) end if av_diff = 0.0 if (have_option(trim(difference%option_path)//"/diagnostic/relative_to_average")) then - do i = 1, difference%dim - field_comp = extract_scalar_field(l_field_a, i) - call field_stats(field_comp, max=max_a) - call field_stats(field_comp, min=min_a) - av_a = (max_a+min_a)/2.0 - field_comp = extract_scalar_field(l_field_b, i) - call field_stats(field_comp, max=max_b) - call field_stats(field_comp, min=min_b) - av_b = (max_b+min_b)/2.0 - av_diff(i) = av_a-av_b - end do + do i = 1, difference%dim + field_comp = extract_scalar_field(l_field_a, i) + call field_stats(field_comp, max=max_a) + call field_stats(field_comp, min=min_a) + av_a = (max_a+min_a)/2.0 + field_comp = extract_scalar_field(l_field_b, i) + call field_stats(field_comp, max=max_b) + call field_stats(field_comp, min=min_b) + av_b = (max_b+min_b)/2.0 + av_diff(i) = av_a-av_b + end do end if call set(difference, l_field_a) @@ -2519,16 +2519,16 @@ subroutine calculate_absolute_difference_vector(state, difference) call addto(difference, -av_diff) do i = 1, difference%dim - difference%val(i,:) = abs(difference%val(i,:)) + difference%val(i,:) = abs(difference%val(i,:)) end do if(remap_field_a) then - call deallocate(l_field_a) - deallocate(l_field_a) + call deallocate(l_field_a) + deallocate(l_field_a) end if if(remap_field_b) then - call deallocate(l_field_b) - deallocate(l_field_b) + call deallocate(l_field_b) + deallocate(l_field_b) end if end subroutine calculate_absolute_difference_vector @@ -2558,8 +2558,8 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) ewrite(2,*) 'in calculate bed_shear_stress' if (have_option(trim(bed_shear_stress%option_path)//"/prescribed")) then - ewrite(2,*) 'prescribed bed_shear_stress - not calculating' - return + ewrite(2,*) 'prescribed bed_shear_stress - not calculating' + return end if ! assumes constant density @@ -2567,13 +2567,13 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) ! calculate using drag coefficient if (have_option(trim(bed_shear_stress%option_path)//& - &"/diagnostic/calculation_method/drag_coefficient")) then + &"/diagnostic/calculation_method/drag_coefficient")) then call zero(bed_shear_stress) call get_option(trim(bed_shear_stress%option_path)//& - & "/diagnostic/calculation_method/drag_coefficient",& - & drag_coefficient) + & "/diagnostic/calculation_method/drag_coefficient",& + & drag_coefficient) U => extract_vector_field(state, "Velocity") snloc = face_loc(U, 1) @@ -2589,9 +2589,9 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) end do deallocate( faceglobalnodes ) - ! calculate using velocity gradient + ! calculate using velocity gradient else if (have_option(trim(bed_shear_stress%option_path)//& - &"/diagnostic/calculation_method/velocity_gradient")) then + &"/diagnostic/calculation_method/velocity_gradient")) then call zero(bed_shear_stress) @@ -2610,7 +2610,7 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) ! Check velociy and bed shear stress meshes are consistent if (continuity(bed_shear_stress) /= continuity(U) .or. & - element_degree(bed_shear_stress, 1) /= element_degree(U, 1)) then + element_degree(bed_shear_stress, 1) /= element_degree(U, 1)) then FLAbort('Bed shear stress and velocity mesh must have the same continuity and degree') end if @@ -2621,7 +2621,7 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) do face = 1, surface_element_count(bed_shear_stress) call calculate_bed_shear_stress_ele_cg(bed_shear_stress, masslump, face, X, U,& - & visc, density) + & visc, density) end do where (masslump%val/=0.0) @@ -2660,13 +2660,13 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) ! calculate bed shear stress do face = 1, ele_count(bed_shear_stress_surface) call calculate_bed_shear_stress_ele_dg(bed_shear_stress_surface, face, X, grad_u_surface,& - & visc_surface, density) + & visc_surface, density) ! copy values to volume field - can be done element by element as the surface is generated ! as we are in DG call set(bed_shear_stress, & - face_global_nodes(bed_shear_stress, face), & - ele_val(bed_shear_stress_surface, face)) + face_global_nodes(bed_shear_stress, face), & + ele_val(bed_shear_stress_surface, face)) end do call deallocate(bed_shear_stress_surface) @@ -2685,122 +2685,122 @@ subroutine calculate_bed_shear_stress(state, bed_shear_stress) end subroutine calculate_bed_shear_stress subroutine calculate_bed_shear_stress_ele_cg(bed_shear_stress, masslump, face, X, U, visc& - &, density) - - type(vector_field), intent(inout) :: bed_shear_stress - type(scalar_field), intent(inout) :: masslump - type(vector_field), intent(in), pointer :: X, U - type(tensor_field), intent(in), pointer :: visc - integer, intent(in) :: face - real, intent(in) :: density - - integer :: i, j, i_gi, ele, dim - type(element_type), pointer :: f_shape, shape - real, dimension(face_ngi(X, face)) :: detwei - real, dimension(X%dim, face_ngi(X, face)) :: normal, normal_shear_at_quad, X_ele - real, dimension(X%dim) :: abs_normal - real, dimension(ele_loc(X, face_ele(X, face)), face_ngi(X, face), X%dim) :: ele_dshape_at_face_quad - real, dimension(X%dim, X%dim, face_ngi(X, face)) :: grad_U_at_quad, visc_at_quad, shear_at_quad - real, dimension(X%dim, face_loc(U, face)) :: normal_shear_at_loc - real, dimension(face_loc(X, face), face_loc(U, face)) :: mass - - ele = face_ele(X, face) ! ele number for volume mesh - dim = mesh_dim(bed_shear_stress) ! field dimension - - ! get shape functions - f_shape => face_shape(U, face) - shape => ele_shape(U, ele) - - call transform_facet_to_physical(X, face, shape, ele_dshape_at_face_quad, & - detwei_f = detwei, normal = normal) - - ! Calculate grad U at the surface element quadrature points - do i=1, dim - do j=1, dim - grad_U_at_quad(i, j, :) = & - & matmul(ele_val(U, j, ele), ele_dshape_at_face_quad(:,:,i)) - end do - end do - - visc_at_quad = face_val_at_quad(visc, face) - X_ele = face_val_at_quad(X, face) - do i_gi = 1, face_ngi(X, face) - ! determine shear ( nu*(grad_u + grad_u.T) ) - shear_at_quad(:,:,i_gi) = matmul(grad_U_at_quad(:,:,i_gi) + transpose(grad_U_at_quad(:,:,i_gi)), visc_at_quad(:,:,i_gi)) - - ! Get absolute of normal vector - do i = 1,dim - abs_normal(i) = abs(normal(i,i_gi)) - end do - - ! Multiply by surface normal (dim,sgi) to obtain shear in direction normal - ! to surface (not sure why it is transpose(shear) but this gives the - ! correct answer?? sp911) - normal_shear_at_quad(:,i_gi) = matmul(transpose(shear_at_quad(:,:,i_gi)), abs_normal) - end do - - normal_shear_at_loc = shape_vector_rhs(f_shape, normal_shear_at_quad, density *& - & detwei) - - ! for CG we need to calculate a global lumped mass - mass = shape_shape(f_shape, f_shape, detwei) - call addto(masslump, face_global_nodes(bed_shear_stress,face), sum(mass,1)) - - ! add to bed_shear_stress field - call addto(bed_shear_stress, face_global_nodes(bed_shear_stress,face), normal_shear_at_loc) + &, density) + + type(vector_field), intent(inout) :: bed_shear_stress + type(scalar_field), intent(inout) :: masslump + type(vector_field), intent(in), pointer :: X, U + type(tensor_field), intent(in), pointer :: visc + integer, intent(in) :: face + real, intent(in) :: density + + integer :: i, j, i_gi, ele, dim + type(element_type), pointer :: f_shape, shape + real, dimension(face_ngi(X, face)) :: detwei + real, dimension(X%dim, face_ngi(X, face)) :: normal, normal_shear_at_quad, X_ele + real, dimension(X%dim) :: abs_normal + real, dimension(ele_loc(X, face_ele(X, face)), face_ngi(X, face), X%dim) :: ele_dshape_at_face_quad + real, dimension(X%dim, X%dim, face_ngi(X, face)) :: grad_U_at_quad, visc_at_quad, shear_at_quad + real, dimension(X%dim, face_loc(U, face)) :: normal_shear_at_loc + real, dimension(face_loc(X, face), face_loc(U, face)) :: mass + + ele = face_ele(X, face) ! ele number for volume mesh + dim = mesh_dim(bed_shear_stress) ! field dimension + + ! get shape functions + f_shape => face_shape(U, face) + shape => ele_shape(U, ele) + + call transform_facet_to_physical(X, face, shape, ele_dshape_at_face_quad, & + detwei_f = detwei, normal = normal) + + ! Calculate grad U at the surface element quadrature points + do i=1, dim + do j=1, dim + grad_U_at_quad(i, j, :) = & + & matmul(ele_val(U, j, ele), ele_dshape_at_face_quad(:,:,i)) + end do + end do + + visc_at_quad = face_val_at_quad(visc, face) + X_ele = face_val_at_quad(X, face) + do i_gi = 1, face_ngi(X, face) + ! determine shear ( nu*(grad_u + grad_u.T) ) + shear_at_quad(:,:,i_gi) = matmul(grad_U_at_quad(:,:,i_gi) + transpose(grad_U_at_quad(:,:,i_gi)), visc_at_quad(:,:,i_gi)) + + ! Get absolute of normal vector + do i = 1,dim + abs_normal(i) = abs(normal(i,i_gi)) + end do + + ! Multiply by surface normal (dim,sgi) to obtain shear in direction normal + ! to surface (not sure why it is transpose(shear) but this gives the + ! correct answer?? sp911) + normal_shear_at_quad(:,i_gi) = matmul(transpose(shear_at_quad(:,:,i_gi)), abs_normal) + end do + + normal_shear_at_loc = shape_vector_rhs(f_shape, normal_shear_at_quad, density *& + & detwei) + + ! for CG we need to calculate a global lumped mass + mass = shape_shape(f_shape, f_shape, detwei) + call addto(masslump, face_global_nodes(bed_shear_stress,face), sum(mass,1)) + + ! add to bed_shear_stress field + call addto(bed_shear_stress, face_global_nodes(bed_shear_stress,face), normal_shear_at_loc) end subroutine calculate_bed_shear_stress_ele_cg subroutine calculate_bed_shear_stress_ele_dg(bss, ele, X, grad_U, visc, density) - type(vector_field), intent(inout) :: bss - type(vector_field), intent(in), pointer :: X - type(tensor_field), intent(in) :: visc - type(tensor_field), intent(in) :: grad_U - integer, intent(in) :: ele - real, intent(in) :: density - - integer :: i, i_gi - type(element_type), pointer :: shape - real, dimension(ele_ngi(bss, ele)) :: detwei - real, dimension(X%dim, ele_ngi(bss, ele)) :: normal, normal_shear_at_quad - real, dimension(X%dim) :: abs_normal - real, dimension(X%dim, X%dim, ele_ngi(grad_U, ele)) :: grad_U_at_quad, visc_at_quad, shear_at_quad - real, dimension(X%dim, ele_loc(bss, ele)) :: rhs - real, dimension(ele_loc(bss, ele), ele_loc(bss, ele)) :: inv_mass - - ! get shape functions - shape => ele_shape(bss, ele) - - call transform_facet_to_physical(X, ele, detwei_f = detwei, normal = normal) - - visc_at_quad = ele_val_at_quad(visc, ele) - grad_U_at_quad = ele_val_at_quad(grad_U, ele) - - do i_gi = 1, ele_ngi(bss, ele) - ! determine shear ( nu*(grad_u + grad_u.T ) ) - shear_at_quad(:,:,i_gi) = density * matmul(grad_U_at_quad(:,:,i_gi) + transpose(grad_U_at_quad(:,:,i_gi)), visc_at_quad(:,:,i_gi)) - - ! Get absolute of normal vector - do i = 1, bss%dim - abs_normal(i) = abs(normal(i,i_gi)) - end do - - ! Multiply by surface normal (dim,sgi) to obtain shear in direction normal - ! to surface (not sure why it is transpose(shear) but this gives the - ! correct answer?? sp911) - normal_shear_at_quad(:,i_gi) = matmul(transpose(shear_at_quad(:,:,i_gi)), abs_normal) - end do - - ! project on to basis functions to recover value at nodes - rhs = shape_vector_rhs(shape, normal_shear_at_quad, detwei) - inv_mass = inverse(shape_shape(shape, shape, detwei)) - do i = 1, X%dim - rhs(i, :) = matmul(inv_mass, rhs(i, :)) - end do - - ! add to bss field - call addto(bss, ele_nodes(bss,ele), rhs) + type(vector_field), intent(inout) :: bss + type(vector_field), intent(in), pointer :: X + type(tensor_field), intent(in) :: visc + type(tensor_field), intent(in) :: grad_U + integer, intent(in) :: ele + real, intent(in) :: density + + integer :: i, i_gi + type(element_type), pointer :: shape + real, dimension(ele_ngi(bss, ele)) :: detwei + real, dimension(X%dim, ele_ngi(bss, ele)) :: normal, normal_shear_at_quad + real, dimension(X%dim) :: abs_normal + real, dimension(X%dim, X%dim, ele_ngi(grad_U, ele)) :: grad_U_at_quad, visc_at_quad, shear_at_quad + real, dimension(X%dim, ele_loc(bss, ele)) :: rhs + real, dimension(ele_loc(bss, ele), ele_loc(bss, ele)) :: inv_mass + + ! get shape functions + shape => ele_shape(bss, ele) + + call transform_facet_to_physical(X, ele, detwei_f = detwei, normal = normal) + + visc_at_quad = ele_val_at_quad(visc, ele) + grad_U_at_quad = ele_val_at_quad(grad_U, ele) + + do i_gi = 1, ele_ngi(bss, ele) + ! determine shear ( nu*(grad_u + grad_u.T ) ) + shear_at_quad(:,:,i_gi) = density * matmul(grad_U_at_quad(:,:,i_gi) + transpose(grad_U_at_quad(:,:,i_gi)), visc_at_quad(:,:,i_gi)) + + ! Get absolute of normal vector + do i = 1, bss%dim + abs_normal(i) = abs(normal(i,i_gi)) + end do + + ! Multiply by surface normal (dim,sgi) to obtain shear in direction normal + ! to surface (not sure why it is transpose(shear) but this gives the + ! correct answer?? sp911) + normal_shear_at_quad(:,i_gi) = matmul(transpose(shear_at_quad(:,:,i_gi)), abs_normal) + end do + + ! project on to basis functions to recover value at nodes + rhs = shape_vector_rhs(shape, normal_shear_at_quad, detwei) + inv_mass = inverse(shape_shape(shape, shape, detwei)) + do i = 1, X%dim + rhs(i, :) = matmul(inv_mass, rhs(i, :)) + end do + + ! add to bss field + call addto(bss, ele_nodes(bss,ele), rhs) end subroutine calculate_bed_shear_stress_ele_dg @@ -2841,84 +2841,84 @@ subroutine calculate_max_bed_shear_stress(state, max_bed_shear_stress) call deallocate(magnitude_max_bss) call deallocate(magnitude_bss) else - call zero(max_bed_shear_stress) + call zero(max_bed_shear_stress) end if end subroutine calculate_max_bed_shear_stress subroutine calculate_galerkin_projection_scalar(state, field) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: field - - character(len=len_trim(field%option_path)) :: path - character(len=FIELD_NAME_LEN) :: field_name - type(scalar_field), pointer :: projected_field - type(vector_field), pointer :: positions - type(csr_sparsity) :: mass_sparsity - type(csr_matrix) :: mass - type(scalar_field) :: rhs, mass_lumped, inverse_mass_lumped - logical :: dg - logical :: check_integrals - logical :: apply_bcs, lump_mass - - integer :: ele - - dg = (continuity(field) < 0) - - check_integrals = .false. - apply_bcs = .true. - - path = field%option_path - call get_option(path // "/diagnostic/source_field_name", field_name) - lump_mass=have_option(path // "/diagnostic/lump_mass") - projected_field => extract_scalar_field(state, trim(field_name)) - positions => extract_vector_field(state, "Coordinate") - - ! Assuming they're on the same quadrature - assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) - - if (.not. dg .and. .not. lump_mass) then - mass_sparsity = make_sparsity(field%mesh, field%mesh, name="MassMatrixSparsity") - call allocate(mass, mass_sparsity, name="MassMatrix") - call zero(mass) - else if (lump_mass) then - call allocate(mass_lumped, field%mesh, name="GalerkinProjectionMassLumped") - call zero(mass_lumped) - end if - - if (lump_mass .or. .not. dg) then - call allocate(rhs, field%mesh, name="GalerkinProjectionRHS") - call zero(rhs) - end if - - do ele=1,ele_count(field) - call assemble_galerkin_projection(field, projected_field, positions, & - & mass, rhs, ele, dg) - end do - - if (lump_mass) then - call allocate(inverse_mass_lumped, field%mesh, & - name="GalerkinProjectionInverseMassLumped") - call invert(mass_lumped, inverse_mass_lumped) - call set(field, rhs) - call scale(field, inverse_mass_lumped) - call deallocate(mass_lumped) - call deallocate(inverse_mass_lumped) - call deallocate(rhs) - else if (.not. dg) then - call petsc_solve(field, mass, rhs, option_path=path // "/diagnostic") - call deallocate(mass) - call deallocate(mass_sparsity) - call deallocate(rhs) - end if - - if (check_integrals) then - assert(field_integral(field, positions) .feq. field_integral(projected_field, positions)) - end if - - contains - - subroutine assemble_galerkin_projection(field, projected_field, positions, mass, rhs, ele, dg) + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: field + + character(len=len_trim(field%option_path)) :: path + character(len=FIELD_NAME_LEN) :: field_name + type(scalar_field), pointer :: projected_field + type(vector_field), pointer :: positions + type(csr_sparsity) :: mass_sparsity + type(csr_matrix) :: mass + type(scalar_field) :: rhs, mass_lumped, inverse_mass_lumped + logical :: dg + logical :: check_integrals + logical :: apply_bcs, lump_mass + + integer :: ele + + dg = (continuity(field) < 0) + + check_integrals = .false. + apply_bcs = .true. + + path = field%option_path + call get_option(path // "/diagnostic/source_field_name", field_name) + lump_mass=have_option(path // "/diagnostic/lump_mass") + projected_field => extract_scalar_field(state, trim(field_name)) + positions => extract_vector_field(state, "Coordinate") + + ! Assuming they're on the same quadrature + assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) + + if (.not. dg .and. .not. lump_mass) then + mass_sparsity = make_sparsity(field%mesh, field%mesh, name="MassMatrixSparsity") + call allocate(mass, mass_sparsity, name="MassMatrix") + call zero(mass) + else if (lump_mass) then + call allocate(mass_lumped, field%mesh, name="GalerkinProjectionMassLumped") + call zero(mass_lumped) + end if + + if (lump_mass .or. .not. dg) then + call allocate(rhs, field%mesh, name="GalerkinProjectionRHS") + call zero(rhs) + end if + + do ele=1,ele_count(field) + call assemble_galerkin_projection(field, projected_field, positions, & + & mass, rhs, ele, dg) + end do + + if (lump_mass) then + call allocate(inverse_mass_lumped, field%mesh, & + name="GalerkinProjectionInverseMassLumped") + call invert(mass_lumped, inverse_mass_lumped) + call set(field, rhs) + call scale(field, inverse_mass_lumped) + call deallocate(mass_lumped) + call deallocate(inverse_mass_lumped) + call deallocate(rhs) + else if (.not. dg) then + call petsc_solve(field, mass, rhs, option_path=path // "/diagnostic") + call deallocate(mass) + call deallocate(mass_sparsity) + call deallocate(rhs) + end if + + if (check_integrals) then + assert(field_integral(field, positions) .feq. field_integral(projected_field, positions)) + end if + + contains + + subroutine assemble_galerkin_projection(field, projected_field, positions, mass, rhs, ele, dg) type(scalar_field), intent(inout) :: field type(scalar_field), intent(in) :: projected_field type(vector_field), intent(in) :: positions @@ -2948,103 +2948,103 @@ subroutine assemble_galerkin_projection(field, projected_field, positions, mass, ! And compute the product of the basis functions little_mba = 0 do i=1,ele_ngi(field, ele) - forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) - little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) - end forall - little_mba = little_mba + little_mba_int * detwei(i) + forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) + little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) + end forall + little_mba = little_mba + little_mba_int * detwei(i) end do proj_field_val = ele_val(projected_field, ele) little_rhs = matmul(little_mba, proj_field_val) if (lump_mass) then - call addto(mass_lumped, ele_nodes(field, ele), & - sum(little_mass,2)) - call addto(rhs, ele_nodes(field, ele), little_rhs) + call addto(mass_lumped, ele_nodes(field, ele), & + sum(little_mass,2)) + call addto(rhs, ele_nodes(field, ele), little_rhs) else if (dg) then - call solve(little_mass, little_rhs) - call set(field, ele_nodes(field, ele), little_rhs) + call solve(little_mass, little_rhs) + call set(field, ele_nodes(field, ele), little_rhs) else - call addto(mass, ele_nodes(field, ele), ele_nodes(field, ele), little_mass) - call addto(rhs, ele_nodes(field, ele), little_rhs) + call addto(mass, ele_nodes(field, ele), ele_nodes(field, ele), little_mass) + call addto(rhs, ele_nodes(field, ele), little_rhs) end if - end subroutine assemble_galerkin_projection + end subroutine assemble_galerkin_projection end subroutine calculate_galerkin_projection_scalar subroutine calculate_galerkin_projection_vector(state, field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: field - character(len=len_trim(field%option_path)) :: path - character(len=FIELD_NAME_LEN) :: field_name - type(vector_field), pointer :: projected_field - type(vector_field), pointer :: positions - type(csr_sparsity) :: mass_sparsity - type(csr_matrix) :: mass - type(vector_field) :: rhs - type(scalar_field) :: mass_lumped, inverse_mass_lumped - logical :: dg - logical :: check_integrals - logical :: apply_bcs, lump_mass - - integer :: ele - - dg = (continuity(field) < 0) - check_integrals = .false. - apply_bcs = .true. - - path = field%option_path - call get_option(path // "/diagnostic/source_field_name", field_name) - lump_mass=have_option(path // "/diagnostic/lump_mass") - projected_field => extract_vector_field(state, trim(field_name)) - positions => extract_vector_field(state, "Coordinate") - - ! Assuming they're on the same quadrature - assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) - - if (.not. dg .and. .not. lump_mass) then - mass_sparsity = make_sparsity(field%mesh, field%mesh, name="MassMatrixSparsity") - call allocate(mass, mass_sparsity, name="MassMatrix") - call zero(mass) - else if (lump_mass) then - call allocate(mass_lumped, field%mesh, name="GalerkinProjectionMassLumped") - call zero(mass_lumped) - end if - - if (lump_mass .or. .not. dg) then - call allocate(rhs, field%dim, field%mesh, name="GalerkinProjectionRHS") - call zero(rhs) - end if - - do ele=1,ele_count(field) - call assemble_galerkin_projection(field, projected_field, positions, & - & mass, rhs, ele, dg) - end do - - if (lump_mass) then - call allocate(inverse_mass_lumped, field%mesh, & - name="GalerkinProjectionInverseMassLumped") - call invert(mass_lumped, inverse_mass_lumped) - call set(field, rhs) - call scale(field, inverse_mass_lumped) - call deallocate(mass_lumped) - call deallocate(inverse_mass_lumped) - call deallocate(rhs) - else if (.not. dg) then - call petsc_solve(field, mass, rhs, option_path=path // "/diagnostic") - call deallocate(mass) - call deallocate(mass_sparsity) - call deallocate(rhs) - end if - - if (check_integrals) then - assert(all(abs(field_integral(field, positions) - field_integral(projected_field, positions)) < epsilon(0.0_4))) - end if - - contains - - subroutine assemble_galerkin_projection(field, projected_field, positions, mass, rhs, ele, dg) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: field + character(len=len_trim(field%option_path)) :: path + character(len=FIELD_NAME_LEN) :: field_name + type(vector_field), pointer :: projected_field + type(vector_field), pointer :: positions + type(csr_sparsity) :: mass_sparsity + type(csr_matrix) :: mass + type(vector_field) :: rhs + type(scalar_field) :: mass_lumped, inverse_mass_lumped + logical :: dg + logical :: check_integrals + logical :: apply_bcs, lump_mass + + integer :: ele + + dg = (continuity(field) < 0) + check_integrals = .false. + apply_bcs = .true. + + path = field%option_path + call get_option(path // "/diagnostic/source_field_name", field_name) + lump_mass=have_option(path // "/diagnostic/lump_mass") + projected_field => extract_vector_field(state, trim(field_name)) + positions => extract_vector_field(state, "Coordinate") + + ! Assuming they're on the same quadrature + assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) + + if (.not. dg .and. .not. lump_mass) then + mass_sparsity = make_sparsity(field%mesh, field%mesh, name="MassMatrixSparsity") + call allocate(mass, mass_sparsity, name="MassMatrix") + call zero(mass) + else if (lump_mass) then + call allocate(mass_lumped, field%mesh, name="GalerkinProjectionMassLumped") + call zero(mass_lumped) + end if + + if (lump_mass .or. .not. dg) then + call allocate(rhs, field%dim, field%mesh, name="GalerkinProjectionRHS") + call zero(rhs) + end if + + do ele=1,ele_count(field) + call assemble_galerkin_projection(field, projected_field, positions, & + & mass, rhs, ele, dg) + end do + + if (lump_mass) then + call allocate(inverse_mass_lumped, field%mesh, & + name="GalerkinProjectionInverseMassLumped") + call invert(mass_lumped, inverse_mass_lumped) + call set(field, rhs) + call scale(field, inverse_mass_lumped) + call deallocate(mass_lumped) + call deallocate(inverse_mass_lumped) + call deallocate(rhs) + else if (.not. dg) then + call petsc_solve(field, mass, rhs, option_path=path // "/diagnostic") + call deallocate(mass) + call deallocate(mass_sparsity) + call deallocate(rhs) + end if + + if (check_integrals) then + assert(all(abs(field_integral(field, positions) - field_integral(projected_field, positions)) < epsilon(0.0_4))) + end if + + contains + + subroutine assemble_galerkin_projection(field, projected_field, positions, mass, rhs, ele, dg) type(vector_field), intent(inout) :: field type(vector_field), intent(in) :: projected_field type(vector_field), intent(in) :: positions @@ -3074,146 +3074,146 @@ subroutine assemble_galerkin_projection(field, projected_field, positions, mass, ! And compute the product of the basis functions little_mba = 0 do i=1,ele_ngi(field, ele) - forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) - little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) - end forall - little_mba = little_mba + little_mba_int * detwei(i) + forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) + little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) + end forall + little_mba = little_mba + little_mba_int * detwei(i) end do proj_field_val = ele_val(projected_field, ele) do i=1,field%dim - little_rhs(:, i) = matmul(little_mba, proj_field_val(i, :)) + little_rhs(:, i) = matmul(little_mba, proj_field_val(i, :)) end do if (lump_mass) then - call addto(mass_lumped, ele_nodes(field, ele), & - sum(little_mass,2)) - call addto(rhs, ele_nodes(field, ele), transpose(little_rhs)) + call addto(mass_lumped, ele_nodes(field, ele), & + sum(little_mass,2)) + call addto(rhs, ele_nodes(field, ele), transpose(little_rhs)) else if (dg) then - call solve(little_mass, little_rhs) - call set(field, ele_nodes(field, ele), transpose(little_rhs)) + call solve(little_mass, little_rhs) + call set(field, ele_nodes(field, ele), transpose(little_rhs)) else - call addto(mass, ele_nodes(field, ele), ele_nodes(field, ele), little_mass) - call addto(rhs, ele_nodes(field, ele), transpose(little_rhs)) + call addto(mass, ele_nodes(field, ele), ele_nodes(field, ele), little_mass) + call addto(rhs, ele_nodes(field, ele), transpose(little_rhs)) end if - end subroutine assemble_galerkin_projection + end subroutine assemble_galerkin_projection end subroutine calculate_galerkin_projection_vector subroutine calculate_universal_number(field) - !!< Output the universal numbering associated with field. Clearly this - !!< is primarily of interest for debugging. - type(scalar_field) :: field + !!< Output the universal numbering associated with field. Clearly this + !!< is primarily of interest for debugging. + type(scalar_field) :: field - integer i - type(halo_type) :: halo + integer i + type(halo_type) :: halo - if(.not.isparallel()) then - do i=1, node_count(field) - call set(field, i, real(i)) - end do + if(.not.isparallel()) then + do i=1, node_count(field) + call set(field, i, real(i)) + end do - else - halo=field%mesh%halos(2) + else + halo=field%mesh%halos(2) - do i=1, node_count(field) + do i=1, node_count(field) - call set(field, i, real(halo_universal_number(halo, i))) + call set(field, i, real(halo_universal_number(halo, i))) - end do + end do - end if + end if end subroutine calculate_universal_number subroutine calculate_node_owner(field) - !!< Output the process owning each node in field. Clearly this - !!< is primarily of interest for debugging. - type(scalar_field) :: field + !!< Output the process owning each node in field. Clearly this + !!< is primarily of interest for debugging. + type(scalar_field) :: field - integer i - type(halo_type) :: halo + integer i + type(halo_type) :: halo - if(.not.isparallel()) then - do i=1, node_count(field) - call set(field, i, real(i)) - end do + if(.not.isparallel()) then + do i=1, node_count(field) + call set(field, i, real(i)) + end do - else - halo=field%mesh%halos(2) + else + halo=field%mesh%halos(2) - do i=1, node_count(field) + do i=1, node_count(field) - call set(field, i, real(halo_node_owner(halo, i))) + call set(field, i, real(halo_node_owner(halo, i))) - end do + end do - end if + end if end subroutine calculate_node_owner subroutine calculate_galerkin_projection_tensor(state, field, solver_path) - type(state_type), intent(in) :: state - type(tensor_field), intent(inout) :: field - character(len=*), intent(in), optional :: solver_path - character(len=len_trim(field%option_path)) :: path - character(len=FIELD_NAME_LEN) :: field_name - type(tensor_field), pointer :: projected_field - type(vector_field), pointer :: positions - type(csr_sparsity) :: mass_sparsity - type(csr_matrix) :: mass - type(tensor_field) :: rhs - logical :: dg - logical :: check_integrals - logical :: apply_bcs - - integer :: ele - - dg = (continuity(field) < 0) - check_integrals = .false. - apply_bcs = .true. - - path = field%option_path - call get_option(path // "/diagnostic/source_field_name", field_name) - projected_field => extract_tensor_field(state, trim(field_name)) - positions => extract_vector_field(state, "Coordinate") - - ! Assuming they're on the same quadrature - assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) - - if (.not. dg) then - mass_sparsity = make_sparsity(field%mesh, field%mesh, name="MassMatrixSparsity") - call allocate(mass, mass_sparsity, name="MassMatrix") - call zero(mass) - call allocate(rhs, field%mesh, name="GalerkinProjectionRHS") - call zero(rhs) - end if - - do ele=1,ele_count(field) - call assemble_galerkin_projection(field, projected_field, positions, & - & mass, rhs, ele, dg) - end do - - if (.not. dg) then - if (present(solver_path)) then - call petsc_solve(field, mass, rhs, option_path=trim(solver_path)) - else - call petsc_solve(field, mass, rhs, option_path=path // "/diagnostic") - endif - call deallocate(mass) - call deallocate(mass_sparsity) - call deallocate(rhs) - end if + type(state_type), intent(in) :: state + type(tensor_field), intent(inout) :: field + character(len=*), intent(in), optional :: solver_path + character(len=len_trim(field%option_path)) :: path + character(len=FIELD_NAME_LEN) :: field_name + type(tensor_field), pointer :: projected_field + type(vector_field), pointer :: positions + type(csr_sparsity) :: mass_sparsity + type(csr_matrix) :: mass + type(tensor_field) :: rhs + logical :: dg + logical :: check_integrals + logical :: apply_bcs + + integer :: ele + + dg = (continuity(field) < 0) + check_integrals = .false. + apply_bcs = .true. + + path = field%option_path + call get_option(path // "/diagnostic/source_field_name", field_name) + projected_field => extract_tensor_field(state, trim(field_name)) + positions => extract_vector_field(state, "Coordinate") + + ! Assuming they're on the same quadrature + assert(ele_ngi(field, 1) == ele_ngi(projected_field, 1)) + + if (.not. dg) then + mass_sparsity = make_sparsity(field%mesh, field%mesh, name="MassMatrixSparsity") + call allocate(mass, mass_sparsity, name="MassMatrix") + call zero(mass) + call allocate(rhs, field%mesh, name="GalerkinProjectionRHS") + call zero(rhs) + end if + + do ele=1,ele_count(field) + call assemble_galerkin_projection(field, projected_field, positions, & + & mass, rhs, ele, dg) + end do + + if (.not. dg) then + if (present(solver_path)) then + call petsc_solve(field, mass, rhs, option_path=trim(solver_path)) + else + call petsc_solve(field, mass, rhs, option_path=path // "/diagnostic") + endif + call deallocate(mass) + call deallocate(mass_sparsity) + call deallocate(rhs) + end if ! if (check_integrals) then ! assert(all(abs(field_integral(field, positions) - field_integral(projected_field, positions)) < epsilon(0.0_4))) ! end if - contains - subroutine assemble_galerkin_projection(field, projected_field, positions, mass, rhs, ele, dg) + contains + subroutine assemble_galerkin_projection(field, projected_field, positions, mass, rhs, ele, dg) type(tensor_field), intent(inout) :: field type(tensor_field), intent(in) :: projected_field type(vector_field), intent(in) :: positions @@ -3243,39 +3243,39 @@ subroutine assemble_galerkin_projection(field, projected_field, positions, mass, ! And compute the product of the basis functions little_mba = 0 do i=1,ele_ngi(field, ele) - forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) - little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) - end forall - little_mba = little_mba + little_mba_int * detwei(i) + forall(j=1:ele_loc(field, ele), k=1:ele_loc(projected_field, ele)) + little_mba_int(j, k) = field_shape%n(j, i) * proj_field_shape%n(k, i) + end forall + little_mba = little_mba + little_mba_int * detwei(i) end do proj_field_val = ele_val(projected_field, ele) do i=1,field%dim(1) - do j=1,field%dim(2) - little_rhs(i, j, :) = matmul(little_mba, proj_field_val(i, j, :)) - end do + do j=1,field%dim(2) + little_rhs(i, j, :) = matmul(little_mba, proj_field_val(i, j, :)) + end do end do if (dg) then - FLAbort("You just need to write the appropriate solve interface.") - !call solve(little_mass, little_rhs) - call set(field, ele_nodes(field, ele), little_rhs) + FLAbort("You just need to write the appropriate solve interface.") + !call solve(little_mass, little_rhs) + call set(field, ele_nodes(field, ele), little_rhs) else - call addto(mass, ele_nodes(field, ele), ele_nodes(field, ele), little_mass) - call addto(rhs, ele_nodes(field, ele), little_rhs) + call addto(mass, ele_nodes(field, ele), ele_nodes(field, ele), little_mass) + call addto(rhs, ele_nodes(field, ele), little_rhs) end if - end subroutine assemble_galerkin_projection + end subroutine assemble_galerkin_projection end subroutine calculate_galerkin_projection_tensor subroutine calculate_diagnostic_coordinate_field(state, field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: field + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: field - type(vector_field) :: coordinate_field + type(vector_field) :: coordinate_field - coordinate_field = get_nodal_coordinate_field(state, field%mesh) - call set(field, coordinate_field) - call deallocate(coordinate_field) + coordinate_field = get_nodal_coordinate_field(state, field%mesh) + call set(field, coordinate_field) + call deallocate(coordinate_field) end subroutine calculate_diagnostic_coordinate_field diff --git a/femtools/Diagnostic_variables.F90 b/femtools/Diagnostic_variables.F90 index 71fd21560b..69d86eca06 100644 --- a/femtools/Diagnostic_variables.F90 +++ b/femtools/Diagnostic_variables.F90 @@ -28,2914 +28,2914 @@ #include "version.h" module diagnostic_variables - !!< A module to calculate and output diagnostics. This replaces the .s file. - use iso_c_binding, only: c_long - use ieee_arithmetic, only: ieee_value, ieee_quiet_nan - use fldebug - use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN, & -& PYTHON_FUNC_LEN, integer_size, real_size - use quadrature - use futils - use elements - use spud - use mpi_interfaces - use parallel_tools - use memory_diagnostics - use integer_hash_table_module - use data_structures - use linked_lists - use halo_data_types - use halos_base - use halos_debug - use halos_allocates - use sparse_tools - use embed_python - use fields_base - use eventcounter - use fetools - use unittest_tools - use halos_communications - use halos_numbering - use halos_ownership - use parallel_fields, only: element_owned - use fields - use profiler - use state_module - use vtk_interfaces - use halos_derivation - use halos_registration - use field_derivatives - use field_options - use fefields - use meshdiagnostics - use sparsity_patterns - use solvers - use write_state_module, only: vtk_write_state_new_options - use surface_integrals - use detector_data_types - use pickers - use mixing_statistics - use detector_tools - use detector_parallel - use h5hut - use particles, only: get_particle_arrays - use state_fields_module - - implicit none - - interface - subroutine register_diagnostics() - end subroutine register_diagnostics - end interface - - private - - public :: initialise_diagnostics, initialise_convergence, & - & initialise_steady_state, field_tag, write_diagnostics, & - & test_and_write_convergence, initialise_detectors, write_detectors, & - & test_and_write_steady_state, steady_state_field, convergence_field, & - & close_diagnostic_files, run_diagnostics, & - & diagnostic_variables_check_options, list_det_into_csr_sparsity, & - & initialise_walltime, & - & uninitialise_diagnostics, register_diagnostic, destroy_registered_diagnostics, set_diagnostic, & - & get_diagnostic, initialise_constant_diagnostics, create_single_detector - - public :: default_stat - public :: stat_type - - interface stat_field - module procedure stat_field_scalar, stat_field_vector, stat_field_tensor - end interface stat_field - - interface convergence_field - module procedure convergence_field_scalar, convergence_field_vector - end interface convergence_field - - interface steady_state_field - module procedure steady_state_field_scalar, steady_state_field_vector - end interface steady_state_field - - interface detector_field - module procedure detector_field_scalar, detector_field_vector - end interface - - ! List of registered diagnostic - type registered_diagnostic_item - integer :: dim - character(len=FIELD_NAME_LEN) :: name - character(len=FIELD_NAME_LEN) :: statistic - character(len=FIELD_NAME_LEN) :: material_phase - logical :: have_material_phase - real, dimension(:), allocatable :: value - type(registered_diagnostic_item), pointer :: next => null() - end type registered_diagnostic_item - - type :: stat_type - ! Idempotency variable - logical :: initialised=.false. - logical :: detectors_initialised = .false. - logical :: convergence_initialised = .false. - logical :: steady_state_initialised = .false. - - !! Output unit for diagnostics file. - !! (assumed non-opened as long these are 0) - integer :: diag_unit=0, conv_unit=0, & + !!< A module to calculate and output diagnostics. This replaces the .s file. + use iso_c_binding, only: c_long + use ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use fldebug + use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN, & + & PYTHON_FUNC_LEN, integer_size, real_size + use quadrature + use futils + use elements + use spud + use mpi_interfaces + use parallel_tools + use memory_diagnostics + use integer_hash_table_module + use data_structures + use linked_lists + use halo_data_types + use halos_base + use halos_debug + use halos_allocates + use sparse_tools + use embed_python + use fields_base + use eventcounter + use fetools + use unittest_tools + use halos_communications + use halos_numbering + use halos_ownership + use parallel_fields, only: element_owned + use fields + use profiler + use state_module + use vtk_interfaces + use halos_derivation + use halos_registration + use field_derivatives + use field_options + use fefields + use meshdiagnostics + use sparsity_patterns + use solvers + use write_state_module, only: vtk_write_state_new_options + use surface_integrals + use detector_data_types + use pickers + use mixing_statistics + use detector_tools + use detector_parallel + use h5hut + use particles, only: get_particle_arrays + use state_fields_module + + implicit none + + interface + subroutine register_diagnostics() + end subroutine register_diagnostics + end interface + + private + + public :: initialise_diagnostics, initialise_convergence, & + & initialise_steady_state, field_tag, write_diagnostics, & + & test_and_write_convergence, initialise_detectors, write_detectors, & + & test_and_write_steady_state, steady_state_field, convergence_field, & + & close_diagnostic_files, run_diagnostics, & + & diagnostic_variables_check_options, list_det_into_csr_sparsity, & + & initialise_walltime, & + & uninitialise_diagnostics, register_diagnostic, destroy_registered_diagnostics, set_diagnostic, & + & get_diagnostic, initialise_constant_diagnostics, create_single_detector + + public :: default_stat + public :: stat_type + + interface stat_field + module procedure stat_field_scalar, stat_field_vector, stat_field_tensor + end interface stat_field + + interface convergence_field + module procedure convergence_field_scalar, convergence_field_vector + end interface convergence_field + + interface steady_state_field + module procedure steady_state_field_scalar, steady_state_field_vector + end interface steady_state_field + + interface detector_field + module procedure detector_field_scalar, detector_field_vector + end interface + + ! List of registered diagnostic + type registered_diagnostic_item + integer :: dim + character(len=FIELD_NAME_LEN) :: name + character(len=FIELD_NAME_LEN) :: statistic + character(len=FIELD_NAME_LEN) :: material_phase + logical :: have_material_phase + real, dimension(:), allocatable :: value + type(registered_diagnostic_item), pointer :: next => null() + end type registered_diagnostic_item + + type :: stat_type + ! Idempotency variable + logical :: initialised=.false. + logical :: detectors_initialised = .false. + logical :: convergence_initialised = .false. + logical :: steady_state_initialised = .false. + + !! Output unit for diagnostics file. + !! (assumed non-opened as long these are 0) + integer :: diag_unit=0, conv_unit=0, & & detector_checkpoint_unit=0, detector_file_unit=0 - !! Are we writing to a convergence file? - logical :: write_convergence_file=.false. + !! Are we writing to a convergence file? + logical :: write_convergence_file=.false. - !! Output unit for .steady_state file (assumed non-opened as long as == 0) - integer :: steady_state_unit = 0 - !! Are we writing to a steady state file? - logical :: write_steady_state_file = .false. - logical :: binary_steady_state_output = .false. + !! Output unit for .steady_state file (assumed non-opened as long as == 0) + integer :: steady_state_unit = 0 + !! Are we writing to a steady state file? + logical :: write_steady_state_file = .false. + logical :: binary_steady_state_output = .false. - !! Are we continuing from a detector checkpoint file? - logical :: from_checkpoint = .false. + !! Are we continuing from a detector checkpoint file? + logical :: from_checkpoint = .false. - !The following variable will switch to true if call to zoltan_drive for the re-load balance occur. - logical :: zoltan_drive_call = .false. + !The following variable will switch to true if call to zoltan_drive for the re-load balance occur. + logical :: zoltan_drive_call = .false. - character(len = FIELD_NAME_LEN), dimension(:), allocatable :: mesh_list - !! List of scalar fields to output. This is stored to ensure that - !! additional fields inserted into state during running do not bugger up - !! the output. - type(stringlist), dimension(:), allocatable :: sfield_list - type(stringlist), dimension(:), allocatable :: vfield_list - type(stringlist), dimension(:), allocatable :: tfield_list + character(len = FIELD_NAME_LEN), dimension(:), allocatable :: mesh_list + !! List of scalar fields to output. This is stored to ensure that + !! additional fields inserted into state during running do not bugger up + !! the output. + type(stringlist), dimension(:), allocatable :: sfield_list + type(stringlist), dimension(:), allocatable :: vfield_list + type(stringlist), dimension(:), allocatable :: tfield_list - ! Names of detector groups used for checkpointing; names are held in read order - character(len = FIELD_NAME_LEN), dimension(:), allocatable :: detector_group_names - integer, dimension(:), allocatable :: number_det_in_each_group + ! Names of detector groups used for checkpointing; names are held in read order + character(len = FIELD_NAME_LEN), dimension(:), allocatable :: detector_group_names + integer, dimension(:), allocatable :: number_det_in_each_group - type(detector_linked_list) :: detector_list + type(detector_linked_list) :: detector_list - type(registered_diagnostic_item), pointer :: registered_diagnostic_first => NULL() + type(registered_diagnostic_item), pointer :: registered_diagnostic_first => NULL() - !! Recording wall time since the system start - integer :: current_count, count_rate, count_max - integer(kind = c_long) :: elapsed_count - end type stat_type + !! Recording wall time since the system start + integer :: current_count, count_rate, count_max + integer(kind = c_long) :: elapsed_count + end type stat_type - type(stat_type), save, target :: default_stat + type(stat_type), save, target :: default_stat contains - function stat_mesh(mesh) - !!< Return whether the supplied mesh should be included in the .stat file - - type(mesh_type), intent(in) :: mesh - - logical :: stat_mesh - integer :: stat - character(len = OPTION_PATH_LEN) :: stat_test_path - - stat_mesh = .false. - stat_test_path=trim(complete_mesh_path(mesh%option_path,stat)) - if(stat==0) then - stat_mesh = have_option(trim(stat_test_path) // "/stat/include_in_stat") & - &.and..not.have_option(trim(stat_test_path) // "/stat/exclude_from_stat") - end if - - end function stat_mesh - - function stat_field_scalar(sfield, state) - !!< Return whether the supplied field should be included in the .stat file - - type(scalar_field), target, intent(in) :: sfield - type(state_type), intent(in) :: state - - logical :: stat_field_scalar - - character(len = OPTION_PATH_LEN) :: stat_test_path - logical :: include_test - type(scalar_field), pointer :: parent_sfield - - if(sfield%name(:3) == "Old") then - parent_sfield => extract_scalar_field(state, trim(sfield%name(4:))) - stat_test_path = "/include_previous_time_step" - include_test = .true. - else if(sfield%name(:9) == "Nonlinear") then - parent_sfield => extract_scalar_field(state, trim(sfield%name(10:))) - stat_test_path = "/include_nonlinear_field" - include_test = .true. - else if(sfield%name(:8) == "Iterated") then - parent_sfield => extract_scalar_field(state, trim(sfield%name(9:))) - stat_test_path = "/include_nonlinear_field" - include_test = .true. - else - parent_sfield => sfield - stat_test_path = "/exclude_from_stat" - include_test = .false. - end if - - if((len_trim(parent_sfield%option_path) == 0).or.aliased(parent_sfield)) then - stat_field_scalar = .false. - return - end if - - if(.not. have_option(trim(complete_field_path(parent_sfield%option_path)) // "/stat")) then - stat_field_scalar = .false. - else - stat_field_scalar = have_option(trim(complete_field_path(parent_sfield%option_path)) // "/stat" // trim(stat_test_path)) - if(.not. include_test) then - stat_field_scalar = (.not. stat_field_scalar) + function stat_mesh(mesh) + !!< Return whether the supplied mesh should be included in the .stat file + + type(mesh_type), intent(in) :: mesh + + logical :: stat_mesh + integer :: stat + character(len = OPTION_PATH_LEN) :: stat_test_path + + stat_mesh = .false. + stat_test_path=trim(complete_mesh_path(mesh%option_path,stat)) + if(stat==0) then + stat_mesh = have_option(trim(stat_test_path) // "/stat/include_in_stat") & + &.and..not.have_option(trim(stat_test_path) // "/stat/exclude_from_stat") end if - end if - - end function stat_field_scalar - - function stat_field_vector(vfield, state, test_for_components) - !!< Return whether the supplied field should be included in the .stat file. - - type(vector_field), target, intent(in) :: vfield - type(state_type), intent(in) :: state - logical, optional, intent(in) :: test_for_components - - logical :: stat_field_vector - - character(len = OPTION_PATH_LEN) :: stat_test_path - type(vector_field), pointer :: parent_vfield => null() - - if(vfield%name(:3) == "Old") then - parent_vfield => extract_vector_field(state, trim(vfield%name(4:))) - stat_test_path = "/stat/previous_time_step" - else if(vfield%name(:9) == "Nonlinear") then - parent_vfield => extract_vector_field(state, trim(vfield%name(10:))) - stat_test_path = "/stat/nonlinear_field" - else if(vfield%name(:8) == "Iterated") then - parent_vfield => extract_vector_field(state, trim(vfield%name(9:))) - stat_test_path = "/stat/nonlinear_field" - else - parent_vfield => vfield - stat_test_path = "/stat" - end if - - if((len_trim(parent_vfield%option_path) == 0).or.aliased(parent_vfield)) then - stat_field_vector = .false. - else if(.not. have_option(trim(complete_field_path(parent_vfield%option_path)) // trim(stat_test_path))) then - stat_field_vector = .false. - else if(present_and_true(test_for_components)) then - stat_field_vector = (.not. have_option(trim(complete_field_path(parent_vfield%option_path)) & - & // trim(stat_test_path) // "/exclude_components_from_stat") & - & .and. .not. have_option(trim(complete_field_path(parent_vfield%option_path)) & - & // trim(stat_test_path) // "/exclude_from_stat")) - else - stat_field_vector = (.not. have_option(trim(complete_field_path(parent_vfield%option_path)) & - & // trim(stat_test_path) // "/exclude_from_stat")) - end if - - end function stat_field_vector - - function stat_field_tensor(tfield, state, test_for_components) - !!< Return whether the supplied field should be included in the .stat file. - - type(tensor_field), target, intent(in) :: tfield - type(state_type), intent(in) :: state - logical, optional, intent(in) :: test_for_components - - logical :: stat_field_tensor - - character(len = OPTION_PATH_LEN) :: stat_test_path - type(tensor_field), pointer :: parent_tfield => null() - - if(tfield%name(:3) == "Old") then - parent_tfield => extract_tensor_field(state, trim(tfield%name(4:))) - stat_test_path = "/stat/previous_time_step" - else if(tfield%name(:9) == "Nonlinear") then - parent_tfield => extract_tensor_field(state, trim(tfield%name(10:))) - stat_test_path = "/stat/nonlinear_field" - else if(tfield%name(:8) == "Iterated") then - parent_tfield => extract_tensor_field(state, trim(tfield%name(9:))) - stat_test_path = "/stat/nonlinear_field" - else - parent_tfield => tfield - stat_test_path = "/stat" - end if - - if((len_trim(parent_tfield%option_path) == 0).or.aliased(parent_tfield)) then - stat_field_tensor = .false. - else if(.not. have_option(trim(complete_field_path(parent_tfield%option_path)) // trim(stat_test_path))) then - stat_field_tensor = .false. - else if(present_and_true(test_for_components)) then - stat_field_tensor = (.not. have_option(trim(complete_field_path(parent_tfield%option_path)) & - & // trim(stat_test_path) // "/exclude_components_from_stat") & - & .and. .not. have_option(trim(complete_field_path(parent_tfield%option_path)) & - & // trim(stat_test_path) // "/exclude_from_stat")) - else - stat_field_tensor = (.not. have_option(trim(complete_field_path(parent_tfield%option_path)) & - & // trim(stat_test_path) // "/exclude_from_stat")) - end if - - end function stat_field_tensor - - function convergence_field_scalar(sfield) - !!< Return whether the supplied field should be included in the .convergence file - - type(scalar_field), target, intent(in) :: sfield - - logical :: convergence_field_scalar - - if(len_trim(sfield%option_path) == 0) then - convergence_field_scalar = .false. - return - end if - - if (aliased(sfield)) then - convergence_field_scalar=.false. - return - end if - - convergence_field_scalar=have_option(trim(complete_field_path(sfield%option_path)) // & - "/convergence/include_in_convergence") - - end function convergence_field_scalar - - function convergence_field_vector(vfield, test_for_components) - !!< Return whether the supplied field should be included in the .convergence file. - - type(vector_field), target, intent(in) :: vfield - logical, optional, intent(in) :: test_for_components - - logical :: convergence_field_vector - - if(len_trim(vfield%option_path) == 0) then - convergence_field_vector = .false. - return - end if - - if (aliased(vfield)) then - convergence_field_vector=.false. - return - end if - - if(present_and_true(test_for_components)) then - convergence_field_vector = have_option(trim(complete_field_path(vfield%option_path)) // & - "/convergence/include_in_convergence") - else - convergence_field_vector=(have_option(trim(complete_field_path(vfield%option_path)) // & - "/convergence/include_in_convergence").or.& - have_option(trim(complete_field_path(vfield%option_path)) // & - "/convergence/exclude_components_from_convergence")) - end if - - end function convergence_field_vector - - function steady_state_field_scalar(sfield) - !!< Return whether the supplied field should be checked for a steady state - - type(scalar_field), target, intent(in) :: sfield - - logical :: steady_state_field_scalar - - if(len_trim(sfield%option_path) == 0) then - steady_state_field_scalar = .false. - return - end if - - if (aliased(sfield)) then - steady_state_field_scalar=.false. - return - end if - - steady_state_field_scalar=have_option(trim(complete_field_path(sfield%option_path)) // & - "/steady_state/include_in_steady_state") - - end function steady_state_field_scalar - - function steady_state_field_vector(vfield, test_for_components) - !!< Return whether the supplied field should be checked for a steady state - - type(vector_field), target, intent(in) :: vfield - logical, optional, intent(in) :: test_for_components - - logical :: steady_state_field_vector - - if(len_trim(vfield%option_path) == 0) then - steady_state_field_vector = .false. - return - end if - if (aliased(vfield)) then - steady_state_field_vector=.false. - return - end if + end function stat_mesh - if(present_and_true(test_for_components)) then - steady_state_field_vector = have_option(trim(complete_field_path(vfield%option_path)) // & - "/steady_state/include_in_steady_state") - else - steady_state_field_vector=(have_option(trim(complete_field_path(vfield%option_path)) // & - "/steady_state/include_in_steady_state").or.& - have_option(trim(complete_field_path(vfield%option_path)) // & - "/steady_state/exclude_components_from_steady_state")) - end if + function stat_field_scalar(sfield, state) + !!< Return whether the supplied field should be included in the .stat file - end function steady_state_field_vector + type(scalar_field), target, intent(in) :: sfield + type(state_type), intent(in) :: state - function detector_field_scalar(sfield) - !!< Return whether the supplied field should be included in the .detector file - logical :: detector_field_scalar - type(scalar_field), target, intent(in) :: sfield + logical :: stat_field_scalar + + character(len = OPTION_PATH_LEN) :: stat_test_path + logical :: include_test + type(scalar_field), pointer :: parent_sfield + + if(sfield%name(:3) == "Old") then + parent_sfield => extract_scalar_field(state, trim(sfield%name(4:))) + stat_test_path = "/include_previous_time_step" + include_test = .true. + else if(sfield%name(:9) == "Nonlinear") then + parent_sfield => extract_scalar_field(state, trim(sfield%name(10:))) + stat_test_path = "/include_nonlinear_field" + include_test = .true. + else if(sfield%name(:8) == "Iterated") then + parent_sfield => extract_scalar_field(state, trim(sfield%name(9:))) + stat_test_path = "/include_nonlinear_field" + include_test = .true. + else + parent_sfield => sfield + stat_test_path = "/exclude_from_stat" + include_test = .false. + end if - if (sfield%option_path=="".or.aliased(sfield)) then - detector_field_scalar=.false. - else - detector_field_scalar = have_option(& - trim(complete_field_path(sfield%option_path)) // & - "/detectors/include_in_detectors") - end if + if((len_trim(parent_sfield%option_path) == 0).or.aliased(parent_sfield)) then + stat_field_scalar = .false. + return + end if - end function detector_field_scalar + if(.not. have_option(trim(complete_field_path(parent_sfield%option_path)) // "/stat")) then + stat_field_scalar = .false. + else + stat_field_scalar = have_option(trim(complete_field_path(parent_sfield%option_path)) // "/stat" // trim(stat_test_path)) + if(.not. include_test) then + stat_field_scalar = (.not. stat_field_scalar) + end if + end if - function detector_field_vector(vfield) - !!< Return whether the supplied field should be included in the .detector file - logical :: detector_field_vector - type(vector_field), target, intent(in) :: vfield + end function stat_field_scalar - if (vfield%option_path=="".or.aliased(vfield)) then - detector_field_vector=.false. - else - detector_field_vector = have_option(& - trim(complete_field_path(vfield%option_path)) // & - "/detectors/include_in_detectors") - end if + function stat_field_vector(vfield, state, test_for_components) + !!< Return whether the supplied field should be included in the .stat file. - end function detector_field_vector + type(vector_field), target, intent(in) :: vfield + type(state_type), intent(in) :: state + logical, optional, intent(in) :: test_for_components + + logical :: stat_field_vector + + character(len = OPTION_PATH_LEN) :: stat_test_path + type(vector_field), pointer :: parent_vfield => null() + + if(vfield%name(:3) == "Old") then + parent_vfield => extract_vector_field(state, trim(vfield%name(4:))) + stat_test_path = "/stat/previous_time_step" + else if(vfield%name(:9) == "Nonlinear") then + parent_vfield => extract_vector_field(state, trim(vfield%name(10:))) + stat_test_path = "/stat/nonlinear_field" + else if(vfield%name(:8) == "Iterated") then + parent_vfield => extract_vector_field(state, trim(vfield%name(9:))) + stat_test_path = "/stat/nonlinear_field" + else + parent_vfield => vfield + stat_test_path = "/stat" + end if - subroutine initialise_walltime - !!< Record the initial walltime, clock_rate and maximum clock count + if((len_trim(parent_vfield%option_path) == 0).or.aliased(parent_vfield)) then + stat_field_vector = .false. + else if(.not. have_option(trim(complete_field_path(parent_vfield%option_path)) // trim(stat_test_path))) then + stat_field_vector = .false. + else if(present_and_true(test_for_components)) then + stat_field_vector = (.not. have_option(trim(complete_field_path(parent_vfield%option_path)) & + & // trim(stat_test_path) // "/exclude_components_from_stat") & + & .and. .not. have_option(trim(complete_field_path(parent_vfield%option_path)) & + & // trim(stat_test_path) // "/exclude_from_stat")) + else + stat_field_vector = (.not. have_option(trim(complete_field_path(parent_vfield%option_path)) & + & // trim(stat_test_path) // "/exclude_from_stat")) + end if - call system_clock(default_stat%current_count, default_stat%count_rate, default_stat%count_max) - default_stat%elapsed_count=0 + end function stat_field_vector - end subroutine initialise_walltime + function stat_field_tensor(tfield, state, test_for_components) + !!< Return whether the supplied field should be included in the .stat file. - function elapsed_walltime() - !!< Return the number of walltime seconds since the beginning of the - !!< simulation. - real :: elapsed_walltime + type(tensor_field), target, intent(in) :: tfield + type(state_type), intent(in) :: state + logical, optional, intent(in) :: test_for_components + + logical :: stat_field_tensor + + character(len = OPTION_PATH_LEN) :: stat_test_path + type(tensor_field), pointer :: parent_tfield => null() + + if(tfield%name(:3) == "Old") then + parent_tfield => extract_tensor_field(state, trim(tfield%name(4:))) + stat_test_path = "/stat/previous_time_step" + else if(tfield%name(:9) == "Nonlinear") then + parent_tfield => extract_tensor_field(state, trim(tfield%name(10:))) + stat_test_path = "/stat/nonlinear_field" + else if(tfield%name(:8) == "Iterated") then + parent_tfield => extract_tensor_field(state, trim(tfield%name(9:))) + stat_test_path = "/stat/nonlinear_field" + else + parent_tfield => tfield + stat_test_path = "/stat" + end if - integer :: new_count + if((len_trim(parent_tfield%option_path) == 0).or.aliased(parent_tfield)) then + stat_field_tensor = .false. + else if(.not. have_option(trim(complete_field_path(parent_tfield%option_path)) // trim(stat_test_path))) then + stat_field_tensor = .false. + else if(present_and_true(test_for_components)) then + stat_field_tensor = (.not. have_option(trim(complete_field_path(parent_tfield%option_path)) & + & // trim(stat_test_path) // "/exclude_components_from_stat") & + & .and. .not. have_option(trim(complete_field_path(parent_tfield%option_path)) & + & // trim(stat_test_path) // "/exclude_from_stat")) + else + stat_field_tensor = (.not. have_option(trim(complete_field_path(parent_tfield%option_path)) & + & // trim(stat_test_path) // "/exclude_from_stat")) + end if - call system_clock(new_count) + end function stat_field_tensor - ! Deal with clock rollover. If one timestep takes more than a whole - ! clock rollover, we have more problems than we can deal with! - if (new_count NULL() + convergence_field_scalar=have_option(trim(complete_field_path(sfield%option_path)) // & + "/convergence/include_in_convergence") - ewrite(1, *) "In initialise_diagnostics" + end function convergence_field_scalar - ! Idempotency check - if(default_stat%initialised) then - ewrite(2, *) "Diagnostics already initialised" - ewrite(1, *) "Exiting initialise_diagnostics" - return - end if - default_stat%initialised=.true. - - ! All processes must assemble the mesh and field lists - - ! Mesh field list - ! first we count how many are included - j = 0 - do i=1, mesh_count(state(1)) - mesh => extract_mesh(state(1), i) - if (stat_mesh(mesh)) j = j + 1 - end do - allocate(default_stat%mesh_list(j)) - ! then copy the names of the ones that are - j = 0 - do i=1, mesh_count(state(1)) - mesh => extract_mesh(state(1), i) - if (stat_mesh(mesh)) then - j = j + 1 - default_stat%mesh_list(j) = mesh%name + function convergence_field_vector(vfield, test_for_components) + !!< Return whether the supplied field should be included in the .convergence file. + + type(vector_field), target, intent(in) :: vfield + logical, optional, intent(in) :: test_for_components + + logical :: convergence_field_vector + + if(len_trim(vfield%option_path) == 0) then + convergence_field_vector = .false. + return end if - end do - - ! NOTE that mesh_list only contains the included meshes - ! whereas mesh_sfield_list, etc. contains all current fields and inclusion - ! is checked on every write - ! this is to deal with the fact that in the case of extrude_adapt the horizontal - ! mesh may disappear, we then need to remember what columns are associated with - ! meshes without knowing the options under the disappeared meshes - - ! Scalar field list - allocate (default_stat%sfield_list(size(state))) - do phase=1, size(state) - if (associated(state(phase)%scalar_names)) then - allocate(default_stat%sfield_list(phase)%ptr(size(state(phase)%scalar_names))) - default_stat%sfield_list(phase)%ptr=state(phase)%scalar_names - else - allocate(default_stat%sfield_list(phase)%ptr(0)) + + if (aliased(vfield)) then + convergence_field_vector=.false. + return end if - end do - ! Vector field list - allocate (default_stat%vfield_list(size(state))) - do phase = 1, size(state) - if (associated(state(phase)%vector_names)) then - allocate(default_stat%vfield_list(phase)%ptr(size(state(phase)%vector_names))) - default_stat%vfield_list(phase)%ptr = state(phase)%vector_names - else - allocate(default_stat%vfield_list(phase)%ptr(0)) + + if(present_and_true(test_for_components)) then + convergence_field_vector = have_option(trim(complete_field_path(vfield%option_path)) // & + "/convergence/include_in_convergence") + else + convergence_field_vector=(have_option(trim(complete_field_path(vfield%option_path)) // & + "/convergence/include_in_convergence").or.& + have_option(trim(complete_field_path(vfield%option_path)) // & + "/convergence/exclude_components_from_convergence")) end if - end do - ! Tensor field list - allocate (default_stat%tfield_list(size(state))) - do phase = 1, size(state) - if (associated(state(phase)%tensor_names)) then - allocate(default_stat%tfield_list(phase)%ptr(size(state(phase)%tensor_names))) - default_stat%tfield_list(phase)%ptr = state(phase)%tensor_names - else - allocate(default_stat%tfield_list(phase)%ptr(0)) + + end function convergence_field_vector + + function steady_state_field_scalar(sfield) + !!< Return whether the supplied field should be checked for a steady state + + type(scalar_field), target, intent(in) :: sfield + + logical :: steady_state_field_scalar + + if(len_trim(sfield%option_path) == 0) then + steady_state_field_scalar = .false. + return end if - end do - ! Only the first process should write statistics information (and hence - ! write the headers) - if(getprocno() == 1) then - default_stat%diag_unit=free_unit() - open(unit=default_stat%diag_unit, file=trim(filename)//'.stat', action="write") + if (aliased(sfield)) then + steady_state_field_scalar=.false. + return + end if - write(default_stat%diag_unit, '(a)') "
" + steady_state_field_scalar=have_option(trim(complete_field_path(sfield%option_path)) // & + "/steady_state/include_in_steady_state") - call initialise_constant_diagnostics(default_stat%diag_unit) + end function steady_state_field_scalar - column=0 + function steady_state_field_vector(vfield, test_for_components) + !!< Return whether the supplied field should be checked for a steady state - ! Initial columns are elapsed time and dt. - column=column+1 - buffer=field_tag(name="ElapsedTime", column=column, statistic="value") - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="dt", column=column, statistic="value") - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="ElapsedWallTime", column=column, statistic="value") - write(default_stat%diag_unit, '(a)') trim(buffer) + type(vector_field), target, intent(in) :: vfield + logical, optional, intent(in) :: test_for_components - do i = 1, size(default_stat%mesh_list) - ! Headers for output statistics for each mesh - mesh => extract_mesh(state(1), default_stat%mesh_list(i)) - - column = column + 1 - buffer = field_tag(name = mesh%name, column = column, statistic = "nodes") - write(default_stat%diag_unit, "(a)") trim(buffer) - column = column + 1 - buffer = field_tag(name = mesh%name, column = column, statistic = "elements") - write(default_stat%diag_unit, "(a)") trim(buffer) - column = column + 1 - buffer = field_tag(name = mesh%name, column = column, statistic = "surface_elements") - write(default_stat%diag_unit, "(a)") trim(buffer) + logical :: steady_state_field_vector + + if(len_trim(vfield%option_path) == 0) then + steady_state_field_vector = .false. + return + end if + + if (aliased(vfield)) then + steady_state_field_vector=.false. + return + end if + + if(present_and_true(test_for_components)) then + steady_state_field_vector = have_option(trim(complete_field_path(vfield%option_path)) // & + "/steady_state/include_in_steady_state") + else + steady_state_field_vector=(have_option(trim(complete_field_path(vfield%option_path)) // & + "/steady_state/include_in_steady_state").or.& + have_option(trim(complete_field_path(vfield%option_path)) // & + "/steady_state/exclude_components_from_steady_state")) + end if + + end function steady_state_field_vector + + function detector_field_scalar(sfield) + !!< Return whether the supplied field should be included in the .detector file + logical :: detector_field_scalar + type(scalar_field), target, intent(in) :: sfield + + if (sfield%option_path=="".or.aliased(sfield)) then + detector_field_scalar=.false. + else + detector_field_scalar = have_option(& + trim(complete_field_path(sfield%option_path)) // & + "/detectors/include_in_detectors") + end if + + end function detector_field_scalar + + function detector_field_vector(vfield) + !!< Return whether the supplied field should be included in the .detector file + logical :: detector_field_vector + type(vector_field), target, intent(in) :: vfield + + if (vfield%option_path=="".or.aliased(vfield)) then + detector_field_vector=.false. + else + detector_field_vector = have_option(& + trim(complete_field_path(vfield%option_path)) // & + "/detectors/include_in_detectors") + end if + + end function detector_field_vector + + subroutine initialise_walltime + !!< Record the initial walltime, clock_rate and maximum clock count + + call system_clock(default_stat%current_count, default_stat%count_rate, default_stat%count_max) + default_stat%elapsed_count=0 + + end subroutine initialise_walltime + + function elapsed_walltime() + !!< Return the number of walltime seconds since the beginning of the + !!< simulation. + real :: elapsed_walltime + + integer :: new_count + + call system_clock(new_count) + + ! Deal with clock rollover. If one timestep takes more than a whole + ! clock rollover, we have more problems than we can deal with! + if (new_count NULL() + + ewrite(1, *) "In initialise_diagnostics" + + ! Idempotency check + if(default_stat%initialised) then + ewrite(2, *) "Diagnostics already initialised" + ewrite(1, *) "Exiting initialise_diagnostics" + return + end if + default_stat%initialised=.true. + + ! All processes must assemble the mesh and field lists + + ! Mesh field list + ! first we count how many are included + j = 0 + do i=1, mesh_count(state(1)) + mesh => extract_mesh(state(1), i) + if (stat_mesh(mesh)) j = j + 1 + end do + allocate(default_stat%mesh_list(j)) + ! then copy the names of the ones that are + j = 0 + do i=1, mesh_count(state(1)) + mesh => extract_mesh(state(1), i) + if (stat_mesh(mesh)) then + j = j + 1 + default_stat%mesh_list(j) = mesh%name + end if end do -#ifdef HAVE_MEMORY_STATS - ! Memory statistics - do i=0, MEMORY_TYPES - column = column + 1 - buffer = field_tag(name = memory_type_names(i), column = column,& - & statistic = "current", material_phase_name="Memory") - write(default_stat%diag_unit, "(a)") trim(buffer) - column = column + 1 - buffer = field_tag(name = memory_type_names(i), column = column,& - & statistic = "min", material_phase_name="Memory") - write(default_stat%diag_unit, "(a)") trim(buffer) - column = column + 1 - buffer = field_tag(name = memory_type_names(i), column = column,& - & statistic = "max", material_phase_name="Memory") - write(default_stat%diag_unit, "(a)") trim(buffer) + ! NOTE that mesh_list only contains the included meshes + ! whereas mesh_sfield_list, etc. contains all current fields and inclusion + ! is checked on every write + ! this is to deal with the fact that in the case of extrude_adapt the horizontal + ! mesh may disappear, we then need to remember what columns are associated with + ! meshes without knowing the options under the disappeared meshes + + ! Scalar field list + allocate (default_stat%sfield_list(size(state))) + do phase=1, size(state) + if (associated(state(phase)%scalar_names)) then + allocate(default_stat%sfield_list(phase)%ptr(size(state(phase)%scalar_names))) + default_stat%sfield_list(phase)%ptr=state(phase)%scalar_names + else + allocate(default_stat%sfield_list(phase)%ptr(0)) + end if + end do + ! Vector field list + allocate (default_stat%vfield_list(size(state))) + do phase = 1, size(state) + if (associated(state(phase)%vector_names)) then + allocate(default_stat%vfield_list(phase)%ptr(size(state(phase)%vector_names))) + default_stat%vfield_list(phase)%ptr = state(phase)%vector_names + else + allocate(default_stat%vfield_list(phase)%ptr(0)) + end if + end do + ! Tensor field list + allocate (default_stat%tfield_list(size(state))) + do phase = 1, size(state) + if (associated(state(phase)%tensor_names)) then + allocate(default_stat%tfield_list(phase)%ptr(size(state(phase)%tensor_names))) + default_stat%tfield_list(phase)%ptr = state(phase)%tensor_names + else + allocate(default_stat%tfield_list(phase)%ptr(0)) + end if end do -#endif - phaseloop: do phase=1,size(state) + ! Only the first process should write statistics information (and hence + ! write the headers) + if(getprocno() == 1) then + default_stat%diag_unit=free_unit() + open(unit=default_stat%diag_unit, file=trim(filename)//'.stat', action="write") - material_phase_name=trim(state(phase)%name) + write(default_stat%diag_unit, '(a)') "
" - do i=1, size(default_stat%sfield_list(phase)%ptr) - ! Headers for output statistics for each scalar field - sfield => extract_scalar_field(state(phase), default_stat%sfield_list(phase)%ptr(i)) + call initialise_constant_diagnostics(default_stat%diag_unit) - ! Standard scalar field stats - if(stat_field(sfield, state(phase))) then - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="min", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="max", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="l2norm", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="integral", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end if + column=0 - ! Control volume stats - if(have_option(trim(complete_field_path(sfield%option_path, stat=stat)) // "/stat/include_cv_stats")) then - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="cv_l2norm", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="cv_integral", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end if + ! Initial columns are elapsed time and dt. + column=column+1 + buffer=field_tag(name="ElapsedTime", column=column, statistic="value") + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="dt", column=column, statistic="value") + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="ElapsedWallTime", column=column, statistic="value") + write(default_stat%diag_unit, '(a)') trim(buffer) - ! Mixing stats - do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat=stat)) // "/stat/include_mixing_stats") - 1 - call get_option(trim(complete_field_path(sfield%option_path)) & - & // "/stat/include_mixing_stats["// int2str(j) // "]/name", mixing_stats_name) - shape_option=option_shape(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds") + do i = 1, size(default_stat%mesh_list) + ! Headers for output statistics for each mesh + mesh => extract_mesh(state(1), default_stat%mesh_list(i)) - if(have_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant")) then + column = column + 1 + buffer = field_tag(name = mesh%name, column = column, statistic = "nodes") + write(default_stat%diag_unit, "(a)") trim(buffer) + column = column + 1 + buffer = field_tag(name = mesh%name, column = column, statistic = "elements") + write(default_stat%diag_unit, "(a)") trim(buffer) + column = column + 1 + buffer = field_tag(name = mesh%name, column = column, statistic = "surface_elements") + write(default_stat%diag_unit, "(a)") trim(buffer) + end do + +#ifdef HAVE_MEMORY_STATS + ! Memory statistics + do i=0, MEMORY_TYPES + column = column + 1 + buffer = field_tag(name = memory_type_names(i), column = column,& + & statistic = "current", material_phase_name="Memory") + write(default_stat%diag_unit, "(a)") trim(buffer) + column = column + 1 + buffer = field_tag(name = memory_type_names(i), column = column,& + & statistic = "min", material_phase_name="Memory") + write(default_stat%diag_unit, "(a)") trim(buffer) + column = column + 1 + buffer = field_tag(name = memory_type_names(i), column = column,& + & statistic = "max", material_phase_name="Memory") + write(default_stat%diag_unit, "(a)") trim(buffer) + end do +#endif + + phaseloop: do phase=1,size(state) + + material_phase_name=trim(state(phase)%name) + + do i=1, size(default_stat%sfield_list(phase)%ptr) + ! Headers for output statistics for each scalar field + sfield => extract_scalar_field(state(phase), default_stat%sfield_list(phase)%ptr(i)) + + ! Standard scalar field stats + if(stat_field(sfield, state(phase))) then + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="min", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="max", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="l2norm", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="integral", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end if + + ! Control volume stats + if(have_option(trim(complete_field_path(sfield%option_path, stat=stat)) // "/stat/include_cv_stats")) then + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="cv_l2norm", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="cv_integral", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end if + + ! Mixing stats + do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat=stat)) // "/stat/include_mixing_stats") - 1 + call get_option(trim(complete_field_path(sfield%option_path)) & + & // "/stat/include_mixing_stats["// int2str(j) // "]/name", mixing_stats_name) shape_option=option_shape(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant") - no_mixing_bins = shape_option(1) - else if(have_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds") + + if(have_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant")) then + shape_option=option_shape(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant") + no_mixing_bins = shape_option(1) + else if(have_option(trim(complete_field_path(sfield%option_path)) // & & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python")) then - call get_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python", func) - call get_option("/timestepping/current_time", current_time) - call real_vector_from_python(func, current_time, mixing_bin_bounds) - no_mixing_bins = size(mixing_bin_bounds) - deallocate(mixing_bin_bounds) - else - FLExit("Unable to determine mixing bin bounds type. Check options under include_mixing_stats") - end if + call get_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python", func) + call get_option("/timestepping/current_time", current_time) + call real_vector_from_python(func, current_time, mixing_bin_bounds) + no_mixing_bins = size(mixing_bin_bounds) + deallocate(mixing_bin_bounds) + else + FLExit("Unable to determine mixing bin bounds type. Check options under include_mixing_stats") + end if + + buffer = field_tag(name=sfield%name, column=column+1, statistic="mixing_bins%" // trim(mixing_stats_name),& + & material_phase_name=material_phase_name, components=(no_mixing_bins)) + + write(default_stat%diag_unit, '(a)') trim(buffer) + column = column + (no_mixing_bins) - buffer = field_tag(name=sfield%name, column=column+1, statistic="mixing_bins%" // trim(mixing_stats_name),& - & material_phase_name=material_phase_name, components=(no_mixing_bins)) + end do - write(default_stat%diag_unit, '(a)') trim(buffer) - column = column + (no_mixing_bins) + ! Surface integrals + do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_integral") - 1 + call get_option(trim(complete_field_path(sfield%option_path)) & + // "/stat/surface_integral[" // int2str(j) // "]/name", surface_integral_name) + column = column + 1 + buffer = field_tag(sfield%name, column, "surface_integral%" // trim(surface_integral_name), material_phase_name) + write(default_stat%diag_unit, "(a)") trim(buffer) + end do - end do + ! Surface l2norms + do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_l2norm") - 1 + call get_option(trim(complete_field_path(sfield%option_path)) & + // "/stat/surface_l2norm[" // int2str(j) // "]/name", surface_integral_name) + column = column + 1 + buffer = field_tag(sfield%name, column, "surface_l2norm%" // trim(surface_integral_name), material_phase_name) + write(default_stat%diag_unit, "(a)") trim(buffer) + end do - ! Surface integrals - do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_integral") - 1 - call get_option(trim(complete_field_path(sfield%option_path)) & - // "/stat/surface_integral[" // int2str(j) // "]/name", surface_integral_name) - column = column + 1 - buffer = field_tag(sfield%name, column, "surface_integral%" // trim(surface_integral_name), material_phase_name) - write(default_stat%diag_unit, "(a)") trim(buffer) - end do + end do - ! Surface l2norms - do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_l2norm") - 1 - call get_option(trim(complete_field_path(sfield%option_path)) & - // "/stat/surface_l2norm[" // int2str(j) // "]/name", surface_integral_name) - column = column + 1 - buffer = field_tag(sfield%name, column, "surface_l2norm%" // trim(surface_integral_name), material_phase_name) - write(default_stat%diag_unit, "(a)") trim(buffer) - end do + do i = 1, size(default_stat%vfield_list(phase)%ptr) + ! Headers for output statistics for each vector field + vfield => extract_vector_field(state(phase), & + & default_stat%vfield_list(phase)%ptr(i)) + + ! Standard scalar field stats for vector field magnitude + if(stat_field(vfield, state(phase))) then + column = column + 1 + buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & + & statistic="min", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & + & statistic="max",material_phase_name= material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & + & statistic="l2norm", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end if - end do + ! Standard scalar field stats for vector field components + if(stat_field(vfield, state(phase), test_for_components = .true.)) then + do j = 1, vfield%dim + vfield_comp = extract_scalar_field(vfield, j) + + column = column + 1 + buffer=field_tag(name=vfield_comp%name, column=column, statistic="min", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer=field_tag(name=vfield_comp%name, column=column, statistic="max", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer=field_tag(name=vfield_comp%name, column=column, statistic="l2norm", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer=field_tag(name=vfield_comp%name, column=column, statistic="integral", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end do + end if - do i = 1, size(default_stat%vfield_list(phase)%ptr) - ! Headers for output statistics for each vector field - vfield => extract_vector_field(state(phase), & - & default_stat%vfield_list(phase)%ptr(i)) - - ! Standard scalar field stats for vector field magnitude - if(stat_field(vfield, state(phase))) then - column = column + 1 - buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & - & statistic="min", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & - & statistic="max",material_phase_name= material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & - & statistic="l2norm", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end if - - ! Standard scalar field stats for vector field components - if(stat_field(vfield, state(phase), test_for_components = .true.)) then - do j = 1, vfield%dim - vfield_comp = extract_scalar_field(vfield, j) + ! Surface integrals + do j = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_integral") - 1 + call get_option(trim(complete_field_path(vfield%option_path)) & + // "/stat/surface_integral[" // int2str(j) // "]/name", surface_integral_name) + column = column + 1 + buffer = field_tag(vfield%name, column, "surface_integral%" // trim(surface_integral_name), material_phase_name) + write(default_stat%diag_unit, "(a)") trim(buffer) + end do - column = column + 1 - buffer=field_tag(name=vfield_comp%name, column=column, statistic="min", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) + ! Surface l2norms + do j = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_l2norm") - 1 + call get_option(trim(complete_field_path(vfield%option_path)) & + // "/stat/surface_l2norm[" // int2str(j) // "]/name", surface_integral_name) + column = column + 1 + buffer = field_tag(vfield%name, column, "surface_l2norm%" // trim(surface_integral_name), material_phase_name) + write(default_stat%diag_unit, "(a)") trim(buffer) + end do - column = column + 1 - buffer=field_tag(name=vfield_comp%name, column=column, statistic="max", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) + ! drag calculation + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces")) then + do s = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/compute_body_forces_on_surfaces") - 1 + call get_option(trim(complete_field_path(vfield%option_path))//"/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/name", surface_integral_name) + do j = 1, mesh_dim(vfield%mesh) + column = column + 1 + buffer = field_tag(name=trim(vfield%name), column=column, statistic="force_"//trim(surface_integral_name)//"%" & + // int2str(j), material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end do + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/output_terms")) then + do j = 1, mesh_dim(vfield%mesh) + column = column + 1 + buffer = field_tag(name=trim(vfield%name), column=column, statistic="pressure_force_"//trim(surface_integral_name)//"%" & + // int2str(j), material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end do + do j = 1, mesh_dim(vfield%mesh) + column = column + 1 + buffer = field_tag(name=trim(vfield%name), column=column, statistic="viscous_force_"//trim(surface_integral_name)//"%" & + // int2str(j), material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end do + end if + end do + end if - column = column + 1 - buffer=field_tag(name=vfield_comp%name, column=column, statistic="l2norm", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/divergence_stats")) then + column=column+1 + buffer=field_tag(name=vfield%name, column=column, statistic="divergence%min", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=vfield%name, column=column, statistic="divergence%max", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=vfield%name, column=column, statistic="divergence%l2norm", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=vfield%name, column=column, statistic="divergence%integral", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end if - column = column + 1 - buffer=field_tag(name=vfield_comp%name, column=column, statistic="integral", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end do - end if - - ! Surface integrals - do j = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_integral") - 1 - call get_option(trim(complete_field_path(vfield%option_path)) & - // "/stat/surface_integral[" // int2str(j) // "]/name", surface_integral_name) - column = column + 1 - buffer = field_tag(vfield%name, column, "surface_integral%" // trim(surface_integral_name), material_phase_name) - write(default_stat%diag_unit, "(a)") trim(buffer) - end do - - ! Surface l2norms - do j = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_l2norm") - 1 - call get_option(trim(complete_field_path(vfield%option_path)) & - // "/stat/surface_l2norm[" // int2str(j) // "]/name", surface_integral_name) - column = column + 1 - buffer = field_tag(vfield%name, column, "surface_l2norm%" // trim(surface_integral_name), material_phase_name) - write(default_stat%diag_unit, "(a)") trim(buffer) - end do - - ! drag calculation - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces")) then - do s = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/compute_body_forces_on_surfaces") - 1 - call get_option(trim(complete_field_path(vfield%option_path))//"/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/name", surface_integral_name) - do j = 1, mesh_dim(vfield%mesh) - column = column + 1 - buffer = field_tag(name=trim(vfield%name), column=column, statistic="force_"//trim(surface_integral_name)//"%" & - // int2str(j), material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end do - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/output_terms")) then - do j = 1, mesh_dim(vfield%mesh) - column = column + 1 - buffer = field_tag(name=trim(vfield%name), column=column, statistic="pressure_force_"//trim(surface_integral_name)//"%" & - // int2str(j), material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end do - do j = 1, mesh_dim(vfield%mesh) - column = column + 1 - buffer = field_tag(name=trim(vfield%name), column=column, statistic="viscous_force_"//trim(surface_integral_name)//"%" & - // int2str(j), material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end do + ! momentum conservation error calculation + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/calculate_momentum_conservation_error")) then + do j = 1, mesh_dim(vfield%mesh) + column = column + 1 + buffer = field_tag(name=trim(vfield%name), column=column, statistic="momentum_conservation%" & + // int2str(j), material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end do end if - end do - end if - - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/divergence_stats")) then - column=column+1 - buffer=field_tag(name=vfield%name, column=column, statistic="divergence%min", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=vfield%name, column=column, statistic="divergence%max", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=vfield%name, column=column, statistic="divergence%l2norm", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name=vfield%name, column=column, statistic="divergence%integral", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end if - - ! momentum conservation error calculation - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/calculate_momentum_conservation_error")) then - do j = 1, mesh_dim(vfield%mesh) - column = column + 1 - buffer = field_tag(name=trim(vfield%name), column=column, statistic="momentum_conservation%" & - // int2str(j), material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end do - end if - end do + end do - do i = 1, size(default_stat%tfield_list(phase)%ptr) - ! Headers for output statistics for each tensor field - tfield => extract_tensor_field(state(phase), & - & default_stat%tfield_list(phase)%ptr(i)) - - ! Standard scalar field stats for tensor field magnitude - if(stat_field(tfield, state(phase))) then - column = column + 1 - buffer = field_tag(name=trim(tfield%name) // "%magnitude", column=column, & - & statistic="min", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer = field_tag(name=trim(tfield%name) // "%magnitude", column=column, & - & statistic="max",material_phase_name= material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer = field_tag(name=trim(tfield%name) // "%magnitude", column=column, & - & statistic="l2norm", material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end if - - ! Standard scalar field stats for tensor field components - if(stat_field(tfield, state(phase), test_for_components = .true.)) then - do j = 1, tfield%dim(1) - do k = 1, tfield%dim(2) - tfield_comp = extract_scalar_field(tfield, j, k) - - column = column + 1 - buffer=field_tag(name=tfield_comp%name, column=column, statistic="min", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer=field_tag(name=tfield_comp%name, column=column, statistic="max", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer=field_tag(name=tfield_comp%name, column=column, statistic="l2norm", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - - column = column + 1 - buffer=field_tag(name=tfield_comp%name, column=column, statistic="integral", & - & material_phase_name=material_phase_name) - write(default_stat%diag_unit, '(a)') trim(buffer) - end do - end do - end if - end do + do i = 1, size(default_stat%tfield_list(phase)%ptr) + ! Headers for output statistics for each tensor field + tfield => extract_tensor_field(state(phase), & + & default_stat%tfield_list(phase)%ptr(i)) + + ! Standard scalar field stats for tensor field magnitude + if(stat_field(tfield, state(phase))) then + column = column + 1 + buffer = field_tag(name=trim(tfield%name) // "%magnitude", column=column, & + & statistic="min", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer = field_tag(name=trim(tfield%name) // "%magnitude", column=column, & + & statistic="max",material_phase_name= material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer = field_tag(name=trim(tfield%name) // "%magnitude", column=column, & + & statistic="l2norm", material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end if - end do phaseloop + ! Standard scalar field stats for tensor field components + if(stat_field(tfield, state(phase), test_for_components = .true.)) then + do j = 1, tfield%dim(1) + do k = 1, tfield%dim(2) + tfield_comp = extract_scalar_field(tfield, j, k) + + column = column + 1 + buffer=field_tag(name=tfield_comp%name, column=column, statistic="min", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer=field_tag(name=tfield_comp%name, column=column, statistic="max", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer=field_tag(name=tfield_comp%name, column=column, statistic="l2norm", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + + column = column + 1 + buffer=field_tag(name=tfield_comp%name, column=column, statistic="integral", & + & material_phase_name=material_phase_name) + write(default_stat%diag_unit, '(a)') trim(buffer) + end do + end do + end if + end do - ! Now add the registered diagnostics - call register_diagnostics - call print_registered_diagnostics + end do phaseloop - iterator => default_stat%registered_diagnostic_first - do while (associated(iterator)) - do i = 1, iterator%dim - column = column + 1 - if (iterator%dim==1) then - prefix="" - else - prefix=int2str(i) - end if - if (iterator%have_material_phase) then - buffer = field_tag(name=trim(iterator%name)//trim(prefix), column=column, & - & statistic=iterator%statistic, material_phase_name=iterator%material_phase) - else - buffer = field_tag(name=trim(iterator%name)//trim(prefix), column=column, & - & statistic=iterator%statistic) - end if - write(default_stat%diag_unit, '(a)') trim(buffer) - end do - iterator => iterator%next - end do + ! Now add the registered diagnostics + call register_diagnostics + call print_registered_diagnostics - !Now particle groups and subgroups - particle_groups = option_count("/particles/particle_group") - if (particle_groups/=0) then - do i = 1,particle_groups - call get_option("/particles/particle_group["//int2str(i-1)//"]/name", group_name) - column = column + 1 - buffer=field_tag(name=trim(group_name), column=column, statistic="total_particles") - write(default_stat%diag_unit, '(a)') trim(buffer) - particle_subgroups = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup") - do j = 1, particle_subgroups - call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(j-1)//"]/name", subgroup_name) + iterator => default_stat%registered_diagnostic_first + do while (associated(iterator)) + do i = 1, iterator%dim column = column + 1 - buffer=field_tag(name=trim(group_name)//"::"//trim(subgroup_name), column=column, statistic="total_particles") + if (iterator%dim==1) then + prefix="" + else + prefix=int2str(i) + end if + if (iterator%have_material_phase) then + buffer = field_tag(name=trim(iterator%name)//trim(prefix), column=column, & + & statistic=iterator%statistic, material_phase_name=iterator%material_phase) + else + buffer = field_tag(name=trim(iterator%name)//trim(prefix), column=column, & + & statistic=iterator%statistic) + end if write(default_stat%diag_unit, '(a)') trim(buffer) end do + iterator => iterator%next end do - end if + !Now particle groups and subgroups + particle_groups = option_count("/particles/particle_group") + if (particle_groups/=0) then + do i = 1,particle_groups + call get_option("/particles/particle_group["//int2str(i-1)//"]/name", group_name) + column = column + 1 + buffer=field_tag(name=trim(group_name), column=column, statistic="total_particles") + write(default_stat%diag_unit, '(a)') trim(buffer) + particle_subgroups = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup") + do j = 1, particle_subgroups + call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(j-1)//"]/name", subgroup_name) + column = column + 1 + buffer=field_tag(name=trim(group_name)//"::"//trim(subgroup_name), column=column, statistic="total_particles") + write(default_stat%diag_unit, '(a)') trim(buffer) + end do + end do + end if - write(default_stat%diag_unit, '(a)') "
" - flush(default_stat%diag_unit) - end if - call initialise_detectors(filename, state) + write(default_stat%diag_unit, '(a)') "
" + flush(default_stat%diag_unit) + end if - ewrite(1, *) "Exiting initialise_diagnostics" + call initialise_detectors(filename, state) - end subroutine initialise_diagnostics + ewrite(1, *) "Exiting initialise_diagnostics" + end subroutine initialise_diagnostics - subroutine set_diagnostic(name, statistic, material_phase, value) - character(len=*), intent(in) :: name, statistic - character(len=*), intent(in), optional :: material_phase - real, dimension(:), intent(in) :: value - integer :: i - type(registered_diagnostic_item), pointer :: iterator => NULL() + subroutine set_diagnostic(name, statistic, material_phase, value) + character(len=*), intent(in) :: name, statistic + character(len=*), intent(in), optional :: material_phase + real, dimension(:), intent(in) :: value + integer :: i - if(getprocno() == 1) then - iterator => default_stat%registered_diagnostic_first + type(registered_diagnostic_item), pointer :: iterator => NULL() - do while (.true.) - if (.not. associated(iterator)) then - ewrite(0, *) "The diagnostic with name=" // trim(name) // " statistic=" // trim(statistic) // & + if(getprocno() == 1) then + iterator => default_stat%registered_diagnostic_first + + do while (.true.) + if (.not. associated(iterator)) then + ewrite(0, *) "The diagnostic with name=" // trim(name) // " statistic=" // trim(statistic) // & & "material_phase=" // trim(material_phase) // " does not exist." - FLAbort("Error in set_diagnostic.") - end if - ! Check if name and statistic match - if (iterator%name == name .and. iterator%statistic == statistic) then - ! Check if name of material_phase match if supplied - if ((present(material_phase) .and. iterator%have_material_phase .and. iterator%material_phase == material_phase) & - & .or. .not. iterator%have_material_phase) then - ! Check that the value arrays have the same dimension - if (size(iterator%value) /= size(value)) then - ewrite(0, *) "The registered diagnostic with name=" // trim(name) // " statistic=" // & - & trim(statistic) // "material_phase=" // trim(material_phase) // " has dimension " // & - & int2str(iterator%dim) // " but a value of dimension " // int2str(size(value)) // & - & " was supplied in set_diagnostic." - FLAbort("Error in set_diagnostic.") + FLAbort("Error in set_diagnostic.") end if - ! set value - do i = 1, iterator%dim - iterator%value(i) = value(i) - end do - return - end if - end if - iterator => iterator%next - end do - end if + ! Check if name and statistic match + if (iterator%name == name .and. iterator%statistic == statistic) then + ! Check if name of material_phase match if supplied + if ((present(material_phase) .and. iterator%have_material_phase .and. iterator%material_phase == material_phase) & + & .or. .not. iterator%have_material_phase) then + ! Check that the value arrays have the same dimension + if (size(iterator%value) /= size(value)) then + ewrite(0, *) "The registered diagnostic with name=" // trim(name) // " statistic=" // & + & trim(statistic) // "material_phase=" // trim(material_phase) // " has dimension " // & + & int2str(iterator%dim) // " but a value of dimension " // int2str(size(value)) // & + & " was supplied in set_diagnostic." + FLAbort("Error in set_diagnostic.") + end if + ! set value + do i = 1, iterator%dim + iterator%value(i) = value(i) + end do + return + end if + end if + iterator => iterator%next + end do + end if - end subroutine set_diagnostic + end subroutine set_diagnostic - function get_diagnostic(name, statistic, material_phase) result(value) - character(len=*), intent(in) :: name, statistic - character(len=*), intent(in), optional :: material_phase - real, dimension(:), pointer :: value + function get_diagnostic(name, statistic, material_phase) result(value) + character(len=*), intent(in) :: name, statistic + character(len=*), intent(in), optional :: material_phase + real, dimension(:), pointer :: value - type(registered_diagnostic_item), pointer :: iterator + type(registered_diagnostic_item), pointer :: iterator - iterator => null() - value => null() + iterator => null() + value => null() - if(getprocno() == 1) then - iterator => default_stat%registered_diagnostic_first + if(getprocno() == 1) then + iterator => default_stat%registered_diagnostic_first - do while (.true.) - if (.not. associated(iterator)) then - ewrite(0, *) "The diagnostic with name=" // trim(name) // " statistic=" // trim(statistic) // & + do while (.true.) + if (.not. associated(iterator)) then + ewrite(0, *) "The diagnostic with name=" // trim(name) // " statistic=" // trim(statistic) // & & "material_phase=" // trim(material_phase) // " does not exist." - FLAbort("Error in set_diagnostic.") - end if - ! Check if name and statistic match - if (iterator%name == name .and. iterator%statistic == statistic) then - ! Check if name of material_phase match if supplied - if ((present(material_phase) .and. iterator%have_material_phase .and. iterator%material_phase == material_phase) & - & .or. .not. iterator%have_material_phase) then - value => iterator%value - return - end if - end if - iterator => iterator%next - end do - end if - end function get_diagnostic - - subroutine print_registered_diagnostics - type(registered_diagnostic_item), pointer :: iterator => NULL() - - iterator => default_stat%registered_diagnostic_first - - ewrite(1, *) "Registered diagnostics:" - do while(associated(iterator)) - if (iterator%have_material_phase) then - ewrite(1, *) "Name: ", trim(iterator%name), ", ", & - & "Statistic: ", trim(iterator%statistic), ", ", & - & "Dimension: ", int2str(iterator%dim), ", ", & - & "Material phase: ", trim(iterator%material_phase) - else - ewrite(1, *) "Name: ", trim(iterator%name), ", ", & - & "Statistic: ", trim(iterator%statistic), ", ", & - & "Dimension: ", int2str(iterator%dim) - end if - iterator => iterator%next - end do - - end subroutine print_registered_diagnostics - - subroutine register_diagnostic(dim, name, statistic, material_phase) - integer, intent(in) :: dim - character(len=*), intent(in) :: name, statistic - character(len=*), intent(in), optional :: material_phase - type(registered_diagnostic_item), pointer :: diagnostic_item, iterator => NULL() - - if(getprocno() == 1) then - ! Allocate the new registered_diagnostic_item and fill it. - allocate(diagnostic_item) - diagnostic_item%dim = dim - diagnostic_item%name = name - diagnostic_item%statistic = statistic - if (present(material_phase)) then - diagnostic_item%material_phase = material_phase - diagnostic_item%have_material_phase = .true. - else - diagnostic_item%have_material_phase = .false. - end if - allocate(diagnostic_item%value(dim)) - diagnostic_item%value = INFINITY - nullify(diagnostic_item%next) - - ! Check if the diagnostic has not been registered yet - if (associated(default_stat%registered_diagnostic_first)) then - iterator => default_stat%registered_diagnostic_first - do while (associated(iterator)) - if (iterator%dim == diagnostic_item%dim .and. iterator%name == diagnostic_item%name .and. & - & iterator%statistic == diagnostic_item%statistic) then - if ( (present(material_phase) .and. iterator%have_material_phase) .or. & - & (.not. present(material_phase) .and. .not. iterator%have_material_phase) ) then - if (present(material_phase)) then - if (iterator%material_phase == diagnostic_item%material_phase) then - ewrite(0, *) "The diagnostic with name = " // trim(name) // ", statistic = " // & - & trim(statistic) // ", material_phase = " // trim(material_phase) // ", and dimension = " // & - & int2str(iterator%dim) // " has already been registered." - end if - else - ewrite(0, *) "The diagnostic with name = " // trim(name) // ", statistic = " // trim(statistic) & - & // ", and dimension = " // int2str(iterator%dim) // " has already been registered." - end if - FLExit("Error in register_diagnostic.") + FLAbort("Error in set_diagnostic.") end if - end if - iterator => iterator%next - end do + ! Check if name and statistic match + if (iterator%name == name .and. iterator%statistic == statistic) then + ! Check if name of material_phase match if supplied + if ((present(material_phase) .and. iterator%have_material_phase .and. iterator%material_phase == material_phase) & + & .or. .not. iterator%have_material_phase) then + value => iterator%value + return + end if + end if + iterator => iterator%next + end do end if + end function get_diagnostic - ! Now append it to the list of registered diagnostics - if (.not. associated(default_stat%registered_diagnostic_first)) then - default_stat%registered_diagnostic_first => diagnostic_item - else - iterator => default_stat%registered_diagnostic_first - do while(associated(iterator%next)) - iterator => iterator%next - end do - iterator%next => diagnostic_item + subroutine print_registered_diagnostics + type(registered_diagnostic_item), pointer :: iterator => NULL() + + iterator => default_stat%registered_diagnostic_first + + ewrite(1, *) "Registered diagnostics:" + do while(associated(iterator)) + if (iterator%have_material_phase) then + ewrite(1, *) "Name: ", trim(iterator%name), ", ", & + & "Statistic: ", trim(iterator%statistic), ", ", & + & "Dimension: ", int2str(iterator%dim), ", ", & + & "Material phase: ", trim(iterator%material_phase) + else + ewrite(1, *) "Name: ", trim(iterator%name), ", ", & + & "Statistic: ", trim(iterator%statistic), ", ", & + & "Dimension: ", int2str(iterator%dim) + end if + iterator => iterator%next + end do + + end subroutine print_registered_diagnostics + + subroutine register_diagnostic(dim, name, statistic, material_phase) + integer, intent(in) :: dim + character(len=*), intent(in) :: name, statistic + character(len=*), intent(in), optional :: material_phase + type(registered_diagnostic_item), pointer :: diagnostic_item, iterator => NULL() + + if(getprocno() == 1) then + ! Allocate the new registered_diagnostic_item and fill it. + allocate(diagnostic_item) + diagnostic_item%dim = dim + diagnostic_item%name = name + diagnostic_item%statistic = statistic + if (present(material_phase)) then + diagnostic_item%material_phase = material_phase + diagnostic_item%have_material_phase = .true. + else + diagnostic_item%have_material_phase = .false. + end if + allocate(diagnostic_item%value(dim)) + diagnostic_item%value = INFINITY + nullify(diagnostic_item%next) + + ! Check if the diagnostic has not been registered yet + if (associated(default_stat%registered_diagnostic_first)) then + iterator => default_stat%registered_diagnostic_first + do while (associated(iterator)) + if (iterator%dim == diagnostic_item%dim .and. iterator%name == diagnostic_item%name .and. & + & iterator%statistic == diagnostic_item%statistic) then + if ( (present(material_phase) .and. iterator%have_material_phase) .or. & + & (.not. present(material_phase) .and. .not. iterator%have_material_phase) ) then + if (present(material_phase)) then + if (iterator%material_phase == diagnostic_item%material_phase) then + ewrite(0, *) "The diagnostic with name = " // trim(name) // ", statistic = " // & + & trim(statistic) // ", material_phase = " // trim(material_phase) // ", and dimension = " // & + & int2str(iterator%dim) // " has already been registered." + end if + else + ewrite(0, *) "The diagnostic with name = " // trim(name) // ", statistic = " // trim(statistic) & + & // ", and dimension = " // int2str(iterator%dim) // " has already been registered." + end if + FLExit("Error in register_diagnostic.") + end if + end if + iterator => iterator%next + end do + end if + + ! Now append it to the list of registered diagnostics + if (.not. associated(default_stat%registered_diagnostic_first)) then + default_stat%registered_diagnostic_first => diagnostic_item + else + iterator => default_stat%registered_diagnostic_first + do while(associated(iterator%next)) + iterator => iterator%next + end do + iterator%next => diagnostic_item + end if end if - end if - end subroutine register_diagnostic + end subroutine register_diagnostic - ! Clean up the list of registered diagnostics - subroutine destroy_registered_diagnostics - type(registered_diagnostic_item), pointer :: next, iterator + ! Clean up the list of registered diagnostics + subroutine destroy_registered_diagnostics + type(registered_diagnostic_item), pointer :: next, iterator - if(getprocno() == 1) then - iterator => default_stat%registered_diagnostic_first + if(getprocno() == 1) then + iterator => default_stat%registered_diagnostic_first - do while (associated(iterator)) - next => iterator%next - deallocate(iterator%value) - deallocate(iterator) - iterator => next - end do + do while (associated(iterator)) + next => iterator%next + deallocate(iterator%value) + deallocate(iterator) + iterator => next + end do - ! the first registered diagnostic needs to be nullified because - ! when adjointing, all the diagnostics are initialised/registered again - nullify(default_stat%registered_diagnostic_first) - end if + ! the first registered diagnostic needs to be nullified because + ! when adjointing, all the diagnostics are initialised/registered again + nullify(default_stat%registered_diagnostic_first) + end if - end subroutine destroy_registered_diagnostics + end subroutine destroy_registered_diagnostics - subroutine uninitialise_diagnostics - ! Undo all of the initialise_diagnostics business. - ! Necessary for adjoints, for a start ... - ! Make sure to call close_diagnostic_files before re-initialising - type(stat_type) :: new_default_stat + subroutine uninitialise_diagnostics + ! Undo all of the initialise_diagnostics business. + ! Necessary for adjoints, for a start ... + ! Make sure to call close_diagnostic_files before re-initialising + type(stat_type) :: new_default_stat - default_stat%initialised = .false. - deallocate(default_stat%mesh_list) - deallocate(default_stat%sfield_list) - deallocate(default_stat%vfield_list) + default_stat%initialised = .false. + deallocate(default_stat%mesh_list) + deallocate(default_stat%sfield_list) + deallocate(default_stat%vfield_list) - ! The diagnostics are registered under initialise_diagnostics so they need to be destroyed here. - call destroy_registered_diagnostics + ! The diagnostics are registered under initialise_diagnostics so they need to be destroyed here. + call destroy_registered_diagnostics - default_stat = new_default_stat ! new default_stat has been initialised with all the default values, na ja? - end subroutine uninitialise_diagnostics + default_stat = new_default_stat ! new default_stat has been initialised with all the default values, na ja? + end subroutine uninitialise_diagnostics - subroutine initialise_constant_diagnostics(unit, binary_format) - !!< Output constant values in the header of the stat file. - integer, intent(in) :: unit - !! If present and .true., indicates binary output format - logical, optional, intent(in) :: binary_format - integer :: stat + subroutine initialise_constant_diagnostics(unit, binary_format) + !!< Output constant values in the header of the stat file. + integer, intent(in) :: unit + !! If present and .true., indicates binary output format + logical, optional, intent(in) :: binary_format + integer :: stat - character(len=254) :: buffer, value_buffer + character(len=254) :: buffer, value_buffer #ifdef __FLUIDITY_VERSION__ - value_buffer = __FLUIDITY_VERSION__ + value_buffer = __FLUIDITY_VERSION__ #else - value_buffer="Unknown" + value_buffer="Unknown" #endif - buffer=constant_tag(name="FluidityVersion", type="string", value=trim(value_buffer)) - write(unit, '(a)') trim(buffer) - - value_buffer = __DATE__ // " " // __TIME__ - buffer=constant_tag(name="CompileTime", type="string", value=trim(value_buffer)) - write(unit, '(a)') trim(buffer) - - value_buffer=date_and_time_string() - buffer=constant_tag(name="StartTime", type="string", value=trim(value_buffer)) - write(unit, '(a)') trim(buffer) - - call get_environment_variable(name="HOSTNAME", value=value_buffer, status=stat) - if (stat /= 0) then - ewrite(-1, *) "GET_ENVIRONMENT_VARIABLE('HOSTNAME') returned no-zero status: ", stat - end if - buffer=constant_tag(name="HostName", type="string", value=trim(value_buffer)) - write(unit, '(a)') trim(buffer) - - ! Constant values - if(present_and_true(binary_format)) then - buffer = constant_tag(name = "format", type = "string", value = "binary") + buffer=constant_tag(name="FluidityVersion", type="string", value=trim(value_buffer)) write(unit, '(a)') trim(buffer) - buffer = constant_tag(name = "real_size", type = "integer", value = int2str(real_size)) + + value_buffer = __DATE__ // " " // __TIME__ + buffer=constant_tag(name="CompileTime", type="string", value=trim(value_buffer)) write(unit, '(a)') trim(buffer) - buffer = constant_tag(name = "integer_size", type = "integer", value = int2str(integer_size)) + + value_buffer=date_and_time_string() + buffer=constant_tag(name="StartTime", type="string", value=trim(value_buffer)) write(unit, '(a)') trim(buffer) - else - buffer = constant_tag(name = "format", type = "string", value = "plain_text") + + call get_environment_variable(name="HOSTNAME", value=value_buffer, status=stat) + if (stat /= 0) then + ewrite(-1, *) "GET_ENVIRONMENT_VARIABLE('HOSTNAME') returned no-zero status: ", stat + end if + buffer=constant_tag(name="HostName", type="string", value=trim(value_buffer)) write(unit, '(a)') trim(buffer) - end if - contains + ! Constant values + if(present_and_true(binary_format)) then + buffer = constant_tag(name = "format", type = "string", value = "binary") + write(unit, '(a)') trim(buffer) + buffer = constant_tag(name = "real_size", type = "integer", value = int2str(real_size)) + write(unit, '(a)') trim(buffer) + buffer = constant_tag(name = "integer_size", type = "integer", value = int2str(integer_size)) + write(unit, '(a)') trim(buffer) + else + buffer = constant_tag(name = "format", type = "string", value = "plain_text") + write(unit, '(a)') trim(buffer) + end if - function date_and_time_string() - character(len=254) :: date_and_time_string + contains - character(len=8) :: date - character(len=10) :: time - character(len=5) :: zone + function date_and_time_string() + character(len=254) :: date_and_time_string - call date_and_time(date, time, zone) + character(len=8) :: date + character(len=10) :: time + character(len=5) :: zone - date_and_time_string=date//" "//time//zone + call date_and_time(date, time, zone) - end function date_and_time_string + date_and_time_string=date//" "//time//zone - end subroutine initialise_constant_diagnostics + end function date_and_time_string - subroutine initialise_convergence(filename, state) - !!< Set up the convergence file headers. + end subroutine initialise_constant_diagnostics - character(len=*) :: filename - type(state_type), dimension(:), intent(in) :: state + subroutine initialise_convergence(filename, state) + !!< Set up the convergence file headers. - integer :: column, i, j, phase - character(len = 254) :: buffer, material_phase_name - type(scalar_field) :: vfield_comp - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield + character(len=*) :: filename + type(state_type), dimension(:), intent(in) :: state - ! Idempotency check - if (default_stat%convergence_initialised) return - default_stat%convergence_initialised=.true. + integer :: column, i, j, phase + character(len = 254) :: buffer, material_phase_name + type(scalar_field) :: vfield_comp + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield - if(have_option("/io/convergence/convergence_file")) then - default_stat%write_convergence_file = .true. - else - default_stat%write_convergence_file = .false. - return - end if + ! Idempotency check + if (default_stat%convergence_initialised) return + default_stat%convergence_initialised=.true. + + if(have_option("/io/convergence/convergence_file")) then + default_stat%write_convergence_file = .true. + else + default_stat%write_convergence_file = .false. + return + end if - ! Only the first process should write convergence information - if(getprocno() == 1) then - default_stat%conv_unit=free_unit() - open(unit=default_stat%conv_unit, file=trim(filename)//'.convergence', action="write") - else - return - end if + ! Only the first process should write convergence information + if(getprocno() == 1) then + default_stat%conv_unit=free_unit() + open(unit=default_stat%conv_unit, file=trim(filename)//'.convergence', action="write") + else + return + end if - write(default_stat%conv_unit, '(a)') "
" + write(default_stat%conv_unit, '(a)') "
" - column=0 + column=0 - ! Initial columns are elapsed time, dt and global iteration - column=column+1 - buffer=field_tag(name="ElapsedTime", column=column, statistic="value") - write(default_stat%conv_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="dt", column=column, statistic="value") - write(default_stat%conv_unit, '(a)') trim(buffer) - column=column+1! Vector field magnitude - buffer=field_tag(name="Iteration", column=column, statistic="value") - write(default_stat%conv_unit, '(a)') trim(buffer) + ! Initial columns are elapsed time, dt and global iteration + column=column+1 + buffer=field_tag(name="ElapsedTime", column=column, statistic="value") + write(default_stat%conv_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="dt", column=column, statistic="value") + write(default_stat%conv_unit, '(a)') trim(buffer) + column=column+1! Vector field magnitude + buffer=field_tag(name="Iteration", column=column, statistic="value") + write(default_stat%conv_unit, '(a)') trim(buffer) - phaseloop: do phase=1,size(state) + phaseloop: do phase=1,size(state) - material_phase_name=trim(state(phase)%name) + material_phase_name=trim(state(phase)%name) - do i=1, size(default_stat%sfield_list(phase)%ptr) - ! Output convergence information for each scalar field. - sfield => extract_scalar_field(state(phase), default_stat%sfield_list(phase)%ptr(i)) + do i=1, size(default_stat%sfield_list(phase)%ptr) + ! Output convergence information for each scalar field. + sfield => extract_scalar_field(state(phase), default_stat%sfield_list(phase)%ptr(i)) - if(.not. convergence_field(sfield)) then - cycle - end if + if(.not. convergence_field(sfield)) then + cycle + end if - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="error", material_phase_name=material_phase_name) - write(default_stat%conv_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="error", material_phase_name=material_phase_name) + write(default_stat%conv_unit, '(a)') trim(buffer) - end do + end do do i = 1, size(default_stat%vfield_list(phase)%ptr) - ! Headers for output convergence information for each vector field + ! Headers for output convergence information for each vector field + + vfield => extract_vector_field(state(phase), & + & default_stat%vfield_list(phase)%ptr(i)) + + if(.not. convergence_field(vfield)) then + cycle + end if + + column = column + 1 + buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & + & statistic="error", material_phase_name=material_phase_name) + write(default_stat%conv_unit, '(a)') trim(buffer) + + if(.not. convergence_field(vfield, test_for_components = .true.)) then + cycle + end if + + do j = 1, mesh_dim(vfield%mesh) + vfield_comp = extract_scalar_field(vfield, j) + + column = column + 1 + buffer=field_tag(name=vfield_comp%name, column=column, statistic="error", & + & material_phase_name=material_phase_name) + write(default_stat%conv_unit, '(a)') trim(buffer) + + end do + + end do + + end do phaseloop + + write(default_stat%conv_unit, '(a)') "
" + + end subroutine initialise_convergence + + subroutine initialise_steady_state(filename, state) + !!< Set up the steady state file headers. + + character(len=*) :: filename + type(state_type), dimension(:), intent(in) :: state - vfield => extract_vector_field(state(phase), & - & default_stat%vfield_list(phase)%ptr(i)) + integer :: column, i, j, phase + character(len = 254) :: buffer, material_phase_name + type(scalar_field) :: vfield_comp + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield - if(.not. convergence_field(vfield)) then - cycle - end if + ! Idempotency check + if (default_stat%steady_state_initialised) return + default_stat%steady_state_initialised=.true. - column = column + 1 - buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & - & statistic="error", material_phase_name=material_phase_name) - write(default_stat%conv_unit, '(a)') trim(buffer) + default_stat%write_steady_state_file = have_option("/timestepping/steady_state/steady_state_file") + if(.not. default_stat%write_steady_state_file) return + if(have_option("/timestepping/steady_state/steady_state_file/binary_output")) then + default_stat%binary_steady_state_output = .true. + else if(have_option("/timestepping/steady_state/steady_state_file/plain_text_output")) then + default_stat%binary_steady_state_output = .false. + else + FLExit("Unable to determine steady state output format. Check options under /timestepping/steady_state/steady_state_file") + end if + + ! Only the first process should write steady state information + if(getprocno() /= 1) return + + default_stat%steady_state_unit=free_unit() + open(unit=default_stat%steady_state_unit, file=trim(filename)//'.steady_state', action="write") + + write(default_stat%steady_state_unit, '(a)') "
" + + call initialise_constant_diagnostics(default_stat%steady_state_unit, binary_format = default_stat%binary_steady_state_output) - if(.not. convergence_field(vfield, test_for_components = .true.)) then - cycle - end if + ! Initial columns are elapsed time, dt and global iteration + column=1 + buffer=field_tag(name="ElapsedTime", column=column, statistic="value") + write(default_stat%steady_state_unit, '(a)') trim(buffer) + column=column+1 + buffer=field_tag(name="dt", column=column, statistic="value") + write(default_stat%steady_state_unit, '(a)') trim(buffer) + + phaseloop: do phase=1,size(state) + material_phase_name = state(phase)%name - do j = 1, mesh_dim(vfield%mesh) - vfield_comp = extract_scalar_field(vfield, j) + do i = 1, scalar_field_count(state(phase)) + sfield => extract_scalar_field(state(phase), i) + if(.not. steady_state_field(sfield)) cycle + ! Scalar fields - column = column + 1 - buffer=field_tag(name=vfield_comp%name, column=column, statistic="error", & + column=column+1 + buffer=field_tag(name=sfield%name, column=column, statistic="error", material_phase_name=material_phase_name) + write(default_stat%steady_state_unit, '(a)') trim(buffer) + end do + + do i = 1, vector_field_count(state(phase)) + vfield => extract_vector_field(state(phase), i) + if(.not. steady_state_field(vfield)) cycle + ! Vector fields + + column = column + 1 + buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & + & statistic="error", material_phase_name=material_phase_name) + write(default_stat%steady_state_unit, '(a)') trim(buffer) + + if(.not. steady_state_field(vfield, test_for_components = .true.)) cycle + ! Vector field components + + do j = 1, mesh_dim(vfield%mesh) + vfield_comp = extract_scalar_field(vfield, j) + + column = column + 1 + buffer=field_tag(name=vfield_comp%name, column=column, statistic="error", & & material_phase_name=material_phase_name) - write(default_stat%conv_unit, '(a)') trim(buffer) + write(default_stat%steady_state_unit, '(a)') trim(buffer) + end do + end do - end do + end do phaseloop + + column = column + 1 + buffer = field_tag(name = "MaxChange", column=column, statistic="value") + write(default_stat%steady_state_unit, '(a)') trim(buffer) + + write(default_stat%steady_state_unit, '(a)') "
" + flush(default_stat%steady_state_unit) + + if(default_stat%binary_steady_state_output) then + close(default_stat%steady_state_unit) + +#ifdef STREAM_IO + open(unit = default_stat%steady_state_unit, file = trim(filename) // '.steady_state.dat', & + & action = "write", access = "stream", form = "unformatted", status = "replace") +#else + FLAbort("No stream I/O support") +#endif + end if + end subroutine initialise_steady_state + + subroutine create_single_detector(detector_list,xfield,position,id,proc_id) + ! Allocate a single detector, populate and insert it into the given list + ! In parallel, first check if the detector would be local and only allocate if it is + type(detector_linked_list), intent(inout) :: detector_list + type(vector_field), pointer :: xfield + real, dimension(xfield%dim), intent(in) :: position + integer, intent(in) :: id, proc_id + + type(detector_type), pointer :: detector + type(element_type), pointer :: shape + real, dimension(xfield%dim+1) :: lcoords + integer :: element + + shape=>ele_shape(xfield,1) + assert(xfield%dim+1==local_coord_count(shape)) + + ! Determine element and local_coords from position + ! In parallel, global=.false. can often work because there will be + ! a halo of non-owned elements in your process and so you can work out + ! ownership without communication. But in general it won't work. + call picker_inquire(xfield,position,element,local_coord=lcoords,global=.true.) + + ! If we're in parallel and don't own the element, skip this detector + if (isparallel()) then + if (element<0) return + if (.not.element_owned(xfield,element)) return + else + ! In serial make sure the detector is in the domain + ! unless we have the write_nan_outside override + if (element<0 .and. .not.detector_list%write_nan_outside) then + ewrite(-1,*) "Dealing with detector ", id, " proc_id ",proc_id + FLExit("Trying to initialise detector outside of computational domain") + end if + end if + ! Otherwise, allocate and insert detector + allocate(detector) + allocate(detector%position(xfield%dim)) + allocate(detector%local_coords(local_coord_count(shape))) + ! Allocate detector attribute sizes to be zero + allocate(detector%attributes(0)) + allocate(detector%old_attributes(0)) + allocate(detector%old_fields(0)) + call insert(detector,detector_list) + + ! Populate detector + detector%position=position + detector%element=element + detector%local_coords=lcoords + detector%id_number=id + detector%proc_id=proc_id + detector_list%proc_part_count = detector_list%proc_part_count + 1 + + end subroutine create_single_detector + + subroutine initialise_detectors(filename, state) + !!< Set up the detector file headers. This has the same syntax as the + !!< .stat file + character(len = *), intent(in) :: filename + type(state_type), dimension(:), intent(in) :: state + + character(len=FIELD_NAME_LEN) ::funcnam, temp_name, detector_name + character(len=PYTHON_FUNC_LEN) :: func + + integer :: i, j, k, phase, m, field_count, totaldet_global + integer :: static_dete, python_functions_or_files, total_dete, total_dete_groups + integer :: python_dete, ndete, dim, group_size, proc_num + integer(kind=8) :: h5_ierror + integer, dimension(2) :: shape_option + character(len = 254) :: buffer, material_phase_name + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield, xfield + real, allocatable, dimension(:,:) :: coords + real, allocatable, dimension(:) :: detector_location + real:: current_time + character(len = OPTION_PATH_LEN) :: detectors_cp_filename, detector_file_filename + + type(element_type), pointer :: shape + + ! Idempotency check + if (default_stat%detectors_initialised) return + default_stat%detectors_initialised=.true. + + ewrite(2,*) "In initialise_detectors" + + proc_num = getprocno() + + ! Check whether there are actually any detectors. + static_dete = option_count("/io/detectors/static_detector") + python_functions_or_files = option_count("/io/detectors/detector_array") + python_dete = 0 + + do i=1,python_functions_or_files + write(buffer, "(a,i0,a)") "/io/detectors/detector_array[",i-1,"]" + call get_option(trim(buffer)//"/number_of_detectors", j) + python_dete=python_dete+j + end do + + total_dete = static_dete + python_dete + default_stat%detector_list%total_num_det = total_dete + default_stat%detector_list%total_attributes(:) = 0 + total_dete_groups = static_dete + python_functions_or_files + + allocate(default_stat%detector_group_names(total_dete_groups)) + allocate(default_stat%number_det_in_each_group(total_dete_groups)) + + if (total_dete==0) return + + ! Register this I/O detector list with a global list of detector lists + call register_detector_list(default_stat%detector_list) + + xfield=>extract_vector_field(state(1), "Coordinate") + shape=>ele_shape(xfield,1) + call get_option("/geometry/dimension",dim) + call get_option("/timestepping/current_time", current_time) + allocate(detector_location(dim)) + + ! Enable detectors to drift with the mesh + if (have_option("/io/detectors/move_with_mesh")) then + default_stat%detector_list%move_with_mesh=.true. + end if + + ! Set flag for NaN detector output + if (have_option("/io/detectors/write_nan_outside_domain")) then + default_stat%detector_list%write_nan_outside=.true. + end if + + ! Retrieve the position of each detector. If the option + ! "from_checkpoint_file" exists, it means we are continuing the simulation + ! after checkpointing and the reading of the detector positions must be + ! done from a file + if (have_option("/io/detectors/static_detector/from_checkpoint_file").or. & + & have_option("/io/detectors/detector_array/from_checkpoint_file")) then + default_stat%from_checkpoint=.true. + else + default_stat%from_checkpoint=.false. + end if + + ! Read detectors from options + if (.not.default_stat%from_checkpoint) then + ewrite(2,*) "Reading detectors from options" + + ! Read all single static detector from options + do i=1,static_dete + write(buffer, "(a,i0,a)") "/io/detectors/static_detector[",i-1,"]" + + shape_option=option_shape(trim(buffer)//"/location") + assert(xfield%dim==shape_option(1)) + call get_option(trim(buffer)//"/location", detector_location) + + ! The arrays below contain information about the order in which detector + ! groups are read and how many detectors there are in each group. This is + ! used when checkpointing detectors. In particular, when continuing a + ! simulation from a checkpoint, with these arrays we make sure we read + ! back the detectors from the file in the same order than at the beginning + ! of the simulation for consistency. All the .detectors files with + ! detector data (position, value of variables at those positions, etc.) + ! will have the information in the same order. + call get_option(trim(buffer)//"/name", detector_name) + default_stat%detector_group_names(i)=detector_name + default_stat%number_det_in_each_group(i)=1.0 + + call create_single_detector(default_stat%detector_list, xfield, & + detector_location, i, proc_num) end do - end do phaseloop + k=static_dete+1 + + do i=1,python_functions_or_files + write(buffer, "(a,i0,a)") "/io/detectors/detector_array[",i-1,"]" + + call get_option(trim(buffer)//"/name", funcnam) + call get_option(trim(buffer)//"/number_of_detectors", ndete) + + default_stat%detector_group_names(i+static_dete) = trim(funcnam) + default_stat%number_det_in_each_group(i+static_dete) = ndete + + if (.not.have_option(trim(buffer)//"/from_file")) then - write(default_stat%conv_unit, '(a)') "
" + ! Reading detectors from a python function + call get_option(trim(buffer)//"/python", func) + allocate(coords(dim,ndete)) + call set_detector_coords_from_python(coords, ndete, func, current_time) - end subroutine initialise_convergence + do j=1,ndete + call create_single_detector(default_stat%detector_list, xfield, & + coords(:,j), k, proc_num) + k=k+1 + end do + deallocate(coords) - subroutine initialise_steady_state(filename, state) - !!< Set up the steady state file headers. + else - character(len=*) :: filename - type(state_type), dimension(:), intent(in) :: state + ! Reading from a binary file where the user has placed the detector positions + default_stat%detector_file_unit=free_unit() + call get_option("/io/detectors/detector_array/from_file/file_name",detector_file_filename) - integer :: column, i, j, phase - character(len = 254) :: buffer, material_phase_name - type(scalar_field) :: vfield_comp - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield +#ifdef STREAM_IO + open(unit = default_stat%detector_file_unit, file = trim(detector_file_filename), & + & action = "read", access = "stream", form = "unformatted") +#else + FLAbort("No stream I/O support") +#endif - ! Idempotency check - if (default_stat%steady_state_initialised) return - default_stat%steady_state_initialised=.true. + do j=1,ndete + read(default_stat%detector_file_unit) detector_location + call create_single_detector(default_stat%detector_list, xfield, & + detector_location, k, proc_num) + k=k+1 + end do + end if + end do + else + ewrite(2,*) "Reading detectors from checkpoint" - default_stat%write_steady_state_file = have_option("/timestepping/steady_state/steady_state_file") - if(.not. default_stat%write_steady_state_file) return - if(have_option("/timestepping/steady_state/steady_state_file/binary_output")) then - default_stat%binary_steady_state_output = .true. - else if(have_option("/timestepping/steady_state/steady_state_file/plain_text_output")) then - default_stat%binary_steady_state_output = .false. - else - FLExit("Unable to determine steady state output format. Check options under /timestepping/steady_state/steady_state_file") - end if + ! If reading from checkpoint file: + ! Detector checkpoint file names end in _det, with.groups appended for the header file + ! and .positions.dat appended for the binary data file that holds the positions - ! Only the first process should write steady state information - if(getprocno() /= 1) return + default_stat%detector_checkpoint_unit=free_unit() + if (have_option("/io/detectors/static_detector")) then + call get_option("/io/detectors/static_detector/from_checkpoint_file/file_name",detectors_cp_filename) + else + call get_option("/io/detectors/detector_array/from_checkpoint_file/file_name",detectors_cp_filename) + end if - default_stat%steady_state_unit=free_unit() - open(unit=default_stat%steady_state_unit, file=trim(filename)//'.steady_state', action="write") + open(unit=default_stat%detector_checkpoint_unit, file=trim(detectors_cp_filename) // '.groups', action="read") - write(default_stat%steady_state_unit, '(a)') "
" + ! First we read the header of checkpoint_file to get the order in which the detectors were read initialliy + do i=1, total_dete_groups + read(default_stat%detector_checkpoint_unit,'(a,i10)') default_stat%detector_group_names(i), default_stat%number_det_in_each_group(i) + end do - call initialise_constant_diagnostics(default_stat%steady_state_unit, binary_format = default_stat%binary_steady_state_output) + close(default_stat%detector_checkpoint_unit) + +#ifdef STREAM_IO + open(unit = default_stat%detector_checkpoint_unit, file = trim(detectors_cp_filename) // '.positions.dat', & + & action = "read", access = "stream", form = "unformatted") +#else + FLAbort("No stream I/O support") +#endif + + ! Read in order the last positions of the detectors from the binary file. + + do j=1,size(default_stat%detector_group_names) + do i=1,static_dete + write(buffer, "(a,i0,a)") "/io/detectors/static_detector[",i-1,"]" + call get_option(trim(buffer)//"/name", temp_name) + + if (default_stat%detector_group_names(j)==temp_name) then + read(default_stat%detector_checkpoint_unit) detector_location + call create_single_detector(default_stat%detector_list, xfield, & + detector_location, i, proc_num) + else + cycle + end if + end do + end do - ! Initial columns are elapsed time, dt and global iteration - column=1 - buffer=field_tag(name="ElapsedTime", column=column, statistic="value") - write(default_stat%steady_state_unit, '(a)') trim(buffer) - column=column+1 - buffer=field_tag(name="dt", column=column, statistic="value") - write(default_stat%steady_state_unit, '(a)') trim(buffer) + k=static_dete+1 - phaseloop: do phase=1,size(state) - material_phase_name = state(phase)%name + do j=1,size(default_stat%detector_group_names) + do i=1,python_functions_or_files + write(buffer, "(a,i0,a)") "/io/detectors/detector_array[",i-1,"]" + call get_option(trim(buffer)//"/name", temp_name) - do i = 1, scalar_field_count(state(phase)) - sfield => extract_scalar_field(state(phase), i) - if(.not. steady_state_field(sfield)) cycle - ! Scalar fields + if (default_stat%detector_group_names(j)==temp_name) then + call get_option(trim(buffer)//"/number_of_detectors", ndete) - column=column+1 - buffer=field_tag(name=sfield%name, column=column, statistic="error", material_phase_name=material_phase_name) - write(default_stat%steady_state_unit, '(a)') trim(buffer) - end do + do m=1,default_stat%number_det_in_each_group(j) + read(default_stat%detector_checkpoint_unit) detector_location + call create_single_detector(default_stat%detector_list, xfield, & + detector_location, k, proc_num) + k=k+1 + end do + else + cycle + end if + end do + end do - do i = 1, vector_field_count(state(phase)) - vfield => extract_vector_field(state(phase), i) - if(.not. steady_state_field(vfield)) cycle - ! Vector fields + end if ! from_checkpoint - column = column + 1 - buffer = field_tag(name=trim(vfield%name) // "%magnitude", column=column, & - & statistic="error", material_phase_name=material_phase_name) - write(default_stat%steady_state_unit, '(a)') trim(buffer) + ! figure out the fields that are destined for output + allocate(default_stat%detector_list%sfield_list(size(state))) + allocate(default_stat%detector_list%vfield_list(size(state))) - if(.not. steady_state_field(vfield, test_for_components = .true.)) cycle - ! Vector field components + phaseloop: do phase = 1, size(state) + material_phase_name = trim(state(phase)%name) - do j = 1, mesh_dim(vfield%mesh) - vfield_comp = extract_scalar_field(vfield, j) + ! count scalar fields to include in detectors + field_count = 0 + do i = 1, size(state(phase)%scalar_names) + sfield => extract_scalar_field(state(phase), state(phase)%scalar_names(i)) - column = column + 1 - buffer=field_tag(name=vfield_comp%name, column=column, statistic="error", & - & material_phase_name=material_phase_name) - write(default_stat%steady_state_unit, '(a)') trim(buffer) + if (detector_field(sfield)) field_count = field_count + 1 end do - end do - - end do phaseloop - - column = column + 1 - buffer = field_tag(name = "MaxChange", column=column, statistic="value") - write(default_stat%steady_state_unit, '(a)') trim(buffer) - - write(default_stat%steady_state_unit, '(a)') "
" - flush(default_stat%steady_state_unit) - if(default_stat%binary_steady_state_output) then - close(default_stat%steady_state_unit) + allocate(default_stat%detector_list%sfield_list(phase)%ptr(field_count)) + default_stat%detector_list%num_sfields = default_stat%detector_list%num_sfields + field_count -#ifdef STREAM_IO - open(unit = default_stat%steady_state_unit, file = trim(filename) // '.steady_state.dat', & - & action = "write", access = "stream", form = "unformatted", status = "replace") -#else - FLAbort("No stream I/O support") -#endif - end if - - end subroutine initialise_steady_state - - subroutine create_single_detector(detector_list,xfield,position,id,proc_id) - ! Allocate a single detector, populate and insert it into the given list - ! In parallel, first check if the detector would be local and only allocate if it is - type(detector_linked_list), intent(inout) :: detector_list - type(vector_field), pointer :: xfield - real, dimension(xfield%dim), intent(in) :: position - integer, intent(in) :: id, proc_id - - type(detector_type), pointer :: detector - type(element_type), pointer :: shape - real, dimension(xfield%dim+1) :: lcoords - integer :: element - - shape=>ele_shape(xfield,1) - assert(xfield%dim+1==local_coord_count(shape)) - - ! Determine element and local_coords from position - ! In parallel, global=.false. can often work because there will be - ! a halo of non-owned elements in your process and so you can work out - ! ownership without communication. But in general it won't work. - call picker_inquire(xfield,position,element,local_coord=lcoords,global=.true.) - - ! If we're in parallel and don't own the element, skip this detector - if (isparallel()) then - if (element<0) return - if (.not.element_owned(xfield,element)) return - else - ! In serial make sure the detector is in the domain - ! unless we have the write_nan_outside override - if (element<0 .and. .not.detector_list%write_nan_outside) then - ewrite(-1,*) "Dealing with detector ", id, " proc_id ",proc_id - FLExit("Trying to initialise detector outside of computational domain") - end if - end if - ! Otherwise, allocate and insert detector - allocate(detector) - allocate(detector%position(xfield%dim)) - allocate(detector%local_coords(local_coord_count(shape))) - ! Allocate detector attribute sizes to be zero - allocate(detector%attributes(0)) - allocate(detector%old_attributes(0)) - allocate(detector%old_fields(0)) - call insert(detector,detector_list) - - ! Populate detector - detector%position=position - detector%element=element - detector%local_coords=lcoords - detector%id_number=id - detector%proc_id=proc_id - detector_list%proc_part_count = detector_list%proc_part_count + 1 - - end subroutine create_single_detector - - subroutine initialise_detectors(filename, state) - !!< Set up the detector file headers. This has the same syntax as the - !!< .stat file - character(len = *), intent(in) :: filename - type(state_type), dimension(:), intent(in) :: state - - character(len=FIELD_NAME_LEN) ::funcnam, temp_name, detector_name - character(len=PYTHON_FUNC_LEN) :: func - - integer :: i, j, k, phase, m, field_count, totaldet_global - integer :: static_dete, python_functions_or_files, total_dete, total_dete_groups - integer :: python_dete, ndete, dim, group_size, proc_num - integer(kind=8) :: h5_ierror - integer, dimension(2) :: shape_option - character(len = 254) :: buffer, material_phase_name - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield, xfield - real, allocatable, dimension(:,:) :: coords - real, allocatable, dimension(:) :: detector_location - real:: current_time - character(len = OPTION_PATH_LEN) :: detectors_cp_filename, detector_file_filename - - type(element_type), pointer :: shape - - ! Idempotency check - if (default_stat%detectors_initialised) return - default_stat%detectors_initialised=.true. - - ewrite(2,*) "In initialise_detectors" - - proc_num = getprocno() - - ! Check whether there are actually any detectors. - static_dete = option_count("/io/detectors/static_detector") - python_functions_or_files = option_count("/io/detectors/detector_array") - python_dete = 0 - - do i=1,python_functions_or_files - write(buffer, "(a,i0,a)") "/io/detectors/detector_array[",i-1,"]" - call get_option(trim(buffer)//"/number_of_detectors", j) - python_dete=python_dete+j - end do - - total_dete = static_dete + python_dete - default_stat%detector_list%total_num_det = total_dete - default_stat%detector_list%total_attributes(:) = 0 - total_dete_groups = static_dete + python_functions_or_files - - allocate(default_stat%detector_group_names(total_dete_groups)) - allocate(default_stat%number_det_in_each_group(total_dete_groups)) - - if (total_dete==0) return - - ! Register this I/O detector list with a global list of detector lists - call register_detector_list(default_stat%detector_list) - - xfield=>extract_vector_field(state(1), "Coordinate") - shape=>ele_shape(xfield,1) - call get_option("/geometry/dimension",dim) - call get_option("/timestepping/current_time", current_time) - allocate(detector_location(dim)) - - ! Enable detectors to drift with the mesh - if (have_option("/io/detectors/move_with_mesh")) then - default_stat%detector_list%move_with_mesh=.true. - end if - - ! Set flag for NaN detector output - if (have_option("/io/detectors/write_nan_outside_domain")) then - default_stat%detector_list%write_nan_outside=.true. - end if - - ! Retrieve the position of each detector. If the option - ! "from_checkpoint_file" exists, it means we are continuing the simulation - ! after checkpointing and the reading of the detector positions must be - ! done from a file - if (have_option("/io/detectors/static_detector/from_checkpoint_file").or. & -& have_option("/io/detectors/detector_array/from_checkpoint_file")) then - default_stat%from_checkpoint=.true. - else - default_stat%from_checkpoint=.false. - end if - - ! Read detectors from options - if (.not.default_stat%from_checkpoint) then - ewrite(2,*) "Reading detectors from options" - - ! Read all single static detector from options - do i=1,static_dete - write(buffer, "(a,i0,a)") "/io/detectors/static_detector[",i-1,"]" - - shape_option=option_shape(trim(buffer)//"/location") - assert(xfield%dim==shape_option(1)) - call get_option(trim(buffer)//"/location", detector_location) - - ! The arrays below contain information about the order in which detector - ! groups are read and how many detectors there are in each group. This is - ! used when checkpointing detectors. In particular, when continuing a - ! simulation from a checkpoint, with these arrays we make sure we read - ! back the detectors from the file in the same order than at the beginning - ! of the simulation for consistency. All the .detectors files with - ! detector data (position, value of variables at those positions, etc.) - ! will have the information in the same order. - call get_option(trim(buffer)//"/name", detector_name) - default_stat%detector_group_names(i)=detector_name - default_stat%number_det_in_each_group(i)=1.0 - - call create_single_detector(default_stat%detector_list, xfield, & - detector_location, i, proc_num) - end do - - k=static_dete+1 - - do i=1,python_functions_or_files - write(buffer, "(a,i0,a)") "/io/detectors/detector_array[",i-1,"]" - - call get_option(trim(buffer)//"/name", funcnam) - call get_option(trim(buffer)//"/number_of_detectors", ndete) - - default_stat%detector_group_names(i+static_dete) = trim(funcnam) - default_stat%number_det_in_each_group(i+static_dete) = ndete - - if (.not.have_option(trim(buffer)//"/from_file")) then - - ! Reading detectors from a python function - call get_option(trim(buffer)//"/python", func) - allocate(coords(dim,ndete)) - call set_detector_coords_from_python(coords, ndete, func, current_time) - - do j=1,ndete - call create_single_detector(default_stat%detector_list, xfield, & - coords(:,j), k, proc_num) - k=k+1 - end do - deallocate(coords) - - else - - ! Reading from a binary file where the user has placed the detector positions - default_stat%detector_file_unit=free_unit() - call get_option("/io/detectors/detector_array/from_file/file_name",detector_file_filename) + ! store scalar field names + field_count = 1 + do i = 1, size(state(phase)%scalar_names) + sfield => extract_scalar_field(state(phase), state(phase)%scalar_names(i)) -#ifdef STREAM_IO - open(unit = default_stat%detector_file_unit, file = trim(detector_file_filename), & - & action = "read", access = "stream", form = "unformatted") -#else - FLAbort("No stream I/O support") -#endif + if (detector_field(sfield)) then + default_stat%detector_list%sfield_list(phase)%ptr(field_count) = state(phase)%scalar_names(i) + field_count = field_count + 1 + end if + end do - do j=1,ndete - read(default_stat%detector_file_unit) detector_location - call create_single_detector(default_stat%detector_list, xfield, & - detector_location, k, proc_num) - k=k+1 - end do - end if - end do - else - ewrite(2,*) "Reading detectors from checkpoint" - - ! If reading from checkpoint file: - ! Detector checkpoint file names end in _det, with.groups appended for the header file - ! and .positions.dat appended for the binary data file that holds the positions - - default_stat%detector_checkpoint_unit=free_unit() - if (have_option("/io/detectors/static_detector")) then - call get_option("/io/detectors/static_detector/from_checkpoint_file/file_name",detectors_cp_filename) - else - call get_option("/io/detectors/detector_array/from_checkpoint_file/file_name",detectors_cp_filename) - end if - - open(unit=default_stat%detector_checkpoint_unit, file=trim(detectors_cp_filename) // '.groups', action="read") - - ! First we read the header of checkpoint_file to get the order in which the detectors were read initialliy - do i=1, total_dete_groups - read(default_stat%detector_checkpoint_unit,'(a,i10)') default_stat%detector_group_names(i), default_stat%number_det_in_each_group(i) - end do - - close(default_stat%detector_checkpoint_unit) + ! same process for vector fields + field_count = 0 + do i = 1, size(state(phase)%vector_names) + vfield => extract_vector_field(state(phase), state(phase)%vector_names(i)) -#ifdef STREAM_IO - open(unit = default_stat%detector_checkpoint_unit, file = trim(detectors_cp_filename) // '.positions.dat', & - & action = "read", access = "stream", form = "unformatted") -#else - FLAbort("No stream I/O support") -#endif + if (detector_field(vfield)) field_count = field_count + 1 + end do - ! Read in order the last positions of the detectors from the binary file. - - do j=1,size(default_stat%detector_group_names) - do i=1,static_dete - write(buffer, "(a,i0,a)") "/io/detectors/static_detector[",i-1,"]" - call get_option(trim(buffer)//"/name", temp_name) - - if (default_stat%detector_group_names(j)==temp_name) then - read(default_stat%detector_checkpoint_unit) detector_location - call create_single_detector(default_stat%detector_list, xfield, & - detector_location, i, proc_num) - else - cycle - end if - end do - end do - - k=static_dete+1 - - do j=1,size(default_stat%detector_group_names) - do i=1,python_functions_or_files - write(buffer, "(a,i0,a)") "/io/detectors/detector_array[",i-1,"]" - call get_option(trim(buffer)//"/name", temp_name) - - if (default_stat%detector_group_names(j)==temp_name) then - call get_option(trim(buffer)//"/number_of_detectors", ndete) - - do m=1,default_stat%number_det_in_each_group(j) - read(default_stat%detector_checkpoint_unit) detector_location - call create_single_detector(default_stat%detector_list, xfield, & - detector_location, k, proc_num) - k=k+1 - end do - else - cycle - end if - end do - end do - - end if ! from_checkpoint - - ! figure out the fields that are destined for output - allocate(default_stat%detector_list%sfield_list(size(state))) - allocate(default_stat%detector_list%vfield_list(size(state))) - - phaseloop: do phase = 1, size(state) - material_phase_name = trim(state(phase)%name) - - ! count scalar fields to include in detectors - field_count = 0 - do i = 1, size(state(phase)%scalar_names) - sfield => extract_scalar_field(state(phase), state(phase)%scalar_names(i)) - - if (detector_field(sfield)) field_count = field_count + 1 - end do - - allocate(default_stat%detector_list%sfield_list(phase)%ptr(field_count)) - default_stat%detector_list%num_sfields = default_stat%detector_list%num_sfields + field_count - - ! store scalar field names - field_count = 1 - do i = 1, size(state(phase)%scalar_names) - sfield => extract_scalar_field(state(phase), state(phase)%scalar_names(i)) - - if (detector_field(sfield)) then - default_stat%detector_list%sfield_list(phase)%ptr(field_count) = state(phase)%scalar_names(i) - field_count = field_count + 1 - end if - end do + allocate(default_stat%detector_list%vfield_list(phase)%ptr(field_count)) + default_stat%detector_list%num_vfields = default_stat%detector_list%num_vfields + field_count - ! same process for vector fields - field_count = 0 - do i = 1, size(state(phase)%vector_names) - vfield => extract_vector_field(state(phase), state(phase)%vector_names(i)) + ! store vector field names + field_count = 1 + do i = 1, size(state(phase)%vector_names) + vfield => extract_vector_field(state(phase), state(phase)%vector_names(i)) - if (detector_field(vfield)) field_count = field_count + 1 - end do + if (detector_field(vfield)) then + default_stat%detector_list%vfield_list(phase)%ptr(field_count) = state(phase)%vector_names(i) + field_count = field_count + 1 + end if + end do + end do phaseloop - allocate(default_stat%detector_list%vfield_list(phase)%ptr(field_count)) - default_stat%detector_list%num_vfields = default_stat%detector_list%num_vfields + field_count + ! output unit for detectors + default_stat%detector_list%h5_id = h5_openfile(trim(filename) // '.detectors.h5part', & + H5_O_WRONLY, H5_PROP_DEFAULT) - ! store vector field names - field_count = 1 - do i = 1, size(state(phase)%vector_names) - vfield => extract_vector_field(state(phase), state(phase)%vector_names(i)) + ! write a mapping between detector names and detector ids as a file attribute + k = 1 + do i = 1, total_dete_groups + group_size = default_stat%number_det_in_each_group(i) - if (detector_field(vfield)) then - default_stat%detector_list%vfield_list(phase)%ptr(field_count) = state(phase)%vector_names(i) - field_count = field_count + 1 - end if - end do - end do phaseloop - - ! output unit for detectors - default_stat%detector_list%h5_id = h5_openfile(trim(filename) // '.detectors.h5part', & - H5_O_WRONLY, H5_PROP_DEFAULT) - - ! write a mapping between detector names and detector ids as a file attribute - k = 1 - do i = 1, total_dete_groups - group_size = default_stat%number_det_in_each_group(i) - - ! write the _ids attribute - ! construct the list of ids in the same way as they - ! are initialised above - h5_ierror = h5_writefileattrib_i4(default_stat%detector_list%h5_id, & + ! write the _ids attribute + ! construct the list of ids in the same way as they + ! are initialised above + h5_ierror = h5_writefileattrib_i4(default_stat%detector_list%h5_id, & trim(default_stat%detector_group_names(i)) // "%ids", & [(j, j=k, k+group_size-1)], int(group_size, 8)) - if (h5_ierror /= 0) print *, "Error writing file attributes" + if (h5_ierror /= 0) print *, "Error writing file attributes" - k = k + group_size - end do + k = k + group_size + end do - ! And finally some sanity checks - totaldet_global=default_stat%detector_list%length - call allsum(totaldet_global) - ewrite(2,*) "Found", default_stat%detector_list%length, "local and ", totaldet_global, "global detectors" + ! And finally some sanity checks + totaldet_global=default_stat%detector_list%length + call allsum(totaldet_global) + ewrite(2,*) "Found", default_stat%detector_list%length, "local and ", totaldet_global, "global detectors" - assert(totaldet_global==default_stat%detector_list%total_num_det) + assert(totaldet_global==default_stat%detector_list%total_num_det) - end subroutine initialise_detectors + end subroutine initialise_detectors - function field_tag(name, column, statistic, material_phase_name, components) - !!< Create a field tag for the given entries. - character(len=*), intent(in) :: name - integer, intent(in) :: column - character(len=*), intent(in) :: statistic - character(len=*), intent(in), optional :: material_phase_name - integer, intent(in), optional :: components - character(len=254) :: field_tag + function field_tag(name, column, statistic, material_phase_name, components) + !!< Create a field tag for the given entries. + character(len=*), intent(in) :: name + integer, intent(in) :: column + character(len=*), intent(in) :: statistic + character(len=*), intent(in), optional :: material_phase_name + integer, intent(in), optional :: components + character(len=254) :: field_tag - character(len=254) :: front_buffer, material_buffer, components_buffer, end_buffer + character(len=254) :: front_buffer, material_buffer, components_buffer, end_buffer - write(front_buffer,'(a,i0,a)') '' - - end function constant_tag - - subroutine write_diagnostics(state, time, dt, timestep) - !!< Write the diagnostics to the previously opened diagnostics file. - - use particles, only: particle_lists - type(state_type), dimension(:), intent(inout) :: state - real, intent(in) :: time, dt - integer, intent(in) :: timestep - - character(len = 2 + real_format_len(padding = 1) + 1) :: format, format2, format3, format4 - character(len = OPTION_PATH_LEN) :: func, option_path - character(len = OPTION_PATH_LEN) :: group_name - integer :: i, j, k, phase, stat - integer, dimension(2) :: shape_option - integer :: nodes, elements, surface_elements - integer :: no_mixing_bins - integer, dimension(:), allocatable :: particle_arrays, subgroup_tot - integer :: particle_groups, group_sum - real :: fmin, fmax, fnorm2, fintegral, fnorm2_cv, fintegral_cv, surface_integral - real, dimension(:), allocatable :: f_mix_fraction - real, dimension(:), pointer :: mixing_bin_bounds - real :: current_time - type(mesh_type), pointer :: mesh - type(scalar_field) :: vfield_comp, tfield_comp - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - type(vector_field) :: xfield - type(scalar_field), pointer :: cv_mass => null() - type(registered_diagnostic_item), pointer :: iterator => NULL() - - ewrite(1,*) 'In write_diagnostics' - call profiler_tic("I/O") - - format="(" // real_format(padding = 1) // ")" - format2="(2" // real_format(padding = 1) // ")" - format3="(3" // real_format(padding = 1) // ")" - format4="(4" // real_format(padding = 1) // ")" - - ! Only the first process should write statistics information (but all must - ! be involved in calculating them) - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format), advance="no") time - write(default_stat%diag_unit, trim(format), advance="no") dt - write(default_stat%diag_unit, trim(format), advance="no") elapsed_walltime() - end if - - do i = 1, size(default_stat%mesh_list) - ! Output statistics for each mesh - mesh => extract_mesh(state(1), default_stat%mesh_list(i), stat=stat) - if (stat/=0) then - ! with extrude then adapt, the horizontal mesh may disappear! - nodes=0; elements=0; surface_elements=0 else - call mesh_stats(mesh, nodes, elements, surface_elements) + material_buffer = '' + end if + + if (present(components)) then + write(components_buffer,'(a,i0,a)') ' components="', components, '"' + else + components_buffer = '' end if + end_buffer = '/>' + + field_tag = trim(front_buffer)//trim(material_buffer)//trim(components_buffer)//trim(end_buffer) + + end function field_tag + + function constant_tag(name, type, value) + !!< Create a field tag for the given entries. + character(len=*), intent(in) :: name, type, value + + character(len=254) :: constant_tag + + constant_tag='' + + end function constant_tag + + subroutine write_diagnostics(state, time, dt, timestep) + !!< Write the diagnostics to the previously opened diagnostics file. + + use particles, only: particle_lists + type(state_type), dimension(:), intent(inout) :: state + real, intent(in) :: time, dt + integer, intent(in) :: timestep + + character(len = 2 + real_format_len(padding = 1) + 1) :: format, format2, format3, format4 + character(len = OPTION_PATH_LEN) :: func, option_path + character(len = OPTION_PATH_LEN) :: group_name + integer :: i, j, k, phase, stat + integer, dimension(2) :: shape_option + integer :: nodes, elements, surface_elements + integer :: no_mixing_bins + integer, dimension(:), allocatable :: particle_arrays, subgroup_tot + integer :: particle_groups, group_sum + real :: fmin, fmax, fnorm2, fintegral, fnorm2_cv, fintegral_cv, surface_integral + real, dimension(:), allocatable :: f_mix_fraction + real, dimension(:), pointer :: mixing_bin_bounds + real :: current_time + type(mesh_type), pointer :: mesh + type(scalar_field) :: vfield_comp, tfield_comp + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + type(vector_field) :: xfield + type(scalar_field), pointer :: cv_mass => null() + type(registered_diagnostic_item), pointer :: iterator => NULL() + + ewrite(1,*) 'In write_diagnostics' + call profiler_tic("I/O") + + format="(" // real_format(padding = 1) // ")" + format2="(2" // real_format(padding = 1) // ")" + format3="(3" // real_format(padding = 1) // ")" + format4="(4" // real_format(padding = 1) // ")" + + ! Only the first process should write statistics information (but all must + ! be involved in calculating them) if(getprocno() == 1) then - write(default_stat%diag_unit, "(a,i0,a,i0,a,i0)", advance = "no") " ", nodes, " ", elements, " ", surface_elements + write(default_stat%diag_unit, trim(format), advance="no") time + write(default_stat%diag_unit, trim(format), advance="no") dt + write(default_stat%diag_unit, trim(format), advance="no") elapsed_walltime() end if - end do + + do i = 1, size(default_stat%mesh_list) + ! Output statistics for each mesh + mesh => extract_mesh(state(1), default_stat%mesh_list(i), stat=stat) + if (stat/=0) then + ! with extrude then adapt, the horizontal mesh may disappear! + nodes=0; elements=0; surface_elements=0 + else + call mesh_stats(mesh, nodes, elements, surface_elements) + end if + + if(getprocno() == 1) then + write(default_stat%diag_unit, "(a,i0,a,i0,a,i0)", advance = "no") " ", nodes, " ", elements, " ", surface_elements + end if + end do #ifdef HAVE_MEMORY_STATS - ! Memory statistics. - call write_memory_stats(default_stat%diag_unit, format) - call reset_memory_logs + ! Memory statistics. + call write_memory_stats(default_stat%diag_unit, format) + call reset_memory_logs #endif - phaseloop: do phase=1,size(state) + phaseloop: do phase=1,size(state) + + scalar_field_loop: do i=1, size(default_stat%sfield_list(phase)%ptr) + ! Output statistics for each scalar field + sfield=>extract_scalar_field(state(phase), default_stat%sfield_list(phase)%ptr(i)) - scalar_field_loop: do i=1, size(default_stat%sfield_list(phase)%ptr) - ! Output statistics for each scalar field - sfield=>extract_scalar_field(state(phase), default_stat%sfield_list(phase)%ptr(i)) + xfield=get_diagnostic_coordinate_field(state(phase), sfield%mesh) - xfield=get_diagnostic_coordinate_field(state(phase), sfield%mesh) + ! Standard scalar field stats + if(stat_field(sfield, state(phase))) then - ! Standard scalar field stats - if(stat_field(sfield, state(phase))) then + call field_stats(sfield, Xfield, fmin, fmax, fnorm2, fintegral) + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format4), advance="no") fmin, fmax, fnorm2,& + & fintegral + end if - call field_stats(sfield, Xfield, fmin, fmax, fnorm2, fintegral) - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format4), advance="no") fmin, fmax, fnorm2,& - & fintegral end if - end if + ! Control volume stats + if(have_option(trim(complete_field_path(sfield%option_path,stat=stat)) //& + & "/stat/include_cv_stats")) then - ! Control volume stats - if(have_option(trim(complete_field_path(sfield%option_path,stat=stat)) //& - & "/stat/include_cv_stats")) then + ! Get the CV mass matrix + cv_mass => get_cv_mass(state(phase), sfield%mesh) - ! Get the CV mass matrix - cv_mass => get_cv_mass(state(phase), sfield%mesh) + call field_cv_stats(sfield, cv_mass, fnorm2_cv, fintegral_cv) - call field_cv_stats(sfield, cv_mass, fnorm2_cv, fintegral_cv) + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format2), advance="no") fnorm2_cv, fintegral_cv + end if - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format2), advance="no") fnorm2_cv, fintegral_cv end if - end if - - ! Mixing stats - do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat=stat)) // "/stat/include_mixing_stats") - 1 - if(have_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant")) then + ! Mixing stats + do j = 0, option_count(trim(complete_field_path(sfield%option_path, stat=stat)) // "/stat/include_mixing_stats") - 1 + if(have_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant")) then shape_option=option_shape(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant") + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/constant") ewrite(1,*) 'shape_option = ', shape_option no_mixing_bins = shape_option(1) - else if(have_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python")) then - call get_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python", func) - call get_option("/timestepping/current_time", current_time) - call real_vector_from_python(func, current_time, mixing_bin_bounds) - no_mixing_bins = size(mixing_bin_bounds) - deallocate(mixing_bin_bounds) - else - FLExit("Unable to determine mixing bin bounds type. Check options under include_mixing_stats") - end if - - allocate(f_mix_fraction(1:no_mixing_bins)) - f_mix_fraction = 0.0 - - call mixing_stats(f_mix_fraction, sfield, Xfield, mixing_stats_count = j) + else if(have_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python")) then + call get_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(j) // "]/mixing_bin_bounds/python", func) + call get_option("/timestepping/current_time", current_time) + call real_vector_from_python(func, current_time, mixing_bin_bounds) + no_mixing_bins = size(mixing_bin_bounds) + deallocate(mixing_bin_bounds) + else + FLExit("Unable to determine mixing bin bounds type. Check options under include_mixing_stats") + end if - if(getprocno() == 1) then - do k=1, (size(f_mix_fraction)) - write(default_stat%diag_unit, trim(format), advance="no") f_mix_fraction(k) - end do - end if + allocate(f_mix_fraction(1:no_mixing_bins)) + f_mix_fraction = 0.0 - deallocate(f_mix_fraction) + call mixing_stats(f_mix_fraction, sfield, Xfield, mixing_stats_count = j) - end do + if(getprocno() == 1) then + do k=1, (size(f_mix_fraction)) + write(default_stat%diag_unit, trim(format), advance="no") f_mix_fraction(k) + end do + end if - ! Surface integrals - option_path = trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_integral" - do j = 0, option_count(option_path) - 1 - surface_integral = calculate_surface_integral(sfield, xfield, trim(option_path)//"["//int2str(j)//"]") - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format), advance = "no") surface_integral - end if - end do + deallocate(f_mix_fraction) - ! Surface l2norms - option_path = trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_l2norm" - do j = 0, option_count(option_path) - 1 - surface_integral = calculate_surface_l2norm(sfield, xfield, trim(option_path)//"["//int2str(j)//"]") - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format), advance = "no") surface_integral - end if - end do + end do - call deallocate(xfield) + ! Surface integrals + option_path = trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_integral" + do j = 0, option_count(option_path) - 1 + surface_integral = calculate_surface_integral(sfield, xfield, trim(option_path)//"["//int2str(j)//"]") + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format), advance = "no") surface_integral + end if + end do - end do scalar_field_loop + ! Surface l2norms + option_path = trim(complete_field_path(sfield%option_path, stat = stat)) // "/stat/surface_l2norm" + do j = 0, option_count(option_path) - 1 + surface_integral = calculate_surface_l2norm(sfield, xfield, trim(option_path)//"["//int2str(j)//"]") + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format), advance = "no") surface_integral + end if + end do - vector_field_loop: do i = 1, size(default_stat%vfield_list(phase)%ptr) - ! Output statistics for each vector field - vfield => extract_vector_field(state(phase), & - & default_stat%vfield_list(phase)%ptr(i)) + call deallocate(xfield) - xfield=get_diagnostic_coordinate_field(state(phase), vfield%mesh) + end do scalar_field_loop - ! Standard scalar field stats for vector field magnitude - if(stat_field(vfield,state(phase))) then - call field_stats(vfield, Xfield, fmin, fmax, fnorm2) - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format3), advance = "no") fmin, fmax, fnorm2 - end if - end if + vector_field_loop: do i = 1, size(default_stat%vfield_list(phase)%ptr) + ! Output statistics for each vector field + vfield => extract_vector_field(state(phase), & + & default_stat%vfield_list(phase)%ptr(i)) - ! Standard scalar field stats for vector field components - if(stat_field(vfield, state(phase), test_for_components = .true.)) then - do j = 1, vfield%dim - vfield_comp = extract_scalar_field(vfield, j) - - call field_stats(vfield_comp, Xfield, fmin, fmax, fnorm2, & - & fintegral) - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format4), advance = "no") fmin, fmax, fnorm2, & - & fintegral - end if - end do - end if + xfield=get_diagnostic_coordinate_field(state(phase), vfield%mesh) - ! Surface integrals - option_path = trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_integral" - do j = 0, option_count(option_path) - 1 - surface_integral = calculate_surface_integral(vfield, xfield, trim(option_path)//"["//int2str(j)//"]") - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format), advance = "no") surface_integral - end if - end do + ! Standard scalar field stats for vector field magnitude + if(stat_field(vfield,state(phase))) then + call field_stats(vfield, Xfield, fmin, fmax, fnorm2) + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format3), advance = "no") fmin, fmax, fnorm2 + end if + end if - ! Surface l2norms - option_path = trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_l2norm" - do j = 0, option_count(option_path) - 1 - surface_integral = calculate_surface_l2norm(vfield, xfield, trim(option_path)//"["//int2str(j)//"]") - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format), advance = "no") surface_integral - end if - end do + ! Standard scalar field stats for vector field components + if(stat_field(vfield, state(phase), test_for_components = .true.)) then + do j = 1, vfield%dim + vfield_comp = extract_scalar_field(vfield, j) + + call field_stats(vfield_comp, Xfield, fmin, fmax, fnorm2, & + & fintegral) + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format4), advance = "no") fmin, fmax, fnorm2, & + & fintegral + end if + end do + end if - ! drag calculation - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces")) then - call write_body_forces(state(phase), vfield) - end if + ! Surface integrals + option_path = trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_integral" + do j = 0, option_count(option_path) - 1 + surface_integral = calculate_surface_integral(vfield, xfield, trim(option_path)//"["//int2str(j)//"]") + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format), advance = "no") surface_integral + end if + end do - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/divergence_stats")) then - call divergence_field_stats(vfield, Xfield, fmin, fmax, fnorm2, fintegral) - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format4), advance="no") fmin, fmax, fnorm2,& - & fintegral - end if - end if + ! Surface l2norms + option_path = trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/surface_l2norm" + do j = 0, option_count(option_path) - 1 + surface_integral = calculate_surface_l2norm(vfield, xfield, trim(option_path)//"["//int2str(j)//"]") + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format), advance = "no") surface_integral + end if + end do - ! momentum conservation error calculation - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/calculate_momentum_conservation_error")) then - call write_momentum_conservation_error(state(phase), vfield) - end if + ! drag calculation + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces")) then + call write_body_forces(state(phase), vfield) + end if - call deallocate(xfield) + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/divergence_stats")) then + call divergence_field_stats(vfield, Xfield, fmin, fmax, fnorm2, fintegral) + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format4), advance="no") fmin, fmax, fnorm2,& + & fintegral + end if + end if - end do vector_field_loop + ! momentum conservation error calculation + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/calculate_momentum_conservation_error")) then + call write_momentum_conservation_error(state(phase), vfield) + end if - tensor_field_loop: do i = 1, size(default_stat%tfield_list(phase)%ptr) - ! Output statistics for each tensor field - tfield => extract_tensor_field(state(phase), & - & default_stat%tfield_list(phase)%ptr(i)) + call deallocate(xfield) - xfield=get_diagnostic_coordinate_field(state(phase), tfield%mesh) + end do vector_field_loop - ! Standard scalar field stats for tensor field magnitude - if(stat_field(tfield,state(phase))) then - call field_stats(tfield, Xfield, fmin, fmax, fnorm2) - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format3), advance = "no") fmin, fmax, fnorm2 - end if - end if + tensor_field_loop: do i = 1, size(default_stat%tfield_list(phase)%ptr) + ! Output statistics for each tensor field + tfield => extract_tensor_field(state(phase), & + & default_stat%tfield_list(phase)%ptr(i)) - ! Standard scalar field stats for tensor field components - if(stat_field(tfield, state(phase), test_for_components = .true.)) then - do j = 1, tfield%dim(1) - do k = 1, tfield%dim(2) - tfield_comp = extract_scalar_field(tfield, j, k) + xfield=get_diagnostic_coordinate_field(state(phase), tfield%mesh) - call field_stats(tfield_comp, Xfield, fmin, fmax, fnorm2, & - & fintegral) + ! Standard scalar field stats for tensor field magnitude + if(stat_field(tfield,state(phase))) then + call field_stats(tfield, Xfield, fmin, fmax, fnorm2) ! Only the first process should write statistics information if(getprocno() == 1) then - write(default_stat%diag_unit, trim(format4), advance = "no") fmin, fmax, fnorm2, & - & fintegral + write(default_stat%diag_unit, trim(format3), advance = "no") fmin, fmax, fnorm2 end if - end do - end do - end if + end if + + ! Standard scalar field stats for tensor field components + if(stat_field(tfield, state(phase), test_for_components = .true.)) then + do j = 1, tfield%dim(1) + do k = 1, tfield%dim(2) + tfield_comp = extract_scalar_field(tfield, j, k) + + call field_stats(tfield_comp, Xfield, fmin, fmax, fnorm2, & + & fintegral) + ! Only the first process should write statistics information + if(getprocno() == 1) then + write(default_stat%diag_unit, trim(format4), advance = "no") fmin, fmax, fnorm2, & + & fintegral + end if + end do + end do + end if - call deallocate(xfield) + call deallocate(xfield) - end do tensor_field_loop + end do tensor_field_loop - end do phaseloop + end do phaseloop + + ! Registered diagnostics + call print_registered_diagnostics + iterator => default_stat%registered_diagnostic_first + do while (associated(iterator)) + ! Only the first process should write statistics information + if(getprocno() == 1) then + do k=1, iterator%dim + write(default_stat%diag_unit, trim(format), advance = "no") iterator%value(k) + end do + end if + iterator => iterator%next + end do - ! Registered diagnostics - call print_registered_diagnostics - iterator => default_stat%registered_diagnostic_first - do while (associated(iterator)) + ! Write output for the total number of particles in the simulation (per particle group and subgroup). + if(getprocno() == 1) then + particle_groups = option_count("/particles/particle_group") + if (particle_groups/=0) then + do i = 1,particle_groups + group_sum = 0 + call get_option("/particles/particle_group["//int2str(i-1)//"]/name", group_name) + call get_particle_arrays(group_name,particle_arrays) + allocate(subgroup_tot(size(particle_arrays))) + do j = 1, size(particle_arrays) + subgroup_tot(j) = particle_lists(particle_arrays(j))%total_num_det + group_sum = group_sum + subgroup_tot(j) + end do + write(default_stat%diag_unit, trim(format), advance = "no") group_sum*1.0 + do j = 1,size(particle_arrays) + write(default_stat%diag_unit, trim(format), advance = "no") subgroup_tot(j)*1.0 + end do + deallocate(subgroup_tot) + deallocate(particle_arrays) + end do + end if + end if + + ! Output end of line ! Only the first process should write statistics information if(getprocno() == 1) then - do k=1, iterator%dim - write(default_stat%diag_unit, trim(format), advance = "no") iterator%value(k) - end do + write(default_stat%diag_unit,'(a)') "" + flush(default_stat%diag_unit) end if - iterator => iterator%next - end do - - ! Write output for the total number of particles in the simulation (per particle group and subgroup). - if(getprocno() == 1) then - particle_groups = option_count("/particles/particle_group") - if (particle_groups/=0) then - do i = 1,particle_groups - group_sum = 0 - call get_option("/particles/particle_group["//int2str(i-1)//"]/name", group_name) - call get_particle_arrays(group_name,particle_arrays) - allocate(subgroup_tot(size(particle_arrays))) - do j = 1, size(particle_arrays) - subgroup_tot(j) = particle_lists(particle_arrays(j))%total_num_det - group_sum = group_sum + subgroup_tot(j) - end do - write(default_stat%diag_unit, trim(format), advance = "no") group_sum*1.0 - do j = 1,size(particle_arrays) - write(default_stat%diag_unit, trim(format), advance = "no") subgroup_tot(j)*1.0 - end do - deallocate(subgroup_tot) - deallocate(particle_arrays) - end do - end if - end if - - ! Output end of line - ! Only the first process should write statistics information - if(getprocno() == 1) then - write(default_stat%diag_unit,'(a)') "" - flush(default_stat%diag_unit) - end if - - ! Now output any detectors. - call write_detectors(state, default_stat%detector_list, time, dt) - - call profiler_toc("I/O") - - contains - - subroutine write_body_forces(state, vfield) - type(state_type), intent(in) :: state - type(vector_field), intent(in) :: vfield - type(tensor_field), pointer :: viscosity - - logical :: have_viscosity - integer :: i, s - real :: force(vfield%dim), pressure_force(vfield%dim), viscous_force(vfield%dim) - character(len = FIELD_NAME_LEN) :: surface_integral_name - - viscosity=>extract_tensor_field(state, "Viscosity", stat) - have_viscosity = stat == 0 - - do s = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/compute_body_forces_on_surfaces") - 1 - call get_option(trim(complete_field_path(vfield%option_path))//"/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/name", surface_integral_name) - - if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/output_terms")) then - if(have_viscosity) then - ! calculate the forces on the surface - call diagnostic_body_drag(state, force, surface_integral_name, pressure_force = pressure_force, viscous_force = viscous_force) - else - call diagnostic_body_drag(state, force, surface_integral_name, pressure_force = pressure_force) - end if - if(getprocno() == 1) then - do i=1, mesh_dim(vfield%mesh) - write(default_stat%diag_unit, trim(format), advance="no") force(i) - end do - do i=1, mesh_dim(vfield%mesh) - write(default_stat%diag_unit, trim(format), advance="no") pressure_force(i) - end do - if(have_viscosity) then - do i=1, mesh_dim(vfield%mesh) - write(default_stat%diag_unit, trim(format), advance="no") viscous_force(i) - end do - end if - end if - else - ! calculate the forces on the surface - call diagnostic_body_drag(state, force, surface_integral_name) - if(getprocno() == 1) then - do i=1, mesh_dim(vfield%mesh) - write(default_stat%diag_unit, trim(format), advance="no") force(i) - end do - end if - end if - end do - end subroutine write_body_forces + ! Now output any detectors. + call write_detectors(state, default_stat%detector_list, time, dt) - subroutine write_momentum_conservation_error(state, v_field) - type(state_type), intent(in) :: state - type(vector_field), intent(inout) :: v_field + call profiler_toc("I/O") - type(vector_field), pointer :: velocity, old_velocity - type(vector_field), pointer :: new_positions, nl_positions, old_positions - type(scalar_field), pointer :: old_pressure, new_pressure - type(scalar_field) :: nl_pressure, vel_comp - real :: theta, dt - integer :: sele, dim + contains - real, dimension(v_field%dim) :: momentum_cons, velocity_int, old_velocity_int, pressure_surface_int + subroutine write_body_forces(state, vfield) + type(state_type), intent(in) :: state + type(vector_field), intent(in) :: vfield + type(tensor_field), pointer :: viscosity - velocity => extract_vector_field(state, "Velocity") - old_velocity => extract_vector_field(state, "OldVelocity") + logical :: have_viscosity + integer :: i, s + real :: force(vfield%dim), pressure_force(vfield%dim), viscous_force(vfield%dim) + character(len = FIELD_NAME_LEN) :: surface_integral_name - new_positions => extract_vector_field(state, "IteratedCoordinate") - nl_positions => extract_vector_field(state, "Coordinate") - old_positions => extract_vector_field(state, "OldCoordinate") + viscosity=>extract_tensor_field(state, "Viscosity", stat) + have_viscosity = stat == 0 - new_pressure => extract_scalar_field(state, "Pressure") - old_pressure => extract_scalar_field(state, "OldPressure") + do s = 0, option_count(trim(complete_field_path(vfield%option_path, stat = stat)) // "/stat/compute_body_forces_on_surfaces") - 1 + call get_option(trim(complete_field_path(vfield%option_path))//"/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/name", surface_integral_name) - call get_option("/timestepping/timestep", dt) - call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/theta", theta) + if(have_option(trim(complete_field_path(vfield%option_path, stat=stat)) // "/stat/compute_body_forces_on_surfaces[" // int2str(s) // "]/output_terms")) then + if(have_viscosity) then + ! calculate the forces on the surface + call diagnostic_body_drag(state, force, surface_integral_name, pressure_force = pressure_force, viscous_force = viscous_force) + else + call diagnostic_body_drag(state, force, surface_integral_name, pressure_force = pressure_force) + end if + if(getprocno() == 1) then + do i=1, mesh_dim(vfield%mesh) + write(default_stat%diag_unit, trim(format), advance="no") force(i) + end do + do i=1, mesh_dim(vfield%mesh) + write(default_stat%diag_unit, trim(format), advance="no") pressure_force(i) + end do + if(have_viscosity) then + do i=1, mesh_dim(vfield%mesh) + write(default_stat%diag_unit, trim(format), advance="no") viscous_force(i) + end do + end if + end if + else + ! calculate the forces on the surface + call diagnostic_body_drag(state, force, surface_integral_name) + if(getprocno() == 1) then + do i=1, mesh_dim(vfield%mesh) + write(default_stat%diag_unit, trim(format), advance="no") force(i) + end do + end if + end if + end do - call allocate(nl_pressure, new_pressure%mesh, "NonlinearPressure") - call set(nl_pressure, new_pressure, old_pressure, theta) + end subroutine write_body_forces - do dim = 1, velocity%dim - vel_comp = extract_scalar_field(velocity, dim) - call field_stats(vel_comp, new_positions, velocity_int(dim)) + subroutine write_momentum_conservation_error(state, v_field) + type(state_type), intent(in) :: state + type(vector_field), intent(inout) :: v_field - vel_comp = extract_scalar_field(old_velocity, dim) - call field_stats(vel_comp, old_positions, old_velocity_int(dim)) - end do + type(vector_field), pointer :: velocity, old_velocity + type(vector_field), pointer :: new_positions, nl_positions, old_positions + type(scalar_field), pointer :: old_pressure, new_pressure + type(scalar_field) :: nl_pressure, vel_comp + real :: theta, dt + integer :: sele, dim - ! pressure surface integral - pressure_surface_int = 0.0 - do sele = 1, surface_element_count(v_field) + real, dimension(v_field%dim) :: momentum_cons, velocity_int, old_velocity_int, pressure_surface_int - pressure_surface_int = pressure_surface_int + pressure_surface_integral_face(sele, nl_pressure, nl_positions) + velocity => extract_vector_field(state, "Velocity") + old_velocity => extract_vector_field(state, "OldVelocity") - end do + new_positions => extract_vector_field(state, "IteratedCoordinate") + nl_positions => extract_vector_field(state, "Coordinate") + old_positions => extract_vector_field(state, "OldCoordinate") - ewrite(2,*) 'velocity_int = ', velocity_int - ewrite(2,*) 'old_velocity_int = ', old_velocity_int - ewrite(2,*) '(velocity_int-old_velocity_int)/dt = ', (velocity_int-old_velocity_int)/dt - ewrite(2,*) 'pressure_surface_int = ', pressure_surface_int + new_pressure => extract_scalar_field(state, "Pressure") + old_pressure => extract_scalar_field(state, "OldPressure") - momentum_cons = (velocity_int-old_velocity_int)/dt - pressure_surface_int + call get_option("/timestepping/timestep", dt) + call get_option(trim(velocity%option_path)//"/prognostic/temporal_discretisation/theta", theta) - if(getprocno() == 1) then - do dim=1, velocity%dim - write(default_stat%diag_unit, trim(format), advance="no") momentum_cons(dim) - end do - end if + call allocate(nl_pressure, new_pressure%mesh, "NonlinearPressure") + call set(nl_pressure, new_pressure, old_pressure, theta) - call deallocate(nl_pressure) + do dim = 1, velocity%dim + vel_comp = extract_scalar_field(velocity, dim) + call field_stats(vel_comp, new_positions, velocity_int(dim)) - end subroutine write_momentum_conservation_error + vel_comp = extract_scalar_field(old_velocity, dim) + call field_stats(vel_comp, old_positions, old_velocity_int(dim)) + end do - function pressure_surface_integral_face(sele, nl_pressure, nl_positions) result(pn) + ! pressure surface integral + pressure_surface_int = 0.0 + do sele = 1, surface_element_count(v_field) - integer :: sele - type(scalar_field) :: nl_pressure - type(vector_field) :: nl_positions - real, dimension(mesh_dim(nl_pressure)) :: pn + pressure_surface_int = pressure_surface_int + pressure_surface_integral_face(sele, nl_pressure, nl_positions) - real, dimension(mesh_dim(nl_pressure), face_ngi(nl_pressure, sele)) :: normal - real, dimension(face_ngi(nl_pressure, sele)) :: detwei + end do - integer :: dim + ewrite(2,*) 'velocity_int = ', velocity_int + ewrite(2,*) 'old_velocity_int = ', old_velocity_int + ewrite(2,*) '(velocity_int-old_velocity_int)/dt = ', (velocity_int-old_velocity_int)/dt + ewrite(2,*) 'pressure_surface_int = ', pressure_surface_int - call transform_facet_to_physical( & - nl_positions, sele, detwei_f = detwei, normal = normal) + momentum_cons = (velocity_int-old_velocity_int)/dt - pressure_surface_int - do dim = 1, size(normal, 1) + if(getprocno() == 1) then + do dim=1, velocity%dim + write(default_stat%diag_unit, trim(format), advance="no") momentum_cons(dim) + end do + end if - pn(dim) = dot_product(face_val_at_quad(nl_pressure, sele), detwei*normal(dim, :)) + call deallocate(nl_pressure) - end do + end subroutine write_momentum_conservation_error - end function pressure_surface_integral_face + function pressure_surface_integral_face(sele, nl_pressure, nl_positions) result(pn) - end subroutine write_diagnostics + integer :: sele + type(scalar_field) :: nl_pressure + type(vector_field) :: nl_positions + real, dimension(mesh_dim(nl_pressure)) :: pn - subroutine test_and_write_convergence(state, time, dt, it, maxerror) - !!< Test and write the diagnostics to the previously opened convergence file. + real, dimension(mesh_dim(nl_pressure), face_ngi(nl_pressure, sele)) :: normal + real, dimension(face_ngi(nl_pressure, sele)) :: detwei - type(state_type), dimension(:), intent(inout) :: state - real, intent(in) :: time, dt - integer, intent(in) :: it - real, intent(out) :: maxerror + integer :: dim - character(len=10) :: format, iformat - integer :: i, j, phase - real :: error - type(scalar_field) :: vfield_comp, nlvfield_comp - type(scalar_field), pointer :: sfield, nlsfield - type(vector_field), pointer :: vfield, nlvfield + call transform_facet_to_physical( & + nl_positions, sele, detwei_f = detwei, normal = normal) - type(vector_field), pointer :: coordinates - integer :: convergence_norm + do dim = 1, size(normal, 1) - maxerror = 0.0 + pn(dim) = dot_product(face_val_at_quad(nl_pressure, sele), detwei*normal(dim, :)) - format='(e15.6e3)' - iformat='(i4)' + end do - if(default_stat%write_convergence_file) then - ! Only the first process should write convergence information - if(getprocno() == 1) then - write(default_stat%conv_unit, format, advance="no") time - write(default_stat%conv_unit, format, advance="no") dt - write(default_stat%conv_unit, iformat, advance="no") it - end if - end if + end function pressure_surface_integral_face - coordinates => extract_vector_field(state(1), "Coordinate") - convergence_norm = convergence_norm_integer("/timestepping/nonlinear_iterations/tolerance") + end subroutine write_diagnostics - phaseloop: do phase=1,size(state) + subroutine test_and_write_convergence(state, time, dt, it, maxerror) + !!< Test and write the diagnostics to the previously opened convergence file. - do i=1, size(default_stat%sfield_list(phase)%ptr) - ! Output convergence information for each scalar field. - sfield=>extract_scalar_field(state(phase), & - & default_stat%sfield_list(phase)%ptr(i)) + type(state_type), dimension(:), intent(inout) :: state + real, intent(in) :: time, dt + integer, intent(in) :: it + real, intent(out) :: maxerror - if(.not. convergence_field(sfield)) then - cycle - end if + character(len=10) :: format, iformat + integer :: i, j, phase + real :: error + type(scalar_field) :: vfield_comp, nlvfield_comp + type(scalar_field), pointer :: sfield, nlsfield + type(vector_field), pointer :: vfield, nlvfield - nlsfield=>extract_scalar_field(state(phase), & - "Iterated"//trim(default_stat%sfield_list(phase)%ptr(i))) + type(vector_field), pointer :: coordinates + integer :: convergence_norm - call field_con_stats(sfield, nlsfield, error, & - convergence_norm, coordinates) - maxerror = max(maxerror, error) + maxerror = 0.0 - if(default_stat%write_convergence_file) then - ! Only the first process should write convergence information - if(getprocno() == 1) then - write(default_stat%conv_unit, format, advance="no") error - end if - end if + format='(e15.6e3)' + iformat='(i4)' - end do + if(default_stat%write_convergence_file) then + ! Only the first process should write convergence information + if(getprocno() == 1) then + write(default_stat%conv_unit, format, advance="no") time + write(default_stat%conv_unit, format, advance="no") dt + write(default_stat%conv_unit, iformat, advance="no") it + end if + end if - do i = 1, size(default_stat%vfield_list(phase)%ptr) - ! Output convergence information for each vector field + coordinates => extract_vector_field(state(1), "Coordinate") + convergence_norm = convergence_norm_integer("/timestepping/nonlinear_iterations/tolerance") - vfield => extract_vector_field(state(phase), & - & default_stat%vfield_list(phase)%ptr(i)) + phaseloop: do phase=1,size(state) - if(.not. convergence_field(vfield)) then - cycle - end if + do i=1, size(default_stat%sfield_list(phase)%ptr) + ! Output convergence information for each scalar field. + sfield=>extract_scalar_field(state(phase), & + & default_stat%sfield_list(phase)%ptr(i)) + + if(.not. convergence_field(sfield)) then + cycle + end if - nlvfield => extract_vector_field(state(phase), & - & "Iterated"//default_stat%vfield_list(phase)%ptr(i)) + nlsfield=>extract_scalar_field(state(phase), & + "Iterated"//trim(default_stat%sfield_list(phase)%ptr(i))) - call field_con_stats(vfield, nlvfield, error, & - convergence_norm, coordinates) - maxerror = max(maxerror, error) + call field_con_stats(sfield, nlsfield, error, & + convergence_norm, coordinates) + maxerror = max(maxerror, error) - if(default_stat%write_convergence_file) then - ! Only the first process should write convergence information - if(getprocno() == 1) then - write(default_stat%conv_unit, format, advance = "no") error + if(default_stat%write_convergence_file) then + ! Only the first process should write convergence information + if(getprocno() == 1) then + write(default_stat%conv_unit, format, advance="no") error + end if end if - end if - if(.not. convergence_field(vfield, test_for_components = .true.)) then - cycle - end if + end do + + do i = 1, size(default_stat%vfield_list(phase)%ptr) + ! Output convergence information for each vector field + + vfield => extract_vector_field(state(phase), & + & default_stat%vfield_list(phase)%ptr(i)) - do j = 1, vfield%dim - vfield_comp = extract_scalar_field(vfield, j) - nlvfield_comp = extract_scalar_field(nlvfield, j) + if(.not. convergence_field(vfield)) then + cycle + end if + + nlvfield => extract_vector_field(state(phase), & + & "Iterated"//default_stat%vfield_list(phase)%ptr(i)) - call field_con_stats(vfield_comp, nlvfield_comp, error, & - convergence_norm, coordinates) - maxerror = max(maxerror, error) + call field_con_stats(vfield, nlvfield, error, & + convergence_norm, coordinates) + maxerror = max(maxerror, error) - if(default_stat%write_convergence_file) then + if(default_stat%write_convergence_file) then ! Only the first process should write convergence information if(getprocno() == 1) then write(default_stat%conv_unit, format, advance = "no") error end if - end if + end if + + if(.not. convergence_field(vfield, test_for_components = .true.)) then + cycle + end if + + do j = 1, vfield%dim + vfield_comp = extract_scalar_field(vfield, j) + nlvfield_comp = extract_scalar_field(nlvfield, j) + + call field_con_stats(vfield_comp, nlvfield_comp, error, & + convergence_norm, coordinates) + maxerror = max(maxerror, error) + + if(default_stat%write_convergence_file) then + ! Only the first process should write convergence information + if(getprocno() == 1) then + write(default_stat%conv_unit, format, advance = "no") error + end if + end if + end do end do - end do - end do phaseloop + end do phaseloop - if(default_stat%write_convergence_file) then - ! Output end of line - ! Only the first process should write convergence information - if(getprocno() == 1) then - write(default_stat%conv_unit,'(a)') "" + if(default_stat%write_convergence_file) then + ! Output end of line + ! Only the first process should write convergence information + if(getprocno() == 1) then + write(default_stat%conv_unit,'(a)') "" + end if end if - end if - - if(have_option("/io/convergence/convergence_vtus")) then - call vtk_write_state_new_options(filename="convergence_test", index=it, state=state) - end if - end subroutine test_and_write_convergence + if(have_option("/io/convergence/convergence_vtus")) then + call vtk_write_state_new_options(filename="convergence_test", index=it, state=state) + end if - subroutine test_and_write_steady_state(state, maxchange) - !!< Test whether a steady state has been reached. + end subroutine test_and_write_convergence - type(state_type), dimension(:), intent(in) :: state - real, intent(out) :: maxchange + subroutine test_and_write_steady_state(state, maxchange) + !!< Test whether a steady state has been reached. - integer :: i, j, phase - real :: change, dt - type(scalar_field) :: vfield_comp, oldvfield_comp - type(scalar_field), pointer :: sfield, oldsfield - type(vector_field), pointer :: vfield, oldvfield + type(state_type), dimension(:), intent(in) :: state + real, intent(out) :: maxchange - logical :: acceleration + integer :: i, j, phase + real :: change, dt + type(scalar_field) :: vfield_comp, oldvfield_comp + type(scalar_field), pointer :: sfield, oldsfield + type(vector_field), pointer :: vfield, oldvfield - type(vector_field), pointer :: coordinates - integer :: convergence_norm + logical :: acceleration - character(len = *), parameter :: format = "(e15.6e3)" - integer :: procno - real :: elapsed_time + type(vector_field), pointer :: coordinates + integer :: convergence_norm - ewrite(1, *) "Entering test_and_write_steady_state" + character(len = *), parameter :: format = "(e15.6e3)" + integer :: procno + real :: elapsed_time - maxchange = 0.0 + ewrite(1, *) "Entering test_and_write_steady_state" - acceleration = have_option("/timestepping/steady_state/acceleration_form") - call get_option("/timestepping/timestep", dt) + maxchange = 0.0 - coordinates => extract_vector_field(state(1), "Coordinate") - convergence_norm = convergence_norm_integer("/timestepping/steady_state/tolerance") + acceleration = have_option("/timestepping/steady_state/acceleration_form") + call get_option("/timestepping/timestep", dt) - procno = getprocno() - if(default_stat%write_steady_state_file .and. procno == 1) then - call get_option("/timestepping/current_time", elapsed_time) - if(default_stat%binary_steady_state_output) then - write(default_stat%steady_state_unit) elapsed_time - write(default_stat%steady_state_unit) dt - else - write(default_stat%steady_state_unit, format, advance="no") elapsed_time - write(default_stat%steady_state_unit, format, advance="no") dt + coordinates => extract_vector_field(state(1), "Coordinate") + convergence_norm = convergence_norm_integer("/timestepping/steady_state/tolerance") + + procno = getprocno() + if(default_stat%write_steady_state_file .and. procno == 1) then + call get_option("/timestepping/current_time", elapsed_time) + if(default_stat%binary_steady_state_output) then + write(default_stat%steady_state_unit) elapsed_time + write(default_stat%steady_state_unit) dt + else + write(default_stat%steady_state_unit, format, advance="no") elapsed_time + write(default_stat%steady_state_unit, format, advance="no") dt + end if end if - end if - phaseloop: do phase=1,size(state) + phaseloop: do phase=1,size(state) - do i=1, size(default_stat%sfield_list(phase)%ptr) - ! Test steady state information for each scalar field. + do i=1, size(default_stat%sfield_list(phase)%ptr) + ! Test steady state information for each scalar field. - sfield=>extract_scalar_field(state(phase), i) - if(.not. steady_state_field(sfield)) cycle - ! Scalar fields + sfield=>extract_scalar_field(state(phase), i) + if(.not. steady_state_field(sfield)) cycle + ! Scalar fields - oldsfield=>extract_scalar_field(state(phase), & - "Old"//trim(default_stat%sfield_list(phase)%ptr(i))) + oldsfield=>extract_scalar_field(state(phase), & + "Old"//trim(default_stat%sfield_list(phase)%ptr(i))) - call field_con_stats(sfield, oldsfield, change, & - convergence_norm, coordinates) - if(acceleration) change = change/dt - ewrite(2, *) trim(state(phase)%name)//"::"//trim(sfield%name), change - maxchange = max(maxchange, change) + call field_con_stats(sfield, oldsfield, change, & + convergence_norm, coordinates) + if(acceleration) change = change/dt + ewrite(2, *) trim(state(phase)%name)//"::"//trim(sfield%name), change + maxchange = max(maxchange, change) - if(default_stat%write_steady_state_file .and. procno == 1) then - if(default_stat%binary_steady_state_output) then - write(default_stat%steady_state_unit) change - else - write(default_stat%steady_state_unit, format, advance = "no") change + if(default_stat%write_steady_state_file .and. procno == 1) then + if(default_stat%binary_steady_state_output) then + write(default_stat%steady_state_unit) change + else + write(default_stat%steady_state_unit, format, advance = "no") change + end if end if - end if - end do + end do - do i = 1, vector_field_count(state(phase)) - vfield => extract_vector_field(state(phase), i) - if(.not. steady_state_field(vfield)) cycle - ! Vector fields + do i = 1, vector_field_count(state(phase)) + vfield => extract_vector_field(state(phase), i) + if(.not. steady_state_field(vfield)) cycle + ! Vector fields - oldvfield => extract_vector_field(state(phase), & - & "Old"//default_stat%vfield_list(phase)%ptr(i)) + oldvfield => extract_vector_field(state(phase), & + & "Old"//default_stat%vfield_list(phase)%ptr(i)) - call field_con_stats(vfield, oldvfield, change, & - convergence_norm, coordinates) - if(acceleration) change = change/dt - ewrite(2, *) trim(state(phase)%name)//"::"//trim(vfield%name), change - maxchange = max(maxchange, change) + call field_con_stats(vfield, oldvfield, change, & + convergence_norm, coordinates) + if(acceleration) change = change/dt + ewrite(2, *) trim(state(phase)%name)//"::"//trim(vfield%name), change + maxchange = max(maxchange, change) - if(default_stat%write_steady_state_file .and. procno == 1) then - if(default_stat%binary_steady_state_output) then - write(default_stat%steady_state_unit) change - else - write(default_stat%steady_state_unit, format, advance = "no") change + if(default_stat%write_steady_state_file .and. procno == 1) then + if(default_stat%binary_steady_state_output) then + write(default_stat%steady_state_unit) change + else + write(default_stat%steady_state_unit, format, advance = "no") change + end if end if - end if - if(.not. steady_state_field(vfield, test_for_components = .true.)) cycle - ! Vector field components - - do j = 1, vfield%dim - vfield_comp = extract_scalar_field(vfield, j) - oldvfield_comp = extract_scalar_field(oldvfield, j) - - call field_con_stats(vfield_comp, oldvfield_comp, change, & - convergence_norm, coordinates) - if(acceleration) change = change/dt - ewrite(2, *) trim(state(phase)%name)//"::"//trim(vfield%name), j, change - maxchange = max(maxchange, change) - - if(default_stat%write_steady_state_file .and. procno == 1) then - if(default_stat%binary_steady_state_output) then - write(default_stat%steady_state_unit) change - else - write(default_stat%steady_state_unit, format, advance = "no") change - end if - end if + if(.not. steady_state_field(vfield, test_for_components = .true.)) cycle + ! Vector field components + + do j = 1, vfield%dim + vfield_comp = extract_scalar_field(vfield, j) + oldvfield_comp = extract_scalar_field(oldvfield, j) + + call field_con_stats(vfield_comp, oldvfield_comp, change, & + convergence_norm, coordinates) + if(acceleration) change = change/dt + ewrite(2, *) trim(state(phase)%name)//"::"//trim(vfield%name), j, change + maxchange = max(maxchange, change) + + if(default_stat%write_steady_state_file .and. procno == 1) then + if(default_stat%binary_steady_state_output) then + write(default_stat%steady_state_unit) change + else + write(default_stat%steady_state_unit, format, advance = "no") change + end if + end if + end do + end do - end do + end do phaseloop - end do phaseloop + ewrite(1, *) "maxchange = ", maxchange - ewrite(1, *) "maxchange = ", maxchange + if(default_stat%write_steady_state_file .and. procno == 1) then + if(default_stat%binary_steady_state_output) then + write(default_stat%steady_state_unit) maxchange + else + write(default_stat%steady_state_unit, format, advance = "no") maxchange + ! Output end of line + write(default_stat%steady_state_unit,'(a)') "" + end if - if(default_stat%write_steady_state_file .and. procno == 1) then - if(default_stat%binary_steady_state_output) then - write(default_stat%steady_state_unit) maxchange - else - write(default_stat%steady_state_unit, format, advance = "no") maxchange - ! Output end of line - write(default_stat%steady_state_unit,'(a)') "" + flush(default_stat%steady_state_unit) end if - flush(default_stat%steady_state_unit) - end if - - ewrite(1, *) "Exiting test_and_write_steady_state" - - end subroutine test_and_write_steady_state - - subroutine write_detectors(state, detector_list, time, dt) - !!< Write the field values at detectors to the previously opened detectors file. - type(state_type), dimension(:), intent(in) :: state - type(detector_linked_list), intent(inout) :: detector_list - real, intent(in) :: time, dt - - character(len=FIELD_NAME_LEN) :: vfield_name - integer :: i, j, phase, check_no_det, totaldet_global, dim - integer(kind=8) :: h5_ierror - integer, dimension(:), allocatable :: detector_ids - real, dimension(:), allocatable :: detector_scalar_values - real, dimension(:,:), allocatable :: detector_vector_values, positions - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(detector_type), pointer :: detector - - ewrite(1,*) "In write_detectors" - - !Computing the global number of detectors. This is to prevent hanging - !when there are no detectors on any processor - check_no_det = 1 - if (detector_list%length == 0) then - check_no_det = 0 - end if - call allmax(check_no_det) - if (check_no_det == 0) then - return - end if - - ! create a new step - h5_ierror = h5_setstep(detector_list%h5_id, h5_getnsteps(detector_list%h5_id) + 1) - if (h5_ierror /= 0) print *, "Error setting step" - - ! write time and dt as step attributes - h5_ierror = h5_writestepattrib_r8(detector_list%h5_id, "time", [time], int(1, 8)) - if (h5_ierror /= 0) print *, "Error writing 'time' step attribute" - h5_ierror = h5_writestepattrib_r8(detector_list%h5_id, "dt", [dt], int(1, 8)) - if (h5_ierror /= 0) print *, "Error writing 'dt' step attribute" - - ! set the number of particles this process is going to write - h5_ierror = h5pt_setnpoints(detector_list%h5_id, int(detector_list%length, 8)) - if (h5_ierror /= 0) print *, "Error setting number of points" - - ! get position dimensionality - vfield => extract_vector_field(state, "Coordinate") - dim = vfield%dim - - ! write out detector positions - allocate(positions(detector_list%length, 3)) - allocate(detector_ids(detector_list%length)) - - detector => detector_list%first - position_loop: do i = 1, detector_list%length - positions(i,1:dim) = detector%position(:) - detector_ids(i) = detector%id_number - - detector => detector%next - end do position_loop - - if (dim >= 1) & - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "x", positions(:,1)) - if (dim >= 2) & - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "y", positions(:,2)) - if (dim >= 3) then - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) - else - positions(:,3) = 0. - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) - end if - - h5_ierror = h5pt_writedata_i4(detector_list%h5_id, "id", detector_ids(:)) - - deallocate(positions) - deallocate(detector_ids) - - phaseloop: do phase = 1, size(state) - ! scalar fields - if (allocated(detector_list%sfield_list)) then - if (size(detector_list%sfield_list(phase)%ptr) > 0) then - ! allocate array to store all the detector data - allocate(detector_scalar_values(detector_list%length)) - - do i = 1, size(detector_list%sfield_list(phase)%ptr) - sfield => extract_scalar_field(state(phase), detector_list%sfield_list(phase)%ptr(i)) - - ! evaluate the field at each detector - detector => detector_list%first - do j = 1, detector_list%length - ! check this detector belongs to an element - if (detector%element<0) then - if (detector_list%write_nan_outside) then - detector_scalar_values(j) = ieee_value(0.0, ieee_quiet_nan) - else - FLExit("Trying to write detector that is outside of domain.") - end if - else - detector_scalar_values(j) = detector_value(sfield, detector) - end if + ewrite(1, *) "Exiting test_and_write_steady_state" + + end subroutine test_and_write_steady_state + + subroutine write_detectors(state, detector_list, time, dt) + !!< Write the field values at detectors to the previously opened detectors file. + type(state_type), dimension(:), intent(in) :: state + type(detector_linked_list), intent(inout) :: detector_list + real, intent(in) :: time, dt + + character(len=FIELD_NAME_LEN) :: vfield_name + integer :: i, j, phase, check_no_det, totaldet_global, dim + integer(kind=8) :: h5_ierror + integer, dimension(:), allocatable :: detector_ids + real, dimension(:), allocatable :: detector_scalar_values + real, dimension(:,:), allocatable :: detector_vector_values, positions + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(detector_type), pointer :: detector + + ewrite(1,*) "In write_detectors" + + !Computing the global number of detectors. This is to prevent hanging + !when there are no detectors on any processor + check_no_det = 1 + if (detector_list%length == 0) then + check_no_det = 0 + end if + call allmax(check_no_det) + if (check_no_det == 0) then + return + end if - detector => detector%next - end do + ! create a new step + h5_ierror = h5_setstep(detector_list%h5_id, h5_getnsteps(detector_list%h5_id) + 1) + if (h5_ierror /= 0) print *, "Error setting step" + + ! write time and dt as step attributes + h5_ierror = h5_writestepattrib_r8(detector_list%h5_id, "time", [time], int(1, 8)) + if (h5_ierror /= 0) print *, "Error writing 'time' step attribute" + h5_ierror = h5_writestepattrib_r8(detector_list%h5_id, "dt", [dt], int(1, 8)) + if (h5_ierror /= 0) print *, "Error writing 'dt' step attribute" + + ! set the number of particles this process is going to write + h5_ierror = h5pt_setnpoints(detector_list%h5_id, int(detector_list%length, 8)) + if (h5_ierror /= 0) print *, "Error setting number of points" + + ! get position dimensionality + vfield => extract_vector_field(state, "Coordinate") + dim = vfield%dim + + ! write out detector positions + allocate(positions(detector_list%length, 3)) + allocate(detector_ids(detector_list%length)) + + detector => detector_list%first + position_loop: do i = 1, detector_list%length + positions(i,1:dim) = detector%position(:) + detector_ids(i) = detector%id_number + + detector => detector%next + end do position_loop + + if (dim >= 1) & + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "x", positions(:,1)) + if (dim >= 2) & + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "y", positions(:,2)) + if (dim >= 3) then + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) + else + positions(:,3) = 0. + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) + end if - ! write this field to file - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & - trim(state(phase)%name) // "%" // trim(detector_list%sfield_list(phase)%ptr(i)), & - detector_scalar_values(:)) - end do + h5_ierror = h5pt_writedata_i4(detector_list%h5_id, "id", detector_ids(:)) + + deallocate(positions) + deallocate(detector_ids) + + phaseloop: do phase = 1, size(state) + ! scalar fields + if (allocated(detector_list%sfield_list)) then + if (size(detector_list%sfield_list(phase)%ptr) > 0) then + ! allocate array to store all the detector data + allocate(detector_scalar_values(detector_list%length)) + + do i = 1, size(detector_list%sfield_list(phase)%ptr) + sfield => extract_scalar_field(state(phase), detector_list%sfield_list(phase)%ptr(i)) + + ! evaluate the field at each detector + detector => detector_list%first + do j = 1, detector_list%length + ! check this detector belongs to an element + if (detector%element<0) then + if (detector_list%write_nan_outside) then + detector_scalar_values(j) = ieee_value(0.0, ieee_quiet_nan) + else + FLExit("Trying to write detector that is outside of domain.") + end if + else + detector_scalar_values(j) = detector_value(sfield, detector) + end if + + detector => detector%next + end do + + ! write this field to file + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & + trim(state(phase)%name) // "%" // trim(detector_list%sfield_list(phase)%ptr(i)), & + detector_scalar_values(:)) + end do - deallocate(detector_scalar_values) + deallocate(detector_scalar_values) + end if end if - end if - if (allocated(detector_list%vfield_list)) then - if (size(detector_list%vfield_list(phase)%ptr) > 0) then - do i = 1, size(detector_list%vfield_list(phase)%ptr) - vfield => extract_vector_field(state(phase), & + if (allocated(detector_list%vfield_list)) then + if (size(detector_list%vfield_list(phase)%ptr) > 0) then + do i = 1, size(detector_list%vfield_list(phase)%ptr) + vfield => extract_vector_field(state(phase), & & detector_list%vfield_list(phase)%ptr(i)) - ! allocate an array to hold all the values with the - ! dimensionality of this field - allocate(detector_vector_values(detector_list%length, vfield%dim)) - - detector => detector_list%first - do j = 1, detector_list%length - if (detector%element<0) then - if (detector_list%write_nan_outside) then - detector_vector_values(j,:) = ieee_value(0.0, ieee_quiet_nan) - else - FLExit("Trying to write detector that is outside of domain.") - end if - else - detector_vector_values(j,:) = detector_value(vfield, detector) - end if - - detector => detector%next - end do - - vfield_name = trim(state(phase)%name) // "%" // trim(detector_list%vfield_list(phase)%ptr(i)) - - ! write this field - if (vfield%dim >= 1) then - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & - trim(vfield_name) // "%x", & - detector_vector_values(:,1)) - end if - if (vfield%dim >= 2) then - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & - trim(vfield_name) // "%y", & - detector_vector_values(:,2)) - end if - if (vfield%dim >= 3) then - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & - trim(vfield_name) // "%z", & - detector_vector_values(:,3)) - end if - - deallocate(detector_vector_values) - end do + ! allocate an array to hold all the values with the + ! dimensionality of this field + allocate(detector_vector_values(detector_list%length, vfield%dim)) + + detector => detector_list%first + do j = 1, detector_list%length + if (detector%element<0) then + if (detector_list%write_nan_outside) then + detector_vector_values(j,:) = ieee_value(0.0, ieee_quiet_nan) + else + FLExit("Trying to write detector that is outside of domain.") + end if + else + detector_vector_values(j,:) = detector_value(vfield, detector) + end if + + detector => detector%next + end do + + vfield_name = trim(state(phase)%name) // "%" // trim(detector_list%vfield_list(phase)%ptr(i)) + + ! write this field + if (vfield%dim >= 1) then + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & + trim(vfield_name) // "%x", & + detector_vector_values(:,1)) + end if + if (vfield%dim >= 2) then + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & + trim(vfield_name) // "%y", & + detector_vector_values(:,2)) + end if + if (vfield%dim >= 3) then + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, & + trim(vfield_name) // "%z", & + detector_vector_values(:,3)) + end if + + deallocate(detector_vector_values) + end do + end if end if - end if - end do phaseloop + end do phaseloop - totaldet_global=detector_list%length - call allsum(totaldet_global) - ewrite(2,*) "Found", detector_list%length, "local and", totaldet_global, "global detectors" + totaldet_global=detector_list%length + call allsum(totaldet_global) + ewrite(2,*) "Found", detector_list%length, "local and", totaldet_global, "global detectors" - if (totaldet_global/=detector_list%total_num_det) then - ewrite(2,*) "We have either duplication or have lost some det" - ewrite(2,*) "totaldet_global", totaldet_global - ewrite(2,*) "total_num_det", detector_list%total_num_det - end if + if (totaldet_global/=detector_list%total_num_det) then + ewrite(2,*) "We have either duplication or have lost some det" + ewrite(2,*) "totaldet_global", totaldet_global + ewrite(2,*) "total_num_det", detector_list%total_num_det + end if - ewrite(1,*) "Exiting write_detectors" - end subroutine write_detectors + ewrite(1,*) "Exiting write_detectors" + end subroutine write_detectors - subroutine list_det_into_csr_sparsity(detector_list,ihash_sparsity,list_into_array,element_detector_list,count) + subroutine list_det_into_csr_sparsity(detector_list,ihash_sparsity,list_into_array,element_detector_list,count) !! This subroutine creates a hash table called ihash_sparsity and a csr_sparsity matrix called element_detector_list that we use to find out !! how many detectors a given element has and we also obtain the location (row index) of those detectors in an array called list_into_array. !! This array contains the information of detector_list but in an array format, each row of the array contains the information of a detector. !! By accessing the array at that/those row indexes we can extract the information (position, id_number, type, etc.) of each detector present !! in the element (each row index corresponds to a detector) - type(detector_linked_list), intent(inout) :: detector_list - type(integer_hash_table), intent(inout) :: ihash_sparsity - type(csr_sparsity), intent(inout) :: element_detector_list - real, dimension(:,:), allocatable, intent(inout) :: list_into_array - integer, intent(in) :: count + type(detector_linked_list), intent(inout) :: detector_list + type(integer_hash_table), intent(inout) :: ihash_sparsity + type(csr_sparsity), intent(inout) :: element_detector_list + real, dimension(:,:), allocatable, intent(inout) :: list_into_array + integer, intent(in) :: count - integer, dimension(:), allocatable:: detector_count ! detectors per element - integer, dimension(:), pointer:: detectors - type(detector_type), pointer :: node - integer :: dim, i, ele, no_rows, entries, row, pos + integer, dimension(:), allocatable:: detector_count ! detectors per element + integer, dimension(:), pointer:: detectors + type(detector_type), pointer :: node + integer :: dim, i, ele, no_rows, entries, row, pos - if (detector_list%length/=0) then + if (detector_list%length/=0) then - node => detector_list%first + node => detector_list%first - dim=size(node%position) + dim=size(node%position) - do i=1, detector_list%length + do i=1, detector_list%length - list_into_array(i,1:dim)=node%position - list_into_array(i,dim+1)=node%element - list_into_array(i,dim+2)=node%id_number - list_into_array(i,dim+3)=0.0 + list_into_array(i,1:dim)=node%position + list_into_array(i,dim+1)=node%element + list_into_array(i,dim+2)=node%id_number + list_into_array(i,dim+3)=0.0 - node => node%next + node => node%next - end do + end do - ! create map between element and rows, where each row corresponds to an element - ! with one or more detectors + ! create map between element and rows, where each row corresponds to an element + ! with one or more detectors - ! loop over detectors: - ! detector is in element ele + ! loop over detectors: + ! detector is in element ele - no_rows=count + no_rows=count - ! count number of detectors per row - allocate(detector_count(1:no_rows)) - detector_count=0 - ! loop over detectors: - node => detector_list%first + ! count number of detectors per row + allocate(detector_count(1:no_rows)) + detector_count=0 + ! loop over detectors: + node => detector_list%first - do i=1, detector_list%length + do i=1, detector_list%length - ele=node%element - if (has_key(ihash_sparsity, ele)) then - row=fetch(ihash_sparsity, ele) - detector_count(row)=detector_count(row)+1 - end if - node => node%next + ele=node%element + if (has_key(ihash_sparsity, ele)) then + row=fetch(ihash_sparsity, ele) + detector_count(row)=detector_count(row)+1 + end if + node => node%next - end do + end do - ! set up %findrm, the beginning of each row in memory - pos=1 ! position in colm - do row=1, no_rows + ! set up %findrm, the beginning of each row in memory + pos=1 ! position in colm + do row=1, no_rows + element_detector_list%findrm(row)=pos + pos=pos+detector_count(row) + end do element_detector_list%findrm(row)=pos - pos=pos+detector_count(row) - end do - element_detector_list%findrm(row)=pos - - ! fill up the rows with the rom_number of the detectors in the list_into_array - detector_count=0 - ! loop over detectors: - do i=1, detector_list%length + ! fill up the rows with the rom_number of the detectors in the list_into_array + detector_count=0 + ! loop over detectors: - ele=list_into_array(i,dim+1) - if (has_key(ihash_sparsity, ele)) then - row=fetch(ihash_sparsity, ele) - detectors => row_m_ptr(element_detector_list, row) - detector_count(row)=detector_count(row)+1 - detectors(detector_count(row))=i - end if + do i=1, detector_list%length - end do + ele=list_into_array(i,dim+1) + if (has_key(ihash_sparsity, ele)) then + row=fetch(ihash_sparsity, ele) + detectors => row_m_ptr(element_detector_list, row) + detector_count(row)=detector_count(row)+1 + detectors(detector_count(row))=i + end if - deallocate(detector_count) + end do - end if + deallocate(detector_count) - end subroutine list_det_into_csr_sparsity + end if - subroutine close_diagnostic_files() - !! Closes .stat, .convergence and .detector file (if openened) - !! Gives a warning for iostat/=0, no point to flabort though. + end subroutine list_det_into_csr_sparsity - integer:: stat - integer(kind=8) :: h5_ierror + subroutine close_diagnostic_files() + !! Closes .stat, .convergence and .detector file (if openened) + !! Gives a warning for iostat/=0, no point to flabort though. - if (default_stat%diag_unit/=0) then - close(default_stat%diag_unit, iostat=stat) - if (stat/=0) then - ewrite(0,*) "Warning: failed to close .stat file" - end if - end if + integer:: stat + integer(kind=8) :: h5_ierror - if (default_stat%conv_unit/=0) then - close(default_stat%conv_unit, iostat=stat) - if (stat/=0) then - ewrite(0,*) "Warning: failed to close .convergence file" - end if - end if + if (default_stat%diag_unit/=0) then + close(default_stat%diag_unit, iostat=stat) + if (stat/=0) then + ewrite(0,*) "Warning: failed to close .stat file" + end if + end if - if(default_stat%steady_state_unit /= 0) then - close(default_stat%steady_state_unit, iostat = stat) - if(stat /= 0) then - ewrite(0, *) "Warning: failed to close .steady_state file" + if (default_stat%conv_unit/=0) then + close(default_stat%conv_unit, iostat=stat) + if (stat/=0) then + ewrite(0,*) "Warning: failed to close .convergence file" + end if end if - end if - if (default_stat%detector_list%h5_id /= -1) then - h5_ierror = h5_closefile(default_stat%detector_list%h5_id) - if (h5_ierror /= 0) then - ewrite(0, *) "Warning: failed to close .detectors.h5part file" + if(default_stat%steady_state_unit /= 0) then + close(default_stat%steady_state_unit, iostat = stat) + if(stat /= 0) then + ewrite(0, *) "Warning: failed to close .steady_state file" + end if end if - end if - end subroutine close_diagnostic_files + if (default_stat%detector_list%h5_id /= -1) then + h5_ierror = h5_closefile(default_stat%detector_list%h5_id) + if (h5_ierror /= 0) then + ewrite(0, *) "Warning: failed to close .detectors.h5part file" + end if + end if - SUBROUTINE RUN_DIAGNOSTICS(state) - !!< Initial diagnostic output. - type(state_type), dimension(:), intent(in) :: state + end subroutine close_diagnostic_files - REAL ::DT,LTIME + SUBROUTINE RUN_DIAGNOSTICS(state) + !!< Initial diagnostic output. + type(state_type), dimension(:), intent(in) :: state - REAL :: VOL,MAXVOL,MINVOL - INTEGER :: ELE, I, minvol_ele, maxvol_ele + REAL ::DT,LTIME - real, dimension(:), allocatable :: detwei - type(vector_field) :: coordinate + REAL :: VOL,MAXVOL,MINVOL + INTEGER :: ELE, I, minvol_ele, maxvol_ele - ! Only do this at all if there will be output. - if (debug_level()<1) return + real, dimension(:), allocatable :: detwei + type(vector_field) :: coordinate - call get_option("/timestepping/timestep", dt) - call get_option("/timestepping/finish_time", ltime) + ! Only do this at all if there will be output. + if (debug_level()<1) return - ewrite(1,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' - ewrite(1,*)'% Some quantities associated with the initial set-up of this problem. %' - ewrite(1,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' - ewrite(1,*)'-' - ewrite(1,*)'The time step (DT) is: ',DT - ewrite(1,*)'The end time (LTIME) is set to: ',LTIME - ewrite(1,*)'This corresponds to this many time steps in simulation:',LTIME/DT - ewrite(1,*)'-' + call get_option("/timestepping/timestep", dt) + call get_option("/timestepping/finish_time", ltime) - coordinate=extract_vector_field(state(1), "Coordinate") + ewrite(1,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' + ewrite(1,*)'% Some quantities associated with the initial set-up of this problem. %' + ewrite(1,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' + ewrite(1,*)'-' + ewrite(1,*)'The time step (DT) is: ',DT + ewrite(1,*)'The end time (LTIME) is set to: ',LTIME + ewrite(1,*)'This corresponds to this many time steps in simulation:',LTIME/DT + ewrite(1,*)'-' - ! Edge lengths are suspended until someone generalises them - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ELEMENT VOLUMES - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - MAXVOL = -huge(1.0) - MINVOL = huge(1.0) + coordinate=extract_vector_field(state(1), "Coordinate") - allocate(detwei(ele_ngi(coordinate,1))) + ! Edge lengths are suspended until someone generalises them + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ELEMENT VOLUMES + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + MAXVOL = -huge(1.0) + MINVOL = huge(1.0) - do ele = 1, element_count(coordinate) + allocate(detwei(ele_ngi(coordinate,1))) - call transform_to_physical(coordinate, ele, detwei) - vol=sum(detwei) + do ele = 1, element_count(coordinate) - if (vol>maxvol) then - maxvol=vol - maxvol_ele=ele - end if - if (volmaxvol) then + maxvol=vol + maxvol_ele=ele + end if + if (vol binlist - - ! count n/o elements per bin - dbin%size=0 - do i=1, nelements - dbin%size(binlist(i))=dbin%size(binlist(i))+1 - end do - - assert(sum(dbin%size)==nelements) - - ! work out the starting point of each bin: - k=1 - do i=1, nbins - dbin%start(i)=k - k=k+dbin%size(i) - end do - dbin%start(nbins+1)=k - - ! set bin size back to 0, so we can let it grow back as we insert the elements - dbin%size=0 - ! insert all elements - do i=1, nelements - new_index=dbin%start(binlist(i))+dbin%size(binlist(i)) - dbin%bin(new_index)=i - dbin%index(i)=new_index - dbin%size(binlist(i))=dbin%size(binlist(i))+1 - end do - - end subroutine allocate_dynamic_bins - - subroutine deallocate_dynamic_bins(dbin) - type(dynamic_bin_type), intent(inout):: dbin - - deallocate(dbin%bin, dbin%index, dbin%start, dbin%size) - ! dbin%bin_no is a pointer to the binlist supplied to allocate - - end subroutine deallocate_dynamic_bins - - subroutine move_element(dbin, element, bin_no) - !!< move an element (thas has been inserted before) - !!< to a different bin - type(dynamic_bin_type), intent(inout):: dbin - integer, intent(in):: element, bin_no - - integer prev_index, prev_bin_no, last, new_index - - prev_index=dbin%index(element) - ! this routine should only be used to move elements that have been inserted already: - assert(prev_index/=0) - - prev_bin_no=dbin%bin_no(element) - ! just to make sure: - if (prev_bin_no==bin_no) return - - ! remove the element from its previous bin by overwriting with - ! the last element of that bin - last=dbin%bin(dbin%start(prev_bin_no)+dbin%size(prev_bin_no)-1) - dbin%index(last)=prev_index - dbin%bin(prev_index)=last - dbin%size(prev_bin_no)=dbin%size(prev_bin_no)-1 - - if (bin_no binlist + + ! count n/o elements per bin + dbin%size=0 + do i=1, nelements + dbin%size(binlist(i))=dbin%size(binlist(i))+1 + end do + + assert(sum(dbin%size)==nelements) + + ! work out the starting point of each bin: + k=1 + do i=1, nbins + dbin%start(i)=k + k=k+dbin%size(i) + end do + dbin%start(nbins+1)=k + + ! set bin size back to 0, so we can let it grow back as we insert the elements + dbin%size=0 + ! insert all elements + do i=1, nelements + new_index=dbin%start(binlist(i))+dbin%size(binlist(i)) + dbin%bin(new_index)=i + dbin%index(i)=new_index + dbin%size(binlist(i))=dbin%size(binlist(i))+1 + end do + + end subroutine allocate_dynamic_bins + + subroutine deallocate_dynamic_bins(dbin) + type(dynamic_bin_type), intent(inout):: dbin + + deallocate(dbin%bin, dbin%index, dbin%start, dbin%size) + ! dbin%bin_no is a pointer to the binlist supplied to allocate + + end subroutine deallocate_dynamic_bins + + subroutine move_element(dbin, element, bin_no) + !!< move an element (thas has been inserted before) + !!< to a different bin + type(dynamic_bin_type), intent(inout):: dbin + integer, intent(in):: element, bin_no + + integer prev_index, prev_bin_no, last, new_index + + prev_index=dbin%index(element) + ! this routine should only be used to move elements that have been inserted already: + assert(prev_index/=0) + + prev_bin_no=dbin%bin_no(element) + ! just to make sure: + if (prev_bin_no==bin_no) return + + ! remove the element from its previous bin by overwriting with + ! the last element of that bin + last=dbin%bin(dbin%start(prev_bin_no)+dbin%size(prev_bin_no)-1) + dbin%index(last)=prev_index + dbin%bin(prev_index)=last + dbin%size(prev_bin_no)=dbin%size(prev_bin_no)-1 + + if (bin_no0) exit - end do - if (i>size(dbin%size)) then - FLAbort("Tried to pull an element while all bins are empty.") - end if - bin_no=i + ! move first element to last position + first=dbin%bin(dbin%start(bin_no)) + dbin%index(first)=dbin%start(bin_no)+dbin%size(bin_no) + dbin%bin(dbin%start(bin_no)+dbin%size(bin_no))=first + dbin%start(bin_no)=dbin%start(bin_no)+1 + + end subroutine shuffle_bin_right + + subroutine pull_element(dbin, element, bin_no) + !!< pull an element from the first non-empty bin + type(dynamic_bin_type), intent(inout):: dbin + integer, intent(out):: element + ! the bin it's pulled from: + integer, intent(out):: bin_no + + integer i + + ! find first non-empty bin: + do i=1, size(dbin%size) + if (dbin%size(i)>0) exit + end do + if (i>size(dbin%size)) then + FLAbort("Tried to pull an element while all bins are empty.") + end if + bin_no=i - call pull_from_bin(dbin, bin_no, element) + call pull_from_bin(dbin, bin_no, element) - end subroutine pull_element + end subroutine pull_element - subroutine pull_from_bin(dbin, bin_no, element) - !!< pull an element from the specified bin - type(dynamic_bin_type), intent(inout):: dbin - integer, intent(in):: bin_no - integer, intent(out):: element + subroutine pull_from_bin(dbin, bin_no, element) + !!< pull an element from the specified bin + type(dynamic_bin_type), intent(inout):: dbin + integer, intent(in):: bin_no + integer, intent(out):: element - integer index + integer index - index=dbin%start(bin_no)+dbin%size(bin_no)-1 - element=dbin%bin(index) + index=dbin%start(bin_no)+dbin%size(bin_no)-1 + element=dbin%bin(index) - ! remove the element: - dbin%index(element)=0 - dbin%size(bin_no)=dbin%size(bin_no)-1 + ! remove the element: + dbin%index(element)=0 + dbin%size(bin_no)=dbin%size(bin_no)-1 - end subroutine pull_from_bin + end subroutine pull_from_bin - logical function element_pulled(dbin, element) - !!< whether an element has been pulled already - type(dynamic_bin_type), intent(in):: dbin - integer, intent(in):: element + logical function element_pulled(dbin, element) + !!< whether an element has been pulled already + type(dynamic_bin_type), intent(in):: dbin + integer, intent(in):: element - element_pulled= dbin%index(element)==0 + element_pulled= dbin%index(element)==0 - end function element_pulled + end function element_pulled end module dynamic_bin_sort_module diff --git a/femtools/Element_Numbering.F90 b/femtools/Element_Numbering.F90 index 56cb29173c..4b363fe2a4 100644 --- a/femtools/Element_Numbering.F90 +++ b/femtools/Element_Numbering.F90 @@ -27,250 +27,250 @@ #include "fdebug.h" module element_numbering - !!< Module containing local element numbering for the One True Numbering - !!< Order. - !!< - !!< This is currently very tet-centric but is written to be - !!< generalised. - !!< - !!< Conventions: - !!< - !!< The One True Numbering Order is the recursive Pascal's triangle order - !!< as documented in the wiki. - !!< - !!< The bdys of a Tet have the same indices as the opposite vertex. - !!< - !!< This module currently implements tets of polynomial order 0 to 5. - !!< - !!< Nodes are subdivided into four disjoint sets: vertex nodes, those lying - !!< on edges, those lying on faces and those interior to elements. - use FLDebug - use futils - implicit none - - integer, parameter, public :: ELEMENT_LAGRANGIAN=1, ELEMENT_NONCONFORMING=2, ELEMENT_BUBBLE=3, & - ELEMENT_CONTROLVOLUMEBDY_SURFACE=4, ELEMENT_CONTROLVOLUME_SURFACE=5, & - ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES=6, & - ELEMENT_TRACE=7 - - integer, parameter, public :: FAMILY_SIMPLEX=1, FAMILY_CUBE=2 - - type ele_numbering_type - ! Type to record element numbering details. - ! Differentiate tets from other elements. - integer :: faces, vertices, edges, boundaries - integer :: degree ! Degree of polynomials. - integer :: dimension ! 2D or 3D - integer :: nodes - integer :: type=ELEMENT_LAGRANGIAN - integer :: family - ! Map local count coordinates to local number. - integer, dimension(:,:,:), pointer :: count2number - ! Map local number to local count coordinates. - integer, dimension(:,:), pointer :: number2count - ! Count coordinate which is held constant for each element boundary. - integer, dimension(:), pointer :: boundary_coord - ! Value of that count coordinate on the element boundary. - integer, dimension(:), pointer :: boundary_val - end type ele_numbering_type - - integer, parameter :: TET_MAX_DEGREE=9, TET_BUBBLE_MAX_DEGREE=3 - integer, parameter :: TRI_MAX_DEGREE=32 - integer, parameter :: TRI_BUBBLE_MAX_DEGREE=2 - integer, parameter :: INTERVAL_MAX_DEGREE=32 - integer, parameter :: HEX_MAX_DEGREE=9, QUAD_MAX_DEGREE=9 - ! bubbles are restricted to prevent co-located nodes - - type(ele_numbering_type), dimension(0:TET_MAX_DEGREE), target, save ::& - & tet_numbering - type(ele_numbering_type), dimension(1:TET_BUBBLE_MAX_DEGREE), target, save ::& - & tet_numbering_bubble - type(ele_numbering_type), dimension(0:TRI_MAX_DEGREE), target, save ::& - & tri_numbering - type(ele_numbering_type), dimension(0:TRI_MAX_DEGREE), target, save ::& - & tri_numbering_trace - type(ele_numbering_type), dimension(0:TRI_MAX_DEGREE), target, save ::& - & quad_numbering_trace - type(ele_numbering_type), dimension(1:TRI_BUBBLE_MAX_DEGREE), target, save ::& - & tri_numbering_bubble - type(ele_numbering_type), target, save :: tri_numbering_nc - type(ele_numbering_type), dimension(0:INTERVAL_MAX_DEGREE), target, & - save :: interval_numbering - type(ele_numbering_type), target, save :: interval_numbering_bubble - type(ele_numbering_type), dimension(0:HEX_MAX_DEGREE), target, save ::& - & hex_numbering - type(ele_numbering_type), dimension(0:QUAD_MAX_DEGREE), target, save ::& - & quad_numbering - type(ele_numbering_type), dimension(0:0), target, save :: point_numbering - - logical, private, save :: initialised=.false. - - interface local_coords - module procedure ele_num_local_coords - end interface - - interface local_vertices - module procedure ele_num_local_vertices - end interface - - interface vertex_num - module procedure svertex_num, vvertex_num - end interface - - interface boundary_numbering - module procedure numbering_boundary_numbering - end interface - - interface edge_num - module procedure edge_num_int, edge_num_no_int - end interface - - interface face_num - module procedure face_num_int, face_num_no_int - end interface - - interface boundary_local_num - module procedure boundary_local_num_int, boundary_local_num_no_int - end interface - - interface face_local_num - module procedure face_local_num_int, face_local_num_no_int - end interface - - interface operator(==) - module procedure element_num_equal - end interface - -private - -public :: find_element_numbering, local_coords, local_vertices, vertex_num,& - boundary_numbering, edge_num, face_num, boundary_local_num, operator(==),& - ele_numbering_type, boundary_num_length, ele_local_num, face_local_num,& - edge_local_num, tr, te + !!< Module containing local element numbering for the One True Numbering + !!< Order. + !!< + !!< This is currently very tet-centric but is written to be + !!< generalised. + !!< + !!< Conventions: + !!< + !!< The One True Numbering Order is the recursive Pascal's triangle order + !!< as documented in the wiki. + !!< + !!< The bdys of a Tet have the same indices as the opposite vertex. + !!< + !!< This module currently implements tets of polynomial order 0 to 5. + !!< + !!< Nodes are subdivided into four disjoint sets: vertex nodes, those lying + !!< on edges, those lying on faces and those interior to elements. + use FLDebug + use futils + implicit none + + integer, parameter, public :: ELEMENT_LAGRANGIAN=1, ELEMENT_NONCONFORMING=2, ELEMENT_BUBBLE=3, & + ELEMENT_CONTROLVOLUMEBDY_SURFACE=4, ELEMENT_CONTROLVOLUME_SURFACE=5, & + ELEMENT_CONTROLVOLUME_SURFACE_BODYDERIVATIVES=6, & + ELEMENT_TRACE=7 + + integer, parameter, public :: FAMILY_SIMPLEX=1, FAMILY_CUBE=2 + + type ele_numbering_type + ! Type to record element numbering details. + ! Differentiate tets from other elements. + integer :: faces, vertices, edges, boundaries + integer :: degree ! Degree of polynomials. + integer :: dimension ! 2D or 3D + integer :: nodes + integer :: type=ELEMENT_LAGRANGIAN + integer :: family + ! Map local count coordinates to local number. + integer, dimension(:,:,:), pointer :: count2number + ! Map local number to local count coordinates. + integer, dimension(:,:), pointer :: number2count + ! Count coordinate which is held constant for each element boundary. + integer, dimension(:), pointer :: boundary_coord + ! Value of that count coordinate on the element boundary. + integer, dimension(:), pointer :: boundary_val + end type ele_numbering_type + + integer, parameter :: TET_MAX_DEGREE=9, TET_BUBBLE_MAX_DEGREE=3 + integer, parameter :: TRI_MAX_DEGREE=32 + integer, parameter :: TRI_BUBBLE_MAX_DEGREE=2 + integer, parameter :: INTERVAL_MAX_DEGREE=32 + integer, parameter :: HEX_MAX_DEGREE=9, QUAD_MAX_DEGREE=9 + ! bubbles are restricted to prevent co-located nodes + + type(ele_numbering_type), dimension(0:TET_MAX_DEGREE), target, save ::& + & tet_numbering + type(ele_numbering_type), dimension(1:TET_BUBBLE_MAX_DEGREE), target, save ::& + & tet_numbering_bubble + type(ele_numbering_type), dimension(0:TRI_MAX_DEGREE), target, save ::& + & tri_numbering + type(ele_numbering_type), dimension(0:TRI_MAX_DEGREE), target, save ::& + & tri_numbering_trace + type(ele_numbering_type), dimension(0:TRI_MAX_DEGREE), target, save ::& + & quad_numbering_trace + type(ele_numbering_type), dimension(1:TRI_BUBBLE_MAX_DEGREE), target, save ::& + & tri_numbering_bubble + type(ele_numbering_type), target, save :: tri_numbering_nc + type(ele_numbering_type), dimension(0:INTERVAL_MAX_DEGREE), target, & + save :: interval_numbering + type(ele_numbering_type), target, save :: interval_numbering_bubble + type(ele_numbering_type), dimension(0:HEX_MAX_DEGREE), target, save ::& + & hex_numbering + type(ele_numbering_type), dimension(0:QUAD_MAX_DEGREE), target, save ::& + & quad_numbering + type(ele_numbering_type), dimension(0:0), target, save :: point_numbering + + logical, private, save :: initialised=.false. + + interface local_coords + module procedure ele_num_local_coords + end interface + + interface local_vertices + module procedure ele_num_local_vertices + end interface + + interface vertex_num + module procedure svertex_num, vvertex_num + end interface + + interface boundary_numbering + module procedure numbering_boundary_numbering + end interface + + interface edge_num + module procedure edge_num_int, edge_num_no_int + end interface + + interface face_num + module procedure face_num_int, face_num_no_int + end interface + + interface boundary_local_num + module procedure boundary_local_num_int, boundary_local_num_no_int + end interface + + interface face_local_num + module procedure face_local_num_int, face_local_num_no_int + end interface + + interface operator(==) + module procedure element_num_equal + end interface + + private + + public :: find_element_numbering, local_coords, local_vertices, vertex_num,& + boundary_numbering, edge_num, face_num, boundary_local_num, operator(==),& + ele_numbering_type, boundary_num_length, ele_local_num, face_local_num,& + edge_local_num, tr, te contains - function find_element_numbering(vertices, dimension, degree, type) result (ele_num) - ! Return the element numbering type for an element in dimension - ! dimensions with vertices vertices and degree polynomial bases. - ! - ! If no suitable numbering is available, return a null pointer. - type(ele_numbering_type), pointer :: ele_num - integer, intent(in) :: vertices, dimension, degree - integer, intent(in), optional :: type - - integer :: ltype - - if (.not.initialised) call number_elements - - if (present(type)) then - ltype=type - else - ltype=ELEMENT_LAGRANGIAN - end if - - select case(ltype) - case (ELEMENT_LAGRANGIAN) - select case(dimension) - case (0) - select case(vertices) - case(1) - ! The point element always has degree 0 - ele_num=>point_numbering(0) - return - case default - ele_num=>null() - return - end select + function find_element_numbering(vertices, dimension, degree, type) result (ele_num) + ! Return the element numbering type for an element in dimension + ! dimensions with vertices vertices and degree polynomial bases. + ! + ! If no suitable numbering is available, return a null pointer. + type(ele_numbering_type), pointer :: ele_num + integer, intent(in) :: vertices, dimension, degree + integer, intent(in), optional :: type + + integer :: ltype + + if (.not.initialised) call number_elements + + if (present(type)) then + ltype=type + else + ltype=ELEMENT_LAGRANGIAN + end if + + select case(ltype) + case (ELEMENT_LAGRANGIAN) + select case(dimension) + case (0) + select case(vertices) + case(1) + ! The point element always has degree 0 + ele_num=>point_numbering(0) + return + case default + ele_num=>null() + return + end select + + case (1) + select case(vertices) + case(2) + ! Intervals - the only possibility. + if (degree>INTERVAL_MAX_DEGREE) then + ele_num=>null() + return + else + ele_num=>interval_numbering(degree) + return + end if + + case default + ele_num=>null() + return + end select - case (1) - select case(vertices) case(2) - ! Intervals - the only possibility. - if (degree>INTERVAL_MAX_DEGREE) then - ele_num=>null() - return - else - ele_num=>interval_numbering(degree) - return - end if - case default - ele_num=>null() - return - end select + select case(vertices) + case(3) + !Triangles. + + if (degree>TRI_MAX_DEGREE) then + ele_num=>null() + return + else + ele_num=>tri_numbering(degree) + return + end if + + case (4) + ! Quads + + if (degree>QUAD_MAX_DEGREE) then + ele_num=>null() + return + else + ele_num=>quad_numbering(degree) + return + end if + + case default + ele_num=>null() + return + end select - case(2) - - select case(vertices) case(3) - !Triangles. - - if (degree>TRI_MAX_DEGREE) then - ele_num=>null() - return - else - ele_num=>tri_numbering(degree) - return - end if - - case (4) - ! Quads - if (degree>QUAD_MAX_DEGREE) then - ele_num=>null() - return - else - ele_num=>quad_numbering(degree) - return - end if + select case (vertices) + case (4) + !Tets + + if (degree>TET_MAX_DEGREE) then + ele_num=>null() + return + else + ele_num=>tet_numbering(degree) + return + end if + + case (8) + ! Hexes + + if (degree>HEX_MAX_DEGREE) then + ele_num=>null() + return + else + ele_num=>hex_numbering(degree) + return + end if + + case default + ele_num=>null() + return + end select case default - ele_num=>null() - return - end select - - case(3) - - select case (vertices) - case (4) - !Tets - - if (degree>TET_MAX_DEGREE) then - ele_num=>null() - return - else - ele_num=>tet_numbering(degree) - return - end if - - case (8) - ! Hexes - - if (degree>HEX_MAX_DEGREE) then - ele_num=>null() - return - else - ele_num=>hex_numbering(degree) - return - end if - - case default - ele_num=>null() - return - end select - - case default - ele_num=>null() - return - end select + ele_num=>null() + return + end select - case (ELEMENT_NONCONFORMING) + case (ELEMENT_NONCONFORMING) - assert(vertices==3) - assert(dimension==2) - assert(degree==1) - ele_num=>tri_numbering_nc + assert(vertices==3) + assert(dimension==2) + assert(degree==1) + ele_num=>tri_numbering_nc ! case (ELEMENT_NONCONFORMING_FACE) @@ -279,1038 +279,1038 @@ function find_element_numbering(vertices, dimension, degree, type) result (ele_n ! assert(degree==1) ! ele_num=>tri_numbering_nc - case (ELEMENT_TRACE) + case (ELEMENT_TRACE) - if(dimension /= 2) then - FLAbort('Trace elements only currently coded for 2D') - end if - select case (vertices) - case (3) - ele_num=>tri_numbering_trace(degree) - case (4) - ele_num=>quad_numbering_trace(degree) - case default - FLAbort('Vertex count not supported for trace elements') - end select - case (ELEMENT_BUBBLE) + if(dimension /= 2) then + FLAbort('Trace elements only currently coded for 2D') + end if + select case (vertices) + case (3) + ele_num=>tri_numbering_trace(degree) + case (4) + ele_num=>quad_numbering_trace(degree) + case default + FLAbort('Vertex count not supported for trace elements') + end select + case (ELEMENT_BUBBLE) - select case(dimension) - case(1) + select case(dimension) + case(1) - select case(vertices) - case(2) - ! Intervals - the only possibility. - if (degree/=1) then - ele_num=>null() - return - else - ele_num=>interval_numbering_bubble - return - end if + select case(vertices) + case(2) + ! Intervals - the only possibility. + if (degree/=1) then + ele_num=>null() + return + else + ele_num=>interval_numbering_bubble + return + end if + + case default + ele_num=>null() + return + end select - case default - ele_num=>null() - return - end select + case(2) - case(2) + select case(vertices) + case(3) + !Triangles. - select case(vertices) - case(3) - !Triangles. + if ((degree==0).or.(degree>TRI_BUBBLE_MAX_DEGREE)) then + ele_num=>null() + return + else + ele_num=>tri_numbering_bubble(degree) + return + end if - if ((degree==0).or.(degree>TRI_BUBBLE_MAX_DEGREE)) then - ele_num=>null() - return - else - ele_num=>tri_numbering_bubble(degree) - return - end if + case default + ele_num=>null() + return + end select - case default - ele_num=>null() - return - end select + case(3) - case(3) + select case(vertices) + case(4) + !Tets. - select case(vertices) - case(4) - !Tets. + if ((degree==0).or.(degree>TET_BUBBLE_MAX_DEGREE)) then + ele_num=>null() + return + else + ele_num=>tet_numbering_bubble(degree) + return + end if - if ((degree==0).or.(degree>TET_BUBBLE_MAX_DEGREE)) then - ele_num=>null() - return - else - ele_num=>tet_numbering_bubble(degree) - return - end if + case default + ele_num=>null() + return + end select case default - ele_num=>null() - return - end select + ele_num=>null() + return + end select case default - ele_num=>null() - return - end select - case default + FLAbort('Attempt to select an illegal element type.') - FLAbort('Attempt to select an illegal element type.') + end select - end select + end function find_element_numbering + + subroutine number_elements + ! Fill the values in in element_numbering. + + ! make sure this is idempotent. + if (initialised) return + initialised=.true. + + call number_tets_lagrange + call number_tets_bubble + call number_triangles_lagrange + call number_triangles_bubble + call number_triangles_trace + call number_triangles_nc + call number_intervals_lagrange + call number_intervals_bubble + call number_point_lagrange + call number_hexes_lagrange + call number_quads_lagrange + call number_quads_trace + + end subroutine number_elements + + subroutine number_tets_lagrange + ! Fill the values in in element_numbering. + integer :: i,j, cnt + integer, dimension(4) :: l + type(ele_numbering_type), pointer :: ele + + ! Currently only tets are supported. + tet_numbering%faces=4 + tet_numbering%vertices=4 + tet_numbering%edges=6 + tet_numbering%dimension=3 + tet_numbering%boundaries=4 + tet_numbering%family=FAMILY_SIMPLEX + tet_numbering%type=ELEMENT_LAGRANGIAN + + ! Degree 0 elements are a special case. + ele=>tet_numbering(0) + ele%degree=0 + + degree_loop: do i=0,TET_MAX_DEGREE + ele=>tet_numbering(i) + ele%degree=i + + ! Allocate mappings: + allocate(ele%count2number(0:i,0:i,0:i)) + allocate(ele%number2count(ele%dimension+1,te(i+1))) + allocate(ele%boundary_coord(ele%faces)) + allocate(ele%boundary_val(ele%faces)) + + ele%nodes=te(i+1) + + ele%count2number=0 + ele%number2count=0 - end function find_element_numbering + l=0 + l(1)=i - subroutine number_elements - ! Fill the values in in element_numbering. + cnt=0 - ! make sure this is idempotent. - if (initialised) return - initialised=.true. + number_loop: do - call number_tets_lagrange - call number_tets_bubble - call number_triangles_lagrange - call number_triangles_bubble - call number_triangles_trace - call number_triangles_nc - call number_intervals_lagrange - call number_intervals_bubble - call number_point_lagrange - call number_hexes_lagrange - call number_quads_lagrange - call number_quads_trace + cnt=cnt+1 - end subroutine number_elements + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - subroutine number_tets_lagrange - ! Fill the values in in element_numbering. - integer :: i,j, cnt - integer, dimension(4) :: l - type(ele_numbering_type), pointer :: ele + ! If the last index has reached the current degree then we are + ! done. + if (l(4)==i) exit number_loop - ! Currently only tets are supported. - tet_numbering%faces=4 - tet_numbering%vertices=4 - tet_numbering%edges=6 - tet_numbering%dimension=3 - tet_numbering%boundaries=4 - tet_numbering%family=FAMILY_SIMPLEX - tet_numbering%type=ELEMENT_LAGRANGIAN + ! Increment the index counter. + l(2)=l(2)+1 - ! Degree 0 elements are a special case. - ele=>tet_numbering(0) - ele%degree=0 + do j=2,3 + ! This comparison implements the decreasing dimension lengths + ! as you move up the pyramid. + if (l(j)>i-sum(l(j+1:))) then + l(j)=0 + l(j+1)=l(j+1)+1 + end if + end do - degree_loop: do i=0,TET_MAX_DEGREE - ele=>tet_numbering(i) - ele%degree=i + l(1)=i-sum(l(2:)) - ! Allocate mappings: - allocate(ele%count2number(0:i,0:i,0:i)) - allocate(ele%number2count(ele%dimension+1,te(i+1))) - allocate(ele%boundary_coord(ele%faces)) - allocate(ele%boundary_val(ele%faces)) - ele%nodes=te(i+1) + end do number_loop - ele%count2number=0 - ele%number2count=0 + ! Sanity test + if (te(i+1)/=cnt) then + ewrite(3,*) 'Counting error', i, te(i+1), cnt + stop + end if - l=0 - l(1)=i + ! Number faces. + forall(j=1:ele%faces) + ele%boundary_coord(j)=j + end forall + ! In a tet all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 - cnt=0 + end do degree_loop - number_loop: do - cnt=cnt+1 + end subroutine number_tets_lagrange - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + subroutine number_tets_bubble + ! Fill the values in in element_numbering. + integer :: i,j, cnt + integer, dimension(4) :: l + type(ele_numbering_type), pointer :: ele - ! If the last index has reached the current degree then we are - ! done. - if (l(4)==i) exit number_loop + ! Currently only tets are supported. + tet_numbering_bubble%faces=4 + tet_numbering_bubble%vertices=4 + tet_numbering_bubble%edges=6 + tet_numbering_bubble%dimension=3 + tet_numbering_bubble%boundaries=4 + tet_numbering_bubble%family=FAMILY_SIMPLEX + tet_numbering_bubble%type=ELEMENT_BUBBLE - ! Increment the index counter. - l(2)=l(2)+1 + degree_loop: do i=1,TET_BUBBLE_MAX_DEGREE + ele=>tet_numbering_bubble(i) + ele%degree=i - do j=2,3 - ! This comparison implements the decreasing dimension lengths - ! as you move up the pyramid. - if (l(j)>i-sum(l(j+1:))) then - l(j)=0 - l(j+1)=l(j+1)+1 - end if - end do + ! Allocate mappings: + allocate(ele%count2number(0:i*(ele%dimension+1),0:i*(ele%dimension+1),0:i*(ele%dimension+1))) + allocate(ele%number2count(ele%dimension+1,te(i+1)+1)) + allocate(ele%boundary_coord(ele%faces)) + allocate(ele%boundary_val(ele%faces)) - l(1)=i-sum(l(2:)) + ele%nodes=te(i+1)+1 + ele%count2number=0 + ele%number2count=0 + l=0 + l(1)=i*(ele%dimension+1) - end do number_loop + cnt=0 - ! Sanity test - if (te(i+1)/=cnt) then - ewrite(3,*) 'Counting error', i, te(i+1), cnt - stop - end if + number_loop: do - ! Number faces. - forall(j=1:ele%faces) - ele%boundary_coord(j)=j - end forall - ! In a tet all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 + cnt=cnt+1 - end do degree_loop - - - end subroutine number_tets_lagrange - - subroutine number_tets_bubble - ! Fill the values in in element_numbering. - integer :: i,j, cnt - integer, dimension(4) :: l - type(ele_numbering_type), pointer :: ele - - ! Currently only tets are supported. - tet_numbering_bubble%faces=4 - tet_numbering_bubble%vertices=4 - tet_numbering_bubble%edges=6 - tet_numbering_bubble%dimension=3 - tet_numbering_bubble%boundaries=4 - tet_numbering_bubble%family=FAMILY_SIMPLEX - tet_numbering_bubble%type=ELEMENT_BUBBLE + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - degree_loop: do i=1,TET_BUBBLE_MAX_DEGREE - ele=>tet_numbering_bubble(i) - ele%degree=i + ! If the last index has reached the current degree then we are + ! done. + if (l(4)==i*(ele%dimension+1)) exit number_loop - ! Allocate mappings: - allocate(ele%count2number(0:i*(ele%dimension+1),0:i*(ele%dimension+1),0:i*(ele%dimension+1))) - allocate(ele%number2count(ele%dimension+1,te(i+1)+1)) - allocate(ele%boundary_coord(ele%faces)) - allocate(ele%boundary_val(ele%faces)) + ! Increment the index counter. + l(2)=l(2)+ele%dimension+1 - ele%nodes=te(i+1)+1 - ele%count2number=0 - ele%number2count=0 + do j=2,3 + ! This comparison implements the decreasing dimension lengths + ! as you move up the pyramid. + if (l(j)>i*(ele%dimension+1)-sum(l(j+1:))) then + l(j)=0 + l(j+1)=l(j+1)+ele%dimension+1 + end if + end do - l=0 - l(1)=i*(ele%dimension+1) + l(1)=i*(ele%dimension+1)-sum(l(2:)) - cnt=0 - number_loop: do + end do number_loop - cnt=cnt+1 + ! add in the bubble node + l(1) = i + l(2) = i + l(3) = i + l(4) = i + cnt=cnt+1 + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + ! Sanity test + if (te(i+1)+1/=cnt) then + ewrite(-1,*) 'degree, nodes, cnt = ', i, te(i+1)+1, cnt + FLAbort("Counting error") + end if - ! If the last index has reached the current degree then we are - ! done. - if (l(4)==i*(ele%dimension+1)) exit number_loop + ! Number faces. + forall(j=1:ele%faces) + ele%boundary_coord(j)=j + end forall + ! In a tet all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 - ! Increment the index counter. - l(2)=l(2)+ele%dimension+1 + end do degree_loop - do j=2,3 - ! This comparison implements the decreasing dimension lengths - ! as you move up the pyramid. - if (l(j)>i*(ele%dimension+1)-sum(l(j+1:))) then - l(j)=0 - l(j+1)=l(j+1)+ele%dimension+1 - end if - end do - l(1)=i*(ele%dimension+1)-sum(l(2:)) + end subroutine number_tets_bubble + subroutine number_triangles_lagrange + ! Fill the values in in element_numbering. + integer :: i,j, cnt + integer, dimension(3) :: l + type(ele_numbering_type), pointer :: ele - end do number_loop + tri_numbering%faces=1 + tri_numbering%vertices=3 + tri_numbering%edges=3 + tri_numbering%dimension=2 + tri_numbering%boundaries=3 + tri_numbering%family=FAMILY_SIMPLEX + tri_numbering%type=ELEMENT_LAGRANGIAN - ! add in the bubble node - l(1) = i - l(2) = i - l(3) = i - l(4) = i - cnt=cnt+1 - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + ! Degree 0 elements are a special case. + ele=>tri_numbering(0) + ele%degree=0 - ! Sanity test - if (te(i+1)+1/=cnt) then - ewrite(-1,*) 'degree, nodes, cnt = ', i, te(i+1)+1, cnt - FLAbort("Counting error") - end if + degree_loop: do i=0,TRI_MAX_DEGREE + ele=>tri_numbering(i) + ele%degree=i - ! Number faces. - forall(j=1:ele%faces) - ele%boundary_coord(j)=j - end forall - ! In a tet all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 - - end do degree_loop - - - end subroutine number_tets_bubble - - subroutine number_triangles_lagrange - ! Fill the values in in element_numbering. - integer :: i,j, cnt - integer, dimension(3) :: l - type(ele_numbering_type), pointer :: ele + ! Allocate mappings: + allocate(ele%count2number(0:i,0:i,0:i)) + allocate(ele%number2count(ele%dimension+1,tr(i+1))) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) - tri_numbering%faces=1 - tri_numbering%vertices=3 - tri_numbering%edges=3 - tri_numbering%dimension=2 - tri_numbering%boundaries=3 - tri_numbering%family=FAMILY_SIMPLEX - tri_numbering%type=ELEMENT_LAGRANGIAN - - ! Degree 0 elements are a special case. - ele=>tri_numbering(0) - ele%degree=0 + ele%nodes=tr(i+1) + ele%count2number=0 + ele%number2count=0 - degree_loop: do i=0,TRI_MAX_DEGREE - ele=>tri_numbering(i) - ele%degree=i + l=0 + l(1)=i - ! Allocate mappings: - allocate(ele%count2number(0:i,0:i,0:i)) - allocate(ele%number2count(ele%dimension+1,tr(i+1))) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) + cnt=0 - ele%nodes=tr(i+1) - ele%count2number=0 - ele%number2count=0 + number_loop: do - l=0 - l(1)=i + cnt=cnt+1 - cnt=0 + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - number_loop: do + ! If the last index has reached the current degree then we are + ! done. + if (l(3)==i) exit number_loop - cnt=cnt+1 + ! Increment the index counter. + l(2)=l(2)+1 - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + do j=2,2 + ! This comparison implements the decreasing dimension lengths + ! as you move up the triangle. + if (l(j)>i-sum(l(j+1:))) then + l(j)=0 + l(j+1)=l(j+1)+1 + end if + end do - ! If the last index has reached the current degree then we are - ! done. - if (l(3)==i) exit number_loop + l(1)=i-sum(l(2:)) - ! Increment the index counter. - l(2)=l(2)+1 - do j=2,2 - ! This comparison implements the decreasing dimension lengths - ! as you move up the triangle. - if (l(j)>i-sum(l(j+1:))) then - l(j)=0 - l(j+1)=l(j+1)+1 - end if - end do + end do number_loop - l(1)=i-sum(l(2:)) + ! Sanity test + if (tr(i+1)/=cnt) then + ewrite(3,*) 'Counting error', i, tr(i+1), cnt + stop + end if + ! Number edges. + forall(j=1:ele%vertices) + ele%boundary_coord(j)=j + end forall + ! In a triangle all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 + end do degree_loop + + end subroutine number_triangles_lagrange + + subroutine number_triangles_bubble + ! Fill the values in in element_numbering. + integer :: i,j, cnt + integer, dimension(3) :: l + type(ele_numbering_type), pointer :: ele + + tri_numbering_bubble%faces=1 + tri_numbering_bubble%vertices=3 + tri_numbering_bubble%edges=3 + tri_numbering_bubble%dimension=2 + tri_numbering_bubble%boundaries=3 + tri_numbering_bubble%family=FAMILY_SIMPLEX + tri_numbering_bubble%type=ELEMENT_BUBBLE + + degree_loop: do i=1,TRI_BUBBLE_MAX_DEGREE + ele=>tri_numbering_bubble(i) + ele%degree=i + + ! Allocate mappings: + allocate(ele%count2number(0:i*(ele%dimension+1),0:i*(ele%dimension+1),0:i*(ele%dimension+1))) + allocate(ele%number2count(ele%dimension+1,tr(i+1)+1)) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) + + ele%nodes=tr(i+1)+1 + ele%count2number=0 + ele%number2count=0 - end do number_loop + l=0 + l(1)=i*(ele%dimension+1) - ! Sanity test - if (tr(i+1)/=cnt) then - ewrite(3,*) 'Counting error', i, tr(i+1), cnt - stop - end if + cnt=0 - ! Number edges. - forall(j=1:ele%vertices) - ele%boundary_coord(j)=j - end forall - ! In a triangle all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 - end do degree_loop + number_loop: do - end subroutine number_triangles_lagrange + cnt=cnt+1 - subroutine number_triangles_bubble - ! Fill the values in in element_numbering. - integer :: i,j, cnt - integer, dimension(3) :: l - type(ele_numbering_type), pointer :: ele + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - tri_numbering_bubble%faces=1 - tri_numbering_bubble%vertices=3 - tri_numbering_bubble%edges=3 - tri_numbering_bubble%dimension=2 - tri_numbering_bubble%boundaries=3 - tri_numbering_bubble%family=FAMILY_SIMPLEX - tri_numbering_bubble%type=ELEMENT_BUBBLE + ! If the last index has reached the current degree then we are + ! done. + if (l(3)==i*(ele%dimension+1)) exit number_loop - degree_loop: do i=1,TRI_BUBBLE_MAX_DEGREE - ele=>tri_numbering_bubble(i) - ele%degree=i + ! Increment the index counter. + l(2)=l(2)+ele%dimension+1 - ! Allocate mappings: - allocate(ele%count2number(0:i*(ele%dimension+1),0:i*(ele%dimension+1),0:i*(ele%dimension+1))) - allocate(ele%number2count(ele%dimension+1,tr(i+1)+1)) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) + do j=2,2 + ! This comparison implements the decreasing dimension lengths + ! as you move up the triangle. + if (l(j)>i*(ele%dimension+1)-sum(l(j+1:))) then + l(j)=0 + l(j+1)=l(j+1)+ele%dimension+1 + end if + end do - ele%nodes=tr(i+1)+1 - ele%count2number=0 - ele%number2count=0 + l(1)=i*(ele%dimension+1)-sum(l(2:)) - l=0 - l(1)=i*(ele%dimension+1) - cnt=0 + end do number_loop - number_loop: do + ! add in the bubble node + l(1) = i + l(2) = i + l(3) = i + cnt=cnt+1 + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - cnt=cnt+1 + ! Sanity test + if (tr(i+1)+1/=cnt) then + ewrite(-1,*) 'degree, nodes, cnt = ', i, tr(i+1)+1, cnt + FLAbort("Counting error") + end if - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + ! Number edges. + forall(j=1:ele%vertices) + ele%boundary_coord(j)=j + end forall + ! In a triangle all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 + end do degree_loop + + end subroutine number_triangles_bubble + + subroutine number_triangles_nc + ! Fill the values in in element_numbering. + integer :: j + type(ele_numbering_type), pointer :: ele + + tri_numbering_nc%faces=1 + tri_numbering_nc%vertices=3 + tri_numbering_nc%edges=3 + tri_numbering_nc%dimension=2 + tri_numbering_nc%type=ELEMENT_NONCONFORMING + tri_numbering_nc%boundaries=3 + tri_numbering_nc%family=FAMILY_SIMPLEX + tri_numbering_nc%type=ELEMENT_NONCONFORMING + + ele=>tri_numbering_nc + ele%degree=1 + + ! Allocate mappings: + allocate(ele%count2number(0:ele%degree,0:ele%degree,0:ele%degree)) + allocate(ele%number2count(ele%dimension+1,tr(ele%degree+1))) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) + + ele%nodes=tr(ele%degree+1) + ele%count2number=0 + ele%number2count=0 + + ! NOTE THAT THE FOLLOWING MAPPING IS NOT 1:1 !!!!! + ! These are the mappings for the shape function locations. + + ! This is the relationship between shape function and vertex numbers. + ! (Only for this element type) + ! 3 + ! / \ + ! 2 1 + ! / \ + ! 1---3---2 + ele%count2number(0,1,1)=1 + ele%count2number(1,0,1)=2 + ele%count2number(1,1,0)=3 + ! These are the mappings for the vertices. + ele%count2number(1,0,0)=1 + ele%count2number(0,1,0)=2 + ele%count2number(0,0,1)=3 + + ! NOTE THAT INVERSE MAPPINGS ARE ONLY DEFINED FOR SHAPE FUNCTIONS. + ele%number2count(:,1)=(/0,1,1/) + ele%number2count(:,2)=(/1,0,1/) + ele%number2count(:,3)=(/1,1,0/) + + ! Number edges. + forall(j=1:ele%vertices) + ele%boundary_coord(j)=j + end forall + ! In a triange all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 + + end subroutine number_triangles_nc + + subroutine number_triangles_trace + ! Fill the values in in element_numbering. + integer :: i,j, cnt, ll + integer, dimension(3) :: l + type(ele_numbering_type), pointer :: ele + + tri_numbering_trace%faces=1 + tri_numbering_trace%vertices=3 + tri_numbering_trace%edges=3 + tri_numbering_trace%dimension=2 + tri_numbering_trace%boundaries=3 + tri_numbering_trace%family=FAMILY_SIMPLEX + tri_numbering_trace%type=ELEMENT_TRACE + + ! Degree 0 elements are a special case. + ele=>tri_numbering_trace(0) + ele%degree=0 + + degree_loop: do i=0,TRI_MAX_DEGREE + ele=>tri_numbering_trace(i) + ele%degree=i + + ! Allocate mappings: + + ele%nodes=(ele%dimension+1)*(ele%degree+1) !faces x floc + + ! For trace elements, the first index is the facet number. + allocate(ele%count2number(1:ele%dimension+1,0:i,0:i)) + allocate(ele%number2count(ele%dimension+1,ele%nodes)) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) + + ele%count2number=0 + ele%number2count=0 - ! If the last index has reached the current degree then we are - ! done. - if (l(3)==i*(ele%dimension+1)) exit number_loop + l=0 + l(1)=ele%degree - ! Increment the index counter. - l(2)=l(2)+ele%dimension+1 + cnt=0 - do j=2,2 - ! This comparison implements the decreasing dimension lengths - ! as you move up the triangle. - if (l(j)>i*(ele%dimension+1)-sum(l(j+1:))) then - l(j)=0 - l(j+1)=l(j+1)+ele%dimension+1 - end if - end do + facet_loop: do ll=1,ele%dimension+1 - l(1)=i*(ele%dimension+1)-sum(l(2:)) + l=0 + l(1)=ll + number_loop: do j=0,ele%degree + cnt=cnt+1 + l(2:3)=(/ele%degree-j,j/) - end do number_loop + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - ! add in the bubble node - l(1) = i - l(2) = i - l(3) = i - cnt=cnt+1 - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + end do number_loop + end do facet_loop - ! Sanity test - if (tr(i+1)+1/=cnt) then - ewrite(-1,*) 'degree, nodes, cnt = ', i, tr(i+1)+1, cnt - FLAbort("Counting error") - end if - - ! Number edges. - forall(j=1:ele%vertices) - ele%boundary_coord(j)=j - end forall - ! In a triangle all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 - end do degree_loop - - end subroutine number_triangles_bubble - - subroutine number_triangles_nc - ! Fill the values in in element_numbering. - integer :: j - type(ele_numbering_type), pointer :: ele - - tri_numbering_nc%faces=1 - tri_numbering_nc%vertices=3 - tri_numbering_nc%edges=3 - tri_numbering_nc%dimension=2 - tri_numbering_nc%type=ELEMENT_NONCONFORMING - tri_numbering_nc%boundaries=3 - tri_numbering_nc%family=FAMILY_SIMPLEX - tri_numbering_nc%type=ELEMENT_NONCONFORMING - - ele=>tri_numbering_nc - ele%degree=1 - - ! Allocate mappings: - allocate(ele%count2number(0:ele%degree,0:ele%degree,0:ele%degree)) - allocate(ele%number2count(ele%dimension+1,tr(ele%degree+1))) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) - - ele%nodes=tr(ele%degree+1) - ele%count2number=0 - ele%number2count=0 - - ! NOTE THAT THE FOLLOWING MAPPING IS NOT 1:1 !!!!! - ! These are the mappings for the shape function locations. - - ! This is the relationship between shape function and vertex numbers. - ! (Only for this element type) - ! 3 - ! / \ - ! 2 1 - ! / \ - ! 1---3---2 - ele%count2number(0,1,1)=1 - ele%count2number(1,0,1)=2 - ele%count2number(1,1,0)=3 - ! These are the mappings for the vertices. - ele%count2number(1,0,0)=1 - ele%count2number(0,1,0)=2 - ele%count2number(0,0,1)=3 - - ! NOTE THAT INVERSE MAPPINGS ARE ONLY DEFINED FOR SHAPE FUNCTIONS. - ele%number2count(:,1)=(/0,1,1/) - ele%number2count(:,2)=(/1,0,1/) - ele%number2count(:,3)=(/1,1,0/) - - ! Number edges. - forall(j=1:ele%vertices) - ele%boundary_coord(j)=j - end forall - ! In a triange all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 - - end subroutine number_triangles_nc - - subroutine number_triangles_trace - ! Fill the values in in element_numbering. - integer :: i,j, cnt, ll - integer, dimension(3) :: l - type(ele_numbering_type), pointer :: ele - - tri_numbering_trace%faces=1 - tri_numbering_trace%vertices=3 - tri_numbering_trace%edges=3 - tri_numbering_trace%dimension=2 - tri_numbering_trace%boundaries=3 - tri_numbering_trace%family=FAMILY_SIMPLEX - tri_numbering_trace%type=ELEMENT_TRACE - - ! Degree 0 elements are a special case. - ele=>tri_numbering_trace(0) - ele%degree=0 - - degree_loop: do i=0,TRI_MAX_DEGREE - ele=>tri_numbering_trace(i) - ele%degree=i - - ! Allocate mappings: - - ele%nodes=(ele%dimension+1)*(ele%degree+1) !faces x floc - - ! For trace elements, the first index is the facet number. - allocate(ele%count2number(1:ele%dimension+1,0:i,0:i)) - allocate(ele%number2count(ele%dimension+1,ele%nodes)) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) - - ele%count2number=0 - ele%number2count=0 - - l=0 - l(1)=ele%degree - - cnt=0 - - facet_loop: do ll=1,ele%dimension+1 - - l=0 - l(1)=ll - number_loop: do j=0,ele%degree - - cnt=cnt+1 - l(2:3)=(/ele%degree-j,j/) - - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l - - end do number_loop - end do facet_loop - - ! Sanity test - if (ele%nodes/=cnt) then - ewrite(3,*) 'Counting error', i, ele%nodes, cnt - stop - end if - - ! For trace elements, the first local_coordinate is the face number. - ele%boundary_coord=1 - forall(j=1:ele%vertices) - ! The first local coordinate labels the face. - ele%boundary_val(j)=j - end forall - end do degree_loop - - end subroutine number_triangles_trace - - subroutine number_quads_trace - ! Fill the values in in element_numbering. - integer :: i,j, cnt, ll - integer, dimension(3) :: l - type(ele_numbering_type), pointer :: ele - - quad_numbering_trace%faces=1 - quad_numbering_trace%vertices=4 - quad_numbering_trace%edges=4 - quad_numbering_trace%dimension=2 - quad_numbering_trace%boundaries=4 - quad_numbering_trace%family=FAMILY_CUBE - quad_numbering_trace%type=ELEMENT_TRACE + ! Sanity test + if (ele%nodes/=cnt) then + ewrite(3,*) 'Counting error', i, ele%nodes, cnt + stop + end if - ! Degree 0 elements are a special case. - ele=>quad_numbering_trace(0) - ele%degree=0 + ! For trace elements, the first local_coordinate is the face number. + ele%boundary_coord=1 + forall(j=1:ele%vertices) + ! The first local coordinate labels the face. + ele%boundary_val(j)=j + end forall + end do degree_loop - degree_loop: do i=0,QUAD_MAX_DEGREE - ele=>quad_numbering_trace(i) - ele%degree=i + end subroutine number_triangles_trace - ! Allocate mappings: + subroutine number_quads_trace + ! Fill the values in in element_numbering. + integer :: i,j, cnt, ll + integer, dimension(3) :: l + type(ele_numbering_type), pointer :: ele - ele%nodes= 2**ele%dimension * (ele%degree + 1) ! faces x floc + quad_numbering_trace%faces=1 + quad_numbering_trace%vertices=4 + quad_numbering_trace%edges=4 + quad_numbering_trace%dimension=2 + quad_numbering_trace%boundaries=4 + quad_numbering_trace%family=FAMILY_CUBE + quad_numbering_trace%type=ELEMENT_TRACE - ! For trace elements, the first index is the facet number. - allocate(ele%count2number(1:2*ele%dimension,0:i,0:i)) - allocate(ele%number2count(ele%dimension+1,ele%nodes)) - allocate(ele%boundary_coord(ele%boundaries)) - allocate(ele%boundary_val(ele%boundaries)) + ! Degree 0 elements are a special case. + ele=>quad_numbering_trace(0) + ele%degree=0 - ele%count2number=0 - ele%number2count=0 + degree_loop: do i=0,QUAD_MAX_DEGREE + ele=>quad_numbering_trace(i) + ele%degree=i - l=0 - l(1)=ele%degree + ! Allocate mappings: - cnt=0 + ele%nodes= 2**ele%dimension * (ele%degree + 1) ! faces x floc - facet_loop: do ll=1,2*ele%dimension + ! For trace elements, the first index is the facet number. + allocate(ele%count2number(1:2*ele%dimension,0:i,0:i)) + allocate(ele%number2count(ele%dimension+1,ele%nodes)) + allocate(ele%boundary_coord(ele%boundaries)) + allocate(ele%boundary_val(ele%boundaries)) - l=0 + ele%count2number=0 + ele%number2count=0 - l(1)=ll - number_loop: do j=0,ele%degree + l=0 + l(1)=ele%degree - cnt=cnt+1 - l(2:3)=(/ele%degree-j,j/) + cnt=0 - ele%count2number(l(1), l(2), l(3))=cnt - ele%number2count(:,cnt)=l + facet_loop: do ll=1,2*ele%dimension - end do number_loop - end do facet_loop + l=0 - ! Sanity test - if (ele%nodes/=cnt) then - ewrite(0,*) 'Counting error', i, ele%nodes, cnt - stop - end if + l(1)=ll + number_loop: do j=0,ele%degree - ! For trace elements, the first local_coordinate is the face number. - ele%boundary_coord=1 - forall(j=1:ele%vertices) - ! The first local coordinate labels the face. - ele%boundary_val(j)=j - end forall - end do degree_loop - - end subroutine number_quads_trace - - subroutine number_intervals_lagrange - ! Fill the values in in element_numbering. - integer :: i, j, cnt - integer, dimension(2) :: l - type(ele_numbering_type), pointer :: ele - - interval_numbering%faces=0 - interval_numbering%vertices=2 - interval_numbering%edges=1 - interval_numbering%dimension=1 - interval_numbering%boundaries=2 - interval_numbering%family=FAMILY_SIMPLEX - interval_numbering%type=ELEMENT_LAGRANGIAN - - ! Degree 0 elements are a special case. - ele=>interval_numbering(0) - ele%degree=0 + cnt=cnt+1 + l(2:3)=(/ele%degree-j,j/) - degree_loop: do i=0,INTERVAL_MAX_DEGREE - ele=>interval_numbering(i) - ele%degree=i + ele%count2number(l(1), l(2), l(3))=cnt + ele%number2count(:,cnt)=l - ! Allocate mappings: - allocate(ele%count2number(0:i,0:i,0:0)) - allocate(ele%number2count(ele%dimension+1,i+1)) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) + end do number_loop + end do facet_loop - ele%nodes=i+1 - ele%count2number=0 - ele%number2count=0 + ! Sanity test + if (ele%nodes/=cnt) then + ewrite(0,*) 'Counting error', i, ele%nodes, cnt + stop + end if - l=0 - l(1)=i + ! For trace elements, the first local_coordinate is the face number. + ele%boundary_coord=1 + forall(j=1:ele%vertices) + ! The first local coordinate labels the face. + ele%boundary_val(j)=j + end forall + end do degree_loop + + end subroutine number_quads_trace + + subroutine number_intervals_lagrange + ! Fill the values in in element_numbering. + integer :: i, j, cnt + integer, dimension(2) :: l + type(ele_numbering_type), pointer :: ele + + interval_numbering%faces=0 + interval_numbering%vertices=2 + interval_numbering%edges=1 + interval_numbering%dimension=1 + interval_numbering%boundaries=2 + interval_numbering%family=FAMILY_SIMPLEX + interval_numbering%type=ELEMENT_LAGRANGIAN + + ! Degree 0 elements are a special case. + ele=>interval_numbering(0) + ele%degree=0 + + degree_loop: do i=0,INTERVAL_MAX_DEGREE + ele=>interval_numbering(i) + ele%degree=i + + ! Allocate mappings: + allocate(ele%count2number(0:i,0:i,0:0)) + allocate(ele%number2count(ele%dimension+1,i+1)) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) + + ele%nodes=i+1 + ele%count2number=0 + ele%number2count=0 - cnt=0 + l=0 + l(1)=i - number_loop: do + cnt=0 - cnt=cnt+1 + number_loop: do - ele%count2number(l(1), l(2), 0)=cnt - ele%number2count(:,cnt)=l + cnt=cnt+1 - ! If the last index has reached the current degree then we are - ! done. - if (l(2)==i) exit number_loop + ele%count2number(l(1), l(2), 0)=cnt + ele%number2count(:,cnt)=l - ! Increment the index counter. - l(2)=l(2)+1 + ! If the last index has reached the current degree then we are + ! done. + if (l(2)==i) exit number_loop - l(1)=i-l(2) + ! Increment the index counter. + l(2)=l(2)+1 - end do number_loop + l(1)=i-l(2) - ! Sanity test - if (i+1/=cnt) then - ewrite(3,*) 'Counting error', i, i+1, cnt - stop - end if + end do number_loop - ! Number edges. - forall(j=1:ele%vertices) - ele%boundary_coord(j)=j - end forall - ! In an interval all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 + ! Sanity test + if (i+1/=cnt) then + ewrite(3,*) 'Counting error', i, i+1, cnt + stop + end if - end do degree_loop - - end subroutine number_intervals_lagrange - - subroutine number_intervals_bubble - ! Fill the values in in element_numbering. - integer :: j, cnt - integer, dimension(2) :: l - type(ele_numbering_type), pointer :: ele - - interval_numbering_bubble%faces=0 - interval_numbering_bubble%vertices=2 - interval_numbering_bubble%edges=1 - interval_numbering_bubble%dimension=1 - interval_numbering_bubble%boundaries=2 - interval_numbering_bubble%family=FAMILY_SIMPLEX - interval_numbering_bubble%type=ELEMENT_BUBBLE - - ! we cannot exceed the bubble max degree of 1 because - ! the count2number map becomes nonunique when two nodes - ! are co-located - ele=>interval_numbering_bubble - ele%degree=1 - - ! Allocate mappings: - ! we need a lot of blank spaces here to make this - ! mapping bijective! - allocate(ele%count2number(0:(ele%dimension+1),0:(ele%dimension+1),0:0)) - allocate(ele%number2count(ele%dimension+1,3)) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) - - ele%nodes=3 - ele%count2number=0 - ele%number2count=0 - - l=0 - l(1)=ele%dimension+1 - - cnt=0 - - number_loop: do - ! this loop just takes care of the standard lagrangian element - ! nodes (i.e. it intentionally excludes the bubble node) - - cnt=cnt+1 - - ele%count2number(l(1), l(2), 0)=cnt - ele%number2count(:,cnt)=l + ! Number edges. + forall(j=1:ele%vertices) + ele%boundary_coord(j)=j + end forall + ! In an interval all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 - ! If the last index has reached the current degree then we are - ! done. - if (l(2)==(ele%dimension+1)) exit number_loop + end do degree_loop - ! Increment the index counter. - l(2)=l(2)+ele%dimension+1 + end subroutine number_intervals_lagrange - l(1)=ele%dimension+1-l(2) + subroutine number_intervals_bubble + ! Fill the values in in element_numbering. + integer :: j, cnt + integer, dimension(2) :: l + type(ele_numbering_type), pointer :: ele - end do number_loop + interval_numbering_bubble%faces=0 + interval_numbering_bubble%vertices=2 + interval_numbering_bubble%edges=1 + interval_numbering_bubble%dimension=1 + interval_numbering_bubble%boundaries=2 + interval_numbering_bubble%family=FAMILY_SIMPLEX + interval_numbering_bubble%type=ELEMENT_BUBBLE - ! add in the bubble node - l(1) = 1 - l(2) = 1 - cnt = cnt +1 - ele%count2number(l(1), l(2), 0)=cnt - ele%number2count(:,cnt)=l + ! we cannot exceed the bubble max degree of 1 because + ! the count2number map becomes nonunique when two nodes + ! are co-located + ele=>interval_numbering_bubble + ele%degree=1 - ! Sanity test - if (cnt/=3) then - ewrite(-1,*) 'Counting error', 1, 3, cnt - FLAbort("Counting error.") - end if + ! Allocate mappings: + ! we need a lot of blank spaces here to make this + ! mapping bijective! + allocate(ele%count2number(0:(ele%dimension+1),0:(ele%dimension+1),0:0)) + allocate(ele%number2count(ele%dimension+1,3)) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) - ! Number edges. - forall(j=1:ele%vertices) - ele%boundary_coord(j)=j - end forall - ! In an interval all faces occur on planes of zero value for one local coord. - ele%boundary_val=0 + ele%nodes=3 + ele%count2number=0 + ele%number2count=0 - end subroutine number_intervals_bubble + l=0 + l(1)=ele%dimension+1 - subroutine number_point_lagrange - !!< The highly complex 1 point 0D element. - type(ele_numbering_type), pointer :: ele - - point_numbering%faces=0 - point_numbering%vertices=1 - point_numbering%edges=0 - point_numbering%dimension=0 - point_numbering%boundaries=0 - point_numbering%family=FAMILY_SIMPLEX - point_numbering%type=ELEMENT_LAGRANGIAN - - ! Degree 0 elements are a special case. - ele=>point_numbering(0) - ele%degree=0 + cnt=0 - ! Allocate mappings: - allocate(ele%count2number(0:0,0:0,0:0)) - allocate(ele%number2count(ele%dimension+1,1)) - allocate(ele%boundary_coord(0)) - allocate(ele%boundary_val(0)) - - ele%nodes=1 - ele%count2number=1 - ele%number2count=0 + number_loop: do + ! this loop just takes care of the standard lagrangian element + ! nodes (i.e. it intentionally excludes the bubble node) - end subroutine number_point_lagrange + cnt=cnt+1 - subroutine number_hexes_lagrange - ! Fill the values in in element_numbering. - integer :: i,j, cnt, l1, l2, l3 - type(ele_numbering_type), pointer :: ele + ele%count2number(l(1), l(2), 0)=cnt + ele%number2count(:,cnt)=l - ! Currently only hexes are supported. - hex_numbering%faces=6 - hex_numbering%vertices=8 - hex_numbering%edges=12 - hex_numbering%dimension=3 - hex_numbering%boundaries=6 - hex_numbering%family=FAMILY_CUBE - hex_numbering%type=ELEMENT_LAGRANGIAN + ! If the last index has reached the current degree then we are + ! done. + if (l(2)==(ele%dimension+1)) exit number_loop - ! Degree 0 elements are a special case. - ele=>hex_numbering(0) - ele%degree=0 + ! Increment the index counter. + l(2)=l(2)+ele%dimension+1 - degree_loop: do i=0,HEX_MAX_DEGREE - ele=>hex_numbering(i) - ele%degree=i + l(1)=ele%dimension+1-l(2) - ! Allocate mappings: - allocate(ele%count2number(0:i,0:i,0:i)) - allocate(ele%number2count(ele%dimension,(i+1)**3)) - allocate(ele%boundary_coord(ele%faces)) - allocate(ele%boundary_val(ele%faces)) + end do number_loop - ele%nodes=(i+1)**3 + ! add in the bubble node + l(1) = 1 + l(2) = 1 + cnt = cnt +1 + ele%count2number(l(1), l(2), 0)=cnt + ele%number2count(:,cnt)=l - ele%count2number=0 - ele%number2count=0 + ! Sanity test + if (cnt/=3) then + ewrite(-1,*) 'Counting error', 1, 3, cnt + FLAbort("Counting error.") + end if + + ! Number edges. + forall(j=1:ele%vertices) + ele%boundary_coord(j)=j + end forall + ! In an interval all faces occur on planes of zero value for one local coord. + ele%boundary_val=0 + + end subroutine number_intervals_bubble + + subroutine number_point_lagrange + !!< The highly complex 1 point 0D element. + type(ele_numbering_type), pointer :: ele + + point_numbering%faces=0 + point_numbering%vertices=1 + point_numbering%edges=0 + point_numbering%dimension=0 + point_numbering%boundaries=0 + point_numbering%family=FAMILY_SIMPLEX + point_numbering%type=ELEMENT_LAGRANGIAN + + ! Degree 0 elements are a special case. + ele=>point_numbering(0) + ele%degree=0 + + ! Allocate mappings: + allocate(ele%count2number(0:0,0:0,0:0)) + allocate(ele%number2count(ele%dimension+1,1)) + allocate(ele%boundary_coord(0)) + allocate(ele%boundary_val(0)) + + ele%nodes=1 + ele%count2number=1 + ele%number2count=0 + + end subroutine number_point_lagrange + + subroutine number_hexes_lagrange + ! Fill the values in in element_numbering. + integer :: i,j, cnt, l1, l2, l3 + type(ele_numbering_type), pointer :: ele + + ! Currently only hexes are supported. + hex_numbering%faces=6 + hex_numbering%vertices=8 + hex_numbering%edges=12 + hex_numbering%dimension=3 + hex_numbering%boundaries=6 + hex_numbering%family=FAMILY_CUBE + hex_numbering%type=ELEMENT_LAGRANGIAN + + ! Degree 0 elements are a special case. + ele=>hex_numbering(0) + ele%degree=0 + + degree_loop: do i=0,HEX_MAX_DEGREE + ele=>hex_numbering(i) + ele%degree=i + + ! Allocate mappings: + allocate(ele%count2number(0:i,0:i,0:i)) + allocate(ele%number2count(ele%dimension,(i+1)**3)) + allocate(ele%boundary_coord(ele%faces)) + allocate(ele%boundary_val(ele%faces)) + + ele%nodes=(i+1)**3 + + ele%count2number=0 + ele%number2count=0 - cnt=0 + cnt=0 - do l1=0, ele%degree + do l1=0, ele%degree - do l2=0, ele%degree + do l2=0, ele%degree - do l3=0, ele%degree + do l3=0, ele%degree - cnt=cnt+1 + cnt=cnt+1 - ele%count2number(l1, l2, l3)=cnt - ele%number2count(:,cnt)=(/l1, l2, l3/) + ele%count2number(l1, l2, l3)=cnt + ele%number2count(:,cnt)=(/l1, l2, l3/) - end do + end do - end do + end do - end do + end do - ! Number faces. - forall(j=1:ele%faces) - ele%boundary_coord(j)=(j+1)/2 - end forall - ! In a hex all faces occur on planes of value -1/+1 for one local - ! coord, that is resp. 0 and degree in count coordinates - ele%boundary_val((/1,3,5/))=0 - ele%boundary_val((/2,4,6/))=ele%degree + ! Number faces. + forall(j=1:ele%faces) + ele%boundary_coord(j)=(j+1)/2 + end forall + ! In a hex all faces occur on planes of value -1/+1 for one local + ! coord, that is resp. 0 and degree in count coordinates + ele%boundary_val((/1,3,5/))=0 + ele%boundary_val((/2,4,6/))=ele%degree - end do degree_loop + end do degree_loop - end subroutine number_hexes_lagrange + end subroutine number_hexes_lagrange - subroutine number_quads_lagrange - ! Fill the values in in element_numbering. - integer :: i,j, cnt, l1, l2 - type(ele_numbering_type), pointer :: ele + subroutine number_quads_lagrange + ! Fill the values in in element_numbering. + integer :: i,j, cnt, l1, l2 + type(ele_numbering_type), pointer :: ele - ! Currently only quads are supported. - quad_numbering%faces=1 - quad_numbering%vertices=4 - quad_numbering%edges=4 - quad_numbering%dimension=2 - quad_numbering%boundaries=4 - quad_numbering%family=FAMILY_CUBE - quad_numbering%type=ELEMENT_LAGRANGIAN + ! Currently only quads are supported. + quad_numbering%faces=1 + quad_numbering%vertices=4 + quad_numbering%edges=4 + quad_numbering%dimension=2 + quad_numbering%boundaries=4 + quad_numbering%family=FAMILY_CUBE + quad_numbering%type=ELEMENT_LAGRANGIAN - ! Degree 0 elements are a special case. - ele=>quad_numbering(0) - ele%degree=0 + ! Degree 0 elements are a special case. + ele=>quad_numbering(0) + ele%degree=0 - degree_loop: do i=0,QUAD_MAX_DEGREE - ele=>quad_numbering(i) - ele%degree=i + degree_loop: do i=0,QUAD_MAX_DEGREE + ele=>quad_numbering(i) + ele%degree=i - ! Allocate mappings: - allocate(ele%count2number(0:i,0:i,0:0)) - allocate(ele%number2count(ele%dimension,(i+1)**2)) - allocate(ele%boundary_coord(ele%vertices)) - allocate(ele%boundary_val(ele%vertices)) + ! Allocate mappings: + allocate(ele%count2number(0:i,0:i,0:0)) + allocate(ele%number2count(ele%dimension,(i+1)**2)) + allocate(ele%boundary_coord(ele%vertices)) + allocate(ele%boundary_val(ele%vertices)) - ele%nodes=(i+1)**2 + ele%nodes=(i+1)**2 - ele%count2number=0 - ele%number2count=0 + ele%count2number=0 + ele%number2count=0 - cnt=0 + cnt=0 - do l1=0, ele%degree + do l1=0, ele%degree - do l2=0, ele%degree + do l2=0, ele%degree - cnt=cnt+1 + cnt=cnt+1 - ele%count2number(l1, l2, 0)=cnt - ele%number2count(:,cnt)=(/l1, l2/) + ele%count2number(l1, l2, 0)=cnt + ele%number2count(:,cnt)=(/l1, l2/) - end do + end do - end do + end do - ! Number faces. - forall(j=1:ele%vertices) - ele%boundary_coord(j)=(j+1)/2 - end forall - ! In a quad all faces occur on planes of value -1 and +1 for one local - ! coord. That is resp. 0 and ele%degree in 'count' coordinates - ele%boundary_val((/1,3/))=0 - ele%boundary_val((/2,4/))=ele%degree + ! Number faces. + forall(j=1:ele%vertices) + ele%boundary_coord(j)=(j+1)/2 + end forall + ! In a quad all faces occur on planes of value -1 and +1 for one local + ! coord. That is resp. 0 and ele%degree in 'count' coordinates + ele%boundary_val((/1,3/))=0 + ele%boundary_val((/2,4/))=ele%degree - end do degree_loop + end do degree_loop - end subroutine number_quads_lagrange + end subroutine number_quads_lagrange - pure function tr(n) - ! Return the nth triangular number - integer :: tr - integer, intent(in) :: n + pure function tr(n) + ! Return the nth triangular number + integer :: tr + integer, intent(in) :: n - tr=max(n,0)*(n+1)/2 + tr=max(n,0)*(n+1)/2 - end function tr + end function tr - pure function te(n) - ! Return the nth tetrahedral number - integer :: te - integer, intent(in) :: n + pure function te(n) + ! Return the nth tetrahedral number + integer :: te + integer, intent(in) :: n - te=max(n,0)*(n+1)*(n+2)/6 + te=max(n,0)*(n+1)*(n+2)/6 - end function te + end function te - pure function inv_tr(m) result (n) - ! Return n where m=tr(n). If m is not a triangular number, return -1 - integer :: n - integer, intent(in) :: m + pure function inv_tr(m) result (n) + ! Return n where m=tr(n). If m is not a triangular number, return -1 + integer :: n + integer, intent(in) :: m - integer :: i, tri + integer :: i, tri - i=0 + i=0 - do - i=i+1 + do + i=i+1 - tri=tr(i) + tri=tr(i) - if (tri==m) then - n=i - return - else if (tri>m) then - ! m is not a triangular number. - n=-1 - return - end if + if (tri==m) then + n=i + return + else if (tri>m) then + ! m is not a triangular number. + n=-1 + return + end if - end do + end do - end function inv_tr + end function inv_tr - pure function inv_te(m) result (n) - ! Return n where m=te(n). If m is not a tetrahedral number, return -1 - integer :: n - integer, intent(in) :: m + pure function inv_te(m) result (n) + ! Return n where m=te(n). If m is not a tetrahedral number, return -1 + integer :: n + integer, intent(in) :: m - integer :: i, tei + integer :: i, tei - i=0 + i=0 - do - i=i+1 + do + i=i+1 - tei=te(i) + tei=te(i) - if (tei==m) then - n=i - return - else if (tei>m) then - ! m is not a tetrahedral number. - n=-1 - return - end if + if (tei==m) then + n=i + return + else if (tei>m) then + ! m is not a tetrahedral number. + n=-1 + return + end if - end do + end do - end function inv_te + end function inv_te - pure function element_num_equal(element_num1,element_num2) - ! Return true if the two element_nums are equivalent. - logical :: element_num_equal - type(ele_numbering_type), intent(in) :: element_num1, element_num2 + pure function element_num_equal(element_num1,element_num2) + ! Return true if the two element_nums are equivalent. + logical :: element_num_equal + type(ele_numbering_type), intent(in) :: element_num1, element_num2 - element_num_equal = element_num1%faces==element_num2%faces & + element_num_equal = element_num1%faces==element_num2%faces & .and. element_num1%vertices==element_num2%vertices & .and. element_num1%edges==element_num2%edges & .and. element_num1%dimension==element_num2%dimension & @@ -1318,1064 +1318,1064 @@ pure function element_num_equal(element_num1,element_num2) .and. element_num1%degree==element_num2%degree & .and. element_num1%boundaries==element_num2%boundaries - end function element_num_equal - - function svertex_num(node, element, ele_num, stat) - ! Given a global vertex node number and a vector of node numbers - ! defining a tet or triangle, return the local node number of that vertex. - ! - ! If the element numbering ele_num is present then the node number in - ! that element is returned. Otherwise the node number for a linear element - ! is returned. - ! - ! If stat is present then it returns 1 if node is not in the - ! element and 0 otherwise. - integer :: svertex_num - integer, intent(in) :: node - integer, dimension(:), intent(in) :: element - type(ele_numbering_type), intent(in), optional :: ele_num - integer, intent(out), optional :: stat - - integer, dimension(4) :: l - - if (present(stat)) then - stat=0 - end if - - ! Find the vertex number on the tet. - svertex_num=minloc(array=element, dim=1, mask=(node==element)) - - if (svertex_num==0) then - if (present(stat)) then - stat=1 - return - else - FLAbort("Node is not part of an element in vertex_num.") - end if - end if - - if (present(ele_num)) then - ! Special case: 0 order elements have no vertices. - if (ele_num%degree==0) then - svertex_num=0 - return - end if - - ! Calculate the local count coordinate. - select case(ele_num%type) - case(ELEMENT_LAGRANGIAN) - l=0 - l(svertex_num)=ele_num%degree - case(ELEMENT_BUBBLE) - l=0 - l(svertex_num)=ele_num%degree*(ele_num%dimension+1) - case(ELEMENT_TRACE) - FLAbort("Trace elements do not have well defined vertices") - case default - FLAbort("Unknown element type") - end select - - ! Look up the node number of the vertex. - svertex_num=ele_num%count2number(l(1), l(2), l(3)) - end if - - end function svertex_num - - function vvertex_num(nodes, element, ele_num, stat) - ! Given a vector of global vertex node numbers and a vector of node - ! numbers defining a tet or triangle, return the local node number of those - ! vertices. - ! - ! If the element numbering ele_num is present then the node numbers in - ! that element are returned. Otherwise the node numbers for a linear element - ! are returned. - ! - ! If stat is present then it returns 1 if node is not in the - ! element and 0 otherwise. - integer, dimension(:), intent(in) :: nodes - integer, dimension(:), intent(in) :: element - type(ele_numbering_type), intent(in), optional :: ele_num - integer, intent(out), optional :: stat - integer, dimension(size(nodes)) :: vvertex_num - - integer :: i - - if (present(stat)) then - stat=0 - end if - - do i=1,size(nodes) - vvertex_num(i)=vertex_num(nodes(i), element, ele_num, stat) - end do - - end function vvertex_num - - function ele_num_local_vertices(ele_num) - ! Given an element numbering, return the local node numbers of its - ! vertices. - type(ele_numbering_type), intent(in) :: ele_num - integer, dimension(ele_num%vertices) :: ele_num_local_vertices - - integer, dimension(4) :: l - integer :: i, c - - select case (ele_num%type) - case (ELEMENT_LAGRANGIAN) - select case (ele_num%family) - case (FAMILY_SIMPLEX) - - ! Simplices - do i=1,ele_num%vertices - l=0 - l(i)=ele_num%degree + end function element_num_equal + + function svertex_num(node, element, ele_num, stat) + ! Given a global vertex node number and a vector of node numbers + ! defining a tet or triangle, return the local node number of that vertex. + ! + ! If the element numbering ele_num is present then the node number in + ! that element is returned. Otherwise the node number for a linear element + ! is returned. + ! + ! If stat is present then it returns 1 if node is not in the + ! element and 0 otherwise. + integer :: svertex_num + integer, intent(in) :: node + integer, dimension(:), intent(in) :: element + type(ele_numbering_type), intent(in), optional :: ele_num + integer, intent(out), optional :: stat + + integer, dimension(4) :: l + + if (present(stat)) then + stat=0 + end if + + ! Find the vertex number on the tet. + svertex_num=minloc(array=element, dim=1, mask=(node==element)) + + if (svertex_num==0) then + if (present(stat)) then + stat=1 + return + else + FLAbort("Node is not part of an element in vertex_num.") + end if + end if - ele_num_local_vertices(i)=ele_num%count2number(l(1),l(2),l(3)) + if (present(ele_num)) then + ! Special case: 0 order elements have no vertices. + if (ele_num%degree==0) then + svertex_num=0 + return + end if - end do + ! Calculate the local count coordinate. + select case(ele_num%type) + case(ELEMENT_LAGRANGIAN) + l=0 + l(svertex_num)=ele_num%degree + case(ELEMENT_BUBBLE) + l=0 + l(svertex_num)=ele_num%degree*(ele_num%dimension+1) + case(ELEMENT_TRACE) + FLAbort("Trace elements do not have well defined vertices") + case default + FLAbort("Unknown element type") + end select + + ! Look up the node number of the vertex. + svertex_num=ele_num%count2number(l(1), l(2), l(3)) + end if + + end function svertex_num + + function vvertex_num(nodes, element, ele_num, stat) + ! Given a vector of global vertex node numbers and a vector of node + ! numbers defining a tet or triangle, return the local node number of those + ! vertices. + ! + ! If the element numbering ele_num is present then the node numbers in + ! that element are returned. Otherwise the node numbers for a linear element + ! are returned. + ! + ! If stat is present then it returns 1 if node is not in the + ! element and 0 otherwise. + integer, dimension(:), intent(in) :: nodes + integer, dimension(:), intent(in) :: element + type(ele_numbering_type), intent(in), optional :: ele_num + integer, intent(out), optional :: stat + integer, dimension(size(nodes)) :: vvertex_num + + integer :: i + + if (present(stat)) then + stat=0 + end if + + do i=1,size(nodes) + vvertex_num(i)=vertex_num(nodes(i), element, ele_num, stat) + end do - case (FAMILY_CUBE) + end function vvertex_num + + function ele_num_local_vertices(ele_num) + ! Given an element numbering, return the local node numbers of its + ! vertices. + type(ele_numbering_type), intent(in) :: ele_num + integer, dimension(ele_num%vertices) :: ele_num_local_vertices + + integer, dimension(4) :: l + integer :: i, c + + select case (ele_num%type) + case (ELEMENT_LAGRANGIAN) + select case (ele_num%family) + case (FAMILY_SIMPLEX) + + ! Simplices + do i=1,ele_num%vertices + l=0 + l(i)=ele_num%degree + + ele_num_local_vertices(i)=ele_num%count2number(l(1),l(2),l(3)) + + end do + + case (FAMILY_CUBE) + + ! Degree zero element only has one node which is non-zero on all vertices. + if(ele_num%degree == 0) then + ele_num_local_vertices = 1 + return + end if + + l=0 + c=1 ! coordinate counter + do i=1, ele_num%vertices + ele_num_local_vertices( i )=ele_num%count2number(l(1), l(2), l(3)) + do c=1, ele_num%vertices + if (l(c)==0) then + l(c)=1 + exit + else + ! switch back to 0, continue with next binary digit + l(c)=0 + end if + end do + end do + assert(c==ele_num%dimension+1) - ! Degree zero element only has one node which is non-zero on all vertices. - if(ele_num%degree == 0) then - ele_num_local_vertices = 1 - return - end if + case default - l=0 - c=1 ! coordinate counter - do i=1, ele_num%vertices - ele_num_local_vertices( i )=ele_num%count2number(l(1), l(2), l(3)) - do c=1, ele_num%vertices - if (l(c)==0) then - l(c)=1 - exit - else - ! switch back to 0, continue with next binary digit - l(c)=0 - end if - end do - end do - assert(c==ele_num%dimension+1) + FLAbort('Unknown element shape.') - case default + end select - FLAbort('Unknown element shape.') + case (ELEMENT_BUBBLE) + select case (ele_num%family) + case (FAMILY_SIMPLEX) - end select + ! Simplices + do i=1,ele_num%vertices + l=0 + l(i)=ele_num%degree*(ele_num%dimension+1) - case (ELEMENT_BUBBLE) - select case (ele_num%family) - case (FAMILY_SIMPLEX) + ele_num_local_vertices(i)=ele_num%count2number(l(1),l(2),l(3)) - ! Simplices - do i=1,ele_num%vertices - l=0 - l(i)=ele_num%degree*(ele_num%dimension+1) + end do - ele_num_local_vertices(i)=ele_num%count2number(l(1),l(2),l(3)) + case default - end do + FLAbort('Unknown element shape.') - case default + end select - FLAbort('Unknown element shape.') + case (ELEMENT_TRACE) + FLAbort("Trace elements do not have well-defined vertices") + case default + FLAbort("Unknown element type") end select - case (ELEMENT_TRACE) - FLAbort("Trace elements do not have well-defined vertices") - - case default - FLAbort("Unknown element type") - end select - - end function ele_num_local_vertices - - !------------------------------------------------------------------------ - ! Extract element boundaries - !------------------------------------------------------------------------ - - pure function boundary_num_length(ele_num,interior) - !!< Determine the length of the vector returned by boundary_num. - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - integer :: boundary_num_length - - select case (ele_num%dimension) - case(1) - if (interior) then - boundary_num_length=0 - else - boundary_num_length=1 - end if - case (2) - if (interior) then - boundary_num_length=ele_num%degree-1 - else - boundary_num_length=ele_num%degree+1 - end if - case (3) - boundary_num_length=face_num_length(ele_num, interior) - end select - - end function boundary_num_length - - pure function edge_num_length(ele_num, interior) - ! Determine the length of the vector returned by edge_num. - integer :: edge_num_length - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - - if (interior.and.ele_num%type/=ELEMENT_TRACE) then - edge_num_length=ele_num%degree-1 - else - edge_num_length=ele_num%degree+1 - end if - - end function edge_num_length - - pure function face_num_length(ele_num, interior) - ! Determine the length of the vector returned by face_num. - integer :: face_num_length - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - - select case (ele_num%family) - case (FAMILY_SIMPLEX) - if (interior.and.ele_num%type/=ELEMENT_TRACE) then - face_num_length=tr(ele_num%degree-2) - else - face_num_length=tr(ele_num%degree+1) - end if - case (FAMILY_CUBE) - if (interior.and.ele_num%type/=ELEMENT_TRACE) then - face_num_length=(ele_num%degree-1)**2 - else - face_num_length=(ele_num%degree+1)**2 - end if - case default - ! can't flabort in a pure function, sorry - ! FLAbort("Unknown element family.") - face_num_length=-666 - end select - - end function face_num_length - - function numbering_boundary_numbering(ele_num, boundary) result (numbering) - !!< Give the local nodes associated with face face in ele_num. - !!< - !!< This is totally generic to all element shapes. Cute huh? - !!< - !!< The underlying principles are that nodes on one element boundary - !!< share one fixed local coordinate and that nodes on a boundary are - !!< ordered in the same order as those nodes occur in the element. - integer, intent(in) :: boundary - type(ele_numbering_type), intent(in) :: ele_num - integer, dimension(boundary_num_length(ele_num, .false.)) ::& - & numbering - - integer :: i, k, l - - k=0 - - do i=1,ele_num%nodes - - if (ele_num%number2count(ele_num%boundary_coord(boundary),i)==& - & ele_num%boundary_val(boundary)) then - ! We are on the face. - k=k+1 - numbering(k)=i - end if - - end do - - ASSERT(k==size(numbering)) - - select case (ele_num%family) - case (FAMILY_SIMPLEX) - - if (mod(boundary,2)==0) then - ! reverse ordering for even faces, so that orientation is - ! always positive with respect to the element: - if (ele_num%dimension==2) then - numbering=numbering(size(numbering):1:-1) - else if (ele_num%dimension==3) then - l=1 - i=size(numbering) - do - numbering(i:i+l-1)=numbering(i+l-1:i:-1) - l=l+1 - i=i-l - if (i<1) exit - end do - end if - - end if - - case (FAMILY_CUBE) - - if (boundary==1 .or. boundary==4 .or. boundary==6) then - ! reverse ordering so that orientation is - ! always positive with respect to the element: - numbering=numbering(size(numbering):1:-1) - end if - - case default - FLAbort("Unknown element family.") - end select - - end function numbering_boundary_numbering - - !------------------------------------------------------------------------ - ! Edge numbering routines. - !------------------------------------------------------------------------ - - function edge_num_no_int(nodes, element, ele_num, stat) - ! This function exists only to make interior in effect an optional - ! argument. - integer, dimension(2), intent(in) :: nodes - integer, dimension(:), intent(in) :: element - type(ele_numbering_type), intent(in) :: ele_num - integer, intent(out), optional :: stat - - integer, dimension(edge_num_length(ele_num, interior=.false.)) ::& - & edge_num_no_int - - edge_num_no_int = edge_num_int(nodes, element, ele_num, .false., stat) - - end function edge_num_no_int - - function edge_num_int(nodes, element, ele_num, interior, stat) - ! Given a pair of vertex node numbers and a vector of node numbers - ! defining a tet, hex, quad, or triangle, return the node numbers - ! of the edge elements along the edge from nodes(1) to nodes(2). - ! - ! The numbers returned are those for the element numbering ele_num and - ! they are in order from nodes(1) to nodes(2). - ! - ! If interior is present and true it indicates that vertices are to be - ! disregarded. - ! - ! If stat is present then it returns 1 if either node is not in the - ! element and 0 otherwise. - integer, dimension(2), intent(in) :: nodes - integer, dimension(:), intent(in) :: element - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - integer, intent(out), optional :: stat - - integer, dimension(edge_num_length(ele_num, interior)) :: edge_num_int - - integer, dimension(2) :: lnodes - - if (present(stat)) stat=0 - - ! Special case: degree 0 elements to not have edge nodes and elements - ! with degree <2 do not have interior edge nodes. - if (ele_num%type/=ELEMENT_TRACE .and.(ele_num%degree==0 .or. & - present_and_true(interior).and.ele_num%degree<2)) return + end function ele_num_local_vertices - ! Find the vertex numbers on the tet. - lnodes(1)=minloc(array=element, dim=1, mask=(nodes(1)==element)) - lnodes(2)=minloc(array=element, dim=1, mask=(nodes(2)==element)) - - if (any(nodes==0)) then - edge_num_int=0 - if (present(stat)) then - stat=1 - return - else - FLAbort("Nodes are not part of element in edge_num_int.") - end if - end if - - edge_num_int=edge_local_num(lnodes, ele_num, interior) - - end function edge_num_int - - function edge_local_num(nodes, ele_num, interior) - ! Given a pair of local vertex node numbers (ie in the range 1..4) - ! return the local node numbers of the edge elements along - ! the edge from nodes(1) to nodes(2) in order from nodes(1) to nodes(2). - ! - ! If interior is present and true it indicates that vertices are to be - ! disregarded. - ! - ! If stat is present then it returns 1 if either node is not in the - ! element and 0 otherwise. - integer, dimension(2), intent(in) :: nodes - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - - integer, dimension(edge_num_length(ele_num, interior)) :: edge_local_num - - integer, dimension(4) :: l - integer :: cnt, i, j, k, inc, inc_l - ! Local edge vertices for trace elements. - integer, dimension(2) :: ln - ! array for locating face in quad - integer, dimension(7) :: sum2face - integer, dimension(1:ele_num%vertices) :: vertices - - select case (ele_num%type) - case (ELEMENT_LAGRANGIAN) - select case (ele_num%family) - case (FAMILY_SIMPLEX) - l=0 - l(nodes(1))=ele_num%degree - cnt=0 - number_loop: do - ! Skip spurious boundary cases. - if (.not.present_and_true(interior) .or. all(& - l(nodes)/=0 .and. l(nodes)/=ele_num%degree)) then - cnt=cnt+1 + !------------------------------------------------------------------------ + ! Extract element boundaries + !------------------------------------------------------------------------ - edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) - end if + pure function boundary_num_length(ele_num,interior) + !!< Determine the length of the vector returned by boundary_num. + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior + integer :: boundary_num_length - ! Advance the index: - l(nodes)=l(nodes)+(/-1,1/) + select case (ele_num%dimension) + case(1) + if (interior) then + boundary_num_length=0 + else + boundary_num_length=1 + end if + case (2) + if (interior) then + boundary_num_length=ele_num%degree-1 + else + boundary_num_length=ele_num%degree+1 + end if + case (3) + boundary_num_length=face_num_length(ele_num, interior) + end select - ! Check for completion - if (any(l<0)) exit number_loop + end function boundary_num_length - end do number_loop - case (FAMILY_CUBE) + pure function edge_num_length(ele_num, interior) + ! Determine the length of the vector returned by edge_num. + integer :: edge_num_length + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior - ! If a quad element has degree zero then the local - if(ele_num%degree == 0) then - edge_local_num = 1 - return - end if - - ! Get local node numbers of vertices - vertices=local_vertices(ele_num) - - l=0 - k=1 ! bit mask - j=0 - do i=ele_num%dimension, 1, -1 - ! compute ith 'count' coordinate - l(i) = iand(vertices(nodes(1))-1, k)/k - - ! increment to go from node 1 to node 2: 0, -1 or +1 - inc_l = iand(vertices(nodes(2))-1, k)/k-l(i) - ! remember the coordinate in which node 1 and 2 differ: - if (inc_l/=0) then - j = i - inc = inc_l - end if - k=k*2 - end do - - if (j==0) then - FLAbort("The same node appears more than once in edge_local_num.") - end if - - ! instead of between 0 and 1, between 0 and degree - l=l*ele_num%degree - if (interior) then - ! leave out boundary nodes - do i=1, ele_num%degree-1 - l(j)=l(j)+inc - edge_local_num(i)=ele_num%count2number(l(1), l(2), l(3)) - end do - else - do i=0, ele_num%degree - edge_local_num(i+1)=ele_num%count2number(l(1), l(2), l(3)) - l(j)=l(j)+inc - end do - end if - - case default - FLAbort("Unknown element family.") - end select + if (interior.and.ele_num%type/=ELEMENT_TRACE) then + edge_num_length=ele_num%degree-1 + else + edge_num_length=ele_num%degree+1 + end if + + end function edge_num_length + + pure function face_num_length(ele_num, interior) + ! Determine the length of the vector returned by face_num. + integer :: face_num_length + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior - case (ELEMENT_BUBBLE) select case (ele_num%family) - case (FAMILY_SIMPLEX) - l=0 - l(nodes(1))=ele_num%degree*(ele_num%dimension+1) - cnt=0 - number_loop_b: do - ! Skip spurious boundary cases. - if (.not.present_and_true(interior) .or. all(& - l(nodes)/=0 .and. l(nodes)/=(ele_num%degree*(ele_num%dimension+1)))) then - cnt=cnt+1 + case (FAMILY_SIMPLEX) + if (interior.and.ele_num%type/=ELEMENT_TRACE) then + face_num_length=tr(ele_num%degree-2) + else + face_num_length=tr(ele_num%degree+1) + end if + case (FAMILY_CUBE) + if (interior.and.ele_num%type/=ELEMENT_TRACE) then + face_num_length=(ele_num%degree-1)**2 + else + face_num_length=(ele_num%degree+1)**2 + end if + case default + ! can't flabort in a pure function, sorry + ! FLAbort("Unknown element family.") + face_num_length=-666 + end select - edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) - end if + end function face_num_length - ! Advance the index: - l(nodes)=l(nodes)+(/-(ele_num%dimension+1),ele_num%dimension+1/) + function numbering_boundary_numbering(ele_num, boundary) result (numbering) + !!< Give the local nodes associated with face face in ele_num. + !!< + !!< This is totally generic to all element shapes. Cute huh? + !!< + !!< The underlying principles are that nodes on one element boundary + !!< share one fixed local coordinate and that nodes on a boundary are + !!< ordered in the same order as those nodes occur in the element. + integer, intent(in) :: boundary + type(ele_numbering_type), intent(in) :: ele_num + integer, dimension(boundary_num_length(ele_num, .false.)) ::& + & numbering - ! Check for completion - if (any(l<0)) exit number_loop_b + integer :: i, k, l - end do number_loop_b + k=0 - case default - FLAbort("Unknown element family.") - end select + do i=1,ele_num%nodes + + if (ele_num%number2count(ele_num%boundary_coord(boundary),i)==& + & ele_num%boundary_val(boundary)) then + ! We are on the face. + k=k+1 + numbering(k)=i + end if + + end do + + ASSERT(k==size(numbering)) - case (ELEMENT_TRACE) select case (ele_num%family) - case (FAMILY_SIMPLEX) - l=0 + case (FAMILY_SIMPLEX) - do i=1,3 - if(.not.any(nodes==i)) l(1)=i - end do - assert(l(1)/=0) + if (mod(boundary,2)==0) then + ! reverse ordering for even faces, so that orientation is + ! always positive with respect to the element: + if (ele_num%dimension==2) then + numbering=numbering(size(numbering):1:-1) + else if (ele_num%dimension==3) then + l=1 + i=size(numbering) + do + numbering(i:i+l-1)=numbering(i+l-1:i:-1) + l=l+1 + i=i-l + if (i<1) exit + end do + end if - if (nodes(2)>nodes(1)) then - ! Counting forward - ln = (/2,3/) - else - ! Counting backwards - ln = (/3,2/) end if - l(ln(1))=ele_num%degree - cnt=0 - trace_number_loop: do - cnt=cnt+1 + case (FAMILY_CUBE) - edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) - - ! Advance the index: - l(ln)=l(ln)+(/-1,1/) - - ! Check for completion - if (any(l<0)) exit trace_number_loop - - end do trace_number_loop - assert(cnt==size(edge_local_num)) - - case (FAMILY_CUBE) - l = 0 - !boundary_coord = (0,0,1,1) - !boundary_val = (0,1,0,1) - !numbering is - ! 4 - ! 3 4 - ! 1 2 - ! 1 2 - ! 3 - sum2face = (/0,0,3,1,0,2,4/) - if(sum(nodes)>7) then - FLAbort('bad vertex numbers') - end if - !first local coordinate is face number - l(1) = sum2face(sum(nodes)) - if(l(1)==0) then - FLAbort('bad vertex numbers') + if (boundary==1 .or. boundary==4 .or. boundary==6) then + ! reverse ordering so that orientation is + ! always positive with respect to the element: + numbering=numbering(size(numbering):1:-1) end if - if (nodes(2)>nodes(1)) then - ! Counting forward - ln = (/2,3/) + case default + FLAbort("Unknown element family.") + end select + + end function numbering_boundary_numbering + + !------------------------------------------------------------------------ + ! Edge numbering routines. + !------------------------------------------------------------------------ + + function edge_num_no_int(nodes, element, ele_num, stat) + ! This function exists only to make interior in effect an optional + ! argument. + integer, dimension(2), intent(in) :: nodes + integer, dimension(:), intent(in) :: element + type(ele_numbering_type), intent(in) :: ele_num + integer, intent(out), optional :: stat + + integer, dimension(edge_num_length(ele_num, interior=.false.)) ::& + & edge_num_no_int + + edge_num_no_int = edge_num_int(nodes, element, ele_num, .false., stat) + + end function edge_num_no_int + + function edge_num_int(nodes, element, ele_num, interior, stat) + ! Given a pair of vertex node numbers and a vector of node numbers + ! defining a tet, hex, quad, or triangle, return the node numbers + ! of the edge elements along the edge from nodes(1) to nodes(2). + ! + ! The numbers returned are those for the element numbering ele_num and + ! they are in order from nodes(1) to nodes(2). + ! + ! If interior is present and true it indicates that vertices are to be + ! disregarded. + ! + ! If stat is present then it returns 1 if either node is not in the + ! element and 0 otherwise. + integer, dimension(2), intent(in) :: nodes + integer, dimension(:), intent(in) :: element + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior + integer, intent(out), optional :: stat + + integer, dimension(edge_num_length(ele_num, interior)) :: edge_num_int + + integer, dimension(2) :: lnodes + + if (present(stat)) stat=0 + + ! Special case: degree 0 elements to not have edge nodes and elements + ! with degree <2 do not have interior edge nodes. + if (ele_num%type/=ELEMENT_TRACE .and.(ele_num%degree==0 .or. & + present_and_true(interior).and.ele_num%degree<2)) return + + ! Find the vertex numbers on the tet. + lnodes(1)=minloc(array=element, dim=1, mask=(nodes(1)==element)) + lnodes(2)=minloc(array=element, dim=1, mask=(nodes(2)==element)) + + if (any(nodes==0)) then + edge_num_int=0 + if (present(stat)) then + stat=1 + return else - ! Counting backwards - ln = (/3,2/) + FLAbort("Nodes are not part of element in edge_num_int.") end if + end if + + edge_num_int=edge_local_num(lnodes, ele_num, interior) + + end function edge_num_int + + function edge_local_num(nodes, ele_num, interior) + ! Given a pair of local vertex node numbers (ie in the range 1..4) + ! return the local node numbers of the edge elements along + ! the edge from nodes(1) to nodes(2) in order from nodes(1) to nodes(2). + ! + ! If interior is present and true it indicates that vertices are to be + ! disregarded. + ! + ! If stat is present then it returns 1 if either node is not in the + ! element and 0 otherwise. + integer, dimension(2), intent(in) :: nodes + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior + + integer, dimension(edge_num_length(ele_num, interior)) :: edge_local_num + + integer, dimension(4) :: l + integer :: cnt, i, j, k, inc, inc_l + ! Local edge vertices for trace elements. + integer, dimension(2) :: ln + ! array for locating face in quad + integer, dimension(7) :: sum2face + integer, dimension(1:ele_num%vertices) :: vertices + + select case (ele_num%type) + case (ELEMENT_LAGRANGIAN) + select case (ele_num%family) + case (FAMILY_SIMPLEX) + l=0 + l(nodes(1))=ele_num%degree + cnt=0 + number_loop: do + ! Skip spurious boundary cases. + if (.not.present_and_true(interior) .or. all(& + l(nodes)/=0 .and. l(nodes)/=ele_num%degree)) then + cnt=cnt+1 + + edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) + end if + + ! Advance the index: + l(nodes)=l(nodes)+(/-1,1/) + + ! Check for completion + if (any(l<0)) exit number_loop + + end do number_loop + case (FAMILY_CUBE) + + ! If a quad element has degree zero then the local + if(ele_num%degree == 0) then + edge_local_num = 1 + return + end if + + ! Get local node numbers of vertices + vertices=local_vertices(ele_num) + + l=0 + k=1 ! bit mask + j=0 + do i=ele_num%dimension, 1, -1 + ! compute ith 'count' coordinate + l(i) = iand(vertices(nodes(1))-1, k)/k + + ! increment to go from node 1 to node 2: 0, -1 or +1 + inc_l = iand(vertices(nodes(2))-1, k)/k-l(i) + ! remember the coordinate in which node 1 and 2 differ: + if (inc_l/=0) then + j = i + inc = inc_l + end if + k=k*2 + end do + + if (j==0) then + FLAbort("The same node appears more than once in edge_local_num.") + end if + + ! instead of between 0 and 1, between 0 and degree + l=l*ele_num%degree + if (interior) then + ! leave out boundary nodes + do i=1, ele_num%degree-1 + l(j)=l(j)+inc + edge_local_num(i)=ele_num%count2number(l(1), l(2), l(3)) + end do + else + do i=0, ele_num%degree + edge_local_num(i+1)=ele_num%count2number(l(1), l(2), l(3)) + l(j)=l(j)+inc + end do + end if - l(ln(1))=ele_num%degree - cnt=0 - trace_number_loop1: do - cnt=cnt+1 + case default + FLAbort("Unknown element family.") + end select + + case (ELEMENT_BUBBLE) + select case (ele_num%family) + case (FAMILY_SIMPLEX) + l=0 + l(nodes(1))=ele_num%degree*(ele_num%dimension+1) + cnt=0 + number_loop_b: do + ! Skip spurious boundary cases. + if (.not.present_and_true(interior) .or. all(& + l(nodes)/=0 .and. l(nodes)/=(ele_num%degree*(ele_num%dimension+1)))) then + cnt=cnt+1 - edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) + edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) + end if - ! Advance the index: - l(ln)=l(ln)+(/-1,1/) + ! Advance the index: + l(nodes)=l(nodes)+(/-(ele_num%dimension+1),ele_num%dimension+1/) - ! Check for completion - if (any(l<0)) exit trace_number_loop1 + ! Check for completion + if (any(l<0)) exit number_loop_b - end do trace_number_loop1 - assert(cnt==size(edge_local_num)) - case default - FLAbort("Unknown element family.") + end do number_loop_b + + case default + FLAbort("Unknown element family.") + end select + + case (ELEMENT_TRACE) + select case (ele_num%family) + case (FAMILY_SIMPLEX) + l=0 + + do i=1,3 + if(.not.any(nodes==i)) l(1)=i + end do + assert(l(1)/=0) + + if (nodes(2)>nodes(1)) then + ! Counting forward + ln = (/2,3/) + else + ! Counting backwards + ln = (/3,2/) + end if + + l(ln(1))=ele_num%degree + cnt=0 + trace_number_loop: do + cnt=cnt+1 + + edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) + + ! Advance the index: + l(ln)=l(ln)+(/-1,1/) + + ! Check for completion + if (any(l<0)) exit trace_number_loop + + end do trace_number_loop + assert(cnt==size(edge_local_num)) + + case (FAMILY_CUBE) + l = 0 + !boundary_coord = (0,0,1,1) + !boundary_val = (0,1,0,1) + !numbering is + ! 4 + ! 3 4 + ! 1 2 + ! 1 2 + ! 3 + sum2face = (/0,0,3,1,0,2,4/) + if(sum(nodes)>7) then + FLAbort('bad vertex numbers') + end if + !first local coordinate is face number + l(1) = sum2face(sum(nodes)) + if(l(1)==0) then + FLAbort('bad vertex numbers') + end if + + if (nodes(2)>nodes(1)) then + ! Counting forward + ln = (/2,3/) + else + ! Counting backwards + ln = (/3,2/) + end if + + l(ln(1))=ele_num%degree + cnt=0 + trace_number_loop1: do + cnt=cnt+1 + + edge_local_num(cnt)=ele_num%count2number(l(1), l(2), l(3)) + + ! Advance the index: + l(ln)=l(ln)+(/-1,1/) + + ! Check for completion + if (any(l<0)) exit trace_number_loop1 + + end do trace_number_loop1 + assert(cnt==size(edge_local_num)) + case default + FLAbort("Unknown element family.") + end select + + case default + FLAbort("Unknown element type") end select - case default - FLAbort("Unknown element type") - end select - - end function edge_local_num - - !------------------------------------------------------------------------ - ! Face numbering routines. - !------------------------------------------------------------------------ - - function face_num_no_int(nodes, element, ele_num, stat) - ! This function exists only to make interior in effect an optional - ! argument. - integer, dimension(3), intent(in) :: nodes - integer, dimension(:), intent(in) :: element - type(ele_numbering_type), intent(in) :: ele_num - integer, intent(out), optional :: stat - - integer, dimension(face_num_length(ele_num, interior=.false.)) ::& - & face_num_no_int - - face_num_no_int = face_num_int(nodes, element, ele_num, .false., stat) - - end function face_num_no_int - - function face_num_int(nodes, element, ele_num, interior, stat) - ! Given a triple of vertex node numbers and a 4-vector (or 8-vector - ! in case of hexes) of node numbers defining an element, - ! return the node numbers of the face elements on the - ! face defined by nodes. - ! - ! The numbers returned are those for the element numbering ele_num and - ! they are in the order given by the order in nodes. - ! - ! If stat is present then it returns 1 if any node is not in the - ! element and 0 otherwise. - integer, dimension(:), intent(in) :: nodes - integer, dimension(:), intent(in) :: element - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - integer, intent(out), optional :: stat - - integer, dimension(face_num_length(ele_num,interior)) :: face_num_int - - integer :: i - integer, dimension(size(nodes)) :: lnodes - - if (present(stat)) stat=0 - - ! Special case: degree 0 elements to not have face nodes - if (ele_num%degree==0.and.ele_num%type/=ELEMENT_TRACE) return - - do i=1, 3 - lnodes(i)=minloc(array=element, dim=1, mask=(element==nodes(i))) - end do - - ! Minloc returns 0 if all elements of mask are false. - if (any(lnodes==0)) then - if (present(stat)) then - stat=1 - return - else - FLAbort("Nodes are not part of an element in face_num_int.") - end if - end if - - face_num_int=face_local_num_int(lnodes, ele_num, interior) - - end function face_num_int - - function face_local_num_no_int(nodes, ele_num) - ! This function exists only to make interior in effect an optional - ! argument. - integer, dimension(:), intent(in) :: nodes - type(ele_numbering_type), intent(in) :: ele_num - !output variable - integer, dimension(face_num_length(ele_num, interior=.false.)) ::& - & face_local_num_no_int - - face_local_num_no_int = face_local_num_int(nodes, ele_num, .false.) - - end function face_local_num_no_int - - function face_local_num_int(nodes, ele_num, interior) - ! Given a triple of local vertex node numbers (ie in the range 1-4, - ! or in the range 1-8 in the case of hexes) - ! return the node numbers of the face elements on the - ! face defined by those nodes. - ! - ! The numbers returned are those for the element numbering ele_num and - ! they are in the order given by the order in nodes. - integer, dimension(:), intent(in) :: nodes - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - - integer, dimension(face_num_length(ele_num,interior)) :: face_local_num_int - integer, dimension(1:ele_num%vertices) :: vertices - - integer, dimension(4) :: l - integer :: i, j, k, cnt, j12, j13, inc12, inc13, tmp - - select case (ele_num%type) - case (ELEMENT_LAGRANGIAN) - select case (ele_num%family) - case (FAMILY_SIMPLEX) - l=0 - l(nodes(1))=ele_num%degree - cnt=0 - - number_loop: do - ! Skip spurious boundary cases. - if ((.not.interior) .or. all(& - l(nodes)/=0 .and. l(nodes)/=ele_num%degree)) then - cnt=cnt+1 + end function edge_local_num + + !------------------------------------------------------------------------ + ! Face numbering routines. + !------------------------------------------------------------------------ + + function face_num_no_int(nodes, element, ele_num, stat) + ! This function exists only to make interior in effect an optional + ! argument. + integer, dimension(3), intent(in) :: nodes + integer, dimension(:), intent(in) :: element + type(ele_numbering_type), intent(in) :: ele_num + integer, intent(out), optional :: stat - ! Do the actual numbering. - face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) - end if + integer, dimension(face_num_length(ele_num, interior=.false.)) ::& + & face_num_no_int - ! Advance the index: - l(nodes(2))=l(nodes(2))+1 + face_num_no_int = face_num_int(nodes, element, ele_num, .false., stat) - if (l(nodes(2))>ele_num%degree-sum(l(nodes(3:)))) then - l(nodes(2))=0 - l(nodes(3))=l(nodes(3))+1 - end if + end function face_num_no_int - l(nodes(1))=ele_num%degree-sum(l(nodes(2:))) + function face_num_int(nodes, element, ele_num, interior, stat) + ! Given a triple of vertex node numbers and a 4-vector (or 8-vector + ! in case of hexes) of node numbers defining an element, + ! return the node numbers of the face elements on the + ! face defined by nodes. + ! + ! The numbers returned are those for the element numbering ele_num and + ! they are in the order given by the order in nodes. + ! + ! If stat is present then it returns 1 if any node is not in the + ! element and 0 otherwise. + integer, dimension(:), intent(in) :: nodes + integer, dimension(:), intent(in) :: element + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior + integer, intent(out), optional :: stat - ! Check for completion - if (l(nodes(3))>ele_num%degree) exit number_loop + integer, dimension(face_num_length(ele_num,interior)) :: face_num_int - end do number_loop + integer :: i + integer, dimension(size(nodes)) :: lnodes - ! Sanity test. - ! assert(cnt==size(face_local_num_int)) - case (FAMILY_CUBE) + if (present(stat)) stat=0 - ! this first loop works out the count coordinates - ! of the first given node N, using the following formula: - ! l(i)=iand( N-1, 2**(3-i) ) / 2**(3-i) - ! also it finds out in which count coordinate node1 and node2 - ! differ and the increment in this coordinate needed to walk - ! from node1 to node2, stored in j12 and inc12 resp. - ! same for node1 and node3, stored in j13 and inc13 + ! Special case: degree 0 elements to not have face nodes + if (ele_num%degree==0.and.ele_num%type/=ELEMENT_TRACE) return - ! If a quad element has degree zero then the local - if(ele_num%degree == 0) then - face_local_num_int = 1 + do i=1, 3 + lnodes(i)=minloc(array=element, dim=1, mask=(element==nodes(i))) + end do + + ! Minloc returns 0 if all elements of mask are false. + if (any(lnodes==0)) then + if (present(stat)) then + stat=1 return - end if - - ! Get local node numbers of vertices - vertices=local_vertices(ele_num) - - l=0 - k=1 ! bit mask - j12=0 - j13=0 - do i=ele_num%dimension, 1, -1 - ! compute ith 'count' coordinate - l(i)=iand(vertices(nodes(1))-1, k)/k - - ! increment to go from node 1 to node 2: 0, -1 or +1 - tmp=iand(vertices(nodes(2))-1, k)/k-l(i) - ! remember the coordinate in which node 1 and 2 differ: - if (tmp /= 0) then - j12=i - inc12 = tmp - end if - - ! increment to go from node 1 to node 3: 0, -1 or +1 - tmp=iand(vertices(nodes(3))-1, k)/k-l(i) - ! remember the coordinate in which node 1 and 3 differ: - if (tmp/=0) then - j13=i - inc13 = tmp - end if - k=k*2 - end do - - if (j12==0 .or. j13==0) then - FLAbort("The same node appears more than once in edge_local_num.") - end if - - ! Now find the nodes on the face by walking through the count - ! numbers, starting at node1 and walking from node1 to node2 - ! in the inner loop, and from node1 to node3 in the outer loop - - ! instead of between 0 and 1, between 0 and degree - l=l*ele_num%degree - cnt=0 - if (interior) then - ! leave out boundary nodes - do i=1, ele_num%degree-1 - l(j13)=l(j13)+inc13 - k=l(j12) ! save original value of node1 - do j=1, ele_num%degree-1 - l(j12)=l(j12)+inc12 - cnt=cnt+1 - face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) - end do - l(j12)=k - end do - else - do i=0, ele_num%degree - k=l(j12) ! save original value of node1 - do j=0, ele_num%degree - cnt=cnt+1 - face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) - l(j12)=l(j12)+inc12 - end do - l(j12)=k - l(j13)=l(j13)+inc13 - end do - end if - - case default - - FLAbort("Unknown element family.") + else + FLAbort("Nodes are not part of an element in face_num_int.") + end if + end if + + face_num_int=face_local_num_int(lnodes, ele_num, interior) + + end function face_num_int + + function face_local_num_no_int(nodes, ele_num) + ! This function exists only to make interior in effect an optional + ! argument. + integer, dimension(:), intent(in) :: nodes + type(ele_numbering_type), intent(in) :: ele_num + !output variable + integer, dimension(face_num_length(ele_num, interior=.false.)) ::& + & face_local_num_no_int + + face_local_num_no_int = face_local_num_int(nodes, ele_num, .false.) + + end function face_local_num_no_int + + function face_local_num_int(nodes, ele_num, interior) + ! Given a triple of local vertex node numbers (ie in the range 1-4, + ! or in the range 1-8 in the case of hexes) + ! return the node numbers of the face elements on the + ! face defined by those nodes. + ! + ! The numbers returned are those for the element numbering ele_num and + ! they are in the order given by the order in nodes. + integer, dimension(:), intent(in) :: nodes + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior + + integer, dimension(face_num_length(ele_num,interior)) :: face_local_num_int + integer, dimension(1:ele_num%vertices) :: vertices + + integer, dimension(4) :: l + integer :: i, j, k, cnt, j12, j13, inc12, inc13, tmp + + select case (ele_num%type) + case (ELEMENT_LAGRANGIAN) + select case (ele_num%family) + case (FAMILY_SIMPLEX) + l=0 + l(nodes(1))=ele_num%degree + cnt=0 + + number_loop: do + ! Skip spurious boundary cases. + if ((.not.interior) .or. all(& + l(nodes)/=0 .and. l(nodes)/=ele_num%degree)) then + cnt=cnt+1 + + ! Do the actual numbering. + face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) + end if + + ! Advance the index: + l(nodes(2))=l(nodes(2))+1 + + if (l(nodes(2))>ele_num%degree-sum(l(nodes(3:)))) then + l(nodes(2))=0 + l(nodes(3))=l(nodes(3))+1 + end if + + l(nodes(1))=ele_num%degree-sum(l(nodes(2:))) + + ! Check for completion + if (l(nodes(3))>ele_num%degree) exit number_loop + + end do number_loop + + ! Sanity test. + ! assert(cnt==size(face_local_num_int)) + case (FAMILY_CUBE) + + ! this first loop works out the count coordinates + ! of the first given node N, using the following formula: + ! l(i)=iand( N-1, 2**(3-i) ) / 2**(3-i) + ! also it finds out in which count coordinate node1 and node2 + ! differ and the increment in this coordinate needed to walk + ! from node1 to node2, stored in j12 and inc12 resp. + ! same for node1 and node3, stored in j13 and inc13 + + ! If a quad element has degree zero then the local + if(ele_num%degree == 0) then + face_local_num_int = 1 + return + end if + + ! Get local node numbers of vertices + vertices=local_vertices(ele_num) + + l=0 + k=1 ! bit mask + j12=0 + j13=0 + do i=ele_num%dimension, 1, -1 + ! compute ith 'count' coordinate + l(i)=iand(vertices(nodes(1))-1, k)/k + + ! increment to go from node 1 to node 2: 0, -1 or +1 + tmp=iand(vertices(nodes(2))-1, k)/k-l(i) + ! remember the coordinate in which node 1 and 2 differ: + if (tmp /= 0) then + j12=i + inc12 = tmp + end if + + ! increment to go from node 1 to node 3: 0, -1 or +1 + tmp=iand(vertices(nodes(3))-1, k)/k-l(i) + ! remember the coordinate in which node 1 and 3 differ: + if (tmp/=0) then + j13=i + inc13 = tmp + end if + k=k*2 + end do + + if (j12==0 .or. j13==0) then + FLAbort("The same node appears more than once in edge_local_num.") + end if + + ! Now find the nodes on the face by walking through the count + ! numbers, starting at node1 and walking from node1 to node2 + ! in the inner loop, and from node1 to node3 in the outer loop + + ! instead of between 0 and 1, between 0 and degree + l=l*ele_num%degree + cnt=0 + if (interior) then + ! leave out boundary nodes + do i=1, ele_num%degree-1 + l(j13)=l(j13)+inc13 + k=l(j12) ! save original value of node1 + do j=1, ele_num%degree-1 + l(j12)=l(j12)+inc12 + cnt=cnt+1 + face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) + end do + l(j12)=k + end do + else + do i=0, ele_num%degree + k=l(j12) ! save original value of node1 + do j=0, ele_num%degree + cnt=cnt+1 + face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) + l(j12)=l(j12)+inc12 + end do + l(j12)=k + l(j13)=l(j13)+inc13 + end do + end if - end select - case (ELEMENT_BUBBLE) - select case (ele_num%family) - case (FAMILY_SIMPLEX) - l=0 - l(nodes(1))=ele_num%degree*(ele_num%dimension+1) - cnt=0 - - number_loop_b: do - ! Skip spurious boundary cases. - if ((.not.interior) .or. all(& + case default + + FLAbort("Unknown element family.") + + end select + case (ELEMENT_BUBBLE) + select case (ele_num%family) + case (FAMILY_SIMPLEX) + l=0 + l(nodes(1))=ele_num%degree*(ele_num%dimension+1) + cnt=0 + + number_loop_b: do + ! Skip spurious boundary cases. + if ((.not.interior) .or. all(& l(nodes)/=0 .and. l(nodes)/=(ele_num%degree*(ele_num%dimension+1)))) then - cnt=cnt+1 + cnt=cnt+1 - ! Do the actual numbering. - face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) - end if + ! Do the actual numbering. + face_local_num_int(cnt)=ele_num%count2number(l(1), l(2), l(3)) + end if - ! Advance the index: - l(nodes(2))=l(nodes(2))+ele_num%dimension+1 + ! Advance the index: + l(nodes(2))=l(nodes(2))+ele_num%dimension+1 - if (l(nodes(2))>ele_num%degree*(ele_num%dimension+1)-sum(l(nodes(3:)))) then - l(nodes(2))=0 - l(nodes(3))=l(nodes(3))+ele_num%dimension+1 - end if + if (l(nodes(2))>ele_num%degree*(ele_num%dimension+1)-sum(l(nodes(3:)))) then + l(nodes(2))=0 + l(nodes(3))=l(nodes(3))+ele_num%dimension+1 + end if - l(nodes(1))=ele_num%degree*(ele_num%dimension+1)-sum(l(nodes(2:))) + l(nodes(1))=ele_num%degree*(ele_num%dimension+1)-sum(l(nodes(2:))) - ! Check for completion - if (l(nodes(3))>(ele_num%degree*(ele_num%dimension+1))) exit number_loop_b + ! Check for completion + if (l(nodes(3))>(ele_num%degree*(ele_num%dimension+1))) exit number_loop_b - end do number_loop_b + end do number_loop_b - case default + case default - FLAbort("Unknown element family.") + FLAbort("Unknown element family.") + end select + case default + FLAbort("Unknown element type.") end select - case default - FLAbort("Unknown element type.") - end select - end function face_local_num_int + end function face_local_num_int - !------------------------------------------------- - !boundary numbering wrapper - !================================================= + !------------------------------------------------- + !boundary numbering wrapper + !================================================= - function boundary_local_num_no_int(nodes, ele_num) & - result (boundary_local_num) - integer, dimension(:), intent(in) :: nodes - type(ele_numbering_type), intent(in) :: ele_num - integer, dimension((boundary_num_length(ele_num, & + function boundary_local_num_no_int(nodes, ele_num) & + result (boundary_local_num) + integer, dimension(:), intent(in) :: nodes + type(ele_numbering_type), intent(in) :: ele_num + integer, dimension((boundary_num_length(ele_num, & interior = .false.))) :: boundary_local_num - select case (ele_num%dimension) - case(1) - if (nodes(1)==1) then - boundary_local_num=1 - else if (nodes(1)==2) then - boundary_local_num=ele_num%nodes - else - write(0,*) 'Error in boundary_local_num_no_int' - stop - end if - case (2) - boundary_local_num = & - edge_local_num(nodes, ele_num, interior = .false.) - case (3) - boundary_local_num = & - face_local_num_no_int(nodes, ele_num) - case default - write(0,*) 'Error in boundary_local_num_no_int' - stop - end select - - end function boundary_local_num_no_int - - function boundary_local_num_int(nodes, ele_num, interior) & - result (boundary_local_num) - integer, dimension(:), intent(in) :: nodes - type(ele_numbering_type), intent(in) :: ele_num - logical, intent(in) :: interior - integer, dimension((boundary_num_length(ele_num,interior))) & + select case (ele_num%dimension) + case(1) + if (nodes(1)==1) then + boundary_local_num=1 + else if (nodes(1)==2) then + boundary_local_num=ele_num%nodes + else + write(0,*) 'Error in boundary_local_num_no_int' + stop + end if + case (2) + boundary_local_num = & + edge_local_num(nodes, ele_num, interior = .false.) + case (3) + boundary_local_num = & + face_local_num_no_int(nodes, ele_num) + case default + write(0,*) 'Error in boundary_local_num_no_int' + stop + end select + + end function boundary_local_num_no_int + + function boundary_local_num_int(nodes, ele_num, interior) & + result (boundary_local_num) + integer, dimension(:), intent(in) :: nodes + type(ele_numbering_type), intent(in) :: ele_num + logical, intent(in) :: interior + integer, dimension((boundary_num_length(ele_num,interior))) & :: boundary_local_num - select case (ele_num%dimension) - case (1) - if (.not. interior) then - if (nodes(1)==1) then - boundary_local_num=1 - else if (nodes(1)==2) then - boundary_local_num=ele_num%nodes - else - write(0,*) 'Error in boundary_local_num_no_int' - stop - end if - end if - ! If interior then there is no boundary. - case (2) - boundary_local_num = & - edge_local_num(nodes, ele_num, interior) - case (3) - boundary_local_num = & - face_local_num(nodes, ele_num, interior) - case default - write(0,*) 'Error in boundary_local_num' - stop - end select - - end function boundary_local_num_int - - !------------------------------------------------------------------------ - ! Return all local nodes in the order determined by specified local vertices - !------------------------------------------------------------------------ - - function ele_local_num(nodes, ele_num) - !!< Given the local vertex numbers (1-4 for tets) in a certain order, - !!< return all local node numbers of ele_num in the corresponding order - !! nodes are the specified vertices - integer, dimension(:), intent(in) :: nodes - type(ele_numbering_type), intent(in) :: ele_num - integer, dimension(1:ele_num%nodes) :: ele_local_num - - ! count coordinate - integer, dimension(3) :: cc - integer :: i, j - - cc=(/ 0, 0, 0 /) - - if (ele_num%family/=FAMILY_SIMPLEX) then - FLAbort("ele_local_num currently only works for simplices") - end if - - if (ele_num%type==ELEMENT_TRACE) then - FLAbort("ele_local_num doesn't know about trace elements yet") - end if - - do i=1, ele_num%nodes - - do j=1, size(ele_num%number2count,1) - if (nodes(j)<=3) then - cc(nodes(j)) = ele_num%number2count(j, i) - end if - end do + select case (ele_num%dimension) + case (1) + if (.not. interior) then + if (nodes(1)==1) then + boundary_local_num=1 + else if (nodes(1)==2) then + boundary_local_num=ele_num%nodes + else + write(0,*) 'Error in boundary_local_num_no_int' + stop + end if + end if + ! If interior then there is no boundary. + case (2) + boundary_local_num = & + edge_local_num(nodes, ele_num, interior) + case (3) + boundary_local_num = & + face_local_num(nodes, ele_num, interior) + case default + write(0,*) 'Error in boundary_local_num' + stop + end select - if (size(ele_num%number2count,1)<3) cc(3)=0 - ele_local_num(i) = ele_num%count2number(cc(1), cc(2), cc(3)) + end function boundary_local_num_int - end do + !------------------------------------------------------------------------ + ! Return all local nodes in the order determined by specified local vertices + !------------------------------------------------------------------------ - end function ele_local_num + function ele_local_num(nodes, ele_num) + !!< Given the local vertex numbers (1-4 for tets) in a certain order, + !!< return all local node numbers of ele_num in the corresponding order + !! nodes are the specified vertices + integer, dimension(:), intent(in) :: nodes + type(ele_numbering_type), intent(in) :: ele_num + integer, dimension(1:ele_num%nodes) :: ele_local_num - !------------------------------------------------------------------------ - ! Local coordinate calculations. - !------------------------------------------------------------------------ + ! count coordinate + integer, dimension(3) :: cc + integer :: i, j - function ele_num_local_coords(n, ele_num) result (coords) - ! Work out the local coordinates of node n in ele_num. - integer, intent(in) :: n - type(ele_numbering_type), intent(in) :: ele_num - real, dimension(size(ele_num%number2count, 1)) :: coords + cc=(/ 0, 0, 0 /) - integer, dimension(size(ele_num%number2count, 1)) :: count_coords - integer :: i + if (ele_num%family/=FAMILY_SIMPLEX) then + FLAbort("ele_local_num currently only works for simplices") + end if - select case(ele_num%type) - case (ELEMENT_LAGRANGIAN) + if (ele_num%type==ELEMENT_TRACE) then + FLAbort("ele_local_num doesn't know about trace elements yet") + end if - select case (ele_num%family) - case (FAMILY_SIMPLEX) + do i=1, ele_num%nodes - if (ele_num%degree>0) then - coords=real(ele_num%number2count(:,n))/real(ele_num%degree) - else - ! Degree 0 elements have a single node in the centre of the - ! element. - coords=1.0/ele_num%vertices - end if + do j=1, size(ele_num%number2count,1) + if (nodes(j)<=3) then + cc(nodes(j)) = ele_num%number2count(j, i) + end if + end do - case (FAMILY_CUBE) + if (size(ele_num%number2count,1)<3) cc(3)=0 + ele_local_num(i) = ele_num%count2number(cc(1), cc(2), cc(3)) - if (ele_num%degree>0) then - coords=-1+ 2*real(ele_num%number2count(:,n))& - & /real(ele_num%degree) - else - ! Degree 0 elements have a single node in the centre of the - ! element. - coords=0.0 - end if + end do - case default + end function ele_local_num - FLAbort('Unknown element family.') + !------------------------------------------------------------------------ + ! Local coordinate calculations. + !------------------------------------------------------------------------ - end select + function ele_num_local_coords(n, ele_num) result (coords) + ! Work out the local coordinates of node n in ele_num. + integer, intent(in) :: n + type(ele_numbering_type), intent(in) :: ele_num + real, dimension(size(ele_num%number2count, 1)) :: coords - case (ELEMENT_BUBBLE) + integer, dimension(size(ele_num%number2count, 1)) :: count_coords + integer :: i - select case (ele_num%family) - case (FAMILY_SIMPLEX) + select case(ele_num%type) + case (ELEMENT_LAGRANGIAN) - if (ele_num%degree>0) then - coords=real(ele_num%number2count(:,n))/real(ele_num%degree*(ele_num%dimension+1)) - else - FLAbort('Illegal element degree') - end if + select case (ele_num%family) + case (FAMILY_SIMPLEX) - case default + if (ele_num%degree>0) then + coords=real(ele_num%number2count(:,n))/real(ele_num%degree) + else + ! Degree 0 elements have a single node in the centre of the + ! element. + coords=1.0/ele_num%vertices + end if - FLAbort('Unknown element family.') + case (FAMILY_CUBE) - end select + if (ele_num%degree>0) then + coords=-1+ 2*real(ele_num%number2count(:,n))& + & /real(ele_num%degree) + else + ! Degree 0 elements have a single node in the centre of the + ! element. + coords=0.0 + end if - case (ELEMENT_NONCONFORMING) + case default - coords=real(ele_num%number2count(:,n))/2.0 + FLAbort('Unknown element family.') - case (ELEMENT_TRACE) + end select - select case (ele_num%family) - case (FAMILY_SIMPLEX) + case (ELEMENT_BUBBLE) - count_coords=ele_num%number2count(:,n) - - if (ele_num%degree>0) then - do i=1,ele_num%dimension+1 - if (i0) then + coords=real(ele_num%number2count(:,n))/real(ele_num%degree*(ele_num%dimension+1)) + else + FLAbort('Illegal element degree') + end if + + case default + + FLAbort('Unknown element family.') + + end select + + case (ELEMENT_NONCONFORMING) - FLAbort('Unknown element family.') + coords=real(ele_num%number2count(:,n))/2.0 - end select + case (ELEMENT_TRACE) - case default + select case (ele_num%family) + case (FAMILY_SIMPLEX) - FLAbort('Illegal element type.') + count_coords=ele_num%number2count(:,n) + + if (ele_num%degree>0) then + do i=1,ele_num%dimension+1 + if (inull(), dn(:,:,:)=>null() - real, pointer :: n_s(:,:)=>null(), dn_s(:,:,:)=>null() - !! Polynomials defining shape functions and their derivatives. - type(polynomial), dimension(:,:), pointer :: spoly=>null(), dspoly=>null() - !! Link back to the node numbering used for this element. - type(ele_numbering_type), pointer :: numbering=>null() - !! Link back to the quadrature used for this element. - type(quadrature_type) :: quadrature - type(quadrature_type), pointer :: surface_quadrature=>null() - !! Pointer to the superconvergence data for this element. - type(superconvergence_type), pointer :: superconvergence=>null() - !! Pointer to constraints data for this element - type(constraints_type), pointer :: constraints=>null() - !! Reference count to prevent memory leaks. - type(refcount_type), pointer :: refcount=>null() - !! Dummy name to satisfy reference counting - character(len=0) :: name - end type element_type - - type superconvergence_type - !!< A structure to represent the superconvergent points of the element in question. - !!< This is in this module because it has to be in element_type, - !!< but Superconvergence.F90 depends on Elements.F90. So Elements.F90 - !!< cannot depend on Superconvergence.F90. (Fortran is a real pain.) - !! Number of superconvergent points - integer :: nsp - !! Locations of superconvergent points in local coordinates - !! allocated to nsp x loc - real, pointer :: l(:, :) - !! Shape functions at each superconvergent point. - !! loc x nsp - real, pointer :: n(:, :) - !! Derivatives of shape functions at each superconvergent point - !! loc x nsp x ndim - real, pointer :: dn(:, :, :) - end type superconvergence_type - - type constraints_type - !!< A type to encode the constraints from the local Lagrange basis for - !!< (Pn)^d vector-valued elements to another local basis, possibly for - !!< a proper subspace. This new basis must have DOFs consisting - !!< of either normal components on faces corresponding to a Lagrange - !!< basis for the normal component when restricted to each face, - !!< or coefficients of basis - !!< functions with vanishing normal components on all faces. - !! type of constraints - integer :: type - !! local dimension - integer :: dim - !! order of local Lagrange basis - integer :: degree - !! number of nodes for local Lagrange basis - integer :: loc - !! Number of constraints - integer :: n_constraints - !! basis of functions that are orthogonal to the - !! constrained vector space - !! dimension n_constraints x loc x dim - real, pointer :: orthogonal(:,:,:)=> null() - end type constraints_type - - integer, parameter, public :: CONSTRAINT_NONE =0, CONSTRAINT_BDFM = 1,& - & CONSTRAINT_RT = 2, CONSTRAINT_BDM = 3 - - interface allocate - module procedure allocate_element - module procedure allocate_constraints_type - end interface - - interface deallocate - module procedure deallocate_element - module procedure deallocate_constraints - end interface - - interface local_coords - module procedure element_local_coords - end interface - - interface local_coord_count - module procedure element_local_coord_count - end interface - - interface local_vertices - module procedure element_local_vertices - end interface - - interface boundary_numbering - module procedure element_boundary_numbering - end interface - - interface operator(==) - module procedure element_equal - end interface - - interface eval_shape - module procedure eval_shape_node, eval_shape_all_nodes - end interface - - interface eval_dshape - module procedure eval_dshape_node, eval_dshape_all_nodes - end interface + !!< This module provides derived types for finite elements and associated functions. + use FLDebug + use element_numbering + use reference_counting + use quadrature + use polynomials + implicit none + + type element_type + !!< Type to encode shape and quadrature information for an element. + integer :: dim !! 2d or 3d? + integer :: loc !! Number of nodes. + integer :: ngi !! Number of gauss points. + integer :: degree !! Polynomial degree of element. + !! Shape functions: n is for the primitive function, dn is for partial derivatives, dn_s is for partial derivatives on surfaces. + !! n is loc x ngi, dn is loc x ngi x dim + !! n_s is loc x sngi, dn_s is loc x sngi x dim + !! NOTE that both n_s and dn_s need to be reoriented before use so that they align with the arbitrary facet node ordering. + real, pointer :: n(:,:)=>null(), dn(:,:,:)=>null() + real, pointer :: n_s(:,:)=>null(), dn_s(:,:,:)=>null() + !! Polynomials defining shape functions and their derivatives. + type(polynomial), dimension(:,:), pointer :: spoly=>null(), dspoly=>null() + !! Link back to the node numbering used for this element. + type(ele_numbering_type), pointer :: numbering=>null() + !! Link back to the quadrature used for this element. + type(quadrature_type) :: quadrature + type(quadrature_type), pointer :: surface_quadrature=>null() + !! Pointer to the superconvergence data for this element. + type(superconvergence_type), pointer :: superconvergence=>null() + !! Pointer to constraints data for this element + type(constraints_type), pointer :: constraints=>null() + !! Reference count to prevent memory leaks. + type(refcount_type), pointer :: refcount=>null() + !! Dummy name to satisfy reference counting + character(len=0) :: name + end type element_type + + type superconvergence_type + !!< A structure to represent the superconvergent points of the element in question. + !!< This is in this module because it has to be in element_type, + !!< but Superconvergence.F90 depends on Elements.F90. So Elements.F90 + !!< cannot depend on Superconvergence.F90. (Fortran is a real pain.) + !! Number of superconvergent points + integer :: nsp + !! Locations of superconvergent points in local coordinates + !! allocated to nsp x loc + real, pointer :: l(:, :) + !! Shape functions at each superconvergent point. + !! loc x nsp + real, pointer :: n(:, :) + !! Derivatives of shape functions at each superconvergent point + !! loc x nsp x ndim + real, pointer :: dn(:, :, :) + end type superconvergence_type + + type constraints_type + !!< A type to encode the constraints from the local Lagrange basis for + !!< (Pn)^d vector-valued elements to another local basis, possibly for + !!< a proper subspace. This new basis must have DOFs consisting + !!< of either normal components on faces corresponding to a Lagrange + !!< basis for the normal component when restricted to each face, + !!< or coefficients of basis + !!< functions with vanishing normal components on all faces. + !! type of constraints + integer :: type + !! local dimension + integer :: dim + !! order of local Lagrange basis + integer :: degree + !! number of nodes for local Lagrange basis + integer :: loc + !! Number of constraints + integer :: n_constraints + !! basis of functions that are orthogonal to the + !! constrained vector space + !! dimension n_constraints x loc x dim + real, pointer :: orthogonal(:,:,:)=> null() + end type constraints_type + + integer, parameter, public :: CONSTRAINT_NONE =0, CONSTRAINT_BDFM = 1,& + & CONSTRAINT_RT = 2, CONSTRAINT_BDM = 3 + + interface allocate + module procedure allocate_element + module procedure allocate_constraints_type + end interface + + interface deallocate + module procedure deallocate_element + module procedure deallocate_constraints + end interface + + interface local_coords + module procedure element_local_coords + end interface + + interface local_coord_count + module procedure element_local_coord_count + end interface + + interface local_vertices + module procedure element_local_vertices + end interface + + interface boundary_numbering + module procedure element_boundary_numbering + end interface + + interface operator(==) + module procedure element_equal + end interface + + interface eval_shape + module procedure eval_shape_node, eval_shape_all_nodes + end interface + + interface eval_dshape + module procedure eval_dshape_node, eval_dshape_all_nodes + end interface #include "Reference_count_interface_element_type.F90" - private + private - public :: element_type, superconvergence_type, constraints_type,& - allocate, deallocate, local_coords, local_coord_count,& - local_vertices, boundary_numbering, operator(==), eval_shape,& - eval_dshape, make_constraints, eval_dshape_transformed + public :: element_type, superconvergence_type, constraints_type,& + allocate, deallocate, local_coords, local_coord_count,& + local_vertices, boundary_numbering, operator(==), eval_shape,& + eval_dshape, make_constraints, eval_dshape_transformed !! public objects from the reference counting - public :: new_refcount, incref, decref + public :: new_refcount, incref, decref contains - subroutine allocate_element(element, ele_num, ngi, ngi_s, type, stat) - !!< Allocate memory for an element_type. - type(element_type), intent(inout) :: element - !! Number of quadrature points - integer, intent(in) :: ngi - !! Element numbering - type(ele_numbering_type), intent(in) :: ele_num - !! Stat returns zero for success and nonzero otherwise. - integer, intent(in), optional :: ngi_s - integer, intent(in), optional :: type - integer, intent(out), optional :: stat - ! - integer :: lstat, coords, ltype - - if(present(type)) then - ltype = type - else - ltype = ele_num%type - end if - - select case(ele_num%family) - case (FAMILY_SIMPLEX) - coords=ele_num%dimension+1 - case (FAMILY_CUBE) - if(ele_num%type==ELEMENT_TRACE .and. ele_num%dimension==2) then - !For trace elements the local coordinate is face number - !then the local coordinates on the face - !For quads, the face is an interval element which has - !two local coordinates. - coords=3 - else - coords=ele_num%dimension - end if - case default - FLAbort('Illegal element family.') - end select - - select case(ltype) - case(ELEMENT_LAGRANGIAN, ELEMENT_NONCONFORMING, & - &ELEMENT_BUBBLE, ELEMENT_TRACE) - - allocate(element%n(ele_num%nodes,ngi),& - &element%dn(ele_num%nodes,ngi,ele_num%dimension), & - &element%spoly(coords,ele_num%nodes), & - &element%dspoly(coords,ele_num%nodes), stat=lstat) - - case(ELEMENT_CONTROLVOLUME_SURFACE) - - allocate(element%n(ele_num%nodes,ngi),& - &element%dn(ele_num%nodes,ngi,ele_num%dimension-1), & - stat=lstat) - - element%spoly=>null() - element%dspoly=>null() - - case(ELEMENT_CONTROLVOLUMEBDY_SURFACE) - - allocate(element%n(ele_num%nodes,ngi),& - &element%dn(ele_num%nodes,ngi,ele_num%dimension), & - stat=lstat) + subroutine allocate_element(element, ele_num, ngi, ngi_s, type, stat) + !!< Allocate memory for an element_type. + type(element_type), intent(inout) :: element + !! Number of quadrature points + integer, intent(in) :: ngi + !! Element numbering + type(ele_numbering_type), intent(in) :: ele_num + !! Stat returns zero for success and nonzero otherwise. + integer, intent(in), optional :: ngi_s + integer, intent(in), optional :: type + integer, intent(out), optional :: stat + ! + integer :: lstat, coords, ltype + + if(present(type)) then + ltype = type + else + ltype = ele_num%type + end if + + select case(ele_num%family) + case (FAMILY_SIMPLEX) + coords=ele_num%dimension+1 + case (FAMILY_CUBE) + if(ele_num%type==ELEMENT_TRACE .and. ele_num%dimension==2) then + !For trace elements the local coordinate is face number + !then the local coordinates on the face + !For quads, the face is an interval element which has + !two local coordinates. + coords=3 + else + coords=ele_num%dimension + end if + case default + FLAbort('Illegal element family.') + end select - element%spoly=>null() - element%dspoly=>null() + select case(ltype) + case(ELEMENT_LAGRANGIAN, ELEMENT_NONCONFORMING, & + &ELEMENT_BUBBLE, ELEMENT_TRACE) - case default + allocate(element%n(ele_num%nodes,ngi),& + &element%dn(ele_num%nodes,ngi,ele_num%dimension), & + &element%spoly(coords,ele_num%nodes), & + &element%dspoly(coords,ele_num%nodes), stat=lstat) - FLAbort("Attempt to select an illegal element type.") + case(ELEMENT_CONTROLVOLUME_SURFACE) - end select + allocate(element%n(ele_num%nodes,ngi),& + &element%dn(ele_num%nodes,ngi,ele_num%dimension-1), & + stat=lstat) - element%loc=ele_num%nodes - element%ngi=ngi - element%dim=ele_num%dimension + element%spoly=>null() + element%dspoly=>null() - if (present(ngi_s)) then - allocate(element%n_s(ele_num%nodes,ngi_s), & - element%dn_s(ele_num%nodes,ngi_s,ele_num%dimension), stat=lstat) - else - nullify(element%n_s) - nullify(element%dn_s) - end if + case(ELEMENT_CONTROLVOLUMEBDY_SURFACE) - nullify(element%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(element) + allocate(element%n(ele_num%nodes,ngi),& + &element%dn(ele_num%nodes,ngi,ele_num%dimension), & + stat=lstat) - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Unable to allocate element.") - end if + element%spoly=>null() + element%dspoly=>null() - end subroutine allocate_element + case default - subroutine allocate_constraints_type(constraint, element, type, stat) - !!< Allocate memory for a constraints type - type(element_type), intent(in) :: element - type(constraints_type), intent(inout) :: constraint - integer, intent(in) :: type !type of constraint - !! Stat returns zero for success and nonzero otherwise. - integer, intent(out), optional :: stat - ! - integer :: lstat + FLAbort("Attempt to select an illegal element type.") - lstat = 0 - constraint%type = type - constraint%dim = element%dim - constraint%loc = element%loc - constraint%degree = element%degree + end select - select case (type) - case (CONSTRAINT_BDFM) - select case(element%numbering%family) - case (FAMILY_SIMPLEX) - if(constraint%degree<3) then - constraint%n_constraints = constraint%dim+1 - else - FLAbort('High order not supported yet') - end if - case (FAMILY_CUBE) - FLExit('Haven''t implemented BDFM1 on quads yet.') - case default - FLAbort('Illegal element family.') - end select - case (CONSTRAINT_RT) - select case(element%numbering%family) - case (FAMILY_SIMPLEX) - FLExit('Haven''t implemented RT0 on simplices yet.') - if(constraint%degree<3) then - constraint%n_constraints = constraint%dim+1 - else - FLAbort('High order not supported yet') - end if - case (FAMILY_CUBE) - if(constraint%degree<3) then - constraint%n_constraints = 2**(constraint%dim) - else - FLAbort('High order not supported yet') - end if + element%loc=ele_num%nodes + element%ngi=ngi + element%dim=ele_num%dimension + + if (present(ngi_s)) then + allocate(element%n_s(ele_num%nodes,ngi_s), & + element%dn_s(ele_num%nodes,ngi_s,ele_num%dimension), stat=lstat) + else + nullify(element%n_s) + nullify(element%dn_s) + end if + + nullify(element%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(element) + + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Unable to allocate element.") + end if + + end subroutine allocate_element + + subroutine allocate_constraints_type(constraint, element, type, stat) + !!< Allocate memory for a constraints type + type(element_type), intent(in) :: element + type(constraints_type), intent(inout) :: constraint + integer, intent(in) :: type !type of constraint + !! Stat returns zero for success and nonzero otherwise. + integer, intent(out), optional :: stat + ! + integer :: lstat + + lstat = 0 + constraint%type = type + constraint%dim = element%dim + constraint%loc = element%loc + constraint%degree = element%degree + + select case (type) + case (CONSTRAINT_BDFM) + select case(element%numbering%family) + case (FAMILY_SIMPLEX) + if(constraint%degree<3) then + constraint%n_constraints = constraint%dim+1 + else + FLAbort('High order not supported yet') + end if + case (FAMILY_CUBE) + FLExit('Haven''t implemented BDFM1 on quads yet.') + case default + FLAbort('Illegal element family.') + end select + case (CONSTRAINT_RT) + select case(element%numbering%family) + case (FAMILY_SIMPLEX) + FLExit('Haven''t implemented RT0 on simplices yet.') + if(constraint%degree<3) then + constraint%n_constraints = constraint%dim+1 + else + FLAbort('High order not supported yet') + end if + case (FAMILY_CUBE) + if(constraint%degree<3) then + constraint%n_constraints = 2**(constraint%dim) + else + FLAbort('High order not supported yet') + end if + case default + FLAbort('Illegal element family.') + end select + case (CONSTRAINT_BDM) + constraint%n_constraints = 0 + case (CONSTRAINT_NONE) + constraint%n_constraints = 0 case default - FLAbort('Illegal element family.') - end select - case (CONSTRAINT_BDM) - constraint%n_constraints = 0 - case (CONSTRAINT_NONE) - constraint%n_constraints = 0 - case default - FLExit('Unknown constraint type') - end select - - if(constraint%n_constraints>0) then - allocate(& + FLExit('Unknown constraint type') + end select + + if(constraint%n_constraints>0) then + allocate(& constraint%orthogonal(constraint%n_constraints,& constraint%loc,constraint%dim),stat=lstat) - if(lstat==0) then - call make_constraints(constraint,element%numbering%family) - end if - end if - - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Unable to allocate element.") - end if - - end subroutine allocate_constraints_type - - subroutine deallocate_element(element, stat) - type(element_type), intent(inout) :: element - integer, intent(out), optional :: stat - - integer :: lstat, tstat - integer :: i,j - - tstat = 0 - lstat = 0 - - call decref(element) - if (has_references(element)) then - ! There are still references to this element so we don't deallocate. - return - end if - - call deallocate(element%quadrature) - - if (associated(element%surface_quadrature)) then - call deallocate(element%surface_quadrature) - deallocate(element%surface_quadrature, stat=tstat) - end if - lstat=max(lstat,tstat) - - if(associated(element%spoly)) then - do i=1,size(element%spoly,1) - do j=1,size(element%spoly,2) - call deallocate(element%spoly(i,j)) - end do - end do - deallocate(element%spoly, stat=tstat) - end if - lstat=max(lstat,tstat) + if(lstat==0) then + call make_constraints(constraint,element%numbering%family) + end if + end if + + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Unable to allocate element.") + end if + + end subroutine allocate_constraints_type + + subroutine deallocate_element(element, stat) + type(element_type), intent(inout) :: element + integer, intent(out), optional :: stat + + integer :: lstat, tstat + integer :: i,j + + tstat = 0 + lstat = 0 + + call decref(element) + if (has_references(element)) then + ! There are still references to this element so we don't deallocate. + return + end if + + call deallocate(element%quadrature) + + if (associated(element%surface_quadrature)) then + call deallocate(element%surface_quadrature) + deallocate(element%surface_quadrature, stat=tstat) + end if + lstat=max(lstat,tstat) + + if(associated(element%spoly)) then + do i=1,size(element%spoly,1) + do j=1,size(element%spoly,2) + call deallocate(element%spoly(i,j)) + end do + end do + deallocate(element%spoly, stat=tstat) + end if + lstat=max(lstat,tstat) + + if (associated(element%n_s)) deallocate(element%n_s,element%dn_s) + + if(associated(element%dspoly)) then + do i=1,size(element%dspoly,1) + do j=1,size(element%dspoly,2) + call deallocate(element%dspoly(i,j)) + end do + end do + deallocate(element%dspoly, stat=tstat) + end if + lstat=max(lstat,tstat) + + deallocate(element%n,element%dn, stat=tstat) + lstat=max(lstat,tstat) + + if(associated(element%constraints)) then + call deallocate(element%constraints,stat=tstat) + lstat = max(lstat,tstat) + + deallocate(element%constraints, stat=tstat) + lstat = max(lstat,tstat) + end if + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Unable to deallocate element.") + end if + + end subroutine deallocate_element + + subroutine deallocate_constraints(constraint, stat) + type(constraints_type), intent(inout) :: constraint + integer, intent(out), optional :: stat + + integer :: lstat + + lstat = 0 + + if(associated(constraint%orthogonal)) then + deallocate(constraint%orthogonal,stat=lstat) + end if + + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Unable to deallocate constraints.") + end if + + end subroutine deallocate_constraints + + function element_local_coords(n, element) result (coords) + !!< Work out the local coordinates of node n in element. This is just a + !!< wrapper function which allows local_coords to be called on an element + !!< instead of on an element numbering. + integer, intent(in) :: n + type(element_type), intent(in) :: element + real, dimension(size(element%numbering%number2count, 1)) :: coords + + coords=local_coords(n, element%numbering) + + end function element_local_coords + + function element_local_coord_count(element) result (n) + !!< Return the number of local coordinates associated with element. + integer :: n + type(element_type), intent(in) :: element + + n=size(element%numbering%number2count, 1) + + end function element_local_coord_count + + function element_local_vertices(element) result (vertices) + !!< Given an element numbering, return the local node numbers of its + !!< vertices. This is just a wrapper hich allows local_vertices to + !!< be called on an element instead of on an element numbering. + type(element_type), intent(in) :: element + integer, dimension(element%numbering%vertices) :: vertices + + vertices=local_vertices(element%numbering) + + end function element_local_vertices + + function element_boundary_numbering(element, boundary) + !!< A wrapper function which allows boundary_numbering to be called on + !!< an element instead of on an element_numbering. + integer, intent(in) :: boundary + type(element_type), intent(in) :: element + integer, dimension(boundary_num_length(element%numbering, .false.)) ::& + & element_boundary_numbering + + element_boundary_numbering=boundary_numbering(element%numbering,& + & boundary) + + end function element_boundary_numbering - if (associated(element%n_s)) deallocate(element%n_s,element%dn_s) + pure function element_equal(element1,element2) + !!< Return true if the two elements are equivalent. + logical :: element_equal + type(element_type), intent(in) :: element1, element2 - if(associated(element%dspoly)) then - do i=1,size(element%dspoly,1) - do j=1,size(element%dspoly,2) - call deallocate(element%dspoly(i,j)) - end do - end do - deallocate(element%dspoly, stat=tstat) - end if - lstat=max(lstat,tstat) + element_equal = element1%dim==element2%dim & + .and. element1%loc==element2%loc & + .and. element1%ngi==element2%ngi & + .and. element1%numbering==element2%numbering & + .and. element1%quadrature==element2%quadrature - deallocate(element%n,element%dn, stat=tstat) - lstat=max(lstat,tstat) + end function element_equal - if(associated(element%constraints)) then - call deallocate(element%constraints,stat=tstat) - lstat = max(lstat,tstat) + pure function eval_shape_node(shape, node, l) result(eval_shape) + ! Evaluate the shape function for node node local coordinates l + real :: eval_shape + type(element_type), intent(in) :: shape + integer, intent(in) :: node + real, dimension(size(shape%spoly,1)), intent(in) :: l - deallocate(element%constraints, stat=tstat) - lstat = max(lstat,tstat) - end if - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Unable to deallocate element.") - end if + integer :: i - end subroutine deallocate_element + eval_shape=1.0 - subroutine deallocate_constraints(constraint, stat) - type(constraints_type), intent(inout) :: constraint - integer, intent(out), optional :: stat + do i=1,size(shape%spoly,1) - integer :: lstat + ! Raw shape function + eval_shape=eval_shape*eval(shape%spoly(i,node), l(i)) - lstat = 0 + end do - if(associated(constraint%orthogonal)) then - deallocate(constraint%orthogonal,stat=lstat) - end if + end function eval_shape_node + + pure function eval_shape_all_nodes(shape, l) result(n) + ! Evaluate the shape function for all locations at local coordinates l + type(element_type), intent(in) :: shape + real, dimension(size(shape%spoly,1)), intent(in) :: l + real, dimension(shape%loc) :: n + + integer :: i,j + + ! for P0,P1 and P2 simplices we use explicitly written out + ! formulas for speed, all other cases are handled below + + if (shape%numbering%family==FAMILY_SIMPLEX .and. & + shape%numbering%type==ELEMENT_LAGRANGIAN) then + select case (shape%degree) + case (0) ! P0 case + n(1) = 1. + return + case (1) ! P1 case + n = l + return + case (2) ! P2 case + select case (shape%dim) + case (1) + n(1) = l(1)*(2*l(1)-1) + n(2) = 4*l(1)*l(2) + n(3) = l(2)*(2*l(2)-1) + case (2) + n(1) = l(1)*(2*l(1)-1) + n(2) = 4*l(1)*l(2) + n(3) = l(2)*(2*l(2)-1) + n(4) = 4*l(1)*l(3) + n(5) = 4*l(2)*l(3) + n(6) = l(3)*(2*l(3)-1) + case (3) + n(1) = l(1)*(2*l(1)-1) + n(2) = 4*l(1)*l(2) + n(3) = l(2)*(2*l(2)-1) + n(4) = 4*l(1)*l(3) + n(5) = 4*l(2)*l(3) + n(6) = l(3)*(2*l(3)-1) + n(7) = 4*l(1)*l(4) + n(8) = 4*l(2)*l(4) + n(9) = 4*l(3)*l(4) + n(10) = l(4)*(2*l(4)-1) + end select + return + case default + ! fall through to slow case + end select + end if - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Unable to deallocate constraints.") - end if + ! generic slow case using polynomials + n=1.0 - end subroutine deallocate_constraints + do j=1,shape%loc - function element_local_coords(n, element) result (coords) - !!< Work out the local coordinates of node n in element. This is just a - !!< wrapper function which allows local_coords to be called on an element - !!< instead of on an element numbering. - integer, intent(in) :: n - type(element_type), intent(in) :: element - real, dimension(size(element%numbering%number2count, 1)) :: coords + do i=1,size(shape%spoly,1) - coords=local_coords(n, element%numbering) + ! Raw shape function + n(j)=n(j)*eval(shape%spoly(i,j), l(i)) - end function element_local_coords + end do - function element_local_coord_count(element) result (n) - !!< Return the number of local coordinates associated with element. - integer :: n - type(element_type), intent(in) :: element + end do - n=size(element%numbering%number2count, 1) + end function eval_shape_all_nodes - end function element_local_coord_count + pure function eval_dshape_node(shape, node, l) result(eval_dshape) + !!< Evaluate the derivatives of the shape function for location node at local + !!< coordinates l + type(element_type), intent(in) :: shape + integer, intent(in) :: node + real, dimension(:), intent(in) :: l + real, dimension(shape%dim) :: eval_dshape - function element_local_vertices(element) result (vertices) - !!< Given an element numbering, return the local node numbers of its - !!< vertices. This is just a wrapper hich allows local_vertices to - !!< be called on an element instead of on an element numbering. - type(element_type), intent(in) :: element - integer, dimension(element%numbering%vertices) :: vertices + select case(shape%numbering%family) - vertices=local_vertices(element%numbering) + case (FAMILY_SIMPLEX) - end function element_local_vertices + eval_dshape=eval_dshape_simplex(shape, node, l) - function element_boundary_numbering(element, boundary) - !!< A wrapper function which allows boundary_numbering to be called on - !!< an element instead of on an element_numbering. - integer, intent(in) :: boundary - type(element_type), intent(in) :: element - integer, dimension(boundary_num_length(element%numbering, .false.)) ::& - & element_boundary_numbering + case (FAMILY_CUBE) - element_boundary_numbering=boundary_numbering(element%numbering,& - & boundary) + eval_dshape=eval_dshape_cube(shape, node, l) - end function element_boundary_numbering + case default + ! Invalid element family. Return a really big number to stuff things + ! quickly. - pure function element_equal(element1,element2) - !!< Return true if the two elements are equivalent. - logical :: element_equal - type(element_type), intent(in) :: element1, element2 + eval_dshape=huge(0.0) - element_equal = element1%dim==element2%dim & - .and. element1%loc==element2%loc & - .and. element1%ngi==element2%ngi & - .and. element1%numbering==element2%numbering & - .and. element1%quadrature==element2%quadrature - - end function element_equal - - pure function eval_shape_node(shape, node, l) result(eval_shape) - ! Evaluate the shape function for node node local coordinates l - real :: eval_shape - type(element_type), intent(in) :: shape - integer, intent(in) :: node - real, dimension(size(shape%spoly,1)), intent(in) :: l - - integer :: i - - eval_shape=1.0 - - do i=1,size(shape%spoly,1) - - ! Raw shape function - eval_shape=eval_shape*eval(shape%spoly(i,node), l(i)) - - end do - - end function eval_shape_node - - pure function eval_shape_all_nodes(shape, l) result(n) - ! Evaluate the shape function for all locations at local coordinates l - type(element_type), intent(in) :: shape - real, dimension(size(shape%spoly,1)), intent(in) :: l - real, dimension(shape%loc) :: n - - integer :: i,j - - ! for P0,P1 and P2 simplices we use explicitly written out - ! formulas for speed, all other cases are handled below - - if (shape%numbering%family==FAMILY_SIMPLEX .and. & - shape%numbering%type==ELEMENT_LAGRANGIAN) then - select case (shape%degree) - case (0) ! P0 case - n(1) = 1. - return - case (1) ! P1 case - n = l - return - case (2) ! P2 case - select case (shape%dim) - case (1) - n(1) = l(1)*(2*l(1)-1) - n(2) = 4*l(1)*l(2) - n(3) = l(2)*(2*l(2)-1) - case (2) - n(1) = l(1)*(2*l(1)-1) - n(2) = 4*l(1)*l(2) - n(3) = l(2)*(2*l(2)-1) - n(4) = 4*l(1)*l(3) - n(5) = 4*l(2)*l(3) - n(6) = l(3)*(2*l(3)-1) - case (3) - n(1) = l(1)*(2*l(1)-1) - n(2) = 4*l(1)*l(2) - n(3) = l(2)*(2*l(2)-1) - n(4) = 4*l(1)*l(3) - n(5) = 4*l(2)*l(3) - n(6) = l(3)*(2*l(3)-1) - n(7) = 4*l(1)*l(4) - n(8) = 4*l(2)*l(4) - n(9) = 4*l(3)*l(4) - n(10) = l(4)*(2*l(4)-1) - end select - return - case default - ! fall through to slow case end select - end if - - ! generic slow case using polynomials - n=1.0 - do j=1,shape%loc + end function eval_dshape_node - do i=1,size(shape%spoly,1) + function eval_dshape_all_nodes(shape, l) result(eval_dshape) + type(element_type), intent(in) :: shape + real, dimension(:), intent(in) :: l + real, dimension(shape%loc, shape%dim) :: eval_dshape - ! Raw shape function - n(j)=n(j)*eval(shape%spoly(i,j), l(i)) + integer :: loc + do loc=1,shape%loc + eval_dshape(loc, :) = eval_dshape_node(shape, loc, l) end do + end function eval_dshape_all_nodes - end do - - end function eval_shape_all_nodes - - pure function eval_dshape_node(shape, node, l) result(eval_dshape) - !!< Evaluate the derivatives of the shape function for location node at local - !!< coordinates l - type(element_type), intent(in) :: shape - integer, intent(in) :: node - real, dimension(:), intent(in) :: l - real, dimension(shape%dim) :: eval_dshape - - select case(shape%numbering%family) - - case (FAMILY_SIMPLEX) - - eval_dshape=eval_dshape_simplex(shape, node, l) - - case (FAMILY_CUBE) - - eval_dshape=eval_dshape_cube(shape, node, l) - - case default - ! Invalid element family. Return a really big number to stuff things - ! quickly. + function eval_dshape_transformed(shape, l, invJ) result(transformed_dshape) + type(element_type), intent(in) :: shape + real, dimension(:), intent(in) :: l + real, dimension(shape%dim, shape%dim), intent(in) :: invJ + real, dimension(shape%loc, shape%dim) :: transformed_dshape, untransformed_dshape - eval_dshape=huge(0.0) + integer :: loc - end select - - end function eval_dshape_node + do loc=1,shape%loc + untransformed_dshape(loc, :) = eval_dshape_node(shape, loc, l) + transformed_dshape(loc, :) = matmul(invJ, untransformed_dshape(loc, :)) + end do + end function eval_dshape_transformed + + pure function eval_dshape_simplex(shape, loc, l) result (eval_dshape) + !!< Evaluate the derivatives of the shape function for location loc at local + !!< coordinates l + !!< + !!< This version of the function applies to members of the simplex + !!< family including the interval. + type(element_type), intent(in) :: shape + integer, intent(in) :: loc + real, dimension(shape%dim+1), intent(in) :: l + real, dimension(shape%dim) :: eval_dshape + + integer :: i,j + ! Derivative of the dependent coordinate with respect to the other + ! coordinates: + real, dimension(shape%dim) :: dl4dl + + ! Find derivative of dependent coordinate + dl4dl=diffl4(shape%numbering%vertices, shape%dim) + + do i=1,shape%dim + ! Directional derivatives. + + ! The derivative has to take into account the dependent + ! coordinate. In 3D: + ! + ! S=P1(L1)P2(L2)P3(L3)P4(L4) + ! + ! dS / dP1 dL4 dP4 \ + ! --- = P2P3| ---P4 + ---*---P1| + ! dL1 \ dL1 dL1 dL4 / + ! + + ! Expression in brackets. + eval_dshape(i)=eval(shape%dspoly(i,loc), l(i))& + *eval(shape%spoly(shape%dim+1,loc),l(shape%dim+1))& + + dl4dl(i)& + *eval(shape%dspoly(shape%dim+1,loc), l(shape%dim+1)) & + *eval(shape%spoly(i,loc),l(i)) - function eval_dshape_all_nodes(shape, l) result(eval_dshape) - type(element_type), intent(in) :: shape - real, dimension(:), intent(in) :: l - real, dimension(shape%loc, shape%dim) :: eval_dshape + ! The other terms + do j=1,shape%dim + if (j==i) cycle - integer :: loc + eval_dshape(i)=eval_dshape(i)*eval(shape%spoly(j,loc), l(j)) + end do - do loc=1,shape%loc - eval_dshape(loc, :) = eval_dshape_node(shape, loc, l) - end do - end function eval_dshape_all_nodes + end do - function eval_dshape_transformed(shape, l, invJ) result(transformed_dshape) - type(element_type), intent(in) :: shape - real, dimension(:), intent(in) :: l - real, dimension(shape%dim, shape%dim), intent(in) :: invJ - real, dimension(shape%loc, shape%dim) :: transformed_dshape, untransformed_dshape + end function eval_dshape_simplex + + pure function eval_dshape_cube(shape, loc, l) result (eval_dshape) + !!< Evaluate the derivatives of the shape function for location loc at local + !!< coordinates l + !!< + !!< This version of the function applies to members of the hypercube + !!< family. Note that this does NOT include the interval. + type(element_type), intent(in) :: shape + integer, intent(in) :: loc + real, dimension(shape%dim+1), intent(in) :: l + real, dimension(shape%dim) :: eval_dshape + + integer :: i,j + + do i=1,shape%dim + eval_dshape(i)=1.0 + ! Directional derivatives. + do j=1,shape%dim + if(i==j) then + eval_dshape(i)=eval_dshape(i)*eval(shape%dspoly(j,loc), l(j)) + else + eval_dshape(i)=eval_dshape(i)*eval(shape%spoly(j,loc), l(j)) + end if + end do - integer :: loc + end do - do loc=1,shape%loc - untransformed_dshape(loc, :) = eval_dshape_node(shape, loc, l) - transformed_dshape(loc, :) = matmul(invJ, untransformed_dshape(loc, :)) - end do - end function eval_dshape_transformed + end function eval_dshape_cube - pure function eval_dshape_simplex(shape, loc, l) result (eval_dshape) - !!< Evaluate the derivatives of the shape function for location loc at local - !!< coordinates l - !!< - !!< This version of the function applies to members of the simplex - !!< family including the interval. - type(element_type), intent(in) :: shape - integer, intent(in) :: loc - real, dimension(shape%dim+1), intent(in) :: l - real, dimension(shape%dim) :: eval_dshape + pure function diffl4(vertices, dimension) + ! Derivative of the dependent coordinate with respect to the other + ! coordinates. + integer, intent(in) :: vertices, dimension + real, dimension(dimension) :: diffl4 - integer :: i,j - ! Derivative of the dependent coordinate with respect to the other - ! coordinates: - real, dimension(shape%dim) :: dl4dl + if (vertices==dimension+1) then + ! Simplex. Dependent coordinate depends on all other coordinates. + diffl4=-1.0 - ! Find derivative of dependent coordinate - dl4dl=diffl4(shape%numbering%vertices, shape%dim) + else if (vertices==2**dimension) then + ! Hypercube. The dependent coordinate is redundant. + diffl4=0.0 - do i=1,shape%dim - ! Directional derivatives. + else if (vertices==6.and.dimension==3) then + ! Wedge. First coordinate is independent. + diffl4=(/0.0,-1.0,-1.0/) - ! The derivative has to take into account the dependent - ! coordinate. In 3D: - ! - ! S=P1(L1)P2(L2)P3(L3)P4(L4) - ! - ! dS / dP1 dL4 dP4 \ - ! --- = P2P3| ---P4 + ---*---P1| - ! dL1 \ dL1 dL1 dL4 / - ! + else + ! No output permitted in a pure procedure so we return a big number to stuff + ! things up quickly. + diffl4=huge(0.0) + end if - ! Expression in brackets. - eval_dshape(i)=eval(shape%dspoly(i,loc), l(i))& - *eval(shape%spoly(shape%dim+1,loc),l(shape%dim+1))& - + dl4dl(i)& - *eval(shape%dspoly(shape%dim+1,loc), l(shape%dim+1)) & - *eval(shape%spoly(i,loc),l(i)) + end function diffl4 - ! The other terms - do j=1,shape%dim - if (j==i) cycle - - eval_dshape(i)=eval_dshape(i)*eval(shape%spoly(j,loc), l(j)) - end do - - end do - - end function eval_dshape_simplex - - pure function eval_dshape_cube(shape, loc, l) result (eval_dshape) - !!< Evaluate the derivatives of the shape function for location loc at local - !!< coordinates l - !!< - !!< This version of the function applies to members of the hypercube - !!< family. Note that this does NOT include the interval. - type(element_type), intent(in) :: shape - integer, intent(in) :: loc - real, dimension(shape%dim+1), intent(in) :: l - real, dimension(shape%dim) :: eval_dshape - - integer :: i,j - - do i=1,shape%dim - eval_dshape(i)=1.0 - ! Directional derivatives. - do j=1,shape%dim - if(i==j) then - eval_dshape(i)=eval_dshape(i)*eval(shape%dspoly(j,loc), l(j)) - else - eval_dshape(i)=eval_dshape(i)*eval(shape%spoly(j,loc), l(j)) - end if - end do - - end do - - end function eval_dshape_cube - - pure function diffl4(vertices, dimension) - ! Derivative of the dependent coordinate with respect to the other - ! coordinates. - integer, intent(in) :: vertices, dimension - real, dimension(dimension) :: diffl4 - - if (vertices==dimension+1) then - ! Simplex. Dependent coordinate depends on all other coordinates. - diffl4=-1.0 - - else if (vertices==2**dimension) then - ! Hypercube. The dependent coordinate is redundant. - diffl4=0.0 - - else if (vertices==6.and.dimension==3) then - ! Wedge. First coordinate is independent. - diffl4=(/0.0,-1.0,-1.0/) - - else - ! No output permitted in a pure procedure so we return a big number to stuff - ! things up quickly. - diffl4=huge(0.0) - end if - - end function diffl4 - - subroutine make_constraints(constraint,family) - type(constraints_type), intent(inout) :: constraint - integer, intent(in) :: family - ! - select case(family) - case (FAMILY_SIMPLEX) - select case(constraint%type) - case (CONSTRAINT_BDM) - !do nothing - case (CONSTRAINT_BDFM) - select case(constraint%dim) - case (2) - select case(constraint%degree) - case (1) - !BDFM0 is the same as RT0 - call make_constraints_rt0_triangle(constraint) + subroutine make_constraints(constraint,family) + type(constraints_type), intent(inout) :: constraint + integer, intent(in) :: family + ! + select case(family) + case (FAMILY_SIMPLEX) + select case(constraint%type) + case (CONSTRAINT_BDM) + !do nothing + case (CONSTRAINT_BDFM) + select case(constraint%dim) case (2) - call make_constraints_bdfm1_triangle(constraint) + select case(constraint%degree) + case (1) + !BDFM0 is the same as RT0 + call make_constraints_rt0_triangle(constraint) + case (2) + call make_constraints_bdfm1_triangle(constraint) + case default + FLExit('Unknown constraints type') + end select case default - FLExit('Unknown constraints type') - end select - case default - FLExit('Unsupported dimension') - end select - case (CONSTRAINT_RT) - select case(constraint%dim) - case (2) - select case(constraint%degree) - case (1) - call make_constraints_rt0_triangle(constraint) + FLExit('Unsupported dimension') + end select + case (CONSTRAINT_RT) + select case(constraint%dim) + case (2) + select case(constraint%degree) + case (1) + call make_constraints_rt0_triangle(constraint) + case default + FLExit('Unknown constraints type') + end select case default - FLExit('Unknown constraints type') - end select + FLExit('Unsupported dimension') + end select case default - FLExit('Unsupported dimension') - end select - case default - FLExit('Unknown constraints type') - end select - case (FAMILY_CUBE) - select case(constraint%type) - case (CONSTRAINT_BDM) - !do nothing - case (CONSTRAINT_RT) - select case(constraint%dim) - case (2) - select case(constraint%degree) - case (1) - call make_constraints_rt0_square(constraint) + FLExit('Unknown constraints type') + end select + case (FAMILY_CUBE) + select case(constraint%type) + case (CONSTRAINT_BDM) + !do nothing + case (CONSTRAINT_RT) + select case(constraint%dim) case (2) - FLExit('Haven''t implemented it yet!') - !call make_constraints_rt1_square(constraint) + select case(constraint%degree) + case (1) + call make_constraints_rt0_square(constraint) + case (2) + FLExit('Haven''t implemented it yet!') + !call make_constraints_rt1_square(constraint) + case default + FLExit('Unknown constraints type') + end select case default - FLExit('Unknown constraints type') - end select + FLExit('Unsupported dimension') + end select case default - FLExit('Unsupported dimension') - end select + FLExit('Unknown constraints type') + end select case default - FLExit('Unknown constraints type') - end select - case default - FLExit('Unknown element numbering family') - end select - end subroutine make_constraints - - subroutine make_constraints_bdfm1_triangle(constraint) - implicit none - type(constraints_type), intent(inout) :: constraint - real, dimension(3,2) :: n - integer, dimension(3,3) :: face_loc - integer :: dim1, face, floc - real, dimension(3) :: c - - if(constraint%dim/=2) then - FLExit('Only implemented for 2D so far') - end if - - !BDFM1 constraint requires that normal components are linear. - !This means that the normal components at the edge centres - !need to be constrained to the average of the normal components - !at each end of the edge. - - !DOFS FACES - ! 3 - ! 5 2 1 3 - ! 6 4 1 2 - - !constraint equations are: - ! (0.5 u_3 - u_5 + 0.5 u_6).n_1 = 0 - ! (0.5 u_1 - u_4 + 0.5 u_6).n_2 = 0 - ! (0.5 u_1 - u_2 + 0.5 u_3).n_3 = 0 - - !face local nodes to element local nodes - face_loc(1,:) = (/ 3,5,6 /) - face_loc(2,:) = (/ 1,4,6 /) - face_loc(3,:) = (/ 1,2,3 /) - - !normals - n(1,:) = (/ -1., 0. /) - n(2,:) = (/ 0.,-1. /) - n(3,:) = (/ 1./sqrt(2.),1./sqrt(2.) /) - - !coefficients in each face - c = (/ 0.5,-1.,0.5 /) - - !constraint%orthogonal(i,loc,dim1) stores the coefficient - !for basis function loc, dimension dim1 in equation i. - - constraint%orthogonal = 0. - do face = 1, 3 - do floc = 1,3 - do dim1 = 1, 2 - constraint%orthogonal(face,face_loc(face,floc),dim1) = & + FLExit('Unknown element numbering family') + end select + end subroutine make_constraints + + subroutine make_constraints_bdfm1_triangle(constraint) + implicit none + type(constraints_type), intent(inout) :: constraint + real, dimension(3,2) :: n + integer, dimension(3,3) :: face_loc + integer :: dim1, face, floc + real, dimension(3) :: c + + if(constraint%dim/=2) then + FLExit('Only implemented for 2D so far') + end if + + !BDFM1 constraint requires that normal components are linear. + !This means that the normal components at the edge centres + !need to be constrained to the average of the normal components + !at each end of the edge. + + !DOFS FACES + ! 3 + ! 5 2 1 3 + ! 6 4 1 2 + + !constraint equations are: + ! (0.5 u_3 - u_5 + 0.5 u_6).n_1 = 0 + ! (0.5 u_1 - u_4 + 0.5 u_6).n_2 = 0 + ! (0.5 u_1 - u_2 + 0.5 u_3).n_3 = 0 + + !face local nodes to element local nodes + face_loc(1,:) = (/ 3,5,6 /) + face_loc(2,:) = (/ 1,4,6 /) + face_loc(3,:) = (/ 1,2,3 /) + + !normals + n(1,:) = (/ -1., 0. /) + n(2,:) = (/ 0.,-1. /) + n(3,:) = (/ 1./sqrt(2.),1./sqrt(2.) /) + + !coefficients in each face + c = (/ 0.5,-1.,0.5 /) + + !constraint%orthogonal(i,loc,dim1) stores the coefficient + !for basis function loc, dimension dim1 in equation i. + + constraint%orthogonal = 0. + do face = 1, 3 + do floc = 1,3 + do dim1 = 1, 2 + constraint%orthogonal(face,face_loc(face,floc),dim1) = & c(floc)*n(face,dim1) - end do - end do - end do - !! dimension n_constraints x loc x dim - end subroutine make_constraints_bdfm1_triangle - - subroutine make_constraints_rt0_triangle(constraint) - implicit none - type(constraints_type), intent(inout) :: constraint - real, dimension(3,2) :: n - integer, dimension(3,2) :: face_loc - integer :: dim1, face, floc, count - real, dimension(2) :: c - - if(constraint%dim/=2) then - FLExit('Only implemented for 2D so far') - end if - - !RT0 constraint requires that normal components are constant. - !This means that both the normal components at each end of the - !edge need to have the same value. - - !DOFS FACES - ! 2 - ! 1 3 - ! 3 1 2 - - !constraint equations are: - ! (u_2 - u_3).n_1 = 0 - ! (u_1 - u_3).n_2 = 0 - ! (u_1 - u_2).n_3 = 0 - - !face local nodes to element local nodes - face_loc(1,:) = (/ 2,3 /) - face_loc(2,:) = (/ 1,3 /) - face_loc(3,:) = (/ 1,2 /) - - !normals - n(1,:) = (/ -1., 0. /) - n(2,:) = (/ 0.,-1. /) - n(3,:) = (/ 1./sqrt(2.),1./sqrt(2.) /) - - !constraint coefficients - c = (/ 1., -1. /) - - !constraint%orthogonal(i,loc,dim1) stores the coefficient - !for basis function loc, dimension dim1 in equation i. - - constraint%orthogonal = 0. - count = 0 - do face = 1, 3 - count = count + 1 - do floc = 1,2 - do dim1 = 1, 2 - constraint%orthogonal(count,face_loc(face,floc),dim1)& + end do + end do + end do + !! dimension n_constraints x loc x dim + end subroutine make_constraints_bdfm1_triangle + + subroutine make_constraints_rt0_triangle(constraint) + implicit none + type(constraints_type), intent(inout) :: constraint + real, dimension(3,2) :: n + integer, dimension(3,2) :: face_loc + integer :: dim1, face, floc, count + real, dimension(2) :: c + + if(constraint%dim/=2) then + FLExit('Only implemented for 2D so far') + end if + + !RT0 constraint requires that normal components are constant. + !This means that both the normal components at each end of the + !edge need to have the same value. + + !DOFS FACES + ! 2 + ! 1 3 + ! 3 1 2 + + !constraint equations are: + ! (u_2 - u_3).n_1 = 0 + ! (u_1 - u_3).n_2 = 0 + ! (u_1 - u_2).n_3 = 0 + + !face local nodes to element local nodes + face_loc(1,:) = (/ 2,3 /) + face_loc(2,:) = (/ 1,3 /) + face_loc(3,:) = (/ 1,2 /) + + !normals + n(1,:) = (/ -1., 0. /) + n(2,:) = (/ 0.,-1. /) + n(3,:) = (/ 1./sqrt(2.),1./sqrt(2.) /) + + !constraint coefficients + c = (/ 1., -1. /) + + !constraint%orthogonal(i,loc,dim1) stores the coefficient + !for basis function loc, dimension dim1 in equation i. + + constraint%orthogonal = 0. + count = 0 + do face = 1, 3 + count = count + 1 + do floc = 1,2 + do dim1 = 1, 2 + constraint%orthogonal(count,face_loc(face,floc),dim1)& = c(floc)*n(face,dim1) - end do - end do - end do - assert(count==3) - !! dimension n_constraints x loc x dim - end subroutine make_constraints_rt0_triangle - - subroutine make_constraints_rt0_square(constraint) - implicit none - type(constraints_type), intent(inout) :: constraint - real, dimension(4,2) :: n - integer, dimension(4,2) :: face_loc - integer :: dim1, face, floc, count - real, dimension(2) :: c - - if(constraint%dim/=2) then - FLExit('Only implemented for 2D so far') - end if - - !RT0 constraint requires that normal components are constant. - !This means that both the normal components at each end of the - !edge need to have the same value. - - !DOFS FACES - ! 3 4 3 - ! 4 2 - ! 1 2 1 - - !constraint equations are: - ! (u_1 - u_2).n_1 = 0 - ! (u_2 - u_4).n_2 = 0 - ! (u_3 - u_4).n_3 = 0 - ! (u_3 - u_1).n_4 = 0 - - !face local nodes to element local nodes - face_loc(1,:) = (/ 1,2 /) - face_loc(2,:) = (/ 2,4 /) - face_loc(3,:) = (/ 3,4 /) - face_loc(4,:) = (/ 3,1 /) - - !normals - n(1,:) = (/ 0., -1. /) - n(2,:) = (/ 1., 0. /) - n(3,:) = (/ 0., 1. /) - n(4,:) = (/ -1., 0. /) - - !constraint%orthogonal(i,loc,dim1) stores the coefficient - !for basis function loc, dimension dim1 in equation i. - - !constraint coefficients - c = (/ 1., -1. /) - - constraint%orthogonal = 0. - count = 0 - do face = 1, 4 - count = count + 1 - do floc = 1,2 - do dim1 = 1, 2 - constraint%orthogonal(count,face_loc(face,floc),dim1)& + end do + end do + end do + assert(count==3) + !! dimension n_constraints x loc x dim + end subroutine make_constraints_rt0_triangle + + subroutine make_constraints_rt0_square(constraint) + implicit none + type(constraints_type), intent(inout) :: constraint + real, dimension(4,2) :: n + integer, dimension(4,2) :: face_loc + integer :: dim1, face, floc, count + real, dimension(2) :: c + + if(constraint%dim/=2) then + FLExit('Only implemented for 2D so far') + end if + + !RT0 constraint requires that normal components are constant. + !This means that both the normal components at each end of the + !edge need to have the same value. + + !DOFS FACES + ! 3 4 3 + ! 4 2 + ! 1 2 1 + + !constraint equations are: + ! (u_1 - u_2).n_1 = 0 + ! (u_2 - u_4).n_2 = 0 + ! (u_3 - u_4).n_3 = 0 + ! (u_3 - u_1).n_4 = 0 + + !face local nodes to element local nodes + face_loc(1,:) = (/ 1,2 /) + face_loc(2,:) = (/ 2,4 /) + face_loc(3,:) = (/ 3,4 /) + face_loc(4,:) = (/ 3,1 /) + + !normals + n(1,:) = (/ 0., -1. /) + n(2,:) = (/ 1., 0. /) + n(3,:) = (/ 0., 1. /) + n(4,:) = (/ -1., 0. /) + + !constraint%orthogonal(i,loc,dim1) stores the coefficient + !for basis function loc, dimension dim1 in equation i. + + !constraint coefficients + c = (/ 1., -1. /) + + constraint%orthogonal = 0. + count = 0 + do face = 1, 4 + count = count + 1 + do floc = 1,2 + do dim1 = 1, 2 + constraint%orthogonal(count,face_loc(face,floc),dim1)& = c(floc)*n(face,dim1) - end do - end do - end do - assert(count==4) - !! dimension n_constraints x loc x dim - end subroutine make_constraints_rt0_square + end do + end do + end do + assert(count==4) + !! dimension n_constraints x loc x dim + end subroutine make_constraints_rt0_square #include "Reference_count_element_type.F90" diff --git a/femtools/Embed_Python_Fortran.F90 b/femtools/Embed_Python_Fortran.F90 index a428aa271f..9e76a7e3e7 100644 --- a/femtools/Embed_Python_Fortran.F90 +++ b/femtools/Embed_Python_Fortran.F90 @@ -29,918 +29,918 @@ module embed_python - use fldebug - use iso_c_binding - use global_parameters, only: FIELD_NAME_LEN + use fldebug + use iso_c_binding + use global_parameters, only: FIELD_NAME_LEN - implicit none + implicit none - interface deallocate_c_array - subroutine deallocate_c_array(ptr) bind(c) - use iso_c_binding, only: c_ptr - implicit none + interface deallocate_c_array + subroutine deallocate_c_array(ptr) bind(c) + use iso_c_binding, only: c_ptr + implicit none - type(c_ptr), value :: ptr - end subroutine deallocate_c_array - end interface deallocate_c_array + type(c_ptr), value :: ptr + end subroutine deallocate_c_array + end interface deallocate_c_array - interface set_scalar_field_from_python - module procedure set_scalar_field_from_python_sp + interface set_scalar_field_from_python + module procedure set_scalar_field_from_python_sp - subroutine set_scalar_field_from_python(function, function_len, dim, & + subroutine set_scalar_field_from_python(function, function_len, dim, & nodes, x, y, z, t, result, stat) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char, len=function_len) :: function - integer(c_int), intent(in), value :: dim, nodes - real(c_double), dimension(nodes), intent(in) :: x, y, z - real(c_double), intent(in), value :: t - real(c_double), dimension(nodes), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_scalar_field_from_python - end interface set_scalar_field_from_python - - interface set_integer_array_from_python - module procedure set_integer_array_from_python_sp - - subroutine set_integer_array_from_python(function, function_len, dim, & + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char, len=function_len) :: function + integer(c_int), intent(in), value :: dim, nodes + real(c_double), dimension(nodes), intent(in) :: x, y, z + real(c_double), intent(in), value :: t + real(c_double), dimension(nodes), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_scalar_field_from_python + end interface set_scalar_field_from_python + + interface set_integer_array_from_python + module procedure set_integer_array_from_python_sp + + subroutine set_integer_array_from_python(function, function_len, dim, & nodes, x, y, z, t, result, stat) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char, len=function_len), intent(in) :: function - integer(c_int), intent(in), value :: dim, nodes - real(c_double), dimension(nodes), intent(in) :: x, y, z - real(c_double), intent(in), value :: t - integer(c_int), dimension(nodes), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_integer_array_from_python - end interface set_integer_array_from_python - - interface set_vector_field_from_python - module procedure set_vector_field_from_python_sp - - subroutine set_vector_field_from_python(function, function_len, dim, & + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char, len=function_len), intent(in) :: function + integer(c_int), intent(in), value :: dim, nodes + real(c_double), dimension(nodes), intent(in) :: x, y, z + real(c_double), intent(in), value :: t + integer(c_int), dimension(nodes), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_integer_array_from_python + end interface set_integer_array_from_python + + interface set_vector_field_from_python + module procedure set_vector_field_from_python_sp + + subroutine set_vector_field_from_python(function, function_len, dim, & nodes, x, y, z, t, result_dim, result_x, result_y, result_z, & stat) - !! Interface to c wrapper function. - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char, len=function_len) :: function - integer(c_int), intent(in), value :: dim, nodes, result_dim - real(c_double), dimension(nodes), intent(in) :: x, y, z - real(c_double), intent(in), value :: t - real(c_double), dimension(nodes), intent(out) :: result_x, result_y, result_z - integer(c_int), intent(out) :: stat - end subroutine set_vector_field_from_python - end interface set_vector_field_from_python - - interface set_tensor_field_from_python - module procedure set_tensor_field_from_python_sp - - subroutine set_tensor_field_from_python(function, function_len, dim, & + !! Interface to c wrapper function. + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char, len=function_len) :: function + integer(c_int), intent(in), value :: dim, nodes, result_dim + real(c_double), dimension(nodes), intent(in) :: x, y, z + real(c_double), intent(in), value :: t + real(c_double), dimension(nodes), intent(out) :: result_x, result_y, result_z + integer(c_int), intent(out) :: stat + end subroutine set_vector_field_from_python + end interface set_vector_field_from_python + + interface set_tensor_field_from_python + module procedure set_tensor_field_from_python_sp + + subroutine set_tensor_field_from_python(function, function_len, dim, & nodes, x, y, z, t, result_dim, result, stat) - !! Interface to c wrapper function. - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char, len=function_len) :: function - integer(c_int), intent(in), value :: dim, nodes - real(c_double), dimension(nodes), intent(in) :: x, y, z - real(c_double), intent(in), value :: t - integer(c_int), dimension(2), intent(in) :: result_dim - real(c_double), dimension(result_dim(1), result_dim(2), nodes), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_tensor_field_from_python - end interface set_tensor_field_from_python - - interface set_detectors_from_python - module procedure set_detectors_from_python_sp - - subroutine set_detectors_from_python(function, function_len, dim,& + !! Interface to c wrapper function. + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char, len=function_len) :: function + integer(c_int), intent(in), value :: dim, nodes + real(c_double), dimension(nodes), intent(in) :: x, y, z + real(c_double), intent(in), value :: t + integer(c_int), dimension(2), intent(in) :: result_dim + real(c_double), dimension(result_dim(1), result_dim(2), nodes), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_tensor_field_from_python + end interface set_tensor_field_from_python + + interface set_detectors_from_python + module procedure set_detectors_from_python_sp + + subroutine set_detectors_from_python(function, function_len, dim,& ndete, t, rdim, result_x, result_y, result_z, stat) - !! Interface to c wrapper function. - use iso_c_binding, only: c_double - implicit none + !! Interface to c wrapper function. + use iso_c_binding, only: c_double + implicit none + integer, intent(in) :: function_len + character(len = function_len) :: function + integer, intent(in) :: dim,rdim + integer, intent(in) :: ndete + real(kind = c_double), intent(in) :: t + real(kind = c_double), dimension(ndete), intent(out) :: result_x, result_y, result_z + integer, intent(out) :: stat + end subroutine set_detectors_from_python + + subroutine set_detectors_from_python_unknown(func, func_len, dim, & + t, result_ptr, n, stat) bind(c) + use iso_c_binding, only: c_double, c_ptr, c_int, c_char + implicit none + + integer(c_int), intent(in), value :: func_len + character(kind=c_char) :: func + integer(c_int), intent(in), value :: dim + real(c_double), intent(in), value :: t + type(c_ptr), intent(out) :: result_ptr + integer(c_int), intent(out) :: n, stat + end subroutine set_detectors_from_python_unknown + end interface set_detectors_from_python + + interface set_scalar_particles_from_python + subroutine set_scalar_particles_from_python(function, function_len, dim, & + npart, x, y, z, t, dt, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + real(c_double), dimension(1, npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_scalar_particles_from_python + + subroutine set_scalar_particles_from_python_array(func, func_len, dim, & + npart, natt, x, y, z, t, dt, res, stat) bind(c) + use iso_c_binding, only : c_double, c_int, c_char + implicit none + + integer(c_int), intent(in), value :: func_len + character(kind=c_char) :: func + integer(c_int), intent(in), value :: dim, npart, natt + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + real(c_double), dimension(natt, npart), intent(out) :: res + integer(c_int), intent(out) :: stat + end subroutine set_scalar_particles_from_python_array + end interface set_scalar_particles_from_python + + interface set_scalar_particles_from_python_fields + ! dispatch procedure, mainly to fill out field_name_len + module procedure set_scalar_particles_from_python_fields_sp + + subroutine set_scalar_particles_from_python_fields(function, function_len, dim, & + npart, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & + old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) + !! Interface to c wrapper function. + use iso_c_binding, only: c_double, c_char, c_int + use global_parameters, only: FIELD_NAME_LEN + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char):: function + integer(c_int), intent(in), value :: dim, npart + integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + integer(c_int), intent(in), value :: fld_name_len + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names + real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names + real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names + integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes + real(c_double), dimension(1,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_scalar_particles_from_python_fields + + subroutine set_scalar_particles_from_python_fields_array(function, function_len, dim, & + npart, natt, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & + old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) + !! Interface to c wrapper function. + use iso_c_binding, only: c_double, c_char, c_int + use global_parameters, only: FIELD_NAME_LEN + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char):: function + integer(c_int), intent(in), value :: dim, npart, natt + integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + integer(c_int), intent(in), value :: fld_name_len + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names + real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names + real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names + integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes + real(c_double), dimension(natt,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + + end subroutine set_scalar_particles_from_python_fields_array + end interface set_scalar_particles_from_python_fields + + interface set_vector_particles_from_python + subroutine set_vector_particles_from_python(function, function_len, dim, & + npart, x, y, z, t, dt, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + real(c_double), dimension(dim, npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_vector_particles_from_python + + subroutine set_vector_particles_from_python_array(function, function_len, dim, & + npart, natt, x, y, z, t, dt, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart, natt + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + real(c_double), dimension(natt*dim, npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_vector_particles_from_python_array + end interface set_vector_particles_from_python + + interface set_vector_particles_from_python_fields + module procedure set_vector_particles_from_python_fields_sp + + subroutine set_vector_particles_from_python_fields(function, function_len, dim, & + npart, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & + old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + use global_parameters, only: FIELD_NAME_LEN + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart + integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + integer(c_int), intent(in), value :: fld_name_len + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names + real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names + real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names + integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes + real(c_double), dimension(dim,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_vector_particles_from_python_fields + + subroutine set_vector_particles_from_python_fields_array(function, function_len, dim, & + npart, natt, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & + old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + use global_parameters, only: FIELD_NAME_LEN + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart, natt + integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + integer(c_int), intent(in), value :: fld_name_len + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names + real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names + real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names + integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes + real(c_double), dimension(dim*natt,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_vector_particles_from_python_fields_array + end interface set_vector_particles_from_python_fields + + interface set_tensor_particles_from_python + subroutine set_tensor_particles_from_python(function, function_len, dim, & + npart, x, y, z, t, dt, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + real(c_double), dimension(dim,dim,1,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_tensor_particles_from_python + + subroutine set_tensor_particles_from_python_array(function, function_len, dim, & + npart, natt, x, y, z, t, dt, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char) :: function + integer(c_int), intent(in), value :: dim, npart, natt + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + real(c_double), dimension(dim,dim,natt,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_tensor_particles_from_python_array + end interface set_tensor_particles_from_python + + interface set_tensor_particles_from_python_fields + module procedure set_tensor_particles_from_python_fields_sp + + subroutine set_tensor_particles_from_python_fields(function, function_len, dim, & + npart, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & + old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + use global_parameters, only: FIELD_NAME_LEN + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char):: function + integer(c_int), intent(in), value :: dim, npart + integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + integer(c_int), intent(in), value :: fld_name_len + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names + real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names + real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names + integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes + real(c_double), dimension(dim,dim,1,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_tensor_particles_from_python_fields + + subroutine set_tensor_particles_from_python_fields_array(function, function_len, dim, & + npart, natt, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & + old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) + use iso_c_binding, only: c_double, c_int, c_char + use global_parameters, only: FIELD_NAME_LEN + implicit none + integer(c_int), intent(in), value :: function_len + character(kind=c_char):: function + integer(c_int), intent(in), value :: dim, npart, natt + integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + integer(c_int), intent(in), value :: fld_name_len + real(c_double), dimension(npart), intent(in) :: x, y, z + real(c_double), intent(in), value :: t, dt + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names + real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names + real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names + integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes + real(c_double), dimension(dim,dim,natt,npart), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine set_tensor_particles_from_python_fields_array + end interface set_tensor_particles_from_python_fields + + interface real_from_python + module procedure real_from_python_sp, real_from_python_interface + + subroutine real_from_python(function, function_len, t, result, stat) + use iso_c_binding, only: c_double, c_int, c_char + implicit none + integer(c_int), intent(in) :: function_len + character(kind=c_char, len=function_len), intent(in) :: function + real(kind = c_double), intent(in) :: t + real(kind = c_double), intent(out) :: result + integer(c_int), intent(out) :: stat + end subroutine real_from_python + end interface real_from_python + + interface real_vector_from_python + module procedure real_vector_from_python_interface, real_vector_from_python_sp + + subroutine real_vector_from_python(function, function_len, t, result,& + & result_len, stat) bind(c) + use :: iso_c_binding + implicit none + integer(c_int), intent(in) :: function_len + character(kind=c_char,len = 1), intent(in) :: function + real(kind = c_double), intent(in) :: t + type(c_ptr), intent(out) :: result + integer(c_int), intent(out) :: result_len, stat + end subroutine real_vector_from_python + end interface real_vector_from_python + + interface integer_vector_from_python + module procedure integer_vector_from_python_interface + + subroutine integer_vector_from_python(function, function_len, t, result,& + & result_len, stat) bind(c) + use :: iso_c_binding + implicit none + integer(c_int), intent(in) :: function_len + character(kind=c_char,len = 1), intent(in) :: function + real(kind=c_double), intent(in) :: t + type(c_ptr), intent(out) :: result + integer(c_int), intent(out) :: result_len, stat + end subroutine integer_vector_from_python + end interface integer_vector_from_python + + interface + subroutine free_c_vector(vector) bind(c) + use :: iso_c_binding + implicit none + type(c_ptr) :: vector + end subroutine + end interface + + interface integer_from_python + module procedure integer_from_python_sp, integer_from_python_interface + + subroutine integer_from_python(function, function_len, t, result, stat) + use iso_c_binding, only: c_double + implicit none + integer, intent(in) :: function_len + character(len = function_len), intent(in) :: function + real(kind = c_double), intent(in) :: t + integer, intent(out) :: result + integer, intent(out) :: stat + end subroutine integer_from_python + end interface integer_from_python + + interface string_from_python + module procedure string_from_python_sp, string_from_python_interface + + subroutine string_from_python(function, function_len, result_len, t, result, stat) + use iso_c_binding, only: c_double + implicit none + integer, intent(in) :: function_len + character(len = function_len), intent(in) :: function + integer, intent(inout) :: result_len + real(kind = c_double), intent(in) :: t + character(len = result_len), intent(out) :: result + integer, intent(out) :: stat + end subroutine string_from_python + end interface string_from_python + + private + + public :: set_scalar_field_from_python, set_integer_array_from_python, & + & set_vector_field_from_python, set_tensor_field_from_python, & + & set_detectors_from_python, real_from_python, real_vector_from_python, & + & integer_from_python, string_from_python, integer_vector_from_python, & + & set_scalar_particles_from_python_fields, set_scalar_particles_from_python, & + & set_vector_particles_from_python_fields, set_vector_particles_from_python, & + & set_tensor_particles_from_python_fields, set_tensor_particles_from_python, & + deallocate_c_array + +contains + + + subroutine set_scalar_field_from_python_sp(function, function_len, dim, & + & nodes, x, y, z, t, result, stat) + integer, intent(in) :: function_len + character(len = function_len) :: function + integer, intent(in) :: dim + integer, intent(in) :: nodes + real(kind = c_float), dimension(nodes), intent(in) :: x + real(kind = c_float), dimension(:), intent(in) :: y + real(kind = c_float), dimension(:), intent(in) :: z + real(kind = c_float), intent(in) :: t + real(kind = c_float), dimension(nodes), intent(out) :: result + integer, intent(out) :: stat + + real(kind = c_double), dimension(nodes) :: lresult + + call set_scalar_field_from_python(function, function_len, dim, & + & nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), lresult, stat) + result = lresult + + end subroutine set_scalar_field_from_python_sp + + subroutine set_integer_array_from_python_sp(function, function_len, dim, nodes, x, y, z, t, result, stat) + integer, intent(in) :: function_len + character(len = function_len), intent(in) :: function + integer, intent(in) :: dim + integer, intent(in) :: nodes + real(kind = c_float), dimension(nodes), intent(in) :: x + real(kind = c_float), dimension(:), intent(in) :: y + real(kind = c_float), dimension(:), intent(in) :: z + real(kind = c_float), intent(in) :: t + integer, dimension(nodes), intent(out) :: result + integer, intent(out) :: stat + + call set_integer_array_from_python(function, function_len, dim, nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), result, stat) + + end subroutine set_integer_array_from_python_sp + + subroutine set_vector_field_from_python_sp(function, function_len, dim, & + & nodes, x, y, z, t, result_dim, result_x, result_y, result_z, & + & stat) + integer, intent(in) :: function_len + character(len = function_len) :: function + integer, intent(in) :: dim + integer, intent(in) :: nodes + real(kind = c_float), dimension(nodes), intent(in) :: x + real(kind = c_float), dimension(:), intent(in) :: y + real(kind = c_float), dimension(:), intent(in) :: z + real(kind = c_float), intent(in) :: t + integer, intent(in) :: result_dim + real(kind = c_float), dimension(nodes), intent(out) :: result_x + real(kind = c_float), dimension(:), intent(out) :: result_y + real(kind = c_float), dimension(:), intent(out) :: result_z + integer, intent(out) :: stat + + real(kind = c_double), dimension(size(result_x)) :: lresult_x + real(kind = c_double), dimension(size(result_y)) :: lresult_y + real(kind = c_double), dimension(size(result_z)) :: lresult_z + + call set_vector_field_from_python(function, function_len, dim, & + & nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), result_dim, lresult_x, lresult_y, lresult_z, & + & stat) + result_x = lresult_x + result_y = lresult_y + result_z = lresult_z + + end subroutine set_vector_field_from_python_sp + + subroutine set_tensor_field_from_python_sp(function, function_len, dim, & + & nodes, x, y, z, t, result_dim, result, stat) + integer, intent(in) :: function_len + character(len = function_len) :: function + integer, intent(in) :: dim + integer, intent(in) :: nodes + real(kind = c_float), dimension(nodes), intent(in) :: x + real(kind = c_float), dimension(:), intent(in) :: y + real(kind = c_float), dimension(:), intent(in) :: z + real(kind = c_float), intent(in) :: t + integer, dimension(2), intent(in) :: result_dim + real(kind = c_float), dimension(:, :, :), intent(out) :: result + integer, intent(out) :: stat + + real(kind = c_double), dimension(size(result, 1), size(result, 2), size(result, 3)) :: lresult + + call set_tensor_field_from_python(function, function_len, dim, & + & nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), result_dim, lresult, stat) + result = lresult + + end subroutine set_tensor_field_from_python_sp + + subroutine set_detectors_from_python_sp(function, function_len, dim, & + & ndete, t, rdim, result_x, result_y, result_z, stat) integer, intent(in) :: function_len character(len = function_len) :: function integer, intent(in) :: dim,rdim integer, intent(in) :: ndete - real(kind = c_double), intent(in) :: t - real(kind = c_double), dimension(ndete), intent(out) :: result_x, result_y, result_z + real(kind = c_float), intent(in) :: t + real(kind = c_float), dimension(ndete), intent(out) :: result_x + real(kind = c_float), dimension(:), intent(out) :: result_y + real(kind = c_float), dimension(:), intent(out) :: result_z integer, intent(out) :: stat - end subroutine set_detectors_from_python - - subroutine set_detectors_from_python_unknown(func, func_len, dim, & - t, result_ptr, n, stat) bind(c) - use iso_c_binding, only: c_double, c_ptr, c_int, c_char - implicit none - - integer(c_int), intent(in), value :: func_len - character(kind=c_char) :: func - integer(c_int), intent(in), value :: dim - real(c_double), intent(in), value :: t - type(c_ptr), intent(out) :: result_ptr - integer(c_int), intent(out) :: n, stat - end subroutine set_detectors_from_python_unknown - end interface set_detectors_from_python - - interface set_scalar_particles_from_python - subroutine set_scalar_particles_from_python(function, function_len, dim, & - npart, x, y, z, t, dt, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - real(c_double), dimension(1, npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_scalar_particles_from_python - - subroutine set_scalar_particles_from_python_array(func, func_len, dim, & - npart, natt, x, y, z, t, dt, res, stat) bind(c) - use iso_c_binding, only : c_double, c_int, c_char - implicit none - - integer(c_int), intent(in), value :: func_len - character(kind=c_char) :: func - integer(c_int), intent(in), value :: dim, npart, natt - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - real(c_double), dimension(natt, npart), intent(out) :: res - integer(c_int), intent(out) :: stat - end subroutine set_scalar_particles_from_python_array - end interface set_scalar_particles_from_python - - interface set_scalar_particles_from_python_fields - ! dispatch procedure, mainly to fill out field_name_len - module procedure set_scalar_particles_from_python_fields_sp - - subroutine set_scalar_particles_from_python_fields(function, function_len, dim, & - npart, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & - old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) - !! Interface to c wrapper function. - use iso_c_binding, only: c_double, c_char, c_int - use global_parameters, only: FIELD_NAME_LEN - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char):: function - integer(c_int), intent(in), value :: dim, npart - integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - integer(c_int), intent(in), value :: fld_name_len - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes - real(c_double), dimension(1,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_scalar_particles_from_python_fields - subroutine set_scalar_particles_from_python_fields_array(function, function_len, dim, & - npart, natt, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & - old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) - !! Interface to c wrapper function. - use iso_c_binding, only: c_double, c_char, c_int - use global_parameters, only: FIELD_NAME_LEN - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char):: function - integer(c_int), intent(in), value :: dim, npart, natt - integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - integer(c_int), intent(in), value :: fld_name_len - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes - real(c_double), dimension(natt,npart), intent(out) :: result - integer(c_int), intent(out) :: stat + real(kind = c_double), dimension(size(result_x)) :: lresult_x + real(kind = c_double), dimension(size(result_y)) :: lresult_y + real(kind = c_double), dimension(size(result_z)) :: lresult_z - end subroutine set_scalar_particles_from_python_fields_array - end interface set_scalar_particles_from_python_fields + call set_detectors_from_python(function, function_len, dim, & + & ndete, real(t, kind = c_double), rdim, lresult_x, lresult_y, lresult_z, stat) + result_x = lresult_x + result_y = lresult_y + result_z = lresult_z - interface set_vector_particles_from_python - subroutine set_vector_particles_from_python(function, function_len, dim, & - npart, x, y, z, t, dt, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - real(c_double), dimension(dim, npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_vector_particles_from_python - - subroutine set_vector_particles_from_python_array(function, function_len, dim, & - npart, natt, x, y, z, t, dt, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart, natt - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - real(c_double), dimension(natt*dim, npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_vector_particles_from_python_array - end interface set_vector_particles_from_python - - interface set_vector_particles_from_python_fields - module procedure set_vector_particles_from_python_fields_sp - - subroutine set_vector_particles_from_python_fields(function, function_len, dim, & - npart, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & - old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - use global_parameters, only: FIELD_NAME_LEN - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart - integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - integer(c_int), intent(in), value :: fld_name_len - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes - real(c_double), dimension(dim,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_vector_particles_from_python_fields - - subroutine set_vector_particles_from_python_fields_array(function, function_len, dim, & - npart, natt, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & - old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - use global_parameters, only: FIELD_NAME_LEN - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart, natt - integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - integer(c_int), intent(in), value :: fld_name_len - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt + end subroutine set_detectors_from_python_sp + + !Subroutine to call c_wrapper function set_scalar_particles_from_python_fields + subroutine set_scalar_particles_from_python_fields_sp(function, function_len, dim, & + npart, natt, x, y, z, t, dt, nfields, field_names, field_vals, old_nfields, & + old_field_names, old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, & + is_array, result, stat) + integer, intent(in) :: function_len + character(len = *) :: function + integer, intent(in) :: dim, npart, natt + integer, dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + real(kind=c_double), dimension(npart), intent(in) :: x + real(kind=c_double), dimension(:), intent(in) :: y + real(kind=c_double), dimension(:), intent(in) :: z + real(kind=c_double), intent(in) :: t + real(kind=c_double), intent(in) :: dt + logical, intent(in) :: is_array character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + real(kind=c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + real(kind=c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes - real(c_double), dimension(dim*natt,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_vector_particles_from_python_fields_array - end interface set_vector_particles_from_python_fields - - interface set_tensor_particles_from_python - subroutine set_tensor_particles_from_python(function, function_len, dim, & - npart, x, y, z, t, dt, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - real(c_double), dimension(dim,dim,1,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_tensor_particles_from_python - - subroutine set_tensor_particles_from_python_array(function, function_len, dim, & - npart, natt, x, y, z, t, dt, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char) :: function - integer(c_int), intent(in), value :: dim, npart, natt - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt - real(c_double), dimension(dim,dim,natt,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_tensor_particles_from_python_array - end interface set_tensor_particles_from_python - - interface set_tensor_particles_from_python_fields - module procedure set_tensor_particles_from_python_fields_sp - - subroutine set_tensor_particles_from_python_fields(function, function_len, dim, & - npart, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & - old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - use global_parameters, only: FIELD_NAME_LEN - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char):: function - integer(c_int), intent(in), value :: dim, npart - integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - integer(c_int), intent(in), value :: fld_name_len - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt + integer, dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(kind=c_double), dimension(:,:), intent(in) :: old_attributes + real(kind=c_double), dimension(natt, npart), intent(out) :: result + integer, intent(out) :: stat + + real(kind=c_double), dimension(natt, npart) :: lresult + + if (is_array) then + call set_scalar_particles_from_python_fields(function, function_len, dim, npart, natt, & + real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & + real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & + old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & + old_att_dims, real(old_attributes, kind=c_double), lresult, stat) + else + call set_scalar_particles_from_python_fields(function, function_len, dim, npart, & + real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & + real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & + old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & + old_att_dims, real(old_attributes, kind=c_double), lresult, stat) + end if + + result = lresult + end subroutine set_scalar_particles_from_python_fields_sp + + !Subroutine to call c_wrapper function set_vector_particles_from_python_fields + subroutine set_vector_particles_from_python_fields_sp(function, function_len, dim, & + npart, natt, x, y, z, t, dt, nfields, field_names, field_vals, old_nfields, & + old_field_names, old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, & + is_array, result, stat) + integer, intent(in) :: function_len + character(len = *) :: function + integer, intent(in) :: dim, npart, natt + integer, dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + real(kind=c_double), dimension(npart), intent(in) :: x + real(kind=c_double), dimension(:), intent(in) :: y + real(kind=c_double), dimension(:), intent(in) :: z + real(kind=c_double), intent(in) :: t + real(kind=c_double), intent(in) :: dt + logical, intent(in) :: is_array character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + real(kind=c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + real(kind=c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes - real(c_double), dimension(dim,dim,1,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_tensor_particles_from_python_fields + integer, dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(kind=c_double), dimension(:,:), intent(in) :: old_attributes + real(kind=c_double), dimension(dim*natt,npart), intent(out) :: result + integer, intent(out) :: stat - subroutine set_tensor_particles_from_python_fields_array(function, function_len, dim, & - npart, natt, x, y, z, t, dt, fld_name_len, nfields, field_names, field_vals, old_nfields, old_field_names, & - old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, result, stat) bind(c) - use iso_c_binding, only: c_double, c_int, c_char - use global_parameters, only: FIELD_NAME_LEN - implicit none - integer(c_int), intent(in), value :: function_len - character(kind=c_char):: function - integer(c_int), intent(in), value :: dim, npart, natt - integer(c_int), dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - integer(c_int), intent(in), value :: fld_name_len - real(c_double), dimension(npart), intent(in) :: x, y, z - real(c_double), intent(in), value :: t, dt + real(kind=c_double), dimension(dim*natt,npart) :: lresult + if (is_array) then + call set_vector_particles_from_python_fields(function, function_len, dim, npart, natt, & + real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & + real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & + old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & + old_att_dims, real(old_attributes, kind=c_double), lresult, stat) + else + call set_vector_particles_from_python_fields(function, function_len, dim, npart, & + real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & + real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & + old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & + old_att_dims, real(old_attributes, kind=c_double), lresult, stat) + end if + + result = lresult + end subroutine set_vector_particles_from_python_fields_sp + + !Subroutine to call c_wrapper function set_tensor_particles_from_python_fields + subroutine set_tensor_particles_from_python_fields_sp(function, function_len, dim, & + npart, natt, x, y, z, t, dt, nfields, field_names, field_vals, old_nfields, & + old_field_names, old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, & + is_array, result, stat) + integer, intent(in) :: function_len + character(len = *) :: function + integer, intent(in) :: dim, npart, natt + integer, dimension(3), intent(in) :: nfields, old_nfields, old_nattributes + real(kind=c_double), dimension(npart), intent(in) :: x + real(kind=c_double), dimension(:), intent(in) :: y + real(kind=c_double), dimension(:), intent(in) :: z + real(kind=c_double), intent(in) :: t + real(kind=c_double), intent(in) :: dt + logical, intent(in) :: is_array character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals + real(kind=c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals + real(kind=c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer(c_int), dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(c_double), dimension(old_nattributes(1)+dim*old_nattributes(2)+dim**2*old_nattributes(3),npart), intent(in) :: old_attributes - real(c_double), dimension(dim,dim,natt,npart), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine set_tensor_particles_from_python_fields_array - end interface set_tensor_particles_from_python_fields - - interface real_from_python - module procedure real_from_python_sp, real_from_python_interface - - subroutine real_from_python(function, function_len, t, result, stat) - use iso_c_binding, only: c_double, c_int, c_char - implicit none - integer(c_int), intent(in) :: function_len - character(kind=c_char, len=function_len), intent(in) :: function - real(kind = c_double), intent(in) :: t - real(kind = c_double), intent(out) :: result - integer(c_int), intent(out) :: stat - end subroutine real_from_python - end interface real_from_python - - interface real_vector_from_python - module procedure real_vector_from_python_interface, real_vector_from_python_sp - - subroutine real_vector_from_python(function, function_len, t, result,& - & result_len, stat) bind(c) - use :: iso_c_binding - implicit none - integer(c_int), intent(in) :: function_len - character(kind=c_char,len = 1), intent(in) :: function - real(kind = c_double), intent(in) :: t - type(c_ptr), intent(out) :: result - integer(c_int), intent(out) :: result_len, stat - end subroutine real_vector_from_python - end interface real_vector_from_python - - interface integer_vector_from_python - module procedure integer_vector_from_python_interface - - subroutine integer_vector_from_python(function, function_len, t, result,& - & result_len, stat) bind(c) - use :: iso_c_binding - implicit none - integer(c_int), intent(in) :: function_len - character(kind=c_char,len = 1), intent(in) :: function - real(kind=c_double), intent(in) :: t - type(c_ptr), intent(out) :: result - integer(c_int), intent(out) :: result_len, stat - end subroutine integer_vector_from_python - end interface integer_vector_from_python - - interface - subroutine free_c_vector(vector) bind(c) - use :: iso_c_binding - implicit none - type(c_ptr) :: vector - end subroutine - end interface - - interface integer_from_python - module procedure integer_from_python_sp, integer_from_python_interface - - subroutine integer_from_python(function, function_len, t, result, stat) - use iso_c_binding, only: c_double - implicit none - integer, intent(in) :: function_len - character(len = function_len), intent(in) :: function - real(kind = c_double), intent(in) :: t - integer, intent(out) :: result + integer, dimension(sum(old_nattributes)), intent(in) :: old_att_dims + real(kind=c_double), dimension(:,:), intent(in) :: old_attributes + real(kind=c_double), dimension(dim,dim,natt,npart), intent(out) :: result integer, intent(out) :: stat - end subroutine integer_from_python - end interface integer_from_python - interface string_from_python - module procedure string_from_python_sp, string_from_python_interface + real(kind=c_double), dimension(dim,dim,natt,npart) :: lresult + + if (is_array) then + call set_tensor_particles_from_python_fields(function, function_len, dim, npart, natt, & + real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & + real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & + old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & + old_att_dims, real(old_attributes, kind=c_double), lresult, stat) + else + call set_tensor_particles_from_python_fields(function, function_len, dim, npart, & + real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & + real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & + old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & + old_att_dims, real(old_attributes, kind=c_double), lresult, stat) + end if - subroutine string_from_python(function, function_len, result_len, t, result, stat) - use iso_c_binding, only: c_double - implicit none + result = lresult + end subroutine set_tensor_particles_from_python_fields_sp + + subroutine real_from_python_sp(function, function_len, t, result, stat) integer, intent(in) :: function_len character(len = function_len), intent(in) :: function - integer, intent(inout) :: result_len - real(kind = c_double), intent(in) :: t - character(len = result_len), intent(out) :: result + real(kind = c_float), intent(in) :: t + real(kind = c_float), intent(out) :: result integer, intent(out) :: stat - end subroutine string_from_python - end interface string_from_python - private + real(kind = c_double) :: lresult - public :: set_scalar_field_from_python, set_integer_array_from_python, & - & set_vector_field_from_python, set_tensor_field_from_python, & - & set_detectors_from_python, real_from_python, real_vector_from_python, & - & integer_from_python, string_from_python, integer_vector_from_python, & - & set_scalar_particles_from_python_fields, set_scalar_particles_from_python, & - & set_vector_particles_from_python_fields, set_vector_particles_from_python, & - & set_tensor_particles_from_python_fields, set_tensor_particles_from_python, & - deallocate_c_array + call real_from_python(function, function_len, real(t, kind = c_double), lresult, stat) + result = lresult -contains + end subroutine real_from_python_sp + subroutine real_from_python_interface(function, current_time, result, stat) + character(len = *), intent(in) :: function + real, intent(in) :: current_time + real, intent(out) :: result + integer, optional, intent(out) :: stat - subroutine set_scalar_field_from_python_sp(function, function_len, dim, & - & nodes, x, y, z, t, result, stat) - integer, intent(in) :: function_len - character(len = function_len) :: function - integer, intent(in) :: dim - integer, intent(in) :: nodes - real(kind = c_float), dimension(nodes), intent(in) :: x - real(kind = c_float), dimension(:), intent(in) :: y - real(kind = c_float), dimension(:), intent(in) :: z - real(kind = c_float), intent(in) :: t - real(kind = c_float), dimension(nodes), intent(out) :: result - integer, intent(out) :: stat + integer :: lstat - real(kind = c_double), dimension(nodes) :: lresult + if(present(stat)) stat = 0 - call set_scalar_field_from_python(function, function_len, dim, & - & nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), lresult, stat) - result = lresult - - end subroutine set_scalar_field_from_python_sp - - subroutine set_integer_array_from_python_sp(function, function_len, dim, nodes, x, y, z, t, result, stat) - integer, intent(in) :: function_len - character(len = function_len), intent(in) :: function - integer, intent(in) :: dim - integer, intent(in) :: nodes - real(kind = c_float), dimension(nodes), intent(in) :: x - real(kind = c_float), dimension(:), intent(in) :: y - real(kind = c_float), dimension(:), intent(in) :: z - real(kind = c_float), intent(in) :: t - integer, dimension(nodes), intent(out) :: result - integer, intent(out) :: stat - - call set_integer_array_from_python(function, function_len, dim, nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), result, stat) - - end subroutine set_integer_array_from_python_sp - - subroutine set_vector_field_from_python_sp(function, function_len, dim, & - & nodes, x, y, z, t, result_dim, result_x, result_y, result_z, & - & stat) - integer, intent(in) :: function_len - character(len = function_len) :: function - integer, intent(in) :: dim - integer, intent(in) :: nodes - real(kind = c_float), dimension(nodes), intent(in) :: x - real(kind = c_float), dimension(:), intent(in) :: y - real(kind = c_float), dimension(:), intent(in) :: z - real(kind = c_float), intent(in) :: t - integer, intent(in) :: result_dim - real(kind = c_float), dimension(nodes), intent(out) :: result_x - real(kind = c_float), dimension(:), intent(out) :: result_y - real(kind = c_float), dimension(:), intent(out) :: result_z - integer, intent(out) :: stat - - real(kind = c_double), dimension(size(result_x)) :: lresult_x - real(kind = c_double), dimension(size(result_y)) :: lresult_y - real(kind = c_double), dimension(size(result_z)) :: lresult_z - - call set_vector_field_from_python(function, function_len, dim, & - & nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), result_dim, lresult_x, lresult_y, lresult_z, & - & stat) - result_x = lresult_x - result_y = lresult_y - result_z = lresult_z - - end subroutine set_vector_field_from_python_sp - - subroutine set_tensor_field_from_python_sp(function, function_len, dim, & - & nodes, x, y, z, t, result_dim, result, stat) - integer, intent(in) :: function_len - character(len = function_len) :: function - integer, intent(in) :: dim - integer, intent(in) :: nodes - real(kind = c_float), dimension(nodes), intent(in) :: x - real(kind = c_float), dimension(:), intent(in) :: y - real(kind = c_float), dimension(:), intent(in) :: z - real(kind = c_float), intent(in) :: t - integer, dimension(2), intent(in) :: result_dim - real(kind = c_float), dimension(:, :, :), intent(out) :: result - integer, intent(out) :: stat - - real(kind = c_double), dimension(size(result, 1), size(result, 2), size(result, 3)) :: lresult - - call set_tensor_field_from_python(function, function_len, dim, & - & nodes, real(x, kind = c_double), real(y, kind = c_double), real(z, kind = c_double), real(t, kind = c_double), result_dim, lresult, stat) - result = lresult - - end subroutine set_tensor_field_from_python_sp - - subroutine set_detectors_from_python_sp(function, function_len, dim, & - & ndete, t, rdim, result_x, result_y, result_z, stat) - integer, intent(in) :: function_len - character(len = function_len) :: function - integer, intent(in) :: dim,rdim - integer, intent(in) :: ndete - real(kind = c_float), intent(in) :: t - real(kind = c_float), dimension(ndete), intent(out) :: result_x - real(kind = c_float), dimension(:), intent(out) :: result_y - real(kind = c_float), dimension(:), intent(out) :: result_z - integer, intent(out) :: stat - - real(kind = c_double), dimension(size(result_x)) :: lresult_x - real(kind = c_double), dimension(size(result_y)) :: lresult_y - real(kind = c_double), dimension(size(result_z)) :: lresult_z - - call set_detectors_from_python(function, function_len, dim, & - & ndete, real(t, kind = c_double), rdim, lresult_x, lresult_y, lresult_z, stat) - result_x = lresult_x - result_y = lresult_y - result_z = lresult_z - - end subroutine set_detectors_from_python_sp - - !Subroutine to call c_wrapper function set_scalar_particles_from_python_fields - subroutine set_scalar_particles_from_python_fields_sp(function, function_len, dim, & - npart, natt, x, y, z, t, dt, nfields, field_names, field_vals, old_nfields, & - old_field_names, old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, & - is_array, result, stat) - integer, intent(in) :: function_len - character(len = *) :: function - integer, intent(in) :: dim, npart, natt - integer, dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - real(kind=c_double), dimension(npart), intent(in) :: x - real(kind=c_double), dimension(:), intent(in) :: y - real(kind=c_double), dimension(:), intent(in) :: z - real(kind=c_double), intent(in) :: t - real(kind=c_double), intent(in) :: dt - logical, intent(in) :: is_array - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(kind=c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(kind=c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer, dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(kind=c_double), dimension(:,:), intent(in) :: old_attributes - real(kind=c_double), dimension(natt, npart), intent(out) :: result - integer, intent(out) :: stat - - real(kind=c_double), dimension(natt, npart) :: lresult - - if (is_array) then - call set_scalar_particles_from_python_fields(function, function_len, dim, npart, natt, & - real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & - real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & - old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & - old_att_dims, real(old_attributes, kind=c_double), lresult, stat) - else - call set_scalar_particles_from_python_fields(function, function_len, dim, npart, & - real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & - real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & - old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & - old_att_dims, real(old_attributes, kind=c_double), lresult, stat) - end if - - result = lresult - end subroutine set_scalar_particles_from_python_fields_sp - - !Subroutine to call c_wrapper function set_vector_particles_from_python_fields - subroutine set_vector_particles_from_python_fields_sp(function, function_len, dim, & - npart, natt, x, y, z, t, dt, nfields, field_names, field_vals, old_nfields, & - old_field_names, old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, & - is_array, result, stat) - integer, intent(in) :: function_len - character(len = *) :: function - integer, intent(in) :: dim, npart, natt - integer, dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - real(kind=c_double), dimension(npart), intent(in) :: x - real(kind=c_double), dimension(:), intent(in) :: y - real(kind=c_double), dimension(:), intent(in) :: z - real(kind=c_double), intent(in) :: t - real(kind=c_double), intent(in) :: dt - logical, intent(in) :: is_array - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(kind=c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(kind=c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer, dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(kind=c_double), dimension(:,:), intent(in) :: old_attributes - real(kind=c_double), dimension(dim*natt,npart), intent(out) :: result - integer, intent(out) :: stat - - real(kind=c_double), dimension(dim*natt,npart) :: lresult - if (is_array) then - call set_vector_particles_from_python_fields(function, function_len, dim, npart, natt, & - real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & - real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & - old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & - old_att_dims, real(old_attributes, kind=c_double), lresult, stat) - else - call set_vector_particles_from_python_fields(function, function_len, dim, npart, & - real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & - real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & - old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & - old_att_dims, real(old_attributes, kind=c_double), lresult, stat) - end if - - result = lresult - end subroutine set_vector_particles_from_python_fields_sp - - !Subroutine to call c_wrapper function set_tensor_particles_from_python_fields - subroutine set_tensor_particles_from_python_fields_sp(function, function_len, dim, & - npart, natt, x, y, z, t, dt, nfields, field_names, field_vals, old_nfields, & - old_field_names, old_field_vals, old_nattributes, old_att_names, old_att_dims, old_attributes, & - is_array, result, stat) - integer, intent(in) :: function_len - character(len = *) :: function - integer, intent(in) :: dim, npart, natt - integer, dimension(3), intent(in) :: nfields, old_nfields, old_nattributes - real(kind=c_double), dimension(npart), intent(in) :: x - real(kind=c_double), dimension(:), intent(in) :: y - real(kind=c_double), dimension(:), intent(in) :: z - real(kind=c_double), intent(in) :: t - real(kind=c_double), intent(in) :: dt - logical, intent(in) :: is_array - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(nfields)), intent(in) :: field_names - real(kind=c_double), dimension(nfields(1)+dim*nfields(2)+dim**2*nfields(3),npart), intent(in) :: field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nfields)), intent(in) :: old_field_names - real(kind=c_double), dimension(old_nfields(1)+dim*old_nfields(2)+dim**2*old_nfields(3),npart), intent(in) :: old_field_vals - character(kind=c_char), dimension(FIELD_NAME_LEN,sum(old_nattributes)), intent(in) :: old_att_names - integer, dimension(sum(old_nattributes)), intent(in) :: old_att_dims - real(kind=c_double), dimension(:,:), intent(in) :: old_attributes - real(kind=c_double), dimension(dim,dim,natt,npart), intent(out) :: result - integer, intent(out) :: stat - - real(kind=c_double), dimension(dim,dim,natt,npart) :: lresult - - if (is_array) then - call set_tensor_particles_from_python_fields(function, function_len, dim, npart, natt, & - real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & - real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & - old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & - old_att_dims, real(old_attributes, kind=c_double), lresult, stat) - else - call set_tensor_particles_from_python_fields(function, function_len, dim, npart, & - real(x, kind=c_double), real(y, kind=c_double), real(z, kind=c_double), real(t, kind=c_double), & - real(dt, kind=c_double), FIELD_NAME_LEN, nfields, field_names, real(field_vals, kind=c_double), & - old_nfields, old_field_names, real(old_field_vals, kind=c_double), old_nattributes, old_att_names, & - old_att_dims, real(old_attributes, kind=c_double), lresult, stat) - end if - - result = lresult - end subroutine set_tensor_particles_from_python_fields_sp - - subroutine real_from_python_sp(function, function_len, t, result, stat) - integer, intent(in) :: function_len - character(len = function_len), intent(in) :: function - real(kind = c_float), intent(in) :: t - real(kind = c_float), intent(out) :: result - integer, intent(out) :: stat - - real(kind = c_double) :: lresult - - call real_from_python(function, function_len, real(t, kind = c_double), lresult, stat) - result = lresult - - end subroutine real_from_python_sp - - subroutine real_from_python_interface(function, current_time, result, stat) - character(len = *), intent(in) :: function - real, intent(in) :: current_time - real, intent(out) :: result - integer, optional, intent(out) :: stat - - integer :: lstat - - if(present(stat)) stat = 0 - - call real_from_python(function, len_trim(function), current_time, result, lstat) - - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - return - else - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(function) - FLExit("Dying!") + call real_from_python(function, len_trim(function), current_time, result, lstat) + + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + return + else + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(function) + FLExit("Dying!") + end if end if - end if - end subroutine real_from_python_interface + end subroutine real_from_python_interface - subroutine real_vector_from_python_sp(function, current_time, result, stat) - character(len = *), intent(in) :: function - real(kind=c_float), intent(in) :: current_time - real(kind=c_float), dimension(:), pointer, intent(out) :: result - integer, optional, intent(out) :: stat + subroutine real_vector_from_python_sp(function, current_time, result, stat) + character(len = *), intent(in) :: function + real(kind=c_float), intent(in) :: current_time + real(kind=c_float), dimension(:), pointer, intent(out) :: result + integer, optional, intent(out) :: stat - real(kind=c_double), dimension(:), pointer :: lresult + real(kind=c_double), dimension(:), pointer :: lresult - call real_vector_from_python(function, real(current_time, kind=c_double),& - & lresult, stat) + call real_vector_from_python(function, real(current_time, kind=c_double),& + & lresult, stat) - allocate(result(size(lresult))) + allocate(result(size(lresult))) - result=lresult + result=lresult - deallocate(lresult) + deallocate(lresult) - end subroutine real_vector_from_python_sp + end subroutine real_vector_from_python_sp - subroutine real_vector_from_python_interface(function, current_time, result, stat) - character(len = *), intent(in) :: function - real(kind=c_double), intent(in) :: current_time - real(kind=c_double), dimension(:), pointer, intent(out) :: result - integer, optional, intent(out) :: stat + subroutine real_vector_from_python_interface(function, current_time, result, stat) + character(len = *), intent(in) :: function + real(kind=c_double), intent(in) :: current_time + real(kind=c_double), dimension(:), pointer, intent(out) :: result + integer, optional, intent(out) :: stat - type(c_ptr) :: c_result - integer(kind=c_int) :: c_result_len - real, dimension(:), pointer :: tmp_result - integer(kind=c_int) :: lstat + type(c_ptr) :: c_result + integer(kind=c_int) :: c_result_len + real, dimension(:), pointer :: tmp_result + integer(kind=c_int) :: lstat - if(present(stat)) stat = 0 + if(present(stat)) stat = 0 - call real_vector_from_python(function, & + call real_vector_from_python(function, & int(len_trim(function), kind=c_int), & real(current_time, kind=c_double), c_result, c_result_len, lstat) - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - return - else - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(function) - FLExit("Dying!") + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + return + else + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(function) + FLExit("Dying!") + end if end if - end if - call c_f_pointer(c_result, tmp_result, (/c_result_len/)) + call c_f_pointer(c_result, tmp_result, (/c_result_len/)) - allocate(result(c_result_len)) + allocate(result(c_result_len)) - result=tmp_result + result=tmp_result - call free_c_vector(c_result) + call free_c_vector(c_result) - end subroutine real_vector_from_python_interface + end subroutine real_vector_from_python_interface - subroutine integer_vector_from_python_interface(function, current_time, result, stat) - character(len = *), intent(in) :: function - real, intent(in) :: current_time - integer, dimension(:), pointer, intent(out) :: result - integer, optional, intent(out) :: stat + subroutine integer_vector_from_python_interface(function, current_time, result, stat) + character(len = *), intent(in) :: function + real, intent(in) :: current_time + integer, dimension(:), pointer, intent(out) :: result + integer, optional, intent(out) :: stat - type(c_ptr) :: c_result - integer(kind=c_int) :: c_result_len - integer, dimension(:), pointer :: tmp_result - integer(kind=c_int) :: lstat + type(c_ptr) :: c_result + integer(kind=c_int) :: c_result_len + integer, dimension(:), pointer :: tmp_result + integer(kind=c_int) :: lstat - if(present(stat)) stat = 0 + if(present(stat)) stat = 0 - call integer_vector_from_python(function, & + call integer_vector_from_python(function, & int(len_trim(function), kind=c_int), & real(current_time, kind=c_double), c_result, c_result_len, lstat) - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - return - else - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(function) - FLExit("Dying!") + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + return + else + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(function) + FLExit("Dying!") + end if end if - end if - call c_f_pointer(c_result, tmp_result, (/c_result_len/)) + call c_f_pointer(c_result, tmp_result, (/c_result_len/)) - allocate(result(c_result_len)) + allocate(result(c_result_len)) - result=tmp_result + result=tmp_result - call free_c_vector(c_result) + call free_c_vector(c_result) - end subroutine integer_vector_from_python_interface + end subroutine integer_vector_from_python_interface - subroutine integer_from_python_sp(function, function_len, t, result, stat) - integer, intent(in) :: function_len - character(len = function_len), intent(in) :: function - real(kind = c_float), intent(in) :: t - integer, intent(out) :: result - integer, intent(out) :: stat + subroutine integer_from_python_sp(function, function_len, t, result, stat) + integer, intent(in) :: function_len + character(len = function_len), intent(in) :: function + real(kind = c_float), intent(in) :: t + integer, intent(out) :: result + integer, intent(out) :: stat - call integer_from_python(function, function_len, real(t, kind = c_double), result, stat) + call integer_from_python(function, function_len, real(t, kind = c_double), result, stat) - end subroutine integer_from_python_sp + end subroutine integer_from_python_sp - subroutine integer_from_python_interface(function, current_time, result, stat) - character(len = *), intent(in) :: function - real, intent(in) :: current_time - integer, intent(out) :: result - integer, optional, intent(out) :: stat + subroutine integer_from_python_interface(function, current_time, result, stat) + character(len = *), intent(in) :: function + real, intent(in) :: current_time + integer, intent(out) :: result + integer, optional, intent(out) :: stat - integer :: lstat + integer :: lstat - if(present(stat)) stat = 0 + if(present(stat)) stat = 0 - call integer_from_python(function, len_trim(function), current_time, result, lstat) + call integer_from_python(function, len_trim(function), current_time, result, lstat) - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - return - else - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(function) - FLExit("Dying!") + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + return + else + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(function) + FLExit("Dying!") + end if end if - end if - end subroutine integer_from_python_interface + end subroutine integer_from_python_interface - subroutine string_from_python_sp(function, function_len, result_len, t, result, stat) - integer, intent(in) :: function_len - character(len = function_len), intent(in) :: function - integer, intent(inout) :: result_len - real(kind = c_float), intent(in) :: t - character(len = result_len), intent(out) :: result - integer, intent(out) :: stat + subroutine string_from_python_sp(function, function_len, result_len, t, result, stat) + integer, intent(in) :: function_len + character(len = function_len), intent(in) :: function + integer, intent(inout) :: result_len + real(kind = c_float), intent(in) :: t + character(len = result_len), intent(out) :: result + integer, intent(out) :: stat - call string_from_python(function, function_len, result_len, real(t, kind = c_double), result, stat) + call string_from_python(function, function_len, result_len, real(t, kind = c_double), result, stat) - end subroutine string_from_python_sp + end subroutine string_from_python_sp - subroutine string_from_python_interface(function, t, result, stat) - character(len = *), intent(in) :: function - real, intent(in) :: t - character(len = *), intent(out) :: result - integer, optional, intent(out) :: stat + subroutine string_from_python_interface(function, t, result, stat) + character(len = *), intent(in) :: function + real, intent(in) :: t + character(len = *), intent(out) :: result + integer, optional, intent(out) :: stat - integer :: lstat, result_len + integer :: lstat, result_len - if(present(stat)) stat = 0 - result_len = len(result) + if(present(stat)) stat = 0 + result_len = len(result) - call string_from_python(function, len_trim(function), result_len, t, result, lstat) + call string_from_python(function, len_trim(function), result_len, t, result, lstat) - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - return - else - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(function) - FLExit("Dying!") + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + return + else + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(function) + FLExit("Dying!") + end if end if - end if - result(result_len + 1:) = "" + result(result_len + 1:) = "" - end subroutine string_from_python_interface + end subroutine string_from_python_interface end module embed_python diff --git a/femtools/EventCounter.F90 b/femtools/EventCounter.F90 index 0168320ca2..a431ba3330 100644 --- a/femtools/EventCounter.F90 +++ b/femtools/EventCounter.F90 @@ -28,62 +28,62 @@ #include "fdebug.h" module eventcounter - !--------------------------------------------------------------------- - ! - !! This module is used to keep a record of events (eg. how often a task was performed) - ! - !--------------------------------------------------------------------- + !--------------------------------------------------------------------- + ! + !! This module is used to keep a record of events (eg. how often a task was performed) + ! + !--------------------------------------------------------------------- - use fldebug + use fldebug - implicit none + implicit none - private + private - ! List of identifiers - integer, parameter, public ::EVENT_ADAPTIVITY=1 - integer, parameter, public ::EVENT_MESH_MOVEMENT=2 - integer, parameter :: MAXIMUM_NUMBER_OF_EVENTS=2 - ! Data arrays - integer, save :: events(MAXIMUM_NUMBER_OF_EVENTS) = 0 + ! List of identifiers + integer, parameter, public ::EVENT_ADAPTIVITY=1 + integer, parameter, public ::EVENT_MESH_MOVEMENT=2 + integer, parameter :: MAXIMUM_NUMBER_OF_EVENTS=2 + ! Data arrays + integer, save :: events(MAXIMUM_NUMBER_OF_EVENTS) = 0 - public :: incrementeventcounter, geteventcounter, seteventcounter, eventcount + public :: incrementeventcounter, geteventcounter, seteventcounter, eventcount contains - subroutine incrementeventcounter(event) - integer, intent(in)::event + subroutine incrementeventcounter(event) + integer, intent(in)::event - assert(event > 0 .and. event <= MAXIMUM_NUMBER_OF_EVENTS) - events(event) = events(event) + 1 + assert(event > 0 .and. event <= MAXIMUM_NUMBER_OF_EVENTS) + events(event) = events(event) + 1 - end subroutine incrementeventcounter + end subroutine incrementeventcounter - subroutine geteventcounter(event, cnt) - integer, intent(in)::event - integer, intent(out)::cnt + subroutine geteventcounter(event, cnt) + integer, intent(in)::event + integer, intent(out)::cnt - assert(event > 0 .and. event <= MAXIMUM_NUMBER_OF_EVENTS) - cnt = events(event) + assert(event > 0 .and. event <= MAXIMUM_NUMBER_OF_EVENTS) + cnt = events(event) - end subroutine geteventcounter + end subroutine geteventcounter - subroutine seteventcounter(event, cnt) - integer, intent(in)::event, cnt + subroutine seteventcounter(event, cnt) + integer, intent(in)::event, cnt - assert(event > 0 .and. event <= MAXIMUM_NUMBER_OF_EVENTS) - assert(cnt > 0) - events(event) = cnt + assert(event > 0 .and. event <= MAXIMUM_NUMBER_OF_EVENTS) + assert(cnt > 0) + events(event) = cnt - end subroutine seteventcounter + end subroutine seteventcounter - function eventcount(event) result(cnt) - integer, intent(in) :: event + function eventcount(event) result(cnt) + integer, intent(in) :: event - integer :: cnt + integer :: cnt - call geteventcounter(event, cnt) + call geteventcounter(event, cnt) - end function eventcount + end function eventcount end module eventcounter diff --git a/femtools/Exodusii_Common.F90 b/femtools/Exodusii_Common.F90 index e48256b8c4..7499820f7b 100644 --- a/femtools/Exodusii_Common.F90 +++ b/femtools/Exodusii_Common.F90 @@ -29,72 +29,72 @@ module exodusii_common - type EXOnode - integer :: nodeID - double precision :: x(3) - end type EXOnode + type EXOnode + integer :: nodeID + double precision :: x(3) + end type EXOnode - type EXOelement - integer :: elementID, type, numTags, blockID - integer, pointer :: tags(:), nodeIDs(:) - end type EXOelement + type EXOelement + integer :: elementID, type, numTags, blockID + integer, pointer :: tags(:), nodeIDs(:) + end type EXOelement - contains +contains - ! ----------------------------------------------------------------- - ! Tries valid exodusii file extensions and quits if none of them - ! has been found aka file does not exist - subroutine get_exodusii_filename(filename, lfilename, fileExists) - character(len=*), intent(in) :: filename - character(len=*), intent(inout) :: lfilename - logical, intent(inout) :: fileExists - ! An ExodusII file can have the following file extensions: - ! e, exo, E, EXO, our first guess shall be exo - lfilename = trim(filename)//".exo" - inquire(file = trim(lfilename), exist = fileExists) - if(.not. fileExists) then - lfilename = trim(filename) // ".e" + ! ----------------------------------------------------------------- + ! Tries valid exodusii file extensions and quits if none of them + ! has been found aka file does not exist + subroutine get_exodusii_filename(filename, lfilename, fileExists) + character(len=*), intent(in) :: filename + character(len=*), intent(inout) :: lfilename + logical, intent(inout) :: fileExists + ! An ExodusII file can have the following file extensions: + ! e, exo, E, EXO, our first guess shall be exo + lfilename = trim(filename)//".exo" inquire(file = trim(lfilename), exist = fileExists) if(.not. fileExists) then - lfilename = trim(filename) // ".EXO" - inquire(file = trim(lfilename), exist = fileExists) - if(.not. fileExists) then - lfilename = trim(filename) // ".E" - inquire(file = trim(lfilename), exist = fileExists) - end if + lfilename = trim(filename) // ".e" + inquire(file = trim(lfilename), exist = fileExists) + if(.not. fileExists) then + lfilename = trim(filename) // ".EXO" + inquire(file = trim(lfilename), exist = fileExists) + if(.not. fileExists) then + lfilename = trim(filename) // ".E" + inquire(file = trim(lfilename), exist = fileExists) + end if + end if end if - end if - lfilename = trim(lfilename) - end subroutine get_exodusii_filename + lfilename = trim(lfilename) + end subroutine get_exodusii_filename - ! ----------------------------------------------------------------- - ! Reorder to Fluidity node ordering - subroutine toFluidityElementNodeOrdering( ele_nodes, elemType ) - integer, dimension(:), intent(inout) :: ele_nodes - integer, intent(in) :: elemType + ! ----------------------------------------------------------------- + ! Reorder to Fluidity node ordering + subroutine toFluidityElementNodeOrdering( ele_nodes, elemType ) + integer, dimension(:), intent(inout) :: ele_nodes + integer, intent(in) :: elemType - integer i - integer, dimension(size(ele_nodes)) :: nodeOrder + integer i + integer, dimension(size(ele_nodes)) :: nodeOrder - ! Specify node ordering - select case( elemType ) - ! Quads - case (3) - nodeOrder = (/1, 2, 4, 3/) - ! Hexahedron - case (5) - nodeOrder = (/1, 2, 4, 3, 5, 6, 8, 7/) - case default - do i=1, size(ele_nodes) - nodeOrder(i) = i - end do - end select + ! Specify node ordering + select case( elemType ) + ! Quads + case (3) + nodeOrder = (/1, 2, 4, 3/) + ! Hexahedron + case (5) + nodeOrder = (/1, 2, 4, 3, 5, 6, 8, 7/) + case default + do i=1, size(ele_nodes) + nodeOrder(i) = i + end do + end select - ele_nodes = ele_nodes(nodeOrder) + ele_nodes = ele_nodes(nodeOrder) - end subroutine toFluidityElementNodeOrdering + end subroutine toFluidityElementNodeOrdering end module exodusii_common diff --git a/femtools/Exodusii_F_Interface.F90 b/femtools/Exodusii_F_Interface.F90 index 1b055b49de..c65c2832ee 100644 --- a/femtools/Exodusii_F_Interface.F90 +++ b/femtools/Exodusii_F_Interface.F90 @@ -1,223 +1,223 @@ module exodusii_f_interface - use iso_c_binding - implicit none - - private - - public :: f_read_ex_open, & - f_ex_get_init, f_ex_get_coord, & - f_ex_get_node_num_map, f_ex_get_elem_num_map, & - f_ex_get_elem_order_map, f_ex_get_elem_blk_ids, & - f_ex_get_elem_block, & - f_ex_get_elem_block_parameters, & - f_ex_get_elem_connectivity, & - f_ex_get_node_set_param, f_ex_get_node_set_node_list, & - f_ex_get_side_set_ids, f_ex_get_side_set_param, & - f_ex_get_side_set, f_ex_get_side_set_node_list, & - f_ex_close - - - ! Open an ExodusII mesh file - interface f_read_ex_open - function c_read_ex_open(path, mode, comp_ws, io_ws, version) result(exoid) bind(c) - use, intrinsic :: iso_c_binding - implicit none - character(kind=c_char, len=1):: path - integer(kind=c_int) :: mode - integer(kind=c_int) :: comp_ws - integer(kind=c_int) :: io_ws - real(kind=c_float) :: version - integer(kind=c_int) :: exoid - end function c_read_ex_open - end interface - - ! Get database parameters from exodusII file - interface f_ex_get_init - function c_ex_get_init(exoid, title, num_dim, num_nodes, num_elem, & - num_elem_blk, num_node_sets, num_side_sets) & - result(error) bind(c) - use, intrinsic :: iso_c_binding - !implicit none - integer(kind=c_int) :: exoid - character(kind=c_char, len=1):: title - integer(kind=c_int) :: num_dim - integer(kind=c_int) :: num_nodes - integer(kind=c_int) :: num_elem - integer(kind=c_int) :: num_elem_blk - integer(kind=c_int) :: num_node_sets - integer(kind=c_int) :: num_side_sets - integer(kind=c_int) :: error - end function c_ex_get_init - end interface - - ! Get coordinates of nodes: - interface f_ex_get_coord - function c_ex_get_coord(exoid, x, y, z) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - real(kind=c_float) :: x(*) - real(kind=c_float) :: y(*) - real(kind=c_float) :: z(*) - integer(kind=c_int) :: error - end function c_ex_get_coord - end interface - - ! Get node number map - interface f_ex_get_node_num_map - function c_ex_get_node_num_map(exoid, node_map) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: node_map(*) - integer(kind=c_int) :: error - end function c_ex_get_node_num_map - end interface - - ! Get element number map - interface f_ex_get_elem_num_map - function c_ex_get_elem_num_map(exoid, elem_num_map) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: elem_num_map(*) - integer(kind=c_int) :: error - end function c_ex_get_elem_num_map - end interface - - ! Get element order map: - interface f_ex_get_elem_order_map - function c_ex_get_elem_order_map(exoid, elem_order_map) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: elem_order_map(*) - integer(kind=c_int) :: error - end function c_ex_get_elem_order_map - end interface - - ! Get block ids: - interface f_ex_get_elem_blk_ids - function c_ex_get_elem_blk_ids(exoid, block_ids) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: block_ids(*) - integer(kind=c_int) :: error - end function c_ex_get_elem_blk_ids - end interface - - interface f_ex_get_elem_block - function c_ex_get_elem_block(exoid, block_id, elem_type, & - num_elem_in_block, & - num_nodes_per_elem, & - num_attr) & - result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: block_id - character(kind=c_char, len=1):: elem_type - integer(kind=c_int) :: num_elem_in_block - integer(kind=c_int) :: num_nodes_per_elem - integer(kind=c_int) :: num_attr - integer(kind=c_int) :: error - end function c_ex_get_elem_block - end interface - - ! Get block parameters - interface f_ex_get_elem_block_parameters - function c_ex_get_elem_block_parameters(exoid, num_elem_blk, & - block_ids, num_elem_in_block, & - num_nodes_per_elem) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: num_elem_blk - integer(kind=c_int) :: block_ids(*) - integer(kind=c_int) :: num_elem_in_block(*) - integer(kind=c_int) :: num_nodes_per_elem(*) - integer(kind=c_int) :: error - end function c_ex_get_elem_block_parameters - end interface - - interface f_ex_get_elem_connectivity - function c_ex_get_elem_connectivity(exoid, block_id, elem_connectivity) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: block_id - integer(kind=c_int) :: elem_connectivity(*) - integer(kind=c_int) :: error - end function c_ex_get_elem_connectivity - end interface - - interface f_ex_get_node_set_param - function c_ex_get_node_set_param(exoid, num_node_sets, node_set_ids, num_nodes_in_set) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: num_node_sets - integer(kind=c_int) :: node_set_ids(*) - integer(kind=c_int) :: num_nodes_in_set(*) - integer(kind=c_int) :: error - end function c_ex_get_node_set_param - end interface - - interface f_ex_get_node_set_node_list - function c_ex_get_node_set_node_list(exoid, num_node_sets, node_set_id, node_set_node_list) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: num_node_sets - integer(kind=c_int) :: node_set_id - integer(kind=c_int) :: node_set_node_list(*) - integer(kind=c_int) :: error - end function c_ex_get_node_set_node_list - end interface - - interface f_ex_get_side_set_ids - function c_ex_get_side_set_ids(exoid, side_set_ids) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: side_set_ids(*) - integer(kind=c_int) :: error - end function c_ex_get_side_set_ids - end interface - - interface f_ex_get_side_set_param - function c_ex_get_side_set_param(exoid, side_set_id, num_sides_in_set, num_df_in_set) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: side_set_id - integer(kind=c_int) :: num_sides_in_set - integer(kind=c_int) :: num_df_in_set - integer(kind=c_int) :: error - end function c_ex_get_side_set_param - end interface - - interface f_ex_get_side_set - function c_ex_get_side_set(exoid, side_set_id, elem_list, side_list) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: side_set_id - integer(kind=c_int) :: elem_list(*) - integer(kind=c_int) :: side_list(*) - integer(kind=c_int) :: error - end function c_ex_get_side_set - end interface - - interface f_ex_get_side_set_node_list - function c_ex_get_side_set_node_list(exoid, side_set_id, side_set_node_cnt_list, side_set_node_list) result(error) bind(c) - use, intrinsic :: iso_c_binding - integer(kind=c_int) :: exoid - integer(kind=c_int) :: side_set_id - integer(kind=c_int) :: side_set_node_cnt_list(*) - integer(kind=c_int) :: side_set_node_list(*) - integer(kind=c_int) :: error - end function c_ex_get_side_set_node_list - end interface - - ! Closing exodusII file - interface f_ex_close - function c_ex_close(exoid) result(ierr) bind(c) - use, intrinsic :: iso_c_binding - !implicit none - integer(kind=c_int) :: exoid - integer(kind=c_int) :: ierr - end function c_ex_close - end interface + use iso_c_binding + implicit none + + private + + public :: f_read_ex_open, & + f_ex_get_init, f_ex_get_coord, & + f_ex_get_node_num_map, f_ex_get_elem_num_map, & + f_ex_get_elem_order_map, f_ex_get_elem_blk_ids, & + f_ex_get_elem_block, & + f_ex_get_elem_block_parameters, & + f_ex_get_elem_connectivity, & + f_ex_get_node_set_param, f_ex_get_node_set_node_list, & + f_ex_get_side_set_ids, f_ex_get_side_set_param, & + f_ex_get_side_set, f_ex_get_side_set_node_list, & + f_ex_close + + + ! Open an ExodusII mesh file + interface f_read_ex_open + function c_read_ex_open(path, mode, comp_ws, io_ws, version) result(exoid) bind(c) + use, intrinsic :: iso_c_binding + implicit none + character(kind=c_char, len=1):: path + integer(kind=c_int) :: mode + integer(kind=c_int) :: comp_ws + integer(kind=c_int) :: io_ws + real(kind=c_float) :: version + integer(kind=c_int) :: exoid + end function c_read_ex_open + end interface + + ! Get database parameters from exodusII file + interface f_ex_get_init + function c_ex_get_init(exoid, title, num_dim, num_nodes, num_elem, & + num_elem_blk, num_node_sets, num_side_sets) & + result(error) bind(c) + use, intrinsic :: iso_c_binding + !implicit none + integer(kind=c_int) :: exoid + character(kind=c_char, len=1):: title + integer(kind=c_int) :: num_dim + integer(kind=c_int) :: num_nodes + integer(kind=c_int) :: num_elem + integer(kind=c_int) :: num_elem_blk + integer(kind=c_int) :: num_node_sets + integer(kind=c_int) :: num_side_sets + integer(kind=c_int) :: error + end function c_ex_get_init + end interface + + ! Get coordinates of nodes: + interface f_ex_get_coord + function c_ex_get_coord(exoid, x, y, z) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + real(kind=c_float) :: x(*) + real(kind=c_float) :: y(*) + real(kind=c_float) :: z(*) + integer(kind=c_int) :: error + end function c_ex_get_coord + end interface + + ! Get node number map + interface f_ex_get_node_num_map + function c_ex_get_node_num_map(exoid, node_map) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: node_map(*) + integer(kind=c_int) :: error + end function c_ex_get_node_num_map + end interface + + ! Get element number map + interface f_ex_get_elem_num_map + function c_ex_get_elem_num_map(exoid, elem_num_map) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: elem_num_map(*) + integer(kind=c_int) :: error + end function c_ex_get_elem_num_map + end interface + + ! Get element order map: + interface f_ex_get_elem_order_map + function c_ex_get_elem_order_map(exoid, elem_order_map) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: elem_order_map(*) + integer(kind=c_int) :: error + end function c_ex_get_elem_order_map + end interface + + ! Get block ids: + interface f_ex_get_elem_blk_ids + function c_ex_get_elem_blk_ids(exoid, block_ids) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: block_ids(*) + integer(kind=c_int) :: error + end function c_ex_get_elem_blk_ids + end interface + + interface f_ex_get_elem_block + function c_ex_get_elem_block(exoid, block_id, elem_type, & + num_elem_in_block, & + num_nodes_per_elem, & + num_attr) & + result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: block_id + character(kind=c_char, len=1):: elem_type + integer(kind=c_int) :: num_elem_in_block + integer(kind=c_int) :: num_nodes_per_elem + integer(kind=c_int) :: num_attr + integer(kind=c_int) :: error + end function c_ex_get_elem_block + end interface + + ! Get block parameters + interface f_ex_get_elem_block_parameters + function c_ex_get_elem_block_parameters(exoid, num_elem_blk, & + block_ids, num_elem_in_block, & + num_nodes_per_elem) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: num_elem_blk + integer(kind=c_int) :: block_ids(*) + integer(kind=c_int) :: num_elem_in_block(*) + integer(kind=c_int) :: num_nodes_per_elem(*) + integer(kind=c_int) :: error + end function c_ex_get_elem_block_parameters + end interface + + interface f_ex_get_elem_connectivity + function c_ex_get_elem_connectivity(exoid, block_id, elem_connectivity) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: block_id + integer(kind=c_int) :: elem_connectivity(*) + integer(kind=c_int) :: error + end function c_ex_get_elem_connectivity + end interface + + interface f_ex_get_node_set_param + function c_ex_get_node_set_param(exoid, num_node_sets, node_set_ids, num_nodes_in_set) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: num_node_sets + integer(kind=c_int) :: node_set_ids(*) + integer(kind=c_int) :: num_nodes_in_set(*) + integer(kind=c_int) :: error + end function c_ex_get_node_set_param + end interface + + interface f_ex_get_node_set_node_list + function c_ex_get_node_set_node_list(exoid, num_node_sets, node_set_id, node_set_node_list) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: num_node_sets + integer(kind=c_int) :: node_set_id + integer(kind=c_int) :: node_set_node_list(*) + integer(kind=c_int) :: error + end function c_ex_get_node_set_node_list + end interface + + interface f_ex_get_side_set_ids + function c_ex_get_side_set_ids(exoid, side_set_ids) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: side_set_ids(*) + integer(kind=c_int) :: error + end function c_ex_get_side_set_ids + end interface + + interface f_ex_get_side_set_param + function c_ex_get_side_set_param(exoid, side_set_id, num_sides_in_set, num_df_in_set) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: side_set_id + integer(kind=c_int) :: num_sides_in_set + integer(kind=c_int) :: num_df_in_set + integer(kind=c_int) :: error + end function c_ex_get_side_set_param + end interface + + interface f_ex_get_side_set + function c_ex_get_side_set(exoid, side_set_id, elem_list, side_list) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: side_set_id + integer(kind=c_int) :: elem_list(*) + integer(kind=c_int) :: side_list(*) + integer(kind=c_int) :: error + end function c_ex_get_side_set + end interface + + interface f_ex_get_side_set_node_list + function c_ex_get_side_set_node_list(exoid, side_set_id, side_set_node_cnt_list, side_set_node_list) result(error) bind(c) + use, intrinsic :: iso_c_binding + integer(kind=c_int) :: exoid + integer(kind=c_int) :: side_set_id + integer(kind=c_int) :: side_set_node_cnt_list(*) + integer(kind=c_int) :: side_set_node_list(*) + integer(kind=c_int) :: error + end function c_ex_get_side_set_node_list + end interface + + ! Closing exodusII file + interface f_ex_close + function c_ex_close(exoid) result(ierr) bind(c) + use, intrinsic :: iso_c_binding + !implicit none + integer(kind=c_int) :: exoid + integer(kind=c_int) :: ierr + end function c_ex_close + end interface end module exodusii_f_interface diff --git a/femtools/FEFields.F90 b/femtools/FEFields.F90 index b3640699e8..ab474a0708 100644 --- a/femtools/FEFields.F90 +++ b/femtools/FEFields.F90 @@ -1,1005 +1,1005 @@ #include "fdebug.h" module fefields - !!< Module containing general tools for discretising Finite Element problems. - - use fldebug - use data_structures - use mpi_interfaces - use element_numbering - use elements, only: element_type - use parallel_tools - use sparse_tools - use parallel_fields - use transform_elements, only: transform_to_physical, element_volume - use fetools, only: shape_shape, shape_rhs, shape_vector_rhs - use fields - use state_module - use field_options, only: get_coordinate_field - use halos - use sparse_matrices_fields - implicit none - - interface add_source_to_rhs - module procedure add_source_to_rhs_scalar, add_source_to_rhs_vector - end interface add_source_to_rhs - - interface project_field - module procedure project_scalar_field, project_vector_field - end interface - - private - public :: compute_lumped_mass, compute_mass, compute_projection_matrix, add_source_to_rhs, & - compute_lumped_mass_on_submesh, compute_cv_mass, project_field - public :: create_subdomain_mesh, create_parallel_redundant_mesh + !!< Module containing general tools for discretising Finite Element problems. + + use fldebug + use data_structures + use mpi_interfaces + use element_numbering + use elements, only: element_type + use parallel_tools + use sparse_tools + use parallel_fields + use transform_elements, only: transform_to_physical, element_volume + use fetools, only: shape_shape, shape_rhs, shape_vector_rhs + use fields + use state_module + use field_options, only: get_coordinate_field + use halos + use sparse_matrices_fields + implicit none + + interface add_source_to_rhs + module procedure add_source_to_rhs_scalar, add_source_to_rhs_vector + end interface add_source_to_rhs + + interface project_field + module procedure project_scalar_field, project_vector_field + end interface + + private + public :: compute_lumped_mass, compute_mass, compute_projection_matrix, add_source_to_rhs, & + compute_lumped_mass_on_submesh, compute_cv_mass, project_field + public :: create_subdomain_mesh, create_parallel_redundant_mesh contains - subroutine compute_cv_mass(positions, cv_mass) + subroutine compute_cv_mass(positions, cv_mass) - !!< Compute the cv mass matrix associated with the - !!< input scalar fields mesh. This will use pre tabulated - !!< coefficients to calculate each sub control volumes - !!< volume - which is only set up for constant, linear elements and - !!< selected quadratic elements. This assumes that all - !!< elements have the same vertices, degree and dim. Also - !!< the mesh element type must be Lagrangian. This WILL work - !!< for both continuous and discontinuous meshes. If the element - !!< order is zero then return the element volume. + !!< Compute the cv mass matrix associated with the + !!< input scalar fields mesh. This will use pre tabulated + !!< coefficients to calculate each sub control volumes + !!< volume - which is only set up for constant, linear elements and + !!< selected quadratic elements. This assumes that all + !!< elements have the same vertices, degree and dim. Also + !!< the mesh element type must be Lagrangian. This WILL work + !!< for both continuous and discontinuous meshes. If the element + !!< order is zero then return the element volume. - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: cv_mass + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: cv_mass - ! local variables - integer :: ele - integer :: vertices, polydegree, dim, type, family, loc - real, dimension(:), pointer :: subcv_ele_volf => null() + ! local variables + integer :: ele + integer :: vertices, polydegree, dim, type, family, loc + real, dimension(:), pointer :: subcv_ele_volf => null() - ewrite(1,*) 'In compute_cv_mass' + ewrite(1,*) 'In compute_cv_mass' - ! sanity check - assert(element_count(positions) == element_count(cv_mass)) + ! sanity check + assert(element_count(positions) == element_count(cv_mass)) - ! initialise - call zero(cv_mass) + ! initialise + call zero(cv_mass) - ! get element info (assume all the same for whole mesh) - vertices = ele_vertices(cv_mass,1) - polydegree = cv_mass%mesh%shape%degree - dim = cv_mass%mesh%shape%dim - type = cv_mass%mesh%shape%numbering%type - family = cv_mass%mesh%shape%numbering%family - loc = cv_mass%mesh%shape%loc + ! get element info (assume all the same for whole mesh) + vertices = ele_vertices(cv_mass,1) + polydegree = cv_mass%mesh%shape%degree + dim = cv_mass%mesh%shape%dim + type = cv_mass%mesh%shape%numbering%type + family = cv_mass%mesh%shape%numbering%family + loc = cv_mass%mesh%shape%loc - ! The element type must be Lagrangian - if (type /= ELEMENT_LAGRANGIAN) then - FLAbort('Can only find the CV mass if the element type is Lagrangian') - end if + ! The element type must be Lagrangian + if (type /= ELEMENT_LAGRANGIAN) then + FLAbort('Can only find the CV mass if the element type is Lagrangian') + end if - ! The polydegree must be < 3 - if (polydegree > 2) then - FLAbort('Can only find the CV mass if the element polynomial degree is 2 or less') - end if + ! The polydegree must be < 3 + if (polydegree > 2) then + FLAbort('Can only find the CV mass if the element polynomial degree is 2 or less') + end if - ! If the polydegree is 2 then the element family must be Simplex - if ((polydegree == 2) .and. (.not. family == FAMILY_SIMPLEX)) then - FLAbort('Can only find the CV mass for a mesh with a 2nd degree element if the element familiy is Simplex') - end if + ! If the polydegree is 2 then the element family must be Simplex + if ((polydegree == 2) .and. (.not. family == FAMILY_SIMPLEX)) then + FLAbort('Can only find the CV mass for a mesh with a 2nd degree element if the element familiy is Simplex') + end if - ! Find the sub CV element volume fractions + ! Find the sub CV element volume fractions - allocate(subcv_ele_volf(loc)) + allocate(subcv_ele_volf(loc)) - if (polydegree == 0) then + if (polydegree == 0) then - ! dummy value for element wise - subcv_ele_volf = 1.0 + ! dummy value for element wise + subcv_ele_volf = 1.0 - else if (polydegree == 1) then + else if (polydegree == 1) then - ! for linear poly the volume of each - ! subcontrol volume is ele_vol / loc + ! for linear poly the volume of each + ! subcontrol volume is ele_vol / loc - subcv_ele_volf = 1.0/real(loc) + subcv_ele_volf = 1.0/real(loc) - else if (polydegree == 2) then + else if (polydegree == 2) then - ! for quadratic poly we only consider Simplex family + ! for quadratic poly we only consider Simplex family - if (vertices == 2) then + if (vertices == 2) then - subcv_ele_volf(1) = 0.25 ! 1/2 * 1/2 = 1/4 Vertex CV - subcv_ele_volf(2) = 0.5 ! (1 - 2 * 1/4) / 1 Centre CV - subcv_ele_volf(3) = 0.25 ! 1/2 * 1/2 = 1/4 Vertex CV + subcv_ele_volf(1) = 0.25 ! 1/2 * 1/2 = 1/4 Vertex CV + subcv_ele_volf(2) = 0.5 ! (1 - 2 * 1/4) / 1 Centre CV + subcv_ele_volf(3) = 0.25 ! 1/2 * 1/2 = 1/4 Vertex CV - else if (vertices == 3) then + else if (vertices == 3) then - subcv_ele_volf(1) = 8.3333333333333333e-02 ! 1/3 * 1/4 = 1/12 Vertex CV - subcv_ele_volf(2) = 0.25 ! (1 - 3 * 1/12) / 3 Edge CV - subcv_ele_volf(3) = 8.3333333333333333e-02 ! 1/3 * 1/4 = 1/12 Vertex CV - subcv_ele_volf(4) = 0.25 ! (1 - 3 * 1/12) / 3 Edge CV - subcv_ele_volf(5) = 0.25 ! (1 - 3 * 1/12) / 3 Edge CV - subcv_ele_volf(6) = 8.3333333333333333e-02 ! 1/3 * 1/4 = 1/12 Vertex CV + subcv_ele_volf(1) = 8.3333333333333333e-02 ! 1/3 * 1/4 = 1/12 Vertex CV + subcv_ele_volf(2) = 0.25 ! (1 - 3 * 1/12) / 3 Edge CV + subcv_ele_volf(3) = 8.3333333333333333e-02 ! 1/3 * 1/4 = 1/12 Vertex CV + subcv_ele_volf(4) = 0.25 ! (1 - 3 * 1/12) / 3 Edge CV + subcv_ele_volf(5) = 0.25 ! (1 - 3 * 1/12) / 3 Edge CV + subcv_ele_volf(6) = 8.3333333333333333e-02 ! 1/3 * 1/4 = 1/12 Vertex CV - else if ((vertices == 4) .and. (dim == 3)) then + else if ((vertices == 4) .and. (dim == 3)) then - subcv_ele_volf(1) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV - subcv_ele_volf(2) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV - subcv_ele_volf(3) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV - subcv_ele_volf(4) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV - subcv_ele_volf(5) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV - subcv_ele_volf(6) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV - subcv_ele_volf(7) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV - subcv_ele_volf(8) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV - subcv_ele_volf(9) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV - subcv_ele_volf(10) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV + subcv_ele_volf(1) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV + subcv_ele_volf(2) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV + subcv_ele_volf(3) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV + subcv_ele_volf(4) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV + subcv_ele_volf(5) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV + subcv_ele_volf(6) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV + subcv_ele_volf(7) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV + subcv_ele_volf(8) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV + subcv_ele_volf(9) = 1.4583333333333333e-01 ! (1 - 4 * 1/32) / 6 Edge CV + subcv_ele_volf(10) = 0.03125 ! 1/8 * 1/4 = 1/32 Vertex CV - else + else - FLAbort('No code to form the sub control volume element volume fractions if not a Simplex') + FLAbort('No code to form the sub control volume element volume fractions if not a Simplex') - end if + end if - else + else - FLAbort('No code to form the sub control volume element volume fractions if poly degree is > 2') + FLAbort('No code to form the sub control volume element volume fractions if poly degree is > 2') - end if + end if - ! Form the CV mass matrix: - do ele = 1,element_count(cv_mass) + ! Form the CV mass matrix: + do ele = 1,element_count(cv_mass) - call addto(cv_mass, & + call addto(cv_mass, & ele_nodes(cv_mass, ele), & subcv_ele_volf * element_volume(positions, ele)) - end do - - deallocate(subcv_ele_volf) - - end subroutine compute_cv_mass - - subroutine compute_lumped_mass(positions, lumped_mass, density, vfrac) - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: lumped_mass - type(scalar_field), intent(inout), target, optional :: density - type(scalar_field), intent(inout), target, optional :: vfrac ! PhaseVolumeFraction field - - integer :: ele - real, dimension(ele_ngi(lumped_mass, 1)) :: detwei - type(element_type), pointer :: t_shape - real, dimension(ele_loc(lumped_mass, 1), ele_loc(lumped_mass, 1)) :: mass_matrix - type(scalar_field), pointer :: l_density, l_vfrac - - real, dimension(ele_ngi(lumped_mass, 1)) :: density_gi, vfrac_gi - - ewrite(1,*) 'In compute_lumped_mass' - - if(present(density)) then - l_density => density - else - allocate(l_density) - call allocate(l_density, lumped_mass%mesh, name="LocalDensity", field_type=FIELD_TYPE_CONSTANT) - call set(l_density, 1.0) - end if - - if(present(vfrac)) then - l_vfrac => vfrac - else - allocate(l_vfrac) - call allocate(l_vfrac, lumped_mass%mesh, name="LocalPhaseVolumeFraction", field_type=FIELD_TYPE_CONSTANT) - call set(l_vfrac, 1.0) - end if - - call zero(lumped_mass) - - do ele=1,ele_count(lumped_mass) - t_shape => ele_shape(lumped_mass, ele) - density_gi = ele_val_at_quad(l_density, ele) - vfrac_gi = ele_val_at_quad(l_vfrac, ele) - call transform_to_physical(positions, ele, detwei=detwei) - mass_matrix = shape_shape(t_shape, t_shape, detwei*density_gi*vfrac_gi) - call addto(lumped_mass, ele_nodes(lumped_mass, ele), sum(mass_matrix, 2)) - end do - - if(.not.present(density)) then - call deallocate(l_density) - deallocate(l_density) - end if - - if(.not.present(vfrac)) then - call deallocate(l_vfrac) - deallocate(l_vfrac) - end if - - end subroutine compute_lumped_mass - - subroutine compute_mass(positions, mesh, mass, lumped_mass, density) - type(vector_field), intent(in) :: positions - type(mesh_type), intent(in) :: mesh - type(csr_matrix), intent(inout) :: mass - type(scalar_field), intent(inout), optional :: lumped_mass - type(scalar_field), intent(inout), target, optional :: density - - integer :: ele - real, dimension(ele_ngi(mesh, 1)) :: detwei - type(element_type), pointer :: t_shape - real, dimension(ele_loc(mesh, 1), ele_loc(mesh, 1)) :: mass_matrix - type(scalar_field), pointer :: l_density - - real, dimension(ele_ngi(mesh, 1)) :: density_gi - - ewrite(1,*) 'In compute_mass' - - if(present(density)) then - l_density => density - else - allocate(l_density) - call allocate(l_density, mesh, name="LocalDensity", field_type=FIELD_TYPE_CONSTANT) - call set(l_density, 1.0) - end if - - call zero(mass) - if(present(lumped_mass)) then - assert(lumped_mass%mesh==mesh) + end do + + deallocate(subcv_ele_volf) + + end subroutine compute_cv_mass + + subroutine compute_lumped_mass(positions, lumped_mass, density, vfrac) + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: lumped_mass + type(scalar_field), intent(inout), target, optional :: density + type(scalar_field), intent(inout), target, optional :: vfrac ! PhaseVolumeFraction field + + integer :: ele + real, dimension(ele_ngi(lumped_mass, 1)) :: detwei + type(element_type), pointer :: t_shape + real, dimension(ele_loc(lumped_mass, 1), ele_loc(lumped_mass, 1)) :: mass_matrix + type(scalar_field), pointer :: l_density, l_vfrac + + real, dimension(ele_ngi(lumped_mass, 1)) :: density_gi, vfrac_gi + + ewrite(1,*) 'In compute_lumped_mass' + + if(present(density)) then + l_density => density + else + allocate(l_density) + call allocate(l_density, lumped_mass%mesh, name="LocalDensity", field_type=FIELD_TYPE_CONSTANT) + call set(l_density, 1.0) + end if + + if(present(vfrac)) then + l_vfrac => vfrac + else + allocate(l_vfrac) + call allocate(l_vfrac, lumped_mass%mesh, name="LocalPhaseVolumeFraction", field_type=FIELD_TYPE_CONSTANT) + call set(l_vfrac, 1.0) + end if + call zero(lumped_mass) - end if - - do ele=1,ele_count(mesh) - t_shape => ele_shape(mesh, ele) - density_gi = ele_val_at_quad(l_density, ele) - call transform_to_physical(positions, ele, detwei=detwei) - mass_matrix = shape_shape(t_shape, t_shape, detwei*density_gi) - call addto(mass, ele_nodes(mesh, ele), ele_nodes(mesh, ele), mass_matrix) + + do ele=1,ele_count(lumped_mass) + t_shape => ele_shape(lumped_mass, ele) + density_gi = ele_val_at_quad(l_density, ele) + vfrac_gi = ele_val_at_quad(l_vfrac, ele) + call transform_to_physical(positions, ele, detwei=detwei) + mass_matrix = shape_shape(t_shape, t_shape, detwei*density_gi*vfrac_gi) + call addto(lumped_mass, ele_nodes(lumped_mass, ele), sum(mass_matrix, 2)) + end do + + if(.not.present(density)) then + call deallocate(l_density) + deallocate(l_density) + end if + + if(.not.present(vfrac)) then + call deallocate(l_vfrac) + deallocate(l_vfrac) + end if + + end subroutine compute_lumped_mass + + subroutine compute_mass(positions, mesh, mass, lumped_mass, density) + type(vector_field), intent(in) :: positions + type(mesh_type), intent(in) :: mesh + type(csr_matrix), intent(inout) :: mass + type(scalar_field), intent(inout), optional :: lumped_mass + type(scalar_field), intent(inout), target, optional :: density + + integer :: ele + real, dimension(ele_ngi(mesh, 1)) :: detwei + type(element_type), pointer :: t_shape + real, dimension(ele_loc(mesh, 1), ele_loc(mesh, 1)) :: mass_matrix + type(scalar_field), pointer :: l_density + + real, dimension(ele_ngi(mesh, 1)) :: density_gi + + ewrite(1,*) 'In compute_mass' + + if(present(density)) then + l_density => density + else + allocate(l_density) + call allocate(l_density, mesh, name="LocalDensity", field_type=FIELD_TYPE_CONSTANT) + call set(l_density, 1.0) + end if + + call zero(mass) if(present(lumped_mass)) then - call addto(lumped_mass, ele_nodes(lumped_mass, ele), sum(mass_matrix, 2)) + assert(lumped_mass%mesh==mesh) + call zero(lumped_mass) end if - end do - - if(.not.present(density)) then - call deallocate(l_density) - deallocate(l_density) - end if - - end subroutine compute_mass - - subroutine compute_lumped_mass_on_submesh(state, lumped_mass, density, vfrac) - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: lumped_mass - type(scalar_field), intent(in), optional :: density - type(scalar_field), intent(in), optional :: vfrac - - type(mesh_type) :: submesh, unperiodic_submesh ! submesh - type(scalar_field) :: rho_pmesh, rho_submesh ! density on parent and submesh - type(vector_field) :: x_pmesh, x_submesh ! coordinates on parent and submesh - type(scalar_field) :: vfrac_pmesh, vfrac_submesh ! PhaseVolumeFraction on parent and submesh - type(scalar_field) :: masslump_submesh - - ewrite(1,*) 'In compute_lumped_mass_on_submesh' - - submesh = make_submesh(lumped_mass%mesh, name="SubMesh") - - x_pmesh=get_coordinate_field(state, lumped_mass%mesh) - - if (mesh_periodic(submesh)) then - ! you should never have periodic coordinates - ! remake the mesh using the shape and continuity - ! of the desired mesh (but not periodic) - unperiodic_submesh=make_submesh(x_pmesh%mesh, name="UnPeriodicSubMesh") - call allocate(x_submesh, mesh_dim(submesh), unperiodic_submesh, name="SubMeshCoordinate") - call deallocate(unperiodic_submesh) - else - call allocate(x_submesh, mesh_dim(submesh), submesh, name="SubMeshCoordinate") - end if - call set_to_submesh(x_pmesh, x_submesh) - - call deallocate(x_pmesh) - - if(present(density)) then - call allocate(rho_pmesh, lumped_mass%mesh, name="ParentMeshDensity") - call remap_field(density, rho_pmesh) - - call allocate(rho_submesh, submesh, name="SubMeshDensity") - call set_to_submesh(rho_pmesh, rho_submesh) - - call deallocate(rho_pmesh) - else - call allocate(rho_submesh, submesh, name="DummySubMeshDensity", field_type=FIELD_TYPE_CONSTANT) - call set(rho_submesh, 1.0) - end if - - ! This is only included in multiphase simulations - if(present(vfrac)) then - call allocate(vfrac_pmesh, lumped_mass%mesh, name="ParentMeshPhaseVolumeFraction") - call remap_field(vfrac, vfrac_pmesh) - - call allocate(vfrac_submesh, submesh, name="SubMeshPhaseVolumeFraction") - call set_to_submesh(vfrac_pmesh, vfrac_submesh) - - call deallocate(vfrac_pmesh) - else - call allocate(vfrac_submesh, submesh, name="DummySubMeshPhaseVolumeFraction", field_type=FIELD_TYPE_CONSTANT) - call set(vfrac_submesh, 1.0) - end if - - call allocate(masslump_submesh, submesh, "TemporarySubMeshLumpedMass") - - call compute_lumped_mass(x_submesh, masslump_submesh, rho_submesh, vfrac_submesh) - - call set_from_submesh(masslump_submesh, lumped_mass) - - call deallocate(submesh) - call deallocate(x_submesh) - call deallocate(rho_submesh) - call deallocate(vfrac_submesh) - call deallocate(masslump_submesh) - - end subroutine compute_lumped_mass_on_submesh - - function compute_projection_matrix(to_mesh, from_mesh, position) & - result (P) - !!< Calculate the projection matrix from from_mesh to to_mesh. - !!< from_mesh, to_mesh and positions must have the same topology but - !!< naturally may have different continuity or shape functions. - !!< - !!< The projection equation is: - !!< - !!< M T = P F - !!< - !!< Where T is the to field, F is the from field and M is the mass - !!< matrix on the same mesh as T. - !!< - !!< This function constructs the matrix P. - type (csr_matrix) :: P - type(mesh_type), intent(in) :: to_mesh, from_mesh - type(vector_field), intent(in) :: position - - ! We produce P using a dcsr matrix as this is easy to code. If it - ! becomes performance critical we could work with sparsities. - type(dynamic_csr_matrix) :: tmpP - - integer :: ele - - call allocate(tmpP, rows=node_count(to_mesh), & - columns=node_count(from_mesh), name="tmpP") - do ele=1, element_count(to_mesh) + do ele=1,ele_count(mesh) + t_shape => ele_shape(mesh, ele) + density_gi = ele_val_at_quad(l_density, ele) + call transform_to_physical(positions, ele, detwei=detwei) + mass_matrix = shape_shape(t_shape, t_shape, detwei*density_gi) + call addto(mass, ele_nodes(mesh, ele), ele_nodes(mesh, ele), mass_matrix) + if(present(lumped_mass)) then + call addto(lumped_mass, ele_nodes(lumped_mass, ele), sum(mass_matrix, 2)) + end if + end do - call projection_matrix_element(tmpP, ele, from_mesh, to_mesh,& - & position) + if(.not.present(density)) then + call deallocate(l_density) + deallocate(l_density) + end if - end do + end subroutine compute_mass - P=dcsr2csr(tmpP) - call deallocate(tmpP) + subroutine compute_lumped_mass_on_submesh(state, lumped_mass, density, vfrac) - contains + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: lumped_mass + type(scalar_field), intent(in), optional :: density + type(scalar_field), intent(in), optional :: vfrac - subroutine projection_matrix_element(tmpP, ele, from_mesh, to_mesh,& - & position) - !!< Calculate the contribution to tmpP from ele. - type(dynamic_csr_matrix), intent(inout) :: tmpP - integer, intent(in) :: ele - type(mesh_type), intent(in) :: from_mesh, to_mesh - type(vector_field), intent(in) :: position + type(mesh_type) :: submesh, unperiodic_submesh ! submesh + type(scalar_field) :: rho_pmesh, rho_submesh ! density on parent and submesh + type(vector_field) :: x_pmesh, x_submesh ! coordinates on parent and submesh + type(scalar_field) :: vfrac_pmesh, vfrac_submesh ! PhaseVolumeFraction on parent and submesh + type(scalar_field) :: masslump_submesh + + ewrite(1,*) 'In compute_lumped_mass_on_submesh' + + submesh = make_submesh(lumped_mass%mesh, name="SubMesh") - real, dimension(ele_ngi(to_mesh, ele)) :: detwei - type(element_type), pointer :: to_shape, from_shape - integer, dimension(:), pointer :: to_ele, from_ele + x_pmesh=get_coordinate_field(state, lumped_mass%mesh) - to_shape=>ele_shape(to_mesh, ele) - from_shape=>ele_shape(from_mesh, ele) - to_ele=>ele_nodes(to_mesh, ele) - from_ele=>ele_nodes(from_mesh, ele) + if (mesh_periodic(submesh)) then + ! you should never have periodic coordinates + ! remake the mesh using the shape and continuity + ! of the desired mesh (but not periodic) + unperiodic_submesh=make_submesh(x_pmesh%mesh, name="UnPeriodicSubMesh") + call allocate(x_submesh, mesh_dim(submesh), unperiodic_submesh, name="SubMeshCoordinate") + call deallocate(unperiodic_submesh) + else + call allocate(x_submesh, mesh_dim(submesh), submesh, name="SubMeshCoordinate") + end if + call set_to_submesh(x_pmesh, x_submesh) - ! Work out change of variables for quadrature. - call transform_to_physical(position, ele, detwei=detwei) + call deallocate(x_pmesh) - call addto(tmpP, to_ele, from_ele, & - & shape_shape(to_shape, from_shape, detwei)) + if(present(density)) then + call allocate(rho_pmesh, lumped_mass%mesh, name="ParentMeshDensity") + call remap_field(density, rho_pmesh) - end subroutine projection_matrix_element + call allocate(rho_submesh, submesh, name="SubMeshDensity") + call set_to_submesh(rho_pmesh, rho_submesh) - end function compute_projection_matrix + call deallocate(rho_pmesh) + else + call allocate(rho_submesh, submesh, name="DummySubMeshDensity", field_type=FIELD_TYPE_CONSTANT) + call set(rho_submesh, 1.0) + end if - subroutine project_scalar_field(from_field, to_field, X) - !!< Project from_field onto to_field. If to_field is discontinuous then - !!< this will be calculated using the full mass matrix locally. - !!< Otherwise, the mass will be lumped. - type(scalar_field), intent(in) :: from_field - type(scalar_field), intent(inout) :: to_field - type(vector_field), intent(in) :: X + ! This is only included in multiphase simulations + if(present(vfrac)) then + call allocate(vfrac_pmesh, lumped_mass%mesh, name="ParentMeshPhaseVolumeFraction") + call remap_field(vfrac, vfrac_pmesh) - type(scalar_field) :: masslump - integer :: ele - type(csr_matrix) :: P - type(mesh_type) :: dg_mesh, cg_mesh + call allocate(vfrac_submesh, submesh, name="SubMeshPhaseVolumeFraction") + call set_to_submesh(vfrac_pmesh, vfrac_submesh) + call deallocate(vfrac_pmesh) + else + call allocate(vfrac_submesh, submesh, name="DummySubMeshPhaseVolumeFraction", field_type=FIELD_TYPE_CONSTANT) + call set(vfrac_submesh, 1.0) + end if - if(from_field%mesh==to_field%mesh) then + call allocate(masslump_submesh, submesh, "TemporarySubMeshLumpedMass") + + call compute_lumped_mass(x_submesh, masslump_submesh, rho_submesh, vfrac_submesh) + + call set_from_submesh(masslump_submesh, lumped_mass) + + call deallocate(submesh) + call deallocate(x_submesh) + call deallocate(rho_submesh) + call deallocate(vfrac_submesh) + call deallocate(masslump_submesh) + + end subroutine compute_lumped_mass_on_submesh + + function compute_projection_matrix(to_mesh, from_mesh, position) & + result (P) + !!< Calculate the projection matrix from from_mesh to to_mesh. + !!< from_mesh, to_mesh and positions must have the same topology but + !!< naturally may have different continuity or shape functions. + !!< + !!< The projection equation is: + !!< + !!< M T = P F + !!< + !!< Where T is the to field, F is the from field and M is the mass + !!< matrix on the same mesh as T. + !!< + !!< This function constructs the matrix P. + type (csr_matrix) :: P + type(mesh_type), intent(in) :: to_mesh, from_mesh + type(vector_field), intent(in) :: position - call set(to_field, from_field) + ! We produce P using a dcsr matrix as this is easy to code. If it + ! becomes performance critical we could work with sparsities. + type(dynamic_csr_matrix) :: tmpP - else + integer :: ele - if (to_field%mesh%continuity<0) then - ! DG case + call allocate(tmpP, rows=node_count(to_mesh), & + columns=node_count(from_mesh), name="tmpP") - do ele=1,element_count(to_field) - call dg_projection_ele(ele, from_field, to_field, X) - end do + do ele=1, element_count(to_mesh) - else - ! DG to CG case + call projection_matrix_element(tmpP, ele, from_mesh, to_mesh,& + & position) - cg_mesh=to_field%mesh + end do - call allocate(masslump, cg_mesh, "LumpedMass") + P=dcsr2csr(tmpP) + call deallocate(tmpP) - call compute_lumped_mass(X, masslump) - ! Invert lumped mass. - masslump%val=1./masslump%val + contains - dg_mesh=from_field%mesh + subroutine projection_matrix_element(tmpP, ele, from_mesh, to_mesh,& + & position) + !!< Calculate the contribution to tmpP from ele. + type(dynamic_csr_matrix), intent(inout) :: tmpP + integer, intent(in) :: ele + type(mesh_type), intent(in) :: from_mesh, to_mesh + type(vector_field), intent(in) :: position - P=compute_projection_matrix(cg_mesh, dg_mesh , X) + real, dimension(ele_ngi(to_mesh, ele)) :: detwei + type(element_type), pointer :: to_shape, from_shape + integer, dimension(:), pointer :: to_ele, from_ele - call zero(to_field) - ! Perform projection. - call mult(to_field, P, from_field) - ! Apply inverted lumped mass to projected quantity. - call scale(to_field, masslump) + to_shape=>ele_shape(to_mesh, ele) + from_shape=>ele_shape(from_mesh, ele) + to_ele=>ele_nodes(to_mesh, ele) + from_ele=>ele_nodes(from_mesh, ele) - call deallocate(masslump) - call deallocate(P) + ! Work out change of variables for quadrature. + call transform_to_physical(position, ele, detwei=detwei) - end if + call addto(tmpP, to_ele, from_ele, & + & shape_shape(to_shape, from_shape, detwei)) - end if + end subroutine projection_matrix_element - contains + end function compute_projection_matrix - subroutine dg_projection_ele(ele, from_field, to_field, X) - integer :: ele + subroutine project_scalar_field(from_field, to_field, X) + !!< Project from_field onto to_field. If to_field is discontinuous then + !!< this will be calculated using the full mass matrix locally. + !!< Otherwise, the mass will be lumped. type(scalar_field), intent(in) :: from_field type(scalar_field), intent(inout) :: to_field type(vector_field), intent(in) :: X - real, dimension(ele_loc(to_field,ele), ele_loc(to_field,ele)) :: mass - real, dimension(ele_ngi(to_field,ele)) :: detwei - type(element_type), pointer :: to_shape - - call transform_to_physical(X, ele, detwei) + type(scalar_field) :: masslump + integer :: ele + type(csr_matrix) :: P + type(mesh_type) :: dg_mesh, cg_mesh - to_shape=>ele_shape(to_field, ele) - mass=shape_shape(to_shape, to_shape, detwei) + if(from_field%mesh==to_field%mesh) then - call invert(mass) + call set(to_field, from_field) - call set(to_field, ele_nodes(to_field, ele), & - matmul(mass, & - shape_rhs(to_shape, ele_val_at_quad(from_field, ele)*detwei))) + else - end subroutine dg_projection_ele + if (to_field%mesh%continuity<0) then + ! DG case - end subroutine project_scalar_field + do ele=1,element_count(to_field) + call dg_projection_ele(ele, from_field, to_field, X) + end do - subroutine project_vector_field(from_field, to_field, X) - !!< Project from_field onto to_field. If to_field is discontinuous then - !!< this will be calculated using the full mass matrix locally. - !!< Otherwise, the mass will be lumped. - type(vector_field), intent(in) :: from_field - type(vector_field), intent(inout) :: to_field - type(vector_field), intent(in) :: X + else + ! DG to CG case - type(scalar_field) :: masslump, dg_scalar, cg_scalar - integer :: ele - type(csr_matrix) :: P - type(mesh_type) :: dg_mesh, cg_mesh - integer :: j + cg_mesh=to_field%mesh + call allocate(masslump, cg_mesh, "LumpedMass") - if(from_field%mesh==to_field%mesh) then + call compute_lumped_mass(X, masslump) + ! Invert lumped mass. + masslump%val=1./masslump%val - call set(to_field, from_field) + dg_mesh=from_field%mesh - else + P=compute_projection_matrix(cg_mesh, dg_mesh , X) - if (to_field%mesh%continuity<0) then - ! DG case + call zero(to_field) + ! Perform projection. + call mult(to_field, P, from_field) + ! Apply inverted lumped mass to projected quantity. + call scale(to_field, masslump) - do ele=1,element_count(to_field) - call dg_projection_ele(ele, from_field, to_field, X) - end do + call deallocate(masslump) + call deallocate(P) - else - ! CG case + end if - cg_mesh=to_field%mesh + end if - call allocate(masslump, cg_mesh, "LumpedMass") + contains - call compute_lumped_mass(X, masslump) - ! Invert lumped mass. - masslump%val=1./masslump%val + subroutine dg_projection_ele(ele, from_field, to_field, X) + integer :: ele + type(scalar_field), intent(in) :: from_field + type(scalar_field), intent(inout) :: to_field + type(vector_field), intent(in) :: X - dg_mesh=from_field%mesh + real, dimension(ele_loc(to_field,ele), ele_loc(to_field,ele)) :: mass + real, dimension(ele_ngi(to_field,ele)) :: detwei + type(element_type), pointer :: to_shape - P=compute_projection_matrix(cg_mesh, dg_mesh, X) + call transform_to_physical(X, ele, detwei) - call zero(to_field) - ! Perform projection. - do j=1,to_field%dim - cg_scalar=extract_scalar_field_from_vector_field(to_field, j) - dg_scalar=extract_scalar_field_from_vector_field(from_field, j) - call mult(cg_scalar, P, dg_scalar) - call set(to_field, j, cg_scalar) - end do + to_shape=>ele_shape(to_field, ele) - ! Apply inverted lumped mass to projected quantity. - call scale(to_field, masslump) + mass=shape_shape(to_shape, to_shape, detwei) - call deallocate(masslump) - call deallocate(P) + call invert(mass) - end if + call set(to_field, ele_nodes(to_field, ele), & + matmul(mass, & + shape_rhs(to_shape, ele_val_at_quad(from_field, ele)*detwei))) - end if + end subroutine dg_projection_ele - contains + end subroutine project_scalar_field - subroutine dg_projection_ele(ele, from_field, to_field, X) - integer :: ele + subroutine project_vector_field(from_field, to_field, X) + !!< Project from_field onto to_field. If to_field is discontinuous then + !!< this will be calculated using the full mass matrix locally. + !!< Otherwise, the mass will be lumped. type(vector_field), intent(in) :: from_field type(vector_field), intent(inout) :: to_field type(vector_field), intent(in) :: X - real, dimension(ele_loc(to_field,ele), ele_loc(to_field,ele)) :: mass - real, dimension(ele_ngi(to_field,ele)) :: detwei - type(element_type), pointer :: to_shape + type(scalar_field) :: masslump, dg_scalar, cg_scalar + integer :: ele + type(csr_matrix) :: P + type(mesh_type) :: dg_mesh, cg_mesh + integer :: j + + + if(from_field%mesh==to_field%mesh) then + + call set(to_field, from_field) + + else + + if (to_field%mesh%continuity<0) then + ! DG case + + do ele=1,element_count(to_field) + call dg_projection_ele(ele, from_field, to_field, X) + end do + + else + ! CG case + + cg_mesh=to_field%mesh + + call allocate(masslump, cg_mesh, "LumpedMass") + + call compute_lumped_mass(X, masslump) + ! Invert lumped mass. + masslump%val=1./masslump%val + + dg_mesh=from_field%mesh + + P=compute_projection_matrix(cg_mesh, dg_mesh, X) + + call zero(to_field) + ! Perform projection. + do j=1,to_field%dim + cg_scalar=extract_scalar_field_from_vector_field(to_field, j) + dg_scalar=extract_scalar_field_from_vector_field(from_field, j) + call mult(cg_scalar, P, dg_scalar) + call set(to_field, j, cg_scalar) + end do + + ! Apply inverted lumped mass to projected quantity. + call scale(to_field, masslump) + + call deallocate(masslump) + call deallocate(P) + + end if + + end if - integer :: dim + contains - call transform_to_physical(X, ele, detwei) + subroutine dg_projection_ele(ele, from_field, to_field, X) + integer :: ele + type(vector_field), intent(in) :: from_field + type(vector_field), intent(inout) :: to_field + type(vector_field), intent(in) :: X - to_shape=>ele_shape(to_field, ele) + real, dimension(ele_loc(to_field,ele), ele_loc(to_field,ele)) :: mass + real, dimension(ele_ngi(to_field,ele)) :: detwei + type(element_type), pointer :: to_shape - mass=shape_shape(to_shape, to_shape, detwei) + integer :: dim - call invert(mass) + call transform_to_physical(X, ele, detwei) - do dim=1,to_field%dim - call set(to_field, dim, ele_nodes(to_field, ele), & - matmul(mass, & - shape_rhs(to_shape, ele_val_at_quad(from_field, dim, ele)*detwei))) + to_shape=>ele_shape(to_field, ele) + + mass=shape_shape(to_shape, to_shape, detwei) + + call invert(mass) + + do dim=1,to_field%dim + call set(to_field, dim, ele_nodes(to_field, ele), & + matmul(mass, & + shape_rhs(to_shape, ele_val_at_quad(from_field, dim, ele)*detwei))) + end do + + end subroutine dg_projection_ele + + subroutine cg_projection_ele(ele, from_field, to_field, masslump, X) + integer :: ele + type(vector_field), intent(in) :: from_field + type(vector_field), intent(inout) :: to_field + type(scalar_field), intent(inout) :: masslump + type(vector_field), intent(in) :: X + + real, dimension(ele_ngi(to_field,ele)) :: detwei + type(element_type), pointer :: to_shape + + to_shape=>ele_shape(to_field, ele) + + call transform_to_physical(X, ele, detwei) + + call addto(masslump, ele_nodes(to_field, ele), & + shape_rhs(to_shape, detwei)) + + call addto(to_field, ele_nodes(to_field, ele), & + shape_vector_rhs(to_shape, ele_val_at_quad(from_field, ele), detwei)) + + end subroutine cg_projection_ele + + end subroutine project_vector_field + + subroutine add_source_to_rhs_scalar(rhs, source, positions) + !!< Add in a source field to the rhs of a FE equation, + !!< i.e. compute the integrals: + !!< + !!< rhs_i=\int N_i source dV + !!< + !!< with source=\sum_j source_j M_j, this means we multiply + !!< source with the mass matrix \int N_i M_j dV + type(scalar_field), intent(inout):: rhs + type(scalar_field), intent(in):: source + !!< needed for integration: + type(vector_field), intent(in):: positions + + real, dimension( ele_loc(rhs,1), ele_loc(source,1) ):: M + real, dimension( ele_ngi(positions,1) ):: detwei + integer, dimension(:), pointer:: nodes + integer ele + + do ele=1, element_count(source) + call transform_to_physical(positions, ele, detwei) + M=shape_shape(ele_shape(rhs,ele), ele_shape(source, ele), detwei) + nodes => ele_nodes(rhs, ele) + call addto(rhs, nodes, matmul(M, ele_val(source, ele))) end do - end subroutine dg_projection_ele + end subroutine add_source_to_rhs_scalar + + subroutine add_source_to_rhs_vector(rhs, source, positions) + !!< Add in a source field to the rhs of a FE equation, i.e. compute the integrals: + !!< + !!< rhs_i=\int N_i source dV + !!< + !!< + !!< with source=\sum_j source_j M_j, this means we multiply + !!< source with the mass matrix \int N_i M_j dV + !!< This is the vector version, a direct copy of the scalar case + type(vector_field), intent(inout):: rhs + type(vector_field), intent(in):: source + !!< needed for integration: + type(vector_field), intent(in):: positions + + real, dimension( ele_loc(source,1), ele_loc(rhs,1) ):: M_transpose + real, dimension( ele_ngi(positions,1) ):: detwei + integer, dimension(:), pointer:: nodes + integer ele + + do ele=1, element_count(source) + call transform_to_physical(positions, ele, detwei) + ! M_transpose_ji=\int M_j N_i ( source=\sum_j s_j N_j, testing with N_i ) + ! note this is the transpose of what we usually compute + M_transpose=shape_shape(ele_shape(source, ele), ele_shape(rhs,ele), detwei) + nodes => ele_nodes(rhs, ele) + call addto(rhs, nodes, matmul(ele_val(source, ele), M_transpose)) + end do - subroutine cg_projection_ele(ele, from_field, to_field, masslump, X) - integer :: ele - type(vector_field), intent(in) :: from_field - type(vector_field), intent(inout) :: to_field - type(scalar_field), intent(inout) :: masslump - type(vector_field), intent(in) :: X + end subroutine add_source_to_rhs_vector + + subroutine create_subdomain_mesh(mesh, element_list, name, submesh, node_list) + !!< Create a mesh that only covers part of the domain + + ! full mesh to take submesh from + type(mesh_type), intent(in), target :: mesh + ! elements that will make up the submesh + integer, dimension(:), intent(in):: element_list + ! name for the new submesh + character(len=*), intent(in) :: name + ! submesh created + type(mesh_type), intent(out) :: submesh + ! list of nodes in submesh (also functions as node map from submesh to full mesh) + integer, dimension(:), pointer :: node_list + + ! integer set containing nodes in submesh: + type(integer_set) :: submesh_node_set + ! node mapping functions from full to submesh (=0 if not in submesh) + integer, dimension(:), allocatable :: inverse_node_list + + ! Others: + integer :: ele, ele_2, ni, edge_count, i, node, loc, sloc, face, surf_ele_count + integer, dimension(:), pointer :: neigh, faces + + type(element_type), pointer :: shape + + type(integer_hash_table) :: face_ele_list + + integer, allocatable, dimension(:) :: sndglno, boundary_ids, element_owner + + ewrite(1,*) "Entering create_subdomain_mesh" + + ! Build element mapping functions to and from sub mesh: + + ewrite(1,*) 'Number of elements in submesh:', size(element_list) + + ! Derive node list for subdomain_mesh: + call allocate(submesh_node_set) + do i = 1, size(element_list) + ele = element_list(i) + call insert(submesh_node_set, ele_nodes(mesh, ele)) + end do + + allocate(node_list(key_count(submesh_node_set))) ! Nodal map from sub mesh --> full mesh + node_list = set2vector(submesh_node_set) + ewrite(1,*) 'Number of nodes in submesh:', size(node_list) + + allocate(inverse_node_list(node_count(mesh))) ! Nodal map from full mesh --> sub mesh + ! if after it is set up, the value in inverse_subnode_list = 0, this means that that element of + ! the full mesh does not have a corresponding element on the subdomain_mesh - i.e. it is not a part + ! of the prognostic subdomain. + inverse_node_list = 0 + do i = 1, key_count(submesh_node_set) + node = node_list(i) + inverse_node_list(node) = i + end do + + ! Allocate subdomain_mesh: + shape => mesh%shape + call allocate(submesh, nodes=size(node_list), elements=size(element_list),& + & shape=shape, name=trim(name)) + submesh%option_path = mesh%option_path + if (associated(mesh%region_ids)) then + allocate(submesh%region_ids(size(element_list))) + submesh%region_ids = mesh%region_ids(element_list) + end if + + ! Determine ndglno (connectivity matrix) on subdomain_mesh: + loc = shape%loc + do i = 1, size(element_list) + ele = element_list(i) + ! can't use set_ele_nodes as it would create circularity between fields_allocates and fields_manipulation modules + submesh%ndglno(loc*(i-1)+1:loc*i) = inverse_node_list(ele_nodes(mesh, ele)) + end do + + ! Calculate sndglno - an array of nodes corresponding to edges along surface: + sloc = mesh%faces%shape%loc + surf_ele_count = surface_element_count(mesh) + + ! Begin by determining which faces are on submesh boundaries: + call allocate(face_ele_list) + do i = 1, size(element_list) + ele = element_list(i) + neigh => ele_neigh(mesh, ele) ! Determine element neighbours on parent mesh + faces => ele_faces(mesh, ele) ! Determine element faces on parent mesh + do ni = 1, size(neigh) + ele_2 = neigh(ni) + face = faces(ni) + ! If this face is part of the full surface mesh (which includes internal faces) then + ! it must be on the submesh boundary, and not on a processor boundary (if parallel). + ! note that for internal facets that are on now on the boundary of the subdomain, we only + ! collect one copy, whereas for internal facets that remain internal we collect both + ! this is dealt with using the allow_duplicate_internal_facets flag to add_faces() + if (face <= surf_ele_count) then + call insert(face_ele_list, face, ele) + end if + end do + end do - real, dimension(ele_ngi(to_field,ele)) :: detwei - type(element_type), pointer :: to_shape - - to_shape=>ele_shape(to_field, ele) - - call transform_to_physical(X, ele, detwei) - - call addto(masslump, ele_nodes(to_field, ele), & - shape_rhs(to_shape, detwei)) - - call addto(to_field, ele_nodes(to_field, ele), & - shape_vector_rhs(to_shape, ele_val_at_quad(from_field, ele), detwei)) - - end subroutine cg_projection_ele - - end subroutine project_vector_field - - subroutine add_source_to_rhs_scalar(rhs, source, positions) - !!< Add in a source field to the rhs of a FE equation, - !!< i.e. compute the integrals: - !!< - !!< rhs_i=\int N_i source dV - !!< - !!< with source=\sum_j source_j M_j, this means we multiply - !!< source with the mass matrix \int N_i M_j dV - type(scalar_field), intent(inout):: rhs - type(scalar_field), intent(in):: source - !!< needed for integration: - type(vector_field), intent(in):: positions - - real, dimension( ele_loc(rhs,1), ele_loc(source,1) ):: M - real, dimension( ele_ngi(positions,1) ):: detwei - integer, dimension(:), pointer:: nodes - integer ele - - do ele=1, element_count(source) - call transform_to_physical(positions, ele, detwei) - M=shape_shape(ele_shape(rhs,ele), ele_shape(source, ele), detwei) - nodes => ele_nodes(rhs, ele) - call addto(rhs, nodes, matmul(M, ele_val(source, ele))) - end do - - end subroutine add_source_to_rhs_scalar - - subroutine add_source_to_rhs_vector(rhs, source, positions) - !!< Add in a source field to the rhs of a FE equation, i.e. compute the integrals: - !!< - !!< rhs_i=\int N_i source dV - !!< - !!< - !!< with source=\sum_j source_j M_j, this means we multiply - !!< source with the mass matrix \int N_i M_j dV - !!< This is the vector version, a direct copy of the scalar case - type(vector_field), intent(inout):: rhs - type(vector_field), intent(in):: source - !!< needed for integration: - type(vector_field), intent(in):: positions - - real, dimension( ele_loc(source,1), ele_loc(rhs,1) ):: M_transpose - real, dimension( ele_ngi(positions,1) ):: detwei - integer, dimension(:), pointer:: nodes - integer ele - - do ele=1, element_count(source) - call transform_to_physical(positions, ele, detwei) - ! M_transpose_ji=\int M_j N_i ( source=\sum_j s_j N_j, testing with N_i ) - ! note this is the transpose of what we usually compute - M_transpose=shape_shape(ele_shape(source, ele), ele_shape(rhs,ele), detwei) - nodes => ele_nodes(rhs, ele) - call addto(rhs, nodes, matmul(ele_val(source, ele), M_transpose)) - end do - - end subroutine add_source_to_rhs_vector - - subroutine create_subdomain_mesh(mesh, element_list, name, submesh, node_list) - !!< Create a mesh that only covers part of the domain - - ! full mesh to take submesh from - type(mesh_type), intent(in), target :: mesh - ! elements that will make up the submesh - integer, dimension(:), intent(in):: element_list - ! name for the new submesh - character(len=*), intent(in) :: name - ! submesh created - type(mesh_type), intent(out) :: submesh - ! list of nodes in submesh (also functions as node map from submesh to full mesh) - integer, dimension(:), pointer :: node_list - - ! integer set containing nodes in submesh: - type(integer_set) :: submesh_node_set - ! node mapping functions from full to submesh (=0 if not in submesh) - integer, dimension(:), allocatable :: inverse_node_list - - ! Others: - integer :: ele, ele_2, ni, edge_count, i, node, loc, sloc, face, surf_ele_count - integer, dimension(:), pointer :: neigh, faces - - type(element_type), pointer :: shape - - type(integer_hash_table) :: face_ele_list - - integer, allocatable, dimension(:) :: sndglno, boundary_ids, element_owner - - ewrite(1,*) "Entering create_subdomain_mesh" - - ! Build element mapping functions to and from sub mesh: - - ewrite(1,*) 'Number of elements in submesh:', size(element_list) - - ! Derive node list for subdomain_mesh: - call allocate(submesh_node_set) - do i = 1, size(element_list) - ele = element_list(i) - call insert(submesh_node_set, ele_nodes(mesh, ele)) - end do - - allocate(node_list(key_count(submesh_node_set))) ! Nodal map from sub mesh --> full mesh - node_list = set2vector(submesh_node_set) - ewrite(1,*) 'Number of nodes in submesh:', size(node_list) - - allocate(inverse_node_list(node_count(mesh))) ! Nodal map from full mesh --> sub mesh - ! if after it is set up, the value in inverse_subnode_list = 0, this means that that element of - ! the full mesh does not have a corresponding element on the subdomain_mesh - i.e. it is not a part - ! of the prognostic subdomain. - inverse_node_list = 0 - do i = 1, key_count(submesh_node_set) - node = node_list(i) - inverse_node_list(node) = i - end do - - ! Allocate subdomain_mesh: - shape => mesh%shape - call allocate(submesh, nodes=size(node_list), elements=size(element_list),& - & shape=shape, name=trim(name)) - submesh%option_path = mesh%option_path - if (associated(mesh%region_ids)) then - allocate(submesh%region_ids(size(element_list))) - submesh%region_ids = mesh%region_ids(element_list) - end if - - ! Determine ndglno (connectivity matrix) on subdomain_mesh: - loc = shape%loc - do i = 1, size(element_list) - ele = element_list(i) - ! can't use set_ele_nodes as it would create circularity between fields_allocates and fields_manipulation modules - submesh%ndglno(loc*(i-1)+1:loc*i) = inverse_node_list(ele_nodes(mesh, ele)) - end do - - ! Calculate sndglno - an array of nodes corresponding to edges along surface: - sloc = mesh%faces%shape%loc - surf_ele_count = surface_element_count(mesh) - - ! Begin by determining which faces are on submesh boundaries: - call allocate(face_ele_list) - do i = 1, size(element_list) - ele = element_list(i) - neigh => ele_neigh(mesh, ele) ! Determine element neighbours on parent mesh - faces => ele_faces(mesh, ele) ! Determine element faces on parent mesh - do ni = 1, size(neigh) - ele_2 = neigh(ni) - face = faces(ni) - ! If this face is part of the full surface mesh (which includes internal faces) then - ! it must be on the submesh boundary, and not on a processor boundary (if parallel). - ! note that for internal facets that are on now on the boundary of the subdomain, we only - ! collect one copy, whereas for internal facets that remain internal we collect both - ! this is dealt with using the allow_duplicate_internal_facets flag to add_faces() - if (face <= surf_ele_count) then - call insert(face_ele_list, face, ele) - end if + ! Set up sndglno and boundary_ids: + edge_count = key_count(face_ele_list) + allocate(sndglno(edge_count*sloc), boundary_ids(1:edge_count)) + do i = 1, edge_count + call fetch_pair(face_ele_list, i, face, ele) + sndglno((i-1)*sloc+1:i*sloc) = inverse_node_list(face_global_nodes(mesh, face)) + boundary_ids(i) = surface_element_id(mesh, face) end do - end do - - ! Set up sndglno and boundary_ids: - edge_count = key_count(face_ele_list) - allocate(sndglno(edge_count*sloc), boundary_ids(1:edge_count)) - do i = 1, edge_count - call fetch_pair(face_ele_list, i, face, ele) - sndglno((i-1)*sloc+1:i*sloc) = inverse_node_list(face_global_nodes(mesh, face)) - boundary_ids(i) = surface_element_id(mesh, face) - end do - - ewrite(2,*) "Number of surface elements: ", edge_count - ! Add faces to submesh: - if (has_discontinuous_internal_boundaries(mesh)) then - allocate(element_owner(1:edge_count)) - do i=1, edge_count - call fetch_pair(face_ele_list, i, face, ele) - element_owner(i) = ele + + ewrite(2,*) "Number of surface elements: ", edge_count + ! Add faces to submesh: + if (has_discontinuous_internal_boundaries(mesh)) then + allocate(element_owner(1:edge_count)) + do i=1, edge_count + call fetch_pair(face_ele_list, i, face, ele) + element_owner(i) = ele + end do + call add_faces(submesh, sndgln=sndglno, boundary_ids=boundary_ids, & + element_owner=element_owner) + deallocate(element_owner) + else + call add_faces(submesh, sndgln=sndglno, boundary_ids=boundary_ids, & + allow_duplicate_internal_facets=.true.) + end if + + call deallocate(face_ele_list) + deallocate(sndglno) + deallocate(boundary_ids) + + ! If parallel then set up node and element halos, by checking whether mesh halos + ! exist on submesh: + + if(isparallel()) then + call generate_subdomain_halos(mesh, submesh, node_list, inverse_node_list) + end if + + deallocate(inverse_node_list) + call deallocate(submesh_node_set) + + ewrite(1,*) "Leaving create_subdomain_mesh" + + end subroutine create_subdomain_mesh + + subroutine generate_subdomain_halos(external_mesh,subdomain_mesh,node_list,inverse_node_list) + + type(mesh_type), intent(in) :: external_mesh + type(mesh_type), intent(inout) :: subdomain_mesh + integer, dimension(:) :: node_list, inverse_node_list + + integer :: nhalos, communicator, nprocs, procno, ihalo, nowned_nodes + + ewrite(1, *) "In generate_subdomain_halos" + + assert(continuity(subdomain_mesh) == 0) + assert(.not. associated(subdomain_mesh%halos)) + assert(.not. associated(subdomain_mesh%element_halos)) + + ! Initialise key MPI information: + + nhalos = halo_count(external_mesh) + ewrite(2,*) "Number of subdomain_mesh halos = ",nhalos + + if(nhalos == 0) return + + communicator = halo_communicator(external_mesh%halos(nhalos)) + nprocs = getnprocs(communicator = communicator) + ewrite(2,*) 'Number of processes = ', nprocs + procno = getprocno(communicator = communicator) + ewrite(2,*) 'Processor ID/number = ', procno + + ! Allocate subdomain mesh halos: + allocate(subdomain_mesh%halos(nhalos)) + + ! Derive subdomain_mesh halos: + do ihalo = 1, nhalos + + subdomain_mesh%halos(ihalo) = derive_sub_halo(external_mesh%halos(ihalo),node_list) + + assert(trailing_receives_consistent(subdomain_mesh%halos(ihalo))) + + if(.not. serial_storage_halo(external_mesh%halos(ihalo))) then + assert(halo_valid_for_communication(subdomain_mesh%halos(ihalo))) + call create_global_to_universal_numbering(subdomain_mesh%halos(ihalo)) + call create_ownership(subdomain_mesh%halos(ihalo)) + end if + + end do ! ihalo + + if(all(serial_storage_halo(subdomain_mesh%halos))) then + allocate(subdomain_mesh%element_halos(0)) + else + allocate(subdomain_mesh%element_halos(nhalos)) + call derive_element_halo_from_node_halo(subdomain_mesh, & + & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) + end if + + end subroutine generate_subdomain_halos + + function create_parallel_redundant_mesh(mesh) result (redundant_mesh) + !!< Creates a global mesh that is redundant, i.e. each process sees the entire + !!< mesh, constructed by gathering all local input meshes together. The global mesh + !!< is equiped with a halo structure in which each process owns the nodes associated + !!< with their input mesh. Since each input mesh is sent to each other process, to form + !!< part of their copy of the entire global mesh, on a halo update a process will send + !!< values for its owned nodes to all other processes. + !!< Although the global redundant mesh is the same on all processes, the node and element numbering + !!< is not. The first nodes and elements of the redundant mesh correspond to the node and element numbers + !!< of the input mesh (so we have trailing receives). The input mesh is treated as a completely local + !!< mesh, i.e. any global/halo structure it has is ignored, and each node and element is treated as unique + !!< and not associated with any nodes/elements of input meshes on other processes. + !!< The output redundant mesh only caries a single, nodal halo, in which all nodes associated with the input mesh + !!< are owned (send) nodes, and all other nodes are receives. In this way a simple halo_update(field) suffices + !!< to share all field values with all processes, where field is defined on the redundant_mesh. The send values of + !!< field can first be set by copying over the values from another field defined on the local input mesh (using + !!< the shared node numbering), or through a remap (using the shared element numbering). + !!< It should be clear that setting up this redundant mesh structure, and communicating through halo updates on it + !!< can be extremely expensive and will not in general scale very well - for small meshes such as a surface mesh + !!< this might still be feasible. + + !! Local input mesh. Treated as independent on each process, ignoring any halos + type(mesh_type), intent(inout):: mesh + !! Output global redudant mesh + type(mesh_type):: redundant_mesh + + type(halo_type), pointer :: halo + integer, dimension(:), allocatable :: eles_per_proc, eles_displs + integer, dimension(:), allocatable :: nodes_per_proc, nsends + integer, dimension(:), allocatable :: nodes_to_send, nodes_to_recv + integer, dimension(:, :), allocatable :: eles_send_buf, eles_recv_buf + integer neles, nloc, nprocs, procno + integer comm, ierr + integer i, j, node_offset, ele_offset, send_count + + ewrite(1,*) "Entering create_parallel_redundant_mesh for input mesh ", trim(mesh%name) + + neles = element_count(mesh) + nloc = ele_loc(mesh, 1) + nprocs = getnprocs() + procno = getprocno() + comm = MPI_COMM_FEMTOOLS + + ! exchange element numbers with all other processes + allocate(eles_per_proc(nprocs)) + call mpi_allgather(neles, 1, MPI_INTEGER, & + eles_per_proc, 1, MPI_INTEGER, comm, ierr) + assert(ierr == MPI_SUCCESS) + + ! our local mesh to be sent to everyone + allocate(eles_send_buf(nloc, neles)) + do i=1, neles + eles_send_buf(:,i) = ele_nodes(mesh, i) + end do + + allocate(eles_recv_buf(nloc, sum(eles_per_proc)), eles_displs(nprocs+1)) + ! displacements where in eles_recv_buf to put each bit of the recv'd surface mesh + ! (indexed from 0 - would be nice if they'd actually tell you these things in the mpi docs!) + j = 0 + do i=1, nprocs + eles_displs(i) = j + j = j + eles_per_proc(i)*nloc end do - call add_faces(submesh, sndgln=sndglno, boundary_ids=boundary_ids, & - element_owner=element_owner) - deallocate(element_owner) - else - call add_faces(submesh, sndgln=sndglno, boundary_ids=boundary_ids, & - allow_duplicate_internal_facets=.true.) - end if - - call deallocate(face_ele_list) - deallocate(sndglno) - deallocate(boundary_ids) - - ! If parallel then set up node and element halos, by checking whether mesh halos - ! exist on submesh: - - if(isparallel()) then - call generate_subdomain_halos(mesh, submesh, node_list, inverse_node_list) - end if - - deallocate(inverse_node_list) - call deallocate(submesh_node_set) - - ewrite(1,*) "Leaving create_subdomain_mesh" - - end subroutine create_subdomain_mesh - - subroutine generate_subdomain_halos(external_mesh,subdomain_mesh,node_list,inverse_node_list) - - type(mesh_type), intent(in) :: external_mesh - type(mesh_type), intent(inout) :: subdomain_mesh - integer, dimension(:) :: node_list, inverse_node_list - - integer :: nhalos, communicator, nprocs, procno, ihalo, nowned_nodes - - ewrite(1, *) "In generate_subdomain_halos" - - assert(continuity(subdomain_mesh) == 0) - assert(.not. associated(subdomain_mesh%halos)) - assert(.not. associated(subdomain_mesh%element_halos)) - - ! Initialise key MPI information: - - nhalos = halo_count(external_mesh) - ewrite(2,*) "Number of subdomain_mesh halos = ",nhalos - - if(nhalos == 0) return - - communicator = halo_communicator(external_mesh%halos(nhalos)) - nprocs = getnprocs(communicator = communicator) - ewrite(2,*) 'Number of processes = ', nprocs - procno = getprocno(communicator = communicator) - ewrite(2,*) 'Processor ID/number = ', procno - - ! Allocate subdomain mesh halos: - allocate(subdomain_mesh%halos(nhalos)) - - ! Derive subdomain_mesh halos: - do ihalo = 1, nhalos - - subdomain_mesh%halos(ihalo) = derive_sub_halo(external_mesh%halos(ihalo),node_list) - - assert(trailing_receives_consistent(subdomain_mesh%halos(ihalo))) - - if(.not. serial_storage_halo(external_mesh%halos(ihalo))) then - assert(halo_valid_for_communication(subdomain_mesh%halos(ihalo))) - call create_global_to_universal_numbering(subdomain_mesh%halos(ihalo)) - call create_ownership(subdomain_mesh%halos(ihalo)) - end if - - end do ! ihalo - - if(all(serial_storage_halo(subdomain_mesh%halos))) then - allocate(subdomain_mesh%element_halos(0)) - else - allocate(subdomain_mesh%element_halos(nhalos)) - call derive_element_halo_from_node_halo(subdomain_mesh, & - & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) - end if - - end subroutine generate_subdomain_halos - - function create_parallel_redundant_mesh(mesh) result (redundant_mesh) - !!< Creates a global mesh that is redundant, i.e. each process sees the entire - !!< mesh, constructed by gathering all local input meshes together. The global mesh - !!< is equiped with a halo structure in which each process owns the nodes associated - !!< with their input mesh. Since each input mesh is sent to each other process, to form - !!< part of their copy of the entire global mesh, on a halo update a process will send - !!< values for its owned nodes to all other processes. - !!< Although the global redundant mesh is the same on all processes, the node and element numbering - !!< is not. The first nodes and elements of the redundant mesh correspond to the node and element numbers - !!< of the input mesh (so we have trailing receives). The input mesh is treated as a completely local - !!< mesh, i.e. any global/halo structure it has is ignored, and each node and element is treated as unique - !!< and not associated with any nodes/elements of input meshes on other processes. - !!< The output redundant mesh only caries a single, nodal halo, in which all nodes associated with the input mesh - !!< are owned (send) nodes, and all other nodes are receives. In this way a simple halo_update(field) suffices - !!< to share all field values with all processes, where field is defined on the redundant_mesh. The send values of - !!< field can first be set by copying over the values from another field defined on the local input mesh (using - !!< the shared node numbering), or through a remap (using the shared element numbering). - !!< It should be clear that setting up this redundant mesh structure, and communicating through halo updates on it - !!< can be extremely expensive and will not in general scale very well - for small meshes such as a surface mesh - !!< this might still be feasible. - - !! Local input mesh. Treated as independent on each process, ignoring any halos - type(mesh_type), intent(inout):: mesh - !! Output global redudant mesh - type(mesh_type):: redundant_mesh - - type(halo_type), pointer :: halo - integer, dimension(:), allocatable :: eles_per_proc, eles_displs - integer, dimension(:), allocatable :: nodes_per_proc, nsends - integer, dimension(:), allocatable :: nodes_to_send, nodes_to_recv - integer, dimension(:, :), allocatable :: eles_send_buf, eles_recv_buf - integer neles, nloc, nprocs, procno - integer comm, ierr - integer i, j, node_offset, ele_offset, send_count - - ewrite(1,*) "Entering create_parallel_redundant_mesh for input mesh ", trim(mesh%name) - - neles = element_count(mesh) - nloc = ele_loc(mesh, 1) - nprocs = getnprocs() - procno = getprocno() - comm = MPI_COMM_FEMTOOLS - - ! exchange element numbers with all other processes - allocate(eles_per_proc(nprocs)) - call mpi_allgather(neles, 1, MPI_INTEGER, & - eles_per_proc, 1, MPI_INTEGER, comm, ierr) - assert(ierr == MPI_SUCCESS) - - ! our local mesh to be sent to everyone - allocate(eles_send_buf(nloc, neles)) - do i=1, neles - eles_send_buf(:,i) = ele_nodes(mesh, i) - end do - - allocate(eles_recv_buf(nloc, sum(eles_per_proc)), eles_displs(nprocs+1)) - ! displacements where in eles_recv_buf to put each bit of the recv'd surface mesh - ! (indexed from 0 - would be nice if they'd actually tell you these things in the mpi docs!) - j = 0 - do i=1, nprocs + ! extra entry nprocs+1 for convenience: eles_displs(i) = j - j = j + eles_per_proc(i)*nloc - end do - ! extra entry nprocs+1 for convenience: - eles_displs(i) = j - assert(j == size(eles_recv_buf)) - - call mpi_allgatherv(eles_send_buf, nloc*neles, MPI_INTEGER, & - eles_recv_buf, nloc*eles_per_proc, eles_displs, MPI_INTEGER, comm, ierr) - assert(ierr == MPI_SUCCESS) - - ! convert from 0-based index in flattened eles_recv_buf - ! to 1-based index for 2nd dim of eles_recv_buf(:, :) - eles_displs = eles_displs/nloc + 1 - - ! nodes per processor - this will be used later as n/o recv nodes, so we don't count our own - allocate(nodes_per_proc(1:nprocs)) - do i=1, nprocs - if (i==procno) then - nodes_per_proc(i) = 0 - else if (eles_displs(i+1)>eles_displs(i)) then - nodes_per_proc(i) = maxval(eles_recv_buf(:, eles_displs(i):eles_displs(i+1)-1)) + assert(j == size(eles_recv_buf)) + + call mpi_allgatherv(eles_send_buf, nloc*neles, MPI_INTEGER, & + eles_recv_buf, nloc*eles_per_proc, eles_displs, MPI_INTEGER, comm, ierr) + assert(ierr == MPI_SUCCESS) + + ! convert from 0-based index in flattened eles_recv_buf + ! to 1-based index for 2nd dim of eles_recv_buf(:, :) + eles_displs = eles_displs/nloc + 1 + + ! nodes per processor - this will be used later as n/o recv nodes, so we don't count our own + allocate(nodes_per_proc(1:nprocs)) + do i=1, nprocs + if (i==procno) then + nodes_per_proc(i) = 0 + else if (eles_displs(i+1)>eles_displs(i)) then + nodes_per_proc(i) = maxval(eles_recv_buf(:, eles_displs(i):eles_displs(i+1)-1)) + else + nodes_per_proc(i) = 0 + end if + end do + + ! n/o nodes to send to each other process based on max node number in elements + ! (typically the same as node_count(mesh), but we could have spurious isolated nodes) + if (neles>0) then + send_count = maxval(eles_send_buf) else - nodes_per_proc(i) = 0 + send_count = 0 end if - end do - - ! n/o nodes to send to each other process based on max node number in elements - ! (typically the same as node_count(mesh), but we could have spurious isolated nodes) - if (neles>0) then - send_count = maxval(eles_send_buf) - else - send_count = 0 - end if - - call allocate(redundant_mesh, send_count + sum(nodes_per_proc), size(eles_recv_buf, 2), mesh%shape, & - name="Verticallyredundant"//trim(mesh%name)) - do i=1, neles - call set_ele_nodes(redundant_mesh, i, ele_nodes(mesh, i)) - end do - - node_offset = send_count - ele_offset = neles - - do i=1, nprocs - if (i==procno) cycle - do j=eles_displs(i), eles_displs(i+1)-1 - ele_offset = ele_offset + 1 - call set_ele_nodes(redundant_mesh, ele_offset, eles_recv_buf(:, j)+node_offset) + + call allocate(redundant_mesh, send_count + sum(nodes_per_proc), size(eles_recv_buf, 2), mesh%shape, & + name="Verticallyredundant"//trim(mesh%name)) + do i=1, neles + call set_ele_nodes(redundant_mesh, i, ele_nodes(mesh, i)) + end do + + node_offset = send_count + ele_offset = neles + + do i=1, nprocs + if (i==procno) cycle + do j=eles_displs(i), eles_displs(i+1)-1 + ele_offset = ele_offset + 1 + call set_ele_nodes(redundant_mesh, ele_offset, eles_recv_buf(:, j)+node_offset) + end do + node_offset = node_offset + nodes_per_proc(i) + end do + assert(node_offset==node_count(redundant_mesh)) + assert(ele_offset==element_count(redundant_mesh)) + + allocate(redundant_mesh%halos(1)) + halo => redundant_mesh%halos(1) + allocate(nsends(1:nprocs)) + + ! send all "owned" nodes (owned nodes in redudant_mesh which is based on max. node number in owned elements of mesh) + nsends = send_count + ! but we don't send it (and recv) these to (from) ourself + nodes_per_proc(procno) = 0 + nsends(procno) = 0 + + call allocate(halo, nsends, nodes_per_proc, nowned_nodes=send_count, & + name="ParallelRedundant"//trim(mesh%name)//"Halo", & + communicator=comm, data_type=HALO_TYPE_CG_NODE) + + allocate(nodes_to_send(1:send_count)) + allocate(nodes_to_recv(1:node_count(redundant_mesh)-send_count)) + nodes_to_send = (/ (i, i=1, send_count) /) + nodes_to_recv = (/ (i, i=send_count+1, node_count(redundant_mesh)) /) + node_offset = 1 + do i=1, nprocs + if (i==procno) cycle + call set_halo_sends(halo, i, nodes_to_send) + call set_halo_receives(halo, i, nodes_to_recv(node_offset:node_offset+nodes_per_proc(i)-1)) + node_offset = node_offset + nodes_per_proc(i) end do - node_offset = node_offset + nodes_per_proc(i) - end do - assert(node_offset==node_count(redundant_mesh)) - assert(ele_offset==element_count(redundant_mesh)) - - allocate(redundant_mesh%halos(1)) - halo => redundant_mesh%halos(1) - allocate(nsends(1:nprocs)) - - ! send all "owned" nodes (owned nodes in redudant_mesh which is based on max. node number in owned elements of mesh) - nsends = send_count - ! but we don't send it (and recv) these to (from) ourself - nodes_per_proc(procno) = 0 - nsends(procno) = 0 - - call allocate(halo, nsends, nodes_per_proc, nowned_nodes=send_count, & - name="ParallelRedundant"//trim(mesh%name)//"Halo", & - communicator=comm, data_type=HALO_TYPE_CG_NODE) - - allocate(nodes_to_send(1:send_count)) - allocate(nodes_to_recv(1:node_count(redundant_mesh)-send_count)) - nodes_to_send = (/ (i, i=1, send_count) /) - nodes_to_recv = (/ (i, i=send_count+1, node_count(redundant_mesh)) /) - node_offset = 1 - do i=1, nprocs - if (i==procno) cycle - call set_halo_sends(halo, i, nodes_to_send) - call set_halo_receives(halo, i, nodes_to_recv(node_offset:node_offset+nodes_per_proc(i)-1)) - node_offset = node_offset + nodes_per_proc(i) - end do - - assert(trailing_receives_consistent(halo)) - assert(halo_valid_for_communication(halo)) - call create_ownership(halo) - call create_global_to_universal_numbering(halo) - - end function create_parallel_redundant_mesh + + assert(trailing_receives_consistent(halo)) + assert(halo_valid_for_communication(halo)) + call create_ownership(halo) + call create_global_to_universal_numbering(halo) + + end function create_parallel_redundant_mesh end module fefields diff --git a/femtools/FETools.F90 b/femtools/FETools.F90 index 082167937d..3c72728658 100644 --- a/femtools/FETools.F90 +++ b/femtools/FETools.F90 @@ -1,929 +1,929 @@ #include "fdebug.h" #define INLINE_MATMUL module fetools - !!< Module containing general tools for discretising Finite Element problems. + !!< Module containing general tools for discretising Finite Element problems. - use fldebug - use elements - use fields_data_types - use fields_base - use transform_elements - implicit none + use fldebug + use elements + use fields_data_types + use fields_base + use transform_elements + implicit none - !! X, Y and Z indices. - integer, parameter :: X_=1,Y_=2,Z_=3 - !! U, V and W indices. - integer, parameter :: U_=1,V_=2,W_=3 + !! X, Y and Z indices. + integer, parameter :: X_=1,Y_=2,Z_=3 + !! U, V and W indices. + integer, parameter :: U_=1,V_=2,W_=3 - !! Huge number useful for effectively zeroing out rows of a matrix. - real, parameter :: INFINITY=huge(0.0)*epsilon(0.0) + !! Huge number useful for effectively zeroing out rows of a matrix. + real, parameter :: INFINITY=huge(0.0)*epsilon(0.0) - interface norm2 - module procedure norm2_element - end interface + interface norm2 + module procedure norm2_element + end interface - interface integral_element - module procedure integral_element_scalar, integral_element_vector, integral_element_scalars - end interface + interface integral_element + module procedure integral_element_scalar, integral_element_vector, integral_element_scalars + end interface - interface dot_integral_element - module procedure dot_integral_element_vector - end interface + interface dot_integral_element + module procedure dot_integral_element_vector + end interface - private :: norm2_element, dot_integral_element_vector - private :: integral_element_scalar, integral_element_vector, integral_element_scalars + private :: norm2_element, dot_integral_element_vector + private :: integral_element_scalar, integral_element_vector, integral_element_scalars contains - function shape_rhs(shape, detwei) - !!< / - !!< Calculate | shape detwei dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - type(element_type), intent(in) :: shape - real, dimension(shape%ngi), intent(in) :: detwei - - real, dimension(shape%loc) :: shape_rhs - - shape_rhs=matmul(shape%n, detwei) - - end function shape_rhs - - function shape_vector_rhs(shape,vector,detwei) - !!< / - !!< Calculate | shape vector detwei dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - type(element_type), intent(in) :: shape - real, dimension(shape%ngi), intent(in) :: detwei - !! vector is dim x ngi - real, dimension(:,:), intent(in) :: vector - - real, dimension(size(vector,1),shape%loc) :: shape_vector_rhs - - integer :: dim,i - - assert(size(vector,2)==shape%ngi) - - dim = size(vector,1) - forall(i=1:dim) - shape_vector_rhs(i,:)=matmul(shape%n, detwei * vector(i,:)) - end forall - - end function shape_vector_rhs - - function shape_tensor_rhs(shape,tensor,detwei) - !!< / - !!< Calculate | shape tensor detwei dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - type(element_type), intent(in) :: shape - real, dimension(shape%ngi), intent(in) :: detwei - !! tensor is dim1 x dim2 x ngi - real, dimension(:,:,:), intent(in) :: tensor - - real, dimension(size(tensor,1), size(tensor, 2), shape%loc) :: shape_tensor_rhs - - integer :: dim1,dim2,i, j - - assert(size(tensor,3)==shape%ngi) - shape_tensor_rhs = 0.0 - - dim1 = size(tensor,1) - dim2 = size(tensor,2) - forall(i=1:dim1) - forall(j=1:dim2) - shape_tensor_rhs(i,j,:)=matmul(shape%n, detwei * tensor(i,j,:)) + function shape_rhs(shape, detwei) + !!< / + !!< Calculate | shape detwei dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + type(element_type), intent(in) :: shape + real, dimension(shape%ngi), intent(in) :: detwei + + real, dimension(shape%loc) :: shape_rhs + + shape_rhs=matmul(shape%n, detwei) + + end function shape_rhs + + function shape_vector_rhs(shape,vector,detwei) + !!< / + !!< Calculate | shape vector detwei dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + type(element_type), intent(in) :: shape + real, dimension(shape%ngi), intent(in) :: detwei + !! vector is dim x ngi + real, dimension(:,:), intent(in) :: vector + + real, dimension(size(vector,1),shape%loc) :: shape_vector_rhs + + integer :: dim,i + + assert(size(vector,2)==shape%ngi) + + dim = size(vector,1) + forall(i=1:dim) + shape_vector_rhs(i,:)=matmul(shape%n, detwei * vector(i,:)) end forall - end forall - - end function shape_tensor_rhs - - function shape_tensor_dot_vector_rhs(shape,tensor,vector,detwei) - !!< / - !!< Calculate | shape tensor detwei dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - type(element_type), intent(in) :: shape ! shape%n is loc x ngi - real, dimension(shape%ngi), intent(in) :: detwei - real, dimension(:,:,:), intent(in) :: tensor !dim1 x dim2 x ngi - real, dimension(:,:) :: vector !dim2 x ngi - - real, dimension(size(tensor,1), shape%loc) :: shape_tensor_dot_vector_rhs - - integer :: dim,i, ngi, j - - assert(size(tensor,3)==shape%ngi) - assert(size(tensor,2)==size(vector,1)) - - dim = size(tensor,1) - ngi = shape%ngi - shape_tensor_dot_vector_rhs = 0.0 - do i=1,dim - do j=1,ngi - shape_tensor_dot_vector_rhs(i,:)=shape_tensor_dot_vector_rhs(i,:) + & - shape%n(:,j)*sum(tensor(i,:,j)*vector(:,j))*detwei(j) + + end function shape_vector_rhs + + function shape_tensor_rhs(shape,tensor,detwei) + !!< / + !!< Calculate | shape tensor detwei dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + type(element_type), intent(in) :: shape + real, dimension(shape%ngi), intent(in) :: detwei + !! tensor is dim1 x dim2 x ngi + real, dimension(:,:,:), intent(in) :: tensor + + real, dimension(size(tensor,1), size(tensor, 2), shape%loc) :: shape_tensor_rhs + + integer :: dim1,dim2,i, j + + assert(size(tensor,3)==shape%ngi) + shape_tensor_rhs = 0.0 + + dim1 = size(tensor,1) + dim2 = size(tensor,2) + forall(i=1:dim1) + forall(j=1:dim2) + shape_tensor_rhs(i,j,:)=matmul(shape%n, detwei * tensor(i,j,:)) + end forall + end forall + + end function shape_tensor_rhs + + function shape_tensor_dot_vector_rhs(shape,tensor,vector,detwei) + !!< / + !!< Calculate | shape tensor detwei dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + type(element_type), intent(in) :: shape ! shape%n is loc x ngi + real, dimension(shape%ngi), intent(in) :: detwei + real, dimension(:,:,:), intent(in) :: tensor !dim1 x dim2 x ngi + real, dimension(:,:) :: vector !dim2 x ngi + + real, dimension(size(tensor,1), shape%loc) :: shape_tensor_dot_vector_rhs + + integer :: dim,i, ngi, j + + assert(size(tensor,3)==shape%ngi) + assert(size(tensor,2)==size(vector,1)) + + dim = size(tensor,1) + ngi = shape%ngi + shape_tensor_dot_vector_rhs = 0.0 + do i=1,dim + do j=1,ngi + shape_tensor_dot_vector_rhs(i,:)=shape_tensor_dot_vector_rhs(i,:) + & + shape%n(:,j)*sum(tensor(i,:,j)*vector(:,j))*detwei(j) + end do end do - end do - - end function shape_tensor_dot_vector_rhs - - function dshape_dot_vector_rhs(dshape, vector, detwei) - !!< / - !!< Calculate | dshape detwei dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - real, dimension(:,:,:), intent(in) :: dshape - !! vector is dim x ngi - real, dimension(:,:), intent(in) :: vector - real, dimension(:), intent(in) :: detwei - - real, dimension(size(dshape,1)) :: dshape_dot_vector_rhs - integer :: ix,loc - - dshape_dot_vector_rhs=0.0 - loc=size(dshape,1) - - forall(ix=1:loc) - dshape_dot_vector_rhs(ix)=sum(sum(dshape(ix,:,:)& + + end function shape_tensor_dot_vector_rhs + + function dshape_dot_vector_rhs(dshape, vector, detwei) + !!< / + !!< Calculate | dshape detwei dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + real, dimension(:,:,:), intent(in) :: dshape + !! vector is dim x ngi + real, dimension(:,:), intent(in) :: vector + real, dimension(:), intent(in) :: detwei + + real, dimension(size(dshape,1)) :: dshape_dot_vector_rhs + integer :: ix,loc + + dshape_dot_vector_rhs=0.0 + loc=size(dshape,1) + + forall(ix=1:loc) + dshape_dot_vector_rhs(ix)=sum(sum(dshape(ix,:,:)& *transpose(vector),2)*detwei,1) - end forall - - end function dshape_dot_vector_rhs - - function dshape_dot_tensor_rhs(dshape,tensor,detwei) - !!< / - !!< Calculate | dshape_dxj tensor_ij dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - real, dimension(:,:,:), intent(in) :: dshape ! loc x ngi x dim2 - real, dimension(:), intent(in) :: detwei ! ngi - real, dimension(:,:,:), intent(in) :: tensor ! dim1 x dim2 x ngi - - real, dimension(size(tensor,1),size(dshape,1)) :: dshape_dot_tensor_rhs - - integer :: dim,i,ngi,j - - assert(size(tensor,3)==size(detwei)) - assert(size(tensor,2)==size(dshape,3)) - dim = size(tensor,1) - ngi = size(detwei) - - dshape_dot_tensor_rhs = 0.0 - do i = 1, dim - do j = 1, ngi - dshape_dot_tensor_rhs(i,:) = dshape_dot_tensor_rhs(i,:) +& - matmul(tensor(i,:,j), transpose(dshape(:,j,:)))*detwei(j) + end forall + + end function dshape_dot_vector_rhs + + function dshape_dot_tensor_rhs(dshape,tensor,detwei) + !!< / + !!< Calculate | dshape_dxj tensor_ij dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + real, dimension(:,:,:), intent(in) :: dshape ! loc x ngi x dim2 + real, dimension(:), intent(in) :: detwei ! ngi + real, dimension(:,:,:), intent(in) :: tensor ! dim1 x dim2 x ngi + + real, dimension(size(tensor,1),size(dshape,1)) :: dshape_dot_tensor_rhs + + integer :: dim,i,ngi,j + + assert(size(tensor,3)==size(detwei)) + assert(size(tensor,2)==size(dshape,3)) + dim = size(tensor,1) + ngi = size(detwei) + + dshape_dot_tensor_rhs = 0.0 + do i = 1, dim + do j = 1, ngi + dshape_dot_tensor_rhs(i,:) = dshape_dot_tensor_rhs(i,:) +& + matmul(tensor(i,:,j), transpose(dshape(:,j,:)))*detwei(j) + end do end do - end do - end function dshape_dot_tensor_rhs + end function dshape_dot_tensor_rhs - function shape_shape(shape1, shape2, detwei) - !!< For each node in each element shape1, shape2 calculate the - !!< coefficient of the integral int(shape1shape2)dV. - !!< - !!< In effect, this calculates a mass matrix. - type(element_type), intent(in) :: shape1, shape2 - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape1%ngi), intent(in) :: detwei + function shape_shape(shape1, shape2, detwei) + !!< For each node in each element shape1, shape2 calculate the + !!< coefficient of the integral int(shape1shape2)dV. + !!< + !!< In effect, this calculates a mass matrix. + type(element_type), intent(in) :: shape1, shape2 + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape1%ngi), intent(in) :: detwei - real, dimension(shape1%loc,shape2%loc) :: shape_shape + real, dimension(shape1%loc,shape2%loc) :: shape_shape - integer :: iloc, jloc + integer :: iloc, jloc - forall(iloc=1:shape1%loc,jloc=1:shape2%loc) - ! Main mass matrix. - shape_shape(iloc,jloc)=& + forall(iloc=1:shape1%loc,jloc=1:shape2%loc) + ! Main mass matrix. + shape_shape(iloc,jloc)=& dot_product(shape1%n(iloc,:)*shape2%n(jloc,:),detwei) - end forall + end forall - end function shape_shape + end function shape_shape - function shape_shape_vector(shape1, shape2, detwei, vector) - !!< For each node in each element shape1, shape2 calculate the - !!< coefficient of the integral int(shape1shape2)vectordV. - type(element_type), intent(in) :: shape1, shape2 - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape1%ngi), intent(in) :: detwei - !! dim x ngi list of vectors. - real, dimension(:,:), intent(in) :: vector + function shape_shape_vector(shape1, shape2, detwei, vector) + !!< For each node in each element shape1, shape2 calculate the + !!< coefficient of the integral int(shape1shape2)vectordV. + type(element_type), intent(in) :: shape1, shape2 + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape1%ngi), intent(in) :: detwei + !! dim x ngi list of vectors. + real, dimension(:,:), intent(in) :: vector - real, dimension(size(vector,1),shape1%loc,shape2%loc) ::& - & shape_shape_vector + real, dimension(size(vector,1),shape1%loc,shape2%loc) ::& + & shape_shape_vector - integer :: iloc,jloc - integer :: dim + integer :: iloc,jloc + integer :: dim - dim=size(vector,1) + dim=size(vector,1) - ! assert(size(vector,2)==shape1%ngi) + ! assert(size(vector,2)==shape1%ngi) - forall(iloc=1:shape1%loc,jloc=1:shape2%loc) - ! Main mass matrix. - shape_shape_vector(:,iloc,jloc)=& + forall(iloc=1:shape1%loc,jloc=1:shape2%loc) + ! Main mass matrix. + shape_shape_vector(:,iloc,jloc)=& matmul(vector*spread(shape1%n(iloc,:)*shape2%n(jloc,:),1,dim),detwei) - end forall + end forall - end function shape_shape_vector + end function shape_shape_vector - function shape_shape_tensor(shape1, shape2, detwei, tensor) - !!< For each node in each element shape1, shape2 calculate the - !!< coefficient of the integral int(shape1shape2)tensor dV. - type(element_type), intent(in) :: shape1, shape2 - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape1%ngi), intent(in) :: detwei - real, dimension(:,:,:), intent(in) :: tensor + function shape_shape_tensor(shape1, shape2, detwei, tensor) + !!< For each node in each element shape1, shape2 calculate the + !!< coefficient of the integral int(shape1shape2)tensor dV. + type(element_type), intent(in) :: shape1, shape2 + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape1%ngi), intent(in) :: detwei + real, dimension(:,:,:), intent(in) :: tensor - real, dimension(size(tensor,1),size(tensor,2),shape1%loc,shape2%loc) ::& - & shape_shape_tensor + real, dimension(size(tensor,1),size(tensor,2),shape1%loc,shape2%loc) ::& + & shape_shape_tensor - integer :: iloc,jloc,i,j + integer :: iloc,jloc,i,j - assert(size(tensor,3)==shape1%ngi) + assert(size(tensor,3)==shape1%ngi) - forall(iloc=1:shape1%loc,jloc=1:shape2%loc,i=1:size(tensor,1),j=1:size(tensor,2)) - ! Main mass matrix. - shape_shape_tensor(i,j,iloc,jloc)=& + forall(iloc=1:shape1%loc,jloc=1:shape2%loc,i=1:size(tensor,1),j=1:size(tensor,2)) + ! Main mass matrix. + shape_shape_tensor(i,j,iloc,jloc)=& sum(shape1%n(iloc,:)*shape2%n(jloc,:)*tensor(i,j,:)*detwei) - end forall + end forall - end function shape_shape_tensor + end function shape_shape_tensor - function shape_shape_vector_outer_vector(shape1, shape2, detwei,vector1,vector2) - !!< For each node in each element shape1, shape2 calculate the - !!< coefficient of the integral int(shape1shape2)vector outer vector dV. - !! - type(element_type), intent(in) :: shape1, shape2 - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape1%ngi), intent(in) :: detwei - real, dimension(:,:), intent(in) :: vector1 - real, dimension(:,:), intent(in) :: vector2 + function shape_shape_vector_outer_vector(shape1, shape2, detwei,vector1,vector2) + !!< For each node in each element shape1, shape2 calculate the + !!< coefficient of the integral int(shape1shape2)vector outer vector dV. + !! + type(element_type), intent(in) :: shape1, shape2 + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape1%ngi), intent(in) :: detwei + real, dimension(:,:), intent(in) :: vector1 + real, dimension(:,:), intent(in) :: vector2 - real, dimension(size(vector1,1),size(vector2,1),shape1%loc,shape2%loc) ::& - & shape_shape_vector_outer_vector + real, dimension(size(vector1,1),size(vector2,1),shape1%loc,shape2%loc) ::& + & shape_shape_vector_outer_vector - integer :: iloc,jloc,i,j + integer :: iloc,jloc,i,j - assert(size(vector1,2)==shape1%ngi) - assert(size(vector2,2)==shape1%ngi) + assert(size(vector1,2)==shape1%ngi) + assert(size(vector2,2)==shape1%ngi) - forall(iloc=1:shape1%loc,jloc=1:shape2%loc,i=1:size(vector1,1),j=1:size(vector2,1)) - ! Main mass matrix. - shape_shape_vector_outer_vector(i,j,iloc,jloc)=& + forall(iloc=1:shape1%loc,jloc=1:shape2%loc,i=1:size(vector1,1),j=1:size(vector2,1)) + ! Main mass matrix. + shape_shape_vector_outer_vector(i,j,iloc,jloc)=& sum(shape1%n(iloc,:)*shape2%n(jloc,:)*vector1(i,:)* & vector2(j,:)*detwei) - end forall + end forall - end function shape_shape_vector_outer_vector + end function shape_shape_vector_outer_vector - function dshape_rhs(dshape, detwei) - !!< / - !!< Calculate | dshape detwei dV - !!< / - !!< - !!< Note that this is an integral of a single shape function. This is - !!< primarily useful for evaluating righthand sides of equations where a - !!< function has been evaluated at the quadrature points and incorporated - !!< with detwei. - real, dimension(:,:,:), intent(in) :: dshape !loc * ngi * dim - real, dimension(size(dshape,2)), intent(in) :: detwei !ngi + function dshape_rhs(dshape, detwei) + !!< / + !!< Calculate | dshape detwei dV + !!< / + !!< + !!< Note that this is an integral of a single shape function. This is + !!< primarily useful for evaluating righthand sides of equations where a + !!< function has been evaluated at the quadrature points and incorporated + !!< with detwei. + real, dimension(:,:,:), intent(in) :: dshape !loc * ngi * dim + real, dimension(size(dshape,2)), intent(in) :: detwei !ngi - real, dimension(size(dshape,3),size(dshape,1)) :: dshape_rhs !dim * loc + real, dimension(size(dshape,3),size(dshape,1)) :: dshape_rhs !dim * loc - integer :: dim,i + integer :: dim,i - dim = size(dshape,3) + dim = size(dshape,3) - forall(i=1:dim) - dshape_rhs(i,:)=matmul(dshape(:,:,i),detwei) - end forall + forall(i=1:dim) + dshape_rhs(i,:)=matmul(dshape(:,:,i),detwei) + end forall - end function dshape_rhs + end function dshape_rhs - function shape_dshape(shape, dshape, detwei) - !!< For each node in element shape and transformed gradient dshape, - !!< calculate the coefficient of the integral int(shape dshape)dV. - type(element_type), intent(in) :: shape - !! The dimensions of dshape are: - !! (nodes, gauss points, dimensions) - real, dimension(:,:,:), intent(in) :: dshape - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape%ngi), intent(in) :: detwei + function shape_dshape(shape, dshape, detwei) + !!< For each node in element shape and transformed gradient dshape, + !!< calculate the coefficient of the integral int(shape dshape)dV. + type(element_type), intent(in) :: shape + !! The dimensions of dshape are: + !! (nodes, gauss points, dimensions) + real, dimension(:,:,:), intent(in) :: dshape + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape%ngi), intent(in) :: detwei - real, dimension(size(dshape,3), shape%loc, size(dshape,1)) :: shape_dshape + real, dimension(size(dshape,3), shape%loc, size(dshape,1)) :: shape_dshape - integer :: iloc,jloc - integer :: dshape_loc, dim, idim + integer :: iloc,jloc + integer :: dshape_loc, dim, idim - dshape_loc=size(dshape,1) - dim=size(dshape,3) + dshape_loc=size(dshape,1) + dim=size(dshape,3) #ifdef INLINE_MATMUL - forall(iloc=1:shape%loc,jloc=1:dshape_loc,idim=1:dim) - shape_dshape(idim,iloc,jloc)= sum(detwei * dshape(jloc,:,idim) * shape%n(iloc,:)) - end forall + forall(iloc=1:shape%loc,jloc=1:dshape_loc,idim=1:dim) + shape_dshape(idim,iloc,jloc)= sum(detwei * dshape(jloc,:,idim) * shape%n(iloc,:)) + end forall #else - forall(iloc=1:shape%loc,jloc=1:dshape_loc) - ! Main matrix. - shape_dshape(1:dim,iloc,jloc)= & + forall(iloc=1:shape%loc,jloc=1:dshape_loc) + ! Main matrix. + shape_dshape(1:dim,iloc,jloc)= & matmul(detwei,spread(shape%n(iloc,:),2,dim)*dshape(jloc,:,:)) - end forall + end forall #endif - end function shape_dshape - - function dshape_shape(dshape, shape, detwei) - !!< For each node in element shape and transformed gradient dshape, - !!< calculate the coefficient of the integral int(dshape shape)dV. - type(element_type), intent(in) :: shape - !! The dimensions of dshape are: - !! (nodes, gauss points, dimensions) - real, dimension(:,:,:), intent(in) :: dshape - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape%ngi), intent(in) :: detwei - - real, dimension(size(dshape,3),size(dshape,1),shape%loc) :: dshape_shape - - integer :: iloc,jloc - integer :: dshape_loc, dim - - dshape_loc=size(dshape,1) - dim=size(dshape,3) - - forall(iloc=1:dshape_loc,jloc=1:shape%loc) - ! Main matrix. - dshape_shape(1:dim,iloc,jloc)= & + end function shape_dshape + + function dshape_shape(dshape, shape, detwei) + !!< For each node in element shape and transformed gradient dshape, + !!< calculate the coefficient of the integral int(dshape shape)dV. + type(element_type), intent(in) :: shape + !! The dimensions of dshape are: + !! (nodes, gauss points, dimensions) + real, dimension(:,:,:), intent(in) :: dshape + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape%ngi), intent(in) :: detwei + + real, dimension(size(dshape,3),size(dshape,1),shape%loc) :: dshape_shape + + integer :: iloc,jloc + integer :: dshape_loc, dim + + dshape_loc=size(dshape,1) + dim=size(dshape,3) + + forall(iloc=1:dshape_loc,jloc=1:shape%loc) + ! Main matrix. + dshape_shape(1:dim,iloc,jloc)= & matmul(detwei,dshape(iloc,:,1:dim)*spread(shape%n(jloc,:),2,dim)) - end forall - - end function dshape_shape - - function dshape_dot_dshape(dshape1, dshape2, detwei) result (R) - !!< / - !!< Evaluate: |(Grad N1)' dot (Grad N2) dV For shapes N1 and N2. - !!< / - real, dimension(:,:,:), intent(in) :: dshape1, dshape2 - real, dimension(size(dshape1,2)) :: detwei - - real, dimension(size(dshape1,1),size(dshape2,1)) :: R - - integer :: iloc,jloc, gi - integer :: loc1, loc2, ngi, dim - - loc1=size(dshape1,1) - loc2=size(dshape2,1) - ngi=size(dshape1,2) - dim=size(dshape1,3) - - assert(loc1==loc2) - - R=0.0 - - select case(dim) - case(3) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * dshape2(jloc,gi,1)) & - & + (dshape1(iloc,gi,2) * dshape2(jloc,gi,2)) & - & + (dshape1(iloc,gi,3) * dshape2(jloc,gi,3)) & - & ) * detwei(gi) - end forall - end do - case(2) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * dshape2(jloc,gi,1)) & - & + (dshape1(iloc,gi,2) * dshape2(jloc,gi,2)) & - & ) * detwei(gi) - end forall - end do - case(1) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * dshape2(jloc,gi,1)) & - & ) * detwei(gi) - end forall - end do - case default - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - +dot_product(dshape1(iloc,gi,:),dshape2(jloc,gi,:))& - *detwei(gi) - end forall - end do - end select - - end function dshape_dot_dshape - - function shape_vector_outer_dshape(& - shape,vector,dshape,detwei) result (tensor) - !!< For each node in element shape and transformed gradient dshape, - !!< calculate the coefficient of the integral - !!< - !!< Q_ij = int(shape vector_i dshape_j)dV. - type(element_type), intent(in) :: shape - !! The dimensions of dshape are: - !! (nodes, gauss points, dimensions) - real, dimension(:,:,:), intent(in) :: dshape - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape%ngi), intent(in) :: detwei - real, dimension(:,:), intent(in) :: vector - real, dimension(size(vector,1),size(dshape,3), & + end forall + + end function dshape_shape + + function dshape_dot_dshape(dshape1, dshape2, detwei) result (R) + !!< / + !!< Evaluate: |(Grad N1)' dot (Grad N2) dV For shapes N1 and N2. + !!< / + real, dimension(:,:,:), intent(in) :: dshape1, dshape2 + real, dimension(size(dshape1,2)) :: detwei + + real, dimension(size(dshape1,1),size(dshape2,1)) :: R + + integer :: iloc,jloc, gi + integer :: loc1, loc2, ngi, dim + + loc1=size(dshape1,1) + loc2=size(dshape2,1) + ngi=size(dshape1,2) + dim=size(dshape1,3) + + assert(loc1==loc2) + + R=0.0 + + select case(dim) + case(3) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * dshape2(jloc,gi,1)) & + & + (dshape1(iloc,gi,2) * dshape2(jloc,gi,2)) & + & + (dshape1(iloc,gi,3) * dshape2(jloc,gi,3)) & + & ) * detwei(gi) + end forall + end do + case(2) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * dshape2(jloc,gi,1)) & + & + (dshape1(iloc,gi,2) * dshape2(jloc,gi,2)) & + & ) * detwei(gi) + end forall + end do + case(1) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * dshape2(jloc,gi,1)) & + & ) * detwei(gi) + end forall + end do + case default + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + +dot_product(dshape1(iloc,gi,:),dshape2(jloc,gi,:))& + *detwei(gi) + end forall + end do + end select + + end function dshape_dot_dshape + + function shape_vector_outer_dshape(& + shape,vector,dshape,detwei) result (tensor) + !!< For each node in element shape and transformed gradient dshape, + !!< calculate the coefficient of the integral + !!< + !!< Q_ij = int(shape vector_i dshape_j)dV. + type(element_type), intent(in) :: shape + !! The dimensions of dshape are: + !! (nodes, gauss points, dimensions) + real, dimension(:,:,:), intent(in) :: dshape + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape%ngi), intent(in) :: detwei + real, dimension(:,:), intent(in) :: vector + real, dimension(size(vector,1),size(dshape,3), & shape%loc,size(dshape,1)) :: tensor - integer :: iloc,jloc,i,j - integer :: dshape_loc, dim1,dim2 + integer :: iloc,jloc,i,j + integer :: dshape_loc, dim1,dim2 - dshape_loc=size(dshape,1) - dim1=size(dshape,3) - dim2=size(vector,1) - assert(size(vector,2)==shape%ngi) + dshape_loc=size(dshape,1) + dim1=size(dshape,3) + dim2=size(vector,1) + assert(size(vector,2)==shape%ngi) - forall(iloc=1:shape%loc,jloc=1:dshape_loc,i = 1:dim1,j = 1:dim2) - ! Main matrix. - tensor(i,j,iloc,jloc)= & + forall(iloc=1:shape%loc,jloc=1:dshape_loc,i = 1:dim1,j = 1:dim2) + ! Main matrix. + tensor(i,j,iloc,jloc)= & sum(shape%n(iloc,:)*dshape(jloc,:,j)*detwei*vector(i,:)) - end forall - - end function shape_vector_outer_dshape - - function dshape_outer_vector_shape( & - dshape,vector,shape,detwei) result (tensor) - !!< For each node in element shape and transformed gradient dshape, - !!< calculate the coefficient of the integral - !!< - !!< Q_ij = int(shape vector_i dshape_j)dV. - type(element_type), intent(in) :: shape - !! The dimensions of dshape are: - !! (nodes, gauss points, dimensions) - real, dimension(:,:,:), intent(in) :: dshape - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(shape%ngi), intent(in) :: detwei - real, dimension(:,:), intent(in) :: vector - real, dimension(size(dshape,3),size(vector,1), & + end forall + + end function shape_vector_outer_dshape + + function dshape_outer_vector_shape( & + dshape,vector,shape,detwei) result (tensor) + !!< For each node in element shape and transformed gradient dshape, + !!< calculate the coefficient of the integral + !!< + !!< Q_ij = int(shape vector_i dshape_j)dV. + type(element_type), intent(in) :: shape + !! The dimensions of dshape are: + !! (nodes, gauss points, dimensions) + real, dimension(:,:,:), intent(in) :: dshape + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(shape%ngi), intent(in) :: detwei + real, dimension(:,:), intent(in) :: vector + real, dimension(size(dshape,3),size(vector,1), & shape%loc,size(dshape,1)) :: tensor - integer :: iloc,jloc,i,j - integer :: dshape_loc, dim1,dim2 + integer :: iloc,jloc,i,j + integer :: dshape_loc, dim1,dim2 - dshape_loc=size(dshape,1) - dim1=size(dshape,3) - dim2=size(vector,1) - assert(size(vector,2)==shape%ngi) + dshape_loc=size(dshape,1) + dim1=size(dshape,3) + dim2=size(vector,1) + assert(size(vector,2)==shape%ngi) - forall(iloc=1:dshape_loc,jloc=1:shape%loc,i = 1:dim1,j = 1:dim2) - ! Main matrix. - tensor(i,j,iloc,jloc)= & + forall(iloc=1:dshape_loc,jloc=1:shape%loc,i = 1:dim1,j = 1:dim2) + ! Main matrix. + tensor(i,j,iloc,jloc)= & sum(dshape(iloc,:,i)*detwei*vector(j,:)*shape%n(jloc,:)) - end forall + end forall - end function dshape_outer_vector_shape + end function dshape_outer_vector_shape - function dshape_outer_dshape(dshape1, dshape2, detwei) result (R) - !!< For each node in each transformed gradient dshape1, dshape2, - !!< calculate the coefficient of the integral int(dshape outer dshape)dV. + function dshape_outer_dshape(dshape1, dshape2, detwei) result (R) + !!< For each node in each transformed gradient dshape1, dshape2, + !!< calculate the coefficient of the integral int(dshape outer dshape)dV. - !! The dimensions of dshape are: - !! (nodes, gauss points, dimensions) - real, dimension(:,:,:), intent(in) :: dshape1,dshape2 - !! The gauss weights transformed by the coordinate transform - !! from real to computational space. - real, dimension(size(dshape1,2)) :: detwei - real, dimension(size(dshape1,3),size(dshape2,3),size(dshape1,1),size(dshape2,1)) :: R + !! The dimensions of dshape are: + !! (nodes, gauss points, dimensions) + real, dimension(:,:,:), intent(in) :: dshape1,dshape2 + !! The gauss weights transformed by the coordinate transform + !! from real to computational space. + real, dimension(size(dshape1,2)) :: detwei + real, dimension(size(dshape1,3),size(dshape2,3),size(dshape1,1),size(dshape2,1)) :: R - integer :: iloc,jloc, i,j - integer :: loc1, loc2, ngi, dim1, dim2 + integer :: iloc,jloc, i,j + integer :: loc1, loc2, ngi, dim1, dim2 - loc1=size(dshape1,1) - loc2=size(dshape2,1) - ngi=size(dshape1,2) - dim1=size(dshape1,3) - dim2=size(dshape2,3) + loc1=size(dshape1,1) + loc2=size(dshape2,1) + ngi=size(dshape1,2) + dim1=size(dshape1,3) + dim2=size(dshape2,3) - R=0.0 + R=0.0 - forall(iloc=1:loc1,jloc=1:loc2,i=1:dim1,j=1:dim2) - r(i,j,iloc,jloc)=r(i,j,iloc,jloc) & + forall(iloc=1:loc1,jloc=1:loc2,i=1:dim1,j=1:dim2) + r(i,j,iloc,jloc)=r(i,j,iloc,jloc) & +sum(dshape1(iloc,:,i)*dshape2(jloc,:,j)*detwei) - end forall - - end function dshape_outer_dshape - - function dshape_diagtensor_dshape(dshape1, tensor, dshape2, detwei) result (R) - !!< - !!< Evaluate: (Grad N1)' diag(T) (Grad N2) For shape N and tensor T. - !!< - real, dimension(:,:,:), intent(in) :: dshape1, dshape2 - real, dimension(size(dshape1,3),size(dshape1,3),size(dshape1,2)), intent(in) :: tensor - real, dimension(size(dshape1,2)) :: detwei - - real, dimension(size(dshape1,1),size(dshape2,1)) :: R - - real, dimension(size(dshape1,3),size(dshape1,2)) :: diag_tensor - integer :: iloc,jloc, gi - integer :: loc1, loc2, ngi, dim - - loc1=size(dshape1,1) - loc2=size(dshape2,1) - ngi=size(dshape1,2) - dim=size(dshape1,3) - - assert(loc1==loc2) - - R=0.0 - - select case(dim) - case(3) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * tensor(1,1,gi) * dshape2(jloc,gi,1)) & - & + (dshape1(iloc,gi,2) * tensor(2,2,gi) * dshape2(jloc,gi,2)) & - & + (dshape1(iloc,gi,3) * tensor(3,3,gi) * dshape2(jloc,gi,3)) & - & ) * detwei(gi) - end forall - end do - case(2) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * tensor(1,1,gi) * dshape2(jloc,gi,1)) & - & + (dshape1(iloc,gi,2) * tensor(2,2,gi) * dshape2(jloc,gi,2)) & - & ) * detwei(gi) - end forall - end do - case default - diag_tensor = 0.0 - forall(iloc=1:dim) - diag_tensor(iloc,:) = tensor(iloc,iloc,:) - end forall - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - +dot_product(dshape1(iloc,gi,:)*diag_tensor(:,gi),dshape2(jloc,gi,:))& - *detwei(gi) - end forall - end do - end select - - end function dshape_diagtensor_dshape - - function dshape_vector_dshape(dshape1, vector, dshape2, detwei) result (R) - !!< - !!< Evaluate: (Grad N1)' V (Grad N2) For shape N and vector V. - !!< - real, dimension(:,:,:), intent(in) :: dshape1, dshape2 - real, dimension(size(dshape1,3),size(dshape1,2)), intent(in) :: vector - real, dimension(size(dshape1,2)) :: detwei - - real, dimension(size(dshape1,1),size(dshape2,1)) :: R - - integer :: iloc,jloc, gi - integer :: loc1, loc2, ngi, dim - - loc1=size(dshape1,1) - loc2=size(dshape2,1) - ngi=size(dshape1,2) - dim=size(dshape1,3) - - assert(loc1==loc2) - - R=0.0 - - select case(dim) - case(3) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * vector(1,gi) * dshape2(jloc,gi,1)) & - & + (dshape1(iloc,gi,2) * vector(2,gi) * dshape2(jloc,gi,2)) & - & + (dshape1(iloc,gi,3) * vector(3,gi) * dshape2(jloc,gi,3)) & - & ) * detwei(gi) - end forall - end do - case(2) - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - & + ( & - & (dshape1(iloc,gi,1) * vector(1,gi) * dshape2(jloc,gi,1)) & - & + (dshape1(iloc,gi,2) * vector(2,gi) * dshape2(jloc,gi,2)) & - & ) * detwei(gi) - end forall - end do - case default - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & - +dot_product(dshape1(iloc,gi,:)*vector(:,gi),dshape2(jloc,gi,:))& - *detwei(gi) - end forall - end do - end select - - end function dshape_vector_dshape - - function dshape_tensor_dshape(dshape1, tensor, dshape2, detwei) result (R) - !!< - !!< Evaluate: (Grad N1)' T (Grad N2) For shape N and tensor T. - !!< - real, dimension(:,:,:), intent(in) :: dshape1, dshape2 - real, dimension(size(dshape1,3),size(dshape1,3),size(dshape1,2)), intent(in) :: tensor - real, dimension(size(dshape1,2)) :: detwei - - real, dimension(size(dshape1,1),size(dshape2,1)) :: R - - integer :: iloc,jloc, gi - integer :: loc1, loc2, ngi, dim - - loc1=size(dshape1,1) - loc2=size(dshape2,1) - ngi=size(dshape1,2) - dim=size(dshape1,3) - - assert(loc1==loc2) - - R=0.0 - - do gi=1,ngi - forall(iloc=1:loc1,jloc=1:loc2) - r(iloc,jloc)=r(iloc,jloc) & + end forall + + end function dshape_outer_dshape + + function dshape_diagtensor_dshape(dshape1, tensor, dshape2, detwei) result (R) + !!< + !!< Evaluate: (Grad N1)' diag(T) (Grad N2) For shape N and tensor T. + !!< + real, dimension(:,:,:), intent(in) :: dshape1, dshape2 + real, dimension(size(dshape1,3),size(dshape1,3),size(dshape1,2)), intent(in) :: tensor + real, dimension(size(dshape1,2)) :: detwei + + real, dimension(size(dshape1,1),size(dshape2,1)) :: R + + real, dimension(size(dshape1,3),size(dshape1,2)) :: diag_tensor + integer :: iloc,jloc, gi + integer :: loc1, loc2, ngi, dim + + loc1=size(dshape1,1) + loc2=size(dshape2,1) + ngi=size(dshape1,2) + dim=size(dshape1,3) + + assert(loc1==loc2) + + R=0.0 + + select case(dim) + case(3) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * tensor(1,1,gi) * dshape2(jloc,gi,1)) & + & + (dshape1(iloc,gi,2) * tensor(2,2,gi) * dshape2(jloc,gi,2)) & + & + (dshape1(iloc,gi,3) * tensor(3,3,gi) * dshape2(jloc,gi,3)) & + & ) * detwei(gi) + end forall + end do + case(2) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * tensor(1,1,gi) * dshape2(jloc,gi,1)) & + & + (dshape1(iloc,gi,2) * tensor(2,2,gi) * dshape2(jloc,gi,2)) & + & ) * detwei(gi) + end forall + end do + case default + diag_tensor = 0.0 + forall(iloc=1:dim) + diag_tensor(iloc,:) = tensor(iloc,iloc,:) + end forall + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + +dot_product(dshape1(iloc,gi,:)*diag_tensor(:,gi),dshape2(jloc,gi,:))& + *detwei(gi) + end forall + end do + end select + + end function dshape_diagtensor_dshape + + function dshape_vector_dshape(dshape1, vector, dshape2, detwei) result (R) + !!< + !!< Evaluate: (Grad N1)' V (Grad N2) For shape N and vector V. + !!< + real, dimension(:,:,:), intent(in) :: dshape1, dshape2 + real, dimension(size(dshape1,3),size(dshape1,2)), intent(in) :: vector + real, dimension(size(dshape1,2)) :: detwei + + real, dimension(size(dshape1,1),size(dshape2,1)) :: R + + integer :: iloc,jloc, gi + integer :: loc1, loc2, ngi, dim + + loc1=size(dshape1,1) + loc2=size(dshape2,1) + ngi=size(dshape1,2) + dim=size(dshape1,3) + + assert(loc1==loc2) + + R=0.0 + + select case(dim) + case(3) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * vector(1,gi) * dshape2(jloc,gi,1)) & + & + (dshape1(iloc,gi,2) * vector(2,gi) * dshape2(jloc,gi,2)) & + & + (dshape1(iloc,gi,3) * vector(3,gi) * dshape2(jloc,gi,3)) & + & ) * detwei(gi) + end forall + end do + case(2) + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + & + ( & + & (dshape1(iloc,gi,1) * vector(1,gi) * dshape2(jloc,gi,1)) & + & + (dshape1(iloc,gi,2) * vector(2,gi) * dshape2(jloc,gi,2)) & + & ) * detwei(gi) + end forall + end do + case default + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & + +dot_product(dshape1(iloc,gi,:)*vector(:,gi),dshape2(jloc,gi,:))& + *detwei(gi) + end forall + end do + end select + + end function dshape_vector_dshape + + function dshape_tensor_dshape(dshape1, tensor, dshape2, detwei) result (R) + !!< + !!< Evaluate: (Grad N1)' T (Grad N2) For shape N and tensor T. + !!< + real, dimension(:,:,:), intent(in) :: dshape1, dshape2 + real, dimension(size(dshape1,3),size(dshape1,3),size(dshape1,2)), intent(in) :: tensor + real, dimension(size(dshape1,2)) :: detwei + + real, dimension(size(dshape1,1),size(dshape2,1)) :: R + + integer :: iloc,jloc, gi + integer :: loc1, loc2, ngi, dim + + loc1=size(dshape1,1) + loc2=size(dshape2,1) + ngi=size(dshape1,2) + dim=size(dshape1,3) + + assert(loc1==loc2) + + R=0.0 + + do gi=1,ngi + forall(iloc=1:loc1,jloc=1:loc2) + r(iloc,jloc)=r(iloc,jloc) & +dot_product(matmul(dshape1(iloc,gi,:), tensor(:,:,gi)),& - & dshape2(jloc,gi,:))*detwei(gi) - end forall - end do + & dshape2(jloc,gi,:))*detwei(gi) + end forall + end do - end function dshape_tensor_dshape + end function dshape_tensor_dshape - function dshape_dot_vector_shape(dshape, vector, shape, detwei) result (R) - !!< - !!< Evaluate (Grad N1 dot vector) (N2) - !!< - real, dimension(:,:,:), intent(in) :: dshape - real, dimension(size(dshape,3),size(dshape,2)), intent(in) :: vector - type(element_type), intent(in) :: shape - real, dimension(size(dshape,2)) :: detwei + function dshape_dot_vector_shape(dshape, vector, shape, detwei) result (R) + !!< + !!< Evaluate (Grad N1 dot vector) (N2) + !!< + real, dimension(:,:,:), intent(in) :: dshape + real, dimension(size(dshape,3),size(dshape,2)), intent(in) :: vector + type(element_type), intent(in) :: shape + real, dimension(size(dshape,2)) :: detwei - real, dimension(size(dshape,1),shape%loc) :: R + real, dimension(size(dshape,1),shape%loc) :: R - integer :: iloc,jloc - integer :: dshape_loc + integer :: iloc,jloc + integer :: dshape_loc - dshape_loc=size(dshape,1) + dshape_loc=size(dshape,1) - forall(iloc=1:dshape_loc,jloc=1:shape%loc) - R(iloc,jloc)= dot_product(sum(dshape(iloc,:,:)*transpose(vector),2) & + forall(iloc=1:dshape_loc,jloc=1:shape%loc) + R(iloc,jloc)= dot_product(sum(dshape(iloc,:,:)*transpose(vector),2) & *shape%n(jloc,:), detwei) - end forall + end forall - end function dshape_dot_vector_shape + end function dshape_dot_vector_shape - function dshape_dot_tensor_shape(dshape, tensor, shape, detwei) result (R) - !!< / - !!< Evaluate | (Grad N1 dot tensor) (N2) - !!< / - real, dimension(:,:,:), intent(in) :: dshape ! nloc1 x ngi x dim1 - real, dimension(:,:,:), intent(in) :: tensor ! dim1 x dim2 x ngi - type(element_type), intent(in) :: shape - real, dimension(size(dshape,2)) :: detwei + function dshape_dot_tensor_shape(dshape, tensor, shape, detwei) result (R) + !!< / + !!< Evaluate | (Grad N1 dot tensor) (N2) + !!< / + real, dimension(:,:,:), intent(in) :: dshape ! nloc1 x ngi x dim1 + real, dimension(:,:,:), intent(in) :: tensor ! dim1 x dim2 x ngi + type(element_type), intent(in) :: shape + real, dimension(size(dshape,2)) :: detwei - real, dimension(size(tensor,2),size(dshape,1),shape%loc) :: R + real, dimension(size(tensor,2),size(dshape,1),shape%loc) :: R - integer :: iloc,jloc, idim2 - integer :: dshape_loc, dim2 + integer :: iloc,jloc, idim2 + integer :: dshape_loc, dim2 - dshape_loc=size(dshape,1) - dim2=size(tensor,2) + dshape_loc=size(dshape,1) + dim2=size(tensor,2) - forall(iloc=1:dshape_loc,jloc=1:shape%loc,idim2=1:dim2) - R(idim2,iloc,jloc)=dot_product(sum( dshape(iloc,:,:)* transpose(tensor(:,idim2,:)) ) & + forall(iloc=1:dshape_loc,jloc=1:shape%loc,idim2=1:dim2) + R(idim2,iloc,jloc)=dot_product(sum( dshape(iloc,:,:)* transpose(tensor(:,idim2,:)) ) & *shape%n(jloc,:), detwei) - end forall + end forall - end function dshape_dot_tensor_shape + end function dshape_dot_tensor_shape - function shape_vector_dot_dshape(shape, vector, dshape, detwei) result (R) - !!< - !!< Evaluate (Grad N1 dot vector) (N2) - !!< - type(element_type), intent(in) :: shape - real, dimension(:,:,:), intent(in) :: dshape - real, dimension(size(dshape,3),size(dshape,2)), intent(in) :: vector - real, dimension(size(dshape,2)) :: detwei + function shape_vector_dot_dshape(shape, vector, dshape, detwei) result (R) + !!< + !!< Evaluate (Grad N1 dot vector) (N2) + !!< + type(element_type), intent(in) :: shape + real, dimension(:,:,:), intent(in) :: dshape + real, dimension(size(dshape,3),size(dshape,2)), intent(in) :: vector + real, dimension(size(dshape,2)) :: detwei - real, dimension(shape%loc, size(dshape,1)) :: R + real, dimension(shape%loc, size(dshape,1)) :: R - integer :: iloc,jloc - integer :: dshape_loc, dim + integer :: iloc,jloc + integer :: dshape_loc, dim - dshape_loc=size(dshape,1) - dim=size(dshape,3) + dshape_loc=size(dshape,1) + dim=size(dshape,3) - forall(iloc=1:shape%loc,jloc=1:dshape_loc) - R(iloc,jloc)= dot_product(shape%n(iloc,:) * & + forall(iloc=1:shape%loc,jloc=1:dshape_loc) + R(iloc,jloc)= dot_product(shape%n(iloc,:) * & sum(dshape(jloc,:,:)*transpose(vector),2), detwei) - end forall + end forall - end function shape_vector_dot_dshape + end function shape_vector_dot_dshape - function shape_curl_shape_2d(shape, dshape, detwei) result (R) - !!< / - !!< Evaluate: |(N1)(Curl N2) dV For shapes N1 and N2. - !!< / - !!< Note that curl is a dimension-specific operator so this version - !!< only makes sense for 2D. - type(element_type), intent(in) :: shape - real, dimension(:,:,:), intent(in) :: dshape - real, dimension(size(dshape,2)) :: detwei + function shape_curl_shape_2d(shape, dshape, detwei) result (R) + !!< / + !!< Evaluate: |(N1)(Curl N2) dV For shapes N1 and N2. + !!< / + !!< Note that curl is a dimension-specific operator so this version + !!< only makes sense for 2D. + type(element_type), intent(in) :: shape + real, dimension(:,:,:), intent(in) :: dshape + real, dimension(size(dshape,2)) :: detwei - real, dimension(2,shape%loc,size(dshape,1)) :: R + real, dimension(2,shape%loc,size(dshape,1)) :: R - integer :: iloc,jloc - integer :: dshape_loc, dim + integer :: iloc,jloc + integer :: dshape_loc, dim - dshape_loc=size(dshape,1) - dim=size(dshape,3) + dshape_loc=size(dshape,1) + dim=size(dshape,3) - assert(dim==2) + assert(dim==2) - forall(iloc=1:shape%loc,jloc=1:dshape_loc) - R(1,iloc,jloc)= dot_product(shape%n(iloc,:) * & + forall(iloc=1:shape%loc,jloc=1:dshape_loc) + R(1,iloc,jloc)= dot_product(shape%n(iloc,:) * & dshape(jloc,:,2), detwei) - R(2,iloc,jloc)= -dot_product(shape%n(iloc,:) * & + R(2,iloc,jloc)= -dot_product(shape%n(iloc,:) * & dshape(jloc,:,1), detwei) - end forall + end forall - end function shape_curl_shape_2d + end function shape_curl_shape_2d - function norm2_element(field, X, ele) result (norm) - !!< Return the l2 norm of field on the given element. - real :: norm - ! Element values at the nodes. - type(scalar_field), intent(in) :: field - ! Shape of field elements. - type(element_type), pointer :: field_shape - ! The positions of the nodes in this element. - type(vector_field), intent(in) :: X - ! The number of the element to operate on. - integer, intent(in) :: ele + function norm2_element(field, X, ele) result (norm) + !!< Return the l2 norm of field on the given element. + real :: norm + ! Element values at the nodes. + type(scalar_field), intent(in) :: field + ! Shape of field elements. + type(element_type), pointer :: field_shape + ! The positions of the nodes in this element. + type(vector_field), intent(in) :: X + ! The number of the element to operate on. + integer, intent(in) :: ele - real, dimension(ele_ngi(field,ele)) :: detwei + real, dimension(ele_ngi(field,ele)) :: detwei - real, dimension(ele_loc(field,ele)) :: field_val + real, dimension(ele_loc(field,ele)) :: field_val - field_val=ele_val(field, ele) + field_val=ele_val(field, ele) - field_shape=>ele_shape(field, ele) + field_shape=>ele_shape(field, ele) - call transform_to_physical(X, ele, detwei=detwei) + call transform_to_physical(X, ele, detwei=detwei) - norm = dot_product(field_val, matmul(& - & shape_shape(field_shape, field_shape, detwei)& - & ,field_val)) + norm = dot_product(field_val, matmul(& + & shape_shape(field_shape, field_shape, detwei)& + & ,field_val)) - end function norm2_element + end function norm2_element - function integral_element_scalar(field, X, ele) result& - & (integral) - !!< Return the integral of field over the given element. - real :: integral - ! Element values at the nodes. - type(scalar_field), intent(in) :: field - ! The positions of the nodes in this element. - type(vector_field), intent(in) :: X - ! The number of the current element - integer, intent(in) :: ele + function integral_element_scalar(field, X, ele) result& + & (integral) + !!< Return the integral of field over the given element. + real :: integral + ! Element values at the nodes. + type(scalar_field), intent(in) :: field + ! The positions of the nodes in this element. + type(vector_field), intent(in) :: X + ! The number of the current element + integer, intent(in) :: ele - real, dimension(ele_ngi(field, ele)) :: detwei + real, dimension(ele_ngi(field, ele)) :: detwei - call transform_to_physical(X, ele, detwei=detwei) + call transform_to_physical(X, ele, detwei=detwei) - integral=dot_product(ele_val_at_quad(field, ele), detwei) + integral=dot_product(ele_val_at_quad(field, ele), detwei) - end function integral_element_scalar + end function integral_element_scalar - function integral_element_vector(field, X, ele) result& - & (integral) - !!< Return the integral of field over the given element_vector. - ! Element values at the nodes. - type(vector_field), intent(in) :: field - ! The positions of the nodes in this element - type(vector_field), intent(in) :: X - ! The number of the current element - integer, intent(in) :: ele + function integral_element_vector(field, X, ele) result& + & (integral) + !!< Return the integral of field over the given element_vector. + ! Element values at the nodes. + type(vector_field), intent(in) :: field + ! The positions of the nodes in this element + type(vector_field), intent(in) :: X + ! The number of the current element + integer, intent(in) :: ele - real, dimension(field%dim) :: integral + real, dimension(field%dim) :: integral - real, dimension(ele_ngi(field, ele)) :: detwei + real, dimension(ele_ngi(field, ele)) :: detwei - call transform_to_physical(X, ele, detwei=detwei) + call transform_to_physical(X, ele, detwei=detwei) - integral=matmul(matmul(ele_val(field, ele), field%mesh%shape%n), detwei) + integral=matmul(matmul(ele_val(field, ele), field%mesh%shape%n), detwei) - end function integral_element_vector + end function integral_element_vector - function dot_integral_element_vector(fieldA, fieldB, X, ele) result& - & (integral) - !!< Return the integral of dot(fieldA, fieldB) over the element ele - type(vector_field), intent(in) :: fieldA, fieldB - ! positions field - type(vector_field), intent(in) :: X - ! The number of the current element - integer, intent(in) :: ele + function dot_integral_element_vector(fieldA, fieldB, X, ele) result& + & (integral) + !!< Return the integral of dot(fieldA, fieldB) over the element ele + type(vector_field), intent(in) :: fieldA, fieldB + ! positions field + type(vector_field), intent(in) :: X + ! The number of the current element + integer, intent(in) :: ele - real :: integral + real :: integral - real, dimension(ele_ngi(fieldA, ele)) :: detwei + real, dimension(ele_ngi(fieldA, ele)) :: detwei - call transform_to_physical(X, ele, detwei=detwei) + call transform_to_physical(X, ele, detwei=detwei) - integral = sum(sum(ele_val_at_quad(fieldA, ele) * ele_val_at_quad(fieldB, ele), dim=1)*detwei) + integral = sum(sum(ele_val_at_quad(fieldA, ele) * ele_val_at_quad(fieldB, ele), dim=1)*detwei) - end function dot_integral_element_vector + end function dot_integral_element_vector - function integral_element_scalars(fields, X, ele) result& - & (integral) - !!< Return the integral of the product of fields over the given element. - real :: integral - ! Element values at the nodes. - type(scalar_field_pointer), dimension(:), intent(in) :: fields - ! The positions of the nodes in this element. - type(vector_field), intent(in) :: X - ! The number of the current element - integer, intent(in) :: ele + function integral_element_scalars(fields, X, ele) result& + & (integral) + !!< Return the integral of the product of fields over the given element. + real :: integral + ! Element values at the nodes. + type(scalar_field_pointer), dimension(:), intent(in) :: fields + ! The positions of the nodes in this element. + type(vector_field), intent(in) :: X + ! The number of the current element + integer, intent(in) :: ele - integer :: s - real, dimension(ele_ngi(fields(1)%ptr, ele)) :: detwei - real, dimension(ele_ngi(fields(1)%ptr, ele)) :: product_ele_val_at_quad + integer :: s + real, dimension(ele_ngi(fields(1)%ptr, ele)) :: detwei + real, dimension(ele_ngi(fields(1)%ptr, ele)) :: product_ele_val_at_quad - call transform_to_physical(X, ele, detwei=detwei) + call transform_to_physical(X, ele, detwei=detwei) - do s = 1,size(fields) + do s = 1,size(fields) - assert(ele_ngi(X,ele) == ele_ngi(fields(s)%ptr,ele)) + assert(ele_ngi(X,ele) == ele_ngi(fields(s)%ptr,ele)) - if (s == 1) then + if (s == 1) then - product_ele_val_at_quad = ele_val_at_quad(fields(s)%ptr, ele) + product_ele_val_at_quad = ele_val_at_quad(fields(s)%ptr, ele) - else + else - product_ele_val_at_quad = product_ele_val_at_quad * & - ele_val_at_quad(fields(s)%ptr, ele) + product_ele_val_at_quad = product_ele_val_at_quad * & + ele_val_at_quad(fields(s)%ptr, ele) - end if + end if - end do + end do - integral=dot_product(product_ele_val_at_quad, detwei) + integral=dot_product(product_ele_val_at_quad, detwei) - end function integral_element_scalars + end function integral_element_scalars !!$ subroutine lump(mass) !!$ !!< lump mass. @@ -944,22 +944,22 @@ end function integral_element_scalars !!$ !!$ end subroutine lump - function lumped(mass) - !!< lumped mass. - real, dimension(:,:), intent(in) :: mass - real, dimension(size(mass,1),size(mass,2)) :: lumped + function lumped(mass) + !!< lumped mass. + real, dimension(:,:), intent(in) :: mass + real, dimension(size(mass,1),size(mass,2)) :: lumped - integer :: i + integer :: i - ! Check that matrix is square. - ASSERT(size(mass,1)==size(mass,2)) + ! Check that matrix is square. + ASSERT(size(mass,1)==size(mass,2)) - lumped=0 + lumped=0 - forall(i=1:size(mass,1)) - lumped(i,i)=sum(mass(i,:)) - end forall + forall(i=1:size(mass,1)) + lumped(i,i)=sum(mass(i,:)) + end forall - end function lumped + end function lumped end module fetools diff --git a/femtools/Field_Options.F90 b/femtools/Field_Options.F90 index 8fc17ebd9f..8fcb2edced 100644 --- a/femtools/Field_Options.F90 +++ b/femtools/Field_Options.F90 @@ -54,17 +54,17 @@ module field_options interface interpolate_field module procedure interpolate_field_scalar, interpolate_field_vector, & - & interpolate_field_tensor, interpolate_options + & interpolate_field_tensor, interpolate_options end interface interface needs_initial_mesh module procedure needs_initial_mesh_scalar, needs_initial_mesh_vector, & - & needs_initial_mesh_tensor, interpolate_options + & needs_initial_mesh_tensor, interpolate_options end interface interface constant_field module procedure constant_field_scalar, constant_field_vector, & - & constant_field_tensor + & constant_field_tensor end interface interface isotropic_field @@ -86,1347 +86,1347 @@ module field_options private public :: complete_mesh_path, complete_field_path, & - & get_external_mesh, adaptivity_options, print_children, & - & get_coordinate_field, select_fields_to_interpolate, & - & find_mesh_to_adapt, & - & adaptivity_bounds, find_linear_parent_mesh, & - & interpolate_field, convergence_norm_integer, & - & do_not_recalculate, needs_initial_mesh, & - & get_external_coordinate_field, collect_fields_by_mesh, & - & equation_type_index, field_options_check_options, & - & constant_field, isotropic_field, diagonal_field, & - & extract_pressure_mesh, extract_velocity_mesh, & - & postprocess_periodic_mesh, get_diagnostic_coordinate_field, & - & get_nodal_coordinate_field, extract_prognostic_pressure, & - & extract_prognostic_velocity, remove_non_extruded_mesh_options - - integer, parameter, public :: FIELD_EQUATION_UNKNOWN = 0, & - FIELD_EQUATION_ADVECTIONDIFFUSION = 1, & - FIELD_EQUATION_CONSERVATIONOFMASS = 2, & - FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS = 3, & - FIELD_EQUATION_INTERNALENERGY = 4, & - FIELD_EQUATION_HEATTRANSFER = 5, & - FIELD_EQUATION_ELECTRICALPOTENTIAL = 6, & - FIELD_EQUATION_KEPSILON = 7 + & get_external_mesh, adaptivity_options, print_children, & + & get_coordinate_field, select_fields_to_interpolate, & + & find_mesh_to_adapt, & + & adaptivity_bounds, find_linear_parent_mesh, & + & interpolate_field, convergence_norm_integer, & + & do_not_recalculate, needs_initial_mesh, & + & get_external_coordinate_field, collect_fields_by_mesh, & + & equation_type_index, field_options_check_options, & + & constant_field, isotropic_field, diagonal_field, & + & extract_pressure_mesh, extract_velocity_mesh, & + & postprocess_periodic_mesh, get_diagnostic_coordinate_field, & + & get_nodal_coordinate_field, extract_prognostic_pressure, & + & extract_prognostic_velocity, remove_non_extruded_mesh_options + + integer, parameter, public :: FIELD_EQUATION_UNKNOWN = 0, & + FIELD_EQUATION_ADVECTIONDIFFUSION = 1, & + FIELD_EQUATION_CONSERVATIONOFMASS = 2, & + FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS = 3, & + FIELD_EQUATION_INTERNALENERGY = 4, & + FIELD_EQUATION_HEATTRANSFER = 5, & + FIELD_EQUATION_ELECTRICALPOTENTIAL = 6, & + FIELD_EQUATION_KEPSILON = 7 contains - recursive subroutine print_children(path) + recursive subroutine print_children(path) - implicit none + implicit none - character(len=*), intent(in)::path - character(len=OPTION_PATH_LEN)::name, child_name - integer :: i, nchildren + character(len=*), intent(in)::path + character(len=OPTION_PATH_LEN)::name, child_name + integer :: i, nchildren - name = " " - child_name = " " + name = " " + child_name = " " - call get_number_of_children(path, nchildren) - print *, trim(path), ": number of children: ", nchildren - if(nchildren==0) return - do i=0, nchildren-1 - call get_child_name(path, i, name) - print*, trim(path), " contains ", trim(name) - child_name=path//"/"//trim(name) - call print_children(trim(child_name)) - end do + call get_number_of_children(path, nchildren) + print *, trim(path), ": number of children: ", nchildren + if(nchildren==0) return + do i=0, nchildren-1 + call get_child_name(path, i, name) + print*, trim(path), " contains ", trim(name) + child_name=path//"/"//trim(name) + call print_children(trim(child_name)) + end do - end subroutine print_children + end subroutine print_children - function complete_mesh_path(path, stat) - !!< Auxillary function to add from_file/from_mesh to meshion path. + function complete_mesh_path(path, stat) + !!< Auxillary function to add from_file/from_mesh to meshion path. - character(len = *), intent(in) :: path - integer, optional, intent(out) :: stat + character(len = *), intent(in) :: path + integer, optional, intent(out) :: stat - character(len = OPTION_PATH_LEN) :: complete_mesh_path + character(len = OPTION_PATH_LEN) :: complete_mesh_path - if(present(stat)) then - stat = 0 - end if + if(present(stat)) then + stat = 0 + end if - if(have_option(trim(path) // "/from_mesh")) then - complete_mesh_path = trim(path) // "/from_mesh" - else if(have_option(trim(path) // "/from_file")) then - complete_mesh_path = trim(path) // "/from_file" - else if(present(stat)) then - stat = 1 - else - ewrite(-1, *) "For mesh option path: " // trim(path) - FLAbort("Unknown mesh type or wrong mesh option path") - end if + if(have_option(trim(path) // "/from_mesh")) then + complete_mesh_path = trim(path) // "/from_mesh" + else if(have_option(trim(path) // "/from_file")) then + complete_mesh_path = trim(path) // "/from_file" + else if(present(stat)) then + stat = 1 + else + ewrite(-1, *) "For mesh option path: " // trim(path) + FLAbort("Unknown mesh type or wrong mesh option path") + end if - end function complete_mesh_path + end function complete_mesh_path character(len=OPTION_PATH_LEN) function complete_field_path(path, name, stat) - !!< Auxillary function to add prognostic/diagnostic/prescribed - !!< to field option path. This version flaborts as opposed to the one - !!< in populate_state_module. + !!< Auxillary function to add prognostic/diagnostic/prescribed + !!< to field option path. This version flaborts as opposed to the one + !!< in populate_state_module. - character(len=*), intent(in) :: path - character(len=*), intent(in), optional :: name - integer, intent(out), optional :: stat + character(len=*), intent(in) :: path + character(len=*), intent(in), optional :: name + integer, intent(out), optional :: stat - if (present(stat)) then - stat = 0 - end if - - if (have_option(trim(path) // "/prognostic")) then + if (present(stat)) then + stat = 0 + end if - complete_field_path=trim(path) // "/prognostic" + if (have_option(trim(path) // "/prognostic")) then - else if (have_option(trim(path) // "/diagnostic")) then + complete_field_path=trim(path) // "/prognostic" - complete_field_path=trim(path) // "/diagnostic" + else if (have_option(trim(path) // "/diagnostic")) then - else if (have_option(trim(path) // "/prescribed")) then + complete_field_path=trim(path) // "/diagnostic" - complete_field_path=trim(path) // "/prescribed" + else if (have_option(trim(path) // "/prescribed")) then - else if (have_option(trim(path) // "/aliased")) then + complete_field_path=trim(path) // "/prescribed" - complete_field_path=trim(path) // "/aliased" + else if (have_option(trim(path) // "/aliased")) then - else + complete_field_path=trim(path) // "/aliased" - if (present(stat)) then - stat = 1 - complete_field_path=trim(path) else - ewrite(0,*) "Error completing field path given the option path:", trim(path) - if (present(name)) then - ewrite(0,*) "for field name:", trim(name) - else - ewrite(0,*) "Note field name not available. Modify the call to include this for a more informative error message." - end if - FLAbort("Error: unknown field type or wrong field option path.") + + if (present(stat)) then + stat = 1 + complete_field_path=trim(path) + else + ewrite(0,*) "Error completing field path given the option path:", trim(path) + if (present(name)) then + ewrite(0,*) "for field name:", trim(name) + else + ewrite(0,*) "Note field name not available. Modify the call to include this for a more informative error message." + end if + FLAbort("Error: unknown field type or wrong field option path.") + end if end if - end if - - end function complete_field_path - - function make_coordinate_field(state, target_mesh) result (to_position) - !!< Creates a coordinate field interpolated on the target_mesh - !!< If we're on the sphere and the super parametric option is selected - !!< the coordinate field is "bended" onto the sphere. This routine - !!< always creates a field with a new reference (even if we simply return - !!< a coordinate field that is already in state), so it has to be deallocated - !!< after its use. - type(vector_field):: to_position - type(state_type), intent(inout):: state - type(mesh_type), intent(in):: target_mesh - - - integer, parameter:: kloc(1:6)=(/ 2, 4, 5, 7, 8, 9 /) - integer, parameter:: iloc(1:6)=(/ 1, 1, 3, 1, 3, 6 /) - integer, parameter:: jloc(1:6)=(/ 3, 6, 6, 10, 10, 10 /) - - type(vector_field), pointer:: position - type(element_type), pointer:: target_shape - real radi, radj - integer ele, k - - position => extract_vector_field(state, "Coordinate") - if (position%mesh==target_mesh) then - to_position=position - ! make this a new reference - call incref(to_position) - else - ! if position is not on the same mesh as the target_mesh - call allocate(to_position, position%dim, target_mesh, & - name=trim(target_mesh%name)//'Coordinate') - call remap_field(position, to_position) - end if - - target_shape => ele_shape(target_mesh, 1) - if (target_shape%degree==2 .and. have_option( & - '/geometry/spherical_earth/quadratic_superparametric_mapping')) then - - - do ele=1, element_count(to_position) - do k=1, 6 - radi=sqrt(sum(ele_val(to_position, iloc(k))**2)) - radj=sqrt(sum(ele_val(to_position, jloc(k))**2)) - end do - end do - - end if - - end function make_coordinate_field - - subroutine adaptivity_bounds(state, minch, maxch, name) - type(state_type), intent(inout) :: state - real, intent(in) :: minch, maxch - type(tensor_field) :: min_eigen, max_eigen - type(mesh_type), pointer :: mesh - character(len=*), intent(in), optional :: name - integer :: dim - - if (present(name)) then - mesh => extract_mesh(state, trim(name)) - else - mesh => extract_mesh(state, "Mesh") - end if - dim = mesh_dim(mesh) - call allocate(min_eigen, mesh, "MinMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) - call allocate(max_eigen, mesh, "MaxMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) - - call set(min_eigen, get_matrix_identity(dim) * eigenvalue_from_edge_length(maxch)) - call set(max_eigen, get_matrix_identity(dim) * eigenvalue_from_edge_length(minch)) - - call insert(state, min_eigen, "MinMetricEigenbound") - call insert(state, max_eigen, "MaxMetricEigenbound") - - call deallocate(min_eigen) - call deallocate(max_eigen) - end subroutine adaptivity_bounds - - subroutine adaptivity_options_scalar(state, field, weight, relative, min_psi) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: field - real, intent(in) :: weight - logical, intent(in) :: relative - type(scalar_field) :: adaptivity_weight - real, intent(in), optional :: min_psi - integer :: stat - - field%option_path = "/material_phase[0]/" // field%name - if (relative) then - call add_option(trim(field%option_path) // "/virtual/adaptivity_options/relative_measure", stat=stat) - call set_option(trim(field%option_path) // "/virtual/adaptivity_option& - &s/relative_measure/tolerance", min_psi, stat=stat) - else - call add_option(trim(field%option_path) // "/virtual/adaptivity_options/absolute_measure", stat=stat) - end if - - call allocate(adaptivity_weight, field%mesh, trim(field%name) // "InterpolationErrorBound", FIELD_TYPE_CONSTANT) - call set(adaptivity_weight, weight) - call insert(state, adaptivity_weight, trim(field%name) // "InterpolationErrorBound") - call deallocate(adaptivity_weight) - - end subroutine adaptivity_options_scalar - - subroutine adaptivity_options_vector(state, field, weight, relative, min_psi) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: field - real, intent(in), dimension(:) :: weight - logical, intent(in) :: relative - type(vector_field) :: adaptivity_weight - real, intent(in), optional, dimension(:) :: min_psi - integer :: stat - - field%option_path = "/material_phase[0]/" // field%name - if (relative) then - call add_option(trim(field%option_path) // "/virtual/adaptivity_options/relative_measure", stat=stat) - call set_option(trim(field%option_path) // "/virtual/adaptivity_options/relative_measure/tolerance", min_psi, stat=stat) - else - call add_option(trim(field%option_path) // "/virtual/adaptivity_options/absolute_measure", stat=stat) - end if - - call allocate(adaptivity_weight, field%dim, field%mesh, trim(field%name) // "InterpolationErrorBound", FIELD_TYPE_CONSTANT) - call set(adaptivity_weight, weight) - call insert(state, adaptivity_weight, trim(field%name) // "InterpolationErrorBound") - call deallocate(adaptivity_weight) - - end subroutine adaptivity_options_vector - - function get_external_mesh(states, external_mesh_name) result(mesh) - type(state_type), dimension(:), intent(in) :: states - type(mesh_type), pointer:: mesh - integer :: nmeshes, i - character(len=OPTION_PATH_LEN) :: mesh_path - character(len=FIELD_NAME_LEN) linear_mesh_name - character(len=FIELD_NAME_LEN), intent(in), optional :: external_mesh_name - - if (present(external_mesh_name)) then - mesh => extract_mesh(states(1), trim(external_mesh_name)) - else - nmeshes=option_count("/geometry/mesh") - do i = 0, nmeshes-1 - mesh_path="/geometry/mesh["//int2str(i)//"]" - if(have_option(trim(mesh_path)//"/from_file")) exit - end do - if (i>nmeshes-1) then - FLExit("Options tree does not have external mesh") + + end function complete_field_path + + function make_coordinate_field(state, target_mesh) result (to_position) + !!< Creates a coordinate field interpolated on the target_mesh + !!< If we're on the sphere and the super parametric option is selected + !!< the coordinate field is "bended" onto the sphere. This routine + !!< always creates a field with a new reference (even if we simply return + !!< a coordinate field that is already in state), so it has to be deallocated + !!< after its use. + type(vector_field):: to_position + type(state_type), intent(inout):: state + type(mesh_type), intent(in):: target_mesh + + + integer, parameter:: kloc(1:6)=(/ 2, 4, 5, 7, 8, 9 /) + integer, parameter:: iloc(1:6)=(/ 1, 1, 3, 1, 3, 6 /) + integer, parameter:: jloc(1:6)=(/ 3, 6, 6, 10, 10, 10 /) + + type(vector_field), pointer:: position + type(element_type), pointer:: target_shape + real radi, radj + integer ele, k + + position => extract_vector_field(state, "Coordinate") + if (position%mesh==target_mesh) then + to_position=position + ! make this a new reference + call incref(to_position) + else + ! if position is not on the same mesh as the target_mesh + call allocate(to_position, position%dim, target_mesh, & + name=trim(target_mesh%name)//'Coordinate') + call remap_field(position, to_position) end if - call get_option(trim(mesh_path)//"/name", linear_mesh_name) - ! We'll assume this one is the linear mesh - ewrite(2,*) "Assuming linear mesh is: " // trim(linear_mesh_name) - mesh => extract_mesh(states(1), linear_mesh_name) - end if - - end function get_external_mesh - - function get_external_coordinate_field(state, mesh) result (positions) - !!< returns a coordinate field called trim(mesh%name)//"Coordinate" - !!< pulled from state if present, otherwise it returns the "Coordinate" field - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh - type(vector_field), pointer :: positions - - if (has_vector_field(state, trim(mesh%name)//"Coordinate")) then - positions=>extract_vector_field(state, trim(mesh%name)//"Coordinate") - elseif (has_vector_field(state, "IteratedCoordinate")) then - ! if the mesh is moving it's necessary to evaluate diagnostics on the most - ! up to date coordinate. - ! if the mesh is not moving this is just aliased to Coordinate anyway. - positions=>extract_vector_field(state, "IteratedCoordinate") - else - positions=>extract_vector_field(state, "Coordinate") - end if - - end function get_external_coordinate_field - - function get_diagnostic_coordinate_field(state, mesh) result (positions) - !!< Returns a coordinate field suitable for finite element integration. - !!< In most cases this will be the "Coordinate" field. In case of - !!< external meshes with the exclude_from_mesh_adaptivity_option, or in - !!< the case of the horizontal mesh in an extruded mesh setup, it will - !!< return the positions field stored for that mesh in state. - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh - type(vector_field) positions - - type(vector_field), pointer:: coordinate_field - type(mesh_type), pointer:: mesh_i - character(len=FIELD_NAME_LEN):: mesh_name - integer:: i - - if (have_option(trim(mesh%option_path)//"/exclude_from_mesh_adaptivity")) then - positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") - call incref(positions) - else - coordinate_field => extract_vector_field(state, "Coordinate") - if (mesh_dim(mesh)+1==mesh_dim(coordinate_field)) then - ! coordinate is extruded, mesh is a horizontal mesh - if (mesh_periodic(mesh)) then - ! search for the unperiodic mesh derived from it - do i=1, mesh_count(state) - mesh_i => extract_mesh(state, i) - if (have_option(trim(mesh_i%option_path)//"/from_mesh/mesh[0]/name") & - .and. have_option(trim(mesh_i%option_path)// & - "/from_mesh/periodic_boundary_conditions/remove_periodicity")) then - call get_option(trim(mesh_i%option_path)//"/name", mesh_name) - positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") - call incref(positions) - return - end if + + target_shape => ele_shape(target_mesh, 1) + if (target_shape%degree==2 .and. have_option( & + '/geometry/spherical_earth/quadratic_superparametric_mapping')) then + + + do ele=1, element_count(to_position) + do k=1, 6 + radi=sqrt(sum(ele_val(to_position, iloc(k))**2)) + radj=sqrt(sum(ele_val(to_position, jloc(k))**2)) end do - ! no mesh derived from it - ewrite(0,*) "Can't find a suitable unperiodic coordinate field for periodic mesh ", & - trim(mesh%name) - ewrite(0,*) "This probably means the operation you want to do on this field "//& - &"is not supported for a horizontal periodic mesh" - FLExit("No suitable coordinate field found.") - else - positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") - call incref(positions) + end do + + end if + + end function make_coordinate_field + + subroutine adaptivity_bounds(state, minch, maxch, name) + type(state_type), intent(inout) :: state + real, intent(in) :: minch, maxch + type(tensor_field) :: min_eigen, max_eigen + type(mesh_type), pointer :: mesh + character(len=*), intent(in), optional :: name + integer :: dim + + if (present(name)) then + mesh => extract_mesh(state, trim(name)) + else + mesh => extract_mesh(state, "Mesh") + end if + dim = mesh_dim(mesh) + call allocate(min_eigen, mesh, "MinMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) + call allocate(max_eigen, mesh, "MaxMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) + + call set(min_eigen, get_matrix_identity(dim) * eigenvalue_from_edge_length(maxch)) + call set(max_eigen, get_matrix_identity(dim) * eigenvalue_from_edge_length(minch)) + + call insert(state, min_eigen, "MinMetricEigenbound") + call insert(state, max_eigen, "MaxMetricEigenbound") + + call deallocate(min_eigen) + call deallocate(max_eigen) + end subroutine adaptivity_bounds + + subroutine adaptivity_options_scalar(state, field, weight, relative, min_psi) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: field + real, intent(in) :: weight + logical, intent(in) :: relative + type(scalar_field) :: adaptivity_weight + real, intent(in), optional :: min_psi + integer :: stat + + field%option_path = "/material_phase[0]/" // field%name + if (relative) then + call add_option(trim(field%option_path) // "/virtual/adaptivity_options/relative_measure", stat=stat) + call set_option(trim(field%option_path) // "/virtual/adaptivity_option& + &s/relative_measure/tolerance", min_psi, stat=stat) + else + call add_option(trim(field%option_path) // "/virtual/adaptivity_options/absolute_measure", stat=stat) + end if + + call allocate(adaptivity_weight, field%mesh, trim(field%name) // "InterpolationErrorBound", FIELD_TYPE_CONSTANT) + call set(adaptivity_weight, weight) + call insert(state, adaptivity_weight, trim(field%name) // "InterpolationErrorBound") + call deallocate(adaptivity_weight) + + end subroutine adaptivity_options_scalar + + subroutine adaptivity_options_vector(state, field, weight, relative, min_psi) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: field + real, intent(in), dimension(:) :: weight + logical, intent(in) :: relative + type(vector_field) :: adaptivity_weight + real, intent(in), optional, dimension(:) :: min_psi + integer :: stat + + field%option_path = "/material_phase[0]/" // field%name + if (relative) then + call add_option(trim(field%option_path) // "/virtual/adaptivity_options/relative_measure", stat=stat) + call set_option(trim(field%option_path) // "/virtual/adaptivity_options/relative_measure/tolerance", min_psi, stat=stat) + else + call add_option(trim(field%option_path) // "/virtual/adaptivity_options/absolute_measure", stat=stat) + end if + + call allocate(adaptivity_weight, field%dim, field%mesh, trim(field%name) // "InterpolationErrorBound", FIELD_TYPE_CONSTANT) + call set(adaptivity_weight, weight) + call insert(state, adaptivity_weight, trim(field%name) // "InterpolationErrorBound") + call deallocate(adaptivity_weight) + + end subroutine adaptivity_options_vector + + function get_external_mesh(states, external_mesh_name) result(mesh) + type(state_type), dimension(:), intent(in) :: states + type(mesh_type), pointer:: mesh + integer :: nmeshes, i + character(len=OPTION_PATH_LEN) :: mesh_path + character(len=FIELD_NAME_LEN) linear_mesh_name + character(len=FIELD_NAME_LEN), intent(in), optional :: external_mesh_name + + if (present(external_mesh_name)) then + mesh => extract_mesh(states(1), trim(external_mesh_name)) + else + nmeshes=option_count("/geometry/mesh") + do i = 0, nmeshes-1 + mesh_path="/geometry/mesh["//int2str(i)//"]" + if(have_option(trim(mesh_path)//"/from_file")) exit + end do + if (i>nmeshes-1) then + FLExit("Options tree does not have external mesh") end if - else if (element_count(coordinate_field)==element_count(mesh) .and. & - mesh_dim(coordinate_field)==mesh_dim(mesh)) then - positions=coordinate_field + call get_option(trim(mesh_path)//"/name", linear_mesh_name) + ! We'll assume this one is the linear mesh + ewrite(2,*) "Assuming linear mesh is: " // trim(linear_mesh_name) + mesh => extract_mesh(states(1), linear_mesh_name) + end if + + end function get_external_mesh + + function get_external_coordinate_field(state, mesh) result (positions) + !!< returns a coordinate field called trim(mesh%name)//"Coordinate" + !!< pulled from state if present, otherwise it returns the "Coordinate" field + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh + type(vector_field), pointer :: positions + + if (has_vector_field(state, trim(mesh%name)//"Coordinate")) then + positions=>extract_vector_field(state, trim(mesh%name)//"Coordinate") + elseif (has_vector_field(state, "IteratedCoordinate")) then + ! if the mesh is moving it's necessary to evaluate diagnostics on the most + ! up to date coordinate. + ! if the mesh is not moving this is just aliased to Coordinate anyway. + positions=>extract_vector_field(state, "IteratedCoordinate") + else + positions=>extract_vector_field(state, "Coordinate") + end if + + end function get_external_coordinate_field + + function get_diagnostic_coordinate_field(state, mesh) result (positions) + !!< Returns a coordinate field suitable for finite element integration. + !!< In most cases this will be the "Coordinate" field. In case of + !!< external meshes with the exclude_from_mesh_adaptivity_option, or in + !!< the case of the horizontal mesh in an extruded mesh setup, it will + !!< return the positions field stored for that mesh in state. + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh + type(vector_field) positions + + type(vector_field), pointer:: coordinate_field + type(mesh_type), pointer:: mesh_i + character(len=FIELD_NAME_LEN):: mesh_name + integer:: i + + if (have_option(trim(mesh%option_path)//"/exclude_from_mesh_adaptivity")) then + positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") call incref(positions) else - ewrite(0,*) "Can't find a suitable coordinate field for mesh ", & - trim(mesh%name) - ewrite(0,*) "This probably means the operation you want to do is not supported for this mesh" - FLExit("No suitable coordinate field found.") + coordinate_field => extract_vector_field(state, "Coordinate") + if (mesh_dim(mesh)+1==mesh_dim(coordinate_field)) then + ! coordinate is extruded, mesh is a horizontal mesh + if (mesh_periodic(mesh)) then + ! search for the unperiodic mesh derived from it + do i=1, mesh_count(state) + mesh_i => extract_mesh(state, i) + if (have_option(trim(mesh_i%option_path)//"/from_mesh/mesh[0]/name") & + .and. have_option(trim(mesh_i%option_path)// & + "/from_mesh/periodic_boundary_conditions/remove_periodicity")) then + call get_option(trim(mesh_i%option_path)//"/name", mesh_name) + positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") + call incref(positions) + return + end if + end do + ! no mesh derived from it + ewrite(0,*) "Can't find a suitable unperiodic coordinate field for periodic mesh ", & + trim(mesh%name) + ewrite(0,*) "This probably means the operation you want to do on this field "//& + &"is not supported for a horizontal periodic mesh" + FLExit("No suitable coordinate field found.") + else + positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") + call incref(positions) + end if + else if (element_count(coordinate_field)==element_count(mesh) .and. & + mesh_dim(coordinate_field)==mesh_dim(mesh)) then + positions=coordinate_field + call incref(positions) + else + ewrite(0,*) "Can't find a suitable coordinate field for mesh ", & + trim(mesh%name) + ewrite(0,*) "This probably means the operation you want to do is not supported for this mesh" + FLExit("No suitable coordinate field found.") + end if end if - end if - - end function get_diagnostic_coordinate_field - - function get_coordinate_field(state, mesh) result (positions) - !!< Returns a coordinate field for the given mesh, that has the same - !!< shape (and thus number of nodes) in each element. If the mesh is - !!< discontinuous or periodic however, the positions%mesh is not - !!< necessarily the same as 'mesh'. The returned positions field is - !!< never periodic and thus provides valid coordinates for each element - !!< individually. - !!< As the polynomial degree of the returned coordinates is the same as - !!< that of the input mesh, it won't return a superparametric - !!< "Coordinate" field. This routine should therefore only be used if - !!< there is an algorithmic reason to have the positions on the same - !!< nodes as 'mesh' in each element. - !!< NOTE: The returned vector_field should always be deallocated - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh - type(vector_field) positions - - type(vector_field), pointer:: coordinate_field - type(mesh_type) :: unperiodic_mesh - logical:: can_remap_from_coordinate_field - - if (have_option(trim(mesh%option_path)//"/exclude_from_mesh_adaptivity").and.& - has_vector_field(state, trim(mesh%name)//"Coordinate")) then - positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") - call incref(positions) - else - coordinate_field => extract_vector_field(state, "Coordinate") - can_remap_from_coordinate_field = & - element_count(coordinate_field)==element_count(mesh) .and. & - mesh_dim(coordinate_field)==mesh_dim(mesh) - if (mesh_dim(mesh)+1==mesh_dim(coordinate_field)) then - ! coordinate is extruded, mesh is a horizontal mesh - if (mesh_periodic(mesh)) call give_up + + end function get_diagnostic_coordinate_field + + function get_coordinate_field(state, mesh) result (positions) + !!< Returns a coordinate field for the given mesh, that has the same + !!< shape (and thus number of nodes) in each element. If the mesh is + !!< discontinuous or periodic however, the positions%mesh is not + !!< necessarily the same as 'mesh'. The returned positions field is + !!< never periodic and thus provides valid coordinates for each element + !!< individually. + !!< As the polynomial degree of the returned coordinates is the same as + !!< that of the input mesh, it won't return a superparametric + !!< "Coordinate" field. This routine should therefore only be used if + !!< there is an algorithmic reason to have the positions on the same + !!< nodes as 'mesh' in each element. + !!< NOTE: The returned vector_field should always be deallocated + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh + type(vector_field) positions + + type(vector_field), pointer:: coordinate_field + type(mesh_type) :: unperiodic_mesh + logical:: can_remap_from_coordinate_field + + if (have_option(trim(mesh%option_path)//"/exclude_from_mesh_adaptivity").and.& + has_vector_field(state, trim(mesh%name)//"Coordinate")) then positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") call incref(positions) - else if (mesh_periodic(mesh)) then - ! never return periodic coordinates - if((coordinate_field%mesh%shape==mesh%shape).and.& - (coordinate_field%mesh%elements==mesh%elements).and.& - (coordinate_field%mesh%continuity==mesh%continuity)) then - ! meshes are sufficiently similar that you shouldn't - ! need to remake the mesh (hopefully) + else + coordinate_field => extract_vector_field(state, "Coordinate") + can_remap_from_coordinate_field = & + element_count(coordinate_field)==element_count(mesh) .and. & + mesh_dim(coordinate_field)==mesh_dim(mesh) + if (mesh_dim(mesh)+1==mesh_dim(coordinate_field)) then + ! coordinate is extruded, mesh is a horizontal mesh + if (mesh_periodic(mesh)) call give_up + positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") + call incref(positions) + else if (mesh_periodic(mesh)) then + ! never return periodic coordinates + if((coordinate_field%mesh%shape==mesh%shape).and.& + (coordinate_field%mesh%elements==mesh%elements).and.& + (coordinate_field%mesh%continuity==mesh%continuity)) then + ! meshes are sufficiently similar that you shouldn't + ! need to remake the mesh (hopefully) + positions=coordinate_field + call incref(positions) + else if (can_remap_from_coordinate_field) then + ! meshes are different in an important way so + ! remake the mesh using the shape and continuity + ! of the desired mesh (but not periodic) + unperiodic_mesh=make_mesh(coordinate_field%mesh, mesh%shape, mesh%continuity, & + name="UnPeriodicCoordinateMesh") + call allocate(positions, coordinate_field%dim, unperiodic_mesh, & + name="Coordinate") + call remap_field(coordinate_field, positions) + call deallocate(unperiodic_mesh) + else + call give_up() + end if + elseif (has_vector_field(state, trim(mesh%name)//"Coordinate")) then + positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") + call incref(positions) + elseif (coordinate_field%mesh==mesh) then positions=coordinate_field call incref(positions) else if (can_remap_from_coordinate_field) then - ! meshes are different in an important way so - ! remake the mesh using the shape and continuity - ! of the desired mesh (but not periodic) - unperiodic_mesh=make_mesh(coordinate_field%mesh, mesh%shape, mesh%continuity, & - name="UnPeriodicCoordinateMesh") - call allocate(positions, coordinate_field%dim, unperiodic_mesh, & - name="Coordinate") + call allocate(positions, coordinate_field%dim, mesh, name="Coordinate") call remap_field(coordinate_field, positions) - call deallocate(unperiodic_mesh) else call give_up() end if - elseif (has_vector_field(state, trim(mesh%name)//"Coordinate")) then + end if + + contains + + subroutine give_up() + + ewrite(0,*) "Can't find a suitable coordinate field for mesh ", & + trim(mesh%name) + ewrite(0,*) "This probably means the operation you want to do is not "//& + &"supported for this mesh" + FLExit("No suitable coordinate field found.") + + end subroutine give_up + + end function get_coordinate_field + + function get_nodal_coordinate_field(state, mesh) result (positions) + !!< Returns a coordinate field on the mesh provided. For periodic + !!< meshes the nodes on the periodic boundary will get the original + !!< position of the aliased nodes. The returned field is not suitable + !!< for finite element integration. + !!< NOTE: The returned vector_field should always be deallocated + type(state_type), intent(in):: state + type(mesh_type), intent(in):: mesh + type(vector_field) positions + + type(vector_field), pointer:: coordinate_field + integer:: stat + + if (has_vector_field(state, trim(mesh%name)//"Coordinate")) then positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") call incref(positions) - elseif (coordinate_field%mesh==mesh) then - positions=coordinate_field - call incref(positions) - else if (can_remap_from_coordinate_field) then - call allocate(positions, coordinate_field%dim, mesh, name="Coordinate") - call remap_field(coordinate_field, positions) else - call give_up() - end if - end if - - contains - - subroutine give_up() - - ewrite(0,*) "Can't find a suitable coordinate field for mesh ", & - trim(mesh%name) - ewrite(0,*) "This probably means the operation you want to do is not "//& - &"supported for this mesh" - FLExit("No suitable coordinate field found.") - - end subroutine give_up - - end function get_coordinate_field - - function get_nodal_coordinate_field(state, mesh) result (positions) - !!< Returns a coordinate field on the mesh provided. For periodic - !!< meshes the nodes on the periodic boundary will get the original - !!< position of the aliased nodes. The returned field is not suitable - !!< for finite element integration. - !!< NOTE: The returned vector_field should always be deallocated - type(state_type), intent(in):: state - type(mesh_type), intent(in):: mesh - type(vector_field) positions - - type(vector_field), pointer:: coordinate_field - integer:: stat - - if (has_vector_field(state, trim(mesh%name)//"Coordinate")) then - positions=extract_vector_field(state, trim(mesh%name)//"Coordinate") - call incref(positions) - else - coordinate_field => extract_vector_field(state, "Coordinate") - if (coordinate_field%mesh==mesh) then - positions=coordinate_field - call incref(positions) - else if (element_count(coordinate_field)==element_count(mesh) .and. & - mesh_dim(coordinate_field)==mesh_dim(mesh)) then - ! can remap from coordinate field - call allocate(positions, coordinate_field%dim, mesh, name="Coordinate") - - if (mesh_periodic(mesh) .and. continuity(mesh)>=0) then - call remap_field(coordinate_field, positions, stat=stat) - if (stat/=REMAP_ERR_UNPERIODIC_PERIODIC) then - FLAbort("Error remapping coordinate field") + coordinate_field => extract_vector_field(state, "Coordinate") + if (coordinate_field%mesh==mesh) then + positions=coordinate_field + call incref(positions) + else if (element_count(coordinate_field)==element_count(mesh) .and. & + mesh_dim(coordinate_field)==mesh_dim(mesh)) then + ! can remap from coordinate field + call allocate(positions, coordinate_field%dim, mesh, name="Coordinate") + + if (mesh_periodic(mesh) .and. continuity(mesh)>=0) then + call remap_field(coordinate_field, positions, stat=stat) + if (stat/=REMAP_ERR_UNPERIODIC_PERIODIC) then + FLAbort("Error remapping coordinate field") + end if + ! make sure the remapped coordinates adhere to the convention + ! of storing the aliased from position in the periodic boundary nodes + call postprocess_periodic_mesh(coordinate_field%mesh, coordinate_field, & + mesh, positions) + else + call remap_field(coordinate_field, positions) end if - ! make sure the remapped coordinates adhere to the convention - ! of storing the aliased from position in the periodic boundary nodes - call postprocess_periodic_mesh(coordinate_field%mesh, coordinate_field, & - mesh, positions) else - call remap_field(coordinate_field, positions) + ewrite(0,*) "Can't find a suitable coordinate field for mesh ", & + trim(mesh%name) + ewrite(0,*) "This probably means the operation you want to do is not& + &supported for this mesh" + FLExit("No suitable coordinate field found.") end if - else - ewrite(0,*) "Can't find a suitable coordinate field for mesh ", & - trim(mesh%name) - ewrite(0,*) "This probably means the operation you want to do is not& - &supported for this mesh" - FLExit("No suitable coordinate field found.") end if - end if - - end function get_nodal_coordinate_field - - function extract_pressure_mesh_from_state(state, stat) - type(state_type), intent(in):: state - type(mesh_type), pointer:: extract_pressure_mesh_from_state - integer, optional, intent(out):: stat - - type(scalar_field), pointer:: p - - p => extract_scalar_field(state, "Pressure", stat=stat) - if (associated(p)) then - extract_pressure_mesh_from_state => p%mesh - else - nullify(extract_pressure_mesh_from_state) - end if - - end function extract_pressure_mesh_from_state - - function extract_pressure_mesh_from_any_state(states, stat) - type(state_type), dimension(:), intent(in):: states - type(mesh_type), pointer:: extract_pressure_mesh_from_any_state - integer, optional, intent(out):: stat - - type(scalar_field), pointer:: p - - p => extract_scalar_field(states, "Pressure", stat=stat) - if (associated(p)) then - extract_pressure_mesh_from_any_state => p%mesh - else - nullify(extract_pressure_mesh_from_any_state) - end if - - end function extract_pressure_mesh_from_any_state - - function extract_velocity_mesh_from_state(state, stat) - type(state_type), intent(in):: state - type(mesh_type), pointer:: extract_velocity_mesh_from_state - integer, optional, intent(out):: stat - - type(vector_field), pointer:: u - - u => extract_vector_field(state, "Velocity", stat=stat) - if (associated(u)) then - extract_velocity_mesh_from_state => u%mesh - else - nullify(extract_velocity_mesh_from_state) - end if - - end function extract_velocity_mesh_from_state - - function extract_velocity_mesh_from_any_state(states, stat) - type(state_type), dimension(:), intent(in):: states - type(mesh_type), pointer:: extract_velocity_mesh_from_any_state - integer, optional, intent(out):: stat - - type(vector_field), pointer:: u - - u => extract_vector_field(states, "Velocity", stat=stat) - if (associated(u)) then - extract_velocity_mesh_from_any_state => u%mesh - else - nullify(extract_velocity_mesh_from_any_state) - end if - - end function extract_velocity_mesh_from_any_state - - subroutine select_fields_to_interpolate(state, interpolate_state, no_positions, & - first_time_step) - !!< This routine returns a state that is a selection of the fields - !!< of the input state that should be interpolated after adaptivity - !!< from the old to the new mesh. - !!< Diagnostic are never interpolated, although this could - !!< be useful for diagnostic purposes - again an option may be implemented. - !!< Aliased fields are obviously excluded. - - type(state_type), intent(in):: state - type(state_type), intent(out):: interpolate_state - !! leave out the "Coordinate" field - logical, optional, intent(in) :: no_positions - !! exclude prognostic fields that can be re-initialised (not from_file) - logical, optional, intent(in) :: first_time_step - - integer :: i - type(mesh_type), pointer :: mesh - type(scalar_field), pointer:: sfield => null() - type(vector_field), pointer:: vfield => null() - type(tensor_field), pointer:: tfield => null() - integer :: stat - - interpolate_state%name = state%name - - do i=1, mesh_count(state) - mesh => extract_mesh(state, i) - call insert(interpolate_state, mesh, trim(mesh%name)) - if (.not. present_and_true(no_positions)) then - vfield => extract_vector_field(state, trim(mesh%name) // 'Coordinate', stat=stat) - if (stat == 0) then - call insert(interpolate_state, vfield, trim(mesh%name) // 'Coordinate') - end if + end function get_nodal_coordinate_field + + function extract_pressure_mesh_from_state(state, stat) + type(state_type), intent(in):: state + type(mesh_type), pointer:: extract_pressure_mesh_from_state + integer, optional, intent(out):: stat + + type(scalar_field), pointer:: p + + p => extract_scalar_field(state, "Pressure", stat=stat) + if (associated(p)) then + extract_pressure_mesh_from_state => p%mesh + else + nullify(extract_pressure_mesh_from_state) end if - end do - - ! Select all prognostic and prescribed scalar fields that do not have interpolation - ! disabled. In addition, select diagnostic scalar fields that have interpolation enabled. - do i = 1, scalar_field_count(state) - sfield => extract_scalar_field(state, i) - if (interpolate_field(sfield, first_time_step=first_time_step)) then - ewrite(2,*) 'selecting to interpolate ', trim(sfield%name) - call insert(interpolate_state, sfield, sfield%name) + + end function extract_pressure_mesh_from_state + + function extract_pressure_mesh_from_any_state(states, stat) + type(state_type), dimension(:), intent(in):: states + type(mesh_type), pointer:: extract_pressure_mesh_from_any_state + integer, optional, intent(out):: stat + + type(scalar_field), pointer:: p + + p => extract_scalar_field(states, "Pressure", stat=stat) + if (associated(p)) then + extract_pressure_mesh_from_any_state => p%mesh + else + nullify(extract_pressure_mesh_from_any_state) end if - end do - - ! Select all prognostic and prescribed vector fields that do not have interpolation - ! disabled. In addition, select diagnostic vector fields that have interpolation enabled. - do i = 1, vector_field_count(state) - vfield => extract_vector_field(state, i) - if (interpolate_field(vfield, first_time_step=first_time_step)) then - ewrite(2,*) 'selecting to interpolate ', trim(vfield%name) - call insert(interpolate_state, vfield, vfield%name) + + end function extract_pressure_mesh_from_any_state + + function extract_velocity_mesh_from_state(state, stat) + type(state_type), intent(in):: state + type(mesh_type), pointer:: extract_velocity_mesh_from_state + integer, optional, intent(out):: stat + + type(vector_field), pointer:: u + + u => extract_vector_field(state, "Velocity", stat=stat) + if (associated(u)) then + extract_velocity_mesh_from_state => u%mesh + else + nullify(extract_velocity_mesh_from_state) end if - end do - - ! Select all prognostic and prescribed tensor fields that do not have interpolation - ! disabled. In addition, select diagnostic tensor fields that have interpolation enabled. - do i = 1, tensor_field_count(state) - tfield => extract_tensor_field(state, i) - if (interpolate_field(tfield, first_time_step=first_time_step)) then - ewrite(2,*) 'selecting to interpolate ', trim(tfield%name) - call insert(interpolate_state, tfield, tfield%name) + + end function extract_velocity_mesh_from_state + + function extract_velocity_mesh_from_any_state(states, stat) + type(state_type), dimension(:), intent(in):: states + type(mesh_type), pointer:: extract_velocity_mesh_from_any_state + integer, optional, intent(out):: stat + + type(vector_field), pointer:: u + + u => extract_vector_field(states, "Velocity", stat=stat) + if (associated(u)) then + extract_velocity_mesh_from_any_state => u%mesh + else + nullify(extract_velocity_mesh_from_any_state) end if - end do - - if (.not. present_and_true(no_positions)) then - ! Need coordinate for interpolation - vfield => extract_vector_field(state, "Coordinate") - call insert(interpolate_state, vfield, vfield%name) - end if - - end subroutine select_fields_to_interpolate - - function interpolate_field_scalar(field, first_time_step) result (interpolate_field) - !!< Does this field want to be interpolated? - logical :: interpolate_field - type(scalar_field), intent(in) :: field - !! at first_time_step skip those prognostice fields that can be reinitialised - logical, optional, intent(in):: first_time_step - - interpolate_field = (.not.aliased(field)) .and. & - interpolate_options(trim(field%option_path), first_time_step=first_time_step) - - end function interpolate_field_scalar - - function interpolate_field_vector(field, first_time_step) result (interpolate_field) - !!< Does this field want to be interpolated? - logical :: interpolate_field - type(vector_field), intent(in) :: field - !! at first_time_step skip those prognostice fields that can be reinitialised - logical, optional, intent(in):: first_time_step - - interpolate_field = (.not.aliased(field)) .and. & - interpolate_options(trim(field%option_path), first_time_step=first_time_step) - - end function interpolate_field_vector - - function interpolate_field_tensor(field, first_time_step) result (interpolate_field) - !!< Does this field want to be interpolated? - logical :: interpolate_field - type(tensor_field), intent(in) :: field - !! at first_time_step skip those prognostice fields that can be reinitialised - logical, optional, intent(in):: first_time_step - - interpolate_field = (.not.aliased(field)) .and. & - interpolate_options(trim(field%option_path), first_time_step=first_time_step) - - end function interpolate_field_tensor - - logical function interpolate_options(option_path, first_time_step) - !!< Does this option path make the associated field want to be interpolated? - character(len=*) :: option_path - !! at first_time_step skip those prognostice fields that can be reinitialised - logical, optional, intent(in):: first_time_step - - if (present(first_time_step)) then - if (first_time_step) then - ! if the field is prognostic/prescribed and needs its initial mesh - ! it can't be reinitialised, so we need to interpolate - interpolate_options = needs_initial_mesh_options(option_path) .and. & - (have_option(trim(option_path) // "/prognostic") .or. & - have_option(trim(option_path) // "/prescribed")) - return + + end function extract_velocity_mesh_from_any_state + + subroutine select_fields_to_interpolate(state, interpolate_state, no_positions, & + first_time_step) + !!< This routine returns a state that is a selection of the fields + !!< of the input state that should be interpolated after adaptivity + !!< from the old to the new mesh. + !!< Diagnostic are never interpolated, although this could + !!< be useful for diagnostic purposes - again an option may be implemented. + !!< Aliased fields are obviously excluded. + + type(state_type), intent(in):: state + type(state_type), intent(out):: interpolate_state + !! leave out the "Coordinate" field + logical, optional, intent(in) :: no_positions + !! exclude prognostic fields that can be re-initialised (not from_file) + logical, optional, intent(in) :: first_time_step + + integer :: i + type(mesh_type), pointer :: mesh + type(scalar_field), pointer:: sfield => null() + type(vector_field), pointer:: vfield => null() + type(tensor_field), pointer:: tfield => null() + integer :: stat + + interpolate_state%name = state%name + + do i=1, mesh_count(state) + mesh => extract_mesh(state, i) + call insert(interpolate_state, mesh, trim(mesh%name)) + + if (.not. present_and_true(no_positions)) then + vfield => extract_vector_field(state, trim(mesh%name) // 'Coordinate', stat=stat) + if (stat == 0) then + call insert(interpolate_state, vfield, trim(mesh%name) // 'Coordinate') + end if + end if + end do + + ! Select all prognostic and prescribed scalar fields that do not have interpolation + ! disabled. In addition, select diagnostic scalar fields that have interpolation enabled. + do i = 1, scalar_field_count(state) + sfield => extract_scalar_field(state, i) + if (interpolate_field(sfield, first_time_step=first_time_step)) then + ewrite(2,*) 'selecting to interpolate ', trim(sfield%name) + call insert(interpolate_state, sfield, sfield%name) + end if + end do + + ! Select all prognostic and prescribed vector fields that do not have interpolation + ! disabled. In addition, select diagnostic vector fields that have interpolation enabled. + do i = 1, vector_field_count(state) + vfield => extract_vector_field(state, i) + if (interpolate_field(vfield, first_time_step=first_time_step)) then + ewrite(2,*) 'selecting to interpolate ', trim(vfield%name) + call insert(interpolate_state, vfield, vfield%name) + end if + end do + + ! Select all prognostic and prescribed tensor fields that do not have interpolation + ! disabled. In addition, select diagnostic tensor fields that have interpolation enabled. + do i = 1, tensor_field_count(state) + tfield => extract_tensor_field(state, i) + if (interpolate_field(tfield, first_time_step=first_time_step)) then + ewrite(2,*) 'selecting to interpolate ', trim(tfield%name) + call insert(interpolate_state, tfield, tfield%name) + end if + end do + + if (.not. present_and_true(no_positions)) then + ! Need coordinate for interpolation + vfield => extract_vector_field(state, "Coordinate") + call insert(interpolate_state, vfield, vfield%name) end if - end if - - interpolate_options = (have_option(trim(option_path) // "/prognostic") .and. & - & .not. have_option(trim(option_path) // "/prognostic/no_interpolation")) & - .or. have_option(trim(option_path)//"/prescribed/galerkin_projection") & - .or. have_option(trim(option_path)//"/prescribed/consistent_interpolation") & - .or. have_option(trim(option_path)//"/prescribed/pseudo_consistent_interpolation") & - .or. have_option(trim(option_path)//"/prescribed/grandy_interpolation") & - .or. have_option(trim(option_path)//"/diagnostic/galerkin_projection") & - .or. have_option(trim(option_path)//"/diagnostic/consistent_interpolation") & - .or. have_option(trim(option_path)//"/diagnostic/pseudo_consistent_interpolation") & - .or. have_option(trim(option_path)//"/diagnostic/grandy_interpolation") - - end function interpolate_options - - function needs_initial_mesh_scalar(field) result (needs_initial_mesh) - !!< Does the field need the initial mesh for (re)initialisation or prescribing - !!< this is the case if any of its initial conditions are from_file - logical :: needs_initial_mesh - type(scalar_field), intent(in) :: field - - needs_initial_mesh = needs_initial_mesh_options(field%option_path) - - end function needs_initial_mesh_scalar - - function needs_initial_mesh_vector(field) result (needs_initial_mesh) - !!< Does the field need the initial mesh for (re)initialisation or prescribing - !!< this is the case if any of its initial conditions are from_file - logical :: needs_initial_mesh - type(vector_field), intent(in) :: field - - needs_initial_mesh = needs_initial_mesh_options(field%option_path) - - end function needs_initial_mesh_vector - - function needs_initial_mesh_tensor(field) result (needs_initial_mesh) - !!< Does the field need the initial mesh for (re)initialisation or prescribing - !!< this is the case if any of its initial conditions are from_file - logical :: needs_initial_mesh - type(tensor_field), intent(in) :: field - - needs_initial_mesh = needs_initial_mesh_options(field%option_path) - - end function needs_initial_mesh_tensor - - logical function needs_initial_mesh_options(option_path) - !!< Does the field need the initial mesh for initialisation or prescribing - !!< this is the case if any of its initial conditions are from_file - character(len=*) :: option_path - - character(len=OPTION_PATH_LEN):: initialisation_path - integer:: i - - if (have_option(trim(option_path)//'/prognostic')) then - initialisation_path=trim(option_path)//'/prognostic/initial_condition' - else if (have_option(trim(option_path)//'/prescribed')) then - initialisation_path=trim(option_path)//'/prescribed/value' - else - ! diagnostic fields are not initialised/prescribed anyway - if(.not. have_option(trim(option_path)//'/diagnostic/output/checkpoint')) then - needs_initial_mesh_options=.false. - return + + end subroutine select_fields_to_interpolate + + function interpolate_field_scalar(field, first_time_step) result (interpolate_field) + !!< Does this field want to be interpolated? + logical :: interpolate_field + type(scalar_field), intent(in) :: field + !! at first_time_step skip those prognostice fields that can be reinitialised + logical, optional, intent(in):: first_time_step + + interpolate_field = (.not.aliased(field)) .and. & + interpolate_options(trim(field%option_path), first_time_step=first_time_step) + + end function interpolate_field_scalar + + function interpolate_field_vector(field, first_time_step) result (interpolate_field) + !!< Does this field want to be interpolated? + logical :: interpolate_field + type(vector_field), intent(in) :: field + !! at first_time_step skip those prognostice fields that can be reinitialised + logical, optional, intent(in):: first_time_step + + interpolate_field = (.not.aliased(field)) .and. & + interpolate_options(trim(field%option_path), first_time_step=first_time_step) + + end function interpolate_field_vector + + function interpolate_field_tensor(field, first_time_step) result (interpolate_field) + !!< Does this field want to be interpolated? + logical :: interpolate_field + type(tensor_field), intent(in) :: field + !! at first_time_step skip those prognostice fields that can be reinitialised + logical, optional, intent(in):: first_time_step + + interpolate_field = (.not.aliased(field)) .and. & + interpolate_options(trim(field%option_path), first_time_step=first_time_step) + + end function interpolate_field_tensor + + logical function interpolate_options(option_path, first_time_step) + !!< Does this option path make the associated field want to be interpolated? + character(len=*) :: option_path + !! at first_time_step skip those prognostice fields that can be reinitialised + logical, optional, intent(in):: first_time_step + + if (present(first_time_step)) then + if (first_time_step) then + ! if the field is prognostic/prescribed and needs its initial mesh + ! it can't be reinitialised, so we need to interpolate + interpolate_options = needs_initial_mesh_options(option_path) .and. & + (have_option(trim(option_path) // "/prognostic") .or. & + have_option(trim(option_path) // "/prescribed")) + return + end if end if - end if - - ! return .true. if any of the regions are initialised from file - do i=0, option_count(initialisation_path)-1 - if (have_option(trim(initialisation_path)// & - '['//int2str(i)//']/from_file')) then - needs_initial_mesh_options=.true. - return + + interpolate_options = (have_option(trim(option_path) // "/prognostic") .and. & + & .not. have_option(trim(option_path) // "/prognostic/no_interpolation")) & + .or. have_option(trim(option_path)//"/prescribed/galerkin_projection") & + .or. have_option(trim(option_path)//"/prescribed/consistent_interpolation") & + .or. have_option(trim(option_path)//"/prescribed/pseudo_consistent_interpolation") & + .or. have_option(trim(option_path)//"/prescribed/grandy_interpolation") & + .or. have_option(trim(option_path)//"/diagnostic/galerkin_projection") & + .or. have_option(trim(option_path)//"/diagnostic/consistent_interpolation") & + .or. have_option(trim(option_path)//"/diagnostic/pseudo_consistent_interpolation") & + .or. have_option(trim(option_path)//"/diagnostic/grandy_interpolation") + + end function interpolate_options + + function needs_initial_mesh_scalar(field) result (needs_initial_mesh) + !!< Does the field need the initial mesh for (re)initialisation or prescribing + !!< this is the case if any of its initial conditions are from_file + logical :: needs_initial_mesh + type(scalar_field), intent(in) :: field + + needs_initial_mesh = needs_initial_mesh_options(field%option_path) + + end function needs_initial_mesh_scalar + + function needs_initial_mesh_vector(field) result (needs_initial_mesh) + !!< Does the field need the initial mesh for (re)initialisation or prescribing + !!< this is the case if any of its initial conditions are from_file + logical :: needs_initial_mesh + type(vector_field), intent(in) :: field + + needs_initial_mesh = needs_initial_mesh_options(field%option_path) + + end function needs_initial_mesh_vector + + function needs_initial_mesh_tensor(field) result (needs_initial_mesh) + !!< Does the field need the initial mesh for (re)initialisation or prescribing + !!< this is the case if any of its initial conditions are from_file + logical :: needs_initial_mesh + type(tensor_field), intent(in) :: field + + needs_initial_mesh = needs_initial_mesh_options(field%option_path) + + end function needs_initial_mesh_tensor + + logical function needs_initial_mesh_options(option_path) + !!< Does the field need the initial mesh for initialisation or prescribing + !!< this is the case if any of its initial conditions are from_file + character(len=*) :: option_path + + character(len=OPTION_PATH_LEN):: initialisation_path + integer:: i + + if (have_option(trim(option_path)//'/prognostic')) then + initialisation_path=trim(option_path)//'/prognostic/initial_condition' + else if (have_option(trim(option_path)//'/prescribed')) then + initialisation_path=trim(option_path)//'/prescribed/value' + else + ! diagnostic fields are not initialised/prescribed anyway + if(.not. have_option(trim(option_path)//'/diagnostic/output/checkpoint')) then + needs_initial_mesh_options=.false. + return + end if end if - end do - needs_initial_mesh_options=.false. + ! return .true. if any of the regions are initialised from file + do i=0, option_count(initialisation_path)-1 + if (have_option(trim(initialisation_path)// & + '['//int2str(i)//']/from_file')) then + needs_initial_mesh_options=.true. + return + end if + end do + + needs_initial_mesh_options=.false. + + end function needs_initial_mesh_options - end function needs_initial_mesh_options + logical function do_not_recalculate(option_path) + !!< Does this option path tell us not to represcribe + character(len=*) :: option_path - logical function do_not_recalculate(option_path) - !!< Does this option path tell us not to represcribe - character(len=*) :: option_path + integer :: stat - integer :: stat + do_not_recalculate = have_option(trim(complete_field_path(option_path, stat=stat))//"/do_not_recalculate") - do_not_recalculate = have_option(trim(complete_field_path(option_path, stat=stat))//"/do_not_recalculate") + end function do_not_recalculate - end function do_not_recalculate + subroutine find_linear_parent_mesh(state, mesh, parent_mesh, stat) + !!< Tries to find the parent mesh (possibly grand...parent mesh) + !!< that is linear and continuous by trawling through + !!< the options tree. It will have the same periodicity. + type(state_type), intent(in):: state + type(mesh_type), target, intent(in):: mesh + type(mesh_type), pointer:: parent_mesh + integer, optional, intent(out) :: stat - subroutine find_linear_parent_mesh(state, mesh, parent_mesh, stat) - !!< Tries to find the parent mesh (possibly grand...parent mesh) - !!< that is linear and continuous by trawling through - !!< the options tree. It will have the same periodicity. - type(state_type), intent(in):: state - type(mesh_type), target, intent(in):: mesh - type(mesh_type), pointer:: parent_mesh - integer, optional, intent(out) :: stat + character(len=FIELD_NAME_LEN) parent_name + integer lstat - character(len=FIELD_NAME_LEN) parent_name - integer lstat + if(present(stat)) stat = 0 - if(present(stat)) stat = 0 + ! start with mesh itself: + parent_mesh => mesh - ! start with mesh itself: - parent_mesh => mesh + do + ! this is what we're looking for: + if (parent_mesh%shape%degree==1 .and. parent_mesh%continuity>=0) then + return + end if + call get_option(trim(parent_mesh%option_path)// & + '/from_mesh/mesh[0]/name', parent_name, stat=lstat) + if (lstat/=0) then + if (present(stat)) then + stat = 1 + return + else + ! this fails if parent is not derived, i.e. external, and not + ! meeting our criteria (currently not possible as higher order + ! meshes are always derived directly from a P1 mesh - can't + ! extrude or periodise higher order meshes) + ewrite(-1,*) "Trying to find linear and continuous parent mesh of ", & + trim(mesh%name) + ewrite(-1,*) "External mesh ", trim(parent_mesh%name), & + &" does not meet these criteria" + FLExit("Linear input mesh required") + end if + end if + parent_mesh => extract_mesh(state, parent_name) + end do + + end subroutine find_linear_parent_mesh + + subroutine find_mesh_to_adapt(state, mesh) + !!< Finds the external mesh used as basis for adaptivity + !!< This has to be a continuous linear mesh. It has to be the + !!< external mesh as all other meshes will be derived from it. + type(state_type), intent(in):: state + type(mesh_type), pointer:: mesh + + mesh => extract_mesh(state, adaptivity_mesh_name) - do - ! this is what we're looking for: - if (parent_mesh%shape%degree==1 .and. parent_mesh%continuity>=0) then - return + if (mesh%shape%degree/=1 .or. mesh%continuity<0) then + FLExit("For adaptivity external mesh needs to be linear and continuous.") end if - call get_option(trim(parent_mesh%option_path)// & - '/from_mesh/mesh[0]/name', parent_name, stat=lstat) - if (lstat/=0) then - if (present(stat)) then - stat = 1 - return - else - ! this fails if parent is not derived, i.e. external, and not - ! meeting our criteria (currently not possible as higher order - ! meshes are always derived directly from a P1 mesh - can't - ! extrude or periodise higher order meshes) - ewrite(-1,*) "Trying to find linear and continuous parent mesh of ", & - trim(mesh%name) - ewrite(-1,*) "External mesh ", trim(parent_mesh%name), & - &" does not meet these criteria" - FLExit("Linear input mesh required") - end if + + end subroutine find_mesh_to_adapt + + function convergence_norm_integer(option_path) result(norm) + !!< Return the integer index for the norm for the convergence index + !!< defaults to the infinity norm if no option found + integer :: norm + character(len=*), intent(in) :: option_path + + if(have_option(trim(option_path)//"/l2_norm")) then + norm = CONVERGENCE_L2_NORM + else if(have_option(trim(option_path)//"/cv_l2_norm")) then + norm = CONVERGENCE_CV_L2_NORM + else + norm = CONVERGENCE_INFINITY_NORM end if - parent_mesh => extract_mesh(state, parent_name) - end do - - end subroutine find_linear_parent_mesh - - subroutine find_mesh_to_adapt(state, mesh) - !!< Finds the external mesh used as basis for adaptivity - !!< This has to be a continuous linear mesh. It has to be the - !!< external mesh as all other meshes will be derived from it. - type(state_type), intent(in):: state - type(mesh_type), pointer:: mesh - - mesh => extract_mesh(state, adaptivity_mesh_name) - - if (mesh%shape%degree/=1 .or. mesh%continuity<0) then - FLExit("For adaptivity external mesh needs to be linear and continuous.") - end if - - end subroutine find_mesh_to_adapt - - function convergence_norm_integer(option_path) result(norm) - !!< Return the integer index for the norm for the convergence index - !!< defaults to the infinity norm if no option found - integer :: norm - character(len=*), intent(in) :: option_path - - if(have_option(trim(option_path)//"/l2_norm")) then - norm = CONVERGENCE_L2_NORM - else if(have_option(trim(option_path)//"/cv_l2_norm")) then - norm = CONVERGENCE_CV_L2_NORM - else - norm = CONVERGENCE_INFINITY_NORM - end if - - end function convergence_norm_integer - - integer function equation_type_index(option_path) - - character(len=*) :: option_path - - character(len=FIELD_NAME_LEN) :: equation_type - - ! find out equation type - call get_option(trim(option_path)//'/prognostic/equation[0]/name', & - equation_type, default="Unknown") - - select case(trim(equation_type)) - case ("AdvectionDiffusion") - equation_type_index = FIELD_EQUATION_ADVECTIONDIFFUSION - case ("HeatTransfer") - equation_type_index = FIELD_EQUATION_HEATTRANSFER - case ("ConservationOfMass") - equation_type_index = FIELD_EQUATION_CONSERVATIONOFMASS - case ("ReducedConservationOfMass") - equation_type_index = FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS - case ( "InternalEnergy" ) - equation_type_index = FIELD_EQUATION_INTERNALENERGY - case ( "ElectricalPotential" ) - equation_type_index = FIELD_EQUATION_ELECTRICALPOTENTIAL - case ( "KEpsilon" ) - equation_type_index = FIELD_EQUATION_KEPSILON - case default - equation_type_index = FIELD_EQUATION_UNKNOWN - end select - - end function equation_type_index - - subroutine collect_fields_by_mesh(states, mesh_names, mesh_states) - !! For each mesh_names(i) returns a mesh_states(i) that contains the corresponding mesh - !! and all fields in all states defined on that mesh. To distinguish between different fields - !! with the same name from different states, each field coming from states(j) gets inserted - !! as "StateFieldName", the actual field name is not changed. - type(state_type), dimension(:), intent(in) :: states - character(len=*), dimension(:), intent(in) :: mesh_names - type(state_type), dimension(:), intent(out) :: mesh_states - - type(integer_hash_table) :: refcount_to_meshno - integer :: i, j, mesh_no - type(mesh_type), pointer :: mesh - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - - assert( size(mesh_names)==size(mesh_states) ) - - call allocate(refcount_to_meshno) - do i=1, size(mesh_names) - mesh => extract_mesh(states(1), mesh_names(i)) - call insert(mesh_states(i), mesh, mesh_names(i)) - call insert(refcount_to_meshno, mesh%refcount%id, i) - end do - - do i=1,size(states) - do j=1,scalar_field_count(states(i)) - sfield => extract_scalar_field(states(i), j) - if(has_key(refcount_to_meshno, sfield%mesh%refcount%id)) then - mesh_no = fetch(refcount_to_meshno, sfield%mesh%refcount%id) - call insert(mesh_states(mesh_no), sfield, "State" // int2str(i) // trim(sfield%name)) - end if - end do - sfield => null() - - do j=1,vector_field_count(states(i)) - vfield => extract_vector_field(states(i), j) - if(has_key(refcount_to_meshno, vfield%mesh%refcount%id)) then - mesh_no = fetch(refcount_to_meshno, vfield%mesh%refcount%id) - call insert(mesh_states(mesh_no), vfield, "State" // int2str(i) // trim(vfield%name)) - end if + + end function convergence_norm_integer + + integer function equation_type_index(option_path) + + character(len=*) :: option_path + + character(len=FIELD_NAME_LEN) :: equation_type + + ! find out equation type + call get_option(trim(option_path)//'/prognostic/equation[0]/name', & + equation_type, default="Unknown") + + select case(trim(equation_type)) + case ("AdvectionDiffusion") + equation_type_index = FIELD_EQUATION_ADVECTIONDIFFUSION + case ("HeatTransfer") + equation_type_index = FIELD_EQUATION_HEATTRANSFER + case ("ConservationOfMass") + equation_type_index = FIELD_EQUATION_CONSERVATIONOFMASS + case ("ReducedConservationOfMass") + equation_type_index = FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS + case ( "InternalEnergy" ) + equation_type_index = FIELD_EQUATION_INTERNALENERGY + case ( "ElectricalPotential" ) + equation_type_index = FIELD_EQUATION_ELECTRICALPOTENTIAL + case ( "KEpsilon" ) + equation_type_index = FIELD_EQUATION_KEPSILON + case default + equation_type_index = FIELD_EQUATION_UNKNOWN + end select + + end function equation_type_index + + subroutine collect_fields_by_mesh(states, mesh_names, mesh_states) + !! For each mesh_names(i) returns a mesh_states(i) that contains the corresponding mesh + !! and all fields in all states defined on that mesh. To distinguish between different fields + !! with the same name from different states, each field coming from states(j) gets inserted + !! as "StateFieldName", the actual field name is not changed. + type(state_type), dimension(:), intent(in) :: states + character(len=*), dimension(:), intent(in) :: mesh_names + type(state_type), dimension(:), intent(out) :: mesh_states + + type(integer_hash_table) :: refcount_to_meshno + integer :: i, j, mesh_no + type(mesh_type), pointer :: mesh + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + + assert( size(mesh_names)==size(mesh_states) ) + + call allocate(refcount_to_meshno) + do i=1, size(mesh_names) + mesh => extract_mesh(states(1), mesh_names(i)) + call insert(mesh_states(i), mesh, mesh_names(i)) + call insert(refcount_to_meshno, mesh%refcount%id, i) end do - vfield => null() - - do j=1,tensor_field_count(states(i)) - tfield => extract_tensor_field(states(i), j) - if(has_key(refcount_to_meshno, tfield%mesh%refcount%id)) then - mesh_no = fetch(refcount_to_meshno, tfield%mesh%refcount%id) - call insert(mesh_states(mesh_no), tfield, "State" // int2str(i) // trim(tfield%name)) - end if + + do i=1,size(states) + do j=1,scalar_field_count(states(i)) + sfield => extract_scalar_field(states(i), j) + if(has_key(refcount_to_meshno, sfield%mesh%refcount%id)) then + mesh_no = fetch(refcount_to_meshno, sfield%mesh%refcount%id) + call insert(mesh_states(mesh_no), sfield, "State" // int2str(i) // trim(sfield%name)) + end if + end do + sfield => null() + + do j=1,vector_field_count(states(i)) + vfield => extract_vector_field(states(i), j) + if(has_key(refcount_to_meshno, vfield%mesh%refcount%id)) then + mesh_no = fetch(refcount_to_meshno, vfield%mesh%refcount%id) + call insert(mesh_states(mesh_no), vfield, "State" // int2str(i) // trim(vfield%name)) + end if + end do + vfield => null() + + do j=1,tensor_field_count(states(i)) + tfield => extract_tensor_field(states(i), j) + if(has_key(refcount_to_meshno, tfield%mesh%refcount%id)) then + mesh_no = fetch(refcount_to_meshno, tfield%mesh%refcount%id) + call insert(mesh_states(mesh_no), tfield, "State" // int2str(i) // trim(tfield%name)) + end if + end do + tfield => null() end do - tfield => null() - end do - call deallocate(refcount_to_meshno) + call deallocate(refcount_to_meshno) - end subroutine collect_fields_by_mesh + end subroutine collect_fields_by_mesh - function constant_field_scalar(field) result (constant) - type(scalar_field), intent(in) :: field + function constant_field_scalar(field) result (constant) + type(scalar_field), intent(in) :: field - logical :: constant + logical :: constant - integer :: value_count, constant_count + integer :: value_count, constant_count - value_count = option_count(trim(field%option_path)//"/prescribed/value") - constant_count = option_count(trim(field%option_path)//"/prescribed/value/constant") + value_count = option_count(trim(field%option_path)//"/prescribed/value") + constant_count = option_count(trim(field%option_path)//"/prescribed/value/constant") - constant = (value_count==constant_count).and.(constant_count>0) + constant = (value_count==constant_count).and.(constant_count>0) - end function constant_field_scalar + end function constant_field_scalar - function constant_field_vector(field) result (constant) - type(vector_field), intent(in) :: field + function constant_field_vector(field) result (constant) + type(vector_field), intent(in) :: field - logical :: constant + logical :: constant - integer :: value_count, constant_count + integer :: value_count, constant_count - value_count = option_count(trim(field%option_path)//"/prescribed/value") - constant_count = option_count(trim(field%option_path)//"/prescribed/value/constant") + value_count = option_count(trim(field%option_path)//"/prescribed/value") + constant_count = option_count(trim(field%option_path)//"/prescribed/value/constant") - constant = (value_count==constant_count).and.(constant_count>0) + constant = (value_count==constant_count).and.(constant_count>0) - end function constant_field_vector + end function constant_field_vector - function constant_field_tensor(field) result (constant) - type(tensor_field), intent(in) :: field + function constant_field_tensor(field) result (constant) + type(tensor_field), intent(in) :: field - logical :: constant + logical :: constant - integer :: value_count, constant_count + integer :: value_count, constant_count - value_count = option_count(trim(field%option_path)//"/prescribed/value") - constant_count = option_count(trim(field%option_path)//"/prescribed/value/isotropic/constant")+& - option_count(trim(field%option_path)//"/prescribed/value/diagonal/constant")+& - option_count(trim(field%option_path)//"/prescribed/value/anistropic_symmetric/constant")+& - option_count(trim(field%option_path)//"/prescribed/value/anistropic_asymmetric/constant") + value_count = option_count(trim(field%option_path)//"/prescribed/value") + constant_count = option_count(trim(field%option_path)//"/prescribed/value/isotropic/constant")+& + option_count(trim(field%option_path)//"/prescribed/value/diagonal/constant")+& + option_count(trim(field%option_path)//"/prescribed/value/anistropic_symmetric/constant")+& + option_count(trim(field%option_path)//"/prescribed/value/anistropic_asymmetric/constant") - constant = (value_count==constant_count).and.(constant_count>0) + constant = (value_count==constant_count).and.(constant_count>0) - end function constant_field_tensor + end function constant_field_tensor - function isotropic_field_tensor(field) result (isotropic) - type(tensor_field), intent(in) :: field + function isotropic_field_tensor(field) result (isotropic) + type(tensor_field), intent(in) :: field - logical :: isotropic + logical :: isotropic - integer :: value_count, isotropic_count + integer :: value_count, isotropic_count - isotropic_count = option_count(trim(field%option_path)//"/prescribed/value/isotropic") - value_count = option_count(trim(field%option_path)//"/prescribed/value") + isotropic_count = option_count(trim(field%option_path)//"/prescribed/value/isotropic") + value_count = option_count(trim(field%option_path)//"/prescribed/value") - isotropic = (value_count==isotropic_count).and.(value_count>0) + isotropic = (value_count==isotropic_count).and.(value_count>0) - end function isotropic_field_tensor + end function isotropic_field_tensor - function diagonal_field_tensor(field) result (diagonal) - type(tensor_field), intent(in) :: field + function diagonal_field_tensor(field) result (diagonal) + type(tensor_field), intent(in) :: field - logical :: diagonal + logical :: diagonal - integer :: value_count, diagonal_count + integer :: value_count, diagonal_count - diagonal_count = option_count(trim(field%option_path)//"/prescribed/value/diagonal") - value_count = option_count(trim(field%option_path)//"/prescribed/value") + diagonal_count = option_count(trim(field%option_path)//"/prescribed/value/diagonal") + value_count = option_count(trim(field%option_path)//"/prescribed/value") - diagonal = (value_count==diagonal_count).and.(value_count>0) + diagonal = (value_count==diagonal_count).and.(value_count>0) - end function diagonal_field_tensor + end function diagonal_field_tensor - subroutine postprocess_periodic_mesh(external_mesh, external_positions, periodic_mesh, periodic_positions) - type(mesh_type), intent(in) :: periodic_mesh - type(mesh_type), intent(in) :: external_mesh - type(vector_field), intent(inout) :: periodic_positions - type(vector_field), intent(in) :: external_positions + subroutine postprocess_periodic_mesh(external_mesh, external_positions, periodic_mesh, periodic_positions) + type(mesh_type), intent(in) :: periodic_mesh + type(mesh_type), intent(in) :: external_mesh + type(vector_field), intent(inout) :: periodic_positions + type(vector_field), intent(in) :: external_positions + + type(integer_set):: physical_bc_nodes + integer :: periodic_bc, aliased_id, physical_id, j + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: aliased_boundary_ids, physical_boundary_ids + integer :: face + integer :: ele + real, dimension(ele_ngi(periodic_positions, 1)) :: detwei + real :: vol + + ! Check for degenerate elements + do ele=1,ele_count(periodic_positions) + call transform_to_physical(periodic_positions, ele, detwei=detwei) + vol = sum(detwei) + assert(vol > 0) + end do - type(integer_set):: physical_bc_nodes - integer :: periodic_bc, aliased_id, physical_id, j - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: aliased_boundary_ids, physical_boundary_ids - integer :: face - integer :: ele - real, dimension(ele_ngi(periodic_positions, 1)) :: detwei - real :: vol + ! First we need to create a set of all nodes that are on physical periodic + ! boundaries. If these nodes (in the non-periodic mesh) also appear on + ! aliased boundaries (happens for double periodic), they should not be + ! used to determine the position in the periodic coordinate field + + call allocate(physical_bc_nodes) + do periodic_bc=0,option_count(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions')-1 + shape_option = option_shape(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids') + allocate(physical_boundary_ids(shape_option(1))) + call get_option(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/physical_boundary_ids', physical_boundary_ids) + do j=1, shape_option(1) + physical_id = physical_boundary_ids(j) + ! Now we can finally loop over faces with this id and set appropriately + do face=1, surface_element_count(external_mesh) + if (surface_element_id(external_mesh, face) == physical_id) then + call insert(physical_bc_nodes, face_global_nodes(external_mesh, face)) + end if + end do + end do + deallocate(physical_boundary_ids) + end do + + ! We need to loop through all aliased faces and set the periodic positions to + ! the aliased values, so that we can recover them by applying the map later + + do periodic_bc=0,option_count(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions')-1 + shape_option = option_shape(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids') + allocate(aliased_boundary_ids(shape_option(1))) + call get_option(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/aliased_boundary_ids', aliased_boundary_ids) + do j=1,shape_option(1) + aliased_id = aliased_boundary_ids(j) + ! Now we can finally loop over faces with this id and set appropriately + do face=1,surface_element_count(external_mesh) + if (surface_element_id(external_mesh, face) == aliased_id) then + call postprocess_periodic_mesh_face(periodic_positions, external_positions, face, physical_bc_nodes) + end if + end do + end do + deallocate(aliased_boundary_ids) + + end do - ! Check for degenerate elements - do ele=1,ele_count(periodic_positions) - call transform_to_physical(periodic_positions, ele, detwei=detwei) - vol = sum(detwei) - assert(vol > 0) - end do + call deallocate(physical_bc_nodes) - ! First we need to create a set of all nodes that are on physical periodic - ! boundaries. If these nodes (in the non-periodic mesh) also appear on - ! aliased boundaries (happens for double periodic), they should not be - ! used to determine the position in the periodic coordinate field + ! Check for degenerate elements + do ele=1,ele_count(periodic_positions) + call transform_to_physical(periodic_positions, ele, detwei=detwei) + vol = sum(detwei) + assert(vol > 0) + end do - call allocate(physical_bc_nodes) - do periodic_bc=0,option_count(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions')-1 - shape_option = option_shape(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids') - allocate(physical_boundary_ids(shape_option(1))) - call get_option(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/physical_boundary_ids', physical_boundary_ids) - do j=1, shape_option(1) - physical_id = physical_boundary_ids(j) - ! Now we can finally loop over faces with this id and set appropriately - do face=1, surface_element_count(external_mesh) - if (surface_element_id(external_mesh, face) == physical_id) then - call insert(physical_bc_nodes, face_global_nodes(external_mesh, face)) - end if - end do + end subroutine postprocess_periodic_mesh + + subroutine postprocess_periodic_mesh_face(periodic_positions, external_positions, face, physical_bc_nodes) + ! Write the positions of the nodes on this aliased face + ! to the periodic_positions. The physical positions can later be + ! recovered by applying the coordinate map. Nodes that are on both + ! a physical and an aliased face (happens for double/triple periodic) + ! should not be written, as they have another copy, going back + ! applying the inverse of the coordinate map associated with the + ! physical face - and its that position we want to write out. + type(vector_field), intent(inout):: periodic_positions + type(vector_field), intent(in):: external_positions + integer, intent(in):: face + type(integer_set), intent(in):: physical_bc_nodes + + integer, dimension(face_loc(external_positions, face)):: face_non_periodic_nodes, face_periodic_nodes + integer:: k, np_node, p_node + + face_non_periodic_nodes=face_global_nodes(external_positions, face) + face_periodic_nodes=face_global_nodes(periodic_positions, face) + + do k=1, size(face_non_periodic_nodes) + np_node=face_non_periodic_nodes(k) + p_node=face_periodic_nodes(k) + if (.not. has_value(physical_bc_nodes, np_node)) then + call set(periodic_positions, p_node, node_val(external_positions, np_node)) + end if end do - deallocate(physical_boundary_ids) - end do - - ! We need to loop through all aliased faces and set the periodic positions to - ! the aliased values, so that we can recover them by applying the map later - - do periodic_bc=0,option_count(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions')-1 - shape_option = option_shape(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids') - allocate(aliased_boundary_ids(shape_option(1))) - call get_option(trim(periodic_mesh%option_path) // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/aliased_boundary_ids', aliased_boundary_ids) - do j=1,shape_option(1) - aliased_id = aliased_boundary_ids(j) - ! Now we can finally loop over faces with this id and set appropriately - do face=1,surface_element_count(external_mesh) - if (surface_element_id(external_mesh, face) == aliased_id) then - call postprocess_periodic_mesh_face(periodic_positions, external_positions, face, physical_bc_nodes) - end if - end do + + end subroutine postprocess_periodic_mesh_face + + subroutine remove_non_extruded_mesh_options(state) + type(state_type), dimension(:), intent(inout) :: state + + type(mesh_type), pointer :: external_mesh + character(len=OPTION_PATH_LEN) :: mesh_path + character(len=FIELD_NAME_LEN) :: mesh_name, mesh_format + integer :: i, nmeshes, stat + logical :: include_in_stat + + + nmeshes = option_count("/geometry/mesh") + mesh_name = '' + do i = 0, nmeshes-1 + mesh_path="/geometry/mesh["//int2str(i)//"]" + if(have_option(trim(mesh_path)//"/from_mesh/extrude")) exit end do - deallocate(aliased_boundary_ids) - - end do - - call deallocate(physical_bc_nodes) - - ! Check for degenerate elements - do ele=1,ele_count(periodic_positions) - call transform_to_physical(periodic_positions, ele, detwei=detwei) - vol = sum(detwei) - assert(vol > 0) - end do - - end subroutine postprocess_periodic_mesh - - subroutine postprocess_periodic_mesh_face(periodic_positions, external_positions, face, physical_bc_nodes) - ! Write the positions of the nodes on this aliased face - ! to the periodic_positions. The physical positions can later be - ! recovered by applying the coordinate map. Nodes that are on both - ! a physical and an aliased face (happens for double/triple periodic) - ! should not be written, as they have another copy, going back - ! applying the inverse of the coordinate map associated with the - ! physical face - and its that position we want to write out. - type(vector_field), intent(inout):: periodic_positions - type(vector_field), intent(in):: external_positions - integer, intent(in):: face - type(integer_set), intent(in):: physical_bc_nodes - - integer, dimension(face_loc(external_positions, face)):: face_non_periodic_nodes, face_periodic_nodes - integer:: k, np_node, p_node - - face_non_periodic_nodes=face_global_nodes(external_positions, face) - face_periodic_nodes=face_global_nodes(periodic_positions, face) - - do k=1, size(face_non_periodic_nodes) - np_node=face_non_periodic_nodes(k) - p_node=face_periodic_nodes(k) - if (.not. has_value(physical_bc_nodes, np_node)) then - call set(periodic_positions, p_node, node_val(external_positions, np_node)) + + if (i>=nmeshes) then + ! I probably shouldn't be here + FLAbort("Cannot find extrusion options") + end if + + ! get everything from the external mesh before it's nuked + external_mesh => get_external_mesh(state) + call get_option(trim(external_mesh%option_path) // "/from_file/format/name", mesh_format) + include_in_stat = have_option(trim(external_mesh%option_path)//"/from_file/stat/include_in_stat") + + ! delete option paths of all parent meshes + call get_option(trim(mesh_path)//"/from_mesh/mesh/name", mesh_name) + call remove_mesh_options_and_parents(state, mesh_name) + !! external_mesh is a pointer to the mesh in state, so should have its option_path removed by now + assert(external_mesh%option_path=='') + + ! we switch include_in_stat under the new from_file if either the original external mesh + ! or the extruded mesh have it - again, we need to check here, before the from_mesh/ options are removed + include_in_stat = include_in_stat .or. have_option(trim(mesh_path)//"/from_mesh/stat/include_in_stat") + call delete_option(trim(mesh_path)//"/from_mesh") + + ! now setup options under from_file/ + call add_option(trim(mesh_path)//"/from_file", stat=stat) + if (stat /= SPUD_NEW_KEY_WARNING) then + FLAbort("Failed to add from_file options. Spud error code is: "//int2str(stat)) + end if + ! shouldn't matter what we set here, as it will be overwritten upon checkpoint: + call set_option_attribute(trim(mesh_path)//"/from_file/file_name", '', stat=stat) + if (stat /= SPUD_NEW_KEY_WARNING) then + FLAbort("Failed to set the mesh format. Spud error code is: "//int2str(stat)) end if - end do - - end subroutine postprocess_periodic_mesh_face - - subroutine remove_non_extruded_mesh_options(state) - type(state_type), dimension(:), intent(inout) :: state - - type(mesh_type), pointer :: external_mesh - character(len=OPTION_PATH_LEN) :: mesh_path - character(len=FIELD_NAME_LEN) :: mesh_name, mesh_format - integer :: i, nmeshes, stat - logical :: include_in_stat - - - nmeshes = option_count("/geometry/mesh") - mesh_name = '' - do i = 0, nmeshes-1 - mesh_path="/geometry/mesh["//int2str(i)//"]" - if(have_option(trim(mesh_path)//"/from_mesh/extrude")) exit - end do - - if (i>=nmeshes) then - ! I probably shouldn't be here - FLAbort("Cannot find extrusion options") - end if - - ! get everything from the external mesh before it's nuked - external_mesh => get_external_mesh(state) - call get_option(trim(external_mesh%option_path) // "/from_file/format/name", mesh_format) - include_in_stat = have_option(trim(external_mesh%option_path)//"/from_file/stat/include_in_stat") - - ! delete option paths of all parent meshes - call get_option(trim(mesh_path)//"/from_mesh/mesh/name", mesh_name) - call remove_mesh_options_and_parents(state, mesh_name) - !! external_mesh is a pointer to the mesh in state, so should have its option_path removed by now - assert(external_mesh%option_path=='') - - ! we switch include_in_stat under the new from_file if either the original external mesh - ! or the extruded mesh have it - again, we need to check here, before the from_mesh/ options are removed - include_in_stat = include_in_stat .or. have_option(trim(mesh_path)//"/from_mesh/stat/include_in_stat") - call delete_option(trim(mesh_path)//"/from_mesh") - - ! now setup options under from_file/ - call add_option(trim(mesh_path)//"/from_file", stat=stat) - if (stat /= SPUD_NEW_KEY_WARNING) then - FLAbort("Failed to add from_file options. Spud error code is: "//int2str(stat)) - end if - ! shouldn't matter what we set here, as it will be overwritten upon checkpoint: - call set_option_attribute(trim(mesh_path)//"/from_file/file_name", '', stat=stat) - if (stat /= SPUD_NEW_KEY_WARNING) then - FLAbort("Failed to set the mesh format. Spud error code is: "//int2str(stat)) - end if - call set_option_attribute(trim(mesh_path)//"/from_file/format/name", trim(mesh_format), stat=stat) - if (stat /= SPUD_NEW_KEY_WARNING) then - FLAbort("Failed to set the mesh format. Spud error code is: "//int2str(stat)) - end if - - if (include_in_stat) then - call add_option(trim(mesh_path)//"/from_file/stat/include_in_stat", stat=stat) - else - call add_option(trim(mesh_path)//"/from_file/stat/exclude_from_stat", stat=stat) - end if - if (stat /= SPUD_NEW_KEY_WARNING) then - FLAbort("Failed to set stat option. Spud error code is: "//int2str(stat)) - end if - - end subroutine remove_non_extruded_mesh_options - - recursive subroutine remove_mesh_options_and_parents(state, mesh_name) - type(state_type), dimension(:), intent(inout) :: state - character(len=*), intent(in) :: mesh_name - - type(mesh_type), pointer :: mesh - character(len=OPTION_PATH_LEN) :: mesh_path - character(len=FIELD_NAME_LEN) :: parent_mesh_name - integer :: mesh_stat - - mesh_path="/geometry/mesh::"//trim(mesh_name) - if (have_option(trim(mesh_path)//"/from_mesh")) then - call get_option(trim(mesh_path)//"/from_mesh/mesh/name", parent_mesh_name) - call remove_mesh_options_and_parents(state, parent_mesh_name) - end if - - ! reset option path if mesh present in state - mesh => extract_mesh(state, mesh_name, stat=mesh_stat) - if (mesh_stat==0) then - mesh%option_path = '' - ! reinsert to ensure all copies have it - call insert(state, mesh, mesh_name) - end if - - call delete_option(mesh_path) - - end subroutine remove_mesh_options_and_parents - - subroutine field_options_check_options - integer :: nmat, nfield, m, f - character(len=OPTION_PATH_LEN) :: mat_name, field_name - integer :: equation_type - logical :: cv_disc, cg_disc - - nmat = option_count("/material_phase") - - do m = 0, nmat-1 - call get_option("/material_phase["//int2str(m)//"]/name", mat_name) - nfield = option_count("/material_phase["//int2str(m)//"]/scalar_field") - do f = 0, nfield-1 - call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/name", field_name) - - cv_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/spatial_discretisation/control_volumes") - cg_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& - "]/prognostic/spatial_discretisation/continuous_galerkin") - - equation_type=equation_type_index(trim("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//"]")) - select case(equation_type) - case(FIELD_EQUATION_CONSERVATIONOFMASS) - if(.not.cv_disc) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Selected equation type only compatible with control volume spatial_discretisation") - end if - case(FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS) - if(.not.cv_disc) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Selected equation type only compatible with control volume spatial_discretisation") - end if - case(FIELD_EQUATION_INTERNALENERGY) - if(.not.(cv_disc.or.cg_disc)) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Selected equation type only compatible with control volume or continuous galerkin spatial_discretisation") - end if - case(FIELD_EQUATION_HEATTRANSFER) - if(.not.cv_disc) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Selected equation type only compatible with control volume spatial_discretisation") - end if - case(FIELD_EQUATION_KEPSILON) - if(.not.cg_disc) then - ewrite(-1,*) "Options checking field "//& - trim(field_name)//" in material_phase "//& - trim(mat_name)//"." - FLExit("Selected equation type only compatible with continuous galerkin spatial_discretisation") - end if - end select + call set_option_attribute(trim(mesh_path)//"/from_file/format/name", trim(mesh_format), stat=stat) + if (stat /= SPUD_NEW_KEY_WARNING) then + FLAbort("Failed to set the mesh format. Spud error code is: "//int2str(stat)) + end if + + if (include_in_stat) then + call add_option(trim(mesh_path)//"/from_file/stat/include_in_stat", stat=stat) + else + call add_option(trim(mesh_path)//"/from_file/stat/exclude_from_stat", stat=stat) + end if + if (stat /= SPUD_NEW_KEY_WARNING) then + FLAbort("Failed to set stat option. Spud error code is: "//int2str(stat)) + end if + + end subroutine remove_non_extruded_mesh_options + + recursive subroutine remove_mesh_options_and_parents(state, mesh_name) + type(state_type), dimension(:), intent(inout) :: state + character(len=*), intent(in) :: mesh_name + + type(mesh_type), pointer :: mesh + character(len=OPTION_PATH_LEN) :: mesh_path + character(len=FIELD_NAME_LEN) :: parent_mesh_name + integer :: mesh_stat + + mesh_path="/geometry/mesh::"//trim(mesh_name) + if (have_option(trim(mesh_path)//"/from_mesh")) then + call get_option(trim(mesh_path)//"/from_mesh/mesh/name", parent_mesh_name) + call remove_mesh_options_and_parents(state, parent_mesh_name) + end if + + ! reset option path if mesh present in state + mesh => extract_mesh(state, mesh_name, stat=mesh_stat) + if (mesh_stat==0) then + mesh%option_path = '' + ! reinsert to ensure all copies have it + call insert(state, mesh, mesh_name) + end if + + call delete_option(mesh_path) + + end subroutine remove_mesh_options_and_parents + + subroutine field_options_check_options + integer :: nmat, nfield, m, f + character(len=OPTION_PATH_LEN) :: mat_name, field_name + integer :: equation_type + logical :: cv_disc, cg_disc + + nmat = option_count("/material_phase") + + do m = 0, nmat-1 + call get_option("/material_phase["//int2str(m)//"]/name", mat_name) + nfield = option_count("/material_phase["//int2str(m)//"]/scalar_field") + do f = 0, nfield-1 + call get_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/name", field_name) + + cv_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/spatial_discretisation/control_volumes") + cg_disc=have_option("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//& + "]/prognostic/spatial_discretisation/continuous_galerkin") + + equation_type=equation_type_index(trim("/material_phase["//int2str(m)//"]/scalar_field["//int2str(f)//"]")) + select case(equation_type) + case(FIELD_EQUATION_CONSERVATIONOFMASS) + if(.not.cv_disc) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Selected equation type only compatible with control volume spatial_discretisation") + end if + case(FIELD_EQUATION_REDUCEDCONSERVATIONOFMASS) + if(.not.cv_disc) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Selected equation type only compatible with control volume spatial_discretisation") + end if + case(FIELD_EQUATION_INTERNALENERGY) + if(.not.(cv_disc.or.cg_disc)) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Selected equation type only compatible with control volume or continuous galerkin spatial_discretisation") + end if + case(FIELD_EQUATION_HEATTRANSFER) + if(.not.cv_disc) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Selected equation type only compatible with control volume spatial_discretisation") + end if + case(FIELD_EQUATION_KEPSILON) + if(.not.cg_disc) then + ewrite(-1,*) "Options checking field "//& + trim(field_name)//" in material_phase "//& + trim(mat_name)//"." + FLExit("Selected equation type only compatible with continuous galerkin spatial_discretisation") + end if + end select + end do end do - end do - end subroutine field_options_check_options + end subroutine field_options_check_options - function extract_prognostic_pressure(state, stat) result(sfield) + function extract_prognostic_pressure(state, stat) result(sfield) - type(state_type), dimension(:), intent(in) :: state - type(scalar_field), pointer :: sfield - integer, optional :: stat + type(state_type), dimension(:), intent(in) :: state + type(scalar_field), pointer :: sfield + integer, optional :: stat - integer :: i, prognostic_count - character(len=OPTION_PATH_LEN) :: thismaterial_phase + integer :: i, prognostic_count + character(len=OPTION_PATH_LEN) :: thismaterial_phase - ! subroutine to get the prognostic field out of an array of states - ! intended to get the correct pointer to pressure or velocity + ! subroutine to get the prognostic field out of an array of states + ! intended to get the correct pointer to pressure or velocity - if(present(stat)) stat = 0 + if(present(stat)) stat = 0 - prognostic_count=option_count('/material_phase/scalar_field::Pressure/prognostic') + prognostic_count=option_count('/material_phase/scalar_field::Pressure/prognostic') - if(prognostic_count==1) then - do i = 1,size(state) - write(thismaterial_phase, '(a)') "/material_phase::"//trim(state(i)%name) + if(prognostic_count==1) then + do i = 1,size(state) + write(thismaterial_phase, '(a)') "/material_phase::"//trim(state(i)%name) - if(have_option(trim(thismaterial_phase)//'/scalar_field::Pressure/prognostic')) then - sfield=>extract_scalar_field(state(i),'Pressure') + if(have_option(trim(thismaterial_phase)//'/scalar_field::Pressure/prognostic')) then + sfield=>extract_scalar_field(state(i),'Pressure') + end if + + end do + else if(prognostic_count>1) then + if(present(stat)) then + stat = 2 + else + FLExit("Multiple prognostic pressure fields.") + end if + else + if(present(stat)) then + stat = 1 + else + FLExit("No prognostic pressure field found.") + end if end if - end do - else if(prognostic_count>1) then - if(present(stat)) then - stat = 2 - else - FLExit("Multiple prognostic pressure fields.") - end if - else - if(present(stat)) then - stat = 1 - else - FLExit("No prognostic pressure field found.") - end if - end if + end function extract_prognostic_pressure - end function extract_prognostic_pressure + function extract_prognostic_velocity(state, stat) result(vfield) - function extract_prognostic_velocity(state, stat) result(vfield) + type(state_type), dimension(:), intent(in) :: state + type(vector_field), pointer :: vfield + integer, optional :: stat - type(state_type), dimension(:), intent(in) :: state - type(vector_field), pointer :: vfield - integer, optional :: stat + integer :: i, prognostic_count + character(len=OPTION_PATH_LEN) :: thismaterial_phase - integer :: i, prognostic_count - character(len=OPTION_PATH_LEN) :: thismaterial_phase + ! subroutine to get the prognostic field out of an array of states + ! intended to get the correct pointer to pressure or velocity - ! subroutine to get the prognostic field out of an array of states - ! intended to get the correct pointer to pressure or velocity + if(present(stat)) stat = 0 - if(present(stat)) stat = 0 + prognostic_count=option_count('/material_phase/vector_field::Velocity/prognostic') - prognostic_count=option_count('/material_phase/vector_field::Velocity/prognostic') + if(prognostic_count==1) then - if(prognostic_count==1) then + do i = 1,size(state) + write(thismaterial_phase, '(a)') "/material_phase::"//trim(state(i)%name) - do i = 1,size(state) - write(thismaterial_phase, '(a)') "/material_phase::"//trim(state(i)%name) + if(have_option(trim(thismaterial_phase)//'/vector_field::Velocity/prognostic')) then + vfield=>extract_vector_field(state(i),'Velocity') + end if - if(have_option(trim(thismaterial_phase)//'/vector_field::Velocity/prognostic')) then - vfield=>extract_vector_field(state(i),'Velocity') + end do + else if(prognostic_count>1) then + if(present(stat)) then + stat = 2 + else + FLExit("Multiple prognostic velocity fields.") + end if + else + if(present(stat)) then + stat = 1 + else + FLExit("No prognostic velocity field found.") + end if end if - end do - else if(prognostic_count>1) then - if(present(stat)) then - stat = 2 - else - FLExit("Multiple prognostic velocity fields.") - end if - else - if(present(stat)) then - stat = 1 - else - FLExit("No prognostic velocity field found.") - end if - end if - - end function extract_prognostic_velocity + end function extract_prognostic_velocity end module field_options diff --git a/femtools/Field_derivatives.F90 b/femtools/Field_derivatives.F90 index ea21b2dc19..d4b46d23fd 100644 --- a/femtools/Field_derivatives.F90 +++ b/femtools/Field_derivatives.F90 @@ -1,72 +1,72 @@ #include "fdebug.h" module field_derivatives - !!< This module contains code to compute the derivatives of - !!< scalar fields. It uses superconvergent patch recovery, see - !!< Zienkiewicz & Zhu, Int. J. Numer. Methods Eng, 33, 1331-1364 (1992) - !!< At present it only computes up to the second derivative. - !!< (Since the k-th derivative of a scalar field is a rank-k tensor, - !!< anything with k > 2 rapidly becomes far too big to store in memory.) - - use fldebug - use vector_tools - use elements - use eventcounter - use superconvergence - use sparse_tools - use tensors, only: tensormul - use transform_elements - use fetools, only: shape_shape, shape_dshape, dshape_outer_dshape,& - shape_vector_rhs - use parallel_fields - use fields - use state_module - use vtk_interfaces - use halos - use vector_set - use surfacelabels - use node_boundary - use boundary_conditions, only: get_entire_boundary_condition - implicit none - - interface compute_hessian_real + !!< This module contains code to compute the derivatives of + !!< scalar fields. It uses superconvergent patch recovery, see + !!< Zienkiewicz & Zhu, Int. J. Numer. Methods Eng, 33, 1331-1364 (1992) + !!< At present it only computes up to the second derivative. + !!< (Since the k-th derivative of a scalar field is a rank-k tensor, + !!< anything with k > 2 rapidly becomes far too big to store in memory.) + + use fldebug + use vector_tools + use elements + use eventcounter + use superconvergence + use sparse_tools + use tensors, only: tensormul + use transform_elements + use fetools, only: shape_shape, shape_dshape, dshape_outer_dshape,& + shape_vector_rhs + use parallel_fields + use fields + use state_module + use vtk_interfaces + use halos + use vector_set + use surfacelabels + use node_boundary + use boundary_conditions, only: get_entire_boundary_condition + implicit none + + interface compute_hessian_real module procedure compute_hessian_var - end interface + end interface - interface differentiate_field_lumped + interface differentiate_field_lumped module procedure differentiate_field_lumped_single, differentiate_field_lumped_multiple, & - differentiate_field_lumped_vector - end interface + differentiate_field_lumped_vector + end interface - interface u_dot_nabla + interface u_dot_nabla module procedure u_dot_nabla_scalar, & - & u_dot_nabla_vector - end interface u_dot_nabla + & u_dot_nabla_vector + end interface u_dot_nabla - interface grad + interface grad module procedure grad_scalar, grad_vector, grad_vector_tensor - end interface grad + end interface grad - interface dg_ele_grad + interface dg_ele_grad module procedure dg_ele_grad_scalar, dg_ele_grad_vector - end interface dg_ele_grad + end interface dg_ele_grad - interface dg_ele_grad_at_quad + interface dg_ele_grad_at_quad module procedure dg_ele_grad_at_quad_scalar, dg_ele_grad_at_quad_vector - end interface dg_ele_grad_at_quad + end interface dg_ele_grad_at_quad - private + private - public :: strain_rate, differentiate_field, grad, compute_hessian, & + public :: strain_rate, differentiate_field, grad, compute_hessian, & domain_is_2d, get_quadratic_fit_qf, curl, & get_quadratic_fit_eqf, div, u_dot_nabla, get_cubic_fit_cf, differentiate_field_lumped, & dg_ele_grad_at_quad, dg_ele_grad - public :: compute_hessian_qf, compute_hessian_eqf, compute_hessian_var + public :: compute_hessian_qf, compute_hessian_eqf, compute_hessian_var - contains +contains - function dg_ele_grad_scalar(field, ele, X, bc_value, bc_type) result (loc_grad) + function dg_ele_grad_scalar(field, ele, X, bc_value, bc_type) result (loc_grad) ! Return the element contritubtion to the grad matrix of (scalar) ! field for element ele. X is the coordinate field, Optional ! arguments bc_value and bc_type allow for boundary information. @@ -120,32 +120,32 @@ function dg_ele_grad_scalar(field, ele, X, bc_value, bc_type) result (loc_grad) neigh=>ele_neigh(field, ele) faces => ele_faces(field, ele) do ni=1,size(neigh) - ! Find the relevant faces. - ele_2 = neigh(ni) - face = faces(ni) - - if (ele_2>0) then - ! Internal faces. - face_2=ele_face(field, ele_2, ele) - else - ! External face. - face_2=face - end if - - call dg_ele_grad_scalar_interface(ele, face, face_2, ni, & - & loc_grad, X, field, bc_value, bc_type) + ! Find the relevant faces. + ele_2 = neigh(ni) + face = faces(ni) + + if (ele_2>0) then + ! Internal faces. + face_2=ele_face(field, ele_2, ele) + else + ! External face. + face_2=face + end if + + call dg_ele_grad_scalar_interface(ele, face, face_2, ni, & + & loc_grad, X, field, bc_value, bc_type) end do ! multiply by inverse of mass matrix inv_mass = inverse(shape_shape(shape, shape, detwei)) do i = 1, mesh_dim(field) - loc_grad(i,:) = matmul(inv_mass, loc_grad(i,:)) + loc_grad(i,:) = matmul(inv_mass, loc_grad(i,:)) end do - end function dg_ele_grad_scalar + end function dg_ele_grad_scalar - subroutine dg_ele_grad_scalar_interface(ele, face, face_2, & - ni, loc_grad, X, field, bc_value, bc_type) + subroutine dg_ele_grad_scalar_interface(ele, face, face_2, & + ni, loc_grad, X, field, bc_value, bc_type) !!< Construct the DG element boundary integrals on the ni-th face of !!< element ele. @@ -174,41 +174,41 @@ subroutine dg_ele_grad_scalar_interface(ele, face, face_2, & call transform_facet_to_physical(X, face, detwei_f=detwei, normal=normal) if (face==face_2) then - ! boundary faces - need to apply weak dirichlet bc's - ! = - int_ v_h \cdot (u - u^b) n - ! first check for weak-dirichlet bc - ! if no bc_info is applied then assume not weak bc - if (present(bc_type)) then - if (bc_type(face) == 1) then - in_q = face_val_at_quad(field, face) - in_bc_q = ele_val_at_quad(bc_value, face) - - do i=1, mesh_dim(field) - vector(i,:) = -1.0*(in_q(:) - in_bc_q(:))*normal(i,:) - end do - face_rhs = shape_vector_rhs(shape, vector, detwei) - end if - end if + ! boundary faces - need to apply weak dirichlet bc's + ! = - int_ v_h \cdot (u - u^b) n + ! first check for weak-dirichlet bc + ! if no bc_info is applied then assume not weak bc + if (present(bc_type)) then + if (bc_type(face) == 1) then + in_q = face_val_at_quad(field, face) + in_bc_q = ele_val_at_quad(bc_value, face) + + do i=1, mesh_dim(field) + vector(i,:) = -1.0*(in_q(:) - in_bc_q(:))*normal(i,:) + end do + face_rhs = shape_vector_rhs(shape, vector, detwei) + end if + end if else - ! internal face - ! = int_ {v_h} \cdot J(x) - in_q = face_val_at_quad(field, face) - in_q_2 = face_val_at_quad(field, face_2) - - do i=1, mesh_dim(field) - !! factor of 0.5 comes from the averaging operator applied to the - !! test function at the interface. - vector(i,:) = -0.5*(in_q(:) - in_q_2(:))*normal(i,:) - end do - face_rhs = shape_vector_rhs(shape, vector, detwei) + ! internal face + ! = int_ {v_h} \cdot J(x) + in_q = face_val_at_quad(field, face) + in_q_2 = face_val_at_quad(field, face_2) + + do i=1, mesh_dim(field) + !! factor of 0.5 comes from the averaging operator applied to the + !! test function at the interface. + vector(i,:) = -0.5*(in_q(:) - in_q_2(:))*normal(i,:) + end do + face_rhs = shape_vector_rhs(shape, vector, detwei) end if lnodes = face_local_nodes(field, face) loc_grad(:,lnodes) = loc_grad(:,lnodes) + face_rhs - end subroutine dg_ele_grad_scalar_interface + end subroutine dg_ele_grad_scalar_interface - function dg_ele_grad_vector(field, ele_number, X, bc_value, bc_type) result (loc_grad) + function dg_ele_grad_vector(field, ele_number, X, bc_value, bc_type) result (loc_grad) ! Return the element contritubtion to the grad matrix of vector ! field for element ele_number. X is the coordinate field, Optional ! arguments bc_value and bc_type allow for boundary information. @@ -232,19 +232,19 @@ function dg_ele_grad_vector(field, ele_number, X, bc_value, bc_type) result (loc integer :: j do j=1,field%dim - field_component = extract_scalar_field(field, j) - if (present(bc_value)) then - bc_component_value = extract_scalar_field(bc_value, j) - loc_grad(:,j,:) = dg_ele_grad(field_component, ele_number, X, & - & bc_component_value, bc_type(j,:)) - else - loc_grad(:,j,:) = dg_ele_grad(field_component, ele_number, X) - end if + field_component = extract_scalar_field(field, j) + if (present(bc_value)) then + bc_component_value = extract_scalar_field(bc_value, j) + loc_grad(:,j,:) = dg_ele_grad(field_component, ele_number, X, & + & bc_component_value, bc_type(j,:)) + else + loc_grad(:,j,:) = dg_ele_grad(field_component, ele_number, X) + end if end do - end function dg_ele_grad_vector + end function dg_ele_grad_vector - function dg_ele_grad_at_quad_scalar(field, ele_number, shape, X, bc_value, bc_type) result (quad_grad) + function dg_ele_grad_at_quad_scalar(field, ele_number, shape, X, bc_value, bc_type) result (quad_grad) ! Return the grad of field at the quadrature points of ! ele_number. dn is the transformed element gradient. ! including interface terms for dg discretisations based upon @@ -270,9 +270,9 @@ function dg_ele_grad_at_quad_scalar(field, ele_number, shape, X, bc_value, bc_ty ! transform to physical quad_grad = matmul(loc_grad, shape%n) - end function dg_ele_grad_at_quad_scalar + end function dg_ele_grad_at_quad_scalar - function dg_ele_grad_at_quad_vector(field, ele_number, shape, X, bc_value, bc_type) result (quad_grad) + function dg_ele_grad_at_quad_vector(field, ele_number, shape, X, bc_value, bc_type) result (quad_grad) ! Return the grad of field at the quadrature points of ! ele_number. dn is the transformed element gradient. ! including interface terms for dg discretisations based upon @@ -296,19 +296,19 @@ function dg_ele_grad_at_quad_vector(field, ele_number, shape, X, bc_value, bc_ty integer :: j do j=1,field%dim - field_component = extract_scalar_field(field, j) - if (present(bc_value)) then - bc_component_value = extract_scalar_field(bc_value, j) - quad_grad(:,j,:) = dg_ele_grad_at_quad(field_component, ele_number, shape, X, & - & bc_component_value, bc_type(j,:)) - else - quad_grad(:,j,:) = dg_ele_grad_at_quad(field_component, ele_number, shape, X) - end if + field_component = extract_scalar_field(field, j) + if (present(bc_value)) then + bc_component_value = extract_scalar_field(bc_value, j) + quad_grad(:,j,:) = dg_ele_grad_at_quad(field_component, ele_number, shape, X, & + & bc_component_value, bc_type(j,:)) + else + quad_grad(:,j,:) = dg_ele_grad_at_quad(field_component, ele_number, shape, X) + end if end do - end function dg_ele_grad_at_quad_vector + end function dg_ele_grad_at_quad_vector - subroutine differentiate_field_spr(infield, positions, derivatives, outfields, accuracy_at_cost) + subroutine differentiate_field_spr(infield, positions, derivatives, outfields, accuracy_at_cost) !!< This subroutine takes in a scalar field infield, !!< an array of allocated scalar fields outfields, and an array of logicals !!< telling it what derivatives to take. @@ -322,10 +322,10 @@ subroutine differentiate_field_spr(infield, positions, derivatives, outfields, a logical, dimension(:), intent(in) :: derivatives type(scalar_field), dimension(:), intent(inout) :: outfields logical, intent(in), optional :: accuracy_at_cost !!< Don't check for duplicate - !!< superconvergent points. - !!< Setting this improves - !!< accuracy but greatly increases - !!< runtime. + !!< superconvergent points. + !!< Setting this improves + !!< accuracy but greatly increases + !!< runtime. ! (n%loc x n%superconvergence%nsp x dim) real, dimension(:,:,:), allocatable :: dnsp_t ! Holds the output of transform_superconvergent_to_physical @@ -355,7 +355,7 @@ subroutine differentiate_field_spr(infield, positions, derivatives, outfields, a cnt = 0 do i=1,size(derivatives) - if (derivatives(i)) cnt = cnt + 1 + if (derivatives(i)) cnt = cnt + 1 end do assert(size(outfields) .ge. cnt) @@ -380,75 +380,75 @@ subroutine differentiate_field_spr(infield, positions, derivatives, outfields, a call vecset_create(vset) do node=1,infield%mesh%nodes ! loop over nodes requested - A = 0.0; b = 0.0 ! clear the linear system - if (node_lies_on_boundary(node)) then - level = 2 - else - level = 1 - end if - patch = get_patch_ele(infield%mesh, node, level=level) ! form patch - - node_position = node_val(positions, node) - - do ele=1,patch%count ! loop over elements around node - !shape = ele_shape(infield%mesh, patch%elements(ele)) ! get the element type - - ! get the derivatives of the basis functions at the superconvergent points - assert(associated(shape%superconvergence)) - call transform_superconvergent_to_physical(ele_val(positions, patch%elements(ele)), x_shape, shape, dnsp_t) - - ! get the positions of the superconvergent points - superconvergent_positions = ele_val_at_superconvergent(positions, patch%elements(ele)) - - do sp=1,shape%superconvergence%nsp - if (.not. present(accuracy_at_cost)) then - call vecset_is_present(vset, superconvergent_positions(:, sp), already_processed) - if (already_processed) cycle - end if + A = 0.0; b = 0.0 ! clear the linear system + if (node_lies_on_boundary(node)) then + level = 2 + else + level = 1 + end if + patch = get_patch_ele(infield%mesh, node, level=level) ! form patch - ! construct the matrix. - A = A + compute_matrix_contribution_spr(superconvergent_positions(:, sp), shape) - - ! construct the rhs. - cnt = 0 - do i=1,size(derivatives) - - if (derivatives(i)) then - cnt = cnt+1 - diffval = dot_product(ele_val(infield, patch%elements(ele)), dnsp_t(:, sp, i)) ! compute the direct derivative at the point - b(:, cnt) = b(:, cnt) + compute_rhs_contribution_spr(superconvergent_positions(:, sp), shape, diffval) - end if - end do ! loop over derivatives - end do ! loop over superconvergent points - end do ! loop over elements - - ! OK. Now we have the linear system to be solved. - ! First solve it: - - call solve(A, b, stat) - assert(stat == 0) - - ! The solutions are now in the memory of b. - - ! Now we need to multiply P * the solution to get the recovered derivative at the point. - do i=1,positions%dim - node_position(i) = positions%val(i,node) - end do - ! So now get P: - P = getP_spr(node_position, shape) - - ! Now compute the derivative. (At last!) - cnt = 0 - do i=1,size(derivatives) - if (derivatives(i)) then - cnt = cnt + 1 - diffval = dot_product(P, b(:, cnt)) - outfields(cnt)%val(node) = diffval - end if - end do + node_position = node_val(positions, node) + + do ele=1,patch%count ! loop over elements around node + !shape = ele_shape(infield%mesh, patch%elements(ele)) ! get the element type + + ! get the derivatives of the basis functions at the superconvergent points + assert(associated(shape%superconvergence)) + call transform_superconvergent_to_physical(ele_val(positions, patch%elements(ele)), x_shape, shape, dnsp_t) + + ! get the positions of the superconvergent points + superconvergent_positions = ele_val_at_superconvergent(positions, patch%elements(ele)) + + do sp=1,shape%superconvergence%nsp + if (.not. present(accuracy_at_cost)) then + call vecset_is_present(vset, superconvergent_positions(:, sp), already_processed) + if (already_processed) cycle + end if + + ! construct the matrix. + A = A + compute_matrix_contribution_spr(superconvergent_positions(:, sp), shape) + + ! construct the rhs. + cnt = 0 + do i=1,size(derivatives) + + if (derivatives(i)) then + cnt = cnt+1 + diffval = dot_product(ele_val(infield, patch%elements(ele)), dnsp_t(:, sp, i)) ! compute the direct derivative at the point + b(:, cnt) = b(:, cnt) + compute_rhs_contribution_spr(superconvergent_positions(:, sp), shape, diffval) + end if + end do ! loop over derivatives + end do ! loop over superconvergent points + end do ! loop over elements + + ! OK. Now we have the linear system to be solved. + ! First solve it: + + call solve(A, b, stat) + assert(stat == 0) + + ! The solutions are now in the memory of b. + + ! Now we need to multiply P * the solution to get the recovered derivative at the point. + do i=1,positions%dim + node_position(i) = positions%val(i,node) + end do + ! So now get P: + P = getP_spr(node_position, shape) + + ! Now compute the derivative. (At last!) + cnt = 0 + do i=1,size(derivatives) + if (derivatives(i)) then + cnt = cnt + 1 + diffval = dot_product(P, b(:, cnt)) + outfields(cnt)%val(node) = diffval + end if + end do - deallocate(patch%elements) ! Have to do it here; otherwise memory leak - call vecset_clear(vset) + deallocate(patch%elements) ! Have to do it here; otherwise memory leak + call vecset_clear(vset) end do ! loop over nodes deallocate(dnsp_t, superconvergent_positions, A, b, node_position) call vecset_destroy(vset) @@ -464,9 +464,9 @@ subroutine differentiate_field_spr(infield, positions, derivatives, outfields, a end if end do - end subroutine differentiate_field_spr + end subroutine differentiate_field_spr - subroutine grad_scalar(infield, positions, gradient) + subroutine grad_scalar(infield, positions, gradient) !!< This routine computes the gradient of a field. !!< For a continuous gradient this lumps the mass matrix !!< in the Galerkin projection. @@ -486,28 +486,28 @@ subroutine grad_scalar(infield, positions, gradient) dim = gradient%dim do i=1,dim - pardiff(i) = extract_scalar_field(gradient, i) + pardiff(i) = extract_scalar_field(gradient, i) end do ! we need all derivatives derivatives = .true. if (infield%mesh%continuity<0) then - !! required for dg gradient calculation - allocate(bc_type(1:surface_element_count(infield))) - call get_entire_boundary_condition(infield, (/"weakdirichlet"/), bc_value, bc_type) + !! required for dg gradient calculation + allocate(bc_type(1:surface_element_count(infield))) + call get_entire_boundary_condition(infield, (/"weakdirichlet"/), bc_value, bc_type) - call differentiate_field(infield, positions, derivatives, pardiff, bc_value, bc_type) + call differentiate_field(infield, positions, derivatives, pardiff, bc_value, bc_type) - call deallocate(bc_value) - deallocate(bc_type) + call deallocate(bc_value) + deallocate(bc_type) else - call differentiate_field(infield, positions, derivatives, pardiff) + call differentiate_field(infield, positions, derivatives, pardiff) end if - end subroutine grad_scalar + end subroutine grad_scalar - subroutine grad_vector(infield, positions, gradient) + subroutine grad_vector(infield, positions, gradient) !!< This routine computes the gradient of a field. type(vector_field), intent(in) :: infield type(vector_field), intent(in) :: positions @@ -527,42 +527,42 @@ subroutine grad_vector(infield, positions, gradient) ewrite(1,*) 'in grad_vector' if (infield%mesh%continuity<0) then - !! required for dg gradient calculation - allocate(bc_type(infield%dim, 1:surface_element_count(infield))) - allocate(bc_component_type(1:surface_element_count(infield))) - call get_entire_boundary_condition(infield, (/"weakdirichlet"/), bc_value, bc_type) + !! required for dg gradient calculation + allocate(bc_type(infield%dim, 1:surface_element_count(infield))) + allocate(bc_component_type(1:surface_element_count(infield))) + call get_entire_boundary_condition(infield, (/"weakdirichlet"/), bc_value, bc_type) end if dim = gradient(1)%dim do j=1,infield%dim - component = extract_scalar_field(infield, j) + component = extract_scalar_field(infield, j) - do i=1,dim - pardiff(i) = extract_scalar_field(gradient(j), i) - end do + do i=1,dim + pardiff(i) = extract_scalar_field(gradient(j), i) + end do - derivatives = .true. + derivatives = .true. - if (infield%mesh%continuity<0) then - bc_component_value = extract_scalar_field(bc_value, j) - bc_component_type = bc_type(j,:) - call differentiate_field(component, positions, derivatives, pardiff, bc_component_value, bc_component_type) - else - call differentiate_field(component, positions, derivatives, pardiff) - end if + if (infield%mesh%continuity<0) then + bc_component_value = extract_scalar_field(bc_value, j) + bc_component_type = bc_type(j,:) + call differentiate_field(component, positions, derivatives, pardiff, bc_component_value, bc_component_type) + else + call differentiate_field(component, positions, derivatives, pardiff) + end if end do if (infield%mesh%continuity<0) then - call deallocate(bc_value) - deallocate(bc_type, bc_component_type) + call deallocate(bc_value) + deallocate(bc_type, bc_component_type) end if - end subroutine grad_vector + end subroutine grad_vector - subroutine grad_vector_tensor(infield,positions,t_field) + subroutine grad_vector_tensor(infield,positions,t_field) !!< This routine computes the full (tensor) grad of an infield vector field type(vector_field), intent(in) :: infield type(vector_field), intent(in) :: positions @@ -584,40 +584,40 @@ subroutine grad_vector_tensor(infield,positions,t_field) ewrite(1,*) 'in grad_vector_tensor' if (infield%mesh%continuity<0) then - !! required for dg gradient calculation - allocate(bc_type(infield%dim, 1:surface_element_count(infield))) - allocate(bc_component_type(1:surface_element_count(infield))) - call get_entire_boundary_condition(infield, (/"weakdirichlet"/), bc_value, bc_type) + !! required for dg gradient calculation + allocate(bc_type(infield%dim, 1:surface_element_count(infield))) + allocate(bc_component_type(1:surface_element_count(infield))) + call get_entire_boundary_condition(infield, (/"weakdirichlet"/), bc_value, bc_type) end if do j=1,infield%dim - component = extract_scalar_field(infield, j) + component = extract_scalar_field(infield, j) - do i=1,infield%dim - pardiff(i) = extract_scalar_field(t_field,i,j) - end do + do i=1,infield%dim + pardiff(i) = extract_scalar_field(t_field,i,j) + end do - derivatives = .true. + derivatives = .true. - if (infield%mesh%continuity<0) then - bc_component_value = extract_scalar_field(bc_value, j) - bc_component_type = bc_type(j,:) - call differentiate_field(component, positions, derivatives, pardiff, bc_component_value, bc_component_type) - else - call differentiate_field(component, positions, derivatives, pardiff) - end if + if (infield%mesh%continuity<0) then + bc_component_value = extract_scalar_field(bc_value, j) + bc_component_type = bc_type(j,:) + call differentiate_field(component, positions, derivatives, pardiff, bc_component_value, bc_component_type) + else + call differentiate_field(component, positions, derivatives, pardiff) + end if end do if (infield%mesh%continuity<0) then - call deallocate(bc_value) - deallocate(bc_type, bc_component_type) + call deallocate(bc_value) + deallocate(bc_type, bc_component_type) end if - end subroutine grad_vector_tensor + end subroutine grad_vector_tensor - subroutine strain_rate(infield,positions,t_field) + subroutine strain_rate(infield,positions,t_field) !!< This routine computes the strain rate of an infield vector field type(vector_field), intent(in) :: infield type(vector_field), intent(in) :: positions @@ -633,31 +633,31 @@ subroutine strain_rate(infield,positions,t_field) do j=1,infield%dim - component = extract_scalar_field(infield, j) + component = extract_scalar_field(infield, j) - do i=1,infield%dim - pardiff(i) = extract_scalar_field(t_field,i,j) - end do + do i=1,infield%dim + pardiff(i) = extract_scalar_field(t_field,i,j) + end do - derivatives = .true. + derivatives = .true. - call differentiate_field(component, positions, derivatives, pardiff) + call differentiate_field(component, positions, derivatives, pardiff) end do ! Computing the final strain rate tensor do node=1,node_count(t_field) - t=node_val(t_field, node) - call set(t_field, node, (t+transpose(t))/2) + t=node_val(t_field, node) + call set(t_field, node, (t+transpose(t))/2) end do - end subroutine strain_rate + end subroutine strain_rate - subroutine differentiate_field_qf(infield, positions, derivatives, pardiff) - !!< This routine computes the derivative using the QF (quadratic-fit) - !!< approach described in: - !!< M.G. Vallet et al., Numerical comparison of some Hessian recovery techniques - !!< Int. J. Numer. Meth. Engng., in press + subroutine differentiate_field_qf(infield, positions, derivatives, pardiff) + !!< This routine computes the derivative using the QF (quadratic-fit) + !!< approach described in: + !!< M.G. Vallet et al., Numerical comparison of some Hessian recovery techniques + !!< Int. J. Numer. Meth. Engng., in press type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -677,32 +677,32 @@ subroutine differentiate_field_qf(infield, positions, derivatives, pardiff) t_shape = ele_shape(mesh, 1) x_shape = ele_shape(positions, 1) do i=1,count(derivatives .eqv. .true.) - call zero(pardiff(i)) + call zero(pardiff(i)) end do if (maxval(infield%val) == minval(infield%val)) then - ewrite(2,*) "+++: Field constant; returning 0.0" - return + ewrite(2,*) "+++: Field constant; returning 0.0" + return end if call add_nelist(mesh) call initialise_boundcount(mesh, positions) do node=1,node_count(infield) - x = node_val(positions, 1, node); y = node_val(positions, 2, node); z = node_val(positions, 3, node) - b = get_quadratic_fit_qf(infield, positions, node) - - diffvals(1) = b(2) + 2 * b(5) * x + b(8) * y + b(9) * z + b(11) * y * z - diffvals(2) = b(3) + 2 * b(6) * y + b(8) * x + b(10) * z + b(11) * x * z - diffvals(3) = b(4) + 2 * b(7) * z + b(9) * x + b(10) * y + b(11) * x * y - - j = 1 - do i=1,3 - if (derivatives(i)) then - pardiff(j)%val(node) = diffvals(i) - j = j + 1 - end if - end do + x = node_val(positions, 1, node); y = node_val(positions, 2, node); z = node_val(positions, 3, node) + b = get_quadratic_fit_qf(infield, positions, node) + + diffvals(1) = b(2) + 2 * b(5) * x + b(8) * y + b(9) * z + b(11) * y * z + diffvals(2) = b(3) + 2 * b(6) * y + b(8) * x + b(10) * z + b(11) * x * z + diffvals(3) = b(4) + 2 * b(7) * z + b(9) * x + b(10) * y + b(11) * x * y + + j = 1 + do i=1,3 + if (derivatives(i)) then + pardiff(j)%val(node) = diffvals(i) + j = j + 1 + end if + end do end do call differentiate_boundary_correction(pardiff, positions, t_shape, count(derivatives .eqv. .true.)) @@ -711,13 +711,13 @@ subroutine differentiate_field_qf(infield, positions, derivatives, pardiff) do i=1,count(derivatives .eqv. .true.) call halo_update(pardiff(i)) end do - end subroutine differentiate_field_qf + end subroutine differentiate_field_qf - subroutine compute_hessian_qf(infield, positions, hessian) - !!< This routine computes the hessian using the QF (quadratic-fit) - !!< approach described in: - !!< M.G. Vallet et al., Numerical comparison of some Hessian recovery techniques - !!< Int. J. Numer. Meth. Engng., in press + subroutine compute_hessian_qf(infield, positions, hessian) + !!< This routine computes the hessian using the QF (quadratic-fit) + !!< approach described in: + !!< M.G. Vallet et al., Numerical comparison of some Hessian recovery techniques + !!< Int. J. Numer. Meth. Engng., in press type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout) :: hessian @@ -747,35 +747,35 @@ subroutine compute_hessian_qf(infield, positions, hessian) x_shape = ele_shape(positions, 1) call zero(hessian) if (maxval(infield%val) == minval(infield%val)) then - ewrite(2,*) "+++: Field constant; returning 0.0" - return + ewrite(2,*) "+++: Field constant; returning 0.0" + return end if call add_nelist(mesh) call initialise_boundcount(mesh, positions) do node=1,node_count(infield) - x = node_val(positions, 1, node); y = node_val(positions, 2, node); z = node_val(positions, 3, node); - b = get_quadratic_fit_qf(infield, positions, node) + x = node_val(positions, 1, node); y = node_val(positions, 2, node); z = node_val(positions, 3, node); + b = get_quadratic_fit_qf(infield, positions, node) #ifdef QF_DEBUG - patch = get_patch_node(mesh, node, level=2, min_nodes=MATRIX_SIZE_QF) - do i=1,patch%count - nnode = patch%elements(i) - call addto(variance, node, (node_val(infield, nnode) - evaluate_qf(b, node_val(positions, nnode)))**2) - end do - variance%val(node) = sqrt(variance%val(node)) + patch = get_patch_node(mesh, node, level=2, min_nodes=MATRIX_SIZE_QF) + do i=1,patch%count + nnode = patch%elements(i) + call addto(variance, node, (node_val(infield, nnode) - evaluate_qf(b, node_val(positions, nnode)))**2) + end do + variance%val(node) = sqrt(variance%val(node)) #endif - hessian%val(1, 1, node) = 2 * b(5) - hessian%val(1, 2, node) = b(8) + z * b(11) - hessian%val(1, 3, node) = b(9) + y * b(11) - hessian%val(2, 1, node) = b(8) + z * b(11) - hessian%val(2, 2, node) = 2 * b(6) - hessian%val(2, 3, node) = b(10) + x * b(11) - hessian%val(3, 1, node) = b(9) + y * b(11) - hessian%val(3, 2, node) = b(10) + x * b(11) - hessian%val(3, 3, node) = 2 * b(7) + hessian%val(1, 1, node) = 2 * b(5) + hessian%val(1, 2, node) = b(8) + z * b(11) + hessian%val(1, 3, node) = b(9) + y * b(11) + hessian%val(2, 1, node) = b(8) + z * b(11) + hessian%val(2, 2, node) = 2 * b(6) + hessian%val(2, 3, node) = b(10) + x * b(11) + hessian%val(3, 1, node) = b(9) + y * b(11) + hessian%val(3, 2, node) = b(10) + x * b(11) + hessian%val(3, 3, node) = 2 * b(7) end do call hessian_boundary_correction(hessian, positions, t_shape) @@ -787,9 +787,9 @@ subroutine compute_hessian_qf(infield, positions, hessian) call vtk_write_fields("qf_debug", 0, positions, mesh, sfields=(/infield, variance/)) call deallocate(variance) #endif - end subroutine compute_hessian_qf + end subroutine compute_hessian_qf - recursive function get_quadratic_fit_qf(infield, positions, node, level, maxlevel) result(b) + recursive function get_quadratic_fit_qf(infield, positions, node, level, maxlevel) result(b) !!< Fit a quadratic function to infield around the node, !!< with a least squares approach. type(scalar_field), intent(in) :: infield @@ -807,64 +807,64 @@ recursive function get_quadratic_fit_qf(infield, positions, node, level, maxleve type(mesh_type) :: mesh if (present(level)) then - llevel = level + llevel = level else - llevel = 2 + llevel = 2 end if if (present(maxlevel)) then - lmaxlevel = maxlevel + lmaxlevel = maxlevel else - lmaxlevel = llevel + 1 + lmaxlevel = llevel + 1 end if mesh = infield%mesh node_patch = get_patch_node(mesh, node, level=llevel, min_nodes=MATRIX_SIZE_QF) A = 0.0; b_tmp = 0.0 do i=1,node_patch%count - nnode = node_patch%elements(i) + nnode = node_patch%elements(i) - A = A + compute_matrix_contribution_qf(node_val(positions, nnode)) - b_tmp(:, 1) = b_tmp(:, 1) + compute_rhs_contribution_qf(node_val(positions, nnode), node_val(infield, nnode)) + A = A + compute_matrix_contribution_qf(node_val(positions, nnode)) + b_tmp(:, 1) = b_tmp(:, 1) + compute_rhs_contribution_qf(node_val(positions, nnode), node_val(infield, nnode)) end do if (pseudo2d_coord /= 0) then - if (pseudo2d_coord == 1) then - A_2D = A(QF_2D_X, QF_2D_X) - b_tmp_2D(:, 1) = b_tmp(QF_2D_X, 1) - call solve(A_2D, b_tmp_2D, stat) - b = 0.0; b(QF_2D_X) = b_tmp_2D(:, 1) - else if (pseudo2d_coord == 2) then - A_2D = A(QF_2D_Y, QF_2D_Y) - b_tmp_2D(:, 1) = b_tmp(QF_2D_Y, 1) - call solve(A_2D, b_tmp_2D, stat) - b = 0.0; b(QF_2D_Y) = b_tmp_2D(:, 1) - else if (pseudo2d_coord == 3) then - A_2D = A(QF_2D_Z, QF_2D_Z) - b_tmp_2D(:, 1) = b_tmp(QF_2D_Z, 1) - call solve(A_2D, b_tmp_2D, stat) - b = 0.0; b(QF_2D_Z) = b_tmp_2D(:, 1) - end if + if (pseudo2d_coord == 1) then + A_2D = A(QF_2D_X, QF_2D_X) + b_tmp_2D(:, 1) = b_tmp(QF_2D_X, 1) + call solve(A_2D, b_tmp_2D, stat) + b = 0.0; b(QF_2D_X) = b_tmp_2D(:, 1) + else if (pseudo2d_coord == 2) then + A_2D = A(QF_2D_Y, QF_2D_Y) + b_tmp_2D(:, 1) = b_tmp(QF_2D_Y, 1) + call solve(A_2D, b_tmp_2D, stat) + b = 0.0; b(QF_2D_Y) = b_tmp_2D(:, 1) + else if (pseudo2d_coord == 3) then + A_2D = A(QF_2D_Z, QF_2D_Z) + b_tmp_2D(:, 1) = b_tmp(QF_2D_Z, 1) + call solve(A_2D, b_tmp_2D, stat) + b = 0.0; b(QF_2D_Z) = b_tmp_2D(:, 1) + end if else - call solve(A, b_tmp, stat) - b = b_tmp(:, 1) + call solve(A, b_tmp, stat) + b = b_tmp(:, 1) end if if (llevel < lmaxlevel) then - if (stat /= 0) then - ! If the solver fails, go one more level deep - ! to get enough equations to do the fitting - b = get_quadratic_fit_qf(infield, positions, node, level=llevel+1) - end if + if (stat /= 0) then + ! If the solver fails, go one more level deep + ! to get enough equations to do the fitting + b = get_quadratic_fit_qf(infield, positions, node, level=llevel+1) + end if end if deallocate(node_patch%elements) ! Have to do it here; otherwise memory leak - end function get_quadratic_fit_qf + end function get_quadratic_fit_qf - subroutine compute_hessian_int(infield, positions, hessian) - !!< This routine computes the hessian using integration by parts. - !!< See Buscaglia and Dari, Int. J. Numer. Meth. Engng., 40, 4119-4136 (1997) + subroutine compute_hessian_int(infield, positions, hessian) + !!< This routine computes the hessian using integration by parts. + !!< See Buscaglia and Dari, Int. J. Numer. Meth. Engng., 40, 4119-4136 (1997) type(scalar_field), intent(inout) :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout) :: hessian @@ -885,8 +885,8 @@ subroutine compute_hessian_int(infield, positions, hessian) call zero(hessian) if (maxval(infield%val) == minval(infield%val)) then - ewrite(2,*) "+++: Field constant; returning 0.0" - return + ewrite(2,*) "+++: Field constant; returning 0.0" + return end if mesh = infield%mesh @@ -899,38 +899,38 @@ subroutine compute_hessian_int(infield, positions, hessian) t_shape => ele_shape(infield, 1) do ele=1,element_count(infield) - ! Compute detwei. - call transform_to_physical(positions, ele, t_shape, dshape=dt_t, detwei=detwei) - - ! Compute the tensor representing grad(N) grad(N) - r = dshape_outer_dshape(dt_t, dt_t, detwei) - !r_ele = 0.5 * (tensormul(r, ele_val(infield, ele), 3) + tensormul(r, ele_val(infield, ele), 4)) - !r_ele = tensormul(r, ele_val(infield, ele), 4) - - r_ele = 0. - do i = 1,size(r,1) - do j = 1,size(r,2) - r_ele(i,j,:) = r_ele(i,j,:) + & - matmul(r(i,j,:,:),ele_val(infield,ele)) - end do - end do - call addto(hessian, ele_nodes(infield, ele), r_ele) - - ! Lump the mass matrix - mass_matrix = shape_shape(t_shape, t_shape, detwei) - call addto(lumped_mass_matrix, ele_nodes(infield, ele), sum(mass_matrix, 2)) + ! Compute detwei. + call transform_to_physical(positions, ele, t_shape, dshape=dt_t, detwei=detwei) + + ! Compute the tensor representing grad(N) grad(N) + r = dshape_outer_dshape(dt_t, dt_t, detwei) + !r_ele = 0.5 * (tensormul(r, ele_val(infield, ele), 3) + tensormul(r, ele_val(infield, ele), 4)) + !r_ele = tensormul(r, ele_val(infield, ele), 4) + + r_ele = 0. + do i = 1,size(r,1) + do j = 1,size(r,2) + r_ele(i,j,:) = r_ele(i,j,:) + & + matmul(r(i,j,:,:),ele_val(infield,ele)) + end do + end do + call addto(hessian, ele_nodes(infield, ele), r_ele) + + ! Lump the mass matrix + mass_matrix = shape_shape(t_shape, t_shape, detwei) + call addto(lumped_mass_matrix, ele_nodes(infield, ele), sum(mass_matrix, 2)) end do do node=1,node_count(infield) - hessian%val(:, :, node) = (-1.0 / node_val(lumped_mass_matrix, node)) * hessian%val(:, :, node) - !hessian%val(:, :, node) = (-1) * hessian%val(:, :, node) + hessian%val(:, :, node) = (-1.0 / node_val(lumped_mass_matrix, node)) * hessian%val(:, :, node) + !hessian%val(:, :, node) = (-1) * hessian%val(:, :, node) end do call hessian_boundary_correction(hessian, positions, t_shape) call deallocate(lumped_mass_matrix) - end subroutine compute_hessian_int + end subroutine compute_hessian_int - subroutine differentiate_boundary_correction(pardiff, positions, t_shape, count) + subroutine differentiate_boundary_correction(pardiff, positions, t_shape, count) !!< Implement the boundary correction routine for first derivatives. type(scalar_field), dimension(:), intent(inout), target :: pardiff type(vector_field), intent(in) :: positions @@ -963,73 +963,73 @@ subroutine differentiate_boundary_correction(pardiff, positions, t_shape, count) call initialise_boundcount(mesh, positions) do i=1,dim - do node=1,node_count(mesh) - if (node_boundary_count(node) >= get_expected_boundcount() + i) then - call zero(node_weights) - has_neighbouring_interior_node = .false. - ! First we need to compute the weights for each neighbouring node. - neighbour_elements => row_m_ptr(nelist, node) - do j=1,size(neighbour_elements) - ele = neighbour_elements(j) - neighbour_nodes => ele_nodes(mesh, ele) - call transform_to_physical(positions, ele, detwei=detwei) - mass_matrix = shape_shape(t_shape, t_shape, detwei) - ! In words: find the row of the mass matrix corresponding to the node we're interested in, - ! and stuff the integral of the shape functions into node_weights. - call addto(node_weights, neighbour_nodes, mass_matrix(:, find(neighbour_nodes, node))) - - ! Also: find out if the node has /any/ neighbouring interior nodes. - if (.not. has_neighbouring_interior_node) then - do k=1,size(neighbour_nodes) - nnode = neighbour_nodes(k) - if (.not. node_lies_on_boundary(nnode)) then - has_neighbouring_interior_node = .true. - exit + do node=1,node_count(mesh) + if (node_boundary_count(node) >= get_expected_boundcount() + i) then + call zero(node_weights) + has_neighbouring_interior_node = .false. + ! First we need to compute the weights for each neighbouring node. + neighbour_elements => row_m_ptr(nelist, node) + do j=1,size(neighbour_elements) + ele = neighbour_elements(j) + neighbour_nodes => ele_nodes(mesh, ele) + call transform_to_physical(positions, ele, detwei=detwei) + mass_matrix = shape_shape(t_shape, t_shape, detwei) + ! In words: find the row of the mass matrix corresponding to the node we're interested in, + ! and stuff the integral of the shape functions into node_weights. + call addto(node_weights, neighbour_nodes, mass_matrix(:, find(neighbour_nodes, node))) + + ! Also: find out if the node has /any/ neighbouring interior nodes. + if (.not. has_neighbouring_interior_node) then + do k=1,size(neighbour_nodes) + nnode = neighbour_nodes(k) + if (.not. node_lies_on_boundary(nnode)) then + has_neighbouring_interior_node = .true. + exit + end if + end do end if - end do - end if - end do - - ! Now that we have the weights, let us use them. - - node_patch = get_patch_node(mesh, node) - sum_weights = 0.0 - forall (j=1:count) - old_val(j) = pardiff(j)%val(node) - pardiff(j)%val(node) = 0.0 - end forall - do j=1,node_patch%count - nnode = node_patch%elements(j) - ! If it's on the boundary, no ... - if (& - (has_neighbouring_interior_node .and. & - (.not. node_lies_on_boundary(nnode))) & - .or. ((.not. has_neighbouring_interior_node) .and. node_boundary_count(nnode) < node_boundary_count(node))) then - sum_weights = sum_weights + node_val(node_weights, nnode) - do k=1,count - pardiff(k)%val(node) = pardiff(k)%val(node) + & - pardiff(k)%val(nnode) * node_val(node_weights, nnode) - end do - end if - end do - - if (sum_weights == 0.0) then - forall (k=1:count) - pardiff(k)%val(node) = old_val(k) - end forall - else - forall (k=1:count) - pardiff(k)%val(node) = pardiff(k)%val(node) / sum_weights - end forall + end do + + ! Now that we have the weights, let us use them. + + node_patch = get_patch_node(mesh, node) + sum_weights = 0.0 + forall (j=1:count) + old_val(j) = pardiff(j)%val(node) + pardiff(j)%val(node) = 0.0 + end forall + do j=1,node_patch%count + nnode = node_patch%elements(j) + ! If it's on the boundary, no ... + if (& + (has_neighbouring_interior_node .and. & + (.not. node_lies_on_boundary(nnode))) & + .or. ((.not. has_neighbouring_interior_node) .and. node_boundary_count(nnode) < node_boundary_count(node))) then + sum_weights = sum_weights + node_val(node_weights, nnode) + do k=1,count + pardiff(k)%val(node) = pardiff(k)%val(node) + & + pardiff(k)%val(nnode) * node_val(node_weights, nnode) + end do + end if + end do + + if (sum_weights == 0.0) then + forall (k=1:count) + pardiff(k)%val(node) = old_val(k) + end forall + else + forall (k=1:count) + pardiff(k)%val(node) = pardiff(k)%val(node) / sum_weights + end forall + end if + deallocate(node_patch%elements) end if - deallocate(node_patch%elements) - end if - end do + end do end do call deallocate(node_weights) - end subroutine differentiate_boundary_correction + end subroutine differentiate_boundary_correction - subroutine hessian_boundary_correction(hessian, positions, t_shape) + subroutine hessian_boundary_correction(hessian, positions, t_shape) !!< Implement the hessian boundary correction routine. type(tensor_field), intent(inout), target :: hessian type(vector_field), intent(in) :: positions @@ -1060,93 +1060,93 @@ subroutine hessian_boundary_correction(hessian, positions, t_shape) call initialise_boundcount(hessian%mesh, positions) do i=1,dim - do node=1,node_count(hessian) - if (node_boundary_count(node) >= get_expected_boundcount() + i) then - call zero(node_weights) - has_neighbouring_interior_node = .false. - ! First we need to compute the weights for each neighbouring node. - neighbour_elements => row_m_ptr(nelist, node) - do j=1,size(neighbour_elements) - ele = neighbour_elements(j) - neighbour_nodes => ele_nodes(hessian, ele) - call transform_to_physical(positions, ele, detwei=detwei) - mass_matrix = shape_shape(t_shape, t_shape, detwei) - ! In words: find the row of the mass matrix corresponding to the node we're interested in, - ! and stuff the integral of the shape functions into node_weights. - call addto(node_weights, neighbour_nodes, mass_matrix(:, find(neighbour_nodes, node))) - - ! Also: find out if the node has /any/ neighbouring interior nodes. - if (.not. has_neighbouring_interior_node) then - do k=1,size(neighbour_nodes) - nnode = neighbour_nodes(k) - if (.not. node_lies_on_boundary(nnode)) then - has_neighbouring_interior_node = .true. - exit + do node=1,node_count(hessian) + if (node_boundary_count(node) >= get_expected_boundcount() + i) then + call zero(node_weights) + has_neighbouring_interior_node = .false. + ! First we need to compute the weights for each neighbouring node. + neighbour_elements => row_m_ptr(nelist, node) + do j=1,size(neighbour_elements) + ele = neighbour_elements(j) + neighbour_nodes => ele_nodes(hessian, ele) + call transform_to_physical(positions, ele, detwei=detwei) + mass_matrix = shape_shape(t_shape, t_shape, detwei) + ! In words: find the row of the mass matrix corresponding to the node we're interested in, + ! and stuff the integral of the shape functions into node_weights. + call addto(node_weights, neighbour_nodes, mass_matrix(:, find(neighbour_nodes, node))) + + ! Also: find out if the node has /any/ neighbouring interior nodes. + if (.not. has_neighbouring_interior_node) then + do k=1,size(neighbour_nodes) + nnode = neighbour_nodes(k) + if (.not. node_lies_on_boundary(nnode)) then + has_neighbouring_interior_node = .true. + exit + end if + end do end if - end do - end if - end do - - ! Now that we have the weights, let us use them. - - node_patch = get_patch_node(mesh, node) - sum_weights = 0.0 - old_val = hessian%val(:, :, node) - hessian%val(:, :, node) = 0.0 - do j=1,node_patch%count - nnode = node_patch%elements(j) - ! If it's on the boundary, no ... - if (& - (has_neighbouring_interior_node .and. & - (.not. node_lies_on_boundary(nnode))) & - .or. ((.not. has_neighbouring_interior_node) .and. node_boundary_count(nnode) < node_boundary_count(node))) then - sum_weights = sum_weights + node_val(node_weights, nnode) - hessian%val(:, :, node) = hessian%val(:, :, node) + & - hessian%val(:, :, nnode) * node_val(node_weights, nnode) - end if - end do - - if (sum_weights == 0.0) then - hessian%val(:, :, node) = old_val - else - hessian%val(:, :, node) = hessian%val(:, :, node) / sum_weights + end do + + ! Now that we have the weights, let us use them. + + node_patch = get_patch_node(mesh, node) + sum_weights = 0.0 + old_val = hessian%val(:, :, node) + hessian%val(:, :, node) = 0.0 + do j=1,node_patch%count + nnode = node_patch%elements(j) + ! If it's on the boundary, no ... + if (& + (has_neighbouring_interior_node .and. & + (.not. node_lies_on_boundary(nnode))) & + .or. ((.not. has_neighbouring_interior_node) .and. node_boundary_count(nnode) < node_boundary_count(node))) then + sum_weights = sum_weights + node_val(node_weights, nnode) + hessian%val(:, :, node) = hessian%val(:, :, node) + & + hessian%val(:, :, nnode) * node_val(node_weights, nnode) + end if + end do + + if (sum_weights == 0.0) then + hessian%val(:, :, node) = old_val + else + hessian%val(:, :, node) = hessian%val(:, :, node) / sum_weights + end if + deallocate(node_patch%elements) end if - deallocate(node_patch%elements) - end if - end do + end do end do call deallocate(node_weights) - end subroutine hessian_boundary_correction + end subroutine hessian_boundary_correction - subroutine hessian_squash_pseudo2d(hessian) + subroutine hessian_squash_pseudo2d(hessian) !!< Squash derivatives in directions where no dynamics occur. type(tensor_field), intent(inout) :: hessian integer :: node if (pseudo2d_coord == 0) then - return + return end if do node=1,node_count(hessian) - hessian%val(:, pseudo2d_coord, node) = 0.0 - hessian%val(pseudo2d_coord, :, node) = 0.0 + hessian%val(:, pseudo2d_coord, node) = 0.0 + hessian%val(pseudo2d_coord, :, node) = 0.0 end do - end subroutine hessian_squash_pseudo2d + end subroutine hessian_squash_pseudo2d - subroutine differentiate_squash_pseudo2d(pardiff) + subroutine differentiate_squash_pseudo2d(pardiff) !!< Squash derivatives in directions where no dynamics occur. type(scalar_field), dimension(:), intent(inout) :: pardiff if (pseudo2d_coord == 0) then - return + return end if call zero(pardiff(pseudo2d_coord)) - end subroutine differentiate_squash_pseudo2d + end subroutine differentiate_squash_pseudo2d - function find(array, val) result(loc) + function find(array, val) result(loc) !!< Find the first instance of val in array. integer, intent(in), dimension(:) :: array integer, intent(in) :: val @@ -1154,15 +1154,15 @@ function find(array, val) result(loc) loc = -1 do i=1,size(array) - if (array(i) == val) then - loc = i - return - end if + if (array(i) == val) then + loc = i + return + end if end do - end function find + end function find - subroutine compute_hessian_spr(infield, positions, hessian, accuracy_at_cost) - !!< This routine computes the hessian, applying differentiate_field_spr multiple times. + subroutine compute_hessian_spr(infield, positions, hessian, accuracy_at_cost) + !!< This routine computes the hessian, applying differentiate_field_spr multiple times. type(scalar_field), intent(inout) :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout) :: hessian @@ -1177,163 +1177,163 @@ subroutine compute_hessian_spr(infield, positions, hessian, accuracy_at_cost) ! integer :: j, k, neigh_count, node if (maxval(infield%val) == minval(infield%val)) then - hessian%val = 0.0 - ewrite(2,*) "+++: Field constant; returning 0.0" - return + hessian%val = 0.0 + ewrite(2,*) "+++: Field constant; returning 0.0" + return end if call initialise_boundcount(infield%mesh, positions) dim = positions%dim do i=1,dim - call allocate(pardiff(i), infield%mesh) ! allocate the partial derivatives + call allocate(pardiff(i), infield%mesh) ! allocate the partial derivatives end do ! First get the first derivatives. if (dim == 2) then - derivatives(1) = .true. ; derivatives(2) = .true. - call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) + derivatives(1) = .true. ; derivatives(2) = .true. + call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 1, 1) - temp_fields(2) = extract_scalar_field_from_tensor_field(hessian, 1, 2) - derivatives(1) = .true. ; derivatives(2) = .false. - call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 1, 1) + temp_fields(2) = extract_scalar_field_from_tensor_field(hessian, 1, 2) + derivatives(1) = .true. ; derivatives(2) = .false. + call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx ] - ! [ ?? ?? ] + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx ] + ! [ ?? ?? ] - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 1) - temp_fields(1)%val(:) = temp_fields(2)%val + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 1) + temp_fields(1)%val(:) = temp_fields(2)%val - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx ] - ! [ d^2f/dxdy ?? ] + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx ] + ! [ d^2f/dxdy ?? ] - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 2) - derivatives(1) = .false. ; derivatives(2) = .true. - call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 2) + derivatives(1) = .false. ; derivatives(2) = .true. + call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx ] - ! [ d^2f/dydy d^2f/dy^2 ] + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx ] + ! [ d^2f/dydy d^2f/dy^2 ] end if if (dim == 3) then - ! if the domain is pseudo-2d, we don't want to take z derivatives - if (.not. domain_is_2d()) then - derivatives(1) = .true. ; derivatives(2) = .true. ; derivatives(3) = .true. - call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) - else if (domain_is_2d_x()) then - derivatives(1) = .false. ; derivatives(2) = .true. ; derivatives(3) = .true. - call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) - pardiff(1)%val = 0.0 - else if (domain_is_2d_y()) then - derivatives(1) = .true. ; derivatives(2) = .false. ; derivatives(3) = .true. - call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) - pardiff(2)%val = 0.0 - else if (domain_is_2d_z()) then - derivatives(1) = .true. ; derivatives(2) = .true. ; derivatives(3) = .false. - call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) - pardiff(3)%val = 0.0 - end if - ewrite(2,*) "+++: Gradient computed" - - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 1, 1) - temp_fields(2) = extract_scalar_field_from_tensor_field(hessian, 1, 2) - temp_fields(3) = extract_scalar_field_from_tensor_field(hessian, 1, 3) - if (.not. domain_is_2d()) then - derivatives(1) = .true. ; derivatives(2) = .true.; derivatives(3) = .true. - call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) - else if (domain_is_2d_x()) then - temp_fields(1)%val = 0.0 - temp_fields(2)%val = 0.0 - temp_fields(3)%val = 0.0 - else if (domain_is_2d_y()) then - derivatives(1) = .true. ; derivatives(2) = .false.; derivatives(3) = .true. - call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) - temp_fields(2)%val = 0.0 - else if (domain_is_2d_z()) then - derivatives(1) = .true. ; derivatives(2) = .true.; derivatives(3) = .false. - call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) - temp_fields(3)%val = 0.0 - end if - - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] - ! [ ?? ?? ?? ] - ! [ ?? ?? ?? ] - - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 1) - temp_fields(1)%val(:) = temp_fields(2)%val - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 3, 1) - temp_fields(1)%val(:) = temp_fields(3)%val - - ewrite(2,*) "+++: 2nd-order x derivatives computed" - - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] - ! [ d^2f/dydx ?? ?? ] - ! [ d^2f/dzdx ?? ?? ] - - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 2) - temp_fields(2) = extract_scalar_field_from_tensor_field(hessian, 2, 3) - if (.not. domain_is_2d()) then - derivatives(1) = .false.; derivatives(2) = .true. ; derivatives(3) = .true. ! only want the y,z derivatives - call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) - else if (domain_is_2d_x()) then - derivatives(1) = .false.; derivatives(2) = .true. ; derivatives(3) = .true. - call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) - else if (domain_is_2d_y()) then - temp_fields(1)%val = 0.0 - temp_fields(2)%val = 0.0 - else if (domain_is_2d_z()) then - derivatives(1) = .false.; derivatives(2) = .true. ; derivatives(3) = .false. - call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) - temp_fields(2)%val = 0.0 - end if - - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] - ! [ d^2f/dydx d^2f/dy^2 d^2f/dydz ] - ! [ d^2f/dzdx ?? ?? ] - - ewrite(2,*) "+++: 2nd-order y derivatives computed" - - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 3, 2) - temp_fields(1)%val(:) = temp_fields(2)%val - - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] - ! [ d^2f/dydx d^2f/dy^2 d^2f/dydz ] - ! [ d^2f/dzdx d^2f/dydx ?? ] - - temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 3, 3) - if (.not. domain_is_2d_z()) then - derivatives(1) = .false.; derivatives(2) = .false. ; derivatives(3) = .true. ! only want z derivative - call differentiate_field_spr(pardiff(3), positions, derivatives, temp_fields, accuracy_at_cost) - else - temp_fields(1)%val = 0.0 - end if - - ! Now the state of hessian is - ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] - ! [ d^2f/dydx d^2f/dy^2 d^2f/dydz ] - ! [ d^2f/dzdx d^2f/dydx d^2f/dz^2 ] - - ewrite(2,*) "+++: 2nd-order z derivatives computed" + ! if the domain is pseudo-2d, we don't want to take z derivatives + if (.not. domain_is_2d()) then + derivatives(1) = .true. ; derivatives(2) = .true. ; derivatives(3) = .true. + call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) + else if (domain_is_2d_x()) then + derivatives(1) = .false. ; derivatives(2) = .true. ; derivatives(3) = .true. + call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) + pardiff(1)%val = 0.0 + else if (domain_is_2d_y()) then + derivatives(1) = .true. ; derivatives(2) = .false. ; derivatives(3) = .true. + call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) + pardiff(2)%val = 0.0 + else if (domain_is_2d_z()) then + derivatives(1) = .true. ; derivatives(2) = .true. ; derivatives(3) = .false. + call differentiate_field_spr(infield, positions, derivatives, pardiff, accuracy_at_cost) + pardiff(3)%val = 0.0 + end if + ewrite(2,*) "+++: Gradient computed" + + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 1, 1) + temp_fields(2) = extract_scalar_field_from_tensor_field(hessian, 1, 2) + temp_fields(3) = extract_scalar_field_from_tensor_field(hessian, 1, 3) + if (.not. domain_is_2d()) then + derivatives(1) = .true. ; derivatives(2) = .true.; derivatives(3) = .true. + call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) + else if (domain_is_2d_x()) then + temp_fields(1)%val = 0.0 + temp_fields(2)%val = 0.0 + temp_fields(3)%val = 0.0 + else if (domain_is_2d_y()) then + derivatives(1) = .true. ; derivatives(2) = .false.; derivatives(3) = .true. + call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) + temp_fields(2)%val = 0.0 + else if (domain_is_2d_z()) then + derivatives(1) = .true. ; derivatives(2) = .true.; derivatives(3) = .false. + call differentiate_field_spr(pardiff(1), positions, derivatives, temp_fields, accuracy_at_cost) + temp_fields(3)%val = 0.0 + end if + + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] + ! [ ?? ?? ?? ] + ! [ ?? ?? ?? ] + + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 1) + temp_fields(1)%val(:) = temp_fields(2)%val + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 3, 1) + temp_fields(1)%val(:) = temp_fields(3)%val + + ewrite(2,*) "+++: 2nd-order x derivatives computed" + + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] + ! [ d^2f/dydx ?? ?? ] + ! [ d^2f/dzdx ?? ?? ] + + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 2, 2) + temp_fields(2) = extract_scalar_field_from_tensor_field(hessian, 2, 3) + if (.not. domain_is_2d()) then + derivatives(1) = .false.; derivatives(2) = .true. ; derivatives(3) = .true. ! only want the y,z derivatives + call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) + else if (domain_is_2d_x()) then + derivatives(1) = .false.; derivatives(2) = .true. ; derivatives(3) = .true. + call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) + else if (domain_is_2d_y()) then + temp_fields(1)%val = 0.0 + temp_fields(2)%val = 0.0 + else if (domain_is_2d_z()) then + derivatives(1) = .false.; derivatives(2) = .true. ; derivatives(3) = .false. + call differentiate_field_spr(pardiff(2), positions, derivatives, temp_fields, accuracy_at_cost) + temp_fields(2)%val = 0.0 + end if + + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] + ! [ d^2f/dydx d^2f/dy^2 d^2f/dydz ] + ! [ d^2f/dzdx ?? ?? ] + + ewrite(2,*) "+++: 2nd-order y derivatives computed" + + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 3, 2) + temp_fields(1)%val(:) = temp_fields(2)%val + + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] + ! [ d^2f/dydx d^2f/dy^2 d^2f/dydz ] + ! [ d^2f/dzdx d^2f/dydx ?? ] + + temp_fields(1) = extract_scalar_field_from_tensor_field(hessian, 3, 3) + if (.not. domain_is_2d_z()) then + derivatives(1) = .false.; derivatives(2) = .false. ; derivatives(3) = .true. ! only want z derivative + call differentiate_field_spr(pardiff(3), positions, derivatives, temp_fields, accuracy_at_cost) + else + temp_fields(1)%val = 0.0 + end if + + ! Now the state of hessian is + ! [ d^2f/dx^2 d^2f/dydx d^2f/dzdx ] + ! [ d^2f/dydx d^2f/dy^2 d^2f/dydz ] + ! [ d^2f/dzdx d^2f/dydx d^2f/dz^2 ] + + ewrite(2,*) "+++: 2nd-order z derivatives computed" end if do i=1,dim - deallocate(pardiff(i)%val) + deallocate(pardiff(i)%val) end do - end subroutine compute_hessian_spr + end subroutine compute_hessian_spr - subroutine compute_hessian_var(infield, positions, hessian) - !!< This routine computes the hessian using a weak finite element formulation. + subroutine compute_hessian_var(infield, positions, hessian) + !!< This routine computes the hessian using a weak finite element formulation. type(scalar_field), intent(in) :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout), target :: hessian @@ -1360,8 +1360,8 @@ subroutine compute_hessian_var(infield, positions, hessian) call zero(hessian) if (maxval(infield%val) == minval(infield%val)) then - ewrite(2,*) "+++: Field constant; returning 0.0" - return + ewrite(2,*) "+++: Field constant; returning 0.0" + return end if call allocate(lumped_mass_matrix, mesh, "Lumped mass matrix") @@ -1378,23 +1378,23 @@ subroutine compute_hessian_var(infield, positions, hessian) ! First, compute gradient and mass matrix. do ele=1,element_count(infield) - ! Compute detwei. - call transform_to_physical(positions, ele, t_shape, dshape=dt_t, detwei=detwei) + ! Compute detwei. + call transform_to_physical(positions, ele, t_shape, dshape=dt_t, detwei=detwei) - r = shape_dshape(h_shape, dt_t, detwei) - r_grad_ele = tensormul(r, ele_val(infield, ele), 3) + r = shape_dshape(h_shape, dt_t, detwei) + r_grad_ele = tensormul(r, ele_val(infield, ele), 3) - call addto(gradient, ele_nodes(gradient, ele), r_grad_ele) + call addto(gradient, ele_nodes(gradient, ele), r_grad_ele) - ! Lump the mass matrix - mass_matrix = shape_shape(h_shape, h_shape, detwei) - call addto(lumped_mass_matrix, ele_nodes(lumped_mass_matrix, ele), sum(mass_matrix, 2)) + ! Lump the mass matrix + mass_matrix = shape_shape(h_shape, h_shape, detwei) + call addto(lumped_mass_matrix, ele_nodes(lumped_mass_matrix, ele), sum(mass_matrix, 2)) end do do node=1,node_count(gradient) - do i=1,dim - gradient%val(i,node) = gradient%val(i,node) / node_val(lumped_mass_matrix, node) - end do + do i=1,dim + gradient%val(i,node) = gradient%val(i,node) / node_val(lumped_mass_matrix, node) + end do end do ! Testing: does this cause the lock exchange result to fail? @@ -1404,35 +1404,35 @@ subroutine compute_hessian_var(infield, positions, hessian) !call differentiate_boundary_correction(grad_components, positions, x_shape, t_shape, dim) do ele=1,element_count(infield) - call transform_to_physical(positions, ele, h_shape, dshape=dh_t, detwei=detwei) - r_hess = shape_dshape(h_shape, dh_t, detwei) - do i=1,dim - r_hess_ele(i, :, :) = tensormul(r_hess, ele_val(gradient, i, ele), 3) - end do - call addto(hessian, ele_nodes(hessian, ele), r_hess_ele) + call transform_to_physical(positions, ele, h_shape, dshape=dh_t, detwei=detwei) + r_hess = shape_dshape(h_shape, dh_t, detwei) + do i=1,dim + r_hess_ele(i, :, :) = tensormul(r_hess, ele_val(gradient, i, ele), 3) + end do + call addto(hessian, ele_nodes(hessian, ele), r_hess_ele) end do do node=1,node_count(hessian) - hess_ptr => hessian%val(:, :, node) - hess_ptr = hess_ptr / node_val(lumped_mass_matrix, node) - - ! Now we need to make it symmetric, see? - do i=1,dim - do j=i+1,dim - hess_ptr(i, j) = (hess_ptr(i, j) + hess_ptr(j, i)) / 2.0 - hess_ptr(j, i) = hess_ptr(i, j) - end do - end do + hess_ptr => hessian%val(:, :, node) + hess_ptr = hess_ptr / node_val(lumped_mass_matrix, node) + + ! Now we need to make it symmetric, see? + do i=1,dim + do j=i+1,dim + hess_ptr(i, j) = (hess_ptr(i, j) + hess_ptr(j, i)) / 2.0 + hess_ptr(j, i) = hess_ptr(i, j) + end do + end do end do call hessian_boundary_correction(hessian, positions, h_shape) call deallocate(lumped_mass_matrix) call deallocate(gradient) - end subroutine compute_hessian_var + end subroutine compute_hessian_var - subroutine differentiate_field_lumped_multiple(infields, positions, derivatives, pardiff) - !!< This routine computes the first derivatives using a weak finite element formulation. + subroutine differentiate_field_lumped_multiple(infields, positions, derivatives, pardiff) + !!< This routine computes the first derivatives using a weak finite element formulation. type(scalar_field), dimension(:), intent(in) :: infields type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -1449,48 +1449,48 @@ subroutine differentiate_field_lumped_multiple(infields, positions, derivatives, mesh => pardiff(1, 1)%mesh do i=1, size(infields) - ! don't compute if the field is constant - compute(i)= (maxval(infields(i)%val) /= minval(infields(i)%val)) - ! check the infield is continuous!!!! - if (infields(i)%mesh%continuity<0) then - ewrite(0,*) "If the following error is directly due to user input" - ewrite(0,*) "a check and a more helpful error message should be inserted in" - ewrite(0,*) "the calling routine (outside field_derivatives) - please mantis this:" - ewrite(0,*) "Error has occured in differentiate_field_lumped_multiple, with field, ", trim(infields(i)%name) - FLAbort("The field_derivatives code cannot take the derivative of a discontinuous field") - end if + ! don't compute if the field is constant + compute(i)= (maxval(infields(i)%val) /= minval(infields(i)%val)) + ! check the infield is continuous!!!! + if (infields(i)%mesh%continuity<0) then + ewrite(0,*) "If the following error is directly due to user input" + ewrite(0,*) "a check and a more helpful error message should be inserted in" + ewrite(0,*) "the calling routine (outside field_derivatives) - please mantis this:" + ewrite(0,*) "Error has occured in differentiate_field_lumped_multiple, with field, ", trim(infields(i)%name) + FLAbort("The field_derivatives code cannot take the derivative of a discontinuous field") + end if end do call allocate(lumped_mass_matrix, mesh, "LumpedMassMatrix") call zero(lumped_mass_matrix) do i=1, size(infields) - if (compute(i)) then - call allocate(gradient(i), positions%dim, mesh, "Gradient") - call zero(gradient(i)) - end if + if (compute(i)) then + call allocate(gradient(i), positions%dim, mesh, "Gradient") + call zero(gradient(i)) + end if end do ! First, compute gradient and mass matrix. do ele=1, element_count(mesh) - call differentiate_field_ele(ele) + call differentiate_field_ele(ele) end do do i=1, size(infields) - if (compute(i)) then - k=0 - do j=1, positions%dim - if (derivatives(j)) then - k=k+1 - call set( pardiff(k,i), gradient(i), dim=j ) - end if - end do - else - do k=1, size(pardiff,1) - call zero(pardiff(k,i)) - end do - end if + if (compute(i)) then + k=0 + do j=1, positions%dim + if (derivatives(j)) then + k=k+1 + call set( pardiff(k,i), gradient(i), dim=j ) + end if + end do + else + do k=1, size(pardiff,1) + call zero(pardiff(k,i)) + end do + end if end do ! invert the lumped mass matrix @@ -1499,55 +1499,55 @@ subroutine differentiate_field_lumped_multiple(infields, positions, derivatives, ! compute pardiff=M^-1*pardiff do i=1, size(infields) - do k=1, size(pardiff,1) - call scale(pardiff(k,i), inverse_lumped_mass) - end do + do k=1, size(pardiff,1) + call scale(pardiff(k,i), inverse_lumped_mass) + end do end do do i=1, size(infields) - if (compute(i)) then - call deallocate(gradient(i)) - end if + if (compute(i)) then + call deallocate(gradient(i)) + end if end do call deallocate(lumped_mass_matrix) call deallocate(inverse_lumped_mass) - contains + contains subroutine differentiate_field_ele(ele) - integer, intent(in):: ele + integer, intent(in):: ele - real, dimension(mesh_dim(mesh), ele_loc(mesh, ele), ele_loc(infields(1), ele)) :: r - real, dimension(ele_ngi(mesh, ele)) :: detwei - real, dimension(ele_loc(infields(1), ele), ele_ngi(infields(1), ele), mesh_dim(infields(1))) :: dt_t - real, dimension(ele_loc(mesh, ele), ele_loc(mesh, ele)) :: mass_matrix + real, dimension(mesh_dim(mesh), ele_loc(mesh, ele), ele_loc(infields(1), ele)) :: r + real, dimension(ele_ngi(mesh, ele)) :: detwei + real, dimension(ele_loc(infields(1), ele), ele_ngi(infields(1), ele), mesh_dim(infields(1))) :: dt_t + real, dimension(ele_loc(mesh, ele), ele_loc(mesh, ele)) :: mass_matrix - integer i + integer i - ! Compute detwei. - call transform_to_physical(positions, ele, & - ele_shape(infields(1), ele), dshape=dt_t, detwei=detwei) + ! Compute detwei. + call transform_to_physical(positions, ele, & + ele_shape(infields(1), ele), dshape=dt_t, detwei=detwei) - r = shape_dshape(ele_shape(mesh, ele), dt_t, detwei) - do i=1, size(infields) + r = shape_dshape(ele_shape(mesh, ele), dt_t, detwei) + do i=1, size(infields) - if (compute(i)) then - call addto(gradient(i), ele_nodes(mesh, ele), & - tensormul(r, ele_val(infields(i), ele), 3) ) - end if + if (compute(i)) then + call addto(gradient(i), ele_nodes(mesh, ele), & + tensormul(r, ele_val(infields(i), ele), 3) ) + end if - end do + end do - ! Lump the mass matrix - mass_matrix = shape_shape(ele_shape(mesh, ele), ele_shape(mesh, ele), detwei) - call addto(lumped_mass_matrix, ele_nodes(mesh, ele), sum(mass_matrix, 2)) + ! Lump the mass matrix + mass_matrix = shape_shape(ele_shape(mesh, ele), ele_shape(mesh, ele), detwei) + call addto(lumped_mass_matrix, ele_nodes(mesh, ele), sum(mass_matrix, 2)) end subroutine differentiate_field_ele - end subroutine differentiate_field_lumped_multiple + end subroutine differentiate_field_lumped_multiple - subroutine differentiate_field_lumped_single(infield, positions, derivatives, pardiff) - !!< This routine computes the first derivatives using a weak finite element formulation. + subroutine differentiate_field_lumped_single(infield, positions, derivatives, pardiff) + !!< This routine computes the first derivatives using a weak finite element formulation. type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -1559,10 +1559,10 @@ subroutine differentiate_field_lumped_single(infield, positions, derivatives, pa call differentiate_field_lumped_multiple( (/ infield /), positions, derivatives, pardiffs) - end subroutine differentiate_field_lumped_single + end subroutine differentiate_field_lumped_single - subroutine differentiate_field_lumped_vector(infield, positions, outfield) - !!< This routine computes the derivatives of a vector field returning a tensor field + subroutine differentiate_field_lumped_vector(infield, positions, outfield) + !!< This routine computes the derivatives of a vector field returning a tensor field type(vector_field), intent(in), target :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout) :: outfield @@ -1574,17 +1574,17 @@ subroutine differentiate_field_lumped_vector(infield, positions, outfield) derivatives=.true. do i=1, infield%dim - infields(i)=extract_scalar_field(infield, i) - do j=1, positions%dim - pardiffs(j, i)=extract_scalar_field(outfield, j, i) - end do + infields(i)=extract_scalar_field(infield, i) + do j=1, positions%dim + pardiffs(j, i)=extract_scalar_field(outfield, j, i) + end do end do call differentiate_field_lumped_multiple( infields, positions, derivatives, pardiffs) - end subroutine differentiate_field_lumped_vector + end subroutine differentiate_field_lumped_vector - subroutine differentiate_field(infield, positions, derivatives, pardiff, bc_value, bc_type) + subroutine differentiate_field(infield, positions, derivatives, pardiff, bc_value, bc_type) type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -1598,20 +1598,20 @@ subroutine differentiate_field(infield, positions, derivatives, pardiff, bc_valu type(mesh_type), pointer :: mesh if (infield%field_type == FIELD_TYPE_CONSTANT) then - do i=1,count(derivatives) - call zero(pardiff(i)) - end do - return + do i=1,count(derivatives) + call zero(pardiff(i)) + end do + return end if if (continuity(infield)<0) then - call differentiate_discontinuous_field(infield, positions, derivatives, pardiff, bc_value, bc_type) - return + call differentiate_discontinuous_field(infield, positions, derivatives, pardiff, bc_value, bc_type) + return end if if (continuity(pardiff(1))<0) then - call differentiate_field_discontinuous(infield, positions, derivatives, pardiff) - return + call differentiate_field_discontinuous(infield, positions, derivatives, pardiff) + return end if mesh => infield%mesh @@ -1619,16 +1619,16 @@ subroutine differentiate_field(infield, positions, derivatives, pardiff, bc_valu call differentiate_field_lumped_single(infield, positions, derivatives, pardiff) if (pseudo2d_coord /= 0) then - if (derivatives(pseudo2d_coord)) then - ! which pardiff corresponds to dimension pseudo2d_coord? - i = count(derivatives(1:pseudo2d_coord)) - call zero(pardiff(i)) - end if + if (derivatives(pseudo2d_coord)) then + ! which pardiff corresponds to dimension pseudo2d_coord? + i = count(derivatives(1:pseudo2d_coord)) + call zero(pardiff(i)) + end if end if - end subroutine differentiate_field + end subroutine differentiate_field - subroutine differentiate_discontinuous_field(infield, positions, derivatives, pardiff, bc_value, bc_type) + subroutine differentiate_discontinuous_field(infield, positions, derivatives, pardiff, bc_value, bc_type) type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -1640,27 +1640,27 @@ subroutine differentiate_discontinuous_field(infield, positions, derivatives, pa integer :: ele, i if (infield%field_type == FIELD_TYPE_CONSTANT) then - do i=1,count(derivatives) - if (derivatives(i)) then - call zero(pardiff(i)) - end if - end do - return + do i=1,count(derivatives) + if (derivatives(i)) then + call zero(pardiff(i)) + end if + end do + return end if ! only works if all pardiff fields are discontinuous: do i=1, count(derivatives) - assert(pardiff(i)%mesh%continuity<0) + assert(pardiff(i)%mesh%continuity<0) end do ! calculate gradient do ele = 1, ele_count(infield) - call calculate_grad_ele_dg(infield, positions, derivatives, pardiff, ele, bc_value, bc_type) + call calculate_grad_ele_dg(infield, positions, derivatives, pardiff, ele, bc_value, bc_type) end do - end subroutine differentiate_discontinuous_field + end subroutine differentiate_discontinuous_field - subroutine calculate_grad_ele_dg(infield, positions, derivatives, pardiff, ele, bc_value, bc_type) + subroutine calculate_grad_ele_dg(infield, positions, derivatives, pardiff, ele, bc_value, bc_type) type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -1676,7 +1676,7 @@ subroutine calculate_grad_ele_dg(infield, positions, derivatives, pardiff, ele, ! In parallel, we only construct the equations on elements we own, or ! those in the L1 halo. if (.not.(element_owned(infield, ele).or.element_neighbour_owned(infield, ele))) then - return + return end if ! Get dg grad @@ -1684,14 +1684,14 @@ subroutine calculate_grad_ele_dg(infield, positions, derivatives, pardiff, ele, ! set pardiffs do i = 1, positions%dim - if (derivatives(i)) then - call set(pardiff(i), ele_nodes(pardiff(i), ele), rhs(i,:)) - end if + if (derivatives(i)) then + call set(pardiff(i), ele_nodes(pardiff(i), ele), rhs(i,:)) + end if end do - end subroutine calculate_grad_ele_dg + end subroutine calculate_grad_ele_dg - subroutine differentiate_field_discontinuous(infield, positions, derivatives, pardiff) + subroutine differentiate_field_discontinuous(infield, positions, derivatives, pardiff) type(scalar_field), intent(in), target :: infield type(vector_field), intent(in) :: positions logical, dimension(:), intent(in) :: derivatives @@ -1707,25 +1707,25 @@ subroutine differentiate_field_discontinuous(infield, positions, derivatives, pa integer ele, gi, i, j if (infield%field_type == FIELD_TYPE_CONSTANT) then - do i=1,count(derivatives) - if (derivatives(i)) then - call zero(pardiff(i)) - end if - end do - return + do i=1,count(derivatives) + if (derivatives(i)) then + call zero(pardiff(i)) + end if + end do + return end if ! only works if all pardiff fields are discontinuous: do i=1, count(derivatives) - assert(pardiff(i)%mesh%continuity<0) + assert(pardiff(i)%mesh%continuity<0) end do ! and the infield is continuous!!!! if (infield%mesh%continuity<0) then - ewrite(0,*) "If the following error is directly due to user input" - ewrite(0,*) "a check and a more helpful error message should be inserted in" - ewrite(0,*) "the calling routine (outside field_derivatives) - please mantis this:" - ewrite(0,*) "Error has occured in differentiate_field_discontinuous, with field, ", trim(infield%name) - FLAbort("Shouldn't get here?") + ewrite(0,*) "If the following error is directly due to user input" + ewrite(0,*) "a check and a more helpful error message should be inserted in" + ewrite(0,*) "the calling routine (outside field_derivatives) - please mantis this:" + ewrite(0,*) "Error has occured in differentiate_field_discontinuous, with field, ", trim(infield%name) + FLAbort("Shouldn't get here?") end if xshape=ele_shape(positions, 1) @@ -1754,13 +1754,13 @@ subroutine differentiate_field_discontinuous(infield, positions, derivatives, pa r=matmul(M, matmul(Q(i,:,:), ele_val(infield, ele))) call set(pardiff(j), ele_nodes(pardiff(j), ele), r) end if - end do + end do end do - end subroutine differentiate_field_discontinuous + end subroutine differentiate_field_discontinuous - subroutine compute_hessian(infield, positions, hessian) + subroutine compute_hessian(infield, positions, hessian) type(scalar_field), intent(inout) :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout) :: hessian @@ -1768,22 +1768,22 @@ subroutine compute_hessian(infield, positions, hessian) integer :: node if (infield%field_type == FIELD_TYPE_CONSTANT) then - call zero(hessian) - return + call zero(hessian) + return end if call add_nelist(infield%mesh) call compute_hessian_real(infield, positions, hessian) if (pseudo2d_coord /= 0) then - do node=1,node_count(hessian) - hessian%val(pseudo2d_coord, :, node) = 0.0 - hessian%val(:, pseudo2d_coord, node) = 0.0 - end do + do node=1,node_count(hessian) + hessian%val(pseudo2d_coord, :, node) = 0.0 + hessian%val(:, pseudo2d_coord, node) = 0.0 + end do end if - end subroutine compute_hessian + end subroutine compute_hessian - subroutine curl(infield, positions, curl_norm, curl_field) + subroutine curl(infield, positions, curl_norm, curl_field) type(vector_field), intent(in) :: positions, infield type(scalar_field), intent(inout), optional :: curl_norm ! norm of curl_field type(vector_field), intent(inout), optional :: curl_field @@ -1799,85 +1799,85 @@ subroutine curl(infield, positions, curl_norm, curl_field) call add_nelist(mesh) do i=1,positions%dim - call allocate(grad_v(i), positions%dim, infield%mesh, "Grad V") - call grad(extract_scalar_field(infield, i), positions, grad_v(i)) + call allocate(grad_v(i), positions%dim, infield%mesh, "Grad V") + call grad(extract_scalar_field(infield, i), positions, grad_v(i)) end do if (present(curl_field)) then - call zero(curl_field) + call zero(curl_field) end if if (present(curl_norm)) then - call zero(curl_norm) + call zero(curl_norm) end if do i=1,node_count(infield) - a = grad_v(3)%val(2,i) - grad_v(2)%val(3,i) ! dw/dy - dv/dz - b = grad_v(1)%val(3,i) - grad_v(3)%val(1,i) ! du/dz - dw/dx - c = grad_v(2)%val(1,i) - grad_v(1)%val(2,i) ! dv/dx - du/dy - if (present(curl_norm)) then - w = sqrt(a**2 + b**2 + c**2) - call addto(curl_norm, i, w) - end if - if (present(curl_field)) then - call addto(curl_field, i, (/a, b, c/)) - end if + a = grad_v(3)%val(2,i) - grad_v(2)%val(3,i) ! dw/dy - dv/dz + b = grad_v(1)%val(3,i) - grad_v(3)%val(1,i) ! du/dz - dw/dx + c = grad_v(2)%val(1,i) - grad_v(1)%val(2,i) ! dv/dx - du/dy + if (present(curl_norm)) then + w = sqrt(a**2 + b**2 + c**2) + call addto(curl_norm, i, w) + end if + if (present(curl_field)) then + call addto(curl_field, i, (/a, b, c/)) + end if end do do i=1,positions%dim - call deallocate(grad_v(i)) + call deallocate(grad_v(i)) end do - end subroutine curl + end subroutine curl - subroutine u_dot_nabla_scalar(v_field, in_field, positions, out_field) - !!< Calculates (u dot nabla) in_field for scalar fields + subroutine u_dot_nabla_scalar(v_field, in_field, positions, out_field) + !!< Calculates (u dot nabla) in_field for scalar fields - type(vector_field), intent(in) :: v_field - type(scalar_field), intent(in) :: in_field - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: out_field + type(vector_field), intent(in) :: v_field + type(scalar_field), intent(in) :: in_field + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: out_field - integer :: i - real, dimension(positions%dim) :: grad_val_at_node, & + integer :: i + real, dimension(positions%dim) :: grad_val_at_node, & & v_field_val_at_node - type(vector_field) :: gradient + type(vector_field) :: gradient - call allocate(gradient, positions%dim, in_field%mesh, "Gradient") + call allocate(gradient, positions%dim, in_field%mesh, "Gradient") - call grad(in_field, positions, gradient) + call grad(in_field, positions, gradient) - call zero(out_field) - do i = 1, node_count(out_field) - grad_val_at_node = node_val(gradient, i) - v_field_val_at_node = node_val(v_field, i) - call set(out_field, i, & - & dot_product(v_field_val_at_node, grad_val_at_node)) - end do + call zero(out_field) + do i = 1, node_count(out_field) + grad_val_at_node = node_val(gradient, i) + v_field_val_at_node = node_val(v_field, i) + call set(out_field, i, & + & dot_product(v_field_val_at_node, grad_val_at_node)) + end do - call deallocate(gradient) + call deallocate(gradient) - end subroutine u_dot_nabla_scalar + end subroutine u_dot_nabla_scalar - subroutine u_dot_nabla_vector(v_field, in_field, positions, out_field) - !!< Calculates (u dot nabla) in_field for vector fields + subroutine u_dot_nabla_vector(v_field, in_field, positions, out_field) + !!< Calculates (u dot nabla) in_field for vector fields - type(vector_field), intent(in) :: v_field - type(vector_field), intent(in) :: in_field - type(vector_field), intent(in) :: positions - type(vector_field), intent(inout) :: out_field + type(vector_field), intent(in) :: v_field + type(vector_field), intent(in) :: in_field + type(vector_field), intent(in) :: positions + type(vector_field), intent(inout) :: out_field - integer :: i - type(scalar_field) :: out_field_comp + integer :: i + type(scalar_field) :: out_field_comp - do i = 1, v_field%dim - out_field_comp = extract_scalar_field(out_field, i) - call u_dot_nabla(v_field, & - & extract_scalar_field(in_field, i), positions, & - & out_field_comp) - end do + do i = 1, v_field%dim + out_field_comp = extract_scalar_field(out_field, i) + call u_dot_nabla(v_field, & + & extract_scalar_field(in_field, i), positions, & + & out_field_comp) + end do - end subroutine u_dot_nabla_vector + end subroutine u_dot_nabla_vector ! subroutine compute_hessian_eqf(infield, positions, hessian) ! !!< This routine computes the hessian using the method suggested @@ -1897,7 +1897,7 @@ end subroutine u_dot_nabla_vector ! real, dimension(MATRIX_SIZE_QF) :: b ! end subroutine compute_hessian_eqf - function get_quadratic_fit_eqf(infield, positions, ele, gradient) result(b) + function get_quadratic_fit_eqf(infield, positions, ele, gradient) result(b) !!< Implement Chris' idea for computing the Hessian. !!< The idea is, for a given element, construct a quadratic polynomial !!< expansion of the field over that element by constraining it as follows: @@ -1928,31 +1928,31 @@ function get_quadratic_fit_eqf(infield, positions, ele, gradient) result(b) centroid = insphere_tet(ele_val(positions, ele)) do j=1,4 - A(i, :) = getP_qf(node_val(positions, nodelist(j))) - b(i) = node_val(infield, nodelist(j)) - i = i + 1 + A(i, :) = getP_qf(node_val(positions, nodelist(j))) + b(i) = node_val(infield, nodelist(j)) + i = i + 1 end do do j=1,4 - do k=j+1,4 - edge_centre = (node_val(positions, nodelist(j)) + node_val(positions, nodelist(k))) / 2.0 - dir = centroid - edge_centre - !dir = node_val(positions, nodelist(k)) - node_val(positions, nodelist(j)) - A(i, 2) = dir(1); A(i, 3) = dir(2); A(i, 4) = dir(3) - A(i, 5) = 2 * dir(1) * edge_centre(1); A(i, 6) = 2 * dir(2) * edge_centre(2); A(i, 7) = 2 * dir(3) * edge_centre(3); - A(i, 8) = dir(1) * edge_centre(2) + dir(2) * edge_centre(1) - A(i, 9) = dir(3) * edge_centre(1) + dir(1) * edge_centre(3) - A(i, 10) = dir(2) * edge_centre(3) + dir(3) * edge_centre(2) - b(i) = dot_product((gradient(j, :) + gradient(k, :)) / 2.0, dir) - i = i + 1 - end do + do k=j+1,4 + edge_centre = (node_val(positions, nodelist(j)) + node_val(positions, nodelist(k))) / 2.0 + dir = centroid - edge_centre + !dir = node_val(positions, nodelist(k)) - node_val(positions, nodelist(j)) + A(i, 2) = dir(1); A(i, 3) = dir(2); A(i, 4) = dir(3) + A(i, 5) = 2 * dir(1) * edge_centre(1); A(i, 6) = 2 * dir(2) * edge_centre(2); A(i, 7) = 2 * dir(3) * edge_centre(3); + A(i, 8) = dir(1) * edge_centre(2) + dir(2) * edge_centre(1) + A(i, 9) = dir(3) * edge_centre(1) + dir(1) * edge_centre(3) + A(i, 10) = dir(2) * edge_centre(3) + dir(3) * edge_centre(2) + b(i) = dot_product((gradient(j, :) + gradient(k, :)) / 2.0, dir) + i = i + 1 + end do end do A(11, 11) = 1.0; b(11) = 0.0 call solve(A, b) - end function get_quadratic_fit_eqf + end function get_quadratic_fit_eqf - subroutine compute_hessian_eqf(infield, positions, hessian) + subroutine compute_hessian_eqf(infield, positions, hessian) type(scalar_field), intent(in) :: infield type(vector_field), intent(in) :: positions type(tensor_field), intent(inout) :: hessian @@ -1974,36 +1974,36 @@ subroutine compute_hessian_eqf(infield, positions, hessian) x_shape = ele_shape(positions, 1) do ele=1,ele_count(infield) - nodelist => ele_nodes(infield, ele) - fit = get_quadratic_fit_eqf(infield, positions, ele, transpose(ele_val(gradient, ele))) - do j=1,ele_loc(infield, ele) - node = nodelist(j) - x = node_val(positions, 1, node); y = node_val(positions, 2, node); z = node_val(positions, 3, node); - tmp_hessian(1, 1) = 2 * fit(5) - tmp_hessian(1, 2) = fit(8) + z * fit(11) - tmp_hessian(1, 3) = fit(9) + y * fit(11) - tmp_hessian(2, 1) = fit(8) + z * fit(11) - tmp_hessian(2, 2) = 2 * fit(6) - tmp_hessian(2, 3) = fit(10) + x * fit(11) - tmp_hessian(3, 1) = fit(9) + y * fit(11) - tmp_hessian(3, 2) = fit(10) + x * fit(11) - tmp_hessian(3, 3) = 2 * fit(7) - hessian%val(:, :, node) = hessian%val(:, :, node) + tmp_hessian - touched(node) = touched(node) + 1 - end do + nodelist => ele_nodes(infield, ele) + fit = get_quadratic_fit_eqf(infield, positions, ele, transpose(ele_val(gradient, ele))) + do j=1,ele_loc(infield, ele) + node = nodelist(j) + x = node_val(positions, 1, node); y = node_val(positions, 2, node); z = node_val(positions, 3, node); + tmp_hessian(1, 1) = 2 * fit(5) + tmp_hessian(1, 2) = fit(8) + z * fit(11) + tmp_hessian(1, 3) = fit(9) + y * fit(11) + tmp_hessian(2, 1) = fit(8) + z * fit(11) + tmp_hessian(2, 2) = 2 * fit(6) + tmp_hessian(2, 3) = fit(10) + x * fit(11) + tmp_hessian(3, 1) = fit(9) + y * fit(11) + tmp_hessian(3, 2) = fit(10) + x * fit(11) + tmp_hessian(3, 3) = 2 * fit(7) + hessian%val(:, :, node) = hessian%val(:, :, node) + tmp_hessian + touched(node) = touched(node) + 1 + end do end do do node=1,node_count(hessian) - hessian%val(:, :, node) = hessian%val(:, :, node) / touched(node) + hessian%val(:, :, node) = hessian%val(:, :, node) / touched(node) end do call hessian_boundary_correction(hessian, positions, t_shape) call hessian_squash_pseudo2d(hessian) call deallocate(gradient) - end subroutine compute_hessian_eqf + end subroutine compute_hessian_eqf - subroutine div(infield, positions, divergence) + subroutine div(infield, positions, divergence) !! Implement div() operator. type(vector_field), intent(in):: infield, positions type(scalar_field), intent(inout), target :: divergence @@ -2021,17 +2021,17 @@ subroutine div(infield, positions, divergence) derivatives = .false. do i=1,mesh_dim(infield) - derivatives(i) = .true. - component = extract_scalar_field(infield, i) - call differentiate_field(component, positions, derivatives, derivative) - call addto(divergence, derivative(1)) - derivatives = .false. + derivatives(i) = .true. + component = extract_scalar_field(infield, i) + call differentiate_field(component, positions, derivatives, derivative) + call addto(divergence, derivative(1)) + derivatives = .false. end do call deallocate(derivative(1)) - end subroutine div + end subroutine div - function insphere_tet(positions) result(centre) + function insphere_tet(positions) result(centre) !! dim x loc real, dimension(3, 4), intent(in) :: positions real, dimension(size(positions, 1)) :: centre @@ -2057,9 +2057,9 @@ function insphere_tet(positions) result(centre) O1 = s - p t = dot_product(w, s) / dot_product(y, O1) centre = positions(:, 1) + t * y - end function insphere_tet + end function insphere_tet - recursive function get_cubic_fit_cf(infield, positions, node, level, maxlevel) result(b) + recursive function get_cubic_fit_cf(infield, positions, node, level, maxlevel) result(b) !!< Fit a cubic function to infield around the node, !!< with a least squares approach. type(scalar_field), intent(in) :: infield @@ -2077,58 +2077,58 @@ recursive function get_cubic_fit_cf(infield, positions, node, level, maxlevel) r type(mesh_type) :: mesh if (present(level)) then - llevel = level + llevel = level else - llevel = 2 + llevel = 2 end if if (present(maxlevel)) then - lmaxlevel = maxlevel + lmaxlevel = maxlevel else - lmaxlevel = llevel + 1 + lmaxlevel = llevel + 1 end if mesh = infield%mesh node_patch = get_patch_node(mesh, node, level=llevel, min_nodes=min(node_count(mesh), int(2.5 * MATRIX_SIZE_CF))) A = 0.0; b_tmp = 0.0 do i=1,node_patch%count - nnode = node_patch%elements(i) + nnode = node_patch%elements(i) - A = A + compute_matrix_contribution_cf(node_val(positions, nnode)) - b_tmp(:, 1) = b_tmp(:, 1) + compute_rhs_contribution_cf(node_val(positions, nnode), node_val(infield, nnode)) + A = A + compute_matrix_contribution_cf(node_val(positions, nnode)) + b_tmp(:, 1) = b_tmp(:, 1) + compute_rhs_contribution_cf(node_val(positions, nnode), node_val(infield, nnode)) end do if (pseudo2d_coord /= 0) then - if (pseudo2d_coord == 1) then - A_2D = A(CF_2D_X, CF_2D_X) - b_tmp_2D(:, 1) = b_tmp(CF_2D_X, 1) - call solve(A_2D, b_tmp_2D, stat) - b = 0.0; b(CF_2D_X) = b_tmp_2D(:, 1) - else if (pseudo2d_coord == 2) then - A_2D = A(CF_2D_Y, CF_2D_Y) - b_tmp_2D(:, 1) = b_tmp(CF_2D_Y, 1) - call solve(A_2D, b_tmp_2D, stat) - b = 0.0; b(CF_2D_Y) = b_tmp_2D(:, 1) - else if (pseudo2d_coord == 3) then - A_2D = A(CF_2D_Z, CF_2D_Z) - b_tmp_2D(:, 1) = b_tmp(CF_2D_Z, 1) - call solve(A_2D, b_tmp_2D, stat) - b = 0.0; b(CF_2D_Z) = b_tmp_2D(:, 1) - end if + if (pseudo2d_coord == 1) then + A_2D = A(CF_2D_X, CF_2D_X) + b_tmp_2D(:, 1) = b_tmp(CF_2D_X, 1) + call solve(A_2D, b_tmp_2D, stat) + b = 0.0; b(CF_2D_X) = b_tmp_2D(:, 1) + else if (pseudo2d_coord == 2) then + A_2D = A(CF_2D_Y, CF_2D_Y) + b_tmp_2D(:, 1) = b_tmp(CF_2D_Y, 1) + call solve(A_2D, b_tmp_2D, stat) + b = 0.0; b(CF_2D_Y) = b_tmp_2D(:, 1) + else if (pseudo2d_coord == 3) then + A_2D = A(CF_2D_Z, CF_2D_Z) + b_tmp_2D(:, 1) = b_tmp(CF_2D_Z, 1) + call solve(A_2D, b_tmp_2D, stat) + b = 0.0; b(CF_2D_Z) = b_tmp_2D(:, 1) + end if else - call solve(A, b_tmp, stat) - b = b_tmp(:, 1) + call solve(A, b_tmp, stat) + b = b_tmp(:, 1) end if if (llevel < lmaxlevel) then - if (stat /= 0) then - ! If the solver fails, go one more level deep - ! to get enough equations to do the fitting - b = get_cubic_fit_cf(infield, positions, node, level=llevel+1) - end if + if (stat /= 0) then + ! If the solver fails, go one more level deep + ! to get enough equations to do the fitting + b = get_cubic_fit_cf(infield, positions, node, level=llevel+1) + end if end if deallocate(node_patch%elements) ! Have to do it here; otherwise memory leak - end function get_cubic_fit_cf + end function get_cubic_fit_cf end module field_derivatives diff --git a/femtools/Fields.F90 b/femtools/Fields.F90 index 4e89c3be33..c2d6f3dff9 100644 --- a/femtools/Fields.F90 +++ b/femtools/Fields.F90 @@ -26,18 +26,18 @@ ! USA #include "fdebug.h" module fields - !!< This module contains abstracted field types which carry shape and - !!< connectivity with them. + !!< This module contains abstracted field types which carry shape and + !!< connectivity with them. - ! this is a wrapper module providing the routines specified in the following modules: - use fields_data_types ! the derived types of the basic objects - use fields_base ! all basic enquiry functions and field evaluation at nodes and elements - use fields_allocates ! allocates, deallocates and all other routines creating field or mesh objects - use fields_manipulation ! all routines that do operations on existing fields to change their values - use fields_calculations ! all calculation routines that return values or complete new fields + ! this is a wrapper module providing the routines specified in the following modules: + use fields_data_types ! the derived types of the basic objects + use fields_base ! all basic enquiry functions and field evaluation at nodes and elements + use fields_allocates ! allocates, deallocates and all other routines creating field or mesh objects + use fields_manipulation ! all routines that do operations on existing fields to change their values + use fields_calculations ! all calculation routines that return values or complete new fields - implicit none + implicit none - public + public end module fields diff --git a/femtools/Fields_Allocates.F90 b/femtools/Fields_Allocates.F90 index 7adedac664..66bb65a5ea 100644 --- a/femtools/Fields_Allocates.F90 +++ b/femtools/Fields_Allocates.F90 @@ -26,127 +26,127 @@ ! USA #include "fdebug.h" module fields_allocates -use fldebug -use global_parameters, only: PYTHON_FUNC_LEN, empty_path, empty_name, & - topology_mesh_name, NUM_COLOURINGS -use futils, only: present_and_true -use quadrature -use element_numbering -use elements -use ieee_arithmetic -use halo_data_types -use parallel_tools -use halos_allocates -use memory_diagnostics -use data_structures -use sparse_tools -use shape_functions, only: make_element_shape -use fields_data_types -use fields_base -use halos_repair -use pickers_deallocates -use adjacency_lists -use global_numbering, only: make_global_numbering, make_global_numbering_dg,& - &make_global_numbering_trace - -implicit none - - private - - public :: allocate, deallocate, incref, decref, has_references, add_faces, & - & deallocate_faces, zero - public :: make_element_shape, make_mesh, make_mesh_periodic, make_submesh, & - & create_surface_mesh, make_fake_mesh_linearnonconforming - public :: extract_scalar_field, wrap_mesh, wrap_scalar_field, & - & wrap_tensor_field - public :: add_lists, extract_lists, add_nnlist, extract_nnlist, add_nelist, & - & extract_nelist, add_eelist, extract_eelist, remove_lists, remove_nnlist, & - & remove_nelist, remove_eelist, extract_elements, remove_boundary_conditions - - interface allocate - module procedure allocate_scalar_field, allocate_vector_field,& - & allocate_tensor_field, allocate_mesh, & - & allocate_scalar_boundary_condition, & - & allocate_vector_boundary_condition - end interface - - interface deallocate - module procedure deallocate_mesh, deallocate_scalar_field,& - & deallocate_vector_field, deallocate_tensor_field, & - & deallocate_scalar_boundary_condition, & - & deallocate_vector_boundary_condition - end interface - - interface zero - module procedure zero_scalar, zero_vector, zero_tensor, & - zero_vector_dim, zero_tensor_dim_dim, & - zero_scalar_field_nodes, zero_vector_field_nodes, zero_tensor_field_nodes - end interface - - interface deallocate_faces - module procedure deallocate_mesh_faces - end interface - - interface add_lists - module procedure add_lists_mesh, add_lists_scalar, add_lists_vector, & + use fldebug + use global_parameters, only: PYTHON_FUNC_LEN, empty_path, empty_name, & + topology_mesh_name, NUM_COLOURINGS + use futils, only: present_and_true + use quadrature + use element_numbering + use elements + use ieee_arithmetic + use halo_data_types + use parallel_tools + use halos_allocates + use memory_diagnostics + use data_structures + use sparse_tools + use shape_functions, only: make_element_shape + use fields_data_types + use fields_base + use halos_repair + use pickers_deallocates + use adjacency_lists + use global_numbering, only: make_global_numbering, make_global_numbering_dg,& + &make_global_numbering_trace + + implicit none + + private + + public :: allocate, deallocate, incref, decref, has_references, add_faces, & + & deallocate_faces, zero + public :: make_element_shape, make_mesh, make_mesh_periodic, make_submesh, & + & create_surface_mesh, make_fake_mesh_linearnonconforming + public :: extract_scalar_field, wrap_mesh, wrap_scalar_field, & + & wrap_tensor_field + public :: add_lists, extract_lists, add_nnlist, extract_nnlist, add_nelist, & + & extract_nelist, add_eelist, extract_eelist, remove_lists, remove_nnlist, & + & remove_nelist, remove_eelist, extract_elements, remove_boundary_conditions + + interface allocate + module procedure allocate_scalar_field, allocate_vector_field,& + & allocate_tensor_field, allocate_mesh, & + & allocate_scalar_boundary_condition, & + & allocate_vector_boundary_condition + end interface + + interface deallocate + module procedure deallocate_mesh, deallocate_scalar_field,& + & deallocate_vector_field, deallocate_tensor_field, & + & deallocate_scalar_boundary_condition, & + & deallocate_vector_boundary_condition + end interface + + interface zero + module procedure zero_scalar, zero_vector, zero_tensor, & + zero_vector_dim, zero_tensor_dim_dim, & + zero_scalar_field_nodes, zero_vector_field_nodes, zero_tensor_field_nodes + end interface + + interface deallocate_faces + module procedure deallocate_mesh_faces + end interface + + interface add_lists + module procedure add_lists_mesh, add_lists_scalar, add_lists_vector, & & add_lists_tensor - end interface add_lists + end interface add_lists - interface extract_lists - module procedure extract_lists_mesh, extract_lists_scalar, & + interface extract_lists + module procedure extract_lists_mesh, extract_lists_scalar, & & extract_lists_vector, extract_lists_tensor - end interface extract_lists + end interface extract_lists - interface add_nnlist - module procedure add_nnlist_mesh, add_nnlist_scalar, add_nnlist_vector, & + interface add_nnlist + module procedure add_nnlist_mesh, add_nnlist_scalar, add_nnlist_vector, & & add_nnlist_tensor - end interface add_nnlist + end interface add_nnlist - interface extract_nnlist - module procedure extract_nnlist_mesh, extract_nnlist_scalar, & + interface extract_nnlist + module procedure extract_nnlist_mesh, extract_nnlist_scalar, & & extract_nnlist_vector, extract_nnlist_tensor - end interface extract_nnlist + end interface extract_nnlist - interface add_nelist - module procedure add_nelist_mesh, add_nelist_scalar, add_nelist_vector, & + interface add_nelist + module procedure add_nelist_mesh, add_nelist_scalar, add_nelist_vector, & & add_nelist_tensor - end interface add_nelist + end interface add_nelist - interface extract_nelist - module procedure extract_nelist_mesh, extract_nelist_scalar, & + interface extract_nelist + module procedure extract_nelist_mesh, extract_nelist_scalar, & & extract_nelist_vector, extract_nelist_tensor - end interface extract_nelist + end interface extract_nelist - interface add_eelist - module procedure add_eelist_mesh, add_eelist_scalar, add_eelist_vector, & + interface add_eelist + module procedure add_eelist_mesh, add_eelist_scalar, add_eelist_vector, & & add_eelist_tensor - end interface add_eelist + end interface add_eelist - interface extract_eelist - module procedure extract_eelist_mesh, extract_eelist_scalar, & + interface extract_eelist + module procedure extract_eelist_mesh, extract_eelist_scalar, & & extract_eelist_vector, extract_eelist_tensor - end interface extract_eelist + end interface extract_eelist - interface remove_lists - module procedure remove_lists_mesh - end interface remove_lists + interface remove_lists + module procedure remove_lists_mesh + end interface remove_lists - interface remove_nnlist - module procedure remove_nnlist_mesh - end interface remove_nnlist + interface remove_nnlist + module procedure remove_nnlist_mesh + end interface remove_nnlist - interface remove_nelist - module procedure remove_nelist_mesh - end interface remove_nelist + interface remove_nelist + module procedure remove_nelist_mesh + end interface remove_nelist - interface remove_eelist - module procedure remove_eelist_mesh - end interface remove_eelist + interface remove_eelist + module procedure remove_eelist_mesh + end interface remove_eelist - interface remove_boundary_conditions - module procedure remove_boundary_conditions_scalar, & - remove_boundary_conditions_vector - end interface remove_boundary_conditions + interface remove_boundary_conditions + module procedure remove_boundary_conditions_scalar, & + remove_boundary_conditions_vector + end interface remove_boundary_conditions #include "Reference_count_interface_mesh_type.F90" #include "Reference_count_interface_scalar_field.F90" @@ -155,2195 +155,2195 @@ module fields_allocates contains - subroutine allocate_mesh(mesh, nodes, elements, shape, name) - type(mesh_type), intent(out) :: mesh - integer, intent(in) :: nodes, elements - type(element_type), target, intent(in) :: shape - character(len=*), intent(in), optional :: name - integer :: i + subroutine allocate_mesh(mesh, nodes, elements, shape, name) + type(mesh_type), intent(out) :: mesh + integer, intent(in) :: nodes, elements + type(element_type), target, intent(in) :: shape + character(len=*), intent(in), optional :: name + integer :: i #ifdef _OPENMP - integer :: j + integer :: j #endif - mesh%nodes=nodes + mesh%nodes=nodes - mesh%elements=elements + mesh%elements=elements - mesh%shape=shape - call incref(shape) + mesh%shape=shape + call incref(shape) - if (present(name)) then - mesh%name=name - else - mesh%name=empty_name - end if + if (present(name)) then + mesh%name=name + else + mesh%name=empty_name + end if - ! should happen in derived type initialisation already, - ! but just to make sure in case an mesh variable is supplied - ! that has previously been used for something else: - nullify(mesh%faces) - nullify(mesh%columns) - nullify(mesh%element_columns) + ! should happen in derived type initialisation already, + ! but just to make sure in case an mesh variable is supplied + ! that has previously been used for something else: + nullify(mesh%faces) + nullify(mesh%columns) + nullify(mesh%element_columns) - allocate(mesh%colourings(NUM_COLOURINGS)) - do i = 1, NUM_COLOURINGS - nullify(mesh%colourings(i)%sets) - end do - allocate(mesh%ndglno(elements*shape%loc)) + allocate(mesh%colourings(NUM_COLOURINGS)) + do i = 1, NUM_COLOURINGS + nullify(mesh%colourings(i)%sets) + end do + allocate(mesh%ndglno(elements*shape%loc)) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do i=1, mesh%elements - do j=1, shape%loc - mesh%ndglno((i-1)*shape%loc+j)=0 - end do - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do i=1, mesh%elements + do j=1, shape%loc + mesh%ndglno((i-1)*shape%loc+j)=0 + end do + end do + !$OMP END PARALLEL DO #endif #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", elements*shape%loc,& - & name=mesh%name) + call register_allocation("mesh_type", "integer", elements*shape%loc,& + & name=mesh%name) #endif - allocate(mesh%adj_lists) - mesh%wrapped=.false. - nullify(mesh%region_ids) - nullify(mesh%subdomain_mesh) - nullify(mesh%refcount) ! Hack for gfortran component initialisation - ! bug. - mesh%periodic=.false. - - call addref(mesh) - - end subroutine allocate_mesh - - subroutine allocate_scalar_field(field, mesh, name, field_type, py_func, py_positions) - type(scalar_field), intent(out) :: field - type(mesh_type), intent(in), target :: mesh - character(len=*), intent(in),optional :: name - integer, intent(in), optional :: field_type - - character(len=*), intent(in), optional :: py_func - type(vector_field), intent(in), optional, target :: py_positions - - integer :: lfield_type - integer :: stat - integer :: toloc - - if (present(field_type)) then - lfield_type = field_type - else - lfield_type = FIELD_TYPE_NORMAL - end if - - field%mesh=mesh - call incref(mesh) - - if (present(name)) then - field%name=name - else - field%name=empty_name - end if - - field%field_type = lfield_type - select case(lfield_type) - case(FIELD_TYPE_NORMAL) - allocate(field%val(node_count(mesh))) - field%py_dim = mesh_dim(mesh) - field%py_positions_shape => mesh%shape + allocate(mesh%adj_lists) + mesh%wrapped=.false. + nullify(mesh%region_ids) + nullify(mesh%subdomain_mesh) + nullify(mesh%refcount) ! Hack for gfortran component initialisation + ! bug. + mesh%periodic=.false. + + call addref(mesh) + + end subroutine allocate_mesh + + subroutine allocate_scalar_field(field, mesh, name, field_type, py_func, py_positions) + type(scalar_field), intent(out) :: field + type(mesh_type), intent(in), target :: mesh + character(len=*), intent(in),optional :: name + integer, intent(in), optional :: field_type + + character(len=*), intent(in), optional :: py_func + type(vector_field), intent(in), optional, target :: py_positions + + integer :: lfield_type + integer :: stat + integer :: toloc + + if (present(field_type)) then + lfield_type = field_type + else + lfield_type = FIELD_TYPE_NORMAL + end if + + field%mesh=mesh + call incref(mesh) + + if (present(name)) then + field%name=name + else + field%name=empty_name + end if + + field%field_type = lfield_type + select case(lfield_type) + case(FIELD_TYPE_NORMAL) + allocate(field%val(node_count(mesh))) + field%py_dim = mesh_dim(mesh) + field%py_positions_shape => mesh%shape #ifdef HAVE_MEMORY_STATS - call register_allocation("scalar_field", "real", node_count(mesh), & - name=name) + call register_allocation("scalar_field", "real", node_count(mesh), & + name=name) #endif - case(FIELD_TYPE_CONSTANT) - allocate(field%val(1)) - field%py_dim = mesh_dim(mesh) - field%py_positions_shape => mesh%shape + case(FIELD_TYPE_CONSTANT) + allocate(field%val(1)) + field%py_dim = mesh_dim(mesh) + field%py_positions_shape => mesh%shape #ifdef HAVE_MEMORY_STATS - call register_allocation("scalar_field", "real", 1, name=name) + call register_allocation("scalar_field", "real", 1, name=name) #endif - case(FIELD_TYPE_DEFERRED) - allocate(field%val(0)) - field%py_dim = mesh_dim(mesh) - field%py_positions_shape => mesh%shape - case(FIELD_TYPE_PYTHON) - if (present(py_func)) then - field%py_func = py_func + case(FIELD_TYPE_DEFERRED) + allocate(field%val(0)) + field%py_dim = mesh_dim(mesh) + field%py_positions_shape => mesh%shape + case(FIELD_TYPE_PYTHON) + if (present(py_func)) then + field%py_func = py_func + else + if (stat /= 0) then + FLAbort("Field specified as FIELD_TYPE_PYTHON, but no func passed!") + end if + end if + + if (.not. present(py_positions)) then + FLAbort("Field specified as FIELD_TYPE_PYTHON but no positions field passed!") + end if + field%py_positions => py_positions + field%py_dim = py_positions%dim + field%py_positions_shape => py_positions%mesh%shape + call incref(field%py_positions_shape) + call incref(field%py_positions) + + if (associated(py_positions%mesh%refcount, mesh%refcount)) then + field%py_positions_same_mesh = .true. + else + field%py_positions_same_mesh = .false. + allocate(field%py_locweight(mesh%shape%loc, py_positions%mesh%shape%loc)) + do toloc=1,size(field%py_locweight,1) + field%py_locweight(toloc,:)=eval_shape(py_positions%mesh%shape, & + local_coords(toloc, mesh%shape)) + end do + end if + + call add_nelist(field%mesh) + end select + + field%wrapped=.false. + field%aliased=.false. + field%option_path=empty_path + allocate(field%bc) + nullify(field%refcount) ! Hacks for gfortran component initialisation + ! bug. + call addref(field) + + call zero(field) + + end subroutine allocate_scalar_field + + subroutine allocate_vector_field(field, dim, mesh, name, field_type) + type(vector_field), intent(out) :: field + integer, intent(in) :: dim + type(mesh_type), intent(in), target :: mesh + character(len=*), intent(in), optional :: name + integer, intent(in), optional :: field_type + integer :: n_count + integer :: lfield_type + + if (present(field_type)) then + lfield_type = field_type else - if (stat /= 0) then - FLAbort("Field specified as FIELD_TYPE_PYTHON, but no func passed!") - end if + lfield_type = FIELD_TYPE_NORMAL end if - if (.not. present(py_positions)) then - FLAbort("Field specified as FIELD_TYPE_PYTHON but no positions field passed!") - end if - field%py_positions => py_positions - field%py_dim = py_positions%dim - field%py_positions_shape => py_positions%mesh%shape - call incref(field%py_positions_shape) - call incref(field%py_positions) + field%dim=dim + field%option_path=empty_path - if (associated(py_positions%mesh%refcount, mesh%refcount)) then - field%py_positions_same_mesh = .true. + field%mesh=mesh + call incref(mesh) + + if (present(name)) then + field%name=name else - field%py_positions_same_mesh = .false. - allocate(field%py_locweight(mesh%shape%loc, py_positions%mesh%shape%loc)) - do toloc=1,size(field%py_locweight,1) - field%py_locweight(toloc,:)=eval_shape(py_positions%mesh%shape, & - local_coords(toloc, mesh%shape)) - end do + field%name=empty_name end if - call add_nelist(field%mesh) - end select - - field%wrapped=.false. - field%aliased=.false. - field%option_path=empty_path - allocate(field%bc) - nullify(field%refcount) ! Hacks for gfortran component initialisation - ! bug. - call addref(field) - - call zero(field) - - end subroutine allocate_scalar_field - - subroutine allocate_vector_field(field, dim, mesh, name, field_type) - type(vector_field), intent(out) :: field - integer, intent(in) :: dim - type(mesh_type), intent(in), target :: mesh - character(len=*), intent(in), optional :: name - integer, intent(in), optional :: field_type - integer :: n_count - integer :: lfield_type - - if (present(field_type)) then - lfield_type = field_type - else - lfield_type = FIELD_TYPE_NORMAL - end if - - field%dim=dim - field%option_path=empty_path - - field%mesh=mesh - call incref(mesh) - - if (present(name)) then - field%name=name - else - field%name=empty_name - end if - - field%field_type = lfield_type - select case(lfield_type) - case(FIELD_TYPE_NORMAL) - n_count = node_count(mesh) - allocate(field%val(dim,n_count)) + field%field_type = lfield_type + select case(lfield_type) + case(FIELD_TYPE_NORMAL) + n_count = node_count(mesh) + allocate(field%val(dim,n_count)) #ifdef HAVE_MEMORY_STATS - call register_allocation("vector_field", "real", n_count*dim, & - name=name) + call register_allocation("vector_field", "real", n_count*dim, & + name=name) #endif - case(FIELD_TYPE_CONSTANT) - allocate(field%val(dim,1)) + case(FIELD_TYPE_CONSTANT) + allocate(field%val(dim,1)) #ifdef HAVE_MEMORY_STATS - call register_allocation("vector_field", "real", dim, name=name) + call register_allocation("vector_field", "real", dim, name=name) #endif - case(FIELD_TYPE_DEFERRED) - allocate(field%val(0,0)) - end select - - field%wrapped = .false. - field%aliased = .false. - allocate(field%bc) - nullify(field%refcount) ! Hack for gfortran component initialisation - ! bug. - - allocate(field%picker) - - call addref(field) - - call zero(field) - - end subroutine allocate_vector_field - - subroutine allocate_tensor_field(field, mesh, name, field_type, dim) - type(tensor_field), intent(inout) :: field - type(mesh_type), intent(in), target :: mesh - character(len=*), intent(in), optional :: name - integer, intent(in), optional :: field_type - integer, intent(in), dimension(2), optional :: dim - integer :: lfield_type - - if (present(field_type)) then - lfield_type = field_type - else - lfield_type = FIELD_TYPE_NORMAL - end if - - if(present(dim)) then - field%dim = dim - else - field%dim=(/mesh_dim(mesh),mesh_dim(mesh)/) - end if - field%option_path=empty_path - - field%mesh=mesh - call incref(mesh) - - if (present(name)) then - field%name=name - else - field%name=empty_name - end if - - field%field_type = lfield_type - select case(lfield_type) - case(FIELD_TYPE_NORMAL) - allocate(field%val(field%dim(1), field%dim(2), node_count(mesh))) + case(FIELD_TYPE_DEFERRED) + allocate(field%val(0,0)) + end select + + field%wrapped = .false. + field%aliased = .false. + allocate(field%bc) + nullify(field%refcount) ! Hack for gfortran component initialisation + ! bug. + + allocate(field%picker) + + call addref(field) + + call zero(field) + + end subroutine allocate_vector_field + + subroutine allocate_tensor_field(field, mesh, name, field_type, dim) + type(tensor_field), intent(inout) :: field + type(mesh_type), intent(in), target :: mesh + character(len=*), intent(in), optional :: name + integer, intent(in), optional :: field_type + integer, intent(in), dimension(2), optional :: dim + integer :: lfield_type + + if (present(field_type)) then + lfield_type = field_type + else + lfield_type = FIELD_TYPE_NORMAL + end if + + if(present(dim)) then + field%dim = dim + else + field%dim=(/mesh_dim(mesh),mesh_dim(mesh)/) + end if + field%option_path=empty_path + + field%mesh=mesh + call incref(mesh) + + if (present(name)) then + field%name=name + else + field%name=empty_name + end if + + field%field_type = lfield_type + select case(lfield_type) + case(FIELD_TYPE_NORMAL) + allocate(field%val(field%dim(1), field%dim(2), node_count(mesh))) #ifdef HAVE_MEMORY_STATS - call register_allocation("tensor_field", "real", & - node_count(mesh)*field%dim(1)*field%dim(2), name=name) + call register_allocation("tensor_field", "real", & + node_count(mesh)*field%dim(1)*field%dim(2), name=name) #endif - case(FIELD_TYPE_CONSTANT) - allocate(field%val(field%dim(1), field%dim(2), 1)) + case(FIELD_TYPE_CONSTANT) + allocate(field%val(field%dim(1), field%dim(2), 1)) #ifdef HAVE_MEMORY_STATS - call register_allocation("tensor_field", "real", & - field%dim(1)*field%dim(2), name=name) + call register_allocation("tensor_field", "real", & + field%dim(1)*field%dim(2), name=name) #endif - case(FIELD_TYPE_DEFERRED) - allocate(field%val(0, 0, 0)) - end select + case(FIELD_TYPE_DEFERRED) + allocate(field%val(0, 0, 0)) + end select - field%wrapped=.false. - field%aliased=.false. - nullify(field%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(field) + field%wrapped=.false. + field%aliased=.false. + nullify(field%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(field) - call zero(field) + call zero(field) - end subroutine allocate_tensor_field + end subroutine allocate_tensor_field - subroutine deallocate_subdomain_mesh(mesh) - type(mesh_type) :: mesh + subroutine deallocate_subdomain_mesh(mesh) + type(mesh_type) :: mesh - if (.not.associated(mesh%subdomain_mesh)) return + if (.not.associated(mesh%subdomain_mesh)) return - deallocate(mesh%subdomain_mesh%element_list) - deallocate(mesh%subdomain_mesh%node_list) + deallocate(mesh%subdomain_mesh%element_list) + deallocate(mesh%subdomain_mesh%node_list) - deallocate(mesh%subdomain_mesh) + deallocate(mesh%subdomain_mesh) - end subroutine deallocate_subdomain_mesh + end subroutine deallocate_subdomain_mesh - recursive subroutine deallocate_mesh_faces(mesh) - type(mesh_type) :: mesh + recursive subroutine deallocate_mesh_faces(mesh) + type(mesh_type) :: mesh - if (.not.associated(mesh%faces)) return + if (.not.associated(mesh%faces)) return - call deallocate(mesh%faces%face_list) + call deallocate(mesh%faces%face_list) #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", & + call register_deallocation("mesh_type", "integer", & size(mesh%faces%face_lno), name=mesh%name) #endif - deallocate(mesh%faces%face_lno) + deallocate(mesh%faces%face_lno) #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", & + call register_deallocation("mesh_type", "integer", & size(mesh%faces%face_element_list), & name=mesh%name) #endif - deallocate(mesh%faces%face_element_list) + deallocate(mesh%faces%face_element_list) - call deallocate(mesh%faces%shape%quadrature) - call deallocate(mesh%faces%shape) - deallocate(mesh%faces%shape) + call deallocate(mesh%faces%shape%quadrature) + call deallocate(mesh%faces%shape) + deallocate(mesh%faces%shape) - call deallocate(mesh%faces%surface_mesh) + call deallocate(mesh%faces%surface_mesh) #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", & + call register_deallocation("mesh_type", "integer", & size(mesh%faces%surface_node_list), name=trim(mesh%name)//" surface_nodes") #endif - deallocate(mesh%faces%surface_node_list) + deallocate(mesh%faces%surface_node_list) #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", & + call register_deallocation("mesh_type", "integer", & size(mesh%faces%boundary_ids), & name=trim(mesh%name)//" boundary_ids") #endif - deallocate(mesh%faces%boundary_ids) - - if (associated(mesh%faces%coplanar_ids)) then - deallocate(mesh%faces%coplanar_ids) - end if - - if (associated(mesh%faces%dg_surface_mesh)) then - call deallocate(mesh%faces%dg_surface_mesh) - deallocate(mesh%faces%dg_surface_mesh) - end if - - deallocate(mesh%faces) - - end subroutine deallocate_mesh_faces - - recursive subroutine deallocate_mesh(mesh) - !!< Deallocate the components of mesh. Shape functions are not - !!< deallocated here. - type(mesh_type), intent(inout) :: mesh - integer :: i - call decref(mesh) - if (has_references(mesh)) then - ! There are still references to this mesh so we don't deallocate. - return - end if - call deallocate(mesh%shape) - - if (.not.mesh%wrapped) then + deallocate(mesh%faces%boundary_ids) + + if (associated(mesh%faces%coplanar_ids)) then + deallocate(mesh%faces%coplanar_ids) + end if + + if (associated(mesh%faces%dg_surface_mesh)) then + call deallocate(mesh%faces%dg_surface_mesh) + deallocate(mesh%faces%dg_surface_mesh) + end if + + deallocate(mesh%faces) + + end subroutine deallocate_mesh_faces + + recursive subroutine deallocate_mesh(mesh) + !!< Deallocate the components of mesh. Shape functions are not + !!< deallocated here. + type(mesh_type), intent(inout) :: mesh + integer :: i + call decref(mesh) + if (has_references(mesh)) then + ! There are still references to this mesh so we don't deallocate. + return + end if + call deallocate(mesh%shape) + + if (.not.mesh%wrapped) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", & + call register_deallocation("mesh_type", "integer", & size(mesh%ndglno), name=mesh%name) #endif - deallocate(mesh%ndglno) - end if - - if(associated(mesh%region_ids)) then - deallocate(mesh%region_ids) - end if - - assert(associated(mesh%adj_lists)) - call remove_lists(mesh) - deallocate(mesh%adj_lists) - nullify(mesh%adj_lists) - - if(associated(mesh%halos)) then - call deallocate(mesh%halos) - deallocate(mesh%halos) - end if - - if(associated(mesh%element_halos)) then - call deallocate(mesh%element_halos) - deallocate(mesh%element_halos) - end if - - call deallocate_faces(mesh) - - if(associated(mesh%subdomain_mesh)) then - call deallocate_subdomain_mesh(mesh) - end if - - if(associated(mesh%columns)) then - deallocate(mesh%columns) - end if - - if(associated(mesh%element_columns)) then - deallocate(mesh%element_columns) - end if - - if(associated(mesh%colourings)) then - do i = 1, NUM_COLOURINGS - if(associated(mesh%colourings(i)%sets)) then - call deallocate(mesh%colourings(i)%sets) - deallocate(mesh%colourings(i)%sets) - end if - end do - deallocate(mesh%colourings) - end if - end subroutine deallocate_mesh - - recursive subroutine deallocate_scalar_field(field) - !!< Deallocate the storage associated with the field values. Deallocate - !!< is called on the mesh which will delete one reference to it and - !!< deallocate it if the count drops to zero. - type(scalar_field), intent(inout) :: field - - call decref(field) - if (has_references(field)) then - ! There are still references to this field so we don't deallocate. - return - end if - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - if (.not.field%wrapped) then + deallocate(mesh%ndglno) + end if + + if(associated(mesh%region_ids)) then + deallocate(mesh%region_ids) + end if + + assert(associated(mesh%adj_lists)) + call remove_lists(mesh) + deallocate(mesh%adj_lists) + nullify(mesh%adj_lists) + + if(associated(mesh%halos)) then + call deallocate(mesh%halos) + deallocate(mesh%halos) + end if + + if(associated(mesh%element_halos)) then + call deallocate(mesh%element_halos) + deallocate(mesh%element_halos) + end if + + call deallocate_faces(mesh) + + if(associated(mesh%subdomain_mesh)) then + call deallocate_subdomain_mesh(mesh) + end if + + if(associated(mesh%columns)) then + deallocate(mesh%columns) + end if + + if(associated(mesh%element_columns)) then + deallocate(mesh%element_columns) + end if + + if(associated(mesh%colourings)) then + do i = 1, NUM_COLOURINGS + if(associated(mesh%colourings(i)%sets)) then + call deallocate(mesh%colourings(i)%sets) + deallocate(mesh%colourings(i)%sets) + end if + end do + deallocate(mesh%colourings) + end if + end subroutine deallocate_mesh + + recursive subroutine deallocate_scalar_field(field) + !!< Deallocate the storage associated with the field values. Deallocate + !!< is called on the mesh which will delete one reference to it and + !!< deallocate it if the count drops to zero. + type(scalar_field), intent(inout) :: field + + call decref(field) + if (has_references(field)) then + ! There are still references to this field so we don't deallocate. + return + end if + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + if (.not.field%wrapped) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("scalar_field", "real", & - size(field%val), name=field%name) + call register_deallocation("scalar_field", "real", & + size(field%val), name=field%name) #endif #ifdef DDEBUG - field%val = ieee_value(0.0, ieee_quiet_nan) + field%val = ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(field%val) - end if - case(FIELD_TYPE_CONSTANT) + deallocate(field%val) + end if + case(FIELD_TYPE_CONSTANT) #ifdef HAVE_MEMORY_STATS call register_deallocation("scalar_field", "real", & - 1, name=field%name) + 1, name=field%name) #endif #ifdef DDEBUG - field%val = ieee_value(0.0, ieee_quiet_nan) + field%val = ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(field%val) - case(FIELD_TYPE_PYTHON) - call deallocate(field%py_positions) - call deallocate(field%py_positions_shape) - if (associated(field%py_locweight)) then - deallocate(field%py_locweight) - end if - case(FIELD_TYPE_DEFERRED) - FLAbort("You were supposed to allocate the deferred field later!") - end select + deallocate(field%val) + case(FIELD_TYPE_PYTHON) + call deallocate(field%py_positions) + call deallocate(field%py_positions_shape) + if (associated(field%py_locweight)) then + deallocate(field%py_locweight) + end if + case(FIELD_TYPE_DEFERRED) + FLAbort("You were supposed to allocate the deferred field later!") + end select - call deallocate(field%mesh) + call deallocate(field%mesh) - call remove_boundary_conditions(field) - deallocate(field%bc) + call remove_boundary_conditions(field) + deallocate(field%bc) - end subroutine deallocate_scalar_field + end subroutine deallocate_scalar_field - recursive subroutine remove_boundary_conditions_scalar(field) - !!< Removes and deallocates all boundary conditions from a field - type(scalar_field), intent(inout):: field + recursive subroutine remove_boundary_conditions_scalar(field) + !!< Removes and deallocates all boundary conditions from a field + type(scalar_field), intent(inout):: field - integer:: i + integer:: i - if (associated(field%bc%boundary_condition)) then - do i=1, size(field%bc%boundary_condition) - call deallocate(field%bc%boundary_condition(i)) - end do - deallocate(field%bc%boundary_condition) - end if + if (associated(field%bc%boundary_condition)) then + do i=1, size(field%bc%boundary_condition) + call deallocate(field%bc%boundary_condition(i)) + end do + deallocate(field%bc%boundary_condition) + end if - end subroutine remove_boundary_conditions_scalar + end subroutine remove_boundary_conditions_scalar - recursive subroutine deallocate_vector_field(field) - !!< Deallocate the storage associated with the field values. Deallocate - !!< is called on the mesh which will delete one reference to it and - !!< deallocate it if the count drops to zero. - type(vector_field), intent(inout) :: field + recursive subroutine deallocate_vector_field(field) + !!< Deallocate the storage associated with the field values. Deallocate + !!< is called on the mesh which will delete one reference to it and + !!< deallocate it if the count drops to zero. + type(vector_field), intent(inout) :: field - call decref(field) - if (has_references(field)) then - ! There are still references to this field so we don't deallocate. - return - end if + call decref(field) + if (has_references(field)) then + ! There are still references to this field so we don't deallocate. + return + end if - if (.not.field%wrapped) then - select case(field%field_type) - case(FIELD_TYPE_NORMAL,FIELD_TYPE_CONSTANT) + if (.not.field%wrapped) then + select case(field%field_type) + case(FIELD_TYPE_NORMAL,FIELD_TYPE_CONSTANT) #ifdef DDEBUG - field%val = ieee_value(0.0, ieee_quiet_nan) + field%val = ieee_value(0.0, ieee_quiet_nan) #endif #ifdef HAVE_MEMORY_STATS - call register_deallocation("vector_field", "real", & - size(field%val), name=field%name) + call register_deallocation("vector_field", "real", & + size(field%val), name=field%name) #endif - deallocate(field%val) - case(FIELD_TYPE_DEFERRED) - FLAbort("You were supposed to allocate the deferred field later!") - end select - end if + deallocate(field%val) + case(FIELD_TYPE_DEFERRED) + FLAbort("You were supposed to allocate the deferred field later!") + end select + end if - call deallocate(field%mesh) + call deallocate(field%mesh) - call remove_boundary_conditions(field) - deallocate(field%bc) + call remove_boundary_conditions(field) + deallocate(field%bc) - assert(associated(field%picker)) - call remove_picker(field) - deallocate(field%picker) - nullify(field%picker) + assert(associated(field%picker)) + call remove_picker(field) + deallocate(field%picker) + nullify(field%picker) - end subroutine deallocate_vector_field + end subroutine deallocate_vector_field - recursive subroutine remove_boundary_conditions_vector(field) - !!< Removes and deallocates all boundary conditions from a field - type(vector_field), intent(inout):: field + recursive subroutine remove_boundary_conditions_vector(field) + !!< Removes and deallocates all boundary conditions from a field + type(vector_field), intent(inout):: field - integer:: i + integer:: i - if (associated(field%bc%boundary_condition)) then - do i=1, size(field%bc%boundary_condition) - call deallocate(field%bc%boundary_condition(i)) - end do - deallocate(field%bc%boundary_condition) - end if + if (associated(field%bc%boundary_condition)) then + do i=1, size(field%bc%boundary_condition) + call deallocate(field%bc%boundary_condition(i)) + end do + deallocate(field%bc%boundary_condition) + end if - end subroutine remove_boundary_conditions_vector + end subroutine remove_boundary_conditions_vector - subroutine deallocate_tensor_field(field) - !!< Deallocate the storage associated with the field values. Deallocate - !!< is called on the mesh which will delete one reference to it and - !!< deallocate it if the count drops to zero. - type(tensor_field), intent(inout) :: field + subroutine deallocate_tensor_field(field) + !!< Deallocate the storage associated with the field values. Deallocate + !!< is called on the mesh which will delete one reference to it and + !!< deallocate it if the count drops to zero. + type(tensor_field), intent(inout) :: field - call decref(field) - if (has_references(field)) then - ! There are still references to this field so we don't deallocate. - return - end if + call decref(field) + if (has_references(field)) then + ! There are still references to this field so we don't deallocate. + return + end if - if (.not.field%wrapped) then - select case(field%field_type) - case(FIELD_TYPE_NORMAL,FIELD_TYPE_CONSTANT) + if (.not.field%wrapped) then + select case(field%field_type) + case(FIELD_TYPE_NORMAL,FIELD_TYPE_CONSTANT) #ifdef HAVE_MEMORY_STATS - call register_deallocation("tensor_field", "real", & - size(field%val), field%name) + call register_deallocation("tensor_field", "real", & + size(field%val), field%name) #endif #ifdef DDEBUG - field%val = ieee_value(0.0, ieee_quiet_nan) + field%val = ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(field%val) - case(FIELD_TYPE_DEFERRED) - FLAbort("You were supposed to allocate the deferred field later!") - end select - end if - - call deallocate(field%mesh) - - end subroutine deallocate_tensor_field - - subroutine allocate_scalar_boundary_condition(bc, mesh, surface_element_list, & - name, type) - !!< Allocate a scalar boundary condition - type(scalar_boundary_condition), intent(out):: bc - type(mesh_type), intent(in):: mesh - !! surface elements to which this b.c. applies (is copied in) - integer, dimension(:), intent(in):: surface_element_list - !! all things should have a name - character(len=*), intent(in):: name - !! type can be any of: ... - character(len=*), intent(in):: type - - bc%name=name - bc%type=type - allocate( bc%surface_element_list(1:size(surface_element_list)) ) - bc%surface_element_list=surface_element_list - allocate(bc%surface_mesh) - call create_surface_mesh(bc%surface_mesh, bc%surface_node_list, & - mesh, bc%surface_element_list, name=trim(name)//'Mesh') - - end subroutine allocate_scalar_boundary_condition - - subroutine allocate_vector_boundary_condition(bc, mesh, surface_element_list, & - applies, name, type) - !!< Allocate a vector boundary condition - type(vector_boundary_condition), intent(out):: bc - type(mesh_type), intent(in):: mesh - !! surface elements of this mesh to which this b.c. applies (is copied in): - integer, dimension(:), intent(in):: surface_element_list - !! all things should have a name - character(len=*), intent(in):: name - !! type can be any of: ... - character(len=*), intent(in):: type - !! b.c. only applies for components with applies==.true. - logical, dimension(:), intent(in), optional:: applies - - bc%name=name - bc%type=type - allocate( bc%surface_element_list(1:size(surface_element_list)) ) - bc%surface_element_list=surface_element_list - allocate(bc%surface_mesh) - call create_surface_mesh(bc%surface_mesh, bc%surface_node_list, & - mesh, bc%surface_element_list, name=trim(name)//'Mesh') - - if (present(applies)) then - ! size(bc%applies) is always 3! also for dim<3 - bc%applies(1:size(applies))=applies - bc%applies(size(applies)+1:)=.false. - else - ! default .true. for all components - bc%applies=.true. - end if - - end subroutine allocate_vector_boundary_condition - - subroutine deallocate_scalar_boundary_condition(bc) - !! deallocate a scalar boundary condition - type(scalar_boundary_condition), intent(inout):: bc - - integer i - - if (associated(bc%surface_fields)) then - do i=1, size(bc%surface_fields) - call deallocate(bc%surface_fields(i)) - end do - deallocate(bc%surface_fields) - end if + deallocate(field%val) + case(FIELD_TYPE_DEFERRED) + FLAbort("You were supposed to allocate the deferred field later!") + end select + end if - call deallocate(bc%surface_mesh) - deallocate(bc%surface_mesh) + call deallocate(field%mesh) + + end subroutine deallocate_tensor_field + + subroutine allocate_scalar_boundary_condition(bc, mesh, surface_element_list, & + name, type) + !!< Allocate a scalar boundary condition + type(scalar_boundary_condition), intent(out):: bc + type(mesh_type), intent(in):: mesh + !! surface elements to which this b.c. applies (is copied in) + integer, dimension(:), intent(in):: surface_element_list + !! all things should have a name + character(len=*), intent(in):: name + !! type can be any of: ... + character(len=*), intent(in):: type + + bc%name=name + bc%type=type + allocate( bc%surface_element_list(1:size(surface_element_list)) ) + bc%surface_element_list=surface_element_list + allocate(bc%surface_mesh) + call create_surface_mesh(bc%surface_mesh, bc%surface_node_list, & + mesh, bc%surface_element_list, name=trim(name)//'Mesh') + + end subroutine allocate_scalar_boundary_condition + + subroutine allocate_vector_boundary_condition(bc, mesh, surface_element_list, & + applies, name, type) + !!< Allocate a vector boundary condition + type(vector_boundary_condition), intent(out):: bc + type(mesh_type), intent(in):: mesh + !! surface elements of this mesh to which this b.c. applies (is copied in): + integer, dimension(:), intent(in):: surface_element_list + !! all things should have a name + character(len=*), intent(in):: name + !! type can be any of: ... + character(len=*), intent(in):: type + !! b.c. only applies for components with applies==.true. + logical, dimension(:), intent(in), optional:: applies + + bc%name=name + bc%type=type + allocate( bc%surface_element_list(1:size(surface_element_list)) ) + bc%surface_element_list=surface_element_list + allocate(bc%surface_mesh) + call create_surface_mesh(bc%surface_mesh, bc%surface_node_list, & + mesh, bc%surface_element_list, name=trim(name)//'Mesh') + + if (present(applies)) then + ! size(bc%applies) is always 3! also for dim<3 + bc%applies(1:size(applies))=applies + bc%applies(size(applies)+1:)=.false. + else + ! default .true. for all components + bc%applies=.true. + end if - deallocate(bc%surface_element_list, bc%surface_node_list) + end subroutine allocate_vector_boundary_condition - end subroutine deallocate_scalar_boundary_condition + subroutine deallocate_scalar_boundary_condition(bc) + !! deallocate a scalar boundary condition + type(scalar_boundary_condition), intent(inout):: bc - subroutine deallocate_vector_boundary_condition(bc) - !! deallocate a vector boundary condition - type(vector_boundary_condition), intent(inout):: bc + integer i - integer i + if (associated(bc%surface_fields)) then + do i=1, size(bc%surface_fields) + call deallocate(bc%surface_fields(i)) + end do + deallocate(bc%surface_fields) + end if - if (associated(bc%surface_fields)) then - do i=1, size(bc%surface_fields) - call deallocate(bc%surface_fields(i)) - end do - deallocate(bc%surface_fields) - end if + call deallocate(bc%surface_mesh) + deallocate(bc%surface_mesh) - if (associated(bc%scalar_surface_fields)) then - do i=1, size(bc%scalar_surface_fields) - call deallocate(bc%scalar_surface_fields(i)) - end do - deallocate(bc%scalar_surface_fields) - end if + deallocate(bc%surface_element_list, bc%surface_node_list) + + end subroutine deallocate_scalar_boundary_condition + + subroutine deallocate_vector_boundary_condition(bc) + !! deallocate a vector boundary condition + type(vector_boundary_condition), intent(inout):: bc + + integer i + + if (associated(bc%surface_fields)) then + do i=1, size(bc%surface_fields) + call deallocate(bc%surface_fields(i)) + end do + deallocate(bc%surface_fields) + end if + + if (associated(bc%scalar_surface_fields)) then + do i=1, size(bc%scalar_surface_fields) + call deallocate(bc%scalar_surface_fields(i)) + end do + deallocate(bc%scalar_surface_fields) + end if + + call deallocate(bc%surface_mesh) + deallocate(bc%surface_mesh) + + deallocate(bc%surface_element_list, bc%surface_node_list) + end subroutine deallocate_vector_boundary_condition + + !--------------------------------------------------------------------- + ! routines for wrapping meshes and fields around provided arrays + !--------------------------------------------------------------------- + + function wrap_mesh(ndglno, shape, name) result (mesh) + !!< Return a mesh wrapped around the information provided. + type(mesh_type) :: mesh + + integer, dimension(:), target, intent(in) :: ndglno + type(element_type), target, intent(in) :: shape + character(len=*), intent(in) :: name + + mesh%ndglno=>ndglno + mesh%shape=shape + call incref(shape) + nullify(mesh%faces) + + mesh%name=name + + mesh%elements=size(ndglno)/shape%loc + + allocate(mesh%adj_lists) + mesh%wrapped=.true. + mesh%nodes=maxval(ndglno) + nullify(mesh%refcount) ! Hack for gfortran component initialisation + ! bug. + mesh%periodic = .false. ! can only really assume that this is false as + ! we have no other information + call addref(mesh) + + end function wrap_mesh + + function wrap_scalar_field(mesh, val, name, val_stride) result (field) + !!< Return a scalar field wrapped around the arrays provided. + type(scalar_field) :: field + + type(mesh_type), target, intent(in) :: mesh + real, dimension(:), target, intent(in) :: val + character(len=*), intent(in) :: name + !! has to be provided if the val array is non-contiguous in memory! + integer, optional:: val_stride - call deallocate(bc%surface_mesh) - deallocate(bc%surface_mesh) + field%val=>val + field%mesh=mesh - deallocate(bc%surface_element_list, bc%surface_node_list) - end subroutine deallocate_vector_boundary_condition - - !--------------------------------------------------------------------- - ! routines for wrapping meshes and fields around provided arrays - !--------------------------------------------------------------------- - - function wrap_mesh(ndglno, shape, name) result (mesh) - !!< Return a mesh wrapped around the information provided. - type(mesh_type) :: mesh - - integer, dimension(:), target, intent(in) :: ndglno - type(element_type), target, intent(in) :: shape - character(len=*), intent(in) :: name - - mesh%ndglno=>ndglno - mesh%shape=shape - call incref(shape) - nullify(mesh%faces) - - mesh%name=name - - mesh%elements=size(ndglno)/shape%loc - - allocate(mesh%adj_lists) - mesh%wrapped=.true. - mesh%nodes=maxval(ndglno) - nullify(mesh%refcount) ! Hack for gfortran component initialisation - ! bug. - mesh%periodic = .false. ! can only really assume that this is false as - ! we have no other information - call addref(mesh) - - end function wrap_mesh - - function wrap_scalar_field(mesh, val, name, val_stride) result (field) - !!< Return a scalar field wrapped around the arrays provided. - type(scalar_field) :: field - - type(mesh_type), target, intent(in) :: mesh - real, dimension(:), target, intent(in) :: val - character(len=*), intent(in) :: name - !! has to be provided if the val array is non-contiguous in memory! - integer, optional:: val_stride - - field%val=>val - field%mesh=mesh - - field%name=name - if (present(val_stride)) then - field%val_stride=val_stride - else - field%val_stride=1 - end if - - field%py_dim = mesh_dim(mesh) - field%py_positions_shape => mesh%shape - - field%wrapped = .true. - call incref(mesh) - allocate(field%bc) - nullify(field%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(field) - - end function wrap_scalar_field - - function wrap_tensor_field(mesh, val, name) result (field) - !!< Return a tensor field wrapped around the arrays provided. - type(tensor_field) :: field - - type(mesh_type), target, intent(in) :: mesh - real, dimension(mesh_dim(mesh), mesh_dim(mesh), node_count(mesh)),& - & target, intent(in) :: val - character(len=*), intent(in) :: name - - field%val=>val - field%mesh=mesh - field%dim=mesh_dim(mesh) - - field%name=name - - field%wrapped=.true. - call incref(mesh) - nullify(field%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(field) - - end function wrap_tensor_field - - function make_mesh (model, shape, continuity, name) & - result (mesh) - !!< Produce a mesh based on an old mesh but with a different shape and/or continuity. - type(mesh_type) :: mesh - - type(mesh_type), intent(in) :: model - type(element_type), target, intent(in), optional :: shape - integer, intent(in), optional :: continuity - character(len=*), intent(in), optional :: name - - integer, dimension(:), allocatable :: ndglno - real, dimension(:), pointer :: val - integer :: i, input_nodes, n_faces + field%name=name + if (present(val_stride)) then + field%val_stride=val_stride + else + field%val_stride=1 + end if + + field%py_dim = mesh_dim(mesh) + field%py_positions_shape => mesh%shape + + field%wrapped = .true. + call incref(mesh) + allocate(field%bc) + nullify(field%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(field) + + end function wrap_scalar_field + + function wrap_tensor_field(mesh, val, name) result (field) + !!< Return a tensor field wrapped around the arrays provided. + type(tensor_field) :: field + + type(mesh_type), target, intent(in) :: mesh + real, dimension(mesh_dim(mesh), mesh_dim(mesh), node_count(mesh)),& + & target, intent(in) :: val + character(len=*), intent(in) :: name + + field%val=>val + field%mesh=mesh + field%dim=mesh_dim(mesh) + + field%name=name + + field%wrapped=.true. + call incref(mesh) + nullify(field%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(field) + + end function wrap_tensor_field + + function make_mesh (model, shape, continuity, name) & + result (mesh) + !!< Produce a mesh based on an old mesh but with a different shape and/or continuity. + type(mesh_type) :: mesh + + type(mesh_type), intent(in) :: model + type(element_type), target, intent(in), optional :: shape + integer, intent(in), optional :: continuity + character(len=*), intent(in), optional :: name + + integer, dimension(:), allocatable :: ndglno + real, dimension(:), pointer :: val + integer :: i, input_nodes, n_faces #ifdef _OPENMP - integer :: j + integer :: j #endif - if (present(continuity)) then - mesh%continuity=continuity - else - mesh%continuity=model%continuity - end if - - allocate(mesh%adj_lists) - mesh%elements=model%elements - mesh%periodic=model%periodic - mesh%wrapped=.false. - - if (present(shape)) then - mesh%shape=shape - else - mesh%shape=model%shape - end if - call incref(mesh%shape) - - ! You can't have a CG degree 0 mesh! - if(mesh%shape%degree==0.and.mesh%continuity>=0.and.mesh%shape& - &%numbering%type/=ELEMENT_TRACE) then - FLExit("For a P0 mesh, the 'mesh_continuity' must be Discontinuous.") - end if - - if (present(name)) then - mesh%name=name - else - mesh%name=empty_name - end if - - if (associated(model%region_ids)) then - allocate(mesh%region_ids(size(model%region_ids))) - mesh%region_ids=model%region_ids - end if - - if (mesh%continuity>=0) then - ! Make a continuous field. - if (model%continuity<0) then - FLExit("Unable to derive a continuous mesh from a discontinuous mesh") - end if - - allocate(ndglno(mesh%shape%numbering%vertices*model%elements), & + if (present(continuity)) then + mesh%continuity=continuity + else + mesh%continuity=model%continuity + end if + + allocate(mesh%adj_lists) + mesh%elements=model%elements + mesh%periodic=model%periodic + mesh%wrapped=.false. + + if (present(shape)) then + mesh%shape=shape + else + mesh%shape=model%shape + end if + call incref(mesh%shape) + + ! You can't have a CG degree 0 mesh! + if(mesh%shape%degree==0.and.mesh%continuity>=0.and.mesh%shape& + &%numbering%type/=ELEMENT_TRACE) then + FLExit("For a P0 mesh, the 'mesh_continuity' must be Discontinuous.") + end if + + if (present(name)) then + mesh%name=name + else + mesh%name=empty_name + end if + + if (associated(model%region_ids)) then + allocate(mesh%region_ids(size(model%region_ids))) + mesh%region_ids=model%region_ids + end if + + if (mesh%continuity>=0) then + ! Make a continuous field. + if (model%continuity<0) then + FLExit("Unable to derive a continuous mesh from a discontinuous mesh") + end if + + allocate(ndglno(mesh%shape%numbering%vertices*model%elements), & mesh%ndglno(mesh%shape%loc*model%elements)) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do i=1, mesh%elements - do j=1, mesh%shape%loc - mesh%ndglno((i-1)*mesh%shape%loc+j)=0 - end do - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do i=1, mesh%elements + do j=1, mesh%shape%loc + mesh%ndglno((i-1)*mesh%shape%loc+j)=0 + end do + end do + !$OMP END PARALLEL DO #endif #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & + call register_allocation("mesh_type", "integer", & size(mesh%ndglno), name=name) #endif - if(model%shape%degree==1 .or. ele_count(model) == 0) then - ndglno=model%ndglno - input_nodes = node_count(model) - else - ndglno=mesh_connectivity(model) - input_nodes = maxval(ndglno) - end if + if(model%shape%degree==1 .or. ele_count(model) == 0) then + ndglno=model%ndglno + input_nodes = node_count(model) + else + ndglno=mesh_connectivity(model) + input_nodes = maxval(ndglno) + end if - if (associated(model%halos)) then - assert(element_halo_count(model) > 0) - allocate(mesh%halos(size(model%halos))) + if (associated(model%halos)) then + assert(element_halo_count(model) > 0) + allocate(mesh%halos(size(model%halos))) - call make_global_numbering & + call make_global_numbering & (mesh%nodes, mesh%ndglno, input_nodes, mesh%elements, & ndglno, mesh%shape, model%halos, model%element_halos(1), & mesh%halos) - allocate(mesh%element_halos(size(model%element_halos))) - do i=1,size(mesh%element_halos) - mesh%element_halos(i)=model%element_halos(i) - call incref(mesh%element_halos(i)) - end do + allocate(mesh%element_halos(size(model%element_halos))) + do i=1,size(mesh%element_halos) + mesh%element_halos(i)=model%element_halos(i) + call incref(mesh%element_halos(i)) + end do - do i=1,size(mesh%halos) - call reorder_halo_from_element_halo(mesh%halos(i), mesh& - &%element_halos(1), mesh) - end do + do i=1,size(mesh%halos) + call reorder_halo_from_element_halo(mesh%halos(i), mesh& + &%element_halos(1), mesh) + end do - else + else - call make_global_numbering & + call make_global_numbering & (mesh%nodes, mesh%ndglno, max(maxval(ndglno), 0), mesh%elements, & ndglno, mesh%shape) - end if + end if - else - !trace fields have continuity -1 but aren't like DG - if(mesh%shape%numbering%type/=ELEMENT_TRACE) then - ! Make a discontinuous field. - allocate(mesh%ndglno(mesh%shape%loc*model%elements)) + else + !trace fields have continuity -1 but aren't like DG + if(mesh%shape%numbering%type/=ELEMENT_TRACE) then + ! Make a discontinuous field. + allocate(mesh%ndglno(mesh%shape%loc*model%elements)) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do i=1, mesh%elements - do j=1, mesh%shape%loc - mesh%ndglno((i-1)*mesh%shape%loc+j)=0 - end do - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do i=1, mesh%elements + do j=1, mesh%shape%loc + mesh%ndglno((i-1)*mesh%shape%loc+j)=0 + end do + end do + !$OMP END PARALLEL DO #endif #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & + call register_allocation("mesh_type", "integer", & size(mesh%ndglno), name=name) #endif - if (associated(model%halos)) then - assert(associated(model%element_halos)) - allocate(mesh%halos(size(model%halos))) + if (associated(model%halos)) then + assert(associated(model%element_halos)) + allocate(mesh%halos(size(model%halos))) - call make_global_numbering_DG(mesh%nodes, mesh%ndglno, & + call make_global_numbering_DG(mesh%nodes, mesh%ndglno, & mesh%elements, mesh%shape, model%element_halos, & mesh%halos) - allocate(mesh%element_halos(size(model%element_halos))) - do i=1,size(mesh%element_halos) - mesh%element_halos(i)=model%element_halos(i) - call incref(mesh%element_halos(i)) - end do + allocate(mesh%element_halos(size(model%element_halos))) + do i=1,size(mesh%element_halos) + mesh%element_halos(i)=model%element_halos(i) + call incref(mesh%element_halos(i)) + end do - else + else - call make_global_numbering_DG(mesh%nodes, mesh%ndglno, & + call make_global_numbering_DG(mesh%nodes, mesh%ndglno, & mesh%elements, mesh%shape) - end if - end if - end if + end if + end if + end if - nullify(mesh%refcount) ! Hack for gfortran component initialisation - ! bug. + nullify(mesh%refcount) ! Hack for gfortran component initialisation + ! bug. - ! Transfer the eelist from model to mesh - assert(associated(model%adj_lists)) - if(associated(model%adj_lists%eelist)) then - ewrite(2, *) "Transferring element-element list to mesh " // trim(mesh%name) - allocate(mesh%adj_lists%eelist) - mesh%adj_lists%eelist = model%adj_lists%eelist - call incref(mesh%adj_lists%eelist) - end if + ! Transfer the eelist from model to mesh + assert(associated(model%adj_lists)) + if(associated(model%adj_lists%eelist)) then + ewrite(2, *) "Transferring element-element list to mesh " // trim(mesh%name) + allocate(mesh%adj_lists%eelist) + mesh%adj_lists%eelist = model%adj_lists%eelist + call incref(mesh%adj_lists%eelist) + end if - if(has_faces(model)) then - call add_faces(mesh, model) - end if + if(has_faces(model)) then + call add_faces(mesh, model) + end if - if (mesh%shape%numbering%type==ELEMENT_TRACE) then - select case(mesh%shape%numbering%family) - case(FAMILY_SIMPLEX) - n_faces = mesh%shape%dim + 1 - case(FAMILY_CUBE) - n_faces = 2*mesh%shape%dim - case default - FLExit('Element family not supported for trace elements') - end select - allocate(mesh%ndglno(mesh%elements*n_faces*mesh%faces%shape%loc)) - call make_global_numbering_trace(mesh) - call create_surface_mesh(mesh%faces%surface_mesh, & + if (mesh%shape%numbering%type==ELEMENT_TRACE) then + select case(mesh%shape%numbering%family) + case(FAMILY_SIMPLEX) + n_faces = mesh%shape%dim + 1 + case(FAMILY_CUBE) + n_faces = 2*mesh%shape%dim + case default + FLExit('Element family not supported for trace elements') + end select + allocate(mesh%ndglno(mesh%elements*n_faces*mesh%faces%shape%loc)) + call make_global_numbering_trace(mesh) + call create_surface_mesh(mesh%faces%surface_mesh, & mesh%faces%surface_node_list, mesh, name='Surface'//trim(mesh%name)) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & + call register_allocation("mesh_type", "integer", & size(mesh%faces%surface_node_list), name='Surface'//trim(mesh%name)) #endif - end if - call addref(mesh) - - end function make_mesh - - subroutine add_faces(mesh, model, sndgln, sngi, boundary_ids, & - periodic_face_map, element_owner, incomplete_surface_mesh, & - allow_duplicate_internal_facets, stat) - !!< Subroutine to add a faces component to mesh. Since mesh may be - !!< discontinuous, a continuous model mesh must - !!< be provided. To avoid duplicate computations, and ensure - !!< consistent numbering one should first call add_faces on the model - !!< mesh. If no model is provided, the mesh must be continuous. - !!< WARNING: after the model mesh is deallocated the faces component - !!< of 'mesh' also becomes invalid! - type(mesh_type), target :: mesh - !!< model is only changed when periodic_face_map is provided (see below) - !!< not using intent(inout) - which is allowed as we only change pointed to values - type(mesh_type), optional, target, intent(in) :: model - !! surface mesh (ndglno using the same node numbering as in 'mesh') - !! if present the N elements in this mesh will correspond to the first - !! N faces of the new faces component. - !! LEGACY: Any other faces found to be on the boundary of the domain are - !! inserted after that. So that with M=surface_element_count(mesh) (where M>=N) - !! the first 1:M faces form a complete surface mesh of the domain. This - !! is legacy functionality that only works in serial. - !! A warning will therefore be issued. - !! This legacy behaviour can be switched off with - !! incomplete_surface_mesh=.true. (see below) - integer, dimension(:), intent(in), optional:: sndgln - !! number of quadrature points for the faces mesh (if not present the - !! degree of 'mesh' is maintained): - integer, intent(in), optional:: sngi - !! A list of ids marking different parts of the surface mesh - !! so that boundary conditions can be associated with it. - integer, dimension(:), intent(in), optional :: boundary_ids - !! if supplied the mesh is periodic and the model non-periodic - !! this list must contain the pairs of faces, on the periodic boundary, - !! that are now between two elements. This is needed to update the face_list - !! Additionaly the face local node numbering of the *model* mesh is updated - !! be consistent with that of the periodic face local node numbering. - type(integer_hash_table), intent(in), optional :: periodic_face_map - !! This list gives the element owning each face in sndgln. This needs - !! to be provided when sndgln contains internal faces and both copies - !! are included, as we need to decide which of the two adjacent elements - !! the facet belongs to (used in reading in periodic meshes which include - !! the periodic facets in the surface mesh with a different surface id on - !! either side of the periodic boundary). If no element_owner information - !! is provided, internal facets in sndgln are assumed to only appear once - !! and a copy will be made, its boundary id will be copied as well. This - !! means afterwards the surface_element_count() will be higher than the - !! number of facets provided in sndgln. The original number of (unique) - !! facets is returned by unique_surface_element_count() and the copies - !! are numbered between unique_surface_element_count() and surface_element_count() - !! If element_owner is present, both copies of the interior facets should be - !! present in sndgln (each with a different adjacent element owner) - integer, dimension(:), intent(in), optional :: element_owner - !! See comments above sndgln - logical, intent(in), optional :: incomplete_surface_mesh - !! if provided and true duplicate entries in sndgln are allowed for interior facets - !! but only if their boundary ids match. The duplicate entries will be stripped out - !! meaning that the facet numbering will no longer match that provided in sndgln - !! As always interior facets will occur twice, with one copy numbered <=unique_surface_element_count() - !! and one copy numbered <=surface_element_count() - logical, intent(in), optional :: allow_duplicate_internal_facets - integer, intent(out), optional :: stat - - type(integer_hash_table):: lperiodic_face_map - type(mesh_type), pointer :: lmodel - type(element_type) :: element_s - type(quadrature_type) :: quad_face - integer, dimension(:), pointer :: faces, neigh, model_ele_glno, model_ele_glno2 - integer, dimension(1:mesh%shape%numbering%vertices) :: vertices, & + end if + call addref(mesh) + + end function make_mesh + + subroutine add_faces(mesh, model, sndgln, sngi, boundary_ids, & + periodic_face_map, element_owner, incomplete_surface_mesh, & + allow_duplicate_internal_facets, stat) + !!< Subroutine to add a faces component to mesh. Since mesh may be + !!< discontinuous, a continuous model mesh must + !!< be provided. To avoid duplicate computations, and ensure + !!< consistent numbering one should first call add_faces on the model + !!< mesh. If no model is provided, the mesh must be continuous. + !!< WARNING: after the model mesh is deallocated the faces component + !!< of 'mesh' also becomes invalid! + type(mesh_type), target :: mesh + !!< model is only changed when periodic_face_map is provided (see below) + !!< not using intent(inout) - which is allowed as we only change pointed to values + type(mesh_type), optional, target, intent(in) :: model + !! surface mesh (ndglno using the same node numbering as in 'mesh') + !! if present the N elements in this mesh will correspond to the first + !! N faces of the new faces component. + !! LEGACY: Any other faces found to be on the boundary of the domain are + !! inserted after that. So that with M=surface_element_count(mesh) (where M>=N) + !! the first 1:M faces form a complete surface mesh of the domain. This + !! is legacy functionality that only works in serial. + !! A warning will therefore be issued. + !! This legacy behaviour can be switched off with + !! incomplete_surface_mesh=.true. (see below) + integer, dimension(:), intent(in), optional:: sndgln + !! number of quadrature points for the faces mesh (if not present the + !! degree of 'mesh' is maintained): + integer, intent(in), optional:: sngi + !! A list of ids marking different parts of the surface mesh + !! so that boundary conditions can be associated with it. + integer, dimension(:), intent(in), optional :: boundary_ids + !! if supplied the mesh is periodic and the model non-periodic + !! this list must contain the pairs of faces, on the periodic boundary, + !! that are now between two elements. This is needed to update the face_list + !! Additionaly the face local node numbering of the *model* mesh is updated + !! be consistent with that of the periodic face local node numbering. + type(integer_hash_table), intent(in), optional :: periodic_face_map + !! This list gives the element owning each face in sndgln. This needs + !! to be provided when sndgln contains internal faces and both copies + !! are included, as we need to decide which of the two adjacent elements + !! the facet belongs to (used in reading in periodic meshes which include + !! the periodic facets in the surface mesh with a different surface id on + !! either side of the periodic boundary). If no element_owner information + !! is provided, internal facets in sndgln are assumed to only appear once + !! and a copy will be made, its boundary id will be copied as well. This + !! means afterwards the surface_element_count() will be higher than the + !! number of facets provided in sndgln. The original number of (unique) + !! facets is returned by unique_surface_element_count() and the copies + !! are numbered between unique_surface_element_count() and surface_element_count() + !! If element_owner is present, both copies of the interior facets should be + !! present in sndgln (each with a different adjacent element owner) + integer, dimension(:), intent(in), optional :: element_owner + !! See comments above sndgln + logical, intent(in), optional :: incomplete_surface_mesh + !! if provided and true duplicate entries in sndgln are allowed for interior facets + !! but only if their boundary ids match. The duplicate entries will be stripped out + !! meaning that the facet numbering will no longer match that provided in sndgln + !! As always interior facets will occur twice, with one copy numbered <=unique_surface_element_count() + !! and one copy numbered <=surface_element_count() + logical, intent(in), optional :: allow_duplicate_internal_facets + integer, intent(out), optional :: stat + + type(integer_hash_table):: lperiodic_face_map + type(mesh_type), pointer :: lmodel + type(element_type) :: element_s + type(quadrature_type) :: quad_face + integer, dimension(:), pointer :: faces, neigh, model_ele_glno, model_ele_glno2 + integer, dimension(1:mesh%shape%numbering%vertices) :: vertices, & ele_boundary, ele_boundary2 ! these last two are actually smaller - integer :: face_count, ele, j, snloc, m, n, p, face2 + integer :: face_count, ele, j, snloc, m, n, p, face2 - if (present(stat)) then - stat = 0 - end if - - if (associated(mesh%faces)) then - ! calling add_faces twice is dangerous as it may nuke information - ! supplied in the first call (such as sndgln, boundary_ids) if (present(stat)) then - stat = 1 - return - else - ewrite(0,*) "add_faces is already called for this mesh" - ewrite(0,*) "call deallocate_faces() first if you want to recompute" - FLAbort("The end.") + stat = 0 + end if + + if (associated(mesh%faces)) then + ! calling add_faces twice is dangerous as it may nuke information + ! supplied in the first call (such as sndgln, boundary_ids) + if (present(stat)) then + stat = 1 + return + else + ewrite(0,*) "add_faces is already called for this mesh" + ewrite(0,*) "call deallocate_faces() first if you want to recompute" + FLAbort("The end.") + end if end if - end if - if (present(element_owner) .and. present_and_true(allow_duplicate_internal_facets)) then - ! if element_owner is provided, each internal facet should occur exactly twice (possibly with differen boundary id) - FLAbort("You may not provide both element_owner and allow_duplicate_internal_facets in add_faces") - end if + if (present(element_owner) .and. present_and_true(allow_duplicate_internal_facets)) then + ! if element_owner is provided, each internal facet should occur exactly twice (possibly with differen boundary id) + FLAbort("You may not provide both element_owner and allow_duplicate_internal_facets in add_faces") + end if - allocate(mesh%faces) + allocate(mesh%faces) - ! only created in the first call to get_dg_surface_mesh() - mesh%faces%dg_surface_mesh => null() + ! only created in the first call to get_dg_surface_mesh() + mesh%faces%dg_surface_mesh => null() - if (.not. present(model)) then + if (.not. present(model)) then - ! create mesh%faces%face_list an integer csr matrix storing the - ! face number between each (directed) pair of adjacent elements - ! note that this is an assymetric matrix A - ! where A_ij gives the boundary of element i facing element j - ! and A_ji the boundary of element j facing element i - ! (i.e. there are 2 opposite faces between two elements) - ! and mesh%faces%face_element_list storing the element adjacent to - ! each face - call add_faces_face_list(mesh, & - allow_duplicate_internal_facets=present_and_true(allow_duplicate_internal_facets), & - sndgln=sndgln, & - boundary_ids=boundary_ids, & - element_owner=element_owner, & - incomplete_surface_mesh=incomplete_surface_mesh) + ! create mesh%faces%face_list an integer csr matrix storing the + ! face number between each (directed) pair of adjacent elements + ! note that this is an assymetric matrix A + ! where A_ij gives the boundary of element i facing element j + ! and A_ji the boundary of element j facing element i + ! (i.e. there are 2 opposite faces between two elements) + ! and mesh%faces%face_element_list storing the element adjacent to + ! each face + call add_faces_face_list(mesh, & + allow_duplicate_internal_facets=present_and_true(allow_duplicate_internal_facets), & + sndgln=sndgln, & + boundary_ids=boundary_ids, & + element_owner=element_owner, & + incomplete_surface_mesh=incomplete_surface_mesh) - ! we don't calculate coplanar_ids here, as we need positions - mesh%faces%coplanar_ids => null() + ! we don't calculate coplanar_ids here, as we need positions + mesh%faces%coplanar_ids => null() - lmodel => mesh + lmodel => mesh - else + else - ! mesh%faces%face_list and mesh%faces%face_element_list - ! are the same as for the model, so are simply copied - ! (unless periodic) - assert(continuity(model)>=0) + ! mesh%faces%face_list and mesh%faces%face_element_list + ! are the same as for the model, so are simply copied + ! (unless periodic) + assert(continuity(model)>=0) - if (.not. associated(model%faces)) then - FLAbort("One should call add_faces on the model mesh first.") - end if + if (.not. associated(model%faces)) then + FLAbort("One should call add_faces on the model mesh first.") + end if - lmodel => model + lmodel => model - if (present(periodic_face_map)) then + if (present(periodic_face_map)) then - ! make face_list from the model but change periodic faces to become internal - call add_faces_face_list_periodic_from_non_periodic_model( & - mesh, model, periodic_face_map) + ! make face_list from the model but change periodic faces to become internal + call add_faces_face_list_periodic_from_non_periodic_model( & + mesh, model, periodic_face_map) - ! Having fixed the face list, we should now use the original mesh - ! rather than the model so that all faces which are supposed to be - ! adjacent actually are. - lmodel=>mesh - ! works as long as we're not discontinuous - assert( mesh%continuity>=0 ) + ! Having fixed the face list, we should now use the original mesh + ! rather than the model so that all faces which are supposed to be + ! adjacent actually are. + lmodel=>mesh + ! works as long as we're not discontinuous + assert( mesh%continuity>=0 ) - ! the periodic faces will be discontinuous internal faces in the output periodic mesh - mesh%faces%has_discontinuous_internal_boundaries = .true. + ! the periodic faces will be discontinuous internal faces in the output periodic mesh + mesh%faces%has_discontinuous_internal_boundaries = .true. - else if (model%periodic .and. .not. mesh%periodic) then + else if (model%periodic .and. .not. mesh%periodic) then - ! make face_list from the model but change periodic faces to normal external faces - call add_faces_face_list_non_periodic_from_periodic_model( & - mesh, model, lperiodic_face_map, stat=stat) + ! make face_list from the model but change periodic faces to normal external faces + call add_faces_face_list_non_periodic_from_periodic_model( & + mesh, model, lperiodic_face_map, stat=stat) - ! the subroutine above only works if the removing of periodic bcs has removed all internal boundaries - mesh%faces%has_discontinuous_internal_boundaries = .false. + ! the subroutine above only works if the removing of periodic bcs has removed all internal boundaries + mesh%faces%has_discontinuous_internal_boundaries = .false. - else - ! Transfer the faces from model to mesh - mesh%faces%face_list=model%faces%face_list - call incref(mesh%faces%face_list) + else + ! Transfer the faces from model to mesh + mesh%faces%face_list=model%faces%face_list + call incref(mesh%faces%face_list) - ! have internal faces if the model does - mesh%faces%has_discontinuous_internal_boundaries = has_discontinuous_internal_boundaries(model) - end if + ! have internal faces if the model does + mesh%faces%has_discontinuous_internal_boundaries = has_discontinuous_internal_boundaries(model) + end if - ! face_element_list is a pure copy of that of the model - allocate( mesh%faces%face_element_list(1:size(model%faces%face_element_list)) ) - mesh%faces%face_element_list=model%faces%face_element_list + ! face_element_list is a pure copy of that of the model + allocate( mesh%faces%face_element_list(1:size(model%faces%face_element_list)) ) + mesh%faces%face_element_list=model%faces%face_element_list #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & - size(mesh%faces%face_element_list), & - trim(mesh%name)//" face_element_list.") + call register_allocation("mesh_type", "integer", & + size(mesh%faces%face_element_list), & + trim(mesh%name)//" face_element_list.") #endif - ! boundary_ids is a pure copy of that of model - allocate( mesh%faces%boundary_ids(1:size(model%faces%boundary_ids)) ) - mesh%faces%boundary_ids=model%faces%boundary_ids + ! boundary_ids is a pure copy of that of model + allocate( mesh%faces%boundary_ids(1:size(model%faces%boundary_ids)) ) + mesh%faces%boundary_ids=model%faces%boundary_ids #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & - size(mesh%faces%boundary_ids), & - trim(mesh%name)//" boundary_ids") + call register_allocation("mesh_type", "integer", & + size(mesh%faces%boundary_ids), & + trim(mesh%name)//" boundary_ids") #endif - mesh%faces%unique_surface_element_count = model%faces%unique_surface_element_count + mesh%faces%unique_surface_element_count = model%faces%unique_surface_element_count + + ! same for coplanar ids (if existent) + if (associated(model%faces%coplanar_ids)) then + allocate( mesh%faces%coplanar_ids(1:size(model%faces%coplanar_ids)) ) + mesh%faces%coplanar_ids=model%faces%coplanar_ids + else + nullify(mesh%faces%coplanar_ids) + end if - ! same for coplanar ids (if existent) - if (associated(model%faces%coplanar_ids)) then - allocate( mesh%faces%coplanar_ids(1:size(model%faces%coplanar_ids)) ) - mesh%faces%coplanar_ids=model%faces%coplanar_ids + end if ! if (.not. present(model)) then ... else ... + + ! at this point mesh%faces%face_list and mesh%faces%face_element_list are + ! ready (either newly computed or copied from model) + ! now we only have to work out mesh%faces%face_lno + + if (present(sngi)) then + ! if specified use quadrature with sngi gausspoints + quad_face = make_quadrature(vertices=face_vertices(mesh%shape), & + & dim=mesh_dim(mesh)-1, ngi=sngi, family=mesh%shape%quadrature%family) + ! quad_face will be deallocated inside deallocate_faces! else - nullify(mesh%faces%coplanar_ids) - end if - - end if ! if (.not. present(model)) then ... else ... - - ! at this point mesh%faces%face_list and mesh%faces%face_element_list are - ! ready (either newly computed or copied from model) - ! now we only have to work out mesh%faces%face_lno - - if (present(sngi)) then - ! if specified use quadrature with sngi gausspoints - quad_face = make_quadrature(vertices=face_vertices(mesh%shape), & - & dim=mesh_dim(mesh)-1, ngi=sngi, family=mesh%shape%quadrature%family) - ! quad_face will be deallocated inside deallocate_faces! - else - ! otherwise use degree of full mesh - quad_face = make_quadrature(vertices=face_vertices(mesh%shape), & - & dim=mesh_dim(mesh)-1, degree=mesh%shape%quadrature%degree, family=mesh%shape%quadrature%family) - ! quad_face will be deallocated inside deallocate_faces! - end if - - element_s = make_element_shape(mesh%shape, quad_s = quad_face) - call deallocate(mesh%shape) - mesh%shape = element_s - - allocate(mesh%faces%shape) - mesh%faces%shape = make_element_shape(vertices=face_vertices(mesh%shape), & - & dim=mesh_dim(mesh)-1, degree=mesh%shape%degree, quad=quad_face) - - face_count=entries(mesh%faces%face_list) - snloc=mesh%faces%shape%loc - allocate(mesh%faces%face_lno( face_count*snloc )) + ! otherwise use degree of full mesh + quad_face = make_quadrature(vertices=face_vertices(mesh%shape), & + & dim=mesh_dim(mesh)-1, degree=mesh%shape%quadrature%degree, family=mesh%shape%quadrature%family) + ! quad_face will be deallocated inside deallocate_faces! + end if + + element_s = make_element_shape(mesh%shape, quad_s = quad_face) + call deallocate(mesh%shape) + mesh%shape = element_s + + allocate(mesh%faces%shape) + mesh%faces%shape = make_element_shape(vertices=face_vertices(mesh%shape), & + & dim=mesh_dim(mesh)-1, degree=mesh%shape%degree, quad=quad_face) + + face_count=entries(mesh%faces%face_list) + snloc=mesh%faces%shape%loc + allocate(mesh%faces%face_lno( face_count*snloc )) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & + call register_allocation("mesh_type", "integer", & size(mesh%faces%face_lno), name=mesh%name) #endif - vertices=local_vertices(lmodel%shape%numbering) - - ! now fill in face_lno - eleloop: do ele=1, size(mesh%faces%face_list,1) - - faces => row_ival_ptr(mesh%faces%face_list, ele) - neigh => row_m_ptr(mesh%faces%face_list, ele) - model_ele_glno => ele_nodes(lmodel, ele) - - faceloop: do j=1, size(faces) - if (ele ele_nodes(lmodel, neigh(j)) - p=0 - ! Look for common boundaries by matching common vertices - ! Note that we have to use the model mesh here - do m=1,size(vertices) - do n=1,size(vertices) - if (model_ele_glno(vertices(m))==model_ele_glno2(vertices(n))) then - p=p+1 - ele_boundary(p)=m - ele_boundary2(p)=n - end if - end do - end do - - ! Check that we really have found two boundaries. - ASSERT(p==lmodel%faces%shape%numbering%vertices) - ! (this might break for the case where elements share more than one - ! face, but in that case the next few lines are wrong as well) - - mesh%faces%face_lno((faces(j)-1)*snloc+1:faces(j)*snloc)= & + vertices=local_vertices(lmodel%shape%numbering) + + ! now fill in face_lno + eleloop: do ele=1, size(mesh%faces%face_list,1) + + faces => row_ival_ptr(mesh%faces%face_list, ele) + neigh => row_m_ptr(mesh%faces%face_list, ele) + model_ele_glno => ele_nodes(lmodel, ele) + + faceloop: do j=1, size(faces) + if (ele ele_nodes(lmodel, neigh(j)) + p=0 + ! Look for common boundaries by matching common vertices + ! Note that we have to use the model mesh here + do m=1,size(vertices) + do n=1,size(vertices) + if (model_ele_glno(vertices(m))==model_ele_glno2(vertices(n))) then + p=p+1 + ele_boundary(p)=m + ele_boundary2(p)=n + end if + end do + end do + + ! Check that we really have found two boundaries. + ASSERT(p==lmodel%faces%shape%numbering%vertices) + ! (this might break for the case where elements share more than one + ! face, but in that case the next few lines are wrong as well) + + mesh%faces%face_lno((faces(j)-1)*snloc+1:faces(j)*snloc)= & boundary_local_num(ele_boundary(1:p), mesh%shape%numbering) - face2=ival(mesh%faces%face_list, neigh(j), ele) + face2=ival(mesh%faces%face_list, neigh(j), ele) - mesh%faces%face_lno((face2-1)*snloc+1:face2*snloc)= & + mesh%faces%face_lno((face2-1)*snloc+1:face2*snloc)= & boundary_local_num(ele_boundary2(1:p), mesh%shape%numbering) - else if (neigh(j)<0) then + else if (neigh(j)<0) then - ! boundary face: - mesh%faces%face_lno((faces(j)-1)*snloc+1:faces(j)*snloc)= & - & boundary_numbering(ele_shape(mesh, ele), j) + ! boundary face: + mesh%faces%face_lno((faces(j)-1)*snloc+1:faces(j)*snloc)= & + & boundary_numbering(ele_shape(mesh, ele), j) - end if + end if - end do faceloop - end do eleloop + end do faceloop + end do eleloop - if (present(periodic_face_map)) then - call fix_periodic_face_orientation(model, mesh, periodic_face_map) - else if (present(model)) then - if (model%periodic .and. .not. mesh%periodic) then - nullify(mesh%faces%surface_node_list) - call fix_periodic_face_orientation(mesh, model, lperiodic_face_map) - call deallocate(lperiodic_face_map) + if (present(periodic_face_map)) then + call fix_periodic_face_orientation(model, mesh, periodic_face_map) + else if (present(model)) then + if (model%periodic .and. .not. mesh%periodic) then + nullify(mesh%faces%surface_node_list) + call fix_periodic_face_orientation(mesh, model, lperiodic_face_map) + call deallocate(lperiodic_face_map) + end if end if - end if - if(mesh%shape%numbering%type/=ELEMENT_TRACE) then - ! this is a surface mesh consisting of all exterior faces - ! which is often used and therefore created in advance - ! this also create a surface_node_list which can be used - ! as a mapping between the node numbering of this surface mesh - ! and the node numbering of the full mesh - call create_surface_mesh(mesh%faces%surface_mesh, & + if(mesh%shape%numbering%type/=ELEMENT_TRACE) then + ! this is a surface mesh consisting of all exterior faces + ! which is often used and therefore created in advance + ! this also create a surface_node_list which can be used + ! as a mapping between the node numbering of this surface mesh + ! and the node numbering of the full mesh + call create_surface_mesh(mesh%faces%surface_mesh, & mesh%faces%surface_node_list, mesh, name='Surface'//trim(mesh%name)) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & + call register_allocation("mesh_type", "integer", & size(mesh%faces%surface_node_list), name='Surface'//trim(mesh%name)) #endif - end if - - end subroutine add_faces - - subroutine add_faces_face_list(mesh, allow_duplicate_internal_facets, & - sndgln, boundary_ids, & - element_owner, incomplete_surface_mesh) - !!< Subroutine to calculate the face_list and face_element_list of the - !!< faces component of a 'model mesh'. This should be the linear continuous - !!< mesh that may serve as a 'model' for other meshes. - type(mesh_type), intent(inout) :: mesh - !! if true duplicate entries in sndgln are allowed for interior facets - !! but only if their boundary ids match - !! the duplicate entries will be stripped out - logical, intent(in) :: allow_duplicate_internal_facets - !! surface mesh (ndglno using the same node numbering as in 'mesh') - !! if present the N elements in this mesh will correspond to the first - !! N faces of the new faces component. - integer, dimension(:), target, intent(in), optional:: sndgln - integer, dimension(:), target, intent(in), optional:: boundary_ids - integer, dimension(:), intent(in), optional :: element_owner - logical, intent(in), optional :: incomplete_surface_mesh - - type(integer_hash_table):: internal_facet_map, duplicate_facets - type(element_type), pointer :: mesh_shape - type(element_type) :: face_shape - logical:: surface_elements_added, registered_already - ! listen very carefully, I shall say this only once: - logical, save :: warning_given=.false. - integer, dimension(:), pointer :: faces, neigh, snodes - integer, dimension(2) :: common_elements - integer :: snloc, stotel - integer :: bdry_count, ele, sele, sele2, neighbour_ele, j, no_found - integer :: no_faces - type(csr_sparsity) :: sparsity - type(csr_sparsity) :: nelist - - assert(continuity(mesh)>=0) - - mesh_shape=>ele_shape(mesh, 1) - - ! Calculate the node-to-element list. - ! Calculate the element adjacency list. - call extract_lists(mesh, nelist = nelist, eelist = sparsity) - - call allocate(mesh%faces%face_list, sparsity, type=CSR_INTEGER, & - name=trim(mesh%name)//"FaceList") - call zero(mesh%faces%face_list) - - no_faces=size(mesh%faces%face_list%sparsity%colm) - allocate(mesh%faces%face_element_list(no_faces)) + end if + + end subroutine add_faces + + subroutine add_faces_face_list(mesh, allow_duplicate_internal_facets, & + sndgln, boundary_ids, & + element_owner, incomplete_surface_mesh) + !!< Subroutine to calculate the face_list and face_element_list of the + !!< faces component of a 'model mesh'. This should be the linear continuous + !!< mesh that may serve as a 'model' for other meshes. + type(mesh_type), intent(inout) :: mesh + !! if true duplicate entries in sndgln are allowed for interior facets + !! but only if their boundary ids match + !! the duplicate entries will be stripped out + logical, intent(in) :: allow_duplicate_internal_facets + !! surface mesh (ndglno using the same node numbering as in 'mesh') + !! if present the N elements in this mesh will correspond to the first + !! N faces of the new faces component. + integer, dimension(:), target, intent(in), optional:: sndgln + integer, dimension(:), target, intent(in), optional:: boundary_ids + integer, dimension(:), intent(in), optional :: element_owner + logical, intent(in), optional :: incomplete_surface_mesh + + type(integer_hash_table):: internal_facet_map, duplicate_facets + type(element_type), pointer :: mesh_shape + type(element_type) :: face_shape + logical:: surface_elements_added, registered_already + ! listen very carefully, I shall say this only once: + logical, save :: warning_given=.false. + integer, dimension(:), pointer :: faces, neigh, snodes + integer, dimension(2) :: common_elements + integer :: snloc, stotel + integer :: bdry_count, ele, sele, sele2, neighbour_ele, j, no_found + integer :: no_faces + type(csr_sparsity) :: sparsity + type(csr_sparsity) :: nelist + + assert(continuity(mesh)>=0) + + mesh_shape=>ele_shape(mesh, 1) + + ! Calculate the node-to-element list. + ! Calculate the element adjacency list. + call extract_lists(mesh, nelist = nelist, eelist = sparsity) + + call allocate(mesh%faces%face_list, sparsity, type=CSR_INTEGER, & + name=trim(mesh%name)//"FaceList") + call zero(mesh%faces%face_list) + + no_faces=size(mesh%faces%face_list%sparsity%colm) + allocate(mesh%faces%face_element_list(no_faces)) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", no_faces, & + call register_allocation("mesh_type", "integer", no_faces, & trim(mesh%name)//" face_element_list") #endif - mesh%faces%has_discontinuous_internal_boundaries = present(element_owner) + mesh%faces%has_discontinuous_internal_boundaries = present(element_owner) + + call allocate(internal_facet_map) + call allocate(duplicate_facets) + + snloc=face_vertices(mesh_shape) + if (present(sndgln)) then + + stotel=size(sndgln)/snloc ! number of provided surface elements + ! we might add some more when duplicating internal facets + bdry_count=stotel + + do sele=1, stotel + + ! find the elements adjacent to this surface element + snodes => sndgln( (sele-1)*snloc+1:sele*snloc ) + call FindCommonElements(common_elements, no_found, nelist, & + nodes=snodes ) + + if (no_found==1) then + ! we have found the adjacent element + ele=common_elements(1) + if (present(element_owner)) then + if (element_owner(sele)/=ele) then + ewrite(0,*) "Surface element: ", sele + ewrite(0,*) "Provided element owner: ", element_owner(sele) + ewrite(0,*) "Found adjacent element: ", ele + FLExit("Provided element ownership information is incorrect") + end if + end if + call register_external_surface_element(mesh, sele, ele, snodes) + else if (no_found==2 .and. present(element_owner)) then + ! internal facet with element ownership infomation provided + ! so we assume both of the coinciding internal facets are + ! present in the provided surface mesh and register only + ! one of them here + ele = element_owner(sele) + if (ele==common_elements(1)) then + neighbour_ele = common_elements(2) + else if (ele==common_elements(2)) then + neighbour_ele = common_elements(1) + else + ewrite(0,*) "Surface element: ", sele + ewrite(0,*) "Provided element owner: ", ele + ewrite(0,*) "Found adjacent elements: ", common_elements + FLExit("Provided element owner ship information is incorrect") + end if + call register_internal_surface_element(mesh, sele, ele, neighbour_ele, snodes) + else if (no_found==2) then + ! internal facet but not element ownership information: + ! we assume this facet only occurs once and we register both + ! copies at once + + ! first one using the current surface element number: + if (allow_duplicate_internal_facets) then + ! don't error for duplicate facets + call register_internal_surface_element(mesh, sele, common_elements(1), common_elements(2), & + snodes, duplicate_facets=duplicate_facets) + registered_already = has_key(duplicate_facets, sele) + else + ! do error for duplicate facets + call register_internal_surface_element(mesh, sele, common_elements(1), common_elements(2), & + snodes) + registered_already = .false. + end if + + if (.not. registered_already) then + ! for the second one we create a new facet number at the end of the provided number surface + ! elements: + bdry_count = bdry_count+1 + ! note that we don't allow duplicate ones here, since we should have picked this up + ! in the first call - so if only one side is registered already something is definitely wrong + call register_internal_surface_element(mesh, bdry_count, common_elements(2), common_elements(1), snodes) + ! store this pair so we can later copy the boundary id of the first (sele) to the second one (bdry_count) + call insert(internal_facet_map, sele, bdry_count) + end if + + else if (no_found==0) then + ewrite(0,*) "Current surface element: ", sele + ewrite(0,*) "With nodes: ", snodes + FLExit("Surface element does not exist in the mesh") + else + ! no_found>2 apparently + ! this might happen when calling add_faces on meshes with non-trivial toplogy such + ! as calling add_faces on the surface_mesh - we can't really deal with that + ewrite(0,*) "Current surface element: ", sele + ewrite(0,*) "With nodes: ", snodes + FLExit("Surface element (facet) adjacent to more than two elements!") + end if - call allocate(internal_facet_map) - call allocate(duplicate_facets) + end do - snloc=face_vertices(mesh_shape) - if (present(sndgln)) then - stotel=size(sndgln)/snloc ! number of provided surface elements - ! we might add some more when duplicating internal facets - bdry_count=stotel + else - do sele=1, stotel + stotel=0 ! number of facets provided in sndgln + bdry_count=0 ! number of facets including the doubling of interior facets - ! find the elements adjacent to this surface element - snodes => sndgln( (sele-1)*snloc+1:sele*snloc ) - call FindCommonElements(common_elements, no_found, nelist, & - nodes=snodes ) + end if - if (no_found==1) then - ! we have found the adjacent element - ele=common_elements(1) - if (present(element_owner)) then - if (element_owner(sele)/=ele) then - ewrite(0,*) "Surface element: ", sele - ewrite(0,*) "Provided element owner: ", element_owner(sele) - ewrite(0,*) "Found adjacent element: ", ele - FLExit("Provided element ownership information is incorrect") - end if - end if - call register_external_surface_element(mesh, sele, ele, snodes) - else if (no_found==2 .and. present(element_owner)) then - ! internal facet with element ownership infomation provided - ! so we assume both of the coinciding internal facets are - ! present in the provided surface mesh and register only - ! one of them here - ele = element_owner(sele) - if (ele==common_elements(1)) then - neighbour_ele = common_elements(2) - else if (ele==common_elements(2)) then - neighbour_ele = common_elements(1) - else - ewrite(0,*) "Surface element: ", sele - ewrite(0,*) "Provided element owner: ", ele - ewrite(0,*) "Found adjacent elements: ", common_elements - FLExit("Provided element owner ship information is incorrect") - end if - call register_internal_surface_element(mesh, sele, ele, neighbour_ele, snodes) - else if (no_found==2) then - ! internal facet but not element ownership information: - ! we assume this facet only occurs once and we register both - ! copies at once - - ! first one using the current surface element number: - if (allow_duplicate_internal_facets) then - ! don't error for duplicate facets - call register_internal_surface_element(mesh, sele, common_elements(1), common_elements(2), & - snodes, duplicate_facets=duplicate_facets) - registered_already = has_key(duplicate_facets, sele) - else - ! do error for duplicate facets - call register_internal_surface_element(mesh, sele, common_elements(1), common_elements(2), & - snodes) - registered_already = .false. - end if - - if (.not. registered_already) then - ! for the second one we create a new facet number at the end of the provided number surface - ! elements: - bdry_count = bdry_count+1 - ! note that we don't allow duplicate ones here, since we should have picked this up - ! in the first call - so if only one side is registered already something is definitely wrong - call register_internal_surface_element(mesh, bdry_count, common_elements(2), common_elements(1), snodes) - ! store this pair so we can later copy the boundary id of the first (sele) to the second one (bdry_count) - call insert(internal_facet_map, sele, bdry_count) - end if - - else if (no_found==0) then - ewrite(0,*) "Current surface element: ", sele - ewrite(0,*) "With nodes: ", snodes - FLExit("Surface element does not exist in the mesh") - else - ! no_found>2 apparently - ! this might happen when calling add_faces on meshes with non-trivial toplogy such - ! as calling add_faces on the surface_mesh - we can't really deal with that - ewrite(0,*) "Current surface element: ", sele - ewrite(0,*) "With nodes: ", snodes - FLExit("Surface element (facet) adjacent to more than two elements!") - end if + if (.not. (IsParallel() .or. present_and_true(incomplete_surface_mesh))) then + ! register the rest of the boundaries + ! remaining exterior boundaries first, thus completing the surface mesh + ! This does not work in parallel and is therefore discouraged - end do + surface_elements_added=.false. + do ele=1, size(mesh%faces%face_list,1) + neigh=>row_m_ptr(mesh%faces%face_list, ele) + faces=>row_ival_ptr(mesh%faces%face_list, ele) - else + do j=1,size(neigh) - stotel=0 ! number of facets provided in sndgln - bdry_count=0 ! number of facets including the doubling of interior facets + if (neigh(j)==0) then - end if + bdry_count=bdry_count+1 + faces(j)=bdry_count + neigh(j)=-j ! negative number indicates exterior boundary - if (.not. (IsParallel() .or. present_and_true(incomplete_surface_mesh))) then - ! register the rest of the boundaries - ! remaining exterior boundaries first, thus completing the surface mesh - ! This does not work in parallel and is therefore discouraged + surface_elements_added=.true. - surface_elements_added=.false. - do ele=1, size(mesh%faces%face_list,1) + end if + end do + + end do + if (surface_elements_added .and. key_count(internal_facet_map)>0) then + ewrite(0,*) "It appears this mesh has internal boundaries." + ewrite(0,*) "In this case all external boundaries need to be marked with a surface id." + FLExit("Incomplete surface mesh") + else if (surface_elements_added .and. .not. warning_given) then + ewrite(0,*) "WARNING: an incomplete surface mesh has been provided." + ewrite(0,*) "This will not work in parallel." + ewrite(0,*) "All parts of the domain boundary need to be marked with a (physical) surface id." + warning_given=.true. + end if + + if (surface_elements_added) then + stotel = bdry_count + end if + + end if + + + ! the size of this array will be the way to store the n/o + ! exterior boundaries (returned by surface_element_count()) + allocate(mesh%faces%boundary_ids(1:bdry_count)) +#ifdef HAVE_MEMORY_STATS + call register_allocation("mesh_type", "integer", bdry_count, & + trim(mesh%name)//" boundary_ids") +#endif + + mesh%faces%unique_surface_element_count = stotel + ewrite(2,*) "Number of surface elements: ", bdry_count + ewrite(2,*) "Number of unique surface elements: ", stotel + + mesh%faces%boundary_ids=0 + ! copy in supplied boundary ids + if (present(boundary_ids)) then + if (.not. present(sndgln)) then + FLAbort("Boundary ids can only be supplied to add_faces with associated surface mesh") + else if (size(boundary_ids) /= size(sndgln)/snloc) then + FLAbort("Must supply boundary_ids array for the same number of elements as the surface mesh sndgln") + end if + mesh%faces%boundary_ids(1:size(boundary_ids))=boundary_ids + + do j=1, key_count(internal_facet_map) + call fetch_pair(internal_facet_map, j, sele, sele2) + mesh%faces%boundary_ids(sele2) = boundary_ids(sele) + end do + end if + + if (key_count(duplicate_facets)>0) then + call remove_duplicate_facets(mesh, duplicate_facets, sndgln) + ! update bdry_count + bdry_count = size(mesh%faces%boundary_ids) + end if + + ! register the rest of the boundaries (the interior ones): + do ele=1, size(mesh%faces%face_list,1) neigh=>row_m_ptr(mesh%faces%face_list, ele) faces=>row_ival_ptr(mesh%faces%face_list, ele) do j=1,size(neigh) + if (neigh(j)>0 .and. faces(j)==0) then + bdry_count=bdry_count+1 + faces(j)=bdry_count + else if (neigh(j)==0) then + ! left over exterior faces: + bdry_count=bdry_count+1 + faces(j)=bdry_count + neigh(j)=-j ! negative number indicates exterior boundary - if (neigh(j)==0) then + end if + end do - bdry_count=bdry_count+1 - faces(j)=bdry_count - neigh(j)=-j ! negative number indicates exterior boundary + ! Record the element number of each face. + ! (all faces should have an index now): + mesh%faces%face_element_list(faces)=ele - surface_elements_added=.true. + end do - end if - end do + ! Sanity checks that we have found all the faces. + assert(bdry_count==size(mesh%faces%face_list%sparsity%colm)) + assert(.not.any(mesh%faces%face_list%sparsity%colm==0)) + assert(.not.any(mesh%faces%face_list%ival==0)) + call deallocate(internal_facet_map) + call deallocate(duplicate_facets) + + end subroutine add_faces_face_list + + subroutine register_internal_surface_element(mesh, sele, ele, neighbour_ele, snodes, duplicate_facets) + type(mesh_type), intent(inout):: mesh + integer, intent(in):: sele, ele, neighbour_ele + integer, dimension(:), intent(in):: snodes ! only used to give a more helpful error message + ! if provided do not error for facets that have already been registered, but store the map between the two + type(integer_hash_table), intent(inout), optional:: duplicate_facets + + integer, dimension(:), pointer:: neigh, faces + integer:: j + + ! neigh should contain correct neighbours already for internal facets: + neigh=>row_m_ptr(mesh%faces%face_list, ele) + faces=>row_ival_ptr(mesh%faces%face_list, ele) + + ! find the corresponding boundary of ele + ! by searching for neighbour_ele in neigh + do j=1, mesh%shape%numbering%boundaries + if (neigh(j)==neighbour_ele) exit end do - if (surface_elements_added .and. key_count(internal_facet_map)>0) then - ewrite(0,*) "It appears this mesh has internal boundaries." - ewrite(0,*) "In this case all external boundaries need to be marked with a surface id." - FLExit("Incomplete surface mesh") - else if (surface_elements_added .and. .not. warning_given) then - ewrite(0,*) "WARNING: an incomplete surface mesh has been provided." - ewrite(0,*) "This will not work in parallel." - ewrite(0,*) "All parts of the domain boundary need to be marked with a (physical) surface id." - warning_given=.true. + if (j>mesh%shape%numbering%boundaries) then + ! not found a matching boundary, something's wrong + FLAbort("Something wrong with the mesh, sndgln, or mesh%nelist") end if - if (surface_elements_added) then - stotel = bdry_count + if (faces(j)/=0) then + if (present(duplicate_facets)) then + call insert(duplicate_facets, sele, faces(j)) + return + else + ! if you hit this at the start of your simulation you have + ! marked the same part of the boundary more than once in gmsh + ! if this occurs later on in the run (e.g. during an adapt) + ! there may be a bug / unimplemented feature related to internal boundary facets + ewrite(0,*) 'Surface element:', faces(j),' and ',sele + ewrite(0,*) 'Both define the surface element:', snodes + FLExit("Provided surface mesh has duplicate surface elements") + end if end if - end if + ! register the surface element in surface_element_list and face_list + mesh%faces%face_element_list(sele)=ele + faces(j)=sele + end subroutine register_internal_surface_element - ! the size of this array will be the way to store the n/o - ! exterior boundaries (returned by surface_element_count()) - allocate(mesh%faces%boundary_ids(1:bdry_count)) -#ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", bdry_count, & - trim(mesh%name)//" boundary_ids") -#endif + subroutine register_external_surface_element(mesh, sele, ele, snodes) + type(mesh_type), intent(inout):: mesh + integer, intent(in):: sele, ele + integer, dimension(:), intent(in):: snodes - mesh%faces%unique_surface_element_count = stotel - ewrite(2,*) "Number of surface elements: ", bdry_count - ewrite(2,*) "Number of unique surface elements: ", stotel + integer, dimension(:), pointer:: neigh, faces, nodes + integer:: j, nloc - mesh%faces%boundary_ids=0 - ! copy in supplied boundary ids - if (present(boundary_ids)) then - if (.not. present(sndgln)) then - FLAbort("Boundary ids can only be supplied to add_faces with associated surface mesh") - else if (size(boundary_ids) /= size(sndgln)/snloc) then - FLAbort("Must supply boundary_ids array for the same number of elements as the surface mesh sndgln") - end if - mesh%faces%boundary_ids(1:size(boundary_ids))=boundary_ids + nloc = ele_loc(mesh, ele) + + mesh%faces%face_element_list(sele)=ele - do j=1, key_count(internal_facet_map) - call fetch_pair(internal_facet_map, j, sele, sele2) - mesh%faces%boundary_ids(sele2) = boundary_ids(sele) + ! for external facets the corresponding entry in neigh + ! is still zero, a negative value will be filled in + ! when it's registered + neigh=>row_m_ptr(mesh%faces%face_list, ele) + faces=>row_ival_ptr(mesh%faces%face_list, ele) + nodes => ele_nodes(mesh, ele) + + ! find the matching boundary of ele + do j=1, mesh%shape%numbering%boundaries + ! also check negative entries to check for duplicate registrations + if (neigh(j)<=0) then + if (SetContains(snodes, nodes(boundary_numbering(mesh%shape%numbering, j)))) exit + end if end do - end if - - if (key_count(duplicate_facets)>0) then - call remove_duplicate_facets(mesh, duplicate_facets, sndgln) - ! update bdry_count - bdry_count = size(mesh%faces%boundary_ids) - end if - - ! register the rest of the boundaries (the interior ones): - do ele=1, size(mesh%faces%face_list,1) - neigh=>row_m_ptr(mesh%faces%face_list, ele) - faces=>row_ival_ptr(mesh%faces%face_list, ele) - - do j=1,size(neigh) - if (neigh(j)>0 .and. faces(j)==0) then - bdry_count=bdry_count+1 - faces(j)=bdry_count - else if (neigh(j)==0) then - ! left over exterior faces: - bdry_count=bdry_count+1 - faces(j)=bdry_count - neigh(j)=-j ! negative number indicates exterior boundary - - end if - end do - - ! Record the element number of each face. - ! (all faces should have an index now): - mesh%faces%face_element_list(faces)=ele - - end do - - ! Sanity checks that we have found all the faces. - assert(bdry_count==size(mesh%faces%face_list%sparsity%colm)) - assert(.not.any(mesh%faces%face_list%sparsity%colm==0)) - assert(.not.any(mesh%faces%face_list%ival==0)) - - call deallocate(internal_facet_map) - call deallocate(duplicate_facets) - - end subroutine add_faces_face_list - - subroutine register_internal_surface_element(mesh, sele, ele, neighbour_ele, snodes, duplicate_facets) - type(mesh_type), intent(inout):: mesh - integer, intent(in):: sele, ele, neighbour_ele - integer, dimension(:), intent(in):: snodes ! only used to give a more helpful error message - ! if provided do not error for facets that have already been registered, but store the map between the two - type(integer_hash_table), intent(inout), optional:: duplicate_facets - - integer, dimension(:), pointer:: neigh, faces - integer:: j - - ! neigh should contain correct neighbours already for internal facets: - neigh=>row_m_ptr(mesh%faces%face_list, ele) - faces=>row_ival_ptr(mesh%faces%face_list, ele) - - ! find the corresponding boundary of ele - ! by searching for neighbour_ele in neigh - do j=1, mesh%shape%numbering%boundaries - if (neigh(j)==neighbour_ele) exit - end do - - if (j>mesh%shape%numbering%boundaries) then - ! not found a matching boundary, something's wrong - FLAbort("Something wrong with the mesh, sndgln, or mesh%nelist") - end if - - if (faces(j)/=0) then - if (present(duplicate_facets)) then - call insert(duplicate_facets, sele, faces(j)) - return - else - ! if you hit this at the start of your simulation you have - ! marked the same part of the boundary more than once in gmsh - ! if this occurs later on in the run (e.g. during an adapt) - ! there may be a bug / unimplemented feature related to internal boundary facets - ewrite(0,*) 'Surface element:', faces(j),' and ',sele - ewrite(0,*) 'Both define the surface element:', snodes - FLExit("Provided surface mesh has duplicate surface elements") - end if - end if - - ! register the surface element in surface_element_list and face_list - mesh%faces%face_element_list(sele)=ele - faces(j)=sele - - end subroutine register_internal_surface_element - - subroutine register_external_surface_element(mesh, sele, ele, snodes) - type(mesh_type), intent(inout):: mesh - integer, intent(in):: sele, ele - integer, dimension(:), intent(in):: snodes - - integer, dimension(:), pointer:: neigh, faces, nodes - integer:: j, nloc - - nloc = ele_loc(mesh, ele) - - mesh%faces%face_element_list(sele)=ele - - ! for external facets the corresponding entry in neigh - ! is still zero, a negative value will be filled in - ! when it's registered - neigh=>row_m_ptr(mesh%faces%face_list, ele) - faces=>row_ival_ptr(mesh%faces%face_list, ele) - nodes => ele_nodes(mesh, ele) - - ! find the matching boundary of ele - do j=1, mesh%shape%numbering%boundaries - ! also check negative entries to check for duplicate registrations - if (neigh(j)<=0) then - if (SetContains(snodes, nodes(boundary_numbering(mesh%shape%numbering, j)))) exit - end if - end do - - if (j>mesh%shape%numbering%boundaries) then - ! not found a matching boundary, something's wrong - FLAbort("Something wrong with the mesh, sndgln, or mesh%nelist") - end if - - if (neigh(j)/=0) then - ! this surface element is already registered - ! so apparently there's a duplicate element in the surface mesh - ewrite(0,*) 'Surface element:', faces(j),' and ',sele - ewrite(0,*) 'Both define the surface element:', snodes - FLAbort("Duplicate element in the surface mesh") - end if - - ! register the surface element in face_list - faces(j)=sele - neigh(j)=-j ! negative number indicates exterior boundary - - end subroutine register_external_surface_element - - subroutine remove_duplicate_facets(mesh, duplicate_facets, sndgln) - type(mesh_type), intent(inout) :: mesh - type(integer_hash_table), intent(in) :: duplicate_facets - integer, dimension(:), intent(in) :: sndgln - - integer, dimension(:), pointer :: old_boundary_ids, faces - integer, dimension(:), allocatable :: old_to_new_facet_number - integer :: snloc, i, j, facets_to_keep, new_surface_element_count - - old_boundary_ids => mesh%faces%boundary_ids - new_surface_element_count = size(old_boundary_ids)-key_count(duplicate_facets) - mesh%faces%unique_surface_element_count = mesh%faces%unique_surface_element_count-key_count(duplicate_facets) - allocate(old_to_new_facet_number(size(old_boundary_ids))) - allocate(mesh%faces%boundary_ids(new_surface_element_count)) - - ! number the facets to keep, and check that the duplicate actually have consistent surface ids - facets_to_keep = 0 - do i=1, size(old_boundary_ids) - if (has_key(duplicate_facets, i)) then - ! check that the boundary ids match - if (old_boundary_ids(i)/=old_boundary_ids(fetch(duplicate_facets,i))) then - ewrite(0,*) 'Surface element:', i,' and ', fetch(duplicate_facets, i) - ewrite(0,*) 'Both define the surface element:', sndgln((i-1)*snloc+1:i*snloc) - ewrite(0,*) 'but define different surface ids:', old_boundary_ids(i), old_boundary_ids(fetch(duplicate_facets, i)) - ! if we hit this here, it's probably a bug as we've explicitly told add_faces() that we expect duplicate - ! interior facets but with boundary ids that agreee. - FLAbort("Provided surface mesh has duplicate surface elements") - end if - else - facets_to_keep = facets_to_keep+1 - mesh%faces%boundary_ids(facets_to_keep) = old_boundary_ids(i) - ! note that we don't need to reallocate this one: we're merely shifting it forward - mesh%faces%face_element_list(facets_to_keep) = mesh%faces%face_element_list(i) - old_to_new_facet_number(i) = facets_to_keep + + if (j>mesh%shape%numbering%boundaries) then + ! not found a matching boundary, something's wrong + FLAbort("Something wrong with the mesh, sndgln, or mesh%nelist") + end if + + if (neigh(j)/=0) then + ! this surface element is already registered + ! so apparently there's a duplicate element in the surface mesh + ewrite(0,*) 'Surface element:', faces(j),' and ',sele + ewrite(0,*) 'Both define the surface element:', snodes + FLAbort("Duplicate element in the surface mesh") end if - end do - if (facets_to_keep/=new_surface_element_count) then - FLAbort("Something wrong in mesh faces administration.") - end if + ! register the surface element in face_list + faces(j)=sele + neigh(j)=-j ! negative number indicates exterior boundary + + end subroutine register_external_surface_element + + subroutine remove_duplicate_facets(mesh, duplicate_facets, sndgln) + type(mesh_type), intent(inout) :: mesh + type(integer_hash_table), intent(in) :: duplicate_facets + integer, dimension(:), intent(in) :: sndgln + + integer, dimension(:), pointer :: old_boundary_ids, faces + integer, dimension(:), allocatable :: old_to_new_facet_number + integer :: snloc, i, j, facets_to_keep, new_surface_element_count + + old_boundary_ids => mesh%faces%boundary_ids + new_surface_element_count = size(old_boundary_ids)-key_count(duplicate_facets) + mesh%faces%unique_surface_element_count = mesh%faces%unique_surface_element_count-key_count(duplicate_facets) + allocate(old_to_new_facet_number(size(old_boundary_ids))) + allocate(mesh%faces%boundary_ids(new_surface_element_count)) + + ! number the facets to keep, and check that the duplicate actually have consistent surface ids + facets_to_keep = 0 + do i=1, size(old_boundary_ids) + if (has_key(duplicate_facets, i)) then + ! check that the boundary ids match + if (old_boundary_ids(i)/=old_boundary_ids(fetch(duplicate_facets,i))) then + ewrite(0,*) 'Surface element:', i,' and ', fetch(duplicate_facets, i) + ewrite(0,*) 'Both define the surface element:', sndgln((i-1)*snloc+1:i*snloc) + ewrite(0,*) 'but define different surface ids:', old_boundary_ids(i), old_boundary_ids(fetch(duplicate_facets, i)) + ! if we hit this here, it's probably a bug as we've explicitly told add_faces() that we expect duplicate + ! interior facets but with boundary ids that agreee. + FLAbort("Provided surface mesh has duplicate surface elements") + end if + else + facets_to_keep = facets_to_keep+1 + mesh%faces%boundary_ids(facets_to_keep) = old_boundary_ids(i) + ! note that we don't need to reallocate this one: we're merely shifting it forward + mesh%faces%face_element_list(facets_to_keep) = mesh%faces%face_element_list(i) + old_to_new_facet_number(i) = facets_to_keep + end if + end do + + if (facets_to_keep/=new_surface_element_count) then + FLAbort("Something wrong in mesh faces administration.") + end if - ! now we can safely deallocate the old boundary ids and fix the mem stats - deallocate(old_boundary_ids) + ! now we can safely deallocate the old boundary ids and fix the mem stats + deallocate(old_boundary_ids) #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", size(old_boundary_ids), & + call register_deallocation("mesh_type", "integer", size(old_boundary_ids), & trim(mesh%name)//" boundary_ids") - call register_allocation("mesh_type", "integer", new_surface_element_count, & + call register_allocation("mesh_type", "integer", new_surface_element_count, & trim(mesh%name)//" boundary_ids") #endif - ! now renumber the facet numbers we've already stored in face_list - do i=1, size(mesh%faces%face_list,1) - faces=>row_ival_ptr(mesh%faces%face_list, i) - do j=1, size(faces) - if (faces(j)/=0) then - faces(j) = old_to_new_facet_number(faces(j)) - end if + ! now renumber the facet numbers we've already stored in face_list + do i=1, size(mesh%faces%face_list,1) + faces=>row_ival_ptr(mesh%faces%face_list, i) + do j=1, size(faces) + if (faces(j)/=0) then + faces(j) = old_to_new_facet_number(faces(j)) + end if + end do + end do + + deallocate(old_to_new_facet_number) + + ewrite(2,*) "After removing duplicate interior facets:" + ewrite(2,*) "Number of surface elements: ", size(mesh%faces%boundary_ids) + ewrite(2,*) "Number of unique surface elements: ", mesh%faces%unique_surface_element_count + + end subroutine remove_duplicate_facets + + subroutine add_faces_face_list_periodic_from_non_periodic_model( & + mesh, model, periodic_face_map) + ! computes the face_list of a periodic mesh by copying it from + ! a non-periodic model mesh and changing the periodic faces + ! to internal + type(mesh_type), intent(inout):: mesh + type(mesh_type), intent(in):: model + type(integer_hash_table), intent(in):: periodic_face_map + + type(csr_sparsity):: face_list_sparsity + integer, dimension(:), pointer :: faces, neigh + integer:: face1, face2, ele1, ele2 + integer:: i, j + + ewrite(1,*) "In add_faces_face_list_periodic_from_non_periodic_model" + + ! for periodic meshes we need to fix the face_list + ! so we have to have a separate copy + call allocate(face_list_sparsity, element_count(model), & + element_count(model), entries(model%faces%face_list), & + name=trim(mesh%name)//"EEList") + face_list_sparsity%colm=model%faces%face_list%sparsity%colm + face_list_sparsity%findrm=model%faces%face_list%sparsity%findrm + + call allocate(mesh%faces%face_list, face_list_sparsity, & + type=CSR_INTEGER, name=trim(mesh%name)//"FaceList") + mesh%faces%face_list%ival=model%faces%face_list%ival + call deallocate(face_list_sparsity) + + ! now fix the face list + do i=1, key_count(periodic_face_map) + call fetch_pair(periodic_face_map, i, face1, face2) + ele1=model%faces%face_element_list(face1) + ele2=model%faces%face_element_list(face2) + + ! register ele2 as a neighbour of ele1 + faces => row_ival_ptr(mesh%faces%face_list, ele1) + neigh => row_m_ptr(mesh%faces%face_list, ele1) + do j=1, size(faces) + if (faces(j)==face1) then + neigh(j)=ele2 + end if + end do + + ! register ele1 as a neighbour of ele2 + faces => row_ival_ptr(mesh%faces%face_list, ele2) + neigh => row_m_ptr(mesh%faces%face_list, ele2) + do j=1, size(faces) + if (faces(j)==face2) then + neigh(j)=ele1 + end if + end do + end do - end do - - deallocate(old_to_new_facet_number) - - ewrite(2,*) "After removing duplicate interior facets:" - ewrite(2,*) "Number of surface elements: ", size(mesh%faces%boundary_ids) - ewrite(2,*) "Number of unique surface elements: ", mesh%faces%unique_surface_element_count - - end subroutine remove_duplicate_facets - - subroutine add_faces_face_list_periodic_from_non_periodic_model( & - mesh, model, periodic_face_map) - ! computes the face_list of a periodic mesh by copying it from - ! a non-periodic model mesh and changing the periodic faces - ! to internal - type(mesh_type), intent(inout):: mesh - type(mesh_type), intent(in):: model - type(integer_hash_table), intent(in):: periodic_face_map - - type(csr_sparsity):: face_list_sparsity - integer, dimension(:), pointer :: faces, neigh - integer:: face1, face2, ele1, ele2 - integer:: i, j - - ewrite(1,*) "In add_faces_face_list_periodic_from_non_periodic_model" - - ! for periodic meshes we need to fix the face_list - ! so we have to have a separate copy - call allocate(face_list_sparsity, element_count(model), & - element_count(model), entries(model%faces%face_list), & - name=trim(mesh%name)//"EEList") - face_list_sparsity%colm=model%faces%face_list%sparsity%colm - face_list_sparsity%findrm=model%faces%face_list%sparsity%findrm - - call allocate(mesh%faces%face_list, face_list_sparsity, & - type=CSR_INTEGER, name=trim(mesh%name)//"FaceList") - mesh%faces%face_list%ival=model%faces%face_list%ival - call deallocate(face_list_sparsity) - - ! now fix the face list - do i=1, key_count(periodic_face_map) - call fetch_pair(periodic_face_map, i, face1, face2) - ele1=model%faces%face_element_list(face1) - ele2=model%faces%face_element_list(face2) - - ! register ele2 as a neighbour of ele1 - faces => row_ival_ptr(mesh%faces%face_list, ele1) - neigh => row_m_ptr(mesh%faces%face_list, ele1) - do j=1, size(faces) - if (faces(j)==face1) then - neigh(j)=ele2 - end if - end do - - ! register ele1 as a neighbour of ele2 - faces => row_ival_ptr(mesh%faces%face_list, ele2) - neigh => row_m_ptr(mesh%faces%face_list, ele2) - do j=1, size(faces) - if (faces(j)==face2) then - neigh(j)=ele1 - end if - end do - - end do - - end subroutine add_faces_face_list_periodic_from_non_periodic_model - - subroutine add_faces_face_list_non_periodic_from_periodic_model( & - mesh, model, periodic_face_map, stat) - ! computes the face_list of a non-periodic mesh by copying it from - ! a periodic model mesh and changing the periodic faces - ! to external - type(mesh_type), intent(inout):: mesh - type(mesh_type), intent(in):: model - ! we return a list of periodic face pairs, as these need their local node numbering fixed later - type(integer_hash_table), intent(out):: periodic_face_map - integer, intent(out), optional :: stat - - type(csr_sparsity):: face_list_sparsity - integer, dimension(:), pointer:: neigh, ele1_nodes, ele2_nodes - integer:: face, face2, ele1, ele2, lface1, lface2 - - ewrite(1,*) "In add_faces_face_list_non_periodic_from_periodic_model" - - if (present(stat)) then - stat = 0 - end if - - ! we need to fix the face_list so we have to have a separate copy - call allocate(face_list_sparsity, element_count(model), & - element_count(model), entries(model%faces%face_list), & - name=trim(mesh%name)//"EEList") - face_list_sparsity%colm=model%faces%face_list%sparsity%colm - face_list_sparsity%findrm=model%faces%face_list%sparsity%findrm - - call allocate(mesh%faces%face_list, face_list_sparsity, & - type=CSR_INTEGER, name=trim(mesh%name)//"FaceList") - mesh%faces%face_list%ival=model%faces%face_list%ival - call deallocate(face_list_sparsity) - - call allocate(periodic_face_map) - - ! now fix the face list - by searching for internal faces in the - ! model mesh, these are the periodic faces that now need to be removed - do face = 1, surface_element_count(model) - ele1 = face_ele(model, face) - neigh => row_m_ptr(mesh%faces%face_list, ele1) - lface1 = local_face_number(model, face) - ele2 = neigh(lface1) - if (ele2>0) then - ! we've found an internal face in the surface mesh - - ! check that the connection has disappeared - face2 = ele_face(model, ele2, ele1) - lface2 = local_face_number(model, face2) - ele1_nodes => ele_nodes(mesh, ele1) - ele2_nodes => ele_nodes(mesh, ele2) - if (SetContains( & - ele1_nodes(boundary_numbering(ele_shape(mesh, ele1), lface1)), & - ele2_nodes(boundary_numbering(ele_shape(mesh, ele2), lface2)))) then - ! apparently these faces are still connected - ! (not currently supported) - if (present(stat)) then - stat = 1 - else - ewrite(-1,*) "Face: ", face, "; element: ", ele1 - ewrite(-1,*) "face_global_nodes(mesh, face): ", ele1_nodes(boundary_numbering(ele_shape(mesh, ele1), lface1)) - ewrite(-1,*) "Opposing face: ", face2, "; element: ", ele2 - ewrite(-1,*) "face_global_nodes(mesh, face2): ", ele2_nodes(boundary_numbering(ele_shape(mesh, ele2), lface2)) - FLAbort("Left-over internal faces in removing periodic bcs.") - end if + + end subroutine add_faces_face_list_periodic_from_non_periodic_model + + subroutine add_faces_face_list_non_periodic_from_periodic_model( & + mesh, model, periodic_face_map, stat) + ! computes the face_list of a non-periodic mesh by copying it from + ! a periodic model mesh and changing the periodic faces + ! to external + type(mesh_type), intent(inout):: mesh + type(mesh_type), intent(in):: model + ! we return a list of periodic face pairs, as these need their local node numbering fixed later + type(integer_hash_table), intent(out):: periodic_face_map + integer, intent(out), optional :: stat + + type(csr_sparsity):: face_list_sparsity + integer, dimension(:), pointer:: neigh, ele1_nodes, ele2_nodes + integer:: face, face2, ele1, ele2, lface1, lface2 + + ewrite(1,*) "In add_faces_face_list_non_periodic_from_periodic_model" + + if (present(stat)) then + stat = 0 + end if + + ! we need to fix the face_list so we have to have a separate copy + call allocate(face_list_sparsity, element_count(model), & + element_count(model), entries(model%faces%face_list), & + name=trim(mesh%name)//"EEList") + face_list_sparsity%colm=model%faces%face_list%sparsity%colm + face_list_sparsity%findrm=model%faces%face_list%sparsity%findrm + + call allocate(mesh%faces%face_list, face_list_sparsity, & + type=CSR_INTEGER, name=trim(mesh%name)//"FaceList") + mesh%faces%face_list%ival=model%faces%face_list%ival + call deallocate(face_list_sparsity) + + call allocate(periodic_face_map) + + ! now fix the face list - by searching for internal faces in the + ! model mesh, these are the periodic faces that now need to be removed + do face = 1, surface_element_count(model) + ele1 = face_ele(model, face) + neigh => row_m_ptr(mesh%faces%face_list, ele1) + lface1 = local_face_number(model, face) + ele2 = neigh(lface1) + if (ele2>0) then + ! we've found an internal face in the surface mesh + + ! check that the connection has disappeared + face2 = ele_face(model, ele2, ele1) + lface2 = local_face_number(model, face2) + ele1_nodes => ele_nodes(mesh, ele1) + ele2_nodes => ele_nodes(mesh, ele2) + if (SetContains( & + ele1_nodes(boundary_numbering(ele_shape(mesh, ele1), lface1)), & + ele2_nodes(boundary_numbering(ele_shape(mesh, ele2), lface2)))) then + ! apparently these faces are still connected + ! (not currently supported) + if (present(stat)) then + stat = 1 + else + ewrite(-1,*) "Face: ", face, "; element: ", ele1 + ewrite(-1,*) "face_global_nodes(mesh, face): ", ele1_nodes(boundary_numbering(ele_shape(mesh, ele1), lface1)) + ewrite(-1,*) "Opposing face: ", face2, "; element: ", ele2 + ewrite(-1,*) "face_global_nodes(mesh, face2): ", ele2_nodes(boundary_numbering(ele_shape(mesh, ele2), lface2)) + FLAbort("Left-over internal faces in removing periodic bcs.") + end if + end if + + ! we're cool + neigh(lface1)=-lface1 + ! might as well fix the other side while we're at it + neigh => row_m_ptr(mesh%faces%face_list, ele2) + neigh(lface2)=-lface2 + ! we store these as their face local node numbering needs to be "fixed" later + call insert(periodic_face_map, face, face2) end if - ! we're cool - neigh(lface1)=-lface1 - ! might as well fix the other side while we're at it - neigh => row_m_ptr(mesh%faces%face_list, ele2) - neigh(lface2)=-lface2 - ! we store these as their face local node numbering needs to be "fixed" later - call insert(periodic_face_map, face, face2) - end if - - end do - - end subroutine add_faces_face_list_non_periodic_from_periodic_model - - subroutine fix_periodic_face_orientation(nonperiodic, periodic, periodic_face_map) - !!< Fixes, i.e. overwrites the face local node numbering of non-periodic nonperiodic - !!< in periodic faces to make it consistent with the periodic 'mesh' - !!< Assumes the shape functions of elements and faces in mesh and nonperiodic are the same!! - type(mesh_type), intent(in):: nonperiodic - type(mesh_type), intent(in):: periodic - type(integer_hash_table), intent(in):: periodic_face_map - - type(mesh_faces), pointer:: nonperiodic_faces - integer:: i, face1, face2 - - ewrite(1,*) "Inside fix_periodic_face_orientation" - - if (.not. periodic%faces%shape==nonperiodic%faces%shape) then - ewrite(-1,*) "When deriving the faces structure of a periodic mesh from a non-periodic mesh" - ewrite(-1,*) "Its shape functions have to be the same" - FLAbort("Different shape functions in non-periodic nonperiodic mesh") - end if - - do i=1, key_count(periodic_face_map) - call fetch_pair(periodic_face_map, i, face1, face2) - call fix_periodic_face_orientation_face(face1) - call fix_periodic_face_orientation_face(face2) - end do - - ! when deriving a non-periodic mesh from a periodic model, - ! we don't have the surface mesh yet, so no need to fix it: - if (.not. associated(nonperiodic%faces%surface_node_list)) return - - nonperiodic_faces => nonperiodic%faces - call deallocate(nonperiodic_faces%surface_mesh) + end do + + end subroutine add_faces_face_list_non_periodic_from_periodic_model + + subroutine fix_periodic_face_orientation(nonperiodic, periodic, periodic_face_map) + !!< Fixes, i.e. overwrites the face local node numbering of non-periodic nonperiodic + !!< in periodic faces to make it consistent with the periodic 'mesh' + !!< Assumes the shape functions of elements and faces in mesh and nonperiodic are the same!! + type(mesh_type), intent(in):: nonperiodic + type(mesh_type), intent(in):: periodic + type(integer_hash_table), intent(in):: periodic_face_map + + type(mesh_faces), pointer:: nonperiodic_faces + integer:: i, face1, face2 + + ewrite(1,*) "Inside fix_periodic_face_orientation" + + if (.not. periodic%faces%shape==nonperiodic%faces%shape) then + ewrite(-1,*) "When deriving the faces structure of a periodic mesh from a non-periodic mesh" + ewrite(-1,*) "Its shape functions have to be the same" + FLAbort("Different shape functions in non-periodic nonperiodic mesh") + end if + + do i=1, key_count(periodic_face_map) + call fetch_pair(periodic_face_map, i, face1, face2) + call fix_periodic_face_orientation_face(face1) + call fix_periodic_face_orientation_face(face2) + end do + + ! when deriving a non-periodic mesh from a periodic model, + ! we don't have the surface mesh yet, so no need to fix it: + if (.not. associated(nonperiodic%faces%surface_node_list)) return + + nonperiodic_faces => nonperiodic%faces + call deallocate(nonperiodic_faces%surface_mesh) #ifdef HAVE_MEMORY_STATS - call register_deallocation("mesh_type", "integer", & + call register_deallocation("mesh_type", "integer", & size(nonperiodic_faces%surface_node_list), name='Surface'//trim(nonperiodic%name)) #endif - deallocate(nonperiodic_faces%surface_node_list) - call create_surface_mesh(nonperiodic_faces%surface_mesh, & - nonperiodic_faces%surface_node_list, nonperiodic, name='Surface'//trim(nonperiodic%name)) + deallocate(nonperiodic_faces%surface_node_list) + call create_surface_mesh(nonperiodic_faces%surface_mesh, & + nonperiodic_faces%surface_node_list, nonperiodic, name='Surface'//trim(nonperiodic%name)) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & + call register_allocation("mesh_type", "integer", & size(nonperiodic_faces%surface_node_list), name='Surface'//trim(nonperiodic%name)) #endif - contains - - subroutine fix_periodic_face_orientation_face(face) - integer, intent(in):: face - - integer, dimension(:), pointer:: mesh_face_local_nodes, nonperiodic_face_local_nodes - - mesh_face_local_nodes => face_local_nodes(periodic, face) - nonperiodic_face_local_nodes => face_local_nodes(nonperiodic, face) - - nonperiodic_face_local_nodes=mesh_face_local_nodes - - end subroutine fix_periodic_face_orientation_face - - end subroutine fix_periodic_face_orientation - - subroutine create_surface_mesh(surface_mesh, surface_nodes, & - mesh, surface_elements, name) - !! Creates a surface mesh consisting of the surface elements - !! specified by surface_element_list - type(mesh_type), intent(out):: surface_mesh - !! Returns a pointer to a list containing the global node number - !! of the nodes on this surface mesh, can be used for surface node - !! to global node numbering conversion. - integer, dimension(:), pointer:: surface_nodes - !! mesh to take surface from (should have %faces component) - type(mesh_type), intent(in):: mesh - !! which surface elements to select - !! (if not provided all surface elements are included) - integer, dimension(:), optional, target,intent(in):: surface_elements - !! name for the new surface_mesh - character(len=*), intent(in):: name - - integer, dimension(:), pointer:: lsurface_elements - integer, dimension(:), pointer:: suf_ndglno - integer, dimension(:), allocatable:: nod2sufnod - integer, dimension(mesh%faces%shape%loc):: glnodes - integer i, j, sele, sufnod, snloc - - snloc=mesh%faces%shape%loc - - if (present(surface_elements)) then - lsurface_elements => surface_elements - else - allocate(lsurface_elements(1:surface_element_count(mesh))) - lsurface_elements=(/ (i, i=1, size(lsurface_elements)) /) - end if - - allocate(nod2sufnod(1:node_count(mesh))) - nod2sufnod=0 - - ! mark surface nodes with nod2sufnod(nod)==1 - sufnod=0 - do i=1, size(lsurface_elements) - sele=lsurface_elements(i) - glnodes=face_global_nodes(mesh, sele) - do j=1, snloc - if (nod2sufnod(glnodes(j))==0) then - sufnod=sufnod+1 - nod2sufnod(glnodes(j))=1 - end if + contains + + subroutine fix_periodic_face_orientation_face(face) + integer, intent(in):: face + + integer, dimension(:), pointer:: mesh_face_local_nodes, nonperiodic_face_local_nodes + + mesh_face_local_nodes => face_local_nodes(periodic, face) + nonperiodic_face_local_nodes => face_local_nodes(nonperiodic, face) + + nonperiodic_face_local_nodes=mesh_face_local_nodes + + end subroutine fix_periodic_face_orientation_face + + end subroutine fix_periodic_face_orientation + + subroutine create_surface_mesh(surface_mesh, surface_nodes, & + mesh, surface_elements, name) + !! Creates a surface mesh consisting of the surface elements + !! specified by surface_element_list + type(mesh_type), intent(out):: surface_mesh + !! Returns a pointer to a list containing the global node number + !! of the nodes on this surface mesh, can be used for surface node + !! to global node numbering conversion. + integer, dimension(:), pointer:: surface_nodes + !! mesh to take surface from (should have %faces component) + type(mesh_type), intent(in):: mesh + !! which surface elements to select + !! (if not provided all surface elements are included) + integer, dimension(:), optional, target,intent(in):: surface_elements + !! name for the new surface_mesh + character(len=*), intent(in):: name + + integer, dimension(:), pointer:: lsurface_elements + integer, dimension(:), pointer:: suf_ndglno + integer, dimension(:), allocatable:: nod2sufnod + integer, dimension(mesh%faces%shape%loc):: glnodes + integer i, j, sele, sufnod, snloc + + snloc=mesh%faces%shape%loc + + if (present(surface_elements)) then + lsurface_elements => surface_elements + else + allocate(lsurface_elements(1:surface_element_count(mesh))) + lsurface_elements=(/ (i, i=1, size(lsurface_elements)) /) + end if + + allocate(nod2sufnod(1:node_count(mesh))) + nod2sufnod=0 + + ! mark surface nodes with nod2sufnod(nod)==1 + sufnod=0 + do i=1, size(lsurface_elements) + sele=lsurface_elements(i) + glnodes=face_global_nodes(mesh, sele) + do j=1, snloc + if (nod2sufnod(glnodes(j))==0) then + sufnod=sufnod+1 + nod2sufnod(glnodes(j))=1 + end if + end do + end do + + call allocate(surface_mesh, nodes=sufnod, & + elements=size(lsurface_elements), shape=mesh%faces%shape, & + name=name) + + surface_mesh%periodic=mesh%periodic + surface_mesh%continuity=mesh%continuity + + allocate(surface_nodes(1:sufnod)) + + ! create numbering in the same order as full nodal numbering: + sufnod=0 + do i=1, size(nod2sufnod) + if (nod2sufnod(i)==1) then + sufnod=sufnod+1 + ! global node to surface node numbering + nod2sufnod(i)=sufnod + ! and the reverse + surface_nodes(sufnod)=i + + end if + end do + + ! map global node numbering to surface node numbering + suf_ndglno => surface_mesh%ndglno + do i=1, size(lsurface_elements) + sele=lsurface_elements(i) + suf_ndglno( (i-1)*snloc+1:i*snloc )=nod2sufnod(face_global_nodes(mesh, sele)) + end do + + deallocate(nod2sufnod) + + if (.not. present(surface_elements)) then + deallocate(lsurface_elements) + end if + + end subroutine create_surface_mesh + + logical function SetContains(a, b) + !!< Auxillary function that returns true if b contains a + integer, dimension(:), intent(in):: a, b + + integer i + + SetContains=.false. + do i=1, size(a) + if (.not. any(b==a(i))) return + end do + SetContains=.true. + + end function SetContains + + function make_mesh_periodic(positions,physical_boundary_ids,aliased_boundary_ids,periodic_mapping_python,name, & + periodic_face_map) result (positions_out) + !!< Produce a mesh based on an old mesh but with periodic boundary conditions + type(vector_field) :: positions_out + type(vector_field), target, intent(in) :: positions + + integer, dimension(:), intent(in) :: physical_boundary_ids, aliased_boundary_ids + character(len=*), intent(in) :: periodic_mapping_python + ! name of positions_out%mesh, positions_out will called trim(name)//"Coordinate" + character(len=*), intent(in), optional :: name + !! builds up a map between aliased and physical faces, has to be allocated + !! before the call, and is not emptied, so this can be used to build up a + !! aliased to physical face map over multiple calls to make_mesh_periodic + type(integer_hash_table), optional, intent(inout):: periodic_face_map + + type(mesh_type) :: mesh + type(mesh_type), pointer:: model + + integer, dimension(:), allocatable :: ndglno + real, dimension(:), pointer :: val + integer, dimension(:,:), allocatable :: local_mapping_list + integer, dimension(:), allocatable :: mapping_list, mapped + integer :: i, j, k, id, nod, nod1, map_index, periodic_faces + integer, dimension(:), allocatable :: face_nodes, face_nodes2 + integer :: count + real, dimension(:,:), allocatable :: mapX + real, dimension(positions%dim) :: tmp_pos + real, dimension(:), pointer :: x,y,z + real :: epsilon0 + logical :: found_node + + model => positions%mesh + + assert(has_faces(model)) + + !get pointers to coordinates + x => positions%val(1,:) + if (positions%dim>1) then + y => positions%val(2,:) + if(positions%dim>2) then + z => positions%val(3,:) + end if + end if + call allocate(mesh, 0, model%elements, model%shape, name=name) + !copy over all the mesh parameters + mesh%continuity=model%continuity + mesh%wrapped=.false. + mesh%periodic=.true. + + if (associated(model%region_ids)) then + allocate(mesh%region_ids(size(model%region_ids))) + mesh%region_ids = model%region_ids + end if + + !allocate memory for temporary place to hold old connectivity, + !and memory for periodic connectivity + allocate(ndglno(mesh%shape%numbering%vertices*model%elements)) + + !get old connectivity + ndglno=model%ndglno + + !mapping_list is mapping from coordinates to periodic node number + !mapped takes value 1 if node is aliased + allocate( mapping_list(model%nodes), mapped(model%nodes) ) + mapping_list = 0 + mapped = 0 + + !array to store the global node numbers in a face + !ATTENTION: broken for meshes with different element types on + !different meshes + allocate( face_nodes(face_loc(model,1)) ) + allocate( face_nodes2(face_loc(model,1)) ) + + !label any nodes which are aliased by: + ! visiting each surface element + ! checking the id + ! if the id indicates aliased node then set mapped(node) to 1 + ! for each node in the surface element + periodic_faces=0 + do i = 1, surface_element_count(model) + id = surface_element_id(model,i) + if(any(aliased_boundary_ids==id)) then + face_nodes = face_global_nodes(model,i) + mapped(face_nodes) = 1 + + periodic_faces=periodic_faces+1 + end if end do - end do - - call allocate(surface_mesh, nodes=sufnod, & - elements=size(lsurface_elements), shape=mesh%faces%shape, & - name=name) - - surface_mesh%periodic=mesh%periodic - surface_mesh%continuity=mesh%continuity - - allocate(surface_nodes(1:sufnod)) - - ! create numbering in the same order as full nodal numbering: - sufnod=0 - do i=1, size(nod2sufnod) - if (nod2sufnod(i)==1) then - sufnod=sufnod+1 - ! global node to surface node numbering - nod2sufnod(i)=sufnod - ! and the reverse - surface_nodes(sufnod)=i - - end if - end do - - ! map global node numbering to surface node numbering - suf_ndglno => surface_mesh%ndglno - do i=1, size(lsurface_elements) - sele=lsurface_elements(i) - suf_ndglno( (i-1)*snloc+1:i*snloc )=nod2sufnod(face_global_nodes(mesh, sele)) - end do - - deallocate(nod2sufnod) - - if (.not. present(surface_elements)) then - deallocate(lsurface_elements) - end if - - end subroutine create_surface_mesh - - logical function SetContains(a, b) - !!< Auxillary function that returns true if b contains a - integer, dimension(:), intent(in):: a, b - - integer i - - SetContains=.false. - do i=1, size(a) - if (.not. any(b==a(i))) return - end do - SetContains=.true. - - end function SetContains - - function make_mesh_periodic(positions,physical_boundary_ids,aliased_boundary_ids,periodic_mapping_python,name, & - periodic_face_map) result (positions_out) - !!< Produce a mesh based on an old mesh but with periodic boundary conditions - type(vector_field) :: positions_out - type(vector_field), target, intent(in) :: positions - - integer, dimension(:), intent(in) :: physical_boundary_ids, aliased_boundary_ids - character(len=*), intent(in) :: periodic_mapping_python - ! name of positions_out%mesh, positions_out will called trim(name)//"Coordinate" - character(len=*), intent(in), optional :: name - !! builds up a map between aliased and physical faces, has to be allocated - !! before the call, and is not emptied, so this can be used to build up a - !! aliased to physical face map over multiple calls to make_mesh_periodic - type(integer_hash_table), optional, intent(inout):: periodic_face_map - - type(mesh_type) :: mesh - type(mesh_type), pointer:: model - - integer, dimension(:), allocatable :: ndglno - real, dimension(:), pointer :: val - integer, dimension(:,:), allocatable :: local_mapping_list - integer, dimension(:), allocatable :: mapping_list, mapped - integer :: i, j, k, id, nod, nod1, map_index, periodic_faces - integer, dimension(:), allocatable :: face_nodes, face_nodes2 - integer :: count - real, dimension(:,:), allocatable :: mapX - real, dimension(positions%dim) :: tmp_pos - real, dimension(:), pointer :: x,y,z - real :: epsilon0 - logical :: found_node - - model => positions%mesh - - assert(has_faces(model)) - - !get pointers to coordinates - x => positions%val(1,:) - if (positions%dim>1) then - y => positions%val(2,:) - if(positions%dim>2) then - z => positions%val(3,:) - end if - end if - call allocate(mesh, 0, model%elements, model%shape, name=name) - !copy over all the mesh parameters - mesh%continuity=model%continuity - mesh%wrapped=.false. - mesh%periodic=.true. - - if (associated(model%region_ids)) then - allocate(mesh%region_ids(size(model%region_ids))) - mesh%region_ids = model%region_ids - end if - - !allocate memory for temporary place to hold old connectivity, - !and memory for periodic connectivity - allocate(ndglno(mesh%shape%numbering%vertices*model%elements)) - - !get old connectivity - ndglno=model%ndglno - - !mapping_list is mapping from coordinates to periodic node number - !mapped takes value 1 if node is aliased - allocate( mapping_list(model%nodes), mapped(model%nodes) ) - mapping_list = 0 - mapped = 0 - - !array to store the global node numbers in a face - !ATTENTION: broken for meshes with different element types on - !different meshes - allocate( face_nodes(face_loc(model,1)) ) - allocate( face_nodes2(face_loc(model,1)) ) - - !label any nodes which are aliased by: - ! visiting each surface element - ! checking the id - ! if the id indicates aliased node then set mapped(node) to 1 - ! for each node in the surface element - periodic_faces=0 - do i = 1, surface_element_count(model) - id = surface_element_id(model,i) - if(any(aliased_boundary_ids==id)) then - face_nodes = face_global_nodes(model,i) - mapped(face_nodes) = 1 - - periodic_faces=periodic_faces+1 - end if - end do - - !compute the number of nodes in the periodic mesh - mesh%nodes = model%nodes - sum(mapped) - - ewrite(2,*) 'cjc nonods xnonod',mesh%nodes,model%nodes, sum(mapped) - - !local_mapping_list(1,:) contains aliased nodes - !local_mapping_list(2,:) contains the nodes they are aliased to - allocate( local_mapping_list(2,sum(mapped)) ) - local_mapping_list = 0 - - !mapX contains the coordinates of the nodes that aliased nodes - !are mapped to - allocate( mapX(positions%dim,sum(mapped)) ) - - !compute local_mapping_list(1,:) by - !visiting each surface element - !if id indicates it is aliased - !visit each node in the surface element - !if the node has yet to be added to the list (mapped(node)==1) then - ! set mapped(node) to -1 - ! add node to the local_mapping_list(1,:), and - ! increment count - count = 1 - do i = 1, surface_element_count(model) - id = surface_element_id(model,i) - face_nodes = face_global_nodes(model,i) - if(any(aliased_boundary_ids==id)) then - do nod = 1, size(face_nodes) - if(mapped(face_nodes(nod))==1) then - mapped(face_nodes(nod))=-1 - local_mapping_list(1,count) = face_nodes(nod) - count = count + 1 - end if - end do - end if - end do - - !compute the coordinates of the nodes that aliased nodes are mapped to - if (positions%dim==1) then - call set_from_python_function(mapX, & + + !compute the number of nodes in the periodic mesh + mesh%nodes = model%nodes - sum(mapped) + + ewrite(2,*) 'cjc nonods xnonod',mesh%nodes,model%nodes, sum(mapped) + + !local_mapping_list(1,:) contains aliased nodes + !local_mapping_list(2,:) contains the nodes they are aliased to + allocate( local_mapping_list(2,sum(mapped)) ) + local_mapping_list = 0 + + !mapX contains the coordinates of the nodes that aliased nodes + !are mapped to + allocate( mapX(positions%dim,sum(mapped)) ) + + !compute local_mapping_list(1,:) by + !visiting each surface element + !if id indicates it is aliased + !visit each node in the surface element + !if the node has yet to be added to the list (mapped(node)==1) then + ! set mapped(node) to -1 + ! add node to the local_mapping_list(1,:), and + ! increment count + count = 1 + do i = 1, surface_element_count(model) + id = surface_element_id(model,i) + face_nodes = face_global_nodes(model,i) + if(any(aliased_boundary_ids==id)) then + do nod = 1, size(face_nodes) + if(mapped(face_nodes(nod))==1) then + mapped(face_nodes(nod))=-1 + local_mapping_list(1,count) = face_nodes(nod) + count = count + 1 + end if + end do + end if + end do + + !compute the coordinates of the nodes that aliased nodes are mapped to + if (positions%dim==1) then + call set_from_python_function(mapX, & periodic_mapping_python, x(local_mapping_list(1,:)), & time=0.0) - else if (positions%dim==2) then - call set_from_python_function(mapX, & + else if (positions%dim==2) then + call set_from_python_function(mapX, & periodic_mapping_python, x(local_mapping_list(1,:)), & y(local_mapping_list(1,:)), time=0.0) - else if (positions%dim==3) then - call set_from_python_function(mapX, & + else if (positions%dim==3) then + call set_from_python_function(mapX, & periodic_mapping_python, x(local_mapping_list(1,:)), & y(local_mapping_list(1,:)), z(local_mapping_list(1,:)), 0.0) - end if - - !compute list of aliased to nodes - !loop over surface elements - !check for mapped to ids - !if surface is mapped to - !loop over nodes in aliased list - !if any of the aliased nodes are mapped to a point - !close to the current node - !add that to the list - do i = 1, surface_element_count(model) - id = surface_element_id(model,i) - if(any(physical_boundary_ids==id)) then - face_nodes = face_global_nodes(model,i) - do nod = 1, size(face_nodes) - tmp_pos = node_val(positions, face_nodes(nod)) - found_node = .false. - do nod1 = 1, size(mapX,2) + end if + + !compute list of aliased to nodes + !loop over surface elements + !check for mapped to ids + !if surface is mapped to + !loop over nodes in aliased list + !if any of the aliased nodes are mapped to a point + !close to the current node + !add that to the list + do i = 1, surface_element_count(model) + id = surface_element_id(model,i) + if(any(physical_boundary_ids==id)) then + face_nodes = face_global_nodes(model,i) + do nod = 1, size(face_nodes) + tmp_pos = node_val(positions, face_nodes(nod)) + found_node = .false. + do nod1 = 1, size(mapX,2) ! epsilon0 = & ! 100*epsilon(0.0)*max( & ! maxval(abs(my_vec)),maxval(abs(mapX(:,nod1)))) - epsilon0 = 1.0e-5 - if(maxval(abs(tmp_pos-mapX(:,nod1))) mesh%nodes) then - ewrite(-1,*) 'max(ndglno)=',maxval(mesh%ndglno), 'nodes',mesh%nodes - FLAbort('Ndglno contains value greater than nonods') - end if + epsilon0 = 1.0e-5 + if(maxval(abs(tmp_pos-mapX(:,nod1))) mesh%nodes) then + ewrite(-1,*) 'max(ndglno)=',maxval(mesh%ndglno), 'nodes',mesh%nodes + FLAbort('Ndglno contains value greater than nonods') + end if ! ! This test is quadratic in mesh%nodes ! do nod = 1, mesh%nodes ! if(.not.any(nod==mesh%ndglno)) then @@ -2352,951 +2352,951 @@ function make_mesh_periodic(positions,physical_boundary_ids,aliased_boundary_ids ! end if ! end do - if (has_faces(model) .and. present(periodic_face_map)) then - - map_index=0 - face_loop_1: do i=1,surface_element_count(model) - if(any(physical_boundary_ids==surface_element_id(model,i))) then - face_nodes = mapping_list(face_global_nodes(model,i)) - map_index=map_index+1 - - do j=1,surface_element_count(model) - if(any(aliased_boundary_ids==surface_element_id(model,j)))& - & then - face_nodes2 = mapping_list(face_global_nodes(model,j)) - - if (SetContains(face_nodes, face_nodes2)) then - call insert( periodic_face_map, i, j) - - cycle face_loop_1 - end if - - end if - end do - ! If we get here then we have an unmatched face. - FLExit("Unmatched face in periodic mesh creation. Check faces on periodic boundaries conform.") - end if - end do face_loop_1 - - end if - - ! lose our reference - call deallocate(mesh) - - end function make_mesh_periodic - - function make_fake_mesh_linearnonconforming(model, name) result (mesh) - !!< Produce a mesh based on a piecewise linear continuous model mesh but - !!< converted to have edge centred nonconforming nodes. - type(mesh_type) :: mesh - - type(mesh_type), intent(in) :: model - character(len=*), intent(in), optional :: name - - integer :: number_facets, vertices, n, ele, ele2, face2, local_face2, facet_count - integer, dimension(:), pointer :: ele2_nodes, neigh - - type(element_type) :: shape - - ewrite(1,*) 'entering make_mesh_linearnonconforming' - - number_facets = (face_count(model)-surface_element_count(model))/2 & - + surface_element_count(model) - - vertices = model%shape%quadrature%vertices - - ! create a dummy linear shape function to put into the mesh - ! FIXME: I'm Lagrange when I should be NC - do not use for anything other - ! than the number of nodes per element - shape = make_element_shape(vertices = vertices, dim = mesh_dim(model), & - degree = 1, quad = model%shape%quadrature) - - call allocate(mesh, nodes=number_facets, elements=element_count(model), & - shape=shape, name=name) - call deallocate(shape) - - ! Transfer the eelist from model to mesh - assert(associated(model%adj_lists)) - if(associated(model%adj_lists%eelist)) then - ewrite(2, *) "Transferring element-element list to mesh " // trim(mesh%name) - allocate(mesh%adj_lists%eelist) - mesh%adj_lists%eelist = model%adj_lists%eelist - call incref(mesh%adj_lists%eelist) - end if - - mesh%continuity=-1 - - assert(has_faces(model)) - mesh%ndglno = -1 - facet_count = 0 - do ele = 1, element_count(mesh) - ! let's build up the ndglno by looping - ! around the faces (and neighbouring elements) - ! of this element - neigh => ele_neigh(model, ele) - do n = 1, size(neigh) - ele2 = neigh(n) - if((ele2>0).and.(ele2 ele_nodes(mesh, ele2) - ! 4. now, since we've been adding nodes to mesh consistently - ! with the local face numbering we should be able to retrieve - ! the global node number of the node on this face - mesh%ndglno(mesh%shape%loc*(ele-1)+n) = ele2_nodes(local_face2) - else - ! we're adding a new edge so increment - facet_count = facet_count + 1 - mesh%ndglno(mesh%shape%loc*(ele-1)+n) = facet_count - end if - end do - end do - assert(facet_count==number_facets) - assert(all(mesh%ndglno > 0)) - - call addref(mesh) - - ewrite(1,*) 'exiting make_mesh_linearnonconforming' - - end function make_fake_mesh_linearnonconforming - - function make_submesh (model, name) & - result (mesh) - !!< Produce a mesh based on an old mesh but divided into piecewise linear. - !!< FIXME: only works for quadratic simplex elements and doesn't do faces! - type(mesh_type) :: mesh - - type(mesh_type), intent(in) :: model - character(len=*), intent(in), optional :: name - - type(element_type) :: shape - integer :: vertices, model_ele, sub_ele, l_ele - integer, dimension(:,:), allocatable :: permutation - integer, dimension(:), pointer :: model_nodes - logical :: regions - - ewrite(1,*) 'entering make_submesh' - - if (present(name)) then - mesh%name=name - else - mesh%name=empty_name - end if + if (has_faces(model) .and. present(periodic_face_map)) then - allocate(mesh%adj_lists) - mesh%continuity=model%continuity + map_index=0 + face_loop_1: do i=1,surface_element_count(model) + if(any(physical_boundary_ids==surface_element_id(model,i))) then + face_nodes = mapping_list(face_global_nodes(model,i)) + map_index=map_index+1 - mesh%nodes = model%nodes + do j=1,surface_element_count(model) + if(any(aliased_boundary_ids==surface_element_id(model,j)))& + & then + face_nodes2 = mapping_list(face_global_nodes(model,j)) - vertices = model%shape%quadrature%vertices + if (SetContains(face_nodes, face_nodes2)) then + call insert( periodic_face_map, i, j) - select case(model%shape%numbering%family) - case(FAMILY_SIMPLEX) + cycle face_loop_1 + end if - select case(model%shape%degree) - case(2) + end if + end do + ! If we get here then we have an unmatched face. + FLExit("Unmatched face in periodic mesh creation. Check faces on periodic boundaries conform.") + end if + end do face_loop_1 - select case(vertices) - case(3) ! triangle + end if - mesh%elements=4*model%elements + ! lose our reference + call deallocate(mesh) - allocate(permutation(4,3)) - ! here we assume that the one true node ordering is used - permutation = reshape((/1, 2, 2, 4, & - 2, 3, 4, 5, & - 4, 5, 5, 6/), (/4,3/)) - case(4) ! tet + end function make_mesh_periodic - mesh%elements=8*model%elements + function make_fake_mesh_linearnonconforming(model, name) result (mesh) + !!< Produce a mesh based on a piecewise linear continuous model mesh but + !!< converted to have edge centred nonconforming nodes. + type(mesh_type) :: mesh - allocate(permutation(8,4)) - ! here we assume that the one true node ordering is used - ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron - permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & - 2, 3, 5, 8, 4, 5, 5, 7, & - 4, 5, 6, 9, 5, 7, 7, 8, & - 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) - case default - ewrite(-1,*) "Submesh only supported for simplex elements." - FLExit("Unsupported vertex count for the submesh.") - end select - case(1) - !nothing to be done really + type(mesh_type), intent(in) :: model + character(len=*), intent(in), optional :: name - mesh%elements=model%elements + integer :: number_facets, vertices, n, ele, ele2, face2, local_face2, facet_count + integer, dimension(:), pointer :: ele2_nodes, neigh - select case(vertices) - case(3) ! triangle + type(element_type) :: shape + ewrite(1,*) 'entering make_mesh_linearnonconforming' - allocate(permutation(1,3)) - permutation = reshape((/1, 2, 3/), (/1,3/)) - case(4) ! tet + number_facets = (face_count(model)-surface_element_count(model))/2 & + + surface_element_count(model) - allocate(permutation(1,4)) - permutation = reshape((/1, 2, 3, 4/), (/1,4/)) - case default - ewrite(-1,*) "Submesh only supported for simplex elements." - FLExit("Unsupported vertex count for the submesh.") - end select + vertices = model%shape%quadrature%vertices - case default - FLExit("Submesh only supported for quadratic or lower elements") - end select + ! create a dummy linear shape function to put into the mesh + ! FIXME: I'm Lagrange when I should be NC - do not use for anything other + ! than the number of nodes per element + shape = make_element_shape(vertices = vertices, dim = mesh_dim(model), & + degree = 1, quad = model%shape%quadrature) + + call allocate(mesh, nodes=number_facets, elements=element_count(model), & + shape=shape, name=name) + call deallocate(shape) + + ! Transfer the eelist from model to mesh + assert(associated(model%adj_lists)) + if(associated(model%adj_lists%eelist)) then + ewrite(2, *) "Transferring element-element list to mesh " // trim(mesh%name) + allocate(mesh%adj_lists%eelist) + mesh%adj_lists%eelist = model%adj_lists%eelist + call incref(mesh%adj_lists%eelist) + end if + + mesh%continuity=-1 + + assert(has_faces(model)) + mesh%ndglno = -1 + facet_count = 0 + do ele = 1, element_count(mesh) + ! let's build up the ndglno by looping + ! around the faces (and neighbouring elements) + ! of this element + neigh => ele_neigh(model, ele) + do n = 1, size(neigh) + ele2 = neigh(n) + if((ele2>0).and.(ele2 ele_nodes(mesh, ele2) + ! 4. now, since we've been adding nodes to mesh consistently + ! with the local face numbering we should be able to retrieve + ! the global node number of the node on this face + mesh%ndglno(mesh%shape%loc*(ele-1)+n) = ele2_nodes(local_face2) + else + ! we're adding a new edge so increment + facet_count = facet_count + 1 + mesh%ndglno(mesh%shape%loc*(ele-1)+n) = facet_count + end if + end do + end do + assert(facet_count==number_facets) + assert(all(mesh%ndglno > 0)) + + call addref(mesh) + + ewrite(1,*) 'exiting make_mesh_linearnonconforming' + + end function make_fake_mesh_linearnonconforming + + function make_submesh (model, name) & + result (mesh) + !!< Produce a mesh based on an old mesh but divided into piecewise linear. + !!< FIXME: only works for quadratic simplex elements and doesn't do faces! + type(mesh_type) :: mesh + + type(mesh_type), intent(in) :: model + character(len=*), intent(in), optional :: name + + type(element_type) :: shape + integer :: vertices, model_ele, sub_ele, l_ele + integer, dimension(:,:), allocatable :: permutation + integer, dimension(:), pointer :: model_nodes + logical :: regions + + ewrite(1,*) 'entering make_submesh' + + if (present(name)) then + mesh%name=name + else + mesh%name=empty_name + end if + + allocate(mesh%adj_lists) + mesh%continuity=model%continuity + + mesh%nodes = model%nodes + + vertices = model%shape%quadrature%vertices + + select case(model%shape%numbering%family) + case(FAMILY_SIMPLEX) + + select case(model%shape%degree) + case(2) + + select case(vertices) + case(3) ! triangle + + mesh%elements=4*model%elements + + allocate(permutation(4,3)) + ! here we assume that the one true node ordering is used + permutation = reshape((/1, 2, 2, 4, & + 2, 3, 4, 5, & + 4, 5, 5, 6/), (/4,3/)) + case(4) ! tet + + mesh%elements=8*model%elements + + allocate(permutation(8,4)) + ! here we assume that the one true node ordering is used + ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron + permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & + 2, 3, 5, 8, 4, 5, 5, 7, & + 4, 5, 6, 9, 5, 7, 7, 8, & + 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) + case default + ewrite(-1,*) "Submesh only supported for simplex elements." + FLExit("Unsupported vertex count for the submesh.") + end select + case(1) + !nothing to be done really - case default - FLExit("Submesh only supported for simplex elements") - end select + mesh%elements=model%elements - shape = make_element_shape(vertices = vertices, dim = mesh_dim(model), & - degree = 1, quad = model%shape%quadrature) + select case(vertices) + case(3) ! triangle - mesh%shape=shape - call incref(mesh%shape) - regions = .false. - if (associated(model%region_ids)) then - allocate(mesh%region_ids(mesh%elements)) - regions = .true. - end if + allocate(permutation(1,3)) + permutation = reshape((/1, 2, 3/), (/1,3/)) + case(4) ! tet - allocate(mesh%ndglno(mesh%shape%loc*mesh%elements)) + allocate(permutation(1,4)) + permutation = reshape((/1, 2, 3, 4/), (/1,4/)) + case default + ewrite(-1,*) "Submesh only supported for simplex elements." + FLExit("Unsupported vertex count for the submesh.") + end select + + case default + FLExit("Submesh only supported for quadratic or lower elements") + end select + + case default + FLExit("Submesh only supported for simplex elements") + end select + + shape = make_element_shape(vertices = vertices, dim = mesh_dim(model), & + degree = 1, quad = model%shape%quadrature) + + mesh%shape=shape + call incref(mesh%shape) + + regions = .false. + if (associated(model%region_ids)) then + allocate(mesh%region_ids(mesh%elements)) + regions = .true. + end if + + allocate(mesh%ndglno(mesh%shape%loc*mesh%elements)) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", size(mesh%ndglno), & - name=mesh%name) + call register_allocation("mesh_type", "integer", size(mesh%ndglno), & + name=mesh%name) #endif - sub_ele = 0 - do model_ele = 1, element_count(model) - model_nodes=>ele_nodes(model, model_ele) + sub_ele = 0 + do model_ele = 1, element_count(model) + model_nodes=>ele_nodes(model, model_ele) - if(regions) mesh%region_ids(sub_ele+1:sub_ele+size(permutation,1)) = model%region_ids(model_ele) + if(regions) mesh%region_ids(sub_ele+1:sub_ele+size(permutation,1)) = model%region_ids(model_ele) + + do l_ele = 1, size(permutation,1) + sub_ele = sub_ele+1 + mesh%ndglno(mesh%shape%loc*(sub_ele-1)+1:mesh%shape%loc*sub_ele) = model_nodes(permutation(l_ele,:)) + end do - do l_ele = 1, size(permutation,1) - sub_ele = sub_ele+1 - mesh%ndglno(mesh%shape%loc*(sub_ele-1)+1:mesh%shape%loc*sub_ele) = model_nodes(permutation(l_ele,:)) end do - end do - - mesh%wrapped=.false. - mesh%periodic=model%periodic - nullify(mesh%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(mesh) - call deallocate(shape) - - end function make_submesh - - function extract_elements(positions, elements) result(subpos) - !! Given a mesh and a list of elements, - !! return a mesh containing just those elements. - type(vector_field), intent(in), target :: positions - integer, dimension(:), intent(in) :: elements - type(vector_field) :: subpos - - type(mesh_type), pointer :: mesh - type(mesh_type) :: submesh - - integer :: ele, nodes, i, j, k, loc - - mesh => positions%mesh - loc = ele_loc(mesh, 1) - - nodes = size(elements) * loc - call allocate(submesh, nodes, size(elements), ele_shape(mesh, 1), "SubMesh") - call allocate(subpos, positions%dim, submesh, "SubCoordinate") - call deallocate(submesh) - - do j=1,nodes - submesh%ndglno(j) = j - end do - - j = 1 - do i=1,size(elements) - ele = elements(i) - do k=1,positions%dim - subpos%val(k,ele_nodes(subpos, j)) = ele_val(positions, k, ele) - end do - j = j + 1 - end do - end function extract_elements - - subroutine add_lists_mesh(mesh, nnlist, nelist, eelist) - !!< Add requested adjacency lists to the adjacency cache for the supplied mesh - - type(mesh_type), intent(in) :: mesh - logical, optional, intent(in) :: nnlist, nelist, eelist - - type(csr_sparsity), pointer :: lnnlist, lnelist, leelist - - logical :: ladd_nnlist, ladd_nelist, ladd_eelist - - assert(associated(mesh%adj_lists)) - ladd_nnlist = present_and_true(nnlist) .and. .not. associated(mesh%adj_lists%nnlist) - ladd_eelist = present_and_true(eelist) .and. .not. associated(mesh%adj_lists%eelist) - ladd_nelist = (present_and_true(nelist) .or. ladd_eelist) .and. .not. associated(mesh%adj_lists%nelist) - - if(ladd_nnlist .and. ladd_nelist .and. ladd_eelist) then - ewrite(2, *) "Adding node-node list to mesh " // trim(mesh%name) - ewrite(2, *) "Adding node-element list to mesh " // trim(mesh%name) - ewrite(2, *) "Adding element-element list to mesh " // trim(mesh%name) - allocate(mesh%adj_lists%nnlist) - allocate(mesh%adj_lists%nelist) - allocate(mesh%adj_lists%eelist) - ! Use these pointers to work around compilers that insist on having mesh - ! intent(inout) - it really only needs to be intent(in) - lnnlist => mesh%adj_lists%nnlist - lnelist => mesh%adj_lists%nelist - leelist => mesh%adj_lists%eelist - call makelists(mesh, & - & nnlist = lnnlist, & - & nelist = lnelist, & - & eelist = leelist) - else if(ladd_nnlist .and. ladd_nelist) then - ewrite(2, *) "Adding node-node list to mesh " // trim(mesh%name) - ewrite(2, *) "Adding node-element list to mesh " // trim(mesh%name) - allocate(mesh%adj_lists%nnlist) - allocate(mesh%adj_lists%nelist) - ! Use these pointers to work around compilers that insist on having mesh - ! intent(inout) - it really only needs to be intent(in) - lnnlist => mesh%adj_lists%nnlist - lnelist => mesh%adj_lists%nelist - call makelists(mesh, & - & nnlist = lnnlist, & - & nelist = lnelist) - else if(ladd_eelist) then - if(ladd_nnlist) then - call add_nnlist(mesh) - end if - call add_eelist(mesh) ! The eelist generates the nelist. If we need all - ! three then we enter the branch above. - else if(ladd_nnlist) then - call add_nnlist(mesh) - else if(ladd_nelist) then - call add_nelist(mesh) + mesh%wrapped=.false. + mesh%periodic=model%periodic + nullify(mesh%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(mesh) + call deallocate(shape) + + end function make_submesh + + function extract_elements(positions, elements) result(subpos) + !! Given a mesh and a list of elements, + !! return a mesh containing just those elements. + type(vector_field), intent(in), target :: positions + integer, dimension(:), intent(in) :: elements + type(vector_field) :: subpos + + type(mesh_type), pointer :: mesh + type(mesh_type) :: submesh + + integer :: ele, nodes, i, j, k, loc + + mesh => positions%mesh + loc = ele_loc(mesh, 1) + + nodes = size(elements) * loc + call allocate(submesh, nodes, size(elements), ele_shape(mesh, 1), "SubMesh") + call allocate(subpos, positions%dim, submesh, "SubCoordinate") + call deallocate(submesh) + + do j=1,nodes + submesh%ndglno(j) = j + end do + + j = 1 + do i=1,size(elements) + ele = elements(i) + do k=1,positions%dim + subpos%val(k,ele_nodes(subpos, j)) = ele_val(positions, k, ele) + end do + j = j + 1 + end do + end function extract_elements + + subroutine add_lists_mesh(mesh, nnlist, nelist, eelist) + !!< Add requested adjacency lists to the adjacency cache for the supplied mesh + + type(mesh_type), intent(in) :: mesh + logical, optional, intent(in) :: nnlist, nelist, eelist + + type(csr_sparsity), pointer :: lnnlist, lnelist, leelist + + logical :: ladd_nnlist, ladd_nelist, ladd_eelist + + assert(associated(mesh%adj_lists)) + ladd_nnlist = present_and_true(nnlist) .and. .not. associated(mesh%adj_lists%nnlist) + ladd_eelist = present_and_true(eelist) .and. .not. associated(mesh%adj_lists%eelist) + ladd_nelist = (present_and_true(nelist) .or. ladd_eelist) .and. .not. associated(mesh%adj_lists%nelist) + + if(ladd_nnlist .and. ladd_nelist .and. ladd_eelist) then + ewrite(2, *) "Adding node-node list to mesh " // trim(mesh%name) + ewrite(2, *) "Adding node-element list to mesh " // trim(mesh%name) + ewrite(2, *) "Adding element-element list to mesh " // trim(mesh%name) + allocate(mesh%adj_lists%nnlist) + allocate(mesh%adj_lists%nelist) + allocate(mesh%adj_lists%eelist) + ! Use these pointers to work around compilers that insist on having mesh + ! intent(inout) - it really only needs to be intent(in) + lnnlist => mesh%adj_lists%nnlist + lnelist => mesh%adj_lists%nelist + leelist => mesh%adj_lists%eelist + call makelists(mesh, & + & nnlist = lnnlist, & + & nelist = lnelist, & + & eelist = leelist) + else if(ladd_nnlist .and. ladd_nelist) then + ewrite(2, *) "Adding node-node list to mesh " // trim(mesh%name) + ewrite(2, *) "Adding node-element list to mesh " // trim(mesh%name) + allocate(mesh%adj_lists%nnlist) + allocate(mesh%adj_lists%nelist) + ! Use these pointers to work around compilers that insist on having mesh + ! intent(inout) - it really only needs to be intent(in) + lnnlist => mesh%adj_lists%nnlist + lnelist => mesh%adj_lists%nelist + call makelists(mesh, & + & nnlist = lnnlist, & + & nelist = lnelist) + else if(ladd_eelist) then + if(ladd_nnlist) then + call add_nnlist(mesh) + end if + call add_eelist(mesh) ! The eelist generates the nelist. If we need all + ! three then we enter the branch above. + else if(ladd_nnlist) then + call add_nnlist(mesh) + else if(ladd_nelist) then + call add_nelist(mesh) ! else ! ! We already have the requested lists (or no lists were requested) - end if + end if - end subroutine add_lists_mesh + end subroutine add_lists_mesh - subroutine add_lists_scalar(field, nnlist, nelist, eelist) - !!< Add requested adjacency lists to the adjacency cache for the supplied field + subroutine add_lists_scalar(field, nnlist, nelist, eelist) + !!< Add requested adjacency lists to the adjacency cache for the supplied field - type(scalar_field), intent(in) :: field - logical, optional, intent(in) :: nnlist, nelist, eelist + type(scalar_field), intent(in) :: field + logical, optional, intent(in) :: nnlist, nelist, eelist - call add_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) + call add_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) - end subroutine add_lists_scalar + end subroutine add_lists_scalar - subroutine add_lists_vector(field, nnlist, nelist, eelist) - !!< Add requested adjacency lists to the adjacency cache for the supplied field + subroutine add_lists_vector(field, nnlist, nelist, eelist) + !!< Add requested adjacency lists to the adjacency cache for the supplied field - type(vector_field), intent(in) :: field - logical, optional, intent(in) :: nnlist, nelist, eelist + type(vector_field), intent(in) :: field + logical, optional, intent(in) :: nnlist, nelist, eelist - call add_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) + call add_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) - end subroutine add_lists_vector + end subroutine add_lists_vector - subroutine add_lists_tensor(field, nnlist, nelist, eelist) - !!< Add requested adjacency lists to the adjacency cache for the supplied field + subroutine add_lists_tensor(field, nnlist, nelist, eelist) + !!< Add requested adjacency lists to the adjacency cache for the supplied field - type(tensor_field), intent(in) :: field - logical, optional, intent(in) :: nnlist, nelist, eelist + type(tensor_field), intent(in) :: field + logical, optional, intent(in) :: nnlist, nelist, eelist - call add_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) + call add_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) - end subroutine add_lists_tensor + end subroutine add_lists_tensor - subroutine extract_lists_mesh(mesh, nnlist, nelist, eelist) - !!< Extract adjacancy lists (generating if necessary) from the - !!< adjacency cache for the supplied mesh + subroutine extract_lists_mesh(mesh, nnlist, nelist, eelist) + !!< Extract adjacancy lists (generating if necessary) from the + !!< adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh - type(csr_sparsity), optional, intent(out) :: nnlist - type(csr_sparsity), optional, intent(out) :: nelist - type(csr_sparsity), optional, intent(out) :: eelist + type(mesh_type), intent(in) :: mesh + type(csr_sparsity), optional, intent(out) :: nnlist + type(csr_sparsity), optional, intent(out) :: nelist + type(csr_sparsity), optional, intent(out) :: eelist - call add_lists(mesh, nnlist = present(nnlist), nelist = present(nelist), eelist = present(eelist)) - assert(associated(mesh%adj_lists)) - if(present(nnlist)) then - assert(associated(mesh%adj_lists%nnlist)) - nnlist = mesh%adj_lists%nnlist - assert(has_references(nnlist)) - end if - if(present(nelist)) then - assert(associated(mesh%adj_lists%nelist)) - nelist = mesh%adj_lists%nelist - assert(has_references(nelist)) - end if - if(present(eelist)) then - assert(associated(mesh%adj_lists%eelist)) - eelist = mesh%adj_lists%eelist - assert(has_references(eelist)) - end if + call add_lists(mesh, nnlist = present(nnlist), nelist = present(nelist), eelist = present(eelist)) + assert(associated(mesh%adj_lists)) + if(present(nnlist)) then + assert(associated(mesh%adj_lists%nnlist)) + nnlist = mesh%adj_lists%nnlist + assert(has_references(nnlist)) + end if + if(present(nelist)) then + assert(associated(mesh%adj_lists%nelist)) + nelist = mesh%adj_lists%nelist + assert(has_references(nelist)) + end if + if(present(eelist)) then + assert(associated(mesh%adj_lists%eelist)) + eelist = mesh%adj_lists%eelist + assert(has_references(eelist)) + end if - end subroutine extract_lists_mesh + end subroutine extract_lists_mesh - subroutine extract_lists_scalar(field, nnlist, nelist, eelist) - !!< Extract adjacancy lists (generating if necessary) from the - !!< adjacency cache for the supplied field + subroutine extract_lists_scalar(field, nnlist, nelist, eelist) + !!< Extract adjacancy lists (generating if necessary) from the + !!< adjacency cache for the supplied field - type(scalar_field), intent(in) :: field - type(csr_sparsity), optional, intent(out) :: nnlist - type(csr_sparsity), optional, intent(out) :: nelist - type(csr_sparsity), optional, intent(out) :: eelist + type(scalar_field), intent(in) :: field + type(csr_sparsity), optional, intent(out) :: nnlist + type(csr_sparsity), optional, intent(out) :: nelist + type(csr_sparsity), optional, intent(out) :: eelist - call extract_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) + call extract_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) - end subroutine extract_lists_scalar + end subroutine extract_lists_scalar - subroutine extract_lists_vector(field, nnlist, nelist, eelist) - !!< Extract adjacancy lists (generating if necessary) from the - !!< adjacency cache for the supplied field + subroutine extract_lists_vector(field, nnlist, nelist, eelist) + !!< Extract adjacancy lists (generating if necessary) from the + !!< adjacency cache for the supplied field - type(vector_field), intent(in) :: field - type(csr_sparsity), optional, intent(out) :: nnlist - type(csr_sparsity), optional, intent(out) :: nelist - type(csr_sparsity), optional, intent(out) :: eelist + type(vector_field), intent(in) :: field + type(csr_sparsity), optional, intent(out) :: nnlist + type(csr_sparsity), optional, intent(out) :: nelist + type(csr_sparsity), optional, intent(out) :: eelist - call extract_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) + call extract_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) - end subroutine extract_lists_vector + end subroutine extract_lists_vector - subroutine extract_lists_tensor(field, nnlist, nelist, eelist) - !!< Extract adjacancy lists (generating if necessary) from the - !!< adjacency cache for the supplied field + subroutine extract_lists_tensor(field, nnlist, nelist, eelist) + !!< Extract adjacancy lists (generating if necessary) from the + !!< adjacency cache for the supplied field - type(tensor_field), intent(in) :: field - type(csr_sparsity), optional, intent(out) :: nnlist - type(csr_sparsity), optional, intent(out) :: nelist - type(csr_sparsity), optional, intent(out) :: eelist + type(tensor_field), intent(in) :: field + type(csr_sparsity), optional, intent(out) :: nnlist + type(csr_sparsity), optional, intent(out) :: nelist + type(csr_sparsity), optional, intent(out) :: eelist - call extract_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) + call extract_lists(field%mesh, nnlist = nnlist, nelist = nelist, eelist = eelist) - end subroutine extract_lists_tensor + end subroutine extract_lists_tensor - subroutine add_nnlist_mesh(mesh) - !!< Add the node-node list to the adjacency cache for the supplied mesh + subroutine add_nnlist_mesh(mesh) + !!< Add the node-node list to the adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - type(csr_sparsity), pointer :: nnlist + type(csr_sparsity), pointer :: nnlist - assert(associated(mesh%adj_lists)) - if(.not. associated(mesh%adj_lists%nnlist)) then - ewrite(2, *) "Adding node-node list to mesh " // trim(mesh%name) - allocate(nnlist) - mesh%adj_lists%nnlist => nnlist - call makelists(mesh, nnlist = nnlist) + assert(associated(mesh%adj_lists)) + if(.not. associated(mesh%adj_lists%nnlist)) then + ewrite(2, *) "Adding node-node list to mesh " // trim(mesh%name) + allocate(nnlist) + mesh%adj_lists%nnlist => nnlist + call makelists(mesh, nnlist = nnlist) #ifdef DDEBUG - else - assert(has_references(mesh%adj_lists%nnlist)) + else + assert(has_references(mesh%adj_lists%nnlist)) #endif - end if + end if - end subroutine add_nnlist_mesh + end subroutine add_nnlist_mesh - subroutine add_nnlist_scalar(field) - !!< Add the node-node list to the adjacency cache for the supplied field + subroutine add_nnlist_scalar(field) + !!< Add the node-node list to the adjacency cache for the supplied field - type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: field - call add_nnlist(field%mesh) + call add_nnlist(field%mesh) - end subroutine add_nnlist_scalar + end subroutine add_nnlist_scalar - subroutine add_nnlist_vector(field) - !!< Add the node-node list to the adjacency cache for the supplied field + subroutine add_nnlist_vector(field) + !!< Add the node-node list to the adjacency cache for the supplied field - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - call add_nnlist(field%mesh) + call add_nnlist(field%mesh) - end subroutine add_nnlist_vector + end subroutine add_nnlist_vector - subroutine add_nnlist_tensor(field) - !!< Add the node-node list to the adjacency cache for the supplied field + subroutine add_nnlist_tensor(field) + !!< Add the node-node list to the adjacency cache for the supplied field - type(tensor_field), intent(in) :: field + type(tensor_field), intent(in) :: field - call add_nnlist(field%mesh) + call add_nnlist(field%mesh) - end subroutine add_nnlist_tensor + end subroutine add_nnlist_tensor - function extract_nnlist_mesh(mesh) result(nnlist) - !!< Extract the node-node list (generating if necessary) from the - !!< adjacency cache for the supplied mesh + function extract_nnlist_mesh(mesh) result(nnlist) + !!< Extract the node-node list (generating if necessary) from the + !!< adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - type(csr_sparsity), pointer :: nnlist + type(csr_sparsity), pointer :: nnlist - call add_nnlist(mesh) - nnlist => mesh%adj_lists%nnlist - assert(has_references(nnlist)) + call add_nnlist(mesh) + nnlist => mesh%adj_lists%nnlist + assert(has_references(nnlist)) - end function extract_nnlist_mesh + end function extract_nnlist_mesh - function extract_nnlist_scalar(field) result(nnlist) - !!< Extract the node-node list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_nnlist_scalar(field) result(nnlist) + !!< Extract the node-node list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: field - type(csr_sparsity), pointer :: nnlist + type(csr_sparsity), pointer :: nnlist - nnlist => extract_nnlist(field%mesh) + nnlist => extract_nnlist(field%mesh) - end function extract_nnlist_scalar + end function extract_nnlist_scalar - function extract_nnlist_vector(field) result(nnlist) - !!< Extract the node-node list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_nnlist_vector(field) result(nnlist) + !!< Extract the node-node list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - type(csr_sparsity), pointer :: nnlist + type(csr_sparsity), pointer :: nnlist - nnlist => extract_nnlist(field%mesh) + nnlist => extract_nnlist(field%mesh) - end function extract_nnlist_vector + end function extract_nnlist_vector - function extract_nnlist_tensor(field) result(nnlist) - !!< Extract the node-node list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_nnlist_tensor(field) result(nnlist) + !!< Extract the node-node list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(tensor_field), intent(in) :: field + type(tensor_field), intent(in) :: field - type(csr_sparsity), pointer :: nnlist + type(csr_sparsity), pointer :: nnlist - nnlist => extract_nnlist(field%mesh) + nnlist => extract_nnlist(field%mesh) - end function extract_nnlist_tensor + end function extract_nnlist_tensor - subroutine add_nelist_mesh(mesh) - !!< Add the node-element list to the adjacency cache for the supplied mesh + subroutine add_nelist_mesh(mesh) + !!< Add the node-element list to the adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - type(csr_sparsity), pointer :: nelist + type(csr_sparsity), pointer :: nelist - assert(associated(mesh%adj_lists)) - if(.not. associated(mesh%adj_lists%nelist)) then - ewrite(2, *) "Adding node-element list to mesh " // trim(mesh%name) - allocate(nelist) - mesh%adj_lists%nelist => nelist - call makelists(mesh, nelist = nelist) + assert(associated(mesh%adj_lists)) + if(.not. associated(mesh%adj_lists%nelist)) then + ewrite(2, *) "Adding node-element list to mesh " // trim(mesh%name) + allocate(nelist) + mesh%adj_lists%nelist => nelist + call makelists(mesh, nelist = nelist) #ifdef DDEBUG - else - assert(has_references(mesh%adj_lists%nelist)) + else + assert(has_references(mesh%adj_lists%nelist)) #endif - end if + end if - end subroutine add_nelist_mesh + end subroutine add_nelist_mesh - subroutine add_nelist_scalar(field) - !!< Add the node-element list to the adjacency cache for the supplied field + subroutine add_nelist_scalar(field) + !!< Add the node-element list to the adjacency cache for the supplied field - type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: field - call add_nelist(field%mesh) + call add_nelist(field%mesh) - end subroutine add_nelist_scalar + end subroutine add_nelist_scalar - subroutine add_nelist_vector(field) - !!< Add the node-element list to the adjacency cache for the supplied field + subroutine add_nelist_vector(field) + !!< Add the node-element list to the adjacency cache for the supplied field - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - call add_nelist(field%mesh) + call add_nelist(field%mesh) - end subroutine add_nelist_vector + end subroutine add_nelist_vector - subroutine add_nelist_tensor(field) - !!< Add the node-element list to the adjacency cache for the supplied field + subroutine add_nelist_tensor(field) + !!< Add the node-element list to the adjacency cache for the supplied field - type(tensor_field), intent(in) :: field + type(tensor_field), intent(in) :: field - call add_nelist(field%mesh) + call add_nelist(field%mesh) - end subroutine add_nelist_tensor + end subroutine add_nelist_tensor - function extract_nelist_mesh(mesh) result(nelist) - !!< Extract the node-element list (generating if necessary) from the - !!< adjacency cache for the supplied mesh + function extract_nelist_mesh(mesh) result(nelist) + !!< Extract the node-element list (generating if necessary) from the + !!< adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - type(csr_sparsity), pointer :: nelist + type(csr_sparsity), pointer :: nelist - call add_nelist(mesh) - nelist => mesh%adj_lists%nelist - assert(has_references(nelist)) + call add_nelist(mesh) + nelist => mesh%adj_lists%nelist + assert(has_references(nelist)) - end function extract_nelist_mesh + end function extract_nelist_mesh - function extract_nelist_scalar(field) result(nelist) - !!< Extract the node-element list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_nelist_scalar(field) result(nelist) + !!< Extract the node-element list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: field - type(csr_sparsity), pointer :: nelist + type(csr_sparsity), pointer :: nelist - nelist => extract_nelist(field%mesh) + nelist => extract_nelist(field%mesh) - end function extract_nelist_scalar + end function extract_nelist_scalar - function extract_nelist_vector(field) result(nelist) - !!< Extract the node-element list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_nelist_vector(field) result(nelist) + !!< Extract the node-element list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - type(csr_sparsity), pointer :: nelist + type(csr_sparsity), pointer :: nelist - nelist => extract_nelist(field%mesh) + nelist => extract_nelist(field%mesh) - end function extract_nelist_vector + end function extract_nelist_vector - function extract_nelist_tensor(field) result(nelist) - !!< Extract the node-element list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_nelist_tensor(field) result(nelist) + !!< Extract the node-element list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(tensor_field), intent(in) :: field + type(tensor_field), intent(in) :: field - type(csr_sparsity), pointer :: nelist + type(csr_sparsity), pointer :: nelist - nelist => extract_nelist(field%mesh) + nelist => extract_nelist(field%mesh) - end function extract_nelist_tensor + end function extract_nelist_tensor - subroutine add_eelist_mesh(mesh) - !!< Add the element-element list to the adjacency cache for the supplied mesh + subroutine add_eelist_mesh(mesh) + !!< Add the element-element list to the adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - type(csr_sparsity), pointer :: eelist, nelist + type(csr_sparsity), pointer :: eelist, nelist - assert(associated(mesh%adj_lists)) - if(.not. associated(mesh%adj_lists%eelist)) then - ewrite(2, *) "Adding element-element list to mesh " // trim(mesh%name) - allocate(eelist) - mesh%adj_lists%eelist => eelist - ! We need the nelist to generate the eelist, so extract it from the cache - ! (generating if necessary) - nelist => extract_nelist(mesh) - ewrite(1, *) "Using the new makeeelist" - call makeeelist(eelist, mesh, nelist) + assert(associated(mesh%adj_lists)) + if(.not. associated(mesh%adj_lists%eelist)) then + ewrite(2, *) "Adding element-element list to mesh " // trim(mesh%name) + allocate(eelist) + mesh%adj_lists%eelist => eelist + ! We need the nelist to generate the eelist, so extract it from the cache + ! (generating if necessary) + nelist => extract_nelist(mesh) + ewrite(1, *) "Using the new makeeelist" + call makeeelist(eelist, mesh, nelist) #ifdef DDEBUG - else - assert(has_references(mesh%adj_lists%eelist)) + else + assert(has_references(mesh%adj_lists%eelist)) #endif - end if + end if - end subroutine add_eelist_mesh + end subroutine add_eelist_mesh - subroutine add_eelist_scalar(field) - !!< Add the element-element list to the adjacency cache for the supplied field + subroutine add_eelist_scalar(field) + !!< Add the element-element list to the adjacency cache for the supplied field - type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: field - call add_eelist(field%mesh) + call add_eelist(field%mesh) - end subroutine add_eelist_scalar + end subroutine add_eelist_scalar - subroutine add_eelist_vector(field) - !!< Add the element-element list to the adjacency cache for the supplied field + subroutine add_eelist_vector(field) + !!< Add the element-element list to the adjacency cache for the supplied field - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - call add_eelist(field%mesh) + call add_eelist(field%mesh) - end subroutine add_eelist_vector + end subroutine add_eelist_vector - subroutine add_eelist_tensor(field) - !!< Add the element-element list to the adjacency cache for the supplied field + subroutine add_eelist_tensor(field) + !!< Add the element-element list to the adjacency cache for the supplied field - type(tensor_field), intent(in) :: field + type(tensor_field), intent(in) :: field - call add_eelist(field%mesh) + call add_eelist(field%mesh) - end subroutine add_eelist_tensor + end subroutine add_eelist_tensor - function extract_eelist_mesh(mesh) result(eelist) - !!< Extract the element-element list (generating if necessary) from the - !!< adjacency cache for the supplied mesh + function extract_eelist_mesh(mesh) result(eelist) + !!< Extract the element-element list (generating if necessary) from the + !!< adjacency cache for the supplied mesh - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - type(csr_sparsity), pointer :: eelist + type(csr_sparsity), pointer :: eelist - call add_eelist(mesh) - eelist => mesh%adj_lists%eelist - assert(has_references(eelist)) + call add_eelist(mesh) + eelist => mesh%adj_lists%eelist + assert(has_references(eelist)) - end function extract_eelist_mesh + end function extract_eelist_mesh - function extract_eelist_scalar(field) result(eelist) - !!< Extract the element-element list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_eelist_scalar(field) result(eelist) + !!< Extract the element-element list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: field - type(csr_sparsity), pointer :: eelist + type(csr_sparsity), pointer :: eelist - eelist => extract_eelist(field%mesh) + eelist => extract_eelist(field%mesh) - end function extract_eelist_scalar + end function extract_eelist_scalar - function extract_eelist_vector(field) result(eelist) - !!< Extract the element-element list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_eelist_vector(field) result(eelist) + !!< Extract the element-element list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - type(csr_sparsity), pointer :: eelist + type(csr_sparsity), pointer :: eelist - eelist => extract_eelist(field%mesh) + eelist => extract_eelist(field%mesh) - end function extract_eelist_vector + end function extract_eelist_vector - function extract_eelist_tensor(field) result(eelist) - !!< Extract the element-element list (generating if necessary) from the - !!< adjacency cache for the supplied field + function extract_eelist_tensor(field) result(eelist) + !!< Extract the element-element list (generating if necessary) from the + !!< adjacency cache for the supplied field - type(tensor_field), intent(in) :: field + type(tensor_field), intent(in) :: field - type(csr_sparsity), pointer :: eelist + type(csr_sparsity), pointer :: eelist - eelist => extract_eelist(field%mesh) + eelist => extract_eelist(field%mesh) - end function extract_eelist_tensor + end function extract_eelist_tensor - subroutine remove_lists_mesh(mesh) - !!< Remove the adjecency lists from the adjacency cache for the supplied - !!< mesh + subroutine remove_lists_mesh(mesh) + !!< Remove the adjecency lists from the adjacency cache for the supplied + !!< mesh - type(mesh_type), intent(inout) :: mesh + type(mesh_type), intent(inout) :: mesh - call remove_nnlist(mesh) - call remove_nelist(mesh) - call remove_eelist(mesh) + call remove_nnlist(mesh) + call remove_nelist(mesh) + call remove_eelist(mesh) - end subroutine remove_lists_mesh + end subroutine remove_lists_mesh - subroutine remove_nnlist_mesh(mesh) - !!< Remove the node-node list from the adjacency cache for the supplied mesh + subroutine remove_nnlist_mesh(mesh) + !!< Remove the node-node list from the adjacency cache for the supplied mesh - type(mesh_type), intent(inout) :: mesh + type(mesh_type), intent(inout) :: mesh - assert(associated(mesh%adj_lists)) - if(associated(mesh%adj_lists%nnlist)) then - ewrite(2, *) "Removing node-node list from mesh " // trim(mesh%name) - call deallocate(mesh%adj_lists%nnlist) - deallocate(mesh%adj_lists%nnlist) - nullify(mesh%adj_lists%nnlist) - end if + assert(associated(mesh%adj_lists)) + if(associated(mesh%adj_lists%nnlist)) then + ewrite(2, *) "Removing node-node list from mesh " // trim(mesh%name) + call deallocate(mesh%adj_lists%nnlist) + deallocate(mesh%adj_lists%nnlist) + nullify(mesh%adj_lists%nnlist) + end if - end subroutine remove_nnlist_mesh + end subroutine remove_nnlist_mesh - subroutine remove_nelist_mesh(mesh) - !!< Remove the node-element list from the adjacency cache for the supplied mesh + subroutine remove_nelist_mesh(mesh) + !!< Remove the node-element list from the adjacency cache for the supplied mesh - type(mesh_type), intent(inout) :: mesh + type(mesh_type), intent(inout) :: mesh - assert(associated(mesh%adj_lists)) - if(associated(mesh%adj_lists%nelist)) then - ewrite(2, *) "Removing node-element list from mesh " // trim(mesh%name) - call deallocate(mesh%adj_lists%nelist) - deallocate(mesh%adj_lists%nelist) - nullify(mesh%adj_lists%nelist) - end if + assert(associated(mesh%adj_lists)) + if(associated(mesh%adj_lists%nelist)) then + ewrite(2, *) "Removing node-element list from mesh " // trim(mesh%name) + call deallocate(mesh%adj_lists%nelist) + deallocate(mesh%adj_lists%nelist) + nullify(mesh%adj_lists%nelist) + end if - end subroutine remove_nelist_mesh + end subroutine remove_nelist_mesh - subroutine remove_eelist_mesh(mesh) - !!< Remove the element-element list from the adjacency cache for the supplied mesh + subroutine remove_eelist_mesh(mesh) + !!< Remove the element-element list from the adjacency cache for the supplied mesh - type(mesh_type), intent(inout) :: mesh + type(mesh_type), intent(inout) :: mesh - assert(associated(mesh%adj_lists)) - if(associated(mesh%adj_lists%eelist)) then - ewrite(2, *) "Removing element-element list from mesh " // trim(mesh%name) - call deallocate(mesh%adj_lists%eelist) - deallocate(mesh%adj_lists%eelist) - nullify(mesh%adj_lists%eelist) - end if + assert(associated(mesh%adj_lists)) + if(associated(mesh%adj_lists%eelist)) then + ewrite(2, *) "Removing element-element list from mesh " // trim(mesh%name) + call deallocate(mesh%adj_lists%eelist) + deallocate(mesh%adj_lists%eelist) + nullify(mesh%adj_lists%eelist) + end if - end subroutine remove_eelist_mesh + end subroutine remove_eelist_mesh - subroutine zero_scalar(field) - !!< Set all entries in the field provided to 0.0 - type(scalar_field), intent(inout) :: field + subroutine zero_scalar(field) + !!< Set all entries in the field provided to 0.0 + type(scalar_field), intent(inout) :: field #ifdef _OPENMP - integer :: i + integer :: i #endif - assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type/=FIELD_TYPE_PYTHON) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do i=1, size(field%val) - field%val(i)=0.0 - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do i=1, size(field%val) + field%val(i)=0.0 + end do + !$OMP END PARALLEL DO #else - field%val=0.0 + field%val=0.0 #endif - end subroutine zero_scalar + end subroutine zero_scalar - subroutine zero_vector(field) - !!< Set all entries in the field provided to 0.0 - type(vector_field), intent(inout) :: field + subroutine zero_vector(field) + !!< Set all entries in the field provided to 0.0 + type(vector_field), intent(inout) :: field #ifdef _OPENMP - integer :: i + integer :: i #endif - assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type/=FIELD_TYPE_PYTHON) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do i=1, size(field%val, 2) - field%val(:,i)=0.0 - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do i=1, size(field%val, 2) + field%val(:,i)=0.0 + end do + !$OMP END PARALLEL DO #else - field%val=0.0 + field%val=0.0 #endif - end subroutine zero_vector + end subroutine zero_vector - subroutine zero_vector_dim(field, dim) - !!< Set all entries in dimension dim of the field provided to 0.0 - type(vector_field), intent(inout) :: field - integer, intent(in) :: dim + subroutine zero_vector_dim(field, dim) + !!< Set all entries in dimension dim of the field provided to 0.0 + type(vector_field), intent(inout) :: field + integer, intent(in) :: dim #ifdef _OPENMP - integer :: j + integer :: j #endif - assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type/=FIELD_TYPE_PYTHON) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do j=1, size(field%val, 2) - field%val(dim,j)=0.0 - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do j=1, size(field%val, 2) + field%val(dim,j)=0.0 + end do + !$OMP END PARALLEL DO #else - field%val(dim,:)=0.0 + field%val(dim,:)=0.0 #endif - end subroutine zero_vector_dim + end subroutine zero_vector_dim - subroutine zero_tensor(field) - !!< Set all entries in the field provided to 0.0 - type(tensor_field), intent(inout) :: field + subroutine zero_tensor(field) + !!< Set all entries in the field provided to 0.0 + type(tensor_field), intent(inout) :: field #ifdef _OPENMP - integer :: j + integer :: j #endif - assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type/=FIELD_TYPE_PYTHON) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do j=1, size(field%val, 3) - field%val(:,:,j)=0.0 - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do j=1, size(field%val, 3) + field%val(:,:,j)=0.0 + end do + !$OMP END PARALLEL DO #else - field%val=0.0 + field%val=0.0 #endif - end subroutine zero_tensor + end subroutine zero_tensor - subroutine zero_tensor_dim_dim(field, dim1, dim2) - !!< Set all entries in the component indicated of field to 0.0 - type(tensor_field), intent(inout) :: field - integer, intent(in) :: dim1, dim2 + subroutine zero_tensor_dim_dim(field, dim1, dim2) + !!< Set all entries in the component indicated of field to 0.0 + type(tensor_field), intent(inout) :: field + integer, intent(in) :: dim1, dim2 #ifdef _OPENMP - integer :: j + integer :: j #endif - assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type/=FIELD_TYPE_PYTHON) #ifdef _OPENMP - ! Use first touch policy. - !$OMP PARALLEL DO SCHEDULE(STATIC) - do j=1, size(field%val, 3) - field%val(dim1,dim2,j)=0.0 - end do - !$OMP END PARALLEL DO + ! Use first touch policy. + !$OMP PARALLEL DO SCHEDULE(STATIC) + do j=1, size(field%val, 3) + field%val(dim1,dim2,j)=0.0 + end do + !$OMP END PARALLEL DO #else - field%val(dim1,dim2,:)=0.0 + field%val(dim1,dim2,:)=0.0 #endif - end subroutine zero_tensor_dim_dim + end subroutine zero_tensor_dim_dim - subroutine zero_scalar_field_nodes(field, node_numbers) - !!< Zeroes the scalar field at the specified node_numbers - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers + subroutine zero_scalar_field_nodes(field, node_numbers) + !!< Zeroes the scalar field at the specified node_numbers + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers - assert(field%field_type==FIELD_TYPE_NORMAL) + assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(node_numbers) = 0.0 + field%val(node_numbers) = 0.0 - end subroutine zero_scalar_field_nodes + end subroutine zero_scalar_field_nodes - subroutine zero_vector_field_nodes(field, node_numbers) - !!< Zeroes the vector field at the specified nodes - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - integer :: i + subroutine zero_vector_field_nodes(field, node_numbers) + !!< Zeroes the vector field at the specified nodes + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + integer :: i - assert(field%field_type==FIELD_TYPE_NORMAL) + assert(field%field_type==FIELD_TYPE_NORMAL) - do i=1,field%dim - field%val(i,node_numbers) = 0.0 - end do + do i=1,field%dim + field%val(i,node_numbers) = 0.0 + end do - end subroutine zero_vector_field_nodes + end subroutine zero_vector_field_nodes - subroutine zero_tensor_field_nodes(field, node_numbers) - !!< Zeroes the tensor field at the specified nodes - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers + subroutine zero_tensor_field_nodes(field, node_numbers) + !!< Zeroes the tensor field at the specified nodes + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers - assert(field%field_type==FIELD_TYPE_NORMAL) + assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(:, :, node_numbers) = 0.0 + field%val(:, :, node_numbers) = 0.0 - end subroutine zero_tensor_field_nodes + end subroutine zero_tensor_field_nodes #include "Reference_count_mesh_type.F90" #include "Reference_count_scalar_field.F90" diff --git a/femtools/Fields_Base.F90 b/femtools/Fields_Base.F90 index 05e30dbb58..166920e395 100644 --- a/femtools/Fields_Base.F90 +++ b/femtools/Fields_Base.F90 @@ -27,3993 +27,3993 @@ #include "fdebug.h" module fields_base - !!< This module contains abstracted field types which carry shape and - !!< connectivity with them. - use fldebug - use global_parameters, only: FIELD_NAME_LEN, current_debug_level, current_time - use futils, only: free_unit, int2str - use reference_counting - use element_numbering - use vector_tools, only: solve, invert, norm2, cross_product - use elements - use shape_functions, only: element_type - use tensors - use sparse_tools - use fields_data_types - use embed_python - implicit none - - interface ele_nodes - module procedure ele_nodes_scalar, ele_nodes_vector, ele_nodes_tensor,& - & ele_nodes_mesh - end interface - - interface face_local_nodes - module procedure face_local_nodes_mesh,face_local_nodes_scalar,& - & face_local_nodes_vector, face_local_nodes_tensor - end interface - - interface face_global_nodes - module procedure face_global_nodes_mesh, face_global_nodes_vector,& - & face_global_nodes_scalar, face_global_nodes_tensor - end interface - - interface ele_neigh - module procedure ele_neigh_mesh, ele_neigh_scalar, ele_neigh_vector, & - & ele_neigh_tensor, ele_neigh_i_mesh, ele_neigh_i_scalar, & - & ele_neigh_i_vector, ele_neigh_i_tensor - end interface - - interface ele_faces - module procedure ele_faces_mesh, ele_faces_vector, ele_faces_scalar, & - & ele_faces_tensor - end interface - - interface node_neigh - module procedure node_neigh_mesh, node_neigh_vector, node_neigh_scalar, & - & node_neigh_tensor - end interface - - interface face_neigh - module procedure face_neigh_mesh, face_neigh_scalar, face_neigh_vector, & - & face_neigh_tensor - end interface - - interface ele_face - module procedure ele_face_mesh, ele_face_scalar, ele_face_vector,& - & ele_face_tensor - end interface - - interface face_ele - module procedure face_ele_mesh, face_ele_scalar, face_ele_vector,& - & face_ele_tensor - end interface - - interface local_face_number - module procedure local_face_number_mesh, local_face_number_scalar, & - & local_face_number_vector, local_face_number_tensor - end interface local_face_number - - interface ele_face_count - module procedure ele_face_count_mesh, ele_face_count_scalar,& - & ele_face_count_vector, ele_face_count_tensor - end interface - - interface ele_numbering_family - module procedure ele_numbering_family_shape, ele_numbering_family_mesh, & + !!< This module contains abstracted field types which carry shape and + !!< connectivity with them. + use fldebug + use global_parameters, only: FIELD_NAME_LEN, current_debug_level, current_time + use futils, only: free_unit, int2str + use reference_counting + use element_numbering + use vector_tools, only: solve, invert, norm2, cross_product + use elements + use shape_functions, only: element_type + use tensors + use sparse_tools + use fields_data_types + use embed_python + implicit none + + interface ele_nodes + module procedure ele_nodes_scalar, ele_nodes_vector, ele_nodes_tensor,& + & ele_nodes_mesh + end interface + + interface face_local_nodes + module procedure face_local_nodes_mesh,face_local_nodes_scalar,& + & face_local_nodes_vector, face_local_nodes_tensor + end interface + + interface face_global_nodes + module procedure face_global_nodes_mesh, face_global_nodes_vector,& + & face_global_nodes_scalar, face_global_nodes_tensor + end interface + + interface ele_neigh + module procedure ele_neigh_mesh, ele_neigh_scalar, ele_neigh_vector, & + & ele_neigh_tensor, ele_neigh_i_mesh, ele_neigh_i_scalar, & + & ele_neigh_i_vector, ele_neigh_i_tensor + end interface + + interface ele_faces + module procedure ele_faces_mesh, ele_faces_vector, ele_faces_scalar, & + & ele_faces_tensor + end interface + + interface node_neigh + module procedure node_neigh_mesh, node_neigh_vector, node_neigh_scalar, & + & node_neigh_tensor + end interface + + interface face_neigh + module procedure face_neigh_mesh, face_neigh_scalar, face_neigh_vector, & + & face_neigh_tensor + end interface + + interface ele_face + module procedure ele_face_mesh, ele_face_scalar, ele_face_vector,& + & ele_face_tensor + end interface + + interface face_ele + module procedure face_ele_mesh, face_ele_scalar, face_ele_vector,& + & face_ele_tensor + end interface + + interface local_face_number + module procedure local_face_number_mesh, local_face_number_scalar, & + & local_face_number_vector, local_face_number_tensor + end interface local_face_number + + interface ele_face_count + module procedure ele_face_count_mesh, ele_face_count_scalar,& + & ele_face_count_vector, ele_face_count_tensor + end interface + + interface ele_numbering_family + module procedure ele_numbering_family_shape, ele_numbering_family_mesh, & & ele_numbering_family_scalar, ele_numbering_family_vector, & & ele_numbering_family_tensor - end interface ele_numbering_family + end interface ele_numbering_family - interface ele_num_type - module procedure ele_num_type_shape, ele_num_type_mesh, & + interface ele_num_type + module procedure ele_num_type_shape, ele_num_type_mesh, & & ele_num_type_scalar, ele_num_type_vector, & & ele_num_type_tensor - end interface ele_num_type - - interface ele_loc - module procedure ele_loc_scalar, ele_loc_vector, ele_loc_tensor,& - & ele_loc_mesh - end interface - - interface ele_vertices - module procedure ele_vertices_scalar, ele_vertices_vector, ele_vertices_tensor,& - & ele_vertices_mesh - end interface - - interface face_vertices - module procedure face_vertices_scalar, face_vertices_vector, face_vertices_tensor,& - & face_vertices_mesh, face_vertices_shape - end interface - - interface ele_ngi - module procedure ele_ngi_scalar, ele_ngi_vector, ele_ngi_tensor,& - & ele_ngi_mesh - end interface - - interface face_loc - module procedure face_loc_scalar, face_loc_vector, face_loc_tensor,& - & face_loc_mesh - end interface - - interface ele_and_faces_loc - module procedure ele_and_faces_loc_scalar, ele_and_faces_loc_vector,& - & ele_and_faces_loc_tensor, ele_and_faces_loc_mesh - end interface - - interface face_ngi - module procedure face_ngi_scalar, face_ngi_vector, face_ngi_tensor,& - & face_ngi_mesh - end interface - - interface ele_shape - module procedure ele_shape_scalar, ele_shape_vector, ele_shape_tensor,& - & ele_shape_mesh - end interface - - interface ele_n_constraints - module procedure ele_n_constraints_vector - end interface - - interface face_shape - module procedure face_shape_scalar, face_shape_vector,& - & face_shape_tensor, face_shape_mesh - end interface - - interface ele_val - module procedure ele_val_scalar, ele_val_vector, ele_val_vector_dim,& - & ele_val_tensor, ele_val_tensor_dim_dim - end interface - - interface face_val - module procedure face_val_scalar, face_val_vector, face_val_tensor,& - & face_val_vector_dim, face_val_tensor_dim_dim - end interface - - interface ele_val_at_quad - module procedure ele_val_at_quad_scalar, ele_val_at_quad_vector,& - & ele_val_at_quad_tensor, ele_val_at_shape_quad_scalar, & - & ele_val_at_shape_quad_vector, ele_val_at_shape_quad_tensor, & - & ele_val_at_quad_vector_dim, ele_val_at_quad_tensor_dim_dim - end interface - - interface face_val_at_quad - module procedure face_val_at_quad_scalar, face_val_at_quad_vector, & - & face_val_at_quad_tensor, face_val_at_quad_vector_dim,& - & face_val_at_quad_tensor_dim_dim, face_val_at_shape_quad_scalar,& - & face_val_at_shape_quad_vector, face_val_at_shape_quad_tensor - end interface - - interface ele_grad_at_quad - module procedure ele_grad_at_quad_scalar, ele_grad_at_quad_vector - end interface - - interface node_val - module procedure node_val_scalar, node_val_vector, node_val_tensor, & - & node_val_scalar_v, node_val_vector_v, node_val_vector_dim_v,& - & node_val_tensor_v, node_val_vector_dim, node_val_tensor_dim_dim, & - & node_val_tensor_dim_dim_v - end interface - - interface node_count - module procedure node_count_scalar, node_count_vector,& - & node_count_tensor, node_count_mesh - end interface - - interface node_ele - module procedure node_ele_mesh, node_ele_scalar, node_ele_vector,& - & node_ele_tensor - end interface - - interface element_count - module procedure element_count_scalar, element_count_vector,& - & element_count_tensor, element_count_mesh - end interface - - interface ele_count - module procedure element_count_scalar, element_count_vector,& - & element_count_tensor, element_count_mesh - end interface - - interface face_count - module procedure face_count_scalar, face_count_vector, & - & face_count_tensor, face_count_mesh - end interface - - interface surface_element_count - module procedure surface_element_count_scalar, surface_element_count_vector, & - & surface_element_count_tensor, surface_element_count_mesh - end interface - - interface unique_surface_element_count - module procedure unique_surface_element_count_mesh - end interface - - interface surface_element_id - module procedure surface_element_id_scalar, surface_element_id_vector, & - surface_element_id_mesh - end interface - - interface ele_region_id - module procedure ele_region_id_mesh, ele_region_id_scalar, & + end interface ele_num_type + + interface ele_loc + module procedure ele_loc_scalar, ele_loc_vector, ele_loc_tensor,& + & ele_loc_mesh + end interface + + interface ele_vertices + module procedure ele_vertices_scalar, ele_vertices_vector, ele_vertices_tensor,& + & ele_vertices_mesh + end interface + + interface face_vertices + module procedure face_vertices_scalar, face_vertices_vector, face_vertices_tensor,& + & face_vertices_mesh, face_vertices_shape + end interface + + interface ele_ngi + module procedure ele_ngi_scalar, ele_ngi_vector, ele_ngi_tensor,& + & ele_ngi_mesh + end interface + + interface face_loc + module procedure face_loc_scalar, face_loc_vector, face_loc_tensor,& + & face_loc_mesh + end interface + + interface ele_and_faces_loc + module procedure ele_and_faces_loc_scalar, ele_and_faces_loc_vector,& + & ele_and_faces_loc_tensor, ele_and_faces_loc_mesh + end interface + + interface face_ngi + module procedure face_ngi_scalar, face_ngi_vector, face_ngi_tensor,& + & face_ngi_mesh + end interface + + interface ele_shape + module procedure ele_shape_scalar, ele_shape_vector, ele_shape_tensor,& + & ele_shape_mesh + end interface + + interface ele_n_constraints + module procedure ele_n_constraints_vector + end interface + + interface face_shape + module procedure face_shape_scalar, face_shape_vector,& + & face_shape_tensor, face_shape_mesh + end interface + + interface ele_val + module procedure ele_val_scalar, ele_val_vector, ele_val_vector_dim,& + & ele_val_tensor, ele_val_tensor_dim_dim + end interface + + interface face_val + module procedure face_val_scalar, face_val_vector, face_val_tensor,& + & face_val_vector_dim, face_val_tensor_dim_dim + end interface + + interface ele_val_at_quad + module procedure ele_val_at_quad_scalar, ele_val_at_quad_vector,& + & ele_val_at_quad_tensor, ele_val_at_shape_quad_scalar, & + & ele_val_at_shape_quad_vector, ele_val_at_shape_quad_tensor, & + & ele_val_at_quad_vector_dim, ele_val_at_quad_tensor_dim_dim + end interface + + interface face_val_at_quad + module procedure face_val_at_quad_scalar, face_val_at_quad_vector, & + & face_val_at_quad_tensor, face_val_at_quad_vector_dim,& + & face_val_at_quad_tensor_dim_dim, face_val_at_shape_quad_scalar,& + & face_val_at_shape_quad_vector, face_val_at_shape_quad_tensor + end interface + + interface ele_grad_at_quad + module procedure ele_grad_at_quad_scalar, ele_grad_at_quad_vector + end interface + + interface node_val + module procedure node_val_scalar, node_val_vector, node_val_tensor, & + & node_val_scalar_v, node_val_vector_v, node_val_vector_dim_v,& + & node_val_tensor_v, node_val_vector_dim, node_val_tensor_dim_dim, & + & node_val_tensor_dim_dim_v + end interface + + interface node_count + module procedure node_count_scalar, node_count_vector,& + & node_count_tensor, node_count_mesh + end interface + + interface node_ele + module procedure node_ele_mesh, node_ele_scalar, node_ele_vector,& + & node_ele_tensor + end interface + + interface element_count + module procedure element_count_scalar, element_count_vector,& + & element_count_tensor, element_count_mesh + end interface + + interface ele_count + module procedure element_count_scalar, element_count_vector,& + & element_count_tensor, element_count_mesh + end interface + + interface face_count + module procedure face_count_scalar, face_count_vector, & + & face_count_tensor, face_count_mesh + end interface + + interface surface_element_count + module procedure surface_element_count_scalar, surface_element_count_vector, & + & surface_element_count_tensor, surface_element_count_mesh + end interface + + interface unique_surface_element_count + module procedure unique_surface_element_count_mesh + end interface + + interface surface_element_id + module procedure surface_element_id_scalar, surface_element_id_vector, & + surface_element_id_mesh + end interface + + interface ele_region_id + module procedure ele_region_id_mesh, ele_region_id_scalar, & & ele_region_id_vector, ele_region_id_tensor - end interface + end interface - interface ele_region_ids - module procedure ele_region_ids_mesh, ele_region_ids_scalar, & + interface ele_region_ids + module procedure ele_region_ids_mesh, ele_region_ids_scalar, & & ele_region_ids_vector, ele_region_ids_tensor - end interface - - interface continuity - module procedure continuity_scalar, continuity_vector,& - & continuity_tensor, continuity_mesh - end interface - - interface element_degree - module procedure element_degree_mesh, element_degree_scalar, & - & element_degree_vector, element_degree_tensor - end interface - - interface has_faces - module procedure has_faces_mesh - end interface - - interface mesh_dim - module procedure mesh_dim_mesh, mesh_dim_scalar, mesh_dim_vector,& - & mesh_dim_tensor - end interface - - interface mesh_periodic - module procedure mesh_periodic_mesh, mesh_periodic_scalar, mesh_periodic_vector, & - & mesh_periodic_tensor - end interface - - interface has_discontinuous_internal_boundaries - module procedure mesh_has_discontinuous_internal_boundaries - end interface has_discontinuous_internal_boundaries - - interface extract_scalar_field ! extract_scalar_field is already used in State.F90 - module procedure extract_scalar_field_from_vector_field, extract_scalar_field_from_tensor_field - end interface - - interface ele_val_at_superconvergent - module procedure ele_val_at_superconvergent_scalar, ele_val_at_superconvergent_vector, ele_val_at_superconvergent_tensor - end interface - - interface field2file - module procedure field2file_scalar, field2file_vector - end interface - - interface halo_count - module procedure halo_count_mesh, halo_count_scalar, halo_count_vector, & + end interface + + interface continuity + module procedure continuity_scalar, continuity_vector,& + & continuity_tensor, continuity_mesh + end interface + + interface element_degree + module procedure element_degree_mesh, element_degree_scalar, & + & element_degree_vector, element_degree_tensor + end interface + + interface has_faces + module procedure has_faces_mesh + end interface + + interface mesh_dim + module procedure mesh_dim_mesh, mesh_dim_scalar, mesh_dim_vector,& + & mesh_dim_tensor + end interface + + interface mesh_periodic + module procedure mesh_periodic_mesh, mesh_periodic_scalar, mesh_periodic_vector, & + & mesh_periodic_tensor + end interface + + interface has_discontinuous_internal_boundaries + module procedure mesh_has_discontinuous_internal_boundaries + end interface has_discontinuous_internal_boundaries + + interface extract_scalar_field ! extract_scalar_field is already used in State.F90 + module procedure extract_scalar_field_from_vector_field, extract_scalar_field_from_tensor_field + end interface + + interface ele_val_at_superconvergent + module procedure ele_val_at_superconvergent_scalar, ele_val_at_superconvergent_vector, ele_val_at_superconvergent_tensor + end interface + + interface field2file + module procedure field2file_scalar, field2file_vector + end interface + + interface halo_count + module procedure halo_count_mesh, halo_count_scalar, halo_count_vector, & & halo_count_tensor - end interface halo_count + end interface halo_count - interface element_halo_count - module procedure element_halo_count_mesh, element_halo_count_scalar, & + interface element_halo_count + module procedure element_halo_count_mesh, element_halo_count_scalar, & & element_halo_count_vector, element_halo_count_tensor - end interface element_halo_count - - interface operator(==) - module procedure mesh_equal - end interface - - interface local_coords - module procedure local_coords_interpolation_all, local_coords_mesh, & - local_coords_scalar, local_coords_vector, local_coords_tensor - end interface - - interface field_val - module procedure field_val_scalar, field_val_vector - end interface field_val - - interface eval_field - module procedure eval_field_scalar, eval_field_vector, eval_field_tensor - end interface eval_field - - interface face_eval_field - module procedure face_eval_field_scalar, face_eval_field_vector, face_eval_field_tensor, & - face_eval_field_vector_dim, face_eval_field_tensor_dim_dim - end interface face_eval_field - - interface set_from_python_function - module procedure set_values_from_python_scalar, set_values_from_python_scalar_pos, & - set_values_from_python_vector, set_values_from_python_vector_pos, & - set_values_from_python_vector_field - end interface - - interface tetvol - module procedure tetvol_old - end interface tetvol - - interface face_opposite - module procedure face_opposite_mesh, face_opposite_scalar, face_opposite_vector, & - face_opposite_tensor - end interface - - interface mesh_compatible - module procedure mesh_compatible, mesh_positions_compatible - end interface - - interface print_mesh_incompatibility - module procedure print_mesh_incompatibility, print_mesh_positions_incompatibility - end interface - - interface write_minmax - module procedure write_minmax_scalar, write_minmax_vector, write_minmax_tensor - end interface - - private - - public :: mesh_dim, mesh_periodic, halo_count, node_val, ele_loc, & - node_count, node_ele, element_count, surface_element_count,& - unique_surface_element_count, face_count, surface_element_id,& - ele_region_id, ele_region_ids, mesh_connectivity, mesh_equal,& - mesh_compatible, print_mesh_incompatibility,& - ele_faces, ele_neigh, operator (==), local_coords, eval_field,& - face_eval_field, set_from_python_function, tetvol, face_opposite,& - write_minmax, field_val, element_halo_count, field2file,& - ele_val_at_superconvergent, extract_scalar_field,& - has_discontinuous_internal_boundaries, has_faces,& - element_degree, face_val_at_quad, ele_val_at_quad, face_val,& - ele_val, ele_n_constraints, ele_shape, face_ngi, ele_and_faces_loc,& - face_loc, ele_ngi, face_vertices, ele_vertices, ele_num_type,& - ele_numbering_family, ele_face_count, face_ele, ele_face,& - face_neigh, node_neigh, face_global_nodes, face_local_nodes,& - ele_nodes, ele_count, local_face_number, face_shape, face_n_s,& - face_dn_s, continuity, simplex_volume, ele_div_at_quad,& - extract_scalar_field_from_vector_field, triarea, ele_grad_at_quad,& - extract_scalar_field_from_tensor_field, ele_curl_at_quad,& - eval_shape, ele_jacobian_at_quad, ele_div_at_quad_tensor,& - ele_2d_curl_at_quad, getsndgln, local_coords_matrix + end interface element_halo_count + + interface operator(==) + module procedure mesh_equal + end interface + + interface local_coords + module procedure local_coords_interpolation_all, local_coords_mesh, & + local_coords_scalar, local_coords_vector, local_coords_tensor + end interface + + interface field_val + module procedure field_val_scalar, field_val_vector + end interface field_val + + interface eval_field + module procedure eval_field_scalar, eval_field_vector, eval_field_tensor + end interface eval_field + + interface face_eval_field + module procedure face_eval_field_scalar, face_eval_field_vector, face_eval_field_tensor, & + face_eval_field_vector_dim, face_eval_field_tensor_dim_dim + end interface face_eval_field + + interface set_from_python_function + module procedure set_values_from_python_scalar, set_values_from_python_scalar_pos, & + set_values_from_python_vector, set_values_from_python_vector_pos, & + set_values_from_python_vector_field + end interface + + interface tetvol + module procedure tetvol_old + end interface tetvol + + interface face_opposite + module procedure face_opposite_mesh, face_opposite_scalar, face_opposite_vector, & + face_opposite_tensor + end interface + + interface mesh_compatible + module procedure mesh_compatible, mesh_positions_compatible + end interface + + interface print_mesh_incompatibility + module procedure print_mesh_incompatibility, print_mesh_positions_incompatibility + end interface + + interface write_minmax + module procedure write_minmax_scalar, write_minmax_vector, write_minmax_tensor + end interface + + private + + public :: mesh_dim, mesh_periodic, halo_count, node_val, ele_loc, & + node_count, node_ele, element_count, surface_element_count,& + unique_surface_element_count, face_count, surface_element_id,& + ele_region_id, ele_region_ids, mesh_connectivity, mesh_equal,& + mesh_compatible, print_mesh_incompatibility,& + ele_faces, ele_neigh, operator (==), local_coords, eval_field,& + face_eval_field, set_from_python_function, tetvol, face_opposite,& + write_minmax, field_val, element_halo_count, field2file,& + ele_val_at_superconvergent, extract_scalar_field,& + has_discontinuous_internal_boundaries, has_faces,& + element_degree, face_val_at_quad, ele_val_at_quad, face_val,& + ele_val, ele_n_constraints, ele_shape, face_ngi, ele_and_faces_loc,& + face_loc, ele_ngi, face_vertices, ele_vertices, ele_num_type,& + ele_numbering_family, ele_face_count, face_ele, ele_face,& + face_neigh, node_neigh, face_global_nodes, face_local_nodes,& + ele_nodes, ele_count, local_face_number, face_shape, face_n_s,& + face_dn_s, continuity, simplex_volume, ele_div_at_quad,& + extract_scalar_field_from_vector_field, triarea, ele_grad_at_quad,& + extract_scalar_field_from_tensor_field, ele_curl_at_quad,& + eval_shape, ele_jacobian_at_quad, ele_div_at_quad_tensor,& + ele_2d_curl_at_quad, getsndgln, local_coords_matrix contains - pure function mesh_dim_mesh(mesh) result (mesh_dim) - ! Return the dimensionality of the mesh. - integer :: mesh_dim - type(mesh_type), intent(in) :: mesh + pure function mesh_dim_mesh(mesh) result (mesh_dim) + ! Return the dimensionality of the mesh. + integer :: mesh_dim + type(mesh_type), intent(in) :: mesh - mesh_dim=mesh%shape%dim + mesh_dim=mesh%shape%dim - end function mesh_dim_mesh + end function mesh_dim_mesh - pure function mesh_dim_scalar(field) result (mesh_dim) - ! Return the dimensionality of the field. - integer :: mesh_dim - type(scalar_field), intent(in) :: field + pure function mesh_dim_scalar(field) result (mesh_dim) + ! Return the dimensionality of the field. + integer :: mesh_dim + type(scalar_field), intent(in) :: field - mesh_dim=field%mesh%shape%dim + mesh_dim=field%mesh%shape%dim - end function mesh_dim_scalar + end function mesh_dim_scalar - pure function mesh_dim_vector(field) result (mesh_dim) - ! Return the dimensionality of the field. - integer :: mesh_dim - type(vector_field), intent(in) :: field + pure function mesh_dim_vector(field) result (mesh_dim) + ! Return the dimensionality of the field. + integer :: mesh_dim + type(vector_field), intent(in) :: field - mesh_dim=field%mesh%shape%dim + mesh_dim=field%mesh%shape%dim - end function mesh_dim_vector + end function mesh_dim_vector - pure function mesh_dim_tensor(field) result (mesh_dim) - ! Return the dimensionality of the field. - integer :: mesh_dim - type(tensor_field), intent(in) :: field + pure function mesh_dim_tensor(field) result (mesh_dim) + ! Return the dimensionality of the field. + integer :: mesh_dim + type(tensor_field), intent(in) :: field - mesh_dim=field%mesh%shape%dim + mesh_dim=field%mesh%shape%dim - end function mesh_dim_tensor + end function mesh_dim_tensor - pure function mesh_periodic_mesh(mesh) result (mesh_periodic) - ! Return the periodic flag of the mesh - logical :: mesh_periodic - type(mesh_type), intent(in) :: mesh + pure function mesh_periodic_mesh(mesh) result (mesh_periodic) + ! Return the periodic flag of the mesh + logical :: mesh_periodic + type(mesh_type), intent(in) :: mesh - mesh_periodic=mesh%periodic + mesh_periodic=mesh%periodic - end function mesh_periodic_mesh + end function mesh_periodic_mesh - pure function mesh_periodic_scalar(field) result (mesh_periodic) - ! Return the periodic flag of the mesh - logical :: mesh_periodic - type(scalar_field), intent(in) :: field + pure function mesh_periodic_scalar(field) result (mesh_periodic) + ! Return the periodic flag of the mesh + logical :: mesh_periodic + type(scalar_field), intent(in) :: field - mesh_periodic=field%mesh%periodic + mesh_periodic=field%mesh%periodic - end function mesh_periodic_scalar + end function mesh_periodic_scalar - pure function mesh_periodic_vector(field) result (mesh_periodic) - ! Return the periodic flag of the mesh - logical :: mesh_periodic - type(vector_field), intent(in) :: field + pure function mesh_periodic_vector(field) result (mesh_periodic) + ! Return the periodic flag of the mesh + logical :: mesh_periodic + type(vector_field), intent(in) :: field - mesh_periodic=field%mesh%periodic + mesh_periodic=field%mesh%periodic - end function mesh_periodic_vector + end function mesh_periodic_vector - pure function mesh_periodic_tensor(field) result (mesh_periodic) - ! Return the periodic flag of the mesh - logical :: mesh_periodic - type(tensor_field), intent(in) :: field + pure function mesh_periodic_tensor(field) result (mesh_periodic) + ! Return the periodic flag of the mesh + logical :: mesh_periodic + type(tensor_field), intent(in) :: field - mesh_periodic=field%mesh%periodic + mesh_periodic=field%mesh%periodic - end function mesh_periodic_tensor + end function mesh_periodic_tensor - pure function mesh_has_discontinuous_internal_boundaries(mesh) - !!< Return whether the mesh has discontinuous boundaries - !!< These are internal boundaries where the surface id are - !!< allowed to be discontinuous (the pair of adjacent - !!< internal facets can have two different ids). - logical :: mesh_has_discontinuous_internal_boundaries - type(mesh_type), intent(in) :: mesh + pure function mesh_has_discontinuous_internal_boundaries(mesh) + !!< Return whether the mesh has discontinuous boundaries + !!< These are internal boundaries where the surface id are + !!< allowed to be discontinuous (the pair of adjacent + !!< internal facets can have two different ids). + logical :: mesh_has_discontinuous_internal_boundaries + type(mesh_type), intent(in) :: mesh - if (associated(mesh%faces)) then - mesh_has_discontinuous_internal_boundaries = mesh%faces%has_discontinuous_internal_boundaries - else - mesh_has_discontinuous_internal_boundaries = .false. - end if + if (associated(mesh%faces)) then + mesh_has_discontinuous_internal_boundaries = mesh%faces%has_discontinuous_internal_boundaries + else + mesh_has_discontinuous_internal_boundaries = .false. + end if - end function mesh_has_discontinuous_internal_boundaries + end function mesh_has_discontinuous_internal_boundaries - pure function node_count_mesh(mesh) result (node_count) - ! Return the number of nodes in a mesh. - integer :: node_count - type(mesh_type), intent(in) :: mesh + pure function node_count_mesh(mesh) result (node_count) + ! Return the number of nodes in a mesh. + integer :: node_count + type(mesh_type), intent(in) :: mesh - node_count=mesh%nodes + node_count=mesh%nodes - end function node_count_mesh + end function node_count_mesh - pure function node_count_scalar(field) result (node_count) - ! Return the number of nodes in a field. - integer :: node_count - type(scalar_field),intent(in) :: field + pure function node_count_scalar(field) result (node_count) + ! Return the number of nodes in a field. + integer :: node_count + type(scalar_field),intent(in) :: field - node_count=node_count_mesh(field%mesh) + node_count=node_count_mesh(field%mesh) - end function node_count_scalar + end function node_count_scalar - pure function node_count_vector(field) result (node_count) - ! Return the number of nodes in a field. - integer :: node_count - type(vector_field),intent(in) :: field + pure function node_count_vector(field) result (node_count) + ! Return the number of nodes in a field. + integer :: node_count + type(vector_field),intent(in) :: field - node_count=node_count_mesh(field%mesh) + node_count=node_count_mesh(field%mesh) - end function node_count_vector + end function node_count_vector - pure function node_count_tensor(field) result (node_count) - ! Return the number of nodes in a field. - integer :: node_count - type(tensor_field),intent(in) :: field + pure function node_count_tensor(field) result (node_count) + ! Return the number of nodes in a field. + integer :: node_count + type(tensor_field),intent(in) :: field - node_count=node_count_mesh(field%mesh) + node_count=node_count_mesh(field%mesh) - end function node_count_tensor + end function node_count_tensor - function node_ele_mesh(mesh, node) result (node_ele) - ! Return the element to which node belongs in mesh. This is only a sane - ! thing to do for dg meshes: for cg it is undefined as nodes may belong - ! to multiple elements. - integer :: node_ele - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: node + function node_ele_mesh(mesh, node) result (node_ele) + ! Return the element to which node belongs in mesh. This is only a sane + ! thing to do for dg meshes: for cg it is undefined as nodes may belong + ! to multiple elements. + integer :: node_ele + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: node - assert(mesh%continuity<0) - assert(node>=1) - assert(node<=mesh%nodes) + assert(mesh%continuity<0) + assert(node>=1) + assert(node<=mesh%nodes) - ! Note that this will have to change for mixed element meshes. - node_ele=1+(node-1)/ele_loc(mesh,1) + ! Note that this will have to change for mixed element meshes. + node_ele=1+(node-1)/ele_loc(mesh,1) - end function node_ele_mesh + end function node_ele_mesh - function node_ele_scalar(field, node) result (node_ele) - ! Return the element to which node belongs in field. This is only a sane - ! thing to do for dg meshes: for cg it is undefined as nodes may belong - ! to multiple elements. - integer :: node_ele - type(scalar_field), intent(in) :: field - integer, intent(in) :: node + function node_ele_scalar(field, node) result (node_ele) + ! Return the element to which node belongs in field. This is only a sane + ! thing to do for dg meshes: for cg it is undefined as nodes may belong + ! to multiple elements. + integer :: node_ele + type(scalar_field), intent(in) :: field + integer, intent(in) :: node - node_ele=node_ele_mesh(field%mesh, node) + node_ele=node_ele_mesh(field%mesh, node) - end function node_ele_scalar + end function node_ele_scalar - function node_ele_vector(field, node) result (node_ele) - ! Return the element to which node belongs in field. This is only a sane - ! thing to do for dg meshes: for cg it is undefined as nodes may belong - ! to multiple elements. - integer :: node_ele - type(vector_field), intent(in) :: field - integer, intent(in) :: node + function node_ele_vector(field, node) result (node_ele) + ! Return the element to which node belongs in field. This is only a sane + ! thing to do for dg meshes: for cg it is undefined as nodes may belong + ! to multiple elements. + integer :: node_ele + type(vector_field), intent(in) :: field + integer, intent(in) :: node - node_ele=node_ele_mesh(field%mesh, node) + node_ele=node_ele_mesh(field%mesh, node) - end function node_ele_vector + end function node_ele_vector - function node_ele_tensor(field, node) result (node_ele) - ! Return the element to which node belongs in field. This is only a sane - ! thing to do for dg meshes: for cg it is undefined as nodes may belong - ! to multiple elements. - integer :: node_ele - type(tensor_field), intent(in) :: field - integer, intent(in) :: node + function node_ele_tensor(field, node) result (node_ele) + ! Return the element to which node belongs in field. This is only a sane + ! thing to do for dg meshes: for cg it is undefined as nodes may belong + ! to multiple elements. + integer :: node_ele + type(tensor_field), intent(in) :: field + integer, intent(in) :: node - node_ele=node_ele_mesh(field%mesh, node) + node_ele=node_ele_mesh(field%mesh, node) - end function node_ele_tensor + end function node_ele_tensor - pure function element_count_mesh(mesh) result (element_count) - ! Return the number of nodes in a mesh. - integer :: element_count - type(mesh_type),intent(in) :: mesh + pure function element_count_mesh(mesh) result (element_count) + ! Return the number of nodes in a mesh. + integer :: element_count + type(mesh_type),intent(in) :: mesh - element_count=mesh%elements + element_count=mesh%elements - end function element_count_mesh + end function element_count_mesh - pure function surface_element_count_scalar(field) result (element_count) - ! Return the number of surface elements in a field. - integer :: element_count - type(scalar_field),intent(in) :: field + pure function surface_element_count_scalar(field) result (element_count) + ! Return the number of surface elements in a field. + integer :: element_count + type(scalar_field),intent(in) :: field - if (associated(field%mesh%faces)) then - element_count=size(field%mesh%faces%boundary_ids) - else - element_count=0 - end if + if (associated(field%mesh%faces)) then + element_count=size(field%mesh%faces%boundary_ids) + else + element_count=0 + end if - end function surface_element_count_scalar + end function surface_element_count_scalar - pure function surface_element_count_vector(field) result (element_count) - ! Return the number of surface elements in a field. - integer :: element_count - type(vector_field),intent(in) :: field + pure function surface_element_count_vector(field) result (element_count) + ! Return the number of surface elements in a field. + integer :: element_count + type(vector_field),intent(in) :: field - if (associated(field%mesh%faces)) then - element_count=size(field%mesh%faces%boundary_ids) - else - element_count=0 - end if + if (associated(field%mesh%faces)) then + element_count=size(field%mesh%faces%boundary_ids) + else + element_count=0 + end if - end function surface_element_count_vector + end function surface_element_count_vector - pure function surface_element_count_tensor(field) result (element_count) - ! Return the number of surface elements in a field. - integer :: element_count - type(tensor_field),intent(in) :: field - - if (associated(field%mesh%faces)) then - element_count=size(field%mesh%faces%boundary_ids) - else - element_count=0 - end if + pure function surface_element_count_tensor(field) result (element_count) + ! Return the number of surface elements in a field. + integer :: element_count + type(tensor_field),intent(in) :: field - end function surface_element_count_tensor - - pure function surface_element_count_mesh(mesh) result (element_count) - ! Return the number of surface elements in a mesh. - integer :: element_count - type(mesh_type),intent(in) :: mesh + if (associated(field%mesh%faces)) then + element_count=size(field%mesh%faces%boundary_ids) + else + element_count=0 + end if - if (associated(mesh%faces)) then - element_count=size(mesh%faces%boundary_ids) - else - element_count=0 - end if + end function surface_element_count_tensor - end function surface_element_count_mesh + pure function surface_element_count_mesh(mesh) result (element_count) + ! Return the number of surface elements in a mesh. + integer :: element_count + type(mesh_type),intent(in) :: mesh - pure function unique_surface_element_count_mesh(mesh) result (element_count) - ! Return the number of unique surface elements of a mesh. For internal - ! facets that are part of the surface mesh, each pair of adjacent facets - ! is only counted once. - integer :: element_count - type(mesh_type),intent(in) :: mesh + if (associated(mesh%faces)) then + element_count=size(mesh%faces%boundary_ids) + else + element_count=0 + end if - if (associated(mesh%faces)) then - element_count=mesh%faces%unique_surface_element_count - else - element_count=0 - end if + end function surface_element_count_mesh - end function unique_surface_element_count_mesh + pure function unique_surface_element_count_mesh(mesh) result (element_count) + ! Return the number of unique surface elements of a mesh. For internal + ! facets that are part of the surface mesh, each pair of adjacent facets + ! is only counted once. + integer :: element_count + type(mesh_type),intent(in) :: mesh - pure function face_count_scalar(field) result (face_count) - ! Return the number of faces in a mesh. - integer :: face_count - type(scalar_field),intent(in) :: field + if (associated(mesh%faces)) then + element_count=mesh%faces%unique_surface_element_count + else + element_count=0 + end if - if (associated(field%mesh%faces)) then - face_count=size(field%mesh%faces%face_element_list) - else - face_count=0 - end if + end function unique_surface_element_count_mesh - end function face_count_scalar + pure function face_count_scalar(field) result (face_count) + ! Return the number of faces in a mesh. + integer :: face_count + type(scalar_field),intent(in) :: field - pure function face_count_vector(field) result (face_count) - ! Return the number of faces in a mesh. - integer :: face_count - type(vector_field),intent(in) :: field + if (associated(field%mesh%faces)) then + face_count=size(field%mesh%faces%face_element_list) + else + face_count=0 + end if - if (associated(field%mesh%faces)) then - face_count=size(field%mesh%faces%face_element_list) - else - face_count=0 - end if + end function face_count_scalar - end function face_count_vector + pure function face_count_vector(field) result (face_count) + ! Return the number of faces in a mesh. + integer :: face_count + type(vector_field),intent(in) :: field - pure function face_count_tensor(field) result (face_count) - ! Return the number of faces in a mesh. - integer :: face_count - type(tensor_field),intent(in) :: field + if (associated(field%mesh%faces)) then + face_count=size(field%mesh%faces%face_element_list) + else + face_count=0 + end if - if (associated(field%mesh%faces)) then - face_count=size(field%mesh%faces%face_element_list) - else - face_count=0 - end if + end function face_count_vector - end function face_count_tensor + pure function face_count_tensor(field) result (face_count) + ! Return the number of faces in a mesh. + integer :: face_count + type(tensor_field),intent(in) :: field - pure function face_count_mesh(mesh) result (face_count) - ! Return the number of faces in a mesh. - integer :: face_count - type(mesh_type),intent(in) :: mesh + if (associated(field%mesh%faces)) then + face_count=size(field%mesh%faces%face_element_list) + else + face_count=0 + end if - if (associated(mesh%faces)) then - face_count=size(mesh%faces%face_element_list) - else - face_count=0 - end if + end function face_count_tensor - end function face_count_mesh + pure function face_count_mesh(mesh) result (face_count) + ! Return the number of faces in a mesh. + integer :: face_count + type(mesh_type),intent(in) :: mesh - pure function element_count_scalar(field) result (element_count) - ! Return the number of elements in a field. - integer :: element_count - type(scalar_field),intent(in) :: field + if (associated(mesh%faces)) then + face_count=size(mesh%faces%face_element_list) + else + face_count=0 + end if - element_count=field%mesh%elements + end function face_count_mesh - end function element_count_scalar + pure function element_count_scalar(field) result (element_count) + ! Return the number of elements in a field. + integer :: element_count + type(scalar_field),intent(in) :: field - pure function element_count_vector(field) result (element_count) - ! Return the number of elements in a field. - integer :: element_count - type(vector_field),intent(in) :: field + element_count=field%mesh%elements - element_count=field%mesh%elements + end function element_count_scalar - end function element_count_vector + pure function element_count_vector(field) result (element_count) + ! Return the number of elements in a field. + integer :: element_count + type(vector_field),intent(in) :: field - pure function element_count_tensor(field) result (element_count) - ! Return the number of elements in a field. - integer :: element_count - type(tensor_field),intent(in) :: field + element_count=field%mesh%elements - element_count=field%mesh%elements + end function element_count_vector - end function element_count_tensor + pure function element_count_tensor(field) result (element_count) + ! Return the number of elements in a field. + integer :: element_count + type(tensor_field),intent(in) :: field - elemental function surface_element_id_mesh(mesh, ele) result (id) - !!< Return the boundary id of the given surface element - type(mesh_type), intent(in):: mesh - integer, intent(in):: ele - integer id + element_count=field%mesh%elements - ! sorry can't assert in elemental - !assert(associated(mesh%faces)) - !assert(ele>0 .and. ele0 .and. ele0 .and. ele0 .and. ele0 .and. ele0 .and. ele mesh%region_ids + type(mesh_type), target, intent(in) :: mesh - end function ele_region_ids_mesh + integer, dimension(:), pointer :: ids - function ele_region_ids_scalar(field) result(ids) - !!< Return the region ids of all elements + ids => mesh%region_ids - type(scalar_field), target, intent(in) :: field + end function ele_region_ids_mesh - integer, dimension(:), pointer :: ids + function ele_region_ids_scalar(field) result(ids) + !!< Return the region ids of all elements - ids => ele_region_ids(field%mesh) + type(scalar_field), target, intent(in) :: field - end function ele_region_ids_scalar + integer, dimension(:), pointer :: ids - function ele_region_ids_vector(field) result(ids) - !!< Return the region ids of all elements + ids => ele_region_ids(field%mesh) - type(vector_field), target, intent(in) :: field + end function ele_region_ids_scalar - integer, dimension(:), pointer :: ids + function ele_region_ids_vector(field) result(ids) + !!< Return the region ids of all elements - ids => ele_region_ids(field%mesh) + type(vector_field), target, intent(in) :: field - end function ele_region_ids_vector + integer, dimension(:), pointer :: ids - function ele_region_ids_tensor(field) result(ids) - !!< Return the region ids of all elements + ids => ele_region_ids(field%mesh) - type(tensor_field), target, intent(in) :: field + end function ele_region_ids_vector - integer, dimension(:), pointer :: ids + function ele_region_ids_tensor(field) result(ids) + !!< Return the region ids of all elements - ids => ele_region_ids(field%mesh) + type(tensor_field), target, intent(in) :: field - end function ele_region_ids_tensor + integer, dimension(:), pointer :: ids - function mesh_connectivity(mesh) result (ndglno) - !!< Assuming that the input mesh is at least C0, return the connectivity - !!< of the mesh. - type(mesh_type), intent(in) :: mesh - integer, dimension(mesh%elements*mesh%shape%numbering%vertices) ::& - & ndglno + ids => ele_region_ids(field%mesh) - integer, dimension(mesh%shape%numbering%vertices) :: vertices - integer :: i, nodes + end function ele_region_ids_tensor - integer, dimension(:), allocatable :: map - integer, dimension(:), pointer :: e_nodes + function mesh_connectivity(mesh) result (ndglno) + !!< Assuming that the input mesh is at least C0, return the connectivity + !!< of the mesh. + type(mesh_type), intent(in) :: mesh + integer, dimension(mesh%elements*mesh%shape%numbering%vertices) ::& + & ndglno - vertices=local_vertices(mesh%shape%numbering) + integer, dimension(mesh%shape%numbering%vertices) :: vertices + integer :: i, nodes - do i=1,mesh%elements - e_nodes => ele_nodes(mesh, i) - ndglno((i-1)*size(vertices)+1:i*size(vertices)) = e_nodes(vertices) - end do + integer, dimension(:), allocatable :: map + integer, dimension(:), pointer :: e_nodes - allocate(map(maxval(ndglno))) + vertices=local_vertices(mesh%shape%numbering) - map=0 - nodes=0 + do i=1,mesh%elements + e_nodes => ele_nodes(mesh, i) + ndglno((i-1)*size(vertices)+1:i*size(vertices)) = e_nodes(vertices) + end do - do i=1,size(ndglno) - if (map(ndglno(i))==0) then - nodes=nodes+1 - map(ndglno(i))=nodes - end if + allocate(map(maxval(ndglno))) - ndglno(i)=map(ndglno(i)) - end do + map=0 + nodes=0 - end function mesh_connectivity + do i=1,size(ndglno) + if (map(ndglno(i))==0) then + nodes=nodes+1 + map(ndglno(i))=nodes + end if - pure function mesh_equal(mesh1, mesh2) - !!< Test for the equality of two meshes. This is not totally safe since - !!< we do not compare all of ndglno. We assume that two meshes are equal - !!< if they have the same element, continuity, node count and element - !!< count. This should be sufficient in almost all circumstances. - logical :: mesh_equal - type(mesh_type), intent(in) :: mesh1, mesh2 + ndglno(i)=map(ndglno(i)) + end do - if (associated(mesh1%refcount) .and. associated(mesh2%refcount)) then - mesh_equal= (mesh1%refcount%id==mesh2%refcount%id) - else - mesh_equal= .false. - end if + end function mesh_connectivity - end function mesh_equal + pure function mesh_equal(mesh1, mesh2) + !!< Test for the equality of two meshes. This is not totally safe since + !!< we do not compare all of ndglno. We assume that two meshes are equal + !!< if they have the same element, continuity, node count and element + !!< count. This should be sufficient in almost all circumstances. + logical :: mesh_equal + type(mesh_type), intent(in) :: mesh1, mesh2 - function mesh_compatible(test_mesh, reference_mesh) result(pass) - !!< Tests if a field on test_mesh is suitable for initialising a field - !!< on reference_mesh. + if (associated(mesh1%refcount) .and. associated(mesh2%refcount)) then + mesh_equal= (mesh1%refcount%id==mesh2%refcount%id) + else + mesh_equal= .false. + end if - type(mesh_type), intent(in) :: test_mesh - type(mesh_type), intent(in) :: reference_mesh + end function mesh_equal - logical :: pass + function mesh_compatible(test_mesh, reference_mesh) result(pass) + !!< Tests if a field on test_mesh is suitable for initialising a field + !!< on reference_mesh. - pass = node_count(test_mesh) == node_count(reference_mesh) .and. & + type(mesh_type), intent(in) :: test_mesh + type(mesh_type), intent(in) :: reference_mesh + + logical :: pass + + pass = node_count(test_mesh) == node_count(reference_mesh) .and. & &ele_count(test_mesh) == ele_count(reference_mesh) .and. & &continuity(test_mesh) == continuity(reference_mesh) - end function mesh_compatible + end function mesh_compatible - function mesh_positions_compatible(test_positions, reference_positions) result(pass) - !!< Tests if two meshes (including its positions) are the same + function mesh_positions_compatible(test_positions, reference_positions) result(pass) + !!< Tests if two meshes (including its positions) are the same - type(vector_field), intent(in) :: test_positions, reference_positions - logical :: pass + type(vector_field), intent(in) :: test_positions, reference_positions + logical :: pass - real:: L - integer:: i - - ! first test if the topological meshes are the same - if (.not. mesh_compatible(test_positions%mesh, reference_positions%mesh)) then - pass=.false. - return - end if + real:: L + integer:: i - do i=1, reference_positions%dim - L=maxval(reference_positions%val(i,:))-minval(reference_positions%val(i,:)) - if (maxval(abs(test_positions%val(i,:)-reference_positions%val(i,:)))>1e-9*L) then - pass=.false. - return + ! first test if the topological meshes are the same + if (.not. mesh_compatible(test_positions%mesh, reference_positions%mesh)) then + pass=.false. + return end if - end do - - pass=.true. - - end function mesh_positions_compatible - - subroutine print_mesh_incompatibility(debug_level, test_mesh, reference_mesh) - !!< Tests if a field on test_mesh is suitable for initialising a field - !!< on reference_mesh, and prints a descriptive message. - integer, intent(in) :: debug_level - type(mesh_type), intent(in) :: test_mesh - type(mesh_type), intent(in) :: reference_mesh - - if(node_count(test_mesh) /= node_count(reference_mesh)) then - ewrite(debug_level, *) "Node counts do not match" - end if - if(ele_count(test_mesh) /= ele_count(reference_mesh)) then - ewrite(debug_level, *) "Element counts do not match" - end if - if(continuity(test_mesh) /= continuity(reference_mesh)) then - ewrite(debug_level, *) "Continuities do not match" - end if - - end subroutine print_mesh_incompatibility + do i=1, reference_positions%dim + L=maxval(reference_positions%val(i,:))-minval(reference_positions%val(i,:)) + if (maxval(abs(test_positions%val(i,:)-reference_positions%val(i,:)))>1e-9*L) then + pass=.false. + return + end if + end do - subroutine print_mesh_positions_incompatibility(debug_level, test_positions, reference_positions) - !!< Tests if two meshes are the same (including its positions) and prints a descriptive message. + pass=.true. - integer, intent(in) :: debug_level - type(vector_field), intent(in) :: test_positions, reference_positions + end function mesh_positions_compatible - if (.not. mesh_compatible(test_positions%mesh, reference_positions%mesh)) then - call print_mesh_incompatibility(debug_level, test_positions%mesh, reference_positions%mesh) - else if (.not. mesh_compatible(test_positions, reference_positions)) then - ewrite(debug_level, *) "Node positions do not match" - end if + subroutine print_mesh_incompatibility(debug_level, test_mesh, reference_mesh) + !!< Tests if a field on test_mesh is suitable for initialising a field + !!< on reference_mesh, and prints a descriptive message. - end subroutine print_mesh_positions_incompatibility + integer, intent(in) :: debug_level + type(mesh_type), intent(in) :: test_mesh + type(mesh_type), intent(in) :: reference_mesh - function ele_faces_mesh(mesh, ele_number) result (ele_faces) - !!< Return a pointer to a vector containing the face numbers of the - !!< faces adjacent to ele_number. - integer, dimension(:), pointer :: ele_faces - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + if(node_count(test_mesh) /= node_count(reference_mesh)) then + ewrite(debug_level, *) "Node counts do not match" + end if + if(ele_count(test_mesh) /= ele_count(reference_mesh)) then + ewrite(debug_level, *) "Element counts do not match" + end if + if(continuity(test_mesh) /= continuity(reference_mesh)) then + ewrite(debug_level, *) "Continuities do not match" + end if - ele_faces =>row_ival_ptr(mesh%faces%face_list, ele_number) + end subroutine print_mesh_incompatibility - end function ele_faces_mesh + subroutine print_mesh_positions_incompatibility(debug_level, test_positions, reference_positions) + !!< Tests if two meshes are the same (including its positions) and prints a descriptive message. - function ele_faces_scalar(field, ele_number) result (ele_faces) - !!< Return a pointer to a vector containing the face numbers of the - !!< faces adjacent to ele_number. - integer, dimension(:), pointer :: ele_faces - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + integer, intent(in) :: debug_level + type(vector_field), intent(in) :: test_positions, reference_positions - ele_faces=>ele_faces_mesh(field%mesh, ele_number) + if (.not. mesh_compatible(test_positions%mesh, reference_positions%mesh)) then + call print_mesh_incompatibility(debug_level, test_positions%mesh, reference_positions%mesh) + else if (.not. mesh_compatible(test_positions, reference_positions)) then + ewrite(debug_level, *) "Node positions do not match" + end if - end function ele_faces_scalar + end subroutine print_mesh_positions_incompatibility - function ele_faces_vector(field, ele_number) result (ele_faces) - !!< Return a pointer to a vector containing the face numbers of the - !!< faces adjacent to ele_number. - integer, dimension(:), pointer :: ele_faces - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_faces_mesh(mesh, ele_number) result (ele_faces) + !!< Return a pointer to a vector containing the face numbers of the + !!< faces adjacent to ele_number. + integer, dimension(:), pointer :: ele_faces + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - ele_faces=>ele_faces_mesh(field%mesh, ele_number) + ele_faces =>row_ival_ptr(mesh%faces%face_list, ele_number) - end function ele_faces_vector + end function ele_faces_mesh - function ele_faces_tensor(field, ele_number) result (ele_faces) - !!< Return a pointer to a vector containing the face numbers of the - !!< faces adjacent to ele_number. - integer, dimension(:), pointer :: ele_faces - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_faces_scalar(field, ele_number) result (ele_faces) + !!< Return a pointer to a vector containing the face numbers of the + !!< faces adjacent to ele_number. + integer, dimension(:), pointer :: ele_faces + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_faces=>ele_faces_mesh(field%mesh, ele_number) + ele_faces=>ele_faces_mesh(field%mesh, ele_number) - end function ele_faces_tensor + end function ele_faces_scalar - function ele_neigh_mesh(mesh, ele_number) result (ele_neigh) - !!< Return a pointer to a vector containing the element numbers of the - !!< elements adjacent to ele_number. - integer, dimension(:), pointer :: ele_neigh - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + function ele_faces_vector(field, ele_number) result (ele_faces) + !!< Return a pointer to a vector containing the face numbers of the + !!< faces adjacent to ele_number. + integer, dimension(:), pointer :: ele_faces + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_neigh=>row_m_ptr(mesh%faces%face_list, ele_number) + ele_faces=>ele_faces_mesh(field%mesh, ele_number) - end function ele_neigh_mesh + end function ele_faces_vector - function ele_neigh_scalar(field, ele_number) result (ele_neigh) - !!< Return a pointer to a vector containing the element numbers of the - !!< elements adjacent to ele_number. - integer, dimension(:), pointer :: ele_neigh - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_faces_tensor(field, ele_number) result (ele_faces) + !!< Return a pointer to a vector containing the face numbers of the + !!< faces adjacent to ele_number. + integer, dimension(:), pointer :: ele_faces + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_neigh=>ele_neigh_mesh(field%mesh, ele_number) + ele_faces=>ele_faces_mesh(field%mesh, ele_number) - end function ele_neigh_scalar + end function ele_faces_tensor - function ele_neigh_vector(field, ele_number) result (ele_neigh) - !!< Return a pointer to a vector containing the element numbers of the - !!< elements adjacent to ele_number. - integer, dimension(:), pointer :: ele_neigh - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_neigh_mesh(mesh, ele_number) result (ele_neigh) + !!< Return a pointer to a vector containing the element numbers of the + !!< elements adjacent to ele_number. + integer, dimension(:), pointer :: ele_neigh + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - ele_neigh=>ele_neigh_mesh(field%mesh, ele_number) + ele_neigh=>row_m_ptr(mesh%faces%face_list, ele_number) - end function ele_neigh_vector + end function ele_neigh_mesh - function ele_neigh_tensor(field, ele_number) result (ele_neigh) - !!< Return a pointer to a vector containing the element numbers of the - !!< elements adjacent to ele_number. - integer, dimension(:), pointer :: ele_neigh - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_neigh_scalar(field, ele_number) result (ele_neigh) + !!< Return a pointer to a vector containing the element numbers of the + !!< elements adjacent to ele_number. + integer, dimension(:), pointer :: ele_neigh + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_neigh=>ele_neigh_mesh(field%mesh, ele_number) + ele_neigh=>ele_neigh_mesh(field%mesh, ele_number) - end function ele_neigh_tensor + end function ele_neigh_scalar - function ele_neigh_i_mesh(mesh, ele_number, neigh_number) result& - & (ele_neigh) - !!< Return the neigh_numberth neighbour of ele_number. - integer :: ele_neigh - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele_number, neigh_number + function ele_neigh_vector(field, ele_number) result (ele_neigh) + !!< Return a pointer to a vector containing the element numbers of the + !!< elements adjacent to ele_number. + integer, dimension(:), pointer :: ele_neigh + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - integer, dimension(:), pointer :: neighlist + ele_neigh=>ele_neigh_mesh(field%mesh, ele_number) - neighlist=>ele_neigh_mesh(mesh, ele_number) + end function ele_neigh_vector - ele_neigh=neighlist(neigh_number) + function ele_neigh_tensor(field, ele_number) result (ele_neigh) + !!< Return a pointer to a vector containing the element numbers of the + !!< elements adjacent to ele_number. + integer, dimension(:), pointer :: ele_neigh + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - end function ele_neigh_i_mesh + ele_neigh=>ele_neigh_mesh(field%mesh, ele_number) - function ele_neigh_i_scalar(field, ele_number, neigh_number) result& - & (ele_neigh) - !!< Return the neigh_numberth neighbour of ele_number. - integer :: ele_neigh - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele_number, neigh_number + end function ele_neigh_tensor - ele_neigh=ele_neigh_i_mesh(field%mesh, ele_number, neigh_number) + function ele_neigh_i_mesh(mesh, ele_number, neigh_number) result& + & (ele_neigh) + !!< Return the neigh_numberth neighbour of ele_number. + integer :: ele_neigh + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele_number, neigh_number - end function ele_neigh_i_scalar + integer, dimension(:), pointer :: neighlist - function ele_neigh_i_vector(field, ele_number, neigh_number) result& - & (ele_neigh) - !!< Return the neigh_numberth neighbour of ele_number. - integer :: ele_neigh - type(vector_field), intent(in) :: field - integer, intent(in) :: ele_number, neigh_number + neighlist=>ele_neigh_mesh(mesh, ele_number) - ele_neigh=ele_neigh_i_mesh(field%mesh, ele_number, neigh_number) + ele_neigh=neighlist(neigh_number) - end function ele_neigh_i_vector + end function ele_neigh_i_mesh - function ele_neigh_i_tensor(field, ele_number, neigh_number) result& - & (ele_neigh) - !!< Return the neigh_numberth neighbour of ele_number. - integer :: ele_neigh - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele_number, neigh_number + function ele_neigh_i_scalar(field, ele_number, neigh_number) result& + & (ele_neigh) + !!< Return the neigh_numberth neighbour of ele_number. + integer :: ele_neigh + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele_number, neigh_number - ele_neigh=ele_neigh_i_mesh(field%mesh, ele_number, neigh_number) + ele_neigh=ele_neigh_i_mesh(field%mesh, ele_number, neigh_number) - end function ele_neigh_i_tensor + end function ele_neigh_i_scalar - function node_neigh_mesh(mesh, node_number) result (node_neigh) - !!< Return a pointer to a vector containing the element numbers of the - !!< elements containing node_number. - integer, dimension(:), pointer :: node_neigh - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: node_number + function ele_neigh_i_vector(field, ele_number, neigh_number) result& + & (ele_neigh) + !!< Return the neigh_numberth neighbour of ele_number. + integer :: ele_neigh + type(vector_field), intent(in) :: field + integer, intent(in) :: ele_number, neigh_number - assert(associated(mesh%adj_lists)) - if (.not. associated(mesh%adj_lists%nelist)) then - ewrite(-1,*) "nelist not initialised. I could allocate it myself," - ewrite(-1,*) "but you're probably calling this a lot." - ewrite(-1,*) " call add_nelist(mesh) first" - FLAbort("Call add_nelist(mesh) before calling node_neigh.") - end if + ele_neigh=ele_neigh_i_mesh(field%mesh, ele_number, neigh_number) - node_neigh => row_m_ptr(mesh%adj_lists%nelist, node_number) - end function node_neigh_mesh + end function ele_neigh_i_vector - function node_neigh_scalar(field, node_number) result (node_neigh) - integer, dimension(:), pointer :: node_neigh - type(scalar_field),intent(in) :: field - integer, intent(in) :: node_number + function ele_neigh_i_tensor(field, ele_number, neigh_number) result& + & (ele_neigh) + !!< Return the neigh_numberth neighbour of ele_number. + integer :: ele_neigh + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele_number, neigh_number - node_neigh => node_neigh_mesh(field%mesh, node_number) - end function node_neigh_scalar + ele_neigh=ele_neigh_i_mesh(field%mesh, ele_number, neigh_number) - function node_neigh_vector(field, node_number) result (node_neigh) - integer, dimension(:), pointer :: node_neigh - type(vector_field),intent(in) :: field - integer, intent(in) :: node_number - - node_neigh => node_neigh_mesh(field%mesh, node_number) - end function node_neigh_vector + end function ele_neigh_i_tensor - function node_neigh_tensor(field, node_number) result (node_neigh) - integer, dimension(:), pointer :: node_neigh - type(tensor_field),intent(in) :: field - integer, intent(in) :: node_number + function node_neigh_mesh(mesh, node_number) result (node_neigh) + !!< Return a pointer to a vector containing the element numbers of the + !!< elements containing node_number. + integer, dimension(:), pointer :: node_neigh + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: node_number - node_neigh => node_neigh_mesh(field%mesh, node_number) - end function node_neigh_tensor - - ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. - function face_neigh_mesh(mesh, face) result(face_neigh) - integer, intent(in) :: face - type(mesh_type), intent(in) :: mesh - integer :: face_neigh - integer :: ele, ele2, i - integer, dimension(:), pointer :: ele_neighs + assert(associated(mesh%adj_lists)) + if (.not. associated(mesh%adj_lists%nelist)) then + ewrite(-1,*) "nelist not initialised. I could allocate it myself," + ewrite(-1,*) "but you're probably calling this a lot." + ewrite(-1,*) " call add_nelist(mesh) first" + FLAbort("Call add_nelist(mesh) before calling node_neigh.") + end if - ele=face_ele(mesh, face) - ele_neighs=>ele_neigh(mesh, ele) - - face_neigh=face - ! Search for a neighbour which shares the same face - do i=1, size(ele_neighs) - ele2=ele_neighs(i) - if (ele2.le.0) then - continue - elseif (ele_face(mesh, ele, ele2)==face) then + node_neigh => row_m_ptr(mesh%adj_lists%nelist, node_number) + end function node_neigh_mesh + + function node_neigh_scalar(field, node_number) result (node_neigh) + integer, dimension(:), pointer :: node_neigh + type(scalar_field),intent(in) :: field + integer, intent(in) :: node_number + + node_neigh => node_neigh_mesh(field%mesh, node_number) + end function node_neigh_scalar + + function node_neigh_vector(field, node_number) result (node_neigh) + integer, dimension(:), pointer :: node_neigh + type(vector_field),intent(in) :: field + integer, intent(in) :: node_number + + node_neigh => node_neigh_mesh(field%mesh, node_number) + end function node_neigh_vector + + function node_neigh_tensor(field, node_number) result (node_neigh) + integer, dimension(:), pointer :: node_neigh + type(tensor_field),intent(in) :: field + integer, intent(in) :: node_number + + node_neigh => node_neigh_mesh(field%mesh, node_number) + end function node_neigh_tensor + + ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. + function face_neigh_mesh(mesh, face) result(face_neigh) + integer, intent(in) :: face + type(mesh_type), intent(in) :: mesh + integer :: face_neigh + integer :: ele, ele2, i + integer, dimension(:), pointer :: ele_neighs + + ele=face_ele(mesh, face) + ele_neighs=>ele_neigh(mesh, ele) + + face_neigh=face + ! Search for a neighbour which shares the same face + do i=1, size(ele_neighs) + ele2=ele_neighs(i) + if (ele2.le.0) then + continue + elseif (ele_face(mesh, ele, ele2)==face) then face_neigh=ele_face(mesh, ele2, ele) exit - end if - end do - end function face_neigh_mesh - - ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. - function face_neigh_scalar(field, face) result(face_neigh) - integer, intent(in) :: face - type(scalar_field), intent(in) :: field - integer :: face_neigh - integer :: ele, ele2, i - integer, dimension(:), pointer :: ele_neighs - - ele=face_ele(field%mesh, face) - ele_neighs=>ele_neigh(field%mesh, ele) - - face_neigh=face - ! Search for a neighbour which shares the same face - do i=1, size(ele_neighs) - ele2=ele_neighs(i) - if (ele2.le.0) then - continue - elseif (ele_face(field%mesh, ele, ele2)==face) then + end if + end do + end function face_neigh_mesh + + ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. + function face_neigh_scalar(field, face) result(face_neigh) + integer, intent(in) :: face + type(scalar_field), intent(in) :: field + integer :: face_neigh + integer :: ele, ele2, i + integer, dimension(:), pointer :: ele_neighs + + ele=face_ele(field%mesh, face) + ele_neighs=>ele_neigh(field%mesh, ele) + + face_neigh=face + ! Search for a neighbour which shares the same face + do i=1, size(ele_neighs) + ele2=ele_neighs(i) + if (ele2.le.0) then + continue + elseif (ele_face(field%mesh, ele, ele2)==face) then face_neigh=ele_face(field%mesh, ele2, ele) exit - end if - end do - end function face_neigh_scalar - - ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. - function face_neigh_vector(field, face) result(face_neigh) - integer, intent(in) :: face - type(vector_field), intent(in) :: field - integer :: face_neigh - integer :: ele, ele2, i - integer, dimension(:), pointer :: ele_neighs - - ele=face_ele(field%mesh, face) - ele_neighs=>ele_neigh(field%mesh, ele) - - face_neigh=face - ! Search for a neighbour which shares the same face - do i=1, size(ele_neighs) - ele2=ele_neighs(i) - if (ele2.le.0) then - continue - elseif (ele_face(field%mesh, ele, ele2)==face) then + end if + end do + end function face_neigh_scalar + + ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. + function face_neigh_vector(field, face) result(face_neigh) + integer, intent(in) :: face + type(vector_field), intent(in) :: field + integer :: face_neigh + integer :: ele, ele2, i + integer, dimension(:), pointer :: ele_neighs + + ele=face_ele(field%mesh, face) + ele_neighs=>ele_neigh(field%mesh, ele) + + face_neigh=face + ! Search for a neighbour which shares the same face + do i=1, size(ele_neighs) + ele2=ele_neighs(i) + if (ele2.le.0) then + continue + elseif (ele_face(field%mesh, ele, ele2)==face) then face_neigh=ele_face(field%mesh, ele2, ele) exit - end if - end do - end function face_neigh_vector - - ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. - function face_neigh_tensor(field, face) result(face_neigh) - integer, intent(in) :: face - type(tensor_field), intent(in) :: field - integer :: face_neigh - integer :: ele, ele2, i - integer, dimension(:), pointer :: ele_neighs - - ele=face_ele(field%mesh, face) - ele_neighs=>ele_neigh(field%mesh, ele) - - face_neigh=face - ! Search for a neighbour which shares the same face - do i=1, size(ele_neighs) - ele2=ele_neighs(i) - if (ele2.le.0) then - continue - elseif (ele_face(field%mesh, ele, ele2)==face) then + end if + end do + end function face_neigh_vector + + ! Returns the neighbouring face of a given face. The incoming face number is returned if no neighbour face exists. + function face_neigh_tensor(field, face) result(face_neigh) + integer, intent(in) :: face + type(tensor_field), intent(in) :: field + integer :: face_neigh + integer :: ele, ele2, i + integer, dimension(:), pointer :: ele_neighs + + ele=face_ele(field%mesh, face) + ele_neighs=>ele_neigh(field%mesh, ele) + + face_neigh=face + ! Search for a neighbour which shares the same face + do i=1, size(ele_neighs) + ele2=ele_neighs(i) + if (ele2.le.0) then + continue + elseif (ele_face(field%mesh, ele, ele2)==face) then face_neigh=ele_face(field%mesh, ele2, ele) exit - end if - end do - end function face_neigh_tensor + end if + end do + end function face_neigh_tensor - pure function ele_face_count_mesh(mesh, ele_number) result (face_count) - !!< Return the number of faces associated with ele_number. - integer :: face_count - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele_number + pure function ele_face_count_mesh(mesh, ele_number) result (face_count) + !!< Return the number of faces associated with ele_number. + integer :: face_count + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele_number - face_count=mesh%shape%numbering%boundaries + face_count=mesh%shape%numbering%boundaries - end function ele_face_count_mesh + end function ele_face_count_mesh - pure function ele_face_count_scalar(field, ele_number) result (face_count) - integer :: face_count - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_face_count_scalar(field, ele_number) result (face_count) + integer :: face_count + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele_number - face_count=ele_face_count_mesh(field%mesh, ele_number) + face_count=ele_face_count_mesh(field%mesh, ele_number) - end function ele_face_count_scalar + end function ele_face_count_scalar - pure function ele_face_count_vector(field, ele_number) result (face_count) - integer :: face_count - type(vector_field), intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_face_count_vector(field, ele_number) result (face_count) + integer :: face_count + type(vector_field), intent(in) :: field + integer, intent(in) :: ele_number - face_count=ele_face_count_mesh(field%mesh, ele_number) + face_count=ele_face_count_mesh(field%mesh, ele_number) - end function ele_face_count_vector + end function ele_face_count_vector - pure function ele_face_count_tensor(field, ele_number) result (face_count) - integer :: face_count - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_face_count_tensor(field, ele_number) result (face_count) + integer :: face_count + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele_number - face_count=ele_face_count_mesh(field%mesh, ele_number) + face_count=ele_face_count_mesh(field%mesh, ele_number) - end function ele_face_count_tensor + end function ele_face_count_tensor - function ele_face_mesh(mesh, ele_number1, ele_number2) result (ele_face) - ! Return the face in ele1 adjacent to ele2. - integer ele_face - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele_number1, ele_number2 + function ele_face_mesh(mesh, ele_number1, ele_number2) result (ele_face) + ! Return the face in ele1 adjacent to ele2. + integer ele_face + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele_number1, ele_number2 - ele_face=ival(mesh%faces%face_list, ele_number1, ele_number2) + ele_face=ival(mesh%faces%face_list, ele_number1, ele_number2) - end function ele_face_mesh + end function ele_face_mesh - function ele_face_scalar(field, ele_number1, ele_number2) result (ele_face) - ! Return the face in ele1 adjacent to ele2. - integer ele_face - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele_number1, ele_number2 + function ele_face_scalar(field, ele_number1, ele_number2) result (ele_face) + ! Return the face in ele1 adjacent to ele2. + integer ele_face + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele_number1, ele_number2 - ele_face=ele_face_mesh(field%mesh, ele_number1, ele_number2) + ele_face=ele_face_mesh(field%mesh, ele_number1, ele_number2) - end function ele_face_scalar + end function ele_face_scalar - function ele_face_vector(field, ele_number1, ele_number2) result (ele_face) - ! Return the face in ele1 adjacent to ele2. - integer ele_face - type(vector_field), intent(in) :: field - integer, intent(in) :: ele_number1, ele_number2 + function ele_face_vector(field, ele_number1, ele_number2) result (ele_face) + ! Return the face in ele1 adjacent to ele2. + integer ele_face + type(vector_field), intent(in) :: field + integer, intent(in) :: ele_number1, ele_number2 - ele_face=ele_face_mesh(field%mesh, ele_number1, ele_number2) + ele_face=ele_face_mesh(field%mesh, ele_number1, ele_number2) - end function ele_face_vector + end function ele_face_vector - function ele_face_tensor(field, ele_number1, ele_number2) result (ele_face) - ! Return the face in ele1 adjacent to ele2. - integer ele_face - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele_number1, ele_number2 + function ele_face_tensor(field, ele_number1, ele_number2) result (ele_face) + ! Return the face in ele1 adjacent to ele2. + integer ele_face + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele_number1, ele_number2 - ele_face=ele_face_mesh(field%mesh, ele_number1, ele_number2) + ele_face=ele_face_mesh(field%mesh, ele_number1, ele_number2) - end function ele_face_tensor + end function ele_face_tensor - elemental function face_ele_mesh(mesh, face_number) result (face_ele) - ! Return the index of the element of which face is a part. - integer :: face_ele - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face_number + elemental function face_ele_mesh(mesh, face_number) result (face_ele) + ! Return the index of the element of which face is a part. + integer :: face_ele + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face_number - face_ele=mesh%faces%face_element_list(face_number) + face_ele=mesh%faces%face_element_list(face_number) - end function face_ele_mesh + end function face_ele_mesh - pure function ele_numbering_family_shape(shape) result(family) - type(element_type), intent(in) :: shape + pure function ele_numbering_family_shape(shape) result(family) + type(element_type), intent(in) :: shape - integer :: family + integer :: family - family = shape%numbering%family + family = shape%numbering%family - end function ele_numbering_family_shape + end function ele_numbering_family_shape - pure function ele_numbering_family_mesh(mesh, ele) result(family) - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele + pure function ele_numbering_family_mesh(mesh, ele) result(family) + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele - integer :: family + integer :: family - family = mesh%shape%numbering%family + family = mesh%shape%numbering%family - end function ele_numbering_family_mesh + end function ele_numbering_family_mesh - pure function ele_numbering_family_scalar(field, ele) result(family) - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele + pure function ele_numbering_family_scalar(field, ele) result(family) + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele - integer :: family + integer :: family - family = field%mesh%shape%numbering%family + family = field%mesh%shape%numbering%family - end function ele_numbering_family_scalar + end function ele_numbering_family_scalar - pure function ele_numbering_family_vector(field, ele) result(family) - type(vector_field), intent(in) :: field - integer, intent(in) :: ele + pure function ele_numbering_family_vector(field, ele) result(family) + type(vector_field), intent(in) :: field + integer, intent(in) :: ele - integer :: family + integer :: family - family = field%mesh%shape%numbering%family + family = field%mesh%shape%numbering%family - end function ele_numbering_family_vector + end function ele_numbering_family_vector - pure function ele_numbering_family_tensor(field, ele) result(family) - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele + pure function ele_numbering_family_tensor(field, ele) result(family) + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele - integer :: family + integer :: family - family = field%mesh%shape%numbering%family + family = field%mesh%shape%numbering%family - end function ele_numbering_family_tensor + end function ele_numbering_family_tensor - pure function ele_num_type_shape(shape) result(family) - type(element_type), intent(in) :: shape + pure function ele_num_type_shape(shape) result(family) + type(element_type), intent(in) :: shape - integer :: family + integer :: family - family = shape%numbering%type + family = shape%numbering%type - end function ele_num_type_shape + end function ele_num_type_shape - pure function ele_num_type_mesh(mesh, ele) result(family) - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele + pure function ele_num_type_mesh(mesh, ele) result(family) + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele - integer :: family + integer :: family - family = mesh%shape%numbering%type + family = mesh%shape%numbering%type - end function ele_num_type_mesh + end function ele_num_type_mesh - pure function ele_num_type_scalar(field, ele) result(family) - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele + pure function ele_num_type_scalar(field, ele) result(family) + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele - integer :: family + integer :: family - family = field%mesh%shape%numbering%type + family = field%mesh%shape%numbering%type - end function ele_num_type_scalar + end function ele_num_type_scalar - pure function ele_num_type_vector(field, ele) result(family) - type(vector_field), intent(in) :: field - integer, intent(in) :: ele + pure function ele_num_type_vector(field, ele) result(family) + type(vector_field), intent(in) :: field + integer, intent(in) :: ele - integer :: family + integer :: family - family = field%mesh%shape%numbering%type + family = field%mesh%shape%numbering%type - end function ele_num_type_vector + end function ele_num_type_vector - pure function ele_num_type_tensor(field, ele) result(family) - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele + pure function ele_num_type_tensor(field, ele) result(family) + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele - integer :: family + integer :: family - family = field%mesh%shape%numbering%type + family = field%mesh%shape%numbering%type - end function ele_num_type_tensor + end function ele_num_type_tensor - pure function ele_n_constraints_vector(vfield, ele_number) result& - & (ele_n_constraints) - integer :: ele_n_constraints - type(vector_field), intent(in) :: vfield - integer, intent(in) :: ele_number + pure function ele_n_constraints_vector(vfield, ele_number) result& + & (ele_n_constraints) + integer :: ele_n_constraints + type(vector_field), intent(in) :: vfield + integer, intent(in) :: ele_number - ele_n_constraints = vfield%mesh%shape%constraints%n_constraints + ele_n_constraints = vfield%mesh%shape%constraints%n_constraints - end function ele_n_constraints_vector + end function ele_n_constraints_vector - pure function ele_loc_mesh(mesh, ele_number) result (ele_loc) - ! Return the number of nodes of element ele_number. - integer :: ele_loc - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + pure function ele_loc_mesh(mesh, ele_number) result (ele_loc) + ! Return the number of nodes of element ele_number. + integer :: ele_loc + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - ele_loc=mesh%shape%loc + ele_loc=mesh%shape%loc - end function ele_loc_mesh + end function ele_loc_mesh - pure function ele_loc_scalar(field, ele_number) result (ele_loc) - ! Return the number of nodes of element ele_number. - integer :: ele_loc - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_loc_scalar(field, ele_number) result (ele_loc) + ! Return the number of nodes of element ele_number. + integer :: ele_loc + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_loc=field%mesh%shape%loc + ele_loc=field%mesh%shape%loc - end function ele_loc_scalar + end function ele_loc_scalar - pure function ele_loc_vector(field, ele_number) result (ele_loc) - ! Return the number of nodes of element ele_number. - integer :: ele_loc - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_loc_vector(field, ele_number) result (ele_loc) + ! Return the number of nodes of element ele_number. + integer :: ele_loc + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_loc=field%mesh%shape%loc + ele_loc=field%mesh%shape%loc - end function ele_loc_vector + end function ele_loc_vector - pure function ele_loc_tensor(field, ele_number) result (ele_loc) - ! Return the number of nodes of element ele_number. - integer :: ele_loc - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_loc_tensor(field, ele_number) result (ele_loc) + ! Return the number of nodes of element ele_number. + integer :: ele_loc + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_loc=field%mesh%shape%loc + ele_loc=field%mesh%shape%loc - end function ele_loc_tensor + end function ele_loc_tensor - pure function ele_vertices_mesh(mesh, ele_number) result (ele_vertices) - ! Return the number of vertices of element ele_number. - integer :: ele_vertices - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + pure function ele_vertices_mesh(mesh, ele_number) result (ele_vertices) + ! Return the number of vertices of element ele_number. + integer :: ele_vertices + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - ele_vertices=mesh%shape%quadrature%vertices + ele_vertices=mesh%shape%quadrature%vertices - end function ele_vertices_mesh + end function ele_vertices_mesh - pure function ele_vertices_scalar(field, ele_number) result (ele_vertices) - ! Return the number of vertices of element ele_number. - integer :: ele_vertices - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_vertices_scalar(field, ele_number) result (ele_vertices) + ! Return the number of vertices of element ele_number. + integer :: ele_vertices + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_vertices=field%mesh%shape%quadrature%vertices + ele_vertices=field%mesh%shape%quadrature%vertices - end function ele_vertices_scalar + end function ele_vertices_scalar - pure function ele_vertices_vector(field, ele_number) result (ele_vertices) - ! Return the number of vertices of element ele_number. - integer :: ele_vertices - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_vertices_vector(field, ele_number) result (ele_vertices) + ! Return the number of vertices of element ele_number. + integer :: ele_vertices + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_vertices=field%mesh%shape%quadrature%vertices + ele_vertices=field%mesh%shape%quadrature%vertices - end function ele_vertices_vector + end function ele_vertices_vector - pure function ele_vertices_tensor(field, ele_number) result (ele_vertices) - ! Return the number of vertices of element ele_number. - integer :: ele_vertices - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_vertices_tensor(field, ele_number) result (ele_vertices) + ! Return the number of vertices of element ele_number. + integer :: ele_vertices + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_vertices=field%mesh%shape%quadrature%vertices + ele_vertices=field%mesh%shape%quadrature%vertices - end function ele_vertices_tensor + end function ele_vertices_tensor - pure function face_vertices_mesh(mesh, face_number) result (face_vertices) - ! Return the number of vertices of face face_number. - integer :: face_vertices - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: face_number + pure function face_vertices_mesh(mesh, face_number) result (face_vertices) + ! Return the number of vertices of face face_number. + integer :: face_vertices + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: face_number - face_vertices=mesh%faces%shape%quadrature%vertices + face_vertices=mesh%faces%shape%quadrature%vertices - end function face_vertices_mesh + end function face_vertices_mesh - pure function face_vertices_scalar(field, face_number) result (face_vertices) - ! Return the number of vertices of face face_number. - integer :: face_vertices - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_vertices_scalar(field, face_number) result (face_vertices) + ! Return the number of vertices of face face_number. + integer :: face_vertices + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number - face_vertices=field%mesh%faces%shape%quadrature%vertices + face_vertices=field%mesh%faces%shape%quadrature%vertices - end function face_vertices_scalar + end function face_vertices_scalar - pure function face_vertices_vector(field, face_number) result (face_vertices) - ! Return the number of vertices of face face_number. - integer :: face_vertices - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_vertices_vector(field, face_number) result (face_vertices) + ! Return the number of vertices of face face_number. + integer :: face_vertices + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number - face_vertices=field%mesh%faces%shape%quadrature%vertices + face_vertices=field%mesh%faces%shape%quadrature%vertices - end function face_vertices_vector + end function face_vertices_vector - pure function face_vertices_tensor(field, face_number) result (face_vertices) - ! Return the number of vertices of face face_number. - integer :: face_vertices - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_vertices_tensor(field, face_number) result (face_vertices) + ! Return the number of vertices of face face_number. + integer :: face_vertices + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number - face_vertices=field%mesh%faces%shape%quadrature%vertices + face_vertices=field%mesh%faces%shape%quadrature%vertices - end function face_vertices_tensor + end function face_vertices_tensor - pure function face_loc_mesh(mesh, face_number) result (face_loc) - ! Return the number of nodes of face face_number. - integer :: face_loc - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: face_number + pure function face_loc_mesh(mesh, face_number) result (face_loc) + ! Return the number of nodes of face face_number. + integer :: face_loc + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: face_number - face_loc=mesh%faces%shape%loc + face_loc=mesh%faces%shape%loc - end function face_loc_mesh + end function face_loc_mesh - pure function face_loc_scalar(field, face_number) result (face_loc) - ! Return the number of nodes of face face_number. - integer :: face_loc - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_loc_scalar(field, face_number) result (face_loc) + ! Return the number of nodes of face face_number. + integer :: face_loc + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number - face_loc=field%mesh%faces%shape%loc + face_loc=field%mesh%faces%shape%loc - end function face_loc_scalar + end function face_loc_scalar - pure function face_loc_vector(field, face_number) result (face_loc) - ! Return the number of nodes of face face_number. - integer :: face_loc - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_loc_vector(field, face_number) result (face_loc) + ! Return the number of nodes of face face_number. + integer :: face_loc + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number - face_loc=field%mesh%faces%shape%loc + face_loc=field%mesh%faces%shape%loc - end function face_loc_vector + end function face_loc_vector - pure function face_loc_tensor(field, face_number) result (face_loc) - ! Return the number of nodes of face face_number. - integer :: face_loc - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_loc_tensor(field, face_number) result (face_loc) + ! Return the number of nodes of face face_number. + integer :: face_loc + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number - face_loc=field%mesh%faces%shape%loc + face_loc=field%mesh%faces%shape%loc - end function face_loc_tensor + end function face_loc_tensor - pure function ele_and_faces_loc_mesh(mesh, ele_number) result& - & (loc) - ! Return the number of nodes of facement ele_number. - integer :: loc - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + pure function ele_and_faces_loc_mesh(mesh, ele_number) result& + & (loc) + ! Return the number of nodes of facement ele_number. + integer :: loc + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - if (mesh%continuity<0) then - loc=mesh%shape%loc + mesh%shape%numbering%boundaries & + if (mesh%continuity<0) then + loc=mesh%shape%loc + mesh%shape%numbering%boundaries & * mesh%faces%shape%loc - else - ! For a continuous mesh the face nodes are among the element nodes. - loc=mesh%shape%loc - end if + else + ! For a continuous mesh the face nodes are among the element nodes. + loc=mesh%shape%loc + end if - end function ele_and_faces_loc_mesh + end function ele_and_faces_loc_mesh - pure function ele_and_faces_loc_scalar(field, ele_number) result& - & (loc) - ! Return the number of nodes of facement ele_number. - integer :: loc - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_and_faces_loc_scalar(field, ele_number) result& + & (loc) + ! Return the number of nodes of facement ele_number. + integer :: loc + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - loc=ele_and_faces_loc_mesh(field%mesh, ele_number) + loc=ele_and_faces_loc_mesh(field%mesh, ele_number) - end function ele_and_faces_loc_scalar + end function ele_and_faces_loc_scalar - pure function ele_and_faces_loc_vector(field, ele_number) result& - & (loc) - ! Return the number of nodes of facement ele_number. - integer :: loc - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_and_faces_loc_vector(field, ele_number) result& + & (loc) + ! Return the number of nodes of facement ele_number. + integer :: loc + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - loc=ele_and_faces_loc_mesh(field%mesh, ele_number) + loc=ele_and_faces_loc_mesh(field%mesh, ele_number) - end function ele_and_faces_loc_vector + end function ele_and_faces_loc_vector - pure function ele_and_faces_loc_tensor(field, ele_number) result& - & (loc) - ! Return the number of nodes of facement ele_number. - integer :: loc - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_and_faces_loc_tensor(field, ele_number) result& + & (loc) + ! Return the number of nodes of facement ele_number. + integer :: loc + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - loc=ele_and_faces_loc_mesh(field%mesh, ele_number) + loc=ele_and_faces_loc_mesh(field%mesh, ele_number) - end function ele_and_faces_loc_tensor + end function ele_and_faces_loc_tensor - pure function ele_ngi_mesh(mesh, ele_number) result (ele_ngi) - ! Return the number of nodes of element ele_number. - integer :: ele_ngi - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + pure function ele_ngi_mesh(mesh, ele_number) result (ele_ngi) + ! Return the number of nodes of element ele_number. + integer :: ele_ngi + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - ele_ngi=mesh%shape%ngi + ele_ngi=mesh%shape%ngi - end function ele_ngi_mesh + end function ele_ngi_mesh - pure function ele_ngi_scalar(field, ele_number) result (ele_ngi) - ! Return the number of nodes of element ele_number. - integer :: ele_ngi - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_ngi_scalar(field, ele_number) result (ele_ngi) + ! Return the number of nodes of element ele_number. + integer :: ele_ngi + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_ngi=field%mesh%shape%ngi + ele_ngi=field%mesh%shape%ngi - end function ele_ngi_scalar + end function ele_ngi_scalar - pure function ele_ngi_vector(field, ele_number) result (ele_ngi) - ! Return the number of nodes of element ele_number. - integer :: ele_ngi - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_ngi_vector(field, ele_number) result (ele_ngi) + ! Return the number of nodes of element ele_number. + integer :: ele_ngi + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_ngi=field%mesh%shape%ngi + ele_ngi=field%mesh%shape%ngi - end function ele_ngi_vector + end function ele_ngi_vector - pure function ele_ngi_tensor(field, ele_number) result (ele_ngi) - ! Return the number of nodes of element ele_number. - integer :: ele_ngi - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + pure function ele_ngi_tensor(field, ele_number) result (ele_ngi) + ! Return the number of nodes of element ele_number. + integer :: ele_ngi + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_ngi=field%mesh%shape%ngi + ele_ngi=field%mesh%shape%ngi - end function ele_ngi_tensor + end function ele_ngi_tensor - pure function face_ngi_mesh(mesh, face_number) result (face_ngi) - ! Return the number of nodes of element face_number. - integer :: face_ngi - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: face_number + pure function face_ngi_mesh(mesh, face_number) result (face_ngi) + ! Return the number of nodes of element face_number. + integer :: face_ngi + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: face_number - face_ngi=mesh%faces%shape%ngi + face_ngi=mesh%faces%shape%ngi - end function face_ngi_mesh + end function face_ngi_mesh - pure function face_ngi_scalar(field, face_number) result (face_ngi) - ! Return the number of nodes of element face_number. - integer :: face_ngi - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_ngi_scalar(field, face_number) result (face_ngi) + ! Return the number of nodes of element face_number. + integer :: face_ngi + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number - face_ngi=field%mesh%faces%shape%ngi + face_ngi=field%mesh%faces%shape%ngi - end function face_ngi_scalar + end function face_ngi_scalar - pure function face_ngi_vector(field, face_number) result (face_ngi) - ! Return the number of nodes of element face_number. - integer :: face_ngi - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_ngi_vector(field, face_number) result (face_ngi) + ! Return the number of nodes of element face_number. + integer :: face_ngi + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number - face_ngi=field%mesh%faces%shape%ngi + face_ngi=field%mesh%faces%shape%ngi - end function face_ngi_vector + end function face_ngi_vector - pure function face_ngi_tensor(field, face_number) result (face_ngi) - ! Return the number of nodes of element face_number. - integer :: face_ngi - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number + pure function face_ngi_tensor(field, face_number) result (face_ngi) + ! Return the number of nodes of element face_number. + integer :: face_ngi + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number - face_ngi=field%mesh%faces%shape%ngi + face_ngi=field%mesh%faces%shape%ngi - end function face_ngi_tensor + end function face_ngi_tensor - elemental function face_ele_scalar(field, face_number) result (face_ele) - ! Return the index of the element of which face is a part. - integer :: face_ele - type(scalar_field), intent(in) :: field - integer, intent(in) :: face_number + elemental function face_ele_scalar(field, face_number) result (face_ele) + ! Return the index of the element of which face is a part. + integer :: face_ele + type(scalar_field), intent(in) :: field + integer, intent(in) :: face_number - face_ele=field%mesh%faces%face_element_list(face_number) + face_ele=field%mesh%faces%face_element_list(face_number) - end function face_ele_scalar + end function face_ele_scalar - elemental function face_ele_vector(field, face_number) result (face_ele) - ! Return the index of the element of which face is a part. - integer :: face_ele - type(vector_field), intent(in) :: field - integer, intent(in) :: face_number + elemental function face_ele_vector(field, face_number) result (face_ele) + ! Return the index of the element of which face is a part. + integer :: face_ele + type(vector_field), intent(in) :: field + integer, intent(in) :: face_number - face_ele=field%mesh%faces%face_element_list(face_number) + face_ele=field%mesh%faces%face_element_list(face_number) - end function face_ele_vector + end function face_ele_vector - elemental function face_ele_tensor(field, face_number) result (face_ele) - ! Return the index of the element of which face is a part. - integer :: face_ele - type(tensor_field), intent(in) :: field - integer, intent(in) :: face_number + elemental function face_ele_tensor(field, face_number) result (face_ele) + ! Return the index of the element of which face is a part. + integer :: face_ele + type(tensor_field), intent(in) :: field + integer, intent(in) :: face_number - face_ele=field%mesh%faces%face_element_list(face_number) + face_ele=field%mesh%faces%face_element_list(face_number) - end function face_ele_tensor + end function face_ele_tensor - function local_face_number_mesh(mesh, global_face_number, stat) result (local_face_number) - ! Return the local face number of the given global face number in element ele_number - integer :: local_face_number - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: global_face_number - integer, intent(inout), optional :: stat + function local_face_number_mesh(mesh, global_face_number, stat) result (local_face_number) + ! Return the local face number of the given global face number in element ele_number + integer :: local_face_number + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: global_face_number + integer, intent(inout), optional :: stat - integer :: ele_number, i - integer, dimension(:), pointer :: element_faces + integer :: ele_number, i + integer, dimension(:), pointer :: element_faces - local_face_number = 0 + local_face_number = 0 - ele_number = face_ele(mesh, global_face_number) + ele_number = face_ele(mesh, global_face_number) - element_faces => ele_faces(mesh, ele_number) - do i = 1, size(element_faces) - if(element_faces(i) == global_face_number) then - local_face_number = i - exit - end if - end do + element_faces => ele_faces(mesh, ele_number) + do i = 1, size(element_faces) + if(element_faces(i) == global_face_number) then + local_face_number = i + exit + end if + end do - if(local_face_number==0) then - if(present(stat)) then - stat = 1 + if(local_face_number==0) then + if(present(stat)) then + stat = 1 + else + FLAbort("Failed to find local face number.") + end if else - FLAbort("Failed to find local face number.") + if(present(stat)) stat = 0 end if - else - if(present(stat)) stat = 0 - end if - end function local_face_number_mesh + end function local_face_number_mesh - function local_face_number_scalar(field, global_face_number, stat) result (local_face_number) - ! Return the local face number of the given global face number in element ele_number - integer :: local_face_number - type(scalar_field), intent(in) :: field - integer, intent(in) :: global_face_number - integer, intent(inout), optional :: stat + function local_face_number_scalar(field, global_face_number, stat) result (local_face_number) + ! Return the local face number of the given global face number in element ele_number + integer :: local_face_number + type(scalar_field), intent(in) :: field + integer, intent(in) :: global_face_number + integer, intent(inout), optional :: stat - local_face_number = local_face_number_mesh(field%mesh, global_face_number, stat) + local_face_number = local_face_number_mesh(field%mesh, global_face_number, stat) - end function local_face_number_scalar + end function local_face_number_scalar - function local_face_number_vector(field, global_face_number, stat) result (local_face_number) - ! Return the local face number of the given global face number in element ele_number - integer :: local_face_number - type(vector_field), intent(in) :: field - integer, intent(in) :: global_face_number - integer, intent(inout), optional :: stat + function local_face_number_vector(field, global_face_number, stat) result (local_face_number) + ! Return the local face number of the given global face number in element ele_number + integer :: local_face_number + type(vector_field), intent(in) :: field + integer, intent(in) :: global_face_number + integer, intent(inout), optional :: stat - local_face_number = local_face_number_mesh(field%mesh, global_face_number, stat) + local_face_number = local_face_number_mesh(field%mesh, global_face_number, stat) - end function local_face_number_vector + end function local_face_number_vector - function local_face_number_tensor(field, global_face_number, stat) result (local_face_number) - ! Return the local face number of the given global face number in element ele_number - integer :: local_face_number - type(tensor_field), intent(in) :: field - integer, intent(in) :: global_face_number - integer, intent(inout), optional :: stat + function local_face_number_tensor(field, global_face_number, stat) result (local_face_number) + ! Return the local face number of the given global face number in element ele_number + integer :: local_face_number + type(tensor_field), intent(in) :: field + integer, intent(in) :: global_face_number + integer, intent(inout), optional :: stat - local_face_number = local_face_number_mesh(field%mesh, global_face_number, stat) + local_face_number = local_face_number_mesh(field%mesh, global_face_number, stat) - end function local_face_number_tensor + end function local_face_number_tensor - function ele_nodes_mesh(mesh, ele_number) result (ele_nodes) - ! Return a pointer to a vector containing the global node numbers of - ! element ele_number in mesh. - integer, dimension(:), pointer :: ele_nodes - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: ele_number + function ele_nodes_mesh(mesh, ele_number) result (ele_nodes) + ! Return a pointer to a vector containing the global node numbers of + ! element ele_number in mesh. + integer, dimension(:), pointer :: ele_nodes + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: ele_number - ele_nodes=>mesh%ndglno(mesh%shape%loc*(ele_number-1)+1:& - &mesh%shape%loc*ele_number) + ele_nodes=>mesh%ndglno(mesh%shape%loc*(ele_number-1)+1:& + &mesh%shape%loc*ele_number) - end function ele_nodes_mesh + end function ele_nodes_mesh - function ele_nodes_scalar(field, ele_number) result (ele_nodes) - ! Return a pointer to a vector containing the global node numbers of - ! element ele_number in field. - integer, dimension(:), pointer :: ele_nodes - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_nodes_scalar(field, ele_number) result (ele_nodes) + ! Return a pointer to a vector containing the global node numbers of + ! element ele_number in field. + integer, dimension(:), pointer :: ele_nodes + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_nodes=>ele_nodes_mesh(field%mesh, ele_number) + ele_nodes=>ele_nodes_mesh(field%mesh, ele_number) - end function ele_nodes_scalar + end function ele_nodes_scalar - function ele_nodes_vector(field, ele_number) result (ele_nodes) - ! Return a pointer to a vector containing the global node numbers of - ! element ele_number in field. - integer, dimension(:), pointer :: ele_nodes - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_nodes_vector(field, ele_number) result (ele_nodes) + ! Return a pointer to a vector containing the global node numbers of + ! element ele_number in field. + integer, dimension(:), pointer :: ele_nodes + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_nodes=>ele_nodes_mesh(field%mesh, ele_number) + ele_nodes=>ele_nodes_mesh(field%mesh, ele_number) - end function ele_nodes_vector + end function ele_nodes_vector - function ele_nodes_tensor(field, ele_number) result (ele_nodes) - ! Return a pointer to a tensor containing the global node numbers of - ! element ele_number in field. - integer, dimension(:), pointer :: ele_nodes - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number + function ele_nodes_tensor(field, ele_number) result (ele_nodes) + ! Return a pointer to a tensor containing the global node numbers of + ! element ele_number in field. + integer, dimension(:), pointer :: ele_nodes + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number - ele_nodes=>ele_nodes_mesh(field%mesh, ele_number) + ele_nodes=>ele_nodes_mesh(field%mesh, ele_number) - end function ele_nodes_tensor + end function ele_nodes_tensor - function face_local_nodes_mesh(mesh, face_number) result (face_nodes) - ! Return a pointer to a vector containing the local node numbers of - ! facet face_number in mesh. - integer, dimension(:), pointer :: face_nodes - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: face_number + function face_local_nodes_mesh(mesh, face_number) result (face_nodes) + ! Return a pointer to a vector containing the local node numbers of + ! facet face_number in mesh. + integer, dimension(:), pointer :: face_nodes + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: face_number - ! This just reduces notational clutter. - type(mesh_faces), pointer :: faces + ! This just reduces notational clutter. + type(mesh_faces), pointer :: faces - faces=>mesh%faces + faces=>mesh%faces - face_nodes=>faces%face_lno(faces%shape%loc*(face_number-1)+1:& - &faces%shape%loc*face_number) + face_nodes=>faces%face_lno(faces%shape%loc*(face_number-1)+1:& + &faces%shape%loc*face_number) - end function face_local_nodes_mesh + end function face_local_nodes_mesh - function face_local_nodes_scalar(field, face_number) result (face_nodes) - !!< Return a vector containing the local node numbers of - !!< facet face_number in field. - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number - integer, dimension(face_loc(field, face_number)) :: face_nodes + function face_local_nodes_scalar(field, face_number) result (face_nodes) + !!< Return a vector containing the local node numbers of + !!< facet face_number in field. + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number + integer, dimension(face_loc(field, face_number)) :: face_nodes - face_nodes=face_local_nodes_mesh(field%mesh, face_number) + face_nodes=face_local_nodes_mesh(field%mesh, face_number) - end function face_local_nodes_scalar + end function face_local_nodes_scalar - function face_local_nodes_vector(field, face_number) result (face_nodes) - !!< Return a vector containing the local node numbers of - !!< facet face_number in field. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - integer, dimension(face_loc(field, face_number)) :: face_nodes + function face_local_nodes_vector(field, face_number) result (face_nodes) + !!< Return a vector containing the local node numbers of + !!< facet face_number in field. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + integer, dimension(face_loc(field, face_number)) :: face_nodes - face_nodes=face_local_nodes_mesh(field%mesh, face_number) + face_nodes=face_local_nodes_mesh(field%mesh, face_number) - end function face_local_nodes_vector + end function face_local_nodes_vector - function face_local_nodes_tensor(field, face_number) result (face_nodes) - !!< Return a vector containing the local node numbers of - !!< facet face_number in field. - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number - integer, dimension(face_loc(field, face_number)) :: face_nodes + function face_local_nodes_tensor(field, face_number) result (face_nodes) + !!< Return a vector containing the local node numbers of + !!< facet face_number in field. + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number + integer, dimension(face_loc(field, face_number)) :: face_nodes - face_nodes=face_local_nodes_mesh(field%mesh, face_number) + face_nodes=face_local_nodes_mesh(field%mesh, face_number) - end function face_local_nodes_tensor + end function face_local_nodes_tensor - function face_global_nodes_mesh(mesh, face_number) result (face_nodes) - !!< Return a vector containing the global node numbers of - !!< facet face_number in mesh. - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: face_number - integer, dimension(face_loc(mesh, face_number)) :: face_nodes + function face_global_nodes_mesh(mesh, face_number) result (face_nodes) + !!< Return a vector containing the global node numbers of + !!< facet face_number in mesh. + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: face_number + integer, dimension(face_loc(mesh, face_number)) :: face_nodes - integer, dimension(:), pointer :: ele + integer, dimension(:), pointer :: ele - assert(has_faces(mesh)) + assert(has_faces(mesh)) - ele=>ele_nodes(mesh, face_ele(mesh,face_number)) + ele=>ele_nodes(mesh, face_ele(mesh,face_number)) - face_nodes=ele(face_local_nodes_mesh(mesh, face_number)) + face_nodes=ele(face_local_nodes_mesh(mesh, face_number)) - end function face_global_nodes_mesh + end function face_global_nodes_mesh - function face_global_nodes_scalar(field, face_number) result (face_nodes) - !!< Return a vector containing the global node numbers of - !!< facet face_number in field. - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number - integer, dimension(face_loc(field, face_number)) :: face_nodes + function face_global_nodes_scalar(field, face_number) result (face_nodes) + !!< Return a vector containing the global node numbers of + !!< facet face_number in field. + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number + integer, dimension(face_loc(field, face_number)) :: face_nodes - face_nodes=face_global_nodes_mesh(field%mesh, face_number) + face_nodes=face_global_nodes_mesh(field%mesh, face_number) - end function face_global_nodes_scalar + end function face_global_nodes_scalar - function face_global_nodes_vector(field, face_number) result (face_nodes) - !!< Return a vector containing the global node numbers of - !!< facet face_number in field. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - integer, dimension(face_loc(field, face_number)) :: face_nodes + function face_global_nodes_vector(field, face_number) result (face_nodes) + !!< Return a vector containing the global node numbers of + !!< facet face_number in field. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + integer, dimension(face_loc(field, face_number)) :: face_nodes - face_nodes=face_global_nodes_mesh(field%mesh, face_number) + face_nodes=face_global_nodes_mesh(field%mesh, face_number) - end function face_global_nodes_vector + end function face_global_nodes_vector - function face_global_nodes_tensor(field, face_number) result (face_nodes) - !!< Return a vector containing the global node numbers of - !!< facet face_number in field. - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number - integer, dimension(face_loc(field, face_number)) :: face_nodes + function face_global_nodes_tensor(field, face_number) result (face_nodes) + !!< Return a vector containing the global node numbers of + !!< facet face_number in field. + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number + integer, dimension(face_loc(field, face_number)) :: face_nodes - face_nodes=face_global_nodes_mesh(field%mesh, face_number) + face_nodes=face_global_nodes_mesh(field%mesh, face_number) - end function face_global_nodes_tensor + end function face_global_nodes_tensor - function ele_shape_mesh(mesh, ele_number) result (ele_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: ele_shape - type(mesh_type),intent(in), target :: mesh - integer, intent(in) :: ele_number + function ele_shape_mesh(mesh, ele_number) result (ele_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: ele_shape + type(mesh_type),intent(in), target :: mesh + integer, intent(in) :: ele_number - ele_shape=>mesh%shape + ele_shape=>mesh%shape - end function ele_shape_mesh + end function ele_shape_mesh - function ele_shape_scalar(field, ele_number) result (ele_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: ele_shape - type(scalar_field),intent(in), target :: field - integer, intent(in) :: ele_number + function ele_shape_scalar(field, ele_number) result (ele_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: ele_shape + type(scalar_field),intent(in), target :: field + integer, intent(in) :: ele_number - ele_shape=>field%mesh%shape + ele_shape=>field%mesh%shape - end function ele_shape_scalar + end function ele_shape_scalar - function ele_shape_vector(field, ele_number) result (ele_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: ele_shape - type(vector_field),intent(in), target :: field - integer, intent(in) :: ele_number + function ele_shape_vector(field, ele_number) result (ele_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: ele_shape + type(vector_field),intent(in), target :: field + integer, intent(in) :: ele_number - ele_shape=>field%mesh%shape + ele_shape=>field%mesh%shape - end function ele_shape_vector + end function ele_shape_vector - function ele_shape_tensor(field, ele_number) result (ele_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: ele_shape - type(tensor_field),intent(in), target :: field - integer, intent(in) :: ele_number + function ele_shape_tensor(field, ele_number) result (ele_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: ele_shape + type(tensor_field),intent(in), target :: field + integer, intent(in) :: ele_number - ele_shape=>field%mesh%shape + ele_shape=>field%mesh%shape - end function ele_shape_tensor + end function ele_shape_tensor - function face_shape_mesh(mesh, face_number) result (face_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: face_shape - type(mesh_type),intent(in) :: mesh - integer, intent(in) :: face_number + function face_shape_mesh(mesh, face_number) result (face_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: face_shape + type(mesh_type),intent(in) :: mesh + integer, intent(in) :: face_number - face_shape=>mesh%faces%shape + face_shape=>mesh%faces%shape - end function face_shape_mesh + end function face_shape_mesh - function face_shape_scalar(field, face_number) result (face_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: face_shape - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number + function face_shape_scalar(field, face_number) result (face_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: face_shape + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number - face_shape=>field%mesh%faces%shape + face_shape=>field%mesh%faces%shape - end function face_shape_scalar + end function face_shape_scalar - function face_shape_vector(field, face_number) result (face_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: face_shape - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number + function face_shape_vector(field, face_number) result (face_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: face_shape + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number - face_shape=>field%mesh%faces%shape + face_shape=>field%mesh%faces%shape - end function face_shape_vector + end function face_shape_vector - function face_shape_tensor(field, face_number) result (face_shape) - ! Return a pointer to the shape of element ele_number. - type(element_type), pointer :: face_shape - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number + function face_shape_tensor(field, face_number) result (face_shape) + ! Return a pointer to the shape of element ele_number. + type(element_type), pointer :: face_shape + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number - face_shape=>field%mesh%faces%shape + face_shape=>field%mesh%faces%shape - end function face_shape_tensor + end function face_shape_tensor - function ele_val_scalar(field, ele_number) result (ele_val_out) - ! Return the values of field at the nodes of ele_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%mesh%shape%loc) :: ele_val_out - integer :: i + function ele_val_scalar(field, ele_number) result (ele_val_out) + ! Return the values of field at the nodes of ele_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%mesh%shape%loc) :: ele_val_out + integer :: i - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - ele_val_out=field%val(ele_nodes(field,ele_number)) - case(FIELD_TYPE_CONSTANT) - ele_val_out=field%val(1) - case(FIELD_TYPE_PYTHON) - call val_python - end select + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + ele_val_out=field%val(ele_nodes(field,ele_number)) + case(FIELD_TYPE_CONSTANT) + ele_val_out=field%val(1) + case(FIELD_TYPE_PYTHON) + call val_python + end select - contains + contains + + subroutine val_python + !!< This subroutine only exists to remove the following stack variables + !!< from the main routine. + real, dimension(field%py_dim, field%mesh%shape%loc) :: pos + real, dimension(field%py_dim, field%py_positions_shape%loc) :: tmp_pos + + if (.not. field%py_positions_same_mesh) then + tmp_pos = ele_val(field%py_positions, ele_number) + do i=1,field%py_dim + pos(i, :) = matmul(field%py_locweight, tmp_pos(i, :)) + end do + else + do i=1,field%py_dim + pos(i, :) = field%py_positions%val(i,ele_nodes(field%py_positions%mesh, ele_number)) + end do + end if + call set_from_python_function(ele_val_out, trim(field%py_func), pos, & + time=current_time) + + end subroutine val_python + + end function ele_val_scalar + + function ele_val_vector(field, ele_number) result (ele_val) + ! Return the values of field at the nodes of ele_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%dim, field%mesh%shape%loc) :: ele_val + + integer :: i + integer, dimension(:), pointer :: nodes + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + nodes => ele_nodes(field, ele_number) + do i=1,field%dim + ele_val(i, :) = field%val(i,nodes) + end do + case(FIELD_TYPE_CONSTANT) + do i=1,field%dim + ele_val(i,:)=field%val(i,1) + end do + end select - subroutine val_python - !!< This subroutine only exists to remove the following stack variables - !!< from the main routine. - real, dimension(field%py_dim, field%mesh%shape%loc) :: pos - real, dimension(field%py_dim, field%py_positions_shape%loc) :: tmp_pos - if (.not. field%py_positions_same_mesh) then - tmp_pos = ele_val(field%py_positions, ele_number) - do i=1,field%py_dim - pos(i, :) = matmul(field%py_locweight, tmp_pos(i, :)) - end do - else - do i=1,field%py_dim - pos(i, :) = field%py_positions%val(i,ele_nodes(field%py_positions%mesh, ele_number)) - end do - end if - call set_from_python_function(ele_val_out, trim(field%py_func), pos, & - time=current_time) + end function ele_val_vector - end subroutine val_python + function ele_val_vector_dim(field, dim, ele_number) result (ele_val) + ! Return the values of dimension dim of field at the nodes of ele_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%mesh%shape%loc) :: ele_val + integer, intent(in) :: dim - end function ele_val_scalar + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + ele_val=field%val(dim,ele_nodes(field,ele_number)) + case(FIELD_TYPE_CONSTANT) + ele_val=field%val(dim,1) + end select - function ele_val_vector(field, ele_number) result (ele_val) - ! Return the values of field at the nodes of ele_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%dim, field%mesh%shape%loc) :: ele_val + end function ele_val_vector_dim + + function ele_val_tensor(field, ele_number) result (ele_val) + ! Return the values of field at the nodes of ele_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%dim(1), field%dim(2), field%mesh%shape%loc) :: ele_val + + integer, dimension(:), pointer :: nodes + integer :: i + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + nodes=>ele_nodes(field,ele_number) + ele_val=field%val(:,:,nodes) + case(FIELD_TYPE_CONSTANT) + do i=1,size(ele_val, 3) + ele_val(:, :, i)=field%val(:, :, 1) + end do + end select - integer :: i - integer, dimension(:), pointer :: nodes + end function ele_val_tensor - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - nodes => ele_nodes(field, ele_number) - do i=1,field%dim - ele_val(i, :) = field%val(i,nodes) - end do - case(FIELD_TYPE_CONSTANT) - do i=1,field%dim - ele_val(i,:)=field%val(i,1) - end do - end select - - - end function ele_val_vector - - function ele_val_vector_dim(field, dim, ele_number) result (ele_val) - ! Return the values of dimension dim of field at the nodes of ele_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%mesh%shape%loc) :: ele_val - integer, intent(in) :: dim - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - ele_val=field%val(dim,ele_nodes(field,ele_number)) - case(FIELD_TYPE_CONSTANT) - ele_val=field%val(dim,1) - end select - - end function ele_val_vector_dim - - function ele_val_tensor(field, ele_number) result (ele_val) - ! Return the values of field at the nodes of ele_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%dim(1), field%dim(2), field%mesh%shape%loc) :: ele_val - - integer, dimension(:), pointer :: nodes - integer :: i - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - nodes=>ele_nodes(field,ele_number) - ele_val=field%val(:,:,nodes) - case(FIELD_TYPE_CONSTANT) - do i=1,size(ele_val, 3) - ele_val(:, :, i)=field%val(:, :, 1) - end do - end select - - end function ele_val_tensor - - function ele_val_tensor_dim_dim(field, dim1, dim2, ele_number) result (ele_val) - ! Return the values of field at the nodes of ele_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: dim1, dim2 - integer, intent(in) :: ele_number - real, dimension(field%mesh%shape%loc) :: ele_val - - integer, dimension(:), pointer :: nodes - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - nodes=>ele_nodes(field,ele_number) - ele_val=field%val(dim1,dim2,nodes) - case(FIELD_TYPE_CONSTANT) - ele_val=field%val(dim1, dim2, 1) - end select - - end function ele_val_tensor_dim_dim - - function face_val_scalar(field, face_number) result (face_val) - ! Return the values of field at the nodes of face_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(face_loc(field, face_number)) :: face_val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - face_val=field%val(face_global_nodes(field,face_number)) - case(FIELD_TYPE_CONSTANT) - face_val=field%val(1) - end select - - end function face_val_scalar - - function face_val_vector(field, face_number) result (face_val) - ! Return the values of field at the nodes of face_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(field%dim, face_loc(field, face_number)) :: face_val - - integer :: i - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - face_val=field%val(:,face_global_nodes(field,face_number)) - case(FIELD_TYPE_CONSTANT) - do i=1,field%dim - face_val(i,:)=field%val(i,1) - end do - end select + function ele_val_tensor_dim_dim(field, dim1, dim2, ele_number) result (ele_val) + ! Return the values of field at the nodes of ele_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: dim1, dim2 + integer, intent(in) :: ele_number + real, dimension(field%mesh%shape%loc) :: ele_val + + integer, dimension(:), pointer :: nodes + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + nodes=>ele_nodes(field,ele_number) + ele_val=field%val(dim1,dim2,nodes) + case(FIELD_TYPE_CONSTANT) + ele_val=field%val(dim1, dim2, 1) + end select - end function face_val_vector + end function ele_val_tensor_dim_dim - function face_val_vector_dim(field, dim, face_number) result (face_val) - !!< Return the values of dimension dim of field at the nodes of face_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(face_loc(field, face_number)) :: face_val - integer :: dim + function face_val_scalar(field, face_number) result (face_val) + ! Return the values of field at the nodes of face_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(face_loc(field, face_number)) :: face_val - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - face_val=field%val(dim,face_global_nodes(field,face_number)) - case(FIELD_TYPE_CONSTANT) - face_val=field%val(dim,1) - end select + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + face_val=field%val(face_global_nodes(field,face_number)) + case(FIELD_TYPE_CONSTANT) + face_val=field%val(1) + end select + + end function face_val_scalar - end function face_val_vector_dim + function face_val_vector(field, face_number) result (face_val) + ! Return the values of field at the nodes of face_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(field%dim, face_loc(field, face_number)) :: face_val - function face_val_tensor(field, face_number) result (face_val) - ! Return the values of field at the nodes of face_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(field%dim(1), field%dim(2), face_loc(field, face_number)) ::& - & face_val + integer :: i + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + face_val=field%val(:,face_global_nodes(field,face_number)) + case(FIELD_TYPE_CONSTANT) + do i=1,field%dim + face_val(i,:)=field%val(i,1) + end do + end select - integer :: i + end function face_val_vector - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - face_val=field%val(:,:,face_global_nodes(field,face_number)) + function face_val_vector_dim(field, dim, face_number) result (face_val) + !!< Return the values of dimension dim of field at the nodes of face_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(face_loc(field, face_number)) :: face_val + integer :: dim - case(FIELD_TYPE_CONSTANT) - forall(i=1:face_loc(field, face_number)) - face_val(:,:,i)=field%val(:,:,1) - end forall - end select + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + face_val=field%val(dim,face_global_nodes(field,face_number)) + case(FIELD_TYPE_CONSTANT) + face_val=field%val(dim,1) + end select - end function face_val_tensor + end function face_val_vector_dim - function face_val_tensor_dim_dim(field, dim1, dim2, face_number) result& - & (face_val) - !!< Return the values of dimension dim of field at the nodes of face_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: dim1, dim2 - integer, intent(in) :: face_number - real, dimension(face_loc(field, face_number)) :: face_val + function face_val_tensor(field, face_number) result (face_val) + ! Return the values of field at the nodes of face_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(field%dim(1), field%dim(2), face_loc(field, face_number)) ::& + & face_val - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - face_val=field%val(dim1,dim2,face_global_nodes(field,face_number)) - case(FIELD_TYPE_CONSTANT) - face_val=field%val(dim1,dim2,1) - end select + integer :: i - end function face_val_tensor_dim_dim + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + face_val=field%val(:,:,face_global_nodes(field,face_number)) - function ele_val_at_quad_scalar(field, ele_number) result (quad_val) - ! Return the values of field at the quadrature points of ele_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%mesh%shape%ngi) :: quad_val + case(FIELD_TYPE_CONSTANT) + forall(i=1:face_loc(field, face_number)) + face_val(:,:,i)=field%val(:,:,1) + end forall + end select - type(element_type), pointer :: shape + end function face_val_tensor + + function face_val_tensor_dim_dim(field, dim1, dim2, face_number) result& + & (face_val) + !!< Return the values of dimension dim of field at the nodes of face_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: dim1, dim2 + integer, intent(in) :: face_number + real, dimension(face_loc(field, face_number)) :: face_val + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + face_val=field%val(dim1,dim2,face_global_nodes(field,face_number)) + case(FIELD_TYPE_CONSTANT) + face_val=field%val(dim1,dim2,1) + end select - shape=>ele_shape(field,ele_number) - quad_val=matmul(ele_val(field, ele_number), shape%n) + end function face_val_tensor_dim_dim - end function ele_val_at_quad_scalar + function ele_val_at_quad_scalar(field, ele_number) result (quad_val) + ! Return the values of field at the quadrature points of ele_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%mesh%shape%ngi) :: quad_val - function ele_val_at_quad_vector(field, ele_number) result (quad_val) - ! Return the values of field at the quadrature points of ele_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%dim, field%mesh%shape%ngi) :: quad_val + type(element_type), pointer :: shape - type(element_type), pointer :: shape + shape=>ele_shape(field,ele_number) + quad_val=matmul(ele_val(field, ele_number), shape%n) - shape=>ele_shape(field,ele_number) + end function ele_val_at_quad_scalar - quad_val=matmul(ele_val(field, ele_number), shape%n) + function ele_val_at_quad_vector(field, ele_number) result (quad_val) + ! Return the values of field at the quadrature points of ele_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%dim, field%mesh%shape%ngi) :: quad_val - end function ele_val_at_quad_vector + type(element_type), pointer :: shape - function ele_val_at_quad_vector_dim(field, ele_number, dim) result (quad_val) - ! Return the values of field at the quadrature points of ele_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%mesh%shape%ngi) :: quad_val - integer, intent(in):: dim + shape=>ele_shape(field,ele_number) - type(element_type), pointer :: shape + quad_val=matmul(ele_val(field, ele_number), shape%n) - shape=>ele_shape(field,ele_number) + end function ele_val_at_quad_vector - quad_val=matmul(ele_val(field, dim, ele_number), shape%n) + function ele_val_at_quad_vector_dim(field, ele_number, dim) result (quad_val) + ! Return the values of field at the quadrature points of ele_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%mesh%shape%ngi) :: quad_val + integer, intent(in):: dim - end function ele_val_at_quad_vector_dim + type(element_type), pointer :: shape - function ele_val_at_quad_tensor(field, ele_number) result (quad_val) - ! Return the values of field at the quadrature points of ele_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%dim(1), field%dim(2), field%mesh%shape%ngi) :: quad_val + shape=>ele_shape(field,ele_number) - type(element_type), pointer :: shape + quad_val=matmul(ele_val(field, dim, ele_number), shape%n) - shape=>ele_shape(field,ele_number) + end function ele_val_at_quad_vector_dim - quad_val=tensormul(ele_val(field, ele_number), shape%n) + function ele_val_at_quad_tensor(field, ele_number) result (quad_val) + ! Return the values of field at the quadrature points of ele_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%dim(1), field%dim(2), field%mesh%shape%ngi) :: quad_val - end function ele_val_at_quad_tensor + type(element_type), pointer :: shape - function ele_val_at_quad_tensor_dim_dim(field, i, j, ele_number) result (quad_val) - ! Return the values of field at the quadrature points of ele_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number - integer, intent(in) :: i, j - real, dimension(field%mesh%shape%ngi) :: quad_val + shape=>ele_shape(field,ele_number) - type(element_type), pointer :: shape + quad_val=tensormul(ele_val(field, ele_number), shape%n) - shape=>ele_shape(field,ele_number) + end function ele_val_at_quad_tensor - quad_val=matmul(ele_val(field, i, j, ele_number), shape%n) - end function ele_val_at_quad_tensor_dim_dim + function ele_val_at_quad_tensor_dim_dim(field, i, j, ele_number) result (quad_val) + ! Return the values of field at the quadrature points of ele_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number + integer, intent(in) :: i, j + real, dimension(field%mesh%shape%ngi) :: quad_val - function ele_val_at_shape_quad_scalar(field, ele_number, shape) result (quad_val) - ! Return the values of field at the quadrature points of shape in ele_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number - type(element_type), intent(in) :: shape - real, dimension(shape%ngi) :: quad_val + type(element_type), pointer :: shape - type(element_type), pointer :: meshshape + shape=>ele_shape(field,ele_number) - meshshape=>ele_shape(field, ele_number) - assert(meshshape%loc==shape%loc) + quad_val=matmul(ele_val(field, i, j, ele_number), shape%n) + end function ele_val_at_quad_tensor_dim_dim - quad_val=matmul(ele_val(field, ele_number), shape%n) + function ele_val_at_shape_quad_scalar(field, ele_number, shape) result (quad_val) + ! Return the values of field at the quadrature points of shape in ele_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number + type(element_type), intent(in) :: shape + real, dimension(shape%ngi) :: quad_val - end function ele_val_at_shape_quad_scalar + type(element_type), pointer :: meshshape - function ele_val_at_shape_quad_vector(field, ele_number, shape) result (quad_val) - ! Return the values of field at the quadrature points of shape in ele_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - type(element_type), intent(in) :: shape - real, dimension(field%dim, shape%ngi) :: quad_val + meshshape=>ele_shape(field, ele_number) + assert(meshshape%loc==shape%loc) - type(element_type), pointer :: meshshape + quad_val=matmul(ele_val(field, ele_number), shape%n) - meshshape=>ele_shape(field, ele_number) - assert(meshshape%loc==shape%loc) + end function ele_val_at_shape_quad_scalar - quad_val=matmul(ele_val(field, ele_number), shape%n) + function ele_val_at_shape_quad_vector(field, ele_number, shape) result (quad_val) + ! Return the values of field at the quadrature points of shape in ele_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + type(element_type), intent(in) :: shape + real, dimension(field%dim, shape%ngi) :: quad_val - end function ele_val_at_shape_quad_vector + type(element_type), pointer :: meshshape - function ele_val_at_shape_quad_tensor(field, ele_number, shape) result (quad_val) - ! Return the values of field at the quadrature points of shape in ele_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number - type(element_type), intent(in) :: shape - real, dimension(field%dim(1), field%dim(2), shape%ngi) :: quad_val + meshshape=>ele_shape(field, ele_number) + assert(meshshape%loc==shape%loc) - type(element_type), pointer :: meshshape + quad_val=matmul(ele_val(field, ele_number), shape%n) - meshshape=>ele_shape(field, ele_number) - assert(meshshape%loc==shape%loc) + end function ele_val_at_shape_quad_vector - quad_val=tensormul(ele_val(field, ele_number), shape%n) + function ele_val_at_shape_quad_tensor(field, ele_number, shape) result (quad_val) + ! Return the values of field at the quadrature points of shape in ele_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number + type(element_type), intent(in) :: shape + real, dimension(field%dim(1), field%dim(2), shape%ngi) :: quad_val - end function ele_val_at_shape_quad_tensor + type(element_type), pointer :: meshshape - function face_val_at_quad_scalar(field, face_number) result (quad_val) - ! Return the values of field at the quadrature points of face_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension( face_ngi(field, face_number)) :: quad_val + meshshape=>ele_shape(field, ele_number) + assert(meshshape%loc==shape%loc) - type(element_type), pointer :: shape + quad_val=tensormul(ele_val(field, ele_number), shape%n) - shape=>face_shape(field, face_number) + end function ele_val_at_shape_quad_tensor - quad_val=matmul(face_val(field, face_number), shape%n) + function face_val_at_quad_scalar(field, face_number) result (quad_val) + ! Return the values of field at the quadrature points of face_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension( face_ngi(field, face_number)) :: quad_val - end function face_val_at_quad_scalar + type(element_type), pointer :: shape - function face_val_at_quad_vector(field, face_number) result (quad_val) - ! Return the values of field at the quadrature points of face_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(field%dim, face_ngi(field, face_number)) :: quad_val + shape=>face_shape(field, face_number) - type(element_type), pointer :: shape + quad_val=matmul(face_val(field, face_number), shape%n) - shape=>face_shape(field,face_number) + end function face_val_at_quad_scalar - quad_val=matmul(face_val(field, face_number), shape%n) + function face_val_at_quad_vector(field, face_number) result (quad_val) + ! Return the values of field at the quadrature points of face_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(field%dim, face_ngi(field, face_number)) :: quad_val - end function face_val_at_quad_vector + type(element_type), pointer :: shape - function face_val_at_quad_vector_dim(field, face_number, dim) result (quad_val) - ! Return the values of field at the quadrature points of face_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(face_ngi(field, face_number)) :: quad_val - integer, intent(in) :: dim + shape=>face_shape(field,face_number) - type(element_type), pointer :: shape + quad_val=matmul(face_val(field, face_number), shape%n) - shape=>face_shape(field,face_number) + end function face_val_at_quad_vector - quad_val=matmul(face_val(field, dim, face_number), shape%n) + function face_val_at_quad_vector_dim(field, face_number, dim) result (quad_val) + ! Return the values of field at the quadrature points of face_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(face_ngi(field, face_number)) :: quad_val + integer, intent(in) :: dim - end function face_val_at_quad_vector_dim + type(element_type), pointer :: shape - function face_val_at_quad_tensor(field, face_number) result (quad_val) - ! Return the values of field at the quadrature points of face_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(field%dim(1), field%dim(2), face_ngi(field, face_number)) :: quad_val + shape=>face_shape(field,face_number) - type(element_type), pointer :: shape + quad_val=matmul(face_val(field, dim, face_number), shape%n) - shape=>face_shape(field,face_number) + end function face_val_at_quad_vector_dim - quad_val=tensormul(face_val(field, face_number), shape%n) + function face_val_at_quad_tensor(field, face_number) result (quad_val) + ! Return the values of field at the quadrature points of face_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(field%dim(1), field%dim(2), face_ngi(field, face_number)) :: quad_val - end function face_val_at_quad_tensor + type(element_type), pointer :: shape - function face_val_at_quad_tensor_dim_dim(field, face_number, dim1, dim2) result (quad_val) - ! Return the values of field at the quadrature points of face_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number - real, dimension(face_ngi(field, face_number)) :: quad_val - integer, intent(in) :: dim1, dim2 + shape=>face_shape(field,face_number) - type(element_type), pointer :: shape + quad_val=tensormul(face_val(field, face_number), shape%n) - shape=>face_shape(field,face_number) + end function face_val_at_quad_tensor - quad_val=matmul(face_val(field, dim1, dim2, face_number), shape%n) + function face_val_at_quad_tensor_dim_dim(field, face_number, dim1, dim2) result (quad_val) + ! Return the values of field at the quadrature points of face_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number + real, dimension(face_ngi(field, face_number)) :: quad_val + integer, intent(in) :: dim1, dim2 - end function face_val_at_quad_tensor_dim_dim + type(element_type), pointer :: shape - function face_val_at_shape_quad_scalar(field, face_number, shape) result (quad_val) - ! Return the values of field at the quadrature points of shape in face_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: face_number - type(element_type), intent(in) :: shape - real, dimension(shape%ngi) :: quad_val + shape=>face_shape(field,face_number) - type(element_type), pointer :: meshshape + quad_val=matmul(face_val(field, dim1, dim2, face_number), shape%n) - meshshape=>face_shape(field, face_number) - assert(meshshape%loc==shape%loc) + end function face_val_at_quad_tensor_dim_dim - quad_val=matmul(face_val(field, face_number), shape%n) + function face_val_at_shape_quad_scalar(field, face_number, shape) result (quad_val) + ! Return the values of field at the quadrature points of shape in face_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: face_number + type(element_type), intent(in) :: shape + real, dimension(shape%ngi) :: quad_val - end function face_val_at_shape_quad_scalar + type(element_type), pointer :: meshshape - function face_val_at_shape_quad_vector(field, face_number, shape) result (quad_val) - ! Return the values of field at the quadrature points of shape in face_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: face_number - type(element_type), intent(in) :: shape - real, dimension(field%dim, shape%ngi) :: quad_val + meshshape=>face_shape(field, face_number) + assert(meshshape%loc==shape%loc) - type(element_type), pointer :: meshshape + quad_val=matmul(face_val(field, face_number), shape%n) - meshshape=>face_shape(field,face_number) - assert(meshshape%loc==shape%loc) + end function face_val_at_shape_quad_scalar - quad_val=matmul(face_val(field, face_number), shape%n) + function face_val_at_shape_quad_vector(field, face_number, shape) result (quad_val) + ! Return the values of field at the quadrature points of shape in face_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: face_number + type(element_type), intent(in) :: shape + real, dimension(field%dim, shape%ngi) :: quad_val - end function face_val_at_shape_quad_vector + type(element_type), pointer :: meshshape - function face_val_at_shape_quad_tensor(field, face_number, shape) result (quad_val) - ! Return the values of field at the quadrature points of face_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: face_number - type(element_type), intent(in) :: shape - real, dimension(mesh_dim(field), mesh_dim(field), shape%ngi) :: quad_val + meshshape=>face_shape(field,face_number) + assert(meshshape%loc==shape%loc) - type(element_type), pointer :: meshshape + quad_val=matmul(face_val(field, face_number), shape%n) - meshshape=>face_shape(field, face_number) - assert(meshshape%loc==shape%loc) + end function face_val_at_shape_quad_vector - quad_val=tensormul(face_val(field, face_number), shape%n) + function face_val_at_shape_quad_tensor(field, face_number, shape) result (quad_val) + ! Return the values of field at the quadrature points of face_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: face_number + type(element_type), intent(in) :: shape + real, dimension(mesh_dim(field), mesh_dim(field), shape%ngi) :: quad_val - end function face_val_at_shape_quad_tensor + type(element_type), pointer :: meshshape - function ele_grad_at_quad_scalar(field, ele_number, dn) result (quad_grad) - ! Return the grad of field at the quadrature points of - ! ele_number. dn is the transformed element gradient. - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field,ele_number), & - & ele_ngi(field,ele_number),& - & mesh_dim(field)), intent(in) :: dn - real, dimension(mesh_dim(field), field%mesh%shape%ngi) :: quad_grad + meshshape=>face_shape(field, face_number) + assert(meshshape%loc==shape%loc) - integer :: i + quad_val=tensormul(face_val(field, face_number), shape%n) - do i=1, mesh_dim(field) - quad_grad(i,:)=matmul(ele_val(field, ele_number),dn(:,:,i)) - end do + end function face_val_at_shape_quad_tensor - end function ele_grad_at_quad_scalar + function ele_grad_at_quad_scalar(field, ele_number, dn) result (quad_grad) + ! Return the grad of field at the quadrature points of + ! ele_number. dn is the transformed element gradient. + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field,ele_number), & + & ele_ngi(field,ele_number),& + & mesh_dim(field)), intent(in) :: dn + real, dimension(mesh_dim(field), field%mesh%shape%ngi) :: quad_grad - function ele_grad_at_quad_vector(field, ele_number, dn) result (quad_grad) - ! Return the grad of field at the quadrature points of - ! ele_number. dn is the transformed element gradient. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field,ele_number), & - & ele_ngi(field,ele_number),& - & mesh_dim(field)), intent(in) :: dn - real, dimension(mesh_dim(field), field%dim, & - & field%mesh%shape%ngi) :: quad_grad + integer :: i - integer :: i, j + do i=1, mesh_dim(field) + quad_grad(i,:)=matmul(ele_val(field, ele_number),dn(:,:,i)) + end do - do i=1, mesh_dim(field) - do j=1, mesh_dim(field) - quad_grad(i,j,:)=matmul(ele_val(field, j, ele_number),dn(:,:,i)) - end do - end do + end function ele_grad_at_quad_scalar + + function ele_grad_at_quad_vector(field, ele_number, dn) result (quad_grad) + ! Return the grad of field at the quadrature points of + ! ele_number. dn is the transformed element gradient. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field,ele_number), & + & ele_ngi(field,ele_number),& + & mesh_dim(field)), intent(in) :: dn + real, dimension(mesh_dim(field), field%dim, & + & field%mesh%shape%ngi) :: quad_grad + + integer :: i, j + + do i=1, mesh_dim(field) + do j=1, mesh_dim(field) + quad_grad(i,j,:)=matmul(ele_val(field, j, ele_number),dn(:,:,i)) + end do + end do - end function ele_grad_at_quad_vector + end function ele_grad_at_quad_vector - function ele_div_at_quad_tensor(field, ele_number, dn) result (quad_div) - ! Return the grad of field (dtensor_{ij}/dx_{j}) at the quadrature points of - ! ele_number. dn is the transformed element gradient. - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field,ele_number), & - & ele_ngi(field,ele_number),& - & mesh_dim(field)), intent(in) :: dn - real, dimension(mesh_dim(field), field%mesh%shape%ngi) :: quad_div + function ele_div_at_quad_tensor(field, ele_number, dn) result (quad_div) + ! Return the grad of field (dtensor_{ij}/dx_{j}) at the quadrature points of + ! ele_number. dn is the transformed element gradient. + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field,ele_number), & + & ele_ngi(field,ele_number),& + & mesh_dim(field)), intent(in) :: dn + real, dimension(mesh_dim(field), field%mesh%shape%ngi) :: quad_div - integer :: i, j - real, dimension(field%dim(1), field%dim(2), ele_loc(field, ele_number)) :: tensor + integer :: i, j + real, dimension(field%dim(1), field%dim(2), ele_loc(field, ele_number)) :: tensor - tensor = ele_val(field, ele_number) - quad_div = 0.0 + tensor = ele_val(field, ele_number) + quad_div = 0.0 - do i=1,mesh_dim(field) - do j=1,mesh_dim(field) - quad_div(i,:) = quad_div(i,:) + matmul(tensor(i,j,:), dn(:,:,j)) + do i=1,mesh_dim(field) + do j=1,mesh_dim(field) + quad_div(i,:) = quad_div(i,:) + matmul(tensor(i,j,:), dn(:,:,j)) + end do end do - end do - end function ele_div_at_quad_tensor + end function ele_div_at_quad_tensor - function ele_div_at_quad(field, ele_number, dn) result (quad_div) - ! Return the divergence of field at the quadrature points of - ! ele_number. dn is the transformed element gradient. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field,ele_number), & - & ele_ngi(field,ele_number),& - & field%dim), intent(in) :: dn - real, dimension(field%mesh%shape%ngi) :: quad_div + function ele_div_at_quad(field, ele_number, dn) result (quad_div) + ! Return the divergence of field at the quadrature points of + ! ele_number. dn is the transformed element gradient. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field,ele_number), & + & ele_ngi(field,ele_number),& + & field%dim), intent(in) :: dn + real, dimension(field%mesh%shape%ngi) :: quad_div - integer :: i + integer :: i - quad_div=0.0 + quad_div=0.0 - do i=1,field%dim - quad_div=quad_div+matmul(ele_val(field, i, ele_number),dn(:,:,i)) - end do + do i=1,field%dim + quad_div=quad_div+matmul(ele_val(field, i, ele_number),dn(:,:,i)) + end do - end function ele_div_at_quad + end function ele_div_at_quad - function ele_2d_curl_at_quad(field, ele_number, dn) result(quad_curl) - ! Return the 2D curl of field at the quadrature points of ele_number. dn is - ! the transformed element gradient. + function ele_2d_curl_at_quad(field, ele_number, dn) result(quad_curl) + ! Return the 2D curl of field at the quadrature points of ele_number. dn is + ! the transformed element gradient. - type(vector_field), intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field, ele_number), ele_ngi(field, ele_number), field%dim), intent(in) :: dn + type(vector_field), intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field, ele_number), ele_ngi(field, ele_number), field%dim), intent(in) :: dn - real, dimension(ele_ngi(field, ele_number)) :: quad_curl + real, dimension(ele_ngi(field, ele_number)) :: quad_curl - assert(field%dim == 2) + assert(field%dim == 2) - quad_curl = matmul(ele_val(field, 2, ele_number), dn(:, :, 1)) - matmul(ele_val(field, 1, ele_number), dn(:, :, 2)) + quad_curl = matmul(ele_val(field, 2, ele_number), dn(:, :, 1)) - matmul(ele_val(field, 1, ele_number), dn(:, :, 2)) - end function ele_2d_curl_at_quad + end function ele_2d_curl_at_quad - function ele_curl_at_quad(field, ele_number, dn) result (quad_curl) - ! Return the 3D curl of field at the quadrature points of - ! ele_number. dn is the transformed element gradient. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field,ele_number), & - & ele_ngi(field,ele_number), & - & field%dim), intent(in) :: dn - real, dimension(3, ele_ngi(field, ele_number)) :: quad_curl + function ele_curl_at_quad(field, ele_number, dn) result (quad_curl) + ! Return the 3D curl of field at the quadrature points of + ! ele_number. dn is the transformed element gradient. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field,ele_number), & + & ele_ngi(field,ele_number), & + & field%dim), intent(in) :: dn + real, dimension(3, ele_ngi(field, ele_number)) :: quad_curl - integer :: i + integer :: i - assert(field%dim == 3) + assert(field%dim == 3) - do i = 1, field%dim - quad_curl(i, :) = & + do i = 1, field%dim + quad_curl(i, :) = & & matmul(ele_val(field, rot3(i, 2), ele_number), & & dn(:, :, rot3(i, 1))) - & & matmul(ele_val(field, rot3(i, 1), ele_number), & & dn(:, :, rot3(i, 2))) - end do - - contains - - function rot3(i, di) - !! Rotate i di places in (1,2,3) - - integer, intent(in) :: i, di - integer :: rot3 - - rot3 = mod(i + di - 1, 3) + 1 - - end function rot3 - - end function ele_curl_at_quad - - function ele_jacobian_at_quad(field, ele_number, dn) result (quad_J) - ! Return the Jacobian matrix of field at the quadrature points of - ! ele_number. dn is the transformed element gradient. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(ele_loc(field,ele_number), & - & ele_ngi(field,ele_number),& - & field%dim), intent(in) :: dn - real, dimension(field%dim, field%dim, field%mesh%shape%ngi) :: quad_J - - integer :: i, j - - quad_J=0.0 - - do i=1, field%dim - do j=1, field%dim - quad_J(i,j,:)=matmul(ele_val(field, ele_number, i),dn(:,:,j)) - end do - end do - - end function ele_jacobian_at_quad - - function node_val_scalar(field, node_number) result (val) - ! Return the value of field at node node_number - type(scalar_field),intent(in) :: field - integer, intent(in) :: node_number - real :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val=field%val(node_number) - case(FIELD_TYPE_CONSTANT) - val=field%val(1) - case(FIELD_TYPE_PYTHON) - call val_python - end select - - contains - - subroutine val_python - !!< This subroutine isolates the following stack variables from the - !!< main code path. - real, dimension(field%py_dim, 1) :: pos - real, dimension(field%py_dim, field%py_positions_shape%loc) :: tmp_pos - real, dimension(field%py_dim, field%mesh%shape%loc) :: tmp_pos_2 - real, dimension(1) :: tmp_val - integer :: i, ele, loccoord - - assert(associated(field%mesh%adj_lists)) - if (.not. associated(field%mesh%adj_lists%nelist)) then - ewrite(-1,*) "nelist not initialised. I could allocate it myself," - ewrite(-1,*) "but you're probably calling this a lot." - ewrite(-1,*) " call add_nelist(mesh) first" - FLAbort("Call add_nelist(mesh) before calling val_python.") - end if + end do - if (.not. field%py_positions_same_mesh) then - ele = field%mesh%adj_lists%nelist%colm(field%mesh%adj_lists%nelist%findrm(node_number)) - loccoord = local_coords(field%mesh, ele, node_number) - tmp_pos = ele_val(field%py_positions, ele) - do i=1,field%py_dim - tmp_pos_2(i, :) = matmul(field%py_locweight, tmp_pos(i, :)) - end do - pos(:, 1) = tmp_pos_2(:, loccoord) - else - do i=1,field%py_dim - pos(i, 1) = field%py_positions%val(i,node_number) - end do - end if + contains - call set_from_python_function(tmp_val, trim(field%py_func), pos, & - time=current_time) - val = tmp_val(1) + function rot3(i, di) + !! Rotate i di places in (1,2,3) - end subroutine val_python + integer, intent(in) :: i, di + integer :: rot3 - end function node_val_scalar + rot3 = mod(i + di - 1, 3) + 1 - pure function node_val_vector(field, node_number) result (val) - ! Return the value of field at node node_number - type(vector_field),intent(in) :: field - integer, intent(in) :: node_number - real, dimension(field%dim) :: val + end function rot3 - integer :: i + end function ele_curl_at_quad - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i=1,field%dim - val(i)=field%val(i,node_number) - end do - case(FIELD_TYPE_CONSTANT) - do i=1,field%dim - val(i)=field%val(i,1) - end do - end select - - end function node_val_vector - - pure function node_val_tensor(field, node_number) result (val) - ! Return the value of field at node node_number - type(tensor_field),intent(in) :: field - integer, intent(in) :: node_number - real, dimension(field%dim(1), field%dim(2)) :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val=field%val(:,:,node_number) - case(FIELD_TYPE_CONSTANT) - val=field%val(:,:,1) - end select - - end function node_val_tensor - - pure function node_val_tensor_dim_dim(field, dim1, dim2, node_number) result (val) - ! Return the value of field at node node_number - type(tensor_field),intent(in) :: field - integer, intent(in) :: node_number - integer, intent(in) :: dim1, dim2 - real :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val=field%val(dim1,dim2,node_number) - case(FIELD_TYPE_CONSTANT) - val=field%val(dim1,dim2,1) - end select - - end function node_val_tensor_dim_dim - - pure function node_val_tensor_dim_dim_v(field, dim1, dim2, node_numbers) result (val) - ! Return the value of field at nodes node_numbers - type(tensor_field),intent(in) :: field - integer, dimension(:), intent(in) :: node_numbers - integer, intent(in) :: dim1, dim2 - real, dimension(size(node_numbers)) :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val=field%val(dim1,dim2,node_numbers) - case(FIELD_TYPE_CONSTANT) - val=field%val(dim1,dim2,1) - end select - - end function node_val_tensor_dim_dim_v - - pure function node_val_scalar_v(field, node_numbers) result (val) - ! Return the value of field at node node_numbers - type(scalar_field),intent(in) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(size(node_numbers)) :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val=field%val(node_numbers) - case(FIELD_TYPE_CONSTANT) - val=field%val(1) - end select - - end function node_val_scalar_v - - pure function node_val_vector_v(field, node_numbers) result (val) - ! Return the value of field at node node_numbers - type(vector_field),intent(in) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(field%dim, size(node_numbers)) :: val - - integer :: i - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i=1,field%dim - val(i,:)=field%val(i,node_numbers) - end do - case(FIELD_TYPE_CONSTANT) - do i=1,field%dim - val(i,:)=field%val(i,1) - end do - end select - - end function node_val_vector_v - - pure function node_val_vector_dim(field, dim, node_number) & - result (val) - ! Return the value of field at node node_numbers - type(vector_field),intent(in) :: field - integer, intent(in) :: node_number - integer, intent(in) :: dim - real :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val = field%val(dim,node_number) - case(FIELD_TYPE_CONSTANT) - val = field%val(dim,1) - end select - - end function node_val_vector_dim - - pure function node_val_vector_dim_v(field, dim, node_numbers) & - result (val) - ! Return the value of field at node node_numbers - type(vector_field),intent(in) :: field - integer, dimension(:), intent(in) :: node_numbers - integer, intent(in) :: dim - real, dimension(size(node_numbers)) :: val - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val(:)=field%val(dim,node_numbers) - case(FIELD_TYPE_CONSTANT) - val=field%val(dim,1) - end select - - end function node_val_vector_dim_v - - pure function node_val_tensor_v(field, node_numbers) result (val) - ! Return the value of field at node node_numbers - type(tensor_field),intent(in) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(field%dim(1), field%dim(2), size(node_numbers)) :: val - integer :: i - - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val=field%val(:,:,node_numbers) - case(FIELD_TYPE_CONSTANT) - do i=1,size(node_numbers) - val(:, :, i)=field%val(:, :, 1) + function ele_jacobian_at_quad(field, ele_number, dn) result (quad_J) + ! Return the Jacobian matrix of field at the quadrature points of + ! ele_number. dn is the transformed element gradient. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(ele_loc(field,ele_number), & + & ele_ngi(field,ele_number),& + & field%dim), intent(in) :: dn + real, dimension(field%dim, field%dim, field%mesh%shape%ngi) :: quad_J + + integer :: i, j + + quad_J=0.0 + + do i=1, field%dim + do j=1, field%dim + quad_J(i,j,:)=matmul(ele_val(field, ele_number, i),dn(:,:,j)) + end do end do - end select - end function node_val_tensor_v + end function ele_jacobian_at_quad + + function node_val_scalar(field, node_number) result (val) + ! Return the value of field at node node_number + type(scalar_field),intent(in) :: field + integer, intent(in) :: node_number + real :: val + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val=field%val(node_number) + case(FIELD_TYPE_CONSTANT) + val=field%val(1) + case(FIELD_TYPE_PYTHON) + call val_python + end select + + contains + + subroutine val_python + !!< This subroutine isolates the following stack variables from the + !!< main code path. + real, dimension(field%py_dim, 1) :: pos + real, dimension(field%py_dim, field%py_positions_shape%loc) :: tmp_pos + real, dimension(field%py_dim, field%mesh%shape%loc) :: tmp_pos_2 + real, dimension(1) :: tmp_val + integer :: i, ele, loccoord + + assert(associated(field%mesh%adj_lists)) + if (.not. associated(field%mesh%adj_lists%nelist)) then + ewrite(-1,*) "nelist not initialised. I could allocate it myself," + ewrite(-1,*) "but you're probably calling this a lot." + ewrite(-1,*) " call add_nelist(mesh) first" + FLAbort("Call add_nelist(mesh) before calling val_python.") + end if + + if (.not. field%py_positions_same_mesh) then + ele = field%mesh%adj_lists%nelist%colm(field%mesh%adj_lists%nelist%findrm(node_number)) + loccoord = local_coords(field%mesh, ele, node_number) + tmp_pos = ele_val(field%py_positions, ele) + do i=1,field%py_dim + tmp_pos_2(i, :) = matmul(field%py_locweight, tmp_pos(i, :)) + end do + pos(:, 1) = tmp_pos_2(:, loccoord) + else + do i=1,field%py_dim + pos(i, 1) = field%py_positions%val(i,node_number) + end do + end if + + call set_from_python_function(tmp_val, trim(field%py_func), pos, & + time=current_time) + val = tmp_val(1) + + end subroutine val_python + + end function node_val_scalar + + pure function node_val_vector(field, node_number) result (val) + ! Return the value of field at node node_number + type(vector_field),intent(in) :: field + integer, intent(in) :: node_number + real, dimension(field%dim) :: val + + integer :: i + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i=1,field%dim + val(i)=field%val(i,node_number) + end do + case(FIELD_TYPE_CONSTANT) + do i=1,field%dim + val(i)=field%val(i,1) + end do + end select + + end function node_val_vector + + pure function node_val_tensor(field, node_number) result (val) + ! Return the value of field at node node_number + type(tensor_field),intent(in) :: field + integer, intent(in) :: node_number + real, dimension(field%dim(1), field%dim(2)) :: val + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val=field%val(:,:,node_number) + case(FIELD_TYPE_CONSTANT) + val=field%val(:,:,1) + end select + + end function node_val_tensor + + pure function node_val_tensor_dim_dim(field, dim1, dim2, node_number) result (val) + ! Return the value of field at node node_number + type(tensor_field),intent(in) :: field + integer, intent(in) :: node_number + integer, intent(in) :: dim1, dim2 + real :: val - function continuity_mesh(mesh) result (continuity) - ! Return the degree of continuity of mesh. - integer :: continuity - type(mesh_type), intent(in) :: mesh + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val=field%val(dim1,dim2,node_number) + case(FIELD_TYPE_CONSTANT) + val=field%val(dim1,dim2,1) + end select + + end function node_val_tensor_dim_dim - continuity=mesh%continuity + pure function node_val_tensor_dim_dim_v(field, dim1, dim2, node_numbers) result (val) + ! Return the value of field at nodes node_numbers + type(tensor_field),intent(in) :: field + integer, dimension(:), intent(in) :: node_numbers + integer, intent(in) :: dim1, dim2 + real, dimension(size(node_numbers)) :: val - end function continuity_mesh + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val=field%val(dim1,dim2,node_numbers) + case(FIELD_TYPE_CONSTANT) + val=field%val(dim1,dim2,1) + end select - function continuity_scalar(field) result (continuity) - ! Return the degree of continuity of mesh. - integer :: continuity - type(scalar_field), intent(in) :: field + end function node_val_tensor_dim_dim_v - continuity=field%mesh%continuity + pure function node_val_scalar_v(field, node_numbers) result (val) + ! Return the value of field at node node_numbers + type(scalar_field),intent(in) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(size(node_numbers)) :: val - end function continuity_scalar + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val=field%val(node_numbers) + case(FIELD_TYPE_CONSTANT) + val=field%val(1) + end select - function continuity_vector(field) result (continuity) - ! Return the degree of continuity of mesh. - integer :: continuity - type(vector_field), intent(in) :: field + end function node_val_scalar_v + + pure function node_val_vector_v(field, node_numbers) result (val) + ! Return the value of field at node node_numbers + type(vector_field),intent(in) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(field%dim, size(node_numbers)) :: val + + integer :: i + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i=1,field%dim + val(i,:)=field%val(i,node_numbers) + end do + case(FIELD_TYPE_CONSTANT) + do i=1,field%dim + val(i,:)=field%val(i,1) + end do + end select - continuity=field%mesh%continuity + end function node_val_vector_v + + pure function node_val_vector_dim(field, dim, node_number) & + result (val) + ! Return the value of field at node node_numbers + type(vector_field),intent(in) :: field + integer, intent(in) :: node_number + integer, intent(in) :: dim + real :: val + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val = field%val(dim,node_number) + case(FIELD_TYPE_CONSTANT) + val = field%val(dim,1) + end select - end function continuity_vector + end function node_val_vector_dim + + pure function node_val_vector_dim_v(field, dim, node_numbers) & + result (val) + ! Return the value of field at node node_numbers + type(vector_field),intent(in) :: field + integer, dimension(:), intent(in) :: node_numbers + integer, intent(in) :: dim + real, dimension(size(node_numbers)) :: val + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val(:)=field%val(dim,node_numbers) + case(FIELD_TYPE_CONSTANT) + val=field%val(dim,1) + end select - function continuity_tensor(field) result (continuity) - ! Return the degree of continuity of mesh. - integer :: continuity - type(tensor_field), intent(in) :: field + end function node_val_vector_dim_v - continuity=field%mesh%continuity + pure function node_val_tensor_v(field, node_numbers) result (val) + ! Return the value of field at node node_numbers + type(tensor_field),intent(in) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(field%dim(1), field%dim(2), size(node_numbers)) :: val + integer :: i - end function continuity_tensor - function element_degree_mesh(mesh, ele_number) result (element_degree) - ! Return the polynomial degree of the shape function for this element of the mesh. - integer :: element_degree - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele_number + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val=field%val(:,:,node_numbers) + case(FIELD_TYPE_CONSTANT) + do i=1,size(node_numbers) + val(:, :, i)=field%val(:, :, 1) + end do + end select - element_degree=mesh%shape%degree + end function node_val_tensor_v - end function element_degree_mesh + function continuity_mesh(mesh) result (continuity) + ! Return the degree of continuity of mesh. + integer :: continuity + type(mesh_type), intent(in) :: mesh - function element_degree_scalar(field, ele_number) result (element_degree) - ! Return the polynomial degree of the shape function for this element of the field. - integer :: element_degree - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele_number + continuity=mesh%continuity - element_degree=field%mesh%shape%degree + end function continuity_mesh - end function element_degree_scalar + function continuity_scalar(field) result (continuity) + ! Return the degree of continuity of mesh. + integer :: continuity + type(scalar_field), intent(in) :: field - function element_degree_vector(field, ele_number) result (element_degree) - ! Return the polynomial degree of the shape function for this element of the field. - integer :: element_degree - type(vector_field), intent(in) :: field - integer, intent(in) :: ele_number + continuity=field%mesh%continuity - element_degree=field%mesh%shape%degree + end function continuity_scalar - end function element_degree_vector + function continuity_vector(field) result (continuity) + ! Return the degree of continuity of mesh. + integer :: continuity + type(vector_field), intent(in) :: field - function element_degree_tensor(field, ele_number) result (element_degree) - ! Return the polynomial degree of the shape function for this element of the field. - integer :: element_degree - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele_number + continuity=field%mesh%continuity - element_degree=field%mesh%shape%degree + end function continuity_vector - end function element_degree_tensor + function continuity_tensor(field) result (continuity) + ! Return the degree of continuity of mesh. + integer :: continuity + type(tensor_field), intent(in) :: field - function has_faces_mesh(mesh) result (has_faces) - ! Check whether the faces component of mesh has been calculated. - logical :: has_faces - type(mesh_type), intent(in) :: mesh + continuity=field%mesh%continuity - has_faces=associated(mesh%faces) + end function continuity_tensor - end function has_faces_mesh + function element_degree_mesh(mesh, ele_number) result (element_degree) + ! Return the polynomial degree of the shape function for this element of the mesh. + integer :: element_degree + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele_number - function extract_scalar_field_from_vector_field(vfield, dim, stat) result(sfield) - !!< This function gives you a way to treat a vector field - !!< as a union of scalar fields. + element_degree=mesh%shape%degree - type(vector_field), intent(in), target :: vfield - integer, intent(in) :: dim - type(scalar_field) :: sfield - integer, intent(out), optional :: stat + end function element_degree_mesh - if (present(stat)) then - stat = 0 - if (dim > vfield%dim) then - stat = 1 - return + function element_degree_scalar(field, ele_number) result (element_degree) + ! Return the polynomial degree of the shape function for this element of the field. + integer :: element_degree + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele_number + + element_degree=field%mesh%shape%degree + + end function element_degree_scalar + + function element_degree_vector(field, ele_number) result (element_degree) + ! Return the polynomial degree of the shape function for this element of the field. + integer :: element_degree + type(vector_field), intent(in) :: field + integer, intent(in) :: ele_number + + element_degree=field%mesh%shape%degree + + end function element_degree_vector + + function element_degree_tensor(field, ele_number) result (element_degree) + ! Return the polynomial degree of the shape function for this element of the field. + integer :: element_degree + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele_number + + element_degree=field%mesh%shape%degree + + end function element_degree_tensor + + function has_faces_mesh(mesh) result (has_faces) + ! Check whether the faces component of mesh has been calculated. + logical :: has_faces + type(mesh_type), intent(in) :: mesh + + has_faces=associated(mesh%faces) + + end function has_faces_mesh + + function extract_scalar_field_from_vector_field(vfield, dim, stat) result(sfield) + !!< This function gives you a way to treat a vector field + !!< as a union of scalar fields. + + type(vector_field), intent(in), target :: vfield + integer, intent(in) :: dim + type(scalar_field) :: sfield + integer, intent(out), optional :: stat + + if (present(stat)) then + stat = 0 + if (dim > vfield%dim) then + stat = 1 + return + end if end if - end if - assert(dim .le. vfield%dim) - - ! Note that the reference count is not incremented as this is a - ! borrowed field reference. - sfield%mesh = vfield%mesh - sfield%val => vfield%val(dim,:) - sfield%val_stride = vfield%dim - sfield%option_path = vfield%option_path - sfield%field_type = vfield%field_type - write(sfield%name, '(a, i0)') trim(vfield%name) // "%", dim - - ! FIXME: make these the same as the vector field - sfield%py_dim = mesh_dim(vfield%mesh) - sfield%py_positions_shape => vfield%mesh%shape - - sfield%refcount => vfield%refcount - - end function extract_scalar_field_from_vector_field - - function extract_scalar_field_from_tensor_field(tfield, dim1, dim2, stat) result(sfield) - !!< This function gives you a way to treat a tensor field - !!< as a union of scalar fields. - - type(tensor_field), intent(in) :: tfield - integer, intent(in) :: dim1, dim2 - type(scalar_field) :: sfield - integer, intent(out), optional :: stat - - if (present(stat)) then - stat = 0 - if (dim1 > tfield%dim(1) .or. dim2 > tfield%dim(2)) then - stat = 1 - return + assert(dim .le. vfield%dim) + + ! Note that the reference count is not incremented as this is a + ! borrowed field reference. + sfield%mesh = vfield%mesh + sfield%val => vfield%val(dim,:) + sfield%val_stride = vfield%dim + sfield%option_path = vfield%option_path + sfield%field_type = vfield%field_type + write(sfield%name, '(a, i0)') trim(vfield%name) // "%", dim + + ! FIXME: make these the same as the vector field + sfield%py_dim = mesh_dim(vfield%mesh) + sfield%py_positions_shape => vfield%mesh%shape + + sfield%refcount => vfield%refcount + + end function extract_scalar_field_from_vector_field + + function extract_scalar_field_from_tensor_field(tfield, dim1, dim2, stat) result(sfield) + !!< This function gives you a way to treat a tensor field + !!< as a union of scalar fields. + + type(tensor_field), intent(in) :: tfield + integer, intent(in) :: dim1, dim2 + type(scalar_field) :: sfield + integer, intent(out), optional :: stat + + if (present(stat)) then + stat = 0 + if (dim1 > tfield%dim(1) .or. dim2 > tfield%dim(2)) then + stat = 1 + return + end if end if - end if - assert(dim1 .le. tfield%dim(1)) - assert(dim2 .le. tfield%dim(2)) + assert(dim1 .le. tfield%dim(1)) + assert(dim2 .le. tfield%dim(2)) - ! Note that the reference count is not incremented as this is a - ! borrowed field reference. - sfield%mesh = tfield%mesh - sfield%val => tfield%val(dim1, dim2, :) - sfield%val_stride = tfield%dim(1) * tfield%dim(2) - sfield%option_path = tfield%option_path - sfield%field_type = tfield%field_type - write(sfield%name, '(a, 2i0)') trim(tfield%name) // "%", (dim1-1) * tfield%dim + dim2 + ! Note that the reference count is not incremented as this is a + ! borrowed field reference. + sfield%mesh = tfield%mesh + sfield%val => tfield%val(dim1, dim2, :) + sfield%val_stride = tfield%dim(1) * tfield%dim(2) + sfield%option_path = tfield%option_path + sfield%field_type = tfield%field_type + write(sfield%name, '(a, 2i0)') trim(tfield%name) // "%", (dim1-1) * tfield%dim + dim2 - sfield%refcount => tfield%refcount - end function extract_scalar_field_from_tensor_field + sfield%refcount => tfield%refcount + end function extract_scalar_field_from_tensor_field - function ele_val_at_superconvergent_scalar(field, ele_number) result (superconvergent_val) - ! Return the values of field at the superconvergent points of ele_number. - type(scalar_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%mesh%shape%superconvergence%nsp) :: superconvergent_val + function ele_val_at_superconvergent_scalar(field, ele_number) result (superconvergent_val) + ! Return the values of field at the superconvergent points of ele_number. + type(scalar_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%mesh%shape%superconvergence%nsp) :: superconvergent_val - type(element_type), pointer :: shape + type(element_type), pointer :: shape - shape=>ele_shape(field,ele_number) + shape=>ele_shape(field,ele_number) - superconvergent_val=matmul(ele_val(field, ele_number), shape%superconvergence%n) + superconvergent_val=matmul(ele_val(field, ele_number), shape%superconvergence%n) - end function ele_val_at_superconvergent_scalar + end function ele_val_at_superconvergent_scalar - function ele_val_at_superconvergent_vector(field, ele_number) result (superconvergent_val) - ! Return the values of field at the superconvergent points of ele_number. - type(vector_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%dim, field%mesh%shape%superconvergence%nsp) :: superconvergent_val + function ele_val_at_superconvergent_vector(field, ele_number) result (superconvergent_val) + ! Return the values of field at the superconvergent points of ele_number. + type(vector_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%dim, field%mesh%shape%superconvergence%nsp) :: superconvergent_val - type(element_type), pointer :: shape + type(element_type), pointer :: shape - shape=>ele_shape(field,ele_number) + shape=>ele_shape(field,ele_number) - superconvergent_val=matmul(ele_val(field, ele_number), shape%superconvergence%n) + superconvergent_val=matmul(ele_val(field, ele_number), shape%superconvergence%n) - end function ele_val_at_superconvergent_vector + end function ele_val_at_superconvergent_vector - function ele_val_at_superconvergent_tensor(field, ele_number) result (superconvergent_val) - ! Return the values of field at the superconvergent points of ele_number. - type(tensor_field),intent(in) :: field - integer, intent(in) :: ele_number - real, dimension(field%dim(1), field%dim(2), & + function ele_val_at_superconvergent_tensor(field, ele_number) result (superconvergent_val) + ! Return the values of field at the superconvergent points of ele_number. + type(tensor_field),intent(in) :: field + integer, intent(in) :: ele_number + real, dimension(field%dim(1), field%dim(2), & field%mesh%shape%superconvergence%nsp) :: superconvergent_val - type(element_type), pointer :: shape + type(element_type), pointer :: shape - shape=>ele_shape(field,ele_number) + shape=>ele_shape(field,ele_number) - superconvergent_val=tensormul(ele_val(field, ele_number), shape%superconvergence%n) + superconvergent_val=tensormul(ele_val(field, ele_number), shape%superconvergence%n) - end function ele_val_at_superconvergent_tensor + end function ele_val_at_superconvergent_tensor - subroutine field2file_scalar(filename, field) - !!< Write the field values to filename. - character(len=*), intent(in) :: filename - type(scalar_field), intent(in) :: field + subroutine field2file_scalar(filename, field) + !!< Write the field values to filename. + character(len=*), intent(in) :: filename + type(scalar_field), intent(in) :: field - integer :: unit + integer :: unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - write(unit, "(g22.8e4)") field%val + write(unit, "(g22.8e4)") field%val - close(unit) + close(unit) - end subroutine field2file_scalar + end subroutine field2file_scalar - subroutine field2file_vector(filename, field) - !!< Write the field values to filename. - character(len=*), intent(in) :: filename - type(vector_field), intent(in) :: field + subroutine field2file_vector(filename, field) + !!< Write the field values to filename. + character(len=*), intent(in) :: filename + type(vector_field), intent(in) :: field - integer :: unit, d + integer :: unit, d - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - do d=1,field%dim - write(unit, "(g22.8e4)") field%val(d,:) - end do + do d=1,field%dim + write(unit, "(g22.8e4)") field%val(d,:) + end do - close(unit) + close(unit) - end subroutine field2file_vector + end subroutine field2file_vector - pure function halo_count_mesh(mesh) result(count) - type(mesh_type), intent(in) :: mesh + pure function halo_count_mesh(mesh) result(count) + type(mesh_type), intent(in) :: mesh - integer :: count + integer :: count - if(.not. associated(mesh%halos)) then - count = 0 - else - count = size(mesh%halos) - end if + if(.not. associated(mesh%halos)) then + count = 0 + else + count = size(mesh%halos) + end if - end function halo_count_mesh + end function halo_count_mesh - pure function halo_count_scalar(s_field) result(count) - type(scalar_field), intent(in) :: s_field + pure function halo_count_scalar(s_field) result(count) + type(scalar_field), intent(in) :: s_field - integer :: count + integer :: count - count = halo_count(s_field%mesh) + count = halo_count(s_field%mesh) - end function halo_count_scalar + end function halo_count_scalar - pure function halo_count_vector(v_field) result(count) - type(vector_field), intent(in) :: v_field + pure function halo_count_vector(v_field) result(count) + type(vector_field), intent(in) :: v_field - integer :: count + integer :: count - count = halo_count(v_field%mesh) + count = halo_count(v_field%mesh) - end function halo_count_vector + end function halo_count_vector - pure function halo_count_tensor(t_field) result(count) - type(tensor_field), intent(in) :: t_field + pure function halo_count_tensor(t_field) result(count) + type(tensor_field), intent(in) :: t_field - integer :: count + integer :: count - count = halo_count(t_field%mesh) + count = halo_count(t_field%mesh) - end function halo_count_tensor + end function halo_count_tensor - pure function element_halo_count_mesh(mesh) result(count) - type(mesh_type), intent(in) :: mesh + pure function element_halo_count_mesh(mesh) result(count) + type(mesh_type), intent(in) :: mesh - integer :: count + integer :: count - if(.not. associated(mesh%element_halos)) then - count = 0 - else - count = size(mesh%element_halos) - end if + if(.not. associated(mesh%element_halos)) then + count = 0 + else + count = size(mesh%element_halos) + end if - end function element_halo_count_mesh + end function element_halo_count_mesh - pure function element_halo_count_scalar(s_field) result(count) - type(scalar_field), intent(in) :: s_field + pure function element_halo_count_scalar(s_field) result(count) + type(scalar_field), intent(in) :: s_field - integer :: count + integer :: count - count = element_halo_count(s_field%mesh) + count = element_halo_count(s_field%mesh) - end function element_halo_count_scalar + end function element_halo_count_scalar - pure function element_halo_count_vector(v_field) result(count) - type(vector_field), intent(in) :: v_field + pure function element_halo_count_vector(v_field) result(count) + type(vector_field), intent(in) :: v_field - integer :: count + integer :: count - count = element_halo_count(v_field%mesh) + count = element_halo_count(v_field%mesh) - end function element_halo_count_vector + end function element_halo_count_vector - pure function element_halo_count_tensor(t_field) result(count) - type(tensor_field), intent(in) :: t_field + pure function element_halo_count_tensor(t_field) result(count) + type(tensor_field), intent(in) :: t_field - integer :: count + integer :: count - count = element_halo_count(t_field%mesh) + count = element_halo_count(t_field%mesh) - end function element_halo_count_tensor + end function element_halo_count_tensor - function face_vertices_shape(shape) result(vert) - type(element_type), intent(in) :: shape - integer :: vert + function face_vertices_shape(shape) result(vert) + type(element_type), intent(in) :: shape + integer :: vert - select case(shape%numbering%type) - case(ELEMENT_LAGRANGIAN, ELEMENT_BUBBLE, ELEMENT_TRACE) - select case(shape%numbering%family) - case (FAMILY_SIMPLEX) - vert = shape%dim - case (FAMILY_CUBE) - vert = 2**(shape%dim-1) - case default - FLAbort("Unknown element family.") + select case(shape%numbering%type) + case(ELEMENT_LAGRANGIAN, ELEMENT_BUBBLE, ELEMENT_TRACE) + select case(shape%numbering%family) + case (FAMILY_SIMPLEX) + vert = shape%dim + case (FAMILY_CUBE) + vert = 2**(shape%dim-1) + case default + FLAbort("Unknown element family.") + end select + case default + FLAbort("Unknown element type.") end select - case default - FLAbort("Unknown element type.") - end select - - end function face_vertices_shape - function local_coords_interpolation_all(position_field, ele, position) result(local_coords) - !!< Given a position field, this returns the local coordinates of a number - !!< of positions which respect to element "ele". - !!< - !!< This assumes the positions field is linear. For higher order - !!< only the coordinates of the vertices are considered - type(vector_field), intent(in) :: position_field - integer, intent(in) :: ele - real, dimension(:, :), intent(in) :: position - - real, dimension(size(position,1)+1, size(position, 2)) :: local_coords - - real, dimension(size(position,1)+1, size(position,1)+1) :: inversion_matrix - - assert(size(position, 1) == position_field%dim) - assert(position_field%mesh%shape%numbering%family==FAMILY_SIMPLEX) - assert(position_field%mesh%shape%numbering%type==ELEMENT_LAGRANGIAN) - - call local_coords_matrix(position_field, ele, inversion_matrix) - local_coords(1:position_field%dim, :) = position - local_coords(position_field%dim + 1, :) = 1.0 - local_coords = matmul(inversion_matrix, local_coords) - - end function local_coords_interpolation_all - - subroutine local_coords_matrix(positions, ele, mat) - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - real, dimension(:,:), intent(out) :: mat - - integer, dimension(positions%mesh%shape%numbering%vertices):: vertices - integer, dimension(:), pointer:: nodes - - assert( size(mat,1)==mesh_dim(positions)+1 ) - assert( size(mat,1)==size(mat,2) ) - - if (positions%mesh%shape%degree==1) then - mat(1:positions%dim, :) = ele_val(positions, ele) - else - nodes => ele_nodes(positions, ele) - vertices=local_vertices(positions%mesh%shape%numbering) - mat(1:positions%dim, :) = node_val(positions, nodes(vertices) ) - end if - mat(positions%dim + 1, :) = 1.0 - - call invert(mat) - - end subroutine local_coords_matrix - - function local_coords_scalar(field, ele, node, stat) result(local_coord) - !!< returns the local node number within a given element ele of the global - !!< node number node - type(scalar_field), intent(in) :: field - integer, intent(in) :: ele, node - integer, intent(inout), optional :: stat - integer :: local_coord - - local_coord = local_coords(field%mesh, ele, node, stat) - - end function local_coords_scalar - - function local_coords_vector(field, ele, node, stat) result(local_coord) - !!< returns the local node number within a given element ele of the global - !!< node number node - type(vector_field), intent(in) :: field - integer, intent(in) :: ele, node - integer, intent(inout), optional :: stat - integer :: local_coord - - local_coord = local_coords(field%mesh, ele, node, stat) - - end function local_coords_vector - - function local_coords_tensor(field, ele, node, stat) result(local_coord) - !!< returns the local node number within a given element ele of the global - !!< node number node - type(tensor_field), intent(in) :: field - integer, intent(in) :: ele, node - integer, intent(inout), optional :: stat - integer :: local_coord - - local_coord = local_coords(field%mesh, ele, node, stat) - - end function local_coords_tensor - - function local_coords_mesh(mesh, ele, node, stat) result(local_coord) - !!< returns the local node number within a given element ele of the global - !!< node number node - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele, node - integer, intent(inout), optional :: stat - integer :: local_coord - integer, dimension(:), pointer :: nodes - integer :: i - - if(present(stat)) stat = 0 - - local_coord = 0 - - nodes => ele_nodes(mesh, ele) - do i=1,size(nodes) - if (nodes(i) == node) then - local_coord = i - return + end function face_vertices_shape + + function local_coords_interpolation_all(position_field, ele, position) result(local_coords) + !!< Given a position field, this returns the local coordinates of a number + !!< of positions which respect to element "ele". + !!< + !!< This assumes the positions field is linear. For higher order + !!< only the coordinates of the vertices are considered + type(vector_field), intent(in) :: position_field + integer, intent(in) :: ele + real, dimension(:, :), intent(in) :: position + + real, dimension(size(position,1)+1, size(position, 2)) :: local_coords + + real, dimension(size(position,1)+1, size(position,1)+1) :: inversion_matrix + + assert(size(position, 1) == position_field%dim) + assert(position_field%mesh%shape%numbering%family==FAMILY_SIMPLEX) + assert(position_field%mesh%shape%numbering%type==ELEMENT_LAGRANGIAN) + + call local_coords_matrix(position_field, ele, inversion_matrix) + local_coords(1:position_field%dim, :) = position + local_coords(position_field%dim + 1, :) = 1.0 + local_coords = matmul(inversion_matrix, local_coords) + + end function local_coords_interpolation_all + + subroutine local_coords_matrix(positions, ele, mat) + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + real, dimension(:,:), intent(out) :: mat + + integer, dimension(positions%mesh%shape%numbering%vertices):: vertices + integer, dimension(:), pointer:: nodes + + assert( size(mat,1)==mesh_dim(positions)+1 ) + assert( size(mat,1)==size(mat,2) ) + + if (positions%mesh%shape%degree==1) then + mat(1:positions%dim, :) = ele_val(positions, ele) + else + nodes => ele_nodes(positions, ele) + vertices=local_vertices(positions%mesh%shape%numbering) + mat(1:positions%dim, :) = node_val(positions, nodes(vertices) ) end if - end do + mat(positions%dim + 1, :) = 1.0 - if(present(stat)) then - stat = 1 - else - FLAbort("Failed to find local coordinate.") - end if + call invert(mat) - end function local_coords_mesh + end subroutine local_coords_matrix - function field_val_scalar(field) result(val) - type(scalar_field), intent(in) :: field - real, dimension(:), pointer :: val + function local_coords_scalar(field, ele, node, stat) result(local_coord) + !!< returns the local node number within a given element ele of the global + !!< node number node + type(scalar_field), intent(in) :: field + integer, intent(in) :: ele, node + integer, intent(inout), optional :: stat + integer :: local_coord - val => null() + local_coord = local_coords(field%mesh, ele, node, stat) - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val => field%val - return - case(FIELD_TYPE_CONSTANT) - FLAbort("Trying to pass around the value space of a constant field") - case(FIELD_TYPE_PYTHON) - FLAbort("Trying to pass around the value space of a pythonic field") - end select - end function field_val_scalar - - function field_val_vector(field, dim) result(val) - type(vector_field), intent(in) :: field - integer, intent(in) :: dim - real, dimension(:), pointer :: val - - val => null() - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - val => field%val(dim,:) - return - case(FIELD_TYPE_CONSTANT) - FLAbort("Trying to pass around the value space of a constant field") - case(FIELD_TYPE_PYTHON) - FLAbort("Trying to pass around the value space of a pythonic field") - end select - end function field_val_vector + end function local_coords_scalar + + function local_coords_vector(field, ele, node, stat) result(local_coord) + !!< returns the local node number within a given element ele of the global + !!< node number node + type(vector_field), intent(in) :: field + integer, intent(in) :: ele, node + integer, intent(inout), optional :: stat + integer :: local_coord + + local_coord = local_coords(field%mesh, ele, node, stat) + + end function local_coords_vector + + function local_coords_tensor(field, ele, node, stat) result(local_coord) + !!< returns the local node number within a given element ele of the global + !!< node number node + type(tensor_field), intent(in) :: field + integer, intent(in) :: ele, node + integer, intent(inout), optional :: stat + integer :: local_coord + + local_coord = local_coords(field%mesh, ele, node, stat) + + end function local_coords_tensor + + function local_coords_mesh(mesh, ele, node, stat) result(local_coord) + !!< returns the local node number within a given element ele of the global + !!< node number node + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele, node + integer, intent(inout), optional :: stat + integer :: local_coord + integer, dimension(:), pointer :: nodes + integer :: i + + if(present(stat)) stat = 0 + + local_coord = 0 + + nodes => ele_nodes(mesh, ele) + do i=1,size(nodes) + if (nodes(i) == node) then + local_coord = i + return + end if + end do + + if(present(stat)) then + stat = 1 + else + FLAbort("Failed to find local coordinate.") + end if + + end function local_coords_mesh + + function field_val_scalar(field) result(val) + type(scalar_field), intent(in) :: field + real, dimension(:), pointer :: val + + val => null() + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val => field%val + return + case(FIELD_TYPE_CONSTANT) + FLAbort("Trying to pass around the value space of a constant field") + case(FIELD_TYPE_PYTHON) + FLAbort("Trying to pass around the value space of a pythonic field") + end select + end function field_val_scalar + + function field_val_vector(field, dim) result(val) + type(vector_field), intent(in) :: field + integer, intent(in) :: dim + real, dimension(:), pointer :: val + + val => null() + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + val => field%val(dim,:) + return + case(FIELD_TYPE_CONSTANT) + FLAbort("Trying to pass around the value space of a constant field") + case(FIELD_TYPE_PYTHON) + FLAbort("Trying to pass around the value space of a pythonic field") + end select + end function field_val_vector - function eval_field_scalar(ele, s_field, local_coord) result(val) - !!< Evaluate the scalar field s_field at element local coordinate - !!< local_coord of element ele. + function eval_field_scalar(ele, s_field, local_coord) result(val) + !!< Evaluate the scalar field s_field at element local coordinate + !!< local_coord of element ele. - integer, intent(in) :: ele - type(scalar_field), intent(in) :: s_field - real, dimension(:), intent(in) :: local_coord - real :: val + integer, intent(in) :: ele + type(scalar_field), intent(in) :: s_field + real, dimension(:), intent(in) :: local_coord + real :: val - val = dot_product(ele_val(s_field, ele), & - eval_shape(ele_shape(s_field, ele), local_coord)) + val = dot_product(ele_val(s_field, ele), & + eval_shape(ele_shape(s_field, ele), local_coord)) - end function eval_field_scalar + end function eval_field_scalar - function eval_field_vector(ele, v_field, local_coord) result(val) - !!< Evaluate the vector field v_field at element local coordinate - !!< local_coord of element ele. + function eval_field_vector(ele, v_field, local_coord) result(val) + !!< Evaluate the vector field v_field at element local coordinate + !!< local_coord of element ele. - integer, intent(in) :: ele - type(vector_field), intent(in) :: v_field - real, dimension(:), intent(in) :: local_coord - real, dimension(v_field%dim) :: val + integer, intent(in) :: ele + type(vector_field), intent(in) :: v_field + real, dimension(:), intent(in) :: local_coord + real, dimension(v_field%dim) :: val - val = matmul(ele_val(v_field, ele), & - eval_shape(ele_shape(v_field, ele), local_coord)) + val = matmul(ele_val(v_field, ele), & + eval_shape(ele_shape(v_field, ele), local_coord)) - end function eval_field_vector + end function eval_field_vector - function eval_field_tensor(ele, t_field, local_coord) result(val) - !!< Evaluate the tensor field t_field at element local coordinate - !!< local_coord of element ele. + function eval_field_tensor(ele, t_field, local_coord) result(val) + !!< Evaluate the tensor field t_field at element local coordinate + !!< local_coord of element ele. - integer, intent(in) :: ele - type(tensor_field), intent(in) :: t_field - real, dimension(:), intent(in) :: local_coord - real, dimension(t_field%dim(1), t_field%dim(2)) :: val + integer, intent(in) :: ele + type(tensor_field), intent(in) :: t_field + real, dimension(:), intent(in) :: local_coord + real, dimension(t_field%dim(1), t_field%dim(2)) :: val - integer :: i - real, dimension(t_field%dim(1), t_field%dim(2), ele_loc(t_field, ele)) :: ele_values - real, dimension(ele_loc(t_field, ele)) :: n + integer :: i + real, dimension(t_field%dim(1), t_field%dim(2), ele_loc(t_field, ele)) :: ele_values + real, dimension(ele_loc(t_field, ele)) :: n - n = eval_shape(ele_shape(t_field, ele), local_coord) - ele_values = ele_val(t_field, ele) + n = eval_shape(ele_shape(t_field, ele), local_coord) + ele_values = ele_val(t_field, ele) - do i=1, size(val, 1) - val(i,:) = matmul(ele_values(i, :, :), n) - end do + do i=1, size(val, 1) + val(i,:) = matmul(ele_values(i, :, :), n) + end do + + end function eval_field_tensor + + function face_eval_field_scalar(face, s_field, local_coord) result(val) + !!< Evaluate the scalar field s_field at face local coordinate + !!< local_coord of the facet face. + + integer, intent(in) :: face + type(scalar_field), intent(in) :: s_field + real, dimension(:), intent(in) :: local_coord + real :: val - end function eval_field_tensor + val = dot_product(face_val(s_field, face), & + eval_shape(face_shape(s_field, face), local_coord)) - function face_eval_field_scalar(face, s_field, local_coord) result(val) - !!< Evaluate the scalar field s_field at face local coordinate - !!< local_coord of the facet face. + end function face_eval_field_scalar - integer, intent(in) :: face - type(scalar_field), intent(in) :: s_field - real, dimension(:), intent(in) :: local_coord - real :: val + function face_eval_field_vector(face, v_field, local_coord) result(val) + !!< Evaluate the vector field v_field at face local coordinate + !!< local_coord of facet face. - val = dot_product(face_val(s_field, face), & - eval_shape(face_shape(s_field, face), local_coord)) + integer, intent(in) :: face + type(vector_field), intent(in) :: v_field + real, dimension(:), intent(in) :: local_coord + real, dimension(v_field%dim) :: val - end function face_eval_field_scalar + val = matmul(face_val(v_field, face), & + eval_shape(face_shape(v_field, face), local_coord)) - function face_eval_field_vector(face, v_field, local_coord) result(val) - !!< Evaluate the vector field v_field at face local coordinate - !!< local_coord of facet face. + end function face_eval_field_vector - integer, intent(in) :: face - type(vector_field), intent(in) :: v_field - real, dimension(:), intent(in) :: local_coord - real, dimension(v_field%dim) :: val + function face_eval_field_vector_dim(face, v_field, dim, local_coord) result(val) + !!< Evaluate the vector field v_field at face local coordinate + !!< local_coord of facet face. - val = matmul(face_val(v_field, face), & - eval_shape(face_shape(v_field, face), local_coord)) + integer, intent(in) :: face + type(vector_field), intent(in) :: v_field + integer, intent(in) :: dim + real, dimension(:), intent(in) :: local_coord + real :: val - end function face_eval_field_vector + val = dot_product(face_val(v_field, dim, face), & + eval_shape(face_shape(v_field, face), local_coord)) - function face_eval_field_vector_dim(face, v_field, dim, local_coord) result(val) - !!< Evaluate the vector field v_field at face local coordinate - !!< local_coord of facet face. - integer, intent(in) :: face - type(vector_field), intent(in) :: v_field - integer, intent(in) :: dim - real, dimension(:), intent(in) :: local_coord - real :: val + end function face_eval_field_vector_dim - val = dot_product(face_val(v_field, dim, face), & - eval_shape(face_shape(v_field, face), local_coord)) + function face_eval_field_tensor(face, t_field, local_coord) result(val) + !!< Evaluate the tensor field t_field at face local coordinate + !!< local_coord of facet face. + integer, intent(in) :: face + type(tensor_field), intent(in) :: t_field + real, dimension(:), intent(in) :: local_coord + real, dimension(t_field%dim(1), t_field%dim(2)) :: val + + integer :: i + real, dimension(t_field%dim(1), t_field%dim(2), face_loc(t_field, face)) :: face_values + real, dimension(face_loc(t_field, face)) :: n + + n = eval_shape(face_shape(t_field, face), local_coord) + face_values = face_val(t_field, face) + + do i=1, size(val, 1) + val(i,:) = matmul(face_values(i, :, :), n) + end do - end function face_eval_field_vector_dim - function face_eval_field_tensor(face, t_field, local_coord) result(val) - !!< Evaluate the tensor field t_field at face local coordinate - !!< local_coord of facet face. + end function face_eval_field_tensor - integer, intent(in) :: face - type(tensor_field), intent(in) :: t_field - real, dimension(:), intent(in) :: local_coord - real, dimension(t_field%dim(1), t_field%dim(2)) :: val + function face_eval_field_tensor_dim_dim(face, t_field, dim1, dim2, local_coord) result(val) + !!< Evaluate the tensor field t_field at face local coordinate + !!< local_coord of facet face. - integer :: i - real, dimension(t_field%dim(1), t_field%dim(2), face_loc(t_field, face)) :: face_values - real, dimension(face_loc(t_field, face)) :: n + integer, intent(in) :: face + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: dim1, dim2 + real, dimension(:), intent(in) :: local_coord + real :: val - n = eval_shape(face_shape(t_field, face), local_coord) - face_values = face_val(t_field, face) + val = dot_product(face_val(t_field, dim1, dim2, face), & + eval_shape(face_shape(t_field, face), local_coord)) - do i=1, size(val, 1) - val(i,:) = matmul(face_values(i, :, :), n) - end do + end function face_eval_field_tensor_dim_dim + subroutine getsndgln(mesh, sndgln) + !! get legacy surface mesh ndglno that uses node numbering of the full mesh + type(mesh_type), intent(in):: mesh + integer, dimension(:), intent(out):: sndgln - end function face_eval_field_tensor - - function face_eval_field_tensor_dim_dim(face, t_field, dim1, dim2, local_coord) result(val) - !!< Evaluate the tensor field t_field at face local coordinate - !!< local_coord of facet face. - - integer, intent(in) :: face - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: dim1, dim2 - real, dimension(:), intent(in) :: local_coord - real :: val - - val = dot_product(face_val(t_field, dim1, dim2, face), & - eval_shape(face_shape(t_field, face), local_coord)) - - end function face_eval_field_tensor_dim_dim - - subroutine getsndgln(mesh, sndgln) - !! get legacy surface mesh ndglno that uses node numbering of the full mesh - type(mesh_type), intent(in):: mesh - integer, dimension(:), intent(out):: sndgln - - integer sele, snloc, stotel - - assert(associated(mesh%faces)) - - stotel=unique_surface_element_count(mesh) - snloc=face_loc(mesh, 1) - - assert(size(sndgln)==stotel*snloc) - - do sele=1, stotel - sndgln( (sele-1)*snloc+1:sele*snloc )=face_global_nodes(mesh, sele) - end do - - end subroutine getsndgln - - ! ------------------------------------------------------------------------ - ! Point wise python evalutiation - ! ------------------------------------------------------------------------ - ! these could go in a separate module - - subroutine set_values_from_python_scalar(values, func, x, y, z, time) - !!< Given a list of positions and a time, evaluate the python function - !!< specified in the string func at those points. - real, dimension(:), intent(inout) :: values - !! Func may contain any python at all but the following function must - !! be defiled: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - real, dimension(size(values)), target :: x - real, dimension(size(values)), optional, target :: y - real, dimension(size(values)), optional, target :: z - real :: time - - real, dimension(:), pointer :: lx, ly, lz - real, dimension(0), target :: zero - integer :: stat, dim - - lx=>x - ly=>zero - lz=>zero - dim=1 - if (present(y)) then - ly=>y - dim=2 - if (present(z)) then - lz=>z - dim=3 - end if - end if - - call set_scalar_field_from_python(func, len(func), dim,& - & size(values), lx, ly, lz, time, values, stat) - - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(func) - FLAbort("Dying") - end if - - end subroutine set_values_from_python_scalar - - subroutine set_values_from_python_scalar_pos(values, func, pos, time) - !!< Given a list of positions and a time, evaluate the python function - !!< specified in the string func at those points. - real, dimension(:), intent(inout) :: values - !! Func may contain any python at all but the following function must - !! be defiled: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - real, dimension(:, :), intent(in), target :: pos - real :: time - - real, dimension(:), pointer :: lx, ly, lz - real, dimension(0), target :: zero - integer :: stat, dim - - dim=size(pos, 1) - select case(dim) - case(1) - lx=>pos(1, :) + integer sele, snloc, stotel + + assert(associated(mesh%faces)) + + stotel=unique_surface_element_count(mesh) + snloc=face_loc(mesh, 1) + + assert(size(sndgln)==stotel*snloc) + + do sele=1, stotel + sndgln( (sele-1)*snloc+1:sele*snloc )=face_global_nodes(mesh, sele) + end do + + end subroutine getsndgln + + ! ------------------------------------------------------------------------ + ! Point wise python evalutiation + ! ------------------------------------------------------------------------ + ! these could go in a separate module + + subroutine set_values_from_python_scalar(values, func, x, y, z, time) + !!< Given a list of positions and a time, evaluate the python function + !!< specified in the string func at those points. + real, dimension(:), intent(inout) :: values + !! Func may contain any python at all but the following function must + !! be defiled: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + real, dimension(size(values)), target :: x + real, dimension(size(values)), optional, target :: y + real, dimension(size(values)), optional, target :: z + real :: time + + real, dimension(:), pointer :: lx, ly, lz + real, dimension(0), target :: zero + integer :: stat, dim + + lx=>x ly=>zero lz=>zero - case(2) - lx=>pos(1, :) - ly=>pos(2, :) + dim=1 + if (present(y)) then + ly=>y + dim=2 + if (present(z)) then + lz=>z + dim=3 + end if + end if + + call set_scalar_field_from_python(func, len(func), dim,& + & size(values), lx, ly, lz, time, values, stat) + + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(func) + FLAbort("Dying") + end if + + end subroutine set_values_from_python_scalar + + subroutine set_values_from_python_scalar_pos(values, func, pos, time) + !!< Given a list of positions and a time, evaluate the python function + !!< specified in the string func at those points. + real, dimension(:), intent(inout) :: values + !! Func may contain any python at all but the following function must + !! be defiled: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + real, dimension(:, :), intent(in), target :: pos + real :: time + + real, dimension(:), pointer :: lx, ly, lz + real, dimension(0), target :: zero + integer :: stat, dim + + dim=size(pos, 1) + select case(dim) + case(1) + lx=>pos(1, :) + ly=>zero + lz=>zero + case(2) + lx=>pos(1, :) + ly=>pos(2, :) + lz=>zero + case(3) + lx=>pos(1, :) + ly=>pos(2, :) + lz=>pos(3, :) + end select + + call set_scalar_field_from_python(func, len(func), dim,& + & size(values), lx, ly, lz, time, values, stat) + + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(func) + FLAbort("Dying") + end if + end subroutine set_values_from_python_scalar_pos + + subroutine set_values_from_python_vector(values, func, x, y, z, time) + !!< Given a list of positions and a time, evaluate the python function + !!< specified in the string func at those points. + real, dimension(:,:), target, intent(inout) :: values + !! Func may contain any python at all but the following function must + !! be defiled: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + real, dimension(size(values,2)), target :: x + real, dimension(size(values,2)), optional, target :: y + real, dimension(size(values,2)), optional, target :: z + real :: time + + real, dimension(:), pointer :: lx, ly, lz + real, dimension(:), pointer :: lvx,lvy,lvz + real, dimension(0), target :: zero + integer :: stat, dim + + lx=>x + ly=>zero lz=>zero - case(3) - lx=>pos(1, :) - ly=>pos(2, :) - lz=>pos(3, :) - end select - - call set_scalar_field_from_python(func, len(func), dim,& - & size(values), lx, ly, lz, time, values, stat) - - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(func) - FLAbort("Dying") - end if - end subroutine set_values_from_python_scalar_pos - - subroutine set_values_from_python_vector(values, func, x, y, z, time) - !!< Given a list of positions and a time, evaluate the python function - !!< specified in the string func at those points. - real, dimension(:,:), target, intent(inout) :: values - !! Func may contain any python at all but the following function must - !! be defiled: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - real, dimension(size(values,2)), target :: x - real, dimension(size(values,2)), optional, target :: y - real, dimension(size(values,2)), optional, target :: z - real :: time - - real, dimension(:), pointer :: lx, ly, lz - real, dimension(:), pointer :: lvx,lvy,lvz - real, dimension(0), target :: zero - integer :: stat, dim - - lx=>x - ly=>zero - lz=>zero - dim=1 - if (present(y)) then - ly=>y - dim=2 - if (present(z)) then - lz=>z - dim=3 - end if - end if - - lvx=>values(1,:) - lvy=>zero - lvz=>zero - if(size(values,1)>1) then - lvy=>values(2,:) - if(size(values,1)>2) then - lvz => values(3,:) - end if - end if - call set_vector_field_from_python(func, len_trim(func), dim,& - & size(values,2), lx, ly, lz, time,size(values,1), & - lvx,lvy,lvz, stat) - - if (stat/=0) then - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(func) - FLAbort("Dying") - end if - - end subroutine set_values_from_python_vector - - subroutine set_values_from_python_vector_pos(values, func, pos, time) - !!< Given a list of positions and a time, evaluate the python function - !!< specified in the string func at those points. - real, dimension(:,:), intent(inout) :: values - !! Func may contain any python at all but the following function must - !! be defiled: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - real, dimension(:, :), intent(in), target :: pos - real, intent(in) :: time - - integer :: dim - - dim=size(pos, 1) - select case(dim) - case(1) - call set_values_from_python_vector(values, func, pos(1,:), time=time) - case(2) - call set_values_from_python_vector(values, func, pos(1,:), pos(2,:), time=time) - case(3) - call set_values_from_python_vector(values, func, pos(1,:), pos(2,:), pos(3,:), time=time) - end select - - end subroutine set_values_from_python_vector_pos - - subroutine set_values_from_python_vector_field(values, func, vfield, time) - !!< Given a list of positions and a time, evaluate the python function - !!< specified in the string func at those points. - real, dimension(:,:), intent(inout) :: values - !! Func may contain any python at all but the following function must - !! be defiled: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - type(vector_field), intent(in) :: vfield - real, intent(in) :: time - - integer :: dim - - dim=vfield%dim - select case(dim) - case(1) - call set_values_from_python_vector(values, func, vfield%val(1,:), time=time) - case(2) - call set_values_from_python_vector(values, func, vfield%val(1,:), vfield%val(2,:), time=time) - case(3) - call set_values_from_python_vector(values, func, vfield%val(1,:), vfield%val(2,:), vfield%val(3,:), time=time) - end select - - end subroutine set_values_from_python_vector_field - - ! ------------------------------------------------------------------------ - ! Geometric element volume routines. These really ought to go somewhere - ! else but tend to cause dependency problems when they do. - ! ------------------------------------------------------------------------ - - function tetvol_new(positions, ele) result(t) - real :: t - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - real, dimension(positions%dim, ele_loc(positions, ele)) :: pos - - pos = ele_val(positions, ele) - t = tetvol_old(pos(1, :), pos(2, :), pos(3, :)) - - end function tetvol_new - - real function tetvol_old( x, y, z ) - - real x(4), y(4), z(4) - real vol, x12, x13, x14, y12, y13, y14, z12, z13, z14 - ! - x12 = x(2) - x(1) - x13 = x(3) - x(1) - x14 = x(4) - x(1) - y12 = y(2) - y(1) - y13 = y(3) - y(1) - y14 = y(4) - y(1) - z12 = z(2) - z(1) - z13 = z(3) - z(1) - z14 = z(4) - z(1) - ! - vol = x12*( y13*z14 - y14*z13 ) & + dim=1 + if (present(y)) then + ly=>y + dim=2 + if (present(z)) then + lz=>z + dim=3 + end if + end if + + lvx=>values(1,:) + lvy=>zero + lvz=>zero + if(size(values,1)>1) then + lvy=>values(2,:) + if(size(values,1)>2) then + lvz => values(3,:) + end if + end if + call set_vector_field_from_python(func, len_trim(func), dim,& + & size(values,2), lx, ly, lz, time,size(values,1), & + lvx,lvy,lvz, stat) + + if (stat/=0) then + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(func) + FLAbort("Dying") + end if + + end subroutine set_values_from_python_vector + + subroutine set_values_from_python_vector_pos(values, func, pos, time) + !!< Given a list of positions and a time, evaluate the python function + !!< specified in the string func at those points. + real, dimension(:,:), intent(inout) :: values + !! Func may contain any python at all but the following function must + !! be defiled: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + real, dimension(:, :), intent(in), target :: pos + real, intent(in) :: time + + integer :: dim + + dim=size(pos, 1) + select case(dim) + case(1) + call set_values_from_python_vector(values, func, pos(1,:), time=time) + case(2) + call set_values_from_python_vector(values, func, pos(1,:), pos(2,:), time=time) + case(3) + call set_values_from_python_vector(values, func, pos(1,:), pos(2,:), pos(3,:), time=time) + end select + + end subroutine set_values_from_python_vector_pos + + subroutine set_values_from_python_vector_field(values, func, vfield, time) + !!< Given a list of positions and a time, evaluate the python function + !!< specified in the string func at those points. + real, dimension(:,:), intent(inout) :: values + !! Func may contain any python at all but the following function must + !! be defiled: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + type(vector_field), intent(in) :: vfield + real, intent(in) :: time + + integer :: dim + + dim=vfield%dim + select case(dim) + case(1) + call set_values_from_python_vector(values, func, vfield%val(1,:), time=time) + case(2) + call set_values_from_python_vector(values, func, vfield%val(1,:), vfield%val(2,:), time=time) + case(3) + call set_values_from_python_vector(values, func, vfield%val(1,:), vfield%val(2,:), vfield%val(3,:), time=time) + end select + + end subroutine set_values_from_python_vector_field + + ! ------------------------------------------------------------------------ + ! Geometric element volume routines. These really ought to go somewhere + ! else but tend to cause dependency problems when they do. + ! ------------------------------------------------------------------------ + + function tetvol_new(positions, ele) result(t) + real :: t + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + real, dimension(positions%dim, ele_loc(positions, ele)) :: pos + + pos = ele_val(positions, ele) + t = tetvol_old(pos(1, :), pos(2, :), pos(3, :)) + + end function tetvol_new + + real function tetvol_old( x, y, z ) + + real x(4), y(4), z(4) + real vol, x12, x13, x14, y12, y13, y14, z12, z13, z14 + ! + x12 = x(2) - x(1) + x13 = x(3) - x(1) + x14 = x(4) - x(1) + y12 = y(2) - y(1) + y13 = y(3) - y(1) + y14 = y(4) - y(1) + z12 = z(2) - z(1) + z13 = z(3) - z(1) + z14 = z(4) - z(1) + ! + vol = x12*( y13*z14 - y14*z13 ) & + x13*( y14*z12 - y12*z14 ) & + x14*( y12*z13 - y13*z12 ) - ! - tetvol_old = vol/6 - ! - return - end function tetvol_old - - function triarea(positions, ele) result(t) - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - real :: t - real, dimension(positions%dim, positions%mesh%shape%loc) :: pos - real :: xA, xB, yA, yB, xC, yC - - pos = ele_val(positions, ele) - if (positions%dim == 2) then - xA = pos(1, 1); xB = pos(1, 2); xC = pos(1, 3) - yA = pos(2, 1); yB = pos(2, 2); yC = pos(2, 3) - t = abs((xB*yA-xA*yB)+(xC*yB-xB*yC)+(xA*yC-xC*yA))/2 - elseif (positions%dim == 3) then - ! http://mathworld.wolfram.com/TriangleArea.html, (19) - t = 0.5 * norm2(cross_product(pos(:, 2) - pos(:, 1), pos(:, 1) - pos(:, 3))) - else - FLAbort("Only 2 or 3 dimensions supported, sorry") - end if - end function triarea - - function tetvol_1d(positions, ele) result(t) - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - - real :: t - - integer, dimension(:), pointer :: element_nodes => null() - - assert(positions%dim == 1) - - element_nodes => ele_nodes(positions, ele) - - assert(size(element_nodes) == 2) - t = abs(node_val(positions, 1, element_nodes(2)) - node_val(positions, 1, element_nodes(1))) - - end function tetvol_1d - - function simplex_volume(positions, ele) result(t) - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - real :: t - - select case(mesh_dim(positions)) - case(3) - t = tetvol_new(positions, ele) - case(2) - t = triarea(positions, ele) - case(1) - t = tetvol_1d(positions, ele) - case default - FLAbort("Invalid dimension") - end select - - end function simplex_volume - - function face_opposite_mesh(mesh, face) result (opp_face) - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face - - integer :: parent_ele, opp_ele, opp_face - integer, dimension(:), pointer :: neighbours - - parent_ele = face_ele(mesh, face) - neighbours => ele_neigh(mesh, parent_ele) - opp_ele = neighbours(local_face_number(mesh, face)) - if (opp_ele > 0) then - opp_face = ele_face(mesh, opp_ele, parent_ele) - else - opp_face = -1 - end if - end function face_opposite_mesh - - function face_opposite_scalar(sfield, face) result (opp_face) - type(scalar_field), intent(in) :: sfield - integer, intent(in) :: face - - integer :: opp_face - - opp_face = face_opposite_mesh(sfield%mesh, face) - end function face_opposite_scalar - - function face_opposite_vector(vfield, face) result (opp_face) - type(vector_field), intent(in) :: vfield - integer, intent(in) :: face - - integer :: opp_face - - opp_face = face_opposite_mesh(vfield%mesh, face) - end function face_opposite_vector - - function face_opposite_tensor(tfield, face) result (opp_face) - type(tensor_field), intent(in) :: tfield - integer, intent(in) :: face - - integer :: opp_face - - opp_face = face_opposite_mesh(tfield%mesh, face) - end function face_opposite_tensor - - function reorder_element_nodes_face(element, mesh, face) result(reordered_element_nodes) - !!< Return a list of node numbers local to an element reordered such that - !!< they correspond with the node numbering on a face - !!< - !!< Note that the element supplied does not need to be from the mesh so long as they are topologically/geometrically the same. - !!< e.g. element can be p2 while mesh can be p1. - type(element_type), intent(in) :: element - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face ! which global face number we're on - - integer, dimension(:), pointer :: face_l_nodes - integer, dimension(mesh%faces%shape%numbering%vertices) :: face_l_vertices, element_face_local_vertices - integer, dimension(element%numbering%vertices) :: element_l_vertices, reordered_element_vertices - integer, dimension(mesh%shape%loc) :: node2vertex - integer, dimension(element%loc) :: reordered_element_nodes - integer :: i, j, l_face_number - - ! local face number of face in element - l_face_number = local_face_number(mesh, face) - - ! get the vertex numbers of the face (indexes into the face node numbering) - face_l_vertices = local_vertices(face_shape(mesh, face)) ! e.g. (1, 3, 6) - - ! get the element local node numbers of the nodes on the face - face_l_nodes => face_local_nodes(mesh, face) ! e.g. (3, 8, 10, 2, 7, 1) - - ! work out the element local node numbers of the face vertices - element_face_local_vertices = face_l_nodes(face_l_vertices) ! e.g. (3, 10, 1) - - ! get the vertex numbers of the element (indexes ino the element node numbering) - element_l_vertices = local_vertices(mesh%shape) ! e.g. (1, 3, 6, 10) - - ! now we want to look up the facet vertices (specified in ele node numbers), - ! i.e. element_face_local_vertices, in element_l_vertices - ! this gives us the vertices of the facet specified as element vertex numbers - - ! first we create a map form element nodes to element vertices - node2vertex = 0 - do i = 1, size(element_l_vertices) - node2vertex(element_l_vertices(i)) = i - end do - ! then we map element_face_local_vertices using this map - - ! the first vertex we want however is the vertex opposite the facet - reordered_element_vertices(1) = l_face_number - ! followed by the facet vertices - do i = 1, size(element_face_local_vertices) - j = node2vertex(element_face_local_vertices(i)) - assert(j>0) - reordered_element_vertices(i+1) = j - end do - - ! Note that we have worked out the correct vertex order, independent of the - ! provided element shape (i.e. we have only used mesh and mesh%shape so far) - ! Only now do we use the provided element, and ask for a local numbering that is - ! consistent with the reordered vertices - reordered_element_nodes = ele_local_num(reordered_element_vertices, element%numbering) - - end function reorder_element_nodes_face - - function face_n_s(element, mesh, face) result(n_s) - !!< Reorders the element shape functions of element%n_s to match that of element (presumed adjacent to face in mesh) - !!< - !!< The precomputed element%n_s = N_i(xi_g), where - !!< - !!< N_i is the ith shape function of the element behind the facet - !!< xi_g is the (vector of) local coordinates of the g-th gauss point on the facet - !!< - !!< They have been calculated based on the assumption that xi^1 is the local coordinate that is 0 at the facet and xi^2 to xi^(dim+1) - !!< are the local coordinates of the facet. The node numbering i of the element is based on a vertex ordering such that vertex 1 is - !!< the vertex opposite the facet, and vertices 2:dim+1 are in the same order as the vertices of the facet. - !!< - !!< An arbitrary element in the mesh adjacent to a facet will not satisfy these assumptions but will have a different ordering j - !!< Let j(i) be the map from the idealised node numbering i to the actual node numbering j, i.e. j(1) is the node opposite the facet, - !!< etc. This map is given by reorder_element_nodes_face() - !!< Let M_j be a reordering of the basis functions N_i such that M_j(i)=N_j - !!< We want to compute T(xi_g) = \sum_j T_j M_j(xi_g) = \sum_i T_j(i) N_i(xi_g) - !!< Therefore face_n_s(j,g,k) returns M_j(xi_g) so that we do not have to reorder T_j. Instead we have applied an inverse - !!< reordering on the first index of n_s. - !!< - !!< Note that the element supplied does not need to be from the mesh so long as they are topologically/geometrically the same. - !!< e.g. element can be p2 while mesh can be p1. - type(element_type), intent(in) :: element - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face - real, dimension(element%loc, element%surface_quadrature%ngi) :: n_s - - integer, dimension(element%loc) :: reordered_element_nodes - integer :: i, j - - reordered_element_nodes = reorder_element_nodes_face(element, mesh, face) - - do i = 1, size(reordered_element_nodes) - j = reordered_element_nodes(i) - n_s(j,:) = element%n_s(i,:) - end do - - end function face_n_s - - function face_dn_s(element, mesh, face) result(dn_s) - !!< Reorders the element shape functions (their derivatives) of element%dn_s to match that of element (presumed adjacent to face in mesh) - !!< - !!< The precomputed element%dn_s = dN_i/dxi^k (xi_g), where - !!< - !!< N_i is the ith shape function of the element behind the facet - !!< xi^k is the kth local coordinate of the element - !!< xi_g is the (vector of) local coordinates of the g-th gauss point on the facet - !!< - !!< They have been calculated based on the assumption that xi_1 is the local coordinate that is 0 at the facet and xi^2 to xi^(dim+1) - !!< are the local coordinates of the facet. The xi_g are based on the same local coordinates. The node numbering i of the element - !!< is based on a vertex ordering such that vertex 1 is the vertex opposite the facet, and vertices 2:dim+1 are in the same order - !!< as the vertices of the facet. - !!< - !!< An arbitrary element in the mesh adjacent to a facet will not satisfy these assumptions but will have a different ordering j - !!< Let j(i) be the map from the idealised node numbering i to the actual node numbering j, i.e. j(1) is the node opposite the facet, - !!< etc. This map is given by reorder_element_nodes_face() - !!< Let M_j be a reordering of the basis functions N_i such that M_j(i)=N_j - !!< We want to compute dT/dxi^k (xi_g) = \sum_j T_j dM_j/dxi^k (xi_g) = \sum_i T_j(i) dN_i/dxi^k (xi_g) - !!< Therefore face_dn_s(j,g,k) returns dM_j/dxi^k (xi_g) so that we do not have to reorder T_j. Instead we have applied an inverse - !!< reordering on the first index of dn_s. - !!< - !!< Note that the element supplied does not need to be from the mesh so long as they are topologically/geometrically the same. - !!< e.g. element can be p2 while mesh can be p1. - type(element_type), intent(in) :: element - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face - real, dimension(element%loc, element%surface_quadrature%ngi, element%dim) :: dn_s - - integer, dimension(element%loc) :: reordered_element_nodes - integer :: i, j - - reordered_element_nodes = reorder_element_nodes_face(element, mesh, face) - - do i = 1, size(reordered_element_nodes) - j = reordered_element_nodes(i) - dn_s(j,:,:) = element%dn_s(i,:,:) - end do - - end function face_dn_s - - subroutine write_minmax_scalar(sfield, field_expression) - ! the scalar field to print its min and max of - type(scalar_field), intent(in):: sfield - ! the actual field in the code - character(len=*), intent(in):: field_expression - - ewrite(2,*) 'Min, max of '//trim(field_expression)//' "'// & - trim(sfield%name)//'" = ',minval(sfield%val), maxval(sfield%val) - - end subroutine write_minmax_scalar - - subroutine write_minmax_vector(vfield, field_expression) - ! the vector field to print its min and max of - type(vector_field), intent(in):: vfield - ! the actual field in the code - character(len=*), intent(in):: field_expression - - integer:: i - - do i=1, vfield%dim + ! + tetvol_old = vol/6 + ! + return + end function tetvol_old + + function triarea(positions, ele) result(t) + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + real :: t + real, dimension(positions%dim, positions%mesh%shape%loc) :: pos + real :: xA, xB, yA, yB, xC, yC + + pos = ele_val(positions, ele) + if (positions%dim == 2) then + xA = pos(1, 1); xB = pos(1, 2); xC = pos(1, 3) + yA = pos(2, 1); yB = pos(2, 2); yC = pos(2, 3) + t = abs((xB*yA-xA*yB)+(xC*yB-xB*yC)+(xA*yC-xC*yA))/2 + elseif (positions%dim == 3) then + ! http://mathworld.wolfram.com/TriangleArea.html, (19) + t = 0.5 * norm2(cross_product(pos(:, 2) - pos(:, 1), pos(:, 1) - pos(:, 3))) + else + FLAbort("Only 2 or 3 dimensions supported, sorry") + end if + end function triarea + + function tetvol_1d(positions, ele) result(t) + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + + real :: t + + integer, dimension(:), pointer :: element_nodes => null() + + assert(positions%dim == 1) + + element_nodes => ele_nodes(positions, ele) + + assert(size(element_nodes) == 2) + t = abs(node_val(positions, 1, element_nodes(2)) - node_val(positions, 1, element_nodes(1))) + + end function tetvol_1d + + function simplex_volume(positions, ele) result(t) + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + real :: t + + select case(mesh_dim(positions)) + case(3) + t = tetvol_new(positions, ele) + case(2) + t = triarea(positions, ele) + case(1) + t = tetvol_1d(positions, ele) + case default + FLAbort("Invalid dimension") + end select + + end function simplex_volume + + function face_opposite_mesh(mesh, face) result (opp_face) + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face + + integer :: parent_ele, opp_ele, opp_face + integer, dimension(:), pointer :: neighbours + + parent_ele = face_ele(mesh, face) + neighbours => ele_neigh(mesh, parent_ele) + opp_ele = neighbours(local_face_number(mesh, face)) + if (opp_ele > 0) then + opp_face = ele_face(mesh, opp_ele, parent_ele) + else + opp_face = -1 + end if + end function face_opposite_mesh + + function face_opposite_scalar(sfield, face) result (opp_face) + type(scalar_field), intent(in) :: sfield + integer, intent(in) :: face + + integer :: opp_face + + opp_face = face_opposite_mesh(sfield%mesh, face) + end function face_opposite_scalar + + function face_opposite_vector(vfield, face) result (opp_face) + type(vector_field), intent(in) :: vfield + integer, intent(in) :: face + + integer :: opp_face + + opp_face = face_opposite_mesh(vfield%mesh, face) + end function face_opposite_vector + + function face_opposite_tensor(tfield, face) result (opp_face) + type(tensor_field), intent(in) :: tfield + integer, intent(in) :: face + + integer :: opp_face + + opp_face = face_opposite_mesh(tfield%mesh, face) + end function face_opposite_tensor + + function reorder_element_nodes_face(element, mesh, face) result(reordered_element_nodes) + !!< Return a list of node numbers local to an element reordered such that + !!< they correspond with the node numbering on a face + !!< + !!< Note that the element supplied does not need to be from the mesh so long as they are topologically/geometrically the same. + !!< e.g. element can be p2 while mesh can be p1. + type(element_type), intent(in) :: element + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face ! which global face number we're on + + integer, dimension(:), pointer :: face_l_nodes + integer, dimension(mesh%faces%shape%numbering%vertices) :: face_l_vertices, element_face_local_vertices + integer, dimension(element%numbering%vertices) :: element_l_vertices, reordered_element_vertices + integer, dimension(mesh%shape%loc) :: node2vertex + integer, dimension(element%loc) :: reordered_element_nodes + integer :: i, j, l_face_number + + ! local face number of face in element + l_face_number = local_face_number(mesh, face) + + ! get the vertex numbers of the face (indexes into the face node numbering) + face_l_vertices = local_vertices(face_shape(mesh, face)) ! e.g. (1, 3, 6) + + ! get the element local node numbers of the nodes on the face + face_l_nodes => face_local_nodes(mesh, face) ! e.g. (3, 8, 10, 2, 7, 1) + + ! work out the element local node numbers of the face vertices + element_face_local_vertices = face_l_nodes(face_l_vertices) ! e.g. (3, 10, 1) + + ! get the vertex numbers of the element (indexes ino the element node numbering) + element_l_vertices = local_vertices(mesh%shape) ! e.g. (1, 3, 6, 10) + + ! now we want to look up the facet vertices (specified in ele node numbers), + ! i.e. element_face_local_vertices, in element_l_vertices + ! this gives us the vertices of the facet specified as element vertex numbers + + ! first we create a map form element nodes to element vertices + node2vertex = 0 + do i = 1, size(element_l_vertices) + node2vertex(element_l_vertices(i)) = i + end do + ! then we map element_face_local_vertices using this map + + ! the first vertex we want however is the vertex opposite the facet + reordered_element_vertices(1) = l_face_number + ! followed by the facet vertices + do i = 1, size(element_face_local_vertices) + j = node2vertex(element_face_local_vertices(i)) + assert(j>0) + reordered_element_vertices(i+1) = j + end do + + ! Note that we have worked out the correct vertex order, independent of the + ! provided element shape (i.e. we have only used mesh and mesh%shape so far) + ! Only now do we use the provided element, and ask for a local numbering that is + ! consistent with the reordered vertices + reordered_element_nodes = ele_local_num(reordered_element_vertices, element%numbering) + + end function reorder_element_nodes_face + + function face_n_s(element, mesh, face) result(n_s) + !!< Reorders the element shape functions of element%n_s to match that of element (presumed adjacent to face in mesh) + !!< + !!< The precomputed element%n_s = N_i(xi_g), where + !!< + !!< N_i is the ith shape function of the element behind the facet + !!< xi_g is the (vector of) local coordinates of the g-th gauss point on the facet + !!< + !!< They have been calculated based on the assumption that xi^1 is the local coordinate that is 0 at the facet and xi^2 to xi^(dim+1) + !!< are the local coordinates of the facet. The node numbering i of the element is based on a vertex ordering such that vertex 1 is + !!< the vertex opposite the facet, and vertices 2:dim+1 are in the same order as the vertices of the facet. + !!< + !!< An arbitrary element in the mesh adjacent to a facet will not satisfy these assumptions but will have a different ordering j + !!< Let j(i) be the map from the idealised node numbering i to the actual node numbering j, i.e. j(1) is the node opposite the facet, + !!< etc. This map is given by reorder_element_nodes_face() + !!< Let M_j be a reordering of the basis functions N_i such that M_j(i)=N_j + !!< We want to compute T(xi_g) = \sum_j T_j M_j(xi_g) = \sum_i T_j(i) N_i(xi_g) + !!< Therefore face_n_s(j,g,k) returns M_j(xi_g) so that we do not have to reorder T_j. Instead we have applied an inverse + !!< reordering on the first index of n_s. + !!< + !!< Note that the element supplied does not need to be from the mesh so long as they are topologically/geometrically the same. + !!< e.g. element can be p2 while mesh can be p1. + type(element_type), intent(in) :: element + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face + real, dimension(element%loc, element%surface_quadrature%ngi) :: n_s + + integer, dimension(element%loc) :: reordered_element_nodes + integer :: i, j + + reordered_element_nodes = reorder_element_nodes_face(element, mesh, face) + + do i = 1, size(reordered_element_nodes) + j = reordered_element_nodes(i) + n_s(j,:) = element%n_s(i,:) + end do + + end function face_n_s + + function face_dn_s(element, mesh, face) result(dn_s) + !!< Reorders the element shape functions (their derivatives) of element%dn_s to match that of element (presumed adjacent to face in mesh) + !!< + !!< The precomputed element%dn_s = dN_i/dxi^k (xi_g), where + !!< + !!< N_i is the ith shape function of the element behind the facet + !!< xi^k is the kth local coordinate of the element + !!< xi_g is the (vector of) local coordinates of the g-th gauss point on the facet + !!< + !!< They have been calculated based on the assumption that xi_1 is the local coordinate that is 0 at the facet and xi^2 to xi^(dim+1) + !!< are the local coordinates of the facet. The xi_g are based on the same local coordinates. The node numbering i of the element + !!< is based on a vertex ordering such that vertex 1 is the vertex opposite the facet, and vertices 2:dim+1 are in the same order + !!< as the vertices of the facet. + !!< + !!< An arbitrary element in the mesh adjacent to a facet will not satisfy these assumptions but will have a different ordering j + !!< Let j(i) be the map from the idealised node numbering i to the actual node numbering j, i.e. j(1) is the node opposite the facet, + !!< etc. This map is given by reorder_element_nodes_face() + !!< Let M_j be a reordering of the basis functions N_i such that M_j(i)=N_j + !!< We want to compute dT/dxi^k (xi_g) = \sum_j T_j dM_j/dxi^k (xi_g) = \sum_i T_j(i) dN_i/dxi^k (xi_g) + !!< Therefore face_dn_s(j,g,k) returns dM_j/dxi^k (xi_g) so that we do not have to reorder T_j. Instead we have applied an inverse + !!< reordering on the first index of dn_s. + !!< + !!< Note that the element supplied does not need to be from the mesh so long as they are topologically/geometrically the same. + !!< e.g. element can be p2 while mesh can be p1. + type(element_type), intent(in) :: element + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face + real, dimension(element%loc, element%surface_quadrature%ngi, element%dim) :: dn_s + + integer, dimension(element%loc) :: reordered_element_nodes + integer :: i, j + + reordered_element_nodes = reorder_element_nodes_face(element, mesh, face) + + do i = 1, size(reordered_element_nodes) + j = reordered_element_nodes(i) + dn_s(j,:,:) = element%dn_s(i,:,:) + end do + + end function face_dn_s + + subroutine write_minmax_scalar(sfield, field_expression) + ! the scalar field to print its min and max of + type(scalar_field), intent(in):: sfield + ! the actual field in the code + character(len=*), intent(in):: field_expression + ewrite(2,*) 'Min, max of '//trim(field_expression)//' "'// & - trim(vfield%name)//'%'//int2str(i)//'" = ', & - minval(vfield%val(i,:)), maxval(vfield%val(i,:)) - end do + trim(sfield%name)//'" = ',minval(sfield%val), maxval(sfield%val) + + end subroutine write_minmax_scalar + + subroutine write_minmax_vector(vfield, field_expression) + ! the vector field to print its min and max of + type(vector_field), intent(in):: vfield + ! the actual field in the code + character(len=*), intent(in):: field_expression + + integer:: i + + do i=1, vfield%dim + ewrite(2,*) 'Min, max of '//trim(field_expression)//' "'// & + trim(vfield%name)//'%'//int2str(i)//'" = ', & + minval(vfield%val(i,:)), maxval(vfield%val(i,:)) + end do - end subroutine write_minmax_vector + end subroutine write_minmax_vector - subroutine write_minmax_tensor(tfield, field_expression) - ! the tensor field to print its min and max of - type(tensor_field), intent(in):: tfield - ! the actual field in the code - character(len=*), intent(in):: field_expression + subroutine write_minmax_tensor(tfield, field_expression) + ! the tensor field to print its min and max of + type(tensor_field), intent(in):: tfield + ! the actual field in the code + character(len=*), intent(in):: field_expression - integer:: i, j + integer:: i, j - do i=1, tfield%dim(1) - do j=1, tfield%dim(2) - ewrite(2,*) 'Min, max of '//trim(field_expression)//' "'// & - trim(tfield%name)//'%'//int2str(i)//','//int2str(j)// & - '" = ', minval(tfield%val(i,j,:)), maxval(tfield%val(i,j,:)) + do i=1, tfield%dim(1) + do j=1, tfield%dim(2) + ewrite(2,*) 'Min, max of '//trim(field_expression)//' "'// & + trim(tfield%name)//'%'//int2str(i)//','//int2str(j)// & + '" = ', minval(tfield%val(i,j,:)), maxval(tfield%val(i,j,:)) + end do end do - end do - end subroutine write_minmax_tensor + end subroutine write_minmax_tensor end module fields_base diff --git a/femtools/Fields_Calculations.F90 b/femtools/Fields_Calculations.F90 index 0609f50fd8..c666c98ea5 100644 --- a/femtools/Fields_Calculations.F90 +++ b/femtools/Fields_Calculations.F90 @@ -27,920 +27,920 @@ #include "fdebug.h" module fields_calculations -use fldebug -use vector_tools -use quadrature -use elements -use parallel_tools -use fields_data_types -use fields_base -use linked_lists -use fields_allocates -use fields_manipulation -use fetools -use parallel_fields -use supermesh_construction -use intersection_finder_module + use fldebug + use vector_tools + use quadrature + use elements + use parallel_tools + use fields_data_types + use fields_base + use linked_lists + use fields_allocates + use fields_manipulation + use fetools + use parallel_fields + use supermesh_construction + use intersection_finder_module + + implicit none + + interface mean + module procedure mean_scalar + end interface + + interface maxval + module procedure maxval_scalar + end interface + + interface minval + module procedure minval_scalar + end interface + + interface sum + module procedure sum_scalar + end interface + + interface norm2 + module procedure norm2_scalar + end interface + + interface field_stats + module procedure field_stats_scalar, field_stats_vector, field_stats_tensor + end interface + + interface field_cv_stats + module procedure field_cv_stats_scalar + end interface + + interface field_con_stats + module procedure field_con_stats_scalar, field_con_stats_vector + end interface + + interface field_integral + module procedure integral_scalar, integral_vector + end interface + + interface fields_integral + module procedure integral_scalars + end interface + + interface function_val_at_quad + module procedure function_val_at_quad_scalar, function_val_at_quad_vector + end interface + + interface dot_product + module procedure dot_product_vector + end interface dot_product + + interface outer_product + module procedure outer_product_vector + end interface + + interface norm2_difference + module procedure norm2_difference_single, norm2_difference_multiple + end interface + + private + + public :: mean, maxval, minval, sum, norm2, field_stats, field_cv_stats,& + field_integral, fields_integral, function_val_at_quad,& + dot_product, outer_product, norm2_difference, magnitude,& + magnitude_tensor, merge_meshes, distance, divergence_field_stats,& + field_con_stats, function_val_at_quad_scalar, trace, mesh_integral + + integer, parameter, public :: CONVERGENCE_INFINITY_NORM=0, CONVERGENCE_L2_NORM=1, CONVERGENCE_CV_L2_NORM=2 + +contains + + function magnitude(field) + !!< Return a scalar field which is the magnitude of the vector field. + type(scalar_field) :: magnitude + type(vector_field), intent(inout) :: field + + integer :: node + + call allocate(magnitude, field%mesh,trim(field%name)//"Magnitude") + + do node=1,node_count(field) + magnitude%val(node)=norm2(node_val(field, node)) + end do -implicit none + end function magnitude - interface mean - module procedure mean_scalar - end interface + function magnitude_tensor(field) + !!< Return a scalar field which is the magnitude of the tensor field. + type(scalar_field) :: magnitude_tensor + type(tensor_field), intent(inout) :: field - interface maxval - module procedure maxval_scalar - end interface + integer :: node - interface minval - module procedure minval_scalar - end interface + call allocate(magnitude_tensor, field%mesh,trim(field%name)//"Magnitude") - interface sum - module procedure sum_scalar - end interface + do node=1,node_count(field) + magnitude_tensor%val(node)=norm2(node_val(field, node)) + end do - interface norm2 - module procedure norm2_scalar - end interface + end function magnitude_tensor - interface field_stats - module procedure field_stats_scalar, field_stats_vector, field_stats_tensor - end interface + pure function mean_scalar(field) result (mean) + !!< Return the mean value of a field + real :: mean + type(scalar_field), intent(in) :: field - interface field_cv_stats - module procedure field_cv_stats_scalar - end interface + mean = sum(field%val)/size(field%val) + end function mean_scalar - interface field_con_stats - module procedure field_con_stats_scalar, field_con_stats_vector - end interface + pure function maxval_scalar(field) result (max) + !!< Return the maximum value in a field. + real :: max + type(scalar_field), intent(in) :: field - interface field_integral - module procedure integral_scalar, integral_vector - end interface + max=maxval(field%val) - interface fields_integral - module procedure integral_scalars - end interface + end function maxval_scalar - interface function_val_at_quad - module procedure function_val_at_quad_scalar, function_val_at_quad_vector - end interface + pure function minval_scalar(field) result (min) + !!< Return the maximum value in a field. + real :: min + type(scalar_field), intent(in) :: field - interface dot_product - module procedure dot_product_vector - end interface dot_product + min=minval(field%val) - interface outer_product - module procedure outer_product_vector - end interface + end function minval_scalar - interface norm2_difference - module procedure norm2_difference_single, norm2_difference_multiple - end interface + pure function sum_scalar(field) result (sumval) + !!< Return the sum of the values of a field + real :: sumval + type(scalar_field), intent(in) :: field - private + sumval = sum(field%val) + end function sum_scalar - public :: mean, maxval, minval, sum, norm2, field_stats, field_cv_stats,& - field_integral, fields_integral, function_val_at_quad,& - dot_product, outer_product, norm2_difference, magnitude,& - magnitude_tensor, merge_meshes, distance, divergence_field_stats,& - field_con_stats, function_val_at_quad_scalar, trace, mesh_integral + function norm2_scalar(field, X) result (norm) + !!< Return the L2 norm of field: + !!< / + !!< (| |field|^2 dV)^(1/2) + !!< / + real :: norm + type(scalar_field), intent(in) :: field + !! The positions field associated with field. + type(vector_field), intent(in) :: X - integer, parameter, public :: CONVERGENCE_INFINITY_NORM=0, CONVERGENCE_L2_NORM=1, CONVERGENCE_CV_L2_NORM=2 + integer :: ele - contains + norm=0 - function magnitude(field) - !!< Return a scalar field which is the magnitude of the vector field. - type(scalar_field) :: magnitude - type(vector_field), intent(inout) :: field + do ele=1, element_count(field) + if(element_owned(field, ele)) then + norm=norm+norm2(field, X, ele) + end if + end do - integer :: node + call allsum(norm) - call allocate(magnitude, field%mesh,trim(field%name)//"Magnitude") + norm = sqrt(norm) - do node=1,node_count(field) - magnitude%val(node)=norm2(node_val(field, node)) - end do + end function norm2_scalar - end function magnitude + function norm2_scalar_cv(field, cv_mass) result (norm) + !!< Return the L2 norm of CV field: + !!< / + !!< | |field|^2 dV + !!< / + real :: norm + type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: cv_mass - function magnitude_tensor(field) - !!< Return a scalar field which is the magnitude of the tensor field. - type(scalar_field) :: magnitude_tensor - type(tensor_field), intent(inout) :: field + assert(node_count(field)==node_count(cv_mass)) - integer :: node + norm = dot_product(cv_mass%val, field%val**2) - call allocate(magnitude_tensor, field%mesh,trim(field%name)//"Magnitude") + call allsum(norm) - do node=1,node_count(field) - magnitude_tensor%val(node)=norm2(node_val(field, node)) - end do + norm = sqrt(norm) - end function magnitude_tensor + end function norm2_scalar_cv - pure function mean_scalar(field) result (mean) - !!< Return the mean value of a field - real :: mean - type(scalar_field), intent(in) :: field + function integral_scalar(field, X) result (integral) + !!< Integrate field over its mesh. + real :: integral + type(scalar_field), intent(in) :: field + !! The positions field associated with field. + type(vector_field), intent(in) :: X - mean = sum(field%val)/size(field%val) - end function mean_scalar + integer :: ele - pure function maxval_scalar(field) result (max) - !!< Return the maximum value in a field. - real :: max - type(scalar_field), intent(in) :: field + integral=0 - max=maxval(field%val) + do ele=1, element_count(field) + if(element_owned(field, ele)) then + integral=integral & + +integral_element(field, X, ele) + end if + end do - end function maxval_scalar + call allsum(integral) - pure function minval_scalar(field) result (min) - !!< Return the maximum value in a field. - real :: min - type(scalar_field), intent(in) :: field + end function integral_scalar - min=minval(field%val) + function integral_vector(field, X) result (integral) + !!< Integrate field over its mesh. + type(vector_field), intent(in) :: field + real, dimension(field%dim) :: integral + !! The positions field associated with field. + type(vector_field), intent(in) :: X - end function minval_scalar + ! Note: this is much slower than it needs to be because + ! it does the integration twice. Don't use for anything + ! important! - pure function sum_scalar(field) result (sumval) - !!< Return the sum of the values of a field - real :: sumval - type(scalar_field), intent(in) :: field + integer :: ele, i - sumval = sum(field%val) - end function sum_scalar + integral=0 - function norm2_scalar(field, X) result (norm) - !!< Return the L2 norm of field: - !!< / - !!< (| |field|^2 dV)^(1/2) - !!< / - real :: norm - type(scalar_field), intent(in) :: field - !! The positions field associated with field. - type(vector_field), intent(in) :: X + do ele=1, element_count(field) + if(element_owned(field, ele)) then + integral=integral & + +integral_element(field, X, ele) + end if + end do - integer :: ele + do i=1,field%dim + call allsum(integral(i)) + end do - norm=0 + end function integral_vector - do ele=1, element_count(field) - if(element_owned(field, ele)) then - norm=norm+norm2(field, X, ele) - end if - end do + function integral_scalar_cv(field, cv_mass) result (integral) + !!< Integrate CV field over its mesh. + real :: integral + type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: cv_mass - call allsum(norm) + assert(node_count(field)==node_count(cv_mass)) - norm = sqrt(norm) + integral = dot_product(cv_mass%val, field%val) - end function norm2_scalar + call allsum(integral) - function norm2_scalar_cv(field, cv_mass) result (norm) - !!< Return the L2 norm of CV field: - !!< / - !!< | |field|^2 dV - !!< / - real :: norm - type(scalar_field), intent(in) :: field - type(scalar_field), intent(in) :: cv_mass + end function integral_scalar_cv - assert(node_count(field)==node_count(cv_mass)) + function integral_scalars(fields, X, region_ids) result (integral) + !!< Integrate the product of fields assuming the same coordinate mesh X. + !!< If region ids is present then only integrate these associated regions + !!< else integrate the whole domain + real :: integral + type(scalar_field_pointer), dimension(:), intent(in) :: fields + !! The positions field associated with the fields. + type(vector_field), intent(in) :: X + integer, dimension(:), intent(in), optional :: region_ids - norm = dot_product(cv_mass%val, field%val**2) + integer :: ele + integer :: s + integer :: id + integer :: ele_id + logical :: found_id - call allsum(norm) + integral=0 - norm = sqrt(norm) + ! Ideally there needs to be an assertion that the fields are associated + ! with the same positions mesh X - end function norm2_scalar_cv + ! assert that each scalar field has the same number of elements + ! and the same dim as positions mesh X + do s = 1,size(fields) - function integral_scalar(field, X) result (integral) - !!< Integrate field over its mesh. - real :: integral - type(scalar_field), intent(in) :: field - !! The positions field associated with field. - type(vector_field), intent(in) :: X + assert(ele_count(X) == ele_count(fields(s)%ptr)) + + assert(mesh_dim(X) == mesh_dim(fields(s)%ptr)) + + end do - integer :: ele + ! if region_ids is present assert that it has something + if (present(region_ids)) then - integral=0 + assert(size(region_ids) > 0) - do ele=1, element_count(field) - if(element_owned(field, ele)) then - integral=integral & - +integral_element(field, X, ele) end if - end do - call allsum(integral) + velement_loop: do ele=1, element_count(fields(1)%ptr) - end function integral_scalar + if(element_owned(fields(1)%ptr, ele)) then - function integral_vector(field, X) result (integral) - !!< Integrate field over its mesh. - type(vector_field), intent(in) :: field - real, dimension(field%dim) :: integral - !! The positions field associated with field. - type(vector_field), intent(in) :: X + ! if present only conisder input region_ids + region_id_present: if (present(region_ids)) then - ! Note: this is much slower than it needs to be because - ! it does the integration twice. Don't use for anything - ! important! + ! initialise flag for whether this volume element ele should be considered + found_id = .false. - integer :: ele, i + ! find the positions X field ele region id + ele_id = ele_region_id(X,ele) - integral=0 + region_id_loop: do id = 1,size(region_ids) - do ele=1, element_count(field) - if(element_owned(field, ele)) then - integral=integral & - +integral_element(field, X, ele) - end if - end do + check_id: if (ele_id == region_ids(id)) then - do i=1,field%dim - call allsum(integral(i)) - end do + found_id = .true. - end function integral_vector + exit region_id_loop - function integral_scalar_cv(field, cv_mass) result (integral) - !!< Integrate CV field over its mesh. - real :: integral - type(scalar_field), intent(in) :: field - type(scalar_field), intent(in) :: cv_mass + end if check_id - assert(node_count(field)==node_count(cv_mass)) + end do region_id_loop - integral = dot_product(cv_mass%val, field%val) + ! if not found an id match then cycle the volume element loop + if (.not. found_id) cycle velement_loop - call allsum(integral) + end if region_id_present - end function integral_scalar_cv + integral=integral + integral_element(fields, X, ele) - function integral_scalars(fields, X, region_ids) result (integral) - !!< Integrate the product of fields assuming the same coordinate mesh X. - !!< If region ids is present then only integrate these associated regions - !!< else integrate the whole domain - real :: integral - type(scalar_field_pointer), dimension(:), intent(in) :: fields - !! The positions field associated with the fields. - type(vector_field), intent(in) :: X - integer, dimension(:), intent(in), optional :: region_ids + end if - integer :: ele - integer :: s - integer :: id - integer :: ele_id - logical :: found_id + end do velement_loop - integral=0 + call allsum(integral) - ! Ideally there needs to be an assertion that the fields are associated - ! with the same positions mesh X + end function integral_scalars - ! assert that each scalar field has the same number of elements - ! and the same dim as positions mesh X - do s = 1,size(fields) + function mesh_integral(X) result (integral) + !!< Integrate mesh volume. + real :: integral + !! The positions field. + type(vector_field), intent(in) :: X - assert(ele_count(X) == ele_count(fields(s)%ptr)) + integer :: ele - assert(mesh_dim(X) == mesh_dim(fields(s)%ptr)) + integral=0 + do ele=1, element_count(X) + if (element_owned(X, ele)) then + integral = integral + element_volume(X, ele) + end if + end do - end do + call allsum(integral) + + end function mesh_integral + + subroutine field_stats_scalar(field, X, min, max, norm2, integral) + !!< Return scalar statistical informaion about field. + type(scalar_field) :: field + !! Positions field associated with field + type(vector_field), optional :: X + !! Minimum value in the field. + real, intent(out), optional :: min + !! Maximum value in the field. + real, intent(out), optional :: max + !! L2 norm of the field. This requires positions to be specified as + !! well. + real, intent(out), optional :: norm2 + !! Integral of the field. This requires positions to be specified as + !! well. + real, intent(out), optional :: integral + + if (present(min)) then + min=minval(field%val) + call allmin(min) + end if - ! if region_ids is present assert that it has something - if (present(region_ids)) then + if (present(max)) then + max=maxval(field%val) + call allmax(max) + end if - assert(size(region_ids) > 0) + if (present(X).and.present(norm2)) then - end if + norm2=norm2_scalar(field, X) - velement_loop: do ele=1, element_count(fields(1)%ptr) + elseif (present(norm2)) then + FLAbort("Cannot evaluate L2 norm without providing positions field") + end if - if(element_owned(fields(1)%ptr, ele)) then + if (present(X).and.present(integral)) then - ! if present only conisder input region_ids - region_id_present: if (present(region_ids)) then + integral=integral_scalar(field, X) - ! initialise flag for whether this volume element ele should be considered - found_id = .false. + elseif (present(integral)) then + FLAbort("Cannot evaluate integral without providing positions field") + end if - ! find the positions X field ele region id - ele_id = ele_region_id(X,ele) + end subroutine field_stats_scalar - region_id_loop: do id = 1,size(region_ids) + subroutine field_cv_stats_scalar(field, cv_mass, norm2, integral) + !!< Return scalar statistical informaion about field. + type(scalar_field), intent(in) :: field + type(scalar_field), intent(in) :: cv_mass + !! L2 norm of the field. This requires positions to be specified as + !! well. + real, intent(out), optional :: norm2 + !! Integral of the field. This requires positions to be specified as + !! well. + real, intent(out), optional :: integral - check_id: if (ele_id == region_ids(id)) then + if (present(norm2)) then - found_id = .true. + norm2=norm2_scalar_cv(field, cv_mass) - exit region_id_loop + end if - end if check_id + if (present(integral)) then - end do region_id_loop + integral=integral_scalar_cv(field, cv_mass) - ! if not found an id match then cycle the volume element loop - if (.not. found_id) cycle velement_loop + end if - end if region_id_present + end subroutine field_cv_stats_scalar - integral=integral + integral_element(fields, X, ele) + subroutine field_stats_vector(field, X, min, max, norm2) + !!< Return scalar statistical information about field. For a vector + !!< field the statistics are calculated on the magnitude of the field. + type(vector_field) :: field + !! Positions field assocated with field + type(vector_field), optional :: X + !! Minimum value in the field. + real, intent(out), optional :: min + !! Maximum value in the field. + real, intent(out), optional :: max + !! L2 norm of the field. This requires positions to be specified as + !! well. + real, intent(out), optional :: norm2 - end if + type(scalar_field) :: mag - end do velement_loop + mag=magnitude(field) - call allsum(integral) + call field_stats(mag, X, min, max, norm2) - end function integral_scalars + call deallocate(mag) - function mesh_integral(X) result (integral) - !!< Integrate mesh volume. - real :: integral - !! The positions field. - type(vector_field), intent(in) :: X + end subroutine field_stats_vector - integer :: ele + subroutine field_stats_tensor(field, X, min, max, norm2) + !!< Return scalar statistical information about field. For a tensor + !!< field the statistics are calculated on the magnitude of the field. + type(tensor_field) :: field + !! Positions field assocated with field + type(vector_field), optional :: X + !! Minimum value in the field. + real, intent(out), optional :: min + !! Maximum value in the field. + real, intent(out), optional :: max + !! L2 norm of the field. This requires positions to be specified as + !! well. + real, intent(out), optional :: norm2 - integral=0 - do ele=1, element_count(X) - if (element_owned(X, ele)) then - integral = integral + element_volume(X, ele) - end if - end do + type(scalar_field) :: mag - call allsum(integral) + mag=magnitude_tensor(field) - end function mesh_integral + call field_stats(mag, X, min, max, norm2) - subroutine field_stats_scalar(field, X, min, max, norm2, integral) - !!< Return scalar statistical informaion about field. - type(scalar_field) :: field - !! Positions field associated with field - type(vector_field), optional :: X - !! Minimum value in the field. - real, intent(out), optional :: min - !! Maximum value in the field. - real, intent(out), optional :: max - !! L2 norm of the field. This requires positions to be specified as - !! well. - real, intent(out), optional :: norm2 - !! Integral of the field. This requires positions to be specified as - !! well. - real, intent(out), optional :: integral + call deallocate(mag) - if (present(min)) then - min=minval(field%val) - call allmin(min) - end if + end subroutine field_stats_tensor - if (present(max)) then - max=maxval(field%val) - call allmax(max) - end if + subroutine field_con_stats_scalar(field, nlfield, error, & + norm, coordinates, cv_mass) + !!< Return scalar convergence informaion about field. + type(scalar_field), intent(inout) :: field, nlfield + !! error in the field. + real, intent(out) :: error + !! what norm are we working out + integer, intent(in), optional :: norm + type(vector_field), intent(in), optional :: coordinates + type(scalar_field), intent(in), optional :: cv_mass - if (present(X).and.present(norm2)) then + type(scalar_field) :: difference + integer :: l_norm - norm2=norm2_scalar(field, X) + if(present(norm)) then + l_norm = norm + else + l_norm = CONVERGENCE_INFINITY_NORM + end if - elseif (present(norm2)) then - FLAbort("Cannot evaluate L2 norm without providing positions field") - end if + assert(field%mesh==nlfield%mesh) + + call allocate(difference, field%mesh, "Difference") + call set(difference, field) + call addto(difference, nlfield, -1.0) + call absolute_value(difference) + + select case(l_norm) + case(CONVERGENCE_INFINITY_NORM) + error = maxval(difference%val) + call allmax(error) + case(CONVERGENCE_L2_NORM) + call field_stats(difference, X=coordinates, norm2=error) + case(CONVERGENCE_CV_L2_NORM) + if (present(cv_mass)) then + call field_cv_stats(difference, cv_mass=cv_mass, norm2=error) + else + FLAbort('Require cv_mass to calculate field_cv_stats') + end if + case default + FLAbort("Unknown norm for convergence statistics.") + end select + + call deallocate(difference) + + end subroutine field_con_stats_scalar + + subroutine field_con_stats_vector(field, nlfield, error, & + norm, coordinates) + !!< Return scalar convergence information about field. For a vector + !!< field the statistics are calculated on the magnitude of the field. + type(vector_field) :: field, nlfield + !! error in the field. + real, intent(out) :: error + integer, intent(in), optional :: norm + type(vector_field), intent(in), optional :: coordinates + + type(scalar_field) :: mag, nlmag + + mag=magnitude(field) + nlmag=magnitude(nlfield) + + call field_con_stats(mag, nlmag, error, & + norm, coordinates) + + call deallocate(mag) + call deallocate(nlmag) + + end subroutine field_con_stats_vector + + subroutine divergence_field_stats(field, X, field_min, field_max, field_norm2, field_integral) + !!< Return scalar statistical informaion about the divergence of field. + type(vector_field) :: field + !! Positions field associated with field + type(vector_field) :: X + !! Minimum value in the field. + real, intent(out) :: field_min + !! Maximum value in the field. + real, intent(out) :: field_max + !! L2 norm of the field. This requires positions to be specified as + !! well. + real, intent(out) :: field_norm2 + !! Integral of the field. This requires positions to be specified as + !! well. + real, intent(out) :: field_integral + + integer :: ele + real :: ele_min, ele_max, ele_norm2, ele_integral + + field_min = huge(0.0) + field_max = -huge(0.0) + field_norm2 = 0.0 + field_integral = 0.0 + + do ele = 1, ele_count(field) + call divergence_field_stats_element(ele, field, X, ele_min, ele_max, ele_norm2, ele_integral) + field_min = min(field_min, ele_min) + field_max = max(field_max, ele_max) + field_norm2 = field_norm2 + ele_norm2 + field_integral = field_integral + ele_integral + end do - if (present(X).and.present(integral)) then + call allmin(field_min) + call allmax(field_max) + call allsum(field_norm2) + field_norm2 = sqrt(field_norm2) + call allsum(field_integral) - integral=integral_scalar(field, X) + contains - elseif (present(integral)) then - FLAbort("Cannot evaluate integral without providing positions field") - end if + subroutine divergence_field_stats_element(ele, field, X, ele_min, ele_max, ele_norm2, ele_integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: field, X + real, intent(inout) :: ele_min, ele_max, ele_norm2, ele_integral - end subroutine field_stats_scalar + real, dimension(ele_loc(field, ele), ele_ngi(field, ele), mesh_dim(field)) :: df_t + real, dimension(ele_ngi(field, ele)) :: detwei, field_div_at_quad - subroutine field_cv_stats_scalar(field, cv_mass, norm2, integral) - !!< Return scalar statistical informaion about field. - type(scalar_field), intent(in) :: field - type(scalar_field), intent(in) :: cv_mass - !! L2 norm of the field. This requires positions to be specified as - !! well. - real, intent(out), optional :: norm2 - !! Integral of the field. This requires positions to be specified as - !! well. - real, intent(out), optional :: integral + call transform_to_physical(X, ele, & + & ele_shape(field, ele), dshape = df_t, detwei = detwei) - if (present(norm2)) then + field_div_at_quad = ele_div_at_quad(field, ele, df_t) - norm2=norm2_scalar_cv(field, cv_mass) + ele_min = minval(field_div_at_quad) + ele_max = maxval(field_div_at_quad) + ele_norm2 = dot_product(field_div_at_quad*field_div_at_quad, detwei) + ele_integral = dot_product(field_div_at_quad, detwei) - end if + end subroutine divergence_field_stats_element - if (present(integral)) then + end subroutine divergence_field_stats - integral=integral_scalar_cv(field, cv_mass) + function distance(positions, p, q) result(dist) + !!< Return the euclidean distance between nodes p and q. + type(vector_field), intent(in) :: positions + integer, intent(in) :: p, q + real :: dist + integer :: i - end if + dist = 0.0 + do i=1,positions%dim + dist = dist + (node_val(positions, i, p) - node_val(positions, i, q))**2 + end do + + dist = sqrt(dist) + + end function distance + + subroutine trace(tensor, output) + type(tensor_field), intent(in) :: tensor + type(scalar_field), intent(inout) :: output - end subroutine field_cv_stats_scalar + integer :: i, j + real, dimension(tensor%dim(1), tensor%dim(2)) :: val + real :: x - subroutine field_stats_vector(field, X, min, max, norm2) - !!< Return scalar statistical information about field. For a vector - !!< field the statistics are calculated on the magnitude of the field. - type(vector_field) :: field - !! Positions field assocated with field - type(vector_field), optional :: X - !! Minimum value in the field. - real, intent(out), optional :: min - !! Maximum value in the field. - real, intent(out), optional :: max - !! L2 norm of the field. This requires positions to be specified as - !! well. - real, intent(out), optional :: norm2 - - type(scalar_field) :: mag - - mag=magnitude(field) - - call field_stats(mag, X, min, max, norm2) - - call deallocate(mag) - - end subroutine field_stats_vector - - subroutine field_stats_tensor(field, X, min, max, norm2) - !!< Return scalar statistical information about field. For a tensor - !!< field the statistics are calculated on the magnitude of the field. - type(tensor_field) :: field - !! Positions field assocated with field - type(vector_field), optional :: X - !! Minimum value in the field. - real, intent(out), optional :: min - !! Maximum value in the field. - real, intent(out), optional :: max - !! L2 norm of the field. This requires positions to be specified as - !! well. - real, intent(out), optional :: norm2 - - type(scalar_field) :: mag - - mag=magnitude_tensor(field) + do i=1,node_count(tensor) + x = 0.0 - call field_stats(mag, X, min, max, norm2) + val = node_val(tensor, i) + do j=1,minval(tensor%dim) + x = x + val(j, j) + end do - call deallocate(mag) + call set(output, i, x) + end do + end subroutine trace + + function dot_product_vector(fieldA, fieldB, X) result(val) + type(vector_field), intent(in) :: fieldA, fieldB, X + real :: val - end subroutine field_stats_tensor + integer :: ele - subroutine field_con_stats_scalar(field, nlfield, error, & - norm, coordinates, cv_mass) - !!< Return scalar convergence informaion about field. - type(scalar_field), intent(inout) :: field, nlfield - !! error in the field. - real, intent(out) :: error - !! what norm are we working out - integer, intent(in), optional :: norm - type(vector_field), intent(in), optional :: coordinates - type(scalar_field), intent(in), optional :: cv_mass + assert(fieldA%dim==fieldB%dim) - type(scalar_field) :: difference - integer :: l_norm + if (.not. associated(fieldA%mesh%refcount, fieldB%mesh%refcount)) then + ewrite(-1,*) "Hello! dot_product_vector here." + ewrite(-1,*) "I couldn't be bothered remapping the fields," + ewrite(-1,*) "even though this is perfectly possible." + ewrite(-1,*) "Code this up to remap the fields to continue!" + FLAbort("Programmmer laziness detected") + end if - if(present(norm)) then - l_norm = norm - else - l_norm = CONVERGENCE_INFINITY_NORM - end if - - assert(field%mesh==nlfield%mesh) - - call allocate(difference, field%mesh, "Difference") - call set(difference, field) - call addto(difference, nlfield, -1.0) - call absolute_value(difference) - - select case(l_norm) - case(CONVERGENCE_INFINITY_NORM) - error = maxval(difference%val) - call allmax(error) - case(CONVERGENCE_L2_NORM) - call field_stats(difference, X=coordinates, norm2=error) - case(CONVERGENCE_CV_L2_NORM) - if (present(cv_mass)) then - call field_cv_stats(difference, cv_mass=cv_mass, norm2=error) + if (fieldA%field_type == FIELD_TYPE_CONSTANT .and. fieldB%field_type == FIELD_TYPE_CONSTANT) then + val = dot_product(fieldA%val(:,1), fieldB%val(:,1)) * mesh_integral(X) else - FLAbort('Require cv_mass to calculate field_cv_stats') + val = 0 + + do ele=1, element_count(fieldA) + if(element_owned(fieldA, ele)) then + val = val + dot_integral_element(fieldA, fieldB, X, ele) + end if + end do + + call allsum(val) + + end if + end function dot_product_vector + + function outer_product_vector(fieldA, fieldB) result(val) + type(vector_field), intent(in) :: fieldA, fieldB + real, dimension(fieldA%dim,fieldB%dim) :: val + integer :: i, d1,d2 + real, dimension(fieldA%dim) :: tmpA + real, dimension(fieldB%dim) :: tmpB + + if (.not. associated(fieldA%mesh%refcount, fieldB%mesh%refcount)) then + ewrite(-1,*) "Hello! outer_product_vector here." + ewrite(-1,*) "I couldn't be bothered remapping the fields," + ewrite(-1,*) "even though this is perfectly possible." + ewrite(-1,*) "Code this up to remap the fields to continue!" + FLAbort("Programmmer laziness detected") end if - case default - FLAbort("Unknown norm for convergence statistics.") - end select - - call deallocate(difference) - - end subroutine field_con_stats_scalar - - subroutine field_con_stats_vector(field, nlfield, error, & - norm, coordinates) - !!< Return scalar convergence information about field. For a vector - !!< field the statistics are calculated on the magnitude of the field. - type(vector_field) :: field, nlfield - !! error in the field. - real, intent(out) :: error - integer, intent(in), optional :: norm - type(vector_field), intent(in), optional :: coordinates - - type(scalar_field) :: mag, nlmag - - mag=magnitude(field) - nlmag=magnitude(nlfield) - - call field_con_stats(mag, nlmag, error, & - norm, coordinates) - - call deallocate(mag) - call deallocate(nlmag) - - end subroutine field_con_stats_vector - - subroutine divergence_field_stats(field, X, field_min, field_max, field_norm2, field_integral) - !!< Return scalar statistical informaion about the divergence of field. - type(vector_field) :: field - !! Positions field associated with field - type(vector_field) :: X - !! Minimum value in the field. - real, intent(out) :: field_min - !! Maximum value in the field. - real, intent(out) :: field_max - !! L2 norm of the field. This requires positions to be specified as - !! well. - real, intent(out) :: field_norm2 - !! Integral of the field. This requires positions to be specified as - !! well. - real, intent(out) :: field_integral - - integer :: ele - real :: ele_min, ele_max, ele_norm2, ele_integral - - field_min = huge(0.0) - field_max = -huge(0.0) - field_norm2 = 0.0 - field_integral = 0.0 - - do ele = 1, ele_count(field) - call divergence_field_stats_element(ele, field, X, ele_min, ele_max, ele_norm2, ele_integral) - field_min = min(field_min, ele_min) - field_max = max(field_max, ele_max) - field_norm2 = field_norm2 + ele_norm2 - field_integral = field_integral + ele_integral - end do - - call allmin(field_min) - call allmax(field_max) - call allsum(field_norm2) - field_norm2 = sqrt(field_norm2) - call allsum(field_integral) - - contains - - subroutine divergence_field_stats_element(ele, field, X, ele_min, ele_max, ele_norm2, ele_integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: field, X - real, intent(inout) :: ele_min, ele_max, ele_norm2, ele_integral - - real, dimension(ele_loc(field, ele), ele_ngi(field, ele), mesh_dim(field)) :: df_t - real, dimension(ele_ngi(field, ele)) :: detwei, field_div_at_quad - - call transform_to_physical(X, ele, & - & ele_shape(field, ele), dshape = df_t, detwei = detwei) - - field_div_at_quad = ele_div_at_quad(field, ele, df_t) - - ele_min = minval(field_div_at_quad) - ele_max = maxval(field_div_at_quad) - ele_norm2 = dot_product(field_div_at_quad*field_div_at_quad, detwei) - ele_integral = dot_product(field_div_at_quad, detwei) - - end subroutine divergence_field_stats_element - - end subroutine divergence_field_stats - - function distance(positions, p, q) result(dist) - !!< Return the euclidean distance between nodes p and q. - type(vector_field), intent(in) :: positions - integer, intent(in) :: p, q - real :: dist - integer :: i - - dist = 0.0 - do i=1,positions%dim - dist = dist + (node_val(positions, i, p) - node_val(positions, i, q))**2 - end do - - dist = sqrt(dist) - - end function distance - - subroutine trace(tensor, output) - type(tensor_field), intent(in) :: tensor - type(scalar_field), intent(inout) :: output - - integer :: i, j - real, dimension(tensor%dim(1), tensor%dim(2)) :: val - real :: x - do i=1,node_count(tensor) - x = 0.0 - - val = node_val(tensor, i) - do j=1,minval(tensor%dim) - x = x + val(j, j) + if ((fieldA%field_type == FIELD_TYPE_NORMAL) .and. & + (fieldB%field_type == FIELD_TYPE_NORMAL)) then + do d1=1,fieldA%dim + do d2=1,fieldB%dim + val(d1,d2) = dot_product(fieldA%val(d1,:), fieldB%val(d2,:)) + end do + end do + else if (fieldA%field_type == FIELD_TYPE_CONSTANT .and. fieldB%field_type == FIELD_TYPE_CONSTANT) then + do d1=1,fieldA%dim + do d2=1,fieldB%dim + val(d1,d2) = fieldA%val(d1,1) * fieldB%val(d2,1) * node_count(fieldA) + end do + end do + else + val = 0.0 + do i=1,node_count(fieldA) + tmpA=node_val(fieldA, i) + tmpB=node_val(fieldB, i) + do d1=1,fieldA%dim + do d2=1,fieldB%dim + val(d1,d2) = val(d1,d2) + tmpA(d1) * tmpB(d2) + end do + end do + end do + end if + end function outer_product_vector + + function function_val_at_quad_scalar(fxn, positions, ele) + interface + function fxn(pos) + real, dimension(:), intent(in) :: pos + real :: fxn + end function + end interface + type(vector_field), intent(in) :: positions + integer :: ele, ngi + + real, dimension(positions%dim, ele_ngi(positions, ele)) :: pos + real, dimension(ele_ngi(positions, ele)) :: function_val_at_quad_scalar + + pos = ele_val_at_quad(positions, ele) + do ngi=1,ele_ngi(positions, ele) + function_val_at_quad_scalar(ngi) = fxn(pos(:, ngi)) + end do + end function function_val_at_quad_scalar + + function function_val_at_quad_vector(fxn, positions, ele) + interface + function fxn(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: fxn + end function + end interface + type(vector_field), intent(in) :: positions + integer :: ele, ngi + + real, dimension(positions%dim, ele_ngi(positions, ele)) :: pos + real, dimension(positions%dim, ele_ngi(positions, ele)) :: function_val_at_quad_vector + + pos = ele_val_at_quad(positions, ele) + do ngi=1,ele_ngi(positions, ele) + function_val_at_quad_vector(:, ngi) = fxn(pos(:, ngi)) + end do + end function function_val_at_quad_vector + + function norm2_difference_single(fieldA, positionsA, fieldB, positionsB) result(norm) + !! Return ||fieldA - fieldB||_2. + !! Since positionsA and positionsB are different, we need to supermesh! + !! If positionsA and positionsB are the same, don't use this: + !! it will be much slower than necessary. + type(scalar_field), intent(in) :: fieldA, fieldB + type(vector_field), intent(in) :: positionsA, positionsB + real :: norm + type(ilist), dimension(ele_count(positionsB)) :: map_BA + integer :: ele_A, ele_B + + type(quadrature_type) :: supermesh_quad + type(element_type) :: supermesh_positions_shape, supermesh_fields_shape + + type(vector_field) :: supermesh + real :: ele_error + + real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1)) :: inversion_matrix_B + real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1), ele_count(positionsA)) :: inversion_matrices_A + integer :: dim, max_degree + + norm = 0.0 + dim = mesh_dim(positionsB) + call intersector_set_dimension(dim) + + max_degree = max(element_degree(fieldA, 1), element_degree(fieldB, 1)) + supermesh_quad = make_quadrature(vertices=ele_loc(positionsB, 1), dim=dim, & + & degree=2*max_degree) + supermesh_positions_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=1, quad=supermesh_quad) + supermesh_fields_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=max_degree, quad=supermesh_quad) + map_BA = intersection_finder(positionsB, positionsA) + + do ele_A=1,ele_count(positionsA) + call local_coords_matrix(positionsA, ele_A, inversion_matrices_A(:, :, ele_A)) end do - call set(output, i, x) - end do - end subroutine trace + do ele_B=1,ele_count(positionsB) + call local_coords_matrix(positionsB, ele_B, inversion_matrix_B) + ! Construct the supermesh associated with ele_B. + call construct_supermesh(positionsB, ele_B, positionsA, map_BA(ele_B), supermesh_positions_shape, supermesh) - function dot_product_vector(fieldA, fieldB, X) result(val) - type(vector_field), intent(in) :: fieldA, fieldB, X - real :: val + ! Interpolate fieldA onto the supermesh. + ! Interpolate fieldB onto the supermesh. + ! Compute the l2norm**2 of the difference. + call compute_projection_error(fieldA, positionsA, supermesh_fields_shape, ele_val(fieldB, ele_B), positionsB, ele_B, supermesh, & + inversion_matrices_A, inversion_matrix_B, ele_error) - integer :: ele + norm = norm + ele_error + call deallocate(supermesh) + end do + + norm = sqrt(norm) - assert(fieldA%dim==fieldB%dim) + call deallocate(supermesh_quad) + call deallocate(supermesh_positions_shape) + call deallocate(supermesh_fields_shape) + do ele_B=1,ele_count(positionsB) + call deallocate(map_BA(ele_B)) + end do - if (.not. associated(fieldA%mesh%refcount, fieldB%mesh%refcount)) then - ewrite(-1,*) "Hello! dot_product_vector here." - ewrite(-1,*) "I couldn't be bothered remapping the fields," - ewrite(-1,*) "even though this is perfectly possible." - ewrite(-1,*) "Code this up to remap the fields to continue!" - FLAbort("Programmmer laziness detected") - end if + end function norm2_difference_single - if (fieldA%field_type == FIELD_TYPE_CONSTANT .and. fieldB%field_type == FIELD_TYPE_CONSTANT) then - val = dot_product(fieldA%val(:,1), fieldB%val(:,1)) * mesh_integral(X) - else - val = 0 + function norm2_difference_multiple(fieldA, positionsA, fieldB, positionsB) result(norm) + !! Return ||fieldA - fieldB||_2. + !! Since positionsA and positionsB are different, we need to supermesh! + !! If positionsA and positionsB are the same, don't use this: + !! it will be much slower than necessary. + type(scalar_field), dimension(:), intent(in) :: fieldA, fieldB + type(vector_field), intent(in) :: positionsA, positionsB + real, dimension(size(fieldA)) :: norm + type(ilist), dimension(ele_count(positionsB)) :: map_BA + integer :: ele_A, ele_B - do ele=1, element_count(fieldA) - if(element_owned(fieldA, ele)) then - val = val + dot_integral_element(fieldA, fieldB, X, ele) - end if - end do - - call allsum(val) - - end if - end function dot_product_vector - - function outer_product_vector(fieldA, fieldB) result(val) - type(vector_field), intent(in) :: fieldA, fieldB - real, dimension(fieldA%dim,fieldB%dim) :: val - integer :: i, d1,d2 - real, dimension(fieldA%dim) :: tmpA - real, dimension(fieldB%dim) :: tmpB - - if (.not. associated(fieldA%mesh%refcount, fieldB%mesh%refcount)) then - ewrite(-1,*) "Hello! outer_product_vector here." - ewrite(-1,*) "I couldn't be bothered remapping the fields," - ewrite(-1,*) "even though this is perfectly possible." - ewrite(-1,*) "Code this up to remap the fields to continue!" - FLAbort("Programmmer laziness detected") - end if - - if ((fieldA%field_type == FIELD_TYPE_NORMAL) .and. & - (fieldB%field_type == FIELD_TYPE_NORMAL)) then - do d1=1,fieldA%dim - do d2=1,fieldB%dim - val(d1,d2) = dot_product(fieldA%val(d1,:), fieldB%val(d2,:)) - end do - end do - else if (fieldA%field_type == FIELD_TYPE_CONSTANT .and. fieldB%field_type == FIELD_TYPE_CONSTANT) then - do d1=1,fieldA%dim - do d2=1,fieldB%dim - val(d1,d2) = fieldA%val(d1,1) * fieldB%val(d2,1) * node_count(fieldA) - end do - end do - else - val = 0.0 - do i=1,node_count(fieldA) - tmpA=node_val(fieldA, i) - tmpB=node_val(fieldB, i) - do d1=1,fieldA%dim - do d2=1,fieldB%dim - val(d1,d2) = val(d1,d2) + tmpA(d1) * tmpB(d2) - end do - end do - end do - end if - end function outer_product_vector - - function function_val_at_quad_scalar(fxn, positions, ele) - interface - function fxn(pos) - real, dimension(:), intent(in) :: pos - real :: fxn - end function - end interface - type(vector_field), intent(in) :: positions - integer :: ele, ngi - - real, dimension(positions%dim, ele_ngi(positions, ele)) :: pos - real, dimension(ele_ngi(positions, ele)) :: function_val_at_quad_scalar - - pos = ele_val_at_quad(positions, ele) - do ngi=1,ele_ngi(positions, ele) - function_val_at_quad_scalar(ngi) = fxn(pos(:, ngi)) - end do - end function function_val_at_quad_scalar - - function function_val_at_quad_vector(fxn, positions, ele) - interface - function fxn(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: fxn - end function - end interface - type(vector_field), intent(in) :: positions - integer :: ele, ngi - - real, dimension(positions%dim, ele_ngi(positions, ele)) :: pos - real, dimension(positions%dim, ele_ngi(positions, ele)) :: function_val_at_quad_vector - - pos = ele_val_at_quad(positions, ele) - do ngi=1,ele_ngi(positions, ele) - function_val_at_quad_vector(:, ngi) = fxn(pos(:, ngi)) - end do - end function function_val_at_quad_vector - - function norm2_difference_single(fieldA, positionsA, fieldB, positionsB) result(norm) - !! Return ||fieldA - fieldB||_2. - !! Since positionsA and positionsB are different, we need to supermesh! - !! If positionsA and positionsB are the same, don't use this: - !! it will be much slower than necessary. - type(scalar_field), intent(in) :: fieldA, fieldB - type(vector_field), intent(in) :: positionsA, positionsB - real :: norm - type(ilist), dimension(ele_count(positionsB)) :: map_BA - integer :: ele_A, ele_B - - type(quadrature_type) :: supermesh_quad - type(element_type) :: supermesh_positions_shape, supermesh_fields_shape - - type(vector_field) :: supermesh - real :: ele_error - - real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1)) :: inversion_matrix_B - real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1), ele_count(positionsA)) :: inversion_matrices_A - integer :: dim, max_degree - - norm = 0.0 - dim = mesh_dim(positionsB) - call intersector_set_dimension(dim) - - max_degree = max(element_degree(fieldA, 1), element_degree(fieldB, 1)) - supermesh_quad = make_quadrature(vertices=ele_loc(positionsB, 1), dim=dim, & - & degree=2*max_degree) - supermesh_positions_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=1, quad=supermesh_quad) - supermesh_fields_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=max_degree, quad=supermesh_quad) - map_BA = intersection_finder(positionsB, positionsA) - - do ele_A=1,ele_count(positionsA) - call local_coords_matrix(positionsA, ele_A, inversion_matrices_A(:, :, ele_A)) - end do - - do ele_B=1,ele_count(positionsB) - call local_coords_matrix(positionsB, ele_B, inversion_matrix_B) - ! Construct the supermesh associated with ele_B. - call construct_supermesh(positionsB, ele_B, positionsA, map_BA(ele_B), supermesh_positions_shape, supermesh) - - ! Interpolate fieldA onto the supermesh. - ! Interpolate fieldB onto the supermesh. - ! Compute the l2norm**2 of the difference. - call compute_projection_error(fieldA, positionsA, supermesh_fields_shape, ele_val(fieldB, ele_B), positionsB, ele_B, supermesh, & - inversion_matrices_A, inversion_matrix_B, ele_error) - - norm = norm + ele_error - call deallocate(supermesh) - end do - - norm = sqrt(norm) - - call deallocate(supermesh_quad) - call deallocate(supermesh_positions_shape) - call deallocate(supermesh_fields_shape) - do ele_B=1,ele_count(positionsB) - call deallocate(map_BA(ele_B)) - end do - - end function norm2_difference_single - - function norm2_difference_multiple(fieldA, positionsA, fieldB, positionsB) result(norm) - !! Return ||fieldA - fieldB||_2. - !! Since positionsA and positionsB are different, we need to supermesh! - !! If positionsA and positionsB are the same, don't use this: - !! it will be much slower than necessary. - type(scalar_field), dimension(:), intent(in) :: fieldA, fieldB - type(vector_field), intent(in) :: positionsA, positionsB - real, dimension(size(fieldA)) :: norm - type(ilist), dimension(ele_count(positionsB)) :: map_BA - integer :: ele_A, ele_B - - type(quadrature_type) :: supermesh_quad - type(element_type) :: supermesh_positions_shape, supermesh_fields_shape - - type(vector_field) :: supermesh - real :: ele_error - - real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1)) :: inversion_matrix_B - real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1), ele_count(positionsA)) :: inversion_matrices_A - integer :: dim, max_degree, field, field_count - - field_count = size(fieldA) - assert(size(fieldB) == field_count) - norm = 0.0 - dim = mesh_dim(positionsB) - call intersector_set_dimension(dim) - - max_degree = 0 - do field=1,field_count - max_degree = max(max_degree, max(element_degree(fieldA(field), 1), element_degree(fieldB(field), 1))) - end do - supermesh_quad = make_quadrature(vertices=ele_loc(positionsB, 1), dim=dim, & - & degree=2*max_degree) - supermesh_positions_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=1, quad=supermesh_quad) - supermesh_fields_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=max_degree, quad=supermesh_quad) - map_BA = intersection_finder(positionsB, positionsA) - - do ele_A=1,ele_count(positionsA) - call local_coords_matrix(positionsA, ele_A, inversion_matrices_A(:, :, ele_A)) - end do - - do ele_B=1,ele_count(positionsB) - call local_coords_matrix(positionsB, ele_B, inversion_matrix_B) - ! Construct the supermesh associated with ele_B. - call construct_supermesh(positionsB, ele_B, positionsA, map_BA(ele_B), supermesh_positions_shape, supermesh) - - ! Interpolate fieldA onto the supermesh. - ! Interpolate fieldB onto the supermesh. - ! Compute the l2norm**2 of the difference. + type(quadrature_type) :: supermesh_quad + type(element_type) :: supermesh_positions_shape, supermesh_fields_shape + + type(vector_field) :: supermesh + real :: ele_error + + real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1)) :: inversion_matrix_B + real, dimension(ele_loc(positionsB, 1), ele_loc(positionsB, 1), ele_count(positionsA)) :: inversion_matrices_A + integer :: dim, max_degree, field, field_count + + field_count = size(fieldA) + assert(size(fieldB) == field_count) + norm = 0.0 + dim = mesh_dim(positionsB) + call intersector_set_dimension(dim) + + max_degree = 0 do field=1,field_count - call compute_projection_error(fieldA(field), positionsA, supermesh_fields_shape, ele_val(fieldB(field), ele_B), positionsB, ele_B, supermesh, & - inversion_matrices_A, inversion_matrix_B, ele_error) - norm(field) = norm(field) + ele_error + max_degree = max(max_degree, max(element_degree(fieldA(field), 1), element_degree(fieldB(field), 1))) + end do + supermesh_quad = make_quadrature(vertices=ele_loc(positionsB, 1), dim=dim, & + & degree=2*max_degree) + supermesh_positions_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=1, quad=supermesh_quad) + supermesh_fields_shape = make_element_shape(vertices=ele_loc(positionsB, 1), dim=dim, degree=max_degree, quad=supermesh_quad) + map_BA = intersection_finder(positionsB, positionsA) + + do ele_A=1,ele_count(positionsA) + call local_coords_matrix(positionsA, ele_A, inversion_matrices_A(:, :, ele_A)) end do - call deallocate(supermesh) - end do + do ele_B=1,ele_count(positionsB) + call local_coords_matrix(positionsB, ele_B, inversion_matrix_B) + ! Construct the supermesh associated with ele_B. + call construct_supermesh(positionsB, ele_B, positionsA, map_BA(ele_B), supermesh_positions_shape, supermesh) + + ! Interpolate fieldA onto the supermesh. + ! Interpolate fieldB onto the supermesh. + ! Compute the l2norm**2 of the difference. + do field=1,field_count + call compute_projection_error(fieldA(field), positionsA, supermesh_fields_shape, ele_val(fieldB(field), ele_B), positionsB, ele_B, supermesh, & + inversion_matrices_A, inversion_matrix_B, ele_error) + norm(field) = norm(field) + ele_error + end do + + call deallocate(supermesh) + end do - norm = sqrt(norm) + norm = sqrt(norm) - call deallocate(supermesh_quad) - call deallocate(supermesh_positions_shape) - call deallocate(supermesh_fields_shape) - do ele_B=1,ele_count(positionsB) - call deallocate(map_BA(ele_B)) - end do + call deallocate(supermesh_quad) + call deallocate(supermesh_positions_shape) + call deallocate(supermesh_fields_shape) + do ele_B=1,ele_count(positionsB) + call deallocate(map_BA(ele_B)) + end do - end function norm2_difference_multiple + end function norm2_difference_multiple - function merge_meshes(meshes, name) - !! merges a set of disjoint meshes, elements and nodes - !! are consecutively numbered following the order of the input meshes - type(mesh_type), dimension(:), intent(in):: meshes - character(len=*), intent(in), optional:: name - type(mesh_type):: merge_meshes + function merge_meshes(meshes, name) + !! merges a set of disjoint meshes, elements and nodes + !! are consecutively numbered following the order of the input meshes + type(mesh_type), dimension(:), intent(in):: meshes + character(len=*), intent(in), optional:: name + type(mesh_type):: merge_meshes - integer:: nodes, elements, ndglno_count, i + integer:: nodes, elements, ndglno_count, i - elements=0 - do i=1, size(meshes) - elements=elements+element_count(meshes(i)) - end do + elements=0 + do i=1, size(meshes) + elements=elements+element_count(meshes(i)) + end do - nodes=0 - do i=1, size(meshes) - nodes=nodes+node_count(meshes(i)) - end do + nodes=0 + do i=1, size(meshes) + nodes=nodes+node_count(meshes(i)) + end do - call allocate(merge_meshes, nodes, elements, meshes(1)%shape, & - name=name) + call allocate(merge_meshes, nodes, elements, meshes(1)%shape, & + name=name) - nodes=0 - ndglno_count=0 - do i=1, size(meshes) - merge_meshes%ndglno(ndglno_count+1:ndglno_count+size(meshes(i)%ndglno)) = & - meshes(i)%ndglno+nodes - ndglno_count=ndglno_count+size(meshes(i)%ndglno) - nodes=nodes+node_count(meshes(i)) - end do + nodes=0 + ndglno_count=0 + do i=1, size(meshes) + merge_meshes%ndglno(ndglno_count+1:ndglno_count+size(meshes(i)%ndglno)) = & + meshes(i)%ndglno+nodes + ndglno_count=ndglno_count+size(meshes(i)%ndglno) + nodes=nodes+node_count(meshes(i)) + end do - end function merge_meshes + end function merge_meshes end module fields_calculations diff --git a/femtools/Fields_Data_Types.F90 b/femtools/Fields_Data_Types.F90 index e40dd90f9d..fb5d7e0687 100644 --- a/femtools/Fields_Data_Types.F90 +++ b/femtools/Fields_Data_Types.F90 @@ -27,289 +27,289 @@ #include "fdebug.h" module fields_data_types - use global_parameters, only:FIELD_NAME_LEN, current_debug_level, OPTION_PATH_LEN, PYTHON_FUNC_LEN - use reference_counting - use picker_data_types - use shape_functions - use spud - use halo_data_types - use data_structures, only : integer_set_vector - use sparse_tools - implicit none + use global_parameters, only:FIELD_NAME_LEN, current_debug_level, OPTION_PATH_LEN, PYTHON_FUNC_LEN + use reference_counting + use picker_data_types + use shape_functions + use spud + use halo_data_types + use data_structures, only : integer_set_vector + use sparse_tools + implicit none - private - public adjacency_cache, & - mesh_type, mesh_faces, mesh_subdomain_mesh, scalar_field, vector_field, tensor_field, & - mesh_pointer, scalar_field_pointer, vector_field_pointer, tensor_field_pointer, & - scalar_boundary_condition, vector_boundary_condition, & - scalar_boundary_conditions_ptr, vector_boundary_conditions_ptr + private + public adjacency_cache, & + mesh_type, mesh_faces, mesh_subdomain_mesh, scalar_field, vector_field, tensor_field, & + mesh_pointer, scalar_field_pointer, vector_field_pointer, tensor_field_pointer, & + scalar_boundary_condition, vector_boundary_condition, & + scalar_boundary_conditions_ptr, vector_boundary_conditions_ptr - !! Types of different halo associated with a field: - integer, public, parameter :: HALO_TYPES=2 - !! Available sources of data for fields: - integer, public, parameter :: FIELD_TYPE_NORMAL=0, FIELD_TYPE_CONSTANT=1, FIELD_TYPE_PYTHON=2, & - FIELD_TYPE_DEFERRED=3 + !! Types of different halo associated with a field: + integer, public, parameter :: HALO_TYPES=2 + !! Available sources of data for fields: + integer, public, parameter :: FIELD_TYPE_NORMAL=0, FIELD_TYPE_CONSTANT=1, FIELD_TYPE_PYTHON=2, & + FIELD_TYPE_DEFERRED=3 - type adjacency_cache - type(csr_sparsity), pointer :: nnlist => null() - type(csr_sparsity), pointer :: nelist => null() - type(csr_sparsity), pointer :: eelist => null() - end type adjacency_cache + type adjacency_cache + type(csr_sparsity), pointer :: nnlist => null() + type(csr_sparsity), pointer :: nelist => null() + type(csr_sparsity), pointer :: eelist => null() + end type adjacency_cache - type mesh_type - !!< Mesh information for (among other things) fields. - integer, dimension(:), pointer :: ndglno - !! Flag for whether ndglno is allocated - logical :: wrapped=.true. - type(element_type) :: shape - integer :: elements - integer :: nodes - character(len=FIELD_NAME_LEN) :: name - !! path to options in the options tree + type mesh_type + !!< Mesh information for (among other things) fields. + integer, dimension(:), pointer :: ndglno + !! Flag for whether ndglno is allocated + logical :: wrapped=.true. + type(element_type) :: shape + integer :: elements + integer :: nodes + character(len=FIELD_NAME_LEN) :: name + !! path to options in the options tree #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - !! Degree of continuity of the field. 0 is for the conventional C0 - !! discretisation. -1 for DG. - integer :: continuity=0 - !! Reference count for mesh - type(refcount_type), pointer :: refcount=>null() - !! Mesh face information for those meshes (eg discontinuous) which need it. - type(mesh_faces), pointer :: faces=>null() - !! Information on subdomain_ mesh, for partially prognostic solves: - type(mesh_subdomain_mesh), pointer :: subdomain_mesh=>null() - type(adjacency_cache), pointer :: adj_lists => null() - !! array that for each node tells which column it is in - !! (column numbers usually correspond to a node number in a surface mesh) - integer, dimension(:), pointer :: columns => null() - !! if this mesh is extruded this array says which horizontal mesh element each element is below - integer, dimension(:), pointer :: element_columns => null() - !! A list of ids marking different parts of the mesh - !! so that initial conditions can be associated with it. - integer, dimension(:), pointer :: region_ids=>null() - !! Halo information for parallel simulations. - type(halo_type), dimension(:), pointer :: halos=>null() - type(halo_type), dimension(:), pointer :: element_halos=>null() - type(integer_set_vector), dimension(:), pointer :: colourings=>null() - !! A logical indicating if this mesh is periodic or not - !! (does not tell you how periodic it is... i.e. true if - !! any surface is periodic) - logical :: periodic=.false. - end type mesh_type + !! Degree of continuity of the field. 0 is for the conventional C0 + !! discretisation. -1 for DG. + integer :: continuity=0 + !! Reference count for mesh + type(refcount_type), pointer :: refcount=>null() + !! Mesh face information for those meshes (eg discontinuous) which need it. + type(mesh_faces), pointer :: faces=>null() + !! Information on subdomain_ mesh, for partially prognostic solves: + type(mesh_subdomain_mesh), pointer :: subdomain_mesh=>null() + type(adjacency_cache), pointer :: adj_lists => null() + !! array that for each node tells which column it is in + !! (column numbers usually correspond to a node number in a surface mesh) + integer, dimension(:), pointer :: columns => null() + !! if this mesh is extruded this array says which horizontal mesh element each element is below + integer, dimension(:), pointer :: element_columns => null() + !! A list of ids marking different parts of the mesh + !! so that initial conditions can be associated with it. + integer, dimension(:), pointer :: region_ids=>null() + !! Halo information for parallel simulations. + type(halo_type), dimension(:), pointer :: halos=>null() + type(halo_type), dimension(:), pointer :: element_halos=>null() + type(integer_set_vector), dimension(:), pointer :: colourings=>null() + !! A logical indicating if this mesh is periodic or not + !! (does not tell you how periodic it is... i.e. true if + !! any surface is periodic) + logical :: periodic=.false. + end type mesh_type - type mesh_faces - !!< Type encoding face information for a mesh. - type(element_type), pointer :: shape - !! Face_list(i,j) is the face in element i bordering j. - type(csr_matrix) :: face_list - !! The local number of the nodes in a given face. - integer, dimension(:), pointer :: face_lno - !! A mesh consisting of all faces on the surface of the domain, - !! it uses its own internal surface node numbering: - type(mesh_type) surface_mesh - !! A list of the nodes on the surface, thus forming a map between - !! internal surface node numbering and global node numbering: - integer, dimension(:), pointer :: surface_node_list - !! The element with which each face is associated - integer, dimension(:), pointer :: face_element_list - !! A list of ids marking different parts of the surface mesh - !! so that boundary conditions can be associated with it. - integer, dimension(:), pointer :: boundary_ids - !! list of ids to identify coplanar patches of the surface: - integer, dimension(:), pointer :: coplanar_ids => null() - !! a DG version of the surface mesh, useful for storing bc values - type(mesh_type), pointer:: dg_surface_mesh => null() - !! A logical indicating if this mesh has a discontinuous internal boundary - !! This means that the pairs of internal facets are allowed to have two different - !! surface ids. When writing out this mesh both facets are written out and - !! element owners (an extra column indiciating which element is adjacent to each facet) - !! needs to be written out along with the surface mesh. - !! This is currently only used for periodic meshes which have a physical and aliased surface id - !! along the periodic boundary (which is an internal boundary of the periodic mesh). - !! Note that other meshes (with has_internal_boundaries==.false.) may still have internal facets - !! as part of the surface mesh, in this case the surface ids do have to agree and only one of each - !! pair of facets is written when writing out the mesh. - logical :: has_discontinuous_internal_boundaries=.false. - !! If internal facets are present in the surface mesh (and has_discontinuous_internal_boundaries==.false.) - !! the surface facets are numbered such that 1:unique_surface_element_count visits each external facet - !! and each pair of internal facets only once (the order of this is typically determined by the - !! read-in input mesh in which internal facets are only also only present once) - !! The second facets of each pair of internal facets are numbered - !! unique_surface_element_count+1:surface_element_count (surface_element_count()==size(boundary_ids)) - !! For meshes with no internal facets: unique_surface_element_count==surface_element_count() - !! For meshes with has_discontinuous_internal_boundaries no order is guaranteed and also - !! unique_surface_element_count==surface_element_count() - integer :: unique_surface_element_count - end type mesh_faces + type mesh_faces + !!< Type encoding face information for a mesh. + type(element_type), pointer :: shape + !! Face_list(i,j) is the face in element i bordering j. + type(csr_matrix) :: face_list + !! The local number of the nodes in a given face. + integer, dimension(:), pointer :: face_lno + !! A mesh consisting of all faces on the surface of the domain, + !! it uses its own internal surface node numbering: + type(mesh_type) surface_mesh + !! A list of the nodes on the surface, thus forming a map between + !! internal surface node numbering and global node numbering: + integer, dimension(:), pointer :: surface_node_list + !! The element with which each face is associated + integer, dimension(:), pointer :: face_element_list + !! A list of ids marking different parts of the surface mesh + !! so that boundary conditions can be associated with it. + integer, dimension(:), pointer :: boundary_ids + !! list of ids to identify coplanar patches of the surface: + integer, dimension(:), pointer :: coplanar_ids => null() + !! a DG version of the surface mesh, useful for storing bc values + type(mesh_type), pointer:: dg_surface_mesh => null() + !! A logical indicating if this mesh has a discontinuous internal boundary + !! This means that the pairs of internal facets are allowed to have two different + !! surface ids. When writing out this mesh both facets are written out and + !! element owners (an extra column indiciating which element is adjacent to each facet) + !! needs to be written out along with the surface mesh. + !! This is currently only used for periodic meshes which have a physical and aliased surface id + !! along the periodic boundary (which is an internal boundary of the periodic mesh). + !! Note that other meshes (with has_internal_boundaries==.false.) may still have internal facets + !! as part of the surface mesh, in this case the surface ids do have to agree and only one of each + !! pair of facets is written when writing out the mesh. + logical :: has_discontinuous_internal_boundaries=.false. + !! If internal facets are present in the surface mesh (and has_discontinuous_internal_boundaries==.false.) + !! the surface facets are numbered such that 1:unique_surface_element_count visits each external facet + !! and each pair of internal facets only once (the order of this is typically determined by the + !! read-in input mesh in which internal facets are only also only present once) + !! The second facets of each pair of internal facets are numbered + !! unique_surface_element_count+1:surface_element_count (surface_element_count()==size(boundary_ids)) + !! For meshes with no internal facets: unique_surface_element_count==surface_element_count() + !! For meshes with has_discontinuous_internal_boundaries no order is guaranteed and also + !! unique_surface_element_count==surface_element_count() + integer :: unique_surface_element_count + end type mesh_faces - type mesh_subdomain_mesh - !! List of elements in subdomain_mesh region(s): - integer, dimension(:), pointer :: element_list - !! List of nodes in subdomain_mesh regions(s): - integer, dimension(:), pointer :: node_list - end type mesh_subdomain_mesh + type mesh_subdomain_mesh + !! List of elements in subdomain_mesh region(s): + integer, dimension(:), pointer :: element_list + !! List of nodes in subdomain_mesh regions(s): + integer, dimension(:), pointer :: node_list + end type mesh_subdomain_mesh - type scalar_field - !! Field value at points. - real, dimension(:), pointer :: val - !! Stride of val - integer :: val_stride = 1 - !! Flag for whether val is allocated - logical :: wrapped=.true. - !! The data source to be used - integer :: field_type = FIELD_TYPE_NORMAL - !! boundary conditions: - type(scalar_boundary_conditions_ptr), pointer :: bc => null() - character(len=FIELD_NAME_LEN) :: name - !! path to options in the options tree + type scalar_field + !! Field value at points. + real, dimension(:), pointer :: val + !! Stride of val + integer :: val_stride = 1 + !! Flag for whether val is allocated + logical :: wrapped=.true. + !! The data source to be used + integer :: field_type = FIELD_TYPE_NORMAL + !! boundary conditions: + type(scalar_boundary_conditions_ptr), pointer :: bc => null() + character(len=FIELD_NAME_LEN) :: name + !! path to options in the options tree #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - type(mesh_type) :: mesh - !! Reference count for field - type(refcount_type), pointer :: refcount=>null() - !! Indicator for whether this is an alias to another field. - logical :: aliased=.false. - !! Python-field implementation. - real, dimension(:, :), pointer :: py_locweight => null() - character(len=PYTHON_FUNC_LEN) :: py_func - type(vector_field), pointer :: py_positions - logical :: py_positions_same_mesh - integer :: py_dim - type(element_type), pointer :: py_positions_shape => null() - end type scalar_field + type(mesh_type) :: mesh + !! Reference count for field + type(refcount_type), pointer :: refcount=>null() + !! Indicator for whether this is an alias to another field. + logical :: aliased=.false. + !! Python-field implementation. + real, dimension(:, :), pointer :: py_locweight => null() + character(len=PYTHON_FUNC_LEN) :: py_func + type(vector_field), pointer :: py_positions + logical :: py_positions_same_mesh + integer :: py_dim + type(element_type), pointer :: py_positions_shape => null() + end type scalar_field - type vector_field - !! dim x nonods vector values - real, dimension(:,:), pointer :: val - !! Flag for whether val is allocated - logical :: wrapped = .true. - !! The data source to be used - integer :: field_type = FIELD_TYPE_NORMAL - !! boundary conditions: - type(vector_boundary_conditions_ptr), pointer :: bc => null() - character(len=FIELD_NAME_LEN) :: name - integer :: dim - !! path to options in the options tree + type vector_field + !! dim x nonods vector values + real, dimension(:,:), pointer :: val + !! Flag for whether val is allocated + logical :: wrapped = .true. + !! The data source to be used + integer :: field_type = FIELD_TYPE_NORMAL + !! boundary conditions: + type(vector_boundary_conditions_ptr), pointer :: bc => null() + character(len=FIELD_NAME_LEN) :: name + integer :: dim + !! path to options in the options tree #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - type(mesh_type) :: mesh - !! Reference count for field - type(refcount_type), pointer :: refcount=>null() - !! Indicator for whether this is an alias to another field. - logical :: aliased=.false. - !! Picker used for spatial indexing (pointer to a pointer to ensure - !! correct handling on assignment) - type(picker_ptr), pointer :: picker => null() - end type vector_field + type(mesh_type) :: mesh + !! Reference count for field + type(refcount_type), pointer :: refcount=>null() + !! Indicator for whether this is an alias to another field. + logical :: aliased=.false. + !! Picker used for spatial indexing (pointer to a pointer to ensure + !! correct handling on assignment) + type(picker_ptr), pointer :: picker => null() + end type vector_field - type tensor_field - !! ndim x ndim x nonods - real, dimension(:,:,:), pointer :: val - !! Flag for whether val is allocated - logical :: wrapped=.true. - !! The data source to be used - integer :: field_type = FIELD_TYPE_NORMAL - character(len=FIELD_NAME_LEN) :: name - integer, dimension(2) :: dim - !! path to options in the options tree + type tensor_field + !! ndim x ndim x nonods + real, dimension(:,:,:), pointer :: val + !! Flag for whether val is allocated + logical :: wrapped=.true. + !! The data source to be used + integer :: field_type = FIELD_TYPE_NORMAL + character(len=FIELD_NAME_LEN) :: name + integer, dimension(2) :: dim + !! path to options in the options tree #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - type(mesh_type) :: mesh - !! Reference count for field - type(refcount_type), pointer :: refcount=>null() - !! Indicator for whether this is an alias to another field. - logical :: aliased=.false. - end type tensor_field + type(mesh_type) :: mesh + !! Reference count for field + type(refcount_type), pointer :: refcount=>null() + !! Indicator for whether this is an alias to another field. + logical :: aliased=.false. + end type tensor_field - type mesh_pointer - !!< Dummy type to allow for arrays of pointers to meshes - type(mesh_type), pointer :: ptr => null() - end type mesh_pointer + type mesh_pointer + !!< Dummy type to allow for arrays of pointers to meshes + type(mesh_type), pointer :: ptr => null() + end type mesh_pointer - type scalar_field_pointer - !!< Dummy type to allow for arrays of pointers to scalar fields - type(scalar_field), pointer :: ptr => null() - end type scalar_field_pointer + type scalar_field_pointer + !!< Dummy type to allow for arrays of pointers to scalar fields + type(scalar_field), pointer :: ptr => null() + end type scalar_field_pointer - type vector_field_pointer - !!< Dummy type to allow for arrays of pointers to vector fields - type(vector_field), pointer :: ptr => null() - end type vector_field_pointer + type vector_field_pointer + !!< Dummy type to allow for arrays of pointers to vector fields + type(vector_field), pointer :: ptr => null() + end type vector_field_pointer - type tensor_field_pointer - !!< Dummy type to allow for arrays of pointers to tensor fields - type(tensor_field), pointer :: ptr => null() - end type tensor_field_pointer + type tensor_field_pointer + !!< Dummy type to allow for arrays of pointers to tensor fields + type(tensor_field), pointer :: ptr => null() + end type tensor_field_pointer - type scalar_boundary_condition - !!< Type to hold boundary condition information for a scalar field - character(len=FIELD_NAME_LEN) :: name - !! b.c. type, any of: ... - character(len=FIELD_NAME_LEN) :: type="" - !! list of surface elements to which boundary condition is applied: - integer, dimension(:), pointer:: surface_element_list => null() - !! list of surface nodes to which boundary condition is applied: - integer, dimension(:), pointer:: surface_node_list => null() - !! mesh consisting of these elements and nodes only: - type(mesh_type), pointer :: surface_mesh - !! surface fields on this mesh containing b.c. values - type(scalar_field), dimension(:), pointer :: surface_fields => null() - !! path to options in the options tree + type scalar_boundary_condition + !!< Type to hold boundary condition information for a scalar field + character(len=FIELD_NAME_LEN) :: name + !! b.c. type, any of: ... + character(len=FIELD_NAME_LEN) :: type="" + !! list of surface elements to which boundary condition is applied: + integer, dimension(:), pointer:: surface_element_list => null() + !! list of surface nodes to which boundary condition is applied: + integer, dimension(:), pointer:: surface_node_list => null() + !! mesh consisting of these elements and nodes only: + type(mesh_type), pointer :: surface_mesh + !! surface fields on this mesh containing b.c. values + type(scalar_field), dimension(:), pointer :: surface_fields => null() + !! path to options in the options tree #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - end type scalar_boundary_condition + end type scalar_boundary_condition - type vector_boundary_condition - !!< Type to hold boundary condition information for a vector field - character(len=FIELD_NAME_LEN) :: name - !! b.c. type, any of: ... - character(len=FIELD_NAME_LEN) :: type="" - !! boundary condition is only applied for component with applies is .true. - logical, dimension(3):: applies - !! list of surface elements to which boundary condition is applied: - integer, dimension(:), pointer:: surface_element_list => null() - !! list of surface nodes to which boundary condition is applied: - integer, dimension(:), pointer:: surface_node_list => null() - !! mesh consisting of these elements and nodes only: - type(mesh_type), pointer :: surface_mesh - !! surface fields on this mesh containing b.c. values - type(vector_field), dimension(:), pointer :: surface_fields => null() - !! scalar surface fields on this mesh containing b.c. values - type(scalar_field), dimension(:), pointer :: scalar_surface_fields => null() - !! path to options in the options tree + type vector_boundary_condition + !!< Type to hold boundary condition information for a vector field + character(len=FIELD_NAME_LEN) :: name + !! b.c. type, any of: ... + character(len=FIELD_NAME_LEN) :: type="" + !! boundary condition is only applied for component with applies is .true. + logical, dimension(3):: applies + !! list of surface elements to which boundary condition is applied: + integer, dimension(:), pointer:: surface_element_list => null() + !! list of surface nodes to which boundary condition is applied: + integer, dimension(:), pointer:: surface_node_list => null() + !! mesh consisting of these elements and nodes only: + type(mesh_type), pointer :: surface_mesh + !! surface fields on this mesh containing b.c. values + type(vector_field), dimension(:), pointer :: surface_fields => null() + !! scalar surface fields on this mesh containing b.c. values + type(scalar_field), dimension(:), pointer :: scalar_surface_fields => null() + !! path to options in the options tree #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - end type vector_boundary_condition + end type vector_boundary_condition - ! container for pointer to array of scalar bcs. This is put in a separate - ! container pointed at by the field so that we don't leak memory - ! if we change the bcs on one copy of the field when there are more copies around - type scalar_boundary_conditions_ptr - type(scalar_boundary_condition), dimension(:), pointer:: boundary_condition => null() - end type scalar_boundary_conditions_ptr + ! container for pointer to array of scalar bcs. This is put in a separate + ! container pointed at by the field so that we don't leak memory + ! if we change the bcs on one copy of the field when there are more copies around + type scalar_boundary_conditions_ptr + type(scalar_boundary_condition), dimension(:), pointer:: boundary_condition => null() + end type scalar_boundary_conditions_ptr - ! container for pointer to array of vector bcs. This is put in a separate - ! container pointed at by the field so that we don't leak memory - ! if we change the bcs on one copy of the field when there are more copies around - type vector_boundary_conditions_ptr - type(vector_boundary_condition), dimension(:), pointer:: boundary_condition => null() - end type vector_boundary_conditions_ptr + ! container for pointer to array of vector bcs. This is put in a separate + ! container pointed at by the field so that we don't leak memory + ! if we change the bcs on one copy of the field when there are more copies around + type vector_boundary_conditions_ptr + type(vector_boundary_condition), dimension(:), pointer:: boundary_condition => null() + end type vector_boundary_conditions_ptr end module fields_data_types diff --git a/femtools/Fields_Halos.F90 b/femtools/Fields_Halos.F90 index d585b3ac72..dd74291e61 100644 --- a/femtools/Fields_Halos.F90 +++ b/femtools/Fields_Halos.F90 @@ -27,229 +27,229 @@ #include "fdebug.h" module fields_halos !!< This module contains code that depends on both fields and halos -use fldebug -use data_structures -use parallel_tools -use fields -use halos -implicit none + use fldebug + use data_structures + use parallel_tools + use fields + use halos + implicit none -private + private -public:: make_mesh_unperiodic, verify_consistent_local_element_numbering + public:: make_mesh_unperiodic, verify_consistent_local_element_numbering contains - function make_mesh_unperiodic(model, my_physical_boundary_ids, aliased_boundary_ids, periodic_mapping_python, name, all_periodic_bc_ids, aliased_to_new_node_number) & - result (new_positions) - !!< Produce a mesh based on an old mesh but with periodic boundary conditions - type(vector_field) :: new_positions - - type(vector_field), intent(in) :: model - integer, dimension(:), intent(in) :: my_physical_boundary_ids, aliased_boundary_ids - character(len=*), intent(in) :: periodic_mapping_python - character(len=*), intent(in):: name - type(integer_set), intent(in) :: all_periodic_bc_ids ! all boundary ids from all periodic BCs - - type(integer_hash_table), intent(out) :: aliased_to_new_node_number - type(mesh_type):: mesh - real, dimension(:,:), allocatable:: aliased_positions, physical_positions - integer:: mapped_node_count, aliased_node, physical_node - integer:: i, j, ele, sid, key, output - integer, dimension(node_count(model)) :: is_periodic - - ! build a map from aliased node number to physical node number - ! thus also counting the number mapped nodes - call allocate( aliased_to_new_node_number ) - mapped_node_count = 0 - do i = 1, surface_element_count(model) - sid = surface_element_id(model, i) - if (any(aliased_boundary_ids==sid)) then - call copy_aliased_nodes_face(i) - end if - end do - - ! before we use it, we need to use the model halos - ! to ensure that everyone agrees on what is a periodic node - ! to be split and what isn't! - if (isparallel()) then - assert(associated(model%mesh%halos)) - is_periodic = 0 - do i=1,key_count(aliased_to_new_node_number) - call fetch_pair(aliased_to_new_node_number, i, key, output) - is_periodic(key) = 1 - end do - call halo_update(model%mesh%halos(2), is_periodic) - - do i=1,node_count(model) - if (is_periodic(i) == 1) then - if (.not. has_key(aliased_to_new_node_number, i)) then - ! we didn't know about this one and need to generate a new local node number for it - mapped_node_count = mapped_node_count + 1 - call insert(aliased_to_new_node_number, i, node_count(model)+mapped_node_count) - end if - else if (is_periodic(i) == 0) then - if (has_key(aliased_to_new_node_number, i)) then - write(0,*) halo_universal_number(model%mesh%halos(2),i) - FLAbort("I thought it was periodic, but the owner says otherwise ... ") - end if - end if + function make_mesh_unperiodic(model, my_physical_boundary_ids, aliased_boundary_ids, periodic_mapping_python, name, all_periodic_bc_ids, aliased_to_new_node_number) & + result (new_positions) + !!< Produce a mesh based on an old mesh but with periodic boundary conditions + type(vector_field) :: new_positions + + type(vector_field), intent(in) :: model + integer, dimension(:), intent(in) :: my_physical_boundary_ids, aliased_boundary_ids + character(len=*), intent(in) :: periodic_mapping_python + character(len=*), intent(in):: name + type(integer_set), intent(in) :: all_periodic_bc_ids ! all boundary ids from all periodic BCs + + type(integer_hash_table), intent(out) :: aliased_to_new_node_number + type(mesh_type):: mesh + real, dimension(:,:), allocatable:: aliased_positions, physical_positions + integer:: mapped_node_count, aliased_node, physical_node + integer:: i, j, ele, sid, key, output + integer, dimension(node_count(model)) :: is_periodic + + ! build a map from aliased node number to physical node number + ! thus also counting the number mapped nodes + call allocate( aliased_to_new_node_number ) + mapped_node_count = 0 + do i = 1, surface_element_count(model) + sid = surface_element_id(model, i) + if (any(aliased_boundary_ids==sid)) then + call copy_aliased_nodes_face(i) + end if end do + ! before we use it, we need to use the model halos + ! to ensure that everyone agrees on what is a periodic node + ! to be split and what isn't! + if (isparallel()) then + assert(associated(model%mesh%halos)) + is_periodic = 0 + do i=1,key_count(aliased_to_new_node_number) + call fetch_pair(aliased_to_new_node_number, i, key, output) + is_periodic(key) = 1 + end do + call halo_update(model%mesh%halos(2), is_periodic) + + do i=1,node_count(model) + if (is_periodic(i) == 1) then + if (.not. has_key(aliased_to_new_node_number, i)) then + ! we didn't know about this one and need to generate a new local node number for it + mapped_node_count = mapped_node_count + 1 + call insert(aliased_to_new_node_number, i, node_count(model)+mapped_node_count) + end if + else if (is_periodic(i) == 0) then + if (has_key(aliased_to_new_node_number, i)) then + write(0,*) halo_universal_number(model%mesh%halos(2),i) + FLAbort("I thought it was periodic, but the owner says otherwise ... ") + end if + end if + end do + #ifdef DDEBUG - is_periodic = 0 - do i=1,key_count(aliased_to_new_node_number) - call fetch_pair(aliased_to_new_node_number, i, key, output) - is_periodic(key) = 1 - end do - assert(halo_verifies(model%mesh%halos(2), is_periodic)) + is_periodic = 0 + do i=1,key_count(aliased_to_new_node_number) + call fetch_pair(aliased_to_new_node_number, i, key, output) + is_periodic(key) = 1 + end do + assert(halo_verifies(model%mesh%halos(2), is_periodic)) #endif - end if - - ! we now have info to allocate the new mesh - call allocate(mesh, node_count(model)+mapped_node_count, element_count(model), & - model%mesh%shape, name=name) - mesh%ndglno=model%mesh%ndglno - - ! now for the new_positions, first copy all positions of the model (including aliased nodes) - call allocate(new_positions, model%dim, mesh, name=trim(name)//"Coordinate") - allocate( aliased_positions(1:model%dim, mapped_node_count), & - physical_positions(1:model%dim, mapped_node_count ) ) - do j=1, model%dim - new_positions%val(j,1:node_count(model))=model%val(j,:) - end do - - ! copy aliased positions into an array - do i=1, mapped_node_count - call fetch_pair(aliased_to_new_node_number, i, aliased_node, physical_node) - aliased_positions(:, i)=node_val(model, aliased_node) - end do - - ! apply the python map - call set_from_python_function(physical_positions, & - periodic_mapping_python, aliased_positions, & - time=0.0) - - ! copy the physical node positions - do i=1, mapped_node_count - call fetch_pair(aliased_to_new_node_number, i, aliased_node, physical_node) - do j=1, model%dim - new_positions%val(j,physical_node)=physical_positions(j,i) - end do - end do - - ! now fix the elements - do i = 1, surface_element_count(model) - sid = surface_element_id(model, i) - if (any(sid == my_physical_boundary_ids)) then - ele=face_ele(model, i) - call make_mesh_unperiodic_fix_ele(mesh, model%mesh, & - aliased_to_new_node_number, all_periodic_bc_ids, ele) end if - end do - call deallocate( mesh ) - deallocate( aliased_positions, physical_positions ) + ! we now have info to allocate the new mesh + call allocate(mesh, node_count(model)+mapped_node_count, element_count(model), & + model%mesh%shape, name=name) + mesh%ndglno=model%mesh%ndglno + + ! now for the new_positions, first copy all positions of the model (including aliased nodes) + call allocate(new_positions, model%dim, mesh, name=trim(name)//"Coordinate") + allocate( aliased_positions(1:model%dim, mapped_node_count), & + physical_positions(1:model%dim, mapped_node_count ) ) + do j=1, model%dim + new_positions%val(j,1:node_count(model))=model%val(j,:) + end do - contains + ! copy aliased positions into an array + do i=1, mapped_node_count + call fetch_pair(aliased_to_new_node_number, i, aliased_node, physical_node) + aliased_positions(:, i)=node_val(model, aliased_node) + end do - subroutine copy_aliased_nodes_face(face) - integer, intent(in):: face + ! apply the python map + call set_from_python_function(physical_positions, & + periodic_mapping_python, aliased_positions, & + time=0.0) + + ! copy the physical node positions + do i=1, mapped_node_count + call fetch_pair(aliased_to_new_node_number, i, aliased_node, physical_node) + do j=1, model%dim + new_positions%val(j,physical_node)=physical_positions(j,i) + end do + end do - integer, dimension(face_loc(model, face)):: aliased_nodes - integer:: j + ! now fix the elements + do i = 1, surface_element_count(model) + sid = surface_element_id(model, i) + if (any(sid == my_physical_boundary_ids)) then + ele=face_ele(model, i) + call make_mesh_unperiodic_fix_ele(mesh, model%mesh, & + aliased_to_new_node_number, all_periodic_bc_ids, ele) + end if + end do - aliased_nodes = face_global_nodes(model, face) - do j = 1, size(aliased_nodes) - if (.not. has_key(aliased_to_new_node_number, aliased_nodes(j))) then - mapped_node_count = mapped_node_count + 1 - call insert(aliased_to_new_node_number, aliased_nodes(j), node_count(model)+mapped_node_count) - end if + call deallocate( mesh ) + deallocate( aliased_positions, physical_positions ) + + contains + + subroutine copy_aliased_nodes_face(face) + integer, intent(in):: face + + integer, dimension(face_loc(model, face)):: aliased_nodes + integer:: j + + aliased_nodes = face_global_nodes(model, face) + do j = 1, size(aliased_nodes) + if (.not. has_key(aliased_to_new_node_number, aliased_nodes(j))) then + mapped_node_count = mapped_node_count + 1 + call insert(aliased_to_new_node_number, aliased_nodes(j), node_count(model)+mapped_node_count) + end if + end do + + end subroutine copy_aliased_nodes_face + + end function make_mesh_unperiodic + + recursive subroutine make_mesh_unperiodic_fix_ele(mesh, model, & + aliased_to_new_node_number, boundary_ids_set, ele) + ! For an element on the physical side of a periodic boundary, + ! change all nodes from aliased to physical. This is recursively + ! called for all neighbouring elements. Neighbours are found using + ! the element-element list of the model, where we don't cross any + ! facets with a physical boundary id - thus staying on this side of + ! the boundary. Also as soon as an element without any aliased nodes + ! is encountered the recursion stops + ! so that we don't propagate into the interior of the mesh and don't fix + ! elements twice. This assumes elements with aliased nodes and elements + ! with physical nodes are not directly adjacent. + type(mesh_type), intent(inout):: mesh + type(mesh_type), intent(in):: model + type(integer_hash_table), intent(in):: aliased_to_new_node_number + type(integer_set), intent(in):: boundary_ids_set + integer, intent(in):: ele + + integer, dimension(:), pointer:: nodes, neigh, faces + integer:: j, sid + logical:: changed + + changed=.false. ! have we changed this element + + nodes => ele_nodes(mesh, ele) + do j = 1, size(nodes) + if (has_key(aliased_to_new_node_number, nodes(j))) then + nodes(j)=fetch(aliased_to_new_node_number, nodes(j)) + changed=.true. + end if end do - end subroutine copy_aliased_nodes_face - - end function make_mesh_unperiodic - - recursive subroutine make_mesh_unperiodic_fix_ele(mesh, model, & - aliased_to_new_node_number, boundary_ids_set, ele) - ! For an element on the physical side of a periodic boundary, - ! change all nodes from aliased to physical. This is recursively - ! called for all neighbouring elements. Neighbours are found using - ! the element-element list of the model, where we don't cross any - ! facets with a physical boundary id - thus staying on this side of - ! the boundary. Also as soon as an element without any aliased nodes - ! is encountered the recursion stops - ! so that we don't propagate into the interior of the mesh and don't fix - ! elements twice. This assumes elements with aliased nodes and elements - ! with physical nodes are not directly adjacent. - type(mesh_type), intent(inout):: mesh - type(mesh_type), intent(in):: model - type(integer_hash_table), intent(in):: aliased_to_new_node_number - type(integer_set), intent(in):: boundary_ids_set - integer, intent(in):: ele - - integer, dimension(:), pointer:: nodes, neigh, faces - integer:: j, sid - logical:: changed - - changed=.false. ! have we changed this element - - nodes => ele_nodes(mesh, ele) - do j = 1, size(nodes) - if (has_key(aliased_to_new_node_number, nodes(j))) then - nodes(j)=fetch(aliased_to_new_node_number, nodes(j)) - changed=.true. - end if - end do - - ! no aliased nodes found, we can stop the recursion - if (.not. changed) return - - ! recursively "fix" our neighbours - neigh => ele_neigh(model, ele) - faces => ele_faces(model, ele) - do j=1, size(neigh) - if (neigh(j)>0) then - ! found a neighbour - - ! check if we're crossing a physical boundary - if (faces(j)<=surface_element_count(model)) then - sid = surface_element_id(model, faces(j)) - if (has_value(boundary_ids_set, sid)) cycle - end if - - ! otherwise go fix it - call make_mesh_unperiodic_fix_ele(mesh, model, & - aliased_to_new_node_number, boundary_ids_set, neigh(j)) - end if - end do + ! no aliased nodes found, we can stop the recursion + if (.not. changed) return + + ! recursively "fix" our neighbours + neigh => ele_neigh(model, ele) + faces => ele_faces(model, ele) + do j=1, size(neigh) + if (neigh(j)>0) then + ! found a neighbour + + ! check if we're crossing a physical boundary + if (faces(j)<=surface_element_count(model)) then + sid = surface_element_id(model, faces(j)) + if (has_value(boundary_ids_set, sid)) cycle + end if + + ! otherwise go fix it + call make_mesh_unperiodic_fix_ele(mesh, model, & + aliased_to_new_node_number, boundary_ids_set, neigh(j)) + end if + end do - end subroutine make_mesh_unperiodic_fix_ele + end subroutine make_mesh_unperiodic_fix_ele - function verify_consistent_local_element_numbering(mesh) result (pass) - !!< Checks that the local element ordering is consistent between the owner - !!< of the element and all other processes that see it. - type(mesh_type), intent(in):: mesh - logical :: pass + function verify_consistent_local_element_numbering(mesh) result (pass) + !!< Checks that the local element ordering is consistent between the owner + !!< of the element and all other processes that see it. + type(mesh_type), intent(in):: mesh + logical :: pass - integer, dimension(:), allocatable:: eleunn, eleunn2 - integer:: nloc + integer, dimension(:), allocatable:: eleunn, eleunn2 + integer:: nloc - if (.not. associated(mesh%element_halos)) then - FLAbort("Element halos not allocated in verify_local_element_numbering") - end if + if (.not. associated(mesh%element_halos)) then + FLAbort("Element halos not allocated in verify_local_element_numbering") + end if - nloc=ele_loc(mesh,1) - assert(nloc*element_count(mesh)==size(mesh%ndglno)) + nloc=ele_loc(mesh,1) + assert(nloc*element_count(mesh)==size(mesh%ndglno)) - allocate( eleunn(1:size(mesh%ndglno)), eleunn2(1:size(mesh%ndglno)) ) - eleunn = halo_universal_numbers(mesh%halos(2),mesh%ndglno) - eleunn2 = eleunn - call halo_update(mesh%element_halos(2), eleunn, block_size=nloc) + allocate( eleunn(1:size(mesh%ndglno)), eleunn2(1:size(mesh%ndglno)) ) + eleunn = halo_universal_numbers(mesh%halos(2),mesh%ndglno) + eleunn2 = eleunn + call halo_update(mesh%element_halos(2), eleunn, block_size=nloc) - pass = all(eleunn==eleunn2) + pass = all(eleunn==eleunn2) - end function verify_consistent_local_element_numbering + end function verify_consistent_local_element_numbering end module fields_halos diff --git a/femtools/Fields_Manipulation.F90 b/femtools/Fields_Manipulation.F90 index d94be7e6d0..b43280ec0b 100644 --- a/femtools/Fields_Manipulation.F90 +++ b/femtools/Fields_Manipulation.F90 @@ -26,204 +26,204 @@ ! USA #include "fdebug.h" module fields_manipulation - use fldebug - use vector_tools - use futils, only: present_and_true - use element_numbering - use elements - use element_set - use data_structures - use halo_data_types - use quicksort - use parallel_tools - use halos_base - use halos_debug - use memory_diagnostics - use halos_allocates - use sparse_tools - use embed_python - use fields_data_types - use fields_base - use halos_numbering - use halos_ownership - use halos_repair - use fields_allocates - implicit none - - private - - public :: addto, set_from_function, set, set_all, & - & set_from_python_function, remap_field, remap_field_to_surface, & - & set_to_submesh, set_from_submesh, scale, bound, invert, & - & absolute_value, inner_product, cross_prod, clone_header - public :: piecewise_constant_field, piecewise_constant_mesh - public :: renumber_positions, renumber_positions_trailing_receives, & - & renumber_positions_elements, & - & renumber_positions_elements_trailing_receives, reorder_element_numbering - public :: get_patch_ele, get_patch_node, patch_type - public :: set_ele_nodes, normalise, tensor_second_invariant - public :: remap_to_subdomain, remap_to_full_domain - public :: get_coordinates_remapped_to_surface, get_remapped_coordinates - public :: power - public :: zero_bubble_vals, ele_zero_bubble_val - - integer, parameter, public :: REMAP_ERR_DISCONTINUOUS_CONTINUOUS = 1, & - REMAP_ERR_HIGHER_LOWER_CONTINUOUS = 2, & - REMAP_ERR_UNPERIODIC_PERIODIC = 3, & - REMAP_ERR_BUBBLE_LAGRANGE = 4 - - interface addto - module procedure scalar_field_vaddto, scalar_field_addto, & - vector_field_addto, vector_field_vaddto_dim, tensor_field_addto, & - tensor_field_vaddto, tensor_field_vaddto_single, tensor_field_vaddto_dim, & - vector_field_vaddto_vec, scalar_field_addto_scalar, vector_field_addto_vector, & - scalar_field_addto_field, vector_field_addto_field, vector_field_addto_dim, & - vector_field_addto_field_dim, tensor_field_addto_field_dim_dim, & - tensor_field_addto_dim, tensor_field_addto_tensor_field, & - real_addto_real, vector_field_addto_field_scale_field - end interface - - interface set_from_function - module procedure set_from_function_scalar, set_from_function_vector,& - & set_from_function_tensor - end interface - - interface set - module procedure set_scalar_field_node, set_scalar_field, & - & set_vector_field_node, set_vector_field, & - & set_vector_field_node_dim, set_vector_field_dim, & - & set_tensor_field_node, set_tensor_field, set_tensor_field_dim, & - & set_scalar_field_nodes, set_scalar_field_constant_nodes, & - & set_tensor_field_node_dim, & - & set_vector_field_nodes, & - & set_vector_field_nodes_dim, & - & set_tensor_field_nodes, & - & set_scalar_field_field, & - & set_scalar_field_from_vector_field, & - & set_vector_field_field, & - & set_vector_field_field_dim, & - & set_tensor_field_field, & - & set_tensor_field_scalar_field, & - & set_tensor_field_diag_vector_field, & - & set_scalar_field_theta, set_vector_field_theta, & - & set_vector_field_vfield_dim, & - & set_tensor_field_theta - end interface - - interface set_all - module procedure set_vector_field_arr, set_vector_field_arr_dim, & - & set_scalar_field_arr, set_tensor_field_arr, & - & set_tensor_field_arr_dim - end interface - - interface set_from_python_function - module procedure set_from_python_function_scalar,& - & set_from_python_function_vector, & - & set_from_python_function_tensor - end interface - - interface test_remap_validity - module procedure test_remap_validity_scalar, test_remap_validity_vector, & - test_remap_validity_tensor, test_remap_validity_generic - end interface - - interface remap_field - module procedure remap_scalar_field, remap_vector_field, remap_tensor_field, & - & remap_scalar_field_specific, remap_vector_field_specific - end interface - - interface remap_field_to_surface - module procedure remap_scalar_field_to_surface, remap_vector_field_to_surface, remap_tensor_field_to_surface - end interface - - interface set_to_submesh - module procedure set_to_submesh_scalar, set_to_submesh_vector - end interface - - interface set_from_submesh - module procedure set_from_submesh_scalar, set_from_submesh_vector - end interface - - interface scale - module procedure scalar_scale, vector_scale, tensor_scale, & - scalar_scale_scalar_field, & - vector_scale_scalar_field, & - tensor_scale_scalar_field, & - vector_scale_vector_field, & - tensor_scale_tensor_field - end interface - - interface power - module procedure scalar_power, vector_power, tensor_power, & - scalar_power_scalar_field, & - vector_power_scalar_field, & - tensor_power_scalar_field - end interface - - interface bound - module procedure bound_scalar_field, bound_scalar_field_field, bound_vector_field, bound_tensor_field - end interface - - interface invert - module procedure invert_scalar_field, invert_vector_field, invert_tensor_field, & - invert_scalar_field_inplace, invert_vector_field_inplace, invert_tensor_field_inplace - end interface - - interface absolute_value - module procedure absolute_value_scalar_field - end interface - - interface inner_product - module procedure inner_product_array_field, inner_product_field_array, & - inner_product_field_field - end interface inner_product - - ! This is named cross_prod rather than cross_product to avoid a name - ! clash with various cross_product functions (this one is a subroutine). - interface cross_prod - module procedure cross_product_vector - end interface cross_prod - - interface clone_header - module procedure clone_header_scalar, clone_header_vector, clone_header_tensor - end interface clone_header - - interface normalise - module procedure normalise_scalar, normalise_vector - end interface - - interface remap_to_subdomain - module procedure remap_to_subdomain_scalar, remap_to_subdomain_vector, remap_to_subdomain_tensor - end interface - - interface remap_to_full_domain - module procedure remap_to_full_domain_scalar, remap_to_full_domain_vector, remap_to_full_domain_tensor - end interface - - interface zero_bubble_vals - module procedure zero_bubble_vals_scalar, zero_bubble_vals_vector, zero_bubble_vals_tensor - end interface - - interface ele_zero_bubble_val - module procedure ele_zero_bubble_val_scalar, ele_zero_bubble_val_vector, ele_zero_bubble_val_tensor - end interface - - type patch_type - !!< This is a type that represents a patch of elements around a given node. - - ! Really this isn't necessary, as it's just an array, but - ! I think encapsulation is good. - - !! The number of elements around the node - integer :: count - !! The array of element indices surrounding the node - integer, dimension(:), pointer :: elements - end type patch_type - - - contains - - subroutine tensor_second_invariant(t_field,second_invariant) + use fldebug + use vector_tools + use futils, only: present_and_true + use element_numbering + use elements + use element_set + use data_structures + use halo_data_types + use quicksort + use parallel_tools + use halos_base + use halos_debug + use memory_diagnostics + use halos_allocates + use sparse_tools + use embed_python + use fields_data_types + use fields_base + use halos_numbering + use halos_ownership + use halos_repair + use fields_allocates + implicit none + + private + + public :: addto, set_from_function, set, set_all, & + & set_from_python_function, remap_field, remap_field_to_surface, & + & set_to_submesh, set_from_submesh, scale, bound, invert, & + & absolute_value, inner_product, cross_prod, clone_header + public :: piecewise_constant_field, piecewise_constant_mesh + public :: renumber_positions, renumber_positions_trailing_receives, & + & renumber_positions_elements, & + & renumber_positions_elements_trailing_receives, reorder_element_numbering + public :: get_patch_ele, get_patch_node, patch_type + public :: set_ele_nodes, normalise, tensor_second_invariant + public :: remap_to_subdomain, remap_to_full_domain + public :: get_coordinates_remapped_to_surface, get_remapped_coordinates + public :: power + public :: zero_bubble_vals, ele_zero_bubble_val + + integer, parameter, public :: REMAP_ERR_DISCONTINUOUS_CONTINUOUS = 1, & + REMAP_ERR_HIGHER_LOWER_CONTINUOUS = 2, & + REMAP_ERR_UNPERIODIC_PERIODIC = 3, & + REMAP_ERR_BUBBLE_LAGRANGE = 4 + + interface addto + module procedure scalar_field_vaddto, scalar_field_addto, & + vector_field_addto, vector_field_vaddto_dim, tensor_field_addto, & + tensor_field_vaddto, tensor_field_vaddto_single, tensor_field_vaddto_dim, & + vector_field_vaddto_vec, scalar_field_addto_scalar, vector_field_addto_vector, & + scalar_field_addto_field, vector_field_addto_field, vector_field_addto_dim, & + vector_field_addto_field_dim, tensor_field_addto_field_dim_dim, & + tensor_field_addto_dim, tensor_field_addto_tensor_field, & + real_addto_real, vector_field_addto_field_scale_field + end interface + + interface set_from_function + module procedure set_from_function_scalar, set_from_function_vector,& + & set_from_function_tensor + end interface + + interface set + module procedure set_scalar_field_node, set_scalar_field, & + & set_vector_field_node, set_vector_field, & + & set_vector_field_node_dim, set_vector_field_dim, & + & set_tensor_field_node, set_tensor_field, set_tensor_field_dim, & + & set_scalar_field_nodes, set_scalar_field_constant_nodes, & + & set_tensor_field_node_dim, & + & set_vector_field_nodes, & + & set_vector_field_nodes_dim, & + & set_tensor_field_nodes, & + & set_scalar_field_field, & + & set_scalar_field_from_vector_field, & + & set_vector_field_field, & + & set_vector_field_field_dim, & + & set_tensor_field_field, & + & set_tensor_field_scalar_field, & + & set_tensor_field_diag_vector_field, & + & set_scalar_field_theta, set_vector_field_theta, & + & set_vector_field_vfield_dim, & + & set_tensor_field_theta + end interface + + interface set_all + module procedure set_vector_field_arr, set_vector_field_arr_dim, & + & set_scalar_field_arr, set_tensor_field_arr, & + & set_tensor_field_arr_dim + end interface + + interface set_from_python_function + module procedure set_from_python_function_scalar,& + & set_from_python_function_vector, & + & set_from_python_function_tensor + end interface + + interface test_remap_validity + module procedure test_remap_validity_scalar, test_remap_validity_vector, & + test_remap_validity_tensor, test_remap_validity_generic + end interface + + interface remap_field + module procedure remap_scalar_field, remap_vector_field, remap_tensor_field, & + & remap_scalar_field_specific, remap_vector_field_specific + end interface + + interface remap_field_to_surface + module procedure remap_scalar_field_to_surface, remap_vector_field_to_surface, remap_tensor_field_to_surface + end interface + + interface set_to_submesh + module procedure set_to_submesh_scalar, set_to_submesh_vector + end interface + + interface set_from_submesh + module procedure set_from_submesh_scalar, set_from_submesh_vector + end interface + + interface scale + module procedure scalar_scale, vector_scale, tensor_scale, & + scalar_scale_scalar_field, & + vector_scale_scalar_field, & + tensor_scale_scalar_field, & + vector_scale_vector_field, & + tensor_scale_tensor_field + end interface + + interface power + module procedure scalar_power, vector_power, tensor_power, & + scalar_power_scalar_field, & + vector_power_scalar_field, & + tensor_power_scalar_field + end interface + + interface bound + module procedure bound_scalar_field, bound_scalar_field_field, bound_vector_field, bound_tensor_field + end interface + + interface invert + module procedure invert_scalar_field, invert_vector_field, invert_tensor_field, & + invert_scalar_field_inplace, invert_vector_field_inplace, invert_tensor_field_inplace + end interface + + interface absolute_value + module procedure absolute_value_scalar_field + end interface + + interface inner_product + module procedure inner_product_array_field, inner_product_field_array, & + inner_product_field_field + end interface inner_product + + ! This is named cross_prod rather than cross_product to avoid a name + ! clash with various cross_product functions (this one is a subroutine). + interface cross_prod + module procedure cross_product_vector + end interface cross_prod + + interface clone_header + module procedure clone_header_scalar, clone_header_vector, clone_header_tensor + end interface clone_header + + interface normalise + module procedure normalise_scalar, normalise_vector + end interface + + interface remap_to_subdomain + module procedure remap_to_subdomain_scalar, remap_to_subdomain_vector, remap_to_subdomain_tensor + end interface + + interface remap_to_full_domain + module procedure remap_to_full_domain_scalar, remap_to_full_domain_vector, remap_to_full_domain_tensor + end interface + + interface zero_bubble_vals + module procedure zero_bubble_vals_scalar, zero_bubble_vals_vector, zero_bubble_vals_tensor + end interface + + interface ele_zero_bubble_val + module procedure ele_zero_bubble_val_scalar, ele_zero_bubble_val_vector, ele_zero_bubble_val_tensor + end interface + + type patch_type + !!< This is a type that represents a patch of elements around a given node. + + ! Really this isn't necessary, as it's just an array, but + ! I think encapsulation is good. + + !! The number of elements around the node + integer :: count + !! The array of element indices surrounding the node + integer, dimension(:), pointer :: elements + end type patch_type + + +contains + + subroutine tensor_second_invariant(t_field,second_invariant) !!< This routine computes the second invariant of an infield tensor field t_field. !!< Note - currently assumes that tensor field t_field is symmetric. type(tensor_field), intent(in):: t_field @@ -250,4152 +250,4152 @@ subroutine tensor_second_invariant(t_field,second_invariant) call deallocate(t_field_local) - end subroutine tensor_second_invariant + end subroutine tensor_second_invariant - subroutine scalar_field_vaddto(field, node_numbers, val) - !!< Add val to the field%val(node_numbers) for a vector of - !!< node_numbers. - !!< - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(size(node_numbers)), intent(in) :: val + subroutine scalar_field_vaddto(field, node_numbers, val) + !!< Add val to the field%val(node_numbers) for a vector of + !!< node_numbers. + !!< + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(size(node_numbers)), intent(in) :: val - integer :: j + integer :: j - assert(field%field_type==FIELD_TYPE_NORMAL) - ! Note that this has to be a do loop in case i contains repeated - ! indices. - do j=1,size(node_numbers) - field%val(node_numbers(j))=field%val(node_numbers(j))+val(j) - end do + assert(field%field_type==FIELD_TYPE_NORMAL) + ! Note that this has to be a do loop in case i contains repeated + ! indices. + do j=1,size(node_numbers) + field%val(node_numbers(j))=field%val(node_numbers(j))+val(j) + end do - end subroutine scalar_field_vaddto + end subroutine scalar_field_vaddto - subroutine scalar_field_addto(field, node_number, val) - !!< Add val to the field%val(node_number). - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - integer, intent(in) :: node_number - real, intent(in) :: val + subroutine scalar_field_addto(field, node_number, val) + !!< Add val to the field%val(node_number). + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + integer, intent(in) :: node_number + real, intent(in) :: val - assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(node_number)=field%val(node_number)+val + assert(field%field_type==FIELD_TYPE_NORMAL) + field%val(node_number)=field%val(node_number)+val - end subroutine scalar_field_addto + end subroutine scalar_field_addto - subroutine scalar_field_addto_scalar(field, val) - !!< Add val to field%val - !!< Works for both constant and space varying fields - type(scalar_field), intent(inout) :: field - real, intent(in) :: val + subroutine scalar_field_addto_scalar(field, val) + !!< Add val to field%val + !!< Works for both constant and space varying fields + type(scalar_field), intent(inout) :: field + real, intent(in) :: val - assert(field%field_type/=FIELD_TYPE_PYTHON) - field%val=field%val+val + assert(field%field_type/=FIELD_TYPE_PYTHON) + field%val=field%val+val - end subroutine scalar_field_addto_scalar + end subroutine scalar_field_addto_scalar - subroutine vector_field_addto_vector(field, val) - !!< Add val to field%val - !!< Works for both constant and space varying fields - type(vector_field), intent(inout) :: field - real, dimension(field%dim), intent(in) :: val + subroutine vector_field_addto_vector(field, val) + !!< Add val to field%val + !!< Works for both constant and space varying fields + type(vector_field), intent(inout) :: field + real, dimension(field%dim), intent(in) :: val - integer :: i + integer :: i - assert(field%field_type/=FIELD_TYPE_PYTHON) - do i = 1, field%dim - field%val(i,:)=field%val(i,:)+val(i) - end do + assert(field%field_type/=FIELD_TYPE_PYTHON) + do i = 1, field%dim + field%val(i,:)=field%val(i,:)+val(i) + end do - end subroutine vector_field_addto_vector + end subroutine vector_field_addto_vector - subroutine vector_field_addto(field, node_number, val) - !!< Add val to the field%val(node_number). - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, intent(in) :: node_number - real, dimension(field%dim), intent(in) :: val + subroutine vector_field_addto(field, node_number, val) + !!< Add val to the field%val(node_number). + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, intent(in) :: node_number + real, dimension(field%dim), intent(in) :: val - integer :: j + integer :: j - assert(field%field_type==FIELD_TYPE_NORMAL) + assert(field%field_type==FIELD_TYPE_NORMAL) - do j=1,field%dim - field%val(j,node_number)=field%val(j,node_number)+val(j) - end do + do j=1,field%dim + field%val(j,node_number)=field%val(j,node_number)+val(j) + end do - end subroutine vector_field_addto + end subroutine vector_field_addto - subroutine vector_field_addto_dim(field, dim, node_number, val) - !!< Add val to the field%val(node_number) only for the specified dim - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, intent(in) :: dim, node_number - real, intent(in) :: val + subroutine vector_field_addto_dim(field, dim, node_number, val) + !!< Add val to the field%val(node_number) only for the specified dim + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, intent(in) :: dim, node_number + real, intent(in) :: val - assert(field%field_type==FIELD_TYPE_NORMAL) + assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(dim,node_number)=field%val(dim,node_number)+val + field%val(dim,node_number)=field%val(dim,node_number)+val - end subroutine vector_field_addto_dim + end subroutine vector_field_addto_dim - subroutine vector_field_vaddto_dim(field, dim, node_numbers, val) - !!< Add val to dimension dim of the field%val(node_numbers) for a - !!< vector of node_numbers. - !!< - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - integer, intent(in) :: dim - real, dimension(size(node_numbers)), intent(in) :: val + subroutine vector_field_vaddto_dim(field, dim, node_numbers, val) + !!< Add val to dimension dim of the field%val(node_numbers) for a + !!< vector of node_numbers. + !!< + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + integer, intent(in) :: dim + real, dimension(size(node_numbers)), intent(in) :: val - integer :: j + integer :: j - assert(field%field_type==FIELD_TYPE_NORMAL) - do j=1,size(node_numbers) - field%val(dim,node_numbers(j))& + assert(field%field_type==FIELD_TYPE_NORMAL) + do j=1,size(node_numbers) + field%val(dim,node_numbers(j))& =field%val(dim,node_numbers(j))+val(j) - end do - - end subroutine vector_field_vaddto_dim - - subroutine vector_field_vaddto_vec(field, node_numbers, val) - !!< Add val(:, node) to field for each node in node_numbers. - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(:, :), intent(in) :: val - - integer :: i - assert(size(val, 1) == field%dim) - assert(size(val, 2) == size(node_numbers)) - - assert(field%field_type==FIELD_TYPE_NORMAL) - do i=1,size(node_numbers) - call addto(field, node_numbers(i), val(:, i)) - end do - - end subroutine vector_field_vaddto_vec - - subroutine tensor_field_addto(field, node_number, val) - !!< Add val to the field%val(i). - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, intent(in) :: node_number - real, dimension(:,:), intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(:,:,node_number)=field%val(:,:,node_number)+val - - end subroutine tensor_field_addto - - subroutine tensor_field_vaddto(field, node_numbers, val) - !!< Add val(:,:,i) to field%val(:,:,i) for vector of node_numbers. - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(:, :, :), intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(:, :, node_numbers) = field%val(:, :, node_numbers) + val - - end subroutine tensor_field_vaddto - - subroutine tensor_field_vaddto_single(field, node_numbers, val) - !!< Add val(:,:,node_numbers) to field%val(:,:,node_numbers) for vector - !!< of node_numbers. - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(:, :), intent(in) :: val - - integer :: j - - assert(field%field_type==FIELD_TYPE_NORMAL) - do j=1,size(node_numbers) - field%val(:, :, node_numbers(j)) & - = field%val(:, :, node_numbers(j)) + val - end do - - end subroutine tensor_field_vaddto_single - - subroutine tensor_field_vaddto_dim(field, dim1, dim2, node_numbers, val) - !!< Add val(node_numbers) to field%val(dim1,dim2,node_numbers) for - !!< vector of node_numbers. - !!< - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, intent(in) :: dim1, dim2 - integer, dimension(:), intent(in) :: node_numbers - real, dimension(:), intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(dim1, dim2, node_numbers) & - = field%val(dim1, dim2, node_numbers) + val - - end subroutine tensor_field_vaddto_dim - - subroutine tensor_field_addto_dim(field, dim1, dim2, node_number, val) - !!< Add val(node_number) to field%val(dim1,dim2,node_number) for a single node_number. - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, intent(in) :: dim1, dim2 - integer, intent(in) :: node_number - real, intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - field%val(dim1, dim2, node_number) = field%val(dim1, dim2, node_number) + val - - end subroutine tensor_field_addto_dim - - subroutine scalar_field_addto_field(field1, field2, scale) - !!< Compute field1=field1+[scale*]field2. - !!< Works for constant and space varying fields. - !!< if field1%mesh/=field2%mesh map field2 to field1%mesh first - !!< (same restrictions apply as mentioned in remap_field() ) - type(scalar_field), intent(inout) :: field1 - type(scalar_field), intent(in) :: field2 - real, intent(in), optional :: scale - - type(scalar_field) lfield2 - - assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lfield2, field1%mesh) - call remap_field(field2, lfield2) - else - lfield2=field2 - end if - - if (field1%field_type==field2%field_type) then - if (present(scale)) then - field1%val=field1%val+scale*lfield2%val - else - field1%val=field1%val+lfield2%val - end if - else if (field1%field_type==FIELD_TYPE_NORMAL) then - - assert(field2%field_type==FIELD_TYPE_CONSTANT) - if (present(scale)) then - field1%val=field1%val+scale*field2%val(1) - else - field1%val=field1%val+field2%val(1) - end if - - else - - FLAbort("Illegal addition for given field types.") - - end if - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call deallocate(lfield2) - end if - - end subroutine scalar_field_addto_field - - subroutine vector_field_addto_field(field1, field2, scale) - !!< Compute field1=field1+[scale*]field2. - !!< Works for constant and space varying fields. - !!< if field1%mesh/=field2%mesh map field2 to field1%mesh first - !!< (same restrictions apply as mentioned in remap_field() ) - type(vector_field), intent(inout) :: field1 - type(vector_field), intent(in) :: field2 - real, intent(in), optional :: scale - - integer :: i - - type(vector_field) lfield2 - - assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - assert(field1%dim==field2%dim) - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lfield2, field1%dim, field1%mesh) - call remap_field(field2, lfield2) - else - lfield2=field2 - end if - - if (field1%field_type==field2%field_type) then - if (present(scale)) then - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+scale*lfield2%val(i,:) - end do - else - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+lfield2%val(i,:) - end do - end if - else if (field1%field_type==FIELD_TYPE_NORMAL) then - - assert(field2%field_type==FIELD_TYPE_CONSTANT) - if (present(scale)) then - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+scale*field2%val(i,1) - end do - else - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+field2%val(i,1) - end do - end if - else - - FLAbort("Illegal addition for given field types.") - - end if - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call deallocate(lfield2) - end if - - end subroutine vector_field_addto_field - - subroutine vector_field_addto_field_scale_field(field1, field2, scale) - !!< Compute field1=field1+[scale*]field2. - !!< In this version of the routine, scale is a scalar field. - !!< Works for constant and space varying fields. - !!< if field1%mesh/=field2%mesh map field2 to field1%mesh first - !!< (same restrictions apply as mentioned in remap_field() ) - type(vector_field), intent(inout) :: field1 - type(vector_field), intent(in) :: field2 - type(scalar_field), intent(in) :: scale - - integer :: i - - type(vector_field) :: lfield2 - type(scalar_field) :: lscale - - assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - assert(field1%dim==field2%dim) - assert(lscale%field_type/=FIELD_TYPE_PYTHON) - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lfield2, field1%dim, field1%mesh) - call remap_field(field2, lfield2) - else - lfield2=field2 - call incref(lfield2) - end if - - if (.not. field1%mesh==scale%mesh .and. .not. scale%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lscale, field1%mesh) - call remap_field(scale, lscale) - else - lscale=scale - call incref(scale) - end if - - if (field1%field_type==FIELD_TYPE_CONSTANT) then - - if ((lfield2%field_type==FIELD_TYPE_CONSTANT) .and. & - (lscale%field_type==FIELD_TYPE_CONSTANT)) then + end do - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+lscale%val*lfield2%val(i,:) - end do + end subroutine vector_field_vaddto_dim - else + subroutine vector_field_vaddto_vec(field, node_numbers, val) + !!< Add val(:, node) to field for each node in node_numbers. + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(:, :), intent(in) :: val - FLAbort("Illegal addition for given field types.") + integer :: i + assert(size(val, 1) == field%dim) + assert(size(val, 2) == size(node_numbers)) - end if + assert(field%field_type==FIELD_TYPE_NORMAL) + do i=1,size(node_numbers) + call addto(field, node_numbers(i), val(:, i)) + end do - else - ! field1 is not constant. + end subroutine vector_field_vaddto_vec - if ((lfield2%field_type==FIELD_TYPE_CONSTANT) .and. & - (lscale%field_type==FIELD_TYPE_CONSTANT)) then + subroutine tensor_field_addto(field, node_number, val) + !!< Add val to the field%val(i). + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, intent(in) :: node_number + real, dimension(:,:), intent(in) :: val - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+lscale%val(1)*lfield2%val(i,1) - end do + assert(field%field_type==FIELD_TYPE_NORMAL) + field%val(:,:,node_number)=field%val(:,:,node_number)+val - else if ((lfield2%field_type==FIELD_TYPE_NORMAL) .and. & - (lscale%field_type==FIELD_TYPE_CONSTANT)) then + end subroutine tensor_field_addto - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+lscale%val(1)*lfield2%val(i,:) - end do + subroutine tensor_field_vaddto(field, node_numbers, val) + !!< Add val(:,:,i) to field%val(:,:,i) for vector of node_numbers. + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(:, :, :), intent(in) :: val - else if ((lfield2%field_type==FIELD_TYPE_CONSTANT) .and. & - (lscale%field_type==FIELD_TYPE_NORMAL)) then + assert(field%field_type==FIELD_TYPE_NORMAL) + field%val(:, :, node_numbers) = field%val(:, :, node_numbers) + val - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+lscale%val*lfield2%val(i,1) - end do + end subroutine tensor_field_vaddto - else if ((lfield2%field_type==FIELD_TYPE_NORMAL) .and. & - (lscale%field_type==FIELD_TYPE_NORMAL)) then + subroutine tensor_field_vaddto_single(field, node_numbers, val) + !!< Add val(:,:,node_numbers) to field%val(:,:,node_numbers) for vector + !!< of node_numbers. + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(:, :), intent(in) :: val - do i=1,field1%dim - field1%val(i,:)=field1%val(i,:)+lscale%val*lfield2%val(i,:) - end do - - else - - FLAbort("Illegal addition for given field types.") - - end if - - end if - - call deallocate(lfield2) - call deallocate(lscale) - - end subroutine vector_field_addto_field_scale_field - - subroutine vector_field_addto_field_dim(field1, dim, field2, scale) - !!< Compute field1(dim)=field1(dim)+scale*field2. - !!< Works for constant and space varying fields. - type(vector_field), intent(inout) :: field1 - integer, intent(in) :: dim - type(scalar_field), intent(in) :: field2 - real, intent(in), optional :: scale - - type(scalar_field) lfield2 - - assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - ! only allow addition to non-constant field1 or - ! addition of constant field1 and constant field2 - assert(field1%field_type==FIELD_TYPE_NORMAL .or. field2%field_type==FIELD_TYPE_CONSTANT) - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lfield2, field1%mesh) - call remap_field(field2, lfield2) - else - lfield2=field2 - end if - - if (field1%field_type==field2%field_type) then - if (present(scale)) then - field1%val(dim,:)=field1%val(dim,:)+scale*lfield2%val - else - field1%val(dim,:)=field1%val(dim,:)+lfield2%val - end if - else if (field1%field_type==FIELD_TYPE_NORMAL) then - - assert(field2%field_type==FIELD_TYPE_CONSTANT) - if (present(scale)) then - field1%val(dim,:)=field1%val(dim,:)+scale*field2%val(1) - else - field1%val(dim,:)=field1%val(dim,:)+field2%val(1) - end if - else - - FLAbort("Illegal addition for given field types.") - - end if - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call deallocate(lfield2) - end if - - end subroutine vector_field_addto_field_dim - - subroutine tensor_field_addto_field_dim_dim(field1, dim1, dim2, field2, scale) - !!< Compute field1(dim1,dim2)=field1(dim1,dim2)+scale*field2. - !!< Works for constant and space varying fields. - type(tensor_field), intent(inout) :: field1 - integer, intent(in) :: dim1, dim2 - type(scalar_field), intent(in) :: field2 - real, intent(in), optional :: scale - - type(scalar_field) lfield2 - - assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - ! only allow addition to non-constant field1 or - ! addition of constant field1 and constant field2 - assert(field1%field_type==FIELD_TYPE_NORMAL .or. field2%field_type==FIELD_TYPE_CONSTANT) - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lfield2, field1%mesh) - call remap_field(field2, lfield2) - else - lfield2=field2 - end if - - if (field1%field_type==field2%field_type) then - if (present(scale)) then - field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+scale*lfield2%val - else - field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+lfield2%val - end if - else if (field1%field_type==FIELD_TYPE_NORMAL) then - - assert(field2%field_type==FIELD_TYPE_CONSTANT) - if (present(scale)) then - field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+scale*field2%val(1) - else - field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+field2%val(1) - end if - else - - FLAbort("Illegal addition for given field types.") - - end if - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call deallocate(lfield2) - end if - - end subroutine tensor_field_addto_field_dim_dim - - subroutine tensor_field_addto_tensor_field(field1, field2, scale) - !!< Compute field1(dim1,dim2)=field1(dim1,dim2)+scale*field2. - !!< Works for constant and space varying fields. - type(tensor_field), intent(inout) :: field1 - type(tensor_field), intent(in) :: field2 - real, intent(in), optional :: scale - integer :: i - - type(tensor_field) lfield2 - - assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - ! only allow addition to non-constant field1 or - ! addition of constant field1 and constant field2 - assert(field1%field_type==FIELD_TYPE_NORMAL .or. field2%field_type==FIELD_TYPE_CONSTANT) - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call allocate(lfield2, field1%mesh) - call remap_field(field2, lfield2) - else - lfield2=field2 - end if - - if (field1%field_type==field2%field_type) then - if (present(scale)) then - field1%val(:,:,:)=field1%val(:, :,:) +scale*lfield2%val(:, :, :) - else - field1%val=field1%val+lfield2%val - end if - else if (field1%field_type==FIELD_TYPE_NORMAL) then - - assert(field2%field_type==FIELD_TYPE_CONSTANT) - if (present(scale)) then - forall(i=1:size(field1%val, 3)) - field1%val(:, :, i)=field1%val(:, :, i)+scale*field2%val(:, :, 1) - end forall - else - forall(i=1:size(field1%val, 3)) - field1%val(:, :, i)=field1%val(:, :, i)+field2%val(:, :, 1) - end forall - end if - else - - FLAbort("Illegal addition for given field types.") - - end if - - if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then - call deallocate(lfield2) - end if - - end subroutine tensor_field_addto_tensor_field - - subroutine real_addto_real(arr, idx, val) - ! Real recognize real, dunn. Fo' life. - - real, dimension(:), intent(inout) :: arr - integer, dimension(:), intent(in) :: idx - real, dimension(size(idx)), intent(in) :: val - - arr(idx) = arr(idx) + val - end subroutine real_addto_real - - subroutine set_scalar_field_field(out_field, in_field) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(scalar_field), intent(inout) :: out_field - type(scalar_field), intent(in) :: in_field - - assert(mesh_compatible(out_field%mesh, in_field%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) - assert(out_field%field_type==FIELD_TYPE_NORMAL .or. in_field%field_type==FIELD_TYPE_CONSTANT) - - select case (in_field%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val=in_field%val - case (FIELD_TYPE_CONSTANT) - out_field%val=in_field%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_scalar_field_field - - subroutine set_scalar_field_from_vector_field(out_field, in_field, dim) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(scalar_field), intent(inout) :: out_field - type(vector_field), intent(in) :: in_field - integer, intent(in) :: dim - - assert(mesh_compatible(out_field%mesh, in_field%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) - assert(out_field%field_type==FIELD_TYPE_NORMAL .or. in_field%field_type==FIELD_TYPE_CONSTANT) - assert(dim>=1 .and. dim<=in_field%dim) - - select case (in_field%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val=in_field%val(dim,:) - case (FIELD_TYPE_CONSTANT) - out_field%val=in_field%val(dim,1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_scalar_field_from_vector_field - - subroutine set_scalar_field_node(field, node_number, val) - !!< Set the scalar field at the specified node - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - integer, intent(in) :: node_number - real, intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - - field%val(node_number) = val - - end subroutine set_scalar_field_node - - subroutine set_scalar_field_nodes(field, node_numbers, val) - !!< Set the scalar field at the specified node_numbers - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, dimension(:), intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - assert(size(node_numbers)==size(val)) - - field%val(node_numbers) = val + integer :: j - end subroutine set_scalar_field_nodes + assert(field%field_type==FIELD_TYPE_NORMAL) + do j=1,size(node_numbers) + field%val(:, :, node_numbers(j)) & + = field%val(:, :, node_numbers(j)) + val + end do - subroutine set_scalar_field_constant_nodes(field, node_numbers, val) - !!< Set the scalar field at the specified node_numbers - !!< to a constant value - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, intent(in) :: val + end subroutine tensor_field_vaddto_single - assert(field%field_type==FIELD_TYPE_NORMAL) + subroutine tensor_field_vaddto_dim(field, dim1, dim2, node_numbers, val) + !!< Add val(node_numbers) to field%val(dim1,dim2,node_numbers) for + !!< vector of node_numbers. + !!< + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, intent(in) :: dim1, dim2 + integer, dimension(:), intent(in) :: node_numbers + real, dimension(:), intent(in) :: val - field%val(node_numbers) = val + assert(field%field_type==FIELD_TYPE_NORMAL) + field%val(dim1, dim2, node_numbers) & + = field%val(dim1, dim2, node_numbers) + val - end subroutine set_scalar_field_constant_nodes + end subroutine tensor_field_vaddto_dim - subroutine set_scalar_field(field, val) - !!< Set the scalar field with a constant value - !!< Works for constant and space varying fields. - type(scalar_field), intent(inout) :: field - real, intent(in) :: val + subroutine tensor_field_addto_dim(field, dim1, dim2, node_number, val) + !!< Add val(node_number) to field%val(dim1,dim2,node_number) for a single node_number. + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, intent(in) :: dim1, dim2 + integer, intent(in) :: node_number + real, intent(in) :: val - assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL) + field%val(dim1, dim2, node_number) = field%val(dim1, dim2, node_number) + val - field%val = val + end subroutine tensor_field_addto_dim - end subroutine set_scalar_field + subroutine scalar_field_addto_field(field1, field2, scale) + !!< Compute field1=field1+[scale*]field2. + !!< Works for constant and space varying fields. + !!< if field1%mesh/=field2%mesh map field2 to field1%mesh first + !!< (same restrictions apply as mentioned in remap_field() ) + type(scalar_field), intent(inout) :: field1 + type(scalar_field), intent(in) :: field2 + real, intent(in), optional :: scale - subroutine set_scalar_field_arr(field, val) - !!< Set the scalar field at all nodes at once - !!< Does not work for constant fields - type(scalar_field), intent(inout) :: field - real, dimension(:), intent(in) :: val + type(scalar_field) lfield2 - assert(field%field_type==FIELD_TYPE_NORMAL) + assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) - field%val = val + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lfield2, field1%mesh) + call remap_field(field2, lfield2) + else + lfield2=field2 + end if - end subroutine set_scalar_field_arr + if (field1%field_type==field2%field_type) then + if (present(scale)) then + field1%val=field1%val+scale*lfield2%val + else + field1%val=field1%val+lfield2%val + end if + else if (field1%field_type==FIELD_TYPE_NORMAL) then + + assert(field2%field_type==FIELD_TYPE_CONSTANT) + if (present(scale)) then + field1%val=field1%val+scale*field2%val(1) + else + field1%val=field1%val+field2%val(1) + end if - subroutine set_vector_field_node(field, node, val) - !!< Set the vector field at the specified node - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, intent(in) :: node - real, intent(in), dimension(:) :: val - integer :: i + else - assert(field%field_type==FIELD_TYPE_NORMAL) + FLAbort("Illegal addition for given field types.") - do i=1,field%dim - field%val(i,node) = val(i) - end do + end if - end subroutine set_vector_field_node + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call deallocate(lfield2) + end if - subroutine set_scalar_field_theta(out_field, in_field_new, in_field_old, theta) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(scalar_field), intent(inout) :: out_field - type(scalar_field), intent(in) :: in_field_new, in_field_old - real, intent(in) :: theta + end subroutine scalar_field_addto_field - assert(mesh_compatible(out_field%mesh, in_field_new%mesh)) - assert(mesh_compatible(out_field%mesh, in_field_old%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) -#ifndef NDEBUG - if(.not.(out_field%field_type==FIELD_TYPE_NORMAL .or. & - (in_field_new%field_type==FIELD_TYPE_CONSTANT .and. & - in_field_old%field_type==FIELD_TYPE_CONSTANT))) then - ewrite(-1,*) "Incompatible field types in set()" - FLAbort("evilness unleashed") - end if -#endif + subroutine vector_field_addto_field(field1, field2, scale) + !!< Compute field1=field1+[scale*]field2. + !!< Works for constant and space varying fields. + !!< if field1%mesh/=field2%mesh map field2 to field1%mesh first + !!< (same restrictions apply as mentioned in remap_field() ) + type(vector_field), intent(inout) :: field1 + type(vector_field), intent(in) :: field2 + real, intent(in), optional :: scale - select case (in_field_new%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val=theta*in_field_new%val + (1.-theta)*in_field_old%val - case (FIELD_TYPE_CONSTANT) - out_field%val=theta*in_field_new%val(1) + (1.-theta)*in_field_old%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select + integer :: i - end subroutine set_scalar_field_theta + type(vector_field) lfield2 - subroutine set_vector_field_node_dim(field, dim, node, val) - !!< Set the vector field at the specified node - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, intent(in) :: node - real, intent(in) :: val - integer, intent(in):: dim + assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) + assert(field1%dim==field2%dim) - assert(field%field_type==FIELD_TYPE_NORMAL) - assert(dim>=1 .and. dim<=field%dim) + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lfield2, field1%dim, field1%mesh) + call remap_field(field2, lfield2) + else + lfield2=field2 + end if - field%val(dim,node) = val + if (field1%field_type==field2%field_type) then + if (present(scale)) then + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+scale*lfield2%val(i,:) + end do + else + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+lfield2%val(i,:) + end do + end if + else if (field1%field_type==FIELD_TYPE_NORMAL) then - end subroutine set_vector_field_node_dim + assert(field2%field_type==FIELD_TYPE_CONSTANT) + if (present(scale)) then + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+scale*field2%val(i,1) + end do + else + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+field2%val(i,1) + end do + end if + else - subroutine set_vector_field_nodes(field, node_numbers, val) - !!< Set the vector field at the specified nodes - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - !! values to set ( dimension x #nodes) - real, intent(in), dimension(:,:) :: val - integer :: i + FLAbort("Illegal addition for given field types.") - assert(field%field_type==FIELD_TYPE_NORMAL) + end if - do i=1,field%dim - field%val(i,node_numbers) = val(i, :) - end do + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call deallocate(lfield2) + end if - end subroutine set_vector_field_nodes + end subroutine vector_field_addto_field - subroutine set_vector_field_nodes_dim(field, dim, node_numbers, val) - !!< Set the vector field at the specified nodes - !!< Does not work for constant fields - type(vector_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - !! values to set - real, intent(in), dimension(:) :: val - integer, intent(in) :: dim + subroutine vector_field_addto_field_scale_field(field1, field2, scale) + !!< Compute field1=field1+[scale*]field2. + !!< In this version of the routine, scale is a scalar field. + !!< Works for constant and space varying fields. + !!< if field1%mesh/=field2%mesh map field2 to field1%mesh first + !!< (same restrictions apply as mentioned in remap_field() ) + type(vector_field), intent(inout) :: field1 + type(vector_field), intent(in) :: field2 + type(scalar_field), intent(in) :: scale - assert(field%field_type==FIELD_TYPE_NORMAL) - assert(dim>=1 .and. dim<=field%dim) + integer :: i - field%val(dim,node_numbers) = val + type(vector_field) :: lfield2 + type(scalar_field) :: lscale - end subroutine set_vector_field_nodes_dim + assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) + assert(field1%dim==field2%dim) + assert(lscale%field_type/=FIELD_TYPE_PYTHON) - subroutine set_vector_field(field, val) - !!< Set the vector field with a constant value - !!< Works for constant and space varying fields. - type(vector_field), intent(inout) :: field - real, intent(in), dimension(:) :: val - integer :: i + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lfield2, field1%dim, field1%mesh) + call remap_field(field2, lfield2) + else + lfield2=field2 + call incref(lfield2) + end if - assert(field%field_type/=FIELD_TYPE_PYTHON) + if (.not. field1%mesh==scale%mesh .and. .not. scale%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lscale, field1%mesh) + call remap_field(scale, lscale) + else + lscale=scale + call incref(scale) + end if - do i=1,field%dim - field%val(i,:) = val(i) - end do + if (field1%field_type==FIELD_TYPE_CONSTANT) then - end subroutine set_vector_field + if ((lfield2%field_type==FIELD_TYPE_CONSTANT) .and. & + (lscale%field_type==FIELD_TYPE_CONSTANT)) then - subroutine set_vector_field_dim(field, dim, val) - !!< Set the vector field with a constant value - !!< Works for constant and space varying fields. - type(vector_field), intent(inout) :: field - real, intent(in):: val - integer, intent(in):: dim + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+lscale%val*lfield2%val(i,:) + end do - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(dim>=1 .and. dim<=field%dim) + else - field%val(dim,:) = val + FLAbort("Illegal addition for given field types.") - end subroutine set_vector_field_dim + end if - subroutine set_vector_field_arr(field, val) - !!< Set the vector field with an array for all nodes at once - type(vector_field), intent(inout) :: field - real, intent(in), dimension(:, :) :: val - integer :: i + else + ! field1 is not constant. - assert(field%field_type==FIELD_TYPE_NORMAL) + if ((lfield2%field_type==FIELD_TYPE_CONSTANT) .and. & + (lscale%field_type==FIELD_TYPE_CONSTANT)) then - do i=1,field%dim - field%val(i,:) = val(i, :) - end do + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+lscale%val(1)*lfield2%val(i,1) + end do - end subroutine set_vector_field_arr + else if ((lfield2%field_type==FIELD_TYPE_NORMAL) .and. & + (lscale%field_type==FIELD_TYPE_CONSTANT)) then - subroutine set_vector_field_arr_dim(field, dim, val) - !!< Set the vector field with an array for all nodes at once - type(vector_field), intent(inout) :: field - real, intent(in), dimension(:) :: val - integer, intent(in):: dim + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+lscale%val(1)*lfield2%val(i,:) + end do - assert(field%field_type==FIELD_TYPE_NORMAL) - assert(dim>=1 .and. dim<=field%dim) + else if ((lfield2%field_type==FIELD_TYPE_CONSTANT) .and. & + (lscale%field_type==FIELD_TYPE_NORMAL)) then - field%val(dim,:) = val + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+lscale%val*lfield2%val(i,1) + end do - end subroutine set_vector_field_arr_dim + else if ((lfield2%field_type==FIELD_TYPE_NORMAL) .and. & + (lscale%field_type==FIELD_TYPE_NORMAL)) then - subroutine set_vector_field_field(out_field, in_field ) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(vector_field), intent(inout) :: out_field - type(vector_field), intent(in) :: in_field + do i=1,field1%dim + field1%val(i,:)=field1%val(i,:)+lscale%val*lfield2%val(i,:) + end do - integer :: dim + else -#ifndef NDEBUG - assert(mesh_compatible(out_field%mesh, in_field%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) - if (.not. (out_field%field_type==FIELD_TYPE_NORMAL .or. & - (out_field%field_type==FIELD_TYPE_CONSTANT .and. in_field%field_type==FIELD_TYPE_CONSTANT))) then - FLAbort("Wrong field_type in set()") - end if - assert(in_field%dim==out_field%dim) -#endif + FLAbort("Illegal addition for given field types.") - select case (in_field%field_type) - case (FIELD_TYPE_NORMAL) - do dim=1,in_field%dim - out_field%val(dim,:)=in_field%val(dim,:) - end do - case (FIELD_TYPE_CONSTANT) - do dim=1,in_field%dim - out_field%val(dim,:)=in_field%val(dim,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_vector_field_field - - subroutine set_vector_field_theta(out_field, in_field_new, in_field_old, theta) - !!< Set theta*in_field_new + (1.-theta)*in_field_old to out_field. This will only work if the fields have - !!< the same mesh. - type(vector_field), intent(inout) :: out_field - type(vector_field), intent(in) :: in_field_new, in_field_old - real, intent(in) :: theta - - integer :: dim - - assert(mesh_compatible(out_field%mesh, in_field_new%mesh)) - assert(mesh_compatible(out_field%mesh, in_field_old%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) -#ifndef NDEBUG - if(.not.(out_field%field_type==FIELD_TYPE_NORMAL .or. & - (in_field_new%field_type==FIELD_TYPE_CONSTANT .and. & - in_field_old%field_type==FIELD_TYPE_CONSTANT))) then - ewrite(-1,*) "Incompatible field types in set()" - FLAbort("Evilness"); - end if -#endif - assert(in_field_new%dim==out_field%dim) - assert(in_field_old%dim==out_field%dim) + end if - select case (in_field_new%field_type) - case (FIELD_TYPE_NORMAL) - do dim = 1, out_field%dim - out_field%val(dim,:)=theta*in_field_new%val(dim,:) + (1.-theta)*in_field_old%val(dim,:) - end do - case (FIELD_TYPE_CONSTANT) - do dim = 1, out_field%dim - out_field%val(dim,:)=theta*in_field_new%val(dim,1) + (1.-theta)*in_field_old%val(dim,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select + end if - end subroutine set_vector_field_theta + call deallocate(lfield2) + call deallocate(lscale) - subroutine set_vector_field_field_dim(out_field, dim, in_field) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(vector_field), intent(inout) :: out_field - type(scalar_field), intent(in) :: in_field - integer, intent(in):: dim + end subroutine vector_field_addto_field_scale_field -#ifndef NDEBUG - assert(mesh_compatible(out_field%mesh, in_field%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) - if (.not. (out_field%field_type==FIELD_TYPE_NORMAL .or. & - (out_field%field_type==FIELD_TYPE_CONSTANT .and. in_field%field_type==FIELD_TYPE_CONSTANT))) then - FLAbort("Wrong field_type in set()") - end if - assert(dim>=1 .and. dim<=out_field%dim) -#endif + subroutine vector_field_addto_field_dim(field1, dim, field2, scale) + !!< Compute field1(dim)=field1(dim)+scale*field2. + !!< Works for constant and space varying fields. + type(vector_field), intent(inout) :: field1 + integer, intent(in) :: dim + type(scalar_field), intent(in) :: field2 + real, intent(in), optional :: scale - select case (in_field%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val(dim,:)=in_field%val - case (FIELD_TYPE_CONSTANT) - out_field%val(dim,:)=in_field%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_vector_field_field_dim - - subroutine set_vector_field_vfield_dim(out_field, dim, in_field) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(vector_field), intent(inout) :: out_field - type(vector_field), intent(in) :: in_field - integer, intent(in):: dim + type(scalar_field) lfield2 -#ifndef NDEBUG - assert(mesh_compatible(out_field%mesh, in_field%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) - if (.not. (out_field%field_type==FIELD_TYPE_NORMAL .or. & - (out_field%field_type==FIELD_TYPE_CONSTANT .and. in_field%field_type==FIELD_TYPE_CONSTANT))) then - FLAbort("Wrong field_type in set()") - end if - assert(dim>=1 .and. dim<=out_field%dim .and. dim<=in_field%dim) -#endif + assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) + ! only allow addition to non-constant field1 or + ! addition of constant field1 and constant field2 + assert(field1%field_type==FIELD_TYPE_NORMAL .or. field2%field_type==FIELD_TYPE_CONSTANT) - select case (in_field%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val(dim,:)=in_field%val(dim,:) - case (FIELD_TYPE_CONSTANT) - out_field%val(dim,:)=in_field%val(dim,1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_vector_field_vfield_dim - - subroutine set_tensor_field_field(out_field, in_field ) - !!< Set in_field to out_field. This will only work if the fields have - !!< the same mesh. - type(tensor_field), intent(inout) :: out_field - type(Tensor_field), intent(in) :: in_field - - integer i - - assert(mesh_compatible(out_field%mesh, in_field%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) - assert(out_field%field_type==FIELD_TYPE_NORMAL.or.in_field%field_type==FIELD_TYPE_CONSTANT) - assert(all(in_field%dim==out_field%dim)) - - select case (in_field%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val=in_field%val - case (FIELD_TYPE_CONSTANT) - do i=1, size(out_field%val,3) - out_field%val(:,:,i)=in_field%val(:,:,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_tensor_field_field - - subroutine set_tensor_field_theta(out_field, in_field_new, in_field_old, theta) - !!< Set theta*in_field_new + (1.-theta)*in_field_old to out_field. This will only work if the fields have - !!< the same mesh. - type(tensor_field), intent(inout) :: out_field - type(tensor_field), intent(in) :: in_field_new, in_field_old - real, intent(in) :: theta - - integer i - - assert(mesh_compatible(out_field%mesh, in_field_new%mesh)) - assert(mesh_compatible(out_field%mesh, in_field_old%mesh)) - assert(out_field%field_type/=FIELD_TYPE_PYTHON) -#ifndef NDEBUG - if(.not.(out_field%field_type==FIELD_TYPE_NORMAL .or. & - (in_field_new%field_type==FIELD_TYPE_CONSTANT .and. & - in_field_old%field_type==FIELD_TYPE_CONSTANT))) then - ewrite(-1,*) "Incompatible field types in set()" - FLAbort("Evil") - end if -#endif - assert(all(in_field_new%dim==out_field%dim)) - assert(all(in_field_old%dim==out_field%dim)) - - select case (in_field_new%field_type) - case (FIELD_TYPE_NORMAL) - out_field%val=theta*in_field_new%val + (1.-theta)*in_field_old%val - case (FIELD_TYPE_CONSTANT) - do i = 1, size(out_field%val, 3) - out_field%val(:,:,i)=theta*in_field_new%val(:,:,1) + (1.-theta)*in_field_old%val(:,:,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_tensor_field_theta - - subroutine set_tensor_field_scalar_field(tensor, i, j, scalar, symmetric, scale) - !!< Set the i,j^th component of tensor to be scalar. - type(tensor_field), intent(inout) :: tensor - integer, intent(in) :: i, j - type(scalar_field), intent(in) :: scalar - logical, intent(in), optional :: symmetric - real, intent(in), optional :: scale - - real :: lscale - - assert(tensor%mesh%refcount%id==scalar%mesh%refcount%id) - assert(tensor%field_type/=FIELD_TYPE_PYTHON) - assert(tensor%field_type==FIELD_TYPE_NORMAL .or. scalar%field_type==FIELD_TYPE_CONSTANT) - - if (present(scale)) then - lscale=scale - else - lscale=1.0 - end if - - select case (scalar%field_type) - case (FIELD_TYPE_NORMAL) - tensor%val(i, j, :) = scalar%val*lscale - if (present_and_true(symmetric)) then - tensor%val(j, i, :) = scalar%val*lscale - end if - case (FIELD_TYPE_CONSTANT) - tensor%val(i, j, :) = scalar%val(1)*lscale - - if (present_and_true(symmetric)) then - tensor%val(j, i, :) = scalar%val(1)*lscale - end if - case default - ! someone could implement scalar field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_tensor_field_scalar_field - - subroutine set_tensor_field_diag_vector_field(tensor, vector, scale) - !!< Set the diagonal components of tensor to be vector. - type(tensor_field), intent(inout) :: tensor - type(vector_field), intent(in) :: vector - real, intent(in), optional :: scale - - integer :: i - real :: lscale - - assert(tensor%mesh%refcount%id==vector%mesh%refcount%id) - assert(tensor%field_type/=FIELD_TYPE_PYTHON) - assert(tensor%field_type==FIELD_TYPE_NORMAL .or. vector%field_type==FIELD_TYPE_CONSTANT) - assert(minval(tensor%dim)==vector%dim) - - if (present(scale)) then - lscale=scale - else - lscale=1.0 - end if - - select case (vector%field_type) - case (FIELD_TYPE_NORMAL) - do i = 1, minval(tensor%dim) - tensor%val(i, i, :) = vector%val(i,:)*lscale - end do - case (FIELD_TYPE_CONSTANT) - do i = 1, minval(tensor%dim) - tensor%val(i, i, :) = vector%val(i,1)*lscale - end do - case default - ! someone could implement scalar field type python - FLAbort("Illegal in_field field type in set()") - end select - - end subroutine set_tensor_field_diag_vector_field - - subroutine set_tensor_field_node(field, node, val) - !!< Set the tensor field at the specified node - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, intent(in) :: node - real, intent(in), dimension(:, :) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - - field%val(:, :, node) = val - - end subroutine set_tensor_field_node - - subroutine set_tensor_field_node_dim(field, dim1, dim2, node, val) - !!< Set the tensor field at the specified node - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, intent(in) :: dim1, dim2, node - real, intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - assert(dim1>=1 .and. dim1<=field%dim(1)) - assert(dim2>=1 .and. dim2<=field%dim(2)) - - field%val(dim1, dim2, node) = val - - end subroutine set_tensor_field_node_dim - - subroutine set_tensor_field_nodes(field, node_numbers, val) - !!< Set the tensor field at the specified nodes - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - integer, dimension(:), intent(in) :: node_numbers - real, intent(in), dimension(:, :, :) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - - field%val(:, :, node_numbers) = val - - end subroutine set_tensor_field_nodes - - subroutine set_tensor_field(field, val) - !!< Sets tensor with constant value - !!< Works for constant and space varying fields. - type(tensor_field), intent(inout) :: field - real, intent(in), dimension(:, :) :: val - integer :: i - - assert(field%field_type/=FIELD_TYPE_PYTHON) - - do i=1,size(field%val, 3) - field%val(:, :, i) = val - end do - - end subroutine set_tensor_field - - subroutine set_tensor_field_dim(field, dim1, dim2, val) - !!< Sets one component of a tensor with constant value - !!< Works for constant and space varying fields. - type(tensor_field), intent(inout) :: field - real, intent(in) :: val - integer, intent(in):: dim1, dim2 - integer :: i - - assert(field%field_type/=FIELD_TYPE_PYTHON) - - do i=1,size(field%val, 3) - field%val(dim1, dim2, i) = val - end do - - end subroutine set_tensor_field_dim - - subroutine set_tensor_field_arr(field, val) - !!< Set the tensor field at all nodes at once - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - real, dimension(:,:,:), intent(in) :: val - - assert(field%field_type==FIELD_TYPE_NORMAL) - - field%val = val - - end subroutine set_tensor_field_arr - - subroutine set_tensor_field_arr_dim(field, dim1, dim2, val) - !!< Set the tensor field at all nodes at once - !!< Does not work for constant fields - type(tensor_field), intent(inout) :: field - real, dimension(:), intent(in) :: val - integer, intent(in):: dim1, dim2 - - assert(field%field_type==FIELD_TYPE_NORMAL) - - field%val(dim1, dim2, :) = val - - end subroutine set_tensor_field_arr_dim - - subroutine set_from_python_function_scalar(field, func, position, time) - !!< Set the values at the nodes of field using the python function - !!< specified in the string func. The position field is used to - !!< determine the locations of the nodes. - type(scalar_field), intent(inout) :: field - !! Func may contain any python at all but the following function must - !! be defined: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - type(vector_field), intent(in), target :: position - real, intent(in) :: time - - type(vector_field) :: lposition - real, dimension(:), pointer :: x, y, z - real, dimension(0), target :: zero - integer :: stat, dim - - dim=position%dim - - x=>zero - y=>zero - z=>zero - if (field%mesh==position%mesh) then - x=>position%val(1,:) - - if (dim>1) then - y=>position%val(2,:) - - if (dim>2) then - z=>position%val(3,:) - end if - end if - else - ! Remap position first. - lposition = get_remapped_coordinates(position, field%mesh) - ! we've just allowed remapping from a higher order to a lower order continuous field as this should be valid for - ! coordinates - ! also allowed to remap from unperiodic to periodic... hopefully the python function used will also be periodic! - - x=>lposition%val(1,:) - - if (dim>1) then - y=>lposition%val(2,:) - - if (dim>2) then - z=>lposition%val(3,:) - end if - end if - end if - - call set_scalar_field_from_python(func, len(func), dim,& - & node_count(field), x, y, z, time, field%val, stat) - - if (stat/=0) then - ewrite(-1, *) "Python error while setting field: "//trim(field%name) - ewrite(-1, *) "Python string was:" - ewrite(-1, *) trim(func) - FLExit("Dying") - end if - - if (has_references(lposition)) then - call deallocate(lposition) - end if - - end subroutine set_from_python_function_scalar - - subroutine set_from_python_function_vector(field, func, position, time) - !!< Set the values at the nodes of field using the python function - !!< specified in the string func. The position field is used to - !!< determine the locations of the nodes. - type(vector_field), intent(inout) :: field - !! Func may contain any python at all but the following function must - !! be defiled: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - type(vector_field), intent(in), target :: position - real, intent(in) :: time - - type(vector_field) :: lposition - real, dimension(:), pointer :: x, y, z, fx, fy, fz - real, dimension(0), target :: zero - integer :: stat, dim - - dim=position%dim - - if (mesh_dim(field)/=mesh_dim(position)) then - ewrite(0,'(a,i0)') "Vector field "//trim(field%name)//" has mesh dimension ",mesh_dim(field) - ewrite(0,'(a,i0)') "Position field "//trim(position%name)//" has mesh dimension ",mesh_dim(position) - FLExit("This is inconsistent") - end if - - x=>zero - y=>zero - z=>zero - if (field%mesh==position%mesh) then - x=>position%val(1,:) - - if (dim>1) then - y=>position%val(2,:) - - if (dim>2) then - z=>position%val(3,:) - end if - end if - else - ! Remap position first. - lposition = get_remapped_coordinates(position, field%mesh) - ! we've just allowed remapping from a higher order to a lower order continuous field as this should be valid for - ! coordinates - ! also allowed to remap from unperiodic to periodic... hopefully the python function used will also be periodic! - - x=>lposition%val(1,:) - - if (dim>1) then - y=>lposition%val(2,:) - - if (dim>2) then - z=>lposition%val(3,:) - end if - end if - end if - - fx=>zero - fy=>zero - fz=>zero - - fx=>field%val(1,:) - if (field%dim>1) then - fy=>field%val(2,:) - - if (field%dim>2) then - fz=>field%val(3,:) - end if - end if - - - call set_vector_field_from_python(func, len_trim(func), dim,& - & node_count(field), x, y, z, time, field%dim, & - & fx, fy, fz, stat) - - if (stat/=0) then - ewrite(-1, *) "Python error while setting field: "//trim(field%name) - ewrite(-1, *) "Python string was:" - ewrite(-1, *) trim(func) - FLExit("Dying") - end if - - if (has_references(lposition)) then - call deallocate(lposition) - end if - - end subroutine set_from_python_function_vector - - subroutine set_from_python_function_tensor(field, func, position, time) - !!< Set the values at the nodes of field using the python function - !!< specified in the string func. The position field is used to - !!< determine the locations of the nodes. - type(tensor_field), intent(inout) :: field - !! Func may contain any python at all but the following function must - !! be defined: - !! def val(X, t) - !! where X is a tuple containing the position of a point and t is the - !! time. The result must be a float. - character(len=*), intent(in) :: func - type(vector_field), intent(in), target :: position - real, intent(in) :: time - - type(vector_field) :: lposition - real, dimension(:), pointer :: x, y, z - real, dimension(0), target :: zero - integer :: stat, dim - - dim=position%dim - - x=>zero - y=>zero - z=>zero - if (field%mesh==position%mesh) then - x=>position%val(1,:) - - if (dim>1) then - y=>position%val(2,:) - - if (dim>2) then - z=>position%val(3,:) - end if - end if - else - ! Remap position first. - lposition = get_remapped_coordinates(position, field%mesh) - ! we've just allowed remapping from a higher order to a lower order continuous field as this should be valid for - ! coordinates - ! also allowed to remap from unperiodic to periodic... hopefully the python function used will also be periodic! - - x=>lposition%val(1,:) - - if (dim>1) then - y=>lposition%val(2,:) - - if (dim>2) then - z=>lposition%val(3,:) - end if - end if - end if - - call set_tensor_field_from_python(func, len(func), dim,& - & node_count(field), x, y, z, time, field%dim, & - field%val, stat) - - if (stat/=0) then - ewrite(-1, *) "Python error while setting field: "//trim(field%name) - ewrite(-1, *) "Python string was:" - ewrite(-1, *) trim(func) - FLExit("Dying") - end if - - if (has_references(lposition)) then - call deallocate(lposition) - end if - - end subroutine set_from_python_function_tensor - - subroutine set_from_function_scalar(field, func, position) - !!< Set the values in field using func applied to the position field. - !!< Func should be a function which takes a real position vector and - !!< returns a scalar real value. - type(scalar_field), intent(inout) :: field - type(vector_field), intent(in) :: position - interface - function func(X) - real :: func - real, dimension(:), intent(in) :: X - end function func - end interface - - type(vector_field) :: lpos - integer :: i - - if (field%field_type /= FIELD_TYPE_NORMAL) then - FLAbort("You can only set a normal field from a function!") - end if - - call allocate(lpos, position%dim, field%mesh, "Local Position") - - call remap_field(position, lpos) - - do i=1,node_count(field) - field%val(i)=func(node_val(lpos, i)) - end do - - call deallocate(lpos) - - end subroutine set_from_function_scalar - - subroutine set_from_function_vector(field, func, position) - !!< Set the values in field using func applied to the position field. - !!< Func should be a function which takes a real position vector and - !!< returns a vector real value of the same dimension as the position - !!< field. - type(vector_field), intent(inout) :: field - type(vector_field), intent(in) :: position - interface - function func(X) - real, dimension(:), intent(in) :: X - real, dimension(size(X)) :: func - end function func - end interface - - type(vector_field) :: lpos - integer :: i + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lfield2, field1%mesh) + call remap_field(field2, lfield2) + else + lfield2=field2 + end if - if (field%field_type /= FIELD_TYPE_NORMAL) then - FLAbort("You can only set a normal field from a function!") - end if - - call allocate(lpos, position%dim, field%mesh, "Local Position") - - call remap_field(position, lpos) - - call zero(field) - - do i=1,node_count(field) - call addto(field, i, func(node_val(lpos, i))) - end do - - call deallocate(lpos) - - end subroutine set_from_function_vector - - subroutine set_from_function_tensor(field, func, position) - !!< Set the values in field using func applied to the position field. - !!< Func should be a function which takes a real position vector and - !!< returns a tensor real value of the same dimension as the position - !!< field. - type(tensor_field), intent(inout) :: field - type(vector_field), intent(in) :: position - interface - function func(X) - real, dimension(:), intent(in) :: X - real, dimension(size(X), size(X)) :: func - end function func - end interface - - type(vector_field) :: lpos - integer :: i - - if (field%field_type /= FIELD_TYPE_NORMAL) then - FLAbort("You can only set a normal field from a function!") - end if - - call allocate(lpos, position%dim, field%mesh, "Local Position") - - call remap_field(position, lpos) + if (field1%field_type==field2%field_type) then + if (present(scale)) then + field1%val(dim,:)=field1%val(dim,:)+scale*lfield2%val + else + field1%val(dim,:)=field1%val(dim,:)+lfield2%val + end if + else if (field1%field_type==FIELD_TYPE_NORMAL) then + + assert(field2%field_type==FIELD_TYPE_CONSTANT) + if (present(scale)) then + field1%val(dim,:)=field1%val(dim,:)+scale*field2%val(1) + else + field1%val(dim,:)=field1%val(dim,:)+field2%val(1) + end if + else - call zero(field) + FLAbort("Illegal addition for given field types.") - do i=1,node_count(field) - call addto(field, i, func(node_val(lpos, i))) - end do + end if - call deallocate(lpos) + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call deallocate(lfield2) + end if - end subroutine set_from_function_tensor - - ! ------------------------------------------------------------------------ - ! Mapping of fields between different meshes - ! ------------------------------------------------------------------------ + end subroutine vector_field_addto_field_dim - subroutine test_remap_validity_scalar(from_field, to_field, stat) - type(scalar_field), intent(in):: from_field, to_field - integer, intent(out), optional:: stat + subroutine tensor_field_addto_field_dim_dim(field1, dim1, dim2, field2, scale) + !!< Compute field1(dim1,dim2)=field1(dim1,dim2)+scale*field2. + !!< Works for constant and space varying fields. + type(tensor_field), intent(inout) :: field1 + integer, intent(in) :: dim1, dim2 + type(scalar_field), intent(in) :: field2 + real, intent(in), optional :: scale - if(present(stat)) stat = 0 + type(scalar_field) lfield2 - call test_remap_validity_generic(trim(from_field%name), trim(to_field%name), & - continuity(from_field), continuity(to_field), & - element_degree(from_field, 1), element_degree(to_field, 1), & - mesh_periodic(from_field), mesh_periodic(to_field), & - from_field%mesh%shape%numbering%type, to_field%mesh%shape%numbering%type, & - stat) + assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) + ! only allow addition to non-constant field1 or + ! addition of constant field1 and constant field2 + assert(field1%field_type==FIELD_TYPE_NORMAL .or. field2%field_type==FIELD_TYPE_CONSTANT) - end subroutine test_remap_validity_scalar + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lfield2, field1%mesh) + call remap_field(field2, lfield2) + else + lfield2=field2 + end if - subroutine test_remap_validity_vector(from_field, to_field, stat) - type(vector_field), intent(in):: from_field, to_field - integer, intent(out), optional:: stat + if (field1%field_type==field2%field_type) then + if (present(scale)) then + field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+scale*lfield2%val + else + field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+lfield2%val + end if + else if (field1%field_type==FIELD_TYPE_NORMAL) then + + assert(field2%field_type==FIELD_TYPE_CONSTANT) + if (present(scale)) then + field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+scale*field2%val(1) + else + field1%val(dim1,dim2,:)=field1%val(dim1,dim2,:)+field2%val(1) + end if + else - if(present(stat)) stat = 0 + FLAbort("Illegal addition for given field types.") - call test_remap_validity_generic(trim(from_field%name), trim(to_field%name), & - continuity(from_field), continuity(to_field), & - element_degree(from_field, 1), element_degree(to_field, 1), & - mesh_periodic(from_field), mesh_periodic(to_field), & - from_field%mesh%shape%numbering%type, to_field%mesh%shape%numbering%type, & - stat) - - end subroutine test_remap_validity_vector + end if - subroutine test_remap_validity_tensor(from_field, to_field, stat) - type(tensor_field), intent(in):: from_field, to_field - integer, intent(out), optional:: stat + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call deallocate(lfield2) + end if - if(present(stat)) stat = 0 + end subroutine tensor_field_addto_field_dim_dim - call test_remap_validity_generic(trim(from_field%name), trim(to_field%name), & - continuity(from_field), continuity(to_field), & - element_degree(from_field, 1), element_degree(to_field, 1), & - mesh_periodic(from_field), mesh_periodic(to_field), & - from_field%mesh%shape%numbering%type, to_field%mesh%shape%numbering%type, & - stat) + subroutine tensor_field_addto_tensor_field(field1, field2, scale) + !!< Compute field1(dim1,dim2)=field1(dim1,dim2)+scale*field2. + !!< Works for constant and space varying fields. + type(tensor_field), intent(inout) :: field1 + type(tensor_field), intent(in) :: field2 + real, intent(in), optional :: scale + integer :: i - end subroutine test_remap_validity_tensor + type(tensor_field) lfield2 - subroutine test_remap_validity_generic(from_name, to_name, & - from_continuity, to_continuity, & - from_degree, to_degree, & - from_periodic, to_periodic, & - from_type, to_type, & - stat) - character(len=*), intent(in):: from_name, to_name - integer, intent(in):: from_continuity, to_continuity - integer, intent(in):: from_degree, to_degree - logical, intent(in):: from_periodic, to_periodic - integer, intent(in):: from_type, to_type - integer, intent(out), optional:: stat + assert(field1%field_type/=FIELD_TYPE_PYTHON .and. field2%field_type/=FIELD_TYPE_PYTHON) + ! only allow addition to non-constant field1 or + ! addition of constant field1 and constant field2 + assert(field1%field_type==FIELD_TYPE_NORMAL .or. field2%field_type==FIELD_TYPE_CONSTANT) - if(present(stat)) stat = 0 - - if((from_continuity<0).and.(.not.(to_continuity<0))) then - if(present(stat)) then - stat = REMAP_ERR_DISCONTINUOUS_CONTINUOUS + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call allocate(lfield2, field1%mesh) + call remap_field(field2, lfield2) else - ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." - FLAbort("Trying to remap from discontinuous to continuous field.") + lfield2=field2 end if - end if - ! this test currently assumes that the shape function degree is constant over the mesh - if((.not.(from_continuity<0)).and.(.not.(to_continuity<0))& - .and.(from_degree>to_degree)) then - if(present(stat)) then - stat = REMAP_ERR_HIGHER_LOWER_CONTINUOUS + if (field1%field_type==field2%field_type) then + if (present(scale)) then + field1%val(:,:,:)=field1%val(:, :,:) +scale*lfield2%val(:, :, :) + else + field1%val=field1%val+lfield2%val + end if + else if (field1%field_type==FIELD_TYPE_NORMAL) then + + assert(field2%field_type==FIELD_TYPE_CONSTANT) + if (present(scale)) then + forall(i=1:size(field1%val, 3)) + field1%val(:, :, i)=field1%val(:, :, i)+scale*field2%val(:, :, 1) + end forall + else + forall(i=1:size(field1%val, 3)) + field1%val(:, :, i)=field1%val(:, :, i)+field2%val(:, :, 1) + end forall + end if else - ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." - FLAbort("Trying to remap from higher order to lower order continuous field") - end if - end if - if((.not.(from_continuity<0)).and.(.not.(to_continuity<0))& - .and.(.not.from_periodic).and.(to_periodic)) then - if(present(stat)) then - stat = REMAP_ERR_UNPERIODIC_PERIODIC - else - ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." - FLAbort("Trying to remap from an unperiodic to a periodic continuous field") - end if - end if + FLAbort("Illegal addition for given field types.") - if((from_type==ELEMENT_BUBBLE).and.& - (to_type==ELEMENT_LAGRANGIAN)) then - if(present(stat)) then - stat = REMAP_ERR_BUBBLE_LAGRANGE - else - ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." - FLAbort("Trying to remap from a bubble to a lagrange field") end if - end if - end subroutine test_remap_validity_generic - - subroutine remap_scalar_field(from_field, to_field, stat) - !!< Remap the components of from_field onto the locations of to_field. - !!< This is used to change the element type of a field. - !!< - !!< This will not validly map a discontinuous field to a continuous - !!< field. - type(scalar_field), intent(in) :: from_field - type(scalar_field), intent(inout) :: to_field - integer, intent(out), optional :: stat - - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: locweight - - integer :: toloc, ele - integer, dimension(:), pointer :: from_ele, to_ele + if (.not. field1%mesh==field2%mesh .and. .not. field2%field_type==FIELD_TYPE_CONSTANT) then + call deallocate(lfield2) + end if - if(present(stat)) stat = 0 + end subroutine tensor_field_addto_tensor_field - if(from_field%mesh==to_field%mesh) then + subroutine real_addto_real(arr, idx, val) + ! Real recognize real, dunn. Fo' life. - call set(to_field, from_field) + real, dimension(:), intent(inout) :: arr + integer, dimension(:), intent(in) :: idx + real, dimension(size(idx)), intent(in) :: val - else + arr(idx) = arr(idx) + val + end subroutine real_addto_real - select case(from_field%field_type) - case(FIELD_TYPE_NORMAL) + subroutine set_scalar_field_field(out_field, in_field) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(scalar_field), intent(inout) :: out_field + type(scalar_field), intent(in) :: in_field - call test_remap_validity(from_field, to_field, stat=stat) + assert(mesh_compatible(out_field%mesh, in_field%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) + assert(out_field%field_type==FIELD_TYPE_NORMAL .or. in_field%field_type==FIELD_TYPE_CONSTANT) - ! First construct remapping weights. - do toloc=1,size(locweight,1) - locweight(toloc,:)=eval_shape(from_field%mesh%shape, & - local_coords(toloc, to_field%mesh%shape)) - end do + select case (in_field%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val=in_field%val + case (FIELD_TYPE_CONSTANT) + out_field%val=in_field%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - ! Now loop over the elements. - do ele=1,element_count(from_field) - from_ele=>ele_nodes(from_field, ele) - to_ele=>ele_nodes(to_field, ele) + end subroutine set_scalar_field_field - to_field%val(to_ele)=matmul(locweight,from_field%val(from_ele)) + subroutine set_scalar_field_from_vector_field(out_field, in_field, dim) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(scalar_field), intent(inout) :: out_field + type(vector_field), intent(in) :: in_field + integer, intent(in) :: dim - end do + assert(mesh_compatible(out_field%mesh, in_field%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) + assert(out_field%field_type==FIELD_TYPE_NORMAL .or. in_field%field_type==FIELD_TYPE_CONSTANT) + assert(dim>=1 .and. dim<=in_field%dim) - case(FIELD_TYPE_CONSTANT) - to_field%val = from_field%val(1) + select case (in_field%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val=in_field%val(dim,:) + case (FIELD_TYPE_CONSTANT) + out_field%val=in_field%val(dim,1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") end select - end if + end subroutine set_scalar_field_from_vector_field - end subroutine remap_scalar_field + subroutine set_scalar_field_node(field, node_number, val) + !!< Set the scalar field at the specified node + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + integer, intent(in) :: node_number + real, intent(in) :: val - subroutine remap_scalar_field_specific(from_field, to_field, elements, output, locweight, stat) - !!< Remap the components of from_field onto the locations of to_field. - !!< This is used to change the element type of a field. - !!< - !!< This will not validly map a discontinuous field to a continuous - !!< field. - !!< This only does certain elements, and can optionally take in a precomputed locweight. + assert(field%field_type==FIELD_TYPE_NORMAL) - type(scalar_field), intent(in) :: from_field - type(scalar_field), intent(inout) :: to_field - integer, dimension(:), intent(in) :: elements - real, dimension(size(elements), to_field%mesh%shape%loc), intent(out) :: output - integer, intent(out), optional:: stat + field%val(node_number) = val - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc), optional :: locweight - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: llocweight + end subroutine set_scalar_field_node - integer :: toloc, ele, i + subroutine set_scalar_field_nodes(field, node_numbers, val) + !!< Set the scalar field at the specified node_numbers + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, dimension(:), intent(in) :: val - if(present(stat)) stat = 0 + assert(field%field_type==FIELD_TYPE_NORMAL) + assert(size(node_numbers)==size(val)) - if (from_field%field_type == FIELD_TYPE_CONSTANT) then - output = from_field%val(1) - return - end if + field%val(node_numbers) = val - call test_remap_validity(from_field, to_field, stat=stat) + end subroutine set_scalar_field_nodes - if (.not. present(locweight)) then - ! First construct remapping weights. - do toloc=1,size(llocweight,1) - llocweight(toloc,:)=eval_shape(from_field%mesh%shape, & - local_coords(toloc, to_field%mesh%shape)) - end do - else - llocweight = locweight - end if - - ! Now loop over the elements. - do i=1,size(elements) - ele = elements(i) - output(i, :)=matmul(llocweight,ele_val(from_field, ele)) - end do - end subroutine remap_scalar_field_specific - - subroutine remap_vector_field(from_field, to_field, stat) - !!< Remap the components of from_field onto the locations of to_field. - !!< This is used to change the element type of a field. - !!< - !!< The result will only be valid if to_field is DG. - type(vector_field), intent(in) :: from_field - type(vector_field), intent(inout) :: to_field - integer, intent(out), optional :: stat - - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: locweight - - integer :: toloc, ele, i - integer, dimension(:), pointer :: from_ele, to_ele - - if(present(stat)) stat = 0 - - assert(to_field%dim>=from_field%dim) - - if (mesh_dim(from_field)/=mesh_dim(to_field)) then - ewrite (0,*)"Remapping "//trim(from_field%name)//" to "& - &//trim(to_field%name) - ewrite (0,'(a,i0)')"Mesh dimension of "//trim(from_field%name)//& - " is ", mesh_dim(from_field) - ewrite (0,'(a,i0)')"Mesh dimension of "//trim(to_field%name)//& - " is ", mesh_dim(to_field) - FLExit("Mesh dimensions inconsistent") - end if + subroutine set_scalar_field_constant_nodes(field, node_numbers, val) + !!< Set the scalar field at the specified node_numbers + !!< to a constant value + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, intent(in) :: val - if(from_field%mesh==to_field%mesh) then + assert(field%field_type==FIELD_TYPE_NORMAL) - call set(to_field, from_field) + field%val(node_numbers) = val - else + end subroutine set_scalar_field_constant_nodes - select case(from_field%field_type) - case(FIELD_TYPE_NORMAL) - - call test_remap_validity(from_field, to_field, stat=stat) - - ! First construct remapping weights. - do toloc=1,size(locweight,1) - locweight(toloc,:)=eval_shape(from_field%mesh%shape, & - local_coords(toloc, to_field%mesh%shape)) - end do - - ! Now loop over the elements. - do ele=1,element_count(from_field) - from_ele=>ele_nodes(from_field, ele) - to_ele=>ele_nodes(to_field, ele) - - do i=1,from_field%dim - to_field%val(i,to_ele)= & - matmul(locweight,from_field%val(i,from_ele)) - end do - - end do - - case(FIELD_TYPE_CONSTANT) - do i=1,from_field%dim - to_field%val(i,:) = from_field%val(i,1) - end do - case default - FLAbort("Wrong field_type for remap_field") - end select + subroutine set_scalar_field(field, val) + !!< Set the scalar field with a constant value + !!< Works for constant and space varying fields. + type(scalar_field), intent(inout) :: field + real, intent(in) :: val - end if + assert(field%field_type/=FIELD_TYPE_PYTHON) - ! Zero any left-over dimensions - do i=from_field%dim+1,to_field%dim - to_field%val(i,:)=0.0 - end do + field%val = val - end subroutine remap_vector_field + end subroutine set_scalar_field - subroutine remap_vector_field_specific(from_field, to_field, elements, output, locweight, stat) - !!< Remap the components of from_field onto the locations of to_field. - !!< This is used to change the element type of a field. - !!< - !!< The result will only be valid if to_field is DG. - type(vector_field), intent(in) :: from_field - type(vector_field), intent(inout) :: to_field - integer, dimension(:), intent(in) :: elements - real, dimension(size(elements), to_field%dim, to_field%mesh%shape%loc), intent(out) :: output - integer, intent(out), optional:: stat + subroutine set_scalar_field_arr(field, val) + !!< Set the scalar field at all nodes at once + !!< Does not work for constant fields + type(scalar_field), intent(inout) :: field + real, dimension(:), intent(in) :: val - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc), optional :: locweight - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: llocweight + assert(field%field_type==FIELD_TYPE_NORMAL) - integer :: toloc, ele, i, j + field%val = val - if(present(stat)) stat = 0 + end subroutine set_scalar_field_arr - assert(to_field%dim>=from_field%dim) + subroutine set_vector_field_node(field, node, val) + !!< Set the vector field at the specified node + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, intent(in) :: node + real, intent(in), dimension(:) :: val + integer :: i - output = 0.0 + assert(field%field_type==FIELD_TYPE_NORMAL) - select case(from_field%field_type) - case(FIELD_TYPE_CONSTANT) - do i=1,from_field%dim - output(:, i, :) = from_field%val(i,1) - end do - return - case default - FLAbort("Wrong field_type for remap_field") - end select - - call test_remap_validity(from_field, to_field, stat=stat) - - if (.not. present(locweight)) then - ! First construct remapping weights. - do toloc=1,size(llocweight,1) - llocweight(toloc,:)=eval_shape(from_field%mesh%shape, & - local_coords(toloc, to_field%mesh%shape)) - end do - else - llocweight = locweight - end if - - ! Now loop over the elements. - do j=1,size(elements) - ele = elements(j) - do i=1,from_field%dim - output(j, i, :) = matmul(llocweight,ele_val(from_field, i, ele)) + do i=1,field%dim + field%val(i,node) = val(i) end do - end do - end subroutine remap_vector_field_specific - subroutine remap_tensor_field(from_field, to_field, stat) - !!< Remap the components of from_field onto the locations of to_field. - !!< This is used to change the element type of a field. - !!< - !!< The result will only be valid if to_field is DG. - type(tensor_field), intent(in) :: from_field - type(tensor_field), intent(inout) :: to_field - integer, intent(inout), optional :: stat + end subroutine set_vector_field_node - real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: locweight + subroutine set_scalar_field_theta(out_field, in_field_new, in_field_old, theta) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(scalar_field), intent(inout) :: out_field + type(scalar_field), intent(in) :: in_field_new, in_field_old + real, intent(in) :: theta + + assert(mesh_compatible(out_field%mesh, in_field_new%mesh)) + assert(mesh_compatible(out_field%mesh, in_field_old%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) +#ifndef NDEBUG + if(.not.(out_field%field_type==FIELD_TYPE_NORMAL .or. & + (in_field_new%field_type==FIELD_TYPE_CONSTANT .and. & + in_field_old%field_type==FIELD_TYPE_CONSTANT))) then + ewrite(-1,*) "Incompatible field types in set()" + FLAbort("evilness unleashed") + end if +#endif - integer :: toloc, ele, i, j - integer, dimension(:), pointer :: from_ele, to_ele + select case (in_field_new%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val=theta*in_field_new%val + (1.-theta)*in_field_old%val + case (FIELD_TYPE_CONSTANT) + out_field%val=theta*in_field_new%val(1) + (1.-theta)*in_field_old%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - if(present(stat)) stat = 0 + end subroutine set_scalar_field_theta - assert(all(to_field%dim>=from_field%dim)) + subroutine set_vector_field_node_dim(field, dim, node, val) + !!< Set the vector field at the specified node + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, intent(in) :: node + real, intent(in) :: val + integer, intent(in):: dim - if(from_field%mesh==to_field%mesh) then + assert(field%field_type==FIELD_TYPE_NORMAL) + assert(dim>=1 .and. dim<=field%dim) - call set(to_field, from_field) + field%val(dim,node) = val - else + end subroutine set_vector_field_node_dim - select case(from_field%field_type) - case(FIELD_TYPE_NORMAL) + subroutine set_vector_field_nodes(field, node_numbers, val) + !!< Set the vector field at the specified nodes + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + !! values to set ( dimension x #nodes) + real, intent(in), dimension(:,:) :: val + integer :: i - call test_remap_validity(from_field, to_field, stat=stat) + assert(field%field_type==FIELD_TYPE_NORMAL) - ! First construct remapping weights. - do toloc=1,size(locweight,1) - locweight(toloc,:)=eval_shape(from_field%mesh%shape, & - local_coords(toloc, to_field%mesh%shape)) - end do + do i=1,field%dim + field%val(i,node_numbers) = val(i, :) + end do - ! Now loop over the elements. - do ele=1,element_count(from_field) - from_ele=>ele_nodes(from_field, ele) - to_ele=>ele_nodes(to_field, ele) + end subroutine set_vector_field_nodes - do i=1,from_field%dim(1) - do j=1,from_field%dim(2) - to_field%val(i, j, to_ele) = matmul(locweight, from_field%val(i, j, from_ele)) - end do - end do + subroutine set_vector_field_nodes_dim(field, dim, node_numbers, val) + !!< Set the vector field at the specified nodes + !!< Does not work for constant fields + type(vector_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + !! values to set + real, intent(in), dimension(:) :: val + integer, intent(in) :: dim - end do - case(FIELD_TYPE_CONSTANT) - do i=1,size(to_field%val, 3) - to_field%val(:, :, i) = from_field%val(:, :, 1) - end do - end select + assert(field%field_type==FIELD_TYPE_NORMAL) + assert(dim>=1 .and. dim<=field%dim) - end if + field%val(dim,node_numbers) = val - end subroutine remap_tensor_field + end subroutine set_vector_field_nodes_dim - subroutine remap_scalar_field_to_surface(from_field, to_field, surface_element_list, stat) - !!< Remap the values of from_field onto the surface_field to_field, which is defined - !!< on the faces given by surface_element_list. - !!< This also deals with remapping between different orders. - type(scalar_field), intent(in):: from_field - type(scalar_field), intent(inout):: to_field - integer, dimension(:), intent(in):: surface_element_list - integer, intent(out), optional:: stat + subroutine set_vector_field(field, val) + !!< Set the vector field with a constant value + !!< Works for constant and space varying fields. + type(vector_field), intent(inout) :: field + real, intent(in), dimension(:) :: val + integer :: i - real, dimension(ele_loc(to_field,1), face_loc(from_field,1)) :: locweight - type(element_type), pointer:: from_shape, to_shape - real, dimension(face_loc(from_field,1)) :: from_val - integer, dimension(:), pointer :: to_nodes - integer toloc, ele, face + assert(field%field_type/=FIELD_TYPE_PYTHON) - if (present(stat)) stat = 0 + do i=1,field%dim + field%val(i,:) = val(i) + end do - select case(from_field%field_type) - case(FIELD_TYPE_NORMAL) + end subroutine set_vector_field - call test_remap_validity(from_field, to_field, stat=stat) + subroutine set_vector_field_dim(field, dim, val) + !!< Set the vector field with a constant value + !!< Works for constant and space varying fields. + type(vector_field), intent(inout) :: field + real, intent(in):: val + integer, intent(in):: dim - ! the remapping happens from a face of from_field which is at the same - ! time an element of to_field - from_shape => face_shape(from_field, 1) - to_shape => ele_shape(to_field, 1) - ! First construct remapping weights. - do toloc=1,size(locweight,1) - locweight(toloc,:)=eval_shape(from_shape, & - local_coords(toloc, to_shape)) - end do + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(dim>=1 .and. dim<=field%dim) - ! Now loop over the surface elements. - do ele=1, size(surface_element_list) - ! element ele is a face in the mesh of from_field: - face=surface_element_list(ele) + field%val(dim,:) = val - to_nodes => ele_nodes(to_field, ele) + end subroutine set_vector_field_dim - from_val = face_val(from_field, face) + subroutine set_vector_field_arr(field, val) + !!< Set the vector field with an array for all nodes at once + type(vector_field), intent(inout) :: field + real, intent(in), dimension(:, :) :: val + integer :: i - to_field%val(to_nodes)=matmul(locweight,from_val) + assert(field%field_type==FIELD_TYPE_NORMAL) + do i=1,field%dim + field%val(i,:) = val(i, :) end do - case(FIELD_TYPE_CONSTANT) + end subroutine set_vector_field_arr - to_field%val = from_field%val(1) + subroutine set_vector_field_arr_dim(field, dim, val) + !!< Set the vector field with an array for all nodes at once + type(vector_field), intent(inout) :: field + real, intent(in), dimension(:) :: val + integer, intent(in):: dim - end select + assert(field%field_type==FIELD_TYPE_NORMAL) + assert(dim>=1 .and. dim<=field%dim) - end subroutine remap_scalar_field_to_surface + field%val(dim,:) = val - subroutine remap_vector_field_to_surface(from_field, to_field, surface_element_list, stat) - !!< Remap the values of from_field onto the surface_field to_field, which is defined - !!< on the faces given by surface_element_list. - !!< This also deals with remapping between different orders. - type(vector_field), intent(in):: from_field - type(vector_field), intent(inout):: to_field - integer, dimension(:), intent(in):: surface_element_list - integer, intent(out), optional:: stat + end subroutine set_vector_field_arr_dim - real, dimension(ele_loc(to_field,1), face_loc(from_field,1)) :: locweight - type(element_type), pointer:: from_shape, to_shape - real, dimension(from_field%dim, face_loc(from_field,1)) :: from_val - integer, dimension(:), pointer :: to_nodes - integer toloc, ele, face, i + subroutine set_vector_field_field(out_field, in_field ) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(vector_field), intent(inout) :: out_field + type(vector_field), intent(in) :: in_field - if(present(stat)) stat = 0 + integer :: dim - assert(to_field%dim>=from_field%dim) - - select case(from_field%field_type) - case(FIELD_TYPE_NORMAL) +#ifndef NDEBUG + assert(mesh_compatible(out_field%mesh, in_field%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) + if (.not. (out_field%field_type==FIELD_TYPE_NORMAL .or. & + (out_field%field_type==FIELD_TYPE_CONSTANT .and. in_field%field_type==FIELD_TYPE_CONSTANT))) then + FLAbort("Wrong field_type in set()") + end if + assert(in_field%dim==out_field%dim) +#endif - call test_remap_validity(from_field, to_field, stat=stat) + select case (in_field%field_type) + case (FIELD_TYPE_NORMAL) + do dim=1,in_field%dim + out_field%val(dim,:)=in_field%val(dim,:) + end do + case (FIELD_TYPE_CONSTANT) + do dim=1,in_field%dim + out_field%val(dim,:)=in_field%val(dim,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - ! the remapping happens from a face of from_field which is at the same - ! time an element of to_field - from_shape => face_shape(from_field, 1) - to_shape => ele_shape(to_field, 1) - ! First construct remapping weights. - do toloc=1,size(locweight,1) - locweight(toloc,:)=eval_shape(from_shape, & - local_coords(toloc, to_shape)) - end do + end subroutine set_vector_field_field - ! Now loop over the surface elements. - do ele=1, size(surface_element_list) - ! element ele is a face in the mesh of from_field: - face=surface_element_list(ele) + subroutine set_vector_field_theta(out_field, in_field_new, in_field_old, theta) + !!< Set theta*in_field_new + (1.-theta)*in_field_old to out_field. This will only work if the fields have + !!< the same mesh. + type(vector_field), intent(inout) :: out_field + type(vector_field), intent(in) :: in_field_new, in_field_old + real, intent(in) :: theta - to_nodes => ele_nodes(to_field, ele) + integer :: dim - from_val = face_val(from_field, face) + assert(mesh_compatible(out_field%mesh, in_field_new%mesh)) + assert(mesh_compatible(out_field%mesh, in_field_old%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) +#ifndef NDEBUG + if(.not.(out_field%field_type==FIELD_TYPE_NORMAL .or. & + (in_field_new%field_type==FIELD_TYPE_CONSTANT .and. & + in_field_old%field_type==FIELD_TYPE_CONSTANT))) then + ewrite(-1,*) "Incompatible field types in set()" + FLAbort("Evilness"); + end if +#endif + assert(in_field_new%dim==out_field%dim) + assert(in_field_old%dim==out_field%dim) - do i=1, to_field%dim - to_field%val(i,to_nodes)=matmul(locweight,from_val(i, :)) + select case (in_field_new%field_type) + case (FIELD_TYPE_NORMAL) + do dim = 1, out_field%dim + out_field%val(dim,:)=theta*in_field_new%val(dim,:) + (1.-theta)*in_field_old%val(dim,:) end do + case (FIELD_TYPE_CONSTANT) + do dim = 1, out_field%dim + out_field%val(dim,:)=theta*in_field_new%val(dim,1) + (1.-theta)*in_field_old%val(dim,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - end do + end subroutine set_vector_field_theta - case(FIELD_TYPE_CONSTANT) - do i=1, from_field%dim - to_field%val(i,:) = from_field%val(i,1) - end do - case default - FLAbort("Unknown field type in remap_field_to_surface") - end select + subroutine set_vector_field_field_dim(out_field, dim, in_field) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(vector_field), intent(inout) :: out_field + type(scalar_field), intent(in) :: in_field + integer, intent(in):: dim - ! Zero any left-over dimensions - do ele=from_field%dim+1, to_field%dim - to_field%val(i,:)=0.0 - end do +#ifndef NDEBUG + assert(mesh_compatible(out_field%mesh, in_field%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) + if (.not. (out_field%field_type==FIELD_TYPE_NORMAL .or. & + (out_field%field_type==FIELD_TYPE_CONSTANT .and. in_field%field_type==FIELD_TYPE_CONSTANT))) then + FLAbort("Wrong field_type in set()") + end if + assert(dim>=1 .and. dim<=out_field%dim) +#endif - end subroutine remap_vector_field_to_surface + select case (in_field%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val(dim,:)=in_field%val + case (FIELD_TYPE_CONSTANT) + out_field%val(dim,:)=in_field%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - subroutine remap_tensor_field_to_surface(from_field, to_field, surface_element_list, stat) - !!< Remap the values of from_field onto the surface_field to_field, which is defined - !!< on the faces given by surface_element_list. - !!< This also deals with remapping between different orders. - type(tensor_field), intent(in):: from_field - type(tensor_field), intent(inout):: to_field - integer, dimension(:), intent(in):: surface_element_list - integer, intent(out), optional:: stat + end subroutine set_vector_field_field_dim - real, dimension(ele_loc(to_field,1), face_loc(from_field,1)) :: locweight - type(element_type), pointer:: from_shape, to_shape - real, dimension(from_field%dim(1), from_field%dim(2), face_loc(from_field,1)) :: from_val - integer, dimension(:), pointer :: to_nodes - integer toloc, ele, face, i, j + subroutine set_vector_field_vfield_dim(out_field, dim, in_field) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(vector_field), intent(inout) :: out_field + type(vector_field), intent(in) :: in_field + integer, intent(in):: dim - if(present(stat)) stat = 0 +#ifndef NDEBUG + assert(mesh_compatible(out_field%mesh, in_field%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) + if (.not. (out_field%field_type==FIELD_TYPE_NORMAL .or. & + (out_field%field_type==FIELD_TYPE_CONSTANT .and. in_field%field_type==FIELD_TYPE_CONSTANT))) then + FLAbort("Wrong field_type in set()") + end if + assert(dim>=1 .and. dim<=out_field%dim .and. dim<=in_field%dim) +#endif - assert(to_field%dim(1)>=from_field%dim(1)) - assert(to_field%dim(2)>=from_field%dim(2)) + select case (in_field%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val(dim,:)=in_field%val(dim,:) + case (FIELD_TYPE_CONSTANT) + out_field%val(dim,:)=in_field%val(dim,1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - select case(from_field%field_type) - case(FIELD_TYPE_NORMAL) + end subroutine set_vector_field_vfield_dim - call test_remap_validity(from_field, to_field, stat=stat) + subroutine set_tensor_field_field(out_field, in_field ) + !!< Set in_field to out_field. This will only work if the fields have + !!< the same mesh. + type(tensor_field), intent(inout) :: out_field + type(Tensor_field), intent(in) :: in_field - ! the remapping happens from a face of from_field which is at the same - ! time an element of to_field - from_shape => face_shape(from_field, 1) - to_shape => ele_shape(to_field, 1) - ! First construct remapping weights. - do toloc=1,size(locweight,1) - locweight(toloc,:)=eval_shape(from_shape, & - local_coords(toloc, to_shape)) - end do + integer i - ! Now loop over the surface elements. - do ele=1, size(surface_element_list) - ! element ele is a face in the mesh of from_field: - face=surface_element_list(ele) + assert(mesh_compatible(out_field%mesh, in_field%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) + assert(out_field%field_type==FIELD_TYPE_NORMAL.or.in_field%field_type==FIELD_TYPE_CONSTANT) + assert(all(in_field%dim==out_field%dim)) - to_nodes => ele_nodes(to_field, ele) + select case (in_field%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val=in_field%val + case (FIELD_TYPE_CONSTANT) + do i=1, size(out_field%val,3) + out_field%val(:,:,i)=in_field%val(:,:,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - from_val = face_val(from_field, face) + end subroutine set_tensor_field_field - do i=1, to_field%dim(1) - do j=1, to_field%dim(2) - to_field%val(i,j,to_nodes)=matmul(locweight,from_val(i,j,:)) - end do - end do + subroutine set_tensor_field_theta(out_field, in_field_new, in_field_old, theta) + !!< Set theta*in_field_new + (1.-theta)*in_field_old to out_field. This will only work if the fields have + !!< the same mesh. + type(tensor_field), intent(inout) :: out_field + type(tensor_field), intent(in) :: in_field_new, in_field_old + real, intent(in) :: theta - end do + integer i - case(FIELD_TYPE_CONSTANT) - do i=1, from_field%dim(1) - do j=1, from_field%dim(2) - to_field%val(i,j,:) = from_field%val(i,j,1) - end do - end do - end select - - ! Zero any left-over dimensions - do i=from_field%dim(1)+1, to_field%dim(1) - do j=1, to_field%dim(2) - to_field%val(i,j,:)=0.0 - end do - end do - do j=from_field%dim(2)+1, to_field%dim(2) - do i=1, to_field%dim(1) - to_field%val(i,j,:)=0.0 - end do - end do - - end subroutine remap_tensor_field_to_surface - - function piecewise_constant_mesh(in_mesh, name) result(new_mesh) - !!< From a given mesh, return a scalar field - !!< allocated on the mesh that's topologically the same - !!< but has piecewise constant basis functions. - !!< This is for the definition of elementwise quantities. - type(mesh_type), intent(in) :: in_mesh - type(mesh_type) :: new_mesh - type(element_type) :: shape, old_shape - character(len=*), intent(in) :: name - - old_shape = in_mesh%shape - - shape = make_element_shape(vertices=old_shape%numbering%vertices, dim=old_shape%dim, degree=0, quad=old_shape%quadrature) - new_mesh = make_mesh(model=in_mesh, shape=shape, continuity=-1) - new_mesh%name=name - call deallocate(shape) - - end function piecewise_constant_mesh - - function piecewise_constant_field(in_mesh, name) result(field) - !!< From a given mesh, return a scalar field - !!< allocated on the mesh that's topologically the same - !!< but has piecewise constant basis functions. - !!< This is for the definition of elementwise quantities. - type(mesh_type), intent(in) :: in_mesh - type(mesh_type) :: new_mesh - type(element_type) :: shape, old_shape - type(scalar_field) :: field - character(len=*), intent(in) :: name - - old_shape = in_mesh%shape - - shape = make_element_shape(vertices=old_shape%loc, dim=old_shape%dim, degree=0, quad=old_shape%quadrature) - new_mesh = make_mesh(model=in_mesh, shape=shape, continuity=-1) - call allocate(field, new_mesh, name) - call zero(field) - call deallocate(shape) - call deallocate(new_mesh) - - end function piecewise_constant_field - - subroutine scalar_scale(field, factor) - !!< Multiply scalar field with factor - type(scalar_field), intent(inout) :: field - real, intent(in) :: factor - - assert(field%field_type/=FIELD_TYPE_PYTHON) - - field%val = field%val * factor - - end subroutine scalar_scale - - subroutine vector_scale(field, factor, dim) - !!< Multiply vector field with factor - type(vector_field), intent(inout) :: field - real, intent(in) :: factor - integer, intent(in), optional :: dim - - integer :: i - - assert(field%field_type/=FIELD_TYPE_PYTHON) - - if (present(dim)) then - field%val(dim,:) = field%val(dim,:) * factor - else - do i=1,field%dim - field%val(i,:) = field%val(i,:) * factor - end do - end if - - end subroutine vector_scale - - subroutine tensor_scale(field, factor) - !!< Multiply tensor field with factor - type(tensor_field), intent(inout) :: field - real, intent(in) :: factor - - assert(field%field_type/=FIELD_TYPE_PYTHON) - - field%val = field%val * factor - - end subroutine tensor_scale - - subroutine scalar_scale_scalar_field(field, sfield) - !!< Multiply scalar field with sfield. This will only work if the - !!< fields have the same mesh. - !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points - !!< will not be as accurate as multiplying the fields at each gauss point seperately - !!< and then summing over these. - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: sfield - - assert(field%mesh%refcount%id==sfield%mesh%refcount%id) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) - - select case (sfield%field_type) - case (FIELD_TYPE_NORMAL) - field%val = field%val * sfield%val - case (FIELD_TYPE_CONSTANT) - field%val = field%val * sfield%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in scale()") - end select - - end subroutine scalar_scale_scalar_field - - subroutine vector_scale_scalar_field(field, sfield) - !!< Multiply vector field with scalar field. This will only work if the - !!< fields have the same mesh. - !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points - !!< will not be as accurate as multiplying the fields at each gauss point seperately - !!< and then summing over these. - type(vector_field), intent(inout) :: field - type(scalar_field), intent(in) :: sfield - - integer :: i - - assert(field%mesh%refcount%id==sfield%mesh%refcount%id) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) - - select case (sfield%field_type) - case (FIELD_TYPE_NORMAL) - do i=1,field%dim - field%val(i,:) = field%val(i,:) * sfield%val - end do - case (FIELD_TYPE_CONSTANT) - do i=1,field%dim - field%val(i,:) = field%val(i,:) * sfield%val(1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in scale()") - end select - - end subroutine vector_scale_scalar_field - - subroutine tensor_scale_scalar_field(field, sfield) - !!< Multiply tensor field with scalar field. This will only work if the - !!< fields have the same mesh. - !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points - !!< will not be as accurate as multiplying the fields at each gauss point seperately - !!< and then summing over these. - type(tensor_field), intent(inout) :: field - type(scalar_field), intent(in) :: sfield - - integer :: i, j - - assert(field%mesh%refcount%id==sfield%mesh%refcount%id) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) - - select case (sfield%field_type) - case (FIELD_TYPE_NORMAL) - do i=1,field%dim(1) - do j=1,field%dim(2) - field%val(i,j,:) = field%val(i,j,:) * sfield%val - end do - end do - case (FIELD_TYPE_CONSTANT) - field%val(:,:,:) = field%val(:,:,:) * sfield%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in scale()") - end select - - end subroutine tensor_scale_scalar_field - - subroutine vector_scale_vector_field(field, vfield) - !!< Multiply vector field with vector field. This will only work if the - !!< fields have the same mesh. - !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points - !!< will not be as accurate as multiplying the fields at each gauss point seperately - !!< and then summing over these. - type(vector_field), intent(inout) :: field - type(vector_field), intent(in) :: vfield - - integer :: i - - assert(field%mesh%refcount%id==vfield%mesh%refcount%id) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. vfield%field_type==FIELD_TYPE_CONSTANT) - - select case (vfield%field_type) - case (FIELD_TYPE_NORMAL) - do i=1,field%dim - field%val(i,:) = field%val(i,:) * vfield%val(i,:) - end do - case (FIELD_TYPE_CONSTANT) - do i=1,field%dim - field%val(i,:) = field%val(i,:) * vfield%val(i,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in scale()") - end select - - end subroutine vector_scale_vector_field - - subroutine tensor_scale_tensor_field(field, tfield) - !!< Multiply tensor field with tensor field. This will only work if the - !!< fields have the same mesh. - !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points - !!< will not be as accurate as multiplying the fields at each gauss point seperately - !!< and then summing over these. - type(tensor_field), intent(inout) :: field - type(tensor_field), intent(in) :: tfield - - integer :: i,j - - assert(field%mesh%refcount%id==tfield%mesh%refcount%id) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. tfield%field_type==FIELD_TYPE_CONSTANT) - - select case (tfield%field_type) - case (FIELD_TYPE_NORMAL) - do i=1,field%dim(1) - do j=1,field%dim(2) - field%val(i,j,:) = field%val(i,j,:) * tfield%val(i,j,:) - end do - end do - case (FIELD_TYPE_CONSTANT) - do i=1,field%dim(1) - do j=1,field%dim(2) - field%val(i,j,:) = field%val(i,j,:) * tfield%val(i,j,1) - end do - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in scale()") - end select + assert(mesh_compatible(out_field%mesh, in_field_new%mesh)) + assert(mesh_compatible(out_field%mesh, in_field_old%mesh)) + assert(out_field%field_type/=FIELD_TYPE_PYTHON) +#ifndef NDEBUG + if(.not.(out_field%field_type==FIELD_TYPE_NORMAL .or. & + (in_field_new%field_type==FIELD_TYPE_CONSTANT .and. & + in_field_old%field_type==FIELD_TYPE_CONSTANT))) then + ewrite(-1,*) "Incompatible field types in set()" + FLAbort("Evil") + end if +#endif + assert(all(in_field_new%dim==out_field%dim)) + assert(all(in_field_old%dim==out_field%dim)) - end subroutine tensor_scale_tensor_field + select case (in_field_new%field_type) + case (FIELD_TYPE_NORMAL) + out_field%val=theta*in_field_new%val + (1.-theta)*in_field_old%val + case (FIELD_TYPE_CONSTANT) + do i = 1, size(out_field%val, 3) + out_field%val(:,:,i)=theta*in_field_new%val(:,:,1) + (1.-theta)*in_field_old%val(:,:,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in set()") + end select - subroutine scalar_power(field, power) - !!< Raise scalar field to power - type(scalar_field), intent(inout) :: field - real, intent(in) :: power + end subroutine set_tensor_field_theta - assert(field%field_type/=FIELD_TYPE_PYTHON) + subroutine set_tensor_field_scalar_field(tensor, i, j, scalar, symmetric, scale) + !!< Set the i,j^th component of tensor to be scalar. + type(tensor_field), intent(inout) :: tensor + integer, intent(in) :: i, j + type(scalar_field), intent(in) :: scalar + logical, intent(in), optional :: symmetric + real, intent(in), optional :: scale - field%val = field%val ** power + real :: lscale - end subroutine scalar_power + assert(tensor%mesh%refcount%id==scalar%mesh%refcount%id) + assert(tensor%field_type/=FIELD_TYPE_PYTHON) + assert(tensor%field_type==FIELD_TYPE_NORMAL .or. scalar%field_type==FIELD_TYPE_CONSTANT) - subroutine vector_power(field, power, dim) - !!< Raise vector field to power - type(vector_field), intent(inout) :: field - real, intent(in) :: power - integer, intent(in), optional :: dim + if (present(scale)) then + lscale=scale + else + lscale=1.0 + end if - assert(field%field_type/=FIELD_TYPE_PYTHON) + select case (scalar%field_type) + case (FIELD_TYPE_NORMAL) + tensor%val(i, j, :) = scalar%val*lscale + if (present_and_true(symmetric)) then + tensor%val(j, i, :) = scalar%val*lscale + end if + case (FIELD_TYPE_CONSTANT) + tensor%val(i, j, :) = scalar%val(1)*lscale - if (present(dim)) then - field%val(dim,:) = field%val(dim,:) ** power - else - field%val = field%val ** power - end if - - end subroutine vector_power - - subroutine tensor_power(field, power) - !!< Raise tensor field to power - type(tensor_field), intent(inout) :: field - real, intent(in) :: power - - assert(field%field_type/=FIELD_TYPE_PYTHON) - - field%val = field%val ** power - - end subroutine tensor_power - - subroutine scalar_power_scalar_field(field, sfield) - !!< Raise scalar field to power based on sfield - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: sfield - - assert(field%mesh==sfield%mesh) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) - - select case (sfield%field_type) - case (FIELD_TYPE_NORMAL) - field%val = field%val ** sfield%val - case (FIELD_TYPE_CONSTANT) - field%val = field%val ** sfield%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in power()") - end select - - end subroutine scalar_power_scalar_field - - subroutine vector_power_scalar_field(field, sfield) - !!< Raise vector field to power based on sfield - type(vector_field), intent(inout) :: field - type(scalar_field), intent(in) :: sfield - - integer :: i - - assert(field%mesh==sfield%mesh) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) - - select case (sfield%field_type) - case (FIELD_TYPE_NORMAL) - do i=1,field%dim - field%val(i,:) = field%val(i,:) ** sfield%val - end do - case (FIELD_TYPE_CONSTANT) - do i=1,field%dim - field%val(i,:) = field%val(i,:) ** sfield%val(1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in power()") - end select - - end subroutine vector_power_scalar_field - - subroutine tensor_power_scalar_field(field, sfield) - !!< Raise tensor field to power based on sfield - type(tensor_field), intent(inout) :: field - type(scalar_field), intent(in) :: sfield - - integer :: i, j - - assert(field%mesh==sfield%mesh) - assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) - - select case (sfield%field_type) - case (FIELD_TYPE_NORMAL) - do i=1,field%dim(1) - do j=1,field%dim(2) - field%val(i,j,:) = field%val(i,j,:) ** sfield%val - end do - end do - case (FIELD_TYPE_CONSTANT) - field%val(:,:,:) = field%val(:,:,:) ** sfield%val(1) - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in power()") - end select - - end subroutine tensor_power_scalar_field - - subroutine bound_scalar_field(field, lower_bound, upper_bound) - !!< Bound a field by the lower and upper bounds supplied - type(scalar_field), intent(inout) :: field - real, intent(in) :: lower_bound, upper_bound - - integer :: i - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, node_count(field) - field%val(i) = min(max(field%val(i), lower_bound), upper_bound) - end do - case(FIELD_TYPE_CONSTANT) - field%val(1) = min(max(field%val(1), lower_bound), upper_bound) - case default - FLAbort("Illegal field type in bound()") - end select - - end subroutine bound_scalar_field - - subroutine bound_scalar_field_field(field, lower_bound, upper_bound) - !!< Bound a field by the lower and upper bounds supplied - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in), optional :: lower_bound, upper_bound - - integer :: i - - if(present(lower_bound)) then - assert(field%mesh==lower_bound%mesh) - assert(lower_bound%field_type==FIELD_TYPE_NORMAL) ! The case lower_bound=FIELD_TYPE_CONSTANT should be implemented - end if - if(present(upper_bound)) then - assert(field%mesh==upper_bound%mesh) - assert(upper_bound%field_type==FIELD_TYPE_NORMAL) ! The case upper_bound=FIELD_TYPE_CONSTANT should be implemented - end if - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - if (present(lower_bound)) then - do i = 1, node_count(field) - field%val(i) = max(field%val(i), lower_bound%val(i)) - end do - end if - if (present(upper_bound)) then - do i = 1, node_count(field) - field%val(i) = min(field%val(i), upper_bound%val(i)) - end do - end if - case default - FLAbort("Illegal field type in bound()") - end select + if (present_and_true(symmetric)) then + tensor%val(j, i, :) = scalar%val(1)*lscale + end if + case default + ! someone could implement scalar field type python + FLAbort("Illegal in_field field type in set()") + end select - end subroutine bound_scalar_field_field + end subroutine set_tensor_field_scalar_field + subroutine set_tensor_field_diag_vector_field(tensor, vector, scale) + !!< Set the diagonal components of tensor to be vector. + type(tensor_field), intent(inout) :: tensor + type(vector_field), intent(in) :: vector + real, intent(in), optional :: scale - subroutine bound_vector_field(field, lower_bound, upper_bound) - !!< Bound a field by the lower and upper bounds supplied - type(vector_field), intent(inout) :: field - real, intent(in) :: lower_bound, upper_bound + integer :: i + real :: lscale - integer :: i, j + assert(tensor%mesh%refcount%id==vector%mesh%refcount%id) + assert(tensor%field_type/=FIELD_TYPE_PYTHON) + assert(tensor%field_type==FIELD_TYPE_NORMAL .or. vector%field_type==FIELD_TYPE_CONSTANT) + assert(minval(tensor%dim)==vector%dim) - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, field%dim - do j = 1, node_count(field) - field%val(i,j) = min(max(field%val(i,j), lower_bound), upper_bound) - end do - end do - case(FIELD_TYPE_CONSTANT) - do i = 1, field%dim - field%val(i,1) = min(max(field%val(i,1), lower_bound), upper_bound) - end do - case default - FLAbort("Illegal field type in bound()") - end select - - end subroutine bound_vector_field - - subroutine bound_tensor_field(field, lower_bound, upper_bound) - !!< Bound a field by the lower and upper bounds supplied - type(tensor_field), intent(inout) :: field - real, intent(in) :: lower_bound, upper_bound - - integer :: i, j, k - - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, field%dim(1) - do j = 1, field%dim(2) - do k = 1, node_count(field) - field%val(i, j, k) = min(max(field%val(i, j, k), lower_bound), upper_bound) - end do - end do - end do - case(FIELD_TYPE_CONSTANT) - do i = 1, field%dim(1) - do j = 1, field%dim(2) - field%val(i, j, 1) = min(max(field%val(i, j, 1), lower_bound), upper_bound) - end do - end do - case default - FLAbort("Illegal field type in bound()") - end select + if (present(scale)) then + lscale=scale + else + lscale=1.0 + end if - end subroutine bound_tensor_field + select case (vector%field_type) + case (FIELD_TYPE_NORMAL) + do i = 1, minval(tensor%dim) + tensor%val(i, i, :) = vector%val(i,:)*lscale + end do + case (FIELD_TYPE_CONSTANT) + do i = 1, minval(tensor%dim) + tensor%val(i, i, :) = vector%val(i,1)*lscale + end do + case default + ! someone could implement scalar field type python + FLAbort("Illegal in_field field type in set()") + end select - subroutine normalise_scalar(field) - type(scalar_field), intent(inout) :: field + end subroutine set_tensor_field_diag_vector_field - integer :: i - real :: tolerance + subroutine set_tensor_field_node(field, node, val) + !!< Set the tensor field at the specified node + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, intent(in) :: node + real, intent(in), dimension(:, :) :: val - tolerance = tiny(0.0) + assert(field%field_type==FIELD_TYPE_NORMAL) - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, node_count(field) - call set(field, i, node_val(field, i)/(max(tolerance, abs(node_val(field, i))))) - end do - case(FIELD_TYPE_CONSTANT) - field%val(1) = field%val(1)/(max(tolerance, abs(node_val(field, 1)))) - case default - FLAbort("Illegal field type in normalise()") - end select + field%val(:, :, node) = val - end subroutine normalise_scalar + end subroutine set_tensor_field_node - subroutine normalise_vector(field) - type(vector_field), intent(inout) :: field + subroutine set_tensor_field_node_dim(field, dim1, dim2, node, val) + !!< Set the tensor field at the specified node + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, intent(in) :: dim1, dim2, node + real, intent(in) :: val - integer :: i - real :: tolerance + assert(field%field_type==FIELD_TYPE_NORMAL) + assert(dim1>=1 .and. dim1<=field%dim(1)) + assert(dim2>=1 .and. dim2<=field%dim(2)) - tolerance = tiny(0.0) + field%val(dim1, dim2, node) = val - select case(field%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, node_count(field) - call set(field, i, node_val(field, i)/(max(tolerance, norm2(node_val(field, i))))) - end do - case(FIELD_TYPE_CONSTANT) - call set(field, 1, node_val(field, 1)/(max(tolerance, norm2(node_val(field, 1))))) - case default - FLAbort("Illegal field type in normalise()") - end select - - end subroutine normalise_vector - - subroutine invert_scalar_field_inplace(field, tolerance) - !!< Computes 1/field for a scalar field - type(scalar_field), intent(inout):: field - real, intent(in), optional :: tolerance - - call invert_scalar_field(field, field, tolerance) - - end subroutine invert_scalar_field_inplace - - subroutine invert_scalar_field(in_field, out_field, tolerance) - !!< Computes 1/field for a scalar field - type(scalar_field), intent(in):: in_field - type(scalar_field), intent(inout):: out_field - real, intent(in), optional :: tolerance - - integer :: i - - assert(out_field%field_type==FIELD_TYPE_NORMAL .or. out_field%field_type==FIELD_TYPE_CONSTANT) - assert(out_field%mesh==in_field%mesh) - if (in_field%field_type==out_field%field_type) then - if(present(tolerance)) then - do i = 1, size(out_field%val) - out_field%val(i) = 1/sign(max(tolerance, abs(in_field%val(i))), in_field%val(i)) - end do - else - out_field%val=1/in_field%val - end if - else if (in_field%field_type==FIELD_TYPE_CONSTANT) then - if(present(tolerance)) then - out_field%val = 1/sign(max(tolerance, abs(in_field%val(1))), in_field%val(1)) - else - out_field%val=1/in_field%val(1) - end if - else - FLAbort("Calling invert_scalar_field with wrong field type") - end if + end subroutine set_tensor_field_node_dim - end subroutine invert_scalar_field + subroutine set_tensor_field_nodes(field, node_numbers, val) + !!< Set the tensor field at the specified nodes + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + integer, dimension(:), intent(in) :: node_numbers + real, intent(in), dimension(:, :, :) :: val - subroutine invert_vector_field_inplace(field, tolerance) - !!< Computes 1/field for a vector field - type(vector_field), intent(inout):: field - real, intent(in), optional :: tolerance + assert(field%field_type==FIELD_TYPE_NORMAL) - call invert_vector_field(field, field, tolerance) + field%val(:, :, node_numbers) = val - end subroutine invert_vector_field_inplace + end subroutine set_tensor_field_nodes - subroutine invert_vector_field(in_field, out_field, tolerance) - !!< Computes 1/field for a vector field - type(vector_field), intent(in):: in_field - type(vector_field), intent(inout):: out_field - real, intent(in), optional :: tolerance + subroutine set_tensor_field(field, val) + !!< Sets tensor with constant value + !!< Works for constant and space varying fields. + type(tensor_field), intent(inout) :: field + real, intent(in), dimension(:, :) :: val + integer :: i - integer :: i, j + assert(field%field_type/=FIELD_TYPE_PYTHON) - assert(out_field%field_type==FIELD_TYPE_NORMAL .or. out_field%field_type==FIELD_TYPE_CONSTANT) - assert(in_field%dim==in_field%dim) - do i = 1, out_field%dim - if (in_field%field_type==out_field%field_type) then - if(present(tolerance)) then - do j = 1, size(out_field%val(i,:)) - out_field%val(i,j) = 1/sign(max(tolerance, abs(in_field%val(i,j))), in_field%val(i,j)) - end do - else - out_field%val(i,:)=1/in_field%val(i,:) - end if - else if (in_field%field_type==FIELD_TYPE_CONSTANT) then - if(present(tolerance)) then - out_field%val(i,:)=1/sign(max(tolerance, abs(in_field%val(i,1))), in_field%val(i,1)) - else - out_field%val(i,:)=1/in_field%val(i,1) - end if - else - FLAbort("Calling invert_vector_field with wrong field type") - end if - end do + do i=1,size(field%val, 3) + field%val(:, :, i) = val + end do - end subroutine invert_vector_field + end subroutine set_tensor_field - subroutine invert_tensor_field_inplace(field, tolerance) - !!< Computes 1/field for a tensor field - type(tensor_field), intent(inout):: field - real, intent(in), optional :: tolerance + subroutine set_tensor_field_dim(field, dim1, dim2, val) + !!< Sets one component of a tensor with constant value + !!< Works for constant and space varying fields. + type(tensor_field), intent(inout) :: field + real, intent(in) :: val + integer, intent(in):: dim1, dim2 + integer :: i - call invert_tensor_field(field, field, tolerance) + assert(field%field_type/=FIELD_TYPE_PYTHON) - end subroutine invert_tensor_field_inplace + do i=1,size(field%val, 3) + field%val(dim1, dim2, i) = val + end do - subroutine invert_tensor_field(in_field, out_field, tolerance) - !!< Computes 1/field for a tensor field - type(tensor_field), intent(in):: in_field - type(tensor_field), intent(inout):: out_field - real, intent(in), optional :: tolerance + end subroutine set_tensor_field_dim - integer :: i, j, k + subroutine set_tensor_field_arr(field, val) + !!< Set the tensor field at all nodes at once + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + real, dimension(:,:,:), intent(in) :: val - assert(out_field%field_type==FIELD_TYPE_NORMAL .or. out_field%field_type==FIELD_TYPE_CONSTANT) - assert(in_field%dim(1)==in_field%dim(1)) - assert(in_field%dim(2)==in_field%dim(2)) - do i = 1, out_field%dim(1) - do j = 1, out_field%dim(2) - if (in_field%field_type==out_field%field_type) then - if(present(tolerance)) then - do k = 1, size(out_field%val(i,j,:)) - out_field%val(i,j,k) = 1/sign(max(tolerance, abs(in_field%val(i,j,k))), in_field%val(i,j,k)) - end do - else - out_field%val(i,j,:)=1/in_field%val(i,j,:) - end if - else if (in_field%field_type==FIELD_TYPE_CONSTANT) then - if(present(tolerance)) then - out_field%val(i,j,:)=1/sign(max(tolerance, abs(in_field%val(i,j,1))), in_field%val(i,j,1)) - else - out_field%val(i,j,:)=1/in_field%val(i,j,1) - end if - else - FLAbort("Calling invert_vector_field with wrong field type") - end if - end do - end do - - end subroutine invert_tensor_field - - subroutine absolute_value_scalar_field(field) - !!< Computes abs(field) for a scalar field - type(scalar_field), intent(inout) :: field - - field%val = abs(field%val) - - end subroutine absolute_value_scalar_field - - subroutine cross_product_vector(a, b, c) - !!< Computes the node-wise outer product a=b x c - !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points - !!< will not be as accurate as multiplying the fields at each gauss point seperately - !!< and then summing over these. - type(vector_field), intent(inout) :: a - type(vector_field), intent(in) :: b, c - - type(vector_field) tmp_b, tmp_c - integer, dimension(3), parameter:: perm1=(/ 2,3,1 /), perm2=(/ 3,1,2 /) - integer i - - assert(a%field_type/=FIELD_TYPE_PYTHON) - assert(a%field_type==FIELD_TYPE_NORMAL .or. b%field_type==FIELD_TYPE_CONSTANT) - assert(a%field_type==FIELD_TYPE_NORMAL .or. c%field_type==FIELD_TYPE_CONSTANT) - assert(a%dim==b%dim) - assert(a%dim==c%dim) - - if (a%mesh==c%mesh .and. c%field_type/=FIELD_TYPE_CONSTANT) then - tmp_c=c - else - call allocate(tmp_c, c%dim, a%mesh, name='cross_product_vector_tmp_c') - call remap_field(c, tmp_c) - end if - - select case (b%field_type) - case (FIELD_TYPE_NORMAL) - - if (a%mesh==b%mesh) then - tmp_b=b - else - call allocate(tmp_b, b%dim, a%mesh, name='cross_product_vector_tmp_b') - call remap_field(b, tmp_b) - end if - - select case (c%field_type) - case (FIELD_TYPE_NORMAL) - do i=1, a%dim - a%val(i,:)=tmp_b%val( perm1(i),: ) * tmp_c%val( perm2(i),: )- & - tmp_b%val( perm2(i),: ) * tmp_c%val( perm1(i),: ) - end do - case (FIELD_TYPE_CONSTANT) - do i=1, a%dim - a%val(i,:)=tmp_b%val( perm1(i),: ) * tmp_c%val( perm2(i),1 )- & - tmp_b%val( perm2(i),: ) * tmp_c%val( perm1(i),1 ) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in cross_product()") - end select + assert(field%field_type==FIELD_TYPE_NORMAL) - if (.not. a%mesh==b%mesh) then - call deallocate(tmp_b) - end if + field%val = val - case (FIELD_TYPE_CONSTANT) + end subroutine set_tensor_field_arr - select case (c%field_type) - case (FIELD_TYPE_NORMAL) - do i=1, a%dim - a%val(i,:)=b%val( perm1(i),1 ) * tmp_c%val( perm2(i),: )- & - b%val( perm2(i),1 ) * tmp_c%val( perm1(i),: ) - end do - case (FIELD_TYPE_CONSTANT) - do i=1, a%dim - a%val(i,:)=b%val( perm1(i),1 ) * tmp_c%val( perm2(i),1 )- & - b%val( perm2(i),1 ) * tmp_c%val( perm1(i),1 ) - end do - case default - ! someone could implement b type python - FLAbort("Illegal in_field field type in cross_product()") - end select + subroutine set_tensor_field_arr_dim(field, dim1, dim2, val) + !!< Set the tensor field at all nodes at once + !!< Does not work for constant fields + type(tensor_field), intent(inout) :: field + real, dimension(:), intent(in) :: val + integer, intent(in):: dim1, dim2 - case default + assert(field%field_type==FIELD_TYPE_NORMAL) - ! someone could implement c field type python - FLAbort("Illegal in_field field type in cross_product()") + field%val(dim1, dim2, :) = val - end select + end subroutine set_tensor_field_arr_dim - if (.not. a%mesh==c%mesh .or. c%field_type==FIELD_TYPE_CONSTANT) then - call deallocate(tmp_c) - end if + subroutine set_from_python_function_scalar(field, func, position, time) + !!< Set the values at the nodes of field using the python function + !!< specified in the string func. The position field is used to + !!< determine the locations of the nodes. + type(scalar_field), intent(inout) :: field + !! Func may contain any python at all but the following function must + !! be defined: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + type(vector_field), intent(in), target :: position + real, intent(in) :: time - end subroutine cross_product_vector + type(vector_field) :: lposition + real, dimension(:), pointer :: x, y, z + real, dimension(0), target :: zero + integer :: stat, dim - subroutine inner_product_field_field(a, b, c) - !!< Computes the node-wise inner/dot product a=b . c - !!< This version takes two scalar fields. NOTE that if a and b and c - !!< have the same polynomial degree you will loose accuracy. In many - !!< cases you have to calculate this at the gauss points instead. - type(scalar_field), intent(inout) :: a - type(vector_field), intent(in) :: b,c + dim=position%dim - type(vector_field) tmp_b, tmp_c - integer i + x=>zero + y=>zero + z=>zero + if (field%mesh==position%mesh) then + x=>position%val(1,:) - assert(a%field_type/=FIELD_TYPE_PYTHON) - assert(a%field_type==FIELD_TYPE_NORMAL .or. b%field_type==FIELD_TYPE_CONSTANT) - assert(a%field_type==FIELD_TYPE_NORMAL .or. c%field_type==FIELD_TYPE_CONSTANT) - assert(b%dim==c%dim) + if (dim>1) then + y=>position%val(2,:) - if (a%mesh==c%mesh .and. c%field_type/=FIELD_TYPE_CONSTANT) then - tmp_c=c - else - call allocate(tmp_c, c%dim, a%mesh, name='inner_product_vector_tmp_c') - call remap_field(c, tmp_c) - end if + if (dim>2) then + z=>position%val(3,:) + end if + end if + else + ! Remap position first. + lposition = get_remapped_coordinates(position, field%mesh) + ! we've just allowed remapping from a higher order to a lower order continuous field as this should be valid for + ! coordinates + ! also allowed to remap from unperiodic to periodic... hopefully the python function used will also be periodic! - select case (b%field_type) - case (FIELD_TYPE_NORMAL) + x=>lposition%val(1,:) - if (a%mesh==b%mesh) then - tmp_b=b - else - call allocate(tmp_b, b%dim, a%mesh, name='cross_product_vector_tmp_b') - call remap_field(b, tmp_b) - end if + if (dim>1) then + y=>lposition%val(2,:) - select case (c%field_type) - case (FIELD_TYPE_NORMAL) - a%val=tmp_b%val(1,:)*tmp_c%val(1,:) - do i=2, c%dim - a%val=a%val+tmp_b%val(i,:)*tmp_c%val(i,:) - end do - case (FIELD_TYPE_CONSTANT) - a%val=tmp_b%val(1,:)*c%val(1,1) - do i=2, c%dim - a%val=a%val+tmp_b%val(i,:)*c%val(i,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in inner_product()") - end select + if (dim>2) then + z=>lposition%val(3,:) + end if + end if + end if - case (FIELD_TYPE_CONSTANT) + call set_scalar_field_from_python(func, len(func), dim,& + & node_count(field), x, y, z, time, field%val, stat) - select case (c%field_type) - case (FIELD_TYPE_NORMAL) - a%val=b%val(1,1)*tmp_c%val(1,:) - do i=2, c%dim - a%val=a%val+b%val(i,1)*tmp_c%val(i,:) - end do - case (FIELD_TYPE_CONSTANT) - a%val=b%val(1,1)*c%val(1,1) - do i=2, c%dim - a%val=a%val+b%val(i,1)*c%val(i,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in inner_product()") - end select - - case default - - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in inner_product()") - - end select - - if (.not. c%mesh==tmp_c%mesh) then - call deallocate(tmp_c) - end if - - end subroutine inner_product_field_field - - subroutine inner_product_array_field(a, b, c) - !!< Computes the node-wise inner/dot product a=b . c - type(scalar_field), intent(inout) :: a - real, dimension(:), intent(in) :: b - type(vector_field), intent(in) :: c - - integer i - - assert(a%mesh%refcount%id==c%mesh%refcount%id) - assert(a%field_type/=FIELD_TYPE_PYTHON) - assert(a%field_type==FIELD_TYPE_NORMAL .or. c%field_type==FIELD_TYPE_CONSTANT) - assert(size(b)==c%dim) - - select case (c%field_type) - case (FIELD_TYPE_NORMAL) - a%val=b(1)*c%val(1,:) - do i=2, c%dim - a%val=a%val+b(i)*c%val(i,:) - end do - case (FIELD_TYPE_CONSTANT) - a%val=b(1)*c%val(1,1) - do i=2, c%dim - a%val=a%val+b(i)*c%val(i,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in inner_product()") - end select - - end subroutine inner_product_array_field - - subroutine inner_product_field_array(a, b, c) - !!< Computes the node-wise inner/dot product a=b . c - type(scalar_field), intent(inout) :: a - type(vector_field), intent(in) :: b - real, dimension(:), intent(in) :: c - - integer i - - assert(a%mesh%refcount%id==b%mesh%refcount%id) - assert(a%field_type/=FIELD_TYPE_PYTHON) - assert(a%field_type==FIELD_TYPE_NORMAL .or. b%field_type==FIELD_TYPE_CONSTANT) - assert(size(c)==b%dim) - - select case (b%field_type) - case (FIELD_TYPE_NORMAL) - a%val=c(1)*b%val(1,:) - do i=2, b%dim - a%val=a%val+c(i)*b%val(i,:) - end do - case (FIELD_TYPE_CONSTANT) - a%val=c(1)*b%val(1,1) - do i=2, b%dim - a%val=a%val+c(i)*b%val(i,1) - end do - case default - ! someone could implement in_field type python - FLAbort("Illegal in_field field type in inner_product()") - end select - - end subroutine inner_product_field_array - - function get_patch_ele(mesh, node, level) result(patch) - !!< This function takes in a node and returns a patch_type containing - !!< information about the elements around this node. - integer, intent(in) :: node - type(mesh_type), intent(inout) :: mesh - integer, optional, intent(in) :: level ! how many elements deep do you want the patch - type(patch_type) :: patch - - integer :: i, j, k, l, llevel, ele, setsize - integer, dimension(:), pointer :: ele_node_list - type(csr_sparsity), pointer :: nelist - - if (present(level)) then - llevel = level - else - llevel = 1 - end if - - nelist => extract_nelist(mesh) - - ! Compute level-1 patch. - do j=nelist%findrm(node), nelist%findrm(node+1) - 1 - ele = nelist%colm(j) - call eleset_add(ele) - end do - - ! Compute any other levels. - ! There's an obvious optimisation here for l > 2, but in - ! practice I don't use l > 2, so I couldn't be bothered coding it. - ! (The optimisation being don't check elements you've already checked) - do l=2,llevel - call eleset_get_size(setsize) - do i=1,setsize - call eleset_get_ele(i, ele) - ele_node_list => ele_nodes(mesh, ele) ! get the nodes in that element - do j=1,size(ele_node_list) ! loop over those nodes - do k=nelist%findrm(ele_node_list(j)),nelist%findrm(ele_node_list(j)+1)-1 ! loop over their elements - call eleset_add(nelist%colm(k)) ! add - end do - end do - end do - end do - - call eleset_get_size(patch%count) - allocate(patch%elements(patch%count)) - call eleset_fetch_list(patch%elements) - - end function get_patch_ele - - function get_patch_node(mesh, node, level, min_nodes) result(patch) - !!< This function takes in a node and returns a patch_type containing - !!< information about the nodes around this node. - integer, intent(in) :: node - type(mesh_type), intent(inout) :: mesh - integer, optional, intent(in) :: level ! how many elements deep do you want the patch - integer, optional, intent(in) :: min_nodes ! how many nodes must be in the patch - type(patch_type) :: patch - - integer :: i, j, k, l, llevel, nnode, nnnode, ele, setsize - integer, dimension(:), pointer :: ele_node_list - type(csr_sparsity), pointer :: nelist - - if (present(level)) then - llevel = level - else - llevel = 1 - end if - - nelist => extract_nelist(mesh) - - ! Compute level-1 patch. - do j=nelist%findrm(node), nelist%findrm(node+1) - 1 - ele = nelist%colm(j) - ele_node_list => ele_nodes(mesh, ele) - do k=1,size(ele_node_list) - nnode = ele_node_list(k) - call eleset_add(nnode) - end do - end do - - ! Compute any other levels. - ! There's an obvious optimisation here for l > 2, but in - ! practice I don't use l > 2, so I couldn't be bothered coding it. - ! (The optimisation being don't check elements you've already checked) - l = 0 - do - ! Let's decide whether - ! to exit or not. - l = l + 1 - if (present(min_nodes)) then - call eleset_get_size(setsize) - if (setsize > min_nodes .and. l >= llevel) then - exit - end if - else - if (l >= llevel) then - exit - end if + if (stat/=0) then + ewrite(-1, *) "Python error while setting field: "//trim(field%name) + ewrite(-1, *) "Python string was:" + ewrite(-1, *) trim(func) + FLExit("Dying") end if - do i=1,setsize - call eleset_get_ele(i, nnode) - do j=nelist%findrm(nnode),nelist%findrm(nnode+1)-1 ! loop over their elements - ele = nelist%colm(j) - ele_node_list => ele_nodes(mesh, ele) ! loop over this elements' nodes - do k=1,size(ele_node_list) - nnnode = ele_node_list(k) - call eleset_add(nnnode) ! add - end do - end do - end do - end do - - call eleset_get_size(patch%count) - allocate(patch%elements(patch%count)) - call eleset_fetch_list(patch%elements) - - end function get_patch_node - - function clone_header_scalar(field) result(out_field) - type(scalar_field), intent(in) :: field - type(scalar_field) :: out_field - - out_field = field - nullify(out_field%val) - end function clone_header_scalar - - function clone_header_vector(field) result(out_field) - type(vector_field), intent(in) :: field - type(vector_field) :: out_field - - out_field = field - nullify(out_field%val) - - end function clone_header_vector - - function clone_header_tensor(field) result(out_field) - type(tensor_field), intent(in) :: field - type(tensor_field) :: out_field - - out_field = field - nullify(out_field%val) - end function clone_header_tensor - - subroutine set_to_submesh_scalar(from_field, to_field) - !!< Set the nodal values of a field on a higher order mesh to a field on its submesh. - type(scalar_field), intent(in) :: from_field - type(scalar_field), intent(inout) :: to_field - - integer :: vertices, from_ele, to_ele, l_ele - integer, dimension(:,:), allocatable :: permutation - real, dimension(:), allocatable :: from_vals - integer, dimension(:), pointer :: to_nodes - - ewrite(1,*) 'entering set_to_submesh_scalar' - - assert(to_field%mesh%shape%degree==1) - - vertices = from_field%mesh%shape%quadrature%vertices - - select case(from_field%mesh%shape%numbering%family) - case(FAMILY_SIMPLEX) - - select case(from_field%mesh%shape%degree) - case(2) - - select case(vertices) - case(3) ! triangle - assert(to_field%mesh%elements==4*from_field%mesh%elements) - - allocate(permutation(4,3)) - ! here we assume that the one true node ordering is used - permutation = reshape((/1, 2, 2, 4, & - 2, 3, 4, 5, & - 4, 5, 5, 6/), (/4,3/)) - case(4) ! tet - assert(to_field%mesh%elements==8*from_field%mesh%elements) - - allocate(permutation(8,4)) - ! here we assume that the one true node ordering is used - ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron - permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & - 2, 3, 5, 8, 4, 5, 5, 7, & - 4, 5, 6, 9, 5, 7, 7, 8, & - 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) - case default - FLAbort("unrecognised vertex count") - end select - case(1) - !nothing to be done really - - select case(vertices) - case(3) ! triangle - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,3)) - permutation = reshape((/1, 2, 3/), (/1,3/)) - case(4) ! tet - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,4)) - permutation = reshape((/1, 2, 3, 4/), (/1,4/)) - case default - FLAbort("unrecognised vertex count") - end select - - case default - FLAbort("set_to_submesh_scalar only works for quadratic or lower elements") - end select + if (has_references(lposition)) then + call deallocate(lposition) + end if - case default - FLExit("set_to_submesh_scalar only works for simplex elements") - end select + end subroutine set_from_python_function_scalar + + subroutine set_from_python_function_vector(field, func, position, time) + !!< Set the values at the nodes of field using the python function + !!< specified in the string func. The position field is used to + !!< determine the locations of the nodes. + type(vector_field), intent(inout) :: field + !! Func may contain any python at all but the following function must + !! be defiled: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + type(vector_field), intent(in), target :: position + real, intent(in) :: time + + type(vector_field) :: lposition + real, dimension(:), pointer :: x, y, z, fx, fy, fz + real, dimension(0), target :: zero + integer :: stat, dim + + dim=position%dim + + if (mesh_dim(field)/=mesh_dim(position)) then + ewrite(0,'(a,i0)') "Vector field "//trim(field%name)//" has mesh dimension ",mesh_dim(field) + ewrite(0,'(a,i0)') "Position field "//trim(position%name)//" has mesh dimension ",mesh_dim(position) + FLExit("This is inconsistent") + end if - allocate(from_vals(from_field%mesh%shape%loc)) + x=>zero + y=>zero + z=>zero + if (field%mesh==position%mesh) then + x=>position%val(1,:) - to_ele = 0 - do from_ele = 1, element_count(from_field) - from_vals=ele_val(from_field, from_ele) + if (dim>1) then + y=>position%val(2,:) - do l_ele = 1, size(permutation,1) - to_ele = to_ele+1 - to_nodes=>ele_nodes(to_field, to_ele) - call set(to_field, to_nodes, from_vals(permutation(l_ele,:))) - end do + if (dim>2) then + z=>position%val(3,:) + end if + end if + else + ! Remap position first. + lposition = get_remapped_coordinates(position, field%mesh) + ! we've just allowed remapping from a higher order to a lower order continuous field as this should be valid for + ! coordinates + ! also allowed to remap from unperiodic to periodic... hopefully the python function used will also be periodic! - end do - - end subroutine set_to_submesh_scalar - - subroutine set_to_submesh_vector(from_field, to_field) - !!< Set the nodal values of a field on a higher order mesh to a field on its submesh. - type(vector_field), intent(in) :: from_field - type(vector_field), intent(inout) :: to_field - - integer :: vertices, from_ele, to_ele, l_ele - integer, dimension(:,:), allocatable :: permutation - real, dimension(:,:), allocatable :: from_vals - integer, dimension(:), pointer :: to_nodes - - ewrite(1,*) 'entering set_to_submesh_vector' - - assert(to_field%mesh%shape%degree==1) - - vertices = from_field%mesh%shape%quadrature%vertices - - select case(from_field%mesh%shape%numbering%family) - case(FAMILY_SIMPLEX) - - select case(from_field%mesh%shape%degree) - case(2) - - select case(vertices) - case(3) ! triangle - assert(to_field%mesh%elements==4*from_field%mesh%elements) - - allocate(permutation(4,3)) - ! here we assume that the one true node ordering is used - permutation = reshape((/1, 2, 2, 4, & - 2, 3, 4, 5, & - 4, 5, 5, 6/), (/4,3/)) - case(4) ! tet - assert(to_field%mesh%elements==8*from_field%mesh%elements) - - allocate(permutation(8,4)) - ! here we assume that the one true node ordering is used - ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron - permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & - 2, 3, 5, 8, 4, 5, 5, 7, & - 4, 5, 6, 9, 5, 7, 7, 8, & - 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) - case default - FLAbort("unrecognised vertex count") - end select - case(1) - !nothing to be done really - - select case(vertices) - case(3) ! triangle - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,3)) - permutation = reshape((/1, 2, 3/), (/1,3/)) - case(4) ! tet - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,4)) - permutation = reshape((/1, 2, 3, 4/), (/1,4/)) - case default - FLAbort("unrecognised vertex count") - end select - - case default - FLAbort("set_to_submesh_vector only works for quadratic or lower elements") - end select + x=>lposition%val(1,:) - case default - FLExit("set_to_submesh_vector only works for simplex elements") - end select + if (dim>1) then + y=>lposition%val(2,:) - allocate(from_vals(from_field%dim, from_field%mesh%shape%loc)) + if (dim>2) then + z=>lposition%val(3,:) + end if + end if + end if - to_ele = 0 - do from_ele = 1, element_count(from_field) - from_vals=ele_val(from_field, from_ele) + fx=>zero + fy=>zero + fz=>zero - do l_ele = 1, size(permutation,1) - to_ele = to_ele+1 - to_nodes=>ele_nodes(to_field, to_ele) - call set(to_field, to_nodes, from_vals(:, permutation(l_ele,:))) - end do + fx=>field%val(1,:) + if (field%dim>1) then + fy=>field%val(2,:) - end do - - end subroutine set_to_submesh_vector - - subroutine set_from_submesh_scalar(from_field, to_field) - !!< Set the nodal values of a field on a lower order submesh to a field on its parent mesh. - type(scalar_field), intent(in) :: from_field - type(scalar_field), intent(inout) :: to_field - - integer :: vertices, from_ele, to_ele, l_ele - integer, dimension(:,:), allocatable :: permutation - real, dimension(:), allocatable :: from_vals - integer, dimension(:), pointer :: to_nodes - - ewrite(1,*) 'entering set_from_submesh_scalar' - - assert(from_field%mesh%shape%degree==1) - - vertices = to_field%mesh%shape%quadrature%vertices - - select case(to_field%mesh%shape%numbering%family) - case(FAMILY_SIMPLEX) - - select case(to_field%mesh%shape%degree) - case(2) - - select case(vertices) - case(3) ! triangle - assert(4*to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(4,3)) - ! here we assume that the one true node ordering is used - permutation = reshape((/1, 2, 2, 4, & - 2, 3, 4, 5, & - 4, 5, 5, 6/), (/4,3/)) - case(4) ! tet - assert(8*to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(8,4)) - ! here we assume that the one true node ordering is used - ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron - permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & - 2, 3, 5, 8, 4, 5, 5, 7, & - 4, 5, 6, 9, 5, 7, 7, 8, & - 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) - case default - FLAbort("unrecognised vertex count") - end select - case(1) - !nothing to be done really - - select case(vertices) - case(3) ! triangle - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,3)) - permutation = reshape((/1, 2, 3/), (/1,3/)) - case(4) ! tet - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,4)) - permutation = reshape((/1, 2, 3, 4/), (/1,4/)) - case default - FLExit("unrecognised vertex count") - end select - - case default - FLAbort("set_from_submesh_vector only works for quadratic or lower elements") - end select + if (field%dim>2) then + fz=>field%val(3,:) + end if + end if - case default - FLAbort("set_from_submesh_vector only works for simplex elements") - end select - allocate(from_vals(from_field%mesh%shape%loc)) + call set_vector_field_from_python(func, len_trim(func), dim,& + & node_count(field), x, y, z, time, field%dim, & + & fx, fy, fz, stat) - from_ele = 0 - do to_ele = 1, element_count(to_field) - to_nodes=>ele_nodes(to_field, to_ele) + if (stat/=0) then + ewrite(-1, *) "Python error while setting field: "//trim(field%name) + ewrite(-1, *) "Python string was:" + ewrite(-1, *) trim(func) + FLExit("Dying") + end if - do l_ele = 1, size(permutation,1) + if (has_references(lposition)) then + call deallocate(lposition) + end if - from_ele = from_ele + 1 - from_vals=ele_val(from_field, from_ele) + end subroutine set_from_python_function_vector + + subroutine set_from_python_function_tensor(field, func, position, time) + !!< Set the values at the nodes of field using the python function + !!< specified in the string func. The position field is used to + !!< determine the locations of the nodes. + type(tensor_field), intent(inout) :: field + !! Func may contain any python at all but the following function must + !! be defined: + !! def val(X, t) + !! where X is a tuple containing the position of a point and t is the + !! time. The result must be a float. + character(len=*), intent(in) :: func + type(vector_field), intent(in), target :: position + real, intent(in) :: time + + type(vector_field) :: lposition + real, dimension(:), pointer :: x, y, z + real, dimension(0), target :: zero + integer :: stat, dim + + dim=position%dim + + x=>zero + y=>zero + z=>zero + if (field%mesh==position%mesh) then + x=>position%val(1,:) + + if (dim>1) then + y=>position%val(2,:) + + if (dim>2) then + z=>position%val(3,:) + end if + end if + else + ! Remap position first. + lposition = get_remapped_coordinates(position, field%mesh) + ! we've just allowed remapping from a higher order to a lower order continuous field as this should be valid for + ! coordinates + ! also allowed to remap from unperiodic to periodic... hopefully the python function used will also be periodic! - call set(to_field, to_nodes(permutation(l_ele,:)), from_vals) + x=>lposition%val(1,:) - end do + if (dim>1) then + y=>lposition%val(2,:) - end do - - end subroutine set_from_submesh_scalar - - subroutine set_from_submesh_vector(from_field, to_field) - !!< Set the nodal values of a field on a lower order submesh to a field on its parent mesh. - type(vector_field), intent(in) :: from_field - type(vector_field), intent(inout) :: to_field - - integer :: vertices, from_ele, to_ele, l_ele - integer, dimension(:,:), allocatable :: permutation - real, dimension(:,:), allocatable :: from_vals - integer, dimension(:), pointer :: to_nodes - - ewrite(1,*) 'entering set_from_submesh_vector' - - assert(from_field%mesh%shape%degree==1) - - vertices = to_field%mesh%shape%quadrature%vertices - - select case(to_field%mesh%shape%numbering%family) - case(FAMILY_SIMPLEX) - - select case(to_field%mesh%shape%degree) - case(2) - - select case(vertices) - case(3) ! triangle - assert(4*to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(4,3)) - ! here we assume that the one true node ordering is used - permutation = reshape((/1, 2, 2, 4, & - 2, 3, 4, 5, & - 4, 5, 5, 6/), (/4,3/)) - case(4) ! tet - assert(8*to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(8,4)) - ! here we assume that the one true node ordering is used - ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron - permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & - 2, 3, 5, 8, 4, 5, 5, 7, & - 4, 5, 6, 9, 5, 7, 7, 8, & - 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) - case default - FLAbort("unrecognised vertex count") - end select - case(1) - !nothing to be done really - - select case(vertices) - case(3) ! triangle - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,3)) - permutation = reshape((/1, 2, 3/), (/1,3/)) - case(4) ! tet - assert(to_field%mesh%elements==from_field%mesh%elements) - - allocate(permutation(1,4)) - permutation = reshape((/1, 2, 3, 4/), (/1,4/)) - case default - FLExit("unrecognised vertex count") - end select - - case default - FLAbort("set_from_submesh_vector only works for quadratic or lower elements") - end select + if (dim>2) then + z=>lposition%val(3,:) + end if + end if + end if - case default - FLAbort("set_from_submesh_vector only works for simplex elements") - end select + call set_tensor_field_from_python(func, len(func), dim,& + & node_count(field), x, y, z, time, field%dim, & + field%val, stat) - allocate(from_vals(from_field%dim, from_field%mesh%shape%loc)) + if (stat/=0) then + ewrite(-1, *) "Python error while setting field: "//trim(field%name) + ewrite(-1, *) "Python string was:" + ewrite(-1, *) trim(func) + FLExit("Dying") + end if - from_ele = 0 - do to_ele = 1, element_count(to_field) - to_nodes=>ele_nodes(to_field, to_ele) + if (has_references(lposition)) then + call deallocate(lposition) + end if - do l_ele = 1, size(permutation,1) + end subroutine set_from_python_function_tensor + + subroutine set_from_function_scalar(field, func, position) + !!< Set the values in field using func applied to the position field. + !!< Func should be a function which takes a real position vector and + !!< returns a scalar real value. + type(scalar_field), intent(inout) :: field + type(vector_field), intent(in) :: position + interface + function func(X) + real :: func + real, dimension(:), intent(in) :: X + end function func + end interface + + type(vector_field) :: lpos + integer :: i + + if (field%field_type /= FIELD_TYPE_NORMAL) then + FLAbort("You can only set a normal field from a function!") + end if - from_ele = from_ele + 1 - from_vals=ele_val(from_field, from_ele) + call allocate(lpos, position%dim, field%mesh, "Local Position") - call set(to_field, to_nodes(permutation(l_ele,:)), from_vals) + call remap_field(position, lpos) + do i=1,node_count(field) + field%val(i)=func(node_val(lpos, i)) end do - end do + call deallocate(lpos) + + end subroutine set_from_function_scalar + + subroutine set_from_function_vector(field, func, position) + !!< Set the values in field using func applied to the position field. + !!< Func should be a function which takes a real position vector and + !!< returns a vector real value of the same dimension as the position + !!< field. + type(vector_field), intent(inout) :: field + type(vector_field), intent(in) :: position + interface + function func(X) + real, dimension(:), intent(in) :: X + real, dimension(size(X)) :: func + end function func + end interface + + type(vector_field) :: lpos + integer :: i + + if (field%field_type /= FIELD_TYPE_NORMAL) then + FLAbort("You can only set a normal field from a function!") + end if - end subroutine set_from_submesh_vector + call allocate(lpos, position%dim, field%mesh, "Local Position") - subroutine set_ele_nodes(mesh, ele, nodes) - type(mesh_type), intent(inout) :: mesh - integer, intent(in) :: ele - integer, dimension(:), intent(in) :: nodes + call remap_field(position, lpos) - assert(size(nodes) == ele_loc(mesh, ele)) + call zero(field) - mesh%ndglno(mesh%shape%loc*(ele-1)+1:& - &mesh%shape%loc*ele) = nodes - end subroutine set_ele_nodes + do i=1,node_count(field) + call addto(field, i, func(node_val(lpos, i))) + end do - subroutine renumber_positions_trailing_receives(positions, permutation) - type(vector_field), intent(inout) :: positions - integer, dimension(:), intent(out), optional :: permutation + call deallocate(lpos) + + end subroutine set_from_function_vector + + subroutine set_from_function_tensor(field, func, position) + !!< Set the values in field using func applied to the position field. + !!< Func should be a function which takes a real position vector and + !!< returns a tensor real value of the same dimension as the position + !!< field. + type(tensor_field), intent(inout) :: field + type(vector_field), intent(in) :: position + interface + function func(X) + real, dimension(:), intent(in) :: X + real, dimension(size(X), size(X)) :: func + end function func + end interface + + type(vector_field) :: lpos + integer :: i + + if (field%field_type /= FIELD_TYPE_NORMAL) then + FLAbort("You can only set a normal field from a function!") + end if + + call allocate(lpos, position%dim, field%mesh, "Local Position") + + call remap_field(position, lpos) + + call zero(field) + + do i=1,node_count(field) + call addto(field, i, func(node_val(lpos, i))) + end do + + call deallocate(lpos) + + end subroutine set_from_function_tensor + + ! ------------------------------------------------------------------------ + ! Mapping of fields between different meshes + ! ------------------------------------------------------------------------ + + subroutine test_remap_validity_scalar(from_field, to_field, stat) + type(scalar_field), intent(in):: from_field, to_field + integer, intent(out), optional:: stat + + if(present(stat)) stat = 0 + + call test_remap_validity_generic(trim(from_field%name), trim(to_field%name), & + continuity(from_field), continuity(to_field), & + element_degree(from_field, 1), element_degree(to_field, 1), & + mesh_periodic(from_field), mesh_periodic(to_field), & + from_field%mesh%shape%numbering%type, to_field%mesh%shape%numbering%type, & + stat) + + end subroutine test_remap_validity_scalar + + subroutine test_remap_validity_vector(from_field, to_field, stat) + type(vector_field), intent(in):: from_field, to_field + integer, intent(out), optional:: stat + + if(present(stat)) stat = 0 + + call test_remap_validity_generic(trim(from_field%name), trim(to_field%name), & + continuity(from_field), continuity(to_field), & + element_degree(from_field, 1), element_degree(to_field, 1), & + mesh_periodic(from_field), mesh_periodic(to_field), & + from_field%mesh%shape%numbering%type, to_field%mesh%shape%numbering%type, & + stat) + + end subroutine test_remap_validity_vector + + subroutine test_remap_validity_tensor(from_field, to_field, stat) + type(tensor_field), intent(in):: from_field, to_field + integer, intent(out), optional:: stat + + if(present(stat)) stat = 0 + + call test_remap_validity_generic(trim(from_field%name), trim(to_field%name), & + continuity(from_field), continuity(to_field), & + element_degree(from_field, 1), element_degree(to_field, 1), & + mesh_periodic(from_field), mesh_periodic(to_field), & + from_field%mesh%shape%numbering%type, to_field%mesh%shape%numbering%type, & + stat) + + end subroutine test_remap_validity_tensor + + subroutine test_remap_validity_generic(from_name, to_name, & + from_continuity, to_continuity, & + from_degree, to_degree, & + from_periodic, to_periodic, & + from_type, to_type, & + stat) + character(len=*), intent(in):: from_name, to_name + integer, intent(in):: from_continuity, to_continuity + integer, intent(in):: from_degree, to_degree + logical, intent(in):: from_periodic, to_periodic + integer, intent(in):: from_type, to_type + integer, intent(out), optional:: stat + + if(present(stat)) stat = 0 + + if((from_continuity<0).and.(.not.(to_continuity<0))) then + if(present(stat)) then + stat = REMAP_ERR_DISCONTINUOUS_CONTINUOUS + else + ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." + FLAbort("Trying to remap from discontinuous to continuous field.") + end if + end if + + ! this test currently assumes that the shape function degree is constant over the mesh + if((.not.(from_continuity<0)).and.(.not.(to_continuity<0))& + .and.(from_degree>to_degree)) then + if(present(stat)) then + stat = REMAP_ERR_HIGHER_LOWER_CONTINUOUS + else + ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." + FLAbort("Trying to remap from higher order to lower order continuous field") + end if + end if + + if((.not.(from_continuity<0)).and.(.not.(to_continuity<0))& + .and.(.not.from_periodic).and.(to_periodic)) then + if(present(stat)) then + stat = REMAP_ERR_UNPERIODIC_PERIODIC + else + ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." + FLAbort("Trying to remap from an unperiodic to a periodic continuous field") + end if + end if + + if((from_type==ELEMENT_BUBBLE).and.& + (to_type==ELEMENT_LAGRANGIAN)) then + if(present(stat)) then + stat = REMAP_ERR_BUBBLE_LAGRANGE + else + ewrite(-1,*) "Remapping from field "//trim(from_name)//" to field "//trim(to_name)//"." + FLAbort("Trying to remap from a bubble to a lagrange field") + end if + end if + + end subroutine test_remap_validity_generic + + subroutine remap_scalar_field(from_field, to_field, stat) + !!< Remap the components of from_field onto the locations of to_field. + !!< This is used to change the element type of a field. + !!< + !!< This will not validly map a discontinuous field to a continuous + !!< field. + type(scalar_field), intent(in) :: from_field + type(scalar_field), intent(inout) :: to_field + integer, intent(out), optional :: stat + + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: locweight + + integer :: toloc, ele + integer, dimension(:), pointer :: from_ele, to_ele + + if(present(stat)) stat = 0 + + if(from_field%mesh==to_field%mesh) then + + call set(to_field, from_field) + + else + + select case(from_field%field_type) + case(FIELD_TYPE_NORMAL) + + call test_remap_validity(from_field, to_field, stat=stat) + + ! First construct remapping weights. + do toloc=1,size(locweight,1) + locweight(toloc,:)=eval_shape(from_field%mesh%shape, & + local_coords(toloc, to_field%mesh%shape)) + end do + + ! Now loop over the elements. + do ele=1,element_count(from_field) + from_ele=>ele_nodes(from_field, ele) + to_ele=>ele_nodes(to_field, ele) + + to_field%val(to_ele)=matmul(locweight,from_field%val(from_ele)) + + end do + + case(FIELD_TYPE_CONSTANT) + to_field%val = from_field%val(1) + end select + + end if + + end subroutine remap_scalar_field + + subroutine remap_scalar_field_specific(from_field, to_field, elements, output, locweight, stat) + !!< Remap the components of from_field onto the locations of to_field. + !!< This is used to change the element type of a field. + !!< + !!< This will not validly map a discontinuous field to a continuous + !!< field. + !!< This only does certain elements, and can optionally take in a precomputed locweight. + + type(scalar_field), intent(in) :: from_field + type(scalar_field), intent(inout) :: to_field + integer, dimension(:), intent(in) :: elements + real, dimension(size(elements), to_field%mesh%shape%loc), intent(out) :: output + integer, intent(out), optional:: stat + + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc), optional :: locweight + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: llocweight + + integer :: toloc, ele, i + + if(present(stat)) stat = 0 + + if (from_field%field_type == FIELD_TYPE_CONSTANT) then + output = from_field%val(1) + return + end if + + call test_remap_validity(from_field, to_field, stat=stat) + + if (.not. present(locweight)) then + ! First construct remapping weights. + do toloc=1,size(llocweight,1) + llocweight(toloc,:)=eval_shape(from_field%mesh%shape, & + local_coords(toloc, to_field%mesh%shape)) + end do + else + llocweight = locweight + end if + + ! Now loop over the elements. + do i=1,size(elements) + ele = elements(i) + output(i, :)=matmul(llocweight,ele_val(from_field, ele)) + end do + end subroutine remap_scalar_field_specific + + subroutine remap_vector_field(from_field, to_field, stat) + !!< Remap the components of from_field onto the locations of to_field. + !!< This is used to change the element type of a field. + !!< + !!< The result will only be valid if to_field is DG. + type(vector_field), intent(in) :: from_field + type(vector_field), intent(inout) :: to_field + integer, intent(out), optional :: stat + + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: locweight + + integer :: toloc, ele, i + integer, dimension(:), pointer :: from_ele, to_ele + + if(present(stat)) stat = 0 + + assert(to_field%dim>=from_field%dim) + + if (mesh_dim(from_field)/=mesh_dim(to_field)) then + ewrite (0,*)"Remapping "//trim(from_field%name)//" to "& + &//trim(to_field%name) + ewrite (0,'(a,i0)')"Mesh dimension of "//trim(from_field%name)//& + " is ", mesh_dim(from_field) + ewrite (0,'(a,i0)')"Mesh dimension of "//trim(to_field%name)//& + " is ", mesh_dim(to_field) + FLExit("Mesh dimensions inconsistent") + end if + + if(from_field%mesh==to_field%mesh) then + + call set(to_field, from_field) + + else + + select case(from_field%field_type) + case(FIELD_TYPE_NORMAL) + + call test_remap_validity(from_field, to_field, stat=stat) + + ! First construct remapping weights. + do toloc=1,size(locweight,1) + locweight(toloc,:)=eval_shape(from_field%mesh%shape, & + local_coords(toloc, to_field%mesh%shape)) + end do + + ! Now loop over the elements. + do ele=1,element_count(from_field) + from_ele=>ele_nodes(from_field, ele) + to_ele=>ele_nodes(to_field, ele) + + do i=1,from_field%dim + to_field%val(i,to_ele)= & + matmul(locweight,from_field%val(i,from_ele)) + end do + + end do + + case(FIELD_TYPE_CONSTANT) + do i=1,from_field%dim + to_field%val(i,:) = from_field%val(i,1) + end do + case default + FLAbort("Wrong field_type for remap_field") + end select + + end if + + ! Zero any left-over dimensions + do i=from_field%dim+1,to_field%dim + to_field%val(i,:)=0.0 + end do + + end subroutine remap_vector_field + + subroutine remap_vector_field_specific(from_field, to_field, elements, output, locweight, stat) + !!< Remap the components of from_field onto the locations of to_field. + !!< This is used to change the element type of a field. + !!< + !!< The result will only be valid if to_field is DG. + type(vector_field), intent(in) :: from_field + type(vector_field), intent(inout) :: to_field + integer, dimension(:), intent(in) :: elements + real, dimension(size(elements), to_field%dim, to_field%mesh%shape%loc), intent(out) :: output + integer, intent(out), optional:: stat + + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc), optional :: locweight + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: llocweight + + integer :: toloc, ele, i, j + + if(present(stat)) stat = 0 + + assert(to_field%dim>=from_field%dim) + + output = 0.0 + + select case(from_field%field_type) + case(FIELD_TYPE_CONSTANT) + do i=1,from_field%dim + output(:, i, :) = from_field%val(i,1) + end do + return + case default + FLAbort("Wrong field_type for remap_field") + end select + + call test_remap_validity(from_field, to_field, stat=stat) + + if (.not. present(locweight)) then + ! First construct remapping weights. + do toloc=1,size(llocweight,1) + llocweight(toloc,:)=eval_shape(from_field%mesh%shape, & + local_coords(toloc, to_field%mesh%shape)) + end do + else + llocweight = locweight + end if + + ! Now loop over the elements. + do j=1,size(elements) + ele = elements(j) + do i=1,from_field%dim + output(j, i, :) = matmul(llocweight,ele_val(from_field, i, ele)) + end do + end do + end subroutine remap_vector_field_specific + + subroutine remap_tensor_field(from_field, to_field, stat) + !!< Remap the components of from_field onto the locations of to_field. + !!< This is used to change the element type of a field. + !!< + !!< The result will only be valid if to_field is DG. + type(tensor_field), intent(in) :: from_field + type(tensor_field), intent(inout) :: to_field + integer, intent(inout), optional :: stat + + real, dimension(to_field%mesh%shape%loc, from_field%mesh%shape%loc) :: locweight + + integer :: toloc, ele, i, j + integer, dimension(:), pointer :: from_ele, to_ele + + if(present(stat)) stat = 0 + + assert(all(to_field%dim>=from_field%dim)) + + if(from_field%mesh==to_field%mesh) then + + call set(to_field, from_field) + + else + + select case(from_field%field_type) + case(FIELD_TYPE_NORMAL) + + call test_remap_validity(from_field, to_field, stat=stat) + + ! First construct remapping weights. + do toloc=1,size(locweight,1) + locweight(toloc,:)=eval_shape(from_field%mesh%shape, & + local_coords(toloc, to_field%mesh%shape)) + end do + + ! Now loop over the elements. + do ele=1,element_count(from_field) + from_ele=>ele_nodes(from_field, ele) + to_ele=>ele_nodes(to_field, ele) + + do i=1,from_field%dim(1) + do j=1,from_field%dim(2) + to_field%val(i, j, to_ele) = matmul(locweight, from_field%val(i, j, from_ele)) + end do + end do + + end do + case(FIELD_TYPE_CONSTANT) + do i=1,size(to_field%val, 3) + to_field%val(:, :, i) = from_field%val(:, :, 1) + end do + end select + + end if + + end subroutine remap_tensor_field + + subroutine remap_scalar_field_to_surface(from_field, to_field, surface_element_list, stat) + !!< Remap the values of from_field onto the surface_field to_field, which is defined + !!< on the faces given by surface_element_list. + !!< This also deals with remapping between different orders. + type(scalar_field), intent(in):: from_field + type(scalar_field), intent(inout):: to_field + integer, dimension(:), intent(in):: surface_element_list + integer, intent(out), optional:: stat + + real, dimension(ele_loc(to_field,1), face_loc(from_field,1)) :: locweight + type(element_type), pointer:: from_shape, to_shape + real, dimension(face_loc(from_field,1)) :: from_val + integer, dimension(:), pointer :: to_nodes + integer toloc, ele, face + + if (present(stat)) stat = 0 + + select case(from_field%field_type) + case(FIELD_TYPE_NORMAL) + + call test_remap_validity(from_field, to_field, stat=stat) + + ! the remapping happens from a face of from_field which is at the same + ! time an element of to_field + from_shape => face_shape(from_field, 1) + to_shape => ele_shape(to_field, 1) + ! First construct remapping weights. + do toloc=1,size(locweight,1) + locweight(toloc,:)=eval_shape(from_shape, & + local_coords(toloc, to_shape)) + end do + + ! Now loop over the surface elements. + do ele=1, size(surface_element_list) + ! element ele is a face in the mesh of from_field: + face=surface_element_list(ele) + + to_nodes => ele_nodes(to_field, ele) + + from_val = face_val(from_field, face) + + to_field%val(to_nodes)=matmul(locweight,from_val) + + end do + + case(FIELD_TYPE_CONSTANT) + + to_field%val = from_field%val(1) + + end select + + end subroutine remap_scalar_field_to_surface + + subroutine remap_vector_field_to_surface(from_field, to_field, surface_element_list, stat) + !!< Remap the values of from_field onto the surface_field to_field, which is defined + !!< on the faces given by surface_element_list. + !!< This also deals with remapping between different orders. + type(vector_field), intent(in):: from_field + type(vector_field), intent(inout):: to_field + integer, dimension(:), intent(in):: surface_element_list + integer, intent(out), optional:: stat + + real, dimension(ele_loc(to_field,1), face_loc(from_field,1)) :: locweight + type(element_type), pointer:: from_shape, to_shape + real, dimension(from_field%dim, face_loc(from_field,1)) :: from_val + integer, dimension(:), pointer :: to_nodes + integer toloc, ele, face, i + + if(present(stat)) stat = 0 + + assert(to_field%dim>=from_field%dim) + + select case(from_field%field_type) + case(FIELD_TYPE_NORMAL) + + call test_remap_validity(from_field, to_field, stat=stat) + + ! the remapping happens from a face of from_field which is at the same + ! time an element of to_field + from_shape => face_shape(from_field, 1) + to_shape => ele_shape(to_field, 1) + ! First construct remapping weights. + do toloc=1,size(locweight,1) + locweight(toloc,:)=eval_shape(from_shape, & + local_coords(toloc, to_shape)) + end do + + ! Now loop over the surface elements. + do ele=1, size(surface_element_list) + ! element ele is a face in the mesh of from_field: + face=surface_element_list(ele) + + to_nodes => ele_nodes(to_field, ele) + + from_val = face_val(from_field, face) + + do i=1, to_field%dim + to_field%val(i,to_nodes)=matmul(locweight,from_val(i, :)) + end do + + end do + + case(FIELD_TYPE_CONSTANT) + do i=1, from_field%dim + to_field%val(i,:) = from_field%val(i,1) + end do + case default + FLAbort("Unknown field type in remap_field_to_surface") + end select + + ! Zero any left-over dimensions + do ele=from_field%dim+1, to_field%dim + to_field%val(i,:)=0.0 + end do + + end subroutine remap_vector_field_to_surface + + subroutine remap_tensor_field_to_surface(from_field, to_field, surface_element_list, stat) + !!< Remap the values of from_field onto the surface_field to_field, which is defined + !!< on the faces given by surface_element_list. + !!< This also deals with remapping between different orders. + type(tensor_field), intent(in):: from_field + type(tensor_field), intent(inout):: to_field + integer, dimension(:), intent(in):: surface_element_list + integer, intent(out), optional:: stat + + real, dimension(ele_loc(to_field,1), face_loc(from_field,1)) :: locweight + type(element_type), pointer:: from_shape, to_shape + real, dimension(from_field%dim(1), from_field%dim(2), face_loc(from_field,1)) :: from_val + integer, dimension(:), pointer :: to_nodes + integer toloc, ele, face, i, j + + if(present(stat)) stat = 0 + + assert(to_field%dim(1)>=from_field%dim(1)) + assert(to_field%dim(2)>=from_field%dim(2)) + + select case(from_field%field_type) + case(FIELD_TYPE_NORMAL) + + call test_remap_validity(from_field, to_field, stat=stat) + + ! the remapping happens from a face of from_field which is at the same + ! time an element of to_field + from_shape => face_shape(from_field, 1) + to_shape => ele_shape(to_field, 1) + ! First construct remapping weights. + do toloc=1,size(locweight,1) + locweight(toloc,:)=eval_shape(from_shape, & + local_coords(toloc, to_shape)) + end do + + ! Now loop over the surface elements. + do ele=1, size(surface_element_list) + ! element ele is a face in the mesh of from_field: + face=surface_element_list(ele) + + to_nodes => ele_nodes(to_field, ele) + + from_val = face_val(from_field, face) + + do i=1, to_field%dim(1) + do j=1, to_field%dim(2) + to_field%val(i,j,to_nodes)=matmul(locweight,from_val(i,j,:)) + end do + end do + + end do + + case(FIELD_TYPE_CONSTANT) + do i=1, from_field%dim(1) + do j=1, from_field%dim(2) + to_field%val(i,j,:) = from_field%val(i,j,1) + end do + end do + end select + + ! Zero any left-over dimensions + do i=from_field%dim(1)+1, to_field%dim(1) + do j=1, to_field%dim(2) + to_field%val(i,j,:)=0.0 + end do + end do + do j=from_field%dim(2)+1, to_field%dim(2) + do i=1, to_field%dim(1) + to_field%val(i,j,:)=0.0 + end do + end do + + end subroutine remap_tensor_field_to_surface + + function piecewise_constant_mesh(in_mesh, name) result(new_mesh) + !!< From a given mesh, return a scalar field + !!< allocated on the mesh that's topologically the same + !!< but has piecewise constant basis functions. + !!< This is for the definition of elementwise quantities. + type(mesh_type), intent(in) :: in_mesh + type(mesh_type) :: new_mesh + type(element_type) :: shape, old_shape + character(len=*), intent(in) :: name + + old_shape = in_mesh%shape + + shape = make_element_shape(vertices=old_shape%numbering%vertices, dim=old_shape%dim, degree=0, quad=old_shape%quadrature) + new_mesh = make_mesh(model=in_mesh, shape=shape, continuity=-1) + new_mesh%name=name + call deallocate(shape) + + end function piecewise_constant_mesh + + function piecewise_constant_field(in_mesh, name) result(field) + !!< From a given mesh, return a scalar field + !!< allocated on the mesh that's topologically the same + !!< but has piecewise constant basis functions. + !!< This is for the definition of elementwise quantities. + type(mesh_type), intent(in) :: in_mesh + type(mesh_type) :: new_mesh + type(element_type) :: shape, old_shape + type(scalar_field) :: field + character(len=*), intent(in) :: name + + old_shape = in_mesh%shape + + shape = make_element_shape(vertices=old_shape%loc, dim=old_shape%dim, degree=0, quad=old_shape%quadrature) + new_mesh = make_mesh(model=in_mesh, shape=shape, continuity=-1) + call allocate(field, new_mesh, name) + call zero(field) + call deallocate(shape) + call deallocate(new_mesh) + + end function piecewise_constant_field + + subroutine scalar_scale(field, factor) + !!< Multiply scalar field with factor + type(scalar_field), intent(inout) :: field + real, intent(in) :: factor + + assert(field%field_type/=FIELD_TYPE_PYTHON) + + field%val = field%val * factor + + end subroutine scalar_scale + + subroutine vector_scale(field, factor, dim) + !!< Multiply vector field with factor + type(vector_field), intent(inout) :: field + real, intent(in) :: factor + integer, intent(in), optional :: dim + + integer :: i + + assert(field%field_type/=FIELD_TYPE_PYTHON) + + if (present(dim)) then + field%val(dim,:) = field%val(dim,:) * factor + else + do i=1,field%dim + field%val(i,:) = field%val(i,:) * factor + end do + end if + + end subroutine vector_scale + + subroutine tensor_scale(field, factor) + !!< Multiply tensor field with factor + type(tensor_field), intent(inout) :: field + real, intent(in) :: factor + + assert(field%field_type/=FIELD_TYPE_PYTHON) + + field%val = field%val * factor + + end subroutine tensor_scale + + subroutine scalar_scale_scalar_field(field, sfield) + !!< Multiply scalar field with sfield. This will only work if the + !!< fields have the same mesh. + !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points + !!< will not be as accurate as multiplying the fields at each gauss point seperately + !!< and then summing over these. + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: sfield + + assert(field%mesh%refcount%id==sfield%mesh%refcount%id) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) + + select case (sfield%field_type) + case (FIELD_TYPE_NORMAL) + field%val = field%val * sfield%val + case (FIELD_TYPE_CONSTANT) + field%val = field%val * sfield%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in scale()") + end select + + end subroutine scalar_scale_scalar_field + + subroutine vector_scale_scalar_field(field, sfield) + !!< Multiply vector field with scalar field. This will only work if the + !!< fields have the same mesh. + !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points + !!< will not be as accurate as multiplying the fields at each gauss point seperately + !!< and then summing over these. + type(vector_field), intent(inout) :: field + type(scalar_field), intent(in) :: sfield + + integer :: i + + assert(field%mesh%refcount%id==sfield%mesh%refcount%id) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) + + select case (sfield%field_type) + case (FIELD_TYPE_NORMAL) + do i=1,field%dim + field%val(i,:) = field%val(i,:) * sfield%val + end do + case (FIELD_TYPE_CONSTANT) + do i=1,field%dim + field%val(i,:) = field%val(i,:) * sfield%val(1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in scale()") + end select + + end subroutine vector_scale_scalar_field + + subroutine tensor_scale_scalar_field(field, sfield) + !!< Multiply tensor field with scalar field. This will only work if the + !!< fields have the same mesh. + !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points + !!< will not be as accurate as multiplying the fields at each gauss point seperately + !!< and then summing over these. + type(tensor_field), intent(inout) :: field + type(scalar_field), intent(in) :: sfield + + integer :: i, j + + assert(field%mesh%refcount%id==sfield%mesh%refcount%id) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) + + select case (sfield%field_type) + case (FIELD_TYPE_NORMAL) + do i=1,field%dim(1) + do j=1,field%dim(2) + field%val(i,j,:) = field%val(i,j,:) * sfield%val + end do + end do + case (FIELD_TYPE_CONSTANT) + field%val(:,:,:) = field%val(:,:,:) * sfield%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in scale()") + end select + + end subroutine tensor_scale_scalar_field + + subroutine vector_scale_vector_field(field, vfield) + !!< Multiply vector field with vector field. This will only work if the + !!< fields have the same mesh. + !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points + !!< will not be as accurate as multiplying the fields at each gauss point seperately + !!< and then summing over these. + type(vector_field), intent(inout) :: field + type(vector_field), intent(in) :: vfield + + integer :: i + + assert(field%mesh%refcount%id==vfield%mesh%refcount%id) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. vfield%field_type==FIELD_TYPE_CONSTANT) + + select case (vfield%field_type) + case (FIELD_TYPE_NORMAL) + do i=1,field%dim + field%val(i,:) = field%val(i,:) * vfield%val(i,:) + end do + case (FIELD_TYPE_CONSTANT) + do i=1,field%dim + field%val(i,:) = field%val(i,:) * vfield%val(i,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in scale()") + end select + + end subroutine vector_scale_vector_field + + subroutine tensor_scale_tensor_field(field, tfield) + !!< Multiply tensor field with tensor field. This will only work if the + !!< fields have the same mesh. + !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points + !!< will not be as accurate as multiplying the fields at each gauss point seperately + !!< and then summing over these. + type(tensor_field), intent(inout) :: field + type(tensor_field), intent(in) :: tfield + + integer :: i,j + + assert(field%mesh%refcount%id==tfield%mesh%refcount%id) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. tfield%field_type==FIELD_TYPE_CONSTANT) + + select case (tfield%field_type) + case (FIELD_TYPE_NORMAL) + do i=1,field%dim(1) + do j=1,field%dim(2) + field%val(i,j,:) = field%val(i,j,:) * tfield%val(i,j,:) + end do + end do + case (FIELD_TYPE_CONSTANT) + do i=1,field%dim(1) + do j=1,field%dim(2) + field%val(i,j,:) = field%val(i,j,:) * tfield%val(i,j,1) + end do + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in scale()") + end select + + end subroutine tensor_scale_tensor_field + + subroutine scalar_power(field, power) + !!< Raise scalar field to power + type(scalar_field), intent(inout) :: field + real, intent(in) :: power + + assert(field%field_type/=FIELD_TYPE_PYTHON) + + field%val = field%val ** power + + end subroutine scalar_power + + subroutine vector_power(field, power, dim) + !!< Raise vector field to power + type(vector_field), intent(inout) :: field + real, intent(in) :: power + integer, intent(in), optional :: dim + + assert(field%field_type/=FIELD_TYPE_PYTHON) + + if (present(dim)) then + field%val(dim,:) = field%val(dim,:) ** power + else + field%val = field%val ** power + end if + + end subroutine vector_power + + subroutine tensor_power(field, power) + !!< Raise tensor field to power + type(tensor_field), intent(inout) :: field + real, intent(in) :: power + + assert(field%field_type/=FIELD_TYPE_PYTHON) + + field%val = field%val ** power + + end subroutine tensor_power + + subroutine scalar_power_scalar_field(field, sfield) + !!< Raise scalar field to power based on sfield + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: sfield + + assert(field%mesh==sfield%mesh) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) + + select case (sfield%field_type) + case (FIELD_TYPE_NORMAL) + field%val = field%val ** sfield%val + case (FIELD_TYPE_CONSTANT) + field%val = field%val ** sfield%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in power()") + end select + + end subroutine scalar_power_scalar_field + + subroutine vector_power_scalar_field(field, sfield) + !!< Raise vector field to power based on sfield + type(vector_field), intent(inout) :: field + type(scalar_field), intent(in) :: sfield + + integer :: i + + assert(field%mesh==sfield%mesh) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) + + select case (sfield%field_type) + case (FIELD_TYPE_NORMAL) + do i=1,field%dim + field%val(i,:) = field%val(i,:) ** sfield%val + end do + case (FIELD_TYPE_CONSTANT) + do i=1,field%dim + field%val(i,:) = field%val(i,:) ** sfield%val(1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in power()") + end select + + end subroutine vector_power_scalar_field + + subroutine tensor_power_scalar_field(field, sfield) + !!< Raise tensor field to power based on sfield + type(tensor_field), intent(inout) :: field + type(scalar_field), intent(in) :: sfield + + integer :: i, j + + assert(field%mesh==sfield%mesh) + assert(field%field_type/=FIELD_TYPE_PYTHON) + assert(field%field_type==FIELD_TYPE_NORMAL .or. sfield%field_type==FIELD_TYPE_CONSTANT) + + select case (sfield%field_type) + case (FIELD_TYPE_NORMAL) + do i=1,field%dim(1) + do j=1,field%dim(2) + field%val(i,j,:) = field%val(i,j,:) ** sfield%val + end do + end do + case (FIELD_TYPE_CONSTANT) + field%val(:,:,:) = field%val(:,:,:) ** sfield%val(1) + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in power()") + end select + + end subroutine tensor_power_scalar_field + + subroutine bound_scalar_field(field, lower_bound, upper_bound) + !!< Bound a field by the lower and upper bounds supplied + type(scalar_field), intent(inout) :: field + real, intent(in) :: lower_bound, upper_bound + + integer :: i + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, node_count(field) + field%val(i) = min(max(field%val(i), lower_bound), upper_bound) + end do + case(FIELD_TYPE_CONSTANT) + field%val(1) = min(max(field%val(1), lower_bound), upper_bound) + case default + FLAbort("Illegal field type in bound()") + end select + + end subroutine bound_scalar_field + + subroutine bound_scalar_field_field(field, lower_bound, upper_bound) + !!< Bound a field by the lower and upper bounds supplied + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in), optional :: lower_bound, upper_bound + + integer :: i + + if(present(lower_bound)) then + assert(field%mesh==lower_bound%mesh) + assert(lower_bound%field_type==FIELD_TYPE_NORMAL) ! The case lower_bound=FIELD_TYPE_CONSTANT should be implemented + end if + if(present(upper_bound)) then + assert(field%mesh==upper_bound%mesh) + assert(upper_bound%field_type==FIELD_TYPE_NORMAL) ! The case upper_bound=FIELD_TYPE_CONSTANT should be implemented + end if + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + if (present(lower_bound)) then + do i = 1, node_count(field) + field%val(i) = max(field%val(i), lower_bound%val(i)) + end do + end if + if (present(upper_bound)) then + do i = 1, node_count(field) + field%val(i) = min(field%val(i), upper_bound%val(i)) + end do + end if + case default + FLAbort("Illegal field type in bound()") + end select + + end subroutine bound_scalar_field_field + + + subroutine bound_vector_field(field, lower_bound, upper_bound) + !!< Bound a field by the lower and upper bounds supplied + type(vector_field), intent(inout) :: field + real, intent(in) :: lower_bound, upper_bound + + integer :: i, j + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, field%dim + do j = 1, node_count(field) + field%val(i,j) = min(max(field%val(i,j), lower_bound), upper_bound) + end do + end do + case(FIELD_TYPE_CONSTANT) + do i = 1, field%dim + field%val(i,1) = min(max(field%val(i,1), lower_bound), upper_bound) + end do + case default + FLAbort("Illegal field type in bound()") + end select + + end subroutine bound_vector_field + + subroutine bound_tensor_field(field, lower_bound, upper_bound) + !!< Bound a field by the lower and upper bounds supplied + type(tensor_field), intent(inout) :: field + real, intent(in) :: lower_bound, upper_bound + + integer :: i, j, k + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, field%dim(1) + do j = 1, field%dim(2) + do k = 1, node_count(field) + field%val(i, j, k) = min(max(field%val(i, j, k), lower_bound), upper_bound) + end do + end do + end do + case(FIELD_TYPE_CONSTANT) + do i = 1, field%dim(1) + do j = 1, field%dim(2) + field%val(i, j, 1) = min(max(field%val(i, j, 1), lower_bound), upper_bound) + end do + end do + case default + FLAbort("Illegal field type in bound()") + end select + + end subroutine bound_tensor_field + + subroutine normalise_scalar(field) + type(scalar_field), intent(inout) :: field + + integer :: i + real :: tolerance + + tolerance = tiny(0.0) + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, node_count(field) + call set(field, i, node_val(field, i)/(max(tolerance, abs(node_val(field, i))))) + end do + case(FIELD_TYPE_CONSTANT) + field%val(1) = field%val(1)/(max(tolerance, abs(node_val(field, 1)))) + case default + FLAbort("Illegal field type in normalise()") + end select + + end subroutine normalise_scalar + + subroutine normalise_vector(field) + type(vector_field), intent(inout) :: field + + integer :: i + real :: tolerance + + tolerance = tiny(0.0) + + select case(field%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, node_count(field) + call set(field, i, node_val(field, i)/(max(tolerance, norm2(node_val(field, i))))) + end do + case(FIELD_TYPE_CONSTANT) + call set(field, 1, node_val(field, 1)/(max(tolerance, norm2(node_val(field, 1))))) + case default + FLAbort("Illegal field type in normalise()") + end select + + end subroutine normalise_vector + + subroutine invert_scalar_field_inplace(field, tolerance) + !!< Computes 1/field for a scalar field + type(scalar_field), intent(inout):: field + real, intent(in), optional :: tolerance + + call invert_scalar_field(field, field, tolerance) + + end subroutine invert_scalar_field_inplace + + subroutine invert_scalar_field(in_field, out_field, tolerance) + !!< Computes 1/field for a scalar field + type(scalar_field), intent(in):: in_field + type(scalar_field), intent(inout):: out_field + real, intent(in), optional :: tolerance + + integer :: i + + assert(out_field%field_type==FIELD_TYPE_NORMAL .or. out_field%field_type==FIELD_TYPE_CONSTANT) + assert(out_field%mesh==in_field%mesh) + if (in_field%field_type==out_field%field_type) then + if(present(tolerance)) then + do i = 1, size(out_field%val) + out_field%val(i) = 1/sign(max(tolerance, abs(in_field%val(i))), in_field%val(i)) + end do + else + out_field%val=1/in_field%val + end if + else if (in_field%field_type==FIELD_TYPE_CONSTANT) then + if(present(tolerance)) then + out_field%val = 1/sign(max(tolerance, abs(in_field%val(1))), in_field%val(1)) + else + out_field%val=1/in_field%val(1) + end if + else + FLAbort("Calling invert_scalar_field with wrong field type") + end if + + end subroutine invert_scalar_field + + subroutine invert_vector_field_inplace(field, tolerance) + !!< Computes 1/field for a vector field + type(vector_field), intent(inout):: field + real, intent(in), optional :: tolerance + + call invert_vector_field(field, field, tolerance) + + end subroutine invert_vector_field_inplace + + subroutine invert_vector_field(in_field, out_field, tolerance) + !!< Computes 1/field for a vector field + type(vector_field), intent(in):: in_field + type(vector_field), intent(inout):: out_field + real, intent(in), optional :: tolerance + + integer :: i, j + + assert(out_field%field_type==FIELD_TYPE_NORMAL .or. out_field%field_type==FIELD_TYPE_CONSTANT) + assert(in_field%dim==in_field%dim) + do i = 1, out_field%dim + if (in_field%field_type==out_field%field_type) then + if(present(tolerance)) then + do j = 1, size(out_field%val(i,:)) + out_field%val(i,j) = 1/sign(max(tolerance, abs(in_field%val(i,j))), in_field%val(i,j)) + end do + else + out_field%val(i,:)=1/in_field%val(i,:) + end if + else if (in_field%field_type==FIELD_TYPE_CONSTANT) then + if(present(tolerance)) then + out_field%val(i,:)=1/sign(max(tolerance, abs(in_field%val(i,1))), in_field%val(i,1)) + else + out_field%val(i,:)=1/in_field%val(i,1) + end if + else + FLAbort("Calling invert_vector_field with wrong field type") + end if + end do + + end subroutine invert_vector_field + + subroutine invert_tensor_field_inplace(field, tolerance) + !!< Computes 1/field for a tensor field + type(tensor_field), intent(inout):: field + real, intent(in), optional :: tolerance + + call invert_tensor_field(field, field, tolerance) + + end subroutine invert_tensor_field_inplace + + subroutine invert_tensor_field(in_field, out_field, tolerance) + !!< Computes 1/field for a tensor field + type(tensor_field), intent(in):: in_field + type(tensor_field), intent(inout):: out_field + real, intent(in), optional :: tolerance + + integer :: i, j, k + + assert(out_field%field_type==FIELD_TYPE_NORMAL .or. out_field%field_type==FIELD_TYPE_CONSTANT) + assert(in_field%dim(1)==in_field%dim(1)) + assert(in_field%dim(2)==in_field%dim(2)) + do i = 1, out_field%dim(1) + do j = 1, out_field%dim(2) + if (in_field%field_type==out_field%field_type) then + if(present(tolerance)) then + do k = 1, size(out_field%val(i,j,:)) + out_field%val(i,j,k) = 1/sign(max(tolerance, abs(in_field%val(i,j,k))), in_field%val(i,j,k)) + end do + else + out_field%val(i,j,:)=1/in_field%val(i,j,:) + end if + else if (in_field%field_type==FIELD_TYPE_CONSTANT) then + if(present(tolerance)) then + out_field%val(i,j,:)=1/sign(max(tolerance, abs(in_field%val(i,j,1))), in_field%val(i,j,1)) + else + out_field%val(i,j,:)=1/in_field%val(i,j,1) + end if + else + FLAbort("Calling invert_vector_field with wrong field type") + end if + end do + end do + + end subroutine invert_tensor_field + + subroutine absolute_value_scalar_field(field) + !!< Computes abs(field) for a scalar field + type(scalar_field), intent(inout) :: field + + field%val = abs(field%val) + + end subroutine absolute_value_scalar_field + + subroutine cross_product_vector(a, b, c) + !!< Computes the node-wise outer product a=b x c + !!< NOTE that the integral of the resulting field by a weighted sum over its values in gauss points + !!< will not be as accurate as multiplying the fields at each gauss point seperately + !!< and then summing over these. + type(vector_field), intent(inout) :: a + type(vector_field), intent(in) :: b, c + + type(vector_field) tmp_b, tmp_c + integer, dimension(3), parameter:: perm1=(/ 2,3,1 /), perm2=(/ 3,1,2 /) + integer i + + assert(a%field_type/=FIELD_TYPE_PYTHON) + assert(a%field_type==FIELD_TYPE_NORMAL .or. b%field_type==FIELD_TYPE_CONSTANT) + assert(a%field_type==FIELD_TYPE_NORMAL .or. c%field_type==FIELD_TYPE_CONSTANT) + assert(a%dim==b%dim) + assert(a%dim==c%dim) + + if (a%mesh==c%mesh .and. c%field_type/=FIELD_TYPE_CONSTANT) then + tmp_c=c + else + call allocate(tmp_c, c%dim, a%mesh, name='cross_product_vector_tmp_c') + call remap_field(c, tmp_c) + end if + + select case (b%field_type) + case (FIELD_TYPE_NORMAL) + + if (a%mesh==b%mesh) then + tmp_b=b + else + call allocate(tmp_b, b%dim, a%mesh, name='cross_product_vector_tmp_b') + call remap_field(b, tmp_b) + end if + + select case (c%field_type) + case (FIELD_TYPE_NORMAL) + do i=1, a%dim + a%val(i,:)=tmp_b%val( perm1(i),: ) * tmp_c%val( perm2(i),: )- & + tmp_b%val( perm2(i),: ) * tmp_c%val( perm1(i),: ) + end do + case (FIELD_TYPE_CONSTANT) + do i=1, a%dim + a%val(i,:)=tmp_b%val( perm1(i),: ) * tmp_c%val( perm2(i),1 )- & + tmp_b%val( perm2(i),: ) * tmp_c%val( perm1(i),1 ) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in cross_product()") + end select + + if (.not. a%mesh==b%mesh) then + call deallocate(tmp_b) + end if + + case (FIELD_TYPE_CONSTANT) + + select case (c%field_type) + case (FIELD_TYPE_NORMAL) + do i=1, a%dim + a%val(i,:)=b%val( perm1(i),1 ) * tmp_c%val( perm2(i),: )- & + b%val( perm2(i),1 ) * tmp_c%val( perm1(i),: ) + end do + case (FIELD_TYPE_CONSTANT) + do i=1, a%dim + a%val(i,:)=b%val( perm1(i),1 ) * tmp_c%val( perm2(i),1 )- & + b%val( perm2(i),1 ) * tmp_c%val( perm1(i),1 ) + end do + case default + ! someone could implement b type python + FLAbort("Illegal in_field field type in cross_product()") + end select - integer :: i, j, nhalos, nonods - integer, dimension(:), allocatable :: inverse_permutation, receive_node, & + case default + + ! someone could implement c field type python + FLAbort("Illegal in_field field type in cross_product()") + + end select + + if (.not. a%mesh==c%mesh .or. c%field_type==FIELD_TYPE_CONSTANT) then + call deallocate(tmp_c) + end if + + end subroutine cross_product_vector + + subroutine inner_product_field_field(a, b, c) + !!< Computes the node-wise inner/dot product a=b . c + !!< This version takes two scalar fields. NOTE that if a and b and c + !!< have the same polynomial degree you will loose accuracy. In many + !!< cases you have to calculate this at the gauss points instead. + type(scalar_field), intent(inout) :: a + type(vector_field), intent(in) :: b,c + + type(vector_field) tmp_b, tmp_c + integer i + + assert(a%field_type/=FIELD_TYPE_PYTHON) + assert(a%field_type==FIELD_TYPE_NORMAL .or. b%field_type==FIELD_TYPE_CONSTANT) + assert(a%field_type==FIELD_TYPE_NORMAL .or. c%field_type==FIELD_TYPE_CONSTANT) + assert(b%dim==c%dim) + + if (a%mesh==c%mesh .and. c%field_type/=FIELD_TYPE_CONSTANT) then + tmp_c=c + else + call allocate(tmp_c, c%dim, a%mesh, name='inner_product_vector_tmp_c') + call remap_field(c, tmp_c) + end if + + select case (b%field_type) + case (FIELD_TYPE_NORMAL) + + if (a%mesh==b%mesh) then + tmp_b=b + else + call allocate(tmp_b, b%dim, a%mesh, name='cross_product_vector_tmp_b') + call remap_field(b, tmp_b) + end if + + select case (c%field_type) + case (FIELD_TYPE_NORMAL) + a%val=tmp_b%val(1,:)*tmp_c%val(1,:) + do i=2, c%dim + a%val=a%val+tmp_b%val(i,:)*tmp_c%val(i,:) + end do + case (FIELD_TYPE_CONSTANT) + a%val=tmp_b%val(1,:)*c%val(1,1) + do i=2, c%dim + a%val=a%val+tmp_b%val(i,:)*c%val(i,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in inner_product()") + end select + + case (FIELD_TYPE_CONSTANT) + + select case (c%field_type) + case (FIELD_TYPE_NORMAL) + a%val=b%val(1,1)*tmp_c%val(1,:) + do i=2, c%dim + a%val=a%val+b%val(i,1)*tmp_c%val(i,:) + end do + case (FIELD_TYPE_CONSTANT) + a%val=b%val(1,1)*c%val(1,1) + do i=2, c%dim + a%val=a%val+b%val(i,1)*c%val(i,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in inner_product()") + end select + + case default + + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in inner_product()") + + end select + + if (.not. c%mesh==tmp_c%mesh) then + call deallocate(tmp_c) + end if + + end subroutine inner_product_field_field + + subroutine inner_product_array_field(a, b, c) + !!< Computes the node-wise inner/dot product a=b . c + type(scalar_field), intent(inout) :: a + real, dimension(:), intent(in) :: b + type(vector_field), intent(in) :: c + + integer i + + assert(a%mesh%refcount%id==c%mesh%refcount%id) + assert(a%field_type/=FIELD_TYPE_PYTHON) + assert(a%field_type==FIELD_TYPE_NORMAL .or. c%field_type==FIELD_TYPE_CONSTANT) + assert(size(b)==c%dim) + + select case (c%field_type) + case (FIELD_TYPE_NORMAL) + a%val=b(1)*c%val(1,:) + do i=2, c%dim + a%val=a%val+b(i)*c%val(i,:) + end do + case (FIELD_TYPE_CONSTANT) + a%val=b(1)*c%val(1,1) + do i=2, c%dim + a%val=a%val+b(i)*c%val(i,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in inner_product()") + end select + + end subroutine inner_product_array_field + + subroutine inner_product_field_array(a, b, c) + !!< Computes the node-wise inner/dot product a=b . c + type(scalar_field), intent(inout) :: a + type(vector_field), intent(in) :: b + real, dimension(:), intent(in) :: c + + integer i + + assert(a%mesh%refcount%id==b%mesh%refcount%id) + assert(a%field_type/=FIELD_TYPE_PYTHON) + assert(a%field_type==FIELD_TYPE_NORMAL .or. b%field_type==FIELD_TYPE_CONSTANT) + assert(size(c)==b%dim) + + select case (b%field_type) + case (FIELD_TYPE_NORMAL) + a%val=c(1)*b%val(1,:) + do i=2, b%dim + a%val=a%val+c(i)*b%val(i,:) + end do + case (FIELD_TYPE_CONSTANT) + a%val=c(1)*b%val(1,1) + do i=2, b%dim + a%val=a%val+c(i)*b%val(i,1) + end do + case default + ! someone could implement in_field type python + FLAbort("Illegal in_field field type in inner_product()") + end select + + end subroutine inner_product_field_array + + function get_patch_ele(mesh, node, level) result(patch) + !!< This function takes in a node and returns a patch_type containing + !!< information about the elements around this node. + integer, intent(in) :: node + type(mesh_type), intent(inout) :: mesh + integer, optional, intent(in) :: level ! how many elements deep do you want the patch + type(patch_type) :: patch + + integer :: i, j, k, l, llevel, ele, setsize + integer, dimension(:), pointer :: ele_node_list + type(csr_sparsity), pointer :: nelist + + if (present(level)) then + llevel = level + else + llevel = 1 + end if + + nelist => extract_nelist(mesh) + + ! Compute level-1 patch. + do j=nelist%findrm(node), nelist%findrm(node+1) - 1 + ele = nelist%colm(j) + call eleset_add(ele) + end do + + ! Compute any other levels. + ! There's an obvious optimisation here for l > 2, but in + ! practice I don't use l > 2, so I couldn't be bothered coding it. + ! (The optimisation being don't check elements you've already checked) + do l=2,llevel + call eleset_get_size(setsize) + do i=1,setsize + call eleset_get_ele(i, ele) + ele_node_list => ele_nodes(mesh, ele) ! get the nodes in that element + do j=1,size(ele_node_list) ! loop over those nodes + do k=nelist%findrm(ele_node_list(j)),nelist%findrm(ele_node_list(j)+1)-1 ! loop over their elements + call eleset_add(nelist%colm(k)) ! add + end do + end do + end do + end do + + call eleset_get_size(patch%count) + allocate(patch%elements(patch%count)) + call eleset_fetch_list(patch%elements) + + end function get_patch_ele + + function get_patch_node(mesh, node, level, min_nodes) result(patch) + !!< This function takes in a node and returns a patch_type containing + !!< information about the nodes around this node. + integer, intent(in) :: node + type(mesh_type), intent(inout) :: mesh + integer, optional, intent(in) :: level ! how many elements deep do you want the patch + integer, optional, intent(in) :: min_nodes ! how many nodes must be in the patch + type(patch_type) :: patch + + integer :: i, j, k, l, llevel, nnode, nnnode, ele, setsize + integer, dimension(:), pointer :: ele_node_list + type(csr_sparsity), pointer :: nelist + + if (present(level)) then + llevel = level + else + llevel = 1 + end if + + nelist => extract_nelist(mesh) + + ! Compute level-1 patch. + do j=nelist%findrm(node), nelist%findrm(node+1) - 1 + ele = nelist%colm(j) + ele_node_list => ele_nodes(mesh, ele) + do k=1,size(ele_node_list) + nnode = ele_node_list(k) + call eleset_add(nnode) + end do + end do + + ! Compute any other levels. + ! There's an obvious optimisation here for l > 2, but in + ! practice I don't use l > 2, so I couldn't be bothered coding it. + ! (The optimisation being don't check elements you've already checked) + l = 0 + do + ! Let's decide whether + ! to exit or not. + l = l + 1 + if (present(min_nodes)) then + call eleset_get_size(setsize) + if (setsize > min_nodes .and. l >= llevel) then + exit + end if + else + if (l >= llevel) then + exit + end if + end if + + do i=1,setsize + call eleset_get_ele(i, nnode) + do j=nelist%findrm(nnode),nelist%findrm(nnode+1)-1 ! loop over their elements + ele = nelist%colm(j) + ele_node_list => ele_nodes(mesh, ele) ! loop over this elements' nodes + do k=1,size(ele_node_list) + nnnode = ele_node_list(k) + call eleset_add(nnnode) ! add + end do + end do + end do + end do + + call eleset_get_size(patch%count) + allocate(patch%elements(patch%count)) + call eleset_fetch_list(patch%elements) + + end function get_patch_node + + function clone_header_scalar(field) result(out_field) + type(scalar_field), intent(in) :: field + type(scalar_field) :: out_field + + out_field = field + nullify(out_field%val) + end function clone_header_scalar + + function clone_header_vector(field) result(out_field) + type(vector_field), intent(in) :: field + type(vector_field) :: out_field + + out_field = field + nullify(out_field%val) + + end function clone_header_vector + + function clone_header_tensor(field) result(out_field) + type(tensor_field), intent(in) :: field + type(tensor_field) :: out_field + + out_field = field + nullify(out_field%val) + end function clone_header_tensor + + subroutine set_to_submesh_scalar(from_field, to_field) + !!< Set the nodal values of a field on a higher order mesh to a field on its submesh. + type(scalar_field), intent(in) :: from_field + type(scalar_field), intent(inout) :: to_field + + integer :: vertices, from_ele, to_ele, l_ele + integer, dimension(:,:), allocatable :: permutation + real, dimension(:), allocatable :: from_vals + integer, dimension(:), pointer :: to_nodes + + ewrite(1,*) 'entering set_to_submesh_scalar' + + assert(to_field%mesh%shape%degree==1) + + vertices = from_field%mesh%shape%quadrature%vertices + + select case(from_field%mesh%shape%numbering%family) + case(FAMILY_SIMPLEX) + + select case(from_field%mesh%shape%degree) + case(2) + + select case(vertices) + case(3) ! triangle + assert(to_field%mesh%elements==4*from_field%mesh%elements) + + allocate(permutation(4,3)) + ! here we assume that the one true node ordering is used + permutation = reshape((/1, 2, 2, 4, & + 2, 3, 4, 5, & + 4, 5, 5, 6/), (/4,3/)) + case(4) ! tet + assert(to_field%mesh%elements==8*from_field%mesh%elements) + + allocate(permutation(8,4)) + ! here we assume that the one true node ordering is used + ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron + permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & + 2, 3, 5, 8, 4, 5, 5, 7, & + 4, 5, 6, 9, 5, 7, 7, 8, & + 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) + case default + FLAbort("unrecognised vertex count") + end select + case(1) + !nothing to be done really + + select case(vertices) + case(3) ! triangle + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,3)) + permutation = reshape((/1, 2, 3/), (/1,3/)) + case(4) ! tet + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,4)) + permutation = reshape((/1, 2, 3, 4/), (/1,4/)) + case default + FLAbort("unrecognised vertex count") + end select + + case default + FLAbort("set_to_submesh_scalar only works for quadratic or lower elements") + end select + + case default + FLExit("set_to_submesh_scalar only works for simplex elements") + end select + + allocate(from_vals(from_field%mesh%shape%loc)) + + to_ele = 0 + do from_ele = 1, element_count(from_field) + from_vals=ele_val(from_field, from_ele) + + do l_ele = 1, size(permutation,1) + to_ele = to_ele+1 + to_nodes=>ele_nodes(to_field, to_ele) + call set(to_field, to_nodes, from_vals(permutation(l_ele,:))) + end do + + end do + + end subroutine set_to_submesh_scalar + + subroutine set_to_submesh_vector(from_field, to_field) + !!< Set the nodal values of a field on a higher order mesh to a field on its submesh. + type(vector_field), intent(in) :: from_field + type(vector_field), intent(inout) :: to_field + + integer :: vertices, from_ele, to_ele, l_ele + integer, dimension(:,:), allocatable :: permutation + real, dimension(:,:), allocatable :: from_vals + integer, dimension(:), pointer :: to_nodes + + ewrite(1,*) 'entering set_to_submesh_vector' + + assert(to_field%mesh%shape%degree==1) + + vertices = from_field%mesh%shape%quadrature%vertices + + select case(from_field%mesh%shape%numbering%family) + case(FAMILY_SIMPLEX) + + select case(from_field%mesh%shape%degree) + case(2) + + select case(vertices) + case(3) ! triangle + assert(to_field%mesh%elements==4*from_field%mesh%elements) + + allocate(permutation(4,3)) + ! here we assume that the one true node ordering is used + permutation = reshape((/1, 2, 2, 4, & + 2, 3, 4, 5, & + 4, 5, 5, 6/), (/4,3/)) + case(4) ! tet + assert(to_field%mesh%elements==8*from_field%mesh%elements) + + allocate(permutation(8,4)) + ! here we assume that the one true node ordering is used + ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron + permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & + 2, 3, 5, 8, 4, 5, 5, 7, & + 4, 5, 6, 9, 5, 7, 7, 8, & + 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) + case default + FLAbort("unrecognised vertex count") + end select + case(1) + !nothing to be done really + + select case(vertices) + case(3) ! triangle + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,3)) + permutation = reshape((/1, 2, 3/), (/1,3/)) + case(4) ! tet + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,4)) + permutation = reshape((/1, 2, 3, 4/), (/1,4/)) + case default + FLAbort("unrecognised vertex count") + end select + + case default + FLAbort("set_to_submesh_vector only works for quadratic or lower elements") + end select + + case default + FLExit("set_to_submesh_vector only works for simplex elements") + end select + + allocate(from_vals(from_field%dim, from_field%mesh%shape%loc)) + + to_ele = 0 + do from_ele = 1, element_count(from_field) + from_vals=ele_val(from_field, from_ele) + + do l_ele = 1, size(permutation,1) + to_ele = to_ele+1 + to_nodes=>ele_nodes(to_field, to_ele) + call set(to_field, to_nodes, from_vals(:, permutation(l_ele,:))) + end do + + end do + + end subroutine set_to_submesh_vector + + subroutine set_from_submesh_scalar(from_field, to_field) + !!< Set the nodal values of a field on a lower order submesh to a field on its parent mesh. + type(scalar_field), intent(in) :: from_field + type(scalar_field), intent(inout) :: to_field + + integer :: vertices, from_ele, to_ele, l_ele + integer, dimension(:,:), allocatable :: permutation + real, dimension(:), allocatable :: from_vals + integer, dimension(:), pointer :: to_nodes + + ewrite(1,*) 'entering set_from_submesh_scalar' + + assert(from_field%mesh%shape%degree==1) + + vertices = to_field%mesh%shape%quadrature%vertices + + select case(to_field%mesh%shape%numbering%family) + case(FAMILY_SIMPLEX) + + select case(to_field%mesh%shape%degree) + case(2) + + select case(vertices) + case(3) ! triangle + assert(4*to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(4,3)) + ! here we assume that the one true node ordering is used + permutation = reshape((/1, 2, 2, 4, & + 2, 3, 4, 5, & + 4, 5, 5, 6/), (/4,3/)) + case(4) ! tet + assert(8*to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(8,4)) + ! here we assume that the one true node ordering is used + ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron + permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & + 2, 3, 5, 8, 4, 5, 5, 7, & + 4, 5, 6, 9, 5, 7, 7, 8, & + 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) + case default + FLAbort("unrecognised vertex count") + end select + case(1) + !nothing to be done really + + select case(vertices) + case(3) ! triangle + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,3)) + permutation = reshape((/1, 2, 3/), (/1,3/)) + case(4) ! tet + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,4)) + permutation = reshape((/1, 2, 3, 4/), (/1,4/)) + case default + FLExit("unrecognised vertex count") + end select + + case default + FLAbort("set_from_submesh_vector only works for quadratic or lower elements") + end select + + case default + FLAbort("set_from_submesh_vector only works for simplex elements") + end select + + allocate(from_vals(from_field%mesh%shape%loc)) + + from_ele = 0 + do to_ele = 1, element_count(to_field) + to_nodes=>ele_nodes(to_field, to_ele) + + do l_ele = 1, size(permutation,1) + + from_ele = from_ele + 1 + from_vals=ele_val(from_field, from_ele) + + call set(to_field, to_nodes(permutation(l_ele,:)), from_vals) + + end do + + end do + + end subroutine set_from_submesh_scalar + + subroutine set_from_submesh_vector(from_field, to_field) + !!< Set the nodal values of a field on a lower order submesh to a field on its parent mesh. + type(vector_field), intent(in) :: from_field + type(vector_field), intent(inout) :: to_field + + integer :: vertices, from_ele, to_ele, l_ele + integer, dimension(:,:), allocatable :: permutation + real, dimension(:,:), allocatable :: from_vals + integer, dimension(:), pointer :: to_nodes + + ewrite(1,*) 'entering set_from_submesh_vector' + + assert(from_field%mesh%shape%degree==1) + + vertices = to_field%mesh%shape%quadrature%vertices + + select case(to_field%mesh%shape%numbering%family) + case(FAMILY_SIMPLEX) + + select case(to_field%mesh%shape%degree) + case(2) + + select case(vertices) + case(3) ! triangle + assert(4*to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(4,3)) + ! here we assume that the one true node ordering is used + permutation = reshape((/1, 2, 2, 4, & + 2, 3, 4, 5, & + 4, 5, 5, 6/), (/4,3/)) + case(4) ! tet + assert(8*to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(8,4)) + ! here we assume that the one true node ordering is used + ! also we arbitrarily select a diagonal (between 5 and 7) through the central octahedron + permutation = reshape((/1, 2, 4, 7, 2, 2, 4, 5, & + 2, 3, 5, 8, 4, 5, 5, 7, & + 4, 5, 6, 9, 5, 7, 7, 8, & + 7, 8, 9, 10, 7, 8, 9, 9/), (/8,4/)) + case default + FLAbort("unrecognised vertex count") + end select + case(1) + !nothing to be done really + + select case(vertices) + case(3) ! triangle + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,3)) + permutation = reshape((/1, 2, 3/), (/1,3/)) + case(4) ! tet + assert(to_field%mesh%elements==from_field%mesh%elements) + + allocate(permutation(1,4)) + permutation = reshape((/1, 2, 3, 4/), (/1,4/)) + case default + FLExit("unrecognised vertex count") + end select + + case default + FLAbort("set_from_submesh_vector only works for quadratic or lower elements") + end select + + case default + FLAbort("set_from_submesh_vector only works for simplex elements") + end select + + allocate(from_vals(from_field%dim, from_field%mesh%shape%loc)) + + from_ele = 0 + do to_ele = 1, element_count(to_field) + to_nodes=>ele_nodes(to_field, to_ele) + + do l_ele = 1, size(permutation,1) + + from_ele = from_ele + 1 + from_vals=ele_val(from_field, from_ele) + + call set(to_field, to_nodes(permutation(l_ele,:)), from_vals) + + end do + + end do + + end subroutine set_from_submesh_vector + + subroutine set_ele_nodes(mesh, ele, nodes) + type(mesh_type), intent(inout) :: mesh + integer, intent(in) :: ele + integer, dimension(:), intent(in) :: nodes + + assert(size(nodes) == ele_loc(mesh, ele)) + + mesh%ndglno(mesh%shape%loc*(ele-1)+1:& + &mesh%shape%loc*ele) = nodes + end subroutine set_ele_nodes + + subroutine renumber_positions_trailing_receives(positions, permutation) + type(vector_field), intent(inout) :: positions + integer, dimension(:), intent(out), optional :: permutation + + integer :: i, j, nhalos, nonods + integer, dimension(:), allocatable :: inverse_permutation, receive_node, & & renumber_permutation - type(vector_field) :: positions_renumbered + type(vector_field) :: positions_renumbered - ewrite(1, *) "In renumber_positions_trailing_receives" - assert(positions%refcount%count == 1) + ewrite(1, *) "In renumber_positions_trailing_receives" + assert(positions%refcount%count == 1) - nhalos = halo_count(positions) - if(nhalos == 0) return + nhalos = halo_count(positions) + if(nhalos == 0) return - nonods = node_count(positions) + nonods = node_count(positions) - allocate(receive_node(nonods)) - allocate(renumber_permutation(nonods)) - allocate(inverse_permutation(nonods)) - receive_node = 0 - do i = nhalos, 1, -1 - do j = 1, halo_proc_count(positions%mesh%halos(i)) - receive_node(halo_receives(positions%mesh%halos(i), j)) = i + allocate(receive_node(nonods)) + allocate(renumber_permutation(nonods)) + allocate(inverse_permutation(nonods)) + receive_node = 0 + do i = nhalos, 1, -1 + do j = 1, halo_proc_count(positions%mesh%halos(i)) + receive_node(halo_receives(positions%mesh%halos(i), j)) = i + end do + end do + call qsort(receive_node, renumber_permutation) + do i=1 , size(renumber_permutation) + inverse_permutation(renumber_permutation(i))=i end do - end do - call qsort(receive_node, renumber_permutation) - do i=1 , size(renumber_permutation) - inverse_permutation(renumber_permutation(i))=i - end do - call renumber_positions(positions, inverse_permutation, positions_renumbered, & + call renumber_positions(positions, inverse_permutation, positions_renumbered, & & node_halo_ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) - call deallocate(positions) - positions = positions_renumbered + call deallocate(positions) + positions = positions_renumbered - if(present(permutation)) then - assert(size(permutation)==nonods) - permutation=inverse_permutation - end if + if(present(permutation)) then + assert(size(permutation)==nonods) + permutation=inverse_permutation + end if - deallocate(receive_node) - deallocate(renumber_permutation) - deallocate(inverse_permutation) + deallocate(receive_node) + deallocate(renumber_permutation) + deallocate(inverse_permutation) #ifdef DDEBUG - do i = 1, nhalos - !if (.not. has_references(positions%mesh%halos(i))) cycle - assert(trailing_receives_consistent(positions%mesh%halos(i))) - end do + do i = 1, nhalos + !if (.not. has_references(positions%mesh%halos(i))) cycle + assert(trailing_receives_consistent(positions%mesh%halos(i))) + end do #endif - ewrite(1, *) "Exiting renumber_positions_trailing_receives" - - end subroutine renumber_positions_trailing_receives + ewrite(1, *) "Exiting renumber_positions_trailing_receives" - subroutine renumber_positions(input_positions, permutation, output_positions, node_halo_ordering_scheme) - type(vector_field), intent(in) :: input_positions - type(vector_field), intent(out) :: output_positions - integer, dimension(:), intent(in) :: permutation - !! As we're reordering nodes it is assumed that output node halos should - !! use a general ordering scheme, unless explicitly overridden via this - !! argument - integer, optional, intent(in) :: node_halo_ordering_scheme + end subroutine renumber_positions_trailing_receives - type(mesh_type) :: output_mesh - integer :: ele, node, halo_num, lnode_halo_ordering_scheme, proc - type(halo_type), pointer :: input_halo, output_halo + subroutine renumber_positions(input_positions, permutation, output_positions, node_halo_ordering_scheme) + type(vector_field), intent(in) :: input_positions + type(vector_field), intent(out) :: output_positions + integer, dimension(:), intent(in) :: permutation + !! As we're reordering nodes it is assumed that output node halos should + !! use a general ordering scheme, unless explicitly overridden via this + !! argument + integer, optional, intent(in) :: node_halo_ordering_scheme - ewrite(1, *) "In renumber_positions" + type(mesh_type) :: output_mesh + integer :: ele, node, halo_num, lnode_halo_ordering_scheme, proc + type(halo_type), pointer :: input_halo, output_halo - assert(size(permutation) == node_count(input_positions)) + ewrite(1, *) "In renumber_positions" - if(present(node_halo_ordering_scheme)) then - lnode_halo_ordering_scheme = node_halo_ordering_scheme - else - lnode_halo_ordering_scheme = HALO_ORDER_GENERAL - end if + assert(size(permutation) == node_count(input_positions)) - call allocate(output_mesh, node_count(input_positions), ele_count(input_positions), & - & input_positions%mesh%shape, trim(input_positions%mesh%name)) + if(present(node_halo_ordering_scheme)) then + lnode_halo_ordering_scheme = node_halo_ordering_scheme + else + lnode_halo_ordering_scheme = HALO_ORDER_GENERAL + end if - do ele=1,ele_count(input_positions) - call set_ele_nodes(output_mesh, ele, permutation(ele_nodes(input_positions, ele))) - end do + call allocate(output_mesh, node_count(input_positions), ele_count(input_positions), & + & input_positions%mesh%shape, trim(input_positions%mesh%name)) - if(associated(input_positions%mesh%columns)) then - allocate(output_mesh%columns(node_count(input_positions))) - do node=1,node_count(input_positions) - output_mesh%columns(permutation(node)) = input_positions%mesh%columns(node) + do ele=1,ele_count(input_positions) + call set_ele_nodes(output_mesh, ele, permutation(ele_nodes(input_positions, ele))) end do - end if - - output_mesh%periodic = input_positions%mesh%periodic - if (associated(input_positions%mesh%region_ids)) then - allocate(output_mesh%region_ids(size(input_positions%mesh%region_ids))) - output_mesh%region_ids = input_positions%mesh%region_ids - end if - - ! Now here comes the damnable face information - - if (associated(input_positions%mesh%faces)) then - allocate(output_mesh%faces) - allocate(output_mesh%faces%shape) - output_mesh%faces%shape = input_positions%mesh%faces%shape - call incref(output_mesh%faces%shape) - call incref(output_mesh%faces%shape%quadrature) - output_mesh%faces%face_list = input_positions%mesh%faces%face_list - call incref(output_mesh%faces%face_list) - allocate(output_mesh%faces%face_lno(size(input_positions%mesh%faces%face_lno))) - output_mesh%faces%face_lno = input_positions%mesh%faces%face_lno + + if(associated(input_positions%mesh%columns)) then + allocate(output_mesh%columns(node_count(input_positions))) + do node=1,node_count(input_positions) + output_mesh%columns(permutation(node)) = input_positions%mesh%columns(node) + end do + end if + + output_mesh%periodic = input_positions%mesh%periodic + if (associated(input_positions%mesh%region_ids)) then + allocate(output_mesh%region_ids(size(input_positions%mesh%region_ids))) + output_mesh%region_ids = input_positions%mesh%region_ids + end if + + ! Now here comes the damnable face information + + if (associated(input_positions%mesh%faces)) then + allocate(output_mesh%faces) + allocate(output_mesh%faces%shape) + output_mesh%faces%shape = input_positions%mesh%faces%shape + call incref(output_mesh%faces%shape) + call incref(output_mesh%faces%shape%quadrature) + output_mesh%faces%face_list = input_positions%mesh%faces%face_list + call incref(output_mesh%faces%face_list) + allocate(output_mesh%faces%face_lno(size(input_positions%mesh%faces%face_lno))) + output_mesh%faces%face_lno = input_positions%mesh%faces%face_lno #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & - size(output_mesh%faces%face_lno), name=output_mesh%name) + call register_allocation("mesh_type", "integer", & + size(output_mesh%faces%face_lno), name=output_mesh%name) #endif - output_mesh%faces%surface_mesh = input_positions%mesh%faces%surface_mesh - call incref(output_mesh%faces%surface_mesh) - allocate(output_mesh%faces%surface_node_list(size(input_positions%mesh%faces%surface_node_list))) - output_mesh%faces%surface_node_list = permutation(input_positions%mesh%faces%surface_node_list) + output_mesh%faces%surface_mesh = input_positions%mesh%faces%surface_mesh + call incref(output_mesh%faces%surface_mesh) + allocate(output_mesh%faces%surface_node_list(size(input_positions%mesh%faces%surface_node_list))) + output_mesh%faces%surface_node_list = permutation(input_positions%mesh%faces%surface_node_list) #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & - size(output_mesh%faces%surface_node_list), name='Surface'//trim(output_mesh%name)) + call register_allocation("mesh_type", "integer", & + size(output_mesh%faces%surface_node_list), name='Surface'//trim(output_mesh%name)) #endif - allocate(output_mesh%faces%face_element_list(size(input_positions%mesh%faces%face_element_list))) - output_mesh%faces%face_element_list = input_positions%mesh%faces%face_element_list + allocate(output_mesh%faces%face_element_list(size(input_positions%mesh%faces%face_element_list))) + output_mesh%faces%face_element_list = input_positions%mesh%faces%face_element_list #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & - size(output_mesh%faces%face_element_list), & - trim(output_mesh%name)//" face_element_list.") + call register_allocation("mesh_type", "integer", & + size(output_mesh%faces%face_element_list), & + trim(output_mesh%name)//" face_element_list.") #endif - output_mesh%faces%unique_surface_element_count = input_positions%mesh%faces%unique_surface_element_count - output_mesh%faces%has_discontinuous_internal_boundaries = has_discontinuous_internal_boundaries(input_positions%mesh) - allocate(output_mesh%faces%boundary_ids(size(input_positions%mesh%faces%boundary_ids))) - output_mesh%faces%boundary_ids = input_positions%mesh%faces%boundary_ids + output_mesh%faces%unique_surface_element_count = input_positions%mesh%faces%unique_surface_element_count + output_mesh%faces%has_discontinuous_internal_boundaries = has_discontinuous_internal_boundaries(input_positions%mesh) + allocate(output_mesh%faces%boundary_ids(size(input_positions%mesh%faces%boundary_ids))) + output_mesh%faces%boundary_ids = input_positions%mesh%faces%boundary_ids #ifdef HAVE_MEMORY_STATS - call register_allocation("mesh_type", "integer", & - size(output_mesh%faces%boundary_ids), & - trim(output_mesh%name)//" boundary_ids") + call register_allocation("mesh_type", "integer", & + size(output_mesh%faces%boundary_ids), & + trim(output_mesh%name)//" boundary_ids") #endif - if(associated(input_positions%mesh%faces%coplanar_ids)) then - allocate(output_mesh%faces%coplanar_ids(size(input_positions%mesh%faces%coplanar_ids))) - output_mesh%faces%coplanar_ids = input_positions%mesh%faces%coplanar_ids + if(associated(input_positions%mesh%faces%coplanar_ids)) then + allocate(output_mesh%faces%coplanar_ids(size(input_positions%mesh%faces%coplanar_ids))) + output_mesh%faces%coplanar_ids = input_positions%mesh%faces%coplanar_ids + end if + if (associated(input_positions%mesh%faces%dg_surface_mesh)) then + allocate(output_mesh%faces%dg_surface_mesh) + output_mesh%faces%dg_surface_mesh = input_positions%mesh%faces%dg_surface_mesh + call incref(output_mesh%faces%dg_surface_mesh) + end if end if - if (associated(input_positions%mesh%faces%dg_surface_mesh)) then - allocate(output_mesh%faces%dg_surface_mesh) - output_mesh%faces%dg_surface_mesh = input_positions%mesh%faces%dg_surface_mesh - call incref(output_mesh%faces%dg_surface_mesh) - end if - end if - - output_mesh%option_path = input_positions%mesh%option_path - output_mesh%continuity = input_positions%mesh%continuity - - ! Now for the positions - call allocate(output_positions, input_positions%dim, output_mesh, trim(input_positions%name)) - do node=1,node_count(output_positions) - call set(output_positions, permutation(node), node_val(input_positions, node)) - end do - call deallocate(output_mesh) - - ! Node halos - allocate(output_positions%mesh%halos(halo_count(input_positions))) - do halo_num = 1, halo_count(input_positions) - if (.not. has_references(input_positions%mesh%halos(halo_num))) cycle - input_halo => input_positions%mesh%halos(halo_num) - output_halo => output_positions%mesh%halos(halo_num) - call allocate(output_halo, input_halo) - call set_halo_ordering_scheme(output_halo, lnode_halo_ordering_scheme) - do proc = 1, halo_proc_count(input_halo) - call set_halo_sends(output_halo, proc, permutation(halo_sends(input_halo, proc))) - call set_halo_receives(output_halo, proc, permutation(halo_receives(input_halo, proc))) + + output_mesh%option_path = input_positions%mesh%option_path + output_mesh%continuity = input_positions%mesh%continuity + + ! Now for the positions + call allocate(output_positions, input_positions%dim, output_mesh, trim(input_positions%name)) + do node=1,node_count(output_positions) + call set(output_positions, permutation(node), node_val(input_positions, node)) + end do + call deallocate(output_mesh) + + ! Node halos + allocate(output_positions%mesh%halos(halo_count(input_positions))) + do halo_num = 1, halo_count(input_positions) + if (.not. has_references(input_positions%mesh%halos(halo_num))) cycle + input_halo => input_positions%mesh%halos(halo_num) + output_halo => output_positions%mesh%halos(halo_num) + call allocate(output_halo, input_halo) + call set_halo_ordering_scheme(output_halo, lnode_halo_ordering_scheme) + do proc = 1, halo_proc_count(input_halo) + call set_halo_sends(output_halo, proc, permutation(halo_sends(input_halo, proc))) + call set_halo_receives(output_halo, proc, permutation(halo_receives(input_halo, proc))) + end do + + ! Create caches + call create_ownership(output_halo) + call create_global_to_universal_numbering(output_halo) + assert(has_global_to_universal_numbering(output_halo)) end do + ! Element halos + allocate(output_positions%mesh%element_halos(element_halo_count(input_positions))) + do halo_num = 1, element_halo_count(input_positions) + if (.not. has_references(input_positions%mesh%element_halos(halo_num))) cycle + output_positions%mesh%element_halos(halo_num) = input_positions%mesh%element_halos(halo_num) + call incref(output_positions%mesh%element_halos(halo_num)) + end do + + output_positions%option_path = input_positions%option_path + + ewrite(1, *) "Exiting renumber_positions" + + end subroutine renumber_positions + + subroutine renumber_positions_elements(input_positions, permutation, output_positions, element_halo_ordering_scheme) + type(vector_field), intent(in) :: input_positions + type(vector_field), intent(out) :: output_positions + integer, dimension(:), intent(in) :: permutation + !! As we're reordering nodes it is assumed that output halos should + !! use a general ordering scheme, unless explicitly overridden via this + !! argument + integer, optional, intent(in) :: element_halo_ordering_scheme + + type(mesh_type) :: output_mesh + integer :: ele, node, halo_num, lelement_halo_ordering_scheme, proc + type(halo_type), pointer :: input_halo, output_halo + integer, dimension(:), allocatable :: sndgln + integer :: no_unique_facets + + ewrite(1, *) "In renumber_positions_elements" + + assert(size(permutation) == ele_count(input_positions)) - ! Create caches - call create_ownership(output_halo) - call create_global_to_universal_numbering(output_halo) - assert(has_global_to_universal_numbering(output_halo)) - end do - ! Element halos - allocate(output_positions%mesh%element_halos(element_halo_count(input_positions))) - do halo_num = 1, element_halo_count(input_positions) - if (.not. has_references(input_positions%mesh%element_halos(halo_num))) cycle - output_positions%mesh%element_halos(halo_num) = input_positions%mesh%element_halos(halo_num) - call incref(output_positions%mesh%element_halos(halo_num)) - end do - - output_positions%option_path = input_positions%option_path - - ewrite(1, *) "Exiting renumber_positions" - - end subroutine renumber_positions - - subroutine renumber_positions_elements(input_positions, permutation, output_positions, element_halo_ordering_scheme) - type(vector_field), intent(in) :: input_positions - type(vector_field), intent(out) :: output_positions - integer, dimension(:), intent(in) :: permutation - !! As we're reordering nodes it is assumed that output halos should - !! use a general ordering scheme, unless explicitly overridden via this - !! argument - integer, optional, intent(in) :: element_halo_ordering_scheme - - type(mesh_type) :: output_mesh - integer :: ele, node, halo_num, lelement_halo_ordering_scheme, proc - type(halo_type), pointer :: input_halo, output_halo - integer, dimension(:), allocatable :: sndgln - integer :: no_unique_facets - - ewrite(1, *) "In renumber_positions_elements" - - assert(size(permutation) == ele_count(input_positions)) - - if(present(element_halo_ordering_scheme)) then - lelement_halo_ordering_scheme = element_halo_ordering_scheme - else - lelement_halo_ordering_scheme = HALO_ORDER_GENERAL - end if - - call allocate(output_mesh, node_count(input_positions), ele_count(input_positions), & - & input_positions%mesh%shape, trim(input_positions%mesh%name)) - - do ele=1,ele_count(input_positions) - call set_ele_nodes(output_mesh, permutation(ele), ele_nodes(input_positions, ele)) - end do - - if(associated(input_positions%mesh%columns)) then - allocate(output_mesh%columns(node_count(input_positions))) - output_mesh%columns = input_positions%mesh%columns - end if - - output_mesh%periodic = input_positions%mesh%periodic - if (associated(input_positions%mesh%region_ids)) then - allocate(output_mesh%region_ids(size(input_positions%mesh%region_ids))) - output_mesh%region_ids = input_positions%mesh%region_ids - end if - - ! Now here comes the damnable face information - - if (associated(input_positions%mesh%faces)) then - no_unique_facets = unique_surface_element_count(input_positions%mesh) - allocate(sndgln(no_unique_facets * face_loc(input_positions, 1))) - call getsndgln(input_positions%mesh, sndgln) - if (has_discontinuous_internal_boundaries(input_positions%mesh)) then - assert(surface_element_count(input_positions%mesh)==no_unique_facets) - call add_faces(output_mesh, sndgln=sndgln, boundary_ids=input_positions%mesh%faces%boundary_ids, & - element_owner=permutation(input_positions%mesh%faces%face_element_list(1:no_unique_facets))) + if(present(element_halo_ordering_scheme)) then + lelement_halo_ordering_scheme = element_halo_ordering_scheme else - call add_faces(output_mesh, sndgln=sndgln, boundary_ids=input_positions%mesh%faces%boundary_ids(1:no_unique_facets)) + lelement_halo_ordering_scheme = HALO_ORDER_GENERAL end if - deallocate(sndgln) - if (associated(input_positions%mesh%faces%coplanar_ids)) then - allocate(output_mesh%faces%coplanar_ids(size(input_positions%mesh%faces%coplanar_ids))) - output_mesh%faces%coplanar_ids = input_positions%mesh%faces%coplanar_ids + + call allocate(output_mesh, node_count(input_positions), ele_count(input_positions), & + & input_positions%mesh%shape, trim(input_positions%mesh%name)) + + do ele=1,ele_count(input_positions) + call set_ele_nodes(output_mesh, permutation(ele), ele_nodes(input_positions, ele)) + end do + + if(associated(input_positions%mesh%columns)) then + allocate(output_mesh%columns(node_count(input_positions))) + output_mesh%columns = input_positions%mesh%columns + end if + + output_mesh%periodic = input_positions%mesh%periodic + if (associated(input_positions%mesh%region_ids)) then + allocate(output_mesh%region_ids(size(input_positions%mesh%region_ids))) + output_mesh%region_ids = input_positions%mesh%region_ids + end if + + ! Now here comes the damnable face information + + if (associated(input_positions%mesh%faces)) then + no_unique_facets = unique_surface_element_count(input_positions%mesh) + allocate(sndgln(no_unique_facets * face_loc(input_positions, 1))) + call getsndgln(input_positions%mesh, sndgln) + if (has_discontinuous_internal_boundaries(input_positions%mesh)) then + assert(surface_element_count(input_positions%mesh)==no_unique_facets) + call add_faces(output_mesh, sndgln=sndgln, boundary_ids=input_positions%mesh%faces%boundary_ids, & + element_owner=permutation(input_positions%mesh%faces%face_element_list(1:no_unique_facets))) + else + call add_faces(output_mesh, sndgln=sndgln, boundary_ids=input_positions%mesh%faces%boundary_ids(1:no_unique_facets)) + end if + deallocate(sndgln) + if (associated(input_positions%mesh%faces%coplanar_ids)) then + allocate(output_mesh%faces%coplanar_ids(size(input_positions%mesh%faces%coplanar_ids))) + output_mesh%faces%coplanar_ids = input_positions%mesh%faces%coplanar_ids + end if end if - end if - - output_mesh%option_path = input_positions%mesh%option_path - output_mesh%continuity = input_positions%mesh%continuity - - ! Now for the positions - call allocate(output_positions, input_positions%dim, output_mesh, trim(input_positions%name)) - do node=1,node_count(output_positions) - call set(output_positions, node, node_val(input_positions, node)) - end do - call deallocate(output_mesh) - - ! Node halos - allocate(output_positions%mesh%halos(halo_count(input_positions))) - do halo_num = 1, halo_count(input_positions) - if (.not. has_references(input_positions%mesh%halos(halo_num))) cycle - output_positions%mesh%halos(halo_num) = input_positions%mesh%halos(halo_num) - call incref(output_positions%mesh%halos(halo_num)) - end do - - ! Element halos - allocate(output_positions%mesh%element_halos(element_halo_count(input_positions))) - do halo_num = 1, element_halo_count(input_positions) - if (.not. has_references(input_positions%mesh%element_halos(halo_num))) cycle - input_halo => input_positions%mesh%element_halos(halo_num) - output_halo => output_positions%mesh%element_halos(halo_num) - call allocate(output_halo, input_halo) - call set_halo_ordering_scheme(output_halo, lelement_halo_ordering_scheme) - do proc = 1, halo_proc_count(input_halo) - call set_halo_sends(output_halo, proc, permutation(halo_sends(input_halo, proc))) - call set_halo_receives(output_halo, proc, permutation(halo_receives(input_halo, proc))) + + output_mesh%option_path = input_positions%mesh%option_path + output_mesh%continuity = input_positions%mesh%continuity + + ! Now for the positions + call allocate(output_positions, input_positions%dim, output_mesh, trim(input_positions%name)) + do node=1,node_count(output_positions) + call set(output_positions, node, node_val(input_positions, node)) end do + call deallocate(output_mesh) + + ! Node halos + allocate(output_positions%mesh%halos(halo_count(input_positions))) + do halo_num = 1, halo_count(input_positions) + if (.not. has_references(input_positions%mesh%halos(halo_num))) cycle + output_positions%mesh%halos(halo_num) = input_positions%mesh%halos(halo_num) + call incref(output_positions%mesh%halos(halo_num)) + end do + + ! Element halos + allocate(output_positions%mesh%element_halos(element_halo_count(input_positions))) + do halo_num = 1, element_halo_count(input_positions) + if (.not. has_references(input_positions%mesh%element_halos(halo_num))) cycle + input_halo => input_positions%mesh%element_halos(halo_num) + output_halo => output_positions%mesh%element_halos(halo_num) + call allocate(output_halo, input_halo) + call set_halo_ordering_scheme(output_halo, lelement_halo_ordering_scheme) + do proc = 1, halo_proc_count(input_halo) + call set_halo_sends(output_halo, proc, permutation(halo_sends(input_halo, proc))) + call set_halo_receives(output_halo, proc, permutation(halo_receives(input_halo, proc))) + end do - ! Create caches - call create_ownership(output_halo) - call create_global_to_universal_numbering(output_halo) - assert(has_global_to_universal_numbering(output_halo)) - end do + ! Create caches + call create_ownership(output_halo) + call create_global_to_universal_numbering(output_halo) + assert(has_global_to_universal_numbering(output_halo)) + end do - output_positions%option_path = input_positions%option_path + output_positions%option_path = input_positions%option_path - ewrite(1, *) "Exiting renumber_positions_elements" + ewrite(1, *) "Exiting renumber_positions_elements" - end subroutine renumber_positions_elements + end subroutine renumber_positions_elements - subroutine renumber_positions_elements_trailing_receives(positions, permutation) - type(vector_field), intent(inout) :: positions - integer, dimension(:), intent(out), optional :: permutation + subroutine renumber_positions_elements_trailing_receives(positions, permutation) + type(vector_field), intent(inout) :: positions + integer, dimension(:), intent(out), optional :: permutation - integer :: i, j, nhalos, elmcnt - integer, dimension(:), allocatable :: inverse_permutation, receive_node, & + integer :: i, j, nhalos, elmcnt + integer, dimension(:), allocatable :: inverse_permutation, receive_node, & & renumber_permutation - type(vector_field) :: positions_renumbered + type(vector_field) :: positions_renumbered - ewrite(1, *) "In renumber_positions_elements_trailing_receives" + ewrite(1, *) "In renumber_positions_elements_trailing_receives" - assert(positions%refcount%count == 1) + assert(positions%refcount%count == 1) - nhalos = element_halo_count(positions) - if(nhalos == 0) return + nhalos = element_halo_count(positions) + if(nhalos == 0) return - elmcnt = ele_count(positions) + elmcnt = ele_count(positions) - allocate(receive_node(elmcnt)) - allocate(renumber_permutation(elmcnt)) - allocate(inverse_permutation(elmcnt)) - receive_node = 0 - do i = nhalos, 1, -1 - do j = 1, halo_proc_count(positions%mesh%element_halos(i)) - receive_node(halo_receives(positions%mesh%element_halos(i), j)) = i + allocate(receive_node(elmcnt)) + allocate(renumber_permutation(elmcnt)) + allocate(inverse_permutation(elmcnt)) + receive_node = 0 + do i = nhalos, 1, -1 + do j = 1, halo_proc_count(positions%mesh%element_halos(i)) + receive_node(halo_receives(positions%mesh%element_halos(i), j)) = i + end do + end do + call qsort(receive_node, renumber_permutation) + do i=1,size(renumber_permutation) + inverse_permutation(renumber_permutation(i)) = i end do - end do - call qsort(receive_node, renumber_permutation) - do i=1,size(renumber_permutation) - inverse_permutation(renumber_permutation(i)) = i - end do - call renumber_positions_elements(positions, inverse_permutation, positions_renumbered, & + call renumber_positions_elements(positions, inverse_permutation, positions_renumbered, & & element_halo_ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) - call deallocate(positions) - positions = positions_renumbered + call deallocate(positions) + positions = positions_renumbered - if (present(permutation)) then - assert(size(permutation) == elmcnt) - permutation = inverse_permutation - end if + if (present(permutation)) then + assert(size(permutation) == elmcnt) + permutation = inverse_permutation + end if - deallocate(receive_node) - deallocate(renumber_permutation) - deallocate(inverse_permutation) + deallocate(receive_node) + deallocate(renumber_permutation) + deallocate(inverse_permutation) #ifdef DDEBUG - do i = 1, nhalos - assert(trailing_receives_consistent(positions%mesh%element_halos(i))) - end do + do i = 1, nhalos + assert(trailing_receives_consistent(positions%mesh%element_halos(i))) + end do #endif - ewrite(1, *) "Exiting renumber_positions_elements_trailing_receives" + ewrite(1, *) "Exiting renumber_positions_elements_trailing_receives" + + end subroutine renumber_positions_elements_trailing_receives + + subroutine reorder_element_numbering(positions, use_unns) + !!< On return from adaptivity, the element node list for halo elements + !!< contains arbitrary reorderings. This routine reorders the element + !!< node lists so that they are consistent accross all processes. + + type(vector_field), target, intent(inout) :: positions + !! Supply this to override unn caches on the positions field. Useful for + !! reordering before caches have been generated. + type(integer_set), dimension(:), intent(in), optional :: use_unns + + integer :: tmp, ele, nhalos + ! Note that this is invalid for mixed geometry meshes, but adaptivity + ! doesn't support those anyway! + integer, dimension(ele_loc(positions,1)) :: unns, unns_order + integer, dimension(:), allocatable :: sndgln + integer, dimension(:), pointer :: nodes + type(mesh_type), pointer :: mesh + + mesh => positions%mesh + if(has_faces(mesh)) then + allocate(sndgln(face_loc(mesh, 1) * unique_surface_element_count(mesh))) + call getsndgln(mesh, sndgln) + end if + + nhalos = halo_count(mesh) + if((nhalos == 0).and.(.not.present(use_unns))) then + FLAbort("Need halos or unns to reorder the mesh.") + end if + + do ele = 1, element_count(mesh) + nodes => ele_nodes(mesh, ele) + + if(present(use_unns)) then + unns = set2vector(use_unns(ele)) + else + ! Get the universal numbers from the largest available halo + unns = halo_universal_numbers(mesh%halos(nhalos), nodes) + end if + + call qsort(unns, unns_order) + call apply_permutation(nodes, unns_order) + + end do + + ! Now we have the nodes in a known order. However, some elements may + ! be inverted. This is only an issue in 3D. + + if(mesh_dim(mesh) == 3) then + do ele = 1, element_count(mesh) + nodes => ele_nodes(mesh, ele) + if(simplex_volume(positions, ele) < 0.0) then + tmp = nodes(1) + nodes(1) = nodes(2) + nodes(2) = tmp + end if + end do + end if + + call remove_eelist(mesh) + if(has_faces(mesh)) then + call update_faces(mesh, sndgln) + deallocate(sndgln) + end if + + contains + + subroutine update_faces(mesh, sndgln) + type(mesh_type), intent(inout) :: mesh + integer, dimension(face_loc(mesh, 1) * unique_surface_element_count(mesh)), intent(in) :: sndgln + + integer, dimension(:), allocatable :: boundary_ids, coplanar_ids, element_owners - end subroutine renumber_positions_elements_trailing_receives + assert(has_faces(mesh)) - subroutine reorder_element_numbering(positions, use_unns) - !!< On return from adaptivity, the element node list for halo elements - !!< contains arbitrary reorderings. This routine reorders the element - !!< node lists so that they are consistent accross all processes. + if(associated(mesh%faces%coplanar_ids)) then + allocate(coplanar_ids(surface_element_count(mesh))) + coplanar_ids = mesh%faces%coplanar_ids + end if - type(vector_field), target, intent(inout) :: positions - !! Supply this to override unn caches on the positions field. Useful for - !! reordering before caches have been generated. - type(integer_set), dimension(:), intent(in), optional :: use_unns + allocate(boundary_ids(1:unique_surface_element_count(mesh))) + boundary_ids = mesh%faces%boundary_ids(1:size(boundary_ids)) - integer :: tmp, ele, nhalos - ! Note that this is invalid for mixed geometry meshes, but adaptivity - ! doesn't support those anyway! - integer, dimension(ele_loc(positions,1)) :: unns, unns_order - integer, dimension(:), allocatable :: sndgln - integer, dimension(:), pointer :: nodes - type(mesh_type), pointer :: mesh + if (has_discontinuous_internal_boundaries(mesh)) then + allocate(element_owners((surface_element_count(mesh)))) + element_owners = mesh%faces%face_element_list(1:surface_element_count(mesh)) - mesh => positions%mesh - if(has_faces(mesh)) then - allocate(sndgln(face_loc(mesh, 1) * unique_surface_element_count(mesh))) - call getsndgln(mesh, sndgln) - end if + call deallocate_faces(mesh) + call add_faces(mesh, sndgln = sndgln, boundary_ids=boundary_ids, & + element_owner=element_owners) + deallocate(element_owners) + else + call deallocate_faces(mesh) + call add_faces(mesh, sndgln = sndgln, boundary_ids=boundary_ids) + end if - nhalos = halo_count(mesh) - if((nhalos == 0).and.(.not.present(use_unns))) then - FLAbort("Need halos or unns to reorder the mesh.") - end if + if(allocated(coplanar_ids)) then + allocate(mesh%faces%coplanar_ids(size(coplanar_ids))) + mesh%faces%coplanar_ids = coplanar_ids + deallocate(coplanar_ids) + end if + deallocate(boundary_ids) - do ele = 1, element_count(mesh) - nodes => ele_nodes(mesh, ele) + end subroutine update_faces - if(present(use_unns)) then - unns = set2vector(use_unns(ele)) + end subroutine reorder_element_numbering + + subroutine remap_to_subdomain_scalar(parent_field,sub_field) + !!< remaps scalar fields from full domain to sub_domain: + type(scalar_field), intent(in) :: parent_field + type(scalar_field), intent(inout) :: sub_field + integer, dimension(:), pointer :: node_map + + assert(associated(sub_field%mesh%subdomain_mesh%node_list)) + node_map => sub_field%mesh%subdomain_mesh%node_list + + if(parent_field%field_type == FIELD_TYPE_CONSTANT) then + call set(sub_field,node_val(parent_field,1)) else - ! Get the universal numbers from the largest available halo - unns = halo_universal_numbers(mesh%halos(nhalos), nodes) + call set_all(sub_field, node_val(parent_field,node_map)) end if - call qsort(unns, unns_order) - call apply_permutation(nodes, unns_order) + end subroutine remap_to_subdomain_scalar - end do + subroutine remap_to_subdomain_vector(parent_field,sub_field) - ! Now we have the nodes in a known order. However, some elements may - ! be inverted. This is only an issue in 3D. + type(vector_field), intent(in) :: parent_field + type(vector_field), intent(inout) :: sub_field + integer, dimension(:), pointer :: node_map - if(mesh_dim(mesh) == 3) then - do ele = 1, element_count(mesh) - nodes => ele_nodes(mesh, ele) - if(simplex_volume(positions, ele) < 0.0) then - tmp = nodes(1) - nodes(1) = nodes(2) - nodes(2) = tmp - end if - end do - end if + assert(associated(sub_field%mesh%subdomain_mesh%node_list)) + node_map => sub_field%mesh%subdomain_mesh%node_list - call remove_eelist(mesh) - if(has_faces(mesh)) then - call update_faces(mesh, sndgln) - deallocate(sndgln) - end if + if(parent_field%field_type == FIELD_TYPE_CONSTANT) then + call set(sub_field,node_val(parent_field,1)) + else + call set_all(sub_field, node_val(parent_field,node_map)) + end if - contains + end subroutine remap_to_subdomain_vector - subroutine update_faces(mesh, sndgln) - type(mesh_type), intent(inout) :: mesh - integer, dimension(face_loc(mesh, 1) * unique_surface_element_count(mesh)), intent(in) :: sndgln + subroutine remap_to_subdomain_tensor(parent_field,sub_field) - integer, dimension(:), allocatable :: boundary_ids, coplanar_ids, element_owners + type(tensor_field), intent(in) :: parent_field + type(tensor_field), intent(inout) :: sub_field + integer, dimension(:), pointer :: node_map - assert(has_faces(mesh)) + assert(associated(sub_field%mesh%subdomain_mesh%node_list)) + node_map => sub_field%mesh%subdomain_mesh%node_list - if(associated(mesh%faces%coplanar_ids)) then - allocate(coplanar_ids(surface_element_count(mesh))) - coplanar_ids = mesh%faces%coplanar_ids + if(parent_field%field_type == FIELD_TYPE_CONSTANT) then + call set(sub_field,node_val(parent_field,1)) + else + call set_all(sub_field, node_val(parent_field,node_map)) end if - allocate(boundary_ids(1:unique_surface_element_count(mesh))) - boundary_ids = mesh%faces%boundary_ids(1:size(boundary_ids)) + end subroutine remap_to_subdomain_tensor + + subroutine remap_to_full_domain_scalar(sub_field,parent_field) + !!< remaps scalar fields from sub_domain to full_domain: + type(scalar_field), intent(in) :: sub_field + type(scalar_field), intent(inout) :: parent_field + integer, dimension(:), pointer :: node_map + integer :: inode - if (has_discontinuous_internal_boundaries(mesh)) then - allocate(element_owners((surface_element_count(mesh)))) - element_owners = mesh%faces%face_element_list(1:surface_element_count(mesh)) + assert(associated(sub_field%mesh%subdomain_mesh%node_list)) + node_map => sub_field%mesh%subdomain_mesh%node_list - call deallocate_faces(mesh) - call add_faces(mesh, sndgln = sndgln, boundary_ids=boundary_ids, & - element_owner=element_owners) - deallocate(element_owners) + if(parent_field%field_type == FIELD_TYPE_CONSTANT) then + call set(parent_field,node_val(sub_field,1)) else - call deallocate_faces(mesh) - call add_faces(mesh, sndgln = sndgln, boundary_ids=boundary_ids) + do inode = 1, size(node_map) + call set(parent_field, node_map(inode), node_val(sub_field,inode)) + end do end if - if(allocated(coplanar_ids)) then - allocate(mesh%faces%coplanar_ids(size(coplanar_ids))) - mesh%faces%coplanar_ids = coplanar_ids - deallocate(coplanar_ids) + end subroutine remap_to_full_domain_scalar + + subroutine remap_to_full_domain_vector(sub_field,parent_field) + type(vector_field), intent(in) :: sub_field + type(vector_field), intent(inout) :: parent_field + integer, dimension(:), pointer :: node_map + integer :: inode + + assert(associated(sub_field%mesh%subdomain_mesh%node_list)) + node_map => sub_field%mesh%subdomain_mesh%node_list + + if(parent_field%field_type == FIELD_TYPE_CONSTANT) then + call set(parent_field,node_val(sub_field,1)) + else + do inode = 1, size(node_map) + call set(parent_field, node_map(inode), node_val(sub_field,inode)) + end do end if - deallocate(boundary_ids) - end subroutine update_faces + end subroutine remap_to_full_domain_vector - end subroutine reorder_element_numbering + subroutine remap_to_full_domain_tensor(sub_field,parent_field) + type(tensor_field), intent(in) :: sub_field + type(tensor_field), intent(inout) :: parent_field + integer, dimension(:), pointer :: node_map + integer :: inode - subroutine remap_to_subdomain_scalar(parent_field,sub_field) - !!< remaps scalar fields from full domain to sub_domain: - type(scalar_field), intent(in) :: parent_field - type(scalar_field), intent(inout) :: sub_field - integer, dimension(:), pointer :: node_map - - assert(associated(sub_field%mesh%subdomain_mesh%node_list)) - node_map => sub_field%mesh%subdomain_mesh%node_list + assert(associated(sub_field%mesh%subdomain_mesh%node_list)) + node_map => sub_field%mesh%subdomain_mesh%node_list - if(parent_field%field_type == FIELD_TYPE_CONSTANT) then - call set(sub_field,node_val(parent_field,1)) - else - call set_all(sub_field, node_val(parent_field,node_map)) - end if + if(parent_field%field_type == FIELD_TYPE_CONSTANT) then + call set(parent_field,node_val(sub_field,1)) + else + do inode = 1, size(node_map) + call set(parent_field, node_map(inode), node_val(sub_field,inode)) + end do + end if + + end subroutine remap_to_full_domain_tensor + + function get_remapped_coordinates(positions, mesh) result(remapped_positions) + type(vector_field), intent(in):: positions + type(mesh_type), intent(inout):: mesh + type(vector_field):: remapped_positions + + integer:: stat + + call allocate(remapped_positions, positions%dim, mesh, "RemappedCoordinates") + call remap_field(positions, remapped_positions, stat=stat) + ! we allow stat==REMAP_ERR_UNPERIODIC_PERIODIC, to create periodic surface positions with coordinates + ! at the periodic boundary having a value that is only determined upto a random number of periodic mappings + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + ewrite(-1,*) 'Remapping of the coordinates just threw an error because' + ewrite(-1,*) 'the input coordinates are discontinuous and you are trying' + ewrite(-1,*) 'to remap them to a continuous field.' + FLAbort("Why are your coordinates discontinuous?") + else if ((stat/=0).and. & + (stat/=REMAP_ERR_UNPERIODIC_PERIODIC).and. & + (stat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & + (stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then + FLAbort('Unknown error when remapping coordinates') + end if + + end function get_remapped_coordinates + + function get_coordinates_remapped_to_surface(positions, surface_mesh, surface_element_list) result(surface_positions) + type(vector_field), intent(in):: positions + type(mesh_type), intent(inout):: surface_mesh + integer, dimension(:), intent(in):: surface_element_list + type(vector_field):: surface_positions + + integer:: stat + + call allocate(surface_positions, positions%dim, surface_mesh, "RemappedSurfaceCoordinates") + call remap_field_to_surface(positions, surface_positions, surface_element_list, stat=stat) + ! we allow stat==REMAP_ERR_UNPERIODIC_PERIODIC, to create periodic surface positions with coordinates + ! at the periodic boundary having a value that is only determined upto a random number of periodic mappings + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + ewrite(-1,*) 'Remapping of the coordinates just threw an error because' + ewrite(-1,*) 'the input coordinates are discontinuous and you are trying' + ewrite(-1,*) 'to remap them to a continuous field.' + FLAbort("Why are your coordinates discontinuous?") + else if ((stat/=0).and. & + (stat/=REMAP_ERR_UNPERIODIC_PERIODIC).and. & + (stat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & + (stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then + FLAbort('Unknown error in mapping coordinates from mesh to surface') + end if - end subroutine remap_to_subdomain_scalar + end function get_coordinates_remapped_to_surface - subroutine remap_to_subdomain_vector(parent_field,sub_field) + subroutine zero_bubble_vals_scalar(field) + type(scalar_field), intent(inout) :: field + integer :: ele - type(vector_field), intent(in) :: parent_field - type(vector_field), intent(inout) :: sub_field - integer, dimension(:), pointer :: node_map - - assert(associated(sub_field%mesh%subdomain_mesh%node_list)) - node_map => sub_field%mesh%subdomain_mesh%node_list - - if(parent_field%field_type == FIELD_TYPE_CONSTANT) then - call set(sub_field,node_val(parent_field,1)) - else - call set_all(sub_field, node_val(parent_field,node_map)) - end if - - end subroutine remap_to_subdomain_vector - - subroutine remap_to_subdomain_tensor(parent_field,sub_field) - - type(tensor_field), intent(in) :: parent_field - type(tensor_field), intent(inout) :: sub_field - integer, dimension(:), pointer :: node_map - - assert(associated(sub_field%mesh%subdomain_mesh%node_list)) - node_map => sub_field%mesh%subdomain_mesh%node_list - - if(parent_field%field_type == FIELD_TYPE_CONSTANT) then - call set(sub_field,node_val(parent_field,1)) - else - call set_all(sub_field, node_val(parent_field,node_map)) - end if - - end subroutine remap_to_subdomain_tensor - - subroutine remap_to_full_domain_scalar(sub_field,parent_field) - !!< remaps scalar fields from sub_domain to full_domain: - type(scalar_field), intent(in) :: sub_field - type(scalar_field), intent(inout) :: parent_field - integer, dimension(:), pointer :: node_map - integer :: inode - - assert(associated(sub_field%mesh%subdomain_mesh%node_list)) - node_map => sub_field%mesh%subdomain_mesh%node_list - - if(parent_field%field_type == FIELD_TYPE_CONSTANT) then - call set(parent_field,node_val(sub_field,1)) - else - do inode = 1, size(node_map) - call set(parent_field, node_map(inode), node_val(sub_field,inode)) - end do - end if - - end subroutine remap_to_full_domain_scalar - - subroutine remap_to_full_domain_vector(sub_field,parent_field) - type(vector_field), intent(in) :: sub_field - type(vector_field), intent(inout) :: parent_field - integer, dimension(:), pointer :: node_map - integer :: inode - - assert(associated(sub_field%mesh%subdomain_mesh%node_list)) - node_map => sub_field%mesh%subdomain_mesh%node_list - - if(parent_field%field_type == FIELD_TYPE_CONSTANT) then - call set(parent_field,node_val(sub_field,1)) - else - do inode = 1, size(node_map) - call set(parent_field, node_map(inode), node_val(sub_field,inode)) - end do - end if - - end subroutine remap_to_full_domain_vector - - subroutine remap_to_full_domain_tensor(sub_field,parent_field) - type(tensor_field), intent(in) :: sub_field - type(tensor_field), intent(inout) :: parent_field - integer, dimension(:), pointer :: node_map - integer :: inode - - assert(associated(sub_field%mesh%subdomain_mesh%node_list)) - node_map => sub_field%mesh%subdomain_mesh%node_list - - if(parent_field%field_type == FIELD_TYPE_CONSTANT) then - call set(parent_field,node_val(sub_field,1)) - else - do inode = 1, size(node_map) - call set(parent_field, node_map(inode), node_val(sub_field,inode)) - end do - end if - - end subroutine remap_to_full_domain_tensor - - function get_remapped_coordinates(positions, mesh) result(remapped_positions) - type(vector_field), intent(in):: positions - type(mesh_type), intent(inout):: mesh - type(vector_field):: remapped_positions - - integer:: stat - - call allocate(remapped_positions, positions%dim, mesh, "RemappedCoordinates") - call remap_field(positions, remapped_positions, stat=stat) - ! we allow stat==REMAP_ERR_UNPERIODIC_PERIODIC, to create periodic surface positions with coordinates - ! at the periodic boundary having a value that is only determined upto a random number of periodic mappings - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - ewrite(-1,*) 'Remapping of the coordinates just threw an error because' - ewrite(-1,*) 'the input coordinates are discontinuous and you are trying' - ewrite(-1,*) 'to remap them to a continuous field.' - FLAbort("Why are your coordinates discontinuous?") - else if ((stat/=0).and. & - (stat/=REMAP_ERR_UNPERIODIC_PERIODIC).and. & - (stat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & - (stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then - FLAbort('Unknown error when remapping coordinates') - end if - - end function get_remapped_coordinates - - function get_coordinates_remapped_to_surface(positions, surface_mesh, surface_element_list) result(surface_positions) - type(vector_field), intent(in):: positions - type(mesh_type), intent(inout):: surface_mesh - integer, dimension(:), intent(in):: surface_element_list - type(vector_field):: surface_positions - - integer:: stat - - call allocate(surface_positions, positions%dim, surface_mesh, "RemappedSurfaceCoordinates") - call remap_field_to_surface(positions, surface_positions, surface_element_list, stat=stat) - ! we allow stat==REMAP_ERR_UNPERIODIC_PERIODIC, to create periodic surface positions with coordinates - ! at the periodic boundary having a value that is only determined upto a random number of periodic mappings - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - ewrite(-1,*) 'Remapping of the coordinates just threw an error because' - ewrite(-1,*) 'the input coordinates are discontinuous and you are trying' - ewrite(-1,*) 'to remap them to a continuous field.' - FLAbort("Why are your coordinates discontinuous?") - else if ((stat/=0).and. & - (stat/=REMAP_ERR_UNPERIODIC_PERIODIC).and. & - (stat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & - (stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then - FLAbort('Unknown error in mapping coordinates from mesh to surface') - end if - - end function get_coordinates_remapped_to_surface - - subroutine zero_bubble_vals_scalar(field) - type(scalar_field), intent(inout) :: field - integer :: ele - - if (field%mesh%shape%numbering%type == ELEMENT_BUBBLE) then - do ele=1,ele_count(field) - call ele_zero_bubble_val(field, ele) - end do - end if + if (field%mesh%shape%numbering%type == ELEMENT_BUBBLE) then + do ele=1,ele_count(field) + call ele_zero_bubble_val(field, ele) + end do + end if - end subroutine zero_bubble_vals_scalar + end subroutine zero_bubble_vals_scalar - subroutine zero_bubble_vals_vector(field) - type(vector_field), intent(inout) :: field - integer :: ele + subroutine zero_bubble_vals_vector(field) + type(vector_field), intent(inout) :: field + integer :: ele - if (field%mesh%shape%numbering%type == ELEMENT_BUBBLE) then - do ele=1,ele_count(field) - call ele_zero_bubble_val(field, ele) - end do - end if + if (field%mesh%shape%numbering%type == ELEMENT_BUBBLE) then + do ele=1,ele_count(field) + call ele_zero_bubble_val(field, ele) + end do + end if - end subroutine zero_bubble_vals_vector + end subroutine zero_bubble_vals_vector - subroutine zero_bubble_vals_tensor(field) - type(tensor_field), intent(inout) :: field - integer :: ele + subroutine zero_bubble_vals_tensor(field) + type(tensor_field), intent(inout) :: field + integer :: ele - if (field%mesh%shape%numbering%type == ELEMENT_BUBBLE) then - do ele=1,ele_count(field) - call ele_zero_bubble_val(field, ele) - end do - end if + if (field%mesh%shape%numbering%type == ELEMENT_BUBBLE) then + do ele=1,ele_count(field) + call ele_zero_bubble_val(field, ele) + end do + end if - end subroutine zero_bubble_vals_tensor + end subroutine zero_bubble_vals_tensor - subroutine ele_zero_bubble_val_scalar(field, ele_number) - type(scalar_field), intent(inout) :: field - integer, intent(in) :: ele_number - integer, dimension(:), pointer :: e_nodes + subroutine ele_zero_bubble_val_scalar(field, ele_number) + type(scalar_field), intent(inout) :: field + integer, intent(in) :: ele_number + integer, dimension(:), pointer :: e_nodes - assert(field%mesh%shape%numbering%type == ELEMENT_BUBBLE) - assert(field%field_type == FIELD_TYPE_NORMAL) + assert(field%mesh%shape%numbering%type == ELEMENT_BUBBLE) + assert(field%field_type == FIELD_TYPE_NORMAL) - e_nodes => ele_nodes(field, ele_number) - field%val(e_nodes(ele_loc(field, ele_number))) = 0.0 + e_nodes => ele_nodes(field, ele_number) + field%val(e_nodes(ele_loc(field, ele_number))) = 0.0 - end subroutine ele_zero_bubble_val_scalar + end subroutine ele_zero_bubble_val_scalar - subroutine ele_zero_bubble_val_vector(field, ele_number) - type(vector_field), intent(inout) :: field - integer, intent(in) :: ele_number - integer, dimension(:), pointer :: e_nodes + subroutine ele_zero_bubble_val_vector(field, ele_number) + type(vector_field), intent(inout) :: field + integer, intent(in) :: ele_number + integer, dimension(:), pointer :: e_nodes - assert(field%mesh%shape%numbering%type == ELEMENT_BUBBLE) - assert(field%field_type == FIELD_TYPE_NORMAL) + assert(field%mesh%shape%numbering%type == ELEMENT_BUBBLE) + assert(field%field_type == FIELD_TYPE_NORMAL) - e_nodes => ele_nodes(field, ele_number) - field%val(:, e_nodes(ele_loc(field, ele_number))) = 0.0 + e_nodes => ele_nodes(field, ele_number) + field%val(:, e_nodes(ele_loc(field, ele_number))) = 0.0 - end subroutine ele_zero_bubble_val_vector + end subroutine ele_zero_bubble_val_vector - subroutine ele_zero_bubble_val_tensor(field, ele_number) - type(tensor_field), intent(inout) :: field - integer, intent(in) :: ele_number - integer, dimension(:), pointer :: e_nodes + subroutine ele_zero_bubble_val_tensor(field, ele_number) + type(tensor_field), intent(inout) :: field + integer, intent(in) :: ele_number + integer, dimension(:), pointer :: e_nodes - assert(field%mesh%shape%numbering%type == ELEMENT_BUBBLE) - assert(field%field_type == FIELD_TYPE_NORMAL) + assert(field%mesh%shape%numbering%type == ELEMENT_BUBBLE) + assert(field%field_type == FIELD_TYPE_NORMAL) - e_nodes => ele_nodes(field, ele_number) - field%val(:, :, e_nodes(ele_loc(field, ele_number))) = 0.0 + e_nodes => ele_nodes(field, ele_number) + field%val(:, :, e_nodes(ele_loc(field, ele_number))) = 0.0 - end subroutine ele_zero_bubble_val_tensor + end subroutine ele_zero_bubble_val_tensor end module fields_manipulation diff --git a/femtools/Futils.F90 b/femtools/Futils.F90 index 1e2f9da8bc..827b724ccc 100644 --- a/femtools/Futils.F90 +++ b/femtools/Futils.F90 @@ -28,412 +28,412 @@ #include "fdebug.h" module futils - !!< Some generic fortran utility functions. + !!< Some generic fortran utility functions. - use fldebug - use global_parameters, only : real_digits_10 + use fldebug + use global_parameters, only : real_digits_10 - implicit none + implicit none - interface real_format_len - module procedure real_format_non_padded_len, real_format_padded_len - end interface + interface real_format_len + module procedure real_format_non_padded_len, real_format_padded_len + end interface - interface real_format - module procedure real_format_non_padded, real_format_padded - end interface real_format + interface real_format + module procedure real_format_non_padded, real_format_padded + end interface real_format - interface nullify - module procedure nullify_integer_vector, nullify_integer_vector_vector, & + interface nullify + module procedure nullify_integer_vector, nullify_integer_vector_vector, & & nullify_real_vector, nullify_real_vector_vector - end interface nullify + end interface nullify - type real_vector + type real_vector #ifdef DDEBUG - real, dimension(:), pointer :: ptr=>null() + real, dimension(:), pointer :: ptr=>null() #else - real, dimension(:), pointer :: ptr + real, dimension(:), pointer :: ptr #endif - end type real_vector + end type real_vector - type real_matrix + type real_matrix #ifdef DDEBUG - real, dimension(:,:), pointer :: ptr=>null() + real, dimension(:,:), pointer :: ptr=>null() #else - real, dimension(:,:), pointer :: ptr + real, dimension(:,:), pointer :: ptr #endif - end type real_matrix + end type real_matrix - type integer_vector + type integer_vector #ifdef DDEBUG - integer, dimension(:), pointer :: ptr=>null() + integer, dimension(:), pointer :: ptr=>null() #else - integer, dimension(:), pointer :: ptr + integer, dimension(:), pointer :: ptr #endif - end type integer_vector + end type integer_vector - private + private - public :: real_format_len, real_format, nullify, real_vector, real_matrix,& - integer_vector, int2str, present_and_true, present_and_false, present_and_zero,& - present_and_nonzero, present_and_nonempty, free_unit, nth_digit, count_chars,& - multiindex, file_extension_len, file_extension, trim_file_extension_len,& - trim_file_extension, random_number_minmax, int2str_len, starts_with, tokenize + public :: real_format_len, real_format, nullify, real_vector, real_matrix,& + integer_vector, int2str, present_and_true, present_and_false, present_and_zero,& + present_and_nonzero, present_and_nonempty, free_unit, nth_digit, count_chars,& + multiindex, file_extension_len, file_extension, trim_file_extension_len,& + trim_file_extension, random_number_minmax, int2str_len, starts_with, tokenize contains - subroutine nullify_integer_vector(vector) - type(integer_vector), intent(inout) :: vector + subroutine nullify_integer_vector(vector) + type(integer_vector), intent(inout) :: vector - vector%ptr => null() + vector%ptr => null() - end subroutine nullify_integer_vector + end subroutine nullify_integer_vector - subroutine nullify_integer_vector_vector(vector) - type(integer_vector), dimension(:), intent(inout) :: vector + subroutine nullify_integer_vector_vector(vector) + type(integer_vector), dimension(:), intent(inout) :: vector - integer :: i + integer :: i - do i = 1, size(vector) - vector(i)%ptr => null() - end do + do i = 1, size(vector) + vector(i)%ptr => null() + end do - end subroutine nullify_integer_vector_vector + end subroutine nullify_integer_vector_vector - subroutine nullify_real_vector(vector) - type(real_vector), intent(inout) :: vector + subroutine nullify_real_vector(vector) + type(real_vector), intent(inout) :: vector - vector%ptr => null() + vector%ptr => null() - end subroutine nullify_real_vector + end subroutine nullify_real_vector - subroutine nullify_real_vector_vector(vector) - type(real_vector), dimension(:), intent(inout) :: vector + subroutine nullify_real_vector_vector(vector) + type(real_vector), dimension(:), intent(inout) :: vector - integer :: i + integer :: i - do i = 1, size(vector) - vector(i)%ptr => null() - end do + do i = 1, size(vector) + vector(i)%ptr => null() + end do - end subroutine nullify_real_vector_vector + end subroutine nullify_real_vector_vector - pure function present_and_true(flag) - logical :: present_and_true - logical, intent(in), optional :: flag + pure function present_and_true(flag) + logical :: present_and_true + logical, intent(in), optional :: flag - if (present(flag)) then - present_and_true=flag - else - present_and_true=.false. - end if - - end function present_and_true - - pure function present_and_false(flag) - logical :: present_and_false - logical, intent(in), optional :: flag + if (present(flag)) then + present_and_true=flag + else + present_and_true=.false. + end if - if (present(flag)) then - present_and_false=.not.flag - else - present_and_false=.false. - end if + end function present_and_true - end function present_and_false + pure function present_and_false(flag) + logical :: present_and_false + logical, intent(in), optional :: flag - pure function present_and_zero(var) - integer, optional, intent(in) :: var + if (present(flag)) then + present_and_false=.not.flag + else + present_and_false=.false. + end if - logical :: present_and_zero + end function present_and_false - if(present(var)) then - present_and_zero = (var == 0) - else - present_and_zero = .false. - end if + pure function present_and_zero(var) + integer, optional, intent(in) :: var - end function present_and_zero + logical :: present_and_zero - pure function present_and_nonzero(var) - integer, optional, intent(in) :: var + if(present(var)) then + present_and_zero = (var == 0) + else + present_and_zero = .false. + end if - logical :: present_and_nonzero + end function present_and_zero - if(present(var)) then - present_and_nonzero = (var /= 0) - else - present_and_nonzero = .false. - end if + pure function present_and_nonzero(var) + integer, optional, intent(in) :: var - end function present_and_nonzero + logical :: present_and_nonzero - pure function present_and_nonempty(var) - character(len = *), optional, intent(in) :: var + if(present(var)) then + present_and_nonzero = (var /= 0) + else + present_and_nonzero = .false. + end if - logical :: present_and_nonempty + end function present_and_nonzero - if(present(var)) then - present_and_nonempty = (len_trim(var) > 0) - else - present_and_nonempty = .false. - end if + pure function present_and_nonempty(var) + character(len = *), optional, intent(in) :: var - end function present_and_nonempty + logical :: present_and_nonempty - function free_unit() - !!< Find a free unit number. Start from unit 10 in order to ensure that - !!< we skip any preconnected units which may not be correctly identified - !!< on some compilers. - integer :: free_unit + if(present(var)) then + present_and_nonempty = (len_trim(var) > 0) + else + present_and_nonempty = .false. + end if - logical :: connected + end function present_and_nonempty - do free_unit=10, 99 + function free_unit() + !!< Find a free unit number. Start from unit 10 in order to ensure that + !!< we skip any preconnected units which may not be correctly identified + !!< on some compilers. + integer :: free_unit - inquire(unit=free_unit, opened=connected) + logical :: connected - if (.not.connected) return + do free_unit=10, 99 - end do + inquire(unit=free_unit, opened=connected) - FLAbort("No free unit numbers avalable") + if (.not.connected) return - end function + end do - pure function real_format_non_padded_len() result(length) - !!< Return the length of the format string for real data, without - !!< padding characters + FLAbort("No free unit numbers avalable") - integer :: length + end function - length = real_format_len(0) + pure function real_format_non_padded_len() result(length) + !!< Return the length of the format string for real data, without + !!< padding characters - end function real_format_non_padded_len + integer :: length - pure function real_format_padded_len(padding) result(length) - !!< Return the length of the format string for real data, with - !!< padding characters + length = real_format_len(0) - integer, intent(in) :: padding + end function real_format_non_padded_len - integer :: length + pure function real_format_padded_len(padding) result(length) + !!< Return the length of the format string for real data, with + !!< padding characters - ! See real_format comment - length = 2 + int2str_len(real_digits_10 + 10 + padding) + int2str_len(real_digits_10 + 2) + 1 + int2str_len(3) + integer, intent(in) :: padding - end function real_format_padded_len + integer :: length - function real_format_non_padded() result(format) - !!< Return a format string for real data, without padding characters + ! See real_format comment + length = 2 + int2str_len(real_digits_10 + 10 + padding) + int2str_len(real_digits_10 + 2) + 1 + int2str_len(3) - character(len = real_format_len()) :: format + end function real_format_padded_len - format = real_format(0) + function real_format_non_padded() result(format) + !!< Return a format string for real data, without padding characters - end function real_format_non_padded + character(len = real_format_len()) :: format - function real_format_padded(padding) result(format) - !!< Return a format string for real data, with padding characters + format = real_format(0) - integer, intent(in) :: padding + end function real_format_non_padded - character(len = real_format_len()) :: format + function real_format_padded(padding) result(format) + !!< Return a format string for real data, with padding characters - ! Construct: - ! (real_digits_10 + 2) + 8 + padding . (real_digits_10 + 2) e3 - ! (real_digits_10 + 2) seems to give sufficient digits to preserve - ! (1.0 + epsilon(1.0) > 1.0) in double precision writes. "8" (before ".") - ! is the minimum number of additional characters allowing a general real - ! to be written. 3 (after "e") is the minimum number of characters allowing - ! a general real exponent to be written. - format = "e" // int2str(real_digits_10 + 10 + padding) // "." // int2str(real_digits_10 + 2) // "e" // int2str(3) + integer, intent(in) :: padding - end function real_format_padded + character(len = real_format_len()) :: format - pure function nth_digit(number, digit) - !!< Return the nth digit of number. Useful for those infernal - !!< overloaded options. - !!< - !!< Digits are counted from the RIGHT. - integer :: nth_digit - integer, intent(in) :: number, digit + ! Construct: + ! (real_digits_10 + 2) + 8 + padding . (real_digits_10 + 2) e3 + ! (real_digits_10 + 2) seems to give sufficient digits to preserve + ! (1.0 + epsilon(1.0) > 1.0) in double precision writes. "8" (before ".") + ! is the minimum number of additional characters allowing a general real + ! to be written. 3 (after "e") is the minimum number of characters allowing + ! a general real exponent to be written. + format = "e" // int2str(real_digits_10 + 10 + padding) // "." // int2str(real_digits_10 + 2) // "e" // int2str(3) - ! The divisions strip the trailing digits while the mod strips the - ! leading digits. - nth_digit=mod(abs(number)/10**(digit-1), 10) + end function real_format_padded - end function nth_digit + pure function nth_digit(number, digit) + !!< Return the nth digit of number. Useful for those infernal + !!< overloaded options. + !!< + !!< Digits are counted from the RIGHT. + integer :: nth_digit + integer, intent(in) :: number, digit - pure function count_chars(string, sep) - character(len=*), intent(in) :: string - character(len=1), intent(in) :: sep - integer :: count_chars - integer :: i + ! The divisions strip the trailing digits while the mod strips the + ! leading digits. + nth_digit=mod(abs(number)/10**(digit-1), 10) - count_chars = 0 + end function nth_digit - do i=1,len(string) - if (string(i:i) == sep) then - count_chars = count_chars + 1 - end if - end do - end function count_chars - - function multiindex(string, sep) - character(len=*), intent(in) :: string - character(len=1), intent(in) :: sep - integer :: i, j - integer, dimension(count_chars(string, sep)) :: multiindex - - multiindex=0 - j=0 - - do i=1,len(string) - if (string(i:i) == sep) then - j = j + 1 - multiindex(j) = i - end if - end do - end function multiindex + pure function count_chars(string, sep) + character(len=*), intent(in) :: string + character(len=1), intent(in) :: sep + integer :: count_chars + integer :: i - pure function trim_file_extension_len(filename) result(length) - !!< Return the length of the supplied filename minus the file extension + count_chars = 0 - character(len = *), intent(in) :: filename + do i=1,len(string) + if (string(i:i) == sep) then + count_chars = count_chars + 1 + end if + end do + end function count_chars - integer :: length + function multiindex(string, sep) + character(len=*), intent(in) :: string + character(len=1), intent(in) :: sep + integer :: i, j + integer, dimension(count_chars(string, sep)) :: multiindex - do length = len_trim(filename), 1, -1 - if(filename(length:length) == ".") then - exit - end if - end do + multiindex=0 + j=0 - length = length - 1 + do i=1,len(string) + if (string(i:i) == sep) then + j = j + 1 + multiindex(j) = i + end if + end do + end function multiindex - end function trim_file_extension_len + pure function trim_file_extension_len(filename) result(length) + !!< Return the length of the supplied filename minus the file extension - pure function file_extension_len(filename) result(length) - !!< Return the length of the file extension of the supplied filename - !!< (including the ".") + character(len = *), intent(in) :: filename - character(len = *), intent(in) :: filename + integer :: length - integer :: length + do length = len_trim(filename), 1, -1 + if(filename(length:length) == ".") then + exit + end if + end do - length = len(filename) - trim_file_extension_len(filename) + length = length - 1 - end function file_extension_len + end function trim_file_extension_len - function file_extension(filename) - !!< Return the file extension of the supplied filename (including the ".") + pure function file_extension_len(filename) result(length) + !!< Return the length of the file extension of the supplied filename + !!< (including the ".") - character(len = *), intent(in) :: filename + character(len = *), intent(in) :: filename - character(len = file_extension_len(filename)) :: file_extension + integer :: length - file_extension = filename(len(filename) - len(file_extension) + 1:) + length = len(filename) - trim_file_extension_len(filename) - end function file_extension + end function file_extension_len - function trim_file_extension(filename) - !!< Trim the file extension from the supplied filename + function file_extension(filename) + !!< Return the file extension of the supplied filename (including the ".") - character(len = *), intent(in) :: filename + character(len = *), intent(in) :: filename - character(len = trim_file_extension_len(filename)) :: trim_file_extension + character(len = file_extension_len(filename)) :: file_extension - trim_file_extension = filename(:len(trim_file_extension)) + file_extension = filename(len(filename) - len(file_extension) + 1:) - end function trim_file_extension + end function file_extension - function random_number_minmax(min, max) result(rand) - real, intent(in) :: min, max - real :: rand + function trim_file_extension(filename) + !!< Trim the file extension from the supplied filename - call random_number(rand) - rand = (max - min) * rand - rand = rand + min - end function random_number_minmax + character(len = *), intent(in) :: filename - pure function int2str_len(i) + character(len = trim_file_extension_len(filename)) :: trim_file_extension - !!< Count number of digits in i. + trim_file_extension = filename(:len(trim_file_extension)) - integer, intent(in) :: i - integer :: int2str_len + end function trim_file_extension - if(i==0) then - int2str_len=1 - else if (i>0) then - int2str_len = floor(log10(real(i)))+1 - else - int2str_len = floor(log10(abs(real(i))))+2 - end if + function random_number_minmax(min, max) result(rand) + real, intent(in) :: min, max + real :: rand - end function int2str_len + call random_number(rand) + rand = (max - min) * rand + rand = rand + min + end function random_number_minmax - function int2str (i) + pure function int2str_len(i) - !!< Convert integer i into a string. - !!< This should only be used when forming option strings. + !!< Count number of digits in i. - integer, intent(in) :: i - character(len=int2str_len(i)) :: int2str + integer, intent(in) :: i + integer :: int2str_len - write(int2str,"(i0)") i + if(i==0) then + int2str_len=1 + else if (i>0) then + int2str_len = floor(log10(real(i)))+1 + else + int2str_len = floor(log10(abs(real(i))))+2 + end if - end function int2str + end function int2str_len - pure function starts_with(string, start) - !!< Auxillary function, returns .true. if 'string' starts with 'start' - logical :: starts_with + function int2str (i) - character(len=*), intent(in):: string, start + !!< Convert integer i into a string. + !!< This should only be used when forming option strings. - if (len(start)>len(string)) then - starts_with=.false. - else - starts_with= string(1:len(start))==start - end if + integer, intent(in) :: i + character(len=int2str_len(i)) :: int2str - end function starts_with + write(int2str,"(i0)") i - subroutine tokenize(string, tokens, delimiter) - !!< Split the supplied string with the supplied delimiter. tokens is - !!< allocated by this routine. Note that the whole of string is parsed and - !!< compared with the whole of delimiter - it is the callers responsibility - !!< to do any necessary trimming. + end function int2str - character(len = *), intent(in) :: string - character(len = *), dimension(:), allocatable, intent(out) :: tokens - character(len = *), intent(in) :: delimiter + pure function starts_with(string, start) + !!< Auxillary function, returns .true. if 'string' starts with 'start' + logical :: starts_with - integer :: end_index, i, tokens_size, start_index + character(len=*), intent(in):: string, start - tokens_size = 1 - do i = 1, len(string) - len(delimiter) + 1 - if(string(i:i + len(delimiter) - 1) == delimiter) then - tokens_size = tokens_size + 1 - end if - end do - allocate(tokens(tokens_size)) - - start_index = 1 - end_index = -len(delimiter) - do i = 1, tokens_size - if(i == tokens_size) then - end_index = len(string) + if (len(start)>len(string)) then + starts_with=.false. else - end_index = end_index + index(string(start_index:), delimiter) + len(delimiter) - 1 + starts_with= string(1:len(start))==start end if - tokens(i) = string(start_index:end_index) - start_index = end_index + len(delimiter) + 1 - tokens(i) = adjustl(tokens(i)) - end do - assert(start_index == len(string) + 1 + len(delimiter)) - end subroutine tokenize + end function starts_with + + subroutine tokenize(string, tokens, delimiter) + !!< Split the supplied string with the supplied delimiter. tokens is + !!< allocated by this routine. Note that the whole of string is parsed and + !!< compared with the whole of delimiter - it is the callers responsibility + !!< to do any necessary trimming. + + character(len = *), intent(in) :: string + character(len = *), dimension(:), allocatable, intent(out) :: tokens + character(len = *), intent(in) :: delimiter + + integer :: end_index, i, tokens_size, start_index + + tokens_size = 1 + do i = 1, len(string) - len(delimiter) + 1 + if(string(i:i + len(delimiter) - 1) == delimiter) then + tokens_size = tokens_size + 1 + end if + end do + allocate(tokens(tokens_size)) + + start_index = 1 + end_index = -len(delimiter) + do i = 1, tokens_size + if(i == tokens_size) then + end_index = len(string) + else + end_index = end_index + index(string(start_index:), delimiter) + len(delimiter) - 1 + end if + tokens(i) = string(start_index:end_index) + start_index = end_index + len(delimiter) + 1 + tokens(i) = adjustl(tokens(i)) + end do + assert(start_index == len(string) + 1 + len(delimiter)) + + end subroutine tokenize end module futils diff --git a/femtools/GMSH_Common.F90 b/femtools/GMSH_Common.F90 index 1ab9ba1bd7..2c706938c7 100644 --- a/femtools/GMSH_Common.F90 +++ b/femtools/GMSH_Common.F90 @@ -32,178 +32,178 @@ module gmsh_common - character(len=3), parameter :: GMSHVersionStr = "2.1" - integer, parameter :: asciiFormat = 0 - integer, parameter :: binaryFormat = 1 - ! Anyway to automatically calc this in Fortran? - integer, parameter :: doubleNumBytes = 8 + character(len=3), parameter :: GMSHVersionStr = "2.1" + integer, parameter :: asciiFormat = 0 + integer, parameter :: binaryFormat = 1 + ! Anyway to automatically calc this in Fortran? + integer, parameter :: doubleNumBytes = 8 - integer, parameter :: longStringLen = 1000 - real, parameter :: verySmall = 10e-10 + integer, parameter :: longStringLen = 1000 + real, parameter :: verySmall = 10e-10 - ! For each type, the number of nodes. -1 means unsupported - integer, dimension(15) :: elementNumNodes = (/ & - 2, 3, 4, 4, 8, & - -1, -1, -1, -1, -1, -1, -1, -1, -1, 1 /) + ! For each type, the number of nodes. -1 means unsupported + integer, dimension(15) :: elementNumNodes = (/ & + 2, 3, 4, 4, 8, & + -1, -1, -1, -1, -1, -1, -1, -1, -1, 1 /) - type GMSHnode - integer :: nodeID, columnID - double precision :: x(3) - ! Currently unused - ! real, pointer :: properties(:) - end type GMSHnode + type GMSHnode + integer :: nodeID, columnID + double precision :: x(3) + ! Currently unused + ! real, pointer :: properties(:) + end type GMSHnode - type GMSHelement - integer :: elementID, type, numTags - integer, pointer :: tags(:), nodeIDs(:) - end type GMSHelement + type GMSHelement + integer :: elementID, type, numTags + integer, pointer :: tags(:), nodeIDs(:) + end type GMSHelement contains - ! ----------------------------------------------------------------- - ! Change already-open file to ASCII formatting - ! Involves a bit of sneaky code. + ! ----------------------------------------------------------------- + ! Change already-open file to ASCII formatting + ! Involves a bit of sneaky code. - subroutine ascii_formatting(fd, filename, readWriteStr) - integer fd - character(len=*) :: filename, readWriteStr + subroutine ascii_formatting(fd, filename, readWriteStr) + integer fd + character(len=*) :: filename, readWriteStr - integer position + integer position - inquire(fd, POS=position) - close(fd) + inquire(fd, POS=position) + close(fd) - select case( trim(readWriteStr) ) + select case( trim(readWriteStr) ) - case("read") - open( fd, file=trim(filename), action="read", form="formatted", & + case("read") + open( fd, file=trim(filename), action="read", form="formatted", & access="stream") - read( fd, "(I1)", POS=position, ADVANCE="no" ) + read( fd, "(I1)", POS=position, ADVANCE="no" ) - case("write") - open( fd, file=trim(filename), action="write", form="formatted", & + case("write") + open( fd, file=trim(filename), action="write", form="formatted", & access="stream", position="append") - end select + end select - end subroutine ascii_formatting + end subroutine ascii_formatting - ! ----------------------------------------------------------------- - ! Change already-open file to binary formatting - ! Sneaky code, as above. + ! ----------------------------------------------------------------- + ! Change already-open file to binary formatting + ! Sneaky code, as above. - subroutine binary_formatting(fd, filename, readWriteStr) - integer fd - character(len=*) filename, readWriteStr + subroutine binary_formatting(fd, filename, readWriteStr) + integer fd + character(len=*) filename, readWriteStr - integer position + integer position - inquire(fd, POS=position) - close(fd) + inquire(fd, POS=position) + close(fd) - select case( trim(readWriteStr) ) + select case( trim(readWriteStr) ) - case("read") - open( fd, file=trim(filename), action="read", form="unformatted", & + case("read") + open( fd, file=trim(filename), action="read", form="unformatted", & access="stream") - read( fd, POS=position ) + read( fd, POS=position ) - case("write") - open( fd, file=trim(filename), action="write", form="unformatted", & + case("write") + open( fd, file=trim(filename), action="write", form="unformatted", & access="stream", position="append") - end select + end select - end subroutine binary_formatting + end subroutine binary_formatting - ! ----------------------------------------------------------------- - ! Reorder to Fluidity node ordering + ! ----------------------------------------------------------------- + ! Reorder to Fluidity node ordering - subroutine toFluidityElementNodeOrdering( oldList, elemType ) - integer, pointer :: oldList(:) - integer, dimension(size(oldList)) :: nodeOrder, flNodeList - integer i, elemType + subroutine toFluidityElementNodeOrdering( oldList, elemType ) + integer, pointer :: oldList(:) + integer, dimension(size(oldList)) :: nodeOrder, flNodeList + integer i, elemType - numNodes = size(oldList) + numNodes = size(oldList) - ! Specify node ordering - select case( elemType ) - ! Quads - case (3) - nodeOrder = (/1, 2, 4, 3/) - ! Hexahedron - case (5) - nodeOrder = (/1, 2, 4, 3, 5, 6, 8, 7/) - case default - do i=1, numNodes - nodeOrder(i) = i - end do - end select + ! Specify node ordering + select case( elemType ) + ! Quads + case (3) + nodeOrder = (/1, 2, 4, 3/) + ! Hexahedron + case (5) + nodeOrder = (/1, 2, 4, 3, 5, 6, 8, 7/) + case default + do i=1, numNodes + nodeOrder(i) = i + end do + end select - ! Reorder nodes - do i=1, numNodes - flNodeList(i) = oldList( nodeOrder(i) ) - end do + ! Reorder nodes + do i=1, numNodes + flNodeList(i) = oldList( nodeOrder(i) ) + end do - ! Allocate to original list, and dealloc temp list. - oldList(:) = flNodeList(:) + ! Allocate to original list, and dealloc temp list. + oldList(:) = flNodeList(:) - end subroutine toFluidityElementNodeOrdering + end subroutine toFluidityElementNodeOrdering - ! ----------------------------------------------------------------- - ! Reorder Fluidity node ordering to GMSH + ! ----------------------------------------------------------------- + ! Reorder Fluidity node ordering to GMSH - subroutine toGMSHElementNodeOrdering( oldList, elemType ) - integer, pointer :: oldList(:) - integer, dimension(size(oldList)) :: nodeOrder, gmshNodeList - integer i, elemType + subroutine toGMSHElementNodeOrdering( oldList, elemType ) + integer, pointer :: oldList(:) + integer, dimension(size(oldList)) :: nodeOrder, gmshNodeList + integer i, elemType - numNodes = size(oldList) + numNodes = size(oldList) - ! Specify node ordering - select case( elemType ) - ! Quads - case (3) - nodeOrder = (/1, 2, 4, 3/) - ! Hexahedron - case (5) - nodeOrder = (/1, 2, 4, 3, 5, 6, 8, 7/) + ! Specify node ordering + select case( elemType ) + ! Quads + case (3) + nodeOrder = (/1, 2, 4, 3/) + ! Hexahedron + case (5) + nodeOrder = (/1, 2, 4, 3, 5, 6, 8, 7/) - case default - do i=1, numNodes - nodeOrder(i) = i - end do - end select + case default + do i=1, numNodes + nodeOrder(i) = i + end do + end select - ! Reorder nodes - do i=1, numNodes - gmshNodeList(i) = oldList( nodeOrder(i) ) - end do + ! Reorder nodes + do i=1, numNodes + gmshNodeList(i) = oldList( nodeOrder(i) ) + end do - ! Allocate to original list, and dealloc temp list. - oldList(:) = gmshNodeList(:) + ! Allocate to original list, and dealloc temp list. + oldList(:) = gmshNodeList(:) - end subroutine toGMSHElementNodeOrdering + end subroutine toGMSHElementNodeOrdering - subroutine deallocateElementList( elements ) - type(GMSHelement), pointer :: elements(:) - integer i + subroutine deallocateElementList( elements ) + type(GMSHelement), pointer :: elements(:) + integer i - do i = 1, size(elements) - deallocate(elements(i)%tags) - deallocate(elements(i)%nodeIDs) - end do + do i = 1, size(elements) + deallocate(elements(i)%tags) + deallocate(elements(i)%nodeIDs) + end do - deallocate( elements ) + deallocate( elements ) - end subroutine deallocateElementList + end subroutine deallocateElementList end module gmsh_common diff --git a/femtools/Generic_interface.F90 b/femtools/Generic_interface.F90 index 477bb30d55..638f614b16 100644 --- a/femtools/Generic_interface.F90 +++ b/femtools/Generic_interface.F90 @@ -26,126 +26,126 @@ ! USA #include "fdebug.h" module generic_interface - !!< This module provides routines for setting fields and boundary - !!< conditions using generic functions provided in strings. - use fldebug - use fields - implicit none - - interface set_from_generic_function - module procedure set_from_generic_function_scalar,& - & set_values_from_generic_scalar - - subroutine set_from_external_function_scalar(function, function_len,& - & nodes, x, y, z, result, stat) - !! Interface to c wrapper function. - integer, intent(in) :: function_len - character(len=function_len) :: function - integer, intent(in) :: nodes - real, dimension(nodes), intent(in) :: x, y, z - real, dimension(nodes), intent(out) :: result - integer, intent(out) :: stat - end subroutine set_from_external_function_scalar - end interface - - private - - public :: set_from_generic_function, set_from_external_function_scalar + !!< This module provides routines for setting fields and boundary + !!< conditions using generic functions provided in strings. + use fldebug + use fields + implicit none + + interface set_from_generic_function + module procedure set_from_generic_function_scalar,& + & set_values_from_generic_scalar + + subroutine set_from_external_function_scalar(function, function_len,& + & nodes, x, y, z, result, stat) + !! Interface to c wrapper function. + integer, intent(in) :: function_len + character(len=function_len) :: function + integer, intent(in) :: nodes + real, dimension(nodes), intent(in) :: x, y, z + real, dimension(nodes), intent(out) :: result + integer, intent(out) :: stat + end subroutine set_from_external_function_scalar + end interface + + private + + public :: set_from_generic_function, set_from_external_function_scalar contains - subroutine set_from_generic_function_scalar(field, func, position) - !!< Set the values at the nodes of field using the generic function - !!< specified in the string func. The position field is used to - !!< determine the locations of the nodes. - type(scalar_field), intent(inout) :: field - !! Func is the string to execute on the command line to start the - !! generic function. - character(len=*), intent(in) :: func - type(vector_field), intent(in), target :: position - - type(vector_field) :: lposition - real, dimension(:), pointer :: x, y, z - integer :: stat, dim - - dim=mesh_dim(position) - - if (dim/=3) then - FLExit("Generic functions are only supported for 3d scalar fields") - end if - - if (field%mesh==position%mesh) then - x=>position%val(1,:) - - if (dim>1) then - y=>position%val(2,:) - - if (dim>2) then - z=>position%val(3,:) - end if - end if - else - ! Remap position first. - call allocate(lposition, dim, field%mesh, "Local Position") - call remap_field(position, lposition) - - x=>lposition%val(1,:) - - if (dim>1) then - y=>lposition%val(2,:) - - if (dim>2) then - z=>lposition%val(3,:) - end if - end if - end if - - call set_from_external_function_scalar(func, len(func), & - & node_count(field), x, y, z, field%val, stat) - - if (stat/=0) then - ewrite(0,*) "Generic error, function was:" - ewrite(0,*) func - FLExit("Dying") - end if - - if (has_references(lposition)) then - call deallocate(lposition) - end if - - end subroutine set_from_generic_function_scalar - - subroutine set_values_from_generic_scalar(values, func, x, y, z) - !!< Given a list of positions evaluate the generic function - !!< specified in the string func at those points. - real, dimension(:), intent(inout) :: values - !! Func is the string to execute on the command line to start the - !! generic function. - character(len=*), intent(in) :: func - real, dimension(size(values)), target :: x - real, dimension(size(values)), optional, target :: y - real, dimension(size(values)), optional, target :: z - - real, dimension(:), pointer :: lx, ly, lz - integer :: stat, dim - - if (dim/=3) then - FLExit("Generic functions are only supported for 3d scalar fields") - end if - - lx=>x - ly=>y - lz=>z - - call set_from_external_function_scalar(func, len(func), & - & size(values), lx, ly, lz, values, stat) - - if (stat/=0) then - ewrite(0,*) "Generic error, function was:" - ewrite(0,*) func - FLExit("Dying") - end if - - end subroutine set_values_from_generic_scalar + subroutine set_from_generic_function_scalar(field, func, position) + !!< Set the values at the nodes of field using the generic function + !!< specified in the string func. The position field is used to + !!< determine the locations of the nodes. + type(scalar_field), intent(inout) :: field + !! Func is the string to execute on the command line to start the + !! generic function. + character(len=*), intent(in) :: func + type(vector_field), intent(in), target :: position + + type(vector_field) :: lposition + real, dimension(:), pointer :: x, y, z + integer :: stat, dim + + dim=mesh_dim(position) + + if (dim/=3) then + FLExit("Generic functions are only supported for 3d scalar fields") + end if + + if (field%mesh==position%mesh) then + x=>position%val(1,:) + + if (dim>1) then + y=>position%val(2,:) + + if (dim>2) then + z=>position%val(3,:) + end if + end if + else + ! Remap position first. + call allocate(lposition, dim, field%mesh, "Local Position") + call remap_field(position, lposition) + + x=>lposition%val(1,:) + + if (dim>1) then + y=>lposition%val(2,:) + + if (dim>2) then + z=>lposition%val(3,:) + end if + end if + end if + + call set_from_external_function_scalar(func, len(func), & + & node_count(field), x, y, z, field%val, stat) + + if (stat/=0) then + ewrite(0,*) "Generic error, function was:" + ewrite(0,*) func + FLExit("Dying") + end if + + if (has_references(lposition)) then + call deallocate(lposition) + end if + + end subroutine set_from_generic_function_scalar + + subroutine set_values_from_generic_scalar(values, func, x, y, z) + !!< Given a list of positions evaluate the generic function + !!< specified in the string func at those points. + real, dimension(:), intent(inout) :: values + !! Func is the string to execute on the command line to start the + !! generic function. + character(len=*), intent(in) :: func + real, dimension(size(values)), target :: x + real, dimension(size(values)), optional, target :: y + real, dimension(size(values)), optional, target :: z + + real, dimension(:), pointer :: lx, ly, lz + integer :: stat, dim + + if (dim/=3) then + FLExit("Generic functions are only supported for 3d scalar fields") + end if + + lx=>x + ly=>y + lz=>z + + call set_from_external_function_scalar(func, len(func), & + & size(values), lx, ly, lz, values, stat) + + if (stat/=0) then + ewrite(0,*) "Generic error, function was:" + ewrite(0,*) func + FLExit("Dying") + end if + + end subroutine set_values_from_generic_scalar end module generic_interface diff --git a/femtools/Global_Numbering.F90 b/femtools/Global_Numbering.F90 index 1c1c2a297f..ae604e2887 100644 --- a/femtools/Global_Numbering.F90 +++ b/femtools/Global_Numbering.F90 @@ -27,182 +27,182 @@ #include "fdebug.h" module global_numbering - ! ********************************************************************** - ! Module to construct the global node numbering map for elements of a - ! given degree. - use fldebug - use element_numbering - use elements - use mpi_interfaces - use halo_data_types - use parallel_tools - use halos_base - use halos_debug - use halos_allocates - use sparse_tools - use fields_data_types - use fields_base - use adjacency_lists - use linked_lists - use halos_numbering - use halos_ownership - - implicit none - - private - - public :: make_global_numbering_DG, make_boundary_numbering,& - & make_global_numbering, element_halo_communicate_visibility, & - & make_global_numbering_trace + ! ********************************************************************** + ! Module to construct the global node numbering map for elements of a + ! given degree. + use fldebug + use element_numbering + use elements + use mpi_interfaces + use halo_data_types + use parallel_tools + use halos_base + use halos_debug + use halos_allocates + use sparse_tools + use fields_data_types + use fields_base + use adjacency_lists + use linked_lists + use halos_numbering + use halos_ownership + + implicit none + + private + + public :: make_global_numbering_DG, make_boundary_numbering,& + & make_global_numbering, element_halo_communicate_visibility, & + & make_global_numbering_trace contains - subroutine make_global_numbering_DG(new_nonods, new_ndglno, Totele,& - & element, element_halos, new_halos) - ! Construct a global node numbering for the solution variables in a - ! Discontinuous Galerkin simulation. This is trivial. - ! - ! Note that this code is broken for mixed element meshes. - integer, intent(in) :: totele - type(element_type), intent(in) :: element + subroutine make_global_numbering_DG(new_nonods, new_ndglno, Totele,& + & element, element_halos, new_halos) + ! Construct a global node numbering for the solution variables in a + ! Discontinuous Galerkin simulation. This is trivial. + ! + ! Note that this code is broken for mixed element meshes. + integer, intent(in) :: totele + type(element_type), intent(in) :: element - integer, dimension(:), intent(out) :: new_ndglno - integer, intent(out) :: new_nonods - type(halo_type), dimension(:), intent(in), optional :: element_halos - type(halo_type), dimension(:), intent(out), optional :: new_halos + integer, dimension(:), intent(out) :: new_ndglno + integer, intent(out) :: new_nonods + type(halo_type), dimension(:), intent(in), optional :: element_halos + type(halo_type), dimension(:), intent(out), optional :: new_halos - integer :: i + integer :: i - new_nonods=totele*element%loc + new_nonods=totele*element%loc - forall (i=1:new_nonods) - new_ndglno(i)=i - end forall + forall (i=1:new_nonods) + new_ndglno(i)=i + end forall - if (.not.present(element_halos)) return - assert(present(new_halos)) - assert(size(element_halos)==size(new_halos)) + if (.not.present(element_halos)) return + assert(present(new_halos)) + assert(size(element_halos)==size(new_halos)) - do i=1,size(new_halos) - call make_halo_dg(element, element_halos(i), new_halos(i)) - end do + do i=1,size(new_halos) + call make_halo_dg(element, element_halos(i), new_halos(i)) + end do - contains + contains - subroutine make_halo_dg(element, element_halo, new_halo) - !!< This routine constructs a node halo given an element halo. - type(element_type), intent(in) :: element - type(halo_type), intent(in) :: element_halo - type(halo_type), intent(out) :: new_halo + subroutine make_halo_dg(element, element_halo, new_halo) + !!< This routine constructs a node halo given an element halo. + type(element_type), intent(in) :: element + type(halo_type), intent(in) :: element_halo + type(halo_type), intent(out) :: new_halo - integer, dimension(size(element_halo%sends)) :: nsends - integer, dimension(size(element_halo%receives)) :: nreceives + integer, dimension(size(element_halo%sends)) :: nsends + integer, dimension(size(element_halo%receives)) :: nreceives - integer :: i,j,k, nloc + integer :: i,j,k, nloc - nloc=element%loc + nloc=element%loc - do i=1, size(nsends) - nsends(i)=nloc*size(element_halo%sends(i)%ptr) - end do - do i=1, size(nreceives) - nreceives(i)=nloc*size(element_halo%receives(i)%ptr) - end do + do i=1, size(nsends) + nsends(i)=nloc*size(element_halo%sends(i)%ptr) + end do + do i=1, size(nreceives) + nreceives(i)=nloc*size(element_halo%receives(i)%ptr) + end do - call allocate(new_halo, & - nsends, & - nreceives, & + call allocate(new_halo, & + nsends, & + nreceives, & !! Query what is the naming convention for halos. - name=trim(halo_name(element_halo)) // "DG", & - nprocs=element_halo%nprocs, & - nowned_nodes=element_halo%nowned_nodes*element%loc, & - data_type=HALO_TYPE_DG_NODE, & - ordering_scheme=halo_ordering_scheme(element_halo)) + name=trim(halo_name(element_halo)) // "DG", & + nprocs=element_halo%nprocs, & + nowned_nodes=element_halo%nowned_nodes*element%loc, & + data_type=HALO_TYPE_DG_NODE, & + ordering_scheme=halo_ordering_scheme(element_halo)) - do i=1, size(nsends) - do j=1,size(element_halo%sends(i)%ptr) + do i=1, size(nsends) + do j=1,size(element_halo%sends(i)%ptr) - new_halo%sends(i)%ptr((j-1)*nloc+1:j*nloc)& - =(element_halo%sends(i)%ptr(j)-1)*nloc + (/(k,k=1,nloc)/) + new_halo%sends(i)%ptr((j-1)*nloc+1:j*nloc)& + =(element_halo%sends(i)%ptr(j)-1)*nloc + (/(k,k=1,nloc)/) + end do end do - end do - do i=1, size(nreceives) - do j=1,size(element_halo%receives(i)%ptr) + do i=1, size(nreceives) + do j=1,size(element_halo%receives(i)%ptr) - new_halo%receives(i)%ptr((j-1)*nloc+1:j*nloc)& - =(element_halo%receives(i)%ptr(j)-1)*nloc + (/(k,k=1,nloc)/) + new_halo%receives(i)%ptr((j-1)*nloc+1:j*nloc)& + =(element_halo%receives(i)%ptr(j)-1)*nloc + (/(k,k=1,nloc)/) + end do end do - end do - call create_global_to_universal_numbering(new_halo) - call create_ownership(new_halo) - - end subroutine make_halo_dg - - - end subroutine make_global_numbering_DG - - subroutine make_global_numbering_trace(mesh) - ! Construct a global node numbering for a trace mesh - ! - ! Note that this code is broken for mixed element meshes. - type(mesh_type), intent(inout) :: mesh - ! - integer :: ele, totele, ni, ele_2, current_global_index - integer, pointer, dimension(:) :: neigh - integer :: face_1,face_2,nfaces,i,face_loc, nloc - - totele = mesh%elements - face_loc = mesh%faces%shape%loc - nloc = mesh%shape%loc - - !count up how many faces there are - nfaces = 0 - do ele = 1, totele - neigh => ele_neigh(mesh,ele) - do ni = 1, size(neigh) - ele_2 = neigh(ni) - if(ele_2 ele_neigh(mesh,ele) - do ni = 1, size(neigh) - ele_2 = neigh(ni) - if(ele_2 ele_neigh(mesh,ele) + do ni = 1, size(neigh) + ele_2 = neigh(ni) + if(ele_2 ele_neigh(mesh,ele) + do ni = 1, size(neigh) + ele_2 = neigh(ni) + if(ele_20) then + !it's not a domain boundary + !not quite sure how this works in parallel + face_2=ele_face(mesh, ele_2, ele) + mesh%ndglno((ele_2-1)*nloc+face_local_nodes(mesh,face_2))& &=current_global_index+(/(i, i=1,face_loc)/) - if(ele_2>0) then - !it's not a domain boundary - !not quite sure how this works in parallel - face_2=ele_face(mesh, ele_2, ele) - mesh%ndglno((ele_2-1)*nloc+face_local_nodes(mesh,face_2))& - &=current_global_index+(/(i, i=1,face_loc)/) - end if - current_global_index = current_global_index + & - & mesh%faces%shape%loc - end if - end do - end do - if(current_global_index /= mesh%nodes) then - FLAbort('bad global index count in make_global_numbering_trace') - end if - if(any(mesh%ndglno==0)) then - FLAbort('Failed to fully populate trace mesh ndglno') - end if - - end subroutine make_global_numbering_trace + end if + current_global_index = current_global_index + & + & mesh%faces%shape%loc + end if + end do + end do + if(current_global_index /= mesh%nodes) then + FLAbort('bad global index count in make_global_numbering_trace') + end if + if(any(mesh%ndglno==0)) then + FLAbort('Failed to fully populate trace mesh ndglno') + end if + + end subroutine make_global_numbering_trace !!$ subroutine make_global_numbering_nc & !!$ (new_nonods, new_ndglno, Nonods, Totele, NDGLNO) @@ -288,380 +288,380 @@ end subroutine make_global_numbering_trace !!$ !!$ end subroutine make_global_numbering_nc - subroutine make_global_numbering & - (new_nonods, new_ndglno, Nonods, Totele, NDGLNO, element, halos,& - & element_halo, new_halos) - ! Construct the global node numbering based on the node numbering for - ! linear tets given in NDGLNO. - integer, intent(in) :: nonods, totele - integer, intent(in), dimension(:), target :: ndglno - type(element_type), intent(in) :: element - !! The level 1 and 2 halos associated with the incoming mesh. - type(halo_type), dimension(:), intent(in), optional :: halos - !! The full element halo associated with these meshes. - type(halo_type), intent(in), optional :: element_halo - !! The level 1 and 2 halos associated with the new mesh. - type(halo_type), dimension(:), intent(out), optional :: new_halos - - integer, dimension(:), intent(out) :: new_ndglno - integer, intent(out) :: new_nonods - - ! Adjacency lists. - type(csr_sparsity) :: NEList, NNList, EEList - - logical :: D3 - integer :: dim, nloc, snloc, faces, owned_nodes - - ! Number of nodes associated with each object. - integer :: face_len, edge_len, element_len - - ! Total nodes associated with an element - integer :: element_tot_len - - integer :: ele, ele2, node, node2, new_node, new_node2, i, j, k, halo - - integer, dimension(:), allocatable :: n - - ! Process number of this processor - integer :: rank - - ! Owner and halo_level of all the nodes - integer, dimension(:), allocatable :: node_owner, receive_halo_level, & - & new_receive_halo_level - integer, dimension(:,:), allocatable :: new_node_owner - integer :: this_node_owner, this_receive_halo_level, this_node_winner - - ! Cache for positions in ndglno which are currently being worked on and - ! new values to go in them - integer, dimension(:), allocatable :: ndglno_pos, ndglno_val, face_nodes - - ! Map from old node numbers to new ones. - integer, dimension(:), allocatable :: node_map - - ! In each case, halos is the last dimension of halos. - type(ilist), dimension(:), allocatable :: this_send_targets, node_targets,& - & node2_targets - type(ilist), dimension(:,:), allocatable :: old_send_targets, new_send_targets - type(inode), pointer :: this_target - - ! Nodes in current element - integer, pointer, dimension(:) :: ele_node - - ! Flag for whether halos are being calculated: - logical :: have_halos - - ! Ascertain whether we are calculating halos or not. - if (present(halos)) then - assert(present(new_halos)) - assert(present(element_halo)) - allocate(this_send_targets(size(halos)), node_targets(size(halos)),& + subroutine make_global_numbering & + (new_nonods, new_ndglno, Nonods, Totele, NDGLNO, element, halos,& + & element_halo, new_halos) + ! Construct the global node numbering based on the node numbering for + ! linear tets given in NDGLNO. + integer, intent(in) :: nonods, totele + integer, intent(in), dimension(:), target :: ndglno + type(element_type), intent(in) :: element + !! The level 1 and 2 halos associated with the incoming mesh. + type(halo_type), dimension(:), intent(in), optional :: halos + !! The full element halo associated with these meshes. + type(halo_type), intent(in), optional :: element_halo + !! The level 1 and 2 halos associated with the new mesh. + type(halo_type), dimension(:), intent(out), optional :: new_halos + + integer, dimension(:), intent(out) :: new_ndglno + integer, intent(out) :: new_nonods + + ! Adjacency lists. + type(csr_sparsity) :: NEList, NNList, EEList + + logical :: D3 + integer :: dim, nloc, snloc, faces, owned_nodes + + ! Number of nodes associated with each object. + integer :: face_len, edge_len, element_len + + ! Total nodes associated with an element + integer :: element_tot_len + + integer :: ele, ele2, node, node2, new_node, new_node2, i, j, k, halo + + integer, dimension(:), allocatable :: n + + ! Process number of this processor + integer :: rank + + ! Owner and halo_level of all the nodes + integer, dimension(:), allocatable :: node_owner, receive_halo_level, & + & new_receive_halo_level + integer, dimension(:,:), allocatable :: new_node_owner + integer :: this_node_owner, this_receive_halo_level, this_node_winner + + ! Cache for positions in ndglno which are currently being worked on and + ! new values to go in them + integer, dimension(:), allocatable :: ndglno_pos, ndglno_val, face_nodes + + ! Map from old node numbers to new ones. + integer, dimension(:), allocatable :: node_map + + ! In each case, halos is the last dimension of halos. + type(ilist), dimension(:), allocatable :: this_send_targets, node_targets,& + & node2_targets + type(ilist), dimension(:,:), allocatable :: old_send_targets, new_send_targets + type(inode), pointer :: this_target + + ! Nodes in current element + integer, pointer, dimension(:) :: ele_node + + ! Flag for whether halos are being calculated: + logical :: have_halos + + ! Ascertain whether we are calculating halos or not. + if (present(halos)) then + assert(present(new_halos)) + assert(present(element_halo)) + allocate(this_send_targets(size(halos)), node_targets(size(halos)),& & node2_targets(size(halos))) - have_halos=.true. - else - have_halos=.false. - end if - - ! Dimensionality flag. - dim = element%numbering%dimension - D3=dim==3 - - ! Vertices per element. - nloc=element%numbering%vertices - ! Vertices per surface element - snloc = nloc - 1 - - call MakeLists(Nonods, Totele, Nloc, ndglno, D3, NEList,& - & NNList, EEList) - - new_ndglno=0 - - rank=getprocno() - call halo_lists(halos, node_owner, receive_halo_level,& - & old_send_targets) - - !---------------------------------------------------------------------- - ! Calculate the total number of nodes by adding the vertices, edge - ! elements, face elements and interior elements. - !---------------------------------------------------------------------- - - ! Vertices. - new_nonods=nonods - - ! Edges. - edge_len=max(element%numbering%degree-1,0) - new_nonods=new_nonods+0.5*size(NNList%colm)*edge_len - - select case(dim) - case(3) - ! Interior faces - faces=count(EEList%colm/=0) - - ! Total distinct faces - faces=0.5*faces+ size(EEList%colm)-faces - - face_len=max(tr(element%numbering%degree-2),0) - new_nonods=new_nonods+faces*face_len - - ! Interior nodes - element_len=max(te(element%numbering%degree-3),0) - if (element%numbering%type==ELEMENT_BUBBLE) then - element_len = element_len + 1 - end if - new_nonods=new_nonods+totele*element_len - case(2) - faces=0 - - ! Interior nodes - element_len=max(tr(element%numbering%degree-2),0) - if (element%numbering%type==ELEMENT_BUBBLE) then - element_len = element_len + 1 - end if - new_nonods=new_nonods+totele*element_len - case(1) - faces=0 - - ! Interior nodes - element_len=0 - if (element%numbering%type==ELEMENT_BUBBLE) then - element_len = element_len + 1 - end if - new_nonods=new_nonods+totele*element_len - case default - FLAbort("Unsupported dimension specified.") - end select - - ! Total nodes per element - element_tot_len=element%numbering%nodes - - if (have_halos) then - allocate(new_node_owner(new_nonods, 0:size(halos)), & - & new_receive_halo_level(size(new_ndglno)), & - & new_send_targets(new_nonods, size(halos))) - end if - - ! We need one n plus one for each halo so as to separately number the - ! nodes in each halo. We then transplant them into one long list - ! afterwards. - if(have_halos) then - allocate(n(0:size(halos))) - else - allocate(n(0:0)) - end if - n=0 - - !---------------------------------------------------------------------- - ! Vertex numbers - !---------------------------------------------------------------------- - allocate(ndglno_pos(nloc), ndglno_val(nloc)) - allocate(node_map(nonods)) - node_map=0 - - do i=1,totele - ele_node=>NDGLNO(nloc*(i-1)+1:nloc*i) - ndglno_pos=(i-1)*element_tot_len & + have_halos=.true. + else + have_halos=.false. + end if + + ! Dimensionality flag. + dim = element%numbering%dimension + D3=dim==3 + + ! Vertices per element. + nloc=element%numbering%vertices + ! Vertices per surface element + snloc = nloc - 1 + + call MakeLists(Nonods, Totele, Nloc, ndglno, D3, NEList,& + & NNList, EEList) + + new_ndglno=0 + + rank=getprocno() + call halo_lists(halos, node_owner, receive_halo_level,& + & old_send_targets) + + !---------------------------------------------------------------------- + ! Calculate the total number of nodes by adding the vertices, edge + ! elements, face elements and interior elements. + !---------------------------------------------------------------------- + + ! Vertices. + new_nonods=nonods + + ! Edges. + edge_len=max(element%numbering%degree-1,0) + new_nonods=new_nonods+0.5*size(NNList%colm)*edge_len + + select case(dim) + case(3) + ! Interior faces + faces=count(EEList%colm/=0) + + ! Total distinct faces + faces=0.5*faces+ size(EEList%colm)-faces + + face_len=max(tr(element%numbering%degree-2),0) + new_nonods=new_nonods+faces*face_len + + ! Interior nodes + element_len=max(te(element%numbering%degree-3),0) + if (element%numbering%type==ELEMENT_BUBBLE) then + element_len = element_len + 1 + end if + new_nonods=new_nonods+totele*element_len + case(2) + faces=0 + + ! Interior nodes + element_len=max(tr(element%numbering%degree-2),0) + if (element%numbering%type==ELEMENT_BUBBLE) then + element_len = element_len + 1 + end if + new_nonods=new_nonods+totele*element_len + case(1) + faces=0 + + ! Interior nodes + element_len=0 + if (element%numbering%type==ELEMENT_BUBBLE) then + element_len = element_len + 1 + end if + new_nonods=new_nonods+totele*element_len + case default + FLAbort("Unsupported dimension specified.") + end select + + ! Total nodes per element + element_tot_len=element%numbering%nodes + + if (have_halos) then + allocate(new_node_owner(new_nonods, 0:size(halos)), & + & new_receive_halo_level(size(new_ndglno)), & + & new_send_targets(new_nonods, size(halos))) + end if + + ! We need one n plus one for each halo so as to separately number the + ! nodes in each halo. We then transplant them into one long list + ! afterwards. + if(have_halos) then + allocate(n(0:size(halos))) + else + allocate(n(0:0)) + end if + n=0 + + !---------------------------------------------------------------------- + ! Vertex numbers + !---------------------------------------------------------------------- + allocate(ndglno_pos(nloc), ndglno_val(nloc)) + allocate(node_map(nonods)) + node_map=0 + + do i=1,totele + ele_node=>NDGLNO(nloc*(i-1)+1:nloc*i) + ndglno_pos=(i-1)*element_tot_len & + vertex_num(ele_node, & - ele_node, & - element%numbering) + ele_node, & + element%numbering) - ! Pick up those values which have been done already. - ndglno_val=node_map(ele_node) + ! Pick up those values which have been done already. + ndglno_val=node_map(ele_node) - do j=1,nloc - if (ndglno_val(j)==0) then - n(receive_halo_level(ele_node(j)))=& + do j=1,nloc + if (ndglno_val(j)==0) then + n(receive_halo_level(ele_node(j)))=& n(receive_halo_level(ele_node(j)))+1 - ndglno_val(j)=n(receive_halo_level(ele_node(j))) + ndglno_val(j)=n(receive_halo_level(ele_node(j))) - node_map(ele_node(j))=ndglno_val(j) + node_map(ele_node(j))=ndglno_val(j) - if(receive_halo_level(ele_node(j)) == 0 .and. have_halos) then - call copy(new_send_targets(n(0),:), old_send_targets(ele_node(j),:)) - end if - end if - end do + if(receive_halo_level(ele_node(j)) == 0 .and. have_halos) then + call copy(new_send_targets(n(0),:), old_send_targets(ele_node(j),:)) + end if + end if + end do - new_ndglno(ndglno_pos) = ndglno_val - if (have_halos) then - do j=1,nloc - new_node_owner(ndglno_val(j),receive_halo_level(ele_node(j)))& + new_ndglno(ndglno_pos) = ndglno_val + if (have_halos) then + do j=1,nloc + new_node_owner(ndglno_val(j),receive_halo_level(ele_node(j)))& =node_owner(ele_node(j)) - end do - new_receive_halo_level(ndglno_pos)=receive_halo_level(ele_node) - end if - end do - - deallocate(ndglno_pos, ndglno_val) - - !---------------------------------------------------------------------- - ! Edge numbers. - !---------------------------------------------------------------------- - if (edge_len>0) then - allocate(ndglno_pos(edge_len)) - - do node=1,size(NNList,1) - do j=NNList%findrm(node),NNList%findrm(node+1)-1 - node2=NNList%colm(j) - - new_node=node_map(node) - new_node2=node_map(node2) - - ! Listen very carefully, I shall do each row only once! - if (node2<=node) cycle - - ! Defaults which may be overwritten in the following if block - this_receive_halo_level=0 - this_node_owner=node_owner(node) - - if (have_halos) then - if (node_owner(node)/=node_owner(node2)) then - ! Contested nodes. Nodes have the same halo properties as - ! the winning side. - - ! Work out who should own these nodes. - this_node_owner=max(node_owner(node), node_owner(node2)) - if (this_node_owner==node_owner(node)) then - this_receive_halo_level=receive_halo_level(node) - call copy(this_send_targets, old_send_targets(node,:)) - else - this_receive_halo_level=receive_halo_level(node2) - call copy(this_send_targets,old_send_targets(node2,:)) - end if - - ! Uncontested nodes. Nodes belong to the smallest available - ! halo. - else if (any(old_send_targets(node,:)%length>0& - & .and.old_send_targets(node2,:)%length>0))& - & then - - do halo=1, size(halos) - ! A new node is in a halo if both old nodes are. - this_send_targets(halo)=intersect_ascending(& + end do + new_receive_halo_level(ndglno_pos)=receive_halo_level(ele_node) + end if + end do + + deallocate(ndglno_pos, ndglno_val) + + !---------------------------------------------------------------------- + ! Edge numbers. + !---------------------------------------------------------------------- + if (edge_len>0) then + allocate(ndglno_pos(edge_len)) + + do node=1,size(NNList,1) + do j=NNList%findrm(node),NNList%findrm(node+1)-1 + node2=NNList%colm(j) + + new_node=node_map(node) + new_node2=node_map(node2) + + ! Listen very carefully, I shall do each row only once! + if (node2<=node) cycle + + ! Defaults which may be overwritten in the following if block + this_receive_halo_level=0 + this_node_owner=node_owner(node) + + if (have_halos) then + if (node_owner(node)/=node_owner(node2)) then + ! Contested nodes. Nodes have the same halo properties as + ! the winning side. + + ! Work out who should own these nodes. + this_node_owner=max(node_owner(node), node_owner(node2)) + if (this_node_owner==node_owner(node)) then + this_receive_halo_level=receive_halo_level(node) + call copy(this_send_targets, old_send_targets(node,:)) + else + this_receive_halo_level=receive_halo_level(node2) + call copy(this_send_targets,old_send_targets(node2,:)) + end if + + ! Uncontested nodes. Nodes belong to the smallest available + ! halo. + else if (any(old_send_targets(node,:)%length>0& + & .and.old_send_targets(node2,:)%length>0))& + & then + + do halo=1, size(halos) + ! A new node is in a halo if both old nodes are. + this_send_targets(halo)=intersect_ascending(& old_send_targets(node,halo),& old_send_targets(node2,halo)) - end do - - ! For the level 2 halo, a point is in if one of the nodes - ! is in the level 2 halo and the other is in the level 1. - do halo=2,size(halos) - !this_send_targets(halo)=intersect_ascending(& - node_targets=old_send_targets(node,halo-1:halo) - node2_targets=old_send_targets(node2,halo-1:halo) - - this_target=>node_targets(1)%firstnode - do while(associated(this_target)) - if(has_value_sorted(node2_targets(2), this_target%value)) then - call insert_ascending(this_send_targets(halo),& - & this_target%value) - end if - this_target=>this_target%next - end do - - this_target=>node2_targets(1)%firstnode - do while(associated(this_target)) - if(has_value_sorted(node_targets(2), this_target%value)) then - call insert_ascending(this_send_targets(halo),& - & this_target%value) - end if - this_target=>this_target%next - end do - end do - - else if (receive_halo_level(node)& - &>0.and.receive_halo_level(node2)>0) then - - this_receive_halo_level=max(receive_halo_level(node), & + end do + + ! For the level 2 halo, a point is in if one of the nodes + ! is in the level 2 halo and the other is in the level 1. + do halo=2,size(halos) + !this_send_targets(halo)=intersect_ascending(& + node_targets=old_send_targets(node,halo-1:halo) + node2_targets=old_send_targets(node2,halo-1:halo) + + this_target=>node_targets(1)%firstnode + do while(associated(this_target)) + if(has_value_sorted(node2_targets(2), this_target%value)) then + call insert_ascending(this_send_targets(halo),& + & this_target%value) + end if + this_target=>this_target%next + end do + + this_target=>node2_targets(1)%firstnode + do while(associated(this_target)) + if(has_value_sorted(node_targets(2), this_target%value)) then + call insert_ascending(this_send_targets(halo),& + & this_target%value) + end if + this_target=>this_target%next + end do + end do + + else if (receive_halo_level(node)& + &>0.and.receive_halo_level(node2)>0) then + + this_receive_halo_level=max(receive_halo_level(node), & receive_halo_level(node2)) - end if - end if + end if + end if - ! Now double loop over all adjacent elements and number in the - ! elements which border this face. - do k=NEList%findrm(node2), NEList%findrm(node2+1)-1 + ! Now double loop over all adjacent elements and number in the + ! elements which border this face. + do k=NEList%findrm(node2), NEList%findrm(node2+1)-1 - ele=NEList%colm(k) + ele=NEList%colm(k) - if (any(ele==row_m(NEList, node))) then - ! This element contains this edge. + if (any(ele==row_m(NEList, node))) then + ! This element contains this edge. - ! Nodes in this element + ! Nodes in this element - ! This horrible mess finds the appropriate nodes in this - ! element and assigns the next edge_len indices to them. - ndglno_pos=(ele-1)*element_tot_len& + ! This horrible mess finds the appropriate nodes in this + ! element and assigns the next edge_len indices to them. + ndglno_pos=(ele-1)*element_tot_len& +edge_num((/node,node2/), & NDGLNO(nloc*(ele-1)+1:nloc*ele), & element%numbering, interior=.true.) - new_ndglno(ndglno_pos) & + new_ndglno(ndglno_pos) & = sequence(n(this_receive_halo_level)+1, edge_len) - if (have_halos) then - new_receive_halo_level(ndglno_pos)= & + if (have_halos) then + new_receive_halo_level(ndglno_pos)= & this_receive_halo_level - new_node_owner(new_ndglno(ndglno_pos),& - & this_receive_halo_level)=this_node_owner - - if (any(this_send_targets%length/=0)) then - do i=1,size(ndglno_pos) - call deallocate(new_send_targets(new_ndglno(ndglno_pos(i)),:)) - call copy(new_send_targets(new_ndglno(ndglno_pos(i)),:) & - ,this_send_targets) - end do - end if - end if - - end if - end do - - ! Move on the node count. - n(this_receive_halo_level)=n(this_receive_halo_level)+edge_len - - if (have_halos) then - ! Clean up send targets - call flush_lists(this_send_targets) - end if - end do - - end do - - deallocate(ndglno_pos) - - end if - - !---------------------------------------------------------------------- - ! Interior face numbers - only for 3D. - !---------------------------------------------------------------------- - if (D3.and.face_len>0) then - if(isparallel()) then - FLAbort("This is broken - blame dham.") - end if - allocate(face_nodes(snloc), ndglno_pos(face_len)) - do ele=1,size(EEList,1) - do j=EEList%findrm(ele),EEList%findrm(ele+1)-1 - ele2=EEList%colm(j) - - ! Skip exterior faces. - if (ele2==0) cycle - - ! Listen very carefully, I shall do each face only once! - if (ele2<=ele) cycle - - ! This horrible mess finds the appropriate nodes in this - ! element and assigns the next face_len indices to them. - face_nodes=common(NDGLNO(nloc*(ele-1)+1:nloc*ele),& + new_node_owner(new_ndglno(ndglno_pos),& + & this_receive_halo_level)=this_node_owner + + if (any(this_send_targets%length/=0)) then + do i=1,size(ndglno_pos) + call deallocate(new_send_targets(new_ndglno(ndglno_pos(i)),:)) + call copy(new_send_targets(new_ndglno(ndglno_pos(i)),:) & + ,this_send_targets) + end do + end if + end if + + end if + end do + + ! Move on the node count. + n(this_receive_halo_level)=n(this_receive_halo_level)+edge_len + + if (have_halos) then + ! Clean up send targets + call flush_lists(this_send_targets) + end if + end do + + end do + + deallocate(ndglno_pos) + + end if + + !---------------------------------------------------------------------- + ! Interior face numbers - only for 3D. + !---------------------------------------------------------------------- + if (D3.and.face_len>0) then + if(isparallel()) then + FLAbort("This is broken - blame dham.") + end if + allocate(face_nodes(snloc), ndglno_pos(face_len)) + do ele=1,size(EEList,1) + do j=EEList%findrm(ele),EEList%findrm(ele+1)-1 + ele2=EEList%colm(j) + + ! Skip exterior faces. + if (ele2==0) cycle + + ! Listen very carefully, I shall do each face only once! + if (ele2<=ele) cycle + + ! This horrible mess finds the appropriate nodes in this + ! element and assigns the next face_len indices to them. + face_nodes=common(NDGLNO(nloc*(ele-1)+1:nloc*ele),& NDGLNO(nloc*(ele2-1)+1:nloc*ele2)) - ! Work out who should own these nodes. - this_node_winner& - &=face_nodes(maxloc(node_owner(face_nodes),1)) - this_node_owner=node_owner(this_node_winner) - this_receive_halo_level=receive_halo_level(this_node_winner) + ! Work out who should own these nodes. + this_node_winner& + &=face_nodes(maxloc(node_owner(face_nodes),1)) + this_node_owner=node_owner(this_node_winner) + this_receive_halo_level=receive_halo_level(this_node_winner) - ndglno_pos=(ele-1)*element_tot_len& + ndglno_pos=(ele-1)*element_tot_len& +face_num(face_nodes,& NDGLNO(nloc*(ele-1)+1:nloc*ele), & element%numbering, interior=.true.) @@ -669,13 +669,13 @@ subroutine make_global_numbering & ! new_receive_halo_level(ndglno_pos)=this_receive_halo_level ! new_node_owner(ndglno_pos)=this_node_owner - new_ndglno(ndglno_pos) & + new_ndglno(ndglno_pos) & = sequence(n(this_receive_halo_level)+1, face_len) - face_nodes=common(NDGLNO(nloc*(ele-1)+1:nloc*ele),& + face_nodes=common(NDGLNO(nloc*(ele-1)+1:nloc*ele),& NDGLNO(nloc*(ele2-1)+1:nloc*ele2)) - ndglno_pos=(ele2-1)*element_tot_len& + ndglno_pos=(ele2-1)*element_tot_len& +face_num(face_nodes,& NDGLNO(nloc*(ele2-1)+1:nloc*ele2), & element%numbering, interior=.true.) @@ -683,652 +683,652 @@ subroutine make_global_numbering & ! new_receive_halo_level(ndglno_pos)=this_receive_halo_level ! new_node_owner(ndglno_pos)=this_node_owner - new_ndglno(ndglno_pos) & + new_ndglno(ndglno_pos) & = sequence(n(this_receive_halo_level)+1, face_len) - n(this_receive_halo_level)=n(this_receive_halo_level)+1 + n(this_receive_halo_level)=n(this_receive_halo_level)+1 - end do - end do + end do + end do - deallocate(face_nodes, ndglno_pos) - end if + deallocate(face_nodes, ndglno_pos) + end if - !---------------------------------------------------------------------- - ! Remaining numbers. - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! Remaining numbers. + !---------------------------------------------------------------------- - allocate (ndglno_pos(element%loc)) - this_receive_halo_level = 0 + allocate (ndglno_pos(element%loc)) + this_receive_halo_level = 0 - ! This is the internal nodes of the elements plus the external faces. - do ele=1,size(EEList,1) + ! This is the internal nodes of the elements plus the external faces. + do ele=1,size(EEList,1) - ndglno_pos=sequence((ele-1)*element%loc+1, element%loc) + ndglno_pos=sequence((ele-1)*element%loc+1, element%loc) - !this_node_winner=face_nodes(maxloc(new_node_owner(ndglno_pos),1)) - !this_node_owner=new_node_owner(this_node_winner) - !this_send_halo_level=new_send_halo_level(this_node_winner) - !this_receive_halo_level=new_receive_halo_level(this_node_winner) + !this_node_winner=face_nodes(maxloc(new_node_owner(ndglno_pos),1)) + !this_node_owner=new_node_owner(this_node_winner) + !this_send_halo_level=new_send_halo_level(this_node_winner) + !this_receive_halo_level=new_receive_halo_level(this_node_winner) - do i=1, element%loc - if (new_ndglno(ndglno_pos(i))==0) then - n(this_receive_halo_level)=n(this_receive_halo_level)+1 - new_ndglno(ndglno_pos(i))=n(this_receive_halo_level) + do i=1, element%loc + if (new_ndglno(ndglno_pos(i))==0) then + n(this_receive_halo_level)=n(this_receive_halo_level)+1 + new_ndglno(ndglno_pos(i))=n(this_receive_halo_level) - if(isparallel()) then - FLAbort("This is broken - blame dham.") - new_receive_halo_level(ndglno_pos(i))=this_receive_halo_level + if(isparallel()) then + FLAbort("This is broken - blame dham.") + new_receive_halo_level(ndglno_pos(i))=this_receive_halo_level ! new_node_owner(ndglno_pos(i))=this_node_owner - end if - end if - end do + end if + end if + end do - end do + end do - deallocate(ndglno_pos) - call deallocate(NEList) - call deallocate(NNList) - call deallocate(EEList) + deallocate(ndglno_pos) + call deallocate(NEList) + call deallocate(NNList) + call deallocate(EEList) - ASSERT(sum(n)==new_nonods) + ASSERT(sum(n)==new_nonods) - owned_nodes=n(0) - do i=size(n)-1,0,-1 - ! Work out the offset for halo nodes. - n(i)=sum(n(0:i-1)) - end do - n(0)=0 + owned_nodes=n(0) + do i=size(n)-1,0,-1 + ! Work out the offset for halo nodes. + n(i)=sum(n(0:i-1)) + end do + n(0)=0 - if (have_halos) then - new_ndglno=new_ndglno+n(new_receive_halo_level) + if (have_halos) then + new_ndglno=new_ndglno+n(new_receive_halo_level) - ! Repack new_node_owner into a single list. - do halo=1,size(halos)-1 - new_node_owner(n(halo)+1:n(halo+1),0)& + ! Repack new_node_owner into a single list. + do halo=1,size(halos)-1 + new_node_owner(n(halo)+1:n(halo+1),0)& =new_node_owner(:n(halo+1)-n(halo),halo) - end do - halo=size(halos) - new_node_owner(n(halo)+1:,0)& + end do + halo=size(halos) + new_node_owner(n(halo)+1:,0)& =new_node_owner(:new_nonods-n(halo),halo) - call remove_spurious_sends(new_send_targets, new_ndglno,& - & element_tot_len, element_halo) - - call generate_new_halos(new_halos, new_ndglno, new_node_owner(:,0)& - &, new_receive_halo_level, totele,& - & element%loc, owned_nodes, new_send_targets) - - do i = 1, size(old_send_targets,1) - do j = 1, size(halos) - call flush_list(old_send_targets(i, j)) - end do - end do - do i = 1, size(new_send_targets,1) - do j = 1, size(halos) - call flush_list(new_send_targets(i, j)) - end do - end do - deallocate(old_send_targets) - deallocate(new_send_targets) - end if - - contains - - subroutine remove_spurious_sends(send_targets, ndglno, nloc, element_halo) - !!< Given the node ownership and a complete element halo, remove any - !!< sends which apply only to elements about which the receiving - !!< processor is unaware. - - !! Send_targets provides the list of processors to which each - !! node is broadcast at each halo level. It is nonods x halos - type(ilist), dimension(:,:), intent(inout) :: send_targets - !! The element node list and number of nodes per element for the NEW - !! mesh. - integer, dimension(:), intent(in), target :: ndglno - integer, intent(in) :: nloc - type(halo_type), intent(in) :: element_halo - - !! For each node, a list of processors which can see that node. - type(ilist), dimension(:), allocatable :: visible_to - !! For each processor, a list of halo elements that processor can see. - type(integer_vector), dimension(:), allocatable :: known_element_lists - - integer :: e, ele, element_count - integer :: n, node_count, proc, h, halo_count - integer, dimension(:), pointer :: this_ele - type(ilist) :: tmplist + call remove_spurious_sends(new_send_targets, new_ndglno,& + & element_tot_len, element_halo) - element_count=size(ndglno)/nloc - node_count=size(send_targets,1) - halo_count=size(send_targets,2) - - allocate(visible_to(node_count)) - allocate(known_element_lists(halo_proc_count(element_halo))) - - ! Check that nloc does actually divide size(ndglno) - assert(size(ndglno)==element_count*nloc) - - ! Retrieve the list of elements which each processor can see. - call element_halo_communicate_visibility(element_halo,& - & known_element_lists) - - ! Mark all nodes in elements visible to a processor as themselves - ! visible to that processor - do proc=1,halo_proc_count(element_halo) - do e = 1, size(known_element_lists(proc)%ptr) - ele = known_element_lists(proc)%ptr(e) - this_ele=>ndglno((ele-1)*nloc+1:ele*nloc) - - do n=1,size(this_ele) - - call insert_ascending(visible_to(this_ele(n)), proc) + call generate_new_halos(new_halos, new_ndglno, new_node_owner(:,0)& + &, new_receive_halo_level, totele,& + & element%loc, owned_nodes, new_send_targets) + do i = 1, size(old_send_targets,1) + do j = 1, size(halos) + call flush_list(old_send_targets(i, j)) + end do + end do + do i = 1, size(new_send_targets,1) + do j = 1, size(halos) + call flush_list(new_send_targets(i, j)) + end do + end do + deallocate(old_send_targets) + deallocate(new_send_targets) + end if + + contains + + subroutine remove_spurious_sends(send_targets, ndglno, nloc, element_halo) + !!< Given the node ownership and a complete element halo, remove any + !!< sends which apply only to elements about which the receiving + !!< processor is unaware. + + !! Send_targets provides the list of processors to which each + !! node is broadcast at each halo level. It is nonods x halos + type(ilist), dimension(:,:), intent(inout) :: send_targets + !! The element node list and number of nodes per element for the NEW + !! mesh. + integer, dimension(:), intent(in), target :: ndglno + integer, intent(in) :: nloc + type(halo_type), intent(in) :: element_halo + + !! For each node, a list of processors which can see that node. + type(ilist), dimension(:), allocatable :: visible_to + !! For each processor, a list of halo elements that processor can see. + type(integer_vector), dimension(:), allocatable :: known_element_lists + + integer :: e, ele, element_count + integer :: n, node_count, proc, h, halo_count + integer, dimension(:), pointer :: this_ele + type(ilist) :: tmplist + + element_count=size(ndglno)/nloc + node_count=size(send_targets,1) + halo_count=size(send_targets,2) + + allocate(visible_to(node_count)) + allocate(known_element_lists(halo_proc_count(element_halo))) + + ! Check that nloc does actually divide size(ndglno) + assert(size(ndglno)==element_count*nloc) + + ! Retrieve the list of elements which each processor can see. + call element_halo_communicate_visibility(element_halo,& + & known_element_lists) + + ! Mark all nodes in elements visible to a processor as themselves + ! visible to that processor + do proc=1,halo_proc_count(element_halo) + do e = 1, size(known_element_lists(proc)%ptr) + ele = known_element_lists(proc)%ptr(e) + this_ele=>ndglno((ele-1)*nloc+1:ele*nloc) + + do n=1,size(this_ele) + + call insert_ascending(visible_to(this_ele(n)), proc) + + end do end do end do - end do - do proc=1,halo_proc_count(element_halo) - deallocate(known_element_lists(proc)%ptr) - end do + do proc=1,halo_proc_count(element_halo) + deallocate(known_element_lists(proc)%ptr) + end do - do n=1,node_count + do n=1,node_count - do h=1,halo_count - ! Do nothing for non-send nodes. - if (send_targets(n,h)%length==0) cycle + do h=1,halo_count + ! Do nothing for non-send nodes. + if (send_targets(n,h)%length==0) cycle - tmplist=intersect_ascending(send_targets(n,h),visible_to(n)) + tmplist=intersect_ascending(send_targets(n,h),visible_to(n)) - call flush_list(send_targets(n,h)) - send_targets(n,h)=tmplist - end do + call flush_list(send_targets(n,h)) + send_targets(n,h)=tmplist + end do - call flush_list(visible_to(n)) - end do - deallocate(visible_to) + call flush_list(visible_to(n)) + end do + deallocate(visible_to) - end subroutine remove_spurious_sends + end subroutine remove_spurious_sends - subroutine generate_new_halos(new_halos, new_ndglno, new_node_owner& - &, new_receive_halo_level, elements,& - & nloc, owned_nodes, send_targets) - !!< Given the node ownership and halo level information on the new - !!< mesh, construct halos for the new mesh. - !!< Note that these halos are unsorted as sorting the halos requires - !!< the coordinate field which is not available here. - type(halo_type), dimension(:), intent(out) :: new_halos - integer, dimension(:), intent(in), target :: new_ndglno - integer, dimension(:), intent(in), target :: new_node_owner - integer, dimension(:), intent(in), target :: new_receive_halo_level - integer, intent(in) :: elements, nloc, owned_nodes - ! Send_targets provides the list of processors to which each - ! node is broadcast at each halo level. It is nonods x halos - type(ilist), dimension(:,:), intent(in) :: send_targets + subroutine generate_new_halos(new_halos, new_ndglno, new_node_owner& + &, new_receive_halo_level, elements,& + & nloc, owned_nodes, send_targets) + !!< Given the node ownership and halo level information on the new + !!< mesh, construct halos for the new mesh. + !!< Note that these halos are unsorted as sorting the halos requires + !!< the coordinate field which is not available here. + type(halo_type), dimension(:), intent(out) :: new_halos + integer, dimension(:), intent(in), target :: new_ndglno + integer, dimension(:), intent(in), target :: new_node_owner + integer, dimension(:), intent(in), target :: new_receive_halo_level + integer, intent(in) :: elements, nloc, owned_nodes + ! Send_targets provides the list of processors to which each + ! node is broadcast at each halo level. It is nonods x halos + type(ilist), dimension(:,:), intent(in) :: send_targets - integer :: processors, this_proc, halo, n, proc + integer :: processors, this_proc, halo, n, proc - type(ilist), dimension(:), allocatable :: sends, receives - integer, dimension(:), pointer :: ele_nodes - type(inode), pointer :: list_node => null() + type(ilist), dimension(:), allocatable :: sends, receives + integer, dimension(:), pointer :: ele_nodes + type(inode), pointer :: list_node => null() - processors=getnprocs() - this_proc=getprocno() + processors=getnprocs() + this_proc=getprocno() - allocate(sends(processors)) - allocate(receives(processors)) + allocate(sends(processors)) + allocate(receives(processors)) - halo_loop: do halo = 1, size(new_halos) + halo_loop: do halo = 1, size(new_halos) - do n=1, size(new_receive_halo_level) - ! Receive node - if (new_receive_halo_level(n)>0.and.new_receive_halo_level(n)<=halo) then - call insert_ascending(receives(new_node_owner(new_ndglno(n))), new_ndglno(n)) - end if - end do + do n=1, size(new_receive_halo_level) + ! Receive node + if (new_receive_halo_level(n)>0.and.new_receive_halo_level(n)<=halo) then + call insert_ascending(receives(new_node_owner(new_ndglno(n))), new_ndglno(n)) + end if + end do - do n = 1, new_nonods + do n = 1, new_nonods - ! Send node - list_node => send_targets(n,halo)%firstnode - do while(associated(list_node)) - call insert_ascending(sends(list_node%value), n) + ! Send node + list_node => send_targets(n,halo)%firstnode + do while(associated(list_node)) + call insert_ascending(sends(list_node%value), n) - list_node => list_node%next + list_node => list_node%next + end do end do - end do - call allocate(new_halos(halo), nsends=sends%length, & - nreceives=receives%length, nprocs=processors, & - nowned_nodes=owned_nodes) + call allocate(new_halos(halo), nsends=sends%length, & + nreceives=receives%length, nprocs=processors, & + nowned_nodes=owned_nodes) - do proc = 1, processors + do proc = 1, processors - new_halos(halo)%sends(proc)%ptr=list2vector(sends(proc)) - call flush_list(sends(proc)) + new_halos(halo)%sends(proc)%ptr=list2vector(sends(proc)) + call flush_list(sends(proc)) - new_halos(halo)%receives(proc)%ptr=list2vector(receives(proc)) - call flush_list(receives(proc)) + new_halos(halo)%receives(proc)%ptr=list2vector(receives(proc)) + call flush_list(receives(proc)) - end do + end do - assert(trailing_receives_consistent(new_halos(halo))) - assert(halo_valid_for_communication(new_halos(halo))) + assert(trailing_receives_consistent(new_halos(halo))) + assert(halo_valid_for_communication(new_halos(halo))) - end do halo_loop + end do halo_loop - end subroutine generate_new_halos + end subroutine generate_new_halos - function sequence(start, len) - ! Return len consecutive integers starting at start. - integer, intent(in) :: start, len - integer, dimension(len) :: sequence + function sequence(start, len) + ! Return len consecutive integers starting at start. + integer, intent(in) :: start, len + integer, dimension(len) :: sequence - integer :: i + integer :: i - forall (i=1:len) - sequence(i)=start+i-1 - end forall + forall (i=1:len) + sequence(i)=start+i-1 + end forall - end function sequence + end function sequence - function common(list1, list2) result (list) - ! Return the common members of list1 and list2. - integer, dimension(:), intent(in) :: list1, list2 - integer, dimension(count(& - (spread(list1,2,size(list2))-spread(list2,1,size(list1)))==0)) & - :: list + function common(list1, list2) result (list) + ! Return the common members of list1 and list2. + integer, dimension(:), intent(in) :: list1, list2 + integer, dimension(count(& + (spread(list1,2,size(list2))-spread(list2,1,size(list1)))==0)) & + :: list - integer :: i, j + integer :: i, j - j=0 + j=0 - do i=1,size(list2) - if (any(list1(i)==list2)) then - j=j+1 - list(j)=list1(i) - end if - end do + do i=1,size(list2) + if (any(list1(i)==list2)) then + j=j+1 + list(j)=list1(i) + end if + end do - ASSERT(j==size(list)) + ASSERT(j==size(list)) - end function common + end function common - subroutine halo_lists(halos, node_owner, receive_halo_level, old_send_targets) - type(halo_type), dimension(:), intent(in), optional :: halos - integer, dimension(:), allocatable, intent(out) :: node_owner - integer, dimension(:), allocatable, intent(out) :: receive_halo_level - !! Targets to broadcast each node to. Nonods x halos - type(ilist), dimension(:,:), allocatable, intent(out) :: old_send_targets + subroutine halo_lists(halos, node_owner, receive_halo_level, old_send_targets) + type(halo_type), dimension(:), intent(in), optional :: halos + integer, dimension(:), allocatable, intent(out) :: node_owner + integer, dimension(:), allocatable, intent(out) :: receive_halo_level + !! Targets to broadcast each node to. Nonods x halos + type(ilist), dimension(:,:), allocatable, intent(out) :: old_send_targets - integer :: h, n, p + integer :: h, n, p - allocate(node_owner(nonods)) - allocate(receive_halo_level(nonods)) + allocate(node_owner(nonods)) + allocate(receive_halo_level(nonods)) - node_owner = rank - receive_halo_level = 0 + node_owner = rank + receive_halo_level = 0 - if(.not. present(halos)) return - allocate(old_send_targets(nonods, size(halos))) + if(.not. present(halos)) return + allocate(old_send_targets(nonods, size(halos))) - ! Count down through the halos as halo 1 is a subset of halo 2 and - ! we therefore need halo 1 to overwrite. - halo_loop: do h = size(halos), 1, -1 - if(.not. associated(halos(h)%receives)) cycle halo_loop - assert(associated(halos(h)%sends)) + ! Count down through the halos as halo 1 is a subset of halo 2 and + ! we therefore need halo 1 to overwrite. + halo_loop: do h = size(halos), 1, -1 + if(.not. associated(halos(h)%receives)) cycle halo_loop + assert(associated(halos(h)%sends)) - proc_loop: do p = 1, halo_proc_count(halos(h)) + proc_loop: do p = 1, halo_proc_count(halos(h)) #ifdef DDEBUG - if(h < size(halos)) then - ! Check that this halo really is a subset of all higher level - ! halos - assert(all(receive_halo_level(halo_receives(halos(h), p)) /= 0)) - end if + if(h < size(halos)) then + ! Check that this halo really is a subset of all higher level + ! halos + assert(all(receive_halo_level(halo_receives(halos(h), p)) /= 0)) + end if #endif - receive_halo_level(halo_receives(halos(h), p)) = h + receive_halo_level(halo_receives(halos(h), p)) = h - do n = 1, halo_send_count(halos(h), p) - call insert_ascending(old_send_targets(halo_send(halos(h), p, n),h), p) - end do + do n = 1, halo_send_count(halos(h), p) + call insert_ascending(old_send_targets(halo_send(halos(h), p, n),h), p) + end do - if(h == size(halos)) then - ! If we're on the highest level halo, set the node owners - node_owner(halo_receives(halos(h), p)) = p + if(h == size(halos)) then + ! If we're on the highest level halo, set the node owners + node_owner(halo_receives(halos(h), p)) = p #ifdef DDEBUG - else - ! Otherwise, these should already have been set by the higher - ! level halo - assert(all(node_owner(halo_receives(halos(h), p)) == p)) + else + ! Otherwise, these should already have been set by the higher + ! level halo + assert(all(node_owner(halo_receives(halos(h), p)) == p)) #endif - end if + end if - end do proc_loop - - end do halo_loop - - end subroutine halo_lists - - end subroutine make_global_numbering - - subroutine make_boundary_numbering(boundary_list, boundary_n_lno, & - boundary_m_lno, EEList, xnonod& - &, xndglno, ele_n, boundary_n, ele_m, boundary_m) - ! Generate boundary numberings to facilitate the evaluation of boundary - ! integrals. As is usual in fluidity, the suffix n refers to velocity - ! elements while the suffix m refers to pressure elements. - ! - ! If f=boundary_list(i,j) then boundary_n_lno((f-1)*boundary%loc+1:f*boundary%loc) is the - ! vector of local indices of the nodes on the boundary between i and j. - ! - ! Let f2=boundary_list(j,i). Then: - ! xndglno(boundary_list((f-1)*boundary%loc+1:f*boundary%loc)) = - ! xndglno(boundary_list((f2-1)*boundary%loc+1:f2*boundary%loc)) - type(csr_sparsity), intent(in) :: EEList - type(element_type), intent(in) :: ele_n, boundary_n - type(element_type), optional, intent(in) :: ele_m, boundary_m - integer, intent(in) :: xnonod - integer, dimension(size(EEList,1)*ele_n%loc), intent(in), target ::& - & xndglno - - type(csr_matrix), intent(out) :: boundary_list - integer, dimension(boundary_n%loc*entries(EEList)), intent(out), optional :: & + end do proc_loop + + end do halo_loop + + end subroutine halo_lists + + end subroutine make_global_numbering + + subroutine make_boundary_numbering(boundary_list, boundary_n_lno, & + boundary_m_lno, EEList, xnonod& + &, xndglno, ele_n, boundary_n, ele_m, boundary_m) + ! Generate boundary numberings to facilitate the evaluation of boundary + ! integrals. As is usual in fluidity, the suffix n refers to velocity + ! elements while the suffix m refers to pressure elements. + ! + ! If f=boundary_list(i,j) then boundary_n_lno((f-1)*boundary%loc+1:f*boundary%loc) is the + ! vector of local indices of the nodes on the boundary between i and j. + ! + ! Let f2=boundary_list(j,i). Then: + ! xndglno(boundary_list((f-1)*boundary%loc+1:f*boundary%loc)) = + ! xndglno(boundary_list((f2-1)*boundary%loc+1:f2*boundary%loc)) + type(csr_sparsity), intent(in) :: EEList + type(element_type), intent(in) :: ele_n, boundary_n + type(element_type), optional, intent(in) :: ele_m, boundary_m + integer, intent(in) :: xnonod + integer, dimension(size(EEList,1)*ele_n%loc), intent(in), target ::& + & xndglno + + type(csr_matrix), intent(out) :: boundary_list + integer, dimension(boundary_n%loc*entries(EEList)), intent(out), optional :: & boundary_n_lno - integer, dimension(:), optional, intent(out) :: & + integer, dimension(:), optional, intent(out) :: & boundary_m_lno - integer, dimension(ele_n%numbering%boundaries) :: neigh - integer, dimension(ele_n%numbering%vertices) :: vertices - integer, dimension(:), pointer :: ele_i, ele_j + integer, dimension(ele_n%numbering%boundaries) :: neigh + integer, dimension(ele_n%numbering%vertices) :: vertices + integer, dimension(:), pointer :: ele_i, ele_j - integer :: boundary_cnt, i, j, m, n, p, rlen - logical :: logtest - integer, dimension(boundary_n%numbering%vertices) :: boundary_i, boundary_j + integer :: boundary_cnt, i, j, m, n, p, rlen + logical :: logtest + integer, dimension(boundary_n%numbering%vertices) :: boundary_i, boundary_j - ewrite(2,*) "subroutine make_boundary_numbering" + ewrite(2,*) "subroutine make_boundary_numbering" - !CHECK(size(neigh)) + !CHECK(size(neigh)) - call allocate(boundary_list, EEList, type=CSR_INTEGER) - if (present(boundary_m_lno)) boundary_m_lno=0 + call allocate(boundary_list, EEList, type=CSR_INTEGER) + if (present(boundary_m_lno)) boundary_m_lno=0 - logtest = associated(boundary_list%val) - !CHECK(logtest) - logtest = associated(boundary_list%ival) - !CHECK(logtest) + logtest = associated(boundary_list%val) + !CHECK(logtest) + logtest = associated(boundary_list%ival) + !CHECK(logtest) - if(present(boundary_m_lno)) then + if(present(boundary_m_lno)) then ! MSG("Checking size of boundary_m_lno") ! ASSERT(size(boundary_m_lno)==(boundary_m%loc*entries(EEList))) - end if + end if - ewrite(2,*) "zeroing boundary_list" - call zero(boundary_list) + ewrite(2,*) "zeroing boundary_list" + call zero(boundary_list) - if (present(boundary_n_lno)) boundary_n_lno=0 - if (present(boundary_m_lno)) boundary_m_lno=0 + if (present(boundary_n_lno)) boundary_n_lno=0 + if (present(boundary_m_lno)) boundary_m_lno=0 - boundary_cnt=0 + boundary_cnt=0 - vertices=local_vertices(ele_n%numbering) + vertices=local_vertices(ele_n%numbering) - do i=1,size(boundary_list,1) - ele_i=>xndglno((i-1)*ele_n%loc+1:i*ele_n%loc) + do i=1,size(boundary_list,1) + ele_i=>xndglno((i-1)*ele_n%loc+1:i*ele_n%loc) - ! Sanity check EEList form. - rlen = row_length(boundary_List,i) - ASSERT(rlen==size(neigh)) + ! Sanity check EEList form. + rlen = row_length(boundary_List,i) + ASSERT(rlen==size(neigh)) - neigh=row_m(EEList,i) + neigh=row_m(EEList,i) - neighbourloop: do j=1, size(neigh) - ! Exclude boundary boundaries. - if (neigh(j)==0) then - cycle neighbourloop - end if + neighbourloop: do j=1, size(neigh) + ! Exclude boundary boundaries. + if (neigh(j)==0) then + cycle neighbourloop + end if - ! EEList includes the current ele_n, which is obviously wrong. - if (neigh(j)==i) cycle neighbourloop + ! EEList includes the current ele_n, which is obviously wrong. + if (neigh(j)==i) cycle neighbourloop - ! Check to see if the boundary has been done. - if (val(boundary_list,i,neigh(j))/=0) cycle neighbourloop + ! Check to see if the boundary has been done. + if (val(boundary_list,i,neigh(j))/=0) cycle neighbourloop - ele_j=>xndglno((neigh(j)-1)*ele_n%loc+1:neigh(j)*ele_n%loc) + ele_j=>xndglno((neigh(j)-1)*ele_n%loc+1:neigh(j)*ele_n%loc) - p=0 + p=0 - ! Look for common boundaries. - do m=1,size(vertices) - do n=1,size(vertices) - if (ele_i(vertices(m))==ele_j(vertices(n))) then - p=p+1 - boundary_i(p)=m - boundary_j(p)=n - end if - end do - end do + ! Look for common boundaries. + do m=1,size(vertices) + do n=1,size(vertices) + if (ele_i(vertices(m))==ele_j(vertices(n))) then + p=p+1 + boundary_i(p)=m + boundary_j(p)=n + end if + end do + end do - ! Check that we really have found two boundaries. - !ASSERT(p==boundary_n%numbering%vertices) + ! Check that we really have found two boundaries. + !ASSERT(p==boundary_n%numbering%vertices) - ! Put the boundaries we have found in the next two spots. - boundary_cnt=boundary_cnt+1 + ! Put the boundaries we have found in the next two spots. + boundary_cnt=boundary_cnt+1 - ! Velocity element boundaries. - if(present(boundary_n_lno)) then - boundary_n_lno((boundary_cnt-1)*boundary_n%loc+1: & + ! Velocity element boundaries. + if(present(boundary_n_lno)) then + boundary_n_lno((boundary_cnt-1)*boundary_n%loc+1: & boundary_cnt*boundary_n%loc)= & - & boundary_local_num(boundary_i, ele_n%numbering) - end if - - ! Pressure element boundaries. - if(present(boundary_m_lno)) then - ASSERT(present(boundary_m)) - ASSERT(present(boundary_m)) - ASSERT(present(ele_m)) - boundary_m_lno((boundary_cnt-1)*boundary_m%loc+1: & + & boundary_local_num(boundary_i, ele_n%numbering) + end if + + ! Pressure element boundaries. + if(present(boundary_m_lno)) then + ASSERT(present(boundary_m)) + ASSERT(present(boundary_m)) + ASSERT(present(ele_m)) + boundary_m_lno((boundary_cnt-1)*boundary_m%loc+1: & boundary_cnt*boundary_m%loc)= & boundary_local_num(boundary_i, ele_m%numbering) - end if + end if - call set(boundary_list,i,neigh(j),boundary_cnt) + call set(boundary_list,i,neigh(j),boundary_cnt) - boundary_cnt=boundary_cnt+1 + boundary_cnt=boundary_cnt+1 - ! Velocity element boundaries. - if(present(boundary_n_lno)) then - boundary_n_lno((boundary_cnt-1)*boundary_n%loc+1: & + ! Velocity element boundaries. + if(present(boundary_n_lno)) then + boundary_n_lno((boundary_cnt-1)*boundary_n%loc+1: & boundary_cnt*boundary_n%loc)= & boundary_local_num(boundary_j, ele_n%numbering) - end if + end if - ! Pressure element boundaries. - if(present(boundary_m_lno)) then - boundary_m_lno((boundary_cnt-1)*boundary_m%loc+1: & + ! Pressure element boundaries. + if(present(boundary_m_lno)) then + boundary_m_lno((boundary_cnt-1)*boundary_m%loc+1: & boundary_cnt*boundary_m%loc)= & boundary_local_num(boundary_j, ele_m%numbering) - end if + end if - call set(boundary_list,neigh(j),i,boundary_cnt) - end do neighbourloop + call set(boundary_list,neigh(j),i,boundary_cnt) + end do neighbourloop - end do + end do - logtest = (boundary_cnt==entries(EEList)) - ASSERT(logtest) + logtest = (boundary_cnt==entries(EEList)) + ASSERT(logtest) - ewrite(2,*) "END subroutine make_boundary_numbering" + ewrite(2,*) "END subroutine make_boundary_numbering" - end subroutine make_boundary_numbering + end subroutine make_boundary_numbering - subroutine element_halo_communicate_visibility(element_halo,& - & known_element_lists) - !!< Given the element halo, for each processor we know about, send - !!< the list of halo elements we know about. - type(halo_type), intent(in) :: element_halo - type(integer_vector), dimension(halo_proc_count(element_halo)),& - & intent(out) :: known_element_lists + subroutine element_halo_communicate_visibility(element_halo,& + & known_element_lists) + !!< Given the element halo, for each processor we know about, send + !!< the list of halo elements we know about. + type(halo_type), intent(in) :: element_halo + type(integer_vector), dimension(halo_proc_count(element_halo)),& + & intent(out) :: known_element_lists #ifdef HAVE_MPI - ! For each element, the list of other processors it is sent to. - type(ilist), dimension(:), allocatable :: visible_list - ! For each processor, the list of extra elements it can see. - type(ilist), dimension(:), allocatable :: visible_elements - type(inode), pointer :: this_item + ! For each element, the list of other processors it is sent to. + type(ilist), dimension(:), allocatable :: visible_list + ! For each processor, the list of extra elements it can see. + type(ilist), dimension(:), allocatable :: visible_elements + type(inode), pointer :: this_item - ! For each processor, the visible_list which is to be sent to it. - type(integer_vector), dimension(halo_proc_count(element_halo)) ::& - & send_lists - integer, dimension(:), allocatable :: requests, receive_list - integer, dimension(MPI_STATUS_SIZE) :: status - integer :: proc, e, ierr, rank, communicator, count, nprocs, sends,& - & receives, pos, p, sendproc, tag + ! For each processor, the visible_list which is to be sent to it. + type(integer_vector), dimension(halo_proc_count(element_halo)) ::& + & send_lists + integer, dimension(:), allocatable :: requests, receive_list + integer, dimension(MPI_STATUS_SIZE) :: status + integer :: proc, e, ierr, rank, communicator, count, nprocs, sends,& + & receives, pos, p, sendproc, tag - nprocs=halo_proc_count(element_halo) + nprocs=halo_proc_count(element_halo) - allocate(visible_list(node_count(element_halo))) + allocate(visible_list(node_count(element_halo))) - do proc=1, nprocs - do e=1, halo_send_count(element_halo, proc) + do proc=1, nprocs + do e=1, halo_send_count(element_halo, proc) - call insert_ascending(& + call insert_ascending(& visible_list(halo_send(element_halo, proc, e)), & proc) - end do - end do - - do proc=1, nprocs - if (halo_send_count(element_halo, proc)>0) then - allocate(send_lists(proc)%ptr(& - sum(visible_list(halo_sends(element_halo,proc))%length))) - - ! Use the first halo_send_count places to indicate how many - ! processors (other than the receiver) know about each element. - send_lists(proc)%ptr(:halo_send_count(element_halo, proc)) & - = visible_list(halo_sends(element_halo,proc))%length - 1 - - sends = halo_send_count(element_halo, proc) - pos=sends - do e=1, sends - this_item=>visible_list(halo_send(element_halo, proc, e))& - &%firstnode - do while(associated(this_item)) - ! Eliminate self-cites. - if (this_item%value/=proc) then - pos=pos+1 - send_lists(proc)%ptr(pos)=this_item%value - end if + end do + end do + + do proc=1, nprocs + if (halo_send_count(element_halo, proc)>0) then + allocate(send_lists(proc)%ptr(& + sum(visible_list(halo_sends(element_halo,proc))%length))) + + ! Use the first halo_send_count places to indicate how many + ! processors (other than the receiver) know about each element. + send_lists(proc)%ptr(:halo_send_count(element_halo, proc)) & + = visible_list(halo_sends(element_halo,proc))%length - 1 + + sends = halo_send_count(element_halo, proc) + pos=sends + do e=1, sends + this_item=>visible_list(halo_send(element_halo, proc, e))& + &%firstnode + do while(associated(this_item)) + ! Eliminate self-cites. + if (this_item%value/=proc) then + pos=pos+1 + send_lists(proc)%ptr(pos)=this_item%value + end if + + this_item=>this_item%next + end do - this_item=>this_item%next end do + assert(pos==size(send_lists(proc)%ptr)) + end if + end do - end do - assert(pos==size(send_lists(proc)%ptr)) - end if - end do - - call flush_lists(visible_list) - deallocate(visible_list) - - ! Set up non-blocking communications - communicator = halo_communicator(element_halo) - allocate(requests(nprocs)) - requests = MPI_REQUEST_NULL - rank = getrank(communicator) - tag = next_mpi_tag() - - do proc=1, nprocs - - if (halo_send_count(element_halo, proc)>0) then - call mpi_isend(send_lists(proc)%ptr, & - size(send_lists(proc)%ptr), MPI_INTEGER,& - proc-1, tag, communicator, requests(proc), ierr) - assert(ierr == MPI_SUCCESS) - end if + call flush_lists(visible_list) + deallocate(visible_list) + + ! Set up non-blocking communications + communicator = halo_communicator(element_halo) + allocate(requests(nprocs)) + requests = MPI_REQUEST_NULL + rank = getrank(communicator) + tag = next_mpi_tag() + + do proc=1, nprocs - end do + if (halo_send_count(element_halo, proc)>0) then + call mpi_isend(send_lists(proc)%ptr, & + size(send_lists(proc)%ptr), MPI_INTEGER,& + proc-1, tag, communicator, requests(proc), ierr) + assert(ierr == MPI_SUCCESS) + end if - allocate(visible_elements(nprocs)) + end do - ! Wait for incoming data. - do proc=1, nprocs + allocate(visible_elements(nprocs)) - ! note we don't actually use 'proc' in this loop - ! all that matters is that the number of probe+recv calls - ! equals the number of procs that we have recv elements of - if (halo_receive_count(element_halo, proc)==0) cycle + ! Wait for incoming data. + do proc=1, nprocs - call mpi_probe(MPI_ANY_SOURCE, tag, communicator, status,& - & ierr) - assert(ierr == MPI_SUCCESS) + ! note we don't actually use 'proc' in this loop + ! all that matters is that the number of probe+recv calls + ! equals the number of procs that we have recv elements of + if (halo_receive_count(element_halo, proc)==0) cycle - call mpi_get_count(status, MPI_INTEGER, count, ierr) - assert(ierr == MPI_SUCCESS) + call mpi_probe(MPI_ANY_SOURCE, tag, communicator, status,& + & ierr) + assert(ierr == MPI_SUCCESS) + + call mpi_get_count(status, MPI_INTEGER, count, ierr) + assert(ierr == MPI_SUCCESS) - allocate(receive_list(count)) + allocate(receive_list(count)) - call mpi_recv(receive_list, count, MPI_INTEGER, status(MPI_SOURCE),& + call mpi_recv(receive_list, count, MPI_INTEGER, status(MPI_SOURCE),& tag, communicator, MPI_STATUS_IGNORE, ierr) - assert(ierr == MPI_SUCCESS) - - sendproc=status(MPI_SOURCE)+1 - ! For each element on the recieves list for this processor, record - ! which other elements know about it. - receives = halo_receive_count(element_halo, sendproc) - pos = receives - do e=1, receives - ! Recall that the first halo_receive_count entries in the list - ! simply say how many extra processors know about this element. - do p=1,receive_list(e) - pos=pos+1 - call insert_ascending(visible_elements(receive_list(pos)), & + assert(ierr == MPI_SUCCESS) + + sendproc=status(MPI_SOURCE)+1 + ! For each element on the recieves list for this processor, record + ! which other elements know about it. + receives = halo_receive_count(element_halo, sendproc) + pos = receives + do e=1, receives + ! Recall that the first halo_receive_count entries in the list + ! simply say how many extra processors know about this element. + do p=1,receive_list(e) + pos=pos+1 + call insert_ascending(visible_elements(receive_list(pos)), & halo_receive(element_halo, sendproc, e)) - end do - end do - - assert(pos==size(receive_list)) - deallocate(receive_list) - end do - - ! Wait for sends to complete - call mpi_waitall(size(requests), requests, MPI_STATUSES_IGNORE, ierr) - - ! Now actually sort out the lists. The elements which proc and this - ! processor can both see comprise the send and receive elements between - ! these two processors, plus the elements which other processors send - ! to proc and which we were told about above. - do proc=1, nprocs - sends=halo_send_count(element_halo,proc) - receives=halo_receive_count(element_halo,proc) - allocate(known_element_lists(proc)%ptr(& + end do + end do + + assert(pos==size(receive_list)) + deallocate(receive_list) + end do + + ! Wait for sends to complete + call mpi_waitall(size(requests), requests, MPI_STATUSES_IGNORE, ierr) + + ! Now actually sort out the lists. The elements which proc and this + ! processor can both see comprise the send and receive elements between + ! these two processors, plus the elements which other processors send + ! to proc and which we were told about above. + do proc=1, nprocs + sends=halo_send_count(element_halo,proc) + receives=halo_receive_count(element_halo,proc) + allocate(known_element_lists(proc)%ptr(& sends+receives+visible_elements(proc)%length)) - known_element_lists(proc)%ptr(:sends) & + known_element_lists(proc)%ptr(:sends) & = halo_sends(element_halo, proc) - known_element_lists(proc)%ptr(sends+1:sends+receives) & + known_element_lists(proc)%ptr(sends+1:sends+receives) & = halo_receives(element_halo, proc) - known_element_lists(proc)%ptr(sends+receives+1:) & + known_element_lists(proc)%ptr(sends+receives+1:) & = list2vector(visible_elements(proc)) - end do + end do - call flush_lists(visible_elements) + call flush_lists(visible_elements) - do proc=1, nprocs - if (halo_send_count(element_halo, proc)>0) then - deallocate(send_lists(proc)%ptr) - end if - end do + do proc=1, nprocs + if (halo_send_count(element_halo, proc)>0) then + deallocate(send_lists(proc)%ptr) + end if + end do #else - FLAbort("Communicating halo visibility makes no sense without MPI.") + FLAbort("Communicating halo visibility makes no sense without MPI.") #endif - end subroutine element_halo_communicate_visibility + end subroutine element_halo_communicate_visibility end module global_numbering diff --git a/femtools/Global_Parameters.F90 b/femtools/Global_Parameters.F90 index b8d07adbd4..951425f0c2 100644 --- a/femtools/Global_Parameters.F90 +++ b/femtools/Global_Parameters.F90 @@ -28,142 +28,142 @@ #include "fdebug.h" module global_parameters - !!< This routine exists to save us all from argument list hell! - !!< - !!< All the global parameters which don't change while fluidity is running - !!< should live here. I am building this up as I encounter more parameters - !!< in the code. It would be great if others did the same. - !!< - !!< The correct syntax for accessing this module is: - !!< - !!< use global_parameters, only: parameter1, parameter2 ... - !!< - !!< Try to only use the parameters which are needed locally. - - ! Debug specific paramaters are contained in fldebug_parameters - ! (to resolve build dependencies) - use fldebug_parameters - use iso_c_binding - - implicit none - - !------------------------------------------------------------------------ - ! Precision parameters - !------------------------------------------------------------------------ - !! Number of digits past the decimal point for a real - integer, parameter :: real_digits_10 = precision(0.0) - - !! Integer size in bytes - integer, parameter :: integer_size=bit_size(0)/8 - ! The real_size depends on reals having the obvious ieee754 sizes. - !! Real size in bytes + !!< This routine exists to save us all from argument list hell! + !!< + !!< All the global parameters which don't change while fluidity is running + !!< should live here. I am building this up as I encounter more parameters + !!< in the code. It would be great if others did the same. + !!< + !!< The correct syntax for accessing this module is: + !!< + !!< use global_parameters, only: parameter1, parameter2 ... + !!< + !!< Try to only use the parameters which are needed locally. + + ! Debug specific paramaters are contained in fldebug_parameters + ! (to resolve build dependencies) + use fldebug_parameters + use iso_c_binding + + implicit none + + !------------------------------------------------------------------------ + ! Precision parameters + !------------------------------------------------------------------------ + !! Number of digits past the decimal point for a real + integer, parameter :: real_digits_10 = precision(0.0) + + !! Integer size in bytes + integer, parameter :: integer_size=bit_size(0)/8 + ! The real_size depends on reals having the obvious ieee754 sizes. + !! Real size in bytes #ifdef DOUBLEP - integer, parameter :: real_size=8 + integer, parameter :: real_size=8 #else - integer, parameter :: real_size=4 + integer, parameter :: real_size=4 #endif - !------------------------------------------------------------------------ - ! Parameters controlling the scheme used in the flow core. - !------------------------------------------------------------------------ - - - !! The simulation start time (model time) - real, save :: simulation_start_time - !! The simulation start CPU time - real, save :: simulation_start_cpu_time - !! The simulation start wall time - real, save :: simulation_start_wall_time - - !! Accumulated system time. - real, save, target :: current_time - !! The timestep. - real, save, target :: dt - !! The current timestep number - integer, save, target :: timestep = 0 - - real, parameter:: pi = 3.1415926535897931 - - !------------------------------------------------------------------------ - ! Parameters for parallel - !------------------------------------------------------------------------ - - !! When upscaling a problem (e.g. from 16 to 32 processors), - !! we want to run sam on 32 processors to do the domain decomposition. - !! But only 16 processors will have data on disk. However, - !! all 32 processors still have to go through populate_state - !! to make sure it goes through all the MPI calls and doesn't - !! deadlock. So we record whether the process is an "active" process, - !! one that has data on disk. - logical :: is_active_process = .true. - integer :: no_active_processes = -1 - - !------------------------------------------------------------------------ - ! Field names and paths - !------------------------------------------------------------------------ - - ! Zeroing long strings is EXPENSIVE. - ! (See the commit message for r11059) - ! That is why we supply an empty_name and an empty_path - ! as, e.g., - ! field%option_path=empty_path - ! is much much quicker than - ! field%option_path="" . - ! This is probably a bug in gcc, but it is a bug in gcc - ! that we have to live with. - - !! Field names are permitted to be as long as Fortran names. - integer, parameter :: FIELD_NAME_LEN=101 - character(len=FIELD_NAME_LEN) :: empty_name="" - - !! Maximum length of an option path - integer, parameter :: OPTION_PATH_LEN=8192 - character(len=OPTION_PATH_LEN) :: empty_path="" - - !! Maximum length of a python string representing a function - integer, parameter :: PYTHON_FUNC_LEN=8192 - character(len=PYTHON_FUNC_LEN) :: empty_python_func="" - - !! Name of the topology mesh in state - this mesh is used by adaptivity - !! for the error metric etc. - character(len=FIELD_NAME_LEN):: topology_mesh_name="" - - !! Name of mesh to be handled by adapt_state() - character(len=FIELD_NAME_LEN):: adaptivity_mesh_name="" - - !! optionpath where the periodic boundary conditions are defined - character(len=OPTION_PATH_LEN), dimension(3) :: periodic_boundary_option_path="" - - !! The bounding box of the input domain - ! dim x 2 - ! (:, 1) are the minima along each coordinate - ! (:, 2) are the maxima along each coordinate - real, dimension(:, :), allocatable :: domain_bbox - - real :: domain_volume - - !! When on-the-sphere, the planet radius is needed. - ! The variable is initiliased as unity, to avoid garbage - ! being passed around. - real :: surface_radius = 1.0 - - ! Colouring "enum". These can't be in the colouring module due to circular dependencies - integer, parameter :: COLOURING_CG1 = 1 - integer, parameter :: COLOURING_DG0 = 2 - integer, parameter :: COLOURING_DG1 = 3 - integer, parameter :: COLOURING_DG2 = 4 - integer, parameter :: NUM_COLOURINGS = 4 - - contains - - function get_surface_radius() bind(c) - !C-inter-operable subroutine for making the value of surface_radius availabe - ! to C functions. - implicit none - - real(kind=c_double) :: get_surface_radius - - get_surface_radius = real(surface_radius, kind=c_double) - end function get_surface_radius + !------------------------------------------------------------------------ + ! Parameters controlling the scheme used in the flow core. + !------------------------------------------------------------------------ + + + !! The simulation start time (model time) + real, save :: simulation_start_time + !! The simulation start CPU time + real, save :: simulation_start_cpu_time + !! The simulation start wall time + real, save :: simulation_start_wall_time + + !! Accumulated system time. + real, save, target :: current_time + !! The timestep. + real, save, target :: dt + !! The current timestep number + integer, save, target :: timestep = 0 + + real, parameter:: pi = 3.1415926535897931 + + !------------------------------------------------------------------------ + ! Parameters for parallel + !------------------------------------------------------------------------ + + !! When upscaling a problem (e.g. from 16 to 32 processors), + !! we want to run sam on 32 processors to do the domain decomposition. + !! But only 16 processors will have data on disk. However, + !! all 32 processors still have to go through populate_state + !! to make sure it goes through all the MPI calls and doesn't + !! deadlock. So we record whether the process is an "active" process, + !! one that has data on disk. + logical :: is_active_process = .true. + integer :: no_active_processes = -1 + + !------------------------------------------------------------------------ + ! Field names and paths + !------------------------------------------------------------------------ + + ! Zeroing long strings is EXPENSIVE. + ! (See the commit message for r11059) + ! That is why we supply an empty_name and an empty_path + ! as, e.g., + ! field%option_path=empty_path + ! is much much quicker than + ! field%option_path="" . + ! This is probably a bug in gcc, but it is a bug in gcc + ! that we have to live with. + + !! Field names are permitted to be as long as Fortran names. + integer, parameter :: FIELD_NAME_LEN=101 + character(len=FIELD_NAME_LEN) :: empty_name="" + + !! Maximum length of an option path + integer, parameter :: OPTION_PATH_LEN=8192 + character(len=OPTION_PATH_LEN) :: empty_path="" + + !! Maximum length of a python string representing a function + integer, parameter :: PYTHON_FUNC_LEN=8192 + character(len=PYTHON_FUNC_LEN) :: empty_python_func="" + + !! Name of the topology mesh in state - this mesh is used by adaptivity + !! for the error metric etc. + character(len=FIELD_NAME_LEN):: topology_mesh_name="" + + !! Name of mesh to be handled by adapt_state() + character(len=FIELD_NAME_LEN):: adaptivity_mesh_name="" + + !! optionpath where the periodic boundary conditions are defined + character(len=OPTION_PATH_LEN), dimension(3) :: periodic_boundary_option_path="" + + !! The bounding box of the input domain + ! dim x 2 + ! (:, 1) are the minima along each coordinate + ! (:, 2) are the maxima along each coordinate + real, dimension(:, :), allocatable :: domain_bbox + + real :: domain_volume + + !! When on-the-sphere, the planet radius is needed. + ! The variable is initiliased as unity, to avoid garbage + ! being passed around. + real :: surface_radius = 1.0 + + ! Colouring "enum". These can't be in the colouring module due to circular dependencies + integer, parameter :: COLOURING_CG1 = 1 + integer, parameter :: COLOURING_DG0 = 2 + integer, parameter :: COLOURING_DG1 = 3 + integer, parameter :: COLOURING_DG2 = 4 + integer, parameter :: NUM_COLOURINGS = 4 + +contains + + function get_surface_radius() bind(c) + !C-inter-operable subroutine for making the value of surface_radius availabe + ! to C functions. + implicit none + + real(kind=c_double) :: get_surface_radius + + get_surface_radius = real(surface_radius, kind=c_double) + end function get_surface_radius end module global_parameters diff --git a/femtools/Grundmann_Moeller_Quadrature.F90 b/femtools/Grundmann_Moeller_Quadrature.F90 index faf5953aea..ada6274e87 100644 --- a/femtools/Grundmann_Moeller_Quadrature.F90 +++ b/femtools/Grundmann_Moeller_Quadrature.F90 @@ -1,1242 +1,1242 @@ module grundmann_moeller_quadrature - use iso_c_binding, only: c_float, c_double - - implicit none - - interface gm_rule_set - module procedure gm_rule_set_sp, gm_rule_set_orig - end interface gm_rule_set - - contains - subroutine comp_next ( n, k, a, more, h, t ) - - !*****************************************************************************80 - ! - !! COMP_NEXT computes the compositions of the integer N into K parts. - ! - ! Discussion: - ! - ! A composition of the integer N into K parts is an ordered sequence - ! of K nonnegative integers which sum to N. The compositions (1,2,1) - ! and (1,1,2) are considered to be distinct. - ! - ! The routine computes one composition on each call until there are no more. - ! For instance, one composition of 6 into 3 parts is - ! 3+2+1, another would be 6+0+0. - ! - ! On the first call to this routine, set MORE = FALSE. The routine - ! will compute the first element in the sequence of compositions, and - ! return it, as well as setting MORE = TRUE. If more compositions - ! are desired, call again, and again. Each time, the routine will - ! return with a new composition. - ! - ! However, when the LAST composition in the sequence is computed - ! and returned, the routine will reset MORE to FALSE, signaling that - ! the end of the sequence has been reached. - ! - ! Example: - ! - ! The 28 compositions of 6 into three parts are: - ! - ! 6 0 0, 5 1 0, 5 0 1, 4 2 0, 4 1 1, 4 0 2, - ! 3 3 0, 3 2 1, 3 1 2, 3 0 3, 2 4 0, 2 3 1, - ! 2 2 2, 2 1 3, 2 0 4, 1 5 0, 1 4 1, 1 3 2, - ! 1 2 3, 1 1 4, 1 0 5, 0 6 0, 0 5 1, 0 4 2, - ! 0 3 3, 0 2 4, 0 1 5, 0 0 6. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 09 July 2007 - ! - ! Author: - ! - ! FORTRAN77 original version by Albert Nijenhuis, Herbert Wilf. - ! FORTRAN90 version by John Burkardt - ! - ! Reference: - ! - ! Albert Nijenhuis, Herbert Wilf, - ! Combinatorial Algorithms for Computers and Calculators, - ! Second Edition, - ! Academic Press, 1978, - ! ISBN: 0-12-519260-6, - ! LC: QA164.N54. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) N, the integer whose compositions are desired. - ! - ! Input, integer ( kind = 4 ) K, the number of parts in the composition. - ! - ! Input/output, integer ( kind = 4 ) A(K), the parts of the composition. - ! - ! Input/output, logical MORE, set by the user to start the computation, - ! and by the routine to terminate it. - ! - ! Input/output, integer ( kind = 4 ) H, T, values used by the program. - ! The user should NOT set or alter these quantities. - ! - implicit none - - integer ( kind = 4 ) k - - integer ( kind = 4 ) a(k) - integer ( kind = 4 ) h - logical more - integer ( kind = 4 ) n - integer ( kind = 4 ) t - ! - ! The first computation. - ! - if ( .not. more ) then - - t = n - h = 0 - a(1) = n - a(2:k) = 0 - ! - ! The next computation. - ! - else - - if ( 1 < t ) then - h = 0 - end if + use iso_c_binding, only: c_float, c_double + + implicit none + + interface gm_rule_set + module procedure gm_rule_set_sp, gm_rule_set_orig + end interface gm_rule_set + +contains + subroutine comp_next ( n, k, a, more, h, t ) + + !*****************************************************************************80 + ! + !! COMP_NEXT computes the compositions of the integer N into K parts. + ! + ! Discussion: + ! + ! A composition of the integer N into K parts is an ordered sequence + ! of K nonnegative integers which sum to N. The compositions (1,2,1) + ! and (1,1,2) are considered to be distinct. + ! + ! The routine computes one composition on each call until there are no more. + ! For instance, one composition of 6 into 3 parts is + ! 3+2+1, another would be 6+0+0. + ! + ! On the first call to this routine, set MORE = FALSE. The routine + ! will compute the first element in the sequence of compositions, and + ! return it, as well as setting MORE = TRUE. If more compositions + ! are desired, call again, and again. Each time, the routine will + ! return with a new composition. + ! + ! However, when the LAST composition in the sequence is computed + ! and returned, the routine will reset MORE to FALSE, signaling that + ! the end of the sequence has been reached. + ! + ! Example: + ! + ! The 28 compositions of 6 into three parts are: + ! + ! 6 0 0, 5 1 0, 5 0 1, 4 2 0, 4 1 1, 4 0 2, + ! 3 3 0, 3 2 1, 3 1 2, 3 0 3, 2 4 0, 2 3 1, + ! 2 2 2, 2 1 3, 2 0 4, 1 5 0, 1 4 1, 1 3 2, + ! 1 2 3, 1 1 4, 1 0 5, 0 6 0, 0 5 1, 0 4 2, + ! 0 3 3, 0 2 4, 0 1 5, 0 0 6. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 09 July 2007 + ! + ! Author: + ! + ! FORTRAN77 original version by Albert Nijenhuis, Herbert Wilf. + ! FORTRAN90 version by John Burkardt + ! + ! Reference: + ! + ! Albert Nijenhuis, Herbert Wilf, + ! Combinatorial Algorithms for Computers and Calculators, + ! Second Edition, + ! Academic Press, 1978, + ! ISBN: 0-12-519260-6, + ! LC: QA164.N54. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the integer whose compositions are desired. + ! + ! Input, integer ( kind = 4 ) K, the number of parts in the composition. + ! + ! Input/output, integer ( kind = 4 ) A(K), the parts of the composition. + ! + ! Input/output, logical MORE, set by the user to start the computation, + ! and by the routine to terminate it. + ! + ! Input/output, integer ( kind = 4 ) H, T, values used by the program. + ! The user should NOT set or alter these quantities. + ! + implicit none + + integer ( kind = 4 ) k + + integer ( kind = 4 ) a(k) + integer ( kind = 4 ) h + logical more + integer ( kind = 4 ) n + integer ( kind = 4 ) t + ! + ! The first computation. + ! + if ( .not. more ) then + + t = n + h = 0 + a(1) = n + a(2:k) = 0 + ! + ! The next computation. + ! + else - h = h + 1 - t = a(h) - a(h) = 0 - a(1) = t - 1 - a(h+1) = a(h+1) + 1 - - end if - ! - ! This is the last element of the sequence if all the - ! items are in the last slot. - ! - more = ( a(k) /= n ) - - return - end subroutine - subroutine get_unit ( iunit ) - - !*****************************************************************************80 - ! - !! GET_UNIT returns a free FORTRAN unit number. - ! - ! Discussion: - ! - ! A "free" FORTRAN unit number is an integer between 1 and 99 which - ! is not currently associated with an I/O device. A free FORTRAN unit - ! number is needed in order to open a file with the OPEN command. - ! - ! If IUNIT = 0, then no free FORTRAN unit could be found, although - ! all 99 units were checked (except for units 5, 6 and 9, which - ! are commonly reserved for console I/O). - ! - ! Otherwise, IUNIT is an integer between 1 and 99, representing a - ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 - ! are special, and will never return those values. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 18 September 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Output, integer( kind = 4 ) IUNIT, the free unit number. - ! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) ios - integer ( kind = 4 ) iunit - logical ( kind = 4 ) lopen - - iunit = 0 - - do i = 1, 99 - - if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then - - inquire ( unit = i, opened = lopen, iostat = ios ) - - if ( ios == 0 ) then - if ( .not. lopen ) then - iunit = i - return - end if - end if + if ( 1 < t ) then + h = 0 + end if + + h = h + 1 + t = a(h) + a(h) = 0 + a(1) = t - 1 + a(h+1) = a(h+1) + 1 end if + ! + ! This is the last element of the sequence if all the + ! items are in the last slot. + ! + more = ( a(k) /= n ) + + return + end subroutine + subroutine get_unit ( iunit ) + + !*****************************************************************************80 + ! + !! GET_UNIT returns a free FORTRAN unit number. + ! + ! Discussion: + ! + ! A "free" FORTRAN unit number is an integer between 1 and 99 which + ! is not currently associated with an I/O device. A free FORTRAN unit + ! number is needed in order to open a file with the OPEN command. + ! + ! If IUNIT = 0, then no free FORTRAN unit could be found, although + ! all 99 units were checked (except for units 5, 6 and 9, which + ! are commonly reserved for console I/O). + ! + ! Otherwise, IUNIT is an integer between 1 and 99, representing a + ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 + ! are special, and will never return those values. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 18 September 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Output, integer( kind = 4 ) IUNIT, the free unit number. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) ios + integer ( kind = 4 ) iunit + logical ( kind = 4 ) lopen + + iunit = 0 + + do i = 1, 99 + + if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then + + inquire ( unit = i, opened = lopen, iostat = ios ) + + if ( ios == 0 ) then + if ( .not. lopen ) then + iunit = i + return + end if + end if + + end if + + end do + + return + end subroutine + + subroutine gm_rule_set_sp(rule, dim_num, point_num, w, x) + integer, intent(in) :: rule + integer, intent(in) :: dim_num + integer, intent(in) :: point_num + real(kind = c_float), dimension(point_num), intent(out) :: w + real(kind = c_float), dimension(dim_num, point_num), intent(out) :: x + + real(kind = c_double), dimension(point_num) :: lw + real(kind = c_double), dimension(dim_num, point_num) :: lx + + call gm_rule_set(rule, dim_num, point_num, lw, lx) + w = lw + x = lx + + end subroutine gm_rule_set_sp + + subroutine gm_rule_set_orig ( rule, dim_num, point_num, w, x ) + + !*****************************************************************************80 + ! + !! GM_RULE_SET sets a Grundmann-Moeller rule. + ! + ! Discussion: + ! + ! This is a revised version of the calculation which seeks to compute + ! the value of the weight in a cautious way that avoids intermediate + ! overflow. Thanks to John Peterson for pointing out the problem on + ! 26 June 2008. + ! + ! This rule returns weights and abscissas of a Grundmann-Moeller + ! quadrature rule for the DIM_NUM-dimensional unit simplex. + ! + ! The dimension POINT_NUM can be determined by calling GM_RULE_SIZE. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 26 June 2008 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Axel Grundmann, Michael Moeller, + ! Invariant Integration Formulas for the N-Simplex + ! by Combinatorial Methods, + ! SIAM Journal on Numerical Analysis, + ! Volume 15, Number 2, April 1978, pages 282-290. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! 0 <= RULE. + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! 1 <= DIM_NUM. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. + ! + ! Output, real ( kind = 8 ) W(POINT_NUM), the weights. + ! + ! Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the abscissas. + ! + implicit none + + integer ( kind = 4 ) dim_num + integer ( kind = 4 ) point_num + + integer ( kind = 4 ) beta(dim_num+1) + integer ( kind = 4 ) beta_sum + integer ( kind = 4 ) d + integer ( kind = 4 ) h + integer ( kind = 4 ) i + integer ( kind = 4 ) j + integer ( kind = 4 ), parameter :: i4_1 = 1 + integer ( kind = 4 ) k + logical more + integer ( kind = 4 ) n + integer ( kind = 4 ) one_pm + integer ( kind = 4 ) rule + integer ( kind = 4 ) s + integer ( kind = 4 ) t + real ( kind = 8 ) w(point_num) + real ( kind = 8 ) weight + real ( kind = 8 ) x(dim_num, point_num) + + s = rule + d = 2 * s + 1 + k = 0 + n = dim_num + one_pm = 1 + + do i = 0, s + + weight = real ( one_pm ) + + do j = 1, max ( n, d, d + n - i ) + + if ( j <= n ) then + weight = weight * real ( j, kind = 8 ) + end if + if ( j <= d ) then + weight = weight * real ( d + n - 2 * i, kind = 8 ) + end if + if ( j <= 2 * s ) then + weight = weight / 2.0D+00 + end if + if ( j <= i ) then + weight = weight / real ( j, kind = 8 ) + end if + if ( j <= d + n - i ) then + weight = weight / real ( j, kind = 8 ) + end if + + end do + + one_pm = - one_pm + + beta_sum = s - i + more = .false. + h = 0; + t = 0; + + do + + call comp_next ( beta_sum, dim_num + i4_1, beta, more, h, t ) + + k = k + 1 + + w(k) = weight + + x(1:dim_num,k) = real ( 2 * beta(2:dim_num+1) + 1, kind = 8 ) & + / real ( d + n - 2 * i, kind = 8 ) + + if ( .not. more ) then + exit + end if + + end do + + end do - end do - - return - end subroutine - - subroutine gm_rule_set_sp(rule, dim_num, point_num, w, x) - integer, intent(in) :: rule - integer, intent(in) :: dim_num - integer, intent(in) :: point_num - real(kind = c_float), dimension(point_num), intent(out) :: w - real(kind = c_float), dimension(dim_num, point_num), intent(out) :: x - - real(kind = c_double), dimension(point_num) :: lw - real(kind = c_double), dimension(dim_num, point_num) :: lx - - call gm_rule_set(rule, dim_num, point_num, lw, lx) - w = lw - x = lx - - end subroutine gm_rule_set_sp - - subroutine gm_rule_set_orig ( rule, dim_num, point_num, w, x ) - - !*****************************************************************************80 - ! - !! GM_RULE_SET sets a Grundmann-Moeller rule. - ! - ! Discussion: - ! - ! This is a revised version of the calculation which seeks to compute - ! the value of the weight in a cautious way that avoids intermediate - ! overflow. Thanks to John Peterson for pointing out the problem on - ! 26 June 2008. - ! - ! This rule returns weights and abscissas of a Grundmann-Moeller - ! quadrature rule for the DIM_NUM-dimensional unit simplex. - ! - ! The dimension POINT_NUM can be determined by calling GM_RULE_SIZE. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 26 June 2008 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Axel Grundmann, Michael Moeller, - ! Invariant Integration Formulas for the N-Simplex - ! by Combinatorial Methods, - ! SIAM Journal on Numerical Analysis, - ! Volume 15, Number 2, April 1978, pages 282-290. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! 0 <= RULE. - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! 1 <= DIM_NUM. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. - ! - ! Output, real ( kind = 8 ) W(POINT_NUM), the weights. - ! - ! Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the abscissas. - ! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ) point_num - - integer ( kind = 4 ) beta(dim_num+1) - integer ( kind = 4 ) beta_sum - integer ( kind = 4 ) d - integer ( kind = 4 ) h - integer ( kind = 4 ) i - integer ( kind = 4 ) j - integer ( kind = 4 ), parameter :: i4_1 = 1 - integer ( kind = 4 ) k - logical more - integer ( kind = 4 ) n - integer ( kind = 4 ) one_pm - integer ( kind = 4 ) rule - integer ( kind = 4 ) s - integer ( kind = 4 ) t - real ( kind = 8 ) w(point_num) - real ( kind = 8 ) weight - real ( kind = 8 ) x(dim_num, point_num) - - s = rule - d = 2 * s + 1 - k = 0 - n = dim_num - one_pm = 1 - - do i = 0, s - - weight = real ( one_pm ) - - do j = 1, max ( n, d, d + n - i ) - - if ( j <= n ) then - weight = weight * real ( j, kind = 8 ) - end if - if ( j <= d ) then - weight = weight * real ( d + n - 2 * i, kind = 8 ) - end if - if ( j <= 2 * s ) then - weight = weight / 2.0D+00 - end if - if ( j <= i ) then - weight = weight / real ( j, kind = 8 ) - end if - if ( j <= d + n - i ) then - weight = weight / real ( j, kind = 8 ) - end if + return + end subroutine + subroutine gm_rule_set_old ( rule, dim_num, point_num, w, x ) + + !*****************************************************************************80 + ! + !! GM_RULE_SET_OLD sets a Grundmann-Moeller rule. (OBSOLETE VERSION) + ! + ! Discussion: + ! + ! This version of the computation is no longer used. The direct + ! application of the formula results in overflows and inaccuracies + ! very quickly. + ! + ! This rule returns weights and abscissas of a Grundmann-Moeller + ! quadrature rule for the DIM_NUM-dimensional unit simplex. + ! + ! The dimension POINT_NUM can be determined by calling GM_RULE_SIZE. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 09 July 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Axel Grundmann, Michael Moeller, + ! Invariant Integration Formulas for the N-Simplex + ! by Combinatorial Methods, + ! SIAM Journal on Numerical Analysis, + ! Volume 15, Number 2, April 1978, pages 282-290. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! 0 <= RULE. + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! 1 <= DIM_NUM. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. + ! + ! Output, real ( kind = 8 ) W(POINT_NUM), the weights. + ! + ! Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the abscissas. + ! + implicit none + + integer ( kind = 4 ) dim_num + integer ( kind = 4 ) point_num + + integer ( kind = 4 ) beta(dim_num+1) + integer ( kind = 4 ) beta_sum + integer ( kind = 4 ) d + integer ( kind = 4 ) h + integer ( kind = 4 ) i + integer ( kind = 4 ), parameter :: i4_1 = 1 + integer ( kind = 4 ) k + logical more + integer ( kind = 4 ) n + integer ( kind = 4 ) one_pm + integer ( kind = 4 ) rule + integer ( kind = 4 ) s + integer ( kind = 4 ) t + real ( kind = 8 ) w(point_num) + real ( kind = 8 ) weight + real ( kind = 8 ) x(dim_num,point_num) + + s = rule + d = 2 * s + 1 + k = 0 + n = dim_num + one_pm = 1 + + do i = 0, s + + weight = r8_factorial ( n ) & + * real ( one_pm * ( d + n - 2 * i )**d, kind = 8 ) & + / ( real ( 2**(2*s), kind = 8 ) & + * r8_factorial ( i ) * r8_factorial ( d + n - i ) ) + + one_pm = - one_pm + + beta_sum = s - i + more = .false. + h = 0; + t = 0; + + do + + call comp_next ( beta_sum, dim_num + i4_1, beta, more, h, t ) + + k = k + 1 + + w(k) = weight + + x(1:dim_num,k) = real ( 2 * beta(2:dim_num+1) + 1, kind = 8 ) & + / real ( d + n - 2 * i, kind = 8 ) + + if ( .not. more ) then + exit + end if + + end do end do - one_pm = - one_pm + return + end subroutine + subroutine gm_rule_size ( rule, dim_num, point_num ) + + !*****************************************************************************80 + ! + !! GM_RULE_SIZE determines the size of a Grundmann-Moeller rule. + ! + ! Discussion: + ! + ! This rule returns the value of POINT_NUM, the number of points associated + ! with a GM rule of given index. + ! + ! After calling this rule, the user can use the value of POINT_NUM to + ! allocate space for the weight vector as W(POINT_NUM) and the abscissa + ! vector as X(DIM_NUM,POINT_NUM), and then call GM_RULE_SET. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 08 July 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Axel Grundmann, Michael Moeller, + ! Invariant Integration Formulas for the N-Simplex + ! by Combinatorial Methods, + ! SIAM Journal on Numerical Analysis, + ! Volume 15, Number 2, April 1978, pages 282-290. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! 0 <= RULE. + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! 1 <= DIM_NUM. + ! + ! Output, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. + ! + implicit none + + integer ( kind = 4 ) arg1 + integer ( kind = 4 ) dim_num + integer ( kind = 4 ) point_num + integer ( kind = 4 ) rule + + arg1 = dim_num + rule + 1 + + point_num = i4_choose ( arg1, rule ) + + return + end subroutine + function i4_choose ( n, k ) + + !*****************************************************************************80 + ! + !! I4_CHOOSE computes the binomial coefficient C(N,K). + ! + ! Discussion: + ! + ! The value is calculated in such a way as to avoid overflow and + ! roundoff. The calculation is done in integer arithmetic. + ! + ! The formula used is: + ! + ! C(N,K) = N! / ( K! * (N-K)! ) + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 02 June 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! ML Wolfson, HV Wright, + ! Algorithm 160: + ! Combinatorial of M Things Taken N at a Time, + ! Communications of the ACM, + ! Volume 6, Number 4, April 1963, page 161. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, K, are the values of N and K. + ! + ! Output, integer ( kind = 4 ) I4_CHOOSE, the number of combinations of N + ! things taken K at a time. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_choose + integer ( kind = 4 ) k + integer ( kind = 4 ) mn + integer ( kind = 4 ) mx + integer ( kind = 4 ) n + integer ( kind = 4 ) value + + mn = min ( k, n - k ) + + if ( mn < 0 ) then + + value = 0 + + else if ( mn == 0 ) then + + value = 1 + + else + + mx = max ( k, n - k ) + value = mx + 1 + + do i = 2, mn + value = ( value * ( mx + i ) ) / i + end do + + end if + + i4_choose = value + + return + end function + function i4_huge ( ) + + !*****************************************************************************80 + ! + !! I4_HUGE returns a "huge" I4. + ! + ! Discussion: + ! + ! On an IEEE 32 bit machine, I4_HUGE should be 2**31 - 1, and its + ! bit pattern should be + ! + ! 01111111111111111111111111111111 + ! + ! In this case, its numerical value is 2147483647. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 31 May 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Output, integer ( kind = 4 ) I4_HUGE, a "huge" I4. + ! + implicit none + + integer ( kind = 4 ) i4_huge + + i4_huge = 2147483647 + + return + end function + subroutine monomial_value ( dim_num, point_num, x, expon, value ) + + !*****************************************************************************80 + ! + !! MONOMIAL_VALUE evaluates a monomial. + ! + ! Discussion: + ! + ! This routine evaluates a monomial of the form + ! + ! product ( 1 <= dim <= dim_num ) x(dim)^expon(dim) + ! + ! where the exponents are nonnegative integers. Note that + ! if the combination 0^0 is encountered, it should be treated + ! as 1. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 04 May 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points at which the + ! monomial is to be evaluated. + ! + ! Input, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the point coordinates. + ! + ! Input, integer ( kind = 4 ) EXPON(DIM_NUM), the exponents. + ! + ! Output, real ( kind = 8 ) VALUE(POINT_NUM), the value of the monomial. + ! + implicit none + + integer ( kind = 4 ) dim_num + integer ( kind = 4 ) point_num + + integer ( kind = 4 ) dim + integer ( kind = 4 ) expon(dim_num) + real ( kind = 8 ) value(point_num) + real ( kind = 8 ) x(dim_num,point_num) + + value(1:point_num) = 1.0D+00 + + do dim = 1, dim_num + if ( 0 /= expon(dim) ) then + value(1:point_num) = value(1:point_num) * x(dim,1:point_num)**expon(dim) + end if + end do - beta_sum = s - i - more = .false. - h = 0; - t = 0; + return + end subroutine + function r8_factorial ( n ) + + !*****************************************************************************80 + ! + !! R8_FACTORIAL computes the factorial. + ! + ! Discussion: + ! + ! The formula used is: + ! + ! FACTORIAL ( N ) = PRODUCT ( 1 <= I <= N ) I + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 26 June 2008 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the argument of the factorial function. + ! If N is less than 1, R8_FACTORIAL is returned as 1. + ! + ! Output, real ( kind = 8 ) R8_FACTORIAL, the factorial of N. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) n + real ( kind = 8 ) r8_factorial + + r8_factorial = 1.0D+00 + + do i = 1, n + r8_factorial = r8_factorial * real ( i, kind = 8 ) + end do - do + return + end function + subroutine r8vec_uniform_01 ( n, seed, r ) + + !*****************************************************************************80 + ! + !! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. + ! + ! Discussion: + ! + ! An R8VEC is a vector of real ( kind = 8 ) values. + ! + ! For now, the input quantity SEED is an integer variable. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 31 May 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Paul Bratley, Bennett Fox, Linus Schrage, + ! A Guide to Simulation, + ! Second Edition, + ! Springer, 1987, + ! ISBN: 0387964673, + ! LC: QA76.9.C65.B73. + ! + ! Bennett Fox, + ! Algorithm 647: + ! Implementation and Relative Efficiency of Quasirandom + ! Sequence Generators, + ! ACM Transactions on Mathematical Software, + ! Volume 12, Number 4, December 1986, pages 362-376. + ! + ! Pierre L'Ecuyer, + ! Random Number Generation, + ! in Handbook of Simulation, + ! edited by Jerry Banks, + ! Wiley, 1998, + ! ISBN: 0471134031, + ! LC: T57.62.H37. + ! + ! Peter Lewis, Allen Goodman, James Miller, + ! A Pseudo-Random Number Generator for the System/360, + ! IBM Systems Journal, + ! Volume 8, 1969, pages 136-143. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the number of entries in the vector. + ! + ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which + ! should NOT be 0. On output, SEED has been updated. + ! + ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. + ! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + integer ( kind = 4 ) k + integer ( kind = 4 ) seed + real ( kind = 8 ) r(n) + + if ( seed == 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!' + write ( *, '(a)' ) ' Input value of SEED = 0.' + stop + end if - call comp_next ( beta_sum, dim_num + i4_1, beta, more, h, t ) + do i = 1, n - k = k + 1 + k = seed / 127773 - w(k) = weight + seed = 16807 * ( seed - k * 127773 ) - k * 2836 - x(1:dim_num,k) = real ( 2 * beta(2:dim_num+1) + 1, kind = 8 ) & - / real ( d + n - 2 * i, kind = 8 ) + if ( seed < 0 ) then + seed = seed + i4_huge ( ) + end if - if ( .not. more ) then - exit - end if + r(i) = real ( seed, kind = 8 ) * 4.656612875D-10 end do - end do - - return - end subroutine - subroutine gm_rule_set_old ( rule, dim_num, point_num, w, x ) - - !*****************************************************************************80 - ! - !! GM_RULE_SET_OLD sets a Grundmann-Moeller rule. (OBSOLETE VERSION) - ! - ! Discussion: - ! - ! This version of the computation is no longer used. The direct - ! application of the formula results in overflows and inaccuracies - ! very quickly. - ! - ! This rule returns weights and abscissas of a Grundmann-Moeller - ! quadrature rule for the DIM_NUM-dimensional unit simplex. - ! - ! The dimension POINT_NUM can be determined by calling GM_RULE_SIZE. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 09 July 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Axel Grundmann, Michael Moeller, - ! Invariant Integration Formulas for the N-Simplex - ! by Combinatorial Methods, - ! SIAM Journal on Numerical Analysis, - ! Volume 15, Number 2, April 1978, pages 282-290. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! 0 <= RULE. - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! 1 <= DIM_NUM. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. - ! - ! Output, real ( kind = 8 ) W(POINT_NUM), the weights. - ! - ! Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the abscissas. - ! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ) point_num - - integer ( kind = 4 ) beta(dim_num+1) - integer ( kind = 4 ) beta_sum - integer ( kind = 4 ) d - integer ( kind = 4 ) h - integer ( kind = 4 ) i - integer ( kind = 4 ), parameter :: i4_1 = 1 - integer ( kind = 4 ) k - logical more - integer ( kind = 4 ) n - integer ( kind = 4 ) one_pm - integer ( kind = 4 ) rule - integer ( kind = 4 ) s - integer ( kind = 4 ) t - real ( kind = 8 ) w(point_num) - real ( kind = 8 ) weight - real ( kind = 8 ) x(dim_num,point_num) - - s = rule - d = 2 * s + 1 - k = 0 - n = dim_num - one_pm = 1 - - do i = 0, s - - weight = r8_factorial ( n ) & - * real ( one_pm * ( d + n - 2 * i )**d, kind = 8 ) & - / ( real ( 2**(2*s), kind = 8 ) & - * r8_factorial ( i ) * r8_factorial ( d + n - i ) ) - - one_pm = - one_pm - - beta_sum = s - i - more = .false. - h = 0; - t = 0; - - do - - call comp_next ( beta_sum, dim_num + i4_1, beta, more, h, t ) - - k = k + 1 - - w(k) = weight - - x(1:dim_num,k) = real ( 2 * beta(2:dim_num+1) + 1, kind = 8 ) & - / real ( d + n - 2 * i, kind = 8 ) - - if ( .not. more ) then - exit - end if + return + end subroutine + subroutine simplex_unit_monomial_int ( dim_num, expon, value ) + + !*****************************************************************************80 + ! + !! SIMPLEX_UNIT_MONOMIAL_INT integrates a monomial over a simplex. + ! + ! Discussion: + ! + ! This routine evaluates a monomial of the form + ! + ! product ( 1 <= dim <= dim_num ) x(dim)^expon(dim) + ! + ! where the exponents are nonnegative integers. Note that + ! if the combination 0^0 is encountered, it should be treated + ! as 1. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 09 July 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! + ! Input, integer ( kind = 4 ) EXPON(DIM_NUM), the exponents. + ! + ! Output, real ( kind = 8 ) VALUE, the value of the integral of the + ! monomial. + ! + implicit none + + integer ( kind = 4 ) dim_num + + integer ( kind = 4 ) dim + integer ( kind = 4 ) expon(dim_num) + integer ( kind = 4 ) i + integer ( kind = 4 ) k + real ( kind = 8 ) value + ! + ! The first computation ends with VALUE = 1.0; + ! + value = 1.0D+00 + + k = 0 + + do dim = 1, dim_num + + do i = 1, expon(dim) + k = k + 1 + value = value * real ( i, kind = 8 ) / real ( k, kind = 8 ) + end do end do - end do - - return - end subroutine - subroutine gm_rule_size ( rule, dim_num, point_num ) - - !*****************************************************************************80 - ! - !! GM_RULE_SIZE determines the size of a Grundmann-Moeller rule. - ! - ! Discussion: - ! - ! This rule returns the value of POINT_NUM, the number of points associated - ! with a GM rule of given index. - ! - ! After calling this rule, the user can use the value of POINT_NUM to - ! allocate space for the weight vector as W(POINT_NUM) and the abscissa - ! vector as X(DIM_NUM,POINT_NUM), and then call GM_RULE_SET. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 08 July 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Axel Grundmann, Michael Moeller, - ! Invariant Integration Formulas for the N-Simplex - ! by Combinatorial Methods, - ! SIAM Journal on Numerical Analysis, - ! Volume 15, Number 2, April 1978, pages 282-290. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! 0 <= RULE. - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! 1 <= DIM_NUM. - ! - ! Output, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. - ! - implicit none - - integer ( kind = 4 ) arg1 - integer ( kind = 4 ) dim_num - integer ( kind = 4 ) point_num - integer ( kind = 4 ) rule - - arg1 = dim_num + rule + 1 - - point_num = i4_choose ( arg1, rule ) - - return - end subroutine - function i4_choose ( n, k ) - - !*****************************************************************************80 - ! - !! I4_CHOOSE computes the binomial coefficient C(N,K). - ! - ! Discussion: - ! - ! The value is calculated in such a way as to avoid overflow and - ! roundoff. The calculation is done in integer arithmetic. - ! - ! The formula used is: - ! - ! C(N,K) = N! / ( K! * (N-K)! ) - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 02 June 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! ML Wolfson, HV Wright, - ! Algorithm 160: - ! Combinatorial of M Things Taken N at a Time, - ! Communications of the ACM, - ! Volume 6, Number 4, April 1963, page 161. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) N, K, are the values of N and K. - ! - ! Output, integer ( kind = 4 ) I4_CHOOSE, the number of combinations of N - ! things taken K at a time. - ! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) i4_choose - integer ( kind = 4 ) k - integer ( kind = 4 ) mn - integer ( kind = 4 ) mx - integer ( kind = 4 ) n - integer ( kind = 4 ) value - - mn = min ( k, n - k ) - - if ( mn < 0 ) then - - value = 0 - - else if ( mn == 0 ) then - - value = 1 - - else - - mx = max ( k, n - k ) - value = mx + 1 - - do i = 2, mn - value = ( value * ( mx + i ) ) / i + do dim = 1, dim_num + + k = k + 1 + value = value / real ( k, kind = 8 ) + end do - end if - - i4_choose = value - - return - end function - function i4_huge ( ) - - !*****************************************************************************80 - ! - !! I4_HUGE returns a "huge" I4. - ! - ! Discussion: - ! - ! On an IEEE 32 bit machine, I4_HUGE should be 2**31 - 1, and its - ! bit pattern should be - ! - ! 01111111111111111111111111111111 - ! - ! In this case, its numerical value is 2147483647. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 31 May 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Output, integer ( kind = 4 ) I4_HUGE, a "huge" I4. - ! - implicit none - - integer ( kind = 4 ) i4_huge - - i4_huge = 2147483647 - - return - end function - subroutine monomial_value ( dim_num, point_num, x, expon, value ) - - !*****************************************************************************80 - ! - !! MONOMIAL_VALUE evaluates a monomial. - ! - ! Discussion: - ! - ! This routine evaluates a monomial of the form - ! - ! product ( 1 <= dim <= dim_num ) x(dim)^expon(dim) - ! - ! where the exponents are nonnegative integers. Note that - ! if the combination 0^0 is encountered, it should be treated - ! as 1. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 04 May 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points at which the - ! monomial is to be evaluated. - ! - ! Input, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the point coordinates. - ! - ! Input, integer ( kind = 4 ) EXPON(DIM_NUM), the exponents. - ! - ! Output, real ( kind = 8 ) VALUE(POINT_NUM), the value of the monomial. - ! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ) point_num - - integer ( kind = 4 ) dim - integer ( kind = 4 ) expon(dim_num) - real ( kind = 8 ) value(point_num) - real ( kind = 8 ) x(dim_num,point_num) - - value(1:point_num) = 1.0D+00 - - do dim = 1, dim_num - if ( 0 /= expon(dim) ) then - value(1:point_num) = value(1:point_num) * x(dim,1:point_num)**expon(dim) - end if - end do - - return - end subroutine - function r8_factorial ( n ) - - !*****************************************************************************80 - ! - !! R8_FACTORIAL computes the factorial. - ! - ! Discussion: - ! - ! The formula used is: - ! - ! FACTORIAL ( N ) = PRODUCT ( 1 <= I <= N ) I - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 26 June 2008 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) N, the argument of the factorial function. - ! If N is less than 1, R8_FACTORIAL is returned as 1. - ! - ! Output, real ( kind = 8 ) R8_FACTORIAL, the factorial of N. - ! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) n - real ( kind = 8 ) r8_factorial - - r8_factorial = 1.0D+00 - - do i = 1, n - r8_factorial = r8_factorial * real ( i, kind = 8 ) - end do - - return - end function - subroutine r8vec_uniform_01 ( n, seed, r ) - - !*****************************************************************************80 - ! - !! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. - ! - ! Discussion: - ! - ! An R8VEC is a vector of real ( kind = 8 ) values. - ! - ! For now, the input quantity SEED is an integer variable. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 31 May 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Paul Bratley, Bennett Fox, Linus Schrage, - ! A Guide to Simulation, - ! Second Edition, - ! Springer, 1987, - ! ISBN: 0387964673, - ! LC: QA76.9.C65.B73. - ! - ! Bennett Fox, - ! Algorithm 647: - ! Implementation and Relative Efficiency of Quasirandom - ! Sequence Generators, - ! ACM Transactions on Mathematical Software, - ! Volume 12, Number 4, December 1986, pages 362-376. - ! - ! Pierre L'Ecuyer, - ! Random Number Generation, - ! in Handbook of Simulation, - ! edited by Jerry Banks, - ! Wiley, 1998, - ! ISBN: 0471134031, - ! LC: T57.62.H37. - ! - ! Peter Lewis, Allen Goodman, James Miller, - ! A Pseudo-Random Number Generator for the System/360, - ! IBM Systems Journal, - ! Volume 8, 1969, pages 136-143. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) N, the number of entries in the vector. - ! - ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which - ! should NOT be 0. On output, SEED has been updated. - ! - ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. - ! - implicit none - - integer ( kind = 4 ) n - - integer ( kind = 4 ) i - integer ( kind = 4 ) k - integer ( kind = 4 ) seed - real ( kind = 8 ) r(n) - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - do i = 1, n - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + i4_huge ( ) - end if + return + end subroutine + subroutine simplex_unit_monomial_quadrature ( dim_num, expon, point_num, x, & + w, quad_error ) + + !*****************************************************************************80 + ! + !! SIMPLEX_UNIT_MONOMIAL_QUADRATURE: quadrature of monomials in a unit simplex. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 09 July 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! + ! Input, integer ( kind = 4 ) EXPON(DIM_NUM), the exponents. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. + ! + ! Input, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the quadrature points. + ! + ! Input, real ( kind = 8 ) W(POINT_NUM), the quadrature weights. + ! + ! Output, real ( kind = 8 ) QUAD_ERROR, the quadrature error. + ! + implicit none + + integer ( kind = 4 ) dim_num + + real ( kind = 8 ) exact + integer ( kind = 4 ) expon(dim_num) + integer ( kind = 4 ) point_num + real ( kind = 8 ) quad + real ( kind = 8 ) quad_error + real ( kind = 8 ) scale + real ( kind = 8 ) value(point_num) + real ( kind = 8 ) volume + real ( kind = 8 ) w(point_num) + real ( kind = 8 ) x(dim_num,point_num) + ! + ! Get the exact value of the integral of the unscaled monomial. + ! + call simplex_unit_monomial_int ( dim_num, expon, scale ) + ! + ! Evaluate the monomial at the quadrature points. + ! + call monomial_value ( dim_num, point_num, x, expon, value ) + ! + ! Compute the weighted sum and divide by the exact value. + ! + call simplex_unit_volume ( dim_num, volume ) + quad = volume * dot_product ( w, value ) / scale + ! + ! Error: + ! + exact = 1.0D+00 + quad_error = abs ( quad - exact ) + + return + end subroutine + subroutine simplex_unit_sample ( dim_num, point_num, seed, x ) + + !*****************************************************************************80 + ! + !! SIMPLEX_UNIT_SAMPLE returns uniformly random points from a general simplex. + ! + ! Discussion: + ! + ! The interior of the unit DIM_NUM-dimensional simplex is the set of + ! points X(1:DIM_NUM) such that each X(I) is nonnegative, and + ! sum(X(1:DIM_NUM)) <= 1. + ! + ! This routine is valid for any spatial dimension DIM_NUM. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 08 July 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Reuven Rubinstein, + ! Monte Carlo Optimization, Simulation, and Sensitivity + ! of Queueing Networks, + ! Krieger, 1992, + ! ISBN: 0894647644, + ! LC: QA298.R79. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points. + ! + ! Input/output, integer ( kind = 4 ) SEED, a seed for the random + ! number generator. + ! + ! Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the points. + ! + implicit none + + integer ( kind = 4 ) dim_num + integer ( kind = 4 ), parameter :: i4_1 = 1 + integer ( kind = 4 ) point_num + + real ( kind = 8 ) e(dim_num+1) + integer ( kind = 4 ) j + integer ( kind = 4 ) seed + real ( kind = 8 ) x(dim_num,point_num) + ! + ! The construction begins by sampling DIM_NUM+1 points from the + ! exponential distribution with parameter 1. + ! + do j = 1, point_num + + call r8vec_uniform_01 ( dim_num+i4_1, seed, e ) + + e(1:dim_num+1) = -log ( e(1:dim_num+1) ) + + x(1:dim_num,j) = e(1:dim_num) / sum ( e(1:dim_num+1) ) - r(i) = real ( seed, kind = 8 ) * 4.656612875D-10 - - end do - - return - end subroutine - subroutine simplex_unit_monomial_int ( dim_num, expon, value ) - - !*****************************************************************************80 - ! - !! SIMPLEX_UNIT_MONOMIAL_INT integrates a monomial over a simplex. - ! - ! Discussion: - ! - ! This routine evaluates a monomial of the form - ! - ! product ( 1 <= dim <= dim_num ) x(dim)^expon(dim) - ! - ! where the exponents are nonnegative integers. Note that - ! if the combination 0^0 is encountered, it should be treated - ! as 1. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 09 July 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! - ! Input, integer ( kind = 4 ) EXPON(DIM_NUM), the exponents. - ! - ! Output, real ( kind = 8 ) VALUE, the value of the integral of the - ! monomial. - ! - implicit none - - integer ( kind = 4 ) dim_num - - integer ( kind = 4 ) dim - integer ( kind = 4 ) expon(dim_num) - integer ( kind = 4 ) i - integer ( kind = 4 ) k - real ( kind = 8 ) value - ! - ! The first computation ends with VALUE = 1.0; - ! - value = 1.0D+00 - - k = 0 - - do dim = 1, dim_num - - do i = 1, expon(dim) - k = k + 1 - value = value * real ( i, kind = 8 ) / real ( k, kind = 8 ) end do - end do - - do dim = 1, dim_num - - k = k + 1 - value = value / real ( k, kind = 8 ) - - end do - - return - end subroutine - subroutine simplex_unit_monomial_quadrature ( dim_num, expon, point_num, x, & - w, quad_error ) - - !*****************************************************************************80 - ! - !! SIMPLEX_UNIT_MONOMIAL_QUADRATURE: quadrature of monomials in a unit simplex. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 09 July 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! - ! Input, integer ( kind = 4 ) EXPON(DIM_NUM), the exponents. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points in the rule. - ! - ! Input, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the quadrature points. - ! - ! Input, real ( kind = 8 ) W(POINT_NUM), the quadrature weights. - ! - ! Output, real ( kind = 8 ) QUAD_ERROR, the quadrature error. - ! - implicit none - - integer ( kind = 4 ) dim_num - - real ( kind = 8 ) exact - integer ( kind = 4 ) expon(dim_num) - integer ( kind = 4 ) point_num - real ( kind = 8 ) quad - real ( kind = 8 ) quad_error - real ( kind = 8 ) scale - real ( kind = 8 ) value(point_num) - real ( kind = 8 ) volume - real ( kind = 8 ) w(point_num) - real ( kind = 8 ) x(dim_num,point_num) - ! - ! Get the exact value of the integral of the unscaled monomial. - ! - call simplex_unit_monomial_int ( dim_num, expon, scale ) - ! - ! Evaluate the monomial at the quadrature points. - ! - call monomial_value ( dim_num, point_num, x, expon, value ) - ! - ! Compute the weighted sum and divide by the exact value. - ! - call simplex_unit_volume ( dim_num, volume ) - quad = volume * dot_product ( w, value ) / scale - ! - ! Error: - ! - exact = 1.0D+00 - quad_error = abs ( quad - exact ) - - return - end subroutine - subroutine simplex_unit_sample ( dim_num, point_num, seed, x ) - - !*****************************************************************************80 - ! - !! SIMPLEX_UNIT_SAMPLE returns uniformly random points from a general simplex. - ! - ! Discussion: - ! - ! The interior of the unit DIM_NUM-dimensional simplex is the set of - ! points X(1:DIM_NUM) such that each X(I) is nonnegative, and - ! sum(X(1:DIM_NUM)) <= 1. - ! - ! This routine is valid for any spatial dimension DIM_NUM. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 08 July 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Reuven Rubinstein, - ! Monte Carlo Optimization, Simulation, and Sensitivity - ! of Queueing Networks, - ! Krieger, 1992, - ! ISBN: 0894647644, - ! LC: QA298.R79. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the dimension of the space. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points. - ! - ! Input/output, integer ( kind = 4 ) SEED, a seed for the random - ! number generator. - ! - ! Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the points. - ! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), parameter :: i4_1 = 1 - integer ( kind = 4 ) point_num - - real ( kind = 8 ) e(dim_num+1) - integer ( kind = 4 ) j - integer ( kind = 4 ) seed - real ( kind = 8 ) x(dim_num,point_num) - ! - ! The construction begins by sampling DIM_NUM+1 points from the - ! exponential distribution with parameter 1. - ! - do j = 1, point_num - - call r8vec_uniform_01 ( dim_num+i4_1, seed, e ) - - e(1:dim_num+1) = -log ( e(1:dim_num+1) ) - - x(1:dim_num,j) = e(1:dim_num) / sum ( e(1:dim_num+1) ) - - end do - - return - end subroutine - subroutine simplex_unit_to_general ( dim_num, point_num, t, ref, phy ) - - !*****************************************************************************80 - ! - !! SIMPLEX_UNIT_TO_GENERAL maps the unit simplex to a general simplex. - ! - ! Discussion: - ! - ! Given that the unit simplex has been mapped to a general simplex - ! with vertices T, compute the images in T, under the same linear - ! mapping, of points whose coordinates in the unit simplex are REF. - ! - ! The vertices of the unit simplex are listed as suggested in the - ! following: - ! - ! (0,0,0,...,0) - ! (1,0,0,...,0) - ! (0,1,0,...,0) - ! (0,0,1,...,0) - ! (...........) - ! (0,0,0,...,1) - ! - ! Thanks to Andrei ("spiritualworlds") for pointing out a mistake in the - ! previous implementation of this routine, 02 March 2008. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 02 March 2008 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points to transform. - ! - ! Input, real ( kind = 8 ) T(DIM_NUM,DIM_NUM+1), the vertices of the - ! general simplex. - ! - ! Input, real ( kind = 8 ) REF(DIM_NUM,POINT_NUM), points in the - ! reference triangle. - ! - ! Output, real ( kind = 8 ) PHY(DIM_NUM,POINT_NUM), corresponding points - ! in the physical triangle. - ! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ) point_num - - integer ( kind = 4 ) dim - real ( kind = 8 ) phy(dim_num,point_num) - real ( kind = 8 ) ref(dim_num,point_num) - real ( kind = 8 ) t(dim_num,dim_num+1) - integer ( kind = 4 ) vertex - ! - ! The image of each point is initially the image of the origin. - ! - ! Insofar as the pre-image differs from the origin in a given vertex - ! direction, add that proportion of the difference between the images - ! of the origin and the vertex. - ! - do dim = 1, dim_num - - phy(dim,1:point_num) = t(dim,1) - - do vertex = 2, dim_num + 1 - - phy(dim,1:point_num) = phy(dim,1:point_num) & - + ( t(dim,vertex) - t(dim,1) ) * ref(vertex-1,1:point_num) + return + end subroutine + subroutine simplex_unit_to_general ( dim_num, point_num, t, ref, phy ) + + !*****************************************************************************80 + ! + !! SIMPLEX_UNIT_TO_GENERAL maps the unit simplex to a general simplex. + ! + ! Discussion: + ! + ! Given that the unit simplex has been mapped to a general simplex + ! with vertices T, compute the images in T, under the same linear + ! mapping, of points whose coordinates in the unit simplex are REF. + ! + ! The vertices of the unit simplex are listed as suggested in the + ! following: + ! + ! (0,0,0,...,0) + ! (1,0,0,...,0) + ! (0,1,0,...,0) + ! (0,0,1,...,0) + ! (...........) + ! (0,0,0,...,1) + ! + ! Thanks to Andrei ("spiritualworlds") for pointing out a mistake in the + ! previous implementation of this routine, 02 March 2008. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 02 March 2008 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points to transform. + ! + ! Input, real ( kind = 8 ) T(DIM_NUM,DIM_NUM+1), the vertices of the + ! general simplex. + ! + ! Input, real ( kind = 8 ) REF(DIM_NUM,POINT_NUM), points in the + ! reference triangle. + ! + ! Output, real ( kind = 8 ) PHY(DIM_NUM,POINT_NUM), corresponding points + ! in the physical triangle. + ! + implicit none + + integer ( kind = 4 ) dim_num + integer ( kind = 4 ) point_num + + integer ( kind = 4 ) dim + real ( kind = 8 ) phy(dim_num,point_num) + real ( kind = 8 ) ref(dim_num,point_num) + real ( kind = 8 ) t(dim_num,dim_num+1) + integer ( kind = 4 ) vertex + ! + ! The image of each point is initially the image of the origin. + ! + ! Insofar as the pre-image differs from the origin in a given vertex + ! direction, add that proportion of the difference between the images + ! of the origin and the vertex. + ! + do dim = 1, dim_num + + phy(dim,1:point_num) = t(dim,1) + + do vertex = 2, dim_num + 1 + + phy(dim,1:point_num) = phy(dim,1:point_num) & + + ( t(dim,vertex) - t(dim,1) ) * ref(vertex-1,1:point_num) + + end do end do - end do - - return - end subroutine - subroutine simplex_unit_volume ( dim_num, volume ) - - !*****************************************************************************80 - ! - !! SIMPLEX_UNIT_VOLUME computes the volume of the unit simplex. - ! - ! Discussion: - ! - ! The formula is simple: volume = 1/N!. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 29 March 2003 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. - ! - ! Output, real ( kind = 8 ) VOLUME, the volume of the cone. - ! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) dim_num - real ( kind = 8 ) volume - - volume = 1.0D+00 - do i = 1, dim_num - volume = volume / real ( i, kind = 8 ) - end do - - return - end subroutine - subroutine timestamp ( ) - - !*****************************************************************************80 - ! - !! TIMESTAMP prints the current YMDHMS date as a time stamp. - ! - ! Example: - ! - ! 31 May 2001 9:45:54.872 AM - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 06 August 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! None - ! - implicit none - - character ( len = 8 ) ampm - integer d - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - integer values(8) - integer y - - call date_and_time ( values = values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 + return + end subroutine + subroutine simplex_unit_volume ( dim_num, volume ) + + !*****************************************************************************80 + ! + !! SIMPLEX_UNIT_VOLUME computes the volume of the unit simplex. + ! + ! Discussion: + ! + ! The formula is simple: volume = 1/N!. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 29 March 2003 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. + ! + ! Output, real ( kind = 8 ) VOLUME, the volume of the cone. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) dim_num + real ( kind = 8 ) volume + + volume = 1.0D+00 + do i = 1, dim_num + volume = volume / real ( i, kind = 8 ) + end do + + return + end subroutine + subroutine timestamp ( ) + + !*****************************************************************************80 + ! + !! TIMESTAMP prints the current YMDHMS date as a time stamp. + ! + ! Example: + ! + ! 31 May 2001 9:45:54.872 AM + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 06 August 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! None + ! + implicit none + + character ( len = 8 ) ampm + integer d + integer h + integer m + integer mm + character ( len = 9 ), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December ' /) + integer n + integer s + integer values(8) + integer y + + call date_and_time ( values = values ) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + if ( h < 12 ) then - ampm = 'PM' + ampm = 'AM' else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if + if ( n == 0 .and. s == 0 ) then + ampm = 'Noon' + else + ampm = 'PM' + end if + else + h = h - 12 + if ( h < 12 ) then + ampm = 'PM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if end if - end if - write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) + write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & + d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - return - end subroutine + return + end subroutine end module grundmann_moeller_quadrature diff --git a/femtools/Halo_Data_Types.F90 b/femtools/Halo_Data_Types.F90 index ce3f12771e..a676a60e26 100644 --- a/femtools/Halo_Data_Types.F90 +++ b/femtools/Halo_Data_Types.F90 @@ -29,77 +29,77 @@ module halo_data_types - use global_parameters, only : FIELD_NAME_LEN - use futils - use mpi_interfaces - use reference_counting + use global_parameters, only : FIELD_NAME_LEN + use futils + use mpi_interfaces + use reference_counting - implicit none + implicit none - private + private - public :: halo_type, halo_pointer + public :: halo_type, halo_pointer - !! Halo data types - integer, parameter, public :: HALO_TYPE_CG_NODE = 1,& - HALO_TYPE_DG_NODE = 2, & - HALO_TYPE_ELEMENT = 3 + !! Halo data types + integer, parameter, public :: HALO_TYPE_CG_NODE = 1,& + HALO_TYPE_DG_NODE = 2, & + HALO_TYPE_ELEMENT = 3 - !! Halo ordering schemes - integer, parameter, public :: HALO_ORDER_GENERAL = 1, & - & HALO_ORDER_TRAILING_RECEIVES = 2 + !! Halo ordering schemes + integer, parameter, public :: HALO_ORDER_GENERAL = 1, & + & HALO_ORDER_TRAILING_RECEIVES = 2 - !! Halo information type - type halo_type - !! Name of this halo - character(len = FIELD_NAME_LEN) :: name - !! Reference count for halo - type(refcount_type), pointer :: refcount => null() + !! Halo information type + type halo_type + !! Name of this halo + character(len = FIELD_NAME_LEN) :: name + !! Reference count for halo + type(refcount_type), pointer :: refcount => null() - !! Halo data type - integer :: data_type = 0 - !! Ordering scheme for halo - integer :: ordering_scheme = 0 + !! Halo data type + integer :: data_type = 0 + !! Ordering scheme for halo + integer :: ordering_scheme = 0 - !! The MPI communicator for this halo + !! The MPI communicator for this halo #ifdef HAVE_MPI - integer :: communicator + integer :: communicator #else - integer :: communicator = -1 + integer :: communicator = -1 #endif - !! The number of processes - integer :: nprocs = 0 - !! The sends - type(integer_vector), dimension(:), pointer :: sends => null() - !! The receives - type(integer_vector), dimension(:), pointer :: receives => null() - - !! The number of owned nodes - integer :: nowned_nodes = -1 - - !! Ownership cache - integer, dimension(:), pointer :: owners => null() - - ! Global to universal numbering mapping cache - !! Universal number of nodes - integer :: unn_count = -1 - !! Base for owned nodes universal node numbering of each process: - integer, dimension(:), pointer :: owned_nodes_unn_base => null() - !! Base for owned nodes universal node numbering for this process - !! should be the same as owned_nodes_unn_base(rank+1): - integer :: my_owned_nodes_unn_base = -1 - - !! Map from global to universal numbers for receives - integer, dimension(:), pointer :: receives_gnn_to_unn => null() - - !! Map from global to universal node numbers for all items. - !! This is required for halos which are not ordered by ownership. - integer, dimension(:), pointer :: gnn_to_unn => null() - end type halo_type - - type halo_pointer - !!< Dummy type to allow for arrays of pointers to halos - type(halo_type), pointer :: ptr => null() - end type halo_pointer + !! The number of processes + integer :: nprocs = 0 + !! The sends + type(integer_vector), dimension(:), pointer :: sends => null() + !! The receives + type(integer_vector), dimension(:), pointer :: receives => null() + + !! The number of owned nodes + integer :: nowned_nodes = -1 + + !! Ownership cache + integer, dimension(:), pointer :: owners => null() + + ! Global to universal numbering mapping cache + !! Universal number of nodes + integer :: unn_count = -1 + !! Base for owned nodes universal node numbering of each process: + integer, dimension(:), pointer :: owned_nodes_unn_base => null() + !! Base for owned nodes universal node numbering for this process + !! should be the same as owned_nodes_unn_base(rank+1): + integer :: my_owned_nodes_unn_base = -1 + + !! Map from global to universal numbers for receives + integer, dimension(:), pointer :: receives_gnn_to_unn => null() + + !! Map from global to universal node numbers for all items. + !! This is required for halos which are not ordered by ownership. + integer, dimension(:), pointer :: gnn_to_unn => null() + end type halo_type + + type halo_pointer + !!< Dummy type to allow for arrays of pointers to halos + type(halo_type), pointer :: ptr => null() + end type halo_pointer end module halo_data_types diff --git a/femtools/Halos.F90 b/femtools/Halos.F90 index c9ece2067f..10b54c610e 100644 --- a/femtools/Halos.F90 +++ b/femtools/Halos.F90 @@ -29,18 +29,18 @@ module halos - use halo_data_types - use halos_base - use halos_debug - use halos_allocates - use halos_communications - use halos_numbering - use halos_ownership - use halos_repair - use halos_diagnostics - use halos_derivation - use halos_registration + use halo_data_types + use halos_base + use halos_debug + use halos_allocates + use halos_communications + use halos_numbering + use halos_ownership + use halos_repair + use halos_diagnostics + use halos_derivation + use halos_registration - implicit none + implicit none end module halos diff --git a/femtools/Halos_Allocates.F90 b/femtools/Halos_Allocates.F90 index 2052a472db..83728e5b31 100644 --- a/femtools/Halos_Allocates.F90 +++ b/femtools/Halos_Allocates.F90 @@ -29,38 +29,38 @@ module halos_allocates - use fldebug - use global_parameters, only : empty_name - use mpi_interfaces - use reference_counting - use halo_data_types - use parallel_tools - use halos_base - use halos_debug + use fldebug + use global_parameters, only : empty_name + use mpi_interfaces + use reference_counting + use halo_data_types + use parallel_tools + use halos_base + use halos_debug - implicit none + implicit none - private + private - public :: allocate, reallocate, deallocate, incref, has_references, & - & deallocate_ownership_cache, deallocate_universal_numbering_cache, & - & nullify + public :: allocate, reallocate, deallocate, incref, has_references, & + & deallocate_ownership_cache, deallocate_universal_numbering_cache, & + & nullify - interface allocate - module procedure allocate_halo, allocate_halo_halo - end interface allocate + interface allocate + module procedure allocate_halo, allocate_halo_halo + end interface allocate - interface reallocate - module procedure reallocate_halo - end interface reallocate + interface reallocate + module procedure reallocate_halo + end interface reallocate - interface deallocate - module procedure deallocate_halo, deallocate_halo_vector - end interface deallocate + interface deallocate + module procedure deallocate_halo, deallocate_halo_vector + end interface deallocate - interface nullify - module procedure nullify_halo - end interface nullify + interface nullify + module procedure nullify_halo + end interface nullify #include "Reference_count_interface_halo_type.F90" @@ -68,115 +68,115 @@ module halos_allocates #include "Reference_count_halo_type.F90" - subroutine allocate_halo(halo, nsends, nreceives, name, communicator, nprocs, nowned_nodes, data_type, ordering_scheme) - !!< Allocate a halo + subroutine allocate_halo(halo, nsends, nreceives, name, communicator, nprocs, nowned_nodes, data_type, ordering_scheme) + !!< Allocate a halo - type(halo_type), intent(out) :: halo - ! size(nprocs / communicator size) - integer, dimension(:), intent(in) :: nsends - ! size(nprocs / communicator size) - integer, dimension(:), intent(in) :: nreceives - character(len = *), optional, intent(in) :: name - integer, optional, intent(in) :: communicator - integer, optional, intent(in) :: nprocs - integer, optional, intent(in) :: nowned_nodes - integer, optional, intent(in) :: data_type - integer, optional, intent(in) :: ordering_scheme + type(halo_type), intent(out) :: halo + ! size(nprocs / communicator size) + integer, dimension(:), intent(in) :: nsends + ! size(nprocs / communicator size) + integer, dimension(:), intent(in) :: nreceives + character(len = *), optional, intent(in) :: name + integer, optional, intent(in) :: communicator + integer, optional, intent(in) :: nprocs + integer, optional, intent(in) :: nowned_nodes + integer, optional, intent(in) :: data_type + integer, optional, intent(in) :: ordering_scheme - integer :: i, lnprocs + integer :: i, lnprocs #ifdef HAVE_MPI - halo%communicator = MPI_COMM_FEMTOOLS + halo%communicator = MPI_COMM_FEMTOOLS #else - halo%communicator = -1 + halo%communicator = -1 #endif - ! Set nprocs - if(present(communicator)) then + ! Set nprocs + if(present(communicator)) then #ifdef HAVE_MPI - lnprocs = getnprocs(communicator = communicator) - halo%nprocs = lnprocs - call set_halo_communicator(halo, communicator) - - if(present(nprocs)) then - if(nprocs /= lnprocs) then - FLAbort("Inconsistent communicator and nprocs supplied when allocating a halo") - end if - end if + lnprocs = getnprocs(communicator = communicator) + halo%nprocs = lnprocs + call set_halo_communicator(halo, communicator) + + if(present(nprocs)) then + if(nprocs /= lnprocs) then + FLAbort("Inconsistent communicator and nprocs supplied when allocating a halo") + end if + end if #else - FLAbort("Cannot assign a communicator to a halo without MPI support") + FLAbort("Cannot assign a communicator to a halo without MPI support") #endif - else if(present(nprocs)) then - halo%nprocs = nprocs - lnprocs = nprocs - else - FLAbort("Either a communicator or nprocs must be supplied when allocating a halo") - end if - - assert(lnprocs >= 0) - assert(size(nsends) == lnprocs) - assert(size(nreceives) == lnprocs) - - ! Allocate the sends - allocate(halo%sends(lnprocs)) - do i = 1, lnprocs - assert(nsends(i) >= 0) - allocate(halo%sends(i)%ptr(nsends(i))) - end do - - ! Allocate the receives - allocate(halo%receives(lnprocs)) - do i = 1, lnprocs - assert(nreceives(i) >= 0) - allocate(halo%receives(i)%ptr(nreceives(i))) - end do - - if(present(name)) then - ! Set the name - call set_halo_name(halo, name) - else - call set_halo_name(halo, empty_name) - end if - - if(present(data_type)) then - ! Set the data type - call set_halo_data_type(halo, data_type) - else - call set_halo_data_type(halo, HALO_TYPE_CG_NODE) - end if - - if(present(ordering_scheme)) then - ! Set the ordering scheme - call set_halo_ordering_scheme(halo, ordering_scheme) - else - call set_halo_ordering_scheme(halo, HALO_ORDER_TRAILING_RECEIVES) - end if - - if(present(nowned_nodes)) then - ! Set the number of owned nodes - call set_halo_nowned_nodes(halo, nowned_nodes) - end if - - call addref(halo) - - end subroutine allocate_halo - - subroutine allocate_halo_halo(output_halo, base_halo) - !!< Allocate a halo based upon an existing halo - - type(halo_type), intent(out) :: output_halo - type(halo_type), intent(in) :: base_halo - - integer :: nprocs - integer, dimension(:), allocatable :: nreceives, nsends - - nprocs = halo_proc_count(base_halo) - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - call halo_send_counts(base_halo, nsends) - call halo_receive_counts(base_halo, nreceives) - - call allocate(output_halo, & + else if(present(nprocs)) then + halo%nprocs = nprocs + lnprocs = nprocs + else + FLAbort("Either a communicator or nprocs must be supplied when allocating a halo") + end if + + assert(lnprocs >= 0) + assert(size(nsends) == lnprocs) + assert(size(nreceives) == lnprocs) + + ! Allocate the sends + allocate(halo%sends(lnprocs)) + do i = 1, lnprocs + assert(nsends(i) >= 0) + allocate(halo%sends(i)%ptr(nsends(i))) + end do + + ! Allocate the receives + allocate(halo%receives(lnprocs)) + do i = 1, lnprocs + assert(nreceives(i) >= 0) + allocate(halo%receives(i)%ptr(nreceives(i))) + end do + + if(present(name)) then + ! Set the name + call set_halo_name(halo, name) + else + call set_halo_name(halo, empty_name) + end if + + if(present(data_type)) then + ! Set the data type + call set_halo_data_type(halo, data_type) + else + call set_halo_data_type(halo, HALO_TYPE_CG_NODE) + end if + + if(present(ordering_scheme)) then + ! Set the ordering scheme + call set_halo_ordering_scheme(halo, ordering_scheme) + else + call set_halo_ordering_scheme(halo, HALO_ORDER_TRAILING_RECEIVES) + end if + + if(present(nowned_nodes)) then + ! Set the number of owned nodes + call set_halo_nowned_nodes(halo, nowned_nodes) + end if + + call addref(halo) + + end subroutine allocate_halo + + subroutine allocate_halo_halo(output_halo, base_halo) + !!< Allocate a halo based upon an existing halo + + type(halo_type), intent(out) :: output_halo + type(halo_type), intent(in) :: base_halo + + integer :: nprocs + integer, dimension(:), allocatable :: nreceives, nsends + + nprocs = halo_proc_count(base_halo) + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + call halo_send_counts(base_halo, nsends) + call halo_receive_counts(base_halo, nreceives) + + call allocate(output_halo, & & nsends = nsends, & & nreceives = nreceives, & & name = halo_name(base_halo), & @@ -185,137 +185,137 @@ subroutine allocate_halo_halo(output_halo, base_halo) & data_type = halo_data_type(base_halo), & & ordering_scheme = halo_ordering_scheme(base_halo)) - deallocate(nsends) - deallocate(nreceives) + deallocate(nsends) + deallocate(nreceives) - end subroutine allocate_halo_halo + end subroutine allocate_halo_halo - subroutine reallocate_halo(halo, nsends, nreceives) - !!< Re-allocate a halo. This is useful if the send or receive allocation is - !!< deferred. + subroutine reallocate_halo(halo, nsends, nreceives) + !!< Re-allocate a halo. This is useful if the send or receive allocation is + !!< deferred. - type(halo_type), intent(inout) :: halo - integer, dimension(halo_proc_count(halo)), optional, intent(in) :: nsends - integer, dimension(halo_proc_count(halo)), optional, intent(in) :: nreceives + type(halo_type), intent(inout) :: halo + integer, dimension(halo_proc_count(halo)), optional, intent(in) :: nsends + integer, dimension(halo_proc_count(halo)), optional, intent(in) :: nreceives - integer :: i, nprocs + integer :: i, nprocs - nprocs = halo_proc_count(halo) + nprocs = halo_proc_count(halo) - if(present(nsends)) then - assert(associated(halo%sends)) - do i = 1, nprocs - assert(associated(halo%sends(i)%ptr)) - deallocate(halo%sends(i)%ptr) - allocate(halo%sends(i)%ptr(nsends(i))) - end do - end if - if(present(nreceives)) then - assert(associated(halo%receives)) - do i = 1, nprocs - assert(associated(halo%receives(i)%ptr)) - deallocate(halo%receives(i)%ptr) - allocate(halo%receives(i)%ptr(nreceives(i))) - end do - end if + if(present(nsends)) then + assert(associated(halo%sends)) + do i = 1, nprocs + assert(associated(halo%sends(i)%ptr)) + deallocate(halo%sends(i)%ptr) + allocate(halo%sends(i)%ptr(nsends(i))) + end do + end if + if(present(nreceives)) then + assert(associated(halo%receives)) + do i = 1, nprocs + assert(associated(halo%receives(i)%ptr)) + deallocate(halo%receives(i)%ptr) + allocate(halo%receives(i)%ptr(nreceives(i))) + end do + end if - end subroutine reallocate_halo + end subroutine reallocate_halo - subroutine deallocate_halo(halo) - !!< Deallocate a halo type + subroutine deallocate_halo(halo) + !!< Deallocate a halo type - type(halo_type), intent(inout) :: halo + type(halo_type), intent(inout) :: halo - integer :: i + integer :: i - call decref(halo) - if(has_references(halo)) return + call decref(halo) + if(has_references(halo)) return - ! Deallocate the sends - if(associated(halo%sends)) then - do i = 1, size(halo%sends) - deallocate(halo%sends(i)%ptr) - end do - deallocate(halo%sends) - nullify(halo%sends) - end if - - ! Deallocate the receives - if(associated(halo%receives)) then - do i = 1, size(halo%receives) - deallocate(halo%receives(i)%ptr) - end do - deallocate(halo%receives) - nullify(halo%receives) - end if + ! Deallocate the sends + if(associated(halo%sends)) then + do i = 1, size(halo%sends) + deallocate(halo%sends(i)%ptr) + end do + deallocate(halo%sends) + nullify(halo%sends) + end if - ! Deallocate caches - call deallocate_ownership_cache(halo) - call deallocate_universal_numbering_cache(halo) + ! Deallocate the receives + if(associated(halo%receives)) then + do i = 1, size(halo%receives) + deallocate(halo%receives(i)%ptr) + end do + deallocate(halo%receives) + nullify(halo%receives) + end if - ! Reset variables - call nullify(halo) + ! Deallocate caches + call deallocate_ownership_cache(halo) + call deallocate_universal_numbering_cache(halo) - end subroutine deallocate_halo + ! Reset variables + call nullify(halo) - subroutine deallocate_halo_vector(halos) - !!< Deallocate each of a vector of halos. - type(halo_type), dimension(:), intent(inout) :: halos + end subroutine deallocate_halo - integer :: i + subroutine deallocate_halo_vector(halos) + !!< Deallocate each of a vector of halos. + type(halo_type), dimension(:), intent(inout) :: halos - do i=1, size(halos) - call deallocate(halos(i)) - end do + integer :: i - end subroutine deallocate_halo_vector + do i=1, size(halos) + call deallocate(halos(i)) + end do - subroutine deallocate_ownership_cache(halo) - !!< Deallocate the node ownership cache data + end subroutine deallocate_halo_vector - type(halo_type), intent(inout) :: halo + subroutine deallocate_ownership_cache(halo) + !!< Deallocate the node ownership cache data - if(associated(halo%owners)) then - deallocate(halo%owners) - nullify(halo%owners) - end if + type(halo_type), intent(inout) :: halo - end subroutine deallocate_ownership_cache + if(associated(halo%owners)) then + deallocate(halo%owners) + nullify(halo%owners) + end if - subroutine deallocate_universal_numbering_cache(halo) - !!< Deallocate halo universal node numbering cache data + end subroutine deallocate_ownership_cache - type(halo_type), intent(inout) :: halo + subroutine deallocate_universal_numbering_cache(halo) + !!< Deallocate halo universal node numbering cache data - halo%unn_count = -1 - if (associated(halo%owned_nodes_unn_base)) then - deallocate(halo%owned_nodes_unn_base) - end if - halo%my_owned_nodes_unn_base = -1 + type(halo_type), intent(inout) :: halo - if(associated(halo%receives_gnn_to_unn)) then - deallocate(halo%receives_gnn_to_unn) - nullify(halo%receives_gnn_to_unn) - end if + halo%unn_count = -1 + if (associated(halo%owned_nodes_unn_base)) then + deallocate(halo%owned_nodes_unn_base) + end if + halo%my_owned_nodes_unn_base = -1 + + if(associated(halo%receives_gnn_to_unn)) then + deallocate(halo%receives_gnn_to_unn) + nullify(halo%receives_gnn_to_unn) + end if - if(associated(halo%gnn_to_unn)) then - deallocate(halo%gnn_to_unn) - nullify(halo%gnn_to_unn) - end if + if(associated(halo%gnn_to_unn)) then + deallocate(halo%gnn_to_unn) + nullify(halo%gnn_to_unn) + end if - end subroutine deallocate_universal_numbering_cache + end subroutine deallocate_universal_numbering_cache - subroutine nullify_halo(halo) - !!< Return a halo type to its uninitialised state + subroutine nullify_halo(halo) + !!< Return a halo type to its uninitialised state - type(halo_type), intent(inout) :: halo + type(halo_type), intent(inout) :: halo - type(halo_type) :: null_halo + type(halo_type) :: null_halo - ! Initialise the null_halo name to prevent uninitialised variable access - call set_halo_name(null_halo, empty_name) - halo = null_halo + ! Initialise the null_halo name to prevent uninitialised variable access + call set_halo_name(null_halo, empty_name) + halo = null_halo - end subroutine nullify_halo + end subroutine nullify_halo end module halos_allocates diff --git a/femtools/Halos_Base.F90 b/femtools/Halos_Base.F90 index bd0d36573d..209ada1a16 100644 --- a/femtools/Halos_Base.F90 +++ b/femtools/Halos_Base.F90 @@ -29,731 +29,731 @@ module halos_base - use fldebug - use mpi_interfaces - use halo_data_types - use quicksort - use parallel_tools - - implicit none - - private - - public :: zero, halo_name, set_halo_name, halo_data_type, & - & set_halo_data_type, halo_ordering_scheme, set_halo_ordering_scheme, & - & has_nowned_nodes, halo_nowned_nodes, set_halo_nowned_nodes, halo_communicator, & - & set_halo_communicator, halo_proc_count, halo_send_count, & - & halo_receive_count, halo_unique_receive_count, halo_send, halo_receive, & - & set_halo_send, set_halo_receive, halo_send_counts, halo_receive_counts, & - & halo_sends, halo_receives, set_halo_sends, set_halo_receives, & - & halo_all_sends_count, halo_all_receives_count, & - & halo_all_unique_receives_count, extract_all_halo_sends, & - & extract_all_halo_receives, set_all_halo_sends, set_all_halo_receives, & - & min_halo_send_node, min_halo_receive_node, min_halo_node, & - & max_halo_send_node, max_halo_receive_node, max_halo_node,& - & node_count, serial_storage_halo - - interface zero - module procedure zero_halo - end interface zero - - interface halo_communicator - module procedure halo_communicator_halo - end interface halo_communicator - - interface node_count - module procedure node_count_halo - end interface node_count - - interface serial_storage_halo - module procedure serial_storage_halo_single, serial_storage_halo_multiple - end interface serial_storage_halo + use fldebug + use mpi_interfaces + use halo_data_types + use quicksort + use parallel_tools + + implicit none + + private + + public :: zero, halo_name, set_halo_name, halo_data_type, & + & set_halo_data_type, halo_ordering_scheme, set_halo_ordering_scheme, & + & has_nowned_nodes, halo_nowned_nodes, set_halo_nowned_nodes, halo_communicator, & + & set_halo_communicator, halo_proc_count, halo_send_count, & + & halo_receive_count, halo_unique_receive_count, halo_send, halo_receive, & + & set_halo_send, set_halo_receive, halo_send_counts, halo_receive_counts, & + & halo_sends, halo_receives, set_halo_sends, set_halo_receives, & + & halo_all_sends_count, halo_all_receives_count, & + & halo_all_unique_receives_count, extract_all_halo_sends, & + & extract_all_halo_receives, set_all_halo_sends, set_all_halo_receives, & + & min_halo_send_node, min_halo_receive_node, min_halo_node, & + & max_halo_send_node, max_halo_receive_node, max_halo_node,& + & node_count, serial_storage_halo + + interface zero + module procedure zero_halo + end interface zero + + interface halo_communicator + module procedure halo_communicator_halo + end interface halo_communicator + + interface node_count + module procedure node_count_halo + end interface node_count + + interface serial_storage_halo + module procedure serial_storage_halo_single, serial_storage_halo_multiple + end interface serial_storage_halo contains - subroutine zero_halo(halo) - !!< Zero the sends and receives information for the supplied halo + subroutine zero_halo(halo) + !!< Zero the sends and receives information for the supplied halo - type(halo_type), intent(inout) :: halo + type(halo_type), intent(inout) :: halo - integer :: i + integer :: i - assert(associated(halo%sends)) - assert(associated(halo%receives)) - do i = 1, halo_proc_count(halo) - assert(associated(halo%sends(i)%ptr)) - assert(associated(halo%receives(i)%ptr)) - halo%sends(i)%ptr = 0 - halo%receives(i)%ptr = 0 - end do + assert(associated(halo%sends)) + assert(associated(halo%receives)) + do i = 1, halo_proc_count(halo) + assert(associated(halo%sends(i)%ptr)) + assert(associated(halo%receives(i)%ptr)) + halo%sends(i)%ptr = 0 + halo%receives(i)%ptr = 0 + end do - end subroutine zero_halo + end subroutine zero_halo - pure function halo_name(halo) - !!< Retrieve the name of the supplied halo + pure function halo_name(halo) + !!< Retrieve the name of the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - character(len = len_trim(halo%name)) :: halo_name + character(len = len_trim(halo%name)) :: halo_name - halo_name = halo%name + halo_name = halo%name - end function halo_name + end function halo_name - subroutine set_halo_name(halo, name) - !!< Set the name of the supplied halo + subroutine set_halo_name(halo, name) + !!< Set the name of the supplied halo - type(halo_type), intent(inout) :: halo - character(len = *), intent(in) :: name + type(halo_type), intent(inout) :: halo + character(len = *), intent(in) :: name - halo%name = trim(name) + halo%name = trim(name) - end subroutine set_halo_name + end subroutine set_halo_name - pure function halo_data_type(halo) - !!< Return the data type of the supplied halo + pure function halo_data_type(halo) + !!< Return the data type of the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_data_type + integer :: halo_data_type - halo_data_type = halo%data_type + halo_data_type = halo%data_type - end function halo_data_type + end function halo_data_type - subroutine set_halo_data_type(halo, data_type) - !!< Set the data type of the supplied halo + subroutine set_halo_data_type(halo, data_type) + !!< Set the data type of the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: data_type + type(halo_type), intent(inout) :: halo + integer, intent(in) :: data_type #ifdef DDEBUG - logical:: data_type_valid + logical:: data_type_valid - data_type_valid=any(data_type == (/HALO_TYPE_CG_NODE, & + data_type_valid=any(data_type == (/HALO_TYPE_CG_NODE, & HALO_TYPE_DG_NODE, & HALO_TYPE_ELEMENT/)) - assert(data_type_valid) + assert(data_type_valid) #endif - halo%data_type = data_type + halo%data_type = data_type - end subroutine set_halo_data_type + end subroutine set_halo_data_type - pure function halo_ordering_scheme(halo) - !!< Return the ordering scheme of the supplied halo + pure function halo_ordering_scheme(halo) + !!< Return the ordering scheme of the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_ordering_scheme + integer :: halo_ordering_scheme - halo_ordering_scheme = halo%ordering_scheme + halo_ordering_scheme = halo%ordering_scheme - end function halo_ordering_scheme + end function halo_ordering_scheme - subroutine set_halo_ordering_scheme(halo, ordering_scheme) - !!< Set the ordering scheme of the supplied halo + subroutine set_halo_ordering_scheme(halo, ordering_scheme) + !!< Set the ordering scheme of the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: ordering_scheme + type(halo_type), intent(inout) :: halo + integer, intent(in) :: ordering_scheme - assert(any(ordering_scheme == (/HALO_ORDER_GENERAL, HALO_ORDER_TRAILING_RECEIVES/))) - halo%ordering_scheme = ordering_scheme + assert(any(ordering_scheme == (/HALO_ORDER_GENERAL, HALO_ORDER_TRAILING_RECEIVES/))) + halo%ordering_scheme = ordering_scheme - end subroutine set_halo_ordering_scheme + end subroutine set_halo_ordering_scheme - pure function has_nowned_nodes(halo) - !!< Return whether the supplied halo has a number of owned nodes set + pure function has_nowned_nodes(halo) + !!< Return whether the supplied halo has a number of owned nodes set - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: has_nowned_nodes + logical :: has_nowned_nodes - has_nowned_nodes = halo%nowned_nodes >= 0 + has_nowned_nodes = halo%nowned_nodes >= 0 - end function has_nowned_nodes + end function has_nowned_nodes - pure function halo_nowned_nodes(halo) - !!< Retrieve the number of owned nodes for the supplied halo + pure function halo_nowned_nodes(halo) + !!< Retrieve the number of owned nodes for the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_nowned_nodes + integer :: halo_nowned_nodes - halo_nowned_nodes = halo%nowned_nodes + halo_nowned_nodes = halo%nowned_nodes - end function halo_nowned_nodes + end function halo_nowned_nodes - subroutine set_halo_nowned_nodes(halo, nowned_nodes) - !!< Set the number of owned nodes for the supplied halo + subroutine set_halo_nowned_nodes(halo, nowned_nodes) + !!< Set the number of owned nodes for the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: nowned_nodes + type(halo_type), intent(inout) :: halo + integer, intent(in) :: nowned_nodes - assert(nowned_nodes >= 0) + assert(nowned_nodes >= 0) - halo%nowned_nodes = nowned_nodes + halo%nowned_nodes = nowned_nodes - end subroutine set_halo_nowned_nodes + end subroutine set_halo_nowned_nodes - pure function node_count_halo(halo) result(node_count) - !!< Retrieve the total number of nodes in the supplied halo. + pure function node_count_halo(halo) result(node_count) + !!< Retrieve the total number of nodes in the supplied halo. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: node_count + integer :: node_count - node_count = halo_nowned_nodes(halo) & + node_count = halo_nowned_nodes(halo) & + halo_all_receives_count(halo) - end function node_count_halo + end function node_count_halo - pure function halo_communicator_halo(halo) result(communicator) - !!< Extract the halo MPI communicator + pure function halo_communicator_halo(halo) result(communicator) + !!< Extract the halo MPI communicator - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: communicator + integer :: communicator - communicator = halo%communicator + communicator = halo%communicator - end function halo_communicator_halo + end function halo_communicator_halo - subroutine set_halo_communicator(halo, communicator) - !!< Set the halo MPI communicator + subroutine set_halo_communicator(halo, communicator) + !!< Set the halo MPI communicator - type(halo_type), intent(inout) :: halo - integer, intent(in) :: communicator + type(halo_type), intent(inout) :: halo + integer, intent(in) :: communicator - assert(valid_communicator(communicator)) - assert(getnprocs(communicator = communicator) == halo_proc_count(halo)) - halo%communicator = communicator + assert(valid_communicator(communicator)) + assert(getnprocs(communicator = communicator) == halo_proc_count(halo)) + halo%communicator = communicator - end subroutine set_halo_communicator + end subroutine set_halo_communicator - pure function halo_proc_count(halo) - !!< Retrieve the number of processes in the supplied halo + pure function halo_proc_count(halo) + !!< Retrieve the number of processes in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_proc_count + integer :: halo_proc_count - halo_proc_count = halo%nprocs + halo_proc_count = halo%nprocs - end function halo_proc_count + end function halo_proc_count - pure function halo_send_count(halo, process) - !!< Retrieve the number of send nodes in the supplied halo for the supplied - !!< process + pure function halo_send_count(halo, process) + !!< Retrieve the number of send nodes in the supplied halo for the supplied + !!< process - type(halo_type), intent(in) :: halo - integer, intent(in) :: process + type(halo_type), intent(in) :: halo + integer, intent(in) :: process - integer :: halo_send_count + integer :: halo_send_count - !assert(process > 0) - !assert(process <= halo_proc_count(halo)) + !assert(process > 0) + !assert(process <= halo_proc_count(halo)) - !assert(associated(halo%sends)) - !assert(associated(halo%sends(process)%ptr)) + !assert(associated(halo%sends)) + !assert(associated(halo%sends(process)%ptr)) - halo_send_count = size(halo%sends(process)%ptr) + halo_send_count = size(halo%sends(process)%ptr) - end function halo_send_count + end function halo_send_count - pure function halo_receive_count(halo, process) - !!< Retrieve the number of receive nodes in the supplied halo for the - !!< supplied process + pure function halo_receive_count(halo, process) + !!< Retrieve the number of receive nodes in the supplied halo for the + !!< supplied process - type(halo_type), intent(in) :: halo - integer, intent(in) :: process + type(halo_type), intent(in) :: halo + integer, intent(in) :: process - integer :: halo_receive_count + integer :: halo_receive_count - !assert(process > 0) - !assert(process <= halo_proc_count(halo)) + !assert(process > 0) + !assert(process <= halo_proc_count(halo)) - !assert(associated(halo%receives)) - !assert(associated(halo%receives(process)%ptr)) + !assert(associated(halo%receives)) + !assert(associated(halo%receives(process)%ptr)) - halo_receive_count = size(halo%receives(process)%ptr) + halo_receive_count = size(halo%receives(process)%ptr) - end function halo_receive_count + end function halo_receive_count - function halo_unique_receive_count(halo, process) - !!< Retrieve the number of unique receives nodes in the supplied halo for - !!< the supplied process + function halo_unique_receive_count(halo, process) + !!< Retrieve the number of unique receives nodes in the supplied halo for + !!< the supplied process - type(halo_type), intent(in) :: halo - integer, intent(in) :: process + type(halo_type), intent(in) :: halo + integer, intent(in) :: process - integer :: halo_unique_receive_count + integer :: halo_unique_receive_count - halo_unique_receive_count = count_unique(halo_receives(halo, process)) + halo_unique_receive_count = count_unique(halo_receives(halo, process)) - end function halo_unique_receive_count + end function halo_unique_receive_count - function halo_send(halo, process, index) - !!< Retrieve a send node from the supplied halo + function halo_send(halo, process, index) + !!< Retrieve a send node from the supplied halo - type(halo_type), intent(in) :: halo - integer, intent(in) :: process - integer, intent(in) :: index + type(halo_type), intent(in) :: halo + integer, intent(in) :: process + integer, intent(in) :: index - integer :: halo_send + integer :: halo_send - assert(process > 0) - assert(process <= halo_proc_count(halo)) - assert(index > 0) - assert(index <= halo_send_count(halo, process)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) + assert(index > 0) + assert(index <= halo_send_count(halo, process)) - assert(associated(halo%sends)) - assert(associated(halo%sends(process)%ptr)) + assert(associated(halo%sends)) + assert(associated(halo%sends(process)%ptr)) - halo_send = halo%sends(process)%ptr(index) + halo_send = halo%sends(process)%ptr(index) - end function halo_send + end function halo_send - function halo_receive(halo, process, index) - !!< Retrieve a receive node from the supplied halo + function halo_receive(halo, process, index) + !!< Retrieve a receive node from the supplied halo - type(halo_type), intent(in) :: halo - integer, intent(in) :: process - integer, intent(in) :: index + type(halo_type), intent(in) :: halo + integer, intent(in) :: process + integer, intent(in) :: index - integer :: halo_receive + integer :: halo_receive - assert(process > 0) - assert(process <= halo_proc_count(halo)) - assert(index > 0) - assert(index <= halo_receive_count(halo, process)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) + assert(index > 0) + assert(index <= halo_receive_count(halo, process)) - assert(associated(halo%receives)) - assert(associated(halo%receives(process)%ptr)) + assert(associated(halo%receives)) + assert(associated(halo%receives(process)%ptr)) - halo_receive = halo%receives(process)%ptr(index) + halo_receive = halo%receives(process)%ptr(index) - end function halo_receive + end function halo_receive - subroutine set_halo_send(halo, process, index, node) - !!< Set a send node for the supplied halo + subroutine set_halo_send(halo, process, index, node) + !!< Set a send node for the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: process - integer, intent(in) :: index - integer, intent(in) :: node + type(halo_type), intent(inout) :: halo + integer, intent(in) :: process + integer, intent(in) :: index + integer, intent(in) :: node - assert(process > 0) - assert(process <= halo_proc_count(halo)) - assert(index > 0) - assert(index <= halo_send_count(halo, process)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) + assert(index > 0) + assert(index <= halo_send_count(halo, process)) - assert(associated(halo%sends)) - assert(associated(halo%sends(process)%ptr)) + assert(associated(halo%sends)) + assert(associated(halo%sends(process)%ptr)) - halo%sends(process)%ptr(index) = node + halo%sends(process)%ptr(index) = node - end subroutine set_halo_send + end subroutine set_halo_send - subroutine set_halo_receive(halo, process, index, node) - !!< Set a receive node for the supplied halo + subroutine set_halo_receive(halo, process, index, node) + !!< Set a receive node for the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: process - integer, intent(in) :: index - integer, intent(in) :: node + type(halo_type), intent(inout) :: halo + integer, intent(in) :: process + integer, intent(in) :: index + integer, intent(in) :: node - assert(process > 0) - assert(process <= halo_proc_count(halo)) - assert(index > 0) - assert(index <= halo_receive_count(halo, process)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) + assert(index > 0) + assert(index <= halo_receive_count(halo, process)) - assert(associated(halo%receives)) - assert(associated(halo%receives(process)%ptr)) + assert(associated(halo%receives)) + assert(associated(halo%receives(process)%ptr)) - halo%receives(process)%ptr(index) = node + halo%receives(process)%ptr(index) = node - end subroutine set_halo_receive + end subroutine set_halo_receive - subroutine halo_send_counts(halo, nsends) - !!< Retrieve the number of sends nodes for all process + subroutine halo_send_counts(halo, nsends) + !!< Retrieve the number of sends nodes for all process - type(halo_type), intent(in) :: halo - integer, dimension(halo_proc_count(halo)), intent(out) :: nsends + type(halo_type), intent(in) :: halo + integer, dimension(halo_proc_count(halo)), intent(out) :: nsends - integer :: i + integer :: i - do i = 1, halo_proc_count(halo) - nsends(i) = halo_send_count(halo, i) - end do + do i = 1, halo_proc_count(halo) + nsends(i) = halo_send_count(halo, i) + end do - end subroutine halo_send_counts + end subroutine halo_send_counts - subroutine halo_receive_counts(halo, nreceives) - !!< Retrieve the number of receives nodes for all process + subroutine halo_receive_counts(halo, nreceives) + !!< Retrieve the number of receives nodes for all process - type(halo_type), intent(in) :: halo - integer, dimension(halo_proc_count(halo)), intent(out) :: nreceives + type(halo_type), intent(in) :: halo + integer, dimension(halo_proc_count(halo)), intent(out) :: nreceives - integer :: i + integer :: i - do i = 1, halo_proc_count(halo) - nreceives(i) = halo_receive_count(halo, i) - end do + do i = 1, halo_proc_count(halo) + nreceives(i) = halo_receive_count(halo, i) + end do - end subroutine halo_receive_counts + end subroutine halo_receive_counts - function halo_sends(halo, process) - !!< Retrieve all send nodes for the supplied process from the supplied halo + function halo_sends(halo, process) + !!< Retrieve all send nodes for the supplied process from the supplied halo - type(halo_type), intent(in) :: halo - integer, intent(in) :: process + type(halo_type), intent(in) :: halo + integer, intent(in) :: process - integer, dimension(:), pointer :: halo_sends + integer, dimension(:), pointer :: halo_sends - assert(process > 0) - assert(process <= halo_proc_count(halo)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) - assert(associated(halo%sends)) - assert(associated(halo%sends(process)%ptr)) + assert(associated(halo%sends)) + assert(associated(halo%sends(process)%ptr)) - halo_sends => halo%sends(process)%ptr + halo_sends => halo%sends(process)%ptr - end function halo_sends + end function halo_sends - function halo_receives(halo, process) - !!< Retrieve all receive nodes for the supplied process from the supplied - !!< halo + function halo_receives(halo, process) + !!< Retrieve all receive nodes for the supplied process from the supplied + !!< halo - type(halo_type), intent(in) :: halo - integer, intent(in) :: process + type(halo_type), intent(in) :: halo + integer, intent(in) :: process - integer, dimension(:), pointer :: halo_receives + integer, dimension(:), pointer :: halo_receives - assert(process > 0) - assert(process <= halo_proc_count(halo)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) - assert(associated(halo%receives)) - assert(associated(halo%receives(process)%ptr)) + assert(associated(halo%receives)) + assert(associated(halo%receives(process)%ptr)) - halo_receives => halo%receives(process)%ptr + halo_receives => halo%receives(process)%ptr - end function halo_receives + end function halo_receives - subroutine set_halo_sends(halo, process, sends) - !!< Set all send nodes for the supplied process for the supplied halo + subroutine set_halo_sends(halo, process, sends) + !!< Set all send nodes for the supplied process for the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: process - integer, dimension(halo_send_count(halo, process)), intent(in) :: sends + type(halo_type), intent(inout) :: halo + integer, intent(in) :: process + integer, dimension(halo_send_count(halo, process)), intent(in) :: sends - assert(process > 0) - assert(process <= halo_proc_count(halo)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) - assert(associated(halo%sends)) - assert(associated(halo%sends(process)%ptr)) + assert(associated(halo%sends)) + assert(associated(halo%sends(process)%ptr)) - halo%sends(process)%ptr = sends + halo%sends(process)%ptr = sends - end subroutine set_halo_sends + end subroutine set_halo_sends - subroutine set_halo_receives(halo, process, receives) - !!< Set all receive nodes for the supplied process for the supplied halo + subroutine set_halo_receives(halo, process, receives) + !!< Set all receive nodes for the supplied process for the supplied halo - type(halo_type), intent(inout) :: halo - integer, intent(in) :: process - integer, dimension(halo_receive_count(halo, process)), intent(in) :: receives + type(halo_type), intent(inout) :: halo + integer, intent(in) :: process + integer, dimension(halo_receive_count(halo, process)), intent(in) :: receives - assert(process > 0) - assert(process <= halo_proc_count(halo)) + assert(process > 0) + assert(process <= halo_proc_count(halo)) - assert(associated(halo%receives)) - assert(associated(halo%receives(process)%ptr)) + assert(associated(halo%receives)) + assert(associated(halo%receives(process)%ptr)) - halo%receives(process)%ptr = receives + halo%receives(process)%ptr = receives - end subroutine set_halo_receives + end subroutine set_halo_receives - pure function halo_all_sends_count(halo) - !!< Count the total number of sends in the supplied halo. + pure function halo_all_sends_count(halo) + !!< Count the total number of sends in the supplied halo. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_all_sends_count + integer :: halo_all_sends_count - integer :: i + integer :: i - !assert(associated(halo%receives)) + !assert(associated(halo%receives)) - halo_all_sends_count = 0 - do i = 1, halo_proc_count(halo) - !assert(associated(halo%sends(i)%ptr)) - halo_all_sends_count = halo_all_sends_count + size(halo%sends(i)%ptr) - end do + halo_all_sends_count = 0 + do i = 1, halo_proc_count(halo) + !assert(associated(halo%sends(i)%ptr)) + halo_all_sends_count = halo_all_sends_count + size(halo%sends(i)%ptr) + end do - end function halo_all_sends_count + end function halo_all_sends_count - pure function halo_all_receives_count(halo) - !!< Count the total number of receives in the supplied halo. + pure function halo_all_receives_count(halo) + !!< Count the total number of receives in the supplied halo. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_all_receives_count + integer :: halo_all_receives_count - integer :: i + integer :: i - !assert(associated(halo%receives)) + !assert(associated(halo%receives)) - halo_all_receives_count = 0 - do i = 1, halo_proc_count(halo) - !assert(associated(halo%receives(i)%ptr)) - halo_all_receives_count = halo_all_receives_count + size(halo%receives(i)%ptr) - end do + halo_all_receives_count = 0 + do i = 1, halo_proc_count(halo) + !assert(associated(halo%receives(i)%ptr)) + halo_all_receives_count = halo_all_receives_count + size(halo%receives(i)%ptr) + end do - end function halo_all_receives_count + end function halo_all_receives_count - function halo_all_unique_receives_count(halo) - !!< Count the total number of unique receives in the supplied halo. + function halo_all_unique_receives_count(halo) + !!< Count the total number of unique receives in the supplied halo. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: halo_all_unique_receives_count + integer :: halo_all_unique_receives_count - integer, dimension(:), allocatable :: receives + integer, dimension(:), allocatable :: receives - allocate(receives(halo_all_receives_count(halo))) + allocate(receives(halo_all_receives_count(halo))) - call extract_all_halo_receives(halo, receives) - halo_all_unique_receives_count = count_unique(receives) + call extract_all_halo_receives(halo, receives) + halo_all_unique_receives_count = count_unique(receives) - deallocate(receives) + deallocate(receives) - end function halo_all_unique_receives_count + end function halo_all_unique_receives_count - subroutine extract_all_halo_sends(halo, sends, nsends, start_indices) - !!< Extract all sends from the supplied halo and assemble them onto a - !!< single vector. + subroutine extract_all_halo_sends(halo, sends, nsends, start_indices) + !!< Extract all sends from the supplied halo and assemble them onto a + !!< single vector. - type(halo_type), intent(in) :: halo - integer, dimension(halo_all_sends_count(halo)), intent(out) :: sends - integer, dimension(halo_proc_count(halo)), optional, intent(out) :: nsends - integer, dimension(halo_proc_count(halo)), optional, intent(out) :: start_indices + type(halo_type), intent(in) :: halo + integer, dimension(halo_all_sends_count(halo)), intent(out) :: sends + integer, dimension(halo_proc_count(halo)), optional, intent(out) :: nsends + integer, dimension(halo_proc_count(halo)), optional, intent(out) :: start_indices - integer :: i, index, nprocs + integer :: i, index, nprocs - nprocs = halo_proc_count(halo) + nprocs = halo_proc_count(halo) - assert(associated(halo%sends)) + assert(associated(halo%sends)) - index = 1 - do i = 1, nprocs - assert(associated(halo%sends(i)%ptr)) + index = 1 + do i = 1, nprocs + assert(associated(halo%sends(i)%ptr)) - sends(index:index + size(halo%sends(i)%ptr) - 1) = halo%sends(i)%ptr + sends(index:index + size(halo%sends(i)%ptr) - 1) = halo%sends(i)%ptr - if(present(nsends)) nsends(i) = size(halo%sends(i)%ptr) - if(present(start_indices)) start_indices(i) = index + if(present(nsends)) nsends(i) = size(halo%sends(i)%ptr) + if(present(start_indices)) start_indices(i) = index - index = index + size(halo%sends(i)%ptr) - end do - assert(index == size(sends) + 1) + index = index + size(halo%sends(i)%ptr) + end do + assert(index == size(sends) + 1) - end subroutine extract_all_halo_sends + end subroutine extract_all_halo_sends - subroutine extract_all_halo_receives(halo, receives, nreceives, start_indices) - !!< Extract all receives from the supplied halo and assemble them onto a - !!< single vector. + subroutine extract_all_halo_receives(halo, receives, nreceives, start_indices) + !!< Extract all receives from the supplied halo and assemble them onto a + !!< single vector. - type(halo_type), intent(in) :: halo - integer, dimension(halo_all_receives_count(halo)), intent(out) :: receives - integer, dimension(halo_proc_count(halo)), optional, intent(out) :: nreceives - integer, dimension(halo_proc_count(halo)), optional, intent(out) :: start_indices + type(halo_type), intent(in) :: halo + integer, dimension(halo_all_receives_count(halo)), intent(out) :: receives + integer, dimension(halo_proc_count(halo)), optional, intent(out) :: nreceives + integer, dimension(halo_proc_count(halo)), optional, intent(out) :: start_indices - integer :: i, index, nprocs + integer :: i, index, nprocs - nprocs = halo_proc_count(halo) + nprocs = halo_proc_count(halo) - assert(associated(halo%receives)) + assert(associated(halo%receives)) - index = 1 - do i = 1, nprocs - assert(associated(halo%receives(i)%ptr)) + index = 1 + do i = 1, nprocs + assert(associated(halo%receives(i)%ptr)) - receives(index:index + size(halo%receives(i)%ptr) - 1) = halo%receives(i)%ptr + receives(index:index + size(halo%receives(i)%ptr) - 1) = halo%receives(i)%ptr - if(present(nreceives)) nreceives(i) = size(halo%receives(i)%ptr) - if(present(start_indices)) start_indices(i) = index + if(present(nreceives)) nreceives(i) = size(halo%receives(i)%ptr) + if(present(start_indices)) start_indices(i) = index - index = index + size(halo%receives(i)%ptr) - end do - assert(index == size(receives) + 1) + index = index + size(halo%receives(i)%ptr) + end do + assert(index == size(receives) + 1) - end subroutine extract_all_halo_receives + end subroutine extract_all_halo_receives - subroutine set_all_halo_sends(halo, sends) - !!< Set all sends from the supplied vector. + subroutine set_all_halo_sends(halo, sends) + !!< Set all sends from the supplied vector. - type(halo_type), intent(inout) :: halo - integer, dimension(:), intent(in) :: sends + type(halo_type), intent(inout) :: halo + integer, dimension(:), intent(in) :: sends - integer :: i, index, nprocs + integer :: i, index, nprocs - assert(size(sends) == halo_all_sends_count(halo)) + assert(size(sends) == halo_all_sends_count(halo)) - nprocs = halo_proc_count(halo) + nprocs = halo_proc_count(halo) - assert(associated(halo%sends)) + assert(associated(halo%sends)) - index = 1 - do i = 1, nprocs - call set_halo_sends(halo, i, sends(index:index + halo_send_count(halo, i) - 1)) - index = index + halo_send_count(halo, i) - end do - assert(index == size(sends) + 1) + index = 1 + do i = 1, nprocs + call set_halo_sends(halo, i, sends(index:index + halo_send_count(halo, i) - 1)) + index = index + halo_send_count(halo, i) + end do + assert(index == size(sends) + 1) - end subroutine set_all_halo_sends + end subroutine set_all_halo_sends - subroutine set_all_halo_receives(halo, receives) - !!< Set all receives from the supplied vector. + subroutine set_all_halo_receives(halo, receives) + !!< Set all receives from the supplied vector. - type(halo_type), intent(inout) :: halo - integer, dimension(:), intent(in) :: receives + type(halo_type), intent(inout) :: halo + integer, dimension(:), intent(in) :: receives - integer :: i, index, nprocs + integer :: i, index, nprocs - assert(size(receives) == halo_all_receives_count(halo)) + assert(size(receives) == halo_all_receives_count(halo)) - nprocs = halo_proc_count(halo) + nprocs = halo_proc_count(halo) - assert(associated(halo%receives)) + assert(associated(halo%receives)) - index = 1 - do i = 1, nprocs - call set_halo_receives(halo, i, receives(index:index + halo_receive_count(halo, i) - 1)) - index = index + halo_receive_count(halo, i) - end do - assert(index == size(receives) + 1) + index = 1 + do i = 1, nprocs + call set_halo_receives(halo, i, receives(index:index + halo_receive_count(halo, i) - 1)) + index = index + halo_receive_count(halo, i) + end do + assert(index == size(receives) + 1) - end subroutine set_all_halo_receives + end subroutine set_all_halo_receives - function min_halo_send_node(halo) result(min_node) - !!< Return the minimum send node stored in the supplied halo + function min_halo_send_node(halo) result(min_node) + !!< Return the minimum send node stored in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: min_node + integer :: min_node - integer :: i + integer :: i - min_node = huge(0) - do i = 1, halo_proc_count(halo) - min_node = min(min_node, minval(halo_sends(halo, i))) - end do + min_node = huge(0) + do i = 1, halo_proc_count(halo) + min_node = min(min_node, minval(halo_sends(halo, i))) + end do - end function min_halo_send_node + end function min_halo_send_node - function min_halo_receive_node(halo) result(min_node) - !!< Return the minimum receive node stored in the supplied halo + function min_halo_receive_node(halo) result(min_node) + !!< Return the minimum receive node stored in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: min_node + integer :: min_node - integer :: i + integer :: i - min_node = huge(0) - do i = 1, halo_proc_count(halo) - min_node = min(min_node, minval(halo_receives(halo, i))) - end do + min_node = huge(0) + do i = 1, halo_proc_count(halo) + min_node = min(min_node, minval(halo_receives(halo, i))) + end do - end function min_halo_receive_node + end function min_halo_receive_node - function min_halo_node(halo) result(min_node) - !!< Return the minimum node stored in the supplied halo + function min_halo_node(halo) result(min_node) + !!< Return the minimum node stored in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: min_node + integer :: min_node - min_node = min_halo_send_node(halo) - min_node = min(min_node, min_halo_receive_node(halo)) + min_node = min_halo_send_node(halo) + min_node = min(min_node, min_halo_receive_node(halo)) - end function min_halo_node + end function min_halo_node - function max_halo_send_node(halo) result(max_node) - !!< Return the maximum send node stored in the supplied halo + function max_halo_send_node(halo) result(max_node) + !!< Return the maximum send node stored in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: max_node + integer :: max_node - integer :: i + integer :: i - max_node = -huge(0) - do i = 1, halo_proc_count(halo) - max_node = max(max_node, maxval(halo_sends(halo, i))) - end do + max_node = -huge(0) + do i = 1, halo_proc_count(halo) + max_node = max(max_node, maxval(halo_sends(halo, i))) + end do - end function max_halo_send_node + end function max_halo_send_node - function max_halo_receive_node(halo) result(max_node) - !!< Return the maximum receive node stored in the supplied halo + function max_halo_receive_node(halo) result(max_node) + !!< Return the maximum receive node stored in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: max_node + integer :: max_node - integer :: i + integer :: i - max_node = -huge(0) - do i = 1, halo_proc_count(halo) - max_node = max(max_node, maxval(halo_receives(halo, i))) - end do + max_node = -huge(0) + do i = 1, halo_proc_count(halo) + max_node = max(max_node, maxval(halo_receives(halo, i))) + end do - end function max_halo_receive_node + end function max_halo_receive_node - function max_halo_node(halo) result(max_node) - !!< Return the maximum node stored in the supplied halo + function max_halo_node(halo) result(max_node) + !!< Return the maximum node stored in the supplied halo - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: max_node + integer :: max_node - max_node = max_halo_send_node(halo) - max_node = max(max_node, max_halo_receive_node(halo)) + max_node = max_halo_send_node(halo) + max_node = max(max_node, max_halo_receive_node(halo)) - end function max_halo_node + end function max_halo_node - function serial_storage_halo_single(halo) result(serial) - !!< Return whether this halo is used to store parallel data in serial. This - !!< should be used (rather than a .not. isparallel()) for future proofing. + function serial_storage_halo_single(halo) result(serial) + !!< Return whether this halo is used to store parallel data in serial. This + !!< should be used (rather than a .not. isparallel()) for future proofing. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: serial + logical :: serial #ifdef HAVE_MPI - serial = getnprocs(communicator = MPI_COMM_FEMTOOLS) == 1 + serial = getnprocs(communicator = MPI_COMM_FEMTOOLS) == 1 #else - serial = .true. + serial = .true. #endif - end function serial_storage_halo_single + end function serial_storage_halo_single - function serial_storage_halo_multiple(halos) result(serial) - !!< Return whether these halos are used to store parallel data in serial. This - !!< should be used (rather than a .not. isparallel()) for future proofing. + function serial_storage_halo_multiple(halos) result(serial) + !!< Return whether these halos are used to store parallel data in serial. This + !!< should be used (rather than a .not. isparallel()) for future proofing. - type(halo_type), dimension(:), intent(in) :: halos + type(halo_type), dimension(:), intent(in) :: halos - integer :: i - logical, dimension(size(halos)) :: serial + integer :: i + logical, dimension(size(halos)) :: serial - do i = 1, size(halos) - serial(i) = serial_storage_halo(halos(i)) - end do + do i = 1, size(halos) + serial(i) = serial_storage_halo(halos(i)) + end do - end function serial_storage_halo_multiple + end function serial_storage_halo_multiple end module halos_base diff --git a/femtools/Halos_Communications.F90 b/femtools/Halos_Communications.F90 index 4412517ac8..ce19b482d8 100644 --- a/femtools/Halos_Communications.F90 +++ b/femtools/Halos_Communications.F90 @@ -29,945 +29,945 @@ module halos_communications - use fldebug - use futils - use mpi_interfaces - use halo_data_types - use parallel_tools - use quicksort - use halos_base - use halos_debug - use halos_allocates - use fields_data_types - use fields_base - use linked_lists - - implicit none - - private - - public :: halo_update, halo_accumulate, halo_max, halo_verifies - - interface zero_halo_receives - module procedure zero_halo_receives_array_integer, & + use fldebug + use futils + use mpi_interfaces + use halo_data_types + use parallel_tools + use quicksort + use halos_base + use halos_debug + use halos_allocates + use fields_data_types + use fields_base + use linked_lists + + implicit none + + private + + public :: halo_update, halo_accumulate, halo_max, halo_verifies + + interface zero_halo_receives + module procedure zero_halo_receives_array_integer, & & zero_halo_receives_array_real, zero_halo_receives_scalar_on_halo, & & zero_halo_receives_vector_on_halo_dim, zero_halo_receives_vector_on_halo - end interface zero_halo_receives + end interface zero_halo_receives - interface halo_update - module procedure halo_update_array_integer, halo_update_array_integer_block, & + interface halo_update + module procedure halo_update_array_integer, halo_update_array_integer_block, & & halo_update_array_integer_block2, halo_update_array_integer_star, & & halo_update_array_real, halo_update_array_real_block, halo_update_array_real_block2, & & halo_update_scalar_on_halo, halo_update_vector_on_halo, & & halo_update_tensor_on_halo, halo_update_scalar, halo_update_vector, & & halo_update_tensor - end interface halo_update + end interface halo_update - interface halo_max - module procedure halo_max_array_real, halo_max_scalar_on_halo, & + interface halo_max + module procedure halo_max_array_real, halo_max_scalar_on_halo, & & halo_max_scalar - end interface halo_max + end interface halo_max - interface halo_verifies - module procedure halo_verifies_array_integer, halo_verifies_array_real, & + interface halo_verifies + module procedure halo_verifies_array_integer, halo_verifies_array_real, & & halo_verifies_scalar, halo_verifies_vector_dim, halo_verifies_vector - end interface halo_verifies + end interface halo_verifies - interface halo_accumulate - module procedure halo_accumulate_array_real - end interface halo_accumulate + interface halo_accumulate + module procedure halo_accumulate_array_real + end interface halo_accumulate contains - subroutine zero_halo_receives_array_integer(halo, integer_data) - !!< Zero the receives for the supplied array of integer data + subroutine zero_halo_receives_array_integer(halo, integer_data) + !!< Zero the receives for the supplied array of integer data - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(inout) :: integer_data + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(inout) :: integer_data - integer :: i + integer :: i - do i = 1, halo_proc_count(halo) - integer_data(halo_receives(halo, i)) = 0 - end do + do i = 1, halo_proc_count(halo) + integer_data(halo_receives(halo, i)) = 0 + end do - end subroutine zero_halo_receives_array_integer + end subroutine zero_halo_receives_array_integer - subroutine zero_halo_receives_array_real(halo, real_data) - !!< Zero the receives for the supplied array of real data + subroutine zero_halo_receives_array_real(halo, real_data) + !!< Zero the receives for the supplied array of real data - type(halo_type), intent(in) :: halo - real, dimension(:), intent(inout) :: real_data + type(halo_type), intent(in) :: halo + real, dimension(:), intent(inout) :: real_data - integer :: i + integer :: i - do i = 1, halo_proc_count(halo) - real_data(halo_receives(halo, i)) = 0.0 - end do + do i = 1, halo_proc_count(halo) + real_data(halo_receives(halo, i)) = 0.0 + end do - end subroutine zero_halo_receives_array_real + end subroutine zero_halo_receives_array_real - subroutine zero_halo_receives_scalar_on_halo(halo, sfield) - !!< Zero the receives of the supplied halo for the supplied scalar field + subroutine zero_halo_receives_scalar_on_halo(halo, sfield) + !!< Zero the receives of the supplied halo for the supplied scalar field - type(halo_type), intent(in) :: halo - type(scalar_field), intent(inout) :: sfield + type(halo_type), intent(in) :: halo + type(scalar_field), intent(inout) :: sfield - call zero_halo_receives(halo, sfield%val) + call zero_halo_receives(halo, sfield%val) - end subroutine zero_halo_receives_scalar_on_halo + end subroutine zero_halo_receives_scalar_on_halo - subroutine zero_halo_receives_vector_on_halo_dim(halo, vfield, dim) - !!< Zero the receives of the supplied halo for the supplied vector field + subroutine zero_halo_receives_vector_on_halo_dim(halo, vfield, dim) + !!< Zero the receives of the supplied halo for the supplied vector field - type(halo_type), intent(in) :: halo - type(vector_field), intent(inout) :: vfield - integer, intent(in) :: dim + type(halo_type), intent(in) :: halo + type(vector_field), intent(inout) :: vfield + integer, intent(in) :: dim - assert(dim >= 1) - assert(dim <= vfield%dim) + assert(dim >= 1) + assert(dim <= vfield%dim) - call zero_halo_receives(halo, vfield%val(dim,:)) + call zero_halo_receives(halo, vfield%val(dim,:)) - end subroutine zero_halo_receives_vector_on_halo_dim + end subroutine zero_halo_receives_vector_on_halo_dim - subroutine zero_halo_receives_vector_on_halo(halo, vfield) - !!< Zero the receives of the supplied halo for the supplied vector field + subroutine zero_halo_receives_vector_on_halo(halo, vfield) + !!< Zero the receives of the supplied halo for the supplied vector field - type(halo_type), intent(in) :: halo - type(vector_field), intent(inout) :: vfield + type(halo_type), intent(in) :: halo + type(vector_field), intent(inout) :: vfield - integer :: i + integer :: i - do i = 1, vfield%dim - call zero_halo_receives(halo, vfield, i) - end do + do i = 1, vfield%dim + call zero_halo_receives(halo, vfield, i) + end do - end subroutine zero_halo_receives_vector_on_halo + end subroutine zero_halo_receives_vector_on_halo - subroutine halo_update_array_integer(halo, integer_data) - !!< Update the supplied array of integer data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_integer(halo, integer_data) + !!< Update the supplied array of integer data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(inout) :: integer_data + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(inout) :: integer_data - assert(size(integer_data, 1) >= max_halo_node(halo)) + assert(size(integer_data, 1) >= max_halo_node(halo)) - call halo_update_array_integer_star(halo, integer_data, 1) + call halo_update_array_integer_star(halo, integer_data, 1) - end subroutine halo_update_array_integer + end subroutine halo_update_array_integer - subroutine halo_update_array_integer_block(halo, integer_data) - !!< Update the supplied array of integer data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_integer_block(halo, integer_data) + !!< Update the supplied array of integer data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - integer, dimension(:,:), intent(inout) :: integer_data + type(halo_type), intent(in) :: halo + integer, dimension(:,:), intent(inout) :: integer_data - assert(size(integer_data, 2) >= max_halo_node(halo)) + assert(size(integer_data, 2) >= max_halo_node(halo)) - call halo_update_array_integer_star(halo, integer_data, size(integer_data,1)) + call halo_update_array_integer_star(halo, integer_data, size(integer_data,1)) - end subroutine halo_update_array_integer_block + end subroutine halo_update_array_integer_block - subroutine halo_update_array_integer_block2(halo, integer_data) - !!< Update the supplied array of integer data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_integer_block2(halo, integer_data) + !!< Update the supplied array of integer data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - integer, dimension(:,:,:), intent(inout) :: integer_data + type(halo_type), intent(in) :: halo + integer, dimension(:,:,:), intent(inout) :: integer_data - assert(size(integer_data, 3) >= max_halo_node(halo)) + assert(size(integer_data, 3) >= max_halo_node(halo)) - call halo_update_array_integer_star(halo, integer_data, size(integer_data,1)*size(integer_data,2)) + call halo_update_array_integer_star(halo, integer_data, size(integer_data,1)*size(integer_data,2)) - end subroutine halo_update_array_integer_block2 + end subroutine halo_update_array_integer_block2 - subroutine halo_update_array_integer_star(halo, integer_data, block_size) - !!< Update the supplied array of integer data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_integer_star(halo, integer_data, block_size) + !!< Update the supplied array of integer data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - integer, dimension(*), intent(inout) :: integer_data - integer, intent(in) :: block_size + type(halo_type), intent(in) :: halo + integer, dimension(*), intent(inout) :: integer_data + integer, intent(in) :: block_size #ifdef HAVE_MPI - integer :: communicator, i, ierr, nprocs, nreceives, nsends, rank - integer, dimension(:), allocatable :: receive_types, requests, send_types, statuses - integer tag - assert(halo_valid_for_communication(halo)) - assert(.not. pending_communication(halo)) - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - - ! Create indexed MPI types defining the indices into integer_data to be sent/received - allocate(send_types(nprocs)) - allocate(receive_types(nprocs)) - send_types = MPI_DATATYPE_NULL - receive_types = MPI_DATATYPE_NULL - do i = 1, nprocs - nsends = halo_send_count(halo, i) - if(nsends > 0) then - call mpi_type_create_indexed_block(nsends, block_size, & - & (halo_sends(halo, i) - 1)*block_size, & - & getpinteger(), send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + integer :: communicator, i, ierr, nprocs, nreceives, nsends, rank + integer, dimension(:), allocatable :: receive_types, requests, send_types, statuses + integer tag + assert(halo_valid_for_communication(halo)) + assert(.not. pending_communication(halo)) + + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) + + ! Create indexed MPI types defining the indices into integer_data to be sent/received + allocate(send_types(nprocs)) + allocate(receive_types(nprocs)) + send_types = MPI_DATATYPE_NULL + receive_types = MPI_DATATYPE_NULL + do i = 1, nprocs + nsends = halo_send_count(halo, i) + if(nsends > 0) then + call mpi_type_create_indexed_block(nsends, block_size, & + & (halo_sends(halo, i) - 1)*block_size, & + & getpinteger(), send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if - nreceives = halo_receive_count(halo, i) - if(nreceives > 0) then - call mpi_type_create_indexed_block(nreceives, block_size, & - & (halo_receives(halo, i) - 1)*block_size, & - & getpinteger(), receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Set up non-blocking communications - allocate(requests(nprocs * 2)) - requests = MPI_REQUEST_NULL - rank = getrank(communicator) - tag = next_mpi_tag() - - do i = 1, nprocs - ! Non-blocking sends - if(halo_send_count(halo, i) > 0) then - call mpi_isend(integer_data, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + nreceives = halo_receive_count(halo, i) + if(nreceives > 0) then + call mpi_type_create_indexed_block(nreceives, block_size, & + & (halo_receives(halo, i) - 1)*block_size, & + & getpinteger(), receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do - ! Non-blocking receives - if(halo_receive_count(halo, i) > 0) then - call mpi_irecv(integer_data, 1, receive_types(i), i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - ! Free the indexed MPI types - do i = 1, nprocs - if(send_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + ! Set up non-blocking communications + allocate(requests(nprocs * 2)) + requests = MPI_REQUEST_NULL + rank = getrank(communicator) + tag = next_mpi_tag() + + do i = 1, nprocs + ! Non-blocking sends + if(halo_send_count(halo, i) > 0) then + call mpi_isend(integer_data, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if - if(receive_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - deallocate(send_types) - deallocate(receive_types) + ! Non-blocking receives + if(halo_receive_count(halo, i) > 0) then + call mpi_irecv(integer_data, 1, receive_types(i), i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + ! Free the indexed MPI types + do i = 1, nprocs + if(send_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + if(receive_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + deallocate(send_types) + deallocate(receive_types) #else - if(.not. valid_serial_halo(halo)) then - FLAbort("Cannot update halos without MPI support") - end if + if(.not. valid_serial_halo(halo)) then + FLAbort("Cannot update halos without MPI support") + end if #endif - end subroutine halo_update_array_integer_star + end subroutine halo_update_array_integer_star - subroutine halo_update_array_real(halo, real_data) - !!< Update the supplied array of real data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_real(halo, real_data) + !!< Update the supplied array of real data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - real, dimension(:), intent(inout) :: real_data + type(halo_type), intent(in) :: halo + real, dimension(:), intent(inout) :: real_data - assert(size(real_data, 1) >= max_halo_node(halo)) + assert(size(real_data, 1) >= max_halo_node(halo)) - call halo_update_array_real_star(halo, real_data, 1) + call halo_update_array_real_star(halo, real_data, 1) - end subroutine halo_update_array_real + end subroutine halo_update_array_real - subroutine halo_update_array_real_block(halo, real_data) - !!< Update the supplied array of real data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_real_block(halo, real_data) + !!< Update the supplied array of real data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - real, dimension(:,:), intent(inout) :: real_data + type(halo_type), intent(in) :: halo + real, dimension(:,:), intent(inout) :: real_data - assert(size(real_data, 2) >= max_halo_node(halo)) + assert(size(real_data, 2) >= max_halo_node(halo)) - call halo_update_array_real_star(halo, real_data, size(real_data,1)) + call halo_update_array_real_star(halo, real_data, size(real_data,1)) - end subroutine halo_update_array_real_block + end subroutine halo_update_array_real_block - subroutine halo_update_array_real_block2(halo, real_data) - !!< Update the supplied array of real data. Fortran port of - !!< FLComms::Update(...). + subroutine halo_update_array_real_block2(halo, real_data) + !!< Update the supplied array of real data. Fortran port of + !!< FLComms::Update(...). - type(halo_type), intent(in) :: halo - real, dimension(:,:,:), intent(inout) :: real_data + type(halo_type), intent(in) :: halo + real, dimension(:,:,:), intent(inout) :: real_data - assert(size(real_data, 3) >= max_halo_node(halo)) + assert(size(real_data, 3) >= max_halo_node(halo)) - call halo_update_array_real_star(halo, real_data, size(real_data,1)*size(real_data,2)) + call halo_update_array_real_star(halo, real_data, size(real_data,1)*size(real_data,2)) - end subroutine halo_update_array_real_block2 + end subroutine halo_update_array_real_block2 - subroutine halo_update_array_real_star(halo, real_data, block_size) - ! This is the actual workhorse for the previous versions of halo_update_real_... - ! It simply takes in the begin address and the size of the blocks - type(halo_type), intent(in) :: halo - real, dimension(*), intent(inout) :: real_data - integer, intent(in) :: block_size + subroutine halo_update_array_real_star(halo, real_data, block_size) + ! This is the actual workhorse for the previous versions of halo_update_real_... + ! It simply takes in the begin address and the size of the blocks + type(halo_type), intent(in) :: halo + real, dimension(*), intent(inout) :: real_data + integer, intent(in) :: block_size #ifdef HAVE_MPI - integer :: communicator, i, ierr, nprocs, nreceives, nsends, rank - integer, dimension(:), allocatable :: receive_types, requests, send_types, statuses - integer tag - - assert(halo_valid_for_communication(halo)) - assert(.not. pending_communication(halo)) - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - - ! Create indexed MPI types defining the indices into real_data to be sent/received - allocate(send_types(nprocs)) - allocate(receive_types(nprocs)) - send_types = MPI_DATATYPE_NULL - receive_types = MPI_DATATYPE_NULL - do i = 1, nprocs - nsends = halo_send_count(halo, i) - if(nsends > 0) then - call mpi_type_create_indexed_block(nsends, block_size, & - & (halo_sends(halo, i) - 1)*block_size, & - & getpreal(), send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) + integer :: communicator, i, ierr, nprocs, nreceives, nsends, rank + integer, dimension(:), allocatable :: receive_types, requests, send_types, statuses + integer tag + + assert(halo_valid_for_communication(halo)) + assert(.not. pending_communication(halo)) + + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) + + ! Create indexed MPI types defining the indices into real_data to be sent/received + allocate(send_types(nprocs)) + allocate(receive_types(nprocs)) + send_types = MPI_DATATYPE_NULL + receive_types = MPI_DATATYPE_NULL + do i = 1, nprocs + nsends = halo_send_count(halo, i) + if(nsends > 0) then + call mpi_type_create_indexed_block(nsends, block_size, & + & (halo_sends(halo, i) - 1)*block_size, & + & getpreal(), send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + nreceives = halo_receive_count(halo, i) + if(nreceives > 0) then + call mpi_type_create_indexed_block(nreceives, block_size, & + & (halo_receives(halo, i) - 1)*block_size, & + & getpreal(), receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Set up non-blocking communications + allocate(requests(nprocs * 2)) + requests = MPI_REQUEST_NULL + rank = getrank(communicator) + tag = next_mpi_tag() + + do i = 1, nprocs + ! Non-blocking sends + if(halo_send_count(halo, i) > 0) then + call mpi_isend(real_data, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(halo_receive_count(halo, i) > 0) then + call mpi_irecv(real_data, 1, receive_types(i), i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + ! Free the indexed MPI types + do i = 1, nprocs + if(send_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + if(receive_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + deallocate(send_types) + deallocate(receive_types) +#else + if(.not. valid_serial_halo(halo)) then + FLAbort("Cannot update halos without MPI support") end if +#endif - nreceives = halo_receive_count(halo, i) - if(nreceives > 0) then - call mpi_type_create_indexed_block(nreceives, block_size, & - & (halo_receives(halo, i) - 1)*block_size, & - & getpreal(), receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) + end subroutine halo_update_array_real_star + + subroutine halo_update_scalar_on_halo(halo, s_field, verbose) + !!< Update the supplied scalar field on the supplied halo. + + type(halo_type), intent(in) :: halo + type(scalar_field), intent(inout) :: s_field + logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages + + real, dimension(:), allocatable :: buffer + + if (.not. present_and_false(verbose)) then + ewrite(2, *) "Updating halo " // trim(halo%name) // " for field " // trim(s_field%name) end if - end do - - ! Set up non-blocking communications - allocate(requests(nprocs * 2)) - requests = MPI_REQUEST_NULL - rank = getrank(communicator) - tag = next_mpi_tag() - - do i = 1, nprocs - ! Non-blocking sends - if(halo_send_count(halo, i) > 0) then - call mpi_isend(real_data, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) + + select case(s_field%field_type) + case(FIELD_TYPE_NORMAL) + assert(associated(s_field%val)) + if(s_field%val_stride == 1) then + call halo_update(halo, s_field%val) + else + if (.not. present_and_false(verbose)) then + ewrite(2,*) "Need to copy into temp. buffer because field has stride", s_field%val_stride + end if + ! A stride argument should be passed to halo_update_real_array. For + ! now just use a buffer. + allocate(buffer(node_count(s_field))) + buffer = s_field%val + call halo_update(halo, buffer) + s_field%val = buffer + deallocate(buffer) + end if + case(FIELD_TYPE_CONSTANT) + case default + ewrite(-1, "(a,i0)") "For field type ", s_field%field_type + FLAbort("Unrecognised field type") + end select + + end subroutine halo_update_scalar_on_halo + + subroutine halo_update_vector_on_halo(halo, v_field, verbose) + !!< Update the supplied vector field on the supplied halo. + + type(halo_type), intent(in) :: halo + type(vector_field), intent(inout) :: v_field + logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages + + if (.not. present_and_false(verbose)) then + ewrite(2, *) "Updating halo " // trim(halo%name) // " for field " // trim(v_field%name) end if - ! Non-blocking receives - if(halo_receive_count(halo, i) > 0) then - call mpi_irecv(real_data, 1, receive_types(i), i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) + select case(v_field%field_type) + case(FIELD_TYPE_NORMAL) + call halo_update(halo, v_field%val) + case(FIELD_TYPE_CONSTANT) + case default + ewrite(-1, "(a,i0)") "For field type ", v_field%field_type + FLAbort("Unrecognised field type") + end select + + end subroutine halo_update_vector_on_halo + + subroutine halo_update_tensor_on_halo(halo, t_field, verbose) + !!< Update the supplied tensor field on the supplied halo. + + type(halo_type), intent(in) :: halo + type(tensor_field), intent(inout) :: t_field + logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages + + if (.not. present_and_false(verbose)) then + ewrite(2, *) "Updating halo " // trim(halo%name) // " for field " // trim(t_field%name) end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - ! Free the indexed MPI types - do i = 1, nprocs - if(send_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) + + select case(t_field%field_type) + case(FIELD_TYPE_NORMAL) + assert(associated(t_field%val)) + call halo_update(halo, t_field%val) + case(FIELD_TYPE_CONSTANT) + case default + ewrite(-1, "(a,i0)") "For field type ", t_field%field_type + FLAbort("Unrecognised field type") + end select + + end subroutine halo_update_tensor_on_halo + + subroutine halo_update_scalar(s_field, level, verbose) + !!< Update the halos of the supplied field. If level is not supplied, the + !!< field is updated on its largest halo. + + type(scalar_field), intent(inout) :: s_field + integer, optional, intent(in) :: level + logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages + + integer :: llevel, nhalos + + nhalos = halo_count(s_field) + if(present(level)) then + assert(level > 0) + llevel = min(level, nhalos) + else + llevel = nhalos end if - if(receive_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) + if(nhalos > 0) then + call halo_update(s_field%mesh%halos(llevel), s_field, verbose=verbose) end if - end do - deallocate(send_types) - deallocate(receive_types) -#else - if(.not. valid_serial_halo(halo)) then - FLAbort("Cannot update halos without MPI support") - end if -#endif - end subroutine halo_update_array_real_star - - subroutine halo_update_scalar_on_halo(halo, s_field, verbose) - !!< Update the supplied scalar field on the supplied halo. - - type(halo_type), intent(in) :: halo - type(scalar_field), intent(inout) :: s_field - logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages - - real, dimension(:), allocatable :: buffer - - if (.not. present_and_false(verbose)) then - ewrite(2, *) "Updating halo " // trim(halo%name) // " for field " // trim(s_field%name) - end if - - select case(s_field%field_type) - case(FIELD_TYPE_NORMAL) - assert(associated(s_field%val)) - if(s_field%val_stride == 1) then - call halo_update(halo, s_field%val) - else - if (.not. present_and_false(verbose)) then - ewrite(2,*) "Need to copy into temp. buffer because field has stride", s_field%val_stride - end if - ! A stride argument should be passed to halo_update_real_array. For - ! now just use a buffer. - allocate(buffer(node_count(s_field))) - buffer = s_field%val - call halo_update(halo, buffer) - s_field%val = buffer - deallocate(buffer) - end if - case(FIELD_TYPE_CONSTANT) - case default - ewrite(-1, "(a,i0)") "For field type ", s_field%field_type - FLAbort("Unrecognised field type") - end select - - end subroutine halo_update_scalar_on_halo - - subroutine halo_update_vector_on_halo(halo, v_field, verbose) - !!< Update the supplied vector field on the supplied halo. - - type(halo_type), intent(in) :: halo - type(vector_field), intent(inout) :: v_field - logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages - - if (.not. present_and_false(verbose)) then - ewrite(2, *) "Updating halo " // trim(halo%name) // " for field " // trim(v_field%name) - end if - - select case(v_field%field_type) - case(FIELD_TYPE_NORMAL) - call halo_update(halo, v_field%val) - case(FIELD_TYPE_CONSTANT) - case default - ewrite(-1, "(a,i0)") "For field type ", v_field%field_type - FLAbort("Unrecognised field type") - end select - - end subroutine halo_update_vector_on_halo - - subroutine halo_update_tensor_on_halo(halo, t_field, verbose) - !!< Update the supplied tensor field on the supplied halo. - - type(halo_type), intent(in) :: halo - type(tensor_field), intent(inout) :: t_field - logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages - - if (.not. present_and_false(verbose)) then - ewrite(2, *) "Updating halo " // trim(halo%name) // " for field " // trim(t_field%name) - end if - - select case(t_field%field_type) - case(FIELD_TYPE_NORMAL) - assert(associated(t_field%val)) - call halo_update(halo, t_field%val) - case(FIELD_TYPE_CONSTANT) - case default - ewrite(-1, "(a,i0)") "For field type ", t_field%field_type - FLAbort("Unrecognised field type") - end select - - end subroutine halo_update_tensor_on_halo - - subroutine halo_update_scalar(s_field, level, verbose) - !!< Update the halos of the supplied field. If level is not supplied, the - !!< field is updated on its largest halo. - - type(scalar_field), intent(inout) :: s_field - integer, optional, intent(in) :: level - logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages - - integer :: llevel, nhalos - - nhalos = halo_count(s_field) - if(present(level)) then - assert(level > 0) - llevel = min(level, nhalos) - else - llevel = nhalos - end if - - if(nhalos > 0) then - call halo_update(s_field%mesh%halos(llevel), s_field, verbose=verbose) - end if - - end subroutine halo_update_scalar - - subroutine halo_update_vector(v_field, level, verbose) - !!< Update the halos of the supplied field. If level is not supplied, the - !!< field is updated on its largest halo. - - type(vector_field), intent(inout) :: v_field - integer, optional, intent(in) :: level - logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages - - integer :: llevel, nhalos - - nhalos = halo_count(v_field) - if(present(level)) then - assert(level > 0) - llevel = min(level, nhalos) - else - llevel = nhalos - end if - - if(nhalos > 0) then - call halo_update(v_field%mesh%halos(llevel), v_field, verbose=verbose) - end if - - end subroutine halo_update_vector - - subroutine halo_update_tensor(t_field, level, verbose) - !!< Update the halos of the supplied field. If level is not supplied, the - !!< field is updated on its largest halo. - - type(tensor_field), intent(inout) :: t_field - integer, optional, intent(in) :: level - logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages - - integer :: llevel, nhalos - - nhalos = halo_count(t_field) - if(present(level)) then - assert(level > 0) - llevel = min(level, nhalos) - else - llevel = nhalos - end if - - if(nhalos > 0) then - call halo_update(t_field%mesh%halos(llevel), t_field, verbose) - end if - - end subroutine halo_update_tensor - - subroutine halo_accumulate_array_real_star(halo, real_data, block_size) - !!< For nodes that are seen by one or more other processors (recv nodes on these processes) - !!< add the contributions they have stored for these recv nodes to the corresponding entry - !!< of the corresponding send node on the owner of the node. Note, that this is a reverse - !!< communication pattern, where contributions from recv nodes are send to send nodes - type(halo_type), intent(in) :: halo - real, dimension(*), intent(inout) :: real_data - integer, intent(in) :: block_size + end subroutine halo_update_scalar -#ifdef HAVE_MPI - integer :: communicator, ierr, nprocs, nrecvs, nsends - type(real_vector), dimension(:), allocatable :: send_buffer, recv_buffer - integer, dimension(:), allocatable :: requests, statuses - integer tag - integer i, j, k - - assert(halo_valid_for_communication(halo)) - assert(.not. pending_communication(halo)) - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - allocate(requests(1:2*nprocs), statuses(1:2*nprocs*MPI_STATUS_SIZE)) - allocate(recv_buffer(1:nprocs), send_buffer(1:nprocs)) - - tag = next_mpi_tag() - - do i = 1, nprocs - nrecvs = halo_receive_count(halo, i) - if (nrecvs > 0) then - allocate(send_buffer(i)%ptr(1:nrecvs*block_size)) - do j=1, nrecvs - k = halo_receive(halo, i, j) - send_buffer(i)%ptr((j-1)*block_size+1:j*block_size) = real_data((k-1)*block_size+1:k*block_size) - end do - call mpi_isend(send_buffer(i)%ptr, nrecvs*block_size, getpreal(), i-1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) + subroutine halo_update_vector(v_field, level, verbose) + !!< Update the halos of the supplied field. If level is not supplied, the + !!< field is updated on its largest halo. + + type(vector_field), intent(inout) :: v_field + integer, optional, intent(in) :: level + logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages + + integer :: llevel, nhalos + + nhalos = halo_count(v_field) + if(present(level)) then + assert(level > 0) + llevel = min(level, nhalos) else - requests(i) = MPI_REQUEST_NULL + llevel = nhalos end if - nsends = halo_send_count(halo, i) - if (nsends > 0) then - allocate(recv_buffer(i)%ptr(1:nsends*block_size)) - call mpi_irecv(recv_buffer(i)%ptr, nsends*block_size, getpreal(), i-1, tag, communicator, requests(nprocs+i), ierr) - assert(ierr == MPI_SUCCESS) - else - requests(nprocs+i) = MPI_REQUEST_NULL + if(nhalos > 0) then + call halo_update(v_field%mesh%halos(llevel), v_field, verbose=verbose) end if - end do - - call mpi_waitall(2*nprocs, requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(requests, statuses) - - do i=1, nprocs - nsends = halo_send_count(halo, i) - if (nsends > 0) then - do j=1, nsends - k = halo_send(halo, i, j) - real_data((k-1)*block_size+1:k*block_size) = real_data((k-1)*block_size+1:k*block_size) + & - recv_buffer(i)%ptr((j-1)*block_size+1:j*block_size) - end do - deallocate(recv_buffer(i)%ptr) + + end subroutine halo_update_vector + + subroutine halo_update_tensor(t_field, level, verbose) + !!< Update the halos of the supplied field. If level is not supplied, the + !!< field is updated on its largest halo. + + type(tensor_field), intent(inout) :: t_field + integer, optional, intent(in) :: level + logical, intent(in), optional :: verbose ! set to .false. to leave out any verbosity 1 or 2 messages + + integer :: llevel, nhalos + + nhalos = halo_count(t_field) + if(present(level)) then + assert(level > 0) + llevel = min(level, nhalos) + else + llevel = nhalos end if - nrecvs = halo_receive_count(halo, i) - if (nrecvs > 0) then - deallocate(send_buffer(i)%ptr) + if(nhalos > 0) then + call halo_update(t_field%mesh%halos(llevel), t_field, verbose) end if - end do - deallocate(send_buffer, recv_buffer) + end subroutine halo_update_tensor + + subroutine halo_accumulate_array_real_star(halo, real_data, block_size) + !!< For nodes that are seen by one or more other processors (recv nodes on these processes) + !!< add the contributions they have stored for these recv nodes to the corresponding entry + !!< of the corresponding send node on the owner of the node. Note, that this is a reverse + !!< communication pattern, where contributions from recv nodes are send to send nodes + type(halo_type), intent(in) :: halo + real, dimension(*), intent(inout) :: real_data + integer, intent(in) :: block_size + +#ifdef HAVE_MPI + integer :: communicator, ierr, nprocs, nrecvs, nsends + type(real_vector), dimension(:), allocatable :: send_buffer, recv_buffer + integer, dimension(:), allocatable :: requests, statuses + integer tag + integer i, j, k + + assert(halo_valid_for_communication(halo)) + assert(.not. pending_communication(halo)) + + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) + allocate(requests(1:2*nprocs), statuses(1:2*nprocs*MPI_STATUS_SIZE)) + allocate(recv_buffer(1:nprocs), send_buffer(1:nprocs)) + + tag = next_mpi_tag() + + do i = 1, nprocs + nrecvs = halo_receive_count(halo, i) + if (nrecvs > 0) then + allocate(send_buffer(i)%ptr(1:nrecvs*block_size)) + do j=1, nrecvs + k = halo_receive(halo, i, j) + send_buffer(i)%ptr((j-1)*block_size+1:j*block_size) = real_data((k-1)*block_size+1:k*block_size) + end do + call mpi_isend(send_buffer(i)%ptr, nrecvs*block_size, getpreal(), i-1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + else + requests(i) = MPI_REQUEST_NULL + end if + + nsends = halo_send_count(halo, i) + if (nsends > 0) then + allocate(recv_buffer(i)%ptr(1:nsends*block_size)) + call mpi_irecv(recv_buffer(i)%ptr, nsends*block_size, getpreal(), i-1, tag, communicator, requests(nprocs+i), ierr) + assert(ierr == MPI_SUCCESS) + else + requests(nprocs+i) = MPI_REQUEST_NULL + end if + end do + + call mpi_waitall(2*nprocs, requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(requests, statuses) + + do i=1, nprocs + nsends = halo_send_count(halo, i) + if (nsends > 0) then + do j=1, nsends + k = halo_send(halo, i, j) + real_data((k-1)*block_size+1:k*block_size) = real_data((k-1)*block_size+1:k*block_size) + & + recv_buffer(i)%ptr((j-1)*block_size+1:j*block_size) + end do + deallocate(recv_buffer(i)%ptr) + end if + + nrecvs = halo_receive_count(halo, i) + if (nrecvs > 0) then + deallocate(send_buffer(i)%ptr) + end if + end do + + deallocate(send_buffer, recv_buffer) #else - if(.not. valid_serial_halo(halo)) then - FLAbort("Cannot update halos without MPI support") - end if + if(.not. valid_serial_halo(halo)) then + FLAbort("Cannot update halos without MPI support") + end if #endif - end subroutine halo_accumulate_array_real_star + end subroutine halo_accumulate_array_real_star - subroutine halo_accumulate_array_real(halo, array) - !!< For nodes that are seen by one or more other processors (recv nodes on these processes) - !!< add the contributions they have stored for these recv nodes to the correpsonding entry - !!< of the corresponding send node on the owner of the node. Note, that this is a reverse - !!< communication pattern, where contributions from recv nodes are send to send nodes - type(halo_type), intent(in) :: halo - real, dimension(:), intent(inout) :: array + subroutine halo_accumulate_array_real(halo, array) + !!< For nodes that are seen by one or more other processors (recv nodes on these processes) + !!< add the contributions they have stored for these recv nodes to the correpsonding entry + !!< of the corresponding send node on the owner of the node. Note, that this is a reverse + !!< communication pattern, where contributions from recv nodes are send to send nodes + type(halo_type), intent(in) :: halo + real, dimension(:), intent(inout) :: array - assert(size(array,1) >= max_halo_node(halo)) + assert(size(array,1) >= max_halo_node(halo)) - call halo_accumulate_array_real_star(halo, array, 1) + call halo_accumulate_array_real_star(halo, array, 1) - end subroutine halo_accumulate_array_real + end subroutine halo_accumulate_array_real - subroutine halo_max_array_real(halo, real_data) - type(halo_type), intent(in) :: halo - real, dimension(:), intent(inout) :: real_data + subroutine halo_max_array_real(halo, real_data) + type(halo_type), intent(in) :: halo + real, dimension(:), intent(inout) :: real_data #ifdef HAVE_MPI - integer :: communicator, i, ierr, nprocs, nsends, nreceives, rank - integer, dimension(:), allocatable :: requests, receive_types, send_types, statuses - type(real_vector), dimension(:), allocatable :: receive_real_array - integer tag - - assert(halo_valid_for_communication(halo)) - assert(.not. pending_communication(halo)) - - assert(lbound(real_data, 1) <= min_halo_node(halo)) - assert(ubound(real_data, 1) >= max_halo_node(halo)) - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - - ! Create indexed MPI types defining the indices into real_data to be sent - allocate(send_types(nprocs)) - allocate(receive_types(nprocs)) - send_types = MPI_DATATYPE_NULL - receive_types = MPI_DATATYPE_NULL - do i = 1, nprocs - nsends = halo_send_count(halo, i) - if(nsends > 0) then - call mpi_type_create_indexed_block(nsends, 1, & - & halo_sends(halo, i) - lbound(real_data, 1), getpreal(), send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + integer :: communicator, i, ierr, nprocs, nsends, nreceives, rank + integer, dimension(:), allocatable :: requests, receive_types, send_types, statuses + type(real_vector), dimension(:), allocatable :: receive_real_array + integer tag + + assert(halo_valid_for_communication(halo)) + assert(.not. pending_communication(halo)) + + assert(lbound(real_data, 1) <= min_halo_node(halo)) + assert(ubound(real_data, 1) >= max_halo_node(halo)) + + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) + + ! Create indexed MPI types defining the indices into real_data to be sent + allocate(send_types(nprocs)) + allocate(receive_types(nprocs)) + send_types = MPI_DATATYPE_NULL + receive_types = MPI_DATATYPE_NULL + do i = 1, nprocs + nsends = halo_send_count(halo, i) + if(nsends > 0) then + call mpi_type_create_indexed_block(nsends, 1, & + & halo_sends(halo, i) - lbound(real_data, 1), getpreal(), send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if - nreceives = halo_receive_count(halo, i) - if(nreceives > 0) then - call mpi_type_create_indexed_block(nreceives, 1, & - & halo_receives(halo, i) - lbound(real_data, 1), getpreal(), receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Allocate receive arrays. Use these to collect values for the send/receive - ! nodes for all sending processes. - allocate(receive_real_array(nprocs * 2)) - - ! Set up non-blocking communications - allocate(requests(nprocs * 4)) - requests = MPI_REQUEST_NULL - rank = getrank(communicator) - tag = next_mpi_tag() - - do i = 1, nprocs - ! Allocate receive arrays - allocate(receive_real_array(i)%ptr(halo_send_count(halo, i))) - allocate(receive_real_array(i + nprocs)%ptr(halo_receive_count(halo, i))) - - if(halo_send_count(halo, i) > 0) then - ! Non-blocking sends on sends - call mpi_isend(real_data, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - - ! Non-blocking receives on sends - call mpi_irecv(receive_real_array(i)%ptr, size(receive_real_array(i)%ptr), getpreal(), & - i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if + nreceives = halo_receive_count(halo, i) + if(nreceives > 0) then + call mpi_type_create_indexed_block(nreceives, 1, & + & halo_receives(halo, i) - lbound(real_data, 1), getpreal(), receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do - if(halo_receive_count(halo, i) > 0) then - ! Non-blocking sends on receives - call mpi_isend(real_data, 1, receive_types(i), i - 1, tag, communicator, & - requests(i + 2 * nprocs), ierr) - assert(ierr == MPI_SUCCESS) + ! Allocate receive arrays. Use these to collect values for the send/receive + ! nodes for all sending processes. + allocate(receive_real_array(nprocs * 2)) + + ! Set up non-blocking communications + allocate(requests(nprocs * 4)) + requests = MPI_REQUEST_NULL + rank = getrank(communicator) + tag = next_mpi_tag() + + do i = 1, nprocs + ! Allocate receive arrays + allocate(receive_real_array(i)%ptr(halo_send_count(halo, i))) + allocate(receive_real_array(i + nprocs)%ptr(halo_receive_count(halo, i))) + + if(halo_send_count(halo, i) > 0) then + ! Non-blocking sends on sends + call mpi_isend(real_data, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + + ! Non-blocking receives on sends + call mpi_irecv(receive_real_array(i)%ptr, size(receive_real_array(i)%ptr), getpreal(), & + i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if - ! Non-blocking receives on receives - call mpi_irecv(receive_real_array(i + nprocs)%ptr, size(receive_real_array(i + nprocs)%ptr),& - getpreal(), i - 1, tag, communicator, requests(i + 3 * nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - ! Free the indexed MPI types - do i = 1, nprocs - if(send_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + if(halo_receive_count(halo, i) > 0) then + ! Non-blocking sends on receives + call mpi_isend(real_data, 1, receive_types(i), i - 1, tag, communicator, & + requests(i + 2 * nprocs), ierr) + assert(ierr == MPI_SUCCESS) - if(receive_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - deallocate(send_types) - deallocate(receive_types) - - ! Perform the allmax - do i = 1, nprocs - real_data(halo_sends(halo, i)) = max(real_data(halo_sends(halo, i)), receive_real_array(i)%ptr) - real_data(halo_receives(halo, i)) = max(real_data(halo_receives(halo, i)), receive_real_array(i + nprocs)%ptr) - deallocate(receive_real_array(i)%ptr) - deallocate(receive_real_array(i + nprocs)%ptr) - end do - deallocate(receive_real_array) + ! Non-blocking receives on receives + call mpi_irecv(receive_real_array(i + nprocs)%ptr, size(receive_real_array(i + nprocs)%ptr),& + getpreal(), i - 1, tag, communicator, requests(i + 3 * nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + ! Free the indexed MPI types + do i = 1, nprocs + if(send_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + if(receive_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + deallocate(send_types) + deallocate(receive_types) + + ! Perform the allmax + do i = 1, nprocs + real_data(halo_sends(halo, i)) = max(real_data(halo_sends(halo, i)), receive_real_array(i)%ptr) + real_data(halo_receives(halo, i)) = max(real_data(halo_receives(halo, i)), receive_real_array(i + nprocs)%ptr) + deallocate(receive_real_array(i)%ptr) + deallocate(receive_real_array(i + nprocs)%ptr) + end do + deallocate(receive_real_array) #else - if(.not. valid_serial_halo(halo)) then - FLAbort("Cannot update halos without MPI support") - end if + if(.not. valid_serial_halo(halo)) then + FLAbort("Cannot update halos without MPI support") + end if #endif - end subroutine halo_max_array_real + end subroutine halo_max_array_real - subroutine halo_max_scalar_on_halo(halo, s_field) - type(halo_type), intent(in) :: halo - type(scalar_field), intent(inout) :: s_field + subroutine halo_max_scalar_on_halo(halo, s_field) + type(halo_type), intent(in) :: halo + type(scalar_field), intent(inout) :: s_field - select case(s_field%field_type) - case(FIELD_TYPE_NORMAL) - call halo_max(halo, s_field%val) - case(FIELD_TYPE_CONSTANT) - call allmax(s_field%val(1), communicator = halo_communicator(halo)) - case default - ewrite(-1, "(a,i0)") "For field type ", s_field%field_type - FLAbort("Unrecognised field type") - end select + select case(s_field%field_type) + case(FIELD_TYPE_NORMAL) + call halo_max(halo, s_field%val) + case(FIELD_TYPE_CONSTANT) + call allmax(s_field%val(1), communicator = halo_communicator(halo)) + case default + ewrite(-1, "(a,i0)") "For field type ", s_field%field_type + FLAbort("Unrecognised field type") + end select - end subroutine halo_max_scalar_on_halo + end subroutine halo_max_scalar_on_halo - subroutine halo_max_scalar(s_field, level) - type(scalar_field), intent(inout) :: s_field - integer, optional, intent(in) :: level + subroutine halo_max_scalar(s_field, level) + type(scalar_field), intent(inout) :: s_field + integer, optional, intent(in) :: level - integer :: llevel, nhalos + integer :: llevel, nhalos - nhalos = halo_count(s_field) - if(present(level)) then - assert(level > 0) - llevel = min(level, nhalos) - else - llevel = nhalos - end if + nhalos = halo_count(s_field) + if(present(level)) then + assert(level > 0) + llevel = min(level, nhalos) + else + llevel = nhalos + end if - if(nhalos > 0) then - call halo_max(s_field%mesh%halos(llevel), s_field) - end if + if(nhalos > 0) then + call halo_max(s_field%mesh%halos(llevel), s_field) + end if - end subroutine halo_max_scalar + end subroutine halo_max_scalar - function halo_verifies_array_integer(halo, integer_array) result(verifies) - !!< Verify the halo against the supplied array of integer data + function halo_verifies_array_integer(halo, integer_array) result(verifies) + !!< Verify the halo against the supplied array of integer data - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(in) :: integer_array + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(in) :: integer_array - logical :: verifies + logical :: verifies #ifdef DDEBUG - integer :: i, j, receive + integer :: i, j, receive #endif - integer, dimension(size(integer_array)) :: linteger_array + integer, dimension(size(integer_array)) :: linteger_array - linteger_array = integer_array - call zero_halo_receives(halo, linteger_array) + linteger_array = integer_array + call zero_halo_receives(halo, linteger_array) - call halo_update(halo, linteger_array) + call halo_update(halo, linteger_array) - verifies = all(integer_array == linteger_array) + verifies = all(integer_array == linteger_array) #ifdef DDEBUG - if(.not. verifies) then - do i = 1, halo_proc_count(halo) - do j = 1, halo_receive_count(halo, i) - receive = halo_receive(halo, i, j) - if(integer_array(receive) /= linteger_array(receive)) then - ewrite(0, *) "Warning: Halo receive ", receive, " for halo " // halo_name(halo) // " failed verification" - ewrite(0, *) "Reference = ", integer_array(receive) - ewrite(0, *) "Value in verification array = ", linteger_array(receive) - end if - end do - end do - - do i = 1, size(integer_array) - if(integer_array(i) /= linteger_array(i)) then - ewrite(0, *) "Warning: Reference index ", i, " for halo " // halo_name(halo) // " failed verification" - ewrite(0, *) "Reference = ", integer_array(i) - ewrite(0, *) "Value in verification array = ", linteger_array(i) - end if - end do - end if + if(.not. verifies) then + do i = 1, halo_proc_count(halo) + do j = 1, halo_receive_count(halo, i) + receive = halo_receive(halo, i, j) + if(integer_array(receive) /= linteger_array(receive)) then + ewrite(0, *) "Warning: Halo receive ", receive, " for halo " // halo_name(halo) // " failed verification" + ewrite(0, *) "Reference = ", integer_array(receive) + ewrite(0, *) "Value in verification array = ", linteger_array(receive) + end if + end do + end do + + do i = 1, size(integer_array) + if(integer_array(i) /= linteger_array(i)) then + ewrite(0, *) "Warning: Reference index ", i, " for halo " // halo_name(halo) // " failed verification" + ewrite(0, *) "Reference = ", integer_array(i) + ewrite(0, *) "Value in verification array = ", linteger_array(i) + end if + end do + end if #endif - if(verifies) then - ewrite(2, *) "halo_verifies_array_integer returning .true." - else - ewrite(2, *) "halo_verifies_array_integer returning .false." - end if + if(verifies) then + ewrite(2, *) "halo_verifies_array_integer returning .true." + else + ewrite(2, *) "halo_verifies_array_integer returning .false." + end if - end function halo_verifies_array_integer + end function halo_verifies_array_integer - function halo_verifies_array_real(halo, real_array) result(verifies) - !!< Verify the halo against the supplied array of real data. Replaces - !!< testhalo. + function halo_verifies_array_real(halo, real_array) result(verifies) + !!< Verify the halo against the supplied array of real data. Replaces + !!< testhalo. - type(halo_type), intent(in) :: halo - real, dimension(:), intent(in) :: real_array + type(halo_type), intent(in) :: halo + real, dimension(:), intent(in) :: real_array - real :: epsl + real :: epsl - logical :: verifies + logical :: verifies #ifdef DDEBUG - integer :: i, j, receive + integer :: i, j, receive #endif - real, dimension(size(real_array)) :: lreal_array + real, dimension(size(real_array)) :: lreal_array - lreal_array = real_array - call zero_halo_receives(halo, lreal_array) + lreal_array = real_array + call zero_halo_receives(halo, lreal_array) - call halo_update(halo, lreal_array) + call halo_update(halo, lreal_array) - epsl = spacing( maxval( abs( lreal_array ))) * 10000. - call allmax(epsl) + epsl = spacing( maxval( abs( lreal_array ))) * 10000. + call allmax(epsl) - verifies = all(abs(real_array - lreal_array) < epsl ) + verifies = all(abs(real_array - lreal_array) < epsl ) #ifdef DDEBUG - if(.not. verifies) then - do i = 1, halo_proc_count(halo) - do j = 1, halo_receive_count(halo, i) - receive = halo_receive(halo, i, j) - if(abs(real_array(receive) - lreal_array(receive)) >= epsl) then - ewrite(0, *) "Warning: Halo receive ", receive, " for halo " // halo_name(halo) // " failed verification" - ewrite(0, *) "Reference = ", real_array(receive) - ewrite(0, *) "Value in verification array = ", lreal_array(receive) - end if - end do - end do - - do i = 1, size(real_array) - if(abs(real_array(i) - lreal_array(i)) >= epsl ) then - ewrite(0, *) "Warning: Reference index ", i, " for halo " // halo_name(halo) // " failed verification" - ewrite(0, *) "Reference = ", real_array(i) - ewrite(0, *) "Value in verification array = ", lreal_array(i) - end if - end do - end if + if(.not. verifies) then + do i = 1, halo_proc_count(halo) + do j = 1, halo_receive_count(halo, i) + receive = halo_receive(halo, i, j) + if(abs(real_array(receive) - lreal_array(receive)) >= epsl) then + ewrite(0, *) "Warning: Halo receive ", receive, " for halo " // halo_name(halo) // " failed verification" + ewrite(0, *) "Reference = ", real_array(receive) + ewrite(0, *) "Value in verification array = ", lreal_array(receive) + end if + end do + end do + + do i = 1, size(real_array) + if(abs(real_array(i) - lreal_array(i)) >= epsl ) then + ewrite(0, *) "Warning: Reference index ", i, " for halo " // halo_name(halo) // " failed verification" + ewrite(0, *) "Reference = ", real_array(i) + ewrite(0, *) "Value in verification array = ", lreal_array(i) + end if + end do + end if #endif - if(verifies) then - ewrite(2, *) "halo_verifies_array_real returning .true." - else - ewrite(2, *) "halo_verifies_array_real returning .false." - end if + if(verifies) then + ewrite(2, *) "halo_verifies_array_real returning .true." + else + ewrite(2, *) "halo_verifies_array_real returning .false." + end if - end function halo_verifies_array_real + end function halo_verifies_array_real - function halo_verifies_scalar(halo, sfield) result(verifies) - !!< Verify the halo against the supplied scalar field + function halo_verifies_scalar(halo, sfield) result(verifies) + !!< Verify the halo against the supplied scalar field - type(halo_type), intent(in) :: halo - type(scalar_field), intent(in) :: sfield + type(halo_type), intent(in) :: halo + type(scalar_field), intent(in) :: sfield - logical :: verifies + logical :: verifies - verifies = halo_verifies(halo, sfield%val) + verifies = halo_verifies(halo, sfield%val) - end function halo_verifies_scalar + end function halo_verifies_scalar - function halo_verifies_vector_dim(halo, vfield, dim) result(verifies) - !!< Verify the halo against one component of the supplied vector field + function halo_verifies_vector_dim(halo, vfield, dim) result(verifies) + !!< Verify the halo against one component of the supplied vector field - type(halo_type), intent(in) :: halo - type(vector_field), intent(in) :: vfield - integer, intent(in) :: dim + type(halo_type), intent(in) :: halo + type(vector_field), intent(in) :: vfield + integer, intent(in) :: dim - logical :: verifies + logical :: verifies - type(scalar_field) :: sfield + type(scalar_field) :: sfield - sfield = extract_scalar_field(vfield, dim) - verifies = halo_verifies(halo, sfield) + sfield = extract_scalar_field(vfield, dim) + verifies = halo_verifies(halo, sfield) - end function halo_verifies_vector_dim + end function halo_verifies_vector_dim - function halo_verifies_vector(halo, vfield) result(verifies) - !!< Verify the halo against the supplied vector field + function halo_verifies_vector(halo, vfield) result(verifies) + !!< Verify the halo against the supplied vector field - type(halo_type), intent(in) :: halo - type(vector_field), intent(in) :: vfield + type(halo_type), intent(in) :: halo + type(vector_field), intent(in) :: vfield - logical :: verifies + logical :: verifies - integer :: i + integer :: i - verifies = .true. - do i = 1, vfield%dim - verifies = halo_verifies(halo, vfield, i) - if(.not. verifies) exit - end do + verifies = .true. + do i = 1, vfield%dim + verifies = halo_verifies(halo, vfield, i) + if(.not. verifies) exit + end do - end function halo_verifies_vector + end function halo_verifies_vector end module halos_communications diff --git a/femtools/Halos_Debug.F90 b/femtools/Halos_Debug.F90 index b5524fa959..4aa19f4f04 100644 --- a/femtools/Halos_Debug.F90 +++ b/femtools/Halos_Debug.F90 @@ -29,202 +29,202 @@ module halos_debug - use fldebug - use mpi_interfaces - use halo_data_types - use parallel_tools - use halos_base + use fldebug + use mpi_interfaces + use halo_data_types + use parallel_tools + use halos_base - implicit none + implicit none - private + private - public :: valid_serial_halo, pending_communication, valid_halo_communicator, & - & valid_halo_node_counts, halo_valid_for_communication, & - & trailing_receives_consistent, print_halo + public :: valid_serial_halo, pending_communication, valid_halo_communicator, & + & valid_halo_node_counts, halo_valid_for_communication, & + & trailing_receives_consistent, print_halo - interface pending_communication - module procedure pending_communication_halo - end interface pending_communication + interface pending_communication + module procedure pending_communication_halo + end interface pending_communication contains - function valid_serial_halo(halo) result(valid) - !!< Return whether the supplied halo is valid as a serial halo. + function valid_serial_halo(halo) result(valid) + !!< Return whether the supplied halo is valid as a serial halo. - type(halo_type), intent(in) :: halo - logical :: valid - valid = halo_proc_count(halo) <= 1 .and. halo_all_sends_count(halo) == 0 .and. halo_all_receives_count(halo) == 0 + type(halo_type), intent(in) :: halo + logical :: valid + valid = halo_proc_count(halo) <= 1 .and. halo_all_sends_count(halo) == 0 .and. halo_all_receives_count(halo) == 0 - end function valid_serial_halo + end function valid_serial_halo - function pending_communication_halo(halo) result(pending) - !!< Return whether there is a pending communication for the supplied halo. + function pending_communication_halo(halo) result(pending) + !!< Return whether there is a pending communication for the supplied halo. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: pending + logical :: pending #ifdef HAVE_MPI - assert(valid_halo_communicator(halo)) - pending = pending_communication(communicator = halo_communicator(halo)) + assert(valid_halo_communicator(halo)) + pending = pending_communication(communicator = halo_communicator(halo)) #else - pending = .false. + pending = .false. #endif - end function pending_communication_halo + end function pending_communication_halo - function valid_halo_communicator(halo) result(valid) - !!< Return whether the communicator for the supplied halo corresponds to - !!< a valid MPI communicator and is consistent with the halo number of - !!< processes - i.e. whether the halo communicator can be used for - !!< communication on the halo. + function valid_halo_communicator(halo) result(valid) + !!< Return whether the communicator for the supplied halo corresponds to + !!< a valid MPI communicator and is consistent with the halo number of + !!< processes - i.e. whether the halo communicator can be used for + !!< communication on the halo. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: valid + logical :: valid - valid = valid_communicator(halo_communicator(halo)) .and. & + valid = valid_communicator(halo_communicator(halo)) .and. & & getnprocs(halo_communicator(halo)) == halo_proc_count(halo) - end function valid_halo_communicator + end function valid_halo_communicator - function valid_halo_node_counts(halo) result(valid) - !!< Return whether the halo has consistent node sizes across processors. A - !!< moderately expensive operation (involes communication of nprocs integers - !!< from/to each processors). + function valid_halo_node_counts(halo) result(valid) + !!< Return whether the halo has consistent node sizes across processors. A + !!< moderately expensive operation (involes communication of nprocs integers + !!< from/to each processors). - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: valid + logical :: valid #ifdef HAVE_MPI - integer :: ierr, nprocs - integer, dimension(:), allocatable :: communicated_nreceives, nreceives, nsends + integer :: ierr, nprocs + integer, dimension(:), allocatable :: communicated_nreceives, nreceives, nsends - assert(valid_halo_communicator(halo)) - assert(.not. pending_communication(halo)) + assert(valid_halo_communicator(halo)) + assert(.not. pending_communication(halo)) - nprocs = halo_proc_count(halo) + nprocs = halo_proc_count(halo) - ! Read nsends from the halo - allocate(nsends(nprocs)) - call halo_send_counts(halo, nsends) + ! Read nsends from the halo + allocate(nsends(nprocs)) + call halo_send_counts(halo, nsends) - ! Read nsends from other processes and assemble onto communcated_nreceives - allocate(communicated_nreceives(nprocs)) - call mpi_alltoall(nsends, 1, getpinteger(), communicated_nreceives, 1, getpinteger(), halo_communicator(halo), ierr) - assert(ierr == MPI_SUCCESS) - deallocate(nsends) + ! Read nsends from other processes and assemble onto communcated_nreceives + allocate(communicated_nreceives(nprocs)) + call mpi_alltoall(nsends, 1, getpinteger(), communicated_nreceives, 1, getpinteger(), halo_communicator(halo), ierr) + assert(ierr == MPI_SUCCESS) + deallocate(nsends) - ! Check that the communicated nreceives is consistent with that that read - ! from the halo - allocate(nreceives(nprocs)) - call halo_receive_counts(halo, nreceives) + ! Check that the communicated nreceives is consistent with that that read + ! from the halo + allocate(nreceives(nprocs)) + call halo_receive_counts(halo, nreceives) - valid = all(nreceives == communicated_nreceives) - if(.not. valid) then - ewrite(2, *) "Invalid halo node counts" - end if + valid = all(nreceives == communicated_nreceives) + if(.not. valid) then + ewrite(2, *) "Invalid halo node counts" + end if - deallocate(nreceives) - deallocate(communicated_nreceives) + deallocate(nreceives) + deallocate(communicated_nreceives) #else - valid = valid_serial_halo(halo) + valid = valid_serial_halo(halo) #endif - end function valid_halo_node_counts + end function valid_halo_node_counts - function receive_nodes_unique(halo) result(unique) - !!< Return whether the receive nodes in the supplied halo are unique + function receive_nodes_unique(halo) result(unique) + !!< Return whether the receive nodes in the supplied halo are unique - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: unique + logical :: unique - unique = (halo_all_unique_receives_count(halo) == halo_all_receives_count(halo)) + unique = (halo_all_unique_receives_count(halo) == halo_all_receives_count(halo)) - end function receive_nodes_unique + end function receive_nodes_unique - function halo_valid_for_communication(halo) result(valid) - !!< Return whether the supplied halo is valid for data communication. + function halo_valid_for_communication(halo) result(valid) + !!< Return whether the supplied halo is valid for data communication. - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: valid + logical :: valid - if(.not. valid_halo_communicator(halo)) then - ewrite(0, *) "Invalid communicator" - valid = .false. - else if(.not. valid_halo_node_counts(halo)) then - ewrite(0, *) "Invalid halo node counts" - valid = .false. - else - valid = .true. - end if + if(.not. valid_halo_communicator(halo)) then + ewrite(0, *) "Invalid communicator" + valid = .false. + else if(.not. valid_halo_node_counts(halo)) then + ewrite(0, *) "Invalid halo node counts" + valid = .false. + else + valid = .true. + end if - end function halo_valid_for_communication + end function halo_valid_for_communication - function trailing_receives_consistent(halo) result(consistent) - !!< Return whether the supplied halo is consistent with trailing receives - !!< ordering + function trailing_receives_consistent(halo) result(consistent) + !!< Return whether the supplied halo is consistent with trailing receives + !!< ordering - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: consistent + logical :: consistent - ewrite(1, *) "Checking nodes in halo " // halo_name(halo) // " for consistency with trailing receive ordering" + ewrite(1, *) "Checking nodes in halo " // halo_name(halo) // " for consistency with trailing receive ordering" - if(.not. has_nowned_nodes(halo)) then - ewrite(1, *) "Owned nodes not set" - consistent = .false. - else if(max_halo_send_node(halo) > halo_nowned_nodes(halo)) then - ewrite(1, *) "Not all send nodes are owned" - consistent = .false. - else if(halo_all_receives_count(halo) == 0) then - consistent = .true. - else if(min_halo_receive_node(halo) <= halo_nowned_nodes(halo)) then - ewrite(1, *) "At least one receive node is owned" - consistent = .false. - else if(.not. receive_nodes_unique(halo)) then - ewrite(1, *) "Receive nodes are not unique" - consistent = .false. - else if(max_halo_receive_node(halo) /= node_count(halo)) then - ewrite(1, *) "Not all non-owned nodes are receive nodes" - consistent = .false. - else - consistent = .true. - end if + if(.not. has_nowned_nodes(halo)) then + ewrite(1, *) "Owned nodes not set" + consistent = .false. + else if(max_halo_send_node(halo) > halo_nowned_nodes(halo)) then + ewrite(1, *) "Not all send nodes are owned" + consistent = .false. + else if(halo_all_receives_count(halo) == 0) then + consistent = .true. + else if(min_halo_receive_node(halo) <= halo_nowned_nodes(halo)) then + ewrite(1, *) "At least one receive node is owned" + consistent = .false. + else if(.not. receive_nodes_unique(halo)) then + ewrite(1, *) "Receive nodes are not unique" + consistent = .false. + else if(max_halo_receive_node(halo) /= node_count(halo)) then + ewrite(1, *) "Not all non-owned nodes are receive nodes" + consistent = .false. + else + consistent = .true. + end if - call alland(consistent, communicator = halo_communicator(halo)) + call alland(consistent, communicator = halo_communicator(halo)) - if(consistent) then - ewrite(1, *) "Halo nodes are consistent with trailing receive ordering" - else - ewrite(1, *) "Halo nodes are not consistent with trailing receive ordering" - end if + if(consistent) then + ewrite(1, *) "Halo nodes are consistent with trailing receive ordering" + else + ewrite(1, *) "Halo nodes are not consistent with trailing receive ordering" + end if - end function trailing_receives_consistent + end function trailing_receives_consistent - subroutine print_halo(halo, priority) - type(halo_type), intent(in) :: halo - integer, intent(in) :: priority + subroutine print_halo(halo, priority) + type(halo_type), intent(in) :: halo + integer, intent(in) :: priority - integer :: i + integer :: i - ewrite(priority,*) "Halo name: ", halo_name(halo) - ewrite(priority,*) "Owned nodes: ", halo_nowned_nodes(halo) + ewrite(priority,*) "Halo name: ", halo_name(halo) + ewrite(priority,*) "Owned nodes: ", halo_nowned_nodes(halo) - do i = 1, halo_proc_count(halo) - ewrite(priority,*) "Sends to process ", i - ewrite(priority,*) halo_sends(halo, i) - end do + do i = 1, halo_proc_count(halo) + ewrite(priority,*) "Sends to process ", i + ewrite(priority,*) halo_sends(halo, i) + end do - do i = 1, halo_proc_count(halo) - ewrite(priority,*) "Receives from process ", i - ewrite(priority,*) halo_receives(halo, i) - end do + do i = 1, halo_proc_count(halo) + ewrite(priority,*) "Receives from process ", i + ewrite(priority,*) halo_receives(halo, i) + end do - end subroutine print_halo + end subroutine print_halo end module halos_debug diff --git a/femtools/Halos_Derivation.F90 b/femtools/Halos_Derivation.F90 index 08da5d491d..2673d1b209 100644 --- a/femtools/Halos_Derivation.F90 +++ b/femtools/Halos_Derivation.F90 @@ -48,132 +48,132 @@ module halos_derivation use fields_allocates use fields_manipulation #ifdef HAVE_ZOLTAN - use zoltan + use zoltan #endif - implicit none + implicit none - private + private - public :: derive_l1_from_l2_halo, derive_element_halo_from_node_halo, & - & derive_maximal_surface_element_halo, derive_nonperiodic_halos_from_periodic_halos, derive_sub_halo - public :: invert_comms_sizes, ele_owner, combine_halos, create_combined_numbering_trailing_receives - public :: expand_positions_halo, generate_surface_mesh_halos + public :: derive_l1_from_l2_halo, derive_element_halo_from_node_halo, & + & derive_maximal_surface_element_halo, derive_nonperiodic_halos_from_periodic_halos, derive_sub_halo + public :: invert_comms_sizes, ele_owner, combine_halos, create_combined_numbering_trailing_receives + public :: expand_positions_halo, generate_surface_mesh_halos - interface derive_l1_from_l2_halo - module procedure derive_l1_from_l2_halo_mesh - end interface + interface derive_l1_from_l2_halo + module procedure derive_l1_from_l2_halo_mesh + end interface - interface derive_element_halos_from_l2_halo - module procedure derive_element_halos_from_l2_halo_mesh, & + interface derive_element_halos_from_l2_halo + module procedure derive_element_halos_from_l2_halo_mesh, & & derive_element_halos_from_l2_halo_halo - end interface derive_element_halos_from_l2_halo + end interface derive_element_halos_from_l2_halo contains - subroutine derive_l1_from_l2_halo_mesh(mesh, ordering_scheme, create_caches) - !!< For the supplied mesh, generate a level 1 node halo from the level 2 - !!< node halo + subroutine derive_l1_from_l2_halo_mesh(mesh, ordering_scheme, create_caches) + !!< For the supplied mesh, generate a level 1 node halo from the level 2 + !!< node halo - type(mesh_type), intent(inout) :: mesh - !! By default the l1 halo will inherit it's ordering scheme from the l2 - !! halo. Supply this to override. - integer, optional, intent(in) :: ordering_scheme - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches + type(mesh_type), intent(inout) :: mesh + !! By default the l1 halo will inherit it's ordering scheme from the l2 + !! halo. Supply this to override. + integer, optional, intent(in) :: ordering_scheme + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches - assert(halo_count(mesh) >= 2) - assert(.not. has_references(mesh%halos(1))) - assert(has_references(mesh%halos(2))) + assert(halo_count(mesh) >= 2) + assert(.not. has_references(mesh%halos(1))) + assert(has_references(mesh%halos(2))) - mesh%halos(1) = derive_l1_from_l2_halo_halo(mesh, mesh%halos(2), & + mesh%halos(1) = derive_l1_from_l2_halo_halo(mesh, mesh%halos(2), & & ordering_scheme = ordering_scheme, create_caches = create_caches) - end subroutine derive_l1_from_l2_halo_mesh - - function derive_l1_from_l2_halo_halo(mesh, l2_halo, ordering_scheme, create_caches) result(l1_halo) - !!< Given a level 2 node halo for the supplied mesh, strip it down to form - !!< a level 1 node halo - - type(mesh_type), intent(in) :: mesh - type(halo_type), intent(in) :: l2_halo - !! By default the l1 halo will inherit it's ordering scheme from the l2 - !! halo. Supply this to override. - integer, optional, intent(in) :: ordering_scheme - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches - - type(halo_type) :: l1_halo - - integer :: i, j, k, l, lordering_scheme, nprocs, proc - integer, dimension(:), allocatable :: receive_paint - integer, dimension(:), pointer :: neigh - type(csr_sparsity), pointer :: nnlist - type(integer_set), dimension(:), allocatable :: send_paint, sends, receives - - assert(continuity(mesh) == 0) - assert(halo_data_type(l2_halo) == HALO_TYPE_CG_NODE) - assert(.not. serial_storage_halo(l2_halo)) - - if(present(ordering_scheme)) then - lordering_scheme = ordering_scheme - else - lordering_scheme = halo_ordering_scheme(l2_halo) - end if - - nprocs = halo_proc_count(l2_halo) - - ! Paint the sends and receives - allocate(send_paint(node_count(mesh))) - call allocate(send_paint) - allocate(receive_paint(node_count(mesh))) - receive_paint = 0 - do i = 1, nprocs - do j = 1, halo_send_count(l2_halo, i) - call insert(send_paint(halo_send(l2_halo, i, j)), i) - end do - receive_paint(halo_receives(l2_halo, i)) = i - end do - - ! Walk the nnlist from the sends and receives in l2. If we hit a l2 send - ! one adjacency from a l2 receive, then we have a l1 send. If we hit a l2 - ! receive for process n one adjacency from a l2 send for process n, then we - ! have a l1 receive for process n. - nnlist => extract_nnlist(mesh) - allocate(sends(nprocs)) - call allocate(sends) - allocate(receives(nprocs)) - call allocate(receives) - do i = 1, nprocs - do j = 1, halo_send_count(l2_halo, i) - neigh => row_m_ptr(nnlist, halo_send(l2_halo, i, j)) - do k = 1, size(neigh) - proc = receive_paint(neigh(k)) - if(proc > 0) then - call insert(receives(proc), neigh(k)) - end if - end do + end subroutine derive_l1_from_l2_halo_mesh + + function derive_l1_from_l2_halo_halo(mesh, l2_halo, ordering_scheme, create_caches) result(l1_halo) + !!< Given a level 2 node halo for the supplied mesh, strip it down to form + !!< a level 1 node halo + + type(mesh_type), intent(in) :: mesh + type(halo_type), intent(in) :: l2_halo + !! By default the l1 halo will inherit it's ordering scheme from the l2 + !! halo. Supply this to override. + integer, optional, intent(in) :: ordering_scheme + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches + + type(halo_type) :: l1_halo + + integer :: i, j, k, l, lordering_scheme, nprocs, proc + integer, dimension(:), allocatable :: receive_paint + integer, dimension(:), pointer :: neigh + type(csr_sparsity), pointer :: nnlist + type(integer_set), dimension(:), allocatable :: send_paint, sends, receives + + assert(continuity(mesh) == 0) + assert(halo_data_type(l2_halo) == HALO_TYPE_CG_NODE) + assert(.not. serial_storage_halo(l2_halo)) + + if(present(ordering_scheme)) then + lordering_scheme = ordering_scheme + else + lordering_scheme = halo_ordering_scheme(l2_halo) + end if + + nprocs = halo_proc_count(l2_halo) + + ! Paint the sends and receives + allocate(send_paint(node_count(mesh))) + call allocate(send_paint) + allocate(receive_paint(node_count(mesh))) + receive_paint = 0 + do i = 1, nprocs + do j = 1, halo_send_count(l2_halo, i) + call insert(send_paint(halo_send(l2_halo, i, j)), i) + end do + receive_paint(halo_receives(l2_halo, i)) = i end do - do j = 1, halo_receive_count(l2_halo, i) - neigh => row_m_ptr(nnlist, halo_receive(l2_halo, i, j)) - do k = 1, size(neigh) - do l = 1, key_count(send_paint(neigh(k))) - proc = fetch(send_paint(neigh(k)), l) - if(proc == i) then - call insert(sends(proc), neigh(k)) - end if - end do - end do + ! Walk the nnlist from the sends and receives in l2. If we hit a l2 send + ! one adjacency from a l2 receive, then we have a l1 send. If we hit a l2 + ! receive for process n one adjacency from a l2 send for process n, then we + ! have a l1 receive for process n. + nnlist => extract_nnlist(mesh) + allocate(sends(nprocs)) + call allocate(sends) + allocate(receives(nprocs)) + call allocate(receives) + do i = 1, nprocs + do j = 1, halo_send_count(l2_halo, i) + neigh => row_m_ptr(nnlist, halo_send(l2_halo, i, j)) + do k = 1, size(neigh) + proc = receive_paint(neigh(k)) + if(proc > 0) then + call insert(receives(proc), neigh(k)) + end if + end do + end do + + do j = 1, halo_receive_count(l2_halo, i) + neigh => row_m_ptr(nnlist, halo_receive(l2_halo, i, j)) + do k = 1, size(neigh) + do l = 1, key_count(send_paint(neigh(k))) + proc = fetch(send_paint(neigh(k)), l) + if(proc == i) then + call insert(sends(proc), neigh(k)) + end if + end do + end do + end do end do - end do - call deallocate(send_paint) - deallocate(send_paint) - deallocate(receive_paint) + call deallocate(send_paint) + deallocate(send_paint) + deallocate(receive_paint) - ! Generate the l1 halo from the sends and receives sets + ! Generate the l1 halo from the sends and receives sets - call allocate(l1_halo, & + call allocate(l1_halo, & & nsends = key_count(sends), & & nreceives = key_count(receives), & & name = trim(mesh%name) // "Level1Halo", & @@ -182,113 +182,113 @@ function derive_l1_from_l2_halo_halo(mesh, l2_halo, ordering_scheme, create_cach & data_type = HALO_TYPE_CG_NODE, & & ordering_scheme = lordering_scheme) - assert(valid_halo_node_counts(l1_halo)) + assert(valid_halo_node_counts(l1_halo)) - do i = 1, nprocs - call set_halo_sends(l1_halo, i, set2vector(sends(i))) - call deallocate(sends(i)) + do i = 1, nprocs + call set_halo_sends(l1_halo, i, set2vector(sends(i))) + call deallocate(sends(i)) - call set_halo_receives(l1_halo, i, set2vector(receives(i))) - call deallocate(receives(i)) - end do - deallocate(sends) - deallocate(receives) + call set_halo_receives(l1_halo, i, set2vector(receives(i))) + call deallocate(receives(i)) + end do + deallocate(sends) + deallocate(receives) - call reorder_l1_from_l2_halo(l1_halo, l2_halo, sorted_l1_halo = .true.) + call reorder_l1_from_l2_halo(l1_halo, l2_halo, sorted_l1_halo = .true.) #ifdef DDEBUG - if(halo_ordering_scheme(l1_halo) == HALO_ORDER_TRAILING_RECEIVES) then - assert(trailing_receives_consistent(l1_halo)) - end if + if(halo_ordering_scheme(l1_halo) == HALO_ORDER_TRAILING_RECEIVES) then + assert(trailing_receives_consistent(l1_halo)) + end if #endif - if(.not. present_and_false(create_caches)) then - ! Create caches - call create_global_to_universal_numbering(l1_halo) - call create_ownership(l1_halo) - end if + if(.not. present_and_false(create_caches)) then + ! Create caches + call create_global_to_universal_numbering(l1_halo) + call create_ownership(l1_halo) + end if - end function derive_l1_from_l2_halo_halo + end function derive_l1_from_l2_halo_halo - subroutine derive_element_halo_from_node_halo(mesh, ordering_scheme, create_caches) - !!< For the supplied mesh, generate element halos from the level 2 node halo + subroutine derive_element_halo_from_node_halo(mesh, ordering_scheme, create_caches) + !!< For the supplied mesh, generate element halos from the level 2 node halo - type(mesh_type), intent(inout) :: mesh - !! By default the element halos will have a HALO_ORDER_GENERAL ordering - !! scheme. Supply this to override. - integer, optional, intent(in) :: ordering_scheme - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches + type(mesh_type), intent(inout) :: mesh + !! By default the element halos will have a HALO_ORDER_GENERAL ordering + !! scheme. Supply this to override. + integer, optional, intent(in) :: ordering_scheme + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches #ifdef DDEBUG - integer :: i - - assert(halo_count(mesh) > 0) - assert(has_references(mesh%halos(halo_count(mesh)))) - assert(element_halo_count(mesh) <= 2) - do i = 1, element_halo_count(mesh) - assert(.not. has_references(mesh%element_halos(i))) - end do + integer :: i + + assert(halo_count(mesh) > 0) + assert(has_references(mesh%halos(halo_count(mesh)))) + assert(element_halo_count(mesh) <= 2) + do i = 1, element_halo_count(mesh) + assert(.not. has_references(mesh%element_halos(i))) + end do #endif - mesh%element_halos(1) = derive_maximal_element_halo(mesh, mesh%halos(halo_count(mesh)), & + mesh%element_halos(1) = derive_maximal_element_halo(mesh, mesh%halos(halo_count(mesh)), & & ordering_scheme = ordering_scheme, create_caches = create_caches) - if(element_halo_count(mesh) > 1) then - mesh%element_halos(2) = mesh%element_halos(1) - call incref(mesh%element_halos(2)) - end if + if(element_halo_count(mesh) > 1) then + mesh%element_halos(2) = mesh%element_halos(1) + call incref(mesh%element_halos(2)) + end if - end subroutine derive_element_halo_from_node_halo + end subroutine derive_element_halo_from_node_halo - function derive_maximal_element_halo(mesh, node_halo, ordering_scheme, create_caches) result(element_halo) - !!< Given a node halo for the supplied mesh, derive the maximal element halo + function derive_maximal_element_halo(mesh, node_halo, ordering_scheme, create_caches) result(element_halo) + !!< Given a node halo for the supplied mesh, derive the maximal element halo - type(mesh_type), intent(in) :: mesh - type(halo_type), intent(in) :: node_halo - !! By default the maximal element halo will have a HALO_ORDER_GENERAL - !! ordering scheme. Supply this to override. - integer, optional, intent(in) :: ordering_scheme - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches + type(mesh_type), intent(in) :: mesh + type(halo_type), intent(in) :: node_halo + !! By default the maximal element halo will have a HALO_ORDER_GENERAL + !! ordering scheme. Supply this to override. + integer, optional, intent(in) :: ordering_scheme + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches - type(halo_type) :: element_halo + type(halo_type) :: element_halo - integer :: communicator, i, lordering_scheme, nowned_eles, nprocs, & + integer :: communicator, i, lordering_scheme, nowned_eles, nprocs, & & owner, procno - type(integer_set), dimension(:), allocatable :: receives + type(integer_set), dimension(:), allocatable :: receives - ewrite(1, *) "In derive_maximal_element_halo" + ewrite(1, *) "In derive_maximal_element_halo" - assert(continuity(mesh) == 0) - assert(halo_data_type(node_halo) == HALO_TYPE_CG_NODE) - assert(.not. serial_storage_halo(node_halo)) + assert(continuity(mesh) == 0) + assert(halo_data_type(node_halo) == HALO_TYPE_CG_NODE) + assert(.not. serial_storage_halo(node_halo)) - if(present(ordering_scheme)) then - lordering_scheme = ordering_scheme - else - lordering_scheme = HALO_ORDER_GENERAL - end if + if(present(ordering_scheme)) then + lordering_scheme = ordering_scheme + else + lordering_scheme = HALO_ORDER_GENERAL + end if - communicator = halo_communicator(node_halo) - nprocs = halo_proc_count(node_halo) - procno = getprocno(communicator = communicator) + communicator = halo_communicator(node_halo) + nprocs = halo_proc_count(node_halo) + procno = getprocno(communicator = communicator) - ! Step 1: Generate the maximal set of receives + ! Step 1: Generate the maximal set of receives - allocate(receives(nprocs)) - call allocate(receives) - do i = 1, ele_count(mesh) - owner = ele_owner(i, mesh, node_halo) - if(owner /= procno) call insert(receives(owner), i) - end do - ewrite(2, *) "Maximal receive elements: ", sum(key_count(receives)) + allocate(receives(nprocs)) + call allocate(receives) + do i = 1, ele_count(mesh) + owner = ele_owner(i, mesh, node_halo) + if(owner /= procno) call insert(receives(owner), i) + end do + ewrite(2, *) "Maximal receive elements: ", sum(key_count(receives)) - nowned_eles = ele_count(mesh) - sum(key_count(receives)) - ewrite(2, *) "Owned elements: ", nowned_eles + nowned_eles = ele_count(mesh) - sum(key_count(receives)) + ewrite(2, *) "Owned elements: ", nowned_eles - ! Step 2: Allocate the halo and set the receives + ! Step 2: Allocate the halo and set the receives - call allocate(element_halo, & + call allocate(element_halo, & & nsends = spread(0, 1, nprocs), & & nreceives = key_count(receives), & & name = trim(mesh%name) // "MaximalElementHalo", & @@ -297,80 +297,80 @@ function derive_maximal_element_halo(mesh, node_halo, ordering_scheme, create_ca & data_type = HALO_TYPE_ELEMENT, & & ordering_scheme = lordering_scheme) - do i = 1, nprocs - call set_halo_receives(element_halo, i, set2vector(receives(i))) - call deallocate(receives(i)) - end do - deallocate(receives) + do i = 1, nprocs + call set_halo_receives(element_halo, i, set2vector(receives(i))) + call deallocate(receives(i)) + end do + deallocate(receives) - ! Step 3: Invert the receives to form the sends - call invert_element_halo_receives(mesh, node_halo, element_halo) + ! Step 3: Invert the receives to form the sends + call invert_element_halo_receives(mesh, node_halo, element_halo) #ifdef DDEBUG - if(halo_ordering_scheme(element_halo) == HALO_ORDER_TRAILING_RECEIVES) then - assert(trailing_receives_consistent(element_halo)) - end if + if(halo_ordering_scheme(element_halo) == HALO_ORDER_TRAILING_RECEIVES) then + assert(trailing_receives_consistent(element_halo)) + end if #endif - if(.not. present_and_false(create_caches)) then - call create_global_to_universal_numbering(element_halo) - call create_ownership(element_halo) - end if + if(.not. present_and_false(create_caches)) then + call create_global_to_universal_numbering(element_halo) + call create_ownership(element_halo) + end if - ewrite(1, *) "Exiting derive_maximal_element_halo" + ewrite(1, *) "Exiting derive_maximal_element_halo" - end function derive_maximal_element_halo + end function derive_maximal_element_halo - function derive_maximal_surface_element_halo(mesh, element_halo, ordering_scheme, create_caches) result(selement_halo) - !!< Given an element halo for the supplied mesh, derive the maximal surface - !!< element halo + function derive_maximal_surface_element_halo(mesh, element_halo, ordering_scheme, create_caches) result(selement_halo) + !!< Given an element halo for the supplied mesh, derive the maximal surface + !!< element halo - type(mesh_type), intent(inout) :: mesh - type(halo_type), intent(in) :: element_halo - !! By default the maximal surface element halo will have a - !! HALO_ORDER_GENERAL ordering scheme. Supply this to override. - integer, optional, intent(in) :: ordering_scheme - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches + type(mesh_type), intent(inout) :: mesh + type(halo_type), intent(in) :: element_halo + !! By default the maximal surface element halo will have a + !! HALO_ORDER_GENERAL ordering scheme. Supply this to override. + integer, optional, intent(in) :: ordering_scheme + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches - type(halo_type) :: selement_halo + type(halo_type) :: selement_halo - integer :: communicator, i, lordering_scheme, nowned_eles, nprocs, & + integer :: communicator, i, lordering_scheme, nowned_eles, nprocs, & & owner, procno - type(integer_set), dimension(:), allocatable :: receives + type(integer_set), dimension(:), allocatable :: receives - ewrite(1, *) "In derive_maximal_surface_element_halo" + ewrite(1, *) "In derive_maximal_surface_element_halo" - assert(continuity(mesh) == 0) - assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) - assert(.not. serial_storage_halo(element_halo)) + assert(continuity(mesh) == 0) + assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) + assert(.not. serial_storage_halo(element_halo)) - if(present(ordering_scheme)) then - lordering_scheme = ordering_scheme - else - lordering_scheme = HALO_ORDER_GENERAL - end if + if(present(ordering_scheme)) then + lordering_scheme = ordering_scheme + else + lordering_scheme = HALO_ORDER_GENERAL + end if - communicator = halo_communicator(element_halo) - nprocs = halo_proc_count(element_halo) - procno = getprocno(communicator = communicator) + communicator = halo_communicator(element_halo) + nprocs = halo_proc_count(element_halo) + procno = getprocno(communicator = communicator) - ! Step 1: Generate the maximal set of receives + ! Step 1: Generate the maximal set of receives - allocate(receives(nprocs)) - call allocate(receives) - do i = 1, surface_element_count(mesh) - owner = halo_node_owner(element_halo, face_ele(mesh, i)) - if(owner /= procno) call insert(receives(owner), i) - end do - ewrite(2, *) "Maximal receive elements: ", sum(key_count(receives)) + allocate(receives(nprocs)) + call allocate(receives) + do i = 1, surface_element_count(mesh) + owner = halo_node_owner(element_halo, face_ele(mesh, i)) + if(owner /= procno) call insert(receives(owner), i) + end do + ewrite(2, *) "Maximal receive elements: ", sum(key_count(receives)) - nowned_eles = surface_element_count(mesh) - sum(key_count(receives)) - ewrite(2, *) "Owned elements: ", nowned_eles + nowned_eles = surface_element_count(mesh) - sum(key_count(receives)) + ewrite(2, *) "Owned elements: ", nowned_eles - ! Step 2: Allocate the halo and set the receives + ! Step 2: Allocate the halo and set the receives - call allocate(selement_halo, & + call allocate(selement_halo, & & nsends = spread(0, 1, nprocs), & & nreceives = key_count(receives), & & name = trim(mesh%name) // "MaximalSurfaceElementHalo", & @@ -379,182 +379,182 @@ function derive_maximal_surface_element_halo(mesh, element_halo, ordering_scheme & data_type = HALO_TYPE_ELEMENT, & & ordering_scheme = lordering_scheme) - do i = 1, nprocs - call set_halo_receives(selement_halo, i, set2vector(receives(i))) - call deallocate(receives(i)) - end do - deallocate(receives) + do i = 1, nprocs + call set_halo_receives(selement_halo, i, set2vector(receives(i))) + call deallocate(receives(i)) + end do + deallocate(receives) - ! Step 3: Invert the receives to form the sends - call invert_surface_element_halo_receives(mesh, element_halo, selement_halo) + ! Step 3: Invert the receives to form the sends + call invert_surface_element_halo_receives(mesh, element_halo, selement_halo) #ifdef DDEBUG - if(halo_ordering_scheme(selement_halo) == HALO_ORDER_TRAILING_RECEIVES) then - assert(trailing_receives_consistent(selement_halo)) - end if + if(halo_ordering_scheme(selement_halo) == HALO_ORDER_TRAILING_RECEIVES) then + assert(trailing_receives_consistent(selement_halo)) + end if #endif - if(.not. present_and_false(create_caches)) then - call create_global_to_universal_numbering(selement_halo) - call create_ownership(selement_halo) - end if + if(.not. present_and_false(create_caches)) then + call create_global_to_universal_numbering(selement_halo) + call create_ownership(selement_halo) + end if - ewrite(1, *) "Exiting derive_maximal_surface_element_halo" + ewrite(1, *) "Exiting derive_maximal_surface_element_halo" - end function derive_maximal_surface_element_halo + end function derive_maximal_surface_element_halo - subroutine derive_element_halos_from_l2_halo_mesh(mesh, create_caches) - !!< For the supplied mesh, generate element halos from the level 2 node - !!< halo + subroutine derive_element_halos_from_l2_halo_mesh(mesh, create_caches) + !!< For the supplied mesh, generate element halos from the level 2 node + !!< halo - type(mesh_type), intent(inout) :: mesh - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches + type(mesh_type), intent(inout) :: mesh + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches #ifdef DDEBUG - assert(halo_count(mesh) >= 2) - assert(has_references(mesh%halos(2))) - assert(element_halo_count(mesh) >= 2) - assert(.not. has_references(mesh%element_halos(1))) - assert(.not. has_references(mesh%element_halos(2))) + assert(halo_count(mesh) >= 2) + assert(has_references(mesh%halos(2))) + assert(element_halo_count(mesh) >= 2) + assert(.not. has_references(mesh%element_halos(1))) + assert(.not. has_references(mesh%element_halos(2))) #endif - call derive_element_halos_from_l2_halo(mesh, mesh%halos(2), mesh%element_halos(:2), & + call derive_element_halos_from_l2_halo(mesh, mesh%halos(2), mesh%element_halos(:2), & & create_caches = create_caches) - end subroutine derive_element_halos_from_l2_halo_mesh - - subroutine derive_element_halos_from_l2_halo_halo(mesh, l2_halo, element_halos, ordering_scheme, create_caches) - !!< Given a level 2 node halo for the supplied mesh, derive element halos. - !!< We do this by: - !!< 1. Determining which elements we don't own, and who does own them, to - !!< generate a maximum set of receives - !!< 2. Walking the eelist from the maximum set of receives to form the l1 - !!< and l2 sends - !!< 3. Walking the eelist from the l1 sends to form the l1 and l2 receives - - type(mesh_type), intent(in) :: mesh - type(halo_type), intent(in) :: l2_halo - type(halo_type), dimension(2), intent(out) :: element_halos - !! By default the element halos will have HALO_ORDER_GENERAL - !! ordering schemes. Supply this to override. - integer, optional, intent(in) :: ordering_scheme - !! If present and .false., do not create halo caches - logical, optional, intent(in) :: create_caches - - integer :: communicator, ele1, ele2, ele3, i, j, k, l, lordering_scheme, & + end subroutine derive_element_halos_from_l2_halo_mesh + + subroutine derive_element_halos_from_l2_halo_halo(mesh, l2_halo, element_halos, ordering_scheme, create_caches) + !!< Given a level 2 node halo for the supplied mesh, derive element halos. + !!< We do this by: + !!< 1. Determining which elements we don't own, and who does own them, to + !!< generate a maximum set of receives + !!< 2. Walking the eelist from the maximum set of receives to form the l1 + !!< and l2 sends + !!< 3. Walking the eelist from the l1 sends to form the l1 and l2 receives + + type(mesh_type), intent(in) :: mesh + type(halo_type), intent(in) :: l2_halo + type(halo_type), dimension(2), intent(out) :: element_halos + !! By default the element halos will have HALO_ORDER_GENERAL + !! ordering schemes. Supply this to override. + integer, optional, intent(in) :: ordering_scheme + !! If present and .false., do not create halo caches + logical, optional, intent(in) :: create_caches + + integer :: communicator, ele1, ele2, ele3, i, j, k, l, lordering_scheme, & & nowned_eles, nprocs, owner, procno - integer, dimension(:), pointer :: neigh1, neigh2 - type(csr_sparsity), pointer :: eelist - type(integer_set), dimension(:), allocatable :: l1_receives, l1_sends, & + integer, dimension(:), pointer :: neigh1, neigh2 + type(csr_sparsity), pointer :: eelist + type(integer_set), dimension(:), allocatable :: l1_receives, l1_sends, & & l2_receives, l2_sends - ewrite(1, *) "In derive_element_halos_from_l2_halo_halo" - - assert(continuity(mesh) == 0) - assert(halo_data_type(l2_halo) == HALO_TYPE_CG_NODE) - assert(.not. serial_storage_halo(l2_halo)) - - if(present(ordering_scheme)) then - lordering_scheme = ordering_scheme - else - lordering_scheme = HALO_ORDER_GENERAL - end if - - communicator = halo_communicator(l2_halo) - nprocs = halo_proc_count(l2_halo) - procno = getprocno(communicator = communicator) - - ! Step 1: Generate the ownership boundary (stored as the maximum set of - ! receives) - - allocate(l2_receives(nprocs)) - call allocate(l2_receives) - do i = 1, ele_count(mesh) - owner = ele_owner(i, mesh, l2_halo) - if(owner /= procno) call insert(l2_receives(owner), i) - end do - - ! l2_receives is now a superset of the l2 element halo receives - ! This gives us the number of owned elements: - nowned_eles = ele_count(mesh) - sum(key_count(l2_receives)) - ewrite(2, *) "Owned elements: ", nowned_eles - - ! Step 2: Walk the eelist from the element ownership boundary to generate - ! the send elements - - eelist => extract_eelist(mesh) - - allocate(l1_sends(nprocs)) - call allocate(l1_sends) - allocate(l2_sends(nprocs)) - call allocate(l2_sends) - do i = 1, nprocs - do j = 1, key_count(l2_receives(i)) - ele1 = fetch(l2_receives(i), j) - neigh1 => row_m_ptr(eelist, ele1) - do k = 1, size(neigh1) - ele2 = neigh1(k) - if(ele2 <= 0) cycle - if(ele_owner(ele2, mesh, l2_halo) /= procno) cycle - - ! This is a level 1 send element - call insert(l1_sends(i), ele2) - call insert(l2_sends(i), ele2) - - neigh2 => row_m_ptr(eelist, ele2) - do l = 1, size(neigh2) - ele3 = neigh2(l) - if(ele3 <= 0) cycle - if(ele_owner(ele3, mesh, l2_halo) /= procno) cycle - - ! This is a level 2 send element - call insert(l2_sends(i), ele3) - end do - end do + ewrite(1, *) "In derive_element_halos_from_l2_halo_halo" + + assert(continuity(mesh) == 0) + assert(halo_data_type(l2_halo) == HALO_TYPE_CG_NODE) + assert(.not. serial_storage_halo(l2_halo)) + + if(present(ordering_scheme)) then + lordering_scheme = ordering_scheme + else + lordering_scheme = HALO_ORDER_GENERAL + end if + + communicator = halo_communicator(l2_halo) + nprocs = halo_proc_count(l2_halo) + procno = getprocno(communicator = communicator) + + ! Step 1: Generate the ownership boundary (stored as the maximum set of + ! receives) + + allocate(l2_receives(nprocs)) + call allocate(l2_receives) + do i = 1, ele_count(mesh) + owner = ele_owner(i, mesh, l2_halo) + if(owner /= procno) call insert(l2_receives(owner), i) end do - end do - call deallocate(l2_receives) - ewrite(2, *) "Level 1 send elements: ", sum(key_count(l1_sends)) - ewrite(2, *) "Level 2 send elements: ", sum(key_count(l2_sends)) - - ! Step 3: Walk the eelist from the l1 send elements to generate the receive - ! elements - - allocate(l1_receives(nprocs)) - call allocate(l1_receives) - call allocate(l2_receives) - do i = 1, nprocs - do j = 1, key_count(l1_sends(i)) - ele1 = fetch(l1_sends(i), j) - neigh1 => row_m_ptr(eelist, ele1) - do k = 1, size(neigh1) - ele2 = neigh1(k) - if(ele2 <= 0) cycle - if(ele_owner(ele2, mesh, l2_halo) /= i) cycle - - ! This is a level 1 receive element - call insert(l1_receives(i), ele2) - call insert(l2_receives(i), ele2) - - neigh2 => row_m_ptr(eelist, ele2) - do l = 1, size(neigh2) - ele3 = neigh2(l) - if(ele3 <= 0) cycle - if(ele_owner(ele3, mesh, l2_halo) /= i) cycle - - ! This is a level 2 receive element - call insert(l2_receives(i), ele3) - end do - end do + + ! l2_receives is now a superset of the l2 element halo receives + ! This gives us the number of owned elements: + nowned_eles = ele_count(mesh) - sum(key_count(l2_receives)) + ewrite(2, *) "Owned elements: ", nowned_eles + + ! Step 2: Walk the eelist from the element ownership boundary to generate + ! the send elements + + eelist => extract_eelist(mesh) + + allocate(l1_sends(nprocs)) + call allocate(l1_sends) + allocate(l2_sends(nprocs)) + call allocate(l2_sends) + do i = 1, nprocs + do j = 1, key_count(l2_receives(i)) + ele1 = fetch(l2_receives(i), j) + neigh1 => row_m_ptr(eelist, ele1) + do k = 1, size(neigh1) + ele2 = neigh1(k) + if(ele2 <= 0) cycle + if(ele_owner(ele2, mesh, l2_halo) /= procno) cycle + + ! This is a level 1 send element + call insert(l1_sends(i), ele2) + call insert(l2_sends(i), ele2) + + neigh2 => row_m_ptr(eelist, ele2) + do l = 1, size(neigh2) + ele3 = neigh2(l) + if(ele3 <= 0) cycle + if(ele_owner(ele3, mesh, l2_halo) /= procno) cycle + + ! This is a level 2 send element + call insert(l2_sends(i), ele3) + end do + end do + end do + end do + call deallocate(l2_receives) + ewrite(2, *) "Level 1 send elements: ", sum(key_count(l1_sends)) + ewrite(2, *) "Level 2 send elements: ", sum(key_count(l2_sends)) + + ! Step 3: Walk the eelist from the l1 send elements to generate the receive + ! elements + + allocate(l1_receives(nprocs)) + call allocate(l1_receives) + call allocate(l2_receives) + do i = 1, nprocs + do j = 1, key_count(l1_sends(i)) + ele1 = fetch(l1_sends(i), j) + neigh1 => row_m_ptr(eelist, ele1) + do k = 1, size(neigh1) + ele2 = neigh1(k) + if(ele2 <= 0) cycle + if(ele_owner(ele2, mesh, l2_halo) /= i) cycle + + ! This is a level 1 receive element + call insert(l1_receives(i), ele2) + call insert(l2_receives(i), ele2) + + neigh2 => row_m_ptr(eelist, ele2) + do l = 1, size(neigh2) + ele3 = neigh2(l) + if(ele3 <= 0) cycle + if(ele_owner(ele3, mesh, l2_halo) /= i) cycle + + ! This is a level 2 receive element + call insert(l2_receives(i), ele3) + end do + end do + end do end do - end do - ewrite(2, *) "Level 1 receive elements: ", key_count(l1_receives) - ewrite(2, *) "Level 2 receive elements: ", key_count(l2_receives) + ewrite(2, *) "Level 1 receive elements: ", key_count(l1_receives) + ewrite(2, *) "Level 2 receive elements: ", key_count(l2_receives) - ! Step 4: Generate the element halos from the sends and receives sets + ! Step 4: Generate the element halos from the sends and receives sets - call allocate(element_halos(1), & + call allocate(element_halos(1), & & nsends = key_count(l1_sends), & & nreceives = key_count(l1_receives), & & name = trim(mesh%name) // "Level1ElementHalo", & @@ -563,7 +563,7 @@ subroutine derive_element_halos_from_l2_halo_halo(mesh, l2_halo, element_halos, & data_type = HALO_TYPE_ELEMENT, & & ordering_scheme = lordering_scheme) - call allocate(element_halos(2), & + call allocate(element_halos(2), & & nsends = key_count(l2_sends), & & nreceives = key_count(l2_receives), & & name = trim(mesh%name) // "Level2ElementHalo", & @@ -572,1496 +572,1496 @@ subroutine derive_element_halos_from_l2_halo_halo(mesh, l2_halo, element_halos, & data_type = HALO_TYPE_ELEMENT, & & ordering_scheme = lordering_scheme) - assert(valid_halo_node_counts(element_halos(1))) - assert(valid_halo_node_counts(element_halos(2))) + assert(valid_halo_node_counts(element_halos(1))) + assert(valid_halo_node_counts(element_halos(2))) - do i = 1, nprocs - call set_halo_sends(element_halos(1), i, set2vector(l1_sends(i))) - call deallocate(l1_sends(i)) + do i = 1, nprocs + call set_halo_sends(element_halos(1), i, set2vector(l1_sends(i))) + call deallocate(l1_sends(i)) - call set_halo_sends(element_halos(2), i, set2vector(l2_sends(i))) - call deallocate(l2_sends(i)) + call set_halo_sends(element_halos(2), i, set2vector(l2_sends(i))) + call deallocate(l2_sends(i)) - call set_halo_receives(element_halos(1), i, set2vector(l1_receives(i))) - call deallocate(l1_receives(i)) + call set_halo_receives(element_halos(1), i, set2vector(l1_receives(i))) + call deallocate(l1_receives(i)) - call set_halo_receives(element_halos(2), i, set2vector(l2_receives(i))) - call deallocate(l2_receives(i)) - end do - deallocate(l1_sends) - deallocate(l1_receives) - deallocate(l2_sends) - deallocate(l2_receives) - - call reorder_element_halo(element_halos(1), l2_halo, mesh) - call reorder_element_halo(element_halos(2), l2_halo, mesh) - - if(.not. present_and_false(create_caches)) then - ! Create caches - call create_global_to_universal_numbering(element_halos(1)) - call create_global_to_universal_numbering(element_halos(2)) - call create_ownership(element_halos(1)) - call create_ownership(element_halos(2)) - end if + call set_halo_receives(element_halos(2), i, set2vector(l2_receives(i))) + call deallocate(l2_receives(i)) + end do + deallocate(l1_sends) + deallocate(l1_receives) + deallocate(l2_sends) + deallocate(l2_receives) + + call reorder_element_halo(element_halos(1), l2_halo, mesh) + call reorder_element_halo(element_halos(2), l2_halo, mesh) + + if(.not. present_and_false(create_caches)) then + ! Create caches + call create_global_to_universal_numbering(element_halos(1)) + call create_global_to_universal_numbering(element_halos(2)) + call create_ownership(element_halos(1)) + call create_ownership(element_halos(2)) + end if - ewrite(1, *) "Exiting derive_element_halos_from_l2_halo_halo" + ewrite(1, *) "Exiting derive_element_halos_from_l2_halo_halo" - end subroutine derive_element_halos_from_l2_halo_halo + end subroutine derive_element_halos_from_l2_halo_halo - function ele_owner(ele, mesh, node_halo) - !!< Use the node halo node_halo, associated with mesh mesh, to determine a - !!< universally unique owner for element ele in mesh + function ele_owner(ele, mesh, node_halo) + !!< Use the node halo node_halo, associated with mesh mesh, to determine a + !!< universally unique owner for element ele in mesh - integer, intent(in) :: ele - type(mesh_type), intent(in) :: mesh - type(halo_type), intent(in) :: node_halo + integer, intent(in) :: ele + type(mesh_type), intent(in) :: mesh + type(halo_type), intent(in) :: node_halo - integer :: ele_owner + integer :: ele_owner - ele_owner = minval(halo_node_owners(node_halo, ele_nodes(mesh, ele))) - assert(ele_owner > 0) + ele_owner = minval(halo_node_owners(node_halo, ele_nodes(mesh, ele))) + assert(ele_owner > 0) - end function ele_owner + end function ele_owner - function invert_comms_sizes(knowns_sizes, communicator) result(unknowns_sizes) - !!< Given a set of knowns with size knowns_sizes (e.g. halo receive node - !!< counts), form the inverse (the halo send node counts) + function invert_comms_sizes(knowns_sizes, communicator) result(unknowns_sizes) + !!< Given a set of knowns with size knowns_sizes (e.g. halo receive node + !!< counts), form the inverse (the halo send node counts) - integer, dimension(:), intent(in) :: knowns_sizes - integer, optional, intent(in) :: communicator + integer, dimension(:), intent(in) :: knowns_sizes + integer, optional, intent(in) :: communicator - integer, dimension(size(knowns_sizes)) :: unknowns_sizes + integer, dimension(size(knowns_sizes)) :: unknowns_sizes #ifdef HAVE_MPI - integer :: ierr, lcommunicator + integer :: ierr, lcommunicator - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - assert(size(knowns_sizes) == getnprocs(communicator = lcommunicator)) + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + assert(size(knowns_sizes) == getnprocs(communicator = lcommunicator)) - call mpi_alltoall(knowns_sizes, 1, getpinteger(), unknowns_sizes, 1, getpinteger(), communicator, ierr) - assert(ierr == MPI_SUCCESS) + call mpi_alltoall(knowns_sizes, 1, getpinteger(), unknowns_sizes, 1, getpinteger(), communicator, ierr) + assert(ierr == MPI_SUCCESS) #else - FLAbort("invert_comms_sizes cannot be called without MPI support") + FLAbort("invert_comms_sizes cannot be called without MPI support") #endif - end function invert_comms_sizes + end function invert_comms_sizes - subroutine invert_element_halo_receives(mesh, node_halo, element_halo) - !!< Invert an element halo receives to form the element halo sends, using - !!< the unn cache of a node halo + subroutine invert_element_halo_receives(mesh, node_halo, element_halo) + !!< Invert an element halo receives to form the element halo sends, using + !!< the unn cache of a node halo - type(mesh_type), intent(in) :: mesh - type(halo_type), intent(in) :: node_halo - type(halo_type), intent(inout) :: element_halo + type(mesh_type), intent(in) :: mesh + type(halo_type), intent(in) :: node_halo + type(halo_type), intent(inout) :: element_halo #ifdef HAVE_MPI - ! No mixed mesh support here - integer :: loc - integer :: communicator, ele, i, ierr, j, nprocs, rank - integer, dimension(ele_loc(mesh, 1)) :: nodes - integer, dimension(:), allocatable :: nreceives, nsends, requests, statuses - type(integer_hash_table) :: gnns - type(integer_vector), dimension(:), allocatable :: receives_uenlist, sends_uenlist - integer tag - - assert(continuity(mesh) == 0) - assert(halo_data_type(node_halo) == HALO_TYPE_CG_NODE) - assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) - assert(has_global_to_universal_numbering(node_halo)) - assert(.not. has_global_to_universal_numbering(element_halo)) - - communicator = halo_communicator(node_halo) - nprocs = halo_proc_count(node_halo) - rank = getrank(communicator) - - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - call halo_receive_counts(element_halo, nreceives) - nsends = invert_comms_sizes(nreceives, communicator = communicator) - deallocate(nreceives) - call reallocate(element_halo, nsends = nsends) - deallocate(nsends) - - assert(valid_halo_node_counts(element_halo)) - - loc = mesh%shape%loc - - allocate(receives_uenlist(nprocs)) - do i = 1, nprocs - allocate(receives_uenlist(i)%ptr(halo_receive_count(element_halo, i)*loc)) - do j = 1, halo_receive_count(element_halo, i) - receives_uenlist(i)%ptr((j - 1) * loc + 1:j * loc) = halo_universal_numbers(node_halo, ele_nodes(mesh, halo_receive(element_halo, i, j))) + ! No mixed mesh support here + integer :: loc + integer :: communicator, ele, i, ierr, j, nprocs, rank + integer, dimension(ele_loc(mesh, 1)) :: nodes + integer, dimension(:), allocatable :: nreceives, nsends, requests, statuses + type(integer_hash_table) :: gnns + type(integer_vector), dimension(:), allocatable :: receives_uenlist, sends_uenlist + integer tag + + assert(continuity(mesh) == 0) + assert(halo_data_type(node_halo) == HALO_TYPE_CG_NODE) + assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) + assert(has_global_to_universal_numbering(node_halo)) + assert(.not. has_global_to_universal_numbering(element_halo)) + + communicator = halo_communicator(node_halo) + nprocs = halo_proc_count(node_halo) + rank = getrank(communicator) + + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + call halo_receive_counts(element_halo, nreceives) + nsends = invert_comms_sizes(nreceives, communicator = communicator) + deallocate(nreceives) + call reallocate(element_halo, nsends = nsends) + deallocate(nsends) + + assert(valid_halo_node_counts(element_halo)) + + loc = mesh%shape%loc + + allocate(receives_uenlist(nprocs)) + do i = 1, nprocs + allocate(receives_uenlist(i)%ptr(halo_receive_count(element_halo, i)*loc)) + do j = 1, halo_receive_count(element_halo, i) + receives_uenlist(i)%ptr((j - 1) * loc + 1:j * loc) = halo_universal_numbers(node_halo, ele_nodes(mesh, halo_receive(element_halo, i, j))) + end do end do - end do - - ! Set up non-blocking communications - allocate(sends_uenlist(nprocs)) - allocate(requests(nprocs * 2)) - requests = MPI_REQUEST_NULL - tag = next_mpi_tag() - - do i = 1, nprocs - allocate(sends_uenlist(i)%ptr(halo_send_count(element_halo, i)*loc)) - - ! Non-blocking sends - if(size(receives_uenlist(i)%ptr) > 0) then - call mpi_isend(receives_uenlist(i)%ptr, size(receives_uenlist(i)%ptr), getpinteger(), & - i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - ! Non-blocking receives - if(size(sends_uenlist(i)%ptr) > 0) then - call mpi_irecv(sends_uenlist(i)%ptr, size(sends_uenlist(i)%ptr), getpinteger(), & - i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - do i = 1, nprocs - deallocate(receives_uenlist(i)%ptr) - end do - deallocate(receives_uenlist) - - call get_universal_numbering_inverse(node_halo, gnns) - call add_nelist(mesh) - do i = 1, nprocs - do j = 1, halo_send_count(element_halo, i) - nodes = fetch(gnns, sends_uenlist(i)%ptr((j - 1) * loc + 1:j * loc)) - ele = nodes_ele(mesh, nodes) - call set_halo_send(element_halo, i, j, ele) + ! Set up non-blocking communications + allocate(sends_uenlist(nprocs)) + allocate(requests(nprocs * 2)) + requests = MPI_REQUEST_NULL + tag = next_mpi_tag() + + do i = 1, nprocs + allocate(sends_uenlist(i)%ptr(halo_send_count(element_halo, i)*loc)) + + ! Non-blocking sends + if(size(receives_uenlist(i)%ptr) > 0) then + call mpi_isend(receives_uenlist(i)%ptr, size(receives_uenlist(i)%ptr), getpinteger(), & + i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(size(sends_uenlist(i)%ptr) > 0) then + call mpi_irecv(sends_uenlist(i)%ptr, size(sends_uenlist(i)%ptr), getpinteger(), & + i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if end do - deallocate(sends_uenlist(i)%ptr) - end do - call deallocate(gnns) - deallocate(sends_uenlist) + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + do i = 1, nprocs + deallocate(receives_uenlist(i)%ptr) + end do + deallocate(receives_uenlist) + + call get_universal_numbering_inverse(node_halo, gnns) + call add_nelist(mesh) + do i = 1, nprocs + do j = 1, halo_send_count(element_halo, i) + nodes = fetch(gnns, sends_uenlist(i)%ptr((j - 1) * loc + 1:j * loc)) + ele = nodes_ele(mesh, nodes) + call set_halo_send(element_halo, i, j, ele) + end do + deallocate(sends_uenlist(i)%ptr) + end do + call deallocate(gnns) + deallocate(sends_uenlist) #else - FLAbort("invert_element_halo_receives cannot be called without MPI support") + FLAbort("invert_element_halo_receives cannot be called without MPI support") #endif - end subroutine invert_element_halo_receives + end subroutine invert_element_halo_receives - subroutine invert_surface_element_halo_receives(mesh, element_halo, selement_halo) - !!< Invert surface element halo receives to form the surface element halo - !!< sends, using the unn cache of an element halo + subroutine invert_surface_element_halo_receives(mesh, element_halo, selement_halo) + !!< Invert surface element halo receives to form the surface element halo + !!< sends, using the unn cache of an element halo - type(mesh_type), intent(in) :: mesh - type(halo_type), intent(in) :: element_halo - type(halo_type), intent(inout) :: selement_halo + type(mesh_type), intent(in) :: mesh + type(halo_type), intent(in) :: element_halo + type(halo_type), intent(inout) :: selement_halo #ifdef HAVE_MPI - integer :: communicator, ele, face, i, ierr, j, lface, nprocs, rank - integer, dimension(:), allocatable :: nreceives, nsends, requests, statuses - integer, dimension(:), pointer :: faces - type(integer_hash_table) :: gnns - type(integer_vector), dimension(:), allocatable :: receives_uenlist, sends_uenlist - integer tag - - assert(continuity(mesh) == 0) - assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) - assert(halo_data_type(selement_halo) == HALO_TYPE_ELEMENT) - assert(has_global_to_universal_numbering(element_halo)) - assert(.not. has_global_to_universal_numbering(selement_halo)) - - communicator = halo_communicator(element_halo) - nprocs = halo_proc_count(element_halo) - rank = getrank(communicator) - - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - call halo_receive_counts(selement_halo, nreceives) - nsends = invert_comms_sizes(nreceives, communicator = communicator) - deallocate(nreceives) - call reallocate(selement_halo, nsends = nsends) - deallocate(nsends) - - assert(valid_halo_node_counts(selement_halo)) - - allocate(receives_uenlist(nprocs)) - do i = 1, nprocs - allocate(receives_uenlist(i)%ptr(halo_receive_count(selement_halo, i)*2)) - do j = 1, halo_receive_count(selement_halo, i) - face = halo_receive(selement_halo, i, j) - receives_uenlist(i)%ptr((j - 1) * 2 + 1) = halo_universal_number(element_halo, face_ele(mesh, face)) - receives_uenlist(i)%ptr((j - 1) * 2 + 2) = local_face_number(mesh, face) + integer :: communicator, ele, face, i, ierr, j, lface, nprocs, rank + integer, dimension(:), allocatable :: nreceives, nsends, requests, statuses + integer, dimension(:), pointer :: faces + type(integer_hash_table) :: gnns + type(integer_vector), dimension(:), allocatable :: receives_uenlist, sends_uenlist + integer tag + + assert(continuity(mesh) == 0) + assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) + assert(halo_data_type(selement_halo) == HALO_TYPE_ELEMENT) + assert(has_global_to_universal_numbering(element_halo)) + assert(.not. has_global_to_universal_numbering(selement_halo)) + + communicator = halo_communicator(element_halo) + nprocs = halo_proc_count(element_halo) + rank = getrank(communicator) + + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + call halo_receive_counts(selement_halo, nreceives) + nsends = invert_comms_sizes(nreceives, communicator = communicator) + deallocate(nreceives) + call reallocate(selement_halo, nsends = nsends) + deallocate(nsends) + + assert(valid_halo_node_counts(selement_halo)) + + allocate(receives_uenlist(nprocs)) + do i = 1, nprocs + allocate(receives_uenlist(i)%ptr(halo_receive_count(selement_halo, i)*2)) + do j = 1, halo_receive_count(selement_halo, i) + face = halo_receive(selement_halo, i, j) + receives_uenlist(i)%ptr((j - 1) * 2 + 1) = halo_universal_number(element_halo, face_ele(mesh, face)) + receives_uenlist(i)%ptr((j - 1) * 2 + 2) = local_face_number(mesh, face) + end do end do - end do - - ! Set up non-blocking communications - allocate(sends_uenlist(nprocs)) - allocate(requests(nprocs * 2)) - requests = MPI_REQUEST_NULL - tag = next_mpi_tag() - - do i = 1, nprocs - allocate(sends_uenlist(i)%ptr(halo_send_count(selement_halo, i)*2)) - - ! Non-blocking sends - if(size(receives_uenlist(i)%ptr) > 0) then - call mpi_isend(receives_uenlist(i)%ptr, size(receives_uenlist(i)%ptr), getpinteger(), & - i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - ! Non-blocking receives - if(size(sends_uenlist(i)%ptr) > 0) then - call mpi_irecv(sends_uenlist(i)%ptr, size(sends_uenlist(i)%ptr), getpinteger(), & - i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - do i = 1, nprocs - deallocate(receives_uenlist(i)%ptr) - end do - deallocate(receives_uenlist) - - call get_universal_numbering_inverse(element_halo, gnns) - do i = 1, nprocs - do j = 1, halo_send_count(selement_halo, i) - ele = fetch(gnns, sends_uenlist(i)%ptr((j - 1) * 2 + 1)) - lface = sends_uenlist(i)%ptr((j - 1) * 2 + 2) - faces => ele_faces(mesh, ele) - face = faces(lface) - assert(face > 0) - call set_halo_send(selement_halo, i, j, face) + ! Set up non-blocking communications + allocate(sends_uenlist(nprocs)) + allocate(requests(nprocs * 2)) + requests = MPI_REQUEST_NULL + tag = next_mpi_tag() + + do i = 1, nprocs + allocate(sends_uenlist(i)%ptr(halo_send_count(selement_halo, i)*2)) + + ! Non-blocking sends + if(size(receives_uenlist(i)%ptr) > 0) then + call mpi_isend(receives_uenlist(i)%ptr, size(receives_uenlist(i)%ptr), getpinteger(), & + i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(size(sends_uenlist(i)%ptr) > 0) then + call mpi_irecv(sends_uenlist(i)%ptr, size(sends_uenlist(i)%ptr), getpinteger(), & + i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + do i = 1, nprocs + deallocate(receives_uenlist(i)%ptr) + end do + deallocate(receives_uenlist) + + call get_universal_numbering_inverse(element_halo, gnns) + do i = 1, nprocs + do j = 1, halo_send_count(selement_halo, i) + ele = fetch(gnns, sends_uenlist(i)%ptr((j - 1) * 2 + 1)) + lface = sends_uenlist(i)%ptr((j - 1) * 2 + 2) + faces => ele_faces(mesh, ele) + face = faces(lface) + assert(face > 0) + call set_halo_send(selement_halo, i, j, face) + end do + deallocate(sends_uenlist(i)%ptr) end do - deallocate(sends_uenlist(i)%ptr) - end do - call deallocate(gnns) - deallocate(sends_uenlist) + call deallocate(gnns) + deallocate(sends_uenlist) #else - FLAbort("invert_surface_element_halo_receives cannot be called without MPI support") + FLAbort("invert_surface_element_halo_receives cannot be called without MPI support") #endif - end subroutine invert_surface_element_halo_receives + end subroutine invert_surface_element_halo_receives - function nodes_ele(mesh, nodes) result(ele) - !!< Inverse of ele_nodes + function nodes_ele(mesh, nodes) result(ele) + !!< Inverse of ele_nodes - type(mesh_type), intent(in) :: mesh - integer, dimension(:), intent(in) :: nodes + type(mesh_type), intent(in) :: mesh + integer, dimension(:), intent(in) :: nodes - integer :: ele + integer :: ele - integer :: i, j - integer, dimension(:), pointer :: element_nodes, eles + integer :: i, j + integer, dimension(:), pointer :: element_nodes, eles - assert(size(nodes) > 0) - assert(associated(mesh%adj_lists)) - assert(associated(mesh%adj_lists%nelist)) - eles => row_m_ptr(mesh%adj_lists%nelist, nodes(1)) - eles_loop: do i = 1, size(eles) - element_nodes => ele_nodes(mesh, eles(i)) - if(size(element_nodes) /= size(nodes)) cycle eles_loop - do j = 1, size(nodes) - if(.not. any(element_nodes == nodes(j))) cycle eles_loop - end do + assert(size(nodes) > 0) + assert(associated(mesh%adj_lists)) + assert(associated(mesh%adj_lists%nelist)) + eles => row_m_ptr(mesh%adj_lists%nelist, nodes(1)) + eles_loop: do i = 1, size(eles) + element_nodes => ele_nodes(mesh, eles(i)) + if(size(element_nodes) /= size(nodes)) cycle eles_loop + do j = 1, size(nodes) + if(.not. any(element_nodes == nodes(j))) cycle eles_loop + end do - ele = eles(i) - return - end do eles_loop + ele = eles(i) + return + end do eles_loop - ewrite(-1, *) "For nodes ", nodes - FLAbort("Failed to find element") + ewrite(-1, *) "For nodes ", nodes + FLAbort("Failed to find element") - end function nodes_ele + end function nodes_ele - function invert_comms_global(halo, knowns) result(unknowns) - !!< Given a set of knowns global numbers (e.g. halo receive nodes) - !!< for the supplied halo, form the inverse (the halo send nodes) + function invert_comms_global(halo, knowns) result(unknowns) + !!< Given a set of knowns global numbers (e.g. halo receive nodes) + !!< for the supplied halo, form the inverse (the halo send nodes) - type(halo_type), intent(in) :: halo - type(integer_set), dimension(:), intent(in) :: knowns + type(halo_type), intent(in) :: halo + type(integer_set), dimension(:), intent(in) :: knowns - type(integer_set), dimension(size(knowns)) :: unknowns + type(integer_set), dimension(size(knowns)) :: unknowns - integer :: i, j - type(integer_hash_table) :: gnns - type(integer_set), dimension(size(knowns)) :: unn_knowns, unn_unknowns + integer :: i, j + type(integer_hash_table) :: gnns + type(integer_set), dimension(size(knowns)) :: unn_knowns, unn_unknowns - call allocate(unn_knowns) - do i = 1, size(knowns) - do j = 1, key_count(knowns(i)) - call insert(unn_knowns(i), halo_universal_number(halo, fetch(knowns(i), j))) + call allocate(unn_knowns) + do i = 1, size(knowns) + do j = 1, key_count(knowns(i)) + call insert(unn_knowns(i), halo_universal_number(halo, fetch(knowns(i), j))) + end do end do - end do - unn_unknowns = invert_comms(unn_knowns, communicator = halo_communicator(halo)) - call deallocate(unn_knowns) + unn_unknowns = invert_comms(unn_knowns, communicator = halo_communicator(halo)) + call deallocate(unn_knowns) - call get_universal_numbering_inverse(halo, gnns) + call get_universal_numbering_inverse(halo, gnns) - call allocate(unknowns) - do i = 1, size(unn_unknowns) - do j = 1, key_count(unn_unknowns(i)) - call insert(unknowns(i), fetch(gnns, fetch(unn_unknowns(i), j))) + call allocate(unknowns) + do i = 1, size(unn_unknowns) + do j = 1, key_count(unn_unknowns(i)) + call insert(unknowns(i), fetch(gnns, fetch(unn_unknowns(i), j))) + end do + call deallocate(unn_unknowns(i)) end do - call deallocate(unn_unknowns(i)) - end do - call deallocate(gnns) + call deallocate(gnns) - end function invert_comms_global + end function invert_comms_global - function invert_comms(knowns, communicator) result(unknowns) + function invert_comms(knowns, communicator) result(unknowns) - type(integer_set), dimension(:), intent(in) :: knowns - type(integer_set), dimension(size(knowns)) :: unknowns ! we'll actually know them by the end, but however - integer, intent(in), optional :: communicator + type(integer_set), dimension(:), intent(in) :: knowns + type(integer_set), dimension(size(knowns)) :: unknowns ! we'll actually know them by the end, but however + integer, intent(in), optional :: communicator #ifdef HAVE_ZOLTAN - type(zoltan_struct), pointer :: zz - integer(zoltan_int) :: ierr - - integer :: num_known, num_unknown - integer, dimension(:), pointer :: known_global_ids, known_local_ids, known_procs, known_to_part - integer, dimension(:), pointer :: unknown_global_ids, unknown_local_ids, unknown_procs, unknown_to_part - - integer :: i, head - - ! Set up zoltan structure - if (present(communicator)) then - zz => Zoltan_Create(communicator) - else - zz => Zoltan_Create(MPI_COMM_FEMTOOLS) - end if - - ! Convert the sets to zoltan's input (a bunch of arrays) - unknown_global_ids => null() - unknown_local_ids => null() - unknown_procs => null() - unknown_to_part => null() - - num_known = sum(key_count(knowns)) - allocate(known_global_ids(num_known)) - allocate(known_local_ids(num_known)) - allocate(known_procs(num_known)) - known_to_part => null() - known_local_ids = -666 ! in my reading of the zoltan docs, you shouldn't need this, but however - - ! Set known_global_ids and known_procs - head = 1 - do i=1,size(knowns) - known_global_ids(head:head + key_count(knowns(i)) - 1) = set2vector(knowns(i)) - known_procs(head:head + key_count(knowns(i)) - 1) = i - 1 - end do - - ! Call Zoltan_Compute_Destinations - ierr = Zoltan_Compute_Destinations(zz, & - & num_known, known_global_ids, known_local_ids, known_procs, & - & num_unknown, unknown_global_ids, unknown_local_ids, unknown_procs) - assert(ierr == ZOLTAN_OK) - - ! Set unknowns - call allocate(unknowns) - do i=1,num_unknown - call insert(unknowns(unknown_procs(i) + 1), unknown_global_ids(i)) - end do - - ! Deallocate - - ierr = Zoltan_LB_Free_Part(unknown_global_ids, unknown_local_ids, unknown_procs, unknown_to_part) - assert(ierr == ZOLTAN_OK) - - deallocate(known_procs) - deallocate(known_local_ids) - deallocate(known_global_ids) - call Zoltan_Destroy(zz) + type(zoltan_struct), pointer :: zz + integer(zoltan_int) :: ierr + + integer :: num_known, num_unknown + integer, dimension(:), pointer :: known_global_ids, known_local_ids, known_procs, known_to_part + integer, dimension(:), pointer :: unknown_global_ids, unknown_local_ids, unknown_procs, unknown_to_part + + integer :: i, head + + ! Set up zoltan structure + if (present(communicator)) then + zz => Zoltan_Create(communicator) + else + zz => Zoltan_Create(MPI_COMM_FEMTOOLS) + end if + + ! Convert the sets to zoltan's input (a bunch of arrays) + unknown_global_ids => null() + unknown_local_ids => null() + unknown_procs => null() + unknown_to_part => null() + + num_known = sum(key_count(knowns)) + allocate(known_global_ids(num_known)) + allocate(known_local_ids(num_known)) + allocate(known_procs(num_known)) + known_to_part => null() + known_local_ids = -666 ! in my reading of the zoltan docs, you shouldn't need this, but however + + ! Set known_global_ids and known_procs + head = 1 + do i=1,size(knowns) + known_global_ids(head:head + key_count(knowns(i)) - 1) = set2vector(knowns(i)) + known_procs(head:head + key_count(knowns(i)) - 1) = i - 1 + end do + + ! Call Zoltan_Compute_Destinations + ierr = Zoltan_Compute_Destinations(zz, & + & num_known, known_global_ids, known_local_ids, known_procs, & + & num_unknown, unknown_global_ids, unknown_local_ids, unknown_procs) + assert(ierr == ZOLTAN_OK) + + ! Set unknowns + call allocate(unknowns) + do i=1,num_unknown + call insert(unknowns(unknown_procs(i) + 1), unknown_global_ids(i)) + end do + + ! Deallocate + + ierr = Zoltan_LB_Free_Part(unknown_global_ids, unknown_local_ids, unknown_procs, unknown_to_part) + assert(ierr == ZOLTAN_OK) + + deallocate(known_procs) + deallocate(known_local_ids) + deallocate(known_global_ids) + call Zoltan_Destroy(zz) #else - call allocate(unknowns) ! Keep the compiler quiet - FLAbort("invert_comms called without zoltan support") + call allocate(unknowns) ! Keep the compiler quiet + FLAbort("invert_comms called without zoltan support") #endif - end function invert_comms + end function invert_comms - subroutine derive_nonperiodic_halos_from_periodic_halos(new_positions, model, aliased_to_new_node_number) - type(vector_field), intent(inout) :: new_positions - type(vector_field), intent(in) :: model - type(integer_hash_table), intent(in) :: aliased_to_new_node_number - type(ilist), dimension(:), allocatable :: sends, receives - integer :: proc, i, new_nowned_nodes + subroutine derive_nonperiodic_halos_from_periodic_halos(new_positions, model, aliased_to_new_node_number) + type(vector_field), intent(inout) :: new_positions + type(vector_field), intent(in) :: model + type(integer_hash_table), intent(in) :: aliased_to_new_node_number + type(ilist), dimension(:), allocatable :: sends, receives + integer :: proc, i, new_nowned_nodes #ifdef DDEBUG - integer, dimension(node_count(model)) :: map_verification - integer :: key, output + integer, dimension(node_count(model)) :: map_verification + integer :: key, output #endif - assert(halo_count(model) == 2) - assert(element_halo_count(model) == 2) - assert(halo_valid_for_communication(model%mesh%element_halos(1))) - assert(halo_valid_for_communication(model%mesh%element_halos(2))) - assert(halo_valid_for_communication(model%mesh%halos(1))) - assert(halo_valid_for_communication(model%mesh%halos(2))) + assert(halo_count(model) == 2) + assert(element_halo_count(model) == 2) + assert(halo_valid_for_communication(model%mesh%element_halos(1))) + assert(halo_valid_for_communication(model%mesh%element_halos(2))) + assert(halo_valid_for_communication(model%mesh%halos(1))) + assert(halo_valid_for_communication(model%mesh%halos(2))) #ifdef DDEBUG - map_verification = 0 - do i=1,key_count(aliased_to_new_node_number) - call fetch_pair(aliased_to_new_node_number, i, key, output) - map_verification(key) = 1 - end do - assert(halo_verifies(model%mesh%halos(2), map_verification)) - - assert(halo_verifies(model%mesh%halos(2), model)) -#endif - - ! element halos are easy, just a copy, na ja? - allocate(new_positions%mesh%element_halos(2)) - new_positions%mesh%element_halos(1) = model%mesh%element_halos(1); call incref(new_positions%mesh%element_halos(1)) - new_positions%mesh%element_halos(2) = model%mesh%element_halos(2); call incref(new_positions%mesh%element_halos(2)) - - ! nodal halo: let's compute the l2 nodal halo, then derive the l1 - ! from it - allocate(new_positions%mesh%halos(2)) + map_verification = 0 + do i=1,key_count(aliased_to_new_node_number) + call fetch_pair(aliased_to_new_node_number, i, key, output) + map_verification(key) = 1 + end do + assert(halo_verifies(model%mesh%halos(2), map_verification)) - allocate(sends(halo_proc_count(model%mesh%halos(2)))) - allocate(receives(halo_proc_count(model%mesh%halos(2)))) - do proc=1,halo_proc_count(model%mesh%halos(2)) + assert(halo_verifies(model%mesh%halos(2), model)) +#endif - do i=1,halo_send_count(model%mesh%halos(2), proc) - call insert(sends(proc), halo_send(model%mesh%halos(2), proc, i)) - end do - do i=1,halo_receive_count(model%mesh%halos(2), proc) - call insert(receives(proc), halo_receive(model%mesh%halos(2), proc, i)) + ! element halos are easy, just a copy, na ja? + allocate(new_positions%mesh%element_halos(2)) + new_positions%mesh%element_halos(1) = model%mesh%element_halos(1); call incref(new_positions%mesh%element_halos(1)) + new_positions%mesh%element_halos(2) = model%mesh%element_halos(2); call incref(new_positions%mesh%element_halos(2)) + + ! nodal halo: let's compute the l2 nodal halo, then derive the l1 + ! from it + allocate(new_positions%mesh%halos(2)) + + allocate(sends(halo_proc_count(model%mesh%halos(2)))) + allocate(receives(halo_proc_count(model%mesh%halos(2)))) + do proc=1,halo_proc_count(model%mesh%halos(2)) + + do i=1,halo_send_count(model%mesh%halos(2), proc) + call insert(sends(proc), halo_send(model%mesh%halos(2), proc, i)) + end do + do i=1,halo_receive_count(model%mesh%halos(2), proc) + call insert(receives(proc), halo_receive(model%mesh%halos(2), proc, i)) + end do + + do i=1,halo_send_count(model%mesh%halos(2), proc) + if (has_key(aliased_to_new_node_number, halo_send(model%mesh%halos(2), proc, i))) then + call insert(sends(proc), fetch(aliased_to_new_node_number, halo_send(model%mesh%halos(2), proc, i))) + end if + end do + do i=1,halo_receive_count(model%mesh%halos(2), proc) + if (has_key(aliased_to_new_node_number, halo_receive(model%mesh%halos(2), proc, i))) then + call insert(receives(proc), fetch(aliased_to_new_node_number, halo_receive(model%mesh%halos(2), proc, i))) + end if + end do end do - do i=1,halo_send_count(model%mesh%halos(2), proc) - if (has_key(aliased_to_new_node_number, halo_send(model%mesh%halos(2), proc, i))) then - call insert(sends(proc), fetch(aliased_to_new_node_number, halo_send(model%mesh%halos(2), proc, i))) - end if + new_nowned_nodes = halo_nowned_nodes(model%mesh%halos(2)) + do i=1,node_count(model) + if (.not. node_owned(model%mesh%halos(2), i)) cycle + if (has_key(aliased_to_new_node_number, i)) then + new_nowned_nodes = new_nowned_nodes + 1 + end if end do - do i=1,halo_receive_count(model%mesh%halos(2), proc) - if (has_key(aliased_to_new_node_number, halo_receive(model%mesh%halos(2), proc, i))) then - call insert(receives(proc), fetch(aliased_to_new_node_number, halo_receive(model%mesh%halos(2), proc, i))) - end if + + call allocate(new_positions%mesh%halos(2), & + nsends = sends%length, & + nreceives = receives%length, & + name = trim(new_positions%mesh%name) // "Level2Halo", & + communicator = halo_communicator(model%mesh%halos(2)), & + nowned_nodes = new_nowned_nodes, & + data_type = halo_data_type(model%mesh%halos(2)), & + ordering_scheme = HALO_ORDER_GENERAL) + + do proc=1,halo_proc_count(model%mesh%halos(2)) + call set_halo_sends(new_positions%mesh%halos(2), proc, list2vector(sends(proc))) + call deallocate(sends(proc)) + call set_halo_receives(new_positions%mesh%halos(2), proc, list2vector(receives(proc))) + call deallocate(receives(proc)) end do - end do - new_nowned_nodes = halo_nowned_nodes(model%mesh%halos(2)) - do i=1,node_count(model) - if (.not. node_owned(model%mesh%halos(2), i)) cycle - if (has_key(aliased_to_new_node_number, i)) then - new_nowned_nodes = new_nowned_nodes + 1 - end if - end do - - call allocate(new_positions%mesh%halos(2), & - nsends = sends%length, & - nreceives = receives%length, & - name = trim(new_positions%mesh%name) // "Level2Halo", & - communicator = halo_communicator(model%mesh%halos(2)), & - nowned_nodes = new_nowned_nodes, & - data_type = halo_data_type(model%mesh%halos(2)), & - ordering_scheme = HALO_ORDER_GENERAL) - - do proc=1,halo_proc_count(model%mesh%halos(2)) - call set_halo_sends(new_positions%mesh%halos(2), proc, list2vector(sends(proc))) - call deallocate(sends(proc)) - call set_halo_receives(new_positions%mesh%halos(2), proc, list2vector(receives(proc))) - call deallocate(receives(proc)) - end do - - deallocate(sends) - deallocate(receives) - - assert(halo_valid_for_communication(new_positions%mesh%halos(2))) - assert(halo_verifies(new_positions%mesh%halos(2), new_positions)) - - ! Ideally we would derive, but it fails if the mesh has nodes not associated with - ! any elements - !call derive_l1_from_l2_halo_mesh(new_positions%mesh, ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - new_positions%mesh%halos(1) = new_positions%mesh%halos(2) - call incref(new_positions%mesh%halos(1)) - - assert(halo_valid_for_communication(new_positions%mesh%halos(1))) - call renumber_positions_trailing_receives(new_positions) - assert(halo_valid_for_communication(new_positions%mesh%halos(1))) - assert(halo_valid_for_communication(new_positions%mesh%halos(2))) - - end subroutine derive_nonperiodic_halos_from_periodic_halos - - function derive_sub_halo(halo, sub_nodes) result (sub_halo) - !!< Derive a halo that is valid for a problem defined on a subset of the nodes - !!< of the original problem. A new local numbering (determined by the order - !!< of the 'sub_nodes' array) of these nodes is formed that is used in the sub-problem. - !!< Each process decides for itself which nodes of the full mesh will take part in - !!< the sub-problem, both for owned and receive nodes. - - !!< It is allowed for nodes that are considered to be part of the sub-problem - !!< by their owner, to be left out on other processes that see this node (receivers). This means - !!< each receiving process needs to tell its sender which nodes it is interested in for the sub-problem. - - !!< Usage cases: - !!< - solving equations on only part of a mesh. The subproblem is typically defined by a subset of the - !!< elements. It is then possible that a node adjacent to an element that forms part of the sub-problem, - !!< is seen (received) by another process which doesn't know about this element. For that process it - !!< wouldn't make sense to add it to the sub-problem, as it would not be part of any element in the - !!< sub-problem that it sees. It is therefore allowed in the sub_halo, to leave this node out as a recv - !!< node even though it is actually part of the global sub-problem that is solved for. - !!< - a similar situation arised in the case of solving on (parts of) the surface mesh. A receive node - !!< may only touch the surface mesh, without any surface elements being known in this process. - - type(halo_type), intent(in):: halo - integer, dimension(:), intent(in):: sub_nodes - type(halo_type) :: sub_halo - - type(integer_hash_table):: inverse_map - type(integer_set):: sub_receives_indices_set - type(integer_vector), dimension(:), allocatable:: sub_receives_indices, sub_sends_indices - integer, dimension(:), allocatable:: full_sends, full_receives - integer, dimension(:), allocatable:: full_sends_start_indices, full_receives_start_indices - integer, dimension(:), allocatable:: full_nsends, full_nreceives - integer, dimension(:), allocatable:: sub_nsends, sub_nreceives - integer, dimension(:), allocatable:: send_requests - integer, dimension(:), allocatable:: statuses - integer, dimension(MPI_STATUS_SIZE):: status - integer:: nprocs, tag, communicator, ierr - integer:: start, full_node, sub_node, no_sends, no_recvs, nowned_nodes - integer:: i, iproc - - ewrite(1,*) "deriving halo for sub-problem" - - nprocs = halo_proc_count(halo) - tag = next_mpi_tag() - communicator = halo_communicator(halo) - - ! create inverse map from the full problem to the sub_nodes numbering: - call invert_set(sub_nodes, inverse_map) - - allocate(full_sends(halo_all_sends_count(halo))) - allocate(full_receives(halo_all_receives_count(halo))) - - full_sends = 0 - full_receives = 0 - - allocate(full_sends_start_indices(nprocs)) - allocate(full_receives_start_indices(nprocs)) - - full_sends_start_indices = 0 - full_receives_start_indices = 0 - - allocate(full_nsends(nprocs)) - allocate(full_nreceives(nprocs)) - - full_nsends = 0 - full_nreceives = 0 - - allocate(sub_receives_indices(1:nprocs)) - allocate(sub_sends_indices(1:nprocs)) - - allocate(sub_nsends(nprocs)) - allocate(sub_nreceives(nprocs)) - - sub_nsends = 0 - sub_nreceives = 0 - - call extract_all_halo_sends(halo, full_sends, nsends=full_nsends, start_indices=full_sends_start_indices) - call extract_all_halo_receives(halo, full_receives, nreceives=full_nreceives, start_indices=full_receives_start_indices) - - ! we only send to processors of which we have receive nodes - allocate(send_requests(1:count(full_nreceives>0))) - no_sends = 0 - - do iproc = 1, nprocs - if(full_nreceives(iproc) > 0 ) then - - ! a set of indices in the array of all receive nodes received from iproc, corresponding to the nodes - ! we want to keep - call allocate(sub_receives_indices_set) - - ! start+i gives the location in full_receives of the i-th receive node from processor iproc - start = full_receives_start_indices(iproc)-1 - - ! collect receive nodes we want to keep - do i = 1, full_nreceives(iproc) - if (has_key(inverse_map, full_receives(start+i))) then - ! we store i as this is the index in the array of all receive nodes received from iproc - ! this is what we'll send to iproc, as it will know which send node it corresponds to - call insert(sub_receives_indices_set, i) - end if - end do - - sub_nreceives(iproc) = key_count(sub_receives_indices_set) - - ! convert to array so we can send it off - allocate( sub_receives_indices(iproc)%ptr(sub_nreceives(iproc)) ) - sub_receives_indices(iproc)%ptr = set2vector(sub_receives_indices_set) - call deallocate(sub_receives_indices_set) - - no_sends=no_sends+1 - ! Non-blocking send to the sender iproc to tell it which nodes we want to receive - call mpi_isend(sub_receives_indices(iproc)%ptr, sub_nreceives(iproc), MPI_INTEGER, iproc-1, tag, & - communicator, send_requests(no_sends), ierr) + deallocate(sends) + deallocate(receives) + + assert(halo_valid_for_communication(new_positions%mesh%halos(2))) + assert(halo_verifies(new_positions%mesh%halos(2), new_positions)) - end if + ! Ideally we would derive, but it fails if the mesh has nodes not associated with + ! any elements + !call derive_l1_from_l2_halo_mesh(new_positions%mesh, ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + new_positions%mesh%halos(1) = new_positions%mesh%halos(2) + call incref(new_positions%mesh%halos(1)) - end do ! iproc + assert(halo_valid_for_communication(new_positions%mesh%halos(1))) + call renumber_positions_trailing_receives(new_positions) + assert(halo_valid_for_communication(new_positions%mesh%halos(1))) + assert(halo_valid_for_communication(new_positions%mesh%halos(2))) + + end subroutine derive_nonperiodic_halos_from_periodic_halos + + function derive_sub_halo(halo, sub_nodes) result (sub_halo) + !!< Derive a halo that is valid for a problem defined on a subset of the nodes + !!< of the original problem. A new local numbering (determined by the order + !!< of the 'sub_nodes' array) of these nodes is formed that is used in the sub-problem. + !!< Each process decides for itself which nodes of the full mesh will take part in + !!< the sub-problem, both for owned and receive nodes. + + !!< It is allowed for nodes that are considered to be part of the sub-problem + !!< by their owner, to be left out on other processes that see this node (receivers). This means + !!< each receiving process needs to tell its sender which nodes it is interested in for the sub-problem. + + !!< Usage cases: + !!< - solving equations on only part of a mesh. The subproblem is typically defined by a subset of the + !!< elements. It is then possible that a node adjacent to an element that forms part of the sub-problem, + !!< is seen (received) by another process which doesn't know about this element. For that process it + !!< wouldn't make sense to add it to the sub-problem, as it would not be part of any element in the + !!< sub-problem that it sees. It is therefore allowed in the sub_halo, to leave this node out as a recv + !!< node even though it is actually part of the global sub-problem that is solved for. + !!< - a similar situation arised in the case of solving on (parts of) the surface mesh. A receive node + !!< may only touch the surface mesh, without any surface elements being known in this process. + + type(halo_type), intent(in):: halo + integer, dimension(:), intent(in):: sub_nodes + type(halo_type) :: sub_halo + + type(integer_hash_table):: inverse_map + type(integer_set):: sub_receives_indices_set + type(integer_vector), dimension(:), allocatable:: sub_receives_indices, sub_sends_indices + integer, dimension(:), allocatable:: full_sends, full_receives + integer, dimension(:), allocatable:: full_sends_start_indices, full_receives_start_indices + integer, dimension(:), allocatable:: full_nsends, full_nreceives + integer, dimension(:), allocatable:: sub_nsends, sub_nreceives + integer, dimension(:), allocatable:: send_requests + integer, dimension(:), allocatable:: statuses + integer, dimension(MPI_STATUS_SIZE):: status + integer:: nprocs, tag, communicator, ierr + integer:: start, full_node, sub_node, no_sends, no_recvs, nowned_nodes + integer:: i, iproc + + ewrite(1,*) "deriving halo for sub-problem" + + nprocs = halo_proc_count(halo) + tag = next_mpi_tag() + communicator = halo_communicator(halo) + + ! create inverse map from the full problem to the sub_nodes numbering: + call invert_set(sub_nodes, inverse_map) + + allocate(full_sends(halo_all_sends_count(halo))) + allocate(full_receives(halo_all_receives_count(halo))) + + full_sends = 0 + full_receives = 0 + + allocate(full_sends_start_indices(nprocs)) + allocate(full_receives_start_indices(nprocs)) + + full_sends_start_indices = 0 + full_receives_start_indices = 0 + + allocate(full_nsends(nprocs)) + allocate(full_nreceives(nprocs)) + + full_nsends = 0 + full_nreceives = 0 + + allocate(sub_receives_indices(1:nprocs)) + allocate(sub_sends_indices(1:nprocs)) + + allocate(sub_nsends(nprocs)) + allocate(sub_nreceives(nprocs)) + + sub_nsends = 0 + sub_nreceives = 0 + + call extract_all_halo_sends(halo, full_sends, nsends=full_nsends, start_indices=full_sends_start_indices) + call extract_all_halo_receives(halo, full_receives, nreceives=full_nreceives, start_indices=full_receives_start_indices) + + ! we only send to processors of which we have receive nodes + allocate(send_requests(1:count(full_nreceives>0))) + no_sends = 0 + + do iproc = 1, nprocs + if(full_nreceives(iproc) > 0 ) then + + ! a set of indices in the array of all receive nodes received from iproc, corresponding to the nodes + ! we want to keep + call allocate(sub_receives_indices_set) + + ! start+i gives the location in full_receives of the i-th receive node from processor iproc + start = full_receives_start_indices(iproc)-1 + + ! collect receive nodes we want to keep + do i = 1, full_nreceives(iproc) + if (has_key(inverse_map, full_receives(start+i))) then + ! we store i as this is the index in the array of all receive nodes received from iproc + ! this is what we'll send to iproc, as it will know which send node it corresponds to + call insert(sub_receives_indices_set, i) + end if + end do - ! number of messages expected: - ! only expect a request from processes we have send nodes for - no_recvs = count(full_nsends>0) - assert( no_sends==count(full_nreceives>0) ) + sub_nreceives(iproc) = key_count(sub_receives_indices_set) - ! receive all requests and store in sub_sends_indices + ! convert to array so we can send it off + allocate( sub_receives_indices(iproc)%ptr(sub_nreceives(iproc)) ) + sub_receives_indices(iproc)%ptr = set2vector(sub_receives_indices_set) + call deallocate(sub_receives_indices_set) - do i = 1, no_recvs + no_sends=no_sends+1 + ! Non-blocking send to the sender iproc to tell it which nodes we want to receive + call mpi_isend(sub_receives_indices(iproc)%ptr, sub_nreceives(iproc), MPI_INTEGER, iproc-1, tag, & + communicator, send_requests(no_sends), ierr) - ! check for pending messages, only returns when a message is ready to receive: - call mpi_probe(MPI_ANY_SOURCE, tag, communicator, status, ierr) - assert(ierr == MPI_SUCCESS) + end if - ! who did we receive from? - iproc = status(MPI_SOURCE) + 1 + end do ! iproc - ! query the size and set up the recv buffer - call mpi_get_count(status, MPI_INTEGER, sub_nsends(iproc), ierr) - assert(ierr == MPI_SUCCESS) - allocate(sub_sends_indices(iproc)%ptr(sub_nsends(iproc))) + ! number of messages expected: + ! only expect a request from processes we have send nodes for + no_recvs = count(full_nsends>0) + assert( no_sends==count(full_nreceives>0) ) - ! because of the mpi_probe, this blocking send is guaranteed to finish - call mpi_recv(sub_sends_indices(iproc)%ptr, sub_nsends(iproc), MPI_INTEGER, iproc-1, tag, & - communicator, status, ierr) - assert(ierr == MPI_SUCCESS) + ! receive all requests and store in sub_sends_indices - assert( full_nsends(iproc)>0 ) ! should only be receiving from processes we are sending to - assert( sub_nsends(iproc)<=full_nsends(iproc) ) ! should request less than the complete number of sends - assert( maxval(sub_sends_indices(iproc)%ptr)<=full_nsends(iproc) ) ! requested indices should be within the full list of sends + do i = 1, no_recvs - end do + ! check for pending messages, only returns when a message is ready to receive: + call mpi_probe(MPI_ANY_SOURCE, tag, communicator, status, ierr) + assert(ierr == MPI_SUCCESS) - ! we now have all the information to allocate the new sub_halo - call allocate(sub_halo, sub_nsends, sub_nreceives, name=trim(halo%name) // "SubHalo", & - & communicator = communicator, data_type = halo%data_type) + ! who did we receive from? + iproc = status(MPI_SOURCE) + 1 - ! now count the number of owned nodes in sub_nodes and store it on the halo - nowned_nodes = 0 - do i = 1, size(sub_nodes) - if (node_owned(halo, sub_nodes(i))) then - nowned_nodes = nowned_nodes + 1 - end if - end do - call set_halo_nowned_nodes(sub_halo, nowned_nodes) - - ! store the requested nodes in the send lists of the sub_halo - do iproc = 1, nprocs - if(full_nsends(iproc) > 0 ) then - ! start+i gives the location in full_sends of the i-th node sent to processor iproc - start = full_sends_start_indices(iproc)-1 - ! loop over the requested nodes one by one - do i=1, sub_nsends(iproc) - ! requested node in full numbering: - full_node = full_sends(start+sub_sends_indices(iproc)%ptr(i)) - ! this will fail if the receiver has requested a node, that is not in our 'sub_nodes' array - sub_node = fetch(inverse_map, full_node) - call set_halo_send(sub_halo, iproc, i, sub_node) - end do - deallocate(sub_sends_indices(iproc)%ptr) - end if - end do - - ! we have to wait here till all isends have finished, so we can safely deallocate the sub_receives_indices - allocate(statuses(MPI_STATUS_SIZE*no_sends)) - call mpi_waitall(no_sends, send_requests, statuses, ierr) - deallocate(statuses) - - ! store the receive nodes we've requested in the receive lists of the sub_halo - do iproc = 1, nprocs - if(full_nreceives(iproc) > 0 ) then - ! start+i gives the location in full_receives of the i-th node received from processor iproc - start = full_receives_start_indices(iproc)-1 - ! loop over the requested nodes one by one - do i=1, sub_nreceives(iproc) - ! requested node in full numbering: - full_node = full_receives(start+sub_receives_indices(iproc)%ptr(i)) - ! this shouldn't fail because of the has_key check where sub_receives_indices was assembled - sub_node = fetch(inverse_map, full_node) - call set_halo_receive(sub_halo, iproc, i, sub_node) - end do - deallocate(sub_receives_indices(iproc)%ptr) - end if - end do - - call deallocate(inverse_map) - deallocate(sub_nreceives) - deallocate(sub_nsends) - - end function derive_sub_halo - - function combine_halos(halos, node_maps, name) result (halo_out) - !!< Combine two or more halos of a number of subproblems into a single - !!< halo, where the numbering of the dofs (nodes) of each subproblem is - !!< combined into one single contiguous numbering of the dofs in the combined - !!< system. This is useful to combine the linear solve of two or more coupled - !!< problem into a single system (which can then be passed to petsc_solve e.g.) - !!< The numbering of the combined system should be provided by node_maps(:) - !!< which for each of the sub-problems, provides a map from the sub-problem - !!< dof-numbering to the dof-numbering of the combined system. If you need - !!< the combined halo to be in trailing receive order, you need to choose - !!< the new numbering accordingly for which the function - !!< create_combined_numbering_trailing_receives() below can be used. - type(halo_type) :: halo_out - type(halo_type), dimension(:), intent(in):: halos - type(integer_vector), dimension(:), intent(in):: node_maps - character(len=*), intent(in):: name ! name for the halo - - integer, dimension(halo_proc_count(halos(1))):: nsends, nreceives, combined_nsends, combined_nreceives, & - send_count, receive_count - integer:: data_type, communicator, nprocs - integer:: combined_nowned_nodes - integer:: ihalo, jproc, k, new_node_no - - communicator = halo_communicator(halos(1)) - data_type = halo_data_type(halos(1)) - nprocs = halo_proc_count(halos(1)) + ! query the size and set up the recv buffer + call mpi_get_count(status, MPI_INTEGER, sub_nsends(iproc), ierr) + assert(ierr == MPI_SUCCESS) + allocate(sub_sends_indices(iproc)%ptr(sub_nsends(iproc))) + + ! because of the mpi_probe, this blocking send is guaranteed to finish + call mpi_recv(sub_sends_indices(iproc)%ptr, sub_nsends(iproc), MPI_INTEGER, iproc-1, tag, & + communicator, status, ierr) + assert(ierr == MPI_SUCCESS) + + assert( full_nsends(iproc)>0 ) ! should only be receiving from processes we are sending to + assert( sub_nsends(iproc)<=full_nsends(iproc) ) ! should request less than the complete number of sends + assert( maxval(sub_sends_indices(iproc)%ptr)<=full_nsends(iproc) ) ! requested indices should be within the full list of sends + + end do + + ! we now have all the information to allocate the new sub_halo + call allocate(sub_halo, sub_nsends, sub_nreceives, name=trim(halo%name) // "SubHalo", & + & communicator = communicator, data_type = halo%data_type) + + ! now count the number of owned nodes in sub_nodes and store it on the halo + nowned_nodes = 0 + do i = 1, size(sub_nodes) + if (node_owned(halo, sub_nodes(i))) then + nowned_nodes = nowned_nodes + 1 + end if + end do + call set_halo_nowned_nodes(sub_halo, nowned_nodes) + + ! store the requested nodes in the send lists of the sub_halo + do iproc = 1, nprocs + if(full_nsends(iproc) > 0 ) then + ! start+i gives the location in full_sends of the i-th node sent to processor iproc + start = full_sends_start_indices(iproc)-1 + ! loop over the requested nodes one by one + do i=1, sub_nsends(iproc) + ! requested node in full numbering: + full_node = full_sends(start+sub_sends_indices(iproc)%ptr(i)) + ! this will fail if the receiver has requested a node, that is not in our 'sub_nodes' array + sub_node = fetch(inverse_map, full_node) + call set_halo_send(sub_halo, iproc, i, sub_node) + end do + deallocate(sub_sends_indices(iproc)%ptr) + end if + end do + + ! we have to wait here till all isends have finished, so we can safely deallocate the sub_receives_indices + allocate(statuses(MPI_STATUS_SIZE*no_sends)) + call mpi_waitall(no_sends, send_requests, statuses, ierr) + deallocate(statuses) + + ! store the receive nodes we've requested in the receive lists of the sub_halo + do iproc = 1, nprocs + if(full_nreceives(iproc) > 0 ) then + ! start+i gives the location in full_receives of the i-th node received from processor iproc + start = full_receives_start_indices(iproc)-1 + ! loop over the requested nodes one by one + do i=1, sub_nreceives(iproc) + ! requested node in full numbering: + full_node = full_receives(start+sub_receives_indices(iproc)%ptr(i)) + ! this shouldn't fail because of the has_key check where sub_receives_indices was assembled + sub_node = fetch(inverse_map, full_node) + call set_halo_receive(sub_halo, iproc, i, sub_node) + end do + deallocate(sub_receives_indices(iproc)%ptr) + end if + end do + + call deallocate(inverse_map) + deallocate(sub_nreceives) + deallocate(sub_nsends) + + end function derive_sub_halo + + function combine_halos(halos, node_maps, name) result (halo_out) + !!< Combine two or more halos of a number of subproblems into a single + !!< halo, where the numbering of the dofs (nodes) of each subproblem is + !!< combined into one single contiguous numbering of the dofs in the combined + !!< system. This is useful to combine the linear solve of two or more coupled + !!< problem into a single system (which can then be passed to petsc_solve e.g.) + !!< The numbering of the combined system should be provided by node_maps(:) + !!< which for each of the sub-problems, provides a map from the sub-problem + !!< dof-numbering to the dof-numbering of the combined system. If you need + !!< the combined halo to be in trailing receive order, you need to choose + !!< the new numbering accordingly for which the function + !!< create_combined_numbering_trailing_receives() below can be used. + type(halo_type) :: halo_out + type(halo_type), dimension(:), intent(in):: halos + type(integer_vector), dimension(:), intent(in):: node_maps + character(len=*), intent(in):: name ! name for the halo + + integer, dimension(halo_proc_count(halos(1))):: nsends, nreceives, combined_nsends, combined_nreceives, & + send_count, receive_count + integer:: data_type, communicator, nprocs + integer:: combined_nowned_nodes + integer:: ihalo, jproc, k, new_node_no + + communicator = halo_communicator(halos(1)) + data_type = halo_data_type(halos(1)) + nprocs = halo_proc_count(halos(1)) #ifdef DDEBUG - do ihalo=2, size(halos) - assert(communicator==halo_communicator(halos(ihalo))) - assert(data_type==halo_data_type(halos(ihalo))) - assert(nprocs==halo_proc_count(halos(ihalo))) - end do + do ihalo=2, size(halos) + assert(communicator==halo_communicator(halos(ihalo))) + assert(data_type==halo_data_type(halos(ihalo))) + assert(nprocs==halo_proc_count(halos(ihalo))) + end do #endif - assert( size(node_maps)==size(halos) ) + assert( size(node_maps)==size(halos) ) - combined_nsends = 0 - combined_nreceives =0 - combined_nowned_nodes =0 + combined_nsends = 0 + combined_nreceives =0 + combined_nowned_nodes =0 - do ihalo=1, size(halos) - call halo_send_counts(halos(ihalo), nsends) - combined_nsends = combined_nsends + nsends - call halo_receive_counts(halos(ihalo), nreceives) - combined_nreceives = combined_nreceives + nreceives - combined_nowned_nodes = combined_nowned_nodes + halo_nowned_nodes(halos(ihalo)) - end do + do ihalo=1, size(halos) + call halo_send_counts(halos(ihalo), nsends) + combined_nsends = combined_nsends + nsends + call halo_receive_counts(halos(ihalo), nreceives) + combined_nreceives = combined_nreceives + nreceives + combined_nowned_nodes = combined_nowned_nodes + halo_nowned_nodes(halos(ihalo)) + end do - call allocate(halo_out, combined_nsends, combined_nreceives, name=name, & - communicator=communicator, data_type=data_type, nowned_nodes=combined_nowned_nodes) + call allocate(halo_out, combined_nsends, combined_nreceives, name=name, & + communicator=communicator, data_type=data_type, nowned_nodes=combined_nowned_nodes) - send_count = 0 - receive_count = 0 + send_count = 0 + receive_count = 0 - do ihalo=1, size(halos) + do ihalo=1, size(halos) - do jproc=1, nprocs + do jproc=1, nprocs - do k=1, halo_send_count(halos(ihalo), jproc) - new_node_no = node_maps(ihalo)%ptr(halo_send(halos(ihalo), jproc, k)) - call set_halo_send(halo_out, jproc, send_count(jproc)+k, new_node_no) - end do - send_count(jproc) = send_count(jproc) + halo_send_count(halos(ihalo), jproc) + do k=1, halo_send_count(halos(ihalo), jproc) + new_node_no = node_maps(ihalo)%ptr(halo_send(halos(ihalo), jproc, k)) + call set_halo_send(halo_out, jproc, send_count(jproc)+k, new_node_no) + end do + send_count(jproc) = send_count(jproc) + halo_send_count(halos(ihalo), jproc) - do k=1, halo_receive_count(halos(ihalo), jproc) - new_node_no = node_maps(ihalo)%ptr(halo_receive(halos(ihalo), jproc, k)) - call set_halo_receive(halo_out, jproc, receive_count(jproc)+k, new_node_no) - end do - receive_count(jproc) = receive_count(jproc) + halo_receive_count(halos(ihalo), jproc) - end do + do k=1, halo_receive_count(halos(ihalo), jproc) + new_node_no = node_maps(ihalo)%ptr(halo_receive(halos(ihalo), jproc, k)) + call set_halo_receive(halo_out, jproc, receive_count(jproc)+k, new_node_no) + end do + receive_count(jproc) = receive_count(jproc) + halo_receive_count(halos(ihalo), jproc) + end do - end do - - assert( all(receive_count==combined_nreceives) ) - assert( all(send_count==combined_nsends) ) - - end function combine_halos - - function create_combined_numbering_trailing_receives(halos1, halos2) result (node_maps) - !!< Combine the node numbering of one of more subproblems into a single - !!< contiguous numbering in such a way that we fulfill all requirements - !!< of trailing_receives_consistent(). This means we first number all - !!< owned nodes (first of subsystem 1, then of subsystem2, etc.), followed - !!< by the receive nodes. We assume here that halos1 and halos2 are based - !!< on the same numbering of the subsystems, and that the receive - !!< nodes of halos1 are a subset of those in halos2. - !!< In order to adhere to the following requirement: - !!< max_halo_receive_node(halo) == node_count(halo) - !!< for both halos1 and halos2, we need to then number the receive nodes - !!< of halos1 first (for all subsystems), followed by any receive nodes - !!< that are only in halos2. - type(halo_type), dimension(:), intent(in):: halos1, halos2 - !! we return an array of node_maps that maps the numbering of each subsystem - !! to that of the combined system - type(integer_vector), dimension(size(halos1)):: node_maps - - integer, dimension(:), allocatable :: all_recvs - integer :: new_node - integer :: i, j - - ! some rudimentary checks to see the halos adhere to the above - assert(size(halos1)==size(halos2)) - do i=1, size(halos1) - assert(halo_nowned_nodes(halos1(i))==halo_nowned_nodes(halos2(i))) - assert(node_count(halos1(i))<=node_count(halos2(i))) - end do - - do i=1, size(node_maps) - allocate(node_maps(i)%ptr(node_count(halos2(i)))) - node_maps(i)%ptr = 0 - end do - - new_node = 1 ! keeps track of the next new node number in the combined numbering - - ! owned nodes - do i=1, size(halos1) - do j=1, halo_nowned_nodes(halos1(i)) - node_maps(i)%ptr(j) = new_node - new_node = new_node + 1 end do - end do - - ! receive nodes of halos1 - do i=1, size(halos1) - allocate(all_recvs(1:halo_all_receives_count(halos1(i)))) - call extract_all_halo_receives(halos1(i), all_recvs) - do j=1, size(all_recvs) - node_maps(i)%ptr(all_recvs(j)) = new_node - new_node = new_node + 1 + + assert( all(receive_count==combined_nreceives) ) + assert( all(send_count==combined_nsends) ) + + end function combine_halos + + function create_combined_numbering_trailing_receives(halos1, halos2) result (node_maps) + !!< Combine the node numbering of one of more subproblems into a single + !!< contiguous numbering in such a way that we fulfill all requirements + !!< of trailing_receives_consistent(). This means we first number all + !!< owned nodes (first of subsystem 1, then of subsystem2, etc.), followed + !!< by the receive nodes. We assume here that halos1 and halos2 are based + !!< on the same numbering of the subsystems, and that the receive + !!< nodes of halos1 are a subset of those in halos2. + !!< In order to adhere to the following requirement: + !!< max_halo_receive_node(halo) == node_count(halo) + !!< for both halos1 and halos2, we need to then number the receive nodes + !!< of halos1 first (for all subsystems), followed by any receive nodes + !!< that are only in halos2. + type(halo_type), dimension(:), intent(in):: halos1, halos2 + !! we return an array of node_maps that maps the numbering of each subsystem + !! to that of the combined system + type(integer_vector), dimension(size(halos1)):: node_maps + + integer, dimension(:), allocatable :: all_recvs + integer :: new_node + integer :: i, j + + ! some rudimentary checks to see the halos adhere to the above + assert(size(halos1)==size(halos2)) + do i=1, size(halos1) + assert(halo_nowned_nodes(halos1(i))==halo_nowned_nodes(halos2(i))) + assert(node_count(halos1(i))<=node_count(halos2(i))) end do - deallocate(all_recvs) - end do - - ! receive nodes of halos2 - do i=1, size(halos2) - allocate(all_recvs(1:halo_all_receives_count(halos2(i)))) - call extract_all_halo_receives(halos2(i), all_recvs) - do j=1, size(all_recvs) - if (node_maps(i)%ptr(all_recvs(j))==0) then - ! only include those that weren't recv nodes of halos1 already - node_maps(i)%ptr(all_recvs(j)) = new_node - new_node = new_node + 1 - end if + + do i=1, size(node_maps) + allocate(node_maps(i)%ptr(node_count(halos2(i)))) + node_maps(i)%ptr = 0 end do - deallocate(all_recvs) - end do - - end function create_combined_numbering_trailing_receives - - function expand_positions_halo(positions) result (new_positions) - type(vector_field), intent(in) :: positions - type(vector_field) :: new_positions - - type(mesh_type) :: new_mesh - - ewrite(1,*) "Inside expand_positions_halo" - - new_mesh = expand_mesh_halo(positions%mesh) - call allocate(new_positions, positions%dim, new_mesh, name=positions%name) - new_positions%val(:,1:node_count(positions)) = positions%val - call halo_update(new_positions) - call deallocate(new_mesh) - - ewrite(1,*) "Exiting expand_positions_halo" - - end function expand_positions_halo - - function expand_mesh_halo(mesh) result (new_mesh) - type(mesh_type), intent(in) :: mesh - type(mesh_type) :: new_mesh - - type(csr_sparsity), pointer :: nelist - type(halo_type), pointer :: old_halo, ele_halo - type(halo_type) :: new_halo - type(integer_hash_table) :: ueid_to_gid, uid_to_gid, ufid_to_gid - type(integer_set) :: elements_to_send - type(integer_vector), dimension(:), allocatable :: send_buffer, recv_buffer - integer, dimension(:), allocatable :: send_request - integer, dimension(:), pointer :: neigh, nodes, facets - integer, dimension(:), allocatable :: sndgln, boundary_ids, element_owners - integer, dimension(:), allocatable :: statuses - integer, dimension(MPI_STATUS_SIZE) :: status - integer :: comm, tag, ierr, nprocs - integer :: new_node_count, new_element_count, new_surface_element_count - integer :: nhalos, nloc, snloc, nfaces, send_count, recv_size - integer :: no_boundary_id, old_node_count - integer :: proc, ele, sele, ele_uid, ufid, i, j, ele_info_size, lface - logical :: has_surface_mesh, all_new_nodes - - ewrite(1,*) "Inside expand_mesh_halo" - nhalos = size(mesh%halos) - old_halo => mesh%halos(nhalos) - ele_halo => mesh%element_halos(size(mesh%element_halos)) - new_halo = expand_halo(mesh, old_halo) - - ! map from universal node id to global node id - call create_global_to_universal_numbering(new_halo) - call get_universal_numbering_inverse(new_halo, uid_to_gid) - call create_ownership(new_halo) - ! map from universal element id to global element id - call create_global_to_universal_numbering(ele_halo) - call get_universal_numbering_inverse(ele_halo, ueid_to_gid) - - old_node_count = node_count(mesh) - new_node_count = key_count(uid_to_gid) - assert(new_node_count==max_halo_receive_node(new_halo)) - new_element_count = element_count(mesh) ! we start with all existing elements - nloc = mesh%shape%loc - nfaces = mesh%shape%numbering%boundaries - ! things we send with each element: - ! 1) its universal element id - ! 2) its nodes (by uid) - ! if associated(mesh%faces): 3) the surface ids of adjacent facets - ele_info_size = 1+nloc - - has_surface_mesh = .false. - if (associated(mesh%faces)) then - if (associated(mesh%faces%boundary_ids)) then - has_surface_mesh = .true. - end if - end if - - if (has_surface_mesh) then - snloc = mesh%faces%shape%loc - ele_info_size = ele_info_size+nfaces - ! we have to agree on an id that means: this facet is not part of the surface mesh - no_boundary_id = minval(mesh%faces%boundary_ids) - call allmin(no_boundary_id) - no_boundary_id = no_boundary_id-1 - ! Coming out of the 3d adaptivity wrapper we don't trust all surface elements. - ! In order to lock the halo, the 3d wrapper has marked surface elements at the end of the halo - ! and when reconstructing the mesh object after the adapt these get added to the surface mesh. - ! Luckily, surface elements at the end of the halo can be identified as not having any owned nodes. - ! This is because of the logic in strip_l2_halo, where we keep any elements with owned nodes, so a halo - ! surface element must be adjacent to an element that doesn't have any owned nodes. Because we don't - ! trust the information about these, we simply drop them here and let adacent node owners send the - ! information again (it could for instance be that one of the surface elements is actually really - ! on the true surface mesh). - call allocate(ufid_to_gid) ! a map from universal facet ids to facet ids for the new mesh - new_surface_element_count = 0 - do i=1, unique_surface_element_count(mesh) - if (any(nodes_owned(old_halo, face_global_nodes(mesh, i)))) then - new_surface_element_count = new_surface_element_count+1 - ele = face_ele(mesh, i) - lface = local_face_number(mesh, i) - ! compute a universal facets numbering based on the universal element number - ufid = halo_universal_number(ele_halo, ele)*nfaces + lface - call insert(ufid_to_gid, ufid, new_surface_element_count) - end if + + new_node = 1 ! keeps track of the next new node number in the combined numbering + + ! owned nodes + do i=1, size(halos1) + do j=1, halo_nowned_nodes(halos1(i)) + node_maps(i)%ptr(j) = new_node + new_node = new_node + 1 + end do end do - end if - - ! send and recv buffers for each processor - nprocs = halo_proc_count(old_halo) - comm = halo_communicator(old_halo) - tag = next_mpi_tag() - allocate(send_buffer(nprocs), send_request(nprocs)) - allocate(recv_buffer(nprocs)) - send_request = MPI_REQUEST_NULL - - ! loop over all new send nodes and send its adjacent elements - nelist => extract_nelist(mesh) - do proc=1, nprocs - if (halo_send_count(new_halo, proc)==0) cycle - call allocate(elements_to_send) - ! loop over all send nodes - do i=1, halo_send_count(new_halo, proc) - neigh => row_m_ptr(nelist, halo_send(new_halo, proc, i)) - call insert(elements_to_send, neigh) + + ! receive nodes of halos1 + do i=1, size(halos1) + allocate(all_recvs(1:halo_all_receives_count(halos1(i)))) + call extract_all_halo_receives(halos1(i), all_recvs) + do j=1, size(all_recvs) + node_maps(i)%ptr(all_recvs(j)) = new_node + new_node = new_node + 1 + end do + deallocate(all_recvs) end do - send_count = key_count(elements_to_send) - ! for each element, send its ueid and the uids of its nodes - ! and optionally, the surface ids of its facets - allocate(send_buffer(proc)%ptr(send_count*ele_info_size)) - send_count = 1 - do i=1, key_count(elements_to_send) - ele = fetch(elements_to_send, i) - ele_uid = halo_universal_number(ele_halo, ele) - send_buffer(proc)%ptr(send_count) = ele_uid - nodes => ele_nodes(mesh, ele) - send_buffer(proc)%ptr(send_count+1:send_count+size(nodes)) = halo_universal_number(new_halo, nodes) - send_count = send_count+1+size(nodes) - if (has_surface_mesh) then - facets => ele_faces(mesh, ele) - do j=1, size(facets) - ufid = ele_uid*nfaces+j - if (has_key(ufid_to_gid, ufid)) then - send_buffer(proc)%ptr(send_count+j-1) = surface_element_id(mesh, facets(j)) - else - send_buffer(proc)%ptr(send_count+j-1) = no_boundary_id + + ! receive nodes of halos2 + do i=1, size(halos2) + allocate(all_recvs(1:halo_all_receives_count(halos2(i)))) + call extract_all_halo_receives(halos2(i), all_recvs) + do j=1, size(all_recvs) + if (node_maps(i)%ptr(all_recvs(j))==0) then + ! only include those that weren't recv nodes of halos1 already + node_maps(i)%ptr(all_recvs(j)) = new_node + new_node = new_node + 1 end if - end do - send_count = send_count+nfaces - end if + end do + deallocate(all_recvs) end do - assert(send_count==size(send_buffer(proc)%ptr)+1) - call deallocate(elements_to_send) - call MPI_ISend(send_buffer(proc)%ptr, send_count-1, getpinteger(), & - proc-1, tag, comm, send_request(proc), ierr) - assert(ierr == MPI_SUCCESS) + end function create_combined_numbering_trailing_receives + + function expand_positions_halo(positions) result (new_positions) + type(vector_field), intent(in) :: positions + type(vector_field) :: new_positions + + type(mesh_type) :: new_mesh + + ewrite(1,*) "Inside expand_positions_halo" + + new_mesh = expand_mesh_halo(positions%mesh) + call allocate(new_positions, positions%dim, new_mesh, name=positions%name) + new_positions%val(:,1:node_count(positions)) = positions%val + call halo_update(new_positions) + call deallocate(new_mesh) + + ewrite(1,*) "Exiting expand_positions_halo" + + end function expand_positions_halo + + function expand_mesh_halo(mesh) result (new_mesh) + type(mesh_type), intent(in) :: mesh + type(mesh_type) :: new_mesh + + type(csr_sparsity), pointer :: nelist + type(halo_type), pointer :: old_halo, ele_halo + type(halo_type) :: new_halo + type(integer_hash_table) :: ueid_to_gid, uid_to_gid, ufid_to_gid + type(integer_set) :: elements_to_send + type(integer_vector), dimension(:), allocatable :: send_buffer, recv_buffer + integer, dimension(:), allocatable :: send_request + integer, dimension(:), pointer :: neigh, nodes, facets + integer, dimension(:), allocatable :: sndgln, boundary_ids, element_owners + integer, dimension(:), allocatable :: statuses + integer, dimension(MPI_STATUS_SIZE) :: status + integer :: comm, tag, ierr, nprocs + integer :: new_node_count, new_element_count, new_surface_element_count + integer :: nhalos, nloc, snloc, nfaces, send_count, recv_size + integer :: no_boundary_id, old_node_count + integer :: proc, ele, sele, ele_uid, ufid, i, j, ele_info_size, lface + logical :: has_surface_mesh, all_new_nodes + + ewrite(1,*) "Inside expand_mesh_halo" + nhalos = size(mesh%halos) + old_halo => mesh%halos(nhalos) + ele_halo => mesh%element_halos(size(mesh%element_halos)) + new_halo = expand_halo(mesh, old_halo) + + ! map from universal node id to global node id + call create_global_to_universal_numbering(new_halo) + call get_universal_numbering_inverse(new_halo, uid_to_gid) + call create_ownership(new_halo) + ! map from universal element id to global element id + call create_global_to_universal_numbering(ele_halo) + call get_universal_numbering_inverse(ele_halo, ueid_to_gid) + + old_node_count = node_count(mesh) + new_node_count = key_count(uid_to_gid) + assert(new_node_count==max_halo_receive_node(new_halo)) + new_element_count = element_count(mesh) ! we start with all existing elements + nloc = mesh%shape%loc + nfaces = mesh%shape%numbering%boundaries + ! things we send with each element: + ! 1) its universal element id + ! 2) its nodes (by uid) + ! if associated(mesh%faces): 3) the surface ids of adjacent facets + ele_info_size = 1+nloc + + has_surface_mesh = .false. + if (associated(mesh%faces)) then + if (associated(mesh%faces%boundary_ids)) then + has_surface_mesh = .true. + end if + end if - end do + if (has_surface_mesh) then + snloc = mesh%faces%shape%loc + ele_info_size = ele_info_size+nfaces + ! we have to agree on an id that means: this facet is not part of the surface mesh + no_boundary_id = minval(mesh%faces%boundary_ids) + call allmin(no_boundary_id) + no_boundary_id = no_boundary_id-1 + ! Coming out of the 3d adaptivity wrapper we don't trust all surface elements. + ! In order to lock the halo, the 3d wrapper has marked surface elements at the end of the halo + ! and when reconstructing the mesh object after the adapt these get added to the surface mesh. + ! Luckily, surface elements at the end of the halo can be identified as not having any owned nodes. + ! This is because of the logic in strip_l2_halo, where we keep any elements with owned nodes, so a halo + ! surface element must be adjacent to an element that doesn't have any owned nodes. Because we don't + ! trust the information about these, we simply drop them here and let adacent node owners send the + ! information again (it could for instance be that one of the surface elements is actually really + ! on the true surface mesh). + call allocate(ufid_to_gid) ! a map from universal facet ids to facet ids for the new mesh + new_surface_element_count = 0 + do i=1, unique_surface_element_count(mesh) + if (any(nodes_owned(old_halo, face_global_nodes(mesh, i)))) then + new_surface_element_count = new_surface_element_count+1 + ele = face_ele(mesh, i) + lface = local_face_number(mesh, i) + ! compute a universal facets numbering based on the universal element number + ufid = halo_universal_number(ele_halo, ele)*nfaces + lface + call insert(ufid_to_gid, ufid, new_surface_element_count) + end if + end do + end if - ! loop over the recv buffers to work out the numbering - ! for new elements and surface elements - do proc=1, nprocs - assert( (halo_send_count(new_halo, proc)==0) .eqv. (halo_receive_count(new_halo, proc)==0) ) - if (halo_receive_count(new_halo, proc)==0) cycle - call mpi_probe(proc-1, tag, comm, status, ierr) - assert(ierr == MPI_SUCCESS) + ! send and recv buffers for each processor + nprocs = halo_proc_count(old_halo) + comm = halo_communicator(old_halo) + tag = next_mpi_tag() + allocate(send_buffer(nprocs), send_request(nprocs)) + allocate(recv_buffer(nprocs)) + send_request = MPI_REQUEST_NULL + + ! loop over all new send nodes and send its adjacent elements + nelist => extract_nelist(mesh) + do proc=1, nprocs + if (halo_send_count(new_halo, proc)==0) cycle + call allocate(elements_to_send) + ! loop over all send nodes + do i=1, halo_send_count(new_halo, proc) + neigh => row_m_ptr(nelist, halo_send(new_halo, proc, i)) + call insert(elements_to_send, neigh) + end do + send_count = key_count(elements_to_send) + ! for each element, send its ueid and the uids of its nodes + ! and optionally, the surface ids of its facets + allocate(send_buffer(proc)%ptr(send_count*ele_info_size)) + send_count = 1 + do i=1, key_count(elements_to_send) + ele = fetch(elements_to_send, i) + ele_uid = halo_universal_number(ele_halo, ele) + send_buffer(proc)%ptr(send_count) = ele_uid + nodes => ele_nodes(mesh, ele) + send_buffer(proc)%ptr(send_count+1:send_count+size(nodes)) = halo_universal_number(new_halo, nodes) + send_count = send_count+1+size(nodes) + if (has_surface_mesh) then + facets => ele_faces(mesh, ele) + do j=1, size(facets) + ufid = ele_uid*nfaces+j + if (has_key(ufid_to_gid, ufid)) then + send_buffer(proc)%ptr(send_count+j-1) = surface_element_id(mesh, facets(j)) + else + send_buffer(proc)%ptr(send_count+j-1) = no_boundary_id + end if + end do + send_count = send_count+nfaces + end if + end do + assert(send_count==size(send_buffer(proc)%ptr)+1) + call deallocate(elements_to_send) - call mpi_get_count(status, getpinteger(), recv_size, ierr) - allocate(recv_buffer(proc)%ptr(1:recv_size)) + call MPI_ISend(send_buffer(proc)%ptr, send_count-1, getpinteger(), & + proc-1, tag, comm, send_request(proc), ierr) + assert(ierr == MPI_SUCCESS) - call MPI_Recv(recv_buffer(proc)%ptr, recv_size, getpinteger(), & - proc-1, tag, comm, status, ierr) - assert(ierr == MPI_SUCCESS) + end do - ele_loop: do i=1, recv_size/ele_info_size - ele_uid = recv_buffer(proc)%ptr((i-1)*ele_info_size+1) - if (.not. has_key(ueid_to_gid, ele_uid)) then - nodes => recv_buffer(proc)%ptr((i-1)*ele_info_size+2:(i-1)*ele_info_size+1+nloc) - ! we're only interested in this element if we know all its nodes: - all_new_nodes = .true. - do j=1, size(nodes) - if (.not. has_key(uid_to_gid, nodes(j))) cycle ele_loop - all_new_nodes = all_new_nodes .and. fetch(uid_to_gid, nodes(j))>old_node_count - end do - ! Additionaly, we also skip elements that consist of new nodes only - this is because - ! such elements can potentially become isolated (i.e. if all adjacent elements have a non-shared - ! node that is in an even higher level halo) - ! Elements consisting of the highest level halo nodes only, are typically not needed because - ! even elements adjacent to elements adjacent to such elements will still consist of nodes that are either - ! in the highest or in the one-but-highest level halo. Thus e.g. if we're regrowing an l2-halo, - ! elements adjacent to elements adjacent to an element consisting of l2-halo nodes only, still consists - ! of l1 or l2 halo nodes only and is thus not owned. Thus an l2-halo node only element is never in the - ! level 2 *element* halo. - if (all_new_nodes) cycle - new_element_count = new_element_count+1 - call insert(ueid_to_gid, ele_uid, new_element_count) - end if - if (has_surface_mesh) then - facets => recv_buffer(proc)%ptr((i-1)*ele_info_size+nloc+2:(i-1)*ele_info_size+1+nloc+nfaces) - do j=1, nfaces - if (facets(j)/=no_boundary_id) then - ufid = ele_uid*nfaces+j - if (.not. has_key(ufid_to_gid, ufid)) then - new_surface_element_count = new_surface_element_count+1 - call insert(ufid_to_gid, ufid, new_surface_element_count) - end if + ! loop over the recv buffers to work out the numbering + ! for new elements and surface elements + do proc=1, nprocs + assert( (halo_send_count(new_halo, proc)==0) .eqv. (halo_receive_count(new_halo, proc)==0) ) + if (halo_receive_count(new_halo, proc)==0) cycle + call mpi_probe(proc-1, tag, comm, status, ierr) + assert(ierr == MPI_SUCCESS) + + call mpi_get_count(status, getpinteger(), recv_size, ierr) + allocate(recv_buffer(proc)%ptr(1:recv_size)) + + call MPI_Recv(recv_buffer(proc)%ptr, recv_size, getpinteger(), & + proc-1, tag, comm, status, ierr) + assert(ierr == MPI_SUCCESS) + + ele_loop: do i=1, recv_size/ele_info_size + ele_uid = recv_buffer(proc)%ptr((i-1)*ele_info_size+1) + if (.not. has_key(ueid_to_gid, ele_uid)) then + nodes => recv_buffer(proc)%ptr((i-1)*ele_info_size+2:(i-1)*ele_info_size+1+nloc) + ! we're only interested in this element if we know all its nodes: + all_new_nodes = .true. + do j=1, size(nodes) + if (.not. has_key(uid_to_gid, nodes(j))) cycle ele_loop + all_new_nodes = all_new_nodes .and. fetch(uid_to_gid, nodes(j))>old_node_count + end do + ! Additionaly, we also skip elements that consist of new nodes only - this is because + ! such elements can potentially become isolated (i.e. if all adjacent elements have a non-shared + ! node that is in an even higher level halo) + ! Elements consisting of the highest level halo nodes only, are typically not needed because + ! even elements adjacent to elements adjacent to such elements will still consist of nodes that are either + ! in the highest or in the one-but-highest level halo. Thus e.g. if we're regrowing an l2-halo, + ! elements adjacent to elements adjacent to an element consisting of l2-halo nodes only, still consists + ! of l1 or l2 halo nodes only and is thus not owned. Thus an l2-halo node only element is never in the + ! level 2 *element* halo. + if (all_new_nodes) cycle + new_element_count = new_element_count+1 + call insert(ueid_to_gid, ele_uid, new_element_count) end if - end do - end if - end do ele_loop - end do - - ! make sure all sends are dealt with - allocate(statuses(1:MPI_STATUS_SIZE*nprocs)) - call MPI_WaitAll(nprocs, send_request, statuses, ierr) - assert(ierr==MPI_SUCCESS) - deallocate(statuses) - - ! now we know enough to allocate the new mesh - call allocate(new_mesh, new_node_count, key_count(ueid_to_gid), & - mesh%shape, name=mesh%name) - allocate(new_mesh%halos(nhalos+1)) - do i=1, nhalos - new_mesh%halos(i) = mesh%halos(i) - call incref(new_mesh%halos(i)) - end do - new_mesh%halos(nhalos+1) = new_halo - new_mesh%option_path = mesh%option_path - - ! start by copying over existing elements - do ele=1, element_count(mesh) - call set_ele_nodes(new_mesh, ele, ele_nodes(mesh, ele)) - end do - - if (has_surface_mesh) then - allocate(sndgln(1:key_count(ufid_to_gid)*snloc)) - allocate(boundary_ids(1:key_count(ufid_to_gid))) - if (has_discontinuous_internal_boundaries(mesh)) then - allocate(element_owners(1:size(boundary_ids))) - end if - ! first copy element from trusted (see above) existing surface facets - do i=1, unique_surface_element_count(mesh) - ele = face_ele(mesh, i) - lface = local_face_number(mesh, i) - ufid = halo_universal_number(ele_halo, ele)*nfaces + lface - if (has_key(ufid_to_gid, ufid)) then - ! this may include existing elements we don't trust (see above) - ! but in that case its info will be overwritten by sent info - sele = fetch(ufid_to_gid, ufid) - sndgln((sele-1)*snloc+1:sele*snloc) = face_global_nodes(mesh, i) - boundary_ids(sele) = surface_element_id(mesh, i) - if (has_discontinuous_internal_boundaries(mesh)) then - element_owners(sele) = ele - end if - end if + if (has_surface_mesh) then + facets => recv_buffer(proc)%ptr((i-1)*ele_info_size+nloc+2:(i-1)*ele_info_size+1+nloc+nfaces) + do j=1, nfaces + if (facets(j)/=no_boundary_id) then + ufid = ele_uid*nfaces+j + if (.not. has_key(ufid_to_gid, ufid)) then + new_surface_element_count = new_surface_element_count+1 + call insert(ufid_to_gid, ufid, new_surface_element_count) + end if + end if + end do + end if + end do ele_loop end do - end if - - ! now peel out the new elements from the recv buffers - do proc=1, nprocs - if (halo_receive_count(new_halo, proc)==0) cycle - recv_size = size(recv_buffer(proc)%ptr) - do i=1, recv_size/ele_info_size - ele_uid = recv_buffer(proc)%ptr((i-1)*ele_info_size+1) - if (has_key(ueid_to_gid, ele_uid)) then - ele = fetch(ueid_to_gid, ele_uid) - nodes => recv_buffer(proc)%ptr((i-1)*ele_info_size+2:(i-1)*ele_info_size+1+nloc) - call set_ele_nodes(new_mesh, ele, fetch(uid_to_gid, nodes)) - - if (has_surface_mesh) then - facets => recv_buffer(proc)%ptr((i-1)*ele_info_size+nloc+2:(i-1)*ele_info_size+1+nloc+nfaces) - nodes => ele_nodes(new_mesh, ele) ! nodes now in gids - do j=1, size(facets) - ufid = ele_uid*nfaces + j - if (facets(j)/=no_boundary_id .and. has_key(ufid_to_gid, ufid)) then - sele = fetch(ufid_to_gid, ufid) - sndgln((sele-1)*snloc+1:sele*snloc) = nodes(boundary_numbering(mesh%shape, j)) - boundary_ids(sele) = facets(j) - if (has_discontinuous_internal_boundaries(mesh)) then + ! make sure all sends are dealt with + allocate(statuses(1:MPI_STATUS_SIZE*nprocs)) + call MPI_WaitAll(nprocs, send_request, statuses, ierr) + assert(ierr==MPI_SUCCESS) + deallocate(statuses) + + ! now we know enough to allocate the new mesh + call allocate(new_mesh, new_node_count, key_count(ueid_to_gid), & + mesh%shape, name=mesh%name) + allocate(new_mesh%halos(nhalos+1)) + do i=1, nhalos + new_mesh%halos(i) = mesh%halos(i) + call incref(new_mesh%halos(i)) + end do + new_mesh%halos(nhalos+1) = new_halo + new_mesh%option_path = mesh%option_path + + ! start by copying over existing elements + do ele=1, element_count(mesh) + call set_ele_nodes(new_mesh, ele, ele_nodes(mesh, ele)) + end do + + if (has_surface_mesh) then + allocate(sndgln(1:key_count(ufid_to_gid)*snloc)) + allocate(boundary_ids(1:key_count(ufid_to_gid))) + if (has_discontinuous_internal_boundaries(mesh)) then + allocate(element_owners(1:size(boundary_ids))) + end if + ! first copy element from trusted (see above) existing surface facets + do i=1, unique_surface_element_count(mesh) + ele = face_ele(mesh, i) + lface = local_face_number(mesh, i) + ufid = halo_universal_number(ele_halo, ele)*nfaces + lface + if (has_key(ufid_to_gid, ufid)) then + ! this may include existing elements we don't trust (see above) + ! but in that case its info will be overwritten by sent info + sele = fetch(ufid_to_gid, ufid) + sndgln((sele-1)*snloc+1:sele*snloc) = face_global_nodes(mesh, i) + boundary_ids(sele) = surface_element_id(mesh, i) + if (has_discontinuous_internal_boundaries(mesh)) then element_owners(sele) = ele - end if - end if - end do - end if + end if + end if + end do + + end if - end if + ! now peel out the new elements from the recv buffers + do proc=1, nprocs + if (halo_receive_count(new_halo, proc)==0) cycle + recv_size = size(recv_buffer(proc)%ptr) + do i=1, recv_size/ele_info_size + ele_uid = recv_buffer(proc)%ptr((i-1)*ele_info_size+1) + if (has_key(ueid_to_gid, ele_uid)) then + ele = fetch(ueid_to_gid, ele_uid) + nodes => recv_buffer(proc)%ptr((i-1)*ele_info_size+2:(i-1)*ele_info_size+1+nloc) + call set_ele_nodes(new_mesh, ele, fetch(uid_to_gid, nodes)) + + if (has_surface_mesh) then + facets => recv_buffer(proc)%ptr((i-1)*ele_info_size+nloc+2:(i-1)*ele_info_size+1+nloc+nfaces) + nodes => ele_nodes(new_mesh, ele) ! nodes now in gids + do j=1, size(facets) + ufid = ele_uid*nfaces + j + if (facets(j)/=no_boundary_id .and. has_key(ufid_to_gid, ufid)) then + sele = fetch(ufid_to_gid, ufid) + sndgln((sele-1)*snloc+1:sele*snloc) = nodes(boundary_numbering(mesh%shape, j)) + boundary_ids(sele) = facets(j) + if (has_discontinuous_internal_boundaries(mesh)) then + element_owners(sele) = ele + end if + end if + end do + end if + + end if + end do + deallocate(recv_buffer(proc)%ptr) + deallocate(send_buffer(proc)%ptr) end do - deallocate(recv_buffer(proc)%ptr) - deallocate(send_buffer(proc)%ptr) - end do - - ewrite(2,*) "No. nodes before/after expanding halo:", node_count(mesh), node_count(new_mesh) - ewrite(2,*) "No. elements before/after expanding halo:", element_count(mesh), new_element_count - if (has_surface_mesh) then - ewrite(2,*) "No. surface elements before/after expanding halo:", surface_element_count(mesh), new_surface_element_count - if (has_discontinuous_internal_boundaries(mesh)) then - call add_faces(new_mesh, sndgln=sndgln, boundary_ids=boundary_ids, element_owner=element_owners) - else - call add_faces(new_mesh, sndgln=sndgln, boundary_ids=boundary_ids, & - allow_duplicate_internal_facets=.true.) + + ewrite(2,*) "No. nodes before/after expanding halo:", node_count(mesh), node_count(new_mesh) + ewrite(2,*) "No. elements before/after expanding halo:", element_count(mesh), new_element_count + if (has_surface_mesh) then + ewrite(2,*) "No. surface elements before/after expanding halo:", surface_element_count(mesh), new_surface_element_count + if (has_discontinuous_internal_boundaries(mesh)) then + call add_faces(new_mesh, sndgln=sndgln, boundary_ids=boundary_ids, element_owner=element_owners) + else + call add_faces(new_mesh, sndgln=sndgln, boundary_ids=boundary_ids, & + allow_duplicate_internal_facets=.true.) + end if end if - end if - call deallocate(uid_to_gid) - call deallocate(ueid_to_gid) - call deallocate(ufid_to_gid) + call deallocate(uid_to_gid) + call deallocate(ueid_to_gid) + call deallocate(ufid_to_gid) - allocate(new_mesh%element_halos(nhalos+1)) - call derive_element_halo_from_node_halo(new_mesh, & + allocate(new_mesh%element_halos(nhalos+1)) + call derive_element_halo_from_node_halo(new_mesh, & & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) - if (associated(mesh%region_ids)) then - ! now we can simply copy and halo update the region ids - allocate(new_mesh%region_ids(1:new_element_count)) - new_mesh%region_ids(1:element_count(mesh)) = mesh%region_ids - call halo_update(new_mesh%element_halos(nhalos+1), new_mesh%region_ids) - end if - - ewrite(1,*) "Exiting expand_mesh_halo" - - end function expand_mesh_halo - - function expand_halo(mesh, halo, name) result (new_halo) - !!< function that expands the halo one level further, starting - !!< from existing recv nodes, e.g. derive a level 2 halo from a level 1 halo - !!< This handles the case where these new recv nodes do not yet exist in - !!< the mesh. The new recv nodes are numbered after the current ones, - !!< i.e. node_count(mesh) extract_nnlist(mesh) - - ! adjacency count: how many nodes connected each node - allocate(adjacency_count(1:node_count(mesh))) - adjacency_count = 0 - ! set of all halo 1 nodes - call allocate(halo1_nodes) - - ! send and recv buffers for each processor - nprocs = halo_proc_count(halo) - comm = halo_communicator(halo) - tag = next_mpi_tag() - my_rank = getrank(comm) - allocate(send_buffer(nprocs), recv_buffer(nprocs)) - allocate(send_request(nprocs), recv_request(nprocs)) - send_request = MPI_REQUEST_NULL - recv_request = MPI_REQUEST_NULL - - ! record the adjacency count for halo1 send nodes - ! and allocate send buffers - do proc=1, nprocs - if (halo_send_count(halo, proc)==0) cycle - send_count = 0 - do i=1, halo_send_count(halo, proc) - node = halo_send(halo, proc, i) - nodes => row_m_ptr(nnlist, node) - adjacency_count(node) = size(nodes) - send_count = send_count+size(nodes) + if (associated(mesh%region_ids)) then + ! now we can simply copy and halo update the region ids + allocate(new_mesh%region_ids(1:new_element_count)) + new_mesh%region_ids(1:element_count(mesh)) = mesh%region_ids + call halo_update(new_mesh%element_halos(nhalos+1), new_mesh%region_ids) + end if + + ewrite(1,*) "Exiting expand_mesh_halo" + + end function expand_mesh_halo + + function expand_halo(mesh, halo, name) result (new_halo) + !!< function that expands the halo one level further, starting + !!< from existing recv nodes, e.g. derive a level 2 halo from a level 1 halo + !!< This handles the case where these new recv nodes do not yet exist in + !!< the mesh. The new recv nodes are numbered after the current ones, + !!< i.e. node_count(mesh) extract_nnlist(mesh) + + ! adjacency count: how many nodes connected each node + allocate(adjacency_count(1:node_count(mesh))) + adjacency_count = 0 + ! set of all halo 1 nodes + call allocate(halo1_nodes) + + ! send and recv buffers for each processor + nprocs = halo_proc_count(halo) + comm = halo_communicator(halo) + tag = next_mpi_tag() + my_rank = getrank(comm) + allocate(send_buffer(nprocs), recv_buffer(nprocs)) + allocate(send_request(nprocs), recv_request(nprocs)) + send_request = MPI_REQUEST_NULL + recv_request = MPI_REQUEST_NULL + + ! record the adjacency count for halo1 send nodes + ! and allocate send buffers + do proc=1, nprocs + if (halo_send_count(halo, proc)==0) cycle + send_count = 0 + do i=1, halo_send_count(halo, proc) + node = halo_send(halo, proc, i) + nodes => row_m_ptr(nnlist, node) + adjacency_count(node) = size(nodes) + send_count = send_count+size(nodes) + end do + ! for each entry in the nnlist we send a uid and an owner + allocate(send_buffer(proc)%ptr(send_count*2)) end do - ! for each entry in the nnlist we send a uid and an owner - allocate(send_buffer(proc)%ptr(send_count*2)) - end do - - ! by halo updating, we get the true adjacency count for halo1 recv nodes as well - call halo_update(halo, adjacency_count) - ! so we can allocate the recv buffers - ! and setup the mpi recv call - do proc=1, nprocs - if (halo_receive_count(halo, proc)==0) cycle - recv_count = 0 - do i=1, halo_receive_count(halo, proc) - node = halo_receive(halo, proc, i) - recv_count = recv_count+adjacency_count(node) - ! while we're at it, build up set of all halo 1 nodes - call insert(halo1_nodes, halo_universal_number(halo, node)) + + ! by halo updating, we get the true adjacency count for halo1 recv nodes as well + call halo_update(halo, adjacency_count) + ! so we can allocate the recv buffers + ! and setup the mpi recv call + do proc=1, nprocs + if (halo_receive_count(halo, proc)==0) cycle + recv_count = 0 + do i=1, halo_receive_count(halo, proc) + node = halo_receive(halo, proc, i) + recv_count = recv_count+adjacency_count(node) + ! while we're at it, build up set of all halo 1 nodes + call insert(halo1_nodes, halo_universal_number(halo, node)) + end do + allocate(recv_buffer(proc)%ptr(recv_count*2)) + call MPI_IRecv(recv_buffer(proc)%ptr, recv_count*2, getpinteger(), & + proc-1, tag, comm, recv_request(proc), ierr) + assert(ierr == MPI_SUCCESS) end do - allocate(recv_buffer(proc)%ptr(recv_count*2)) - call MPI_IRecv(recv_buffer(proc)%ptr, recv_count*2, getpinteger(), & - proc-1, tag, comm, recv_request(proc), ierr) - assert(ierr == MPI_SUCCESS) - end do - ! now pack the send buffers with uid and owner for each entry - ! in the nnlist around all halo1 send nodes, and send them off - do proc=1, nprocs - if (halo_send_count(halo, proc)==0) cycle - send_count = 0 - do i=1, halo_send_count(halo, proc) - node = halo_send(halo, proc, i) - nodes => row_m_ptr(nnlist, node) - send_buffer(proc)%ptr(send_count+1:send_count+size(nodes)) = halo_universal_number(halo, nodes) - send_count = send_count+size(nodes) - send_buffer(proc)%ptr(send_count+1:send_count+size(nodes)) = halo_node_owners(halo, nodes) - send_count = send_count+size(nodes) + ! now pack the send buffers with uid and owner for each entry + ! in the nnlist around all halo1 send nodes, and send them off + do proc=1, nprocs + if (halo_send_count(halo, proc)==0) cycle + send_count = 0 + do i=1, halo_send_count(halo, proc) + node = halo_send(halo, proc, i) + nodes => row_m_ptr(nnlist, node) + send_buffer(proc)%ptr(send_count+1:send_count+size(nodes)) = halo_universal_number(halo, nodes) + send_count = send_count+size(nodes) + send_buffer(proc)%ptr(send_count+1:send_count+size(nodes)) = halo_node_owners(halo, nodes) + send_count = send_count+size(nodes) + end do + assert(size(send_buffer(proc)%ptr)==send_count) + call MPI_ISend(send_buffer(proc)%ptr, send_count, getpinteger(), & + proc-1, tag, comm, send_request(proc), ierr) + assert(ierr == MPI_SUCCESS) + end do + + ! from the bits of nnlist that we've been sent, collect the new halo recv nodes we encounter + allocate(new_halo_recvs(nprocs)) + do proc=1, nprocs + call allocate(new_halo_recvs(proc)) end do - assert(size(send_buffer(proc)%ptr)==send_count) - call MPI_ISend(send_buffer(proc)%ptr, send_count, getpinteger(), & - proc-1, tag, comm, send_request(proc), ierr) - assert(ierr == MPI_SUCCESS) - end do - ! from the bits of nnlist that we've been sent, collect the new halo recv nodes we encounter - allocate(new_halo_recvs(nprocs)) - do proc=1, nprocs - call allocate(new_halo_recvs(proc)) - end do + do proc=1, nprocs + if (halo_receive_count(halo, proc)==0) cycle + call MPI_Wait(recv_request(proc), status, ierr) + assert(ierr==MPI_SUCCESS) + recv_count = 0 + do i=1, halo_receive_count(halo, proc) + node = halo_receive(halo, proc, i) + nnodes = adjacency_count(node) + do j=1, nnodes + uid = recv_buffer(proc)%ptr(recv_count+j) + owner = recv_buffer(proc)%ptr(recv_count+nnodes+j) + if (owner/=my_rank+1) then + if (.not. has_value(halo1_nodes, uid)) then + call insert(new_halo_recvs(owner), uid) + end if + end if + end do + recv_count = recv_count+2*nnodes + end do + assert(recv_count==size(recv_buffer(proc)%ptr)) + deallocate(recv_buffer(proc)%ptr) + end do + call deallocate(halo1_nodes) - do proc=1, nprocs - if (halo_receive_count(halo, proc)==0) cycle - call MPI_Wait(recv_request(proc), status, ierr) + ! before we move on to the next stage, make sure all our sends are done + ! so we don't mix anything up and we can reuse our buffers + allocate(statuses(1:MPI_STATUS_SIZE*nprocs)) + call MPI_WaitAll(nprocs, send_request, statuses, ierr) assert(ierr==MPI_SUCCESS) - recv_count = 0 - do i=1, halo_receive_count(halo, proc) - node = halo_receive(halo, proc, i) - nnodes = adjacency_count(node) - do j=1, nnodes - uid = recv_buffer(proc)%ptr(recv_count+j) - owner = recv_buffer(proc)%ptr(recv_count+nnodes+j) - if (owner/=my_rank+1) then - if (.not. has_value(halo1_nodes, uid)) then - call insert(new_halo_recvs(owner), uid) - end if - end if - end do - recv_count = recv_count+2*nnodes + do proc=1, nprocs + if (halo_send_count(halo, proc)/=0) then + deallocate(send_buffer(proc)%ptr) + end if end do - assert(recv_count==size(recv_buffer(proc)%ptr)) - deallocate(recv_buffer(proc)%ptr) - end do - call deallocate(halo1_nodes) - - ! before we move on to the next stage, make sure all our sends are done - ! so we don't mix anything up and we can reuse our buffers - allocate(statuses(1:MPI_STATUS_SIZE*nprocs)) - call MPI_WaitAll(nprocs, send_request, statuses, ierr) - assert(ierr==MPI_SUCCESS) - do proc=1, nprocs - if (halo_send_count(halo, proc)/=0) then - deallocate(send_buffer(proc)%ptr) - end if - end do - send_request = MPI_REQUEST_NULL ! reuse send_request as well - - ! so we've collected our new halo 2 recv nodes per process - ! now we need to tell these processes that we want these as recv nodes - tag = next_mpi_tag() - allocate(new_halo_recv_count(nprocs), new_halo_send_count(nprocs)) - do proc=1, nprocs - new_halo_recv_count(proc) = key_count(new_halo_recvs(proc)) - ! this assumes a symmetric communication pattern, where if processor A has - ! any recv nodes in the new expanded halo (which includes the old halo) from - ! proc B - then proc B has receive nodes of proc A in the new expanded halo. - ! for the case where we're expanding from halo1 to halo2: if proc. A - ! has halo1 recv nodes of proc. B, then trivially the node attached to - ! it owned by proc. A is a recv node for proc B. If proc A only has halo2 - ! recv nodes from proc B then such a node is connected to an owned node - ! via a inbetween node owned by a third proc. This means the node owned - ! by proc A is in the combined recv halo1+halo2 for proc B. NOTE that it - ! possible however that this node was already a halo1 node and is therefore - ! not a *new* halo2 node. See for instance the following scenario: - ! - ! A - B - ! | | where the 4 nodes are labeled with their ownership by either - ! C - B proc A and B, or the third owner C - ! - ! therefore we cannot assume that we only get a request for *new* halo2 nodes - ! if we request *new* halo2 nodes as well. We might get a request from - ! any proc that has halo1 recv nodes owned by us (i.e. halo1 send nodes). - ! - ! To make this more predictable we should therefore always send a request - ! (even if empty) to any proc for which we already have halo1 recv nodes - if (halo_receive_count(halo, proc)/=0 .or. new_halo_recv_count(proc)/=0) then - allocate(send_buffer(proc)%ptr(new_halo_recv_count(proc))) - send_buffer(proc)%ptr = set2vector(new_halo_recvs(proc)) - call MPI_ISend(send_buffer(proc)%ptr, new_halo_recv_count(proc), getpinteger(), & - proc-1, tag, comm, send_request(proc), ierr) - assert(ierr == MPI_SUCCESS) - end if - call deallocate(new_halo_recvs(proc)) - end do - - ! the same request from other processes will tell us our new halo 2 send nodes - do proc=1, nprocs - ! see comments above: we rely on this logic to be symmetric - ! and expect a request from any proc for which we have send nodes already or for - ! which we have new halo recv nodes - if (halo_send_count(halo, proc)/=0 .or. new_halo_recv_count(proc)/=0) then - call mpi_probe(proc-1, tag, comm, status, ierr) - assert(ierr == MPI_SUCCESS) - - call mpi_get_count(status, getpinteger(), new_halo_send_count(proc), ierr) - allocate(recv_buffer(proc)%ptr(new_halo_send_count(proc))) - - call MPI_Recv(recv_buffer(proc)%ptr, new_halo_send_count(proc), getpinteger(), & - proc-1, tag, comm, status, ierr) - assert(ierr == MPI_SUCCESS) - else - new_halo_send_count(proc) = 0 - end if - end do - - ! again make sure all sends are dealt with - call MPI_WaitAll(nprocs, send_request, statuses, ierr) - assert(ierr==MPI_SUCCESS) - deallocate(statuses) - deallocate(send_request) - deallocate(recv_request) - - ! the new halo should include the existing halo: - allocate(old_halo_count(nprocs)) - call halo_send_counts(halo, old_halo_count) - new_halo_send_count = new_halo_send_count+old_halo_count - call halo_receive_counts(halo, old_halo_count) - new_halo_recv_count = new_halo_recv_count+old_halo_count - - - ! we now have all the information to create a new halo nodal halo - call allocate(new_halo, new_halo_send_count, new_halo_recv_count, & - name=name, & - nowned_nodes = halo_nowned_nodes(halo), & - communicator = comm, data_type = halo%data_type) - call get_universal_numbering_inverse(halo, uid_to_gid) - assert(node_count(mesh)==key_count(uid_to_gid)) ! if this fails the old halo has duplicate nodes - new_node_count = node_count(mesh) ! counter to number new recv nodes - do proc=1, nprocs - if (new_halo_send_count(proc)/=0) then - allocate(buffer(1:new_halo_send_count(proc))) - buffer(1:halo_send_count(halo,proc)) = halo_sends(halo, proc) - buffer(halo_send_count(halo,proc)+1:) = fetch(uid_to_gid, recv_buffer(proc)%ptr) - call set_halo_sends(new_halo, proc, buffer) - deallocate(buffer) - - assert(new_halo_recv_count(proc)/=0) - allocate(buffer(1:new_halo_recv_count(proc))) - new_recv_count = new_halo_recv_count(proc) - halo_receive_count(halo, proc) - buffer(1:halo_receive_count(halo,proc)) = halo_receives(halo, proc) - buffer(halo_receive_count(halo,proc)+1:) = (/ ( i, i=new_node_count+1, new_node_count+new_recv_count)/) - call set_halo_receives(new_halo, proc, buffer) - deallocate(buffer) - deallocate(recv_buffer(proc)%ptr) - deallocate(send_buffer(proc)%ptr) - new_node_count = new_node_count + new_recv_count - end if - end do - call deallocate(uid_to_gid) - deallocate(new_halo_recv_count) - deallocate(new_halo_send_count) + send_request = MPI_REQUEST_NULL ! reuse send_request as well + + ! so we've collected our new halo 2 recv nodes per process + ! now we need to tell these processes that we want these as recv nodes + tag = next_mpi_tag() + allocate(new_halo_recv_count(nprocs), new_halo_send_count(nprocs)) + do proc=1, nprocs + new_halo_recv_count(proc) = key_count(new_halo_recvs(proc)) + ! this assumes a symmetric communication pattern, where if processor A has + ! any recv nodes in the new expanded halo (which includes the old halo) from + ! proc B - then proc B has receive nodes of proc A in the new expanded halo. + ! for the case where we're expanding from halo1 to halo2: if proc. A + ! has halo1 recv nodes of proc. B, then trivially the node attached to + ! it owned by proc. A is a recv node for proc B. If proc A only has halo2 + ! recv nodes from proc B then such a node is connected to an owned node + ! via a inbetween node owned by a third proc. This means the node owned + ! by proc A is in the combined recv halo1+halo2 for proc B. NOTE that it + ! possible however that this node was already a halo1 node and is therefore + ! not a *new* halo2 node. See for instance the following scenario: + ! + ! A - B + ! | | where the 4 nodes are labeled with their ownership by either + ! C - B proc A and B, or the third owner C + ! + ! therefore we cannot assume that we only get a request for *new* halo2 nodes + ! if we request *new* halo2 nodes as well. We might get a request from + ! any proc that has halo1 recv nodes owned by us (i.e. halo1 send nodes). + ! + ! To make this more predictable we should therefore always send a request + ! (even if empty) to any proc for which we already have halo1 recv nodes + if (halo_receive_count(halo, proc)/=0 .or. new_halo_recv_count(proc)/=0) then + allocate(send_buffer(proc)%ptr(new_halo_recv_count(proc))) + send_buffer(proc)%ptr = set2vector(new_halo_recvs(proc)) + call MPI_ISend(send_buffer(proc)%ptr, new_halo_recv_count(proc), getpinteger(), & + proc-1, tag, comm, send_request(proc), ierr) + assert(ierr == MPI_SUCCESS) + end if + call deallocate(new_halo_recvs(proc)) + end do + + ! the same request from other processes will tell us our new halo 2 send nodes + do proc=1, nprocs + ! see comments above: we rely on this logic to be symmetric + ! and expect a request from any proc for which we have send nodes already or for + ! which we have new halo recv nodes + if (halo_send_count(halo, proc)/=0 .or. new_halo_recv_count(proc)/=0) then + call mpi_probe(proc-1, tag, comm, status, ierr) + assert(ierr == MPI_SUCCESS) + + call mpi_get_count(status, getpinteger(), new_halo_send_count(proc), ierr) + allocate(recv_buffer(proc)%ptr(new_halo_send_count(proc))) + + call MPI_Recv(recv_buffer(proc)%ptr, new_halo_send_count(proc), getpinteger(), & + proc-1, tag, comm, status, ierr) + assert(ierr == MPI_SUCCESS) + else + new_halo_send_count(proc) = 0 + end if + end do + + ! again make sure all sends are dealt with + call MPI_WaitAll(nprocs, send_request, statuses, ierr) + assert(ierr==MPI_SUCCESS) + deallocate(statuses) + deallocate(send_request) + deallocate(recv_request) + + ! the new halo should include the existing halo: + allocate(old_halo_count(nprocs)) + call halo_send_counts(halo, old_halo_count) + new_halo_send_count = new_halo_send_count+old_halo_count + call halo_receive_counts(halo, old_halo_count) + new_halo_recv_count = new_halo_recv_count+old_halo_count + + + ! we now have all the information to create a new halo nodal halo + call allocate(new_halo, new_halo_send_count, new_halo_recv_count, & + name=name, & + nowned_nodes = halo_nowned_nodes(halo), & + communicator = comm, data_type = halo%data_type) + call get_universal_numbering_inverse(halo, uid_to_gid) + assert(node_count(mesh)==key_count(uid_to_gid)) ! if this fails the old halo has duplicate nodes + new_node_count = node_count(mesh) ! counter to number new recv nodes + do proc=1, nprocs + if (new_halo_send_count(proc)/=0) then + allocate(buffer(1:new_halo_send_count(proc))) + buffer(1:halo_send_count(halo,proc)) = halo_sends(halo, proc) + buffer(halo_send_count(halo,proc)+1:) = fetch(uid_to_gid, recv_buffer(proc)%ptr) + call set_halo_sends(new_halo, proc, buffer) + deallocate(buffer) + + assert(new_halo_recv_count(proc)/=0) + allocate(buffer(1:new_halo_recv_count(proc))) + new_recv_count = new_halo_recv_count(proc) - halo_receive_count(halo, proc) + buffer(1:halo_receive_count(halo,proc)) = halo_receives(halo, proc) + buffer(halo_receive_count(halo,proc)+1:) = (/ ( i, i=new_node_count+1, new_node_count+new_recv_count)/) + call set_halo_receives(new_halo, proc, buffer) + deallocate(buffer) + deallocate(recv_buffer(proc)%ptr) + deallocate(send_buffer(proc)%ptr) + new_node_count = new_node_count + new_recv_count + end if + end do + call deallocate(uid_to_gid) + deallocate(new_halo_recv_count) + deallocate(new_halo_send_count) - ewrite(1,*) "Exiting expand_halo" + ewrite(1,*) "Exiting expand_halo" - end function expand_halo + end function expand_halo - subroutine generate_surface_mesh_halos(full_mesh, surface_mesh, surface_nodes) - type(mesh_type), intent(in):: full_mesh - type(mesh_type), intent(inout):: surface_mesh - integer, dimension(:), intent(in):: surface_nodes + subroutine generate_surface_mesh_halos(full_mesh, surface_mesh, surface_nodes) + type(mesh_type), intent(in):: full_mesh + type(mesh_type), intent(inout):: surface_mesh + integer, dimension(:), intent(in):: surface_nodes - integer :: ihalo, nhalos + integer :: ihalo, nhalos - ewrite(1, *) "In generate_surface_mesh for mesh: ", trim(surface_mesh%name) + ewrite(1, *) "In generate_surface_mesh for mesh: ", trim(surface_mesh%name) - ! hm, is this only gonna work for p1cg fs+pressure? - assert(continuity(surface_mesh) == 0) - assert(.not. associated(surface_mesh%halos)) - assert(.not. associated(surface_mesh%element_halos)) + ! hm, is this only gonna work for p1cg fs+pressure? + assert(continuity(surface_mesh) == 0) + assert(.not. associated(surface_mesh%halos)) + assert(.not. associated(surface_mesh%element_halos)) - ! Initialise key MPI information: + ! Initialise key MPI information: - nhalos = halo_count(full_mesh) - ewrite(2,*) "Number of surface_mesh halos = ",nhalos + nhalos = halo_count(full_mesh) + ewrite(2,*) "Number of surface_mesh halos = ",nhalos - if(nhalos == 0) return + if(nhalos == 0) return - ! Allocate subdomain mesh halos: - allocate(surface_mesh%halos(nhalos)) + ! Allocate subdomain mesh halos: + allocate(surface_mesh%halos(nhalos)) - ! Derive subdomain_mesh halos: - do ihalo = 1, nhalos + ! Derive subdomain_mesh halos: + do ihalo = 1, nhalos - surface_mesh%halos(ihalo) = derive_sub_halo(full_mesh%halos(ihalo), surface_nodes) + surface_mesh%halos(ihalo) = derive_sub_halo(full_mesh%halos(ihalo), surface_nodes) - assert(trailing_receives_consistent(surface_mesh%halos(ihalo))) - assert(halo_valid_for_communication(surface_mesh%halos(ihalo))) - call create_global_to_universal_numbering(surface_mesh%halos(ihalo)) - call create_ownership(surface_mesh%halos(ihalo)) + assert(trailing_receives_consistent(surface_mesh%halos(ihalo))) + assert(halo_valid_for_communication(surface_mesh%halos(ihalo))) + call create_global_to_universal_numbering(surface_mesh%halos(ihalo)) + call create_ownership(surface_mesh%halos(ihalo)) - end do ! ihalo + end do ! ihalo - allocate(surface_mesh%element_halos(nhalos)) - ! the element order of the surface mesh will not be trailing receive - do we care? - call derive_element_halo_from_node_halo(surface_mesh, & - & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .true.) + allocate(surface_mesh%element_halos(nhalos)) + ! the element order of the surface mesh will not be trailing receive - do we care? + call derive_element_halo_from_node_halo(surface_mesh, & + & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .true.) - end subroutine generate_surface_mesh_halos + end subroutine generate_surface_mesh_halos end module halos_derivation diff --git a/femtools/Halos_Diagnostics.F90 b/femtools/Halos_Diagnostics.F90 index f783beb949..c002e59b60 100644 --- a/femtools/Halos_Diagnostics.F90 +++ b/femtools/Halos_Diagnostics.F90 @@ -27,67 +27,67 @@ #include "fdebug.h" module halos_diagnostics - !!< this module contains routines for diagnosing halo problems. - use shape_functions - use halo_data_types - use fields_data_types - use fields_base - use halos_numbering - use fields_allocates - use fields_manipulation - use vtk_interfaces - implicit none - - private - public write_universal_numbering + !!< this module contains routines for diagnosing halo problems. + use shape_functions + use halo_data_types + use fields_data_types + use fields_base + use halos_numbering + use fields_allocates + use fields_manipulation + use vtk_interfaces + implicit none + + private + public write_universal_numbering contains - subroutine write_universal_numbering(halo, mesh, position, name) - !!< Dump a vtu file containing the universal numbering of halo on mesh. - type(halo_type), intent(in) :: halo - type(mesh_type), intent(inout) :: mesh - type(vector_field), intent(in) :: position - character(len=*), intent(in) :: name + subroutine write_universal_numbering(halo, mesh, position, name) + !!< Dump a vtu file containing the universal numbering of halo on mesh. + type(halo_type), intent(in) :: halo + type(mesh_type), intent(inout) :: mesh + type(vector_field), intent(in) :: position + character(len=*), intent(in) :: name - type(scalar_field) :: field - type(mesh_type) :: lmesh - type(element_type) :: shape - integer :: node, ele + type(scalar_field) :: field + type(mesh_type) :: lmesh + type(element_type) :: shape + integer :: node, ele - assert(has_global_to_universal_numbering(halo)) + assert(has_global_to_universal_numbering(halo)) - if (halo%data_type==HALO_TYPE_ELEMENT) then - shape=make_element_shape(mesh%shape, degree=0) - lmesh=make_mesh(position%mesh, shape=shape, continuity=-1) - call allocate(field, lmesh, name="UniversalNumber") + if (halo%data_type==HALO_TYPE_ELEMENT) then + shape=make_element_shape(mesh%shape, degree=0) + lmesh=make_mesh(position%mesh, shape=shape, continuity=-1) + call allocate(field, lmesh, name="UniversalNumber") - ! Drop excess mesh and shape references - call deallocate(lmesh) - call deallocate(shape) + ! Drop excess mesh and shape references + call deallocate(lmesh) + call deallocate(shape) - ! Note that for degree 0 shape functions, nodes==elements - do ele=1, element_count(field) - call set(field, ele, real(halo_universal_number(halo, ele))) - end do + ! Note that for degree 0 shape functions, nodes==elements + do ele=1, element_count(field) + call set(field, ele, real(halo_universal_number(halo, ele))) + end do - else + else - lmesh=mesh - call allocate(field, mesh, name="UniversalNumber") + lmesh=mesh + call allocate(field, mesh, name="UniversalNumber") - ! Note that for degree 0 shape functions, nodes==elements - do node=1, node_count(field) - call set(field, node, real(halo_universal_number(halo, node))) - end do + ! Note that for degree 0 shape functions, nodes==elements + do node=1, node_count(field) + call set(field, node, real(halo_universal_number(halo, node))) + end do - end if + end if - call vtk_write_fields(name, position=position, model=lmesh,& - & sfields=(/field/)) + call vtk_write_fields(name, position=position, model=lmesh,& + & sfields=(/field/)) - call deallocate(field) + call deallocate(field) - end subroutine write_universal_numbering + end subroutine write_universal_numbering end module halos_diagnostics diff --git a/femtools/Halos_Numbering.F90 b/femtools/Halos_Numbering.F90 index f591cf365f..d2599c0d8c 100644 --- a/femtools/Halos_Numbering.F90 +++ b/femtools/Halos_Numbering.F90 @@ -29,751 +29,751 @@ module halos_numbering - use fldebug - use data_structures - use futils - use mpi_interfaces - use halo_data_types - use parallel_tools - use quicksort - use halos_base - use halos_debug - use halos_allocates - use halos_communications - - implicit none - - private - - public :: create_global_to_universal_numbering, & - & has_global_to_universal_numbering, universal_numbering_count, & - & halo_universal_number, halo_universal_numbers, get_universal_numbering, & - & get_universal_numbering_inverse, set_halo_universal_number, & - & ewrite_universal_numbers, valid_global_to_universal_numbering - - interface halo_universal_number - module procedure halo_universal_number, halo_universal_number_vector - end interface - - interface get_universal_numbering - module procedure get_universal_numbering, get_universal_numbering_multiple_components - end interface + use fldebug + use data_structures + use futils + use mpi_interfaces + use halo_data_types + use parallel_tools + use quicksort + use halos_base + use halos_debug + use halos_allocates + use halos_communications + + implicit none + + private + + public :: create_global_to_universal_numbering, & + & has_global_to_universal_numbering, universal_numbering_count, & + & halo_universal_number, halo_universal_numbers, get_universal_numbering, & + & get_universal_numbering_inverse, set_halo_universal_number, & + & ewrite_universal_numbers, valid_global_to_universal_numbering + + interface halo_universal_number + module procedure halo_universal_number, halo_universal_number_vector + end interface + + interface get_universal_numbering + module procedure get_universal_numbering, get_universal_numbering_multiple_components + end interface contains - subroutine create_global_to_universal_numbering(halo, local_only) - !!< Create the global to universal node numbering, and cache it on the halo - !!< - !!< If local_only is present and .true. then only the universal numbers - !!< for the owned nodes will be calculated. This is required when the - !!< halos are not yet consistent and the universal numbers are to be - !!< used to coordinate the halos. + subroutine create_global_to_universal_numbering(halo, local_only) + !!< Create the global to universal node numbering, and cache it on the halo + !!< + !!< If local_only is present and .true. then only the universal numbers + !!< for the owned nodes will be calculated. This is required when the + !!< halos are not yet consistent and the universal numbers are to be + !!< used to coordinate the halos. - type(halo_type), intent(inout) :: halo - logical, intent(in), optional :: local_only + type(halo_type), intent(inout) :: halo + logical, intent(in), optional :: local_only - !assert(halo_valid_for_communication(halo)) - assert(.not. pending_communication(halo)) + !assert(halo_valid_for_communication(halo)) + assert(.not. pending_communication(halo)) - if(has_global_to_universal_numbering(halo)) return + if(has_global_to_universal_numbering(halo)) return - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - call create_global_to_universal_numbering_order_general(halo, local_only) - case(HALO_ORDER_TRAILING_RECEIVES) - call create_global_to_universal_numbering_order_trailing_receives& - (halo, local_only) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + call create_global_to_universal_numbering_order_general(halo, local_only) + case(HALO_ORDER_TRAILING_RECEIVES) + call create_global_to_universal_numbering_order_trailing_receives& + (halo, local_only) + case default + FLAbort("Unrecognised halo ordering scheme") + end select #ifdef DDEBUG - if(.not. present_and_true(local_only)) then - assert(valid_global_to_universal_numbering(halo)) - end if + if(.not. present_and_true(local_only)) then + assert(valid_global_to_universal_numbering(halo)) + end if #endif - end subroutine create_global_to_universal_numbering + end subroutine create_global_to_universal_numbering - subroutine create_global_to_universal_numbering_order_general(halo, local_only) - type(halo_type), intent(inout) :: halo - logical, intent(in), optional :: local_only + subroutine create_global_to_universal_numbering_order_general(halo, local_only) + type(halo_type), intent(inout) :: halo + logical, intent(in), optional :: local_only #ifdef HAVE_MPI - integer :: communicator, i, ierr, nowned_nodes, nprocs, nreceives, nsends, & + integer :: communicator, i, ierr, nowned_nodes, nprocs, nreceives, nsends, & & rank, count, nnodes - integer, dimension(:), allocatable :: receive_types, requests,& - & send_types, statuses - logical, dimension(:), allocatable :: local_nodes - integer tag - - ewrite(1,*) "Creating universal numbering for a general order halo" - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - rank = getrank(communicator) - nowned_nodes = halo_nowned_nodes(halo) - - call set_universal_numbering_count(halo) - - ! Calculate the base universal node number for the owned nodes. The i th - ! owned node then has universal node number equal to the base + i. - call mpi_scan(nowned_nodes, halo%my_owned_nodes_unn_base, 1, getpinteger(), MPI_SUM, communicator, ierr) - assert(ierr == MPI_SUCCESS) - halo%my_owned_nodes_unn_base = halo%my_owned_nodes_unn_base - nowned_nodes - ! gather this information from/to all other processors: - allocate(halo%owned_nodes_unn_base(1:nprocs+1)) - call mpi_allgather(halo%my_owned_nodes_unn_base, 1, getpinteger(), & - halo%owned_nodes_unn_base, 1, getpinteger(), communicator, ierr) - assert(ierr == MPI_SUCCESS) - assert( halo%owned_nodes_unn_base(rank+1)==halo%my_owned_nodes_unn_base ) - ! extra entry for convenience, such that number of owned nodes on a process - ! can be derived from subtracting its unn_base from the next (similar to findrm): - halo%owned_nodes_unn_base(nprocs+1)=universal_numbering_count(halo) - assert( halo%owned_nodes_unn_base(nprocs)<=halo%owned_nodes_unn_base(nprocs+1) ) - - nnodes = node_count(halo) - - allocate(local_nodes(nnodes)) - local_nodes=.true. - assert(max_halo_receive_node(halo) <= nnodes) - do i = 1, nprocs - local_nodes(halo_receives(halo, i)) = .false. - end do - - allocate(halo%gnn_to_unn(nnodes)) - halo%gnn_to_unn=-1 - - count=halo%my_owned_nodes_unn_base - do i=1, nnodes - if (local_nodes(i)) then - count=count+1 - halo%gnn_to_unn(i)=count - end if - end do - - if (present_and_true(local_only)) then - return - end if - - ! Create indexed MPI types defining the indices into halo%gnn_to_unn to be sent/received - allocate(send_types(nprocs)) - allocate(receive_types(nprocs)) - send_types = MPI_DATATYPE_NULL - receive_types = MPI_DATATYPE_NULL - do i = 1, nprocs - nsends = halo_send_count(halo, i) - if(nsends > 0) then - call mpi_type_create_indexed_block(nsends, 1, & - & halo_sends(halo, i) - lbound(halo%gnn_to_unn, 1), & - & getpinteger(), send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + integer, dimension(:), allocatable :: receive_types, requests,& + & send_types, statuses + logical, dimension(:), allocatable :: local_nodes + integer tag + + ewrite(1,*) "Creating universal numbering for a general order halo" + + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) + rank = getrank(communicator) + nowned_nodes = halo_nowned_nodes(halo) + + call set_universal_numbering_count(halo) + + ! Calculate the base universal node number for the owned nodes. The i th + ! owned node then has universal node number equal to the base + i. + call mpi_scan(nowned_nodes, halo%my_owned_nodes_unn_base, 1, getpinteger(), MPI_SUM, communicator, ierr) + assert(ierr == MPI_SUCCESS) + halo%my_owned_nodes_unn_base = halo%my_owned_nodes_unn_base - nowned_nodes + ! gather this information from/to all other processors: + allocate(halo%owned_nodes_unn_base(1:nprocs+1)) + call mpi_allgather(halo%my_owned_nodes_unn_base, 1, getpinteger(), & + halo%owned_nodes_unn_base, 1, getpinteger(), communicator, ierr) + assert(ierr == MPI_SUCCESS) + assert( halo%owned_nodes_unn_base(rank+1)==halo%my_owned_nodes_unn_base ) + ! extra entry for convenience, such that number of owned nodes on a process + ! can be derived from subtracting its unn_base from the next (similar to findrm): + halo%owned_nodes_unn_base(nprocs+1)=universal_numbering_count(halo) + assert( halo%owned_nodes_unn_base(nprocs)<=halo%owned_nodes_unn_base(nprocs+1) ) + + nnodes = node_count(halo) + + allocate(local_nodes(nnodes)) + local_nodes=.true. + assert(max_halo_receive_node(halo) <= nnodes) + do i = 1, nprocs + local_nodes(halo_receives(halo, i)) = .false. + end do - nreceives = halo_receive_count(halo, i) - if(nreceives > 0) then - call mpi_type_create_indexed_block(nreceives, 1, & - & halo_receives(halo, i) - lbound(halo%gnn_to_unn, 1), & - & getpinteger(), receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Set up non-blocking communications - allocate(requests(nprocs * 2)) - requests = MPI_REQUEST_NULL - tag = next_mpi_tag() - - do i = 1, nprocs - ! Non-blocking sends - if(halo_send_count(halo, i) > 0) then - call mpi_isend(halo%gnn_to_unn, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + allocate(halo%gnn_to_unn(nnodes)) + halo%gnn_to_unn=-1 - ! Non-blocking receives - if(halo_receive_count(halo, i) > 0) then - call mpi_irecv(halo%gnn_to_unn, 1, receive_types(i), i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - ! Free the indexed MPI types - do i = 1, nprocs - if(send_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + count=halo%my_owned_nodes_unn_base + do i=1, nnodes + if (local_nodes(i)) then + count=count+1 + halo%gnn_to_unn(i)=count + end if + end do - if(receive_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(receive_types(i), ierr) - assert(ierr == MPI_SUCCESS) + if (present_and_true(local_only)) then + return end if - end do - deallocate(send_types) - deallocate(receive_types) + + ! Create indexed MPI types defining the indices into halo%gnn_to_unn to be sent/received + allocate(send_types(nprocs)) + allocate(receive_types(nprocs)) + send_types = MPI_DATATYPE_NULL + receive_types = MPI_DATATYPE_NULL + do i = 1, nprocs + nsends = halo_send_count(halo, i) + if(nsends > 0) then + call mpi_type_create_indexed_block(nsends, 1, & + & halo_sends(halo, i) - lbound(halo%gnn_to_unn, 1), & + & getpinteger(), send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + nreceives = halo_receive_count(halo, i) + if(nreceives > 0) then + call mpi_type_create_indexed_block(nreceives, 1, & + & halo_receives(halo, i) - lbound(halo%gnn_to_unn, 1), & + & getpinteger(), receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Set up non-blocking communications + allocate(requests(nprocs * 2)) + requests = MPI_REQUEST_NULL + tag = next_mpi_tag() + + do i = 1, nprocs + ! Non-blocking sends + if(halo_send_count(halo, i) > 0) then + call mpi_isend(halo%gnn_to_unn, 1, send_types(i), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(halo_receive_count(halo, i) > 0) then + call mpi_irecv(halo%gnn_to_unn, 1, receive_types(i), i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + ! Free the indexed MPI types + do i = 1, nprocs + if(send_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + if(receive_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(receive_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + deallocate(send_types) + deallocate(receive_types) #else - if(valid_serial_halo(halo)) then - allocate(halo%owned_nodes_unn_base(halo_proc_count(halo))) - halo%owned_nodes_unn_base = 0 - halo%my_owned_nodes_unn_base = 0 - allocate(halo%receives_gnn_to_unn(halo_all_receives_count(halo))) - else - FLAbort("Cannot create global to universal numbering without MPI support") - end if + if(valid_serial_halo(halo)) then + allocate(halo%owned_nodes_unn_base(halo_proc_count(halo))) + halo%owned_nodes_unn_base = 0 + halo%my_owned_nodes_unn_base = 0 + allocate(halo%receives_gnn_to_unn(halo_all_receives_count(halo))) + else + FLAbort("Cannot create global to universal numbering without MPI support") + end if #endif - end subroutine create_global_to_universal_numbering_order_general + end subroutine create_global_to_universal_numbering_order_general - subroutine create_global_to_universal_numbering_order_trailing_receives& - (halo, local_only) - type(halo_type), intent(inout) :: halo - logical, intent(in), optional :: local_only + subroutine create_global_to_universal_numbering_order_trailing_receives& + (halo, local_only) + type(halo_type), intent(inout) :: halo + logical, intent(in), optional :: local_only #ifdef HAVE_MPI - integer :: communicator, i, ierr, nowned_nodes, nprocs, rank - integer, dimension(:), allocatable :: requests, statuses - type(integer_vector), dimension(:), allocatable :: receives_unn, sends_unn - integer tag - - ewrite(1,*) "Creating universal numbering for a trailing receives halo" - assert(trailing_receives_consistent(halo)) - assert(halo_valid_for_communication(halo)) - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - rank = getrank(communicator) - nowned_nodes = halo_nowned_nodes(halo) - - call set_universal_numbering_count(halo) - - ! Calculate the base universal node number for the owned nodes. The i th - ! owned node then has universal node number equal to the base + i. - call mpi_scan(nowned_nodes, halo%my_owned_nodes_unn_base, 1, getpinteger(), MPI_SUM, communicator, ierr) - assert(ierr == MPI_SUCCESS) - halo%my_owned_nodes_unn_base = halo%my_owned_nodes_unn_base - nowned_nodes - ! gather this information from/to all other processors: - allocate(halo%owned_nodes_unn_base(1:nprocs+1)) - call mpi_allgather(halo%my_owned_nodes_unn_base, 1, getpinteger(), & - halo%owned_nodes_unn_base, 1, getpinteger(), communicator, ierr) - assert(ierr == MPI_SUCCESS) - assert( halo%owned_nodes_unn_base(rank+1)==halo%my_owned_nodes_unn_base ) - ! extra entry for convenience, such that number of owned nodes on a process - ! can be derived from subtracting its unn_base from the next (similar to findrm): - halo%owned_nodes_unn_base(nprocs+1)=universal_numbering_count(halo) - assert( halo%owned_nodes_unn_base(nprocs)<=halo%owned_nodes_unn_base(nprocs+1) ) - - ewrite(2, "(a,i0)") "Owned nodes universal node number base = ", & + integer :: communicator, i, ierr, nowned_nodes, nprocs, rank + integer, dimension(:), allocatable :: requests, statuses + type(integer_vector), dimension(:), allocatable :: receives_unn, sends_unn + integer tag + + ewrite(1,*) "Creating universal numbering for a trailing receives halo" + assert(trailing_receives_consistent(halo)) + assert(halo_valid_for_communication(halo)) + + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) + rank = getrank(communicator) + nowned_nodes = halo_nowned_nodes(halo) + + call set_universal_numbering_count(halo) + + ! Calculate the base universal node number for the owned nodes. The i th + ! owned node then has universal node number equal to the base + i. + call mpi_scan(nowned_nodes, halo%my_owned_nodes_unn_base, 1, getpinteger(), MPI_SUM, communicator, ierr) + assert(ierr == MPI_SUCCESS) + halo%my_owned_nodes_unn_base = halo%my_owned_nodes_unn_base - nowned_nodes + ! gather this information from/to all other processors: + allocate(halo%owned_nodes_unn_base(1:nprocs+1)) + call mpi_allgather(halo%my_owned_nodes_unn_base, 1, getpinteger(), & + halo%owned_nodes_unn_base, 1, getpinteger(), communicator, ierr) + assert(ierr == MPI_SUCCESS) + assert( halo%owned_nodes_unn_base(rank+1)==halo%my_owned_nodes_unn_base ) + ! extra entry for convenience, such that number of owned nodes on a process + ! can be derived from subtracting its unn_base from the next (similar to findrm): + halo%owned_nodes_unn_base(nprocs+1)=universal_numbering_count(halo) + assert( halo%owned_nodes_unn_base(nprocs)<=halo%owned_nodes_unn_base(nprocs+1) ) + + ewrite(2, "(a,i0)") "Owned nodes universal node number base = ", & & halo%my_owned_nodes_unn_base - ewrite(2, "(a,i0)") "Total receive_nodes = ", halo_all_receives_count(halo) - allocate(halo%receives_gnn_to_unn(halo_all_receives_count(halo))) - - if(present_and_true(local_only)) then - halo%receives_gnn_to_unn = -1 - return - end if - - ! Communicate the universal node numbers of the receive nodes across - ! processes - allocate(sends_unn(nprocs)) - do i = 1, nprocs - allocate(sends_unn(i)%ptr(halo_send_count(halo, i))) - sends_unn(i)%ptr = halo%my_owned_nodes_unn_base + halo_sends(halo, i) - assert(all(sends_unn(i)%ptr > halo%my_owned_nodes_unn_base .and. sends_unn(i)%ptr <= halo%my_owned_nodes_unn_base + nowned_nodes)) - end do - allocate(receives_unn(nprocs)) - allocate(requests(nprocs * 2)) - requests = MPI_REQUEST_NULL - rank = getrank(communicator) - tag = next_mpi_tag() - do i = 1, nprocs - allocate(receives_unn(i)%ptr(halo_receive_count(halo, i))) - - ! Non-blocking sends - if(halo_send_count(halo, i) > 0) then - call mpi_isend(sends_unn(i)%ptr, size(sends_unn(i)%ptr), getpinteger(), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - end if + ewrite(2, "(a,i0)") "Total receive_nodes = ", halo_all_receives_count(halo) + allocate(halo%receives_gnn_to_unn(halo_all_receives_count(halo))) - ! Non-blocking receives - if(halo_receive_count(halo, i) > 0) then - call mpi_irecv(receives_unn(i)%ptr, halo_receive_count(halo, i),& - & getpinteger(), i - 1, tag, communicator, requests(i +& - & nprocs), ierr) - assert(ierr == MPI_SUCCESS) + if(present_and_true(local_only)) then + halo%receives_gnn_to_unn = -1 + return end if - end do - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) + ! Communicate the universal node numbers of the receive nodes across + ! processes + allocate(sends_unn(nprocs)) + do i = 1, nprocs + allocate(sends_unn(i)%ptr(halo_send_count(halo, i))) + sends_unn(i)%ptr = halo%my_owned_nodes_unn_base + halo_sends(halo, i) + assert(all(sends_unn(i)%ptr > halo%my_owned_nodes_unn_base .and. sends_unn(i)%ptr <= halo%my_owned_nodes_unn_base + nowned_nodes)) + end do + allocate(receives_unn(nprocs)) + allocate(requests(nprocs * 2)) + requests = MPI_REQUEST_NULL + rank = getrank(communicator) + tag = next_mpi_tag() + do i = 1, nprocs + allocate(receives_unn(i)%ptr(halo_receive_count(halo, i))) + + ! Non-blocking sends + if(halo_send_count(halo, i) > 0) then + call mpi_isend(sends_unn(i)%ptr, size(sends_unn(i)%ptr), getpinteger(), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(halo_receive_count(halo, i) > 0) then + call mpi_irecv(receives_unn(i)%ptr, halo_receive_count(halo, i),& + & getpinteger(), i - 1, tag, communicator, requests(i +& + & nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) + deallocate(statuses) + deallocate(requests) - do i = 1, nprocs - assert(all(receives_unn(i)%ptr <= halo%my_owned_nodes_unn_base .or. receives_unn(i)%ptr > halo%my_owned_nodes_unn_base + nowned_nodes)) - halo%receives_gnn_to_unn(halo_receives(halo, i) - nowned_nodes) = receives_unn(i)%ptr - deallocate(sends_unn(i)%ptr) - deallocate(receives_unn(i)%ptr) - end do - deallocate(sends_unn) - deallocate(receives_unn) + do i = 1, nprocs + assert(all(receives_unn(i)%ptr <= halo%my_owned_nodes_unn_base .or. receives_unn(i)%ptr > halo%my_owned_nodes_unn_base + nowned_nodes)) + halo%receives_gnn_to_unn(halo_receives(halo, i) - nowned_nodes) = receives_unn(i)%ptr + deallocate(sends_unn(i)%ptr) + deallocate(receives_unn(i)%ptr) + end do + deallocate(sends_unn) + deallocate(receives_unn) #else - if(valid_serial_halo(halo)) then - allocate(halo%owned_nodes_unn_base(halo_proc_count(halo))) - halo%owned_nodes_unn_base = 0 - halo%my_owned_nodes_unn_base = 0 - allocate(halo%receives_gnn_to_unn(halo_all_receives_count(halo))) - else - FLAbort("Cannot create global to universal numbering without MPI support") - end if + if(valid_serial_halo(halo)) then + allocate(halo%owned_nodes_unn_base(halo_proc_count(halo))) + halo%owned_nodes_unn_base = 0 + halo%my_owned_nodes_unn_base = 0 + allocate(halo%receives_gnn_to_unn(halo_all_receives_count(halo))) + else + FLAbort("Cannot create global to universal numbering without MPI support") + end if #endif - end subroutine create_global_to_universal_numbering_order_trailing_receives + end subroutine create_global_to_universal_numbering_order_trailing_receives - function valid_global_to_universal_numbering(halo) result(valid) - !!< Return whether the global to universal numbering cache for the supplied - !!< halo is valid + function valid_global_to_universal_numbering(halo) result(valid) + !!< Return whether the global to universal numbering cache for the supplied + !!< halo is valid - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: valid + logical :: valid - integer, dimension(node_count(halo)) :: unns + integer, dimension(node_count(halo)) :: unns - call get_universal_numbering(halo, unns) - valid = halo_verifies(halo, unns) + call get_universal_numbering(halo, unns) + valid = halo_verifies(halo, unns) - end function valid_global_to_universal_numbering + end function valid_global_to_universal_numbering - function has_global_to_universal_numbering(halo) result(has_gnn_to_unn) - !!< Return whether the supplied halo has global to universal node numbering - !!< data + function has_global_to_universal_numbering(halo) result(has_gnn_to_unn) + !!< Return whether the supplied halo has global to universal node numbering + !!< data - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: has_gnn_to_unn + logical :: has_gnn_to_unn - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - has_gnn_to_unn = associated(halo%owned_nodes_unn_base) + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + has_gnn_to_unn = associated(halo%owned_nodes_unn_base) #ifdef DDEBUG - if(has_gnn_to_unn) then - assert(associated(halo%gnn_to_unn)) - assert(halo%my_owned_nodes_unn_base>=0) - end if + if(has_gnn_to_unn) then + assert(associated(halo%gnn_to_unn)) + assert(halo%my_owned_nodes_unn_base>=0) + end if #endif - case(HALO_ORDER_TRAILING_RECEIVES) - has_gnn_to_unn = associated(halo%receives_gnn_to_unn) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + case(HALO_ORDER_TRAILING_RECEIVES) + has_gnn_to_unn = associated(halo%receives_gnn_to_unn) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end function has_global_to_universal_numbering + end function has_global_to_universal_numbering - pure function universal_numbering_count(halo) result(unn_count) - !!< Return the global (universal) number of nodes + pure function universal_numbering_count(halo) result(unn_count) + !!< Return the global (universal) number of nodes - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - integer :: unn_count + integer :: unn_count - unn_count = halo%unn_count + unn_count = halo%unn_count - end function universal_numbering_count + end function universal_numbering_count - subroutine set_universal_numbering_count(halo) - !!< Set the universal numbering count for the supplied halo + subroutine set_universal_numbering_count(halo) + !!< Set the universal numbering count for the supplied halo - type(halo_type), intent(inout) :: halo + type(halo_type), intent(inout) :: halo - halo%unn_count = halo_nowned_nodes(halo) - call allsum(halo%unn_count, communicator = halo_communicator(halo)) + halo%unn_count = halo_nowned_nodes(halo) + call allsum(halo%unn_count, communicator = halo_communicator(halo)) - end subroutine set_universal_numbering_count + end subroutine set_universal_numbering_count - function halo_universal_number(halo, global_number) result(unn) - !!< For the supplied halo, return the corresponding universal node number - !!< for the supplied global node number + function halo_universal_number(halo, global_number) result(unn) + !!< For the supplied halo, return the corresponding universal node number + !!< for the supplied global node number - type(halo_type), intent(in) :: halo - integer, intent(in) :: global_number + type(halo_type), intent(in) :: halo + integer, intent(in) :: global_number - integer :: unn + integer :: unn - assert(global_number > 0) + assert(global_number > 0) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - unn = halo_universal_number_order_general(halo, global_number) - case(HALO_ORDER_TRAILING_RECEIVES) - unn = halo_universal_number_order_trailing_receives(halo, global_number) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + unn = halo_universal_number_order_general(halo, global_number) + case(HALO_ORDER_TRAILING_RECEIVES) + unn = halo_universal_number_order_trailing_receives(halo, global_number) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end function halo_universal_number + end function halo_universal_number - function halo_universal_number_vector(halo, global_number) result(unn) - !!< Version of halo_universal_number which returns a vector of - !!< universal numbers corresponding to the supplied vector of global - !!< numbers. - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(in) :: global_number + function halo_universal_number_vector(halo, global_number) result(unn) + !!< Version of halo_universal_number which returns a vector of + !!< universal numbers corresponding to the supplied vector of global + !!< numbers. + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(in) :: global_number - integer, dimension(size(global_number)) :: unn + integer, dimension(size(global_number)) :: unn - integer :: i + integer :: i - do i = 1, size(global_number) - unn(i) = halo_universal_number(halo, global_number(i)) - end do + do i = 1, size(global_number) + unn(i) = halo_universal_number(halo, global_number(i)) + end do - end function halo_universal_number_vector + end function halo_universal_number_vector - function halo_universal_number_order_general(halo, global_number) result(unn) - type(halo_type), intent(in) :: halo - integer, intent(in) :: global_number + function halo_universal_number_order_general(halo, global_number) result(unn) + type(halo_type), intent(in) :: halo + integer, intent(in) :: global_number - integer :: unn + integer :: unn - assert(has_global_to_universal_numbering(halo)) - if (global_number<=size(halo%gnn_to_unn)) then - unn = halo%gnn_to_unn(global_number) - else - unn = -1 - end if + assert(has_global_to_universal_numbering(halo)) + if (global_number<=size(halo%gnn_to_unn)) then + unn = halo%gnn_to_unn(global_number) + else + unn = -1 + end if - end function halo_universal_number_order_general + end function halo_universal_number_order_general - function halo_universal_number_order_trailing_receives(halo, global_number) result(unn) - type(halo_type), intent(in) :: halo - integer, intent(in) :: global_number + function halo_universal_number_order_trailing_receives(halo, global_number) result(unn) + type(halo_type), intent(in) :: halo + integer, intent(in) :: global_number - integer :: unn + integer :: unn - assert(has_global_to_universal_numbering(halo)) + assert(has_global_to_universal_numbering(halo)) - if(global_number <= halo_nowned_nodes(halo)) then - unn = halo%my_owned_nodes_unn_base + global_number - else if(global_number - halo_nowned_nodes(halo) > size(halo%receives_gnn_to_unn)) then - unn = - 1 - else - unn = halo%receives_gnn_to_unn(global_number - halo_nowned_nodes(halo)) - end if + if(global_number <= halo_nowned_nodes(halo)) then + unn = halo%my_owned_nodes_unn_base + global_number + else if(global_number - halo_nowned_nodes(halo) > size(halo%receives_gnn_to_unn)) then + unn = - 1 + else + unn = halo%receives_gnn_to_unn(global_number - halo_nowned_nodes(halo)) + end if - end function halo_universal_number_order_trailing_receives + end function halo_universal_number_order_trailing_receives - function halo_universal_numbers(halo, global_numbers) result(unns) - !!< For the supplied halo, return the corresponding universal node numbers - !!< for the supplied global node numbers + function halo_universal_numbers(halo, global_numbers) result(unns) + !!< For the supplied halo, return the corresponding universal node numbers + !!< for the supplied global node numbers - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(in) :: global_numbers + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(in) :: global_numbers - integer :: i - integer, dimension(size(global_numbers)) :: unns + integer :: i + integer, dimension(size(global_numbers)) :: unns - do i = 1, size(global_numbers) - unns(i) = halo_universal_number(halo, global_numbers(i)) - end do + do i = 1, size(global_numbers) + unns(i) = halo_universal_number(halo, global_numbers(i)) + end do - end function halo_universal_numbers + end function halo_universal_numbers - subroutine get_universal_numbering(halo, unns) - !!< For the supplied halo, retrieve the complete universal node numbering - !!< list + subroutine get_universal_numbering(halo, unns) + !!< For the supplied halo, retrieve the complete universal node numbering + !!< list - type(halo_type), intent(in) :: halo - integer, dimension(node_count(halo)), intent(out) :: unns + type(halo_type), intent(in) :: halo + integer, dimension(node_count(halo)), intent(out) :: unns - assert(has_global_to_universal_numbering(halo)) + assert(has_global_to_universal_numbering(halo)) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - call get_universal_numbering_order_general(halo, unns) - case(HALO_ORDER_TRAILING_RECEIVES) - call get_universal_numbering_order_trailing_receives(halo, unns) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + call get_universal_numbering_order_general(halo, unns) + case(HALO_ORDER_TRAILING_RECEIVES) + call get_universal_numbering_order_trailing_receives(halo, unns) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine get_universal_numbering + end subroutine get_universal_numbering - subroutine get_universal_numbering_order_general(halo, unns) - type(halo_type), intent(in) :: halo - integer, dimension(node_count(halo)), intent(out) :: unns + subroutine get_universal_numbering_order_general(halo, unns) + type(halo_type), intent(in) :: halo + integer, dimension(node_count(halo)), intent(out) :: unns - unns=halo%gnn_to_unn + unns=halo%gnn_to_unn - end subroutine get_universal_numbering_order_general + end subroutine get_universal_numbering_order_general - subroutine get_universal_numbering_order_trailing_receives(halo, unns) - type(halo_type), intent(in) :: halo - integer, dimension(node_count(halo)), intent(out) :: unns + subroutine get_universal_numbering_order_trailing_receives(halo, unns) + type(halo_type), intent(in) :: halo + integer, dimension(node_count(halo)), intent(out) :: unns - integer :: i + integer :: i - assert(trailing_receives_consistent(halo)) + assert(trailing_receives_consistent(halo)) - unns = -1 - do i = 1, halo_nowned_nodes(halo) - unns(i) = halo%my_owned_nodes_unn_base + i - end do - unns(halo_nowned_nodes(halo) + 1:& + unns = -1 + do i = 1, halo_nowned_nodes(halo) + unns(i) = halo%my_owned_nodes_unn_base + i + end do + unns(halo_nowned_nodes(halo) + 1:& halo_nowned_nodes(halo) + size(halo%receives_gnn_to_unn)) = & halo%receives_gnn_to_unn - end subroutine get_universal_numbering_order_trailing_receives + end subroutine get_universal_numbering_order_trailing_receives - subroutine get_universal_numbering_multiple_components(halo, unns) - !!< For the supplied halo, retrieve the complete universal numbering - !!< of the degrees of freedom in a multi-component field, - !!< in such a way that the universal ordering is: - !!< - 1st component of all owned nodes on process 0 - !!< - 2nd component of all owned nodes on process 0 - !!< - ... - !!< - n-th component of all owned nodes on process 0 - !!< - 1st component of all owned nodes on process 1 - !!< - ... - !!< - n-th component of all owned nodes on the last process - !!< The number of components n is determined by size(unns,2) + subroutine get_universal_numbering_multiple_components(halo, unns) + !!< For the supplied halo, retrieve the complete universal numbering + !!< of the degrees of freedom in a multi-component field, + !!< in such a way that the universal ordering is: + !!< - 1st component of all owned nodes on process 0 + !!< - 2nd component of all owned nodes on process 0 + !!< - ... + !!< - n-th component of all owned nodes on process 0 + !!< - 1st component of all owned nodes on process 1 + !!< - ... + !!< - n-th component of all owned nodes on the last process + !!< The number of components n is determined by size(unns,2) - type(halo_type), intent(in) :: halo - integer, dimension(:,:), intent(out) :: unns + type(halo_type), intent(in) :: halo + integer, dimension(:,:), intent(out) :: unns - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - call get_unn_multiple_components_order_general(halo, unns) - case(HALO_ORDER_TRAILING_RECEIVES) - call get_unn_multiple_components_order_trailing_receives(halo, unns) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + call get_unn_multiple_components_order_general(halo, unns) + case(HALO_ORDER_TRAILING_RECEIVES) + call get_unn_multiple_components_order_trailing_receives(halo, unns) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine get_universal_numbering_multiple_components + end subroutine get_universal_numbering_multiple_components - subroutine get_unn_multiple_components_order_general(halo, unns) - !!< For the supplied halo, retrieve the complete universal numbering - !!< of the degrees of freedom in a multi-component field + subroutine get_unn_multiple_components_order_general(halo, unns) + !!< For the supplied halo, retrieve the complete universal numbering + !!< of the degrees of freedom in a multi-component field - type(halo_type), intent(in) :: halo - integer, dimension(:,:), intent(out) :: unns + type(halo_type), intent(in) :: halo + integer, dimension(:,:), intent(out) :: unns - integer, dimension(:), pointer :: receives - integer :: owned_nodes, ncomponents, out_unn, out_unn_base, remote_gnn - integer :: i, j, k, unn + integer, dimension(:), pointer :: receives + integer :: owned_nodes, ncomponents, out_unn, out_unn_base, remote_gnn + integer :: i, j, k, unn - assert(has_global_to_universal_numbering(halo)) - assert(size(unns,1)>=size(halo%gnn_to_unn)) + assert(has_global_to_universal_numbering(halo)) + assert(size(unns,1)>=size(halo%gnn_to_unn)) - ncomponents = size(unns, 2) + ncomponents = size(unns, 2) - unns = -1 + unns = -1 - ! first the receiving nodes - do i = 1, halo_proc_count(halo) + ! first the receiving nodes + do i = 1, halo_proc_count(halo) - receives => halo_receives(halo, i) - ! base for the created multi-component unns of owned nodes on proces i: - out_unn_base = halo%owned_nodes_unn_base(i)*ncomponents - ! nodes owned by process i: - owned_nodes = halo%owned_nodes_unn_base(i+1)-halo%owned_nodes_unn_base(i) + receives => halo_receives(halo, i) + ! base for the created multi-component unns of owned nodes on proces i: + out_unn_base = halo%owned_nodes_unn_base(i)*ncomponents + ! nodes owned by process i: + owned_nodes = halo%owned_nodes_unn_base(i+1)-halo%owned_nodes_unn_base(i) - do j = 1, size(receives) + do j = 1, size(receives) - unn = halo%gnn_to_unn(receives(j)) - ! global no as owned node on process i: - remote_gnn = unn-halo%owned_nodes_unn_base(i) + unn = halo%gnn_to_unn(receives(j)) + ! global no as owned node on process i: + remote_gnn = unn-halo%owned_nodes_unn_base(i) - ! start with unn for component 1 - out_unn = out_unn_base+remote_gnn - do k = 1, ncomponents - unns(receives(j), k) = out_unn - out_unn = out_unn + owned_nodes - end do + ! start with unn for component 1 + out_unn = out_unn_base+remote_gnn + do k = 1, ncomponents + unns(receives(j), k) = out_unn + out_unn = out_unn + owned_nodes + end do + end do + end do + + ! the rest must be owned nodes + owned_nodes = halo_nowned_nodes(halo) + do i=1, size(halo%gnn_to_unn) + if (unns(i,1)==-1) then + ! the multi-component unn should be using base unn_base*ncomponents + ! so we add the missing bit: + out_unn = halo%gnn_to_unn(i)+(ncomponents-1)*halo%my_owned_nodes_unn_base + do k=1, ncomponents + unns(i, k) = out_unn + out_unn = out_unn + owned_nodes + end do + end if end do - end do - - ! the rest must be owned nodes - owned_nodes = halo_nowned_nodes(halo) - do i=1, size(halo%gnn_to_unn) - if (unns(i,1)==-1) then - ! the multi-component unn should be using base unn_base*ncomponents - ! so we add the missing bit: - out_unn = halo%gnn_to_unn(i)+(ncomponents-1)*halo%my_owned_nodes_unn_base - do k=1, ncomponents - unns(i, k) = out_unn - out_unn = out_unn + owned_nodes - end do - end if - end do - end subroutine get_unn_multiple_components_order_general + end subroutine get_unn_multiple_components_order_general - subroutine get_unn_multiple_components_order_trailing_receives(halo, unns) - !!< For the supplied halo, retrieve the complete universal numbering - !!< of the degrees of freedom in a multi-component field + subroutine get_unn_multiple_components_order_trailing_receives(halo, unns) + !!< For the supplied halo, retrieve the complete universal numbering + !!< of the degrees of freedom in a multi-component field - type(halo_type), intent(in) :: halo - integer, dimension(:,:), intent(out) :: unns + type(halo_type), intent(in) :: halo + integer, dimension(:,:), intent(out) :: unns - integer, dimension(:), pointer :: receives - integer :: owned_nodes, ncomponents, out_unn, out_unn_base, remote_gnn - integer :: i, j, k, unn, my_nowned_nodes + integer, dimension(:), pointer :: receives + integer :: owned_nodes, ncomponents, out_unn, out_unn_base, remote_gnn + integer :: i, j, k, unn, my_nowned_nodes - assert(trailing_receives_consistent(halo)) - assert(size(unns) >= halo_nowned_nodes(halo) + size(halo%receives_gnn_to_unn)) - assert(has_global_to_universal_numbering(halo)) + assert(trailing_receives_consistent(halo)) + assert(size(unns) >= halo_nowned_nodes(halo) + size(halo%receives_gnn_to_unn)) + assert(has_global_to_universal_numbering(halo)) - ncomponents = size(unns, 2) + ncomponents = size(unns, 2) - ! first our owned nodes - my_nowned_nodes = halo_nowned_nodes(halo) - do i = 1, my_nowned_nodes - ! the multi-component unn uses a base of unn_base*ncomponents - out_unn = ncomponents*halo%my_owned_nodes_unn_base + i - do k = 1, ncomponents - unns(i, k) = out_unn - out_unn = out_unn + my_nowned_nodes + ! first our owned nodes + my_nowned_nodes = halo_nowned_nodes(halo) + do i = 1, my_nowned_nodes + ! the multi-component unn uses a base of unn_base*ncomponents + out_unn = ncomponents*halo%my_owned_nodes_unn_base + i + do k = 1, ncomponents + unns(i, k) = out_unn + out_unn = out_unn + my_nowned_nodes + end do end do - end do - - ! then fill in the receiving nodes - do i = 1, halo_proc_count(halo) - receives => halo_receives(halo, i) - ! base for the created multi-component unns of owned nodes on proces i: - out_unn_base = halo%owned_nodes_unn_base(i)*ncomponents - ! nodes owned by process i: - owned_nodes = halo%owned_nodes_unn_base(i+1)-halo%owned_nodes_unn_base(i) - do j = 1, size(receives) - - unn = halo%receives_gnn_to_unn(receives(j)-my_nowned_nodes) - ! global no as owned node on process i: - remote_gnn = unn-halo%owned_nodes_unn_base(i) - - ! start with unn for component 1 - out_unn = out_unn_base+remote_gnn - do k = 1, ncomponents - unns(receives(j), k) = out_unn - out_unn = out_unn + owned_nodes - end do + ! then fill in the receiving nodes + do i = 1, halo_proc_count(halo) + receives => halo_receives(halo, i) + ! base for the created multi-component unns of owned nodes on proces i: + out_unn_base = halo%owned_nodes_unn_base(i)*ncomponents + ! nodes owned by process i: + owned_nodes = halo%owned_nodes_unn_base(i+1)-halo%owned_nodes_unn_base(i) + do j = 1, size(receives) + + unn = halo%receives_gnn_to_unn(receives(j)-my_nowned_nodes) + ! global no as owned node on process i: + remote_gnn = unn-halo%owned_nodes_unn_base(i) + + ! start with unn for component 1 + out_unn = out_unn_base+remote_gnn + do k = 1, ncomponents + unns(receives(j), k) = out_unn + out_unn = out_unn + owned_nodes + end do + + end do end do - end do - - end subroutine get_unn_multiple_components_order_trailing_receives - - subroutine get_universal_numbering_inverse(halo, gnns) - !!< For the supplied halo, retrieve the complete universal node numbering - !!< list inverse - - type(halo_type), intent(in) :: halo - type(integer_hash_table), intent(out) :: gnns - - integer, dimension(:), allocatable :: unns - - allocate(unns(node_count(halo))) - call get_universal_numbering(halo, unns) - call invert_set(unns, gnns) - deallocate(unns) - - end subroutine get_universal_numbering_inverse - - subroutine set_halo_universal_number(halo, node, universal_number, stat) - !!< Set a single universal number in halo. This is useful for external - !!< routines which set up universal numberings such as - !!< reorder_halo_from_element_halo. - !!< - !!< The stat argument, if present, returns 1 if the node is outside the - !!< range of the halo and 0 otherwise. - type(halo_type), intent(inout) :: halo - integer, intent(in) :: node, universal_number - integer, intent(out), optional :: stat - - assert(has_global_to_universal_numbering(halo)) - if (present(stat)) stat=0 - - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - if (node>size(halo%gnn_to_unn)) then - if (present(stat)) then - stat=1 - return - else - FLAbort("Illegal node number in set_halo_universal_number") - end if - end if - - halo%gnn_to_unn(node)=universal_number - - case(HALO_ORDER_TRAILING_RECEIVES) - - if (node>halo%nowned_nodes)& - & then - if (node-halo%nowned_nodes>size(halo%receives_gnn_to_unn)) then - if (present(stat)) then - stat=1 - return - else - FLAbort("Illegal node number in set_halo_universal_number") - end if - end if - - halo%receives_gnn_to_unn(node-halo%nowned_nodes) & + + end subroutine get_unn_multiple_components_order_trailing_receives + + subroutine get_universal_numbering_inverse(halo, gnns) + !!< For the supplied halo, retrieve the complete universal node numbering + !!< list inverse + + type(halo_type), intent(in) :: halo + type(integer_hash_table), intent(out) :: gnns + + integer, dimension(:), allocatable :: unns + + allocate(unns(node_count(halo))) + call get_universal_numbering(halo, unns) + call invert_set(unns, gnns) + deallocate(unns) + + end subroutine get_universal_numbering_inverse + + subroutine set_halo_universal_number(halo, node, universal_number, stat) + !!< Set a single universal number in halo. This is useful for external + !!< routines which set up universal numberings such as + !!< reorder_halo_from_element_halo. + !!< + !!< The stat argument, if present, returns 1 if the node is outside the + !!< range of the halo and 0 otherwise. + type(halo_type), intent(inout) :: halo + integer, intent(in) :: node, universal_number + integer, intent(out), optional :: stat + + assert(has_global_to_universal_numbering(halo)) + if (present(stat)) stat=0 + + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + if (node>size(halo%gnn_to_unn)) then + if (present(stat)) then + stat=1 + return + else + FLAbort("Illegal node number in set_halo_universal_number") + end if + end if + + halo%gnn_to_unn(node)=universal_number + + case(HALO_ORDER_TRAILING_RECEIVES) + + if (node>halo%nowned_nodes)& + & then + if (node-halo%nowned_nodes>size(halo%receives_gnn_to_unn)) then + if (present(stat)) then + stat=1 + return + else + FLAbort("Illegal node number in set_halo_universal_number") + end if + end if + + halo%receives_gnn_to_unn(node-halo%nowned_nodes) & = universal_number - else - assert(universal_number==node+halo%my_owned_nodes_unn_base) - end if + else + assert(universal_number==node+halo%my_owned_nodes_unn_base) + end if - case default - FLAbort("Unrecognised halo ordering scheme") - end select + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine set_halo_universal_number + end subroutine set_halo_universal_number - subroutine ewrite_universal_numbers(halo, debug_level) - !!< Print the universal number cache for this process with the supplied - !!< debug level + subroutine ewrite_universal_numbers(halo, debug_level) + !!< Print the universal number cache for this process with the supplied + !!< debug level - type(halo_type), intent(in) :: halo - integer, intent(in) :: debug_level + type(halo_type), intent(in) :: halo + integer, intent(in) :: debug_level - assert(has_global_to_universal_numbering(halo)) + assert(has_global_to_universal_numbering(halo)) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - assert(associated(halo%gnn_to_unn)) + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + assert(associated(halo%gnn_to_unn)) - ewrite(debug_level, *) "Global to universal numbering map:" - ewrite(debug_level, *) halo%gnn_to_unn - case(HALO_ORDER_TRAILING_RECEIVES) - assert(associated(halo%receives_gnn_to_unn)) + ewrite(debug_level, *) "Global to universal numbering map:" + ewrite(debug_level, *) halo%gnn_to_unn + case(HALO_ORDER_TRAILING_RECEIVES) + assert(associated(halo%receives_gnn_to_unn)) - ewrite(debug_level, *) "Owned nodes universal node number base = ", halo%my_owned_nodes_unn_base - ewrite(debug_level, *) "Receives global to universal numbering map:" - ewrite(debug_level, *) halo%receives_gnn_to_unn - case default - FLAbort("Unrecognised halo ordering scheme") - end select + ewrite(debug_level, *) "Owned nodes universal node number base = ", halo%my_owned_nodes_unn_base + ewrite(debug_level, *) "Receives global to universal numbering map:" + ewrite(debug_level, *) halo%receives_gnn_to_unn + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine ewrite_universal_numbers + end subroutine ewrite_universal_numbers end module halos_numbering diff --git a/femtools/Halos_Ownership.F90 b/femtools/Halos_Ownership.F90 index 77106ae9a2..88c271dba0 100644 --- a/femtools/Halos_Ownership.F90 +++ b/femtools/Halos_Ownership.F90 @@ -2,323 +2,323 @@ module halos_ownership - use fldebug - use futils - use halo_data_types - use parallel_tools - use quicksort - use halos_base - use halos_debug - use halos_allocates - use halos_numbering + use fldebug + use futils + use halo_data_types + use parallel_tools + use quicksort + use halos_base + use halos_debug + use halos_allocates + use halos_numbering - implicit none + implicit none - private + private - public :: create_ownership, has_ownership, halo_node_owner, & - & halo_node_owners, node_owned, nodes_owned, get_node_owners, & - & get_owned_nodes, halo_universal_node_owners + public :: create_ownership, has_ownership, halo_node_owner, & + & halo_node_owners, node_owned, nodes_owned, get_node_owners, & + & get_owned_nodes, halo_universal_node_owners - interface node_owned - module procedure node_owned_halo - end interface + interface node_owned + module procedure node_owned_halo + end interface - interface nodes_owned - module procedure nodes_owned_halo - end interface nodes_owned + interface nodes_owned + module procedure nodes_owned_halo + end interface nodes_owned contains - subroutine create_ownership(halo) - !!< Establish the node ownership on the supplied halo, and cache it on the - !!< halo + subroutine create_ownership(halo) + !!< Establish the node ownership on the supplied halo, and cache it on the + !!< halo - type(halo_type), intent(inout) :: halo + type(halo_type), intent(inout) :: halo - if(has_ownership(halo)) return + if(has_ownership(halo)) return - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - call create_ownership_order_general(halo) - case(HALO_ORDER_TRAILING_RECEIVES) - call create_ownership_order_trailing_receives(halo) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + call create_ownership_order_general(halo) + case(HALO_ORDER_TRAILING_RECEIVES) + call create_ownership_order_trailing_receives(halo) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine create_ownership + end subroutine create_ownership - subroutine create_ownership_order_general(halo) - type(halo_type), intent(inout) :: halo + subroutine create_ownership_order_general(halo) + type(halo_type), intent(inout) :: halo - integer :: i + integer :: i - allocate(halo%owners(node_count(halo))) + allocate(halo%owners(node_count(halo))) - halo%owners = getprocno(communicator = halo_communicator(halo)) - do i = 1, halo_proc_count(halo) - halo%owners(halo_receives(halo, i)) = i - end do + halo%owners = getprocno(communicator = halo_communicator(halo)) + do i = 1, halo_proc_count(halo) + halo%owners(halo_receives(halo, i)) = i + end do - end subroutine create_ownership_order_general + end subroutine create_ownership_order_general - subroutine create_ownership_order_trailing_receives(halo) - type(halo_type), intent(inout) :: halo + subroutine create_ownership_order_trailing_receives(halo) + type(halo_type), intent(inout) :: halo - integer :: i, nowned_nodes + integer :: i, nowned_nodes - assert(trailing_receives_consistent(halo)) - nowned_nodes = halo_nowned_nodes(halo) + assert(trailing_receives_consistent(halo)) + nowned_nodes = halo_nowned_nodes(halo) - allocate(halo%owners(halo_all_receives_count(halo))) - do i = 1, halo_proc_count(halo) - assert(all(halo_receives(halo, i) >= nowned_nodes)) - assert(all(halo_receives(halo, i) <= nowned_nodes + size(halo%owners))) - halo%owners(halo_receives(halo, i) - nowned_nodes) = i - end do + allocate(halo%owners(halo_all_receives_count(halo))) + do i = 1, halo_proc_count(halo) + assert(all(halo_receives(halo, i) >= nowned_nodes)) + assert(all(halo_receives(halo, i) <= nowned_nodes + size(halo%owners))) + halo%owners(halo_receives(halo, i) - nowned_nodes) = i + end do - end subroutine create_ownership_order_trailing_receives + end subroutine create_ownership_order_trailing_receives - pure function has_ownership(halo) - !!< Return whether the supplied halo has node ownership data + pure function has_ownership(halo) + !!< Return whether the supplied halo has node ownership data - type(halo_type), intent(in) :: halo + type(halo_type), intent(in) :: halo - logical :: has_ownership + logical :: has_ownership - has_ownership = associated(halo%owners) + has_ownership = associated(halo%owners) - end function has_ownership + end function has_ownership - function halo_node_owner(halo, node, permit_extended) result(node_owner) - !!< Return the node owner for the supplied node on the supplied halo + function halo_node_owner(halo, node, permit_extended) result(node_owner) + !!< Return the node owner for the supplied node on the supplied halo - type(halo_type), intent(in) :: halo - integer, intent(in) :: node - !! If present and .true. and the node is not contained in the supplied halo, - !! return a negative owning process - logical, optional, intent(in) :: permit_extended + type(halo_type), intent(in) :: halo + integer, intent(in) :: node + !! If present and .true. and the node is not contained in the supplied halo, + !! return a negative owning process + logical, optional, intent(in) :: permit_extended - integer :: node_owner + integer :: node_owner - assert(node > 0) - assert(has_ownership(halo)) + assert(node > 0) + assert(has_ownership(halo)) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - node_owner = halo_node_owner_order_general(halo, node, permit_extended = permit_extended) - case(HALO_ORDER_TRAILING_RECEIVES) - node_owner = halo_node_owner_order_trailing_receives(halo, node, permit_extended = permit_extended) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + node_owner = halo_node_owner_order_general(halo, node, permit_extended = permit_extended) + case(HALO_ORDER_TRAILING_RECEIVES) + node_owner = halo_node_owner_order_trailing_receives(halo, node, permit_extended = permit_extended) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end function halo_node_owner + end function halo_node_owner - function halo_node_owner_order_general(halo, node, permit_extended) result(node_owner) - type(halo_type), intent(in) :: halo - integer, intent(in) :: node - !! If present and .true. and the node is not contained in the supplied halo, - !! return a negative owning process - logical, optional, intent(in) :: permit_extended + function halo_node_owner_order_general(halo, node, permit_extended) result(node_owner) + type(halo_type), intent(in) :: halo + integer, intent(in) :: node + !! If present and .true. and the node is not contained in the supplied halo, + !! return a negative owning process + logical, optional, intent(in) :: permit_extended - integer :: node_owner + integer :: node_owner - if(present_and_true(permit_extended)) then - if(node <= size(halo%owners)) then - node_owner = halo%owners(node) + if(present_and_true(permit_extended)) then + if(node <= size(halo%owners)) then + node_owner = halo%owners(node) + else + node_owner = -1 + end if else - node_owner = -1 + assert(node <= size(halo%owners)) + node_owner = halo%owners(node) end if - else - assert(node <= size(halo%owners)) - node_owner = halo%owners(node) - end if - - end function halo_node_owner_order_general - - function halo_node_owner_order_trailing_receives(halo, node, permit_extended) result(node_owner) - type(halo_type), intent(in) :: halo - integer, intent(in) :: node - !! If present and .true. and the node is not contained in the supplied halo, - !! return a negative owning process - logical, optional, intent(in) :: permit_extended - - integer :: node_owner, nowned_nodes - - nowned_nodes = halo_nowned_nodes(halo) - if(node <= nowned_nodes) then - node_owner = getprocno(halo_communicator(halo)) - else if(present_and_true(permit_extended)) then - if(node - nowned_nodes <= size(halo%owners)) then - node_owner = halo%owners(node - nowned_nodes) + + end function halo_node_owner_order_general + + function halo_node_owner_order_trailing_receives(halo, node, permit_extended) result(node_owner) + type(halo_type), intent(in) :: halo + integer, intent(in) :: node + !! If present and .true. and the node is not contained in the supplied halo, + !! return a negative owning process + logical, optional, intent(in) :: permit_extended + + integer :: node_owner, nowned_nodes + + nowned_nodes = halo_nowned_nodes(halo) + if(node <= nowned_nodes) then + node_owner = getprocno(halo_communicator(halo)) + else if(present_and_true(permit_extended)) then + if(node - nowned_nodes <= size(halo%owners)) then + node_owner = halo%owners(node - nowned_nodes) + else + node_owner = -1 + end if else - node_owner = -1 + assert(node - nowned_nodes <= size(halo%owners)) + node_owner = halo%owners(node - nowned_nodes) end if - else - assert(node - nowned_nodes <= size(halo%owners)) - node_owner = halo%owners(node - nowned_nodes) - end if - end function halo_node_owner_order_trailing_receives + end function halo_node_owner_order_trailing_receives - function halo_node_owners(halo, nodes, permit_extended) result(node_owners) - !!< Return the node owners for the supplied nodes on the supplied halo + function halo_node_owners(halo, nodes, permit_extended) result(node_owners) + !!< Return the node owners for the supplied nodes on the supplied halo - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(in) :: nodes - !! If present and .true. and a node is not contained in the supplied halo, - !! return a negative owning process for that node - logical, optional, intent(in) :: permit_extended + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(in) :: nodes + !! If present and .true. and a node is not contained in the supplied halo, + !! return a negative owning process for that node + logical, optional, intent(in) :: permit_extended - integer, dimension(size(nodes)) :: node_owners + integer, dimension(size(nodes)) :: node_owners - integer :: i + integer :: i - do i = 1, size(nodes) - node_owners(i) = halo_node_owner(halo, nodes(i), permit_extended) - end do + do i = 1, size(nodes) + node_owners(i) = halo_node_owner(halo, nodes(i), permit_extended) + end do - end function halo_node_owners + end function halo_node_owners - function node_owned_halo(halo, node) - !!< Return whether this process owns the supplied node on the supplied halo + function node_owned_halo(halo, node) + !!< Return whether this process owns the supplied node on the supplied halo - type(halo_type), intent(in) :: halo - integer, intent(in) :: node + type(halo_type), intent(in) :: halo + integer, intent(in) :: node - logical :: node_owned_halo + logical :: node_owned_halo - assert(node > 0) + assert(node > 0) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - node_owned_halo = halo_node_owner(halo, node, permit_extended = .true.) == getprocno(communicator = halo_communicator(halo)) - case(HALO_ORDER_TRAILING_RECEIVES) - node_owned_halo = node <= halo_nowned_nodes(halo) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + node_owned_halo = halo_node_owner(halo, node, permit_extended = .true.) == getprocno(communicator = halo_communicator(halo)) + case(HALO_ORDER_TRAILING_RECEIVES) + node_owned_halo = node <= halo_nowned_nodes(halo) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end function node_owned_halo + end function node_owned_halo - function nodes_owned_halo(halo, nodes) result(owned) - !!< Return whether this process owns the supplied nodes on the supplied halo + function nodes_owned_halo(halo, nodes) result(owned) + !!< Return whether this process owns the supplied nodes on the supplied halo - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(in) :: nodes + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(in) :: nodes - logical, dimension(size(nodes)) :: owned + logical, dimension(size(nodes)) :: owned - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - owned = halo_node_owners(halo, nodes, permit_extended = .true.) == getprocno(communicator = halo_communicator(halo)) - case(HALO_ORDER_TRAILING_RECEIVES) - owned = nodes <= halo_nowned_nodes(halo) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + owned = halo_node_owners(halo, nodes, permit_extended = .true.) == getprocno(communicator = halo_communicator(halo)) + case(HALO_ORDER_TRAILING_RECEIVES) + owned = nodes <= halo_nowned_nodes(halo) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end function nodes_owned_halo + end function nodes_owned_halo - subroutine get_node_owners(halo, owners) - !!< For the supplied halo, retreive the complete node ownership list + subroutine get_node_owners(halo, owners) + !!< For the supplied halo, retreive the complete node ownership list - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(out) :: owners + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(out) :: owners - assert(has_ownership(halo)) + assert(has_ownership(halo)) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - assert(size(owners) == size(halo%owners)) + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + assert(size(owners) == size(halo%owners)) - owners = halo%owners - case(HALO_ORDER_TRAILING_RECEIVES) - assert(size(owners) == halo_nowned_nodes(halo) + size(halo%receives_gnn_to_unn)) + owners = halo%owners + case(HALO_ORDER_TRAILING_RECEIVES) + assert(size(owners) == halo_nowned_nodes(halo) + size(halo%receives_gnn_to_unn)) - owners(:halo_nowned_nodes(halo)) = getprocno(halo_communicator(halo)) - owners(halo_nowned_nodes(halo) + 1:) = halo%owners - case default - FLAbort("Unrecognised halo ordering scheme") - end select + owners(:halo_nowned_nodes(halo)) = getprocno(halo_communicator(halo)) + owners(halo_nowned_nodes(halo) + 1:) = halo%owners + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine get_node_owners + end subroutine get_node_owners - subroutine get_owned_nodes(halo, owned_nodes) - !!< Retrieve the owned nodes for the supplied halo + subroutine get_owned_nodes(halo, owned_nodes) + !!< Retrieve the owned nodes for the supplied halo - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(out) :: owned_nodes + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(out) :: owned_nodes - integer :: i, index + integer :: i, index - assert(size(owned_nodes) == halo_nowned_nodes(halo)) + assert(size(owned_nodes) == halo_nowned_nodes(halo)) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - index = 1 - do i = 1, size(halo%owners) - if(node_owned(halo, i)) then - assert(index <= size(owned_nodes)) - owned_nodes(index) = i - index = index + 1 - end if - end do - assert(index == size(owned_nodes) + 1) - case(HALO_ORDER_TRAILING_RECEIVES) - owned_nodes = (/(i, i = 1, halo_nowned_nodes(halo))/) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + index = 1 + do i = 1, size(halo%owners) + if(node_owned(halo, i)) then + assert(index <= size(owned_nodes)) + owned_nodes(index) = i + index = index + 1 + end if + end do + assert(index == size(owned_nodes) + 1) + case(HALO_ORDER_TRAILING_RECEIVES) + owned_nodes = (/(i, i = 1, halo_nowned_nodes(halo))/) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine get_owned_nodes + end subroutine get_owned_nodes - function halo_universal_node_owners(halo, unns) result(node_owners) - !!< Return the node owners for the supplied universal nodes on the supplied - !!< halo. + function halo_universal_node_owners(halo, unns) result(node_owners) + !!< Return the node owners for the supplied universal nodes on the supplied + !!< halo. - type(halo_type), intent(in) :: halo - integer, dimension(:), intent(in) :: unns + type(halo_type), intent(in) :: halo + integer, dimension(:), intent(in) :: unns - integer, dimension(size(unns)) :: node_owners + integer, dimension(size(unns)) :: node_owners - integer :: i, nprocs, proc - integer, dimension(:), allocatable :: permutation + integer :: i, nprocs, proc + integer, dimension(:), allocatable :: permutation - assert(has_global_to_universal_numbering(halo)) - assert(associated(halo%owned_nodes_unn_base)) - assert(size(halo%owned_nodes_unn_base) == nprocs + 1) + assert(has_global_to_universal_numbering(halo)) + assert(associated(halo%owned_nodes_unn_base)) + assert(size(halo%owned_nodes_unn_base) == nprocs + 1) - nprocs = halo_proc_count(halo) - assert(all(unns > 0) .and. all(unns < halo%owned_nodes_unn_base(nprocs + 1))) + nprocs = halo_proc_count(halo) + assert(all(unns > 0) .and. all(unns < halo%owned_nodes_unn_base(nprocs + 1))) - ! We could add an optimisation for when the caller promises to supply - ! sorted unns - allocate(permutation(size(unns))) - call qsort(unns, permutation) + ! We could add an optimisation for when the caller promises to supply + ! sorted unns + allocate(permutation(size(unns))) + call qsort(unns, permutation) #ifdef DDEBUG - node_owners = -1 + node_owners = -1 #endif - proc = 1 - assert(nprocs > 0) - unns_loop: do i = 1, size(unns) - do while(unns(permutation(i)) > halo%owned_nodes_unn_base(proc)) - proc = proc + 1 - if(proc > nprocs) exit unns_loop - end do - node_owners(permutation(i)) = proc - end do unns_loop + proc = 1 + assert(nprocs > 0) + unns_loop: do i = 1, size(unns) + do while(unns(permutation(i)) > halo%owned_nodes_unn_base(proc)) + proc = proc + 1 + if(proc > nprocs) exit unns_loop + end do + node_owners(permutation(i)) = proc + end do unns_loop - deallocate(permutation) + deallocate(permutation) #ifdef DDEBUG - assert(all(node_owners > 0)) + assert(all(node_owners > 0)) #endif - end function halo_universal_node_owners + end function halo_universal_node_owners end module halos_ownership diff --git a/femtools/Halos_Registration.F90 b/femtools/Halos_Registration.F90 index 994aa253a3..92feadedef 100644 --- a/femtools/Halos_Registration.F90 +++ b/femtools/Halos_Registration.F90 @@ -29,385 +29,385 @@ module halos_registration - use fldebug - use futils - use mpi_interfaces - use halo_data_types - use parallel_tools - use halos_base - use halos_debug - use halos_allocates - use data_structures - use fields_data_types - use fields_base - use halos_communications - use halos_numbering - use halos_ownership - use fields_allocates - use fields_manipulation - use halos_derivation - - implicit none - - private - - public :: read_halos, write_halos, verify_halos - public :: extract_raw_halo_data, form_halo_from_raw_data - - interface - subroutine chalo_reader_reset() - end subroutine chalo_reader_reset - - function chalo_reader_set_input(filename, filename_len, process, nprocs) - implicit none - integer, intent(in) :: filename_len - character(len = filename_len) :: filename - integer, intent(in) :: process - integer, intent(in) :: nprocs - integer :: chalo_reader_set_input - end function chalo_reader_set_input - - subroutine chalo_reader_query_output(level, nprocs, nsends, nreceives) - implicit none - integer, intent(in) :: level - integer, intent(in) :: nprocs - integer, dimension(nprocs), intent(out) :: nsends - integer, dimension(nprocs), intent(out) :: nreceives - end subroutine chalo_reader_query_output - - subroutine chalo_reader_get_output(level, nprocs, nsends, nreceives, & + use fldebug + use futils + use mpi_interfaces + use halo_data_types + use parallel_tools + use halos_base + use halos_debug + use halos_allocates + use data_structures + use fields_data_types + use fields_base + use halos_communications + use halos_numbering + use halos_ownership + use fields_allocates + use fields_manipulation + use halos_derivation + + implicit none + + private + + public :: read_halos, write_halos, verify_halos + public :: extract_raw_halo_data, form_halo_from_raw_data + + interface + subroutine chalo_reader_reset() + end subroutine chalo_reader_reset + + function chalo_reader_set_input(filename, filename_len, process, nprocs) + implicit none + integer, intent(in) :: filename_len + character(len = filename_len) :: filename + integer, intent(in) :: process + integer, intent(in) :: nprocs + integer :: chalo_reader_set_input + end function chalo_reader_set_input + + subroutine chalo_reader_query_output(level, nprocs, nsends, nreceives) + implicit none + integer, intent(in) :: level + integer, intent(in) :: nprocs + integer, dimension(nprocs), intent(out) :: nsends + integer, dimension(nprocs), intent(out) :: nreceives + end subroutine chalo_reader_query_output + + subroutine chalo_reader_get_output(level, nprocs, nsends, nreceives, & & npnodes, send, recv) - implicit none - integer, intent(in) :: level - integer, intent(in) :: nprocs - integer, dimension(nprocs), intent(in) :: nsends - integer, dimension(nprocs), intent(in) :: nreceives - integer, intent(out) :: npnodes - integer, dimension(sum(nsends)), intent(out) :: send - integer, dimension(sum(nreceives)), intent(out) :: recv - end subroutine chalo_reader_get_output - - subroutine chalo_writer_reset() - end subroutine chalo_writer_reset - - subroutine chalo_writer_initialise(process, nprocs) - implicit none - integer, intent(in) :: process - integer, intent(in) :: nprocs - end subroutine chalo_writer_initialise - - subroutine chalo_writer_set_input(level, nprocs, nsends, nreceives, & + implicit none + integer, intent(in) :: level + integer, intent(in) :: nprocs + integer, dimension(nprocs), intent(in) :: nsends + integer, dimension(nprocs), intent(in) :: nreceives + integer, intent(out) :: npnodes + integer, dimension(sum(nsends)), intent(out) :: send + integer, dimension(sum(nreceives)), intent(out) :: recv + end subroutine chalo_reader_get_output + + subroutine chalo_writer_reset() + end subroutine chalo_writer_reset + + subroutine chalo_writer_initialise(process, nprocs) + implicit none + integer, intent(in) :: process + integer, intent(in) :: nprocs + end subroutine chalo_writer_initialise + + subroutine chalo_writer_set_input(level, nprocs, nsends, nreceives, & & npnodes, send, recv) - implicit none - integer, intent(in) :: level - integer, intent(in) :: nprocs - integer, dimension(nprocs), intent(in) :: nsends - integer, dimension(nprocs), intent(in) :: nreceives - integer, intent(in) :: npnodes - integer, dimension(sum(nsends)), intent(in) :: send - integer, dimension(sum(nreceives)), intent(in) :: recv - end subroutine chalo_writer_set_input - - function chalo_writer_write(filename, filename_len) - implicit none - integer, intent(in) :: filename_len - character(len = filename_len) :: filename - integer :: chalo_writer_write - end function chalo_writer_write - end interface - - interface read_halos - module procedure read_halos_mesh, read_halos_positions - end interface read_halos + implicit none + integer, intent(in) :: level + integer, intent(in) :: nprocs + integer, dimension(nprocs), intent(in) :: nsends + integer, dimension(nprocs), intent(in) :: nreceives + integer, intent(in) :: npnodes + integer, dimension(sum(nsends)), intent(in) :: send + integer, dimension(sum(nreceives)), intent(in) :: recv + end subroutine chalo_writer_set_input + + function chalo_writer_write(filename, filename_len) + implicit none + integer, intent(in) :: filename_len + character(len = filename_len) :: filename + integer :: chalo_writer_write + end function chalo_writer_write + end interface + + interface read_halos + module procedure read_halos_mesh, read_halos_positions + end interface read_halos contains - subroutine read_halos_mesh(filename, mesh, communicator) - character(len = *), intent(in) :: filename - type(mesh_type), intent(inout) :: mesh - integer, optional, intent(in) :: communicator + subroutine read_halos_mesh(filename, mesh, communicator) + character(len = *), intent(in) :: filename + type(mesh_type), intent(inout) :: mesh + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: error_count, i, lcommunicator, nowned_nodes, nprocs, procno - integer, dimension(:), allocatable :: nreceives, nsends, receives, sends - - ewrite(1, *) "In read_halos_mesh" - - assert(continuity(mesh) == 0) - assert(.not. associated(mesh%halos)) - assert(.not. associated(mesh%element_halos)) - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - procno = getprocno(communicator = lcommunicator) - nprocs = getnprocs(communicator = lcommunicator) - - error_count = chalo_reader_set_input(filename, len_trim(filename), procno - 1, nprocs) - call allsum(error_count, communicator = lcommunicator) - if(error_count > 0) then - FLExit("Unable to read halos with name " // trim(filename)) - end if - - allocate(mesh%halos(2)) - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - do i = 1, 2 - call chalo_reader_query_output(i, nprocs, nsends, nreceives) - call allocate(mesh%halos(i), nsends, nreceives, name = trim(mesh%name) // "Level" // int2str(i) // "Halo", communicator = lcommunicator, & - & data_type = HALO_TYPE_CG_NODE, ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) - - allocate(sends(sum(nsends))) - allocate(receives(sum(nreceives))) - call chalo_reader_get_output(i, nprocs, nsends, nreceives, & - & nowned_nodes, sends, receives) - call set_halo_nowned_nodes(mesh%halos(i), nowned_nodes) - call set_all_halo_sends(mesh%halos(i), sends) - call set_all_halo_receives(mesh%halos(i), receives) - deallocate(sends) - deallocate(receives) - assert(trailing_receives_consistent(mesh%halos(i))) - - if(.not. serial_storage_halo(mesh%halos(i))) then - assert(halo_valid_for_communication(mesh%halos(i))) - call create_global_to_universal_numbering(mesh%halos(i)) - call create_ownership(mesh%halos(i)) + integer :: error_count, i, lcommunicator, nowned_nodes, nprocs, procno + integer, dimension(:), allocatable :: nreceives, nsends, receives, sends + + ewrite(1, *) "In read_halos_mesh" + + assert(continuity(mesh) == 0) + assert(.not. associated(mesh%halos)) + assert(.not. associated(mesh%element_halos)) + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + procno = getprocno(communicator = lcommunicator) + nprocs = getnprocs(communicator = lcommunicator) + + error_count = chalo_reader_set_input(filename, len_trim(filename), procno - 1, nprocs) + call allsum(error_count, communicator = lcommunicator) + if(error_count > 0) then + FLExit("Unable to read halos with name " // trim(filename)) end if - end do - deallocate(nsends) - deallocate(nreceives) - call chalo_reader_reset() + allocate(mesh%halos(2)) + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + do i = 1, 2 + call chalo_reader_query_output(i, nprocs, nsends, nreceives) + call allocate(mesh%halos(i), nsends, nreceives, name = trim(mesh%name) // "Level" // int2str(i) // "Halo", communicator = lcommunicator, & + & data_type = HALO_TYPE_CG_NODE, ordering_scheme = HALO_ORDER_TRAILING_RECEIVES) + + allocate(sends(sum(nsends))) + allocate(receives(sum(nreceives))) + call chalo_reader_get_output(i, nprocs, nsends, nreceives, & + & nowned_nodes, sends, receives) + call set_halo_nowned_nodes(mesh%halos(i), nowned_nodes) + call set_all_halo_sends(mesh%halos(i), sends) + call set_all_halo_receives(mesh%halos(i), receives) + deallocate(sends) + deallocate(receives) + assert(trailing_receives_consistent(mesh%halos(i))) + + if(.not. serial_storage_halo(mesh%halos(i))) then + assert(halo_valid_for_communication(mesh%halos(i))) + call create_global_to_universal_numbering(mesh%halos(i)) + call create_ownership(mesh%halos(i)) + end if + end do + deallocate(nsends) + deallocate(nreceives) + + call chalo_reader_reset() - if(all(serial_storage_halo(mesh%halos))) then - allocate(mesh%element_halos(0)) - else - allocate(mesh%element_halos(2)) - call derive_element_halo_from_node_halo(mesh, & - & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) - end if + if(all(serial_storage_halo(mesh%halos))) then + allocate(mesh%element_halos(0)) + else + allocate(mesh%element_halos(2)) + call derive_element_halo_from_node_halo(mesh, & + & ordering_scheme = HALO_ORDER_TRAILING_RECEIVES, create_caches = .true.) + end if - ewrite(1, *) "Exiting read_halos_mesh" + ewrite(1, *) "Exiting read_halos_mesh" #else - FLAbort("read_halos_mesh cannot be called without MPI support") + FLAbort("read_halos_mesh cannot be called without MPI support") #endif - end subroutine read_halos_mesh + end subroutine read_halos_mesh - subroutine read_halos_positions(filename, positions, communicator) - character(len = *), intent(in) :: filename - type(vector_field), intent(inout) :: positions - integer, optional, intent(in) :: communicator + subroutine read_halos_positions(filename, positions, communicator) + character(len = *), intent(in) :: filename + type(vector_field), intent(inout) :: positions + integer, optional, intent(in) :: communicator - call read_halos(filename, positions%mesh, communicator = communicator) + call read_halos(filename, positions%mesh, communicator = communicator) #ifdef DDEBUG - call verify_halos(positions) + call verify_halos(positions) #endif - end subroutine read_halos_positions + end subroutine read_halos_positions + + subroutine verify_halos(positions) + type(vector_field), intent(inout) :: positions + + integer :: i, nhalos + type(mesh_type) :: pwc_mesh + type(vector_field) :: positions_ele + + ! Node halo verification + nhalos = halo_count(positions) + do i = 1, nhalos + if(.not. serial_storage_halo(positions%mesh%halos(i))) then + assert(halo_verifies(positions%mesh%halos(i), positions)) + end if + end do + + ! Element halo verification + nhalos = element_halo_count(positions) + if(nhalos > 0) then + if(.not. all(serial_storage_halo(positions%mesh%element_halos))) then + pwc_mesh = piecewise_constant_mesh(positions%mesh, "PiecewiseConstantMesh") + call allocate(positions_ele, positions%dim, pwc_mesh, positions%name) + call deallocate(pwc_mesh) + call remap_field(positions, positions_ele) + do i = 1, nhalos + if(.not. serial_storage_halo(positions%mesh%element_halos(i))) then + assert(halo_verifies(positions%mesh%element_halos(i), positions_ele)) + end if + end do + call deallocate(positions_ele) + end if + end if + + end subroutine verify_halos + + subroutine write_halos(filename, mesh, number_of_partitions) + character(len = *), intent(in) :: filename + type(mesh_type), intent(in) :: mesh + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions + + integer :: communicator, error_count, i, nhalos, procno, nparts, nprocs + integer, dimension(:), allocatable :: nreceives, nsends, receives, sends + + ewrite(1, *) "In write_halos" - subroutine verify_halos(positions) - type(vector_field), intent(inout) :: positions + nhalos = halo_count(mesh) + if(nhalos == 0) return - integer :: i, nhalos - type(mesh_type) :: pwc_mesh - type(vector_field) :: positions_ele + communicator = halo_communicator(mesh%halos(nhalos)) + procno = getprocno(communicator = communicator) - ! Node halo verification - nhalos = halo_count(positions) - do i = 1, nhalos - if(.not. serial_storage_halo(positions%mesh%halos(i))) then - assert(halo_verifies(positions%mesh%halos(i), positions)) + if (present(number_of_partitions)) then + nparts = number_of_partitions + else + nparts = getnprocs() end if - end do - - ! Element halo verification - nhalos = element_halo_count(positions) - if(nhalos > 0) then - if(.not. all(serial_storage_halo(positions%mesh%element_halos))) then - pwc_mesh = piecewise_constant_mesh(positions%mesh, "PiecewiseConstantMesh") - call allocate(positions_ele, positions%dim, pwc_mesh, positions%name) - call deallocate(pwc_mesh) - call remap_field(positions, positions_ele) - do i = 1, nhalos - if(.not. serial_storage_halo(positions%mesh%element_halos(i))) then - assert(halo_verifies(positions%mesh%element_halos(i), positions_ele)) - end if - end do - call deallocate(positions_ele) - end if - end if - - end subroutine verify_halos - - subroutine write_halos(filename, mesh, number_of_partitions) - character(len = *), intent(in) :: filename - type(mesh_type), intent(in) :: mesh - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions - - integer :: communicator, error_count, i, nhalos, procno, nparts, nprocs - integer, dimension(:), allocatable :: nreceives, nsends, receives, sends - - ewrite(1, *) "In write_halos" - - nhalos = halo_count(mesh) - if(nhalos == 0) return - - communicator = halo_communicator(mesh%halos(nhalos)) - procno = getprocno(communicator = communicator) - - if (present(number_of_partitions)) then - nparts = number_of_partitions - else - nparts = getnprocs() - end if - - if(procno <= nparts) then - nprocs = getnprocs(communicator = communicator) - - call chalo_writer_initialise(procno - 1, nparts) + + if(procno <= nparts) then + nprocs = getnprocs(communicator = communicator) + + call chalo_writer_initialise(procno - 1, nparts) + + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + do i = 1, nhalos + allocate(sends(halo_all_sends_count(mesh%halos(i)))) + allocate(receives(halo_all_receives_count(mesh%halos(i)))) + call extract_all_halo_sends(mesh%halos(i), sends, nsends = nsends) + call extract_all_halo_receives(mesh%halos(i), receives, nreceives = nreceives) + call chalo_writer_set_input(i, nparts, nsends(:nparts), nreceives(:nparts), & + & halo_nowned_nodes(mesh%halos(i)), sends, receives) + deallocate(sends) + deallocate(receives) + end do + deallocate(nsends) + deallocate(nreceives) + + error_count = chalo_writer_write(filename, len_trim(filename)) + call chalo_writer_reset() + else + error_count = 0 + end if + + call allsum(error_count, communicator = communicator) + if(error_count > 0) then + FLExit("Unable to write halos with name " // trim(filename)) + end if + + ewrite(1, *) "Exiting write_halos" + + end subroutine write_halos + + subroutine extract_raw_halo_data(halo, sends, send_starts, receives, receive_starts, nowned_nodes) + !!< Extract raw halo data from the supplied halo + + type(halo_type), intent(in) :: halo + + !! Send nodes for all processes. Size halo_all_sends_count(halo). + integer, dimension(:), intent(out) :: sends + !! imem type indices into sends denoting the start points of process send + !! nodes. Size halo_proc_count(halo) or halo_proc_count(halo) + 1. + integer, dimension(:), intent(out) :: send_starts + !! Receive nodes for all process. Size halo_all_receives_count(halo). + integer, dimension(:), intent(out) :: receives + !! imem type indices into receives denoting the start points of process + !! receive nodes. Size halo_proc_count(halo) or halo_proc_count(halo) + 1. + integer, dimension(:), intent(out) :: receive_starts + !! Number of owned nodes + integer, optional, intent(out) :: nowned_nodes + + integer :: nprocs, receives_size, sends_size + + nprocs = halo_proc_count(halo) + sends_size = halo_all_sends_count(halo) + receives_size = halo_all_receives_count(halo) + + assert(size(sends) == sends_size) + assert(any(size(send_starts) == (/nprocs, nprocs + 1/))) + assert(size(receives) == receives_size) + assert(any(size(receive_starts) == (/nprocs, nprocs + 1/))) + + ! Form sends, receives, send_starts and receive_starts from the halo + call extract_all_halo_sends(halo, sends, start_indices = send_starts(:nprocs)) + call extract_all_halo_receives(halo, receives, start_indices = receive_starts(:nprocs)) + if(size(send_starts) == nprocs + 1) send_starts(nprocs + 1) = sends_size + 1 + if(size(receive_starts) == nprocs + 1) receive_starts(nprocs + 1) = receives_size + 1 + + if(present(nowned_nodes)) then + ! Extract nowned_nodes from the halo + nowned_nodes = halo_nowned_nodes(halo) + end if + + end subroutine extract_raw_halo_data + + subroutine form_halo_from_raw_data(halo, nprocs, sends, send_starts, receives, receive_starts, nowned_nodes, ordering_scheme, create_caches) + !!< Inverse of extract_legacy_halo_data. halo is allocated by this + !!< routine. + + type(halo_type), intent(inout) :: halo + integer, intent(in) :: nprocs + integer, dimension(:), intent(in) :: sends + integer, dimension(:), intent(in) :: send_starts + integer, dimension(:), intent(in) :: receives + integer, dimension(:), intent(in) :: receive_starts + integer, optional, intent(in) :: nowned_nodes + integer, optional, intent(in) :: ordering_scheme + logical, optional, intent(in) :: create_caches + + integer :: i, lordering_scheme + integer, dimension(:), allocatable :: nreceives, nsends + logical :: lcreate_caches + + if(present(ordering_scheme)) then + lordering_scheme = ordering_scheme + else + lordering_scheme = HALO_ORDER_TRAILING_RECEIVES + end if + + lcreate_caches = .not. present_and_false(create_caches) + + ! Form nsends and nreceives from send_starts and receive_starts + assert(nprocs > 0) + assert(any(size(send_starts) == (/nprocs, nprocs + 1/))) + assert(any(size(receive_starts) == (/nprocs, nprocs + 1/))) allocate(nsends(nprocs)) allocate(nreceives(nprocs)) - do i = 1, nhalos - allocate(sends(halo_all_sends_count(mesh%halos(i)))) - allocate(receives(halo_all_receives_count(mesh%halos(i)))) - call extract_all_halo_sends(mesh%halos(i), sends, nsends = nsends) - call extract_all_halo_receives(mesh%halos(i), receives, nreceives = nreceives) - call chalo_writer_set_input(i, nparts, nsends(:nparts), nreceives(:nparts), & - & halo_nowned_nodes(mesh%halos(i)), sends, receives) - deallocate(sends) - deallocate(receives) + + do i = 1, size(send_starts) - 1 + nsends(i) = send_starts(i + 1) - send_starts(i) + assert(nsends(i) >= 0) end do - deallocate(nsends) - deallocate(nreceives) + if(size(send_starts) == nprocs) nsends(nprocs) = size(sends) - send_starts(nprocs) + 1 + assert(sum(nsends) == size(sends)) + + do i = 1, size(receive_starts) - 1 + nreceives(i) = receive_starts(i + 1) - receive_starts(i) + assert(nreceives(i) >= 0) + end do + if(size(receive_starts) == nprocs) nreceives(nprocs) = size(receives) - receive_starts(nprocs) + 1 + assert(sum(nreceives) == size(receives)) - error_count = chalo_writer_write(filename, len_trim(filename)) - call chalo_writer_reset() - else - error_count = 0 - end if - - call allsum(error_count, communicator = communicator) - if(error_count > 0) then - FLExit("Unable to write halos with name " // trim(filename)) - end if - - ewrite(1, *) "Exiting write_halos" - - end subroutine write_halos - - subroutine extract_raw_halo_data(halo, sends, send_starts, receives, receive_starts, nowned_nodes) - !!< Extract raw halo data from the supplied halo - - type(halo_type), intent(in) :: halo - - !! Send nodes for all processes. Size halo_all_sends_count(halo). - integer, dimension(:), intent(out) :: sends - !! imem type indices into sends denoting the start points of process send - !! nodes. Size halo_proc_count(halo) or halo_proc_count(halo) + 1. - integer, dimension(:), intent(out) :: send_starts - !! Receive nodes for all process. Size halo_all_receives_count(halo). - integer, dimension(:), intent(out) :: receives - !! imem type indices into receives denoting the start points of process - !! receive nodes. Size halo_proc_count(halo) or halo_proc_count(halo) + 1. - integer, dimension(:), intent(out) :: receive_starts - !! Number of owned nodes - integer, optional, intent(out) :: nowned_nodes - - integer :: nprocs, receives_size, sends_size - - nprocs = halo_proc_count(halo) - sends_size = halo_all_sends_count(halo) - receives_size = halo_all_receives_count(halo) - - assert(size(sends) == sends_size) - assert(any(size(send_starts) == (/nprocs, nprocs + 1/))) - assert(size(receives) == receives_size) - assert(any(size(receive_starts) == (/nprocs, nprocs + 1/))) - - ! Form sends, receives, send_starts and receive_starts from the halo - call extract_all_halo_sends(halo, sends, start_indices = send_starts(:nprocs)) - call extract_all_halo_receives(halo, receives, start_indices = receive_starts(:nprocs)) - if(size(send_starts) == nprocs + 1) send_starts(nprocs + 1) = sends_size + 1 - if(size(receive_starts) == nprocs + 1) receive_starts(nprocs + 1) = receives_size + 1 - - if(present(nowned_nodes)) then - ! Extract nowned_nodes from the halo - nowned_nodes = halo_nowned_nodes(halo) - end if - - end subroutine extract_raw_halo_data - - subroutine form_halo_from_raw_data(halo, nprocs, sends, send_starts, receives, receive_starts, nowned_nodes, ordering_scheme, create_caches) - !!< Inverse of extract_legacy_halo_data. halo is allocated by this - !!< routine. - - type(halo_type), intent(inout) :: halo - integer, intent(in) :: nprocs - integer, dimension(:), intent(in) :: sends - integer, dimension(:), intent(in) :: send_starts - integer, dimension(:), intent(in) :: receives - integer, dimension(:), intent(in) :: receive_starts - integer, optional, intent(in) :: nowned_nodes - integer, optional, intent(in) :: ordering_scheme - logical, optional, intent(in) :: create_caches - - integer :: i, lordering_scheme - integer, dimension(:), allocatable :: nreceives, nsends - logical :: lcreate_caches - - if(present(ordering_scheme)) then - lordering_scheme = ordering_scheme - else - lordering_scheme = HALO_ORDER_TRAILING_RECEIVES - end if - - lcreate_caches = .not. present_and_false(create_caches) - - ! Form nsends and nreceives from send_starts and receive_starts - assert(nprocs > 0) - assert(any(size(send_starts) == (/nprocs, nprocs + 1/))) - assert(any(size(receive_starts) == (/nprocs, nprocs + 1/))) - - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - - do i = 1, size(send_starts) - 1 - nsends(i) = send_starts(i + 1) - send_starts(i) - assert(nsends(i) >= 0) - end do - if(size(send_starts) == nprocs) nsends(nprocs) = size(sends) - send_starts(nprocs) + 1 - assert(sum(nsends) == size(sends)) - - do i = 1, size(receive_starts) - 1 - nreceives(i) = receive_starts(i + 1) - receive_starts(i) - assert(nreceives(i) >= 0) - end do - if(size(receive_starts) == nprocs) nreceives(nprocs) = size(receives) - receive_starts(nprocs) + 1 - assert(sum(nreceives) == size(receives)) - - ! Allocate the halo - call allocate(halo, nsends, nreceives, nprocs = nprocs, & + ! Allocate the halo + call allocate(halo, nsends, nreceives, nprocs = nprocs, & & nowned_nodes = nowned_nodes, name = "HaloFormedFromRawData", & & ordering_scheme = lordering_scheme) - deallocate(nsends) - deallocate(nreceives) + deallocate(nsends) + deallocate(nreceives) - ! Copy sends and receives into the halo - call set_all_halo_sends(halo, sends) - call set_all_halo_receives(halo, receives) + ! Copy sends and receives into the halo + call set_all_halo_sends(halo, sends) + call set_all_halo_receives(halo, receives) - if(lcreate_caches .and. .not. serial_storage_halo(halo)) then - call create_global_to_universal_numbering(halo) - call create_ownership(halo) - end if + if(lcreate_caches .and. .not. serial_storage_halo(halo)) then + call create_global_to_universal_numbering(halo) + call create_ownership(halo) + end if - end subroutine form_halo_from_raw_data + end subroutine form_halo_from_raw_data end module halos_registration diff --git a/femtools/Halos_Repair.F90 b/femtools/Halos_Repair.F90 index 54d250fdcf..b4acced3f6 100644 --- a/femtools/Halos_Repair.F90 +++ b/femtools/Halos_Repair.F90 @@ -29,743 +29,743 @@ module halos_repair - use fldebug - use futils - use mpi_interfaces - use parallel_tools - use halo_data_types - use quicksort - use halos_base - use halos_debug - use fields_data_types - use fields_base - use halos_numbering - use halos_ownership - - implicit none - - private - - public :: reorder_halo, reorder_l1_from_l2_halo, reorder_element_halo, & - & reorder_halo_receives, reorder_halo_from_element_halo - - interface reorder_halo - module procedure reorder_halo_vector, reorder_halo_halo - end interface reorder_halo + use fldebug + use futils + use mpi_interfaces + use parallel_tools + use halo_data_types + use quicksort + use halos_base + use halos_debug + use fields_data_types + use fields_base + use halos_numbering + use halos_ownership + + implicit none + + private + + public :: reorder_halo, reorder_l1_from_l2_halo, reorder_element_halo, & + & reorder_halo_receives, reorder_halo_from_element_halo + + interface reorder_halo + module procedure reorder_halo_vector, reorder_halo_halo + end interface reorder_halo contains - subroutine reorder_halo_vector(halo, repair_field) - !!< Reorder the halo sends and receives for consistency with the supplied - !!< repair field. Sends and receives are changed, although no communication - !!< is involved. - !!< IMPORTANT NOTE: This assumes that the repair field in the halo region is - !!< *floating point equal* across processes. - - type(halo_type), intent(inout) :: halo - type(vector_field), intent(in) :: repair_field - - integer :: i, j, receives_count, sends_count - integer, dimension(:), allocatable :: permutation, receives, sends - real, dimension(:, :), allocatable :: receive_data, send_data - - assert(any(halo_data_type(halo) == (/HALO_TYPE_CG_NODE, HALO_TYPE_DG_NODE/))) - assert(.not. has_global_to_universal_numbering(halo)) - assert(.not. has_ownership(halo)) - - do i = 1, halo_proc_count(halo) - ! Step 1: Extract the current halo sends - sends_count = halo_send_count(halo, i) - allocate(sends(sends_count)) - sends = halo_sends(halo, i) - - ! Step 2: Pull out the data we currently have for the sends - allocate(send_data(sends_count, repair_field%dim)) - do j = 1, sends_count - send_data(j, :) = node_val(repair_field, sends(j)) + subroutine reorder_halo_vector(halo, repair_field) + !!< Reorder the halo sends and receives for consistency with the supplied + !!< repair field. Sends and receives are changed, although no communication + !!< is involved. + !!< IMPORTANT NOTE: This assumes that the repair field in the halo region is + !!< *floating point equal* across processes. + + type(halo_type), intent(inout) :: halo + type(vector_field), intent(in) :: repair_field + + integer :: i, j, receives_count, sends_count + integer, dimension(:), allocatable :: permutation, receives, sends + real, dimension(:, :), allocatable :: receive_data, send_data + + assert(any(halo_data_type(halo) == (/HALO_TYPE_CG_NODE, HALO_TYPE_DG_NODE/))) + assert(.not. has_global_to_universal_numbering(halo)) + assert(.not. has_ownership(halo)) + + do i = 1, halo_proc_count(halo) + ! Step 1: Extract the current halo sends + sends_count = halo_send_count(halo, i) + allocate(sends(sends_count)) + sends = halo_sends(halo, i) + + ! Step 2: Pull out the data we currently have for the sends + allocate(send_data(sends_count, repair_field%dim)) + do j = 1, sends_count + send_data(j, :) = node_val(repair_field, sends(j)) + end do + + ! Step 3: Sort them into order + allocate(permutation(sends_count)) + call sort(send_data, permutation) + deallocate(send_data) + call apply_permutation(sends, permutation) + deallocate(permutation) + + ! Step 4: Set the halo sends + call set_halo_sends(halo, i, sends) + deallocate(sends) + + ! Step 5: Extract the current halo receives + receives_count = halo_receive_count(halo, i) + allocate(receives(receives_count)) + receives = halo_receives(halo, i) + + ! Step 6: Pull out the data we currently have for the receives + allocate(receive_data(receives_count, repair_field%dim)) + do j = 1, receives_count + receive_data(j, :) = node_val(repair_field, receives(j)) + end do + + ! Step 7: Sort them into order + allocate(permutation(receives_count)) + call sort(receive_data, permutation) + deallocate(receive_data) + call apply_permutation(receives, permutation) + deallocate(permutation) + + ! Step 8: Set the halo receives + call set_halo_receives(halo, i, receives) + deallocate(receives) end do - ! Step 3: Sort them into order - allocate(permutation(sends_count)) - call sort(send_data, permutation) - deallocate(send_data) - call apply_permutation(sends, permutation) - deallocate(permutation) + ! The halo sends and recevies are now sorted on all processes for all + ! processes, and hence must be in a consistent order (provided the halo + ! is actually valid on the supplied repair field) - ! Step 4: Set the halo sends - call set_halo_sends(halo, i, sends) - deallocate(sends) + end subroutine reorder_halo_vector - ! Step 5: Extract the current halo receives - receives_count = halo_receive_count(halo, i) - allocate(receives(receives_count)) - receives = halo_receives(halo, i) + subroutine reorder_halo_halo(halo, repair_halo) + !!< Using the order information from the supplied repair halo, rerorder the + !!< sends and receives in halo into a consistent order - ! Step 6: Pull out the data we currently have for the receives - allocate(receive_data(receives_count, repair_field%dim)) - do j = 1, receives_count - receive_data(j, :) = node_val(repair_field, receives(j)) - end do - - ! Step 7: Sort them into order - allocate(permutation(receives_count)) - call sort(receive_data, permutation) - deallocate(receive_data) - call apply_permutation(receives, permutation) - deallocate(permutation) - - ! Step 8: Set the halo receives - call set_halo_receives(halo, i, receives) - deallocate(receives) - end do + type(halo_type), intent(inout) :: halo + type(halo_type), intent(in) :: repair_halo - ! The halo sends and recevies are now sorted on all processes for all - ! processes, and hence must be in a consistent order (provided the halo - ! is actually valid on the supplied repair field) + integer :: i + integer, dimension(:), allocatable :: permutation + integer, dimension(:), pointer :: halo_nodes - end subroutine reorder_halo_vector + assert(has_global_to_universal_numbering(repair_halo)) + assert(.not. has_global_to_universal_numbering(halo)) + assert(.not. has_ownership(halo)) - subroutine reorder_halo_halo(halo, repair_halo) - !!< Using the order information from the supplied repair halo, rerorder the - !!< sends and receives in halo into a consistent order - - type(halo_type), intent(inout) :: halo - type(halo_type), intent(in) :: repair_halo - - integer :: i - integer, dimension(:), allocatable :: permutation - integer, dimension(:), pointer :: halo_nodes - - assert(has_global_to_universal_numbering(repair_halo)) - assert(.not. has_global_to_universal_numbering(halo)) - assert(.not. has_ownership(halo)) - - do i = 1, halo_proc_count(halo) - allocate(permutation(halo_send_count(halo, i))) - halo_nodes => halo_sends(halo, i) - call qsort(halo_universal_numbers(repair_halo, halo_nodes), permutation) - call apply_permutation(halo_nodes, permutation) - deallocate(permutation) - - allocate(permutation(halo_receive_count(halo, i))) - halo_nodes => halo_receives(halo, i) - call qsort(halo_universal_numbers(repair_halo, halo_nodes), permutation) - call apply_permutation(halo_nodes, permutation) - deallocate(permutation) - end do - - end subroutine reorder_halo_halo - - subroutine reorder_l1_from_l2_halo(l1_halo, l2_halo, sorted_l1_halo) - !!< Use the supplied consistently ordered l2 halo to reorder the supplied l1 - !!< halo - - type(halo_type), intent(inout) :: l1_halo - type(halo_type), intent(in) :: l2_halo - !! If present and .true., indicates that the l1 halo nodes are already - !! sorted into order - logical, optional, intent(in) :: sorted_l1_halo - - integer :: i, index, j - integer, dimension(:), allocatable :: l2_halo_nodes, permutation - integer, dimension(:), pointer :: l1_halo_nodes - logical :: lsorted_l1_halo - - lsorted_l1_halo = present_and_true(sorted_l1_halo) - - assert(.not. has_global_to_universal_numbering(l1_halo)) - assert(.not. has_ownership(l1_halo)) - assert(halo_proc_count(l1_halo) == halo_proc_count(l2_halo)) - - do i = 1, halo_proc_count(l1_halo) - ! Extract and (if necessary) sort the l1 halo sends - l1_halo_nodes => halo_sends(l1_halo, i) - if(size(l1_halo_nodes) == 0) cycle - if(.not. lsorted_l1_halo) then - allocate(permutation(size(l1_halo_nodes))) - call qsort(l1_halo_nodes, permutation) - call apply_permutation(l1_halo_nodes, permutation) - deallocate(permutation) - end if + do i = 1, halo_proc_count(halo) + allocate(permutation(halo_send_count(halo, i))) + halo_nodes => halo_sends(halo, i) + call qsort(halo_universal_numbers(repair_halo, halo_nodes), permutation) + call apply_permutation(halo_nodes, permutation) + deallocate(permutation) - ! Extract and sort the l2 halo sends - allocate(l2_halo_nodes(halo_send_count(l2_halo, i))) - l2_halo_nodes = halo_sends(l2_halo, i) - allocate(permutation(size(l2_halo_nodes))) - call qsort(l2_halo_nodes, permutation) - call apply_permutation(l2_halo_nodes, permutation) - ! Zero out the pure l2 sends in the l2 halo, to leave just the l1 halo sends - index = 1 - do j = 1, size(l2_halo_nodes) - if(l1_halo_nodes(index) == l2_halo_nodes(j)) then - index = index + 1 - if(index > size(l1_halo_nodes)) then - l2_halo_nodes(j + 1:) = 0 - exit - end if - else - l2_halo_nodes(j) = 0 - end if + allocate(permutation(halo_receive_count(halo, i))) + halo_nodes => halo_receives(halo, i) + call qsort(halo_universal_numbers(repair_halo, halo_nodes), permutation) + call apply_permutation(halo_nodes, permutation) + deallocate(permutation) end do - ! Permute the l2 halo sends (with pure l2 sends zerod out) back into their - ! original order - call apply_permutation(l2_halo_nodes, inverse_permutation(permutation)) - deallocate(permutation) - ! Collapse the l1 halo sends (stripping out the zeros) - index = 1 - do j = 1, size(l2_halo_nodes) - if(l2_halo_nodes(j) > 0) then - l1_halo_nodes(index) = l2_halo_nodes(j) - index = index + 1 - if(index > size(l1_halo_nodes)) exit - end if - end do - deallocate(l2_halo_nodes) - end do - - do i = 1, halo_proc_count(l1_halo) - ! Extract and (if necessary) sort the l1 halo receives - l1_halo_nodes => halo_receives(l1_halo, i) - if(size(l1_halo_nodes) == 0) cycle - if(.not. lsorted_l1_halo) then - allocate(permutation(size(l1_halo_nodes))) - call qsort(l1_halo_nodes, permutation) - call apply_permutation(l1_halo_nodes, permutation) - deallocate(permutation) - end if - ! Extract and sort the l2 halo receives - allocate(l2_halo_nodes(halo_receive_count(l2_halo, i))) - l2_halo_nodes = halo_receives(l2_halo, i) - allocate(permutation(size(l2_halo_nodes))) - call qsort(l2_halo_nodes, permutation) - call apply_permutation(l2_halo_nodes, permutation) - ! Zero out the pure l2 receives in the l2 halo, to leave just the l1 halo receives - index = 1 - do j = 1, size(l2_halo_nodes) - if(l1_halo_nodes(index) == l2_halo_nodes(j)) then - index = index + 1 - if(index > size(l1_halo_nodes)) then - l2_halo_nodes(j + 1:) = 0 - exit - end if - else - l2_halo_nodes(j) = 0 - end if + end subroutine reorder_halo_halo + + subroutine reorder_l1_from_l2_halo(l1_halo, l2_halo, sorted_l1_halo) + !!< Use the supplied consistently ordered l2 halo to reorder the supplied l1 + !!< halo + + type(halo_type), intent(inout) :: l1_halo + type(halo_type), intent(in) :: l2_halo + !! If present and .true., indicates that the l1 halo nodes are already + !! sorted into order + logical, optional, intent(in) :: sorted_l1_halo + + integer :: i, index, j + integer, dimension(:), allocatable :: l2_halo_nodes, permutation + integer, dimension(:), pointer :: l1_halo_nodes + logical :: lsorted_l1_halo + + lsorted_l1_halo = present_and_true(sorted_l1_halo) + + assert(.not. has_global_to_universal_numbering(l1_halo)) + assert(.not. has_ownership(l1_halo)) + assert(halo_proc_count(l1_halo) == halo_proc_count(l2_halo)) + + do i = 1, halo_proc_count(l1_halo) + ! Extract and (if necessary) sort the l1 halo sends + l1_halo_nodes => halo_sends(l1_halo, i) + if(size(l1_halo_nodes) == 0) cycle + if(.not. lsorted_l1_halo) then + allocate(permutation(size(l1_halo_nodes))) + call qsort(l1_halo_nodes, permutation) + call apply_permutation(l1_halo_nodes, permutation) + deallocate(permutation) + end if + + ! Extract and sort the l2 halo sends + allocate(l2_halo_nodes(halo_send_count(l2_halo, i))) + l2_halo_nodes = halo_sends(l2_halo, i) + allocate(permutation(size(l2_halo_nodes))) + call qsort(l2_halo_nodes, permutation) + call apply_permutation(l2_halo_nodes, permutation) + ! Zero out the pure l2 sends in the l2 halo, to leave just the l1 halo sends + index = 1 + do j = 1, size(l2_halo_nodes) + if(l1_halo_nodes(index) == l2_halo_nodes(j)) then + index = index + 1 + if(index > size(l1_halo_nodes)) then + l2_halo_nodes(j + 1:) = 0 + exit + end if + else + l2_halo_nodes(j) = 0 + end if + end do + ! Permute the l2 halo sends (with pure l2 sends zerod out) back into their + ! original order + call apply_permutation(l2_halo_nodes, inverse_permutation(permutation)) + deallocate(permutation) + ! Collapse the l1 halo sends (stripping out the zeros) + index = 1 + do j = 1, size(l2_halo_nodes) + if(l2_halo_nodes(j) > 0) then + l1_halo_nodes(index) = l2_halo_nodes(j) + index = index + 1 + if(index > size(l1_halo_nodes)) exit + end if + end do + deallocate(l2_halo_nodes) end do - ! Permute the l2 halo receives (with pure l2 receives zerod out) back into their - ! original order - call apply_permutation(l2_halo_nodes, inverse_permutation(permutation)) - deallocate(permutation) - ! Collapse the l1 halo receives (stripping out the zeros) - index = 1 - do j = 1, size(l2_halo_nodes) - if(l2_halo_nodes(j) > 0) then - l1_halo_nodes(index) = l2_halo_nodes(j) - index = index + 1 - if(index > size(l1_halo_nodes)) exit - end if + + do i = 1, halo_proc_count(l1_halo) + ! Extract and (if necessary) sort the l1 halo receives + l1_halo_nodes => halo_receives(l1_halo, i) + if(size(l1_halo_nodes) == 0) cycle + if(.not. lsorted_l1_halo) then + allocate(permutation(size(l1_halo_nodes))) + call qsort(l1_halo_nodes, permutation) + call apply_permutation(l1_halo_nodes, permutation) + deallocate(permutation) + end if + + ! Extract and sort the l2 halo receives + allocate(l2_halo_nodes(halo_receive_count(l2_halo, i))) + l2_halo_nodes = halo_receives(l2_halo, i) + allocate(permutation(size(l2_halo_nodes))) + call qsort(l2_halo_nodes, permutation) + call apply_permutation(l2_halo_nodes, permutation) + ! Zero out the pure l2 receives in the l2 halo, to leave just the l1 halo receives + index = 1 + do j = 1, size(l2_halo_nodes) + if(l1_halo_nodes(index) == l2_halo_nodes(j)) then + index = index + 1 + if(index > size(l1_halo_nodes)) then + l2_halo_nodes(j + 1:) = 0 + exit + end if + else + l2_halo_nodes(j) = 0 + end if + end do + ! Permute the l2 halo receives (with pure l2 receives zerod out) back into their + ! original order + call apply_permutation(l2_halo_nodes, inverse_permutation(permutation)) + deallocate(permutation) + ! Collapse the l1 halo receives (stripping out the zeros) + index = 1 + do j = 1, size(l2_halo_nodes) + if(l2_halo_nodes(j) > 0) then + l1_halo_nodes(index) = l2_halo_nodes(j) + index = index + 1 + if(index > size(l1_halo_nodes)) exit + end if + end do + deallocate(l2_halo_nodes) end do - deallocate(l2_halo_nodes) - end do - end subroutine reorder_l1_from_l2_halo + end subroutine reorder_l1_from_l2_halo - subroutine reorder_halo_from_element_halo(node_halo, element_halo, mesh) - !!< Using the order information in the element halo, reorder the sends - !!< and receives in halo into a consistent order. - !!< - !!< This has the side effect of also defining the universal numbering on - !!< node_halo. + subroutine reorder_halo_from_element_halo(node_halo, element_halo, mesh) + !!< Using the order information in the element halo, reorder the sends + !!< and receives in halo into a consistent order. + !!< + !!< This has the side effect of also defining the universal numbering on + !!< node_halo. - type(halo_type), intent(inout) :: node_halo - type(halo_type), intent(in) :: element_halo - type(mesh_type), intent(in) :: mesh + type(halo_type), intent(inout) :: node_halo + type(halo_type), intent(in) :: element_halo + type(mesh_type), intent(in) :: mesh - integer :: p, nprocs, n - integer, dimension(:), allocatable :: global_numbers, order + integer :: p, nprocs, n + integer, dimension(:), allocatable :: global_numbers, order - assert(any(halo_data_type(node_halo) == (/HALO_TYPE_CG_NODE, HALO_TYPE_DG_NODE/))) - assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) - assert(.not. has_global_to_universal_numbering(node_halo)) - assert(.not. has_ownership(node_halo)) + assert(any(halo_data_type(node_halo) == (/HALO_TYPE_CG_NODE, HALO_TYPE_DG_NODE/))) + assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) + assert(.not. has_global_to_universal_numbering(node_halo)) + assert(.not. has_ownership(node_halo)) - nprocs = halo_proc_count(node_halo) + nprocs = halo_proc_count(node_halo) - ! First we need to establish the universal numbers of owned nodes. - call create_global_to_universal_numbering(node_halo, local_only=.true.) + ! First we need to establish the universal numbers of owned nodes. + call create_global_to_universal_numbering(node_halo, local_only=.true.) - call communicate_universal_numbers(node_halo, element_halo, mesh) + call communicate_universal_numbers(node_halo, element_halo, mesh) #ifdef DDEBUG - select case(halo_ordering_scheme(node_halo)) - case(HALO_ORDER_GENERAL) - assert(minval(node_halo%gnn_to_unn)>0) - case(HALO_ORDER_TRAILING_RECEIVES) - assert(minval(node_halo%receives_gnn_to_unn)>0) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + select case(halo_ordering_scheme(node_halo)) + case(HALO_ORDER_GENERAL) + assert(minval(node_halo%gnn_to_unn)>0) + case(HALO_ORDER_TRAILING_RECEIVES) + assert(minval(node_halo%receives_gnn_to_unn)>0) + case default + FLAbort("Unrecognised halo ordering scheme") + end select #endif - ! Now that we have the universal numbers, we can sort the send and - ! receive lists into universal number order. - do p=1, nprocs - ! Sort receives for this processor. - allocate(global_numbers(halo_receive_count(node_halo,p))) - allocate(order(halo_receive_count(node_halo,p))) - do n=1,size(global_numbers) - global_numbers(n)=halo_universal_number(node_halo,& + ! Now that we have the universal numbers, we can sort the send and + ! receive lists into universal number order. + do p=1, nprocs + ! Sort receives for this processor. + allocate(global_numbers(halo_receive_count(node_halo,p))) + allocate(order(halo_receive_count(node_halo,p))) + do n=1,size(global_numbers) + global_numbers(n)=halo_universal_number(node_halo,& halo_receive(node_halo,p,n)) - end do + end do - call qsort(global_numbers, order) - call apply_permutation(node_halo%receives(p)%ptr, order) - deallocate(global_numbers,order) + call qsort(global_numbers, order) + call apply_permutation(node_halo%receives(p)%ptr, order) + deallocate(global_numbers,order) - ! Sort sends for this processor. - allocate(global_numbers(halo_send_count(node_halo,p))) - allocate(order(halo_send_count(node_halo,p))) - do n=1,size(global_numbers) - global_numbers(n)=halo_universal_number(node_halo,& + ! Sort sends for this processor. + allocate(global_numbers(halo_send_count(node_halo,p))) + allocate(order(halo_send_count(node_halo,p))) + do n=1,size(global_numbers) + global_numbers(n)=halo_universal_number(node_halo,& halo_send(node_halo,p,n)) - end do + end do - call qsort(global_numbers, order) - call apply_permutation(node_halo%sends(p)%ptr, order) - deallocate(global_numbers,order) - end do + call qsort(global_numbers, order) + call apply_permutation(node_halo%sends(p)%ptr, order) + deallocate(global_numbers,order) + end do #ifdef DDEBUG - if(halo_ordering_scheme(node_halo) == HALO_ORDER_TRAILING_RECEIVES) then - assert(trailing_receives_consistent(node_halo)) - end if + if(halo_ordering_scheme(node_halo) == HALO_ORDER_TRAILING_RECEIVES) then + assert(trailing_receives_consistent(node_halo)) + end if #endif - call create_ownership(node_halo) + call create_ownership(node_halo) - end subroutine reorder_halo_from_element_halo + end subroutine reorder_halo_from_element_halo - subroutine communicate_universal_numbers(node_halo, element_halo, mesh) - ! Communicate the universal numbers of halos. Due to the problem of - ! receive nodes in send elements, it is necessary to do this twice as - ! some numbers will travel indirectly via third processors. + subroutine communicate_universal_numbers(node_halo, element_halo, mesh) + ! Communicate the universal numbers of halos. Due to the problem of + ! receive nodes in send elements, it is necessary to do this twice as + ! some numbers will travel indirectly via third processors. - type(halo_type), intent(inout) :: node_halo - type(halo_type), intent(in) :: element_halo - type(mesh_type), intent(in) :: mesh + type(halo_type), intent(inout) :: node_halo + type(halo_type), intent(in) :: element_halo + type(mesh_type), intent(in) :: mesh #ifdef HAVE_MPI - type(integer_vector), dimension(:), allocatable :: send_data, receive_data - integer :: p, nloc, nprocs, communicator, rank, ierr, pos, n, e, stat, i - integer :: current_unn, new_unn, total_halo, sends, receives - integer, dimension(:), pointer :: nodes - integer, dimension(:), allocatable :: requests, statuses - integer tag(2) - - nprocs = halo_proc_count(node_halo) - communicator = halo_communicator(node_halo) - - allocate(send_data(nprocs), receive_data(nprocs)) - - ! Note that this won't work for mixed element meshes. - nloc=ele_loc(mesh,1) - - ! Establish lists of the universal numbers for both send and receive elements. - ! - ! Because the boundary between processors is in a slightly different - ! location for element and node halos, it is necessary to do a double - ! communication in which universal numbers corresponding to elements in - ! the entire send and receive components of the element halo are transmitted. - do p=1, nprocs - total_halo=halo_send_count(element_halo,p)+halo_receive_count(element_halo,p) - allocate(send_data(p)%ptr(nloc*total_halo)) - allocate(receive_data(p)%ptr(nloc*total_halo)) - end do - - doubleloop: do i = 1, 2 - do p=1, nprocs - do e=1,halo_send_count(element_halo,p) - nodes=>ele_nodes(mesh,halo_send(element_halo,p,e)) - do n=1,nloc - pos=(e-1)*nloc+n - send_data(p)%ptr(pos)=halo_universal_number(node_halo,nodes(n)) - end do - end do - - sends=halo_send_count(element_halo,p) - do e=1,halo_receive_count(element_halo,p) - nodes=>ele_nodes(mesh,halo_receive(element_halo,p,e)) - do n=1,nloc - pos=(e+sends-1)*nloc+n - send_data(p)%ptr(pos)=halo_universal_number(node_halo,nodes(n)) - end do - end do - - end do - - ! Actually communicate the data - rank = getrank(communicator) - tag(i) = next_mpi_tag() - - allocate(requests(2*nprocs)) - requests = MPI_REQUEST_NULL - do p = 1, nprocs - if(size(send_data(p)%ptr) > 0) then - ! Non-blocking sends - call mpi_isend(send_data(p)%ptr, size(send_data(p)%ptr), getpinteger()& - &, p - 1, tag(i), communicator, & - & requests(p), ierr) - assert(ierr == MPI_SUCCESS) - end if + type(integer_vector), dimension(:), allocatable :: send_data, receive_data + integer :: p, nloc, nprocs, communicator, rank, ierr, pos, n, e, stat, i + integer :: current_unn, new_unn, total_halo, sends, receives + integer, dimension(:), pointer :: nodes + integer, dimension(:), allocatable :: requests, statuses + integer tag(2) + + nprocs = halo_proc_count(node_halo) + communicator = halo_communicator(node_halo) + + allocate(send_data(nprocs), receive_data(nprocs)) + + ! Note that this won't work for mixed element meshes. + nloc=ele_loc(mesh,1) + + ! Establish lists of the universal numbers for both send and receive elements. + ! + ! Because the boundary between processors is in a slightly different + ! location for element and node halos, it is necessary to do a double + ! communication in which universal numbers corresponding to elements in + ! the entire send and receive components of the element halo are transmitted. + do p=1, nprocs + total_halo=halo_send_count(element_halo,p)+halo_receive_count(element_halo,p) + allocate(send_data(p)%ptr(nloc*total_halo)) + allocate(receive_data(p)%ptr(nloc*total_halo)) + end do - ! Non-blocking receives - if(size(receive_data(p)%ptr) > 0) then - call mpi_irecv(receive_data(p)%ptr, size(receive_data(p)%ptr),& - & getpinteger(), p-1, tag(i), communicator, requests(p+nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - ! Now that we have all the communications, walk through them and set - ! the corresponding universal numbers. - do p=1, nprocs - do e=1,halo_receive_count(element_halo,p) - nodes=>ele_nodes(mesh,halo_receive(element_halo,p,e)) - - nodeloop: do n=1,nloc - pos=(e-1)*nloc+n - new_unn=receive_data(p)%ptr(pos) - if (new_unn>0) then - ! We have real data (unknown quantities are transmitted as - !-1) - current_unn=halo_universal_number(node_halo,nodes(n)) - if(new_unn==current_unn) then - ! Already got this information - cycle nodeloop - else if (current_unn<0) then - call set_halo_universal_number(node_halo, nodes(n),& - & new_unn, stat) - ! We don't bother to check stat as it could legitimately - ! be 1 in the case where the halo does not cover the - ! whole mesh. - else - FLAbort("Universal node number mismatch") - end if - end if - - end do nodeloop - end do - receives=halo_receive_count(element_halo,p) - do e=1,halo_send_count(element_halo,p) - nodes=>ele_nodes(mesh,halo_send(element_halo,p,e)) - - receive_nodeloop: do n=1,nloc - pos=(e+receives-1)*nloc+n - new_unn=receive_data(p)%ptr(pos) - if (new_unn>0) then - ! We have real data (unknown quantities are transmitted as - !-1) - current_unn=halo_universal_number(node_halo,nodes(n)) - if(new_unn==current_unn) then - ! Already got this information - cycle receive_nodeloop - else if (current_unn<0) then - call set_halo_universal_number(node_halo, nodes(n),& - & new_unn, stat) - ! We don't bother to check stat as it could legitimately - ! be 1 in the case where the halo does not cover the - ! whole mesh. - else - FLAbort("Universal node number mismatch") - end if - end if - - end do receive_nodeloop - end do - end do - end do doubleloop - - do p=1, nprocs - deallocate(send_data(p)%ptr) - deallocate(receive_data(p)%ptr) - end do + doubleloop: do i = 1, 2 + do p=1, nprocs + do e=1,halo_send_count(element_halo,p) + nodes=>ele_nodes(mesh,halo_send(element_halo,p,e)) + do n=1,nloc + pos=(e-1)*nloc+n + send_data(p)%ptr(pos)=halo_universal_number(node_halo,nodes(n)) + end do + end do + + sends=halo_send_count(element_halo,p) + do e=1,halo_receive_count(element_halo,p) + nodes=>ele_nodes(mesh,halo_receive(element_halo,p,e)) + do n=1,nloc + pos=(e+sends-1)*nloc+n + send_data(p)%ptr(pos)=halo_universal_number(node_halo,nodes(n)) + end do + end do + + end do + + ! Actually communicate the data + rank = getrank(communicator) + tag(i) = next_mpi_tag() + + allocate(requests(2*nprocs)) + requests = MPI_REQUEST_NULL + do p = 1, nprocs + if(size(send_data(p)%ptr) > 0) then + ! Non-blocking sends + call mpi_isend(send_data(p)%ptr, size(send_data(p)%ptr), getpinteger()& + &, p - 1, tag(i), communicator, & + & requests(p), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(size(receive_data(p)%ptr) > 0) then + call mpi_irecv(receive_data(p)%ptr, size(receive_data(p)%ptr),& + & getpinteger(), p-1, tag(i), communicator, requests(p+nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + ! Now that we have all the communications, walk through them and set + ! the corresponding universal numbers. + do p=1, nprocs + do e=1,halo_receive_count(element_halo,p) + nodes=>ele_nodes(mesh,halo_receive(element_halo,p,e)) + + nodeloop: do n=1,nloc + pos=(e-1)*nloc+n + new_unn=receive_data(p)%ptr(pos) + if (new_unn>0) then + ! We have real data (unknown quantities are transmitted as + !-1) + current_unn=halo_universal_number(node_halo,nodes(n)) + if(new_unn==current_unn) then + ! Already got this information + cycle nodeloop + else if (current_unn<0) then + call set_halo_universal_number(node_halo, nodes(n),& + & new_unn, stat) + ! We don't bother to check stat as it could legitimately + ! be 1 in the case where the halo does not cover the + ! whole mesh. + else + FLAbort("Universal node number mismatch") + end if + end if + + end do nodeloop + end do + receives=halo_receive_count(element_halo,p) + do e=1,halo_send_count(element_halo,p) + nodes=>ele_nodes(mesh,halo_send(element_halo,p,e)) + + receive_nodeloop: do n=1,nloc + pos=(e+receives-1)*nloc+n + new_unn=receive_data(p)%ptr(pos) + if (new_unn>0) then + ! We have real data (unknown quantities are transmitted as + !-1) + current_unn=halo_universal_number(node_halo,nodes(n)) + if(new_unn==current_unn) then + ! Already got this information + cycle receive_nodeloop + else if (current_unn<0) then + call set_halo_universal_number(node_halo, nodes(n),& + & new_unn, stat) + ! We don't bother to check stat as it could legitimately + ! be 1 in the case where the halo does not cover the + ! whole mesh. + else + FLAbort("Universal node number mismatch") + end if + end if + + end do receive_nodeloop + end do + end do + end do doubleloop + + do p=1, nprocs + deallocate(send_data(p)%ptr) + deallocate(receive_data(p)%ptr) + end do #else - FLAbort("Communicating universal numbers makes no sense without MPI") + FLAbort("Communicating universal numbers makes no sense without MPI") #endif - end subroutine communicate_universal_numbers + end subroutine communicate_universal_numbers - subroutine reorder_element_halo(element_halo, node_halo, mesh) - !!< Reorder the halo sends and receives in the supplied element halo for - !!< consistency with the universal numbering of the supplied node halo. + subroutine reorder_element_halo(element_halo, node_halo, mesh) + !!< Reorder the halo sends and receives in the supplied element halo for + !!< consistency with the universal numbering of the supplied node halo. - type(halo_type), intent(inout) :: element_halo - type(halo_type), intent(in) :: node_halo - type(mesh_type), intent(in) :: mesh + type(halo_type), intent(inout) :: element_halo + type(halo_type), intent(in) :: node_halo + type(mesh_type), intent(in) :: mesh - integer :: i, j, k, loc, receives_count, sends_count - integer, dimension(:), allocatable :: permutation, receives, sends, unns, unns_permutation - integer, dimension(:, :), allocatable :: receive_data, send_data + integer :: i, j, k, loc, receives_count, sends_count + integer, dimension(:), allocatable :: permutation, receives, sends, unns, unns_permutation + integer, dimension(:, :), allocatable :: receive_data, send_data - assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) - assert(.not. has_global_to_universal_numbering(element_halo)) - assert(.not. has_ownership(element_halo)) + assert(halo_data_type(element_halo) == HALO_TYPE_ELEMENT) + assert(.not. has_global_to_universal_numbering(element_halo)) + assert(.not. has_ownership(element_halo)) - ! Hybrid meshes are not supported by this algorithm. This could be done - ! if a csr sparsity sort were written to swap out for sort_integer_array, - ! but as femtools doesn't yet support hybrid meshes anyway ... - loc = ele_loc(mesh, 1) + ! Hybrid meshes are not supported by this algorithm. This could be done + ! if a csr sparsity sort were written to swap out for sort_integer_array, + ! but as femtools doesn't yet support hybrid meshes anyway ... + loc = ele_loc(mesh, 1) #ifdef DDEBUG - do i = 2, ele_count(mesh) - assert(ele_loc(mesh, i) == loc) - end do + do i = 2, ele_count(mesh) + assert(ele_loc(mesh, i) == loc) + end do #endif - allocate(unns(loc)) - allocate(unns_permutation(loc)) - - ! This is basically the same as reorder_halo, except we're repairing using - ! the universal numbering of the node halo instead of a field - - do i = 1, halo_proc_count(element_halo) - ! Step 1: Extract the current halo sends - sends_count = halo_send_count(element_halo, i) - allocate(sends(sends_count)) - sends = halo_sends(element_halo, i) - - ! Step 2: Collect the ordered universal numbering on the sends - allocate(send_data(sends_count, loc)) - do j = 1, sends_count - unns = halo_universal_numbers(node_halo, ele_nodes(mesh, sends(j))) - call qsort(unns, unns_permutation) - do k = 1, loc - send_data(j, k) = unns(unns_permutation(k)) - end do + allocate(unns(loc)) + allocate(unns_permutation(loc)) + + ! This is basically the same as reorder_halo, except we're repairing using + ! the universal numbering of the node halo instead of a field + + do i = 1, halo_proc_count(element_halo) + ! Step 1: Extract the current halo sends + sends_count = halo_send_count(element_halo, i) + allocate(sends(sends_count)) + sends = halo_sends(element_halo, i) + + ! Step 2: Collect the ordered universal numbering on the sends + allocate(send_data(sends_count, loc)) + do j = 1, sends_count + unns = halo_universal_numbers(node_halo, ele_nodes(mesh, sends(j))) + call qsort(unns, unns_permutation) + do k = 1, loc + send_data(j, k) = unns(unns_permutation(k)) + end do + end do + + ! Step 3: Sort them into order + allocate(permutation(sends_count)) + call sort(send_data, permutation) + deallocate(send_data) + call apply_permutation(sends, permutation) + deallocate(permutation) + + ! Step 4: Set the halo sends + call set_halo_sends(element_halo, i, sends) + deallocate(sends) + + ! Step 5: Extract the current halo receives + receives_count = halo_receive_count(element_halo, i) + allocate(receives(receives_count)) + receives = halo_receives(element_halo, i) + + ! Step 6: Collect the ordered universal numbering on the receives + allocate(receive_data(receives_count, loc)) + do j = 1, receives_count + unns = halo_universal_numbers(node_halo, ele_nodes(mesh, receives(j))) + call qsort(unns, unns_permutation) + do k = 1, loc + receive_data(j, k) = unns(unns_permutation(k)) + end do + end do + + ! Step 7: Sort them into order + allocate(permutation(receives_count)) + call sort(receive_data, permutation) + deallocate(receive_data) + call apply_permutation(receives, permutation) + deallocate(permutation) + + ! Step 8: Set the halo receives + call set_halo_receives(element_halo, i, receives) + deallocate(receives) end do - ! Step 3: Sort them into order - allocate(permutation(sends_count)) - call sort(send_data, permutation) - deallocate(send_data) - call apply_permutation(sends, permutation) - deallocate(permutation) + deallocate(unns) + deallocate(unns_permutation) - ! Step 4: Set the halo sends - call set_halo_sends(element_halo, i, sends) - deallocate(sends) + end subroutine reorder_element_halo - ! Step 5: Extract the current halo receives - receives_count = halo_receive_count(element_halo, i) - allocate(receives(receives_count)) - receives = halo_receives(element_halo, i) - - ! Step 6: Collect the ordered universal numbering on the receives - allocate(receive_data(receives_count, loc)) - do j = 1, receives_count - unns = halo_universal_numbers(node_halo, ele_nodes(mesh, receives(j))) - call qsort(unns, unns_permutation) - do k = 1, loc - receive_data(j, k) = unns(unns_permutation(k)) - end do - end do + subroutine reorder_halo_receives(halo, repair_field) + !!< Reorder the halo receives for consistency with the supplied repair + !!< field (which will typically be Coordinate). The sends are unchanged in + !!< the repair, although communication is involved. - ! Step 7: Sort them into order - allocate(permutation(receives_count)) - call sort(receive_data, permutation) - deallocate(receive_data) - call apply_permutation(receives, permutation) - deallocate(permutation) + type(halo_type), intent(inout) :: halo + type(vector_field), intent(in) :: repair_field - ! Step 8: Set the halo receives - call set_halo_receives(element_halo, i, receives) - deallocate(receives) - end do + assert(halo_valid_for_communication(halo)) + assert(.not. pending_communication(halo)) + assert(.not. has_global_to_universal_numbering(halo)) + assert(.not. has_ownership(halo)) - deallocate(unns) - deallocate(unns_permutation) + select case(halo_ordering_scheme(halo)) + case(HALO_ORDER_GENERAL) + FLAbort("Halo receive reordering is not yet available for halos with general ordering") + case(HALO_ORDER_TRAILING_RECEIVES) + call reorder_halo_receives_order_trailing_receives(halo, repair_field) + case default + FLAbort("Unrecognised halo ordering scheme") + end select - end subroutine reorder_element_halo + end subroutine reorder_halo_receives + + subroutine reorder_halo_receives_order_trailing_receives(halo, repair_field) + !!< Reorder the halo receives for consistency with the supplied repair + !!< field (which will typically be Coordinate). The sends are unchanged in + !!< the repair, although communication is involved. + !!< IMPORTANT NOTE: This assumes that the repair field in the halo region is + !!< *floating point equal* across processes. - subroutine reorder_halo_receives(halo, repair_field) - !!< Reorder the halo receives for consistency with the supplied repair - !!< field (which will typically be Coordinate). The sends are unchanged in - !!< the repair, although communication is involved. + type(halo_type), intent(inout) :: halo + type(vector_field), intent(in) :: repair_field - type(halo_type), intent(inout) :: halo - type(vector_field), intent(in) :: repair_field +#ifdef HAVE_MPI + integer :: communicator, i, ierr, j, nprocs, nsends, rank, receives_count + integer, dimension(:), allocatable :: receives, requests, & + & send_types, start_indices, statuses, permutation, & + & permutation_inverse + real, dimension(:, :), allocatable :: current_receive_data, correct_receive_data + integer tag - assert(halo_valid_for_communication(halo)) - assert(.not. pending_communication(halo)) - assert(.not. has_global_to_universal_numbering(halo)) - assert(.not. has_ownership(halo)) + assert(trailing_receives_consistent(halo)) - select case(halo_ordering_scheme(halo)) - case(HALO_ORDER_GENERAL) - FLAbort("Halo receive reordering is not yet available for halos with general ordering") - case(HALO_ORDER_TRAILING_RECEIVES) - call reorder_halo_receives_order_trailing_receives(halo, repair_field) - case default - FLAbort("Unrecognised halo ordering scheme") - end select + nprocs = halo_proc_count(halo) + communicator = halo_communicator(halo) - end subroutine reorder_halo_receives + ! Step 1: Extract the current halo receives - subroutine reorder_halo_receives_order_trailing_receives(halo, repair_field) - !!< Reorder the halo receives for consistency with the supplied repair - !!< field (which will typically be Coordinate). The sends are unchanged in - !!< the repair, although communication is involved. - !!< IMPORTANT NOTE: This assumes that the repair field in the halo region is - !!< *floating point equal* across processes. + receives_count = halo_all_receives_count(halo) + allocate(receives(receives_count)) + allocate(start_indices(nprocs)) + call extract_all_halo_receives(halo, receives, start_indices = start_indices) - type(halo_type), intent(inout) :: halo - type(vector_field), intent(in) :: repair_field + ! Step 2: Pull out the data we currently have for the receives -#ifdef HAVE_MPI - integer :: communicator, i, ierr, j, nprocs, nsends, rank, receives_count - integer, dimension(:), allocatable :: receives, requests, & - & send_types, start_indices, statuses, permutation, & - & permutation_inverse - real, dimension(:, :), allocatable :: current_receive_data, correct_receive_data - integer tag - - assert(trailing_receives_consistent(halo)) - - nprocs = halo_proc_count(halo) - communicator = halo_communicator(halo) - - ! Step 1: Extract the current halo receives - - receives_count = halo_all_receives_count(halo) - allocate(receives(receives_count)) - allocate(start_indices(nprocs)) - call extract_all_halo_receives(halo, receives, start_indices = start_indices) - - ! Step 2: Pull out the data we currently have for the receives - - allocate(current_receive_data(receives_count, repair_field%dim)) - do i = 1, receives_count - current_receive_data(i, :) = node_val(repair_field, receives(i)) - end do - - ! Step 3: Communicate the data from other processes, indicating what we - ! should have retrieved on the receives - - ! Create indexed MPI types defining the indices into real data to be - ! sent/received - allocate(send_types(nprocs)) - send_types = MPI_DATATYPE_NULL - do i = 1, nprocs - nsends = halo_send_count(halo, i) - if(nsends > 0) then - call mpi_type_create_indexed_block(nsends, 1, & - & halo_sends(halo, i) - 1, getpreal(), send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - call mpi_type_commit(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - - ! Set up non-blocking communications - allocate(correct_receive_data(receives_count, repair_field%dim)) - allocate(requests(nprocs * 2 * repair_field%dim)) - requests = MPI_REQUEST_NULL - rank = getrank(communicator) - tag = next_mpi_tag() - - do i = 1, nprocs - do j = 1, repair_field%dim - ! Non-blocking sends - if(halo_send_count(halo, i) > 0) then - call mpi_isend(repair_field%val(j,:), 1, send_types(i), i - 1, & - tag, communicator, requests((i - 1) * repair_field%dim + j), ierr) - assert(ierr == MPI_SUCCESS) - end if - - ! Non-blocking receives - if(halo_receive_count(halo, i) > 0) then - call mpi_irecv(correct_receive_data(start_indices(i):, j), & - halo_receive_count(halo, i), getpreal(), i - 1, tag, & - communicator, requests((i - 1 + nprocs) * repair_field%dim + j), ierr) - assert(ierr == MPI_SUCCESS) - end if + allocate(current_receive_data(receives_count, repair_field%dim)) + do i = 1, receives_count + current_receive_data(i, :) = node_val(repair_field, receives(i)) end do - end do - deallocate(start_indices) - - ! Wait for all non-blocking communications to complete - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) - deallocate(statuses) - deallocate(requests) - - ! Free the indexed MPI types - do i = 1, nprocs - if(send_types(i) /= MPI_DATATYPE_NULL) then - call mpi_type_free(send_types(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do - deallocate(send_types) - ! If all is as expected, current_receive_data and correct_receive_data now - ! contain the same data in different orders. + ! Step 3: Communicate the data from other processes, indicating what we + ! should have retrieved on the receives + + ! Create indexed MPI types defining the indices into real data to be + ! sent/received + allocate(send_types(nprocs)) + send_types = MPI_DATATYPE_NULL + do i = 1, nprocs + nsends = halo_send_count(halo, i) + if(nsends > 0) then + call mpi_type_create_indexed_block(nsends, 1, & + & halo_sends(halo, i) - 1, getpreal(), send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + call mpi_type_commit(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Set up non-blocking communications + allocate(correct_receive_data(receives_count, repair_field%dim)) + allocate(requests(nprocs * 2 * repair_field%dim)) + requests = MPI_REQUEST_NULL + rank = getrank(communicator) + tag = next_mpi_tag() + + do i = 1, nprocs + do j = 1, repair_field%dim + ! Non-blocking sends + if(halo_send_count(halo, i) > 0) then + call mpi_isend(repair_field%val(j,:), 1, send_types(i), i - 1, & + tag, communicator, requests((i - 1) * repair_field%dim + j), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(halo_receive_count(halo, i) > 0) then + call mpi_irecv(correct_receive_data(start_indices(i):, j), & + halo_receive_count(halo, i), getpreal(), i - 1, tag, & + communicator, requests((i - 1 + nprocs) * repair_field%dim + j), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + end do + deallocate(start_indices) + + ! Wait for all non-blocking communications to complete + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + deallocate(statuses) + deallocate(requests) + + ! Free the indexed MPI types + do i = 1, nprocs + if(send_types(i) /= MPI_DATATYPE_NULL) then + call mpi_type_free(send_types(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + deallocate(send_types) + + ! If all is as expected, current_receive_data and correct_receive_data now + ! contain the same data in different orders. #ifdef DDEBUG - if(all(abs(current_receive_data - correct_receive_data) < epsilon(0.0))) then - ewrite(0, *) "Warning: reorder_halo_receives called for halo with correctly orderered receives" - end if + if(all(abs(current_receive_data - correct_receive_data) < epsilon(0.0))) then + ewrite(0, *) "Warning: reorder_halo_receives called for halo with correctly orderered receives" + end if #endif - ! Step 4: Sort them - this is the fiddly bit + ! Step 4: Sort them - this is the fiddly bit - ! Sort 1: Sort the current receive data - allocate(permutation(receives_count)) - call sort(current_receive_data, permutation) - ! Apply the sort to the current receives - call apply_permutation(receives, permutation) + ! Sort 1: Sort the current receive data + allocate(permutation(receives_count)) + call sort(current_receive_data, permutation) + ! Apply the sort to the current receives + call apply_permutation(receives, permutation) #ifdef DDEBUG - ! Sort the current receive data as well to enabled checking below - call apply_permutation(current_receive_data, permutation) + ! Sort the current receive data as well to enabled checking below + call apply_permutation(current_receive_data, permutation) #endif - ! Sort 2: Sort the correct receive data using the same sorting algorithm - call sort(correct_receive_data, permutation) - ! Invert it - allocate(permutation_inverse(receives_count)) - permutation_inverse = inverse_permutation(permutation) - ! Apply the inverse sort to the sorted current receives - call apply_permutation(receives, permutation_inverse) + ! Sort 2: Sort the correct receive data using the same sorting algorithm + call sort(correct_receive_data, permutation) + ! Invert it + allocate(permutation_inverse(receives_count)) + permutation_inverse = inverse_permutation(permutation) + ! Apply the inverse sort to the sorted current receives + call apply_permutation(receives, permutation_inverse) #ifdef DDEBUG - ! Again, sort the current receive data - call apply_permutation(current_receive_data, permutation_inverse) - ! We can now check that current_receive_data and correct_receive data - ! actually contained the same data in different orders - assert(all(abs(current_receive_data - correct_receive_data) < epsilon(0.0))) + ! Again, sort the current receive data + call apply_permutation(current_receive_data, permutation_inverse) + ! We can now check that current_receive_data and correct_receive data + ! actually contained the same data in different orders + assert(all(abs(current_receive_data - correct_receive_data) < epsilon(0.0))) #endif - deallocate(permutation) - deallocate(permutation_inverse) + deallocate(permutation) + deallocate(permutation_inverse) - deallocate(current_receive_data) - deallocate(correct_receive_data) + deallocate(current_receive_data) + deallocate(correct_receive_data) - ! Step 5: We now have our copy of receives in the correct order. Set the - ! halo receives from this. - call set_all_halo_receives(halo, receives) + ! Step 5: We now have our copy of receives in the correct order. Set the + ! halo receives from this. + call set_all_halo_receives(halo, receives) - deallocate(receives) + deallocate(receives) #else - if(.not. valid_serial_halo(halo)) then - FLAbort("Cannot reorder halo receives without MPI support") - end if + if(.not. valid_serial_halo(halo)) then + FLAbort("Cannot reorder halo receives without MPI support") + end if #endif - end subroutine reorder_halo_receives_order_trailing_receives + end subroutine reorder_halo_receives_order_trailing_receives end module halos_repair diff --git a/femtools/Integer_hash_table.F90 b/femtools/Integer_hash_table.F90 index 966364c68a..8a29c15946 100644 --- a/femtools/Integer_hash_table.F90 +++ b/femtools/Integer_hash_table.F90 @@ -1,210 +1,210 @@ #include "fdebug.h" module integer_hash_table_module - ! Don't use this directly, use data_structures - use iso_c_binding, only: c_ptr - use fldebug - type integer_hash_table - type(c_ptr) :: address - end type integer_hash_table - - interface - subroutine integer_hash_table_create_c(i) bind(c) - use iso_c_binding, only: c_ptr - type(c_ptr), intent(out) :: i - end subroutine integer_hash_table_create_c - - subroutine integer_hash_table_delete_c(i) bind(c) - use iso_c_binding, only: c_ptr - type(c_ptr), intent(inout) :: i - end subroutine integer_hash_table_delete_c - - subroutine integer_hash_table_insert_c(i, k, v) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(inout) :: i - integer(c_int), intent(in) :: k, v - end subroutine integer_hash_table_insert_c - - pure subroutine integer_hash_table_length_c(i, l) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(out) :: l - end subroutine integer_hash_table_length_c - - subroutine integer_hash_table_fetch_c(i, key, val) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(in) :: key - integer(c_int), intent(out) :: val - end subroutine integer_hash_table_fetch_c - - subroutine integer_hash_table_remove_c(i, key, stat) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(inout) :: i - integer(c_int), intent(in) :: key - integer(c_int), intent(out) :: stat - end subroutine integer_hash_table_remove_c - - subroutine integer_hash_table_has_key_c(i, val, bool) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(in) :: val - integer(c_int), intent(out) :: bool - end subroutine integer_hash_table_has_key_c - - subroutine integer_hash_table_fetch_pair_c(i, idx, key, val) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(in) :: idx - integer(c_int), intent(out) :: key, val - end subroutine integer_hash_table_fetch_pair_c - end interface - - interface allocate - module procedure integer_hash_table_allocate - end interface - - interface insert - module procedure integer_hash_table_insert - end interface - - interface remove - module procedure integer_hash_table_remove - end interface - - interface deallocate - module procedure integer_hash_table_delete - end interface - - interface has_key - module procedure integer_hash_table_has_key - end interface - - interface key_count - module procedure integer_hash_table_length - end interface - - interface fetch - module procedure integer_hash_table_fetch, integer_hash_table_fetch_v - end interface - - interface fetch_pair - module procedure integer_hash_table_fetch_pair - end interface - - interface print - module procedure print_hash_table - end interface - - interface copy - module procedure integer_hash_table_copy - end interface - - private - public :: integer_hash_table, allocate, deallocate, has_key, key_count, fetch, insert, & - fetch_pair, print, remove, copy - - contains - - subroutine integer_hash_table_copy(ihash_copy, ihash) - type(integer_hash_table), intent(out) :: ihash_copy - type(integer_hash_table), intent(in) :: ihash - - integer :: ind, key, key_val - - call allocate(ihash_copy) - do ind = 1, key_count(ihash) - call fetch_pair(ihash, ind, key, key_val) - call insert(ihash_copy, key, key_val) - end do - - end subroutine integer_hash_table_copy - - subroutine integer_hash_table_allocate(ihash) - type(integer_hash_table), intent(out) :: ihash - ihash = integer_hash_table_create() - end subroutine integer_hash_table_allocate - - function integer_hash_table_create() result(ihash) - type(integer_hash_table) :: ihash - call integer_hash_table_create_c(ihash%address) - end function integer_hash_table_create - - subroutine integer_hash_table_delete(ihash) - type(integer_hash_table), intent(inout) :: ihash - call integer_hash_table_delete_c(ihash%address) - end subroutine integer_hash_table_delete - - subroutine integer_hash_table_insert(ihash, key, val) - type(integer_hash_table), intent(inout) :: ihash - integer, intent(in) :: key, val - - call integer_hash_table_insert_c(ihash%address, key, val) - end subroutine integer_hash_table_insert - - pure function integer_hash_table_length(ihash) result(len) - type(integer_hash_table), intent(in) :: ihash - integer :: len - - call integer_hash_table_length_c(ihash%address, len) - end function integer_hash_table_length - - function integer_hash_table_fetch(ihash, key) result(val) - type(integer_hash_table), intent(in) :: ihash - integer, intent(in) :: key - integer :: val - - call integer_hash_table_fetch_c(ihash%address, key, val) - end function integer_hash_table_fetch - - subroutine integer_hash_table_remove(ihash, key) - type(integer_hash_table), intent(inout) :: ihash - integer, intent(in) :: key - integer :: stat - - call integer_hash_table_remove_c(ihash%address, key, stat) - assert(stat == 1) - end subroutine integer_hash_table_remove - - function integer_hash_table_fetch_v(ihash, keys) result(vals) - type(integer_hash_table), intent(in) :: ihash - integer, intent(in), dimension(:) :: keys - integer, dimension(size(keys)) :: vals - integer :: i - - do i=1,size(keys) - call integer_hash_table_fetch_c(ihash%address, keys(i), vals(i)) - end do - end function integer_hash_table_fetch_v - - function integer_hash_table_has_key(ihash, key) result(bool) - type(integer_hash_table), intent(in) :: ihash - integer, intent(in) :: key - logical :: bool - - integer :: lbool - call integer_hash_table_has_key_c(ihash%address, key, lbool) - bool = (lbool == 1) - end function integer_hash_table_has_key - - subroutine integer_hash_table_fetch_pair(ihash, idx, key, val) - type(integer_hash_table), intent(in) :: ihash - integer, intent(in) :: idx - integer, intent(out) :: key, val - - call integer_hash_table_fetch_pair_c(ihash%address, idx, key, val) - end subroutine integer_hash_table_fetch_pair - - subroutine print_hash_table(ihash, priority) - type(integer_hash_table), intent(in) :: ihash - integer, intent(in) :: priority - - integer :: i, key, val - - ewrite(priority,*) "Writing hash table: " - do i=1,key_count(ihash) - call fetch_pair(ihash, i, key, val) - ewrite(priority,*) key, " --> ", val - end do - end subroutine print_hash_table + ! Don't use this directly, use data_structures + use iso_c_binding, only: c_ptr + use fldebug + type integer_hash_table + type(c_ptr) :: address + end type integer_hash_table + + interface + subroutine integer_hash_table_create_c(i) bind(c) + use iso_c_binding, only: c_ptr + type(c_ptr), intent(out) :: i + end subroutine integer_hash_table_create_c + + subroutine integer_hash_table_delete_c(i) bind(c) + use iso_c_binding, only: c_ptr + type(c_ptr), intent(inout) :: i + end subroutine integer_hash_table_delete_c + + subroutine integer_hash_table_insert_c(i, k, v) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(inout) :: i + integer(c_int), intent(in) :: k, v + end subroutine integer_hash_table_insert_c + + pure subroutine integer_hash_table_length_c(i, l) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(out) :: l + end subroutine integer_hash_table_length_c + + subroutine integer_hash_table_fetch_c(i, key, val) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(in) :: key + integer(c_int), intent(out) :: val + end subroutine integer_hash_table_fetch_c + + subroutine integer_hash_table_remove_c(i, key, stat) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(inout) :: i + integer(c_int), intent(in) :: key + integer(c_int), intent(out) :: stat + end subroutine integer_hash_table_remove_c + + subroutine integer_hash_table_has_key_c(i, val, bool) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(in) :: val + integer(c_int), intent(out) :: bool + end subroutine integer_hash_table_has_key_c + + subroutine integer_hash_table_fetch_pair_c(i, idx, key, val) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(in) :: idx + integer(c_int), intent(out) :: key, val + end subroutine integer_hash_table_fetch_pair_c + end interface + + interface allocate + module procedure integer_hash_table_allocate + end interface + + interface insert + module procedure integer_hash_table_insert + end interface + + interface remove + module procedure integer_hash_table_remove + end interface + + interface deallocate + module procedure integer_hash_table_delete + end interface + + interface has_key + module procedure integer_hash_table_has_key + end interface + + interface key_count + module procedure integer_hash_table_length + end interface + + interface fetch + module procedure integer_hash_table_fetch, integer_hash_table_fetch_v + end interface + + interface fetch_pair + module procedure integer_hash_table_fetch_pair + end interface + + interface print + module procedure print_hash_table + end interface + + interface copy + module procedure integer_hash_table_copy + end interface + + private + public :: integer_hash_table, allocate, deallocate, has_key, key_count, fetch, insert, & + fetch_pair, print, remove, copy + +contains + + subroutine integer_hash_table_copy(ihash_copy, ihash) + type(integer_hash_table), intent(out) :: ihash_copy + type(integer_hash_table), intent(in) :: ihash + + integer :: ind, key, key_val + + call allocate(ihash_copy) + do ind = 1, key_count(ihash) + call fetch_pair(ihash, ind, key, key_val) + call insert(ihash_copy, key, key_val) + end do + + end subroutine integer_hash_table_copy + + subroutine integer_hash_table_allocate(ihash) + type(integer_hash_table), intent(out) :: ihash + ihash = integer_hash_table_create() + end subroutine integer_hash_table_allocate + + function integer_hash_table_create() result(ihash) + type(integer_hash_table) :: ihash + call integer_hash_table_create_c(ihash%address) + end function integer_hash_table_create + + subroutine integer_hash_table_delete(ihash) + type(integer_hash_table), intent(inout) :: ihash + call integer_hash_table_delete_c(ihash%address) + end subroutine integer_hash_table_delete + + subroutine integer_hash_table_insert(ihash, key, val) + type(integer_hash_table), intent(inout) :: ihash + integer, intent(in) :: key, val + + call integer_hash_table_insert_c(ihash%address, key, val) + end subroutine integer_hash_table_insert + + pure function integer_hash_table_length(ihash) result(len) + type(integer_hash_table), intent(in) :: ihash + integer :: len + + call integer_hash_table_length_c(ihash%address, len) + end function integer_hash_table_length + + function integer_hash_table_fetch(ihash, key) result(val) + type(integer_hash_table), intent(in) :: ihash + integer, intent(in) :: key + integer :: val + + call integer_hash_table_fetch_c(ihash%address, key, val) + end function integer_hash_table_fetch + + subroutine integer_hash_table_remove(ihash, key) + type(integer_hash_table), intent(inout) :: ihash + integer, intent(in) :: key + integer :: stat + + call integer_hash_table_remove_c(ihash%address, key, stat) + assert(stat == 1) + end subroutine integer_hash_table_remove + + function integer_hash_table_fetch_v(ihash, keys) result(vals) + type(integer_hash_table), intent(in) :: ihash + integer, intent(in), dimension(:) :: keys + integer, dimension(size(keys)) :: vals + integer :: i + + do i=1,size(keys) + call integer_hash_table_fetch_c(ihash%address, keys(i), vals(i)) + end do + end function integer_hash_table_fetch_v + + function integer_hash_table_has_key(ihash, key) result(bool) + type(integer_hash_table), intent(in) :: ihash + integer, intent(in) :: key + logical :: bool + + integer :: lbool + call integer_hash_table_has_key_c(ihash%address, key, lbool) + bool = (lbool == 1) + end function integer_hash_table_has_key + + subroutine integer_hash_table_fetch_pair(ihash, idx, key, val) + type(integer_hash_table), intent(in) :: ihash + integer, intent(in) :: idx + integer, intent(out) :: key, val + + call integer_hash_table_fetch_pair_c(ihash%address, idx, key, val) + end subroutine integer_hash_table_fetch_pair + + subroutine print_hash_table(ihash, priority) + type(integer_hash_table), intent(in) :: ihash + integer, intent(in) :: priority + + integer :: i, key, val + + ewrite(priority,*) "Writing hash table: " + do i=1,key_count(ihash) + call fetch_pair(ihash, i, key, val) + ewrite(priority,*) key, " --> ", val + end do + end subroutine print_hash_table end module integer_hash_table_module diff --git a/femtools/Integer_set.F90 b/femtools/Integer_set.F90 index 3fde864777..5b7533cf14 100644 --- a/femtools/Integer_set.F90 +++ b/femtools/Integer_set.F90 @@ -1,334 +1,334 @@ #include "fdebug.h" module integer_set_module - ! Don't use this directly, use data_structures - use iso_c_binding, only: c_ptr, c_int - use fldebug - type integer_set - type(c_ptr) :: address - end type integer_set - - type integer_set_vector - type(integer_set), dimension(:), pointer :: sets - end type integer_set_vector - - interface - subroutine integer_set_create_c(i) bind(c) - use iso_c_binding, only: c_ptr - type(c_ptr), intent(out) :: i - end subroutine integer_set_create_c - - subroutine integer_set_delete_c(i) bind(c) - use iso_c_binding, only: c_ptr - type(c_ptr), intent(inout) :: i - end subroutine integer_set_delete_c - - subroutine integer_set_insert_c(i, v, c) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(inout) :: i - integer(c_int), intent(in) :: v - integer(c_int), intent(out) :: c - end subroutine integer_set_insert_c - - pure subroutine integer_set_length_c(i, l) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(out) :: l - end subroutine integer_set_length_c - - subroutine integer_set_fetch_c(i, idx, val) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(in) :: idx - integer(c_int), intent(out) :: val - end subroutine integer_set_fetch_c - - subroutine integer_set_remove_c(i, idx, stat) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(in) :: idx - integer(c_int), intent(out) :: stat - end subroutine integer_set_remove_c - - subroutine integer_set_has_value_c(i, val, bool) bind(c) - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), intent(in) :: i - integer(c_int), intent(in) :: val - integer(c_int), intent(out) :: bool - end subroutine integer_set_has_value_c - end interface - - interface allocate - module procedure integer_set_allocate_single, integer_set_allocate_vector - end interface - - interface insert - module procedure integer_set_insert, integer_set_insert_multiple, & - integer_set_insert_set - end interface - - interface deallocate - module procedure integer_set_delete_single, integer_set_delete_vector - end interface - - interface has_value - module procedure integer_set_has_value, integer_set_has_value_multiple - end interface - - interface key_count - module procedure integer_set_length_single, integer_set_length_vector - end interface - - interface fetch - module procedure integer_set_fetch - end interface - - interface remove - module procedure integer_set_remove - end interface - - interface copy - module procedure integer_set_copy, integer_set_copy_multiple - end interface - - interface set_intersection - module procedure set_intersection_two, set_intersection_multiple - end interface - - private - public :: integer_set, allocate, deallocate, has_value, key_count, fetch, insert, & - & set_complement, set2vector, set_intersection, set_minus, remove, copy, & - & integer_set_vector - - contains - - subroutine integer_set_allocate_single(iset) - type(integer_set), intent(out) :: iset - iset = integer_set_create() - end subroutine integer_set_allocate_single - - subroutine integer_set_allocate_vector(iset) - type(integer_set), dimension(:), intent(out) :: iset - - integer :: i - - do i = 1, size(iset) - call allocate(iset(i)) - end do - - end subroutine integer_set_allocate_vector - - function integer_set_create() result(iset) - type(integer_set) :: iset - call integer_set_create_c(iset%address) - end function integer_set_create - - subroutine integer_set_delete_single(iset) - type(integer_set), intent(inout) :: iset - call integer_set_delete_c(iset%address) - end subroutine integer_set_delete_single - - subroutine integer_set_delete_vector(iset) - type(integer_set), dimension(:), intent(inout) :: iset - - integer :: i - - do i = 1, size(iset) - call deallocate(iset(i)) - end do - - end subroutine integer_set_delete_vector - - subroutine integer_set_insert(iset, val, changed) - type(integer_set), intent(inout) :: iset - integer, intent(in) :: val - logical, intent(out), optional :: changed - integer :: lchanged - - call integer_set_insert_c(iset%address, val, lchanged) - - if (present(changed)) then - changed = (lchanged == 1) - end if - end subroutine integer_set_insert + ! Don't use this directly, use data_structures + use iso_c_binding, only: c_ptr, c_int + use fldebug + type integer_set + type(c_ptr) :: address + end type integer_set + + type integer_set_vector + type(integer_set), dimension(:), pointer :: sets + end type integer_set_vector + + interface + subroutine integer_set_create_c(i) bind(c) + use iso_c_binding, only: c_ptr + type(c_ptr), intent(out) :: i + end subroutine integer_set_create_c + + subroutine integer_set_delete_c(i) bind(c) + use iso_c_binding, only: c_ptr + type(c_ptr), intent(inout) :: i + end subroutine integer_set_delete_c + + subroutine integer_set_insert_c(i, v, c) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(inout) :: i + integer(c_int), intent(in) :: v + integer(c_int), intent(out) :: c + end subroutine integer_set_insert_c + + pure subroutine integer_set_length_c(i, l) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(out) :: l + end subroutine integer_set_length_c + + subroutine integer_set_fetch_c(i, idx, val) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(in) :: idx + integer(c_int), intent(out) :: val + end subroutine integer_set_fetch_c + + subroutine integer_set_remove_c(i, idx, stat) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(in) :: idx + integer(c_int), intent(out) :: stat + end subroutine integer_set_remove_c + + subroutine integer_set_has_value_c(i, val, bool) bind(c) + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), intent(in) :: i + integer(c_int), intent(in) :: val + integer(c_int), intent(out) :: bool + end subroutine integer_set_has_value_c + end interface + + interface allocate + module procedure integer_set_allocate_single, integer_set_allocate_vector + end interface + + interface insert + module procedure integer_set_insert, integer_set_insert_multiple, & + integer_set_insert_set + end interface + + interface deallocate + module procedure integer_set_delete_single, integer_set_delete_vector + end interface + + interface has_value + module procedure integer_set_has_value, integer_set_has_value_multiple + end interface + + interface key_count + module procedure integer_set_length_single, integer_set_length_vector + end interface + + interface fetch + module procedure integer_set_fetch + end interface + + interface remove + module procedure integer_set_remove + end interface + + interface copy + module procedure integer_set_copy, integer_set_copy_multiple + end interface + + interface set_intersection + module procedure set_intersection_two, set_intersection_multiple + end interface + + private + public :: integer_set, allocate, deallocate, has_value, key_count, fetch, insert, & + & set_complement, set2vector, set_intersection, set_minus, remove, copy, & + & integer_set_vector + +contains + + subroutine integer_set_allocate_single(iset) + type(integer_set), intent(out) :: iset + iset = integer_set_create() + end subroutine integer_set_allocate_single + + subroutine integer_set_allocate_vector(iset) + type(integer_set), dimension(:), intent(out) :: iset + + integer :: i + + do i = 1, size(iset) + call allocate(iset(i)) + end do + + end subroutine integer_set_allocate_vector + + function integer_set_create() result(iset) + type(integer_set) :: iset + call integer_set_create_c(iset%address) + end function integer_set_create + + subroutine integer_set_delete_single(iset) + type(integer_set), intent(inout) :: iset + call integer_set_delete_c(iset%address) + end subroutine integer_set_delete_single + + subroutine integer_set_delete_vector(iset) + type(integer_set), dimension(:), intent(inout) :: iset + + integer :: i + + do i = 1, size(iset) + call deallocate(iset(i)) + end do + + end subroutine integer_set_delete_vector - subroutine integer_set_insert_multiple(iset, values) - type(integer_set), intent(inout) :: iset - integer, dimension(:), intent(in) :: values - integer :: i + subroutine integer_set_insert(iset, val, changed) + type(integer_set), intent(inout) :: iset + integer, intent(in) :: val + logical, intent(out), optional :: changed + integer :: lchanged - do i=1,size(values) - call insert(iset, values(i)) - end do - end subroutine integer_set_insert_multiple + call integer_set_insert_c(iset%address, val, lchanged) - subroutine integer_set_insert_set(iset, value_set) - type(integer_set), intent(inout) :: iset - type(integer_set), intent(in) :: value_set - integer :: i - - do i=1, key_count(value_set) - call insert(iset, fetch(value_set,i)) - end do - end subroutine integer_set_insert_set - - pure function integer_set_length_single(iset) result(len) - type(integer_set), intent(in) :: iset - integer :: len - - call integer_set_length_c(iset%address, len) - end function integer_set_length_single - - pure function integer_set_length_vector(iset) result(len) - type(integer_set), dimension(:), intent(in) :: iset - - integer, dimension(size(iset)) :: len - - integer :: i - - do i = 1, size(iset) - len(i) = key_count(iset(i)) - end do - - end function integer_set_length_vector - - function integer_set_fetch(iset, idx) result(val) - type(integer_set), intent(in) :: iset - integer, intent(in) :: idx - integer :: val - - call integer_set_fetch_c(iset%address, idx, val) - end function integer_set_fetch - - subroutine integer_set_remove(iset, idx) - type(integer_set), intent(in) :: iset - integer, intent(in) :: idx - integer :: stat - - call integer_set_remove_c(iset%address, idx, stat) - assert(stat == 1) - end subroutine integer_set_remove - - function integer_set_has_value(iset, val) result(bool) - type(integer_set), intent(in) :: iset - integer, intent(in) :: val - logical :: bool - - integer :: lbool - call integer_set_has_value_c(iset%address, val, lbool) - bool = (lbool == 1) - end function integer_set_has_value - - function integer_set_has_value_multiple(iset, val) result(bool) - type(integer_set), intent(in) :: iset - integer, dimension(:), intent(in) :: val - logical, dimension(size(val)) :: bool - - integer:: i - - do i=1, size(val) - bool(i)=integer_set_has_value(iset, val(i)) - end do - end function integer_set_has_value_multiple - - subroutine set_complement(complement, universe, current) - ! complement = universe \ current - type(integer_set), intent(out) :: complement - type(integer_set), intent(in) :: universe, current - integer :: i, val - - call allocate(complement) - do i=1,key_count(universe) - val = fetch(universe, i) - if (.not. has_value(current, val)) then - call insert(complement, val) - end if - end do - end subroutine set_complement - - subroutine set_intersection_two(intersection, A, B) - ! intersection = A n B - type(integer_set), intent(out) :: intersection - type(integer_set), intent(in) :: A, B - integer :: i, val - - call allocate(intersection) - do i=1,key_count(A) - val = fetch(A, i) - if (has_value(B, val)) then - call insert(intersection, val) - end if - end do - end subroutine set_intersection_two - - subroutine set_intersection_multiple(intersection, isets) - ! intersection = isets(i) n isets(j), forall i /= j - type(integer_set), intent(out) :: intersection - type(integer_set), dimension(:), intent(in) :: isets - integer :: i - - type(integer_set) :: tmp_intersection, tmp_iset - - tmp_iset = isets(1) - do i = 2, size(isets) - call set_intersection(tmp_intersection, tmp_iset, isets(i)) - call copy(tmp_iset, tmp_intersection) - call deallocate(tmp_intersection) - end do - intersection = tmp_iset - - end subroutine set_intersection_multiple - - subroutine integer_set_copy(iset_copy, iset) - type(integer_set), intent(out) :: iset_copy - type(integer_set), intent(in) :: iset - - integer :: i, val - - call allocate(iset_copy) - - do i = 1, key_count(iset) - val = fetch(iset, i) - call insert(iset_copy, val) - end do - - end subroutine integer_set_copy - - subroutine integer_set_copy_multiple(iset_copy, iset) - type(integer_set), dimension(:), intent(out) :: iset_copy - type(integer_set), dimension(:), intent(in) :: iset - - integer :: n - - do n=1, size(iset) - call copy(iset_copy(n), iset(n)) - end do - - end subroutine integer_set_copy_multiple - - subroutine set_minus(minus, A, B) - ! minus = A \ B - type(integer_set), intent(out) :: minus - type(integer_set), intent(in) :: A, B - integer :: i, val - - call allocate(minus) - do i=1,key_count(A) - val = fetch(A, i) - if (.not. has_value(B, val)) then - call insert(minus, val) + if (present(changed)) then + changed = (lchanged == 1) end if - end do - end subroutine set_minus - - function set2vector(iset) result(vec) - type(integer_set), intent(in) :: iset - integer, dimension(key_count(iset)) :: vec - integer :: i - - do i=1,key_count(iset) - vec(i) = fetch(iset, i) - end do - end function set2vector + end subroutine integer_set_insert + + subroutine integer_set_insert_multiple(iset, values) + type(integer_set), intent(inout) :: iset + integer, dimension(:), intent(in) :: values + integer :: i + + do i=1,size(values) + call insert(iset, values(i)) + end do + end subroutine integer_set_insert_multiple + + subroutine integer_set_insert_set(iset, value_set) + type(integer_set), intent(inout) :: iset + type(integer_set), intent(in) :: value_set + integer :: i + + do i=1, key_count(value_set) + call insert(iset, fetch(value_set,i)) + end do + end subroutine integer_set_insert_set + + pure function integer_set_length_single(iset) result(len) + type(integer_set), intent(in) :: iset + integer :: len + + call integer_set_length_c(iset%address, len) + end function integer_set_length_single + + pure function integer_set_length_vector(iset) result(len) + type(integer_set), dimension(:), intent(in) :: iset + + integer, dimension(size(iset)) :: len + + integer :: i + + do i = 1, size(iset) + len(i) = key_count(iset(i)) + end do + + end function integer_set_length_vector + + function integer_set_fetch(iset, idx) result(val) + type(integer_set), intent(in) :: iset + integer, intent(in) :: idx + integer :: val + + call integer_set_fetch_c(iset%address, idx, val) + end function integer_set_fetch + + subroutine integer_set_remove(iset, idx) + type(integer_set), intent(in) :: iset + integer, intent(in) :: idx + integer :: stat + + call integer_set_remove_c(iset%address, idx, stat) + assert(stat == 1) + end subroutine integer_set_remove + + function integer_set_has_value(iset, val) result(bool) + type(integer_set), intent(in) :: iset + integer, intent(in) :: val + logical :: bool + + integer :: lbool + call integer_set_has_value_c(iset%address, val, lbool) + bool = (lbool == 1) + end function integer_set_has_value + + function integer_set_has_value_multiple(iset, val) result(bool) + type(integer_set), intent(in) :: iset + integer, dimension(:), intent(in) :: val + logical, dimension(size(val)) :: bool + + integer:: i + + do i=1, size(val) + bool(i)=integer_set_has_value(iset, val(i)) + end do + end function integer_set_has_value_multiple + + subroutine set_complement(complement, universe, current) + ! complement = universe \ current + type(integer_set), intent(out) :: complement + type(integer_set), intent(in) :: universe, current + integer :: i, val + + call allocate(complement) + do i=1,key_count(universe) + val = fetch(universe, i) + if (.not. has_value(current, val)) then + call insert(complement, val) + end if + end do + end subroutine set_complement + + subroutine set_intersection_two(intersection, A, B) + ! intersection = A n B + type(integer_set), intent(out) :: intersection + type(integer_set), intent(in) :: A, B + integer :: i, val + + call allocate(intersection) + do i=1,key_count(A) + val = fetch(A, i) + if (has_value(B, val)) then + call insert(intersection, val) + end if + end do + end subroutine set_intersection_two + + subroutine set_intersection_multiple(intersection, isets) + ! intersection = isets(i) n isets(j), forall i /= j + type(integer_set), intent(out) :: intersection + type(integer_set), dimension(:), intent(in) :: isets + integer :: i + + type(integer_set) :: tmp_intersection, tmp_iset + + tmp_iset = isets(1) + do i = 2, size(isets) + call set_intersection(tmp_intersection, tmp_iset, isets(i)) + call copy(tmp_iset, tmp_intersection) + call deallocate(tmp_intersection) + end do + intersection = tmp_iset + + end subroutine set_intersection_multiple + + subroutine integer_set_copy(iset_copy, iset) + type(integer_set), intent(out) :: iset_copy + type(integer_set), intent(in) :: iset + + integer :: i, val + + call allocate(iset_copy) + + do i = 1, key_count(iset) + val = fetch(iset, i) + call insert(iset_copy, val) + end do + + end subroutine integer_set_copy + + subroutine integer_set_copy_multiple(iset_copy, iset) + type(integer_set), dimension(:), intent(out) :: iset_copy + type(integer_set), dimension(:), intent(in) :: iset + + integer :: n + + do n=1, size(iset) + call copy(iset_copy(n), iset(n)) + end do + + end subroutine integer_set_copy_multiple + + subroutine set_minus(minus, A, B) + ! minus = A \ B + type(integer_set), intent(out) :: minus + type(integer_set), intent(in) :: A, B + integer :: i, val + + call allocate(minus) + do i=1,key_count(A) + val = fetch(A, i) + if (.not. has_value(B, val)) then + call insert(minus, val) + end if + end do + end subroutine set_minus + + function set2vector(iset) result(vec) + type(integer_set), intent(in) :: iset + integer, dimension(key_count(iset)) :: vec + integer :: i + + do i=1,key_count(iset) + vec(i) = fetch(iset, i) + end do + end function set2vector end module integer_set_module diff --git a/femtools/Interpolation.F90 b/femtools/Interpolation.F90 index e3d1de71ee..3a2141a117 100644 --- a/femtools/Interpolation.F90 +++ b/femtools/Interpolation.F90 @@ -1,713 +1,713 @@ #include "fdebug.h" module interpolation_module - use fldebug - use futils - use superconvergence - use sparse_tools - use transform_elements - use supermesh_construction - use parallel_fields - use fields - use state_module - use field_derivatives - use meshdiagnostics - use field_options - use node_ownership - implicit none - - interface linear_interpolation - module procedure linear_interpolation_state, linear_interpolation_scalar, & + use fldebug + use futils + use superconvergence + use sparse_tools + use transform_elements + use supermesh_construction + use parallel_fields + use fields + use state_module + use field_derivatives + use meshdiagnostics + use field_options + use node_ownership + implicit none + + interface linear_interpolation + module procedure linear_interpolation_state, linear_interpolation_scalar, & & linear_interpolation_scalars, linear_interpolation_vector, linear_interpolation_vectors, & & linear_interpolation_tensors, linear_interpolation_tensor - end interface + end interface - interface quadratic_interpolation - module procedure quadratic_interpolation_eqf - end interface + interface quadratic_interpolation + module procedure quadratic_interpolation_eqf + end interface - interface cubic_interpolation - module procedure cubic_interpolation_cf_scalar, cubic_interpolation_cf_vector - end interface + interface cubic_interpolation + module procedure cubic_interpolation_cf_scalar, cubic_interpolation_cf_vector + end interface - private + private - public :: linear_interpolation, quadratic_interpolation, cubic_interpolation,& + public :: linear_interpolation, quadratic_interpolation, cubic_interpolation,& get_element_mapping, linear_interpolate_states - contains - - function get_element_mapping(old_position, new_position, different_domains, only_owned) result(map) - !!< Return the elements in the mesh of old_position - !!< that contains the nodes of the mesh of new_position - type(vector_field), intent(inout) :: old_position - type(vector_field), intent(in) :: new_position - logical, optional, intent(in) :: different_domains - logical, optional, intent(in) :: only_owned - - integer, dimension(node_count(new_position)) :: map - integer :: i - - ! Thanks, James! - call find_node_ownership(old_position, new_position, map) - - if(.not. present_and_true(different_domains)) then - if (present_and_true(only_owned)) then - do i = 1,size(map) - if (map(i) < 0 .and. node_owned(new_position,i)) then - FLAbort("Failed to find map for at least one owned node") - end if - end do - else - if (.not. all(map > 0)) then - FLAbort("Failed to find element mapping") - end if +contains + + function get_element_mapping(old_position, new_position, different_domains, only_owned) result(map) + !!< Return the elements in the mesh of old_position + !!< that contains the nodes of the mesh of new_position + type(vector_field), intent(inout) :: old_position + type(vector_field), intent(in) :: new_position + logical, optional, intent(in) :: different_domains + logical, optional, intent(in) :: only_owned + + integer, dimension(node_count(new_position)) :: map + integer :: i + + ! Thanks, James! + call find_node_ownership(old_position, new_position, map) + + if(.not. present_and_true(different_domains)) then + if (present_and_true(only_owned)) then + do i = 1,size(map) + if (map(i) < 0 .and. node_owned(new_position,i)) then + FLAbort("Failed to find map for at least one owned node") + end if + end do + else + if (.not. all(map > 0)) then + FLAbort("Failed to find element mapping") + end if + end if end if - end if - - end function get_element_mapping - subroutine quadratic_interpolation_qf(old_fields, old_position, new_fields, new_position, only_owned) - !!< Interpolate the fields defined on the old_fields mesh - !!< onto the new_fields mesh. - !!< This routine assumes new_fields have all been allocated. + end function get_element_mapping - type(scalar_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(inout) :: old_position - type(scalar_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned + subroutine quadratic_interpolation_qf(old_fields, old_position, new_fields, new_position, only_owned) + !!< Interpolate the fields defined on the old_fields mesh + !!< onto the new_fields mesh. + !!< This routine assumes new_fields have all been allocated. - type(mesh_type) :: old_mesh, new_mesh - integer :: old_node - integer :: new_node - integer :: ele - integer :: field_count - integer :: field - integer, dimension(:), pointer :: node_list - integer :: i - integer, dimension(node_count(new_position)) :: map - real, dimension(MATRIX_SIZE_QF) :: qf_expansion - real :: val - logical :: only_owned_b + type(scalar_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(inout) :: old_position + type(scalar_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned - only_owned_b = present_and_true(only_owned) + type(mesh_type) :: old_mesh, new_mesh + integer :: old_node + integer :: new_node + integer :: ele + integer :: field_count + integer :: field + integer, dimension(:), pointer :: node_list + integer :: i + integer, dimension(node_count(new_position)) :: map + real, dimension(MATRIX_SIZE_QF) :: qf_expansion + real :: val + logical :: only_owned_b - assert(size(old_fields) == size(new_fields)) - field_count = size(old_fields) + only_owned_b = present_and_true(only_owned) - old_mesh = old_fields(1)%mesh - new_mesh = new_fields(1)%mesh + assert(size(old_fields) == size(new_fields)) + field_count = size(old_fields) + old_mesh = old_fields(1)%mesh + new_mesh = new_fields(1)%mesh - call add_nelist(old_mesh) - map = get_element_mapping(old_position, new_position, only_owned=only_owned_b) - ! Zero the new fields. + call add_nelist(old_mesh) + map = get_element_mapping(old_position, new_position, only_owned=only_owned_b) - do field=1,field_count - call zero(new_fields(field)) - end do + ! Zero the new fields. - ! Loop over the nodes of the new mesh. + do field=1,field_count + call zero(new_fields(field)) + end do - do new_node=1,node_count(new_mesh) - ! cycle unowned elements - if (only_owned_b) then - if (.not. node_owned(new_mesh, new_node)) then - cycle - end if - end if + ! Loop over the nodes of the new mesh. - ! In what element of the old mesh does the new node lie? - ele = map(new_node) - node_list => ele_nodes(old_mesh, ele) + do new_node=1,node_count(new_mesh) + ! cycle unowned elements + if (only_owned_b) then + if (.not. node_owned(new_mesh, new_node)) then + cycle + end if + end if - do field=1,field_count - ! Loop over the nodes of that element, - ! get the quadratic expansion of that field, - ! evaluate at the point and average. - val = 0.0 - do i=1,size(node_list) - old_node = node_list(i) - qf_expansion = get_quadratic_fit_qf(old_fields(field), old_position, old_node) - val = val + evaluate_qf(qf_expansion, node_val(new_position, new_node)) - end do - val = val / size(node_list) - call set(new_fields(field), new_node, val) + ! In what element of the old mesh does the new node lie? + ele = map(new_node) + node_list => ele_nodes(old_mesh, ele) + + do field=1,field_count + ! Loop over the nodes of that element, + ! get the quadratic expansion of that field, + ! evaluate at the point and average. + val = 0.0 + do i=1,size(node_list) + old_node = node_list(i) + qf_expansion = get_quadratic_fit_qf(old_fields(field), old_position, old_node) + val = val + evaluate_qf(qf_expansion, node_val(new_position, new_node)) + end do + val = val / size(node_list) + call set(new_fields(field), new_node, val) + end do end do - end do - end subroutine quadratic_interpolation_qf + end subroutine quadratic_interpolation_qf - subroutine quadratic_interpolation_eqf(old_fields, old_position, new_fields, new_position, only_owned) - !!< Interpolate the fields defined on the old_fields mesh - !!< onto the new_fields mesh. - !!< This routine assumes new_fields have all been allocated. + subroutine quadratic_interpolation_eqf(old_fields, old_position, new_fields, new_position, only_owned) + !!< Interpolate the fields defined on the old_fields mesh + !!< onto the new_fields mesh. + !!< This routine assumes new_fields have all been allocated. - type(scalar_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(inout) :: old_position - type(scalar_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned + type(scalar_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(inout) :: old_position + type(scalar_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned - type(mesh_type) :: old_mesh, new_mesh - integer :: new_node - integer :: ele - integer :: field_count - integer :: field - integer, dimension(node_count(new_position)) :: map - real, dimension(MATRIX_SIZE_QF) :: fit - real :: val - type(vector_field) :: gradient - logical :: only_owned_b + type(mesh_type) :: old_mesh, new_mesh + integer :: new_node + integer :: ele + integer :: field_count + integer :: field + integer, dimension(node_count(new_position)) :: map + real, dimension(MATRIX_SIZE_QF) :: fit + real :: val + type(vector_field) :: gradient + logical :: only_owned_b - only_owned_b = present_and_true(only_owned) + only_owned_b = present_and_true(only_owned) - assert(size(old_fields) == size(new_fields)) - field_count = size(old_fields) + assert(size(old_fields) == size(new_fields)) + field_count = size(old_fields) - old_mesh = old_fields(1)%mesh - new_mesh = new_fields(1)%mesh + old_mesh = old_fields(1)%mesh + new_mesh = new_fields(1)%mesh - call allocate(gradient, 3, old_mesh, "Gradient") + call allocate(gradient, 3, old_mesh, "Gradient") - call add_nelist(old_mesh) - map = get_element_mapping(old_position, new_position, only_owned=only_owned_b) + call add_nelist(old_mesh) + map = get_element_mapping(old_position, new_position, only_owned=only_owned_b) - ! Zero the new fields. + ! Zero the new fields. - do field=1,field_count - call zero(new_fields(field)) - end do + do field=1,field_count + call zero(new_fields(field)) + end do - ! Loop over the nodes of the new mesh. + ! Loop over the nodes of the new mesh. - do field=1,field_count - call grad(old_fields(field), old_position, gradient) + do field=1,field_count + call grad(old_fields(field), old_position, gradient) + + do new_node=1,node_count(new_mesh) + ! cycle unowned elements + if (only_owned_b) then + if (.not. node_owned(new_mesh, new_node)) then + cycle + end if + end if + + ! In what element of the old mesh does the new node lie? + ele = map(new_node) + fit = get_quadratic_fit_eqf(old_fields(field), old_position, ele, transpose(ele_val(gradient, ele))) + val = evaluate_qf(fit, node_val(new_position, new_node)) + + call set(new_fields(field), new_node, val) + end do + end do - do new_node=1,node_count(new_mesh) - ! cycle unowned elements - if (only_owned_b) then - if (.not. node_owned(new_mesh, new_node)) then - cycle - end if - end if + call deallocate(gradient) - ! In what element of the old mesh does the new node lie? - ele = map(new_node) - fit = get_quadratic_fit_eqf(old_fields(field), old_position, ele, transpose(ele_val(gradient, ele))) - val = evaluate_qf(fit, node_val(new_position, new_node)) + end subroutine quadratic_interpolation_eqf - call set(new_fields(field), new_node, val) - end do - end do + subroutine linear_interpolation_scalar(old_field, old_position, new_field, new_position, map, only_owned) + type(scalar_field), intent(in) :: old_field + type(vector_field), intent(in) :: old_position + type(scalar_field), intent(inout) :: new_field + type(vector_field), intent(in) :: new_position + integer, dimension(:), optional, intent(in) :: map + logical, intent(in), optional :: only_owned - call deallocate(gradient) + type(state_type) :: old_state, new_state - end subroutine quadratic_interpolation_eqf + call insert(old_state, old_field, old_field%name) + call insert(new_state, new_field, old_field%name) - subroutine linear_interpolation_scalar(old_field, old_position, new_field, new_position, map, only_owned) - type(scalar_field), intent(in) :: old_field - type(vector_field), intent(in) :: old_position - type(scalar_field), intent(inout) :: new_field - type(vector_field), intent(in) :: new_position - integer, dimension(:), optional, intent(in) :: map - logical, intent(in), optional :: only_owned + call insert(old_state, old_position, "Coordinate") + call insert(new_state, new_position, "Coordinate") - type(state_type) :: old_state, new_state + call insert(old_state, old_field%mesh, "Mesh") + call insert(new_state, new_field%mesh, "Mesh") - call insert(old_state, old_field, old_field%name) - call insert(new_state, new_field, old_field%name) + call linear_interpolation_state(old_state, new_state, map = map, only_owned = only_owned) + call deallocate(old_state) + call deallocate(new_state) - call insert(old_state, old_position, "Coordinate") - call insert(new_state, new_position, "Coordinate") + end subroutine linear_interpolation_scalar - call insert(old_state, old_field%mesh, "Mesh") - call insert(new_state, new_field%mesh, "Mesh") + subroutine linear_interpolation_scalars(old_fields, old_position, new_fields, new_position, map, only_owned) + type(scalar_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(in) :: old_position + type(scalar_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + integer, dimension(:), optional, intent(in) :: map + logical, intent(in), optional :: only_owned - call linear_interpolation_state(old_state, new_state, map = map, only_owned = only_owned) - call deallocate(old_state) - call deallocate(new_state) + type(state_type) :: old_state, new_state + integer :: field, field_count - end subroutine linear_interpolation_scalar + field_count = size(old_fields) - subroutine linear_interpolation_scalars(old_fields, old_position, new_fields, new_position, map, only_owned) - type(scalar_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(in) :: old_position - type(scalar_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - integer, dimension(:), optional, intent(in) :: map - logical, intent(in), optional :: only_owned + do field=1,field_count + call insert(old_state, old_fields(field), old_fields(field)%name) + call insert(new_state, new_fields(field), old_fields(field)%name) + end do - type(state_type) :: old_state, new_state - integer :: field, field_count + call insert(old_state, old_position, "Coordinate") + call insert(new_state, new_position, "Coordinate") - field_count = size(old_fields) + call insert(old_state, old_fields(1)%mesh, "Mesh") + call insert(new_state, new_fields(1)%mesh, "Mesh") - do field=1,field_count - call insert(old_state, old_fields(field), old_fields(field)%name) - call insert(new_state, new_fields(field), old_fields(field)%name) - end do + call linear_interpolation_state(old_state, new_state, map = map, only_owned = only_owned) + call deallocate(old_state) + call deallocate(new_state) - call insert(old_state, old_position, "Coordinate") - call insert(new_state, new_position, "Coordinate") + end subroutine linear_interpolation_scalars - call insert(old_state, old_fields(1)%mesh, "Mesh") - call insert(new_state, new_fields(1)%mesh, "Mesh") + subroutine linear_interpolation_vector(old_field, old_position, new_field, new_position, map, only_owned) + type(vector_field), intent(in) :: old_field + type(vector_field), intent(in) :: old_position + type(vector_field), intent(inout) :: new_field + type(vector_field), intent(in) :: new_position + integer, dimension(:), optional, intent(in) :: map + logical, intent(in), optional :: only_owned - call linear_interpolation_state(old_state, new_state, map = map, only_owned = only_owned) - call deallocate(old_state) - call deallocate(new_state) + type(state_type) :: old_state, new_state - end subroutine linear_interpolation_scalars + call insert(old_state, old_field, old_field%name) + call insert(new_state, new_field, new_field%name) - subroutine linear_interpolation_vector(old_field, old_position, new_field, new_position, map, only_owned) - type(vector_field), intent(in) :: old_field - type(vector_field), intent(in) :: old_position - type(vector_field), intent(inout) :: new_field - type(vector_field), intent(in) :: new_position - integer, dimension(:), optional, intent(in) :: map - logical, intent(in), optional :: only_owned + call insert(old_state, old_position, "Coordinate") + call insert(new_state, new_position, "Coordinate") - type(state_type) :: old_state, new_state + call insert(old_state, old_field%mesh, "Mesh") + call insert(new_state, new_field%mesh, "Mesh") - call insert(old_state, old_field, old_field%name) - call insert(new_state, new_field, new_field%name) + call linear_interpolation_state(old_state, new_state, map = map, only_owned = only_owned) + call deallocate(old_state) + call deallocate(new_state) - call insert(old_state, old_position, "Coordinate") - call insert(new_state, new_position, "Coordinate") + end subroutine linear_interpolation_vector - call insert(old_state, old_field%mesh, "Mesh") - call insert(new_state, new_field%mesh, "Mesh") + subroutine linear_interpolation_vectors(old_fields, old_position, new_fields, new_position, only_owned) + type(vector_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(in) :: old_position + type(vector_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned - call linear_interpolation_state(old_state, new_state, map = map, only_owned = only_owned) - call deallocate(old_state) - call deallocate(new_state) + type(state_type) :: old_state, new_state + integer :: field, field_count - end subroutine linear_interpolation_vector + field_count = size(old_fields) - subroutine linear_interpolation_vectors(old_fields, old_position, new_fields, new_position, only_owned) - type(vector_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(in) :: old_position - type(vector_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned + do field=1,field_count + call insert(old_state, old_fields(field), old_fields(field)%name) + call insert(new_state, new_fields(field), old_fields(field)%name) + end do - type(state_type) :: old_state, new_state - integer :: field, field_count + call insert(old_state, old_position, "Coordinate") + call insert(new_state, new_position, "Coordinate") - field_count = size(old_fields) + call insert(old_state, old_fields(1)%mesh, "Mesh") + call insert(new_state, new_fields(1)%mesh, "Mesh") - do field=1,field_count - call insert(old_state, old_fields(field), old_fields(field)%name) - call insert(new_state, new_fields(field), old_fields(field)%name) - end do + call linear_interpolation_state(old_state, new_state, only_owned = only_owned) + call deallocate(old_state) + call deallocate(new_state) - call insert(old_state, old_position, "Coordinate") - call insert(new_state, new_position, "Coordinate") + end subroutine linear_interpolation_vectors - call insert(old_state, old_fields(1)%mesh, "Mesh") - call insert(new_state, new_fields(1)%mesh, "Mesh") + subroutine linear_interpolation_tensors(old_fields, old_position, new_fields, new_position, only_owned) + type(tensor_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(in) :: old_position + type(tensor_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned - call linear_interpolation_state(old_state, new_state, only_owned = only_owned) - call deallocate(old_state) - call deallocate(new_state) + type(state_type) :: old_state, new_state + integer :: field, field_count - end subroutine linear_interpolation_vectors - - subroutine linear_interpolation_tensors(old_fields, old_position, new_fields, new_position, only_owned) - type(tensor_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(in) :: old_position - type(tensor_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned + field_count = size(old_fields) - type(state_type) :: old_state, new_state - integer :: field, field_count + do field=1,field_count + call insert(old_state, old_fields(field), old_fields(field)%name) + call insert(new_state, new_fields(field), old_fields(field)%name) + end do - field_count = size(old_fields) + call insert(old_state, old_position, "Coordinate") + call insert(new_state, new_position, "Coordinate") + + call insert(old_state, old_fields(1)%mesh, "Mesh") + call insert(new_state, new_fields(1)%mesh, "Mesh") + + call linear_interpolation_state(old_state, new_state, only_owned = only_owned) + call deallocate(old_state) + call deallocate(new_state) + + end subroutine linear_interpolation_tensors + + subroutine linear_interpolation_tensor(old_field, old_position, new_field, new_position, only_owned) + type(tensor_field), intent(in) :: old_field + type(vector_field), intent(in) :: old_position + type(tensor_field), intent(inout) :: new_field + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned + + type(tensor_field), dimension(1) :: new_field_array, old_field_array + + new_field_array(1) = new_field + old_field_array(1) = old_field + + call linear_interpolation(old_field_array, old_position, new_field_array, new_position, only_owned = only_owned) + + end subroutine linear_interpolation_tensor + + subroutine linear_interpolation_state(old_state, new_state, map, different_domains, only_owned) + !!< Interpolate the fields defined on the old_fields mesh + !!< onto the new_fields mesh. + !!< This routine assumes new_state has all been allocated, + !!< ON THE SAME MESH; it also assumes old_state has all been + !!< allocated on the same mesh. Call it multiple times for + !!< multiple meshes. + + type(state_type), intent(in), target :: old_state, new_state + integer, dimension(:), intent(in), optional, target :: map + integer, dimension(:), pointer :: lmap + logical, intent(in), optional :: different_domains + logical, intent(in), optional :: only_owned + + type(vector_field), pointer :: old_position + type(vector_field) :: new_position + + type(mesh_type), pointer :: old_mesh, new_mesh + integer :: new_node + integer :: ele + integer :: field_count_s + integer :: field_s + integer :: field_count_v + integer :: field_v + integer :: field_count_t + integer :: field_t + integer, dimension(:), pointer :: node_list + integer :: i, j + real :: val_s + real, dimension(:), allocatable :: val_v + real, dimension(:,:), allocatable :: val_t + real, dimension(:), allocatable :: local_coord, shape_fns + logical :: only_owned_b + + type(scalar_field), dimension(:), allocatable, target :: old_fields_s + type(scalar_field), dimension(:), allocatable, target :: new_fields_s + + type(vector_field), dimension(:), allocatable, target :: old_fields_v + type(vector_field), dimension(:), allocatable, target :: new_fields_v + + type(tensor_field), dimension(:), allocatable, target :: old_fields_t + type(tensor_field), dimension(:), allocatable, target :: new_fields_t + + if (associated(old_state%scalar_fields)) then + allocate(old_fields_s(size(old_state%scalar_fields))) + allocate(new_fields_s(size(new_state%scalar_fields))) + end if + if (associated(old_state%vector_fields)) then + allocate(old_fields_v(size(old_state%vector_fields))) + allocate(new_fields_v(size(new_state%vector_fields))) + end if + if (associated(old_state%tensor_fields)) then + allocate(old_fields_t(size(old_state%tensor_fields))) + allocate(new_fields_t(size(new_state%tensor_fields))) + end if - do field=1,field_count - call insert(old_state, old_fields(field), old_fields(field)%name) - call insert(new_state, new_fields(field), old_fields(field)%name) - end do - - call insert(old_state, old_position, "Coordinate") - call insert(new_state, new_position, "Coordinate") - - call insert(old_state, old_fields(1)%mesh, "Mesh") - call insert(new_state, new_fields(1)%mesh, "Mesh") + only_owned_b = present_and_true(only_owned) - call linear_interpolation_state(old_state, new_state, only_owned = only_owned) - call deallocate(old_state) - call deallocate(new_state) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Scalar fields + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - end subroutine linear_interpolation_tensors + if (associated(old_state%scalar_fields)) then + field_count_s = size(old_state%scalar_fields) - subroutine linear_interpolation_tensor(old_field, old_position, new_field, new_position, only_owned) - type(tensor_field), intent(in) :: old_field - type(vector_field), intent(in) :: old_position - type(tensor_field), intent(inout) :: new_field - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned - - type(tensor_field), dimension(1) :: new_field_array, old_field_array - - new_field_array(1) = new_field - old_field_array(1) = old_field - - call linear_interpolation(old_field_array, old_position, new_field_array, new_position, only_owned = only_owned) - - end subroutine linear_interpolation_tensor - - subroutine linear_interpolation_state(old_state, new_state, map, different_domains, only_owned) - !!< Interpolate the fields defined on the old_fields mesh - !!< onto the new_fields mesh. - !!< This routine assumes new_state has all been allocated, - !!< ON THE SAME MESH; it also assumes old_state has all been - !!< allocated on the same mesh. Call it multiple times for - !!< multiple meshes. + ! Construct the list of new_fields to be modified - type(state_type), intent(in), target :: old_state, new_state - integer, dimension(:), intent(in), optional, target :: map - integer, dimension(:), pointer :: lmap - logical, intent(in), optional :: different_domains - logical, intent(in), optional :: only_owned - - type(vector_field), pointer :: old_position - type(vector_field) :: new_position - - type(mesh_type), pointer :: old_mesh, new_mesh - integer :: new_node - integer :: ele - integer :: field_count_s - integer :: field_s - integer :: field_count_v - integer :: field_v - integer :: field_count_t - integer :: field_t - integer, dimension(:), pointer :: node_list - integer :: i, j - real :: val_s - real, dimension(:), allocatable :: val_v - real, dimension(:,:), allocatable :: val_t - real, dimension(:), allocatable :: local_coord, shape_fns - logical :: only_owned_b - - type(scalar_field), dimension(:), allocatable, target :: old_fields_s - type(scalar_field), dimension(:), allocatable, target :: new_fields_s - - type(vector_field), dimension(:), allocatable, target :: old_fields_v - type(vector_field), dimension(:), allocatable, target :: new_fields_v - - type(tensor_field), dimension(:), allocatable, target :: old_fields_t - type(tensor_field), dimension(:), allocatable, target :: new_fields_t - - if (associated(old_state%scalar_fields)) then - allocate(old_fields_s(size(old_state%scalar_fields))) - allocate(new_fields_s(size(new_state%scalar_fields))) - end if - if (associated(old_state%vector_fields)) then - allocate(old_fields_v(size(old_state%vector_fields))) - allocate(new_fields_v(size(new_state%vector_fields))) - end if - if (associated(old_state%tensor_fields)) then - allocate(old_fields_t(size(old_state%tensor_fields))) - allocate(new_fields_t(size(new_state%tensor_fields))) - end if - - only_owned_b = present_and_true(only_owned) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Scalar fields - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (associated(old_state%scalar_fields)) then - field_count_s = size(old_state%scalar_fields) - - ! Construct the list of new_fields to be modified - - do field_s=1,field_count_s - old_fields_s(field_s) = extract_scalar_field(old_state, trim(old_state%scalar_names(field_s))) - new_fields_s(field_s) = extract_scalar_field(new_state, trim(old_state%scalar_names(field_s))) - end do + do field_s=1,field_count_s + old_fields_s(field_s) = extract_scalar_field(old_state, trim(old_state%scalar_names(field_s))) + new_fields_s(field_s) = extract_scalar_field(new_state, trim(old_state%scalar_names(field_s))) + end do - ! Zero the new fields. + ! Zero the new fields. - if (.not. present_and_true(different_domains)) then - do field_s=1,field_count_s - call zero(new_fields_s(field_s)) - end do - end if - else - field_count_s = 0 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Vector fields - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - j=1 - do i=1, vector_field_count(old_state) - old_fields_v(j) = extract_vector_field(old_state, i) - ! skip coordinate fields - if (.not. (old_fields_v(j)%name=="Coordinate" .or. & - old_fields_v(j)%name==trim(old_fields_v(j)%mesh%name)//"Coordinate")) then - - new_fields_v(j) = extract_vector_field(new_state, old_state%vector_names(i)) if (.not. present_and_true(different_domains)) then - call zero(new_fields_v(j)) + do field_s=1,field_count_s + call zero(new_fields_s(field_s)) + end do end if - j=j+1 - + else + field_count_s = 0 end if - end do - field_count_v=j-1 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Tensor fields - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Vector fields + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (associated(old_state%tensor_fields)) then - field_count_t = size(old_state%tensor_fields) + j=1 + do i=1, vector_field_count(old_state) + old_fields_v(j) = extract_vector_field(old_state, i) + ! skip coordinate fields + if (.not. (old_fields_v(j)%name=="Coordinate" .or. & + old_fields_v(j)%name==trim(old_fields_v(j)%mesh%name)//"Coordinate")) then - ! Construct the list of new_fields to be modified + new_fields_v(j) = extract_vector_field(new_state, old_state%vector_names(i)) + if (.not. present_and_true(different_domains)) then + call zero(new_fields_v(j)) + end if + j=j+1 - do field_t=1,field_count_t - old_fields_t(field_t) = extract_tensor_field(old_state, trim(old_state%tensor_names(field_t))) - new_fields_t(field_t) = extract_tensor_field(new_state, trim(old_state%tensor_names(field_t))) + end if end do + field_count_v=j-1 - ! Zero the new fields. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Tensor fields + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (associated(old_state%tensor_fields)) then + field_count_t = size(old_state%tensor_fields) + + ! Construct the list of new_fields to be modified + + do field_t=1,field_count_t + old_fields_t(field_t) = extract_tensor_field(old_state, trim(old_state%tensor_names(field_t))) + new_fields_t(field_t) = extract_tensor_field(new_state, trim(old_state%tensor_names(field_t))) + end do - if (.not. present_and_true(different_domains)) then - do field_t=1,field_count_t - call zero(new_fields_t(field_t)) - end do + ! Zero the new fields. + + if (.not. present_and_true(different_domains)) then + do field_t=1,field_count_t + call zero(new_fields_t(field_t)) + end do + end if + else + field_count_t = 0 end if - else - field_count_t = 0 - end if - - if(field_count_s > 0) then - old_mesh => old_fields_s(1)%mesh - new_mesh => new_fields_s(1)%mesh - else if(field_count_v > 0) then - old_mesh => old_fields_v(1)%mesh - new_mesh => new_fields_v(1)%mesh - else if(field_count_t > 0) then - old_mesh => old_fields_t(1)%mesh - new_mesh => new_fields_t(1)%mesh - else - return - end if - - old_position => extract_vector_field(old_state, "Coordinate") - new_position=get_coordinate_field(new_state, new_mesh) - - allocate(local_coord(old_position%dim + 1)) - allocate(shape_fns(ele_loc(old_mesh, 1))) - - if(field_count_v>0) then - allocate(val_v(old_state%vector_fields(1)%ptr%dim)) - end if - if(field_count_t>0) then - allocate(val_t(old_state%tensor_fields(1)%ptr%dim(1), old_state%tensor_fields(1)%ptr%dim(2))) - end if - - if (present(map)) then - assert(node_count(new_mesh) == size(map)) - lmap => map - else - allocate(lmap(node_count(new_mesh))) - lmap = get_element_mapping(old_position, new_position, different_domains = different_domains, only_owned = only_owned_b) - end if - - ! Loop over the nodes of the new mesh. - - do new_node=1,node_count(new_mesh) - ! cycle unowned elements - if (only_owned_b) then - if (.not. node_owned(new_mesh, new_node)) then - cycle - end if + + if(field_count_s > 0) then + old_mesh => old_fields_s(1)%mesh + new_mesh => new_fields_s(1)%mesh + else if(field_count_v > 0) then + old_mesh => old_fields_v(1)%mesh + new_mesh => new_fields_v(1)%mesh + else if(field_count_t > 0) then + old_mesh => old_fields_t(1)%mesh + new_mesh => new_fields_t(1)%mesh + else + return end if - ! In what element of the old mesh does the new node lie? - ! Find the local coordinates of the point in that element, - ! and evaluate all the shape functions at that point - ele = lmap(new_node) + old_position => extract_vector_field(old_state, "Coordinate") + new_position=get_coordinate_field(new_state, new_mesh) + + allocate(local_coord(old_position%dim + 1)) + allocate(shape_fns(ele_loc(old_mesh, 1))) - if (ele < 0) then - assert(present_and_true(different_domains)) - cycle + if(field_count_v>0) then + allocate(val_v(old_state%vector_fields(1)%ptr%dim)) + end if + if(field_count_t>0) then + allocate(val_t(old_state%tensor_fields(1)%ptr%dim(1), old_state%tensor_fields(1)%ptr%dim(2))) end if - node_list => ele_nodes(old_mesh, ele) - local_coord = local_coords(old_position, ele, node_val(new_position, new_node)) - shape_fns = eval_shape(ele_shape(old_mesh, ele), local_coord) - - do field_s=1,field_count_s - ! At each node of the old element, evaluate val * shape_fn - val_s = 0.0 - do i=1,ele_loc(old_mesh, ele) - val_s = val_s + node_val(old_fields_s(field_s), node_list(i)) * shape_fns(i) - end do - call set(new_fields_s(field_s), new_node, val_s) - end do + if (present(map)) then + assert(node_count(new_mesh) == size(map)) + lmap => map + else + allocate(lmap(node_count(new_mesh))) + lmap = get_element_mapping(old_position, new_position, different_domains = different_domains, only_owned = only_owned_b) + end if - do field_v=1,field_count_v - ! At each node of the old element, evaluate val * shape_fn - val_v = 0.0 - do i=1,ele_loc(old_mesh, ele) - val_v = val_v + node_val(old_fields_v(field_v), node_list(i)) * shape_fns(i) - end do - call set(new_fields_v(field_v), new_node, val_v) - end do + ! Loop over the nodes of the new mesh. + + do new_node=1,node_count(new_mesh) + ! cycle unowned elements + if (only_owned_b) then + if (.not. node_owned(new_mesh, new_node)) then + cycle + end if + end if + + ! In what element of the old mesh does the new node lie? + ! Find the local coordinates of the point in that element, + ! and evaluate all the shape functions at that point + ele = lmap(new_node) + + if (ele < 0) then + assert(present_and_true(different_domains)) + cycle + end if - do field_t=1,field_count_t - ! At each node of the old element, evaluate val * shape_fn - val_t = 0.0 - do i=1,ele_loc(old_mesh, ele) - val_t = val_t + node_val(old_fields_t(field_t), node_list(i)) * shape_fns(i) - end do - call set(new_fields_t(field_t), new_node, val_t) + node_list => ele_nodes(old_mesh, ele) + local_coord = local_coords(old_position, ele, node_val(new_position, new_node)) + shape_fns = eval_shape(ele_shape(old_mesh, ele), local_coord) + + do field_s=1,field_count_s + ! At each node of the old element, evaluate val * shape_fn + val_s = 0.0 + do i=1,ele_loc(old_mesh, ele) + val_s = val_s + node_val(old_fields_s(field_s), node_list(i)) * shape_fns(i) + end do + call set(new_fields_s(field_s), new_node, val_s) + end do + + do field_v=1,field_count_v + ! At each node of the old element, evaluate val * shape_fn + val_v = 0.0 + do i=1,ele_loc(old_mesh, ele) + val_v = val_v + node_val(old_fields_v(field_v), node_list(i)) * shape_fns(i) + end do + call set(new_fields_v(field_v), new_node, val_v) + end do + + do field_t=1,field_count_t + ! At each node of the old element, evaluate val * shape_fn + val_t = 0.0 + do i=1,ele_loc(old_mesh, ele) + val_t = val_t + node_val(old_fields_t(field_t), node_list(i)) * shape_fns(i) + end do + call set(new_fields_t(field_t), new_node, val_t) + end do end do - end do - - if (.not. present(map)) then - deallocate(lmap) - end if - deallocate(local_coord) - deallocate(shape_fns) - - call deallocate(new_position) - - end subroutine linear_interpolation_state - - subroutine cubic_interpolation_cf_scalar(old_fields, old_position, new_fields, new_position, only_owned) - !!< Interpolate the fields defined on the old_fields mesh - !!< onto the new_fields mesh. - !!< This routine assumes new_fields have all been allocated. - - type(scalar_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(inout) :: old_position - type(scalar_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned - - type(mesh_type) :: old_mesh, new_mesh - integer :: old_node - integer :: new_node - integer :: ele - integer :: field_count - integer :: field - integer, dimension(:), pointer :: node_list - integer :: i - integer, dimension(node_count(new_position)) :: map - real, dimension(MATRIX_SIZE_CF) :: cf_expansion - real :: val - logical :: only_owned_b - - assert(size(old_fields) == size(new_fields)) - field_count = size(old_fields) - - old_mesh = old_fields(1)%mesh - new_mesh = new_fields(1)%mesh - - only_owned_b = present_and_true(only_owned) - - call add_nelist(old_mesh) - map = get_element_mapping(old_position, new_position, only_owned = only_owned_b) - - ! Zero the new fields. - - do field=1,field_count - call zero(new_fields(field)) - end do - - ! Loop over the nodes of the new mesh. - - do new_node=1,node_count(new_mesh) - ! cycle unowned elements - if (only_owned_b) then - if (.not. node_owned(new_mesh, new_node)) then - cycle - end if + + if (.not. present(map)) then + deallocate(lmap) end if + deallocate(local_coord) + deallocate(shape_fns) + + call deallocate(new_position) + + end subroutine linear_interpolation_state + + subroutine cubic_interpolation_cf_scalar(old_fields, old_position, new_fields, new_position, only_owned) + !!< Interpolate the fields defined on the old_fields mesh + !!< onto the new_fields mesh. + !!< This routine assumes new_fields have all been allocated. + + type(scalar_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(inout) :: old_position + type(scalar_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned + + type(mesh_type) :: old_mesh, new_mesh + integer :: old_node + integer :: new_node + integer :: ele + integer :: field_count + integer :: field + integer, dimension(:), pointer :: node_list + integer :: i + integer, dimension(node_count(new_position)) :: map + real, dimension(MATRIX_SIZE_CF) :: cf_expansion + real :: val + logical :: only_owned_b + + assert(size(old_fields) == size(new_fields)) + field_count = size(old_fields) + + old_mesh = old_fields(1)%mesh + new_mesh = new_fields(1)%mesh - ! In what element of the old mesh does the new node lie? - ele = map(new_node) - node_list => ele_nodes(old_mesh, ele) + only_owned_b = present_and_true(only_owned) + + call add_nelist(old_mesh) + map = get_element_mapping(old_position, new_position, only_owned = only_owned_b) + + ! Zero the new fields. do field=1,field_count - ! Loop over the nodes of that element, - ! get the cubic expansion of that field, - ! evaluate at the point and average. - val = 0.0 - do i=1,size(node_list) - old_node = node_list(i) - cf_expansion = get_cubic_fit_cf(old_fields(field), old_position, old_node) - val = val + evaluate_cf(cf_expansion, node_val(new_position, new_node)) - end do - val = val / size(node_list) - call set(new_fields(field), new_node, val) + call zero(new_fields(field)) + end do + + ! Loop over the nodes of the new mesh. + + do new_node=1,node_count(new_mesh) + ! cycle unowned elements + if (only_owned_b) then + if (.not. node_owned(new_mesh, new_node)) then + cycle + end if + end if + + ! In what element of the old mesh does the new node lie? + ele = map(new_node) + node_list => ele_nodes(old_mesh, ele) + + do field=1,field_count + ! Loop over the nodes of that element, + ! get the cubic expansion of that field, + ! evaluate at the point and average. + val = 0.0 + do i=1,size(node_list) + old_node = node_list(i) + cf_expansion = get_cubic_fit_cf(old_fields(field), old_position, old_node) + val = val + evaluate_cf(cf_expansion, node_val(new_position, new_node)) + end do + val = val / size(node_list) + call set(new_fields(field), new_node, val) + end do end do - end do - end subroutine cubic_interpolation_cf_scalar + end subroutine cubic_interpolation_cf_scalar - subroutine cubic_interpolation_cf_vector(old_fields, old_position, new_fields, new_position, only_owned) - type(vector_field), dimension(:), intent(in) :: old_fields - type(vector_field), intent(inout) :: old_position - type(vector_field), dimension(:), intent(inout) :: new_fields - type(vector_field), intent(in) :: new_position - logical, intent(in), optional :: only_owned + subroutine cubic_interpolation_cf_vector(old_fields, old_position, new_fields, new_position, only_owned) + type(vector_field), dimension(:), intent(in) :: old_fields + type(vector_field), intent(inout) :: old_position + type(vector_field), dimension(:), intent(inout) :: new_fields + type(vector_field), intent(in) :: new_position + logical, intent(in), optional :: only_owned - type(scalar_field), dimension(old_position%dim * size(old_fields)) :: scalars_in - type(scalar_field), dimension(old_position%dim * size(old_fields)) :: scalars_out - integer :: i, j + type(scalar_field), dimension(old_position%dim * size(old_fields)) :: scalars_in + type(scalar_field), dimension(old_position%dim * size(old_fields)) :: scalars_out + integer :: i, j - do i=1,size(old_fields) - do j=1,old_position%dim - scalars_in((i-1) * old_position%dim + j) = extract_scalar_field(old_fields(i), j) - scalars_out((i-1) * old_position%dim + j) = extract_scalar_field(new_fields(i), j) + do i=1,size(old_fields) + do j=1,old_position%dim + scalars_in((i-1) * old_position%dim + j) = extract_scalar_field(old_fields(i), j) + scalars_out((i-1) * old_position%dim + j) = extract_scalar_field(new_fields(i), j) + end do end do - end do - call cubic_interpolation_cf_scalar(scalars_in, old_position, scalars_out, new_position, only_owned = only_owned) - - end subroutine cubic_interpolation_cf_vector - - subroutine linear_interpolate_states(from_states, target_states, map, only_owned) - type(state_type), dimension(:), intent(inout):: from_states - type(state_type), dimension(:), intent(inout):: target_states - integer, dimension(:), intent(in), optional :: map - logical, intent(in), optional :: only_owned - - type(state_type) meshj_state - type(vector_field), pointer:: from_positions - type(mesh_type), pointer:: from_meshj, target_meshj - integer i, j - - do i=1, size(target_states) - do j=1, mesh_count(target_states(i)) - target_meshj => extract_mesh(target_states(i), j) - from_meshj => extract_mesh(from_states(i), j) - ! select fields that are on meshj only - call select_state_by_mesh(from_states(i), trim(from_meshj%name), meshj_state) - - ! insert coordinate field in selection - ! (possibly on other mesh, will be remapped in linear_interpolation_state) - from_positions => extract_vector_field(from_states(i), "Coordinate") - call insert(meshj_state, from_positions, name=from_positions%name) - - call linear_interpolation_state(meshj_state, target_states(i), & - map = map, only_owned = only_owned) - call deallocate(meshj_state) + call cubic_interpolation_cf_scalar(scalars_in, old_position, scalars_out, new_position, only_owned = only_owned) + + end subroutine cubic_interpolation_cf_vector + + subroutine linear_interpolate_states(from_states, target_states, map, only_owned) + type(state_type), dimension(:), intent(inout):: from_states + type(state_type), dimension(:), intent(inout):: target_states + integer, dimension(:), intent(in), optional :: map + logical, intent(in), optional :: only_owned + + type(state_type) meshj_state + type(vector_field), pointer:: from_positions + type(mesh_type), pointer:: from_meshj, target_meshj + integer i, j + + do i=1, size(target_states) + do j=1, mesh_count(target_states(i)) + target_meshj => extract_mesh(target_states(i), j) + from_meshj => extract_mesh(from_states(i), j) + ! select fields that are on meshj only + call select_state_by_mesh(from_states(i), trim(from_meshj%name), meshj_state) + + ! insert coordinate field in selection + ! (possibly on other mesh, will be remapped in linear_interpolation_state) + from_positions => extract_vector_field(from_states(i), "Coordinate") + call insert(meshj_state, from_positions, name=from_positions%name) + + call linear_interpolation_state(meshj_state, target_states(i), & + map = map, only_owned = only_owned) + call deallocate(meshj_state) + end do end do - end do - end subroutine linear_interpolate_states + end subroutine linear_interpolate_states end module interpolation_module diff --git a/femtools/Intersection_finder.F90 b/femtools/Intersection_finder.F90 index 227d1b83a3..a893820591 100644 --- a/femtools/Intersection_finder.F90 +++ b/femtools/Intersection_finder.F90 @@ -2,820 +2,820 @@ module intersection_finder_module -use fldebug -use quadrature -use elements -use parallel_tools -use data_structures -use sparse_tools -use fields_data_types -use fields_base -use adjacency_lists -use linked_lists -use fields_allocates -use parallel_fields -use transform_elements + use fldebug + use quadrature + use elements + use parallel_tools + use data_structures + use sparse_tools + use fields_data_types + use fields_base + use adjacency_lists + use linked_lists + use fields_allocates + use parallel_fields + use transform_elements #ifdef HAVE_LIBSUPERMESH -use libsupermesh, only : intersections, deallocate, & - & rtree_intersection_finder_reset, & - & rtree_intersection_finder_query_output, & - & rtree_intersection_finder_get_output -use libsupermesh, only : & - & libsupermesh_advancing_front_intersection_finder => advancing_front_intersection_finder, & - & libsupermesh_rtree_intersection_finder => rtree_intersection_finder, & - & libsupermesh_rtree_intersection_finder_set_input => rtree_intersection_finder_set_input, & - & libsupermesh_rtree_intersection_finder_find => rtree_intersection_finder_find + use libsupermesh, only : intersections, deallocate, & + & rtree_intersection_finder_reset, & + & rtree_intersection_finder_query_output, & + & rtree_intersection_finder_get_output + use libsupermesh, only : & + & libsupermesh_advancing_front_intersection_finder => advancing_front_intersection_finder, & + & libsupermesh_rtree_intersection_finder => rtree_intersection_finder, & + & libsupermesh_rtree_intersection_finder_set_input => rtree_intersection_finder_set_input, & + & libsupermesh_rtree_intersection_finder_find => rtree_intersection_finder_find #endif -use supermesh_construction + use supermesh_construction -implicit none + implicit none #ifndef HAVE_LIBSUPERMESH -interface crtree_intersection_finder_set_input - subroutine cintersection_finder_set_input(positions, enlist, ndim, loc, nnodes, nelements) - implicit none - integer, intent(in) :: ndim, loc, nnodes, nelements - real, intent(in), dimension(nnodes * ndim) :: positions - integer, intent(in), dimension(nelements * loc) :: enlist - end subroutine cintersection_finder_set_input -end interface crtree_intersection_finder_set_input - -interface crtree_intersection_finder_find - subroutine cintersection_finder_find(positions, ndim, loc) - implicit none - integer, intent(in) :: ndim, loc - real, dimension(ndim * loc) :: positions - end subroutine cintersection_finder_find -end interface crtree_intersection_finder_find - -interface rtree_intersection_finder_query_output - subroutine cintersection_finder_query_output(nelems) - implicit none - integer, intent(out) :: nelems - end subroutine cintersection_finder_query_output -end interface rtree_intersection_finder_query_output - -interface rtree_intersection_finder_get_output - subroutine cintersection_finder_get_output(id, nelem) - implicit none - integer, intent(out) :: id - integer, intent(in) :: nelem - end subroutine cintersection_finder_get_output -end interface rtree_intersection_finder_get_output - -interface crtree_intersection_finder_reset - subroutine cintersection_finder_reset(ntests) - implicit none - integer, intent(out) :: ntests - end subroutine cintersection_finder_reset -end interface crtree_intersection_finder_reset + interface crtree_intersection_finder_set_input + subroutine cintersection_finder_set_input(positions, enlist, ndim, loc, nnodes, nelements) + implicit none + integer, intent(in) :: ndim, loc, nnodes, nelements + real, intent(in), dimension(nnodes * ndim) :: positions + integer, intent(in), dimension(nelements * loc) :: enlist + end subroutine cintersection_finder_set_input + end interface crtree_intersection_finder_set_input + + interface crtree_intersection_finder_find + subroutine cintersection_finder_find(positions, ndim, loc) + implicit none + integer, intent(in) :: ndim, loc + real, dimension(ndim * loc) :: positions + end subroutine cintersection_finder_find + end interface crtree_intersection_finder_find + + interface rtree_intersection_finder_query_output + subroutine cintersection_finder_query_output(nelems) + implicit none + integer, intent(out) :: nelems + end subroutine cintersection_finder_query_output + end interface rtree_intersection_finder_query_output + + interface rtree_intersection_finder_get_output + subroutine cintersection_finder_get_output(id, nelem) + implicit none + integer, intent(out) :: id + integer, intent(in) :: nelem + end subroutine cintersection_finder_get_output + end interface rtree_intersection_finder_get_output + + interface crtree_intersection_finder_reset + subroutine cintersection_finder_reset(ntests) + implicit none + integer, intent(out) :: ntests + end subroutine cintersection_finder_reset + end interface crtree_intersection_finder_reset #endif -private + private -public :: rtree_intersection_finder_set_input, rtree_intersection_finder_find, & - & rtree_intersection_finder_query_output, & - & rtree_intersection_finder_get_output, rtree_intersection_finder_reset + public :: rtree_intersection_finder_set_input, rtree_intersection_finder_find, & + & rtree_intersection_finder_query_output, & + & rtree_intersection_finder_get_output, rtree_intersection_finder_reset -public :: tri_predicate, tet_predicate, bbox_predicate, intersection_finder, & - & advancing_front_intersection_finder_seeds, & - & advancing_front_intersection_finder, rtree_intersection_finder, & - & brute_force_intersection_finder, verify_map + public :: tri_predicate, tet_predicate, bbox_predicate, intersection_finder, & + & advancing_front_intersection_finder_seeds, & + & advancing_front_intersection_finder, rtree_intersection_finder, & + & brute_force_intersection_finder, verify_map contains - function tri_predicate(posA, posB) result(intersects) - ! dim x loc - real, dimension(:, :), intent(in) :: posA, posB - logical :: intersects + function tri_predicate(posA, posB) result(intersects) + ! dim x loc + real, dimension(:, :), intent(in) :: posA, posB + logical :: intersects + + interface + function tri_tri_overlap_test_2d(p1, q1, r1, p2, q2, r2) result(f) + real, dimension(2) :: p1, q1, r1, p2, q2, r2 + integer :: f + end function tri_tri_overlap_test_2d + end interface - interface - function tri_tri_overlap_test_2d(p1, q1, r1, p2, q2, r2) result(f) real, dimension(2) :: p1, q1, r1, p2, q2, r2 integer :: f - end function tri_tri_overlap_test_2d - end interface - - real, dimension(2) :: p1, q1, r1, p2, q2, r2 - integer :: f - - p1 = posA(:, 1); q1 = posA(:, 2); r1 = posA(:, 3) - p2 = posB(:, 1); q2 = posB(:, 2); r2 = posB(:, 3) - f = tri_tri_overlap_test_2d(p1, q1, r1, p2, q2, r2) - intersects = (f == 1) - - end function tri_predicate - - function tet_predicate(posA, posB) result(intersects) - ! dim x loc - real, dimension(:, :), intent(in) :: posA, posB - logical :: intersects - - interface - function tet_a_tet(V1, V2) result(f) - real, dimension(4, 3), intent(in) :: V1, V2 - integer :: f - end function tet_a_tet - end interface - - integer :: f - - f = tet_a_tet(posA, posB) - intersects = (f == 1) - - end function tet_predicate - - function bbox(pos) result(box) - ! dim x loc - real, dimension(:, :) :: pos - real, dimension(size(pos, 1), 2) :: box - integer :: dim, i, loc, j - - dim = size(pos, 1) - loc = size(pos, 2) - do i=1,dim - box(i, 1) = pos(i, 1) - box(i, 2) = pos(i, 1) - do j=2,loc - box(i, 1) = min(pos(i, j), box(i, 1)) - box(i, 2) = max(pos(i, j), box(i, 2)) + + p1 = posA(:, 1); q1 = posA(:, 2); r1 = posA(:, 3) + p2 = posB(:, 1); q2 = posB(:, 2); r2 = posB(:, 3) + f = tri_tri_overlap_test_2d(p1, q1, r1, p2, q2, r2) + intersects = (f == 1) + + end function tri_predicate + + function tet_predicate(posA, posB) result(intersects) + ! dim x loc + real, dimension(:, :), intent(in) :: posA, posB + logical :: intersects + + interface + function tet_a_tet(V1, V2) result(f) + real, dimension(4, 3), intent(in) :: V1, V2 + integer :: f + end function tet_a_tet + end interface + + integer :: f + + f = tet_a_tet(posA, posB) + intersects = (f == 1) + + end function tet_predicate + + function bbox(pos) result(box) + ! dim x loc + real, dimension(:, :) :: pos + real, dimension(size(pos, 1), 2) :: box + integer :: dim, i, loc, j + + dim = size(pos, 1) + loc = size(pos, 2) + do i=1,dim + box(i, 1) = pos(i, 1) + box(i, 2) = pos(i, 1) + do j=2,loc + box(i, 1) = min(pos(i, j), box(i, 1)) + box(i, 2) = max(pos(i, j), box(i, 2)) + end do end do - end do - end function bbox + end function bbox - function bbox_predicate(bboxA, bboxB) result(intersects) - real, dimension(:, :), intent(in) :: bboxA, bboxB - logical :: intersects - integer :: dim, i + function bbox_predicate(bboxA, bboxB) result(intersects) + real, dimension(:, :), intent(in) :: bboxA, bboxB + logical :: intersects + integer :: dim, i - intersects = .false. - dim = size(bboxA, 1) + intersects = .false. + dim = size(bboxA, 1) - do i=1,dim - if (bboxA(i, 1) > bboxB(i, 2)) return - if (bboxA(i, 2) < bboxB(i, 1)) return - end do - intersects = .true. + do i=1,dim + if (bboxA(i, 1) > bboxB(i, 2)) return + if (bboxA(i, 2) < bboxB(i, 1)) return + end do + intersects = .true. - end function bbox_predicate + end function bbox_predicate - function intersection_finder(positionsA, positionsB) result(map_AB) - !!< A simple wrapper to select an intersection finder + function intersection_finder(positionsA, positionsB) result(map_AB) + !!< A simple wrapper to select an intersection finder - ! The positions and meshes of A and B - type(vector_field), intent(in), target :: positionsA, positionsB - ! for each element in A, the intersecting elements in B - type(ilist), dimension(ele_count(positionsA)) :: map_AB + ! The positions and meshes of A and B + type(vector_field), intent(in), target :: positionsA, positionsB + ! for each element in A, the intersecting elements in B + type(ilist), dimension(ele_count(positionsA)) :: map_AB - integer :: i + integer :: i #if HAVE_LIBSUPERMESH - integer :: j - type(intersections), dimension(:), allocatable :: lmap_AB + integer :: j + type(intersections), dimension(:), allocatable :: lmap_AB - ewrite(1, *) "In intersection_finder" + ewrite(1, *) "In intersection_finder" - ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 - map_AB%length = 0.0 + ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 + map_AB%length = 0.0 - allocate(lmap_AB(size(map_AB))) - call libsupermesh_advancing_front_intersection_finder( & + allocate(lmap_AB(size(map_AB))) + call libsupermesh_advancing_front_intersection_finder( & & positionsA%val, reshape(positionsA%mesh%ndglno, (/positionsA%mesh%shape%loc, ele_count(positionsA)/)), & & positionsB%val, reshape(positionsB%mesh%ndglno, (/positionsB%mesh%shape%loc, ele_count(positionsB)/)), lmap_AB) - do i = 1, size(lmap_AB) - do j = 1, lmap_AB(i)%n - call insert(map_AB(i), lmap_AB(i)%v(j)) + do i = 1, size(lmap_AB) + do j = 1, lmap_AB(i)%n + call insert(map_AB(i), lmap_AB(i)%v(j)) + end do end do - end do - call deallocate(lmap_AB) - deallocate(lmap_AB) + call deallocate(lmap_AB) + deallocate(lmap_AB) - ewrite(1, *) "Exiting intersection_finder" + ewrite(1, *) "Exiting intersection_finder" #else - type(ilist) :: seeds - type(inode), pointer :: node - type(ilist), dimension(:), allocatable :: sub_map_AB + type(ilist) :: seeds + type(inode), pointer :: node + type(ilist), dimension(:), allocatable :: sub_map_AB - ewrite(1, *) "In intersection_finder" + ewrite(1, *) "In intersection_finder" - ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 - map_AB%length = 0.0 + ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 + map_AB%length = 0.0 - ! We cannot assume connectedness, so we may have to run the - ! advancing front more than once (once per connected sub-domain) + ! We cannot assume connectedness, so we may have to run the + ! advancing front more than once (once per connected sub-domain) - seeds = advancing_front_intersection_finder_seeds(positionsA) + seeds = advancing_front_intersection_finder_seeds(positionsA) - allocate(sub_map_AB(size(map_AB))) - node => seeds%firstnode - do while(associated(node)) - sub_map_AB = advancing_front_intersection_finder(positionsA, positionsB, seed = node%value) - do i = 1, size(sub_map_AB) - if(sub_map_AB(i)%length > 0) then - assert(map_AB(i)%length == 0) - map_AB(i) = sub_map_AB(i) - end if - end do + allocate(sub_map_AB(size(map_AB))) + node => seeds%firstnode + do while(associated(node)) + sub_map_AB = advancing_front_intersection_finder(positionsA, positionsB, seed = node%value) + do i = 1, size(sub_map_AB) + if(sub_map_AB(i)%length > 0) then + assert(map_AB(i)%length == 0) + map_AB(i) = sub_map_AB(i) + end if + end do - node => node%next - end do + node => node%next + end do - deallocate(sub_map_AB) - call deallocate(seeds) + deallocate(sub_map_AB) + call deallocate(seeds) - ewrite(1, *) "Exiting intersection_finder" + ewrite(1, *) "Exiting intersection_finder" #endif - end function intersection_finder + end function intersection_finder - function connected(positions) - !!< Return whether the supplied coordinate field is connected. Uses a simple - !!< element advancing front. + function connected(positions) + !!< Return whether the supplied coordinate field is connected. Uses a simple + !!< element advancing front. - type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: positions - logical :: connected + logical :: connected - integer :: ele, i - type(csr_sparsity), pointer :: eelist - logical, dimension(:), allocatable :: tested - integer, dimension(:), pointer :: neigh - type(ilist) :: next + integer :: ele, i + type(csr_sparsity), pointer :: eelist + logical, dimension(:), allocatable :: tested + integer, dimension(:), pointer :: neigh + type(ilist) :: next - eelist => extract_eelist(positions) + eelist => extract_eelist(positions) - allocate(tested(ele_count(positions))) - tested = .false. - - assert(ele_count(positions) > 0) - ele = 1 - tested(ele) = .true. - neigh => row_m_ptr(eelist, ele) - do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - - call insert(next, neigh(i)) - end do - - do while(next%length > 0) - ele = pop(next) - if(tested(ele)) cycle + allocate(tested(ele_count(positions))) + tested = .false. + assert(ele_count(positions) > 0) + ele = 1 tested(ele) = .true. neigh => row_m_ptr(eelist, ele) do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - if(tested(neigh(i))) cycle - ! Should check if neigh(i) is already in the list + if(neigh(i) <= 0) cycle + + call insert(next, neigh(i)) + end do - call insert(next, neigh(i)) + do while(next%length > 0) + ele = pop(next) + if(tested(ele)) cycle + + tested(ele) = .true. + neigh => row_m_ptr(eelist, ele) + do i = 1, size(neigh) + if(neigh(i) <= 0) cycle + if(tested(neigh(i))) cycle + ! Should check if neigh(i) is already in the list + + call insert(next, neigh(i)) + end do end do - end do - ! The mesh is connected iff we see all elements in the advancing front - connected = all(tested) + ! The mesh is connected iff we see all elements in the advancing front + connected = all(tested) - deallocate(tested) + deallocate(tested) - end function connected + end function connected - function advancing_front_intersection_finder_seeds(positions) result(seeds) - !!< Return a list of seeds for the advancing front intersection finder - one - !!< seed per connected sub-domain. + function advancing_front_intersection_finder_seeds(positions) result(seeds) + !!< Return a list of seeds for the advancing front intersection finder - one + !!< seed per connected sub-domain. - type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: positions - type(ilist) :: seeds + type(ilist) :: seeds - integer :: ele, first_ele, i - type(csr_sparsity), pointer :: eelist - logical, dimension(:), allocatable :: tested - integer, dimension(:), pointer :: neigh - type(ilist) :: next + integer :: ele, first_ele, i + type(csr_sparsity), pointer :: eelist + logical, dimension(:), allocatable :: tested + integer, dimension(:), pointer :: neigh + type(ilist) :: next - eelist => extract_eelist(positions) + eelist => extract_eelist(positions) - allocate(tested(ele_count(positions))) - tested = .false. + allocate(tested(ele_count(positions))) + tested = .false. - first_ele = 1 - do while(first_ele /= 0) - ele = first_ele - assert(ele > 0) - assert(ele <= ele_count(positions)) - assert(.not. tested(ele)) + first_ele = 1 + do while(first_ele /= 0) + ele = first_ele + assert(ele > 0) + assert(ele <= ele_count(positions)) + assert(.not. tested(ele)) - call insert(seeds, ele) + call insert(seeds, ele) - tested(ele) = .true. - neigh => row_m_ptr(eelist, ele) - do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - if(tested(neigh(i))) cycle + tested(ele) = .true. + neigh => row_m_ptr(eelist, ele) + do i = 1, size(neigh) + if(neigh(i) <= 0) cycle + if(tested(neigh(i))) cycle - call insert(next, neigh(i)) - end do + call insert(next, neigh(i)) + end do - do while(next%length > 0) - ele = pop(next) - if(tested(ele)) cycle - - tested(ele) = .true. - neigh => row_m_ptr(eelist, ele) - do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - if(tested(neigh(i))) cycle - ! Should check if neigh(i) is already in the list - - call insert(next, neigh(i)) - end do - end do + do while(next%length > 0) + ele = pop(next) + if(tested(ele)) cycle - first_ele = next_false_loc(first_ele + 1, tested) - end do - assert(all(tested)) + tested(ele) = .true. + neigh => row_m_ptr(eelist, ele) + do i = 1, size(neigh) + if(neigh(i) <= 0) cycle + if(tested(neigh(i))) cycle + ! Should check if neigh(i) is already in the list - deallocate(tested) + call insert(next, neigh(i)) + end do + end do - contains + first_ele = next_false_loc(first_ele + 1, tested) + end do + assert(all(tested)) - pure function next_false_loc(start_index, logical_vector) result(loc) - integer, intent(in) :: start_index - logical, dimension(:), intent(in) :: logical_vector + deallocate(tested) - integer :: loc + contains - integer :: i + pure function next_false_loc(start_index, logical_vector) result(loc) + integer, intent(in) :: start_index + logical, dimension(:), intent(in) :: logical_vector - do i = start_index, size(logical_vector) - if(.not. logical_vector(i)) then - loc = i - return - end if - end do + integer :: loc + + integer :: i - loc = 0 + do i = start_index, size(logical_vector) + if(.not. logical_vector(i)) then + loc = i + return + end if + end do + + loc = 0 - end function next_false_loc + end function next_false_loc - end function advancing_front_intersection_finder_seeds + end function advancing_front_intersection_finder_seeds #ifdef HAVE_LIBSUPERMESH - function advancing_front_intersection_finder(positionsA, positionsB) result(map_AB) - ! The positions and meshes of A and B - type(vector_field), intent(in) :: positionsA - type(vector_field), intent(in) :: positionsB + function advancing_front_intersection_finder(positionsA, positionsB) result(map_AB) + ! The positions and meshes of A and B + type(vector_field), intent(in) :: positionsA + type(vector_field), intent(in) :: positionsB - ! for each element in A, the intersecting elements in B - type(ilist), dimension(ele_count(positionsA)) :: map_AB + ! for each element in A, the intersecting elements in B + type(ilist), dimension(ele_count(positionsA)) :: map_AB - integer :: i, j - type(intersections), dimension(:), allocatable :: lmap_AB + integer :: i, j + type(intersections), dimension(:), allocatable :: lmap_AB - ewrite(1, *) "In advancing_front_intersection_finder" + ewrite(1, *) "In advancing_front_intersection_finder" - ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 - map_AB%length = 0.0 + ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 + map_AB%length = 0.0 - allocate(lmap_AB(size(map_AB))) - call libsupermesh_advancing_front_intersection_finder( & + allocate(lmap_AB(size(map_AB))) + call libsupermesh_advancing_front_intersection_finder( & & positionsA%val, reshape(positionsA%mesh%ndglno, (/positionsA%mesh%shape%loc, ele_count(positionsA)/)), & & positionsB%val, reshape(positionsB%mesh%ndglno, (/positionsB%mesh%shape%loc, ele_count(positionsB)/)), lmap_AB) - do i = 1, size(lmap_AB) - do j = 1, lmap_AB(i)%n - call insert(map_AB(i), lmap_AB(i)%v(j)) + do i = 1, size(lmap_AB) + do j = 1, lmap_AB(i)%n + call insert(map_AB(i), lmap_AB(i)%v(j)) + end do end do - end do - call deallocate(lmap_AB) + call deallocate(lmap_AB) - ewrite(1, *) "Exiting advancing_front_intersection_finder" + ewrite(1, *) "Exiting advancing_front_intersection_finder" - end function advancing_front_intersection_finder + end function advancing_front_intersection_finder #else - function advancing_front_intersection_finder(positionsA, positionsB, seed) result(map_AB) - ! The positions and meshes of A and B - type(vector_field), intent(in), target :: positionsA, positionsB - ! for each element in A, the intersecting elements in B - type(ilist), dimension(ele_count(positionsA)) :: map_AB - integer, optional, intent(in) :: seed - - ! processed_neighbour maps an element to a neighbour that has already been processed (i.e. its clue) - type(integer_hash_table) :: processed_neighbour - ! we also need to keep a set of the elements we've seen: this is different to - ! the elements that have map_AB(ele)%length > 0 in the case where the domain - ! is not simply connected! - type(integer_set) :: seen_elements - - integer :: ele_A - type(mesh_type), pointer :: mesh_A, mesh_B - integer :: i, neighbour - real, dimension(ele_count(positionsB), positionsB%dim, 2) :: bboxes_B - integer, dimension(:), pointer :: neigh_A - type(csr_sparsity), pointer :: eelist_A, eelist_B - - type(ilist) :: clues - - ewrite(1, *) "In advancing_front_intersection_finder" - - ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 - map_AB%length = 0.0 - - mesh_A => positionsA%mesh - mesh_B => positionsB%mesh - - eelist_A => extract_eelist(mesh_A) - eelist_B => extract_eelist(mesh_B) - - call compute_bboxes(positionsB, bboxes_B) - - if(present(seed)) then - assert(seed > 0) - assert(seed <= ele_count(positionsA)) - ele_A = seed - else - ele_A = 1 - end if - map_AB(ele_A) = brute_force_search(ele_val(positionsA, ele_A), positionsB, bboxes_B) - - call allocate(processed_neighbour) - call allocate(seen_elements) - - neigh_A => row_m_ptr(eelist_A, ele_A) - do i=1,size(neigh_A) - neighbour = neigh_A(i) - if (neighbour <= 0) cycle - call insert(processed_neighbour, neighbour, ele_A) - end do - call insert(seen_elements, ele_A) - - do while (key_count(processed_neighbour) > 0) - call fetch_pair(processed_neighbour, 1, ele_A, neighbour) - ! try to keep our memory footprint low - call remove(processed_neighbour, ele_A) - call insert(seen_elements, ele_A) - - assert(map_AB(ele_A)%length == 0) ! we haven't seen it yet + function advancing_front_intersection_finder(positionsA, positionsB, seed) result(map_AB) + ! The positions and meshes of A and B + type(vector_field), intent(in), target :: positionsA, positionsB + ! for each element in A, the intersecting elements in B + type(ilist), dimension(ele_count(positionsA)) :: map_AB + integer, optional, intent(in) :: seed + + ! processed_neighbour maps an element to a neighbour that has already been processed (i.e. its clue) + type(integer_hash_table) :: processed_neighbour + ! we also need to keep a set of the elements we've seen: this is different to + ! the elements that have map_AB(ele)%length > 0 in the case where the domain + ! is not simply connected! + type(integer_set) :: seen_elements + + integer :: ele_A + type(mesh_type), pointer :: mesh_A, mesh_B + integer :: i, neighbour + real, dimension(ele_count(positionsB), positionsB%dim, 2) :: bboxes_B + integer, dimension(:), pointer :: neigh_A + type(csr_sparsity), pointer :: eelist_A, eelist_B + + type(ilist) :: clues + + ewrite(1, *) "In advancing_front_intersection_finder" + + ! workaround gfortran issue: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85750 + map_AB%length = 0.0 + + mesh_A => positionsA%mesh + mesh_B => positionsB%mesh + + eelist_A => extract_eelist(mesh_A) + eelist_B => extract_eelist(mesh_B) + + call compute_bboxes(positionsB, bboxes_B) + + if(present(seed)) then + assert(seed > 0) + assert(seed <= ele_count(positionsA)) + ele_A = seed + else + ele_A = 1 + end if + map_AB(ele_A) = brute_force_search(ele_val(positionsA, ele_A), positionsB, bboxes_B) - clues = clueful_search(ele_val(positionsA, ele_A), map_AB(neighbour), & - & bboxes_B, ele_A, neighbour) - map_AB(ele_A) = advance_front(ele_val(positionsA, ele_A), positionsB, clues, bboxes_B, eelist_B) - call deallocate(clues) + call allocate(processed_neighbour) + call allocate(seen_elements) - ! Now that ele_A has been computed, make its clues available to anyone who needs them neigh_A => row_m_ptr(eelist_A, ele_A) do i=1,size(neigh_A) - neighbour = neigh_A(i) - if (neighbour <= 0) cycle - if (has_value(seen_elements, neighbour)) then - ! We've already seen it - cycle - end if - call insert(processed_neighbour, neighbour, ele_A) + neighbour = neigh_A(i) + if (neighbour <= 0) cycle + call insert(processed_neighbour, neighbour, ele_A) end do - end do + call insert(seen_elements, ele_A) - assert(key_count(processed_neighbour) == 0) - call deallocate(processed_neighbour) - call deallocate(seen_elements) + do while (key_count(processed_neighbour) > 0) + call fetch_pair(processed_neighbour, 1, ele_A, neighbour) + ! try to keep our memory footprint low + call remove(processed_neighbour, ele_A) + call insert(seen_elements, ele_A) - ewrite(1, *) "Exiting advancing_front_intersection_finder" + assert(map_AB(ele_A)%length == 0) ! we haven't seen it yet - contains - function advance_front(posA, positionsB, clues, bboxes_B, eelist_B) result(map) - real, dimension(:, :), intent(in) :: posA - type(vector_field), intent(in), target :: positionsB - type(ilist), intent(inout) :: clues - real, dimension(:, :, :), intent(in) :: bboxes_B - type(csr_sparsity), intent(in) :: eelist_B - - type(ilist) :: map - integer, dimension(:), pointer :: neigh_B - integer :: i, possible, neighbour, j - logical :: intersects - type(mesh_type), pointer :: mesh_B - real, dimension(size(posA, 1), 2) :: bboxA - integer :: ele_B - type(integer_set) :: in_list - type(integer_hash_table) :: possibles_tbl - integer :: possible_size - - bboxA = bbox(posA) - call allocate(in_list) - call allocate(possibles_tbl) - possible_size = 0 - - mesh_B => positionsB%mesh - - do while (clues%length /= 0) - ele_B = pop(clues) - if (.not. has_value(in_list, ele_B)) then - call insert(map, ele_B) - call insert(in_list, ele_B) - end if + clues = clueful_search(ele_val(positionsA, ele_A), map_AB(neighbour), & + & bboxes_B, ele_A, neighbour) + map_AB(ele_A) = advance_front(ele_val(positionsA, ele_A), positionsB, clues, bboxes_B, eelist_B) + call deallocate(clues) - ! Append all the neighbours of ele_B to possibles. - neigh_B => row_m_ptr(eelist_B, ele_B) - do i=1,size(neigh_B) - neighbour = neigh_B(i) + ! Now that ele_A has been computed, make its clues available to anyone who needs them + neigh_A => row_m_ptr(eelist_A, ele_A) + do i=1,size(neigh_A) + neighbour = neigh_A(i) if (neighbour <= 0) cycle - if (.not. has_value(in_list, neighbour)) then - possible_size = possible_size + 1 - call insert(possibles_tbl, possible_size, neighbour) - call insert(in_list, neighbour) + if (has_value(seen_elements, neighbour)) then + ! We've already seen it + cycle end if - end do - end do - - ! while len(possibles) != 0: - ! If predicate(ele_A, ele_B) is false: remove it from possibles and add it to rejects. - ! If true: add it to map and add all its neighbours not in map or rejects to map. - - j = 1 - do while (j <= possible_size) - possible = fetch(possibles_tbl, j) - intersects = bbox_predicate(bboxA, bboxes_B(possible, :, :)) - if (intersects) then - call insert(map, possible) - neigh_B => row_m_ptr(eelist_B, possible) + call insert(processed_neighbour, neighbour, ele_A) + end do + end do + + assert(key_count(processed_neighbour) == 0) + call deallocate(processed_neighbour) + call deallocate(seen_elements) + + ewrite(1, *) "Exiting advancing_front_intersection_finder" + + contains + function advance_front(posA, positionsB, clues, bboxes_B, eelist_B) result(map) + real, dimension(:, :), intent(in) :: posA + type(vector_field), intent(in), target :: positionsB + type(ilist), intent(inout) :: clues + real, dimension(:, :, :), intent(in) :: bboxes_B + type(csr_sparsity), intent(in) :: eelist_B + + type(ilist) :: map + integer, dimension(:), pointer :: neigh_B + integer :: i, possible, neighbour, j + logical :: intersects + type(mesh_type), pointer :: mesh_B + real, dimension(size(posA, 1), 2) :: bboxA + integer :: ele_B + type(integer_set) :: in_list + type(integer_hash_table) :: possibles_tbl + integer :: possible_size + + bboxA = bbox(posA) + call allocate(in_list) + call allocate(possibles_tbl) + possible_size = 0 + + mesh_B => positionsB%mesh + + do while (clues%length /= 0) + ele_B = pop(clues) + if (.not. has_value(in_list, ele_B)) then + call insert(map, ele_B) + call insert(in_list, ele_B) + end if + + ! Append all the neighbours of ele_B to possibles. + neigh_B => row_m_ptr(eelist_B, ele_B) do i=1,size(neigh_B) - neighbour = neigh_B(i) - if (neighbour <= 0) cycle - if (.not. has_value(in_list, neighbour)) then - possible_size = possible_size + 1 - call insert(possibles_tbl, possible_size, neighbour) - call insert(in_list, neighbour) - end if + neighbour = neigh_B(i) + if (neighbour <= 0) cycle + if (.not. has_value(in_list, neighbour)) then + possible_size = possible_size + 1 + call insert(possibles_tbl, possible_size, neighbour) + call insert(in_list, neighbour) + end if end do - end if - j = j + 1 - end do + end do + + ! while len(possibles) != 0: + ! If predicate(ele_A, ele_B) is false: remove it from possibles and add it to rejects. + ! If true: add it to map and add all its neighbours not in map or rejects to map. + + j = 1 + do while (j <= possible_size) + possible = fetch(possibles_tbl, j) + intersects = bbox_predicate(bboxA, bboxes_B(possible, :, :)) + if (intersects) then + call insert(map, possible) + neigh_B => row_m_ptr(eelist_B, possible) + do i=1,size(neigh_B) + neighbour = neigh_B(i) + if (neighbour <= 0) cycle + if (.not. has_value(in_list, neighbour)) then + possible_size = possible_size + 1 + call insert(possibles_tbl, possible_size, neighbour) + call insert(in_list, neighbour) + end if + end do + end if + j = j + 1 + end do - call deallocate(in_list) - call deallocate(possibles_tbl) + call deallocate(in_list) + call deallocate(possibles_tbl) - possible_size = 0 + possible_size = 0 end function advance_front - end function advancing_front_intersection_finder + end function advancing_front_intersection_finder #endif - function brute_force_intersection_finder(positions_a, positions_b) result(map_ab) - !!< As advancing_front_intersection_finder, but uses a brute force - !!< algorithm. For testing *only*. For practical applications, use the - !!< linear algorithm. + function brute_force_intersection_finder(positions_a, positions_b) result(map_ab) + !!< As advancing_front_intersection_finder, but uses a brute force + !!< algorithm. For testing *only*. For practical applications, use the + !!< linear algorithm. - ! The positions and meshes of A and B - type(vector_field), intent(in), target :: positions_a, positions_b - ! for each element in A, the intersecting elements in B - type(ilist), dimension(ele_count(positions_a)) :: map_ab + ! The positions and meshes of A and B + type(vector_field), intent(in), target :: positions_a, positions_b + ! for each element in A, the intersecting elements in B + type(ilist), dimension(ele_count(positions_a)) :: map_ab - integer :: i, j + integer :: i, j - ewrite(1, *) "In brute_force_intersection_finder" + ewrite(1, *) "In brute_force_intersection_finder" - do i = 1, ele_count(positions_a) - do j = 1, ele_count(positions_b) - if(bbox_predicate(bbox(ele_val(positions_a, i)), bbox(ele_val(positions_b, j)))) then - call insert(map_ab(i), j) - end if + do i = 1, ele_count(positions_a) + do j = 1, ele_count(positions_b) + if(bbox_predicate(bbox(ele_val(positions_a, i)), bbox(ele_val(positions_b, j)))) then + call insert(map_ab(i), j) + end if + end do end do - end do - ewrite(1, *) "Exiting brute_force_intersection_finder" + ewrite(1, *) "Exiting brute_force_intersection_finder" - end function brute_force_intersection_finder + end function brute_force_intersection_finder #ifndef HAVE_LIBSUPERMESH - subroutine rtree_intersection_finder_reset() - integer :: ntests + subroutine rtree_intersection_finder_reset() + integer :: ntests - call crtree_intersection_finder_reset(ntests) + call crtree_intersection_finder_reset(ntests) - end subroutine rtree_intersection_finder_reset + end subroutine rtree_intersection_finder_reset #endif - subroutine rtree_intersection_finder_set_input(old_positions) - type(vector_field), intent(in) :: old_positions + subroutine rtree_intersection_finder_set_input(old_positions) + type(vector_field), intent(in) :: old_positions #ifdef HAVE_LIBSUPERMESH - call libsupermesh_rtree_intersection_finder_set_input( & + call libsupermesh_rtree_intersection_finder_set_input( & & old_positions%val, & & reshape(old_positions%mesh%ndglno, (/old_positions%mesh%shape%loc, ele_count(old_positions)/))) #else - real, dimension(node_count(old_positions) * old_positions%dim) :: tmp_positions - integer :: node, dim + real, dimension(node_count(old_positions) * old_positions%dim) :: tmp_positions + integer :: node, dim - dim = old_positions%dim + dim = old_positions%dim - ! Ugh. We have to copy the memory because old_positions - ! stores it as 2 or 3 separate vectors - do node=1,node_count(old_positions) - tmp_positions((node-1)*dim+1:node*dim) = node_val(old_positions, node) - end do + ! Ugh. We have to copy the memory because old_positions + ! stores it as 2 or 3 separate vectors + do node=1,node_count(old_positions) + tmp_positions((node-1)*dim+1:node*dim) = node_val(old_positions, node) + end do - call crtree_intersection_finder_set_input(tmp_positions, old_positions%mesh%ndglno, dim, & - & ele_loc(old_positions, 1), node_count(old_positions), & - & ele_count(old_positions)) + call crtree_intersection_finder_set_input(tmp_positions, old_positions%mesh%ndglno, dim, & + & ele_loc(old_positions, 1), node_count(old_positions), & + & ele_count(old_positions)) #endif - end subroutine rtree_intersection_finder_set_input + end subroutine rtree_intersection_finder_set_input - subroutine rtree_intersection_finder_find(new_positions, ele_B) - type(vector_field), intent(in) :: new_positions - integer, intent(in) :: ele_B + subroutine rtree_intersection_finder_find(new_positions, ele_B) + type(vector_field), intent(in) :: new_positions + integer, intent(in) :: ele_B #ifdef HAVE_LIBSUPERMESH - call libsupermesh_rtree_intersection_finder_find(ele_val(new_positions, ele_B)) + call libsupermesh_rtree_intersection_finder_find(ele_val(new_positions, ele_B)) #else - integer :: dim, loc + integer :: dim, loc - dim = new_positions%dim - loc = ele_loc(new_positions, 1) + dim = new_positions%dim + loc = ele_loc(new_positions, 1) - call crtree_intersection_finder_find(reshape(ele_val(new_positions, ele_B), (/dim*loc/)), dim, loc) + call crtree_intersection_finder_find(reshape(ele_val(new_positions, ele_B), (/dim*loc/)), dim, loc) #endif - end subroutine rtree_intersection_finder_find + end subroutine rtree_intersection_finder_find - function rtree_intersection_finder(positions_a, positions_b) result(map_ab) - !!< As advancing_front_intersection_finder, but uses an rtree algorithm. For - !!< testing *only*. For practical applications, use the linear algorithm. + function rtree_intersection_finder(positions_a, positions_b) result(map_ab) + !!< As advancing_front_intersection_finder, but uses an rtree algorithm. For + !!< testing *only*. For practical applications, use the linear algorithm. - ! The positions and meshes of A and B - type(vector_field), intent(in), target :: positions_a, positions_b - ! for each element in A, the intersecting elements in B - type(ilist), dimension(ele_count(positions_a)) :: map_ab + ! The positions and meshes of A and B + type(vector_field), intent(in), target :: positions_a, positions_b + ! for each element in A, the intersecting elements in B + type(ilist), dimension(ele_count(positions_a)) :: map_ab - integer :: i, j, id, nelms + integer :: i, j, id, nelms - ewrite(1, *) "In rtree_intersection_finder" + ewrite(1, *) "In rtree_intersection_finder" - call rtree_intersection_finder_set_input(positions_b) - do i = 1, ele_count(positions_a) - call rtree_intersection_finder_find(positions_a, i) - call rtree_intersection_finder_query_output(nelms) - do j = 1, nelms - call rtree_intersection_finder_get_output(id, j) - call insert(map_ab(i), id) + call rtree_intersection_finder_set_input(positions_b) + do i = 1, ele_count(positions_a) + call rtree_intersection_finder_find(positions_a, i) + call rtree_intersection_finder_query_output(nelms) + do j = 1, nelms + call rtree_intersection_finder_get_output(id, j) + call insert(map_ab(i), id) + end do end do - end do - call rtree_intersection_finder_reset() - - ewrite(1, *) "Exiting rtree_intersection_finder" - - end function rtree_intersection_finder - - subroutine verify_map(mesh_field_a, mesh_field_b, map_ab, map_ab_reference) - !!< Verify the given intersection map against a reference map. - - type(vector_field), intent(in) :: mesh_field_a - type(vector_field), intent(in) :: mesh_field_b - type(ilist), dimension(:), intent(in) :: map_ab - type(ilist), dimension(:), intent(in) :: map_ab_reference - - integer :: dim, i, j, loc - real :: reference_intersection_volume, intersection_volume - real, dimension(:), allocatable :: detwei - real, parameter :: relative_tolerance = 1.0e-8 - type(element_type):: shape - type(quadrature_type) :: quad - type(inode), pointer :: node - type(vector_field) :: intersection - logical :: empty_intersection - - ewrite(1, *) "Entering verify_map" - - assert(mesh_field_a%dim == mesh_field_b%dim) - dim = mesh_field_a%dim - select case(dim) - case(2) - loc = 3 - case(3) - loc = 4 - case default - FLAbort("Can only verify intersection maps for dimension 2 or 3") - end select - - quad = make_quadrature(loc, mesh_field_a%dim ,degree = mesh_field_a%mesh%shape%quadrature%degree) - shape = make_element_shape(loc, mesh_field_a%dim, mesh_field_a%mesh%shape%degree, quad) - call deallocate(quad) - - call intersector_set_dimension(mesh_field_a%dim) - - do i = 1, ele_count(mesh_field_a) - if(map_ab(i)%length /= map_ab_reference(i)%length) then - ewrite(0, "(a,i0)") "For element ", i - ewrite(0, "(a,i0)") "Test number of intersections: ", map_ab(i)%length - ewrite(0, "(a,i0)") "Reference number of intersections: ", map_ab_reference(i)%length - ewrite(0, *) "Warning: Number of intersection elements differs" - end if + call rtree_intersection_finder_reset() + + ewrite(1, *) "Exiting rtree_intersection_finder" + + end function rtree_intersection_finder + + subroutine verify_map(mesh_field_a, mesh_field_b, map_ab, map_ab_reference) + !!< Verify the given intersection map against a reference map. + + type(vector_field), intent(in) :: mesh_field_a + type(vector_field), intent(in) :: mesh_field_b + type(ilist), dimension(:), intent(in) :: map_ab + type(ilist), dimension(:), intent(in) :: map_ab_reference + + integer :: dim, i, j, loc + real :: reference_intersection_volume, intersection_volume + real, dimension(:), allocatable :: detwei + real, parameter :: relative_tolerance = 1.0e-8 + type(element_type):: shape + type(quadrature_type) :: quad + type(inode), pointer :: node + type(vector_field) :: intersection + logical :: empty_intersection + + ewrite(1, *) "Entering verify_map" + + assert(mesh_field_a%dim == mesh_field_b%dim) + dim = mesh_field_a%dim + select case(dim) + case(2) + loc = 3 + case(3) + loc = 4 + case default + FLAbort("Can only verify intersection maps for dimension 2 or 3") + end select + + quad = make_quadrature(loc, mesh_field_a%dim ,degree = mesh_field_a%mesh%shape%quadrature%degree) + shape = make_element_shape(loc, mesh_field_a%dim, mesh_field_a%mesh%shape%degree, quad) + call deallocate(quad) + + call intersector_set_dimension(mesh_field_a%dim) + + do i = 1, ele_count(mesh_field_a) + if(map_ab(i)%length /= map_ab_reference(i)%length) then + ewrite(0, "(a,i0)") "For element ", i + ewrite(0, "(a,i0)") "Test number of intersections: ", map_ab(i)%length + ewrite(0, "(a,i0)") "Reference number of intersections: ", map_ab_reference(i)%length + ewrite(0, *) "Warning: Number of intersection elements differs" + end if + + intersection_volume = 0.0 + node => map_ab(i)%firstnode + do while(associated(node)) + intersection = intersect_elements(mesh_field_a, i, ele_val(mesh_field_b, node%value), shape, empty_intersection) + if (empty_intersection) then + node => node%next + cycle + end if - intersection_volume = 0.0 - node => map_ab(i)%firstnode - do while(associated(node)) - intersection = intersect_elements(mesh_field_a, i, ele_val(mesh_field_b, node%value), shape, empty_intersection) - if (empty_intersection) then - node => node%next - cycle - end if - - do j = 1, ele_count(intersection) - allocate(detwei(shape%ngi)) - call transform_to_physical(intersection, j, detwei = detwei) - intersection_volume = intersection_volume + sum(detwei) - deallocate(detwei) - end do - call deallocate(intersection) - node => node%next - end do + do j = 1, ele_count(intersection) + allocate(detwei(shape%ngi)) + call transform_to_physical(intersection, j, detwei = detwei) + intersection_volume = intersection_volume + sum(detwei) + deallocate(detwei) + end do + call deallocate(intersection) + node => node%next + end do + + reference_intersection_volume = 0.0 + node => map_ab_reference(i)%firstnode + do while(associated(node)) + intersection = intersect_elements(mesh_field_a, i, ele_val(mesh_field_b, node%value), shape, empty_intersection) + if (empty_intersection) then + node => node%next + cycle + end if - reference_intersection_volume = 0.0 - node => map_ab_reference(i)%firstnode - do while(associated(node)) - intersection = intersect_elements(mesh_field_a, i, ele_val(mesh_field_b, node%value), shape, empty_intersection) - if (empty_intersection) then - node => node%next - cycle - end if - - do j = 1, ele_count(intersection) - allocate(detwei(shape%ngi)) - call transform_to_physical(intersection, j, detwei = detwei) - reference_intersection_volume = reference_intersection_volume + sum(detwei) - deallocate(detwei) - end do - call deallocate(intersection) - node => node%next + do j = 1, ele_count(intersection) + allocate(detwei(shape%ngi)) + call transform_to_physical(intersection, j, detwei = detwei) + reference_intersection_volume = reference_intersection_volume + sum(detwei) + deallocate(detwei) + end do + call deallocate(intersection) + node => node%next + end do + + if(abs(intersection_volume - reference_intersection_volume) > abs(max(relative_tolerance, relative_tolerance * intersection_volume))) then + ewrite(-1, "(a,i0)") "For element ", i + ewrite(-1, *) "Volume of test intersection: ", intersection_volume + ewrite(-1, *) "Volume of reference intersection: ", reference_intersection_volume + FLAbort("Intersection volumes do not match") + end if end do - if(abs(intersection_volume - reference_intersection_volume) > abs(max(relative_tolerance, relative_tolerance * intersection_volume))) then - ewrite(-1, "(a,i0)") "For element ", i - ewrite(-1, *) "Volume of test intersection: ", intersection_volume - ewrite(-1, *) "Volume of reference intersection: ", reference_intersection_volume - FLAbort("Intersection volumes do not match") - end if - end do - - call deallocate(shape) + call deallocate(shape) - ewrite(2, *) "Verification successful" + ewrite(2, *) "Verification successful" - ewrite(1, *) "Exiting verify_map" + ewrite(1, *) "Exiting verify_map" - end subroutine verify_map + end subroutine verify_map #ifndef HAVE_LIBSUPERMESH - subroutine compute_bboxes(positionsB, bboxes_B) - type(vector_field), intent(in) :: positionsB - real, dimension(:, :, :), intent(out) :: bboxes_B - integer :: ele_B - - do ele_B=1,ele_count(positionsB) - bboxes_B(ele_B, :, :) = bbox(ele_val(positionsB, ele_B)) - end do - end subroutine compute_bboxes - - function brute_force_search(posA, positionsB, bboxes_B) result(map) - real, dimension(:, :), intent(in) :: posA - type(vector_field), intent(in) :: positionsB - real, dimension(:, :, :), intent(in) :: bboxes_B - type(ilist) :: map - integer :: ele_B - real, dimension(size(posA, 1), 2) :: bboxA - - bboxA = bbox(posA) - - do ele_B=1,ele_count(positionsB) - if (bbox_predicate(bboxA, bboxes_B(ele_B, :, :))) then - call insert(map, ele_B) - end if - end do - - if (map%length == 0) then - FLAbort("Should never get here -- it has to intersect /something/!") - end if - end function brute_force_search - - function clueful_search(posA, possibles, bboxes_B, ele_A, neighbour) result(clues) - real, dimension(:, :), intent(in) :: posA - type(ilist), intent(in) :: possibles - real, dimension(:, :, :), intent(in) :: bboxes_B - integer, intent(in) :: ele_A, neighbour - type(inode), pointer :: node - type(ilist) :: clues - real, dimension(size(posA, 1), 2) :: bboxA - integer :: ele_B - - bboxA = bbox(posA) - - node => possibles%firstnode - do while (associated(node)) - ele_B = node%value - if (bbox_predicate(bboxA, bboxes_B(ele_B, :, :))) then - call insert(clues, ele_B) + subroutine compute_bboxes(positionsB, bboxes_B) + type(vector_field), intent(in) :: positionsB + real, dimension(:, :, :), intent(out) :: bboxes_B + integer :: ele_B + + do ele_B=1,ele_count(positionsB) + bboxes_B(ele_B, :, :) = bbox(ele_val(positionsB, ele_B)) + end do + end subroutine compute_bboxes + + function brute_force_search(posA, positionsB, bboxes_B) result(map) + real, dimension(:, :), intent(in) :: posA + type(vector_field), intent(in) :: positionsB + real, dimension(:, :, :), intent(in) :: bboxes_B + type(ilist) :: map + integer :: ele_B + real, dimension(size(posA, 1), 2) :: bboxA + + bboxA = bbox(posA) + + do ele_B=1,ele_count(positionsB) + if (bbox_predicate(bboxA, bboxes_B(ele_B, :, :))) then + call insert(map, ele_B) + end if + end do + + if (map%length == 0) then + FLAbort("Should never get here -- it has to intersect /something/!") end if - node => node%next - end do + end function brute_force_search + + function clueful_search(posA, possibles, bboxes_B, ele_A, neighbour) result(clues) + real, dimension(:, :), intent(in) :: posA + type(ilist), intent(in) :: possibles + real, dimension(:, :, :), intent(in) :: bboxes_B + integer, intent(in) :: ele_A, neighbour + type(inode), pointer :: node + type(ilist) :: clues + real, dimension(size(posA, 1), 2) :: bboxA + integer :: ele_B + + bboxA = bbox(posA) + + node => possibles%firstnode + do while (associated(node)) + ele_B = node%value + if (bbox_predicate(bboxA, bboxes_B(ele_B, :, :))) then + call insert(clues, ele_B) + end if + node => node%next + end do ! if (clues%length == 0) then ! ewrite(-1,*) "It seems something has gone rather badly wrong." @@ -846,7 +846,7 @@ function clueful_search(posA, possibles, bboxes_B, ele_A, neighbour) result(clue !! call deallocate(subpos) !! FLAbort("Should never get here -- it has to intersect /something/!") ! end if - end function clueful_search + end function clueful_search #endif end module diff --git a/femtools/Lagrangian_Remap.F90 b/femtools/Lagrangian_Remap.F90 index 4546b4f205..6f4d020ce2 100644 --- a/femtools/Lagrangian_Remap.F90 +++ b/femtools/Lagrangian_Remap.F90 @@ -1,135 +1,135 @@ module lagrangian_remap - use futils, only: int2str - use sparse_tools - use elements - use transform_elements, only: transform_to_physical - use fetools, only: shape_shape - use fields - use state_module - use vtk_interfaces - use interpolation_module - use sparse_matrices_fields - use solvers - use sparsity_patterns - use conservative_interpolation_module - - implicit none - - private - - public :: lagrangian_advection + use futils, only: int2str + use sparse_tools + use elements + use transform_elements, only: transform_to_physical + use fetools, only: shape_shape + use fields + use state_module + use vtk_interfaces + use interpolation_module + use sparse_matrices_fields + use solvers + use sparsity_patterns + use conservative_interpolation_module + + implicit none + + private + + public :: lagrangian_advection contains - subroutine lagrangian_advection(old_position, velocity, dt, & - old_fields, new_fields) - - type(vector_field), intent(in) :: old_position - type(vector_field), intent(in) :: velocity - real, intent(in) :: dt - type(scalar_field), dimension(:), intent(in), target :: old_fields - type(scalar_field), dimension(:), intent(inout) :: new_fields - - type(state_type) :: old_state, new_state - - type(vector_field) :: new_position, unadvected_velocity - integer :: i - integer :: subcycle_factor - type(element_type), pointer :: shape - type(mesh_type), pointer :: mesh - type(csr_matrix) :: mass_matrix_new, mass_matrix_old - type(csr_sparsity) :: sparsity - type(scalar_field), dimension(size(old_fields)) :: rhs, advected_fields - integer :: field_count, field, ele - real, dimension(ele_ngi(old_fields(1), 1)) :: detwei - real, dimension(ele_loc(old_fields(1), 1), ele_loc(old_fields(1), 1)) :: little_mass_matrix - - type(state_type), dimension(1) :: old_interpolation_state, new_interpolation_state - - call insert(old_state, old_position, "Coordinate") - call insert(old_state, velocity, "Velocity") - call insert(old_state, old_position%mesh, "Mesh") - - call allocate(new_position, old_position%dim, old_position%mesh, name="Coordinate") - call zero(new_position) - - call allocate(unadvected_velocity, velocity%dim, velocity%mesh, name="Velocity") - call zero(unadvected_velocity) - call insert(new_state, new_position, "Coordinate") - call insert(new_state, unadvected_velocity, "Velocity") - call insert(new_state, new_position%mesh, "Mesh") - - call addto(new_position, old_position) - subcycle_factor = 100 - do i=1,subcycle_factor - call linear_interpolation(old_state, new_state) - call addto(new_position, unadvected_velocity, dt/subcycle_factor) - end do + subroutine lagrangian_advection(old_position, velocity, dt, & + old_fields, new_fields) + + type(vector_field), intent(in) :: old_position + type(vector_field), intent(in) :: velocity + real, intent(in) :: dt + type(scalar_field), dimension(:), intent(in), target :: old_fields + type(scalar_field), dimension(:), intent(inout) :: new_fields + + type(state_type) :: old_state, new_state + + type(vector_field) :: new_position, unadvected_velocity + integer :: i + integer :: subcycle_factor + type(element_type), pointer :: shape + type(mesh_type), pointer :: mesh + type(csr_matrix) :: mass_matrix_new, mass_matrix_old + type(csr_sparsity) :: sparsity + type(scalar_field), dimension(size(old_fields)) :: rhs, advected_fields + integer :: field_count, field, ele + real, dimension(ele_ngi(old_fields(1), 1)) :: detwei + real, dimension(ele_loc(old_fields(1), 1), ele_loc(old_fields(1), 1)) :: little_mass_matrix + + type(state_type), dimension(1) :: old_interpolation_state, new_interpolation_state + + call insert(old_state, old_position, "Coordinate") + call insert(old_state, velocity, "Velocity") + call insert(old_state, old_position%mesh, "Mesh") + + call allocate(new_position, old_position%dim, old_position%mesh, name="Coordinate") + call zero(new_position) + + call allocate(unadvected_velocity, velocity%dim, velocity%mesh, name="Velocity") + call zero(unadvected_velocity) + call insert(new_state, new_position, "Coordinate") + call insert(new_state, unadvected_velocity, "Velocity") + call insert(new_state, new_position%mesh, "Mesh") + + call addto(new_position, old_position) + subcycle_factor = 100 + do i=1,subcycle_factor + call linear_interpolation(old_state, new_state) + call addto(new_position, unadvected_velocity, dt/subcycle_factor) + end do ! call addto(new_position, velocity, dt) - ! Now we solve the mass matrix equation to make it conservative, na ja? - mesh => old_fields(1)%mesh - field_count = size(old_fields) - shape => ele_shape(mesh, 1) + ! Now we solve the mass matrix equation to make it conservative, na ja? + mesh => old_fields(1)%mesh + field_count = size(old_fields) + shape => ele_shape(mesh, 1) - sparsity = make_sparsity(mesh, mesh, name="MassMatrixSparsity") - call allocate(mass_matrix_old, sparsity, name="OldMassMatrix") - call zero(mass_matrix_old) - call allocate(mass_matrix_new, sparsity, name="NewMassMatrix") - call zero(mass_matrix_new) - call deallocate(sparsity) + sparsity = make_sparsity(mesh, mesh, name="MassMatrixSparsity") + call allocate(mass_matrix_old, sparsity, name="OldMassMatrix") + call zero(mass_matrix_old) + call allocate(mass_matrix_new, sparsity, name="NewMassMatrix") + call zero(mass_matrix_new) + call deallocate(sparsity) - do ele=1,ele_count(mesh) - call transform_to_physical(old_position, ele, detwei=detwei) - little_mass_matrix = shape_shape(shape, shape, detwei) - call addto(mass_matrix_old, ele_nodes(old_position, ele), ele_nodes(old_position, ele), little_mass_matrix) + do ele=1,ele_count(mesh) + call transform_to_physical(old_position, ele, detwei=detwei) + little_mass_matrix = shape_shape(shape, shape, detwei) + call addto(mass_matrix_old, ele_nodes(old_position, ele), ele_nodes(old_position, ele), little_mass_matrix) - call transform_to_physical(new_position, ele, detwei=detwei) - little_mass_matrix = shape_shape(shape, shape, detwei) - call addto(mass_matrix_new, ele_nodes(new_position, ele), ele_nodes(new_position, ele), little_mass_matrix) - end do + call transform_to_physical(new_position, ele, detwei=detwei) + little_mass_matrix = shape_shape(shape, shape, detwei) + call addto(mass_matrix_new, ele_nodes(new_position, ele), ele_nodes(new_position, ele), little_mass_matrix) + end do - do field=1,field_count - call allocate(rhs(field), mesh, "Rhs" // int2str(field)) - call mult(rhs(field), mass_matrix_old, old_fields(field)) + do field=1,field_count + call allocate(rhs(field), mesh, "Rhs" // int2str(field)) + call mult(rhs(field), mass_matrix_old, old_fields(field)) - call allocate(advected_fields(field), mesh, "AdvectedField" // int2str(field)) - call set(advected_fields(field), old_fields(field)) - end do + call allocate(advected_fields(field), mesh, "AdvectedField" // int2str(field)) + call set(advected_fields(field), old_fields(field)) + end do - call deallocate(mass_matrix_old) + call deallocate(mass_matrix_old) - call petsc_solve(advected_fields, mass_matrix_new, rhs, option_path=trim(new_fields(1)%option_path) & - & // "/prognostic/lagrangian_remap") - call deallocate(mass_matrix_new) + call petsc_solve(advected_fields, mass_matrix_new, rhs, option_path=trim(new_fields(1)%option_path) & + & // "/prognostic/lagrangian_remap") + call deallocate(mass_matrix_new) - do field=1,field_count - call deallocate(rhs(field)) - end do + do field=1,field_count + call deallocate(rhs(field)) + end do - do field = 1, field_count - call insert(old_interpolation_state(1), advected_fields(field), name=trim(advected_fields(field)%name)) - call insert(new_interpolation_state(1), new_fields(field), name=trim(new_fields(field)%name)) - end do + do field = 1, field_count + call insert(old_interpolation_state(1), advected_fields(field), name=trim(advected_fields(field)%name)) + call insert(new_interpolation_state(1), new_fields(field), name=trim(new_fields(field)%name)) + end do - call interpolation_galerkin(old_interpolation_state, new_position, & - new_interpolation_state, old_position, & - force_bounded=.true.) + call interpolation_galerkin(old_interpolation_state, new_position, & + new_interpolation_state, old_position, & + force_bounded=.true.) - call deallocate(old_interpolation_state(1)) - call deallocate(new_interpolation_state(1)) + call deallocate(old_interpolation_state(1)) + call deallocate(new_interpolation_state(1)) - do field=1,field_count - call deallocate(advected_fields(field)) - end do + do field=1,field_count + call deallocate(advected_fields(field)) + end do - call deallocate(new_position) - call deallocate(unadvected_velocity) - call deallocate(new_state) - call deallocate(old_state) + call deallocate(new_position) + call deallocate(unadvected_velocity) + call deallocate(new_state) + call deallocate(old_state) - end subroutine lagrangian_advection + end subroutine lagrangian_advection end module lagrangian_remap diff --git a/femtools/Linked_Lists.F90 b/femtools/Linked_Lists.F90 index 942384d18f..f94cf24251 100644 --- a/femtools/Linked_Lists.F90 +++ b/femtools/Linked_Lists.F90 @@ -1,705 +1,705 @@ #include "fdebug.h" module linked_lists - ! A module to provide linked lists and operations on them. - use fldebug - implicit none - - ! Define a linked list for integers - TYPE inode - INTEGER :: value - TYPE (inode), POINTER :: next=>null() ! next node - END TYPE inode - - TYPE ilist - integer :: length=0 - TYPE (inode), POINTER :: firstnode=>null() - type(inode), pointer :: lastnode => null() - END TYPE ilist - - ! I need a linked list for edges in the mesh. - ! I'm adding it here. - - TYPE edgenode - INTEGER :: i, j - TYPE(edgenode), POINTER :: next => null() - END TYPE edgenode - - TYPE elist - INTEGER :: length = 0 - TYPE(edgenode), POINTER :: firstnode => null() - TYPE(edgenode), POINTER :: lastnode => null() - END TYPE elist - - ! I need a linked list for reals - ! I'm adding it here - sigh, templates anyone? - - type rnode - real :: value - type (rnode), pointer :: next=>null() ! next node - end type rnode - - type rlist - integer :: length=0 - type (rnode), pointer :: firstnode=>null() - type(rnode), pointer :: lastnode => null() - end type rlist - - interface insert_ascending - module procedure iinsert_ascending - end interface - - interface has_value - module procedure ihas_value, ehas_value - end interface - - interface deallocate - module procedure flush_ilist, flush_elist, flush_ilist_v, flush_rlist, flush_rlist_v - end interface - - interface insert - module procedure einsert, iinsert, rinsert - end interface - - interface flush_list - module procedure flush_ilist, flush_elist, flush_rlist - end interface - - interface flush_lists - module procedure flush_ilist_array - end interface flush_lists - - interface pop - module procedure ipop, epop_fn, rpop - end interface - - interface fetch - module procedure ifetch - end interface - - interface spop ! I need this to be a subroutine, not a function - module procedure epop - end interface - - interface list2vector - module procedure ilist2vector, rlist2vector - end interface - - interface pop_last - module procedure ipop_last - end interface - - interface size_intersection - module procedure isize_intersection - end interface - - interface has_value_sorted - module procedure ihas_value_sorted - end interface - - interface print_list - module procedure iprint, eprint - end interface - - interface intersect_ascending - module procedure intersect_ascending_ilist - end interface intersect_ascending - - interface copy - module procedure copy_ilist, copy_ilist_array - end interface - - interface maxval - module procedure list_maxval - end interface maxval - - private - public:: inode, ilist, edgenode, elist, rlist, insert_ascending,& - has_value, deallocate,& - insert, flush_list, flush_lists, pop, fetch, spop, list2vector,& - pop_last, size_intersection, has_value_sorted, print_list,& - intersect_ascending, copy, maxval + ! A module to provide linked lists and operations on them. + use fldebug + implicit none + + ! Define a linked list for integers + TYPE inode + INTEGER :: value + TYPE (inode), POINTER :: next=>null() ! next node + END TYPE inode + + TYPE ilist + integer :: length=0 + TYPE (inode), POINTER :: firstnode=>null() + type(inode), pointer :: lastnode => null() + END TYPE ilist + + ! I need a linked list for edges in the mesh. + ! I'm adding it here. + + TYPE edgenode + INTEGER :: i, j + TYPE(edgenode), POINTER :: next => null() + END TYPE edgenode + + TYPE elist + INTEGER :: length = 0 + TYPE(edgenode), POINTER :: firstnode => null() + TYPE(edgenode), POINTER :: lastnode => null() + END TYPE elist + + ! I need a linked list for reals + ! I'm adding it here - sigh, templates anyone? + + type rnode + real :: value + type (rnode), pointer :: next=>null() ! next node + end type rnode + + type rlist + integer :: length=0 + type (rnode), pointer :: firstnode=>null() + type(rnode), pointer :: lastnode => null() + end type rlist + + interface insert_ascending + module procedure iinsert_ascending + end interface + + interface has_value + module procedure ihas_value, ehas_value + end interface + + interface deallocate + module procedure flush_ilist, flush_elist, flush_ilist_v, flush_rlist, flush_rlist_v + end interface + + interface insert + module procedure einsert, iinsert, rinsert + end interface + + interface flush_list + module procedure flush_ilist, flush_elist, flush_rlist + end interface + + interface flush_lists + module procedure flush_ilist_array + end interface flush_lists + + interface pop + module procedure ipop, epop_fn, rpop + end interface + + interface fetch + module procedure ifetch + end interface + + interface spop ! I need this to be a subroutine, not a function + module procedure epop + end interface + + interface list2vector + module procedure ilist2vector, rlist2vector + end interface + + interface pop_last + module procedure ipop_last + end interface + + interface size_intersection + module procedure isize_intersection + end interface + + interface has_value_sorted + module procedure ihas_value_sorted + end interface + + interface print_list + module procedure iprint, eprint + end interface + + interface intersect_ascending + module procedure intersect_ascending_ilist + end interface intersect_ascending + + interface copy + module procedure copy_ilist, copy_ilist_array + end interface + + interface maxval + module procedure list_maxval + end interface maxval + + private + public:: inode, ilist, edgenode, elist, rlist, insert_ascending,& + has_value, deallocate,& + insert, flush_list, flush_lists, pop, fetch, spop, list2vector,& + pop_last, size_intersection, has_value_sorted, print_list,& + intersect_ascending, copy, maxval contains - integer function list_maxval(list) - type(ilist), intent(in) :: list - type(inode), pointer :: node - - node => list%firstnode - list_maxval = node%value - do while (associated(node)) - list_maxval = max(list_maxval, node%value) - node => node%next - end do - end function list_maxval + integer function list_maxval(list) + type(ilist), intent(in) :: list + type(inode), pointer :: node - logical function ihas_value(list, value) - ! Check if the list contains the value. - type(ilist), intent(in) :: list - integer, intent(in) :: value + node => list%firstnode + list_maxval = node%value + do while (associated(node)) + list_maxval = max(list_maxval, node%value) + node => node%next + end do + end function list_maxval - type(inode), pointer :: node + logical function ihas_value(list, value) + ! Check if the list contains the value. + type(ilist), intent(in) :: list + integer, intent(in) :: value - ihas_value = .false. + type(inode), pointer :: node - node => list%firstnode - do while (associated(node)) - if(value==node%value) then - ihas_value = .true. - return - end if - node => node%next - end do - end function ihas_value + ihas_value = .false. - subroutine iinsert_ascending(list, value, discard) - ! Insert value in list in such a position as to ensure that list remains - ! in ascending order. This assumes that list is in ascending order. - ! Duplicate values are discarded! - type(ilist), intent(inout) :: list - integer, intent(in) :: value + node => list%firstnode + do while (associated(node)) + if(value==node%value) then + ihas_value = .true. + return + end if + node => node%next + end do + end function ihas_value - logical, optional :: discard + subroutine iinsert_ascending(list, value, discard) + ! Insert value in list in such a position as to ensure that list remains + ! in ascending order. This assumes that list is in ascending order. + ! Duplicate values are discarded! + type(ilist), intent(inout) :: list + integer, intent(in) :: value - type(inode), pointer :: this_node, next_node - integer :: pos + logical, optional :: discard - ! Special case for zero length lists. - if (list%length==0) then - allocate(list%firstnode) + type(inode), pointer :: this_node, next_node + integer :: pos - list%firstnode%value=value - ! The following should not be necessary - list%firstnode%next=>null() + ! Special case for zero length lists. + if (list%length==0) then + allocate(list%firstnode) - list%length=1 - return - end if + list%firstnode%value=value + ! The following should not be necessary + list%firstnode%next=>null() - this_node=>list%firstnode - next_node=>list%firstnode%next + list%length=1 + return + end if - ! Special case for a value smaller than the first value. - if (valuelist%firstnode + next_node=>list%firstnode%next - list%firstnode%next=>this_node + ! Special case for a value smaller than the first value. + if (valuethis_node - list%length=list%length+1 - return - end if + list%firstnode%value=value - ! initialise discard logical - if (present(discard)) discard =.false. + list%length=list%length+1 + return + end if - do pos=0,list%length - if(this_node%value==value) then - ! Discard duplicates. - if (present(discard)) discard = .true. - return - end if + ! initialise discard logical + if (present(discard)) discard =.false. - if (.not.associated(next_node)) then - ! We have hit then end of the chain. - allocate(this_node%next) + do pos=0,list%length + if(this_node%value==value) then + ! Discard duplicates. + if (present(discard)) discard = .true. + return + end if - if (this_node%valuenull() + if (this_node%valuenull() - ! Mid-chain. At this point we know this_node%valuevalue) then - ! Need to insert the value here. - allocate(this_node%next) + list%length=list%length+1 + return + end if - this_node%next%next=>next_node + ! Mid-chain. At this point we know this_node%valuevalue) then + ! Need to insert the value here. + allocate(this_node%next) - this_node%next%value=value + this_node%next%next=>next_node - list%length=list%length+1 - return - end if + this_node%next%value=value - ! Move along the chain. - next_node=>next_node%next - this_node=>this_node%next + list%length=list%length+1 + return + end if - end do + ! Move along the chain. + next_node=>next_node%next + this_node=>this_node%next - FLAbort("Walked off the end of the list. This can't happen.") + end do - end subroutine iinsert_ascending + FLAbort("Walked off the end of the list. This can't happen.") - subroutine iinsert(list, i) - type(ilist), intent(inout) :: list - integer, intent(in) :: i - type(inode), pointer :: node + end subroutine iinsert_ascending - ! Special case for zero length lists. - if (list%length==0) then - allocate(list%firstnode) + subroutine iinsert(list, i) + type(ilist), intent(inout) :: list + integer, intent(in) :: i + type(inode), pointer :: node - list%firstnode%value=i - ! The following should not be necessary - list%firstnode%next=>null() + ! Special case for zero length lists. + if (list%length==0) then + allocate(list%firstnode) - list%length=1 - list%lastnode => list%firstnode - return - end if + list%firstnode%value=i + ! The following should not be necessary + list%firstnode%next=>null() - node => list%lastnode - allocate(node%next) - node%next%value = i + list%length=1 + list%lastnode => list%firstnode + return + end if - ! The following should not be necessary - node%next%next => null() + node => list%lastnode + allocate(node%next) + node%next%value = i - list%length = list%length+1 - list%lastnode => node%next - return - end subroutine iinsert + ! The following should not be necessary + node%next%next => null() - subroutine flush_ilist(list) - ! Remove all entries from a list. - type(ilist), intent(inout) ::list + list%length = list%length+1 + list%lastnode => node%next + return + end subroutine iinsert - integer :: i, tmp + subroutine flush_ilist(list) + ! Remove all entries from a list. + type(ilist), intent(inout) ::list - do i=1,list%length - tmp=pop(list) - end do + integer :: i, tmp - end subroutine flush_ilist + do i=1,list%length + tmp=pop(list) + end do - subroutine flush_ilist_v(lists) - type(ilist), intent(inout), dimension(:) :: lists - integer :: i + end subroutine flush_ilist - do i=1,size(lists) - call flush_ilist(lists(i)) - end do - end subroutine flush_ilist_v + subroutine flush_ilist_v(lists) + type(ilist), intent(inout), dimension(:) :: lists + integer :: i - subroutine flush_rlist_v(lists) - type(rlist), intent(inout), dimension(:) :: lists - integer :: i + do i=1,size(lists) + call flush_ilist(lists(i)) + end do + end subroutine flush_ilist_v - do i=1,size(lists) - call flush_rlist(lists(i)) - end do - end subroutine flush_rlist_v + subroutine flush_rlist_v(lists) + type(rlist), intent(inout), dimension(:) :: lists + integer :: i - subroutine flush_ilist_array(lists) - ! Remove all entries from an array of lists + do i=1,size(lists) + call flush_rlist(lists(i)) + end do + end subroutine flush_rlist_v - type(ilist), dimension(:), intent(inout) :: lists + subroutine flush_ilist_array(lists) + ! Remove all entries from an array of lists - integer :: i + type(ilist), dimension(:), intent(inout) :: lists - do i = 1, size(lists) - call flush_list(lists(i)) - end do + integer :: i - end subroutine flush_ilist_array + do i = 1, size(lists) + call flush_list(lists(i)) + end do - function ipop(list) - ! Pop the first value off list. - integer :: ipop - type(ilist), intent(inout) :: list + end subroutine flush_ilist_array - type(inode), pointer :: firstnode + function ipop(list) + ! Pop the first value off list. + integer :: ipop + type(ilist), intent(inout) :: list - ipop=list%firstnode%value + type(inode), pointer :: firstnode - firstnode=>list%firstnode + ipop=list%firstnode%value - list%firstnode=>firstnode%next + firstnode=>list%firstnode - deallocate(firstnode) + list%firstnode=>firstnode%next - list%length=list%length-1 + deallocate(firstnode) - end function ipop + list%length=list%length-1 - function ipop_last(list) - ! Pop the last value off list. - integer :: ipop_last - type(ilist), intent(inout) :: list + end function ipop - type(inode), pointer :: prev_node => null(), node - integer :: i + function ipop_last(list) + ! Pop the last value off list. + integer :: ipop_last + type(ilist), intent(inout) :: list - node => list%firstnode - do i=1,list%length-1 - prev_node => node - node => node%next - end do + type(inode), pointer :: prev_node => null(), node + integer :: i - ipop_last = node%value - deallocate(node) - prev_node%next => null() - list%length = list%length - 1 - end function ipop_last + node => list%firstnode + do i=1,list%length-1 + prev_node => node + node => node%next + end do - function ifetch(list, j) - integer :: ifetch - type(ilist), intent(inout) :: list - integer, intent(in) :: j + ipop_last = node%value + deallocate(node) + prev_node%next => null() + list%length = list%length - 1 + end function ipop_last - type(inode), pointer :: node - integer :: i + function ifetch(list, j) + integer :: ifetch + type(ilist), intent(inout) :: list + integer, intent(in) :: j - node => list%firstnode - do i=1,j-1 - node => node%next - end do + type(inode), pointer :: node + integer :: i - ifetch = node%value - end function ifetch + node => list%firstnode + do i=1,j-1 + node => node%next + end do - function ilist2vector(list) result (vector) - ! Return a vector containing the contents of ilist - type(ilist), intent(in) :: list - integer, dimension(list%length) :: vector + ifetch = node%value + end function ifetch - type(inode), pointer :: this_node - integer :: i + function ilist2vector(list) result (vector) + ! Return a vector containing the contents of ilist + type(ilist), intent(in) :: list + integer, dimension(list%length) :: vector - this_node=>list%firstnode + type(inode), pointer :: this_node + integer :: i - do i=1,list%length - vector(i)=this_node%value + this_node=>list%firstnode - this_node=>this_node%next - end do + do i=1,list%length + vector(i)=this_node%value - end function ilist2vector + this_node=>this_node%next + end do - subroutine einsert(list, i, j) - type(elist), intent(inout) :: list - integer, intent(in) :: i, j + end function ilist2vector - ! Special case for zero length lists. - if (list%length==0) then - allocate(list%firstnode) + subroutine einsert(list, i, j) + type(elist), intent(inout) :: list + integer, intent(in) :: i, j - list%firstnode%i=i - list%firstnode%j=j - ! The following should not be necessary - list%firstnode%next=>null() + ! Special case for zero length lists. + if (list%length==0) then + allocate(list%firstnode) - list%length=1 - list%lastnode=>list%firstnode - return - end if + list%firstnode%i=i + list%firstnode%j=j + ! The following should not be necessary + list%firstnode%next=>null() + list%length=1 + list%lastnode=>list%firstnode + return + end if - allocate(list%lastnode%next) - list%lastnode%next%i = i - list%lastnode%next%j = j - ! The following should not be necessary - list%lastnode%next%next => null() + allocate(list%lastnode%next) + list%lastnode%next%i = i + list%lastnode%next%j = j - list%length = list%length+1 - list%lastnode => list%lastnode%next - return + ! The following should not be necessary + list%lastnode%next%next => null() - end subroutine einsert + list%length = list%length+1 + list%lastnode => list%lastnode%next + return - logical function ehas_value(list, i, j) - type(elist), intent(inout) :: list - integer, intent(in) :: i, j - type(edgenode), pointer :: node + end subroutine einsert - ehas_value = .false. + logical function ehas_value(list, i, j) + type(elist), intent(inout) :: list + integer, intent(in) :: i, j + type(edgenode), pointer :: node - node => list%firstnode - do while(associated(node)) - if (node%i == i .and. node%j == j) then - ehas_value = .true. - return - end if - node => node%next - end do - end function ehas_value + ehas_value = .false. - subroutine flush_elist(list) - ! Remove all entries from a list. - type(elist), intent(inout) ::list + node => list%firstnode + do while(associated(node)) + if (node%i == i .and. node%j == j) then + ehas_value = .true. + return + end if + node => node%next + end do + end function ehas_value + + subroutine flush_elist(list) + ! Remove all entries from a list. + type(elist), intent(inout) ::list - integer :: i, tmp1, tmp2 + integer :: i, tmp1, tmp2 - do i=1,list%length - call spop(list, tmp1, tmp2) - end do + do i=1,list%length + call spop(list, tmp1, tmp2) + end do - end subroutine flush_elist + end subroutine flush_elist - subroutine epop(list, i, j) - ! Pop the first value off list. - integer, intent(out) :: i, j - type(elist), intent(inout) :: list + subroutine epop(list, i, j) + ! Pop the first value off list. + integer, intent(out) :: i, j + type(elist), intent(inout) :: list - type(edgenode), pointer :: firstnode + type(edgenode), pointer :: firstnode - i=list%firstnode%i - j=list%firstnode%j + i=list%firstnode%i + j=list%firstnode%j - firstnode=>list%firstnode + firstnode=>list%firstnode - list%firstnode=>firstnode%next + list%firstnode=>firstnode%next - deallocate(firstnode) + deallocate(firstnode) - list%length=list%length-1 - end subroutine epop + list%length=list%length-1 + end subroutine epop - function isize_intersection(listA, listB) result(x) - type(ilist), intent(in) :: listA, listB - type(inode), pointer :: nodeA, nodeB - integer :: x + function isize_intersection(listA, listB) result(x) + type(ilist), intent(in) :: listA, listB + type(inode), pointer :: nodeA, nodeB + integer :: x - x = 0 - nodeA => listA%firstnode - do while(associated(nodeA)) - nodeB => listB%firstnode - do while(associated(nodeB)) - if (nodeA%value == nodeB%value) then - x = x + 1 - exit - else - nodeB => nodeB%next - end if + x = 0 + nodeA => listA%firstnode + do while(associated(nodeA)) + nodeB => listB%firstnode + do while(associated(nodeB)) + if (nodeA%value == nodeB%value) then + x = x + 1 + exit + else + nodeB => nodeB%next + end if + end do + nodeA => nodeA%next end do - nodeA => nodeA%next - end do - end function isize_intersection - - function ihas_value_sorted(list, i) result(isin) - ! This function assumes list is sorted - ! in ascending order - type(ilist), intent(in) :: list - integer, intent(in) :: i - type(inode), pointer :: node - logical :: isin - - node => list%firstnode - isin = .false. - - do while(associated(node)) - if (node%value > i) then - return - else if (node%value == i) then - isin = .true. - return - end if - node => node%next - end do - end function ihas_value_sorted - - function epop_fn(list) result(x) - type(elist), intent(inout) :: list - integer, dimension(2) :: x - type(edgenode), pointer :: firstnode - - x(1) = list%firstnode%i - x(2) = list%firstnode%j - - firstnode => list%firstnode - list%firstnode => firstnode%next - deallocate(firstnode) - list%length = list%length - 1 - end function epop_fn - - subroutine iprint(list, priority) - type(ilist), intent(in) :: list - integer, intent(in) :: priority - type(inode), pointer :: node - - ewrite(priority, *) "length: ", list%length - - node => list%firstnode - do while (associated(node)) - ewrite(priority, *) " -- ", node%value - node => node%next - end do - end subroutine - - subroutine eprint(list, priority) - type(elist), intent(in) :: list - integer, intent(in) :: priority - type(edgenode), pointer :: node - - ewrite(priority, *) "length: ", list%length - - node => list%firstnode - do while (associated(node)) - ewrite(priority, *) " -- (", node%i, ", ", node%j, ")" - node => node%next - end do - end subroutine - - function intersect_ascending_ilist(list1, list2) result(intersection) - !!< Assumes that list1 and list2 are already sorted - type(ilist), intent(in) :: list1 - type(ilist), intent(in) :: list2 - - type(ilist) :: intersection - - type(inode), pointer :: node1 => null(), node2 => null() - - node1 => list1%firstnode - node2 => list2%firstnode - do while(associated(node1) .and. associated(node2)) - if(node1%value == node2%value) then - call insert_ascending(intersection, node1%value) - node1 => node1%next - node2 => node2%next - else - if(node1%value < node2%value) then - node1 => node1%next - else - node2 => node2%next - end if - end if - end do + end function isize_intersection + + function ihas_value_sorted(list, i) result(isin) + ! This function assumes list is sorted + ! in ascending order + type(ilist), intent(in) :: list + integer, intent(in) :: i + type(inode), pointer :: node + logical :: isin + + node => list%firstnode + isin = .false. + + do while(associated(node)) + if (node%value > i) then + return + else if (node%value == i) then + isin = .true. + return + end if + node => node%next + end do + end function ihas_value_sorted - end function intersect_ascending_ilist + function epop_fn(list) result(x) + type(elist), intent(inout) :: list + integer, dimension(2) :: x + type(edgenode), pointer :: firstnode - subroutine copy_ilist(copy_list, list) - !!< Make a deep copy of list - type(ilist), intent(out) :: copy_list - type(ilist), intent(in) :: list + x(1) = list%firstnode%i + x(2) = list%firstnode%j - type(inode), pointer :: node, copy_node + firstnode => list%firstnode + list%firstnode => firstnode%next + deallocate(firstnode) + list%length = list%length - 1 + end function epop_fn - if (list%length==0) return + subroutine iprint(list, priority) + type(ilist), intent(in) :: list + integer, intent(in) :: priority + type(inode), pointer :: node - ! Special case the first entry - node=>list%firstnode - allocate(copy_list%firstnode) - copy_list%firstnode%value=node%value - copy_node=>copy_list%firstnode - copy_list%length=1 - node=>node%next + ewrite(priority, *) "length: ", list%length - do while(associated(node)) - allocate(copy_node%next) - copy_node=>copy_node%next - copy_node%value=node%value + node => list%firstnode + do while (associated(node)) + ewrite(priority, *) " -- ", node%value + node => node%next + end do + end subroutine - copy_list%length=copy_list%length+1 + subroutine eprint(list, priority) + type(elist), intent(in) :: list + integer, intent(in) :: priority + type(edgenode), pointer :: node - node=>node%next - end do + ewrite(priority, *) "length: ", list%length + + node => list%firstnode + do while (associated(node)) + ewrite(priority, *) " -- (", node%i, ", ", node%j, ")" + node => node%next + end do + end subroutine + + function intersect_ascending_ilist(list1, list2) result(intersection) + !!< Assumes that list1 and list2 are already sorted + type(ilist), intent(in) :: list1 + type(ilist), intent(in) :: list2 + + type(ilist) :: intersection + + type(inode), pointer :: node1 => null(), node2 => null() + + node1 => list1%firstnode + node2 => list2%firstnode + do while(associated(node1) .and. associated(node2)) + if(node1%value == node2%value) then + call insert_ascending(intersection, node1%value) + node1 => node1%next + node2 => node2%next + else + if(node1%value < node2%value) then + node1 => node1%next + else + node2 => node2%next + end if + end if + end do - end subroutine copy_ilist + end function intersect_ascending_ilist - subroutine copy_ilist_array(copy_lists, lists) - !!< Make a deep copy of list - type(ilist), dimension(:), intent(in) :: lists - type(ilist), dimension(size(lists)), intent(out) :: copy_lists + subroutine copy_ilist(copy_list, list) + !!< Make a deep copy of list + type(ilist), intent(out) :: copy_list + type(ilist), intent(in) :: list - integer :: i + type(inode), pointer :: node, copy_node - do i=1,size(lists) - call copy_ilist(copy_lists(i), lists(i)) - end do + if (list%length==0) return - end subroutine copy_ilist_array + ! Special case the first entry + node=>list%firstnode + allocate(copy_list%firstnode) + copy_list%firstnode%value=node%value + copy_node=>copy_list%firstnode + copy_list%length=1 + node=>node%next - subroutine rinsert(list, value) - type(rlist), intent(inout) :: list - real, intent(in) :: value - type(rnode), pointer :: node + do while(associated(node)) + allocate(copy_node%next) + copy_node=>copy_node%next + copy_node%value=node%value - ! Special case for zero length lists. - if (list%length==0) then - allocate(list%firstnode) + copy_list%length=copy_list%length+1 - list%firstnode%value=value - ! The following should not be necessary - list%firstnode%next=>null() + node=>node%next + end do - list%length=1 - list%lastnode => list%firstnode - return - end if + end subroutine copy_ilist - node => list%lastnode - allocate(node%next) - node%next%value = value + subroutine copy_ilist_array(copy_lists, lists) + !!< Make a deep copy of list + type(ilist), dimension(:), intent(in) :: lists + type(ilist), dimension(size(lists)), intent(out) :: copy_lists - ! The following should not be necessary - node%next%next => null() + integer :: i - list%length = list%length+1 - list%lastnode => node%next + do i=1,size(lists) + call copy_ilist(copy_lists(i), lists(i)) + end do - end subroutine rinsert + end subroutine copy_ilist_array - subroutine flush_rlist(list) - ! Remove all entries from a list. - type(rlist), intent(inout) ::list + subroutine rinsert(list, value) + type(rlist), intent(inout) :: list + real, intent(in) :: value + type(rnode), pointer :: node - integer :: i, tmp + ! Special case for zero length lists. + if (list%length==0) then + allocate(list%firstnode) - do i=1,list%length - tmp=pop(list) - end do + list%firstnode%value=value + ! The following should not be necessary + list%firstnode%next=>null() - end subroutine flush_rlist + list%length=1 + list%lastnode => list%firstnode + return + end if - function rpop(list) - ! Pop the first value off list. - real :: rpop - type(rlist), intent(inout) :: list + node => list%lastnode + allocate(node%next) + node%next%value = value - type(rnode), pointer :: firstnode + ! The following should not be necessary + node%next%next => null() - rpop=list%firstnode%value + list%length = list%length+1 + list%lastnode => node%next - firstnode=>list%firstnode + end subroutine rinsert - list%firstnode=>firstnode%next + subroutine flush_rlist(list) + ! Remove all entries from a list. + type(rlist), intent(inout) ::list - deallocate(firstnode) + integer :: i, tmp - list%length=list%length-1 + do i=1,list%length + tmp=pop(list) + end do - end function rpop + end subroutine flush_rlist - function rlist2vector(list) result (vector) - ! Return a vector containing the contents of rlist - type(rlist), intent(in) :: list - real, dimension(list%length) :: vector + function rpop(list) + ! Pop the first value off list. + real :: rpop + type(rlist), intent(inout) :: list - type(rnode), pointer :: this_node - integer :: i + type(rnode), pointer :: firstnode - this_node=>list%firstnode + rpop=list%firstnode%value - do i=1, list%length - vector(i)=this_node%value + firstnode=>list%firstnode - this_node=>this_node%next - end do + list%firstnode=>firstnode%next + + deallocate(firstnode) + + list%length=list%length-1 + + end function rpop + + function rlist2vector(list) result (vector) + ! Return a vector containing the contents of rlist + type(rlist), intent(in) :: list + real, dimension(list%length) :: vector + + type(rnode), pointer :: this_node + integer :: i + + this_node=>list%firstnode + + do i=1, list%length + vector(i)=this_node%value + + this_node=>this_node%next + end do - end function rlist2vector + end function rlist2vector end module linked_lists diff --git a/femtools/MPI_Interfaces.F90 b/femtools/MPI_Interfaces.F90 index a3e5077c0c..1be2a799e1 100644 --- a/femtools/MPI_Interfaces.F90 +++ b/femtools/MPI_Interfaces.F90 @@ -28,226 +28,226 @@ #include "fdebug.h" module mpi_interfaces - !!< Interfaces for MPI routines + !!< Interfaces for MPI routines - implicit none + implicit none #ifdef HAVE_MPI - include "mpif.h" - - interface - subroutine mpi_barrier(communicator, ierr) - implicit none - integer, intent(in) :: communicator - integer, intent(out) :: ierr - end subroutine mpi_barrier - - subroutine mpi_comm_rank(communicator, rank, ierr) - implicit none - integer, intent(in) :: communicator - integer, intent(out) :: rank - integer, intent(out) :: ierr - end subroutine mpi_comm_rank - - subroutine mpi_comm_size(communicator, size, ierr) - implicit none - integer, intent(in) :: communicator - integer, intent(out) :: size - integer, intent(out) :: ierr - end subroutine mpi_comm_size - - subroutine mpi_comm_test_inter(communicator, inter_communicator, ierr) - implicit none - integer, intent(in) :: communicator - logical, intent(out) :: inter_communicator - integer, intent(out) :: ierr - end subroutine mpi_comm_test_inter - - subroutine mpi_finalize(ierr) - implicit none - integer, intent(out) :: ierr - end subroutine mpi_finalize - - subroutine mpi_init(ierr) - implicit none - integer, intent(out) :: ierr - end subroutine mpi_init - - subroutine mpi_initialized(initialized, ierr) - implicit none - logical, intent(out) :: initialized - integer, intent(out) :: ierr - end subroutine mpi_initialized - - subroutine mpi_iprobe(source, tag, communicator, result, status, ierr) - implicit none - include "mpif.h" - integer, intent(in) :: source - integer, intent(in) :: tag - integer, intent(in) :: communicator - integer, intent(out) :: result - integer, dimension(MPI_STATUS_SIZE), intent(out) :: status - integer, intent(out) :: ierr - end subroutine mpi_iprobe - - function mpi_tick() - use iso_c_binding, only: c_double - implicit none - real(kind = c_double) :: mpi_tick - end function mpi_tick - - subroutine mpi_type_commit(type, ierr) - implicit none - integer, intent(in) :: type - integer, intent(out) :: ierr - end subroutine mpi_type_commit - - subroutine mpi_type_indexed(displacements_size, entries_per_displacement, displacements, old_type, new_type, ierr) - implicit none - integer, intent(in) :: displacements_size - integer, dimension(displacements_size), intent(in) :: entries_per_displacement - integer, dimension(displacements_size), intent(in) :: displacements - integer, intent(in) :: old_type - integer, intent(out) :: new_type - integer, intent(out) :: ierr - end subroutine mpi_type_indexed - - subroutine mpi_type_free(type, ierr) - implicit none - integer, intent(in) :: type - integer, intent(out) :: ierr - end subroutine mpi_type_free - - subroutine mpi_type_vector(blocks, block_size, stride, old_type, new_type, ierr) - implicit none - integer, intent(in) :: blocks - integer, intent(in) :: block_size - integer, intent(in) :: stride - integer, intent(in) :: old_type - integer, intent(out) :: new_type - integer, intent(out) :: ierr - end subroutine mpi_type_vector - end interface - - external :: mpi_allreduce - !subroutine mpi_allreduce(send, receive, size, type, operation, communicator, ierr) - ! implicit none - ! integer, intent(in) :: size - ! (type), dimension(size), intent(in) :: send - ! (type), dimension(size), intent(out) :: receive - ! integer, intent(in) :: type - ! integer, intent(in) :: operation - ! integer, intent(in) :: communicator - ! integer, intent(out) :: ierr - !end subroutine mpi_allreduce - - external :: mpi_alltoall - !subroutine mpi_alltoall(send_buffer, send_buffer_size, send_type, receive_buffer, receive_buffer_size, receive_type, communicator, ierr) - ! implicit none - ! integer, intent(in) :: send_buffer_size - ! integer, intent(in) :: receive_buffer_size - ! (send_type), dimension(send_buffer_size), intent(in) :: send_buffer - ! integer, intent(in) :: send_type - ! (receive_type), dimension(receive_buffer_size), intent(out) :: receive_buffer - ! integer, intent(in) :: receive_type - ! integer, intent(in) :: communicator - ! integer, intent(out) :: ierr - !end subroutine mpi_alltoall - - external :: mpi_bcast - !subroutine mpi_bcast(buffer, buffer_size, type, source, communicator, ierr) - ! implicit none - ! integer, intent(in) :: buffer_size - ! (type), dimension(buffer_size), intent(inout) :: buffer - ! integer, intent(in) :: type - ! integer, intent(in) :: source - ! integer, intent(in) :: communicator - ! integer, intent(out) :: ierr - !end subroutine mpi_bcast - - external :: mpi_gather - !subroutine mpi_gather(send_buffer, send_buffer_size, send_type, receive_buffer, receive_buffer_size, receive_type, source, communicator, ierr) - ! implicit none - ! integer, intent(in) :: send_buffer_size - ! (send_type), dimension(send_buffer_size), intent(in) :: send_buffer - ! integer, intent(in) :: send_type - ! (receive_type), dimension(*), intent(out) :: receive_buffer - ! integer, intent(in) :: receive_buffer_size - ! integer, intent(in) :: receive_type - ! integer, intent(in) :: source - ! integer, intent(in) :: communicator - ! integer, intent(out) :: ierr - !end subroutine mpi_gather - - external :: mpi_allgather - - external :: mpi_irecv - !subroutine mpi_irecv(buffer, buffer_size, type, source, tag, communicator, request, ierr) - ! implicit none - ! integer, intent(in) :: buffer_size - ! (type), dimension(buffer_size), intent(out) :: buffer - ! integer, intent(in) :: type - ! integer, intent(in) :: source - ! integer, intent(in) :: tag - ! integer, intent(in) :: communicator - ! integer, intent(out) :: request - ! integer, intent(out) :: ierr - !end subroutine mpi_irecv - - external :: mpi_isend - !subroutine mpi_isend(buffer, buffer_size, type, destination, tag, communicator, request, ierr) - ! implicit none - ! integer, intent(in) :: buffer_size - ! (type), dimension(buffer_size), intent(out) :: buffer - ! integer, intent(in) :: type - ! integer, intent(in) :: destination - ! integer, intent(in) :: tag - ! integer, intent(in) :: communicator - ! integer, intent(out) :: request - ! integer, intent(out) :: ierr - !end subroutine mpi_isend - - external :: mpi_scan - !subroutine mpi_scan(send_buffer, receive_buffer, send_buffer_size, type, operation, communicator, ierr) - ! implicit none - ! integer, intent(in) :: send_buffer_size - ! (type), dimension(send_buffer_size), intent(in) :: send_buffer - ! (type), intent(out) :: receive_buffer - ! integer, intent(in) :: type - ! integer, intent(in) :: operation - ! integer, intent(in) :: communicator - ! integer, intent(out) :: ierr - !end subroutine mpi_scan - - external :: mpi_waitall - !subroutine mpi_waitall(requests_size, requests, statuses, ierr) - ! implicit none - ! include "mpif.h" - ! integer, intent(in) :: requests_size - ! integer, dimension(requests_size), intent(inout) :: requests - ! integer, dimension(requests_size * MPI_STATUS_SIZE), intent(out) :: statuses - ! integer, intent(out) :: ierr - !end subroutine mpi_waitall - - ! It seems that mpif.h can declare this external - !external :: mpi_wtime - !function mpi_wtime - ! implicit none - ! real :: mpi_wtime - !end function mpi_wtime + include "mpif.h" + + interface + subroutine mpi_barrier(communicator, ierr) + implicit none + integer, intent(in) :: communicator + integer, intent(out) :: ierr + end subroutine mpi_barrier + + subroutine mpi_comm_rank(communicator, rank, ierr) + implicit none + integer, intent(in) :: communicator + integer, intent(out) :: rank + integer, intent(out) :: ierr + end subroutine mpi_comm_rank + + subroutine mpi_comm_size(communicator, size, ierr) + implicit none + integer, intent(in) :: communicator + integer, intent(out) :: size + integer, intent(out) :: ierr + end subroutine mpi_comm_size + + subroutine mpi_comm_test_inter(communicator, inter_communicator, ierr) + implicit none + integer, intent(in) :: communicator + logical, intent(out) :: inter_communicator + integer, intent(out) :: ierr + end subroutine mpi_comm_test_inter + + subroutine mpi_finalize(ierr) + implicit none + integer, intent(out) :: ierr + end subroutine mpi_finalize + + subroutine mpi_init(ierr) + implicit none + integer, intent(out) :: ierr + end subroutine mpi_init + + subroutine mpi_initialized(initialized, ierr) + implicit none + logical, intent(out) :: initialized + integer, intent(out) :: ierr + end subroutine mpi_initialized + + subroutine mpi_iprobe(source, tag, communicator, result, status, ierr) + implicit none + include "mpif.h" + integer, intent(in) :: source + integer, intent(in) :: tag + integer, intent(in) :: communicator + integer, intent(out) :: result + integer, dimension(MPI_STATUS_SIZE), intent(out) :: status + integer, intent(out) :: ierr + end subroutine mpi_iprobe + + function mpi_tick() + use iso_c_binding, only: c_double + implicit none + real(kind = c_double) :: mpi_tick + end function mpi_tick + + subroutine mpi_type_commit(type, ierr) + implicit none + integer, intent(in) :: type + integer, intent(out) :: ierr + end subroutine mpi_type_commit + + subroutine mpi_type_indexed(displacements_size, entries_per_displacement, displacements, old_type, new_type, ierr) + implicit none + integer, intent(in) :: displacements_size + integer, dimension(displacements_size), intent(in) :: entries_per_displacement + integer, dimension(displacements_size), intent(in) :: displacements + integer, intent(in) :: old_type + integer, intent(out) :: new_type + integer, intent(out) :: ierr + end subroutine mpi_type_indexed + + subroutine mpi_type_free(type, ierr) + implicit none + integer, intent(in) :: type + integer, intent(out) :: ierr + end subroutine mpi_type_free + + subroutine mpi_type_vector(blocks, block_size, stride, old_type, new_type, ierr) + implicit none + integer, intent(in) :: blocks + integer, intent(in) :: block_size + integer, intent(in) :: stride + integer, intent(in) :: old_type + integer, intent(out) :: new_type + integer, intent(out) :: ierr + end subroutine mpi_type_vector + end interface + + external :: mpi_allreduce + !subroutine mpi_allreduce(send, receive, size, type, operation, communicator, ierr) + ! implicit none + ! integer, intent(in) :: size + ! (type), dimension(size), intent(in) :: send + ! (type), dimension(size), intent(out) :: receive + ! integer, intent(in) :: type + ! integer, intent(in) :: operation + ! integer, intent(in) :: communicator + ! integer, intent(out) :: ierr + !end subroutine mpi_allreduce + + external :: mpi_alltoall + !subroutine mpi_alltoall(send_buffer, send_buffer_size, send_type, receive_buffer, receive_buffer_size, receive_type, communicator, ierr) + ! implicit none + ! integer, intent(in) :: send_buffer_size + ! integer, intent(in) :: receive_buffer_size + ! (send_type), dimension(send_buffer_size), intent(in) :: send_buffer + ! integer, intent(in) :: send_type + ! (receive_type), dimension(receive_buffer_size), intent(out) :: receive_buffer + ! integer, intent(in) :: receive_type + ! integer, intent(in) :: communicator + ! integer, intent(out) :: ierr + !end subroutine mpi_alltoall + + external :: mpi_bcast + !subroutine mpi_bcast(buffer, buffer_size, type, source, communicator, ierr) + ! implicit none + ! integer, intent(in) :: buffer_size + ! (type), dimension(buffer_size), intent(inout) :: buffer + ! integer, intent(in) :: type + ! integer, intent(in) :: source + ! integer, intent(in) :: communicator + ! integer, intent(out) :: ierr + !end subroutine mpi_bcast + + external :: mpi_gather + !subroutine mpi_gather(send_buffer, send_buffer_size, send_type, receive_buffer, receive_buffer_size, receive_type, source, communicator, ierr) + ! implicit none + ! integer, intent(in) :: send_buffer_size + ! (send_type), dimension(send_buffer_size), intent(in) :: send_buffer + ! integer, intent(in) :: send_type + ! (receive_type), dimension(*), intent(out) :: receive_buffer + ! integer, intent(in) :: receive_buffer_size + ! integer, intent(in) :: receive_type + ! integer, intent(in) :: source + ! integer, intent(in) :: communicator + ! integer, intent(out) :: ierr + !end subroutine mpi_gather + + external :: mpi_allgather + + external :: mpi_irecv + !subroutine mpi_irecv(buffer, buffer_size, type, source, tag, communicator, request, ierr) + ! implicit none + ! integer, intent(in) :: buffer_size + ! (type), dimension(buffer_size), intent(out) :: buffer + ! integer, intent(in) :: type + ! integer, intent(in) :: source + ! integer, intent(in) :: tag + ! integer, intent(in) :: communicator + ! integer, intent(out) :: request + ! integer, intent(out) :: ierr + !end subroutine mpi_irecv + + external :: mpi_isend + !subroutine mpi_isend(buffer, buffer_size, type, destination, tag, communicator, request, ierr) + ! implicit none + ! integer, intent(in) :: buffer_size + ! (type), dimension(buffer_size), intent(out) :: buffer + ! integer, intent(in) :: type + ! integer, intent(in) :: destination + ! integer, intent(in) :: tag + ! integer, intent(in) :: communicator + ! integer, intent(out) :: request + ! integer, intent(out) :: ierr + !end subroutine mpi_isend + + external :: mpi_scan + !subroutine mpi_scan(send_buffer, receive_buffer, send_buffer_size, type, operation, communicator, ierr) + ! implicit none + ! integer, intent(in) :: send_buffer_size + ! (type), dimension(send_buffer_size), intent(in) :: send_buffer + ! (type), intent(out) :: receive_buffer + ! integer, intent(in) :: type + ! integer, intent(in) :: operation + ! integer, intent(in) :: communicator + ! integer, intent(out) :: ierr + !end subroutine mpi_scan + + external :: mpi_waitall + !subroutine mpi_waitall(requests_size, requests, statuses, ierr) + ! implicit none + ! include "mpif.h" + ! integer, intent(in) :: requests_size + ! integer, dimension(requests_size), intent(inout) :: requests + ! integer, dimension(requests_size * MPI_STATUS_SIZE), intent(out) :: statuses + ! integer, intent(out) :: ierr + !end subroutine mpi_waitall + + ! It seems that mpif.h can declare this external + !external :: mpi_wtime + !function mpi_wtime + ! implicit none + ! real :: mpi_wtime + !end function mpi_wtime #ifdef HAVE_MPI2 - interface - subroutine mpi_type_create_indexed_block(displacements_size, entries_per_displacement, displacements, old_type, new_type, ierr) - implicit none - integer, intent(in) :: displacements_size - integer, intent(in) :: entries_per_displacement - integer, dimension(displacements_size), intent(in) :: displacements - integer, intent(in) :: old_type - integer, intent(out) :: new_type - integer, intent(out) :: ierr - end subroutine mpi_type_create_indexed_block - end interface + interface + subroutine mpi_type_create_indexed_block(displacements_size, entries_per_displacement, displacements, old_type, new_type, ierr) + implicit none + integer, intent(in) :: displacements_size + integer, intent(in) :: entries_per_displacement + integer, dimension(displacements_size), intent(in) :: displacements + integer, intent(in) :: old_type + integer, intent(out) :: new_type + integer, intent(out) :: ierr + end subroutine mpi_type_create_indexed_block + end interface #endif ! Note: Make sure the contains statement is only seen if the contains part is @@ -255,20 +255,20 @@ end subroutine mpi_type_create_indexed_block #ifndef HAVE_MPI2 contains - subroutine mpi_type_create_indexed_block(displacements_size, & - & entries_per_displacement, displacements, old_type, new_type, ierr) - integer, intent(in) :: displacements_size - integer, intent(in) :: entries_per_displacement - integer, dimension(displacements_size), intent(in) :: displacements - integer, intent(in) :: old_type - integer, intent(out) :: new_type - integer, intent(out) :: ierr + subroutine mpi_type_create_indexed_block(displacements_size, & + & entries_per_displacement, displacements, old_type, new_type, ierr) + integer, intent(in) :: displacements_size + integer, intent(in) :: entries_per_displacement + integer, dimension(displacements_size), intent(in) :: displacements + integer, intent(in) :: old_type + integer, intent(out) :: new_type + integer, intent(out) :: ierr - call mpi_type_indexed(displacements_size, & + call mpi_type_indexed(displacements_size, & & spread(entries_per_displacement, 1, displacements_size), & & displacements, old_type, new_type, ierr) - end subroutine mpi_type_create_indexed_block + end subroutine mpi_type_create_indexed_block #endif #endif diff --git a/femtools/Matrix_Norms.F90 b/femtools/Matrix_Norms.F90 index 580c85357f..a26f184ca4 100644 --- a/femtools/Matrix_Norms.F90 +++ b/femtools/Matrix_Norms.F90 @@ -2,131 +2,131 @@ module matrix_norms - use fldebug - use vector_tools - use fields - use node_boundary - implicit none + use fldebug + use vector_tools + use fields + use node_boundary + implicit none - interface one_norm - module procedure one_norm_matrix, one_norm_field - end interface + interface one_norm + module procedure one_norm_matrix, one_norm_field + end interface - interface two_norm - module procedure two_norm_matrix, two_norm_field - end interface + interface two_norm + module procedure two_norm_matrix, two_norm_field + end interface - interface inf_norm - module procedure inf_norm_matrix, inf_norm_field - end interface + interface inf_norm + module procedure inf_norm_matrix, inf_norm_field + end interface - private + private - public :: one_norm, two_norm, inf_norm + public :: one_norm, two_norm, inf_norm - contains +contains - function one_norm_matrix(matrix) result(one) - real, dimension(:, :), intent(in) :: matrix - real :: one - integer :: j + function one_norm_matrix(matrix) result(one) + real, dimension(:, :), intent(in) :: matrix + real :: one + integer :: j - one = 0.0 + one = 0.0 - do j=1,size(matrix, 2) - one = max(one, sum(abs(matrix(:, j)))) - end do - end function one_norm_matrix + do j=1,size(matrix, 2) + one = max(one, sum(abs(matrix(:, j)))) + end do + end function one_norm_matrix - function one_norm_field(field, boundary) result(one) - type(tensor_field), intent(in) :: field - logical, intent(in), optional :: boundary - real :: one - integer :: node - logical :: lboundary + function one_norm_field(field, boundary) result(one) + type(tensor_field), intent(in) :: field + logical, intent(in), optional :: boundary + real :: one + integer :: node + logical :: lboundary - one = 0.0 + one = 0.0 - lboundary = .false. - if (present(boundary)) then - lboundary = boundary - end if - - do node=1,node_count(field) - if (lboundary .and. .not. node_lies_on_boundary(node)) then - cycle + lboundary = .false. + if (present(boundary)) then + lboundary = boundary end if - one = one + one_norm_matrix(node_val(field, node)) - end do - one = one / node_count(field) - end function one_norm_field - - function two_norm_matrix(matrix) result(two) - real, dimension(:, :), intent(in) :: matrix - real :: two - real, dimension(size(matrix, 1), size(matrix, 1)) :: evecs - real, dimension(size(matrix, 1)) :: evals - - assert(size(matrix, 1) == size(matrix, 2)) - call eigendecomposition_symmetric(matmul(transpose(matrix), matrix), evecs, evals) - two = sqrt(maxval(evals)) - end function two_norm_matrix - - function two_norm_field(field, boundary) result(two) - type(tensor_field), intent(in) :: field - logical, intent(in), optional :: boundary - real :: two - integer :: node - logical :: lboundary - - two = 0.0 - - lboundary = .false. - if (present(boundary)) then - lboundary = boundary - end if - - do node=1,node_count(field) - if (lboundary .and. .not. node_lies_on_boundary(node)) then - cycle + + do node=1,node_count(field) + if (lboundary .and. .not. node_lies_on_boundary(node)) then + cycle + end if + one = one + one_norm_matrix(node_val(field, node)) + end do + one = one / node_count(field) + end function one_norm_field + + function two_norm_matrix(matrix) result(two) + real, dimension(:, :), intent(in) :: matrix + real :: two + real, dimension(size(matrix, 1), size(matrix, 1)) :: evecs + real, dimension(size(matrix, 1)) :: evals + + assert(size(matrix, 1) == size(matrix, 2)) + call eigendecomposition_symmetric(matmul(transpose(matrix), matrix), evecs, evals) + two = sqrt(maxval(evals)) + end function two_norm_matrix + + function two_norm_field(field, boundary) result(two) + type(tensor_field), intent(in) :: field + logical, intent(in), optional :: boundary + real :: two + integer :: node + logical :: lboundary + + two = 0.0 + + lboundary = .false. + if (present(boundary)) then + lboundary = boundary end if - two = two + two_norm_matrix(node_val(field, node))**2 - end do - two = two / node_count(field) - two = sqrt(two) - end function two_norm_field - - function inf_norm_matrix(matrix) result(inf) - real, dimension(:, :), intent(in) :: matrix - real :: inf - integer :: i - - inf = 0.0 - - do i=1,size(matrix, 1) - inf = max(inf, sum(abs(matrix(i, :)))) - end do - end function inf_norm_matrix - - function inf_norm_field(field, boundary) result(inf) - type(tensor_field), intent(in) :: field - logical, intent(in), optional :: boundary - real :: inf - integer :: node - logical :: lboundary - - inf = 0.0 - - lboundary = .false. - if (present(boundary)) then - lboundary = boundary - end if - - do node=1,node_count(field) - if (lboundary .and. .not. node_lies_on_boundary(node)) then - cycle + + do node=1,node_count(field) + if (lboundary .and. .not. node_lies_on_boundary(node)) then + cycle + end if + two = two + two_norm_matrix(node_val(field, node))**2 + end do + two = two / node_count(field) + two = sqrt(two) + end function two_norm_field + + function inf_norm_matrix(matrix) result(inf) + real, dimension(:, :), intent(in) :: matrix + real :: inf + integer :: i + + inf = 0.0 + + do i=1,size(matrix, 1) + inf = max(inf, sum(abs(matrix(i, :)))) + end do + end function inf_norm_matrix + + function inf_norm_field(field, boundary) result(inf) + type(tensor_field), intent(in) :: field + logical, intent(in), optional :: boundary + real :: inf + integer :: node + logical :: lboundary + + inf = 0.0 + + lboundary = .false. + if (present(boundary)) then + lboundary = boundary end if - inf = max(inf, inf_norm_matrix(node_val(field, node))) - end do - end function inf_norm_field + + do node=1,node_count(field) + if (lboundary .and. .not. node_lies_on_boundary(node)) then + cycle + end if + inf = max(inf, inf_norm_matrix(node_val(field, node))) + end do + end function inf_norm_field end module matrix_norms diff --git a/femtools/Memory_Diagnostics.F90 b/femtools/Memory_Diagnostics.F90 index 1899d8a552..b80d8861ff 100644 --- a/femtools/Memory_Diagnostics.F90 +++ b/femtools/Memory_Diagnostics.F90 @@ -27,290 +27,290 @@ #include "fdebug.h" module memory_diagnostics - use fldebug - use global_parameters, only : integer_size, real_size - use spud - use parallel_tools - implicit none - - private - - type memory_log - !!< Current memory usage, and minimum and maximum since last reset. - !! - !! This is a sequence type to facilitate feeding it to mpi. - sequence - !! We use reals here to prevent overflows at 2G. - real :: min=0, max=0, current=0 - end type memory_log - - ! This is the total number of bins we sort memory types into. - integer, parameter :: MEMORY_TYPES=7 - ! This is the number of statistics we store for each memory type. - integer, parameter :: MEMORY_STATS=3 - - integer, parameter :: MESH_TYPE=1, & - SCALAR_FIELD=2, & - VECTOR_FIELD=3, & - TENSOR_FIELD=4, & - CSR_SPARSITY=5, & - CSR_MATRIX=6, & - TRANSFORM_CACHE=7 - - character(len=20), dimension(0:MEMORY_TYPES) :: memory_type_names= (/ & - "TotalMemory ", & - "MeshMemory ", & - "ScalarFieldMemory ", & - "VectorFieldMemory ", & - "TensorFieldMemory ", & - "MatrixSparsityMemory", & - "MatrixMemory ", & - "TransformCacheMemory" & - /) - - character(len=7), dimension(MEMORY_STATS) :: memory_stat_names = (/ & - "current", & - "min ", & - "max " & - /) - - ! This vector should have as many entries as the types of data we track above. - type(memory_log), dimension(0:MEMORY_TYPES), target, save :: memory_usage - - ! whether to write to the log for each (de)allocate: - logical :: log_allocates + use fldebug + use global_parameters, only : integer_size, real_size + use spud + use parallel_tools + implicit none + + private + + type memory_log + !!< Current memory usage, and minimum and maximum since last reset. + !! + !! This is a sequence type to facilitate feeding it to mpi. + sequence + !! We use reals here to prevent overflows at 2G. + real :: min=0, max=0, current=0 + end type memory_log + + ! This is the total number of bins we sort memory types into. + integer, parameter :: MEMORY_TYPES=7 + ! This is the number of statistics we store for each memory type. + integer, parameter :: MEMORY_STATS=3 + + integer, parameter :: MESH_TYPE=1, & + SCALAR_FIELD=2, & + VECTOR_FIELD=3, & + TENSOR_FIELD=4, & + CSR_SPARSITY=5, & + CSR_MATRIX=6, & + TRANSFORM_CACHE=7 + + character(len=20), dimension(0:MEMORY_TYPES) :: memory_type_names= (/ & + "TotalMemory ", & + "MeshMemory ", & + "ScalarFieldMemory ", & + "VectorFieldMemory ", & + "TensorFieldMemory ", & + "MatrixSparsityMemory", & + "MatrixMemory ", & + "TransformCacheMemory" & + /) + + character(len=7), dimension(MEMORY_STATS) :: memory_stat_names = (/ & + "current", & + "min ", & + "max " & + /) + + ! This vector should have as many entries as the types of data we track above. + type(memory_log), dimension(0:MEMORY_TYPES), target, save :: memory_usage + + ! whether to write to the log for each (de)allocate: + logical :: log_allocates #ifdef HAVE_MEMORY_STATS - public :: memory_log, memory_type_names, MEMORY_TYPES, memory_stat_names,& - & memory_usage, register_allocation, register_deallocation,& - & register_temporary_memory, reset_memory_logs, write_memory_stats, & - & print_current_memory_stats, print_memory_stats + public :: memory_log, memory_type_names, MEMORY_TYPES, memory_stat_names,& + & memory_usage, register_allocation, register_deallocation,& + & register_temporary_memory, reset_memory_logs, write_memory_stats, & + & print_current_memory_stats, print_memory_stats #endif contains - subroutine register_allocation(object_type, data_type, size, name) - !!< Register the allocation of a new object. - !!< - !!< We sort the object data on the basis of the object_type while the - !!< data_type and the size tell us how much memory has been allocated. - character(len=*), intent(in) :: object_type, data_type - integer, intent(in) :: size - character(len=*), intent(in), optional :: name - - integer :: data_size - type(memory_log), pointer :: this_log - - select case(data_type) - case("real") - data_size=real_size - case("integer") - data_size=integer_size - case default - FLAbort(trim(data_type)//" is not a supported data type.") - end select - - select case(object_type) - case("mesh_type") - this_log=>memory_usage(MESH_TYPE) - case("scalar_field") - this_log=>memory_usage(SCALAR_FIELD) - case("vector_field") - this_log=>memory_usage(VECTOR_FIELD) - case("tensor_field") - this_log=>memory_usage(TENSOR_FIELD) - case("csr_sparsity") - this_log=>memory_usage(CSR_SPARSITY) - case("csr_matrix") - this_log=>memory_usage(CSR_MATRIX) - case("transform_cache") - this_log=>memory_usage(TRANSFORM_CACHE) - case default - FLAbort(trim(data_type)//" is not a supported object type.") - end select - - if (log_allocates) then - if (present(name)) then - ewrite(2,*) "Allocating ",size*data_size," bytes of ",trim(object_type)& - &, ", name ",trim(name) - else - ewrite(2,*) "Allocating ",size*data_size," bytes of ",trim(object_type) + subroutine register_allocation(object_type, data_type, size, name) + !!< Register the allocation of a new object. + !!< + !!< We sort the object data on the basis of the object_type while the + !!< data_type and the size tell us how much memory has been allocated. + character(len=*), intent(in) :: object_type, data_type + integer, intent(in) :: size + character(len=*), intent(in), optional :: name + + integer :: data_size + type(memory_log), pointer :: this_log + + select case(data_type) + case("real") + data_size=real_size + case("integer") + data_size=integer_size + case default + FLAbort(trim(data_type)//" is not a supported data type.") + end select + + select case(object_type) + case("mesh_type") + this_log=>memory_usage(MESH_TYPE) + case("scalar_field") + this_log=>memory_usage(SCALAR_FIELD) + case("vector_field") + this_log=>memory_usage(VECTOR_FIELD) + case("tensor_field") + this_log=>memory_usage(TENSOR_FIELD) + case("csr_sparsity") + this_log=>memory_usage(CSR_SPARSITY) + case("csr_matrix") + this_log=>memory_usage(CSR_MATRIX) + case("transform_cache") + this_log=>memory_usage(TRANSFORM_CACHE) + case default + FLAbort(trim(data_type)//" is not a supported object type.") + end select + + if (log_allocates) then + if (present(name)) then + ewrite(2,*) "Allocating ",size*data_size," bytes of ",trim(object_type)& + &, ", name ",trim(name) + else + ewrite(2,*) "Allocating ",size*data_size," bytes of ",trim(object_type) + end if end if - end if - - this_log%current=this_log%current + size*data_size - - this_log%max=max(this_log%max, this_log%current) - this_log%min=min(this_log%min, this_log%current) - - ! Also account for total memory. - memory_usage(0)%current=memory_usage(0)%current + size*data_size - - memory_usage(0)%max=max(memory_usage(0)%max, memory_usage(0)%current) - memory_usage(0)%min=min(memory_usage(0)%min, memory_usage(0)%current) - - end subroutine register_allocation - - subroutine register_deallocation(object_type, data_type, size, name) - !!< Register the deallocation of a new object. - !!< - !!< We sort the object data on the basis of the object_type while the - !!< data_type and the size tell us how much memory has been allocated. - character(len=*), intent(in) :: object_type, data_type - integer, intent(in) :: size - character(len=*), intent(in), optional :: name - - integer :: data_size - type(memory_log), pointer :: this_log - - select case(data_type) - case("real") - data_size=real_size - case("integer") - data_size=integer_size - case default - FLAbort(trim(data_type)//" is not a supported data type.") - end select - - select case(object_type) - case("mesh_type") - this_log=>memory_usage(MESH_TYPE) - case("scalar_field") - this_log=>memory_usage(SCALAR_FIELD) - case("vector_field") - this_log=>memory_usage(VECTOR_FIELD) - case("tensor_field") - this_log=>memory_usage(TENSOR_FIELD) - case("csr_sparsity") - this_log=>memory_usage(CSR_SPARSITY) - case("csr_matrix") - this_log=>memory_usage(CSR_MATRIX) - case("transform_cache") - this_log=>memory_usage(TRANSFORM_CACHE) - case default - FLAbort(trim(data_type)//" is not a supported object type.") - end select - - if (log_allocates) then - if (present(name)) then - ewrite(2,*) "Deallocating ",size*data_size," bytes of ",trim(object_type)& - &, ", name ",trim(name) - else - ewrite(2,*) "Deallocating ",size*data_size," bytes of ",trim(object_type) + + this_log%current=this_log%current + size*data_size + + this_log%max=max(this_log%max, this_log%current) + this_log%min=min(this_log%min, this_log%current) + + ! Also account for total memory. + memory_usage(0)%current=memory_usage(0)%current + size*data_size + + memory_usage(0)%max=max(memory_usage(0)%max, memory_usage(0)%current) + memory_usage(0)%min=min(memory_usage(0)%min, memory_usage(0)%current) + + end subroutine register_allocation + + subroutine register_deallocation(object_type, data_type, size, name) + !!< Register the deallocation of a new object. + !!< + !!< We sort the object data on the basis of the object_type while the + !!< data_type and the size tell us how much memory has been allocated. + character(len=*), intent(in) :: object_type, data_type + integer, intent(in) :: size + character(len=*), intent(in), optional :: name + + integer :: data_size + type(memory_log), pointer :: this_log + + select case(data_type) + case("real") + data_size=real_size + case("integer") + data_size=integer_size + case default + FLAbort(trim(data_type)//" is not a supported data type.") + end select + + select case(object_type) + case("mesh_type") + this_log=>memory_usage(MESH_TYPE) + case("scalar_field") + this_log=>memory_usage(SCALAR_FIELD) + case("vector_field") + this_log=>memory_usage(VECTOR_FIELD) + case("tensor_field") + this_log=>memory_usage(TENSOR_FIELD) + case("csr_sparsity") + this_log=>memory_usage(CSR_SPARSITY) + case("csr_matrix") + this_log=>memory_usage(CSR_MATRIX) + case("transform_cache") + this_log=>memory_usage(TRANSFORM_CACHE) + case default + FLAbort(trim(data_type)//" is not a supported object type.") + end select + + if (log_allocates) then + if (present(name)) then + ewrite(2,*) "Deallocating ",size*data_size," bytes of ",trim(object_type)& + &, ", name ",trim(name) + else + ewrite(2,*) "Deallocating ",size*data_size," bytes of ",trim(object_type) + end if end if - end if - this_log%current=this_log%current - size*data_size + this_log%current=this_log%current - size*data_size - this_log%max=max(this_log%max, this_log%current) - this_log%min=min(this_log%min, this_log%current) + this_log%max=max(this_log%max, this_log%current) + this_log%min=min(this_log%min, this_log%current) - ! Also account for total memory. - memory_usage(0)%current=memory_usage(0)%current - size*data_size + ! Also account for total memory. + memory_usage(0)%current=memory_usage(0)%current - size*data_size - memory_usage(0)%max=max(memory_usage(0)%max, memory_usage(0)%current) - memory_usage(0)%min=min(memory_usage(0)%min, memory_usage(0)%current) + memory_usage(0)%max=max(memory_usage(0)%max, memory_usage(0)%current) + memory_usage(0)%min=min(memory_usage(0)%min, memory_usage(0)%current) - end subroutine register_deallocation + end subroutine register_deallocation - subroutine register_temporary_memory(object_type, data_type, size) - !!< Register some memory which has been used but already freed. - character(len=*), intent(in) :: object_type, data_type - integer, intent(in) :: size + subroutine register_temporary_memory(object_type, data_type, size) + !!< Register some memory which has been used but already freed. + character(len=*), intent(in) :: object_type, data_type + integer, intent(in) :: size - call register_allocation(object_type, data_type, size) - call register_deallocation(object_type, data_type, size) + call register_allocation(object_type, data_type, size) + call register_deallocation(object_type, data_type, size) - end subroutine register_temporary_memory + end subroutine register_temporary_memory - subroutine reset_memory_logs - !!< Set the minimum and maximum values in the memory logs back to the - !!< current value. This is primarily of use for calculating the peak - !!< and minumum memory consumption during a timestep. - integer :: i + subroutine reset_memory_logs + !!< Set the minimum and maximum values in the memory logs back to the + !!< current value. This is primarily of use for calculating the peak + !!< and minumum memory consumption during a timestep. + integer :: i - log_allocates=have_option('/io/log_output/memory_diagnostics') + log_allocates=have_option('/io/log_output/memory_diagnostics') - do i=0,MEMORY_TYPES - memory_usage(i)%max=memory_usage(i)%current - memory_usage(i)%min=memory_usage(i)%current - end do + do i=0,MEMORY_TYPES + memory_usage(i)%max=memory_usage(i)%current + memory_usage(i)%min=memory_usage(i)%current + end do - end subroutine reset_memory_logs + end subroutine reset_memory_logs - subroutine write_memory_stats(diag_unit, format) - !!< Write the current memory stats out on the unit provided. - integer, intent(in) :: diag_unit - character(len=*), intent(in) :: format - type(memory_log), dimension(0:MEMORY_TYPES) ::& - & global_memory_usage - real, dimension((MEMORY_TYPES+1)*MEMORY_STATS) :: buffer + subroutine write_memory_stats(diag_unit, format) + !!< Write the current memory stats out on the unit provided. + integer, intent(in) :: diag_unit + character(len=*), intent(in) :: format + type(memory_log), dimension(0:MEMORY_TYPES) ::& + & global_memory_usage + real, dimension((MEMORY_TYPES+1)*MEMORY_STATS) :: buffer - integer :: i + integer :: i - if (isparallel()) then - buffer=transfer(memory_usage, buffer) - call allsum(buffer) - global_memory_usage=transfer(buffer, memory_usage) - else - global_memory_usage=memory_usage - end if + if (isparallel()) then + buffer=transfer(memory_usage, buffer) + call allsum(buffer) + global_memory_usage=transfer(buffer, memory_usage) + else + global_memory_usage=memory_usage + end if - ! Only output from process 0. - if (getrank()==0) then - do i=0,MEMORY_TYPES + ! Only output from process 0. + if (getrank()==0) then + do i=0,MEMORY_TYPES - write(diag_unit, trim(format), advance="no") & + write(diag_unit, trim(format), advance="no") & memory_usage(i)%current - write(diag_unit, trim(format), advance="no") & + write(diag_unit, trim(format), advance="no") & memory_usage(i)%min - write(diag_unit, trim(format), advance="no") & + write(diag_unit, trim(format), advance="no") & memory_usage(i)%max - end do - end if + end do + end if - end subroutine write_memory_stats + end subroutine write_memory_stats - subroutine print_memory_stats(priority) - !!< Print out the current memory allocation statistics using ewrites - !!< with the given priority. - integer, intent(in) :: priority - integer :: i + subroutine print_memory_stats(priority) + !!< Print out the current memory allocation statistics using ewrites + !!< with the given priority. + integer, intent(in) :: priority + integer :: i - ewrite(priority,*) "Memory usage in bytes:" - ewrite(priority,'(a30,3a15)') "", "current", "min", "max" + ewrite(priority,*) "Memory usage in bytes:" + ewrite(priority,'(a30,3a15)') "", "current", "min", "max" - do i=0,MEMORY_TYPES + do i=0,MEMORY_TYPES - ewrite(priority,'(a30,3f15.0)') memory_type_names(i), & + ewrite(priority,'(a30,3f15.0)') memory_type_names(i), & memory_usage(i)%current, & memory_usage(i)%min, & memory_usage(i)%max - end do + end do - end subroutine print_memory_stats + end subroutine print_memory_stats - subroutine print_current_memory_stats(priority) - !!< Print out the current memory allocation statistics using ewrites - !!< with the given priority. - integer, intent(in) :: priority - integer :: i + subroutine print_current_memory_stats(priority) + !!< Print out the current memory allocation statistics using ewrites + !!< with the given priority. + integer, intent(in) :: priority + integer :: i - if (all(memory_usage%current==0)) then - ewrite(1,*) "No registered memory in use." - return - end if + if (all(memory_usage%current==0)) then + ewrite(1,*) "No registered memory in use." + return + end if - ewrite(priority,*) "Current memory usage in bytes:" + ewrite(priority,*) "Current memory usage in bytes:" - do i=0,MEMORY_TYPES + do i=0,MEMORY_TYPES - ewrite(priority,'(a30,f15.0)') memory_type_names(i), memory_usage(i)%current + ewrite(priority,'(a30,f15.0)') memory_type_names(i), memory_usage(i)%current - end do + end do - end subroutine print_current_memory_stats + end subroutine print_current_memory_stats end module memory_diagnostics diff --git a/femtools/Merge_tensors.F90 b/femtools/Merge_tensors.F90 index 4bec7776d8..a73932522a 100644 --- a/femtools/Merge_tensors.F90 +++ b/femtools/Merge_tensors.F90 @@ -1,23 +1,23 @@ #include "fdebug.h" module merge_tensors - !!< This module contains code to merge two tensors representing - !!< anisotropic mesh information together to form a new metric - !!< satisfying both constraints. - !!< See Gerard Gorman's thesis, section 2.4. - - use fldebug - use vector_tools - use unittest_tools - use metric_tools, only: aspect_ratio - use fields - implicit none - - private - public :: merge_tensor, merge_tensor_fields, get_deformation_matrix - contains - - subroutine merge_tensor(tensor1, tensor2, aniso_min) + !!< This module contains code to merge two tensors representing + !!< anisotropic mesh information together to form a new metric + !!< satisfying both constraints. + !!< See Gerard Gorman's thesis, section 2.4. + + use fldebug + use vector_tools + use unittest_tools + use metric_tools, only: aspect_ratio + use fields + implicit none + + private + public :: merge_tensor, merge_tensor_fields, get_deformation_matrix +contains + + subroutine merge_tensor(tensor1, tensor2, aniso_min) !!< Merge two tensors together, putting the result in tensor1. real, dimension(:, :), intent(inout), target :: tensor1 real, dimension(:, :), intent(inout), target :: tensor2 @@ -43,9 +43,9 @@ subroutine merge_tensor(tensor1, tensor2, aniso_min) ! ignore the case aniso_min/laniso_min = .true. if (present(aniso_min)) then - laniso_min = aniso_min + laniso_min = aniso_min else - laniso_min = .false. + laniso_min = .false. end if ! Step 1: decompose the two matrices. @@ -57,32 +57,32 @@ subroutine merge_tensor(tensor1, tensor2, aniso_min) call vec_clean(a2, 1e-12) if (maxval(a1) == 0.0 .and. maxval(a2) == 0.0) then - return + return end if do i=1,dim - if (a1(i) .lt. 0.0) then - a1(i) = 0.0 - end if - if (a2(i) .lt. 0.0) then - a2(i) = 0.0 - end if + if (a1(i) .lt. 0.0) then + a1(i) = 0.0 + end if + if (a2(i) .lt. 0.0) then + a2(i) = 0.0 + end if end do aspect1 = aspect_ratio(a1) aspect2 = aspect_ratio(a2) if (.not. laniso_min) then - if (aspect1 .le. aspect2) then ! so aspect1 is mapped to the sphere - sphere_t => tensor1; sphere_v => v1; sphere_a => a1 - other_t => tensor2; other_v => v2; other_a => a2 - else - sphere_t => tensor2; sphere_v => v2; sphere_a => a2 - other_t => tensor1; other_v => v1; other_a => a1 - end if + if (aspect1 .le. aspect2) then ! so aspect1 is mapped to the sphere + sphere_t => tensor1; sphere_v => v1; sphere_a => a1 + other_t => tensor2; other_v => v2; other_a => a2 + else + sphere_t => tensor2; sphere_v => v2; sphere_a => a2 + other_t => tensor1; other_v => v1; other_a => a1 + end if else - sphere_t => tensor2; sphere_v => v2; sphere_a => a2 - other_t => tensor1; other_v => v1; other_a => a1 + sphere_t => tensor2; sphere_v => v2; sphere_a => a2 + other_t => tensor1; other_v => v1; other_a => a1 end if store = other_t ! if no eigenvalues change, don't do the eigendecomposition/eigenrecomposition @@ -95,17 +95,17 @@ subroutine merge_tensor(tensor1, tensor2, aniso_min) Finv = F; call invert(Finv, stat=stat) if (stat /= 0) then - call write_matrix(sphere_t, "The tensor we are mapping to the sphere") - call write_matrix(sphere_v, "Its eigenvectors") - call write_vector(sphere_a, "Its eigenvalues") - call write_matrix(F, "Deformation matrix") - call write_matrix(other_t, "Other matrix") - call write_matrix(other_v, "Its eigenvectors") - call write_vector(other_a, "Its eigenvalues") - call write_vector(a1, "First eigenvalues") - call write_vector(a2, "Second eigenvalues") - write (0,*) "aspect1 == ", aspect1, "; aspect2 == ", aspect2 - FLAbort("Error: inverting deformation matrix failed") + call write_matrix(sphere_t, "The tensor we are mapping to the sphere") + call write_matrix(sphere_v, "Its eigenvectors") + call write_vector(sphere_a, "Its eigenvalues") + call write_matrix(F, "Deformation matrix") + call write_matrix(other_t, "Other matrix") + call write_matrix(other_v, "Its eigenvectors") + call write_vector(other_a, "Its eigenvalues") + call write_vector(a1, "First eigenvalues") + call write_vector(a2, "Second eigenvalues") + write (0,*) "aspect1 == ", aspect1, "; aspect2 == ", aspect2 + FLAbort("Error: inverting deformation matrix failed") end if T = transpose(Finv) @@ -121,15 +121,15 @@ subroutine merge_tensor(tensor1, tensor2, aniso_min) call eigendecomposition_symmetric(other_t, other_v, other_a) if (laniso_min) then - do i=1,dim - if (other_a(i) .fgt. 1.0) eigenvalue_changed = .true. - other_a(i) = min(other_a(i), 1.0) - end do + do i=1,dim + if (other_a(i) .fgt. 1.0) eigenvalue_changed = .true. + other_a(i) = min(other_a(i), 1.0) + end do else - do i=1,dim - if (other_a(i) .flt. 1.0) eigenvalue_changed = .true. - other_a(i) = max(other_a(i), 1.0) - end do + do i=1,dim + if (other_a(i) .flt. 1.0) eigenvalue_changed = .true. + other_a(i) = max(other_a(i), 1.0) + end do end if call eigenrecomposition(other_t, other_v, other_a) ! Step 3: Apply the inverse map to other_t. @@ -139,9 +139,9 @@ subroutine merge_tensor(tensor1, tensor2, aniso_min) if (.not. eigenvalue_changed) tensor1 = store ! ignore the eigendecomposition/recomposition ! Done. - end subroutine merge_tensor + end subroutine merge_tensor - function get_deformation_matrix(M, V, A) result(F) + function get_deformation_matrix(M, V, A) result(F) !! Compute F = A^(1/2) * V^T real, dimension(:, :), intent(in) :: M real, dimension(size(M, 1), size(M, 1)), intent(in), optional :: V @@ -151,20 +151,20 @@ function get_deformation_matrix(M, V, A) result(F) integer :: i if (present(V) .and. present(A)) then - local_V = V - local_A = A + local_V = V + local_A = A else - call eigendecomposition_symmetric(M, local_V, local_A) + call eigendecomposition_symmetric(M, local_V, local_A) end if do i=1,size(M, 1) - local_A(i) = sqrt(local_A(i)) + local_A(i) = sqrt(local_A(i)) end do F = matmul(get_mat_diag(local_A), transpose(local_V)) - end function get_deformation_matrix + end function get_deformation_matrix - subroutine merge_tensor_fields(fielda, fieldb, aniso_min) + subroutine merge_tensor_fields(fielda, fieldb, aniso_min) !!< Loop through the two tensor fields and merge them nodewise. type(tensor_field), intent(inout) :: fielda, fieldb logical, intent(in), optional :: aniso_min @@ -175,7 +175,7 @@ subroutine merge_tensor_fields(fielda, fieldb, aniso_min) ewrite(2,*) "Merging tensor fields." do i=1,fielda%mesh%nodes - call merge_tensor(fielda%val(:, :, i), fieldb%val(:, :, i), aniso_min) + call merge_tensor(fielda%val(:, :, i), fieldb%val(:, :, i), aniso_min) end do - end subroutine + end subroutine end module merge_tensors diff --git a/femtools/MeshDiagnostics.F90 b/femtools/MeshDiagnostics.F90 index dbda7bfa46..626b9d2787 100644 --- a/femtools/MeshDiagnostics.F90 +++ b/femtools/MeshDiagnostics.F90 @@ -28,200 +28,200 @@ #include "fdebug.h" module MeshDiagnostics - use fldebug - use elements - use spud - use parallel_tools - use fields_data_types - use fields_base - use transform_elements - use parallel_fields + use fldebug + use elements + use spud + use parallel_tools + use fields_data_types + use fields_base + use transform_elements + use parallel_fields - implicit none + implicit none - private + private - public :: tetvol, triarea, & - & simplex_volume, mesh_stats, pentahedron_vol + public :: tetvol, triarea, & + & simplex_volume, mesh_stats, pentahedron_vol - interface mesh_stats - module procedure mesh_stats_mesh, mesh_stats_scalar, mesh_stats_vector - end interface mesh_stats + interface mesh_stats + module procedure mesh_stats_mesh, mesh_stats_scalar, mesh_stats_vector + end interface mesh_stats contains - REAL FUNCTION PENTAHEDRON_VOL(X,Y,Z) - !c - !C Calculate the volume of a pentahedron, i.e. a polyhedron comprising 5 faces, - !c (3 quadrilaterals and 2 triangles) and 6 vertices. - !c Make the assumption that vertices 3,4,5,6 of X,Y,Z are one of - !c these quadrilaterals. Volume calculated by splitting into 3 tetrahedra. - !c To split into 3 tetrahedra here need to assume that node 1 is on the same - !c face as nodes 3,4 and that node 2 is on the same face as nodes 5,6. - !c - REAL X(6), Y(6), Z(6) - !C - REAL XTET1(4), YTET1(4), ZTET1(4) - REAL XTET2(4), YTET2(4), ZTET2(4) - REAL XTET3(4), YTET3(4), ZTET3(4) - !C - XTET1(1) = X(6) - XTET1(2) = X(4) - XTET1(3) = X(3) - XTET1(4) = X(2) - - YTET1(1) = Y(6) - YTET1(2) = Y(4) - YTET1(3) = Y(3) - YTET1(4) = Y(2) - - ZTET1(1) = Z(6) - ZTET1(2) = Z(4) - ZTET1(3) = Z(3) - ZTET1(4) = Z(2) - - XTET2(1) = X(6) - XTET2(2) = X(3) - XTET2(3) = X(5) - XTET2(4) = X(2) - - YTET2(1) = Y(6) - YTET2(2) = Y(3) - YTET2(3) = Y(5) - YTET2(4) = Y(2) - - ZTET2(1) = Z(6) - ZTET2(2) = Z(3) - ZTET2(3) = Z(5) - ZTET2(4) = Z(2) - - XTET3(1) = X(4) - XTET3(2) = X(3) - XTET3(3) = X(2) - XTET3(4) = X(1) - - YTET3(1) = Y(4) - YTET3(2) = Y(3) - YTET3(3) = Y(2) - YTET3(4) = Y(1) - - ZTET3(1) = Z(4) - ZTET3(2) = Z(3) - ZTET3(3) = Z(2) - ZTET3(4) = Z(1) - - PENTAHEDRON_VOL = abs(TETVOL(XTET1,YTET1,ZTET1)) & + REAL FUNCTION PENTAHEDRON_VOL(X,Y,Z) + !c + !C Calculate the volume of a pentahedron, i.e. a polyhedron comprising 5 faces, + !c (3 quadrilaterals and 2 triangles) and 6 vertices. + !c Make the assumption that vertices 3,4,5,6 of X,Y,Z are one of + !c these quadrilaterals. Volume calculated by splitting into 3 tetrahedra. + !c To split into 3 tetrahedra here need to assume that node 1 is on the same + !c face as nodes 3,4 and that node 2 is on the same face as nodes 5,6. + !c + REAL X(6), Y(6), Z(6) + !C + REAL XTET1(4), YTET1(4), ZTET1(4) + REAL XTET2(4), YTET2(4), ZTET2(4) + REAL XTET3(4), YTET3(4), ZTET3(4) + !C + XTET1(1) = X(6) + XTET1(2) = X(4) + XTET1(3) = X(3) + XTET1(4) = X(2) + + YTET1(1) = Y(6) + YTET1(2) = Y(4) + YTET1(3) = Y(3) + YTET1(4) = Y(2) + + ZTET1(1) = Z(6) + ZTET1(2) = Z(4) + ZTET1(3) = Z(3) + ZTET1(4) = Z(2) + + XTET2(1) = X(6) + XTET2(2) = X(3) + XTET2(3) = X(5) + XTET2(4) = X(2) + + YTET2(1) = Y(6) + YTET2(2) = Y(3) + YTET2(3) = Y(5) + YTET2(4) = Y(2) + + ZTET2(1) = Z(6) + ZTET2(2) = Z(3) + ZTET2(3) = Z(5) + ZTET2(4) = Z(2) + + XTET3(1) = X(4) + XTET3(2) = X(3) + XTET3(3) = X(2) + XTET3(4) = X(1) + + YTET3(1) = Y(4) + YTET3(2) = Y(3) + YTET3(3) = Y(2) + YTET3(4) = Y(1) + + ZTET3(1) = Z(4) + ZTET3(2) = Z(3) + ZTET3(3) = Z(2) + ZTET3(4) = Z(1) + + PENTAHEDRON_VOL = abs(TETVOL(XTET1,YTET1,ZTET1)) & + abs(TETVOL(XTET2,YTET2,ZTET2)) & + abs(TETVOL(XTET3,YTET3,ZTET3)) - RETURN - END FUNCTION PENTAHEDRON_VOL - - subroutine mesh_stats_mesh(mesh, nodes, elements, surface_elements, facets) - !!< Parallel safe mesh statistics - - type(mesh_type), intent(in) :: mesh - integer, optional, intent(out) :: nodes - integer, optional, intent(out) :: elements - integer, optional, intent(out) :: surface_elements - integer, optional, intent(out) :: facets - - integer :: i, surface_facets - - if(present(nodes)) then - if(isparallel()) then - nodes = 0 - do i = 1, node_count(mesh) - if(node_owned_mesh(mesh, i)) then - nodes = nodes + 1 - end if - end do - call allsum(nodes) - else - nodes = node_count(mesh) + RETURN + END FUNCTION PENTAHEDRON_VOL + + subroutine mesh_stats_mesh(mesh, nodes, elements, surface_elements, facets) + !!< Parallel safe mesh statistics + + type(mesh_type), intent(in) :: mesh + integer, optional, intent(out) :: nodes + integer, optional, intent(out) :: elements + integer, optional, intent(out) :: surface_elements + integer, optional, intent(out) :: facets + + integer :: i, surface_facets + + if(present(nodes)) then + if(isparallel()) then + nodes = 0 + do i = 1, node_count(mesh) + if(node_owned_mesh(mesh, i)) then + nodes = nodes + 1 + end if + end do + call allsum(nodes) + else + nodes = node_count(mesh) + end if end if - end if - - if(present(elements)) then - if(isparallel()) then - elements = 0 - do i = 1, ele_count(mesh) - if(element_owned(mesh, i)) then - elements = elements + 1 - end if - end do - call allsum(elements) - else - elements = ele_count(mesh) + + if(present(elements)) then + if(isparallel()) then + elements = 0 + do i = 1, ele_count(mesh) + if(element_owned(mesh, i)) then + elements = elements + 1 + end if + end do + call allsum(elements) + else + elements = ele_count(mesh) + end if end if - end if - - if(present(surface_elements)) then - if(isparallel()) then - surface_elements = 0 - do i = 1, surface_element_count(mesh) - if(surface_element_owned(mesh, i)) then - surface_elements = surface_elements + 1 - end if - end do - call allsum(surface_elements) - else - surface_elements = surface_element_count(mesh) + + if(present(surface_elements)) then + if(isparallel()) then + surface_elements = 0 + do i = 1, surface_element_count(mesh) + if(surface_element_owned(mesh, i)) then + surface_elements = surface_elements + 1 + end if + end do + call allsum(surface_elements) + else + surface_elements = surface_element_count(mesh) + end if end if - end if - - if(present(facets)) then - if(isparallel()) then - facets = 0 - do i = 1, face_count(mesh) - if(surface_element_owned(mesh, i)) then - facets = facets + 1 - end if - end do - if(present(surface_elements)) then - ! this depends on facets being worked out after surface_elements - surface_facets = surface_elements - else - surface_facets = 0 - do i = 1, surface_element_count(mesh) - if(surface_element_owned(mesh, i)) then - surface_facets = surface_facets + 1 + + if(present(facets)) then + if(isparallel()) then + facets = 0 + do i = 1, face_count(mesh) + if(surface_element_owned(mesh, i)) then + facets = facets + 1 + end if + end do + if(present(surface_elements)) then + ! this depends on facets being worked out after surface_elements + surface_facets = surface_elements + else + surface_facets = 0 + do i = 1, surface_element_count(mesh) + if(surface_element_owned(mesh, i)) then + surface_facets = surface_facets + 1 + end if + end do + call allsum(surface_facets) end if - end do - call allsum(surface_facets) - end if - facets = (facets-surface_facets)/2 + surface_facets - call allsum(facets) - else - facets = (face_count(mesh)-surface_element_count(mesh))/2 & - + surface_element_count(mesh) + facets = (facets-surface_facets)/2 + surface_facets + call allsum(facets) + else + facets = (face_count(mesh)-surface_element_count(mesh))/2 & + + surface_element_count(mesh) + end if end if - end if - end subroutine mesh_stats_mesh + end subroutine mesh_stats_mesh - subroutine mesh_stats_scalar(s_field, nodes, elements, surface_elements) - !!< Parallel safe mesh statistics + subroutine mesh_stats_scalar(s_field, nodes, elements, surface_elements) + !!< Parallel safe mesh statistics - type(scalar_field), intent(in) :: s_field - integer, optional, intent(out) :: nodes - integer, optional, intent(out) :: elements - integer, optional, intent(out) :: surface_elements + type(scalar_field), intent(in) :: s_field + integer, optional, intent(out) :: nodes + integer, optional, intent(out) :: elements + integer, optional, intent(out) :: surface_elements - call mesh_stats(s_field%mesh, nodes = nodes, elements = elements, surface_elements = surface_elements) + call mesh_stats(s_field%mesh, nodes = nodes, elements = elements, surface_elements = surface_elements) - end subroutine mesh_stats_scalar + end subroutine mesh_stats_scalar - subroutine mesh_stats_vector(v_field, nodes, elements, surface_elements) - !!< Parallel safe mesh statistics + subroutine mesh_stats_vector(v_field, nodes, elements, surface_elements) + !!< Parallel safe mesh statistics - type(vector_field), intent(in) :: v_field - integer, optional, intent(out) :: nodes - integer, optional, intent(out) :: elements - integer, optional, intent(out) :: surface_elements + type(vector_field), intent(in) :: v_field + integer, optional, intent(out) :: nodes + integer, optional, intent(out) :: elements + integer, optional, intent(out) :: surface_elements - call mesh_stats(v_field%mesh, nodes = nodes, elements = elements, surface_elements = surface_elements) + call mesh_stats(v_field%mesh, nodes = nodes, elements = elements, surface_elements = surface_elements) - end subroutine mesh_stats_vector + end subroutine mesh_stats_vector end module MeshDiagnostics diff --git a/femtools/Mesh_Files.F90 b/femtools/Mesh_Files.F90 index 1c73116bd0..35d9fede07 100644 --- a/femtools/Mesh_Files.F90 +++ b/femtools/Mesh_Files.F90 @@ -43,158 +43,158 @@ module mesh_files - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use futils - use elements - use spud - use fields - use state_module - use gmsh_common - use read_gmsh - use read_triangle - use read_exodusii - use write_gmsh - use write_triangle + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use futils + use elements + use spud + use fields + use state_module + use gmsh_common + use read_gmsh + use read_triangle + use read_exodusii + use write_gmsh + use write_triangle - implicit none + implicit none - private + private - interface read_mesh_files - module procedure read_mesh_simple - end interface + interface read_mesh_files + module procedure read_mesh_simple + end interface - interface write_mesh_files - module procedure write_mesh_to_file, & - write_positions_to_file - end interface + interface write_mesh_files + module procedure write_mesh_to_file, & + write_positions_to_file + end interface - public :: read_mesh_files, write_mesh_files + public :: read_mesh_files, write_mesh_files contains - ! -------------------------------------------------------------------------- - ! Read routines first - ! -------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- + ! Read routines first + ! -------------------------------------------------------------------------- - function read_mesh_simple(filename, format, quad_degree, & - quad_ngi, quad_family, mdim) & - result (field) + function read_mesh_simple(filename, format, quad_degree, & + quad_ngi, quad_family, mdim) & + result (field) - ! A simpler mechanism for reading a mesh file into a field. - ! In parallel the filename must *not* include the process number. + ! A simpler mechanism for reading a mesh file into a field. + ! In parallel the filename must *not* include the process number. - character(len=*), intent(in) :: filename, format - ! The degree of the quadrature. - integer, intent(in), optional, target :: quad_degree - ! The degree of the quadrature. - integer, intent(in), optional, target :: quad_ngi - ! What quadrature family to use - integer, intent(in), optional :: quad_family - ! Dimension of mesh - integer, intent(in), optional :: mdim + character(len=*), intent(in) :: filename, format + ! The degree of the quadrature. + integer, intent(in), optional, target :: quad_degree + ! The degree of the quadrature. + integer, intent(in), optional, target :: quad_ngi + ! What quadrature family to use + integer, intent(in), optional :: quad_family + ! Dimension of mesh + integer, intent(in), optional :: mdim - type(vector_field) :: field + type(vector_field) :: field - select case( trim(format) ) - case("triangle") - ewrite(-1,*) "The Triangle mesh format reader is deprecated." - ewrite(-1,*) "Please convert your mesh to the Gmsh format." - FLAbort("Triangle mesh format is no longer supported") + select case( trim(format) ) + case("triangle") + ewrite(-1,*) "The Triangle mesh format reader is deprecated." + ewrite(-1,*) "Please convert your mesh to the Gmsh format." + FLAbort("Triangle mesh format is no longer supported") - ! field = read_triangle_files(filename, quad_degree=quad_degree, quad_ngi=quad_ngi, & - ! quad_family=quad_family, mdim=mdim) + ! field = read_triangle_files(filename, quad_degree=quad_degree, quad_ngi=quad_ngi, & + ! quad_family=quad_family, mdim=mdim) - case("gmsh") - field = read_gmsh_file(filename, quad_degree=quad_degree, quad_ngi=quad_ngi, & + case("gmsh") + field = read_gmsh_file(filename, quad_degree=quad_degree, quad_ngi=quad_ngi, & quad_family=quad_family, mdim=mdim) - case("exodusii") + case("exodusii") #ifdef HAVE_LIBEXOIIV2C - field = read_exodusii_file(filename, quad_degree=quad_degree, quad_ngi=quad_ngi, & + field = read_exodusii_file(filename, quad_degree=quad_degree, quad_ngi=quad_ngi, & quad_family=quad_family) #else - FLExit("Fluidity was not configured with exodusII, reconfigure with '--with-exodusii'!") + FLExit("Fluidity was not configured with exodusII, reconfigure with '--with-exodusii'!") #endif - ! Additional mesh format subroutines go here + ! Additional mesh format subroutines go here - case default - FLExit("Reading mesh type "//format//" not supported within Fluidity") - end select + case default + FLExit("Reading mesh type "//format//" not supported within Fluidity") + end select - end function read_mesh_simple + end function read_mesh_simple - ! -------------------------------------------------------------------------- - ! Write routines here - ! -------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- + ! Write routines here + ! -------------------------------------------------------------------------- - subroutine write_mesh_to_file(filename, format, state, mesh, number_of_partitions) - ! Write out the supplied mesh to the specified filename as mesh files. + subroutine write_mesh_to_file(filename, format, state, mesh, number_of_partitions) + ! Write out the supplied mesh to the specified filename as mesh files. - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: format - type(state_type), intent(in) :: state - type(mesh_type), intent(in) :: mesh - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: format + type(state_type), intent(in) :: state + type(mesh_type), intent(in) :: mesh + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions - select case(format) - case("triangle") - call write_triangle_files(filename, state, mesh, number_of_partitions=number_of_partitions) + select case(format) + case("triangle") + call write_triangle_files(filename, state, mesh, number_of_partitions=number_of_partitions) - case("gmsh") - call write_gmsh_file(filename, state, mesh, number_of_partitions=number_of_partitions) + case("gmsh") + call write_gmsh_file(filename, state, mesh, number_of_partitions=number_of_partitions) - ! ExodusII write routines are not implemented at this point. - ! Mesh is dumped as gmsh format for now. - ! check subroutine 'insert_external_mesh' in Populate_State.F90, - ! right after reading in external mesh files + ! ExodusII write routines are not implemented at this point. + ! Mesh is dumped as gmsh format for now. + ! check subroutine 'insert_external_mesh' in Populate_State.F90, + ! right after reading in external mesh files - ! Additional mesh format subroutines go here + ! Additional mesh format subroutines go here - case default - FLExit("Writing to mesh type "//format//" not supported within Fluidity") - end select + case default + FLExit("Writing to mesh type "//format//" not supported within Fluidity") + end select - end subroutine write_mesh_to_file + end subroutine write_mesh_to_file - ! -------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- - subroutine write_positions_to_file(filename, format, positions, number_of_partitions) - !!< Write out the mesh given by the position field in mesh files - !!< In parallel, empty trailing processes are not written. - character(len=*), intent(in):: filename, format - type(vector_field), intent(in):: positions - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions + subroutine write_positions_to_file(filename, format, positions, number_of_partitions) + !!< Write out the mesh given by the position field in mesh files + !!< In parallel, empty trailing processes are not written. + character(len=*), intent(in):: filename, format + type(vector_field), intent(in):: positions + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions - select case( trim(format) ) - case("triangle") - call write_triangle_files( trim(filename), positions, number_of_partitions=number_of_partitions) + select case( trim(format) ) + case("triangle") + call write_triangle_files( trim(filename), positions, number_of_partitions=number_of_partitions) - case("gmsh") - call write_gmsh_file( trim(filename), positions, number_of_partitions=number_of_partitions) + case("gmsh") + call write_gmsh_file( trim(filename), positions, number_of_partitions=number_of_partitions) - ! ExodusII write routines are not implemented at this point. - ! Mesh is dumped as gmsh format for now. - ! check subroutine 'insert_external_mesh' in Populate_State.F90, - ! right after reading in external mesh files + ! ExodusII write routines are not implemented at this point. + ! Mesh is dumped as gmsh format for now. + ! check subroutine 'insert_external_mesh' in Populate_State.F90, + ! right after reading in external mesh files - ! Additional mesh format subroutines go here + ! Additional mesh format subroutines go here - case default - FLExit("Writing to mesh type "//format//" not supported within Fluidity") - end select + case default + FLExit("Writing to mesh type "//format//" not supported within Fluidity") + end select - end subroutine write_positions_to_file + end subroutine write_positions_to_file end module mesh_files diff --git a/femtools/Mesh_Quality.F90 b/femtools/Mesh_Quality.F90 index e35294209a..d22d79ecc4 100644 --- a/femtools/Mesh_Quality.F90 +++ b/femtools/Mesh_Quality.F90 @@ -27,79 +27,79 @@ #include "fdebug.h" module mesh_quality - use iso_c_binding - use FLdebug - use element_numbering, only: FAMILY_SIMPLEX - use fields + use iso_c_binding + use FLdebug + use element_numbering, only: FAMILY_SIMPLEX + use fields - interface - subroutine mesh_quality_c(dim, n_nodes, n_elements, connectivity_len,& - measure, points, connectivity, quality) bind(c) - use iso_c_binding - integer (c_int) :: dim, n_nodes, n_elements, connectivity_len, measure - real (c_double) :: points(dim, n_nodes) - integer (c_int) :: connectivity(connectivity_len) - real (c_double) :: quality(n_elements) - end subroutine mesh_quality_c - end interface + interface + subroutine mesh_quality_c(dim, n_nodes, n_elements, connectivity_len,& + measure, points, connectivity, quality) bind(c) + use iso_c_binding + integer (c_int) :: dim, n_nodes, n_elements, connectivity_len, measure + real (c_double) :: points(dim, n_nodes) + integer (c_int) :: connectivity(connectivity_len) + real (c_double) :: quality(n_elements) + end subroutine mesh_quality_c + end interface - private + private - public :: get_mesh_quality + public :: get_mesh_quality - integer, public :: VTK_QUALITY_EDGE_RATIO = 0, & - VTK_QUALITY_ASPECT_RATIO = 1, & - VTK_QUALITY_RADIUS_RATIO = 2, & - VTK_QUALITY_ASPECT_FROBENIUS = 3, & - VTK_QUALITY_MED_ASPECT_FROBENIUS = 4, & - VTK_QUALITY_MAX_ASPECT_FROBENIUS = 5, & - VTK_QUALITY_MIN_ANGLE = 6, & - VTK_QUALITY_COLLAPSE_RATIO = 1, & - VTK_QUALITY_MAX_ANGLE = 8, & - VTK_QUALITY_CONDITION = 9, & - VTK_QUALITY_SCALED_JACOBIAN = 10, & - VTK_QUALITY_SHEAR = 11, & - VTK_QUALITY_RELATIVE_SIZE_SQUARED = 12, & - VTK_QUALITY_SHAPE = 13, & - VTK_QUALITY_SHAPE_AND_SIZE = 14, & - VTK_QUALITY_DISTORTION = 15, & - VTK_QUALITY_MAX_EDGE_RATIO = 16, & - VTK_QUALITY_SKEW = 17, & - VTK_QUALITY_TAPER = 18, & - VTK_QUALITY_ASPECT_VOLUME = 19, & - VTK_QUALITY_ASPECT_STRETCH = 20, & - VTK_QUALITY_ASPECT_DIAGONAL = 21, & - VTK_QUALITY_ASPECT_DIMENSION = 22, & - VTK_QUALITY_ASPECT_ODDY = 23, & - VTK_QUALITY_ASPECT_SHEAR_AND_SIZE = 24, & - VTK_QUALITY_ASPECT_JACOBIAN = 25, & - VTK_QUALITY_ASPECT_WARPAGE = 26, & - VTK_QUALITY_ASPECT_GAMMA = 27, & - VTK_QUALITY_AREA = 28, & - VTK_QUALITY_ASPECT_BETA = 29 + integer, public :: VTK_QUALITY_EDGE_RATIO = 0, & + VTK_QUALITY_ASPECT_RATIO = 1, & + VTK_QUALITY_RADIUS_RATIO = 2, & + VTK_QUALITY_ASPECT_FROBENIUS = 3, & + VTK_QUALITY_MED_ASPECT_FROBENIUS = 4, & + VTK_QUALITY_MAX_ASPECT_FROBENIUS = 5, & + VTK_QUALITY_MIN_ANGLE = 6, & + VTK_QUALITY_COLLAPSE_RATIO = 1, & + VTK_QUALITY_MAX_ANGLE = 8, & + VTK_QUALITY_CONDITION = 9, & + VTK_QUALITY_SCALED_JACOBIAN = 10, & + VTK_QUALITY_SHEAR = 11, & + VTK_QUALITY_RELATIVE_SIZE_SQUARED = 12, & + VTK_QUALITY_SHAPE = 13, & + VTK_QUALITY_SHAPE_AND_SIZE = 14, & + VTK_QUALITY_DISTORTION = 15, & + VTK_QUALITY_MAX_EDGE_RATIO = 16, & + VTK_QUALITY_SKEW = 17, & + VTK_QUALITY_TAPER = 18, & + VTK_QUALITY_ASPECT_VOLUME = 19, & + VTK_QUALITY_ASPECT_STRETCH = 20, & + VTK_QUALITY_ASPECT_DIAGONAL = 21, & + VTK_QUALITY_ASPECT_DIMENSION = 22, & + VTK_QUALITY_ASPECT_ODDY = 23, & + VTK_QUALITY_ASPECT_SHEAR_AND_SIZE = 24, & + VTK_QUALITY_ASPECT_JACOBIAN = 25, & + VTK_QUALITY_ASPECT_WARPAGE = 26, & + VTK_QUALITY_ASPECT_GAMMA = 27, & + VTK_QUALITY_AREA = 28, & + VTK_QUALITY_ASPECT_BETA = 29 contains - subroutine get_mesh_quality(positions, s_field, quality_measure) - integer, intent(inout) :: quality_measure - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: s_field + subroutine get_mesh_quality(positions, s_field, quality_measure) + integer, intent(inout) :: quality_measure + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: s_field - assert(element_count(positions) == element_count(s_field)) - assert(node_count(s_field) == element_count(s_field)) + assert(element_count(positions) == element_count(s_field)) + assert(node_count(s_field) == element_count(s_field)) - if (positions%mesh%shape%numbering%family /= FAMILY_SIMPLEX& + if (positions%mesh%shape%numbering%family /= FAMILY_SIMPLEX& .or. positions%mesh%shape%loc /= positions%mesh%shape%dim+1) then - FLAbort("Trying to get mesh quality for a mesh which isn't linear simplicial. This isn't currently supported.") - endif + FLAbort("Trying to get mesh quality for a mesh which isn't linear simplicial. This isn't currently supported.") + endif - call mesh_quality_c(positions%dim, node_count(positions), ele_count(positions),& + call mesh_quality_c(positions%dim, node_count(positions), ele_count(positions),& size(positions%mesh%ndglno), quality_measure,& positions%val, positions%mesh%ndglno,& s_field%val) - end subroutine get_mesh_quality + end subroutine get_mesh_quality end module mesh_quality diff --git a/femtools/Metric_tools.F90 b/femtools/Metric_tools.F90 index 7dd6dfa184..62e875945a 100644 --- a/femtools/Metric_tools.F90 +++ b/femtools/Metric_tools.F90 @@ -2,1156 +2,1156 @@ module metric_tools - use fldebug - use vector_tools - use spud - use unittest_tools - use element_numbering, only: FAMILY_SIMPLEX - use fields_data_types - use fields_base - use fields_allocates - use fields_manipulation - implicit none - - interface edge_length_from_eigenvalue - module procedure edge_length_from_eigenvalue_scalar, edge_length_from_eigenvalue_vector, & - & edge_length_from_eigenvalue_metric - end interface - - interface eigenvalue_from_edge_length - module procedure eigenvalue_from_edge_length_scalar, eigenvalue_from_edge_length_vector, & - & eigenvalue_from_edge_length_metric - end interface - - interface aspect_ratio - module procedure aspect_ratio_metric, aspect_ratio_eigenvalues - end interface - - interface metric_isotropic - module procedure metric_isotropic_metric, metric_isotropic_eigenvalues - end interface - - interface metric_spheroid - module procedure metric_spheroid_metric, metric_spheroid_eigenvalues - end interface - - interface metric_ellipsoid - module procedure metric_ellipsoid_metric, metric_ellipsoid_eigenvalues - end interface - - interface get_adapt_opt - module procedure get_adapt_opt_real_scalar, get_adapt_opt_real_vector - end interface - - private - public :: edge_length_from_eigenvalue, eigenvalue_from_edge_length,& - aspect_ratio, metric_isotropic, metric_spheroid, metric_ellipsoid,& - get_adapt_opt, check_metric, check_basis, get_spheroid_index,& - get_polar_index, norm, get_real_angle, get_angle_2d,& - get_rotation_matrix, get_rotation_matrix_cross,& - get_rotation_matrix_2d, get_rotation_matrix_3d,& - get_matrix_identity, have_adapt_opt, simplex_tensor,& - metric_from_edge_lengths, edge_lengths_from_metric,& - apply_transform, absolutify_tensor, domain_length_scale,& - get_angle, error_bound_name, project_to_subspace,& - element_quality_p0, check_perm,& - form_anisotropic_metric_from_isotropic_metric - - contains - - subroutine check_metric(metric) - !!< This code checks if the metric has NaN's in it. - type(tensor_field), intent(in) :: metric - - integer :: i, j, k + use fldebug + use vector_tools + use spud + use unittest_tools + use element_numbering, only: FAMILY_SIMPLEX + use fields_data_types + use fields_base + use fields_allocates + use fields_manipulation + implicit none + + interface edge_length_from_eigenvalue + module procedure edge_length_from_eigenvalue_scalar, edge_length_from_eigenvalue_vector, & + & edge_length_from_eigenvalue_metric + end interface + + interface eigenvalue_from_edge_length + module procedure eigenvalue_from_edge_length_scalar, eigenvalue_from_edge_length_vector, & + & eigenvalue_from_edge_length_metric + end interface + + interface aspect_ratio + module procedure aspect_ratio_metric, aspect_ratio_eigenvalues + end interface + + interface metric_isotropic + module procedure metric_isotropic_metric, metric_isotropic_eigenvalues + end interface + + interface metric_spheroid + module procedure metric_spheroid_metric, metric_spheroid_eigenvalues + end interface + + interface metric_ellipsoid + module procedure metric_ellipsoid_metric, metric_ellipsoid_eigenvalues + end interface + + interface get_adapt_opt + module procedure get_adapt_opt_real_scalar, get_adapt_opt_real_vector + end interface + + private + public :: edge_length_from_eigenvalue, eigenvalue_from_edge_length,& + aspect_ratio, metric_isotropic, metric_spheroid, metric_ellipsoid,& + get_adapt_opt, check_metric, check_basis, get_spheroid_index,& + get_polar_index, norm, get_real_angle, get_angle_2d,& + get_rotation_matrix, get_rotation_matrix_cross,& + get_rotation_matrix_2d, get_rotation_matrix_3d,& + get_matrix_identity, have_adapt_opt, simplex_tensor,& + metric_from_edge_lengths, edge_lengths_from_metric,& + apply_transform, absolutify_tensor, domain_length_scale,& + get_angle, error_bound_name, project_to_subspace,& + element_quality_p0, check_perm,& + form_anisotropic_metric_from_isotropic_metric + +contains + + subroutine check_metric(metric) + !!< This code checks if the metric has NaN's in it. + type(tensor_field), intent(in) :: metric + + integer :: i, j, k #ifdef DDEBUG - do i=1,metric%mesh%nodes - do j=1,metric%dim(1) - do k=1,metric%dim(2) - if (is_nan(metric%val(j, k, i))) then - ewrite(-1,*) "Node == ", i, "; position (", j, ", ", k, ")" + do i=1,metric%mesh%nodes + do j=1,metric%dim(1) + do k=1,metric%dim(2) + if (is_nan(metric%val(j, k, i))) then + ewrite(-1,*) "Node == ", i, "; position (", j, ", ", k, ")" + ewrite(-1,*) metric%val(:, :, i) + FLAbort("Your metric has NaNs!") + end if + end do + end do + if (.not. mat_is_symmetric(metric%val(:, :, i))) then + ewrite(-1,*) "Node == ", i ewrite(-1,*) metric%val(:, :, i) - FLAbort("Your metric has NaNs!") - end if - end do + FLAbort("Your metric is not symmetric!") + end if end do - if (.not. mat_is_symmetric(metric%val(:, :, i))) then - ewrite(-1,*) "Node == ", i - ewrite(-1,*) metric%val(:, :, i) - FLAbort("Your metric is not symmetric!") - end if - end do #endif - end subroutine check_metric + end subroutine check_metric - subroutine check_basis(basis, stat) - !!< This code checks if the matrix passed in represents - !!< an orthonormal basis. - real, dimension(:, :), intent(in) :: basis - integer, intent(out), optional :: stat - integer :: i, j - real :: dot + subroutine check_basis(basis, stat) + !!< This code checks if the matrix passed in represents + !!< an orthonormal basis. + real, dimension(:, :), intent(in) :: basis + integer, intent(out), optional :: stat + integer :: i, j + real :: dot - if (present(stat)) stat = 0 + if (present(stat)) stat = 0 #ifdef DDEBUG - do i=1,size(basis,2) - do j=i+1,size(basis,2) - dot = dot_product(basis(:, i), basis(:, j)) - if (dot .fne. 0.0) then - if (.not. present(stat)) then - call write_matrix(basis, "basis") - FLAbort("basis is not orthogonal!") - else - stat = 1 - end if - end if + do i=1,size(basis,2) + do j=i+1,size(basis,2) + dot = dot_product(basis(:, i), basis(:, j)) + if (dot .fne. 0.0) then + if (.not. present(stat)) then + call write_matrix(basis, "basis") + FLAbort("basis is not orthogonal!") + else + stat = 1 + end if + end if + end do + end do + + do i=1,size(basis,2) + dot = dot_product(basis(:, i), basis(:, i)) + if (dot .fne. 1.0) then + if (.not. present(stat)) then + call write_matrix(basis, "basis") + FLAbort("basis is not orthonormal!") + else + stat = 1 + end if + end if end do - end do - - do i=1,size(basis,2) - dot = dot_product(basis(:, i), basis(:, i)) - if (dot .fne. 1.0) then - if (.not. present(stat)) then - call write_matrix(basis, "basis") - FLAbort("basis is not orthonormal!") - else - stat = 1 - end if - end if - end do #endif - end subroutine check_basis + end subroutine check_basis - function edge_length_from_eigenvalue_scalar(evalue) result(edge_len) - real, intent(in) :: evalue - real :: edge_len + function edge_length_from_eigenvalue_scalar(evalue) result(edge_len) + real, intent(in) :: evalue + real :: edge_len - if (evalue /= 0.0) then - edge_len = 1.0/sqrt(abs(evalue)) - else - edge_len = huge(evalue) - end if + if (evalue /= 0.0) then + edge_len = 1.0/sqrt(abs(evalue)) + else + edge_len = huge(evalue) + end if - end function edge_length_from_eigenvalue_scalar + end function edge_length_from_eigenvalue_scalar - function edge_length_from_eigenvalue_vector(evalues) result(edge_lens) - real, dimension(:), intent(in) :: evalues - real, dimension(size(evalues)) :: edge_lens + function edge_length_from_eigenvalue_vector(evalues) result(edge_lens) + real, dimension(:), intent(in) :: evalues + real, dimension(size(evalues)) :: edge_lens - integer :: i + integer :: i - do i=1,size(evalues) - assert(evalues(i) /= 0.0) - edge_lens(i) = 1.0/sqrt(abs(evalues(i))) - end do - end function edge_length_from_eigenvalue_vector + do i=1,size(evalues) + assert(evalues(i) /= 0.0) + edge_lens(i) = 1.0/sqrt(abs(evalues(i))) + end do + end function edge_length_from_eigenvalue_vector - function edge_length_from_eigenvalue_metric(metric) result(edge) - real, dimension(:, :), intent(in) :: metric - real, dimension(size(metric, 1), size(metric, 1)) :: edge, evecs - real, dimension(size(metric, 1)) :: evals + function edge_length_from_eigenvalue_metric(metric) result(edge) + real, dimension(:, :), intent(in) :: metric + real, dimension(size(metric, 1), size(metric, 1)) :: edge, evecs + real, dimension(size(metric, 1)) :: evals - call eigendecomposition_symmetric(metric, evecs, evals) - call eigenrecomposition(edge, evecs, edge_length_from_eigenvalue_vector(evals)) - end function edge_length_from_eigenvalue_metric + call eigendecomposition_symmetric(metric, evecs, evals) + call eigenrecomposition(edge, evecs, edge_length_from_eigenvalue_vector(evals)) + end function edge_length_from_eigenvalue_metric - function eigenvalue_from_edge_length_scalar(edge_len) result(evalue) - real, intent(in) :: edge_len - real :: evalue + function eigenvalue_from_edge_length_scalar(edge_len) result(evalue) + real, intent(in) :: edge_len + real :: evalue - assert(edge_len /= 0.0) - evalue = 1.0/(edge_len * edge_len) - end function eigenvalue_from_edge_length_scalar + assert(edge_len /= 0.0) + evalue = 1.0/(edge_len * edge_len) + end function eigenvalue_from_edge_length_scalar - function eigenvalue_from_edge_length_vector(edge_lens) result(evalues) - real, dimension(:), intent(in) :: edge_lens - real, dimension(size(edge_lens)) :: evalues + function eigenvalue_from_edge_length_vector(edge_lens) result(evalues) + real, dimension(:), intent(in) :: edge_lens + real, dimension(size(edge_lens)) :: evalues - integer :: i + integer :: i - do i=1,size(edge_lens) - if(edge_lens(i) == 0.0) then - evalues(i) = huge(0.0) - else - evalues(i) = 1.0/(edge_lens(i) * edge_lens(i)) - end if - end do - end function eigenvalue_from_edge_length_vector + do i=1,size(edge_lens) + if(edge_lens(i) == 0.0) then + evalues(i) = huge(0.0) + else + evalues(i) = 1.0/(edge_lens(i) * edge_lens(i)) + end if + end do + end function eigenvalue_from_edge_length_vector - function eigenvalue_from_edge_length_metric(edge) result(metric) - real, dimension(:, :), intent(in) :: edge - real, dimension(size(edge, 1), size(edge, 1)) :: metric, evecs - real, dimension(size(edge, 1)) :: evals + function eigenvalue_from_edge_length_metric(edge) result(metric) + real, dimension(:, :), intent(in) :: edge + real, dimension(size(edge, 1), size(edge, 1)) :: metric, evecs + real, dimension(size(edge, 1)) :: evals - call eigendecomposition_symmetric(edge, evecs, evals) - call eigenrecomposition(metric, evecs, eigenvalue_from_edge_length_vector(evals)) - end function eigenvalue_from_edge_length_metric + call eigendecomposition_symmetric(edge, evecs, evals) + call eigenrecomposition(metric, evecs, eigenvalue_from_edge_length_vector(evals)) + end function eigenvalue_from_edge_length_metric - function metric_isotropic_metric(metric) result(isotropic) - !!< Is the metric isotropic, that is, all its eigenvalues are the same? - real, dimension(:, :) :: metric + function metric_isotropic_metric(metric) result(isotropic) + !!< Is the metric isotropic, that is, all its eigenvalues are the same? + real, dimension(:, :) :: metric - real, dimension(size(metric,1), size(metric,1)) :: lvecs - real, dimension(size(metric,1)) :: lvals + real, dimension(size(metric,1), size(metric,1)) :: lvecs + real, dimension(size(metric,1)) :: lvals - integer :: i - real :: maxv + integer :: i + real :: maxv - logical :: isotropic + logical :: isotropic - isotropic = .true. + isotropic = .true. - call eigendecomposition_symmetric(metric, lvecs, lvals) + call eigendecomposition_symmetric(metric, lvecs, lvals) - maxv = maxval(lvals) - do i=1,size(metric,1) - if (.not. fequals(lvals(i), maxv)) then - isotropic = .false. - return - end if - end do - end function metric_isotropic_metric + maxv = maxval(lvals) + do i=1,size(metric,1) + if (.not. fequals(lvals(i), maxv)) then + isotropic = .false. + return + end if + end do + end function metric_isotropic_metric - function metric_isotropic_eigenvalues(vals) result(isotropic) - !!< Is the metric isotropic, that is, all its eigenvalues are the same? - real, dimension(:) :: vals + function metric_isotropic_eigenvalues(vals) result(isotropic) + !!< Is the metric isotropic, that is, all its eigenvalues are the same? + real, dimension(:) :: vals - integer :: i - real :: maxv + integer :: i + real :: maxv - logical :: isotropic + logical :: isotropic - isotropic = .true. + isotropic = .true. - maxv = maxval(vals) - do i=1,size(vals) - if (.not. fequals(vals(i), maxv)) then - isotropic = .false. - return - end if - end do - end function metric_isotropic_eigenvalues + maxv = maxval(vals) + do i=1,size(vals) + if (.not. fequals(vals(i), maxv)) then + isotropic = .false. + return + end if + end do + end function metric_isotropic_eigenvalues - function metric_spheroid_metric(metric) result(spheroid) - !!< Is the metric a spheroid, that is, all but one eigenvalues the same? - real, dimension(:, :) :: metric + function metric_spheroid_metric(metric) result(spheroid) + !!< Is the metric a spheroid, that is, all but one eigenvalues the same? + real, dimension(:, :) :: metric - real, dimension(size(metric,1), size(metric,1)) :: lvecs - real, dimension(size(metric,1)) :: lvals + real, dimension(size(metric,1), size(metric,1)) :: lvecs + real, dimension(size(metric,1)) :: lvals - integer :: i, count - real :: minv + integer :: i, count + real :: minv - logical :: spheroid + logical :: spheroid - spheroid = .false. + spheroid = .false. - call eigendecomposition_symmetric(metric, lvecs, lvals) + call eigendecomposition_symmetric(metric, lvecs, lvals) - minv = minval(lvals) + minv = minval(lvals) - count = 0 - do i=1,size(metric,1) - if (fequals(lvals(i), minv)) then - count = count + 1 + count = 0 + do i=1,size(metric,1) + if (fequals(lvals(i), minv)) then + count = count + 1 + end if + end do + + if (count == (size(metric,1) - 1)) then + spheroid = .true. + return end if - end do + end function metric_spheroid_metric - if (count == (size(metric,1) - 1)) then - spheroid = .true. - return - end if - end function metric_spheroid_metric + function metric_spheroid_eigenvalues(vals) result(spheroid) + !!< Is the metric a spheroid, that is, all but one eigenvalues the same? + real, dimension(:) :: vals - function metric_spheroid_eigenvalues(vals) result(spheroid) - !!< Is the metric a spheroid, that is, all but one eigenvalues the same? - real, dimension(:) :: vals + real, dimension(size(vals)) :: lvals - real, dimension(size(vals)) :: lvals + integer :: i, count + real :: minv - integer :: i, count - real :: minv + logical :: spheroid - logical :: spheroid + spheroid = .false. - spheroid = .false. + lvals = vals - lvals = vals + minv = minval(lvals) - minv = minval(lvals) + count = 0 + do i=1,size(vals) + if (fequals(lvals(i), minv)) then + count = count + 1 + end if + end do - count = 0 - do i=1,size(vals) - if (fequals(lvals(i), minv)) then - count = count + 1 + if (count == (size(vals) - 1)) then + spheroid = .true. + return end if - end do + end function metric_spheroid_eigenvalues - if (count == (size(vals) - 1)) then - spheroid = .true. - return - end if - end function metric_spheroid_eigenvalues + function metric_ellipsoid_metric(mat) result(ellipsoid) + real, intent(in), dimension(:, :) :: mat + logical :: ellipsoid - function metric_ellipsoid_metric(mat) result(ellipsoid) - real, intent(in), dimension(:, :) :: mat - logical :: ellipsoid + ellipsoid = .false. + if ((.not. metric_spheroid(mat)) .and. (.not. metric_isotropic(mat))) ellipsoid = .true. + end function metric_ellipsoid_metric - ellipsoid = .false. - if ((.not. metric_spheroid(mat)) .and. (.not. metric_isotropic(mat))) ellipsoid = .true. - end function metric_ellipsoid_metric + function metric_ellipsoid_eigenvalues(vals) result(ellipsoid) + real, intent(in), dimension(:) :: vals + logical :: ellipsoid - function metric_ellipsoid_eigenvalues(vals) result(ellipsoid) - real, intent(in), dimension(:) :: vals - logical :: ellipsoid + ellipsoid = .false. + if ((.not. metric_spheroid(vals)) .and. (.not. metric_isotropic(vals))) ellipsoid = .true. + end function metric_ellipsoid_eigenvalues - ellipsoid = .false. - if ((.not. metric_spheroid(vals)) .and. (.not. metric_isotropic(vals))) ellipsoid = .true. - end function metric_ellipsoid_eigenvalues + function get_spheroid_index(metric, vecs, vals) result(idx) + !!< Is the metric a spheroid, that is, all but one eigenvalues the same? + real, dimension(:, :) :: metric + real, dimension(size(metric,1), size(metric,1)), optional :: vecs + real, dimension(size(metric,1)), optional :: vals - function get_spheroid_index(metric, vecs, vals) result(idx) - !!< Is the metric a spheroid, that is, all but one eigenvalues the same? - real, dimension(:, :) :: metric - real, dimension(size(metric,1), size(metric,1)), optional :: vecs - real, dimension(size(metric,1)), optional :: vals + real, dimension(size(metric,1), size(metric,1)) :: lvecs + real, dimension(size(metric,1)) :: lvals - real, dimension(size(metric,1), size(metric,1)) :: lvecs - real, dimension(size(metric,1)) :: lvals + integer :: i, count + real :: maxv, minv - integer :: i, count - real :: maxv, minv + integer :: idx, fakeidx(1) - integer :: idx, fakeidx(1) + idx = 0 - idx = 0 + if (present(vecs) .and. present(vals)) then + lvecs = vecs + lvals = vals + else + call eigendecomposition_symmetric(metric, lvecs, lvals) + end if - if (present(vecs) .and. present(vals)) then - lvecs = vecs - lvals = vals - else - call eigendecomposition_symmetric(metric, lvecs, lvals) - end if + maxv = maxval(lvals) + minv = minval(lvals) ! have to try both - maxv = maxval(lvals) - minv = minval(lvals) ! have to try both + count = 0 + do i=1,size(metric,1) + if (fequals(lvals(i), maxv)) then + count = count + 1 + end if + end do - count = 0 - do i=1,size(metric,1) - if (fequals(lvals(i), maxv)) then - count = count + 1 + if (count == (size(metric,1) - 1)) then + fakeidx = maxloc(lvals) + idx = fakeidx(1) + return end if - end do - if (count == (size(metric,1) - 1)) then - fakeidx = maxloc(lvals) - idx = fakeidx(1) - return - end if + ! Wasn't maxval? Try again with minval. - ! Wasn't maxval? Try again with minval. + count = 0 + do i=1,size(metric,1) + if (fequals(lvals(i), minv)) then + count = count + 1 + end if + end do - count = 0 - do i=1,size(metric,1) - if (fequals(lvals(i), minv)) then - count = count + 1 + if (count == (size(metric,1) - 1)) then + fakeidx = minloc(lvals) + idx = fakeidx(1) + return end if + end function get_spheroid_index + + function get_polar_index(vals) result(idx) + !!< Is the metric a polar, that is, all but one eigenvalues the same? + real, dimension(:) :: vals + + real, dimension(size(vals)) :: lvals + + integer :: i, count + real :: maxv, minv + + integer :: idx, fakeidx(1) + + idx = 0 + + lvals = vals + + maxv = maxval(lvals) + minv = minval(lvals) ! have to try both + + count = 0 + do i=1,size(vals) + if (fequals(lvals(i), maxv)) then + count = count + 1 + end if end do - if (count == (size(metric,1) - 1)) then - fakeidx = minloc(lvals) - idx = fakeidx(1) - return - end if - end function get_spheroid_index + if (count == (size(vals) - 1)) then + fakeidx = minloc(lvals) + idx = fakeidx(1) + return + end if - function get_polar_index(vals) result(idx) - !!< Is the metric a polar, that is, all but one eigenvalues the same? - real, dimension(:) :: vals + ! Wasn't maxval? Try again with minval. - real, dimension(size(vals)) :: lvals + count = 0 + do i=1,size(vals) + if (fequals(lvals(i), minv)) then + count = count + 1 + end if + end do - integer :: i, count - real :: maxv, minv + if (count == (size(vals) - 1)) then + fakeidx = maxloc(lvals) + idx = fakeidx(1) + return + end if + end function get_polar_index - integer :: idx, fakeidx(1) + function aspect_ratio_metric(metric) result(ratio) + !!< Returns the aspect ratio: the largest edgelength over the smallest. + real, dimension(:, :) :: metric - idx = 0 + real, dimension(size(metric,1), size(metric,1)) :: lvecs + real, dimension(size(metric,1)) :: lvals - lvals = vals + real :: ratio - maxv = maxval(lvals) - minv = minval(lvals) ! have to try both + call eigendecomposition_symmetric(metric, lvecs, lvals) + assert( all(lvals >= 0) ) - count = 0 - do i=1,size(vals) - if (fequals(lvals(i), maxv)) then - count = count + 1 + if (minval(lvals) == 0) then + ratio = huge(0.0) + else + ratio = sqrt(minval(lvals) / maxval(lvals)) end if - end do + end function aspect_ratio_metric - if (count == (size(vals) - 1)) then - fakeidx = minloc(lvals) - idx = fakeidx(1) - return - end if + function aspect_ratio_eigenvalues(vals) result(ratio) + !!< Returns the aspect ratio: the largest edgelength over the smallest. + real, dimension(:) :: vals - ! Wasn't maxval? Try again with minval. + real :: ratio - count = 0 - do i=1,size(vals) - if (fequals(lvals(i), minv)) then - count = count + 1 + if (minval(vals) == 0) then + ratio = huge(0.0) + else + ratio = sqrt(minval(vals) / maxval(vals)) end if + end function aspect_ratio_eigenvalues + + function norm(vec) result(r2norm) + !!< R-2 norm. R2NORM has an unnecessarily long + !!< interface (this doesn't need to scale to vectors distributed over CPUs). + + real, dimension(:), intent(in) :: vec + real :: r2norm + integer :: i + + r2norm = 0.0 + + do i=1,size(vec) + r2norm = r2norm + vec(i)**2 end do - if (count == (size(vals) - 1)) then - fakeidx = maxloc(lvals) - idx = fakeidx(1) - return - end if - end function get_polar_index - - function aspect_ratio_metric(metric) result(ratio) - !!< Returns the aspect ratio: the largest edgelength over the smallest. - real, dimension(:, :) :: metric - - real, dimension(size(metric,1), size(metric,1)) :: lvecs - real, dimension(size(metric,1)) :: lvals - - real :: ratio - - call eigendecomposition_symmetric(metric, lvecs, lvals) - assert( all(lvals >= 0) ) - - if (minval(lvals) == 0) then - ratio = huge(0.0) - else - ratio = sqrt(minval(lvals) / maxval(lvals)) - end if - end function aspect_ratio_metric - - function aspect_ratio_eigenvalues(vals) result(ratio) - !!< Returns the aspect ratio: the largest edgelength over the smallest. - real, dimension(:) :: vals - - real :: ratio - - if (minval(vals) == 0) then - ratio = huge(0.0) - else - ratio = sqrt(minval(vals) / maxval(vals)) - end if - end function aspect_ratio_eigenvalues - - function norm(vec) result(r2norm) - !!< R-2 norm. R2NORM has an unnecessarily long - !!< interface (this doesn't need to scale to vectors distributed over CPUs). - - real, dimension(:), intent(in) :: vec - real :: r2norm - integer :: i - - r2norm = 0.0 - - do i=1,size(vec) - r2norm = r2norm + vec(i)**2 - end do - - r2norm = sqrt(r2norm) - end function norm - - function get_angle(vecA, vecB) result(angle) - !!< Return the angle between two vectors. - !!< Computed with the dot product formula. - !!< This just treats vectors in terms of direction, - !!< i.e. vecA is considered the same as -vecA for my purposes here. - !!< See also get_angle_2d, get_real_angle. - real, dimension(:), intent(in) :: vecA, vecB - real :: angle, pi - - pi = 4.0 * atan(1.0) - - if (vecA .feq. vecB) then - angle = 0.0 - return - end if - - if (vecA .feq. (-1 * vecB)) then - angle = 0.0 - return - end if - - angle = acos(dot_product(vecA, vecB)/ (norm(vecA) * norm(vecB))) - if (angle > pi / 2.0) angle = pi - angle ! ignore sign, truncate to [0, Pi/2] - if (is_nan(angle)) angle = 0.0 - end function get_angle - - function get_real_angle(vecA, vecB) result(angle) - !!< Return the angle between two vectors. - !!< Computed with the dot product formula. - !!< See also get_angle_2d, get_angle. - real, dimension(:), intent(in) :: vecA, vecB - real :: angle - - if (vecA .feq. vecB) then - angle = 0.0 - return - end if - - angle = acos(dot_product(vecA, vecB)/ (norm(vecA) * norm(vecB))) - end function get_real_angle - - function get_angle_2d(vecA, vecB) result(angle) - !!< Return the angle between two vectors. - !!< Computed with the arctan formula. - real, dimension(:), intent(in) :: vecA, vecB - real :: angle - - if (vecA .feq. vecB) then - angle = 0.0 - return - end if - - angle = atan2(vecB(2), vecB(1)) - atan2(vecA(2), vecA(1)) - end function get_angle_2d - - function get_rotation_matrix(A, B) result(mat) - !!< Really, this should be done with an interface block. - !!< But fortran is a stupid language! It doesn't work! - real, dimension(:), intent(in) :: A, B - real, dimension(size(A), size(A)) :: mat - - real, dimension(size(A)) :: normed_A, normed_B - real :: norm_AplusB, norm_AminusB - - normed_A = A / norm(A) - normed_B = B / norm(B) - - norm_AplusB = norm(A + B) - norm_AminusB = norm(A - B) - - !write(0,*) "norm_AminusB == ", norm_AminusB - - if (norm_AminusB < 1e-4) then - mat = get_matrix_identity(size(A)) - return - end if - - !write(0,*) "norm_AplusB == ", norm_AplusB - - if (norm_AplusB < 1e-4) then - mat = -1 * get_matrix_identity(size(A)) - return - end if - - if (size(A) == 2) mat = get_rotation_matrix_2d(normed_A, normed_B) - if (size(A) == 3) mat = get_rotation_matrix_3d(normed_A, normed_B) - call mat_clean(mat, epsilon(0.0)) - end function get_rotation_matrix + r2norm = sqrt(r2norm) + end function norm - function get_rotation_matrix_cross(vec, angle) result(mat) - !!< Given a vector as the axis of rotation and the angle, - !!< return the rotation matrix. - real, dimension(3), intent(in) :: vec - real, intent(in) :: angle - real, dimension(3, 3) :: mat - real, dimension(3) :: cross - real :: x, y, z - real :: c, s + function get_angle(vecA, vecB) result(angle) + !!< Return the angle between two vectors. + !!< Computed with the dot product formula. + !!< This just treats vectors in terms of direction, + !!< i.e. vecA is considered the same as -vecA for my purposes here. + !!< See also get_angle_2d, get_real_angle. + real, dimension(:), intent(in) :: vecA, vecB + real :: angle, pi - if (abs(angle) < 0.01) then - mat = get_matrix_identity(3) - if (angle < 0) mat = -1 * mat - return - end if + pi = 4.0 * atan(1.0) - c = cos(angle) ; s = sin(angle) + if (vecA .feq. vecB) then + angle = 0.0 + return + end if - cross = vec / norm(vec) + if (vecA .feq. (-1 * vecB)) then + angle = 0.0 + return + end if - x = cross(1) ; y = cross(2) ; z = cross(3) + angle = acos(dot_product(vecA, vecB)/ (norm(vecA) * norm(vecB))) + if (angle > pi / 2.0) angle = pi - angle ! ignore sign, truncate to [0, Pi/2] + if (is_nan(angle)) angle = 0.0 + end function get_angle + + function get_real_angle(vecA, vecB) result(angle) + !!< Return the angle between two vectors. + !!< Computed with the dot product formula. + !!< See also get_angle_2d, get_angle. + real, dimension(:), intent(in) :: vecA, vecB + real :: angle + + if (vecA .feq. vecB) then + angle = 0.0 + return + end if - mat(1, 1) = c + (1 - c) * x * x - mat(2, 2) = c + (1 - c) * y * y - mat(3, 3) = c + (1 - c) * z * z + angle = acos(dot_product(vecA, vecB)/ (norm(vecA) * norm(vecB))) + end function get_real_angle - mat(1, 2) = (1 - c) * x * y - s * z - mat(1, 3) = (1 - c) * x * z + s * y + function get_angle_2d(vecA, vecB) result(angle) + !!< Return the angle between two vectors. + !!< Computed with the arctan formula. + real, dimension(:), intent(in) :: vecA, vecB + real :: angle - mat(2, 1) = (1 - c) * y * x + s * z - mat(2, 3) = (1 - c) * y * z - s * x + if (vecA .feq. vecB) then + angle = 0.0 + return + end if - mat(3, 1) = (1 - c) * z * x - s * y - mat(3, 2) = (1 - c) * z * y + s * x - end function get_rotation_matrix_cross + angle = atan2(vecB(2), vecB(1)) - atan2(vecA(2), vecA(1)) + end function get_angle_2d - function get_rotation_matrix_2d(A, B) result(mat) - !!< Return the rotation matrix that would map A -> B. - real, dimension(2), intent(in) :: A, B + function get_rotation_matrix(A, B) result(mat) + !!< Really, this should be done with an interface block. + !!< But fortran is a stupid language! It doesn't work! + real, dimension(:), intent(in) :: A, B + real, dimension(size(A), size(A)) :: mat - real :: angle - real, dimension(2, 2) :: mat + real, dimension(size(A)) :: normed_A, normed_B + real :: norm_AplusB, norm_AminusB - if (A .feq. B) then - mat = get_matrix_identity(2) - return - end if + normed_A = A / norm(A) + normed_B = B / norm(B) - if (A .feq. (-1 * B)) then - mat = -1 * get_matrix_identity(2) - return - end if + norm_AplusB = norm(A + B) + norm_AminusB = norm(A - B) - angle = get_angle_2d(A, B) - mat(1, 1) = cos(angle) ; mat(1, 2) = -1 * sin(angle) - mat(2, 1) = sin(angle) ; mat(2, 2) = cos(angle) - end function get_rotation_matrix_2d + !write(0,*) "norm_AminusB == ", norm_AminusB - function get_rotation_matrix_3d(A, B) result(mat) - !!< Return the rotation matrix that would map A -> B. - real, dimension(3), intent(in) :: A, B + if (norm_AminusB < 1e-4) then + mat = get_matrix_identity(size(A)) + return + end if - real :: angle, c, s, x, y, z - real, dimension(3, 3) :: mat - real, dimension(3) :: cross + !write(0,*) "norm_AplusB == ", norm_AplusB - if (A .feq. B) then - mat = get_matrix_identity(3) - return - end if + if (norm_AplusB < 1e-4) then + mat = -1 * get_matrix_identity(size(A)) + return + end if - if (A .feq. (-1 * B)) then - mat = -1 * get_matrix_identity(3) - return - end if + if (size(A) == 2) mat = get_rotation_matrix_2d(normed_A, normed_B) + if (size(A) == 3) mat = get_rotation_matrix_3d(normed_A, normed_B) + call mat_clean(mat, epsilon(0.0)) + end function get_rotation_matrix + + function get_rotation_matrix_cross(vec, angle) result(mat) + !!< Given a vector as the axis of rotation and the angle, + !!< return the rotation matrix. + real, dimension(3), intent(in) :: vec + real, intent(in) :: angle + real, dimension(3, 3) :: mat + real, dimension(3) :: cross + real :: x, y, z + real :: c, s + + if (abs(angle) < 0.01) then + mat = get_matrix_identity(3) + if (angle < 0) mat = -1 * mat + return + end if - angle = get_real_angle(A, B) - c = cos(angle) ; s = sin(angle) + c = cos(angle) ; s = sin(angle) - cross = cross_product(A, B) - cross = cross / norm(cross) + cross = vec / norm(vec) - x = cross(1) ; y = cross(2) ; z = cross(3) + x = cross(1) ; y = cross(2) ; z = cross(3) - mat(1, 1) = c + (1 - c) * x * x - mat(2, 2) = c + (1 - c) * y * y - mat(3, 3) = c + (1 - c) * z * z + mat(1, 1) = c + (1 - c) * x * x + mat(2, 2) = c + (1 - c) * y * y + mat(3, 3) = c + (1 - c) * z * z - mat(1, 2) = (1 - c) * x * y - s * z - mat(1, 3) = (1 - c) * x * z + s * y + mat(1, 2) = (1 - c) * x * y - s * z + mat(1, 3) = (1 - c) * x * z + s * y - mat(2, 1) = (1 - c) * y * x + s * z - mat(2, 3) = (1 - c) * y * z - s * x + mat(2, 1) = (1 - c) * y * x + s * z + mat(2, 3) = (1 - c) * y * z - s * x - mat(3, 1) = (1 - c) * z * x - s * y - mat(3, 2) = (1 - c) * z * y + s * x + mat(3, 1) = (1 - c) * z * x - s * y + mat(3, 2) = (1 - c) * z * y + s * x + end function get_rotation_matrix_cross - end function get_rotation_matrix_3d + function get_rotation_matrix_2d(A, B) result(mat) + !!< Return the rotation matrix that would map A -> B. + real, dimension(2), intent(in) :: A, B - function project_to_subspace(vec, basis) result(proj) - !!< Project the vector vec onto the subspace spanned - !!< by the basis vectors basis. - real, dimension(:), intent(in) :: vec - real, dimension(:, :), intent(in) :: basis + real :: angle + real, dimension(2, 2) :: mat - real, dimension(size(vec)) :: proj + if (A .feq. B) then + mat = get_matrix_identity(2) + return + end if - real, dimension(size(vec), size(vec)) :: proj_operator + if (A .feq. (-1 * B)) then + mat = -1 * get_matrix_identity(2) + return + end if - integer :: dim + angle = get_angle_2d(A, B) + mat(1, 1) = cos(angle) ; mat(1, 2) = -1 * sin(angle) + mat(2, 1) = sin(angle) ; mat(2, 2) = cos(angle) + end function get_rotation_matrix_2d - dim = size(vec) - assert(size(basis, 1) == dim) + function get_rotation_matrix_3d(A, B) result(mat) + !!< Return the rotation matrix that would map A -> B. + real, dimension(3), intent(in) :: A, B - proj_operator = matmul(basis, transpose(basis)) - proj = matmul(proj_operator, vec) + real :: angle, c, s, x, y, z + real, dimension(3, 3) :: mat + real, dimension(3) :: cross - end function project_to_subspace + if (A .feq. B) then + mat = get_matrix_identity(3) + return + end if - function dominant_eigenvector(vecs, vals) result(vec) - !!< Return the dominant eigenvector (the - !!< eigenvector corresponding to the largest eigenvalue). - real, dimension(:, :), intent(in) :: vecs - real, dimension(size(vecs, 1)), intent(in) :: vals - real, dimension(size(vecs, 1)) :: vec - integer :: i(1) + if (A .feq. (-1 * B)) then + mat = -1 * get_matrix_identity(3) + return + end if - i = maxloc(vals) + angle = get_real_angle(A, B) + c = cos(angle) ; s = sin(angle) - vec = vecs(:, i(1)) - end function dominant_eigenvector + cross = cross_product(A, B) + cross = cross / norm(cross) - function midval(vals) result(mid) - !!< Return the middle eigenvalue, the one that's - !!< not the max or the min. - real, dimension(:), intent(in) :: vals - real :: mid + x = cross(1) ; y = cross(2) ; z = cross(3) - real :: maxv + mat(1, 1) = c + (1 - c) * x * x + mat(2, 2) = c + (1 - c) * y * y + mat(3, 3) = c + (1 - c) * z * z - maxv = maxval(vals) - mid = maxval(vals, mask=(vals /= maxv)) - end function midval + mat(1, 2) = (1 - c) * x * y - s * z + mat(1, 3) = (1 - c) * x * z + s * y - subroutine get_node_field(mesh, field) - !!< Return a field containing each node number. - type(mesh_type), intent(in) :: mesh - type(scalar_field), intent(inout) :: field - integer :: i + mat(2, 1) = (1 - c) * y * x + s * z + mat(2, 3) = (1 - c) * y * z - s * x - do i=1,mesh%nodes - field%val(i) = float(i) - end do - end subroutine get_node_field + mat(3, 1) = (1 - c) * z * x - s * y + mat(3, 2) = (1 - c) * z * y + s * x - function domain_length_scale(positions) result(scale) - !!< Return the domain length scale. - type(vector_field), intent(in) :: positions - real :: scale - real, dimension(positions%dim) :: domainwidth - integer :: i + end function get_rotation_matrix_3d - do i=1,positions%dim - domainwidth(i) = maxval(positions%val(i,:)) - minval(positions%val(i,:)) - end do + function project_to_subspace(vec, basis) result(proj) + !!< Project the vector vec onto the subspace spanned + !!< by the basis vectors basis. + real, dimension(:), intent(in) :: vec + real, dimension(:, :), intent(in) :: basis - scale = maxval(domainwidth) - end function domain_length_scale + real, dimension(size(vec)) :: proj - subroutine check_perm(perm, stat) - !!< Check if perm represents a permutation. - integer, dimension(:), intent(in) :: perm - integer, optional :: stat -#ifdef DDEBUG - integer :: dim -#endif + real, dimension(size(vec), size(vec)) :: proj_operator - if (present(stat)) stat = 0 + integer :: dim -#ifdef DDEBUG - dim = size(perm) - if ((dim * (dim + 1)) / 2 /= sum(perm)) then - if (present(stat)) then - stat = 1 - else - write(0,*) "perm == ", perm - FLAbort("Not a permutation!") - end if - end if + dim = size(vec) + assert(size(basis, 1) == dim) - if (factorial(dim) /= product(perm)) then - if (present(stat)) then - stat = 1 - else - write(0,*) "perm == ", perm - FLAbort("Not a permutation!") - end if - end if -#endif - end subroutine check_perm - - function factorial(n) result(fact) - integer, intent(in) :: n - integer :: fact - integer :: i - - fact = 1 - do i=2,n - fact = fact * i - end do - end function factorial - - function have_adapt_opt(path, ext) - character(len=*), intent(in) :: path, ext - logical :: have_adapt_opt - have_adapt_opt = (have_option((path) // "/virtual" // (ext)) .or. & - & have_option((path) // "/prescribed" // (ext)) .or. & - & have_option((path) // "/prognostic" // (ext)) .or. & - & have_option((path) // "/diagnostic" // (ext))) - end function have_adapt_opt - - subroutine get_adapt_opt_real_scalar(path, ext, var) - character(len=*), intent(in) :: path, ext - real, intent(out) :: var - integer :: stat - - call get_option(path // "/virtual" // ext, var, stat) - if (stat == 0) return - call get_option(path // "/prescribed" // ext, var, stat) - if (stat == 0) return - call get_option(path // "/prognostic" // ext, var, stat) - if (stat == 0) return - call get_option(path // "/diagnostic" // ext, var, stat) - if (stat == 0) return - - ewrite(-1,*) "path == ", path - ewrite(-1,*) "ext == ", ext - FLAbort("no such variable") - end subroutine get_adapt_opt_real_scalar - - subroutine get_adapt_opt_real_vector(path, ext, var) - character(len=*), intent(in) :: path, ext - real, dimension(:), intent(out) :: var - integer :: stat - - call get_option(path // "/virtual" // ext, var, stat) - if (stat == 0) return - call get_option(path // "/prescribed" // ext, var, stat) - if (stat == 0) return - call get_option(path // "/prognostic" // ext, var, stat) - if (stat == 0) return - call get_option(path // "/diagnostic" // ext, var, stat) - if (stat == 0) return - - ewrite(-1,*) "path == ", path - ewrite(-1,*) "ext == ", ext - !call print_children(path) - FLAbort("no such variable") - end subroutine get_adapt_opt_real_vector - - function error_bound_name(dep) result(ret) - character(len=*), intent(in) :: dep - character(len=len_trim(dep) + len("InterpolationErrorBound")) :: ret - - integer :: idx - idx = index(dep, "%") - if (idx == 0) then - ret = dep // "InterpolationErrorBound" - else - ret = dep(1:idx-1) // "InterpolationErrorBound%" // dep(idx+1:len_trim(dep)) - end if - end function error_bound_name - - function metric_from_edge_lengths(edgelen) result(metric) - real, dimension(:, :), intent(in) :: edgelen - real, dimension(size(edgelen, 1), size(edgelen, 1)) :: metric, evecs - real, dimension(size(edgelen, 1)) :: evals - - call eigendecomposition_symmetric(edgelen, evecs, evals) - evals = eigenvalue_from_edge_length(evals) - call eigenrecomposition(metric, evecs, evals) - end function metric_from_edge_lengths - - function edge_lengths_from_metric(metric) result(edgelen) - real, dimension(:, :), intent(in) :: metric - real, dimension(size(metric, 1), size(metric, 1)) :: edgelen, evecs - real, dimension(size(metric, 1)) :: evals - call eigendecomposition_symmetric(metric, evecs, evals) - evals = edge_length_from_eigenvalue(evals) - call eigenrecomposition(edgelen, evecs, evals) - end function edge_lengths_from_metric - - function simplex_tensor(positions, ele, power) result(m) - !!< Compute the metric tensor - !!< associated with the element. - !!< Note: this only works for linear position - !!< (otherwise you have to do everything in integral form, - !!< and I couldn't be bothered) - - !!< Note well: the units of the returned tensor - !!< are L^-2 (if no power argument is given) - - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - real, intent(in), optional :: power - - real, dimension(positions%dim, positions%dim) :: m, evecs - real, dimension(dof(positions%dim), dof(positions%dim)) :: A - real, dimension(dof(positions%dim)) :: x - real, dimension(positions%dim, ele_loc(positions, ele)) :: pos_ele - real, dimension(positions%dim) :: diff, evals - - integer :: loc, i, j, k, l, p, n, dim, d - - loc = ele_loc(positions, ele) - pos_ele = ele_val(positions, ele) - dim = positions%dim - d = dof(dim) - - ! Assemble - n = 1 - do i=1,loc - do j=i+1,loc - diff = pos_ele(:, j) - pos_ele(:, i) - do k=1,dim - do l=1,dim - p = idx(k, l, dim) - A(n, p) = diff(k) * diff(l) * coeff(k, l) - end do - end do - - n = n + 1 - end do - end do + proj_operator = matmul(basis, transpose(basis)) + proj = matmul(proj_operator, vec) + + end function project_to_subspace + + function dominant_eigenvector(vecs, vals) result(vec) + !!< Return the dominant eigenvector (the + !!< eigenvector corresponding to the largest eigenvalue). + real, dimension(:, :), intent(in) :: vecs + real, dimension(size(vecs, 1)), intent(in) :: vals + real, dimension(size(vecs, 1)) :: vec + integer :: i(1) + + i = maxloc(vals) - x = 1 + vec = vecs(:, i(1)) + end function dominant_eigenvector - call solve(A, x) + function midval(vals) result(mid) + !!< Return the middle eigenvalue, the one that's + !!< not the max or the min. + real, dimension(:), intent(in) :: vals + real :: mid - do i=1,dim - do j=1,dim - m(i, j) = x(idx(i, j, dim)) + real :: maxv + + maxv = maxval(vals) + mid = maxval(vals, mask=(vals /= maxv)) + end function midval + + subroutine get_node_field(mesh, field) + !!< Return a field containing each node number. + type(mesh_type), intent(in) :: mesh + type(scalar_field), intent(inout) :: field + integer :: i + + do i=1,mesh%nodes + field%val(i) = float(i) end do - end do + end subroutine get_node_field - if (present(power)) then - call eigendecomposition_symmetric(m, evecs, evals) - evals = evals**power - call eigenrecomposition(m, evecs, evals) - end if + function domain_length_scale(positions) result(scale) + !!< Return the domain length scale. + type(vector_field), intent(in) :: positions + real :: scale + real, dimension(positions%dim) :: domainwidth + integer :: i - contains + do i=1,positions%dim + domainwidth(i) = maxval(positions%val(i,:)) - minval(positions%val(i,:)) + end do - function idx(i, j, dim) - integer, intent(in) :: i, j, dim - integer :: idx, k, l + scale = maxval(domainwidth) + end function domain_length_scale - k = min(i, j) - l = max(i, j) + subroutine check_perm(perm, stat) + !!< Check if perm represents a permutation. + integer, dimension(:), intent(in) :: perm + integer, optional :: stat +#ifdef DDEBUG + integer :: dim +#endif - if (k == 1) then - idx = l - else - if (dim == 3) then - idx = l + k - else - idx = l + k - 1 - end if + if (present(stat)) stat = 0 + +#ifdef DDEBUG + dim = size(perm) + if ((dim * (dim + 1)) / 2 /= sum(perm)) then + if (present(stat)) then + stat = 1 + else + write(0,*) "perm == ", perm + FLAbort("Not a permutation!") + end if + end if + + if (factorial(dim) /= product(perm)) then + if (present(stat)) then + stat = 1 + else + write(0,*) "perm == ", perm + FLAbort("Not a permutation!") + end if end if - end function idx +#endif + end subroutine check_perm - function coeff(k, l) - integer, intent(in) :: k, l - integer :: coeff - if (k == l) then - coeff = 1 + function factorial(n) result(fact) + integer, intent(in) :: n + integer :: fact + integer :: i + + fact = 1 + do i=2,n + fact = fact * i + end do + end function factorial + + function have_adapt_opt(path, ext) + character(len=*), intent(in) :: path, ext + logical :: have_adapt_opt + have_adapt_opt = (have_option((path) // "/virtual" // (ext)) .or. & + & have_option((path) // "/prescribed" // (ext)) .or. & + & have_option((path) // "/prognostic" // (ext)) .or. & + & have_option((path) // "/diagnostic" // (ext))) + end function have_adapt_opt + + subroutine get_adapt_opt_real_scalar(path, ext, var) + character(len=*), intent(in) :: path, ext + real, intent(out) :: var + integer :: stat + + call get_option(path // "/virtual" // ext, var, stat) + if (stat == 0) return + call get_option(path // "/prescribed" // ext, var, stat) + if (stat == 0) return + call get_option(path // "/prognostic" // ext, var, stat) + if (stat == 0) return + call get_option(path // "/diagnostic" // ext, var, stat) + if (stat == 0) return + + ewrite(-1,*) "path == ", path + ewrite(-1,*) "ext == ", ext + FLAbort("no such variable") + end subroutine get_adapt_opt_real_scalar + + subroutine get_adapt_opt_real_vector(path, ext, var) + character(len=*), intent(in) :: path, ext + real, dimension(:), intent(out) :: var + integer :: stat + + call get_option(path // "/virtual" // ext, var, stat) + if (stat == 0) return + call get_option(path // "/prescribed" // ext, var, stat) + if (stat == 0) return + call get_option(path // "/prognostic" // ext, var, stat) + if (stat == 0) return + call get_option(path // "/diagnostic" // ext, var, stat) + if (stat == 0) return + + ewrite(-1,*) "path == ", path + ewrite(-1,*) "ext == ", ext + !call print_children(path) + FLAbort("no such variable") + end subroutine get_adapt_opt_real_vector + + function error_bound_name(dep) result(ret) + character(len=*), intent(in) :: dep + character(len=len_trim(dep) + len("InterpolationErrorBound")) :: ret + + integer :: idx + idx = index(dep, "%") + if (idx == 0) then + ret = dep // "InterpolationErrorBound" else - coeff = 2 + ret = dep(1:idx-1) // "InterpolationErrorBound%" // dep(idx+1:len_trim(dep)) end if - end function coeff + end function error_bound_name + + function metric_from_edge_lengths(edgelen) result(metric) + real, dimension(:, :), intent(in) :: edgelen + real, dimension(size(edgelen, 1), size(edgelen, 1)) :: metric, evecs + real, dimension(size(edgelen, 1)) :: evals + + call eigendecomposition_symmetric(edgelen, evecs, evals) + evals = eigenvalue_from_edge_length(evals) + call eigenrecomposition(metric, evecs, evals) + end function metric_from_edge_lengths + + function edge_lengths_from_metric(metric) result(edgelen) + real, dimension(:, :), intent(in) :: metric + real, dimension(size(metric, 1), size(metric, 1)) :: edgelen, evecs + real, dimension(size(metric, 1)) :: evals + call eigendecomposition_symmetric(metric, evecs, evals) + evals = edge_length_from_eigenvalue(evals) + call eigenrecomposition(edgelen, evecs, evals) + end function edge_lengths_from_metric + + function simplex_tensor(positions, ele, power) result(m) + !!< Compute the metric tensor + !!< associated with the element. + !!< Note: this only works for linear position + !!< (otherwise you have to do everything in integral form, + !!< and I couldn't be bothered) + + !!< Note well: the units of the returned tensor + !!< are L^-2 (if no power argument is given) + + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + real, intent(in), optional :: power + + real, dimension(positions%dim, positions%dim) :: m, evecs + real, dimension(dof(positions%dim), dof(positions%dim)) :: A + real, dimension(dof(positions%dim)) :: x + real, dimension(positions%dim, ele_loc(positions, ele)) :: pos_ele + real, dimension(positions%dim) :: diff, evals + + integer :: loc, i, j, k, l, p, n, dim, d + + loc = ele_loc(positions, ele) + pos_ele = ele_val(positions, ele) + dim = positions%dim + d = dof(dim) + + ! Assemble + n = 1 + do i=1,loc + do j=i+1,loc + diff = pos_ele(:, j) - pos_ele(:, i) + do k=1,dim + do l=1,dim + p = idx(k, l, dim) + A(n, p) = diff(k) * diff(l) * coeff(k, l) + end do + end do + + n = n + 1 + end do + end do - end function simplex_tensor + x = 1 - pure function dof(n) - integer, intent(in) :: n - integer :: dof + call solve(A, x) - dof = (n * (n+1)) / 2 - end function dof + do i=1,dim + do j=1,dim + m(i, j) = x(idx(i, j, dim)) + end do + end do - function apply_transform(pos, metric) result(new_pos) - !! Given a metric and the positions of some points, - !! map the points to their image under the transformation - !! given by metric. - real, dimension(:, :), intent(in) :: pos - real, dimension(:, :), intent(in) :: metric - real, dimension(size(pos, 1), size(pos, 2)) :: new_pos - integer :: loc, i + if (present(power)) then + call eigendecomposition_symmetric(m, evecs, evals) + evals = evals**power + call eigenrecomposition(m, evecs, evals) + end if - loc = size(pos, 2) - do i=1,loc - new_pos(:, i) = matmul(metric, pos(:, i)) - end do - end function apply_transform + contains + + function idx(i, j, dim) + integer, intent(in) :: i, j, dim + integer :: idx, k, l + + k = min(i, j) + l = max(i, j) + + if (k == 1) then + idx = l + else + if (dim == 3) then + idx = l + k + else + idx = l + k - 1 + end if + end if + end function idx + + function coeff(k, l) + integer, intent(in) :: k, l + integer :: coeff + if (k == l) then + coeff = 1 + else + coeff = 2 + end if + end function coeff + + end function simplex_tensor + + pure function dof(n) + integer, intent(in) :: n + integer :: dof + + dof = (n * (n+1)) / 2 + end function dof + + function apply_transform(pos, metric) result(new_pos) + !! Given a metric and the positions of some points, + !! map the points to their image under the transformation + !! given by metric. + real, dimension(:, :), intent(in) :: pos + real, dimension(:, :), intent(in) :: metric + real, dimension(size(pos, 1), size(pos, 2)) :: new_pos + integer :: loc, i + + loc = size(pos, 2) + do i=1,loc + new_pos(:, i) = matmul(metric, pos(:, i)) + end do + end function apply_transform - subroutine form_anisotropic_metric_from_isotropic_metric(isotropic_metric, anisotropic_metric) - type(scalar_field), intent(in) :: isotropic_metric - type(tensor_field), intent(out) :: anisotropic_metric + subroutine form_anisotropic_metric_from_isotropic_metric(isotropic_metric, anisotropic_metric) + type(scalar_field), intent(in) :: isotropic_metric + type(tensor_field), intent(out) :: anisotropic_metric - integer :: i - real, dimension(mesh_dim(isotropic_metric)) :: eigenvals - real, dimension(mesh_dim(isotropic_metric), mesh_dim(isotropic_metric)) :: eigenvecs, tensor + integer :: i + real, dimension(mesh_dim(isotropic_metric)) :: eigenvals + real, dimension(mesh_dim(isotropic_metric), mesh_dim(isotropic_metric)) :: eigenvecs, tensor - assert(anisotropic_metric%dim(1)==anisotropic_metric%dim(2)) + assert(anisotropic_metric%dim(1)==anisotropic_metric%dim(2)) - call allocate(anisotropic_metric, isotropic_metric%mesh, isotropic_metric%name) + call allocate(anisotropic_metric, isotropic_metric%mesh, isotropic_metric%name) - eigenvecs = get_matrix_identity(anisotropic_metric%dim(1)) + eigenvecs = get_matrix_identity(anisotropic_metric%dim(1)) - call zero(anisotropic_metric) - do i = 1, node_count(isotropic_metric) - eigenvals = node_val(isotropic_metric, i) - call eigenrecomposition(tensor, eigenvecs, eigenvals) - call set(anisotropic_metric, i, tensor) - end do + call zero(anisotropic_metric) + do i = 1, node_count(isotropic_metric) + eigenvals = node_val(isotropic_metric, i) + call eigenrecomposition(tensor, eigenvecs, eigenvals) + call set(anisotropic_metric, i, tensor) + end do - end subroutine form_anisotropic_metric_from_isotropic_metric + end subroutine form_anisotropic_metric_from_isotropic_metric - function absolutify_tensor(tens) result(absolute_tens) - !! Given a tensor, map all its eigenvalues to their absolute values. - real, dimension(:, :), intent(in) :: tens - real, dimension(size(tens, 1), size(tens, 2)) :: absolute_tens, evecs - real, dimension(size(tens, 1)) :: evals + function absolutify_tensor(tens) result(absolute_tens) + !! Given a tensor, map all its eigenvalues to their absolute values. + real, dimension(:, :), intent(in) :: tens + real, dimension(size(tens, 1), size(tens, 2)) :: absolute_tens, evecs + real, dimension(size(tens, 1)) :: evals - call eigendecomposition_symmetric(tens, evecs, evals) - evals = abs(evals) - call eigenrecomposition(absolute_tens, evecs, evals) - end function absolutify_tensor + call eigendecomposition_symmetric(tens, evecs, evals) + evals = abs(evals) + call eigenrecomposition(absolute_tens, evecs, evals) + end function absolutify_tensor - function lipnikov_functional(ele, positions, metric) result(func) - !!< Evaluate the Lipnikov functional for the supplied element + function lipnikov_functional(ele, positions, metric) result(func) + !!< Evaluate the Lipnikov functional for the supplied element - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric - real :: func + real :: func - assert(ele_numbering_family(positions, ele) == FAMILY_SIMPLEX) + assert(ele_numbering_family(positions, ele) == FAMILY_SIMPLEX) - select case(positions%dim) - case(2) - assert(ele_loc(positions, ele) == 3) - func = lipnikov_functional_2d(ele, positions, metric) - case(3) - assert(ele_loc(positions, ele) == 4) - func = lipnikov_functional_3d(ele, positions, metric) - case default - FLExit("The Lipnikov functional is only available in 2 or 3d.") - end select + select case(positions%dim) + case(2) + assert(ele_loc(positions, ele) == 3) + func = lipnikov_functional_2d(ele, positions, metric) + case(3) + assert(ele_loc(positions, ele) == 4) + func = lipnikov_functional_3d(ele, positions, metric) + case default + FLExit("The Lipnikov functional is only available in 2 or 3d.") + end select - end function lipnikov_functional + end function lipnikov_functional - function lipnikov_functional_2d(ele, positions, metric) result(func) - !!< Evaluate the Lipnikov functional for the supplied 2d triangle. See: - !!< Yu. V. Vasileskii and K. N. Lipnikov, An Adaptive Algorithm for - !!< Quasioptimal Mesh Generation, Computational Mathematics and - !!< Mathematical Physics, Vol. 39, No. 9, 1999, pp. 1468 - 1486 + function lipnikov_functional_2d(ele, positions, metric) result(func) + !!< Evaluate the Lipnikov functional for the supplied 2d triangle. See: + !!< Yu. V. Vasileskii and K. N. Lipnikov, An Adaptive Algorithm for + !!< Quasioptimal Mesh Generation, Computational Mathematics and + !!< Mathematical Physics, Vol. 39, No. 9, 1999, pp. 1468 - 1486 - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric - real :: func + real :: func - integer, dimension(:), pointer :: element_nodes - real :: edge_sum, vol - real, dimension(2) :: tmp_pos - real, dimension(2, 2) :: pos - real, dimension(2, 2) :: m + integer, dimension(:), pointer :: element_nodes + real :: edge_sum, vol + real, dimension(2) :: tmp_pos + real, dimension(2, 2) :: pos + real, dimension(2, 2) :: m - real :: scale_factor = 12.0 * sqrt(3.0) + real :: scale_factor = 12.0 * sqrt(3.0) - m = sum(ele_val(metric, ele), 3) / 3.0 + m = sum(ele_val(metric, ele), 3) / 3.0 - element_nodes => ele_nodes(positions, ele) - tmp_pos = node_val(positions, element_nodes(1)) - pos(:, 1) = node_val(positions, element_nodes(2)) - tmp_pos - pos(:, 2) = node_val(positions, element_nodes(3)) - tmp_pos + element_nodes => ele_nodes(positions, ele) + tmp_pos = node_val(positions, element_nodes(1)) + pos(:, 1) = node_val(positions, element_nodes(2)) - tmp_pos + pos(:, 2) = node_val(positions, element_nodes(3)) - tmp_pos - edge_sum = metric_edge_length(pos(:, 1), m) + & - & metric_edge_length(pos(:, 2), m) + & - & metric_edge_length(pos(:, 2) - pos(:, 1), m) - vol = abs(sqrt(det(m)) * det(pos) / 2.0) + edge_sum = metric_edge_length(pos(:, 1), m) + & + & metric_edge_length(pos(:, 2), m) + & + & metric_edge_length(pos(:, 2) - pos(:, 1), m) + vol = abs(sqrt(det(m)) * det(pos) / 2.0) - func = (scale_factor * vol / (edge_sum ** 2)) * F(edge_sum / 3.0) + func = (scale_factor * vol / (edge_sum ** 2)) * F(edge_sum / 3.0) - contains + contains - pure function F(x) - real, intent(in) :: x + pure function F(x) + real, intent(in) :: x - real :: F + real :: F - real :: x1 + real :: x1 - x1 = min(x, 1.0 / x) - F = x1 * (2.0 - x1) - F = F ** 3 + x1 = min(x, 1.0 / x) + F = x1 * (2.0 - x1) + F = F ** 3 - end function F + end function F - end function lipnikov_functional_2d + end function lipnikov_functional_2d - function lipnikov_functional_3d(ele, positions, metric) result(func) - !!< Evaluate the Lipnikov functional for the supplied 3d tetrahedron. See: - !!< A. Agouzal, K Lipnikov, Yu. Vassilevski, Adaptive generation of - !!< quasi-optimal tetrahedral meshes, East-West J. Numer. Math., Vol. 7, - !!< No. 4, pp. 223-244 (1999) + function lipnikov_functional_3d(ele, positions, metric) result(func) + !!< Evaluate the Lipnikov functional for the supplied 3d tetrahedron. See: + !!< A. Agouzal, K Lipnikov, Yu. Vassilevski, Adaptive generation of + !!< quasi-optimal tetrahedral meshes, East-West J. Numer. Math., Vol. 7, + !!< No. 4, pp. 223-244 (1999) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric - real :: func + real :: func - integer, dimension(:), pointer :: element_nodes - real :: edge_sum, vol - real, dimension(3) :: tmp_pos - real, dimension(3, 3) :: pos - real, dimension(3, 3) :: m + integer, dimension(:), pointer :: element_nodes + real :: edge_sum, vol + real, dimension(3) :: tmp_pos + real, dimension(3, 3) :: pos + real, dimension(3, 3) :: m - real :: scale_factor = (6.0 ** 4) * sqrt(2.0) + real :: scale_factor = (6.0 ** 4) * sqrt(2.0) - m = sum(ele_val(metric, ele), 3) / 4.0 + m = sum(ele_val(metric, ele), 3) / 4.0 - element_nodes => ele_nodes(positions, ele) - tmp_pos = node_val(positions, element_nodes(1)) - pos(:, 1) = node_val(positions, element_nodes(2)) - tmp_pos - pos(:, 2) = node_val(positions, element_nodes(3)) - tmp_pos - pos(:, 3) = node_val(positions, element_nodes(4)) - tmp_pos + element_nodes => ele_nodes(positions, ele) + tmp_pos = node_val(positions, element_nodes(1)) + pos(:, 1) = node_val(positions, element_nodes(2)) - tmp_pos + pos(:, 2) = node_val(positions, element_nodes(3)) - tmp_pos + pos(:, 3) = node_val(positions, element_nodes(4)) - tmp_pos - edge_sum = metric_edge_length(pos(:, 1), m) + & - & metric_edge_length(pos(:, 2), m) + & - & metric_edge_length(pos(:, 3), m) + & - & metric_edge_length(pos(:, 3) - pos(:, 1), m) + & - & metric_edge_length(pos(:, 3) - pos(:, 2), m) + & - & metric_edge_length(pos(:, 2) - pos(:, 1), m) - vol = abs(sqrt(det(m)) * det(pos) / 6.0) + edge_sum = metric_edge_length(pos(:, 1), m) + & + & metric_edge_length(pos(:, 2), m) + & + & metric_edge_length(pos(:, 3), m) + & + & metric_edge_length(pos(:, 3) - pos(:, 1), m) + & + & metric_edge_length(pos(:, 3) - pos(:, 2), m) + & + & metric_edge_length(pos(:, 2) - pos(:, 1), m) + vol = abs(sqrt(det(m)) * det(pos) / 6.0) - func = (scale_factor * vol / (edge_sum ** 3)) * F(edge_sum / 6.0) + func = (scale_factor * vol / (edge_sum ** 3)) * F(edge_sum / 6.0) - contains + contains - pure function F(x) - real, intent(in) :: x + pure function F(x) + real, intent(in) :: x - real :: F + real :: F - real :: x1 + real :: x1 - x1 = min(x, 1.0 / x) - F = x1 * (2.0 - x1) - F = F ** 3 + x1 = min(x, 1.0 / x) + F = x1 * (2.0 - x1) + F = F ** 3 - end function F + end function F - end function lipnikov_functional_3d + end function lipnikov_functional_3d - pure function metric_edge_length(x, m) result(length) - !!< Return the length of an edge x in a metric space with metric m + pure function metric_edge_length(x, m) result(length) + !!< Return the length of an edge x in a metric space with metric m - real, dimension(:), intent(in) :: x - real, dimension(size(x), size(x)), intent(in) :: m + real, dimension(:), intent(in) :: x + real, dimension(size(x), size(x)), intent(in) :: m - real :: length + real :: length - length = sqrt(dot_product(x, matmul(m, x))) + length = sqrt(dot_product(x, matmul(m, x))) - end function metric_edge_length + end function metric_edge_length - subroutine element_quality_p0(positions, metric, quality) - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: metric - type(scalar_field), intent(out) :: quality - type(mesh_type) :: pwc_mesh - integer :: ele + subroutine element_quality_p0(positions, metric, quality) + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: metric + type(scalar_field), intent(out) :: quality + type(mesh_type) :: pwc_mesh + integer :: ele - pwc_mesh = piecewise_constant_mesh(positions%mesh, "PWCMesh") - call allocate(quality, pwc_mesh, "ElementQuality") - call deallocate(pwc_mesh) + pwc_mesh = piecewise_constant_mesh(positions%mesh, "PWCMesh") + call allocate(quality, pwc_mesh, "ElementQuality") + call deallocate(pwc_mesh) - do ele=1,ele_count(positions) - call set(quality, ele, lipnikov_functional(ele, positions, metric)) - end do - end subroutine element_quality_p0 + do ele=1,ele_count(positions) + call set(quality, ele, lipnikov_functional(ele, positions, metric)) + end do + end subroutine element_quality_p0 end module metric_tools diff --git a/femtools/Mixing_Statistics.F90 b/femtools/Mixing_Statistics.F90 index 52500b29db..e8ff519e21 100644 --- a/femtools/Mixing_Statistics.F90 +++ b/femtools/Mixing_Statistics.F90 @@ -29,659 +29,659 @@ module mixing_statistics - use fldebug - use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN - use futils - use vector_tools - use element_numbering - use elements - use embed_python - use spud - use parallel_tools - use fetools - use unittest_tools - use parallel_fields - use fields - use state_module - use halos - use field_derivatives - use field_options - use fefields - use meshdiagnostics - - implicit none - - interface heaviside_integral - module procedure heaviside_integral_single, & + use fldebug + use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN + use futils + use vector_tools + use element_numbering + use elements + use embed_python + use spud + use parallel_tools + use fetools + use unittest_tools + use parallel_fields + use fields + use state_module + use halos + use field_derivatives + use field_options + use fefields + use meshdiagnostics + + implicit none + + interface heaviside_integral + module procedure heaviside_integral_single, & & heaviside_integral_multiple - end interface heaviside_integral + end interface heaviside_integral - interface mixing_stats - module procedure mixing_stats_scalar - end interface + interface mixing_stats + module procedure mixing_stats_scalar + end interface - private + private - public :: heaviside_integral, mixing_stats + public :: heaviside_integral, mixing_stats contains - subroutine mixing_stats_scalar(f_mix_fraction, sfield, Xfield, mixing_stats_count) - - real, dimension(:), intent(out) :: f_mix_fraction - type(scalar_field), target, intent(inout) :: sfield - type(vector_field), target, intent(inout) :: Xfield - integer, intent(in) :: mixing_stats_count - - if(have_option(trim(complete_field_path(sfield%option_path))//& - &"/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/continuous_galerkin")) then - - call heaviside_integral_options(f_mix_fraction, sfield, Xfield,& - & mixing_stats_count = mixing_stats_count) - - else if(have_option(trim(complete_field_path(sfield%option_path))//& - &"/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/control_volumes")) then - - call control_volume_mixing(f_mix_fraction, sfield, Xfield, mixing_stats_count) - - else - - FLAbort("Only continuous_galerkin or control_volumes options available for mixing_bins.") - - end if - - end subroutine mixing_stats_scalar - - subroutine control_volume_mixing(f_mix_fraction, sfield, Xfield, mixing_stats_count) - - real, dimension(:), intent(out) :: f_mix_fraction - type(scalar_field), target, intent(inout) :: sfield - type(vector_field), target, intent(inout) :: Xfield - integer, intent(in) :: mixing_stats_count - - integer :: i, j - real :: tolerance, total_volume, current_time - real, dimension(:), pointer :: mixing_bin_bounds - character(len = OPTION_PATH_LEN) :: func - type(scalar_field) :: cv_mass - integer, dimension(2) :: shape_option - - call get_option(trim(complete_field_path(sfield%option_path)) & - &// "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/tolerance",& - & tolerance, default = epsilon(0.0)) - - if(have_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/constant")) then - shape_option=option_shape(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/constant") - allocate(mixing_bin_bounds(shape_option(1))) - - call get_option(trim(complete_field_path(sfield%option_path)) & - &// "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/constant",& - & mixing_bin_bounds) - - else if(have_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/python")) then - call get_option(trim(complete_field_path(sfield%option_path)) // & - & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/python", func) - call get_option("/timestepping/current_time", current_time) - call real_vector_from_python(func, current_time, mixing_bin_bounds) - else - FLAbort("Unable to determine mixing bin bounds type") - end if - - call allocate(cv_mass, sfield%mesh, name="MixingCVMass") - call zero(cv_mass) - call compute_cv_mass(Xfield, cv_mass) - - f_mix_fraction = 0.0 - total_volume = 0.0 - do j = 1, node_count(sfield) - if(node_owned(sfield, j)) then - do i=1,size(f_mix_fraction) - if(node_val(sfield, j) >= (mixing_bin_bounds(i)-tolerance)) then - f_mix_fraction(i) = f_mix_fraction(i) + node_val(cv_mass, j) - end if - end do - total_volume = total_volume + node_val(cv_mass, j) - end if - end do - - ! In f_mix_fraction(j) have volume of sfield >= mixing_bin_bounds(j) - ! Subtract and divide so that f_mix_fraction(j) has - ! mixing_bin_bounds(j)mixing_bin_bounds(j) - ! Subtract so that f_mix_fraction(j) has - ! mixing_bin_bounds(j) 0) - - total_volume = 0.0 - - allocate(detwei(ele_ngi(sfield, 1))) - do ele = 1, ele_count(sfield) - if(.not. element_owned(sfield,ele)) cycle - - call transform_to_physical(Xfield, ele, detwei = detwei) - total_volume = total_volume + sum(detwei) - end do - deallocate(detwei) - - call allsum(total_volume, communicator = halo_communicator(sfield)) - - f_mix_fraction = f_mix_fraction / total_volume - endif - - deallocate(mixing_bin_bounds) - - end subroutine heaviside_integral_options - - function heaviside_integral_single(sfield, bound, positions, tolerance) result(integral) - type(scalar_field), intent(inout) :: sfield - real, intent(in) :: bound - type(vector_field), intent(in) :: positions - real, optional, intent(in) :: tolerance - - real :: integral - - real, dimension(1) :: integrals - type(element_type), pointer :: shape - - shape => ele_shape(sfield, 1) - if(ele_numbering_family(shape) /= FAMILY_SIMPLEX .or. shape%degree /= 1) then - FLAbort("heaviside_integral requires a linear simplex input mesh") - end if - - select case(positions%dim) - case(3) - integrals = heaviside_integral_tet(sfield, (/bound/), positions, tolerance = tolerance) - integral = integrals(1) - case(2) - integrals = heaviside_integral_tri(sfield, (/bound/), positions) - integral = integrals(1) - case(1) - integrals = heaviside_integral_line(sfield, (/bound/), positions) - integral = integrals(1) - case default - FLExit("heaviside_integral requires a linear simplex input mesh") - end select - - end function heaviside_integral_single - - function heaviside_integral_multiple(sfield, bounds, positions, tolerance) result(integrals) - type(scalar_field), intent(inout) :: sfield - real, dimension(:), intent(in) :: bounds - type(vector_field), intent(in) :: positions - real, optional, intent(in) :: tolerance - - real, dimension(size(bounds)) :: integrals - - type(element_type), pointer :: shape - - shape => ele_shape(sfield, 1) - if(ele_numbering_family(shape) /= FAMILY_SIMPLEX .or. shape%degree /= 1) then - FLExit("continuous_galerkin mixing_stats only available on linear simplex meshes") - end if - - select case(positions%dim) - case(3) - integrals = heaviside_integral_tet(sfield, bounds, positions, tolerance = tolerance) - case(2) - integrals = heaviside_integral_tri(sfield, bounds, positions) - case(1) - integrals = heaviside_integral_line(sfield, bounds, positions) - case default - FLAbort("Unsupported dimension count in heaviside_integral_new") - end select - - end function heaviside_integral_multiple - - function heaviside_integral_line(sfield, bounds, positions) result(integrals) - type(scalar_field), intent(in) :: sfield - real, dimension(:), intent(in) :: bounds - type(vector_field), intent(in) :: positions - - real, dimension(size(bounds)) :: integrals - - integer :: ele, i - logical, dimension(2) :: node_integrate - logical, dimension(size(bounds)) :: integrate_length - real :: line_length, sub_coord - real, dimension(2) :: node_vals - real, dimension(1, 2) :: coords - - integrals = 0.0 - ele_loop: do ele = 1, ele_count(sfield) - if(.not. element_owned(sfield, ele)) cycle ele_loop + subroutine mixing_stats_scalar(f_mix_fraction, sfield, Xfield, mixing_stats_count) - assert(ele_loc(sfield, ele) == 2) - coords = ele_val(positions, ele) - node_vals = ele_val(sfield, ele) - - integrate_length = .false. - bounds_loop: do i = 1, size(bounds) - node_integrate = node_vals >= bounds(i) - - if(node_integrate(1)) then - if(node_integrate(2)) then - ! Integrate the whole element + real, dimension(:), intent(out) :: f_mix_fraction + type(scalar_field), target, intent(inout) :: sfield + type(vector_field), target, intent(inout) :: Xfield + integer, intent(in) :: mixing_stats_count + + if(have_option(trim(complete_field_path(sfield%option_path))//& + &"/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/continuous_galerkin")) then + + call heaviside_integral_options(f_mix_fraction, sfield, Xfield,& + & mixing_stats_count = mixing_stats_count) + + else if(have_option(trim(complete_field_path(sfield%option_path))//& + &"/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/control_volumes")) then + + call control_volume_mixing(f_mix_fraction, sfield, Xfield, mixing_stats_count) + + else + + FLAbort("Only continuous_galerkin or control_volumes options available for mixing_bins.") - integrate_length(i) = .true. ! Handled outside the bounds loop (below) - else - ! Integrate part of the element - sub_coord = ((bounds(i) - node_vals(1)) * (coords(1, 2) - coords(1, 1)) / (node_vals(2) - node_vals(1))) + coords(1, 1) - integrals(i) = integrals(i) + abs(coords(1, 1) - sub_coord) - end if - else if(node_integrate(2)) then - ! Integrate part of the element - sub_coord = ((bounds(i) - node_vals(2)) * (coords(1, 1) - coords(1, 2)) / (node_vals(1) - node_vals(2))) + coords(1, 2) - integrals(i) = integrals(i) + abs(coords(1, 2) - sub_coord) - !else - ! ! Element not integrated - end if - end do bounds_loop - - if(count(integrate_length) > 0) then - ! Integrate the whole element - - line_length = abs(coords(1, 1) - coords(1, 2)) - - do i = 1, size(bounds) - if(integrate_length(i)) then - integrals(i) = integrals(i) + line_length - end if - end do end if - end do ele_loop - call allsum(integrals, communicator = halo_communicator(sfield)) + end subroutine mixing_stats_scalar + + subroutine control_volume_mixing(f_mix_fraction, sfield, Xfield, mixing_stats_count) + + real, dimension(:), intent(out) :: f_mix_fraction + type(scalar_field), target, intent(inout) :: sfield + type(vector_field), target, intent(inout) :: Xfield + integer, intent(in) :: mixing_stats_count + + integer :: i, j + real :: tolerance, total_volume, current_time + real, dimension(:), pointer :: mixing_bin_bounds + character(len = OPTION_PATH_LEN) :: func + type(scalar_field) :: cv_mass + integer, dimension(2) :: shape_option + + call get_option(trim(complete_field_path(sfield%option_path)) & + &// "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/tolerance",& + & tolerance, default = epsilon(0.0)) + + if(have_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/constant")) then + shape_option=option_shape(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/constant") + allocate(mixing_bin_bounds(shape_option(1))) + + call get_option(trim(complete_field_path(sfield%option_path)) & + &// "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/constant",& + & mixing_bin_bounds) + + else if(have_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/python")) then + call get_option(trim(complete_field_path(sfield%option_path)) // & + & "/stat/include_mixing_stats["// int2str(mixing_stats_count) // "]/mixing_bin_bounds/python", func) + call get_option("/timestepping/current_time", current_time) + call real_vector_from_python(func, current_time, mixing_bin_bounds) + else + FLAbort("Unable to determine mixing bin bounds type") + end if - do i = 1, size(bounds) - ewrite(2, *) "For field " // trim(sfield%name) // " with bound: ", bounds(i) - ewrite(2, *) "Heaviside integral >= bound = ", integrals(i) - end do + call allocate(cv_mass, sfield%mesh, name="MixingCVMass") + call zero(cv_mass) + call compute_cv_mass(Xfield, cv_mass) + + f_mix_fraction = 0.0 + total_volume = 0.0 + do j = 1, node_count(sfield) + if(node_owned(sfield, j)) then + do i=1,size(f_mix_fraction) + if(node_val(sfield, j) >= (mixing_bin_bounds(i)-tolerance)) then + f_mix_fraction(i) = f_mix_fraction(i) + node_val(cv_mass, j) + end if + end do + total_volume = total_volume + node_val(cv_mass, j) + end if + end do - end function heaviside_integral_line + ! In f_mix_fraction(j) have volume of sfield >= mixing_bin_bounds(j) + ! Subtract and divide so that f_mix_fraction(j) has + ! mixing_bin_bounds(j)= bounds(i) - node_integrate_count = count(node_integrate) + ! In f_mix_fraction(j) have volume of sfield >mixing_bin_bounds(j) + ! Subtract so that f_mix_fraction(j) has + ! mixing_bin_bounds(j) 0) - case(0) - ! Triangle not integrated + total_volume = 0.0 - case(1) - ! Integrate one corner triangle + allocate(detwei(ele_ngi(sfield, 1))) + do ele = 1, ele_count(sfield) + if(.not. element_owned(sfield,ele)) cycle + + call transform_to_physical(Xfield, ele, detwei = detwei) + total_volume = total_volume + sum(detwei) + end do + deallocate(detwei) + + call allsum(total_volume, communicator = halo_communicator(sfield)) + + f_mix_fraction = f_mix_fraction / total_volume + endif + + deallocate(mixing_bin_bounds) + + end subroutine heaviside_integral_options + + function heaviside_integral_single(sfield, bound, positions, tolerance) result(integral) + type(scalar_field), intent(inout) :: sfield + real, intent(in) :: bound + type(vector_field), intent(in) :: positions + real, optional, intent(in) :: tolerance + + real :: integral + + real, dimension(1) :: integrals + type(element_type), pointer :: shape + + shape => ele_shape(sfield, 1) + if(ele_numbering_family(shape) /= FAMILY_SIMPLEX .or. shape%degree /= 1) then + FLAbort("heaviside_integral requires a linear simplex input mesh") + end if + + select case(positions%dim) + case(3) + integrals = heaviside_integral_tet(sfield, (/bound/), positions, tolerance = tolerance) + integral = integrals(1) + case(2) + integrals = heaviside_integral_tri(sfield, (/bound/), positions) + integral = integrals(1) + case(1) + integrals = heaviside_integral_line(sfield, (/bound/), positions) + integral = integrals(1) + case default + FLExit("heaviside_integral requires a linear simplex input mesh") + end select + + end function heaviside_integral_single + + function heaviside_integral_multiple(sfield, bounds, positions, tolerance) result(integrals) + type(scalar_field), intent(inout) :: sfield + real, dimension(:), intent(in) :: bounds + type(vector_field), intent(in) :: positions + real, optional, intent(in) :: tolerance + + real, dimension(size(bounds)) :: integrals + + type(element_type), pointer :: shape + + shape => ele_shape(sfield, 1) + if(ele_numbering_family(shape) /= FAMILY_SIMPLEX .or. shape%degree /= 1) then + FLExit("continuous_galerkin mixing_stats only available on linear simplex meshes") + end if + + select case(positions%dim) + case(3) + integrals = heaviside_integral_tet(sfield, bounds, positions, tolerance = tolerance) + case(2) + integrals = heaviside_integral_tri(sfield, bounds, positions) + case(1) + integrals = heaviside_integral_line(sfield, bounds, positions) + case default + FLAbort("Unsupported dimension count in heaviside_integral_new") + end select + + end function heaviside_integral_multiple + + function heaviside_integral_line(sfield, bounds, positions) result(integrals) + type(scalar_field), intent(in) :: sfield + real, dimension(:), intent(in) :: bounds + type(vector_field), intent(in) :: positions + + real, dimension(size(bounds)) :: integrals + + integer :: ele, i + logical, dimension(2) :: node_integrate + logical, dimension(size(bounds)) :: integrate_length + real :: line_length, sub_coord + real, dimension(2) :: node_vals + real, dimension(1, 2) :: coords + + integrals = 0.0 + ele_loop: do ele = 1, ele_count(sfield) + if(.not. element_owned(sfield, ele)) cycle ele_loop + + assert(ele_loc(sfield, ele) == 2) + coords = ele_val(positions, ele) + node_vals = ele_val(sfield, ele) + + integrate_length = .false. + bounds_loop: do i = 1, size(bounds) + node_integrate = node_vals >= bounds(i) if(node_integrate(1)) then - integrated_node = 1 - non_integrated_nodes(1) = 2 - non_integrated_nodes(2) = 3 + if(node_integrate(2)) then + ! Integrate the whole element + + integrate_length(i) = .true. ! Handled outside the bounds loop (below) + else + ! Integrate part of the element + sub_coord = ((bounds(i) - node_vals(1)) * (coords(1, 2) - coords(1, 1)) / (node_vals(2) - node_vals(1))) + coords(1, 1) + integrals(i) = integrals(i) + abs(coords(1, 1) - sub_coord) + end if else if(node_integrate(2)) then - integrated_node = 2 - non_integrated_nodes(1) = 1 - non_integrated_nodes(2) = 3 - else - integrated_node = 3 - non_integrated_nodes(1) = 1 - non_integrated_nodes(2) = 2 + ! Integrate part of the element + sub_coord = ((bounds(i) - node_vals(2)) * (coords(1, 1) - coords(1, 2)) / (node_vals(1) - node_vals(2))) + coords(1, 2) + integrals(i) = integrals(i) + abs(coords(1, 2) - sub_coord) + !else + ! ! Element not integrated end if + end do bounds_loop - sub_tri_coords(:, 1) = tri_coords(:, integrated_node) - sub_tri_coords(:, 2) = tri_coords(:, non_integrated_nodes(1)) + & - & ((bounds(i) - node_vals(non_integrated_nodes(1))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(1)))) * & - & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(1))) - sub_tri_coords(:, 3) = tri_coords(:, non_integrated_nodes(2)) + & - & ((bounds(i) - node_vals(non_integrated_nodes(2))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(2)))) * & - & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(2))) - - sub_tri_coords(:, 2:) = sub_tri_coords(:, 2:) - spread(sub_tri_coords(:, 1), 2, 2) - - integrals(i) = integrals(i) + 0.5 * abs(det(sub_tri_coords(:, 2:))) - case(2) - ! Integrate one edge trapezium - - integrate_area(i) = .true. ! Handled outside the bounds loop (below) - - if(.not. node_integrate(1)) then - integrated_node = 1 - non_integrated_nodes(1) = 2 - non_integrated_nodes(2) = 3 - else if(.not. node_integrate(2)) then - integrated_node = 2 - non_integrated_nodes(1) = 1 - non_integrated_nodes(2) = 3 - else - integrated_node = 3 - non_integrated_nodes(1) = 1 - non_integrated_nodes(2) = 2 - end if + if(count(integrate_length) > 0) then + ! Integrate the whole element + + line_length = abs(coords(1, 1) - coords(1, 2)) - sub_tri_coords(:, 1) = tri_coords(:, integrated_node) - sub_tri_coords(:, 2) = tri_coords(:, non_integrated_nodes(1)) + & - & ((bounds(i) - node_vals(non_integrated_nodes(1))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(1)))) * & - & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(1))) - sub_tri_coords(:, 3) = tri_coords(:, non_integrated_nodes(2)) + & - & ((bounds(i) - node_vals(non_integrated_nodes(2))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(2)))) * & - & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(2))) - - sub_tri_coords(:, 2:) = sub_tri_coords(:, 2:) - spread(sub_tri_coords(:, 1), 2, 2) - integrals(i) = integrals(i) - 0.5 * abs(det(sub_tri_coords(:, 2:))) - case(3) + do i = 1, size(bounds) + if(integrate_length(i)) then + integrals(i) = integrals(i) + line_length + end if + end do + end if + end do ele_loop + + call allsum(integrals, communicator = halo_communicator(sfield)) + + do i = 1, size(bounds) + ewrite(2, *) "For field " // trim(sfield%name) // " with bound: ", bounds(i) + ewrite(2, *) "Heaviside integral >= bound = ", integrals(i) + end do + + end function heaviside_integral_line + + function heaviside_integral_tri(sfield, bounds, positions) result(integrals) + type(scalar_field), intent(in) :: sfield + real, dimension(:), intent(in) :: bounds + type(vector_field), intent(in) :: positions + + real, dimension(size(bounds)) :: integrals + + integer :: ele, i, integrated_node + integer, dimension(2) :: non_integrated_nodes + integer :: node_integrate_count + logical, dimension(3) :: node_integrate + logical, dimension(size(bounds)) :: integrate_area + real :: tet_area + real, dimension(3) :: node_vals + real, dimension(2, 3) :: tri_coords, sub_tri_coords + + integrals = 0.0 + ele_loop: do ele = 1, ele_count(sfield) + if(.not. element_owned(sfield, ele)) cycle ele_loop + + assert(ele_loc(sfield, ele) == 3) + tri_coords = ele_val(positions, ele) + tri_coords(:, 2:) = tri_coords(:, 2:) - spread(tri_coords(:, 1), 2, 2); tri_coords(:, 1) = 0.0 + node_vals = ele_val(sfield, ele) + + integrate_area = .false. + bounds_loop: do i = 1, size(bounds) + node_integrate = node_vals >= bounds(i) + node_integrate_count = count(node_integrate) + + select case(node_integrate_count) + + case(0) + ! Triangle not integrated + + case(1) + ! Integrate one corner triangle + + if(node_integrate(1)) then + integrated_node = 1 + non_integrated_nodes(1) = 2 + non_integrated_nodes(2) = 3 + else if(node_integrate(2)) then + integrated_node = 2 + non_integrated_nodes(1) = 1 + non_integrated_nodes(2) = 3 + else + integrated_node = 3 + non_integrated_nodes(1) = 1 + non_integrated_nodes(2) = 2 + end if + + sub_tri_coords(:, 1) = tri_coords(:, integrated_node) + sub_tri_coords(:, 2) = tri_coords(:, non_integrated_nodes(1)) + & + & ((bounds(i) - node_vals(non_integrated_nodes(1))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(1)))) * & + & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(1))) + sub_tri_coords(:, 3) = tri_coords(:, non_integrated_nodes(2)) + & + & ((bounds(i) - node_vals(non_integrated_nodes(2))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(2)))) * & + & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(2))) + + sub_tri_coords(:, 2:) = sub_tri_coords(:, 2:) - spread(sub_tri_coords(:, 1), 2, 2) + + integrals(i) = integrals(i) + 0.5 * abs(det(sub_tri_coords(:, 2:))) + case(2) + ! Integrate one edge trapezium + + integrate_area(i) = .true. ! Handled outside the bounds loop (below) + + if(.not. node_integrate(1)) then + integrated_node = 1 + non_integrated_nodes(1) = 2 + non_integrated_nodes(2) = 3 + else if(.not. node_integrate(2)) then + integrated_node = 2 + non_integrated_nodes(1) = 1 + non_integrated_nodes(2) = 3 + else + integrated_node = 3 + non_integrated_nodes(1) = 1 + non_integrated_nodes(2) = 2 + end if + + sub_tri_coords(:, 1) = tri_coords(:, integrated_node) + sub_tri_coords(:, 2) = tri_coords(:, non_integrated_nodes(1)) + & + & ((bounds(i) - node_vals(non_integrated_nodes(1))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(1)))) * & + & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(1))) + sub_tri_coords(:, 3) = tri_coords(:, non_integrated_nodes(2)) + & + & ((bounds(i) - node_vals(non_integrated_nodes(2))) / (node_vals(integrated_node) - node_vals(non_integrated_nodes(2)))) * & + & (tri_coords(:, integrated_node) - tri_coords(:, non_integrated_nodes(2))) + + sub_tri_coords(:, 2:) = sub_tri_coords(:, 2:) - spread(sub_tri_coords(:, 1), 2, 2) + integrals(i) = integrals(i) - 0.5 * abs(det(sub_tri_coords(:, 2:))) + case(3) + ! Integrate the whole triangle + + integrate_area(i) = .true. ! Handled outside the bounds loop (below) + case default + FLAbort("Unexpected number of integrated nodes in triangle") + end select + end do bounds_loop + + if(count(integrate_area) > 0) then ! Integrate the whole triangle - integrate_area(i) = .true. ! Handled outside the bounds loop (below) - case default - FLAbort("Unexpected number of integrated nodes in triangle") - end select - end do bounds_loop + tet_area = 0.5 * abs(det(tri_coords(:, 2:))) + + do i = 1, size(bounds) + if(integrate_area(i)) then + integrals(i) = integrals(i) + tet_area + end if + end do + end if + end do ele_loop + + call allsum(integrals, communicator = halo_communicator(sfield)) + + do i = 1, size(bounds) + ewrite(2, *) "For field " // trim(sfield%name) // " with bound: ", bounds(i) + ewrite(2, *) "Heaviside integral >= bound = ", integrals(i) + end do + + end function heaviside_integral_tri - if(count(integrate_area) > 0) then - ! Integrate the whole triangle + function heaviside_integral_tet(sfield, bounds, positions, tolerance) result(integrals) + type(scalar_field), intent(in) :: sfield + real, dimension(:), intent(in) :: bounds + type(vector_field), intent(in) :: positions + real, optional, intent(in) :: tolerance - tet_area = 0.5 * abs(det(tri_coords(:, 2:))) + real, dimension(size(bounds)) :: integrals - do i = 1, size(bounds) - if(integrate_area(i)) then - integrals(i) = integrals(i) + tet_area - end if - end do + integer :: ii, iloc, heavi_zero + integer, dimension(4) :: heavi_non_zero + real :: dd + real, dimension(4) :: xele, yele, zele, xelesub, yelesub, zelesub + real, dimension(6) :: xpent, ypent, zpent + + integer :: ele, i, node, node_integrate_count, xnode + integer, dimension(:), pointer :: nodes, xnodes + logical, dimension(size(bounds)) :: integrate_vol + real :: tet_vol + + real :: l_tolerance + + if(present(tolerance)) then + l_tolerance = tolerance + else + l_tolerance = epsilon(0.0) end if - end do ele_loop - - call allsum(integrals, communicator = halo_communicator(sfield)) - - do i = 1, size(bounds) - ewrite(2, *) "For field " // trim(sfield%name) // " with bound: ", bounds(i) - ewrite(2, *) "Heaviside integral >= bound = ", integrals(i) - end do - - end function heaviside_integral_tri - - function heaviside_integral_tet(sfield, bounds, positions, tolerance) result(integrals) - type(scalar_field), intent(in) :: sfield - real, dimension(:), intent(in) :: bounds - type(vector_field), intent(in) :: positions - real, optional, intent(in) :: tolerance - - real, dimension(size(bounds)) :: integrals - - integer :: ii, iloc, heavi_zero - integer, dimension(4) :: heavi_non_zero - real :: dd - real, dimension(4) :: xele, yele, zele, xelesub, yelesub, zelesub - real, dimension(6) :: xpent, ypent, zpent - - integer :: ele, i, node, node_integrate_count, xnode - integer, dimension(:), pointer :: nodes, xnodes - logical, dimension(size(bounds)) :: integrate_vol - real :: tet_vol - - real :: l_tolerance - - if(present(tolerance)) then - l_tolerance = tolerance - else - l_tolerance = epsilon(0.0) - end if - - integrals = 0.0 - ele_loop: do ele = 1, ele_count(sfield) - ! Check if this processor is integrating this element - if(.not. element_owned(sfield, ele)) cycle ele_loop - - xnodes => ele_nodes(positions, ele) - nodes => ele_nodes(sfield, ele) - - integrate_vol = .false. - bounds_loop: do i = 1, size(bounds) - - node_integrate_count = 0 - heavi_non_zero = 0 - ii = 0 - - do iloc = 1,4 - node = nodes(iloc) - xnode = xnodes(iloc) - xele(iloc) = node_val(positions, X_, xnode) - yele(iloc) = node_val(positions, Y_, xnode) - zele(iloc) = node_val(positions, Z_, xnode) - if(node_val(sfield, node) >=(bounds(i)-l_tolerance)) then - node_integrate_count = node_integrate_count + 1 - ii = ii + 1 - heavi_non_zero(ii) = iloc - endif - end do - if (node_integrate_count==4) then - ! heaviside funtion 1 over whole element so add entire volume + integrals = 0.0 + ele_loop: do ele = 1, ele_count(sfield) + ! Check if this processor is integrating this element + if(.not. element_owned(sfield, ele)) cycle ele_loop + + xnodes => ele_nodes(positions, ele) + nodes => ele_nodes(sfield, ele) - integrate_vol(i) = .true. ! Handled outside the bounds loop (below) - elseif(node_integrate_count==0) then - ! heaviside function zero over whole element so do nothing + integrate_vol = .false. + bounds_loop: do i = 1, size(bounds) - elseif(node_integrate_count==1) then - ! heaviside function non-zero only over a sub-tet of this element + node_integrate_count = 0 + heavi_non_zero = 0 + ii = 0 - xelesub(1) = node_val(positions, X_, xnodes(heavi_non_zero(1))) - yelesub(1) = node_val(positions, Y_, xnodes(heavi_non_zero(1))) - zelesub(1) = node_val(positions, Z_, xnodes(heavi_non_zero(1))) - ! find locations of the other sub-tet vertices - ii = 1 ! already have the first do iloc = 1,4 - if(iloc/=heavi_non_zero(1)) then + node = nodes(iloc) + xnode = xnodes(iloc) + xele(iloc) = node_val(positions, X_, xnode) + yele(iloc) = node_val(positions, Y_, xnode) + zele(iloc) = node_val(positions, Z_, xnode) + if(node_val(sfield, node) >=(bounds(i)-l_tolerance)) then + node_integrate_count = node_integrate_count + 1 ii = ii + 1 - dd = (bounds(i) - node_val(sfield, nodes(heavi_non_zero(1))))/ & - (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_non_zero(1)))) - !dd = max(min(dd,1.0),0.0) - xelesub(ii) = xelesub(1) + (node_val(positions, X_, xnodes(iloc))-xelesub(1))*dd - yelesub(ii) = yelesub(1) + (node_val(positions, Y_, xnodes(iloc))-yelesub(1))*dd - zelesub(ii) = zelesub(1) + (node_val(positions, Z_, xnodes(iloc))-zelesub(1))*dd + heavi_non_zero(ii) = iloc endif end do - if(ii/=4) then - FLAbort("have not found all three other vertices of the subtet") - end if - integrals(i) = integrals(i) + abs(tetvol(xelesub,yelesub,zelesub)) - elseif(node_integrate_count==2) then - ! this is the complicated case where the ele has been split into two pentahedra - ! split the pentahedra into 3 tets to calculate the volume - xpent(1) = node_val(positions, X_, xnodes(heavi_non_zero(1))) - ypent(1) = node_val(positions, Y_, xnodes(heavi_non_zero(1))) - zpent(1) = node_val(positions, Z_, xnodes(heavi_non_zero(1))) - - xpent(2) = node_val(positions, X_, xnodes(heavi_non_zero(2))) - ypent(2) = node_val(positions, Y_, xnodes(heavi_non_zero(2))) - zpent(2) = node_val(positions, Z_, xnodes(heavi_non_zero(2))) - ! find locations of the other pentahedra vertices - ii = 2 ! already have the first two - do iloc = 1,4 - if((iloc/=heavi_non_zero(1)).and.(iloc/=heavi_non_zero(2))) then - ii = ii + 1 - dd = (bounds(i) - node_val(sfield, nodes(heavi_non_zero(1))))/ & - (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_non_zero(1)))) - assert(.not. is_nan(dd)) - dd = max(min(dd,1.0),0.0) - if(ii==3) then - xpent(3) = xpent(1) + (node_val(positions, X_, xnodes(iloc))-xpent(1))*dd - ypent(3) = ypent(1) + (node_val(positions, Y_, xnodes(iloc))-ypent(1))*dd - zpent(3) = zpent(1) + (node_val(positions, Z_, xnodes(iloc))-zpent(1))*dd - else - xpent(4) = xpent(1) + (node_val(positions, X_, xnodes(iloc))-xpent(1))*dd - ypent(4) = ypent(1) + (node_val(positions, Y_, xnodes(iloc))-ypent(1))*dd - zpent(4) = zpent(1) + (node_val(positions, Z_, xnodes(iloc))-zpent(1))*dd - endif - dd = (bounds(i) - node_val(sfield, nodes(heavi_non_zero(2))))/ & - (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_non_zero(2)))) - assert(.not. is_nan(dd)) - dd = max(min(dd,1.0),0.0) - if(ii==3) then - xpent(5) = xpent(2) + (node_val(positions, X_, xnodes(iloc))-xpent(2))*dd - ypent(5) = ypent(2) + (node_val(positions, Y_, xnodes(iloc))-ypent(2))*dd - zpent(5) = zpent(2) + (node_val(positions, Z_, xnodes(iloc))-zpent(2))*dd - else - xpent(6) = xpent(2) + (node_val(positions, X_, xnodes(iloc))-xpent(2))*dd - ypent(6) = ypent(2) + (node_val(positions, Y_, xnodes(iloc))-ypent(2))*dd - zpent(6) = zpent(2) + (node_val(positions, Z_, xnodes(iloc))-zpent(2))*dd + if (node_integrate_count==4) then + ! heaviside funtion 1 over whole element so add entire volume + + integrate_vol(i) = .true. ! Handled outside the bounds loop (below) + elseif(node_integrate_count==0) then + ! heaviside function zero over whole element so do nothing + + elseif(node_integrate_count==1) then + ! heaviside function non-zero only over a sub-tet of this element + + xelesub(1) = node_val(positions, X_, xnodes(heavi_non_zero(1))) + yelesub(1) = node_val(positions, Y_, xnodes(heavi_non_zero(1))) + zelesub(1) = node_val(positions, Z_, xnodes(heavi_non_zero(1))) + ! find locations of the other sub-tet vertices + ii = 1 ! already have the first + do iloc = 1,4 + if(iloc/=heavi_non_zero(1)) then + ii = ii + 1 + dd = (bounds(i) - node_val(sfield, nodes(heavi_non_zero(1))))/ & + (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_non_zero(1)))) + !dd = max(min(dd,1.0),0.0) + xelesub(ii) = xelesub(1) + (node_val(positions, X_, xnodes(iloc))-xelesub(1))*dd + yelesub(ii) = yelesub(1) + (node_val(positions, Y_, xnodes(iloc))-yelesub(1))*dd + zelesub(ii) = zelesub(1) + (node_val(positions, Z_, xnodes(iloc))-zelesub(1))*dd endif - endif - end do - if(ii/=4) then - FLAbort("have not found all two other vertices of the pent") - end if - integrals(i) = integrals(i) + PENTAHEDRON_VOL(Xpent,Ypent,Zpent) - elseif(node_integrate_count==3) then - ! in this case there is a subtet over which the heaviside function IS ZERO so just - ! use (vol(big_tet) - vol(subtet)) as volume of polyhedra where heaviside function non-zero - heavi_zero = 10 - (heavi_non_zero(1) + heavi_non_zero(2) + heavi_non_zero(3)) - ! heavi_zero is the local node number of the single node where the heaviside function is zero - xelesub(1) = node_val(positions, X_, xnodes(heavi_zero)) - yelesub(1) = node_val(positions, Y_, xnodes(heavi_zero)) - zelesub(1) = node_val(positions, Z_, xnodes(heavi_zero)) - ! find locations of the other sub-tet vertices - ii = 1 ! already have the first - do iloc = 1,4 - if(iloc/=heavi_zero) then - ii = ii + 1 - dd = (bounds(i) - node_val(sfield, nodes(heavi_zero)))/ & - (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_zero))) + end do + if(ii/=4) then + FLAbort("have not found all three other vertices of the subtet") + end if + integrals(i) = integrals(i) + abs(tetvol(xelesub,yelesub,zelesub)) + elseif(node_integrate_count==2) then + ! this is the complicated case where the ele has been split into two pentahedra + ! split the pentahedra into 3 tets to calculate the volume + xpent(1) = node_val(positions, X_, xnodes(heavi_non_zero(1))) + ypent(1) = node_val(positions, Y_, xnodes(heavi_non_zero(1))) + zpent(1) = node_val(positions, Z_, xnodes(heavi_non_zero(1))) + + xpent(2) = node_val(positions, X_, xnodes(heavi_non_zero(2))) + ypent(2) = node_val(positions, Y_, xnodes(heavi_non_zero(2))) + zpent(2) = node_val(positions, Z_, xnodes(heavi_non_zero(2))) + ! find locations of the other pentahedra vertices + ii = 2 ! already have the first two + do iloc = 1,4 + if((iloc/=heavi_non_zero(1)).and.(iloc/=heavi_non_zero(2))) then + ii = ii + 1 + dd = (bounds(i) - node_val(sfield, nodes(heavi_non_zero(1))))/ & + (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_non_zero(1)))) + assert(.not. is_nan(dd)) + dd = max(min(dd,1.0),0.0) + if(ii==3) then + xpent(3) = xpent(1) + (node_val(positions, X_, xnodes(iloc))-xpent(1))*dd + ypent(3) = ypent(1) + (node_val(positions, Y_, xnodes(iloc))-ypent(1))*dd + zpent(3) = zpent(1) + (node_val(positions, Z_, xnodes(iloc))-zpent(1))*dd + else + xpent(4) = xpent(1) + (node_val(positions, X_, xnodes(iloc))-xpent(1))*dd + ypent(4) = ypent(1) + (node_val(positions, Y_, xnodes(iloc))-ypent(1))*dd + zpent(4) = zpent(1) + (node_val(positions, Z_, xnodes(iloc))-zpent(1))*dd + endif + + dd = (bounds(i) - node_val(sfield, nodes(heavi_non_zero(2))))/ & + (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_non_zero(2)))) + assert(.not. is_nan(dd)) + dd = max(min(dd,1.0),0.0) + if(ii==3) then + xpent(5) = xpent(2) + (node_val(positions, X_, xnodes(iloc))-xpent(2))*dd + ypent(5) = ypent(2) + (node_val(positions, Y_, xnodes(iloc))-ypent(2))*dd + zpent(5) = zpent(2) + (node_val(positions, Z_, xnodes(iloc))-zpent(2))*dd + else + xpent(6) = xpent(2) + (node_val(positions, X_, xnodes(iloc))-xpent(2))*dd + ypent(6) = ypent(2) + (node_val(positions, Y_, xnodes(iloc))-ypent(2))*dd + zpent(6) = zpent(2) + (node_val(positions, Z_, xnodes(iloc))-zpent(2))*dd + endif + endif + end do + if(ii/=4) then + FLAbort("have not found all two other vertices of the pent") + end if + integrals(i) = integrals(i) + PENTAHEDRON_VOL(Xpent,Ypent,Zpent) + elseif(node_integrate_count==3) then + ! in this case there is a subtet over which the heaviside function IS ZERO so just + ! use (vol(big_tet) - vol(subtet)) as volume of polyhedra where heaviside function non-zero + heavi_zero = 10 - (heavi_non_zero(1) + heavi_non_zero(2) + heavi_non_zero(3)) + ! heavi_zero is the local node number of the single node where the heaviside function is zero + xelesub(1) = node_val(positions, X_, xnodes(heavi_zero)) + yelesub(1) = node_val(positions, Y_, xnodes(heavi_zero)) + zelesub(1) = node_val(positions, Z_, xnodes(heavi_zero)) + ! find locations of the other sub-tet vertices + ii = 1 ! already have the first + do iloc = 1,4 + if(iloc/=heavi_zero) then + ii = ii + 1 + dd = (bounds(i) - node_val(sfield, nodes(heavi_zero)))/ & + (node_val(sfield, nodes(iloc))-node_val(sfield, nodes(heavi_zero))) + + dd = max(min(dd,1.0),0.0) + + xelesub(ii) = xelesub(1) + (node_val(positions, X_, xnodes(iloc))-xelesub(1))*dd + yelesub(ii) = yelesub(1) + (node_val(positions, Y_, xnodes(iloc))-yelesub(1))*dd + zelesub(ii) = zelesub(1) + (node_val(positions, Z_, xnodes(iloc))-zelesub(1))*dd + endif + end do + if(ii/=4) then + FLAbort("have not found all three other vertices of the subtet") + end if + integrate_vol(i) = .true. ! Handled outside the bounds loop (below) + integrals(i) = integrals(i) - abs(tetvol(xelesub,yelesub,zelesub)) + endif + end do bounds_loop - dd = max(min(dd,1.0),0.0) + if(count(integrate_vol) > 0) then + tet_vol = abs(tetvol(xele,yele,zele)) + do i = 1, size(bounds) + if(integrate_vol(i)) then + ! heaviside funtion 1 over whole element so add entire volume - xelesub(ii) = xelesub(1) + (node_val(positions, X_, xnodes(iloc))-xelesub(1))*dd - yelesub(ii) = yelesub(1) + (node_val(positions, Y_, xnodes(iloc))-yelesub(1))*dd - zelesub(ii) = zelesub(1) + (node_val(positions, Z_, xnodes(iloc))-zelesub(1))*dd - endif + integrals(i) = integrals(i) + tet_vol + end if end do - if(ii/=4) then - FLAbort("have not found all three other vertices of the subtet") - end if - integrate_vol(i) = .true. ! Handled outside the bounds loop (below) - integrals(i) = integrals(i) - abs(tetvol(xelesub,yelesub,zelesub)) - endif - end do bounds_loop - - if(count(integrate_vol) > 0) then - tet_vol = abs(tetvol(xele,yele,zele)) - do i = 1, size(bounds) - if(integrate_vol(i)) then - ! heaviside funtion 1 over whole element so add entire volume - - integrals(i) = integrals(i) + tet_vol - end if - end do - end if - end do ele_loop + end if + end do ele_loop - call allsum(integrals, communicator = halo_communicator(sfield)) + call allsum(integrals, communicator = halo_communicator(sfield)) - do i = 1, size(bounds) - ewrite(2, *) "For field " // trim(sfield%name) // " with bound: ", bounds(i) - ewrite(2, *) "Heaviside integral >= bound = ", integrals(i) - end do + do i = 1, size(bounds) + ewrite(2, *) "For field " // trim(sfield%name) // " with bound: ", bounds(i) + ewrite(2, *) "Heaviside integral >= bound = ", integrals(i) + end do - end function heaviside_integral_tet + end function heaviside_integral_tet end module mixing_statistics diff --git a/femtools/Multigrid.F90 b/femtools/Multigrid.F90 index 3f32e5d798..fa75a83923 100644 --- a/femtools/Multigrid.F90 +++ b/femtools/Multigrid.F90 @@ -2,15 +2,15 @@ !! This module contains multigrid related subroutines, such as the smoothed !! aggregation preconditioner. module multigrid -use FLDebug -use spud -use futils -use parallel_tools - use petsc -use Sparse_tools -use Petsc_Tools -use sparse_tools_petsc -implicit none + use FLDebug + use spud + use futils + use parallel_tools + use petsc + use Sparse_tools + use Petsc_Tools + use sparse_tools_petsc + implicit none #include "petsc_legacy.h" !! Some parameters that change the behaviour of @@ -20,1091 +20,1091 @@ module multigrid !! --mymg_maxlevels, --mymg_coarsesize, --mymg_epsilon and --mymg_omega !! !! maximum number of multigrid levels: -integer, public, parameter:: MULTIGRID_MAXLEVELS_DEFAULT=25 + integer, public, parameter:: MULTIGRID_MAXLEVELS_DEFAULT=25 !! the maximum number of nodes at the coarsest level !! (that is solved by a direct solver): !! in serial we use a direct solver: -integer, public, parameter:: MULTIGRID_COARSESIZE_DEFAULT_SERIAL=5000 + integer, public, parameter:: MULTIGRID_COARSESIZE_DEFAULT_SERIAL=5000 !! in parallel we coarsen a bit further: -integer, public, parameter:: MULTIGRID_COARSESIZE_DEFAULT_PARALLEL=100 + integer, public, parameter:: MULTIGRID_COARSESIZE_DEFAULT_PARALLEL=100 !! epsilon determines the relatively strong connections: -PetscReal, public, parameter:: MULTIGRID_EPSILON_DEFAULT=0.01 + PetscReal, public, parameter:: MULTIGRID_EPSILON_DEFAULT=0.01 !! epsilon is divided by epsilon_decay after each coarsening, !! as the coarser levels are generally less anisotropic and therefore !! we need a less strong criterium for strong connections -PetscReal, public, parameter:: MULTIGRID_EPSILON_DECAY_DEFAULT=1.0 + PetscReal, public, parameter:: MULTIGRID_EPSILON_DECAY_DEFAULT=1.0 !! omega in the prolongation smoother: -PetscReal, public, parameter:: MULTIGRID_OMEGA_DEFAULT=2.0/3.0 + PetscReal, public, parameter:: MULTIGRID_OMEGA_DEFAULT=2.0/3.0 !! number of smoother iterations going down -integer, public, parameter:: MULTIGRID_NOSMD_DEFAULT=1 + integer, public, parameter:: MULTIGRID_NOSMD_DEFAULT=1 !! number of smoother iterations going up -integer, public, parameter:: MULTIGRID_NOSMU_DEFAULT=1 + integer, public, parameter:: MULTIGRID_NOSMU_DEFAULT=1 !! max size of clusters (in first round), 0 means follow Vanek'96 -integer, public, parameter:: MULTIGRID_CLUSTERSIZE_DEFAULT=0 + integer, public, parameter:: MULTIGRID_CLUSTERSIZE_DEFAULT=0 -integer, private, parameter:: ISOLATED=0, COUPLED=-1 + integer, private, parameter:: ISOLATED=0, COUPLED=-1 -integer, public, parameter :: & - !No internal smoothing - INTERNAL_SMOOTHING_NONE=0, & - !No SOR on outer level of the multigrids, whole PC wrapped in - !SOR sweeps - INTERNAL_SMOOTHING_WRAP_SOR=1, & - !SOR on outer level of the multigrids, no wrapping SOR - INTERNAL_SMOOTHING_SEPARATE_SOR=2 + integer, public, parameter :: & + !No internal smoothing + INTERNAL_SMOOTHING_NONE=0, & + !No SOR on outer level of the multigrids, whole PC wrapped in + !SOR sweeps + INTERNAL_SMOOTHING_WRAP_SOR=1, & + !SOR on outer level of the multigrids, no wrapping SOR + INTERNAL_SMOOTHING_SEPARATE_SOR=2 !===================================== !!Stuff for internal smoother -- cjc !===================================== !PC for internal smoother, it will be MG -PC :: internal_smoother_pc + PC :: internal_smoother_pc !Matrix for internal smoother -Mat :: internal_smoother_mat + Mat :: internal_smoother_mat !list of surface nodes -integer, dimension(:), pointer, save :: surface_node_list => null() + integer, dimension(:), pointer, save :: surface_node_list => null() !list of surface values, for copying -PetscReal, dimension(:), pointer, save :: surface_values => null() + PetscReal, dimension(:), pointer, save :: surface_values => null() !===================================== -private -public SetupSmoothedAggregation, SetupMultigrid, DestroyMultigrid + private + public SetupSmoothedAggregation, SetupMultigrid, DestroyMultigrid contains -subroutine SetUpInternalSmoother(surface_node_list_in,matrix,pc, & - no_top_smoothing) + subroutine SetUpInternalSmoother(surface_node_list_in,matrix,pc, & + no_top_smoothing) !!< This subroutine sets up the internal additive smoother as described in !!< Kramer and Cotter (2009) in preparation - integer, intent(in), dimension(:) :: surface_node_list_in - type(csr_matrix), intent(in) :: matrix - PC, intent(inout) :: pc - logical, intent(in), optional :: no_top_smoothing - ! - type(csr_matrix) :: matrix_internal - integer :: row,i, ierr, nsurface - integer, dimension(:), pointer :: r_ptr - - integer, dimension(:), allocatable :: surface_flag - logical :: lno_top_smoothing - ! these are used to point at things in csr_matrices so should be using - ! real instead of PetscReal - real, dimension(:), pointer :: r_val_ptr - - lno_top_smoothing = .false. - if(present(no_top_smoothing)) then - lno_top_smoothing = no_top_smoothing - end if - nsurface = size(surface_node_list_in) - allocate(surface_node_list(nsurface)) - surface_node_list = surface_node_list_in - allocate(surface_values(nsurface)) - surface_values = 0. - - allocate(surface_flag(size(matrix,1))) - surface_flag = 1 - surface_flag(surface_node_list) = 0 - - call allocate(matrix_internal,matrix%sparsity) - call set(matrix_internal,matrix) - - !zero all surface columns in matrix_internal - do row = 1, size(matrix,1) - r_ptr => row_m_ptr(matrix_internal,row) - r_val_ptr => row_val_ptr(matrix_internal,row) - - if(any(surface_flag(r_ptr)==0)) then - call set(matrix_internal,row,r_ptr,r_val_ptr*surface_flag(r_ptr)) - end if - end do - - !zero all surface row in matrix_internal - !and put a 1 on the diagonal - do i = 1, size(surface_node_list) - row = surface_node_list(i) - r_ptr => row_m_ptr(matrix_internal,row) - r_val_ptr => row_val_ptr(matrix_internal,row) - - call set(matrix_internal,row,r_ptr,0.0*r_val_ptr) - call set(matrix_internal,row,row,1.0) - end do - - !create matrix - internal_smoother_mat = csr2petsc(matrix_internal) - !set up multigrid - call PCCreate(MPI_COMM_SELF,internal_smoother_pc,ierr) - call PCSetType(internal_smoother_pc,PCMG,ierr) - call SetupSmoothedAggregation(internal_smoother_pc, & - Internal_Smoother_Mat, ierr, no_top_smoothing=lno_top_smoothing) - - ! PCSetOperators needs to be in small caps due to macro hack in include/petsc_legacy.h - call pcsetoperators(internal_smoother_pc,Internal_Smoother_Mat, Internal_Smoother_Mat, ierr) - - !set up pc to output - call PCShellSetApply(pc,ApplySmoother,ierr) - - surface_node_list = surface_node_list - 1 - -end subroutine SetUpInternalSmoother - -subroutine ApplySmoother(dummy,vec_in,vec_out,ierr_out) - Vec, intent(in) :: vec_in - Vec, intent(inout) :: vec_out - PetscErrorCode, intent(inout) :: ierr_out - integer, intent(in) :: dummy - - integer :: ierr - - ierr_out=0 - - call PCApply(internal_smoother_pc,vec_in,vec_out, ierr) - - call VecSetValues(vec_out, size(surface_node_list), & - surface_node_list, real(spread(0.0, 1, size(surface_values)), kind = PetscScalar_kind), & - INSERT_VALUES, ierr) - -end subroutine ApplySmoother - -subroutine DestroyInternalSmoother() + integer, intent(in), dimension(:) :: surface_node_list_in + type(csr_matrix), intent(in) :: matrix + PC, intent(inout) :: pc + logical, intent(in), optional :: no_top_smoothing + ! + type(csr_matrix) :: matrix_internal + integer :: row,i, ierr, nsurface + integer, dimension(:), pointer :: r_ptr + + integer, dimension(:), allocatable :: surface_flag + logical :: lno_top_smoothing + ! these are used to point at things in csr_matrices so should be using + ! real instead of PetscReal + real, dimension(:), pointer :: r_val_ptr + + lno_top_smoothing = .false. + if(present(no_top_smoothing)) then + lno_top_smoothing = no_top_smoothing + end if + nsurface = size(surface_node_list_in) + allocate(surface_node_list(nsurface)) + surface_node_list = surface_node_list_in + allocate(surface_values(nsurface)) + surface_values = 0. + + allocate(surface_flag(size(matrix,1))) + surface_flag = 1 + surface_flag(surface_node_list) = 0 + + call allocate(matrix_internal,matrix%sparsity) + call set(matrix_internal,matrix) + + !zero all surface columns in matrix_internal + do row = 1, size(matrix,1) + r_ptr => row_m_ptr(matrix_internal,row) + r_val_ptr => row_val_ptr(matrix_internal,row) + + if(any(surface_flag(r_ptr)==0)) then + call set(matrix_internal,row,r_ptr,r_val_ptr*surface_flag(r_ptr)) + end if + end do + + !zero all surface row in matrix_internal + !and put a 1 on the diagonal + do i = 1, size(surface_node_list) + row = surface_node_list(i) + r_ptr => row_m_ptr(matrix_internal,row) + r_val_ptr => row_val_ptr(matrix_internal,row) + + call set(matrix_internal,row,r_ptr,0.0*r_val_ptr) + call set(matrix_internal,row,row,1.0) + end do + + !create matrix + internal_smoother_mat = csr2petsc(matrix_internal) + !set up multigrid + call PCCreate(MPI_COMM_SELF,internal_smoother_pc,ierr) + call PCSetType(internal_smoother_pc,PCMG,ierr) + call SetupSmoothedAggregation(internal_smoother_pc, & + Internal_Smoother_Mat, ierr, no_top_smoothing=lno_top_smoothing) + + ! PCSetOperators needs to be in small caps due to macro hack in include/petsc_legacy.h + call pcsetoperators(internal_smoother_pc,Internal_Smoother_Mat, Internal_Smoother_Mat, ierr) + + !set up pc to output + call PCShellSetApply(pc,ApplySmoother,ierr) + + surface_node_list = surface_node_list - 1 + + end subroutine SetUpInternalSmoother + + subroutine ApplySmoother(dummy,vec_in,vec_out,ierr_out) + Vec, intent(in) :: vec_in + Vec, intent(inout) :: vec_out + PetscErrorCode, intent(inout) :: ierr_out + integer, intent(in) :: dummy + + integer :: ierr + + ierr_out=0 + + call PCApply(internal_smoother_pc,vec_in,vec_out, ierr) + + call VecSetValues(vec_out, size(surface_node_list), & + surface_node_list, real(spread(0.0, 1, size(surface_values)), kind = PetscScalar_kind), & + INSERT_VALUES, ierr) + + end subroutine ApplySmoother + + subroutine DestroyInternalSmoother() !!< Remove all trace of this preconditioner - implicit none - ! - integer :: ierr - ! - deallocate( surface_node_list ) - surface_node_list => null() - deallocate( surface_values ) - surface_values => null() - call PCDestroy(internal_smoother_pc,ierr) - call MatDestroy(internal_smoother_mat,ierr) - -end subroutine DestroyInternalSmoother - -subroutine SetupMultigrid(prec, matrix, ierror, & - external_prolongators, surface_node_list, matrix_csr, & - internal_smoothing_option) + implicit none + ! + integer :: ierr + ! + deallocate( surface_node_list ) + surface_node_list => null() + deallocate( surface_values ) + surface_values => null() + call PCDestroy(internal_smoother_pc,ierr) + call MatDestroy(internal_smoother_mat,ierr) + + end subroutine DestroyInternalSmoother + + subroutine SetupMultigrid(prec, matrix, ierror, & + external_prolongators, surface_node_list, matrix_csr, & + internal_smoothing_option) !!< This subroutine sets up the multigrid preconditioner including !!< all options (vertical_lumping, internal_smoother) -PC, intent(inout):: prec -Mat, intent(in):: matrix + PC, intent(inout):: prec + Mat, intent(in):: matrix !! ierror=0 upon succesful return, otherwise ierror=1 and everything !! will be deallocated -integer, intent(out):: ierror + integer, intent(out):: ierror !! use external prolongator at the finest level -type(petsc_csr_matrix), dimension(:), optional, intent(in):: external_prolongators + type(petsc_csr_matrix), dimension(:), optional, intent(in):: external_prolongators !! if present, use additve smoother that solves the eliptic problem with !! the solution of the last multigrid iteration at the top surface as !! dirichlet boundary condition -integer, optional, dimension(:):: surface_node_list -type(csr_matrix), intent(in), optional :: matrix_csr -integer, optional, intent(in) :: internal_smoothing_option - -integer :: linternal_smoothing_option - - PetscErrorCode ierr - PC subprec, subsubprec - - !! Get internal smoothing options - linternal_smoothing_option = INTERNAL_SMOOTHING_NONE - if(present(internal_smoothing_option)) then - linternal_smoothing_option = internal_smoothing_option - end if - - select case (linternal_smoothing_option) - case (INTERNAL_SMOOTHING_NONE) - !Don't apply internal smoothing, just regular mg - call SetupSmoothedAggregation(prec, matrix, ierror, & - external_prolongators=external_prolongators) - case (INTERNAL_SMOOTHING_WRAP_SOR) - !Apply the internal smoothing with wrapped SOR - if(.not.present(surface_node_list)) then - FLAbort('surface_node_list is needed for chosen internal smoothing option') - end if - if(.not.present(matrix_csr)) then - FLAbort('matrix_csr must also be provided for internal smoother') - end if - - ! The overall preconditioner is compositive multiplicative - call PCSetType(prec, PCCOMPOSITE, ierr) - call PCCompositeSetType(prec, PC_COMPOSITE_MULTIPLICATIVE, ierr) - ! consisting of outer SOR iterations and the composite PC - call PCCompositeAddPCType(prec, PCSOR, ierr) - call PCCompositeAddPCType(prec, PCCOMPOSITE, ierr) - call PCCompositeAddPCType(prec, PCSOR, ierr) - - !set up the forward SOR - call PCCompositeGetPC(prec, 0, subprec, ierr) - call PCSORSetSymmetric(subprec,SOR_FORWARD_SWEEP,ierr) - call PCSORSetIterations(subprec,1,1,ierr) - call PCSORSetOmega(subprec,real(1.0, kind = PetscReal_kind),ierr) - - ! set up the backward SOR - call PCCompositeGetPC(prec, 2, subprec, ierr) - call PCSORSetSymmetric(subprec,SOR_BACKWARD_SWEEP,ierr) - call PCSORSetIterations(subprec,1,1,ierr) - call PCSORSetOmega(subprec,real(1.0, kind = PetscReal_kind),ierr) - - !set up the middle PC - call PCCompositeGetPC(prec, 1, subprec, ierr) - !It is compositive additive - call PCSetType(subprec, PCCOMPOSITE, ierr) - call PCCompositeSetType(subprec, PC_COMPOSITE_ADDITIVE, ierr) - !consisting of the vertical lumped mg, and the internal smoother - !which is a shell - call PCCompositeAddPCType(subprec, PCMG, ierr) - call PCCompositeAddPCType(subprec, PCSHELL, ierr) - ! set up the vertical_lumped mg - call PCCompositeGetPC(subprec, 0, subsubprec, ierr) - call SetupSmoothedAggregation(subsubprec, matrix, ierror, & - external_prolongators, no_top_smoothing=.true.) - !set up the "internal" mg shell - call PCCompositeGetPC(subprec, 1, subsubprec, ierr) - call SetupInternalSmoother(surface_node_list,matrix_csr,subsubprec, & - no_top_smoothing=.true.) - - case (INTERNAL_SMOOTHING_SEPARATE_SOR) - !Apply the internal smoothing with separate SOR for each mg - if(.not.present(surface_node_list)) then - FLAbort('surface_node_list is needed for chosen internal smoothing option') - end if - if(.not.present(matrix_csr)) then - FLAbort('matrix_csr must also be provided for internal smoother') - end if - - !It is compositive additive - call PCSetType(prec, PCCOMPOSITE, ierr) - call PCCompositeSetType(prec, PC_COMPOSITE_ADDITIVE, ierr) - !consisting of the vertical lumped mg, and the internal smoother - !which is a shell - call PCCompositeAddPCType(prec, PCMG, ierr) - call PCCompositeAddPCType(prec, PCSHELL, ierr) - ! set up the vertical_lumped mg - call PCCompositeGetPC(prec, 0, subprec, ierr) - call SetupSmoothedAggregation(subprec, matrix, ierror, & - external_prolongators=external_prolongators) - ! set up the "internal" mg shell - call PCCompositeGetPC(prec, 1, subprec, ierr) - call SetupInternalSmoother(surface_node_list,matrix_csr,subprec) - - case default - FLAbort('bad internal smoothing option') - end select - -end subroutine SetupMultigrid - -subroutine DestroyMultigrid(prec) -PC, intent(inout):: prec - - PetscErrorCode ierr - PCType pctype - PC subprec - - call PCGetType(prec, pctype, ierr) - if (pctype==PCCOMPOSITE) then - ! destroy the real mg - call PCCompositeGetPC(prec, 0, subprec, ierr) - ! destroy the internal mg - call PCCompositeGetPC(prec, 1, subprec, ierr) - call DestroyInternalSmoother() - end if - -end subroutine DestroyMultigrid - -subroutine SetupSmoothedAggregation(prec, matrix, ierror, & - external_prolongators,no_top_smoothing) + integer, optional, dimension(:):: surface_node_list + type(csr_matrix), intent(in), optional :: matrix_csr + integer, optional, intent(in) :: internal_smoothing_option + + integer :: linternal_smoothing_option + + PetscErrorCode ierr + PC subprec, subsubprec + + !! Get internal smoothing options + linternal_smoothing_option = INTERNAL_SMOOTHING_NONE + if(present(internal_smoothing_option)) then + linternal_smoothing_option = internal_smoothing_option + end if + + select case (linternal_smoothing_option) + case (INTERNAL_SMOOTHING_NONE) + !Don't apply internal smoothing, just regular mg + call SetupSmoothedAggregation(prec, matrix, ierror, & + external_prolongators=external_prolongators) + case (INTERNAL_SMOOTHING_WRAP_SOR) + !Apply the internal smoothing with wrapped SOR + if(.not.present(surface_node_list)) then + FLAbort('surface_node_list is needed for chosen internal smoothing option') + end if + if(.not.present(matrix_csr)) then + FLAbort('matrix_csr must also be provided for internal smoother') + end if + + ! The overall preconditioner is compositive multiplicative + call PCSetType(prec, PCCOMPOSITE, ierr) + call PCCompositeSetType(prec, PC_COMPOSITE_MULTIPLICATIVE, ierr) + ! consisting of outer SOR iterations and the composite PC + call PCCompositeAddPCType(prec, PCSOR, ierr) + call PCCompositeAddPCType(prec, PCCOMPOSITE, ierr) + call PCCompositeAddPCType(prec, PCSOR, ierr) + + !set up the forward SOR + call PCCompositeGetPC(prec, 0, subprec, ierr) + call PCSORSetSymmetric(subprec,SOR_FORWARD_SWEEP,ierr) + call PCSORSetIterations(subprec,1,1,ierr) + call PCSORSetOmega(subprec,real(1.0, kind = PetscReal_kind),ierr) + + ! set up the backward SOR + call PCCompositeGetPC(prec, 2, subprec, ierr) + call PCSORSetSymmetric(subprec,SOR_BACKWARD_SWEEP,ierr) + call PCSORSetIterations(subprec,1,1,ierr) + call PCSORSetOmega(subprec,real(1.0, kind = PetscReal_kind),ierr) + + !set up the middle PC + call PCCompositeGetPC(prec, 1, subprec, ierr) + !It is compositive additive + call PCSetType(subprec, PCCOMPOSITE, ierr) + call PCCompositeSetType(subprec, PC_COMPOSITE_ADDITIVE, ierr) + !consisting of the vertical lumped mg, and the internal smoother + !which is a shell + call PCCompositeAddPCType(subprec, PCMG, ierr) + call PCCompositeAddPCType(subprec, PCSHELL, ierr) + ! set up the vertical_lumped mg + call PCCompositeGetPC(subprec, 0, subsubprec, ierr) + call SetupSmoothedAggregation(subsubprec, matrix, ierror, & + external_prolongators, no_top_smoothing=.true.) + !set up the "internal" mg shell + call PCCompositeGetPC(subprec, 1, subsubprec, ierr) + call SetupInternalSmoother(surface_node_list,matrix_csr,subsubprec, & + no_top_smoothing=.true.) + + case (INTERNAL_SMOOTHING_SEPARATE_SOR) + !Apply the internal smoothing with separate SOR for each mg + if(.not.present(surface_node_list)) then + FLAbort('surface_node_list is needed for chosen internal smoothing option') + end if + if(.not.present(matrix_csr)) then + FLAbort('matrix_csr must also be provided for internal smoother') + end if + + !It is compositive additive + call PCSetType(prec, PCCOMPOSITE, ierr) + call PCCompositeSetType(prec, PC_COMPOSITE_ADDITIVE, ierr) + !consisting of the vertical lumped mg, and the internal smoother + !which is a shell + call PCCompositeAddPCType(prec, PCMG, ierr) + call PCCompositeAddPCType(prec, PCSHELL, ierr) + ! set up the vertical_lumped mg + call PCCompositeGetPC(prec, 0, subprec, ierr) + call SetupSmoothedAggregation(subprec, matrix, ierror, & + external_prolongators=external_prolongators) + ! set up the "internal" mg shell + call PCCompositeGetPC(prec, 1, subprec, ierr) + call SetupInternalSmoother(surface_node_list,matrix_csr,subprec) + + case default + FLAbort('bad internal smoothing option') + end select + + end subroutine SetupMultigrid + + subroutine DestroyMultigrid(prec) + PC, intent(inout):: prec + + PetscErrorCode ierr + PCType pctype + PC subprec + + call PCGetType(prec, pctype, ierr) + if (pctype==PCCOMPOSITE) then + ! destroy the real mg + call PCCompositeGetPC(prec, 0, subprec, ierr) + ! destroy the internal mg + call PCCompositeGetPC(prec, 1, subprec, ierr) + call DestroyInternalSmoother() + end if + + end subroutine DestroyMultigrid + + subroutine SetupSmoothedAggregation(prec, matrix, ierror, & + external_prolongators,no_top_smoothing) !!< This subroutine sets up the preconditioner for using the smoothed !!< aggregation method (as described in Vanek et al. !!< Computing 56, 179-196 (1996). -PC, intent(inout):: prec -Mat, intent(in):: matrix + PC, intent(inout):: prec + Mat, intent(in):: matrix !! ierror=0 upon succesful return, otherwise ierror=1 and everything !! will be deallocated -integer, intent(out):: ierror + integer, intent(out):: ierror !! use external prolongator at the finest level -type(petsc_csr_matrix), dimension(:), optional, intent(in):: external_prolongators + type(petsc_csr_matrix), dimension(:), optional, intent(in):: external_prolongators !! Don't do smoothing on the top level -logical, intent(in), optional :: no_top_smoothing - - Mat, allocatable, dimension(:):: matrices, prolongators - KSP ksp_smoother - PC prec_smoother - Vec lvec, rvec - MatNullSpace nullsp - PetscErrorCode ierr - PetscReal epsilon, epsilon_decay, omega - PetscInt maxlevels, coarsesize - PetscReal:: eigval - PetscScalar :: Px2 - Vec:: eigvec, Px - PetscReal, allocatable, dimension(:):: emin, emax - integer, allocatable, dimension(:):: contexts - integer i, j, ri, nolevels, m, n, top_level - integer nosmd, nosmu, clustersize, no_external_prolongators - logical forgetlastone - logical lno_top_smoothing - - ! this might be already done, but it doesn't hurt: - call PCSetType(prec, PCMG, ierr) - - call PCMGGetLevels(prec, nolevels, ierr) - if (ierr==0 .and. nolevels>0) then - ewrite(2,*) "Assuming mg preconditioner is used with the same matrix and same options as before" - ierror = 0 - return - end if - - lno_top_smoothing = .false. - if(present(no_top_smoothing)) then - lno_top_smoothing = no_top_smoothing - end if - - call SetSmoothedAggregationOptions(epsilon, epsilon_decay, omega, maxlevels, coarsesize, & - nosmd, nosmu, clustersize) - - ! In the following level i=1 is the original, fine, problem - ! i=nolevels corresponds to the coarsest problem - ! - ! Unfortunately PETSc uses a reverse numbering in which ri=0 - ! is the coarsest problem and ri=nolevels-1 the finest problem - ! - ! maxlevels is the, user specified (default=25) maximum for nolevels - ! matrices(i) is PETSc matrix at level i - ! prolongators(i) is PETSc prolongator between level i+1 and level i - ! its transpose is the restriction between level i and level i+1 - allocate(matrices(1:maxlevels), prolongators(1:maxlevels-1), & - contexts(1:maxlevels-1)) - - if (present(external_prolongators)) then - no_external_prolongators=size(external_prolongators) - else - no_external_prolongators=0 - end if - - forgetlastone=.false. - matrices(1)=matrix - do i=1, maxlevels-1 - ewrite(3,*) '---------------------' - ewrite(3,*) 'coarsening from level',i,' to ',i+1 - if (i<=no_external_prolongators) then - prolongators(i)=external_prolongators(i)%M - ewrite(2,*) "Using provided external prolongator" - ewrite(2,*) "Coarsening from", size(external_prolongators(i),1), & - "to", size(external_prolongators(i),2), "nodes" - else - prolongators(i)=Prolongator(matrices(i), epsilon, omega, clustersize) - epsilon=epsilon/epsilon_decay + logical, intent(in), optional :: no_top_smoothing + + Mat, allocatable, dimension(:):: matrices, prolongators + KSP ksp_smoother + PC prec_smoother + Vec lvec, rvec + MatNullSpace nullsp + PetscErrorCode ierr + PetscReal epsilon, epsilon_decay, omega + PetscInt maxlevels, coarsesize + PetscReal:: eigval + PetscScalar :: Px2 + Vec:: eigvec, Px + PetscReal, allocatable, dimension(:):: emin, emax + integer, allocatable, dimension(:):: contexts + integer i, j, ri, nolevels, m, n, top_level + integer nosmd, nosmu, clustersize, no_external_prolongators + logical forgetlastone + logical lno_top_smoothing + + ! this might be already done, but it doesn't hurt: + call PCSetType(prec, PCMG, ierr) + + call PCMGGetLevels(prec, nolevels, ierr) + if (ierr==0 .and. nolevels>0) then + ewrite(2,*) "Assuming mg preconditioner is used with the same matrix and same options as before" + ierror = 0 + return end if - if (prolongators(i)==PETSC_NULL_MAT) then - if (IsParallel()) then - ! in parallel we give up - ewrite(-1,*) "ERROR: mg preconditioner setup failed" - ewrite(-1,*) "This may be caused by local partitions being too small" - else - ! in serial you may want to try something else automatically - ewrite(0,*) 'WARNING: mg preconditioner setup failed' - ewrite(0,*) 'This probably means the matrix is not suitable for it.' - end if - do j=1+no_external_prolongators, i-1 - call MatDestroy(prolongators(j), ierr) - call MatDestroy(matrices(j), ierr) - end do - deallocate(matrices, prolongators, contexts) - ! Need to set n/o levels (to 1) otherwise PCDestroy will fail: - call PCMGSetLevels_nocomms(prec, 1, ierr) - ierror=1 - return + lno_top_smoothing = .false. + if(present(no_top_smoothing)) then + lno_top_smoothing = no_top_smoothing + end if + + call SetSmoothedAggregationOptions(epsilon, epsilon_decay, omega, maxlevels, coarsesize, & + nosmd, nosmu, clustersize) + + ! In the following level i=1 is the original, fine, problem + ! i=nolevels corresponds to the coarsest problem + ! + ! Unfortunately PETSc uses a reverse numbering in which ri=0 + ! is the coarsest problem and ri=nolevels-1 the finest problem + ! + ! maxlevels is the, user specified (default=25) maximum for nolevels + ! matrices(i) is PETSc matrix at level i + ! prolongators(i) is PETSc prolongator between level i+1 and level i + ! its transpose is the restriction between level i and level i+1 + allocate(matrices(1:maxlevels), prolongators(1:maxlevels-1), & + contexts(1:maxlevels-1)) + + if (present(external_prolongators)) then + no_external_prolongators=size(external_prolongators) + else + no_external_prolongators=0 end if - ! prolongator between i+1 and i, is restriction between i and i+1 - call MatGetLocalSize(prolongators(i), m, n, ierr) - call MatPtAP(matrices(i), prolongators(i), MAT_INITIAL_MATRIX, real(1.0, kind = PetscReal_kind), & - matrices(i+1), ierr) - - call allmin(n) - if (n0 .and. nosmd>0) then + + ! loop over the 'PETSc' index where 0 is coarse and nolevels-1 is fine: + do i=1, top_level + ! reverse index where 1 is fine and nolevels coarse: + ri=nolevels-i + call PCMGGetSmootherUp(prec, i, ksp_smoother, ierr) + if (IsParallel()) then + call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_LOCAL_SYMMETRIC_SWEEP, nosmu) + else + call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_FORWARD_SWEEP, nosmu) + end if + + call PCMGGetSmootherDown(prec, i, ksp_smoother, ierr) + if (lno_top_smoothing .and. i==nolevels-1) then + call SetupNoneSmoother(ksp_smoother, matrices(ri)) + else if (IsParallel()) then + call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_LOCAL_SYMMETRIC_SWEEP, nosmu) + else + call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_BACKWARD_SWEEP, nosmd) + end if + + end do - else if (nosmu>0 .and. nosmd>0) then + else + + FLAbort("Can't combine chebychev and sor smoothing") + + end if ! loop over the 'PETSc' index where 0 is coarse and nolevels-1 is fine: - do i=1, top_level - ! reverse index where 1 is fine and nolevels coarse: - ri=nolevels-i - call PCMGGetSmootherUp(prec, i, ksp_smoother, ierr) - if (IsParallel()) then - call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_LOCAL_SYMMETRIC_SWEEP, nosmu) - else - call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_FORWARD_SWEEP, nosmu) - end if - - call PCMGGetSmootherDown(prec, i, ksp_smoother, ierr) - if (lno_top_smoothing .and. i==nolevels-1) then - call SetupNoneSmoother(ksp_smoother, matrices(ri)) - else if (IsParallel()) then - call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_LOCAL_SYMMETRIC_SWEEP, nosmu) - else - call SetupSORSmoother(ksp_smoother, matrices(ri), SOR_BACKWARD_SWEEP, nosmd) - end if + do i=1, nolevels-1 + ! reverse index where 1 is fine and nolevels coarse: + ri=nolevels-i + + call PCMGSetInterpolation(prec, i, prolongators(ri), ierr) + call PCMGSetRestriction(prec, i, prolongators(ri), ierr) + ! This won't actually destroy them, as they are still refered to + ! as interpolators and restrictors. PETSc will destroy them once + ! these references are destroyed in KSP/PCDestroy: + if (ri>no_external_prolongators) then + call MatDestroy(prolongators(ri), ierr) + end if end do - else + ! residual needs to be set if PCMG is used with KSPRICHARDSON + lvec = PETSC_NOTANULL_VEC; rvec = PETSC_NOTANULL_VEC + call MatCreateVecs(matrices(1), lvec, rvec, ierr) + call PCMGSetR(prec, nolevels-1, lvec, ierr) + call VecDestroy(lvec, ierr) + call VecDestroy(rvec, ierr) + + ! solver options coarsest level: + call PCMGGetCoarseSolve(prec, ksp_smoother, ierr) + call KSPGetPC(ksp_smoother, prec_smoother, ierr) + call MatGetNullSpace(matrix, nullsp, ierr) + if (IsParallel() .or. (ierr==0 .and. .not. IsNullMatNullSpace(nullsp))) then + ! if parallel or if we have a null space: use smoothing instead of direct solve + call SetupSORSmoother(ksp_smoother, matrices(nolevels), & + SOR_LOCAL_SYMMETRIC_SWEEP, 20) + else + call KSPSetOperators(ksp_smoother, matrices(nolevels), matrices(nolevels), ierr) + call KSPSetType(ksp_smoother, KSPPREONLY, ierr) + call PCSetType(prec_smoother, PCLU, ierr) + call KSPSetTolerances(ksp_smoother, 1.0e-100_PetscReal_kind, 1e-8_PetscReal_kind, 1e10_PetscReal_kind, 300, ierr) + end if - FLAbort("Can't combine chebychev and sor smoothing") + ! destroy our references of the operators at levels 2 (==one but finest) up to coarsest + do i=2, nolevels + call MatDestroy(matrices(i), ierr) + end do - end if + deallocate(matrices, prolongators, contexts) - ! loop over the 'PETSc' index where 0 is coarse and nolevels-1 is fine: - do i=1, nolevels-1 - ! reverse index where 1 is fine and nolevels coarse: - ri=nolevels-i + ! succesful return + ierror=0 - call PCMGSetInterpolation(prec, i, prolongators(ri), ierr) - call PCMGSetRestriction(prec, i, prolongators(ri), ierr) - ! This won't actually destroy them, as they are still refered to - ! as interpolators and restrictors. PETSc will destroy them once - ! these references are destroyed in KSP/PCDestroy: - if (ri>no_external_prolongators) then - call MatDestroy(prolongators(ri), ierr) - end if + end subroutine SetupSmoothedAggregation - end do - - ! residual needs to be set if PCMG is used with KSPRICHARDSON - lvec = PETSC_NOTANULL_VEC; rvec = PETSC_NOTANULL_VEC - call MatCreateVecs(matrices(1), lvec, rvec, ierr) - call PCMGSetR(prec, nolevels-1, lvec, ierr) - call VecDestroy(lvec, ierr) - call VecDestroy(rvec, ierr) - - ! solver options coarsest level: - call PCMGGetCoarseSolve(prec, ksp_smoother, ierr) - call KSPGetPC(ksp_smoother, prec_smoother, ierr) - call MatGetNullSpace(matrix, nullsp, ierr) - if (IsParallel() .or. (ierr==0 .and. .not. IsNullMatNullSpace(nullsp))) then - ! if parallel or if we have a null space: use smoothing instead of direct solve - call SetupSORSmoother(ksp_smoother, matrices(nolevels), & - SOR_LOCAL_SYMMETRIC_SWEEP, 20) - else - call KSPSetOperators(ksp_smoother, matrices(nolevels), matrices(nolevels), ierr) - call KSPSetType(ksp_smoother, KSPPREONLY, ierr) - call PCSetType(prec_smoother, PCLU, ierr) - call KSPSetTolerances(ksp_smoother, 1.0e-100_PetscReal_kind, 1e-8_PetscReal_kind, 1e10_PetscReal_kind, 300, ierr) - end if - - ! destroy our references of the operators at levels 2 (==one but finest) up to coarsest - do i=2, nolevels - call MatDestroy(matrices(i), ierr) - end do - - deallocate(matrices, prolongators, contexts) - - ! succesful return - ierror=0 - -end subroutine SetupSmoothedAggregation - -subroutine SetupSORSmoother(ksp, matrix, sortype, iterations) -KSP, intent(in):: ksp -Mat, intent(in):: matrix -MatSORType, intent(in):: sortype -integer, intent(in):: iterations - - PC:: pc - PetscErrorCode:: ierr - - call KSPSetType(ksp, KSPRICHARDSON, ierr) - call KSPSetOperators(ksp, matrix, matrix, ierr) - ! set 1 richardson iteration, as global iteration inside pcsor might be more efficient - call KSPSetTolerances(ksp, PETSC_DEFAULT_REAL, & - PETSC_DEFAULT_REAL, PETSC_DEFAULT_REAL, & - 1, ierr) - call KSPSetNormType(ksp, KSP_NORM_NONE, ierr) - - call KSPGetPC(ksp, pc, ierr) - call PCSetType(pc, PCSOR, ierr) - call PCSORSetSymmetric(pc, sortype, ierr) - call PCSORSetOmega(pc, real(1.0, kind = PetscReal_kind), ierr) - call PCSORSetIterations(pc, iterations, 1, ierr) - -end subroutine SetupSORSmoother - -subroutine SetupNoneSmoother(ksp, matrix) -KSP, intent(in):: ksp -Mat, intent(in):: matrix - - PC:: pc - PetscErrorCode:: ierr - - call KSPSetType(ksp, KSPRICHARDSON, ierr) - call KSPSetOperators(ksp, matrix, matrix, ierr) - call KSPSetTolerances(ksp, PETSC_DEFAULT_REAL, & - PETSC_DEFAULT_REAL, PETSC_DEFAULT_REAL, & - 0, ierr) - call KSPRichardsonSetScale(ksp,real(0.0, kind = PetscReal_kind),ierr) - call KSPSetNormType(ksp, KSP_NORM_NONE, ierr) - - call KSPGetPC(ksp, pc, ierr) - call PCSetType(pc,PCNONE,ierr) - -end subroutine SetupNoneSmoother - -subroutine SetupChebychevSmoother(ksp, matrix, emin, emax, iterations) -KSP, intent(in):: ksp -Mat, intent(in):: matrix -PetscReal, intent(in):: emin, emax -integer, intent(in):: iterations - - PC:: pc - PetscErrorCode:: ierr - - call KSPSetType(ksp, KSPCHEBYSHEV, ierr) - call KSPSetOperators(ksp, matrix, matrix, ierr) - call KSPSetTolerances(ksp, PETSC_DEFAULT_REAL, & - PETSC_DEFAULT_REAL, PETSC_DEFAULT_REAL, & - iterations, ierr) - call KSPChebyshevSetEigenvalues(ksp, emax, emin, ierr) - call KSPSetNormType(ksp, KSP_NORM_NONE, ierr) - - call KSPGetPC(ksp, pc, ierr) - call PCSetType(pc, PCNONE, ierr) - -end subroutine SetupChebychevSmoother - -subroutine SetSmoothedAggregationOptions(epsilon, epsilon_decay, omega, maxlevels, & - coarsesize, nosmd, nosmu, clustersize) -PetscReal, intent(out):: epsilon, epsilon_decay, omega -integer, intent(out):: maxlevels, coarsesize -integer, intent(out):: nosmd, nosmu, clustersize - - PetscBool flag - PetscErrorCode ierr - - call PetscOptionsGetReal(PETSC_NULL_OPTIONS, '', '-mymg_epsilon', epsilon, flag, ierr) - if (.not. flag) then - epsilon=MULTIGRID_EPSILON_DEFAULT - end if - call PetscOptionsGetReal(PETSC_NULL_OPTIONS, '', '-mymg_epsilon_decay', epsilon_decay, flag, ierr) - if (.not. flag) then - epsilon_decay=MULTIGRID_EPSILON_DECAY_DEFAULT - end if - call PetscOptionsGetReal(PETSC_NULL_OPTIONS, '', '-mymg_omega', omega, flag, ierr) - if (.not. flag) then - omega=MULTIGRID_OMEGA_DEFAULT - end if - call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_maxlevels', maxlevels, flag, ierr) - if (.not. flag) then - maxlevels=MULTIGRID_MAXLEVELS_DEFAULT - end if - call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_coarsesize', coarsesize, flag, ierr) - if (.not. flag) then - if (IsParallel()) then - coarsesize=MULTIGRID_COARSESIZE_DEFAULT_PARALLEL - else - coarsesize=MULTIGRID_COARSESIZE_DEFAULT_SERIAL + subroutine SetupSORSmoother(ksp, matrix, sortype, iterations) + KSP, intent(in):: ksp + Mat, intent(in):: matrix + MatSORType, intent(in):: sortype + integer, intent(in):: iterations + + PC:: pc + PetscErrorCode:: ierr + + call KSPSetType(ksp, KSPRICHARDSON, ierr) + call KSPSetOperators(ksp, matrix, matrix, ierr) + ! set 1 richardson iteration, as global iteration inside pcsor might be more efficient + call KSPSetTolerances(ksp, PETSC_DEFAULT_REAL, & + PETSC_DEFAULT_REAL, PETSC_DEFAULT_REAL, & + 1, ierr) + call KSPSetNormType(ksp, KSP_NORM_NONE, ierr) + + call KSPGetPC(ksp, pc, ierr) + call PCSetType(pc, PCSOR, ierr) + call PCSORSetSymmetric(pc, sortype, ierr) + call PCSORSetOmega(pc, real(1.0, kind = PetscReal_kind), ierr) + call PCSORSetIterations(pc, iterations, 1, ierr) + + end subroutine SetupSORSmoother + + subroutine SetupNoneSmoother(ksp, matrix) + KSP, intent(in):: ksp + Mat, intent(in):: matrix + + PC:: pc + PetscErrorCode:: ierr + + call KSPSetType(ksp, KSPRICHARDSON, ierr) + call KSPSetOperators(ksp, matrix, matrix, ierr) + call KSPSetTolerances(ksp, PETSC_DEFAULT_REAL, & + PETSC_DEFAULT_REAL, PETSC_DEFAULT_REAL, & + 0, ierr) + call KSPRichardsonSetScale(ksp,real(0.0, kind = PetscReal_kind),ierr) + call KSPSetNormType(ksp, KSP_NORM_NONE, ierr) + + call KSPGetPC(ksp, pc, ierr) + call PCSetType(pc,PCNONE,ierr) + + end subroutine SetupNoneSmoother + + subroutine SetupChebychevSmoother(ksp, matrix, emin, emax, iterations) + KSP, intent(in):: ksp + Mat, intent(in):: matrix + PetscReal, intent(in):: emin, emax + integer, intent(in):: iterations + + PC:: pc + PetscErrorCode:: ierr + + call KSPSetType(ksp, KSPCHEBYSHEV, ierr) + call KSPSetOperators(ksp, matrix, matrix, ierr) + call KSPSetTolerances(ksp, PETSC_DEFAULT_REAL, & + PETSC_DEFAULT_REAL, PETSC_DEFAULT_REAL, & + iterations, ierr) + call KSPChebyshevSetEigenvalues(ksp, emax, emin, ierr) + call KSPSetNormType(ksp, KSP_NORM_NONE, ierr) + + call KSPGetPC(ksp, pc, ierr) + call PCSetType(pc, PCNONE, ierr) + + end subroutine SetupChebychevSmoother + + subroutine SetSmoothedAggregationOptions(epsilon, epsilon_decay, omega, maxlevels, & + coarsesize, nosmd, nosmu, clustersize) + PetscReal, intent(out):: epsilon, epsilon_decay, omega + integer, intent(out):: maxlevels, coarsesize + integer, intent(out):: nosmd, nosmu, clustersize + + PetscBool flag + PetscErrorCode ierr + + call PetscOptionsGetReal(PETSC_NULL_OPTIONS, '', '-mymg_epsilon', epsilon, flag, ierr) + if (.not. flag) then + epsilon=MULTIGRID_EPSILON_DEFAULT + end if + call PetscOptionsGetReal(PETSC_NULL_OPTIONS, '', '-mymg_epsilon_decay', epsilon_decay, flag, ierr) + if (.not. flag) then + epsilon_decay=MULTIGRID_EPSILON_DECAY_DEFAULT + end if + call PetscOptionsGetReal(PETSC_NULL_OPTIONS, '', '-mymg_omega', omega, flag, ierr) + if (.not. flag) then + omega=MULTIGRID_OMEGA_DEFAULT + end if + call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_maxlevels', maxlevels, flag, ierr) + if (.not. flag) then + maxlevels=MULTIGRID_MAXLEVELS_DEFAULT + end if + call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_coarsesize', coarsesize, flag, ierr) + if (.not. flag) then + if (IsParallel()) then + coarsesize=MULTIGRID_COARSESIZE_DEFAULT_PARALLEL + else + coarsesize=MULTIGRID_COARSESIZE_DEFAULT_SERIAL + end if end if - end if - call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_nosmd', nosmd, flag, ierr) - if (.not. flag) then - nosmd=MULTIGRID_NOSMD_DEFAULT - end if - call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_nosmu', nosmu, flag, ierr) - if (.not. flag) then - nosmu=MULTIGRID_NOSMU_DEFAULT - end if - call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_clustersize', clustersize, flag, ierr) - if (.not. flag) then - clustersize=MULTIGRID_CLUSTERSIZE_DEFAULT - end if - - ewrite(2,*) 'multgrid options- epsilon:', epsilon - ewrite(2,*) 'multgrid options- epsilon_decay:', epsilon_decay - ewrite(2,*) 'multgrid options- omega: ', omega - ewrite(2,*) 'multgrid options- maxlevels:', maxlevels - ewrite(2,*) 'multgrid options- coarsesize: ', coarsesize - ewrite(2,*) 'multgrid options- n/o smoother its down (nosmd): ', nosmd - ewrite(2,*) 'multgrid options- n/o smoother its up (nosmu): ', nosmu - ewrite(2,*) 'multgrid options- maximum clustersize: ', clustersize - -end subroutine SetSmoothedAggregationOptions - -function Prolongator(A, epsilon, omega, maxclustersize, cluster) result (P) + call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_nosmd', nosmd, flag, ierr) + if (.not. flag) then + nosmd=MULTIGRID_NOSMD_DEFAULT + end if + call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_nosmu', nosmu, flag, ierr) + if (.not. flag) then + nosmu=MULTIGRID_NOSMU_DEFAULT + end if + call PetscOptionsGetInt(PETSC_NULL_OPTIONS, '', '-mymg_clustersize', clustersize, flag, ierr) + if (.not. flag) then + clustersize=MULTIGRID_CLUSTERSIZE_DEFAULT + end if + + ewrite(2,*) 'multgrid options- epsilon:', epsilon + ewrite(2,*) 'multgrid options- epsilon_decay:', epsilon_decay + ewrite(2,*) 'multgrid options- omega: ', omega + ewrite(2,*) 'multgrid options- maxlevels:', maxlevels + ewrite(2,*) 'multgrid options- coarsesize: ', coarsesize + ewrite(2,*) 'multgrid options- n/o smoother its down (nosmd): ', nosmd + ewrite(2,*) 'multgrid options- n/o smoother its up (nosmu): ', nosmu + ewrite(2,*) 'multgrid options- maximum clustersize: ', clustersize + + end subroutine SetSmoothedAggregationOptions + + function Prolongator(A, epsilon, omega, maxclustersize, cluster) result (P) !!< Constructs coarse grid and prolongator operator between coarse and fine !!< grid based on the matrix A. -Mat:: P -Mat, intent(in):: A + Mat:: P + Mat, intent(in):: A !! strong connectivity criterion as in Vanek '96 -PetscReal, intent(in):: epsilon + PetscReal, intent(in):: epsilon !! overrelaxtion in jacobi-smoothed aggregation -PetscReal, intent(in):: omega + PetscReal, intent(in):: omega !! maximum size of clusters -integer, intent(in):: maxclustersize + integer, intent(in):: maxclustersize !! 0 means only clustering as in Vanek '96 !! if supplied returns cluster number each node is assigned to: -integer, optional, dimension(:), intent(out):: cluster - - PetscErrorCode:: ierr - PetscInt:: diagminloc - PetscReal:: diagmin - Vec:: sqrt_diag, inv_sqrt_diag, diag, one - double precision, dimension(MAT_INFO_SIZE):: matrixinfo - integer, dimension(:), allocatable:: findN, N, R - integer:: nrows, nentries, ncols - integer:: jc, ccnt, base, end_of_range - - ! find out basic dimensions of A - call MatGetLocalSize(A, nrows, ncols, ierr) - ! use Petsc_Tools's MatGetInfo because of bug in earlier patch levels of petsc 3.0 - call MatGetInfo(A, MAT_LOCAL, matrixinfo, ierr) - nentries=matrixinfo(MAT_INFO_NZ_USED) - call MatGetOwnerShipRange(A, base, end_of_range, ierr) - ! we decrease by 1, so base+i gives 0-based petsc index if i is the local fortran index: - base=base-1 - - allocate(findN(1:nrows+1), N(1:nentries), R(1:nrows)) - - ! rescale the matrix: a_ij -> a_ij/sqrt(aii*ajj) - ! ensure we don't pass PETSC_NULL_VEC - diag = PETSC_NOTANULL_VEC; sqrt_diag = PETSC_NOTANULL_VEC - call MatCreateVecs(A, diag, sqrt_diag, ierr) - call MatGetDiagonal(A, diag, ierr) - call VecMin(diag, diagminloc, diagmin, ierr) - if (diagmin<=0.0) then - ewrite(0,*) 'Multigrid preconditioner "mg" requires strictly positive diagonal' - FLExit("Zero or negative value on the diagonal") - end if - - ! - call VecCopy(diag, sqrt_diag, ierr) - call VecSqrtAbs(sqrt_diag, ierr) - ! - call VecDuplicate(sqrt_diag, inv_sqrt_diag, ierr) - call VecCopy(sqrt_diag, inv_sqrt_diag, ierr) - call VecReciprocal(inv_sqrt_diag, ierr) - call MatDiagonalScale(A, inv_sqrt_diag, inv_sqrt_diag, ierr) - - ! construct the strongly coupled neighbourhoods N_i around each node - ! and use R to register isolated nodes i with N_i={i} - call Prolongator_init(R, ccnt, findN, N, A, base, epsilon) - - if (ccnt==0 .and. nrows>0) then - ! all nodes are isolated, strongly diagonal dominant matrix - ! we should solve by other means - if (present(cluster)) cluster=ISOLATED - deallocate(findN, N, R) - ! we return PETSC_NULL; callers of this function should check for this - P=PETSC_NULL_MAT - return - else if (100*ccnt<99*nrows .and. .not. IsParallel()) then - ! more than 1% isolated nodes, give a warning - ewrite(2,*) "Percentage of isolated nodes: ", (100.0*(nrows-ccnt))/nrows - ewrite(2,*) "Warning: more than 1 perc. isolated nodes - this may mean mg is not the most suitable preconditioner" - ewrite(2,*) "On small meshes with a lot of boundary nodes, this is typically fine though." - end if - - ! Step 1 - Startup aggregation - ! select some of the coupled neighbourhoods as an initial (incomplete) - ! covering - call Prolongator_step1(R, jc, findN, N, maxclustersize) - - ! Step 2 - Enlarging the decomposition sets (aggregates) - ! add remaining COUPLED but yet uncovered nodes to one of the aggregates - call Prolongator_step2(R, findN, N, A, base) - - ! Step 3 - Handling the remnants - ! the remaining nodes, that are COUPLED but neither in the original covering - ! or assigned in step 2, are assigned to new aggregates - call Prolongator_step3(R, jc, findN, N) - - ! jc is now the n/o aggregates, i.e. the n/o coarse nodes - ! R(i) is now either the coarse node, fine node i is assigned to - ! or ==ISOLATED - - ewrite(3,*) 'Fine nodes: ', nrows - ewrite(3,*) 'Isolated fine nodes: ', nrows-ccnt - ewrite(3,*) 'Aggregates: ', jc - - ! now scale a_ij -> a_ii^-1/2 * a_ij * ajj^1/2, i.e. starting from the - ! original matrix: a_ij -> a_ii^-1 * a_ij - call MatDiagonalScale(A, inv_sqrt_diag, sqrt_diag, ierr) - - ! we now have all the stuff to create the prolongator - call create_prolongator(P, nrows, jc, findN, N, R, A, base, omega) - - ! now restore the original matrix - ! unfortunately MatDiagonalScale is broken for one-sided scaling, i.e. - ! supplying PETSC_NULL(_OBJECT) for one the vectors - call VecDuplicate(diag, one, ierr) - call VecSet(one, 1.0_PetscReal_kind, ierr) - call MatDiagonalScale(A, diag, one, ierr) - - if (present(cluster)) cluster=R - deallocate(R, N, findN) - - call VecDestroy(diag, ierr) - call VecDestroy(sqrt_diag, ierr) - call VecDestroy(inv_sqrt_diag, ierr) - call VecDestroy(one, ierr) - -end function Prolongator - -subroutine create_prolongator(P, nrows, ncols, findN, N, R, A, base, omega) - - Mat, intent(out):: P - integer, intent(in):: nrows ! number of fine nodes - integer, intent(in):: ncols ! number of clusters - integer, dimension(:), intent(in):: findN, N, R - ! A needs to be left rescaled with the inverse diagonal: D^-1 A - Mat, intent(in):: A - integer, intent(in):: base - PetscReal, intent(in):: omega - - PetscErrorCode:: ierr - Vec:: rowsum_vec - PetscReal, dimension(:), allocatable:: Arowsum - PetscReal:: aij(1), rowsum - integer, dimension(:), allocatable:: dnnz, onnz - integer:: i, j, k, coarse_base, end_of_range - - allocate(dnnz(1:nrows), Arowsum(1:nrows)) - - ! work out nnz in each row of the new prolongator - dnnz=0 - do i=1, nrows - ! this is an overestimate it should count the number - ! of different R(j) values in each rows - do k=findN(i), findN(i+1)-1 - j=N(k) - if (R(j)>0) then - dnnz(i)=dnnz(i)+1 + integer, optional, dimension(:), intent(out):: cluster + + PetscErrorCode:: ierr + PetscInt:: diagminloc + PetscReal:: diagmin + Vec:: sqrt_diag, inv_sqrt_diag, diag, one + double precision, dimension(MAT_INFO_SIZE):: matrixinfo + integer, dimension(:), allocatable:: findN, N, R + integer:: nrows, nentries, ncols + integer:: jc, ccnt, base, end_of_range + + ! find out basic dimensions of A + call MatGetLocalSize(A, nrows, ncols, ierr) + ! use Petsc_Tools's MatGetInfo because of bug in earlier patch levels of petsc 3.0 + call MatGetInfo(A, MAT_LOCAL, matrixinfo, ierr) + nentries=matrixinfo(MAT_INFO_NZ_USED) + call MatGetOwnerShipRange(A, base, end_of_range, ierr) + ! we decrease by 1, so base+i gives 0-based petsc index if i is the local fortran index: + base=base-1 + + allocate(findN(1:nrows+1), N(1:nentries), R(1:nrows)) + + ! rescale the matrix: a_ij -> a_ij/sqrt(aii*ajj) + ! ensure we don't pass PETSC_NULL_VEC + diag = PETSC_NOTANULL_VEC; sqrt_diag = PETSC_NOTANULL_VEC + call MatCreateVecs(A, diag, sqrt_diag, ierr) + call MatGetDiagonal(A, diag, ierr) + call VecMin(diag, diagminloc, diagmin, ierr) + if (diagmin<=0.0) then + ewrite(0,*) 'Multigrid preconditioner "mg" requires strictly positive diagonal' + FLExit("Zero or negative value on the diagonal") end if - end do - ! since we overestimate, we don't want to get > ncols - dnnz(i)=min(dnnz(i), ncols) - end do - - if (IsParallel()) then - ! for the moment the prolongator is completely local: - allocate(onnz(1:nrows)) - onnz=0 - - call MatCreateAIJ(MPI_COMM_FEMTOOLS, nrows, ncols, PETSC_DECIDE, PETSC_DECIDE, & - 0, dnnz, 0, onnz, P, ierr) - call MatSetOption(P, MAT_USE_INODES, PETSC_FALSE, ierr) - - ! get base for coarse node/cluster numbering - call MatGetOwnerShipRangeColumn(P, coarse_base, end_of_range, ierr) - ! subtract 1 to convert from 1-based fortran to 0 based petsc - coarse_base=coarse_base-1 - else - call MatCreateAIJ(MPI_COMM_SELF, nrows, ncols, nrows, ncols, & - 0, dnnz, 0, PETSC_NULL_INTEGER, P, ierr) - call MatSetOption(P, MAT_USE_INODES, PETSC_FALSE, ierr) - ! subtract 1 from each cluster no to get petsc 0-based numbering - coarse_base=-1 - end if - call MatSetup(P, ierr) - - rowsum_vec = PETSC_NOTANULL_VEC - call MatCreateVecs(A, rowsum_vec, PETSC_NULL_VEC, ierr) - call VecPlaceArray(rowsum_vec, Arowsum, ierr) - call MatGetRowSum(A, rowsum_vec, ierr) - - do i=1, nrows - rowsum=0.0 - ! the filtered matrix only contains the entries in N_i: - do k=findN(i), findN(i+1)-1 - j=N(k) - call MatGetValues(A, 1, (/ base+i /), 1, (/ base+j /), aij, ierr) - rowsum=rowsum+aij(1) - if (R(j)>0) then - call MatSetValue(P, base+i, coarse_base+R(j), -omega*aij(1), & - ADD_VALUES, ierr) + + ! + call VecCopy(diag, sqrt_diag, ierr) + call VecSqrtAbs(sqrt_diag, ierr) + ! + call VecDuplicate(sqrt_diag, inv_sqrt_diag, ierr) + call VecCopy(sqrt_diag, inv_sqrt_diag, ierr) + call VecReciprocal(inv_sqrt_diag, ierr) + call MatDiagonalScale(A, inv_sqrt_diag, inv_sqrt_diag, ierr) + + ! construct the strongly coupled neighbourhoods N_i around each node + ! and use R to register isolated nodes i with N_i={i} + call Prolongator_init(R, ccnt, findN, N, A, base, epsilon) + + if (ccnt==0 .and. nrows>0) then + ! all nodes are isolated, strongly diagonal dominant matrix + ! we should solve by other means + if (present(cluster)) cluster=ISOLATED + deallocate(findN, N, R) + ! we return PETSC_NULL; callers of this function should check for this + P=PETSC_NULL_MAT + return + else if (100*ccnt<99*nrows .and. .not. IsParallel()) then + ! more than 1% isolated nodes, give a warning + ewrite(2,*) "Percentage of isolated nodes: ", (100.0*(nrows-ccnt))/nrows + ewrite(2,*) "Warning: more than 1 perc. isolated nodes - this may mean mg is not the most suitable preconditioner" + ewrite(2,*) "On small meshes with a lot of boundary nodes, this is typically fine though." + end if + + ! Step 1 - Startup aggregation + ! select some of the coupled neighbourhoods as an initial (incomplete) + ! covering + call Prolongator_step1(R, jc, findN, N, maxclustersize) + + ! Step 2 - Enlarging the decomposition sets (aggregates) + ! add remaining COUPLED but yet uncovered nodes to one of the aggregates + call Prolongator_step2(R, findN, N, A, base) + + ! Step 3 - Handling the remnants + ! the remaining nodes, that are COUPLED but neither in the original covering + ! or assigned in step 2, are assigned to new aggregates + call Prolongator_step3(R, jc, findN, N) + + ! jc is now the n/o aggregates, i.e. the n/o coarse nodes + ! R(i) is now either the coarse node, fine node i is assigned to + ! or ==ISOLATED + + ewrite(3,*) 'Fine nodes: ', nrows + ewrite(3,*) 'Isolated fine nodes: ', nrows-ccnt + ewrite(3,*) 'Aggregates: ', jc + + ! now scale a_ij -> a_ii^-1/2 * a_ij * ajj^1/2, i.e. starting from the + ! original matrix: a_ij -> a_ii^-1 * a_ij + call MatDiagonalScale(A, inv_sqrt_diag, sqrt_diag, ierr) + + ! we now have all the stuff to create the prolongator + call create_prolongator(P, nrows, jc, findN, N, R, A, base, omega) + + ! now restore the original matrix + ! unfortunately MatDiagonalScale is broken for one-sided scaling, i.e. + ! supplying PETSC_NULL(_OBJECT) for one the vectors + call VecDuplicate(diag, one, ierr) + call VecSet(one, 1.0_PetscReal_kind, ierr) + call MatDiagonalScale(A, diag, one, ierr) + + if (present(cluster)) cluster=R + deallocate(R, N, findN) + + call VecDestroy(diag, ierr) + call VecDestroy(sqrt_diag, ierr) + call VecDestroy(inv_sqrt_diag, ierr) + call VecDestroy(one, ierr) + + end function Prolongator + + subroutine create_prolongator(P, nrows, ncols, findN, N, R, A, base, omega) + + Mat, intent(out):: P + integer, intent(in):: nrows ! number of fine nodes + integer, intent(in):: ncols ! number of clusters + integer, dimension(:), intent(in):: findN, N, R + ! A needs to be left rescaled with the inverse diagonal: D^-1 A + Mat, intent(in):: A + integer, intent(in):: base + PetscReal, intent(in):: omega + + PetscErrorCode:: ierr + Vec:: rowsum_vec + PetscReal, dimension(:), allocatable:: Arowsum + PetscReal:: aij(1), rowsum + integer, dimension(:), allocatable:: dnnz, onnz + integer:: i, j, k, coarse_base, end_of_range + + allocate(dnnz(1:nrows), Arowsum(1:nrows)) + + ! work out nnz in each row of the new prolongator + dnnz=0 + do i=1, nrows + ! this is an overestimate it should count the number + ! of different R(j) values in each rows + do k=findN(i), findN(i+1)-1 + j=N(k) + if (R(j)>0) then + dnnz(i)=dnnz(i)+1 + end if + end do + ! since we overestimate, we don't want to get > ncols + dnnz(i)=min(dnnz(i), ncols) + end do + + if (IsParallel()) then + ! for the moment the prolongator is completely local: + allocate(onnz(1:nrows)) + onnz=0 + + call MatCreateAIJ(MPI_COMM_FEMTOOLS, nrows, ncols, PETSC_DECIDE, PETSC_DECIDE, & + 0, dnnz, 0, onnz, P, ierr) + call MatSetOption(P, MAT_USE_INODES, PETSC_FALSE, ierr) + + ! get base for coarse node/cluster numbering + call MatGetOwnerShipRangeColumn(P, coarse_base, end_of_range, ierr) + ! subtract 1 to convert from 1-based fortran to 0 based petsc + coarse_base=coarse_base-1 + else + call MatCreateAIJ(MPI_COMM_SELF, nrows, ncols, nrows, ncols, & + 0, dnnz, 0, PETSC_NULL_INTEGER, P, ierr) + call MatSetOption(P, MAT_USE_INODES, PETSC_FALSE, ierr) + ! subtract 1 from each cluster no to get petsc 0-based numbering + coarse_base=-1 end if - end do - if (R(i)>0) then - call MatSetValue(P, base+i, coarse_base+R(i), & - 1+omega*( rowsum-Arowsum(i) ), ADD_VALUES, ierr) - end if - end do + call MatSetup(P, ierr) + + rowsum_vec = PETSC_NOTANULL_VEC + call MatCreateVecs(A, rowsum_vec, PETSC_NULL_VEC, ierr) + call VecPlaceArray(rowsum_vec, Arowsum, ierr) + call MatGetRowSum(A, rowsum_vec, ierr) + + do i=1, nrows + rowsum=0.0 + ! the filtered matrix only contains the entries in N_i: + do k=findN(i), findN(i+1)-1 + j=N(k) + call MatGetValues(A, 1, (/ base+i /), 1, (/ base+j /), aij, ierr) + rowsum=rowsum+aij(1) + if (R(j)>0) then + call MatSetValue(P, base+i, coarse_base+R(j), -omega*aij(1), & + ADD_VALUES, ierr) + end if + end do + if (R(i)>0) then + call MatSetValue(P, base+i, coarse_base+R(i), & + 1+omega*( rowsum-Arowsum(i) ), ADD_VALUES, ierr) + end if + end do - call MatAssemblyBegin(P, MAT_FINAL_ASSEMBLY, ierr) - call MatAssemblyEnd(P, MAT_FINAL_ASSEMBLY, ierr) + call MatAssemblyBegin(P, MAT_FINAL_ASSEMBLY, ierr) + call MatAssemblyEnd(P, MAT_FINAL_ASSEMBLY, ierr) - call VecDestroy(rowsum_vec, ierr) + call VecDestroy(rowsum_vec, ierr) -end subroutine create_prolongator + end subroutine create_prolongator -subroutine Prolongator_init(R, ccnt, findN, N, A, base, epsilon) + subroutine Prolongator_init(R, ccnt, findN, N, A, base, epsilon) ! construct the strongly coupled neighbourhoods N_i around each node ! and use R to register isolated nodes i with N_i={i} -integer, dimension(:), intent(out):: R, findN, N -integer, intent(out):: ccnt -Mat, intent(in):: A -integer, intent(in):: base -PetscReal, intent(in):: epsilon - - PetscErrorCode:: ierr - PetscReal, dimension(:), allocatable:: vals(:) - integer, dimension(:), allocatable:: cols(:) - PetscReal aij, eps_sqrt - integer i, j, k, p, ncols - - ! workspace for MatGetRow - allocate( vals(1:size(N)), cols(1:size(n)) ) - - eps_sqrt=sqrt(epsilon) - - ccnt=0 ! counts the coupled nodes, i.e. nodes that are not isolated - p=1 - do i=1, size(R) - findN(i)=p - call MatGetRow(A, base+i, ncols, cols, vals, ierr) - do k=1, ncols - j=cols(k)-base - ! ignore non-local columns - if (j<1 .or. j>size(R)) cycle - aij=vals(k) - if (abs(aij)>eps_sqrt) then - N(p)=j - p=p+1 - end if - end do - ! N_i always contains i itself, so p has to be increased with at least 2 - if (p>findN(i)+1) then - R(i)=COUPLED - ccnt=ccnt+1 - else - R(i)=ISOLATED - end if - call MatRestoreRow(A, base+i, ncols, cols, vals, ierr) - end do - findN(i)=p - -end subroutine Prolongator_init - -subroutine Prolongator_step1(R, jc, findN, N, maxclustersize) -integer, dimension(:), intent(inout):: R -integer, intent(out):: jc -integer, dimension(:), intent(in):: findN, N -integer, intent(in):: maxclustersize - ! Step 1 - Startup aggregation - ! select some of the coupled neighbourhoods as an initial (incomplete) - ! covering - - integer, dimension(:), allocatable:: clustersize - integer i, j - - allocate(clustersize(1:size(R))) - clustersize=0 - jc=0 ! count the covering sets, aka aggregates - do i=1, size(R) - ! if the entire N_i is still a subset of R: - if (R(i)==COUPLED) then - if (all(R(N(findN(i):findN(i+1)-1))==COUPLED)) then - jc=jc+1 ! new aggregate - ! assign all of N_i to aggr. jc and remove from R: - R(N(findN(i):findN(i+1)-1))=jc - clustersize(jc)=findN(i+1)-findN(i) - else - ! here we deviate from Vanek'96 by allowing this node to be added - ! to existing clusters, as long as maxclustersize isn't exceeded - do j=findN(i), findN(i+1)-1 - if (N(j)==i) cycle - if (R(N(j))>0) then - if (clustersize(R(N(j)))size(R)) cycle + aij=vals(k) + if (abs(aij)>eps_sqrt) then + N(p)=j + p=p+1 + end if + end do + ! N_i always contains i itself, so p has to be increased with at least 2 + if (p>findN(i)+1) then + R(i)=COUPLED + ccnt=ccnt+1 + else + R(i)=ISOLATED + end if + call MatRestoreRow(A, base+i, ncols, cols, vals, ierr) + end do + findN(i)=p + + end subroutine Prolongator_init + + subroutine Prolongator_step1(R, jc, findN, N, maxclustersize) + integer, dimension(:), intent(inout):: R + integer, intent(out):: jc + integer, dimension(:), intent(in):: findN, N + integer, intent(in):: maxclustersize + ! Step 1 - Startup aggregation + ! select some of the coupled neighbourhoods as an initial (incomplete) + ! covering + + integer, dimension(:), allocatable:: clustersize + integer i, j + + allocate(clustersize(1:size(R))) + clustersize=0 + jc=0 ! count the covering sets, aka aggregates + do i=1, size(R) + ! if the entire N_i is still a subset of R: + if (R(i)==COUPLED) then + if (all(R(N(findN(i):findN(i+1)-1))==COUPLED)) then + jc=jc+1 ! new aggregate + ! assign all of N_i to aggr. jc and remove from R: + R(N(findN(i):findN(i+1)-1))=jc + clustersize(jc)=findN(i+1)-findN(i) + else + ! here we deviate from Vanek'96 by allowing this node to be added + ! to existing clusters, as long as maxclustersize isn't exceeded + do j=findN(i), findN(i+1)-1 + if (N(j)==i) cycle + if (R(N(j))>0) then + if (clustersize(R(N(j)))0) then - j=N(p) - call MatGetValues(A, 1, (/ base+i /), 1, (/ base+j /), aij, ierr) - if (abs(aij(1))>maxc) then - maxc=abs(aij(1)) - k=R(j) - end if - end if + integer, dimension(:), intent(inout):: R + integer, dimension(:), intent(in):: findN, N + Mat, intent(in):: A + integer, intent(in):: base + + PetscErrorCode:: ierr + PetscReal:: maxc, aij(1) + integer:: i, j, k, p + + do i=1, size(R) + if (R(i)==COUPLED) then + ! find the strongest coupling in N_i that is assigned to one of the + ! aggregates in step 1 + maxc=0 + k=0 + do p=findN(i), findN(i+1)-1 + j=N(p) + if (R(j)>0) then + j=N(p) + call MatGetValues(A, 1, (/ base+i /), 1, (/ base+j /), aij, ierr) + if (abs(aij(1))>maxc) then + maxc=abs(aij(1)) + k=R(j) + end if + end if + end do + ! remove i from R, register its assignment to aggregate k + if (k/=0) then + R(i)=-k+COUPLED ! the assignment is temp. registered with a negative + ! number, so as not to actually change the aggregates of step 1 + ! before completion of step 2, the negative numbers should be below + ! the value of COUPLED + end if + end if end do - ! remove i from R, register its assignment to aggregate k - if (k/=0) then - R(i)=-k+COUPLED ! the assignment is temp. registered with a negative - ! number, so as not to actually change the aggregates of step 1 - ! before completion of step 2, the negative numbers should be below - ! the value of COUPLED - end if - end if - end do -end subroutine Prolongator_step2 + end subroutine Prolongator_step2 -subroutine Prolongator_step3(R, jc, findN, N) + subroutine Prolongator_step3(R, jc, findN, N) ! Step 3 - Handling the remnants ! the remaining nodes, that are COUPLED but neither in the original covering ! or assigned in step 2, are assigned to new aggregates -integer, dimension(:), intent(inout):: R -integer, intent(inout):: jc -integer, dimension(:), intent(in):: findN, N - - integer i, j, p - - do i=1, size(R) - if (R(i)==COUPLED) then - ewrite(3,*) 'step3 action! ',i, ':', N(findN(i):findN(i+1)-1) - jc=jc+1 ! add new aggregate - do p=findN(i), findN(i+1)-1 - j=N(p) - if (R(j)==COUPLED) then - R(j)=jc - end if + integer, dimension(:), intent(inout):: R + integer, intent(inout):: jc + integer, dimension(:), intent(in):: findN, N + + integer i, j, p + + do i=1, size(R) + if (R(i)==COUPLED) then + ewrite(3,*) 'step3 action! ',i, ':', N(findN(i):findN(i+1)-1) + jc=jc+1 ! add new aggregate + do p=findN(i), findN(i+1)-1 + j=N(p) + if (R(j)==COUPLED) then + R(j)=jc + end if + end do + else if (R(i) and < x_k+1, x_k > - call VecMDot(x_kp1, 2, (/ x_kp1, x_k /), dot_prods, ierr) - norm2=sqrt(dot_prods(1)) - rho_kp1=dot_prods(2) + do i=1, MAX_ITERATIONS + call MatMult(matrix, x_k, x_kp1, ierr) + ! compute < x_k+1, x_k+1 > and < x_k+1, x_k > + call VecMDot(x_kp1, 2, (/ x_kp1, x_k /), dot_prods, ierr) + norm2=sqrt(dot_prods(1)) + rho_kp1=dot_prods(2) - call VecScale(x_kp1, 1.0_PetscReal_kind/norm2, ierr) + call VecScale(x_kp1, 1.0_PetscReal_kind/norm2, ierr) - ! convergence criterium - if (abs(rho_kp1-rho_k)MAX_ITERATIONS) then - FLAbort("PowerMethod failed to converge") - end if + if (i>MAX_ITERATIONS) then + FLAbort("PowerMethod failed to converge") + end if - eigval=rho_kp1 - eigvec=x_kp1 + eigval=rho_kp1 + eigvec=x_kp1 - call VecDestroy(x_k, ierr) + call VecDestroy(x_k, ierr) -end subroutine PowerMethod + end subroutine PowerMethod end module multigrid diff --git a/femtools/Node_Owner_Finder_Fortran.F90 b/femtools/Node_Owner_Finder_Fortran.F90 index 71ea62da71..067ad9c8bb 100644 --- a/femtools/Node_Owner_Finder_Fortran.F90 +++ b/femtools/Node_Owner_Finder_Fortran.F90 @@ -29,525 +29,525 @@ module node_owner_finder - use iso_c_binding, only: c_float, c_double - use fldebug - use futils, only: present_and_false - use data_structures - use element_numbering, only: FAMILY_SIMPLEX - use mpi_interfaces - use parallel_tools - use parallel_fields - use transform_elements - use fields - - implicit none - - private - - public :: node_owner_finder_reset, cnode_owner_finder_set_input, & - & cnode_owner_finder_find, cnode_owner_finder_query_output, & - & cnode_owner_finder_get_output - public :: node_owner_finder_set_input, node_owner_finder_find - public :: out_of_bounds_tolerance, rtree_tolerance - public :: ownership_predicate - - !! If a test node is more than this distance (in ideal space) outside of a - !! test element in ownership tests, then the test element cannot own the test - !! node - real, parameter :: out_of_bounds_tolerance = 0.1 - !! Factor by which element bounding boxes are expanded in setting up the rtree - real, parameter :: rtree_tolerance = 0.1 - - interface node_owner_finder_reset - subroutine cnode_owner_finder_reset(id) - implicit none - integer, intent(in) :: id - end subroutine cnode_owner_finder_reset - end interface node_owner_finder_reset - - interface cnode_owner_finder_set_input - module procedure node_owner_finder_set_input_sp - - subroutine cnode_owner_finder_set_input(id, positions, enlist, dim, loc, nnodes, nelements) - use iso_c_binding, only: c_double - implicit none - integer, intent(out) :: id - integer, intent(in) :: dim - integer, intent(in) :: loc - integer, intent(in) :: nnodes - integer, intent(in) :: nelements - real(kind = c_double), dimension(nnodes * dim), intent(in) :: positions - integer, dimension(nelements * loc), intent(in) :: enlist - end subroutine cnode_owner_finder_set_input - end interface cnode_owner_finder_set_input - - interface node_owner_finder_set_input - module procedure node_owner_finder_set_input_positions - end interface node_owner_finder_set_input - - interface cnode_owner_finder_find - module procedure node_owner_finder_find_sp - - subroutine cnode_owner_finder_find(id, position, dim) - use iso_c_binding, only: c_double - implicit none - integer, intent(in) :: id - integer, intent(in) :: dim - real(kind = c_double), dimension(dim), intent(in) :: position - end subroutine cnode_owner_finder_find - end interface cnode_owner_finder_find - - interface node_owner_finder_find - module procedure node_owner_finder_find_single_position, & + use iso_c_binding, only: c_float, c_double + use fldebug + use futils, only: present_and_false + use data_structures + use element_numbering, only: FAMILY_SIMPLEX + use mpi_interfaces + use parallel_tools + use parallel_fields + use transform_elements + use fields + + implicit none + + private + + public :: node_owner_finder_reset, cnode_owner_finder_set_input, & + & cnode_owner_finder_find, cnode_owner_finder_query_output, & + & cnode_owner_finder_get_output + public :: node_owner_finder_set_input, node_owner_finder_find + public :: out_of_bounds_tolerance, rtree_tolerance + public :: ownership_predicate + + !! If a test node is more than this distance (in ideal space) outside of a + !! test element in ownership tests, then the test element cannot own the test + !! node + real, parameter :: out_of_bounds_tolerance = 0.1 + !! Factor by which element bounding boxes are expanded in setting up the rtree + real, parameter :: rtree_tolerance = 0.1 + + interface node_owner_finder_reset + subroutine cnode_owner_finder_reset(id) + implicit none + integer, intent(in) :: id + end subroutine cnode_owner_finder_reset + end interface node_owner_finder_reset + + interface cnode_owner_finder_set_input + module procedure node_owner_finder_set_input_sp + + subroutine cnode_owner_finder_set_input(id, positions, enlist, dim, loc, nnodes, nelements) + use iso_c_binding, only: c_double + implicit none + integer, intent(out) :: id + integer, intent(in) :: dim + integer, intent(in) :: loc + integer, intent(in) :: nnodes + integer, intent(in) :: nelements + real(kind = c_double), dimension(nnodes * dim), intent(in) :: positions + integer, dimension(nelements * loc), intent(in) :: enlist + end subroutine cnode_owner_finder_set_input + end interface cnode_owner_finder_set_input + + interface node_owner_finder_set_input + module procedure node_owner_finder_set_input_positions + end interface node_owner_finder_set_input + + interface cnode_owner_finder_find + module procedure node_owner_finder_find_sp + + subroutine cnode_owner_finder_find(id, position, dim) + use iso_c_binding, only: c_double + implicit none + integer, intent(in) :: id + integer, intent(in) :: dim + real(kind = c_double), dimension(dim), intent(in) :: position + end subroutine cnode_owner_finder_find + end interface cnode_owner_finder_find + + interface node_owner_finder_find + module procedure node_owner_finder_find_single_position, & & node_owner_finder_find_multiple_positions, & & node_owner_finder_find_single_position_tolerance, & & node_owner_finder_find_multiple_positions_tolerance, & & node_owner_finder_find_node, node_owner_finder_find_nodes, & & node_owner_finder_find_node_tolerance, & & node_owner_finder_find_nodes_tolerance - end interface node_owner_finder_find - - interface cnode_owner_finder_query_output - subroutine cnode_owner_finder_query_output(id, nelms) - implicit none - integer, intent(in) :: id - integer, intent(out) :: nelms - end subroutine cnode_owner_finder_query_output - end interface cnode_owner_finder_query_output - - interface cnode_owner_finder_get_output - subroutine cnode_owner_finder_get_output(id, ele_id, index) - implicit none - integer, intent(in) :: id - integer, intent(out) :: ele_id - integer, intent(in) :: index - end subroutine cnode_owner_finder_get_output - end interface cnode_owner_finder_get_output - - interface ownership_predicate - module procedure ownership_predicate_position, ownership_predicate_node - end interface ownership_predicate + end interface node_owner_finder_find + + interface cnode_owner_finder_query_output + subroutine cnode_owner_finder_query_output(id, nelms) + implicit none + integer, intent(in) :: id + integer, intent(out) :: nelms + end subroutine cnode_owner_finder_query_output + end interface cnode_owner_finder_query_output + + interface cnode_owner_finder_get_output + subroutine cnode_owner_finder_get_output(id, ele_id, index) + implicit none + integer, intent(in) :: id + integer, intent(out) :: ele_id + integer, intent(in) :: index + end subroutine cnode_owner_finder_get_output + end interface cnode_owner_finder_get_output + + interface ownership_predicate + module procedure ownership_predicate_position, ownership_predicate_node + end interface ownership_predicate contains - subroutine node_owner_finder_set_input_sp(id, positions, enlist, dim, loc, nnodes, nelements) - integer, intent(out) :: id - integer, intent(in) :: dim - integer, intent(in) :: loc - integer, intent(in) :: nnodes - integer, intent(in) :: nelements - real(kind = c_float), dimension(nnodes * dim), intent(in) :: positions - integer, dimension(nelements * loc), intent(in) :: enlist - - call cnode_owner_finder_set_input(id, real(positions, kind = c_double), enlist, dim, loc, nnodes, nelements) - - end subroutine node_owner_finder_set_input_sp - - subroutine node_owner_finder_set_input_positions(id, positions) - !!< Generate a new node owner finder for the supplied positions. Returns the - !!< node owner finder ID in id. - - integer, intent(out) :: id - type(vector_field), intent(in) :: positions - - integer :: i - real, dimension(:), allocatable :: lpositions - - allocate(lpositions(node_count(positions) * positions%dim)) - do i = 1, node_count(positions) - lpositions((i - 1) * positions%dim + 1:i * positions%dim) = node_val(positions, i) - end do - - call cnode_owner_finder_set_input(id, lpositions, positions%mesh%ndglno, positions%dim, ele_loc(positions, 1), node_count(positions), ele_count(positions)) + subroutine node_owner_finder_set_input_sp(id, positions, enlist, dim, loc, nnodes, nelements) + integer, intent(out) :: id + integer, intent(in) :: dim + integer, intent(in) :: loc + integer, intent(in) :: nnodes + integer, intent(in) :: nelements + real(kind = c_float), dimension(nnodes * dim), intent(in) :: positions + integer, dimension(nelements * loc), intent(in) :: enlist - deallocate(lpositions) + call cnode_owner_finder_set_input(id, real(positions, kind = c_double), enlist, dim, loc, nnodes, nelements) - end subroutine node_owner_finder_set_input_positions + end subroutine node_owner_finder_set_input_sp - subroutine node_owner_finder_find_sp(id, position, dim) - integer, intent(in) :: id - integer, intent(in) :: dim - real(kind = c_float), dimension(dim), intent(in) :: position + subroutine node_owner_finder_set_input_positions(id, positions) + !!< Generate a new node owner finder for the supplied positions. Returns the + !!< node owner finder ID in id. - call cnode_owner_finder_find(id, real(position, kind = c_double), dim) + integer, intent(out) :: id + type(vector_field), intent(in) :: positions - end subroutine node_owner_finder_find_sp + integer :: i + real, dimension(:), allocatable :: lpositions - subroutine node_owner_finder_find_single_position(id, positions_a, position, ele_id, global) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element ID owning the given position. - !!< This does not use ownership tolerances - instead, it determines the - !!< "best" owning elements (those that are the smallest distance in ideal - !!< space from test nodes). + allocate(lpositions(node_count(positions) * positions%dim)) + do i = 1, node_count(positions) + lpositions((i - 1) * positions%dim + 1:i * positions%dim) = node_val(positions, i) + end do - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - real, dimension(:), intent(in) :: position - integer, intent(out) :: ele_id - !! If present and .false., do not perform a global ownership test across all - !! processes - logical, optional, intent(in) :: global + call cnode_owner_finder_set_input(id, lpositions, positions%mesh%ndglno, positions%dim, ele_loc(positions, 1), node_count(positions), ele_count(positions)) - integer, dimension(1) :: lele_id + deallocate(lpositions) - call node_owner_finder_find(id, positions_a, spread(position, 2, 1), lele_id, global = global) - ele_id = lele_id(1) + end subroutine node_owner_finder_set_input_positions - end subroutine node_owner_finder_find_single_position + subroutine node_owner_finder_find_sp(id, position, dim) + integer, intent(in) :: id + integer, intent(in) :: dim + real(kind = c_float), dimension(dim), intent(in) :: position - subroutine node_owner_finder_find_multiple_positions(id, positions_a, positions, ele_ids, global) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element IDs owning the given positions. - !!< This does not use ownership tolerances - instead, it determines the - !!< "best" owning elements (those that are the smallest distance in ideal - !!< space from test nodes). + call cnode_owner_finder_find(id, real(position, kind = c_double), dim) - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - real, dimension(:, :), intent(in) :: positions - integer, dimension(size(positions, 2)), intent(out) :: ele_ids - !! If present and .false., do not perform a global ownership test across all - !! processes - logical, optional, intent(in) :: global + end subroutine node_owner_finder_find_sp - if(.not. present_and_false(global) .and. isparallel()) then - call find_parallel() - else - call find_serial() - end if + subroutine node_owner_finder_find_single_position(id, positions_a, position, ele_id, global) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element ID owning the given position. + !!< This does not use ownership tolerances - instead, it determines the + !!< "best" owning elements (those that are the smallest distance in ideal + !!< space from test nodes). - contains + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + real, dimension(:), intent(in) :: position + integer, intent(out) :: ele_id + !! If present and .false., do not perform a global ownership test across all + !! processes + logical, optional, intent(in) :: global - ! Separate serial and parallel versions, as in parallel we need to keep a - ! record of the closest_misses + integer, dimension(1) :: lele_id - subroutine find_serial() - integer :: closest_ele_id, i, j, nele_ids, possible_ele_id - real :: closest_miss, miss + call node_owner_finder_find(id, positions_a, spread(position, 2, 1), lele_id, global = global) + ele_id = lele_id(1) - ele_ids = -1 - positions_loop: do i = 1, size(positions, 2) - call cnode_owner_finder_find(id, positions(:, i), size(positions, 1)) - call cnode_owner_finder_query_output(id, nele_ids) - - closest_ele_id = -1 - ! We don't tolerate very large ownership failures - closest_miss = out_of_bounds_tolerance - do j = 1, nele_ids - call cnode_owner_finder_get_output(id, possible_ele_id, j) - ! Zero tolerance - we're not using an "epsilon-ball" approach here - if(ownership_predicate(positions_a, possible_ele_id, positions(:, i), 0.0, miss = miss)) then - ele_ids(i) = possible_ele_id - ! We've found an owner - no need to worry about the closest miss - cycle positions_loop - else if(miss < closest_miss) then - ! We didn't find an owner, but did find the closest miss so far - closest_ele_id = possible_ele_id - closest_miss = miss - end if - end do - - ! We didn't find an owner, so choose the element with the closest miss - ele_ids(i) = closest_ele_id + end subroutine node_owner_finder_find_single_position - end do positions_loop + subroutine node_owner_finder_find_multiple_positions(id, positions_a, positions, ele_ids, global) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element IDs owning the given positions. + !!< This does not use ownership tolerances - instead, it determines the + !!< "best" owning elements (those that are the smallest distance in ideal + !!< space from test nodes). - end subroutine find_serial + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + real, dimension(:, :), intent(in) :: positions + integer, dimension(size(positions, 2)), intent(out) :: ele_ids + !! If present and .false., do not perform a global ownership test across all + !! processes + logical, optional, intent(in) :: global + + if(.not. present_and_false(global) .and. isparallel()) then + call find_parallel() + else + call find_serial() + end if - subroutine find_parallel() - integer :: closest_ele_id, i, j, nele_ids, possible_ele_id - real :: miss - real, dimension(:), allocatable :: closest_misses + contains + + ! Separate serial and parallel versions, as in parallel we need to keep a + ! record of the closest_misses + + subroutine find_serial() + integer :: closest_ele_id, i, j, nele_ids, possible_ele_id + real :: closest_miss, miss + + ele_ids = -1 + positions_loop: do i = 1, size(positions, 2) + call cnode_owner_finder_find(id, positions(:, i), size(positions, 1)) + call cnode_owner_finder_query_output(id, nele_ids) + + closest_ele_id = -1 + ! We don't tolerate very large ownership failures + closest_miss = out_of_bounds_tolerance + do j = 1, nele_ids + call cnode_owner_finder_get_output(id, possible_ele_id, j) + ! Zero tolerance - we're not using an "epsilon-ball" approach here + if(ownership_predicate(positions_a, possible_ele_id, positions(:, i), 0.0, miss = miss)) then + ele_ids(i) = possible_ele_id + ! We've found an owner - no need to worry about the closest miss + cycle positions_loop + else if(miss < closest_miss) then + ! We didn't find an owner, but did find the closest miss so far + closest_ele_id = possible_ele_id + closest_miss = miss + end if + end do + + ! We didn't find an owner, so choose the element with the closest miss + ele_ids(i) = closest_ele_id + + end do positions_loop + + end subroutine find_serial + + subroutine find_parallel() + integer :: closest_ele_id, i, j, nele_ids, possible_ele_id + real :: miss + real, dimension(:), allocatable :: closest_misses #ifdef HAVE_MPI - integer :: communicator, ierr, rank - real, dimension(2, size(positions, 2)) :: misses_send, minlocs_recv + integer :: communicator, ierr, rank + real, dimension(2, size(positions, 2)) :: misses_send, minlocs_recv #endif - ele_ids = -1 - allocate(closest_misses(size(positions, 2))) - ! We don't tolerate very large ownership failures - closest_misses = out_of_bounds_tolerance - - positions_loop: do i = 1, size(positions, 2) - call cnode_owner_finder_find(id, positions(:, i), size(positions, 1)) - call cnode_owner_finder_query_output(id, nele_ids) - - closest_ele_id = -1 - possible_elements_loop: do j = 1, nele_ids - call cnode_owner_finder_get_output(id, possible_ele_id, j) - ! If this process does not own this possible_ele_id element then - ! don't consider it. This filter is needed to make this subroutine work in - ! parallel without having to use universal numbers, which aren't defined - ! for all the meshes that use this subroutine. - if(.not.element_owned(positions_a,possible_ele_id)) then - assert(isparallel()) - cycle possible_elements_loop - end if - ! Zero tolerance - we're not using an "epsilon-ball" approach here - if(ownership_predicate(positions_a, possible_ele_id, positions(:, i), 0.0, miss = miss)) then - ele_ids(i) = possible_ele_id - ! We've found an owner - no need to worry about the closest miss - closest_misses(i) = 0.0 - cycle positions_loop - else if(miss < closest_misses(i)) then - ! We didn't find an owner, but did find the closest miss so far - closest_ele_id = possible_ele_id - closest_misses(i) = miss - end if - end do possible_elements_loop - - ! We didn't find an owner, so choose the element with the closest miss - ele_ids(i) = closest_ele_id - - end do positions_loop - - ! Find which processes have the smallest miss for each coordinate + ele_ids = -1 + allocate(closest_misses(size(positions, 2))) + ! We don't tolerate very large ownership failures + closest_misses = out_of_bounds_tolerance + + positions_loop: do i = 1, size(positions, 2) + call cnode_owner_finder_find(id, positions(:, i), size(positions, 1)) + call cnode_owner_finder_query_output(id, nele_ids) + + closest_ele_id = -1 + possible_elements_loop: do j = 1, nele_ids + call cnode_owner_finder_get_output(id, possible_ele_id, j) + ! If this process does not own this possible_ele_id element then + ! don't consider it. This filter is needed to make this subroutine work in + ! parallel without having to use universal numbers, which aren't defined + ! for all the meshes that use this subroutine. + if(.not.element_owned(positions_a,possible_ele_id)) then + assert(isparallel()) + cycle possible_elements_loop + end if + ! Zero tolerance - we're not using an "epsilon-ball" approach here + if(ownership_predicate(positions_a, possible_ele_id, positions(:, i), 0.0, miss = miss)) then + ele_ids(i) = possible_ele_id + ! We've found an owner - no need to worry about the closest miss + closest_misses(i) = 0.0 + cycle positions_loop + else if(miss < closest_misses(i)) then + ! We didn't find an owner, but did find the closest miss so far + closest_ele_id = possible_ele_id + closest_misses(i) = miss + end if + end do possible_elements_loop + + ! We didn't find an owner, so choose the element with the closest miss + ele_ids(i) = closest_ele_id + + end do positions_loop + + ! Find which processes have the smallest miss for each coordinate #ifdef HAVE_MPI - communicator = halo_communicator(positions_a) - rank = getrank(communicator = communicator) + communicator = halo_communicator(positions_a) + rank = getrank(communicator = communicator) - misses_send(1, :) = closest_misses - misses_send(2, :) = float(rank) + misses_send(1, :) = closest_misses + misses_send(2, :) = float(rank) - call mpi_allreduce(misses_send, minlocs_recv, size(misses_send, 2), & + call mpi_allreduce(misses_send, minlocs_recv, size(misses_send, 2), & #ifdef DOUBLEP - & MPI_2DOUBLE_PRECISION, & + & MPI_2DOUBLE_PRECISION, & #else - & MPI_2REAL, & + & MPI_2REAL, & #endif - & MPI_MINLOC, communicator, ierr) - assert(ierr == MPI_SUCCESS) - - do i = 1, size(minlocs_recv, 2) - if(int(minlocs_recv(2, i)) /= rank) then - ! Another processes has a smaller miss for this coordinate - ele_ids(i) = -1 - end if - ! if no process has closest_misses(i) < out_of_bounds_tolerance - ! then ele_ids(i) is already set to -1 in positions_loop above - ! on all processes. This matches the find_serial(0) behaviour. - end do + & MPI_MINLOC, communicator, ierr) + assert(ierr == MPI_SUCCESS) + + do i = 1, size(minlocs_recv, 2) + if(int(minlocs_recv(2, i)) /= rank) then + ! Another processes has a smaller miss for this coordinate + ele_ids(i) = -1 + end if + ! if no process has closest_misses(i) < out_of_bounds_tolerance + ! then ele_ids(i) is already set to -1 in positions_loop above + ! on all processes. This matches the find_serial(0) behaviour. + end do #endif - deallocate(closest_misses) + deallocate(closest_misses) - end subroutine find_parallel + end subroutine find_parallel - end subroutine node_owner_finder_find_multiple_positions + end subroutine node_owner_finder_find_multiple_positions - subroutine node_owner_finder_find_single_position_tolerance(id, positions_a, position, ele_ids, ownership_tolerance) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element ID owning the given position using an - !!< ownership tolerance. This performs a strictly local (this process) - !!< ownership test. + subroutine node_owner_finder_find_single_position_tolerance(id, positions_a, position, ele_ids, ownership_tolerance) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element ID owning the given position using an + !!< ownership tolerance. This performs a strictly local (this process) + !!< ownership test. - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - real, dimension(:), intent(in) :: position - type(integer_set), intent(out) :: ele_ids - real, intent(in) :: ownership_tolerance + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + real, dimension(:), intent(in) :: position + type(integer_set), intent(out) :: ele_ids + real, intent(in) :: ownership_tolerance - type(integer_set), dimension(1) :: lele_ids + type(integer_set), dimension(1) :: lele_ids - call node_owner_finder_find(id, positions_a, spread(position, 2, 1), lele_ids, ownership_tolerance = ownership_tolerance) - ele_ids = lele_ids(1) + call node_owner_finder_find(id, positions_a, spread(position, 2, 1), lele_ids, ownership_tolerance = ownership_tolerance) + ele_ids = lele_ids(1) - end subroutine node_owner_finder_find_single_position_tolerance + end subroutine node_owner_finder_find_single_position_tolerance - subroutine node_owner_finder_find_multiple_positions_tolerance(id, positions_a, positions, ele_ids, ownership_tolerance) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element IDs owning the given positions using an - !!< ownership tolerance. This performs a strictly local (this process) - !!< ownership test. + subroutine node_owner_finder_find_multiple_positions_tolerance(id, positions_a, positions, ele_ids, ownership_tolerance) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element IDs owning the given positions using an + !!< ownership tolerance. This performs a strictly local (this process) + !!< ownership test. - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - real, dimension(:, :), intent(in) :: positions - type(integer_set), dimension(size(positions, 2)), intent(out) :: ele_ids - real, intent(in) :: ownership_tolerance + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + real, dimension(:, :), intent(in) :: positions + type(integer_set), dimension(size(positions, 2)), intent(out) :: ele_ids + real, intent(in) :: ownership_tolerance - integer :: i, j, nele_ids, possible_ele_id + integer :: i, j, nele_ids, possible_ele_id - ! Elements will be missed by the rtree query if ownership_tolerance is too - ! big - assert(ownership_tolerance <= rtree_tolerance) + ! Elements will be missed by the rtree query if ownership_tolerance is too + ! big + assert(ownership_tolerance <= rtree_tolerance) - call allocate(ele_ids) - positions_loop: do i = 1, size(positions, 2) - call cnode_owner_finder_find(id, positions(:, i), size(positions, 1)) - call cnode_owner_finder_query_output(id, nele_ids) + call allocate(ele_ids) + positions_loop: do i = 1, size(positions, 2) + call cnode_owner_finder_find(id, positions(:, i), size(positions, 1)) + call cnode_owner_finder_query_output(id, nele_ids) - do j = 1, nele_ids - call cnode_owner_finder_get_output(id, possible_ele_id, j) - if(ownership_predicate(positions_a, possible_ele_id, positions(:, i), ownership_tolerance)) then - ! We've found an owner - call insert(ele_ids(i), possible_ele_id) - end if - end do + do j = 1, nele_ids + call cnode_owner_finder_get_output(id, possible_ele_id, j) + if(ownership_predicate(positions_a, possible_ele_id, positions(:, i), ownership_tolerance)) then + ! We've found an owner + call insert(ele_ids(i), possible_ele_id) + end if + end do - end do positions_loop + end do positions_loop - end subroutine node_owner_finder_find_multiple_positions_tolerance + end subroutine node_owner_finder_find_multiple_positions_tolerance - subroutine node_owner_finder_find_node(id, positions_a, positions_b, ele_a, node_b, global) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element ID owning the given node in positions_b. - !!< This does not use ownership tolerances - instead, it determines the - !!< "best" owning elements (those that are the smallest distance in ideal - !!< space from test nodes). + subroutine node_owner_finder_find_node(id, positions_a, positions_b, ele_a, node_b, global) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element ID owning the given node in positions_b. + !!< This does not use ownership tolerances - instead, it determines the + !!< "best" owning elements (those that are the smallest distance in ideal + !!< space from test nodes). - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, intent(out) :: ele_a - integer, intent(in) :: node_b - !! If present and .false., do not perform a global ownership test across all - !! processes - logical, optional, intent(in) :: global + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, intent(out) :: ele_a + integer, intent(in) :: node_b + !! If present and .false., do not perform a global ownership test across all + !! processes + logical, optional, intent(in) :: global - call node_owner_finder_find(id, positions_a, node_val(positions_b, node_b), ele_a, global = global) + call node_owner_finder_find(id, positions_a, node_val(positions_b, node_b), ele_a, global = global) - end subroutine node_owner_finder_find_node + end subroutine node_owner_finder_find_node - subroutine node_owner_finder_find_nodes(id, positions_a, positions_b, eles_a, global) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element ID owning the nodes in positions_b. - !!< This does not use ownership tolerances - instead, it determines the - !!< "best" owning elements (those that are the smallest distance in ideal - !!< space from test nodes). + subroutine node_owner_finder_find_nodes(id, positions_a, positions_b, eles_a, global) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element ID owning the nodes in positions_b. + !!< This does not use ownership tolerances - instead, it determines the + !!< "best" owning elements (those that are the smallest distance in ideal + !!< space from test nodes). - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, dimension(node_count(positions_b)), intent(out) :: eles_a - !! If present and .false., do not perform a global ownership test across all - !! processes - logical, optional, intent(in) :: global + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, dimension(node_count(positions_b)), intent(out) :: eles_a + !! If present and .false., do not perform a global ownership test across all + !! processes + logical, optional, intent(in) :: global - integer :: node_b - real, dimension(:, :), allocatable :: lpositions + integer :: node_b + real, dimension(:, :), allocatable :: lpositions - allocate(lpositions(positions_b%dim, node_count(positions_b))) + allocate(lpositions(positions_b%dim, node_count(positions_b))) - do node_b = 1, node_count(positions_b) - lpositions(:, node_b) = node_val(positions_b, node_b) - end do + do node_b = 1, node_count(positions_b) + lpositions(:, node_b) = node_val(positions_b, node_b) + end do - call node_owner_finder_find(id, positions_a, lpositions, eles_a, global = global) + call node_owner_finder_find(id, positions_a, lpositions, eles_a, global = global) - deallocate(lpositions) + deallocate(lpositions) - end subroutine node_owner_finder_find_nodes + end subroutine node_owner_finder_find_nodes - subroutine node_owner_finder_find_node_tolerance(id, positions_a, positions_b, eles_a, node_b, ownership_tolerance) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element ID owning the given node in positions_b - !!< using an ownership tolerance. This performs a strictly local (this - !!< process) ownership test. + subroutine node_owner_finder_find_node_tolerance(id, positions_a, positions_b, eles_a, node_b, ownership_tolerance) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element ID owning the given node in positions_b + !!< using an ownership tolerance. This performs a strictly local (this + !!< process) ownership test. - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - type(integer_set), intent(out) :: eles_a - integer, intent(in) :: node_b - real, intent(in) :: ownership_tolerance + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + type(integer_set), intent(out) :: eles_a + integer, intent(in) :: node_b + real, intent(in) :: ownership_tolerance - call node_owner_finder_find(id, positions_a, node_val(positions_b, node_b), eles_a, ownership_tolerance = ownership_tolerance) + call node_owner_finder_find(id, positions_a, node_val(positions_b, node_b), eles_a, ownership_tolerance = ownership_tolerance) - end subroutine node_owner_finder_find_node_tolerance + end subroutine node_owner_finder_find_node_tolerance - subroutine node_owner_finder_find_nodes_tolerance(id, positions_a, positions_b, eles_a, ownership_tolerance) - !!< For the node owner finder with ID id corresponding to positions - !!< positions_a, find the element ID owning the nodes in positions_b - !!< using an ownership tolerance. This performs a strictly local (this - !!< process) ownership test. + subroutine node_owner_finder_find_nodes_tolerance(id, positions_a, positions_b, eles_a, ownership_tolerance) + !!< For the node owner finder with ID id corresponding to positions + !!< positions_a, find the element ID owning the nodes in positions_b + !!< using an ownership tolerance. This performs a strictly local (this + !!< process) ownership test. - integer, intent(in) :: id - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - type(integer_set), dimension(node_count(positions_b)), intent(out) :: eles_a - real, intent(in) :: ownership_tolerance + integer, intent(in) :: id + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + type(integer_set), dimension(node_count(positions_b)), intent(out) :: eles_a + real, intent(in) :: ownership_tolerance - integer :: node_b - real, dimension(:, :), allocatable :: lpositions + integer :: node_b + real, dimension(:, :), allocatable :: lpositions - allocate(lpositions(positions_b%dim, node_count(positions_b))) + allocate(lpositions(positions_b%dim, node_count(positions_b))) - do node_b = 1, node_count(positions_b) - lpositions(:, node_b) = node_val(positions_b, node_b) - end do + do node_b = 1, node_count(positions_b) + lpositions(:, node_b) = node_val(positions_b, node_b) + end do - call node_owner_finder_find(id, positions_a, lpositions, eles_a, ownership_tolerance = ownership_tolerance) + call node_owner_finder_find(id, positions_a, lpositions, eles_a, ownership_tolerance = ownership_tolerance) - deallocate(lpositions) + deallocate(lpositions) - end subroutine node_owner_finder_find_nodes_tolerance + end subroutine node_owner_finder_find_nodes_tolerance - function ownership_predicate_position(positions_a, ele_a, position, ownership_tolerance, miss, l_coords) result(owned) - !!< Node ownership predicate. Returns .true. if the given position is - !!< contained within element ele_a of positions_a to within tolerance - !!< ownership_tolerance. + function ownership_predicate_position(positions_a, ele_a, position, ownership_tolerance, miss, l_coords) result(owned) + !!< Node ownership predicate. Returns .true. if the given position is + !!< contained within element ele_a of positions_a to within tolerance + !!< ownership_tolerance. - type(vector_field), intent(in) :: positions_a - integer, intent(in) :: ele_a - real, dimension(positions_a%dim), intent(in) :: position - real, intent(in) :: ownership_tolerance - !!< Return the "miss" - the distance (in ideal space) of the test position - !!< from the test element - real, optional, intent(out) :: miss - !!< Return the coordinate (in ideal space) of the test position - !!< in the test element - real, dimension(positions_a%dim + 1), optional, intent(out) :: l_coords + type(vector_field), intent(in) :: positions_a + integer, intent(in) :: ele_a + real, dimension(positions_a%dim), intent(in) :: position + real, intent(in) :: ownership_tolerance + !!< Return the "miss" - the distance (in ideal space) of the test position + !!< from the test element + real, optional, intent(out) :: miss + !!< Return the coordinate (in ideal space) of the test position + !!< in the test element + real, dimension(positions_a%dim + 1), optional, intent(out) :: l_coords - logical :: owned + logical :: owned - real :: lmiss - real, dimension(positions_a%dim + 1) :: ll_coords + real :: lmiss + real, dimension(positions_a%dim + 1) :: ll_coords - assert(ownership_tolerance >= 0.0) + assert(ownership_tolerance >= 0.0) - ll_coords = local_coords(positions_a, ele_a, position) + ll_coords = local_coords(positions_a, ele_a, position) - assert(ele_numbering_family(positions_a, ele_a) == FAMILY_SIMPLEX) - if(any(ll_coords < 0.0)) then - lmiss = -minval(ll_coords) - if(lmiss < ownership_tolerance) then - owned = .true. + assert(ele_numbering_family(positions_a, ele_a) == FAMILY_SIMPLEX) + if(any(ll_coords < 0.0)) then + lmiss = -minval(ll_coords) + if(lmiss < ownership_tolerance) then + owned = .true. + else + owned = .false. + end if + if(present(miss)) miss = lmiss else - owned = .false. + owned = .true. + if(present(miss)) miss = 0.0 end if - if(present(miss)) miss = lmiss - else - owned = .true. - if(present(miss)) miss = 0.0 - end if - - if(present(l_coords)) l_coords = ll_coords - - end function ownership_predicate_position - - function ownership_predicate_node(positions_a, positions_b, ele_a, node_b, ownership_tolerance, miss, l_coords) result(owned) - !!< Node ownership predicate. Returns .true. if the given node in - !!< positions_b is contained within element ele_a of positions_a to within - !!< tolerance ownership_tolerance. - - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, intent(in) :: ele_a - integer, intent(in) :: node_b - real, intent(in) :: ownership_tolerance - !!< Return the "miss" - the distance (in ideal space) of the test position - !!< from the test element - real, optional, intent(out) :: miss - !!< Return the coordinate (in ideal space) of the test position - !!< in the test element - real, dimension(positions_a%dim + 1), optional, intent(out) :: l_coords - - logical :: owned - - owned = ownership_predicate(positions_a, ele_a, node_val(positions_b, node_b), ownership_tolerance, & + + if(present(l_coords)) l_coords = ll_coords + + end function ownership_predicate_position + + function ownership_predicate_node(positions_a, positions_b, ele_a, node_b, ownership_tolerance, miss, l_coords) result(owned) + !!< Node ownership predicate. Returns .true. if the given node in + !!< positions_b is contained within element ele_a of positions_a to within + !!< tolerance ownership_tolerance. + + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, intent(in) :: ele_a + integer, intent(in) :: node_b + real, intent(in) :: ownership_tolerance + !!< Return the "miss" - the distance (in ideal space) of the test position + !!< from the test element + real, optional, intent(out) :: miss + !!< Return the coordinate (in ideal space) of the test position + !!< in the test element + real, dimension(positions_a%dim + 1), optional, intent(out) :: l_coords + + logical :: owned + + owned = ownership_predicate(positions_a, ele_a, node_val(positions_b, node_b), ownership_tolerance, & & miss = miss, l_coords = l_coords) - end function ownership_predicate_node + end function ownership_predicate_node end module node_owner_finder diff --git a/femtools/Node_Ownership.F90 b/femtools/Node_Ownership.F90 index 4bef72067d..ed423eac17 100644 --- a/femtools/Node_Ownership.F90 +++ b/femtools/Node_Ownership.F90 @@ -29,328 +29,328 @@ module node_ownership - use fldebug - use data_structures - use sparse_tools - use adjacency_lists - use linked_lists - use intersection_finder_module - use fields - use node_owner_finder - use pickers + use fldebug + use data_structures + use sparse_tools + use adjacency_lists + use linked_lists + use intersection_finder_module + use fields + use node_owner_finder + use pickers - implicit none + implicit none - private + private - public :: find_node_ownership, find_node_ownership_brute_force, & - & find_node_ownership_rtree, find_node_ownership_af, find_node_ownership_if - public :: ownership_predicate + public :: find_node_ownership, find_node_ownership_brute_force, & + & find_node_ownership_rtree, find_node_ownership_af, find_node_ownership_if + public :: ownership_predicate - real, parameter, public :: default_ownership_tolerance = 1.0e2 * epsilon(0.0) + real, parameter, public :: default_ownership_tolerance = 1.0e2 * epsilon(0.0) - interface find_node_ownership - module procedure find_node_ownership_rtree_no_tolerance, & + interface find_node_ownership + module procedure find_node_ownership_rtree_no_tolerance, & & find_node_ownership_rtree_tolerance - end interface find_node_ownership + end interface find_node_ownership - interface find_node_ownership_rtree - module procedure find_node_ownership_rtree_no_tolerance, & + interface find_node_ownership_rtree + module procedure find_node_ownership_rtree_no_tolerance, & & find_node_ownership_rtree_tolerance - end interface find_node_ownership_rtree + end interface find_node_ownership_rtree contains - subroutine find_node_ownership_brute_force(positions_a, positions_b, map, ownership_tolerance) - !!< Find the elements in positions_a containing the nodes in positions_b. - !!< Uses an brute force algorithm. + subroutine find_node_ownership_brute_force(positions_a, positions_b, map, ownership_tolerance) + !!< Find the elements in positions_a containing the nodes in positions_b. + !!< Uses an brute force algorithm. - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, dimension(node_count(positions_b)), intent(out) :: map - real, optional, intent(in) :: ownership_tolerance - - integer :: ele_a, node_b - real :: lownership_tolerance - - ewrite(1, *) "In find_node_ownership_brute_force" - - if(present(ownership_tolerance)) then - lownership_tolerance = ownership_tolerance - else - lownership_tolerance = default_ownership_tolerance - end if - - map = -1 - - node_b_loop: do node_b = 1, node_count(positions_b) - do ele_a = 1, ele_count(positions_a) - if(ownership_predicate(positions_a, positions_b, ele_a, node_b, lownership_tolerance)) then - map(node_b) = ele_a - cycle node_b_loop - end if - end do - end do node_b_loop - - ewrite(1, *) "Exiting find_node_ownership_brute_force" - - end subroutine find_node_ownership_brute_force - - subroutine find_node_ownership_rtree_no_tolerance(positions_a, positions_b, map) - !!< Find the elements in positions_a containing the nodes in positions_b. - !!< Uses an rtree algorithm. - !!< This does not use ownership tolerances - instead, it determines the - !!< "best" owning elements (those that are the smallest distance in ideal - !!< space from test nodes). - - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, dimension(node_count(positions_b)), intent(out) :: map - - ewrite(1, *) "In find_node_ownership_rtree_no_tolerance" - - call picker_inquire(positions_a, positions_b, map, global = .false.) + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, dimension(node_count(positions_b)), intent(out) :: map + real, optional, intent(in) :: ownership_tolerance - ewrite(1, *) "Exiting find_node_ownership_rtree_no_tolerance" + integer :: ele_a, node_b + real :: lownership_tolerance - end subroutine find_node_ownership_rtree_no_tolerance + ewrite(1, *) "In find_node_ownership_brute_force" - subroutine find_node_ownership_rtree_tolerance(positions_a, positions_b, map, ownership_tolerance) - !!< Find all elements in positions_a within ownership_tolerance (in ideal - !!< space) of nodes in positions_b. - !!< Uses an rtree algorithm. + if(present(ownership_tolerance)) then + lownership_tolerance = ownership_tolerance + else + lownership_tolerance = default_ownership_tolerance + end if - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - type(integer_set), dimension(node_count(positions_b)), intent(out) :: map - real, intent(in) :: ownership_tolerance + map = -1 - ewrite(1, *) "In find_node_ownership_rtree_tolerance" + node_b_loop: do node_b = 1, node_count(positions_b) + do ele_a = 1, ele_count(positions_a) + if(ownership_predicate(positions_a, positions_b, ele_a, node_b, lownership_tolerance)) then + map(node_b) = ele_a + cycle node_b_loop + end if + end do + end do node_b_loop - call picker_inquire(positions_a, positions_b, map, ownership_tolerance = ownership_tolerance) + ewrite(1, *) "Exiting find_node_ownership_brute_force" - ewrite(2, *) "Min. elements: ", minval(key_count(map)) - ewrite(2, *) "Max. elements: ", maxval(key_count(map)) + end subroutine find_node_ownership_brute_force - ewrite(1, *) "Exiting find_node_ownership_rtree_tolerance" + subroutine find_node_ownership_rtree_no_tolerance(positions_a, positions_b, map) + !!< Find the elements in positions_a containing the nodes in positions_b. + !!< Uses an rtree algorithm. + !!< This does not use ownership tolerances - instead, it determines the + !!< "best" owning elements (those that are the smallest distance in ideal + !!< space from test nodes). - end subroutine find_node_ownership_rtree_tolerance + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, dimension(node_count(positions_b)), intent(out) :: map - subroutine find_node_ownership_af(positions_a, positions_b, map, ownership_tolerance, seed_b) - !!< Find the elements in positions_a containing the nodes in positions_b. - !!< Uses a simple advancing front algorithm. + ewrite(1, *) "In find_node_ownership_rtree_no_tolerance" - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, dimension(node_count(positions_b)), intent(out) :: map - real, optional, intent(in) :: ownership_tolerance - integer, optional, intent(in) :: seed_b + call picker_inquire(positions_a, positions_b, map, global = .false.) - integer :: ele_a, node_b - real :: lownership_tolerance - type(csr_sparsity), pointer :: eelist_a, nnlist_b - type(ilist) :: null_ilist + ewrite(1, *) "Exiting find_node_ownership_rtree_no_tolerance" - ! The advancing front - logical, dimension(:), allocatable :: ele_a_in_list, tested_ele_a - logical, dimension(:), allocatable :: node_b_in_list - type(ilist) :: next_possible_node_b, possible_node_b - type(ilist) :: next_ele_a + end subroutine find_node_ownership_rtree_no_tolerance - ewrite(1, *) "In find_node_ownership_af" + subroutine find_node_ownership_rtree_tolerance(positions_a, positions_b, map, ownership_tolerance) + !!< Find all elements in positions_a within ownership_tolerance (in ideal + !!< space) of nodes in positions_b. + !!< Uses an rtree algorithm. - if(present(ownership_tolerance)) then - lownership_tolerance = ownership_tolerance - else - lownership_tolerance = default_ownership_tolerance - end if + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + type(integer_set), dimension(node_count(positions_b)), intent(out) :: map + real, intent(in) :: ownership_tolerance - ! Advancing front seed - if(present(seed_b)) then - node_b = seed_b - else - node_b = 1 - end if - assert(node_b > 0 .and. node_b <= node_count(positions_b)) + ewrite(1, *) "In find_node_ownership_rtree_tolerance" - ! Initialisation - allocate(tested_ele_a(ele_count(positions_a))) - tested_ele_a = .false. - allocate(ele_a_in_list(ele_count(positions_a))) - ele_a_in_list = .false. - allocate(node_b_in_list(node_count(positions_b))) - node_b_in_list = .false. + call picker_inquire(positions_a, positions_b, map, ownership_tolerance = ownership_tolerance) - map = -1 + ewrite(2, *) "Min. elements: ", minval(key_count(map)) + ewrite(2, *) "Max. elements: ", maxval(key_count(map)) - eelist_a => extract_eelist(positions_a) - nnlist_b => extract_nnlist(positions_b) + ewrite(1, *) "Exiting find_node_ownership_rtree_tolerance" - ! Step 1: Brute force search for the owner of the seed - map(node_b) = brute_force_search(positions_a, positions_b, node_b, lownership_tolerance) + end subroutine find_node_ownership_rtree_tolerance - ele_a = map(node_b) - call insert(next_ele_a, ele_a) - ele_a_in_list(ele_a) = .true. - call advance_node_b_front(node_b) + subroutine find_node_ownership_af(positions_a, positions_b, map, ownership_tolerance, seed_b) + !!< Find the elements in positions_a containing the nodes in positions_b. + !!< Uses a simple advancing front algorithm. - ! Step 2: The advancing front - do while(next_ele_a%length > 0) - ele_a = pop(next_ele_a) - assert(.not. tested_ele_a(ele_a)) + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, dimension(node_count(positions_b)), intent(out) :: map + real, optional, intent(in) :: ownership_tolerance + integer, optional, intent(in) :: seed_b + + integer :: ele_a, node_b + real :: lownership_tolerance + type(csr_sparsity), pointer :: eelist_a, nnlist_b + type(ilist) :: null_ilist + + ! The advancing front + logical, dimension(:), allocatable :: ele_a_in_list, tested_ele_a + logical, dimension(:), allocatable :: node_b_in_list + type(ilist) :: next_possible_node_b, possible_node_b + type(ilist) :: next_ele_a + + ewrite(1, *) "In find_node_ownership_af" + + if(present(ownership_tolerance)) then + lownership_tolerance = ownership_tolerance + else + lownership_tolerance = default_ownership_tolerance + end if + + ! Advancing front seed + if(present(seed_b)) then + node_b = seed_b + else + node_b = 1 + end if + assert(node_b > 0 .and. node_b <= node_count(positions_b)) + + ! Initialisation + allocate(tested_ele_a(ele_count(positions_a))) + tested_ele_a = .false. + allocate(ele_a_in_list(ele_count(positions_a))) + ele_a_in_list = .false. + allocate(node_b_in_list(node_count(positions_b))) + node_b_in_list = .false. + + map = -1 + + eelist_a => extract_eelist(positions_a) + nnlist_b => extract_nnlist(positions_b) + + ! Step 1: Brute force search for the owner of the seed + map(node_b) = brute_force_search(positions_a, positions_b, node_b, lownership_tolerance) + + ele_a = map(node_b) + call insert(next_ele_a, ele_a) + ele_a_in_list(ele_a) = .true. + call advance_node_b_front(node_b) + + ! Step 2: The advancing front + do while(next_ele_a%length > 0) + ele_a = pop(next_ele_a) + assert(.not. tested_ele_a(ele_a)) + + do while(possible_node_b%length > 0) + node_b = pop(possible_node_b) + assert(map(node_b) < 0) + + if(ownership_predicate(positions_a, positions_b, ele_a, node_b, lownership_tolerance)) then + map(node_b) = ele_a + call advance_node_b_front(node_b) + else if(map(node_b) < 0) then + call insert(next_possible_node_b, node_b) + end if + end do + + call advance_ele_a_front(ele_a) + possible_node_b = next_possible_node_b + next_possible_node_b = null_ilist + end do - do while(possible_node_b%length > 0) - node_b = pop(possible_node_b) - assert(map(node_b) < 0) + ! Cleanup + assert(next_ele_a%length == 0) + assert(possible_node_b%length == 0) + deallocate(tested_ele_a) + deallocate(ele_a_in_list) + deallocate(node_b_in_list) - if(ownership_predicate(positions_a, positions_b, ele_a, node_b, lownership_tolerance)) then - map(node_b) = ele_a - call advance_node_b_front(node_b) - else if(map(node_b) < 0) then - call insert(next_possible_node_b, node_b) - end if - end do + ewrite(1, *) "Exiting find_node_ownership_af" - call advance_ele_a_front(ele_a) - possible_node_b = next_possible_node_b - next_possible_node_b = null_ilist - end do + contains - ! Cleanup - assert(next_ele_a%length == 0) - assert(possible_node_b%length == 0) - deallocate(tested_ele_a) - deallocate(ele_a_in_list) - deallocate(node_b_in_list) + function brute_force_search(positions_a, positions_b, node_b, ownership_tolerance) result(ele_a) + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, intent(in) :: node_b + real, intent(in) :: ownership_tolerance - ewrite(1, *) "Exiting find_node_ownership_af" + integer :: ele_a - contains + do ele_a = 1, ele_count(positions_a) + if(ownership_predicate(positions_a, positions_b, ele_a, node_b, ownership_tolerance)) then + return + end if + end do - function brute_force_search(positions_a, positions_b, node_b, ownership_tolerance) result(ele_a) - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, intent(in) :: node_b - real, intent(in) :: ownership_tolerance + ewrite(-1, *) "For node ", node_b + FLAbort("Brute force ownership search failed") - integer :: ele_a + end function brute_force_search - do ele_a = 1, ele_count(positions_a) - if(ownership_predicate(positions_a, positions_b, ele_a, node_b, ownership_tolerance)) then - return - end if - end do + subroutine advance_ele_a_front(ele_a) + integer, intent(in) :: ele_a - ewrite(-1, *) "For node ", node_b - FLAbort("Brute force ownership search failed") + integer :: i + integer, dimension(:), pointer :: neigh - end function brute_force_search + tested_ele_a(ele_a) = .true. + neigh => row_m_ptr(eelist_a, ele_a) + do i = 1, size(neigh) + if(neigh(i) <= 0) cycle + if(ele_a_in_list(neigh(i))) cycle + if(tested_ele_a(neigh(i))) cycle - subroutine advance_ele_a_front(ele_a) - integer, intent(in) :: ele_a + call insert(next_ele_a, neigh(i)) + ele_a_in_list(neigh(i)) = .true. + end do - integer :: i - integer, dimension(:), pointer :: neigh + end subroutine advance_ele_a_front - tested_ele_a(ele_a) = .true. - neigh => row_m_ptr(eelist_a, ele_a) - do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - if(ele_a_in_list(neigh(i))) cycle - if(tested_ele_a(neigh(i))) cycle + subroutine advance_node_b_front(node_b) + integer, intent(in) :: node_b - call insert(next_ele_a, neigh(i)) - ele_a_in_list(neigh(i)) = .true. - end do + integer :: i + integer, dimension(:), pointer :: neigh - end subroutine advance_ele_a_front + neigh => row_m_ptr(nnlist_b, node_b) + do i = 1, size(neigh) + if(node_b_in_list(neigh(i))) cycle + if(map(neigh(i)) > 0) cycle - subroutine advance_node_b_front(node_b) - integer, intent(in) :: node_b + call insert(possible_node_b, neigh(i)) + node_b_in_list(neigh(i)) = .true. + end do - integer :: i - integer, dimension(:), pointer :: neigh + end subroutine advance_node_b_front - neigh => row_m_ptr(nnlist_b, node_b) - do i = 1, size(neigh) - if(node_b_in_list(neigh(i))) cycle - if(map(neigh(i)) > 0) cycle + end subroutine find_node_ownership_af - call insert(possible_node_b, neigh(i)) - node_b_in_list(neigh(i)) = .true. - end do + subroutine find_node_ownership_if(positions_a, positions_b, map, ownership_tolerance, map_ab) + !!< Find the elements in positions_a containing the nodes in positions_b. + !!< Uses the element intersection finder. - end subroutine advance_node_b_front - - end subroutine find_node_ownership_af - - subroutine find_node_ownership_if(positions_a, positions_b, map, ownership_tolerance, map_ab) - !!< Find the elements in positions_a containing the nodes in positions_b. - !!< Uses the element intersection finder. - - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, dimension(node_count(positions_b)), intent(out) :: map - real, optional, intent(in) :: ownership_tolerance - type(ilist), dimension(ele_count(positions_a)), optional, intent(in) :: map_ab - - integer :: ele_a, ele_b, node_b - integer, dimension(:), pointer :: ele_bs - real :: lownership_tolerance - type(csr_sparsity), pointer :: nelist_b - type(inode), pointer :: node - type(ilist), dimension(:), allocatable :: map_ba - - ewrite(1, *) "In find_node_ownership_if" - - if(present(ownership_tolerance)) then - lownership_tolerance = ownership_tolerance - else - lownership_tolerance = default_ownership_tolerance - end if - - allocate(map_ba(ele_count(positions_b))) - if(present(map_ab)) then - ! We need the inverse map here - do ele_a = 1, ele_count(positions_a) - node => map_ab(ele_a)%firstnode - do while(associated(node)) - ele_b = node%value - call insert(map_ba(ele_b), ele_a) - node => node%next - end do - end do - else - map_ba = intersection_finder(positions_b, positions_a) - end if - - nelist_b => extract_nelist(positions_b) - - map = -1 - node_b_loop: do node_b = 1, node_count(positions_b) - ele_bs => row_m_ptr(nelist_b, node_b) - assert(size(ele_bs) > 0) - ele_b = ele_bs(1) - - node => map_ba(ele_b)%firstnode - do while(associated(node)) - ele_a = node%value - if(ownership_predicate(positions_a, positions_b, ele_a, node_b, lownership_tolerance)) then - map(node_b) = ele_a - cycle node_b_loop - end if - - node => node%next + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, dimension(node_count(positions_b)), intent(out) :: map + real, optional, intent(in) :: ownership_tolerance + type(ilist), dimension(ele_count(positions_a)), optional, intent(in) :: map_ab + + integer :: ele_a, ele_b, node_b + integer, dimension(:), pointer :: ele_bs + real :: lownership_tolerance + type(csr_sparsity), pointer :: nelist_b + type(inode), pointer :: node + type(ilist), dimension(:), allocatable :: map_ba + + ewrite(1, *) "In find_node_ownership_if" + + if(present(ownership_tolerance)) then + lownership_tolerance = ownership_tolerance + else + lownership_tolerance = default_ownership_tolerance + end if + + allocate(map_ba(ele_count(positions_b))) + if(present(map_ab)) then + ! We need the inverse map here + do ele_a = 1, ele_count(positions_a) + node => map_ab(ele_a)%firstnode + do while(associated(node)) + ele_b = node%value + call insert(map_ba(ele_b), ele_a) + node => node%next + end do + end do + else + map_ba = intersection_finder(positions_b, positions_a) + end if + + nelist_b => extract_nelist(positions_b) + + map = -1 + node_b_loop: do node_b = 1, node_count(positions_b) + ele_bs => row_m_ptr(nelist_b, node_b) + assert(size(ele_bs) > 0) + ele_b = ele_bs(1) + + node => map_ba(ele_b)%firstnode + do while(associated(node)) + ele_a = node%value + if(ownership_predicate(positions_a, positions_b, ele_a, node_b, lownership_tolerance)) then + map(node_b) = ele_a + cycle node_b_loop + end if + + node => node%next + end do + end do node_b_loop + + do ele_b = 1, size(map_ba) + call deallocate(map_ba(ele_b)) end do - end do node_b_loop - - do ele_b = 1, size(map_ba) - call deallocate(map_ba(ele_b)) - end do - deallocate(map_ba) + deallocate(map_ba) - ewrite(1, *) "Exiting find_node_ownership_if" + ewrite(1, *) "Exiting find_node_ownership_if" - end subroutine find_node_ownership_if + end subroutine find_node_ownership_if end module node_ownership diff --git a/femtools/Node_boundary.F90 b/femtools/Node_boundary.F90 index fa3269b838..4e7afde4d0 100644 --- a/femtools/Node_boundary.F90 +++ b/femtools/Node_boundary.F90 @@ -4,258 +4,258 @@ module node_boundary !!< Does a node lie on a boundary? Surprisingly !!< difficult question to answer. - use fldebug - use linked_lists - use eventcounter - use elements - use fields - use surfacelabels - - implicit none - - integer, dimension(:), pointer, public, save :: boundcount - integer, save :: expected_boundcount - logical, save :: boundcount_initialised = .false. - integer, public, save :: pseudo2d_coord = 0 - - interface node_boundary_count - module procedure node_boundary_count_full, node_boundary_count_slim - end interface - - interface node_lies_on_boundary - module procedure node_lies_on_boundary_full, node_lies_on_boundary_slim - end interface - - private - - public :: node_boundary_count, node_lies_on_boundary, one_to_n,& - boundcount_is_initialised, deallocate_boundcount,& - initialise_boundcount, get_expected_boundcount, domain_is_2d,& - domain_is_2d_x, domain_is_2d_y, domain_is_2d_z - - contains - - function one_to_n(n) result(arr) - integer, intent(in) :: n - integer, dimension(n) :: arr - integer :: i - - do i=1,n - arr(i) = i - end do - end function one_to_n - - function boundcount_is_initialised() result(init) - logical :: init - - init = boundcount_initialised - end function boundcount_is_initialised - - subroutine deallocate_boundcount - if (associated(boundcount)) then - deallocate(boundcount) - end if - - boundcount_initialised = .false. - end subroutine deallocate_boundcount - - subroutine initialise_boundcount(mesh, positions, out_boundcount) - type(mesh_type), intent(inout) :: mesh - type(vector_field), intent(in) :: positions - integer, dimension(:), optional :: out_boundcount - - integer, save :: eventcount = 0 - integer :: latest_eventcount - integer :: i, j - integer, dimension(:), pointer :: surf_ids - type(ilist), dimension(:), allocatable :: tags - integer :: snloc - real, dimension(mesh_dim(mesh)) :: dimlen - integer, dimension(1) :: minloc_out - - integer :: count_zero_boundaries(1) - type(element_type) :: element - integer, dimension(:), allocatable :: face_glob_nod - - latest_eventcount = 0 - - call GetEventCounter(EVENT_ADAPTIVITY, latest_eventcount) - if (latest_eventcount > eventcount) then - eventcount = latest_eventcount - boundcount_initialised = .false. + use fldebug + use linked_lists + use eventcounter + use elements + use fields + use surfacelabels + + implicit none + + integer, dimension(:), pointer, public, save :: boundcount + integer, save :: expected_boundcount + logical, save :: boundcount_initialised = .false. + integer, public, save :: pseudo2d_coord = 0 + + interface node_boundary_count + module procedure node_boundary_count_full, node_boundary_count_slim + end interface + + interface node_lies_on_boundary + module procedure node_lies_on_boundary_full, node_lies_on_boundary_slim + end interface + + private + + public :: node_boundary_count, node_lies_on_boundary, one_to_n,& + boundcount_is_initialised, deallocate_boundcount,& + initialise_boundcount, get_expected_boundcount, domain_is_2d,& + domain_is_2d_x, domain_is_2d_y, domain_is_2d_z + +contains + + function one_to_n(n) result(arr) + integer, intent(in) :: n + integer, dimension(n) :: arr + integer :: i + + do i=1,n + arr(i) = i + end do + end function one_to_n + + function boundcount_is_initialised() result(init) + logical :: init + + init = boundcount_initialised + end function boundcount_is_initialised + + subroutine deallocate_boundcount if (associated(boundcount)) then - deallocate(boundcount) + deallocate(boundcount) + end if + + boundcount_initialised = .false. + end subroutine deallocate_boundcount + + subroutine initialise_boundcount(mesh, positions, out_boundcount) + type(mesh_type), intent(inout) :: mesh + type(vector_field), intent(in) :: positions + integer, dimension(:), optional :: out_boundcount + + integer, save :: eventcount = 0 + integer :: latest_eventcount + integer :: i, j + integer, dimension(:), pointer :: surf_ids + type(ilist), dimension(:), allocatable :: tags + integer :: snloc + real, dimension(mesh_dim(mesh)) :: dimlen + integer, dimension(1) :: minloc_out + + integer :: count_zero_boundaries(1) + type(element_type) :: element + integer, dimension(:), allocatable :: face_glob_nod + + latest_eventcount = 0 + + call GetEventCounter(EVENT_ADAPTIVITY, latest_eventcount) + if (latest_eventcount > eventcount) then + eventcount = latest_eventcount + boundcount_initialised = .false. + if (associated(boundcount)) then + deallocate(boundcount) + end if end if - end if - ! generate coplanar ids, if not already done - call get_coplanar_ids(mesh, positions, surf_ids) + ! generate coplanar ids, if not already done + call get_coplanar_ids(mesh, positions, surf_ids) + + if (boundcount_initialised .eqv. .false.) then + element = ele_shape(mesh, 1) + if (.not. has_faces(mesh)) then + call add_faces(mesh) + end if + + allocate(boundcount(node_count(mesh))) + boundcount = 0 + boundcount_initialised = .true. + + allocate(tags(node_count(mesh))) + snloc = face_loc(mesh, 1) + allocate(face_glob_nod(snloc)) + + do i=1,surface_element_count(mesh) + face_glob_nod = face_global_nodes(mesh, i) + do j=1,snloc + call insert_ascending(tags(face_glob_nod(j)), surf_ids(i)) + end do + end do + + do i=1,size(boundcount) + boundcount(i) = tags(i)%length + end do + + if (present(out_boundcount)) then + out_boundcount = boundcount + end if + + deallocate(face_glob_nod) - if (boundcount_initialised .eqv. .false.) then - element = ele_shape(mesh, 1) - if (.not. has_faces(mesh)) then - call add_faces(mesh) + if (allocated(tags)) then + do i=1,size(tags) + call deallocate(tags(i)) + end do + deallocate(tags) + end if + + expected_boundcount = 0 + if (mesh_dim(mesh) == 3 .and. domain_is_2d()) expected_boundcount = 1 + if (minval(boundcount) > 0) expected_boundcount = 1 + count_zero_boundaries = count(boundcount == 0) + ! if only 20% of nodes are not on boundaries, + ! assume it's pseudo2d + if (mesh_dim(mesh) == 3) then + if ((float(count_zero_boundaries(1)) / float(size(boundcount))) < 0.20) then + expected_boundcount = 1 + if (pseudo2d_coord /= 0) then + return + else + do i=1,mesh_dim(mesh) + dimlen(i) = maxval(positions%val(i,:)) - minval(positions%val(i,:)) + end do + minloc_out = minloc(dimlen) + pseudo2d_coord = minloc_out(1) + end if + ewrite(1,*) 'WARNING: pseudo2D switched on' + end if + end if end if + end subroutine initialise_boundcount - allocate(boundcount(node_count(mesh))) - boundcount = 0 - boundcount_initialised = .true. + function node_lies_on_boundary_full(mesh, positions, node, expected) result(on_bound) + !!< Does the given node lie on the boundary? + type(mesh_type), intent(inout) :: mesh + type(vector_field), intent(in) :: positions + integer, intent(in) :: node + integer, intent(in), optional :: expected + logical :: on_bound - allocate(tags(node_count(mesh))) - snloc = face_loc(mesh, 1) - allocate(face_glob_nod(snloc)) + integer :: lexpected - do i=1,surface_element_count(mesh) - face_glob_nod = face_global_nodes(mesh, i) - do j=1,snloc - call insert_ascending(tags(face_glob_nod(j)), surf_ids(i)) - end do - end do + call initialise_boundcount(mesh, positions) - do i=1,size(boundcount) - boundcount(i) = tags(i)%length - end do + if (present(expected)) then + lexpected = expected + else + lexpected = expected_boundcount + end if - if (present(out_boundcount)) then - out_boundcount = boundcount + if (boundcount(node) > lexpected) then + on_bound = .true. + else + on_bound = .false. end if - deallocate(face_glob_nod) + end function node_lies_on_boundary_full + + function node_lies_on_boundary_slim(node, expected) result(on_bound) + integer, intent(in) :: node + integer, intent(in), optional :: expected + integer :: lexpected + logical :: on_bound - if (allocated(tags)) then - do i=1,size(tags) - call deallocate(tags(i)) - end do - deallocate(tags) + if (.not. boundcount_is_initialised()) then + FLAbort("You need to call initialise_boundcount before using this routine") end if - expected_boundcount = 0 - if (mesh_dim(mesh) == 3 .and. domain_is_2d()) expected_boundcount = 1 - if (minval(boundcount) > 0) expected_boundcount = 1 - count_zero_boundaries = count(boundcount == 0) - ! if only 20% of nodes are not on boundaries, - ! assume it's pseudo2d - if (mesh_dim(mesh) == 3) then - if ((float(count_zero_boundaries(1)) / float(size(boundcount))) < 0.20) then - expected_boundcount = 1 - if (pseudo2d_coord /= 0) then - return - else - do i=1,mesh_dim(mesh) - dimlen(i) = maxval(positions%val(i,:)) - minval(positions%val(i,:)) - end do - minloc_out = minloc(dimlen) - pseudo2d_coord = minloc_out(1) - end if - ewrite(1,*) 'WARNING: pseudo2D switched on' - end if + if (present(expected)) then + lexpected = expected + else + lexpected = expected_boundcount + end if + + if (boundcount(node) > lexpected) then + on_bound = .true. + else + on_bound = .false. + end if + + end function node_lies_on_boundary_slim + + function node_boundary_count_full(mesh, positions, node) result(cnt) + type(mesh_type), intent(inout) :: mesh + type(vector_field), intent(in) :: positions + integer, intent(in) :: node + integer :: cnt + + call initialise_boundcount(mesh, positions) + + cnt = boundcount(node) + end function node_boundary_count_full + + function node_boundary_count_slim(node) result(cnt) + integer, intent(in) :: node + integer :: cnt + + if (.not. boundcount_is_initialised()) then + FLAbort("You need to have called initialise_boundcount before using this routine!") end if - end if - end subroutine initialise_boundcount - - function node_lies_on_boundary_full(mesh, positions, node, expected) result(on_bound) - !!< Does the given node lie on the boundary? - type(mesh_type), intent(inout) :: mesh - type(vector_field), intent(in) :: positions - integer, intent(in) :: node - integer, intent(in), optional :: expected - logical :: on_bound - - integer :: lexpected - - call initialise_boundcount(mesh, positions) - - if (present(expected)) then - lexpected = expected - else - lexpected = expected_boundcount - end if - - if (boundcount(node) > lexpected) then - on_bound = .true. - else - on_bound = .false. - end if - - end function node_lies_on_boundary_full - - function node_lies_on_boundary_slim(node, expected) result(on_bound) - integer, intent(in) :: node - integer, intent(in), optional :: expected - integer :: lexpected - logical :: on_bound - - if (.not. boundcount_is_initialised()) then - FLAbort("You need to call initialise_boundcount before using this routine") - end if - - if (present(expected)) then - lexpected = expected - else - lexpected = expected_boundcount - end if - - if (boundcount(node) > lexpected) then - on_bound = .true. - else - on_bound = .false. - end if - - end function node_lies_on_boundary_slim - - function node_boundary_count_full(mesh, positions, node) result(cnt) - type(mesh_type), intent(inout) :: mesh - type(vector_field), intent(in) :: positions - integer, intent(in) :: node - integer :: cnt - - call initialise_boundcount(mesh, positions) - - cnt = boundcount(node) - end function node_boundary_count_full - - function node_boundary_count_slim(node) result(cnt) - integer, intent(in) :: node - integer :: cnt - - if (.not. boundcount_is_initialised()) then - FLAbort("You need to have called initialise_boundcount before using this routine!") - end if - - cnt = boundcount(node) - end function node_boundary_count_slim - - function get_expected_boundcount() result(lexpected_boundcount) - integer :: lexpected_boundcount - - lexpected_boundcount = expected_boundcount - end function - - function domain_is_2d() result(bool) - !!< Is the domain pseudo2d or not? - logical :: bool - - bool = .false. - if (pseudo2d_coord > 0 .and. pseudo2d_coord < 4) bool = .true. - end function domain_is_2d - - function domain_is_2d_x() result(bool) - !!< Is the domain pseudo2d in the x direction? - logical :: bool - bool = (pseudo2d_coord == 1) - end function domain_is_2d_x - - function domain_is_2d_y() result(bool) - !!< Is the domain pseudo2d in the y direction? - logical :: bool - bool = (pseudo2d_coord == 2) - end function domain_is_2d_y - - function domain_is_2d_z() result(bool) - !!< Is the domain pseudo2d in the z direction? - logical :: bool - bool = (pseudo2d_coord == 3) - - end function domain_is_2d_z + + cnt = boundcount(node) + end function node_boundary_count_slim + + function get_expected_boundcount() result(lexpected_boundcount) + integer :: lexpected_boundcount + + lexpected_boundcount = expected_boundcount + end function + + function domain_is_2d() result(bool) + !!< Is the domain pseudo2d or not? + logical :: bool + + bool = .false. + if (pseudo2d_coord > 0 .and. pseudo2d_coord < 4) bool = .true. + end function domain_is_2d + + function domain_is_2d_x() result(bool) + !!< Is the domain pseudo2d in the x direction? + logical :: bool + bool = (pseudo2d_coord == 1) + end function domain_is_2d_x + + function domain_is_2d_y() result(bool) + !!< Is the domain pseudo2d in the y direction? + logical :: bool + bool = (pseudo2d_coord == 2) + end function domain_is_2d_y + + function domain_is_2d_z() result(bool) + !!< Is the domain pseudo2d in the z direction? + logical :: bool + bool = (pseudo2d_coord == 3) + + end function domain_is_2d_z end module node_boundary diff --git a/femtools/Parallel_Tools.F90 b/femtools/Parallel_Tools.F90 index 0fe9c0046d..e40e3111a9 100644 --- a/femtools/Parallel_Tools.F90 +++ b/femtools/Parallel_Tools.F90 @@ -29,935 +29,935 @@ module parallel_tools - use fldebug - use mpi_interfaces - use iso_c_binding - use global_parameters, only: is_active_process, no_active_processes + use fldebug + use mpi_interfaces + use iso_c_binding + use global_parameters, only: is_active_process, no_active_processes #ifdef _OPENMP - use omp_lib + use omp_lib #endif - implicit none + implicit none - private + private - public :: halgetnb, halgetnb_simple, abort_if_in_parallel_region - public :: allor, alland, allmax, allmin, allsum, allmean, allfequals,& - getnprocs, getpinteger, getpreal, getprocno, getrank, & - isparallel, parallel_filename, parallel_filename_len, & - pending_communication, valid_communicator, next_mpi_tag, & - MPI_COMM_FEMTOOLS, set_communicator + public :: halgetnb, halgetnb_simple, abort_if_in_parallel_region + public :: allor, alland, allmax, allmin, allsum, allmean, allfequals,& + getnprocs, getpinteger, getpreal, getprocno, getrank, & + isparallel, parallel_filename, parallel_filename_len, & + pending_communication, valid_communicator, next_mpi_tag, & + MPI_COMM_FEMTOOLS, set_communicator - integer(c_int), bind(c) :: MPI_COMM_FEMTOOLS = MPI_COMM_WORLD + integer(c_int), bind(c) :: MPI_COMM_FEMTOOLS = MPI_COMM_WORLD - interface allmax - module procedure allmax_integer, allmax_real - end interface allmax + interface allmax + module procedure allmax_integer, allmax_real + end interface allmax - interface allmin - module procedure allmin_integer, allmin_real - end interface allmin + interface allmin + module procedure allmin_integer, allmin_real + end interface allmin - interface allsum - module procedure allsum_integer, allsum_real, allsum_integer_vector, & + interface allsum + module procedure allsum_integer, allsum_real, allsum_integer_vector, & & allsum_real_vector - end interface allsum + end interface allsum - interface parallel_filename_len - module procedure parallel_filename_no_extension_len, & + interface parallel_filename_len + module procedure parallel_filename_no_extension_len, & & parallel_filename_with_extension_len - end interface + end interface - interface parallel_filename - module procedure parallel_filename_no_extension, & + interface parallel_filename + module procedure parallel_filename_no_extension, & & parallel_filename_with_extension - end interface + end interface - interface pending_communication - module procedure pending_communication_communicator - end interface pending_communication + interface pending_communication + module procedure pending_communication_communicator + end interface pending_communication contains - integer function next_mpi_tag() + integer function next_mpi_tag() #ifdef HAVE_MPI - integer, save::last_tag=0, tag_ub=0 - integer flag, ierr - if(tag_ub==0) then - call MPI_Attr_get(MPI_COMM_FEMTOOLS, MPI_TAG_UB, tag_ub, flag, ierr) - end if - - last_tag = mod(last_tag+1, tag_ub) - if(last_tag==0) then - last_tag = last_tag+1 - end if - next_mpi_tag = last_tag + integer, save::last_tag=0, tag_ub=0 + integer flag, ierr + if(tag_ub==0) then + call MPI_Attr_get(MPI_COMM_FEMTOOLS, MPI_TAG_UB, tag_ub, flag, ierr) + end if + + last_tag = mod(last_tag+1, tag_ub) + if(last_tag==0) then + last_tag = last_tag+1 + end if + next_mpi_tag = last_tag #else - next_mpi_tag = 1 + next_mpi_tag = 1 #endif - end function next_mpi_tag + end function next_mpi_tag - function getprocno(communicator) result(procno) - !!< This is a convenience routine which returns the MPI rank - !!< number + 1 when MPI is being used and 1 otherwise. + function getprocno(communicator) result(procno) + !!< This is a convenience routine which returns the MPI rank + !!< number + 1 when MPI is being used and 1 otherwise. - integer, optional, intent(in) :: communicator + integer, optional, intent(in) :: communicator - integer :: procno + integer :: procno #ifdef HAVE_MPI - integer :: ierr, lcommunicator - logical :: initialized - - call MPI_Initialized(initialized, ierr) - if(initialized) then - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - assert(valid_communicator(lcommunicator)) - call MPI_Comm_Rank(lcommunicator, procno, ierr) - assert(ierr == MPI_SUCCESS) - procno = procno + 1 - else - procno = 1 - end if + integer :: ierr, lcommunicator + logical :: initialized + + call MPI_Initialized(initialized, ierr) + if(initialized) then + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + assert(valid_communicator(lcommunicator)) + call MPI_Comm_Rank(lcommunicator, procno, ierr) + assert(ierr == MPI_SUCCESS) + procno = procno + 1 + else + procno = 1 + end if #else - procno = 1 + procno = 1 #endif - end function getprocno + end function getprocno - function getrank(communicator) result(rank) - !!< This is a convience routine which returns the MPI rank - !!< number of the process when MPI is being used and 0 otherwise. + function getrank(communicator) result(rank) + !!< This is a convience routine which returns the MPI rank + !!< number of the process when MPI is being used and 0 otherwise. - integer, optional, intent(in) :: communicator + integer, optional, intent(in) :: communicator - integer::rank + integer::rank #ifdef HAVE_MPI - integer :: ierr, lcommunicator + integer :: ierr, lcommunicator - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if - assert(valid_communicator(lcommunicator)) - call MPI_Comm_Rank(lcommunicator, rank, ierr) - assert(ierr == MPI_SUCCESS) + assert(valid_communicator(lcommunicator)) + call MPI_Comm_Rank(lcommunicator, rank, ierr) + assert(ierr == MPI_SUCCESS) #else - rank = 0 + rank = 0 #endif - end function getrank + end function getrank - function getnprocs(communicator) result(nprocs) - !!< This is a convience routine which returns the number of processes - !!< in a communicator (default MPI_COMM_FEMTOOLS) when MPI is being used and 1 - !!< otherwise. + function getnprocs(communicator) result(nprocs) + !!< This is a convience routine which returns the number of processes + !!< in a communicator (default MPI_COMM_FEMTOOLS) when MPI is being used and 1 + !!< otherwise. - integer, optional, intent(in) :: communicator + integer, optional, intent(in) :: communicator - integer :: nprocs + integer :: nprocs #ifdef HAVE_MPI - integer :: ierr, lcommunicator - logical :: initialized - - call MPI_Initialized(initialized, ierr) - if(initialized) then - if(present(communicator)) then - assert(valid_communicator(communicator)) - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - assert(valid_communicator(lcommunicator)) - call MPI_Comm_Size(lcommunicator, nprocs, ierr) - assert(ierr == MPI_SUCCESS) - else - nprocs = 1 - end if + integer :: ierr, lcommunicator + logical :: initialized + + call MPI_Initialized(initialized, ierr) + if(initialized) then + if(present(communicator)) then + assert(valid_communicator(communicator)) + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + assert(valid_communicator(lcommunicator)) + call MPI_Comm_Size(lcommunicator, nprocs, ierr) + assert(ierr == MPI_SUCCESS) + else + nprocs = 1 + end if #else - nprocs = 1 + nprocs = 1 #endif - end function getnprocs + end function getnprocs - logical function isparallel() - !!< Return true if we are running in parallel, and false otherwise. + logical function isparallel() + !!< Return true if we are running in parallel, and false otherwise. - isparallel = (getnprocs()>1) + isparallel = (getnprocs()>1) - end function isparallel + end function isparallel - function getpinteger() result(pinteger) - !!< This is a convience routine which returns the MPI integer type - !!< being used. If MPI is not being used Pinteger is set to -1 + function getpinteger() result(pinteger) + !!< This is a convience routine which returns the MPI integer type + !!< being used. If MPI is not being used Pinteger is set to -1 - integer :: pinteger + integer :: pinteger #ifdef HAVE_MPI - pinteger = MPI_INTEGER + pinteger = MPI_INTEGER #else - pinteger = -1 + pinteger = -1 #endif - end function getpinteger + end function getpinteger - function getpreal() result(preal) - !!< This is a convience routine which returns the MPI real type - !!< being used. If MPI is not being used PREAL is set to -1 + function getpreal() result(preal) + !!< This is a convience routine which returns the MPI real type + !!< being used. If MPI is not being used PREAL is set to -1 - integer :: preal + integer :: preal #ifdef HAVE_MPI #ifdef DOUBLEP - preal = MPI_DOUBLE_PRECISION + preal = MPI_DOUBLE_PRECISION #else - preal = MPI_REAL + preal = MPI_REAL #endif #else - preal = -1 + preal = -1 #endif - end function getpreal + end function getpreal - logical function usingmpi() + logical function usingmpi() - integer :: ierr - usingmpi = .false. + integer :: ierr + usingmpi = .false. #ifdef HAVE_MPI - call MPI_Initialized(UsingMPI, IERR) + call MPI_Initialized(UsingMPI, IERR) #endif - end function usingmpi + end function usingmpi - ! Abort run if we're in an OMP parallel region - ! Call this routine at the start of functions that are known not to - ! be thread safe (for example, populating caches) and should - ! therefore never be called in a parallel region due to race - ! conditions. - subroutine abort_if_in_parallel_region() + ! Abort run if we're in an OMP parallel region + ! Call this routine at the start of functions that are known not to + ! be thread safe (for example, populating caches) and should + ! therefore never be called in a parallel region due to race + ! conditions. + subroutine abort_if_in_parallel_region() #ifdef _OPENMP - if (omp_in_parallel()) then - FLAbort("Calling non-thread-safe code in OMP parallel region") - endif + if (omp_in_parallel()) then + FLAbort("Calling non-thread-safe code in OMP parallel region") + endif #else - return + return #endif - end subroutine abort_if_in_parallel_region + end subroutine abort_if_in_parallel_region - ! Array - points to the begining of the real array that stores the field values - ! blockLen - the number of field values continiously stored per node - ! stride - the distance distance between successive nodes data blocks - ! fieldCnt - the total number of field variables to be communicated per node - subroutine HalgetNB(Array, blockLen, stride, fieldCnt, ATOSEN, Gather, ATOREC, Scatter) + ! Array - points to the begining of the real array that stores the field values + ! blockLen - the number of field values continiously stored per node + ! stride - the distance distance between successive nodes data blocks + ! fieldCnt - the total number of field variables to be communicated per node + subroutine HalgetNB(Array, blockLen, stride, fieldCnt, ATOSEN, Gather, ATOREC, Scatter) #ifdef HAVE_MPI - integer PREAL + integer PREAL #endif - integer, intent(in)::blockLen, stride, fieldCnt - real Array(:) - integer, intent(in)::ATOSEN(0:), ATOREC(0:) - integer, intent(in)::Gather(:), Scatter(:) + integer, intent(in)::blockLen, stride, fieldCnt + real Array(:) + integer, intent(in)::ATOSEN(0:), ATOREC(0:) + integer, intent(in)::Gather(:), Scatter(:) - integer, ALLOCATABLE, DIMENSION(:)::recvRequest, sendRequest - integer, ALLOCATABLE, DIMENSION(:,:)::Status - SAVE recvRequest, sendRequest, Status + integer, ALLOCATABLE, DIMENSION(:)::recvRequest, sendRequest + integer, ALLOCATABLE, DIMENSION(:,:)::Status + SAVE recvRequest, sendRequest, Status - integer, PARAMETER::TAG=12 + integer, PARAMETER::TAG=12 - integer NProcs, Rank, I, J, Count, IERROR - integer numBlocks, numBlocksPerNode, POS - integer, ALLOCATABLE, DIMENSION(:)::haloType - SAVE haloType - integer typeRef - integer MaxHaloLen - integer, ALLOCATABLE, DIMENSION(:)::blens, disp - SAVE blens, disp + integer NProcs, Rank, I, J, Count, IERROR + integer numBlocks, numBlocksPerNode, POS + integer, ALLOCATABLE, DIMENSION(:)::haloType + SAVE haloType + integer typeRef + integer MaxHaloLen + integer, ALLOCATABLE, DIMENSION(:)::blens, disp + SAVE blens, disp - logical Initalized - SAVE Initalized - DATA Initalized /.false./ + logical Initalized + SAVE Initalized + DATA Initalized /.false./ - integer NBits - SAVE NBits - DATA NBits /0/ + integer NBits + SAVE NBits + DATA NBits /0/ #ifdef HAVE_MPI - NProcs = GetNProcs() - PREAL = GetPREAL() - - numBlocksPerNode = fieldCnt/blockLen - - ! Allocate space for the blens and disp arrays - MaxHaloLen = 0 - do Rank=0, NProcs-1 - MaxHaloLen = MAX(MaxHaloLen, ATOREC(Rank+1)-ATOREC(Rank), ATOSEN(Rank+1)-ATOSEN(Rank)) - end do - - if(NBits.LT.(MaxHaloLen*numBlocksPerNode)) then - NBits = MaxHaloLen*numBlocksPerNode - - if(ALLOCATED(blens)) DEallocate(blens) - if(ALLOCATED(disp) ) DEallocate(disp) - - allocate( blens(NBits) ) - allocate( disp(NBits) ) - end if - - ! The length of each block being sent. This is constant. - do I=1, MaxHaloLen*numBlocksPerNode - blens(I) = blockLen - end do - - ! If this is the fist call to this routine then allocate some space - ! for these arrays - if(.NOT.Initalized) then - allocate( recvRequest(0:NProcs-1) ) - allocate( sendRequest(0:NProcs-1) ) - allocate( Status(MPI_STATUS_SIZE, 0:NProcs-1) ) - allocate( haloType(NProcs*2) ) - do I=1, NProcs*2 - haloType(I) = MPI_DATATYPE_NULL - end do - Initalized = .true. - end if - - typeRef = 1 - - ! Set up all the receives first - do Rank=0, NProcs-1 - Count = ATOREC(Rank+1)-ATOREC(Rank) - IF (Count .EQ. 0) then - ! Nothing to receive from Rank - recvRequest(Rank) = MPI_REQUEST_NULL - ELSE - numBlocks = Count*numBlocksPerNode - I = MaxHaloLen*numBlocksPerNode - - POS=1 - do I=0, numBlocksPerNode-1 - do J=1, Count - disp(POS) = I*stride + (Scatter(ATOREC(Rank)+J-1) - 1)*blockLen - POS = POS + 1 - end do - end do - - call MPI_TYPE_INDEXED(numBlocks, blens, disp, PREAL, haloType(typeRef), IERROR) - call MPI_TYPE_COMMIT(haloType(typeRef), IERROR) - - call MPI_IRECV(Array, 1, haloType(typeRef), Rank, TAG, MPI_COMM_FEMTOOLS, recvRequest(Rank), IERROR) - - typeRef = typeRef + 1 - end if - end do - - ! Set up all the sends - do Rank=0, NProcs-1 - Count = ATOSEN(Rank+1)-ATOSEN(Rank) - IF (Count .EQ. 0) then - ! Nothing to receive from Rank - sendRequest(Rank) = MPI_REQUEST_NULL - ELSE - numBlocks = Count*numBlocksPerNode - - POS=1 - do I=0, numBlocksPerNode-1 - do J=1, Count - disp(POS) = I*stride + (Gather(ATOSEN(Rank)+J-1) - 1)*blockLen - POS = POS + 1 - end do - end do - - call MPI_TYPE_INDEXED(numBlocks, blens, disp, PREAL, haloType(typeRef), IERROR) - call MPI_TYPE_COMMIT(haloType(typeRef), IERROR) - call MPI_ISEND(Array, 1, haloType(typeRef), Rank, TAG, MPI_COMM_FEMTOOLS, sendRequest(Rank), IERROR) - - typeRef = typeRef + 1 - end if - end do - - ! Wait for everything to finish. - call MPI_WAITALL(NProcs, sendRequest, Status, IERROR) - call MPI_WAITALL(NProcs, recvRequest, Status, IERROR) - - ! Free all derived datatypes - do I=1, typeRef-1 - call MPI_TYPE_FREE(haloType(I), IERROR) - if(IERROR.NE.MPI_SUCCESS) then - if(IERROR.EQ.MPI_ERR_TYPE) then - ewrite(-1,*) "Invalid datatype argument. May be an ", & + NProcs = GetNProcs() + PREAL = GetPREAL() + + numBlocksPerNode = fieldCnt/blockLen + + ! Allocate space for the blens and disp arrays + MaxHaloLen = 0 + do Rank=0, NProcs-1 + MaxHaloLen = MAX(MaxHaloLen, ATOREC(Rank+1)-ATOREC(Rank), ATOSEN(Rank+1)-ATOSEN(Rank)) + end do + + if(NBits.LT.(MaxHaloLen*numBlocksPerNode)) then + NBits = MaxHaloLen*numBlocksPerNode + + if(ALLOCATED(blens)) DEallocate(blens) + if(ALLOCATED(disp) ) DEallocate(disp) + + allocate( blens(NBits) ) + allocate( disp(NBits) ) + end if + + ! The length of each block being sent. This is constant. + do I=1, MaxHaloLen*numBlocksPerNode + blens(I) = blockLen + end do + + ! If this is the fist call to this routine then allocate some space + ! for these arrays + if(.NOT.Initalized) then + allocate( recvRequest(0:NProcs-1) ) + allocate( sendRequest(0:NProcs-1) ) + allocate( Status(MPI_STATUS_SIZE, 0:NProcs-1) ) + allocate( haloType(NProcs*2) ) + do I=1, NProcs*2 + haloType(I) = MPI_DATATYPE_NULL + end do + Initalized = .true. + end if + + typeRef = 1 + + ! Set up all the receives first + do Rank=0, NProcs-1 + Count = ATOREC(Rank+1)-ATOREC(Rank) + IF (Count .EQ. 0) then + ! Nothing to receive from Rank + recvRequest(Rank) = MPI_REQUEST_NULL + ELSE + numBlocks = Count*numBlocksPerNode + I = MaxHaloLen*numBlocksPerNode + + POS=1 + do I=0, numBlocksPerNode-1 + do J=1, Count + disp(POS) = I*stride + (Scatter(ATOREC(Rank)+J-1) - 1)*blockLen + POS = POS + 1 + end do + end do + + call MPI_TYPE_INDEXED(numBlocks, blens, disp, PREAL, haloType(typeRef), IERROR) + call MPI_TYPE_COMMIT(haloType(typeRef), IERROR) + + call MPI_IRECV(Array, 1, haloType(typeRef), Rank, TAG, MPI_COMM_FEMTOOLS, recvRequest(Rank), IERROR) + + typeRef = typeRef + 1 + end if + end do + + ! Set up all the sends + do Rank=0, NProcs-1 + Count = ATOSEN(Rank+1)-ATOSEN(Rank) + IF (Count .EQ. 0) then + ! Nothing to receive from Rank + sendRequest(Rank) = MPI_REQUEST_NULL + ELSE + numBlocks = Count*numBlocksPerNode + + POS=1 + do I=0, numBlocksPerNode-1 + do J=1, Count + disp(POS) = I*stride + (Gather(ATOSEN(Rank)+J-1) - 1)*blockLen + POS = POS + 1 + end do + end do + + call MPI_TYPE_INDEXED(numBlocks, blens, disp, PREAL, haloType(typeRef), IERROR) + call MPI_TYPE_COMMIT(haloType(typeRef), IERROR) + call MPI_ISEND(Array, 1, haloType(typeRef), Rank, TAG, MPI_COMM_FEMTOOLS, sendRequest(Rank), IERROR) + + typeRef = typeRef + 1 + end if + end do + + ! Wait for everything to finish. + call MPI_WAITALL(NProcs, sendRequest, Status, IERROR) + call MPI_WAITALL(NProcs, recvRequest, Status, IERROR) + + ! Free all derived datatypes + do I=1, typeRef-1 + call MPI_TYPE_FREE(haloType(I), IERROR) + if(IERROR.NE.MPI_SUCCESS) then + if(IERROR.EQ.MPI_ERR_TYPE) then + ewrite(-1,*) "Invalid datatype argument. May be an ", & "uncommitted MPI_Datatype (see MPI_Type_commit)." - call MPI_ABORT(MPI_COMM_FEMTOOLS, MPI_ERR_OTHER, IERROR) - ELSE if(IERROR.EQ.MPI_ERR_ARG) then - ewrite(-1,*) "Invalid argument. Some argument is invalid and is not ", & + call MPI_ABORT(MPI_COMM_FEMTOOLS, MPI_ERR_OTHER, IERROR) + ELSE if(IERROR.EQ.MPI_ERR_ARG) then + ewrite(-1,*) "Invalid argument. Some argument is invalid and is not ", & "identified by a specific error class (e.g., MPI_ERR_RANK)." - call MPI_ABORT(MPI_COMM_FEMTOOLS, MPI_ERR_OTHER, IERROR) - ELSE - ewrite(-1,*) "Unknown error from MPI_TYPE_FREE()" - call MPI_ABORT(MPI_COMM_FEMTOOLS, MPI_ERR_OTHER, IERROR) - end if - end if - end do + call MPI_ABORT(MPI_COMM_FEMTOOLS, MPI_ERR_OTHER, IERROR) + ELSE + ewrite(-1,*) "Unknown error from MPI_TYPE_FREE()" + call MPI_ABORT(MPI_COMM_FEMTOOLS, MPI_ERR_OTHER, IERROR) + end if + end if + end do #endif - end subroutine HalgetNB + end subroutine HalgetNB - subroutine HalgetNB_simple(Array, FperN, ATOSEN, Gather, ATOREC, Scatter) + subroutine HalgetNB_simple(Array, FperN, ATOSEN, Gather, ATOREC, Scatter) #ifdef HAVE_MPI - integer PREAL + integer PREAL #endif - real, intent(inout)::Array(:) - integer, intent(in)::FperN + real, intent(inout)::Array(:) + integer, intent(in)::FperN - integer, intent(in)::ATOSEN(0:), ATOREC(0:) - integer, intent(in)::Gather(:), Scatter(:) + integer, intent(in)::ATOSEN(0:), ATOREC(0:) + integer, intent(in)::Gather(:), Scatter(:) - integer, ALLOCATABLE, DIMENSION(:)::recvRequest, sendRequest - integer, ALLOCATABLE, DIMENSION(:,:)::Status - SAVE recvRequest, sendRequest, Status + integer, ALLOCATABLE, DIMENSION(:)::recvRequest, sendRequest + integer, ALLOCATABLE, DIMENSION(:,:)::Status + SAVE recvRequest, sendRequest, Status - integer, PARAMETER::TAG=12 + integer, PARAMETER::TAG=12 - integer NProcs, Rank, I, J, K, Count, toRecvCnt, IERROR - SAVE NProcs + integer NProcs, Rank, I, J, K, Count, toRecvCnt, IERROR + SAVE NProcs - real, ALLOCATABLE, DIMENSION(:)::bufferRecv, bufferSend - SAVE bufferRecv, bufferSend + real, ALLOCATABLE, DIMENSION(:)::bufferRecv, bufferSend + SAVE bufferRecv, bufferSend - integer BufferRecvLen - SAVE BufferRecvLen - DATA BufferRecvLen /0/ + integer BufferRecvLen + SAVE BufferRecvLen + DATA BufferRecvLen /0/ - integer BufferSendLen - SAVE BufferSendLen - DATA BufferSendLen /0/ + integer BufferSendLen + SAVE BufferSendLen + DATA BufferSendLen /0/ - logical Initalized - SAVE Initalized - DATA Initalized /.false./ + logical Initalized + SAVE Initalized + DATA Initalized /.false./ #ifdef HAVE_MPI - PREAL = GetPREAL() - - ! If this is the fist call to this routine then allocate some space - ! for these arrays - if(.NOT.Initalized) then - NProcs = GetNProcs() - - allocate( recvRequest(0:NProcs-1) ) - allocate( sendRequest(0:NProcs-1) ) - allocate( Status(MPI_STATUS_SIZE, 0:NProcs-1) ) - Initalized = .true. - end if - - assert(size(atosen).eq.(NProcs+1)) - assert(size(atorec).eq.(NProcs+1)) - - ! Make sure enough space has been allocated for the receive buffer - if(BufferRecvLen.LT.(ATOREC(NProcs) - 1)) then - if(ALLOCATED(bufferRecv)) DEallocate(bufferRecv) - BufferRecvLen = ATOREC(NProcs) - 1 - - allocate( bufferRecv(BufferRecvLen*FperN) ) - end if - - ! Make sure enough space has been allocated for the send buffer - if(BufferSendLen.LT.(ATOSEN(NProcs) - 1)) then - if(ALLOCATED(bufferSend)) DEallocate(bufferSend) - BufferSendLen = ATOSEN(NProcs) - 1 - - allocate( bufferSend(BufferSendLen*FperN) ) - end if - - ! Set up all the receives first - toRecvCnt = 0 - do Rank=0, NProcs-1 - Count = ATOREC(Rank+1)-ATOREC(Rank) - IF (Count .EQ. 0) then - ! Nothing to receive from Rank - recvRequest(Rank) = MPI_REQUEST_NULL - ELSE - call MPI_IRECV(bufferRecv(ATOREC(Rank)*FperN), Count*FperN, PREAL, & + PREAL = GetPREAL() + + ! If this is the fist call to this routine then allocate some space + ! for these arrays + if(.NOT.Initalized) then + NProcs = GetNProcs() + + allocate( recvRequest(0:NProcs-1) ) + allocate( sendRequest(0:NProcs-1) ) + allocate( Status(MPI_STATUS_SIZE, 0:NProcs-1) ) + Initalized = .true. + end if + + assert(size(atosen).eq.(NProcs+1)) + assert(size(atorec).eq.(NProcs+1)) + + ! Make sure enough space has been allocated for the receive buffer + if(BufferRecvLen.LT.(ATOREC(NProcs) - 1)) then + if(ALLOCATED(bufferRecv)) DEallocate(bufferRecv) + BufferRecvLen = ATOREC(NProcs) - 1 + + allocate( bufferRecv(BufferRecvLen*FperN) ) + end if + + ! Make sure enough space has been allocated for the send buffer + if(BufferSendLen.LT.(ATOSEN(NProcs) - 1)) then + if(ALLOCATED(bufferSend)) DEallocate(bufferSend) + BufferSendLen = ATOSEN(NProcs) - 1 + + allocate( bufferSend(BufferSendLen*FperN) ) + end if + + ! Set up all the receives first + toRecvCnt = 0 + do Rank=0, NProcs-1 + Count = ATOREC(Rank+1)-ATOREC(Rank) + IF (Count .EQ. 0) then + ! Nothing to receive from Rank + recvRequest(Rank) = MPI_REQUEST_NULL + ELSE + call MPI_IRECV(bufferRecv(ATOREC(Rank)*FperN), Count*FperN, PREAL, & Rank, TAG, MPI_COMM_FEMTOOLS, recvRequest(Rank), IERROR) - toRecvCnt = toRecvCnt + 1 - end if - end do - - ! Set up all the sends - do Rank=0, NProcs-1 - Count = ATOSEN(Rank+1)-ATOSEN(Rank) - IF (Count .EQ. 0) then - ! Nothing to receive from Rank - sendRequest(Rank) = MPI_REQUEST_NULL - ELSE - do I=ATOSEN(Rank), ATOSEN(Rank+1)-1 - do J=0, FperN-1 - bufferSend(I*FperN+J) = Array(Gather(I)*FperN + J) - end do - end do - - call MPI_ISEND(bufferSend(ATOSEN(Rank)*FperN), Count*FperN, PREAL, & + toRecvCnt = toRecvCnt + 1 + end if + end do + + ! Set up all the sends + do Rank=0, NProcs-1 + Count = ATOSEN(Rank+1)-ATOSEN(Rank) + IF (Count .EQ. 0) then + ! Nothing to receive from Rank + sendRequest(Rank) = MPI_REQUEST_NULL + ELSE + do I=ATOSEN(Rank), ATOSEN(Rank+1)-1 + do J=0, FperN-1 + bufferSend(I*FperN+J) = Array(Gather(I)*FperN + J) + end do + end do + + call MPI_ISEND(bufferSend(ATOSEN(Rank)*FperN), Count*FperN, PREAL, & Rank, TAG, MPI_COMM_FEMTOOLS, sendRequest(Rank), IERROR) - end if - end do - - ! Wait for receives to finish. - do K=1, toRecvCnt - call MPI_WAITANY(NProcs, recvRequest, J, Status(:,0), IERROR) - - ! Unpack received data - Rank = Status(MPI_SOURCE, 0) - do I=ATOREC(Rank), ATOREC(Rank+1)-1 - do J=0, FperN-1 - Array(Scatter(I)*FperN + J) = bufferRecv(I*FperN+J) - end do - end do - end do - - call MPI_WAITALL(NProcs, sendRequest, Status, IERROR) + end if + end do + + ! Wait for receives to finish. + do K=1, toRecvCnt + call MPI_WAITANY(NProcs, recvRequest, J, Status(:,0), IERROR) + + ! Unpack received data + Rank = Status(MPI_SOURCE, 0) + do I=ATOREC(Rank), ATOREC(Rank+1)-1 + do J=0, FperN-1 + Array(Scatter(I)*FperN + J) = bufferRecv(I*FperN+J) + end do + end do + end do + + call MPI_WAITALL(NProcs, sendRequest, Status, IERROR) #endif - end subroutine HalgetNB_simple + end subroutine HalgetNB_simple - function pending_communication_communicator(communicator) result(pending) - !!< Return whether there is a pending communication for the supplied communicator. + function pending_communication_communicator(communicator) result(pending) + !!< Return whether there is a pending communication for the supplied communicator. - integer, optional, intent(in) :: communicator + integer, optional, intent(in) :: communicator - logical :: pending + logical :: pending - integer :: lcommunicator + integer :: lcommunicator #ifdef HAVE_MPI - integer :: ierr, ipending + integer :: ierr, ipending - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if - call mpi_iprobe(MPI_ANY_SOURCE, MPI_ANY_TAG, lcommunicator, ipending, MPI_STATUS_IGNORE, ierr) - assert(ierr == MPI_SUCCESS) + call mpi_iprobe(MPI_ANY_SOURCE, MPI_ANY_TAG, lcommunicator, ipending, MPI_STATUS_IGNORE, ierr) + assert(ierr == MPI_SUCCESS) - pending = (ipending /= 0) + pending = (ipending /= 0) - ! Note - removing this mpi_barrier could result in a false - ! positive on another process. - call mpi_barrier(lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) + ! Note - removing this mpi_barrier could result in a false + ! positive on another process. + call mpi_barrier(lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) #else - pending = .false. + pending = .false. #endif - end function pending_communication_communicator + end function pending_communication_communicator - function valid_communicator(communicator) result(valid) - !!< Return whether the supplied MPI communicator is valid + function valid_communicator(communicator) result(valid) + !!< Return whether the supplied MPI communicator is valid - integer, intent(in) :: communicator + integer, intent(in) :: communicator - logical :: valid + logical :: valid #ifdef HAVE_MPI - integer :: ierr, size + integer :: ierr, size - call mpi_comm_size(communicator, size, ierr) + call mpi_comm_size(communicator, size, ierr) - valid = (ierr == MPI_SUCCESS) + valid = (ierr == MPI_SUCCESS) #else - valid = .false. + valid = .false. #endif - end function valid_communicator + end function valid_communicator - subroutine allor(value, communicator) - !!< Or the logical value across all processes + subroutine allor(value, communicator) + !!< Or the logical value across all processes - logical, intent(inout) :: value - integer, optional, intent(in) :: communicator + logical, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: ierr, lcommunicator - logical :: or - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - call mpi_allreduce(value, or, 1, MPI_LOGICAL, MPI_LOR, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = or - end if + integer :: ierr, lcommunicator + logical :: or + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + call mpi_allreduce(value, or, 1, MPI_LOGICAL, MPI_LOR, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = or + end if #endif - end subroutine allor + end subroutine allor - subroutine alland(value, communicator) - !!< And the logical value across all processes + subroutine alland(value, communicator) + !!< And the logical value across all processes - logical, intent(inout) :: value - integer, optional, intent(in) :: communicator + logical, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: ierr, lcommunicator - logical :: and - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - call mpi_allreduce(value, and, 1, MPI_LOGICAL, MPI_LAND, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = and - end if + integer :: ierr, lcommunicator + logical :: and + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + call mpi_allreduce(value, and, 1, MPI_LOGICAL, MPI_LAND, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = and + end if #endif - end subroutine alland + end subroutine alland - subroutine allmax_integer(value, communicator) - !!< Find the maxmimum value across all processes + subroutine allmax_integer(value, communicator) + !!< Find the maxmimum value across all processes - integer, intent(inout) :: value - integer, optional, intent(in) :: communicator + integer, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: ierr, lcommunicator, maximum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - call MPI_Allreduce(value, maximum, 1, getpinteger(), MPI_MAX, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = maximum - end if + integer :: ierr, lcommunicator, maximum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + call MPI_Allreduce(value, maximum, 1, getpinteger(), MPI_MAX, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = maximum + end if #endif - end subroutine allmax_integer + end subroutine allmax_integer - subroutine allmax_real(value, communicator) - !!< Find the maxmimum value across all processes + subroutine allmax_real(value, communicator) + !!< Find the maxmimum value across all processes - real, intent(inout) :: value - integer, optional, intent(in) :: communicator + real, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: ierr, lcommunicator - real :: maximum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - call mpi_allreduce(value, maximum, 1, getpreal(), MPI_MAX, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = maximum - end if + integer :: ierr, lcommunicator + real :: maximum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + call mpi_allreduce(value, maximum, 1, getpreal(), MPI_MAX, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = maximum + end if #endif - end subroutine allmax_real + end subroutine allmax_real - subroutine allmin_integer(value, communicator) - !!< Find the minimum value across all processes + subroutine allmin_integer(value, communicator) + !!< Find the minimum value across all processes - integer, intent(inout) :: value - integer, optional, intent(in) :: communicator + integer, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: lcommunicator, mierr, minimum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(IsParallel()) then - assert(valid_communicator(lcommunicator)) - call MPI_Allreduce(value, minimum, 1, getpinteger(), MPI_MIN, lcommunicator, mierr) - assert(mierr == MPI_SUCCESS) - value = minimum - end if + integer :: lcommunicator, mierr, minimum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(IsParallel()) then + assert(valid_communicator(lcommunicator)) + call MPI_Allreduce(value, minimum, 1, getpinteger(), MPI_MIN, lcommunicator, mierr) + assert(mierr == MPI_SUCCESS) + value = minimum + end if #endif - end subroutine allmin_integer + end subroutine allmin_integer - subroutine allmin_real(value, communicator) - !!< Find the minimum value across all processes + subroutine allmin_real(value, communicator) + !!< Find the minimum value across all processes - real, intent(inout) :: value - integer, optional, intent(in) :: communicator + real, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: lcommunicator, mierr - real :: minimum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(IsParallel()) then - assert(valid_communicator(lcommunicator)) - call MPI_Allreduce(value, minimum, 1, getpreal(), MPI_MIN, lcommunicator, mierr) - assert(mierr == MPI_SUCCESS) - value = minimum - end if + integer :: lcommunicator, mierr + real :: minimum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(IsParallel()) then + assert(valid_communicator(lcommunicator)) + call MPI_Allreduce(value, minimum, 1, getpreal(), MPI_MIN, lcommunicator, mierr) + assert(mierr == MPI_SUCCESS) + value = minimum + end if #endif - end subroutine allmin_real + end subroutine allmin_real - subroutine allsum_integer(value, communicator) - !!< Sum the integer value across all processes + subroutine allsum_integer(value, communicator) + !!< Sum the integer value across all processes - integer, intent(inout) :: value - integer, optional, intent(in) :: communicator + integer, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: ierr, lcommunicator - integer :: sum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - sum = 0.0 - call MPI_Allreduce(value, sum, 1, getpinteger(), MPI_SUM, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = sum - end if + integer :: ierr, lcommunicator + integer :: sum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + sum = 0.0 + call MPI_Allreduce(value, sum, 1, getpinteger(), MPI_SUM, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = sum + end if #endif - end subroutine allsum_integer + end subroutine allsum_integer - subroutine allsum_real(value, communicator) - !!< Sum the real value across all processes + subroutine allsum_real(value, communicator) + !!< Sum the real value across all processes - real, intent(inout) :: value - integer, optional, intent(in) :: communicator + real, intent(inout) :: value + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: ierr, lcommunicator - real :: sum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - sum = 0.0 - call MPI_Allreduce(value, sum, 1, getpreal(), MPI_SUM, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = sum - end if + integer :: ierr, lcommunicator + real :: sum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + sum = 0.0 + call MPI_Allreduce(value, sum, 1, getpreal(), MPI_SUM, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = sum + end if #endif - end subroutine allsum_real + end subroutine allsum_real - subroutine allmean(value, communicator) - !!< Sum the real value across all processes + subroutine allmean(value, communicator) + !!< Sum the real value across all processes - real, intent(inout) :: value - integer, optional, intent(in) :: communicator + real, intent(inout) :: value + integer, optional, intent(in) :: communicator - call allsum(value, communicator = communicator) - value = value / getnprocs(communicator = communicator) + call allsum(value, communicator = communicator) + value = value / getnprocs(communicator = communicator) - end subroutine allmean + end subroutine allmean - subroutine allsum_integer_vector(value, communicator) - !!< Sum the value across all processes + subroutine allsum_integer_vector(value, communicator) + !!< Sum the value across all processes - integer, intent(inout) :: value(:) - integer, optional, intent(in) :: communicator + integer, intent(inout) :: value(:) + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: lcommunicator, ierr - integer, dimension(size(value)) :: sum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - sum = 0 - call MPI_Allreduce(value, sum, size(value), getpinteger(), MPI_SUM, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = sum - end if + integer :: lcommunicator, ierr + integer, dimension(size(value)) :: sum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + sum = 0 + call MPI_Allreduce(value, sum, size(value), getpinteger(), MPI_SUM, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = sum + end if #endif - end subroutine allsum_integer_vector + end subroutine allsum_integer_vector - subroutine allsum_real_vector(value, communicator) - !!< Sum the value across all processes + subroutine allsum_real_vector(value, communicator) + !!< Sum the value across all processes - real, intent(inout) :: value(:) - integer, optional, intent(in) :: communicator + real, intent(inout) :: value(:) + integer, optional, intent(in) :: communicator #ifdef HAVE_MPI - integer :: lcommunicator, ierr - real, dimension(size(value)) :: sum - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - sum = 0.0 - call MPI_Allreduce(value, sum, size(value), getpreal(), MPI_SUM, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - value = sum - end if + integer :: lcommunicator, ierr + real, dimension(size(value)) :: sum + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + sum = 0.0 + call MPI_Allreduce(value, sum, size(value), getpreal(), MPI_SUM, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + value = sum + end if #endif - end subroutine allsum_real_vector + end subroutine allsum_real_vector - function allfequals(value, communicator, tol) - !!< Return if all of value are almost equal across all processes + function allfequals(value, communicator, tol) + !!< Return if all of value are almost equal across all processes - real, intent(in) :: value - integer, optional, intent(in) :: communicator - real, optional, intent(in) :: tol + real, intent(in) :: value + integer, optional, intent(in) :: communicator + real, optional, intent(in) :: tol - logical :: allfequals + logical :: allfequals #ifdef HAVE_MPI - integer :: lcommunicator, ierr - real :: eps, zero_value - - if(present(communicator)) then - lcommunicator = communicator - else - lcommunicator = MPI_COMM_FEMTOOLS - end if - - if(present(tol)) then - eps = tol - else - eps = 100.0 * epsilon(0.0) - end if - - if(isparallel()) then - assert(valid_communicator(lcommunicator)) - if(getrank(communicator = lcommunicator) == 0) zero_value = value - call mpi_bcast(zero_value, 1, getpreal(), 0, lcommunicator, ierr) - assert(ierr == MPI_SUCCESS) - - allfequals = abs(zero_value - value) < max(eps, abs(value) * eps) - call alland(allfequals, communicator = lcommunicator) - else - allfequals = .true. - end if + integer :: lcommunicator, ierr + real :: eps, zero_value + + if(present(communicator)) then + lcommunicator = communicator + else + lcommunicator = MPI_COMM_FEMTOOLS + end if + + if(present(tol)) then + eps = tol + else + eps = 100.0 * epsilon(0.0) + end if + + if(isparallel()) then + assert(valid_communicator(lcommunicator)) + if(getrank(communicator = lcommunicator) == 0) zero_value = value + call mpi_bcast(zero_value, 1, getpreal(), 0, lcommunicator, ierr) + assert(ierr == MPI_SUCCESS) + + allfequals = abs(zero_value - value) < max(eps, abs(value) * eps) + call alland(allfequals, communicator = lcommunicator) + else + allfequals = .true. + end if #else - allfequals = .true. + allfequals = .true. #endif - end function allfequals + end function allfequals - pure function parallel_filename_no_extension_len(filename) result(length) - !!< Return the (maximum) length of a string containing: - !!< [filename]_[process number] + pure function parallel_filename_no_extension_len(filename) result(length) + !!< Return the (maximum) length of a string containing: + !!< [filename]_[process number] - character(len = *), intent(in) :: filename + character(len = *), intent(in) :: filename - integer :: length + integer :: length - length = len_trim(filename) + 1 + floor(log10(real(huge(0)))) + 1 + length = len_trim(filename) + 1 + floor(log10(real(huge(0)))) + 1 - end function parallel_filename_no_extension_len + end function parallel_filename_no_extension_len - function parallel_filename_no_extension(filename) result(pfilename) - !!< Return a string containing: - !!< [filename]-[process-number] - !!< Note that is it important to trim the returned string. + function parallel_filename_no_extension(filename) result(pfilename) + !!< Return a string containing: + !!< [filename]-[process-number] + !!< Note that is it important to trim the returned string. - character(len = *), intent(in) :: filename + character(len = *), intent(in) :: filename - character(len = parallel_filename_len(filename)) :: pfilename + character(len = parallel_filename_len(filename)) :: pfilename - if (is_active_process .and. no_active_processes == 1) then - write(pfilename, "(a)") trim(filename) - else - write(pfilename, "(a, i0)") trim(filename) // "_", getrank() - end if + if (is_active_process .and. no_active_processes == 1) then + write(pfilename, "(a)") trim(filename) + else + write(pfilename, "(a, i0)") trim(filename) // "_", getrank() + end if - end function parallel_filename_no_extension + end function parallel_filename_no_extension - pure function parallel_filename_with_extension_len(filename, extension) result(length) - !!< Return the (maximum) length of a string containing: - !!< [filename]_[process number].[extension] + pure function parallel_filename_with_extension_len(filename, extension) result(length) + !!< Return the (maximum) length of a string containing: + !!< [filename]_[process number].[extension] - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: extension + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: extension - integer :: length + integer :: length - length = parallel_filename_len(filename) + len_trim(extension) + length = parallel_filename_len(filename) + len_trim(extension) - end function parallel_filename_with_extension_len + end function parallel_filename_with_extension_len - function parallel_filename_with_extension(filename, extension) result(pfilename) - !!< Return a string containing: - !!< [filename]-[process-number][extension] - !!< Note that is it important to trim the returned string. + function parallel_filename_with_extension(filename, extension) result(pfilename) + !!< Return a string containing: + !!< [filename]-[process-number][extension] + !!< Note that is it important to trim the returned string. - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: extension + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: extension - character(len = parallel_filename_len(filename, extension)) :: pfilename + character(len = parallel_filename_len(filename, extension)) :: pfilename - pfilename = trim(parallel_filename(filename)) // trim(extension) + pfilename = trim(parallel_filename(filename)) // trim(extension) - end function parallel_filename_with_extension + end function parallel_filename_with_extension - subroutine set_communicator(communicator) bind(c) - !!< Set mpi_comm_femtools to the provided communicator - !!< If this subroutine is not used, mpi_comm_femtools = mpi_comm_world + subroutine set_communicator(communicator) bind(c) + !!< Set mpi_comm_femtools to the provided communicator + !!< If this subroutine is not used, mpi_comm_femtools = mpi_comm_world - integer(c_int), intent(in) :: communicator + integer(c_int), intent(in) :: communicator - MPI_COMM_FEMTOOLS = communicator + MPI_COMM_FEMTOOLS = communicator - end subroutine set_communicator + end subroutine set_communicator end module parallel_tools diff --git a/femtools/Parallel_fields.F90 b/femtools/Parallel_fields.F90 index c3cf86f9da..74f735d33b 100644 --- a/femtools/Parallel_fields.F90 +++ b/femtools/Parallel_fields.F90 @@ -28,733 +28,733 @@ #include "fdebug.h" module parallel_fields - !!< This module exists to separate out parallel operations on fields - - use fldebug - use futils - use mpi_interfaces - use parallel_tools - use elements - use halo_data_types - use halos_base - use fields_data_types - use fields_base - use halos_communications - use halos_numbering - use halos_ownership - use fields_allocates - use fields_manipulation - - implicit none - - private - - public :: halo_communicator, element_owned, element_neighbour_owned, & - & element_owner, node_owned, assemble_ele, & - & surface_element_owned, nowned_nodes - ! Apparently ifort has a problem with the generic name node_owned - public :: node_owned_mesh, zero_non_owned - - interface node_owned - module procedure node_owned_mesh, node_owned_scalar, node_owned_vector, & + !!< This module exists to separate out parallel operations on fields + + use fldebug + use futils + use mpi_interfaces + use parallel_tools + use elements + use halo_data_types + use halos_base + use fields_data_types + use fields_base + use halos_communications + use halos_numbering + use halos_ownership + use fields_allocates + use fields_manipulation + + implicit none + + private + + public :: halo_communicator, element_owned, element_neighbour_owned, & + & element_owner, node_owned, assemble_ele, & + & surface_element_owned, nowned_nodes + ! Apparently ifort has a problem with the generic name node_owned + public :: node_owned_mesh, zero_non_owned + + interface node_owned + module procedure node_owned_mesh, node_owned_scalar, node_owned_vector, & & node_owned_tensor - end interface node_owned + end interface node_owned - interface element_owned - module procedure element_owned_mesh, element_owned_scalar, & + interface element_owned + module procedure element_owned_mesh, element_owned_scalar, & & element_owned_vector, element_owned_tensor - end interface element_owned + end interface element_owned - interface element_neighbour_owned - module procedure element_neighbour_owned_mesh, & - & element_neighbour_owned_scalar, element_neighbour_owned_vector, & - & element_neighbour_owned_tensor - end interface element_neighbour_owned + interface element_neighbour_owned + module procedure element_neighbour_owned_mesh, & + & element_neighbour_owned_scalar, element_neighbour_owned_vector, & + & element_neighbour_owned_tensor + end interface element_neighbour_owned - interface element_owner - module procedure element_owner_mesh, element_owner_scalar, & + interface element_owner + module procedure element_owner_mesh, element_owner_scalar, & & element_owner_vector, element_owner_tensor - end interface element_owner + end interface element_owner - interface assemble_ele - module procedure assemble_ele_mesh, assemble_ele_scalar, & + interface assemble_ele + module procedure assemble_ele_mesh, assemble_ele_scalar, & & assemble_ele_vector, assemble_ele_tensor - end interface assemble_ele + end interface assemble_ele - interface surface_element_owned - module procedure surface_element_owned_mesh, surface_element_owned_scalar, & + interface surface_element_owned + module procedure surface_element_owned_mesh, surface_element_owned_scalar, & & surface_element_owned_vector, surface_element_owned_tensor - end interface surface_element_owned + end interface surface_element_owned - interface zero_non_owned - module procedure zero_non_owned_scalar, zero_non_owned_vector - end interface + interface zero_non_owned + module procedure zero_non_owned_scalar, zero_non_owned_vector + end interface - interface halo_communicator - module procedure halo_communicator_mesh, halo_communicator_scalar, & + interface halo_communicator + module procedure halo_communicator_mesh, halo_communicator_scalar, & & halo_communicator_vector, halo_communicator_tensor - end interface halo_communicator + end interface halo_communicator - interface nowned_nodes - module procedure nowned_nodes_mesh, nowned_nodes_scalar, & + interface nowned_nodes + module procedure nowned_nodes_mesh, nowned_nodes_scalar, & & nowned_nodes_vector, nowned_nodes_tensor - end interface nowned_nodes + end interface nowned_nodes contains - function halo_communicator_mesh(mesh) result(communicator) - !!< Return the halo communicator for this mesh. Returns the halo - !!< communicator off of the max level node halo. + function halo_communicator_mesh(mesh) result(communicator) + !!< Return the halo communicator for this mesh. Returns the halo + !!< communicator off of the max level node halo. - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - integer :: communicator + integer :: communicator - integer :: nhalos + integer :: nhalos - nhalos = halo_count(mesh) - if(nhalos > 0) then - communicator = halo_communicator(mesh%halos(nhalos)) - else + nhalos = halo_count(mesh) + if(nhalos > 0) then + communicator = halo_communicator(mesh%halos(nhalos)) + else #ifdef HAVE_MPI - communicator = MPI_COMM_FEMTOOLS + communicator = MPI_COMM_FEMTOOLS #else - communicator = -1 + communicator = -1 #endif - end if - - end function halo_communicator_mesh - - function halo_communicator_scalar(s_field) result(communicator) - !!< Return the halo communicator for this field. Returns the halo - !!< communicator off of the max level node halo. - - type(scalar_field), intent(in) :: s_field - - integer :: communicator + end if - communicator = halo_communicator(s_field%mesh) + end function halo_communicator_mesh - end function halo_communicator_scalar + function halo_communicator_scalar(s_field) result(communicator) + !!< Return the halo communicator for this field. Returns the halo + !!< communicator off of the max level node halo. - function halo_communicator_vector(v_field) result(communicator) - !!< Return the halo communicator for this mesh. Returns the halo - !!< communicator off of the max level node halo. + type(scalar_field), intent(in) :: s_field - type(vector_field), intent(in) :: v_field + integer :: communicator - integer :: communicator + communicator = halo_communicator(s_field%mesh) - communicator = halo_communicator(v_field%mesh) + end function halo_communicator_scalar - end function halo_communicator_vector + function halo_communicator_vector(v_field) result(communicator) + !!< Return the halo communicator for this mesh. Returns the halo + !!< communicator off of the max level node halo. - function halo_communicator_tensor(t_field) result(communicator) - !!< Return the halo communicator for this mesh. Returns the halo - !!< communicator off of the max level node halo. + type(vector_field), intent(in) :: v_field - type(tensor_field), intent(in) :: t_field + integer :: communicator - integer :: communicator + communicator = halo_communicator(v_field%mesh) - communicator = halo_communicator(t_field%mesh) + end function halo_communicator_vector - end function halo_communicator_tensor + function halo_communicator_tensor(t_field) result(communicator) + !!< Return the halo communicator for this mesh. Returns the halo + !!< communicator off of the max level node halo. - function node_owned_mesh(mesh, node_number) result(owned) - !!< Return whether the supplied node in the given mesh is owned by this - !!< process + type(tensor_field), intent(in) :: t_field - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: node_number + integer :: communicator - logical :: owned + communicator = halo_communicator(t_field%mesh) - assert(node_number > 0) - assert(node_number <= node_count(mesh)) + end function halo_communicator_tensor - if(isparallel()) then - ! For ownership it doesn't matter if we use depth 1 or 2. - assert(associated(mesh%halos)) - owned = node_owned(mesh%halos(1), node_number) - else - owned = .true. - end if + function node_owned_mesh(mesh, node_number) result(owned) + !!< Return whether the supplied node in the given mesh is owned by this + !!< process - end function node_owned_mesh + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: node_number - function node_owned_scalar(s_field, node_number) result(owned) - !!< Return whether the supplied node in the given field's mesh is owned by this - !!< process + logical :: owned - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: node_number + assert(node_number > 0) + assert(node_number <= node_count(mesh)) - logical :: owned + if(isparallel()) then + ! For ownership it doesn't matter if we use depth 1 or 2. + assert(associated(mesh%halos)) + owned = node_owned(mesh%halos(1), node_number) + else + owned = .true. + end if - owned = node_owned(s_field%mesh, node_number) + end function node_owned_mesh - end function node_owned_scalar + function node_owned_scalar(s_field, node_number) result(owned) + !!< Return whether the supplied node in the given field's mesh is owned by this + !!< process - function node_owned_vector(v_field, node_number) result(owned) - !!< Return whether the supplied node in the given field's mesh is owned by this - !!< process + type(scalar_field), intent(in) :: s_field + integer, intent(in) :: node_number - type(vector_field), intent(in) :: v_field - integer, intent(in) :: node_number + logical :: owned - logical :: owned + owned = node_owned(s_field%mesh, node_number) - owned = node_owned(v_field%mesh, node_number) + end function node_owned_scalar - end function node_owned_vector + function node_owned_vector(v_field, node_number) result(owned) + !!< Return whether the supplied node in the given field's mesh is owned by this + !!< process - function node_owned_tensor(t_field, node_number) result(owned) - !!< Return whether the supplied node in the given field's mesh is owned by this - !!< process + type(vector_field), intent(in) :: v_field + integer, intent(in) :: node_number - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: node_number + logical :: owned - logical :: owned + owned = node_owned(v_field%mesh, node_number) - owned = node_owned(t_field%mesh, node_number) + end function node_owned_vector - end function node_owned_tensor + function node_owned_tensor(t_field, node_number) result(owned) + !!< Return whether the supplied node in the given field's mesh is owned by this + !!< process - function element_owned_mesh(mesh, element_number) result(owned) - !!< Return whether the supplied element in the given mesh is owned by this - !!< process + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: node_number - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: element_number + logical :: owned - integer :: nhalos - logical :: owned + owned = node_owned(t_field%mesh, node_number) - assert(element_number > 0) - assert(element_number <= ele_count(mesh)) + end function node_owned_tensor - nhalos = element_halo_count(mesh) - if(nhalos > 0) then - owned = node_owned(mesh%element_halos(nhalos), element_number) - else - owned = .true. - end if + function element_owned_mesh(mesh, element_number) result(owned) + !!< Return whether the supplied element in the given mesh is owned by this + !!< process - end function element_owned_mesh + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: element_number - function element_owned_scalar(s_field, element_number) result(owned) - !!< Return whether the supplied element in the mesh of the given scalar - !!< field is owned by this process + integer :: nhalos + logical :: owned - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: element_number + assert(element_number > 0) + assert(element_number <= ele_count(mesh)) - logical :: owned + nhalos = element_halo_count(mesh) + if(nhalos > 0) then + owned = node_owned(mesh%element_halos(nhalos), element_number) + else + owned = .true. + end if - owned = element_owned(s_field%mesh, element_number) + end function element_owned_mesh - end function element_owned_scalar + function element_owned_scalar(s_field, element_number) result(owned) + !!< Return whether the supplied element in the mesh of the given scalar + !!< field is owned by this process - function element_owned_vector(v_field, element_number) result(owned) - !!< Return whether the supplied element in the mesh of the given scalar - !!< field is owned by this process + type(scalar_field), intent(in) :: s_field + integer, intent(in) :: element_number - type(vector_field), intent(in) :: v_field - integer, intent(in) :: element_number + logical :: owned - logical :: owned + owned = element_owned(s_field%mesh, element_number) - owned = element_owned(v_field%mesh, element_number) + end function element_owned_scalar - end function element_owned_vector + function element_owned_vector(v_field, element_number) result(owned) + !!< Return whether the supplied element in the mesh of the given scalar + !!< field is owned by this process - function element_owned_tensor(t_field, element_number) result(owned) - !!< Return whether the supplied element in the mesh of the given tensor - !!< field is owned by this process + type(vector_field), intent(in) :: v_field + integer, intent(in) :: element_number - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: element_number + logical :: owned - logical :: owned + owned = element_owned(v_field%mesh, element_number) - owned = element_owned(t_field%mesh, element_number) + end function element_owned_vector - end function element_owned_tensor + function element_owned_tensor(t_field, element_number) result(owned) + !!< Return whether the supplied element in the mesh of the given tensor + !!< field is owned by this process - function element_neighbour_owned_mesh(mesh, element_number) result(owned) - !!< Return .true. if ELEMENT_NUMBER has a neighbour in MESH that - !!< is owned by this process otherwise .false. + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: element_number - !! Note, you cannot use this function to compute if - !! ELEMENT_NUMBER is owned. Imagine if this is the only owned - !! element on a process, then none of the neighbours will be owned. - !! You can use this function to compute whether ELEMENT_NUMBER is - !! in the L1 element halo. - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: element_number - logical :: owned - integer, dimension(:), pointer :: neighbours - integer :: i, n_neigh + logical :: owned - neighbours => ele_neigh(mesh, element_number) - n_neigh = size(neighbours) - owned = .false. - do i = 1, n_neigh - ! If element_number is in the halo, then some of the neighbour - ! data might not be available, in which case neighbours(i) can - ! be invalid (missing data are marked by negative values). - if ( neighbours(i) <= 0 ) cycle - if ( element_owned(mesh, neighbours(i)) ) then - owned = .true. - return - end if - end do - end function element_neighbour_owned_mesh + owned = element_owned(t_field%mesh, element_number) - function element_neighbour_owned_scalar(field, element_number) result(owned) - !!< Return .true. if ELEMENT_NUMBER has a neighbour in FIELD that - !!< is owned by this process otherwise .false. + end function element_owned_tensor - !! Note, you cannot use this function to compute if - !! ELEMENT_NUMBER is owned. Imagine if this is the only owned - !! element on a process, then none of the neighbours will be owned. - !! You can use this function to compute whether ELEMENT_NUMBER is - !! in the L1 element halo. - type(scalar_field), intent(in) :: field - integer, intent(in) :: element_number - logical :: owned + function element_neighbour_owned_mesh(mesh, element_number) result(owned) + !!< Return .true. if ELEMENT_NUMBER has a neighbour in MESH that + !!< is owned by this process otherwise .false. - owned = element_neighbour_owned(field%mesh, element_number) - end function element_neighbour_owned_scalar + !! Note, you cannot use this function to compute if + !! ELEMENT_NUMBER is owned. Imagine if this is the only owned + !! element on a process, then none of the neighbours will be owned. + !! You can use this function to compute whether ELEMENT_NUMBER is + !! in the L1 element halo. + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: element_number + logical :: owned + integer, dimension(:), pointer :: neighbours + integer :: i, n_neigh - function element_neighbour_owned_vector(field, element_number) result(owned) - !!< Return .true. if ELEMENT_NUMBER has a neighbour in FIELD that - !!< is owned by this process otherwise .false. + neighbours => ele_neigh(mesh, element_number) + n_neigh = size(neighbours) + owned = .false. + do i = 1, n_neigh + ! If element_number is in the halo, then some of the neighbour + ! data might not be available, in which case neighbours(i) can + ! be invalid (missing data are marked by negative values). + if ( neighbours(i) <= 0 ) cycle + if ( element_owned(mesh, neighbours(i)) ) then + owned = .true. + return + end if + end do + end function element_neighbour_owned_mesh + + function element_neighbour_owned_scalar(field, element_number) result(owned) + !!< Return .true. if ELEMENT_NUMBER has a neighbour in FIELD that + !!< is owned by this process otherwise .false. + + !! Note, you cannot use this function to compute if + !! ELEMENT_NUMBER is owned. Imagine if this is the only owned + !! element on a process, then none of the neighbours will be owned. + !! You can use this function to compute whether ELEMENT_NUMBER is + !! in the L1 element halo. + type(scalar_field), intent(in) :: field + integer, intent(in) :: element_number + logical :: owned + + owned = element_neighbour_owned(field%mesh, element_number) + end function element_neighbour_owned_scalar + + function element_neighbour_owned_vector(field, element_number) result(owned) + !!< Return .true. if ELEMENT_NUMBER has a neighbour in FIELD that + !!< is owned by this process otherwise .false. + + !! Note, you cannot use this function to compute if + !! ELEMENT_NUMBER is owned. Imagine if this is the only owned + !! element on a process, then none of the neighbours will be owned. + !! You can use this function to compute whether ELEMENT_NUMBER is + !! in the L1 element halo. + type(vector_field), intent(in) :: field + integer, intent(in) :: element_number + logical :: owned + + owned = element_neighbour_owned(field%mesh, element_number) + end function element_neighbour_owned_vector + + function element_neighbour_owned_tensor(field, element_number) result(owned) + !!< Return .true. if ELEMENT_NUMBER has a neighbour in FIELD that + !!< is owned by this process otherwise .false. + + !! Note, you cannot use this function to compute if + !! ELEMENT_NUMBER is owned. Imagine if this is the only owned + !! element on a process, then none of the neighbours will be owned. + !! You can use this function to compute whether ELEMENT_NUMBER is + !! in the L1 element halo. + type(tensor_field), intent(in) :: field + integer, intent(in) :: element_number + logical :: owned + + owned = element_neighbour_owned(field%mesh, element_number) + end function element_neighbour_owned_tensor + + function element_owner_mesh(mesh, element_number) result(owner) + !!< Return number of processor that owns the supplied element in the + !given mesh + + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: element_number + + integer :: nhalos + integer :: owner + + assert(element_number > 0) + assert(element_number <= ele_count(mesh)) + + nhalos = element_halo_count(mesh) + + if(nhalos == 0) then + owner=getprocno() + else + owner = halo_node_owner(mesh%element_halos(nhalos), element_number) + end if - !! Note, you cannot use this function to compute if - !! ELEMENT_NUMBER is owned. Imagine if this is the only owned - !! element on a process, then none of the neighbours will be owned. - !! You can use this function to compute whether ELEMENT_NUMBER is - !! in the L1 element halo. - type(vector_field), intent(in) :: field - integer, intent(in) :: element_number - logical :: owned + end function element_owner_mesh - owned = element_neighbour_owned(field%mesh, element_number) - end function element_neighbour_owned_vector + function element_owner_scalar(s_field, element_number) result(owner) + !!< Return the processor that owns the supplied element in the mesh of the given scalar + !!< field - function element_neighbour_owned_tensor(field, element_number) result(owned) - !!< Return .true. if ELEMENT_NUMBER has a neighbour in FIELD that - !!< is owned by this process otherwise .false. + type(scalar_field), intent(in) :: s_field + integer, intent(in) :: element_number - !! Note, you cannot use this function to compute if - !! ELEMENT_NUMBER is owned. Imagine if this is the only owned - !! element on a process, then none of the neighbours will be owned. - !! You can use this function to compute whether ELEMENT_NUMBER is - !! in the L1 element halo. - type(tensor_field), intent(in) :: field - integer, intent(in) :: element_number - logical :: owned + integer :: owner - owned = element_neighbour_owned(field%mesh, element_number) - end function element_neighbour_owned_tensor + owner = element_owner(s_field%mesh, element_number) - function element_owner_mesh(mesh, element_number) result(owner) - !!< Return number of processor that owns the supplied element in the - !given mesh + end function element_owner_scalar - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: element_number + function element_owner_vector(v_field, element_number) result(owner) + !!< Return the processor that owns the supplied element in the mesh of the given vector + !!< field - integer :: nhalos - integer :: owner + type(vector_field), intent(in) :: v_field + integer, intent(in) :: element_number - assert(element_number > 0) - assert(element_number <= ele_count(mesh)) + integer :: owner - nhalos = element_halo_count(mesh) + owner = element_owner(v_field%mesh, element_number) - if(nhalos == 0) then - owner=getprocno() - else - owner = halo_node_owner(mesh%element_halos(nhalos), element_number) - end if + end function element_owner_vector - end function element_owner_mesh + function element_owner_tensor(t_field, element_number) result(owner) + !!< Return the processor that owns the supplied element in the mesh of the given tensor + !!< field - function element_owner_scalar(s_field, element_number) result(owner) - !!< Return the processor that owns the supplied element in the mesh of the given scalar - !!< field + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: element_number - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: element_number + integer :: owner - integer :: owner + owner = element_owner(t_field%mesh, element_number) - owner = element_owner(s_field%mesh, element_number) + end function element_owner_tensor - end function element_owner_scalar + function assemble_ele_mesh(mesh, ele) result(assemble) + !!< Return whether the supplied element for the supplied mesh should be + !!< assembled. An element need not be assembled if it has no owned nodes. - function element_owner_vector(v_field, element_number) result(owner) - !!< Return the processor that owns the supplied element in the mesh of the given vector - !!< field + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: ele - type(vector_field), intent(in) :: v_field - integer, intent(in) :: element_number + logical :: assemble + + select case(continuity(mesh)) + case(0) + if(associated(mesh%halos)) then + assemble = any(nodes_owned(mesh%halos(1), ele_nodes(mesh, ele))) + else + assemble = .true. + end if + case(-1) + if(associated(mesh%element_halos)) then + assemble = element_owned(mesh, ele) + else + assemble = .true. + end if + case default + ewrite(-1, "(a,i0)") "For mesh continuity", mesh%continuity + FLAbort("Unrecognised mesh continuity") + end select + + end function assemble_ele_mesh + + function assemble_ele_scalar(s_field, ele) result(assemble) + type(scalar_field), intent(in) :: s_field + integer, intent(in) :: ele - integer :: owner + logical :: assemble - owner = element_owner(v_field%mesh, element_number) + assemble = assemble_ele(s_field%mesh, ele) - end function element_owner_vector + end function assemble_ele_scalar - function element_owner_tensor(t_field, element_number) result(owner) - !!< Return the processor that owns the supplied element in the mesh of the given tensor - !!< field + function assemble_ele_vector(v_field, ele) result(assemble) + type(vector_field), intent(in) :: v_field + integer, intent(in) :: ele - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: element_number + logical :: assemble - integer :: owner + assemble = assemble_ele(v_field%mesh, ele) - owner = element_owner(t_field%mesh, element_number) + end function assemble_ele_vector - end function element_owner_tensor + function assemble_ele_tensor(t_field, ele) result(assemble) + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: ele - function assemble_ele_mesh(mesh, ele) result(assemble) - !!< Return whether the supplied element for the supplied mesh should be - !!< assembled. An element need not be assembled if it has no owned nodes. + logical :: assemble - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: ele + assemble = assemble_ele(t_field%mesh, ele) - logical :: assemble + end function assemble_ele_tensor - select case(continuity(mesh)) - case(0) - if(associated(mesh%halos)) then - assemble = any(nodes_owned(mesh%halos(1), ele_nodes(mesh, ele))) - else - assemble = .true. - end if - case(-1) - if(associated(mesh%element_halos)) then - assemble = element_owned(mesh, ele) - else - assemble = .true. - end if - case default - ewrite(-1, "(a,i0)") "For mesh continuity", mesh%continuity - FLAbort("Unrecognised mesh continuity") - end select + function surface_element_owned_mesh(mesh, face_number) result(owned) + !!< Return if the supplied surface element in the given mesh is owned by + !!< this process. - end function assemble_ele_mesh + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face_number - function assemble_ele_scalar(s_field, ele) result(assemble) - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: ele + logical :: owned - logical :: assemble + owned = element_owned(mesh, face_ele(mesh, face_number)) - assemble = assemble_ele(s_field%mesh, ele) + end function surface_element_owned_mesh - end function assemble_ele_scalar + function surface_element_owned_scalar(s_field, face_number) result(owned) + !!< Return if the supplied surface element in the mesh of the given field is + !!< owned by this process. - function assemble_ele_vector(v_field, ele) result(assemble) - type(vector_field), intent(in) :: v_field - integer, intent(in) :: ele + type(scalar_field), intent(in) :: s_field + integer, intent(in) :: face_number - logical :: assemble + logical :: owned - assemble = assemble_ele(v_field%mesh, ele) + owned = surface_element_owned(s_field%mesh, face_number) - end function assemble_ele_vector + end function surface_element_owned_scalar - function assemble_ele_tensor(t_field, ele) result(assemble) - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: ele + function surface_element_owned_vector(v_field, face_number) result(owned) + !!< Return if the supplied surface element in the mesh of the given field is + !!< owned by this process. - logical :: assemble + type(vector_field), intent(in) :: v_field + integer, intent(in) :: face_number - assemble = assemble_ele(t_field%mesh, ele) + logical :: owned - end function assemble_ele_tensor + owned = surface_element_owned(v_field%mesh, face_number) - function surface_element_owned_mesh(mesh, face_number) result(owned) - !!< Return if the supplied surface element in the given mesh is owned by - !!< this process. + end function surface_element_owned_vector - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face_number + function surface_element_owned_tensor(t_field, face_number) result(owned) + !!< Return if the supplied surface element in the mesh of the given field is + !!< owned by this process. - logical :: owned + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: face_number - owned = element_owned(mesh, face_ele(mesh, face_number)) + logical :: owned - end function surface_element_owned_mesh + owned = surface_element_owned(t_field%mesh, face_number) - function surface_element_owned_scalar(s_field, face_number) result(owned) - !!< Return if the supplied surface element in the mesh of the given field is - !!< owned by this process. + end function surface_element_owned_tensor - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: face_number + subroutine zero_non_owned_scalar(field) + !!< Zero all of the entries of field which do not correspond to + !!< that are owned by this process. + !!< + !!< This is useful for where dirty halo data has poluted a field. + type(scalar_field), intent(inout) :: field - logical :: owned + integer :: i + real :: zero - owned = surface_element_owned(s_field%mesh, face_number) + zero=0.0 - end function surface_element_owned_scalar + if (.not.isparallel()) return - function surface_element_owned_vector(v_field, face_number) result(owned) - !!< Return if the supplied surface element in the mesh of the given field is - !!< owned by this process. + if (halo_ordering_scheme(field%mesh%halos(1))& + &==HALO_ORDER_TRAILING_RECEIVES) then + do i = halo_nowned_nodes(field%mesh%halos(1))+1,& + node_count(field) + call set(field, i, zero) + end do + else + do i = 1, node_count(field) + if (.not.node_owned(field, i)) then + call set(field, i, zero) + end if + end do + end if - type(vector_field), intent(in) :: v_field - integer, intent(in) :: face_number + end subroutine zero_non_owned_scalar - logical :: owned + subroutine zero_non_owned_vector(field) + !!< Zero all of the entries of field which do not correspond to + !!< that are owned by this process. + !!< + !!< This is useful for where dirty halo data has poluted a vector field. + type(vector_field), intent(inout) :: field - owned = surface_element_owned(v_field%mesh, face_number) + integer :: i + real, dimension(field%dim) :: zero - end function surface_element_owned_vector + zero=0.0 - function surface_element_owned_tensor(t_field, face_number) result(owned) - !!< Return if the supplied surface element in the mesh of the given field is - !!< owned by this process. + if (.not.isparallel()) return - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: face_number + if (halo_ordering_scheme(field%mesh%halos(1))& + &==HALO_ORDER_TRAILING_RECEIVES) then + do i = halo_nowned_nodes(field%mesh%halos(1))+1,& + node_count(field) + call set(field, i, zero) + end do + else + do i = 1, node_count(field) + if (.not.node_owned(field, i)) then + call set(field, i, zero) + end if + end do + end if - logical :: owned + end subroutine zero_non_owned_vector - owned = surface_element_owned(t_field%mesh, face_number) + function owner_map(model_owner, new_mesh) result (new_owner) + !!< Given a P1 field whose values are the node owners, and a new Pn + !!< mesh, return a field whose values are the new node owners of the Pn + !!< mesh. + type(scalar_field) :: new_owner + type(scalar_field), intent(in) :: model_owner + type(mesh_type), intent(inout) :: new_mesh - end function surface_element_owned_tensor + integer :: face, ele - subroutine zero_non_owned_scalar(field) - !!< Zero all of the entries of field which do not correspond to - !!< that are owned by this process. - !!< - !!< This is useful for where dirty halo data has poluted a field. - type(scalar_field), intent(inout) :: field + call allocate(new_owner, new_mesh, trim(new_mesh%name)//"OwnerMap") + call zero(new_owner) - integer :: i - real :: zero + do face=1,face_count(new_mesh) + call create_owner_map_face(model_owner, new_owner, face) + end do - zero=0.0 + do ele=1,element_count(new_mesh) + call create_owner_map_ele(model_owner, new_owner, ele) + end do - if (.not.isparallel()) return + contains - if (halo_ordering_scheme(field%mesh%halos(1))& - &==HALO_ORDER_TRAILING_RECEIVES) then - do i = halo_nowned_nodes(field%mesh%halos(1))+1,& - node_count(field) - call set(field, i, zero) - end do - else - do i = 1, node_count(field) - if (.not.node_owned(field, i)) then - call set(field, i, zero) - end if - end do - end if - - end subroutine zero_non_owned_scalar - - subroutine zero_non_owned_vector(field) - !!< Zero all of the entries of field which do not correspond to - !!< that are owned by this process. - !!< - !!< This is useful for where dirty halo data has poluted a vector field. - type(vector_field), intent(inout) :: field - - integer :: i - real, dimension(field%dim) :: zero - - zero=0.0 - - if (.not.isparallel()) return - - if (halo_ordering_scheme(field%mesh%halos(1))& - &==HALO_ORDER_TRAILING_RECEIVES) then - do i = halo_nowned_nodes(field%mesh%halos(1))+1,& - node_count(field) - call set(field, i, zero) - end do - else - do i = 1, node_count(field) - if (.not.node_owned(field, i)) then - call set(field, i, zero) - end if - end do - end if - - end subroutine zero_non_owned_vector - - function owner_map(model_owner, new_mesh) result (new_owner) - !!< Given a P1 field whose values are the node owners, and a new Pn - !!< mesh, return a field whose values are the new node owners of the Pn - !!< mesh. - type(scalar_field) :: new_owner - type(scalar_field), intent(in) :: model_owner - type(mesh_type), intent(inout) :: new_mesh - - integer :: face, ele - - call allocate(new_owner, new_mesh, trim(new_mesh%name)//"OwnerMap") - call zero(new_owner) - - do face=1,face_count(new_mesh) - call create_owner_map_face(model_owner, new_owner, face) - end do - - do ele=1,element_count(new_mesh) - call create_owner_map_ele(model_owner, new_owner, ele) - end do - - contains - - subroutine create_owner_map_face(model_owner, new_owner, face) - type(scalar_field), intent(in) :: model_owner - type(scalar_field), intent(inout) :: new_owner - ! Global face number. - integer, intent(in) :: face + subroutine create_owner_map_face(model_owner, new_owner, face) + type(scalar_field), intent(in) :: model_owner + type(scalar_field), intent(inout) :: new_owner + ! Global face number. + integer, intent(in) :: face - type(element_type), pointer :: model_shape, new_shape - real, dimension(face_loc(new_owner, face)) :: new_node_owner - real, dimension(face_loc(model_owner, face)) :: model_node_owner - real :: face_owner + type(element_type), pointer :: model_shape, new_shape + real, dimension(face_loc(new_owner, face)) :: new_node_owner + real, dimension(face_loc(model_owner, face)) :: model_node_owner + real :: face_owner - new_node_owner=face_val(new_owner, face) + new_node_owner=face_val(new_owner, face) - ! Quick bit of premature optimisation. - if (all(new_node_owner/=0)) return + ! Quick bit of premature optimisation. + if (all(new_node_owner/=0)) return - model_shape=>face_shape(model_owner, face) - new_shape=>face_shape(new_owner, face) - model_node_owner=face_val(model_owner, face) + model_shape=>face_shape(model_owner, face) + new_shape=>face_shape(new_owner, face) + model_node_owner=face_val(model_owner, face) - ! The vertices all belong to the owners of the - ! corresponding vertices in the model. - new_node_owner(local_vertices(new_shape))=model_node_owner + ! The vertices all belong to the owners of the + ! corresponding vertices in the model. + new_node_owner(local_vertices(new_shape))=model_node_owner - ! In 3D the face elements have edges which have to be dealt with - ! separately. - if (mesh_dim(model_owner)>2) then - call create_owner_map_edge(new_node_owner, & - & new_shape) - end if + ! In 3D the face elements have edges which have to be dealt with + ! separately. + if (mesh_dim(model_owner)>2) then + call create_owner_map_edge(new_node_owner, & + & new_shape) + end if - ! Any remaining nodes are interior to the face and - ! belong to the face_owner element owner. + ! Any remaining nodes are interior to the face and + ! belong to the face_owner element owner. - face_owner=minval(model_node_owner) + face_owner=minval(model_node_owner) - where(new_node_owner==0) - new_node_owner=face_owner - end where + where(new_node_owner==0) + new_node_owner=face_owner + end where - call set(new_owner, ele_nodes(new_owner, ele), new_node_owner) + call set(new_owner, ele_nodes(new_owner, ele), new_node_owner) - end subroutine create_owner_map_face + end subroutine create_owner_map_face - subroutine create_owner_map_edge(new_node_owner, & - & new_shape) - ! Numbering on the edge. - real, dimension(:), intent(inout) :: new_node_owner - type(element_type), intent(in) :: new_shape + subroutine create_owner_map_edge(new_node_owner, & + & new_shape) + ! Numbering on the edge. + real, dimension(:), intent(inout) :: new_node_owner + type(element_type), intent(in) :: new_shape - ! Local edge number. - integer :: edge - real :: edge_owner + ! Local edge number. + integer :: edge + real :: edge_owner - ! Interval elements always have degree+1 nodes. - integer, dimension(new_shape%degree+1) :: edge_numbering + ! Interval elements always have degree+1 nodes. + integer, dimension(new_shape%degree+1) :: edge_numbering - do edge=1,new_shape%numbering%boundaries - edge_numbering=boundary_numbering(new_shape, edge) + do edge=1,new_shape%numbering%boundaries + edge_numbering=boundary_numbering(new_shape, edge) - edge_owner=min(new_node_owner(edge_numbering(1)), & - new_node_owner(edge_numbering(size(edge_numbering)))) + edge_owner=min(new_node_owner(edge_numbering(1)), & + new_node_owner(edge_numbering(size(edge_numbering)))) - new_node_owner(edge_numbering(2:size(edge_numbering)-1))& - &=edge_owner + new_node_owner(edge_numbering(2:size(edge_numbering)-1))& + &=edge_owner - end do + end do - end subroutine create_owner_map_edge + end subroutine create_owner_map_edge - subroutine create_owner_map_ele(model_owner, new_owner, ele) - ! Any remaining nodes are interior to elements and belong to the - ! element owner. - type(scalar_field), intent(in) :: model_owner - type(scalar_field), intent(inout) :: new_owner - integer, intent(in) :: ele + subroutine create_owner_map_ele(model_owner, new_owner, ele) + ! Any remaining nodes are interior to elements and belong to the + ! element owner. + type(scalar_field), intent(in) :: model_owner + type(scalar_field), intent(inout) :: new_owner + integer, intent(in) :: ele - real, dimension(ele_loc(new_owner, ele)) :: new_node_owner - real :: element_owner + real, dimension(ele_loc(new_owner, ele)) :: new_node_owner + real :: element_owner - new_node_owner=ele_val(new_owner, ele) + new_node_owner=ele_val(new_owner, ele) - ! Quick bit of premature optimisation. - if (all(new_node_owner/=0)) return + ! Quick bit of premature optimisation. + if (all(new_node_owner/=0)) return - element_owner=minval(ele_val(model_owner,ele)) + element_owner=minval(ele_val(model_owner,ele)) - where(new_node_owner==0) - new_node_owner=element_owner - end where + where(new_node_owner==0) + new_node_owner=element_owner + end where - call set(new_owner, ele_nodes(new_owner, ele), new_node_owner) + call set(new_owner, ele_nodes(new_owner, ele), new_node_owner) - end subroutine create_owner_map_ele + end subroutine create_owner_map_ele - end function owner_map + end function owner_map - pure function nowned_nodes_mesh(mesh) result(nodes) - type(mesh_type), intent(in) :: mesh + pure function nowned_nodes_mesh(mesh) result(nodes) + type(mesh_type), intent(in) :: mesh - integer :: nodes + integer :: nodes - integer :: nhalos + integer :: nhalos - nhalos = halo_count(mesh) - if(nhalos > 0) then - nodes = halo_nowned_nodes(mesh%halos(nhalos)) - else - nodes = node_count(mesh) - end if + nhalos = halo_count(mesh) + if(nhalos > 0) then + nodes = halo_nowned_nodes(mesh%halos(nhalos)) + else + nodes = node_count(mesh) + end if - end function nowned_nodes_mesh + end function nowned_nodes_mesh - pure function nowned_nodes_scalar(s_field) result(nodes) - type(scalar_field), intent(in) :: s_field + pure function nowned_nodes_scalar(s_field) result(nodes) + type(scalar_field), intent(in) :: s_field - integer :: nodes + integer :: nodes - nodes = nowned_nodes(s_field%mesh) + nodes = nowned_nodes(s_field%mesh) - end function nowned_nodes_scalar + end function nowned_nodes_scalar - pure function nowned_nodes_vector(v_field) result(nodes) - type(vector_field), intent(in) :: v_field + pure function nowned_nodes_vector(v_field) result(nodes) + type(vector_field), intent(in) :: v_field - integer :: nodes + integer :: nodes - nodes = nowned_nodes(v_field%mesh) + nodes = nowned_nodes(v_field%mesh) - end function nowned_nodes_vector + end function nowned_nodes_vector - pure function nowned_nodes_tensor(t_field) result(nodes) - type(tensor_field), intent(in) :: t_field + pure function nowned_nodes_tensor(t_field) result(nodes) + type(tensor_field), intent(in) :: t_field - integer :: nodes + integer :: nodes - nodes = nowned_nodes(t_field%mesh) + nodes = nowned_nodes(t_field%mesh) - end function nowned_nodes_tensor + end function nowned_nodes_tensor end module parallel_fields diff --git a/femtools/Particles.F90 b/femtools/Particles.F90 index 947c32267e..d83d9c3987 100644 --- a/femtools/Particles.F90 +++ b/femtools/Particles.F90 @@ -27,2219 +27,2219 @@ #include "fdebug.h" module particles - use fldebug - use iso_c_binding, only: C_NULL_CHAR, c_ptr, c_f_pointer - use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN, & -& PYTHON_FUNC_LEN, integer_size, real_size, is_active_process - use futils, only: int2str, free_unit - use elements - use mpi_interfaces - use parallel_tools - use spud - use embed_python, only: set_detectors_from_python, deallocate_c_array - use parallel_fields - use fields - use profiler - use state_module - use field_options - use detector_data_types - use pickers - use detector_tools - use detector_parallel - use detector_move_lagrangian - use time_period - use h5hut - - implicit none - - private - - public :: initialise_particles, move_particles, write_particles_loop, destroy_particles, & - update_particle_attributes_and_fields, checkpoint_particles_loop, & - get_particle_arrays, particle_lists, initialise_constant_particle_attributes, & - initialise_particles_during_simulation - - - ! One particle list for each subgroup - type(detector_linked_list), allocatable, dimension(:), target, save :: particle_lists - ! Timing info for group output - type(time_period_type), allocatable, dimension(:), save :: output_CS - - !> Derived type to hold the number of scalar, vector and tensor attributes, - !! old attributes and old fields for a particle subgroup - type attr_counts_type - integer, dimension(3) :: attrs, old_attrs, old_fields - end type attr_counts_type - - !> Derived type to hold scalar, vector and tensor attributes - type attr_vals_type - real, dimension(:), allocatable :: s - real, dimension(:,:), allocatable :: v - real, dimension(:,:,:), allocatable :: t - end type attr_vals_type - - interface allocate - module procedure allocate_attr_vals - end interface allocate - - interface deallocate - module procedure deallocate_attr_vals - end interface deallocate + use fldebug + use iso_c_binding, only: C_NULL_CHAR, c_ptr, c_f_pointer + use global_parameters, only:FIELD_NAME_LEN,OPTION_PATH_LEN, & + & PYTHON_FUNC_LEN, integer_size, real_size, is_active_process + use futils, only: int2str, free_unit + use elements + use mpi_interfaces + use parallel_tools + use spud + use embed_python, only: set_detectors_from_python, deallocate_c_array + use parallel_fields + use fields + use profiler + use state_module + use field_options + use detector_data_types + use pickers + use detector_tools + use detector_parallel + use detector_move_lagrangian + use time_period + use h5hut + + implicit none + + private + + public :: initialise_particles, move_particles, write_particles_loop, destroy_particles, & + update_particle_attributes_and_fields, checkpoint_particles_loop, & + get_particle_arrays, particle_lists, initialise_constant_particle_attributes, & + initialise_particles_during_simulation + + + ! One particle list for each subgroup + type(detector_linked_list), allocatable, dimension(:), target, save :: particle_lists + ! Timing info for group output + type(time_period_type), allocatable, dimension(:), save :: output_CS + + !> Derived type to hold the number of scalar, vector and tensor attributes, + !! old attributes and old fields for a particle subgroup + type attr_counts_type + integer, dimension(3) :: attrs, old_attrs, old_fields + end type attr_counts_type + + !> Derived type to hold scalar, vector and tensor attributes + type attr_vals_type + real, dimension(:), allocatable :: s + real, dimension(:,:), allocatable :: v + real, dimension(:,:,:), allocatable :: t + end type attr_vals_type + + interface allocate + module procedure allocate_attr_vals + end interface allocate + + interface deallocate + module procedure deallocate_attr_vals + end interface deallocate contains - !> Allocate an attr_vals_type structure, with the given number - !! of scalar, vector and tensor attributes, and the geometric dimension - !! of the problem. - subroutine allocate_attr_vals(vals, dim, counts) - !> Structure to allocate - type(attr_vals_type), pointer :: vals - !> Geometric dimension - integer, intent(in) :: dim - !> Counts of each rank of attribute - integer, dimension(3), intent(in) :: counts - - allocate(vals) - allocate(vals%s(counts(1))) - allocate(vals%v(dim, counts(2))) - allocate(vals%t(dim, dim, counts(3))) - end subroutine allocate_attr_vals - - !> Deallocate an attr_vals_type structure - subroutine deallocate_attr_vals(vals) - type(attr_vals_type), pointer :: vals - - deallocate(vals%s) - deallocate(vals%v) - deallocate(vals%t) - deallocate(vals) - end subroutine deallocate_attr_vals - - !> Initialise particles and set up particle file headers (per particle array) - subroutine initialise_particles(filename, state, global, setup_output, ignore_analytical, number_of_partitions) - !> Experiment filename to prefix particle output files - character(len=*), intent(in) :: filename - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Use global/parallel picker queries to determine particle elements? - logical, intent(in), optional :: global - !> Whether to set up output files for particle lists - logical, intent(in), optional :: setup_output - !> Whether to ignore analytical particles (i.e. not from file) - logical, intent(in), optional :: ignore_analytical - !> Number of processes to use for reading particle data - integer, intent(in), optional :: number_of_partitions - - character(len=FIELD_NAME_LEN) :: subname - character(len=OPTION_PATH_LEN) :: group_path, subgroup_path - - type(vector_field), pointer :: xfield - real :: current_time - - integer :: sub_particles - integer :: i, j, k - integer :: dim, particle_groups, total_arrays, list_counter - integer, dimension(:), allocatable :: particle_arrays - integer :: totaldet_global - logical :: from_file, do_output, do_analytical, store_old_fields - integer :: n_fields, n_oldfields - integer :: s_field, v_field, t_field ! field index variables - integer :: s_oldfield, v_oldfield, t_oldfield - integer, dimension(3) :: field_counts, old_field_counts - type(attr_names_type) :: attr_names, old_attr_names, field_names, old_field_names - type(attr_write_type) :: attr_write - type(attr_counts_type) :: attr_counts - type(field_phase_type) :: field_phases, old_field_phases - - ! field pointers to get their names, for old_field_names - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - - character(len=*), dimension(3), parameter :: orders = ["scalar", "vector", "tensor"] - character(len=*), dimension(3), parameter :: types = ["prescribed", "diagnostic", "prognostic"] - - ewrite(2,*) "In initialise_particles" - - do_output = .true. - if (present(setup_output)) do_output = setup_output - do_analytical = .true. - if (present(ignore_analytical)) do_analytical = .not. ignore_analytical - - ! Check whether there are any particle groups to initialise - particle_groups = option_count("/particles/particle_group") - if (particle_groups == 0) return - - ! Set up particle lists - allocate(particle_arrays(particle_groups)) - allocate(output_CS(particle_groups)) - - total_arrays = 0 - do i = 1, particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - - call init_output_CS(output_CS(i), trim(group_path) // "/particle_io") - - ! count subgroups for this group - particle_arrays(i) = option_count(trim(group_path) // "/particle_subgroup") - total_arrays = total_arrays + particle_arrays(i) - end do - allocate(particle_lists(total_arrays)) - - ! Allocate parameters from the coordinate field - xfield => extract_vector_field(state(1), "Coordinate") - call get_option("/geometry/dimension", dim) - call get_option("/timestepping/current_time", current_time) - - ! calculate the number of fields and old fields that would have to be stored - ! (each combination of field order and field type) - field_counts(:) = 0 - old_field_counts(:) = 0 - do i = 1, 3 - do j = 1, 3 - field_counts(i) = field_counts(i) + & - option_count("/material_phase/"//orders(i)//"_field/"//types(j)//"/particles/include_in_particles") - old_field_counts(i) = old_field_counts(i) + & - option_count("/material_phase/"//orders(i)//"_field/"//types(j)//"/particles/include_in_particles/store_old_field") + !> Allocate an attr_vals_type structure, with the given number + !! of scalar, vector and tensor attributes, and the geometric dimension + !! of the problem. + subroutine allocate_attr_vals(vals, dim, counts) + !> Structure to allocate + type(attr_vals_type), pointer :: vals + !> Geometric dimension + integer, intent(in) :: dim + !> Counts of each rank of attribute + integer, dimension(3), intent(in) :: counts + + allocate(vals) + allocate(vals%s(counts(1))) + allocate(vals%v(dim, counts(2))) + allocate(vals%t(dim, dim, counts(3))) + end subroutine allocate_attr_vals + + !> Deallocate an attr_vals_type structure + subroutine deallocate_attr_vals(vals) + type(attr_vals_type), pointer :: vals + + deallocate(vals%s) + deallocate(vals%v) + deallocate(vals%t) + deallocate(vals) + end subroutine deallocate_attr_vals + + !> Initialise particles and set up particle file headers (per particle array) + subroutine initialise_particles(filename, state, global, setup_output, ignore_analytical, number_of_partitions) + !> Experiment filename to prefix particle output files + character(len=*), intent(in) :: filename + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Use global/parallel picker queries to determine particle elements? + logical, intent(in), optional :: global + !> Whether to set up output files for particle lists + logical, intent(in), optional :: setup_output + !> Whether to ignore analytical particles (i.e. not from file) + logical, intent(in), optional :: ignore_analytical + !> Number of processes to use for reading particle data + integer, intent(in), optional :: number_of_partitions + + character(len=FIELD_NAME_LEN) :: subname + character(len=OPTION_PATH_LEN) :: group_path, subgroup_path + + type(vector_field), pointer :: xfield + real :: current_time + + integer :: sub_particles + integer :: i, j, k + integer :: dim, particle_groups, total_arrays, list_counter + integer, dimension(:), allocatable :: particle_arrays + integer :: totaldet_global + logical :: from_file, do_output, do_analytical, store_old_fields + integer :: n_fields, n_oldfields + integer :: s_field, v_field, t_field ! field index variables + integer :: s_oldfield, v_oldfield, t_oldfield + integer, dimension(3) :: field_counts, old_field_counts + type(attr_names_type) :: attr_names, old_attr_names, field_names, old_field_names + type(attr_write_type) :: attr_write + type(attr_counts_type) :: attr_counts + type(field_phase_type) :: field_phases, old_field_phases + + ! field pointers to get their names, for old_field_names + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + + character(len=*), dimension(3), parameter :: orders = ["scalar", "vector", "tensor"] + character(len=*), dimension(3), parameter :: types = ["prescribed", "diagnostic", "prognostic"] + + ewrite(2,*) "In initialise_particles" + + do_output = .true. + if (present(setup_output)) do_output = setup_output + do_analytical = .true. + if (present(ignore_analytical)) do_analytical = .not. ignore_analytical + + ! Check whether there are any particle groups to initialise + particle_groups = option_count("/particles/particle_group") + if (particle_groups == 0) return + + ! Set up particle lists + allocate(particle_arrays(particle_groups)) + allocate(output_CS(particle_groups)) + + total_arrays = 0 + do i = 1, particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + + call init_output_CS(output_CS(i), trim(group_path) // "/particle_io") + + ! count subgroups for this group + particle_arrays(i) = option_count(trim(group_path) // "/particle_subgroup") + total_arrays = total_arrays + particle_arrays(i) end do - end do - n_fields = sum(field_counts) - n_oldfields = sum(old_field_counts) - - ! allocate arrays to hold field names - call allocate(field_names, field_counts) - call allocate(old_field_names, old_field_counts) - ! allocate arrays to hold field phases - call allocate(field_phases, field_counts) - call allocate(old_field_phases, old_field_counts) - - ! read the names of the fields if there are any - ! this is both for fields that should be included in particles, and that - ! should have their old values available to particles too - s_field = 0 - v_field = 0 - t_field = 0 - s_oldfield = 0 - v_oldfield = 0 - t_oldfield = 0 - do i = 1, size(state) - if (field_counts(1) > 0) then - do j = 1, size(state(i)%scalar_names) - sfield => extract_scalar_field(state(i), state(i)%scalar_names(j)) - if (sfield%option_path == "" .or. aliased(sfield)) then - cycle - else if (have_option(trim(complete_field_path(sfield%option_path)) // "/particles/include_in_particles")) then - s_field = s_field + 1 - field_names%s(s_field) = state(i)%scalar_names(j) - field_phases%s(s_field) = i - - if (have_option(trim(complete_field_path(sfield%option_path)) // "/particles/include_in_particles/store_old_field")) then - s_oldfield = s_oldfield + 1 - old_field_names%s(s_oldfield) = state(i)%scalar_names(j) - old_field_phases%s(s_oldfield) = i - end if - end if - end do - end if + allocate(particle_lists(total_arrays)) + + ! Allocate parameters from the coordinate field + xfield => extract_vector_field(state(1), "Coordinate") + call get_option("/geometry/dimension", dim) + call get_option("/timestepping/current_time", current_time) + + ! calculate the number of fields and old fields that would have to be stored + ! (each combination of field order and field type) + field_counts(:) = 0 + old_field_counts(:) = 0 + do i = 1, 3 + do j = 1, 3 + field_counts(i) = field_counts(i) + & + option_count("/material_phase/"//orders(i)//"_field/"//types(j)//"/particles/include_in_particles") + old_field_counts(i) = old_field_counts(i) + & + option_count("/material_phase/"//orders(i)//"_field/"//types(j)//"/particles/include_in_particles/store_old_field") + end do + end do + n_fields = sum(field_counts) + n_oldfields = sum(old_field_counts) + + ! allocate arrays to hold field names + call allocate(field_names, field_counts) + call allocate(old_field_names, old_field_counts) + ! allocate arrays to hold field phases + call allocate(field_phases, field_counts) + call allocate(old_field_phases, old_field_counts) + + ! read the names of the fields if there are any + ! this is both for fields that should be included in particles, and that + ! should have their old values available to particles too + s_field = 0 + v_field = 0 + t_field = 0 + s_oldfield = 0 + v_oldfield = 0 + t_oldfield = 0 + do i = 1, size(state) + if (field_counts(1) > 0) then + do j = 1, size(state(i)%scalar_names) + sfield => extract_scalar_field(state(i), state(i)%scalar_names(j)) + if (sfield%option_path == "" .or. aliased(sfield)) then + cycle + else if (have_option(trim(complete_field_path(sfield%option_path)) // "/particles/include_in_particles")) then + s_field = s_field + 1 + field_names%s(s_field) = state(i)%scalar_names(j) + field_phases%s(s_field) = i + + if (have_option(trim(complete_field_path(sfield%option_path)) // "/particles/include_in_particles/store_old_field")) then + s_oldfield = s_oldfield + 1 + old_field_names%s(s_oldfield) = state(i)%scalar_names(j) + old_field_phases%s(s_oldfield) = i + end if + end if + end do + end if - if (field_counts(2) > 0) then - do j = 1, size(state(i)%vector_names) - vfield => extract_vector_field(state(i), state(i)%vector_names(j)) - if (vfield%option_path == "" .or. aliased(vfield)) then - cycle - else if (have_option(trim(complete_field_path(vfield%option_path)) // "/particles/include_in_particles")) then - v_field = v_field + 1 - field_names%v(v_field) = state(i)%vector_names(j) - field_phases%v(v_field) = i - - if (have_option(trim(complete_field_path(vfield%option_path)) // "/particles/include_in_particles/store_old_field")) then - v_oldfield = v_oldfield + 1 - old_field_names%v(v_oldfield) = state(i)%vector_names(j) - old_field_phases%v(v_oldfield) = i - end if - end if - end do - end if + if (field_counts(2) > 0) then + do j = 1, size(state(i)%vector_names) + vfield => extract_vector_field(state(i), state(i)%vector_names(j)) + if (vfield%option_path == "" .or. aliased(vfield)) then + cycle + else if (have_option(trim(complete_field_path(vfield%option_path)) // "/particles/include_in_particles")) then + v_field = v_field + 1 + field_names%v(v_field) = state(i)%vector_names(j) + field_phases%v(v_field) = i + + if (have_option(trim(complete_field_path(vfield%option_path)) // "/particles/include_in_particles/store_old_field")) then + v_oldfield = v_oldfield + 1 + old_field_names%v(v_oldfield) = state(i)%vector_names(j) + old_field_phases%v(v_oldfield) = i + end if + end if + end do + end if - if (field_counts(3) > 0) then - do j = 1, size(state(i)%tensor_names) - tfield => extract_tensor_field(state(i), state(i)%tensor_names(j)) - if (tfield%option_path == "" .or. aliased(tfield)) then - cycle - else if (have_option(trim(complete_field_path(tfield%option_path)) // "/particles/include_in_particles")) then - t_field = t_field + 1 - field_names%t(t_field) = state(i)%tensor_names(j) - field_phases%t(t_field) = i - - if (have_option(trim(complete_field_path(tfield%option_path)) // "/particles/include_in_particles/store_old_field")) then - t_oldfield = t_oldfield + 1 - old_field_names%t(t_oldfield) = state(i)%tensor_names(j) - old_field_phases%t(t_oldfield) = i - end if - end if - end do - end if - end do - assert(s_field + v_field + t_field == n_fields) - assert(s_oldfield + v_oldfield + t_oldfield == n_oldfields) + if (field_counts(3) > 0) then + do j = 1, size(state(i)%tensor_names) + tfield => extract_tensor_field(state(i), state(i)%tensor_names(j)) + if (tfield%option_path == "" .or. aliased(tfield)) then + cycle + else if (have_option(trim(complete_field_path(tfield%option_path)) // "/particles/include_in_particles")) then + t_field = t_field + 1 + field_names%t(t_field) = state(i)%tensor_names(j) + field_phases%t(t_field) = i + + if (have_option(trim(complete_field_path(tfield%option_path)) // "/particles/include_in_particles/store_old_field")) then + t_oldfield = t_oldfield + 1 + old_field_names%t(t_oldfield) = state(i)%tensor_names(j) + old_field_phases%t(t_oldfield) = i + end if + end if + end do + end if + end do + assert(s_field + v_field + t_field == n_fields) + assert(s_oldfield + v_oldfield + t_oldfield == n_oldfields) - list_counter = 1 - do i = 1,particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" + list_counter = 1 + do i = 1,particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" - do k = 1, particle_arrays(i) - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" + do k = 1, particle_arrays(i) + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" - ! If the option "from_file" exists, it means we are - ! continuing the simulation after checkpointing and the - ! reading of the particle positions must be done from a file - from_file = have_option(trim(subgroup_path) // "/initial_position/from_file") + ! If the option "from_file" exists, it means we are + ! continuing the simulation after checkpointing and the + ! reading of the particle positions must be done from a file + from_file = have_option(trim(subgroup_path) // "/initial_position/from_file") - ! But if we're flredecomping, we don't want to handle - ! particles with analytically-specified positions (i.e. not - ! from a file) - if (.not. do_analytical .and. .not. from_file) cycle + ! But if we're flredecomping, we don't want to handle + ! particles with analytically-specified positions (i.e. not + ! from a file) + if (.not. do_analytical .and. .not. from_file) cycle - ! Set up the particle list structure - call get_option(trim(subgroup_path) // "/name", subname) + ! Set up the particle list structure + call get_option(trim(subgroup_path) // "/name", subname) - ! Register this I/O list with a global list of detectors/particles - call register_detector_list(particle_lists(list_counter)) + ! Register this I/O list with a global list of detectors/particles + call register_detector_list(particle_lists(list_counter)) - !Set list id - particle_lists(list_counter)%id = list_counter + !Set list id + particle_lists(list_counter)%id = list_counter - ! Find number of attributes, old attributes, and names of each - call attr_names_and_count(trim(subgroup_path) // "/attributes/scalar_attribute", & + ! Find number of attributes, old attributes, and names of each + call attr_names_and_count(trim(subgroup_path) // "/attributes/scalar_attribute", & attr_names%s, old_attr_names%s, attr_names%sn, old_attr_names%sn, attr_write%s, & attr_counts%attrs(1), attr_counts%old_attrs(1)) - call attr_names_and_count(trim(subgroup_path) // "/attributes/vector_attribute", & + call attr_names_and_count(trim(subgroup_path) // "/attributes/vector_attribute", & attr_names%v, old_attr_names%v, attr_names%vn, old_attr_names%vn, attr_write%v, & attr_counts%attrs(2), attr_counts%old_attrs(2)) - call attr_names_and_count(trim(subgroup_path) // "/attributes/tensor_attribute", & + call attr_names_and_count(trim(subgroup_path) // "/attributes/tensor_attribute", & attr_names%t, old_attr_names%t, attr_names%tn, old_attr_names%tn, attr_write%t, & attr_counts%attrs(3), attr_counts%old_attrs(3)) - ! save names in the detector list -- this will allocate and assign values - ! as expected - particle_lists(list_counter)%attr_names = attr_names - particle_lists(list_counter)%old_attr_names = old_attr_names - particle_lists(list_counter)%attr_write = attr_write - - ! If any attributes are from fields, we'll need to store old fields too - store_old_fields = .false. - if (option_count(trim(subgroup_path) // "/attributes/scalar_attribute/python_fields") > 0 .or. & - option_count(trim(subgroup_path) // "/attributes/scalar_attribute_array/python_fields") > 0 .or. & - option_count(trim(subgroup_path) // "/attributes/vector_attribute/python_fields") > 0 .or. & - option_count(trim(subgroup_path) // "/attributes/vector_attribute_array/python_fields") > 0 .or. & - option_count(trim(subgroup_path) // "/attributes/tensor_attribute/python_fields") > 0 .or. & - option_count(trim(subgroup_path) // "/attributes/tensor_attribute_array/python_fields") > 0) then - store_old_fields = .true. - end if - - if (store_old_fields) then - attr_counts%old_fields(:) = old_field_counts(:) - ! only copy old field names if they're required - particle_lists(list_counter)%field_names = field_names - particle_lists(list_counter)%old_field_names = old_field_names - - ! and the field phases so we can look them up later - particle_lists(list_counter)%field_phases = field_phases - particle_lists(list_counter)%old_field_phases = old_field_phases - else - attr_counts%old_fields(:) = 0 - - ! allocate empty arrays for names and phases - call allocate(particle_lists(list_counter)%field_names, [0, 0, 0]) - call allocate(particle_lists(list_counter)%old_field_names, [0, 0, 0]) - call allocate(particle_lists(list_counter)%field_phases, [0, 0, 0]) - call allocate(particle_lists(list_counter)%old_field_phases, [0, 0, 0]) - end if - - ! assign the total number of list slices for each kind of attribute - ! this is used mostly for transferring detectors across processes - particle_lists(list_counter)%total_attributes(1) = & + ! save names in the detector list -- this will allocate and assign values + ! as expected + particle_lists(list_counter)%attr_names = attr_names + particle_lists(list_counter)%old_attr_names = old_attr_names + particle_lists(list_counter)%attr_write = attr_write + + ! If any attributes are from fields, we'll need to store old fields too + store_old_fields = .false. + if (option_count(trim(subgroup_path) // "/attributes/scalar_attribute/python_fields") > 0 .or. & + option_count(trim(subgroup_path) // "/attributes/scalar_attribute_array/python_fields") > 0 .or. & + option_count(trim(subgroup_path) // "/attributes/vector_attribute/python_fields") > 0 .or. & + option_count(trim(subgroup_path) // "/attributes/vector_attribute_array/python_fields") > 0 .or. & + option_count(trim(subgroup_path) // "/attributes/tensor_attribute/python_fields") > 0 .or. & + option_count(trim(subgroup_path) // "/attributes/tensor_attribute_array/python_fields") > 0) then + store_old_fields = .true. + end if + + if (store_old_fields) then + attr_counts%old_fields(:) = old_field_counts(:) + ! only copy old field names if they're required + particle_lists(list_counter)%field_names = field_names + particle_lists(list_counter)%old_field_names = old_field_names + + ! and the field phases so we can look them up later + particle_lists(list_counter)%field_phases = field_phases + particle_lists(list_counter)%old_field_phases = old_field_phases + else + attr_counts%old_fields(:) = 0 + + ! allocate empty arrays for names and phases + call allocate(particle_lists(list_counter)%field_names, [0, 0, 0]) + call allocate(particle_lists(list_counter)%old_field_names, [0, 0, 0]) + call allocate(particle_lists(list_counter)%field_phases, [0, 0, 0]) + call allocate(particle_lists(list_counter)%old_field_phases, [0, 0, 0]) + end if + + ! assign the total number of list slices for each kind of attribute + ! this is used mostly for transferring detectors across processes + particle_lists(list_counter)%total_attributes(1) = & total_attributes(attr_counts%attrs, dim) - particle_lists(list_counter)%total_attributes(2) = & + particle_lists(list_counter)%total_attributes(2) = & total_attributes(attr_counts%old_attrs, dim) - particle_lists(list_counter)%total_attributes(3) = & + particle_lists(list_counter)%total_attributes(3) = & total_attributes(attr_counts%old_fields, dim) - ! Enable particles to drift with the mesh - if (have_option("/particles/move_with_mesh")) then - particle_lists(list_counter)%move_with_mesh = .true. - end if - - if (is_active_process) then - ! Read particles from options -- only if this process is currently active (as defined in flredecomp) - if (from_file) then - call get_option(trim(subgroup_path) // "/initial_position/from_file/number_of_particles", sub_particles) - call read_particles_from_file(sub_particles, subname, subgroup_path, & - particle_lists(list_counter), xfield, dim, & - attr_counts, attr_names, old_attr_names, old_field_names, & - number_of_partitions) - else - call read_particles_from_python(subname, subgroup_path, & - particle_lists(list_counter), xfield, dim, & - current_time, state, attr_counts, global, sub_particles) + ! Enable particles to drift with the mesh + if (have_option("/particles/move_with_mesh")) then + particle_lists(list_counter)%move_with_mesh = .true. end if - end if - - particle_lists(list_counter)%total_num_det = sub_particles - - if (do_output) then - ! Only set up output if we need to (i.e. actually running, - ! not flredecomping) - call set_particle_output_file(subname, filename, & - particle_lists(list_counter)) - end if - - ! Get options for lagrangian particle movement - call read_detector_move_options(particle_lists(list_counter), "/particles") - - ! Make sure to deallocate attribute names before moving on - call deallocate(attr_names) - call deallocate(old_attr_names) - - list_counter = list_counter + 1 - end do - end do - - ! And finally some sanity checks - list_counter=1 - do i = 1,particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - do k = 1,particle_arrays(i) - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" - call get_option(trim(subgroup_path)//"/name",subname) - totaldet_global=particle_lists(list_counter)%length - call allsum(totaldet_global) - ewrite(2,*) "Found", particle_lists(list_counter)%length, "local and ", totaldet_global, "global particles for particle array ", trim(subname) - - assert(totaldet_global==particle_lists(list_counter)%total_num_det) - list_counter = list_counter + 1 + + if (is_active_process) then + ! Read particles from options -- only if this process is currently active (as defined in flredecomp) + if (from_file) then + call get_option(trim(subgroup_path) // "/initial_position/from_file/number_of_particles", sub_particles) + call read_particles_from_file(sub_particles, subname, subgroup_path, & + particle_lists(list_counter), xfield, dim, & + attr_counts, attr_names, old_attr_names, old_field_names, & + number_of_partitions) + else + call read_particles_from_python(subname, subgroup_path, & + particle_lists(list_counter), xfield, dim, & + current_time, state, attr_counts, global, sub_particles) + end if + end if + + particle_lists(list_counter)%total_num_det = sub_particles + + if (do_output) then + ! Only set up output if we need to (i.e. actually running, + ! not flredecomping) + call set_particle_output_file(subname, filename, & + particle_lists(list_counter)) + end if + + ! Get options for lagrangian particle movement + call read_detector_move_options(particle_lists(list_counter), "/particles") + + ! Make sure to deallocate attribute names before moving on + call deallocate(attr_names) + call deallocate(old_attr_names) + + list_counter = list_counter + 1 + end do end do - end do - - deallocate(particle_arrays) - call deallocate(field_names) - call deallocate(old_field_names) - end subroutine initialise_particles - - !> Initialise particles for times greater than 0 - subroutine initialise_particles_during_simulation(state, current_time) - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Current simulation time - real, intent(in) :: current_time - - integer :: i, k, j, dim, id_number - integer :: particle_groups, particle_subgroups, list_counter, sub_particles - - type(vector_field), pointer :: xfield - type(attr_counts_type) :: attr_counts - type(attr_names_type) :: attr_names, old_attr_names - type(attr_write_type) :: attr_write - integer, dimension(3) :: old_field_counts - - character(len=OPTION_PATH_LEN) :: group_path, subgroup_path - character(len=FIELD_NAME_LEN) :: subname - character(len=PYTHON_FUNC_LEN) :: script - - character(len=*), dimension(3), parameter :: orders = ["scalar", "vector", "tensor"] - character(len=*), dimension(3), parameter :: types = ["prescribed", "diagnostic", "prognostic"] - - logical :: global, store_old_fields - - ! Check whether there are any particles. - particle_groups = option_count("/particles/particle_group") - if (particle_groups == 0) return - - ! calculate the number of fields and old fields that would have to be stored - ! (each combination of field order and field type) - old_field_counts(:) = 0 - do i = 1, 3 - do j = 1, 3 - old_field_counts(i) = old_field_counts(i) + & - option_count("/material_phase/"//orders(i)//"_field/"//types(j)//"/particles/include_in_particles/store_old_field") + + ! And finally some sanity checks + list_counter=1 + do i = 1,particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + do k = 1,particle_arrays(i) + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" + call get_option(trim(subgroup_path)//"/name",subname) + totaldet_global=particle_lists(list_counter)%length + call allsum(totaldet_global) + ewrite(2,*) "Found", particle_lists(list_counter)%length, "local and ", totaldet_global, "global particles for particle array ", trim(subname) + + assert(totaldet_global==particle_lists(list_counter)%total_num_det) + list_counter = list_counter + 1 + end do end do - end do - ! Allocate parameters from the coordinate field - xfield => extract_vector_field(state(1), "Coordinate") - call get_option("/geometry/dimension", dim) + deallocate(particle_arrays) + call deallocate(field_names) + call deallocate(old_field_names) + end subroutine initialise_particles + + !> Initialise particles for times greater than 0 + subroutine initialise_particles_during_simulation(state, current_time) + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Current simulation time + real, intent(in) :: current_time + + integer :: i, k, j, dim, id_number + integer :: particle_groups, particle_subgroups, list_counter, sub_particles + + type(vector_field), pointer :: xfield + type(attr_counts_type) :: attr_counts + type(attr_names_type) :: attr_names, old_attr_names + type(attr_write_type) :: attr_write + integer, dimension(3) :: old_field_counts + + character(len=OPTION_PATH_LEN) :: group_path, subgroup_path + character(len=FIELD_NAME_LEN) :: subname + character(len=PYTHON_FUNC_LEN) :: script + + character(len=*), dimension(3), parameter :: orders = ["scalar", "vector", "tensor"] + character(len=*), dimension(3), parameter :: types = ["prescribed", "diagnostic", "prognostic"] + + logical :: global, store_old_fields + + ! Check whether there are any particles. + particle_groups = option_count("/particles/particle_group") + if (particle_groups == 0) return + + ! calculate the number of fields and old fields that would have to be stored + ! (each combination of field order and field type) + old_field_counts(:) = 0 + do i = 1, 3 + do j = 1, 3 + old_field_counts(i) = old_field_counts(i) + & + option_count("/material_phase/"//orders(i)//"_field/"//types(j)//"/particles/include_in_particles/store_old_field") + end do + end do - list_counter = 1 + ! Allocate parameters from the coordinate field + xfield => extract_vector_field(state(1), "Coordinate") + call get_option("/geometry/dimension", dim) - ewrite(2,*) "In initialise_particles_during_simulation" + list_counter = 1 - !Check if initialise_during_simulation is enabled - do i = 1, particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") - do k = 1, particle_subgroups - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" - if (have_option(trim(subgroup_path)//"/initialise_during_simulation")) then - ! Find number of attributes, old attributes, and names of each - call attr_names_and_count(trim(subgroup_path) // "/attributes/scalar_attribute", & - attr_names%s, old_attr_names%s, attr_names%sn, old_attr_names%sn, attr_write%s, & - attr_counts%attrs(1), attr_counts%old_attrs(1)) - call attr_names_and_count(trim(subgroup_path) // "/attributes/vector_attribute", & - attr_names%v, old_attr_names%v, attr_names%vn, old_attr_names%vn, attr_write%v, & - attr_counts%attrs(2), attr_counts%old_attrs(2)) - call attr_names_and_count(trim(subgroup_path) // "/attributes/tensor_attribute", & - attr_names%t, old_attr_names%t, attr_names%tn, old_attr_names%tn, attr_write%t, & - attr_counts%attrs(3), attr_counts%old_attrs(3)) + ewrite(2,*) "In initialise_particles_during_simulation" - ! If any attributes are from fields, we'll need to store old fields too - store_old_fields = .false. - if (option_count(trim(subgroup_path) // "/attributes/scalar_attribute/python_fields") > 0 .or. & + !Check if initialise_during_simulation is enabled + do i = 1, particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") + do k = 1, particle_subgroups + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" + if (have_option(trim(subgroup_path)//"/initialise_during_simulation")) then + ! Find number of attributes, old attributes, and names of each + call attr_names_and_count(trim(subgroup_path) // "/attributes/scalar_attribute", & + attr_names%s, old_attr_names%s, attr_names%sn, old_attr_names%sn, attr_write%s, & + attr_counts%attrs(1), attr_counts%old_attrs(1)) + call attr_names_and_count(trim(subgroup_path) // "/attributes/vector_attribute", & + attr_names%v, old_attr_names%v, attr_names%vn, old_attr_names%vn, attr_write%v, & + attr_counts%attrs(2), attr_counts%old_attrs(2)) + call attr_names_and_count(trim(subgroup_path) // "/attributes/tensor_attribute", & + attr_names%t, old_attr_names%t, attr_names%tn, old_attr_names%tn, attr_write%t, & + attr_counts%attrs(3), attr_counts%old_attrs(3)) + + ! If any attributes are from fields, we'll need to store old fields too + store_old_fields = .false. + if (option_count(trim(subgroup_path) // "/attributes/scalar_attribute/python_fields") > 0 .or. & option_count(trim(subgroup_path) // "/attributes/scalar_attribute_array/python_fields") > 0 .or. & option_count(trim(subgroup_path) // "/attributes/vector_attribute/python_fields") > 0 .or. & option_count(trim(subgroup_path) // "/attributes/vector_attribute_array/python_fields") > 0 .or. & option_count(trim(subgroup_path) // "/attributes/tensor_attribute/python_fields") > 0 .or. & option_count(trim(subgroup_path) // "/attributes/tensor_attribute_array/python_fields") > 0) then - store_old_fields = .true. - end if + store_old_fields = .true. + end if - if (store_old_fields) then - attr_counts%old_fields(:) = old_field_counts(:) - else - attr_counts%old_fields(:) = 0 - end if + if (store_old_fields) then + attr_counts%old_fields(:) = old_field_counts(:) + else + attr_counts%old_fields(:) = 0 + end if - call get_option(trim(subgroup_path)//"/initialise_during_simulation/python", script) + call get_option(trim(subgroup_path)//"/initialise_during_simulation/python", script) - id_number = particle_lists(list_counter)%proc_part_count - call get_option(trim(subgroup_path) // "/name", subname) - call read_particles_from_python(subname, subgroup_path, particle_lists(list_counter), xfield, dim, & + id_number = particle_lists(list_counter)%proc_part_count + call get_option(trim(subgroup_path) // "/name", subname) + call read_particles_from_python(subname, subgroup_path, particle_lists(list_counter), xfield, dim, & current_time, state, attr_counts, global, sub_particles, id_number=id_number, script=script) - particle_lists(list_counter)%total_num_det = particle_lists(list_counter)%total_num_det + sub_particles - - end if - list_counter = list_counter + 1 - end do - end do - - - end subroutine initialise_particles_during_simulation + particle_lists(list_counter)%total_num_det = particle_lists(list_counter)%total_num_det + sub_particles - !> Get the names and count of all attributes and old attributes for - !! a given attribute rank for a particle subgroup - subroutine attr_names_and_count(key, names, old_names, dims, old_dims, to_write, count, old_count) - !> Prefix key to an attribute rank within a subgroup - character(len=*), intent(in) :: key - !> Output arrays for attribute names - character(len=*), dimension(:), allocatable, intent(out) :: names, old_names - !> Output arrays for attribute dimensions - integer, dimension(:), allocatable, intent(out) :: dims, old_dims - !> Output arrays for whether to write attributes - logical, dimension(:), allocatable, intent(out) :: to_write - !> Output attribute counts - integer, intent(out) :: count, old_count + end if + list_counter = list_counter + 1 + end do + end do - integer :: i, old_i, single_count, array_count, single_old_count, array_old_count - character(len=FIELD_NAME_LEN) :: array_key, subkey - ! array-valued attribute name - array_key = trim(key) // "_array" + end subroutine initialise_particles_during_simulation + + !> Get the names and count of all attributes and old attributes for + !! a given attribute rank for a particle subgroup + subroutine attr_names_and_count(key, names, old_names, dims, old_dims, to_write, count, old_count) + !> Prefix key to an attribute rank within a subgroup + character(len=*), intent(in) :: key + !> Output arrays for attribute names + character(len=*), dimension(:), allocatable, intent(out) :: names, old_names + !> Output arrays for attribute dimensions + integer, dimension(:), allocatable, intent(out) :: dims, old_dims + !> Output arrays for whether to write attributes + logical, dimension(:), allocatable, intent(out) :: to_write + !> Output attribute counts + integer, intent(out) :: count, old_count + + integer :: i, old_i, single_count, array_count, single_old_count, array_old_count + character(len=FIELD_NAME_LEN) :: array_key, subkey + + ! array-valued attribute name + array_key = trim(key) // "_array" + + ! get option count so we can allocate the names array + single_count = option_count(key) + array_count = option_count(array_key) + + single_old_count = option_count(key//"/python_fields/store_old_attribute") + array_old_count = option_count(trim(array_key)//"/python_fields/store_old_attribute") + + allocate(names(single_count + array_count)) + allocate(old_names(single_old_count + array_old_count)) + + allocate(to_write(single_count + array_count)) + + allocate(dims(single_count + array_count)) + allocate(old_dims(single_old_count + array_old_count)) + + ! names for single-valued attributes + old_i = 1 + do i = 1, single_count + ! get the attribute's name + write(subkey, "(a,'[',i0,']')") key, i-1 + call get_option(trim(subkey)//"/name", names(i)) + ! we set single-valued attributes to have a dimension of 0 to distinguish from + ! a length 1 array attribute + dims(i) = 0 + + to_write(i) = .not. have_option(trim(subkey)//"/exclude_from_output") + + if (have_option(trim(subkey)//"/python_fields/store_old_attribute")) then + ! prefix with "old%" to distinguish from current attribute + old_names(old_i) = "old%" // trim(names(i)) + old_dims(old_i) = 0 + old_i = old_i + 1 + end if + end do - ! get option count so we can allocate the names array - single_count = option_count(key) - array_count = option_count(array_key) + ! names for array-valued attributes + do i = 1, array_count + write(subkey, "(a,'[',i0,']')") trim(array_key), i-1 + call get_option(trim(subkey)//"/name", names(i+single_count)) + call get_option(trim(subkey)//"/dimension", dims(i+single_count)) - single_old_count = option_count(key//"/python_fields/store_old_attribute") - array_old_count = option_count(trim(array_key)//"/python_fields/store_old_attribute") + to_write(i+single_count) = .not. have_option(trim(subkey)//"/exclude_from_output") - allocate(names(single_count + array_count)) - allocate(old_names(single_old_count + array_old_count)) + if (have_option(trim(subkey)//"/python_fields/store_old_attribute")) then + old_names(old_i) = "old%" // trim(names(i+single_count)) + old_dims(old_i) = dims(i+single_count) + old_i = old_i + 1 + end if + end do - allocate(to_write(single_count + array_count)) + ! compute the number of attribute arrays + count = single_count + sum(dims) + old_count = single_old_count + sum(old_dims) + end subroutine attr_names_and_count + + !> Initialise particles which are defined by a Python function + subroutine read_particles_from_python(subgroup_name, subgroup_path, & + p_list, xfield, dim, & + current_time, state, & + attr_counts, global, & + n_particles, id_number, script) + + !> Name of the particles' subgroup + character(len=FIELD_NAME_LEN), intent(in) :: subgroup_name + !> Path prefix for the subgroup in options + character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path + !> Detector list to hold the particles + type(detector_linked_list), intent(inout) :: p_list + !> Coordinate vector field + type(vector_field), pointer, intent(in) :: xfield + !> Geometry dimension + integer, intent(in) :: dim + !> Current model time, for passing through to Python functions + real, intent(in) :: current_time + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Counts of attributes, old attributes, and old fields + !! for each scalar, vector and tensor + type(attr_counts_type), intent(in) :: attr_counts + !> Whether to consider this particle in a global element search + logical, intent(in), optional :: global + !> Number of particles being initialized + integer, intent(out) :: n_particles + !> ID number of last particle currently in list + integer, optional, intent(in) :: id_number + !> Python script used by initialise_during_simulation + character(len=PYTHON_FUNC_LEN), optional, intent(in) :: script + + integer :: i, proc_num, stat, offset + character(len=PYTHON_FUNC_LEN) :: func + real, allocatable, dimension(:,:) :: coords ! all particle coordinates, from python + ! if we don't know how many particles we're getting, we need a C pointer + type(c_ptr) :: coord_ptr + ! and a fortran pointer + real, pointer, dimension(:,:) :: coord_array_ptr + real :: dt + + proc_num = getprocno() + + ewrite(2,*) "Reading particles from options" + + if (present(script)) then + func=script + else + call get_option(trim(subgroup_path)//"/initial_position/python", func) + end if + call get_option("/timestepping/timestep", dt) + + call set_detectors_from_python(func, len(func), dim, current_time, coord_ptr, n_particles, stat) + call c_f_pointer(coord_ptr, coord_array_ptr, [dim, n_particles]) + allocate(coords(dim, n_particles)) + if (n_particles==0) return + coords = coord_array_ptr + + call deallocate_c_array(coord_ptr) + offset = 0 + if (present(id_number)) offset = id_number + do i = 1, n_particles + call create_single_particle(p_list, xfield, coords(:,i), & + i+offset, proc_num, dim, attr_counts, global=global) + end do - allocate(dims(single_count + array_count)) - allocate(old_dims(single_old_count + array_old_count)) + deallocate(coords) + end subroutine read_particles_from_python + + !> Read attributes for all ranks from an H5Part file + subroutine read_attrs(h5_id, dim, counts, names, vals, prefix) + !> h5 file to read from + !! it's assumed this has been set up to read from the right place! + integer(kind=8), intent(in) :: h5_id + !> spatial dimension + integer, intent(in) :: dim + !> counts of scalar/vector/tensor attributes + integer, dimension(3), intent(in) :: counts + !> attribute names to read from the file + type(attr_names_type), intent(in) :: names + !> SVT values to hold the output + type(attr_vals_type), intent(inout) :: vals + !> Optional prefix to attribute names + character(len=*), intent(in), optional :: prefix + + integer :: i, j, k, ii, val_i + integer(kind=8) :: h5_ierror + character(len=FIELD_NAME_LEN) :: p + + p = "" + if (present(prefix)) p = prefix + + val_i = 1 + scalar_attr_loop: do i = 1, size(names%s) + if (names%sn(i) == 0) then + ! single-valued attribute + h5_ierror = h5pt_readdata_r8(h5_id, & + trim(p)//trim(names%s(i)), vals%s(val_i)) + val_i = val_i + 1 + else + do ii = 1, names%sn(i) + ! inner loop for array-valued attribute + h5_ierror = h5pt_readdata_r8(h5_id, & + trim(p)//trim(names%s(i))//int2str(ii), vals%s(val_i)) + val_i = val_i + 1 + end do + end if + end do scalar_attr_loop + + val_i = 1 + vector_attr_loop: do i = 1, size(names%v) + if (names%vn(i) == 0) then + ! single-valued attribute + do j = 1, dim + h5_ierror = h5pt_readdata_r8(h5_id, & + trim(p)//trim(names%v(i))//"_"//int2str(j-1), vals%v(j,val_i)) + end do + val_i = val_i + 1 + else + do ii = 1, names%vn(i) + ! inner loop for array-valued attribute + do j = 1, dim + h5_ierror = h5pt_readdata_r8(h5_id, & + trim(p)//trim(names%v(i))//int2str(ii)//"_"//int2str(j-1), vals%v(j,val_i)) + end do + val_i = val_i + 1 + end do + end if + end do vector_attr_loop + + val_i = 1 + tensor_attr_loop: do i = 1, size(names%t) + if (names%tn(i) == 0) then + ! single-valued attribute + do j = 1, dim + do k = 1, dim + h5_ierror = h5pt_readdata_r8(h5_id, & + trim(p)//trim(names%t(i))//"_"//int2str((k-1)*dim + (j-1)), & + vals%t(j,k,val_i)) + end do + end do + val_i = val_i + 1 + else + do ii = 1, names%tn(i) + ! inner loop for array-valued attribute + do j = 1, dim + do k = 1, dim + h5_ierror = h5pt_readdata_r8(h5_id, & + trim(p)//trim(names%t(i))//int2str(ii)//"_"//int2str((k-1)*dim + (j-1)), & + vals%t(j,k,val_i)) + end do + end do + val_i = val_i + 1 + end do + end if + end do tensor_attr_loop + end subroutine read_attrs + + !> Read particles in the given subgroup from a checkpoint file + subroutine read_particles_from_file(n_particles, subgroup_name, subgroup_path, & + p_list, xfield, dim, & + attr_counts, attr_names, old_attr_names, old_field_names, & + n_partitions) + !> Number of particles in this subgroup + integer, intent(in) :: n_particles + !> Name of the particles' subgroup + character(len=FIELD_NAME_LEN), intent(in) :: subgroup_name + !> Path prefix for the subgroup in options + character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path + !> Detector list to hold the particles + type(detector_linked_list), intent(inout) :: p_list + !> Coordinate vector field + type(vector_field), pointer, intent(in) :: xfield + !> Geometry dimension + integer, intent(in) :: dim + !> Counts of attributes, old attributes, and old fields + !! for each scalar, vector and tensor + type(attr_counts_type), intent(in) :: attr_counts + !> Names of attributes to store on this subgroup + type(attr_names_type), intent(in) :: attr_names + !> The attributes for which an old value should be checkpointed + type(attr_names_type), intent(in) :: old_attr_names + !> Names of fields for which old values should be checkpointed + type(attr_names_type), intent(in) :: old_field_names + + !> Optional parameter during recomposition to control the + !! processes which are involved in reading from file + integer, intent(in), optional :: n_partitions + + integer :: i + integer :: ierr, commsize, rank, id(1), proc_id(1) + integer :: input_comm, world_group, input_group ! opaque MPI pointers + real, allocatable, dimension(:) :: positions ! particle coordinates + character(len=OPTION_PATH_LEN) :: particles_cp_filename + integer(kind=8) :: h5_ierror, h5_id, h5_prop, view_start, view_end ! h5hut state + integer(kind=8), dimension(:), allocatable :: npoints, part_counter ! number of points for each rank to read + type(attr_vals_type), pointer :: attr_vals, old_attr_vals, old_field_vals ! scalar/vector/tensor arrays + + ewrite(2,*) "Reading particles from file" + + ! create new mpi group for active particles only + ! non-active processes are already not in this routine, + ! so we don't have to worry about them + if (present(n_partitions)) then + call mpi_comm_group(MPI_COMM_FEMTOOLS, world_group, ierr) + call mpi_group_incl(world_group, n_partitions, [(i, i=0, n_partitions-1)], input_group, ierr) + call mpi_comm_create_group(MPI_COMM_FEMTOOLS, input_group, 0, input_comm, ierr) + else + input_comm = MPI_COMM_FEMTOOLS + end if - ! names for single-valued attributes - old_i = 1 - do i = 1, single_count - ! get the attribute's name - write(subkey, "(a,'[',i0,']')") key, i-1 - call get_option(trim(subkey)//"/name", names(i)) - ! we set single-valued attributes to have a dimension of 0 to distinguish from - ! a length 1 array attribute - dims(i) = 0 + ! allocate arrays to hold positions and attributes for a single particle + allocate(positions(dim)) + call allocate(attr_vals, dim, attr_counts%attrs) + call allocate(old_attr_vals, dim, attr_counts%old_attrs) + call allocate(old_field_vals, dim, attr_counts%old_fields) + + ! set up the checkpoint file for reading + call get_option(trim(subgroup_path) // "/initial_position/from_file/file_name", particles_cp_filename) + + h5_prop = h5_createprop_file() + ! because we're reading separate particle counts per core + ! we can't use collective IO + h5_ierror = h5_setprop_file_mpio_independent(h5_prop, input_comm) + assert(h5_ierror == H5_SUCCESS) + + h5_id = h5_openfile(trim(particles_cp_filename), H5_O_RDONLY, h5_prop) + h5_ierror = h5_closeprop(h5_prop) + h5_ierror = h5_setstep(h5_id, int(1, 8)) + + ! determine the number of particles we are to initiliase + call mpi_comm_size(MPI_COMM_FEMTOOLS, commsize, ierr) + call mpi_comm_rank(MPI_COMM_FEMTOOLS, rank, ierr) + allocate(npoints(commsize)) + allocate(part_counter(commsize)) + h5_ierror = h5_readfileattrib_i8(h5_id, "npoints", npoints) + h5_ierror = h5_readfileattrib_i8(h5_id, "part_counter", part_counter) + h5_ierror = h5pt_setnpoints(h5_id, npoints(rank+1)) + + ! figure out our local offset into the file + h5_ierror = h5pt_getview(h5_id, view_start, view_end) + + do i = 1, npoints(rank+1) + + ! set view to read this particle + h5_ierror = h5pt_setview(h5_id, int(view_start + i - 1, 8), int(view_start + i - 1, 8)) + + if (dim >= 1) & + h5_ierror = h5pt_readdata_r8(h5_id, "x", positions(1)) + if (dim >= 2) & + h5_ierror = h5pt_readdata_r8(h5_id, "y", positions(2)) + if (dim >= 3) & + h5_ierror = h5pt_readdata_r8(h5_id, "z", positions(3)) + + h5_ierror = h5pt_readdata_i4(h5_id, "id", id(1)) + h5_ierror = h5pt_readdata_i4(h5_id, "proc_id", proc_id(1)) + + ! batched reads of scalar, vector, tensor values of each kind of attribute + call read_attrs(h5_id, dim, attr_counts%attrs, attr_names, attr_vals) + call read_attrs(h5_id, dim, attr_counts%old_attrs, old_attr_names, old_attr_vals) + call read_attrs(h5_id, dim, attr_counts%old_fields, old_field_names, old_field_vals, prefix="old%") + + ! don't use a global check for this particle + call create_single_particle(p_list, xfield, & + positions, id(1), proc_id(1), dim, & + attr_counts, attr_vals, old_attr_vals, old_field_vals, global=.false.) + end do - to_write(i) = .not. have_option(trim(subkey)//"/exclude_from_output") + ! reset proc_particle_count + p_list%proc_part_count = part_counter(rank+1) - if (have_option(trim(subkey)//"/python_fields/store_old_attribute")) then - ! prefix with "old%" to distinguish from current attribute - old_names(old_i) = "old%" // trim(names(i)) - old_dims(old_i) = 0 - old_i = old_i + 1 - end if - end do + h5_ierror = h5_closefile(h5_id) - ! names for array-valued attributes - do i = 1, array_count - write(subkey, "(a,'[',i0,']')") trim(array_key), i-1 - call get_option(trim(subkey)//"/name", names(i+single_count)) - call get_option(trim(subkey)//"/dimension", dims(i+single_count)) + deallocate(positions) + deallocate(npoints) + deallocate(part_counter) - to_write(i+single_count) = .not. have_option(trim(subkey)//"/exclude_from_output") + deallocate(attr_vals) + deallocate(old_attr_vals) + deallocate(old_field_vals) - if (have_option(trim(subkey)//"/python_fields/store_old_attribute")) then - old_names(old_i) = "old%" // trim(names(i+single_count)) - old_dims(old_i) = dims(i+single_count) - old_i = old_i + 1 + if (present(n_partitions)) then + call mpi_comm_free(input_comm, ierr) + call mpi_group_free(input_group, ierr) end if - end do - - ! compute the number of attribute arrays - count = single_count + sum(dims) - old_count = single_old_count + sum(old_dims) - end subroutine attr_names_and_count - - !> Initialise particles which are defined by a Python function - subroutine read_particles_from_python(subgroup_name, subgroup_path, & - p_list, xfield, dim, & - current_time, state, & - attr_counts, global, & - n_particles, id_number, script) - - !> Name of the particles' subgroup - character(len=FIELD_NAME_LEN), intent(in) :: subgroup_name - !> Path prefix for the subgroup in options - character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path - !> Detector list to hold the particles - type(detector_linked_list), intent(inout) :: p_list - !> Coordinate vector field - type(vector_field), pointer, intent(in) :: xfield - !> Geometry dimension - integer, intent(in) :: dim - !> Current model time, for passing through to Python functions - real, intent(in) :: current_time - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Counts of attributes, old attributes, and old fields - !! for each scalar, vector and tensor - type(attr_counts_type), intent(in) :: attr_counts - !> Whether to consider this particle in a global element search - logical, intent(in), optional :: global - !> Number of particles being initialized - integer, intent(out) :: n_particles - !> ID number of last particle currently in list - integer, optional, intent(in) :: id_number - !> Python script used by initialise_during_simulation - character(len=PYTHON_FUNC_LEN), optional, intent(in) :: script - - integer :: i, proc_num, stat, offset - character(len=PYTHON_FUNC_LEN) :: func - real, allocatable, dimension(:,:) :: coords ! all particle coordinates, from python - ! if we don't know how many particles we're getting, we need a C pointer - type(c_ptr) :: coord_ptr - ! and a fortran pointer - real, pointer, dimension(:,:) :: coord_array_ptr - real :: dt - - proc_num = getprocno() - - ewrite(2,*) "Reading particles from options" - - if (present(script)) then - func=script - else - call get_option(trim(subgroup_path)//"/initial_position/python", func) - end if - call get_option("/timestepping/timestep", dt) - - call set_detectors_from_python(func, len(func), dim, current_time, coord_ptr, n_particles, stat) - call c_f_pointer(coord_ptr, coord_array_ptr, [dim, n_particles]) - allocate(coords(dim, n_particles)) - if (n_particles==0) return - coords = coord_array_ptr - - call deallocate_c_array(coord_ptr) - offset = 0 - if (present(id_number)) offset = id_number - do i = 1, n_particles - call create_single_particle(p_list, xfield, coords(:,i), & - i+offset, proc_num, dim, attr_counts, global=global) - end do - - deallocate(coords) - end subroutine read_particles_from_python - - !> Read attributes for all ranks from an H5Part file - subroutine read_attrs(h5_id, dim, counts, names, vals, prefix) - !> h5 file to read from - !! it's assumed this has been set up to read from the right place! - integer(kind=8), intent(in) :: h5_id - !> spatial dimension - integer, intent(in) :: dim - !> counts of scalar/vector/tensor attributes - integer, dimension(3), intent(in) :: counts - !> attribute names to read from the file - type(attr_names_type), intent(in) :: names - !> SVT values to hold the output - type(attr_vals_type), intent(inout) :: vals - !> Optional prefix to attribute names - character(len=*), intent(in), optional :: prefix - - integer :: i, j, k, ii, val_i - integer(kind=8) :: h5_ierror - character(len=FIELD_NAME_LEN) :: p - - p = "" - if (present(prefix)) p = prefix - - val_i = 1 - scalar_attr_loop: do i = 1, size(names%s) - if (names%sn(i) == 0) then - ! single-valued attribute - h5_ierror = h5pt_readdata_r8(h5_id, & - trim(p)//trim(names%s(i)), vals%s(val_i)) - val_i = val_i + 1 - else - do ii = 1, names%sn(i) - ! inner loop for array-valued attribute - h5_ierror = h5pt_readdata_r8(h5_id, & - trim(p)//trim(names%s(i))//int2str(ii), vals%s(val_i)) - val_i = val_i + 1 - end do - end if - end do scalar_attr_loop - - val_i = 1 - vector_attr_loop: do i = 1, size(names%v) - if (names%vn(i) == 0) then - ! single-valued attribute - do j = 1, dim - h5_ierror = h5pt_readdata_r8(h5_id, & - trim(p)//trim(names%v(i))//"_"//int2str(j-1), vals%v(j,val_i)) - end do - val_i = val_i + 1 + end subroutine read_particles_from_file + + subroutine set_particle_output_file(subname, filename, p_list) + !! Set up the particle output file for a single subgroup + + type(detector_linked_list), intent(inout) :: p_list + character(len=*), intent(in) :: filename + character(len=FIELD_NAME_LEN), intent(in) :: subname + + p_list%h5_id = h5_openfile(trim(filename) // '.particles.' // trim(subname) // '.h5part', H5_O_WRONLY, H5_PROP_DEFAULT) + + ! optionally set any file attributes here? + end subroutine set_particle_output_file + + !> Allocate a single particle, populate and insert it into the given list + !! In parallel, first check if the particle would be local and only allocate if it is + subroutine create_single_particle(detector_list, xfield, position, id, proc_id, dim, & + attr_counts, attr_vals, old_attr_vals, old_field_vals, global) + !> The detector list to hold the particle + type(detector_linked_list), intent(inout) :: detector_list + !> Coordinate vector field + type(vector_field), pointer, intent(in) :: xfield + !> Spatial position of the particle + real, dimension(xfield%dim), intent(in) :: position + !> Unique ID number for this particle + integer, intent(in) :: id + !> Procces ID on which this particle was created + integer, intent(in) :: proc_id + !> Geometry dimension + integer, intent(in) :: dim + !> Counts of scalar, vector and tensor attributes, old attributes + !! and old fields to store on the particle + type(attr_counts_type), intent(in) :: attr_counts + !> If provided, initialise the particle's attributes directly + type(attr_vals_type), intent(in), optional :: attr_vals, old_attr_vals, old_field_vals + !> Whether to create this particle in a collective operation (true) + !! or for the local processor only (false). + !! This affects the inquiry of the element owning the particle + logical, intent(in), optional :: global + + type(detector_type), pointer :: detector + type(element_type), pointer :: shape + real, dimension(xfield%dim+1) :: lcoords + integer :: element + + real :: dt + logical :: picker_global = .true. + + if (present(global)) picker_global = global + + shape => ele_shape(xfield,1) + assert(xfield%dim+1==local_coord_count(shape)) + + ! Determine element and local_coords from position + call picker_inquire(xfield, position, element, local_coord=lcoords, global=picker_global) + call get_option("/timestepping/timestep", dt) + ! If we're in parallel and don't own the element, skip this particle + if (isparallel()) then + if (element<0) return + if (.not.element_owned(xfield,element)) return else - do ii = 1, names%vn(i) - ! inner loop for array-valued attribute - do j = 1, dim - h5_ierror = h5pt_readdata_r8(h5_id, & - trim(p)//trim(names%v(i))//int2str(ii)//"_"//int2str(j-1), vals%v(j,val_i)) - end do - val_i = val_i + 1 - end do + ! In serial make sure the particle is in the domain + ! unless we have the write_nan_outside override + if (element<0 .and. .not.detector_list%write_nan_outside) then + ewrite(-1,*) "Dealing with particle ", id, " proc_id:", proc_id + FLExit("Trying to initialise particle outside of computational domain") + end if end if - end do vector_attr_loop - - val_i = 1 - tensor_attr_loop: do i = 1, size(names%t) - if (names%tn(i) == 0) then - ! single-valued attribute - do j = 1, dim - do k = 1, dim - h5_ierror = h5pt_readdata_r8(h5_id, & - trim(p)//trim(names%t(i))//"_"//int2str((k-1)*dim + (j-1)), & - vals%t(j,k,val_i)) - end do - end do - val_i = val_i + 1 - else - do ii = 1, names%tn(i) - ! inner loop for array-valued attribute - do j = 1, dim - do k = 1, dim - h5_ierror = h5pt_readdata_r8(h5_id, & - trim(p)//trim(names%t(i))//int2str(ii)//"_"//int2str((k-1)*dim + (j-1)), & - vals%t(j,k,val_i)) + + ! Otherwise, allocate and insert particle + allocate(detector) + allocate(detector%position(xfield%dim)) + allocate(detector%local_coords(local_coord_count(shape))) + call insert(detector, detector_list) + + ! Populate particle + detector%position = position + detector%element = element + detector%local_coords = lcoords + detector%id_number = id + detector%proc_id = proc_id + detector%list_id = detector_list%id + detector_list%proc_part_count = max(detector_list%proc_part_count,id) + + ! allocate space to store all attributes on the particle + allocate(detector%attributes(total_attributes(attr_counts%attrs, dim))) + allocate(detector%old_attributes(total_attributes(attr_counts%old_attrs, dim))) + allocate(detector%old_fields(total_attributes(attr_counts%old_fields, dim))) + + ! copy attributes if they're present, otherwise initialise to zero + call copy_attrs(detector%attributes, dim, attr_counts%attrs, attr_vals) + call copy_attrs(detector%old_attributes, dim, attr_counts%old_attrs, old_attr_vals) + call copy_attrs(detector%old_fields, dim, attr_counts%old_fields, old_field_vals) + end subroutine create_single_particle + + !> Convert an array of scalar, vector and tensor attribute counts + !! to the total number of attribute slices (i.e. 1 per scalar attribute, + !! 'dim' per vector, and 'dim*dim' per tensor) + function total_attributes(counts, dim) + !> Counts of scalar, vector and tensor attributes + integer, dimension(3), intent(in) :: counts + !> Geometry dimension + integer, intent(in) :: dim + integer :: total_attributes + + total_attributes = counts(1) + dim*counts(2) + dim*dim*counts(3) + end function total_attributes + + !> Copy from an attr_vals_type to attribute arrays + subroutine copy_attrs(dest, dim, counts, vals) + !! Destination attribute array + real, dimension(:), intent(out) :: dest + !! Geometric dimension + integer, intent(in) :: dim + !! Attribute counts for each rank + integer, dimension(3), intent(in) :: counts + !! The attr_vals to copy from, if present + type(attr_vals_type), intent(in), optional :: vals + + integer :: cur, i, j, k + + if (present(vals)) then + cur = 1 + scalar_copy_loop: do i = 1, counts(1) + dest(cur) = vals%s(i) + cur = cur + 1 + end do scalar_copy_loop + + vector_copy_loop: do i = 1, counts(2) + do j = 1, dim + dest(cur) = vals%v(j,i) + cur = cur + 1 end do - end do - val_i = val_i + 1 - end do + end do vector_copy_loop + + tensor_copy_loop: do i = 1, counts(3) + do j = 1, dim + do k = 1, dim + dest(cur) = vals%t(j,k,i) + cur = cur + 1 + end do + end do + end do tensor_copy_loop + else + dest(:) = 0. end if - end do tensor_attr_loop - end subroutine read_attrs - - !> Read particles in the given subgroup from a checkpoint file - subroutine read_particles_from_file(n_particles, subgroup_name, subgroup_path, & - p_list, xfield, dim, & - attr_counts, attr_names, old_attr_names, old_field_names, & - n_partitions) - !> Number of particles in this subgroup - integer, intent(in) :: n_particles - !> Name of the particles' subgroup - character(len=FIELD_NAME_LEN), intent(in) :: subgroup_name - !> Path prefix for the subgroup in options - character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path - !> Detector list to hold the particles - type(detector_linked_list), intent(inout) :: p_list - !> Coordinate vector field - type(vector_field), pointer, intent(in) :: xfield - !> Geometry dimension - integer, intent(in) :: dim - !> Counts of attributes, old attributes, and old fields - !! for each scalar, vector and tensor - type(attr_counts_type), intent(in) :: attr_counts - !> Names of attributes to store on this subgroup - type(attr_names_type), intent(in) :: attr_names - !> The attributes for which an old value should be checkpointed - type(attr_names_type), intent(in) :: old_attr_names - !> Names of fields for which old values should be checkpointed - type(attr_names_type), intent(in) :: old_field_names - - !> Optional parameter during recomposition to control the - !! processes which are involved in reading from file - integer, intent(in), optional :: n_partitions - - integer :: i - integer :: ierr, commsize, rank, id(1), proc_id(1) - integer :: input_comm, world_group, input_group ! opaque MPI pointers - real, allocatable, dimension(:) :: positions ! particle coordinates - character(len=OPTION_PATH_LEN) :: particles_cp_filename - integer(kind=8) :: h5_ierror, h5_id, h5_prop, view_start, view_end ! h5hut state - integer(kind=8), dimension(:), allocatable :: npoints, part_counter ! number of points for each rank to read - type(attr_vals_type), pointer :: attr_vals, old_attr_vals, old_field_vals ! scalar/vector/tensor arrays - - ewrite(2,*) "Reading particles from file" - - ! create new mpi group for active particles only - ! non-active processes are already not in this routine, - ! so we don't have to worry about them - if (present(n_partitions)) then - call mpi_comm_group(MPI_COMM_FEMTOOLS, world_group, ierr) - call mpi_group_incl(world_group, n_partitions, [(i, i=0, n_partitions-1)], input_group, ierr) - call mpi_comm_create_group(MPI_COMM_FEMTOOLS, input_group, 0, input_comm, ierr) - else - input_comm = MPI_COMM_FEMTOOLS - end if - - ! allocate arrays to hold positions and attributes for a single particle - allocate(positions(dim)) - call allocate(attr_vals, dim, attr_counts%attrs) - call allocate(old_attr_vals, dim, attr_counts%old_attrs) - call allocate(old_field_vals, dim, attr_counts%old_fields) - - ! set up the checkpoint file for reading - call get_option(trim(subgroup_path) // "/initial_position/from_file/file_name", particles_cp_filename) - - h5_prop = h5_createprop_file() - ! because we're reading separate particle counts per core - ! we can't use collective IO - h5_ierror = h5_setprop_file_mpio_independent(h5_prop, input_comm) - assert(h5_ierror == H5_SUCCESS) - - h5_id = h5_openfile(trim(particles_cp_filename), H5_O_RDONLY, h5_prop) - h5_ierror = h5_closeprop(h5_prop) - h5_ierror = h5_setstep(h5_id, int(1, 8)) - - ! determine the number of particles we are to initiliase - call mpi_comm_size(MPI_COMM_FEMTOOLS, commsize, ierr) - call mpi_comm_rank(MPI_COMM_FEMTOOLS, rank, ierr) - allocate(npoints(commsize)) - allocate(part_counter(commsize)) - h5_ierror = h5_readfileattrib_i8(h5_id, "npoints", npoints) - h5_ierror = h5_readfileattrib_i8(h5_id, "part_counter", part_counter) - h5_ierror = h5pt_setnpoints(h5_id, npoints(rank+1)) - - ! figure out our local offset into the file - h5_ierror = h5pt_getview(h5_id, view_start, view_end) - - do i = 1, npoints(rank+1) - - ! set view to read this particle - h5_ierror = h5pt_setview(h5_id, int(view_start + i - 1, 8), int(view_start + i - 1, 8)) + end subroutine copy_attrs - if (dim >= 1) & - h5_ierror = h5pt_readdata_r8(h5_id, "x", positions(1)) - if (dim >= 2) & - h5_ierror = h5pt_readdata_r8(h5_id, "y", positions(2)) - if (dim >= 3) & - h5_ierror = h5pt_readdata_r8(h5_id, "z", positions(3)) - - h5_ierror = h5pt_readdata_i4(h5_id, "id", id(1)) - h5_ierror = h5pt_readdata_i4(h5_id, "proc_id", proc_id(1)) - - ! batched reads of scalar, vector, tensor values of each kind of attribute - call read_attrs(h5_id, dim, attr_counts%attrs, attr_names, attr_vals) - call read_attrs(h5_id, dim, attr_counts%old_attrs, old_attr_names, old_attr_vals) - call read_attrs(h5_id, dim, attr_counts%old_fields, old_field_names, old_field_vals, prefix="old%") - - ! don't use a global check for this particle - call create_single_particle(p_list, xfield, & - positions, id(1), proc_id(1), dim, & - attr_counts, attr_vals, old_attr_vals, old_field_vals, global=.false.) - end do - - ! reset proc_particle_count - p_list%proc_part_count = part_counter(rank+1) - - h5_ierror = h5_closefile(h5_id) - - deallocate(positions) - deallocate(npoints) - deallocate(part_counter) - - deallocate(attr_vals) - deallocate(old_attr_vals) - deallocate(old_field_vals) - - if (present(n_partitions)) then - call mpi_comm_free(input_comm, ierr) - call mpi_group_free(input_group, ierr) - end if - end subroutine read_particles_from_file - - subroutine set_particle_output_file(subname, filename, p_list) - !! Set up the particle output file for a single subgroup - - type(detector_linked_list), intent(inout) :: p_list - character(len=*), intent(in) :: filename - character(len=FIELD_NAME_LEN), intent(in) :: subname - - p_list%h5_id = h5_openfile(trim(filename) // '.particles.' // trim(subname) // '.h5part', H5_O_WRONLY, H5_PROP_DEFAULT) - - ! optionally set any file attributes here? - end subroutine set_particle_output_file - - !> Allocate a single particle, populate and insert it into the given list - !! In parallel, first check if the particle would be local and only allocate if it is - subroutine create_single_particle(detector_list, xfield, position, id, proc_id, dim, & - attr_counts, attr_vals, old_attr_vals, old_field_vals, global) - !> The detector list to hold the particle - type(detector_linked_list), intent(inout) :: detector_list - !> Coordinate vector field - type(vector_field), pointer, intent(in) :: xfield - !> Spatial position of the particle - real, dimension(xfield%dim), intent(in) :: position - !> Unique ID number for this particle - integer, intent(in) :: id - !> Procces ID on which this particle was created - integer, intent(in) :: proc_id - !> Geometry dimension - integer, intent(in) :: dim - !> Counts of scalar, vector and tensor attributes, old attributes - !! and old fields to store on the particle - type(attr_counts_type), intent(in) :: attr_counts - !> If provided, initialise the particle's attributes directly - type(attr_vals_type), intent(in), optional :: attr_vals, old_attr_vals, old_field_vals - !> Whether to create this particle in a collective operation (true) - !! or for the local processor only (false). - !! This affects the inquiry of the element owning the particle - logical, intent(in), optional :: global - - type(detector_type), pointer :: detector - type(element_type), pointer :: shape - real, dimension(xfield%dim+1) :: lcoords - integer :: element - - real :: dt - logical :: picker_global = .true. - - if (present(global)) picker_global = global - - shape => ele_shape(xfield,1) - assert(xfield%dim+1==local_coord_count(shape)) - - ! Determine element and local_coords from position - call picker_inquire(xfield, position, element, local_coord=lcoords, global=picker_global) - call get_option("/timestepping/timestep", dt) - ! If we're in parallel and don't own the element, skip this particle - if (isparallel()) then - if (element<0) return - if (.not.element_owned(xfield,element)) return - else - ! In serial make sure the particle is in the domain - ! unless we have the write_nan_outside override - if (element<0 .and. .not.detector_list%write_nan_outside) then - ewrite(-1,*) "Dealing with particle ", id, " proc_id:", proc_id - FLExit("Trying to initialise particle outside of computational domain") - end if - end if - - ! Otherwise, allocate and insert particle - allocate(detector) - allocate(detector%position(xfield%dim)) - allocate(detector%local_coords(local_coord_count(shape))) - call insert(detector, detector_list) - - ! Populate particle - detector%position = position - detector%element = element - detector%local_coords = lcoords - detector%id_number = id - detector%proc_id = proc_id - detector%list_id = detector_list%id - detector_list%proc_part_count = max(detector_list%proc_part_count,id) - - ! allocate space to store all attributes on the particle - allocate(detector%attributes(total_attributes(attr_counts%attrs, dim))) - allocate(detector%old_attributes(total_attributes(attr_counts%old_attrs, dim))) - allocate(detector%old_fields(total_attributes(attr_counts%old_fields, dim))) - - ! copy attributes if they're present, otherwise initialise to zero - call copy_attrs(detector%attributes, dim, attr_counts%attrs, attr_vals) - call copy_attrs(detector%old_attributes, dim, attr_counts%old_attrs, old_attr_vals) - call copy_attrs(detector%old_fields, dim, attr_counts%old_fields, old_field_vals) - end subroutine create_single_particle - - !> Convert an array of scalar, vector and tensor attribute counts - !! to the total number of attribute slices (i.e. 1 per scalar attribute, - !! 'dim' per vector, and 'dim*dim' per tensor) - function total_attributes(counts, dim) - !> Counts of scalar, vector and tensor attributes - integer, dimension(3), intent(in) :: counts - !> Geometry dimension - integer, intent(in) :: dim - integer :: total_attributes - - total_attributes = counts(1) + dim*counts(2) + dim*dim*counts(3) - end function total_attributes - - !> Copy from an attr_vals_type to attribute arrays - subroutine copy_attrs(dest, dim, counts, vals) - !! Destination attribute array - real, dimension(:), intent(out) :: dest - !! Geometric dimension - integer, intent(in) :: dim - !! Attribute counts for each rank - integer, dimension(3), intent(in) :: counts - !! The attr_vals to copy from, if present - type(attr_vals_type), intent(in), optional :: vals - - integer :: cur, i, j, k - - if (present(vals)) then - cur = 1 - scalar_copy_loop: do i = 1, counts(1) - dest(cur) = vals%s(i) - cur = cur + 1 - end do scalar_copy_loop - - vector_copy_loop: do i = 1, counts(2) - do j = 1, dim - dest(cur) = vals%v(j,i) - cur = cur + 1 - end do - end do vector_copy_loop - - tensor_copy_loop: do i = 1, counts(3) - do j = 1, dim - do k = 1, dim - dest(cur) = vals%t(j,k,i) - cur = cur + 1 - end do - end do - end do tensor_copy_loop - else - dest(:) = 0. - end if - end subroutine copy_attrs - - !> Call move_lagrangian_detectors on all tracked particle groups - subroutine move_particles(state, dt) - type(state_type), dimension(:), intent(in) :: state - real, intent(in) :: dt - - integer :: i, particle_groups - - ewrite(2,*) "In move_particles" - call profiler_tic("particle_advection") - - particle_groups = option_count("/particles/particle_group") - if (particle_groups == 0) return - - do i = 1, size(particle_lists) - call move_lagrangian_detectors(state, particle_lists(i), dt) - end do - - call profiler_toc("particle_advection") - end subroutine move_particles - - !> Initialise constant attribute values before diagnostic fields are set - subroutine initialise_constant_particle_attributes(state, subgroup_path, p_list) - !!Routine to initialise constant attributes for MVF field - type(state_type), dimension(:), intent(in) :: state - character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path - type(detector_linked_list), intent(in) :: p_list - - type(detector_type), pointer :: particle - character(len=OPTION_PATH_LEN) :: attr_key - - real, allocatable, dimension(:,:) :: attribute_array - real :: constant - real, allocatable, dimension(:) :: vconstant - real, allocatable, dimension(:,:) :: tconstant - integer :: i, j, nparticles, n, i_single, attr_idx, dim - integer :: nscalar, nvector, ntensor - - !Check if this processor contains particles - nparticles = p_list%length - - if (nparticles.eq.0) then - return - end if - - ! get attribute sizes from the detector list - nscalar = size(p_list%attr_names%s) - nvector = size(p_list%attr_names%v) - ntensor = size(p_list%attr_names%t) - - call get_option("/geometry/dimension", dim) - allocate(vconstant(dim)) - allocate(tconstant(dim, dim)) - - particle => p_list%first - allocate(attribute_array(size(particle%attributes),nparticles)) - attribute_array(:,:) = 0 - - !Scalar constants - i_single = 1 - attr_idx = 1 - do i = 1, nscalar - n = p_list%attr_names%sn(i) - if (n == 0) then - ! single-valued attribute - attr_key = trim(subgroup_path) // '/attributes/scalar_attribute['//int2str(i_single-1)//']' - i_single = i_single + 1 - if (have_option(trim(attr_key)//'/constant')) then - call get_option(trim(attr_key)//'/constant', constant) - attribute_array(attr_idx:attr_idx,:) = constant - end if - attr_idx = attr_idx + 1 - end if - end do - - !Vector constants - i_single = 1 - do i=1, nvector - n = p_list%attr_names%vn(i) - if (n == 0) then - ! single-valued attribute - attr_key = trim(subgroup_path) // '/attributes/vector_attribute['//int2str(i_single-1)//']' - i_single = i_single + 1 - if (have_option(trim(attr_key)//'/constant')) then - call get_option(trim(attr_key)//'/constant', vconstant) - ! broadcast vector constant out to all particles - attribute_array(attr_idx:attr_idx+dim-1,:) = spread(vconstant, 2, nparticles) - end if - attr_idx = attr_idx + dim - end if - end do - - !Tensor constants - i_single = 1 - do i=1, ntensor - n = p_list%attr_names%tn(i) - if (n == 0) then - ! single-valued attribute - attr_key = trim(subgroup_path) // '/attributes/tensor_attribute['//int2str(i_single-1)//']' - i_single = i_single + 1 - if (have_option(trim(attr_key)//'/constant')) then - call get_option(trim(attr_key)//'/constant', tconstant) - ! flatten tensor, then broadcast out to all particles - attribute_array(attr_idx:attr_idx+dim**2-1,:) = spread(reshape(tconstant, [dim**2]), 2, nparticles) - end if - attr_idx = attr_idx + dim**2 - end if - end do - - !Set constant attribute values - particle => p_list%first - do j = 1,nparticles - particle%attributes = attribute_array(:,j) - particle => particle%next - end do - deallocate(vconstant) - deallocate(tconstant) - deallocate(attribute_array) - - end subroutine initialise_constant_particle_attributes - - !> Update attributes and fields for every subgroup of every particle group - subroutine update_particle_attributes_and_fields(state, time, dt) - type(state_type), dimension(:), intent(in) :: state - real, intent(in) :: time - real, intent(in) :: dt - character(len = OPTION_PATH_LEN) :: group_path, subgroup_path - - integer :: i, k - integer :: particle_groups, particle_subgroups, list_counter - - ! Check whether there are any particles. - particle_groups = option_count("/particles/particle_group") - if (particle_groups == 0) return - - ewrite(2,*) "In update_particle_attributes_and_fields" - - list_counter = 1 - - do i = 1, particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") - do k = 1, particle_subgroups - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" - - if (particle_lists(list_counter)%length==0) then - list_counter = list_counter + 1 - cycle - end if + !> Call move_lagrangian_detectors on all tracked particle groups + subroutine move_particles(state, dt) + type(state_type), dimension(:), intent(in) :: state + real, intent(in) :: dt - call update_particle_subgroup_attributes_and_fields(state, time, dt, subgroup_path, particle_lists(list_counter)) - list_counter = list_counter + 1 - end do - end do - end subroutine update_particle_attributes_and_fields - - !> Copy a structure of attribute names by rank - !! to a 2D character array for passing to C - subroutine copy_names_to_array(attr_names, name_array, attr_counts, attr_dims, prefix) - type(attr_names_type), intent(in) :: attr_names - character, allocatable, dimension(:,:), intent(out) :: name_array - integer, dimension(3), intent(out) :: attr_counts - integer, allocatable, dimension(:), intent(out), optional :: attr_dims - character(len=*), intent(in), optional :: prefix - - integer :: i, j, k, n, np - character(len=FIELD_NAME_LEN) :: p - - p = "" - if (present(prefix)) p = prefix - - np = len_trim(p) - - ! determine number of names for each rank - ! so that we can allocate the names array - attr_counts(1) = size(attr_names%s) - attr_counts(2) = size(attr_names%v) - attr_counts(3) = size(attr_names%t) - allocate(name_array(FIELD_NAME_LEN, sum(attr_counts))) - - if (present(attr_dims)) then - allocate(attr_dims(sum(attr_counts))) - end if - - ! unfortunately, we have to use a character array for C - ! interoperability, and we can't assign an array from - ! a character scalar, so we have to do explicit lops - j = 1 - do i = 1, attr_counts(1) - ! copy prefix - do k = 1, np - name_array(k,j) = p(k:k) - end do + integer :: i, particle_groups + + ewrite(2,*) "In move_particles" + call profiler_tic("particle_advection") - ! copy attribute name - n = min(FIELD_NAME_LEN - np - 1, len_trim(attr_names%s(i))) - do k = 1, n - name_array(k+np,j) = attr_names%s(i)(k:k) + particle_groups = option_count("/particles/particle_group") + if (particle_groups == 0) return + + do i = 1, size(particle_lists) + call move_lagrangian_detectors(state, particle_lists(i), dt) end do - ! null terminate - name_array(np+n+1,j) = C_NULL_CHAR + call profiler_toc("particle_advection") + end subroutine move_particles - ! possibly copy in the dimension - if (present(attr_dims)) then - attr_dims(j) = attr_names%sn(i) + !> Initialise constant attribute values before diagnostic fields are set + subroutine initialise_constant_particle_attributes(state, subgroup_path, p_list) + !!Routine to initialise constant attributes for MVF field + type(state_type), dimension(:), intent(in) :: state + character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path + type(detector_linked_list), intent(in) :: p_list + + type(detector_type), pointer :: particle + character(len=OPTION_PATH_LEN) :: attr_key + + real, allocatable, dimension(:,:) :: attribute_array + real :: constant + real, allocatable, dimension(:) :: vconstant + real, allocatable, dimension(:,:) :: tconstant + integer :: i, j, nparticles, n, i_single, attr_idx, dim + integer :: nscalar, nvector, ntensor + + !Check if this processor contains particles + nparticles = p_list%length + + if (nparticles.eq.0) then + return end if - j = j + 1 - end do - do i = 1, attr_counts(2) - ! copy prefix - do k = 1, np - name_array(k,j) = p(k:k) + + ! get attribute sizes from the detector list + nscalar = size(p_list%attr_names%s) + nvector = size(p_list%attr_names%v) + ntensor = size(p_list%attr_names%t) + + call get_option("/geometry/dimension", dim) + allocate(vconstant(dim)) + allocate(tconstant(dim, dim)) + + particle => p_list%first + allocate(attribute_array(size(particle%attributes),nparticles)) + attribute_array(:,:) = 0 + + !Scalar constants + i_single = 1 + attr_idx = 1 + do i = 1, nscalar + n = p_list%attr_names%sn(i) + if (n == 0) then + ! single-valued attribute + attr_key = trim(subgroup_path) // '/attributes/scalar_attribute['//int2str(i_single-1)//']' + i_single = i_single + 1 + if (have_option(trim(attr_key)//'/constant')) then + call get_option(trim(attr_key)//'/constant', constant) + attribute_array(attr_idx:attr_idx,:) = constant + end if + attr_idx = attr_idx + 1 + end if end do - n = min(FIELD_NAME_LEN - np - 1, len_trim(attr_names%v(i))) - do k = 1, n - name_array(k+np,j) = attr_names%v(i)(k:k) + !Vector constants + i_single = 1 + do i=1, nvector + n = p_list%attr_names%vn(i) + if (n == 0) then + ! single-valued attribute + attr_key = trim(subgroup_path) // '/attributes/vector_attribute['//int2str(i_single-1)//']' + i_single = i_single + 1 + if (have_option(trim(attr_key)//'/constant')) then + call get_option(trim(attr_key)//'/constant', vconstant) + ! broadcast vector constant out to all particles + attribute_array(attr_idx:attr_idx+dim-1,:) = spread(vconstant, 2, nparticles) + end if + attr_idx = attr_idx + dim + end if end do - name_array(np+n+1,j) = C_NULL_CHAR - if (present(attr_dims)) then - attr_dims(j) = attr_names%vn(i) - end if - j = j + 1 - end do - do i = 1, attr_counts(3) - ! copy prefix - do k = 1, np - name_array(k,j) = p(k:k) + + !Tensor constants + i_single = 1 + do i=1, ntensor + n = p_list%attr_names%tn(i) + if (n == 0) then + ! single-valued attribute + attr_key = trim(subgroup_path) // '/attributes/tensor_attribute['//int2str(i_single-1)//']' + i_single = i_single + 1 + if (have_option(trim(attr_key)//'/constant')) then + call get_option(trim(attr_key)//'/constant', tconstant) + ! flatten tensor, then broadcast out to all particles + attribute_array(attr_idx:attr_idx+dim**2-1,:) = spread(reshape(tconstant, [dim**2]), 2, nparticles) + end if + attr_idx = attr_idx + dim**2 + end if end do - n = min(FIELD_NAME_LEN - np - 1, len_trim(attr_names%t(i))) - do k = 1, n - name_array(k+np,j) = attr_names%t(i)(k:k) + !Set constant attribute values + particle => p_list%first + do j = 1,nparticles + particle%attributes = attribute_array(:,j) + particle => particle%next end do - name_array(np+n+1,j) = C_NULL_CHAR - if (present(attr_dims)) then - attr_dims(j) = attr_names%tn(i) - end if - j = j + 1 - end do - end subroutine copy_names_to_array - - !> Set particle attributes for a single subgroup - subroutine update_particle_subgroup_attributes_and_fields(state, time, dt, subgroup_path, p_list) - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Current model time - real, intent(in) :: time - !> Model timestep - real, intent(in) :: dt - !> Option path for the subgroup - character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path - !> Subgroup particle list - type(detector_linked_list), intent(in) :: p_list - - character(len=PYTHON_FUNC_LEN) :: func - type(detector_type), pointer :: particle - character(len=OPTION_PATH_LEN) :: attr_key - - ! arrays into which all particle data for the - ! subgroup is copied - real, allocatable, dimension(:,:) :: positions - real, allocatable, dimension(:,:) :: attribute_array - real, allocatable, dimension(:,:) :: old_attributes - real, allocatable, dimension(:,:) :: lcoords - integer, allocatable, dimension(:) :: ele - - logical, allocatable, dimension(:) :: store_old_attr - - character, allocatable, dimension(:,:) :: old_attr_names, field_names, old_field_names - integer, allocatable, dimension(:) :: old_attr_dims - - real :: constant - real, allocatable, dimension(:) :: vconstant - real, allocatable, dimension(:,:) :: tconstant - integer :: i, j, nparticles, m, n, dim, attr_idx, i_single, i_array - integer :: nscalar, nvector, ntensor - integer, dimension(3) :: old_attr_counts, field_counts, old_field_counts - logical :: is_array - - nparticles = p_list%length - ! return if no particles - if (nparticles == 0) then - return - end if - - ! get attribute sizes from the detector list - nscalar = size(p_list%attr_names%s) - nvector = size(p_list%attr_names%v) - ntensor = size(p_list%attr_names%t) - - ! return if no attributes - if (nscalar+nvector+ntensor== 0) then - return - end if - - ! store all the old attribute names in a contiguous list - ! for passing through to python functions - ! we also allocate the array of old attribute dims here - call copy_names_to_array(p_list%old_attr_names, old_attr_names, old_attr_counts, old_attr_dims) - call copy_names_to_array(p_list%field_names, field_names, field_counts) - call copy_names_to_array(p_list%old_field_names, old_field_names, old_field_counts, prefix="old%") - - call get_option("/geometry/dimension", dim) - allocate(vconstant(dim)) - allocate(tconstant(dim, dim)) - - ! allocate space to hold data for all particles in the group - particle => p_list%first - allocate(positions(size(particle%position), nparticles)) - allocate(attribute_array(size(particle%attributes), nparticles)) - allocate(lcoords(size(particle%local_coords), nparticles)) - allocate(ele(nparticles)) - allocate(old_attributes(size(particle%old_attributes), nparticles)) - - ! copy the data - do i = 1, nparticles - positions(:,i) = particle%position - lcoords(:,i) = particle%local_coords - ele(i) = particle%element - ! copy current attributes in case we loaded from file - attribute_array(:,i) = particle%attributes - old_attributes(:,i) = particle%old_attributes - particle => particle%next - end do - - attr_idx = 1 - - ! calculate new values for all attributes - i_single = 1 - i_array = 1 - do i = 1, nscalar - n = p_list%attr_names%sn(i) - - if (n == 0) then - ! single-valued attribute - attr_key = trim(subgroup_path) // '/attributes/scalar_attribute['//int2str(i_single-1)//']' - i_single = i_single + 1 - is_array = .false. - n = 1 - else - ! array-valued attribute - attr_key = trim(subgroup_path) // '/attributes/scalar_attribute_array['//int2str(i_array-1)//']' - i_array = i_array + 1 - is_array = .true. - end if + deallocate(vconstant) + deallocate(tconstant) + deallocate(attribute_array) - if (have_option(trim(attr_key)//'/constant')) then - call get_option(trim(attr_key)//'/constant', constant) - attribute_array(attr_idx:attr_idx+n-1,:) = constant - - else if (have_option(trim(attr_key)//'/python')) then - call get_option(trim(attr_key)//'/python', func) - call set_particle_scalar_attribute_from_python( & - attribute_array(attr_idx:attr_idx+n-1,:), & - positions(:,:), n, func, time, dt, is_array) - - else if (have_option(trim(attr_key)//'/python_fields')) then - call get_option(trim(attr_key)//'/python_fields', func) - call set_particle_scalar_attribute_from_python_fields( & - p_list, state, positions(:,:), lcoords(:,:), ele(:), n, & - attribute_array(attr_idx:attr_idx+n-1,:), & - old_attr_names, old_attr_counts, old_attr_dims, old_attributes, & - field_names, field_counts, old_field_names, old_field_counts, & - func, time, dt, is_array) - - else if (have_option(trim(attr_key)//'/from_checkpoint_file')) then - ! don't do anything, the attribute was already loaded from file - end if + end subroutine initialise_constant_particle_attributes - attr_idx = attr_idx + n - end do + !> Update attributes and fields for every subgroup of every particle group + subroutine update_particle_attributes_and_fields(state, time, dt) + type(state_type), dimension(:), intent(in) :: state + real, intent(in) :: time + real, intent(in) :: dt + character(len = OPTION_PATH_LEN) :: group_path, subgroup_path - i_single = 1 - i_array = 1 - do i = 1, nvector - n = p_list%attr_names%vn(i) + integer :: i, k + integer :: particle_groups, particle_subgroups, list_counter - if (n == 0) then - ! single-valued attribute - attr_key = trim(subgroup_path) // '/attributes/vector_attribute['//int2str(i_single-1)//']' - i_single = i_single + 1 - is_array = .false. - n = 1 - else - ! array-valued attribute - attr_key = trim(subgroup_path) // '/attributes/vector_attribute_array['//int2str(i_array-1)//']' - i_array = i_array + 1 - is_array = .true. - end if + ! Check whether there are any particles. + particle_groups = option_count("/particles/particle_group") + if (particle_groups == 0) return + + ewrite(2,*) "In update_particle_attributes_and_fields" + + list_counter = 1 + + do i = 1, particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") + do k = 1, particle_subgroups + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" + + if (particle_lists(list_counter)%length==0) then + list_counter = list_counter + 1 + cycle + end if + + call update_particle_subgroup_attributes_and_fields(state, time, dt, subgroup_path, particle_lists(list_counter)) + list_counter = list_counter + 1 + end do + end do + end subroutine update_particle_attributes_and_fields + + !> Copy a structure of attribute names by rank + !! to a 2D character array for passing to C + subroutine copy_names_to_array(attr_names, name_array, attr_counts, attr_dims, prefix) + type(attr_names_type), intent(in) :: attr_names + character, allocatable, dimension(:,:), intent(out) :: name_array + integer, dimension(3), intent(out) :: attr_counts + integer, allocatable, dimension(:), intent(out), optional :: attr_dims + character(len=*), intent(in), optional :: prefix + + integer :: i, j, k, n, np + character(len=FIELD_NAME_LEN) :: p + + p = "" + if (present(prefix)) p = prefix + + np = len_trim(p) + + ! determine number of names for each rank + ! so that we can allocate the names array + attr_counts(1) = size(attr_names%s) + attr_counts(2) = size(attr_names%v) + attr_counts(3) = size(attr_names%t) + allocate(name_array(FIELD_NAME_LEN, sum(attr_counts))) - if (have_option(trim(attr_key)//'/constant')) then - call get_option(trim(attr_key)//'/constant', vconstant) - ! broadcast vector constant out to all particles - attribute_array(attr_idx:attr_idx+n*dim-1,:) = spread(vconstant, 2, nparticles) - - else if (have_option(trim(attr_key)//'/python')) then - call get_option(trim(attr_key)//'/python', func) - call set_particle_vector_attribute_from_python( & - attribute_array(attr_idx:attr_idx+n*dim-1,:), & - positions(:,:), n, func, time, dt, is_array) - - else if (have_option(trim(attr_key)//'/python_fields')) then - call get_option(trim(attr_key)//'/python_fields', func) - call set_particle_vector_attribute_from_python_fields( & - p_list, state, positions(:,:), lcoords(:,:), ele(:), n, & - attribute_array(attr_idx:attr_idx+n*dim-1,:), & - old_attr_names, old_attr_counts, old_attr_dims, old_attributes, & - field_names, field_counts, old_field_names, old_field_counts, & - func, time, dt, is_array) - - else if (have_option(trim(attr_key)//'/from_checkpoint_file')) then - ! don't do anything, the attribute was already loaded from file + if (present(attr_dims)) then + allocate(attr_dims(sum(attr_counts))) end if - attr_idx = attr_idx + n*dim - end do + ! unfortunately, we have to use a character array for C + ! interoperability, and we can't assign an array from + ! a character scalar, so we have to do explicit lops + j = 1 + do i = 1, attr_counts(1) + ! copy prefix + do k = 1, np + name_array(k,j) = p(k:k) + end do + + ! copy attribute name + n = min(FIELD_NAME_LEN - np - 1, len_trim(attr_names%s(i))) + do k = 1, n + name_array(k+np,j) = attr_names%s(i)(k:k) + end do + + ! null terminate + name_array(np+n+1,j) = C_NULL_CHAR + + ! possibly copy in the dimension + if (present(attr_dims)) then + attr_dims(j) = attr_names%sn(i) + end if + j = j + 1 + end do + do i = 1, attr_counts(2) + ! copy prefix + do k = 1, np + name_array(k,j) = p(k:k) + end do + + n = min(FIELD_NAME_LEN - np - 1, len_trim(attr_names%v(i))) + do k = 1, n + name_array(k+np,j) = attr_names%v(i)(k:k) + end do + name_array(np+n+1,j) = C_NULL_CHAR + if (present(attr_dims)) then + attr_dims(j) = attr_names%vn(i) + end if + j = j + 1 + end do + do i = 1, attr_counts(3) + ! copy prefix + do k = 1, np + name_array(k,j) = p(k:k) + end do + + n = min(FIELD_NAME_LEN - np - 1, len_trim(attr_names%t(i))) + do k = 1, n + name_array(k+np,j) = attr_names%t(i)(k:k) + end do + name_array(np+n+1,j) = C_NULL_CHAR + if (present(attr_dims)) then + attr_dims(j) = attr_names%tn(i) + end if + j = j + 1 + end do + end subroutine copy_names_to_array + + !> Set particle attributes for a single subgroup + subroutine update_particle_subgroup_attributes_and_fields(state, time, dt, subgroup_path, p_list) + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Current model time + real, intent(in) :: time + !> Model timestep + real, intent(in) :: dt + !> Option path for the subgroup + character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path + !> Subgroup particle list + type(detector_linked_list), intent(in) :: p_list + + character(len=PYTHON_FUNC_LEN) :: func + type(detector_type), pointer :: particle + character(len=OPTION_PATH_LEN) :: attr_key + + ! arrays into which all particle data for the + ! subgroup is copied + real, allocatable, dimension(:,:) :: positions + real, allocatable, dimension(:,:) :: attribute_array + real, allocatable, dimension(:,:) :: old_attributes + real, allocatable, dimension(:,:) :: lcoords + integer, allocatable, dimension(:) :: ele + + logical, allocatable, dimension(:) :: store_old_attr + + character, allocatable, dimension(:,:) :: old_attr_names, field_names, old_field_names + integer, allocatable, dimension(:) :: old_attr_dims + + real :: constant + real, allocatable, dimension(:) :: vconstant + real, allocatable, dimension(:,:) :: tconstant + integer :: i, j, nparticles, m, n, dim, attr_idx, i_single, i_array + integer :: nscalar, nvector, ntensor + integer, dimension(3) :: old_attr_counts, field_counts, old_field_counts + logical :: is_array + + nparticles = p_list%length + ! return if no particles + if (nparticles == 0) then + return + end if - i_single = 1 - i_array = 1 - do i = 1, ntensor - n = p_list%attr_names%tn(i) + ! get attribute sizes from the detector list + nscalar = size(p_list%attr_names%s) + nvector = size(p_list%attr_names%v) + ntensor = size(p_list%attr_names%t) - if (n == 0) then - ! single-valued attribute - attr_key = trim(subgroup_path) // '/attributes/tensor_attribute['//int2str(i_single-1)//']' - i_single = i_single + 1 - is_array = .false. - n = 1 - else - ! array-valued attribute - attr_key = trim(subgroup_path) // '/attributes/tensor_attribute_array['//int2str(i_array-1)//']' - i_array = i_array + 1 - is_array = .true. + ! return if no attributes + if (nscalar+nvector+ntensor== 0) then + return end if - if (have_option(trim(attr_key)//'/constant')) then - call get_option(trim(attr_key)//'/constant', tconstant) - ! flatten tensor, then broadcast out to all particles - attribute_array(attr_idx:attr_idx+n*dim**2-1,:) = spread(reshape(tconstant, [dim**2]), 2, nparticles) - - else if (have_option(trim(attr_key)//'/python')) then - call get_option(trim(attr_key)//'/python', func) - call set_particle_tensor_attribute_from_python( & - attribute_array(attr_idx:attr_idx + n*dim**2 - 1,:), & - positions(:,:), n, func, time, dt, is_array) - - else if (have_option(trim(attr_key)//'/python_fields')) then - call get_option(trim(attr_key)//'/python_fields', func) - call set_particle_tensor_attribute_from_python_fields( & - p_list, state, positions(:,:), lcoords(:,:), ele(:), n, & - attribute_array(attr_idx:attr_idx + n*dim**2 - 1,:), & - old_attr_names, old_attr_counts, old_attr_dims, old_attributes, & - field_names, field_counts, old_field_names, old_field_counts, & - func, time, dt, is_array) - - else if (have_option(trim(attr_key)//'/from_checkpoint_file')) then - ! don't do anything, the attribute was already loaded from file - end if - - attr_idx = attr_idx + n*dim**2 - end do - - ! Set attribute values and old_attribute values - particle => p_list%first - if (size(particle%old_attributes) == 0) then - ! no old attributes to store; only store current attributes - do j = 1, nparticles - particle%attributes = attribute_array(:,j) - particle => particle%next + ! store all the old attribute names in a contiguous list + ! for passing through to python functions + ! we also allocate the array of old attribute dims here + call copy_names_to_array(p_list%old_attr_names, old_attr_names, old_attr_counts, old_attr_dims) + call copy_names_to_array(p_list%field_names, field_names, field_counts) + call copy_names_to_array(p_list%old_field_names, old_field_names, old_field_counts, prefix="old%") + + call get_option("/geometry/dimension", dim) + allocate(vconstant(dim)) + allocate(tconstant(dim, dim)) + + ! allocate space to hold data for all particles in the group + particle => p_list%first + allocate(positions(size(particle%position), nparticles)) + allocate(attribute_array(size(particle%attributes), nparticles)) + allocate(lcoords(size(particle%local_coords), nparticles)) + allocate(ele(nparticles)) + allocate(old_attributes(size(particle%old_attributes), nparticles)) + + ! copy the data + do i = 1, nparticles + positions(:,i) = particle%position + lcoords(:,i) = particle%local_coords + ele(i) = particle%element + ! copy current attributes in case we loaded from file + attribute_array(:,i) = particle%attributes + old_attributes(:,i) = particle%old_attributes + particle => particle%next end do - else - ! else, we have to figure out which attributes - ! need to be stored as old attributes too - allocate(store_old_attr(size(particle%attributes))) + attr_idx = 1 + ! calculate new values for all attributes i_single = 1 i_array = 1 do i = 1, nscalar - n = p_list%attr_names%sn(i) - if (n == 0) then - store_old_attr(attr_idx) = have_option(trim(subgroup_path) // & - '/attributes/scalar_attribute['//int2str(i_single-1)//']/python_fields/store_old_attribute') - i_single = i_single + 1 - attr_idx = attr_idx + 1 - else - store_old_attr(attr_idx:attr_idx+n-1) = have_option(trim(subgroup_path) // & - '/attributes/scalar_attribute_array['//int2str(i_array-1)//']/python_fields/store_old_attribute') - i_array = i_array + 1 - attr_idx = attr_idx + n - end if + n = p_list%attr_names%sn(i) + + if (n == 0) then + ! single-valued attribute + attr_key = trim(subgroup_path) // '/attributes/scalar_attribute['//int2str(i_single-1)//']' + i_single = i_single + 1 + is_array = .false. + n = 1 + else + ! array-valued attribute + attr_key = trim(subgroup_path) // '/attributes/scalar_attribute_array['//int2str(i_array-1)//']' + i_array = i_array + 1 + is_array = .true. + end if + + if (have_option(trim(attr_key)//'/constant')) then + call get_option(trim(attr_key)//'/constant', constant) + attribute_array(attr_idx:attr_idx+n-1,:) = constant + + else if (have_option(trim(attr_key)//'/python')) then + call get_option(trim(attr_key)//'/python', func) + call set_particle_scalar_attribute_from_python( & + attribute_array(attr_idx:attr_idx+n-1,:), & + positions(:,:), n, func, time, dt, is_array) + + else if (have_option(trim(attr_key)//'/python_fields')) then + call get_option(trim(attr_key)//'/python_fields', func) + call set_particle_scalar_attribute_from_python_fields( & + p_list, state, positions(:,:), lcoords(:,:), ele(:), n, & + attribute_array(attr_idx:attr_idx+n-1,:), & + old_attr_names, old_attr_counts, old_attr_dims, old_attributes, & + field_names, field_counts, old_field_names, old_field_counts, & + func, time, dt, is_array) + + else if (have_option(trim(attr_key)//'/from_checkpoint_file')) then + ! don't do anything, the attribute was already loaded from file + end if + + attr_idx = attr_idx + n end do i_single = 1 i_array = 1 do i = 1, nvector - n = p_list%attr_names%vn(i) - if (n == 0) then - store_old_attr(attr_idx:attr_idx+dim-1) = have_option(trim(subgroup_path) // & - '/attributes/vector_attribute['//int2str(i_single-1)//']/python_fields/store_old_attribute') - i_single = i_single + 1 - attr_idx = attr_idx + dim - else - store_old_attr(attr_idx:attr_idx + n*dim-1) = have_option(trim(subgroup_path) // & - '/attributes/vector_attribute_array['//int2str(i_array-1)//']/python_fields/store_old_attribute') - i_array = i_array + 1 - attr_idx = attr_idx + n*dim - end if + n = p_list%attr_names%vn(i) + + if (n == 0) then + ! single-valued attribute + attr_key = trim(subgroup_path) // '/attributes/vector_attribute['//int2str(i_single-1)//']' + i_single = i_single + 1 + is_array = .false. + n = 1 + else + ! array-valued attribute + attr_key = trim(subgroup_path) // '/attributes/vector_attribute_array['//int2str(i_array-1)//']' + i_array = i_array + 1 + is_array = .true. + end if + + if (have_option(trim(attr_key)//'/constant')) then + call get_option(trim(attr_key)//'/constant', vconstant) + ! broadcast vector constant out to all particles + attribute_array(attr_idx:attr_idx+n*dim-1,:) = spread(vconstant, 2, nparticles) + + else if (have_option(trim(attr_key)//'/python')) then + call get_option(trim(attr_key)//'/python', func) + call set_particle_vector_attribute_from_python( & + attribute_array(attr_idx:attr_idx+n*dim-1,:), & + positions(:,:), n, func, time, dt, is_array) + + else if (have_option(trim(attr_key)//'/python_fields')) then + call get_option(trim(attr_key)//'/python_fields', func) + call set_particle_vector_attribute_from_python_fields( & + p_list, state, positions(:,:), lcoords(:,:), ele(:), n, & + attribute_array(attr_idx:attr_idx+n*dim-1,:), & + old_attr_names, old_attr_counts, old_attr_dims, old_attributes, & + field_names, field_counts, old_field_names, old_field_counts, & + func, time, dt, is_array) + + else if (have_option(trim(attr_key)//'/from_checkpoint_file')) then + ! don't do anything, the attribute was already loaded from file + end if + + attr_idx = attr_idx + n*dim end do i_single = 1 i_array = 1 do i = 1, ntensor - n = p_list%attr_names%tn(i) - if (n == 0) then - store_old_attr(attr_idx:attr_idx + dim**2 - 1) = have_option(trim(subgroup_path) // & - '/attributes/tensor_attribute['//int2str(i_single-1)//']/python_fields/store_old_attribute') - i_single = i_single + 1 - attr_idx = attr_idx + dim**2 - else - store_old_attr(attr_idx:attr_idx + n*dim**2 - 1) = have_option(trim(subgroup_path) // & - '/attributes/tensor_attribute_array['//int2str(i_array-1)//']/python_fields/store_old_attribute') - i_array = i_array + 1 - attr_idx = attr_idx + n*dim**2 - end if - end do + n = p_list%attr_names%tn(i) + + if (n == 0) then + ! single-valued attribute + attr_key = trim(subgroup_path) // '/attributes/tensor_attribute['//int2str(i_single-1)//']' + i_single = i_single + 1 + is_array = .false. + n = 1 + else + ! array-valued attribute + attr_key = trim(subgroup_path) // '/attributes/tensor_attribute_array['//int2str(i_array-1)//']' + i_array = i_array + 1 + is_array = .true. + end if - do j = 1, nparticles - ! store current attributes as usual - particle%attributes = attribute_array(:,j) - - ! store the old attributes which are required - m = 1 - do n = 1, size(particle%attributes) - if (store_old_attr(n)) then - particle%old_attributes(m) = particle%attributes(n) - m = m + 1 - end if - end do - particle => particle%next - end do + if (have_option(trim(attr_key)//'/constant')) then + call get_option(trim(attr_key)//'/constant', tconstant) + ! flatten tensor, then broadcast out to all particles + attribute_array(attr_idx:attr_idx+n*dim**2-1,:) = spread(reshape(tconstant, [dim**2]), 2, nparticles) + + else if (have_option(trim(attr_key)//'/python')) then + call get_option(trim(attr_key)//'/python', func) + call set_particle_tensor_attribute_from_python( & + attribute_array(attr_idx:attr_idx + n*dim**2 - 1,:), & + positions(:,:), n, func, time, dt, is_array) + + else if (have_option(trim(attr_key)//'/python_fields')) then + call get_option(trim(attr_key)//'/python_fields', func) + call set_particle_tensor_attribute_from_python_fields( & + p_list, state, positions(:,:), lcoords(:,:), ele(:), n, & + attribute_array(attr_idx:attr_idx + n*dim**2 - 1,:), & + old_attr_names, old_attr_counts, old_attr_dims, old_attributes, & + field_names, field_counts, old_field_names, old_field_counts, & + func, time, dt, is_array) + + else if (have_option(trim(attr_key)//'/from_checkpoint_file')) then + ! don't do anything, the attribute was already loaded from file + end if - deallocate(store_old_attr) - end if - - ! update old field values on the particles - call update_particle_subgroup_fields(state, ele, lcoords, p_list, old_field_counts) - - deallocate(positions) - deallocate(lcoords) - deallocate(ele) - deallocate(attribute_array) - deallocate(old_attributes) - deallocate(old_attr_names) - deallocate(old_attr_dims) - deallocate(vconstant) - deallocate(tconstant) - end subroutine update_particle_subgroup_attributes_and_fields - - !> Update old values of fields stored on particles - subroutine update_particle_subgroup_fields(state, ele, lcoords, p_list, counts) - !! Model state structure - type(state_type), dimension(:), intent(in) :: state - !! Elements containing particles - integer, dimension(:), intent(in) :: ele - !! Local particle coordinates - real, dimension(:,:), intent(in) :: lcoords - !! Particle list - type(detector_linked_list), intent(in) :: p_list - !! Number of scalar/vector/tensor old fields - integer, dimension(3), intent(in) :: counts - - integer :: i, dim, nparts - real, allocatable, dimension(:,:) :: vals - type(detector_type), pointer :: particle - - call get_option("/geometry/dimension", dim) - nparts = p_list%length - - allocate(vals(counts(1) + dim*counts(2) + dim**2*counts(3), nparts)) - - call evaluate_particle_fields(nparts, state, ele, lcoords, & - p_list%old_field_names, p_list%old_field_phases, counts, vals, dim) + attr_idx = attr_idx + n*dim**2 + end do - ! assign back to particles - particle => p_list%first - do i = 1, nparts - particle%old_fields = vals(:,i) - particle => particle%next - end do - - deallocate(vals) - end subroutine update_particle_subgroup_fields - - !! Write particle attributes for all groups that should output at the current time - subroutine write_particles_loop(state, timestep, time) - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Current timestep - integer, intent(in) :: timestep - !> Current model time - real, intent(in) :: time - - integer :: i, k - integer :: particle_groups, particle_subgroups, list_counter - character(len=OPTION_PATH_LEN) :: group_path, subgroup_path - logical :: output_group - - ewrite(1,*) "In write_particles_loop" - - particle_groups = option_count("/particles/particle_group") - - list_counter = 1 - do i = 1, particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") - - output_group = should_output(output_CS(i), time, timestep, trim(group_path) // "/particle_io") - if (output_group) then - call update_output_CS(output_CS(i), time) + ! Set attribute values and old_attribute values + particle => p_list%first + if (size(particle%old_attributes) == 0) then + ! no old attributes to store; only store current attributes + do j = 1, nparticles + particle%attributes = attribute_array(:,j) + particle => particle%next + end do else - ! skip all subgroups - list_counter = list_counter + particle_subgroups - cycle + ! else, we have to figure out which attributes + ! need to be stored as old attributes too + allocate(store_old_attr(size(particle%attributes))) + attr_idx = 1 + + i_single = 1 + i_array = 1 + do i = 1, nscalar + n = p_list%attr_names%sn(i) + if (n == 0) then + store_old_attr(attr_idx) = have_option(trim(subgroup_path) // & + '/attributes/scalar_attribute['//int2str(i_single-1)//']/python_fields/store_old_attribute') + i_single = i_single + 1 + attr_idx = attr_idx + 1 + else + store_old_attr(attr_idx:attr_idx+n-1) = have_option(trim(subgroup_path) // & + '/attributes/scalar_attribute_array['//int2str(i_array-1)//']/python_fields/store_old_attribute') + i_array = i_array + 1 + attr_idx = attr_idx + n + end if + end do + + i_single = 1 + i_array = 1 + do i = 1, nvector + n = p_list%attr_names%vn(i) + if (n == 0) then + store_old_attr(attr_idx:attr_idx+dim-1) = have_option(trim(subgroup_path) // & + '/attributes/vector_attribute['//int2str(i_single-1)//']/python_fields/store_old_attribute') + i_single = i_single + 1 + attr_idx = attr_idx + dim + else + store_old_attr(attr_idx:attr_idx + n*dim-1) = have_option(trim(subgroup_path) // & + '/attributes/vector_attribute_array['//int2str(i_array-1)//']/python_fields/store_old_attribute') + i_array = i_array + 1 + attr_idx = attr_idx + n*dim + end if + end do + + i_single = 1 + i_array = 1 + do i = 1, ntensor + n = p_list%attr_names%tn(i) + if (n == 0) then + store_old_attr(attr_idx:attr_idx + dim**2 - 1) = have_option(trim(subgroup_path) // & + '/attributes/tensor_attribute['//int2str(i_single-1)//']/python_fields/store_old_attribute') + i_single = i_single + 1 + attr_idx = attr_idx + dim**2 + else + store_old_attr(attr_idx:attr_idx + n*dim**2 - 1) = have_option(trim(subgroup_path) // & + '/attributes/tensor_attribute_array['//int2str(i_array-1)//']/python_fields/store_old_attribute') + i_array = i_array + 1 + attr_idx = attr_idx + n*dim**2 + end if + end do + + do j = 1, nparticles + ! store current attributes as usual + particle%attributes = attribute_array(:,j) + + ! store the old attributes which are required + m = 1 + do n = 1, size(particle%attributes) + if (store_old_attr(n)) then + particle%old_attributes(m) = particle%attributes(n) + m = m + 1 + end if + end do + particle => particle%next + end do + + deallocate(store_old_attr) end if - do k = 1, particle_subgroups - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" - call write_particles_subgroup(state, particle_lists(list_counter), timestep, time, trim(subgroup_path)) - list_counter = list_counter + 1 + ! update old field values on the particles + call update_particle_subgroup_fields(state, ele, lcoords, p_list, old_field_counts) + + deallocate(positions) + deallocate(lcoords) + deallocate(ele) + deallocate(attribute_array) + deallocate(old_attributes) + deallocate(old_attr_names) + deallocate(old_attr_dims) + deallocate(vconstant) + deallocate(tconstant) + end subroutine update_particle_subgroup_attributes_and_fields + + !> Update old values of fields stored on particles + subroutine update_particle_subgroup_fields(state, ele, lcoords, p_list, counts) + !! Model state structure + type(state_type), dimension(:), intent(in) :: state + !! Elements containing particles + integer, dimension(:), intent(in) :: ele + !! Local particle coordinates + real, dimension(:,:), intent(in) :: lcoords + !! Particle list + type(detector_linked_list), intent(in) :: p_list + !! Number of scalar/vector/tensor old fields + integer, dimension(3), intent(in) :: counts + + integer :: i, dim, nparts + real, allocatable, dimension(:,:) :: vals + type(detector_type), pointer :: particle + + call get_option("/geometry/dimension", dim) + nparts = p_list%length + + allocate(vals(counts(1) + dim*counts(2) + dim**2*counts(3), nparts)) + + call evaluate_particle_fields(nparts, state, ele, lcoords, & + p_list%old_field_names, p_list%old_field_phases, counts, vals, dim) + + ! assign back to particles + particle => p_list%first + do i = 1, nparts + particle%old_fields = vals(:,i) + particle => particle%next end do - end do - end subroutine write_particles_loop - - !> Write particle attributes for a given subgroup - subroutine write_particles_subgroup(state, detector_list, timestep, time, subgroup_path) - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> The particle subgroup data structure - type(detector_linked_list), intent(inout) :: detector_list - !> Current model timestep (to record in output file) - integer, intent(in) :: timestep - !> Current model time (to record in output file) - real, intent(in) :: time - !> Path prefix for the subgroup in options - character(len=*), intent(in) :: subgroup_path - - integer :: dim, i, tot_atts - integer(kind=8) :: h5_ierror - real, dimension(:,:), allocatable :: positions, attrib_data - integer, dimension(:), allocatable :: node_ids, proc_ids - type(detector_type), pointer :: node - - ewrite(1,*) "In write_particles" - - ! create new step -- create them sequentially so they're easy to iterate - h5_ierror = h5_setstep(detector_list%h5_id, h5_getnsteps(detector_list%h5_id) + 1) - - ! write time and timestep as step attributes - h5_ierror = h5_writestepattrib_r8(detector_list%h5_id, "time", [time], int(1, 8)) - h5_ierror = h5_writestepattrib_i8(detector_list%h5_id, "timestep", [int(timestep, 8)], int(1, 8)) - - ! set the number of particles this process is going to write - h5_ierror = h5pt_setnpoints(detector_list%h5_id, int(detector_list%length, 8)) - - ! set up arrays to hold all node data - call get_option("/geometry/dimension", dim) - tot_atts = detector_list%total_attributes(1) - allocate(positions(detector_list%length, 3)) - allocate(attrib_data(detector_list%length, tot_atts)) - allocate(node_ids(detector_list%length)) - allocate(proc_ids(detector_list%length)) - - node => detector_list%first - position_loop: do i = 1, detector_list%length - assert(size(node%position) == dim) - assert(size(node%attributes) == tot_atts) - - positions(i,1:dim) = node%position(:) - attrib_data(i,:) = node%attributes(:) - node_ids(i) = node%id_number - proc_ids(i) = node%proc_id - - node => node%next - end do position_loop - - ! write out position - if (dim >= 1) & + + deallocate(vals) + end subroutine update_particle_subgroup_fields + + !! Write particle attributes for all groups that should output at the current time + subroutine write_particles_loop(state, timestep, time) + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Current timestep + integer, intent(in) :: timestep + !> Current model time + real, intent(in) :: time + + integer :: i, k + integer :: particle_groups, particle_subgroups, list_counter + character(len=OPTION_PATH_LEN) :: group_path, subgroup_path + logical :: output_group + + ewrite(1,*) "In write_particles_loop" + + particle_groups = option_count("/particles/particle_group") + + list_counter = 1 + do i = 1, particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") + + output_group = should_output(output_CS(i), time, timestep, trim(group_path) // "/particle_io") + if (output_group) then + call update_output_CS(output_CS(i), time) + else + ! skip all subgroups + list_counter = list_counter + particle_subgroups + cycle + end if + + do k = 1, particle_subgroups + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(k-1)//"]" + call write_particles_subgroup(state, particle_lists(list_counter), timestep, time, trim(subgroup_path)) + list_counter = list_counter + 1 + end do + end do + end subroutine write_particles_loop + + !> Write particle attributes for a given subgroup + subroutine write_particles_subgroup(state, detector_list, timestep, time, subgroup_path) + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> The particle subgroup data structure + type(detector_linked_list), intent(inout) :: detector_list + !> Current model timestep (to record in output file) + integer, intent(in) :: timestep + !> Current model time (to record in output file) + real, intent(in) :: time + !> Path prefix for the subgroup in options + character(len=*), intent(in) :: subgroup_path + + integer :: dim, i, tot_atts + integer(kind=8) :: h5_ierror + real, dimension(:,:), allocatable :: positions, attrib_data + integer, dimension(:), allocatable :: node_ids, proc_ids + type(detector_type), pointer :: node + + ewrite(1,*) "In write_particles" + + ! create new step -- create them sequentially so they're easy to iterate + h5_ierror = h5_setstep(detector_list%h5_id, h5_getnsteps(detector_list%h5_id) + 1) + + ! write time and timestep as step attributes + h5_ierror = h5_writestepattrib_r8(detector_list%h5_id, "time", [time], int(1, 8)) + h5_ierror = h5_writestepattrib_i8(detector_list%h5_id, "timestep", [int(timestep, 8)], int(1, 8)) + + ! set the number of particles this process is going to write + h5_ierror = h5pt_setnpoints(detector_list%h5_id, int(detector_list%length, 8)) + + ! set up arrays to hold all node data + call get_option("/geometry/dimension", dim) + tot_atts = detector_list%total_attributes(1) + allocate(positions(detector_list%length, 3)) + allocate(attrib_data(detector_list%length, tot_atts)) + allocate(node_ids(detector_list%length)) + allocate(proc_ids(detector_list%length)) + + node => detector_list%first + position_loop: do i = 1, detector_list%length + assert(size(node%position) == dim) + assert(size(node%attributes) == tot_atts) + + positions(i,1:dim) = node%position(:) + attrib_data(i,:) = node%attributes(:) + node_ids(i) = node%id_number + proc_ids(i) = node%proc_id + + node => node%next + end do position_loop + + ! write out position + if (dim >= 1) & h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "x", positions(:,1)) - if (dim >= 2) & + if (dim >= 2) & h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "y", positions(:,2)) - if (dim >= 3) then - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) - else - positions(:,3) = 0. - h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) - end if - - h5_ierror = h5pt_writedata_i4(detector_list%h5_id, "id", node_ids(:)) - h5_ierror = h5pt_writedata_i4(detector_list%h5_id, "proc_id", proc_ids(:)) - - call write_attrs(detector_list%h5_id, dim, detector_list%attr_names, attrib_data, to_write=detector_list%attr_write) - - h5_ierror = h5_flushstep(detector_list%h5_id) - - deallocate(proc_ids) - deallocate(node_ids) - deallocate(attrib_data) - deallocate(positions) - end subroutine write_particles_subgroup - - !> Write attributes with given names to an H5Part file - subroutine write_attrs(h5_id, dim, names, vals, prefix, to_write) - !> h5 file to write to - integer(kind=8), intent(in) :: h5_id - !> spatial dimension - integer, intent(in) :: dim - !> attribute names to write to the file - type(attr_names_type), intent(in) :: names - !> attribute values, ordered by position/rank as they are on particles - real, dimension(:,:), intent(in) :: vals - !> Optional prefix to attribute names - character(len=*), intent(in), optional :: prefix - !> Optional control of which attributes to write - type(attr_write_type), intent(in), optional :: to_write - - integer :: i, j, k, att, ii - integer(kind=8) :: h5_ierror - character(len=FIELD_NAME_LEN) :: p - logical :: write_attr - - p = "" - if (present(prefix)) p = prefix - - write_attr = .true. - - ! write out attributes -- scalar, vector, tensor - att = 1 - scalar_attr_loop: do i = 1, size(names%s) - ! booleans aren't short-circuiting, so we have to stack here - if (present(to_write)) then - write_attr = to_write%s(i) - end if - - if (names%sn(i) == 0) then - ! single-valued attribute - if (write_attr) & - h5_ierror = h5pt_writedata_r8(h5_id, & - trim(p)//trim(names%s(i)), vals(:,att)) - att = att + 1 + if (dim >= 3) then + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) else - do ii = 1, names%sn(i) - ! inner loop for array-valued attribute - if (write_attr) & - h5_ierror = h5pt_writedata_r8(h5_id, & - trim(p)//trim(names%s(i))//int2str(ii), vals(:,att)) - att = att + 1 - end do + positions(:,3) = 0. + h5_ierror = h5pt_writedata_r8(detector_list%h5_id, "z", positions(:,3)) end if - end do scalar_attr_loop - vector_attr_loop: do i = 1, size(names%v) - if (present(to_write)) then - write_attr = to_write%v(i) - end if + h5_ierror = h5pt_writedata_i4(detector_list%h5_id, "id", node_ids(:)) + h5_ierror = h5pt_writedata_i4(detector_list%h5_id, "proc_id", proc_ids(:)) + + call write_attrs(detector_list%h5_id, dim, detector_list%attr_names, attrib_data, to_write=detector_list%attr_write) + + h5_ierror = h5_flushstep(detector_list%h5_id) + + deallocate(proc_ids) + deallocate(node_ids) + deallocate(attrib_data) + deallocate(positions) + end subroutine write_particles_subgroup + + !> Write attributes with given names to an H5Part file + subroutine write_attrs(h5_id, dim, names, vals, prefix, to_write) + !> h5 file to write to + integer(kind=8), intent(in) :: h5_id + !> spatial dimension + integer, intent(in) :: dim + !> attribute names to write to the file + type(attr_names_type), intent(in) :: names + !> attribute values, ordered by position/rank as they are on particles + real, dimension(:,:), intent(in) :: vals + !> Optional prefix to attribute names + character(len=*), intent(in), optional :: prefix + !> Optional control of which attributes to write + type(attr_write_type), intent(in), optional :: to_write + + integer :: i, j, k, att, ii + integer(kind=8) :: h5_ierror + character(len=FIELD_NAME_LEN) :: p + logical :: write_attr + + p = "" + if (present(prefix)) p = prefix + + write_attr = .true. + + ! write out attributes -- scalar, vector, tensor + att = 1 + scalar_attr_loop: do i = 1, size(names%s) + ! booleans aren't short-circuiting, so we have to stack here + if (present(to_write)) then + write_attr = to_write%s(i) + end if - if (names%vn(i) == 0) then - do j = 1, dim - if (write_attr) & - h5_ierror = h5pt_writedata_r8(h5_id, & - trim(p)//trim(names%v(i))//"_"//int2str(j-1), vals(:,att)) - att = att + 1 - end do - else - do ii = 1, names%vn(i) - do j = 1, dim + if (names%sn(i) == 0) then + ! single-valued attribute if (write_attr) & - h5_ierror = h5pt_writedata_r8(h5_id, & - trim(p)//trim(names%v(i))//int2str(ii)//"_"//int2str(j-1), vals(:,att)) + h5_ierror = h5pt_writedata_r8(h5_id, & + trim(p)//trim(names%s(i)), vals(:,att)) att = att + 1 - end do - end do - end if - end do vector_attr_loop + else + do ii = 1, names%sn(i) + ! inner loop for array-valued attribute + if (write_attr) & + h5_ierror = h5pt_writedata_r8(h5_id, & + trim(p)//trim(names%s(i))//int2str(ii), vals(:,att)) + att = att + 1 + end do + end if + end do scalar_attr_loop - tensor_attr_loop: do i = 1, size(names%t) - if (present(to_write)) then - write_attr = to_write%t(i) - end if + vector_attr_loop: do i = 1, size(names%v) + if (present(to_write)) then + write_attr = to_write%v(i) + end if - if (names%tn(i) == 0) then - do j = 1, dim - do k = 1, dim - if (write_attr) & - h5_ierror = h5pt_writedata_r8(h5_id, & - trim(p)//trim(names%t(i))//"_"//int2str((k-1)*dim + (j-1)), vals(:,att)) - att = att + 1 - end do - end do - else - do ii = 1, names%tn(i) - do j = 1, dim - do k = 1, dim - if (write_attr) & - h5_ierror = h5pt_writedata_r8(h5_id, & - trim(p)//trim(names%t(i))//int2str(ii)//"_"//int2str((k-1)*dim + (j-1)), vals(:,att)) - att = att + 1 + if (names%vn(i) == 0) then + do j = 1, dim + if (write_attr) & + h5_ierror = h5pt_writedata_r8(h5_id, & + trim(p)//trim(names%v(i))//"_"//int2str(j-1), vals(:,att)) + att = att + 1 end do - end do - end do + else + do ii = 1, names%vn(i) + do j = 1, dim + if (write_attr) & + h5_ierror = h5pt_writedata_r8(h5_id, & + trim(p)//trim(names%v(i))//int2str(ii)//"_"//int2str(j-1), vals(:,att)) + att = att + 1 + end do + end do + end if + end do vector_attr_loop + + tensor_attr_loop: do i = 1, size(names%t) + if (present(to_write)) then + write_attr = to_write%t(i) + end if + + if (names%tn(i) == 0) then + do j = 1, dim + do k = 1, dim + if (write_attr) & + h5_ierror = h5pt_writedata_r8(h5_id, & + trim(p)//trim(names%t(i))//"_"//int2str((k-1)*dim + (j-1)), vals(:,att)) + att = att + 1 + end do + end do + else + do ii = 1, names%tn(i) + do j = 1, dim + do k = 1, dim + if (write_attr) & + h5_ierror = h5pt_writedata_r8(h5_id, & + trim(p)//trim(names%t(i))//int2str(ii)//"_"//int2str((k-1)*dim + (j-1)), vals(:,att)) + att = att + 1 + end do + end do + end do + end if + end do tensor_attr_loop + end subroutine write_attrs + + !> Checkpoint all particles, by subgroup + subroutine checkpoint_particles_loop(state, prefix, postfix, cp_no, number_of_partitions) + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Checkpoint filename prefix + character(len=*), intent(in) :: prefix + !> Checkpoint filename postfix (e.g. flredecomp) + character(len=*), intent(in) :: postfix + !> Checkpoint number of the simulation + integer, optional, intent(in) :: cp_no + !> Only write data for this many processes (flredecomp to more partitions needs this) + integer, optional, intent(in) :: number_of_partitions + + integer :: i, j, particle_groups, particle_subgroups, list_counter + character(len=OPTION_PATH_LEN) :: group_path, subgroup_path, subgroup_path_name, name + type(vector_field), pointer :: xfield + + integer :: output_comm, world_group, output_group, ierr + + ! create a new mpi group for active particles only + ! otherwise the collectives (and especially file writing) will break + + xfield => extract_vector_field(state(1), "Coordinate") + if (present(number_of_partitions)) then + if (getprocno() > number_of_partitions) return + + call mpi_comm_group(MPI_COMM_FEMTOOLS, world_group, ierr) + call mpi_group_incl(world_group, number_of_partitions, & + [(i, i=0, number_of_partitions-1)], output_group, ierr) + call mpi_comm_create_group(MPI_COMM_FEMTOOLS, output_group, 0, output_comm, ierr) + else + output_comm = MPI_COMM_FEMTOOLS end if - end do tensor_attr_loop - end subroutine write_attrs - - !> Checkpoint all particles, by subgroup - subroutine checkpoint_particles_loop(state, prefix, postfix, cp_no, number_of_partitions) - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Checkpoint filename prefix - character(len=*), intent(in) :: prefix - !> Checkpoint filename postfix (e.g. flredecomp) - character(len=*), intent(in) :: postfix - !> Checkpoint number of the simulation - integer, optional, intent(in) :: cp_no - !> Only write data for this many processes (flredecomp to more partitions needs this) - integer, optional, intent(in) :: number_of_partitions - - integer :: i, j, particle_groups, particle_subgroups, list_counter - character(len=OPTION_PATH_LEN) :: group_path, subgroup_path, subgroup_path_name, name - type(vector_field), pointer :: xfield - - integer :: output_comm, world_group, output_group, ierr - - ! create a new mpi group for active particles only - ! otherwise the collectives (and especially file writing) will break - - xfield => extract_vector_field(state(1), "Coordinate") - if (present(number_of_partitions)) then - if (getprocno() > number_of_partitions) return - - call mpi_comm_group(MPI_COMM_FEMTOOLS, world_group, ierr) - call mpi_group_incl(world_group, number_of_partitions, & - [(i, i=0, number_of_partitions-1)], output_group, ierr) - call mpi_comm_create_group(MPI_COMM_FEMTOOLS, output_group, 0, output_comm, ierr) - else - output_comm = MPI_COMM_FEMTOOLS - end if - - particle_groups = option_count("/particles/particle_group") - - ewrite(1, *) "Checkpointing particles" - - assert(len_trim(prefix) > 0) - - list_counter = 1 - do i = 1, particle_groups - group_path = "/particles/particle_group["//int2str(i-1)//"]" - particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") - do j = 1, particle_subgroups - ! set the path to this subgroup, and the path used in update_particle_options - subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(j-1)//"]" - subgroup_path_name = trim(group_path) // "/particle_subgroup::" - call get_option(trim(subgroup_path) // "/name", name) - - ! skip checkpointing this subgroup if we're coming from flredecomp - ! and the particles weren't loaded from a file - if (present(number_of_partitions) .and. & - .not. have_option(trim(subgroup_path) // "/initial_position/from_file")) then - cycle - end if - - !Ensure all particles are local before checkpointing - if (present(number_of_partitions)) then - !Don't call distribute detectors if in flredecomp - else - call distribute_detectors(state(1),particle_lists(list_counter),positions = xfield) - end if - !Checkpoint particle group - call checkpoint_particles_subgroup(state, prefix, postfix, cp_no, particle_lists(list_counter), & - name, subgroup_path, subgroup_path_name, output_comm) - list_counter = list_counter + 1 + + particle_groups = option_count("/particles/particle_group") + + ewrite(1, *) "Checkpointing particles" + + assert(len_trim(prefix) > 0) + + list_counter = 1 + do i = 1, particle_groups + group_path = "/particles/particle_group["//int2str(i-1)//"]" + particle_subgroups = option_count(trim(group_path) // "/particle_subgroup") + do j = 1, particle_subgroups + ! set the path to this subgroup, and the path used in update_particle_options + subgroup_path = trim(group_path) // "/particle_subgroup["//int2str(j-1)//"]" + subgroup_path_name = trim(group_path) // "/particle_subgroup::" + call get_option(trim(subgroup_path) // "/name", name) + + ! skip checkpointing this subgroup if we're coming from flredecomp + ! and the particles weren't loaded from a file + if (present(number_of_partitions) .and. & + .not. have_option(trim(subgroup_path) // "/initial_position/from_file")) then + cycle + end if + + !Ensure all particles are local before checkpointing + if (present(number_of_partitions)) then + !Don't call distribute detectors if in flredecomp + else + call distribute_detectors(state(1),particle_lists(list_counter),positions = xfield) + end if + !Checkpoint particle group + call checkpoint_particles_subgroup(state, prefix, postfix, cp_no, particle_lists(list_counter), & + name, subgroup_path, subgroup_path_name, output_comm) + list_counter = list_counter + 1 + end do end do - end do - - ! clean up mpi structures - if (present(number_of_partitions)) then - call mpi_comm_free(output_comm, ierr) - call mpi_group_free(output_group, ierr) - end if - end subroutine checkpoint_particles_loop - - !> Checkpoint a single particle subgroup - subroutine checkpoint_particles_subgroup(state, prefix, postfix, cp_no, particle_list, & - name, subgroup_path, subgroup_path_name, output_comm) - !> Model state structure - type(state_type), dimension(:), intent(in) :: state - !> Checkpoint filename prefix - character(len=*), intent(in) :: prefix - !> Checkpoint filename postfix - character(len=*), intent(in) :: postfix - !> Checkpoint number of the simulation - integer, optional, intent(in) :: cp_no - !> Particle list for the subgroup - type(detector_linked_list), intent(inout) :: particle_list - !> Particle subgroup name - character(len=*), intent(in) :: name - !> Option subgroup path, and the prefix used for updating options - character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path, subgroup_path_name - !> MPI communicator to use for output/collectives - integer, optional, intent(in) :: output_comm - - character(len=OPTION_PATH_LEN) :: particles_cp_filename - integer :: i, dim, tot_attrs, tot_old_attrs, tot_old_fields - real, dimension(:,:), allocatable :: positions, attr_data, old_attr_data, old_field_data - integer(kind=8) :: h5_id, h5_prop, h5_ierror - integer(kind=8), dimension(:), allocatable :: npoints - integer, dimension(:), allocatable :: node_ids, proc_ids - type(detector_type), pointer :: node - - integer :: comm, commsize, ierr - comm = MPI_COMM_FEMTOOLS - if (present(output_comm)) comm = output_comm - - ! we store the number of points per process, so gather them - ! this is because h5part attributes must be agreed upon by all, - ! so every process needs to know the size for every other process - ! we also store the proc_part_count to ensure newly spawned - ! particles after checkpointing remain unique - call mpi_comm_size(comm, commsize, ierr) - allocate(npoints(commsize*2)) - call mpi_allgather([int(particle_list%length, 8), int(particle_list%proc_part_count, 8)], & + + ! clean up mpi structures + if (present(number_of_partitions)) then + call mpi_comm_free(output_comm, ierr) + call mpi_group_free(output_group, ierr) + end if + end subroutine checkpoint_particles_loop + + !> Checkpoint a single particle subgroup + subroutine checkpoint_particles_subgroup(state, prefix, postfix, cp_no, particle_list, & + name, subgroup_path, subgroup_path_name, output_comm) + !> Model state structure + type(state_type), dimension(:), intent(in) :: state + !> Checkpoint filename prefix + character(len=*), intent(in) :: prefix + !> Checkpoint filename postfix + character(len=*), intent(in) :: postfix + !> Checkpoint number of the simulation + integer, optional, intent(in) :: cp_no + !> Particle list for the subgroup + type(detector_linked_list), intent(inout) :: particle_list + !> Particle subgroup name + character(len=*), intent(in) :: name + !> Option subgroup path, and the prefix used for updating options + character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path, subgroup_path_name + !> MPI communicator to use for output/collectives + integer, optional, intent(in) :: output_comm + + character(len=OPTION_PATH_LEN) :: particles_cp_filename + integer :: i, dim, tot_attrs, tot_old_attrs, tot_old_fields + real, dimension(:,:), allocatable :: positions, attr_data, old_attr_data, old_field_data + integer(kind=8) :: h5_id, h5_prop, h5_ierror + integer(kind=8), dimension(:), allocatable :: npoints + integer, dimension(:), allocatable :: node_ids, proc_ids + type(detector_type), pointer :: node + + integer :: comm, commsize, ierr + comm = MPI_COMM_FEMTOOLS + if (present(output_comm)) comm = output_comm + + ! we store the number of points per process, so gather them + ! this is because h5part attributes must be agreed upon by all, + ! so every process needs to know the size for every other process + ! we also store the proc_part_count to ensure newly spawned + ! particles after checkpointing remain unique + call mpi_comm_size(comm, commsize, ierr) + allocate(npoints(commsize*2)) + call mpi_allgather([int(particle_list%length, 8), int(particle_list%proc_part_count, 8)], & 2, MPI_INTEGER8, & npoints, 2, MPI_INTEGER8, comm, ierr) - ! construct a new particle checkpoint filename - particles_cp_filename = trim(prefix) - if(present(cp_no)) particles_cp_filename = trim(particles_cp_filename) // "_" // int2str(cp_no) - particles_cp_filename = trim(particles_cp_filename) // "_" // trim(postfix) - particles_cp_filename = trim(particles_cp_filename) // "_particles." // trim(name) // ".h5part" - - ! restrict h5 IO to the specified communicator - h5_prop = h5_createprop_file() - h5_ierror = h5_setprop_file_mpio_collective(h5_prop, comm) - - ! open output file - h5_id = h5_openfile(trim(particles_cp_filename), H5_O_WRONLY, h5_prop) - h5_ierror = h5_closeprop(h5_prop) - ! write out number of points per process - h5_ierror = h5_writefileattrib_i8(h5_id, "npoints", npoints(1::2), int(commsize, 8)) - ! write out per-processor particle count, for unique spawning - h5_ierror = h5_writefileattrib_i8(h5_id, "part_counter", npoints(2::2), int(commsize, 8)) - ! write data in the first step - h5_ierror = h5_setstep(h5_id, int(1, 8)) - ! the number of points this process is writing - h5_ierror = h5pt_setnpoints(h5_id, int(particle_list%length, 8)) - - ! get dimension of particle positions - call get_option("/geometry/dimension", dim) - - tot_attrs = particle_list%total_attributes(1) - tot_old_attrs = particle_list%total_attributes(2) - tot_old_fields = particle_list%total_attributes(3) - - ! allocate arrays for node data - allocate(positions(particle_list%length, dim)) - allocate(node_ids(particle_list%length)) - allocate(proc_ids(particle_list%length)) - allocate(attr_data(particle_list%length, tot_attrs)) - allocate(old_attr_data(particle_list%length, tot_old_attrs)) - allocate(old_field_data(particle_list%length, tot_old_fields)) - - ! gather data off all particles - node => particle_list%first - positionloop_cp: do i = 1, particle_list%length - ! collect positions - assert(size(node%position) == dim) - - positions(i,:) = node%position(:) - if (tot_attrs /= 0) & - attr_data(i,:) = node%attributes(:) - if (tot_old_attrs /= 0) & - old_attr_data(i,:) = node%old_attributes(:) - if (tot_old_fields /= 0) & - old_field_data(i,:) = node%old_fields(:) - - ! collect node ids - node_ids(i) = node%id_number - proc_ids(i) = node%proc_id - - node => node%next - end do positionloop_cp - - ! write out positions and ids - if (dim >= 1) & + ! construct a new particle checkpoint filename + particles_cp_filename = trim(prefix) + if(present(cp_no)) particles_cp_filename = trim(particles_cp_filename) // "_" // int2str(cp_no) + particles_cp_filename = trim(particles_cp_filename) // "_" // trim(postfix) + particles_cp_filename = trim(particles_cp_filename) // "_particles." // trim(name) // ".h5part" + + ! restrict h5 IO to the specified communicator + h5_prop = h5_createprop_file() + h5_ierror = h5_setprop_file_mpio_collective(h5_prop, comm) + + ! open output file + h5_id = h5_openfile(trim(particles_cp_filename), H5_O_WRONLY, h5_prop) + h5_ierror = h5_closeprop(h5_prop) + ! write out number of points per process + h5_ierror = h5_writefileattrib_i8(h5_id, "npoints", npoints(1::2), int(commsize, 8)) + ! write out per-processor particle count, for unique spawning + h5_ierror = h5_writefileattrib_i8(h5_id, "part_counter", npoints(2::2), int(commsize, 8)) + ! write data in the first step + h5_ierror = h5_setstep(h5_id, int(1, 8)) + ! the number of points this process is writing + h5_ierror = h5pt_setnpoints(h5_id, int(particle_list%length, 8)) + + ! get dimension of particle positions + call get_option("/geometry/dimension", dim) + + tot_attrs = particle_list%total_attributes(1) + tot_old_attrs = particle_list%total_attributes(2) + tot_old_fields = particle_list%total_attributes(3) + + ! allocate arrays for node data + allocate(positions(particle_list%length, dim)) + allocate(node_ids(particle_list%length)) + allocate(proc_ids(particle_list%length)) + allocate(attr_data(particle_list%length, tot_attrs)) + allocate(old_attr_data(particle_list%length, tot_old_attrs)) + allocate(old_field_data(particle_list%length, tot_old_fields)) + + ! gather data off all particles + node => particle_list%first + positionloop_cp: do i = 1, particle_list%length + ! collect positions + assert(size(node%position) == dim) + + positions(i,:) = node%position(:) + if (tot_attrs /= 0) & + attr_data(i,:) = node%attributes(:) + if (tot_old_attrs /= 0) & + old_attr_data(i,:) = node%old_attributes(:) + if (tot_old_fields /= 0) & + old_field_data(i,:) = node%old_fields(:) + + ! collect node ids + node_ids(i) = node%id_number + proc_ids(i) = node%proc_id + + node => node%next + end do positionloop_cp + + ! write out positions and ids + if (dim >= 1) & h5_ierror = h5pt_writedata_r8(h5_id, "x", positions(:,1)) - if (dim >= 2) & + if (dim >= 2) & h5_ierror = h5pt_writedata_r8(h5_id, "y", positions(:,2)) - if (dim >= 3) & + if (dim >= 3) & h5_ierror = h5pt_writedata_r8(h5_id, "z", positions(:,3)) - h5_ierror = h5pt_writedata_i4(h5_id, "id", node_ids(:)) - h5_ierror = h5pt_writedata_i4(h5_id, "proc_id", proc_ids(:)) + h5_ierror = h5pt_writedata_i4(h5_id, "id", node_ids(:)) + h5_ierror = h5pt_writedata_i4(h5_id, "proc_id", proc_ids(:)) - call write_attrs(h5_id, dim, particle_list%attr_names, attr_data) - call write_attrs(h5_id, dim, particle_list%old_attr_names, old_attr_data) - call write_attrs(h5_id, dim, particle_list%old_field_names, old_field_data, prefix="old%") + call write_attrs(h5_id, dim, particle_list%attr_names, attr_data) + call write_attrs(h5_id, dim, particle_list%old_attr_names, old_attr_data) + call write_attrs(h5_id, dim, particle_list%old_field_names, old_field_data, prefix="old%") - ! update schema file to read this subgroup from the checkpoint file - call update_particle_subgroup_options(trim(particles_cp_filename), particle_list, name, & + ! update schema file to read this subgroup from the checkpoint file + call update_particle_subgroup_options(trim(particles_cp_filename), particle_list, name, & tot_attrs, subgroup_path_name) - deallocate(old_field_data) - deallocate(old_attr_data) - deallocate(node_ids) - deallocate(proc_ids) - deallocate(attr_data) - deallocate(positions) - deallocate(npoints) + deallocate(old_field_data) + deallocate(old_attr_data) + deallocate(node_ids) + deallocate(proc_ids) + deallocate(attr_data) + deallocate(positions) + deallocate(npoints) - h5_ierror = h5_closefile(h5_id) - end subroutine checkpoint_particles_subgroup + h5_ierror = h5_closefile(h5_id) + end subroutine checkpoint_particles_subgroup - subroutine update_particle_subgroup_options(filename, particle_list, name, tot_atts, subgroup_path_name) - !! Updates the initial options of particles in the schema file for reinitialization after checkpointing. - !! Updates schema options for the initial number of particles and their initial positions. + subroutine update_particle_subgroup_options(filename, particle_list, name, tot_atts, subgroup_path_name) + !! Updates the initial options of particles in the schema file for reinitialization after checkpointing. + !! Updates schema options for the initial number of particles and their initial positions. - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: name + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: name - type(detector_linked_list), intent(inout) :: particle_list - integer, intent(in) :: tot_atts - character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path_name + type(detector_linked_list), intent(inout) :: particle_list + integer, intent(in) :: tot_atts + character(len=OPTION_PATH_LEN), intent(in) :: subgroup_path_name - integer :: num_particles, j, stat - logical :: particles_s, particles_v, particles_t + integer :: num_particles, j, stat + logical :: particles_s, particles_v, particles_t - character(len = 254) :: temp_string + character(len = 254) :: temp_string - num_particles = particle_list%total_num_det + num_particles = particle_list%total_num_det - temp_string=name + temp_string=name - ewrite(1,*) 'In update_particles_options' - ewrite(1,*) temp_string + ewrite(1,*) 'In update_particles_options' + ewrite(1,*) temp_string - call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/initial_position") + call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/initial_position") - call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/initial_position/from_file/file_name", trim(filename), stat) - call set_option(trim(subgroup_path_name) // trim(temp_string) // "/initial_position/from_file/number_of_particles", num_particles, stat = stat) + call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/initial_position/from_file/file_name", trim(filename), stat) + call set_option(trim(subgroup_path_name) // trim(temp_string) // "/initial_position/from_file/number_of_particles", num_particles, stat = stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then - FLAbort("Failed to set particles options filename when checkpointing particles with option path " // "/particles/particle_array::" // trim(temp_string)) - end if + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + FLAbort("Failed to set particles options filename when checkpointing particles with option path " // "/particles/particle_array::" // trim(temp_string)) + end if - do j = 1, tot_atts - particles_s = have_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/scalar_attribute["//int2str(j-1)//"]/constant") - particles_v = have_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/vector_attribute["//int2str(j-1)//"]/constant") - particles_t = have_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/tensor_attribute["//int2str(j-1)//"]/constant") - if (particles_s) then - call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/scalar_attribute["//int2str(j-1)//"]/constant") - call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/attributes/scalar_attribute["//int2str(j-1)// & - "]/from_checkpoint_file/file_name", trim(filename) // "." // trim(temp_string), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then - FLAbort("Failed to set scalar field particles filename when checkpointing") - end if - else if (particles_v) then - call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/vector_attribute["//int2str(j-1)//"]/constant") - call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/attributes/vector_attribute["//int2str(j-1)// & + do j = 1, tot_atts + particles_s = have_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/scalar_attribute["//int2str(j-1)//"]/constant") + particles_v = have_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/vector_attribute["//int2str(j-1)//"]/constant") + particles_t = have_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/tensor_attribute["//int2str(j-1)//"]/constant") + if (particles_s) then + call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/scalar_attribute["//int2str(j-1)//"]/constant") + call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/attributes/scalar_attribute["//int2str(j-1)// & "]/from_checkpoint_file/file_name", trim(filename) // "." // trim(temp_string), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then - FLAbort("Failed to set vector field particles filename when checkpointing") - end if - else if (particles_t) then - call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/tensor_attribute["//int2str(j-1)//"]/constant") - call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/attributes/tensor_attribute["//int2str(j-1)// & + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + FLAbort("Failed to set scalar field particles filename when checkpointing") + end if + else if (particles_v) then + call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/vector_attribute["//int2str(j-1)//"]/constant") + call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/attributes/vector_attribute["//int2str(j-1)// & + "]/from_checkpoint_file/file_name", trim(filename) // "." // trim(temp_string), stat) + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + FLAbort("Failed to set vector field particles filename when checkpointing") + end if + else if (particles_t) then + call delete_option(trim(subgroup_path_name) // trim(temp_string) // "/attributes/tensor_attribute["//int2str(j-1)//"]/constant") + call set_option_attribute(trim(subgroup_path_name) // trim(temp_string) // "/attributes/tensor_attribute["//int2str(j-1)// & "]/from_checkpoint_file/file_name", trim(filename) // "." // trim(temp_string), stat) - if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then - FLAbort("Failed to set tensor field particles filename when checkpointing") - end if - end if - end do - - end subroutine update_particle_subgroup_options - - subroutine get_particles(p_array, p_allocated) - !Send particle arrays to another routine - - type(detector_linked_list), allocatable, dimension(:), intent(out) :: p_array - integer, intent(out) :: p_allocated - - integer :: i, particle_groups - - particle_groups = option_count("/particles/particle_group") - if (particle_groups==0) then - FLAbort("No particle groups exist") - return - end if - - if (allocated(particle_lists)) then - p_allocated = 1 - allocate(p_array(size(particle_lists))) - do i = 1,size(particle_lists) - p_array(i) = particle_lists(i) - end do - else - p_allocated = 0 - end if - - end subroutine get_particles - - subroutine get_particle_arrays(lgroup, group_arrays, group_attribute, att_n, lattribute) - !Read in a particle group and attribute name or particle subgroup, send back numbers of particle arrays and particle attribute - - character(len=OPTION_PATH_LEN), intent(in) :: lgroup - character(len=OPTION_PATH_LEN), optional, intent(in) :: lattribute - integer, allocatable, dimension(:), intent(out) :: group_arrays - integer, optional, intent(out) :: group_attribute - integer, optional, intent(in) :: att_n - - character(len=OPTION_PATH_LEN) :: group_name, attribute_name - integer :: particle_groups, array_counter, particle_subgroups, particle_attributes - integer :: i, j, k, l - - logical :: found_attribute - - particle_groups = option_count("/particles/particle_group") - - found_attribute = .false. - array_counter = 0 - do i = 1, particle_groups - call get_option("/particles/particle_group["//int2str(i-1)//"]/name", group_name) - particle_subgroups = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup") - if (trim(group_name)==trim(lgroup)) then - allocate(group_arrays(particle_subgroups)) - if (present(lattribute)) then - if (att_n==0) then - particle_attributes = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)//"]/attributes/scalar_attribute") - do k = 1, particle_attributes - call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)// & + if(stat /= SPUD_NO_ERROR .and. stat /= SPUD_NEW_KEY_WARNING .and. stat /= SPUD_ATTR_SET_FAILED_WARNING) then + FLAbort("Failed to set tensor field particles filename when checkpointing") + end if + end if + end do + + end subroutine update_particle_subgroup_options + + subroutine get_particles(p_array, p_allocated) + !Send particle arrays to another routine + + type(detector_linked_list), allocatable, dimension(:), intent(out) :: p_array + integer, intent(out) :: p_allocated + + integer :: i, particle_groups + + particle_groups = option_count("/particles/particle_group") + if (particle_groups==0) then + FLAbort("No particle groups exist") + return + end if + + if (allocated(particle_lists)) then + p_allocated = 1 + allocate(p_array(size(particle_lists))) + do i = 1,size(particle_lists) + p_array(i) = particle_lists(i) + end do + else + p_allocated = 0 + end if + + end subroutine get_particles + + subroutine get_particle_arrays(lgroup, group_arrays, group_attribute, att_n, lattribute) + !Read in a particle group and attribute name or particle subgroup, send back numbers of particle arrays and particle attribute + + character(len=OPTION_PATH_LEN), intent(in) :: lgroup + character(len=OPTION_PATH_LEN), optional, intent(in) :: lattribute + integer, allocatable, dimension(:), intent(out) :: group_arrays + integer, optional, intent(out) :: group_attribute + integer, optional, intent(in) :: att_n + + character(len=OPTION_PATH_LEN) :: group_name, attribute_name + integer :: particle_groups, array_counter, particle_subgroups, particle_attributes + integer :: i, j, k, l + + logical :: found_attribute + + particle_groups = option_count("/particles/particle_group") + + found_attribute = .false. + array_counter = 0 + do i = 1, particle_groups + call get_option("/particles/particle_group["//int2str(i-1)//"]/name", group_name) + particle_subgroups = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup") + if (trim(group_name)==trim(lgroup)) then + allocate(group_arrays(particle_subgroups)) + if (present(lattribute)) then + if (att_n==0) then + particle_attributes = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)//"]/attributes/scalar_attribute") + do k = 1, particle_attributes + call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)// & "]/attributes/scalar_attribute["//int2str(k-1)//"]/name", attribute_name) - if (trim(attribute_name)==trim(lattribute)) then - found_attribute = .true. - group_attribute = k - end if - end do - if (found_attribute.eqv..false.) then - FLExit("Could not find particle attribute "//trim(lattribute)//" in particle group "//trim(lgroup)//". Check attribute is a scalar.") - end if - else - particle_attributes = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)//"]/attributes/scalar_attribute_array") - l = 0 - group_attribute = 0 - do k = 1, particle_attributes - call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)// & + if (trim(attribute_name)==trim(lattribute)) then + found_attribute = .true. + group_attribute = k + end if + end do + if (found_attribute.eqv..false.) then + FLExit("Could not find particle attribute "//trim(lattribute)//" in particle group "//trim(lgroup)//". Check attribute is a scalar.") + end if + else + particle_attributes = option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)//"]/attributes/scalar_attribute_array") + l = 0 + group_attribute = 0 + do k = 1, particle_attributes + call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)// & "]/attributes/scalar_attribute_array["//int2str(k-1)//"]/name", attribute_name) - call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)// & + call get_option("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)// & "]/attributes/scalar_attribute_array["//int2str(k-1)//"]/dimension", l) - if (trim(attribute_name)==trim(lattribute)) then - found_attribute = .true. - group_attribute = group_attribute + att_n - else - group_attribute = group_attribute + l - end if - end do - if (found_attribute.eqv..false.) then - FLExit("Could not find particle attribute "//trim(lattribute)//" in particle group "//trim(lgroup)//". Check attribute is a scalar.") - end if - group_attribute = group_attribute + option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)//"]/attributes/scalar_attribute") - end if - end if - j=1 - do l = array_counter+1, array_counter+particle_subgroups - group_arrays(j) = l - j=j+1 - end do - return - end if - array_counter = array_counter + particle_subgroups - end do - FLExit("Could not find particle group "//trim(lgroup)) - end subroutine get_particle_arrays - - subroutine update_list_lengths(list_num) - integer, intent(in) :: list_num - - particle_lists(list_num)%total_num_det = particle_lists(list_num)%total_num_det + 1 - particle_lists(list_num)%length = particle_lists(list_num)%length + 1 - - end subroutine update_list_lengths - subroutine destroy_particles() - type(detector_linked_list), pointer :: del_particle_lists - integer :: i, particle_groups - integer(kind=8) :: h5_ierror - - if (allocated(particle_lists)) then - ! gracefully clean up output files and deallocate all particle arrays (detector lists) - particle_groups = size(particle_lists) - do i = 1, particle_groups - if (particle_lists(i)%h5_id /= -1) h5_ierror = h5_closefile(particle_lists(i)%h5_id) - del_particle_lists => particle_lists(i) - call deallocate(del_particle_lists) - enddo - end if - - if (allocated(output_CS)) then - deallocate(output_CS) - end if - end subroutine destroy_particles + if (trim(attribute_name)==trim(lattribute)) then + found_attribute = .true. + group_attribute = group_attribute + att_n + else + group_attribute = group_attribute + l + end if + end do + if (found_attribute.eqv..false.) then + FLExit("Could not find particle attribute "//trim(lattribute)//" in particle group "//trim(lgroup)//". Check attribute is a scalar.") + end if + group_attribute = group_attribute + option_count("/particles/particle_group["//int2str(i-1)//"]/particle_subgroup["//int2str(0)//"]/attributes/scalar_attribute") + end if + end if + j=1 + do l = array_counter+1, array_counter+particle_subgroups + group_arrays(j) = l + j=j+1 + end do + return + end if + array_counter = array_counter + particle_subgroups + end do + FLExit("Could not find particle group "//trim(lgroup)) + end subroutine get_particle_arrays + + subroutine update_list_lengths(list_num) + integer, intent(in) :: list_num + + particle_lists(list_num)%total_num_det = particle_lists(list_num)%total_num_det + 1 + particle_lists(list_num)%length = particle_lists(list_num)%length + 1 + + end subroutine update_list_lengths + subroutine destroy_particles() + type(detector_linked_list), pointer :: del_particle_lists + integer :: i, particle_groups + integer(kind=8) :: h5_ierror + + if (allocated(particle_lists)) then + ! gracefully clean up output files and deallocate all particle arrays (detector lists) + particle_groups = size(particle_lists) + do i = 1, particle_groups + if (particle_lists(i)%h5_id /= -1) h5_ierror = h5_closefile(particle_lists(i)%h5_id) + del_particle_lists => particle_lists(i) + call deallocate(del_particle_lists) + enddo + end if + + if (allocated(output_CS)) then + deallocate(output_CS) + end if + end subroutine destroy_particles end module particles diff --git a/femtools/Petsc_Tools.F90 b/femtools/Petsc_Tools.F90 index e3d8face62..139c4a3183 100644 --- a/femtools/Petsc_Tools.F90 +++ b/femtools/Petsc_Tools.F90 @@ -26,22 +26,22 @@ ! USA #include "fdebug.h" module Petsc_Tools - use FLDebug - use global_parameters, only: FIELD_NAME_LEN - use futils - use parallel_tools - use Reference_Counting - use halo_data_types - use halos_base - use petsc - use Sparse_Tools - use fields_data_types - use fields_base - use halos_communications - use halos_numbering - use fields_manipulation - use profiler - implicit none + use FLDebug + use global_parameters, only: FIELD_NAME_LEN + use futils + use parallel_tools + use Reference_Counting + use halo_data_types + use halos_base + use petsc + use Sparse_Tools + use fields_data_types + use fields_base + use halos_communications + use halos_numbering + use fields_manipulation + use profiler + implicit none #include "petsc_legacy.h" @@ -50,1494 +50,1494 @@ module Petsc_Tools ! it is possible (and not unlikely) that the uninitialised object happens to contain -1 which ! in petsc v3.8 is recognized as a NULL object. Therefore in petsc v3.8 we have to pass in an ! object that is known not to be a null vec - Vec, parameter, public :: PETSC_NOTANULL_VEC = tVec(1) - - PetscReal, parameter, private :: dummy_petsc_real = 0.0 - integer, parameter, public :: PetscReal_kind = kind(dummy_petsc_real) - PetscScalar, parameter, private :: dummy_petsc_scalar = 0.0 - integer, parameter, public :: PetscScalar_kind = kind(dummy_petsc_scalar) - - type petsc_numbering_type - type(halo_type), pointer :: halo => null() - integer nprivatenodes - ! global length of Petsc vector - integer universal_length - ! block size as seen by petsc - integer group_size - ! start index of local part of petsc vector - integer offset - ! mapping between "global" (fludity numbering inside each local domain) - ! and "universal" numbering (truly global numbering over all processes - ! used by PETSc), second index is for multi-component fields - integer, dimension(:,:), pointer:: gnn2unn - ! list of ghost nodes, these are skipped in copying from and to - ! PETSc vectors, and will have a zero row and column in the matrix - ! with something suitable on the diagonal - integer, dimension(:), pointer:: ghost_nodes => null() - ! the universal numbering of the ghost_nodes - ! (in gnn2unn the ghost_nodes are masked out with -1) - integer, dimension(:,:), pointer:: ghost2unn => null() - !! Reference counting - type(refcount_type), pointer :: refcount => null() - character(len=FIELD_NAME_LEN):: name="" - end type petsc_numbering_type - - interface allocate - module procedure allocate_petsc_numbering - end interface - - interface deallocate - module procedure deallocate_petsc_numbering - end interface - - interface field2petsc - module procedure VectorFields2Petsc, ScalarFields2Petsc, VectorField2Petsc, ScalarField2Petsc - end interface - - interface petsc2field - module procedure Petsc2VectorFields, Petsc2ScalarFields, Petsc2VectorField, Petsc2ScalarField - end interface - - interface petsc_numbering_create_is - module procedure petsc_numbering_create_is_dim - end interface + Vec, parameter, public :: PETSC_NOTANULL_VEC = tVec(1) + + PetscReal, parameter, private :: dummy_petsc_real = 0.0 + integer, parameter, public :: PetscReal_kind = kind(dummy_petsc_real) + PetscScalar, parameter, private :: dummy_petsc_scalar = 0.0 + integer, parameter, public :: PetscScalar_kind = kind(dummy_petsc_scalar) + + type petsc_numbering_type + type(halo_type), pointer :: halo => null() + integer nprivatenodes + ! global length of Petsc vector + integer universal_length + ! block size as seen by petsc + integer group_size + ! start index of local part of petsc vector + integer offset + ! mapping between "global" (fludity numbering inside each local domain) + ! and "universal" numbering (truly global numbering over all processes + ! used by PETSc), second index is for multi-component fields + integer, dimension(:,:), pointer:: gnn2unn + ! list of ghost nodes, these are skipped in copying from and to + ! PETSc vectors, and will have a zero row and column in the matrix + ! with something suitable on the diagonal + integer, dimension(:), pointer:: ghost_nodes => null() + ! the universal numbering of the ghost_nodes + ! (in gnn2unn the ghost_nodes are masked out with -1) + integer, dimension(:,:), pointer:: ghost2unn => null() + !! Reference counting + type(refcount_type), pointer :: refcount => null() + character(len=FIELD_NAME_LEN):: name="" + end type petsc_numbering_type + + interface allocate + module procedure allocate_petsc_numbering + end interface + + interface deallocate + module procedure deallocate_petsc_numbering + end interface + + interface field2petsc + module procedure VectorFields2Petsc, ScalarFields2Petsc, VectorField2Petsc, ScalarField2Petsc + end interface + + interface petsc2field + module procedure Petsc2VectorFields, Petsc2ScalarFields, Petsc2VectorField, Petsc2ScalarField + end interface + + interface petsc_numbering_create_is + module procedure petsc_numbering_create_is_dim + end interface #include "Reference_count_interface_petsc_numbering_type.F90" - private - - public reorder, DumpMatrixEquation, Initialize_Petsc - public csr2petsc, petsc2csr, block_csr2petsc, petsc2array, array2petsc - public field2petsc, petsc2field, petsc_numbering_create_is - public petsc_numbering_type, PetscNumberingCreateVec, allocate, deallocate - public csr2petsc_CreateSeqAIJ, csr2petsc_CreateMPIAIJ - public addup_global_assembly - ! for petsc_numbering: - public incref, decref, addref - ! for unit-testing: - logical, public, save :: petsc_test_error_handler_called = .false. - public petsc_test_error_handler - public IsNullMatNullSpace + private + + public reorder, DumpMatrixEquation, Initialize_Petsc + public csr2petsc, petsc2csr, block_csr2petsc, petsc2array, array2petsc + public field2petsc, petsc2field, petsc_numbering_create_is + public petsc_numbering_type, PetscNumberingCreateVec, allocate, deallocate + public csr2petsc_CreateSeqAIJ, csr2petsc_CreateMPIAIJ + public addup_global_assembly + ! for petsc_numbering: + public incref, decref, addref + ! for unit-testing: + logical, public, save :: petsc_test_error_handler_called = .false. + public petsc_test_error_handler + public IsNullMatNullSpace contains - ! Note about definitions in this module: - ! - ! In this module the real arrays are assumed to only store 1 - ! value per node continuously in memory. So if multiple fields, or fields - ! with more than one component (vector fields) are stored in the arrays - ! they start with nonods values for the first component of the first field - ! followed by blocks of size nonods for each of the other components and - ! fields. These blocks are refered to either as block or field (so one - ! component of one vector field counts as one field). The - ! (block_)csr_matrices are layed out correspondingly (using the word - ! block in a similar way). - - ! In the produced petsc_numbering we allow for (some of) the components of a - ! field to be grouped together per node in memory. Such a group forms - ! a local block of values per node in memory, but will always be referred to - ! as group to avoid confusion with the above definition. - - subroutine allocate_petsc_numbering(petsc_numbering, & - nnodes, nfields, group_size, halo, ghost_nodes) - !!< Set ups the 'universal'(what most people call global) - !!< numbering used in PETSc. In serial this is trivial - !!< but could still be used for reordering schemes. - !! the numbering object created: - type(petsc_numbering_type), intent(out):: petsc_numbering - !! number of nodes and fields: - !! (here nfields counts each scalar component of vector fields, so - !! e.g. for nphases velocity fields in 3 dimensions nfields=3*nphases) - integer, intent(in):: nnodes, nfields - !! if present 'group_size' fields are grouped in the petsc numbering, i.e. - integer, intent(in), optional:: group_size - !! for parallel: halo information - type(halo_type), pointer, optional :: halo - !! If supplied number these as -1, so they'll be skipped by Petsc - integer, dimension(:), optional, intent(in):: ghost_nodes - integer, dimension(:), allocatable:: ghost_marker - integer i, g, f, start, offset, fpg - integer nuniversalnodes, ngroups, ierr - - allocate( petsc_numbering%gnn2unn(1:nnodes, 1:nfields) ) - - if (present(halo)) then - if (associated(halo)) then - - allocate(petsc_numbering%halo) - petsc_numbering%halo=halo - call incref(petsc_numbering%halo) - - end if - end if - - if (present(group_size)) then - fpg=group_size ! fields per group - ngroups=nfields/fpg - assert(nfields==fpg*ngroups) - else - fpg=1 - ngroups=nfields - end if - petsc_numbering%group_size=fpg - - ! first we set up the petsc numbering for the first entry of each group only: - - if (.not.associated(petsc_numbering%halo)) then - - ! *** Serial case *or* parallel without halo - - ! standard, trivial numbering, starting at 0: - start=0 ! start of each group of fields - do g=0, ngroups-1 - do f=0, fpg-1 - petsc_numbering%gnn2unn(:, g*fpg+f+1 )= & - (/ ( start + fpg*i+f, i=0, nnodes-1 ) /) - end do - start=start+nnodes*fpg - end do - - if (isParallel()) then - - ! universal numbering can now be worked out trivially - ! by calculating the offset (start of the universal number - ! range for each process) - call mpi_scan(nnodes, offset, 1, MPI_INTEGER, & + ! Note about definitions in this module: + ! + ! In this module the real arrays are assumed to only store 1 + ! value per node continuously in memory. So if multiple fields, or fields + ! with more than one component (vector fields) are stored in the arrays + ! they start with nonods values for the first component of the first field + ! followed by blocks of size nonods for each of the other components and + ! fields. These blocks are refered to either as block or field (so one + ! component of one vector field counts as one field). The + ! (block_)csr_matrices are layed out correspondingly (using the word + ! block in a similar way). + + ! In the produced petsc_numbering we allow for (some of) the components of a + ! field to be grouped together per node in memory. Such a group forms + ! a local block of values per node in memory, but will always be referred to + ! as group to avoid confusion with the above definition. + + subroutine allocate_petsc_numbering(petsc_numbering, & + nnodes, nfields, group_size, halo, ghost_nodes) + !!< Set ups the 'universal'(what most people call global) + !!< numbering used in PETSc. In serial this is trivial + !!< but could still be used for reordering schemes. + !! the numbering object created: + type(petsc_numbering_type), intent(out):: petsc_numbering + !! number of nodes and fields: + !! (here nfields counts each scalar component of vector fields, so + !! e.g. for nphases velocity fields in 3 dimensions nfields=3*nphases) + integer, intent(in):: nnodes, nfields + !! if present 'group_size' fields are grouped in the petsc numbering, i.e. + integer, intent(in), optional:: group_size + !! for parallel: halo information + type(halo_type), pointer, optional :: halo + !! If supplied number these as -1, so they'll be skipped by Petsc + integer, dimension(:), optional, intent(in):: ghost_nodes + integer, dimension(:), allocatable:: ghost_marker + integer i, g, f, start, offset, fpg + integer nuniversalnodes, ngroups, ierr + + allocate( petsc_numbering%gnn2unn(1:nnodes, 1:nfields) ) + + if (present(halo)) then + if (associated(halo)) then + + allocate(petsc_numbering%halo) + petsc_numbering%halo=halo + call incref(petsc_numbering%halo) + + end if + end if + + if (present(group_size)) then + fpg=group_size ! fields per group + ngroups=nfields/fpg + assert(nfields==fpg*ngroups) + else + fpg=1 + ngroups=nfields + end if + petsc_numbering%group_size=fpg + + ! first we set up the petsc numbering for the first entry of each group only: + + if (.not.associated(petsc_numbering%halo)) then + + ! *** Serial case *or* parallel without halo + + ! standard, trivial numbering, starting at 0: + start=0 ! start of each group of fields + do g=0, ngroups-1 + do f=0, fpg-1 + petsc_numbering%gnn2unn(:, g*fpg+f+1 )= & + (/ ( start + fpg*i+f, i=0, nnodes-1 ) /) + end do + start=start+nnodes*fpg + end do + + if (isParallel()) then + + ! universal numbering can now be worked out trivially + ! by calculating the offset (start of the universal number + ! range for each process) + call mpi_scan(nnodes, offset, 1, MPI_INTEGER, & MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - offset=offset-nnodes - petsc_numbering%gnn2unn=petsc_numbering%gnn2unn+offset*nfields + offset=offset-nnodes + petsc_numbering%gnn2unn=petsc_numbering%gnn2unn+offset*nfields - end if + end if - petsc_numbering%nprivatenodes=nnodes + petsc_numbering%nprivatenodes=nnodes - ! the offset is the first universal number assigned to this process - ! in the standard petsc numbering the universal number is equal to - ! offset+local number - petsc_numbering%offset=petsc_numbering%gnn2unn(1,1) + ! the offset is the first universal number assigned to this process + ! in the standard petsc numbering the universal number is equal to + ! offset+local number + petsc_numbering%offset=petsc_numbering%gnn2unn(1,1) - else + else + + ! *** Parallel case with halo: + + ! the hard work is done inside get_universal_numbering() for the case fpg=1 + ! for fpg>1 we just ask for a numbering for the groups and pad it out afterwards + call get_universal_numbering(halo, petsc_numbering%gnn2unn(:,1:ngroups)) + ! petsc uses base 0 + petsc_numbering%gnn2unn(:,1:ngroups) = petsc_numbering%gnn2unn(:,1:ngroups)-1 + + if (fpg>1) then + ! the universal node number of the first node in each group is + ! simply the universal groups times fpg - as we know other processes + ! do the same we need no negotiation for the halo nodes + petsc_numbering%gnn2unn(:,1:nfields:fpg) = petsc_numbering%gnn2unn(:,1:ngroups)*fpg + ! as always the subsequent nodes in a group are number consequently: + do f=2, fpg + petsc_numbering%gnn2unn(:,f:nfields:fpg) = petsc_numbering%gnn2unn(:,1:nfields:fpg)+(f-1) + end do + end if + + petsc_numbering%nprivatenodes=halo_nowned_nodes(halo) + + petsc_numbering%offset=halo%my_owned_nodes_unn_base*nfields + + end if + + if (isParallel()) then + ! work out the length of global(universal) vector + call mpi_allreduce(petsc_numbering%nprivatenodes, nuniversalnodes, 1, MPI_INTEGER, & + MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - ! *** Parallel case with halo: + petsc_numbering%universal_length=nuniversalnodes*nfields + else + ! trivial in serial case: + petsc_numbering%universal_length=nnodes*nfields + end if - ! the hard work is done inside get_universal_numbering() for the case fpg=1 - ! for fpg>1 we just ask for a numbering for the groups and pad it out afterwards - call get_universal_numbering(halo, petsc_numbering%gnn2unn(:,1:ngroups)) - ! petsc uses base 0 - petsc_numbering%gnn2unn(:,1:ngroups) = petsc_numbering%gnn2unn(:,1:ngroups)-1 + if (present(ghost_nodes)) then + if (associated(petsc_numbering%halo)) then + ! check whether any of the halo nodes have been marked as + ! ghost nodes by the owner of that node + allocate( ghost_marker( 1:nnodes ) ) + ghost_marker = 0 + ghost_marker( ghost_nodes ) = 1 + call halo_update( petsc_numbering%halo, ghost_marker ) + + ! fill in ghost_nodes list, now including halo nodes + g=count(ghost_marker/=0) + allocate( petsc_numbering%ghost_nodes(1:g), & + petsc_numbering%ghost2unn(1:g, 1:nfields) ) + g=0 + do i=1, nnodes + if (ghost_marker(i)/=0) then + g=g+1 + petsc_numbering%ghost_nodes(g)=i + ! store the original universal number seperately + petsc_numbering%ghost2unn(g,:)=petsc_numbering%gnn2unn(i,:) + ! mask it out with -1 in gnn2unn + petsc_numbering%gnn2unn(i,:)=-1 + end if + end do + assert(g == size(petsc_numbering%ghost_nodes)) + else + ! serial case, or no halo in parallel + g=size(ghost_nodes) + allocate( petsc_numbering%ghost_nodes(1:g), & + petsc_numbering%ghost2unn(1:g, 1:nfields) ) + petsc_numbering%ghost_nodes=ghost_nodes + do g=1, size(ghost_nodes) + i=ghost_nodes(g) + ! store the original universal number seperately + petsc_numbering%ghost2unn(g,:)=petsc_numbering%gnn2unn(i,:) + ! mask it out with -1 in gnn2unn + petsc_numbering%gnn2unn(i,:)=-1 + end do + end if - if (fpg>1) then - ! the universal node number of the first node in each group is - ! simply the universal groups times fpg - as we know other processes - ! do the same we need no negotiation for the halo nodes - petsc_numbering%gnn2unn(:,1:nfields:fpg) = petsc_numbering%gnn2unn(:,1:ngroups)*fpg - ! as always the subsequent nodes in a group are number consequently: - do f=2, fpg - petsc_numbering%gnn2unn(:,f:nfields:fpg) = petsc_numbering%gnn2unn(:,1:nfields:fpg)+(f-1) + else + nullify( petsc_numbering%ghost_nodes ) + nullify( petsc_numbering%ghost2unn ) + end if + + nullify(petsc_numbering%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(petsc_numbering) + + end subroutine allocate_petsc_numbering + + subroutine deallocate_petsc_numbering(petsc_numbering) + !!< Deallocate the petsc_numbering object + type(petsc_numbering_type), intent(inout):: petsc_numbering + + call decref(petsc_numbering) + if (has_references(petsc_numbering)) return + + deallocate(petsc_numbering%gnn2unn) + if (associated(petsc_numbering%ghost_nodes)) then + deallocate(petsc_numbering%ghost_nodes) + deallocate(petsc_numbering%ghost2unn) + end if + + if (associated(petsc_numbering%halo)) then + call deallocate(petsc_numbering%halo) + deallocate(petsc_numbering%halo) + end if + + end subroutine deallocate_petsc_numbering + + subroutine reorder(petsc_numbering, sparsity, ordering_type) + type(petsc_numbering_type), intent(inout):: petsc_numbering + type(csr_sparsity), intent(in):: sparsity + MatOrderingType, intent(in):: ordering_type + + Mat M + IS rperm, cperm + PetscErrorCode ierr + PetscInt, dimension(:), allocatable:: iperm + integer nnodes, nfields, nprivatenodes + integer b, g, ghost + + nnodes=size(petsc_numbering%gnn2unn,1) + nfields=size(petsc_numbering%gnn2unn,2) + nprivatenodes=petsc_numbering%nprivatenodes + + ! sets up sequential matrix with only private nodes, + ! ignoring all halo entries: + M=CreatePrivateMatrixFromSparsity(sparsity) + + call MatGetOrdering(M, ordering_type, rperm, cperm, ierr) + + call MatDestroy(M, ierr) + + allocate(iperm(1:nprivatenodes)) + call ISCopyIndices(rperm, iperm, ierr) + iperm=iperm+1 + + if (associated(petsc_numbering%ghost_nodes)) then + ! fill ghost nodes back in (overwriting the -1s) + ! so they get reordered as well + do g=1, size(petsc_numbering%ghost_nodes) + ghost=petsc_numbering%ghost_nodes(g) + petsc_numbering%gnn2unn(ghost,:)=petsc_numbering%ghost2unn(g,:) end do - end if - - petsc_numbering%nprivatenodes=halo_nowned_nodes(halo) - - petsc_numbering%offset=halo%my_owned_nodes_unn_base*nfields - - end if - - if (isParallel()) then - ! work out the length of global(universal) vector - call mpi_allreduce(petsc_numbering%nprivatenodes, nuniversalnodes, 1, MPI_INTEGER, & - MPI_SUM, MPI_COMM_FEMTOOLS, ierr) - - petsc_numbering%universal_length=nuniversalnodes*nfields - else - ! trivial in serial case: - petsc_numbering%universal_length=nnodes*nfields - end if - - if (present(ghost_nodes)) then - if (associated(petsc_numbering%halo)) then - ! check whether any of the halo nodes have been marked as - ! ghost nodes by the owner of that node - allocate( ghost_marker( 1:nnodes ) ) - ghost_marker = 0 - ghost_marker( ghost_nodes ) = 1 - call halo_update( petsc_numbering%halo, ghost_marker ) - - ! fill in ghost_nodes list, now including halo nodes - g=count(ghost_marker/=0) - allocate( petsc_numbering%ghost_nodes(1:g), & - petsc_numbering%ghost2unn(1:g, 1:nfields) ) - g=0 - do i=1, nnodes - if (ghost_marker(i)/=0) then - g=g+1 - petsc_numbering%ghost_nodes(g)=i - ! store the original universal number seperately - petsc_numbering%ghost2unn(g,:)=petsc_numbering%gnn2unn(i,:) - ! mask it out with -1 in gnn2unn - petsc_numbering%gnn2unn(i,:)=-1 - end if - end do - assert(g == size(petsc_numbering%ghost_nodes)) - else - ! serial case, or no halo in parallel - g=size(ghost_nodes) - allocate( petsc_numbering%ghost_nodes(1:g), & - petsc_numbering%ghost2unn(1:g, 1:nfields) ) - petsc_numbering%ghost_nodes=ghost_nodes - do g=1, size(ghost_nodes) - i=ghost_nodes(g) - ! store the original universal number seperately - petsc_numbering%ghost2unn(g,:)=petsc_numbering%gnn2unn(i,:) - ! mask it out with -1 in gnn2unn - petsc_numbering%gnn2unn(i,:)=-1 - end do - end if - - else - nullify( petsc_numbering%ghost_nodes ) - nullify( petsc_numbering%ghost2unn ) - end if - - nullify(petsc_numbering%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(petsc_numbering) - - end subroutine allocate_petsc_numbering - - subroutine deallocate_petsc_numbering(petsc_numbering) - !!< Deallocate the petsc_numbering object - type(petsc_numbering_type), intent(inout):: petsc_numbering - - call decref(petsc_numbering) - if (has_references(petsc_numbering)) return - - deallocate(petsc_numbering%gnn2unn) - if (associated(petsc_numbering%ghost_nodes)) then - deallocate(petsc_numbering%ghost_nodes) - deallocate(petsc_numbering%ghost2unn) - end if - - if (associated(petsc_numbering%halo)) then - call deallocate(petsc_numbering%halo) - deallocate(petsc_numbering%halo) - end if - - end subroutine deallocate_petsc_numbering - - subroutine reorder(petsc_numbering, sparsity, ordering_type) - type(petsc_numbering_type), intent(inout):: petsc_numbering - type(csr_sparsity), intent(in):: sparsity - MatOrderingType, intent(in):: ordering_type - - Mat M - IS rperm, cperm - PetscErrorCode ierr - PetscInt, dimension(:), allocatable:: iperm - integer nnodes, nfields, nprivatenodes - integer b, g, ghost - - nnodes=size(petsc_numbering%gnn2unn,1) - nfields=size(petsc_numbering%gnn2unn,2) - nprivatenodes=petsc_numbering%nprivatenodes - - ! sets up sequential matrix with only private nodes, - ! ignoring all halo entries: - M=CreatePrivateMatrixFromSparsity(sparsity) - - call MatGetOrdering(M, ordering_type, rperm, cperm, ierr) - - call MatDestroy(M, ierr) - - allocate(iperm(1:nprivatenodes)) - call ISCopyIndices(rperm, iperm, ierr) - iperm=iperm+1 - - if (associated(petsc_numbering%ghost_nodes)) then - ! fill ghost nodes back in (overwriting the -1s) - ! so they get reordered as well - do g=1, size(petsc_numbering%ghost_nodes) - ghost=petsc_numbering%ghost_nodes(g) - petsc_numbering%gnn2unn(ghost,:)=petsc_numbering%ghost2unn(g,:) - end do - end if - - do b=1, nfields - petsc_numbering%gnn2unn(iperm, b)= & - petsc_numbering%gnn2unn(1:nprivatenodes, b) - end do - - if (associated(petsc_numbering%ghost_nodes)) then - ! put the -1s back in and write new ghost2unn - do g=1, size(petsc_numbering%ghost_nodes) - ghost=petsc_numbering%ghost_nodes(g) - petsc_numbering%ghost2unn(g,:)=petsc_numbering%gnn2unn(ghost,:) - petsc_numbering%gnn2unn(ghost,:)=-1 + end if + + do b=1, nfields + petsc_numbering%gnn2unn(iperm, b)= & + petsc_numbering%gnn2unn(1:nprivatenodes, b) end do - end if - deallocate(iperm) - call ISDestroy(rperm, ierr) - call ISDestroy(cperm, ierr) + if (associated(petsc_numbering%ghost_nodes)) then + ! put the -1s back in and write new ghost2unn + do g=1, size(petsc_numbering%ghost_nodes) + ghost=petsc_numbering%ghost_nodes(g) + petsc_numbering%ghost2unn(g,:)=petsc_numbering%gnn2unn(ghost,:) + petsc_numbering%gnn2unn(ghost,:)=-1 + end do + end if + deallocate(iperm) + + call ISDestroy(rperm, ierr) + call ISDestroy(cperm, ierr) - end subroutine reorder + end subroutine reorder - subroutine Array2Petsc(array, petsc_numbering, vec) - !!< Assembles petsc array using the specified numbering. - !!< Allocates a petsc Vec that should be destroyed with VecDestroy - real, dimension(:), intent(in):: array - type(petsc_numbering_type), intent(in):: petsc_numbering - Vec, intent(inout) :: vec + subroutine Array2Petsc(array, petsc_numbering, vec) + !!< Assembles petsc array using the specified numbering. + !!< Allocates a petsc Vec that should be destroyed with VecDestroy + real, dimension(:), intent(in):: array + type(petsc_numbering_type), intent(in):: petsc_numbering + Vec, intent(inout) :: vec - integer ierr, nnodp, start, b, nfields, nnodes + integer ierr, nnodp, start, b, nfields, nnodes - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of nodes on this process, including halo/ghost nodes - nnodes=size(petsc_numbering%gnn2unn, 1) + ! number of nodes on this process, including halo/ghost nodes + nnodes=size(petsc_numbering%gnn2unn, 1) - ! number of fields: - nfields=size(petsc_numbering%gnn2unn, 2) + ! number of fields: + nfields=size(petsc_numbering%gnn2unn, 2) - ! start of each field -1 - start=0 + ! start of each field -1 + start=0 - if (associated(petsc_numbering%halo)) then - if (.not. ((petsc_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & + if (associated(petsc_numbering%halo)) then + if (.not. ((petsc_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & .or. (petsc_numbering%halo%data_type .eq. HALO_TYPE_DG_NODE))) then - FLAbort("Matrices can only be assembled on the basis of node halos") - end if - end if + FLAbort("Matrices can only be assembled on the basis of node halos") + end if + end if - do b=1, nfields + do b=1, nfields #ifdef DOUBLEP - call VecSetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - array( start+1:start+nnodp ), INSERT_VALUES, ierr) + call VecSetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + array( start+1:start+nnodp ), INSERT_VALUES, ierr) #else - call VecSetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - real(array( start+1:start+nnodp ), kind = PetscScalar_kind), INSERT_VALUES, ierr) + call VecSetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + real(array( start+1:start+nnodp ), kind = PetscScalar_kind), INSERT_VALUES, ierr) #endif - ! go to next field: - start=start+nnodes + ! go to next field: + start=start+nnodes - end do + end do - call VecAssemblyBegin(vec, ierr) - call VecAssemblyEnd(vec, ierr) + call VecAssemblyBegin(vec, ierr) + call VecAssemblyEnd(vec, ierr) - end subroutine Array2Petsc + end subroutine Array2Petsc - subroutine VectorFields2Petsc(fields, petsc_numbering, vec) - !!< Assembles field into (previously created) petsc Vec using petsc_numbering for the DOFs of the fields combined - type(vector_field), dimension(:), intent(in):: fields - type(petsc_numbering_type), intent(in):: petsc_numbering - Vec, intent(inout) :: vec + subroutine VectorFields2Petsc(fields, petsc_numbering, vec) + !!< Assembles field into (previously created) petsc Vec using petsc_numbering for the DOFs of the fields combined + type(vector_field), dimension(:), intent(in):: fields + type(petsc_numbering_type), intent(in):: petsc_numbering + Vec, intent(inout) :: vec - integer ierr, nnodp, b, nfields, nnodes - integer i, j + integer ierr, nnodp, b, nfields, nnodes + integer i, j - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of nodes on this process, including halo/ghost nodes - nnodes=size(petsc_numbering%gnn2unn, 1) + ! number of nodes on this process, including halo/ghost nodes + nnodes=size(petsc_numbering%gnn2unn, 1) - ! number of "component" fields: (i.e. n/o vector fields *times* n/o components per vector field) - nfields=size(petsc_numbering%gnn2unn, 2) - assert( nfields==sum(fields%dim) ) + ! number of "component" fields: (i.e. n/o vector fields *times* n/o components per vector field) + nfields=size(petsc_numbering%gnn2unn, 2) + assert( nfields==sum(fields%dim) ) - if (associated(petsc_numbering%halo)) then - if (.not. ((petsc_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & + if (associated(petsc_numbering%halo)) then + if (.not. ((petsc_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & .or. (petsc_numbering%halo%data_type .eq. HALO_TYPE_DG_NODE))) then - FLAbort("Matrices can only be assembled on the basis of node halos") - end if - end if + FLAbort("Matrices can only be assembled on the basis of node halos") + end if + end if - b=1 - do i=1, size(fields) + b=1 + do i=1, size(fields) - do j=1, fields(i)%dim + do j=1, fields(i)%dim #ifdef DOUBLEP - call VecSetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - fields(i)%val(j, 1:nnodp ), INSERT_VALUES, ierr) + call VecSetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + fields(i)%val(j, 1:nnodp ), INSERT_VALUES, ierr) #else - call VecSetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - real(fields(i)%val(j, 1:nnodp ), kind = PetscScalar_kind), INSERT_VALUES, ierr) + call VecSetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + real(fields(i)%val(j, 1:nnodp ), kind = PetscScalar_kind), INSERT_VALUES, ierr) #endif - b=b+1 + b=b+1 - end do + end do - end do + end do - call VecAssemblyBegin(vec, ierr) - call VecAssemblyEnd(vec, ierr) + call VecAssemblyBegin(vec, ierr) + call VecAssemblyEnd(vec, ierr) - end subroutine VectorFields2Petsc + end subroutine VectorFields2Petsc - subroutine VectorField2Petsc(field, petsc_numbering, vec) - !!< Assembles given field into (previously created) petsc Vec using petsc_numbering - type(vector_field), intent(in):: field - type(petsc_numbering_type), intent(in):: petsc_numbering - Vec, intent(inout) :: vec + subroutine VectorField2Petsc(field, petsc_numbering, vec) + !!< Assembles given field into (previously created) petsc Vec using petsc_numbering + type(vector_field), intent(in):: field + type(petsc_numbering_type), intent(in):: petsc_numbering + Vec, intent(inout) :: vec - call VectorFields2Petsc( (/ field /), petsc_numbering, vec) + call VectorFields2Petsc( (/ field /), petsc_numbering, vec) - end subroutine VectorField2Petsc + end subroutine VectorField2Petsc - subroutine ScalarFields2Petsc(fields, petsc_numbering, vec) - !!< Assembles field into (previously created) petsc Vec using petsc_numbering for the DOFs of the fields combined - type(scalar_field), dimension(:), intent(in):: fields - type(petsc_numbering_type), intent(in):: petsc_numbering - Vec, intent(inout) :: vec + subroutine ScalarFields2Petsc(fields, petsc_numbering, vec) + !!< Assembles field into (previously created) petsc Vec using petsc_numbering for the DOFs of the fields combined + type(scalar_field), dimension(:), intent(in):: fields + type(petsc_numbering_type), intent(in):: petsc_numbering + Vec, intent(inout) :: vec - integer ierr, nnodp, b, nfields, nnodes + integer ierr, nnodp, b, nfields, nnodes - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of nodes on this process, including halo/ghost nodes - nnodes=size(petsc_numbering%gnn2unn, 1) + ! number of nodes on this process, including halo/ghost nodes + nnodes=size(petsc_numbering%gnn2unn, 1) - ! number of fields: - nfields=size(petsc_numbering%gnn2unn, 2) - assert(nfields==size(fields)) + ! number of fields: + nfields=size(petsc_numbering%gnn2unn, 2) + assert(nfields==size(fields)) - if (associated(petsc_numbering%halo)) then - if (.not. ((petsc_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & + if (associated(petsc_numbering%halo)) then + if (.not. ((petsc_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & .or. (petsc_numbering%halo%data_type .eq. HALO_TYPE_DG_NODE))) then - FLAbort("Matrices can only be assembled on the basis of node halos") - end if - end if + FLAbort("Matrices can only be assembled on the basis of node halos") + end if + end if - do b=1, nfields + do b=1, nfields #ifdef DOUBLEP - call VecSetValues(vec, nnodp, & + call VecSetValues(vec, nnodp, & petsc_numbering%gnn2unn( 1:nnodp, b ), & fields(b)%val( 1:nnodp ), INSERT_VALUES, ierr) #else - call VecSetValues(vec, nnodp, & + call VecSetValues(vec, nnodp, & petsc_numbering%gnn2unn( 1:nnodp, b ), & real(fields(b)%val( 1:nnodp ), kind = PetscScalar_kind), INSERT_VALUES, ierr) #endif - end do + end do - call VecAssemblyBegin(vec, ierr) - call VecAssemblyEnd(vec, ierr) + call VecAssemblyBegin(vec, ierr) + call VecAssemblyEnd(vec, ierr) - end subroutine ScalarFields2Petsc + end subroutine ScalarFields2Petsc - subroutine ScalarField2Petsc(field, petsc_numbering, vec) - !!< Assembles given field into (previously created) petsc Vec using petsc_numbering - type(scalar_field), intent(in):: field - type(petsc_numbering_type), intent(in):: petsc_numbering - Vec, intent(inout) :: vec + subroutine ScalarField2Petsc(field, petsc_numbering, vec) + !!< Assembles given field into (previously created) petsc Vec using petsc_numbering + type(scalar_field), intent(in):: field + type(petsc_numbering_type), intent(in):: petsc_numbering + Vec, intent(inout) :: vec - call ScalarFields2Petsc( (/ field /), petsc_numbering, vec) + call ScalarFields2Petsc( (/ field /), petsc_numbering, vec) - end subroutine ScalarField2Petsc + end subroutine ScalarField2Petsc - function PetscNumberingCreateVec(petsc_numbering) result (vec) - !!< Creates a petsc array with size corresponding to petsc_numbering. - !!< After use it should be destroyed with VecDestroy. No vector values - !!< are set in this function. - type(petsc_numbering_type), intent(in):: petsc_numbering - Vec vec + function PetscNumberingCreateVec(petsc_numbering) result (vec) + !!< Creates a petsc array with size corresponding to petsc_numbering. + !!< After use it should be destroyed with VecDestroy. No vector values + !!< are set in this function. + type(petsc_numbering_type), intent(in):: petsc_numbering + Vec vec - integer ierr, nnodp, plength, ulength, nfields - logical parallel + integer ierr, nnodp, plength, ulength, nfields + logical parallel - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of fields: - nfields=size(petsc_numbering%gnn2unn, 2) + ! number of fields: + nfields=size(petsc_numbering%gnn2unn, 2) - ! length of local (private) vector - plength=nnodp*nfields + ! length of local (private) vector + plength=nnodp*nfields - ! length of global (universal) vector - ulength=petsc_numbering%universal_length + ! length of global (universal) vector + ulength=petsc_numbering%universal_length - ! whether this is a parallel vector: - parallel= (associated(petsc_numbering%halo)) + ! whether this is a parallel vector: + parallel= (associated(petsc_numbering%halo)) - if (parallel) then - call VecCreateMPI(MPI_COMM_FEMTOOLS, plength, ulength, vec, ierr) - else - call VecCreateSeq(MPI_COMM_SELF, ulength, vec, ierr) - end if + if (parallel) then + call VecCreateMPI(MPI_COMM_FEMTOOLS, plength, ulength, vec, ierr) + else + call VecCreateSeq(MPI_COMM_SELF, ulength, vec, ierr) + end if - call VecSetOption(vec, VEC_IGNORE_NEGATIVE_INDICES, PETSC_TRUE, ierr) - call VecSetOption(vec, VEC_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) + call VecSetOption(vec, VEC_IGNORE_NEGATIVE_INDICES, PETSC_TRUE, ierr) + call VecSetOption(vec, VEC_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) - end function PetscNumberingCreateVec + end function PetscNumberingCreateVec - function petsc_numbering_create_is_dim(petsc_numbering, dim) result (index_set) - IS:: index_set - type(petsc_numbering_type), intent(in):: petsc_numbering - integer, intent(in):: dim + function petsc_numbering_create_is_dim(petsc_numbering, dim) result (index_set) + IS:: index_set + type(petsc_numbering_type), intent(in):: petsc_numbering + integer, intent(in):: dim - PetscErrorCode:: ierr - integer:: nnodp + PetscErrorCode:: ierr + integer:: nnodp - nnodp = petsc_numbering%nprivatenodes + nnodp = petsc_numbering%nprivatenodes - call ISCreateGeneral(MPI_COMM_FEMTOOLS, nnodp, petsc_numbering%gnn2unn(:,dim), & + call ISCreateGeneral(MPI_COMM_FEMTOOLS, nnodp, petsc_numbering%gnn2unn(:,dim), & PETSC_COPY_VALUES, index_set, ierr) - end function petsc_numbering_create_is_dim + end function petsc_numbering_create_is_dim - subroutine Petsc2Array(vec, petsc_numbering, array) - !!< Copies the values of a PETSc Vec into an array. The PETSc Vec - !!< must have been assembled using the same petsc_numbering. - Vec, intent(in):: vec - type(petsc_numbering_type), intent(in):: petsc_numbering - real, dimension(:), intent(out) :: array + subroutine Petsc2Array(vec, petsc_numbering, array) + !!< Copies the values of a PETSc Vec into an array. The PETSc Vec + !!< must have been assembled using the same petsc_numbering. + Vec, intent(in):: vec + type(petsc_numbering_type), intent(in):: petsc_numbering + real, dimension(:), intent(out) :: array - integer ierr, nnodp, start, b, nfields, nnodes + integer ierr, nnodp, start, b, nfields, nnodes #ifndef DOUBLEP - PetscScalar, dimension(:), allocatable :: vals + PetscScalar, dimension(:), allocatable :: vals #endif - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of nodes on this process, including halo/ghost nodes - nnodes=size(petsc_numbering%gnn2unn, 1) + ! number of nodes on this process, including halo/ghost nodes + nnodes=size(petsc_numbering%gnn2unn, 1) - ! number of fields: - nfields=size(petsc_numbering%gnn2unn, 2) + ! number of fields: + nfields=size(petsc_numbering%gnn2unn, 2) - ! start of each field -1 - start=0 + ! start of each field -1 + start=0 #ifdef DOUBLEP - do b=1, nfields + do b=1, nfields - ! this check should be unnecessary but is a work around for a bug in petsc, fixed in 18ae1927 (pops up with intel 15) - if (nnodp>0) then - call VecGetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - array( start+1:start+nnodp ), ierr) - end if + ! this check should be unnecessary but is a work around for a bug in petsc, fixed in 18ae1927 (pops up with intel 15) + if (nnodp>0) then + call VecGetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + array( start+1:start+nnodp ), ierr) + end if - ! go to next field: - start=start+nnodes + ! go to next field: + start=start+nnodes - ! Update the halo: - if (associated(petsc_numbering%halo)) then - call halo_update(petsc_numbering%halo, & - array( start+1:start+nnodp )) - end if + ! Update the halo: + if (associated(petsc_numbering%halo)) then + call halo_update(petsc_numbering%halo, & + array( start+1:start+nnodp )) + end if - end do + end do #else - allocate(vals(nnodp)) - do b=1, nfields - - if (nnodp>0) then - call VecGetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - vals, ierr) - array( start+1:start+nnodp ) = vals - end if + allocate(vals(nnodp)) + do b=1, nfields + + if (nnodp>0) then + call VecGetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + vals, ierr) + array( start+1:start+nnodp ) = vals + end if - ! go to next field: - start=start+nnodes + ! go to next field: + start=start+nnodes - ! Update the halo: - if (associated(petsc_numbering%halo)) then - call halo_update(petsc_numbering%halo, & - array( start+1:start+nnodp )) - end if + ! Update the halo: + if (associated(petsc_numbering%halo)) then + call halo_update(petsc_numbering%halo, & + array( start+1:start+nnodp )) + end if - end do - deallocate(vals) + end do + deallocate(vals) #endif - end subroutine Petsc2Array + end subroutine Petsc2Array - subroutine Petsc2ScalarFields(vec, petsc_numbering, fields, rhs) - !!< Copies the values of a PETSc Vec into scalar fields. The PETSc Vec - !!< must have been assembled using the same petsc_numbering. - Vec, intent(in):: vec - type(petsc_numbering_type), intent(in):: petsc_numbering - type(scalar_field), dimension(:), intent(inout) :: fields - !! for ghost_nodes the value of the rhs gets copied into fields - type(scalar_field), dimension(:), intent(in), optional :: rhs + subroutine Petsc2ScalarFields(vec, petsc_numbering, fields, rhs) + !!< Copies the values of a PETSc Vec into scalar fields. The PETSc Vec + !!< must have been assembled using the same petsc_numbering. + Vec, intent(in):: vec + type(petsc_numbering_type), intent(in):: petsc_numbering + type(scalar_field), dimension(:), intent(inout) :: fields + !! for ghost_nodes the value of the rhs gets copied into fields + type(scalar_field), dimension(:), intent(in), optional :: rhs - integer ierr, nnodp, b, nfields, nnodes + integer ierr, nnodp, b, nfields, nnodes #ifndef DOUBLEP - PetscScalar, dimension(:), allocatable :: vals + PetscScalar, dimension(:), allocatable :: vals #endif - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of nodes on this process, including halo/ghost nodes - nnodes=size(petsc_numbering%gnn2unn, 1) + ! number of nodes on this process, including halo/ghost nodes + nnodes=size(petsc_numbering%gnn2unn, 1) - ! number of fields: - nfields=size(petsc_numbering%gnn2unn, 2) + ! number of fields: + nfields=size(petsc_numbering%gnn2unn, 2) #ifdef DOUBLEP - do b=1, nfields - - call profiler_tic(fields(b), "petsc2field") - ! this check should be unnecessary but is a work around for a bug in petsc, fixed in 18ae1927 (pops up with intel 15) - if (nnodp>0) then - call VecGetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - fields(b)%val( 1:nnodp ), ierr) - end if - call profiler_toc(fields(b), "petsc2field") + do b=1, nfields + + call profiler_tic(fields(b), "petsc2field") + ! this check should be unnecessary but is a work around for a bug in petsc, fixed in 18ae1927 (pops up with intel 15) + if (nnodp>0) then + call VecGetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + fields(b)%val( 1:nnodp ), ierr) + end if + call profiler_toc(fields(b), "petsc2field") - end do + end do #else - allocate(vals(nnodp)) - do b=1, nfields - - call profiler_tic(fields(b), "petsc2field") - if (nnodp>0) then - call VecGetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - vals, ierr) - end if - fields(b)%val( 1:nnodp ) = vals - call profiler_toc(fields(b), "petsc2field") + allocate(vals(nnodp)) + do b=1, nfields + + call profiler_tic(fields(b), "petsc2field") + if (nnodp>0) then + call VecGetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + vals, ierr) + end if + fields(b)%val( 1:nnodp ) = vals + call profiler_toc(fields(b), "petsc2field") - end do - deallocate(vals) + end do + deallocate(vals) #endif - if (associated(petsc_numbering%ghost_nodes) .and. present(rhs)) then + if (associated(petsc_numbering%ghost_nodes) .and. present(rhs)) then - do b=1, nfields - call profiler_tic(fields(b), "petsc2field") - call set(fields(b), petsc_numbering%ghost_nodes, & - node_val(rhs(b), petsc_numbering%ghost_nodes)) - call profiler_toc(fields(b), "petsc2field") - end do - - end if - - - if (associated(petsc_numbering%halo)) then - if (size(fields)>1) then - ewrite(2, *) 'Updating of halo of multiple scalar fields needs to be improved.' - end if - do b=1, size(fields) - call profiler_tic(fields(b), "petsc2field") - ! Always update on the level 2 halo to ensure that the whole - ! field is well defined. - call halo_update(fields(b), 2) - call profiler_toc(fields(b), "petsc2field") - end do - end if - - end subroutine Petsc2ScalarFields - - subroutine Petsc2ScalarField(vec, petsc_numbering, field, rhs) - !!< Copies the values of a PETSc Vec into a scalar field. The PETSc Vec - !!< must have been assembled using the same petsc_numbering. - Vec, intent(in):: vec - type(petsc_numbering_type), intent(in):: petsc_numbering - type(scalar_field), intent(inout) :: field - !! for ghost_nodes the value of the rhs gets copied into fields - type(scalar_field), intent(in), optional :: rhs + do b=1, nfields + call profiler_tic(fields(b), "petsc2field") + call set(fields(b), petsc_numbering%ghost_nodes, & + node_val(rhs(b), petsc_numbering%ghost_nodes)) + call profiler_toc(fields(b), "petsc2field") + end do + + end if + + + if (associated(petsc_numbering%halo)) then + if (size(fields)>1) then + ewrite(2, *) 'Updating of halo of multiple scalar fields needs to be improved.' + end if + do b=1, size(fields) + call profiler_tic(fields(b), "petsc2field") + ! Always update on the level 2 halo to ensure that the whole + ! field is well defined. + call halo_update(fields(b), 2) + call profiler_toc(fields(b), "petsc2field") + end do + end if + + end subroutine Petsc2ScalarFields + + subroutine Petsc2ScalarField(vec, petsc_numbering, field, rhs) + !!< Copies the values of a PETSc Vec into a scalar field. The PETSc Vec + !!< must have been assembled using the same petsc_numbering. + Vec, intent(in):: vec + type(petsc_numbering_type), intent(in):: petsc_numbering + type(scalar_field), intent(inout) :: field + !! for ghost_nodes the value of the rhs gets copied into fields + type(scalar_field), intent(in), optional :: rhs type(scalar_field) fields(1), rhss(1) fields(1)=field if (present(rhs)) then - rhss(1)=rhs - call Petsc2ScalarFields(vec, petsc_numbering, fields, rhs=rhss) + rhss(1)=rhs + call Petsc2ScalarFields(vec, petsc_numbering, fields, rhs=rhss) else - call Petsc2ScalarFields(vec, petsc_numbering, fields) + call Petsc2ScalarFields(vec, petsc_numbering, fields) end if - end subroutine Petsc2ScalarField + end subroutine Petsc2ScalarField - subroutine Petsc2VectorFields(vec, petsc_numbering, fields) - !!< Copies the values of a PETSc Vec into vector fields. The PETSc Vec - !!< must have been assembled using the same petsc_numbering. - Vec, intent(in):: vec - type(petsc_numbering_type), intent(in):: petsc_numbering - type(vector_field), dimension(:), intent(inout) :: fields + subroutine Petsc2VectorFields(vec, petsc_numbering, fields) + !!< Copies the values of a PETSc Vec into vector fields. The PETSc Vec + !!< must have been assembled using the same petsc_numbering. + Vec, intent(in):: vec + type(petsc_numbering_type), intent(in):: petsc_numbering + type(vector_field), dimension(:), intent(inout) :: fields - integer ierr, nnodp, b, nfields, nnodes - integer i, j + integer ierr, nnodp, b, nfields, nnodes + integer i, j #ifndef DOUBLEP - PetscScalar, dimension(:), allocatable :: vals + PetscScalar, dimension(:), allocatable :: vals #endif - ! number of nodes owned by this process: - nnodp=petsc_numbering%nprivatenodes + ! number of nodes owned by this process: + nnodp=petsc_numbering%nprivatenodes - ! number of nodes on this process, including halo/ghost nodes - nnodes=size(petsc_numbering%gnn2unn, 1) + ! number of nodes on this process, including halo/ghost nodes + nnodes=size(petsc_numbering%gnn2unn, 1) - ! number of "component" fields: (i.e. n/o vector fields *times* n/o components per vector field) - nfields=size(petsc_numbering%gnn2unn, 2) - assert( nfields==sum(fields%dim) ) + ! number of "component" fields: (i.e. n/o vector fields *times* n/o components per vector field) + nfields=size(petsc_numbering%gnn2unn, 2) + assert( nfields==sum(fields%dim) ) #ifdef DOUBLEP - b=1 - do i=1, size(fields) + b=1 + do i=1, size(fields) + + call profiler_tic(fields(i), "petsc2field") + do j=1, fields(i)%dim + ! this check should be unnecessary but is a work around for a bug in petsc, fixed in 18ae1927 (pops up with intel 15) + if (nnodp>0) then + call VecGetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + fields(i)%val(j, 1:nnodp ), ierr) + end if + b=b+1 + end do + call profiler_toc(fields(i), "petsc2field") - call profiler_tic(fields(i), "petsc2field") - do j=1, fields(i)%dim - ! this check should be unnecessary but is a work around for a bug in petsc, fixed in 18ae1927 (pops up with intel 15) - if (nnodp>0) then - call VecGetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - fields(i)%val(j, 1:nnodp ), ierr) - end if - b=b+1 end do - call profiler_toc(fields(i), "petsc2field") - - end do #else - allocate(vals(nnodp)) - b=1 - do i=1, size(fields) + allocate(vals(nnodp)) + b=1 + do i=1, size(fields) + + call profiler_tic(fields(i), "petsc2field") + do j=1, fields(i)%dim + if (nnodp>0) then + call VecGetValues(vec, nnodp, & + petsc_numbering%gnn2unn( 1:nnodp, b ), & + vals, ierr) + end if + fields(i)%val(j, 1:nnodp ) = vals + b=b+1 + end do + call profiler_toc(fields(i), "petsc2field") - call profiler_tic(fields(i), "petsc2field") - do j=1, fields(i)%dim - if (nnodp>0) then - call VecGetValues(vec, nnodp, & - petsc_numbering%gnn2unn( 1:nnodp, b ), & - vals, ierr) - end if - fields(i)%val(j, 1:nnodp ) = vals - b=b+1 end do - call profiler_toc(fields(i), "petsc2field") - - end do - deallocate(vals) + deallocate(vals) #endif - ! Update the halo: - if (associated(petsc_numbering%halo)) then - ewrite(2, *) '*** Updating of halo of vector_fields needs to be improved.' - do i=1, size(fields) - ! Always update on the level 2 halo to ensure that the whole - ! field is well defined. - call profiler_tic(fields(i), "petsc2field") - call halo_update(fields(i), 2) - call profiler_toc(fields(i), "petsc2field") - end do - end if - - end subroutine Petsc2VectorFields - - subroutine Petsc2VectorField(vec, petsc_numbering, field) - !!< Copies the values of a PETSc Vec into a vector field. The PETSc Vec - !!< must have been assembled using the same petsc_numbering. - Vec, intent(in):: vec - type(petsc_numbering_type), intent(in):: petsc_numbering - type(vector_field), intent(inout) :: field + ! Update the halo: + if (associated(petsc_numbering%halo)) then + ewrite(2, *) '*** Updating of halo of vector_fields needs to be improved.' + do i=1, size(fields) + ! Always update on the level 2 halo to ensure that the whole + ! field is well defined. + call profiler_tic(fields(i), "petsc2field") + call halo_update(fields(i), 2) + call profiler_toc(fields(i), "petsc2field") + end do + end if + + end subroutine Petsc2VectorFields + + subroutine Petsc2VectorField(vec, petsc_numbering, field) + !!< Copies the values of a PETSc Vec into a vector field. The PETSc Vec + !!< must have been assembled using the same petsc_numbering. + Vec, intent(in):: vec + type(petsc_numbering_type), intent(in):: petsc_numbering + type(vector_field), intent(inout) :: field type(vector_field) fields(1) fields(1)=field call Petsc2VectorFields(vec, petsc_numbering, fields) - end subroutine Petsc2VectorField - - function csr2petsc(A, petsc_numbering, column_petsc_numbering, & - use_inodes) result(M) - !!< Converts a csr_matrix from Sparse_Tools into a PETSc matrix. - !!< Note: this function creates a PETSc matrix, it has to be deallocated - !!< with MatDestroy by the user. - type(csr_matrix), intent(in):: A - !! If present use the following numbering, otherwise the standard numbering is - !! set up and deallocated again. - type(petsc_numbering_type), optional, intent(in):: petsc_numbering - !! If present this numbering is used for the column numbering, and the previous - !! for row numbering, otherwise the previous defines row and column numbering. - !! In parallel they must be the same - type(petsc_numbering_type), optional, intent(in):: column_petsc_numbering - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - Mat M - - type(block_csr_matrix) block_matrix - - block_matrix=wrap(A%sparsity, (/ 1, 1 /), A%val, name="TemporaryMatrix_csr2petsc") - - M=block_csr2petsc(block_matrix, petsc_numbering=petsc_numbering, & - column_petsc_numbering=column_petsc_numbering, & - use_inodes=use_inodes) - - call deallocate(block_matrix) - - end function csr2petsc - - function block_csr2petsc(A, petsc_numbering, column_petsc_numbering, & - use_inodes) result(M) - !!< Converts a block_csr_matrix from Sparse_Tools into a PETSc matrix. - !!< Note: this function creates a PETSc matrix, it has to be deallocated - !!< with MatDestroy by the user. - type(block_csr_matrix), intent(in):: A - !! If present use the following numbering, otherwise the standard numbering is - !! set up and deallocated again. - type(petsc_numbering_type), optional, intent(in):: petsc_numbering - !! If present this numbering is used for the column numbering, and the previous - !! for row numbering, otherwise the previous defines row and column numbering. - !! In parallel they must be the same. - type(petsc_numbering_type), optional, intent(in):: column_petsc_numbering - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - Mat M - - type(petsc_numbering_type) row_numbering, col_numbering - real, dimension(:), pointer:: vals - real ghost_pivot, mindiag, maxdiag, diag - integer, dimension(:), pointer:: cols - integer, dimension(:), allocatable:: colidx - integer, dimension(:), allocatable:: row2ghost - integer nbrows, nbcols, nblocksv, nblocksh - integer nbrowsp, nbcolsp - integer rows(1) - integer len, bh, bv, i, g, row, ierr - - if (present(petsc_numbering)) then - row_numbering=petsc_numbering - else - ! set up standard numbering for the rows: - if (associated(A%sparsity%row_halo)) then - call allocate(row_numbering, & + end subroutine Petsc2VectorField + + function csr2petsc(A, petsc_numbering, column_petsc_numbering, & + use_inodes) result(M) + !!< Converts a csr_matrix from Sparse_Tools into a PETSc matrix. + !!< Note: this function creates a PETSc matrix, it has to be deallocated + !!< with MatDestroy by the user. + type(csr_matrix), intent(in):: A + !! If present use the following numbering, otherwise the standard numbering is + !! set up and deallocated again. + type(petsc_numbering_type), optional, intent(in):: petsc_numbering + !! If present this numbering is used for the column numbering, and the previous + !! for row numbering, otherwise the previous defines row and column numbering. + !! In parallel they must be the same + type(petsc_numbering_type), optional, intent(in):: column_petsc_numbering + !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") + !! that's why we default to not use them + logical, intent(in), optional:: use_inodes + Mat M + + type(block_csr_matrix) block_matrix + + block_matrix=wrap(A%sparsity, (/ 1, 1 /), A%val, name="TemporaryMatrix_csr2petsc") + + M=block_csr2petsc(block_matrix, petsc_numbering=petsc_numbering, & + column_petsc_numbering=column_petsc_numbering, & + use_inodes=use_inodes) + + call deallocate(block_matrix) + + end function csr2petsc + + function block_csr2petsc(A, petsc_numbering, column_petsc_numbering, & + use_inodes) result(M) + !!< Converts a block_csr_matrix from Sparse_Tools into a PETSc matrix. + !!< Note: this function creates a PETSc matrix, it has to be deallocated + !!< with MatDestroy by the user. + type(block_csr_matrix), intent(in):: A + !! If present use the following numbering, otherwise the standard numbering is + !! set up and deallocated again. + type(petsc_numbering_type), optional, intent(in):: petsc_numbering + !! If present this numbering is used for the column numbering, and the previous + !! for row numbering, otherwise the previous defines row and column numbering. + !! In parallel they must be the same. + type(petsc_numbering_type), optional, intent(in):: column_petsc_numbering + !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") + !! that's why we default to not use them + logical, intent(in), optional:: use_inodes + Mat M + + type(petsc_numbering_type) row_numbering, col_numbering + real, dimension(:), pointer:: vals + real ghost_pivot, mindiag, maxdiag, diag + integer, dimension(:), pointer:: cols + integer, dimension(:), allocatable:: colidx + integer, dimension(:), allocatable:: row2ghost + integer nbrows, nbcols, nblocksv, nblocksh + integer nbrowsp, nbcolsp + integer rows(1) + integer len, bh, bv, i, g, row, ierr + + if (present(petsc_numbering)) then + row_numbering=petsc_numbering + else + ! set up standard numbering for the rows: + if (associated(A%sparsity%row_halo)) then + call allocate(row_numbering, & nnodes=size(A, 1), nfields=blocks(A, 1), & halo=A%sparsity%row_halo) - else - call allocate(row_numbering, & + else + call allocate(row_numbering, & nnodes=size(A, 1), nfields=blocks(A, 1)) - end if - end if - - if (present(column_petsc_numbering)) then - col_numbering=column_petsc_numbering - else - ! set up standard numbering for the columns: - if (associated(A%sparsity%column_halo)) then - call allocate(col_numbering, & + end if + end if + + if (present(column_petsc_numbering)) then + col_numbering=column_petsc_numbering + else + ! set up standard numbering for the columns: + if (associated(A%sparsity%column_halo)) then + call allocate(col_numbering, & nnodes=size(A, 2), nfields=blocks(A, 2), & halo=A%sparsity%column_halo) - else - call allocate(col_numbering, & + else + call allocate(col_numbering, & nnodes=size(A, 2), nfields=blocks(A, 2)) - end if - end if - - ! rows and cols per block: - nbrows=size(row_numbering%gnn2unn, 1) - nbcols=size(col_numbering%gnn2unn, 1) - ! number of vertical and horizontal blocks: - nblocksv=size(row_numbering%gnn2unn, 2) - nblocksh=size(col_numbering%gnn2unn, 2) - - ! number of private rows and cols in each block - nbrowsp=row_numbering%nprivatenodes - nbcolsp=col_numbering%nprivatenodes - - ! setup reverse mapping from row no to ghost no - allocate( row2ghost(1:nbrows) ) - row2ghost=0 - if (associated(row_numbering%ghost_nodes)) then - ! only do something on the diagonal if the row numbering and - ! column numbering have the same ghost nodes, otherwise the - ! ghost rows and/or columns are just zeroed: - if (size(row_numbering%ghost_nodes) > 0 .and. & - associated(row_numbering%ghost_nodes, col_numbering%ghost_nodes) & - ) then - - row2ghost( row_numbering%ghost_nodes )= & - (/ ( i, i=1, size(row_numbering%ghost_nodes)) /) - - ! now find a suitable value to put on the diagonal - mindiag=huge(0.0) - maxdiag=-mindiag - do i=1, nbrowsp - do bv=1, nblocksv - diag=abs(val(A, bv, bv, i, i)) - if (diagmaxdiag) maxdiag=diag - end do - end do - ghost_pivot=sqrt((maxdiag+mindiag)*maxdiag/2.0) + end if end if - end if - ! collect the lengths of all rows - ! (the total horizontal row length across all blocks) - if (.not. IsParallel()) then + ! rows and cols per block: + nbrows=size(row_numbering%gnn2unn, 1) + nbcols=size(col_numbering%gnn2unn, 1) + ! number of vertical and horizontal blocks: + nblocksv=size(row_numbering%gnn2unn, 2) + nblocksh=size(col_numbering%gnn2unn, 2) + + ! number of private rows and cols in each block + nbrowsp=row_numbering%nprivatenodes + nbcolsp=col_numbering%nprivatenodes + + ! setup reverse mapping from row no to ghost no + allocate( row2ghost(1:nbrows) ) + row2ghost=0 + if (associated(row_numbering%ghost_nodes)) then + ! only do something on the diagonal if the row numbering and + ! column numbering have the same ghost nodes, otherwise the + ! ghost rows and/or columns are just zeroed: + if (size(row_numbering%ghost_nodes) > 0 .and. & + associated(row_numbering%ghost_nodes, col_numbering%ghost_nodes) & + ) then + + row2ghost( row_numbering%ghost_nodes )= & + (/ ( i, i=1, size(row_numbering%ghost_nodes)) /) + + ! now find a suitable value to put on the diagonal + mindiag=huge(0.0) + maxdiag=-mindiag + do i=1, nbrowsp + do bv=1, nblocksv + diag=abs(val(A, bv, bv, i, i)) + if (diagmaxdiag) maxdiag=diag + end do + end do + ghost_pivot=sqrt((maxdiag+mindiag)*maxdiag/2.0) + end if + end if + + ! collect the lengths of all rows + ! (the total horizontal row length across all blocks) + if (.not. IsParallel()) then - ! Create serial matrix: - M=csr2petsc_CreateSeqAIJ(A%sparsity, row_numbering, col_numbering, A%diagonal, use_inodes=use_inodes) + ! Create serial matrix: + M=csr2petsc_CreateSeqAIJ(A%sparsity, row_numbering, col_numbering, A%diagonal, use_inodes=use_inodes) - ! these should be the same, just to make sure: - nbrowsp=nbrows + ! these should be the same, just to make sure: + nbrowsp=nbrows - else + else - ! Create parallel matrix: - M=csr2petsc_CreateMPIAIJ(A%sparsity, row_numbering, col_numbering, A%diagonal, use_inodes=use_inodes) + ! Create parallel matrix: + M=csr2petsc_CreateMPIAIJ(A%sparsity, row_numbering, col_numbering, A%diagonal, use_inodes=use_inodes) - call MatSetOption(M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) - endif + call MatSetOption(M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) + endif - allocate(colidx(1:nbcols)) + allocate(colidx(1:nbcols)) - if (associated(row_numbering%halo)) then - if (.not. ((row_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & + if (associated(row_numbering%halo)) then + if (.not. ((row_numbering%halo%data_type .eq. HALO_TYPE_CG_NODE) & .or. (row_numbering%halo%data_type .eq. HALO_TYPE_DG_NODE))) then - FLAbort("Matrices can only be assembled on the basis of node halos") - end if - end if + FLAbort("Matrices can only be assembled on the basis of node halos") + end if + end if - ! loop over rows within a block: - do i=1, nbrowsp + ! loop over rows within a block: + do i=1, nbrowsp - if (row2ghost(i)==0) then - cols => row_m_ptr(A, i) - len=size(cols) + if (row2ghost(i)==0) then + cols => row_m_ptr(A, i) + len=size(cols) - ! loop through all rows i in the different blocks: - ! outer loop: from left to right - do bh=1, nblocksh + ! loop through all rows i in the different blocks: + ! outer loop: from left to right + do bh=1, nblocksh - ! translate column indices to petsc - colidx(1:len)=col_numbering%gnn2unn(cols, bh) + ! translate column indices to petsc + colidx(1:len)=col_numbering%gnn2unn(cols, bh) - ! we go down first as all the column indices stay the same - do bv=1, nblocksv - if (A%diagonal .and. bh/=bv) cycle - ! row number in PETSc land: - rows(1)=row_numbering%gnn2unn(i, bv) - vals => row_val_ptr(A, bv, bh, i) + ! we go down first as all the column indices stay the same + do bv=1, nblocksv + if (A%diagonal .and. bh/=bv) cycle + ! row number in PETSc land: + rows(1)=row_numbering%gnn2unn(i, bv) + vals => row_val_ptr(A, bv, bh, i) #ifdef DOUBLEP - call MatSetValues(M, 1, rows, len, colidx(1:len), vals, & - INSERT_VALUES, ierr) + call MatSetValues(M, 1, rows, len, colidx(1:len), vals, & + INSERT_VALUES, ierr) #else - call MatSetValues(M, 1, rows, len, colidx(1:len), real(vals, kind = PetscScalar_kind), & - INSERT_VALUES, ierr) + call MatSetValues(M, 1, rows, len, colidx(1:len), real(vals, kind = PetscScalar_kind), & + INSERT_VALUES, ierr) #endif - end do + end do - end do + end do - ! only set ghost pivot for owned rows: - else if (i<=nbrowsp) then + ! only set ghost pivot for owned rows: + else if (i<=nbrowsp) then - g=row2ghost(i) - do bv=1, nblocksv - row=row_numbering%ghost2unn(g, bv) + g=row2ghost(i) + do bv=1, nblocksv + row=row_numbering%ghost2unn(g, bv) #ifdef DOUBLEP - call MatSetValue(M, row, row, ghost_pivot, INSERT_VALUES, ierr) + call MatSetValue(M, row, row, ghost_pivot, INSERT_VALUES, ierr) #else - call MatSetValue(M, row, row, real(ghost_pivot, kind = PetscScalar_kind), INSERT_VALUES, ierr) + call MatSetValue(M, row, row, real(ghost_pivot, kind = PetscScalar_kind), INSERT_VALUES, ierr) #endif - end do + end do + + end if + + end do + + deallocate(colidx) + + call MatAssemblyBegin(M, MAT_FINAL_ASSEMBLY, ierr) + call MatAssemblyEnd(M, MAT_FINAL_ASSEMBLY, ierr) + + if (.not. present(petsc_numbering)) then + call deallocate(row_numbering) + endif + if (.not. present(column_petsc_numbering)) then + call deallocate(col_numbering) + endif + end function block_csr2petsc + + function CreatePrivateMatrixFromSparsity(sparsity) result (M) + ! creates Petsc matrix containing only entries corresponding to private nodes + type(csr_sparsity), intent(in):: sparsity + + Mat M + PetscErrorCode ierr + real, dimension(:), allocatable:: vals + integer, dimension(:), pointer:: cols + integer rows(1) + integer, dimension(:), allocatable:: colidx, nnz + integer ncols, nprows, npcols + integer i, l + + ncols=size(sparsity,2) + if (associated(sparsity%row_halo)) then + nprows=halo_nowned_nodes(sparsity%row_halo) + else + nprows=size(sparsity,1) end if + if (associated(sparsity%column_halo)) then + npcols=halo_nowned_nodes(sparsity%column_halo) + else + npcols=size(sparsity,2) + end if + + if (.not. IsParallel()) then + nprows=size(sparsity,1) + npcols=ncols + end if + + allocate(nnz(1:nprows)) + ! calcute n/o nonzero entries of private rows: + do i=1, nprows + cols => row_m_ptr(sparsity, i) + ! ignore halo column indices + nnz(i)=count(cols<=npcols) + + end do - end do - - deallocate(colidx) - - call MatAssemblyBegin(M, MAT_FINAL_ASSEMBLY, ierr) - call MatAssemblyEnd(M, MAT_FINAL_ASSEMBLY, ierr) - - if (.not. present(petsc_numbering)) then - call deallocate(row_numbering) - endif - if (.not. present(column_petsc_numbering)) then - call deallocate(col_numbering) - endif - - end function block_csr2petsc - - function CreatePrivateMatrixFromSparsity(sparsity) result (M) - ! creates Petsc matrix containing only entries corresponding to private nodes - type(csr_sparsity), intent(in):: sparsity - - Mat M - PetscErrorCode ierr - real, dimension(:), allocatable:: vals - integer, dimension(:), pointer:: cols - integer rows(1) - integer, dimension(:), allocatable:: colidx, nnz - integer ncols, nprows, npcols - integer i, l - - ncols=size(sparsity,2) - if (associated(sparsity%row_halo)) then - nprows=halo_nowned_nodes(sparsity%row_halo) - else - nprows=size(sparsity,1) - end if - if (associated(sparsity%column_halo)) then - npcols=halo_nowned_nodes(sparsity%column_halo) - else - npcols=size(sparsity,2) - end if - - if (.not. IsParallel()) then - nprows=size(sparsity,1) - npcols=ncols - end if - - allocate(nnz(1:nprows)) - ! calcute n/o nonzero entries of private rows: - do i=1, nprows - cols => row_m_ptr(sparsity, i) - ! ignore halo column indices - nnz(i)=count(cols<=npcols) - - end do - - call MatCreateAIJ(MPI_COMM_SELF, nprows, npcols, nprows, npcols, & - 0, nnz, 0, PETSC_NULL_INTEGER, M, ierr) - call MatSetup(M, ierr) - - call MatSetOption(M, MAT_USE_INODES, PETSC_FALSE, ierr) - - - deallocate(nnz) - - allocate(colidx(1:ncols), vals(1:ncols)) - ! some random number for the matrix values: - vals=1.0 - - do i=1, nprows - cols => row_m_ptr(sparsity,i) - l=size(cols) - where (cols<=npcols) - colidx(1:l)=cols-1 - elsewhere - ! -1 is skipped over by PETSc - colidx(1:l)=-1 - end where - rows(1)=i-1 + call MatCreateAIJ(MPI_COMM_SELF, nprows, npcols, nprows, npcols, & + 0, nnz, 0, PETSC_NULL_INTEGER, M, ierr) + call MatSetup(M, ierr) + + call MatSetOption(M, MAT_USE_INODES, PETSC_FALSE, ierr) + + + deallocate(nnz) + + allocate(colidx(1:ncols), vals(1:ncols)) + ! some random number for the matrix values: + vals=1.0 + + do i=1, nprows + cols => row_m_ptr(sparsity,i) + l=size(cols) + where (cols<=npcols) + colidx(1:l)=cols-1 + elsewhere + ! -1 is skipped over by PETSc + colidx(1:l)=-1 + end where + rows(1)=i-1 #ifdef DOUBLEP - call MatSetValues(M, 1, rows, l, colidx(1:l), vals(1:l), & + call MatSetValues(M, 1, rows, l, colidx(1:l), vals(1:l), & INSERT_VALUES, ierr) #else - call MatSetValues(M, 1, rows, l, colidx(1:l), real(vals(1:l), kind = PetscScalar_kind), & + call MatSetValues(M, 1, rows, l, colidx(1:l), real(vals(1:l), kind = PetscScalar_kind), & INSERT_VALUES, ierr) #endif - end do - - call MatAssemblyBegin(M, MAT_FINAL_ASSEMBLY, ierr) - call MatAssemblyEnd(M, MAT_FINAL_ASSEMBLY, ierr) - - deallocate(colidx, vals) - - end function CreatePrivateMatrixFromSparsity - - function csr2petsc_CreateSeqAIJ(sparsity, row_numbering, col_numbering, only_diagonal_blocks, use_inodes) result(M) - !!< Creates a sequential PETSc Mat of size corresponding with - !!< row_numbering and col_numbering. - type(csr_sparsity), intent(in):: sparsity - type(petsc_numbering_type), intent(in):: row_numbering, col_numbering - logical, intent(in):: only_diagonal_blocks - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - Mat M - - integer, dimension(:), allocatable:: nnz - integer nrows, ncols, nbrows, nbcols, nblocksv, nblocksh - integer row, len, ierr - integer bv, i - - ! total number of rows and cols: - nrows=row_numbering%universal_length - ncols=col_numbering%universal_length - ! rows and cols per block: - nbrows=size(row_numbering%gnn2unn, 1) - nbcols=size(col_numbering%gnn2unn, 1) - ! number of vertical and horizontal blocks: - nblocksv=size(row_numbering%gnn2unn, 2) - nblocksh=size(col_numbering%gnn2unn, 2) - - allocate(nnz(0:nrows-1)) - ! loop over complete horizontal rows within a block of rows - nnz=1 ! ghost rows are skipped below and only have a diagonal - do i=1, nbrows - if (only_diagonal_blocks) then - len=row_length(sparsity,i) - else - len=row_length(sparsity,i)*nblocksh - end if - ! loop over the blocks of rows - do bv=1, nblocksv - ! row in petsc numbering: - row=row_numbering%gnn2unn(i,bv) - if (row/=-1) then - nnz(row)=len - end if end do - end do - call MatCreate(PETSC_COMM_SELF, M, ierr) - call MatSetSizes(M, nrows, ncols, PETSC_DETERMINE, PETSC_DETERMINE, ierr) - call MatSetBlockSizes(M, row_numbering%group_size, col_numbering%group_size, ierr) - call MatSetType(M, MATAIJ, ierr) - ! NOTE: 2nd argument is not used - call MatSeqAIJSetPreallocation(M, 0, nnz, ierr) + call MatAssemblyBegin(M, MAT_FINAL_ASSEMBLY, ierr) + call MatAssemblyEnd(M, MAT_FINAL_ASSEMBLY, ierr) + + deallocate(colidx, vals) + + end function CreatePrivateMatrixFromSparsity + + function csr2petsc_CreateSeqAIJ(sparsity, row_numbering, col_numbering, only_diagonal_blocks, use_inodes) result(M) + !!< Creates a sequential PETSc Mat of size corresponding with + !!< row_numbering and col_numbering. + type(csr_sparsity), intent(in):: sparsity + type(petsc_numbering_type), intent(in):: row_numbering, col_numbering + logical, intent(in):: only_diagonal_blocks + !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") + !! that's why we default to not use them + logical, intent(in), optional:: use_inodes + Mat M + + integer, dimension(:), allocatable:: nnz + integer nrows, ncols, nbrows, nbcols, nblocksv, nblocksh + integer row, len, ierr + integer bv, i + + ! total number of rows and cols: + nrows=row_numbering%universal_length + ncols=col_numbering%universal_length + ! rows and cols per block: + nbrows=size(row_numbering%gnn2unn, 1) + nbcols=size(col_numbering%gnn2unn, 1) + ! number of vertical and horizontal blocks: + nblocksv=size(row_numbering%gnn2unn, 2) + nblocksh=size(col_numbering%gnn2unn, 2) + + allocate(nnz(0:nrows-1)) + ! loop over complete horizontal rows within a block of rows + nnz=1 ! ghost rows are skipped below and only have a diagonal + do i=1, nbrows + if (only_diagonal_blocks) then + len=row_length(sparsity,i) + else + len=row_length(sparsity,i)*nblocksh + end if + ! loop over the blocks of rows + do bv=1, nblocksv + ! row in petsc numbering: + row=row_numbering%gnn2unn(i,bv) + if (row/=-1) then + nnz(row)=len + end if + end do + end do - if (.not. present_and_true(use_inodes)) then - call MatSetOption(M, MAT_USE_INODES, PETSC_FALSE, ierr) - end if - - call MatSetup(M, ierr) - - deallocate(nnz) - - end function csr2petsc_CreateSeqAIJ - - function csr2petsc_CreateMPIAIJ(sparsity, row_numbering, col_numbering, only_diagonal_blocks, use_inodes) result(M) - !!< Creates a parallel PETSc Mat of size corresponding with - !!< row_numbering and col_numbering. - type(csr_sparsity), intent(in):: sparsity - type(petsc_numbering_type), intent(in):: row_numbering, col_numbering - logical, intent(in):: only_diagonal_blocks - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - Mat M - - integer, dimension(:), pointer:: cols - integer, dimension(:), allocatable:: d_nnz, o_nnz - integer nrows, ncols, nbrows, nbcols, nblocksv, nblocksh - integer nrowsp, ncolsp, nbrowsp, nbcolsp, row_offset - integer row, len, private_len, ghost_len - integer bv, i, ierr - - ! total number of rows and cols: - nrows=row_numbering%universal_length - ncols=col_numbering%universal_length - ! rows and cols per block: - nbrows=size(row_numbering%gnn2unn, 1) - nbcols=size(col_numbering%gnn2unn, 1) - ! number of vertical and horizontal blocks: - nblocksv=size(row_numbering%gnn2unn, 2) - nblocksh=size(col_numbering%gnn2unn, 2) - - ! number of private rows and cols in each block - nbrowsp=row_numbering%nprivatenodes - nbcolsp=col_numbering%nprivatenodes - - ! number of private rows and cols in total - ! (this will be the number of local rows and cols for petsc) - nrowsp=nbrowsp*nblocksv - ncolsp=nbcolsp*nblocksh - - ! the universal numbers used by petsc for private nodes are in the range - ! row_offset:row_offset+nrowsp-1 - row_offset=row_numbering%offset - - ! for each private row we have to count the number of column indices - ! refering to private nodes and refering to ghost/halos nodes - allocate(d_nnz(row_offset:row_offset+nrowsp-1), & - o_nnz(row_offset:row_offset+nrowsp-1)) - ! ghost rows are skipped below, and only have a diagonal - d_nnz=1 - o_nnz=0 - ! loop over complete horizontal rows within a block of rows - do i=1, nbrowsp - ! this is just the row within a block - cols => row_m_ptr(sparsity, i) - ! the row length over all blocks from left to right - len=size(cols) - ! number of entries refering to private nodes: - private_len=count(cols<=nbcolsp) - if (.not. only_diagonal_blocks) then - len=len*nblocksh - private_len=private_len*nblocksh + call MatCreate(PETSC_COMM_SELF, M, ierr) + call MatSetSizes(M, nrows, ncols, PETSC_DETERMINE, PETSC_DETERMINE, ierr) + call MatSetBlockSizes(M, row_numbering%group_size, col_numbering%group_size, ierr) + call MatSetType(M, MATAIJ, ierr) + ! NOTE: 2nd argument is not used + call MatSeqAIJSetPreallocation(M, 0, nnz, ierr) + + if (.not. present_and_true(use_inodes)) then + call MatSetOption(M, MAT_USE_INODES, PETSC_FALSE, ierr) end if - ! the rest refers to ghost/halo nodes: - ghost_len=len-private_len - - ! loop over the blocks of rows - do bv=1, nblocksv - ! row in petsc numbering: - row=row_numbering%gnn2unn(i,bv) - if (row/=-1) then - ASSERT(row>=row_offset .and. row row_m_ptr(sparsity, i) + ! the row length over all blocks from left to right + len=size(cols) + ! number of entries refering to private nodes: + private_len=count(cols<=nbcolsp) + if (.not. only_diagonal_blocks) then + len=len*nblocksh + private_len=private_len*nblocksh + end if + ! the rest refers to ghost/halo nodes: + ghost_len=len-private_len + + ! loop over the blocks of rows + do bv=1, nblocksv + ! row in petsc numbering: + row=row_numbering%gnn2unn(i,bv) + if (row/=-1) then + ASSERT(row>=row_offset .and. row=0) then - ! unused halo nodes are marked -1 (see allocate_petsc_numbering() ) - unn2gnn( ui ) = i - end if - end do - else - ! in parallel no halo rows or columns are included, so - ! in both the serial and the parallel case we allocate a matrix with - ! nprivate_nodes==nnodes: - call allocate(sparsity, rows, columns, entries, diag=.false., & - name="petsc2csrSparsity") - end if - call allocate(A, sparsity) - - if (parallel) then - ! in the parallel case we first copy in a temp. buffer - ! and only insert the entries A_ij with both i *and* j local - allocate(row_cols(1:entries), row_vals(1:entries)) - j=1 - do i=0, rows-1 - sparsity%findrm(i+1)=j - call MatGetRow(matrix, offset+i, ncols, row_cols, row_vals, ierr) - do k=1, ncols - if (row_cols(k)>=offset .and. row_cols(k)local entries get inserted - sparsity%colm(j)=row_cols(k)-offset+1 - A%val(j)=row_vals(k) - j=j+1 - else if (present(column_numbering)) then - ! halo columns - sparsity%colm(j)=unn2gnn(row_cols(k)) - A%val(j)=row_vals(k) - assert( sparsity%colm(j)>0 ) - j=j+1 - end if - end do - ! This is stupid, we were given copies in MatGetRow so it could - ! have restored its internal tmp arrays straight away, anyway: - call MatRestoreRow(matrix, offset+i, ncols, row_cols, row_vals, ierr) - end do - A%sparsity%findrm(i+1)=j - deallocate(row_cols, row_vals) - else - ! Serial case: - j=1 - do i=0, rows-1 - sparsity%findrm(i+1)=j + deallocate(d_nnz, o_nnz) + + end function csr2petsc_CreateMPIAIJ + + function petsc2csr(matrix, column_numbering) result(A) + !!< Converts a PETSc matrix into a csr_matrix from Sparse_Tools. + !!< Note: this function allocates a csr_matrix, it has to be deallocated + !!< by the user. + !!< Note2: for parallel matrices this assumes standard numbering, i.e. the + !!< numbering where each processor owns a consecutive range of 'nrows' local rows + !!< from offset+0 to offset+nrows-1. If column_numbering is not provided + !!< the column numbering is exactly the same as for rows. + !!< Note3: for parallel matrices where column_numbering is not provided, + !!< only the entries for which both the row number *and* the column number + !!< are local are copied over, i.e. "remote + !!< entries" in a local row are left out. + !!< Note4: for parallel matrices where column_numbering *is* provided + !!< only local rows are copied over (i.e. no halo *rows*). The translation + !!< back from global to local indices for the halo columns is done via + !!< a naive inverse map, i.e. we allocate an integer array of global length! + !!< This should therefore not be used in production code, unless some more + !!< (memory) efficient mapping is implemented - currently used for + !!< petsc_readnsolve only. + type(csr_matrix) :: A + Mat, intent(in):: matrix + type(petsc_numbering_type), optional, intent(in):: column_numbering + + PetscErrorCode ierr + type(csr_sparsity) :: sparsity + double precision, dimension(MAT_INFO_SIZE):: matrixinfo + PetscScalar, dimension(:), allocatable:: row_vals + integer, dimension(:), allocatable:: row_cols, unn2gnn + integer private_columns + integer i, j, k, ui, rows, columns, entries, ncols, offset, end_of_range + logical parallel + + ! get the necessary info about the matrix: + call MatGetInfo(matrix, MAT_LOCAL, matrixinfo, ierr) + entries=matrixinfo(MAT_INFO_NZ_USED) + ! note we're no longer using MAT_INFO for getting local n/o rows and cols + ! as it's bugged in Petsc < 3.0 and obsoloted thereafter: + call MatGetLocalSize(matrix, rows, columns, ierr) + call MatGetOwnershipRange(matrix, offset, end_of_range, ierr) + parallel=IsParallel() + + if (present(column_numbering)) then + ! only halo columns are copied over: + private_columns=columns + columns=size(column_numbering%gnn2unn,1) + assert( private_columns==column_numbering%nprivatenodes ) + assert( private_columns<=columns ) + assert( size(column_numbering%gnn2unn,2)==1 ) + call allocate(sparsity, rows, columns, entries, & + diag=.false., name="petsc2csrSparsity") + if (associated(column_numbering%halo)) then + allocate(sparsity%column_halo) + sparsity%column_halo=column_numbering%halo + call incref(sparsity%column_halo) + end if + ! allocate inverse mapping + ! WARNING: this is a 'universal' length array + allocate( unn2gnn(0:column_numbering%universal_length-1) ) + unn2gnn=0 + do i=1, columns + ui=column_numbering%gnn2unn(i,1) + if (ui>=0) then + ! unused halo nodes are marked -1 (see allocate_petsc_numbering() ) + unn2gnn( ui ) = i + end if + end do + else + ! in parallel no halo rows or columns are included, so + ! in both the serial and the parallel case we allocate a matrix with + ! nprivate_nodes==nnodes: + call allocate(sparsity, rows, columns, entries, diag=.false., & + name="petsc2csrSparsity") + end if + call allocate(A, sparsity) + + if (parallel) then + ! in the parallel case we first copy in a temp. buffer + ! and only insert the entries A_ij with both i *and* j local + allocate(row_cols(1:entries), row_vals(1:entries)) + j=1 + do i=0, rows-1 + sparsity%findrm(i+1)=j + call MatGetRow(matrix, offset+i, ncols, row_cols, row_vals, ierr) + do k=1, ncols + if (row_cols(k)>=offset .and. row_cols(k)local entries get inserted + sparsity%colm(j)=row_cols(k)-offset+1 + A%val(j)=row_vals(k) + j=j+1 + else if (present(column_numbering)) then + ! halo columns + sparsity%colm(j)=unn2gnn(row_cols(k)) + A%val(j)=row_vals(k) + assert( sparsity%colm(j)>0 ) + j=j+1 + end if + end do + ! This is stupid, we were given copies in MatGetRow so it could + ! have restored its internal tmp arrays straight away, anyway: + call MatRestoreRow(matrix, offset+i, ncols, row_cols, row_vals, ierr) + end do + A%sparsity%findrm(i+1)=j + + deallocate(row_cols, row_vals) + else + ! Serial case: + j=1 + do i=0, rows-1 + sparsity%findrm(i+1)=j #ifdef DOUBLEP - call MatGetRow(matrix, offset+i, ncols, sparsity%colm(j:), A%val(j:), ierr) - j=j+ncols - ! This is stupid, we were given copies in MatGetRow so it could - ! have restored its internal tmp arrays straight away, anyway: - call MatRestoreRow(matrix, offset+i, ncols, sparsity%colm(j:), A%val(j:), ierr) + call MatGetRow(matrix, offset+i, ncols, sparsity%colm(j:), A%val(j:), ierr) + j=j+ncols + ! This is stupid, we were given copies in MatGetRow so it could + ! have restored its internal tmp arrays straight away, anyway: + call MatRestoreRow(matrix, offset+i, ncols, sparsity%colm(j:), A%val(j:), ierr) #else - allocate(row_vals(size(A%val) - j + 1)) - call MatGetRow(matrix, offset+i, ncols, sparsity%colm(j:), row_vals, ierr) - A%val(j:) = row_vals - j=j+ncols - ! This is stupid, we were given copies in MatGetRow so it could - ! have restored its internal tmp arrays straight away, anyway: - call MatRestoreRow(matrix, offset+i, ncols, sparsity%colm(j:), row_vals, ierr) - deallocate(row_vals) + allocate(row_vals(size(A%val) - j + 1)) + call MatGetRow(matrix, offset+i, ncols, sparsity%colm(j:), row_vals, ierr) + A%val(j:) = row_vals + j=j+ncols + ! This is stupid, we were given copies in MatGetRow so it could + ! have restored its internal tmp arrays straight away, anyway: + call MatRestoreRow(matrix, offset+i, ncols, sparsity%colm(j:), row_vals, ierr) + deallocate(row_vals) #endif - end do - A%sparsity%findrm(i+1)=j + end do + A%sparsity%findrm(i+1)=j - ! matrix is indexed from offset+0, colm should be indexed from 1: - sparsity%colm=sparsity%colm-offset+1 + ! matrix is indexed from offset+0, colm should be indexed from 1: + sparsity%colm=sparsity%colm-offset+1 - end if - call deallocate(sparsity) + end if + call deallocate(sparsity) - if (present(column_numbering)) then - deallocate(unn2gnn) - end if + if (present(column_numbering)) then + deallocate(unn2gnn) + end if - end function petsc2csr + end function petsc2csr - subroutine addup_global_assembly(vfield, halo) - !!< adds up the local contributions in a globally assembled vfield - !!< i.e. the non-owned contributions in halo nodes get added into - !!< the non-halo nodes on the owning processes. This is followed by - !!< a halo_update so that the added up values are communicated back to - !!< the halo nodes - type(vector_field), intent(inout):: vfield - type(halo_type), pointer:: halo + subroutine addup_global_assembly(vfield, halo) + !!< adds up the local contributions in a globally assembled vfield + !!< i.e. the non-owned contributions in halo nodes get added into + !!< the non-halo nodes on the owning processes. This is followed by + !!< a halo_update so that the added up values are communicated back to + !!< the halo nodes + type(vector_field), intent(inout):: vfield + type(halo_type), pointer:: halo - type(petsc_numbering_type):: petsc_numbering - Vec:: vec - PetscErrorCode:: ierr + type(petsc_numbering_type):: petsc_numbering + Vec:: vec + PetscErrorCode:: ierr - if (.not. IsParallel()) return + if (.not. IsParallel()) return - call allocate(petsc_numbering, node_count(vfield), vfield%dim, & - halo=halo) - vec=PetscNumberingCreateVec(petsc_numbering) - ! assemble vfield into petsc Vec, this lets petsc do the adding up - call field2petsc(vfield, petsc_numbering, vec) - ! copy back (this includes the promised halo update): - call petsc2field(vec, petsc_numbering, vfield) - call VecDestroy(vec, ierr) - call deallocate(petsc_numbering) + call allocate(petsc_numbering, node_count(vfield), vfield%dim, & + halo=halo) + vec=PetscNumberingCreateVec(petsc_numbering) + ! assemble vfield into petsc Vec, this lets petsc do the adding up + call field2petsc(vfield, petsc_numbering, vec) + ! copy back (this includes the promised halo update): + call petsc2field(vec, petsc_numbering, vfield) + call VecDestroy(vec, ierr) + call deallocate(petsc_numbering) - end subroutine addup_global_assembly + end subroutine addup_global_assembly - function FindrmFromRowSizes(sizes) - !!< Auxilary routine to work out findrm from the row sizes - integer, dimension(:), intent(in):: sizes - integer, dimension(1:size(sizes)+1):: FindrmFromRowSizes + function FindrmFromRowSizes(sizes) + !!< Auxilary routine to work out findrm from the row sizes + integer, dimension(:), intent(in):: sizes + integer, dimension(1:size(sizes)+1):: FindrmFromRowSizes - integer i, j + integer i, j - j=1 - do i=1, size(sizes) + j=1 + do i=1, size(sizes) + FindrmFromRowSizes(i)=j + j=j+sizes(i) + end do FindrmFromRowSizes(i)=j - j=j+sizes(i) - end do - FindrmFromRowSizes(i)=j - end function FindrmFromRowSizes + end function FindrmFromRowSizes - subroutine DumpMatrixEquation(filename, x0, A, b) - character(len=*), intent(in):: filename - Mat, intent(in):: A - Vec, intent(in):: x0, b + subroutine DumpMatrixEquation(filename, x0, A, b) + character(len=*), intent(in):: filename + Mat, intent(in):: A + Vec, intent(in):: x0, b - PetscViewer :: viewer - PetscErrorCode :: ierr + PetscViewer :: viewer + PetscErrorCode :: ierr - ewrite(0, *) 'Dumping matrix equation in file called '//filename - call PetscViewerBinaryOpen(MPI_COMM_FEMTOOLS, & - filename, FILE_MODE_WRITE, & - viewer, ierr) - call MatView(A, viewer, ierr) - call VecView(b, viewer, ierr) - call VecView(x0, viewer, ierr) - call PetscViewerDestroy(viewer, ierr) + ewrite(0, *) 'Dumping matrix equation in file called '//filename + call PetscViewerBinaryOpen(MPI_COMM_FEMTOOLS, & + filename, FILE_MODE_WRITE, & + viewer, ierr) + call MatView(A, viewer, ierr) + call VecView(b, viewer, ierr) + call VecView(x0, viewer, ierr) + call PetscViewerDestroy(viewer, ierr) - end subroutine DumpMatrixEquation + end subroutine DumpMatrixEquation - subroutine Initialize_Petsc() - PetscErrorCode :: ierr - call PetscInitialize(PETSC_NULL_CHARACTER, ierr); CHKERRQ(ierr); - end subroutine Initialize_Petsc + subroutine Initialize_Petsc() + PetscErrorCode :: ierr + call PetscInitialize(PETSC_NULL_CHARACTER, ierr); CHKERRQ(ierr); + end subroutine Initialize_Petsc ! Simple dummy error handler that just tracks whether it's been called or not ! Useful for unittesting to see that petsc gives error messages at the right moment -subroutine petsc_test_error_handler(comm,line, func, file, dir, n, p, mess, ctx, ierr) - MPI_Comm:: comm - PetscInt:: line - character(len=*):: func, file, dir - PetscErrorCode:: n - PetscInt:: p - character(len=*):: mess - PetscInt:: ctx - PetscErrorCode:: ierr - - - petsc_test_error_handler_called = .true. - -end subroutine petsc_test_error_handler - -function IsNullMatNullSpace(nullsp) - ! This function checks whether `nullsp` is a NULL nullspace - ! (the equivalent of (MatNullspace *) null in C) - MatNullSpace, intent(in) :: nullsp - logical :: IsNullMatNullSpace - - ! MatNullSpace(-1) is what is recognized as null in CHKFORTRANNULLOBJECT - ! MatNullSpace(0) is what is returned by MatGetNullspace if no nullspace is present - ! (because a wrapper on the output is missing, and there isn't a PETSC_NULL_MATNULLSPACE - ! in the first place) - IsNullMatNullSpace = nullsp%v==-1 .or. nullsp%v==0 - -end function IsNullMatNullSpace + subroutine petsc_test_error_handler(comm,line, func, file, dir, n, p, mess, ctx, ierr) + MPI_Comm:: comm + PetscInt:: line + character(len=*):: func, file, dir + PetscErrorCode:: n + PetscInt:: p + character(len=*):: mess + PetscInt:: ctx + PetscErrorCode:: ierr + + + petsc_test_error_handler_called = .true. + + end subroutine petsc_test_error_handler + + function IsNullMatNullSpace(nullsp) + ! This function checks whether `nullsp` is a NULL nullspace + ! (the equivalent of (MatNullspace *) null in C) + MatNullSpace, intent(in) :: nullsp + logical :: IsNullMatNullSpace + + ! MatNullSpace(-1) is what is recognized as null in CHKFORTRANNULLOBJECT + ! MatNullSpace(0) is what is returned by MatGetNullspace if no nullspace is present + ! (because a wrapper on the output is missing, and there isn't a PETSC_NULL_MATNULLSPACE + ! in the first place) + IsNullMatNullSpace = nullsp%v==-1 .or. nullsp%v==0 + + end function IsNullMatNullSpace #include "Reference_count_petsc_numbering_type.F90" end module Petsc_Tools diff --git a/femtools/Picker_Data_Types.F90 b/femtools/Picker_Data_Types.F90 index 0ce1c8675a..1716cf1b6f 100644 --- a/femtools/Picker_Data_Types.F90 +++ b/femtools/Picker_Data_Types.F90 @@ -29,31 +29,31 @@ module picker_data_types - use fldebug - use global_parameters, only : FIELD_NAME_LEN - use reference_counting - - implicit none - - private - - public :: picker_type, picker_ptr - - !! Picker (spatial index interface) information - type picker_type - !! Name of this picker - character(len = FIELD_NAME_LEN) :: name - !! Reference count for picker - type(refcount_type), pointer :: refcount => null() - !! Node owner finder ID for this picker - integer :: picker_id = 0 - !! Last mesh movement event - used to keep track of when a new picker must - !! be generated - integer :: last_mesh_movement = 0 - end type picker_type - - type picker_ptr - type(picker_type), pointer :: ptr => null() - end type picker_ptr + use fldebug + use global_parameters, only : FIELD_NAME_LEN + use reference_counting + + implicit none + + private + + public :: picker_type, picker_ptr + + !! Picker (spatial index interface) information + type picker_type + !! Name of this picker + character(len = FIELD_NAME_LEN) :: name + !! Reference count for picker + type(refcount_type), pointer :: refcount => null() + !! Node owner finder ID for this picker + integer :: picker_id = 0 + !! Last mesh movement event - used to keep track of when a new picker must + !! be generated + integer :: last_mesh_movement = 0 + end type picker_type + + type picker_ptr + type(picker_type), pointer :: ptr => null() + end type picker_ptr end module picker_data_types diff --git a/femtools/Pickers.F90 b/femtools/Pickers.F90 index bd9e8c4ee9..8dae1eb5fe 100644 --- a/femtools/Pickers.F90 +++ b/femtools/Pickers.F90 @@ -29,12 +29,12 @@ module pickers - use picker_data_types - use pickers_base - use pickers_deallocates - use pickers_allocates - use pickers_inquire + use picker_data_types + use pickers_base + use pickers_deallocates + use pickers_allocates + use pickers_inquire - implicit none + implicit none end module pickers diff --git a/femtools/Pickers_Allocates.F90 b/femtools/Pickers_Allocates.F90 index e57dc2d98d..58d57e01d2 100644 --- a/femtools/Pickers_Allocates.F90 +++ b/femtools/Pickers_Allocates.F90 @@ -29,85 +29,85 @@ module pickers_allocates - use fldebug - use global_parameters, only : empty_name - use elements - use eventcounter - use picker_data_types - use fields_data_types - use fields_base - use pickers_base - use pickers_deallocates - use node_owner_finder + use fldebug + use global_parameters, only : empty_name + use elements + use eventcounter + use picker_data_types + use fields_data_types + use fields_base + use pickers_base + use pickers_deallocates + use node_owner_finder - implicit none + implicit none - private + private - public :: allocate, initialise_picker, incref, has_references + public :: allocate, initialise_picker, incref, has_references - interface allocate - module procedure allocate_picker - end interface allocate + interface allocate + module procedure allocate_picker + end interface allocate contains - subroutine allocate_picker(picker, positions, name) - !!< Allocate a picker + subroutine allocate_picker(picker, positions, name) + !!< Allocate a picker - type(picker_type), intent(out) :: picker - type(vector_field), intent(in) :: positions - character(len = *), optional, intent(in) :: name + type(picker_type), intent(out) :: picker + type(vector_field), intent(in) :: positions + character(len = *), optional, intent(in) :: name - call node_owner_finder_set_input(picker%picker_id, positions) - ewrite(2, *) "New picker ID: ", picker%picker_id + call node_owner_finder_set_input(picker%picker_id, positions) + ewrite(2, *) "New picker ID: ", picker%picker_id - if(present(name)) then - call set_picker_name(picker, name) - else - call set_picker_name(picker, empty_name) - end if + if(present(name)) then + call set_picker_name(picker, name) + else + call set_picker_name(picker, empty_name) + end if - picker%last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + picker%last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - call addref(picker) + call addref(picker) - end subroutine allocate_picker + end subroutine allocate_picker - subroutine initialise_picker(positions) - !!< Initialise a picker for a Coordinate field + subroutine initialise_picker(positions) + !!< Initialise a picker for a Coordinate field - type(vector_field), intent(inout) :: positions + type(vector_field), intent(inout) :: positions - if(use_cached_picker(positions)) return + if(use_cached_picker(positions)) return - ewrite(2, *) "Initialising picker for field " // trim(positions%name) - assert(associated(positions%picker)) - if(associated(positions%picker%ptr)) call remove_picker(positions) - allocate(positions%picker%ptr) - call allocate(positions%picker%ptr, positions, name = trim(positions%name) // "Picker") + ewrite(2, *) "Initialising picker for field " // trim(positions%name) + assert(associated(positions%picker)) + if(associated(positions%picker%ptr)) call remove_picker(positions) + allocate(positions%picker%ptr) + call allocate(positions%picker%ptr, positions, name = trim(positions%name) // "Picker") - contains + contains - function use_cached_picker(positions) - type(vector_field), intent(in) :: positions + function use_cached_picker(positions) + type(vector_field), intent(in) :: positions - logical :: use_cached_picker + logical :: use_cached_picker - assert(associated(positions%picker)) - if(associated(positions%picker%ptr)) then - if(eventcount(EVENT_MESH_MOVEMENT) > positions%picker%ptr%last_mesh_movement) then - ! Mesh movement event has occurred - generate a new picker - use_cached_picker = .false. - else - use_cached_picker = .true. - end if - else - use_cached_picker = .false. - end if + assert(associated(positions%picker)) + if(associated(positions%picker%ptr)) then + if(eventcount(EVENT_MESH_MOVEMENT) > positions%picker%ptr%last_mesh_movement) then + ! Mesh movement event has occurred - generate a new picker + use_cached_picker = .false. + else + use_cached_picker = .true. + end if + else + use_cached_picker = .false. + end if - end function use_cached_picker + end function use_cached_picker - end subroutine initialise_picker + end subroutine initialise_picker end module pickers_allocates diff --git a/femtools/Pickers_Base.F90 b/femtools/Pickers_Base.F90 index a54e46beba..4d88ca44b2 100644 --- a/femtools/Pickers_Base.F90 +++ b/femtools/Pickers_Base.F90 @@ -29,36 +29,36 @@ module pickers_base - use fldebug - use picker_data_types + use fldebug + use picker_data_types - implicit none + implicit none - private + private - public :: picker_name, set_picker_name + public :: picker_name, set_picker_name contains - pure function picker_name(picker) - !!< Return the name of the supplied picker + pure function picker_name(picker) + !!< Return the name of the supplied picker - type(picker_type), intent(in) :: picker + type(picker_type), intent(in) :: picker - character(len = len_trim(picker%name)) :: picker_name + character(len = len_trim(picker%name)) :: picker_name - picker_name = picker%name + picker_name = picker%name - end function picker_name + end function picker_name - subroutine set_picker_name(picker, name) - !!< Set the name of the supplied picker + subroutine set_picker_name(picker, name) + !!< Set the name of the supplied picker - type(picker_type), intent(inout) :: picker - character(len = *), intent(in) :: name + type(picker_type), intent(inout) :: picker + character(len = *), intent(in) :: name - picker%name = name + picker%name = name - end subroutine set_picker_name + end subroutine set_picker_name end module pickers_base diff --git a/femtools/Pickers_Deallocates.F90 b/femtools/Pickers_Deallocates.F90 index d8ee264447..4b910d5d9e 100644 --- a/femtools/Pickers_Deallocates.F90 +++ b/femtools/Pickers_Deallocates.F90 @@ -29,33 +29,33 @@ module pickers_deallocates - use fldebug - use global_parameters, only : empty_name - use reference_counting - use picker_data_types - use fields_data_types - use pickers_base + use fldebug + use global_parameters, only : empty_name + use reference_counting + use picker_data_types + use fields_data_types + use pickers_base - implicit none + implicit none - private + private - public :: deallocate, nullify, remove_picker, addref, incref, has_references + public :: deallocate, nullify, remove_picker, addref, incref, has_references - interface deallocate - module procedure deallocate_picker - end interface deallocate + interface deallocate + module procedure deallocate_picker + end interface deallocate - interface nullify - module procedure nullify_picker - end interface nullify + interface nullify + module procedure nullify_picker + end interface nullify - interface node_owner_finder_reset - subroutine cnode_owner_finder_reset(id) - implicit none - integer, intent(in) :: id - end subroutine cnode_owner_finder_reset - end interface node_owner_finder_reset + interface node_owner_finder_reset + subroutine cnode_owner_finder_reset(id) + implicit none + integer, intent(in) :: id + end subroutine cnode_owner_finder_reset + end interface node_owner_finder_reset #include "Reference_count_interface_picker_type.F90" @@ -63,45 +63,45 @@ end subroutine cnode_owner_finder_reset #include "Reference_count_picker_type.F90" - subroutine deallocate_picker(picker) - !!< Deallocate a picker + subroutine deallocate_picker(picker) + !!< Deallocate a picker - type(picker_type), intent(inout) :: picker + type(picker_type), intent(inout) :: picker - call decref(picker) - if(has_references(picker)) return + call decref(picker) + if(has_references(picker)) return - ewrite(2, *) "Deallocating picker with ID", picker%picker_id - call node_owner_finder_reset(picker%picker_id) - call nullify(picker) + ewrite(2, *) "Deallocating picker with ID", picker%picker_id + call node_owner_finder_reset(picker%picker_id) + call nullify(picker) - end subroutine deallocate_picker + end subroutine deallocate_picker - subroutine nullify_picker(picker) - !!< Return a picker type to its uninitialised state + subroutine nullify_picker(picker) + !!< Return a picker type to its uninitialised state - type(picker_type), intent(inout) :: picker + type(picker_type), intent(inout) :: picker - type(picker_type) :: null_picker + type(picker_type) :: null_picker - ! Initialise the null_picker name to prevent uninitialised variable access - call set_picker_name(picker, empty_name) - picker = null_picker + ! Initialise the null_picker name to prevent uninitialised variable access + call set_picker_name(picker, empty_name) + picker = null_picker - end subroutine nullify_picker + end subroutine nullify_picker - subroutine remove_picker(field) - !!< Remove the picker from the supplied Coordinate field + subroutine remove_picker(field) + !!< Remove the picker from the supplied Coordinate field - type(vector_field), intent(inout) :: field + type(vector_field), intent(inout) :: field - assert(associated(field%picker)) - if(associated(field%picker%ptr)) then - call deallocate(field%picker%ptr) - deallocate(field%picker%ptr) - nullify(field%picker%ptr) - end if + assert(associated(field%picker)) + if(associated(field%picker%ptr)) then + call deallocate(field%picker%ptr) + deallocate(field%picker%ptr) + nullify(field%picker%ptr) + end if - end subroutine remove_picker + end subroutine remove_picker end module pickers_deallocates diff --git a/femtools/Pickers_Inquire.F90 b/femtools/Pickers_Inquire.F90 index bf1b8dacaa..65afece20b 100644 --- a/femtools/Pickers_Inquire.F90 +++ b/femtools/Pickers_Inquire.F90 @@ -29,351 +29,351 @@ module pickers_inquire - use fldebug - use data_structures - use element_numbering, only: FAMILY_SIMPLEX - use parallel_tools - use detector_data_types - use picker_data_types - use pickers_base - use transform_elements - use fields - use node_owner_finder - use pickers_allocates - - implicit none - - interface picker_inquire - module procedure picker_inquire_single_position, & + use fldebug + use data_structures + use element_numbering, only: FAMILY_SIMPLEX + use parallel_tools + use detector_data_types + use picker_data_types + use pickers_base + use transform_elements + use fields + use node_owner_finder + use pickers_allocates + + implicit none + + interface picker_inquire + module procedure picker_inquire_single_position, & & picker_inquire_single_position_xyz, picker_inquire_multiple_positions, & & picker_inquire_single_position_tolerance, & & picker_inquire_multiple_positions_tolerance, & & picker_inquire_multiple_positions_xyz, picker_inquire_node, & & picker_inquire_nodes, picker_inquire_node_tolerance, & & picker_inquire_nodes_tolerance - end interface picker_inquire + end interface picker_inquire - real, parameter, public :: max_picker_ownership_tolerance = rtree_tolerance + real, parameter, public :: max_picker_ownership_tolerance = rtree_tolerance - public :: picker_inquire, search_for_detectors + public :: picker_inquire, search_for_detectors - private + private contains - subroutine picker_inquire_single_position_xyz(positions, coordx, coordy, coordz, ele, local_coord, global) - !!< Find the owning elements in positions of the supplied coordinate - - type(vector_field), intent(inout) :: positions - real, intent(in) :: coordx - real, optional, intent(in) :: coordy - real, optional, intent(in) :: coordz - integer, intent(out) :: ele - !! The local coordinates of the coordinate in the owning element - real, dimension(positions%dim+1), optional, intent(out) :: local_coord - !! If present and .false., do not perform a global inquiry across all - !! processes - logical, optional, intent(in) :: global - - real, dimension(:), allocatable :: coord - - if(present(coordy)) then - if(present(coordz)) then - allocate(coord(3)) - coord = (/coordx, coordy, coordz/) + subroutine picker_inquire_single_position_xyz(positions, coordx, coordy, coordz, ele, local_coord, global) + !!< Find the owning elements in positions of the supplied coordinate + + type(vector_field), intent(inout) :: positions + real, intent(in) :: coordx + real, optional, intent(in) :: coordy + real, optional, intent(in) :: coordz + integer, intent(out) :: ele + !! The local coordinates of the coordinate in the owning element + real, dimension(positions%dim+1), optional, intent(out) :: local_coord + !! If present and .false., do not perform a global inquiry across all + !! processes + logical, optional, intent(in) :: global + + real, dimension(:), allocatable :: coord + + if(present(coordy)) then + if(present(coordz)) then + allocate(coord(3)) + coord = (/coordx, coordy, coordz/) + else + allocate(coord(2)) + coord = (/coordx, coordy/) + end if else - allocate(coord(2)) - coord = (/coordx, coordy/) + assert(.not. present(coordz)) + allocate(coord(1)) + coord = (/coordx/) end if - else - assert(.not. present(coordz)) - allocate(coord(1)) - coord = (/coordx/) - end if - call picker_inquire(positions, coord, ele, local_coord = local_coord, global = global) + call picker_inquire(positions, coord, ele, local_coord = local_coord, global = global) - deallocate(coord) + deallocate(coord) - end subroutine picker_inquire_single_position_xyz + end subroutine picker_inquire_single_position_xyz - subroutine picker_inquire_single_position(positions, coord, ele, local_coord, global) - !!< Find the owning elements in positions of the supplied coordinate + subroutine picker_inquire_single_position(positions, coord, ele, local_coord, global) + !!< Find the owning elements in positions of the supplied coordinate - type(vector_field), intent(inout) :: positions - real, dimension(positions%dim), intent(in) :: coord - integer, intent(out) :: ele - !! The local coordinates of the coordinate in the owning element - real, dimension(positions%dim+1), optional, intent(out) :: local_coord - !! If present and .false., do not perform a global inquiry across all - !! processes - logical, optional, intent(in) :: global + type(vector_field), intent(inout) :: positions + real, dimension(positions%dim), intent(in) :: coord + integer, intent(out) :: ele + !! The local coordinates of the coordinate in the owning element + real, dimension(positions%dim+1), optional, intent(out) :: local_coord + !! If present and .false., do not perform a global inquiry across all + !! processes + logical, optional, intent(in) :: global - call initialise_picker(positions) + call initialise_picker(positions) - call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coord, ele, global = global) - if(present(local_coord)) then - if(ele > 0) then - local_coord = local_coords(positions, ele, coord) - else - ! If we don't own this node then we really shouldn't be using any local - ! coord information - local_coord = huge(0.0) + call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coord, ele, global = global) + if(present(local_coord)) then + if(ele > 0) then + local_coord = local_coords(positions, ele, coord) + else + ! If we don't own this node then we really shouldn't be using any local + ! coord information + local_coord = huge(0.0) + end if end if - end if - - end subroutine picker_inquire_single_position - - subroutine picker_inquire_multiple_positions_xyz(positions, coordsx, coordsy, coordsz, eles, local_coords, global) - !!< Find the owning elements in positions of the supplied coordinates - - type(vector_field), intent(inout) :: positions - real, dimension(:), intent(in) :: coordsx - real, dimension(size(coordsx)), optional, intent(in) :: coordsy - real, dimension(size(coordsx)), optional, intent(in) :: coordsz - integer, dimension(size(coordsx)), intent(out) :: eles - !! The local coordinates of the coordinates in the owning elements - real, dimension(positions%dim+1, size(coordsx)), optional, intent(out) :: local_coords - !! If present and .false., do not perform a global inquiry across all - !! processes - logical, optional, intent(in) :: global - - real, dimension(:, :), allocatable :: coords - - if(present(coordsy)) then - if(present(coordsz)) then - allocate(coords(3, size(coordsx))) - coords(1, :) = coordsx - coords(2, :) = coordsy - coords(3, :) = coordsz + + end subroutine picker_inquire_single_position + + subroutine picker_inquire_multiple_positions_xyz(positions, coordsx, coordsy, coordsz, eles, local_coords, global) + !!< Find the owning elements in positions of the supplied coordinates + + type(vector_field), intent(inout) :: positions + real, dimension(:), intent(in) :: coordsx + real, dimension(size(coordsx)), optional, intent(in) :: coordsy + real, dimension(size(coordsx)), optional, intent(in) :: coordsz + integer, dimension(size(coordsx)), intent(out) :: eles + !! The local coordinates of the coordinates in the owning elements + real, dimension(positions%dim+1, size(coordsx)), optional, intent(out) :: local_coords + !! If present and .false., do not perform a global inquiry across all + !! processes + logical, optional, intent(in) :: global + + real, dimension(:, :), allocatable :: coords + + if(present(coordsy)) then + if(present(coordsz)) then + allocate(coords(3, size(coordsx))) + coords(1, :) = coordsx + coords(2, :) = coordsy + coords(3, :) = coordsz + else + allocate(coords(2, size(coordsx))) + coords(1, :) = coordsx + coords(2, :) = coordsy + end if else - allocate(coords(2, size(coordsx))) - coords(1, :) = coordsx - coords(2, :) = coordsy + assert(.not. present(coordsz)) + allocate(coords(1, size(coordsx))) + coords(1, :) = coordsx end if - else - assert(.not. present(coordsz)) - allocate(coords(1, size(coordsx))) - coords(1, :) = coordsx - end if - - call picker_inquire(positions, coords, eles, local_coords = local_coords, global = global) - - deallocate(coords) - - end subroutine picker_inquire_multiple_positions_xyz - - subroutine picker_inquire_multiple_positions(positions, coords, eles, local_coords, global) - !!< Find the owning elements in positions of the supplied coordinates - - type(vector_field), intent(inout) :: positions - real, dimension(:, :), intent(in) :: coords - integer, dimension(size(coords, 2)), intent(out) :: eles - !! The local coordinates of the coordinates in the owning elements - real, dimension(positions%dim+1, size(coords, 2)), optional, intent(out) :: local_coords - !! If present and .false., do not perform a global inquiry across all - !! processes - logical, optional, intent(in) :: global - - integer :: i - - assert(size(coords, 1) == positions%dim) - - call initialise_picker(positions) - - call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coords, eles, global = global) - if(present(local_coords)) then - do i = 1, size(coords, 2) - if(eles(i) > 0) then - local_coords(:, i) = local_coords_interpolation(positions, eles(i), coords(:, i)) - else - ! If we don't own this node then we really shouldn't be using any - ! local coord information - local_coords(:, i) = huge(0.0) - end if - end do - end if - end subroutine picker_inquire_multiple_positions + call picker_inquire(positions, coords, eles, local_coords = local_coords, global = global) - subroutine picker_inquire_single_position_tolerance(positions, coord, ele, ownership_tolerance) - !!< Find the owning elements in positions of the supplied coordinate - !!< using an ownership tolerance. This performs a strictly local (this - !!< process) ownership test. + deallocate(coords) - type(vector_field), intent(inout) :: positions - real, dimension(positions%dim), intent(in) :: coord - type(integer_set), intent(out) :: ele - real, intent(in) :: ownership_tolerance + end subroutine picker_inquire_multiple_positions_xyz - call initialise_picker(positions) - call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coord, ele, ownership_tolerance = ownership_tolerance) + subroutine picker_inquire_multiple_positions(positions, coords, eles, local_coords, global) + !!< Find the owning elements in positions of the supplied coordinates - end subroutine picker_inquire_single_position_tolerance + type(vector_field), intent(inout) :: positions + real, dimension(:, :), intent(in) :: coords + integer, dimension(size(coords, 2)), intent(out) :: eles + !! The local coordinates of the coordinates in the owning elements + real, dimension(positions%dim+1, size(coords, 2)), optional, intent(out) :: local_coords + !! If present and .false., do not perform a global inquiry across all + !! processes + logical, optional, intent(in) :: global - subroutine picker_inquire_multiple_positions_tolerance(positions, coords, eles, ownership_tolerance) - !!< Find the owning elements in positions of the supplied coordinates - !!< using an ownership tolerance. This performs a strictly local (this - !!< process) ownership test. + integer :: i - type(vector_field), intent(inout) :: positions - real, dimension(:, :), intent(in) :: coords - type(integer_set), dimension(size(coords, 2)), intent(out) :: eles - real, intent(in) :: ownership_tolerance + assert(size(coords, 1) == positions%dim) + + call initialise_picker(positions) + + call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coords, eles, global = global) + if(present(local_coords)) then + do i = 1, size(coords, 2) + if(eles(i) > 0) then + local_coords(:, i) = local_coords_interpolation(positions, eles(i), coords(:, i)) + else + ! If we don't own this node then we really shouldn't be using any + ! local coord information + local_coords(:, i) = huge(0.0) + end if + end do + end if - assert(size(coords, 1) == positions%dim) + end subroutine picker_inquire_multiple_positions - call initialise_picker(positions) - call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coords, eles, ownership_tolerance = ownership_tolerance) + subroutine picker_inquire_single_position_tolerance(positions, coord, ele, ownership_tolerance) + !!< Find the owning elements in positions of the supplied coordinate + !!< using an ownership tolerance. This performs a strictly local (this + !!< process) ownership test. - end subroutine picker_inquire_multiple_positions_tolerance + type(vector_field), intent(inout) :: positions + real, dimension(positions%dim), intent(in) :: coord + type(integer_set), intent(out) :: ele + real, intent(in) :: ownership_tolerance - subroutine picker_inquire_node(positions_a, positions_b, ele_a, node_b, local_coord, global) - !!< Find the owning element in positions_a of a node in positions_b + call initialise_picker(positions) + call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coord, ele, ownership_tolerance = ownership_tolerance) - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, intent(out) :: ele_a - integer, intent(in) :: node_b - !! The local coordinates of the node in the owning element - real, dimension(positions_a%dim+1), optional, intent(out) :: local_coord - !! If present and .false., do not perform a global inquiry across all - !! processes - logical, optional, intent(in) :: global + end subroutine picker_inquire_single_position_tolerance - assert(positions_a%dim == positions_b%dim) + subroutine picker_inquire_multiple_positions_tolerance(positions, coords, eles, ownership_tolerance) + !!< Find the owning elements in positions of the supplied coordinates + !!< using an ownership tolerance. This performs a strictly local (this + !!< process) ownership test. - if(present(local_coord)) then - call picker_inquire(positions_a, node_val(positions_b, node_b), ele_a, local_coord = local_coord, global = global) - else - call picker_inquire(positions_a, node_val(positions_b, node_b), ele_a, global = global) - end if + type(vector_field), intent(inout) :: positions + real, dimension(:, :), intent(in) :: coords + type(integer_set), dimension(size(coords, 2)), intent(out) :: eles + real, intent(in) :: ownership_tolerance - end subroutine picker_inquire_node + assert(size(coords, 1) == positions%dim) - subroutine picker_inquire_nodes(positions_a, positions_b, ele_as, local_coords, global) - !!< Find the owning elements in positions_a of the nodes in positions_b + call initialise_picker(positions) + call node_owner_finder_find(positions%picker%ptr%picker_id, positions, coords, eles, ownership_tolerance = ownership_tolerance) - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - integer, dimension(node_count(positions_b)), intent(out) :: ele_as - !! The local coordinates of the nodes in the owning elements - real, dimension(positions_a%dim+1, node_count(positions_b)), optional, intent(out) :: local_coords - !! If present and .false., do not perform a global inquiry across all - !! processes - logical, optional, intent(in) :: global + end subroutine picker_inquire_multiple_positions_tolerance - integer :: i - real, dimension(:, :), allocatable :: lpositions + subroutine picker_inquire_node(positions_a, positions_b, ele_a, node_b, local_coord, global) + !!< Find the owning element in positions_a of a node in positions_b - assert(positions_a%dim == positions_b%dim) + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, intent(out) :: ele_a + integer, intent(in) :: node_b + !! The local coordinates of the node in the owning element + real, dimension(positions_a%dim+1), optional, intent(out) :: local_coord + !! If present and .false., do not perform a global inquiry across all + !! processes + logical, optional, intent(in) :: global - allocate(lpositions(positions_b%dim, node_count(positions_b))) - do i = 1, node_count(positions_b) - lpositions(:, i) = node_val(positions_b, i) - end do + assert(positions_a%dim == positions_b%dim) - if(present(local_coords)) then - call picker_inquire(positions_a, lpositions, ele_as, local_coords = local_coords, global = global) - else - call picker_inquire(positions_a, lpositions, ele_as, global = global) - end if + if(present(local_coord)) then + call picker_inquire(positions_a, node_val(positions_b, node_b), ele_a, local_coord = local_coord, global = global) + else + call picker_inquire(positions_a, node_val(positions_b, node_b), ele_a, global = global) + end if - deallocate(lpositions) + end subroutine picker_inquire_node - end subroutine picker_inquire_nodes + subroutine picker_inquire_nodes(positions_a, positions_b, ele_as, local_coords, global) + !!< Find the owning elements in positions_a of the nodes in positions_b - subroutine picker_inquire_node_tolerance(positions_a, positions_b, ele_a, node_b, ownership_tolerance) - !!< Find the owning element in positions_a of a node in positions_b - !!< using an ownership tolerance. This performs a strictly local (this - !!< process) ownership test. + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + integer, dimension(node_count(positions_b)), intent(out) :: ele_as + !! The local coordinates of the nodes in the owning elements + real, dimension(positions_a%dim+1, node_count(positions_b)), optional, intent(out) :: local_coords + !! If present and .false., do not perform a global inquiry across all + !! processes + logical, optional, intent(in) :: global - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - type(integer_set), intent(out) :: ele_a - integer, intent(in) :: node_b - real, intent(in) :: ownership_tolerance + integer :: i + real, dimension(:, :), allocatable :: lpositions - assert(positions_a%dim == positions_b%dim) + assert(positions_a%dim == positions_b%dim) - call picker_inquire(positions_a, node_val(positions_b, node_b), ele_a, ownership_tolerance = ownership_tolerance) + allocate(lpositions(positions_b%dim, node_count(positions_b))) + do i = 1, node_count(positions_b) + lpositions(:, i) = node_val(positions_b, i) + end do - end subroutine picker_inquire_node_tolerance + if(present(local_coords)) then + call picker_inquire(positions_a, lpositions, ele_as, local_coords = local_coords, global = global) + else + call picker_inquire(positions_a, lpositions, ele_as, global = global) + end if - subroutine picker_inquire_nodes_tolerance(positions_a, positions_b, ele_as, ownership_tolerance) - !!< Find the owning elements in positions_a of the nodes in positions_b - !!< using an ownership tolerance. This performs a strictly local (this - !!< process) ownership test. + deallocate(lpositions) - type(vector_field), intent(inout) :: positions_a - type(vector_field), intent(in) :: positions_b - type(integer_set), dimension(node_count(positions_b)), intent(out) :: ele_as - real, intent(in) :: ownership_tolerance + end subroutine picker_inquire_nodes - integer :: i - real, dimension(:, :), allocatable :: lpositions + subroutine picker_inquire_node_tolerance(positions_a, positions_b, ele_a, node_b, ownership_tolerance) + !!< Find the owning element in positions_a of a node in positions_b + !!< using an ownership tolerance. This performs a strictly local (this + !!< process) ownership test. - assert(positions_a%dim == positions_b%dim) + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + type(integer_set), intent(out) :: ele_a + integer, intent(in) :: node_b + real, intent(in) :: ownership_tolerance - allocate(lpositions(positions_b%dim, node_count(positions_b))) - do i = 1, node_count(positions_b) - lpositions(:, i) = node_val(positions_b, i) - end do + assert(positions_a%dim == positions_b%dim) - call picker_inquire(positions_a, lpositions, ele_as, ownership_tolerance = ownership_tolerance) + call picker_inquire(positions_a, node_val(positions_b, node_b), ele_a, ownership_tolerance = ownership_tolerance) - deallocate(lpositions) + end subroutine picker_inquire_node_tolerance - end subroutine picker_inquire_nodes_tolerance + subroutine picker_inquire_nodes_tolerance(positions_a, positions_b, ele_as, ownership_tolerance) + !!< Find the owning elements in positions_a of the nodes in positions_b + !!< using an ownership tolerance. This performs a strictly local (this + !!< process) ownership test. - subroutine search_for_detectors(detectors, positions) - !!< This subroutine establishes on which processor, in which element and at - !!< which local coordinates each detector is to be found. A negative element - !!< value indicates that no element could be found for that node. - !!< Detectors are assumed to be local. - - !!< NOTE: This routine does not check whether all detectors have been found. "Lost" detectors - !!< are marked with a %element = -1. Therefore this routine should be followed by a call to - !!< distribute_detectors() to globally search for these, or if we know that this shouldn't occur - !!< a test that indeed all detectors have been found. + type(vector_field), intent(inout) :: positions_a + type(vector_field), intent(in) :: positions_b + type(integer_set), dimension(node_count(positions_b)), intent(out) :: ele_as + real, intent(in) :: ownership_tolerance - type(vector_field), intent(inout) :: positions - type(detector_linked_list), intent(inout) :: detectors - type(detector_type), pointer :: node + integer :: i + real, dimension(:, :), allocatable :: lpositions - integer :: i - real, dimension(:, :), allocatable :: coords, l_coords - integer, dimension(:), allocatable :: ele + assert(positions_a%dim == positions_b%dim) - call initialise_picker(positions) - assert(ele_numbering_family(positions, 1) == FAMILY_SIMPLEX) + allocate(lpositions(positions_b%dim, node_count(positions_b))) + do i = 1, node_count(positions_b) + lpositions(:, i) = node_val(positions_b, i) + end do - allocate(coords(positions%dim, detectors%length)) - allocate(l_coords(positions%dim+1, detectors%length)) - allocate(ele(detectors%length)) + call picker_inquire(positions_a, lpositions, ele_as, ownership_tolerance = ownership_tolerance) - node => detectors%first - do i = 1, detectors%length - coords(:, i) = node%position - node => node%next - end do + deallocate(lpositions) - ! First check locally - if (detectors%length > 0) then - call picker_inquire(positions, coords(:,:), ele(:), local_coords = l_coords(:,:), global = .false.) - end if + end subroutine picker_inquire_nodes_tolerance - node => detectors%first - do i = 1, detectors%length - node%local_coords = l_coords(:, i) - node%element = ele(i) - node => node%next - end do + subroutine search_for_detectors(detectors, positions) + !!< This subroutine establishes on which processor, in which element and at + !!< which local coordinates each detector is to be found. A negative element + !!< value indicates that no element could be found for that node. + !!< Detectors are assumed to be local. + + !!< NOTE: This routine does not check whether all detectors have been found. "Lost" detectors + !!< are marked with a %element = -1. Therefore this routine should be followed by a call to + !!< distribute_detectors() to globally search for these, or if we know that this shouldn't occur + !!< a test that indeed all detectors have been found. + + type(vector_field), intent(inout) :: positions + type(detector_linked_list), intent(inout) :: detectors + type(detector_type), pointer :: node + + integer :: i + real, dimension(:, :), allocatable :: coords, l_coords + integer, dimension(:), allocatable :: ele + + call initialise_picker(positions) + assert(ele_numbering_family(positions, 1) == FAMILY_SIMPLEX) + + allocate(coords(positions%dim, detectors%length)) + allocate(l_coords(positions%dim+1, detectors%length)) + allocate(ele(detectors%length)) + + node => detectors%first + do i = 1, detectors%length + coords(:, i) = node%position + node => node%next + end do + + ! First check locally + if (detectors%length > 0) then + call picker_inquire(positions, coords(:,:), ele(:), local_coords = l_coords(:,:), global = .false.) + end if + + node => detectors%first + do i = 1, detectors%length + node%local_coords = l_coords(:, i) + node%element = ele(i) + node => node%next + end do - deallocate(coords) - deallocate(l_coords) - deallocate(ele) + deallocate(coords) + deallocate(l_coords) + deallocate(ele) - end subroutine search_for_detectors + end subroutine search_for_detectors end module pickers_inquire diff --git a/femtools/Polynomials.F90 b/femtools/Polynomials.F90 index 2aea1eabd3..da81cbbf12 100644 --- a/femtools/Polynomials.F90 +++ b/femtools/Polynomials.F90 @@ -27,529 +27,529 @@ #include "fdebug.h" module polynomials - !!< Module implementing real polynomials of one variable. Available - !!< operations are addition, subtraction, multiplication and taking the - !!< derivative. - !!< - !!< The polynomials can, of course, be evaluated at any point. - !!< - !!< Since polynomials have a pointer component, they must be explicitly - !!< deallocated before they go out of scope or memory leaks will occur. - !!< - !!< The polynomial module also treats real vectors as - !!< polynomials where the entries of the vector are read as the - !!< coefficients of the polynomial. That is (/3.5, 1.0, 2.0/) is - !!< 3.5*x**2+x+2. - !!< - !!< To allow polynomials to grow from the front of the coefs array, the - !!< internal storage order of coefficients is the reverse of the external - !!< storage order. - !!< - !!< To avoid memory leaks, all functions return real vectors which are then - !!< turned into polynomials on assignment. Note however that at least one - !!< operand of each operation must be a polynomial and not a vector acting - !!< as a polynomial or the module won't know to do polynomial operations. - !!< - use FLDebug - use futils - - implicit none - - type polynomial - real, dimension(:), pointer :: coefs=>null() - integer :: degree=-1 - end type polynomial - - interface assignment(=) - module procedure assign_vec_poly, assign_poly_vec - end interface - - interface operator(+) - module procedure add_poly_poly, add_vec_poly, add_poly_vec - end interface - - interface operator(-) - module procedure subtract_poly_poly, subtract_vec_poly, & - subtract_poly_vec - end interface - - interface operator(-) - module procedure unary_minus_poly - end interface - - interface operator(*) - module procedure mult_poly_poly, mult_poly_vec, mult_vec_poly, & - mult_poly_scalar, mult_scalar_poly - end interface - - interface operator(/) - module procedure div_poly_scalar - end interface - - interface ddx - module procedure differentiate_poly, differentiate_vec - end interface - - interface eval - module procedure eval_poly_scalar, eval_poly_vector, & - eval_vec_scalar, eval_vec_vector - end interface - - interface deallocate - module procedure deallocate_polynomial - end interface - - private - public :: polynomial, ddx, eval, deallocate, assignment(=), & - operator(+), operator(-), operator(*), operator(/), poly2string,& - & write_polynomial + !!< Module implementing real polynomials of one variable. Available + !!< operations are addition, subtraction, multiplication and taking the + !!< derivative. + !!< + !!< The polynomials can, of course, be evaluated at any point. + !!< + !!< Since polynomials have a pointer component, they must be explicitly + !!< deallocated before they go out of scope or memory leaks will occur. + !!< + !!< The polynomial module also treats real vectors as + !!< polynomials where the entries of the vector are read as the + !!< coefficients of the polynomial. That is (/3.5, 1.0, 2.0/) is + !!< 3.5*x**2+x+2. + !!< + !!< To allow polynomials to grow from the front of the coefs array, the + !!< internal storage order of coefficients is the reverse of the external + !!< storage order. + !!< + !!< To avoid memory leaks, all functions return real vectors which are then + !!< turned into polynomials on assignment. Note however that at least one + !!< operand of each operation must be a polynomial and not a vector acting + !!< as a polynomial or the module won't know to do polynomial operations. + !!< + use FLDebug + use futils + + implicit none + + type polynomial + real, dimension(:), pointer :: coefs=>null() + integer :: degree=-1 + end type polynomial + + interface assignment(=) + module procedure assign_vec_poly, assign_poly_vec + end interface + + interface operator(+) + module procedure add_poly_poly, add_vec_poly, add_poly_vec + end interface + + interface operator(-) + module procedure subtract_poly_poly, subtract_vec_poly, & + subtract_poly_vec + end interface + + interface operator(-) + module procedure unary_minus_poly + end interface + + interface operator(*) + module procedure mult_poly_poly, mult_poly_vec, mult_vec_poly, & + mult_poly_scalar, mult_scalar_poly + end interface + + interface operator(/) + module procedure div_poly_scalar + end interface + + interface ddx + module procedure differentiate_poly, differentiate_vec + end interface + + interface eval + module procedure eval_poly_scalar, eval_poly_vector, & + eval_vec_scalar, eval_vec_vector + end interface + + interface deallocate + module procedure deallocate_polynomial + end interface + + private + public :: polynomial, ddx, eval, deallocate, assignment(=), & + operator(+), operator(-), operator(*), operator(/), poly2string,& + & write_polynomial contains - subroutine assign_vec_poly(poly, vec) - ! Assign a vector to a poly. - type(polynomial), intent(inout) :: poly - real, dimension(:), intent(in) :: vec + subroutine assign_vec_poly(poly, vec) + ! Assign a vector to a poly. + type(polynomial), intent(inout) :: poly + real, dimension(:), intent(in) :: vec - call upsize(poly, size(vec)-1, preserve=.false.) + call upsize(poly, size(vec)-1, preserve=.false.) - poly%degree=size(vec)-1 - poly%coefs(:size(vec))=reverse(vec) + poly%degree=size(vec)-1 + poly%coefs(:size(vec))=reverse(vec) - end subroutine assign_vec_poly + end subroutine assign_vec_poly - subroutine assign_poly_vec(vec, poly) - ! Assign a vector to a poly. - type(polynomial), intent(in) :: poly - real, dimension(poly%degree+1), intent(out) :: vec + subroutine assign_poly_vec(vec, poly) + ! Assign a vector to a poly. + type(polynomial), intent(in) :: poly + real, dimension(poly%degree+1), intent(out) :: vec - vec=reverse(poly%coefs(:poly%degree+1)) + vec=reverse(poly%coefs(:poly%degree+1)) - end subroutine assign_poly_vec + end subroutine assign_poly_vec - function add_poly_poly(poly1, poly2) result (sum) - ! Add two polynomials returning a vector. - type(polynomial), intent(in) :: poly1, poly2 - real, dimension(max(poly1%degree,poly2%degree)+1) :: sum + function add_poly_poly(poly1, poly2) result (sum) + ! Add two polynomials returning a vector. + type(polynomial), intent(in) :: poly1, poly2 + real, dimension(max(poly1%degree,poly2%degree)+1) :: sum - sum=0.0 - sum(:poly1%degree+1)=sum(:poly1%degree+1)& + sum=0.0 + sum(:poly1%degree+1)=sum(:poly1%degree+1)& +poly1%coefs(:poly1%degree+1) - sum(:poly2%degree+1)=sum(:poly2%degree+1)& + sum(:poly2%degree+1)=sum(:poly2%degree+1)& +poly2%coefs(:poly2%degree+1) - sum=reverse(sum) + sum=reverse(sum) - end function add_poly_poly + end function add_poly_poly - function add_poly_vec(poly, vec) result (sum) - ! Add two polynomials returning a vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vec - real, dimension(max(poly%degree+1,size(vec))) :: sum + function add_poly_vec(poly, vec) result (sum) + ! Add two polynomials returning a vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vec + real, dimension(max(poly%degree+1,size(vec))) :: sum - sum=0.0 - sum(:poly%degree+1)=sum(:poly%degree+1)& + sum=0.0 + sum(:poly%degree+1)=sum(:poly%degree+1)& +poly%coefs(:poly%degree+1) - sum(:size(vec))=sum(:size(vec))+reverse(vec) + sum(:size(vec))=sum(:size(vec))+reverse(vec) - sum=reverse(sum) + sum=reverse(sum) - end function add_poly_vec + end function add_poly_vec - function add_vec_poly(vec, poly) result (sum) - ! Add two polynomials returning a vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vec - real, dimension(max(poly%degree+1,size(vec))) :: sum + function add_vec_poly(vec, poly) result (sum) + ! Add two polynomials returning a vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vec + real, dimension(max(poly%degree+1,size(vec))) :: sum - sum=0.0 - sum(:size(vec))=sum(:size(vec))+reverse(vec) - sum(:poly%degree+1)=sum(:poly%degree+1)& + sum=0.0 + sum(:size(vec))=sum(:size(vec))+reverse(vec) + sum(:poly%degree+1)=sum(:poly%degree+1)& +poly%coefs(:poly%degree+1) - sum=reverse(sum) + sum=reverse(sum) - end function add_vec_poly + end function add_vec_poly - function subtract_poly_poly(poly1, poly2) result (diff) - ! Subtract two polynomials returning a vector. - type(polynomial), intent(in) :: poly1, poly2 - real, dimension(max(poly1%degree,poly2%degree)+1) :: diff + function subtract_poly_poly(poly1, poly2) result (diff) + ! Subtract two polynomials returning a vector. + type(polynomial), intent(in) :: poly1, poly2 + real, dimension(max(poly1%degree,poly2%degree)+1) :: diff - diff=0.0 - diff(:poly1%degree+1)=diff(:poly1%degree+1)& + diff=0.0 + diff(:poly1%degree+1)=diff(:poly1%degree+1)& +poly1%coefs(:poly1%degree+1) - diff(:poly2%degree+1)=diff(:poly2%degree+1)& + diff(:poly2%degree+1)=diff(:poly2%degree+1)& -poly2%coefs(:poly2%degree+1) - diff=reverse(diff) + diff=reverse(diff) - end function subtract_poly_poly + end function subtract_poly_poly - function subtract_poly_vec(poly, vec) result (diff) - ! Subtract two polynomials returning a vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vec - real, dimension(max(poly%degree+1,size(vec))) :: diff + function subtract_poly_vec(poly, vec) result (diff) + ! Subtract two polynomials returning a vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vec + real, dimension(max(poly%degree+1,size(vec))) :: diff - diff=0.0 - diff(:poly%degree+1)=diff(:poly%degree+1)& + diff=0.0 + diff(:poly%degree+1)=diff(:poly%degree+1)& +poly%coefs(:poly%degree+1) - diff(:size(vec))=diff(:size(vec))-reverse(vec) + diff(:size(vec))=diff(:size(vec))-reverse(vec) - diff=reverse(diff) + diff=reverse(diff) - end function subtract_poly_vec + end function subtract_poly_vec - function subtract_vec_poly(vec, poly) result (diff) - ! Subtract two polynomials returning a vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vec - real, dimension(max(poly%degree+1,size(vec))) :: diff + function subtract_vec_poly(vec, poly) result (diff) + ! Subtract two polynomials returning a vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vec + real, dimension(max(poly%degree+1,size(vec))) :: diff - diff=0.0 - diff(:size(vec))=diff(:size(vec))+reverse(vec) - diff(:poly%degree+1)=diff(:poly%degree+1)& + diff=0.0 + diff(:size(vec))=diff(:size(vec))+reverse(vec) + diff(:poly%degree+1)=diff(:poly%degree+1)& -poly%coefs(:poly%degree+1) - diff=reverse(diff) + diff=reverse(diff) - end function subtract_vec_poly + end function subtract_vec_poly - function unary_minus_poly(poly) result(minus_poly) - ! Calculate -1*poly. The result is a vector.. - type(polynomial), intent(in) :: poly - real, dimension(poly%degree+1) :: minus_poly + function unary_minus_poly(poly) result(minus_poly) + ! Calculate -1*poly. The result is a vector.. + type(polynomial), intent(in) :: poly + real, dimension(poly%degree+1) :: minus_poly - minus_poly=-reverse(poly%coefs(:poly%degree+1)) + minus_poly=-reverse(poly%coefs(:poly%degree+1)) - end function unary_minus_poly + end function unary_minus_poly - function mult_poly_poly(poly1,poly2) result (product) - ! Multiply two polynomials returning a vector. - type(polynomial), intent(in) :: poly1, poly2 - real, dimension(poly1%degree+poly2%degree+1) :: product + function mult_poly_poly(poly1,poly2) result (product) + ! Multiply two polynomials returning a vector. + type(polynomial), intent(in) :: poly1, poly2 + real, dimension(poly1%degree+poly2%degree+1) :: product - integer :: i + integer :: i - ! In this algorithm, product is assembled in increasing power order and - ! only reversed just before being returned. - product=0.0 + ! In this algorithm, product is assembled in increasing power order and + ! only reversed just before being returned. + product=0.0 - do i=1, poly1%degree+1 - ! Standard long multiplication algorithm for polynomials. - product(i:i+poly2%degree)=product(i:i+poly2%degree)+& + do i=1, poly1%degree+1 + ! Standard long multiplication algorithm for polynomials. + product(i:i+poly2%degree)=product(i:i+poly2%degree)+& poly1%coefs(i)*poly2%coefs(:poly2%degree+1) - end do + end do - product=reverse(product) + product=reverse(product) - end function mult_poly_poly + end function mult_poly_poly - function mult_poly_vec(poly,vec) result (product) - ! Multiply two polynomials returning a vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vec - real, dimension(poly%degree+size(vec)) :: product + function mult_poly_vec(poly,vec) result (product) + ! Multiply two polynomials returning a vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vec + real, dimension(poly%degree+size(vec)) :: product - integer :: i + integer :: i - ! In this algorithm, product is assembled in increasing power order and - ! only reversed just before being returned. - product=0.0 + ! In this algorithm, product is assembled in increasing power order and + ! only reversed just before being returned. + product=0.0 - do i=1, size(vec) - ! Standard long multiplication algorithm for polynomials. - product(i:i+poly%degree)=product(i:i+poly%degree)+& + do i=1, size(vec) + ! Standard long multiplication algorithm for polynomials. + product(i:i+poly%degree)=product(i:i+poly%degree)+& vec(size(vec)+1-i)*poly%coefs(:poly%degree+1) - end do + end do - product=reverse(product) + product=reverse(product) - end function mult_poly_vec + end function mult_poly_vec - function mult_vec_poly(vec,poly) result (product) - ! Multiply two polynomials returning a vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vec - real, dimension(poly%degree+size(vec)) :: product + function mult_vec_poly(vec,poly) result (product) + ! Multiply two polynomials returning a vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vec + real, dimension(poly%degree+size(vec)) :: product - integer :: i + integer :: i - ! In this algorithm, product is assembled in increasing power order and - ! only reversed just before being returned. - product=0.0 + ! In this algorithm, product is assembled in increasing power order and + ! only reversed just before being returned. + product=0.0 - do i=1, size(vec) - ! Standard long multiplication algorithm for polynomials. - product(i:i+poly%degree)=product(i:i+poly%degree)+& + do i=1, size(vec) + ! Standard long multiplication algorithm for polynomials. + product(i:i+poly%degree)=product(i:i+poly%degree)+& vec(size(vec)+1-i)*poly%coefs(:poly%degree+1) - end do + end do - product=reverse(product) + product=reverse(product) - end function mult_vec_poly + end function mult_vec_poly - function mult_poly_scalar(poly, scalar) result (product) - ! Multiply a polynomial by a scalar returning a vector. - type(polynomial), intent(in) :: poly - real, intent(in) :: scalar - real, dimension(poly%degree+1) :: product + function mult_poly_scalar(poly, scalar) result (product) + ! Multiply a polynomial by a scalar returning a vector. + type(polynomial), intent(in) :: poly + real, intent(in) :: scalar + real, dimension(poly%degree+1) :: product - product=poly - product=product*scalar + product=poly + product=product*scalar - end function mult_poly_scalar + end function mult_poly_scalar - function mult_scalar_poly(scalar, poly) result (product) - ! Multiply a polynomial by a scalar returning a vector. - type(polynomial), intent(in) :: poly - real, intent(in) :: scalar - real, dimension(poly%degree+1) :: product + function mult_scalar_poly(scalar, poly) result (product) + ! Multiply a polynomial by a scalar returning a vector. + type(polynomial), intent(in) :: poly + real, intent(in) :: scalar + real, dimension(poly%degree+1) :: product - product=poly - product=product*scalar + product=poly + product=product*scalar - end function mult_scalar_poly + end function mult_scalar_poly - function div_poly_scalar(poly, scalar) result (quotient) - ! Multiply a polynomial by a scalar returning a vector. - type(polynomial), intent(in) :: poly - real, intent(in) :: scalar - real, dimension(poly%degree+1) :: quotient + function div_poly_scalar(poly, scalar) result (quotient) + ! Multiply a polynomial by a scalar returning a vector. + type(polynomial), intent(in) :: poly + real, intent(in) :: scalar + real, dimension(poly%degree+1) :: quotient - quotient=poly - quotient=quotient/scalar + quotient=poly + quotient=quotient/scalar - end function div_poly_scalar + end function div_poly_scalar - function differentiate_poly(poly) result (diff) - ! Differentiate a polynomial returning a vector. - type(polynomial), intent(in) :: poly - ! The derivative is always at least degree 0! - real, dimension(max(poly%degree,1)) :: diff + function differentiate_poly(poly) result (diff) + ! Differentiate a polynomial returning a vector. + type(polynomial), intent(in) :: poly + ! The derivative is always at least degree 0! + real, dimension(max(poly%degree,1)) :: diff - integer :: i + integer :: i - ! This ensures that the degree 0 case is handled properly: - diff=0.0 + ! This ensures that the degree 0 case is handled properly: + diff=0.0 - forall (i=1:poly%degree) - diff(i)=(poly%degree+1-i)*poly%coefs(poly%degree+2-i) - end forall + forall (i=1:poly%degree) + diff(i)=(poly%degree+1-i)*poly%coefs(poly%degree+2-i) + end forall - end function differentiate_poly + end function differentiate_poly - function differentiate_vec(vec) result (diff) - ! Differentiate a polynomial returning a vector. - real, dimension(:), intent(in) :: vec - real, dimension(size(vec)-1) :: diff + function differentiate_vec(vec) result (diff) + ! Differentiate a polynomial returning a vector. + real, dimension(:), intent(in) :: vec + real, dimension(size(vec)-1) :: diff - integer :: i + integer :: i - forall (i=1:size(vec)-1) - diff(i)=(size(vec)-i)*vec(i) - end forall + forall (i=1:size(vec)-1) + diff(i)=(size(vec)-i)*vec(i) + end forall - end function differentiate_vec + end function differentiate_vec - pure function eval_poly_scalar(poly, scalar) result (val) - ! Evaluate poly(scalar) returning a scalar. - type(polynomial), intent(in) :: poly - real, intent(in) :: scalar - real :: val + pure function eval_poly_scalar(poly, scalar) result (val) + ! Evaluate poly(scalar) returning a scalar. + type(polynomial), intent(in) :: poly + real, intent(in) :: scalar + real :: val - integer :: i + integer :: i - val=0.0 + val=0.0 - do i=0,poly%degree + do i=0,poly%degree - val=val+poly%coefs(i+1)*scalar**i + val=val+poly%coefs(i+1)*scalar**i - end do + end do - end function eval_poly_scalar + end function eval_poly_scalar - pure function eval_poly_vector(poly, vector) result (val) - ! Evaluate poly at each element of vector. - type(polynomial), intent(in) :: poly - real, dimension(:), intent(in) :: vector - real, dimension(size(vector)) :: val + pure function eval_poly_vector(poly, vector) result (val) + ! Evaluate poly at each element of vector. + type(polynomial), intent(in) :: poly + real, dimension(:), intent(in) :: vector + real, dimension(size(vector)) :: val - integer :: i + integer :: i - val=0.0 + val=0.0 - do i=0,poly%degree + do i=0,poly%degree - val=val+poly%coefs(i+1)*vector**i + val=val+poly%coefs(i+1)*vector**i - end do + end do - end function eval_poly_vector + end function eval_poly_vector - pure function eval_vec_scalar(vec, scalar) result (val) - ! Evaluate vec(scalar) interpreting vec as a vector and - ! returning a scalar. - real, dimension(:), intent(in) :: vec - real, intent(in) :: scalar - real :: val + pure function eval_vec_scalar(vec, scalar) result (val) + ! Evaluate vec(scalar) interpreting vec as a vector and + ! returning a scalar. + real, dimension(:), intent(in) :: vec + real, intent(in) :: scalar + real :: val - integer :: i + integer :: i - val=0.0 + val=0.0 - do i=0,size(vec)-1 + do i=0,size(vec)-1 - val=val+vec(size(vec)-i)*scalar**i + val=val+vec(size(vec)-i)*scalar**i - end do + end do - end function eval_vec_scalar + end function eval_vec_scalar - pure function eval_vec_vector(vec, vector) result (val) - ! Evaluate vec interpreted at each element of vector. - real, dimension(:), intent(in) :: vec - real, dimension(:), intent(in) :: vector - real, dimension(size(vector)) :: val + pure function eval_vec_vector(vec, vector) result (val) + ! Evaluate vec interpreted at each element of vector. + real, dimension(:), intent(in) :: vec + real, dimension(:), intent(in) :: vector + real, dimension(size(vector)) :: val - integer :: i + integer :: i - val=0.0 + val=0.0 - do i=0,size(vec)-1 + do i=0,size(vec)-1 - val=val+vec(size(vec)-i)*vector**i + val=val+vec(size(vec)-i)*vector**i - end do + end do - end function eval_vec_vector + end function eval_vec_vector - subroutine upsize(poly, degree, preserve) - ! Ensure poly can handle entries of degree. - ! This preserves existing data unless preserve is - ! present and .false. in which case the polynomial is zeroed. - type(polynomial), intent(inout) :: poly - integer, intent(in) :: degree - logical, intent(in), optional :: preserve + subroutine upsize(poly, degree, preserve) + ! Ensure poly can handle entries of degree. + ! This preserves existing data unless preserve is + ! present and .false. in which case the polynomial is zeroed. + type(polynomial), intent(inout) :: poly + integer, intent(in) :: degree + logical, intent(in), optional :: preserve - real, dimension(:), pointer :: lcoefs + real, dimension(:), pointer :: lcoefs - if (associated(poly%coefs)) then - if (size(poly%coefs)>=degree+1) then - ! Nothing to do. - if (present_and_false(preserve)) then - poly%coefs=0.0 - end if - end if - end if + if (associated(poly%coefs)) then + if (size(poly%coefs)>=degree+1) then + ! Nothing to do. + if (present_and_false(preserve)) then + poly%coefs=0.0 + end if + end if + end if - lcoefs=>poly%coefs + lcoefs=>poly%coefs - allocate(poly%coefs(degree+1)) - poly%coefs=0.0 + allocate(poly%coefs(degree+1)) + poly%coefs=0.0 - if (associated(lcoefs)) then - ! Preserve existing data - if (.not.present_and_false(preserve)) then - poly%coefs(:poly%degree)=lcoefs - end if + if (associated(lcoefs)) then + ! Preserve existing data + if (.not.present_and_false(preserve)) then + poly%coefs(:poly%degree)=lcoefs + end if - deallocate(lcoefs) - end if + deallocate(lcoefs) + end if - end subroutine upsize + end subroutine upsize - subroutine deallocate_polynomial(poly, stat) - ! It's never necessary to allocate a polynomial since they - ! automagically acquire the right size but it is necessary to - ! deallocate them to prevent memory leaks. - type(polynomial), intent(inout) :: poly - integer, intent(out), optional :: stat + subroutine deallocate_polynomial(poly, stat) + ! It's never necessary to allocate a polynomial since they + ! automagically acquire the right size but it is necessary to + ! deallocate them to prevent memory leaks. + type(polynomial), intent(inout) :: poly + integer, intent(out), optional :: stat - integer :: lstat + integer :: lstat - deallocate(poly%coefs, stat=lstat) + deallocate(poly%coefs, stat=lstat) - poly%degree=-1 + poly%degree=-1 - if (present(stat)) then - stat=lstat - elseif (lstat/=0) then - FLAbort("Failed to deallocate polynomial") - end if + if (present(stat)) then + stat=lstat + elseif (lstat/=0) then + FLAbort("Failed to deallocate polynomial") + end if - end subroutine deallocate_polynomial + end subroutine deallocate_polynomial - pure function reverse(vec) - ! This function reverses the elements of vec. This is useful because - ! poly%coefs is in ascending order of power of x while vectors are - ! taken to be in descending order. - real, dimension(:), intent(in) :: vec - real, dimension(size(vec)) :: reverse + pure function reverse(vec) + ! This function reverses the elements of vec. This is useful because + ! poly%coefs is in ascending order of power of x while vectors are + ! taken to be in descending order. + real, dimension(:), intent(in) :: vec + real, dimension(size(vec)) :: reverse - reverse=vec(size(vec):1:-1) + reverse=vec(size(vec):1:-1) - end function reverse + end function reverse - subroutine write_polynomial(unit, poly, format) - !!< Output polynomial on unit. If format is present it specifies the - !!< format of coefficients, otherwise f8.3 is used. - integer, intent(in) :: unit - type(polynomial), intent(in) :: poly - character(len=*), intent(in), optional :: format - character(len=poly%degree*20+20) :: string + subroutine write_polynomial(unit, poly, format) + !!< Output polynomial on unit. If format is present it specifies the + !!< format of coefficients, otherwise f8.3 is used. + integer, intent(in) :: unit + type(polynomial), intent(in) :: poly + character(len=*), intent(in), optional :: format + character(len=poly%degree*20+20) :: string - string=poly2string(poly, format) + string=poly2string(poly, format) - write(unit, "(a)") trim(string) + write(unit, "(a)") trim(string) - end subroutine write_polynomial + end subroutine write_polynomial - function poly2string(poly, format) result (string) - !!< Produce a string representation of poly in which the coefficients - !!< have the format given by format, if present, and f8.3 otherwise. - type(polynomial), intent(in) :: poly - character(len=*), intent(in), optional :: format - character(len=poly%degree*20+20) :: string + function poly2string(poly, format) result (string) + !!< Produce a string representation of poly in which the coefficients + !!< have the format given by format, if present, and f8.3 otherwise. + type(polynomial), intent(in) :: poly + character(len=*), intent(in), optional :: format + character(len=poly%degree*20+20) :: string - character(len=1000) :: outformat - character(len=20) :: lformat - integer :: i + character(len=1000) :: outformat + character(len=20) :: lformat + integer :: i - type real_integer - !!< Local type with one real and one integer for io purposes. - real :: r - integer :: i - end type real_integer + type real_integer + !!< Local type with one real and one integer for io purposes. + real :: r + integer :: i + end type real_integer - type(real_integer), dimension(poly%degree-1) :: r_i + type(real_integer), dimension(poly%degree-1) :: r_i - if (present(format)) then - lformat=format - else - lformat='f8.3' - end if + if (present(format)) then + lformat=format + else + lformat='f8.3' + end if - forall (i=1:poly%degree-1) r_i(i)%i=i+1 + forall (i=1:poly%degree-1) r_i(i)%i=i+1 - r_i%r=poly%coefs(3:) + r_i%r=poly%coefs(3:) - ! Special case degree 0 and 1 polynomials - select case(poly%degree) - case (0) - write(string, "("//lformat//")") poly%coefs(1) - case (1) - write(string, "("//lformat//",'x + ',"//lformat//")") reverse(poly%coefs) - case default - write(outformat, "(a,i0,a)") "(",poly%degree-1,"("//trim(lformat) & - //",'x^',i0,' + ')"//trim(lformat)//",'x + ',"//trim(lformat)//")" + ! Special case degree 0 and 1 polynomials + select case(poly%degree) + case (0) + write(string, "("//lformat//")") poly%coefs(1) + case (1) + write(string, "("//lformat//",'x + ',"//lformat//")") reverse(poly%coefs) + case default + write(outformat, "(a,i0,a)") "(",poly%degree-1,"("//trim(lformat) & + //",'x^',i0,' + ')"//trim(lformat)//",'x + ',"//trim(lformat)//")" - write(string, outformat) r_i(size(r_i):1:-1), poly%coefs(2), poly%coefs(1) - end select + write(string, outformat) r_i(size(r_i):1:-1), poly%coefs(2), poly%coefs(1) + end select - end function poly2string + end function poly2string end module polynomials diff --git a/femtools/Profiler_Fortran.F90 b/femtools/Profiler_Fortran.F90 index b27360eb1c..5f722c7d99 100644 --- a/femtools/Profiler_Fortran.F90 +++ b/femtools/Profiler_Fortran.F90 @@ -26,208 +26,208 @@ ! USA module Profiler - use iso_c_binding, only : c_ptr, c_double - use fields - - implicit none - - private - - public profiler_tic, profiler_toc, profiler_zero, & - profiler_minorpagefaults, profiler_majorpagefaults, & - profiler_getresidence - - interface profiler_tic - module procedure profiler_tic_scalar, profiler_tic_vector, & - profiler_tic_tensor, profiler_tic_key - end interface profiler_tic - - interface profiler_toc - module procedure profiler_toc_scalar, profiler_toc_vector, & - profiler_toc_tensor, profiler_toc_key - end interface profiler_toc - - interface profiler_get - module procedure profiler_get_scalar, profiler_get_vector, & - profiler_get_tensor, profiler_get_key - end interface profiler_get - - interface - subroutine cprofiler_zero - end subroutine cprofiler_zero - - subroutine cprofiler_tic(key, key_len) - implicit none - integer, intent(in) :: key_len - character(len = key_len), intent(in) :: key - end subroutine cprofiler_tic - - subroutine cprofiler_toc(key, key_len) - implicit none - integer, intent(in) :: key_len - character(len = key_len), intent(in) :: key - end subroutine cprofiler_toc - - subroutine cprofiler_get(key, key_len, time) - use iso_c_binding, only: c_double - implicit none - integer, intent(in) :: key_len - character(len = key_len), intent(in) :: key - real(kind = c_double), intent(out) :: time - end subroutine cprofiler_get - - subroutine cprofiler_minorpagefaults(faults) - implicit none - integer, intent(out) :: faults - end subroutine cprofiler_minorpagefaults - - subroutine cprofiler_majorpagefaults(faults) - implicit none - integer, intent(out) :: faults - end subroutine cprofiler_majorpagefaults - - subroutine cprofiler_getresidence(ptr, residence) - use iso_c_binding, only : c_ptr - implicit none - type(c_ptr), intent(in) :: ptr - integer, intent(out):: residence - end subroutine cprofiler_getresidence - - end interface + use iso_c_binding, only : c_ptr, c_double + use fields + + implicit none + + private + + public profiler_tic, profiler_toc, profiler_zero, & + profiler_minorpagefaults, profiler_majorpagefaults, & + profiler_getresidence + + interface profiler_tic + module procedure profiler_tic_scalar, profiler_tic_vector, & + profiler_tic_tensor, profiler_tic_key + end interface profiler_tic + + interface profiler_toc + module procedure profiler_toc_scalar, profiler_toc_vector, & + profiler_toc_tensor, profiler_toc_key + end interface profiler_toc + + interface profiler_get + module procedure profiler_get_scalar, profiler_get_vector, & + profiler_get_tensor, profiler_get_key + end interface profiler_get + + interface + subroutine cprofiler_zero + end subroutine cprofiler_zero + + subroutine cprofiler_tic(key, key_len) + implicit none + integer, intent(in) :: key_len + character(len = key_len), intent(in) :: key + end subroutine cprofiler_tic + + subroutine cprofiler_toc(key, key_len) + implicit none + integer, intent(in) :: key_len + character(len = key_len), intent(in) :: key + end subroutine cprofiler_toc + + subroutine cprofiler_get(key, key_len, time) + use iso_c_binding, only: c_double + implicit none + integer, intent(in) :: key_len + character(len = key_len), intent(in) :: key + real(kind = c_double), intent(out) :: time + end subroutine cprofiler_get + + subroutine cprofiler_minorpagefaults(faults) + implicit none + integer, intent(out) :: faults + end subroutine cprofiler_minorpagefaults + + subroutine cprofiler_majorpagefaults(faults) + implicit none + integer, intent(out) :: faults + end subroutine cprofiler_majorpagefaults + + subroutine cprofiler_getresidence(ptr, residence) + use iso_c_binding, only : c_ptr + implicit none + type(c_ptr), intent(in) :: ptr + integer, intent(out):: residence + end subroutine cprofiler_getresidence + + end interface contains - real(kind = c_double) function profiler_get_scalar(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(scalar_field), intent(in):: field - character(len=*), intent(in):: action + real(kind = c_double) function profiler_get_scalar(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(scalar_field), intent(in):: field + character(len=*), intent(in):: action - profiler_get_scalar=profiler_get_key(create_profile_key(field%option_path, action)) + profiler_get_scalar=profiler_get_key(create_profile_key(field%option_path, action)) - end function profiler_get_scalar + end function profiler_get_scalar - real(kind = c_double) function profiler_get_vector(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(vector_field), intent(in):: field - character(len=*), intent(in):: action + real(kind = c_double) function profiler_get_vector(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(vector_field), intent(in):: field + character(len=*), intent(in):: action - profiler_get_vector=profiler_get_key(create_profile_key(field%option_path, action)) + profiler_get_vector=profiler_get_key(create_profile_key(field%option_path, action)) - end function profiler_get_vector + end function profiler_get_vector - real(kind = c_double) function profiler_get_tensor(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(tensor_field), intent(in):: field - character(len=*), intent(in):: action + real(kind = c_double) function profiler_get_tensor(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(tensor_field), intent(in):: field + character(len=*), intent(in):: action - profiler_get_tensor=profiler_get_key(create_profile_key(field%option_path, action)) + profiler_get_tensor=profiler_get_key(create_profile_key(field%option_path, action)) - end function profiler_get_tensor + end function profiler_get_tensor - real(kind = c_double) function profiler_get_key(key) - character(len=*), intent(in)::key - call cprofiler_get(key, len_trim(key), profiler_get_key) - end function profiler_get_key + real(kind = c_double) function profiler_get_key(key) + character(len=*), intent(in)::key + call cprofiler_get(key, len_trim(key), profiler_get_key) + end function profiler_get_key - subroutine profiler_tic_scalar(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(scalar_field), intent(in):: field - character(len=*), intent(in):: action + subroutine profiler_tic_scalar(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(scalar_field), intent(in):: field + character(len=*), intent(in):: action - call profiler_tic_key(create_profile_key(field%option_path, action)) + call profiler_tic_key(create_profile_key(field%option_path, action)) - end subroutine profiler_tic_scalar + end subroutine profiler_tic_scalar - subroutine profiler_tic_vector(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(vector_field), intent(in):: field - character(len=*), intent(in):: action + subroutine profiler_tic_vector(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(vector_field), intent(in):: field + character(len=*), intent(in):: action - call profiler_tic_key(create_profile_key(field%option_path, action)) + call profiler_tic_key(create_profile_key(field%option_path, action)) - end subroutine profiler_tic_vector + end subroutine profiler_tic_vector - subroutine profiler_tic_tensor(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(tensor_field), intent(in):: field - character(len=*), intent(in):: action + subroutine profiler_tic_tensor(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(tensor_field), intent(in):: field + character(len=*), intent(in):: action - call profiler_tic_key(create_profile_key(field%option_path, action)) + call profiler_tic_key(create_profile_key(field%option_path, action)) - end subroutine profiler_tic_tensor + end subroutine profiler_tic_tensor - subroutine profiler_toc_scalar(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(scalar_field), intent(in):: field - character(len=*), intent(in):: action + subroutine profiler_toc_scalar(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(scalar_field), intent(in):: field + character(len=*), intent(in):: action - call profiler_toc_key(create_profile_key(field%option_path, action)) + call profiler_toc_key(create_profile_key(field%option_path, action)) - end subroutine profiler_toc_scalar + end subroutine profiler_toc_scalar - subroutine profiler_toc_vector(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(vector_field), intent(in):: field - character(len=*), intent(in):: action + subroutine profiler_toc_vector(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(vector_field), intent(in):: field + character(len=*), intent(in):: action - call profiler_toc_key(create_profile_key(field%option_path, action)) + call profiler_toc_key(create_profile_key(field%option_path, action)) - end subroutine profiler_toc_vector + end subroutine profiler_toc_vector - subroutine profiler_toc_tensor(field, action) - !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation - !!< for field and stores this under a unique key - type(tensor_field), intent(in):: field - character(len=*), intent(in):: action + subroutine profiler_toc_tensor(field, action) + !!< Starts profiling a certain 'action', .e.g.: assembly, solve, interpolation + !!< for field and stores this under a unique key + type(tensor_field), intent(in):: field + character(len=*), intent(in):: action - call profiler_toc_key(create_profile_key(field%option_path, action)) + call profiler_toc_key(create_profile_key(field%option_path, action)) - end subroutine profiler_toc_tensor + end subroutine profiler_toc_tensor - function create_profile_key(option_path, action) - character(len=*), intent(in):: option_path, action - character(len=len_trim(option_path)+2+len_trim(action)):: create_profile_key + function create_profile_key(option_path, action) + character(len=*), intent(in):: option_path, action + character(len=len_trim(option_path)+2+len_trim(action)):: create_profile_key - create_profile_key=trim(option_path)//'::'//trim(action) + create_profile_key=trim(option_path)//'::'//trim(action) - end function create_profile_key + end function create_profile_key - subroutine profiler_tic_key(key) - character(len=*), intent(in)::key - call cprofiler_tic(key, len_trim(key)) - end subroutine profiler_tic_key + subroutine profiler_tic_key(key) + character(len=*), intent(in)::key + call cprofiler_tic(key, len_trim(key)) + end subroutine profiler_tic_key - subroutine profiler_toc_key(key) - character(len=*), intent(in)::key - call cprofiler_toc(key, len_trim(key)) - end subroutine profiler_toc_key + subroutine profiler_toc_key(key) + character(len=*), intent(in)::key + call cprofiler_toc(key, len_trim(key)) + end subroutine profiler_toc_key - subroutine profiler_zero() - call cprofiler_zero() - end subroutine profiler_zero + subroutine profiler_zero() + call cprofiler_zero() + end subroutine profiler_zero - subroutine profiler_minorpagefaults(faults) - integer, intent(out) :: faults - call cprofiler_minorpagefaults(faults) - end subroutine profiler_minorpagefaults + subroutine profiler_minorpagefaults(faults) + integer, intent(out) :: faults + call cprofiler_minorpagefaults(faults) + end subroutine profiler_minorpagefaults - subroutine profiler_majorpagefaults(faults) - integer, intent(out) :: faults - call cprofiler_majorpagefaults(faults) - end subroutine profiler_majorpagefaults + subroutine profiler_majorpagefaults(faults) + integer, intent(out) :: faults + call cprofiler_majorpagefaults(faults) + end subroutine profiler_majorpagefaults - subroutine profiler_getresidence(ptr, residence) - type(c_ptr), intent(in) :: ptr - integer, intent(out) :: residence - call cprofiler_getresidence(ptr, residence) - end subroutine profiler_getresidence + subroutine profiler_getresidence(ptr, residence) + type(c_ptr), intent(in) :: ptr + integer, intent(out) :: residence + call cprofiler_getresidence(ptr, residence) + end subroutine profiler_getresidence end module Profiler diff --git a/femtools/Pseudo_2D.F90 b/femtools/Pseudo_2D.F90 index 9f77e7cb24..fb1d73859c 100644 --- a/femtools/Pseudo_2D.F90 +++ b/femtools/Pseudo_2D.F90 @@ -26,14 +26,14 @@ ! USA subroutine set_pseudo2d_domain(val) - !!< Set the pseudo-2D coordinate + !!< Set the pseudo-2D coordinate - use node_boundary, only: pseudo2d_coord + use node_boundary, only: pseudo2d_coord - implicit none + implicit none - integer, intent(in) :: val + integer, intent(in) :: val - pseudo2d_coord = val + pseudo2d_coord = val end subroutine set_pseudo2d_domain diff --git a/femtools/Pseudo_Consistent_Interpolation.F90 b/femtools/Pseudo_Consistent_Interpolation.F90 index c09493d1b0..d27466f991 100644 --- a/femtools/Pseudo_Consistent_Interpolation.F90 +++ b/femtools/Pseudo_Consistent_Interpolation.F90 @@ -29,251 +29,251 @@ module pseudo_consistent_interpolation - use fldebug - use data_structures - use transform_elements - use fields - use state_module - use field_options - use node_ownership + use fldebug + use data_structures + use transform_elements + use fields + use state_module + use field_options + use node_ownership - implicit none + implicit none - private + private - public :: pseudo_consistent_interpolate + public :: pseudo_consistent_interpolate - interface pseudo_consistent_interpolate - module procedure pseudo_consistent_interpolate_state, & + interface pseudo_consistent_interpolate + module procedure pseudo_consistent_interpolate_state, & & pseudo_consistent_interpolate_states - end interface pseudo_consistent_interpolate + end interface pseudo_consistent_interpolate - !! The tolerance used for boundary node detection - real, parameter :: ownership_tolerance = 1.0e3 * epsilon(0.0) + !! The tolerance used for boundary node detection + real, parameter :: ownership_tolerance = 1.0e3 * epsilon(0.0) contains - subroutine pseudo_consistent_interpolate_state(old_state, new_state) - type(state_type), intent(in) :: old_state - type(state_type), intent(inout) :: new_state - - type(integer_set), dimension(:), allocatable :: map - - type(vector_field), pointer :: old_position - type(vector_field) :: new_position - - type(mesh_type), pointer :: old_mesh, new_mesh - integer :: new_node - integer :: ele - integer :: field_count_s - integer :: field_s - integer :: field_count_v - integer :: field_v - integer :: field_count_t - integer :: field_t - integer, dimension(:), pointer :: node_list - integer :: i, j - real :: val_s - real, dimension(mesh_dim(old_state%meshes(1)%ptr)) :: val_v - real, dimension(mesh_dim(old_state%meshes(1)%ptr), mesh_dim(old_state%meshes(1)%ptr)) :: val_t - real, dimension(:), allocatable :: local_coord, shape_fns - - type(scalar_field), dimension(:), allocatable, target :: old_fields_s - type(scalar_field), dimension(:), allocatable, target :: new_fields_s - - type(vector_field), dimension(:), allocatable, target :: old_fields_v - type(vector_field), dimension(:), allocatable, target :: new_fields_v - - type(tensor_field), dimension(:), allocatable, target :: old_fields_t - type(tensor_field), dimension(:), allocatable, target :: new_fields_t - - integer :: elei, neles - - ewrite(1, *) "In pseudo_consistent_interpolate_state" - - field_count_s = scalar_field_count(old_state) - field_count_v = vector_field_count(old_state) - field_count_t = tensor_field_count(old_state) - - if(field_count_s > 0) then - allocate(old_fields_s(field_count_s)) - allocate(new_fields_s(field_count_s)) - end if - if(field_count_v > 0) then - allocate(old_fields_v(field_count_v)) - allocate(new_fields_v(field_count_v)) - end if - if(field_count_t > 0) then - allocate(old_fields_t(field_count_t)) - allocate(new_fields_t(field_count_t)) - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Scalar fields - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if(field_count_s > 0) then - ! Construct the list of new_fields to be modified - - do field_s=1,field_count_s - old_fields_s(field_s) = extract_scalar_field(old_state, field_s) - new_fields_s(field_s) = extract_scalar_field(new_state, field_s) - ! Zero the new fields. - call zero(new_fields_s(field_s)) - end do - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Vector fields - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - j=1 - do i=1, field_count_v - old_fields_v(j) = extract_vector_field(old_state, i) - ! skip coordinate fields - if (.not. (old_fields_v(j)%name=="Coordinate" .or. & - old_fields_v(j)%name==trim(old_fields_v(j)%mesh%name)//"Coordinate")) then - - new_fields_v(j) = extract_vector_field(new_state, i) - ! Zero the new fields. - call zero(new_fields_v(j)) - j=j+1 + subroutine pseudo_consistent_interpolate_state(old_state, new_state) + type(state_type), intent(in) :: old_state + type(state_type), intent(inout) :: new_state + + type(integer_set), dimension(:), allocatable :: map + + type(vector_field), pointer :: old_position + type(vector_field) :: new_position + + type(mesh_type), pointer :: old_mesh, new_mesh + integer :: new_node + integer :: ele + integer :: field_count_s + integer :: field_s + integer :: field_count_v + integer :: field_v + integer :: field_count_t + integer :: field_t + integer, dimension(:), pointer :: node_list + integer :: i, j + real :: val_s + real, dimension(mesh_dim(old_state%meshes(1)%ptr)) :: val_v + real, dimension(mesh_dim(old_state%meshes(1)%ptr), mesh_dim(old_state%meshes(1)%ptr)) :: val_t + real, dimension(:), allocatable :: local_coord, shape_fns + + type(scalar_field), dimension(:), allocatable, target :: old_fields_s + type(scalar_field), dimension(:), allocatable, target :: new_fields_s + + type(vector_field), dimension(:), allocatable, target :: old_fields_v + type(vector_field), dimension(:), allocatable, target :: new_fields_v + + type(tensor_field), dimension(:), allocatable, target :: old_fields_t + type(tensor_field), dimension(:), allocatable, target :: new_fields_t + + integer :: elei, neles + + ewrite(1, *) "In pseudo_consistent_interpolate_state" + + field_count_s = scalar_field_count(old_state) + field_count_v = vector_field_count(old_state) + field_count_t = tensor_field_count(old_state) + + if(field_count_s > 0) then + allocate(old_fields_s(field_count_s)) + allocate(new_fields_s(field_count_s)) + end if + if(field_count_v > 0) then + allocate(old_fields_v(field_count_v)) + allocate(new_fields_v(field_count_v)) + end if + if(field_count_t > 0) then + allocate(old_fields_t(field_count_t)) + allocate(new_fields_t(field_count_t)) end if - end do - field_count_v = j - 1 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Tensor fields - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Scalar fields + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if(field_count_t > 0) then - ! Construct the list of new_fields to be modified + if(field_count_s > 0) then + ! Construct the list of new_fields to be modified - do field_t=1,field_count_t - old_fields_t(field_t) = extract_tensor_field(old_state, field_t) - new_fields_t(field_t) = extract_tensor_field(new_state, field_t) - ! Zero the new fields. - call zero(new_fields_t(field_t)) + do field_s=1,field_count_s + old_fields_s(field_s) = extract_scalar_field(old_state, field_s) + new_fields_s(field_s) = extract_scalar_field(new_state, field_s) + ! Zero the new fields. + call zero(new_fields_s(field_s)) + end do + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Vector fields + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + j=1 + do i=1, field_count_v + old_fields_v(j) = extract_vector_field(old_state, i) + ! skip coordinate fields + if (.not. (old_fields_v(j)%name=="Coordinate" .or. & + old_fields_v(j)%name==trim(old_fields_v(j)%mesh%name)//"Coordinate")) then + + new_fields_v(j) = extract_vector_field(new_state, i) + ! Zero the new fields. + call zero(new_fields_v(j)) + j=j+1 + end if end do - end if - - if(field_count_s > 0) then - old_mesh => old_fields_s(1)%mesh - new_mesh => new_fields_s(1)%mesh - else if(field_count_v > 0) then - old_mesh => old_fields_v(1)%mesh - new_mesh => new_fields_v(1)%mesh - else if(field_count_t > 0) then - old_mesh => old_fields_t(1)%mesh - new_mesh => new_fields_t(1)%mesh - else - return - end if - - if(continuity(new_mesh) == 0) then - ewrite(0, *) "For mesh " // trim(new_mesh%name) - ewrite(0, *) "Warning: Pseudo consistent interpolation applied for fields on a continuous mesh" - end if - - old_position => extract_vector_field(old_state, "Coordinate") - new_position=get_coordinate_field(new_state, new_mesh) - - allocate(local_coord(mesh_dim(new_position) + 1)) - allocate(shape_fns(ele_loc(old_mesh, 1))) - - allocate(map(node_count(new_mesh))) - call find_node_ownership(old_position, new_position, map, ownership_tolerance = ownership_tolerance) - - ! Loop over the nodes of the new mesh. - - do new_node=1,node_count(new_mesh) - - neles = key_count(map(new_node)) - assert(neles > 0) - do elei = 1, neles - ! In what element of the old mesh does the new node lie? - ! Find the local coordinates of the point in that element, - ! and evaluate all the shape functions at that point - ele = fetch(map(new_node), elei) - - node_list => ele_nodes(old_mesh, ele) - local_coord = local_coords(old_position, ele, node_val(new_position, new_node)) - shape_fns = eval_shape(ele_shape(old_mesh, ele), local_coord) - - do field_s=1,field_count_s - ! At each node of the old element, evaluate val * shape_fn - val_s = 0.0 - do i=1,ele_loc(old_mesh, ele) - val_s = val_s + node_val(old_fields_s(field_s), node_list(i)) * shape_fns(i) - end do - call addto(new_fields_s(field_s), new_node, val_s / float(neles)) - end do - - do field_v=1,field_count_v - ! At each node of the old element, evaluate val * shape_fn - val_v = 0.0 - do i=1,ele_loc(old_mesh, ele) - val_v = val_v + node_val(old_fields_v(field_v), node_list(i)) * shape_fns(i) - end do - call addto(new_fields_v(field_v), new_node, val_v / float(neles)) - end do - - do field_t=1,field_count_t - ! At each node of the old element, evaluate val * shape_fn - val_t = 0.0 - do i=1,ele_loc(old_mesh, ele) - val_t = val_t + node_val(old_fields_t(field_t), node_list(i)) * shape_fns(i) - end do - call addto(new_fields_t(field_t), new_node, val_t / float(neles)) - end do + field_count_v = j - 1 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Tensor fields + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(field_count_t > 0) then + ! Construct the list of new_fields to be modified + + do field_t=1,field_count_t + old_fields_t(field_t) = extract_tensor_field(old_state, field_t) + new_fields_t(field_t) = extract_tensor_field(new_state, field_t) + ! Zero the new fields. + call zero(new_fields_t(field_t)) + end do + end if + + if(field_count_s > 0) then + old_mesh => old_fields_s(1)%mesh + new_mesh => new_fields_s(1)%mesh + else if(field_count_v > 0) then + old_mesh => old_fields_v(1)%mesh + new_mesh => new_fields_v(1)%mesh + else if(field_count_t > 0) then + old_mesh => old_fields_t(1)%mesh + new_mesh => new_fields_t(1)%mesh + else + return + end if + + if(continuity(new_mesh) == 0) then + ewrite(0, *) "For mesh " // trim(new_mesh%name) + ewrite(0, *) "Warning: Pseudo consistent interpolation applied for fields on a continuous mesh" + end if + + old_position => extract_vector_field(old_state, "Coordinate") + new_position=get_coordinate_field(new_state, new_mesh) + + allocate(local_coord(mesh_dim(new_position) + 1)) + allocate(shape_fns(ele_loc(old_mesh, 1))) + + allocate(map(node_count(new_mesh))) + call find_node_ownership(old_position, new_position, map, ownership_tolerance = ownership_tolerance) + + ! Loop over the nodes of the new mesh. + + do new_node=1,node_count(new_mesh) + + neles = key_count(map(new_node)) + assert(neles > 0) + do elei = 1, neles + ! In what element of the old mesh does the new node lie? + ! Find the local coordinates of the point in that element, + ! and evaluate all the shape functions at that point + ele = fetch(map(new_node), elei) + + node_list => ele_nodes(old_mesh, ele) + local_coord = local_coords(old_position, ele, node_val(new_position, new_node)) + shape_fns = eval_shape(ele_shape(old_mesh, ele), local_coord) + + do field_s=1,field_count_s + ! At each node of the old element, evaluate val * shape_fn + val_s = 0.0 + do i=1,ele_loc(old_mesh, ele) + val_s = val_s + node_val(old_fields_s(field_s), node_list(i)) * shape_fns(i) + end do + call addto(new_fields_s(field_s), new_node, val_s / float(neles)) + end do + + do field_v=1,field_count_v + ! At each node of the old element, evaluate val * shape_fn + val_v = 0.0 + do i=1,ele_loc(old_mesh, ele) + val_v = val_v + node_val(old_fields_v(field_v), node_list(i)) * shape_fns(i) + end do + call addto(new_fields_v(field_v), new_node, val_v / float(neles)) + end do + + do field_t=1,field_count_t + ! At each node of the old element, evaluate val * shape_fn + val_t = 0.0 + do i=1,ele_loc(old_mesh, ele) + val_t = val_t + node_val(old_fields_t(field_t), node_list(i)) * shape_fns(i) + end do + call addto(new_fields_t(field_t), new_node, val_t / float(neles)) + end do + end do end do - end do - call deallocate(map) - deallocate(map) - deallocate(local_coord) - deallocate(shape_fns) + call deallocate(map) + deallocate(map) + deallocate(local_coord) + deallocate(shape_fns) - call deallocate(new_position) + call deallocate(new_position) - do field_s = 1, field_count_s - call halo_update(new_fields_s(field_s)) - end do - do field_v = 1, field_count_v - call halo_update(new_fields_v(field_v)) - end do - do field_t = 1, field_count_t - call halo_update(new_fields_t(field_t)) - end do + do field_s = 1, field_count_s + call halo_update(new_fields_s(field_s)) + end do + do field_v = 1, field_count_v + call halo_update(new_fields_v(field_v)) + end do + do field_t = 1, field_count_t + call halo_update(new_fields_t(field_t)) + end do - ewrite(1, *) "Exiting pseudo_consistent_interpolate_state" + ewrite(1, *) "Exiting pseudo_consistent_interpolate_state" - end subroutine pseudo_consistent_interpolate_state + end subroutine pseudo_consistent_interpolate_state - subroutine pseudo_consistent_interpolate_states(old_states, new_states) - type(state_type), dimension(:), intent(in) :: old_states - type(state_type), dimension(size(old_states)), intent(inout) :: new_states + subroutine pseudo_consistent_interpolate_states(old_states, new_states) + type(state_type), dimension(:), intent(in) :: old_states + type(state_type), dimension(size(old_states)), intent(inout) :: new_states - integer :: i, j - type(mesh_type), pointer:: old_mesh, new_mesh - type(state_type) :: old_mesh_state - type(vector_field), pointer :: old_positions + integer :: i, j + type(mesh_type), pointer:: old_mesh, new_mesh + type(state_type) :: old_mesh_state + type(vector_field), pointer :: old_positions - do i = 1, size(new_states) - do j = 1, mesh_count(new_states(i)) - new_mesh => extract_mesh(new_states(i), j) - old_mesh => extract_mesh(old_states(i), new_mesh%name) - call select_state_by_mesh(old_states(i), new_mesh%name, old_mesh_state) + do i = 1, size(new_states) + do j = 1, mesh_count(new_states(i)) + new_mesh => extract_mesh(new_states(i), j) + old_mesh => extract_mesh(old_states(i), new_mesh%name) + call select_state_by_mesh(old_states(i), new_mesh%name, old_mesh_state) - old_positions => extract_vector_field(old_states(i), "Coordiante") - call insert(old_mesh_state, old_positions, old_positions%name) + old_positions => extract_vector_field(old_states(i), "Coordiante") + call insert(old_mesh_state, old_positions, old_positions%name) - call pseudo_consistent_interpolate(old_mesh_state, new_states(i)) + call pseudo_consistent_interpolate(old_mesh_state, new_states(i)) - call deallocate(old_mesh_state) + call deallocate(old_mesh_state) + end do end do - end do - end subroutine pseudo_consistent_interpolate_states + end subroutine pseudo_consistent_interpolate_states end module pseudo_consistent_interpolation diff --git a/femtools/Quadrature.F90 b/femtools/Quadrature.F90 index bff6cac237..bb3b5acfb9 100644 --- a/femtools/Quadrature.F90 +++ b/femtools/Quadrature.F90 @@ -27,229 +27,270 @@ #include "fdebug.h" module quadrature - !!< This module implements quadrature of varying degrees for a number of - !!< elements. Quadrature information is used to numerically evaluate - !!< integrals over an element. - use FLDebug - use reference_counting - use wandzura_quadrature - use grundmann_moeller_quadrature - use vector_tools - implicit none - - private - - type permutation_type - !!< A type encoding a series of permutations. This type is only used - !!< internally in the quadrature module. - - !! Each column of P is a different permuation of points which can be - !! used in quadrature on a given element shape. - integer, pointer, dimension(:,:) :: p - end type permutation_type - - type generator_type - !!< The generator type is an encoding of a quadrature generator of the - !!< type used in the encyclopedia of cubature. This type is only used - !!< internally in the quadrature module. - integer, dimension(:,:), pointer :: permutation - real, dimension(:), pointer :: coords - real :: weight - end type generator_type - - type quadrature_template - !!< A data type which defines a quadrature rule. These are only - !!< directly used inside the quadrature module. - - !! A quadrature is defined by a set of generators. - type(generator_type), dimension(:), pointer :: generator - !! Dimension of the space we are in and the degree of accuracy of the - !! quadrature. - integer :: dim, degree - !! Ngi is number of quadrature points. Vertices is number of vertices. These - !! names are chosen for consistency with the rest of fluidity. - integer :: ngi, vertices - end type quadrature_template - - type quadrature_type - !!< A data type which describes quadrature information. For most - !!< developers, quadrature can be treated as an opaque data type which - !!< will only be encountered when creating element_type variables to - !!< represent shape functions. - integer :: dim !! Dimension of the elements for which quadrature - !!< is required. - integer :: degree !! Degree of accuracy of quadrature. - integer :: vertices !! Number of vertices of the element. - integer :: ngi !! Number of quadrature points. - real, pointer :: weight(:)=>null() !! Quadrature weights. - real, pointer :: l(:,:)=>null() !! Locations of quadrature points. - character(len=0) :: name !! Fake name for reference counting. - !! Reference count to prevent memory leaks. - type(refcount_type), pointer :: refcount=>null() - integer :: family - end type quadrature_type - - type(permutation_type), dimension(11), target, save :: tet_permutations - type(permutation_type), dimension(6), target, save :: tri_permutations - ! Cyclic permutations for triangles. - type(permutation_type), dimension(6), target, save :: tri_cycles - type(permutation_type), dimension(2), target, save :: interval_permutations - type(permutation_type), dimension(7), target, save :: hex_permutations - type(permutation_type), dimension(4), target, save :: quad_permutations - type(permutation_type), dimension(1), target, save :: point_permutation - - type(quadrature_template), dimension(8), target, save, public :: tet_quads - type(quadrature_template), dimension(8), target, save, public :: tri_quads - type(quadrature_template), dimension(8), target, save, public :: interval_quads - type(quadrature_template), dimension(6), target, save, public :: hex_quads - type(quadrature_template), dimension(6), target, save, public :: quad_quads - type(quadrature_template), dimension(1), target, save, public :: point_quad - - character(len=100), save, public :: quadrature_error_message="" - - !! Unsupported vertex count. - integer, parameter, public :: QUADRATURE_VERTEX_ERROR=1 - !! Quadrature degree requested is not available. - integer, parameter, public :: QUADRATURE_DEGREE_ERROR=2 - !! Elements with this number of dimensions are not available. - integer, parameter, public :: QUADRATURE_DIMENSION_ERROR=3 - !! Unsupported number of quadrature points. - integer, parameter, public :: QUADRATURE_NGI_ERROR=4 - !! Not enough arguments specified. - integer, parameter, public :: QUADRATURE_ARGUMENT_ERROR=5 - - logical, save, private :: initialised=.false. - - integer, parameter :: FAMILY_COOLS=0, FAMILY_WANDZURA=1, FAMILY_GM=2 - - interface allocate - module procedure allocate_quad - end interface - - interface deallocate - module procedure deallocate_quad - end interface - - interface operator (==) - module procedure quad_equal - end interface + !!< This module implements quadrature of varying degrees for a number of + !!< elements. Quadrature information is used to numerically evaluate + !!< integrals over an element. + use FLDebug + use reference_counting + use wandzura_quadrature + use grundmann_moeller_quadrature + use vector_tools + implicit none + + private + + type permutation_type + !!< A type encoding a series of permutations. This type is only used + !!< internally in the quadrature module. + + !! Each column of P is a different permuation of points which can be + !! used in quadrature on a given element shape. + integer, pointer, dimension(:,:) :: p + end type permutation_type + + type generator_type + !!< The generator type is an encoding of a quadrature generator of the + !!< type used in the encyclopedia of cubature. This type is only used + !!< internally in the quadrature module. + integer, dimension(:,:), pointer :: permutation + real, dimension(:), pointer :: coords + real :: weight + end type generator_type + + type quadrature_template + !!< A data type which defines a quadrature rule. These are only + !!< directly used inside the quadrature module. + + !! A quadrature is defined by a set of generators. + type(generator_type), dimension(:), pointer :: generator + !! Dimension of the space we are in and the degree of accuracy of the + !! quadrature. + integer :: dim, degree + !! Ngi is number of quadrature points. Vertices is number of vertices. These + !! names are chosen for consistency with the rest of fluidity. + integer :: ngi, vertices + end type quadrature_template + + type quadrature_type + !!< A data type which describes quadrature information. For most + !!< developers, quadrature can be treated as an opaque data type which + !!< will only be encountered when creating element_type variables to + !!< represent shape functions. + integer :: dim !! Dimension of the elements for which quadrature + !!< is required. + integer :: degree !! Degree of accuracy of quadrature. + integer :: vertices !! Number of vertices of the element. + integer :: ngi !! Number of quadrature points. + real, pointer :: weight(:)=>null() !! Quadrature weights. + real, pointer :: l(:,:)=>null() !! Locations of quadrature points. + character(len=0) :: name !! Fake name for reference counting. + !! Reference count to prevent memory leaks. + type(refcount_type), pointer :: refcount=>null() + integer :: family + end type quadrature_type + + type(permutation_type), dimension(11), target, save :: tet_permutations + type(permutation_type), dimension(6), target, save :: tri_permutations + ! Cyclic permutations for triangles. + type(permutation_type), dimension(6), target, save :: tri_cycles + type(permutation_type), dimension(2), target, save :: interval_permutations + type(permutation_type), dimension(7), target, save :: hex_permutations + type(permutation_type), dimension(4), target, save :: quad_permutations + type(permutation_type), dimension(1), target, save :: point_permutation + + type(quadrature_template), dimension(8), target, save, public :: tet_quads + type(quadrature_template), dimension(8), target, save, public :: tri_quads + type(quadrature_template), dimension(8), target, save, public :: interval_quads + type(quadrature_template), dimension(6), target, save, public :: hex_quads + type(quadrature_template), dimension(6), target, save, public :: quad_quads + type(quadrature_template), dimension(1), target, save, public :: point_quad + + character(len=100), save, public :: quadrature_error_message="" + + !! Unsupported vertex count. + integer, parameter, public :: QUADRATURE_VERTEX_ERROR=1 + !! Quadrature degree requested is not available. + integer, parameter, public :: QUADRATURE_DEGREE_ERROR=2 + !! Elements with this number of dimensions are not available. + integer, parameter, public :: QUADRATURE_DIMENSION_ERROR=3 + !! Unsupported number of quadrature points. + integer, parameter, public :: QUADRATURE_NGI_ERROR=4 + !! Not enough arguments specified. + integer, parameter, public :: QUADRATURE_ARGUMENT_ERROR=5 + + logical, save, private :: initialised=.false. + + integer, parameter :: FAMILY_COOLS=0, FAMILY_WANDZURA=1, FAMILY_GM=2 + + interface allocate + module procedure allocate_quad + end interface + + interface deallocate + module procedure deallocate_quad + end interface + + interface operator (==) + module procedure quad_equal + end interface #include "Reference_count_interface_quadrature_type.F90" - public make_quadrature, allocate, deallocate, quadrature_type,& - & quadrature_template, construct_quadrature_templates, & - & operator(==), incref, addref, decref, & - & has_references, FAMILY_COOLS, FAMILY_WANDZURA, FAMILY_GM + public make_quadrature, allocate, deallocate, quadrature_type,& + & quadrature_template, construct_quadrature_templates, & + & operator(==), incref, addref, decref, & + & has_references, FAMILY_COOLS, FAMILY_WANDZURA, FAMILY_GM contains - !------------------------------------------------------------------------ - ! Procedures for creating and destroying quadrature data types. - !------------------------------------------------------------------------ - - function make_generator(permutation, weight, coords) result (generator) - !!< Function hiding the fact that generators are dynamically sized. - type(generator_type) :: generator - type(permutation_type), intent(in) :: permutation - real, intent(in) :: weight - real, dimension(:), intent(in) :: coords - - generator%permutation=>permutation%p - generator%weight=weight - allocate(generator%coords(size(coords))) - generator%coords=coords - - end function make_generator - - function make_quadrature(vertices, dim, degree, ngi, family, stat) result (quad) - !!< Given information about a quadrature, return a quad type encoding - !!< that quadrature. - type(quadrature_type) :: quad - !! Using vertices and dimension it is possible to determine what shape we are - !! using. At this stage we assume that no-one will require elements in - !! the shape of the tetragonal antiwedge! - integer, intent(in) :: vertices, dim - !! Ngi is the old way of specifying quadrature. This should really be - !! done via degree. At least one of these must be specified. If both are - !! specified then ngi is used. - integer, intent(in), optional :: degree, ngi - !! Which family of quadrature you'd like to use. - integer, intent(in), optional :: family - !! Status argument - zero for success non-zero otherwise. - integer, intent(out), optional :: stat - - ! The set of quadrature templates for this shape of element. - type(quadrature_template), dimension(:), pointer :: template_set - ! The quadrature template we will use. - type(quadrature_template), pointer :: template - ! Number of local coordinates - integer coords - - integer :: lfamily - integer :: wandzura_rule_idx, wandzura_rule_degree, max_wandzura_rule, wandzura_order - real, dimension(2, 3) :: wandzura_ref_tri - real, dimension(3, 3) :: wandzura_ref_map - real, dimension(:, :), allocatable :: tmp_coordinates - integer :: gi - - integer :: gm_rule, gm_order, vertex - real, dimension(:, :), allocatable :: gm_ref_simplex - real, dimension(:, :), allocatable :: gm_ref_map - - ! Idempotent initialisation - call construct_quadrature_templates - - if (present(stat)) stat=0 - - if (present(family)) then - lfamily = family - else - lfamily = FAMILY_COOLS - end if - - if (lfamily == FAMILY_COOLS) then - ! First isolate the set of templates applicable to this shape. - select case(dim) - case(0) - select case(vertices) - case(1) + !------------------------------------------------------------------------ + ! Procedures for creating and destroying quadrature data types. + !------------------------------------------------------------------------ + + function make_generator(permutation, weight, coords) result (generator) + !!< Function hiding the fact that generators are dynamically sized. + type(generator_type) :: generator + type(permutation_type), intent(in) :: permutation + real, intent(in) :: weight + real, dimension(:), intent(in) :: coords + + generator%permutation=>permutation%p + generator%weight=weight + allocate(generator%coords(size(coords))) + generator%coords=coords + + end function make_generator + + function make_quadrature(vertices, dim, degree, ngi, family, stat) result (quad) + !!< Given information about a quadrature, return a quad type encoding + !!< that quadrature. + type(quadrature_type) :: quad + !! Using vertices and dimension it is possible to determine what shape we are + !! using. At this stage we assume that no-one will require elements in + !! the shape of the tetragonal antiwedge! + integer, intent(in) :: vertices, dim + !! Ngi is the old way of specifying quadrature. This should really be + !! done via degree. At least one of these must be specified. If both are + !! specified then ngi is used. + integer, intent(in), optional :: degree, ngi + !! Which family of quadrature you'd like to use. + integer, intent(in), optional :: family + !! Status argument - zero for success non-zero otherwise. + integer, intent(out), optional :: stat + + ! The set of quadrature templates for this shape of element. + type(quadrature_template), dimension(:), pointer :: template_set + ! The quadrature template we will use. + type(quadrature_template), pointer :: template + ! Number of local coordinates + integer coords + + integer :: lfamily + integer :: wandzura_rule_idx, wandzura_rule_degree, max_wandzura_rule, wandzura_order + real, dimension(2, 3) :: wandzura_ref_tri + real, dimension(3, 3) :: wandzura_ref_map + real, dimension(:, :), allocatable :: tmp_coordinates + integer :: gi + + integer :: gm_rule, gm_order, vertex + real, dimension(:, :), allocatable :: gm_ref_simplex + real, dimension(:, :), allocatable :: gm_ref_map + + ! Idempotent initialisation + call construct_quadrature_templates + + if (present(stat)) stat=0 + + if (present(family)) then + lfamily = family + else + lfamily = FAMILY_COOLS + end if + + if (lfamily == FAMILY_COOLS) then + ! First isolate the set of templates applicable to this shape. + select case(dim) + case(0) + select case(vertices) + case(1) ! All zero dimensional elements are points. template_set=>point_quad coords=1 - case default + case default FLAbort('Invalid quadrature') end select - case(1) - select case(vertices) - case(2) + case(1) + select case(vertices) + case(2) ! All one dimensional elements are intervals. template_set=>interval_quads coords=2 - case default + case default FLAbort('Invalid quadrature') end select - case(2) - select case(vertices) - case(3) ! Triangles + case(2) + select case(vertices) + case(3) ! Triangles + + template_set=>tri_quads + coords=3 + + case(4) ! Quads + + template_set=>quad_quads + coords=2 + + case default + ! Sanity test + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: ",vertices, " is an unsupported vertex count." + + if (present(stat)) then + stat=QUADRATURE_VERTEX_ERROR + return + else + FLAbort(quadrature_error_message) + end if + + end select + + case(3) - template_set=>tri_quads - coords=3 + select case(vertices) + case(4) ! Tets. - case(4) ! Quads + template_set=>tet_quads + coords=4 - template_set=>quad_quads - coords=2 + case(8) ! Hexahedra - case default + template_set=>hex_quads + coords=3 + + case default + ! Sanity test + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: ",vertices, " is an unsupported vertex count." + + if (present(stat)) then + stat=QUADRATURE_VERTEX_ERROR + return + else + FLAbort(quadrature_error_message) + end if + + end select + + case default ! Sanity test write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: ",vertices, " is an unsupported vertex count." + "make_quadrature: ",dim, " is not a supported dimension." if (present(stat)) then - stat=QUADRATURE_VERTEX_ERROR + stat=QUADRATURE_DIMENSION_ERROR return else FLAbort(quadrature_error_message) @@ -257,1394 +298,1353 @@ function make_quadrature(vertices, dim, degree, ngi, family, stat) result (quad) end select - case(3) + ! Now locate the appropriate template for this degree or number of + ! quadrature points.` + if (present(degree)) then + ! Attempt to find a quadrature of at least required degree. + if (all(template_set%degreetet_quads - coords=4 + template=>template_set(minloc(template_set%degree, dim=1,& + mask=template_set%degree>=degree)) - case(8) ! Hexahedra + else if (present(ngi)) then + ! Attempt to find a quadrature with the specified number of points. + if (any(template_set%ngi==ngi)) then - template_set=>hex_quads - coords=3 + template=>template_set(minloc(template_set%ngi, dim=1,& + mask=template_set%ngi==ngi)) - case default - ! Sanity test - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: ",vertices, " is an unsupported vertex count." + else + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: No quadrature with ",ngi," points." + if (present(stat)) then + stat=QUADRATURE_NGI_ERROR + return + else + FLExit(quadrature_error_message) + end if + end if + else + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: You must specify either degree or ngi." if (present(stat)) then - stat=QUADRATURE_VERTEX_ERROR + stat=QUADRATURE_ARGUMENT_ERROR return else FLAbort(quadrature_error_message) end if - end select - - case default - ! Sanity test - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: ",dim, " is not a supported dimension." + end if - if (present(stat)) then - stat=QUADRATURE_DIMENSION_ERROR - return - else - FLAbort(quadrature_error_message) +#if defined (DDEBUG) + if (present(degree).and.(dim/=0)) then + if (template%degree/=degree) then + ewrite(0,*) "Warning:make_quadrature: degree ",degree, " requested& + & but ", template%degree, "available." + end if end if +#endif + + ! Now we can start putting together the quad. + call allocate(quad, vertices, template%ngi, coords) + quad%degree=template%degree + quad%dim=dim - end select + call expand_quadrature_template(quad, template) + else if (lfamily == FAMILY_WANDZURA) then - ! Now locate the appropriate template for this degree or number of - ! quadrature points.` - if (present(degree)) then - ! Attempt to find a quadrature of at least required degree. - if (all(template_set%degreetemplate_set(minloc(template_set%degree, dim=1,& - mask=template_set%degree>=degree)) + call wandzura_rule_num(max_wandzura_rule) + do wandzura_rule_idx=1,max_wandzura_rule + call wandzura_degree(wandzura_rule_idx, wandzura_rule_degree) + if (wandzura_rule_degree >= degree) then + exit + end if + end do - else if (present(ngi)) then - ! Attempt to find a quadrature with the specified number of points. - if (any(template_set%ngi==ngi)) then + if (wandzura_rule_degree < degree) then + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: We can only supply degree ", wandzura_rule_degree, "with Wandzura quadrature. Sorry." + if (present(stat)) then + stat=QUADRATURE_DEGREE_ERROR + return + else + FLExit(quadrature_error_message) + end if + end if - template=>template_set(minloc(template_set%ngi, dim=1,& - mask=template_set%ngi==ngi)) + ! OK. So now we know which Wandzura rule to use. Let's make it happen .. + call wandzura_order_num(wandzura_rule_idx, wandzura_order) + call allocate(quad, vertices, wandzura_order, coords=3) + allocate(tmp_coordinates(2, wandzura_order)) + quad%degree = wandzura_rule_degree + quad%dim = 2 + call wandzura_rule(wandzura_rule_idx, wandzura_order, tmp_coordinates, quad%weight) + wandzura_ref_tri(:, 1) = (/0, 0/) + wandzura_ref_tri(:, 2) = (/1, 0/) + wandzura_ref_tri(:, 3) = (/0, 1/) + call local_coords_matrix_positions(wandzura_ref_tri, wandzura_ref_map) + do gi=1,wandzura_order + quad%l(gi, 1:2) = tmp_coordinates(:, gi); quad%l(gi, 3) = 1.0 + quad%l(gi, :) = matmul(wandzura_ref_map, quad%l(gi, :)) + end do + elseif (lfamily == FAMILY_GM) then + ! Make sure we're on triangles. + if (vertices /= dim+1) then + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: You can only specify Grundmann-Moeller quadrature for simplices." + if (present(stat)) then + stat=QUADRATURE_ARGUMENT_ERROR + return + else + FLExit(quadrature_error_message) + end if + end if - else + ! OK. First let's figure out which rule we want to use. + if (.not. present(degree)) then + write (quadrature_error_message, '(a,i0,a)') & + "make_quadrature: You can only specify degree if you want Grundmann-Moeller quadrature." + if (present(stat)) then + stat=QUADRATURE_ARGUMENT_ERROR + return + else + FLExit(quadrature_error_message) + end if + end if + + if (degree >= 30) then write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: No quadrature with ",ngi," points." + "Grundmann-Moeller quadrature is only accurate up to about degree 30." if (present(stat)) then - stat=QUADRATURE_NGI_ERROR + stat=QUADRATURE_DEGREE_ERROR return else FLExit(quadrature_error_message) end if end if + if (modulo(degree, 2) == 0) then + gm_rule = degree / 2 + else + gm_rule = (degree-1)/2 + end if + + call gm_rule_size(gm_rule, dim, gm_order) + call allocate(quad, vertices, gm_order, coords=vertices) + allocate(tmp_coordinates(dim, gm_order)) + quad%degree = 2*gm_rule + 1 + quad%dim = dim + + call gm_rule_set(gm_rule, dim, gm_order, quad%weight, tmp_coordinates) + + allocate(gm_ref_simplex(dim, vertices)) + gm_ref_simplex(:, 1) = 0.0 + do vertex=1,dim + gm_ref_simplex(:, vertex+1) = 0.0 + gm_ref_simplex(vertex, vertex+1) = 1.0 + end do + allocate(gm_ref_map(vertices, vertices)) + + call local_coords_matrix_positions(gm_ref_simplex, gm_ref_map) + do gi=1,gm_order + quad%l(gi, 1:dim) = tmp_coordinates(:, gi); quad%l(gi, dim+1) = 1.0 + quad%l(gi, :) = matmul(gm_ref_map, quad%l(gi, :)) + end do + quad%weight = quad%weight / factorial(dim) else - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: You must specify either degree or ngi." if (present(stat)) then stat=QUADRATURE_ARGUMENT_ERROR - return else - FLAbort(quadrature_error_message) + FLAbort("Unknown family of quadrature") end if - end if -#if defined (DDEBUG) - if (present(degree).and.(dim/=0)) then - if (template%degree/=degree) then - ewrite(0,*) "Warning:make_quadrature: degree ",degree, " requested& - & but ", template%degree, "available." - end if - end if -#endif + quad%family = lfamily - ! Now we can start putting together the quad. - call allocate(quad, vertices, template%ngi, coords) - quad%degree=template%degree - quad%dim=dim - - call expand_quadrature_template(quad, template) - else if (lfamily == FAMILY_WANDZURA) then - - ! Make sure we're on triangles. - if (dim /= 2 .or. vertices /= 3) then - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: You can only specify Wandzura quadrature for triangles." - if (present(stat)) then - stat=QUADRATURE_ARGUMENT_ERROR - return - else - FLExit(quadrature_error_message) - end if - end if + end function make_quadrature - ! OK. First let's figure out which rule we want to use. - if (.not. present(degree)) then - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: You can only specify degree if you want Wandzura quadrature." - if (present(stat)) then - stat=QUADRATURE_ARGUMENT_ERROR - return - else - FLExit(quadrature_error_message) - end if - end if + subroutine allocate_quad(quad, vertices, ngi, coords, stat) + !!< Allocate memory for a quadrature type. Note that this is done + !!< automatically in make_quadrature. + type(quadrature_type), intent(inout) :: quad + !! Vertices is the number of vertices. Ngi is the number of quadrature + !! points. Coords the number of local coords + integer, intent(in) :: vertices, ngi, coords + !! Stat returns zero for successful completion and nonzero otherwise. + integer, intent(out), optional :: stat - call wandzura_rule_num(max_wandzura_rule) - do wandzura_rule_idx=1,max_wandzura_rule - call wandzura_degree(wandzura_rule_idx, wandzura_rule_degree) - if (wandzura_rule_degree >= degree) then - exit - end if - end do + integer :: lstat - if (wandzura_rule_degree < degree) then - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: We can only supply degree ", wandzura_rule_degree, "with Wandzura quadrature. Sorry." - if (present(stat)) then - stat=QUADRATURE_DEGREE_ERROR - return - else - FLExit(quadrature_error_message) - end if - end if - - ! OK. So now we know which Wandzura rule to use. Let's make it happen .. - call wandzura_order_num(wandzura_rule_idx, wandzura_order) - call allocate(quad, vertices, wandzura_order, coords=3) - allocate(tmp_coordinates(2, wandzura_order)) - quad%degree = wandzura_rule_degree - quad%dim = 2 - call wandzura_rule(wandzura_rule_idx, wandzura_order, tmp_coordinates, quad%weight) - wandzura_ref_tri(:, 1) = (/0, 0/) - wandzura_ref_tri(:, 2) = (/1, 0/) - wandzura_ref_tri(:, 3) = (/0, 1/) - call local_coords_matrix_positions(wandzura_ref_tri, wandzura_ref_map) - do gi=1,wandzura_order - quad%l(gi, 1:2) = tmp_coordinates(:, gi); quad%l(gi, 3) = 1.0 - quad%l(gi, :) = matmul(wandzura_ref_map, quad%l(gi, :)) - end do - elseif (lfamily == FAMILY_GM) then - ! Make sure we're on triangles. - if (vertices /= dim+1) then - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: You can only specify Grundmann-Moeller quadrature for simplices." - if (present(stat)) then - stat=QUADRATURE_ARGUMENT_ERROR - return - else - FLExit(quadrature_error_message) - end if - end if + allocate(quad%weight(ngi), quad%l(ngi,coords), stat=lstat) - ! OK. First let's figure out which rule we want to use. - if (.not. present(degree)) then - write (quadrature_error_message, '(a,i0,a)') & - "make_quadrature: You can only specify degree if you want Grundmann-Moeller quadrature." - if (present(stat)) then - stat=QUADRATURE_ARGUMENT_ERROR - return - else - FLExit(quadrature_error_message) - end if - end if + quad%vertices=vertices + quad%ngi=ngi - if (degree >= 30) then - write (quadrature_error_message, '(a,i0,a)') & - "Grundmann-Moeller quadrature is only accurate up to about degree 30." - if (present(stat)) then - stat=QUADRATURE_DEGREE_ERROR - return - else - FLExit(quadrature_error_message) - end if - end if + nullify(quad%refcount) ! Hack for gfortran component initialisation + ! bug. - if (modulo(degree, 2) == 0) then - gm_rule = degree / 2 - else - gm_rule = (degree-1)/2 - end if + call addref(quad) - call gm_rule_size(gm_rule, dim, gm_order) - call allocate(quad, vertices, gm_order, coords=vertices) - allocate(tmp_coordinates(dim, gm_order)) - quad%degree = 2*gm_rule + 1 - quad%dim = dim - - call gm_rule_set(gm_rule, dim, gm_order, quad%weight, tmp_coordinates) - - allocate(gm_ref_simplex(dim, vertices)) - gm_ref_simplex(:, 1) = 0.0 - do vertex=1,dim - gm_ref_simplex(:, vertex+1) = 0.0 - gm_ref_simplex(vertex, vertex+1) = 1.0 - end do - allocate(gm_ref_map(vertices, vertices)) - - call local_coords_matrix_positions(gm_ref_simplex, gm_ref_map) - do gi=1,gm_order - quad%l(gi, 1:dim) = tmp_coordinates(:, gi); quad%l(gi, dim+1) = 1.0 - quad%l(gi, :) = matmul(gm_ref_map, quad%l(gi, :)) - end do - quad%weight = quad%weight / factorial(dim) - else if (present(stat)) then - stat=QUADRATURE_ARGUMENT_ERROR - else - FLAbort("Unknown family of quadrature") + stat=lstat + else if (lstat/=0) then + FLAbort("Error allocating quad") end if - end if - - quad%family = lfamily - end function make_quadrature + end subroutine allocate_quad - subroutine allocate_quad(quad, vertices, ngi, coords, stat) - !!< Allocate memory for a quadrature type. Note that this is done - !!< automatically in make_quadrature. - type(quadrature_type), intent(inout) :: quad - !! Vertices is the number of vertices. Ngi is the number of quadrature - !! points. Coords the number of local coords - integer, intent(in) :: vertices, ngi, coords - !! Stat returns zero for successful completion and nonzero otherwise. - integer, intent(out), optional :: stat + subroutine deallocate_quad(quad,stat) + !!< Since quadrature types contain pointers it is necessary to + !!< explicitly deallocate them. + !! The quadrature type to be deallocated. + type(quadrature_type), intent(inout) :: quad + !! Stat returns zero for successful completion and nonzero otherwise. + integer, intent(out), optional :: stat - integer :: lstat + integer :: lstat - allocate(quad%weight(ngi), quad%l(ngi,coords), stat=lstat) - - quad%vertices=vertices - quad%ngi=ngi - - nullify(quad%refcount) ! Hack for gfortran component initialisation - ! bug. - - call addref(quad) - - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Error allocating quad") - end if - - end subroutine allocate_quad - - subroutine deallocate_quad(quad,stat) - !!< Since quadrature types contain pointers it is necessary to - !!< explicitly deallocate them. - !! The quadrature type to be deallocated. - type(quadrature_type), intent(inout) :: quad - !! Stat returns zero for successful completion and nonzero otherwise. - integer, intent(out), optional :: stat - - integer :: lstat - - call decref(quad) - if (has_references(quad)) then - ! There are still references to this quad so we don't deallocate. - return - end if + call decref(quad) + if (has_references(quad)) then + ! There are still references to this quad so we don't deallocate. + return + end if - deallocate(quad%weight,quad%l, stat=lstat) + deallocate(quad%weight,quad%l, stat=lstat) - if (present(stat)) then - stat=lstat - else if (lstat/=0) then - FLAbort("Error deallocating quad") - end if + if (present(stat)) then + stat=lstat + else if (lstat/=0) then + FLAbort("Error deallocating quad") + end if - end subroutine deallocate_quad + end subroutine deallocate_quad #include "Reference_count_quadrature_type.F90" - pure function quad_equal(quad1,quad2) - !!< Return true if the two quadratures are equivalent. - logical :: quad_equal - type(quadrature_type), intent(in) :: quad1, quad2 + pure function quad_equal(quad1,quad2) + !!< Return true if the two quadratures are equivalent. + logical :: quad_equal + type(quadrature_type), intent(in) :: quad1, quad2 - quad_equal = quad1%dim==quad2%dim & + quad_equal = quad1%dim==quad2%dim & .and. quad1%degree==quad2%degree & .and. quad1%vertices==quad2%vertices & .and. quad1%ngi==quad2%ngi - end function quad_equal + end function quad_equal - subroutine expand_quadrature_template(quad, template) - ! Expand the given template into the quad provided. - type(quadrature_type), intent(inout) :: quad - type(quadrature_template), intent(in) :: template + subroutine expand_quadrature_template(quad, template) + ! Expand the given template into the quad provided. + type(quadrature_type), intent(inout) :: quad + type(quadrature_template), intent(in) :: template - integer :: i, j, k, dk - type(generator_type), pointer :: lgen + integer :: i, j, k, dk + type(generator_type), pointer :: lgen - quad%l=0.0 - dk=0 + quad%l=0.0 + dk=0 - do i=1,size(template%generator) - lgen=>template%generator(i) + do i=1,size(template%generator) + lgen=>template%generator(i) - ! Permute coordinates and insert into quad%l - ! Note that for external compatibility, quad%l is transposed. - forall(j=1:size(lgen%permutation,1), & + ! Permute coordinates and insert into quad%l + ! Note that for external compatibility, quad%l is transposed. + forall(j=1:size(lgen%permutation,1), & k=1:size(lgen%permutation,2), & lgen%permutation(j,k)/=0) - ! The permutation stores both the permutation order and (for - ! quads and hexs) the sign of the coordinate. - quad%l(k+dk,j)=sign(lgen%coords(abs(lgen%permutation(j,k))),& - & real(lgen%permutation(j,k))) - end forall + ! The permutation stores both the permutation order and (for + ! quads and hexs) the sign of the coordinate. + quad%l(k+dk,j)=sign(lgen%coords(abs(lgen%permutation(j,k))),& + & real(lgen%permutation(j,k))) + end forall - ! Insert weights: - quad%weight(dk+1:dk+size(lgen%permutation,2))=lgen%weight + ! Insert weights: + quad%weight(dk+1:dk+size(lgen%permutation,2))=lgen%weight - ! Move down k: - dk=dk+size(lgen%permutation,2) + ! Move down k: + dk=dk+size(lgen%permutation,2) - end do + end do - end subroutine expand_quadrature_template + end subroutine expand_quadrature_template - !------------------------------------------------------------------------ - ! Procedures for generating permutations and quadratures. - !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + ! Procedures for generating permutations and quadratures. + !------------------------------------------------------------------------ - subroutine construct_quadrature_templates - !!< Construct the generators of symmetric rules on the tet. - !!< The order of generators follows that on the - !!< Encyclopaedia of Cubature Formulas at: - !!< http://www.cs.kuleuven.ac.be/~nines/research/ecf/ecf.html + subroutine construct_quadrature_templates + !!< Construct the generators of symmetric rules on the tet. + !!< The order of generators follows that on the + !!< Encyclopaedia of Cubature Formulas at: + !!< http://www.cs.kuleuven.ac.be/~nines/research/ecf/ecf.html - !Idempotency test. - if (initialised) return - initialised=.true. + !Idempotency test. + if (initialised) return + initialised=.true. - call construct_point_permutation + call construct_point_permutation - call construct_point_quadrature + call construct_point_quadrature - call construct_interval_permutations + call construct_interval_permutations - call construct_interval_quadratures + call construct_interval_quadratures - call construct_tri_permutations + call construct_tri_permutations - call construct_tri_cycles + call construct_tri_cycles - call construct_tri_quadratures + call construct_tri_quadratures - call construct_tet_permutations + call construct_tet_permutations - call construct_tet_quadratures + call construct_tet_quadratures - call construct_hex_permutations + call construct_hex_permutations - call construct_hex_quadratures + call construct_hex_quadratures - call construct_quad_permutations + call construct_quad_permutations - call construct_quad_quadratures + call construct_quad_quadratures - end subroutine construct_quadrature_templates + end subroutine construct_quadrature_templates - subroutine construct_tet_quadratures - ! Construct list of available quadratures. - ! The references cited are listed on the Encyclopedia of Cubature - ! Formulas. - integer :: i - real, dimension(4) :: coords + subroutine construct_tet_quadratures + ! Construct list of available quadratures. + ! The references cited are listed on the Encyclopedia of Cubature + ! Formulas. + integer :: i + real, dimension(4) :: coords - tet_quads%dim=3 - tet_quads%vertices=4 + tet_quads%dim=3 + tet_quads%vertices=4 - i=0 + i=0 - !---------------------------------------------------------------------- - ! 1 point degree 1 quadrature. - ! Citation: Str71 - i=i+1 - ! Only one generator. - allocate(tet_quads(i)%generator(1)) - tet_quads(i)%ngi=1 - tet_quads(i)%degree=1 + !---------------------------------------------------------------------- + ! 1 point degree 1 quadrature. + ! Citation: Str71 + i=i+1 + ! Only one generator. + allocate(tet_quads(i)%generator(1)) + tet_quads(i)%ngi=1 + tet_quads(i)%degree=1 - tet_quads(i)%generator(1)=make_generator( & + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(7), & weight=0.166666666666666666666666666666666, & coords=(/0.25/)) - !---------------------------------------------------------------------- - ! 4 point degree 2 quadrature. - ! Citation: str71 - i=i+1 - allocate(tet_quads(i)%generator(1)) - tet_quads(i)%ngi=4 - tet_quads(i)%degree=2 - - coords(1)=0.138196601125010515179541316563436 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(1)=make_generator( & + !---------------------------------------------------------------------- + ! 4 point degree 2 quadrature. + ! Citation: str71 + i=i+1 + allocate(tet_quads(i)%generator(1)) + tet_quads(i)%ngi=4 + tet_quads(i)%degree=2 + + coords(1)=0.138196601125010515179541316563436 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(8), & weight=0.041666666666666666666666666666666, & coords=coords(1:2)) - !---------------------------------------------------------------------- - ! 5 point degree 3 quadrature. - ! Citation: str71 - i=i+1 - allocate(tet_quads(i)%generator(2)) - tet_quads(i)%ngi=5 - tet_quads(i)%degree=3 + !---------------------------------------------------------------------- + ! 5 point degree 3 quadrature. + ! Citation: str71 + i=i+1 + allocate(tet_quads(i)%generator(2)) + tet_quads(i)%ngi=5 + tet_quads(i)%degree=3 - tet_quads(i)%generator(1)=make_generator( & + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(7), & weight=-0.133333333333333333333333333333333, & coords=(/0.25/)) - coords(1)=0.166666666666666666666666666666666 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(2)=make_generator( & + coords(1)=0.166666666666666666666666666666666 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(2)=make_generator( & permutation=tet_permutations(8), & weight=0.075, & coords=coords(1:2)) - !---------------------------------------------------------------------- - ! 11 point degree 4 quadrature. - ! Citation: kea86 - i=i+1 - allocate(tet_quads(i)%generator(3)) - tet_quads(i)%ngi=11 - tet_quads(i)%degree=4 + !---------------------------------------------------------------------- + ! 11 point degree 4 quadrature. + ! Citation: kea86 + i=i+1 + allocate(tet_quads(i)%generator(3)) + tet_quads(i)%ngi=11 + tet_quads(i)%degree=4 - tet_quads(i)%generator(1)=make_generator( & + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(7), & weight=-0.013155555555555555555555555555555, & coords=(/0.25/)) - coords(1)=0.0714285714285714285714285714285714 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(2)=make_generator( & + coords(1)=0.0714285714285714285714285714285714 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(2)=make_generator( & permutation=tet_permutations(8), & weight=7.62222222222222222222222222222222E-3, & coords=coords(1:2)) - coords(1)=0.399403576166799204996102147461640 - coords(2)=0.5-coords(1) - tet_quads(i)%generator(3)=make_generator( & + coords(1)=0.399403576166799204996102147461640 + coords(2)=0.5-coords(1) + tet_quads(i)%generator(3)=make_generator( & permutation=tet_permutations(9), & weight=0.0248888888888888888888888888888888, & coords=coords(1:2)) - !---------------------------------------------------------------------- - ! 14 point degree 5 quadrature. - ! Citation gm78 - i=i+1 - allocate(tet_quads(i)%generator(3)) - tet_quads(i)%ngi=14 - tet_quads(i)%degree=5 - - coords(1)=0.0927352503108912264023239137370306 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(1)=make_generator( & + !---------------------------------------------------------------------- + ! 14 point degree 5 quadrature. + ! Citation gm78 + i=i+1 + allocate(tet_quads(i)%generator(3)) + tet_quads(i)%ngi=14 + tet_quads(i)%degree=5 + + coords(1)=0.0927352503108912264023239137370306 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(8), & weight=0.0122488405193936582572850342477212, & coords=coords(1:2)) - coords(1)=0.310885919263300609797345733763457 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(2)=make_generator( & + coords(1)=0.310885919263300609797345733763457 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(2)=make_generator( & permutation=tet_permutations(8), & weight=0.0187813209530026417998642753888810, & coords=coords(1:2)) - coords(1)=0.454496295874350350508119473720660 - coords(2)=0.5-coords(1) - tet_quads(i)%generator(3)=make_generator( & + coords(1)=0.454496295874350350508119473720660 + coords(2)=0.5-coords(1) + tet_quads(i)%generator(3)=make_generator( & permutation=tet_permutations(9), & weight=7.09100346284691107301157135337624E-3, & coords=coords(1:2)) - !---------------------------------------------------------------------- - ! 24 point degree 6 quadrature. - ! Citation kea86 - i=i+1 - allocate(tet_quads(i)%generator(4)) - tet_quads(i)%ngi=24 - tet_quads(i)%degree=6 - - coords(1)=0.214602871259152029288839219386284 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(1)=make_generator( & + !---------------------------------------------------------------------- + ! 24 point degree 6 quadrature. + ! Citation kea86 + i=i+1 + allocate(tet_quads(i)%generator(4)) + tet_quads(i)%ngi=24 + tet_quads(i)%degree=6 + + coords(1)=0.214602871259152029288839219386284 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(8), & weight=6.65379170969458201661510459291332E-3, & coords=coords(1:2)) - coords(1)=0.0406739585346113531155794489564100 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(2)=make_generator( & + coords(1)=0.0406739585346113531155794489564100 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(2)=make_generator( & permutation=tet_permutations(8), & weight=1.67953517588677382466887290765614E-3, & coords=coords(1:2)) - coords(1)=0.322337890142275510343994470762492 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(3)=make_generator( & + coords(1)=0.322337890142275510343994470762492 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(3)=make_generator( & permutation=tet_permutations(8), & weight=9.22619692394245368252554630895433E-3, & coords=coords(1:2)) - coords(1)=0.0636610018750175252992355276057269 - coords(2)=0.269672331458315808034097805727606 - coords(3)=1.0-2.0*coords(1)-coords(2) - tet_quads(i)%generator(4)=make_generator( & + coords(1)=0.0636610018750175252992355276057269 + coords(2)=0.269672331458315808034097805727606 + coords(3)=1.0-2.0*coords(1)-coords(2) + tet_quads(i)%generator(4)=make_generator( & permutation=tet_permutations(10), & weight=8.03571428571428571428571428571428E-3, & coords=coords(1:3)) - !---------------------------------------------------------------------- - ! 31 point degree 7 quadrature. - ! Citation kea86 - i=i+1 - allocate(tet_quads(i)%generator(6)) - tet_quads(i)%ngi=31 - tet_quads(i)%degree=7 + !---------------------------------------------------------------------- + ! 31 point degree 7 quadrature. + ! Citation kea86 + i=i+1 + allocate(tet_quads(i)%generator(6)) + tet_quads(i)%ngi=31 + tet_quads(i)%degree=7 - tet_quads(i)%generator(1)=make_generator( & + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(2), & weight=9.70017636684303350970017636684303E-4, & coords=(/0.5/)) - tet_quads(i)%generator(2)=make_generator( & + tet_quads(i)%generator(2)=make_generator( & permutation=tet_permutations(7), & weight=0.0182642234661088202912015685649462, & coords=(/0.25/)) - coords(1)=0.0782131923303180643739942508375545 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(3)=make_generator( & + coords(1)=0.0782131923303180643739942508375545 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(3)=make_generator( & permutation=tet_permutations(8), & weight=0.0105999415244136869164138748545257, & coords=coords(1:2)) - coords(1)=0.121843216663905174652156372684818 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(4)=make_generator( & + coords(1)=0.121843216663905174652156372684818 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(4)=make_generator( & permutation=tet_permutations(8), & weight=-0.0625177401143318516914703474927900, & coords=coords(1:2)) - coords(1)=0.332539164446420624152923823157707 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(5)=make_generator( & + coords(1)=0.332539164446420624152923823157707 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(5)=make_generator( & permutation=tet_permutations(8), & weight=4.89142526307349938479576303671027E-3, & coords=coords(1:2)) - coords(1)=0.1 - coords(2)=0.2 - coords(3)=1.0-2.0*coords(1)-coords(2) - tet_quads(i)%generator(6)=make_generator( & + coords(1)=0.1 + coords(2)=0.2 + coords(3)=1.0-2.0*coords(1)-coords(2) + tet_quads(i)%generator(6)=make_generator( & permutation=tet_permutations(10), & weight=0.0275573192239858906525573192239858, & coords=coords(1:3)) - !---------------------------------------------------------------------- - ! 43 point degree 8 quadrature. - ! Citation bh90 bec92 - i=i+1 - allocate(tet_quads(i)%generator(7)) - tet_quads(i)%ngi=43 - tet_quads(i)%degree=8 + !---------------------------------------------------------------------- + ! 43 point degree 8 quadrature. + ! Citation bh90 bec92 + i=i+1 + allocate(tet_quads(i)%generator(7)) + tet_quads(i)%ngi=43 + tet_quads(i)%degree=8 - tet_quads(i)%generator(1)=make_generator( & + tet_quads(i)%generator(1)=make_generator( & permutation=tet_permutations(7), & weight=-0.0205001886586399158405865177642941, & coords=(/0.25/)) - coords(1)=0.206829931610673204083980900024961 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(2)=make_generator( & + coords(1)=0.206829931610673204083980900024961 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(2)=make_generator( & permutation=tet_permutations(8), & weight=0.0142503058228669012484397415358704, & coords=coords(1:2)) - coords(1)=0.0821035883105467230906058078714215 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(3)=make_generator( & + coords(1)=0.0821035883105467230906058078714215 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(3)=make_generator( & permutation=tet_permutations(8), & weight=1.96703331313390098756280342445466E-3, & coords=coords(1:2)) - coords(1)=5.78195050519799725317663886414270E-3 - coords(2)=1.0-3.0*coords(1) - tet_quads(i)%generator(4)=make_generator( & + coords(1)=5.78195050519799725317663886414270E-3 + coords(2)=1.0-3.0*coords(1) + tet_quads(i)%generator(4)=make_generator( & permutation=tet_permutations(8), & weight=1.69834109092887379837744566704016E-4, & coords=coords(1:2)) - coords(1)=0.0505327400188942244256245285579071 - coords(2)=0.5-coords(1) - tet_quads(i)%generator(5)=make_generator( & + coords(1)=0.0505327400188942244256245285579071 + coords(2)=0.5-coords(1) + tet_quads(i)%generator(5)=make_generator( & permutation=tet_permutations(9), & weight=4.57968382446728180074351446297276E-3, & coords=coords(1:2)) - coords(1)=0.229066536116811139600408854554753 - coords(2)=0.0356395827885340437169173969506114 - coords(3)=1.0-2.0*coords(1)-coords(2) - tet_quads(i)%generator(6)=make_generator( & + coords(1)=0.229066536116811139600408854554753 + coords(2)=0.0356395827885340437169173969506114 + coords(3)=1.0-2.0*coords(1)-coords(2) + tet_quads(i)%generator(6)=make_generator( & permutation=tet_permutations(10), & weight=5.70448580868191850680255862783040E-3, & coords=coords(1:3)) - coords(1)=0.0366077495531974236787738546327104 - coords(2)=0.190486041934633455699433285315099 - coords(3)=1.0-2.0*coords(1)-coords(2) - tet_quads(i)%generator(7)=make_generator( & + coords(1)=0.0366077495531974236787738546327104 + coords(2)=0.190486041934633455699433285315099 + coords(3)=1.0-2.0*coords(1)-coords(2) + tet_quads(i)%generator(7)=make_generator( & permutation=tet_permutations(10), & weight=2.14051914116209259648335300092023E-3, & coords=coords(1:3)) - end subroutine construct_tet_quadratures + end subroutine construct_tet_quadratures - subroutine construct_tri_quadratures - ! Construct list of available quadratures. - ! The references cited are listed on the Encyclopedia of Cubature - ! Formulas. - integer :: i - real, dimension(3) :: coords + subroutine construct_tri_quadratures + ! Construct list of available quadratures. + ! The references cited are listed on the Encyclopedia of Cubature + ! Formulas. + integer :: i + real, dimension(3) :: coords - tri_quads%dim=2 - tri_quads%vertices=3 + tri_quads%dim=2 + tri_quads%vertices=3 - i=0 + i=0 - !---------------------------------------------------------------------- - ! 1 point degree 1 quadrature. - ! Citation: Str71 - i=i+1 - ! Only one generator. - allocate(tri_quads(i)%generator(1)) - tri_quads(i)%ngi=1 - tri_quads(i)%degree=1 + !---------------------------------------------------------------------- + ! 1 point degree 1 quadrature. + ! Citation: Str71 + i=i+1 + ! Only one generator. + allocate(tri_quads(i)%generator(1)) + tri_quads(i)%ngi=1 + tri_quads(i)%degree=1 - tri_quads(i)%generator(1)=make_generator( & + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(4), & weight=0.5, & coords=(/0.333333333333333333333333333333333/)) - !---------------------------------------------------------------------- - ! 3 point degree 2 quadrature. - ! Citation: Str71 - i=i+1 - ! Only one generator. - allocate(tri_quads(i)%generator(1)) - tri_quads(i)%ngi=3 - tri_quads(i)%degree=2 - - coords(1)=0.166666666666666666666666666666666 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(1)=make_generator( & + !---------------------------------------------------------------------- + ! 3 point degree 2 quadrature. + ! Citation: Str71 + i=i+1 + ! Only one generator. + allocate(tri_quads(i)%generator(1)) + tri_quads(i)%ngi=3 + tri_quads(i)%degree=2 + + coords(1)=0.166666666666666666666666666666666 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(5), & weight=0.166666666666666666666666666666666, & coords=coords) - !---------------------------------------------------------------------- - ! 4 point degree 3 quadrature. - ! Citation: Str71 - i=i+1 + !---------------------------------------------------------------------- + ! 4 point degree 3 quadrature. + ! Citation: Str71 + i=i+1 - allocate(tri_quads(i)%generator(2)) - tri_quads(i)%ngi=4 - tri_quads(i)%degree=3 + allocate(tri_quads(i)%generator(2)) + tri_quads(i)%ngi=4 + tri_quads(i)%degree=3 - tri_quads(i)%generator(1)=make_generator( & + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(4), & weight=-0.28125, & coords=(/0.333333333333333333333333333333333/)) - coords(1)=0.2 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(2)=make_generator( & + coords(1)=0.2 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(2)=make_generator( & permutation=tri_permutations(5), & weight=0.260416666666666666666666666666666, & coords=coords) - !---------------------------------------------------------------------- - ! 6 point degree 4 quadrature. - ! Citation: cow73 dun85 blg78 lj75 moa74 sf73 - i=i+1 + !---------------------------------------------------------------------- + ! 6 point degree 4 quadrature. + ! Citation: cow73 dun85 blg78 lj75 moa74 sf73 + i=i+1 - allocate(tri_quads(i)%generator(2)) - tri_quads(i)%ngi=6 - tri_quads(i)%degree=4 + allocate(tri_quads(i)%generator(2)) + tri_quads(i)%ngi=6 + tri_quads(i)%degree=4 - coords(1)=0.0915762135097707434595714634022015 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(1)=make_generator( & + coords(1)=0.0915762135097707434595714634022015 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(5), & weight=0.0549758718276609338191631624501052, & coords=coords) - coords(1)=0.445948490915964886318329253883051 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(2)=make_generator( & + coords(1)=0.445948490915964886318329253883051 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(2)=make_generator( & permutation=tri_permutations(5), & weight=0.111690794839005732847503504216561, & coords=coords) - !---------------------------------------------------------------------- - ! 7 point degree 5 quadrature. - ! Citation: str71 - i=i+1 + !---------------------------------------------------------------------- + ! 7 point degree 5 quadrature. + ! Citation: str71 + i=i+1 - allocate(tri_quads(i)%generator(3)) - tri_quads(i)%ngi=7 - tri_quads(i)%degree=5 + allocate(tri_quads(i)%generator(3)) + tri_quads(i)%ngi=7 + tri_quads(i)%degree=5 - tri_quads(i)%generator(1)=make_generator( & + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(4), & weight=0.1125, & coords=(/0.333333333333333333333333333333333/)) - coords(1)=0.101286507323456338800987361915123 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(2)=make_generator( & + coords(1)=0.101286507323456338800987361915123 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(2)=make_generator( & permutation=tri_permutations(5), & weight=0.0629695902724135762978419727500906, & coords=coords) - coords(1)=0.470142064105115089770441209513447 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(3)=make_generator( & + coords(1)=0.470142064105115089770441209513447 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(3)=make_generator( & permutation=tri_permutations(5), & weight=0.0661970763942530903688246939165759, & coords=coords) - !---------------------------------------------------------------------- - ! 12 point degree 6 quadrature. - ! Citation: cow73 dun85 blg78 lj75 moa74 sf73 - i=i+1 + !---------------------------------------------------------------------- + ! 12 point degree 6 quadrature. + ! Citation: cow73 dun85 blg78 lj75 moa74 sf73 + i=i+1 - allocate(tri_quads(i)%generator(3)) - tri_quads(i)%ngi=12 - tri_quads(i)%degree=6 + allocate(tri_quads(i)%generator(3)) + tri_quads(i)%ngi=12 + tri_quads(i)%degree=6 - coords(1)=0.0630890144915022283403316028708191 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(1)=make_generator( & + coords(1)=0.0630890144915022283403316028708191 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(5), & weight=0.0254224531851034084604684045534344, & coords=coords) - coords(1)=0.249286745170910421291638553107019 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(2)=make_generator( & + coords(1)=0.249286745170910421291638553107019 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(2)=make_generator( & permutation=tri_permutations(5), & weight=0.0583931378631896830126448056927897, & coords=coords) - coords(1)=0.0531450498448169473532496716313981 - coords(2)=0.310352451033784405416607733956552 - coords(3)=1.0-coords(1)-coords(2) - tri_quads(i)%generator(3)=make_generator( & + coords(1)=0.0531450498448169473532496716313981 + coords(2)=0.310352451033784405416607733956552 + coords(3)=1.0-coords(1)-coords(2) + tri_quads(i)%generator(3)=make_generator( & permutation=tri_permutations(6), & weight=0.0414255378091867875967767282102212, & coords=coords) - !---------------------------------------------------------------------- - ! 12 point degree 7 quadrature. - ! Citation: gat88 - i=i+1 + !---------------------------------------------------------------------- + ! 12 point degree 7 quadrature. + ! Citation: gat88 + i=i+1 - allocate(tri_quads(i)%generator(4)) - tri_quads(i)%ngi=12 - tri_quads(i)%degree=7 + allocate(tri_quads(i)%generator(4)) + tri_quads(i)%ngi=12 + tri_quads(i)%degree=7 - coords(1)=0.0623822650944021181736830009963499 - coords(2)=0.0675178670739160854425571310508685 - coords(3)=1.0-coords(1)-coords(2) - tri_quads(i)%generator(1)=make_generator( & + coords(1)=0.0623822650944021181736830009963499 + coords(2)=0.0675178670739160854425571310508685 + coords(3)=1.0-coords(1)-coords(2) + tri_quads(i)%generator(1)=make_generator( & permutation=tri_cycles(6), & weight=0.0265170281574362514287541804607391, & coords=coords) - coords(1)=0.0552254566569266117374791902756449 - coords(2)=0.321502493851981822666307849199202 - coords(3)=1.0-coords(1)-coords(2) - tri_quads(i)%generator(2)=make_generator( & + coords(1)=0.0552254566569266117374791902756449 + coords(2)=0.321502493851981822666307849199202 + coords(3)=1.0-coords(1)-coords(2) + tri_quads(i)%generator(2)=make_generator( & permutation=tri_cycles(6), & weight=0.0438814087144460550367699031392875, & coords=coords) - coords(1)=0.0343243029450971464696306424839376 - coords(2)=0.660949196186735657611980310197799 - coords(3)=1.0-coords(1)-coords(2) - tri_quads(i)%generator(3)=make_generator( & + coords(1)=0.0343243029450971464696306424839376 + coords(2)=0.660949196186735657611980310197799 + coords(3)=1.0-coords(1)-coords(2) + tri_quads(i)%generator(3)=make_generator( & permutation=tri_cycles(6), & weight=0.0287750427849815857384454969002185, & coords=coords) - coords(1)=0.515842334353591779257463386826430 - coords(2)=0.277716166976391782569581871393723 - coords(3)=1.0-coords(1)-coords(2) - tri_quads(i)%generator(4)=make_generator( & + coords(1)=0.515842334353591779257463386826430 + coords(2)=0.277716166976391782569581871393723 + coords(3)=1.0-coords(1)-coords(2) + tri_quads(i)%generator(4)=make_generator( & permutation=tri_cycles(6), & weight=0.0674931870098027744626970861664214, & coords=coords) - !---------------------------------------------------------------------- - ! 16 point degree 8 quadrature. - ! Citation: lj75, dun85b, lg78 - i=i+1 + !---------------------------------------------------------------------- + ! 16 point degree 8 quadrature. + ! Citation: lj75, dun85b, lg78 + i=i+1 - allocate(tri_quads(i)%generator(5)) - tri_quads(i)%ngi=16 - tri_quads(i)%degree=8 + allocate(tri_quads(i)%generator(5)) + tri_quads(i)%ngi=16 + tri_quads(i)%degree=8 - tri_quads(i)%generator(1)=make_generator( & + tri_quads(i)%generator(1)=make_generator( & permutation=tri_permutations(4), & weight=0.0721578038388935841255455552445323, & coords=(/1.0/3.0/)) - coords(1)=0.170569307751760206622293501491464 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(2)=make_generator( & + coords(1)=0.170569307751760206622293501491464 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(2)=make_generator( & permutation=tri_permutations(5), & weight=0.0516086852673591251408957751460645, & coords=coords(1:2)) - coords(1)=0.0505472283170309754584235505965989 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(3)=make_generator( & + coords(1)=0.0505472283170309754584235505965989 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(3)=make_generator( & permutation=tri_permutations(5), & weight=0.0162292488115990401554629641708902, & coords=coords(1:2)) - coords(1)=0.459292588292723156028815514494169 - coords(2)=1.0-2.0*coords(1) - tri_quads(i)%generator(4)=make_generator( & + coords(1)=0.459292588292723156028815514494169 + coords(2)=1.0-2.0*coords(1) + tri_quads(i)%generator(4)=make_generator( & permutation=tri_permutations(5), & weight=0.0475458171336423123969480521942921, & coords=coords(1:2)) - coords(1)=0.728492392955404281241000379176061 - coords(2)=0.263112829634638113421785786284643 - coords(3)=1.0-coords(1)-coords(2) - tri_quads(i)%generator(5)=make_generator( & + coords(1)=0.728492392955404281241000379176061 + coords(2)=0.263112829634638113421785786284643 + coords(3)=1.0-coords(1)-coords(2) + tri_quads(i)%generator(5)=make_generator( & permutation=tri_permutations(6), & weight=0.0136151570872174971324223450369544, & coords=coords) - end subroutine construct_tri_quadratures + end subroutine construct_tri_quadratures - subroutine construct_interval_quadratures - ! Construct list of available quadratures. - ! Interval quadratures are based on a matlab script by Greg von Winkel - integer :: i - real, dimension(2) :: coords + subroutine construct_interval_quadratures + ! Construct list of available quadratures. + ! Interval quadratures are based on a matlab script by Greg von Winkel + integer :: i + real, dimension(2) :: coords - interval_quads%dim=1 - interval_quads%vertices=2 + interval_quads%dim=1 + interval_quads%vertices=2 - i=0 + i=0 - !---------------------------------------------------------------------- - ! 1 point degree 1 quadrature. - i=i+1 - ! Only one generator. - allocate(interval_quads(i)%generator(1)) - interval_quads(i)%ngi=1 - interval_quads(i)%degree=1 + !---------------------------------------------------------------------- + ! 1 point degree 1 quadrature. + i=i+1 + ! Only one generator. + allocate(interval_quads(i)%generator(1)) + interval_quads(i)%ngi=1 + interval_quads(i)%degree=1 - coords(1)=0.5 - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.5 + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(1), & weight=1.0, & coords=coords) - !---------------------------------------------------------------------- - ! 2 point degree 2 quadrature. - i=i+1 - ! Only one generator. - allocate(interval_quads(i)%generator(1)) - interval_quads(i)%ngi=2 - interval_quads(i)%degree=2 + !---------------------------------------------------------------------- + ! 2 point degree 2 quadrature. + i=i+1 + ! Only one generator. + allocate(interval_quads(i)%generator(1)) + interval_quads(i)%ngi=2 + interval_quads(i)%degree=2 - coords(1)=0.788675134594813 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.788675134594813 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.5, & coords=coords) - !---------------------------------------------------------------------- - ! 3 point degree 3 quadrature. - i=i+1 + !---------------------------------------------------------------------- + ! 3 point degree 3 quadrature. + i=i+1 - allocate(interval_quads(i)%generator(2)) - interval_quads(i)%ngi=3 - interval_quads(i)%degree=3 + allocate(interval_quads(i)%generator(2)) + interval_quads(i)%ngi=3 + interval_quads(i)%degree=3 - coords(1)=0.887298334620742 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.887298334620742 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.277777777777777, & coords=coords) - coords(1)=0.5 - interval_quads(i)%generator(2)=make_generator( & + coords(1)=0.5 + interval_quads(i)%generator(2)=make_generator( & permutation=interval_permutations(1), & weight=0.444444444444444, & coords=coords) - !---------------------------------------------------------------------- - ! 4 point degree 4 quadrature. - i=i+1 + !---------------------------------------------------------------------- + ! 4 point degree 4 quadrature. + i=i+1 - allocate(interval_quads(i)%generator(2)) - interval_quads(i)%ngi=4 - interval_quads(i)%degree=4 + allocate(interval_quads(i)%generator(2)) + interval_quads(i)%ngi=4 + interval_quads(i)%degree=4 - coords(1)=0.9305681557970262 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.9305681557970262 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.173927422568727, & coords=coords) - coords(1)=0.6699905217924281 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(2)=make_generator( & + coords(1)=0.6699905217924281 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(2)=make_generator( & permutation=interval_permutations(2), & weight=0.326072577431273, & coords=coords) - !---------------------------------------------------------------------- - ! 5 point degree 5 quadrature. - i=i+1 + !---------------------------------------------------------------------- + ! 5 point degree 5 quadrature. + i=i+1 - allocate(interval_quads(i)%generator(3)) - interval_quads(i)%ngi=5 - interval_quads(i)%degree=5 + allocate(interval_quads(i)%generator(3)) + interval_quads(i)%ngi=5 + interval_quads(i)%degree=5 - coords(1)=0.9530899229693319 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.9530899229693319 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.118463442528095, & coords=coords) - coords(1)=0.7692346550528415 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(2)=make_generator( & + coords(1)=0.7692346550528415 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(2)=make_generator( & permutation=interval_permutations(2), & weight=0.239314335249683, & coords=coords) - coords(1)=0.5 - interval_quads(i)%generator(3)=make_generator( & + coords(1)=0.5 + interval_quads(i)%generator(3)=make_generator( & permutation=interval_permutations(1), & weight=0.284444444444444, & coords=coords) - !---------------------------------------------------------------------- - ! 6 point degree 6 quadrature. - i=i+1 + !---------------------------------------------------------------------- + ! 6 point degree 6 quadrature. + i=i+1 - allocate(interval_quads(i)%generator(3)) - interval_quads(i)%ngi=6 - interval_quads(i)%degree=6 + allocate(interval_quads(i)%generator(3)) + interval_quads(i)%ngi=6 + interval_quads(i)%degree=6 - coords(1)=0.9662347571015760 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.9662347571015760 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.0856622461895852, & coords=coords) - coords(1)=0.8306046932331322 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(2)=make_generator( & + coords(1)=0.8306046932331322 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(2)=make_generator( & permutation=interval_permutations(2), & weight=0.1803807865240693, & coords=coords) - coords(1)=0.6193095930415985 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(3)=make_generator( & + coords(1)=0.6193095930415985 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(3)=make_generator( & permutation=interval_permutations(2), & weight=0.2339569672863455, & coords=coords) - !---------------------------------------------------------------------- - ! 7 point degree 7 quadrature. - i=i+1 + !---------------------------------------------------------------------- + ! 7 point degree 7 quadrature. + i=i+1 - allocate(interval_quads(i)%generator(4)) - interval_quads(i)%ngi=7 - interval_quads(i)%degree=7 + allocate(interval_quads(i)%generator(4)) + interval_quads(i)%ngi=7 + interval_quads(i)%degree=7 - coords(1)=0.9745539561713792 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.9745539561713792 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.0647424830844348, & coords=coords) - coords(1)=0.8707655927996972 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(2)=make_generator( & + coords(1)=0.8707655927996972 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(2)=make_generator( & permutation=interval_permutations(2), & weight=0.1398526957446384, & coords=coords) - coords(1)=0.7029225756886985 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(3)=make_generator( & + coords(1)=0.7029225756886985 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(3)=make_generator( & permutation=interval_permutations(2), & weight=0.1909150252525595, & coords=coords) - coords(1)=0.5 - interval_quads(i)%generator(4)=make_generator( & + coords(1)=0.5 + interval_quads(i)%generator(4)=make_generator( & permutation=interval_permutations(1), & weight=0.2089795918367347, & coords=coords) - !---------------------------------------------------------------------- - ! 8 point degree 8 quadrature. - i=i+1 + !---------------------------------------------------------------------- + ! 8 point degree 8 quadrature. + i=i+1 - allocate(interval_quads(i)%generator(4)) - interval_quads(i)%ngi=8 - interval_quads(i)%degree=8 + allocate(interval_quads(i)%generator(4)) + interval_quads(i)%ngi=8 + interval_quads(i)%degree=8 - coords(1)=0.9801449282487682 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(1)=make_generator( & + coords(1)=0.9801449282487682 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(1)=make_generator( & permutation=interval_permutations(2), & weight=0.0506142681451884, & coords=coords) - coords(1)=0.8983332387068134 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(2)=make_generator( & + coords(1)=0.8983332387068134 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(2)=make_generator( & permutation=interval_permutations(2), & weight=0.1111905172266872, & coords=coords) - coords(1)=0.7627662049581645 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(3)=make_generator( & + coords(1)=0.7627662049581645 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(3)=make_generator( & permutation=interval_permutations(2), & weight=0.1568533229389437, & coords=coords) - coords(1)=0.5917173212478249 - coords(2)=1.0-coords(1) - interval_quads(i)%generator(4)=make_generator( & + coords(1)=0.5917173212478249 + coords(2)=1.0-coords(1) + interval_quads(i)%generator(4)=make_generator( & permutation=interval_permutations(2), & weight=0.1813418916891811, & coords=coords) - end subroutine construct_interval_quadratures + end subroutine construct_interval_quadratures - subroutine construct_point_quadrature - !!< Construct the quadrature of the point according to a top secret - !!< formula! + subroutine construct_point_quadrature + !!< Construct the quadrature of the point according to a top secret + !!< formula! - point_quad%dim=0 - point_quad%vertices=1 - point_quad%ngi=1 - point_quad%degree=666 - allocate(point_quad(1)%generator(1)) - point_quad(1)%generator(1)=make_generator( & + point_quad%dim=0 + point_quad%vertices=1 + point_quad%ngi=1 + point_quad%degree=666 + allocate(point_quad(1)%generator(1)) + point_quad(1)%generator(1)=make_generator( & permutation=point_permutation(1), & weight=1.0, & coords=(/1.0/)) - end subroutine construct_point_quadrature + end subroutine construct_point_quadrature - subroutine construct_hex_quadratures - ! Construct list of available quadratures. - ! The references cited are listed on the Encyclopedia of Cubature - ! Formulas. - integer :: i + subroutine construct_hex_quadratures + ! Construct list of available quadratures. + ! The references cited are listed on the Encyclopedia of Cubature + ! Formulas. + integer :: i - hex_quads%dim=3 - hex_quads%vertices=8 + hex_quads%dim=3 + hex_quads%vertices=8 - i=0 + i=0 - !---------------------------------------------------------------------- - ! 1 point degree 1 quadrature. - ! Citation: Str71 - i=i+1 - ! Only one generator. - allocate(hex_quads(i)%generator(1)) - hex_quads(i)%ngi=1 - hex_quads(i)%degree=1 + !---------------------------------------------------------------------- + ! 1 point degree 1 quadrature. + ! Citation: Str71 + i=i+1 + ! Only one generator. + allocate(hex_quads(i)%generator(1)) + hex_quads(i)%ngi=1 + hex_quads(i)%degree=1 - hex_quads(i)%generator(1)=make_generator( & + hex_quads(i)%generator(1)=make_generator( & permutation=hex_permutations(1), & weight=8.0, & coords=(/0.0/)) - !---------------------------------------------------------------------- - ! 6 point degree 3 quadrature. - ! Citation: Str71 - i=i+1 - allocate(hex_quads(i)%generator(1)) - hex_quads(i)%ngi=6 - hex_quads(i)%degree=3 + !---------------------------------------------------------------------- + ! 6 point degree 3 quadrature. + ! Citation: Str71 + i=i+1 + allocate(hex_quads(i)%generator(1)) + hex_quads(i)%ngi=6 + hex_quads(i)%degree=3 - hex_quads(i)%generator(1)=make_generator( & + hex_quads(i)%generator(1)=make_generator( & permutation=hex_permutations(2), & weight=1.33333333333333333333333333333333, & coords=(/1.0/)) - !---------------------------------------------------------------------- - ! 8 point degree 3 quadrature. - ! Citation: Gauss - i=i+1 - allocate(hex_quads(i)%generator(1)) - hex_quads(i)%ngi=8 - hex_quads(i)%degree=3 + !---------------------------------------------------------------------- + ! 8 point degree 3 quadrature. + ! Citation: Gauss + i=i+1 + allocate(hex_quads(i)%generator(1)) + hex_quads(i)%ngi=8 + hex_quads(i)%degree=3 - hex_quads(i)%generator(1)=make_generator( & + hex_quads(i)%generator(1)=make_generator( & permutation=hex_permutations(5), & weight=1.0, & coords=(/sqrt(3.0)/3.0/)) - !---------------------------------------------------------------------- - ! 14 point degree 5 quadrature. - ! Citation: Str71 - i=i+1 - allocate(hex_quads(i)%generator(2)) - hex_quads(i)%ngi=14 - hex_quads(i)%degree=5 + !---------------------------------------------------------------------- + ! 14 point degree 5 quadrature. + ! Citation: Str71 + i=i+1 + allocate(hex_quads(i)%generator(2)) + hex_quads(i)%ngi=14 + hex_quads(i)%degree=5 - hex_quads(i)%generator(1)=make_generator( & + hex_quads(i)%generator(1)=make_generator( & permutation=hex_permutations(2), & weight=0.886426592797783933518005540166204, & coords=(/0.795822425754221463264548820476135/)) - hex_quads(i)%generator(2)=make_generator( & + hex_quads(i)%generator(2)=make_generator( & permutation=hex_permutations(5), & weight=0.335180055401662049861495844875346, & coords=(/0.758786910639328146269034278112267/)) - !---------------------------------------------------------------------- - ! 27 point degree 5 quadrature. - ! Citation: Gauss - i=i+1 - allocate(hex_quads(i)%generator(4)) - hex_quads(i)%ngi=27 - hex_quads(i)%degree=5 + !---------------------------------------------------------------------- + ! 27 point degree 5 quadrature. + ! Citation: Gauss + i=i+1 + allocate(hex_quads(i)%generator(4)) + hex_quads(i)%ngi=27 + hex_quads(i)%degree=5 - ! Origin - hex_quads(i)%generator(1)=make_generator( & + ! Origin + hex_quads(i)%generator(1)=make_generator( & permutation=hex_permutations(1), & weight=(8./9.)**3, & coords=(/0.0/)) - ! 2 points on each axis - hex_quads(i)%generator(2)=make_generator( & + ! 2 points on each axis + hex_quads(i)%generator(2)=make_generator( & permutation=hex_permutations(2), & weight=(5./9.)*(8./9.)**2, & coords=(/sqrt(15.)/5./)) - ! Point for each edge. - hex_quads(i)%generator(3)=make_generator( & + ! Point for each edge. + hex_quads(i)%generator(3)=make_generator( & permutation=hex_permutations(3), & weight=(8./9.)*(5./9.)**2, & coords=(/sqrt(15.)/5./)) - ! Corner points. - hex_quads(i)%generator(4)=make_generator( & + ! Corner points. + hex_quads(i)%generator(4)=make_generator( & permutation=hex_permutations(5), & weight=(5./9.)**3, & coords=(/sqrt(15.)/5./)) - !---------------------------------------------------------------------- - ! 38 point degree 7 quadrature. - ! Citation: KS 98 - i=i+1 - allocate(hex_quads(i)%generator(3)) - hex_quads(i)%ngi=38 - hex_quads(i)%degree=7 + !---------------------------------------------------------------------- + ! 38 point degree 7 quadrature. + ! Citation: KS 98 + i=i+1 + allocate(hex_quads(i)%generator(3)) + hex_quads(i)%ngi=38 + hex_quads(i)%degree=7 - hex_quads(i)%generator(1)=make_generator( & + hex_quads(i)%generator(1)=make_generator( & permutation=hex_permutations(2), & weight=0.295189738262622903181631100062774, & coords=(/0.901687807821291289082811566285950/)) - hex_quads(i)%generator(2)=make_generator( & + hex_quads(i)%generator(2)=make_generator( & permutation=hex_permutations(5), & weight=0.404055417266200582425904380777126, & coords=(/0.408372221499474674069588900002128/)) - hex_quads(i)%generator(3)=make_generator( & + hex_quads(i)%generator(3)=make_generator( & permutation=hex_permutations(6), & weight=0.124850759678944080062624098058597, & coords=(/0.859523090201054193116477875786220, & - & 0.414735913727987720499709244748633/)) + & 0.414735913727987720499709244748633/)) - end subroutine construct_hex_quadratures + end subroutine construct_hex_quadratures - subroutine construct_quad_quadratures - ! Construct list of available quadratures. - ! The references cited are listed on the Encyclopedia of Cubature - ! Formulas. - integer :: i + subroutine construct_quad_quadratures + ! Construct list of available quadratures. + ! The references cited are listed on the Encyclopedia of Cubature + ! Formulas. + integer :: i - quad_quads%dim=2 - quad_quads%vertices=4 + quad_quads%dim=2 + quad_quads%vertices=4 - i=0 + i=0 - !---------------------------------------------------------------------- - ! 1 point degree 1 quadrature. - ! Citation: Str71 - i=i+1 - ! Only one generator. - allocate(quad_quads(i)%generator(1)) - quad_quads(i)%ngi=1 - quad_quads(i)%degree=1 + !---------------------------------------------------------------------- + ! 1 point degree 1 quadrature. + ! Citation: Str71 + i=i+1 + ! Only one generator. + allocate(quad_quads(i)%generator(1)) + quad_quads(i)%ngi=1 + quad_quads(i)%degree=1 - quad_quads(i)%generator(1)=make_generator( & + quad_quads(i)%generator(1)=make_generator( & permutation=quad_permutations(1), & weight=4.0, & coords=(/0.0/)) - !---------------------------------------------------------------------- - ! 4 point degree 3 quadrature. - ! Citation: Gauss - i=i+1 - allocate(quad_quads(i)%generator(1)) - quad_quads(i)%ngi=4 - quad_quads(i)%degree=3 + !---------------------------------------------------------------------- + ! 4 point degree 3 quadrature. + ! Citation: Gauss + i=i+1 + allocate(quad_quads(i)%generator(1)) + quad_quads(i)%ngi=4 + quad_quads(i)%degree=3 - quad_quads(i)%generator(1)=make_generator( & + quad_quads(i)%generator(1)=make_generator( & permutation=quad_permutations(3), & weight=1.0, & coords=(/sqrt(3.0)/3.0/)) - !---------------------------------------------------------------------- - ! 8 point degree 5 quadrature. - ! Citation: Str71 - i=i+1 - allocate(quad_quads(i)%generator(2)) - quad_quads(i)%ngi=8 - quad_quads(i)%degree=5 + !---------------------------------------------------------------------- + ! 8 point degree 5 quadrature. + ! Citation: Str71 + i=i+1 + allocate(quad_quads(i)%generator(2)) + quad_quads(i)%ngi=8 + quad_quads(i)%degree=5 - quad_quads(i)%generator(1)=make_generator( & + quad_quads(i)%generator(1)=make_generator( & permutation=quad_permutations(2), & weight=0.816326530612244897959183673469387, & coords=(/0.683130051063973225548069245368070/)) - quad_quads(i)%generator(2)=make_generator( & + quad_quads(i)%generator(2)=make_generator( & permutation=quad_permutations(3), & weight=0.183673469387755102040816326530612, & coords=(/0.881917103688196863500538584546420/)) - !---------------------------------------------------------------------- - ! 9 point degree 5 quadrature. - ! Citation: Gauss - i=i+1 - allocate(quad_quads(i)%generator(4)) - quad_quads(i)%ngi=14 - quad_quads(i)%degree=5 + !---------------------------------------------------------------------- + ! 9 point degree 5 quadrature. + ! Citation: Gauss + i=i+1 + allocate(quad_quads(i)%generator(4)) + quad_quads(i)%ngi=14 + quad_quads(i)%degree=5 - ! Origin - quad_quads(i)%generator(1)=make_generator( & + ! Origin + quad_quads(i)%generator(1)=make_generator( & permutation=quad_permutations(1), & weight=(8./9.)**2, & coords=(/0.0/)) - ! 2 points on each axis - quad_quads(i)%generator(2)=make_generator( & + ! 2 points on each axis + quad_quads(i)%generator(2)=make_generator( & permutation=quad_permutations(2), & weight=(5./9.)*(8./9.), & coords=(/sqrt(15.)/5./)) - ! Corner points. - quad_quads(i)%generator(3)=make_generator( & + ! Corner points. + quad_quads(i)%generator(3)=make_generator( & permutation=quad_permutations(3), & weight=(5./9.)**2, & coords=(/sqrt(15.)/5./)) - !---------------------------------------------------------------------- - ! 12 point degree 7 quadrature. - ! Citation: Str71 - i=i+1 - allocate(quad_quads(i)%generator(3)) - quad_quads(i)%ngi=12 - quad_quads(i)%degree=7 + !---------------------------------------------------------------------- + ! 12 point degree 7 quadrature. + ! Citation: Str71 + i=i+1 + allocate(quad_quads(i)%generator(3)) + quad_quads(i)%ngi=12 + quad_quads(i)%degree=7 - quad_quads(i)%generator(1)=make_generator( & + quad_quads(i)%generator(1)=make_generator( & permutation=quad_permutations(2), & weight=0.241975308641975308641975308641975, & coords=(/0.925820099772551461566566776583999/)) - quad_quads(i)%generator(2)=make_generator( & + quad_quads(i)%generator(2)=make_generator( & permutation=quad_permutations(3), & weight=0.520592916667394457139919432046731, & coords=(/0.380554433208315656379106359086394/)) - quad_quads(i)%generator(3)=make_generator( & + quad_quads(i)%generator(3)=make_generator( & permutation=quad_permutations(3), & weight=0.237431774690630234218105259311293, & coords=(/0.805979782918598743707856181350744/)) - !---------------------------------------------------------------------- - ! 20 point degree 9 quadrature. - ! Citation: Str71 - i=i+1 - allocate(quad_quads(i)%generator(4)) - quad_quads(i)%ngi=20 - quad_quads(i)%degree=9 + !---------------------------------------------------------------------- + ! 20 point degree 9 quadrature. + ! Citation: Str71 + i=i+1 + allocate(quad_quads(i)%generator(4)) + quad_quads(i)%ngi=20 + quad_quads(i)%degree=9 - quad_quads(i)%generator(1)=make_generator( & + quad_quads(i)%generator(1)=make_generator( & permutation=quad_permutations(2), & weight=0.0716134247098109667847339079718044, & coords=(/0.984539811942252392433000600300987/)) - quad_quads(i)%generator(2)=make_generator( & + quad_quads(i)%generator(2)=make_generator( & permutation=quad_permutations(2), & weight=0.454090352551545224132152403485726, & coords=(/0.488886342842372416227768621326681/)) - quad_quads(i)%generator(3)=make_generator( & + quad_quads(i)%generator(3)=make_generator( & permutation=quad_permutations(3), & weight=0.0427846154667780511691683400146727, & coords=(/0.939567287421521534134303076231667/)) - quad_quads(i)%generator(4)=make_generator( & + quad_quads(i)%generator(4)=make_generator( & permutation=quad_permutations(4), & weight=0.215755803635932878956972674263898, & coords=(/0.836710325023988974095346291152195, & - & 0.507376773674613005277484034493916/)) + & 0.507376773674613005277484034493916/)) - end subroutine construct_quad_quadratures + end subroutine construct_quad_quadratures - subroutine construct_tet_permutations + subroutine construct_tet_permutations - allocate(tet_permutations(1)%p(4,4)) + allocate(tet_permutations(1)%p(4,4)) - tet_permutations(1)%p=reshape((/& + tet_permutations(1)%p=reshape((/& 1, 0, 0, 0, & 0, 1, 0, 0, & 0, 0, 1, 0, & 0, 0, 0, 1/),(/4,4/)) - allocate(tet_permutations(2)%p(4,6)) + allocate(tet_permutations(2)%p(4,6)) - tet_permutations(2)%p=reshape((/& + tet_permutations(2)%p=reshape((/& 1, 1, 0, 0, & 1, 0, 1, 0, & 1, 0, 0, 1, & @@ -1652,9 +1652,9 @@ subroutine construct_tet_permutations 0, 1, 0, 1, & 0, 0, 1, 1/),(/4,6/)) - allocate(tet_permutations(3)%p(4,12)) + allocate(tet_permutations(3)%p(4,12)) - tet_permutations(3)%p=reshape((/& + tet_permutations(3)%p=reshape((/& 1, 2, 0, 0, & 1, 0, 2, 0, & 1, 0, 0, 2, & @@ -1668,17 +1668,17 @@ subroutine construct_tet_permutations 0, 2, 0, 1, & 0, 0, 2, 1/),(/4,12/)) - allocate(tet_permutations(4)%p(4,4)) + allocate(tet_permutations(4)%p(4,4)) - tet_permutations(4)%p=reshape((/& + tet_permutations(4)%p=reshape((/& 1, 1, 1, 0, & 1, 1, 0, 1, & 1, 0, 1, 1, & 0, 1, 1, 1/),(/4,4/)) - allocate(tet_permutations(5)%p(4,12)) + allocate(tet_permutations(5)%p(4,12)) - tet_permutations(5)%p=reshape((/& + tet_permutations(5)%p=reshape((/& 1, 1, 2, 0, & 1, 1, 0, 2, & 1, 2, 1, 0, & @@ -1692,9 +1692,9 @@ subroutine construct_tet_permutations 2, 0, 1, 1, & 0, 2, 1, 1/),(/4,12/)) - allocate(tet_permutations(6)%p(4,24)) + allocate(tet_permutations(6)%p(4,24)) - tet_permutations(6)%p=reshape((/& + tet_permutations(6)%p=reshape((/& 1, 2, 3, 0, & 1, 2, 0, 3, & 1, 3, 2, 0, & @@ -1720,21 +1720,21 @@ subroutine construct_tet_permutations 3, 0, 2, 1, & 0, 3, 2, 1/),(/4,24/)) - allocate(tet_permutations(7)%p(4,1)) + allocate(tet_permutations(7)%p(4,1)) - tet_permutations(7)%p(:,1)=(/1, 1, 1, 1/) + tet_permutations(7)%p(:,1)=(/1, 1, 1, 1/) - allocate(tet_permutations(8)%p(4,4)) + allocate(tet_permutations(8)%p(4,4)) - tet_permutations(8)%p=reshape((/& + tet_permutations(8)%p=reshape((/& 1, 1, 1, 2, & 1, 1, 2, 1, & 1, 2, 1, 1, & 2, 1, 1, 1/),(/4,4/)) - allocate(tet_permutations(9)%p(4,6)) + allocate(tet_permutations(9)%p(4,6)) - tet_permutations(9)%p=reshape((/& + tet_permutations(9)%p=reshape((/& 1, 1, 2, 2, & 1, 2, 1, 2, & 1, 2, 2, 1, & @@ -1742,9 +1742,9 @@ subroutine construct_tet_permutations 2, 1, 2, 1, & 2, 2, 1, 1/),(/4,6/)) - allocate(tet_permutations(10)%p(4,12)) + allocate(tet_permutations(10)%p(4,12)) - tet_permutations(10)%p=reshape((/& + tet_permutations(10)%p=reshape((/& 1, 1, 2, 3, & 1, 1, 3, 2, & 1, 2, 1, 3, & @@ -1758,9 +1758,9 @@ subroutine construct_tet_permutations 2, 3, 1, 1, & 3, 2, 1, 1/),(/4,12/)) - allocate(tet_permutations(11)%p(4,24)) + allocate(tet_permutations(11)%p(4,24)) - tet_permutations(11)%p=reshape((/& + tet_permutations(11)%p=reshape((/& 1, 2, 3, 4, & 1, 2, 4, 3, & 1, 3, 2, 4, & @@ -1786,27 +1786,27 @@ subroutine construct_tet_permutations 3, 4, 2, 1, & 4, 3, 2, 1/),(/4,24/)) - end subroutine construct_tet_permutations + end subroutine construct_tet_permutations - subroutine construct_tri_permutations + subroutine construct_tri_permutations - allocate(tri_permutations(1)%p(3,3)) + allocate(tri_permutations(1)%p(3,3)) - tri_permutations(1)%p=reshape((/& + tri_permutations(1)%p=reshape((/& 1, 0, 0, & 0, 1, 0, & 0, 0, 1/),(/3,3/)) - allocate(tri_permutations(2)%p(3,3)) + allocate(tri_permutations(2)%p(3,3)) - tri_permutations(2)%p=reshape((/& + tri_permutations(2)%p=reshape((/& 1, 1, 0, & 1, 0, 1, & 0, 1, 1/),(/3,3/)) - allocate(tri_permutations(3)%p(3,6)) + allocate(tri_permutations(3)%p(3,6)) - tri_permutations(3)%p=reshape((/& + tri_permutations(3)%p=reshape((/& 1, 2, 0, & 1, 0, 2, & 2, 1, 0, & @@ -1814,20 +1814,20 @@ subroutine construct_tri_permutations 2, 0, 1, & 0, 2, 1/),(/3,6/)) - allocate(tri_permutations(4)%p(3,1)) + allocate(tri_permutations(4)%p(3,1)) - tri_permutations(4)%p(:,1)=(/1,1,1/) + tri_permutations(4)%p(:,1)=(/1,1,1/) - allocate(tri_permutations(5)%p(3,3)) + allocate(tri_permutations(5)%p(3,3)) - tri_permutations(5)%p=reshape((/& + tri_permutations(5)%p=reshape((/& 1, 1, 2, & 1, 2, 1, & 2, 1, 1/),(/3,3/)) - allocate(tri_permutations(6)%p(3,6)) + allocate(tri_permutations(6)%p(3,6)) - tri_permutations(6)%p=reshape((/& + tri_permutations(6)%p=reshape((/& 1, 2, 3, & 1, 3, 2, & 2, 1, 3, & @@ -1835,287 +1835,287 @@ subroutine construct_tri_permutations 2, 3, 1, & 3, 2, 1/),(/3,6/)) - end subroutine construct_tri_permutations + end subroutine construct_tri_permutations - subroutine construct_tri_cycles - ! Construct the cyclic permutations of a triangle. + subroutine construct_tri_cycles + ! Construct the cyclic permutations of a triangle. - allocate(tri_cycles(1)%p(3,3)) + allocate(tri_cycles(1)%p(3,3)) - tri_cycles(1)%p=reshape((/& + tri_cycles(1)%p=reshape((/& 1, 0, 0, & 0, 1, 0, & 0, 0, 1/),(/3,3/)) - allocate(tri_cycles(2)%p(3,3)) + allocate(tri_cycles(2)%p(3,3)) - tri_cycles(2)%p=reshape((/& + tri_cycles(2)%p=reshape((/& 1, 1, 0, & 1, 0, 1, & 0, 1, 1/),(/3,3/)) - allocate(tri_cycles(3)%p(3,3)) + allocate(tri_cycles(3)%p(3,3)) - tri_cycles(3)%p=reshape((/& + tri_cycles(3)%p=reshape((/& 1, 2, 0, & 0, 1, 2, & 2, 0, 1/),(/3,3/)) - allocate(tri_cycles(4)%p(3,1)) + allocate(tri_cycles(4)%p(3,1)) - tri_cycles(4)%p(:,1)=(/1,1,1/) + tri_cycles(4)%p(:,1)=(/1,1,1/) - allocate(tri_cycles(5)%p(3,3)) + allocate(tri_cycles(5)%p(3,3)) - tri_cycles(5)%p=reshape((/& + tri_cycles(5)%p=reshape((/& 1, 1, 2, & 1, 2, 1, & 2, 1, 1/),(/3,3/)) - allocate(tri_cycles(6)%p(3,3)) + allocate(tri_cycles(6)%p(3,3)) - tri_cycles(6)%p=reshape((/& + tri_cycles(6)%p=reshape((/& 1, 2, 3, & 3, 1, 2, & 2, 3, 1/),(/3,3/)) - end subroutine construct_tri_cycles + end subroutine construct_tri_cycles - subroutine construct_point_permutation - !! The trivial single permuration of the point. + subroutine construct_point_permutation + !! The trivial single permuration of the point. - allocate(point_permutation(1)%p(1,1)) + allocate(point_permutation(1)%p(1,1)) - point_permutation(1)%p=1 + point_permutation(1)%p=1 - end subroutine construct_point_permutation + end subroutine construct_point_permutation - subroutine construct_interval_permutations + subroutine construct_interval_permutations - allocate(interval_permutations(1)%p(2,1)) + allocate(interval_permutations(1)%p(2,1)) - interval_permutations(1)%p(:,1)=(/1,1/) + interval_permutations(1)%p(:,1)=(/1,1/) - allocate(interval_permutations(2)%p(2,2)) + allocate(interval_permutations(2)%p(2,2)) - interval_permutations(2)%p=reshape((/& + interval_permutations(2)%p=reshape((/& 1, 2, & 2, 1/),(/2,2/)) - end subroutine construct_interval_permutations + end subroutine construct_interval_permutations - subroutine construct_hex_permutations + subroutine construct_hex_permutations - allocate(hex_permutations(1)%p(3,1)) + allocate(hex_permutations(1)%p(3,1)) - hex_permutations(1)%p(:,1)=(/0,0,0/) + hex_permutations(1)%p(:,1)=(/0,0,0/) - allocate(hex_permutations(2)%p(3,6)) + allocate(hex_permutations(2)%p(3,6)) - hex_permutations(2)%p=reshape((/& - 1, 0, 0, & - 0, 1, 0, & - 0, 0, 1, & + hex_permutations(2)%p=reshape((/& + 1, 0, 0, & + 0, 1, 0, & + 0, 0, 1, & -1 ,0, 0, & - 0,-1, 0, & - 0, 0,-1/),(/3,6/)) + 0,-1, 0, & + 0, 0,-1/),(/3,6/)) - allocate(hex_permutations(3)%p(3,12)) + allocate(hex_permutations(3)%p(3,12)) - hex_permutations(3)%p=reshape((/& - 1, 1, 0, & - 1, 0, 1, & - 0, 1, 1, & + hex_permutations(3)%p=reshape((/& + 1, 1, 0, & + 1, 0, 1, & + 0, 1, 1, & -1, 1, 0, & - 1, 0,-1, & - 0,-1, 1, & - 1,-1, 0, & + 1, 0,-1, & + 0,-1, 1, & + 1,-1, 0, & -1, 0, 1, & - 0, 1,-1, & + 0, 1,-1, & -1,-1, 0, & -1, 0,-1, & - 0,-1,-1 /),(/3,12/)) + 0,-1,-1 /),(/3,12/)) - allocate(hex_permutations(4)%p(3,12)) + allocate(hex_permutations(4)%p(3,12)) - hex_permutations(4)%p=reshape((/& - 1, 2, 0, & - 1, 0, 2, & - 0, 1, 2, & - 2, 1, 0, & - 0, 2, 1, & - 2, 0, 1, & + hex_permutations(4)%p=reshape((/& + 1, 2, 0, & + 1, 0, 2, & + 0, 1, 2, & + 2, 1, 0, & + 0, 2, 1, & + 2, 0, 1, & -1, 2, 0, & -1, 0, 2, & - 0,-1, 2, & - 2,-1, 0, & - 0, 2,-1, & - 2, 0,-1, & - 1,-2, 0, & - 1, 0,-2, & - 0, 1,-2, & + 0,-1, 2, & + 2,-1, 0, & + 0, 2,-1, & + 2, 0,-1, & + 1,-2, 0, & + 1, 0,-2, & + 0, 1,-2, & -2, 1, 0, & - 0,-2, 1, & + 0,-2, 1, & -2, 0, 1, & -1,-2, 0, & -1, 0,-2, & - 0,-1,-2, & + 0,-1,-2, & -2,-1, 0, & - 0,-2,-1, & + 0,-2,-1, & -2, 0,-1/),(/3,12/)) - allocate(hex_permutations(5)%p(3,8)) + allocate(hex_permutations(5)%p(3,8)) - hex_permutations(5)%p=reshape((/& - 1, 1, 1, & - 1, 1,-1, & - 1,-1, 1, & - 1,-1,-1, & + hex_permutations(5)%p=reshape((/& + 1, 1, 1, & + 1, 1,-1, & + 1,-1, 1, & + 1,-1,-1, & -1, 1, 1, & -1, 1,-1, & -1,-1, 1, & -1,-1,-1/),(/3,8/)) - allocate(hex_permutations(6)%p(3,24)) + allocate(hex_permutations(6)%p(3,24)) - hex_permutations(6)%p=reshape((/& - 1, 1, 2, & - 1, 1,-2, & - 1,-1, 2, & - 1,-1,-2, & + hex_permutations(6)%p=reshape((/& + 1, 1, 2, & + 1, 1,-2, & + 1,-1, 2, & + 1,-1,-2, & -1, 1, 2, & -1, 1,-2, & -1,-1, 2, & -1,-1,-2, & - 1, 2, 1, & - 1, 2,-1, & - 1,-2, 1, & - 1,-2,-1, & + 1, 2, 1, & + 1, 2,-1, & + 1,-2, 1, & + 1,-2,-1, & -1, 2, 1, & -1, 2,-1, & -1,-2, 1, & -1,-2,-1, & - 2, 1, 1, & - 2, 1,-1, & - 2,-1, 1, & - 2,-1,-1, & + 2, 1, 1, & + 2, 1,-1, & + 2,-1, 1, & + 2,-1,-1, & -2, 1, 1, & -2, 1,-1, & -2,-1, 1, & -2,-1,-1/),(/3,24/)) - allocate(hex_permutations(7)%p(3,48)) + allocate(hex_permutations(7)%p(3,48)) - hex_permutations(7)%p=reshape((/& - 1, 2, 3, & - 1, 2,-3, & - 1,-2, 3, & - 1,-2,-3, & + hex_permutations(7)%p=reshape((/& + 1, 2, 3, & + 1, 2,-3, & + 1,-2, 3, & + 1,-2,-3, & -1, 2, 3, & -1, 2,-3, & -1,-2, 3, & -1,-2,-3, & - 1, 3, 2, & - 1, 3,-2, & - 1,-3, 2, & - 1,-3,-2, & + 1, 3, 2, & + 1, 3,-2, & + 1,-3, 2, & + 1,-3,-2, & -1, 3, 2, & -1, 3,-2, & -1,-3, 2, & -1,-3,-2, & - 2, 1, 3, & - 2, 1,-3, & - 2,-1, 3, & - 2,-1,-3, & + 2, 1, 3, & + 2, 1,-3, & + 2,-1, 3, & + 2,-1,-3, & -2, 1, 3, & -2, 1,-3, & -2,-1, 3, & -2,-1,-3, & - 3, 1, 2, & - 3, 1,-2, & - 3,-1, 2, & - 3,-1,-2, & + 3, 1, 2, & + 3, 1,-2, & + 3,-1, 2, & + 3,-1,-2, & -3, 1, 2, & -3, 1,-2, & -3,-1, 2, & -3,-1,-2, & - 2, 3, 1, & - 2, 3,-1, & - 2,-3, 1, & - 2,-3,-1, & + 2, 3, 1, & + 2, 3,-1, & + 2,-3, 1, & + 2,-3,-1, & -2, 3, 1, & -2, 3,-1, & -2,-3, 1, & -2,-3,-1, & - 3, 2, 1, & - 3, 2,-1, & - 3,-2, 1, & - 3,-2,-1, & + 3, 2, 1, & + 3, 2,-1, & + 3,-2, 1, & + 3,-2,-1, & -3, 2, 1, & -3, 2,-1, & -3,-2, 1, & -3,-2,-1/),(/3,48/)) - end subroutine construct_hex_permutations + end subroutine construct_hex_permutations - subroutine construct_quad_permutations + subroutine construct_quad_permutations - allocate(quad_permutations(1)%p(2,1)) + allocate(quad_permutations(1)%p(2,1)) - quad_permutations(1)%p(:,1)=(/0,0/) + quad_permutations(1)%p(:,1)=(/0,0/) - allocate(quad_permutations(2)%p(2,4)) + allocate(quad_permutations(2)%p(2,4)) - quad_permutations(2)%p=reshape((/& - 1, 0, & + quad_permutations(2)%p=reshape((/& + 1, 0, & -1, 0, & - 0, 1, & - 0,-1/),(/2,4/)) + 0, 1, & + 0,-1/),(/2,4/)) - allocate(quad_permutations(3)%p(2,4)) + allocate(quad_permutations(3)%p(2,4)) - quad_permutations(3)%p=reshape((/& - 1, 1, & - 1,-1, & + quad_permutations(3)%p=reshape((/& + 1, 1, & + 1,-1, & -1, 1, & -1,-1/), (/2,4/)) - allocate(quad_permutations(4)%p(2,8)) + allocate(quad_permutations(4)%p(2,8)) - quad_permutations(4)%p=reshape((/& - 1, 2, & - 1,-2, & + quad_permutations(4)%p=reshape((/& + 1, 2, & + 1,-2, & -1, 2, & -1,-2, & - 2, 1, & - 2,-1, & + 2, 1, & + 2,-1, & -2, 1, & -2,-1/),(/2,8/)) - end subroutine construct_quad_permutations + end subroutine construct_quad_permutations - subroutine local_coords_matrix_positions(positions, mat) - ! dim x loc - real, dimension(:, :), intent(in) :: positions - real, dimension(size(positions, 2), size(positions, 2)), intent(out) :: mat + subroutine local_coords_matrix_positions(positions, mat) + ! dim x loc + real, dimension(:, :), intent(in) :: positions + real, dimension(size(positions, 2), size(positions, 2)), intent(out) :: mat - mat(1:size(positions,1), :) = positions - mat(size(positions,2), :) = 1.0 + mat(1:size(positions,1), :) = positions + mat(size(positions,2), :) = 1.0 - call invert(mat) - end subroutine local_coords_matrix_positions + call invert(mat) + end subroutine local_coords_matrix_positions - recursive function factorial(n) result(f) - ! Calculate n! - integer :: f - integer, intent(in) :: n + recursive function factorial(n) result(f) + ! Calculate n! + integer :: f + integer, intent(in) :: n - if (n==0) then - f=1 - else - f=n*factorial(n-1) - end if + if (n==0) then + f=1 + else + f=n*factorial(n-1) + end if - end function factorial + end function factorial end module quadrature diff --git a/femtools/Quadrature_Test.F90 b/femtools/Quadrature_Test.F90 index a6ece8b043..87eddf9cb0 100644 --- a/femtools/Quadrature_Test.F90 +++ b/femtools/Quadrature_Test.F90 @@ -26,59 +26,59 @@ ! USA module quadrature_test - !!< Support module for all unit tests related to quadrature. - !!< Provides auxiliary routines needed by these tests and separates these - !!< from the actual module, thereby reducing dependencies. - use quadrature - implicit none + !!< Support module for all unit tests related to quadrature. + !!< Provides auxiliary routines needed by these tests and separates these + !!< from the actual module, thereby reducing dependencies. + use quadrature + implicit none - ! Power is used by the test functions. - integer, save :: power=0 + ! Power is used by the test functions. + integer, save :: power=0 - contains +contains - !------------------------------------------------------------------------ - ! Test procedures - !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + ! Test procedures + !------------------------------------------------------------------------ - function quad_integrate(integrand, quad) result (integral) - ! Integrate the function integrand over an element using the - ! specified quadrature. - real :: integral - interface - function integrand(coords) - real :: integrand - real, dimension(:), intent(in) :: coords - end function integrand - end interface - type(quadrature_type) :: quad + function quad_integrate(integrand, quad) result (integral) + ! Integrate the function integrand over an element using the + ! specified quadrature. + real :: integral + interface + function integrand(coords) + real :: integrand + real, dimension(:), intent(in) :: coords + end function integrand + end interface + type(quadrature_type) :: quad - integer :: i + integer :: i - integral=0 + integral=0 - do i=1, size(quad%weight) - integral=integral+quad%weight(i)*integrand(quad%l(i,:)) - end do + do i=1, size(quad%weight) + integral=integral+quad%weight(i)*integrand(quad%l(i,:)) + end do - end function quad_integrate + end function quad_integrate - function monic(coords) - ! Calculate x^n - real :: monic - real, dimension(:), intent(in) :: coords + function monic(coords) + ! Calculate x^n + real :: monic + real, dimension(:), intent(in) :: coords - monic=coords(1)**power + monic=coords(1)**power - end function monic + end function monic - function cube_monic(coords) - ! Calculate. - real :: cube_monic - real, dimension(:), intent(in) :: coords + function cube_monic(coords) + ! Calculate. + real :: cube_monic + real, dimension(:), intent(in) :: coords - cube_monic=((1-coords(1))/2.0)**power + cube_monic=((1-coords(1))/2.0)**power - end function cube_monic + end function cube_monic end module quadrature_test diff --git a/femtools/Read_Exodusii.F90 b/femtools/Read_Exodusii.F90 index 91ad0df6e4..a9dfc8f0dd 100644 --- a/femtools/Read_Exodusii.F90 +++ b/femtools/Read_Exodusii.F90 @@ -28,645 +28,645 @@ #include "fdebug.h" module read_exodusii - ! This module reads ExodusII files and results in a vector field of - ! node coordinates, their connectivity, and node sets (grouped nodes - ! given an ID, e.g. for setting physical boundaries) - - use iso_c_binding, only: C_INT, C_FLOAT, C_CHAR, C_NULL_CHAR - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use futils - use quadrature - use elements - use spud - use parallel_tools - use fields - use state_module - use vtk_interfaces - use exodusii_common - use exodusii_f_interface - - implicit none - - private - - interface read_exodusii_file - module procedure read_exodusii_file_to_field, & - read_exodusii_simple, & - read_exodusii_file_to_state - end interface - - public :: read_exodusii_file, identify_exodusii_file + ! This module reads ExodusII files and results in a vector field of + ! node coordinates, their connectivity, and node sets (grouped nodes + ! given an ID, e.g. for setting physical boundaries) + + use iso_c_binding, only: C_INT, C_FLOAT, C_CHAR, C_NULL_CHAR + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use futils + use quadrature + use elements + use spud + use parallel_tools + use fields + use state_module + use vtk_interfaces + use exodusii_common + use exodusii_f_interface + + implicit none + + private + + interface read_exodusii_file + module procedure read_exodusii_file_to_field, & + read_exodusii_simple, & + read_exodusii_file_to_state + end interface + + public :: read_exodusii_file, identify_exodusii_file contains - function read_exodusii_simple(filename, quad_degree, & - quad_ngi, quad_family ) result (field) - !!< A simpler mechanism for reading an ExodusII file into a field. - character(len=*), intent(in) :: filename - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_degree - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_ngi - !! What quadrature family to use - integer, intent(in), optional :: quad_family - type(vector_field) :: field - type(quadrature_type) :: quad - type(element_type) :: shape - integer :: dim, loc - - ewrite(1,*) "In read_exodusii_simple" - - if(isparallel()) then - !call identify_exodusii_file(parallel_filename(filename), dim, loc) - FLExit("Currently we cannot read in a decomposed Exodus mesh file") - else - call identify_exodusii_file(filename, dim, loc) - end if - - if (present(quad_degree)) then - quad = make_quadrature(loc, dim, degree=quad_degree, family=quad_family) - else if (present(quad_ngi)) then - quad = make_quadrature(loc, dim, ngi=quad_ngi, family=quad_family) - else - FLAbort("Need to specify either quadrature degree or ngi") - end if - - shape=make_element_shape(loc, dim, 1, quad) - - field=read_exodusii_file(filename, shape) - - call deallocate(shape) - call deallocate(quad) - - ewrite(2,*) "Out of read_exodusii_simple" - - end function read_exodusii_simple - - ! ----------------------------------------------------------------- - ! ExodusII version of gmsh/triangle equivalent. - subroutine identify_exodusii_file(filename, numDimenOut, locOut, & - numElementsOut, boundaryFlagOut) - ! Discover the dimension and size of the ExodusII mesh. - ! Filename is the base name of the file without the - ! ExodusII extension .e .exo .E .EXO - - character(len=*), intent(in) :: filename - - !! Number of vertices of elements. - integer, intent(out), optional :: numDimenOut, locOut - integer, intent(out), optional :: numElementsOut - integer, intent(out), optional :: boundaryFlagOut - - integer :: boundaryFlag - - logical :: fileExists - - integer :: exoid, ierr - real(kind=c_float) :: version - integer(kind=c_int) :: comp_ws, io_ws, mode - character(kind=c_char, len=OPTION_PATH_LEN) :: lfilename - - character(kind=c_char, len=OPTION_PATH_LEN) :: title - integer :: num_dim, num_nodes, num_allelem, num_elem_blk - integer :: num_node_sets, num_side_sets - integer, allocatable, dimension(:) :: block_ids, num_elem_in_block, num_nodes_per_elem - - ewrite(1,*) "In identify_exodusii_file" - - call get_exodusii_filename(filename, lfilename, fileExists) - if(.not. fileExists) then - FLExit("None of the possible ExodusII files "//trim(filename)//".exo /.e /.EXO /.E were found") - end if - - ewrite(2, *) "Opening " // trim(lfilename) // " for reading in database parameters" - - version = 0.0 - mode = 0; comp_ws=0; io_ws=0; - exoid = f_read_ex_open(trim(lfilename)//C_NULL_CHAR, mode, comp_ws, io_ws, version) - - if (exoid <= 0) then - FLExit("Unable to open "//trim(lfilename)) - end if - - ! Get database parameters from exodusII file - ierr = f_ex_get_init(exoid, title, num_dim, num_nodes, & - num_allelem, num_elem_blk, num_node_sets, & - num_side_sets) - if (ierr /= 0) then - FLExit("Unable to read database parameters from "//trim(lfilename)) - end if - - ! Check for boundaries (internal boundaries currently not supported): - if (num_side_sets /= 0) then - boundaryFlag = 1 ! physical boundaries found - else - boundaryFlag = 0 ! no physical boundaries defined - end if - - ! Get num_nodes_per_elem - allocate(block_ids(num_elem_blk)) - allocate(num_elem_in_block(num_elem_blk)) - allocate(num_nodes_per_elem(num_elem_blk)) - ierr = f_ex_get_elem_block_parameters(exoid, num_elem_blk, block_ids, num_elem_in_block, num_nodes_per_elem) - if (ierr /= 0) then - FLExit("Unable to read in block parameters from "//trim(lfilename)) - end if - - ierr = f_ex_close(exoid) - if (ierr /= 0) then - FLExit("Unable to close file "//trim(lfilename)) - end if - - ! Return optional variables requested - if(present(numDimenOut)) numDimenOut=num_dim - ! numElementsOut is set to be the total number of volume and surface - ! elements in the exodusII mesh, as only that is stored in the header - ! of the mesh file. In Fluidity, only the volume elements of the mesh - ! file are taken into account. Thus the actual number of volume - ! elements is computed when the CoordinateMesh is assembled. - if(present(numElementsOut)) numElementsOut=num_allelem - ! Here we assume all (volume) elements of the mesh have the same - ! number of vertices/nodes. Since the exodusII mesh could contain - ! surface elements (as described above) we set locOut to be the - ! max number of nodes per elements. Checking for hybrid meshes, - ! that are currently not supported in Fluidity, is done when - ! assembling the CoordinateMesh. - if(present(locOut)) locOut=maxval(num_nodes_per_elem) - if(present(boundaryFlagOut)) boundaryFlagOut=boundaryFlag - - ewrite(2,*) "Out of identify_exodusii_file" - - end subroutine identify_exodusii_file - - ! ----------------------------------------------------------------- - ! The main function for reading ExodusII files - function read_exodusii_file_to_field(filename, shape) result (field) - character(len=*), intent(in) :: filename - type(element_type), intent(in), target :: shape - type(vector_field) :: field - type(mesh_type) :: mesh - - logical :: fileExists - logical :: haveRegionIDs, haveBoundaries - - type(EXOelement), pointer :: exo_element(:), exo_face(:), allelements(:) - - ! exodusii lib basic variables: - integer :: exoid, ierr - real(kind=c_float) :: version - integer(kind=c_int) :: comp_ws, io_ws, mode - character(kind=c_char, len=OPTION_PATH_LEN) :: lfilename - character(kind=c_char, len=OPTION_PATH_LEN) :: title - integer :: num_dim, num_nodes, num_allelem, num_elem_blk - integer :: num_node_sets, num_side_sets - - ! exodusii lib variables: - real(kind=c_float), allocatable, dimension(:) :: coord_x, coord_y, coord_z - integer, allocatable, dimension(:) :: node_map, elem_num_map, elem_order_map - integer, allocatable, dimension(:) :: block_ids, num_elem_in_block, num_nodes_per_elem - integer, allocatable, dimension(:) :: elem_type, elem_connectivity - integer, allocatable, dimension(:) :: side_set_ids, num_elem_in_set - integer, allocatable, dimension(:) :: total_side_sets_node_list, total_side_sets_elem_list - integer, allocatable, dimension(:) :: total_side_sets_node_cnt_list - - ! variables for conversion to fluidity structure: - real(c_float), allocatable, dimension(:,:) :: node_coord - integer, allocatable, dimension(:) :: total_elem_node_list - integer, allocatable, dimension(:) :: sndglno, boundaryIDs - - integer :: num_faces, num_elem, faceType - integer :: loc, sloc - integer :: eff_dim, f, gdim - - ewrite(1,*) "In read_exodusii_file_to_field" - - ! First of all: Identify the filename: - call get_exodusii_filename(filename, lfilename, fileExists) - if(.not. fileExists) then - FLExit("None of the possible ExodusII files "//trim(filename)//".exo /.e /.EXO /.E were found") - end if - - ewrite(2, *) "Opening " // trim(lfilename) // " for reading in the mesh" - - version = 0.0 - mode = 0; comp_ws=0; io_ws=0; - exoid = f_read_ex_open(trim(lfilename)//C_NULL_CHAR, mode, comp_ws, io_ws, version) - - if (exoid <= 0) then - FLExit("Unable to open "//trim(lfilename)) - end if - - ! Get database parameters from exodusII file - ierr = f_ex_get_init(exoid, title, num_dim, num_nodes, & - num_allelem, num_elem_blk, num_node_sets, & - num_side_sets) - if (ierr /= 0) then - FLExit("Unable to read database parameters from "//trim(lfilename)) - end if - - ! Catch user mistake of setting node sets instead of side sets: - ! Give the user an error message, since node sets are not supported here, only side sets: - if (num_node_sets > 0) then - ! Maybe a warning might be better here, instead of FLExit: - ewrite(-1,*) "You have specified node sets on your ExodusII meshfile '"//trim(lfilename)//"' but node sets are not supported by Fluidity. Please set your boundary conditions as side sets" - FLExit("Node sets are not supported by Fluidity, use side sets instead.") - end if - - ! read nodal coordinates values and names from database - allocate(coord_x(num_nodes)) - allocate(coord_y(num_nodes)) - allocate(coord_z(num_nodes)) - coord_x=0.0; coord_y=0.0; coord_z=0.0 - ! Get coordinates from the mesh: - ierr = f_ex_get_coord(exoid, coord_x, coord_y, coord_z) - if (ierr /= 0) then - FLExit("Unable to read in node coordinates "//trim(lfilename)) - end if - - ! Read node number map: - allocate(node_map(num_nodes)) - ierr = f_ex_get_node_num_map(exoid, node_map) - if (ierr /= 0) then - FLExit("Unable to read in node number map from "//trim(lfilename)) - end if - - ! read element number map - allocate(elem_num_map(num_allelem)) - elem_num_map = 0 - ierr = f_ex_get_elem_num_map(exoid, elem_num_map) - if (ierr /= 0) then - FLExit("Unable to read in element number map "//trim(lfilename)) - end if - - ! read element order map - allocate(elem_order_map(num_allelem)) - elem_order_map = 0 - ierr = f_ex_get_elem_order_map(exoid, elem_order_map) - if (ierr /= 0) then - FLExit("Unable to read in element order map "//trim(lfilename)) - end if - - ! Get block ids: - allocate(block_ids(num_elem_blk)) - ierr = f_ex_get_elem_blk_ids(exoid, block_ids) - if (ierr /= 0) then - FLExit("Unable to read in element block ids from "//trim(lfilename)) - end if - - ! Get block parameters: - allocate(num_elem_in_block(num_elem_blk)) - allocate(num_nodes_per_elem(num_elem_blk)) - allocate(elem_type(num_elem_blk)) - call get_block_param(exoid, lfilename, block_ids, num_elem_blk, num_elem_in_block, num_nodes_per_elem, elem_type) - - ! Get faceType and give the user an error if he supplied a mesh with an unsupported combination of element types: - call check_combination_face_element_types(num_dim, num_elem_blk, elem_type, lfilename, faceType) - - ! read element connectivity: - allocate(elem_connectivity(0)) - call get_element_connectivity(exoid, block_ids, num_elem_blk, num_nodes_per_elem, num_elem_in_block, lfilename, elem_connectivity) - - ! Initialize logical variables: - ! We have RegionIDs when there are blockIDs assigned to elements - ! so basically always when supplying an exodusII mesh, as an blockID is assigned - ! to all elements of the mesh if the user does not specify an blockID manually - haveRegionIDs = .true. ! redundant for reasons stated above, but kept here to keep it consistent with gmshreader for now - ! Boundaries: Boundaries are present if at least one side-set was supplied by the user: - if (num_side_sets .gt. 0) then - haveBoundaries = .true. - else - haveBoundaries = .false. - end if - ! Get side sets - ! Side sets in exodusii are what physical lines/surfaces are in gmsh (so basically boundary-IDs) - ! Allocate arrays for the side sets: - ! Get Side SetIDs and parameters: - if (haveBoundaries) then - allocate(side_set_ids(num_side_sets)) - allocate(num_elem_in_set(num_side_sets)) ! There are the same # of elements as sides in a side set - ! Allocate return arrays of the subroutine get_side_set_param: - allocate(total_side_sets_elem_list(0)); allocate(total_side_sets_node_list(0)); allocate(total_side_sets_node_cnt_list(0)) - call get_side_set_param(exoid, num_side_sets, lfilename, side_set_ids, num_elem_in_set, total_side_sets_elem_list, total_side_sets_node_list, total_side_sets_node_cnt_list) - end if - - ! Close ExodusII meshfile - ierr = f_ex_close(exoid) - if (ierr /= 0) then - FLExit("Unable close file "//trim(lfilename)) - end if - - - !--------------------------------- - ! At this point, all relevant data has been read in from the exodusii file - ! Now construct within Fluidity data structures - - if( have_option("/geometry/spherical_earth/") ) then - call get_option('/geometry/dimension', gdim) - eff_dim = gdim - else - eff_dim = num_dim - end if - - ! Reorder element node numbering (if necessary): - ! (allows for different element types) - call reorder_node_numbering(num_elem_blk, num_nodes_per_elem, num_elem_in_block, elem_connectivity, elem_type, total_elem_node_list) - - ! check if number of vertices/nodes are consistent with shape - loc = maxval(num_nodes_per_elem) - assert(loc==shape%loc) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Coordinates ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Loop around nodes copying across coords - ! First, assemble array containing all node coordinates: - allocate(node_coord(eff_dim, num_nodes)) - node_coord = 0 - node_coord(1,:) = coord_x(:) - if (eff_dim .eq. 2 .or. eff_dim .eq. 3) then - node_coord(2,:) = coord_y(:) - end if - if (eff_dim .eq. 3) then - node_coord(3,:) = coord_z(:) - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Assemble allelements (without faces) ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate(allelements(num_allelem)) - call assemble_allelements(num_elem_blk, block_ids, num_elem_in_block, & - num_nodes_per_elem, elem_order_map, elem_type, & - total_elem_node_list, allelements) - ! At this stage 'allelements' contains all elements (faces and elements) of all blocks of the mesh - ! Now, in case we have side sets/boundary ids in the mesh, assigns those ids to allelements: - if (haveBoundaries) then - call allelements_add_boundary_ids(num_side_sets, num_elem_in_set, total_side_sets_elem_list, side_set_ids, allelements) - end if - ! At this stage, the elements of 'allelements' have been correctly tagged, - ! meaning they carry the side set ID(s) as tags, which later will - ! become the boundary ID of their face(s) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Identify Faces ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Now faces: - ! First of all: Face elements in the mesh (-file) are neglected, thus get the - ! number of elements (-minus number of face-elements in the mesh), - ! and by 'elements' we mean no edges/faces in 2D/3D. - ! And then subtract the amount of elements that carry at least one side-set-id - ! In 2D: Faces are lines/edges - ! In 3D: Faces are surfaces - ! Find total number of such faces in all blocks - ! loop over blocks, check for element type in block i, - ! and depending on the mesh dimension, determine if element e is a face or element - ! This does not support a 1D mesh, - ! because you do NOT want to use fancy cubit to create a 1D mesh, do you?! - ! Get number of elements and faces in the mesh: - num_elem = 0; num_faces = 0 - sloc = 0 - call get_num_elem(num_dim, num_elem_blk, elem_type, num_elem_in_block, num_elem) - - ! Set sloc based on faceType: - ! Only faceTypes 1, 2, and 3 are allowed (see above), their corresponding sloc is faceType+1, - ! e.g. if faceType = 2 (triangle), it should have 3 nodes, which is faceType+1 - sloc = faceType+1 - ! Now check for site-set-id/physical-id, if element has numTags>0, - ! than an edge/face will be generated next to that element, - ! and the element's side-set-ID will be assigned to the newly generated edge/face - if (haveBoundaries) then - call get_num_faces(num_allelem, allelements, num_faces) - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Setting Elements and faces ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Now actually set the elements and face-elements: - ! assemble array with faces (exo_face contains element number (=element id of mesh)) - allocate(exo_element(num_elem)) - call assemble_actual_elements(num_dim, num_elem_blk, num_elem_in_block, elem_type, allElements, exo_element) - - - ! Now derive the faces for fluidity, that are based on elements with side-set-ID: - if (haveBoundaries) then - allocate(exo_face(num_faces)) - call assemble_actual_face_elements(num_side_sets, num_elem_in_set, side_set_ids, & - total_side_sets_node_cnt_list, total_side_sets_node_list, & - exo_face) - end if - ! faces and elements are now all set - - ! Assemble the CoordinateMesh: - call allocate(mesh, num_nodes, num_elem, shape, name="CoordinateMesh") - call allocate(field, eff_dim, mesh, name="Coordinate") - - !!!!!!!!!!!!!!!!!!!!!!!!!! - ! Copy Node IDs to field ! - !!!!!!!!!!!!!!!!!!!!!!!!!! - call adding_nodes_to_field(eff_dim, num_nodes, node_map, node_coord, field) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Copy (only) Elements to the mesh ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! RegionIDs in fluidity are blockIDs in exodusII: - if (haveRegionIDs) then - allocate( field%mesh%region_ids(num_elem) ) - field%mesh%region_ids = 0 - end if - call adding_elements_to_field(num_dim, num_elem, exo_element, node_map, field) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Assemble array with faces and boundaryIDs ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate(sndglno(1:num_faces*sloc)) - sndglno=0 - if(haveBoundaries) then - allocate(boundaryIDs(1:num_faces)) - end if - do f=1, num_faces - sndglno((f-1)*sloc+1:f*sloc) = node_map(exo_face(f)%nodeIDs(1:sloc)) - if(haveBoundaries) boundaryIDs(f) = exo_face(f)%tags(1) - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Adding the face-elements to the mesh ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (haveBoundaries) then - call add_faces(field%mesh, sndgln = sndglno(1:num_faces*sloc), boundary_ids = boundaryIDs(1:num_faces)) - else - call add_faces(field%mesh, sndgln = sndglno(1:num_faces*sloc)) - end if - - ! At this point, the field 'CoordinateMesh' is assembled - - ! Deallocate arrays (exodusii arrays): - deallocate(coord_x); deallocate(coord_y); deallocate(coord_z) - deallocate(node_map); deallocate(elem_num_map); deallocate(elem_order_map); - deallocate(block_ids); deallocate(num_elem_in_block); deallocate(num_nodes_per_elem); - deallocate(elem_type) - deallocate(elem_connectivity); - - ! Deallocate other arrays: - deallocate(node_coord); deallocate(total_elem_node_list) - if (haveBoundaries) then - deallocate(side_set_ids); - deallocate(total_side_sets_elem_list); deallocate(total_side_sets_node_list) - deallocate(total_side_sets_node_cnt_list); deallocate(num_elem_in_set) - end if - deallocate(allelements) - deallocate(exo_element) - if (haveBoundaries) then - deallocate(exo_face) - end if - call deallocate( mesh ) - - if (haveBoundaries) then - deallocate(boundaryIDs) - end if - deallocate(sndglno) - - ewrite(2,*) "Out of read_exodusii_file_to_field" - - end function read_exodusii_file_to_field - - ! ----------------------------------------------------------------- - - subroutine get_block_param(exoid, lfilename, & - block_ids, & - num_elem_blk, & - num_elem_in_block, & - num_nodes_per_elem, & - elem_type) - ! This subroutine get block specific data from the mesh file, - ! e.g. the element type (Triangle/Quad/Tet/Hex...) - ! number of elements (and nodes per element) per block: - integer, intent(in) :: exoid - character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename - integer, dimension(:), intent(in) :: block_ids - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(inout) :: num_elem_in_block - integer, dimension(:), intent(inout) :: num_nodes_per_elem - integer, dimension(:), intent(inout) :: elem_type - - character(len=6) :: elem_type_char - integer, allocatable, dimension(:) :: num_attr - integer :: i, ierr - - ! Get block parameters: - allocate(num_attr(num_elem_blk)) - ! Loop over the blocks in the mesh and get block specific data: - do i=1, num_elem_blk - ierr = f_ex_get_elem_block(exoid, block_ids(i), elem_type_char, & - num_elem_in_block(i), & - num_nodes_per_elem(i), & - num_attr(i)) - ! assemble array to hold integers determining the element type - ! element type names in exodusii are: - ! Integer to element type relation (same as for gmsh): - ! 1: BAR2 (line) - ! 2: TRI3 (triangle) - ! 3: SHELL4 (quad) - ! 4: TETRA (tetrahedra) - ! 5: HEX8 (hexahedron) - ! assemble array to hold integers to identify element type of element block i: - if (trim(elem_type_char(1:4)) .eq. "BAR2") then - elem_type(i) = 1 - else if (trim(elem_type_char(1:4)) .eq. "TRI3") then - elem_type(i) = 2 - else if (trim(elem_type_char(1:6)) .eq. "SHELL4") then - elem_type(i) = 3 - else if (trim(elem_type_char(1:5)) .eq. "TETRA") then - elem_type(i) = 4 - else if (trim(elem_type_char(1:4)) .eq. "HEX8") then - elem_type(i) = 5 - else ! element type is not supported, give user an error - ewrite(-1,*) "Mesh file "//trim(lfilename)//": Fluidity does not support meshes with elements of type"//trim(elem_type_char(1:6))//". Please provide a mesh with Triangles, Shells, Tetrahedras or Hexahedrons." - FLExit("Element type of "//trim(elem_type_char(1:6))//" is not supported.") - end if - end do - if (ierr /= 0) then - FLExit("Unable to read in element block parameters from "//trim(lfilename)) - end if - deallocate(num_attr) - - end subroutine get_block_param - - ! ----------------------------------------------------------------- - - subroutine check_combination_face_element_types(num_dim, & - num_elem_blk, & - elem_type, & - lfilename, & - faceType) - ! This subroutine get block specific data from the mesh file, - ! e.g. the element type (Triangle/Quad/Tet/Hex...) - ! number of elements (and nodes per element) per block: - integer, intent(in) :: num_dim - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(in) :: elem_type - character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename - integer, intent(inout) :: faceType - - integer :: i, elementType - - elementType = 0; faceType = 0 - ! Practically looping over the blocks, and checking the combination of face/element types for - ! each block in the supplied mesh, plus exit if dimension of mesh is 1! - do i=1, num_elem_blk - ! 2D meshes: - if (num_dim == 2) then - if (elem_type(i) .ne. 1) then !then it's no edge, but either triangle or shell - if (elementType .ne. 0 .and. elementType .ne. elem_type(i)) then - ewrite(-1,*) "Mesh file "//trim(lfilename)//": You have generated a hybrid 2D mesh with Triangles and Shells which Fluidity does not support. Please choose either Triangles or Shells." - FLExit("Hybrid meshes are not supported by Fluidity.") - end if - end if - ! the face type of 2D meshes are obviously edges, aka type '1' - faceType = 1 - ! Now 3D meshes: - else if (num_dim == 3) then - if (elem_type(i) .ne. 2 .and. elem_type(i) .ne. 3) then !then it's not a triangle nor a shell - if (elementType .ne. 0 .and. elementType .ne. elem_type(i)) then - ewrite(-1,*) "Mesh file "//trim(lfilename)//": You have generated a hybrid 3D mesh with Tetrahedras and Hexahedrons which Fluidity does not support. Please choose either Tetrahedras or Hexahedrons." - FLExit("Hybrid meshes are not supported by Fluidity.") - end if - end if - if (elem_type(i) == 4) then ! tet - ! Set faceType for tets - faceType = 2 - else if (elem_type(i) == 5) then !hex - ! Set faceType for hexas - faceType = 3 - end if - elementType = elem_type(i) - else - ewrite(-1,*) "Mesh file "//trim(lfilename)//": Fluidity currently does not support 1D exodusII meshes. But you do NOT want to use fancy cubit to create a 1D mesh, do you? GMSH or other meshing tools can easily be used to generate 1D meshes" - FLExit("1D exodusII mesh files are not supported.") - end if - end do - - end subroutine check_combination_face_element_types - - ! ----------------------------------------------------------------- - - subroutine get_element_connectivity(exoid, & - block_ids, & - num_elem_blk, & - num_nodes_per_elem, & - num_elem_in_block, & - lfilename, & - elem_connectivity) - ! This subroutine gets the element connectivity of the given mesh file - integer, intent(in) :: exoid - integer, dimension(:), intent(in) :: block_ids - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(in) :: num_nodes_per_elem - integer, dimension(:), intent(in) :: num_elem_in_block - character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename - integer, dimension(:), allocatable, intent(inout) :: elem_connectivity - - integer, dimension(:), allocatable :: elem_blk_connectivity - integer :: i, ierr + function read_exodusii_simple(filename, quad_degree, & + quad_ngi, quad_family ) result (field) + !!< A simpler mechanism for reading an ExodusII file into a field. + character(len=*), intent(in) :: filename + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_degree + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_ngi + !! What quadrature family to use + integer, intent(in), optional :: quad_family + type(vector_field) :: field + type(quadrature_type) :: quad + type(element_type) :: shape + integer :: dim, loc + + ewrite(1,*) "In read_exodusii_simple" + + if(isparallel()) then + !call identify_exodusii_file(parallel_filename(filename), dim, loc) + FLExit("Currently we cannot read in a decomposed Exodus mesh file") + else + call identify_exodusii_file(filename, dim, loc) + end if + + if (present(quad_degree)) then + quad = make_quadrature(loc, dim, degree=quad_degree, family=quad_family) + else if (present(quad_ngi)) then + quad = make_quadrature(loc, dim, ngi=quad_ngi, family=quad_family) + else + FLAbort("Need to specify either quadrature degree or ngi") + end if + + shape=make_element_shape(loc, dim, 1, quad) + + field=read_exodusii_file(filename, shape) + + call deallocate(shape) + call deallocate(quad) + + ewrite(2,*) "Out of read_exodusii_simple" + + end function read_exodusii_simple + + ! ----------------------------------------------------------------- + ! ExodusII version of gmsh/triangle equivalent. + subroutine identify_exodusii_file(filename, numDimenOut, locOut, & + numElementsOut, boundaryFlagOut) + ! Discover the dimension and size of the ExodusII mesh. + ! Filename is the base name of the file without the + ! ExodusII extension .e .exo .E .EXO + + character(len=*), intent(in) :: filename + + !! Number of vertices of elements. + integer, intent(out), optional :: numDimenOut, locOut + integer, intent(out), optional :: numElementsOut + integer, intent(out), optional :: boundaryFlagOut + + integer :: boundaryFlag + + logical :: fileExists + + integer :: exoid, ierr + real(kind=c_float) :: version + integer(kind=c_int) :: comp_ws, io_ws, mode + character(kind=c_char, len=OPTION_PATH_LEN) :: lfilename + + character(kind=c_char, len=OPTION_PATH_LEN) :: title + integer :: num_dim, num_nodes, num_allelem, num_elem_blk + integer :: num_node_sets, num_side_sets + integer, allocatable, dimension(:) :: block_ids, num_elem_in_block, num_nodes_per_elem + + ewrite(1,*) "In identify_exodusii_file" + + call get_exodusii_filename(filename, lfilename, fileExists) + if(.not. fileExists) then + FLExit("None of the possible ExodusII files "//trim(filename)//".exo /.e /.EXO /.E were found") + end if + + ewrite(2, *) "Opening " // trim(lfilename) // " for reading in database parameters" + + version = 0.0 + mode = 0; comp_ws=0; io_ws=0; + exoid = f_read_ex_open(trim(lfilename)//C_NULL_CHAR, mode, comp_ws, io_ws, version) + + if (exoid <= 0) then + FLExit("Unable to open "//trim(lfilename)) + end if + + ! Get database parameters from exodusII file + ierr = f_ex_get_init(exoid, title, num_dim, num_nodes, & + num_allelem, num_elem_blk, num_node_sets, & + num_side_sets) + if (ierr /= 0) then + FLExit("Unable to read database parameters from "//trim(lfilename)) + end if + + ! Check for boundaries (internal boundaries currently not supported): + if (num_side_sets /= 0) then + boundaryFlag = 1 ! physical boundaries found + else + boundaryFlag = 0 ! no physical boundaries defined + end if + + ! Get num_nodes_per_elem + allocate(block_ids(num_elem_blk)) + allocate(num_elem_in_block(num_elem_blk)) + allocate(num_nodes_per_elem(num_elem_blk)) + ierr = f_ex_get_elem_block_parameters(exoid, num_elem_blk, block_ids, num_elem_in_block, num_nodes_per_elem) + if (ierr /= 0) then + FLExit("Unable to read in block parameters from "//trim(lfilename)) + end if + + ierr = f_ex_close(exoid) + if (ierr /= 0) then + FLExit("Unable to close file "//trim(lfilename)) + end if + + ! Return optional variables requested + if(present(numDimenOut)) numDimenOut=num_dim + ! numElementsOut is set to be the total number of volume and surface + ! elements in the exodusII mesh, as only that is stored in the header + ! of the mesh file. In Fluidity, only the volume elements of the mesh + ! file are taken into account. Thus the actual number of volume + ! elements is computed when the CoordinateMesh is assembled. + if(present(numElementsOut)) numElementsOut=num_allelem + ! Here we assume all (volume) elements of the mesh have the same + ! number of vertices/nodes. Since the exodusII mesh could contain + ! surface elements (as described above) we set locOut to be the + ! max number of nodes per elements. Checking for hybrid meshes, + ! that are currently not supported in Fluidity, is done when + ! assembling the CoordinateMesh. + if(present(locOut)) locOut=maxval(num_nodes_per_elem) + if(present(boundaryFlagOut)) boundaryFlagOut=boundaryFlag + + ewrite(2,*) "Out of identify_exodusii_file" + + end subroutine identify_exodusii_file + + ! ----------------------------------------------------------------- + ! The main function for reading ExodusII files + function read_exodusii_file_to_field(filename, shape) result (field) + character(len=*), intent(in) :: filename + type(element_type), intent(in), target :: shape + type(vector_field) :: field + type(mesh_type) :: mesh + + logical :: fileExists + logical :: haveRegionIDs, haveBoundaries + + type(EXOelement), pointer :: exo_element(:), exo_face(:), allelements(:) + + ! exodusii lib basic variables: + integer :: exoid, ierr + real(kind=c_float) :: version + integer(kind=c_int) :: comp_ws, io_ws, mode + character(kind=c_char, len=OPTION_PATH_LEN) :: lfilename + character(kind=c_char, len=OPTION_PATH_LEN) :: title + integer :: num_dim, num_nodes, num_allelem, num_elem_blk + integer :: num_node_sets, num_side_sets + + ! exodusii lib variables: + real(kind=c_float), allocatable, dimension(:) :: coord_x, coord_y, coord_z + integer, allocatable, dimension(:) :: node_map, elem_num_map, elem_order_map + integer, allocatable, dimension(:) :: block_ids, num_elem_in_block, num_nodes_per_elem + integer, allocatable, dimension(:) :: elem_type, elem_connectivity + integer, allocatable, dimension(:) :: side_set_ids, num_elem_in_set + integer, allocatable, dimension(:) :: total_side_sets_node_list, total_side_sets_elem_list + integer, allocatable, dimension(:) :: total_side_sets_node_cnt_list + + ! variables for conversion to fluidity structure: + real(c_float), allocatable, dimension(:,:) :: node_coord + integer, allocatable, dimension(:) :: total_elem_node_list + integer, allocatable, dimension(:) :: sndglno, boundaryIDs + + integer :: num_faces, num_elem, faceType + integer :: loc, sloc + integer :: eff_dim, f, gdim + + ewrite(1,*) "In read_exodusii_file_to_field" + + ! First of all: Identify the filename: + call get_exodusii_filename(filename, lfilename, fileExists) + if(.not. fileExists) then + FLExit("None of the possible ExodusII files "//trim(filename)//".exo /.e /.EXO /.E were found") + end if + + ewrite(2, *) "Opening " // trim(lfilename) // " for reading in the mesh" + + version = 0.0 + mode = 0; comp_ws=0; io_ws=0; + exoid = f_read_ex_open(trim(lfilename)//C_NULL_CHAR, mode, comp_ws, io_ws, version) + + if (exoid <= 0) then + FLExit("Unable to open "//trim(lfilename)) + end if + + ! Get database parameters from exodusII file + ierr = f_ex_get_init(exoid, title, num_dim, num_nodes, & + num_allelem, num_elem_blk, num_node_sets, & + num_side_sets) + if (ierr /= 0) then + FLExit("Unable to read database parameters from "//trim(lfilename)) + end if + + ! Catch user mistake of setting node sets instead of side sets: + ! Give the user an error message, since node sets are not supported here, only side sets: + if (num_node_sets > 0) then + ! Maybe a warning might be better here, instead of FLExit: + ewrite(-1,*) "You have specified node sets on your ExodusII meshfile '"//trim(lfilename)//"' but node sets are not supported by Fluidity. Please set your boundary conditions as side sets" + FLExit("Node sets are not supported by Fluidity, use side sets instead.") + end if + + ! read nodal coordinates values and names from database + allocate(coord_x(num_nodes)) + allocate(coord_y(num_nodes)) + allocate(coord_z(num_nodes)) + coord_x=0.0; coord_y=0.0; coord_z=0.0 + ! Get coordinates from the mesh: + ierr = f_ex_get_coord(exoid, coord_x, coord_y, coord_z) + if (ierr /= 0) then + FLExit("Unable to read in node coordinates "//trim(lfilename)) + end if + + ! Read node number map: + allocate(node_map(num_nodes)) + ierr = f_ex_get_node_num_map(exoid, node_map) + if (ierr /= 0) then + FLExit("Unable to read in node number map from "//trim(lfilename)) + end if + + ! read element number map + allocate(elem_num_map(num_allelem)) + elem_num_map = 0 + ierr = f_ex_get_elem_num_map(exoid, elem_num_map) + if (ierr /= 0) then + FLExit("Unable to read in element number map "//trim(lfilename)) + end if + + ! read element order map + allocate(elem_order_map(num_allelem)) + elem_order_map = 0 + ierr = f_ex_get_elem_order_map(exoid, elem_order_map) + if (ierr /= 0) then + FLExit("Unable to read in element order map "//trim(lfilename)) + end if + + ! Get block ids: + allocate(block_ids(num_elem_blk)) + ierr = f_ex_get_elem_blk_ids(exoid, block_ids) + if (ierr /= 0) then + FLExit("Unable to read in element block ids from "//trim(lfilename)) + end if + + ! Get block parameters: + allocate(num_elem_in_block(num_elem_blk)) + allocate(num_nodes_per_elem(num_elem_blk)) + allocate(elem_type(num_elem_blk)) + call get_block_param(exoid, lfilename, block_ids, num_elem_blk, num_elem_in_block, num_nodes_per_elem, elem_type) + + ! Get faceType and give the user an error if he supplied a mesh with an unsupported combination of element types: + call check_combination_face_element_types(num_dim, num_elem_blk, elem_type, lfilename, faceType) + + ! read element connectivity: + allocate(elem_connectivity(0)) + call get_element_connectivity(exoid, block_ids, num_elem_blk, num_nodes_per_elem, num_elem_in_block, lfilename, elem_connectivity) + + ! Initialize logical variables: + ! We have RegionIDs when there are blockIDs assigned to elements + ! so basically always when supplying an exodusII mesh, as an blockID is assigned + ! to all elements of the mesh if the user does not specify an blockID manually + haveRegionIDs = .true. ! redundant for reasons stated above, but kept here to keep it consistent with gmshreader for now + ! Boundaries: Boundaries are present if at least one side-set was supplied by the user: + if (num_side_sets .gt. 0) then + haveBoundaries = .true. + else + haveBoundaries = .false. + end if + ! Get side sets + ! Side sets in exodusii are what physical lines/surfaces are in gmsh (so basically boundary-IDs) + ! Allocate arrays for the side sets: + ! Get Side SetIDs and parameters: + if (haveBoundaries) then + allocate(side_set_ids(num_side_sets)) + allocate(num_elem_in_set(num_side_sets)) ! There are the same # of elements as sides in a side set + ! Allocate return arrays of the subroutine get_side_set_param: + allocate(total_side_sets_elem_list(0)); allocate(total_side_sets_node_list(0)); allocate(total_side_sets_node_cnt_list(0)) + call get_side_set_param(exoid, num_side_sets, lfilename, side_set_ids, num_elem_in_set, total_side_sets_elem_list, total_side_sets_node_list, total_side_sets_node_cnt_list) + end if + + ! Close ExodusII meshfile + ierr = f_ex_close(exoid) + if (ierr /= 0) then + FLExit("Unable close file "//trim(lfilename)) + end if + + + !--------------------------------- + ! At this point, all relevant data has been read in from the exodusii file + ! Now construct within Fluidity data structures + + if( have_option("/geometry/spherical_earth/") ) then + call get_option('/geometry/dimension', gdim) + eff_dim = gdim + else + eff_dim = num_dim + end if + + ! Reorder element node numbering (if necessary): + ! (allows for different element types) + call reorder_node_numbering(num_elem_blk, num_nodes_per_elem, num_elem_in_block, elem_connectivity, elem_type, total_elem_node_list) + + ! check if number of vertices/nodes are consistent with shape + loc = maxval(num_nodes_per_elem) + assert(loc==shape%loc) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Coordinates ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Loop around nodes copying across coords + ! First, assemble array containing all node coordinates: + allocate(node_coord(eff_dim, num_nodes)) + node_coord = 0 + node_coord(1,:) = coord_x(:) + if (eff_dim .eq. 2 .or. eff_dim .eq. 3) then + node_coord(2,:) = coord_y(:) + end if + if (eff_dim .eq. 3) then + node_coord(3,:) = coord_z(:) + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Assemble allelements (without faces) ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(allelements(num_allelem)) + call assemble_allelements(num_elem_blk, block_ids, num_elem_in_block, & + num_nodes_per_elem, elem_order_map, elem_type, & + total_elem_node_list, allelements) + ! At this stage 'allelements' contains all elements (faces and elements) of all blocks of the mesh + ! Now, in case we have side sets/boundary ids in the mesh, assigns those ids to allelements: + if (haveBoundaries) then + call allelements_add_boundary_ids(num_side_sets, num_elem_in_set, total_side_sets_elem_list, side_set_ids, allelements) + end if + ! At this stage, the elements of 'allelements' have been correctly tagged, + ! meaning they carry the side set ID(s) as tags, which later will + ! become the boundary ID of their face(s) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Identify Faces ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Now faces: + ! First of all: Face elements in the mesh (-file) are neglected, thus get the + ! number of elements (-minus number of face-elements in the mesh), + ! and by 'elements' we mean no edges/faces in 2D/3D. + ! And then subtract the amount of elements that carry at least one side-set-id + ! In 2D: Faces are lines/edges + ! In 3D: Faces are surfaces + ! Find total number of such faces in all blocks + ! loop over blocks, check for element type in block i, + ! and depending on the mesh dimension, determine if element e is a face or element + ! This does not support a 1D mesh, + ! because you do NOT want to use fancy cubit to create a 1D mesh, do you?! + ! Get number of elements and faces in the mesh: + num_elem = 0; num_faces = 0 + sloc = 0 + call get_num_elem(num_dim, num_elem_blk, elem_type, num_elem_in_block, num_elem) + + ! Set sloc based on faceType: + ! Only faceTypes 1, 2, and 3 are allowed (see above), their corresponding sloc is faceType+1, + ! e.g. if faceType = 2 (triangle), it should have 3 nodes, which is faceType+1 + sloc = faceType+1 + ! Now check for site-set-id/physical-id, if element has numTags>0, + ! than an edge/face will be generated next to that element, + ! and the element's side-set-ID will be assigned to the newly generated edge/face + if (haveBoundaries) then + call get_num_faces(num_allelem, allelements, num_faces) + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Setting Elements and faces ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Now actually set the elements and face-elements: + ! assemble array with faces (exo_face contains element number (=element id of mesh)) + allocate(exo_element(num_elem)) + call assemble_actual_elements(num_dim, num_elem_blk, num_elem_in_block, elem_type, allElements, exo_element) + + + ! Now derive the faces for fluidity, that are based on elements with side-set-ID: + if (haveBoundaries) then + allocate(exo_face(num_faces)) + call assemble_actual_face_elements(num_side_sets, num_elem_in_set, side_set_ids, & + total_side_sets_node_cnt_list, total_side_sets_node_list, & + exo_face) + end if + ! faces and elements are now all set + + ! Assemble the CoordinateMesh: + call allocate(mesh, num_nodes, num_elem, shape, name="CoordinateMesh") + call allocate(field, eff_dim, mesh, name="Coordinate") + + !!!!!!!!!!!!!!!!!!!!!!!!!! + ! Copy Node IDs to field ! + !!!!!!!!!!!!!!!!!!!!!!!!!! + call adding_nodes_to_field(eff_dim, num_nodes, node_map, node_coord, field) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Copy (only) Elements to the mesh ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! RegionIDs in fluidity are blockIDs in exodusII: + if (haveRegionIDs) then + allocate( field%mesh%region_ids(num_elem) ) + field%mesh%region_ids = 0 + end if + call adding_elements_to_field(num_dim, num_elem, exo_element, node_map, field) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Assemble array with faces and boundaryIDs ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(sndglno(1:num_faces*sloc)) + sndglno=0 + if(haveBoundaries) then + allocate(boundaryIDs(1:num_faces)) + end if + do f=1, num_faces + sndglno((f-1)*sloc+1:f*sloc) = node_map(exo_face(f)%nodeIDs(1:sloc)) + if(haveBoundaries) boundaryIDs(f) = exo_face(f)%tags(1) + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Adding the face-elements to the mesh ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (haveBoundaries) then + call add_faces(field%mesh, sndgln = sndglno(1:num_faces*sloc), boundary_ids = boundaryIDs(1:num_faces)) + else + call add_faces(field%mesh, sndgln = sndglno(1:num_faces*sloc)) + end if + + ! At this point, the field 'CoordinateMesh' is assembled + + ! Deallocate arrays (exodusii arrays): + deallocate(coord_x); deallocate(coord_y); deallocate(coord_z) + deallocate(node_map); deallocate(elem_num_map); deallocate(elem_order_map); + deallocate(block_ids); deallocate(num_elem_in_block); deallocate(num_nodes_per_elem); + deallocate(elem_type) + deallocate(elem_connectivity); + + ! Deallocate other arrays: + deallocate(node_coord); deallocate(total_elem_node_list) + if (haveBoundaries) then + deallocate(side_set_ids); + deallocate(total_side_sets_elem_list); deallocate(total_side_sets_node_list) + deallocate(total_side_sets_node_cnt_list); deallocate(num_elem_in_set) + end if + deallocate(allelements) + deallocate(exo_element) + if (haveBoundaries) then + deallocate(exo_face) + end if + call deallocate( mesh ) + + if (haveBoundaries) then + deallocate(boundaryIDs) + end if + deallocate(sndglno) + + ewrite(2,*) "Out of read_exodusii_file_to_field" + + end function read_exodusii_file_to_field + + ! ----------------------------------------------------------------- + + subroutine get_block_param(exoid, lfilename, & + block_ids, & + num_elem_blk, & + num_elem_in_block, & + num_nodes_per_elem, & + elem_type) + ! This subroutine get block specific data from the mesh file, + ! e.g. the element type (Triangle/Quad/Tet/Hex...) + ! number of elements (and nodes per element) per block: + integer, intent(in) :: exoid + character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename + integer, dimension(:), intent(in) :: block_ids + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(inout) :: num_elem_in_block + integer, dimension(:), intent(inout) :: num_nodes_per_elem + integer, dimension(:), intent(inout) :: elem_type + + character(len=6) :: elem_type_char + integer, allocatable, dimension(:) :: num_attr + integer :: i, ierr + + ! Get block parameters: + allocate(num_attr(num_elem_blk)) + ! Loop over the blocks in the mesh and get block specific data: + do i=1, num_elem_blk + ierr = f_ex_get_elem_block(exoid, block_ids(i), elem_type_char, & + num_elem_in_block(i), & + num_nodes_per_elem(i), & + num_attr(i)) + ! assemble array to hold integers determining the element type + ! element type names in exodusii are: + ! Integer to element type relation (same as for gmsh): + ! 1: BAR2 (line) + ! 2: TRI3 (triangle) + ! 3: SHELL4 (quad) + ! 4: TETRA (tetrahedra) + ! 5: HEX8 (hexahedron) + ! assemble array to hold integers to identify element type of element block i: + if (trim(elem_type_char(1:4)) .eq. "BAR2") then + elem_type(i) = 1 + else if (trim(elem_type_char(1:4)) .eq. "TRI3") then + elem_type(i) = 2 + else if (trim(elem_type_char(1:6)) .eq. "SHELL4") then + elem_type(i) = 3 + else if (trim(elem_type_char(1:5)) .eq. "TETRA") then + elem_type(i) = 4 + else if (trim(elem_type_char(1:4)) .eq. "HEX8") then + elem_type(i) = 5 + else ! element type is not supported, give user an error + ewrite(-1,*) "Mesh file "//trim(lfilename)//": Fluidity does not support meshes with elements of type"//trim(elem_type_char(1:6))//". Please provide a mesh with Triangles, Shells, Tetrahedras or Hexahedrons." + FLExit("Element type of "//trim(elem_type_char(1:6))//" is not supported.") + end if + end do + if (ierr /= 0) then + FLExit("Unable to read in element block parameters from "//trim(lfilename)) + end if + deallocate(num_attr) + + end subroutine get_block_param + + ! ----------------------------------------------------------------- + + subroutine check_combination_face_element_types(num_dim, & + num_elem_blk, & + elem_type, & + lfilename, & + faceType) + ! This subroutine get block specific data from the mesh file, + ! e.g. the element type (Triangle/Quad/Tet/Hex...) + ! number of elements (and nodes per element) per block: + integer, intent(in) :: num_dim + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(in) :: elem_type + character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename + integer, intent(inout) :: faceType + + integer :: i, elementType + + elementType = 0; faceType = 0 + ! Practically looping over the blocks, and checking the combination of face/element types for + ! each block in the supplied mesh, plus exit if dimension of mesh is 1! + do i=1, num_elem_blk + ! 2D meshes: + if (num_dim == 2) then + if (elem_type(i) .ne. 1) then !then it's no edge, but either triangle or shell + if (elementType .ne. 0 .and. elementType .ne. elem_type(i)) then + ewrite(-1,*) "Mesh file "//trim(lfilename)//": You have generated a hybrid 2D mesh with Triangles and Shells which Fluidity does not support. Please choose either Triangles or Shells." + FLExit("Hybrid meshes are not supported by Fluidity.") + end if + end if + ! the face type of 2D meshes are obviously edges, aka type '1' + faceType = 1 + ! Now 3D meshes: + else if (num_dim == 3) then + if (elem_type(i) .ne. 2 .and. elem_type(i) .ne. 3) then !then it's not a triangle nor a shell + if (elementType .ne. 0 .and. elementType .ne. elem_type(i)) then + ewrite(-1,*) "Mesh file "//trim(lfilename)//": You have generated a hybrid 3D mesh with Tetrahedras and Hexahedrons which Fluidity does not support. Please choose either Tetrahedras or Hexahedrons." + FLExit("Hybrid meshes are not supported by Fluidity.") + end if + end if + if (elem_type(i) == 4) then ! tet + ! Set faceType for tets + faceType = 2 + else if (elem_type(i) == 5) then !hex + ! Set faceType for hexas + faceType = 3 + end if + elementType = elem_type(i) + else + ewrite(-1,*) "Mesh file "//trim(lfilename)//": Fluidity currently does not support 1D exodusII meshes. But you do NOT want to use fancy cubit to create a 1D mesh, do you? GMSH or other meshing tools can easily be used to generate 1D meshes" + FLExit("1D exodusII mesh files are not supported.") + end if + end do + + end subroutine check_combination_face_element_types + + ! ----------------------------------------------------------------- + + subroutine get_element_connectivity(exoid, & + block_ids, & + num_elem_blk, & + num_nodes_per_elem, & + num_elem_in_block, & + lfilename, & + elem_connectivity) + ! This subroutine gets the element connectivity of the given mesh file + integer, intent(in) :: exoid + integer, dimension(:), intent(in) :: block_ids + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(in) :: num_nodes_per_elem + integer, dimension(:), intent(in) :: num_elem_in_block + character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename + integer, dimension(:), allocatable, intent(inout) :: elem_connectivity + + integer, dimension(:), allocatable :: elem_blk_connectivity + integer :: i, ierr do i=1, num_elem_blk ! Get element connectivity of block 'i' and append to global element connectivity: @@ -679,220 +679,220 @@ subroutine get_element_connectivity(exoid, & FLExit("Unable to read in element connectivity from "//trim(lfilename)) end if - end subroutine get_element_connectivity - - ! ----------------------------------------------------------------- - - subroutine get_side_set_param(exoid, & - num_side_sets, & - lfilename, & - side_set_ids, & - num_elem_in_set, & - total_side_sets_elem_list, & - total_side_sets_node_list, & - total_side_sets_node_cnt_list) - integer, intent(in) :: exoid - integer, intent(in) :: num_side_sets - character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename - integer, dimension(:), intent(inout) :: side_set_ids - integer, dimension(:), intent(inout) :: num_elem_in_set - integer, allocatable, dimension(:), intent(inout) :: total_side_sets_elem_list - integer, allocatable, dimension(:), intent(inout) :: total_side_sets_node_list - integer, allocatable, dimension(:), intent(inout) :: total_side_sets_node_cnt_list - - - integer, allocatable, dimension(:) :: num_sides_in_set, num_df_in_set - integer, allocatable, dimension(:) :: side_set_node_list, side_set_side_list - integer, allocatable, dimension(:) :: side_set_elem_list, side_set_node_cnt_list - integer, allocatable, dimension(:) :: elem_node_list - - integer :: i, e, n, ierr - ! This subroutine gives back side set related data - - allocate(num_sides_in_set(num_side_sets)); allocate(num_df_in_set(num_side_sets)); - side_set_ids=0; num_sides_in_set=0; num_df_in_set=0; - ierr = f_ex_get_side_set_ids(exoid, side_set_ids); - if (ierr /= 0) then - ewrite(2,*) "No side sets found in "//trim(lfilename) - end if + end subroutine get_element_connectivity + + ! ----------------------------------------------------------------- + + subroutine get_side_set_param(exoid, & + num_side_sets, & + lfilename, & + side_set_ids, & + num_elem_in_set, & + total_side_sets_elem_list, & + total_side_sets_node_list, & + total_side_sets_node_cnt_list) + integer, intent(in) :: exoid + integer, intent(in) :: num_side_sets + character(kind=c_char, len=OPTION_PATH_LEN), intent(in) :: lfilename + integer, dimension(:), intent(inout) :: side_set_ids + integer, dimension(:), intent(inout) :: num_elem_in_set + integer, allocatable, dimension(:), intent(inout) :: total_side_sets_elem_list + integer, allocatable, dimension(:), intent(inout) :: total_side_sets_node_list + integer, allocatable, dimension(:), intent(inout) :: total_side_sets_node_cnt_list + + + integer, allocatable, dimension(:) :: num_sides_in_set, num_df_in_set + integer, allocatable, dimension(:) :: side_set_node_list, side_set_side_list + integer, allocatable, dimension(:) :: side_set_elem_list, side_set_node_cnt_list + integer, allocatable, dimension(:) :: elem_node_list + + integer :: i, e, n, ierr + ! This subroutine gives back side set related data + + allocate(num_sides_in_set(num_side_sets)); allocate(num_df_in_set(num_side_sets)); + side_set_ids=0; num_sides_in_set=0; num_df_in_set=0; + ierr = f_ex_get_side_set_ids(exoid, side_set_ids); + if (ierr /= 0) then + ewrite(2,*) "No side sets found in "//trim(lfilename) + end if ! Get side set parameters: - do i=1, num_side_sets - ierr = f_ex_get_side_set_param(exoid, side_set_ids(i), num_sides_in_set(i), num_df_in_set(i)); - end do - if (ierr /= 0) then - FLExit("Unable to read in the side set parameters from "//trim(lfilename)) - end if - - num_elem_in_set = num_sides_in_set; ! There are as many elements in a side set, as there are sides in a side set - ! Now let's finally get the side-set-ids! - do i=1, num_side_sets - ! Reset the node index to 1 for the ith side set: - n = 1 - ! Arrays for side list and element list of side sets: - allocate(side_set_elem_list(num_elem_in_set(i))); allocate(side_set_side_list(num_sides_in_set(i))) - ! Arrays needed to obtain the node list: - allocate(side_set_node_list(num_df_in_set(i))); allocate(side_set_node_cnt_list(num_elem_in_set(i))) - - ! Get side set ids, element list, side list - ierr = f_ex_get_side_set(exoid, side_set_ids(i), side_set_elem_list, side_set_side_list) - ! Get side set node list: - ierr = f_ex_get_side_set_node_list(exoid, side_set_ids(i), side_set_node_cnt_list, side_set_node_list) - - ! In case the present element is a hexahedron, its face should be a quad... otherwise sth seriously went wrong - ! Thus, renumber the node list of that quad before adding the node list to the global array: - do e=1, num_elem_in_set(i) - if (side_set_node_cnt_list(e) == 4) then - allocate(elem_node_list(side_set_node_cnt_list(e))) - ! Copy relevant nodes to a tmp array: - elem_node_list(:) = side_set_node_list( n : n+side_set_node_cnt_list(e)-1 ) - ! Renumber the local node list of that face - call toFluidityElementNodeOrdering( elem_node_list, 3 ) - ! After renumbering the face-nodes, copy them back into side_set_node_list: - side_set_node_list( n : n+side_set_node_cnt_list(e)-1 ) = elem_node_list(:) - deallocate(elem_node_list) - end if - ! Increase the node-index by number of nodes in element e of side-set i - n = n + side_set_node_cnt_list(e) - end do - - ! append the side set element list in global array for later: - call append_array(total_side_sets_elem_list, side_set_elem_list) - call append_array(total_side_sets_node_list, side_set_node_list) - call append_array(total_side_sets_node_cnt_list, side_set_node_cnt_list) - deallocate(side_set_elem_list); deallocate(side_set_side_list) - deallocate(side_set_node_list); deallocate(side_set_node_cnt_list) - end do - - ! Deallocate whatever we do not need anymore: - deallocate(num_sides_in_set); deallocate(num_df_in_set) - - end subroutine get_side_set_param - - ! ----------------------------------------------------------------- - - subroutine reorder_node_numbering(num_elem_blk, & - num_nodes_per_elem, & - num_elem_in_block, & - elem_connectivity, & - elem_type, & - total_elem_node_list) - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(in) :: num_nodes_per_elem - integer, dimension(:), intent(in) :: num_elem_in_block - integer, dimension(:), intent(in) :: elem_connectivity - integer, dimension(:), intent(in) :: elem_type - integer, allocatable, dimension(:), intent(inout) :: total_elem_node_list - - integer, allocatable, dimension(:) :: elem_node_list - - integer :: i, e, n, z, total_size - - ! Get the total size of array total_elem_node_list - ! so that it can be allocated outside a loop - ! which gives us a massive speedup compared to dynamically - ! increasing the size of the array within the loop - total_size = 0 - do i=1, num_elem_blk - total_size = total_size + num_nodes_per_elem(i)*num_elem_in_block(i) - end do - ! Now we can allocate the array containing the node list of all elements - ! (all elements, meaning of the entire mesh, which is required for fluidity) - allocate(total_elem_node_list(total_size)) - - z = 0 - do i=1, num_elem_blk - ! assemble element node list as we go: - allocate(elem_node_list(num_nodes_per_elem(i))) - do e=1, num_elem_in_block(i) - do n=1, num_nodes_per_elem(i) - elem_node_list(n) = elem_connectivity(n + z) - end do - call toFluidityElementNodeOrdering( elem_node_list, elem_type(i) ) - ! Now append elem_node_list to total_elem_node_list - do n=1, num_nodes_per_elem(i) - total_elem_node_list(z+n) = elem_node_list(n) - end do - z = z + num_nodes_per_elem(i) - ! reset node list: - elem_node_list = 0 - end do - ! deallocate elem_node_list for next block - deallocate(elem_node_list) - end do - - end subroutine reorder_node_numbering - - ! ----------------------------------------------------------------- - - subroutine assemble_allelements(num_elem_blk, & - block_ids, & - num_elem_in_block, & - num_nodes_per_elem, & - elem_order_map, & - elem_type, & - total_elem_node_list, & - allelements) - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(in) :: block_ids - integer, dimension(:), intent(in) :: num_elem_in_block - integer, dimension(:), intent(in) :: num_nodes_per_elem - integer, dimension(:), intent(in) :: elem_order_map - integer, dimension(:), intent(in) :: elem_type - integer, dimension(:), intent(in) :: total_elem_node_list - type(EXOelement), pointer, dimension(:), intent(inout) :: allelements - - integer :: i, e, n, z, z2 - ! Subroutine to assemble a bucket full of element related data, - ! e.g. element id, which block id it belongs to, its element type, - ! its node ids. - ! This is done for all elements of the mesh, e.g. also for surface - ! elements of a 3D mesh. These surface elements won't be passed - ! to the fluidity structure later on, but are added to allelements - ! here. - ! Also: Potential boundaryID numbers are added in the seperate - ! subroutine 'allelements_add_boundary_ids'. - - ! Set elementIDs and blockIDs of to which the elements belong to - allelements(:)%elementID = 0.0; allelements(:)%blockID = 0.0 - allelements(:)%type = 0.0; allelements(:)%numTags = 0.0 - z=0; z2=0; - do i=1, num_elem_blk - do e=1, num_elem_in_block(i) - ! Set elementID: - allelements(e+z)%elementID = elem_order_map(e+z) - ! Set blockID of element e - allelements(e+z)%blockID = block_ids(i) - ! Set type of element: - allelements(e+z)%type = elem_type(i) - ! For nodeIDs: - allocate( allelements(e+z)%nodeIDs(num_nodes_per_elem(i)) ) - do n=1, num_nodes_per_elem(i) - ! copy the nodes of the element out of total_elem_node_list: - allelements(e+z)%nodeIDs(n) = total_elem_node_list(n+z2) - end do - z2 = z2+num_nodes_per_elem(i) - end do - z = z + num_elem_in_block(i) - end do - - end subroutine assemble_allelements - - ! ----------------------------------------------------------------- - - subroutine allelements_add_boundary_ids(num_side_sets, & - num_elem_in_set, & - total_side_sets_elem_list, & - side_set_ids, & - allelements) - integer, intent(in) :: num_side_sets - integer, dimension(:), intent(in) :: num_elem_in_set - integer, dimension(:), intent(in) :: total_side_sets_elem_list - integer, dimension(:), intent(in) :: side_set_ids - type(EXOelement), pointer, dimension(:), intent(inout) :: allelements - - integer :: elemID, num_tags_elem - integer :: e, i, j, z + do i=1, num_side_sets + ierr = f_ex_get_side_set_param(exoid, side_set_ids(i), num_sides_in_set(i), num_df_in_set(i)); + end do + if (ierr /= 0) then + FLExit("Unable to read in the side set parameters from "//trim(lfilename)) + end if + + num_elem_in_set = num_sides_in_set; ! There are as many elements in a side set, as there are sides in a side set + ! Now let's finally get the side-set-ids! + do i=1, num_side_sets + ! Reset the node index to 1 for the ith side set: + n = 1 + ! Arrays for side list and element list of side sets: + allocate(side_set_elem_list(num_elem_in_set(i))); allocate(side_set_side_list(num_sides_in_set(i))) + ! Arrays needed to obtain the node list: + allocate(side_set_node_list(num_df_in_set(i))); allocate(side_set_node_cnt_list(num_elem_in_set(i))) + + ! Get side set ids, element list, side list + ierr = f_ex_get_side_set(exoid, side_set_ids(i), side_set_elem_list, side_set_side_list) + ! Get side set node list: + ierr = f_ex_get_side_set_node_list(exoid, side_set_ids(i), side_set_node_cnt_list, side_set_node_list) + + ! In case the present element is a hexahedron, its face should be a quad... otherwise sth seriously went wrong + ! Thus, renumber the node list of that quad before adding the node list to the global array: + do e=1, num_elem_in_set(i) + if (side_set_node_cnt_list(e) == 4) then + allocate(elem_node_list(side_set_node_cnt_list(e))) + ! Copy relevant nodes to a tmp array: + elem_node_list(:) = side_set_node_list( n : n+side_set_node_cnt_list(e)-1 ) + ! Renumber the local node list of that face + call toFluidityElementNodeOrdering( elem_node_list, 3 ) + ! After renumbering the face-nodes, copy them back into side_set_node_list: + side_set_node_list( n : n+side_set_node_cnt_list(e)-1 ) = elem_node_list(:) + deallocate(elem_node_list) + end if + ! Increase the node-index by number of nodes in element e of side-set i + n = n + side_set_node_cnt_list(e) + end do + + ! append the side set element list in global array for later: + call append_array(total_side_sets_elem_list, side_set_elem_list) + call append_array(total_side_sets_node_list, side_set_node_list) + call append_array(total_side_sets_node_cnt_list, side_set_node_cnt_list) + deallocate(side_set_elem_list); deallocate(side_set_side_list) + deallocate(side_set_node_list); deallocate(side_set_node_cnt_list) + end do + + ! Deallocate whatever we do not need anymore: + deallocate(num_sides_in_set); deallocate(num_df_in_set) + + end subroutine get_side_set_param + + ! ----------------------------------------------------------------- + + subroutine reorder_node_numbering(num_elem_blk, & + num_nodes_per_elem, & + num_elem_in_block, & + elem_connectivity, & + elem_type, & + total_elem_node_list) + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(in) :: num_nodes_per_elem + integer, dimension(:), intent(in) :: num_elem_in_block + integer, dimension(:), intent(in) :: elem_connectivity + integer, dimension(:), intent(in) :: elem_type + integer, allocatable, dimension(:), intent(inout) :: total_elem_node_list + + integer, allocatable, dimension(:) :: elem_node_list + + integer :: i, e, n, z, total_size + + ! Get the total size of array total_elem_node_list + ! so that it can be allocated outside a loop + ! which gives us a massive speedup compared to dynamically + ! increasing the size of the array within the loop + total_size = 0 + do i=1, num_elem_blk + total_size = total_size + num_nodes_per_elem(i)*num_elem_in_block(i) + end do + ! Now we can allocate the array containing the node list of all elements + ! (all elements, meaning of the entire mesh, which is required for fluidity) + allocate(total_elem_node_list(total_size)) + + z = 0 + do i=1, num_elem_blk + ! assemble element node list as we go: + allocate(elem_node_list(num_nodes_per_elem(i))) + do e=1, num_elem_in_block(i) + do n=1, num_nodes_per_elem(i) + elem_node_list(n) = elem_connectivity(n + z) + end do + call toFluidityElementNodeOrdering( elem_node_list, elem_type(i) ) + ! Now append elem_node_list to total_elem_node_list + do n=1, num_nodes_per_elem(i) + total_elem_node_list(z+n) = elem_node_list(n) + end do + z = z + num_nodes_per_elem(i) + ! reset node list: + elem_node_list = 0 + end do + ! deallocate elem_node_list for next block + deallocate(elem_node_list) + end do + + end subroutine reorder_node_numbering + + ! ----------------------------------------------------------------- + + subroutine assemble_allelements(num_elem_blk, & + block_ids, & + num_elem_in_block, & + num_nodes_per_elem, & + elem_order_map, & + elem_type, & + total_elem_node_list, & + allelements) + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(in) :: block_ids + integer, dimension(:), intent(in) :: num_elem_in_block + integer, dimension(:), intent(in) :: num_nodes_per_elem + integer, dimension(:), intent(in) :: elem_order_map + integer, dimension(:), intent(in) :: elem_type + integer, dimension(:), intent(in) :: total_elem_node_list + type(EXOelement), pointer, dimension(:), intent(inout) :: allelements + + integer :: i, e, n, z, z2 + ! Subroutine to assemble a bucket full of element related data, + ! e.g. element id, which block id it belongs to, its element type, + ! its node ids. + ! This is done for all elements of the mesh, e.g. also for surface + ! elements of a 3D mesh. These surface elements won't be passed + ! to the fluidity structure later on, but are added to allelements + ! here. + ! Also: Potential boundaryID numbers are added in the seperate + ! subroutine 'allelements_add_boundary_ids'. + + ! Set elementIDs and blockIDs of to which the elements belong to + allelements(:)%elementID = 0.0; allelements(:)%blockID = 0.0 + allelements(:)%type = 0.0; allelements(:)%numTags = 0.0 + z=0; z2=0; + do i=1, num_elem_blk + do e=1, num_elem_in_block(i) + ! Set elementID: + allelements(e+z)%elementID = elem_order_map(e+z) + ! Set blockID of element e + allelements(e+z)%blockID = block_ids(i) + ! Set type of element: + allelements(e+z)%type = elem_type(i) + ! For nodeIDs: + allocate( allelements(e+z)%nodeIDs(num_nodes_per_elem(i)) ) + do n=1, num_nodes_per_elem(i) + ! copy the nodes of the element out of total_elem_node_list: + allelements(e+z)%nodeIDs(n) = total_elem_node_list(n+z2) + end do + z2 = z2+num_nodes_per_elem(i) + end do + z = z + num_elem_in_block(i) + end do + + end subroutine assemble_allelements + + ! ----------------------------------------------------------------- + + subroutine allelements_add_boundary_ids(num_side_sets, & + num_elem_in_set, & + total_side_sets_elem_list, & + side_set_ids, & + allelements) + integer, intent(in) :: num_side_sets + integer, dimension(:), intent(in) :: num_elem_in_set + integer, dimension(:), intent(in) :: total_side_sets_elem_list + integer, dimension(:), intent(in) :: side_set_ids + type(EXOelement), pointer, dimension(:), intent(inout) :: allelements + + integer :: elemID, num_tags_elem + integer :: e, i, j, z z=1; do i=1, num_side_sets @@ -904,9 +904,9 @@ subroutine allelements_add_boundary_ids(num_side_sets, & z = z+1 end do end do - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Setting tags to the elements with side-set-id ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Setting tags to the elements with side-set-id ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! z=1; do i=1, num_side_sets do e=1, num_elem_in_set(i) @@ -941,236 +941,236 @@ subroutine allelements_add_boundary_ids(num_side_sets, & end do end do - end subroutine allelements_add_boundary_ids - - ! ----------------------------------------------------------------- - - subroutine get_num_elem(num_dim, num_elem_blk, elem_type, num_elem_in_block, num_elem) - integer, intent(in) :: num_dim - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(in) :: elem_type - integer, dimension(:), intent(in) :: num_elem_in_block - integer, intent(inout) :: num_elem - - integer :: i - ! This subroutines computes the number of elements, which will be - ! included in the fluidity mesh, thus num_elem is the number of - ! elements of the mesh - the number of face-elements, e.g. - ! in a 3D mesh the number of tetrahedras minus the number of - ! triangles on surfaces. - - do i=1, num_elem_blk - if (num_dim .eq. 2) then - if (elem_type(i) .eq. 2 .or. elem_type(i) .eq. 3) then - ! this is an element: - num_elem = num_elem + num_elem_in_block(i) - end if - else if (num_dim .eq. 3) then - if ( elem_type(i) .eq. 4 .or. elem_type(i) .eq. 5 ) then - ! this is an element: - num_elem = num_elem + num_elem_in_block(i) - end if - end if - end do - - end subroutine get_num_elem - - ! ----------------------------------------------------------------- - - subroutine get_num_faces(num_allelem, allelements, num_faces) - integer, intent(in) :: num_allelem - type(EXOelement), pointer, dimension(:), intent(in) :: allelements - integer, intent(inout) :: num_faces - - integer :: i, elemID, num_tags_elem - ! This subroutines computes the number of faces, which will be - ! included in the fluidity mesh. These are the elements of the mesh - ! which have a boundary ID/side set ID assigned to them. - - do i=1, num_allelem - elemID = allelements(i)%elementID - num_tags_elem = allelements(elemID)%numTags - ! Is there at least one site set ID assigned to the element, it is a face: - if (num_tags_elem > 0) then - ! increase number of faces in the mesh... - num_faces = num_faces + num_tags_elem - end if - end do - - end subroutine get_num_faces - - ! ----------------------------------------------------------------- - - subroutine assemble_actual_elements(num_dim, num_elem_blk, num_elem_in_block, elem_type, allElements, exo_element) - integer, intent(in) :: num_dim - integer, intent(in) :: num_elem_blk - integer, dimension(:), intent(in) :: num_elem_in_block - integer, dimension(:), intent(in) :: elem_type - type(EXOelement), pointer, dimension(:), intent(in) :: allelements - type(EXOelement), pointer, dimension(:), intent(inout) :: exo_element - - integer :: b, e, i, exo_e - ! This subroutine assembles a bucket (called exo_element) which corresponds - ! to the actual elements of the mesh, meaning in a 3D mesh only to the volume - ! elements, and in a 2D mesh only to the surface elements. For each elements - ! that matches this description, the elementID, the block ID the element belongs - ! to, its node IDs, and the element type are stored in this bucket. - - b=0; exo_e=1 - do i=1, num_elem_blk - do e=1, num_elem_in_block(i) - ! Distinguish between faces/edges and elements: - if( .not. ( (num_dim .eq. 2 .and. elem_type(i) .eq. 1) .or. & + end subroutine allelements_add_boundary_ids + + ! ----------------------------------------------------------------- + + subroutine get_num_elem(num_dim, num_elem_blk, elem_type, num_elem_in_block, num_elem) + integer, intent(in) :: num_dim + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(in) :: elem_type + integer, dimension(:), intent(in) :: num_elem_in_block + integer, intent(inout) :: num_elem + + integer :: i + ! This subroutines computes the number of elements, which will be + ! included in the fluidity mesh, thus num_elem is the number of + ! elements of the mesh - the number of face-elements, e.g. + ! in a 3D mesh the number of tetrahedras minus the number of + ! triangles on surfaces. + + do i=1, num_elem_blk + if (num_dim .eq. 2) then + if (elem_type(i) .eq. 2 .or. elem_type(i) .eq. 3) then + ! this is an element: + num_elem = num_elem + num_elem_in_block(i) + end if + else if (num_dim .eq. 3) then + if ( elem_type(i) .eq. 4 .or. elem_type(i) .eq. 5 ) then + ! this is an element: + num_elem = num_elem + num_elem_in_block(i) + end if + end if + end do + + end subroutine get_num_elem + + ! ----------------------------------------------------------------- + + subroutine get_num_faces(num_allelem, allelements, num_faces) + integer, intent(in) :: num_allelem + type(EXOelement), pointer, dimension(:), intent(in) :: allelements + integer, intent(inout) :: num_faces + + integer :: i, elemID, num_tags_elem + ! This subroutines computes the number of faces, which will be + ! included in the fluidity mesh. These are the elements of the mesh + ! which have a boundary ID/side set ID assigned to them. + + do i=1, num_allelem + elemID = allelements(i)%elementID + num_tags_elem = allelements(elemID)%numTags + ! Is there at least one site set ID assigned to the element, it is a face: + if (num_tags_elem > 0) then + ! increase number of faces in the mesh... + num_faces = num_faces + num_tags_elem + end if + end do + + end subroutine get_num_faces + + ! ----------------------------------------------------------------- + + subroutine assemble_actual_elements(num_dim, num_elem_blk, num_elem_in_block, elem_type, allElements, exo_element) + integer, intent(in) :: num_dim + integer, intent(in) :: num_elem_blk + integer, dimension(:), intent(in) :: num_elem_in_block + integer, dimension(:), intent(in) :: elem_type + type(EXOelement), pointer, dimension(:), intent(in) :: allelements + type(EXOelement), pointer, dimension(:), intent(inout) :: exo_element + + integer :: b, e, i, exo_e + ! This subroutine assembles a bucket (called exo_element) which corresponds + ! to the actual elements of the mesh, meaning in a 3D mesh only to the volume + ! elements, and in a 2D mesh only to the surface elements. For each elements + ! that matches this description, the elementID, the block ID the element belongs + ! to, its node IDs, and the element type are stored in this bucket. + + b=0; exo_e=1 + do i=1, num_elem_blk + do e=1, num_elem_in_block(i) + ! Distinguish between faces/edges and elements: + if( .not. ( (num_dim .eq. 2 .and. elem_type(i) .eq. 1) .or. & (num_dim .eq. 3 .and. & (elem_type(i) .eq. 2 .or. elem_type(i) .eq. 3)) ) ) then - ! these are elements (not edges/faces) - allocate( exo_element(exo_e)%nodeIDs(size(allElements(e+b)%nodeIDs))) - exo_element(exo_e)%elementID = allelements(e+b)%elementID - exo_element(exo_e)%blockID = allelements(e+b)%blockID - exo_element(exo_e)%nodeIDs = allelements(e+b)%nodeIDs - exo_element(exo_e)%type = allelements(e+b)%type - exo_e = exo_e + 1 - ! else - ! These are edges/faces, thus do nothing - end if - ! next element e of block i - end do - b = b + num_elem_in_block(i) ! next block - end do - - end subroutine assemble_actual_elements - - ! ----------------------------------------------------------------- - - subroutine assemble_actual_face_elements(num_side_sets, & - num_elem_in_set, & - side_set_ids, & - total_side_sets_node_cnt_list, & - total_side_sets_node_list, & - exo_face) - integer, intent(in) :: num_side_sets - integer, dimension(:), intent(in) :: num_elem_in_set - integer, dimension(:), intent(in) :: side_set_ids - integer, dimension(:), intent(in) :: total_side_sets_node_cnt_list - integer, dimension(:), intent(in) :: total_side_sets_node_list - type(EXOelement), pointer, dimension(:), intent(inout) :: exo_face - - integer :: num_nodes_face_ele - integer :: i, e, n, m, exo_f - - n=1; exo_f=1; - do i=1, num_side_sets - do e=1, num_elem_in_set(i) - num_nodes_face_ele = total_side_sets_node_cnt_list(e) - allocate( exo_face(exo_f)%nodeIDs(num_nodes_face_ele)) - do m=1, num_nodes_face_ele - exo_face(exo_f)%nodeIDs(m) = total_side_sets_node_list(n) - n = n+1 - end do - ! Set boundaryID to face: - allocate(exo_face(exo_f)%tags(1)) - exo_face(exo_f)%tags = side_set_ids(i) - exo_f = exo_f+1 - end do - end do - - end subroutine assemble_actual_face_elements - - ! ----------------------------------------------------------------- - - subroutine adding_nodes_to_field(eff_dim, num_nodes, node_map, node_coord, field) - integer, intent(in) :: eff_dim - integer, intent(in) :: num_nodes - integer, allocatable, dimension(:), intent(in) :: node_map - real(kind=c_float), dimension(:,:), intent(in) :: node_coord - type(vector_field), intent(inout) :: field - - type(EXOnode), pointer, dimension(:) :: exo_nodes - integer :: d, n, nodeID - ! This subroutine does what its name tells us: Adding the nodes of the mesh file - ! to the actual field that describes the coordinate mesh in Fluidity - - ! Now set up nodes, their IDs and coordinates: - ! Allocate exodus nodes - allocate(exo_nodes(num_nodes)) - ! setting all node properties to zero - exo_nodes(:)%nodeID = 0.0 - exo_nodes(:)%x(1)=0.0; exo_nodes(:)%x(2)=0.0; exo_nodes(:)%x(3)=0.0; - ! copy coordinates into Coordinate field - do n=1, num_nodes - nodeID = node_map(n) - exo_nodes(n)%nodeID = nodeID - forall (d = 1:eff_dim) - exo_nodes(n)%x(d) = node_coord(d,n) - field%val(d,nodeID) = exo_nodes(n)%x(d) - end forall - end do - ! Don't need those anymore: - deallocate(exo_nodes); - - end subroutine adding_nodes_to_field - - ! ----------------------------------------------------------------- - - subroutine adding_elements_to_field(num_dim, num_elem, exo_element, node_map, field) - integer, intent(in) :: num_dim - integer, intent(in) :: num_elem - type(EXOelement), pointer, dimension(:), intent(in) :: exo_element - integer, dimension(:), intent(in) :: node_map - type(vector_field), intent(inout) :: field - - integer :: elementType, num_nodes_per_elem_ele - integer :: i, n, z, exo_e - ! This subroutine now adds elements and regionIDs (which in an exodusII mesh - ! are blockIDs) to the field - - z=0; exo_e=1; - do i=1, num_elem - elementType = exo_element(exo_e)%type - if(.not.( (num_dim .eq. 2 .and. elementType .eq. 1) .or. & - (num_dim .eq. 3 .and. & - (elementType .eq. 2 .or. elementType .eq. 3)) ) ) then - !these are normal elements: - num_nodes_per_elem_ele = size(exo_element(exo_e)%nodeIDs) - do n=1, num_nodes_per_elem_ele - field%mesh%ndglno(n+z) = node_map(exo_element(exo_e)%nodeIDs(n)) - end do - ! Set region_id of element (this will be its blockID in exodus) - field%mesh%region_ids(i) = exo_element(exo_e)%blockID - exo_e = exo_e+1 - z = z+num_nodes_per_elem_ele - end if - end do - - end subroutine adding_elements_to_field - - ! ----------------------------------------------------------------- - ! Read ExodusII file to state object. - function read_exodusii_file_to_state(filename, shape,shape_type,n_states) & - result (result_state) - ! Filename is the base name of the ExodusII file without file extension, e.g. .exo - character(len=*), intent(in) :: filename - type(element_type), intent(in), target :: shape - logical , intent(in):: shape_type - integer, intent(in), optional :: n_states - type(state_type) :: result_state - - FLAbort("read_exodusii_file_to_state() not implemented yet") - - end function read_exodusii_file_to_state - - ! ----------------------------------------------------------------- - - subroutine append_array(array, array2) - integer, allocatable, dimension(:), intent(inout) :: array - integer, allocatable, dimension(:), intent(in) :: array2 - integer, allocatable, dimension(:) :: tmp - allocate(tmp(size(array) + size(array2))) - tmp(1:size(array)) = array - tmp(size(array)+1:size(array)+size(array2)) = array2 - deallocate(array) - allocate(array(size(tmp))) - array = tmp - end subroutine append_array + ! these are elements (not edges/faces) + allocate( exo_element(exo_e)%nodeIDs(size(allElements(e+b)%nodeIDs))) + exo_element(exo_e)%elementID = allelements(e+b)%elementID + exo_element(exo_e)%blockID = allelements(e+b)%blockID + exo_element(exo_e)%nodeIDs = allelements(e+b)%nodeIDs + exo_element(exo_e)%type = allelements(e+b)%type + exo_e = exo_e + 1 + ! else + ! These are edges/faces, thus do nothing + end if + ! next element e of block i + end do + b = b + num_elem_in_block(i) ! next block + end do + + end subroutine assemble_actual_elements + + ! ----------------------------------------------------------------- + + subroutine assemble_actual_face_elements(num_side_sets, & + num_elem_in_set, & + side_set_ids, & + total_side_sets_node_cnt_list, & + total_side_sets_node_list, & + exo_face) + integer, intent(in) :: num_side_sets + integer, dimension(:), intent(in) :: num_elem_in_set + integer, dimension(:), intent(in) :: side_set_ids + integer, dimension(:), intent(in) :: total_side_sets_node_cnt_list + integer, dimension(:), intent(in) :: total_side_sets_node_list + type(EXOelement), pointer, dimension(:), intent(inout) :: exo_face + + integer :: num_nodes_face_ele + integer :: i, e, n, m, exo_f + + n=1; exo_f=1; + do i=1, num_side_sets + do e=1, num_elem_in_set(i) + num_nodes_face_ele = total_side_sets_node_cnt_list(e) + allocate( exo_face(exo_f)%nodeIDs(num_nodes_face_ele)) + do m=1, num_nodes_face_ele + exo_face(exo_f)%nodeIDs(m) = total_side_sets_node_list(n) + n = n+1 + end do + ! Set boundaryID to face: + allocate(exo_face(exo_f)%tags(1)) + exo_face(exo_f)%tags = side_set_ids(i) + exo_f = exo_f+1 + end do + end do + + end subroutine assemble_actual_face_elements + + ! ----------------------------------------------------------------- + + subroutine adding_nodes_to_field(eff_dim, num_nodes, node_map, node_coord, field) + integer, intent(in) :: eff_dim + integer, intent(in) :: num_nodes + integer, allocatable, dimension(:), intent(in) :: node_map + real(kind=c_float), dimension(:,:), intent(in) :: node_coord + type(vector_field), intent(inout) :: field + + type(EXOnode), pointer, dimension(:) :: exo_nodes + integer :: d, n, nodeID + ! This subroutine does what its name tells us: Adding the nodes of the mesh file + ! to the actual field that describes the coordinate mesh in Fluidity + + ! Now set up nodes, their IDs and coordinates: + ! Allocate exodus nodes + allocate(exo_nodes(num_nodes)) + ! setting all node properties to zero + exo_nodes(:)%nodeID = 0.0 + exo_nodes(:)%x(1)=0.0; exo_nodes(:)%x(2)=0.0; exo_nodes(:)%x(3)=0.0; + ! copy coordinates into Coordinate field + do n=1, num_nodes + nodeID = node_map(n) + exo_nodes(n)%nodeID = nodeID + forall (d = 1:eff_dim) + exo_nodes(n)%x(d) = node_coord(d,n) + field%val(d,nodeID) = exo_nodes(n)%x(d) + end forall + end do + ! Don't need those anymore: + deallocate(exo_nodes); + + end subroutine adding_nodes_to_field + + ! ----------------------------------------------------------------- + + subroutine adding_elements_to_field(num_dim, num_elem, exo_element, node_map, field) + integer, intent(in) :: num_dim + integer, intent(in) :: num_elem + type(EXOelement), pointer, dimension(:), intent(in) :: exo_element + integer, dimension(:), intent(in) :: node_map + type(vector_field), intent(inout) :: field + + integer :: elementType, num_nodes_per_elem_ele + integer :: i, n, z, exo_e + ! This subroutine now adds elements and regionIDs (which in an exodusII mesh + ! are blockIDs) to the field + + z=0; exo_e=1; + do i=1, num_elem + elementType = exo_element(exo_e)%type + if(.not.( (num_dim .eq. 2 .and. elementType .eq. 1) .or. & + (num_dim .eq. 3 .and. & + (elementType .eq. 2 .or. elementType .eq. 3)) ) ) then + !these are normal elements: + num_nodes_per_elem_ele = size(exo_element(exo_e)%nodeIDs) + do n=1, num_nodes_per_elem_ele + field%mesh%ndglno(n+z) = node_map(exo_element(exo_e)%nodeIDs(n)) + end do + ! Set region_id of element (this will be its blockID in exodus) + field%mesh%region_ids(i) = exo_element(exo_e)%blockID + exo_e = exo_e+1 + z = z+num_nodes_per_elem_ele + end if + end do + + end subroutine adding_elements_to_field + + ! ----------------------------------------------------------------- + ! Read ExodusII file to state object. + function read_exodusii_file_to_state(filename, shape,shape_type,n_states) & + result (result_state) + ! Filename is the base name of the ExodusII file without file extension, e.g. .exo + character(len=*), intent(in) :: filename + type(element_type), intent(in), target :: shape + logical , intent(in):: shape_type + integer, intent(in), optional :: n_states + type(state_type) :: result_state + + FLAbort("read_exodusii_file_to_state() not implemented yet") + + end function read_exodusii_file_to_state + + ! ----------------------------------------------------------------- + + subroutine append_array(array, array2) + integer, allocatable, dimension(:), intent(inout) :: array + integer, allocatable, dimension(:), intent(in) :: array2 + integer, allocatable, dimension(:) :: tmp + allocate(tmp(size(array) + size(array2))) + tmp(1:size(array)) = array + tmp(size(array)+1:size(array)+size(array2)) = array2 + deallocate(array) + allocate(array(size(tmp))) + array = tmp + end subroutine append_array end module read_exodusii diff --git a/femtools/Read_GMSH.F90 b/femtools/Read_GMSH.F90 index 92c8c6a163..b6aa7f48d4 100644 --- a/femtools/Read_GMSH.F90 +++ b/femtools/Read_GMSH.F90 @@ -28,1454 +28,1454 @@ #include "fdebug.h" module read_gmsh - ! This module reads GMSH files and results in a vector field of - ! positions. + ! This module reads GMSH files and results in a vector field of + ! positions. - use iso_c_binding - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use futils - use data_structures - use linked_lists - use quadrature - use elements - use spud - use parallel_tools - use fields - use state_module - use gmsh_common + use iso_c_binding + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use futils + use data_structures + use linked_lists + use quadrature + use elements + use spud + use parallel_tools + use fields + use state_module + use gmsh_common - implicit none + implicit none - private + private - interface read_gmsh_file - module procedure read_gmsh_simple - end interface + interface read_gmsh_file + module procedure read_gmsh_simple + end interface - public :: read_gmsh_file + public :: read_gmsh_file - integer, parameter:: GMSH_LINE=1, GMSH_TRIANGLE=2, GMSH_QUAD=3, GMSH_TET=4, GMSH_HEX=5, GMSH_NODE=15 + integer, parameter:: GMSH_LINE=1, GMSH_TRIANGLE=2, GMSH_QUAD=3, GMSH_TET=4, GMSH_HEX=5, GMSH_NODE=15 - type version + type version - integer :: major = 0 - integer :: minor = 0 + integer :: major = 0 + integer :: minor = 0 - end type version + end type version contains - ! ----------------------------------------------------------------- - ! The main function for reading GMSH files - - function read_gmsh_simple( filename, quad_degree, & - quad_ngi, quad_family, mdim ) & - result (field) - !!< Read a GMSH file into a coordinate field. - !!< In parallel the filename must *not* include the process number. - - character(len=*), intent(in) :: filename - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_degree - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_ngi - !! What quadrature family to use - integer, intent(in), optional :: quad_family - !! Dimension of mesh - integer, intent(in), optional :: mdim - !! result: a coordinate field - type(vector_field) :: field - - type(quadrature_type):: quad - type(element_type):: shape - type(mesh_type):: mesh - - integer :: fd - integer, pointer, dimension(:) :: sndglno, boundaryIDs, faceOwner - - character(len = parallel_filename_len(filename)) :: lfilename - integer :: loc, sloc - integer :: numNodes, numElements, numFaces - logical :: haveBounds, haveElementOwners, haveRegionIDs - integer :: dim, coordinate_dim, gdim - integer :: gmshFormat, beforeHeaderPos - type(version) :: versionNumber - integer :: n, d, e, f, nodeID - logical :: findElementData - - type(integer_hash_table) :: entityMap(4) - integer, allocatable :: entityTags(:) - - type(GMSHnode), pointer :: nodes(:) - type(GMSHelement), pointer :: elements(:), faces(:) - - - ! If running in parallel, add the process number - if(isparallel()) then - lfilename = trim(parallel_filename(filename)) // ".msh" - else - lfilename = trim(filename) // ".msh" - end if - - fd = free_unit() - - ! Open node file - ewrite(2, *) "Opening "//trim(lfilename)//" for reading." - open( unit=fd, file=trim(lfilename), err=43, action="read", & + ! ----------------------------------------------------------------- + ! The main function for reading GMSH files + + function read_gmsh_simple( filename, quad_degree, & + quad_ngi, quad_family, mdim ) & + result (field) + !!< Read a GMSH file into a coordinate field. + !!< In parallel the filename must *not* include the process number. + + character(len=*), intent(in) :: filename + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_degree + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_ngi + !! What quadrature family to use + integer, intent(in), optional :: quad_family + !! Dimension of mesh + integer, intent(in), optional :: mdim + !! result: a coordinate field + type(vector_field) :: field + + type(quadrature_type):: quad + type(element_type):: shape + type(mesh_type):: mesh + + integer :: fd + integer, pointer, dimension(:) :: sndglno, boundaryIDs, faceOwner + + character(len = parallel_filename_len(filename)) :: lfilename + integer :: loc, sloc + integer :: numNodes, numElements, numFaces + logical :: haveBounds, haveElementOwners, haveRegionIDs + integer :: dim, coordinate_dim, gdim + integer :: gmshFormat, beforeHeaderPos + type(version) :: versionNumber + integer :: n, d, e, f, nodeID + logical :: findElementData + + type(integer_hash_table) :: entityMap(4) + integer, allocatable :: entityTags(:) + + type(GMSHnode), pointer :: nodes(:) + type(GMSHelement), pointer :: elements(:), faces(:) + + + ! If running in parallel, add the process number + if(isparallel()) then + lfilename = trim(parallel_filename(filename)) // ".msh" + else + lfilename = trim(filename) // ".msh" + end if + + fd = free_unit() + + ! Open node file + ewrite(2, *) "Opening "//trim(lfilename)//" for reading." + open( unit=fd, file=trim(lfilename), err=43, action="read", & access="stream", form="formatted" ) - ! Read in header information, and validate - call read_header( fd, lfilename, gmshFormat, versionNumber ) + ! Read in header information, and validate + call read_header( fd, lfilename, gmshFormat, versionNumber ) - if (versionNumber%major == 4) then - do n=1,4 - call allocate(entityMap(n)) - end do - call read_entities(fd, lfilename, gmshFormat, versionNumber, & + if (versionNumber%major == 4) then + do n=1,4 + call allocate(entityMap(n)) + end do + call read_entities(fd, lfilename, gmshFormat, versionNumber, & entityMap, entityTags, beforeHeaderPos, findElementData) - end if + end if - ! Read in the nodes - if (versionNumber%major == 4) then - if( gmshFormat == asciiFormat ) then - call read_nodes_coords_v4_ascii(fd, lfilename, beforeHeaderPos, & + ! Read in the nodes + if (versionNumber%major == 4) then + if( gmshFormat == asciiFormat ) then + call read_nodes_coords_v4_ascii(fd, lfilename, beforeHeaderPos, & versionNumber, nodes) - else - call read_nodes_coords_v4_binary(fd, lfilename, beforeHeaderPos, & + else + call read_nodes_coords_v4_binary(fd, lfilename, beforeHeaderPos, & versionNumber, nodes) - end if - else - call read_nodes_coords_v2( fd, lfilename, gmshFormat, nodes ) - end if - - ! Read in elements - if (versionNumber%major == 4) then - if( gmshFormat == asciiFormat ) then - call read_faces_and_elements_v4_ascii( fd, lfilename, & + end if + else + call read_nodes_coords_v2( fd, lfilename, gmshFormat, nodes ) + end if + + ! Read in elements + if (versionNumber%major == 4) then + if( gmshFormat == asciiFormat ) then + call read_faces_and_elements_v4_ascii( fd, lfilename, & versionNumber, elements, faces, dim, entityMap, entityTags, & findElementData) - else - call read_faces_and_elements_v4_binary( fd, lfilename, & + else + call read_faces_and_elements_v4_binary( fd, lfilename, & versionNumber, elements, faces, dim, entityMap, entityTags, & findElementData) - end if - else - call read_faces_and_elements_v2( fd, lfilename, gmshFormat, & - elements, faces, dim) - end if - - call read_node_column_IDs( fd, lfilename, gmshFormat, nodes ) - - ! According to fluidity/bin/gmsh2triangle, Fluidity doesn't need - ! anything past $EndElements, so we close the file. - close( fd ) - - if (versionNumber%major == 4) then - do n=1,4 - call deallocate(entityMap(n)) - end do - deallocate(entityTags) - end if - - - numNodes = size(nodes) - numFaces = size(faces) - numElements = size(elements) - - ! NOTE: similar function 'boundaries' variable in Read_Triangle.F90 - ! ie. flag for boundaries and internal boundaries (period mesh bounds) - - if (numFaces>0) then - ! do we have physical surface ids? - haveBounds= faces(1)%numTags>0 - ! do we have element owners of faces? - haveElementOwners = faces(1)%numTags==4 - - ! if any (the first face) has them, then all should have them - do f=2, numFaces - if(faces(f)%numTags/=faces(1)%numTags) then - ewrite(0,*) "In your gmsh input files all faces (3d)/edges (2d) should" // & - & " have the same number of tags" - FLExit("Inconsistent number of face tags") end if - end do + else + call read_faces_and_elements_v2( fd, lfilename, gmshFormat, & + elements, faces, dim) + end if + + call read_node_column_IDs( fd, lfilename, gmshFormat, nodes ) + + ! According to fluidity/bin/gmsh2triangle, Fluidity doesn't need + ! anything past $EndElements, so we close the file. + close( fd ) + + if (versionNumber%major == 4) then + do n=1,4 + call deallocate(entityMap(n)) + end do + deallocate(entityTags) + end if - else - haveBounds=.false. - haveElementOwners=.false. + numNodes = size(nodes) + numFaces = size(faces) + numElements = size(elements) - end if + ! NOTE: similar function 'boundaries' variable in Read_Triangle.F90 + ! ie. flag for boundaries and internal boundaries (period mesh bounds) - if (numElements>0) then + if (numFaces>0) then + ! do we have physical surface ids? + haveBounds= faces(1)%numTags>0 + ! do we have element owners of faces? + haveElementOwners = faces(1)%numTags==4 + + ! if any (the first face) has them, then all should have them + do f=2, numFaces + if(faces(f)%numTags/=faces(1)%numTags) then + ewrite(0,*) "In your gmsh input files all faces (3d)/edges (2d) should" // & + & " have the same number of tags" + FLExit("Inconsistent number of face tags") + end if + end do + + else + + haveBounds=.false. + haveElementOwners=.false. + + end if + + if (numElements>0) then + + haveRegionIDs = elements(1)%numTags>0 + ! if any (the first face) has them, then all should have them + do e=2, numElements + if(elements(e)%numTags/=elements(1)%numTags) then + ewrite(0,*) "In your gmsh input files all elements should" // & + & " have the same number of tags" + FLExit("Inconsistent number of element tags") + end if + end do + + else + + haveRegionIDs = .false. + + end if + + if (present(mdim)) then + coordinate_dim = mdim + else if(have_option("/geometry/spherical_earth") ) then + ! on the n-sphere the input mesh may be 1/2d (extrusion), or 3d but + ! Coordinate is always geometry dimensional + call get_option('/geometry/dimension', gdim) + coordinate_dim = gdim + else + coordinate_dim = dim + end if + + loc = size( elements(1)%nodeIDs ) + if (numFaces>0) then + sloc = size( faces(1)%nodeIDs ) + else + sloc = 0 + end if - haveRegionIDs = elements(1)%numTags>0 - ! if any (the first face) has them, then all should have them - do e=2, numElements - if(elements(e)%numTags/=elements(1)%numTags) then - ewrite(0,*) "In your gmsh input files all elements should" // & - & " have the same number of tags" - FLExit("Inconsistent number of element tags") + ! Now construct within Fluidity data structures + + if (present(quad_degree)) then + quad = make_quadrature(loc, dim, degree=quad_degree, family=quad_family) + else if (present(quad_ngi)) then + quad = make_quadrature(loc, dim, ngi=quad_ngi, family=quad_family) + else + FLAbort("Need to specify either quadrature degree or ngi") + end if + shape=make_element_shape(loc, dim, 1, quad) + call allocate(mesh, numNodes, numElements, shape, name="CoordinateMesh") + call allocate( field, coordinate_dim, mesh, name="Coordinate") + + ! deallocate our references of mesh, shape and quadrature: + call deallocate(mesh) + call deallocate(shape) + call deallocate(quad) + + + if (haveRegionIDs) then + allocate( field%mesh%region_ids(numElements) ) + end if + if(nodes(1)%columnID>=0) allocate(field%mesh%columns(1:numNodes)) + + ! Loop round nodes copying across coords and column IDs to field mesh, + ! if they exist + do n=1, numNodes + + nodeID = nodes(n)%nodeID + forall (d = 1:field%dim) + field%val(d,nodeID) = nodes(n)%x(d) + end forall + + ! If there's a valid node column ID, use it. + if ( nodes(n)%columnID .ne. -1 ) then + field%mesh%columns(nodeID) = nodes(n)%columnID end if + + end do + + ! Copy elements to field + do e=1, numElements + field%mesh%ndglno((e-1)*loc+1:e*loc) = elements(e)%nodeIDs + if (haveRegionIDs) field%mesh%region_ids(e) = elements(e)%tags(1) end do - else - - haveRegionIDs = .false. - - end if - - if (present(mdim)) then - coordinate_dim = mdim - else if(have_option("/geometry/spherical_earth") ) then - ! on the n-sphere the input mesh may be 1/2d (extrusion), or 3d but - ! Coordinate is always geometry dimensional - call get_option('/geometry/dimension', gdim) - coordinate_dim = gdim - else - coordinate_dim = dim - end if - - loc = size( elements(1)%nodeIDs ) - if (numFaces>0) then - sloc = size( faces(1)%nodeIDs ) - else - sloc = 0 - end if - - ! Now construct within Fluidity data structures - - if (present(quad_degree)) then - quad = make_quadrature(loc, dim, degree=quad_degree, family=quad_family) - else if (present(quad_ngi)) then - quad = make_quadrature(loc, dim, ngi=quad_ngi, family=quad_family) - else - FLAbort("Need to specify either quadrature degree or ngi") - end if - shape=make_element_shape(loc, dim, 1, quad) - call allocate(mesh, numNodes, numElements, shape, name="CoordinateMesh") - call allocate( field, coordinate_dim, mesh, name="Coordinate") - - ! deallocate our references of mesh, shape and quadrature: - call deallocate(mesh) - call deallocate(shape) - call deallocate(quad) - - - if (haveRegionIDs) then - allocate( field%mesh%region_ids(numElements) ) - end if - if(nodes(1)%columnID>=0) allocate(field%mesh%columns(1:numNodes)) - - ! Loop round nodes copying across coords and column IDs to field mesh, - ! if they exist - do n=1, numNodes - - nodeID = nodes(n)%nodeID - forall (d = 1:field%dim) - field%val(d,nodeID) = nodes(n)%x(d) - end forall - - ! If there's a valid node column ID, use it. - if ( nodes(n)%columnID .ne. -1 ) then - field%mesh%columns(nodeID) = nodes(n)%columnID - end if - - end do - - ! Copy elements to field - do e=1, numElements - field%mesh%ndglno((e-1)*loc+1:e*loc) = elements(e)%nodeIDs - if (haveRegionIDs) field%mesh%region_ids(e) = elements(e)%tags(1) - end do - - ! Now faces - allocate(sndglno(1:numFaces*sloc)) - sndglno=0 - if(haveBounds) then - allocate(boundaryIDs(1:numFaces)) - end if - if(haveElementOwners) then - allocate(faceOwner(1:numFaces)) - end if - - do f=1, numFaces - sndglno((f-1)*sloc+1:f*sloc) = faces(f)%nodeIDs(1:sloc) - if(haveBounds) boundaryIDs(f) = faces(f)%tags(1) - if(haveElementOwners) faceOwner(f) = faces(f)%tags(4) - end do - - ! If we've got boundaries, do something - if( haveBounds ) then - if ( haveElementOwners ) then - call add_faces( field%mesh, & + ! Now faces + allocate(sndglno(1:numFaces*sloc)) + sndglno=0 + if(haveBounds) then + allocate(boundaryIDs(1:numFaces)) + end if + if(haveElementOwners) then + allocate(faceOwner(1:numFaces)) + end if + + do f=1, numFaces + sndglno((f-1)*sloc+1:f*sloc) = faces(f)%nodeIDs(1:sloc) + if(haveBounds) boundaryIDs(f) = faces(f)%tags(1) + if(haveElementOwners) faceOwner(f) = faces(f)%tags(4) + end do + + ! If we've got boundaries, do something + if( haveBounds ) then + if ( haveElementOwners ) then + call add_faces( field%mesh, & sndgln = sndglno(1:numFaces*sloc), & boundary_ids = boundaryIDs(1:numFaces), & element_owner=faceOwner ) - else - call add_faces( field%mesh, & + else + call add_faces( field%mesh, & sndgln = sndglno(1:numFaces*sloc), & boundary_ids = boundaryIDs(1:numFaces) ) - end if - else - ewrite(2,*) "WARNING: no boundaries in GMSH file "//trim(lfilename) - call add_faces( field%mesh, sndgln = sndglno(1:numFaces*sloc) ) - end if + end if + else + ewrite(2,*) "WARNING: no boundaries in GMSH file "//trim(lfilename) + call add_faces( field%mesh, sndgln = sndglno(1:numFaces*sloc) ) + end if + + ! Deallocate arrays + deallocate(sndglno) + if (haveBounds) deallocate(boundaryIDs) + if (haveElementOwners) deallocate(faceOwner) - ! Deallocate arrays - deallocate(sndglno) - if (haveBounds) deallocate(boundaryIDs) - if (haveElementOwners) deallocate(faceOwner) + deallocate(nodes) + deallocate(faces) + deallocate(elements) - deallocate(nodes) - deallocate(faces) - deallocate(elements) + return - return +43 FLExit("Unable to open "//trim(lfilename)) -43 FLExit("Unable to open "//trim(lfilename)) + end function read_gmsh_simple - end function read_gmsh_simple + ! ----------------------------------------------------------------- + ! Read through the head to decide whether binary or ASCII, and decide + ! whether this looks like a GMSH mesh file or not. Also returns + ! the version number if it is indeed a GMSH file. + ! Finally, skip if any $PhysicalNames are present in the header. - ! ----------------------------------------------------------------- - ! Read through the head to decide whether binary or ASCII, and decide - ! whether this looks like a GMSH mesh file or not. Also returns - ! the version number if it is indeed a GMSH file. - ! Finally, skip if any $PhysicalNames are present in the header. + subroutine read_header( fd, lfilename, gmshFormat, versionNumber ) + integer, intent(in) :: fd + character(len=*), intent(in) :: lfilename + integer, intent(out) :: gmshFormat + type(version), intent(out) :: versionNumber - subroutine read_header( fd, lfilename, gmshFormat, versionNumber ) - integer, intent(in) :: fd - character(len=*), intent(in) :: lfilename - integer, intent(out) :: gmshFormat - type(version), intent(out) :: versionNumber + character(len=longStringLen) :: charBuf + character :: newlineChar + integer :: gmshFileType, gmshDataSize, one, i, oldBufPos + logical :: decimalVersion - character(len=longStringLen) :: charBuf - character :: newlineChar - integer :: gmshFileType, gmshDataSize, one, i, oldBufPos - logical :: decimalVersion + decimalVersion = .false. - decimalVersion = .false. + ! Error checking ... - ! Error checking ... + read(fd, *) charBuf + if( trim(charBuf) .ne. "$MeshFormat" ) then + FLExit("Error: can't find '$MeshFormat' (GMSH mesh file?)") + end if - read(fd, *) charBuf - if( trim(charBuf) .ne. "$MeshFormat" ) then - FLExit("Error: can't find '$MeshFormat' (GMSH mesh file?)") - end if + read(fd, *) charBuf, gmshFileType, gmshDataSize - read(fd, *) charBuf, gmshFileType, gmshDataSize + do i=1, len_trim(charbuf) + if (charbuf(i:i) == '.') then + charbuf(i:i) = ' ' + decimalVersion = .true. + end if + end do - do i=1, len_trim(charbuf) - if (charbuf(i:i) == '.') then - charbuf(i:i) = ' ' - decimalVersion = .true. + if (decimalVersion) then + read(charBuf,*, pad='yes') versionNumber%major, versionNumber%minor + else + read(charBuf,*, pad='yes') versionNumber%major end if - end do - - if (decimalVersion) then - read(charBuf,*, pad='yes') versionNumber%major, versionNumber%minor - else - read(charBuf,*, pad='yes') versionNumber%major - end if - if( versionNumber%major < 2 .or. & + if( versionNumber%major < 2 .or. & versionNumber%major == 3 .or. & (versionNumber%major == 4 .and. versionNumber%minor > 1) .or. & versionNumber%major > 4 & - ) then - FLExit("Error: GMSH mesh version must be 2.x or 4.x") - end if - - - if( gmshDataSize .ne. doubleNumBytes ) then - write(charBuf,*) doubleNumBytes - FLExit("Error: GMSH data size does not equal "//trim(adjustl(charBuf))) - end if - - ! GMSH binary format continues the integer 1, in binary. - if( gmshFileType == binaryFormat ) then - call binary_formatting(fd, lfilename, "read") - read(fd) one, newlineChar - call ascii_formatting(fd, lfilename, "read") - end if - - inquire(fd, pos=oldBufPos) - read(fd, *) charBuf - if( trim(charBuf) .ne. "$EndMeshFormat" ) then - FLExit("Error: can't find '$EndMeshFormat' (is this a GMSH mesh file?)") - end if - - ! Skip ahead $PhysicalNames if present. Fluidity does not currently use them - ! If not simply rewind to old location. - read(fd, *) charBuf - if (trim(charBuf) == "$PhysicalNames") then - ! Regardless of file format this is an ASCII int - read(fd, *) one - ! Read all lines up until $EndPhysicalNames - do i=1, one+1 - read(fd, *) charBuf - end do - else - rewind(fd) - read(fd, *, pos=oldBufPos) charBuf - end if + ) then + FLExit("Error: GMSH mesh version must be 2.x or 4.x") + end if - ! Done with error checking... set format (ie. ascii or binary) - gmshFormat = gmshFileType + + if( gmshDataSize .ne. doubleNumBytes ) then + write(charBuf,*) doubleNumBytes + FLExit("Error: GMSH data size does not equal "//trim(adjustl(charBuf))) + end if + + ! GMSH binary format continues the integer 1, in binary. + if( gmshFileType == binaryFormat ) then + call binary_formatting(fd, lfilename, "read") + read(fd) one, newlineChar + call ascii_formatting(fd, lfilename, "read") + end if + + inquire(fd, pos=oldBufPos) + read(fd, *) charBuf + if( trim(charBuf) .ne. "$EndMeshFormat" ) then + FLExit("Error: can't find '$EndMeshFormat' (is this a GMSH mesh file?)") + end if + + ! Skip ahead $PhysicalNames if present. Fluidity does not currently use them + ! If not simply rewind to old location. + read(fd, *) charBuf + if (trim(charBuf) == "$PhysicalNames") then + ! Regardless of file format this is an ASCII int + read(fd, *) one + ! Read all lines up until $EndPhysicalNames + do i=1, one+1 + read(fd, *) charBuf + end do + else + rewind(fd) + read(fd, *, pos=oldBufPos) charBuf + end if + + ! Done with error checking... set format (ie. ascii or binary) + gmshFormat = gmshFileType #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - if(gmshFormat == binaryFormat) read(fd, *) charBuf + if(gmshFormat == binaryFormat) read(fd, *) charBuf #endif - end subroutine read_header - - ! ----------------------------------------------------------------- - ! Read GMSH 4 entities into a physical tag map - - subroutine read_entities(fd, filename, gmshFormat, versionNumber, & - entityMap, entityTags, beforeHeaderPos, findElementData) - - integer, intent(in) :: fd, gmshFormat - type(version), intent(in) :: versionNumber - character(len=*), intent(in) :: filename - - type(integer_hash_table), intent(out) :: entityMap(4) - integer, allocatable, intent(out) :: entityTags(:) - integer, intent(out) :: beforeHeaderPos - logical, intent(out) :: findElementData - type(ilist) :: tmpTags - - integer :: i, k, n, numPoints, numDim(3), stat, count - integer :: entityTag, numBoundTags, numPhysicalTags, pointBounds - integer, allocatable :: tags(:), boundObjects(:) - integer(kind=c_long) :: ltmp - real :: bounds(6) - character :: newlineChar - character(len=longStringLen) :: charBuf - - if ( versionNumber%minor == 0 ) then - pointBounds=6 - else - pointBounds=3 - end if - - findElementData = .false. - - ! save location - inquire(fd, pos=beforeHeaderPos) - read(fd, *) charBuf - if (trim(charBuf) /= "$Entities") then - ! we'll assume the Entities - ! section was omitted (valid for 4.1) - if (versionNumber%major == 4 .and. versionNumber%minor < 1) then - FLExit("Error: can't find '$Entities' in GMSH <4.1 file") + end subroutine read_header + + ! ----------------------------------------------------------------- + ! Read GMSH 4 entities into a physical tag map + + subroutine read_entities(fd, filename, gmshFormat, versionNumber, & + entityMap, entityTags, beforeHeaderPos, findElementData) + + integer, intent(in) :: fd, gmshFormat + type(version), intent(in) :: versionNumber + character(len=*), intent(in) :: filename + + type(integer_hash_table), intent(out) :: entityMap(4) + integer, allocatable, intent(out) :: entityTags(:) + integer, intent(out) :: beforeHeaderPos + logical, intent(out) :: findElementData + type(ilist) :: tmpTags + + integer :: i, k, n, numPoints, numDim(3), stat, count + integer :: entityTag, numBoundTags, numPhysicalTags, pointBounds + integer, allocatable :: tags(:), boundObjects(:) + integer(kind=c_long) :: ltmp + real :: bounds(6) + character :: newlineChar + character(len=longStringLen) :: charBuf + + if ( versionNumber%minor == 0 ) then + pointBounds=6 + else + pointBounds=3 end if - ! work around gfortran bug(?) in binary files - ! where read specifying pos= doesn't work correctly - rewind(fd) + findElementData = .false. - do i = 1, 4 - ! map tag 0 to the null physical tag - call insert(entityMap(i), 0, 1) + ! save location + inquire(fd, pos=beforeHeaderPos) + read(fd, *) charBuf + if (trim(charBuf) /= "$Entities") then + ! we'll assume the Entities + ! section was omitted (valid for 4.1) + if (versionNumber%major == 4 .and. versionNumber%minor < 1) then + FLExit("Error: can't find '$Entities' in GMSH <4.1 file") + end if + + ! work around gfortran bug(?) in binary files + ! where read specifying pos= doesn't work correctly + rewind(fd) + + do i = 1, 4 + ! map tag 0 to the null physical tag + call insert(entityMap(i), 0, 1) + end do + allocate(entityTags(2)) + entityTags = [1, 0] + + ! we'll look for physical tags in an $ElementData section + findElementData = .true. + + ! reset file position to before the header + return + end if + + if( gmshFormat == asciiFormat ) then + read(fd, * ) numPoints, numDim + else + call binary_formatting(fd, filename, "read") + read(fd) ltmp + numPoints = ltmp + do i=1, 3 + read(fd) ltmp + numDim(i) = ltmp + end do + end if + + count = 1 + do i=1, numPoints + if( gmshFormat == asciiFormat ) then + read(fd, "(a)", end=606) charBuf +606 read(charBuf, *, iostat=stat ) entityTag, bounds(1:pointBounds), numPhysicalTags + allocate(tags(numPhysicalTags)) + read(charBuf, *, iostat=stat ) entityTag, bounds(1:pointBounds), numPhysicalTags, tags + else + read(fd) entityTag, bounds(1:pointBounds), ltmp + numPhysicalTags=ltmp + allocate(tags(numPhysicalTags)) + read(fd) tags + end if + call insert(tmpTags, numPhysicalTags) + call insert(entityMap(1), entityTag, count) + do n = 1, numPhysicalTags + call insert(tmpTags, tags(n)) + end do + deallocate(tags) + count = count + numPhysicalTags + 1 end do - allocate(entityTags(2)) - entityTags = [1, 0] - ! we'll look for physical tags in an $ElementData section - findElementData = .true. + do k=1,3 + do i=1, numDim(k) + if( gmshFormat == asciiFormat ) then + read(fd, "(a)", end=607) charBuf +607 read(charBuf, *, iostat=stat ) entityTag, bounds, numPhysicalTags + allocate(tags(numPhysicalTags)) + read(charBuf, *, iostat=stat ) entityTag, bounds, numPhysicalTags, tags + else + read(fd) entityTag, bounds, ltmp + numPhysicalTags = ltmp + allocate(tags(numPhysicalTags)) + read(fd) tags + read(fd) ltmp + numBoundTags = ltmp + allocate(boundObjects(numBoundTags)) + read(fd) boundObjects + deallocate(boundObjects) + end if + call insert(tmpTags, numPhysicalTags) + call insert(entityMap(k+1), entityTag, count) + do n = 1, numPhysicalTags + call insert(tmpTags, tags(n)) + end do + deallocate(tags) + count = count + numPhysicalTags + 1 + end do + end do - ! reset file position to before the header - return - end if - - if( gmshFormat == asciiFormat ) then - read(fd, * ) numPoints, numDim - else - call binary_formatting(fd, filename, "read") - read(fd) ltmp - numPoints = ltmp - do i=1, 3 - read(fd) ltmp - numDim(i) = ltmp - end do - end if - - count = 1 - do i=1, numPoints - if( gmshFormat == asciiFormat ) then - read(fd, "(a)", end=606) charBuf -606 read(charBuf, *, iostat=stat ) entityTag, bounds(1:pointBounds), numPhysicalTags - allocate(tags(numPhysicalTags)) - read(charBuf, *, iostat=stat ) entityTag, bounds(1:pointBounds), numPhysicalTags, tags - else - read(fd) entityTag, bounds(1:pointBounds), ltmp - numPhysicalTags=ltmp - allocate(tags(numPhysicalTags)) - read(fd) tags - end if - call insert(tmpTags, numPhysicalTags) - call insert(entityMap(1), entityTag, count) - do n = 1, numPhysicalTags - call insert(tmpTags, tags(n)) - end do - deallocate(tags) - count = count + numPhysicalTags + 1 - end do - - do k=1,3 - do i=1, numDim(k) - if( gmshFormat == asciiFormat ) then - read(fd, "(a)", end=607) charBuf -607 read(charBuf, *, iostat=stat ) entityTag, bounds, numPhysicalTags - allocate(tags(numPhysicalTags)) - read(charBuf, *, iostat=stat ) entityTag, bounds, numPhysicalTags, tags - else - read(fd) entityTag, bounds, ltmp - numPhysicalTags = ltmp - allocate(tags(numPhysicalTags)) - read(fd) tags - read(fd) ltmp - numBoundTags = ltmp - allocate(boundObjects(numBoundTags)) - read(fd) boundObjects - deallocate(boundObjects) - end if - call insert(tmpTags, numPhysicalTags) - call insert(entityMap(k+1), entityTag, count) - do n = 1, numPhysicalTags - call insert(tmpTags, tags(n)) - end do - deallocate(tags) - count = count + numPhysicalTags + 1 - end do - end do - - ! Skip newline character when in binary mode - if( gmshFormat == binaryFormat ) then - read(fd) newlineChar - call ascii_formatting(fd, filename, "read") - end if - - read(fd, *) charBuf - if( trim(charBuf) /= "$EndEntities" ) then - FLExit("Error: can't find '$EndEntities' (is this a GMSH mesh file?)") - end if - - allocate(entityTags(count-1)) - entityTags = list2vector(tmpTags) - call deallocate(tmpTags) + ! Skip newline character when in binary mode + if( gmshFormat == binaryFormat ) then + read(fd) newlineChar + call ascii_formatting(fd, filename, "read") + end if + + read(fd, *) charBuf + if( trim(charBuf) /= "$EndEntities" ) then + FLExit("Error: can't find '$EndEntities' (is this a GMSH mesh file?)") + end if + + allocate(entityTags(count-1)) + entityTags = list2vector(tmpTags) + call deallocate(tmpTags) #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - if(gmshFormat == binaryFormat) read(fd, *) charBuf + if(gmshFormat == binaryFormat) read(fd, *) charBuf #endif - inquire(fd, pos=beforeHeaderPos) + inquire(fd, pos=beforeHeaderPos) + + end subroutine read_entities + - end subroutine read_entities + ! ----------------------------------------------------------------- + ! read in GMSH version 2 mesh nodes' coords into temporary arrays + subroutine read_nodes_coords_v2( fd, filename, gmshFormat, nodes ) + integer, intent(in) :: fd, gmshFormat + character(len=*), intent(in) :: filename + type(GMSHnode), pointer :: nodes(:) - ! ----------------------------------------------------------------- - ! read in GMSH version 2 mesh nodes' coords into temporary arrays + character(len=longStringLen) :: charBuf + character :: newlineChar + integer :: i, numNodes - subroutine read_nodes_coords_v2( fd, filename, gmshFormat, nodes ) - integer, intent(in) :: fd, gmshFormat - character(len=*), intent(in) :: filename - type(GMSHnode), pointer :: nodes(:) - character(len=longStringLen) :: charBuf - character :: newlineChar - integer :: i, numNodes + read(fd, *) charBuf + if( trim(charBuf) .ne. "$Nodes" ) then + FLExit("Error: cannot find '$Nodes' in GMSH mesh file") + end if + read(fd, *) numNodes - read(fd, *) charBuf - if( trim(charBuf) .ne. "$Nodes" ) then - FLExit("Error: cannot find '$Nodes' in GMSH mesh file") - end if + if(numNodes < 2) then + FLExit("Error: GMSH number of nodes field < 2") + end if - read(fd, *) numNodes + if (gmshFormat==binaryFormat) then + call binary_formatting(fd, filename, "read") + end if - if(numNodes < 2) then - FLExit("Error: GMSH number of nodes field < 2") - end if + allocate( nodes(numNodes) ) - if (gmshFormat==binaryFormat) then - call binary_formatting(fd, filename, "read") - end if - - allocate( nodes(numNodes) ) - - ! read in node data - do i=1, numNodes - if( gmshFormat == asciiFormat ) then - read(fd, * ) nodes(i)%nodeID, nodes(i)%x - else - read(fd) nodes(i)%nodeID, nodes(i)%x - end if - ! Set column ID to -1: this will be changed later if $NodeData exists - nodes(i)%columnID = -1 - end do - - ! Skip newline character when in binary mode - if( gmshFormat == binaryFormat ) then - read(fd) newlineChar - call ascii_formatting(fd, filename, "read") - end if - - ! Read in end node section - read(fd, *) charBuf - if( trim(charBuf) .ne. "$EndNodes" ) then - FLExit("Error: can't find '$EndNodes' in GMSH file '"//trim(filename)//"'") - end if + ! read in node data + do i=1, numNodes + if( gmshFormat == asciiFormat ) then + read(fd, * ) nodes(i)%nodeID, nodes(i)%x + else + read(fd) nodes(i)%nodeID, nodes(i)%x + end if + ! Set column ID to -1: this will be changed later if $NodeData exists + nodes(i)%columnID = -1 + end do + + ! Skip newline character when in binary mode + if( gmshFormat == binaryFormat ) then + read(fd) newlineChar + call ascii_formatting(fd, filename, "read") + end if + + ! Read in end node section + read(fd, *) charBuf + if( trim(charBuf) .ne. "$EndNodes" ) then + FLExit("Error: can't find '$EndNodes' in GMSH file '"//trim(filename)//"'") + end if #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - if(gmshFormat == binaryFormat) read(fd, *) charBuf + if(gmshFormat == binaryFormat) read(fd, *) charBuf #endif - end subroutine read_nodes_coords_v2 - - ! ----------------------------------------------------------------- - ! read in ASCII-formatted GMSH version 4 mesh nodes' coords into - ! temporary arrays - - subroutine read_nodes_coords_v4_ascii(fd, filename, beforeHeaderPos, & - versionNumber, nodes) - integer, intent(in) :: fd - character(len=*), intent(in) :: filename - integer, intent(in) :: beforeHeaderPos - type(version), intent(in) :: versionNumber - type(GMSHnode), pointer :: nodes(:) - - character(len=longStringLen) :: charBuf - integer :: i, j, k, numEntities, numNodes, numEntityNodes, minN, maxN, meta(3) - - read(fd, *, pos=beforeHeaderPos) charBuf - if( trim(charBuf) /= "$Nodes" ) then - FLExit("Error: cannot find '$Nodes' in GMSH mesh file") - end if - - if (versionNumber%minor == 1) then - read(fd, *) numEntities, numNodes, minN, maxN - else - read(fd, *) numEntities, numNodes - end if - - if(numNodes < 2) then - FLExit("Error: GMSH number of nodes field < 2") - end if - - allocate( nodes(numNodes) ) - - ! read in node data - k = 0 - do j=1, numEntities - read(fd, *) meta(1), meta(2), meta(3), numEntityNodes - if (versionNumber%minor == 1) then - do i=k+1, k+numEntityNodes - read(fd, * ) nodes(i)%nodeID - end do - do i=k+1, k+numEntityNodes - read(fd, * ) nodes(i)%x - ! Set column ID to -1: this will be changed later if $NodeData exists - nodes(i)%columnID = -1 - end do - else - do i= k+1, k+numEntityNodes - read(fd, * ) nodes(i)%nodeID, nodes(i)%x - ! Set column ID to -1: this will be changed later if $NodeData exists - nodes(i)%columnID = -1 - end do - end if - k = k + numEntityNodes - end do - - ! Read in end node section - read(fd, *) charBuf - if( trim(charBuf) /= "$EndNodes" ) then - FLExit("Error: can't find '$EndNodes' in GMSH file '"//trim(filename)//"'") - end if - - end subroutine read_nodes_coords_v4_ascii - - ! ----------------------------------------------------------------- - ! read in binary GMSH version 4 mesh nodes' coords into - ! temporary arrays - - subroutine read_nodes_coords_v4_binary(fd, filename, beforeHeaderPos, & - versionNumber, nodes) - integer, intent(in) :: fd - character(len=*), intent(in) :: filename - integer, intent(in) :: beforeHeaderPos - type(version), intent(in) :: versionNumber - type(GMSHnode), pointer :: nodes(:) - - character(len=longStringLen) :: charBuf - character :: newlineChar - integer(kind=c_long) :: numEntities, numNodes, numEntityNodes, minN, maxN - integer :: i, j, k, meta(3) - integer(kind=c_long) :: ltmp - - read(fd, *, pos=beforeHeaderPos) charBuf - if( trim(charBuf) /= "$Nodes" ) then - FLExit("Error: cannot find '$Nodes' in GMSH mesh file") - end if - - call binary_formatting(fd, filename, "read") - - if (versionNumber%minor == 1) then - read(fd) numEntities, numNodes, minN, maxN - else - read(fd) numEntities, numNodes - end if - - if(numNodes < 2) then - FLExit("Error: GMSH number of nodes field < 2") - end if - - allocate( nodes(numNodes) ) - - ! read in node data - k = 0 - do j=1, numEntities - read(fd) meta(1), meta(2), meta(3), numEntityNodes - if (versionNumber%minor == 1) then - do i=k+1, k + numEntityNodes - read(fd) ltmp - nodes(i)%nodeID = ltmp - end do - do i=k+1, k + numEntityNodes - read(fd) nodes(i)%x - ! Set column ID to -1: this will be changed later if $NodeData exists - nodes(i)%columnID = -1 - end do - else - do i= k+1, k + numEntityNodes - read(fd) nodes(i)%nodeID, nodes(i)%x - ! Set column ID to -1: this will be changed later if $NodeData exists - nodes(i)%columnID = -1 - end do - end if - k = k + numEntityNodes - end do - - ! Skip newline character when in binary mode - read(fd) newlineChar - call ascii_formatting(fd, filename, "read") - - ! Read in end node section - read(fd, *) charBuf - if( trim(charBuf) /= "$EndNodes" ) then - FLExit("Error: can't find '$EndNodes' in GMSH file '"//trim(filename)//"'") - end if + end subroutine read_nodes_coords_v2 + + ! ----------------------------------------------------------------- + ! read in ASCII-formatted GMSH version 4 mesh nodes' coords into + ! temporary arrays + + subroutine read_nodes_coords_v4_ascii(fd, filename, beforeHeaderPos, & + versionNumber, nodes) + integer, intent(in) :: fd + character(len=*), intent(in) :: filename + integer, intent(in) :: beforeHeaderPos + type(version), intent(in) :: versionNumber + type(GMSHnode), pointer :: nodes(:) + + character(len=longStringLen) :: charBuf + integer :: i, j, k, numEntities, numNodes, numEntityNodes, minN, maxN, meta(3) + + read(fd, *, pos=beforeHeaderPos) charBuf + if( trim(charBuf) /= "$Nodes" ) then + FLExit("Error: cannot find '$Nodes' in GMSH mesh file") + end if + + if (versionNumber%minor == 1) then + read(fd, *) numEntities, numNodes, minN, maxN + else + read(fd, *) numEntities, numNodes + end if + + if(numNodes < 2) then + FLExit("Error: GMSH number of nodes field < 2") + end if + + allocate( nodes(numNodes) ) + + ! read in node data + k = 0 + do j=1, numEntities + read(fd, *) meta(1), meta(2), meta(3), numEntityNodes + if (versionNumber%minor == 1) then + do i=k+1, k+numEntityNodes + read(fd, * ) nodes(i)%nodeID + end do + do i=k+1, k+numEntityNodes + read(fd, * ) nodes(i)%x + ! Set column ID to -1: this will be changed later if $NodeData exists + nodes(i)%columnID = -1 + end do + else + do i= k+1, k+numEntityNodes + read(fd, * ) nodes(i)%nodeID, nodes(i)%x + ! Set column ID to -1: this will be changed later if $NodeData exists + nodes(i)%columnID = -1 + end do + end if + k = k + numEntityNodes + end do + + ! Read in end node section + read(fd, *) charBuf + if( trim(charBuf) /= "$EndNodes" ) then + FLExit("Error: can't find '$EndNodes' in GMSH file '"//trim(filename)//"'") + end if + + end subroutine read_nodes_coords_v4_ascii + + ! ----------------------------------------------------------------- + ! read in binary GMSH version 4 mesh nodes' coords into + ! temporary arrays + + subroutine read_nodes_coords_v4_binary(fd, filename, beforeHeaderPos, & + versionNumber, nodes) + integer, intent(in) :: fd + character(len=*), intent(in) :: filename + integer, intent(in) :: beforeHeaderPos + type(version), intent(in) :: versionNumber + type(GMSHnode), pointer :: nodes(:) + + character(len=longStringLen) :: charBuf + character :: newlineChar + integer(kind=c_long) :: numEntities, numNodes, numEntityNodes, minN, maxN + integer :: i, j, k, meta(3) + integer(kind=c_long) :: ltmp + + read(fd, *, pos=beforeHeaderPos) charBuf + if( trim(charBuf) /= "$Nodes" ) then + FLExit("Error: cannot find '$Nodes' in GMSH mesh file") + end if + + call binary_formatting(fd, filename, "read") + + if (versionNumber%minor == 1) then + read(fd) numEntities, numNodes, minN, maxN + else + read(fd) numEntities, numNodes + end if + + if(numNodes < 2) then + FLExit("Error: GMSH number of nodes field < 2") + end if + + allocate( nodes(numNodes) ) + + ! read in node data + k = 0 + do j=1, numEntities + read(fd) meta(1), meta(2), meta(3), numEntityNodes + if (versionNumber%minor == 1) then + do i=k+1, k + numEntityNodes + read(fd) ltmp + nodes(i)%nodeID = ltmp + end do + do i=k+1, k + numEntityNodes + read(fd) nodes(i)%x + ! Set column ID to -1: this will be changed later if $NodeData exists + nodes(i)%columnID = -1 + end do + else + do i= k+1, k + numEntityNodes + read(fd) nodes(i)%nodeID, nodes(i)%x + ! Set column ID to -1: this will be changed later if $NodeData exists + nodes(i)%columnID = -1 + end do + end if + k = k + numEntityNodes + end do + + ! Skip newline character when in binary mode + read(fd) newlineChar + call ascii_formatting(fd, filename, "read") + + ! Read in end node section + read(fd, *) charBuf + if( trim(charBuf) /= "$EndNodes" ) then + FLExit("Error: can't find '$EndNodes' in GMSH file '"//trim(filename)//"'") + end if #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - read(fd, *) charBuf + read(fd, *) charBuf #endif - end subroutine read_nodes_coords_v4_binary - - - ! ----------------------------------------------------------------- - ! read in GMSH mesh nodes' column IDs (if exists) - - subroutine read_node_column_IDs( fd, filename, gmshFormat, nodes ) - integer, intent(in) :: fd, gmshFormat - character(len=*), intent(in) :: filename - type(GMSHnode), pointer :: nodes(:) - - character(len=longStringLen) :: charBuf - character :: newlineChar - - integer :: numStringTags, numRealTags, numIntTags - integer :: timeStep, numComponents, numNodes - integer :: i, nodeIx, fileState - real :: rval - - ! If there's no $NodeData section, don't try to read in column IDs: return - read(fd, iostat=fileState, fmt=*) charBuf - if (fileState<0) return ! end of file - if (trim(charBuf)/="$NodeData") return - - ! Sanity checking - read(fd, *) numStringTags - if(numStringTags .ne. 1) then - FLExit("Error: must have one string tag in GMSH file $NodeData part") - end if - read(fd, *) charBuf - if( trim(charBuf) .ne. "column_ids") then - FLExit("Error: GMSH string tag in $NodeData section != 'column_ids'") - end if - - ! Skip over these, not used (yet) - read(fd, *) numRealTags - do i=1, numRealTags - read(fd, *) rval - end do - - read(fd,*) numIntTags - ! This must equal 3 - if(numIntTags .ne. 3) then - FLExit("Error: must be 3 GMSH integer tags in GMSH $NodeData section") - end if - - read(fd, *) timeStep - read(fd, *) numComponents - read(fd, *) numNodes - - ! More sanity checking - if(numNodes .ne. size(nodes) ) then - FLExit("Error: number of nodes for column IDs doesn't match node array") - end if - - ! Switch to binary if necessary - if(gmshFormat == binaryFormat) then - call binary_formatting(fd, filename, "read") - end if - - - ! Now read in the node column IDs - do i=1, numNodes - select case(gmshFormat) - case(asciiFormat) - read(fd, *) nodeIx, rval - case(binaryFormat) - read(fd ) nodeIx, rval - end select - nodes(i)%columnID = floor(rval) - end do - - ! Skip newline character when in binary mode - if( gmshFormat == binaryFormat ) then - read(fd) newlineChar - call ascii_formatting(fd, filename, "read") - end if + end subroutine read_nodes_coords_v4_binary + + + ! ----------------------------------------------------------------- + ! read in GMSH mesh nodes' column IDs (if exists) + + subroutine read_node_column_IDs( fd, filename, gmshFormat, nodes ) + integer, intent(in) :: fd, gmshFormat + character(len=*), intent(in) :: filename + type(GMSHnode), pointer :: nodes(:) + + character(len=longStringLen) :: charBuf + character :: newlineChar + + integer :: numStringTags, numRealTags, numIntTags + integer :: timeStep, numComponents, numNodes + integer :: i, nodeIx, fileState + real :: rval - ! Read in end node section - read(fd, *) charBuf - if( trim(charBuf) .ne. "$EndNodeData" ) then - FLExit("Error: cannot find '$EndNodeData' in GMSH mesh file") - end if + ! If there's no $NodeData section, don't try to read in column IDs: return + read(fd, iostat=fileState, fmt=*) charBuf + if (fileState<0) return ! end of file + if (trim(charBuf)/="$NodeData") return + + ! Sanity checking + read(fd, *) numStringTags + if(numStringTags .ne. 1) then + FLExit("Error: must have one string tag in GMSH file $NodeData part") + end if + read(fd, *) charBuf + if( trim(charBuf) .ne. "column_ids") then + FLExit("Error: GMSH string tag in $NodeData section != 'column_ids'") + end if + + ! Skip over these, not used (yet) + read(fd, *) numRealTags + do i=1, numRealTags + read(fd, *) rval + end do + + read(fd,*) numIntTags + ! This must equal 3 + if(numIntTags .ne. 3) then + FLExit("Error: must be 3 GMSH integer tags in GMSH $NodeData section") + end if + + read(fd, *) timeStep + read(fd, *) numComponents + read(fd, *) numNodes + + ! More sanity checking + if(numNodes .ne. size(nodes) ) then + FLExit("Error: number of nodes for column IDs doesn't match node array") + end if + + ! Switch to binary if necessary + if(gmshFormat == binaryFormat) then + call binary_formatting(fd, filename, "read") + end if + + + ! Now read in the node column IDs + do i=1, numNodes + select case(gmshFormat) + case(asciiFormat) + read(fd, *) nodeIx, rval + case(binaryFormat) + read(fd ) nodeIx, rval + end select + nodes(i)%columnID = floor(rval) + end do + + ! Skip newline character when in binary mode + if( gmshFormat == binaryFormat ) then + read(fd) newlineChar + call ascii_formatting(fd, filename, "read") + end if + + ! Read in end node section + read(fd, *) charBuf + if( trim(charBuf) .ne. "$EndNodeData" ) then + FLExit("Error: cannot find '$EndNodeData' in GMSH mesh file") + end if #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - if(gmshFormat == binaryFormat) read(fd, *) charBuf + if(gmshFormat == binaryFormat) read(fd, *) charBuf #endif - end subroutine read_node_column_IDs + end subroutine read_node_column_IDs - ! ----------------------------------------------------------------- - ! Read in ASCII-formatted GMSH 4 element header data and - ! establish topological dimension + ! ----------------------------------------------------------------- + ! Read in ASCII-formatted GMSH 4 element header data and + ! establish topological dimension - subroutine read_faces_and_elements_v4_ascii( fd, filename, & - versionNumber, elements, faces, dim, entityMap, entityTags, & - findElementData) + subroutine read_faces_and_elements_v4_ascii( fd, filename, & + versionNumber, elements, faces, dim, entityMap, entityTags, & + findElementData) - integer, intent(in) :: fd - character(len=*), intent(in) :: filename - type(version), intent(in) :: versionNumber - type(GMSHelement), pointer :: elements(:), faces(:) - integer, intent(out) :: dim + integer, intent(in) :: fd + character(len=*), intent(in) :: filename + type(version), intent(in) :: versionNumber + type(GMSHelement), pointer :: elements(:), faces(:) + integer, intent(out) :: dim - type(integer_hash_table), intent(in) :: entityMap(4) - integer, intent(in) :: entityTags(:) + type(integer_hash_table), intent(in) :: entityMap(4) + integer, intent(in) :: entityTags(:) - logical, intent(in) :: findElementData + logical, intent(in) :: findElementData - type(GMSHelement), pointer :: allElements(:) + type(GMSHelement), pointer :: allElements(:) - integer :: numEntities, numAllElements, minEle, maxEle, numTags - character(len=longStringLen) :: charBuf - integer :: elementType - integer :: e, j, k, numLocNodes - integer :: entityDim, entityTag, tag_index - integer :: numentityelements + integer :: numEntities, numAllElements, minEle, maxEle, numTags + character(len=longStringLen) :: charBuf + integer :: elementType + integer :: e, j, k, numLocNodes + integer :: entityDim, entityTag, tag_index + integer :: numentityelements - read(fd,*) charBuf - if( trim(charBuf) /= "$Elements" ) then - FLExit("Error: cannot find '$Elements' in GMSH mesh file") - end if + read(fd,*) charBuf + if( trim(charBuf) /= "$Elements" ) then + FLExit("Error: cannot find '$Elements' in GMSH mesh file") + end if - if (versionNumber%minor == 1) then - read(fd,*) numEntities, numAllElements, minEle, maxEle - else - read(fd,*) numEntities, numAllElements - end if + if (versionNumber%minor == 1) then + read(fd,*) numEntities, numAllElements, minEle, maxEle + else + read(fd,*) numEntities, numAllElements + end if - ! Sanity check. - if(numAllElements<1) then - FLExit("Error: number of elements in GMSH file < 1") - end if + ! Sanity check. + if(numAllElements<1) then + FLExit("Error: number of elements in GMSH file < 1") + end if - allocate( allElements(numAllElements) ) + allocate( allElements(numAllElements) ) - ! Read in GMSH elements, corresponding tags and nodes + ! Read in GMSH elements, corresponding tags and nodes - e = 0 + e = 0 - do j=1, numEntities + do j=1, numEntities - read(fd, "(a)", end=808) charBuf -808 if (versionNumber%minor == 1) then - read(charBuf, *) entityDim, entityTag, elementType, numEntityElements - else - read(charBuf, *) entityTag, entityDim, elementType, numEntityElements - end if + read(fd, "(a)", end=808) charBuf +808 if (versionNumber%minor == 1) then + read(charBuf, *) entityDim, entityTag, elementType, numEntityElements + else + read(charBuf, *) entityTag, entityDim, elementType, numEntityElements + end if - tag_index = fetch(entityMap(entityDim+1), entityTag) - numTags = entityTags(tag_index) + tag_index = fetch(entityMap(entityDim+1), entityTag) + numTags = entityTags(tag_index) - do k=1, numEntityElements - e = e + 1 - ! Read in whole line into a string buffer - read(fd, "(a)", end=880) charBuf - ! Now read from string buffer for main element info -880 allElements(e)%type = elementType - allElements(e)%numTags = numTags + do k=1, numEntityElements + e = e + 1 + ! Read in whole line into a string buffer + read(fd, "(a)", end=880) charBuf + ! Now read from string buffer for main element info +880 allElements(e)%type = elementType + allElements(e)%numTags = numTags - numLocNodes = elementNumNodes(allElements(e)%type) - allocate( allElements(e)%nodeIDs(numLocNodes) ) - allocate( allElements(e)%tags( allElements(e)%numTags) ) + numLocNodes = elementNumNodes(allElements(e)%type) + allocate( allElements(e)%nodeIDs(numLocNodes) ) + allocate( allElements(e)%tags( allElements(e)%numTags) ) - ! Now read in tags and node IDs - read(charBuf, *) allElements(e)%elementID, allElements(e)%nodeIDs - allElements(e)%tags = entityTags(tag_index+1:tag_index+numTags) + ! Now read in tags and node IDs + read(charBuf, *) allElements(e)%elementID, allElements(e)%nodeIDs + allElements(e)%tags = entityTags(tag_index+1:tag_index+numTags) - end do - end do + end do + end do - ! Check for $EndElements tag - read(fd,*) charBuf - if( trim(charBuf) /= "$EndElements" ) then - FLExit("Error: cannot find '$EndElements' in GMSH mesh file") - end if + ! Check for $EndElements tag + read(fd,*) charBuf + if( trim(charBuf) /= "$EndElements" ) then + FLExit("Error: cannot find '$EndElements' in GMSH mesh file") + end if - ! if we need, get tags from the $ElementData section - if (findElementData) then - call read_element_data_v4_ascii(fd, numAllElements, allElements) - end if + ! if we need, get tags from the $ElementData section + if (findElementData) then + call read_element_data_v4_ascii(fd, numAllElements, allElements) + end if - call process_gmsh_elements(numAllElements, allElements, elements, faces, dim) + call process_gmsh_elements(numAllElements, allElements, elements, faces, dim) - ! We no longer need this - call deallocateElementList( allElements ) + ! We no longer need this + call deallocateElementList( allElements ) - end subroutine read_faces_and_elements_v4_ascii + end subroutine read_faces_and_elements_v4_ascii - ! ----------------------------------------------------------------- - ! Read in GMSH 4 element data header - ! This is ascii regardless of the file format - subroutine read_element_data_v4_common(fd) - integer, intent(in) :: fd + ! ----------------------------------------------------------------- + ! Read in GMSH 4 element data header + ! This is ascii regardless of the file format + subroutine read_element_data_v4_common(fd) + integer, intent(in) :: fd - character(len=longStringLen) :: charBuf - integer :: numStringTags, numRealTags, numIntegerTags - integer :: stat, tmpInt, i - real :: tmpReal + character(len=longStringLen) :: charBuf + integer :: numStringTags, numRealTags, numIntegerTags + integer :: stat, tmpInt, i + real :: tmpReal - read (fd, *, iostat=stat) charBuf - do while (trim(charBuf) /= "$ElementData" .and. stat == 0) read (fd, *, iostat=stat) charBuf - if (stat /= 0) then - FLExit("Error: cannot find '$ElementData' in GMSH mesh file") - end if - end do - - ! string tags first - read (fd, *) numStringTags - do i = 1, numStringTags - ! just read and discard the tags - ! they're double-quote delimited, and fortran just handles that - ! magically... + do while (trim(charBuf) /= "$ElementData" .and. stat == 0) + read (fd, *, iostat=stat) charBuf + if (stat /= 0) then + FLExit("Error: cannot find '$ElementData' in GMSH mesh file") + end if + end do + + ! string tags first + read (fd, *) numStringTags + do i = 1, numStringTags + ! just read and discard the tags + ! they're double-quote delimited, and fortran just handles that + ! magically... + read (fd, *) charBuf + + if (trim(charBuf) /= "gmsh:physical") then + FLExit("Error: expected to find physical IDs in $ElementData") + end if + end do + + ! real tags (apparently for timesteps) + read (fd, *) numRealTags + do i = 1, numRealTags + read (fd, *) tmpReal + end do + + ! integer tags, canonically time step index, field components in view, entities in view + read (fd, *) numIntegerTags + do i = 1, numIntegerTags + read (fd, *) tmpInt + end do + end subroutine read_element_data_v4_common + + ! ----------------------------------------------------------------- + ! Read in ASCII-formatted GMSH 4 element data associating + ! elements with physical tags, when the Entities section is + ! omitted + subroutine read_element_data_v4_ascii(fd, numAllElements, allElements) + integer, intent(in) :: fd, numAllElements + type(GMSHelement), pointer :: allElements(:) + + integer :: i, e + real :: id + character(len=longStringLen) :: charBuf + + ! skip through the common header data + call read_element_data_v4_common(fd) + + ! now we have what we're interested in: a map between element tags and the physical entity ID + do i = 1, numAllElements + read (fd, *) e, id + allElements(e)%tags(1) = int(id) + end do + read (fd, *) charBuf + if (trim(charBuf) /= "$EndElementData") then + FLExit("Error: cannot find '$EndElementData' in GMSH mesh file") + end if + end subroutine read_element_data_v4_ascii + + ! ----------------------------------------------------------------- + ! Read in binary GMSH 4 element header data and + ! establish topological dimension + + subroutine read_faces_and_elements_v4_binary( fd, filename, & + versionNumber, elements, faces, dim, entityMap, entityTags, & + findElementData) + + integer, intent(in) :: fd + character(len=*), intent(in) :: filename + type(version), intent(in) :: versionNumber + type(GMSHelement), pointer :: elements(:), faces(:) + integer, intent(out) :: dim - if (trim(charBuf) /= "gmsh:physical") then - FLExit("Error: expected to find physical IDs in $ElementData") + type(integer_hash_table), intent(in) :: entityMap(4) + integer, intent(in) :: entityTags(:) + + logical, intent(in) :: findElementData + + type(GMSHelement), pointer :: allElements(:) + + integer(kind=c_long) :: numEntities, numAllElements, minEle, maxEle, numTags + character(len=longStringLen) :: charBuf + character :: newlineChar + integer :: elementType + integer :: e, j, k, numLocNodes + integer :: entityDim, entityTag, tag_index + integer(kind=c_long) :: numentityelements + + integer(kind=c_long), allocatable :: vltmp(:) + + read(fd,*) charBuf + if( trim(charBuf)/="$Elements" ) then + FLExit("Error: cannot find '$Elements' in GMSH mesh file") + end if + + call binary_formatting(fd, filename, "read") + if (versionNumber%minor == 1) then + read(fd) numEntities, numAllElements, minEle, maxEle + else + read(fd) numEntities, numAllElements + end if + + ! Sanity check. + if(numAllElements<1) then + FLExit("Error: number of elements in GMSH file < 1") end if - end do - - ! real tags (apparently for timesteps) - read (fd, *) numRealTags - do i = 1, numRealTags - read (fd, *) tmpReal - end do - - ! integer tags, canonically time step index, field components in view, entities in view - read (fd, *) numIntegerTags - do i = 1, numIntegerTags - read (fd, *) tmpInt - end do - end subroutine read_element_data_v4_common - - ! ----------------------------------------------------------------- - ! Read in ASCII-formatted GMSH 4 element data associating - ! elements with physical tags, when the Entities section is - ! omitted - subroutine read_element_data_v4_ascii(fd, numAllElements, allElements) - integer, intent(in) :: fd, numAllElements - type(GMSHelement), pointer :: allElements(:) - - integer :: i, e - real :: id - character(len=longStringLen) :: charBuf - - ! skip through the common header data - call read_element_data_v4_common(fd) - - ! now we have what we're interested in: a map between element tags and the physical entity ID - do i = 1, numAllElements - read (fd, *) e, id - allElements(e)%tags(1) = int(id) - end do - - read (fd, *) charBuf - if (trim(charBuf) /= "$EndElementData") then - FLExit("Error: cannot find '$EndElementData' in GMSH mesh file") - end if - end subroutine read_element_data_v4_ascii - - ! ----------------------------------------------------------------- - ! Read in binary GMSH 4 element header data and - ! establish topological dimension - - subroutine read_faces_and_elements_v4_binary( fd, filename, & - versionNumber, elements, faces, dim, entityMap, entityTags, & - findElementData) - - integer, intent(in) :: fd - character(len=*), intent(in) :: filename - type(version), intent(in) :: versionNumber - type(GMSHelement), pointer :: elements(:), faces(:) - integer, intent(out) :: dim - - type(integer_hash_table), intent(in) :: entityMap(4) - integer, intent(in) :: entityTags(:) - - logical, intent(in) :: findElementData - - type(GMSHelement), pointer :: allElements(:) - - integer(kind=c_long) :: numEntities, numAllElements, minEle, maxEle, numTags - character(len=longStringLen) :: charBuf - character :: newlineChar - integer :: elementType - integer :: e, j, k, numLocNodes - integer :: entityDim, entityTag, tag_index - integer(kind=c_long) :: numentityelements - - integer(kind=c_long), allocatable :: vltmp(:) - - read(fd,*) charBuf - if( trim(charBuf)/="$Elements" ) then - FLExit("Error: cannot find '$Elements' in GMSH mesh file") - end if - - call binary_formatting(fd, filename, "read") - if (versionNumber%minor == 1) then - read(fd) numEntities, numAllElements, minEle, maxEle - else - read(fd) numEntities, numAllElements - end if - - ! Sanity check. - if(numAllElements<1) then - FLExit("Error: number of elements in GMSH file < 1") - end if - - allocate( allElements(numAllElements) ) - - ! Read in GMSH elements, corresponding tags and nodes - e = 0 - do j = 1, numEntities - if (versionNumber%minor == 1) then - read(fd) entityDim, entityTag, elementType, numEntityElements - else - read(fd) entityTag, entityDim, elementType, numEntityElements - end if - - tag_index = fetch(entityMap(entityDim+1), entityTag) - numTags = entityTags(tag_index) - numLocNodes = elementNumNodes(elementType) - if (versionNumber%minor == 1) allocate(vltmp(numLocNodes+1)) - - ! Read in elements in a particular entity block - do k = 1, numEntityElements - e = e + 1 - - allocate(allElements(e)%nodeIDs(numLocNodes)) - allocate(allElements(e)%tags(numTags)) - - allElements(e)%type = elementType - allElements(e)%numTags = numTags - allElements(e)%tags = entityTags(tag_index+1:tag_index+numTags) + allocate( allElements(numAllElements) ) + + ! Read in GMSH elements, corresponding tags and nodes + e = 0 + do j = 1, numEntities if (versionNumber%minor == 1) then - read(fd) vltmp - allElements(e)%elementID = vltmp(1) - allElements(e)%nodeIDs = vltmp(2:numLocNodes+1) + read(fd) entityDim, entityTag, elementType, numEntityElements else - read(fd) allElements(e)%elementID, allElements(e)%nodeIDs + read(fd) entityTag, entityDim, elementType, numEntityElements end if - end do - if (versionNumber%minor == 1) deallocate(vltmp) - end do + tag_index = fetch(entityMap(entityDim+1), entityTag) + numTags = entityTags(tag_index) + numLocNodes = elementNumNodes(elementType) + if (versionNumber%minor == 1) allocate(vltmp(numLocNodes+1)) + + ! Read in elements in a particular entity block + do k = 1, numEntityElements + e = e + 1 + + allocate(allElements(e)%nodeIDs(numLocNodes)) + allocate(allElements(e)%tags(numTags)) + + allElements(e)%type = elementType + allElements(e)%numTags = numTags + allElements(e)%tags = entityTags(tag_index+1:tag_index+numTags) + if (versionNumber%minor == 1) then + read(fd) vltmp + allElements(e)%elementID = vltmp(1) + allElements(e)%nodeIDs = vltmp(2:numLocNodes+1) + else + read(fd) allElements(e)%elementID, allElements(e)%nodeIDs + end if + end do - ! Skip final newline - read(fd) newlineChar - call ascii_formatting( fd, filename, "read" ) + if (versionNumber%minor == 1) deallocate(vltmp) + end do + + + ! Skip final newline + read(fd) newlineChar + call ascii_formatting( fd, filename, "read" ) - ! Check for $EndElements tag - read(fd,*) charBuf - if( trim(charBuf) /= "$EndElements" ) then - FLExit("Error: cannot find '$EndElements' in GMSH mesh file") - end if + ! Check for $EndElements tag + read(fd,*) charBuf + if( trim(charBuf) /= "$EndElements" ) then + FLExit("Error: cannot find '$EndElements' in GMSH mesh file") + end if #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - read(fd, *) charBuf + read(fd, *) charBuf #endif - ! if we need, get tags from the $ElementData section - if (findElementData) then - call read_element_data_v4_binary(fd, filename, numAllElements, allElements) - end if + ! if we need, get tags from the $ElementData section + if (findElementData) then + call read_element_data_v4_binary(fd, filename, numAllElements, allElements) + end if - call process_gmsh_elements(int(numAllElements), allElements, elements, faces, dim) + call process_gmsh_elements(int(numAllElements), allElements, elements, faces, dim) - ! We no longer need this - call deallocateElementList( allElements ) + ! We no longer need this + call deallocateElementList( allElements ) - end subroutine read_faces_and_elements_v4_binary + end subroutine read_faces_and_elements_v4_binary - ! ----------------------------------------------------------------- - ! Read in binary GMSH 4 element data associating - ! elements with physical tags, when the Entities section is - ! omitted - subroutine read_element_data_v4_binary(fd, filename, numAllElements, allElements) - integer, intent(in) :: fd - character(len=*), intent(in) :: filename - integer(kind=c_long), intent(in) :: numAllElements - type(GMSHelement), pointer :: allElements(:) + ! ----------------------------------------------------------------- + ! Read in binary GMSH 4 element data associating + ! elements with physical tags, when the Entities section is + ! omitted + subroutine read_element_data_v4_binary(fd, filename, numAllElements, allElements) + integer, intent(in) :: fd + character(len=*), intent(in) :: filename + integer(kind=c_long), intent(in) :: numAllElements + type(GMSHelement), pointer :: allElements(:) - integer :: i, e - real(kind=c_double) :: id - character(len=longStringLen) :: charBuf - character :: newlineChar + integer :: i, e + real(kind=c_double) :: id + character(len=longStringLen) :: charBuf + character :: newlineChar - ! skip through the common header data - call read_element_data_v4_common(fd) + ! skip through the common header data + call read_element_data_v4_common(fd) - call binary_formatting(fd, filename, "read") - do i = 1, numAllElements - read (fd) e, id - allElements(e)%tags(1) = id - end do + call binary_formatting(fd, filename, "read") + do i = 1, numAllElements + read (fd) e, id + allElements(e)%tags(1) = id + end do - read (fd) newlineChar - call ascii_formatting(fd, filename, "read") + read (fd) newlineChar + call ascii_formatting(fd, filename, "read") - read (fd, *) charBuf - if (trim(charBuf) /= "$EndElementData") then - FLExit("Error: cannot find '$EndElementData' in GMSH mesh file") - end if + read (fd, *) charBuf + if (trim(charBuf) /= "$EndElementData") then + FLExit("Error: cannot find '$EndElementData' in GMSH mesh file") + end if #ifdef IO_ADVANCE_BUG - read(fd, *) charBuf + read(fd, *) charBuf #endif - end subroutine read_element_data_v4_binary + end subroutine read_element_data_v4_binary - ! ----------------------------------------------------------------- - ! Read in GMSH 2 element header data and - ! establish topological dimension + ! ----------------------------------------------------------------- + ! Read in GMSH 2 element header data and + ! establish topological dimension - subroutine read_faces_and_elements_v2( fd, filename, gmshFormat, & - elements, faces, dim) + subroutine read_faces_and_elements_v2( fd, filename, gmshFormat, & + elements, faces, dim) - integer, intent(in) :: fd, gmshFormat - character(len=*), intent(in) :: filename - type(GMSHelement), pointer :: elements(:), faces(:) - integer, intent(out) :: dim + integer, intent(in) :: fd, gmshFormat + character(len=*), intent(in) :: filename + type(GMSHelement), pointer :: elements(:), faces(:) + integer, intent(out) :: dim - type(GMSHelement), pointer :: allElements(:) + type(GMSHelement), pointer :: allElements(:) - integer :: numAllElements - character(len=longStringLen) :: charBuf - character :: newlineChar - integer :: e, i, numLocNodes, tmp1, tmp2, tmp3 - integer :: groupType, groupElems, groupTags + integer :: numAllElements + character(len=longStringLen) :: charBuf + character :: newlineChar + integer :: e, i, numLocNodes, tmp1, tmp2, tmp3 + integer :: groupType, groupElems, groupTags - read(fd,*) charBuf - if( trim(charBuf)/="$Elements" ) then - FLExit("Error: cannot find '$Elements' in GMSH mesh file") - end if + read(fd,*) charBuf + if( trim(charBuf)/="$Elements" ) then + FLExit("Error: cannot find '$Elements' in GMSH mesh file") + end if - read(fd,*) numAllElements + read(fd,*) numAllElements - ! Sanity check. - if(numAllElements<1) then - FLExit("Error: number of elements in GMSH file < 1") - end if + ! Sanity check. + if(numAllElements<1) then + FLExit("Error: number of elements in GMSH file < 1") + end if - allocate( allElements(numAllElements) ) + allocate( allElements(numAllElements) ) - ! Read in GMSH elements, corresponding tags and nodes + ! Read in GMSH elements, corresponding tags and nodes - select case(gmshFormat) + select case(gmshFormat) - ! ASCII is straightforward - case (asciiFormat) + ! ASCII is straightforward + case (asciiFormat) - do e=1, numAllElements - ! Read in whole line into a string buffer - read(fd, "(a)", end=888) charBuf - ! Now read from string buffer for main element info -888 read(charBuf, *) allElements(e)%elementID, allElements(e)%type, & + do e=1, numAllElements + ! Read in whole line into a string buffer + read(fd, "(a)", end=888) charBuf + ! Now read from string buffer for main element info +888 read(charBuf, *) allElements(e)%elementID, allElements(e)%type, & allElements(e)%numTags - numLocNodes = elementNumNodes(allElements(e)%type) - allocate( allElements(e)%nodeIDs(numLocNodes) ) - allocate( allElements(e)%tags( allElements(e)%numTags) ) + numLocNodes = elementNumNodes(allElements(e)%type) + allocate( allElements(e)%nodeIDs(numLocNodes) ) + allocate( allElements(e)%tags( allElements(e)%numTags) ) - ! Now read in tags and node IDs - read(charBuf, *) tmp1, tmp2, tmp3, & + ! Now read in tags and node IDs + read(charBuf, *) tmp1, tmp2, tmp3, & allElements(e)%tags, allElements(e)%nodeIDs - end do + end do - case (binaryFormat) - ! Make sure raw stream format is on - call binary_formatting( fd, filename, "read" ) + case (binaryFormat) + ! Make sure raw stream format is on + call binary_formatting( fd, filename, "read" ) - e=1 + e=1 - ! GMSH groups elements by type: - ! the code below reads in one type of element in a block, followed - ! by other types until all the elements have been read in. - do while( e .le. numAllelements ) - read(fd) groupType, groupElems, groupTags + ! GMSH groups elements by type: + ! the code below reads in one type of element in a block, followed + ! by other types until all the elements have been read in. + do while( e .le. numAllelements ) + read(fd) groupType, groupElems, groupTags - if( (e-1)+groupElems .gt. numAllElements ) then - FLExit("GMSH element group contains more than the total") - end if + if( (e-1)+groupElems .gt. numAllElements ) then + FLExit("GMSH element group contains more than the total") + end if - ! Read in elements in a particular type block - do i=e, (e-1)+groupElems - numLocNodes = elementNumNodes(groupType) - allocate( allElements(i)%nodeIDs(numLocNodes) ) - allocate( allElements(i)%tags( groupTags ) ) + ! Read in elements in a particular type block + do i=e, (e-1)+groupElems + numLocNodes = elementNumNodes(groupType) + allocate( allElements(i)%nodeIDs(numLocNodes) ) + allocate( allElements(i)%tags( groupTags ) ) - allElements(i)%type = groupType - allElements(i)%numTags = groupTags + allElements(i)%type = groupType + allElements(i)%numTags = groupTags - read(fd) allElements(i)%elementID, allElements(i)%tags, & + read(fd) allElements(i)%elementID, allElements(i)%tags, & allElements(i)%nodeIDs - end do + end do - e = e+groupElems - end do + e = e+groupElems + end do - end select + end select - ! Skip final newline - if(gmshFormat==binaryFormat) then - read(fd) newlineChar - call ascii_formatting( fd, filename, "read" ) - end if + ! Skip final newline + if(gmshFormat==binaryFormat) then + read(fd) newlineChar + call ascii_formatting( fd, filename, "read" ) + end if - ! Check for $EndElements tag - read(fd,*) charBuf - if( trim(charBuf) .ne. "$EndElements" ) then - FLExit("Error: cannot find '$EndElements' in GMSH mesh file") - end if + ! Check for $EndElements tag + read(fd,*) charBuf + if( trim(charBuf) .ne. "$EndElements" ) then + FLExit("Error: cannot find '$EndElements' in GMSH mesh file") + end if #ifdef IO_ADVANCE_BUG ! for intel the call to ascii_formatting causes the first read after it to have advance='no' ! therefore forcing it to jump to a newline here - if(gmshFormat == binaryFormat) read(fd, *) charBuf + if(gmshFormat == binaryFormat) read(fd, *) charBuf #endif - call process_gmsh_elements(numAllElements, allElements, elements, faces, dim) + call process_gmsh_elements(numAllElements, allElements, elements, faces, dim) - ! We no longer need this - call deallocateElementList( allElements ) + ! We no longer need this + call deallocateElementList( allElements ) - end subroutine read_faces_and_elements_v2 + end subroutine read_faces_and_elements_v2 - ! ----------------------------------------------------------------- - ! Process faces and elements according to their types + ! ----------------------------------------------------------------- + ! Process faces and elements according to their types - subroutine process_gmsh_elements(numAllElements, allElements, elements, faces, dim) + subroutine process_gmsh_elements(numAllElements, allElements, elements, faces, dim) - integer, intent(in) :: numAllElements - type(GMSHelement), pointer :: allElements(:) - type(GMSHelement), pointer :: elements(:), faces(:) - integer, intent(out) :: dim + integer, intent(in) :: numAllElements + type(GMSHelement), pointer :: allElements(:) + type(GMSHelement), pointer :: elements(:), faces(:) + integer, intent(out) :: dim - integer :: numEdges, numTriangles, numQuads, numTets, numHexes, numVertices - integer :: numFaces, faceType, numElements, elementType - integer :: e + integer :: numEdges, numTriangles, numQuads, numTets, numHexes, numVertices + integer :: numFaces, faceType, numElements, elementType + integer :: e - ! Run through final list of elements, reorder nodes etc. - numEdges = 0 - numTriangles = 0 - numTets = 0 - numQuads = 0 - numHexes = 0 - numVertices = 0 + ! Run through final list of elements, reorder nodes etc. + numEdges = 0 + numTriangles = 0 + numTets = 0 + numQuads = 0 + numHexes = 0 + numVertices = 0 - ! Now we've got all our elements in memory, do some housekeeping. - do e=1, numAllElements + ! Now we've got all our elements in memory, do some housekeeping. + do e=1, numAllElements - call toFluidityElementNodeOrdering( allElements(e)%nodeIDs, & + call toFluidityElementNodeOrdering( allElements(e)%nodeIDs, & allElements(e)%type ) - select case ( allElements(e)%type ) - case (GMSH_LINE) - numEdges = numEdges+1 - case (GMSH_TRIANGLE) - numTriangles = numTriangles+1 - case (GMSH_QUAD) - numQuads = numQuads+1 - case (GMSH_TET) - numTets = numTets+1 - case (GMSH_HEX) - numHexes = numHexes+1 - case (GMSH_NODE) - numVertices = numVertices+1 - case default - ewrite(0,*) "element id,type: ", allElements(e)%elementID, allElements(e)%type - FLExit("Unsupported element type in gmsh .msh file") - end select - - end do - - ! This decides which element types are faces, and which are - ! regular elements, as per gmsh2triangle logic. Implicit in that logic - ! is that faces can only be of one element type, and so the following - ! meshes are verboten: - ! tet/hex, tet/quad, triangle/hex and triangle/quad - - if (numTets>0) then - numElements = numTets - elementType = GMSH_TET - numFaces = numTriangles - faceType = GMSH_TRIANGLE - dim = 3 - if (numQuads>0 .or. numHexes>0) then - FLExit("Cannot combine hexes or quads with tetrahedrals in one gmsh .msh file") - end if - - elseif (numTriangles>0) then - numElements = numTriangles - elementType = GMSH_TRIANGLE - numFaces = numEdges - faceType = GMSH_LINE - dim = 2 - if (numQuads>0 .or. numHexes>0) then - FLExit("Cannot combine hexes or quads with triangles in one gmsh .msh file") - end if - - elseif (numHexes > 0) then - numElements = numHexes - elementType = GMSH_HEX - numFaces = numQuads - faceType = GMSH_QUAD - dim = 3 - - elseif (numQuads > 0) then - numElements = numQuads - elementType = GMSH_QUAD - numFaces = numEdges - faceType = GMSH_LINE - dim = 2 - - elseif (numEdges > 0) then - numElements = numEdges - elementType = GMSH_LINE - numFaces = numVertices - faceType = GMSH_NODE - dim = 1 - - else - FLExit("Unsupported mixture of face/element types") - end if - - call copy_to_faces_and_elements( allElements, & + select case ( allElements(e)%type ) + case (GMSH_LINE) + numEdges = numEdges+1 + case (GMSH_TRIANGLE) + numTriangles = numTriangles+1 + case (GMSH_QUAD) + numQuads = numQuads+1 + case (GMSH_TET) + numTets = numTets+1 + case (GMSH_HEX) + numHexes = numHexes+1 + case (GMSH_NODE) + numVertices = numVertices+1 + case default + ewrite(0,*) "element id,type: ", allElements(e)%elementID, allElements(e)%type + FLExit("Unsupported element type in gmsh .msh file") + end select + + end do + + ! This decides which element types are faces, and which are + ! regular elements, as per gmsh2triangle logic. Implicit in that logic + ! is that faces can only be of one element type, and so the following + ! meshes are verboten: + ! tet/hex, tet/quad, triangle/hex and triangle/quad + + if (numTets>0) then + numElements = numTets + elementType = GMSH_TET + numFaces = numTriangles + faceType = GMSH_TRIANGLE + dim = 3 + if (numQuads>0 .or. numHexes>0) then + FLExit("Cannot combine hexes or quads with tetrahedrals in one gmsh .msh file") + end if + + elseif (numTriangles>0) then + numElements = numTriangles + elementType = GMSH_TRIANGLE + numFaces = numEdges + faceType = GMSH_LINE + dim = 2 + if (numQuads>0 .or. numHexes>0) then + FLExit("Cannot combine hexes or quads with triangles in one gmsh .msh file") + end if + + elseif (numHexes > 0) then + numElements = numHexes + elementType = GMSH_HEX + numFaces = numQuads + faceType = GMSH_QUAD + dim = 3 + + elseif (numQuads > 0) then + numElements = numQuads + elementType = GMSH_QUAD + numFaces = numEdges + faceType = GMSH_LINE + dim = 2 + + elseif (numEdges > 0) then + numElements = numEdges + elementType = GMSH_LINE + numFaces = numVertices + faceType = GMSH_NODE + dim = 1 + + else + FLExit("Unsupported mixture of face/element types") + end if + + call copy_to_faces_and_elements( allElements, & elements, numElements, elementType, & faces, numFaces, faceType ) - end subroutine process_gmsh_elements + end subroutine process_gmsh_elements - ! ----------------------------------------------------------------- - ! This copies elements from allElements(:) to elements(:) and faces(:), - ! depending upon the element type definition of faces. + ! ----------------------------------------------------------------- + ! This copies elements from allElements(:) to elements(:) and faces(:), + ! depending upon the element type definition of faces. - subroutine copy_to_faces_and_elements( allElements, & - elements, numElements, elementType, & - faces, numFaces, faceType ) + subroutine copy_to_faces_and_elements( allElements, & + elements, numElements, elementType, & + faces, numFaces, faceType ) - type(GMSHelement), pointer :: allElements(:), elements(:), faces(:) - integer :: numElements, elementType, numFaces, faceType + type(GMSHelement), pointer :: allElements(:), elements(:), faces(:) + integer :: numElements, elementType, numFaces, faceType - integer :: allelementType - integer :: e, fIndex, eIndex, numTags, numNodeIDs + integer :: allelementType + integer :: e, fIndex, eIndex, numTags, numNodeIDs - allocate( elements(numElements) ) - allocate( faces(numFaces) ) + allocate( elements(numElements) ) + allocate( faces(numFaces) ) - fIndex=1 - eIndex=1 + fIndex=1 + eIndex=1 - ! Copy element data across. Only array pointers are copied, which - ! is why we don't deallocate nodeIDs(:), etc. - do e=1, size(allElements) - allelementType = allElements(e)%type + ! Copy element data across. Only array pointers are copied, which + ! is why we don't deallocate nodeIDs(:), etc. + do e=1, size(allElements) + allelementType = allElements(e)%type - numTags = allElements(e)%numTags - numNodeIDs = size(allElements(e)%nodeIDs) + numTags = allElements(e)%numTags + numNodeIDs = size(allElements(e)%nodeIDs) - if(allelementType .eq. faceType) then + if(allelementType .eq. faceType) then - faces(fIndex) = allElements(e) + faces(fIndex) = allElements(e) - allocate( faces(fIndex)%tags(numTags) ) - allocate( faces(fIndex)%nodeIDs(numNodeIDs) ) - faces(fIndex)%tags = allElements(e)%tags - faces(fIndex)%nodeIDs = allElements(e)%nodeIDs + allocate( faces(fIndex)%tags(numTags) ) + allocate( faces(fIndex)%nodeIDs(numNodeIDs) ) + faces(fIndex)%tags = allElements(e)%tags + faces(fIndex)%nodeIDs = allElements(e)%nodeIDs - fIndex = fIndex+1 - else if (allelementType .eq. elementType) then + fIndex = fIndex+1 + else if (allelementType .eq. elementType) then - elements(eIndex) = allElements(e) + elements(eIndex) = allElements(e) - allocate( elements(eIndex)%tags(numTags) ) - allocate( elements(eIndex)%nodeIDs(numNodeIDs) ) - elements(eIndex)%tags = allElements(e)%tags - elements(eIndex)%nodeIDs = allElements(e)%nodeIDs + allocate( elements(eIndex)%tags(numTags) ) + allocate( elements(eIndex)%nodeIDs(numNodeIDs) ) + elements(eIndex)%tags = allElements(e)%tags + elements(eIndex)%nodeIDs = allElements(e)%nodeIDs - eIndex = eIndex+1 - end if - end do + eIndex = eIndex+1 + end if + end do - end subroutine copy_to_faces_and_elements + end subroutine copy_to_faces_and_elements end module read_gmsh diff --git a/femtools/Read_Triangle.F90 b/femtools/Read_Triangle.F90 index 07f8deb420..d69f135d97 100644 --- a/femtools/Read_Triangle.F90 +++ b/femtools/Read_Triangle.F90 @@ -28,918 +28,918 @@ #include "fdebug.h" module read_triangle - !!< This module reads triangle files and results in a vector field of - !!< positions. + !!< This module reads triangle files and results in a vector field of + !!< positions. - use fldebug - use futils - use quadrature - use element_numbering - use elements - use spud - use parallel_tools - use fields - use state_module + use fldebug + use futils + use quadrature + use element_numbering + use elements + use spud + use parallel_tools + use fields + use state_module - implicit none + implicit none - private + private - interface read_triangle_files - module procedure read_triangle_files_to_field, read_triangle_simple - end interface + interface read_triangle_files + module procedure read_triangle_files_to_field, read_triangle_simple + end interface - public :: read_triangle_files, identify_triangle_file, read_elemental_mappings, read_triangle_serial + public :: read_triangle_files, identify_triangle_file, read_elemental_mappings, read_triangle_serial contains - subroutine identify_triangle_file(filename, dim, loc, nodes, elements, & - node_attributes, selements, selement_boundaries) - !!< Discover the dimension and size of the triangle inputs. - !!< Filename is the base name of the triangle file without .node or .ele. - !!< In parallel, filename must *include* the process number. - - character(len=*), intent(in) :: filename - !! Dimension of mesh elements. - integer, intent(out), optional :: dim - !! Number of vertices of elements. - integer, intent(out), optional :: loc - !! Node and element counts. - integer, intent(out), optional :: nodes, elements - integer, intent(out), optional :: node_attributes - ! Surface element meta data - integer, optional, intent(out) :: selements - integer, optional, intent(out) :: selement_boundaries - - integer :: node_unit, element_unit, selement_unit - integer :: lnodes, ldim, lnode_attributes, node_boundaries - integer :: lelements, lloc, ele_attributes - integer :: lselements, lselement_boundaries - logical :: file_exists - - ! Read node file header - inquire(file = trim(filename) // ".node", exist = file_exists) - if(.not. file_exists) then - ewrite(-1, *) "For triangle file with base name " // trim(filename) - FLExit(".node file not found") - end if - ewrite(2, *) "Opening " // trim(filename) // ".node for reading." - node_unit = free_unit() - open(unit = node_unit, file = trim(filename) // ".node", err = 42, action = "read") - read (node_unit, *) lnodes, ldim, lnode_attributes, node_boundaries - close(node_unit) - - ! Read volume element file header - lelements = 0 - lloc = 0 - ele_attributes = 0 - inquire(file = trim(filename) // ".ele", exist = file_exists) - if(file_exists) then - ewrite(2, *) "Opening " // trim(filename) // ".ele for reading" - element_unit = free_unit() - open(unit = element_unit, file = trim(filename) // ".ele", err = 43, action = "read") - read (element_unit, *) lelements, lloc, ele_attributes - close(element_unit) - else if (present(loc) .or. present(elements)) then - ewrite(-1, *) "For triangle file with base name " // trim(filename) - FLExit(".ele file not found") - end if - - ! Read the surface element file header - lselements = 0 - lselement_boundaries = 0 - select case(ldim) - case(1) - inquire(file = trim(filename) // ".bound", exist = file_exists) - if(file_exists) then - ewrite(2, *) "Opening " // trim(filename) // ".bound for reading" - selement_unit = free_unit() - open(unit = selement_unit, file = trim(filename) // ".bound", err = 44, action = "read") - read(selement_unit, *) lselements, lselement_boundaries - close(selement_unit) - end if - case(2) - inquire(file = trim(filename) // ".edge", exist = file_exists) - if(file_exists) then - ewrite(2, *) "Opening " // trim(filename) // ".edge for reading" - selement_unit = free_unit() - open(unit = selement_unit, file = trim(filename) // ".edge", err = 45, action = "read") - read(selement_unit, *) lselements, lselement_boundaries - close(selement_unit) - end if - case(3) - inquire(file = trim(filename) // ".face", exist = file_exists) - if(file_exists) then - ewrite(2, *) "Opening " // trim(filename) // ".face for reading" - selement_unit = free_unit() - open(unit = selement_unit, file = trim(filename) // ".face", err = 46, action = "read") - read(selement_unit, *) lselements, lselement_boundaries - close(selement_unit) - end if - end select - - if(present(nodes)) then - nodes = lnodes - end if - if(present(dim)) then - dim = ldim - end if - if(present(node_attributes)) then - node_attributes = lnode_attributes - end if - if(present(loc)) then - loc = lloc - end if - if(present(elements)) then - elements = lelements - end if - if(present(selements)) then - selements = lselements - end if - if(present(selement_boundaries)) then - selement_boundaries = lselement_boundaries - end if - - return - -42 FLExit("Unable to open "//trim(filename)//".node") - -43 FLExit("Unable to open "//trim(filename)//".ele") - -44 FLExit("Unable to open " // trim(filename) // ".bound") - -45 FLExit("Unable to open " // trim(filename) // ".edge") - -46 FLExit("Unable to open " // trim(filename) // ".face") - - end subroutine identify_triangle_file - - function read_triangle_files_to_field(filename, shape) result (field) - !!< Filename is the base name of the triangle file without .node or .ele . - !!< In parallel the filename must *not* include the process number. - - character(len=*), intent(in) :: filename - type(element_type), intent(in), target :: shape - type(vector_field) :: field - - integer :: node_unit, ele_unit - real, allocatable, dimension(:) :: read_buffer - integer, allocatable, dimension(:,:) :: edge_buffer - integer, allocatable, dimension(:) :: sndglno - integer, allocatable, dimension(:) :: boundary_ids, element_owner - - character(len = parallel_filename_len(filename)) :: lfilename - integer :: i, j, nodes, dim, xdim, node_attributes, boundaries,& - & ele_attributes, loc, sloc, elements, edges, edge_count, gdim - integer, allocatable, dimension(:):: node_order - logical :: file_exists - type(mesh_type) :: mesh - - ! If running in parallel, add the process number - if(isparallel()) then - lfilename = parallel_filename(filename) - else - lfilename = trim(filename) - end if - - node_unit=free_unit() - - ewrite(2, *) "Opening "//trim(lfilename)//".node for reading." - ! Open node file - open(unit=node_unit, file=trim(lfilename)//".node", err=42, action="read") - - ! Read node file header. - read (node_unit, *) nodes, xdim, node_attributes, boundaries - - ele_unit=free_unit() - - ewrite(2, *) "Opening "//trim(lfilename)//".ele for reading." - ! Open element file - open(unit=ele_unit, file=trim(lfilename)//".ele", err=43, action="read") - - ! Read element file header. - read (ele_unit, *) elements, loc, ele_attributes - - assert(loc==shape%loc) - allocate(node_order(loc)) - select case(loc) - case(3) - node_order = (/1,2,3/) - case(6) - node_order = (/1,6,2,5,4,3/) - case default - do j=1,loc - node_order(j)=j - end do - end select - - call allocate(mesh, nodes, elements, shape, name="CoordinateMesh") - - if (have_option('/geometry/spherical_earth/')) then - call get_option('/geometry/dimension', gdim) - call allocate(field, gdim, mesh, name="Coordinate") - else - call allocate(field, xdim, mesh, name="Coordinate") - end if - - ! Drop the local reference to mesh - now field owns the only reference. - call deallocate(mesh) - - if (have_option('/geometry/spherical_earth/')) then - allocate(read_buffer(xdim+node_attributes+boundaries+2)) - else - allocate(read_buffer(xdim+node_attributes+boundaries+1)) - end if + subroutine identify_triangle_file(filename, dim, loc, nodes, elements, & + node_attributes, selements, selement_boundaries) + !!< Discover the dimension and size of the triangle inputs. + !!< Filename is the base name of the triangle file without .node or .ele. + !!< In parallel, filename must *include* the process number. + + character(len=*), intent(in) :: filename + !! Dimension of mesh elements. + integer, intent(out), optional :: dim + !! Number of vertices of elements. + integer, intent(out), optional :: loc + !! Node and element counts. + integer, intent(out), optional :: nodes, elements + integer, intent(out), optional :: node_attributes + ! Surface element meta data + integer, optional, intent(out) :: selements + integer, optional, intent(out) :: selement_boundaries + + integer :: node_unit, element_unit, selement_unit + integer :: lnodes, ldim, lnode_attributes, node_boundaries + integer :: lelements, lloc, ele_attributes + integer :: lselements, lselement_boundaries + logical :: file_exists + + ! Read node file header + inquire(file = trim(filename) // ".node", exist = file_exists) + if(.not. file_exists) then + ewrite(-1, *) "For triangle file with base name " // trim(filename) + FLExit(".node file not found") + end if + ewrite(2, *) "Opening " // trim(filename) // ".node for reading." + node_unit = free_unit() + open(unit = node_unit, file = trim(filename) // ".node", err = 42, action = "read") + read (node_unit, *) lnodes, ldim, lnode_attributes, node_boundaries + close(node_unit) + + ! Read volume element file header + lelements = 0 + lloc = 0 + ele_attributes = 0 + inquire(file = trim(filename) // ".ele", exist = file_exists) + if(file_exists) then + ewrite(2, *) "Opening " // trim(filename) // ".ele for reading" + element_unit = free_unit() + open(unit = element_unit, file = trim(filename) // ".ele", err = 43, action = "read") + read (element_unit, *) lelements, lloc, ele_attributes + close(element_unit) + else if (present(loc) .or. present(elements)) then + ewrite(-1, *) "For triangle file with base name " // trim(filename) + FLExit(".ele file not found") + end if - if(node_attributes==1) then ! this assumes the node attribute are column numbers - allocate(field%mesh%columns(1:nodes)) - end if + ! Read the surface element file header + lselements = 0 + lselement_boundaries = 0 + select case(ldim) + case(1) + inquire(file = trim(filename) // ".bound", exist = file_exists) + if(file_exists) then + ewrite(2, *) "Opening " // trim(filename) // ".bound for reading" + selement_unit = free_unit() + open(unit = selement_unit, file = trim(filename) // ".bound", err = 44, action = "read") + read(selement_unit, *) lselements, lselement_boundaries + close(selement_unit) + end if + case(2) + inquire(file = trim(filename) // ".edge", exist = file_exists) + if(file_exists) then + ewrite(2, *) "Opening " // trim(filename) // ".edge for reading" + selement_unit = free_unit() + open(unit = selement_unit, file = trim(filename) // ".edge", err = 45, action = "read") + read(selement_unit, *) lselements, lselement_boundaries + close(selement_unit) + end if + case(3) + inquire(file = trim(filename) // ".face", exist = file_exists) + if(file_exists) then + ewrite(2, *) "Opening " // trim(filename) // ".face for reading" + selement_unit = free_unit() + open(unit = selement_unit, file = trim(filename) // ".face", err = 46, action = "read") + read(selement_unit, *) lselements, lselement_boundaries + close(selement_unit) + end if + end select - do i=1,nodes - if (have_option('/geometry/spherical_earth/')) then - read(node_unit,*) read_buffer - forall (j=1:xdim+1) - field%val(j,i)=read_buffer(j+1) - end forall - if (node_attributes==1) then - field%mesh%columns(i)=floor(read_buffer(xdim+2)) + if(present(nodes)) then + nodes = lnodes + end if + if(present(dim)) then + dim = ldim + end if + if(present(node_attributes)) then + node_attributes = lnode_attributes + end if + if(present(loc)) then + loc = lloc + end if + if(present(elements)) then + elements = lelements + end if + if(present(selements)) then + selements = lselements + end if + if(present(selement_boundaries)) then + selement_boundaries = lselement_boundaries + end if + + return + +42 FLExit("Unable to open "//trim(filename)//".node") + +43 FLExit("Unable to open "//trim(filename)//".ele") + +44 FLExit("Unable to open " // trim(filename) // ".bound") + +45 FLExit("Unable to open " // trim(filename) // ".edge") + +46 FLExit("Unable to open " // trim(filename) // ".face") + + end subroutine identify_triangle_file + + function read_triangle_files_to_field(filename, shape) result (field) + !!< Filename is the base name of the triangle file without .node or .ele . + !!< In parallel the filename must *not* include the process number. + + character(len=*), intent(in) :: filename + type(element_type), intent(in), target :: shape + type(vector_field) :: field + + integer :: node_unit, ele_unit + real, allocatable, dimension(:) :: read_buffer + integer, allocatable, dimension(:,:) :: edge_buffer + integer, allocatable, dimension(:) :: sndglno + integer, allocatable, dimension(:) :: boundary_ids, element_owner + + character(len = parallel_filename_len(filename)) :: lfilename + integer :: i, j, nodes, dim, xdim, node_attributes, boundaries,& + & ele_attributes, loc, sloc, elements, edges, edge_count, gdim + integer, allocatable, dimension(:):: node_order + logical :: file_exists + type(mesh_type) :: mesh + + ! If running in parallel, add the process number + if(isparallel()) then + lfilename = parallel_filename(filename) + else + lfilename = trim(filename) + end if + + node_unit=free_unit() + + ewrite(2, *) "Opening "//trim(lfilename)//".node for reading." + ! Open node file + open(unit=node_unit, file=trim(lfilename)//".node", err=42, action="read") + + ! Read node file header. + read (node_unit, *) nodes, xdim, node_attributes, boundaries + + ele_unit=free_unit() + + ewrite(2, *) "Opening "//trim(lfilename)//".ele for reading." + ! Open element file + open(unit=ele_unit, file=trim(lfilename)//".ele", err=43, action="read") + + ! Read element file header. + read (ele_unit, *) elements, loc, ele_attributes + + assert(loc==shape%loc) + allocate(node_order(loc)) + select case(loc) + case(3) + node_order = (/1,2,3/) + case(6) + node_order = (/1,6,2,5,4,3/) + case default + do j=1,loc + node_order(j)=j + end do + end select + + call allocate(mesh, nodes, elements, shape, name="CoordinateMesh") + + if (have_option('/geometry/spherical_earth/')) then + call get_option('/geometry/dimension', gdim) + call allocate(field, gdim, mesh, name="Coordinate") + else + call allocate(field, xdim, mesh, name="Coordinate") + end if + + ! Drop the local reference to mesh - now field owns the only reference. + call deallocate(mesh) + + if (have_option('/geometry/spherical_earth/')) then + allocate(read_buffer(xdim+node_attributes+boundaries+2)) + else + allocate(read_buffer(xdim+node_attributes+boundaries+1)) + end if + + if(node_attributes==1) then ! this assumes the node attribute are column numbers + allocate(field%mesh%columns(1:nodes)) + end if + + do i=1,nodes + if (have_option('/geometry/spherical_earth/')) then + read(node_unit,*) read_buffer + forall (j=1:xdim+1) + field%val(j,i)=read_buffer(j+1) + end forall + if (node_attributes==1) then + field%mesh%columns(i)=floor(read_buffer(xdim+2)) + end if + else + read(node_unit,*) read_buffer + forall (j=1:xdim) + field%val(j,i)=read_buffer(j+1) + end forall + if (node_attributes==1) then + field%mesh%columns(i)=floor(read_buffer(xdim+2)) + end if end if - else - read(node_unit,*) read_buffer - forall (j=1:xdim) - field%val(j,i)=read_buffer(j+1) - end forall - if (node_attributes==1) then - field%mesh%columns(i)=floor(read_buffer(xdim+2)) + end do + + deallocate(read_buffer) + allocate(read_buffer(loc+ele_attributes+1)) + + if(ele_attributes==1) then ! this assumes that the element attribute is a region id + allocate(field%mesh%region_ids(1:elements)) + end if + + do i=1,elements + read(ele_unit,*) read_buffer + field%mesh%ndglno((i-1)*loc+1:i*loc)=floor(read_buffer(node_order+1)) + if(ele_attributes==1) then + field%mesh%region_ids(i)=read_buffer(loc+2) end if - end if - end do - - deallocate(read_buffer) - allocate(read_buffer(loc+ele_attributes+1)) - - if(ele_attributes==1) then ! this assumes that the element attribute is a region id - allocate(field%mesh%region_ids(1:elements)) - end if - - do i=1,elements - read(ele_unit,*) read_buffer - field%mesh%ndglno((i-1)*loc+1:i*loc)=floor(read_buffer(node_order+1)) - if(ele_attributes==1) then - field%mesh%region_ids(i)=read_buffer(loc+2) - end if - end do - - close(node_unit) - close(ele_unit) - - ! Get the mesh dimension so we know which files to look for - dim=shape%dim - - ! Open edge file - select case (dim) - case(1) - inquire(file=trim(lfilename)//".bound",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".bound for reading." - open(unit=node_unit, file=trim(lfilename)//".bound", err=41, & - action="read") - end if - case(2) - inquire(file=trim(lfilename)//".edge",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".edge for reading." - open(unit=node_unit, file=trim(lfilename)//".edge", err=41, & - action="read") - end if - case(3) - inquire(file=trim(lfilename)//".face",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".face for reading." - open(unit=node_unit, file=trim(lfilename)//".face", err=41, & - action="read") - end if - end select - - if(file_exists) then - ! Read edge file header. - read (node_unit, *) edges, boundaries - else - edges = 0 - boundaries = 1 - end if - - if(edges==0) then - file_exists = .false. - close(node_unit) - end if - - select case(shape%numbering%family) - case(FAMILY_SIMPLEX) - if ((loc/=dim+1).and.(boundaries/=0)) then - ewrite(0,*) "Warning: triangle boundary markers not supported for qua", & - &"dratic space elements." - if(file_exists) then - file_exists= .false. - close(node_unit) - end if - end if - sloc=loc-1 - case(FAMILY_CUBE) - sloc=loc/2 - case default - ewrite(-1,*) "While reading triangle files with basename "//trim(lfilename) - FLAbort('Illegal element family') - end select - - allocate(edge_buffer(sloc+boundaries+1,edges)) - edge_buffer=0 - allocate(sndglno(edges*sloc)) - sndglno=0 - allocate(boundary_ids(1:edges)) - boundary_ids=0 - if (boundaries==2) then - allocate(element_owner(1:edges)) - element_owner=0 - end if - edge_count=0 - - if (boundaries==0) then - ewrite(0,*) "Warning: triangle edge file has no boundary markers" - if(file_exists) then - file_exists=.false. - close(node_unit) - end if - else + end do + + close(node_unit) + close(ele_unit) + + ! Get the mesh dimension so we know which files to look for + dim=shape%dim + + ! Open edge file + select case (dim) + case(1) + inquire(file=trim(lfilename)//".bound",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".bound for reading." + open(unit=node_unit, file=trim(lfilename)//".bound", err=41, & + action="read") + end if + case(2) + inquire(file=trim(lfilename)//".edge",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".edge for reading." + open(unit=node_unit, file=trim(lfilename)//".edge", err=41, & + action="read") + end if + case(3) + inquire(file=trim(lfilename)//".face",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".face for reading." + open(unit=node_unit, file=trim(lfilename)//".face", err=41, & + action="read") + end if + end select + if(file_exists) then - read(node_unit, *) edge_buffer + ! Read edge file header. + read (node_unit, *) edges, boundaries + else + edges = 0 + boundaries = 1 + end if - do i=1, edges - if (edge_buffer(sloc+2,i)/=0) then - ! boundary edge/face - edge_count=edge_count+1 - sndglno((edge_count-1)*sloc+1:edge_count*sloc)= & - edge_buffer(2:sloc+1,i) - boundary_ids(edge_count)=edge_buffer(sloc+2,i) - if (boundaries==2) then - element_owner(edge_count)=edge_buffer(sloc+3,i) + if(edges==0) then + file_exists = .false. + close(node_unit) + end if + + select case(shape%numbering%family) + case(FAMILY_SIMPLEX) + if ((loc/=dim+1).and.(boundaries/=0)) then + ewrite(0,*) "Warning: triangle boundary markers not supported for qua", & + &"dratic space elements." + if(file_exists) then + file_exists= .false. + close(node_unit) end if - end if - end do + end if + sloc=loc-1 + case(FAMILY_CUBE) + sloc=loc/2 + case default + ewrite(-1,*) "While reading triangle files with basename "//trim(lfilename) + FLAbort('Illegal element family') + end select + + allocate(edge_buffer(sloc+boundaries+1,edges)) + edge_buffer=0 + allocate(sndglno(edges*sloc)) + sndglno=0 + allocate(boundary_ids(1:edges)) + boundary_ids=0 + if (boundaries==2) then + allocate(element_owner(1:edges)) + element_owner=0 + end if + edge_count=0 - file_exists=.false. - close(node_unit) + if (boundaries==0) then + ewrite(0,*) "Warning: triangle edge file has no boundary markers" + if(file_exists) then + file_exists=.false. + close(node_unit) + end if + else + if(file_exists) then + read(node_unit, *) edge_buffer + + do i=1, edges + if (edge_buffer(sloc+2,i)/=0) then + ! boundary edge/face + edge_count=edge_count+1 + sndglno((edge_count-1)*sloc+1:edge_count*sloc)= & + edge_buffer(2:sloc+1,i) + boundary_ids(edge_count)=edge_buffer(sloc+2,i) + if (boundaries==2) then + element_owner(edge_count)=edge_buffer(sloc+3,i) + end if + end if + end do + + file_exists=.false. + close(node_unit) + end if end if - end if - if (boundaries<2) then - call add_faces(field%mesh, & - & sndgln=sndglno(1:edge_count*sloc), & - & boundary_ids=boundary_ids(1:edge_count)) - else - call add_faces(field%mesh, & - & sndgln=sndglno(1:edge_count*sloc), & - & boundary_ids=boundary_ids(1:edge_count), & - & element_owner=element_owner) - end if + if (boundaries<2) then + call add_faces(field%mesh, & + & sndgln=sndglno(1:edge_count*sloc), & + & boundary_ids=boundary_ids(1:edge_count)) + else + call add_faces(field%mesh, & + & sndgln=sndglno(1:edge_count*sloc), & + & boundary_ids=boundary_ids(1:edge_count), & + & element_owner=element_owner) + end if - deallocate(edge_buffer) - deallocate(sndglno) - deallocate(boundary_ids) + deallocate(edge_buffer) + deallocate(sndglno) + deallocate(boundary_ids) -41 continue ! We jump to here if there was no edge file. +41 continue ! We jump to here if there was no edge file. - return + return -42 FLExit("Unable to open "//trim(lfilename)//".node") +42 FLExit("Unable to open "//trim(lfilename)//".node") -43 FLExit("Unable to open "//trim(lfilename)//".ele") +43 FLExit("Unable to open "//trim(lfilename)//".ele") - end function read_triangle_files_to_field + end function read_triangle_files_to_field - function read_triangle_simple(filename, quad_degree, quad_ngi, no_faces, quad_family, mdim) result (field) - !!< A simpler mechanism for reading a triangle file into a field. - !!< In parallel the filename must *not* include the process number. + function read_triangle_simple(filename, quad_degree, quad_ngi, no_faces, quad_family, mdim) result (field) + !!< A simpler mechanism for reading a triangle file into a field. + !!< In parallel the filename must *not* include the process number. - character(len=*), intent(in) :: filename - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_degree - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_ngi - !! Whether to add_faces on the resulting mesh. - logical, intent(in), optional :: no_faces - !! What quadrature family to use - integer, intent(in), optional :: quad_family - !! Dimension of mesh - integer, intent(in), optional :: mdim + character(len=*), intent(in) :: filename + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_degree + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_ngi + !! Whether to add_faces on the resulting mesh. + logical, intent(in), optional :: no_faces + !! What quadrature family to use + integer, intent(in), optional :: quad_family + !! Dimension of mesh + integer, intent(in), optional :: mdim - type(vector_field) :: field - type(quadrature_type) :: quad - type(element_type) :: shape + type(vector_field) :: field + type(quadrature_type) :: quad + type(element_type) :: shape - integer :: dim, loc + integer :: dim, loc - if(isparallel()) then - call identify_triangle_file(parallel_filename(filename), dim, loc) - else - call identify_triangle_file(filename, dim, loc) - end if - - if (present(mdim)) then - dim=mdim - end if - - if (present(quad_degree)) then - quad=make_quadrature(loc, dim, degree=quad_degree, family=quad_family) - else if (present(quad_ngi)) then - quad=make_quadrature(loc, dim, ngi=quad_ngi, family=quad_family) - else - FLAbort("Need to specify either quadrature degree or ngi") - end if - - shape=make_element_shape(loc, dim, 1, quad) - - if (present_and_true(no_faces)) then - field=read_triangle_files_to_field_no_faces(filename, shape) - else - field=read_triangle_files(filename, shape) - end if - - ! deallocate our references of shape and quadrature: - call deallocate(shape) - call deallocate(quad) - - end function read_triangle_simple - - function read_elemental_mappings(positions, filename, map, stat) result(field) - type(vector_field), intent(in) :: positions - character(len=*), intent(in) :: filename, map - type(scalar_field) :: field - integer, optional, intent(out) :: stat - - integer :: elements, unit, ele, current_element, target_element - integer :: io - real :: t - - if(present(stat)) stat = 0 - - if(isparallel()) then - call identify_triangle_file(parallel_filename(filename), elements=elements) - else - call identify_triangle_file(filename, elements=elements) - end if - - unit = free_unit() - open(unit=unit, file=trim(filename)// "." // trim(map), action="read", iostat=io, status="old") - if (io == 0) then - field = piecewise_constant_field(positions%mesh, trim(map)) - - do ele=1,elements - read (unit, *) current_element, target_element - t = target_element - call set(field, current_element, t) + if(isparallel()) then + call identify_triangle_file(parallel_filename(filename), dim, loc) + else + call identify_triangle_file(filename, dim, loc) + end if + + if (present(mdim)) then + dim=mdim + end if + + if (present(quad_degree)) then + quad=make_quadrature(loc, dim, degree=quad_degree, family=quad_family) + else if (present(quad_ngi)) then + quad=make_quadrature(loc, dim, ngi=quad_ngi, family=quad_family) + else + FLAbort("Need to specify either quadrature degree or ngi") + end if + + shape=make_element_shape(loc, dim, 1, quad) + + if (present_and_true(no_faces)) then + field=read_triangle_files_to_field_no_faces(filename, shape) + else + field=read_triangle_files(filename, shape) + end if + + ! deallocate our references of shape and quadrature: + call deallocate(shape) + call deallocate(quad) + + end function read_triangle_simple + + function read_elemental_mappings(positions, filename, map, stat) result(field) + type(vector_field), intent(in) :: positions + character(len=*), intent(in) :: filename, map + type(scalar_field) :: field + integer, optional, intent(out) :: stat + + integer :: elements, unit, ele, current_element, target_element + integer :: io + real :: t + + if(present(stat)) stat = 0 + + if(isparallel()) then + call identify_triangle_file(parallel_filename(filename), elements=elements) + else + call identify_triangle_file(filename, elements=elements) + end if + + unit = free_unit() + open(unit=unit, file=trim(filename)// "." // trim(map), action="read", iostat=io, status="old") + if (io == 0) then + field = piecewise_constant_field(positions%mesh, trim(map)) + + do ele=1,elements + read (unit, *) current_element, target_element + t = target_element + call set(field, current_element, t) + end do + else + if(present(stat)) then + stat = io + return + else + ewrite(-1,*) "While opening "//trim(filename)// "." // trim(map) + FLAbort("Failed to read elemental mappings") + end if + end if + + close(unit) + + end function read_elemental_mappings + + ! I'm sorry -- I had to copy this function. + ! The add_faces call on the triangle files I am using + ! crashes, because I am using the edge markers for + ! something different to defining boundary labels. + ! However, I couldn't add an optional logical, + ! as then that makes the interface indistinguishable + ! from read_triangle_files_to_state! + ! -- pfarrell + + function read_triangle_files_to_field_no_faces(filename, shape) result (field) + !!< Filename is the base name of the triangle file without .node or .ele . + !!< In parallel the filename must *not* include the process number. + + character(len=*), intent(in) :: filename + type(element_type), intent(in), target :: shape + type(vector_field) :: field + + integer :: node_unit, ele_unit + real, allocatable, dimension(:) :: read_buffer + integer, allocatable, dimension(:,:) :: edge_buffer + integer, allocatable, dimension(:) :: sndglno + integer, allocatable, dimension(:) :: boundary_ids + + character(len = parallel_filename_len(filename)) :: lfilename + integer :: i, j, nodes, dim, xdim, node_attributes, boundaries,& + & ele_attributes, loc, sloc, elements, edges, edge_count + integer, allocatable, dimension(:):: node_order + logical :: file_exists + type(mesh_type) :: mesh + + ! If running in parallel, add the process number + if(isparallel()) then + lfilename = parallel_filename(filename) + else + lfilename = trim(filename) + end if + + node_unit=free_unit() + + ewrite(2, *) "Opening "//trim(lfilename)//".node for reading." + ! Open node file + open(unit=node_unit, file=trim(lfilename)//".node", err=42, action="read") + + ! Read node file header. + read (node_unit, *) nodes, xdim, node_attributes, boundaries + + ele_unit=free_unit() + + ewrite(2, *) "Opening "//trim(lfilename)//".ele for reading." + ! Open element file + open(unit=ele_unit, file=trim(lfilename)//".ele", err=43, action="read") + + ! Read element file header. + read (ele_unit, *) elements, loc, ele_attributes + + assert(loc==shape%loc) + allocate(node_order(loc)) + select case(loc) + case(3) + node_order = (/1,2,3/) + case(6) + node_order = (/1,6,2,5,4,3/) + case default + do j=1,loc + node_order(j)=j + end do + end select + + call allocate(mesh, nodes, elements, shape, name=filename) + + ! Field has an upper index of 3. Therefore, if dim==3 and + ! node_attributes>0 then we get an out of bounds reference. Assume + ! here that when there are node attributes they can be ignored. + call allocate(field, xdim, mesh, name="Coordinate") + + ! Drop the local reference to mesh - now field owns the only reference. + call deallocate(mesh) + + allocate(read_buffer(xdim+node_attributes+boundaries+1)) + + do i=1,nodes + read(node_unit,*) read_buffer + forall (j=1:xdim) + field%val(j,i)=read_buffer(j+1) + end forall + end do + + deallocate(read_buffer) + allocate(read_buffer(loc+ele_attributes+1)) + + if(ele_attributes==1) then ! this assumes that the element attribute is a region id + allocate(field%mesh%region_ids(1:elements)) + end if + + do i=1,elements + read(ele_unit,*) read_buffer + field%mesh%ndglno((i-1)*loc+1:i*loc)=floor(read_buffer(node_order+1)) + if(ele_attributes==1) then + field%mesh%region_ids(i)=read_buffer(loc+2) + end if end do - else - if(present(stat)) then - stat = io - return + + close(node_unit) + close(ele_unit) + + ! Get the mesh dimension so we know which files to look for + dim=shape%dim + + ! Open edge file + select case (dim) + case(1) + inquire(file=trim(lfilename)//".bound",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".bound for reading." + open(unit=node_unit, file=trim(lfilename)//".bound", err=41, & + action="read") + end if + case(2) + inquire(file=trim(lfilename)//".edge",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".edge for reading." + open(unit=node_unit, file=trim(lfilename)//".edge", err=41, & + action="read") + end if + case(3) + inquire(file=trim(lfilename)//".face",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".face for reading." + open(unit=node_unit, file=trim(lfilename)//".face", err=41, & + action="read") + end if + end select + + if(file_exists) then + ! Read edge file header. + read (node_unit, *) edges, boundaries else - ewrite(-1,*) "While opening "//trim(filename)// "." // trim(map) - FLAbort("Failed to read elemental mappings") - end if - end if - - close(unit) - - end function read_elemental_mappings - - ! I'm sorry -- I had to copy this function. - ! The add_faces call on the triangle files I am using - ! crashes, because I am using the edge markers for - ! something different to defining boundary labels. - ! However, I couldn't add an optional logical, - ! as then that makes the interface indistinguishable - ! from read_triangle_files_to_state! - ! -- pfarrell - - function read_triangle_files_to_field_no_faces(filename, shape) result (field) - !!< Filename is the base name of the triangle file without .node or .ele . - !!< In parallel the filename must *not* include the process number. - - character(len=*), intent(in) :: filename - type(element_type), intent(in), target :: shape - type(vector_field) :: field - - integer :: node_unit, ele_unit - real, allocatable, dimension(:) :: read_buffer - integer, allocatable, dimension(:,:) :: edge_buffer - integer, allocatable, dimension(:) :: sndglno - integer, allocatable, dimension(:) :: boundary_ids - - character(len = parallel_filename_len(filename)) :: lfilename - integer :: i, j, nodes, dim, xdim, node_attributes, boundaries,& - & ele_attributes, loc, sloc, elements, edges, edge_count - integer, allocatable, dimension(:):: node_order - logical :: file_exists - type(mesh_type) :: mesh - - ! If running in parallel, add the process number - if(isparallel()) then - lfilename = parallel_filename(filename) - else - lfilename = trim(filename) - end if - - node_unit=free_unit() - - ewrite(2, *) "Opening "//trim(lfilename)//".node for reading." - ! Open node file - open(unit=node_unit, file=trim(lfilename)//".node", err=42, action="read") - - ! Read node file header. - read (node_unit, *) nodes, xdim, node_attributes, boundaries - - ele_unit=free_unit() - - ewrite(2, *) "Opening "//trim(lfilename)//".ele for reading." - ! Open element file - open(unit=ele_unit, file=trim(lfilename)//".ele", err=43, action="read") - - ! Read element file header. - read (ele_unit, *) elements, loc, ele_attributes - - assert(loc==shape%loc) - allocate(node_order(loc)) - select case(loc) - case(3) - node_order = (/1,2,3/) - case(6) - node_order = (/1,6,2,5,4,3/) - case default - do j=1,loc - node_order(j)=j - end do - end select - - call allocate(mesh, nodes, elements, shape, name=filename) - - ! Field has an upper index of 3. Therefore, if dim==3 and - ! node_attributes>0 then we get an out of bounds reference. Assume - ! here that when there are node attributes they can be ignored. - call allocate(field, xdim, mesh, name="Coordinate") - - ! Drop the local reference to mesh - now field owns the only reference. - call deallocate(mesh) - - allocate(read_buffer(xdim+node_attributes+boundaries+1)) - - do i=1,nodes - read(node_unit,*) read_buffer - forall (j=1:xdim) - field%val(j,i)=read_buffer(j+1) - end forall - end do - - deallocate(read_buffer) - allocate(read_buffer(loc+ele_attributes+1)) - - if(ele_attributes==1) then ! this assumes that the element attribute is a region id - allocate(field%mesh%region_ids(1:elements)) - end if - - do i=1,elements - read(ele_unit,*) read_buffer - field%mesh%ndglno((i-1)*loc+1:i*loc)=floor(read_buffer(node_order+1)) - if(ele_attributes==1) then - field%mesh%region_ids(i)=read_buffer(loc+2) - end if - end do - - close(node_unit) - close(ele_unit) - - ! Get the mesh dimension so we know which files to look for - dim=shape%dim - - ! Open edge file - select case (dim) - case(1) - inquire(file=trim(lfilename)//".bound",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".bound for reading." - open(unit=node_unit, file=trim(lfilename)//".bound", err=41, & - action="read") - end if - case(2) - inquire(file=trim(lfilename)//".edge",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".edge for reading." - open(unit=node_unit, file=trim(lfilename)//".edge", err=41, & - action="read") - end if - case(3) - inquire(file=trim(lfilename)//".face",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".face for reading." - open(unit=node_unit, file=trim(lfilename)//".face", err=41, & - action="read") - end if - end select - - if(file_exists) then - ! Read edge file header. - read (node_unit, *) edges, boundaries - else - edges = 0 - boundaries = 1 - end if - - if (boundaries==0 .or. edges==0) then - if(file_exists) then - close(node_unit) - end if - goto 41 - end if - - select case(shape%numbering%family) - case(FAMILY_SIMPLEX) - if (loc/=dim+1) then - ewrite(0,*) "Warning: triangle boundary markers not supported for qua",& - &"dratic space elements." + edges = 0 + boundaries = 1 + end if + + if (boundaries==0 .or. edges==0) then if(file_exists) then close(node_unit) end if goto 41 end if - sloc=loc-1 - case(FAMILY_CUBE) - sloc=loc/2 - case default - FLAbort('Illegal element family') - end select - allocate(edge_buffer(sloc+boundaries+1,edges)) - allocate(sndglno(edges*sloc)) - allocate(boundary_ids(1:edges)) - if(file_exists) then - read(node_unit, *) edge_buffer - end if + select case(shape%numbering%family) + case(FAMILY_SIMPLEX) + if (loc/=dim+1) then + ewrite(0,*) "Warning: triangle boundary markers not supported for qua",& + &"dratic space elements." + if(file_exists) then + close(node_unit) + end if + goto 41 + end if + sloc=loc-1 + case(FAMILY_CUBE) + sloc=loc/2 + case default + FLAbort('Illegal element family') + end select + allocate(edge_buffer(sloc+boundaries+1,edges)) + allocate(sndglno(edges*sloc)) + allocate(boundary_ids(1:edges)) - edge_count=0 - do i=1, edges - if (edge_buffer(sloc+2,i)/=0) then - ! boundary edge/face - edge_count=edge_count+1 - sndglno((edge_count-1)*sloc+1:edge_count*sloc)= & - edge_buffer(2:sloc+1,i) - boundary_ids(edge_count)=edge_buffer(sloc+2,i) - end if - end do + if(file_exists) then + read(node_unit, *) edge_buffer + end if + + edge_count=0 + do i=1, edges + if (edge_buffer(sloc+2,i)/=0) then + ! boundary edge/face + edge_count=edge_count+1 + sndglno((edge_count-1)*sloc+1:edge_count*sloc)= & + edge_buffer(2:sloc+1,i) + boundary_ids(edge_count)=edge_buffer(sloc+2,i) + end if + end do - deallocate(edge_buffer) - deallocate(sndglno) - deallocate(boundary_ids) + deallocate(edge_buffer) + deallocate(sndglno) + deallocate(boundary_ids) - close(node_unit) + close(node_unit) -41 continue ! We jump to here if there was no edge file. +41 continue ! We jump to here if there was no edge file. - return + return -42 FLExit("Unable to open "//trim(lfilename)//".node") +42 FLExit("Unable to open "//trim(lfilename)//".node") -43 FLExit("Unable to open "//trim(lfilename)//".ele") +43 FLExit("Unable to open "//trim(lfilename)//".ele") - end function read_triangle_files_to_field_no_faces + end function read_triangle_files_to_field_no_faces - function read_triangle_serial(filename, quad_degree) result (field) + function read_triangle_serial(filename, quad_degree) result (field) - character(len=*), intent(in) :: filename - !! The degree of the quadrature. - integer, intent(in), optional, target :: quad_degree - !! The degree of the quadrature. + character(len=*), intent(in) :: filename + !! The degree of the quadrature. + integer, intent(in), optional, target :: quad_degree + !! The degree of the quadrature. - type(vector_field) :: field - type(quadrature_type) :: quad - type(element_type) :: shape + type(vector_field) :: field + type(quadrature_type) :: quad + type(element_type) :: shape - integer :: dim, loc + integer :: dim, loc - call identify_triangle_file(filename, dim, loc) - quad=make_quadrature(loc, dim, degree=quad_degree) - shape=make_element_shape(loc, dim, 1, quad) - field=read_triangle_files_serial(filename, shape) + call identify_triangle_file(filename, dim, loc) + quad=make_quadrature(loc, dim, degree=quad_degree) + shape=make_element_shape(loc, dim, 1, quad) + field=read_triangle_files_serial(filename, shape) - ! deallocate our references of shape and quadrature: - call deallocate(shape) - call deallocate(quad) + ! deallocate our references of shape and quadrature: + call deallocate(shape) + call deallocate(quad) - end function read_triangle_serial + end function read_triangle_serial - function read_triangle_files_serial(filename, shape) result (field) - !!< Filename is the base name of the triangle file without .node or .ele. + function read_triangle_files_serial(filename, shape) result (field) + !!< Filename is the base name of the triangle file without .node or .ele. - character(len=*), intent(in) :: filename - type(element_type), intent(in), target :: shape - type(vector_field) :: field + character(len=*), intent(in) :: filename + type(element_type), intent(in), target :: shape + type(vector_field) :: field - integer :: node_unit, ele_unit - real, allocatable, dimension(:) :: read_buffer - integer, allocatable, dimension(:,:) :: edge_buffer - integer, allocatable, dimension(:) :: sndglno - integer, allocatable, dimension(:) :: boundary_ids, element_owner + integer :: node_unit, ele_unit + real, allocatable, dimension(:) :: read_buffer + integer, allocatable, dimension(:,:) :: edge_buffer + integer, allocatable, dimension(:) :: sndglno + integer, allocatable, dimension(:) :: boundary_ids, element_owner - character(len = parallel_filename_len(filename)) :: lfilename - integer :: i, j, nodes, dim, xdim, node_attributes, boundaries, & + character(len = parallel_filename_len(filename)) :: lfilename + integer :: i, j, nodes, dim, xdim, node_attributes, boundaries, & ele_attributes, loc, sloc, elements, edges, edge_count - integer, allocatable, dimension(:):: node_order - logical :: file_exists - type(mesh_type) :: mesh - - lfilename = trim(filename) - - node_unit=free_unit() - - ewrite(2, *) "Opening "//trim(lfilename)//".node for reading." - ! Open node file - open(unit=node_unit, file=trim(lfilename)//".node", err=42, action="read") - - ! Read node file header. - read (node_unit, *) nodes, xdim, node_attributes, boundaries - - ele_unit=free_unit() - - ewrite(2, *) "Opening "//trim(lfilename)//".ele for reading." - ! Open element file - open(unit=ele_unit, file=trim(lfilename)//".ele", err=43, action="read") - - ! Read element file header. - read (ele_unit, *) elements, loc, ele_attributes - - assert(loc==shape%loc) - allocate(node_order(loc)) - select case(loc) - case(3) - node_order = (/1,2,3/) - case default - do j = 1, loc - node_order(j) = j - end do - end select - - call allocate(mesh, nodes, elements, shape, name="CoordinateMesh") - - call allocate(field, xdim, mesh, name="Coordinate") - - ! Drop the local reference to mesh - now field owns the only reference. - call deallocate(mesh) - - allocate(read_buffer(xdim+node_attributes+boundaries+1)) - - if(node_attributes==1) then ! this assumes the node attribute are column numbers - allocate(field%mesh%columns(1:nodes)) - end if - - do i = 1, nodes - read(node_unit,*) read_buffer - forall (j=1:xdim) - field%val(j,i)=read_buffer(j+1) - end forall - if (node_attributes==1) then - field%mesh%columns(i)=floor(read_buffer(xdim+1)) - end if - end do - - deallocate(read_buffer) - allocate(read_buffer(loc+ele_attributes+1)) - - if(ele_attributes==1) then ! this assumes that the element attribute is a region id - allocate(field%mesh%region_ids(1:elements)) - end if - - do i = 1, elements - read(ele_unit,*) read_buffer - field%mesh%ndglno((i-1)*loc+1:i*loc)=floor(read_buffer(node_order+1)) - if(ele_attributes==1) then - field%mesh%region_ids(i)=read_buffer(loc+2) - end if - end do - - close(node_unit) - close(ele_unit) - - ! Get the mesh dimension so we know which files to look for - dim=shape%dim - - ! Open edge file - select case (dim) - case(2) - inquire(file=trim(lfilename)//".edge",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".edge for reading." - open(unit=node_unit, file=trim(lfilename)//".edge", err=41, & + integer, allocatable, dimension(:):: node_order + logical :: file_exists + type(mesh_type) :: mesh + + lfilename = trim(filename) + + node_unit=free_unit() + + ewrite(2, *) "Opening "//trim(lfilename)//".node for reading." + ! Open node file + open(unit=node_unit, file=trim(lfilename)//".node", err=42, action="read") + + ! Read node file header. + read (node_unit, *) nodes, xdim, node_attributes, boundaries + + ele_unit=free_unit() + + ewrite(2, *) "Opening "//trim(lfilename)//".ele for reading." + ! Open element file + open(unit=ele_unit, file=trim(lfilename)//".ele", err=43, action="read") + + ! Read element file header. + read (ele_unit, *) elements, loc, ele_attributes + + assert(loc==shape%loc) + allocate(node_order(loc)) + select case(loc) + case(3) + node_order = (/1,2,3/) + case default + do j = 1, loc + node_order(j) = j + end do + end select + + call allocate(mesh, nodes, elements, shape, name="CoordinateMesh") + + call allocate(field, xdim, mesh, name="Coordinate") + + ! Drop the local reference to mesh - now field owns the only reference. + call deallocate(mesh) + + allocate(read_buffer(xdim+node_attributes+boundaries+1)) + + if(node_attributes==1) then ! this assumes the node attribute are column numbers + allocate(field%mesh%columns(1:nodes)) + end if + + do i = 1, nodes + read(node_unit,*) read_buffer + forall (j=1:xdim) + field%val(j,i)=read_buffer(j+1) + end forall + if (node_attributes==1) then + field%mesh%columns(i)=floor(read_buffer(xdim+1)) + end if + end do + + deallocate(read_buffer) + allocate(read_buffer(loc+ele_attributes+1)) + + if(ele_attributes==1) then ! this assumes that the element attribute is a region id + allocate(field%mesh%region_ids(1:elements)) + end if + + do i = 1, elements + read(ele_unit,*) read_buffer + field%mesh%ndglno((i-1)*loc+1:i*loc)=floor(read_buffer(node_order+1)) + if(ele_attributes==1) then + field%mesh%region_ids(i)=read_buffer(loc+2) + end if + end do + + close(node_unit) + close(ele_unit) + + ! Get the mesh dimension so we know which files to look for + dim=shape%dim + + ! Open edge file + select case (dim) + case(2) + inquire(file=trim(lfilename)//".edge",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".edge for reading." + open(unit=node_unit, file=trim(lfilename)//".edge", err=41, & action="read") - end if - case(3) - inquire(file=trim(lfilename)//".face",exist=file_exists) - if(file_exists) then - ewrite(2, *) "Opening "//trim(lfilename)//".face for reading." - open(unit=node_unit, file=trim(lfilename)//".face", err=41, & + end if + case(3) + inquire(file=trim(lfilename)//".face",exist=file_exists) + if(file_exists) then + ewrite(2, *) "Opening "//trim(lfilename)//".face for reading." + open(unit=node_unit, file=trim(lfilename)//".face", err=41, & action="read") - end if - end select - - if(file_exists) then - ! Read edge file header. - read (node_unit, *) edges, boundaries - else - edges = 0 - boundaries = 1 - end if - - if(edges==0) then - file_exists = .false. - close(node_unit) - end if - - select case(shape%numbering%family) - case(FAMILY_SIMPLEX) - if ((loc/=dim+1).and.(boundaries/=0)) then - ewrite(0,*) "Warning: triangle boundary markers not supported for qua", & + end if + end select + + if(file_exists) then + ! Read edge file header. + read (node_unit, *) edges, boundaries + else + edges = 0 + boundaries = 1 + end if + + if(edges==0) then + file_exists = .false. + close(node_unit) + end if + + select case(shape%numbering%family) + case(FAMILY_SIMPLEX) + if ((loc/=dim+1).and.(boundaries/=0)) then + ewrite(0,*) "Warning: triangle boundary markers not supported for qua", & "dratic space elements." - if(file_exists) then - file_exists= .false. - close(node_unit) - end if - end if - sloc=loc-1 - case default - FLAbort('Illegal element family') - end select - - allocate(edge_buffer(sloc+boundaries+1,edges)) - edge_buffer=0 - allocate(sndglno(edges*sloc)) - sndglno=0 - allocate(boundary_ids(1:edges)) - boundary_ids=0 - if (boundaries==2) then - allocate(element_owner(1:edges)) - element_owner=0 - end if - edge_count=0 - - if (boundaries==0) then - ewrite(0,*) "Warning: triangle edge file has no boundary markers" - if(file_exists) then - file_exists=.false. - close(node_unit) - end if - else - if(file_exists) then - read(node_unit, *) edge_buffer - do i = 1, edges - if (edge_buffer(sloc+2,i)/=0) then - ! boundary edge/face - edge_count=edge_count+1 - sndglno((edge_count-1)*sloc+1:edge_count*sloc)= & + if(file_exists) then + file_exists= .false. + close(node_unit) + end if + end if + sloc=loc-1 + case default + FLAbort('Illegal element family') + end select + + allocate(edge_buffer(sloc+boundaries+1,edges)) + edge_buffer=0 + allocate(sndglno(edges*sloc)) + sndglno=0 + allocate(boundary_ids(1:edges)) + boundary_ids=0 + if (boundaries==2) then + allocate(element_owner(1:edges)) + element_owner=0 + end if + edge_count=0 + + if (boundaries==0) then + ewrite(0,*) "Warning: triangle edge file has no boundary markers" + if(file_exists) then + file_exists=.false. + close(node_unit) + end if + else + if(file_exists) then + read(node_unit, *) edge_buffer + do i = 1, edges + if (edge_buffer(sloc+2,i)/=0) then + ! boundary edge/face + edge_count=edge_count+1 + sndglno((edge_count-1)*sloc+1:edge_count*sloc)= & edge_buffer(2:sloc+1,i) - boundary_ids(edge_count)=edge_buffer(sloc+2,i) - if (boundaries==2) then - element_owner(edge_count)=edge_buffer(sloc+3,i) - end if - end if - end do - - file_exists=.false. - close(node_unit) - end if - end if - - if (boundaries<2) then - call add_faces(field%mesh, & + boundary_ids(edge_count)=edge_buffer(sloc+2,i) + if (boundaries==2) then + element_owner(edge_count)=edge_buffer(sloc+3,i) + end if + end if + end do + + file_exists=.false. + close(node_unit) + end if + end if + + if (boundaries<2) then + call add_faces(field%mesh, & sndgln=sndglno(1:edge_count*sloc), & boundary_ids=boundary_ids(1:edge_count)) - else - call add_faces(field%mesh, & + else + call add_faces(field%mesh, & sndgln=sndglno(1:edge_count*sloc), & boundary_ids=boundary_ids(1:edge_count), & element_owner=element_owner) - end if + end if - deallocate(edge_buffer) - deallocate(sndglno) - deallocate(boundary_ids) + deallocate(edge_buffer) + deallocate(sndglno) + deallocate(boundary_ids) -41 continue ! We jump to here if there was no edge file. +41 continue ! We jump to here if there was no edge file. - return + return -42 FLExit("Unable to open "//trim(lfilename)//".node") +42 FLExit("Unable to open "//trim(lfilename)//".node") -43 FLExit("Unable to open "//trim(lfilename)//".ele") +43 FLExit("Unable to open "//trim(lfilename)//".ele") - end function read_triangle_files_serial + end function read_triangle_files_serial end module read_triangle diff --git a/femtools/Refcount_interface_templates.F90 b/femtools/Refcount_interface_templates.F90 index 54c3c64443..1b2ac05b4f 100644 --- a/femtools/Refcount_interface_templates.F90 +++ b/femtools/Refcount_interface_templates.F90 @@ -1,15 +1,15 @@ - interface addref - module procedure addref_REFCOUNT_TYPE - end interface +interface addref + module procedure addref_REFCOUNT_TYPE +end interface - interface incref - module procedure incref_REFCOUNT_TYPE - end interface +interface incref + module procedure incref_REFCOUNT_TYPE +end interface - interface decref - module procedure decref_REFCOUNT_TYPE - end interface +interface decref + module procedure decref_REFCOUNT_TYPE +end interface - interface has_references - module procedure has_references_REFCOUNT_TYPE - end interface +interface has_references + module procedure has_references_REFCOUNT_TYPE +end interface diff --git a/femtools/Refcount_templates.F90 b/femtools/Refcount_templates.F90 index 5eec6a3100..5b3beb595b 100644 --- a/femtools/Refcount_templates.F90 +++ b/femtools/Refcount_templates.F90 @@ -1,83 +1,83 @@ - subroutine addref_REFCOUNT_TYPE(object) - !!< Increment the reference count of object creating a new reference - !!< counter if needed. - use parallel_tools, only: abort_if_in_parallel_region - type(REFCOUNT_TYPE), intent(inout), target :: object - integer, save :: id = 0 - - call abort_if_in_parallel_region - if (associated(object%refcount)) then - ! Reference count already exists, just increment it. - object%refcount%count=object%refcount%count+1 - - else - id = id + 1 - object%refcount=>new_refcount("REFCOUNT_TYPE", object%name) - object%refcount%id = id - end if - - end subroutine addref_REFCOUNT_TYPE - - subroutine incref_REFCOUNT_TYPE(object) - !!< Increment the reference count of object. If there are no references - !!< then error. - use parallel_tools, only: abort_if_in_parallel_region - type(REFCOUNT_TYPE), intent(in), target :: object - integer, pointer :: ptr !! Dummy pointer to evade compilers which - !! don't understand the rules for intent. - - call abort_if_in_parallel_region - if (.not.associated(object%refcount)) then - FLAbort ("Attempt to incref REFCOUNT_TYPE "//trim(object%name)//" which has no references") - end if - - ! Reference count already exists, just increment it. - ptr=>object%refcount%count - ptr=ptr+1 - - end subroutine incref_REFCOUNT_TYPE - - subroutine decref_REFCOUNT_TYPE(object) - !!< Decrement the reference count on object. If the reference count drops - !!< to 0 deallocate the refcount as a hint to the calling routine that - !!< the object can safely be deallocated. - use parallel_tools, only: abort_if_in_parallel_region - type(REFCOUNT_TYPE), intent(inout) :: object - - call abort_if_in_parallel_region - if (.not.associated(object%refcount)) then - ! No refcount. Just exit - return - end if - - object%refcount%count=object%refcount%count-1 - - if (object%refcount%count<=0) then - - if (object%refcount%count<0) then - ! Warn for negative reference count - ewrite(0,'(a, i0)') "Reference count of & - &REFCOUNT_TYPE "//trim(object%name)//& - " is ", object%refcount%count - FLAbort("that should never happen.") - end if - - object%refcount%prev%next=>object%refcount%next - if (associated(object%refcount%next)) then - object%refcount%next%prev=>object%refcount%prev - end if - - deallocate(object%refcount) - - end if - - end subroutine decref_REFCOUNT_TYPE - - pure function has_references_REFCOUNT_TYPE(object) result (has_references) - !!< Return true if there are any references to object - type(REFCOUNT_TYPE), intent(in) :: object - logical :: has_references - - has_references=associated(object%refcount) - - end function has_references_REFCOUNT_TYPE +subroutine addref_REFCOUNT_TYPE(object) + !!< Increment the reference count of object creating a new reference + !!< counter if needed. + use parallel_tools, only: abort_if_in_parallel_region + type(REFCOUNT_TYPE), intent(inout), target :: object + integer, save :: id = 0 + + call abort_if_in_parallel_region + if (associated(object%refcount)) then + ! Reference count already exists, just increment it. + object%refcount%count=object%refcount%count+1 + + else + id = id + 1 + object%refcount=>new_refcount("REFCOUNT_TYPE", object%name) + object%refcount%id = id + end if + +end subroutine addref_REFCOUNT_TYPE + +subroutine incref_REFCOUNT_TYPE(object) + !!< Increment the reference count of object. If there are no references + !!< then error. + use parallel_tools, only: abort_if_in_parallel_region + type(REFCOUNT_TYPE), intent(in), target :: object + integer, pointer :: ptr !! Dummy pointer to evade compilers which + !! don't understand the rules for intent. + + call abort_if_in_parallel_region + if (.not.associated(object%refcount)) then + FLAbort ("Attempt to incref REFCOUNT_TYPE "//trim(object%name)//" which has no references") + end if + + ! Reference count already exists, just increment it. + ptr=>object%refcount%count + ptr=ptr+1 + +end subroutine incref_REFCOUNT_TYPE + +subroutine decref_REFCOUNT_TYPE(object) + !!< Decrement the reference count on object. If the reference count drops + !!< to 0 deallocate the refcount as a hint to the calling routine that + !!< the object can safely be deallocated. + use parallel_tools, only: abort_if_in_parallel_region + type(REFCOUNT_TYPE), intent(inout) :: object + + call abort_if_in_parallel_region + if (.not.associated(object%refcount)) then + ! No refcount. Just exit + return + end if + + object%refcount%count=object%refcount%count-1 + + if (object%refcount%count<=0) then + + if (object%refcount%count<0) then + ! Warn for negative reference count + ewrite(0,'(a, i0)') "Reference count of & + &REFCOUNT_TYPE "//trim(object%name)//& + " is ", object%refcount%count + FLAbort("that should never happen.") + end if + + object%refcount%prev%next=>object%refcount%next + if (associated(object%refcount%next)) then + object%refcount%next%prev=>object%refcount%prev + end if + + deallocate(object%refcount) + + end if + +end subroutine decref_REFCOUNT_TYPE + +pure function has_references_REFCOUNT_TYPE(object) result (has_references) + !!< Return true if there are any references to object + type(REFCOUNT_TYPE), intent(in) :: object + logical :: has_references + + has_references=associated(object%refcount) + +end function has_references_REFCOUNT_TYPE diff --git a/femtools/Reference_Counting.F90 b/femtools/Reference_Counting.F90 index 375d15e4ed..9df4066d70 100644 --- a/femtools/Reference_Counting.F90 +++ b/femtools/Reference_Counting.F90 @@ -26,173 +26,173 @@ ! USA #include "fdebug.h" module reference_counting - !! A module to implement reference counting on fields. - use fldebug - use global_parameters, only: FIELD_NAME_LEN, current_debug_level - implicit none - - private - - type refcount_type - !!< Type to hold reference count for an arbitrary object. - type(refcount_type), pointer :: prev=>null(), next=>null() - integer :: count=0 - integer :: id - character(len=FIELD_NAME_LEN) :: name - character(len=FIELD_NAME_LEN) :: type - logical :: tagged=.false. - end type refcount_type - - ! Linked lists to track fields to which references exist. - type(refcount_type), save, target :: refcount_list - - public print_references, refcount_type, & - refcount_list, new_refcount, & - tag_references, print_tagged_references, & - count_references + !! A module to implement reference counting on fields. + use fldebug + use global_parameters, only: FIELD_NAME_LEN, current_debug_level + implicit none + + private + + type refcount_type + !!< Type to hold reference count for an arbitrary object. + type(refcount_type), pointer :: prev=>null(), next=>null() + integer :: count=0 + integer :: id + character(len=FIELD_NAME_LEN) :: name + character(len=FIELD_NAME_LEN) :: type + logical :: tagged=.false. + end type refcount_type + + ! Linked lists to track fields to which references exist. + type(refcount_type), save, target :: refcount_list + + public print_references, refcount_type, & + refcount_list, new_refcount, & + tag_references, print_tagged_references, & + count_references contains - function new_refcount(type, name) - !! Allocate a new refcount and place it in the refcount_list. - type(refcount_type), pointer :: new_refcount - character(len=*), intent(in) :: type, name + function new_refcount(type, name) + !! Allocate a new refcount and place it in the refcount_list. + type(refcount_type), pointer :: new_refcount + character(len=*), intent(in) :: type, name - allocate(new_refcount) + allocate(new_refcount) - new_refcount%count=1 + new_refcount%count=1 - new_refcount%name=name - new_refcount%type=type - new_refcount%tagged=.false. ! just to be sure + new_refcount%name=name + new_refcount%type=type + new_refcount%tagged=.false. ! just to be sure - ! Add the new refcounter at the head of the list. - new_refcount%next=>refcount_list%next - refcount_list%next=>new_refcount + ! Add the new refcounter at the head of the list. + new_refcount%next=>refcount_list%next + refcount_list%next=>new_refcount - ! Reverse pointers - new_refcount%prev=>refcount_list - if (associated(new_refcount%next)) then - new_refcount%next%prev=>new_refcount - end if + ! Reverse pointers + new_refcount%prev=>refcount_list + if (associated(new_refcount%next)) then + new_refcount%next%prev=>new_refcount + end if - end function new_refcount + end function new_refcount - subroutine print_references(priority) - !!< Print out a list of currently allocated fields and their reference - !!< counts. This results in ewrites with the given priority. - integer, intent(in) :: priority + subroutine print_references(priority) + !!< Print out a list of currently allocated fields and their reference + !!< counts. This results in ewrites with the given priority. + integer, intent(in) :: priority - type(refcount_type), pointer :: this_ref + type(refcount_type), pointer :: this_ref - ! the first 2 ewrites have fixed priority, so we can call print_references - ! with priority 0 to print warnings *only* if there are any references left. - ewrite(1,*) "Printing out all currently allocated references:" - this_ref=>refcount_list%next - if (.not.associated(this_ref)) then - ewrite(1,*) "There are no references left." - end if - do - if (.not.associated(this_ref)) then - exit - end if + ! the first 2 ewrites have fixed priority, so we can call print_references + ! with priority 0 to print warnings *only* if there are any references left. + ewrite(1,*) "Printing out all currently allocated references:" + this_ref=>refcount_list%next + if (.not.associated(this_ref)) then + ewrite(1,*) "There are no references left." + end if + do + if (.not.associated(this_ref)) then + exit + end if - ewrite(priority, '(a,i0)') " " // trim(this_ref%type)//& + ewrite(priority, '(a,i0)') " " // trim(this_ref%type)//& " " // trim(this_ref%name)//& " has reference count ", this_ref%count, & " and id ", this_ref%id - this_ref=>this_ref%next - end do + this_ref=>this_ref%next + end do - end subroutine print_references + end subroutine print_references - function count_references() - !!< add up all currently registered reference counts - integer:: count_references + function count_references() + !!< add up all currently registered reference counts + integer:: count_references - type(refcount_type), pointer :: this_ref + type(refcount_type), pointer :: this_ref - count_references = 0 - this_ref=>refcount_list%next - if (.not.associated(this_ref)) then - return - end if + count_references = 0 + this_ref=>refcount_list%next + if (.not.associated(this_ref)) then + return + end if - do - if (.not.associated(this_ref)) then - return - end if + do + if (.not.associated(this_ref)) then + return + end if - count_references = count_references + this_ref%count - this_ref=>this_ref%next - end do + count_references = count_references + this_ref%count + this_ref=>this_ref%next + end do - end function count_references + end function count_references - subroutine tag_references - !!< Tags all current references, so they can later be printed with - !!< print_tagged_references. This can be used if all current objects are - !!< planned for deallocation, but not before new objects are allocated. - !!< The newly allocated objects will not be tagged and therefore after - !!< we've finally deallocated the objects we planned to deallocate, - !!< we can check whether all references have gone - !!< with print_tagged_references without printing any new references. + subroutine tag_references + !!< Tags all current references, so they can later be printed with + !!< print_tagged_references. This can be used if all current objects are + !!< planned for deallocation, but not before new objects are allocated. + !!< The newly allocated objects will not be tagged and therefore after + !!< we've finally deallocated the objects we planned to deallocate, + !!< we can check whether all references have gone + !!< with print_tagged_references without printing any new references. - type(refcount_type), pointer :: this_ref + type(refcount_type), pointer :: this_ref - this_ref=>refcount_list%next - if (.not.associated(this_ref)) return ! no references yet/left + this_ref=>refcount_list%next + if (.not.associated(this_ref)) return ! no references yet/left - do - if (.not.associated(this_ref)) exit - this_ref%tagged=.true. - this_ref=>this_ref%next - end do + do + if (.not.associated(this_ref)) exit + this_ref%tagged=.true. + this_ref=>this_ref%next + end do - end subroutine tag_references + end subroutine tag_references - subroutine print_tagged_references(priority) - !!< Print out a list of all objects - !!< that have been allocated before the last call to tag_references. - !!< This results in ewrites with the given priority. - integer, intent(in) :: priority + subroutine print_tagged_references(priority) + !!< Print out a list of all objects + !!< that have been allocated before the last call to tag_references. + !!< This results in ewrites with the given priority. + integer, intent(in) :: priority - type(refcount_type), pointer :: this_ref - logical no_tags + type(refcount_type), pointer :: this_ref + logical no_tags - ! the first 2 ewrites have fixed priority, so we can call print_references - ! with priority 0 to print warnings *only* if there are any references left. - ewrite(1,*) "Printing out all tagged references:" - this_ref=>refcount_list%next - if (.not.associated(this_ref)) then - ewrite(1,*) "There are no tagged references left." - end if + ! the first 2 ewrites have fixed priority, so we can call print_references + ! with priority 0 to print warnings *only* if there are any references left. + ewrite(1,*) "Printing out all tagged references:" + this_ref=>refcount_list%next + if (.not.associated(this_ref)) then + ewrite(1,*) "There are no tagged references left." + end if - no_tags=.true. - do - if (.not.associated(this_ref)) then - exit - end if + no_tags=.true. + do + if (.not.associated(this_ref)) then + exit + end if - if (this_ref%tagged) then + if (this_ref%tagged) then - ewrite(priority, '(a,i0)') " " // trim(this_ref%type)//& - " " // trim(this_ref%name)//& - " has reference count ", this_ref%count, & - " and id ", this_ref%id - no_tags=.false. + ewrite(priority, '(a,i0)') " " // trim(this_ref%type)//& + " " // trim(this_ref%name)//& + " has reference count ", this_ref%count, & + " and id ", this_ref%id + no_tags=.false. - end if + end if - this_ref=>this_ref%next - end do + this_ref=>this_ref%next + end do - if (no_tags) then - ewrite(1,*) "No tagged references left." - end if + if (no_tags) then + ewrite(1,*) "No tagged references left." + end if - end subroutine print_tagged_references + end subroutine print_tagged_references end module reference_counting diff --git a/femtools/Rotated_Boundary_Conditions.F90 b/femtools/Rotated_Boundary_Conditions.F90 index 5219505ed6..1702342549 100644 --- a/femtools/Rotated_Boundary_Conditions.F90 +++ b/femtools/Rotated_Boundary_Conditions.F90 @@ -29,335 +29,335 @@ module rotated_boundary_conditions -use spud -use fldebug -use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN -use parallel_tools -use sparse_tools -use parallel_fields, only: zero_non_owned -use fields -use sparse_tools_petsc -use state_module -use halos -use boundary_conditions + use spud + use fldebug + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use parallel_tools + use sparse_tools + use parallel_fields, only: zero_non_owned + use fields + use sparse_tools_petsc + use state_module + use halos + use boundary_conditions -implicit none + implicit none -private + private -public :: have_rotated_bcs, create_rotation_matrix, rotate_momentum_equation,& - rotate_ct_m, rotate_velocity, rotate_velocity_back + public :: have_rotated_bcs, create_rotation_matrix, rotate_momentum_equation,& + rotate_ct_m, rotate_velocity, rotate_velocity_back contains - function have_rotated_bcs(u) + function have_rotated_bcs(u) - type(vector_field), intent(in):: u - logical:: have_rotated_bcs + type(vector_field), intent(in):: u + logical:: have_rotated_bcs - character(len=FIELD_NAME_LEN) :: bctype - character(len=OPTION_PATH_LEN):: bc_option_path - integer, dimension(:), pointer:: surface_node_list - integer:: i + character(len=FIELD_NAME_LEN) :: bctype + character(len=OPTION_PATH_LEN):: bc_option_path + integer, dimension(:), pointer:: surface_node_list + integer:: i - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & surface_node_list=surface_node_list, & option_path=bc_option_path) - if (bctype=="dirichlet" .and. & + if (bctype=="dirichlet" .and. & have_option(trim(bc_option_path)//"/type[0]/align_bc_with_surface")) then - have_rotated_bcs=.true. - return - end if - end do - - have_rotated_bcs=.false. - - end function have_rotated_bcs - - subroutine create_rotation_matrix(rotation_m, u) - - type(petsc_csr_matrix), intent(out):: rotation_m - type(vector_field), intent(in):: u - - type(halo_type), pointer:: halo - type(vector_field), pointer:: normal, tangent1, tangent2 - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: bc_option_path - integer, dimension(:), pointer:: surface_node_list - real, dimension(u%dim, u%dim):: local_rotation - integer, dimension(:), allocatable:: dnnz, onnz - integer:: i, j, node, nodes, mynodes - logical:: parallel - - ewrite(1,*) "Inside create_rotation_matrix" - - nodes=node_count(u) - if (associated(u%mesh%halos)) then - halo => u%mesh%halos(1) - mynodes=halo_nowned_nodes(halo) - else - nullify(halo) - mynodes=nodes - end if - parallel=IsParallel() - - allocate(dnnz(1:mynodes*u%dim), onnz(1:mynodes*u%dim)) - onnz=0 - ! default is just a 1.0 on the diagonal (no rotation) - dnnz=1 - - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & + have_rotated_bcs=.true. + return + end if + end do + + have_rotated_bcs=.false. + + end function have_rotated_bcs + + subroutine create_rotation_matrix(rotation_m, u) + + type(petsc_csr_matrix), intent(out):: rotation_m + type(vector_field), intent(in):: u + + type(halo_type), pointer:: halo + type(vector_field), pointer:: normal, tangent1, tangent2 + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: bc_option_path + integer, dimension(:), pointer:: surface_node_list + real, dimension(u%dim, u%dim):: local_rotation + integer, dimension(:), allocatable:: dnnz, onnz + integer:: i, j, node, nodes, mynodes + logical:: parallel + + ewrite(1,*) "Inside create_rotation_matrix" + + nodes=node_count(u) + if (associated(u%mesh%halos)) then + halo => u%mesh%halos(1) + mynodes=halo_nowned_nodes(halo) + else + nullify(halo) + mynodes=nodes + end if + parallel=IsParallel() + + allocate(dnnz(1:mynodes*u%dim), onnz(1:mynodes*u%dim)) + onnz=0 + ! default is just a 1.0 on the diagonal (no rotation) + dnnz=1 + + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & surface_node_list=surface_node_list, & option_path=bc_option_path) - if (bctype=="dirichlet" .and. & + if (bctype=="dirichlet" .and. & have_option(trim(bc_option_path)//"/type[0]/align_bc_with_surface")) then - do j=1, size(surface_node_list) - node=surface_node_list(j) - if (parallel) then - if (node>mynodes) cycle - endif - if (any(dnnz( (node-1)*u%dim+1:node*u%dim )>1)) then - FLExit("Two rotated boundary condition specifications for the same node.") - end if - dnnz( (node-1)*u%dim+1:node*u%dim ) = u%dim - end do - - end if - end do - - call allocate(rotation_m, nodes, nodes, & + do j=1, size(surface_node_list) + node=surface_node_list(j) + if (parallel) then + if (node>mynodes) cycle + endif + if (any(dnnz( (node-1)*u%dim+1:node*u%dim )>1)) then + FLExit("Two rotated boundary condition specifications for the same node.") + end if + dnnz( (node-1)*u%dim+1:node*u%dim ) = u%dim + end do + + end if + end do + + call allocate(rotation_m, nodes, nodes, & dnnz, onnz, (/ u%dim, u%dim /), group_size=(/u%dim, u%dim/), name="RotationMatrix", halo=halo) - ! put a 1.0 on the diagonal for non-rotated nodes - do i=1, mynodes - ! skip rotated nodes - if (dnnz(i*u%dim)/=1) cycle + ! put a 1.0 on the diagonal for non-rotated nodes + do i=1, mynodes + ! skip rotated nodes + if (dnnz(i*u%dim)/=1) cycle - do j=1, u%dim - call addto(rotation_m, j, j, i, i, 1.0) - end do - end do + do j=1, u%dim + call addto(rotation_m, j, j, i, i, 1.0) + end do + end do - ! insert the local rotation matrix as a diagonal block for the rotated nodes - do i=1, get_boundary_condition_count(u) - call get_boundary_condition(u, i, type=bctype, & + ! insert the local rotation matrix as a diagonal block for the rotated nodes + do i=1, get_boundary_condition_count(u) + call get_boundary_condition(u, i, type=bctype, & surface_node_list=surface_node_list, & option_path=bc_option_path) - if (bctype=="dirichlet" .and. & + if (bctype=="dirichlet" .and. & have_option(trim(bc_option_path)//"/type[0]/align_bc_with_surface")) then - normal => extract_surface_field(u, i, "normal") - tangent1 => extract_surface_field(u, i, "tangent1") - tangent2 => extract_surface_field(u, i, "tangent2") + normal => extract_surface_field(u, i, "normal") + tangent1 => extract_surface_field(u, i, "tangent1") + tangent2 => extract_surface_field(u, i, "tangent2") - do j=1, size(surface_node_list) - node=surface_node_list(j) - if (node > mynodes) cycle - local_rotation(:,1)=node_val(normal, j) - local_rotation(:,2)=node_val(tangent1, j) - if (u%dim>2) then - local_rotation(:,3)=node_val(tangent2, j) - end if + do j=1, size(surface_node_list) + node=surface_node_list(j) + if (node > mynodes) cycle + local_rotation(:,1)=node_val(normal, j) + local_rotation(:,2)=node_val(tangent1, j) + if (u%dim>2) then + local_rotation(:,3)=node_val(tangent2, j) + end if - call addto(rotation_m, node, node, local_rotation) - end do + call addto(rotation_m, node, node, local_rotation) + end do - end if - end do + end if + end do - call assemble(rotation_m) + call assemble(rotation_m) - end subroutine create_rotation_matrix + end subroutine create_rotation_matrix - subroutine rotate_momentum_equation(big_m, rhs, u, state, dg) + subroutine rotate_momentum_equation(big_m, rhs, u, state, dg) - type(petsc_csr_matrix), intent(inout):: big_m - type(vector_field), intent(inout):: rhs - type(vector_field), intent(inout):: u - type(state_type), intent(inout):: state - logical, intent(in) :: dg + type(petsc_csr_matrix), intent(inout):: big_m + type(vector_field), intent(inout):: rhs + type(vector_field), intent(inout):: u + type(state_type), intent(inout):: state + logical, intent(in) :: dg - type(petsc_csr_matrix), pointer:: rotation_m - type(petsc_csr_matrix):: rotated_big_m - type(vector_field):: result - integer:: stat + type(petsc_csr_matrix), pointer:: rotation_m + type(petsc_csr_matrix):: rotated_big_m + type(vector_field):: result + integer:: stat - ewrite(1,*) "Inside rotate_momentum_equation" + ewrite(1,*) "Inside rotate_momentum_equation" - rotation_m => extract_petsc_csr_matrix(state, "RotationMatrix", stat=stat) + rotation_m => extract_petsc_csr_matrix(state, "RotationMatrix", stat=stat) - if (stat/=0) then - allocate(rotation_m) - call create_rotation_matrix(rotation_m, u) - call insert(state, rotation_m, "RotationMatrix") - end if + if (stat/=0) then + allocate(rotation_m) + call create_rotation_matrix(rotation_m, u) + call insert(state, rotation_m, "RotationMatrix") + end if - !call assemble(big_m) - !call dump_matrix("bigm", big_m) + !call assemble(big_m) + !call dump_matrix("bigm", big_m) - ! rotate big_m: - call ptap(rotated_big_m, big_m, rotation_m) + ! rotate big_m: + call ptap(rotated_big_m, big_m, rotation_m) - !call dump_matrix("rotated_bigm", rotated_big_m) + !call dump_matrix("rotated_bigm", rotated_big_m) - ! rotate rhs: - ! need to have separate copy of the field, because of intent(out) and intent(in) - ! of mult_T call, as result%val points at the same space as rhs%val, this directly - ! puts the result in rhs as well - result=rhs - call mult_T(result, rotation_m, rhs) - if (dg) then - ! We have just poluted the halo rows of the rhs. This is incorrect - ! in the dg case due to the non-local assembly system employed. - call zero_non_owned(rhs) - end if - ! rotate u: - if (dg) then - call zero_non_owned(u) - end if - result=u ! same story - call mult_T(result, rotation_m, u) + ! rotate rhs: + ! need to have separate copy of the field, because of intent(out) and intent(in) + ! of mult_T call, as result%val points at the same space as rhs%val, this directly + ! puts the result in rhs as well + result=rhs + call mult_T(result, rotation_m, rhs) + if (dg) then + ! We have just poluted the halo rows of the rhs. This is incorrect + ! in the dg case due to the non-local assembly system employed. + call zero_non_owned(rhs) + end if + ! rotate u: + if (dg) then + call zero_non_owned(u) + end if + result=u ! same story + call mult_T(result, rotation_m, u) - ! throw out unrotated big_m and replace with rotated: - call deallocate(big_m) - big_m=rotated_big_m + ! throw out unrotated big_m and replace with rotated: + call deallocate(big_m) + big_m=rotated_big_m - if (stat/=0) then - call deallocate(rotation_m) - deallocate(rotation_m) - end if + if (stat/=0) then + call deallocate(rotation_m) + deallocate(rotation_m) + end if - end subroutine rotate_momentum_equation + end subroutine rotate_momentum_equation - subroutine rotate_ct_m(ct_m, u) + subroutine rotate_ct_m(ct_m, u) - type(block_csr_matrix), intent(inout):: ct_m - type(vector_field), intent(in):: u + type(block_csr_matrix), intent(inout):: ct_m + type(vector_field), intent(in):: u - type(vector_field), pointer:: normal, tangent1, tangent2 - character(len=FIELD_NAME_LEN):: bctype - character(len=OPTION_PATH_LEN):: bc_option_path - integer, dimension(:), pointer:: surface_node_list, rowcol - integer, dimension(:), allocatable:: node2rotated_node - real, dimension(u%dim, u%dim):: local_rotation - real, dimension(u%dim):: ct_xyz, ct_rot - real, dimension(:), pointer:: rowval - integer:: bc, i, j, k, rotated_node + type(vector_field), pointer:: normal, tangent1, tangent2 + character(len=FIELD_NAME_LEN):: bctype + character(len=OPTION_PATH_LEN):: bc_option_path + integer, dimension(:), pointer:: surface_node_list, rowcol + integer, dimension(:), allocatable:: node2rotated_node + real, dimension(u%dim, u%dim):: local_rotation + real, dimension(u%dim):: ct_xyz, ct_rot + real, dimension(:), pointer:: rowval + integer:: bc, i, j, k, rotated_node - ewrite(1,*) "Inside rotate_ct_m" + ewrite(1,*) "Inside rotate_ct_m" - assert( all(blocks(ct_m) == (/ 1, u%dim /)) ) - - allocate( node2rotated_node(1:node_count(u)) ) + assert( all(blocks(ct_m) == (/ 1, u%dim /)) ) + + allocate( node2rotated_node(1:node_count(u)) ) - do bc=1, get_boundary_condition_count(u) - call get_boundary_condition(u, bc, type=bctype, & + do bc=1, get_boundary_condition_count(u) + call get_boundary_condition(u, bc, type=bctype, & surface_node_list=surface_node_list, & option_path=bc_option_path) - if (bctype=="dirichlet" .and. & + if (bctype=="dirichlet" .and. & have_option(trim(bc_option_path)//"/type[0]/align_bc_with_surface")) then - normal => extract_surface_field(u, bc, "normal") - tangent1 => extract_surface_field(u, bc, "tangent1") - tangent2 => extract_surface_field(u, bc, "tangent2") - - node2rotated_node=0 - node2rotated_node(surface_node_list)=(/ (j, j=1, size(surface_node_list)) /) - - do i=1, size(ct_m, 1) - rowcol => row_m_ptr(ct_m, i) - do j=1, size(rowcol) - rotated_node=node2rotated_node(rowcol(j)) - if (rotated_node/=0) then - ! construct local rotation matrix - local_rotation(1,:)=node_val(normal, rotated_node) - local_rotation(2,:)=node_val(tangent1, rotated_node) - if (u%dim>2) then - local_rotation(3,:)=node_val(tangent2, rotated_node) - end if - - ! look up ct_m values of row i, column rowcol(j) in xyz orientation - do k=1, blocks(ct_m,2) - rowval => row_val_ptr(ct_m, 1, k, i) - ct_xyz(k)=rowval(j) - end do - ! rotate to normal, tangent1, tangent2 orientation - ct_rot=matmul( local_rotation, ct_xyz) - ! put back in the matrix - do k=1, blocks(ct_m,2) - rowval => row_val_ptr(ct_m, 1, k, i) - rowval(j)=ct_rot(k) - end do - end if - end do - end do - end if - end do - - deallocate(node2rotated_node) - - end subroutine rotate_ct_m - - subroutine rotate_velocity(vfield, state) - - type(vector_field), intent(inout):: vfield - type(state_type), intent(inout):: state - - type(vector_field), pointer:: u - type(vector_field):: result - type(petsc_csr_matrix), pointer:: rotation_m - integer:: stat - - rotation_m => extract_petsc_csr_matrix(state, "RotationMatrix", stat=stat) - if (stat/=0) then - allocate(rotation_m) - ! the vector field we are rotating might not have the bcs attached to it: - u => extract_vector_field(state, "Velocity") - call create_rotation_matrix(rotation_m, u) - call insert(state, rotation_m, "RotationMatrix") - end if - - result=vfield ! see note in rotate_momentum_equation - call mult_T(result, rotation_m, vfield) - - if (stat/=0) then - call deallocate(rotation_m) - deallocate(rotation_m) - end if - - end subroutine rotate_velocity - - subroutine rotate_velocity_back(vfield, state) - - type(vector_field), intent(inout):: vfield - type(state_type), intent(inout):: state - - type(vector_field), pointer:: u - type(vector_field):: result - type(petsc_csr_matrix), pointer:: rotation_m - integer:: stat - - rotation_m => extract_petsc_csr_matrix(state, "RotationMatrix", stat=stat) - if (stat/=0) then - allocate(rotation_m) - ! the vector field we are rotating might not have the bcs attached to it: - u => extract_vector_field(state, "Velocity") - call create_rotation_matrix(rotation_m, u) - call insert(state, rotation_m, "RotationMatrix") - end if - - result=vfield ! see note in rotate_momentum_equation - call mult(result, rotation_m, vfield) - - if (stat/=0) then - call deallocate(rotation_m) - deallocate(rotation_m) - end if - - end subroutine rotate_velocity_back + normal => extract_surface_field(u, bc, "normal") + tangent1 => extract_surface_field(u, bc, "tangent1") + tangent2 => extract_surface_field(u, bc, "tangent2") + + node2rotated_node=0 + node2rotated_node(surface_node_list)=(/ (j, j=1, size(surface_node_list)) /) + + do i=1, size(ct_m, 1) + rowcol => row_m_ptr(ct_m, i) + do j=1, size(rowcol) + rotated_node=node2rotated_node(rowcol(j)) + if (rotated_node/=0) then + ! construct local rotation matrix + local_rotation(1,:)=node_val(normal, rotated_node) + local_rotation(2,:)=node_val(tangent1, rotated_node) + if (u%dim>2) then + local_rotation(3,:)=node_val(tangent2, rotated_node) + end if + + ! look up ct_m values of row i, column rowcol(j) in xyz orientation + do k=1, blocks(ct_m,2) + rowval => row_val_ptr(ct_m, 1, k, i) + ct_xyz(k)=rowval(j) + end do + ! rotate to normal, tangent1, tangent2 orientation + ct_rot=matmul( local_rotation, ct_xyz) + ! put back in the matrix + do k=1, blocks(ct_m,2) + rowval => row_val_ptr(ct_m, 1, k, i) + rowval(j)=ct_rot(k) + end do + end if + end do + end do + end if + end do + + deallocate(node2rotated_node) + + end subroutine rotate_ct_m + + subroutine rotate_velocity(vfield, state) + + type(vector_field), intent(inout):: vfield + type(state_type), intent(inout):: state + + type(vector_field), pointer:: u + type(vector_field):: result + type(petsc_csr_matrix), pointer:: rotation_m + integer:: stat + + rotation_m => extract_petsc_csr_matrix(state, "RotationMatrix", stat=stat) + if (stat/=0) then + allocate(rotation_m) + ! the vector field we are rotating might not have the bcs attached to it: + u => extract_vector_field(state, "Velocity") + call create_rotation_matrix(rotation_m, u) + call insert(state, rotation_m, "RotationMatrix") + end if + + result=vfield ! see note in rotate_momentum_equation + call mult_T(result, rotation_m, vfield) + + if (stat/=0) then + call deallocate(rotation_m) + deallocate(rotation_m) + end if + + end subroutine rotate_velocity + + subroutine rotate_velocity_back(vfield, state) + + type(vector_field), intent(inout):: vfield + type(state_type), intent(inout):: state + + type(vector_field), pointer:: u + type(vector_field):: result + type(petsc_csr_matrix), pointer:: rotation_m + integer:: stat + + rotation_m => extract_petsc_csr_matrix(state, "RotationMatrix", stat=stat) + if (stat/=0) then + allocate(rotation_m) + ! the vector field we are rotating might not have the bcs attached to it: + u => extract_vector_field(state, "Velocity") + call create_rotation_matrix(rotation_m, u) + call insert(state, rotation_m, "RotationMatrix") + end if + + result=vfield ! see note in rotate_momentum_equation + call mult(result, rotation_m, vfield) + + if (stat/=0) then + call deallocate(rotation_m) + deallocate(rotation_m) + end if + + end subroutine rotate_velocity_back end module rotated_boundary_conditions diff --git a/femtools/SampleNetCDF_fortran.F90 b/femtools/SampleNetCDF_fortran.F90 index 76a95312b6..de3c57b657 100644 --- a/femtools/SampleNetCDF_fortran.F90 +++ b/femtools/SampleNetCDF_fortran.F90 @@ -26,69 +26,69 @@ ! USA module SampleNetCDF - use FLDebug + use FLDebug - implicit none + implicit none - private + private - public :: SampleNetCDF_Open, SampleNetCDF_SetVariable,& - SampleNetCDF_GetValue, SampleNetCDF_Close + public :: SampleNetCDF_Open, SampleNetCDF_SetVariable,& + SampleNetCDF_GetValue, SampleNetCDF_Close - interface + interface - subroutine samplenetcdf_open_c(name, n, id) - character (len=*) :: name - integer, intent(in) :: n - integer, intent(out) :: id - end subroutine samplenetcdf_open_c + subroutine samplenetcdf_open_c(name, n, id) + character (len=*) :: name + integer, intent(in) :: n + integer, intent(out) :: id + end subroutine samplenetcdf_open_c - subroutine samplenetcdf_setvariable_c(id, varname, n) - integer, intent(out) :: id - character (len=*) :: varname - integer, intent(in) :: n - end subroutine samplenetcdf_setvariable_c + subroutine samplenetcdf_setvariable_c(id, varname, n) + integer, intent(out) :: id + character (len=*) :: varname + integer, intent(in) :: n + end subroutine samplenetcdf_setvariable_c - subroutine samplenetcdf_close_c(id) - integer, intent(out) ::id - end subroutine samplenetcdf_close_c + subroutine samplenetcdf_close_c(id) + integer, intent(out) ::id + end subroutine samplenetcdf_close_c - subroutine samplenetcdf_getvalue_c(id, longitude, latitude, val) - integer, intent(out)::id - real, intent(out)::longitude, latitude - real, intent(out)::val - end subroutine Samplenetcdf_getvalue_c + subroutine samplenetcdf_getvalue_c(id, longitude, latitude, val) + integer, intent(out)::id + real, intent(out)::longitude, latitude + real, intent(out)::val + end subroutine Samplenetcdf_getvalue_c - end interface + end interface contains - subroutine SampleNetCDF_Open(name, id) - character(len=*), intent(in)::name - integer, intent(out)::id + subroutine SampleNetCDF_Open(name, id) + character(len=*), intent(in)::name + integer, intent(out)::id - call samplenetcdf_open_c(name, len_trim(name), id) - end subroutine SampleNetCDF_Open + call samplenetcdf_open_c(name, len_trim(name), id) + end subroutine SampleNetCDF_Open - subroutine SampleNetCDF_SetVariable(id, varname) - character(len=*), intent(in)::varname - integer, intent(out)::id + subroutine SampleNetCDF_SetVariable(id, varname) + character(len=*), intent(in)::varname + integer, intent(out)::id - call samplenetcdf_setvariable_c(id, varname, len_trim(varname)) - end subroutine SampleNetCDF_SetVariable + call samplenetcdf_setvariable_c(id, varname, len_trim(varname)) + end subroutine SampleNetCDF_SetVariable - subroutine SampleNetCDF_GetValue(id, longitude, latitude, val) - integer, intent(out)::id - real, intent(out)::longitude, latitude - real, intent(out)::val + subroutine SampleNetCDF_GetValue(id, longitude, latitude, val) + integer, intent(out)::id + real, intent(out)::longitude, latitude + real, intent(out)::val - call samplenetcdf_getvalue_c(id, longitude, latitude, val) - end subroutine SampleNetCDF_GetValue + call samplenetcdf_getvalue_c(id, longitude, latitude, val) + end subroutine SampleNetCDF_GetValue - subroutine SampleNetCDF_Close(id) - integer, intent(out)::id + subroutine SampleNetCDF_Close(id) + integer, intent(out)::id - call samplenetcdf_close_c(id) - end subroutine SampleNetCDF_Close + call samplenetcdf_close_c(id) + end subroutine SampleNetCDF_Close end module SampleNetCDF diff --git a/femtools/Shape_Functions.F90 b/femtools/Shape_Functions.F90 index 837da83dec..d2a079c577 100644 --- a/femtools/Shape_Functions.F90 +++ b/femtools/Shape_Functions.F90 @@ -26,364 +26,364 @@ ! USA #include "fdebug.h" module shape_functions - !!< Generate shape functions for elements of arbitrary polynomial degree. - use FLDebug - use futils - use polynomials - use element_numbering - use quadrature - use elements - use Superconvergence - use ieee_arithmetic, only: ieee_quiet_nan, ieee_value + !!< Generate shape functions for elements of arbitrary polynomial degree. + use FLDebug + use futils + use polynomials + use element_numbering + use quadrature + use elements + use Superconvergence + use ieee_arithmetic, only: ieee_quiet_nan, ieee_value - implicit none + implicit none - private :: lagrange_polynomial, nonconforming_polynomial + private :: lagrange_polynomial, nonconforming_polynomial - interface make_element_shape - module procedure make_element_shape_from_element, make_element_shape - end interface + interface make_element_shape + module procedure make_element_shape_from_element, make_element_shape + end interface contains - function make_element_shape_from_element(model, vertices, dim, degree,& - & quad, type, quad_s, constraint_type_choice, stat) result (shape) - !!< This function enables element shapes to be derived from other - !!< element shapes by specifying which attributes to change. - type(element_type) :: shape - type(element_type), intent(in) :: model - !! Vertices is the number of vertices of the element, not the number of nodes! - !! dim may be 1, 2, or 3. - !! Degree is the degree of the Lagrange polynomials. - integer, intent(in), optional :: vertices, dim, degree - type(quadrature_type), intent(in), target, optional :: quad - integer, intent(in), optional :: type - type(quadrature_type), intent(in), optional, target :: quad_s - !! Element constraints - integer, intent(in), optional :: constraint_type_choice - integer, intent(out), optional :: stat - - integer :: lvertices, ldim, ldegree, lconstraint_type_choice - type(quadrature_type) :: lquad - type(quadrature_type), pointer :: lquad_s - integer :: ltype - - if (present(vertices)) then - lvertices=vertices - else - lvertices=model%numbering%vertices - end if - - if (present(dim)) then - ldim=dim - else - ldim=model%dim - end if - - if(present(degree)) then - ldegree=degree - else - ldegree=model%degree - end if - - if(present(quad)) then - lquad=quad - else - lquad=model%quadrature - end if - - if(present(type)) then - ltype=type - else - ltype=model%numbering%type - end if - - if(present(quad_s)) then - lquad_s=>quad_s - else if (associated(model%surface_quadrature)) then - lquad_s=>model%surface_quadrature - else - lquad_s=>null() - end if - - if(present(constraint_type_choice)) then - lconstraint_type_choice=constraint_type_choice - else if (associated(model%constraints)) then - lconstraint_type_choice=model%constraints%type - else - lconstraint_type_choice=CONSTRAINT_NONE - end if - - - if (associated(lquad_s)) then - shape = make_element_shape(lvertices, ldim, ldegree, lquad, ltype,& + function make_element_shape_from_element(model, vertices, dim, degree,& + & quad, type, quad_s, constraint_type_choice, stat) result (shape) + !!< This function enables element shapes to be derived from other + !!< element shapes by specifying which attributes to change. + type(element_type) :: shape + type(element_type), intent(in) :: model + !! Vertices is the number of vertices of the element, not the number of nodes! + !! dim may be 1, 2, or 3. + !! Degree is the degree of the Lagrange polynomials. + integer, intent(in), optional :: vertices, dim, degree + type(quadrature_type), intent(in), target, optional :: quad + integer, intent(in), optional :: type + type(quadrature_type), intent(in), optional, target :: quad_s + !! Element constraints + integer, intent(in), optional :: constraint_type_choice + integer, intent(out), optional :: stat + + integer :: lvertices, ldim, ldegree, lconstraint_type_choice + type(quadrature_type) :: lquad + type(quadrature_type), pointer :: lquad_s + integer :: ltype + + if (present(vertices)) then + lvertices=vertices + else + lvertices=model%numbering%vertices + end if + + if (present(dim)) then + ldim=dim + else + ldim=model%dim + end if + + if(present(degree)) then + ldegree=degree + else + ldegree=model%degree + end if + + if(present(quad)) then + lquad=quad + else + lquad=model%quadrature + end if + + if(present(type)) then + ltype=type + else + ltype=model%numbering%type + end if + + if(present(quad_s)) then + lquad_s=>quad_s + else if (associated(model%surface_quadrature)) then + lquad_s=>model%surface_quadrature + else + lquad_s=>null() + end if + + if(present(constraint_type_choice)) then + lconstraint_type_choice=constraint_type_choice + else if (associated(model%constraints)) then + lconstraint_type_choice=model%constraints%type + else + lconstraint_type_choice=CONSTRAINT_NONE + end if + + + if (associated(lquad_s)) then + shape = make_element_shape(lvertices, ldim, ldegree, lquad, ltype,& lquad_s, constraint_type_choice=lconstraint_type_choice, stat=stat) - else - shape = make_element_shape(lvertices, ldim, ldegree, lquad, ltype,& + else + shape = make_element_shape(lvertices, ldim, ldegree, lquad, ltype,& constraint_type_choice=lconstraint_type_choice, stat=stat) - end if - - end function make_element_shape_from_element - - function make_element_shape(vertices, dim, degree, quad, type,& - quad_s, constraint_type_choice, stat) result (shape) - !!< Generate the shape functions for an element. The result is a suitable - !!< element_type. - !! - !!< At this stage only Lagrange family polynomial elements are supported. - type(element_type) :: shape - !! Vertices is the number of vertices of the element, not the number of nodes! - !! dim \in [1,2,3] is currently supported. - !! Degree is the degree of the Lagrange polynomials. - integer, intent(in) :: vertices, dim, degree - type(quadrature_type), intent(in), target :: quad - integer, intent(in), optional :: type - type(quadrature_type), intent(in), optional, target :: quad_s - integer, intent(in), optional :: constraint_type_choice - integer, intent(out), optional :: stat - - real, pointer :: g(:)=> null() - - type(ele_numbering_type), pointer :: ele_num - ! Count coordinates of each point - integer, dimension(dim+1) :: counts - integer :: i,j,k - integer :: ltype, coords - real :: dx - type(constraints_type), pointer :: constraint - - ! Check that the quadrature and the element shapes match. - assert(quad%vertices==vertices) - assert(quad%dim==dim) - - if (present(type)) then - ltype=type - else - ltype=ELEMENT_LAGRANGIAN - end if - - if (present(stat)) stat=0 - - ! Get the local numbering of our element - ele_num=>find_element_numbering(vertices, dim, degree, type) - - if (.not.associated(ele_num)) then - if (present(stat)) then - stat=1 - return - else - FLAbort('Element numbering unavailable.') - end if - end if - - shape%numbering=>ele_num - shape%quadrature=quad - call incref(quad) - - ! The number of local coordinates depends on the element family. - select case(ele_num%family) - case (FAMILY_SIMPLEX) - coords=dim+1 - case (FAMILY_CUBE) - if(ele_num%type==ELEMENT_TRACE .and. dim==2) then - !For trace elements the local coordinate is face number - !then the local coordinates on the face - !For quads, the face is an interval element which has - !two local coordinates. - coords=3 - else - coords=dim - end if - case default - FLAbort('Illegal element family.') - end select - - if (present(quad_s) .and. ele_num%type/=ELEMENT_TRACE .and. ele_num%family==FAMILY_SIMPLEX) then - allocate(shape%surface_quadrature) - shape%surface_quadrature=quad_s - call incref(quad_s) - call allocate(shape, ele_num, quad%ngi, ngi_s=quad_s%ngi) - shape%n_s=0.0 - shape%dn_s=0.0 - else - call allocate(shape, ele_num, quad%ngi) - end if - shape%degree=degree - shape%n=0.0 - shape%dn=0.0 - - ! Construct shape for each node - do i=1,shape%loc - - counts(1:coords)=ele_num%number2count(:,i) - - ! Construct appropriate polynomials. - do j=1,coords - - select case(ltype) - case(ELEMENT_LAGRANGIAN) - if (degree == 0) then - dx = 0.0 - else - dx = 1.0/degree - end if - select case(ele_num%family) - case (FAMILY_SIMPLEX) - ! Raw polynomial. - shape%spoly(j,i)& + end if + + end function make_element_shape_from_element + + function make_element_shape(vertices, dim, degree, quad, type,& + quad_s, constraint_type_choice, stat) result (shape) + !!< Generate the shape functions for an element. The result is a suitable + !!< element_type. + !! + !!< At this stage only Lagrange family polynomial elements are supported. + type(element_type) :: shape + !! Vertices is the number of vertices of the element, not the number of nodes! + !! dim \in [1,2,3] is currently supported. + !! Degree is the degree of the Lagrange polynomials. + integer, intent(in) :: vertices, dim, degree + type(quadrature_type), intent(in), target :: quad + integer, intent(in), optional :: type + type(quadrature_type), intent(in), optional, target :: quad_s + integer, intent(in), optional :: constraint_type_choice + integer, intent(out), optional :: stat + + real, pointer :: g(:)=> null() + + type(ele_numbering_type), pointer :: ele_num + ! Count coordinates of each point + integer, dimension(dim+1) :: counts + integer :: i,j,k + integer :: ltype, coords + real :: dx + type(constraints_type), pointer :: constraint + + ! Check that the quadrature and the element shapes match. + assert(quad%vertices==vertices) + assert(quad%dim==dim) + + if (present(type)) then + ltype=type + else + ltype=ELEMENT_LAGRANGIAN + end if + + if (present(stat)) stat=0 + + ! Get the local numbering of our element + ele_num=>find_element_numbering(vertices, dim, degree, type) + + if (.not.associated(ele_num)) then + if (present(stat)) then + stat=1 + return + else + FLAbort('Element numbering unavailable.') + end if + end if + + shape%numbering=>ele_num + shape%quadrature=quad + call incref(quad) + + ! The number of local coordinates depends on the element family. + select case(ele_num%family) + case (FAMILY_SIMPLEX) + coords=dim+1 + case (FAMILY_CUBE) + if(ele_num%type==ELEMENT_TRACE .and. dim==2) then + !For trace elements the local coordinate is face number + !then the local coordinates on the face + !For quads, the face is an interval element which has + !two local coordinates. + coords=3 + else + coords=dim + end if + case default + FLAbort('Illegal element family.') + end select + + if (present(quad_s) .and. ele_num%type/=ELEMENT_TRACE .and. ele_num%family==FAMILY_SIMPLEX) then + allocate(shape%surface_quadrature) + shape%surface_quadrature=quad_s + call incref(quad_s) + call allocate(shape, ele_num, quad%ngi, ngi_s=quad_s%ngi) + shape%n_s=0.0 + shape%dn_s=0.0 + else + call allocate(shape, ele_num, quad%ngi) + end if + shape%degree=degree + shape%n=0.0 + shape%dn=0.0 + + ! Construct shape for each node + do i=1,shape%loc + + counts(1:coords)=ele_num%number2count(:,i) + + ! Construct appropriate polynomials. + do j=1,coords + + select case(ltype) + case(ELEMENT_LAGRANGIAN) + if (degree == 0) then + dx = 0.0 + else + dx = 1.0/degree + end if + select case(ele_num%family) + case (FAMILY_SIMPLEX) + ! Raw polynomial. + shape%spoly(j,i)& =lagrange_polynomial(counts(j), counts(j), dx) - case(FAMILY_CUBE) - ! note that local coordinates run from -1.0 to 1.0 - shape%spoly(j,i)& + case(FAMILY_CUBE) + ! note that local coordinates run from -1.0 to 1.0 + shape%spoly(j,i)& =lagrange_polynomial(counts(j), degree, 2.0*dx, & origin=-1.0) - end select + end select - case(ELEMENT_TRACE) - shape%spoly(j,i) = (/ieee_value(0.0,ieee_quiet_nan)/) + case(ELEMENT_TRACE) + shape%spoly(j,i) = (/ieee_value(0.0,ieee_quiet_nan)/) - case(ELEMENT_BUBBLE) - if(i==shape%loc) then + case(ELEMENT_BUBBLE) + if(i==shape%loc) then - ! the last node is the bubble shape function - shape%spoly(j,i) = (/1.0, 0.0/) + ! the last node is the bubble shape function + shape%spoly(j,i) = (/1.0, 0.0/) - else + else - select case(ele_num%family) - case (FAMILY_SIMPLEX) - ! Raw polynomial. - shape%spoly(j,i)& + select case(ele_num%family) + case (FAMILY_SIMPLEX) + ! Raw polynomial. + shape%spoly(j,i)& =lagrange_polynomial(counts(j)/coords, counts(j)/coords, 1.0/degree) - end select - - end if - - case(ELEMENT_NONCONFORMING) - - shape%spoly(j,i)=nonconforming_polynomial(counts(j)) - - case default - - FLAbort('An unsupported element type has been selected.') - - end select - - ! Derivative - if(ele_num%type==ELEMENT_TRACE) then - shape%dspoly(j,i) = (/ieee_value(0.0,ieee_quiet_nan)/) - else - shape%dspoly(j,i)=ddx(shape%spoly(j,i)) - end if - end do - - if(ele_num%type==ELEMENT_TRACE) then - !No interior functions, hence NaNs - shape%n = ieee_value(0.0,ieee_quiet_nan) - shape%dn = ieee_value(0.0,ieee_quiet_nan) - else - ! Loop over all the quadrature points. - do j=1,quad%ngi + end select + + end if + + case(ELEMENT_NONCONFORMING) + + shape%spoly(j,i)=nonconforming_polynomial(counts(j)) + + case default + + FLAbort('An unsupported element type has been selected.') + + end select + + ! Derivative + if(ele_num%type==ELEMENT_TRACE) then + shape%dspoly(j,i) = (/ieee_value(0.0,ieee_quiet_nan)/) + else + shape%dspoly(j,i)=ddx(shape%spoly(j,i)) + end if + end do + + if(ele_num%type==ELEMENT_TRACE) then + !No interior functions, hence NaNs + shape%n = ieee_value(0.0,ieee_quiet_nan) + shape%dn = ieee_value(0.0,ieee_quiet_nan) + else + ! Loop over all the quadrature points. + do j=1,quad%ngi - ! Raw shape function - shape%n(i,j)=eval_shape(shape, i, quad%l(j,:)) + ! Raw shape function + shape%n(i,j)=eval_shape(shape, i, quad%l(j,:)) - ! Directional derivatives. - shape%dn(i,j,:)=eval_dshape(shape, i, quad%l(j,:)) - end do + ! Directional derivatives. + shape%dn(i,j,:)=eval_dshape(shape, i, quad%l(j,:)) + end do - if (present(quad_s)) then - select case(ele_num%family) - case(FAMILY_SIMPLEX) - allocate(g(dim+1)) - do j=1,quad_s%ngi - g(1) = 0.0 - do k=1,dim - g(k+1)=quad_s%l(j,k) - end do - ! In order to match the arbitrary face node ordering - ! these must get reoriented before use so we don't care - ! about which local facet they're with respect to. - shape%n_s(i,j)=eval_shape(shape,i,g) - shape%dn_s(i,j,:)=eval_dshape(shape,i,g) - end do - deallocate(g) - end select - end if - end if - end do + if (present(quad_s)) then + select case(ele_num%family) + case(FAMILY_SIMPLEX) + allocate(g(dim+1)) + do j=1,quad_s%ngi + g(1) = 0.0 + do k=1,dim + g(k+1)=quad_s%l(j,k) + end do + ! In order to match the arbitrary face node ordering + ! these must get reoriented before use so we don't care + ! about which local facet they're with respect to. + shape%n_s(i,j)=eval_shape(shape,i,g) + shape%dn_s(i,j,:)=eval_dshape(shape,i,g) + end do + deallocate(g) + end select + end if + end if + end do - if(ele_num%type.ne.ELEMENT_TRACE) then - shape%superconvergence => get_superconvergence(shape) - end if + if(ele_num%type.ne.ELEMENT_TRACE) then + shape%superconvergence => get_superconvergence(shape) + end if - if(present(constraint_type_choice)) then - if(constraint_type_choice/=CONSTRAINT_NONE) then - allocate(constraint) - shape%constraints=>constraint - call allocate(shape%constraints,shape,constraint_type_choice) - end if - end if + if(present(constraint_type_choice)) then + if(constraint_type_choice/=CONSTRAINT_NONE) then + allocate(constraint) + shape%constraints=>constraint + call allocate(shape%constraints,shape,constraint_type_choice) + end if + end if - end function make_element_shape + end function make_element_shape - function lagrange_polynomial(n,degree,dx, origin) result (poly) - ! nth equispaced lagrange polynomial of specified degree and point - ! spacing dx. - integer, intent(in) :: n, degree - real, intent(in) :: dx - type(polynomial) :: poly - ! fixes location of n=0 location (0.0 if not specified) - real, intent(in), optional :: origin + function lagrange_polynomial(n,degree,dx, origin) result (poly) + ! nth equispaced lagrange polynomial of specified degree and point + ! spacing dx. + integer, intent(in) :: n, degree + real, intent(in) :: dx + type(polynomial) :: poly + ! fixes location of n=0 location (0.0 if not specified) + real, intent(in), optional :: origin - real lorigin - integer :: i + real lorigin + integer :: i - ! This shouldn't be necessary but there appears to be a bug in initial - ! component values in gfortran: - poly%coefs=>null() - poly%degree=-1 + ! This shouldn't be necessary but there appears to be a bug in initial + ! component values in gfortran: + poly%coefs=>null() + poly%degree=-1 - if (present(origin)) then - lorigin=origin - else - lorigin=0.0 - end if + if (present(origin)) then + lorigin=origin + else + lorigin=0.0 + end if - poly=(/1.0/) + poly=(/1.0/) - degreeloop: do i=0,degree - if (i==n) cycle degreeloop + degreeloop: do i=0,degree + if (i==n) cycle degreeloop - poly=poly*(/1.0, -(lorigin+i*dx) /) - - end do degreeloop - - ! normalize to 1.0 in the n-th location - poly=poly/eval(poly, lorigin+n*dx) - - end function lagrange_polynomial - - function nonconforming_polynomial(n) result (poly) - ! nth P1 nonconforming polynomial. - integer, intent(in) :: n - type(polynomial) :: poly - - ! This shouldn't be necessary but there appears to be a bug in initial - ! component values in gfortran: - poly%coefs=>null() - poly%degree=-1 - - poly=(/1.0/) - - if (n==0) then - - ! polynomial is -2x+1 - poly=(/-2.0, 1.0/) - - end if - - end function nonconforming_polynomial + poly=poly*(/1.0, -(lorigin+i*dx) /) + + end do degreeloop + + ! normalize to 1.0 in the n-th location + poly=poly/eval(poly, lorigin+n*dx) + + end function lagrange_polynomial + + function nonconforming_polynomial(n) result (poly) + ! nth P1 nonconforming polynomial. + integer, intent(in) :: n + type(polynomial) :: poly + + ! This shouldn't be necessary but there appears to be a bug in initial + ! component values in gfortran: + poly%coefs=>null() + poly%degree=-1 + + poly=(/1.0/) + + if (n==0) then + + ! polynomial is -2x+1 + poly=(/-2.0, 1.0/) + + end if + + end function nonconforming_polynomial end module shape_functions diff --git a/femtools/Shape_Functions_Test.F90 b/femtools/Shape_Functions_Test.F90 index 9267e32032..2d72de332a 100644 --- a/femtools/Shape_Functions_Test.F90 +++ b/femtools/Shape_Functions_Test.F90 @@ -27,120 +27,120 @@ #include "fdebug.h" module shape_functions_test - !!< Support module for all unit tests related to shape_functions. - !!< Provides auxiliary routines needed by these tests and separates these - !!< from the actual module, thereby reducing dependencies. - use shape_functions - use spud, only: option_count, get_option + !!< Support module for all unit tests related to shape_functions. + !!< Provides auxiliary routines needed by these tests and separates these + !!< from the actual module, thereby reducing dependencies. + use shape_functions + use spud, only: option_count, get_option - ! Power is used by the test functions. - integer, save :: power=0 + ! Power is used by the test functions. + integer, save :: power=0 contains - !------------------------------------------------------------------------ - ! Test procedures - !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + ! Test procedures + !------------------------------------------------------------------------ - function shape_integrate(integrand, element) result (integral) - !!< Integrate the function integrand over an element using the - !!< specified shape functions and quadrature. - real :: integral - interface - function integrand(coords) - real :: integrand - real, dimension(:), intent(in) :: coords - end function integrand - end interface - type(element_type), intent(in) :: element + function shape_integrate(integrand, element) result (integral) + !!< Integrate the function integrand over an element using the + !!< specified shape functions and quadrature. + real :: integral + interface + function integrand(coords) + real :: integrand + real, dimension(:), intent(in) :: coords + end function integrand + end interface + type(element_type), intent(in) :: element - real :: tmpval - integer :: i,j + real :: tmpval + integer :: i,j - integral=0.0 + integral=0.0 - do i=1, element%loc + do i=1, element%loc - tmpval=integrand(local_coords(i,element)) + tmpval=integrand(local_coords(i,element)) - do j=1, element%quadrature%ngi + do j=1, element%quadrature%ngi - integral=integral+element%quadrature%weight(j)*tmpval*element%n(i,j) + integral=integral+element%quadrature%weight(j)*tmpval*element%n(i,j) - end do - end do + end do + end do - end function shape_integrate + end function shape_integrate - function shape_integrate_diff(integrand, element, dim) result (integral) - !!< Integrate the function derivative of integrand with respect to dim - !!< over an element using the specified shape functions and quadrature. - real :: integral - interface - function integrand(coords) - real :: integrand - real, dimension(:), intent(in) :: coords - end function integrand - end interface - type(element_type), intent(in) :: element - integer, intent(in) :: dim + function shape_integrate_diff(integrand, element, dim) result (integral) + !!< Integrate the function derivative of integrand with respect to dim + !!< over an element using the specified shape functions and quadrature. + real :: integral + interface + function integrand(coords) + real :: integrand + real, dimension(:), intent(in) :: coords + end function integrand + end interface + type(element_type), intent(in) :: element + integer, intent(in) :: dim - real :: tmpval - integer :: i,j + real :: tmpval + integer :: i,j - integral=0.0 + integral=0.0 - do i=1, element%loc + do i=1, element%loc - tmpval=integrand(local_coords(i,element)) + tmpval=integrand(local_coords(i,element)) - do j=1, element%quadrature%ngi + do j=1, element%quadrature%ngi - integral=integral& + integral=integral& +element%quadrature%weight(j)*tmpval*element%dn(i,j,dim) - end do - end do + end do + end do - end function shape_integrate_diff + end function shape_integrate_diff - function monic(coords) - !!< Calculate x^n - real :: monic - real, dimension(:), intent(in) :: coords + function monic(coords) + !!< Calculate x^n + real :: monic + real, dimension(:), intent(in) :: coords - monic=coords(1)**power + monic=coords(1)**power - end function monic + end function monic - function cube_monic(coords) - ! Calculate. - real :: cube_monic - real, dimension(:), intent(in) :: coords + function cube_monic(coords) + ! Calculate. + real :: cube_monic + real, dimension(:), intent(in) :: coords - cube_monic=((1-coords(1))/2.0)**power + cube_monic=((1-coords(1))/2.0)**power - end function cube_monic + end function cube_monic - subroutine shape_functions_test_check_options + subroutine shape_functions_test_check_options - integer :: quaddegree, degree, stat, i, nmesh + integer :: quaddegree, degree, stat, i, nmesh - call get_option("/geometry/quadrature/degree", quaddegree) - nmesh = option_count("/geometry/mesh") - do i = 1, nmesh - call get_option("/geometry/mesh["//int2str(i-1)//& - "]/from_mesh/mesh_shape/polynomial_degree", & - degree, stat) - if(stat==0) then - if (quaddegree<2*degree) then - ewrite(0,"(a,i0,a,i0)") "Warning: quadrature of degree ",quaddegree& - &," may be incomplete for elements of degree ",degree - end if - end if - end do + call get_option("/geometry/quadrature/degree", quaddegree) + nmesh = option_count("/geometry/mesh") + do i = 1, nmesh + call get_option("/geometry/mesh["//int2str(i-1)//& + "]/from_mesh/mesh_shape/polynomial_degree", & + degree, stat) + if(stat==0) then + if (quaddegree<2*degree) then + ewrite(0,"(a,i0,a,i0)") "Warning: quadrature of degree ",quaddegree& + &," may be incomplete for elements of degree ",degree + end if + end if + end do - end subroutine shape_functions_test_check_options + end subroutine shape_functions_test_check_options end module shape_functions_test diff --git a/femtools/Signal_Vars.F90 b/femtools/Signal_Vars.F90 index 59d9e234fb..9c0faecf55 100644 --- a/femtools/Signal_Vars.F90 +++ b/femtools/Signal_Vars.F90 @@ -26,17 +26,17 @@ ! USA module signal_vars - ! This module provides a safe storage place for signal flags. Module - ! inheritance rules prevent this being combined with Signals. - implicit none + ! This module provides a safe storage place for signal flags. Module + ! inheritance rules prevent this being combined with Signals. + implicit none - ! SIGHUP is not yet used in fluidity. - logical, save :: sig_hup=.false. - logical, save :: sig_int=.false. + ! SIGHUP is not yet used in fluidity. + logical, save :: sig_hup=.false. + logical, save :: sig_int=.false. - ! Hopefully these values are fairly portable: - integer, parameter :: SIGHUP=1 - integer, parameter :: SIGINT=2 - integer, parameter :: SIGFPE=8 - integer, parameter :: SIGTERM=15 + ! Hopefully these values are fairly portable: + integer, parameter :: SIGHUP=1 + integer, parameter :: SIGINT=2 + integer, parameter :: SIGFPE=8 + integer, parameter :: SIGTERM=15 end module signal_vars diff --git a/femtools/Signals.F90 b/femtools/Signals.F90 index 383596179b..2b020ed3d3 100644 --- a/femtools/Signals.F90 +++ b/femtools/Signals.F90 @@ -27,23 +27,23 @@ #include "confdefs.h" module signals - ! This module sets up signal handling. - use signal_vars - implicit none + ! This module sets up signal handling. + use signal_vars + implicit none #ifdef SIGNAL_HAVE_FLAG - interface - function signal(signum, proc, flag) - integer :: signal - integer, intent(in):: signum, flag - interface - function proc(signum) - integer :: proc - integer, intent(in) :: signum - end function proc - end interface - end function signal - end interface + interface + function signal(signum, proc, flag) + integer :: signal + integer, intent(in):: signum, flag + interface + function proc(signum) + integer :: proc + integer, intent(in) :: signum + end function proc + end interface + end function signal + end interface !#else ! interface ! function signal(signum, proc) @@ -61,59 +61,59 @@ end function signal contains - subroutine initialise_signals - ! Register the signal handlers. - interface - function handle_sigint(signum) - integer :: handle_sigint - integer, intent(in) :: signum - end function handle_sigint - function handle_sigterm(signum) - integer :: handle_sigterm - integer, intent(in) :: signum - end function handle_sigterm - end interface - interface - function handle_sighup(signum) - integer :: handle_sighup - integer, intent(in) :: signum - end function handle_sighup - end interface - interface - function handle_sigfpe(signum) - integer :: handle_sigfpe - integer, intent(in) :: signum - end function handle_sigfpe - end interface + subroutine initialise_signals + ! Register the signal handlers. + interface + function handle_sigint(signum) + integer :: handle_sigint + integer, intent(in) :: signum + end function handle_sigint + function handle_sigterm(signum) + integer :: handle_sigterm + integer, intent(in) :: signum + end function handle_sigterm + end interface + interface + function handle_sighup(signum) + integer :: handle_sighup + integer, intent(in) :: signum + end function handle_sighup + end interface + interface + function handle_sigfpe(signum) + integer :: handle_sigfpe + integer, intent(in) :: signum + end function handle_sigfpe + end interface - integer :: result + integer :: result - ! SIGHUP support is still to come. - ! call signal(SIGHUP, handle_sighup, -1) + ! SIGHUP support is still to come. + ! call signal(SIGHUP, handle_sighup, -1) #ifdef SIGNAL_HAVE_FLAG - result= signal(SIGINT, handle_sigint, -1) + result= signal(SIGINT, handle_sigint, -1) #else - result= signal(SIGINT, handle_sigint) + result= signal(SIGINT, handle_sigint) #endif #ifdef SIGNAL_HAVE_FLAG - result= signal(SIGTERM, handle_sigterm, -1) + result= signal(SIGTERM, handle_sigterm, -1) #else - result= signal(SIGTERM, handle_sigterm) + result= signal(SIGTERM, handle_sigterm) #endif - ! We don't check result because we don't know if it has the same - ! meaning on all platforms. + ! We don't check result because we don't know if it has the same + ! meaning on all platforms. !DEBUG #ifdef SIGNAL_HAVE_FLAG - result= signal(SIGFPE, handle_sigfpe, -1) + result= signal(SIGFPE, handle_sigfpe, -1) #else - result= signal(SIGFPE, handle_sigfpe) + result= signal(SIGFPE, handle_sigfpe) #endif - end subroutine initialise_signals + end subroutine initialise_signals end module signals @@ -122,16 +122,16 @@ end module signals #ifndef SIGNAL function signal(signum, proc, flag) - integer :: signal - integer, intent(in):: signum, flag - interface - function proc(signum) - integer :: proc - integer, intent(in) :: signum - end function proc - end interface - - signal=0 + integer :: signal + integer, intent(in):: signum, flag + interface + function proc(signum) + integer :: proc + integer, intent(in) :: signum + end function proc + end interface + + signal=0 end function signal #endif diff --git a/femtools/Smoothing_module.F90 b/femtools/Smoothing_module.F90 index a5bf8d07ca..41244d7a2c 100644 --- a/femtools/Smoothing_module.F90 +++ b/femtools/Smoothing_module.F90 @@ -1,645 +1,645 @@ #include "fdebug.h" module smoothing_module - use fldebug - use global_parameters, only : OPTION_PATH_LEN - use sparse_tools - use element_numbering, only: FAMILY_SIMPLEX - use metric_tools - use fetools - use fields - use state_module - use sparsity_patterns - use solvers - use boundary_conditions, only: apply_dirichlet_conditions - implicit none - - private - - public :: smooth_scalar, smooth_vector, smooth_tensor - public :: anisotropic_smooth_scalar, anisotropic_smooth_vector, anisotropic_smooth_tensor - public :: length_scale_scalar, length_scale_tensor + use fldebug + use global_parameters, only : OPTION_PATH_LEN + use sparse_tools + use element_numbering, only: FAMILY_SIMPLEX + use metric_tools + use fetools + use fields + use state_module + use sparsity_patterns + use solvers + use boundary_conditions, only: apply_dirichlet_conditions + implicit none + + private + + public :: smooth_scalar, smooth_vector, smooth_tensor + public :: anisotropic_smooth_scalar, anisotropic_smooth_vector, anisotropic_smooth_tensor + public :: length_scale_scalar, length_scale_tensor contains - subroutine smooth_scalar(field_in,positions,field_out,alpha, path) - - !smoothing length - real, intent(in) :: alpha - !input field - type(scalar_field), intent(inout) :: field_in - !coordinates field - type(vector_field), intent(in) :: positions - !output field, should have same mesh as input field - type(scalar_field), intent(inout) :: field_out - character(len=*), intent(in) :: path - - !local variables - type(csr_matrix) :: M - type(csr_sparsity) :: M_sparsity - type(scalar_field) :: RHSFIELD - integer :: ele - - !allocate smoothing matrix - M_sparsity=make_sparsity(field_in%mesh, & - & field_in%mesh, name='HelmholtzScalarSparsity') - call allocate(M, M_sparsity, name="HelmholtzScalarSmoothingMatrix") - call deallocate(M_sparsity) - call zero(M) - - !allocate RHSFIELD - call allocate(rhsfield, field_in%mesh, "HelmholtzScalarSmoothingRHS") - call zero(rhsfield) - - ! Assemble M element by element. - do ele=1, element_count(field_in) - call assemble_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) - end do - - ! Boundary conditions - ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" - call apply_dirichlet_conditions(M, rhsfield, field_in) - - call zero(field_out) - call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) - - call deallocate(rhsfield) - call deallocate(M) - - end subroutine smooth_scalar - - subroutine smooth_vector(field_in,positions,field_out,alpha, path) - - !smoothing length - real, intent(in) :: alpha - !input field - type(vector_field), intent(inout) :: field_in - !coordinates field - type(vector_field), intent(in) :: positions - !output field, should have same mesh as input field - type(vector_field), intent(inout) :: field_out - character(len=*), intent(in) :: path - - !local variables - type(csr_matrix) :: M - type(csr_sparsity) :: M_sparsity - type(vector_field) :: RHSFIELD - integer :: ele, dim - - !allocate smoothing matrix - M_sparsity=make_sparsity(field_in%mesh, & - & field_in%mesh, name='HelmholtzVectorSparsity') - call allocate(M, M_sparsity, name="HelmholtzVectorSmoothingMatrix") - call deallocate(M_sparsity) - call zero(M) - - !allocate RHSFIELD - call allocate(rhsfield, field_in%dim, field_in%mesh, "HelmholtzVectorSmoothingRHS") - call zero(rhsfield) - - ! Assemble M element by element. - do ele=1, element_count(field_in) - call assemble_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) - end do - - ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" - do dim=1, field_in%dim - call apply_dirichlet_conditions(matrix=M, rhs=rhsfield, field=field_in, dim=dim) - end do - - call zero(field_out) - call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) - - call deallocate(rhsfield) - call deallocate(M) - - end subroutine smooth_vector - - subroutine smooth_tensor(field_in,positions,field_out,alpha, path) - - !smoothing length - real, intent(in) :: alpha - !input field - type(tensor_field), intent(inout) :: field_in - !coordinates field - type(vector_field), intent(in) :: positions - !output field, should have same mesh as input field - type(tensor_field), intent(inout) :: field_out - character(len=*), intent(in) :: path - - !local variables - type(csr_matrix) :: M - type(csr_sparsity) :: M_sparsity - type(tensor_field) :: rhsfield - integer :: ele - - !allocate smoothing matrix - M_sparsity=make_sparsity(field_in%mesh, & - & field_in%mesh, name='HelmholtzTensorSparsity') - call allocate(M, M_sparsity, name="HelmholtzTensorSmoothingMatrix") - call deallocate(M_sparsity) - call zero(M) - - !allocate RHSFIELD - call allocate(rhsfield, field_in%mesh, "HelmholtzTensorSmoothingRHS") - call zero(rhsfield) - - ! Assemble M element by element. - do ele=1, element_count(field_in) - call assemble_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) - end do - - call zero(field_out) - call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) - - call deallocate(rhsfield) - call deallocate(M) - - end subroutine smooth_tensor - - subroutine anisotropic_smooth_scalar(field_in,positions,field_out,alpha,path) - - !smoothing length - real, intent(in) :: alpha - !input field - type(scalar_field), intent(inout) :: field_in - !coordinates - type(vector_field), pointer, intent(in) :: positions - !output field, should have same mesh as input field - type(scalar_field), intent(inout) :: field_out - character(len=*), intent(in) :: path - - !local variables - type(csr_matrix) :: M - type(csr_sparsity) :: M_sparsity - type(scalar_field) :: rhsfield - integer :: ele - - !allocate smoothing matrix, RHS - M_sparsity=make_sparsity(field_in%mesh, field_in%mesh, name='HelmholtzScalarSparsity') - call allocate(M, M_sparsity, name="HelmholtzScalarSmoothingMatrix") - call allocate(rhsfield, field_in%mesh, "HelmholtzScalarSmoothingRHS") - call zero(M); call zero(rhsfield); call zero(field_out) - - ! Assemble M element by element. - do ele=1, element_count(field_in) - call assemble_anisotropic_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) - end do - - ! Boundary conditions - ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" - call apply_dirichlet_conditions(M, rhsfield, field_in) - - call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) - - call deallocate(rhsfield); call deallocate(M); call deallocate(M_sparsity) - - end subroutine anisotropic_smooth_scalar - - subroutine anisotropic_smooth_vector(field_in,positions,field_out,alpha,path) - - !smoothing length - real, intent(in) :: alpha - !input field - type(vector_field), intent(inout) :: field_in - !coordinates field - type(vector_field), intent(in) :: positions - !output field, should have same mesh as input field - type(vector_field), intent(inout) :: field_out - character(len=*), intent(in) :: path - - !local variables - type(csr_matrix) :: M - type(csr_sparsity) :: M_sparsity - type(vector_field) :: rhsfield - integer :: ele, dim - - !allocate smoothing matrix - M_sparsity=make_sparsity(field_in%mesh, field_in%mesh, name='HelmholtzVectorSparsity') - call allocate(M, M_sparsity, name="HelmholtzVectorSmoothingMatrix") - call allocate(rhsfield, field_in%dim, field_in%mesh, "HelmholtzVectorSmoothingRHS") - call zero(M); call zero(rhsfield); call zero(field_out) - - ! Assemble M element by element. - do ele=1, element_count(field_in) - call assemble_anisotropic_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) - end do - - ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" - do dim=1, field_in%dim - call apply_dirichlet_conditions(matrix=M, rhs=rhsfield, field=field_in, dim=dim) - end do - - call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) - - call deallocate(rhsfield); call deallocate(M); call deallocate(M_sparsity) - - end subroutine anisotropic_smooth_vector - - subroutine anisotropic_smooth_tensor(field_in,positions,field_out,alpha, path) - - !smoothing length - real, intent(in) :: alpha - !input field - type(tensor_field), intent(inout) :: field_in - !coordinates field - type(vector_field), intent(in) :: positions - !output field, should have same mesh as input field - type(tensor_field), intent(inout) :: field_out - character(len=*), intent(in) :: path - - !local variables - type(csr_matrix) :: M - type(csr_sparsity) :: M_sparsity - type(tensor_field) :: rhsfield - integer :: ele - - !allocate smoothing matrix - M_sparsity=make_sparsity(field_in%mesh, & - & field_in%mesh, name='HelmholtzTensorSparsity') - call allocate(M, M_sparsity, name="HelmholtzTensorSmoothingMatrix") - call deallocate(M_sparsity) - call zero(M) - - !allocate RHSFIELD - call allocate(rhsfield, field_in%mesh, "HelmholtzTensorSmoothingRHS") - call zero(rhsfield) - - ! Assemble M element by element. - do ele=1, element_count(field_in) - call assemble_anisotropic_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) - end do - - call zero(field_out) - call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) - - call deallocate(rhsfield) - call deallocate(M) - - end subroutine anisotropic_smooth_tensor - - subroutine assemble_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) - type(csr_matrix), intent(inout) :: M - type(scalar_field), intent(inout) :: RHSFIELD - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: field_in - real, intent(in) :: alpha - integer, intent(in) :: ele - - ! value of field_in at quad points - real, dimension(ele_ngi(positions,ele)) :: field_in_quad - ! smoothing tensor at quadrature points real, - real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) & - &:: alpha_quad - ! Derivatives of shape function: - real, dimension(ele_loc(field_in,ele), & + subroutine smooth_scalar(field_in,positions,field_out,alpha, path) + + !smoothing length + real, intent(in) :: alpha + !input field + type(scalar_field), intent(inout) :: field_in + !coordinates field + type(vector_field), intent(in) :: positions + !output field, should have same mesh as input field + type(scalar_field), intent(inout) :: field_out + character(len=*), intent(in) :: path + + !local variables + type(csr_matrix) :: M + type(csr_sparsity) :: M_sparsity + type(scalar_field) :: RHSFIELD + integer :: ele + + !allocate smoothing matrix + M_sparsity=make_sparsity(field_in%mesh, & + & field_in%mesh, name='HelmholtzScalarSparsity') + call allocate(M, M_sparsity, name="HelmholtzScalarSmoothingMatrix") + call deallocate(M_sparsity) + call zero(M) + + !allocate RHSFIELD + call allocate(rhsfield, field_in%mesh, "HelmholtzScalarSmoothingRHS") + call zero(rhsfield) + + ! Assemble M element by element. + do ele=1, element_count(field_in) + call assemble_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) + end do + + ! Boundary conditions + ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" + call apply_dirichlet_conditions(M, rhsfield, field_in) + + call zero(field_out) + call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) + + call deallocate(rhsfield) + call deallocate(M) + + end subroutine smooth_scalar + + subroutine smooth_vector(field_in,positions,field_out,alpha, path) + + !smoothing length + real, intent(in) :: alpha + !input field + type(vector_field), intent(inout) :: field_in + !coordinates field + type(vector_field), intent(in) :: positions + !output field, should have same mesh as input field + type(vector_field), intent(inout) :: field_out + character(len=*), intent(in) :: path + + !local variables + type(csr_matrix) :: M + type(csr_sparsity) :: M_sparsity + type(vector_field) :: RHSFIELD + integer :: ele, dim + + !allocate smoothing matrix + M_sparsity=make_sparsity(field_in%mesh, & + & field_in%mesh, name='HelmholtzVectorSparsity') + call allocate(M, M_sparsity, name="HelmholtzVectorSmoothingMatrix") + call deallocate(M_sparsity) + call zero(M) + + !allocate RHSFIELD + call allocate(rhsfield, field_in%dim, field_in%mesh, "HelmholtzVectorSmoothingRHS") + call zero(rhsfield) + + ! Assemble M element by element. + do ele=1, element_count(field_in) + call assemble_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) + end do + + ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" + do dim=1, field_in%dim + call apply_dirichlet_conditions(matrix=M, rhs=rhsfield, field=field_in, dim=dim) + end do + + call zero(field_out) + call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) + + call deallocate(rhsfield) + call deallocate(M) + + end subroutine smooth_vector + + subroutine smooth_tensor(field_in,positions,field_out,alpha, path) + + !smoothing length + real, intent(in) :: alpha + !input field + type(tensor_field), intent(inout) :: field_in + !coordinates field + type(vector_field), intent(in) :: positions + !output field, should have same mesh as input field + type(tensor_field), intent(inout) :: field_out + character(len=*), intent(in) :: path + + !local variables + type(csr_matrix) :: M + type(csr_sparsity) :: M_sparsity + type(tensor_field) :: rhsfield + integer :: ele + + !allocate smoothing matrix + M_sparsity=make_sparsity(field_in%mesh, & + & field_in%mesh, name='HelmholtzTensorSparsity') + call allocate(M, M_sparsity, name="HelmholtzTensorSmoothingMatrix") + call deallocate(M_sparsity) + call zero(M) + + !allocate RHSFIELD + call allocate(rhsfield, field_in%mesh, "HelmholtzTensorSmoothingRHS") + call zero(rhsfield) + + ! Assemble M element by element. + do ele=1, element_count(field_in) + call assemble_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) + end do + + call zero(field_out) + call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) + + call deallocate(rhsfield) + call deallocate(M) + + end subroutine smooth_tensor + + subroutine anisotropic_smooth_scalar(field_in,positions,field_out,alpha,path) + + !smoothing length + real, intent(in) :: alpha + !input field + type(scalar_field), intent(inout) :: field_in + !coordinates + type(vector_field), pointer, intent(in) :: positions + !output field, should have same mesh as input field + type(scalar_field), intent(inout) :: field_out + character(len=*), intent(in) :: path + + !local variables + type(csr_matrix) :: M + type(csr_sparsity) :: M_sparsity + type(scalar_field) :: rhsfield + integer :: ele + + !allocate smoothing matrix, RHS + M_sparsity=make_sparsity(field_in%mesh, field_in%mesh, name='HelmholtzScalarSparsity') + call allocate(M, M_sparsity, name="HelmholtzScalarSmoothingMatrix") + call allocate(rhsfield, field_in%mesh, "HelmholtzScalarSmoothingRHS") + call zero(M); call zero(rhsfield); call zero(field_out) + + ! Assemble M element by element. + do ele=1, element_count(field_in) + call assemble_anisotropic_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) + end do + + ! Boundary conditions + ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" + call apply_dirichlet_conditions(M, rhsfield, field_in) + + call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) + + call deallocate(rhsfield); call deallocate(M); call deallocate(M_sparsity) + + end subroutine anisotropic_smooth_scalar + + subroutine anisotropic_smooth_vector(field_in,positions,field_out,alpha,path) + + !smoothing length + real, intent(in) :: alpha + !input field + type(vector_field), intent(inout) :: field_in + !coordinates field + type(vector_field), intent(in) :: positions + !output field, should have same mesh as input field + type(vector_field), intent(inout) :: field_out + character(len=*), intent(in) :: path + + !local variables + type(csr_matrix) :: M + type(csr_sparsity) :: M_sparsity + type(vector_field) :: rhsfield + integer :: ele, dim + + !allocate smoothing matrix + M_sparsity=make_sparsity(field_in%mesh, field_in%mesh, name='HelmholtzVectorSparsity') + call allocate(M, M_sparsity, name="HelmholtzVectorSmoothingMatrix") + call allocate(rhsfield, field_in%dim, field_in%mesh, "HelmholtzVectorSmoothingRHS") + call zero(M); call zero(rhsfield); call zero(field_out) + + ! Assemble M element by element. + do ele=1, element_count(field_in) + call assemble_anisotropic_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) + end do + + ewrite(2,*) "Applying strong Dirichlet boundary conditions to filtered field" + do dim=1, field_in%dim + call apply_dirichlet_conditions(matrix=M, rhs=rhsfield, field=field_in, dim=dim) + end do + + call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) + + call deallocate(rhsfield); call deallocate(M); call deallocate(M_sparsity) + + end subroutine anisotropic_smooth_vector + + subroutine anisotropic_smooth_tensor(field_in,positions,field_out,alpha, path) + + !smoothing length + real, intent(in) :: alpha + !input field + type(tensor_field), intent(inout) :: field_in + !coordinates field + type(vector_field), intent(in) :: positions + !output field, should have same mesh as input field + type(tensor_field), intent(inout) :: field_out + character(len=*), intent(in) :: path + + !local variables + type(csr_matrix) :: M + type(csr_sparsity) :: M_sparsity + type(tensor_field) :: rhsfield + integer :: ele + + !allocate smoothing matrix + M_sparsity=make_sparsity(field_in%mesh, & + & field_in%mesh, name='HelmholtzTensorSparsity') + call allocate(M, M_sparsity, name="HelmholtzTensorSmoothingMatrix") + call deallocate(M_sparsity) + call zero(M) + + !allocate RHSFIELD + call allocate(rhsfield, field_in%mesh, "HelmholtzTensorSmoothingRHS") + call zero(rhsfield) + + ! Assemble M element by element. + do ele=1, element_count(field_in) + call assemble_anisotropic_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) + end do + + call zero(field_out) + call petsc_solve(field_out, M, rhsfield, option_path=trim(path)) + + call deallocate(rhsfield) + call deallocate(M) + + end subroutine anisotropic_smooth_tensor + + subroutine assemble_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) + type(csr_matrix), intent(inout) :: M + type(scalar_field), intent(inout) :: RHSFIELD + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: field_in + real, intent(in) :: alpha + integer, intent(in) :: ele + + ! value of field_in at quad points + real, dimension(ele_ngi(positions,ele)) :: field_in_quad + ! smoothing tensor at quadrature points real, + real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) & + &:: alpha_quad + ! Derivatives of shape function: + real, dimension(ele_loc(field_in,ele), & ele_ngi(field_in,ele), positions%dim) :: dshape_field_in - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of field_in element. - integer, dimension(:), pointer :: ele_field_in - ! Shape functions. - type(element_type), pointer :: shape_field_in - ! Local Helmholtz matrix - real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) & - & :: field_in_mat - ! Local right hand side. - real, dimension(ele_loc(field_in, ele)) :: lrhsfield - real :: w - integer :: i - - ele_field_in=>ele_nodes(field_in, ele) - shape_field_in=>ele_shape(field_in, ele) - field_in_quad = ele_val_at_quad(field_in, ele) - - ! Calculate filter width using Deardorff's definition: - ! width^2 = (volume)^(2/d) - w = length_scale_scalar(positions, ele) - !value of tensor at quads - forall(i=1:ele_ngi(positions,ele)) - alpha_quad(:,:,i) = alpha**2/24.*w - end forall - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_field_in, dshape& - &=dshape_field_in, detwei=detwei) - - ! Local assembly: - field_in_mat=dshape_tensor_dshape(dshape_field_in, alpha_quad, & + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of field_in element. + integer, dimension(:), pointer :: ele_field_in + ! Shape functions. + type(element_type), pointer :: shape_field_in + ! Local Helmholtz matrix + real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) & + & :: field_in_mat + ! Local right hand side. + real, dimension(ele_loc(field_in, ele)) :: lrhsfield + real :: w + integer :: i + + ele_field_in=>ele_nodes(field_in, ele) + shape_field_in=>ele_shape(field_in, ele) + field_in_quad = ele_val_at_quad(field_in, ele) + + ! Calculate filter width using Deardorff's definition: + ! width^2 = (volume)^(2/d) + w = length_scale_scalar(positions, ele) + !value of tensor at quads + forall(i=1:ele_ngi(positions,ele)) + alpha_quad(:,:,i) = alpha**2/24.*w + end forall + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_field_in, dshape& + &=dshape_field_in, detwei=detwei) + + ! Local assembly: + field_in_mat=dshape_tensor_dshape(dshape_field_in, alpha_quad, & dshape_field_in, detwei) + shape_shape(shape_field_in& - &,shape_field_in, detwei) + &,shape_field_in, detwei) - lrhsfield=shape_rhs(shape_field_in, field_in_quad*detwei) + lrhsfield=shape_rhs(shape_field_in, field_in_quad*detwei) - ! Global assembly: - call addto(M, ele_field_in, ele_field_in, field_in_mat) + ! Global assembly: + call addto(M, ele_field_in, ele_field_in, field_in_mat) - call addto(rhsfield, ele_field_in, lrhsfield) + call addto(rhsfield, ele_field_in, lrhsfield) - end subroutine assemble_smooth_scalar + end subroutine assemble_smooth_scalar - subroutine assemble_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) + subroutine assemble_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) - type(csr_matrix), intent(inout) :: M - type(vector_field), intent(inout) :: RHSFIELD - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: field_in - real, intent(in) :: alpha - integer, intent(in) :: ele + type(csr_matrix), intent(inout) :: M + type(vector_field), intent(inout) :: RHSFIELD + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: field_in + real, intent(in) :: alpha + integer, intent(in) :: ele - ! value of field_in at quad points - real, dimension(positions%dim,ele_ngi(positions,ele)) :: field_in_quad - ! smoothing tensor at quadrature points real, - real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) & - &:: alpha_quad - ! Derivatives of shape function: - real, dimension(ele_loc(field_in,ele), & + ! value of field_in at quad points + real, dimension(positions%dim,ele_ngi(positions,ele)) :: field_in_quad + ! smoothing tensor at quadrature points real, + real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) & + &:: alpha_quad + ! Derivatives of shape function: + real, dimension(ele_loc(field_in,ele), & ele_ngi(field_in,ele), positions%dim) :: dshape_field_in - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of field_in element. - integer, dimension(:), pointer :: ele_field_in - ! Shape functions. - type(element_type), pointer :: shape_field_in - ! Local Helmholtz matrix - real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) & - & :: field_in_mat - ! Local right hand side. - real, dimension(positions%dim, ele_loc(field_in, ele)) :: lrhsfield - real :: w - integer :: i - - ele_field_in=>ele_nodes(field_in, ele) - shape_field_in=>ele_shape(field_in, ele) - field_in_quad = ele_val_at_quad(field_in, ele) - - ! Calculate filter width using Deardorff's definition: - ! width^2 = (volume)^(2/d) - w = length_scale_scalar(positions, ele) - !value of tensor at quads - forall(i=1:ele_ngi(positions,ele)) - alpha_quad(:,:,i) = alpha**2/24.*w - end forall - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_field_in, dshape& - &=dshape_field_in, detwei=detwei) - - ! Local assembly: - field_in_mat=dshape_tensor_dshape(dshape_field_in, alpha_quad, & + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of field_in element. + integer, dimension(:), pointer :: ele_field_in + ! Shape functions. + type(element_type), pointer :: shape_field_in + ! Local Helmholtz matrix + real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) & + & :: field_in_mat + ! Local right hand side. + real, dimension(positions%dim, ele_loc(field_in, ele)) :: lrhsfield + real :: w + integer :: i + + ele_field_in=>ele_nodes(field_in, ele) + shape_field_in=>ele_shape(field_in, ele) + field_in_quad = ele_val_at_quad(field_in, ele) + + ! Calculate filter width using Deardorff's definition: + ! width^2 = (volume)^(2/d) + w = length_scale_scalar(positions, ele) + !value of tensor at quads + forall(i=1:ele_ngi(positions,ele)) + alpha_quad(:,:,i) = alpha**2/24.*w + end forall + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_field_in, dshape& + &=dshape_field_in, detwei=detwei) + + ! Local assembly: + field_in_mat=dshape_tensor_dshape(dshape_field_in, alpha_quad, & dshape_field_in, detwei) + shape_shape(shape_field_in& - &,shape_field_in, detwei) + &,shape_field_in, detwei) - lrhsfield=shape_vector_rhs(shape_field_in, field_in_quad, detwei) + lrhsfield=shape_vector_rhs(shape_field_in, field_in_quad, detwei) - ! Global assembly: - call addto(M, ele_field_in, ele_field_in, field_in_mat) + ! Global assembly: + call addto(M, ele_field_in, ele_field_in, field_in_mat) - call addto(rhsfield, ele_field_in, lrhsfield) + call addto(rhsfield, ele_field_in, lrhsfield) - end subroutine assemble_smooth_vector + end subroutine assemble_smooth_vector - subroutine assemble_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) + subroutine assemble_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) - type(csr_matrix), intent(inout) :: M - type(tensor_field), intent(inout) :: RHSFIELD - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: field_in - real, intent(in) :: alpha - integer, intent(in) :: ele + type(csr_matrix), intent(inout) :: M + type(tensor_field), intent(inout) :: RHSFIELD + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: field_in + real, intent(in) :: alpha + integer, intent(in) :: ele - ! value of field_in at quad points - real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: field_in_quad - ! smoothing tensor at quadrature points real, - real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) & - &:: alpha_quad - ! Derivatives of shape function: - real, dimension(ele_loc(field_in,ele), & + ! value of field_in at quad points + real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: field_in_quad + ! smoothing tensor at quadrature points real, + real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) & + &:: alpha_quad + ! Derivatives of shape function: + real, dimension(ele_loc(field_in,ele), & ele_ngi(field_in,ele), positions%dim) :: dshape_field_in - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of field_in element. - integer, dimension(:), pointer :: ele_field_in - ! Shape functions. - type(element_type), pointer :: shape_field_in - ! Local Helmholtz matrix - real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) & - & :: field_in_mat - ! Local right hand side. - real, dimension(positions%dim,positions%dim,ele_loc(field_in, ele)) :: lrhsfield - real :: w - integer :: i - - ele_field_in=>ele_nodes(field_in, ele) - shape_field_in=>ele_shape(field_in, ele) - field_in_quad = ele_val_at_quad(field_in, ele) - - ! Calculate filter width using Deardorff's definition: - ! width^2 = (volume)^(2/d) - w = length_scale_scalar(positions, ele) - !value of tensor at quads - forall(i=1:ele_ngi(positions,ele)) - alpha_quad(:,:,i) = alpha**2/24.*w - end forall - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_field_in, dshape& - &=dshape_field_in, detwei=detwei) - - ! Local assembly: - field_in_mat=dshape_tensor_dshape(dshape_field_in, alpha_quad, & + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of field_in element. + integer, dimension(:), pointer :: ele_field_in + ! Shape functions. + type(element_type), pointer :: shape_field_in + ! Local Helmholtz matrix + real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) & + & :: field_in_mat + ! Local right hand side. + real, dimension(positions%dim,positions%dim,ele_loc(field_in, ele)) :: lrhsfield + real :: w + integer :: i + + ele_field_in=>ele_nodes(field_in, ele) + shape_field_in=>ele_shape(field_in, ele) + field_in_quad = ele_val_at_quad(field_in, ele) + + ! Calculate filter width using Deardorff's definition: + ! width^2 = (volume)^(2/d) + w = length_scale_scalar(positions, ele) + !value of tensor at quads + forall(i=1:ele_ngi(positions,ele)) + alpha_quad(:,:,i) = alpha**2/24.*w + end forall + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_field_in, dshape& + &=dshape_field_in, detwei=detwei) + + ! Local assembly: + field_in_mat=dshape_tensor_dshape(dshape_field_in, alpha_quad, & dshape_field_in, detwei) + shape_shape(shape_field_in& - &,shape_field_in, detwei) - - lrhsfield=shape_tensor_rhs(shape_field_in, field_in_quad, detwei) - - ! Global assembly: - call addto(M, ele_field_in, ele_field_in, field_in_mat) - - call addto(rhsfield, ele_field_in, lrhsfield) - - end subroutine assemble_smooth_tensor - - subroutine assemble_anisotropic_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) - type(csr_matrix), intent(inout) :: M - type(scalar_field), intent(inout) :: rhsfield - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: field_in - real, intent(in) :: alpha - integer, intent(in) :: ele - real, dimension(ele_ngi(positions,ele)) :: field_in_quad - real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: mesh_tensor_quad - real, dimension(ele_loc(field_in,ele), ele_ngi(field_in,ele), positions%dim) :: dshape_field_in - real, dimension(ele_ngi(positions,ele)) :: detwei - integer, dimension(:), pointer :: ele_field_in - type(element_type), pointer :: shape_field_in - real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) :: field_in_mat - real, dimension(ele_loc(field_in, ele)) :: lrhsfield - - ele_field_in=>ele_nodes(field_in, ele) - shape_field_in=>ele_shape(field_in, ele) - field_in_quad = ele_val_at_quad(field_in, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_field_in, dshape& - &=dshape_field_in, detwei=detwei) - - ! mesh size tensor=(edge lengths)**2 - ! Helmholtz smoothing lengthscale = alpha**2 * 1/24 * mesh size tensor - ! factor 1/24 derives from 2nd moment of filter (see Pope 2000, Geurts&Holm 2002) - mesh_tensor_quad = alpha**2 / 24. * length_scale_tensor(dshape_field_in, shape_field_in) - - !ewrite(2,*) 'dsd: ', dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei) - !ewrite(2,*) 'srhs: ', shape_shape(shape_field_in,shape_field_in, detwei) - ! Local assembly - field_in_mat=dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei) & - & + shape_shape(shape_field_in,shape_field_in, detwei) - lrhsfield=shape_rhs(shape_field_in, field_in_quad*detwei) - - ! Global assembly - call addto(M, ele_field_in, ele_field_in, field_in_mat) - - call addto(rhsfield, ele_field_in, lrhsfield) - - end subroutine assemble_anisotropic_smooth_scalar - - subroutine assemble_anisotropic_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) - type(csr_matrix), intent(inout) :: M - type(vector_field), intent(inout) :: rhsfield - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: field_in - real, intent(in) :: alpha - integer, intent(in) :: ele - real, dimension(positions%dim,ele_ngi(positions,ele)) :: field_in_quad - real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: mesh_tensor_quad - real, dimension(ele_loc(field_in,ele), ele_ngi(field_in,ele), positions%dim) :: dshape_field_in - real, dimension(ele_ngi(positions,ele)) :: detwei - integer, dimension(:), pointer :: ele_field_in - type(element_type), pointer :: shape_field_in - real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) :: field_in_mat - real, dimension(positions%dim, ele_loc(field_in, ele)) :: lrhsfield - - ele_field_in=>ele_nodes(field_in, ele) - shape_field_in=>ele_shape(field_in, ele) - field_in_quad = ele_val_at_quad(field_in, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_field_in, dshape& - &=dshape_field_in, detwei=detwei) - - ! mesh size tensor=(edge lengths)**2 - ! Helmholtz smoothing lengthscale = alpha**2 * 1/24 * mesh size tensor - mesh_tensor_quad = alpha**2 / 24. * length_scale_tensor(dshape_field_in, shape_field_in) - - ! Local assembly: - field_in_mat=dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei) & - & + shape_shape(shape_field_in, shape_field_in, detwei) - lrhsfield=shape_vector_rhs(shape_field_in, field_in_quad, detwei) - - ! Global assembly: - call addto(M, ele_field_in, ele_field_in, field_in_mat) - call addto(rhsfield, ele_field_in, lrhsfield) - - end subroutine assemble_anisotropic_smooth_vector - - subroutine assemble_anisotropic_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) - type(csr_matrix), intent(inout) :: M - type(tensor_field), intent(inout) :: rhsfield - type(vector_field), intent(in) :: positions - type(tensor_field), intent(in) :: field_in - real, intent(in) :: alpha - integer, intent(in) :: ele - real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: field_in_quad - real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: mesh_tensor_quad - real, dimension(ele_loc(field_in,ele), ele_ngi(field_in,ele), positions%dim) :: dshape_field_in - real, dimension(ele_ngi(positions,ele)) :: detwei - integer, dimension(:), pointer :: ele_field_in - type(element_type), pointer :: shape_field_in - real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) :: field_in_mat - real, dimension(positions%dim, positions%dim, ele_loc(field_in, ele)) :: lrhsfield - - ele_field_in=>ele_nodes(field_in, ele) - shape_field_in=>ele_shape(field_in, ele) - field_in_quad = ele_val_at_quad(field_in, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_field_in, dshape& - &=dshape_field_in, detwei=detwei) - - ! mesh size tensor=(edge lengths)**2 - ! Helmholtz smoothing lengthscale = alpha**2 * 1/24 * mesh size tensor - mesh_tensor_quad = alpha**2 / 24. * length_scale_tensor(dshape_field_in, shape_field_in) - - ! Local assembly: - field_in_mat=dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei)& - & + shape_shape(shape_field_in, shape_field_in, detwei) - lrhsfield=shape_tensor_rhs(shape_field_in, field_in_quad, detwei) - - ! Global assembly: - call addto(M, ele_field_in, ele_field_in, field_in_mat) - - call addto(rhsfield, ele_field_in, lrhsfield) - - end subroutine assemble_anisotropic_smooth_tensor - - function length_scale_scalar(positions, ele) result(s) - ! Computes a scalar length scale for LES models - ! Preserves element volume. (units are in length^2) - type(vector_field), intent(in) :: positions - real :: s - integer, intent(in) :: ele - integer :: dim - dim=positions%dim - - ! filter is a square/cube (width=side length) a la Deardorff: - s=element_volume(positions, ele) - s=s**(2./dim) - - end function length_scale_scalar - - function length_scale_tensor(du_t, shape) result(t) - !! Computes a length scale tensor to be used in LES (units are in length^2) - !! derivative of velocity shape function (nloc x ngi x dim) - real, dimension(:,:,:), intent(in):: du_t - !! the resulting tensor (dim x dim x ngi) - real, dimension(size(du_t,3),size(du_t,3),size(du_t,2)) :: t - !! for a simplex if degree==1 the tensor is the same for all gaussian points - type(element_type), intent(in):: shape - - real, dimension(size(t,1), size(t,2)):: M - real r - integer gi, loc, i, dim, nloc, compute_ngi - - t=0.0 - nloc=size(du_t,1) - dim=size(du_t,3) - - if (.not.(shape%degree==1 .and. shape%numbering%family==FAMILY_SIMPLEX)) then - ! for non-linear compute on all gauss points - compute_ngi=shape%ngi - else - ! for linear: compute only the first and copy the rest - compute_ngi=1 - end if - - do gi=1, compute_ngi - do loc=1, nloc - ! eigenvalues of metric - M=outer_product( du_t(loc,gi,:), du_t(loc,gi,:) ) - ! determinant of M - r=sum( (/ ( M(i,i), i=1, dim) /) ) - ! M^-1 = 1/det(M)*adj(M) = 1/det(M)*M - if (.not. r==0.0) then - t(:,:,gi)=t(:,:,gi)+M/(r**2) - end if - end do - end do - - ! copy the rest - do gi=compute_ngi+1, shape%ngi - t(:,:,gi)=t(:,:,1) - end do - - end function length_scale_tensor + &,shape_field_in, detwei) + + lrhsfield=shape_tensor_rhs(shape_field_in, field_in_quad, detwei) + + ! Global assembly: + call addto(M, ele_field_in, ele_field_in, field_in_mat) + + call addto(rhsfield, ele_field_in, lrhsfield) + + end subroutine assemble_smooth_tensor + + subroutine assemble_anisotropic_smooth_scalar(M, rhsfield, positions, field_in, alpha, ele) + type(csr_matrix), intent(inout) :: M + type(scalar_field), intent(inout) :: rhsfield + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: field_in + real, intent(in) :: alpha + integer, intent(in) :: ele + real, dimension(ele_ngi(positions,ele)) :: field_in_quad + real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: mesh_tensor_quad + real, dimension(ele_loc(field_in,ele), ele_ngi(field_in,ele), positions%dim) :: dshape_field_in + real, dimension(ele_ngi(positions,ele)) :: detwei + integer, dimension(:), pointer :: ele_field_in + type(element_type), pointer :: shape_field_in + real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) :: field_in_mat + real, dimension(ele_loc(field_in, ele)) :: lrhsfield + + ele_field_in=>ele_nodes(field_in, ele) + shape_field_in=>ele_shape(field_in, ele) + field_in_quad = ele_val_at_quad(field_in, ele) + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_field_in, dshape& + &=dshape_field_in, detwei=detwei) + + ! mesh size tensor=(edge lengths)**2 + ! Helmholtz smoothing lengthscale = alpha**2 * 1/24 * mesh size tensor + ! factor 1/24 derives from 2nd moment of filter (see Pope 2000, Geurts&Holm 2002) + mesh_tensor_quad = alpha**2 / 24. * length_scale_tensor(dshape_field_in, shape_field_in) + + !ewrite(2,*) 'dsd: ', dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei) + !ewrite(2,*) 'srhs: ', shape_shape(shape_field_in,shape_field_in, detwei) + ! Local assembly + field_in_mat=dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei) & + & + shape_shape(shape_field_in,shape_field_in, detwei) + lrhsfield=shape_rhs(shape_field_in, field_in_quad*detwei) + + ! Global assembly + call addto(M, ele_field_in, ele_field_in, field_in_mat) + + call addto(rhsfield, ele_field_in, lrhsfield) + + end subroutine assemble_anisotropic_smooth_scalar + + subroutine assemble_anisotropic_smooth_vector(M, rhsfield, positions, field_in, alpha, ele) + type(csr_matrix), intent(inout) :: M + type(vector_field), intent(inout) :: rhsfield + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: field_in + real, intent(in) :: alpha + integer, intent(in) :: ele + real, dimension(positions%dim,ele_ngi(positions,ele)) :: field_in_quad + real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: mesh_tensor_quad + real, dimension(ele_loc(field_in,ele), ele_ngi(field_in,ele), positions%dim) :: dshape_field_in + real, dimension(ele_ngi(positions,ele)) :: detwei + integer, dimension(:), pointer :: ele_field_in + type(element_type), pointer :: shape_field_in + real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) :: field_in_mat + real, dimension(positions%dim, ele_loc(field_in, ele)) :: lrhsfield + + ele_field_in=>ele_nodes(field_in, ele) + shape_field_in=>ele_shape(field_in, ele) + field_in_quad = ele_val_at_quad(field_in, ele) + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_field_in, dshape& + &=dshape_field_in, detwei=detwei) + + ! mesh size tensor=(edge lengths)**2 + ! Helmholtz smoothing lengthscale = alpha**2 * 1/24 * mesh size tensor + mesh_tensor_quad = alpha**2 / 24. * length_scale_tensor(dshape_field_in, shape_field_in) + + ! Local assembly: + field_in_mat=dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei) & + & + shape_shape(shape_field_in, shape_field_in, detwei) + lrhsfield=shape_vector_rhs(shape_field_in, field_in_quad, detwei) + + ! Global assembly: + call addto(M, ele_field_in, ele_field_in, field_in_mat) + call addto(rhsfield, ele_field_in, lrhsfield) + + end subroutine assemble_anisotropic_smooth_vector + + subroutine assemble_anisotropic_smooth_tensor(M, rhsfield, positions, field_in, alpha, ele) + type(csr_matrix), intent(inout) :: M + type(tensor_field), intent(inout) :: rhsfield + type(vector_field), intent(in) :: positions + type(tensor_field), intent(in) :: field_in + real, intent(in) :: alpha + integer, intent(in) :: ele + real, dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: field_in_quad + real,dimension(positions%dim,positions%dim,ele_ngi(positions,ele)) :: mesh_tensor_quad + real, dimension(ele_loc(field_in,ele), ele_ngi(field_in,ele), positions%dim) :: dshape_field_in + real, dimension(ele_ngi(positions,ele)) :: detwei + integer, dimension(:), pointer :: ele_field_in + type(element_type), pointer :: shape_field_in + real, dimension(ele_loc(field_in, ele), ele_loc(field_in, ele)) :: field_in_mat + real, dimension(positions%dim, positions%dim, ele_loc(field_in, ele)) :: lrhsfield + + ele_field_in=>ele_nodes(field_in, ele) + shape_field_in=>ele_shape(field_in, ele) + field_in_quad = ele_val_at_quad(field_in, ele) + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_field_in, dshape& + &=dshape_field_in, detwei=detwei) + + ! mesh size tensor=(edge lengths)**2 + ! Helmholtz smoothing lengthscale = alpha**2 * 1/24 * mesh size tensor + mesh_tensor_quad = alpha**2 / 24. * length_scale_tensor(dshape_field_in, shape_field_in) + + ! Local assembly: + field_in_mat=dshape_tensor_dshape(dshape_field_in, mesh_tensor_quad, dshape_field_in, detwei)& + & + shape_shape(shape_field_in, shape_field_in, detwei) + lrhsfield=shape_tensor_rhs(shape_field_in, field_in_quad, detwei) + + ! Global assembly: + call addto(M, ele_field_in, ele_field_in, field_in_mat) + + call addto(rhsfield, ele_field_in, lrhsfield) + + end subroutine assemble_anisotropic_smooth_tensor + + function length_scale_scalar(positions, ele) result(s) + ! Computes a scalar length scale for LES models + ! Preserves element volume. (units are in length^2) + type(vector_field), intent(in) :: positions + real :: s + integer, intent(in) :: ele + integer :: dim + dim=positions%dim + + ! filter is a square/cube (width=side length) a la Deardorff: + s=element_volume(positions, ele) + s=s**(2./dim) + + end function length_scale_scalar + + function length_scale_tensor(du_t, shape) result(t) + !! Computes a length scale tensor to be used in LES (units are in length^2) + !! derivative of velocity shape function (nloc x ngi x dim) + real, dimension(:,:,:), intent(in):: du_t + !! the resulting tensor (dim x dim x ngi) + real, dimension(size(du_t,3),size(du_t,3),size(du_t,2)) :: t + !! for a simplex if degree==1 the tensor is the same for all gaussian points + type(element_type), intent(in):: shape + + real, dimension(size(t,1), size(t,2)):: M + real r + integer gi, loc, i, dim, nloc, compute_ngi + + t=0.0 + nloc=size(du_t,1) + dim=size(du_t,3) + + if (.not.(shape%degree==1 .and. shape%numbering%family==FAMILY_SIMPLEX)) then + ! for non-linear compute on all gauss points + compute_ngi=shape%ngi + else + ! for linear: compute only the first and copy the rest + compute_ngi=1 + end if + + do gi=1, compute_ngi + do loc=1, nloc + ! eigenvalues of metric + M=outer_product( du_t(loc,gi,:), du_t(loc,gi,:) ) + ! determinant of M + r=sum( (/ ( M(i,i), i=1, dim) /) ) + ! M^-1 = 1/det(M)*adj(M) = 1/det(M)*M + if (.not. r==0.0) then + t(:,:,gi)=t(:,:,gi)+M/(r**2) + end if + end do + end do + + ! copy the rest + do gi=compute_ngi+1, shape%ngi + t(:,:,gi)=t(:,:,1) + end do + + end function length_scale_tensor end module smoothing_module diff --git a/femtools/Solvers.F90 b/femtools/Solvers.F90 index 1b5453ee89..d14a55dd6a 100644 --- a/femtools/Solvers.F90 +++ b/femtools/Solvers.F90 @@ -26,2798 +26,2798 @@ ! USA #include "fdebug.h" module solvers - use FLDebug - use Global_Parameters - use futils, only: present_and_true, int2str, free_unit, real_format - use element_numbering, only: ELEMENT_BUBBLE - use elements - use spud - use parallel_tools - use petsc - use Sparse_Tools - use fields_calculations - use Fields - use profiler - use Petsc_tools - use Signal_Vars - use Multigrid - use sparse_tools_petsc - use sparse_matrices_fields - use vtk_interfaces - use halos - use MeshDiagnostics - implicit none - ! Module to provide explicit interfaces to matrix solvers. + use FLDebug + use Global_Parameters + use futils, only: present_and_true, int2str, free_unit, real_format + use element_numbering, only: ELEMENT_BUBBLE + use elements + use spud + use parallel_tools + use petsc + use Sparse_Tools + use fields_calculations + use Fields + use profiler + use Petsc_tools + use Signal_Vars + use Multigrid + use sparse_tools_petsc + use sparse_matrices_fields + use vtk_interfaces + use halos + use MeshDiagnostics + implicit none + ! Module to provide explicit interfaces to matrix solvers. #include "petsc_legacy.h" - ! stuff used in the PETSc monitor (see petsc_solve_callback_setup() below) - integer :: petsc_monitor_iteration = 0 - Vec :: petsc_monitor_x - ! - ! if .true. the code will compare with the provided exact answer, and - ! give the error convergence each iteration: - logical, save:: petsc_monitor_has_exact=.false. - ! this requires the following: - Vec :: petsc_monitor_exact - real, dimension(:), pointer :: petsc_monitor_error => null() - PetscLogDouble, dimension(:), pointer :: petsc_monitor_flops => null() - type(scalar_field), save:: petsc_monitor_exact_sfield - type(vector_field), save:: petsc_monitor_exact_vfield - character(len=FIELD_NAME_LEN), save:: petsc_monitor_error_filename="" - ! - ! if .true. a vtu will be written for each iteration - logical, save:: petsc_monitor_iteration_vtus=.false. - ! this requires the following: - type(petsc_numbering_type), save:: petsc_monitor_numbering - type(vector_field), target, save:: petsc_monitor_positions - type(scalar_field), dimension(3), save:: petsc_monitor_sfields - type(vector_field), dimension(3), save:: petsc_monitor_vfields - character(len=FIELD_NAME_LEN), save:: petsc_monitor_vtu_name - integer, save:: petsc_monitor_vtu_series=0 - -private - -public petsc_solve, set_solver_options, & - complete_solver_option_path, petsc_solve_needs_positions, & - L2_project_nullspace_vector + ! stuff used in the PETSc monitor (see petsc_solve_callback_setup() below) + integer :: petsc_monitor_iteration = 0 + Vec :: petsc_monitor_x + ! + ! if .true. the code will compare with the provided exact answer, and + ! give the error convergence each iteration: + logical, save:: petsc_monitor_has_exact=.false. + ! this requires the following: + Vec :: petsc_monitor_exact + real, dimension(:), pointer :: petsc_monitor_error => null() + PetscLogDouble, dimension(:), pointer :: petsc_monitor_flops => null() + type(scalar_field), save:: petsc_monitor_exact_sfield + type(vector_field), save:: petsc_monitor_exact_vfield + character(len=FIELD_NAME_LEN), save:: petsc_monitor_error_filename="" + ! + ! if .true. a vtu will be written for each iteration + logical, save:: petsc_monitor_iteration_vtus=.false. + ! this requires the following: + type(petsc_numbering_type), save:: petsc_monitor_numbering + type(vector_field), target, save:: petsc_monitor_positions + type(scalar_field), dimension(3), save:: petsc_monitor_sfields + type(vector_field), dimension(3), save:: petsc_monitor_vfields + character(len=FIELD_NAME_LEN), save:: petsc_monitor_vtu_name + integer, save:: petsc_monitor_vtu_series=0 + + private + + public petsc_solve, set_solver_options, & + complete_solver_option_path, petsc_solve_needs_positions, & + L2_project_nullspace_vector ! meant for unit-testing solver code only: -public petsc_solve_core, petsc_solve_destroy, & - petsc_solve_copy_vectors_from_scalar_fields, & - setup_ksp_from_options, create_ksp_from_options, petsc_solve_monitor_exact, & - petsc_solve_monitor_iteration_vtus, attach_null_space_from_options, & - petsc_solve_setup - -interface petsc_solve - module procedure petsc_solve_scalar, petsc_solve_vector, & - petsc_solve_scalar_multiple, & - petsc_solve_vector_components, & - petsc_solve_tensor_components, & - petsc_solve_scalar_petsc_csr, petsc_solve_vector_petsc_csr -end interface - -interface set_solver_options - module procedure set_solver_options_with_path, & - set_solver_options_scalar, set_solver_options_vector, set_solver_options_tensor -end interface set_solver_options - -interface petsc_solve_monitor_exact - module procedure petsc_solve_monitor_exact_scalar -end interface petsc_solve_monitor_exact + public petsc_solve_core, petsc_solve_destroy, & + petsc_solve_copy_vectors_from_scalar_fields, & + setup_ksp_from_options, create_ksp_from_options, petsc_solve_monitor_exact, & + petsc_solve_monitor_iteration_vtus, attach_null_space_from_options, & + petsc_solve_setup + + interface petsc_solve + module procedure petsc_solve_scalar, petsc_solve_vector, & + petsc_solve_scalar_multiple, & + petsc_solve_vector_components, & + petsc_solve_tensor_components, & + petsc_solve_scalar_petsc_csr, petsc_solve_vector_petsc_csr + end interface + + interface set_solver_options + module procedure set_solver_options_with_path, & + set_solver_options_scalar, set_solver_options_vector, set_solver_options_tensor + end interface set_solver_options + + interface petsc_solve_monitor_exact + module procedure petsc_solve_monitor_exact_scalar + end interface petsc_solve_monitor_exact contains -subroutine petsc_solve_scalar(x, matrix, rhs, option_path, & - preconditioner_matrix, prolongators, surface_node_list, & - internal_smoothing_option, iterations_taken) - !!< Solve a linear system the nice way. - type(scalar_field), intent(inout) :: x - type(scalar_field), intent(in) :: rhs - type(csr_matrix), intent(in) :: matrix - character(len=*), optional, intent(in) :: option_path - !! 2 experimental arguments to improve preconditioning with extra outside information - !! provide approximation the matrix (only to be used in combination with pctype='KSP') - type(csr_matrix), optional, intent(in) :: preconditioner_matrix - !! prolongators to be used at the first levels of 'mg' - type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators - !! surface_node_list for internal smoothing - integer, dimension(:), optional, intent(in) :: surface_node_list - !! internal smoothing option - integer, intent(in), optional :: internal_smoothing_option - !! the number of petsc iterations taken - integer, intent(out), optional :: iterations_taken - - KSP ksp - Mat A - Vec y, b - - character(len=OPTION_PATH_LEN):: solver_option_path - type(petsc_numbering_type) petsc_numbering - integer literations - logical lstartfromzero - - assert(size(x%val)==size(rhs%val)) - assert(size(x%val)==size(matrix,2)) + subroutine petsc_solve_scalar(x, matrix, rhs, option_path, & + preconditioner_matrix, prolongators, surface_node_list, & + internal_smoothing_option, iterations_taken) + !!< Solve a linear system the nice way. + type(scalar_field), intent(inout) :: x + type(scalar_field), intent(in) :: rhs + type(csr_matrix), intent(in) :: matrix + character(len=*), optional, intent(in) :: option_path + !! 2 experimental arguments to improve preconditioning with extra outside information + !! provide approximation the matrix (only to be used in combination with pctype='KSP') + type(csr_matrix), optional, intent(in) :: preconditioner_matrix + !! prolongators to be used at the first levels of 'mg' + type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators + !! surface_node_list for internal smoothing + integer, dimension(:), optional, intent(in) :: surface_node_list + !! internal smoothing option + integer, intent(in), optional :: internal_smoothing_option + !! the number of petsc iterations taken + integer, intent(out), optional :: iterations_taken + + KSP ksp + Mat A + Vec y, b + + character(len=OPTION_PATH_LEN):: solver_option_path + type(petsc_numbering_type) petsc_numbering + integer literations + logical lstartfromzero + + assert(size(x%val)==size(rhs%val)) + assert(size(x%val)==size(matrix,2)) #ifdef DDEBUG - if (.not.associated(matrix%sparsity%column_halo)) then - assert(size(rhs%val)==size(matrix,1)) - else - ! in parallel we allow for the matrix to not have the halo nodes - ! whereas the rhs will always contain them (even if not used) - if (size(matrix,1)/=size(rhs%val)) then - ! get_nowned_nodes() seems completely buggered for T10 halo - ! this should be fixed by dham+jrmaddison's mesh+halo integration - !assert(size(matrix,1)==get_nowned_nodes(matrix%sparsity%halo_tag)) - assert( size(matrix,1)==halo_nowned_nodes(matrix%sparsity%column_halo) ) - end if - end if + if (.not.associated(matrix%sparsity%column_halo)) then + assert(size(rhs%val)==size(matrix,1)) + else + ! in parallel we allow for the matrix to not have the halo nodes + ! whereas the rhs will always contain them (even if not used) + if (size(matrix,1)/=size(rhs%val)) then + ! get_nowned_nodes() seems completely buggered for T10 halo + ! this should be fixed by dham+jrmaddison's mesh+halo integration + !assert(size(matrix,1)==get_nowned_nodes(matrix%sparsity%halo_tag)) + assert( size(matrix,1)==halo_nowned_nodes(matrix%sparsity%column_halo) ) + end if + end if #endif - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, & - matrix=matrix, & - sfield=x, & - option_path=option_path, & - preconditioner_matrix=preconditioner_matrix, & - prolongators=prolongators, surface_node_list=surface_node_list, & - internal_smoothing_option=internal_smoothing_option) - - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_scalar_fields(y, b, x, & - & matrix, rhs, petsc_numbering, lstartfromzero) - - ! the solve and convergence check - call petsc_solve_core(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, literations, & - sfield=x, x0=x%val) - - ! set the optional variable passed out of this procedure - ! for the number of petsc iterations taken - if (present(iterations_taken)) iterations_taken = literations - - ! Copy back the result using the petsc numbering: - call petsc2field(y, petsc_numbering, x, rhs) - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & - & solver_option_path) - -end subroutine petsc_solve_scalar - -subroutine petsc_solve_scalar_multiple(x, matrix, rhs, option_path) - !!< Solves multiple scalar fields with the same matrix. - !!< Need to specify an option_path as there's no default - type(scalar_field), dimension(:), intent(inout) :: x - type(scalar_field), dimension(:), intent(in) :: rhs - type(csr_matrix), intent(in) :: matrix - character(len=*), optional, intent(in) :: option_path - - KSP ksp - Mat A - Vec y, b - - type(petsc_numbering_type) petsc_numbering - character(len=OPTION_PATH_LEN) solver_option_path - integer literations - logical lstartfromzero - integer i - - assert(size(x)==size(rhs)) - do i=1, size(x) - assert(size(x(i)%val)==size(rhs(i)%val)) - assert(size(x(i)%val)==size(matrix,2)) - assert(size(rhs(i)%val)==size(matrix,1)) - end do - - ewrite(1,*) 'Solving for multiple scalar fields at once' - - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, & - matrix=matrix, sfield=x(1), & - option_path=option_path) - - do i=1, size(x) - - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_scalar_fields(y, b, & - x(i), matrix, rhs(i), & - petsc_numbering, lstartfromzero) - - ! the solve and convergence check - call petsc_solve_core(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, literations, & - sfield=x(i), x0=x(i)%val) - - ! Copy back the result using the petsc numbering: - call petsc2field(y, petsc_numbering, x(i), rhs(i)) - - end do - - ewrite(1,*) 'Finished solving all scalar fields' - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & - & solver_option_path) - -end subroutine petsc_solve_scalar_multiple - -subroutine petsc_solve_vector(x, matrix, rhs, option_path, deallocate_matrix) - !!< Solve a linear system the nice way. Options for this - !!< come via the options mechanism. - type(vector_field), intent(inout) :: x - type(vector_field), intent(in) :: rhs - type(block_csr_matrix), intent(inout) :: matrix - character(len=*), optional, intent(in) :: option_path - !! deallocate the matrix after it's been copied - logical, intent(in), optional :: deallocate_matrix - - KSP ksp - Mat A - Vec y, b - - type(petsc_numbering_type) petsc_numbering - character(len=OPTION_PATH_LEN) solver_option_path - integer literations - logical lstartfromzero - - type(csr_matrix) :: matrixblock - type(scalar_field) :: rhsblock, xblock - integer :: i - - assert(x%dim==rhs%dim) - assert(size(x%val(1,:))==size(rhs%val(1,:))) - assert(size(x%val(1,:))==block_size(matrix,2)) - assert(size(rhs%val(1,:))==block_size(matrix,1)) - assert(x%dim==blocks(matrix,2)) - assert(rhs%dim==blocks(matrix,1)) - - if(matrix%diagonal) then - assert(blocks(matrix,1)==blocks(matrix,2)) - ! only want to solve using the diagonal blocks - do i = 1, blocks(matrix,1) - matrixblock=block(matrix,i,i) - rhsblock = extract_scalar_field(rhs, i) - xblock = extract_scalar_field(x, i) + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, & + matrix=matrix, & + sfield=x, & + option_path=option_path, & + preconditioner_matrix=preconditioner_matrix, & + prolongators=prolongators, surface_node_list=surface_node_list, & + internal_smoothing_option=internal_smoothing_option) + + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_scalar_fields(y, b, x, & + & matrix, rhs, petsc_numbering, lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, literations, & + sfield=x, x0=x%val) + + ! set the optional variable passed out of this procedure + ! for the number of petsc iterations taken + if (present(iterations_taken)) iterations_taken = literations + + ! Copy back the result using the petsc numbering: + call petsc2field(y, petsc_numbering, x, rhs) + + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & + & solver_option_path) + + end subroutine petsc_solve_scalar + + subroutine petsc_solve_scalar_multiple(x, matrix, rhs, option_path) + !!< Solves multiple scalar fields with the same matrix. + !!< Need to specify an option_path as there's no default + type(scalar_field), dimension(:), intent(inout) :: x + type(scalar_field), dimension(:), intent(in) :: rhs + type(csr_matrix), intent(in) :: matrix + character(len=*), optional, intent(in) :: option_path + + KSP ksp + Mat A + Vec y, b + + type(petsc_numbering_type) petsc_numbering + character(len=OPTION_PATH_LEN) solver_option_path + integer literations + logical lstartfromzero + integer i + + assert(size(x)==size(rhs)) + do i=1, size(x) + assert(size(x(i)%val)==size(rhs(i)%val)) + assert(size(x(i)%val)==size(matrix,2)) + assert(size(rhs(i)%val)==size(matrix,1)) + end do + + ewrite(1,*) 'Solving for multiple scalar fields at once' ! setup PETSc object and petsc_numbering from options and call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, & + matrix=matrix, sfield=x(1), & + option_path=option_path) + + do i=1, size(x) + + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_scalar_fields(y, b, & + x(i), matrix, rhs(i), & + petsc_numbering, lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, literations, & + sfield=x(i), x0=x(i)%val) + + ! Copy back the result using the petsc numbering: + call petsc2field(y, petsc_numbering, x(i), rhs(i)) + + end do + + ewrite(1,*) 'Finished solving all scalar fields' + + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & + & solver_option_path) + + end subroutine petsc_solve_scalar_multiple + + subroutine petsc_solve_vector(x, matrix, rhs, option_path, deallocate_matrix) + !!< Solve a linear system the nice way. Options for this + !!< come via the options mechanism. + type(vector_field), intent(inout) :: x + type(vector_field), intent(in) :: rhs + type(block_csr_matrix), intent(inout) :: matrix + character(len=*), optional, intent(in) :: option_path + !! deallocate the matrix after it's been copied + logical, intent(in), optional :: deallocate_matrix + + KSP ksp + Mat A + Vec y, b + + type(petsc_numbering_type) petsc_numbering + character(len=OPTION_PATH_LEN) solver_option_path + integer literations + logical lstartfromzero + + type(csr_matrix) :: matrixblock + type(scalar_field) :: rhsblock, xblock + integer :: i + + assert(x%dim==rhs%dim) + assert(size(x%val(1,:))==size(rhs%val(1,:))) + assert(size(x%val(1,:))==block_size(matrix,2)) + assert(size(rhs%val(1,:))==block_size(matrix,1)) + assert(x%dim==blocks(matrix,2)) + assert(rhs%dim==blocks(matrix,1)) + + if(matrix%diagonal) then + assert(blocks(matrix,1)==blocks(matrix,2)) + ! only want to solve using the diagonal blocks + do i = 1, blocks(matrix,1) + matrixblock=block(matrix,i,i) + rhsblock = extract_scalar_field(rhs, i) + xblock = extract_scalar_field(x, i) + + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, & + matrix=matrixblock, & + vfield=x, & + option_path=option_path) + + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_scalar_fields(y, b, xblock, & + & matrixblock, rhsblock, petsc_numbering, lstartfromzero) + + if(present_and_true(deallocate_matrix).and.(i==blocks(matrix,1))) then + call deallocate(matrix) + end if + + ! the solve and convergence check + call petsc_solve_core(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, literations, & + vfield=x, x0=xblock%val) + + ! Copy back the result using the petsc numbering: + call petsc2field(y, petsc_numbering, xblock, rhsblock) + + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & + & solver_option_path) + end do + + else + + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & solver_option_path, lstartfromzero, & - matrix=matrixblock, & + block_matrix=matrix, & vfield=x, & option_path=option_path) - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_scalar_fields(y, b, xblock, & - & matrixblock, rhsblock, petsc_numbering, lstartfromzero) + if(present_and_true(deallocate_matrix)) then + call deallocate(matrix) + end if + + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_vector_fields(y, b, x, rhs, petsc_numbering, lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, literations, & + vfield=x, vector_x0=x) + + ! Copy back the result using the petsc numbering: + call petsc2field(y, petsc_numbering, x) - if(present_and_true(deallocate_matrix).and.(i==blocks(matrix,1))) then - call deallocate(matrix) + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & + & solver_option_path) end if - ! the solve and convergence check - call petsc_solve_core(y, A, b, ksp, petsc_numbering, & + end subroutine petsc_solve_vector + + subroutine petsc_solve_vector_components(x, matrix, rhs, option_path) + !!< Solve a linear system the nice way. Options for this + !!< come via the options mechanism. This version solves a linear system + !!< for each of the components of rhs each time with the same matrix. + type(vector_field), intent(inout) :: x + type(vector_field), intent(in) :: rhs + type(csr_matrix), intent(in) :: matrix + character(len=*), optional, intent(in) :: option_path + + KSP ksp + Mat A + Vec y, b + + type(scalar_field) x_component, rhs_component + type(petsc_numbering_type) petsc_numbering + character(len=OPTION_PATH_LEN) solver_option_path, option_path_in + integer literations, i + logical lstartfromzero + + assert(x%dim==rhs%dim) + assert(size(x%val(1,:))==size(rhs%val(1,:))) + assert(size(x%val(1,:))==size(matrix,2)) + assert(size(rhs%val(1,:))==size(matrix,1)) + + ! option_path_in may still point to field + ! (so we have to add "/prognostic/solver" below) + if (present(option_path)) then + option_path_in=option_path + else + option_path_in=x%option_path + end if + + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, & + matrix=matrix, & + vfield=x, & + option_path=option_path) + + ewrite(1,*) 'Solving for multiple components of a vector field' + + do i=1, x%dim + + ewrite(1, *) 'Now solving for component: ', i + x_component=extract_scalar_field(x, i) + rhs_component=extract_scalar_field(rhs, i) + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_scalar_fields(y, b, x_component, matrix, rhs_component, petsc_numbering, lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, A, b, ksp, petsc_numbering, & solver_option_path, lstartfromzero, literations, & - vfield=x, x0=xblock%val) + vfield=x, x0=x_component%val) - ! Copy back the result using the petsc numbering: - call petsc2field(y, petsc_numbering, xblock, rhsblock) + ! Copy back the result using the petsc numbering: + call petsc2field(y, petsc_numbering, x_component, rhs_component) + + end do + + ewrite(1,*) 'Finished solving all components.' ! destroy all PETSc objects and the petsc_numbering call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & - & solver_option_path) - end do + & solver_option_path) - else + end subroutine petsc_solve_vector_components - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, & - block_matrix=matrix, & - vfield=x, & - option_path=option_path) + subroutine petsc_solve_scalar_petsc_csr(x, matrix, rhs, option_path, & + prolongators, surface_node_list) + !!< Solve a linear system the nice way. Options for this + !!< come via the options mechanism. + type(scalar_field), intent(inout) :: x + type(scalar_field), intent(in) :: rhs + type(petsc_csr_matrix), intent(inout) :: matrix + character(len=*), optional, intent(in) :: option_path + !! prolongators to be used at the first levels of 'mg' + type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators + !! surface_node_list for internal smoothing + integer, dimension(:), optional, intent(in) :: surface_node_list - if(present_and_true(deallocate_matrix)) then - call deallocate(matrix) - end if + Vec y, b - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_vector_fields(y, b, x, rhs, petsc_numbering, lstartfromzero) + character(len=OPTION_PATH_LEN) solver_option_path + integer literations + logical lstartfromzero - ! the solve and convergence check - call petsc_solve_core(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, literations, & - vfield=x, vector_x0=x) + assert(size(x%val)==size(rhs%val)) + assert(size(x%val)==size(matrix,2)) + assert(size(rhs%val)==size(matrix,1)) + + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup_petsc_csr(y, b, & + solver_option_path, lstartfromzero, & + matrix, & + sfield=x, & + option_path=option_path, & + prolongators=prolongators, surface_node_list=surface_node_list) - ! Copy back the result using the petsc numbering: - call petsc2field(y, petsc_numbering, x) - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & - & solver_option_path) - end if - -end subroutine petsc_solve_vector - -subroutine petsc_solve_vector_components(x, matrix, rhs, option_path) - !!< Solve a linear system the nice way. Options for this - !!< come via the options mechanism. This version solves a linear system - !!< for each of the components of rhs each time with the same matrix. - type(vector_field), intent(inout) :: x - type(vector_field), intent(in) :: rhs - type(csr_matrix), intent(in) :: matrix - character(len=*), optional, intent(in) :: option_path - - KSP ksp - Mat A - Vec y, b - - type(scalar_field) x_component, rhs_component - type(petsc_numbering_type) petsc_numbering - character(len=OPTION_PATH_LEN) solver_option_path, option_path_in - integer literations, i - logical lstartfromzero - - assert(x%dim==rhs%dim) - assert(size(x%val(1,:))==size(rhs%val(1,:))) - assert(size(x%val(1,:))==size(matrix,2)) - assert(size(rhs%val(1,:))==size(matrix,1)) - - ! option_path_in may still point to field - ! (so we have to add "/prognostic/solver" below) - if (present(option_path)) then - option_path_in=option_path - else - option_path_in=x%option_path - end if - - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, & - matrix=matrix, & - vfield=x, & - option_path=option_path) - - ewrite(1,*) 'Solving for multiple components of a vector field' - - do i=1, x%dim - - ewrite(1, *) 'Now solving for component: ', i - x_component=extract_scalar_field(x, i) - rhs_component=extract_scalar_field(rhs, i) - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_scalar_fields(y, b, x_component, matrix, rhs_component, petsc_numbering, lstartfromzero) - - ! the solve and convergence check - call petsc_solve_core(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, literations, & - vfield=x, x0=x_component%val) - - ! Copy back the result using the petsc numbering: - call petsc2field(y, petsc_numbering, x_component, rhs_component) - - end do - - ewrite(1,*) 'Finished solving all components.' - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & - & solver_option_path) - -end subroutine petsc_solve_vector_components - -subroutine petsc_solve_scalar_petsc_csr(x, matrix, rhs, option_path, & - prolongators, surface_node_list) - !!< Solve a linear system the nice way. Options for this - !!< come via the options mechanism. - type(scalar_field), intent(inout) :: x - type(scalar_field), intent(in) :: rhs - type(petsc_csr_matrix), intent(inout) :: matrix - character(len=*), optional, intent(in) :: option_path - !! prolongators to be used at the first levels of 'mg' - type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators - !! surface_node_list for internal smoothing - integer, dimension(:), optional, intent(in) :: surface_node_list - - Vec y, b - - character(len=OPTION_PATH_LEN) solver_option_path - integer literations - logical lstartfromzero - - assert(size(x%val)==size(rhs%val)) - assert(size(x%val)==size(matrix,2)) - assert(size(rhs%val)==size(matrix,1)) - - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup_petsc_csr(y, b, & - solver_option_path, lstartfromzero, & - matrix, & - sfield=x, & - option_path=option_path, & - prolongators=prolongators, surface_node_list=surface_node_list) - - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_scalar_fields(y, b, x, rhs=rhs, & - petsc_numbering=matrix%row_numbering, startfromzero=lstartfromzero) - - ! the solve and convergence check - call petsc_solve_core(y, matrix%M, b, matrix%ksp, matrix%row_numbering, & - solver_option_path, lstartfromzero, literations, & - sfield=x, x0=x%val) - - ! Copy back the result using the petsc numbering: - call petsc2field(y, matrix%column_numbering, x) - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy_petsc_csr(y, b, solver_option_path) - -end subroutine petsc_solve_scalar_petsc_csr - -subroutine petsc_solve_vector_petsc_csr(x, matrix, rhs, option_path, & - prolongators, positions, rotation_matrix) - !!< Solve a linear system the nice way. Options for this - !!< come via the options mechanism. - type(vector_field), intent(inout) :: x - type(vector_field), intent(in) :: rhs - type(petsc_csr_matrix), intent(inout) :: matrix - character(len=*), optional, intent(in) :: option_path - !! prolongators to be used at the first levels of 'mg' - type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators - !! positions field is only used with remove_null_space/ or multigrid_near_null_space/ with rotational components - type(vector_field), intent(in), optional :: positions - !! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned - Mat, intent(in), optional:: rotation_matrix - - Vec y, b - - character(len=OPTION_PATH_LEN) solver_option_path - integer literations - logical lstartfromzero - - assert(x%dim==rhs%dim) - assert(size(x%val(1,:))==size(rhs%val(1,:))) - assert(size(x%val(1,:))==block_size(matrix,2)) - assert(size(rhs%val(1,:))==block_size(matrix,1)) - assert(x%dim==blocks(matrix,2)) - assert(rhs%dim==blocks(matrix,1)) - - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup_petsc_csr(y, b, & - solver_option_path, lstartfromzero, & - matrix, vfield=x, option_path=option_path, & - prolongators=prolongators, & - positions=positions, rotation_matrix=rotation_matrix) - - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_vector_fields(y, b, x, rhs, & - matrix%row_numbering, lstartfromzero) - - ! the solve and convergence check - call petsc_solve_core(y, matrix%M, b, matrix%ksp, matrix%row_numbering, & - solver_option_path, lstartfromzero, literations, & - vfield=x, vector_x0=x) - - ! Copy back the result using the petsc numbering: - call petsc2field(y, matrix%column_numbering, x) - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy_petsc_csr(y, b, solver_option_path) - -end subroutine petsc_solve_vector_petsc_csr - -subroutine petsc_solve_tensor_components(x, matrix, rhs, & - symmetric, option_path) - !!< Solve a linear system the nice way. Options for this - !!< come via the options mechanism. This version solves a linear system - !!< for each of the components of rhs each time with the same matrix. - type(tensor_field), intent(inout) :: x - type(tensor_field), intent(in) :: rhs - type(csr_matrix), intent(in) :: matrix - ! if .true. assume rhs is symmetric (so we need to solve for fewer components) - logical, optional, intent(in):: symmetric - character(len=*), optional, intent(in) :: option_path - - KSP ksp - Mat A - Vec y, b - - type(scalar_field) x_component, rhs_component - type(petsc_numbering_type) petsc_numbering - character(len=OPTION_PATH_LEN) solver_option_path, option_path_in - integer literations, i, j, startj - logical lstartfromzero - - assert(all(x%dim==rhs%dim)) - assert(size(x%val,3)==size(rhs%val,3)) - assert(size(x%val,3)==size(matrix,2)) - assert(size(rhs%val,3)==size(matrix,1)) - - ! option_path_in may still point to field - ! (so we have to add "/prognostic/solver" below) - if (present(option_path)) then - option_path_in=option_path - else - option_path_in=x%option_path - end if - - ! setup PETSc object and petsc_numbering from options and - call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, & - matrix=matrix, & - tfield=x, & - option_path=option_path_in) - - ewrite(1,*) 'Solving for multiple components of a tensor field' - - startj=1 - do i=1, x%dim(1) - - if (present(symmetric)) then - if (symmetric) then - ! only computes with rhs(i,j) where j>=i - startj=i - end if - end if - - do j=startj, x%dim(2) - - ewrite(1, *) 'Now solving for component: ', i, j - - x_component=extract_scalar_field(x, i, j) - rhs_component=extract_scalar_field(rhs, i, j) - ! copy array into PETSc vecs - call petsc_solve_copy_vectors_from_scalar_fields(y, b, x_component, matrix, rhs_component, petsc_numbering, lstartfromzero) - - ! the solve and convergence check - call petsc_solve_core(y, A, b, ksp, petsc_numbering, & - solver_option_path, lstartfromzero, literations, & - tfield=x, x0=x_component%val) - - ! Copy back the result using the petsc numbering: - call petsc2field(y, petsc_numbering, x_component, rhs_component) - - end do - end do - - ewrite(1,*) 'Finished solving all components.' - - if (present(symmetric)) then - if (symmetric) then - - ewrite(2,*) 'This is a symmetric matrix' - ewrite(2,*) 'Only components (i,j) with j>=i have been solved for.' - ewrite(2,*) 'Now copying these to components (j,i).' - - ! copy results x(i,j) of equations with rhs(i,j) where j>=i to x(j,i) - do i=1, x%dim(1) - do j=i, x%dim(2) - x%val(j,i,:)=x%val(i,j,:) - end do - end do - end if - end if - - ! destroy all PETSc objects and the petsc_numbering - call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, solver_option_path) - -end subroutine petsc_solve_tensor_components - -function complete_solver_option_path(option_path) -character(len=*), intent(in):: option_path -character(len=OPTION_PATH_LEN):: complete_solver_option_path - - ! at the moment only prognostic fields have a solver options block - ! under [field_path]/prognostic/solver/. Other cases should be - ! implemented here: - if (have_option(trim(option_path)//'/prognostic/solver')) then - complete_solver_option_path=trim(option_path)//'/prognostic/solver' - ! some diagnostic cases have solver blocks now - else if (have_option(trim(option_path)//'/diagnostic/solver')) then - complete_solver_option_path=trim(option_path)//'/diagnostic/solver' - else if (have_option(trim(option_path)//'/solver')) then - complete_solver_option_path=trim(option_path)//'/solver' - else - ewrite(-1,*) 'option_path: ', trim(option_path) - FLAbort("Missing solver element in provided option_path.") - end if - -end function complete_solver_option_path - -subroutine petsc_solve_setup(y, A, b, ksp, petsc_numbering, & - solver_option_path, startfromzero, & - matrix, block_matrix, sfield, vfield, tfield, & - option_path, startfromzero_in, & - preconditioner_matrix, prolongators, surface_node_list, & - internal_smoothing_option, positions) + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_scalar_fields(y, b, x, rhs=rhs, & + petsc_numbering=matrix%row_numbering, startfromzero=lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, matrix%M, b, matrix%ksp, matrix%row_numbering, & + solver_option_path, lstartfromzero, literations, & + sfield=x, x0=x%val) + + ! Copy back the result using the petsc numbering: + call petsc2field(y, matrix%column_numbering, x) + + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy_petsc_csr(y, b, solver_option_path) + + end subroutine petsc_solve_scalar_petsc_csr + + subroutine petsc_solve_vector_petsc_csr(x, matrix, rhs, option_path, & + prolongators, positions, rotation_matrix) + !!< Solve a linear system the nice way. Options for this + !!< come via the options mechanism. + type(vector_field), intent(inout) :: x + type(vector_field), intent(in) :: rhs + type(petsc_csr_matrix), intent(inout) :: matrix + character(len=*), optional, intent(in) :: option_path + !! prolongators to be used at the first levels of 'mg' + type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators + !! positions field is only used with remove_null_space/ or multigrid_near_null_space/ with rotational components + type(vector_field), intent(in), optional :: positions + !! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned + Mat, intent(in), optional:: rotation_matrix + + Vec y, b + + character(len=OPTION_PATH_LEN) solver_option_path + integer literations + logical lstartfromzero + + assert(x%dim==rhs%dim) + assert(size(x%val(1,:))==size(rhs%val(1,:))) + assert(size(x%val(1,:))==block_size(matrix,2)) + assert(size(rhs%val(1,:))==block_size(matrix,1)) + assert(x%dim==blocks(matrix,2)) + assert(rhs%dim==blocks(matrix,1)) + + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup_petsc_csr(y, b, & + solver_option_path, lstartfromzero, & + matrix, vfield=x, option_path=option_path, & + prolongators=prolongators, & + positions=positions, rotation_matrix=rotation_matrix) + + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_vector_fields(y, b, x, rhs, & + matrix%row_numbering, lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, matrix%M, b, matrix%ksp, matrix%row_numbering, & + solver_option_path, lstartfromzero, literations, & + vfield=x, vector_x0=x) + + ! Copy back the result using the petsc numbering: + call petsc2field(y, matrix%column_numbering, x) + + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy_petsc_csr(y, b, solver_option_path) + + end subroutine petsc_solve_vector_petsc_csr + + subroutine petsc_solve_tensor_components(x, matrix, rhs, & + symmetric, option_path) + !!< Solve a linear system the nice way. Options for this + !!< come via the options mechanism. This version solves a linear system + !!< for each of the components of rhs each time with the same matrix. + type(tensor_field), intent(inout) :: x + type(tensor_field), intent(in) :: rhs + type(csr_matrix), intent(in) :: matrix + ! if .true. assume rhs is symmetric (so we need to solve for fewer components) + logical, optional, intent(in):: symmetric + character(len=*), optional, intent(in) :: option_path + + KSP ksp + Mat A + Vec y, b + + type(scalar_field) x_component, rhs_component + type(petsc_numbering_type) petsc_numbering + character(len=OPTION_PATH_LEN) solver_option_path, option_path_in + integer literations, i, j, startj + logical lstartfromzero + + assert(all(x%dim==rhs%dim)) + assert(size(x%val,3)==size(rhs%val,3)) + assert(size(x%val,3)==size(matrix,2)) + assert(size(rhs%val,3)==size(matrix,1)) + + ! option_path_in may still point to field + ! (so we have to add "/prognostic/solver" below) + if (present(option_path)) then + option_path_in=option_path + else + option_path_in=x%option_path + end if + + ! setup PETSc object and petsc_numbering from options and + call petsc_solve_setup(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, & + matrix=matrix, & + tfield=x, & + option_path=option_path_in) + + ewrite(1,*) 'Solving for multiple components of a tensor field' + + startj=1 + do i=1, x%dim(1) + + if (present(symmetric)) then + if (symmetric) then + ! only computes with rhs(i,j) where j>=i + startj=i + end if + end if + + do j=startj, x%dim(2) + + ewrite(1, *) 'Now solving for component: ', i, j + + x_component=extract_scalar_field(x, i, j) + rhs_component=extract_scalar_field(rhs, i, j) + ! copy array into PETSc vecs + call petsc_solve_copy_vectors_from_scalar_fields(y, b, x_component, matrix, rhs_component, petsc_numbering, lstartfromzero) + + ! the solve and convergence check + call petsc_solve_core(y, A, b, ksp, petsc_numbering, & + solver_option_path, lstartfromzero, literations, & + tfield=x, x0=x_component%val) + + ! Copy back the result using the petsc numbering: + call petsc2field(y, petsc_numbering, x_component, rhs_component) + + end do + end do + + ewrite(1,*) 'Finished solving all components.' + + if (present(symmetric)) then + if (symmetric) then + + ewrite(2,*) 'This is a symmetric matrix' + ewrite(2,*) 'Only components (i,j) with j>=i have been solved for.' + ewrite(2,*) 'Now copying these to components (j,i).' + + ! copy results x(i,j) of equations with rhs(i,j) where j>=i to x(j,i) + do i=1, x%dim(1) + do j=i, x%dim(2) + x%val(j,i,:)=x%val(i,j,:) + end do + end do + end if + end if + + ! destroy all PETSc objects and the petsc_numbering + call petsc_solve_destroy(y, A, b, ksp, petsc_numbering, solver_option_path) + + end subroutine petsc_solve_tensor_components + + function complete_solver_option_path(option_path) + character(len=*), intent(in):: option_path + character(len=OPTION_PATH_LEN):: complete_solver_option_path + + ! at the moment only prognostic fields have a solver options block + ! under [field_path]/prognostic/solver/. Other cases should be + ! implemented here: + if (have_option(trim(option_path)//'/prognostic/solver')) then + complete_solver_option_path=trim(option_path)//'/prognostic/solver' + ! some diagnostic cases have solver blocks now + else if (have_option(trim(option_path)//'/diagnostic/solver')) then + complete_solver_option_path=trim(option_path)//'/diagnostic/solver' + else if (have_option(trim(option_path)//'/solver')) then + complete_solver_option_path=trim(option_path)//'/solver' + else + ewrite(-1,*) 'option_path: ', trim(option_path) + FLAbort("Missing solver element in provided option_path.") + end if + + end function complete_solver_option_path + + subroutine petsc_solve_setup(y, A, b, ksp, petsc_numbering, & + solver_option_path, startfromzero, & + matrix, block_matrix, sfield, vfield, tfield, & + option_path, startfromzero_in, & + preconditioner_matrix, prolongators, surface_node_list, & + internal_smoothing_option, positions) !!< sets up things needed to call petsc_solve_core !! Stuff that comes out: !! !! PETSc solution vector -Vec, intent(out):: y + Vec, intent(out):: y !! PETSc matrix -Mat, intent(out):: A + Mat, intent(out):: A !! PETSc rhs vector -Vec, intent(out):: b + Vec, intent(out):: b !! Solver object -KSP, intent(out):: ksp + KSP, intent(out):: ksp !! numbering from local (i.e. fluidity speak: global) to PETSc (fluidity: universal) numbering -type(petsc_numbering_type), intent(out):: petsc_numbering + type(petsc_numbering_type), intent(out):: petsc_numbering !! returns the option path to solver/ block for new options, otherwise "" -character(len=*), intent(out):: solver_option_path + character(len=*), intent(out):: solver_option_path !! whether to start with zero initial guess -logical, intent(out):: startfromzero + logical, intent(out):: startfromzero !! Stuff that goes in: !! !! provide either a matrix or block_matrix to be solved -type(csr_matrix), target, optional, intent(in):: matrix -type(block_csr_matrix), target, optional, intent(in):: block_matrix + type(csr_matrix), target, optional, intent(in):: matrix + type(block_csr_matrix), target, optional, intent(in):: block_matrix !! provide either a scalar field or vector field to be solved for -type(scalar_field), optional, intent(in):: sfield -type(vector_field), optional, intent(in):: vfield -type(tensor_field), optional, intent(in):: tfield + type(scalar_field), optional, intent(in):: sfield + type(vector_field), optional, intent(in):: vfield + type(tensor_field), optional, intent(in):: tfield !! if provided overrides sfield%option_path -character(len=*), optional, intent(in):: option_path + character(len=*), optional, intent(in):: option_path !! whether to start with zero initial guess (as passed in) -logical, optional, intent(in):: startfromzero_in + logical, optional, intent(in):: startfromzero_in !! provide approximation the matrix (only to be used in combination with pctype='KSP') -type(csr_matrix), optional, intent(in) :: preconditioner_matrix + type(csr_matrix), optional, intent(in) :: preconditioner_matrix !! prolongators to be used at the first level of 'mg' -type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators + type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators !! Stuff needed for internal smoother -integer, dimension(:), optional, intent(in) :: surface_node_list -integer, optional, intent(in) :: internal_smoothing_option + integer, dimension(:), optional, intent(in) :: surface_node_list + integer, optional, intent(in) :: internal_smoothing_option !! positions field is only used with remove_null_space/ or multigrid_near_null_space/ with rotational components -type(vector_field), intent(in), optional :: positions - - logical, dimension(:), pointer:: inactive_mask - integer, dimension(:), allocatable:: ghost_nodes - Mat:: pmat - ! one of the PETSc supplied orderings see - ! http://www-unix.mcs.anl.gov/petsc/petsc-as/snapshots/petsc-current/docs/manualpages/MatOrderings/MatGetOrdering.html - MatOrderingType:: ordering_type - logical:: use_reordering - real time1, time2 - integer ierr - logical:: parallel, timing, have_cache - type(halo_type), pointer :: halo - integer i, j - character(len=FIELD_NAME_LEN) :: name - KSP, pointer:: ksp_pointer - - ! Initialise profiler - if(present(sfield)) then - call profiler_tic(sfield, "petsc_setup") - name = sfield%name - else if(present(vfield)) then - call profiler_tic(vfield, "petsc_setup") - name = vfield%name - else if(present(tfield)) then - call profiler_tic(tfield, "petsc_setup") - name = tfield%name - else - FLAbort("petsc_solve_setup should be called with sfield, vfield or tfield") - end if - - timing=(debug_level()>=2) - if (timing) then - call cpu_time(time1) - end if - - - if (present(option_path)) then - solver_option_path=complete_solver_option_path(option_path) - else if (present(sfield)) then - solver_option_path=complete_solver_option_path(sfield%option_path) - else if (present(vfield)) then - solver_option_path=complete_solver_option_path(vfield%option_path) - else if (present(tfield)) then - solver_option_path=complete_solver_option_path(tfield%option_path) - else - FLAbort("Need to provide either sfield, vfield or tfield to petsc_solve_setup.") - end if - - startfromzero=have_option(trim(solver_option_path)//'/start_from_zero') - if (present_and_true(startfromzero_in) .and. .not. startfromzero) then - ewrite(2,*) 'Note: startfromzero hard-coded to .true.' - ewrite(2,*) 'Ignoring setting from solver option.' - startfromzero=.true. - end if - - ksp=PETSC_NULL_KSP - if (present(matrix)) then - if (associated(matrix%ksp)) then - ksp=matrix%ksp - end if - else if (present(block_matrix)) then - if (associated(block_matrix%ksp)) then - ksp=block_matrix%ksp - end if - end if - - if (ksp/=PETSC_NULL_KSP) then - ! oh goody, we've been left something useful! - call KSPGetOperators(ksp, A, Pmat, ierr) - have_cache=.true. - - if (have_option(trim(solver_option_path)// & - '/preconditioner::mg/vertical_lumping/internal_smoother')) then - ! this option is unsafe with caching, as it needs - ! DestroyMultigrid to be called on top of PCDestroy to destroy - ! all its associated objects - FLExit("Sorry, can't combine internal_smoother with cache_solver_context") - end if - else - ! no cache - we just have to do it all over again - have_cache=.false. - end if - - ewrite(1, *) 'Assembling matrix.' - - ! Note the explicitly-described options rcm, 1wd and natural are now not - ! listed explicitly in the schema (but can still be used by adding the - ! appropriate string in the solver reordering node). - call PetscOptionsGetString(PETSC_NULL_OPTIONS, "", "-ordering_type", ordering_type, use_reordering, ierr) - if (.not. use_reordering) then - call get_option(trim(solver_option_path)//'/reordering[0]/name', & - ordering_type, stat=ierr) - use_reordering= (ierr==0) - end if - - if (present(matrix)) then - ewrite(2, *) 'Number of rows == ', size(matrix, 1) - - ! Create the matrix & vectors. - - inactive_mask => get_inactive_mask(matrix) - ! create list of inactive, ghost_nodes - if (associated(inactive_mask)) then - allocate( ghost_nodes(1:count(inactive_mask)) ) - j=0 - do i=1, size(matrix,1) - if (inactive_mask(i)) then - j=j+1 - ghost_nodes(j)=i - end if - end do - else - allocate( ghost_nodes(1:0) ) - end if - - ! set up numbering used in PETSc objects: - ! NOTE: we use size(matrix,2) here as halo rows may be absent - call allocate(petsc_numbering, & - nnodes=size(matrix,2), nfields=1, & - halo=matrix%sparsity%column_halo, & - ghost_nodes=ghost_nodes) - - if (use_reordering) then - call reorder(petsc_numbering, matrix%sparsity, ordering_type) - end if - - if (.not. have_cache) then - ! create PETSc Mat using this numbering: - A=csr2petsc(matrix, petsc_numbering, petsc_numbering) - end if - - halo=>matrix%sparsity%column_halo - - elseif (present(block_matrix)) then - - ewrite(2, *) 'Number of rows == ', size(block_matrix, 1) - ewrite(2, *) 'Number of blocks == ', blocks(block_matrix,1) - assert(.not.block_matrix%diagonal) - - ! Create the matrix & vectors. - - ! set up numbering used in PETSc objects: - call allocate(petsc_numbering, & - nnodes=block_size(block_matrix,2), nfields=blocks(block_matrix,1), & - halo=block_matrix%sparsity%column_halo) - - if (use_reordering) then - call reorder(petsc_numbering, block_matrix%sparsity, ordering_type) - end if - - if (.not. have_cache) then - ! create PETSc Mat using this numbering: - A=block_csr2petsc(block_matrix, petsc_numbering, petsc_numbering) - end if - - halo=>block_matrix%sparsity%column_halo - - else - - ewrite(-1,*) "So what am I going to solve???" - FLAbort("Wake up!") - - end if - - ewrite(1, *) 'Matrix assembly completed.' - - if (IsParallel()) then - parallel= (associated(halo)) - else - parallel=.false. - end if - - if (have_cache) then - ! write the cached solver options to log: - call ewrite_ksp_options(ksp) - else - - if (present(preconditioner_matrix)) then - ewrite(2,*) 'Using provided preconditioner matrix' - pmat=csr2petsc(preconditioner_matrix, petsc_numbering) - else - pmat=A - end if + type(vector_field), intent(in), optional :: positions + + logical, dimension(:), pointer:: inactive_mask + integer, dimension(:), allocatable:: ghost_nodes + Mat:: pmat + ! one of the PETSc supplied orderings see + ! http://www-unix.mcs.anl.gov/petsc/petsc-as/snapshots/petsc-current/docs/manualpages/MatOrderings/MatGetOrdering.html + MatOrderingType:: ordering_type + logical:: use_reordering + real time1, time2 + integer ierr + logical:: parallel, timing, have_cache + type(halo_type), pointer :: halo + integer i, j + character(len=FIELD_NAME_LEN) :: name + KSP, pointer:: ksp_pointer + + ! Initialise profiler + if(present(sfield)) then + call profiler_tic(sfield, "petsc_setup") + name = sfield%name + else if(present(vfield)) then + call profiler_tic(vfield, "petsc_setup") + name = vfield%name + else if(present(tfield)) then + call profiler_tic(tfield, "petsc_setup") + name = tfield%name + else + FLAbort("petsc_solve_setup should be called with sfield, vfield or tfield") + end if + + timing=(debug_level()>=2) + if (timing) then + call cpu_time(time1) + end if - ewrite(2, *) 'Using solver options defined at: ', trim(solver_option_path) - call attach_null_space_from_options(A, solver_option_path, pmat=pmat, & - positions=positions, petsc_numbering=petsc_numbering) - call create_ksp_from_options(ksp, A, pmat, solver_option_path, parallel, & - petsc_numbering, & - startfromzero_in=startfromzero_in, & - prolongators=prolongators, surface_node_list=surface_node_list, & - matrix_csr=matrix, & - internal_smoothing_option=internal_smoothing_option) - end if - - if (.not. have_cache .and. have_option(trim(solver_option_path)// & - &'/cache_solver_context')) then - - ! save the ksp solver context for future generations - ! (hack with pointer to convince intel compiler that it's - ! really just the pointed-to value I'm changing) - if (present(matrix)) then - ksp_pointer => matrix%ksp - else if (present(block_matrix)) then - ksp_pointer => block_matrix%ksp - end if - if (associated(ksp_pointer)) then - ksp_pointer = ksp - - ! make sure we don't destroy it, the %ksp becomes a separate reference - call PetscObjectReferenceWrapper(ksp, ierr) - else - ! matrices coming from block() can't cache - FLAbort("User wants to cache solver context, but no proper matrix is provided.") - end if - - else if (have_cache) then - - ! ksp is a copy of matrix%ksp, make it a separate reference, - ! so we can KSPDestroy it without destroying matrix%ksp - call PetscObjectReferenceWrapper(ksp, ierr) - - ! same for the matrix, kspgetoperators returns the matrix reference - ! owned by the ksp - make it a separate reference - call PetscObjectReferenceWrapper(A, ierr) - - end if - - b=PetscNumberingCreateVec(petsc_numbering) - call VecDuplicate(b, y, ierr) - - if (timing) then - call cpu_time(time2) - ewrite(2,*) trim(name)// " CPU time spent in PETSc setup: ", time2-time1 - end if - - if(present(sfield)) then - call profiler_toc(sfield, "petsc_setup") - else if(present(vfield)) then - call profiler_toc(vfield, "petsc_setup") - else if(present(tfield)) then - call profiler_toc(tfield, "petsc_setup") - end if - -end subroutine petsc_solve_setup - -subroutine petsc_solve_setup_petsc_csr(y, b, & - solver_option_path, startfromzero, & - matrix, sfield, vfield, tfield, & - option_path, startfromzero_in, & - prolongators,surface_node_list, & - positions, rotation_matrix) + if (present(option_path)) then + solver_option_path=complete_solver_option_path(option_path) + else if (present(sfield)) then + solver_option_path=complete_solver_option_path(sfield%option_path) + else if (present(vfield)) then + solver_option_path=complete_solver_option_path(vfield%option_path) + else if (present(tfield)) then + solver_option_path=complete_solver_option_path(tfield%option_path) + else + FLAbort("Need to provide either sfield, vfield or tfield to petsc_solve_setup.") + end if + + startfromzero=have_option(trim(solver_option_path)//'/start_from_zero') + if (present_and_true(startfromzero_in) .and. .not. startfromzero) then + ewrite(2,*) 'Note: startfromzero hard-coded to .true.' + ewrite(2,*) 'Ignoring setting from solver option.' + startfromzero=.true. + end if + + ksp=PETSC_NULL_KSP + if (present(matrix)) then + if (associated(matrix%ksp)) then + ksp=matrix%ksp + end if + else if (present(block_matrix)) then + if (associated(block_matrix%ksp)) then + ksp=block_matrix%ksp + end if + end if + + if (ksp/=PETSC_NULL_KSP) then + ! oh goody, we've been left something useful! + call KSPGetOperators(ksp, A, Pmat, ierr) + have_cache=.true. + + if (have_option(trim(solver_option_path)// & + '/preconditioner::mg/vertical_lumping/internal_smoother')) then + ! this option is unsafe with caching, as it needs + ! DestroyMultigrid to be called on top of PCDestroy to destroy + ! all its associated objects + FLExit("Sorry, can't combine internal_smoother with cache_solver_context") + end if + else + ! no cache - we just have to do it all over again + have_cache=.false. + end if + + ewrite(1, *) 'Assembling matrix.' + + ! Note the explicitly-described options rcm, 1wd and natural are now not + ! listed explicitly in the schema (but can still be used by adding the + ! appropriate string in the solver reordering node). + call PetscOptionsGetString(PETSC_NULL_OPTIONS, "", "-ordering_type", ordering_type, use_reordering, ierr) + if (.not. use_reordering) then + call get_option(trim(solver_option_path)//'/reordering[0]/name', & + ordering_type, stat=ierr) + use_reordering= (ierr==0) + end if + + if (present(matrix)) then + ewrite(2, *) 'Number of rows == ', size(matrix, 1) + + ! Create the matrix & vectors. + + inactive_mask => get_inactive_mask(matrix) + ! create list of inactive, ghost_nodes + if (associated(inactive_mask)) then + allocate( ghost_nodes(1:count(inactive_mask)) ) + j=0 + do i=1, size(matrix,1) + if (inactive_mask(i)) then + j=j+1 + ghost_nodes(j)=i + end if + end do + else + allocate( ghost_nodes(1:0) ) + end if + + ! set up numbering used in PETSc objects: + ! NOTE: we use size(matrix,2) here as halo rows may be absent + call allocate(petsc_numbering, & + nnodes=size(matrix,2), nfields=1, & + halo=matrix%sparsity%column_halo, & + ghost_nodes=ghost_nodes) + + if (use_reordering) then + call reorder(petsc_numbering, matrix%sparsity, ordering_type) + end if + + if (.not. have_cache) then + ! create PETSc Mat using this numbering: + A=csr2petsc(matrix, petsc_numbering, petsc_numbering) + end if + + halo=>matrix%sparsity%column_halo + + elseif (present(block_matrix)) then + + ewrite(2, *) 'Number of rows == ', size(block_matrix, 1) + ewrite(2, *) 'Number of blocks == ', blocks(block_matrix,1) + assert(.not.block_matrix%diagonal) + + ! Create the matrix & vectors. + + ! set up numbering used in PETSc objects: + call allocate(petsc_numbering, & + nnodes=block_size(block_matrix,2), nfields=blocks(block_matrix,1), & + halo=block_matrix%sparsity%column_halo) + + if (use_reordering) then + call reorder(petsc_numbering, block_matrix%sparsity, ordering_type) + end if + + if (.not. have_cache) then + ! create PETSc Mat using this numbering: + A=block_csr2petsc(block_matrix, petsc_numbering, petsc_numbering) + end if + + halo=>block_matrix%sparsity%column_halo + + else + + ewrite(-1,*) "So what am I going to solve???" + FLAbort("Wake up!") + + end if + + ewrite(1, *) 'Matrix assembly completed.' + + if (IsParallel()) then + parallel= (associated(halo)) + else + parallel=.false. + end if + + if (have_cache) then + ! write the cached solver options to log: + call ewrite_ksp_options(ksp) + else + + if (present(preconditioner_matrix)) then + ewrite(2,*) 'Using provided preconditioner matrix' + pmat=csr2petsc(preconditioner_matrix, petsc_numbering) + else + pmat=A + end if + + ewrite(2, *) 'Using solver options defined at: ', trim(solver_option_path) + call attach_null_space_from_options(A, solver_option_path, pmat=pmat, & + positions=positions, petsc_numbering=petsc_numbering) + + call create_ksp_from_options(ksp, A, pmat, solver_option_path, parallel, & + petsc_numbering, & + startfromzero_in=startfromzero_in, & + prolongators=prolongators, surface_node_list=surface_node_list, & + matrix_csr=matrix, & + internal_smoothing_option=internal_smoothing_option) + end if + + if (.not. have_cache .and. have_option(trim(solver_option_path)// & + &'/cache_solver_context')) then + + ! save the ksp solver context for future generations + ! (hack with pointer to convince intel compiler that it's + ! really just the pointed-to value I'm changing) + if (present(matrix)) then + ksp_pointer => matrix%ksp + else if (present(block_matrix)) then + ksp_pointer => block_matrix%ksp + end if + if (associated(ksp_pointer)) then + ksp_pointer = ksp + + ! make sure we don't destroy it, the %ksp becomes a separate reference + call PetscObjectReferenceWrapper(ksp, ierr) + else + ! matrices coming from block() can't cache + FLAbort("User wants to cache solver context, but no proper matrix is provided.") + end if + + else if (have_cache) then + + ! ksp is a copy of matrix%ksp, make it a separate reference, + ! so we can KSPDestroy it without destroying matrix%ksp + call PetscObjectReferenceWrapper(ksp, ierr) + + ! same for the matrix, kspgetoperators returns the matrix reference + ! owned by the ksp - make it a separate reference + call PetscObjectReferenceWrapper(A, ierr) + + end if + + b=PetscNumberingCreateVec(petsc_numbering) + call VecDuplicate(b, y, ierr) + + if (timing) then + call cpu_time(time2) + ewrite(2,*) trim(name)// " CPU time spent in PETSc setup: ", time2-time1 + end if + + if(present(sfield)) then + call profiler_toc(sfield, "petsc_setup") + else if(present(vfield)) then + call profiler_toc(vfield, "petsc_setup") + else if(present(tfield)) then + call profiler_toc(tfield, "petsc_setup") + end if + + end subroutine petsc_solve_setup + + subroutine petsc_solve_setup_petsc_csr(y, b, & + solver_option_path, startfromzero, & + matrix, sfield, vfield, tfield, & + option_path, startfromzero_in, & + prolongators,surface_node_list, & + positions, rotation_matrix) !!< sets up things needed to call petsc_solve_core !! Stuff that comes out: !! !! PETSc solution vector -Vec, intent(out):: y + Vec, intent(out):: y !! PETSc rhs vector -Vec, intent(out):: b + Vec, intent(out):: b !! returns the option path to solver/ block for new options, otherwise "" -character(len=*), intent(out):: solver_option_path + character(len=*), intent(out):: solver_option_path !! whether to start with zero initial guess -logical, intent(out):: startfromzero + logical, intent(out):: startfromzero !! Stuff that goes in: !! !! provide either a matrix or block_matrix to be solved -type(petsc_csr_matrix), intent(inout):: matrix + type(petsc_csr_matrix), intent(inout):: matrix !! provide either a scalar field or vector field to be solved for -type(scalar_field), optional, intent(in):: sfield -type(vector_field), optional, intent(in):: vfield -type(tensor_field), optional, intent(in):: tfield + type(scalar_field), optional, intent(in):: sfield + type(vector_field), optional, intent(in):: vfield + type(tensor_field), optional, intent(in):: tfield !! overrides sfield%option_path or vfield%option_path -character(len=*), intent(in), optional:: option_path + character(len=*), intent(in), optional:: option_path !! whether to start with zero initial guess (as passed in) -logical, optional, intent(in):: startfromzero_in + logical, optional, intent(in):: startfromzero_in !! additional info for "mg" preconditioner: !! prolongators to be used at the first levels of 'mg' -type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators + type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators !! Stuff needed for internal smoother -integer, dimension(:), optional, intent(in) :: surface_node_list + integer, dimension(:), optional, intent(in) :: surface_node_list !! positions field is only used with remove_null_space/ or multigrid_near_null_space/ with rotational components -type(vector_field), intent(in), optional :: positions + type(vector_field), intent(in), optional :: positions !! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned -Mat, intent(in), optional:: rotation_matrix - - real time1, time2 - integer ierr - logical parallel, timing - character(len=FIELD_NAME_LEN) :: name - - ! Initialise profiler - if(present(sfield)) then - call profiler_tic(sfield, "petsc_setup") - name = sfield%name - else if(present(vfield)) then - call profiler_tic(vfield, "petsc_setup") - name = vfield%name - else if(present(tfield)) then - call profiler_tic(tfield, "petsc_setup") - name = tfield%name - else - FLAbort("petsc_solve_setup should be called with sfield, vfield or tfield") - end if - - timing=(debug_level()>=2) - if (timing) then - call cpu_time(time1) - end if - - if (present(option_path)) then - solver_option_path=complete_solver_option_path(option_path) - else if (present(sfield)) then - solver_option_path=complete_solver_option_path(sfield%option_path) - else if (present(vfield)) then - solver_option_path=complete_solver_option_path(vfield%option_path) - else if (present(tfield)) then - solver_option_path=complete_solver_option_path(tfield%option_path) - else - FLAbort("Need to provide either sfield, vfield or tfield to petsc_solve_setup.") - end if - - call assemble(matrix) - - call attach_null_space_from_options(matrix%M, solver_option_path, & - positions=positions, rotation_matrix=rotation_matrix, petsc_numbering=matrix%column_numbering) - - startfromzero=have_option(trim(solver_option_path)//'/start_from_zero') - if (present_and_true(startfromzero_in) .and. .not. startfromzero) then - ewrite(2,*) 'Note: startfromzero hard-coded to .true.' - ewrite(2,*) 'Ignoring setting from solver option.' - startfromzero=.true. - end if - - if (IsParallel()) then - parallel= associated(matrix%row_halo) - else - parallel= .false. - end if - - ewrite(2, *) 'Using solver options defined at: ', trim(solver_option_path) - if (matrix%ksp==PETSC_NULL_KSP) then - - call create_ksp_from_options(matrix%ksp, matrix%M, matrix%M, solver_option_path, parallel, & - matrix%column_numbering, & - startfromzero_in=startfromzero_in, & - prolongators=prolongators, surface_node_list=surface_node_list) - else - ewrite(2, *) "Reusing ksp from a previous solve" - call setup_ksp_from_options(matrix%ksp, matrix%M, matrix%M, solver_option_path, & - matrix%column_numbering, & - startfromzero_in=startfromzero_in, & - prolongators=prolongators, surface_node_list=surface_node_list) - end if - - b=PetscNumberingCreateVec(matrix%column_numbering) - call VecDuplicate(b, y, ierr) - - if (timing) then - call cpu_time(time2) - ewrite(2,*) trim(name)// " CPU time spent in PETSc setup: ", time2-time1 - end if - - if(present(sfield)) then - call profiler_toc(sfield, "petsc_setup") - else if(present(vfield)) then - call profiler_toc(vfield, "petsc_setup") - else if(present(tfield)) then - call profiler_toc(tfield, "petsc_setup") - end if - -end subroutine petsc_solve_setup_petsc_csr - -subroutine petsc_solve_copy_vectors_from_scalar_fields(y, b, x, matrix, rhs, petsc_numbering, startfromzero) -Vec, intent(inout):: y, b -type(scalar_field), target, intent(in):: x, rhs -type(csr_matrix), optional, intent(in):: matrix -type(petsc_numbering_type), intent(in):: petsc_numbering -logical, intent(in):: startfromzero - - type(scalar_field):: ghost_rhs, petsc_solve_rhs, tmp_rhs - type(mesh_type), pointer:: mesh - logical, dimension(:), pointer:: inactive_mask - - ewrite(1, *) 'Assembling RHS.' - - call profiler_tic(x, "field2petsc") - if (present(matrix)) then - inactive_mask => get_inactive_mask(matrix) - else - nullify(inactive_mask) - end if - - if (associated(inactive_mask)) then - ! this takes care of the actual lifting of ghost columns, i.e. - ! row that have column indices referring to ghost nodes, need to - ! move their coefficient multiplied with the bc value moved to the rhs - mesh => rhs%mesh - call allocate(ghost_rhs, mesh, name="GhostRHS") - call allocate(petsc_solve_rhs, mesh, name="PetscSolveRHS") - call allocate(tmp_rhs, mesh, name="TempRHS") - - where (inactive_mask) - ghost_rhs%val=rhs%val - elsewhere - ghost_rhs%val=0. - end where + Mat, intent(in), optional:: rotation_matrix + + real time1, time2 + integer ierr + logical parallel, timing + character(len=FIELD_NAME_LEN) :: name + + ! Initialise profiler + if(present(sfield)) then + call profiler_tic(sfield, "petsc_setup") + name = sfield%name + else if(present(vfield)) then + call profiler_tic(vfield, "petsc_setup") + name = vfield%name + else if(present(tfield)) then + call profiler_tic(tfield, "petsc_setup") + name = tfield%name + else + FLAbort("petsc_solve_setup should be called with sfield, vfield or tfield") + end if - ! not all processes that see a ghost node may have the right - ! value set for it. This ensures the owner gets to set the value: - if(associated(matrix%sparsity%column_halo)) call halo_update(matrix%sparsity%column_halo, ghost_rhs) + timing=(debug_level()>=2) + if (timing) then + call cpu_time(time1) + end if - ! tmp_rhs is the rhs contribution of lifting the ghost columns - call mult(tmp_rhs, matrix, ghost_rhs) + if (present(option_path)) then + solver_option_path=complete_solver_option_path(option_path) + else if (present(sfield)) then + solver_option_path=complete_solver_option_path(sfield%option_path) + else if (present(vfield)) then + solver_option_path=complete_solver_option_path(vfield%option_path) + else if (present(tfield)) then + solver_option_path=complete_solver_option_path(tfield%option_path) + else + FLAbort("Need to provide either sfield, vfield or tfield to petsc_solve_setup.") + end if - call set(petsc_solve_rhs, rhs) - call addto(petsc_solve_rhs, tmp_rhs, scale=-1.0) + call assemble(matrix) - ! note that we don't set the rhs value for the ghost rows - ! the right value will be substituted after we return from the solve - call field2petsc(petsc_solve_rhs, petsc_numbering, b) + call attach_null_space_from_options(matrix%M, solver_option_path, & + positions=positions, rotation_matrix=rotation_matrix, petsc_numbering=matrix%column_numbering) - call deallocate(ghost_rhs) - call deallocate(petsc_solve_rhs) - call deallocate(tmp_rhs) + startfromzero=have_option(trim(solver_option_path)//'/start_from_zero') + if (present_and_true(startfromzero_in) .and. .not. startfromzero) then + ewrite(2,*) 'Note: startfromzero hard-coded to .true.' + ewrite(2,*) 'Ignoring setting from solver option.' + startfromzero=.true. + end if - else + if (IsParallel()) then + parallel= associated(matrix%row_halo) + else + parallel= .false. + end if - ! create PETSc vec for rhs using above numbering: - call field2petsc(rhs, petsc_numbering, b) + ewrite(2, *) 'Using solver options defined at: ', trim(solver_option_path) + if (matrix%ksp==PETSC_NULL_KSP) then - end if + call create_ksp_from_options(matrix%ksp, matrix%M, matrix%M, solver_option_path, parallel, & + matrix%column_numbering, & + startfromzero_in=startfromzero_in, & + prolongators=prolongators, surface_node_list=surface_node_list) + else + ewrite(2, *) "Reusing ksp from a previous solve" + call setup_ksp_from_options(matrix%ksp, matrix%M, matrix%M, solver_option_path, & + matrix%column_numbering, & + startfromzero_in=startfromzero_in, & + prolongators=prolongators, surface_node_list=surface_node_list) + end if + + b=PetscNumberingCreateVec(matrix%column_numbering) + call VecDuplicate(b, y, ierr) + + if (timing) then + call cpu_time(time2) + ewrite(2,*) trim(name)// " CPU time spent in PETSc setup: ", time2-time1 + end if + + if(present(sfield)) then + call profiler_toc(sfield, "petsc_setup") + else if(present(vfield)) then + call profiler_toc(vfield, "petsc_setup") + else if(present(tfield)) then + call profiler_toc(tfield, "petsc_setup") + end if + + end subroutine petsc_solve_setup_petsc_csr - ewrite(1, *) 'RHS assembly completed.' + subroutine petsc_solve_copy_vectors_from_scalar_fields(y, b, x, matrix, rhs, petsc_numbering, startfromzero) + Vec, intent(inout):: y, b + type(scalar_field), target, intent(in):: x, rhs + type(csr_matrix), optional, intent(in):: matrix + type(petsc_numbering_type), intent(in):: petsc_numbering + logical, intent(in):: startfromzero - if (.not. startfromzero) then + type(scalar_field):: ghost_rhs, petsc_solve_rhs, tmp_rhs + type(mesh_type), pointer:: mesh + logical, dimension(:), pointer:: inactive_mask - ewrite(1, *) 'Assembling initial guess.' + ewrite(1, *) 'Assembling RHS.' - ! create PETSc vec for initial guess and result using above numbering: - call field2petsc(x, petsc_numbering, y) + call profiler_tic(x, "field2petsc") + if (present(matrix)) then + inactive_mask => get_inactive_mask(matrix) + else + nullify(inactive_mask) + end if + + if (associated(inactive_mask)) then + ! this takes care of the actual lifting of ghost columns, i.e. + ! row that have column indices referring to ghost nodes, need to + ! move their coefficient multiplied with the bc value moved to the rhs + mesh => rhs%mesh + call allocate(ghost_rhs, mesh, name="GhostRHS") + call allocate(petsc_solve_rhs, mesh, name="PetscSolveRHS") + call allocate(tmp_rhs, mesh, name="TempRHS") + + where (inactive_mask) + ghost_rhs%val=rhs%val + elsewhere + ghost_rhs%val=0. + end where - ewrite(1, *) 'Initial guess assembly completed.' + ! not all processes that see a ghost node may have the right + ! value set for it. This ensures the owner gets to set the value: + if(associated(matrix%sparsity%column_halo)) call halo_update(matrix%sparsity%column_halo, ghost_rhs) - end if - call profiler_toc(x, "field2petsc") + ! tmp_rhs is the rhs contribution of lifting the ghost columns + call mult(tmp_rhs, matrix, ghost_rhs) -end subroutine petsc_solve_copy_vectors_from_scalar_fields + call set(petsc_solve_rhs, rhs) + call addto(petsc_solve_rhs, tmp_rhs, scale=-1.0) -subroutine petsc_solve_copy_vectors_from_vector_fields(y, b, x, rhs, petsc_numbering, startfromzero) -Vec, intent(inout):: y, b -type(vector_field), intent(in):: x, rhs -type(petsc_numbering_type), intent(in):: petsc_numbering -logical, intent(in):: startfromzero + ! note that we don't set the rhs value for the ghost rows + ! the right value will be substituted after we return from the solve + call field2petsc(petsc_solve_rhs, petsc_numbering, b) - call profiler_tic(x, "field2petsc") - ewrite(1, *) 'Assembling RHS.' + call deallocate(ghost_rhs) + call deallocate(petsc_solve_rhs) + call deallocate(tmp_rhs) - ! create PETSc vec for rhs using above numbering: - call field2petsc(rhs, petsc_numbering, b) + else + + ! create PETSc vec for rhs using above numbering: + call field2petsc(rhs, petsc_numbering, b) - ewrite(1, *) 'RHS assembly completed.' + end if - if (.not. startfromzero) then + ewrite(1, *) 'RHS assembly completed.' - ewrite(1, *) 'Assembling initial guess.' + if (.not. startfromzero) then - ! create PETSc vec for initial guess and result using above numbering: - call field2petsc(x, petsc_numbering, y) + ewrite(1, *) 'Assembling initial guess.' - ewrite(1, *) 'Initial guess assembly completed.' + ! create PETSc vec for initial guess and result using above numbering: + call field2petsc(x, petsc_numbering, y) - end if - call profiler_toc(x, "field2petsc") + ewrite(1, *) 'Initial guess assembly completed.' -end subroutine petsc_solve_copy_vectors_from_vector_fields + end if + call profiler_toc(x, "field2petsc") -subroutine petsc_solve_core(y, A, b, ksp, petsc_numbering, & - solver_option_path, startfromzero, & - iterations, & - sfield, vfield, tfield, & - x0, vector_x0, checkconvergence, nomatrixdump) + end subroutine petsc_solve_copy_vectors_from_scalar_fields + + subroutine petsc_solve_copy_vectors_from_vector_fields(y, b, x, rhs, petsc_numbering, startfromzero) + Vec, intent(inout):: y, b + type(vector_field), intent(in):: x, rhs + type(petsc_numbering_type), intent(in):: petsc_numbering + logical, intent(in):: startfromzero + + call profiler_tic(x, "field2petsc") + ewrite(1, *) 'Assembling RHS.' + + ! create PETSc vec for rhs using above numbering: + call field2petsc(rhs, petsc_numbering, b) + + ewrite(1, *) 'RHS assembly completed.' + + if (.not. startfromzero) then + + ewrite(1, *) 'Assembling initial guess.' + + ! create PETSc vec for initial guess and result using above numbering: + call field2petsc(x, petsc_numbering, y) + + ewrite(1, *) 'Initial guess assembly completed.' + + end if + call profiler_toc(x, "field2petsc") + + end subroutine petsc_solve_copy_vectors_from_vector_fields + + subroutine petsc_solve_core(y, A, b, ksp, petsc_numbering, & + solver_option_path, startfromzero, & + iterations, & + sfield, vfield, tfield, & + x0, vector_x0, checkconvergence, nomatrixdump) !!< inner core of matrix solve, called by all versions of petsc_solve !! IN: inital guess, OUT: solution -Vec, intent(inout):: y + Vec, intent(inout):: y !! PETSc matrix -Mat, intent(in):: A + Mat, intent(in):: A !! PETSc vector with right hand side of the equation -Vec, intent(in):: b + Vec, intent(in):: b !! solver object -KSP, intent(inout):: ksp + KSP, intent(inout):: ksp !! numbering from local (i.e. fluidity speak: global) to PETSc (fluidity: universal) numbering -type(petsc_numbering_type), intent(in):: petsc_numbering + type(petsc_numbering_type), intent(in):: petsc_numbering !! for new options option path to solver/ block -character(len=*), intent(in):: solver_option_path + character(len=*), intent(in):: solver_option_path !! whether to start with zero initial guess -logical, intent(in):: startfromzero + logical, intent(in):: startfromzero !! returns number of performed iterations -integer, intent(out):: iterations + integer, intent(out):: iterations !! provide either a scalar field or vector field to be solved for !! (only for logging/timing purposes) -type(scalar_field), optional, intent(in):: sfield -type(vector_field), optional, intent(in):: vfield -type(tensor_field), optional, intent(in):: tfield + type(scalar_field), optional, intent(in):: sfield + type(vector_field), optional, intent(in):: vfield + type(tensor_field), optional, intent(in):: tfield !! initial guess (written out in matrixdump after failed solve) -real, dimension(:), optional, intent(in):: x0 + real, dimension(:), optional, intent(in):: x0 !! initial guess (written out in matrixdump after failed solve) in vector_field form -type(vector_field), optional, intent(in):: vector_x0 + type(vector_field), optional, intent(in):: vector_x0 !! whether to check convergence (optional legacy argument to be passed straight on) -logical, optional, intent(in):: checkconvergence + logical, optional, intent(in):: checkconvergence !! logical to prevent dump of matrix equation (full projection solve eqn cannot be dumped): -logical, optional, intent(in):: nomatrixdump - - PetscReal norm - PetscErrorCode ierr - KSPConvergedReason reason - MatNullSpace nullsp - PetscLogDouble flops1, flops2 - Mat mat, pmat - character(len=FIELD_NAME_LEN):: name - logical print_norms, timing - real time1, time2 - - ! Initialise profiler - if(present(sfield)) then - name=sfield%name - call profiler_tic(sfield, "solve") - else if(present(vfield)) then - name=vfield%name - call profiler_tic(vfield, "solve") - else if(present(tfield)) then - name=tfield%name - call profiler_tic(tfield, "solve") - else - FLAbort("petsc_solve_core should be called with sfield, vfield or tfield") - end if - - timing=( debug_level()>=2 ) - - print_norms=have_option(trim(solver_option_path)//'/diagnostics/print_norms') - if (print_norms) then - call VecNorm(b, NORM_2, norm, ierr) - ewrite(2, *) '2-norm of RHS:', norm - call VecNorm(b, NORM_INFINITY, norm, ierr) - ewrite(2, *) 'inf-norm of RHS:', norm - if (startfromzero) then - call VecNorm(y, NORM_2, norm, ierr) - ewrite(2, *) '2-norm of initial guess:', norm - call VecNorm(y, NORM_INFINITY, norm, ierr) - ewrite(2, *) 'inf-norm of initial guess:', norm - end if - call MatNorm(A, NORM_FROBENIUS, norm, ierr) - ewrite(2, *) 'Frobenius norm of matrix:', norm - call MatNorm(A, NORM_INFINITY, norm, ierr) - ewrite(2, *) 'inf-norm of matrix:', norm - end if - - if (timing) then - call cpu_time(time1) - call PetscGetFlops(flops1, ierr) - end if - - ewrite(1, *) 'Entering solver.' - - ! if a null space is defined for the petsc matrix, make sure it's projected out of the rhs - call KSPGetOperators(ksp, mat, pmat, ierr) - call MatGetNullSpace(mat, nullsp, ierr) - if (ierr==0 .and. .not. IsNullMatNullSpace(nullsp)) then - ewrite(2,*) "Projecting nullspace from RHS" - call MatNullSpaceRemove(nullsp, b, ierr) - end if - - call KSPSolve(ksp, b, y, ierr) - call KSPGetConvergedReason(ksp, reason, ierr) - call KSPGetIterationNumber(ksp, iterations, ierr) - - ewrite(1, *) 'Out of solver.' - - if (timing) then - call cpu_time(time2) - call PetscGetFlops(flops2, ierr) - ewrite(2,*) trim(name)// ' CPU time spent in solver: ',time2-time1 - ewrite(2,*) trim(name)// ' MFlops counted by Petsc: ',(flops2-flops1)/1e6 - ewrite(2,*) trim(name)// ' MFlops/sec: ',(flops2-flops1)/((time2-time1)*1e6) - end if - - if(have_option(trim(solver_option_path)//'/diagnostics/dump_matrix')) then - if(present_and_true(nomatrixdump)) then - ewrite(0,*) 'Requested to dump matrix on solve that is hard coded not to' - ewrite(0,*) 'dump matrices. Therefore ignoring the dump_matrix option request.' - else - call dump_matrix_option(solver_option_path, startfromzero, A, b, & - petsc_numbering, & - x0=x0, vector_x0=vector_x0) - end if - end if - - ! Check convergence and give warning+matrixdump if needed. - ! This needs to be done before we copy back the result as - ! x still contains the initial guess to be used in the matrixdump. - call ConvergenceCheck(reason, iterations, name, solver_option_path, & - startfromzero, A, b, petsc_numbering, & - x0=x0, vector_x0=vector_x0, & - checkconvergence=checkconvergence,nomatrixdump=nomatrixdump) - - ewrite(2, "(A, ' PETSc reason of convergence: ', I0)") trim(name), reason - ewrite(2, "(A, ' PETSc n/o iterations: ', I0)") trim(name), iterations - - if (print_norms) then - call VecNorm(y, NORM_2, norm, ierr) - ewrite(2, *) '2-norm of solution:', norm - call VecNorm(y, NORM_INFINITY, norm, ierr) - ewrite(2, *) 'inf-norm of solution:', norm - end if - - if(present(sfield)) then - call profiler_toc(sfield, "solve") - else if(present(vfield)) then - call profiler_toc(vfield, "solve") - else if(present(tfield)) then - call profiler_toc(tfield, "solve") - end if - -end subroutine petsc_solve_core - -subroutine petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & - solver_option_path) -Vec, intent(inout):: y -Mat, intent(inout):: A -Vec, intent(inout):: b -KSP, intent(inout):: ksp -type(petsc_numbering_type), intent(inout):: petsc_numbering -character(len=*), intent(in):: solver_option_path - - PC pc - PCType pctype - integer ierr - - call VecDestroy(y, ierr) - call MatDestroy(A, ierr) - call VecDestroy(b, ierr) - call KSPGetPC(ksp, pc, ierr) - call PCGetType(pc, pctype, ierr) - if (pctype==PCMG) then - call DestroyMultigrid(pc) - end if - call KSPDestroy(ksp, ierr) - - ! destroy everything associated with the monitors - if(have_option(trim(solver_option_path)// & - '/diagnostics/monitors/true_error') .or. & - have_option(trim(solver_option_path)// & - '/diagnostics/monitors/iteration_vtus')) then - ! note we have to check the option itself and not the logicals - ! as we may be in an inner solver, where only the outer solve - ! has the monitor set - call petsc_monitor_destroy() - petsc_monitor_has_exact=.false. - petsc_monitor_iteration_vtus=.false. - end if - ! we could reuse this, but for the moment we don't: - call deallocate(petsc_numbering) - -end subroutine petsc_solve_destroy - -subroutine petsc_solve_destroy_petsc_csr(y, b, solver_option_path) -Vec, intent(inout):: y -Vec, intent(inout):: b -character(len=*), intent(in):: solver_option_path - - integer ierr - - call VecDestroy(y, ierr) - call VecDestroy(b, ierr) - - ! destroy everything associated with the monitors - if(have_option(trim(solver_option_path)// & - '/diagnostics/monitors/true_error') .or. & - have_option(trim(solver_option_path)// & - '/diagnostics/monitors/iteration_vtus')) then - ! note we have to check the option itself and not the logicals - ! as we may be in an inner solver, where only the outer solve - ! has the monitor set - call petsc_monitor_destroy() - petsc_monitor_has_exact=.false. - petsc_monitor_iteration_vtus=.false. - end if - -end subroutine petsc_solve_destroy_petsc_csr - -subroutine ConvergenceCheck(reason, iterations, name, solver_option_path, & - startfromzero, A, b, petsc_numbering, x0, vector_x0, checkconvergence, nomatrixdump) - !!< Checks reason of convergence. If negative (not converged) - !!< writes out a scary warning and dumps matrix (if first time), - !!< and if reason<0 but reason/=-3 - !!< (i.e. not converged due to other reasons than reaching max_its) - !!< it sets sig_int to .true. causing the run to halt and dump - !!< at the end of the time step. - integer, intent(in):: reason, iterations - !! name of the thing we're solving for, used in log output: - character(len=*), intent(in):: name - !! for new options path to solver options - character(len=*), intent(in):: solver_option_path - ! Arguments needed in the matrixdump: - logical, intent(in):: startfromzero - Mat, intent(in):: A - Vec, intent(in):: b - type(petsc_numbering_type), intent(in):: petsc_numbering - ! initial guess to be written in matrixdump (if startfromzero==.false.) - real, optional, dimension(:), intent(in):: x0 - type(vector_field), optional, intent(in):: vector_x0 - !! if present and .false. do not check, otherwise do check - logical, optional, intent(in):: checkconvergence - !! if present do not dump matrix equation: - logical, optional, intent(in):: nomatrixdump - - ! did we dump before? : - logical, save:: matrixdumped=.false. - Vec y0 - PetscErrorCode ierr - character(len=30) reasons(10) - real spin_up_time, current_time - - reasons(1) = "Undefined" - reasons(2) = "KSP_DIVERGED_NULL" - reasons(3) = "KSP_DIVERGED_ITS" - reasons(4) = "KSP_DIVERGED_DTOL" - reasons(5) = "KSP_DIVERGED_BREAKDOWN" - reasons(6) = "KSP_DIVERGED_BREAKDOWN_BICG" - reasons(7) = "KSP_DIVERGED_NONSYMMETRIC" - reasons(8) = "KSP_DIVERGED_INDEFINITE_PC" - reasons(9) = "KSP_DIVERGED_NAN" - reasons(10) = "KSP_DIVERGED_INDEFINITE_MAT" - - if (reason<=0) then - if(present_and_true(nomatrixdump)) matrixdumped = .true. - if (present(checkconvergence)) then - ! checkconvergence==.false. in iterative solver calls that will - ! not always convergence within the allowed n/o iterations - if (.not. checkconvergence .and. reason==-3) return - end if - ! write reason+iterations to STDERR so we never miss it: - ewrite(-1,*) 'WARNING: Failed to converge.' - ewrite(-1,*) "PETSc did not converge for matrix solve of: " // trim(name) - if((reason>=-10) .and. (reason<=-1)) then - ewrite(-1,*) 'Reason for non-convergence: ', reasons(-reason) - else - ewrite(-1,*) 'Reason for non-convergence is undefined: ', reason - endif - ewrite(-1,*) 'Number of iterations: ', iterations - - if (have_option(trim(solver_option_path)//'/ignore_all_solver_failures')) then - ewrite(0,*) 'Specified ignore_all_solver_failures, therefore continuing' - elseif (reason/=-3 .or. have_option(trim(solver_option_path)//'/never_ignore_solver_failures')) then - ewrite(-1,*) "Sending signal to dump and finish" - ! Setting SIGINT in Signal_Vars module will cause dump and crash - sig_int=.true. - elseif (have_option(trim(solver_option_path)//'/allow_non_convergence_during_spinup')) then - call get_option(trim(solver_option_path)//'/allow_non_convergence_during_spin_up/spin_up_time', spin_up_time) - call get_option('/timestepping/current_time', current_time) - ewrite(2,*) 'current time:', current_time - ewrite(2,*) 'spin up time:', spin_up_time - if (current_time=2 ) + + print_norms=have_option(trim(solver_option_path)//'/diagnostics/print_norms') + if (print_norms) then + call VecNorm(b, NORM_2, norm, ierr) + ewrite(2, *) '2-norm of RHS:', norm + call VecNorm(b, NORM_INFINITY, norm, ierr) + ewrite(2, *) 'inf-norm of RHS:', norm + if (startfromzero) then + call VecNorm(y, NORM_2, norm, ierr) + ewrite(2, *) '2-norm of initial guess:', norm + call VecNorm(y, NORM_INFINITY, norm, ierr) + ewrite(2, *) 'inf-norm of initial guess:', norm + end if + call MatNorm(A, NORM_FROBENIUS, norm, ierr) + ewrite(2, *) 'Frobenius norm of matrix:', norm + call MatNorm(A, NORM_INFINITY, norm, ierr) + ewrite(2, *) 'inf-norm of matrix:', norm + end if + + if (timing) then + call cpu_time(time1) + call PetscGetFlops(flops1, ierr) + end if + + ewrite(1, *) 'Entering solver.' + + ! if a null space is defined for the petsc matrix, make sure it's projected out of the rhs + call KSPGetOperators(ksp, mat, pmat, ierr) + call MatGetNullSpace(mat, nullsp, ierr) + if (ierr==0 .and. .not. IsNullMatNullSpace(nullsp)) then + ewrite(2,*) "Projecting nullspace from RHS" + call MatNullSpaceRemove(nullsp, b, ierr) + end if + + call KSPSolve(ksp, b, y, ierr) + call KSPGetConvergedReason(ksp, reason, ierr) + call KSPGetIterationNumber(ksp, iterations, ierr) + + ewrite(1, *) 'Out of solver.' + + if (timing) then + call cpu_time(time2) + call PetscGetFlops(flops2, ierr) + ewrite(2,*) trim(name)// ' CPU time spent in solver: ',time2-time1 + ewrite(2,*) trim(name)// ' MFlops counted by Petsc: ',(flops2-flops1)/1e6 + ewrite(2,*) trim(name)// ' MFlops/sec: ',(flops2-flops1)/((time2-time1)*1e6) + end if + + if(have_option(trim(solver_option_path)//'/diagnostics/dump_matrix')) then + if(present_and_true(nomatrixdump)) then + ewrite(0,*) 'Requested to dump matrix on solve that is hard coded not to' + ewrite(0,*) 'dump matrices. Therefore ignoring the dump_matrix option request.' + else + call dump_matrix_option(solver_option_path, startfromzero, A, b, & + petsc_numbering, & + x0=x0, vector_x0=vector_x0) + end if + end if + + ! Check convergence and give warning+matrixdump if needed. + ! This needs to be done before we copy back the result as + ! x still contains the initial guess to be used in the matrixdump. + call ConvergenceCheck(reason, iterations, name, solver_option_path, & + startfromzero, A, b, petsc_numbering, & + x0=x0, vector_x0=vector_x0, & + checkconvergence=checkconvergence,nomatrixdump=nomatrixdump) + + ewrite(2, "(A, ' PETSc reason of convergence: ', I0)") trim(name), reason + ewrite(2, "(A, ' PETSc n/o iterations: ', I0)") trim(name), iterations + + if (print_norms) then + call VecNorm(y, NORM_2, norm, ierr) + ewrite(2, *) '2-norm of solution:', norm + call VecNorm(y, NORM_INFINITY, norm, ierr) + ewrite(2, *) 'inf-norm of solution:', norm + end if + + if(present(sfield)) then + call profiler_toc(sfield, "solve") + else if(present(vfield)) then + call profiler_toc(vfield, "solve") + else if(present(tfield)) then + call profiler_toc(tfield, "solve") + end if + + end subroutine petsc_solve_core + + subroutine petsc_solve_destroy(y, A, b, ksp, petsc_numbering, & + solver_option_path) + Vec, intent(inout):: y + Mat, intent(inout):: A + Vec, intent(inout):: b + KSP, intent(inout):: ksp + type(petsc_numbering_type), intent(inout):: petsc_numbering + character(len=*), intent(in):: solver_option_path + + PC pc + PCType pctype + integer ierr + + call VecDestroy(y, ierr) + call MatDestroy(A, ierr) + call VecDestroy(b, ierr) + call KSPGetPC(ksp, pc, ierr) + call PCGetType(pc, pctype, ierr) + if (pctype==PCMG) then + call DestroyMultigrid(pc) + end if + call KSPDestroy(ksp, ierr) + + ! destroy everything associated with the monitors + if(have_option(trim(solver_option_path)// & + '/diagnostics/monitors/true_error') .or. & + have_option(trim(solver_option_path)// & + '/diagnostics/monitors/iteration_vtus')) then + ! note we have to check the option itself and not the logicals + ! as we may be in an inner solver, where only the outer solve + ! has the monitor set + call petsc_monitor_destroy() + petsc_monitor_has_exact=.false. + petsc_monitor_iteration_vtus=.false. + end if + ! we could reuse this, but for the moment we don't: + call deallocate(petsc_numbering) + + end subroutine petsc_solve_destroy + + subroutine petsc_solve_destroy_petsc_csr(y, b, solver_option_path) + Vec, intent(inout):: y + Vec, intent(inout):: b + character(len=*), intent(in):: solver_option_path + + integer ierr + + call VecDestroy(y, ierr) + call VecDestroy(b, ierr) + + ! destroy everything associated with the monitors + if(have_option(trim(solver_option_path)// & + '/diagnostics/monitors/true_error') .or. & + have_option(trim(solver_option_path)// & + '/diagnostics/monitors/iteration_vtus')) then + ! note we have to check the option itself and not the logicals + ! as we may be in an inner solver, where only the outer solve + ! has the monitor set + call petsc_monitor_destroy() + petsc_monitor_has_exact=.false. + petsc_monitor_iteration_vtus=.false. + end if + + end subroutine petsc_solve_destroy_petsc_csr + + subroutine ConvergenceCheck(reason, iterations, name, solver_option_path, & + startfromzero, A, b, petsc_numbering, x0, vector_x0, checkconvergence, nomatrixdump) + !!< Checks reason of convergence. If negative (not converged) + !!< writes out a scary warning and dumps matrix (if first time), + !!< and if reason<0 but reason/=-3 + !!< (i.e. not converged due to other reasons than reaching max_its) + !!< it sets sig_int to .true. causing the run to halt and dump + !!< at the end of the time step. + integer, intent(in):: reason, iterations + !! name of the thing we're solving for, used in log output: + character(len=*), intent(in):: name + !! for new options path to solver options + character(len=*), intent(in):: solver_option_path + ! Arguments needed in the matrixdump: + logical, intent(in):: startfromzero + Mat, intent(in):: A + Vec, intent(in):: b + type(petsc_numbering_type), intent(in):: petsc_numbering + ! initial guess to be written in matrixdump (if startfromzero==.false.) + real, optional, dimension(:), intent(in):: x0 + type(vector_field), optional, intent(in):: vector_x0 + !! if present and .false. do not check, otherwise do check + logical, optional, intent(in):: checkconvergence + !! if present do not dump matrix equation: + logical, optional, intent(in):: nomatrixdump + + ! did we dump before? : + logical, save:: matrixdumped=.false. + Vec y0 + PetscErrorCode ierr + character(len=30) reasons(10) + real spin_up_time, current_time + + reasons(1) = "Undefined" + reasons(2) = "KSP_DIVERGED_NULL" + reasons(3) = "KSP_DIVERGED_ITS" + reasons(4) = "KSP_DIVERGED_DTOL" + reasons(5) = "KSP_DIVERGED_BREAKDOWN" + reasons(6) = "KSP_DIVERGED_BREAKDOWN_BICG" + reasons(7) = "KSP_DIVERGED_NONSYMMETRIC" + reasons(8) = "KSP_DIVERGED_INDEFINITE_PC" + reasons(9) = "KSP_DIVERGED_NAN" + reasons(10) = "KSP_DIVERGED_INDEFINITE_MAT" + + if (reason<=0) then + if(present_and_true(nomatrixdump)) matrixdumped = .true. + if (present(checkconvergence)) then + ! checkconvergence==.false. in iterative solver calls that will + ! not always convergence within the allowed n/o iterations + if (.not. checkconvergence .and. reason==-3) return + end if + ! write reason+iterations to STDERR so we never miss it: + ewrite(-1,*) 'WARNING: Failed to converge.' + ewrite(-1,*) "PETSc did not converge for matrix solve of: " // trim(name) + if((reason>=-10) .and. (reason<=-1)) then + ewrite(-1,*) 'Reason for non-convergence: ', reasons(-reason) + else + ewrite(-1,*) 'Reason for non-convergence is undefined: ', reason + endif + ewrite(-1,*) 'Number of iterations: ', iterations + + if (have_option(trim(solver_option_path)//'/ignore_all_solver_failures')) then + ewrite(0,*) 'Specified ignore_all_solver_failures, therefore continuing' + elseif (reason/=-3 .or. have_option(trim(solver_option_path)//'/never_ignore_solver_failures')) then + ewrite(-1,*) "Sending signal to dump and finish" + ! Setting SIGINT in Signal_Vars module will cause dump and crash + sig_int=.true. + elseif (have_option(trim(solver_option_path)//'/allow_non_convergence_during_spinup')) then + call get_option(trim(solver_option_path)//'/allow_non_convergence_during_spin_up/spin_up_time', spin_up_time) + call get_option('/timestepping/current_time', current_time) + ewrite(2,*) 'current time:', current_time + ewrite(2,*) 'spin up time:', spin_up_time + if (current_time= 0) then - call KSPGMRESSetRestart(ksp, lrestart, ierr) - ewrite(2, *) 'restart:', lrestart - end if - end if - - ! set max. iterations and tolerances: - ! ======================================= - call get_option(trim(solver_option_path)//'/relative_error', rtol) - call get_option(trim(solver_option_path)//'/absolute_error', atol, & - default=real(0.0, kind = kind(rtol))) - ! note that if neither is set the solve will never converge - ! needs checking - - ! this may end up in the schema: - dtol=PETSC_DEFAULT_REAL - ! maximum n/o iterations is required, so no default: - call get_option(trim(solver_option_path)//'/max_iterations', max_its) - - ! set this choice as default (maybe overridden by PETSc options below) - call KSPSetTolerances(ksp, rtol, atol, dtol, max_its, ierr) - - if (have_option(trim(solver_option_path)//'/start_from_zero') & - .or. present_and_true(startfromzero_in) .or. ksptype==KSPPREONLY) then - call KSPSetInitialGuessNonzero(ksp, PETSC_FALSE, ierr) - startfromzero=.true. - else - call KSPSetInitialGuessNonzero(ksp, PETSC_TRUE, ierr) - startfromzero=.false. - end if - - - ! Inquire about settings as they may have changed by PETSc options: - call KSPGetTolerances(ksp, rtol, atol, dtol, max_its, ierr) - - ewrite(2, *) 'ksp_max_it, ksp_atol, ksp_rtol, ksp_dtol: ', & - max_its, atol, rtol, dtol - ewrite(2, *) 'startfromzero:', startfromzero - - ! cancel all existing monitors (if reusing the same ksp) - call KSPMonitorCancel(ksp, ierr) - - ! Set up the monitors: - if (have_option(trim(solver_option_path)// & - '/diagnostics/monitors/preconditioned_residual')) then - call PetscViewerAndFormatCreate(PETSC_VIEWER_STDOUT_WORLD, & - PETSC_VIEWER_DEFAULT,vf,ierr) - call KSPMonitorSet(ksp, KSPMonitorResidual, vf, & - PetscViewerAndFormatDestroy, ierr) - end if - if (have_option(trim(solver_option_path)// & - '/diagnostics/monitors/true_residual')) then - call PetscViewerAndFormatCreate(PETSC_VIEWER_STDOUT_WORLD, & - PETSC_VIEWER_DEFAULT,vf,ierr) - call KSPMonitorSet(ksp, KSPMonitorTrueResidual, vf, & - PetscViewerAndFormatDestroy, ierr) - end if - - if (have_option(trim(solver_option_path)// & - '/diagnostics/monitors/true_error') & - .and. .not. petsc_monitor_has_exact) then - ewrite(-1,*) "Solver option diagnostics/monitors/true_error set but " - ewrite(0,*) "petsc_solve_monitor_exact() not called. This probably means" - ewrite(0,*) "this version of petsc_solve() doesn't support the monitor." - FLExit("petsc_solve_monitor_exact() not called") - end if - if (have_option(trim(solver_option_path)// & - '/diagnostics/monitors/iteration_vtus') & - .and. .not. petsc_monitor_iteration_vtus) then - ewrite(0,*) "Solver option diagnostics/monitors/iteration_vtus set but " - ewrite(0,*) "petsc_solve_monitor_iteration_vtus() not called. This probably means" - ewrite(0,*) "this version of petsc_solve() doesn't support the monitor." - FLExit("petsc_solve_monitor_iteration_vtus() not called") - end if - if(have_option(trim(solver_option_path)// & - '/diagnostics/monitors/true_error') .or. & - have_option(trim(solver_option_path)// & - '/diagnostics/monitors/iteration_vtus')) then - if (.not. present(petsc_numbering)) then - FLAbort("Need petsc_numbering for monitor") - end if - call petsc_monitor_setup(petsc_numbering, max_its) - call KSPMonitorSet(ksp, MyKSPMonitor, vf, & - & PETSC_NULL_FUNCTION, ierr) - end if - - end subroutine setup_ksp_from_options - - recursive subroutine attach_null_space_from_options(mat, solver_option_path, pmat, & + if (lrestart >= 0) then + call KSPGMRESSetRestart(ksp, lrestart, ierr) + ewrite(2, *) 'restart:', lrestart + end if + end if + + ! set max. iterations and tolerances: + ! ======================================= + call get_option(trim(solver_option_path)//'/relative_error', rtol) + call get_option(trim(solver_option_path)//'/absolute_error', atol, & + default=real(0.0, kind = kind(rtol))) + ! note that if neither is set the solve will never converge + ! needs checking + + ! this may end up in the schema: + dtol=PETSC_DEFAULT_REAL + ! maximum n/o iterations is required, so no default: + call get_option(trim(solver_option_path)//'/max_iterations', max_its) + + ! set this choice as default (maybe overridden by PETSc options below) + call KSPSetTolerances(ksp, rtol, atol, dtol, max_its, ierr) + + if (have_option(trim(solver_option_path)//'/start_from_zero') & + .or. present_and_true(startfromzero_in) .or. ksptype==KSPPREONLY) then + call KSPSetInitialGuessNonzero(ksp, PETSC_FALSE, ierr) + startfromzero=.true. + else + call KSPSetInitialGuessNonzero(ksp, PETSC_TRUE, ierr) + startfromzero=.false. + end if + + + ! Inquire about settings as they may have changed by PETSc options: + call KSPGetTolerances(ksp, rtol, atol, dtol, max_its, ierr) + + ewrite(2, *) 'ksp_max_it, ksp_atol, ksp_rtol, ksp_dtol: ', & + max_its, atol, rtol, dtol + ewrite(2, *) 'startfromzero:', startfromzero + + ! cancel all existing monitors (if reusing the same ksp) + call KSPMonitorCancel(ksp, ierr) + + ! Set up the monitors: + if (have_option(trim(solver_option_path)// & + '/diagnostics/monitors/preconditioned_residual')) then + call PetscViewerAndFormatCreate(PETSC_VIEWER_STDOUT_WORLD, & + PETSC_VIEWER_DEFAULT,vf,ierr) + call KSPMonitorSet(ksp, KSPMonitorResidual, vf, & + PetscViewerAndFormatDestroy, ierr) + end if + if (have_option(trim(solver_option_path)// & + '/diagnostics/monitors/true_residual')) then + call PetscViewerAndFormatCreate(PETSC_VIEWER_STDOUT_WORLD, & + PETSC_VIEWER_DEFAULT,vf,ierr) + call KSPMonitorSet(ksp, KSPMonitorTrueResidual, vf, & + PetscViewerAndFormatDestroy, ierr) + end if + + if (have_option(trim(solver_option_path)// & + '/diagnostics/monitors/true_error') & + .and. .not. petsc_monitor_has_exact) then + ewrite(-1,*) "Solver option diagnostics/monitors/true_error set but " + ewrite(0,*) "petsc_solve_monitor_exact() not called. This probably means" + ewrite(0,*) "this version of petsc_solve() doesn't support the monitor." + FLExit("petsc_solve_monitor_exact() not called") + end if + if (have_option(trim(solver_option_path)// & + '/diagnostics/monitors/iteration_vtus') & + .and. .not. petsc_monitor_iteration_vtus) then + ewrite(0,*) "Solver option diagnostics/monitors/iteration_vtus set but " + ewrite(0,*) "petsc_solve_monitor_iteration_vtus() not called. This probably means" + ewrite(0,*) "this version of petsc_solve() doesn't support the monitor." + FLExit("petsc_solve_monitor_iteration_vtus() not called") + end if + if(have_option(trim(solver_option_path)// & + '/diagnostics/monitors/true_error') .or. & + have_option(trim(solver_option_path)// & + '/diagnostics/monitors/iteration_vtus')) then + if (.not. present(petsc_numbering)) then + FLAbort("Need petsc_numbering for monitor") + end if + call petsc_monitor_setup(petsc_numbering, max_its) + call KSPMonitorSet(ksp, MyKSPMonitor, vf, & + & PETSC_NULL_FUNCTION, ierr) + end if + + end subroutine setup_ksp_from_options + + recursive subroutine attach_null_space_from_options(mat, solver_option_path, pmat, & positions, rotation_matrix, petsc_numbering) - !!< attach nullspace and multigrid near-nullspace - !!< if specified in solver options - ! Petsc mat to attach nullspace to - Mat, intent(inout):: mat - ! path to solver block (including '/solver') - character(len=*), intent(in):: solver_option_path - ! the pmat (only required if different from mat) - Mat, intent(inout), optional:: pmat - ! positions field is only used for nullspaces with rotational components - type(vector_field), intent(in), optional :: positions - ! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned - Mat, intent(in), optional:: rotation_matrix - type(petsc_numbering_type), optional, intent(in):: petsc_numbering - - MatNullSpace :: null_space - PetscErrorCode :: ierr - logical :: different_pmat - - if (present(pmat)) then - different_pmat = mat/=pmat - else - different_pmat = .false. - end if - - - if(have_option(trim(solver_option_path)//"/multigrid_near_null_space")) then - - ! Check that we are using the gamg preconditioner: - if(.not.(have_option(trim(solver_option_path)//"/preconditioner::gamg"))) then - FLExit("multigrid_near_null_space removal only valid when using gamg preconditioner") - end if - - if (.not. present(petsc_numbering)) then - FLAbort("Need petsc_numbering for multigrid near null space") - end if - null_space = create_null_space_from_options_vector(mat, trim(solver_option_path)//"/multigrid_near_null_space", & - petsc_numbering, positions=positions, rotation_matrix=rotation_matrix) - if (different_pmat) then - ! nns is only used in the preconditioner, so let's attach it to pmat only - call MatSetNearNullSpace(pmat, null_space, ierr) - else - call MatSetNearNullSpace(mat, null_space, ierr) - end if - call MatNullSpaceDestroy(null_space, ierr) - end if - - if (have_option(trim(solver_option_path)//'/remove_null_space')) then - if (.not. present(petsc_numbering)) then - FLAbort("Need petsc_numbering for null space removal") - end if - ewrite(2,*) "Attaching nullspace to matrix" - if (size(petsc_numbering%gnn2unn,2)==1) then - null_space = create_null_space_from_options_scalar(mat, trim(solver_option_path)//"/remove_null_space") - else - null_space = create_null_space_from_options_vector(mat, trim(solver_option_path)//"/remove_null_space", & - petsc_numbering, positions=positions, rotation_matrix=rotation_matrix) - end if - call MatSetNullSpace(mat, null_space, ierr) - call MatNullSpaceDestroy(null_space, ierr) - if (have_option(trim(solver_option_path)//"/preconditioner::ksp/remove_null_space")) then - if (.not. present(pmat)) then - ewrite(-1,*) "For solver options specified at:", trim(solver_option_path) - ewrite(-1,*) "Nullspace options were found under preconditioner::ksp but no" - ewrite(-1,*) "separate preconditioner matrix is available." - FLExit("Cannot use nullspace options under precondtioner::ksp for this solve") - end if - call attach_null_space_from_options(pmat, trim(solver_option_path)//"/preconditioner::ksp", & - positions=positions, rotation_matrix=rotation_matrix, petsc_numbering=petsc_numbering) - end if - end if - - ! Check for nullspace options under the ksp preconditioner (near nullspaces aren't currently allowed in the schema) - if (have_option(trim(solver_option_path)//"/preconditioner::ksp/solver/remove_null_space")) then - if (.not. different_pmat) then - ewrite(-1,*) "For solver options specified at:", trim(solver_option_path) - ewrite(-1,*) "Nullspace options were found under preconditioner::ksp but no" - ewrite(-1,*) "separate preconditioner matrix is available." - FLExit("Cannot use nullspace options under precondtioner::ksp for this solve") - end if - call attach_null_space_from_options(pmat, trim(solver_option_path)//"/preconditioner::ksp", & - positions=positions, rotation_matrix=rotation_matrix, petsc_numbering=petsc_numbering) - end if - - end subroutine attach_null_space_from_options - - recursive subroutine setup_pc_from_options(pc, pmat, option_path, & - petsc_numbering, prolongators, surface_node_list, matrix_csr, & - internal_smoothing_option, is_subpc) - PC, intent(inout):: pc - Mat, intent(in):: pmat - character(len=*), intent(in):: option_path - ! needed for fieldsplit and to be pass down to pcksp: - type(petsc_numbering_type), optional, intent(in):: petsc_numbering - ! additional information for multigrid smoother: - type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators - integer, dimension(:), optional, intent(in) :: surface_node_list - type(csr_matrix), optional, intent(in) :: matrix_csr - integer, optional, intent(in) :: internal_smoothing_option - ! if present and true, don't setup sor and eisenstat as subpc (again) - logical, optional, intent(in) :: is_subpc - - KSP:: subksp - PC:: subpc - MatNullSpace:: nullsp - PCType:: pctype, hypretype - MatSolverType:: matsolvertype - PetscErrorCode:: ierr - integer :: n_local, first_local - - call get_option(trim(option_path)//'/name', pctype) - - if (pctype==PCMG) then - call SetupMultigrid(pc, pmat, ierr, & + !!< attach nullspace and multigrid near-nullspace + !!< if specified in solver options + ! Petsc mat to attach nullspace to + Mat, intent(inout):: mat + ! path to solver block (including '/solver') + character(len=*), intent(in):: solver_option_path + ! the pmat (only required if different from mat) + Mat, intent(inout), optional:: pmat + ! positions field is only used for nullspaces with rotational components + type(vector_field), intent(in), optional :: positions + ! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned + Mat, intent(in), optional:: rotation_matrix + type(petsc_numbering_type), optional, intent(in):: petsc_numbering + + MatNullSpace :: null_space + PetscErrorCode :: ierr + logical :: different_pmat + + if (present(pmat)) then + different_pmat = mat/=pmat + else + different_pmat = .false. + end if + + + if(have_option(trim(solver_option_path)//"/multigrid_near_null_space")) then + + ! Check that we are using the gamg preconditioner: + if(.not.(have_option(trim(solver_option_path)//"/preconditioner::gamg"))) then + FLExit("multigrid_near_null_space removal only valid when using gamg preconditioner") + end if + + if (.not. present(petsc_numbering)) then + FLAbort("Need petsc_numbering for multigrid near null space") + end if + null_space = create_null_space_from_options_vector(mat, trim(solver_option_path)//"/multigrid_near_null_space", & + petsc_numbering, positions=positions, rotation_matrix=rotation_matrix) + if (different_pmat) then + ! nns is only used in the preconditioner, so let's attach it to pmat only + call MatSetNearNullSpace(pmat, null_space, ierr) + else + call MatSetNearNullSpace(mat, null_space, ierr) + end if + call MatNullSpaceDestroy(null_space, ierr) + end if + + if (have_option(trim(solver_option_path)//'/remove_null_space')) then + if (.not. present(petsc_numbering)) then + FLAbort("Need petsc_numbering for null space removal") + end if + ewrite(2,*) "Attaching nullspace to matrix" + if (size(petsc_numbering%gnn2unn,2)==1) then + null_space = create_null_space_from_options_scalar(mat, trim(solver_option_path)//"/remove_null_space") + else + null_space = create_null_space_from_options_vector(mat, trim(solver_option_path)//"/remove_null_space", & + petsc_numbering, positions=positions, rotation_matrix=rotation_matrix) + end if + call MatSetNullSpace(mat, null_space, ierr) + call MatNullSpaceDestroy(null_space, ierr) + if (have_option(trim(solver_option_path)//"/preconditioner::ksp/remove_null_space")) then + if (.not. present(pmat)) then + ewrite(-1,*) "For solver options specified at:", trim(solver_option_path) + ewrite(-1,*) "Nullspace options were found under preconditioner::ksp but no" + ewrite(-1,*) "separate preconditioner matrix is available." + FLExit("Cannot use nullspace options under precondtioner::ksp for this solve") + end if + call attach_null_space_from_options(pmat, trim(solver_option_path)//"/preconditioner::ksp", & + positions=positions, rotation_matrix=rotation_matrix, petsc_numbering=petsc_numbering) + end if + end if + + ! Check for nullspace options under the ksp preconditioner (near nullspaces aren't currently allowed in the schema) + if (have_option(trim(solver_option_path)//"/preconditioner::ksp/solver/remove_null_space")) then + if (.not. different_pmat) then + ewrite(-1,*) "For solver options specified at:", trim(solver_option_path) + ewrite(-1,*) "Nullspace options were found under preconditioner::ksp but no" + ewrite(-1,*) "separate preconditioner matrix is available." + FLExit("Cannot use nullspace options under precondtioner::ksp for this solve") + end if + call attach_null_space_from_options(pmat, trim(solver_option_path)//"/preconditioner::ksp", & + positions=positions, rotation_matrix=rotation_matrix, petsc_numbering=petsc_numbering) + end if + + end subroutine attach_null_space_from_options + + recursive subroutine setup_pc_from_options(pc, pmat, option_path, & + petsc_numbering, prolongators, surface_node_list, matrix_csr, & + internal_smoothing_option, is_subpc) + PC, intent(inout):: pc + Mat, intent(in):: pmat + character(len=*), intent(in):: option_path + ! needed for fieldsplit and to be pass down to pcksp: + type(petsc_numbering_type), optional, intent(in):: petsc_numbering + ! additional information for multigrid smoother: + type(petsc_csr_matrix), dimension(:), optional, intent(in) :: prolongators + integer, dimension(:), optional, intent(in) :: surface_node_list + type(csr_matrix), optional, intent(in) :: matrix_csr + integer, optional, intent(in) :: internal_smoothing_option + ! if present and true, don't setup sor and eisenstat as subpc (again) + logical, optional, intent(in) :: is_subpc + + KSP:: subksp + PC:: subpc + MatNullSpace:: nullsp + PCType:: pctype, hypretype + MatSolverType:: matsolvertype + PetscErrorCode:: ierr + integer :: n_local, first_local + + call get_option(trim(option_path)//'/name', pctype) + + if (pctype==PCMG) then + call SetupMultigrid(pc, pmat, ierr, & external_prolongators=prolongators, & surface_node_list=surface_node_list, & matrix_csr=matrix_csr, & internal_smoothing_option=internal_smoothing_option) - if (ierr/=0) then - if (IsParallel()) then - ! we give up as SOR is probably not good enough either - ! for big paralel problems - ewrite(-1,*) 'Set up of mg preconditioner failed for:' - ewrite(-1,*) trim(option_path) - FLExit("MG failed: try another preconditioner or improve partitioning") + if (ierr/=0) then + if (IsParallel()) then + ! we give up as SOR is probably not good enough either + ! for big paralel problems + ewrite(-1,*) 'Set up of mg preconditioner failed for:' + ewrite(-1,*) trim(option_path) + FLExit("MG failed: try another preconditioner or improve partitioning") + end if + ewrite(0,*) 'Set up of mg preconditioner failed for:' + ewrite(0,*) trim(option_path) + ewrite(0,*) 'choosing "sor" instead for now' + pctype=PCSOR + call PCSetType(pc, pctype, ierr) end if - ewrite(0,*) 'Set up of mg preconditioner failed for:' - ewrite(0,*) trim(option_path) - ewrite(0,*) 'choosing "sor" instead for now' - pctype=PCSOR - call PCSetType(pc, pctype, ierr) - end if - ! set options that may have been supplied via the - ! PETSC_OPTIONS env. variable for the preconditioner - call PCSetFromOptions(pc, ierr) + ! set options that may have been supplied via the + ! PETSC_OPTIONS env. variable for the preconditioner + call PCSetFromOptions(pc, ierr) - else if (pctype=='hypre') then + else if (pctype=='hypre') then #ifdef HAVE_HYPRE - call PCSetType(pc, pctype, ierr) - call get_option(trim(option_path)//'/hypre_type[0]/name', & - hypretype) - call PCHYPRESetType(pc, hypretype, ierr) + call PCSetType(pc, pctype, ierr) + call get_option(trim(option_path)//'/hypre_type[0]/name', & + hypretype) + call PCHYPRESetType(pc, hypretype, ierr) #else - ewrite(0,*) 'In solver option:', option_path - FLExit("The fluidity binary is built without hypre support!") + ewrite(0,*) 'In solver option:', option_path + FLExit("The fluidity binary is built without hypre support!") #endif - else if (pctype==PCKSP) then + else if (pctype==PCKSP) then - ! this replaces the preconditioner by a complete solve - ! (based on the pmat matrix) - call PCSetType(pc, pctype, ierr) + ! this replaces the preconditioner by a complete solve + ! (based on the pmat matrix) + call PCSetType(pc, pctype, ierr) - ! set the options for the ksp of this complete solve - call PCKSPGetKSP(pc, subksp, ierr) - ewrite(1,*) "Going into setup_ksp_from_options again to set the options "//& - &"for the complete ksp solve of the preconditioner" - call KSPSetOperators(subksp, pmat, pmat, ierr) - call setup_ksp_from_options(subksp, pmat, pmat, & - trim(option_path)//'/solver', petsc_numbering=petsc_numbering) - ewrite(1,*) "Returned from setup_ksp_from_options for the preconditioner solve, "//& - &"now setting options for the outer solve" + ! set the options for the ksp of this complete solve + call PCKSPGetKSP(pc, subksp, ierr) + ewrite(1,*) "Going into setup_ksp_from_options again to set the options "//& + &"for the complete ksp solve of the preconditioner" + call KSPSetOperators(subksp, pmat, pmat, ierr) + call setup_ksp_from_options(subksp, pmat, pmat, & + trim(option_path)//'/solver', petsc_numbering=petsc_numbering) + ewrite(1,*) "Returned from setup_ksp_from_options for the preconditioner solve, "//& + &"now setting options for the outer solve" - else if (pctype==PCASM .or. pctype==PCBJACOBI) then + else if (pctype==PCASM .or. pctype==PCBJACOBI) then - call PCSetType(pc, pctype, ierr) - ! need to call this before the subpc can be retrieved: - call PCSetup(pc, ierr) + call PCSetType(pc, pctype, ierr) + ! need to call this before the subpc can be retrieved: + call PCSetup(pc, ierr) + + if (pctype==PCBJACOBI) then + call PCBJACOBIGetSubKSP(pc, n_local, first_local, subksp, ierr) + else + call PCASMGetSubKSP(pc, n_local, first_local, subksp, ierr) + end if + + call KSPGetPC(subksp, subpc, ierr) + ! recursively call to setup the subpc + ewrite(2,*) "Going into setup_pc_from_options for the subpc within the local domain." + call setup_pc_from_options(subpc, pmat, & + trim(option_path)//'/preconditioner[0]', & + petsc_numbering=petsc_numbering, & + prolongators=prolongators, surface_node_list=surface_node_list, & + matrix_csr=matrix_csr, internal_smoothing_option=internal_smoothing_option, & + is_subpc=.true.) + ewrite(2,*) "Finished setting up subpc." + + else if (IsParallel() .and. (pctype==PCSOR .or. & + pctype==PCEISENSTAT) .and. .not. present_and_true(is_subpc)) then + + ! in parallel set sor and eisenstat up in combination with pcbjacobi + ewrite(2,*) "In parallel sor and eisenstat are setup as bjacobi with& + & sor/eisenstat as subpc in the local domain." + call PCSetType(pc, PCBJACOBI, ierr) + ! need to call this before the subpc can be retrieved: + call PCSetup(pc, ierr) + call PCBJACOBIGetSubKSP(pc, n_local, first_local, subksp, ierr) + call KSPGetPC(subksp, subpc, ierr) + call PCSetType(subpc, pctype, ierr) + + else if (pctype==PCFIELDSPLIT) then + + if (.not. present(petsc_numbering)) then + FLAbort("Need to pass down petsc numbering to set up fieldsplit") + end if + + call setup_fieldsplit_preconditioner(pc, option_path, & + petsc_numbering=petsc_numbering) - if (pctype==PCBJACOBI) then - call PCBJACOBIGetSubKSP(pc, n_local, first_local, subksp, ierr) else - call PCASMGetSubKSP(pc, n_local, first_local, subksp, ierr) + + ! this doesn't work for hypre + call PCSetType(pc, pctype, ierr) + ! set options that may have been supplied via the + ! PETSC_OPTIONS env. variable for the preconditioner + call PCSetFromOptions(pc, ierr) + ! set pctype again to enforce flml choice + call PCSetType(pc, pctype, ierr) + + if (pctype==PCLU) then + call get_option(trim(option_path)//'/factorization_package/name', matsolvertype) + call PCFactorSetMatSolverType(pc, matsolvertype, ierr) + end if + + if (pctype==PCGAMG) then + ! we think this is a more useful default - the default value of 0.0 + ! causes spurious "unsymmetric" failures as well + + ! From petsc v3.8: the threshold can be set at each level, levels that + ! are left unspecified are scaled by a factor level-by-level + ! I believe the following leads to the same default we were using previously: + ! 0.01 is set at level 1 only, and a scaling of 1.0 (i.e. no scaling) is applied + ! so that other levels get the same threshold value + call PCGAMGSetThresholdScale(pc, 1.0, ierr) + call PCGAMGSetThreshold(pc, (/ 0.01/), 1, ierr) + + ! this was the old default: + call PCGAMGSetCoarseEqLim(pc, 800, ierr) + ! PC setup seems to be required so that the Coarse Eq Lim option is used. + call PCSetup(pc,ierr) + + call MatGetNullSpace(pmat, nullsp, ierr) + if (ierr==0 .and. .not. IsNullMatNullSpace(nullsp)) then + ! if the preconditioner matrix has a nullspace, this may still be present + ! at the coarsest level (the constant null vector always will be, the rotational + ! are as well if a near-null-space is provided). In this case the default of + ! using a direct solver at the coarsest level causes issues. Instead we use + ! a fixed number of SOR iterations + call PCMGGETCoarseSolve(pc, subksp, ierr) + call KSPSetType(subksp, KSPPREONLY, ierr) + call KSPGetPC(subksp, subpc, ierr) + call PCSetType(subpc, PCSOR, ierr) + call KSPSetTolerances(subksp, 1e-50, 1e-50, 1e50, 10, ierr) + end if + end if + end if - call KSPGetPC(subksp, subpc, ierr) - ! recursively call to setup the subpc - ewrite(2,*) "Going into setup_pc_from_options for the subpc within the local domain." - call setup_pc_from_options(subpc, pmat, & - trim(option_path)//'/preconditioner[0]', & - petsc_numbering=petsc_numbering, & - prolongators=prolongators, surface_node_list=surface_node_list, & - matrix_csr=matrix_csr, internal_smoothing_option=internal_smoothing_option, & - is_subpc=.true.) - ewrite(2,*) "Finished setting up subpc." - - else if (IsParallel() .and. (pctype==PCSOR .or. & - pctype==PCEISENSTAT) .and. .not. present_and_true(is_subpc)) then - - ! in parallel set sor and eisenstat up in combination with pcbjacobi - ewrite(2,*) "In parallel sor and eisenstat are setup as bjacobi with& - & sor/eisenstat as subpc in the local domain." - call PCSetType(pc, PCBJACOBI, ierr) - ! need to call this before the subpc can be retrieved: - call PCSetup(pc, ierr) - call PCBJACOBIGetSubKSP(pc, n_local, first_local, subksp, ierr) - call KSPGetPC(subksp, subpc, ierr) - call PCSetType(subpc, pctype, ierr) - - else if (pctype==PCFIELDSPLIT) then - - if (.not. present(petsc_numbering)) then - FLAbort("Need to pass down petsc numbering to set up fieldsplit") - end if - - call setup_fieldsplit_preconditioner(pc, option_path, & - petsc_numbering=petsc_numbering) + ewrite(2, *) 'pc_type: ', trim(pctype) + if (pctype=='hypre') then + ewrite(2,*) 'pc_hypre_type:', trim(hypretype) + end if + + end subroutine setup_pc_from_options + + recursive subroutine setup_fieldsplit_preconditioner(pc, option_path, & + petsc_numbering) + PC, intent(inout):: pc + character(len=*), intent(in):: option_path + type(petsc_numbering_type), intent(in):: petsc_numbering + + character(len=128):: fieldsplit_type + KSP, dimension(size(petsc_numbering%gnn2unn,2)):: subksps + Mat :: mat, pmat + MatNullSpace :: null_space + IS:: index_set + PetscErrorCode:: ierr + integer:: i, n + + call PCSetType(pc, "fieldsplit", ierr) + + call PCFieldSplitGetSubKSP(pc, n, subksps, ierr) + if (n==0) then + ! first time this pc set to type fieldplit: it's the first time we set it up, + ! or it was previously set to a different type - in this case, PCSetType will + ! have called PCCreate_FieldSplit which will have set n/o splits to zero + do i=1, size(subksps) + index_set = petsc_numbering_create_is(petsc_numbering, dim=i) + call PCFieldSplitSetIS(pc, PETSC_NULL_CHARACTER, index_set, ierr) + call ISDestroy(index_set, ierr) + end do + + elseif (n/=size(subksps)) then + + ! if this pc is reused (and we've previously already set it up with fieldsplit) + ! we need to check the n/o fieldsplits is the same + + FLAbort("PC being reused with different number of fieldsplits") + + end if + + call get_option(trim(option_path)//"/fieldsplit_type/name", & + fieldsplit_type, ierr) + select case (fieldsplit_type) + case ("multiplicative") + call pcfieldsplitsettype(pc, PC_COMPOSITE_MULTIPLICATIVE, ierr) + case ("additive") + call pcfieldsplitsettype(pc, PC_COMPOSITE_ADDITIVE, ierr) + case ("symmetric_multiplicative") + call pcfieldsplitsettype(pc, PC_COMPOSITE_SYMMETRIC_MULTIPLICATIVE, ierr) + case default + FLAbort("Unknown fieldsplit_type") + end select + + call pcfieldsplitgetsubksp(pc, n, subksps, ierr) + + assert(n==size(subksps)) - else - - ! this doesn't work for hypre - call PCSetType(pc, pctype, ierr) - ! set options that may have been supplied via the - ! PETSC_OPTIONS env. variable for the preconditioner - call PCSetFromOptions(pc, ierr) - ! set pctype again to enforce flml choice - call PCSetType(pc, pctype, ierr) - - if (pctype==PCLU) then - call get_option(trim(option_path)//'/factorization_package/name', matsolvertype) - call PCFactorSetMatSolverType(pc, matsolvertype, ierr) - end if - - if (pctype==PCGAMG) then - ! we think this is a more useful default - the default value of 0.0 - ! causes spurious "unsymmetric" failures as well - - ! From petsc v3.8: the threshold can be set at each level, levels that - ! are left unspecified are scaled by a factor level-by-level - ! I believe the following leads to the same default we were using previously: - ! 0.01 is set at level 1 only, and a scaling of 1.0 (i.e. no scaling) is applied - ! so that other levels get the same threshold value - call PCGAMGSetThresholdScale(pc, 1.0, ierr) - call PCGAMGSetThreshold(pc, (/ 0.01/), 1, ierr) - - ! this was the old default: - call PCGAMGSetCoarseEqLim(pc, 800, ierr) - ! PC setup seems to be required so that the Coarse Eq Lim option is used. - call PCSetup(pc,ierr) - - call MatGetNullSpace(pmat, nullsp, ierr) - if (ierr==0 .and. .not. IsNullMatNullSpace(nullsp)) then - ! if the preconditioner matrix has a nullspace, this may still be present - ! at the coarsest level (the constant null vector always will be, the rotational - ! are as well if a near-null-space is provided). In this case the default of - ! using a direct solver at the coarsest level causes issues. Instead we use - ! a fixed number of SOR iterations - call PCMGGETCoarseSolve(pc, subksp, ierr) - call KSPSetType(subksp, KSPPREONLY, ierr) - call KSPGetPC(subksp, subpc, ierr) - call PCSetType(subpc, PCSOR, ierr) - call KSPSetTolerances(subksp, 1e-50, 1e-50, 1e50, 10, ierr) - end if - end if - - end if - - ewrite(2, *) 'pc_type: ', trim(pctype) - if (pctype=='hypre') then - ewrite(2,*) 'pc_hypre_type:', trim(hypretype) - end if - - end subroutine setup_pc_from_options - - recursive subroutine setup_fieldsplit_preconditioner(pc, option_path, & - petsc_numbering) - PC, intent(inout):: pc - character(len=*), intent(in):: option_path - type(petsc_numbering_type), intent(in):: petsc_numbering - - character(len=128):: fieldsplit_type - KSP, dimension(size(petsc_numbering%gnn2unn,2)):: subksps - Mat :: mat, pmat - MatNullSpace :: null_space - IS:: index_set - PetscErrorCode:: ierr - integer:: i, n - - call PCSetType(pc, "fieldsplit", ierr) - - call PCFieldSplitGetSubKSP(pc, n, subksps, ierr) - if (n==0) then - ! first time this pc set to type fieldplit: it's the first time we set it up, - ! or it was previously set to a different type - in this case, PCSetType will - ! have called PCCreate_FieldSplit which will have set n/o splits to zero do i=1, size(subksps) - index_set = petsc_numbering_create_is(petsc_numbering, dim=i) - call PCFieldSplitSetIS(pc, PETSC_NULL_CHARACTER, index_set, ierr) - call ISDestroy(index_set, ierr) + + call KSPGetOperators(subksps(i), mat, pmat, ierr) + if (have_option(trim(option_path)//"/remove_null_space")) then + null_space = create_null_space_from_options_scalar(mat, trim(option_path)//"/remove_null_space") + call MatSetNullSpace(mat, null_space, ierr) + call MatNullSpaceDestroy(null_space, ierr) + end if + call setup_ksp_from_options(subksps(i), mat, pmat, option_path) + end do - elseif (n/=size(subksps)) then + end subroutine setup_fieldsplit_preconditioner + + subroutine ewrite_ksp_options(ksp) + KSP, intent(in):: ksp + + PC:: pc + KSPType:: ksptype + PCType:: pctype + PetscReal:: rtol, atol, dtol + PetscInt:: maxits + PetscBool:: flag + PetscErrorCode:: ierr + + ewrite(2, *) 'Using solver options from cache:' + + call KSPGetType(ksp, ksptype, ierr) + ewrite(2, *) 'ksp_type: ', trim(ksptype) + + call KSPGetPC(ksp, pc, ierr) + call PCGetType(pc, pctype, ierr) + ewrite(2, *) 'pc_type: ', trim(pctype) + + call KSPGetTolerances(ksp, rtol, atol, dtol, maxits, ierr) + ewrite(2, *) 'ksp_max_it, ksp_atol, ksp_rtol, ksp_dtol: ', & + maxits, atol, rtol, dtol + + call KSPGetInitialGuessNonzero(ksp, flag, ierr) + ewrite(2, *) 'startfromzero:', .not. flag + + end subroutine ewrite_ksp_options + + subroutine set_solver_options_with_path(field_option_path, & + ksptype, pctype, atol, rtol, max_its, & + start_from_zero, petsc_options) + character(len=*), intent(in):: field_option_path + character(len=*), optional, intent(in):: ksptype + character(len=*), optional, intent(in):: pctype + real, optional, intent(in):: rtol, atol + integer, optional, intent(in):: max_its + logical, optional, intent(in):: start_from_zero + character(len=*), optional, intent(in):: petsc_options + + character(len=OPTION_PATH_LEN):: option_path + integer:: stat + + ! set the various options if supplied + ! otherwise set a sensible default + if (have_option(trim(field_option_path)//'/solver')) then + option_path=trim(field_option_path)//'/solver' + else if (have_option(trim(field_option_path)//'/prognostic/solver')) then + option_path=trim(field_option_path)//'/prognostic/solver' + else + option_path=trim(field_option_path)//'/solver' + call add_option(option_path, stat=stat) + end if + + if (present(ksptype)) then + call add_option(trim(option_path)//'/iterative_method::'//trim(ksptype), stat=stat) + else + call add_option(trim(option_path)//'/iterative_method::'//trim(KSPGMRES), stat=stat) + endif + + if (present(pctype)) then + call add_option(trim(option_path)//'/preconditioner::'//trim(pctype), stat=stat) + else + call add_option(trim(option_path)//'/preconditioner::'//trim(PCSOR), stat=stat) + endif + + if (present(rtol)) then + call set_option(trim(option_path)//'/relative_error', rtol, stat=stat) + else + call set_option(trim(option_path)//'/relative_error', 1.0e-7, stat=stat) + end if + + if (present(atol)) then + call set_option(trim(option_path)//'/absolute_error', atol, stat=stat) + end if + + if (present(max_its)) then + call set_option(trim(option_path)//'/max_iterations', max_its, stat=stat) + else + call set_option(trim(option_path)//'/max_iterations', 10000, stat=stat) + end if + + if (present(start_from_zero)) then + if (start_from_zero) then + call add_option(trim(option_path)//'/start_from_zero', stat=stat) + end if + end if + + if (present(petsc_options)) then + call set_option(trim(option_path)//'/petsc_options', petsc_options, stat=stat) + end if + + end subroutine set_solver_options_with_path + + subroutine set_solver_options_scalar(field, & + ksptype, pctype, atol, rtol, max_its, & + start_from_zero, petsc_options) + type(scalar_field), intent(inout):: field + character(len=*), optional, intent(in):: ksptype + character(len=*), optional, intent(in):: pctype + real, optional, intent(in):: rtol, atol + integer, optional, intent(in):: max_its + logical, optional, intent(in):: start_from_zero + character(len=*), optional, intent(in):: petsc_options + + integer:: stat + + if (field%option_path=="") then + if (field%name=="") then + FLAbort("In set_solver_options: if no option_path is supplied a field name is required.") + end if + call add_option("/solver_options/", stat=stat) + field%option_path="/solver_options/scalar_field::"//trim(field%name) + call add_option(field%option_path, stat=stat) + end if + + call set_solver_options_with_path(field%option_path, & + ksptype=ksptype, pctype=pctype, atol=atol, rtol=rtol, max_its=max_its, & + start_from_zero=start_from_zero, petsc_options=petsc_options) + + end subroutine set_solver_options_scalar + + subroutine set_solver_options_vector(field, & + ksptype, pctype, atol, rtol, max_its, & + start_from_zero, petsc_options) + type(vector_field), intent(inout):: field + character(len=*), optional, intent(in):: ksptype + character(len=*), optional, intent(in):: pctype + real, optional, intent(in):: rtol, atol + integer, optional, intent(in):: max_its + logical, optional, intent(in):: start_from_zero + character(len=*), optional, intent(in):: petsc_options + + integer:: stat + + if (field%option_path=="") then + if (field%name=="") then + FLAbort("In set_solver_options: if no option_path is supplied a field name is required.") + end if + call add_option("/solver_options/", stat=stat) + field%option_path="/solver_options/vector_field::"//trim(field%name) + call add_option(field%option_path, stat=stat) + + end if + + call set_solver_options_with_path(field%option_path, & + ksptype=ksptype, pctype=pctype, atol=atol, rtol=rtol, max_its=max_its, & + start_from_zero=start_from_zero, petsc_options=petsc_options) + + end subroutine set_solver_options_vector + + subroutine set_solver_options_tensor(field, & + ksptype, pctype, atol, rtol, max_its, & + start_from_zero, petsc_options) + type(tensor_field), intent(inout):: field + character(len=*), optional, intent(in):: ksptype + character(len=*), optional, intent(in):: pctype + real, optional, intent(in):: rtol, atol + integer, optional, intent(in):: max_its + logical, optional, intent(in):: start_from_zero + character(len=*), optional, intent(in):: petsc_options + + integer:: stat + + if (field%option_path=="") then + if (field%name=="") then + FLAbort("In set_solver_options: if no option_path is supplied a field name is required.") + end if + call add_option("/solver_options/", stat=stat) + field%option_path="/solver_options/vector_field::"//trim(field%name) + call add_option(field%option_path, stat=stat) + end if - ! if this pc is reused (and we've previously already set it up with fieldsplit) - ! we need to check the n/o fieldsplits is the same - - FLAbort("PC being reused with different number of fieldsplits") - - end if - - call get_option(trim(option_path)//"/fieldsplit_type/name", & - fieldsplit_type, ierr) - select case (fieldsplit_type) - case ("multiplicative") - call pcfieldsplitsettype(pc, PC_COMPOSITE_MULTIPLICATIVE, ierr) - case ("additive") - call pcfieldsplitsettype(pc, PC_COMPOSITE_ADDITIVE, ierr) - case ("symmetric_multiplicative") - call pcfieldsplitsettype(pc, PC_COMPOSITE_SYMMETRIC_MULTIPLICATIVE, ierr) - case default - FLAbort("Unknown fieldsplit_type") - end select - - call pcfieldsplitgetsubksp(pc, n, subksps, ierr) - - assert(n==size(subksps)) - - do i=1, size(subksps) - - call KSPGetOperators(subksps(i), mat, pmat, ierr) - if (have_option(trim(option_path)//"/remove_null_space")) then - null_space = create_null_space_from_options_scalar(mat, trim(option_path)//"/remove_null_space") - call MatSetNullSpace(mat, null_space, ierr) - call MatNullSpaceDestroy(null_space, ierr) - end if - call setup_ksp_from_options(subksps(i), mat, pmat, option_path) - - end do - - end subroutine setup_fieldsplit_preconditioner - - subroutine ewrite_ksp_options(ksp) - KSP, intent(in):: ksp - - PC:: pc - KSPType:: ksptype - PCType:: pctype - PetscReal:: rtol, atol, dtol - PetscInt:: maxits - PetscBool:: flag - PetscErrorCode:: ierr - - ewrite(2, *) 'Using solver options from cache:' - - call KSPGetType(ksp, ksptype, ierr) - ewrite(2, *) 'ksp_type: ', trim(ksptype) - - call KSPGetPC(ksp, pc, ierr) - call PCGetType(pc, pctype, ierr) - ewrite(2, *) 'pc_type: ', trim(pctype) - - call KSPGetTolerances(ksp, rtol, atol, dtol, maxits, ierr) - ewrite(2, *) 'ksp_max_it, ksp_atol, ksp_rtol, ksp_dtol: ', & - maxits, atol, rtol, dtol - - call KSPGetInitialGuessNonzero(ksp, flag, ierr) - ewrite(2, *) 'startfromzero:', .not. flag - - end subroutine ewrite_ksp_options - - subroutine set_solver_options_with_path(field_option_path, & - ksptype, pctype, atol, rtol, max_its, & - start_from_zero, petsc_options) - character(len=*), intent(in):: field_option_path - character(len=*), optional, intent(in):: ksptype - character(len=*), optional, intent(in):: pctype - real, optional, intent(in):: rtol, atol - integer, optional, intent(in):: max_its - logical, optional, intent(in):: start_from_zero - character(len=*), optional, intent(in):: petsc_options - - character(len=OPTION_PATH_LEN):: option_path - integer:: stat - - ! set the various options if supplied - ! otherwise set a sensible default - if (have_option(trim(field_option_path)//'/solver')) then - option_path=trim(field_option_path)//'/solver' - else if (have_option(trim(field_option_path)//'/prognostic/solver')) then - option_path=trim(field_option_path)//'/prognostic/solver' - else - option_path=trim(field_option_path)//'/solver' - call add_option(option_path, stat=stat) - end if - - if (present(ksptype)) then - call add_option(trim(option_path)//'/iterative_method::'//trim(ksptype), stat=stat) - else - call add_option(trim(option_path)//'/iterative_method::'//trim(KSPGMRES), stat=stat) - endif - - if (present(pctype)) then - call add_option(trim(option_path)//'/preconditioner::'//trim(pctype), stat=stat) - else - call add_option(trim(option_path)//'/preconditioner::'//trim(PCSOR), stat=stat) - endif - - if (present(rtol)) then - call set_option(trim(option_path)//'/relative_error', rtol, stat=stat) - else - call set_option(trim(option_path)//'/relative_error', 1.0e-7, stat=stat) - end if - - if (present(atol)) then - call set_option(trim(option_path)//'/absolute_error', atol, stat=stat) - end if - - if (present(max_its)) then - call set_option(trim(option_path)//'/max_iterations', max_its, stat=stat) - else - call set_option(trim(option_path)//'/max_iterations', 10000, stat=stat) - end if - - if (present(start_from_zero)) then - if (start_from_zero) then - call add_option(trim(option_path)//'/start_from_zero', stat=stat) - end if - end if - - if (present(petsc_options)) then - call set_option(trim(option_path)//'/petsc_options', petsc_options, stat=stat) - end if - -end subroutine set_solver_options_with_path - -subroutine set_solver_options_scalar(field, & - ksptype, pctype, atol, rtol, max_its, & - start_from_zero, petsc_options) - type(scalar_field), intent(inout):: field - character(len=*), optional, intent(in):: ksptype - character(len=*), optional, intent(in):: pctype - real, optional, intent(in):: rtol, atol - integer, optional, intent(in):: max_its - logical, optional, intent(in):: start_from_zero - character(len=*), optional, intent(in):: petsc_options - - integer:: stat - - if (field%option_path=="") then - if (field%name=="") then - FLAbort("In set_solver_options: if no option_path is supplied a field name is required.") - end if - call add_option("/solver_options/", stat=stat) - field%option_path="/solver_options/scalar_field::"//trim(field%name) - call add_option(field%option_path, stat=stat) - end if - - call set_solver_options_with_path(field%option_path, & - ksptype=ksptype, pctype=pctype, atol=atol, rtol=rtol, max_its=max_its, & - start_from_zero=start_from_zero, petsc_options=petsc_options) - -end subroutine set_solver_options_scalar - -subroutine set_solver_options_vector(field, & - ksptype, pctype, atol, rtol, max_its, & - start_from_zero, petsc_options) - type(vector_field), intent(inout):: field - character(len=*), optional, intent(in):: ksptype - character(len=*), optional, intent(in):: pctype - real, optional, intent(in):: rtol, atol - integer, optional, intent(in):: max_its - logical, optional, intent(in):: start_from_zero - character(len=*), optional, intent(in):: petsc_options - - integer:: stat - - if (field%option_path=="") then - if (field%name=="") then - FLAbort("In set_solver_options: if no option_path is supplied a field name is required.") - end if - call add_option("/solver_options/", stat=stat) - field%option_path="/solver_options/vector_field::"//trim(field%name) - call add_option(field%option_path, stat=stat) - - end if - - call set_solver_options_with_path(field%option_path, & - ksptype=ksptype, pctype=pctype, atol=atol, rtol=rtol, max_its=max_its, & - start_from_zero=start_from_zero, petsc_options=petsc_options) - -end subroutine set_solver_options_vector - -subroutine set_solver_options_tensor(field, & - ksptype, pctype, atol, rtol, max_its, & - start_from_zero, petsc_options) - type(tensor_field), intent(inout):: field - character(len=*), optional, intent(in):: ksptype - character(len=*), optional, intent(in):: pctype - real, optional, intent(in):: rtol, atol - integer, optional, intent(in):: max_its - logical, optional, intent(in):: start_from_zero - character(len=*), optional, intent(in):: petsc_options - - integer:: stat - - if (field%option_path=="") then - if (field%name=="") then - FLAbort("In set_solver_options: if no option_path is supplied a field name is required.") - end if - call add_option("/solver_options/", stat=stat) - field%option_path="/solver_options/vector_field::"//trim(field%name) - call add_option(field%option_path, stat=stat) - end if - - call set_solver_options_with_path(field%option_path, & - ksptype=ksptype, pctype=pctype, atol=atol, rtol=rtol, max_its=max_its, & - start_from_zero=start_from_zero, petsc_options=petsc_options) - -end subroutine set_solver_options_tensor - -subroutine petsc_monitor_setup(petsc_numbering, max_its) - ! sets up the petsc monitors "exact" or "iteration_vtus" - type(petsc_numbering_type), intent(in):: petsc_numbering - integer, intent(in) :: max_its - - type(mesh_type), pointer:: mesh - integer :: ierr, ncomponents - - petsc_monitor_x=PetscNumberingCreateVec(petsc_numbering) - petsc_monitor_numbering=petsc_numbering - ncomponents=size(petsc_numbering%gnn2unn,2) - - if (petsc_monitor_has_exact) then - - call VecDuplicate(petsc_monitor_x, petsc_monitor_exact, ierr) - - if (ncomponents==1) then - call field2petsc(petsc_monitor_exact_sfield, petsc_numbering, petsc_monitor_exact) - else - call field2petsc(petsc_monitor_exact_vfield, petsc_numbering, petsc_monitor_exact) - end if - - allocate( petsc_monitor_error(max_its+1) ) - allocate( petsc_monitor_flops(max_its+1) ) - petsc_monitor_error = 0.0 - petsc_monitor_flops = 0.0 - petsc_monitor_iteration=0 - - end if - - if (petsc_monitor_iteration_vtus) then - mesh => petsc_monitor_positions%mesh - if (ncomponents==1) then - call allocate(petsc_monitor_sfields(1), mesh, name="X") - call allocate(petsc_monitor_sfields(2), mesh, name="Residual") - call allocate(petsc_monitor_sfields(3), mesh, name="PreconditionedResidual") - else - call allocate(petsc_monitor_vfields(1), ncomponents, mesh, name="X") - call allocate(petsc_monitor_vfields(2), ncomponents, mesh, name="Residual") - call allocate(petsc_monitor_vfields(3), ncomponents, mesh, name="PreconditionedResidual") - end if - petsc_monitor_vtu_name="petsc_monitor_"//int2str(petsc_monitor_vtu_series) - petsc_monitor_vtu_series=petsc_monitor_vtu_series+1 - end if - -end subroutine petsc_monitor_setup - -subroutine petsc_solve_monitor_exact_scalar(exact, error_filename) + call set_solver_options_with_path(field%option_path, & + ksptype=ksptype, pctype=pctype, atol=atol, rtol=rtol, max_its=max_its, & + start_from_zero=start_from_zero, petsc_options=petsc_options) + + end subroutine set_solver_options_tensor + + subroutine petsc_monitor_setup(petsc_numbering, max_its) + ! sets up the petsc monitors "exact" or "iteration_vtus" + type(petsc_numbering_type), intent(in):: petsc_numbering + integer, intent(in) :: max_its + + type(mesh_type), pointer:: mesh + integer :: ierr, ncomponents + + petsc_monitor_x=PetscNumberingCreateVec(petsc_numbering) + petsc_monitor_numbering=petsc_numbering + ncomponents=size(petsc_numbering%gnn2unn,2) + + if (petsc_monitor_has_exact) then + + call VecDuplicate(petsc_monitor_x, petsc_monitor_exact, ierr) + + if (ncomponents==1) then + call field2petsc(petsc_monitor_exact_sfield, petsc_numbering, petsc_monitor_exact) + else + call field2petsc(petsc_monitor_exact_vfield, petsc_numbering, petsc_monitor_exact) + end if + + allocate( petsc_monitor_error(max_its+1) ) + allocate( petsc_monitor_flops(max_its+1) ) + petsc_monitor_error = 0.0 + petsc_monitor_flops = 0.0 + petsc_monitor_iteration=0 + + end if + + if (petsc_monitor_iteration_vtus) then + mesh => petsc_monitor_positions%mesh + if (ncomponents==1) then + call allocate(petsc_monitor_sfields(1), mesh, name="X") + call allocate(petsc_monitor_sfields(2), mesh, name="Residual") + call allocate(petsc_monitor_sfields(3), mesh, name="PreconditionedResidual") + else + call allocate(petsc_monitor_vfields(1), ncomponents, mesh, name="X") + call allocate(petsc_monitor_vfields(2), ncomponents, mesh, name="Residual") + call allocate(petsc_monitor_vfields(3), ncomponents, mesh, name="PreconditionedResidual") + end if + petsc_monitor_vtu_name="petsc_monitor_"//int2str(petsc_monitor_vtu_series) + petsc_monitor_vtu_series=petsc_monitor_vtu_series+1 + end if + + end subroutine petsc_monitor_setup + + subroutine petsc_solve_monitor_exact_scalar(exact, error_filename) !! To be called before petsc_solve. Registers the exact solution field !! to which the approximate solutions are compared each iteration. -type(scalar_field), intent(in):: exact + type(scalar_field), intent(in):: exact ! if present write to this filename, otherwise writes to stdout -character(len=*), optional, intent(in):: error_filename + character(len=*), optional, intent(in):: error_filename - petsc_monitor_exact_sfield=exact - call incref(petsc_monitor_exact_sfield) - if (present(error_filename)) then - petsc_monitor_error_filename=error_filename - else - petsc_monitor_error_filename="" - end if - petsc_monitor_has_exact=.true. + petsc_monitor_exact_sfield=exact + call incref(petsc_monitor_exact_sfield) + if (present(error_filename)) then + petsc_monitor_error_filename=error_filename + else + petsc_monitor_error_filename="" + end if + petsc_monitor_has_exact=.true. -end subroutine petsc_solve_monitor_exact_scalar + end subroutine petsc_solve_monitor_exact_scalar -subroutine petsc_solve_monitor_iteration_vtus(positions) + subroutine petsc_solve_monitor_iteration_vtus(positions) !! To be called before petsc_solve. Registers the position field to be !! used in the vtus written out by the "iteration_vtus" monitor. Needs !! to be the exact same mesh as the solution field. -type(vector_field), intent(in):: positions + type(vector_field), intent(in):: positions - petsc_monitor_positions=positions - call incref(petsc_monitor_positions) - petsc_monitor_iteration_vtus=.true. + petsc_monitor_positions=positions + call incref(petsc_monitor_positions) + petsc_monitor_iteration_vtus=.true. -end subroutine petsc_solve_monitor_iteration_vtus + end subroutine petsc_solve_monitor_iteration_vtus -subroutine petsc_monitor_destroy() - ! Destroys everything asscociated with the petsc monitors - integer :: ierr, i - integer :: error_unit - character(len = 100) :: format0 + subroutine petsc_monitor_destroy() + ! Destroys everything asscociated with the petsc monitors + integer :: ierr, i + integer :: error_unit + character(len = 100) :: format0 - call VecDestroy(petsc_monitor_x, ierr) + call VecDestroy(petsc_monitor_x, ierr) - if (petsc_monitor_has_exact) then + if (petsc_monitor_has_exact) then - if(petsc_monitor_error_filename/='') then - !dumping out errors and flops - error_unit=free_unit() - open(unit=error_unit, file=trim(petsc_monitor_error_filename), action="write") - format0="(i0,a," & + if(petsc_monitor_error_filename/='') then + !dumping out errors and flops + error_unit=free_unit() + open(unit=error_unit, file=trim(petsc_monitor_error_filename), action="write") + format0="(i0,a," & & // real_format(padding = 1) // ",a," & & // real_format(padding = 1) //")" - do i = 1, petsc_monitor_iteration - write(error_unit, format0) i , " ", & + do i = 1, petsc_monitor_iteration + write(error_unit, format0) i , " ", & & petsc_monitor_error(i), " ", petsc_monitor_flops(i) - end do - close(error_unit) - else - ewrite(1,*) 'ERROR CALCULATIONS' - ewrite(1,*) 'iteration, error, flops' - do i = 1, petsc_monitor_iteration - ewrite(1,*) i, petsc_monitor_error(i), petsc_monitor_flops(i) - end do - end if - - if (size(petsc_monitor_numbering%gnn2unn,2)==1) then - call deallocate(petsc_monitor_exact_sfield) - else - call deallocate(petsc_monitor_exact_vfield) - end if - - call VecDestroy(petsc_monitor_exact, ierr) - deallocate( petsc_monitor_error ) - deallocate( petsc_monitor_flops ) - end if - - if (petsc_monitor_iteration_vtus) then - if (size(petsc_monitor_numbering%gnn2unn,2)==1) then - do i=1, 3 - call deallocate(petsc_monitor_sfields(i)) - end do - else - do i=1, 3 - call deallocate(petsc_monitor_vfields(i)) - end do - end if - call deallocate(petsc_monitor_positions) - end if + end do + close(error_unit) + else + ewrite(1,*) 'ERROR CALCULATIONS' + ewrite(1,*) 'iteration, error, flops' + do i = 1, petsc_monitor_iteration + ewrite(1,*) i, petsc_monitor_error(i), petsc_monitor_flops(i) + end do + end if -end subroutine petsc_monitor_destroy + if (size(petsc_monitor_numbering%gnn2unn,2)==1) then + call deallocate(petsc_monitor_exact_sfield) + else + call deallocate(petsc_monitor_exact_vfield) + end if + + call VecDestroy(petsc_monitor_exact, ierr) + deallocate( petsc_monitor_error ) + deallocate( petsc_monitor_flops ) + end if + + if (petsc_monitor_iteration_vtus) then + if (size(petsc_monitor_numbering%gnn2unn,2)==1) then + do i=1, 3 + call deallocate(petsc_monitor_sfields(i)) + end do + else + do i=1, 3 + call deallocate(petsc_monitor_vfields(i)) + end do + end if + call deallocate(petsc_monitor_positions) + end if -subroutine MyKSPMonitor(ksp,n,rnorm,dummy,ierr) + end subroutine petsc_monitor_destroy + + subroutine MyKSPMonitor(ksp,n,rnorm,dummy,ierr) !! The monitor function that gets called each iteration of petsc_solve !! (if petsc_solve_callback_setup is called) - PetscInt, intent(in) :: n - PetscObject, intent(in):: dummy - KSP, intent(in) :: ksp - PetscErrorCode, intent(out) :: ierr - - PetscScalar :: rnorm - MatNullSpace :: nullsp - PetscLogDouble :: flops - Mat:: Amat, Pmat - PC:: pc - Vec:: dummy_vec, r, rhs - - ! Build the solution vector - call VecZeroEntries(petsc_monitor_x,ierr) - ! don't pass PETSC_NULL_OBJECT instead of dummy_vec, as petsc - ! will clobber it (bug in fortran interface) - call KSPBuildSolution(ksp,petsc_monitor_x, dummy_vec, ierr) - - if (petsc_monitor_has_exact) then - ! Compare with exact solution - call VecAXPY(petsc_monitor_x, real(-1.0, kind = PetscScalar_kind), petsc_monitor_exact, ierr) - call VecNorm(petsc_monitor_x, NORM_INFINITY, rnorm, ierr) - call PetscGetFlops(flops,ierr) - - petsc_monitor_error(n+1) = rnorm - petsc_monitor_iteration = max(petsc_monitor_iteration,n+1) - petsc_monitor_flops(n+1) = flops - end if - - if (petsc_monitor_iteration_vtus) then - ! store the solution - if (size(petsc_monitor_numbering%gnn2unn,2)==1) then - call petsc2field(petsc_monitor_x, petsc_monitor_numbering, petsc_monitor_sfields(1)) - else - call petsc2field(petsc_monitor_x, petsc_monitor_numbering, petsc_monitor_vfields(1)) - end if - - ! then (re)compute the (true) residual - call KSPGetRhs(ksp, rhs, ierr) - call KSPGetOperators(ksp, Amat, Pmat, ierr) - call VecDuplicate(petsc_monitor_x, r, ierr) - call MatMult(Amat, petsc_monitor_x, r, ierr) - call VecAXPY(r, real(-1.0, kind = PetscScalar_kind), rhs, ierr) - if (size(petsc_monitor_numbering%gnn2unn,2)==1) then - call petsc2field(r, petsc_monitor_numbering, petsc_monitor_sfields(2)) - else - call petsc2field(r, petsc_monitor_numbering, petsc_monitor_vfields(2)) - end if - - ! now (re)compute the preconditioned residual - which is what we usually look at for convergence - call VecCopy(r, petsc_monitor_x, ierr) - call KSPGetPC(ksp, pc, ierr) - call PCApply(pc, petsc_monitor_x, r, ierr) - ! within petsc the nullspace is removed directly after pcapply (see KSP_PCApply) - call MatGetNullSpace(Pmat, nullsp, ierr) - if (.not. IsNullMatNullSpace(nullsp) .and. ierr==0) then - call MatNullSpaceRemove(nullsp, r, ierr) - end if - if (size(petsc_monitor_numbering%gnn2unn,2)==1) then - call petsc2field(r, petsc_monitor_numbering, petsc_monitor_sfields(3)) - else - call petsc2field(r, petsc_monitor_numbering, petsc_monitor_vfields(3)) - end if - - if (size(petsc_monitor_numbering%gnn2unn,2)==1) then - call vtk_write_fields(petsc_monitor_vtu_name, index=n, & - model=petsc_monitor_positions%mesh, position=petsc_monitor_positions, & - sfields=petsc_monitor_sfields) - else - call vtk_write_fields(petsc_monitor_vtu_name, index=n, & - model=petsc_monitor_positions%mesh, position=petsc_monitor_positions, & - vfields=petsc_monitor_vfields) - end if - call VecDestroy(r, ierr) - end if - - ierr=0 - -end subroutine MyKSPMonitor - -function create_null_space_from_options_scalar(mat, null_space_option_path) & - result (null_space) - - Mat, intent(in):: mat - !! the option path to remove_null_space - character(len=*), intent(in):: null_space_option_path - - Vec, dimension(1:0) :: ArrayOfZeroVecs - MatNullSpace :: null_space - PetscErrorCode :: ierr - PetscBool :: isnull - - call MatNullSpaceCreate(MPI_COMM_FEMTOOLS, PETSC_TRUE, 0, ArrayOfZeroVecs, null_space, ierr) - - if(have_option(trim(null_space_option_path)//'/test_null_space')) then - call MatNullSpaceTest(null_space, mat, isnull, ierr) - ewrite(1,*) "For nullspace "//trim(null_space_option_path)//":" - if (isnull) then - ewrite(1,*) "PETSc's MatNullSpaceTest agrees that this is a null space" - else - ewrite(1,*) "PETSc's MatNullSpaceTest does not think this is a null space" - end if - end if - -end function create_null_space_from_options_scalar - -function create_null_space_from_options_vector(mat, null_space_option_path, & + PetscInt, intent(in) :: n + PetscObject, intent(in):: dummy + KSP, intent(in) :: ksp + PetscErrorCode, intent(out) :: ierr + + PetscScalar :: rnorm + MatNullSpace :: nullsp + PetscLogDouble :: flops + Mat:: Amat, Pmat + PC:: pc + Vec:: dummy_vec, r, rhs + + ! Build the solution vector + call VecZeroEntries(petsc_monitor_x,ierr) + ! don't pass PETSC_NULL_OBJECT instead of dummy_vec, as petsc + ! will clobber it (bug in fortran interface) + call KSPBuildSolution(ksp,petsc_monitor_x, dummy_vec, ierr) + + if (petsc_monitor_has_exact) then + ! Compare with exact solution + call VecAXPY(petsc_monitor_x, real(-1.0, kind = PetscScalar_kind), petsc_monitor_exact, ierr) + call VecNorm(petsc_monitor_x, NORM_INFINITY, rnorm, ierr) + call PetscGetFlops(flops,ierr) + + petsc_monitor_error(n+1) = rnorm + petsc_monitor_iteration = max(petsc_monitor_iteration,n+1) + petsc_monitor_flops(n+1) = flops + end if + + if (petsc_monitor_iteration_vtus) then + ! store the solution + if (size(petsc_monitor_numbering%gnn2unn,2)==1) then + call petsc2field(petsc_monitor_x, petsc_monitor_numbering, petsc_monitor_sfields(1)) + else + call petsc2field(petsc_monitor_x, petsc_monitor_numbering, petsc_monitor_vfields(1)) + end if + + ! then (re)compute the (true) residual + call KSPGetRhs(ksp, rhs, ierr) + call KSPGetOperators(ksp, Amat, Pmat, ierr) + call VecDuplicate(petsc_monitor_x, r, ierr) + call MatMult(Amat, petsc_monitor_x, r, ierr) + call VecAXPY(r, real(-1.0, kind = PetscScalar_kind), rhs, ierr) + if (size(petsc_monitor_numbering%gnn2unn,2)==1) then + call petsc2field(r, petsc_monitor_numbering, petsc_monitor_sfields(2)) + else + call petsc2field(r, petsc_monitor_numbering, petsc_monitor_vfields(2)) + end if + + ! now (re)compute the preconditioned residual - which is what we usually look at for convergence + call VecCopy(r, petsc_monitor_x, ierr) + call KSPGetPC(ksp, pc, ierr) + call PCApply(pc, petsc_monitor_x, r, ierr) + ! within petsc the nullspace is removed directly after pcapply (see KSP_PCApply) + call MatGetNullSpace(Pmat, nullsp, ierr) + if (.not. IsNullMatNullSpace(nullsp) .and. ierr==0) then + call MatNullSpaceRemove(nullsp, r, ierr) + end if + if (size(petsc_monitor_numbering%gnn2unn,2)==1) then + call petsc2field(r, petsc_monitor_numbering, petsc_monitor_sfields(3)) + else + call petsc2field(r, petsc_monitor_numbering, petsc_monitor_vfields(3)) + end if + + if (size(petsc_monitor_numbering%gnn2unn,2)==1) then + call vtk_write_fields(petsc_monitor_vtu_name, index=n, & + model=petsc_monitor_positions%mesh, position=petsc_monitor_positions, & + sfields=petsc_monitor_sfields) + else + call vtk_write_fields(petsc_monitor_vtu_name, index=n, & + model=petsc_monitor_positions%mesh, position=petsc_monitor_positions, & + vfields=petsc_monitor_vfields) + end if + call VecDestroy(r, ierr) + end if + + ierr=0 + + end subroutine MyKSPMonitor + + function create_null_space_from_options_scalar(mat, null_space_option_path) & + result (null_space) + + Mat, intent(in):: mat + !! the option path to remove_null_space + character(len=*), intent(in):: null_space_option_path + + Vec, dimension(1:0) :: ArrayOfZeroVecs + MatNullSpace :: null_space + PetscErrorCode :: ierr + PetscBool :: isnull + + call MatNullSpaceCreate(MPI_COMM_FEMTOOLS, PETSC_TRUE, 0, ArrayOfZeroVecs, null_space, ierr) + + if(have_option(trim(null_space_option_path)//'/test_null_space')) then + call MatNullSpaceTest(null_space, mat, isnull, ierr) + ewrite(1,*) "For nullspace "//trim(null_space_option_path)//":" + if (isnull) then + ewrite(1,*) "PETSc's MatNullSpaceTest agrees that this is a null space" + else + ewrite(1,*) "PETSc's MatNullSpaceTest does not think this is a null space" + end if + end if + + end function create_null_space_from_options_scalar + + function create_null_space_from_options_vector(mat, null_space_option_path, & petsc_numbering, positions, rotation_matrix) result (null_space) - Mat, intent(in):: mat - !! the option path to remove_null_space or multigrid_near_space - character(len=*), intent(in):: null_space_option_path - type(petsc_numbering_type), intent(in):: petsc_numbering - ! positions field is only used with remove_null_space/ with rotational components - type(vector_field), intent(in), optional :: positions - ! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned - Mat, intent(in), optional:: rotation_matrix - MatNullSpace :: null_space - - Vec, allocatable, dimension(:) :: null_space_array - Vec :: aux_vec, swap - PetscReal, dimension(:), allocatable :: dots - PetscReal :: norm - PetscErrorCode :: ierr - PetscBool :: isnull - - integer :: i, ele, nnulls, nnodes, comp, dim, universal_nodes - integer, dimension(:), pointer :: nodes - logical, dimension(3) :: rot_mask - logical, dimension(size(petsc_numbering%gnn2unn,2)) :: mask - real, dimension(:,:), allocatable :: null_vector - type(vector_field) :: null_vector_field - type(vector_field), allocatable, dimension(:) :: vtk_vector_fields(:) - integer, save :: vtk_index = 0 - - integer, dimension(5), parameter:: permutations=(/ 1,2,3,1,2 /) - - nnodes=size(petsc_numbering%gnn2unn,1) - dim=size(petsc_numbering%gnn2unn,2) - - call get_null_space_component_options(null_space_option_path, mask, rot_mask) - - nnulls=count(mask)+count(rot_mask) - ! allocate the array of null spaces - allocate(null_space_array(1:nnulls)) - allocate(null_vector(nnodes,dim)) - - ! used in l2-normalisation - universal_nodes=petsc_numbering%universal_length/dim - if (any(mask)) then - if (positions%mesh%shape%numbering%type==ELEMENT_BUBBLE) then - universal_nodes=universal_nodes-element_count(positions) - end if - end if - - ewrite(2,*) "Setting up array of "//int2str(nnulls)//" null spaces." - - ! now loop back over the components building up the null spaces we want - i = 0 - do comp = 1, dim - if (mask(comp)) then - i = i + 1 - null_vector = 0.0 - ! ensure the translations are orthonormal: - null_vector(:,comp)=1.0/sqrt(real(universal_nodes)) - if (positions%mesh%shape%numbering%type==ELEMENT_BUBBLE) then - ! zero bubble nodes - do ele=1, element_count(positions) - nodes => ele_nodes(positions, ele) - null_vector(nodes(size(nodes)),comp) = 0. + Mat, intent(in):: mat + !! the option path to remove_null_space or multigrid_near_space + character(len=*), intent(in):: null_space_option_path + type(petsc_numbering_type), intent(in):: petsc_numbering + ! positions field is only used with remove_null_space/ with rotational components + type(vector_field), intent(in), optional :: positions + ! with rotated bcs: matrix to transform from x,y,z aligned vectors to boundary aligned + Mat, intent(in), optional:: rotation_matrix + MatNullSpace :: null_space + + Vec, allocatable, dimension(:) :: null_space_array + Vec :: aux_vec, swap + PetscReal, dimension(:), allocatable :: dots + PetscReal :: norm + PetscErrorCode :: ierr + PetscBool :: isnull + + integer :: i, ele, nnulls, nnodes, comp, dim, universal_nodes + integer, dimension(:), pointer :: nodes + logical, dimension(3) :: rot_mask + logical, dimension(size(petsc_numbering%gnn2unn,2)) :: mask + real, dimension(:,:), allocatable :: null_vector + type(vector_field) :: null_vector_field + type(vector_field), allocatable, dimension(:) :: vtk_vector_fields(:) + integer, save :: vtk_index = 0 + + integer, dimension(5), parameter:: permutations=(/ 1,2,3,1,2 /) + + nnodes=size(petsc_numbering%gnn2unn,1) + dim=size(petsc_numbering%gnn2unn,2) + + call get_null_space_component_options(null_space_option_path, mask, rot_mask) + + nnulls=count(mask)+count(rot_mask) + ! allocate the array of null spaces + allocate(null_space_array(1:nnulls)) + allocate(null_vector(nnodes,dim)) + + ! used in l2-normalisation + universal_nodes=petsc_numbering%universal_length/dim + if (any(mask)) then + if (positions%mesh%shape%numbering%type==ELEMENT_BUBBLE) then + universal_nodes=universal_nodes-element_count(positions) + end if + end if + + ewrite(2,*) "Setting up array of "//int2str(nnulls)//" null spaces." + + ! now loop back over the components building up the null spaces we want + i = 0 + do comp = 1, dim + if (mask(comp)) then + i = i + 1 + null_vector = 0.0 + ! ensure the translations are orthonormal: + null_vector(:,comp)=1.0/sqrt(real(universal_nodes)) + if (positions%mesh%shape%numbering%type==ELEMENT_BUBBLE) then + ! zero bubble nodes + do ele=1, element_count(positions) + nodes => ele_nodes(positions, ele) + null_vector(nodes(size(nodes)),comp) = 0. + end do + end if + null_space_array(i)=PetscNumberingCreateVec(petsc_numbering) + call array2petsc(reshape(null_vector,(/nnodes*dim/)), petsc_numbering, null_space_array(i)) + end if + end do + + deallocate(null_vector) + + if (any(rot_mask)) then + + if (.not. present(positions)) then + ! when providing the option to remove rotational modes to the user, positions should have been passed in + FLAbort("In create_null_space_from_options, need positions field") + end if + + call allocate(null_vector_field, positions%dim, positions%mesh) + + do comp = 1, 3 + if (rot_mask(comp)) then + i = i + 1 + if (dim==3) then + ! for dim==2: comp==3 and both components will be set already + call zero(null_vector_field, comp) + end if + call set(null_vector_field, permutations(comp+1), & + extract_scalar_field(positions, permutations(comp+2))) + call scale(null_vector_field, -1.0, dim=permutations(comp+1)) + call set(null_vector_field, permutations(comp+2), & + extract_scalar_field(positions, permutations(comp+1))) + null_space_array(i)=PetscNumberingCreateVec(petsc_numbering) + call zero_bubble_vals(null_vector_field) + call field2petsc(null_vector_field, petsc_numbering, null_space_array(i)) + end if end do - end if - null_space_array(i)=PetscNumberingCreateVec(petsc_numbering) - call array2petsc(reshape(null_vector,(/nnodes*dim/)), petsc_numbering, null_space_array(i)) - end if - end do + call deallocate(null_vector_field) - deallocate(null_vector) + end if + + assert(i==nnulls) + + if (present(rotation_matrix) .and. nnulls>0) then + call VecDuplicate(null_space_array(1), aux_vec, ierr) + do i=1, nnulls + ! rotate the null vector and store it in aux_vec + call MatMultTranspose(rotation_matrix, null_space_array(i), aux_vec, ierr) + ! swap the unrotated null_space_array(i) with aux_vec + ! so that we store the rotated one in null_space_array(i) + ! and can use the unrotated as aux_vec in the next iteration + swap = null_space_array(i) + null_space_array(i) = aux_vec + aux_vec = swap + end do + call VecDestroy(aux_vec, ierr) + end if - if (any(rot_mask)) then + ! finally we need to ensure that the nullspace vectors are orthonormal + if (any(rot_mask)) then + ! but only the rotational ones, as the translations are orthonormal already + allocate(dots(1:nnulls)) + do i=count(mask)+1, nnulls + ! take the dot product with all previous vectors: + call VecMDot(null_space_array(i), i-1, null_space_array(1:i-1), dots(1:i-1), ierr) + dots = -dots + ! then subtract their components + call VecMAXPY(null_space_array(i), i-1, dots(1:i-1), null_space_array(1:i-1), ierr) + call VecNormalize(null_space_array(i), norm, ierr) + end do + deallocate(dots) + end if - if (.not. present(positions)) then - ! when providing the option to remove rotational modes to the user, positions should have been passed in - FLAbort("In create_null_space_from_options, need positions field") - end if + call MatNullSpaceCreate(MPI_COMM_FEMTOOLS, PETSC_FALSE, nnulls, & + null_space_array, null_space, ierr) - call allocate(null_vector_field, positions%dim, positions%mesh) + if(have_option(trim(null_space_option_path)//'/test_null_space')) then + call MatNullSpaceTest(null_space, mat, isnull, ierr) + ewrite(1,*) "For nullspace "//trim(null_space_option_path)//":" + if (isnull) then + ewrite(1,*) "PETSc's MatNullSpaceTest agrees that this is a null space" + else + ewrite(1,*) "PETSc's MatNullSpaceTest does not think this is a null space" + end if + end if - do comp = 1, 3 - if (rot_mask(comp)) then - i = i + 1 + if(have_option(trim(null_space_option_path)//'/write_null_space')) then + allocate(vtk_vector_fields(1:nnulls)) + do i=1, nnulls + call allocate(vtk_vector_fields(i), positions%dim, positions%mesh, name="NullVector"//int2str(i)) + call petsc2field(null_space_array(i), petsc_numbering, vtk_vector_fields(i)) + end do + vtk_index = vtk_index + 1 + call vtk_write_fields("null_space", index=vtk_index, & + model=positions%mesh, position=positions, & + vfields=vtk_vector_fields) + do i=1, nnulls + call deallocate(vtk_vector_fields(i)) + end do + deallocate(vtk_vector_fields) + end if + + ! get rid of our Vec references + do i=1, nnulls + call VecDestroy(null_space_array(i), ierr) + end do + deallocate(null_space_array) + + + end function create_null_space_from_options_vector + + subroutine get_null_space_component_options(null_space_option_path, mask, rot_mask) + character(len=*), intent(in) :: null_space_option_path + logical, dimension(:), intent(out) :: mask ! length should be field%dim + logical, dimension(3), intent(out) :: rot_mask ! NOTE: always 3-dim + + integer :: dim + + dim = size(mask) + + if(have_option(trim(null_space_option_path)//'/specify_components')) then + ! count how many null spaces we want + mask = .false. + mask(1) = have_option(trim(null_space_option_path)//& + &"/specify_components/x_component") + if (have_option(trim(null_space_option_path)//& + &"/specify_components/y_component")) then + if(dim<2) then + FLExit("Requested the removal of a y component null space on a less than 2d vector.") + end if + mask(2) = .true. + end if + if (have_option(trim(null_space_option_path)//& + &"/specify_components/z_component")) then + if(dim<3) then + FLExit("Requested the removal of a z component null space on a less than 3d vector.") + end if + mask(3) = .true. + end if + if(.not. any(mask)) then + FLExit("Requested null space removal on specific components but have not specified which components.") + end if + else if(have_option(trim(null_space_option_path)//'/all_components')) then + mask = .true. + else if(have_option(trim(null_space_option_path)//'/no_components')) then + mask = .false. + else + ewrite(0,*) "null_space_option_path: ", null_space_option_path + FLAbort("Invalid null_space_option_path") + end if + + if(have_option(trim(null_space_option_path)//'/specify_rotations')) then + rot_mask = .false. + rot_mask(3)=have_option(trim(null_space_option_path)//& + &"/specify_rotations/xy_rotation") + if (have_option(trim(null_space_option_path)//& + &"/specify_rotations/xz_rotation")) then + + if(dim<3) then + FLExit("Requested the removal of xz rotation on a less than 3d vector.") + end if + rot_mask(2) = .true. + end if + if (have_option(trim(null_space_option_path)//& + &"/specify_rotations/yz_rotation")) then + + if(dim<3) then + FLExit("Requested the removal of yz rotation on a less than 3d vector.") + end if + rot_mask(1) = .true. + end if + if(.not. any(rot_mask)) then + FLExit("Requested null space removal on specific rotations but have not specified which rotations.") + end if + else if(have_option(trim(null_space_option_path)//'/all_rotations')) then + rot_mask = .false. if (dim==3) then - ! for dim==2: comp==3 and both components will be set already - call zero(null_vector_field, comp) + rot_mask = .true. + else if (dim==2) then + rot_mask(3) = .true. + end if + else + rot_mask = .false. + end if + + if (.not. (any(mask) .or. any(rot_mask)) ) then + FLExit("You must remove either a component or a rotation.") + end if + + if(any(rot_mask) .and. dim<2) then + FLExit("Requested the removal of rotational component for a less than 2d vector.") + end if + + end subroutine get_null_space_component_options + + subroutine L2_project_nullspace_vector(field, null_space_option_path, coordinates, mesh_positions) + ! L2 project the nullspace specified under /remove_null_space + ! out of the solution field `field` + ! This uses a proper (big) L2 projection, so after the projection + ! = \int_\Omega n(x)f(x) dx =0 for all null modes n(x) + ! This in contrast with an l2-projection, as it used during the petsc solve + ! which merely results in \sum_i n_i f_i =0 where n_i and f_i are the DOFs of n(x) and f(x) + + ! solution field to project the nullspace out of: + type(vector_field), intent(inout) :: field + ! null_space_option_path (should have remove_null_space/ under it) + character(len=*), intent(in) :: null_space_option_path + ! coordinate field used for integration (should be "Coordinate") + type(vector_field), intent(in) :: coordinates + ! positions of field%mesh + type(vector_field), intent(in) :: mesh_positions + + type(vector_field) :: null_field + integer, dimension(5), parameter:: permutations=(/ 1,2,3,1,2 /) + logical, dimension(field%dim) :: mask + logical, dimension(3) :: rot_mask + integer :: i, j, k + + ewrite(1,*) "Inside L2_project_nullspace_vector" + + call get_null_space_component_options(null_space_option_path, mask, rot_mask) + + call allocate(null_field, field%dim, field%mesh, "NullspaceField") + call zero(null_field) + do i=1, field%dim + if (mask(i)) then + call set(null_field, i, 1.0) + call zero_bubble_vals(null_field) + call L2_project_nullmode_vector(field, null_field, coordinates) + call zero(null_field, dim=i) + end if + end do + + do i=1, 3 + if (rot_mask(i)) then + ! the two directions orthogonal to i + j = permutations(i+1) + k = permutations(i+2) + ! the rotational null field is basically j and k swapped, with a sign in front of one + ! while keeping the i component at zero + ! note that we do not care about the overall sign here, since the L2 projection takes care of that + if (i<=field%dim) then + null_field%val(i,:) = 0. + end if + null_field%val(j,:) = mesh_positions%val(k,:) + null_field%val(k,:) = -mesh_positions%val(j,:) + call zero_bubble_vals(null_field) + call L2_project_nullmode_vector(field, null_field, coordinates) end if - call set(null_vector_field, permutations(comp+1), & - extract_scalar_field(positions, permutations(comp+2))) - call scale(null_vector_field, -1.0, dim=permutations(comp+1)) - call set(null_vector_field, permutations(comp+2), & - extract_scalar_field(positions, permutations(comp+1))) - null_space_array(i)=PetscNumberingCreateVec(petsc_numbering) - call zero_bubble_vals(null_vector_field) - call field2petsc(null_vector_field, petsc_numbering, null_space_array(i)) - end if - end do - call deallocate(null_vector_field) - - end if - - assert(i==nnulls) - - if (present(rotation_matrix) .and. nnulls>0) then - call VecDuplicate(null_space_array(1), aux_vec, ierr) - do i=1, nnulls - ! rotate the null vector and store it in aux_vec - call MatMultTranspose(rotation_matrix, null_space_array(i), aux_vec, ierr) - ! swap the unrotated null_space_array(i) with aux_vec - ! so that we store the rotated one in null_space_array(i) - ! and can use the unrotated as aux_vec in the next iteration - swap = null_space_array(i) - null_space_array(i) = aux_vec - aux_vec = swap - end do - call VecDestroy(aux_vec, ierr) - end if - - ! finally we need to ensure that the nullspace vectors are orthonormal - if (any(rot_mask)) then - ! but only the rotational ones, as the translations are orthonormal already - allocate(dots(1:nnulls)) - do i=count(mask)+1, nnulls - ! take the dot product with all previous vectors: - call VecMDot(null_space_array(i), i-1, null_space_array(1:i-1), dots(1:i-1), ierr) - dots = -dots - ! then subtract their components - call VecMAXPY(null_space_array(i), i-1, dots(1:i-1), null_space_array(1:i-1), ierr) - call VecNormalize(null_space_array(i), norm, ierr) - end do - deallocate(dots) - end if - - call MatNullSpaceCreate(MPI_COMM_FEMTOOLS, PETSC_FALSE, nnulls, & - null_space_array, null_space, ierr) - - if(have_option(trim(null_space_option_path)//'/test_null_space')) then - call MatNullSpaceTest(null_space, mat, isnull, ierr) - ewrite(1,*) "For nullspace "//trim(null_space_option_path)//":" - if (isnull) then - ewrite(1,*) "PETSc's MatNullSpaceTest agrees that this is a null space" - else - ewrite(1,*) "PETSc's MatNullSpaceTest does not think this is a null space" - end if - end if - - if(have_option(trim(null_space_option_path)//'/write_null_space')) then - allocate(vtk_vector_fields(1:nnulls)) - do i=1, nnulls - call allocate(vtk_vector_fields(i), positions%dim, positions%mesh, name="NullVector"//int2str(i)) - call petsc2field(null_space_array(i), petsc_numbering, vtk_vector_fields(i)) - end do - vtk_index = vtk_index + 1 - call vtk_write_fields("null_space", index=vtk_index, & - model=positions%mesh, position=positions, & - vfields=vtk_vector_fields) - do i=1, nnulls - call deallocate(vtk_vector_fields(i)) - end do - deallocate(vtk_vector_fields) - end if - - ! get rid of our Vec references - do i=1, nnulls - call VecDestroy(null_space_array(i), ierr) - end do - deallocate(null_space_array) - - -end function create_null_space_from_options_vector - -subroutine get_null_space_component_options(null_space_option_path, mask, rot_mask) - character(len=*), intent(in) :: null_space_option_path - logical, dimension(:), intent(out) :: mask ! length should be field%dim - logical, dimension(3), intent(out) :: rot_mask ! NOTE: always 3-dim - - integer :: dim - - dim = size(mask) - - if(have_option(trim(null_space_option_path)//'/specify_components')) then - ! count how many null spaces we want - mask = .false. - mask(1) = have_option(trim(null_space_option_path)//& - &"/specify_components/x_component") - if (have_option(trim(null_space_option_path)//& - &"/specify_components/y_component")) then - if(dim<2) then - FLExit("Requested the removal of a y component null space on a less than 2d vector.") - end if - mask(2) = .true. - end if - if (have_option(trim(null_space_option_path)//& - &"/specify_components/z_component")) then - if(dim<3) then - FLExit("Requested the removal of a z component null space on a less than 3d vector.") - end if - mask(3) = .true. - end if - if(.not. any(mask)) then - FLExit("Requested null space removal on specific components but have not specified which components.") - end if - else if(have_option(trim(null_space_option_path)//'/all_components')) then - mask = .true. - else if(have_option(trim(null_space_option_path)//'/no_components')) then - mask = .false. - else - ewrite(0,*) "null_space_option_path: ", null_space_option_path - FLAbort("Invalid null_space_option_path") - end if - - if(have_option(trim(null_space_option_path)//'/specify_rotations')) then - rot_mask = .false. - rot_mask(3)=have_option(trim(null_space_option_path)//& - &"/specify_rotations/xy_rotation") - if (have_option(trim(null_space_option_path)//& - &"/specify_rotations/xz_rotation")) then - - if(dim<3) then - FLExit("Requested the removal of xz rotation on a less than 3d vector.") - end if - rot_mask(2) = .true. - end if - if (have_option(trim(null_space_option_path)//& - &"/specify_rotations/yz_rotation")) then - - if(dim<3) then - FLExit("Requested the removal of yz rotation on a less than 3d vector.") - end if - rot_mask(1) = .true. - end if - if(.not. any(rot_mask)) then - FLExit("Requested null space removal on specific rotations but have not specified which rotations.") - end if - else if(have_option(trim(null_space_option_path)//'/all_rotations')) then - rot_mask = .false. - if (dim==3) then - rot_mask = .true. - else if (dim==2) then - rot_mask(3) = .true. - end if - else - rot_mask = .false. - end if - - if (.not. (any(mask) .or. any(rot_mask)) ) then - FLExit("You must remove either a component or a rotation.") - end if - - if(any(rot_mask) .and. dim<2) then - FLExit("Requested the removal of rotational component for a less than 2d vector.") - end if - -end subroutine get_null_space_component_options - -subroutine L2_project_nullspace_vector(field, null_space_option_path, coordinates, mesh_positions) - ! L2 project the nullspace specified under /remove_null_space - ! out of the solution field `field` - ! This uses a proper (big) L2 projection, so after the projection - ! = \int_\Omega n(x)f(x) dx =0 for all null modes n(x) - ! This in contrast with an l2-projection, as it used during the petsc solve - ! which merely results in \sum_i n_i f_i =0 where n_i and f_i are the DOFs of n(x) and f(x) - - ! solution field to project the nullspace out of: - type(vector_field), intent(inout) :: field - ! null_space_option_path (should have remove_null_space/ under it) - character(len=*), intent(in) :: null_space_option_path - ! coordinate field used for integration (should be "Coordinate") - type(vector_field), intent(in) :: coordinates - ! positions of field%mesh - type(vector_field), intent(in) :: mesh_positions - - type(vector_field) :: null_field - integer, dimension(5), parameter:: permutations=(/ 1,2,3,1,2 /) - logical, dimension(field%dim) :: mask - logical, dimension(3) :: rot_mask - integer :: i, j, k - - ewrite(1,*) "Inside L2_project_nullspace_vector" - - call get_null_space_component_options(null_space_option_path, mask, rot_mask) - - call allocate(null_field, field%dim, field%mesh, "NullspaceField") - call zero(null_field) - do i=1, field%dim - if (mask(i)) then - call set(null_field, i, 1.0) - call zero_bubble_vals(null_field) - call L2_project_nullmode_vector(field, null_field, coordinates) - call zero(null_field, dim=i) - end if - end do - - do i=1, 3 - if (rot_mask(i)) then - ! the two directions orthogonal to i - j = permutations(i+1) - k = permutations(i+2) - ! the rotational null field is basically j and k swapped, with a sign in front of one - ! while keeping the i component at zero - ! note that we do not care about the overall sign here, since the L2 projection takes care of that - if (i<=field%dim) then - null_field%val(i,:) = 0. - end if - null_field%val(j,:) = mesh_positions%val(k,:) - null_field%val(k,:) = -mesh_positions%val(j,:) - call zero_bubble_vals(null_field) - call L2_project_nullmode_vector(field, null_field, coordinates) - end if - end do - - call deallocate(null_field) - -end subroutine L2_project_nullspace_vector - -subroutine L2_project_nullmode_vector(field, null_field, coordinates) - ! L2 project a single null_field out of field - ! This uses a proper (big) L2 projection, so after the projection - ! = \int_\Omega n(x)f(x) dx =0 for null_field n(x) and field f(x) - - ! solution field to project the nullspace out of: - type(vector_field), intent(inout) :: field - ! null mode to project out - type(vector_field), intent(inout) :: null_field - ! coordinate field used for integration (should be "Coordinate") - type(vector_field), intent(in) :: coordinates - - real :: n_dot_f, n_dot_n - - n_dot_f = dot_product(null_field, field, coordinates) - n_dot_n = dot_product(null_field, null_field, coordinates) - - call addto(field, null_field, scale=-n_dot_f/n_dot_n) - -end subroutine L2_project_nullmode_vector - -function petsc_solve_needs_positions(solver_option_path) - !!< Auxillary function to tell us if we need to pass in a positions field to petsc_solve - !!< Currently only for vector solves with remove_null_space or multigrid_near_null_space - character(len=*), intent(in):: solver_option_path - logical:: petsc_solve_needs_positions - - ! for vector fields with multigrid_near_null_space we only need it if we have rotations - ! for vector fields with remove_null_space we need it in all cases, since we do a L2 projection afterwards - petsc_solve_needs_positions = & - have_option(trim(solver_option_path)//'/remove_null_space/all_components') .or. & - have_option(trim(solver_option_path)//'/remove_null_space/specify_components') .or. & - have_option(trim(solver_option_path)//'/remove_null_space/no_components') .or. & - have_option(trim(solver_option_path)//'/multigrid_near_null_space/all_components') .or. & - have_option(trim(solver_option_path)//'/multigrid_near_null_space/specify_components') .or. & - have_option(trim(solver_option_path)//'/multigrid_near_null_space/no_components') - -end function petsc_solve_needs_positions + end do + + call deallocate(null_field) + + end subroutine L2_project_nullspace_vector + + subroutine L2_project_nullmode_vector(field, null_field, coordinates) + ! L2 project a single null_field out of field + ! This uses a proper (big) L2 projection, so after the projection + ! = \int_\Omega n(x)f(x) dx =0 for null_field n(x) and field f(x) + + ! solution field to project the nullspace out of: + type(vector_field), intent(inout) :: field + ! null mode to project out + type(vector_field), intent(inout) :: null_field + ! coordinate field used for integration (should be "Coordinate") + type(vector_field), intent(in) :: coordinates + + real :: n_dot_f, n_dot_n + + n_dot_f = dot_product(null_field, field, coordinates) + n_dot_n = dot_product(null_field, null_field, coordinates) + + call addto(field, null_field, scale=-n_dot_f/n_dot_n) + + end subroutine L2_project_nullmode_vector + + function petsc_solve_needs_positions(solver_option_path) + !!< Auxillary function to tell us if we need to pass in a positions field to petsc_solve + !!< Currently only for vector solves with remove_null_space or multigrid_near_null_space + character(len=*), intent(in):: solver_option_path + logical:: petsc_solve_needs_positions + + ! for vector fields with multigrid_near_null_space we only need it if we have rotations + ! for vector fields with remove_null_space we need it in all cases, since we do a L2 projection afterwards + petsc_solve_needs_positions = & + have_option(trim(solver_option_path)//'/remove_null_space/all_components') .or. & + have_option(trim(solver_option_path)//'/remove_null_space/specify_components') .or. & + have_option(trim(solver_option_path)//'/remove_null_space/no_components') .or. & + have_option(trim(solver_option_path)//'/multigrid_near_null_space/all_components') .or. & + have_option(trim(solver_option_path)//'/multigrid_near_null_space/specify_components') .or. & + have_option(trim(solver_option_path)//'/multigrid_near_null_space/no_components') + + end function petsc_solve_needs_positions end module solvers diff --git a/femtools/Sparse_Matrices_Fields.F90 b/femtools/Sparse_Matrices_Fields.F90 index d1d8955e4a..589887d5a5 100644 --- a/femtools/Sparse_Matrices_Fields.F90 +++ b/femtools/Sparse_Matrices_Fields.F90 @@ -26,987 +26,987 @@ ! USA #include "fdebug.h" module sparse_matrices_fields -use iso_c_binding -use fldebug -use sparse_tools -use fields -use sparse_tools_petsc + use iso_c_binding + use fldebug + use sparse_tools + use fields + use sparse_tools_petsc -implicit none + implicit none - interface mult - module procedure csr_mult_scalar, csr_mult_scalar_vector,& - csr_mult_vector_scalar, csr_mult_vector_vector, csr_mult_vector - end interface + interface mult + module procedure csr_mult_scalar, csr_mult_scalar_vector,& + csr_mult_vector_scalar, csr_mult_vector_vector, csr_mult_vector + end interface - interface mult_addto - module procedure block_csr_mult_addto_vector, csr_mult_addto_scalar - end interface + interface mult_addto + module procedure block_csr_mult_addto_vector, csr_mult_addto_scalar + end interface - interface mult_T - module procedure csr_mult_T_scalar, csr_mult_T_vector_scalar, csr_mult_T_vector_vector - end interface + interface mult_T + module procedure csr_mult_T_scalar, csr_mult_T_vector_scalar, csr_mult_T_vector_vector + end interface - interface mult_T_addto - module procedure csr_mult_T_addto_scalar - end interface + interface mult_T_addto + module procedure csr_mult_T_addto_scalar + end interface - interface mult_diag - module procedure csr_diag_mult_scalar, csr_diag_mult_scalar_v - end interface + interface mult_diag + module procedure csr_diag_mult_scalar, csr_diag_mult_scalar_v + end interface - interface addto_diag - module procedure csr_diag_addto_scalar, block_csr_diag_addto_scalar, & - petsc_csr_diag_addto_scalar, petsc_csr_diag_addto_vector - end interface + interface addto_diag + module procedure csr_diag_addto_scalar, block_csr_diag_addto_scalar, & + petsc_csr_diag_addto_scalar, petsc_csr_diag_addto_vector + end interface - interface extract_diagonal - module procedure block_csr_extract_diagonal - end interface + interface extract_diagonal + module procedure block_csr_extract_diagonal + end interface -private + private -public :: mult, mult_addto, mult_T, mult_T_addto, mult_diag, addto_diag,& - extract_diagonal, mult_div_tensorinvscalar_div_t,& - mult_div_tensorinvscalar_vector, mult_div_invscalar_div_t,& - mult_div_vector_div_t, mult_div_invvector_div_t + public :: mult, mult_addto, mult_T, mult_T_addto, mult_diag, addto_diag,& + extract_diagonal, mult_div_tensorinvscalar_div_t,& + mult_div_tensorinvscalar_vector, mult_div_invscalar_div_t,& + mult_div_vector_div_t, mult_div_invvector_div_t contains - subroutine csr_mult_scalar(x, A, b) - !!< Calculate x=A*b - type(scalar_field), intent(inout), target :: x - type(csr_matrix), intent(in) :: A - type(scalar_field), intent(in), target :: b - real, dimension(:), allocatable :: tmp - - if (c_associated(c_loc(x), c_loc(b))) then - FLAbort("You can't pass the same field in for x and b.") - end if - - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - call mult(x%val, A, b%val) - case(FIELD_TYPE_CONSTANT) - allocate(tmp(size(x%val))) - tmp=b%val(1) - call mult(x%val, A, tmp) - deallocate(tmp) - end select - - end subroutine csr_mult_scalar - - subroutine csr_mult_addto_scalar(x, A, b) - !!< Replace x with x+A*b - type(scalar_field), intent(inout) :: x - type(csr_matrix), intent(in) :: A - type(scalar_field), intent(in) :: b - real, dimension(:), allocatable :: tmp - - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - call mult_addto(x%val, A, b%val) - case(FIELD_TYPE_CONSTANT) - allocate(tmp(size(x%val))) - tmp=b%val(1) - call mult_addto(x%val, A, tmp) - deallocate(tmp) - end select - - end subroutine csr_mult_addto_scalar - - subroutine csr_mult_vector(x, A, b) - !!< Calculate x=A*b - type(vector_field), intent(inout) :: x - type(csr_matrix), intent(in) :: A - type(vector_field), intent(in) :: b - - integer :: i - type(scalar_field) :: x_comp, b_comp - - assert(x%dim==b%dim) - do i = 1, b%dim - x_comp = extract_scalar_field(x, i) - b_comp = extract_scalar_field(b, i) - call mult(x_comp, A, b_comp) - end do - - end subroutine csr_mult_vector - - subroutine block_csr_mult_addto_vector(x, A, b) - !!< Calculate x=A*b - type(vector_field), intent(inout) :: x - type(block_csr_matrix), intent(in) :: A - type(vector_field), intent(in) :: b - - integer :: i, j - type(scalar_field) :: x_comp, b_comp - type(csr_matrix) :: A_block - - assert(x%dim==b%dim) - call zero(x) - do i = 1, b%dim - b_comp = extract_scalar_field(b, i) - if(A%diagonal) then - x_comp = extract_scalar_field(x, i) - A_block = block(A,i,i) - call mult_addto(x_comp, A_block, b_comp) - else - do j = 1, b%dim - x_comp = extract_scalar_field(x, j) - A_block = block(A,i,j) - call mult_addto(x_comp, A_block, b_comp) - end do - end if - end do - end subroutine block_csr_mult_addto_vector - - subroutine csr_diag_mult_scalar(A, b) - !!< Calculate A_{i,i}=A_{i,i}*b_{i} - !!< A_{i,j}=A_{i,j}, i/=j - type(csr_matrix), intent(inout) :: A - type(scalar_field), intent(in) :: b - real, dimension(:), allocatable :: tmp - integer :: i - - assert(size(A,1)==node_count(b)) - assert(size(A,2)==node_count(b)) - - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, size(A,1) - call set(A, i, i, val(A, i, i)*b%val(i)) - end do - case(FIELD_TYPE_CONSTANT) - allocate(tmp(node_count(b))) - tmp=b%val(1) - do i = 1, size(A,1) - call set(A, i, i, val(A, i, i)*tmp(i)) - end do - deallocate(tmp) - end select + subroutine csr_mult_scalar(x, A, b) + !!< Calculate x=A*b + type(scalar_field), intent(inout), target :: x + type(csr_matrix), intent(in) :: A + type(scalar_field), intent(in), target :: b + real, dimension(:), allocatable :: tmp + + if (c_associated(c_loc(x), c_loc(b))) then + FLAbort("You can't pass the same field in for x and b.") + end if + + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + call mult(x%val, A, b%val) + case(FIELD_TYPE_CONSTANT) + allocate(tmp(size(x%val))) + tmp=b%val(1) + call mult(x%val, A, tmp) + deallocate(tmp) + end select - end subroutine csr_diag_mult_scalar + end subroutine csr_mult_scalar - subroutine csr_diag_mult_scalar_v(A, b) - !!< Calculate A_{i,i}=A_{i,i}*b_{i} - !!< A_{i,j}=A_{i,j}, i/=j - type(csr_matrix), intent(inout) :: A - real, dimension(:), intent(in) :: b - integer :: i + subroutine csr_mult_addto_scalar(x, A, b) + !!< Replace x with x+A*b + type(scalar_field), intent(inout) :: x + type(csr_matrix), intent(in) :: A + type(scalar_field), intent(in) :: b + real, dimension(:), allocatable :: tmp - assert(size(A,1)==size(b)) - assert(size(A,2)==size(b)) + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + call mult_addto(x%val, A, b%val) + case(FIELD_TYPE_CONSTANT) + allocate(tmp(size(x%val))) + tmp=b%val(1) + call mult_addto(x%val, A, tmp) + deallocate(tmp) + end select - do i = 1, size(A,1) - call set(A, i, i, val(A, i, i)*b(i)) - end do + end subroutine csr_mult_addto_scalar - end subroutine csr_diag_mult_scalar_v + subroutine csr_mult_vector(x, A, b) + !!< Calculate x=A*b + type(vector_field), intent(inout) :: x + type(csr_matrix), intent(in) :: A + type(vector_field), intent(in) :: b - subroutine csr_diag_addto_scalar(A, b, scale) - !!< Calculate X_{i,i}=A_{i,i}*b_{i} - !!< X_{i,j}=A_{i,j}, i/=j - type(csr_matrix), intent(inout) :: A - type(scalar_field), intent(in) :: b - real, optional, intent(in) :: scale - real, dimension(:), allocatable :: tmp - integer :: i + integer :: i + type(scalar_field) :: x_comp, b_comp - assert(size(A,1)==node_count(b)) - assert(size(A,2)==node_count(b)) + assert(x%dim==b%dim) + do i = 1, b%dim + x_comp = extract_scalar_field(x, i) + b_comp = extract_scalar_field(b, i) + call mult(x_comp, A, b_comp) + end do - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - if(present(scale)) then - do i = 1, size(A,1) - call addto(A, i, i, b%val(i)*scale) - end do - else - do i = 1, size(A,1) - call addto(A, i, i, b%val(i)) - end do - end if - case(FIELD_TYPE_CONSTANT) - allocate(tmp(node_count(b))) - tmp=b%val(1) - if(present(scale)) then - do i = 1, size(A,1) - call addto(A, i, i, tmp(i)*scale) - end do - else - do i = 1, size(A,1) - call addto(A, i, i, tmp(i)) - end do - end if - deallocate(tmp) - end select + end subroutine csr_mult_vector + + subroutine block_csr_mult_addto_vector(x, A, b) + !!< Calculate x=A*b + type(vector_field), intent(inout) :: x + type(block_csr_matrix), intent(in) :: A + type(vector_field), intent(in) :: b + + integer :: i, j + type(scalar_field) :: x_comp, b_comp + type(csr_matrix) :: A_block + + assert(x%dim==b%dim) + call zero(x) + do i = 1, b%dim + b_comp = extract_scalar_field(b, i) + if(A%diagonal) then + x_comp = extract_scalar_field(x, i) + A_block = block(A,i,i) + call mult_addto(x_comp, A_block, b_comp) + else + do j = 1, b%dim + x_comp = extract_scalar_field(x, j) + A_block = block(A,i,j) + call mult_addto(x_comp, A_block, b_comp) + end do + end if + end do + end subroutine block_csr_mult_addto_vector + + subroutine csr_diag_mult_scalar(A, b) + !!< Calculate A_{i,i}=A_{i,i}*b_{i} + !!< A_{i,j}=A_{i,j}, i/=j + type(csr_matrix), intent(inout) :: A + type(scalar_field), intent(in) :: b + real, dimension(:), allocatable :: tmp + integer :: i + + assert(size(A,1)==node_count(b)) + assert(size(A,2)==node_count(b)) + + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, size(A,1) + call set(A, i, i, val(A, i, i)*b%val(i)) + end do + case(FIELD_TYPE_CONSTANT) + allocate(tmp(node_count(b))) + tmp=b%val(1) + do i = 1, size(A,1) + call set(A, i, i, val(A, i, i)*tmp(i)) + end do + deallocate(tmp) + end select - end subroutine csr_diag_addto_scalar + end subroutine csr_diag_mult_scalar - subroutine block_csr_diag_addto_scalar(A, b, scale) - !!< Calculate X_{i,i}=A_{i,i}*b_{i} - !!< X_{i,j}=A_{i,j}, i/=j - type(block_csr_matrix), intent(inout) :: A - type(scalar_field), intent(in) :: b - real, optional, intent(in) :: scale - real, dimension(:), allocatable :: tmp - integer :: i, j - real :: l_scale - type(csr_matrix) :: block_A + subroutine csr_diag_mult_scalar_v(A, b) + !!< Calculate A_{i,i}=A_{i,i}*b_{i} + !!< A_{i,j}=A_{i,j}, i/=j + type(csr_matrix), intent(inout) :: A + real, dimension(:), intent(in) :: b + integer :: i - if(present(scale)) then - l_scale = scale - else - l_scale = 1.0 - end if + assert(size(A,1)==size(b)) + assert(size(A,2)==size(b)) - assert(A%blocks(1)==A%blocks(2)) + do i = 1, size(A,1) + call set(A, i, i, val(A, i, i)*b(i)) + end do - do j = 1, A%blocks(1) + end subroutine csr_diag_mult_scalar_v - block_A = block(A, j, j) + subroutine csr_diag_addto_scalar(A, b, scale) + !!< Calculate X_{i,i}=A_{i,i}*b_{i} + !!< X_{i,j}=A_{i,j}, i/=j + type(csr_matrix), intent(inout) :: A + type(scalar_field), intent(in) :: b + real, optional, intent(in) :: scale + real, dimension(:), allocatable :: tmp + integer :: i - assert(size(block_A,1)==node_count(b)) - assert(size(block_A,2)==node_count(b)) + assert(size(A,1)==node_count(b)) + assert(size(A,2)==node_count(b)) select case(b%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, size(block_A,1) - call addto(block_A, i, i, b%val(i)*l_scale) - end do - case(FIELD_TYPE_CONSTANT) - allocate(tmp(node_count(b))) - tmp=b%val(1) - do i = 1, size(block_A,1) - call addto(block_A, i, i, tmp(i)*l_scale) - end do - deallocate(tmp) + case(FIELD_TYPE_NORMAL) + if(present(scale)) then + do i = 1, size(A,1) + call addto(A, i, i, b%val(i)*scale) + end do + else + do i = 1, size(A,1) + call addto(A, i, i, b%val(i)) + end do + end if + case(FIELD_TYPE_CONSTANT) + allocate(tmp(node_count(b))) + tmp=b%val(1) + if(present(scale)) then + do i = 1, size(A,1) + call addto(A, i, i, tmp(i)*scale) + end do + else + do i = 1, size(A,1) + call addto(A, i, i, tmp(i)) + end do + end if + deallocate(tmp) end select - end do + end subroutine csr_diag_addto_scalar + + subroutine block_csr_diag_addto_scalar(A, b, scale) + !!< Calculate X_{i,i}=A_{i,i}*b_{i} + !!< X_{i,j}=A_{i,j}, i/=j + type(block_csr_matrix), intent(inout) :: A + type(scalar_field), intent(in) :: b + real, optional, intent(in) :: scale + real, dimension(:), allocatable :: tmp + integer :: i, j + real :: l_scale + type(csr_matrix) :: block_A - end subroutine block_csr_diag_addto_scalar + if(present(scale)) then + l_scale = scale + else + l_scale = 1.0 + end if - subroutine petsc_csr_diag_addto_scalar(A, b, scale) - !!< Calculate X_{i,i}=A_{i,i}*b_{i} - !!< X_{i,j}=A_{i,j}, i/=j - type(petsc_csr_matrix), intent(inout) :: A - type(scalar_field), intent(in) :: b - real, optional, intent(in) :: scale - real, dimension(:), allocatable :: tmp - integer :: i, j - real :: l_scale + assert(A%blocks(1)==A%blocks(2)) - if(present(scale)) then - l_scale = scale - else - l_scale = 1.0 - end if + do j = 1, A%blocks(1) - assert( blocks(A,1)==blocks(A,2) ) - assert( block_size(A,1)==node_count(b) ) - assert( block_size(A,2)==node_count(b) ) + block_A = block(A, j, j) - do j = 1, blocks(A,1) + assert(size(block_A,1)==node_count(b)) + assert(size(block_A,2)==node_count(b)) - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, block_size(A,1) - call addto(A, j, j, i, i, b%val(i)*l_scale) - end do - case(FIELD_TYPE_CONSTANT) - allocate(tmp(node_count(b))) - tmp=b%val(1) - do i = 1, block_size(A,1) - call addto(A, j, j, i, i, tmp(i)*l_scale) - end do - deallocate(tmp) - end select + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, size(block_A,1) + call addto(block_A, i, i, b%val(i)*l_scale) + end do + case(FIELD_TYPE_CONSTANT) + allocate(tmp(node_count(b))) + tmp=b%val(1) + do i = 1, size(block_A,1) + call addto(block_A, i, i, tmp(i)*l_scale) + end do + deallocate(tmp) + end select - end do + end do - end subroutine petsc_csr_diag_addto_scalar + end subroutine block_csr_diag_addto_scalar - subroutine petsc_csr_diag_addto_vector(A, b, scale) - !!< Calculate X_{i,i}=A_{i,i}*b_{i} - !!< X_{i,j}=A_{i,j}, i/=j - type(petsc_csr_matrix), intent(inout) :: A - type(vector_field), intent(in) :: b - real, optional, intent(in) :: scale - real, dimension(:), allocatable :: tmp - integer :: i, j - real :: l_scale + subroutine petsc_csr_diag_addto_scalar(A, b, scale) + !!< Calculate X_{i,i}=A_{i,i}*b_{i} + !!< X_{i,j}=A_{i,j}, i/=j + type(petsc_csr_matrix), intent(inout) :: A + type(scalar_field), intent(in) :: b + real, optional, intent(in) :: scale + real, dimension(:), allocatable :: tmp + integer :: i, j + real :: l_scale - if(present(scale)) then - l_scale = scale - else - l_scale = 1.0 - end if + if(present(scale)) then + l_scale = scale + else + l_scale = 1.0 + end if - assert( blocks(A,1)==blocks(A,2) ) - assert( block_size(A,1)==node_count(b) ) - assert( block_size(A,2)==node_count(b) ) + assert( blocks(A,1)==blocks(A,2) ) + assert( block_size(A,1)==node_count(b) ) + assert( block_size(A,2)==node_count(b) ) - do j = 1, blocks(A,1) + do j = 1, blocks(A,1) - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - do i = 1, block_size(A,1) - call addto(A, j, j, i, i, b%val(j,i)*l_scale) - end do - case(FIELD_TYPE_CONSTANT) - allocate(tmp(node_count(b))) - tmp=b%val(j,:) - do i = 1, block_size(A,1) - call addto(A, j, j, i, i, tmp(i)*l_scale) - end do - deallocate(tmp) - end select + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, block_size(A,1) + call addto(A, j, j, i, i, b%val(i)*l_scale) + end do + case(FIELD_TYPE_CONSTANT) + allocate(tmp(node_count(b))) + tmp=b%val(1) + do i = 1, block_size(A,1) + call addto(A, j, j, i, i, tmp(i)*l_scale) + end do + deallocate(tmp) + end select - end do + end do - end subroutine petsc_csr_diag_addto_vector + end subroutine petsc_csr_diag_addto_scalar - subroutine block_csr_extract_diagonal(A,diagonal) - !!< Extracts diagonal components of a block_csr matrix. - !!< The vector field diagonal needs to be allocated before the call. + subroutine petsc_csr_diag_addto_vector(A, b, scale) + !!< Calculate X_{i,i}=A_{i,i}*b_{i} + !!< X_{i,j}=A_{i,j}, i/=j + type(petsc_csr_matrix), intent(inout) :: A + type(vector_field), intent(in) :: b + real, optional, intent(in) :: scale + real, dimension(:), allocatable :: tmp + integer :: i, j + real :: l_scale - type(block_csr_matrix), intent(in) :: A - type(vector_field), intent(inout) :: diagonal - integer i, j + if(present(scale)) then + l_scale = scale + else + l_scale = 1.0 + end if - assert( diagonal%dim==blocks(A,1) ) - assert( node_count(diagonal)==block_size(A,1)) - assert( block_size(A,1)==block_size(A,2)) - assert( blocks(A,1)==blocks(A,2)) + assert( blocks(A,1)==blocks(A,2) ) + assert( block_size(A,1)==node_count(b) ) + assert( block_size(A,2)==node_count(b) ) - if (associated(A%sparsity%centrm)) then - do i=1, blocks(A,1) - call set_all(diagonal, i, A%val(i,i)%ptr(A%sparsity%centrm)) - end do - else - do i=1, blocks(A,1) - do j=1, block_size(A,1) - call set(diagonal, i, j, val(A, i, i, j, j)) - end do - end do - end if + do j = 1, blocks(A,1) - end subroutine block_csr_extract_diagonal + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + do i = 1, block_size(A,1) + call addto(A, j, j, i, i, b%val(j,i)*l_scale) + end do + case(FIELD_TYPE_CONSTANT) + allocate(tmp(node_count(b))) + tmp=b%val(j,:) + do i = 1, block_size(A,1) + call addto(A, j, j, i, i, tmp(i)*l_scale) + end do + deallocate(tmp) + end select - subroutine csr_mult_scalar_vector(x, A, b) - !!< Calculate x=A*b Where b is a vector field, A is a 1*dim block - !!< block_csr_matrix and x is a scalar field. - type(scalar_field), intent(inout) :: x - type(block_csr_matrix), intent(in) :: A - type(vector_field), intent(in) :: b + end do - real, dimension(:), allocatable :: tmpb, tmpx - integer :: dim + end subroutine petsc_csr_diag_addto_vector - assert(all(A%blocks==(/1,b%dim/))) + subroutine block_csr_extract_diagonal(A,diagonal) + !!< Extracts diagonal components of a block_csr matrix. + !!< The vector field diagonal needs to be allocated before the call. - allocate(tmpx(size(x%val))) - call zero(x) + type(block_csr_matrix), intent(in) :: A + type(vector_field), intent(inout) :: diagonal + integer i, j - do dim=1,b%dim - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - call mult(tmpx, block(A,1,dim), b%val(dim,:)) - case(FIELD_TYPE_CONSTANT) - allocate(tmpb(size(x%val))) - tmpb=b%val(dim,1) - call mult(tmpx, block(A,1,dim), tmpb) - deallocate(tmpb) - end select - x%val=x%val+tmpx - end do + assert( diagonal%dim==blocks(A,1) ) + assert( node_count(diagonal)==block_size(A,1)) + assert( block_size(A,1)==block_size(A,2)) + assert( blocks(A,1)==blocks(A,2)) - end subroutine csr_mult_scalar_vector + if (associated(A%sparsity%centrm)) then + do i=1, blocks(A,1) + call set_all(diagonal, i, A%val(i,i)%ptr(A%sparsity%centrm)) + end do + else + do i=1, blocks(A,1) + do j=1, block_size(A,1) + call set(diagonal, i, j, val(A, i, i, j, j)) + end do + end do + end if - subroutine csr_mult_vector_scalar(x, A, b) - !!< Calculate x=A*b Where b is a scalar field, A is a dim*1 block - !!< block_csr_matrix and x is a vector field. - type(vector_field), intent(inout) :: x - type(block_csr_matrix), intent(in) :: A - type(scalar_field), intent(in) :: b + end subroutine block_csr_extract_diagonal - real, dimension(:), allocatable :: tmpb - integer :: dim + subroutine csr_mult_scalar_vector(x, A, b) + !!< Calculate x=A*b Where b is a vector field, A is a 1*dim block + !!< block_csr_matrix and x is a scalar field. + type(scalar_field), intent(inout) :: x + type(block_csr_matrix), intent(in) :: A + type(vector_field), intent(in) :: b - assert(all(A%blocks==(/x%dim,1/))) + real, dimension(:), allocatable :: tmpb, tmpx + integer :: dim - call zero(x) + assert(all(A%blocks==(/1,b%dim/))) - do dim=1,x%dim - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - call mult(x%val(dim,:), block(A,dim,1), b%val) - case(FIELD_TYPE_CONSTANT) - allocate(tmpb(size(x%val(dim,:)))) - tmpb=b%val - call mult(x%val(dim,:), block(A,dim,1), tmpb) - deallocate(tmpb) - end select - end do + allocate(tmpx(size(x%val))) + call zero(x) - end subroutine csr_mult_vector_scalar + do dim=1,b%dim + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + call mult(tmpx, block(A,1,dim), b%val(dim,:)) + case(FIELD_TYPE_CONSTANT) + allocate(tmpb(size(x%val))) + tmpb=b%val(dim,1) + call mult(tmpx, block(A,1,dim), tmpb) + deallocate(tmpb) + end select + x%val=x%val+tmpx + end do - subroutine csr_mult_vector_vector(x, A, b) - !!< Calculate x=A*b Where b is a vector field, A is a dim_x*dim_b block - !!< block_csr_matrix and x is a vector field. - type(vector_field), intent(inout) :: x - type(block_csr_matrix), intent(in) :: A - type(vector_field), intent(in) :: b + end subroutine csr_mult_scalar_vector - real, dimension(:), allocatable :: tmpb, tmpx - integer :: dim_x, dim_b + subroutine csr_mult_vector_scalar(x, A, b) + !!< Calculate x=A*b Where b is a scalar field, A is a dim*1 block + !!< block_csr_matrix and x is a vector field. + type(vector_field), intent(inout) :: x + type(block_csr_matrix), intent(in) :: A + type(scalar_field), intent(in) :: b - assert(all(A%blocks==(/x%dim,b%dim/))) + real, dimension(:), allocatable :: tmpb + integer :: dim - allocate(tmpx(size(x%val(1,:)))) - call zero(x) + assert(all(A%blocks==(/x%dim,1/))) - do dim_x=1,x%dim - do dim_b=1,b%dim - if (A%diagonal .and. dim_b/=dim_x) cycle + call zero(x) - select case(b%field_type) + do dim=1,x%dim + select case(b%field_type) case(FIELD_TYPE_NORMAL) - call mult(tmpx, block(A,dim_x,dim_b), b%val(dim_b,:)) + call mult(x%val(dim,:), block(A,dim,1), b%val) case(FIELD_TYPE_CONSTANT) - allocate(tmpb(size(x%val))) - tmpb=b%val(dim_b,dim_x) - call mult(tmpx, block(A,dim_x,dim_b), tmpb) - deallocate(tmpb) - end select - x%val(dim_x,:)=x%val(dim_x,:)+tmpx - end do - end do - - end subroutine csr_mult_vector_vector - - subroutine csr_mult_T_scalar(x, A, b) - !!< Calculate x=A^T*b - type(scalar_field), intent(inout) :: x - type(csr_matrix), intent(in) :: A - type(scalar_field), intent(in) :: b - real, dimension(:), allocatable :: tmp - - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - call mult_T(x%val, A, b%val) - case(FIELD_TYPE_CONSTANT) - allocate(tmp(size(x%val))) - tmp=b%val(1) - call mult_T(x%val, A, tmp) - deallocate(tmp) - end select - - end subroutine csr_mult_T_scalar - - subroutine csr_mult_T_addto_scalar(x, A, b) - !!< Calculate x=A^T*b - type(scalar_field), intent(inout) :: x - type(csr_matrix), intent(in) :: A - type(scalar_field), intent(in) :: b - real, dimension(:), allocatable :: tmp - - select case(b%field_type) - case(FIELD_TYPE_NORMAL) - call mult_T_addto(x%val, A, b%val) - case(FIELD_TYPE_CONSTANT) - allocate(tmp(size(x%val))) - tmp=b%val(1) - call mult_T_addto(x%val, A, tmp) - deallocate(tmp) - end select - - end subroutine csr_mult_T_addto_scalar - - subroutine csr_mult_T_vector_scalar(x, A, b) - !!< Calculate x=A^T*b Where b is a scalar field, A is a 1*dim block - !!< block_csr_matrix and x is a vector field. - type(vector_field), intent(inout) :: x - type(block_csr_matrix), intent(in) :: A - type(scalar_field), intent(in) :: b - - real, dimension(:), allocatable :: tmpb - integer :: dim - - assert(all(A%blocks==(/1,x%dim/))) - - call zero(x) - - do dim=1,x%dim - select case(b%field_type) + allocate(tmpb(size(x%val(dim,:)))) + tmpb=b%val + call mult(x%val(dim,:), block(A,dim,1), tmpb) + deallocate(tmpb) + end select + end do + + end subroutine csr_mult_vector_scalar + + subroutine csr_mult_vector_vector(x, A, b) + !!< Calculate x=A*b Where b is a vector field, A is a dim_x*dim_b block + !!< block_csr_matrix and x is a vector field. + type(vector_field), intent(inout) :: x + type(block_csr_matrix), intent(in) :: A + type(vector_field), intent(in) :: b + + real, dimension(:), allocatable :: tmpb, tmpx + integer :: dim_x, dim_b + + assert(all(A%blocks==(/x%dim,b%dim/))) + + allocate(tmpx(size(x%val(1,:)))) + call zero(x) + + do dim_x=1,x%dim + do dim_b=1,b%dim + if (A%diagonal .and. dim_b/=dim_x) cycle + + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + call mult(tmpx, block(A,dim_x,dim_b), b%val(dim_b,:)) + case(FIELD_TYPE_CONSTANT) + allocate(tmpb(size(x%val))) + tmpb=b%val(dim_b,dim_x) + call mult(tmpx, block(A,dim_x,dim_b), tmpb) + deallocate(tmpb) + end select + x%val(dim_x,:)=x%val(dim_x,:)+tmpx + end do + end do + + end subroutine csr_mult_vector_vector + + subroutine csr_mult_T_scalar(x, A, b) + !!< Calculate x=A^T*b + type(scalar_field), intent(inout) :: x + type(csr_matrix), intent(in) :: A + type(scalar_field), intent(in) :: b + real, dimension(:), allocatable :: tmp + + select case(b%field_type) case(FIELD_TYPE_NORMAL) - call mult_T(x%val(dim,:), block(A,1,dim), b%val) + call mult_T(x%val, A, b%val) case(FIELD_TYPE_CONSTANT) - allocate(tmpb(node_count(b))) - tmpb=b%val(1) - call mult_T(x%val(dim,:), block(A,1,dim), tmpb) - deallocate(tmpb) - end select - end do + allocate(tmp(size(x%val))) + tmp=b%val(1) + call mult_T(x%val, A, tmp) + deallocate(tmp) + end select - end subroutine csr_mult_T_vector_scalar + end subroutine csr_mult_T_scalar - subroutine csr_mult_T_vector_vector(x, A, b) - !!< Calculate x=A^T*b, where b is a vector fields, A is a dim_b*dim_x block - !!< block_csr_matrix and x is a vector field. - type(vector_field), intent(inout) :: x - type(block_csr_matrix), intent(in) :: A - type(vector_field), intent(in) :: b + subroutine csr_mult_T_addto_scalar(x, A, b) + !!< Calculate x=A^T*b + type(scalar_field), intent(inout) :: x + type(csr_matrix), intent(in) :: A + type(scalar_field), intent(in) :: b + real, dimension(:), allocatable :: tmp - real, dimension(:), allocatable :: tmpb, tmpx - integer :: dim_x, dim_b + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + call mult_T_addto(x%val, A, b%val) + case(FIELD_TYPE_CONSTANT) + allocate(tmp(size(x%val))) + tmp=b%val(1) + call mult_T_addto(x%val, A, tmp) + deallocate(tmp) + end select + + end subroutine csr_mult_T_addto_scalar + + subroutine csr_mult_T_vector_scalar(x, A, b) + !!< Calculate x=A^T*b Where b is a scalar field, A is a 1*dim block + !!< block_csr_matrix and x is a vector field. + type(vector_field), intent(inout) :: x + type(block_csr_matrix), intent(in) :: A + type(scalar_field), intent(in) :: b - assert(all(A%blocks==(/b%dim,x%dim/))) + real, dimension(:), allocatable :: tmpb + integer :: dim - allocate(tmpx(size(x%val(1,:)))) - call zero(x) + assert(all(A%blocks==(/1,x%dim/))) - do dim_x=1,x%dim - do dim_b=1,b%dim - if (A%diagonal .and. dim_b/=dim_x) cycle + call zero(x) - select case(b%field_type) + do dim=1,x%dim + select case(b%field_type) case(FIELD_TYPE_NORMAL) - call mult_T(tmpx, block(A,dim_b,dim_x), b%val(dim_b,:)) + call mult_T(x%val(dim,:), block(A,1,dim), b%val) case(FIELD_TYPE_CONSTANT) - allocate(tmpb(size(x%val))) - tmpb=b%val(dim_b,dim_x) - call mult_T(tmpx, block(A,dim_b,dim_x), tmpb) - deallocate(tmpb) - end select - x%val(dim_x,:)=x%val(dim_x,:)+tmpx - end do - end do - - end subroutine csr_mult_T_vector_vector - - subroutine mult_div_vector_div_T(product, matrix1, vfield, matrix2) - !!< Perform the matrix multiplication: - !!< - !!< product = matrix1*diag(vector)*matrix2^T - !!< - !!< Only works on block csr matrices with monotonic row entries in colm - type(csr_matrix) :: product - type(block_csr_matrix), intent(in) :: matrix1, matrix2 - type(vector_field), intent(in) :: vfield - - integer, dimension(:), pointer :: row, col, row_product - type(real_vector), dimension(blocks(matrix1,2)) :: row_val, col_val - integer :: i,j,k1,k2,jcol,dim,ndim - real :: entry0 - integer :: nentry0 - - ewrite(1,*) 'Entering mult_div_invvector_div_T' - - call zero(product) - - nentry0 = 0 - assert(size(matrix1,2)==size(matrix2,2)) - assert(size(matrix1,1)==size(product,1)) - assert(size(matrix2,1)==size(product,2)) - assert(blocks(matrix1,1)==blocks(matrix2,1)) - assert(blocks(matrix1,2)==blocks(matrix2,2)) - assert(blocks(matrix1,2)==vfield%dim) - assert(blocks(matrix1,1)==1) - - ndim = blocks(matrix1,2) - - if(.not.matrix1%sparsity%sorted_rows.or..not.matrix2%sparsity%sorted_rows) then - FLAbort("mult_div_invvector_div_T assumes sorted rows") - end if - - ! multiplication M_ij=A_ik * D_k * B_jk - - do i=1, size(matrix1%sparsity,1) - row=>row_m_ptr(matrix1, i) - - do dim = 1, ndim - row_val(dim)%ptr=>row_val_ptr(matrix1, 1, dim, i) - end do - - row_product=>row_m_ptr(product, i) - do jcol = 1, size(row_product) - j = row_product(jcol) - - col=>row_m_ptr(matrix2, j) + allocate(tmpb(node_count(b))) + tmpb=b%val(1) + call mult_T(x%val(dim,:), block(A,1,dim), tmpb) + deallocate(tmpb) + end select + end do + + end subroutine csr_mult_T_vector_scalar + + subroutine csr_mult_T_vector_vector(x, A, b) + !!< Calculate x=A^T*b, where b is a vector fields, A is a dim_b*dim_x block + !!< block_csr_matrix and x is a vector field. + type(vector_field), intent(inout) :: x + type(block_csr_matrix), intent(in) :: A + type(vector_field), intent(in) :: b + + real, dimension(:), allocatable :: tmpb, tmpx + integer :: dim_x, dim_b + + assert(all(A%blocks==(/b%dim,x%dim/))) + + allocate(tmpx(size(x%val(1,:)))) + call zero(x) + + do dim_x=1,x%dim + do dim_b=1,b%dim + if (A%diagonal .and. dim_b/=dim_x) cycle + + select case(b%field_type) + case(FIELD_TYPE_NORMAL) + call mult_T(tmpx, block(A,dim_b,dim_x), b%val(dim_b,:)) + case(FIELD_TYPE_CONSTANT) + allocate(tmpb(size(x%val))) + tmpb=b%val(dim_b,dim_x) + call mult_T(tmpx, block(A,dim_b,dim_x), tmpb) + deallocate(tmpb) + end select + x%val(dim_x,:)=x%val(dim_x,:)+tmpx + end do + end do + + end subroutine csr_mult_T_vector_vector + + subroutine mult_div_vector_div_T(product, matrix1, vfield, matrix2) + !!< Perform the matrix multiplication: + !!< + !!< product = matrix1*diag(vector)*matrix2^T + !!< + !!< Only works on block csr matrices with monotonic row entries in colm + type(csr_matrix) :: product + type(block_csr_matrix), intent(in) :: matrix1, matrix2 + type(vector_field), intent(in) :: vfield + + integer, dimension(:), pointer :: row, col, row_product + type(real_vector), dimension(blocks(matrix1,2)) :: row_val, col_val + integer :: i,j,k1,k2,jcol,dim,ndim + real :: entry0 + integer :: nentry0 + + ewrite(1,*) 'Entering mult_div_invvector_div_T' + + call zero(product) + + nentry0 = 0 + assert(size(matrix1,2)==size(matrix2,2)) + assert(size(matrix1,1)==size(product,1)) + assert(size(matrix2,1)==size(product,2)) + assert(blocks(matrix1,1)==blocks(matrix2,1)) + assert(blocks(matrix1,2)==blocks(matrix2,2)) + assert(blocks(matrix1,2)==vfield%dim) + assert(blocks(matrix1,1)==1) + + ndim = blocks(matrix1,2) + + if(.not.matrix1%sparsity%sorted_rows.or..not.matrix2%sparsity%sorted_rows) then + FLAbort("mult_div_invvector_div_T assumes sorted rows") + end if + + ! multiplication M_ij=A_ik * D_k * B_jk + + do i=1, size(matrix1%sparsity,1) + row=>row_m_ptr(matrix1, i) + do dim = 1, ndim - col_val(dim)%ptr=>row_val_ptr(matrix2, 1, dim, j) + row_val(dim)%ptr=>row_val_ptr(matrix1, 1, dim, i) end do - ! to compute entry M_ij find common column indices k in rows - ! A_ik and B_jk - this is done by walking through them together - ! from left to right, where we're using that both are stored - ! in sorted order - - entry0=0.0 - - k1 = 1 - k2 = 1 - do while (k1<=size(row) .and. k2<=size(col)) - if(row(k1)row_m_ptr(product, i) + do jcol = 1, size(row_product) + j = row_product(jcol) + + col=>row_m_ptr(matrix2, j) + do dim = 1, ndim + col_val(dim)%ptr=>row_val_ptr(matrix2, 1, dim, j) + end do + + ! to compute entry M_ij find common column indices k in rows + ! A_ik and B_jk - this is done by walking through them together + ! from left to right, where we're using that both are stored + ! in sorted order + + entry0=0.0 + + k1 = 1 + k2 = 1 + do while (k1<=size(row) .and. k2<=size(col)) + if(row(k1)row_m_ptr(matrix1, i) - - if(size(row)>0) then - row_val=>row_val_ptr(matrix1, i) - - row_product=>row_m_ptr(product, i) - do jcol = 1, size(row_product) - j = row_product(jcol) - - col=>row_m_ptr(matrix2, j) - col_val=>row_val_ptr(matrix2, j) - - if(size(col)>0) then - entry0=0.0 - - addflag = .false. - - k1 = 1 - k2 = 1 - do - if((k1.gt.size(row)).or.(k2.gt.size(col))) exit - if(row(k1)row_m_ptr(matrix1, i) + + if(size(row)>0) then + row_val=>row_val_ptr(matrix1, i) + + row_product=>row_m_ptr(product, i) + do jcol = 1, size(row_product) + j = row_product(jcol) + + col=>row_m_ptr(matrix2, j) + col_val=>row_val_ptr(matrix2, j) + + if(size(col)>0) then + entry0=0.0 + + addflag = .false. + + k1 = 1 + k2 = 1 + do + if((k1.gt.size(row)).or.(k2.gt.size(col))) exit + if(row(k1)row_m_ptr(matrix1, i) - - if(size(row)>0) then - do dim = 1, ndim - row_val(dim)%ptr=>row_val_ptr(matrix1, 1, dim, i) - end do + addflag = .true. + k1 = k1 + 1 + k2 = k2 + 1 + else + k2 = k2 + 1 + end if + end if + end do + if(addflag) then + nentry0 = nentry0 + 1 + product%val(nentry0) = entry0 + end if + end if + end do + end if + end do - row_product=>row_m_ptr(product, i) - do jcol = 1, size(row_product) - j = row_product(jcol) + end subroutine mult_div_invscalar_div_T - col=>row_m_ptr(matrix2, j) - do dim = 1, ndim - col_val(dim)%ptr=>row_val_ptr(matrix2, 1, dim, j) - end do - - if(size(col)>0) then - entry0=0.0 - - addflag = .false. - - k1 = 1 - k2 = 1 - do - if((k1.gt.size(row)).or.(k2.gt.size(col))) exit - if(row(k1)row_m_ptr(matrix1, i) - - if(size(row)>0) then - do dim1 = 1, ndim - row_val(dim1)%ptr=>row_val_ptr(matrix1, 1, dim1, i) - end do - - row_product=>row_m_ptr(product, i) - do jcol = 1, size(row_product) - j = row_product(jcol) - - col=>row_m_ptr(matrix2, j) - do dim1 = 1, ndim - col_val(dim1)%ptr=>row_val_ptr(matrix2, 1, dim1, j) - end do - - if(size(col)>0) then - entry0=0.0 - - addflag = .false. - - k1 = 1 - k2 = 1 - do - if((k1.gt.size(row)).or.(k2.gt.size(col))) exit - if(row(k1)row_m_ptr(matrix1, i) + + if(size(row)>0) then + do dim = 1, ndim + row_val(dim)%ptr=>row_val_ptr(matrix1, 1, dim, i) + end do + + row_product=>row_m_ptr(product, i) + do jcol = 1, size(row_product) + j = row_product(jcol) + + col=>row_m_ptr(matrix2, j) + do dim = 1, ndim + col_val(dim)%ptr=>row_val_ptr(matrix2, 1, dim, j) + end do + + if(size(col)>0) then + entry0=0.0 + + addflag = .false. + + k1 = 1 + k2 = 1 + do + if((k1.gt.size(row)).or.(k2.gt.size(col))) exit + if(row(k1)row_m_ptr(matrix1, i) + + if(size(row)>0) then + do dim1 = 1, ndim + row_val(dim1)%ptr=>row_val_ptr(matrix1, 1, dim1, i) + end do + + row_product=>row_m_ptr(product, i) + do jcol = 1, size(row_product) + j = row_product(jcol) + + col=>row_m_ptr(matrix2, j) + do dim1 = 1, ndim + col_val(dim1)%ptr=>row_val_ptr(matrix2, 1, dim1, j) + end do + + if(size(col)>0) then + entry0=0.0 + + addflag = .false. + + k1 = 1 + k2 = 1 + do + if((k1.gt.size(row)).or.(k2.gt.size(col))) exit + if(row(k1)row_m_ptr(matrix1, row) - - if(size(row_indices)>0) then - do dim1 = 1, ndim - row_val(dim1)%ptr=>row_val_ptr(matrix1, 1, dim1, row) - end do - - entry0 = 0.0 - - if(l_isotropic) then - do dim1 = 1, tfield%dim(1) - entry0 = entry0 + & - sum((row_val(dim1)%ptr*node_val(tfield, dim1, dim1, row_indices)& - /node_val(sfield, row_indices))& - *node_val(vfield, dim1, row_indices)) - end do - else - do dim1 = 1, tfield%dim(1) - do dim2 = 1, tfield%dim(2) - entry0 = entry0 + & - sum((row_val(dim1)%ptr*node_val(tfield, dim1, dim2, row_indices)& - /node_val(sfield, row_indices))& - *node_val(vfield, dim2, row_indices)) + else + do dim1 = 1, ndim + do dim2 = 1, ndim + entry0=entry0+row_val(dim1)%ptr(k1)* & + col_val(dim2)%ptr(k2)*node_val(tfield, dim1, dim2, row(k1))& + /node_val(sfield, row(k1)) + end do + end do + end if + addflag = .true. + k1 = k1 + 1 + k2 = k2 + 1 + else + k2 = k2 + 1 + end if + end if + end do + if(addflag) then + nentry0 = nentry0 + 1 + product%val(nentry0) = entry0 + end if + end if end do - end do - end if + end if + end do + + end subroutine mult_div_tensorinvscalar_div_T + + subroutine mult_div_tensorinvscalar_vector(product, matrix1, tfield, sfield, vfield, isotropic) + !!< Perform the matrix multiplication: + !!< + !!< product = matrix1*tensor*diag(1./vector)*vfield + !!< + !!< Note that product is not zeroed by this subroutine! + type(scalar_field), intent(inout) :: product + type(block_csr_matrix), intent(in) :: matrix1 + type(tensor_field), intent(in) :: tfield + type(scalar_field), intent(in) :: sfield + type(vector_field), intent(in) :: vfield + logical, optional :: isotropic + + integer :: dim1, dim2, ndim, row + type(real_vector), dimension(blocks(matrix1, 2)) :: row_val + integer, dimension(:), pointer :: row_indices + real :: entry0 + + logical :: l_isotropic - call addto(product, row, entry0) + ewrite(1,*) 'Entering mult_div_tensorinvscalar_vector' + + if(present(isotropic)) then + l_isotropic = isotropic + else + l_isotropic = .false. end if - end do + ndim = blocks(matrix1, 2) + + do row = 1, size(matrix1, 1) + row_indices=>row_m_ptr(matrix1, row) + + if(size(row_indices)>0) then + do dim1 = 1, ndim + row_val(dim1)%ptr=>row_val_ptr(matrix1, 1, dim1, row) + end do + + entry0 = 0.0 + + if(l_isotropic) then + do dim1 = 1, tfield%dim(1) + entry0 = entry0 + & + sum((row_val(dim1)%ptr*node_val(tfield, dim1, dim1, row_indices)& + /node_val(sfield, row_indices))& + *node_val(vfield, dim1, row_indices)) + end do + else + do dim1 = 1, tfield%dim(1) + do dim2 = 1, tfield%dim(2) + entry0 = entry0 + & + sum((row_val(dim1)%ptr*node_val(tfield, dim1, dim2, row_indices)& + /node_val(sfield, row_indices))& + *node_val(vfield, dim2, row_indices)) + end do + end do + end if + + call addto(product, row, entry0) + end if + + end do - end subroutine mult_div_tensorinvscalar_vector + end subroutine mult_div_tensorinvscalar_vector end module sparse_matrices_fields diff --git a/femtools/Sparse_Tools.F90 b/femtools/Sparse_Tools.F90 index 153f8e8879..c173a2d8ee 100644 --- a/femtools/Sparse_Tools.F90 +++ b/femtools/Sparse_Tools.F90 @@ -26,400 +26,400 @@ ! USA #include "fdebug.h" module sparse_tools - !!< This module implements abstract data types for sparse matrices and - !!< operations on them. - use FLDebug - use Global_Parameters, only: FIELD_NAME_LEN - use Futils - use Reference_Counting - use Halo_data_types - use halos_allocates - use memory_diagnostics - use ieee_arithmetic - use data_structures - use petsc - - implicit none + !!< This module implements abstract data types for sparse matrices and + !!< operations on them. + use FLDebug + use Global_Parameters, only: FIELD_NAME_LEN + use Futils + use Reference_Counting + use Halo_data_types + use halos_allocates + use memory_diagnostics + use ieee_arithmetic + use data_structures + use petsc + + implicit none #include "petsc_legacy.h" - private - - type csr_sparsity - !!< Encapsulating type for the sparsity patter of a sparse matrix. - - !! Findrm is the indices of the row starts in colm. - integer, dimension(:), pointer :: findrm=>null() - !! Centrm is the indices of the main diagonal in colm. - integer, dimension(:), pointer :: centrm=>null() - !! Colm is the list of matrix j values. - integer, dimension(:), pointer :: colm=>null() - !! Number of columns in matrix. - integer :: columns - !! The halos associated with the rows and columns of the matrix. - type(halo_type), pointer :: row_halo => null(), column_halo => null() - !! Reference counting - type(refcount_type), pointer :: refcount => null() - !! Name - character(len=FIELD_NAME_LEN) :: name="" - !! Flag to indicate whether a matrix was allocated or wrapped. - logical :: wrapped=.false. - !! Flag to indicate whether each row in colm is sorted in ascending j - !! order. If true this enables a faster binary search for entries - !! during matrix accesses. - logical :: sorted_rows=.false. - end type csr_sparsity - - type csr_sparsity_pointer - type(csr_sparsity), pointer :: ptr => null() - end type csr_sparsity_pointer - - ! construct to avoid mem. leaks if people add an inactive array to a borrowed reference - type logical_array_ptr - logical, dimension(:), pointer :: ptr => null() - end type - - type csr_matrix - !!< Encapsulating type for a sparse matrix. - - !! The sparsity pattern for this matrix. - type(csr_sparsity) :: sparsity - !! The values of nonzero real entries - real, dimension(:), pointer :: val=>null() - !! The values of nonzero integer entries - integer, dimension(:), pointer :: ival=>null() - !! Flag to indicate whether a matrix was allocated or cloned. - logical :: clone=.false. - !! Flag to indicate value space has been externally supplied - !! so it shouldn't be deallocated (only used for clone==.true.) - logical :: external_val=.false. - !! for nodes with inactive%ptr(node)==.true. the rows and columns - !! will be left out of the matrix equation solved in petsc_solve() - !! NOTE: %inactive should always be allocated for any allocated csr_matrix - !! %inactive%ptr may not be allocated, in which case all nodes are "active" - !! As %inactive is directly allocated from the start the %inactive%ptr pointer and its - !! association status are always the same for all references of the matrix. - type(logical_array_ptr), pointer:: inactive - !! PETSc Krylov Subspace context, to cache solver setup - !! ( should always be allocated, to avoid different reference having - !! of the same matrix having different KSPs ) - KSP, pointer :: ksp => null() - !! Reference counting - type(refcount_type), pointer :: refcount => null() - !! Name - character(len=FIELD_NAME_LEN) :: name="" - end type csr_matrix - - type csr_matrix_pointer - type(csr_matrix), pointer :: ptr => null() - end type csr_matrix_pointer - - type block_csr_matrix - !!< Encapsulating type for a matrix with block sparse structure. The - !!< blocks are stored in row major order. For example: - !!< +----------+ - !!< | B1 B2 B3 | - !!< | B4 B5 B6 | - !!< | B7 B8 B9 | - !!< +----------+ - - !! The sparsity pattern for this matrix. - type(csr_sparsity) :: sparsity - !! The values of the nonzero real entries. - type(real_vector), dimension(:,:), pointer :: val=>null() - !! Pointer to continuous memory if exists - real, dimension(:), pointer :: contiguous_val=>null() - !! The values of the nonzero integer entries. - type(integer_vector), dimension(:,:), pointer :: ival=>null() - !! The number of rows and columns of blocks. - integer, dimension(2) :: blocks=(/0,0/) - !! Flag to indicate whether a matrix was allocated or cloned. - logical :: clone=.false. - !! Flag to indicate value space has been externally supplied - !! so it shouldn't be deallocated (only used for clone==.true.) - logical :: external_val=.false. - !! Number of columns in each block. - integer :: columns - !! Reference counting - type(refcount_type), pointer :: refcount => null() - !! Name - character(len=FIELD_NAME_LEN) :: name="" - !! Whether only the diagonal blocks are allocated or not - logical :: diagonal=.false. - !! Whether all diagonal blocks point to the same bit of memory - logical :: equal_diagonal_blocks=.false. - !! PETSc Krylov Subspace context, to cache solver setup - !! ( should always be allocated, to avoid different reference having - !! of the same matrix having different KSPs ) - KSP, pointer :: ksp => null() - end type block_csr_matrix - - type block_csr_matrix_pointer - type(block_csr_matrix), pointer :: ptr => null() - end type block_csr_matrix_pointer - - type dynamic_csr_matrix - !!< Dynamically sized CSR matrix. - !! colm is the list of j values. In this case there is 1 colm per row. - type(integer_vector), dimension(:), pointer :: colm=>null() - !! The values of nonzero real entries - type(real_vector), dimension(:), pointer :: val=>null() - !! Number of columns in the matrix. - integer :: columns - !! Reference counting - type(refcount_type), pointer :: refcount => null() - !! Name - character(len=FIELD_NAME_LEN) :: name="" - end type dynamic_csr_matrix - - type block_dynamic_csr_matrix - !!< A block matrix whose blocks are dynamically sized. Clearly the - !!< blocks generally have differing sparsities. - type(dynamic_csr_matrix), dimension(:,:), pointer :: blocks=>null() - !! Reference counting - type(refcount_type), pointer :: refcount => null() - !! Name - character(len=FIELD_NAME_LEN) :: name="" - end type block_dynamic_csr_matrix - - public :: real_vector, integer_vector, csr_matrix, block_csr_matrix,& - & dynamic_csr_matrix, block_dynamic_csr_matrix, dcsr2csr, csr2dcsr, & - & mult,mult_T, zero_column, addref, incref, decref, has_references, & - & csr_matrix_pointer, block_csr_matrix_pointer, & - & csr_sparsity, csr_sparsity_pointer, logical_array_ptr,& - & initialise_inactive, has_inactive, mult_addto, mult_t_addto - - TYPE node - !!< A node in a linked list - INTEGER :: ID !! id number of node - TYPE (node), POINTER :: next !! next node - END TYPE node - - TYPE row - !!< A matrix row comprising a linked list. - TYPE (node), POINTER :: row - END TYPE row - - interface allocate - module procedure allocate_csr_matrix, allocate_block_csr_matrix,& - & allocate_dcsr_matrix, allocate_block_dcsr_matrix,& - & allocate_csr_sparsity - end interface - - interface deallocate - module procedure deallocate_csr_matrix, deallocate_block_csr_matrix,& - & deallocate_dcsr_matrix, deallocate_block_dcsr_matrix,& - & deallocate_csr_sparsity - end interface - - interface attach_block - module procedure block_csr_attach_block - end interface - - interface unclone - module procedure unclone_csr_matrix - end interface - - interface size - module procedure csr_size, block_csr_size, dcsr_size, block_dcsr_size,& - & sparsity_size - end interface - - interface block - module procedure csr_block, dcsr_block - end interface - - interface block_size - module procedure block_csr_block_size, block_dcsr_block_size - end interface - - interface blocks - module procedure blocks_withdim, blocks_nodim, & - & dcsr_blocks_withdim, dcsr_blocks_nodim - end interface - - interface entries - module procedure csr_entries, dcsr_entries, sparsity_entries - end interface - - interface pos - module procedure csr_pos, block_csr_pos, dcsr_pos, dcsr_pos_noadd, & - csr_sparsity_pos - end interface - - private :: pos - - interface row_m - module procedure csr_row_m, block_csr_row_m, dcsr_row_m,& - & sparsity_row_m - end interface - - interface row_m_ptr - module procedure csr_row_m_ptr, block_csr_row_m_ptr, & - dcsr_row_m_ptr, sparsity_row_m_ptr - end interface - - interface row_val - module procedure csr_row_val, block_csr_row_val - end interface - - interface row_val_ptr - module procedure csr_row_val_ptr, block_csr_row_val_ptr, & - dcsr_row_val_ptr - end interface - - interface row_ival_ptr - module procedure csr_row_ival_ptr, block_csr_row_ival_ptr - end interface - - interface diag_val_ptr - module procedure csr_diag_val_ptr - end interface - - interface row_length - module procedure csr_row_length, block_csr_block_row_length, & - dcsr_row_length, csr_sparsity_row_length - end interface - - interface zero - module procedure csr_zero, block_csr_zero, dcsr_zero - end interface - - interface zero_row - module procedure csr_zero_row, block_csr_zero_row, block_csr_zero_single_row - end interface - - interface zero_column - module procedure dcsr_zero_column - end interface - - interface addto - module procedure csr_addto, csr_iaddto, csr_vaddto, & - block_csr_addto, block_csr_vaddto, block_csr_blocks_addto, & - block_csr_baddto, block_csr_bvaddto, & - dcsr_addto, dcsr_vaddto, dcsr_vaddto1, dcsr_vaddto2,& - dcsr_dcsraddto, csr_csraddto - end interface - - interface addto_diag - module procedure csr_addto_diag, csr_vaddto_diag, & - block_csr_addto_diag, block_csr_vaddto_diag - end interface - - interface set - module procedure csr_set, csr_vset, csr_iset, block_csr_set, & - dcsr_set, dcsr_vset, dcsr_set_row, dcsr_set_col, csr_csr_set, & - block_csr_vset, block_csr_bset, csr_rset, csr_block_csr_set - end interface - - interface set_diag - module procedure csr_set_diag - end interface - - interface scale - module procedure csr_scale, block_csr_scale - end interface - - interface val - module procedure csr_val, block_csr_val, dcsr_val - end interface - - interface ival - module procedure csr_ival - end interface - - interface dense - module procedure csr_dense, block_csr_dense, dcsr_dense,& - & block_dcsr_dense - end interface - - interface dense_i - module procedure csr_dense_i - end interface - - interface wrap - module procedure wrap_csr_matrix, block_wrap_csr_matrix,& - & wrap_csr_sparsity - end interface - - interface mult - module procedure csr_mult - end interface - - interface mult_addto - module procedure csr_mult_addto - end interface - - interface mult_T - module procedure csr_mult_T - end interface - - interface mult_T_addto - module procedure csr_mult_T_addto - end interface - - interface matmul - module procedure csr_matmul, & - block_csr_matmul, csr_sparsity_matmul - end interface - - interface matmul_addto - module procedure csr_matmul_addto, block_csr_matmul_addto - end interface - - interface matmul_T - module procedure dcsr_matmul_T, csr_matmul_T - end interface - - interface set_inactive - module procedure csr_set_inactive_rows, csr_set_inactive_row - end interface set_inactive - - interface get_inactive_mask - module procedure csr_get_inactive_mask - end interface get_inactive_mask - - interface matrix2file - module procedure csr_matrix2file, dcsr_matrix2file,& - & block_csr_matrix2file, block_dcsr_matrix2file, & - & dense_matrix2file - end interface - - interface mmwrite - module procedure csr_mmwrite, dcsr_mmwrite - end interface - - interface transpose - module procedure csr_sparsity_transpose, csr_transpose, block_csr_transpose - end interface - - interface mmread - module procedure dcsr_mmread - end interface - - interface initialise_inactive - module procedure csr_initialise_inactive - end interface - - interface reset_inactive - module procedure csr_reset_inactive - end interface - - interface has_solver_cache - module procedure csr_has_solver_cache, block_csr_has_solver_cache - end interface - - interface destroy_solver_cache - module procedure csr_destroy_solver_cache, block_csr_destroy_solver_cache - end interface - - interface is_symmetric - module procedure sparsity_is_symmetric - end interface - - interface write_minmax - module procedure csr_write_minmax, block_csr_write_minmax - end interface + private + + type csr_sparsity + !!< Encapsulating type for the sparsity patter of a sparse matrix. + + !! Findrm is the indices of the row starts in colm. + integer, dimension(:), pointer :: findrm=>null() + !! Centrm is the indices of the main diagonal in colm. + integer, dimension(:), pointer :: centrm=>null() + !! Colm is the list of matrix j values. + integer, dimension(:), pointer :: colm=>null() + !! Number of columns in matrix. + integer :: columns + !! The halos associated with the rows and columns of the matrix. + type(halo_type), pointer :: row_halo => null(), column_halo => null() + !! Reference counting + type(refcount_type), pointer :: refcount => null() + !! Name + character(len=FIELD_NAME_LEN) :: name="" + !! Flag to indicate whether a matrix was allocated or wrapped. + logical :: wrapped=.false. + !! Flag to indicate whether each row in colm is sorted in ascending j + !! order. If true this enables a faster binary search for entries + !! during matrix accesses. + logical :: sorted_rows=.false. + end type csr_sparsity + + type csr_sparsity_pointer + type(csr_sparsity), pointer :: ptr => null() + end type csr_sparsity_pointer + + ! construct to avoid mem. leaks if people add an inactive array to a borrowed reference + type logical_array_ptr + logical, dimension(:), pointer :: ptr => null() + end type + + type csr_matrix + !!< Encapsulating type for a sparse matrix. + + !! The sparsity pattern for this matrix. + type(csr_sparsity) :: sparsity + !! The values of nonzero real entries + real, dimension(:), pointer :: val=>null() + !! The values of nonzero integer entries + integer, dimension(:), pointer :: ival=>null() + !! Flag to indicate whether a matrix was allocated or cloned. + logical :: clone=.false. + !! Flag to indicate value space has been externally supplied + !! so it shouldn't be deallocated (only used for clone==.true.) + logical :: external_val=.false. + !! for nodes with inactive%ptr(node)==.true. the rows and columns + !! will be left out of the matrix equation solved in petsc_solve() + !! NOTE: %inactive should always be allocated for any allocated csr_matrix + !! %inactive%ptr may not be allocated, in which case all nodes are "active" + !! As %inactive is directly allocated from the start the %inactive%ptr pointer and its + !! association status are always the same for all references of the matrix. + type(logical_array_ptr), pointer:: inactive + !! PETSc Krylov Subspace context, to cache solver setup + !! ( should always be allocated, to avoid different reference having + !! of the same matrix having different KSPs ) + KSP, pointer :: ksp => null() + !! Reference counting + type(refcount_type), pointer :: refcount => null() + !! Name + character(len=FIELD_NAME_LEN) :: name="" + end type csr_matrix + + type csr_matrix_pointer + type(csr_matrix), pointer :: ptr => null() + end type csr_matrix_pointer + + type block_csr_matrix + !!< Encapsulating type for a matrix with block sparse structure. The + !!< blocks are stored in row major order. For example: + !!< +----------+ + !!< | B1 B2 B3 | + !!< | B4 B5 B6 | + !!< | B7 B8 B9 | + !!< +----------+ + + !! The sparsity pattern for this matrix. + type(csr_sparsity) :: sparsity + !! The values of the nonzero real entries. + type(real_vector), dimension(:,:), pointer :: val=>null() + !! Pointer to continuous memory if exists + real, dimension(:), pointer :: contiguous_val=>null() + !! The values of the nonzero integer entries. + type(integer_vector), dimension(:,:), pointer :: ival=>null() + !! The number of rows and columns of blocks. + integer, dimension(2) :: blocks=(/0,0/) + !! Flag to indicate whether a matrix was allocated or cloned. + logical :: clone=.false. + !! Flag to indicate value space has been externally supplied + !! so it shouldn't be deallocated (only used for clone==.true.) + logical :: external_val=.false. + !! Number of columns in each block. + integer :: columns + !! Reference counting + type(refcount_type), pointer :: refcount => null() + !! Name + character(len=FIELD_NAME_LEN) :: name="" + !! Whether only the diagonal blocks are allocated or not + logical :: diagonal=.false. + !! Whether all diagonal blocks point to the same bit of memory + logical :: equal_diagonal_blocks=.false. + !! PETSc Krylov Subspace context, to cache solver setup + !! ( should always be allocated, to avoid different reference having + !! of the same matrix having different KSPs ) + KSP, pointer :: ksp => null() + end type block_csr_matrix + + type block_csr_matrix_pointer + type(block_csr_matrix), pointer :: ptr => null() + end type block_csr_matrix_pointer + + type dynamic_csr_matrix + !!< Dynamically sized CSR matrix. + !! colm is the list of j values. In this case there is 1 colm per row. + type(integer_vector), dimension(:), pointer :: colm=>null() + !! The values of nonzero real entries + type(real_vector), dimension(:), pointer :: val=>null() + !! Number of columns in the matrix. + integer :: columns + !! Reference counting + type(refcount_type), pointer :: refcount => null() + !! Name + character(len=FIELD_NAME_LEN) :: name="" + end type dynamic_csr_matrix + + type block_dynamic_csr_matrix + !!< A block matrix whose blocks are dynamically sized. Clearly the + !!< blocks generally have differing sparsities. + type(dynamic_csr_matrix), dimension(:,:), pointer :: blocks=>null() + !! Reference counting + type(refcount_type), pointer :: refcount => null() + !! Name + character(len=FIELD_NAME_LEN) :: name="" + end type block_dynamic_csr_matrix + + public :: real_vector, integer_vector, csr_matrix, block_csr_matrix,& + & dynamic_csr_matrix, block_dynamic_csr_matrix, dcsr2csr, csr2dcsr, & + & mult,mult_T, zero_column, addref, incref, decref, has_references, & + & csr_matrix_pointer, block_csr_matrix_pointer, & + & csr_sparsity, csr_sparsity_pointer, logical_array_ptr,& + & initialise_inactive, has_inactive, mult_addto, mult_t_addto + + TYPE node + !!< A node in a linked list + INTEGER :: ID !! id number of node + TYPE (node), POINTER :: next !! next node + END TYPE node + + TYPE row + !!< A matrix row comprising a linked list. + TYPE (node), POINTER :: row + END TYPE row + + interface allocate + module procedure allocate_csr_matrix, allocate_block_csr_matrix,& + & allocate_dcsr_matrix, allocate_block_dcsr_matrix,& + & allocate_csr_sparsity + end interface + + interface deallocate + module procedure deallocate_csr_matrix, deallocate_block_csr_matrix,& + & deallocate_dcsr_matrix, deallocate_block_dcsr_matrix,& + & deallocate_csr_sparsity + end interface + + interface attach_block + module procedure block_csr_attach_block + end interface + + interface unclone + module procedure unclone_csr_matrix + end interface + + interface size + module procedure csr_size, block_csr_size, dcsr_size, block_dcsr_size,& + & sparsity_size + end interface + + interface block + module procedure csr_block, dcsr_block + end interface + + interface block_size + module procedure block_csr_block_size, block_dcsr_block_size + end interface + + interface blocks + module procedure blocks_withdim, blocks_nodim, & + & dcsr_blocks_withdim, dcsr_blocks_nodim + end interface + + interface entries + module procedure csr_entries, dcsr_entries, sparsity_entries + end interface + + interface pos + module procedure csr_pos, block_csr_pos, dcsr_pos, dcsr_pos_noadd, & + csr_sparsity_pos + end interface + + private :: pos + + interface row_m + module procedure csr_row_m, block_csr_row_m, dcsr_row_m,& + & sparsity_row_m + end interface + + interface row_m_ptr + module procedure csr_row_m_ptr, block_csr_row_m_ptr, & + dcsr_row_m_ptr, sparsity_row_m_ptr + end interface + + interface row_val + module procedure csr_row_val, block_csr_row_val + end interface + + interface row_val_ptr + module procedure csr_row_val_ptr, block_csr_row_val_ptr, & + dcsr_row_val_ptr + end interface + + interface row_ival_ptr + module procedure csr_row_ival_ptr, block_csr_row_ival_ptr + end interface + + interface diag_val_ptr + module procedure csr_diag_val_ptr + end interface + + interface row_length + module procedure csr_row_length, block_csr_block_row_length, & + dcsr_row_length, csr_sparsity_row_length + end interface + + interface zero + module procedure csr_zero, block_csr_zero, dcsr_zero + end interface + + interface zero_row + module procedure csr_zero_row, block_csr_zero_row, block_csr_zero_single_row + end interface + + interface zero_column + module procedure dcsr_zero_column + end interface + + interface addto + module procedure csr_addto, csr_iaddto, csr_vaddto, & + block_csr_addto, block_csr_vaddto, block_csr_blocks_addto, & + block_csr_baddto, block_csr_bvaddto, & + dcsr_addto, dcsr_vaddto, dcsr_vaddto1, dcsr_vaddto2,& + dcsr_dcsraddto, csr_csraddto + end interface + + interface addto_diag + module procedure csr_addto_diag, csr_vaddto_diag, & + block_csr_addto_diag, block_csr_vaddto_diag + end interface + + interface set + module procedure csr_set, csr_vset, csr_iset, block_csr_set, & + dcsr_set, dcsr_vset, dcsr_set_row, dcsr_set_col, csr_csr_set, & + block_csr_vset, block_csr_bset, csr_rset, csr_block_csr_set + end interface + + interface set_diag + module procedure csr_set_diag + end interface + + interface scale + module procedure csr_scale, block_csr_scale + end interface + + interface val + module procedure csr_val, block_csr_val, dcsr_val + end interface + + interface ival + module procedure csr_ival + end interface + + interface dense + module procedure csr_dense, block_csr_dense, dcsr_dense,& + & block_dcsr_dense + end interface + + interface dense_i + module procedure csr_dense_i + end interface + + interface wrap + module procedure wrap_csr_matrix, block_wrap_csr_matrix,& + & wrap_csr_sparsity + end interface + + interface mult + module procedure csr_mult + end interface + + interface mult_addto + module procedure csr_mult_addto + end interface + + interface mult_T + module procedure csr_mult_T + end interface + + interface mult_T_addto + module procedure csr_mult_T_addto + end interface + + interface matmul + module procedure csr_matmul, & + block_csr_matmul, csr_sparsity_matmul + end interface + + interface matmul_addto + module procedure csr_matmul_addto, block_csr_matmul_addto + end interface + + interface matmul_T + module procedure dcsr_matmul_T, csr_matmul_T + end interface + + interface set_inactive + module procedure csr_set_inactive_rows, csr_set_inactive_row + end interface set_inactive + + interface get_inactive_mask + module procedure csr_get_inactive_mask + end interface get_inactive_mask + + interface matrix2file + module procedure csr_matrix2file, dcsr_matrix2file,& + & block_csr_matrix2file, block_dcsr_matrix2file, & + & dense_matrix2file + end interface + + interface mmwrite + module procedure csr_mmwrite, dcsr_mmwrite + end interface + + interface transpose + module procedure csr_sparsity_transpose, csr_transpose, block_csr_transpose + end interface + + interface mmread + module procedure dcsr_mmread + end interface + + interface initialise_inactive + module procedure csr_initialise_inactive + end interface + + interface reset_inactive + module procedure csr_reset_inactive + end interface + + interface has_solver_cache + module procedure csr_has_solver_cache, block_csr_has_solver_cache + end interface + + interface destroy_solver_cache + module procedure csr_destroy_solver_cache, block_csr_destroy_solver_cache + end interface + + interface is_symmetric + module procedure sparsity_is_symmetric + end interface + + interface write_minmax + module procedure csr_write_minmax, block_csr_write_minmax + end interface #include "Reference_count_interface_csr_sparsity.F90" #include "Reference_count_interface_csr_matrix.F90" @@ -427,4791 +427,4791 @@ module sparse_tools #include "Reference_count_interface_dynamic_csr_matrix.F90" #include "Reference_count_interface_block_dynamic_csr_matrix.F90" - !! Parameters enabling the selection of matrix entry type. - integer, public, parameter :: CSR_REAL=0, CSR_INTEGER=1, CSR_NONE=2 + !! Parameters enabling the selection of matrix entry type. + integer, public, parameter :: CSR_REAL=0, CSR_INTEGER=1, CSR_NONE=2 - ! maximum line length in MatrixMarket files - integer, private, parameter :: MMmaxlinelen=1024 - character(len=*), parameter :: MMlineformat='(1024a)' + ! maximum line length in MatrixMarket files + integer, private, parameter :: MMmaxlinelen=1024 + character(len=*), parameter :: MMlineformat='(1024a)' - public :: allocate, deallocate, attach_block, & - unclone, size, block, block_size, blocks, entries, row_m, row_val, & - & row_m_ptr, row_val_ptr, row_ival_ptr, diag_val_ptr, row_length, zero, zero_row, addto,& - & addto_diag, set_diag, set, val, ival, dense, dense_i, wrap, matmul, matmul_addto, matmul_T,& - & matrix2file, mmwrite, mmread, transpose, sparsity_sort,& - & sparsity_merge, scale, set_inactive, get_inactive_mask, & - & reset_inactive, has_solver_cache, destroy_solver_cache, is_symmetric, sparsity_is_sorted, & - & write_minmax + public :: allocate, deallocate, attach_block, & + unclone, size, block, block_size, blocks, entries, row_m, row_val, & + & row_m_ptr, row_val_ptr, row_ival_ptr, diag_val_ptr, row_length, zero, zero_row, addto,& + & addto_diag, set_diag, set, val, ival, dense, dense_i, wrap, matmul, matmul_addto, matmul_T,& + & matrix2file, mmwrite, mmread, transpose, sparsity_sort,& + & sparsity_merge, scale, set_inactive, get_inactive_mask, & + & reset_inactive, has_solver_cache, destroy_solver_cache, is_symmetric, sparsity_is_sorted, & + & write_minmax - public :: posinm + public :: posinm contains - !! This subroutine works out the sparsity pattern of the matrix: - !! <--------- NNodes 1 -----------> - !! ^ - !! | non-zero in row i,colume j iff these exists an element - !! | index, k, where element k in mesh1 contains j and element - !! | k in mesh 2 contains i - !! NNodes 2 - !! | - !! | - !! | - !! v - !! - SUBROUTINE posinm(sparsity, TOTELE, NNodes1, NLoc1, NDGLNO1,& - NNodes2, NLoc2, NDGLNO2, diag, name) - type(csr_sparsity), intent(out) :: sparsity - INTEGER, INTENT(IN)::NNodes1, NNodes2, TOTELE, NLoc1, NLoc2 - INTEGER, INTENT(IN)::NDGLNO1(TOTELE*NLoc1), NDGLNO2(TOTELE*NLoc2) - logical, intent(in), optional :: diag - character(len=*), intent(in):: name - - INTEGER ELE,GLOBI,GLOBJ,LOCI,LOCJ,I - ! Count of nonzero entries. - integer :: entries - ! Count of diagonal entries. - integer :: diag_cnt - - ! Whether val and diag should be allocated. If diag is false then the - ! diagonal will be totally excluded from the matrix. - logical :: ldiag - - TYPE(row), DIMENSION(:), ALLOCATABLE::lMatrix - TYPE(node), POINTER::List, Current, Next - - if(present(diag)) then - ldiag=diag - else - ldiag=.true. - end if - - ewrite(2, *) "SUBROUTINE POSINM()" - - ! Initalise the linked lists - ALLOCATE( lMatrix(NNodes2) ) - DO I=1, NNodes2 - ALLOCATE( List ) - List%ID = -1 - NULLIFY( List%next ) - - lMatrix(I)%row => List - NULLIFY(List) - END DO - - ewrite(2, *) "Constructing lMatrix using linked-lists" - - ! The first entry on each row is already present. - entries=NNodes2 - diag_cnt=0 - - DO ELE=1,TOTELE - DO LOCI=1,NLoc2 - GLOBI=NDGLNO2((ELE-1)*NLoc2+LOCI) - List => lMatrix(GLOBI)%row - - DO LOCJ=1,NLoc1 - GLOBJ=NDGLNO1((ELE-1)*NLoc1+LOCJ) - - ! Check if the list is initalised - IF(List%ID.EQ.-1) THEN - List%ID = GLOBJ - - ! Count diagonal entries. - if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 - - CYCLE - END IF - - IF(GLOBJ.LT.List%ID) THEN - ! Insert at start of list - ALLOCATE(Current) - entries=entries+1 - Current%ID = GLOBJ - Current%next => List - - lMatrix(GLOBI)%row => Current - List => lMatrix(GLOBI)%row - - ! Count diagonal entries. - if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 - ELSE - Current => List - DO WHILE ( ASSOCIATED(Current) ) - IF(GLOBJ.EQ.Current%ID) THEN - ! Already have this node - exit - ELSE IF(.NOT.ASSOCIATED(Current%next)) THEN - ! End of list - insert this node - ALLOCATE(Current%next) - entries=entries+1 - NULLIFY(Current%next%next) - Current%next%ID = GLOBJ - - ! Count diagonal entries. - if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 - - exit - ELSE IF(GLOBJ.LT.Current%next%ID) THEN - ! Insert new node here - ALLOCATE(Next) - entries=entries+1 - Next%ID = GLOBJ - Next%next => Current%next - Current%Next => Next - - ! Count diagonal entries. - if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 - - exit - END IF - Current => Current%next - END DO - END IF - END DO - END DO - END DO - - ewrite(2, *) "Compressing matrix" - - ! Exclude the diagonal if needed. - if (.not.ldiag) then - entries=entries-diag_cnt - end if - - call allocate(sparsity, rows=NNodes2, columns=NNodes2, entries=entries,& - & diag=diag, name=name) - - call compress_sparsity(nnodes2, sparsity, ldiag,lmatrix, entries) - - DEALLOCATE( lMatrix ) - - ewrite(2, *) "END SUBROUTINE POSINM" - RETURN - END SUBROUTINE posinm - - subroutine row_insert(row_in, value, entries) - ! Insert value into list. - type(row), intent(inout) :: row_in - integer, intent(in) :: value - integer, intent(inout) :: entries - - type(node), pointer :: list, current, next - - list=>row_in%row - - ! Check if the list is initalised - IF(List%ID.EQ.-1) THEN - List%ID = value - - return - END IF - - IF(value.LT.List%ID) THEN - ! Insert at start of list - ALLOCATE(Current) - entries=entries+1 - Current%ID = value - Current%next => List - - row_in%row => Current - List => row_in%row - - ELSE - Current => List - DO WHILE ( ASSOCIATED(Current) ) - IF(value.EQ.Current%ID) THEN - ! Already have this node - exit - ELSE IF(.NOT.ASSOCIATED(Current%next)) THEN - ! End of list - insert this node - ALLOCATE(Current%next) - entries=entries+1 - NULLIFY(Current%next%next) - Current%next%ID = value - - exit - ELSE IF(value.LT.Current%next%ID) THEN - ! Insert new node here - ALLOCATE(Next) - entries=entries+1 - Next%ID = value - Next%next => Current%next - Current%Next => Next - - exit - END IF - Current => Current%next - END DO - END IF - - end subroutine row_insert - - subroutine compress_sparsity(nnodes2, sparsity, ldiag,lmatrix, entries) - - integer, intent(in)::nnodes2,entries - logical, intent(in)::ldiag - type(csr_sparsity), intent(inout) :: sparsity - - TYPE(row), DIMENSION(:) ::lMatrix - - !local variables - integer::ptr,irow - TYPE(node), POINTER::Current, Next + !! This subroutine works out the sparsity pattern of the matrix: + !! <--------- NNodes 1 -----------> + !! ^ + !! | non-zero in row i,colume j iff these exists an element + !! | index, k, where element k in mesh1 contains j and element + !! | k in mesh 2 contains i + !! NNodes 2 + !! | + !! | + !! | + !! v + !! + SUBROUTINE posinm(sparsity, TOTELE, NNodes1, NLoc1, NDGLNO1,& + NNodes2, NLoc2, NDGLNO2, diag, name) + type(csr_sparsity), intent(out) :: sparsity + INTEGER, INTENT(IN)::NNodes1, NNodes2, TOTELE, NLoc1, NLoc2 + INTEGER, INTENT(IN)::NDGLNO1(TOTELE*NLoc1), NDGLNO2(TOTELE*NLoc2) + logical, intent(in), optional :: diag + character(len=*), intent(in):: name + + INTEGER ELE,GLOBI,GLOBJ,LOCI,LOCJ,I + ! Count of nonzero entries. + integer :: entries + ! Count of diagonal entries. + integer :: diag_cnt + + ! Whether val and diag should be allocated. If diag is false then the + ! diagonal will be totally excluded from the matrix. + logical :: ldiag + + TYPE(row), DIMENSION(:), ALLOCATABLE::lMatrix + TYPE(node), POINTER::List, Current, Next + + if(present(diag)) then + ldiag=diag + else + ldiag=.true. + end if + + ewrite(2, *) "SUBROUTINE POSINM()" + + ! Initalise the linked lists + ALLOCATE( lMatrix(NNodes2) ) + DO I=1, NNodes2 + ALLOCATE( List ) + List%ID = -1 + NULLIFY( List%next ) + + lMatrix(I)%row => List + NULLIFY(List) + END DO + + ewrite(2, *) "Constructing lMatrix using linked-lists" + + ! The first entry on each row is already present. + entries=NNodes2 + diag_cnt=0 + + DO ELE=1,TOTELE + DO LOCI=1,NLoc2 + GLOBI=NDGLNO2((ELE-1)*NLoc2+LOCI) + List => lMatrix(GLOBI)%row + + DO LOCJ=1,NLoc1 + GLOBJ=NDGLNO1((ELE-1)*NLoc1+LOCJ) + + ! Check if the list is initalised + IF(List%ID.EQ.-1) THEN + List%ID = GLOBJ + + ! Count diagonal entries. + if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 + + CYCLE + END IF + + IF(GLOBJ.LT.List%ID) THEN + ! Insert at start of list + ALLOCATE(Current) + entries=entries+1 + Current%ID = GLOBJ + Current%next => List + + lMatrix(GLOBI)%row => Current + List => lMatrix(GLOBI)%row + + ! Count diagonal entries. + if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 + ELSE + Current => List + DO WHILE ( ASSOCIATED(Current) ) + IF(GLOBJ.EQ.Current%ID) THEN + ! Already have this node + exit + ELSE IF(.NOT.ASSOCIATED(Current%next)) THEN + ! End of list - insert this node + ALLOCATE(Current%next) + entries=entries+1 + NULLIFY(Current%next%next) + Current%next%ID = GLOBJ + + ! Count diagonal entries. + if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 + + exit + ELSE IF(GLOBJ.LT.Current%next%ID) THEN + ! Insert new node here + ALLOCATE(Next) + entries=entries+1 + Next%ID = GLOBJ + Next%next => Current%next + Current%Next => Next + + ! Count diagonal entries. + if (GLOBI==GLOBJ) diag_cnt=diag_cnt+1 + + exit + END IF + Current => Current%next + END DO + END IF + END DO + END DO + END DO + + ewrite(2, *) "Compressing matrix" + + ! Exclude the diagonal if needed. + if (.not.ldiag) then + entries=entries-diag_cnt + end if + + call allocate(sparsity, rows=NNodes2, columns=NNodes2, entries=entries,& + & diag=diag, name=name) + + call compress_sparsity(nnodes2, sparsity, ldiag,lmatrix, entries) + + DEALLOCATE( lMatrix ) + + ewrite(2, *) "END SUBROUTINE POSINM" + RETURN + END SUBROUTINE posinm + + subroutine row_insert(row_in, value, entries) + ! Insert value into list. + type(row), intent(inout) :: row_in + integer, intent(in) :: value + integer, intent(inout) :: entries + + type(node), pointer :: list, current, next + + list=>row_in%row + + ! Check if the list is initalised + IF(List%ID.EQ.-1) THEN + List%ID = value + + return + END IF + + IF(value.LT.List%ID) THEN + ! Insert at start of list + ALLOCATE(Current) + entries=entries+1 + Current%ID = value + Current%next => List + + row_in%row => Current + List => row_in%row + + ELSE + Current => List + DO WHILE ( ASSOCIATED(Current) ) + IF(value.EQ.Current%ID) THEN + ! Already have this node + exit + ELSE IF(.NOT.ASSOCIATED(Current%next)) THEN + ! End of list - insert this node + ALLOCATE(Current%next) + entries=entries+1 + NULLIFY(Current%next%next) + Current%next%ID = value + + exit + ELSE IF(value.LT.Current%next%ID) THEN + ! Insert new node here + ALLOCATE(Next) + entries=entries+1 + Next%ID = value + Next%next => Current%next + Current%Next => Next + + exit + END IF + Current => Current%next + END DO + END IF + + end subroutine row_insert + + subroutine compress_sparsity(nnodes2, sparsity, ldiag,lmatrix, entries) + + integer, intent(in)::nnodes2,entries + logical, intent(in)::ldiag + type(csr_sparsity), intent(inout) :: sparsity + + TYPE(row), DIMENSION(:) ::lMatrix + + !local variables + integer::ptr,irow + TYPE(node), POINTER::Current, Next + + ewrite(2,*) "subroutine compress_sparsity" + + ! From sparsity write COLM, FINDRM and CENTRM + ! linked list as we go + PTR = 1 + + DO IROW=1,NNodes2 + + sparsity%FINDRM(IROW) = PTR + + if (ldiag) then + sparsity%CENTRM(IROW) = -1 + end if + + Current => lMatrix(IROW)%row + + DO WHILE ( ASSOCIATED(Current) ) + + ASSERT(PTR.LE.entries+1) ! Sanity check the calculation of entries. - ewrite(2,*) "subroutine compress_sparsity" + IF(Current%ID.EQ.IROW) THEN + if (ldiag) then + sparsity%CENTRM(IROW) = PTR + else + ! Exclude this element completely. + goto 42 + end if + END IF - ! From sparsity write COLM, FINDRM and CENTRM - ! linked list as we go - PTR = 1 + sparsity%COLM(PTR) = Current%ID + IF(Current%ID==-1) THEN + ewrite(-1,*) "ERROR: POSINM() seriously unhappy with node",IROW + FLAbort("Mesh contains nodes that are not associated with any elements.") + END IF - DO IROW=1,NNodes2 + PTR = PTR + 1 - sparsity%FINDRM(IROW) = PTR +42 Next => Current%next + DEALLOCATE(Current) + Current => Next - if (ldiag) then - sparsity%CENTRM(IROW) = -1 - end if + END DO + END DO - Current => lMatrix(IROW)%row - - DO WHILE ( ASSOCIATED(Current) ) + ASSERT(PTR==entries+1) ! Sanity check the calculation of entries. - ASSERT(PTR.LE.entries+1) ! Sanity check the calculation of entries. + sparsity%FINDRM(NNodes2+1) = entries+1 - IF(Current%ID.EQ.IROW) THEN - if (ldiag) then - sparsity%CENTRM(IROW) = PTR - else - ! Exclude this element completely. - goto 42 - end if - END IF - - sparsity%COLM(PTR) = Current%ID - IF(Current%ID==-1) THEN - ewrite(-1,*) "ERROR: POSINM() seriously unhappy with node",IROW - FLAbort("Mesh contains nodes that are not associated with any elements.") - END IF - - PTR = PTR + 1 - -42 Next => Current%next - DEALLOCATE(Current) - Current => Next - - END DO - END DO - - ASSERT(PTR==entries+1) ! Sanity check the calculation of entries. - - sparsity%FINDRM(NNodes2+1) = entries+1 - - ewrite(2,*)"END subroutine compress_sparsity" - - end subroutine compress_sparsity - - pure function blockstart(matrix, blocki, blockj) - !!< local auxillary function that determines start of a block in matrix%val - !!< This is almost obsolete now - it is only used to position pointers. - integer blockstart - type(block_csr_matrix), intent(in):: matrix - integer, intent(in):: blocki, blockj - - blockstart=((blocki-1)*matrix%blocks(2)+blockj-1)*size(matrix%sparsity%colm)+1 - - end function blockstart - - subroutine allocate_csr_sparsity(sparsity, rows, columns, entries, nnz, diag,& - & name, stat) - type(csr_sparsity), intent(out) :: sparsity - !! Rows is the number of rows. - integer, intent(in) :: rows, columns - !! Entries is the number of nonzero entries. Either 'entries' or 'nnz' is required - integer, intent(in), optional :: entries - !! nnz number of nonzero entries for each row - integer, dimension(:), intent(in), optional :: nnz - !! Diag can be used to not allocate the diagonal. - logical, intent(in), optional :: diag - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat + ewrite(2,*)"END subroutine compress_sparsity" - logical :: ldiag - integer :: lstat, totalmem, lentries - integer :: i, k + end subroutine compress_sparsity - if(present(diag)) then - ldiag=diag - else - ldiag=.true. - end if + pure function blockstart(matrix, blocki, blockj) + !!< local auxillary function that determines start of a block in matrix%val + !!< This is almost obsolete now - it is only used to position pointers. + integer blockstart + type(block_csr_matrix), intent(in):: matrix + integer, intent(in):: blocki, blockj - if(present(entries)) then - lentries=entries - else if (present(nnz)) then - lentries=sum(nnz) - else - FLAbort("In allocate_csr_sparsity need to provide either entries or nnz argument") - end if + blockstart=((blocki-1)*matrix%blocks(2)+blockj-1)*size(matrix%sparsity%colm)+1 - sparsity%name = name + end function blockstart - sparsity%wrapped=.false. + subroutine allocate_csr_sparsity(sparsity, rows, columns, entries, nnz, diag,& + & name, stat) + type(csr_sparsity), intent(out) :: sparsity + !! Rows is the number of rows. + integer, intent(in) :: rows, columns + !! Entries is the number of nonzero entries. Either 'entries' or 'nnz' is required + integer, intent(in), optional :: entries + !! nnz number of nonzero entries for each row + integer, dimension(:), intent(in), optional :: nnz + !! Diag can be used to not allocate the diagonal. + logical, intent(in), optional :: diag + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - sparsity%columns=columns + logical :: ldiag + integer :: lstat, totalmem, lentries + integer :: i, k - nullify(sparsity%refcount) - call addref(sparsity) + if(present(diag)) then + ldiag=diag + else + ldiag=.true. + end if + + if(present(entries)) then + lentries=entries + else if (present(nnz)) then + lentries=sum(nnz) + else + FLAbort("In allocate_csr_sparsity need to provide either entries or nnz argument") + end if + + sparsity%name = name + + sparsity%wrapped=.false. + + sparsity%columns=columns - allocate(sparsity%findrm(rows+1), sparsity%colm(lentries), stat=lstat) - if (lstat/=0) goto 42 - totalmem=rows+1 + lentries + nullify(sparsity%refcount) + call addref(sparsity) - if (ldiag) then - allocate(sparsity%centrm(rows), stat=lstat) - if (lstat/=0) goto 42 - totalmem=totalmem + size(sparsity%centrm) - else - ! fix for 'old' gfortran bug: - nullify(sparsity%centrm) - end if - -42 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to allocate sparsity.") - end if - end if + allocate(sparsity%findrm(rows+1), sparsity%colm(lentries), stat=lstat) + if (lstat/=0) goto 42 + totalmem=rows+1 + lentries + + if (ldiag) then + allocate(sparsity%centrm(rows), stat=lstat) + if (lstat/=0) goto 42 + totalmem=totalmem + size(sparsity%centrm) + else + ! fix for 'old' gfortran bug: + nullify(sparsity%centrm) + end if + +42 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to allocate sparsity.") + end if + end if #ifdef HAVE_MEMORY_STATS - call register_allocation("csr_sparsity", "integer", & + call register_allocation("csr_sparsity", "integer", & totalmem, name=name) #endif - if (present(nnz)) then - ! fill in %findrm from nnz: - k=1 - do i=1, size(nnz) - sparsity%findrm(i)=k - k=k+nnz(i) - end do - sparsity%findrm(i)=k - assert( k==lentries+1 ) - end if - - end subroutine allocate_csr_sparsity - - subroutine allocate_csr_matrix(matrix, sparsity, val, type, name, stat) - type(csr_matrix), intent(out) :: matrix - type(csr_sparsity), intent(in) :: sparsity - !! Val can be used to not allocate the values. - logical, intent(in), optional :: val - !! Real or integer matrix. - integer, intent(in), optional :: type - character(len=*), intent(in), optional :: name - integer, intent(out), optional :: stat - - integer :: lstat, ltype - character(len=FIELD_NAME_LEN) :: lname - - if (present(name)) then - lname=name - else - lname="" - end if - matrix%name = lname - - if (present(type)) then - ltype=type - else - ltype=CSR_REAL - end if - - matrix%clone=.false. - - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) - - matrix%sparsity=sparsity - call incref(matrix%sparsity) - - ! this is a temp. measure as long as gfortran does not do it automatically - nullify(matrix%val) - nullify(matrix%ival) - ! should always be allocated, so that matrix%inactive%ptr is the same for - ! all references of the matrix: - allocate(matrix%inactive) - nullify(matrix%inactive%ptr) - ! same story for ksp - allocate(matrix%ksp) - matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available - - select case (ltype) - case (CSR_REAL) - allocate(matrix%val(size(sparsity%colm)), stat=lstat) + if (present(nnz)) then + ! fill in %findrm from nnz: + k=1 + do i=1, size(nnz) + sparsity%findrm(i)=k + k=k+nnz(i) + end do + sparsity%findrm(i)=k + assert( k==lentries+1 ) + end if + + end subroutine allocate_csr_sparsity + + subroutine allocate_csr_matrix(matrix, sparsity, val, type, name, stat) + type(csr_matrix), intent(out) :: matrix + type(csr_sparsity), intent(in) :: sparsity + !! Val can be used to not allocate the values. + logical, intent(in), optional :: val + !! Real or integer matrix. + integer, intent(in), optional :: type + character(len=*), intent(in), optional :: name + integer, intent(out), optional :: stat + + integer :: lstat, ltype + character(len=FIELD_NAME_LEN) :: lname + + if (present(name)) then + lname=name + else + lname="" + end if + matrix%name = lname + + if (present(type)) then + ltype=type + else + ltype=CSR_REAL + end if + + matrix%clone=.false. + + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) + + matrix%sparsity=sparsity + call incref(matrix%sparsity) + + ! this is a temp. measure as long as gfortran does not do it automatically + nullify(matrix%val) + nullify(matrix%ival) + ! should always be allocated, so that matrix%inactive%ptr is the same for + ! all references of the matrix: + allocate(matrix%inactive) + nullify(matrix%inactive%ptr) + ! same story for ksp + allocate(matrix%ksp) + matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available + + select case (ltype) + case (CSR_REAL) + allocate(matrix%val(size(sparsity%colm)), stat=lstat) #ifdef HAVE_MEMORY_STATS - call register_allocation("csr_matrix", "real", & - size(sparsity%colm), name=name) + call register_allocation("csr_matrix", "real", & + size(sparsity%colm), name=name) #endif - case (CSR_INTEGER) - allocate(matrix%ival(size(sparsity%colm)), stat=lstat) + case (CSR_INTEGER) + allocate(matrix%ival(size(sparsity%colm)), stat=lstat) #ifdef HAVE_MEMORY_STATS - call register_allocation("csr_matrix", "integer", & - size(sparsity%colm), name=name) + call register_allocation("csr_matrix", "integer", & + size(sparsity%colm), name=name) #endif - case default - FLAbort("Unknown matrix data type.") - end select + case default + FLAbort("Unknown matrix data type.") + end select - if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to allocate matrix.") - end if - end if + if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to allocate matrix.") + end if + end if - end subroutine allocate_csr_matrix + end subroutine allocate_csr_matrix - subroutine deallocate_csr_sparsity(sparsity, stat) - type(csr_sparsity), intent(inout) :: sparsity - integer, intent(out), optional :: stat + subroutine deallocate_csr_sparsity(sparsity, stat) + type(csr_sparsity), intent(inout) :: sparsity + integer, intent(out), optional :: stat - integer :: lstat, totalmem + integer :: lstat, totalmem - lstat = 0 + lstat = 0 - call decref(sparsity) - if (has_references(sparsity)) then - goto 42 - end if + call decref(sparsity) + if (has_references(sparsity)) then + goto 42 + end if - if (.not.sparsity%wrapped) then - totalmem=size(sparsity%findrm) + size(sparsity%colm) - deallocate(sparsity%findrm, sparsity%colm, stat=lstat) - if (lstat/=0) goto 42 + if (.not.sparsity%wrapped) then + totalmem=size(sparsity%findrm) + size(sparsity%colm) + deallocate(sparsity%findrm, sparsity%colm, stat=lstat) + if (lstat/=0) goto 42 - ! centrm may legitimately not be allocated. - if (associated(sparsity%centrm)) then - totalmem=totalmem+size(sparsity%centrm) - deallocate(sparsity%centrm, stat=lstat) - if (lstat/=0) goto 42 - end if + ! centrm may legitimately not be allocated. + if (associated(sparsity%centrm)) then + totalmem=totalmem+size(sparsity%centrm) + deallocate(sparsity%centrm, stat=lstat) + if (lstat/=0) goto 42 + end if #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_sparsity", "integer", & + call register_deallocation("csr_sparsity", "integer", & totalmem, name=sparsity%name) #endif - end if + end if - if (associated(sparsity%row_halo)) then - call deallocate(sparsity%row_halo) - deallocate(sparsity%row_halo) - end if + if (associated(sparsity%row_halo)) then + call deallocate(sparsity%row_halo) + deallocate(sparsity%row_halo) + end if - if (associated(sparsity%column_halo)) then - call deallocate(sparsity%column_halo) - deallocate(sparsity%column_halo) - end if + if (associated(sparsity%column_halo)) then + call deallocate(sparsity%column_halo) + deallocate(sparsity%column_halo) + end if -42 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to deallocate matrix.") - end if - end if +42 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to deallocate matrix.") + end if + end if - end subroutine deallocate_csr_sparsity + end subroutine deallocate_csr_sparsity - subroutine deallocate_csr_matrix(matrix, stat) - type(csr_matrix), intent(inout) :: matrix - integer, intent(out), optional :: stat + subroutine deallocate_csr_matrix(matrix, stat) + type(csr_matrix), intent(inout) :: matrix + integer, intent(out), optional :: stat - integer :: lstat + integer :: lstat - lstat = 0 + lstat = 0 - call decref(matrix) - if (has_references(matrix)) then - goto 42 - end if + call decref(matrix) + if (has_references(matrix)) then + goto 42 + end if - call deallocate(matrix%sparsity) + call deallocate(matrix%sparsity) - if (.not. (matrix%clone .and. matrix%external_val)) then - if (associated(matrix%val)) then + if (.not. (matrix%clone .and. matrix%external_val)) then + if (associated(matrix%val)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "real", & - size(matrix%val), name=matrix%name) + call register_deallocation("csr_matrix", "real", & + size(matrix%val), name=matrix%name) #endif #ifdef DDEBUG - matrix%val=ieee_value(0.0, ieee_quiet_nan) + matrix%val=ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(matrix%val, stat=lstat) - if (lstat/=0) goto 42 - end if - if (associated(matrix%ival)) then + deallocate(matrix%val, stat=lstat) + if (lstat/=0) goto 42 + end if + if (associated(matrix%ival)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "integer", & - size(matrix%ival), name=matrix%name) + call register_deallocation("csr_matrix", "integer", & + size(matrix%ival), name=matrix%name) #endif - deallocate(matrix%ival, stat=lstat) + deallocate(matrix%ival, stat=lstat) + if (lstat/=0) goto 42 + end if + end if + + if(can_have_inactive(matrix)) then + if(has_inactive(matrix)) then + deallocate(matrix%inactive%ptr, stat=lstat) + if (lstat/=0) goto 42 + end if + deallocate(matrix%inactive, stat=lstat) if (lstat/=0) goto 42 end if - end if - if(can_have_inactive(matrix)) then - if(has_inactive(matrix)) then - deallocate(matrix%inactive%ptr, stat=lstat) - if (lstat/=0) goto 42 + if (.not. associated(matrix%ksp)) then + FLAbort("Attempt made to deallocate a non-allocated or damaged CSR matrix.") + end if + + if (matrix%ksp/=PETSC_NULL_KSP) then + call KSPDestroy(matrix%ksp, lstat) + if (lstat/=0) then + if (present(stat)) then + ewrite(0,*) "Error from KSPDestroy in deallocate_csr_matrix." + stat=lstat + return + end if + FLAbort("Error from KSPDestroy in deallocate_csr_matrix.") + end if + end if + deallocate(matrix%ksp) + +42 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to deallocate matrix.") + end if + end if + + + end subroutine deallocate_csr_matrix + + subroutine allocate_block_csr_matrix(matrix, sparsity, blocks, data, name, & + diagonal, equal_diagonal_blocks, stat) + type(block_csr_matrix), intent(out) :: matrix + type(csr_sparsity), intent(in) :: sparsity + integer, intent(in), dimension(2) :: blocks + !! Whether the blocks should be filled with data. + logical, intent(in), optional :: data + character(len=*), optional :: name + !! Whether to allocate just the diagonal blocks or not (default is not) + logical, intent(in), optional :: diagonal + !! Together with diagonal this means all diagonal blocks will be the same, + !! i.e. they point at the same bit of memory + logical, intent(in), optional :: equal_diagonal_blocks + integer, intent(out), optional :: stat + + integer :: lstat, i, j + character(len=FIELD_NAME_LEN) :: lname + + lstat = 0 + + if (present(name)) then + lname = name + else + lname = "" + end if + matrix%name = lname + + if(present_and_true(diagonal).and.(blocks(1)/=blocks(2))) then + FLAbort("Attempt made to allocate a non-square diagonal block_csr_matrix!") end if - deallocate(matrix%inactive, stat=lstat) + matrix%diagonal = present_and_true(diagonal) + matrix%equal_diagonal_blocks = present_and_true(equal_diagonal_blocks) + + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) + + matrix%sparsity=sparsity + + call incref(matrix%sparsity) + matrix%blocks=blocks + + allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) if (lstat/=0) goto 42 - end if - - if (.not. associated(matrix%ksp)) then - FLAbort("Attempt made to deallocate a non-allocated or damaged CSR matrix.") - end if - - if (matrix%ksp/=PETSC_NULL_KSP) then - call KSPDestroy(matrix%ksp, lstat) - if (lstat/=0) then - if (present(stat)) then - ewrite(0,*) "Error from KSPDestroy in deallocate_csr_matrix." - stat=lstat - return - end if - FLAbort("Error from KSPDestroy in deallocate_csr_matrix.") - end if - end if - deallocate(matrix%ksp) - -42 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to deallocate matrix.") - end if - end if - - - end subroutine deallocate_csr_matrix - - subroutine allocate_block_csr_matrix(matrix, sparsity, blocks, data, name, & - diagonal, equal_diagonal_blocks, stat) - type(block_csr_matrix), intent(out) :: matrix - type(csr_sparsity), intent(in) :: sparsity - integer, intent(in), dimension(2) :: blocks - !! Whether the blocks should be filled with data. - logical, intent(in), optional :: data - character(len=*), optional :: name - !! Whether to allocate just the diagonal blocks or not (default is not) - logical, intent(in), optional :: diagonal - !! Together with diagonal this means all diagonal blocks will be the same, - !! i.e. they point at the same bit of memory - logical, intent(in), optional :: equal_diagonal_blocks - integer, intent(out), optional :: stat - - integer :: lstat, i, j - character(len=FIELD_NAME_LEN) :: lname - - lstat = 0 - - if (present(name)) then - lname = name - else - lname = "" - end if - matrix%name = lname - - if(present_and_true(diagonal).and.(blocks(1)/=blocks(2))) then - FLAbort("Attempt made to allocate a non-square diagonal block_csr_matrix!") - end if - matrix%diagonal = present_and_true(diagonal) - matrix%equal_diagonal_blocks = present_and_true(equal_diagonal_blocks) - - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) - - matrix%sparsity=sparsity - - call incref(matrix%sparsity) - matrix%blocks=blocks - - allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) - if (lstat/=0) goto 42 - - if (present_and_false(data)) then - - ! no data to be allocated at all: - do i=1, blocks(1) - do j=1, blocks(2) - nullify(matrix%val(i,j)%ptr) - end do - end do - matrix%external_val=.true. - else if (matrix%diagonal) then + if (present_and_false(data)) then + + ! no data to be allocated at all: + do i=1, blocks(1) + do j=1, blocks(2) + nullify(matrix%val(i,j)%ptr) + end do + end do + matrix%external_val=.true. + + else if (matrix%diagonal) then - ! only allocate diagonal blocks + ! only allocate diagonal blocks - do i=1, blocks(1) - do j=1, blocks(2) - nullify(matrix%val(i,j)%ptr) - end do - end do + do i=1, blocks(1) + do j=1, blocks(2) + nullify(matrix%val(i,j)%ptr) + end do + end do - if (matrix%equal_diagonal_blocks) then - allocate(matrix%val(1,1)%ptr(size(sparsity%colm)), stat=lstat) + if (matrix%equal_diagonal_blocks) then + allocate(matrix%val(1,1)%ptr(size(sparsity%colm)), stat=lstat) #ifdef HAVE_MEMORY_STATS - call register_allocation("csr_matrix", "real", & - size(sparsity%colm), name=name) + call register_allocation("csr_matrix", "real", & + size(sparsity%colm), name=name) #endif - if (lstat/=0) goto 42 - do i=2, blocks(1) - matrix%val(i,i)%ptr => matrix%val(1,1)%ptr - end do - else - do i=1, blocks(1) - allocate(matrix%val(i,i)%ptr(size(sparsity%colm)), stat=lstat) + if (lstat/=0) goto 42 + do i=2, blocks(1) + matrix%val(i,i)%ptr => matrix%val(1,1)%ptr + end do + else + do i=1, blocks(1) + allocate(matrix%val(i,i)%ptr(size(sparsity%colm)), stat=lstat) #ifdef HAVE_MEMORY_STATS - call register_allocation("csr_matrix", "real", & + call register_allocation("csr_matrix", "real", & size(sparsity%colm), name=name) #endif - if (lstat/=0) goto 42 - end do - end if - matrix%external_val=.false. + if (lstat/=0) goto 42 + end do + end if + matrix%external_val=.false. - else + else - ! normal case: allocate all blocks - do i=1,blocks(1) - do j=1,blocks(2) - allocate(matrix%val(i,j)%ptr(size(sparsity%colm)), stat=lstat) + ! normal case: allocate all blocks + do i=1,blocks(1) + do j=1,blocks(2) + allocate(matrix%val(i,j)%ptr(size(sparsity%colm)), stat=lstat) #ifdef HAVE_MEMORY_STATS - call register_allocation("csr_matrix", "real", & + call register_allocation("csr_matrix", "real", & size(sparsity%colm), name=name) #endif - if (lstat/=0) goto 42 + if (lstat/=0) goto 42 + end do end do - end do - matrix%external_val=.false. + matrix%external_val=.false. - end if + end if - ! always allocate to make sure all references see the same %ksp - allocate(matrix%ksp) - matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available + ! always allocate to make sure all references see the same %ksp + allocate(matrix%ksp) + matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available -42 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then +42 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then - FLAbort("Failed to allocate matrix.") - end if - end if + FLAbort("Failed to allocate matrix.") + end if + end if - end subroutine allocate_block_csr_matrix + end subroutine allocate_block_csr_matrix - subroutine deallocate_block_csr_matrix(matrix, stat) - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(out), optional :: stat + subroutine deallocate_block_csr_matrix(matrix, stat) + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(out), optional :: stat - integer :: lstat, i, j + integer :: lstat, i, j - lstat=0 + lstat=0 - call decref(matrix) - if (has_references(matrix)) then - goto 42 - end if + call decref(matrix) + if (has_references(matrix)) then + goto 42 + end if - call deallocate(matrix%sparsity) + call deallocate(matrix%sparsity) - if (associated(matrix%val)) then - if (.not. (matrix%clone .and. matrix%external_val)) then - if (matrix%equal_diagonal_blocks) then + if (associated(matrix%val)) then + if (.not. (matrix%clone .and. matrix%external_val)) then + if (matrix%equal_diagonal_blocks) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "real", & - size(matrix%val(1,1)%ptr), name=matrix%name) + call register_deallocation("csr_matrix", "real", & + size(matrix%val(1,1)%ptr), name=matrix%name) #endif #ifdef DDEBUG - matrix%val(1,1)%ptr=ieee_value(0.0, ieee_quiet_nan) + matrix%val(1,1)%ptr=ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(matrix%val(1,1)%ptr, stat=lstat) - if (lstat/=0) goto 42 - elseif (matrix%diagonal) then - do i=1, matrix%blocks(1) + deallocate(matrix%val(1,1)%ptr, stat=lstat) + if (lstat/=0) goto 42 + elseif (matrix%diagonal) then + do i=1, matrix%blocks(1) #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "real", & - size(matrix%val(i,i)%ptr), name=matrix%name) + call register_deallocation("csr_matrix", "real", & + size(matrix%val(i,i)%ptr), name=matrix%name) #endif #ifdef DDEBUG - matrix%val(i,i)%ptr=ieee_value(0.0, ieee_quiet_nan) + matrix%val(i,i)%ptr=ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(matrix%val(i,i)%ptr, stat=lstat) - end do - else - do i=1,matrix%blocks(1) - do j=1,matrix%blocks(2) + deallocate(matrix%val(i,i)%ptr, stat=lstat) + end do + else + do i=1,matrix%blocks(1) + do j=1,matrix%blocks(2) #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "real", & - size(matrix%val(i,j)%ptr), name=matrix%name) + call register_deallocation("csr_matrix", "real", & + size(matrix%val(i,j)%ptr), name=matrix%name) #endif #ifdef DDEBUG - matrix%val(i,j)%ptr=ieee_value(0.0, ieee_quiet_nan) + matrix%val(i,j)%ptr=ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(matrix%val(i,j)%ptr, stat=lstat) - if (lstat/=0) goto 42 - end do - end do - end if + deallocate(matrix%val(i,j)%ptr, stat=lstat) + if (lstat/=0) goto 42 + end do + end do + end if + end if + ! the val pointer-array is always allocated by us: + deallocate(matrix%val, stat=lstat) + if (lstat/=0) goto 42 end if - ! the val pointer-array is always allocated by us: - deallocate(matrix%val, stat=lstat) - if (lstat/=0) goto 42 - end if - - if (.not. associated(matrix%ksp)) then - FLAbort("Attempt made to deallocate a non-allocated or damaged CSR matrix.") - end if - if (matrix%ksp/=PETSC_NULL_KSP) then - call KSPDestroy(matrix%ksp, lstat) - if (lstat/=0) then - if (present(stat)) then - ewrite(0,*) "Error from KSPDestroy in deallocate_csr_matrix" - stat=lstat - return - end if - FLAbort("Error from KSPDestroy in deallocate_csr_matrix.") - end if - end if - deallocate(matrix%ksp) - - if (associated(matrix%ival)) then - if (.not. (matrix%clone .and. matrix%external_val)) then - if (matrix%equal_diagonal_blocks) then + + if (.not. associated(matrix%ksp)) then + FLAbort("Attempt made to deallocate a non-allocated or damaged CSR matrix.") + end if + if (matrix%ksp/=PETSC_NULL_KSP) then + call KSPDestroy(matrix%ksp, lstat) + if (lstat/=0) then + if (present(stat)) then + ewrite(0,*) "Error from KSPDestroy in deallocate_csr_matrix" + stat=lstat + return + end if + FLAbort("Error from KSPDestroy in deallocate_csr_matrix.") + end if + end if + deallocate(matrix%ksp) + + if (associated(matrix%ival)) then + if (.not. (matrix%clone .and. matrix%external_val)) then + if (matrix%equal_diagonal_blocks) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "integer", & - size(matrix%ival(1,1)%ptr), name=matrix%name) + call register_deallocation("csr_matrix", "integer", & + size(matrix%ival(1,1)%ptr), name=matrix%name) #endif - deallocate(matrix%ival(1,1)%ptr, stat=lstat) - if (lstat/=0) goto 42 - elseif (matrix%diagonal) then - do i=1, matrix%blocks(1) + deallocate(matrix%ival(1,1)%ptr, stat=lstat) + if (lstat/=0) goto 42 + elseif (matrix%diagonal) then + do i=1, matrix%blocks(1) #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "integer", & - size(matrix%ival(i,i)%ptr), name=matrix%name) + call register_deallocation("csr_matrix", "integer", & + size(matrix%ival(i,i)%ptr), name=matrix%name) #endif - deallocate(matrix%ival(i,i)%ptr, stat=lstat) - end do - else - do i=1,matrix%blocks(1) - do j=1,matrix%blocks(2) + deallocate(matrix%ival(i,i)%ptr, stat=lstat) + end do + else + do i=1,matrix%blocks(1) + do j=1,matrix%blocks(2) #ifdef HAVE_MEMORY_STATS - call register_deallocation("csr_matrix", "integer", & - size(matrix%ival(i,j)%ptr), name=matrix%name) + call register_deallocation("csr_matrix", "integer", & + size(matrix%ival(i,j)%ptr), name=matrix%name) #endif - deallocate(matrix%ival(i,j)%ptr, stat=lstat) - if (lstat/=0) goto 42 - end do - end do - end if + deallocate(matrix%ival(i,j)%ptr, stat=lstat) + if (lstat/=0) goto 42 + end do + end do + end if + end if + ! the val pointer-array is always allocated by us: + deallocate(matrix%ival, stat=lstat) + if (lstat/=0) goto 42 end if - ! the val pointer-array is always allocated by us: - deallocate(matrix%ival, stat=lstat) - if (lstat/=0) goto 42 - end if -42 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to deallocate matrix.") - end if - end if +42 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to deallocate matrix.") + end if + end if - end subroutine deallocate_block_csr_matrix + end subroutine deallocate_block_csr_matrix - subroutine allocate_dcsr_matrix(matrix, rows, columns, name, stat) - !!< Allocate the core of a dynamic csr matrix. Due to the dynamic - !!< nature of these matrices, further allocation will occur as the - !!< matrix is constructed. - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: rows - integer, intent(in) :: columns - character(len=*), optional :: name - integer, intent(out), optional :: stat + subroutine allocate_dcsr_matrix(matrix, rows, columns, name, stat) + !!< Allocate the core of a dynamic csr matrix. Due to the dynamic + !!< nature of these matrices, further allocation will occur as the + !!< matrix is constructed. + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: rows + integer, intent(in) :: columns + character(len=*), optional :: name + integer, intent(out), optional :: stat - integer :: lstat, i - character(len=FIELD_NAME_LEN) :: lname + integer :: lstat, i + character(len=FIELD_NAME_LEN) :: lname - if (present(name)) then - lname = name - else - lname = "" - end if - matrix%name = lname + if (present(name)) then + lname = name + else + lname = "" + end if + matrix%name = lname - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) - matrix%columns=columns + matrix%columns=columns - allocate(matrix%colm(rows), matrix%val(rows), stat=lstat) + allocate(matrix%colm(rows), matrix%val(rows), stat=lstat) - if (lstat/=0) goto 666 + if (lstat/=0) goto 666 - do i=1, rows - allocate(matrix%colm(i)%ptr(0), matrix%val(i)%ptr(0), stat=lstat) - if (lstat/=0) goto 666 - end do + do i=1, rows + allocate(matrix%colm(i)%ptr(0), matrix%val(i)%ptr(0), stat=lstat) + if (lstat/=0) goto 666 + end do -666 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to allocate matrix.") - end if - end if +666 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to allocate matrix.") + end if + end if - end subroutine allocate_dcsr_matrix + end subroutine allocate_dcsr_matrix - subroutine deallocate_dcsr_matrix(matrix, stat) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(out), optional :: stat + subroutine deallocate_dcsr_matrix(matrix, stat) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(out), optional :: stat - integer :: lstat, i + integer :: lstat, i - call decref(matrix) - if (has_references(matrix)) then - goto 666 - end if + call decref(matrix) + if (has_references(matrix)) then + goto 666 + end if - do i=1,size(matrix%colm) + do i=1,size(matrix%colm) #ifdef DDEBUG - matrix%val(i)%ptr=ieee_value(0.0, ieee_quiet_nan) + matrix%val(i)%ptr=ieee_value(0.0, ieee_quiet_nan) #endif - deallocate(matrix%colm(i)%ptr, matrix%val(i)%ptr, stat=lstat) - if (lstat/=0) goto 666 - end do - - deallocate(matrix%colm, matrix%val, stat=lstat) - -666 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to deallocate matrix.") - end if - end if - - end subroutine deallocate_dcsr_matrix - - subroutine allocate_block_dcsr_matrix(matrix, blocks, rows, columns, name, stat) - type(block_dynamic_csr_matrix), intent(inout) :: matrix - !! Number of rows and columns of blocks. - integer, dimension(2), intent(in) :: blocks - !! Number of rows in each block row. - integer, dimension(blocks(1)), intent(in) :: rows - !! Number of rows in each block column. - integer, dimension(blocks(2)), intent(in) :: columns - character(len=*), optional :: name - integer, intent(out), optional :: stat - - integer :: lstat, i, j - character(len=FIELD_NAME_LEN) :: lname - - if (present(name)) then - lname = name - else - lname = "" - end if - matrix%name = lname - - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) - - allocate(matrix%blocks(blocks(1), blocks(2)), stat=lstat) - - if (lstat/=0) goto 666 - - do i=1,blocks(1) - do j=1,blocks(2) - call allocate(matrix%blocks(i,j),rows(i),columns(j), stat=lstat) - if (lstat/=0) goto 666 - end do - end do - -666 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to allocate matrix.") - end if - end if - - end subroutine allocate_block_dcsr_matrix - - subroutine deallocate_block_dcsr_matrix(matrix, stat) - type(block_dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(out), optional :: stat - - integer :: i, j, lstat - - call decref(matrix) - if (has_references(matrix)) then - goto 666 - end if - - do i=1,size(matrix%blocks,1) - do j=1,size(matrix%blocks,2) - call deallocate(matrix%blocks(i,j), stat=lstat) - if (lstat/=0) goto 666 - end do - end do - - deallocate(matrix%blocks, stat=lstat) - -666 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to deallocate matrix.") - end if - end if - - end subroutine deallocate_block_dcsr_matrix - - function csr_block(matrix, block_i, block_j) result (block_out) - !!< Extract block block_i, block_j from matrix. - !!< This is the only case where the returned matrix - !!< is not to be deallocated!!! - type(csr_matrix) :: block_out - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: block_i, block_j - - if(matrix%diagonal.and.(block_i/=block_j)) then - FLAbort("Attempting to extract an off-diagonal block from a diagonal block_csr_matrix.") - end if - - block_out%clone=.true. - - block_out%sparsity=matrix%sparsity - - if (associated(matrix%val)) then - block_out%val => matrix%val(block_i,block_j)%ptr - ! should only be deallocated in the deallocate() call for the orig. matrix - block_out%external_val=.true. - end if - if (associated(matrix%ival)) then - block_out%ival=> matrix%ival(block_i,block_j)%ptr - ! should only be deallocated in the deallocate() call for the orig. matrix - block_out%external_val=.true. - end if - - ! "Borrowed" matrices cannot have inactive nodes - nullify(block_out%inactive) - - ! we can't unfortunately, as csr_blocks aren't always deallocated - nullify(block_out%ksp) - - end function csr_block - - function dcsr_block(matrix, block_i, block_j) result (block_out) - !!< Extract block block_i, block_j from matrix. - type(dynamic_csr_matrix) :: block_out - type(block_dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: block_i, block_j - - block_out=matrix%blocks(block_i, block_j) - - end function dcsr_block - - function wrap_csr_matrix(sparsity, val, ival, name, stat) result (matrix) - !!< Create a matrix using sparsity and the val or ival provided. - !!< The wrapping matrix must be deallocated after use!!! - type(csr_matrix) :: matrix - type(csr_sparsity), intent(in) :: sparsity - real, dimension(size(sparsity%colm)), intent(in), target, optional :: val - integer, dimension(size(sparsity%colm)), intent(in), target, optional ::& - & ival - character(len=*), intent(in):: name - integer, intent(out), optional :: stat - - integer :: lstat - - matrix%clone=.true. - matrix%name=name - - nullify(matrix%refcount) - call addref(matrix) - - matrix%sparsity=sparsity - call incref(sparsity) - - ! This is a workaround for a gfortran initialisation bug. - matrix%val=>null() - matrix%ival=>null() - - if (present(val)) then - assert(size(sparsity%colm)==size(val)) - matrix%val=>val - ! avoid deallocation of val in deallocate(): - matrix%external_val=.true. - lstat=0 - else if (present(ival)) then - assert(size(sparsity%colm)==size(ival)) - matrix%ival=>ival - ! avoid deallocation of ival in deallocate(): - matrix%external_val=.true. - lstat=0 - else - FLAbort("Either val or ival must be provided to wrap_matrix.") - end if - - ! always allocate to make sure all references see the same %ksp - allocate(matrix%ksp) - matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available - - ! Wrapped matrices can have inactive nodes - allocate( matrix%inactive, stat=lstat ) - nullify( matrix%inactive%ptr ) - - if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to wrap matrix.") - end if - end if - - end function wrap_csr_matrix - - function block_wrap_csr_matrix(sparsity, blocks, & - val, ival, name, stat) result (matrix) - !!< Return a matrix with the same structure but different data space to - !!< matrix. If val is present then it is used as the data space. - !!< Otherwise, a new space is allocated. - !!< The wrapping matrix must be deallocated after use!!! - type(block_csr_matrix) :: matrix - type(csr_sparsity), intent(in) :: sparsity - integer, dimension(2), intent(in)::blocks - real, dimension(size(sparsity%colm)*product(blocks)), & - intent(in), target, optional :: val - integer, dimension(size(sparsity%colm)*product(blocks)), & - intent(in), target, optional :: ival - character(len=*), intent(in):: name - integer, intent(out), optional :: stat - - integer :: lstat, i, j, bs - - lstat=0 - matrix%clone=.true. - matrix%name=name - - nullify(matrix%refcount) - call addref(matrix) - matrix%sparsity=sparsity - call incref(sparsity) - - matrix%blocks=blocks - matrix%diagonal=.false. - - ! this is a temp. measure as long as gfortran does not do it automatically - nullify(matrix%val) - nullify(matrix%ival) - - if (present(val)) then - allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) - do i=1,blocks(1) - do j=1,blocks(2) - bs=blockstart(matrix, i, j) - matrix%val(i,j)%ptr=>val(bs:bs+size(matrix%sparsity%colm)-1) - end do - end do - lstat=0 - ! avoid deallocation of val in deallocate(): - matrix%external_val=.true. - else if (present(ival)) then - allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) - do i=1,blocks(1) - do j=1,blocks(2) - bs=blockstart(matrix, i, j) - matrix%val(i,j)%ptr=>val(bs:bs+size(matrix%sparsity%colm)-1) - end do - end do - lstat=0 - ! avoid deallocation of val in deallocate(): - matrix%external_val=.true. - else - ! No data space. - allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) - do i=1,blocks(1) - do j=1,blocks(2) - nullify(matrix%val(i,j)%ptr) - end do - end do - lstat=0 - ! avoid deallocation of val in deallocate(): - matrix%external_val=.true. - end if - - ! always allocate to make sure all references see the same %ksp - allocate(matrix%ksp) - matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available - - if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to wrap matrix.") - end if - end if - - end function block_wrap_csr_matrix - - subroutine unclone_csr_matrix(matrix) - !!< Specify that matrix is no longer a clone. This is useful for memory - !!< management but be careful not to shoot yourself in the foot! - type(csr_matrix), intent(inout) :: matrix - - if (matrix%clone .and. matrix%external_val) then - FLAbort("Can't unclone this matrix as it is using externally stored values.") - end if - matrix%clone=.false. - - end subroutine unclone_csr_matrix - - subroutine block_csr_attach_block(matrix, blocki, blockj, val) - !!< Having cloned a csr matrix without data, insert val as one of the - !!< blocks. - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki, blockj - real, dimension(size(matrix%sparsity%colm)), intent(in), target :: val - - if (.not.associated(matrix%val)) then - allocate(matrix%val(matrix%blocks(1), matrix%blocks(2))) - else if (.not. matrix%external_val) then - FLAbort("Can't attach block of data as value memory has been allocated internally.") - end if - - matrix%val(blocki,blockj)%ptr=>val - - ! avoid deallocation of val in deallocate(): - matrix%external_val=.true. - - end subroutine block_csr_attach_block - - function wrap_csr_sparsity(findrm, centrm, colm, name, & - row_halo, column_halo) result(sparsity) - !!< Wrap a csr_matrix around the sparsity pattern defined by the input - !!< arguments. - type(csr_sparsity) :: sparsity - integer, dimension(:), intent(in), target :: findrm, colm - integer, dimension(:), intent(in), target, optional :: centrm - character(len=*), intent(in):: name - type(halo_type), optional, intent(in):: row_halo, column_halo - - sparsity%name=name + deallocate(matrix%colm(i)%ptr, matrix%val(i)%ptr, stat=lstat) + if (lstat/=0) goto 666 + end do + + deallocate(matrix%colm, matrix%val, stat=lstat) + +666 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to deallocate matrix.") + end if + end if + + end subroutine deallocate_dcsr_matrix + + subroutine allocate_block_dcsr_matrix(matrix, blocks, rows, columns, name, stat) + type(block_dynamic_csr_matrix), intent(inout) :: matrix + !! Number of rows and columns of blocks. + integer, dimension(2), intent(in) :: blocks + !! Number of rows in each block row. + integer, dimension(blocks(1)), intent(in) :: rows + !! Number of rows in each block column. + integer, dimension(blocks(2)), intent(in) :: columns + character(len=*), optional :: name + integer, intent(out), optional :: stat + + integer :: lstat, i, j + character(len=FIELD_NAME_LEN) :: lname + + if (present(name)) then + lname = name + else + lname = "" + end if + matrix%name = lname + + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) + + allocate(matrix%blocks(blocks(1), blocks(2)), stat=lstat) + + if (lstat/=0) goto 666 + + do i=1,blocks(1) + do j=1,blocks(2) + call allocate(matrix%blocks(i,j),rows(i),columns(j), stat=lstat) + if (lstat/=0) goto 666 + end do + end do + +666 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to allocate matrix.") + end if + end if + + end subroutine allocate_block_dcsr_matrix - sparsity%findrm=>findrm - if (present(centrm)) then - sparsity%centrm=>centrm - else - sparsity%centrm=>null() - end if - sparsity%colm=>colm + subroutine deallocate_block_dcsr_matrix(matrix, stat) + type(block_dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(out), optional :: stat - nullify(sparsity%refcount) - call addref(sparsity) - sparsity%wrapped=.true. + integer :: i, j, lstat + + call decref(matrix) + if (has_references(matrix)) then + goto 666 + end if - ! Attempt to work out columns by voodoo. Not totally safe! - sparsity%columns=maxval(colm) - - if (present(row_halo)) then - allocate(sparsity%row_halo) - sparsity%row_halo=row_halo - call incref(row_halo) - end if + do i=1,size(matrix%blocks,1) + do j=1,size(matrix%blocks,2) + call deallocate(matrix%blocks(i,j), stat=lstat) + if (lstat/=0) goto 666 + end do + end do - if (present(column_halo)) then - allocate(sparsity%column_halo) - sparsity%column_halo=column_halo - call incref(column_halo) - end if + deallocate(matrix%blocks, stat=lstat) - end function wrap_csr_sparsity +666 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to deallocate matrix.") + end if + end if - pure function sparsity_size(sparsity, dim) - !!< Clone of size function. - integer :: sparsity_size - type(csr_sparsity), intent(in) :: sparsity - integer, optional, intent(in) :: dim + end subroutine deallocate_block_dcsr_matrix - integer, dimension(2) :: shape + function csr_block(matrix, block_i, block_j) result (block_out) + !!< Extract block block_i, block_j from matrix. + !!< This is the only case where the returned matrix + !!< is not to be deallocated!!! + type(csr_matrix) :: block_out + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: block_i, block_j - shape(1)=size(sparsity%findrm)-1 - shape(2)=sparsity%columns + if(matrix%diagonal.and.(block_i/=block_j)) then + FLAbort("Attempting to extract an off-diagonal block from a diagonal block_csr_matrix.") + end if - if (present(dim)) then - sparsity_size=shape(dim) - else - sparsity_size=product(shape) - end if + block_out%clone=.true. - end function sparsity_size + block_out%sparsity=matrix%sparsity - pure function csr_size(matrix, dim) - !!< Clone of size function. - integer :: csr_size - type(csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim + if (associated(matrix%val)) then + block_out%val => matrix%val(block_i,block_j)%ptr + ! should only be deallocated in the deallocate() call for the orig. matrix + block_out%external_val=.true. + end if + if (associated(matrix%ival)) then + block_out%ival=> matrix%ival(block_i,block_j)%ptr + ! should only be deallocated in the deallocate() call for the orig. matrix + block_out%external_val=.true. + end if - csr_size=sparsity_size(matrix%sparsity, dim) + ! "Borrowed" matrices cannot have inactive nodes + nullify(block_out%inactive) + + ! we can't unfortunately, as csr_blocks aren't always deallocated + nullify(block_out%ksp) + + end function csr_block + + function dcsr_block(matrix, block_i, block_j) result (block_out) + !!< Extract block block_i, block_j from matrix. + type(dynamic_csr_matrix) :: block_out + type(block_dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: block_i, block_j + + block_out=matrix%blocks(block_i, block_j) + + end function dcsr_block + + function wrap_csr_matrix(sparsity, val, ival, name, stat) result (matrix) + !!< Create a matrix using sparsity and the val or ival provided. + !!< The wrapping matrix must be deallocated after use!!! + type(csr_matrix) :: matrix + type(csr_sparsity), intent(in) :: sparsity + real, dimension(size(sparsity%colm)), intent(in), target, optional :: val + integer, dimension(size(sparsity%colm)), intent(in), target, optional ::& + & ival + character(len=*), intent(in):: name + integer, intent(out), optional :: stat + + integer :: lstat + + matrix%clone=.true. + matrix%name=name + + nullify(matrix%refcount) + call addref(matrix) + + matrix%sparsity=sparsity + call incref(sparsity) + + ! This is a workaround for a gfortran initialisation bug. + matrix%val=>null() + matrix%ival=>null() + + if (present(val)) then + assert(size(sparsity%colm)==size(val)) + matrix%val=>val + ! avoid deallocation of val in deallocate(): + matrix%external_val=.true. + lstat=0 + else if (present(ival)) then + assert(size(sparsity%colm)==size(ival)) + matrix%ival=>ival + ! avoid deallocation of ival in deallocate(): + matrix%external_val=.true. + lstat=0 + else + FLAbort("Either val or ival must be provided to wrap_matrix.") + end if - end function csr_size + ! always allocate to make sure all references see the same %ksp + allocate(matrix%ksp) + matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available - pure function block_csr_size(matrix, dim) - !!< Clone of size function. - integer :: block_csr_size - type(block_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim + ! Wrapped matrices can have inactive nodes + allocate( matrix%inactive, stat=lstat ) + nullify( matrix%inactive%ptr ) - integer, dimension(2) :: shape + if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to wrap matrix.") + end if + end if - shape(1)=size(matrix%sparsity%findrm)-1 - shape(2)=matrix%sparsity%columns + end function wrap_csr_matrix + + function block_wrap_csr_matrix(sparsity, blocks, & + val, ival, name, stat) result (matrix) + !!< Return a matrix with the same structure but different data space to + !!< matrix. If val is present then it is used as the data space. + !!< Otherwise, a new space is allocated. + !!< The wrapping matrix must be deallocated after use!!! + type(block_csr_matrix) :: matrix + type(csr_sparsity), intent(in) :: sparsity + integer, dimension(2), intent(in)::blocks + real, dimension(size(sparsity%colm)*product(blocks)), & + intent(in), target, optional :: val + integer, dimension(size(sparsity%colm)*product(blocks)), & + intent(in), target, optional :: ival + character(len=*), intent(in):: name + integer, intent(out), optional :: stat - if (.not.present(dim)) then - block_csr_size = product(shape)*product(matrix%blocks) - else - block_csr_size = shape(dim)*matrix%blocks(dim) - end if + integer :: lstat, i, j, bs - end function block_csr_size + lstat=0 + matrix%clone=.true. + matrix%name=name - pure function block_csr_block_size(matrix, dim) result (block_size) - !!< Clone of size function. Assumes matrix is blocks of square matrices. - integer :: block_size - type(block_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim + nullify(matrix%refcount) + call addref(matrix) + matrix%sparsity=sparsity + call incref(sparsity) - block_size=sparsity_size(matrix%sparsity, dim) + matrix%blocks=blocks + matrix%diagonal=.false. - end function block_csr_block_size + ! this is a temp. measure as long as gfortran does not do it automatically + nullify(matrix%val) + nullify(matrix%ival) - pure function block_dcsr_block_size(matrix, block_i, block_j, dim) & - result (block_size) - !!< Size function for an individual matrix block. - integer :: block_size - type(block_dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: block_i, block_j - integer, optional, intent(in) :: dim + if (present(val)) then + allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) + do i=1,blocks(1) + do j=1,blocks(2) + bs=blockstart(matrix, i, j) + matrix%val(i,j)%ptr=>val(bs:bs+size(matrix%sparsity%colm)-1) + end do + end do + lstat=0 + ! avoid deallocation of val in deallocate(): + matrix%external_val=.true. + else if (present(ival)) then + allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) + do i=1,blocks(1) + do j=1,blocks(2) + bs=blockstart(matrix, i, j) + matrix%val(i,j)%ptr=>val(bs:bs+size(matrix%sparsity%colm)-1) + end do + end do + lstat=0 + ! avoid deallocation of val in deallocate(): + matrix%external_val=.true. + else + ! No data space. + allocate(matrix%val(blocks(1),blocks(2)), stat=lstat) + do i=1,blocks(1) + do j=1,blocks(2) + nullify(matrix%val(i,j)%ptr) + end do + end do + lstat=0 + ! avoid deallocation of val in deallocate(): + matrix%external_val=.true. + end if - block_size=size(matrix%blocks(block_i, block_j), dim) + ! always allocate to make sure all references see the same %ksp + allocate(matrix%ksp) + matrix%ksp=PETSC_NULL_KSP ! to indicate no ksp cache available - end function block_dcsr_block_size + if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to wrap matrix.") + end if + end if - pure function dcsr_size(matrix, dim) - !!< Clone of size function. Assumes matrix is square. - integer :: dcsr_size - type(dynamic_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim + end function block_wrap_csr_matrix - integer, dimension(2) :: shape + subroutine unclone_csr_matrix(matrix) + !!< Specify that matrix is no longer a clone. This is useful for memory + !!< management but be careful not to shoot yourself in the foot! + type(csr_matrix), intent(inout) :: matrix - shape(1)=size(matrix%colm) - shape(2)=matrix%columns + if (matrix%clone .and. matrix%external_val) then + FLAbort("Can't unclone this matrix as it is using externally stored values.") + end if + matrix%clone=.false. - if (present(dim)) then - dcsr_size=shape(dim) - else - dcsr_size=product(shape) - end if + end subroutine unclone_csr_matrix - end function dcsr_size + subroutine block_csr_attach_block(matrix, blocki, blockj, val) + !!< Having cloned a csr matrix without data, insert val as one of the + !!< blocks. + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki, blockj + real, dimension(size(matrix%sparsity%colm)), intent(in), target :: val - pure function block_dcsr_size(matrix, dim) result(dcsr_size) - !!< Clone of size function. Assumes matrix is square. - integer :: dcsr_size - type(block_dynamic_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim + if (.not.associated(matrix%val)) then + allocate(matrix%val(matrix%blocks(1), matrix%blocks(2))) + else if (.not. matrix%external_val) then + FLAbort("Can't attach block of data as value memory has been allocated internally.") + end if - integer, dimension(2) :: shape - integer :: i, j + matrix%val(blocki,blockj)%ptr=>val - shape=0 + ! avoid deallocation of val in deallocate(): + matrix%external_val=.true. - do i=1,size(matrix%blocks,1) - shape(1)=shape(1)+size(matrix%blocks(i,1),1) - end do + end subroutine block_csr_attach_block - do j=1,size(matrix%blocks,2) - shape(2)=shape(2)+size(matrix%blocks(1,j),2) - end do + function wrap_csr_sparsity(findrm, centrm, colm, name, & + row_halo, column_halo) result(sparsity) + !!< Wrap a csr_matrix around the sparsity pattern defined by the input + !!< arguments. + type(csr_sparsity) :: sparsity + integer, dimension(:), intent(in), target :: findrm, colm + integer, dimension(:), intent(in), target, optional :: centrm + character(len=*), intent(in):: name + type(halo_type), optional, intent(in):: row_halo, column_halo + + sparsity%name=name + + sparsity%findrm=>findrm + if (present(centrm)) then + sparsity%centrm=>centrm + else + sparsity%centrm=>null() + end if + sparsity%colm=>colm - if (present(dim)) then - dcsr_size=shape(dim) - else - dcsr_size=product(shape) - end if + nullify(sparsity%refcount) + call addref(sparsity) + sparsity%wrapped=.true. - end function block_dcsr_size + ! Attempt to work out columns by voodoo. Not totally safe! + sparsity%columns=maxval(colm) - pure function blocks_nodim(matrix) - integer, dimension(2):: blocks_nodim - type(block_csr_matrix), intent(in):: matrix + if (present(row_halo)) then + allocate(sparsity%row_halo) + sparsity%row_halo=row_halo + call incref(row_halo) + end if - blocks_nodim=matrix%blocks + if (present(column_halo)) then + allocate(sparsity%column_halo) + sparsity%column_halo=column_halo + call incref(column_halo) + end if - end function blocks_nodim + end function wrap_csr_sparsity - pure function blocks_withdim(matrix, dim) - integer blocks_withdim - type(block_csr_matrix), intent(in):: matrix - integer, intent(in):: dim + pure function sparsity_size(sparsity, dim) + !!< Clone of size function. + integer :: sparsity_size + type(csr_sparsity), intent(in) :: sparsity + integer, optional, intent(in) :: dim - blocks_withdim=matrix%blocks(dim) + integer, dimension(2) :: shape - end function blocks_withdim + shape(1)=size(sparsity%findrm)-1 + shape(2)=sparsity%columns - pure function dcsr_blocks_nodim(matrix) - integer, dimension(2):: dcsr_blocks_nodim - type(block_dynamic_csr_matrix), intent(in):: matrix + if (present(dim)) then + sparsity_size=shape(dim) + else + sparsity_size=product(shape) + end if - dcsr_blocks_nodim=shape(matrix%blocks) + end function sparsity_size - end function dcsr_blocks_nodim + pure function csr_size(matrix, dim) + !!< Clone of size function. + integer :: csr_size + type(csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim - pure function dcsr_blocks_withdim(matrix, dim) - integer :: dcsr_blocks_withdim - type(block_dynamic_csr_matrix), intent(in):: matrix - integer, intent(in):: dim + csr_size=sparsity_size(matrix%sparsity, dim) - dcsr_blocks_withdim=size(matrix%blocks,dim) + end function csr_size - end function dcsr_blocks_withdim + pure function block_csr_size(matrix, dim) + !!< Clone of size function. + integer :: block_csr_size + type(block_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim - pure function sparsity_entries(sparsity) - !!< Return the number of (potentially) non-zero entries in matrix. - integer :: sparsity_entries - type(csr_sparsity), intent(in) :: sparsity + integer, dimension(2) :: shape - sparsity_entries=count(sparsity%colm/=0) + shape(1)=size(matrix%sparsity%findrm)-1 + shape(2)=matrix%sparsity%columns - end function sparsity_entries + if (.not.present(dim)) then + block_csr_size = product(shape)*product(matrix%blocks) + else + block_csr_size = shape(dim)*matrix%blocks(dim) + end if - pure function csr_entries(matrix) - !!< Return the number of (potentially) non-zero entries in matrix. - integer :: csr_entries - type(csr_matrix), intent(in) :: matrix + end function block_csr_size - csr_entries=count(matrix%sparsity%colm/=0) + pure function block_csr_block_size(matrix, dim) result (block_size) + !!< Clone of size function. Assumes matrix is blocks of square matrices. + integer :: block_size + type(block_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim - end function csr_entries + block_size=sparsity_size(matrix%sparsity, dim) - pure function dcsr_entries(matrix) - !!< Return the number of (potentially) non-zero entries in matrix. - integer :: dcsr_entries - type(dynamic_csr_matrix), intent(in) :: matrix + end function block_csr_block_size - integer i, c + pure function block_dcsr_block_size(matrix, block_i, block_j, dim) & + result (block_size) + !!< Size function for an individual matrix block. + integer :: block_size + type(block_dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: block_i, block_j + integer, optional, intent(in) :: dim - c=0 - do i=1, size(matrix,1) - c=c+size(matrix%colm(i)%ptr) - end do - dcsr_entries=c + block_size=size(matrix%blocks(block_i, block_j), dim) - end function dcsr_entries + end function block_dcsr_block_size - pure function sparsity_row_m(sparsity, i) - !!< Return the m indices of the ith row of sparsity. - type(csr_sparsity), intent(in) :: sparsity - integer, intent(in) :: i - integer, dimension(sparsity%findrm(i+1)-sparsity%findrm(i)) :: sparsity_row_m + pure function dcsr_size(matrix, dim) + !!< Clone of size function. Assumes matrix is square. + integer :: dcsr_size + type(dynamic_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim - sparsity_row_m=sparsity%colm(sparsity%findrm(i):sparsity%findrm(i+1)-1) + integer, dimension(2) :: shape - end function sparsity_row_m + shape(1)=size(matrix%colm) + shape(2)=matrix%columns - pure function csr_row_m(matrix, i) - !!< Return the m indices of the ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity& - &%findrm(i)) :: csr_row_m + if (present(dim)) then + dcsr_size=shape(dim) + else + dcsr_size=product(shape) + end if - csr_row_m=matrix%sparsity%colm& - (matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + end function dcsr_size - end function csr_row_m + pure function block_dcsr_size(matrix, dim) result(dcsr_size) + !!< Clone of size function. Assumes matrix is square. + integer :: dcsr_size + type(block_dynamic_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim - pure function dcsr_row_m(matrix, i) - !!< Return the m indices of the ith row of matrix. - type(dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(size(matrix%colm(i)%ptr)) :: dcsr_row_m + integer, dimension(2) :: shape + integer :: i, j - dcsr_row_m=matrix%colm(i)%ptr + shape=0 - end function dcsr_row_m + do i=1,size(matrix%blocks,1) + shape(1)=shape(1)+size(matrix%blocks(i,1),1) + end do - pure function block_csr_row_m(matrix, i) - !!< Return the m indices of the ith row of matrix. Since all rows in a - !!< blockmatrix are the same, we do not have to specify the block - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity& - &%findrm(i)) :: block_csr_row_m + do j=1,size(matrix%blocks,2) + shape(2)=shape(2)+size(matrix%blocks(1,j),2) + end do - block_csr_row_m=matrix%sparsity%colm& - (matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + if (present(dim)) then + dcsr_size=shape(dim) + else + dcsr_size=product(shape) + end if - end function block_csr_row_m + end function block_dcsr_size - function sparsity_row_m_ptr(sparsity, i) - !!< Return a pointer to the m indices of the ith row of matrix. - type(csr_sparsity), intent(in) :: sparsity - integer, intent(in) :: i - integer, dimension(:), pointer :: sparsity_row_m_ptr + pure function blocks_nodim(matrix) + integer, dimension(2):: blocks_nodim + type(block_csr_matrix), intent(in):: matrix - sparsity_row_m_ptr=>sparsity%colm(sparsity%findrm(i):sparsity%findrm(i+1)-1) + blocks_nodim=matrix%blocks - end function sparsity_row_m_ptr + end function blocks_nodim - function csr_row_m_ptr(matrix, i) - !!< Return a pointer to the m indices of the ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(:), pointer :: csr_row_m_ptr + pure function blocks_withdim(matrix, dim) + integer blocks_withdim + type(block_csr_matrix), intent(in):: matrix + integer, intent(in):: dim - csr_row_m_ptr=>matrix%sparsity%colm(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + blocks_withdim=matrix%blocks(dim) - end function csr_row_m_ptr + end function blocks_withdim - function block_csr_row_m_ptr(matrix, i) - !!< Return a pointer to the m indicies of the ith row of matrix. Since all - !!< rows in a blockmatrix are the same, we do not have to specify the block - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(:), pointer :: block_csr_row_m_ptr + pure function dcsr_blocks_nodim(matrix) + integer, dimension(2):: dcsr_blocks_nodim + type(block_dynamic_csr_matrix), intent(in):: matrix - block_csr_row_m_ptr=>matrix%sparsity%colm(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + dcsr_blocks_nodim=shape(matrix%blocks) - end function block_csr_row_m_ptr + end function dcsr_blocks_nodim - function dcsr_row_m_ptr(matrix, i) - !!< Return a pointer to the m indices of the ith row of matrix. - !!< For dynamic sparse matrices this remains valid until - !!< the matrix is changed. After that call row_m_ptr again. - type(dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(:), pointer :: dcsr_row_m_ptr + pure function dcsr_blocks_withdim(matrix, dim) + integer :: dcsr_blocks_withdim + type(block_dynamic_csr_matrix), intent(in):: matrix + integer, intent(in):: dim - dcsr_row_m_ptr => matrix%colm(i)%ptr + dcsr_blocks_withdim=size(matrix%blocks,dim) - end function dcsr_row_m_ptr + end function dcsr_blocks_withdim - pure function csr_row_val(matrix, i) - !!< Return the values of the ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - real, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i)) :: csr_row_val + pure function sparsity_entries(sparsity) + !!< Return the number of (potentially) non-zero entries in matrix. + integer :: sparsity_entries + type(csr_sparsity), intent(in) :: sparsity - csr_row_val=matrix%val( matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1 ) + sparsity_entries=count(sparsity%colm/=0) - end function csr_row_val + end function sparsity_entries - pure function block_csr_row_val(matrix, blocki, blockj, i) - !!< Return the values of the ith row of (blocki,blockj) of matrix. - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: blocki, blockj, i - real, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i)) :: block_csr_row_val + pure function csr_entries(matrix) + !!< Return the number of (potentially) non-zero entries in matrix. + integer :: csr_entries + type(csr_matrix), intent(in) :: matrix - if(.not.matrix%diagonal.or.(blocki==blockj)) then - block_csr_row_val=matrix%val(blocki,blockj)%ptr( & - matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) - else - block_csr_row_val = 0.0 - end if + csr_entries=count(matrix%sparsity%colm/=0) - end function block_csr_row_val + end function csr_entries + + pure function dcsr_entries(matrix) + !!< Return the number of (potentially) non-zero entries in matrix. + integer :: dcsr_entries + type(dynamic_csr_matrix), intent(in) :: matrix + + integer i, c + + c=0 + do i=1, size(matrix,1) + c=c+size(matrix%colm(i)%ptr) + end do + dcsr_entries=c + + end function dcsr_entries + + pure function sparsity_row_m(sparsity, i) + !!< Return the m indices of the ith row of sparsity. + type(csr_sparsity), intent(in) :: sparsity + integer, intent(in) :: i + integer, dimension(sparsity%findrm(i+1)-sparsity%findrm(i)) :: sparsity_row_m + + sparsity_row_m=sparsity%colm(sparsity%findrm(i):sparsity%findrm(i+1)-1) + + end function sparsity_row_m + + pure function csr_row_m(matrix, i) + !!< Return the m indices of the ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity& + &%findrm(i)) :: csr_row_m + + csr_row_m=matrix%sparsity%colm& + (matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function csr_row_m + + pure function dcsr_row_m(matrix, i) + !!< Return the m indices of the ith row of matrix. + type(dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(size(matrix%colm(i)%ptr)) :: dcsr_row_m + + dcsr_row_m=matrix%colm(i)%ptr + + end function dcsr_row_m + + pure function block_csr_row_m(matrix, i) + !!< Return the m indices of the ith row of matrix. Since all rows in a + !!< blockmatrix are the same, we do not have to specify the block + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity& + &%findrm(i)) :: block_csr_row_m + + block_csr_row_m=matrix%sparsity%colm& + (matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function block_csr_row_m + + function sparsity_row_m_ptr(sparsity, i) + !!< Return a pointer to the m indices of the ith row of matrix. + type(csr_sparsity), intent(in) :: sparsity + integer, intent(in) :: i + integer, dimension(:), pointer :: sparsity_row_m_ptr + + sparsity_row_m_ptr=>sparsity%colm(sparsity%findrm(i):sparsity%findrm(i+1)-1) + + end function sparsity_row_m_ptr + + function csr_row_m_ptr(matrix, i) + !!< Return a pointer to the m indices of the ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(:), pointer :: csr_row_m_ptr + + csr_row_m_ptr=>matrix%sparsity%colm(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function csr_row_m_ptr + + function block_csr_row_m_ptr(matrix, i) + !!< Return a pointer to the m indicies of the ith row of matrix. Since all + !!< rows in a blockmatrix are the same, we do not have to specify the block + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(:), pointer :: block_csr_row_m_ptr + + block_csr_row_m_ptr=>matrix%sparsity%colm(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function block_csr_row_m_ptr + + function dcsr_row_m_ptr(matrix, i) + !!< Return a pointer to the m indices of the ith row of matrix. + !!< For dynamic sparse matrices this remains valid until + !!< the matrix is changed. After that call row_m_ptr again. + type(dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(:), pointer :: dcsr_row_m_ptr + + dcsr_row_m_ptr => matrix%colm(i)%ptr + + end function dcsr_row_m_ptr + + pure function csr_row_val(matrix, i) + !!< Return the values of the ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + real, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i)) :: csr_row_val + + csr_row_val=matrix%val( matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1 ) + + end function csr_row_val + + pure function block_csr_row_val(matrix, blocki, blockj, i) + !!< Return the values of the ith row of (blocki,blockj) of matrix. + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: blocki, blockj, i + real, dimension(matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i)) :: block_csr_row_val + + if(.not.matrix%diagonal.or.(blocki==blockj)) then + block_csr_row_val=matrix%val(blocki,blockj)%ptr( & + matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + else + block_csr_row_val = 0.0 + end if + + end function block_csr_row_val + + pure function block_csr_fullrow_val(matrix, blocki, i) + !!< Return the values of all ith rows of the blocki-th row of blocks + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: blocki, i + real, dimension((matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i))& + &*matrix%blocks(2)) :: block_csr_fullrow_val + + integer :: blockj, k, rowlen + + block_csr_fullrow_val = 0.0 + + rowlen=matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i) + + k=1 + do blockj=1, matrix%blocks(2) + if(.not.matrix%diagonal.or.(blocki==blockj)) then + block_csr_fullrow_val(k:k+rowlen-1)= & + matrix%val(blocki,blockj)%ptr(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1 ) + end if + k=k+rowlen + end do + + end function block_csr_fullrow_val + + function csr_row_val_ptr(matrix, i) + !!< Return a pointer to the values of the ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + real, dimension(:), pointer :: csr_row_val_ptr + + csr_row_val_ptr=>matrix%val(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function csr_row_val_ptr + + function dcsr_row_val_ptr(matrix, i) + !!< Return a pointer to the values of the ith row of matrix. + type(dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + real, dimension(:), pointer :: dcsr_row_val_ptr + + dcsr_row_val_ptr => matrix%val(i)%ptr + + end function dcsr_row_val_ptr + + function block_csr_row_val_ptr(matrix, blocki, blockj, i) + !!< Return a pointer to the values of the ith row of matrix. + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: blocki, blockj, i + real, dimension(:), pointer :: block_csr_row_val_ptr + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to retrieve values in an-off diagonal block of a diagonal block_csr_matrix!") + end if + + block_csr_row_val_ptr=> & + matrix%val(blocki, blockj)%ptr(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function block_csr_row_val_ptr + + function csr_row_ival_ptr(matrix, i) + !!< Return a pointer to the values of the ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer, dimension(:), pointer :: csr_row_ival_ptr + + csr_row_ival_ptr=>matrix%ival(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function csr_row_ival_ptr + + function block_csr_row_ival_ptr(matrix, blocki, blockj, i) + !!< Return a pointer to the values of the ith row of matrix. + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: blocki, blockj, i + integer, dimension(:), pointer :: block_csr_row_ival_ptr + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to retrieve values in an off-diagonal block of a diagonal block_csr_matrix!") + end if + + block_csr_row_ival_ptr=> & + matrix%ival(blocki, blockj)%ptr(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + + end function block_csr_row_ival_ptr + + function csr_diag_val_ptr(matrix, i) + !!< Return a pointer to the values of the diagonal of ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + real, pointer :: csr_diag_val_ptr + + csr_diag_val_ptr=>matrix%val(matrix%sparsity%centrm(i)) + + end function csr_diag_val_ptr + + pure function csr_row_length(matrix, i) + !!< Return the row length of the ith row of matrix. + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer :: csr_row_length + + csr_row_length=matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i) + + end function csr_row_length + + pure function csr_sparsity_row_length(sparsity, i) + !!< Return the row length of the ith row of matrix. + type(csr_sparsity), intent(in) :: sparsity + integer, intent(in) :: i + integer :: csr_sparsity_row_length + + csr_sparsity_row_length=sparsity%findrm(i+1)-sparsity%findrm(i) + end function csr_sparsity_row_length + + pure function dcsr_row_length(matrix, i) + !!< Return the row length of the ith row of matrix. + type(dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer :: dcsr_row_length + + dcsr_row_length=size(matrix%colm(i)%ptr) + + end function dcsr_row_length + + pure function block_csr_block_row_length(matrix, i) + !!< Return the row length of the ith row (within a block) of matrix. + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + integer :: block_csr_block_row_length + + block_csr_block_row_length=matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i) + + end function block_csr_block_row_length + + subroutine csr_initialise_inactive(matrix) + !!< Initialises the administration for registration of inactive rows. + !!< All rows start out as active (i.e. not inactive) + !!< May be called as many times as you like. + type(csr_matrix), intent(inout):: matrix + + if (.not. can_have_inactive(matrix)) then + ewrite(1,*) "Matrix: ", trim(matrix%name) + FLAbort("This matrix cannot have inactive rows set.") + end if + + if (.not. has_inactive(matrix)) then + allocate( matrix%inactive%ptr(1:size(matrix,1)) ) + matrix%inactive%ptr=.false. + end if + + end subroutine csr_initialise_inactive + + subroutine csr_reset_inactive(matrix) + !!< Makes all rows "active" again + type(csr_matrix), intent(inout):: matrix + + if(has_inactive(matrix)) then + deallocate( matrix%inactive%ptr ) + end if + + end subroutine csr_reset_inactive + + + subroutine csr_set_inactive_row(matrix, row) + !!< Registers a single row to be "inactive" this can be used for + !!< strong boundary conditions and reference nodes. + type(csr_matrix), intent(inout):: matrix + integer, intent(in):: row + character(len=255) :: buf + + call csr_initialise_inactive(matrix) + + if (row > size(matrix%inactive%ptr)) then + buf = "Error: attempting to set row " // int2str(row) // " to be inactive, but only " // & + & int2str(size(matrix%inactive%ptr)) // " rows. Check your reference pressure node?" + FLExit(trim(buf)) + end if + matrix%inactive%ptr(row)=.true. + + end subroutine csr_set_inactive_row + + subroutine csr_set_inactive_rows(matrix, rows) + !!< Registers a number of rows to be "inactive" this can be used for + !!< strong boundary conditions and reference nodes. + type(csr_matrix), intent(inout):: matrix + integer, dimension(:), intent(in):: rows + + call csr_initialise_inactive(matrix) + + matrix%inactive%ptr(rows)=.true. + + end subroutine csr_set_inactive_rows + + function csr_get_inactive_mask(matrix) + !!< Returns a pointer to a logical array that indicates inactive rows + !!< May return a null pointer, in which case no rows are inactive + logical, dimension(:), pointer:: csr_get_inactive_mask + type(csr_matrix), intent(in):: matrix + + if (associated(matrix%inactive)) then + csr_get_inactive_mask => matrix%inactive%ptr + else + nullify(csr_get_inactive_mask) + end if + + end function csr_get_inactive_mask + + pure function can_have_inactive(matrix) + type(csr_matrix), intent(in) :: matrix + + logical :: can_have_inactive + + can_have_inactive = associated(matrix%inactive) + + end function can_have_inactive + + pure function has_inactive(matrix) + type(csr_matrix), intent(in) :: matrix + + logical :: has_inactive + + if(can_have_inactive(matrix)) then + has_inactive = associated(matrix%inactive%ptr) + else + has_inactive = .false. + end if + + end function has_inactive + + function csr_has_solver_cache(matrix) + logical :: csr_has_solver_cache + type(csr_matrix), intent(in) :: matrix + + if (associated(matrix%ksp)) then + csr_has_solver_cache = matrix%ksp/=PETSC_NULL_KSP + else + ! this should only be possible for a csr_matrix returned from block() + csr_has_solver_cache = .false. + end if + + end function csr_has_solver_cache + + function block_csr_has_solver_cache(matrix) + logical :: block_csr_has_solver_cache + type(block_csr_matrix), intent(in) :: matrix + + if (associated(matrix%ksp)) then + block_csr_has_solver_cache = matrix%ksp/=PETSC_NULL_KSP + else + ! don't think this is possible, but hey + block_csr_has_solver_cache = .false. + end if + + end function block_csr_has_solver_cache + + subroutine csr_destroy_solver_cache(matrix) + type(csr_matrix), intent(inout) :: matrix + + integer:: ierr + + if (.not. associated(matrix%ksp)) return + + if (matrix%ksp/=PETSC_NULL_KSP) then + call KSPDestroy(matrix%ksp, ierr) + end if + matrix%ksp=PETSC_NULL_KSP + + end subroutine csr_destroy_solver_cache + + subroutine block_csr_destroy_solver_cache(matrix) + type(block_csr_matrix), intent(inout) :: matrix + + integer:: ierr + + if (.not. associated(matrix%ksp)) return + + if (matrix%ksp/=PETSC_NULL_KSP) then + call KSPDestroy(matrix%ksp, ierr) + end if + matrix%ksp=PETSC_NULL_KSP + + end subroutine block_csr_destroy_solver_cache + + subroutine csr_zero(matrix) + !!< Zero the entries of a csr matrix. + type(csr_matrix), intent(inout) :: matrix + + if (associated(matrix%val)) then + matrix%val=0.0 + end if + if (associated(matrix%ival)) then + matrix%ival=0 + end if + if (has_inactive(matrix)) then + deallocate(matrix%inactive%ptr) + nullify(matrix%inactive%ptr) + end if + + ! this invalidates the solver context + call destroy_solver_cache(matrix) + + end subroutine csr_zero + + subroutine block_csr_zero(matrix) + !!< Zero the entries of a csr matrix. + type(block_csr_matrix), intent(inout) :: matrix + + integer :: i,j + + if (associated(matrix%val)) then + if(matrix%equal_diagonal_blocks) then + matrix%val(1,1)%ptr=0.0 + else if(matrix%diagonal) then + do i=1,matrix%blocks(1) + matrix%val(i,i)%ptr=0.0 + end do + else + do i=1,matrix%blocks(1) + do j=1,matrix%blocks(2) + matrix%val(i,j)%ptr=0.0 + end do + end do + end if + end if + if (associated(matrix%ival)) then + if(matrix%equal_diagonal_blocks) then + matrix%ival(1,1)%ptr=0.0 + else if(matrix%diagonal) then + do i=1,matrix%blocks(1) + matrix%ival(i,i)%ptr=0.0 + end do + else + do i=1,matrix%blocks(1) + do j=1,matrix%blocks(2) + matrix%ival(i,j)%ptr=0.0 + end do + end do + end if + end if + + ! this invalidates the solver context + call destroy_solver_cache(matrix) + + end subroutine block_csr_zero + + subroutine dcsr_zero(matrix) + !!< Zero the entries of a dynamic csr matrix. + type(dynamic_csr_matrix), intent(inout) :: matrix + + integer :: i + + do i=1,size(matrix,1) + matrix%val(i)%ptr=0.0 + end do + + end subroutine dcsr_zero + + subroutine csr_zero_row(matrix, i) + !!< Zero the entries of a particular row of a csr matrix. + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + + real, dimension(:), pointer :: val + integer, dimension(:), pointer :: ival + + if (associated(matrix%val)) then + val => row_val_ptr(matrix, i) + val = 0.0 + end if + if (associated(matrix%ival)) then + ival => row_ival_ptr(matrix, i) + ival = 0.0 + end if + + end subroutine csr_zero_row + + subroutine block_csr_zero_single_row(matrix, blocki, i) + !!< Zero the entries of a particular row of a block csr matrix. + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki, i + integer :: k + + real, dimension(:), pointer :: val + integer, dimension(:), pointer :: ival + + if (associated(matrix%val)) then + do k=1,matrix%blocks(2) + if(matrix%diagonal.and.(blocki/=k)) cycle + val => row_val_ptr(matrix, blocki, k, i) + val = 0.0 + end do + end if + if (associated(matrix%ival)) then + do k=1,matrix%blocks(2) + if(matrix%diagonal.and.(blocki/=k)) cycle + ival => row_ival_ptr(matrix, blocki, k, i) + ival = 0 + end do + end if + + end subroutine block_csr_zero_single_row + + subroutine block_csr_zero_row(matrix, i) + !!< Zero the entries of a particular row in all blocks of a block csr matrix. + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + integer :: j, k + + real, dimension(:), pointer :: val + integer, dimension(:), pointer :: ival + + if (associated(matrix%val)) then + do j=1,matrix%blocks(1) + do k=1,matrix%blocks(2) + if(matrix%diagonal.and.(j/=k)) cycle + val => row_val_ptr(matrix, j, k, i) + val = 0.0 + end do + end do + end if + if (associated(matrix%ival)) then + do j=1,matrix%blocks(1) + do k=1,matrix%blocks(2) + if(matrix%diagonal.and.(j/=k)) cycle + ival => row_ival_ptr(matrix, j, k, i) + ival = 0.0 + end do + end do + end if + + end subroutine block_csr_zero_row + + subroutine dcsr_zero_column(matrix,column) + !!< Zero the entries of a dynamic csr matrix. + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: column + + integer, dimension(:), pointer :: row_ptr + integer :: i,j + + do i =1 ,size(matrix,1) + + row_ptr => matrix%colm(i)%ptr + + if(any(row_ptr==column)) then + do j=1,size(row_ptr) + if(row_ptr(j)==column) then + matrix%val(i)%ptr(j)=0.0 + end if + end do + end if + + end do + + end subroutine dcsr_zero_column + + function csr_sparsity_pos(sparsity, i, j, save_pos) + !!< Return the location in sparsity of element (i,j) + integer :: csr_sparsity_pos + type(csr_sparsity), intent(in) :: sparsity + integer, intent(in) :: i,j + ! an attempt at optimisation... + ! if save_pos is present, test to see if it's correct, if yes then return it + ! if no, then carry on as normal but save the position and return it as save_pos + integer, intent(inout), optional :: save_pos + + integer, dimension(:), pointer :: row + integer :: rowpos, base + integer :: lower_pos, lower_j + integer :: upper_pos, upper_j + integer :: this_pos, this_j + + if (present(save_pos)) then + if (save_pos>=sparsity%findrm(i) .and. save_pos row_m_ptr(sparsity,i) + + if (sparsity%sorted_rows) then + ! The j values in row are sorted in ascending order so we can do a + ! fast bisection search. + + ! Base is the last position in colm of the previous row. + base=sparsity%findrm(i)-1 + + upper_pos=size(row) + upper_j=row(upper_pos) + lower_pos=1 + lower_j=row(1) + + if (upper_jj) then + csr_sparsity_pos=0 + goto 42 + else if(lower_j==j) then + csr_sparsity_pos=lower_pos+base + goto 42 + end if + + bisection_loop: do while (upper_pos-lower_pos>1) + this_pos=(upper_pos+lower_pos)/2 + this_j=row(this_pos) + + if(this_j == j) then + csr_sparsity_pos=this_pos+base + goto 42 + else if(this_j > j) then + ! this_j>j + upper_j=this_j + upper_pos=this_pos + else + ! this_jj +! upper_j=this_j +! upper_pos=this_pos +! case(:-1) +! ! this_jmatrix%colm(i)%ptr + + if (.not.any(j==row)) then + ! i,j is not in matrix. + dcsr_pos_noadd=0 + return + end if + + rowpos=0 + rowpos=minloc(row, row==j) + + dcsr_pos_noadd=rowpos(1) + + end function dcsr_pos_noadd + + function dcsr_pos(matrix, i, j, add) + !!< Return the location in matrix of element (i,j) + integer :: dcsr_pos + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i,j + !! Flag which determines whether new entries are added. + logical, intent(in) :: add + + integer, dimension(:), pointer :: row + real, dimension(:), pointer :: val + integer, dimension(1) :: rowpos + + row=>matrix%colm(i)%ptr + val=>matrix%val(i)%ptr + + if (.not.any(j==row)) then + if (.not.add) then + ! i,j is not in matrix. + dcsr_pos=0 + return + end if + + rowpos=0 + if (size(row)>0) then + if (all(j>row)) then + rowpos(1)=size(row) + else + rowpos=minloc(row, mask=row>j)-1 + end if + end if + + ! Lengthen the row by one place + allocate(matrix%colm(i)%ptr(size(row)+1), & + & matrix% val(i)%ptr(size(row)+1)) + + ! Copy the old row in place + if (rowpos(1)>0) then + matrix%colm(i)%ptr(:rowpos(1))=row(:rowpos(1)) + matrix%val(i)%ptr(:rowpos(1))=val(:rowpos(1)) + end if + if (rowpos(1)matrix%colm(i)%ptr + val=>matrix%val(i)%ptr + + ! Insert the new location. + row(rowpos(1)+1)=j + val(rowpos(1)+1)=0.0 + end if + + rowpos=0 + rowpos=minloc(row, row==j) + + dcsr_pos=rowpos(1) + + end function dcsr_pos + + subroutine csr_addto(matrix, i, j, val, save_pos) + !!< Add val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i,j + real, intent(in) :: val + integer, intent(inout), optional :: save_pos + + integer :: mpos + + if (val==0) return ! No point doing nothing. + + mpos = pos(matrix,i,j,save_pos=save_pos) + + if (associated(matrix%val)) then + if(mpos==0) then + FLAbort("Attempting to set value in matrix outside sparsity pattern.") + end if + matrix%val(mpos)=matrix%val(mpos)+val + else if (associated(matrix%ival)) then + matrix%ival(mpos)=matrix%ival(mpos)+val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + + end subroutine csr_addto + + subroutine csr_iaddto(matrix, i, j, val, save_pos) + !!< Add val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i,j + integer, intent(in) :: val + integer, intent(inout), optional :: save_pos + + integer :: mpos + + mpos = pos(matrix,i,j,save_pos=save_pos) + + if (val==0) return ! No point doing nothing. + + if (associated(matrix%val)) then + matrix%val(mpos)=matrix%val(mpos)+val + else if (associated(matrix%ival)) then + matrix%ival(mpos)=matrix%ival(mpos)+val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + + end subroutine csr_iaddto + + subroutine csr_vaddto(matrix, i, j, val, mask) + !!< Add val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i,j + real, dimension(size(i),size(j)), intent(in) :: val + logical, dimension(size(i), size(j)), intent(in), optional :: mask + + integer :: iloc, jloc + logical, dimension(size(i), size(j)) :: l_mask + + if(present(mask)) then + l_mask = mask + else + l_mask = .true. + end if + + do iloc=1,size(i) + do jloc=1,size(j) + if(.not.l_mask(iloc,jloc)) cycle + call addto(matrix, i(iloc), j(jloc), val(iloc,jloc)) + end do + end do + + end subroutine csr_vaddto + + subroutine block_csr_addto(matrix, blocki, blockj, i, j, val, save_pos) + !!< Add val to matrix(i,j) + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj,i,j + real, intent(in) :: val + integer, intent(inout), optional :: save_pos + + integer :: mpos + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + mpos = pos(matrix, i, j, save_pos=save_pos) + + if (associated(matrix%val)) then + matrix%val(blocki, blockj)%ptr(mpos)& + =matrix%val(blocki, blockj)%ptr(mpos)+val + + else if (associated(matrix%ival)) then + matrix%ival(blocki, blockj)%ptr(mpos)& + =matrix%ival(blocki, blockj)%ptr(mpos)+val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + + end subroutine block_csr_addto + + subroutine block_csr_vaddto(matrix, blocki, blockj, i, j, val, mask) + !!< Add val to matrix(i,j) + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj + integer, dimension(:), intent(in) :: i,j + real, dimension(size(i),size(j)), intent(in) :: val + logical, dimension(size(i), size(j)), intent(in), optional :: mask + + integer :: iloc, jloc + logical, dimension(size(i), size(j)) :: l_mask + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + if(present(mask)) then + l_mask = mask + else + l_mask = .true. + end if + + do iloc=1,size(i) + do jloc=1,size(j) + if(.not.l_mask(iloc, jloc)) cycle + call addto(matrix, blocki,blockj, & + & i(iloc),j(jloc), val(iloc,jloc)) + end do + end do + + end subroutine block_csr_vaddto + + subroutine block_csr_blocks_addto(matrix, i, j, val, block_mask) + !!< Add the (blocki, blockj, :, :) th matrix of val onto the (blocki, blockj) th + !!< block of the block csr matrix, for all blocks of the block csr matrix. + + type(block_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i + integer, dimension(:), intent(in) :: j + real, dimension(matrix%blocks(1), matrix%blocks(2), size(i), size(j)), intent(in) :: val + logical, dimension(matrix%blocks(1), matrix%blocks(2)), intent(in), optional :: block_mask + + integer, dimension(size(i), size(j)) :: positions + logical, dimension(matrix%blocks(1), matrix%blocks(2)) :: l_block_mask + + integer :: blocki, blockj, iloc, jloc + + if(present(block_mask)) then + l_block_mask = block_mask + else + l_block_mask = .true. + end if + + ! this is optimised so that row searches are only done once + ! we do however want to want to keep the block loops on the outside + ! to improve data locality. + + do iloc = 1, size(positions, 1) + do jloc = 1, size(positions, 2) + if (all(val(:, :, iloc, jloc)==0.0)) cycle + positions(iloc,jloc)=pos(matrix%sparsity,i(iloc),j(jloc)) + end do + end do + + do blocki = 1, matrix%blocks(1) + do blockj = 1, matrix%blocks(2) + if(.not.l_block_mask(blocki, blockj)) cycle + do iloc = 1, size(positions, 1) + do jloc = 1, size(positions, 2) + ! Don't add zeros into the matrix, especially as these may be + ! at invalid locations. + if(val(blocki, blockj, iloc, jloc)==0) cycle + matrix%val(blocki, blockj)%ptr(positions(iloc,jloc))= & + matrix%val(blocki, blockj)%ptr(positions(iloc,jloc)) + & + val(blocki, blockj, iloc, jloc) + end do + end do + end do + end do + + end subroutine block_csr_blocks_addto + + subroutine block_csr_baddto(matrix, blocki, blockj, mblock, scalar) + !!< Add csr_matrix to a block_csr_matrix, where the csr_matrix has the same + !!< sparsity (or a subset of it) as the blocks of the block_csr_matrix + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj + type(csr_matrix), intent(in):: mblock + !! if present add scalar*mblock: + real, optional, intent(in):: scalar + + real, pointer:: blockijval(:), val_ptr(:) + integer, pointer:: col_ptr(:) + real lscalar + integer row, col + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + if (mblock%clone .or. matrix%clone) then + ! if one of matrix and mblock is a clone of the other, or both are clones + ! of the same original, we only have to copy the values: + if (associated(matrix%sparsity%findrm, mblock%sparsity%findrm) .and. & + associated(matrix%sparsity%colm, mblock%sparsity%colm)) then + + blockijval => matrix%val(blocki, blockj)%ptr + if (present(scalar)) then + blockijval=blockijval+mblock%val*scalar + else + blockijval=blockijval+mblock%val + end if + return + end if + end if + + ! the safe way: all entries are add in one by one... + if (present(scalar)) then + lscalar=scalar + else + lscalar=1.0 + end if + + do row=1, size(mblock,1) + col_ptr => row_m_ptr(mblock, row) + val_ptr => row_val_ptr(mblock, row) + do col=1, size(col_ptr) + call addto(matrix, blocki, blockj, row, col_ptr(col), & + val_ptr(col)*lscalar) + end do + end do + + end subroutine block_csr_baddto + + subroutine block_csr_bset(matrix, blocki, blockj, mblock) + !!< Assign csr_matrix to a block_csr_matrix, where the csr_matrix has the same + !!< sparsity + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj + type(csr_matrix), intent(in):: mblock + + real, pointer:: blockijval(:), val_ptr(:) + integer, pointer:: col_ptr(:) + integer row, col + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + if (associated(matrix%sparsity%findrm, mblock%sparsity%findrm) .and. & + associated(matrix%sparsity%colm, mblock%sparsity%colm)) then + + blockijval => matrix%val(blocki, blockj)%ptr + blockijval=mblock%val + return + else + do row=1, size(mblock,1) + col_ptr => row_m_ptr(mblock, row) + val_ptr => row_val_ptr(mblock, row) + do col=1, size(col_ptr) + call set(matrix, blocki, blockj, row, col_ptr(col), & + val_ptr(col)) + end do + end do + end if + end subroutine block_csr_bset + + subroutine csr_scale(matrix, scale) + !!< Scale matrix by scale. + type(csr_matrix), intent(inout) :: matrix + real, intent(in) :: scale + + matrix%val=matrix%val*scale + + end subroutine csr_scale + + subroutine block_csr_scale(matrix, scale) + !!< Scale matrix by scale. + type(block_csr_matrix), intent(inout) :: matrix + real, intent(in) :: scale + ! + integer :: d1,d2 + + do d1 = 1, matrix%blocks(1) + do d2 = 1, matrix%blocks(2) + matrix%val(d1,d2)%ptr=matrix%val(d1,d2)%ptr*scale + end do + end do + + end subroutine block_csr_scale + + subroutine block_csr_bvaddto(matrixA, blocki, blockj, matrixB, scalar) + !!< Add all blocks of a block_csr_matrix to another block_csr_matrix, + !!< where the same sparsity pattern but possibly more blocks + type(block_csr_matrix), intent(inout) :: matrixA + type(block_csr_matrix), intent(in):: matrixB + ! The compiler on AIX has some unreasonable obkection to the blocks + ! function. +!!$ integer, dimension(blocks(matrixB,1)), intent(in) :: blocki +!!$ integer, dimension(blocks(matrixB,2)), intent(in) :: blockj + integer, dimension(matrixB%blocks(1)), intent(in) :: blocki + integer, dimension(matrixB%blocks(2)), intent(in) :: blockj + !! if present add scalar*matrixB: + real, optional, intent(in):: scalar + + type(csr_matrix) blockij + integer :: i, j + + do i=1, size(blocki) + do j=1, size(blockj) + if(matrixB%diagonal.and.(i/=j)) then + FLAbort("Attempting to retrive an off-diagonal block of a diagonal block_csr_matrix.") + end if + if(matrixA%diagonal.and.(blocki(i)/=blockj(j))) then + FLAbort("Attempting to set values in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + blockij=block(matrixB, i, j) + call addto(matrixA, blocki(i), blockj(j), blockij, scalar=scalar) + end do + end do + + end subroutine block_csr_bvaddto + + subroutine dcsr_addto(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i, j + real, intent(in) :: val + + integer :: rowpos + + ! Because pos has side effects, it is a very good idea to call it + ! before the assemble. + rowpos=pos(matrix, i, j, add=.true.) + + matrix%val(i)%ptr(rowpos)=matrix%val(i)%ptr(rowpos)+val + + end subroutine dcsr_addto + + subroutine dcsr_dcsraddto(matrix1,matrix2) + !!< Add matrix2 to matrix1 + !!< could probably do with optimizing + type(dynamic_csr_matrix), intent(inout) :: matrix1 + type(dynamic_csr_matrix), intent(in) :: matrix2 + + !locals + integer :: i,j + + assert(size(matrix1,1)==size(matrix2,1)) + assert(size(matrix1,2)==size(matrix2,2)) + + do i = 1,size(matrix2%colm) + do j = 1,size(matrix2%colm(i)%ptr) + call addto(matrix1,i,matrix2%colm(i)%ptr(j),matrix2%val(i)%ptr(j)) + end do + end do + + end subroutine dcsr_dcsraddto + + subroutine csr_csraddto(matrix1,matrix2, scale) + !!< Add matrix2 to matrix1: sparsity must be the same though + type(csr_matrix), intent(inout) :: matrix1 + type(csr_matrix), intent(in) :: matrix2 + real, optional, intent(in) :: scale + + !locals + integer :: i,j + real :: l_scale + + assert(size(matrix1,1)==size(matrix2,1)) + assert(size(matrix1,2)==size(matrix2,2)) + + if(present(scale)) then + l_scale=scale + else + l_scale=1.0 + end if + + do i = 1,size(matrix2%sparsity%findrm)-1 + do j = matrix2%sparsity%findrm(i),matrix2%sparsity%findrm(i+1)-1 + call addto(matrix1,i,matrix2%sparsity%colm(j),l_scale*matrix2%val(j)) + end do + end do + + end subroutine csr_csraddto + + subroutine dcsr_vaddto(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i, j + real, dimension(size(i),size(j)), intent(in) :: val + + integer :: iloc, jloc + + do iloc=1,size(i) + do jloc=1,size(j) + call addto(matrix, i(iloc), j(jloc), val(iloc,jloc)) + end do + end do + + end subroutine dcsr_vaddto + + subroutine dcsr_vaddto1(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + integer, dimension(:), intent(in) :: j + real, dimension(size(j)), intent(in) :: val + + integer :: jloc + + do jloc=1,size(j) + call addto(matrix, i, j(jloc), val(jloc)) + end do + + end subroutine dcsr_vaddto1 + + subroutine dcsr_vaddto2(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i + integer, intent(in) :: j + real, dimension(size(i)), intent(in) :: val + + integer :: iloc + + do iloc=1,size(i) + call addto(matrix, i(iloc), j, val(iloc)) + end do + + end subroutine dcsr_vaddto2 + + subroutine dcsr_set(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i, j + real, intent(in) :: val + + integer :: rowpos + + ! Because pos has side effects, it is a very good idea to call it + ! before the assemble. + rowpos=pos(matrix, i, j, add=.true.) + + matrix%val(i)%ptr(rowpos)=val + + end subroutine dcsr_set + + subroutine dcsr_vset(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i, j + real, dimension(size(i),size(j)), intent(in) :: val + + integer :: iloc, jloc + + do iloc=1,size(i) + do jloc=1,size(j) + call set(matrix, i(iloc), j(jloc), val(iloc,jloc)) + end do + end do + + end subroutine dcsr_vset + + subroutine dcsr_set_row(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + integer, dimension(:), intent(in) :: j + real, dimension(size(j)), intent(in) :: val + + integer :: jloc + + do jloc=1,size(j) + call set(matrix, i, j(jloc), val(jloc)) + end do + + end subroutine dcsr_set_row + + subroutine dcsr_set_col(matrix, i, j, val) + !!< Add val to matrix(i,j) + type(dynamic_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i + integer, intent(in) :: j + real, dimension(size(i)), intent(in) :: val + + integer :: iloc + + do iloc=1,size(i) + call set(matrix, i(iloc), j, val(iloc)) + end do + + end subroutine dcsr_set_col + + subroutine csr_addto_diag(matrix, i, val, scale, save_pos) + !!< Add val to matrix(i,i) + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + real, intent(in) :: val + real, intent(in), optional ::scale + integer, intent(inout), optional :: save_pos + + integer :: mpos + + if(associated(matrix%sparsity%centrm)) then + mpos = matrix%sparsity%centrm(i) + else + mpos = pos(matrix,i,i,save_pos=save_pos) + end if + + if (associated(matrix%val)) then + if(present(scale)) then + matrix%val(mpos)=matrix%val(mpos)+val*scale + else + matrix%val(mpos)=matrix%val(mpos)+val + end if + else if (associated(matrix%ival)) then + if(present(scale)) then + matrix%ival(mpos)=matrix%ival(mpos)+val*scale + else + matrix%ival(mpos)=matrix%ival(mpos)+val + end if + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + + end subroutine csr_addto_diag + + subroutine csr_vaddto_diag(matrix, i, val, scale) + !!< Add val to matrix(i,i) + type(csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i + real, dimension(size(i)), intent(in) :: val + real, intent(in), optional :: scale + + integer :: iloc + + do iloc=1,size(i) + call addto_diag(matrix, i(iloc), val(iloc), scale=scale) + end do + + end subroutine csr_vaddto_diag + + subroutine block_csr_addto_diag(matrix, blocki, blockj, i, val, scale, save_pos) + !!< Add val to matrix(i,i) + !!< Adding to the diagonal of a non-diagonal block is supported. + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj, i + real, intent(in) :: val + real, intent(in), optional :: scale + integer, intent(inout), optional :: save_pos + + integer :: mpos + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + if(associated(matrix%sparsity%centrm)) then + mpos = matrix%sparsity%centrm(i) + else + mpos = pos(matrix,i,i,save_pos=save_pos) + end if + + if (associated(matrix%val)) then + if(present(scale)) then + matrix%val(blocki,blockj)%ptr(mpos)& + =matrix%val(blocki, blockj)%ptr(mpos)+val*scale + else + matrix%val(blocki,blockj)%ptr(mpos)& + =matrix%val(blocki, blockj)%ptr(mpos)+val + end if + else if (associated(matrix%ival)) then + if(present(scale)) then + matrix%ival(blocki, blockj)%ptr(mpos)& + =matrix%ival(blocki, blockj)%ptr(mpos)+val*scale + else + matrix%ival(blocki, blockj)%ptr(mpos)& + =matrix%ival(blocki, blockj)%ptr(mpos)+val + end if + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + + end subroutine block_csr_addto_diag + + subroutine block_csr_vaddto_diag(matrix, blocki, blockj, i, val, scale) + !!< Add val to matrix(i,i) + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki, blockj + integer, dimension(:), intent(in) :: i + real, dimension(size(i)), intent(in) :: val + real, intent(in), optional :: scale + + integer :: iloc + + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if + + do iloc=1,size(i) + call addto_diag(matrix, blocki, blockj, i(iloc), val(iloc), scale=scale) + end do + + end subroutine block_csr_vaddto_diag + + subroutine csr_set(matrix, i, j, val, save_pos) + !!< Add val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i,j + real, intent(in) :: val + integer, intent(inout), optional :: save_pos + + integer :: mpos + + mpos = pos(matrix,i,j,save_pos=save_pos) + !In debugging mode, check that the entry actually exists. + assert(mpos>0) + + if (associated(matrix%val)) then + matrix%val(mpos)=val + else if (associated(matrix%ival)) then + matrix%ival(mpos)=val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + + end subroutine csr_set + + subroutine csr_csr_set(out_matrix, in_matrix) + !!< Set out_matrix to in_matrix. This will only work if the matrices have + !!< the same sparsity. + type(csr_matrix), intent(inout) :: out_matrix + type(csr_matrix), intent(in) :: in_matrix + + ! + integer :: row, i + integer, dimension(:), pointer:: cols + real, dimension(:), pointer :: vals +#ifdef DDEBUG + logical :: matrix_same_shape +#endif - pure function block_csr_fullrow_val(matrix, blocki, i) - !!< Return the values of all ith rows of the blocki-th row of blocks - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: blocki, i - real, dimension((matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i))& - &*matrix%blocks(2)) :: block_csr_fullrow_val + if(in_matrix%sparsity%refcount%id==out_matrix%sparsity%refcount%id) then + !Code for the same sparsity + if (associated(out_matrix%ival)) then + assert(associated(in_matrix%ival)) + else + assert((associated(out_matrix%val).and.associated(in_matrix%val))) + end if - integer :: blockj, k, rowlen + if(associated(out_matrix%val)) then + out_matrix%val=in_matrix%val + else if (associated(out_matrix%ival)) then + out_matrix%ival=in_matrix%ival + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + else + ewrite(-1,*) 'Warning, not same sparsity' + !Code for different sparsity, we assume that in_matrix%sparsity + !is contained in out_matrix%sparsity +#ifdef DDEBUG + matrix_same_shape=size(out_matrix,1)==size(in_matrix,1) + assert(matrix_same_shape) + matrix_same_shape=size(out_matrix,2)==size(in_matrix,2) + assert(matrix_same_shape) +#endif - block_csr_fullrow_val = 0.0 + if (associated(out_matrix%ival)) then + assert(associated(in_matrix%ival)) + else + assert((associated(out_matrix%val).and.associated(in_matrix%val))) + end if - rowlen=matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i) + call zero(out_matrix) - k=1 - do blockj=1, matrix%blocks(2) - if(.not.matrix%diagonal.or.(blocki==blockj)) then - block_csr_fullrow_val(k:k+rowlen-1)= & - matrix%val(blocki,blockj)%ptr(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1 ) + do row = 1, size(out_matrix,1) + cols => row_m_ptr(in_matrix, row) + vals => row_val_ptr(in_matrix, row) + do i = 1, size(cols) + call set(out_matrix,row,cols(i),vals(i)) + end do + end do end if - k=k+rowlen - end do + end subroutine csr_csr_set + + subroutine csr_block_csr_set(out_matrix, in_matrix, blocki, blockj) + !!< Set out_matrix to (blocki, blockj) of in_matrix. This will + !!< only work if the matrices have the same sparsity. + type(csr_matrix), intent(inout) :: out_matrix + type(block_csr_matrix), intent(in) :: in_matrix + integer, intent(in) :: blocki, blockj + + ! + integer :: row, i + integer, dimension(:), pointer:: cols + real, dimension(:), pointer :: vals +#ifdef DDEBUG + logical :: matrix_same_shape +#endif - end function block_csr_fullrow_val + if(in_matrix%sparsity%refcount%id==out_matrix%sparsity%refcount%id) then + !Code for the same sparsity + if (associated(out_matrix%ival)) then + assert(associated(in_matrix%ival)) + else + assert((associated(out_matrix%val).and.associated(in_matrix%val))) + end if - function csr_row_val_ptr(matrix, i) - !!< Return a pointer to the values of the ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - real, dimension(:), pointer :: csr_row_val_ptr + if(associated(out_matrix%val)) then + assert(associated(in_matrix%val(blocki,blockj)%ptr)) + out_matrix%val=in_matrix%val(blocki,blockj)%ptr + else if (associated(out_matrix%ival)) then + assert(associated(in_matrix%ival(blocki,blockj)%ptr)) + out_matrix%ival=in_matrix%ival(blocki,blockj)%ptr + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if + else + ewrite(-1,*) 'Warning, not same sparsity' + !Code for different sparsity, we assume that in_matrix%sparsity + !is contained in out_matrix%sparsity +#ifdef DDEBUG + matrix_same_shape=size(out_matrix,1)==size(in_matrix,1) + assert(matrix_same_shape) + matrix_same_shape=size(out_matrix,2)==size(in_matrix,2) + assert(matrix_same_shape) +#endif - csr_row_val_ptr=>matrix%val(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + if (associated(out_matrix%ival)) then + assert(associated(in_matrix%ival)) + else + assert((associated(out_matrix%val).and.associated(in_matrix%val))) + end if - end function csr_row_val_ptr + call zero(out_matrix) - function dcsr_row_val_ptr(matrix, i) - !!< Return a pointer to the values of the ith row of matrix. - type(dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - real, dimension(:), pointer :: dcsr_row_val_ptr + do row = 1, size(out_matrix,1) + cols => row_m_ptr(in_matrix, row) + vals => row_val_ptr(in_matrix, blocki, blockj, row) + do i = 1, size(cols) + call set(out_matrix,row,cols(i),vals(i)) + end do + end do + end if - dcsr_row_val_ptr => matrix%val(i)%ptr + end subroutine csr_block_csr_set - end function dcsr_row_val_ptr + subroutine csr_vset(matrix, i, j, val) + !!< Set val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i, j + real, dimension(size(i),size(j)), intent(in) :: val - function block_csr_row_val_ptr(matrix, blocki, blockj, i) - !!< Return a pointer to the values of the ith row of matrix. - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: blocki, blockj, i - real, dimension(:), pointer :: block_csr_row_val_ptr + integer :: iloc, jloc - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to retrieve values in an-off diagonal block of a diagonal block_csr_matrix!") - end if + do iloc=1,size(i) + do jloc=1,size(j) + call set(matrix, i(iloc), j(jloc), val(iloc,jloc)) + end do + end do - block_csr_row_val_ptr=> & - matrix%val(blocki, blockj)%ptr(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + end subroutine csr_vset - end function block_csr_row_val_ptr + subroutine csr_rset(matrix, i, j, val) + !!< Set val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: j + integer, intent(in) :: i + real, dimension(size(j)), intent(in) :: val - function csr_row_ival_ptr(matrix, i) - !!< Return a pointer to the values of the ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer, dimension(:), pointer :: csr_row_ival_ptr + integer :: jloc - csr_row_ival_ptr=>matrix%ival(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + do jloc=1,size(j) + call set(matrix, i, j(jloc), val(jloc)) + end do - end function csr_row_ival_ptr + end subroutine csr_rset - function block_csr_row_ival_ptr(matrix, blocki, blockj, i) - !!< Return a pointer to the values of the ith row of matrix. - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: blocki, blockj, i - integer, dimension(:), pointer :: block_csr_row_ival_ptr + subroutine csr_iset(matrix, i, j, val, save_pos) + !!< Add val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i,j + integer, intent(in) :: val + integer, intent(inout), optional :: save_pos - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to retrieve values in an off-diagonal block of a diagonal block_csr_matrix!") - end if + integer :: mpos - block_csr_row_ival_ptr=> & - matrix%ival(blocki, blockj)%ptr(matrix%sparsity%findrm(i):matrix%sparsity%findrm(i+1)-1) + mpos = pos(matrix,i,j,save_pos=save_pos) + !In debugging mode, check that the entry actually exists. + assert(mpos>0) - end function block_csr_row_ival_ptr + if (associated(matrix%val)) then + matrix%val(mpos)=val + else if (associated(matrix%ival)) then + matrix%ival(mpos)=val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if - function csr_diag_val_ptr(matrix, i) - !!< Return a pointer to the values of the diagonal of ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - real, pointer :: csr_diag_val_ptr + end subroutine csr_iset - csr_diag_val_ptr=>matrix%val(matrix%sparsity%centrm(i)) + subroutine block_csr_vset(matrix, blocki, blockj, i, j, val) + !!< Add val to matrix(i,j) + type(block_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i, j + integer, intent(in) :: blocki, blockj + real, dimension(size(i),size(j)), intent(in) :: val - end function csr_diag_val_ptr + integer :: iloc, jloc - pure function csr_row_length(matrix, i) - !!< Return the row length of the ith row of matrix. - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer :: csr_row_length + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if - csr_row_length=matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i) + do iloc=1,size(i) + do jloc=1,size(j) + call block_csr_set(matrix, blocki, blockj, i(iloc), j(jloc), val(iloc,jloc)) + end do + end do - end function csr_row_length + end subroutine block_csr_vset - pure function csr_sparsity_row_length(sparsity, i) - !!< Return the row length of the ith row of matrix. - type(csr_sparsity), intent(in) :: sparsity - integer, intent(in) :: i - integer :: csr_sparsity_row_length + subroutine block_csr_set(matrix, blocki, blockj, i, j, val, save_pos) + !!< Add val to matrix(i,j) + type(block_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj,i,j + real, intent(in) :: val + integer, intent(inout), optional :: save_pos - csr_sparsity_row_length=sparsity%findrm(i+1)-sparsity%findrm(i) - end function csr_sparsity_row_length + integer :: mpos - pure function dcsr_row_length(matrix, i) - !!< Return the row length of the ith row of matrix. - type(dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer :: dcsr_row_length + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") + end if - dcsr_row_length=size(matrix%colm(i)%ptr) + mpos = pos(matrix,i,j,save_pos=save_pos) - end function dcsr_row_length + !In debugging mode, check that the entry actually exists. + assert(mpos>0) +! assert(blocki<=matrix%blocks(1).and.blockj<=matrix%blocks(j)) - pure function block_csr_block_row_length(matrix, i) - !!< Return the row length of the ith row (within a block) of matrix. - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - integer :: block_csr_block_row_length + if (associated(matrix%val)) then + matrix%val(blocki,blockj)%ptr(mpos)=val + else if (associated(matrix%ival)) then + matrix%ival(blocki,blockj)%ptr(mpos)=val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if - block_csr_block_row_length=matrix%sparsity%findrm(i+1)-matrix%sparsity%findrm(i) + end subroutine block_csr_set - end function block_csr_block_row_length + subroutine csr_set_diag(matrix, i, val, save_pos) + !!< Set val to matrix(i,j) + type(csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + real, intent(in) :: val + integer, intent(inout), optional :: save_pos - subroutine csr_initialise_inactive(matrix) - !!< Initialises the administration for registration of inactive rows. - !!< All rows start out as active (i.e. not inactive) - !!< May be called as many times as you like. - type(csr_matrix), intent(inout):: matrix + integer :: mpos - if (.not. can_have_inactive(matrix)) then - ewrite(1,*) "Matrix: ", trim(matrix%name) - FLAbort("This matrix cannot have inactive rows set.") - end if + if(associated(matrix%sparsity%centrm)) then + mpos = matrix%sparsity%centrm(i) + else + mpos = pos(matrix,i,i,save_pos=save_pos) + end if - if (.not. has_inactive(matrix)) then - allocate( matrix%inactive%ptr(1:size(matrix,1)) ) - matrix%inactive%ptr=.false. - end if + !In debugging mode, check that the entry actually exists. + assert(mpos>0) - end subroutine csr_initialise_inactive + if (associated(matrix%val)) then + matrix%val(mpos)=val + else if (associated(matrix%ival)) then + matrix%ival(mpos)=val + else + FLAbort("Attempting to set value in a matrix with no value space.") + end if - subroutine csr_reset_inactive(matrix) - !!< Makes all rows "active" again - type(csr_matrix), intent(inout):: matrix + end subroutine csr_set_diag - if(has_inactive(matrix)) then - deallocate( matrix%inactive%ptr ) - end if + function csr_val(matrix, i, j, save_pos) result(val) + !!< Return the value at matrix(i,j) + real :: val + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i,j + integer, intent(inout), optional :: save_pos - end subroutine csr_reset_inactive + integer :: mpos + mpos=pos(matrix,i,j,save_pos=save_pos) - subroutine csr_set_inactive_row(matrix, row) - !!< Registers a single row to be "inactive" this can be used for - !!< strong boundary conditions and reference nodes. - type(csr_matrix), intent(inout):: matrix - integer, intent(in):: row - character(len=255) :: buf + if (associated(matrix%val)) then + if (mpos/=0) then + val=matrix%val(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if + else if (associated(matrix%ival)) then + if (mpos/=0) then + val=matrix%ival(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if - call csr_initialise_inactive(matrix) + else + FLAbort("Attempting to extract value in a matrix with no value space.") + end if - if (row > size(matrix%inactive%ptr)) then - buf = "Error: attempting to set row " // int2str(row) // " to be inactive, but only " // & - & int2str(size(matrix%inactive%ptr)) // " rows. Check your reference pressure node?" - FLExit(trim(buf)) - end if - matrix%inactive%ptr(row)=.true. + end function csr_val - end subroutine csr_set_inactive_row + function csr_ival(matrix, i, j, save_pos) result(val) + !!< Return the value at matrix(i,j) + integer :: val + type(csr_matrix), intent(in) :: matrix + integer, intent(in) :: i,j + integer, intent(inout), optional :: save_pos - subroutine csr_set_inactive_rows(matrix, rows) - !!< Registers a number of rows to be "inactive" this can be used for - !!< strong boundary conditions and reference nodes. - type(csr_matrix), intent(inout):: matrix - integer, dimension(:), intent(in):: rows + integer :: mpos - call csr_initialise_inactive(matrix) + mpos=pos(matrix,i,j,save_pos=save_pos) - matrix%inactive%ptr(rows)=.true. + if (associated(matrix%val)) then + if (mpos/=0) then + val=matrix%val(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if - end subroutine csr_set_inactive_rows + else if (associated(matrix%ival)) then + if (mpos/=0) then + val=matrix%ival(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if - function csr_get_inactive_mask(matrix) - !!< Returns a pointer to a logical array that indicates inactive rows - !!< May return a null pointer, in which case no rows are inactive - logical, dimension(:), pointer:: csr_get_inactive_mask - type(csr_matrix), intent(in):: matrix + else + FLAbort("Attempting to extract value in a matrix with no value space.") + end if - if (associated(matrix%inactive)) then - csr_get_inactive_mask => matrix%inactive%ptr - else - nullify(csr_get_inactive_mask) - end if + end function csr_ival - end function csr_get_inactive_mask + function block_csr_val(matrix, blocki, blockj, i, j, save_pos) result(val) + !!< Return the value at matrix(i,j) + real :: val + type(block_csr_matrix), intent(in) :: matrix + integer, intent(in) :: blocki, blockj, i,j + integer, intent(inout), optional :: save_pos - pure function can_have_inactive(matrix) - type(csr_matrix), intent(in) :: matrix + integer :: mpos - logical :: can_have_inactive + if(matrix%diagonal.and.(blocki/=blockj)) then + FLAbort("Attempting to retrieve value in an off-diagonal block of a diagonal block_csr_matrix.") + end if - can_have_inactive = associated(matrix%inactive) + mpos=pos(matrix,i,j,save_pos=save_pos) - end function can_have_inactive + if (associated(matrix%val)) then + if (mpos/=0) then + val=matrix%val(blocki,blockj)%ptr(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if + else if (associated(matrix%ival)) then + if (mpos/=0) then + val=matrix%ival(blocki,blockj)%ptr(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if - pure function has_inactive(matrix) - type(csr_matrix), intent(in) :: matrix + else + FLAbort("Attempting to extract value in a matrix with no value space.") + end if - logical :: has_inactive + end function block_csr_val - if(can_have_inactive(matrix)) then - has_inactive = associated(matrix%inactive%ptr) - else - has_inactive = .false. - end if + function dcsr_val(matrix, i, j) result (val) + !!< Return the value at matrix(i,j) + real :: val + type(dynamic_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i,j - end function has_inactive + integer :: mpos - function csr_has_solver_cache(matrix) - logical :: csr_has_solver_cache - type(csr_matrix), intent(in) :: matrix + mpos=pos(matrix,i,j) - if (associated(matrix%ksp)) then - csr_has_solver_cache = matrix%ksp/=PETSC_NULL_KSP - else - ! this should only be possible for a csr_matrix returned from block() - csr_has_solver_cache = .false. - end if + if (mpos/=0) then + val=matrix%val(i)%ptr(mpos) + else + ! i,j not in nonzero part of matrix. + val=0 + end if - end function csr_has_solver_cache + end function dcsr_val - function block_csr_has_solver_cache(matrix) - logical :: block_csr_has_solver_cache - type(block_csr_matrix), intent(in) :: matrix + function csr_dense_i(matrix) + !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! + type(csr_matrix), intent(in) :: matrix + integer, dimension(size(matrix,1), size(matrix,2)) :: csr_dense_i - if (associated(matrix%ksp)) then - block_csr_has_solver_cache = matrix%ksp/=PETSC_NULL_KSP - else - ! don't think this is possible, but hey - block_csr_has_solver_cache = .false. - end if + integer :: i - end function block_csr_has_solver_cache + csr_dense_i=0 - subroutine csr_destroy_solver_cache(matrix) - type(csr_matrix), intent(inout) :: matrix + do i=1,size(matrix,1) + csr_dense_i(i,row_m_ptr(matrix,i))=csr_row_ival_ptr(matrix,i) + end do - integer:: ierr + end function csr_dense_i - if (.not. associated(matrix%ksp)) return + function csr_dense(matrix) result(dense) + !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! + type(csr_matrix), intent(in) :: matrix + real, dimension(size(matrix,1), size(matrix,2)) :: dense - if (matrix%ksp/=PETSC_NULL_KSP) then - call KSPDestroy(matrix%ksp, ierr) - end if - matrix%ksp=PETSC_NULL_KSP + integer :: i - end subroutine csr_destroy_solver_cache + dense=0.0 - subroutine block_csr_destroy_solver_cache(matrix) - type(block_csr_matrix), intent(inout) :: matrix + do i=1,size(matrix,1) + dense(i,row_m_ptr(matrix,i))=row_val_ptr(matrix,i) + end do - integer:: ierr + end function csr_dense - if (.not. associated(matrix%ksp)) return + function block_csr_dense(matrix) result(dense) + !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! + type(block_csr_matrix), intent(in) :: matrix + real, dimension(size(matrix,1), size(matrix,2)) :: dense - if (matrix%ksp/=PETSC_NULL_KSP) then - call KSPDestroy(matrix%ksp, ierr) - end if - matrix%ksp=PETSC_NULL_KSP + integer :: i, blocki, blockj, blockstarti, blockstartj - end subroutine block_csr_destroy_solver_cache + dense=0.0 - subroutine csr_zero(matrix) - !!< Zero the entries of a csr matrix. - type(csr_matrix), intent(inout) :: matrix + do blocki=1,matrix%blocks(1) - if (associated(matrix%val)) then - matrix%val=0.0 - end if - if (associated(matrix%ival)) then - matrix%ival=0 - end if - if (has_inactive(matrix)) then - deallocate(matrix%inactive%ptr) - nullify(matrix%inactive%ptr) - end if + blockstarti=(blocki-1)*block_size(matrix,1) - ! this invalidates the solver context - call destroy_solver_cache(matrix) + do blockj=1,matrix%blocks(2) - end subroutine csr_zero + if(matrix%diagonal.and.(blocki/=blockj)) cycle - subroutine block_csr_zero(matrix) - !!< Zero the entries of a csr matrix. - type(block_csr_matrix), intent(inout) :: matrix + blockstartj=(blockj-1)*block_size(matrix,2) - integer :: i,j + do i=1,block_size(matrix,1) - if (associated(matrix%val)) then - if(matrix%equal_diagonal_blocks) then - matrix%val(1,1)%ptr=0.0 - else if(matrix%diagonal) then - do i=1,matrix%blocks(1) - matrix%val(i,i)%ptr=0.0 - end do - else - do i=1,matrix%blocks(1) - do j=1,matrix%blocks(2) - matrix%val(i,j)%ptr=0.0 - end do - end do - end if - end if - if (associated(matrix%ival)) then - if(matrix%equal_diagonal_blocks) then - matrix%ival(1,1)%ptr=0.0 - else if(matrix%diagonal) then - do i=1,matrix%blocks(1) - matrix%ival(i,i)%ptr=0.0 - end do - else - do i=1,matrix%blocks(1) - do j=1,matrix%blocks(2) - matrix%ival(i,j)%ptr=0.0 + dense(blockstarti+i,blockstartj+row_m_ptr(matrix,i))& + =row_val_ptr(matrix,blocki, blockj, i) end do - end do - end if - end if - - ! this invalidates the solver context - call destroy_solver_cache(matrix) - - end subroutine block_csr_zero - - subroutine dcsr_zero(matrix) - !!< Zero the entries of a dynamic csr matrix. - type(dynamic_csr_matrix), intent(inout) :: matrix - - integer :: i - - do i=1,size(matrix,1) - matrix%val(i)%ptr=0.0 - end do - - end subroutine dcsr_zero - - subroutine csr_zero_row(matrix, i) - !!< Zero the entries of a particular row of a csr matrix. - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - - real, dimension(:), pointer :: val - integer, dimension(:), pointer :: ival - - if (associated(matrix%val)) then - val => row_val_ptr(matrix, i) - val = 0.0 - end if - if (associated(matrix%ival)) then - ival => row_ival_ptr(matrix, i) - ival = 0.0 - end if - - end subroutine csr_zero_row - - subroutine block_csr_zero_single_row(matrix, blocki, i) - !!< Zero the entries of a particular row of a block csr matrix. - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki, i - integer :: k - - real, dimension(:), pointer :: val - integer, dimension(:), pointer :: ival - - if (associated(matrix%val)) then - do k=1,matrix%blocks(2) - if(matrix%diagonal.and.(blocki/=k)) cycle - val => row_val_ptr(matrix, blocki, k, i) - val = 0.0 - end do - end if - if (associated(matrix%ival)) then - do k=1,matrix%blocks(2) - if(matrix%diagonal.and.(blocki/=k)) cycle - ival => row_ival_ptr(matrix, blocki, k, i) - ival = 0 - end do - end if - - end subroutine block_csr_zero_single_row - - subroutine block_csr_zero_row(matrix, i) - !!< Zero the entries of a particular row in all blocks of a block csr matrix. - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - integer :: j, k - - real, dimension(:), pointer :: val - integer, dimension(:), pointer :: ival - - if (associated(matrix%val)) then - do j=1,matrix%blocks(1) - do k=1,matrix%blocks(2) - if(matrix%diagonal.and.(j/=k)) cycle - val => row_val_ptr(matrix, j, k, i) - val = 0.0 - end do - end do - end if - if (associated(matrix%ival)) then - do j=1,matrix%blocks(1) - do k=1,matrix%blocks(2) - if(matrix%diagonal.and.(j/=k)) cycle - ival => row_ival_ptr(matrix, j, k, i) - ival = 0.0 - end do - end do - end if - - end subroutine block_csr_zero_row - - subroutine dcsr_zero_column(matrix,column) - !!< Zero the entries of a dynamic csr matrix. - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: column - - integer, dimension(:), pointer :: row_ptr - integer :: i,j - - do i =1 ,size(matrix,1) - - row_ptr => matrix%colm(i)%ptr - - if(any(row_ptr==column)) then - do j=1,size(row_ptr) - if(row_ptr(j)==column) then - matrix%val(i)%ptr(j)=0.0 - end if - end do - end if - - end do - - end subroutine dcsr_zero_column - - function csr_sparsity_pos(sparsity, i, j, save_pos) - !!< Return the location in sparsity of element (i,j) - integer :: csr_sparsity_pos - type(csr_sparsity), intent(in) :: sparsity - integer, intent(in) :: i,j - ! an attempt at optimisation... - ! if save_pos is present, test to see if it's correct, if yes then return it - ! if no, then carry on as normal but save the position and return it as save_pos - integer, intent(inout), optional :: save_pos - - integer, dimension(:), pointer :: row - integer :: rowpos, base - integer :: lower_pos, lower_j - integer :: upper_pos, upper_j - integer :: this_pos, this_j - - if (present(save_pos)) then - if (save_pos>=sparsity%findrm(i) .and. save_pos row_m_ptr(sparsity,i) - - if (sparsity%sorted_rows) then - ! The j values in row are sorted in ascending order so we can do a - ! fast bisection search. - - ! Base is the last position in colm of the previous row. - base=sparsity%findrm(i)-1 - - upper_pos=size(row) - upper_j=row(upper_pos) - lower_pos=1 - lower_j=row(1) - - if (upper_jj) then - csr_sparsity_pos=0 - goto 42 - else if(lower_j==j) then - csr_sparsity_pos=lower_pos+base - goto 42 - end if - - bisection_loop: do while (upper_pos-lower_pos>1) - this_pos=(upper_pos+lower_pos)/2 - this_j=row(this_pos) - - if(this_j == j) then - csr_sparsity_pos=this_pos+base - goto 42 - else if(this_j > j) then - ! this_j>j - upper_j=this_j - upper_pos=this_pos - else - ! this_jj -! upper_j=this_j -! upper_pos=this_pos -! case(:-1) -! ! this_jmatrix%colm(i)%ptr - - if (.not.any(j==row)) then - ! i,j is not in matrix. - dcsr_pos_noadd=0 - return - end if - - rowpos=0 - rowpos=minloc(row, row==j) - - dcsr_pos_noadd=rowpos(1) - - end function dcsr_pos_noadd - - function dcsr_pos(matrix, i, j, add) - !!< Return the location in matrix of element (i,j) - integer :: dcsr_pos - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i,j - !! Flag which determines whether new entries are added. - logical, intent(in) :: add - - integer, dimension(:), pointer :: row - real, dimension(:), pointer :: val - integer, dimension(1) :: rowpos - - row=>matrix%colm(i)%ptr - val=>matrix%val(i)%ptr - - if (.not.any(j==row)) then - if (.not.add) then - ! i,j is not in matrix. - dcsr_pos=0 - return - end if - - rowpos=0 - if (size(row)>0) then - if (all(j>row)) then - rowpos(1)=size(row) - else - rowpos=minloc(row, mask=row>j)-1 - end if - end if - - ! Lengthen the row by one place - allocate(matrix%colm(i)%ptr(size(row)+1), & - & matrix% val(i)%ptr(size(row)+1)) - - ! Copy the old row in place - if (rowpos(1)>0) then - matrix%colm(i)%ptr(:rowpos(1))=row(:rowpos(1)) - matrix%val(i)%ptr(:rowpos(1))=val(:rowpos(1)) - end if - if (rowpos(1)matrix%colm(i)%ptr - val=>matrix%val(i)%ptr + end function dcsr_dense - ! Insert the new location. - row(rowpos(1)+1)=j - val(rowpos(1)+1)=0.0 - end if + function block_dcsr_dense(matrix) result (dense) + !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! + type(block_dynamic_csr_matrix), intent(in) :: matrix + integer, dimension(size(matrix,1), size(matrix,2)) :: dense - rowpos=0 - rowpos=minloc(row, row==j) + integer :: i,j + integer, dimension(blocks(matrix,1)+1) :: sizes_i + integer, dimension(blocks(matrix,2)+1) :: sizes_j - dcsr_pos=rowpos(1) + sizes_i(1)=0 + do i=2,blocks(matrix,1)+1 + sizes_i(i)=sizes_i(i-1)+block_size(matrix, i-1, 1, dim=1) + end do - end function dcsr_pos + sizes_j(1)=0 + do j=2,blocks(matrix,2)+1 + sizes_j(j)=sizes_j(j-1)+block_size(matrix, 1, j-1, dim=2) + end do - subroutine csr_addto(matrix, i, j, val, save_pos) - !!< Add val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i,j - real, intent(in) :: val - integer, intent(inout), optional :: save_pos + do i=1, blocks(matrix,1) + do j=1,blocks(matrix,2) - integer :: mpos + dense(sizes_i(i)+1:sizes_i(i+1),sizes_j(j)+1:sizes_j(j+1))=& + dcsr_dense(matrix%blocks(i,j)) - if (val==0) return ! No point doing nothing. + end do + end do + ! call reset_debug_level() - This shouldn't be in the trunk! - mpos = pos(matrix,i,j,save_pos=save_pos) + end function block_dcsr_dense - if (associated(matrix%val)) then - if(mpos==0) then - FLAbort("Attempting to set value in matrix outside sparsity pattern.") - end if - matrix%val(mpos)=matrix%val(mpos)+val - else if (associated(matrix%ival)) then - matrix%ival(mpos)=matrix%ival(mpos)+val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if + function dcsr2csr(dcsr) result (csr) + !!< Given a dcsr matrix return a csr matrix. The dcsr matrix is left + !!< untouched. + type(dynamic_csr_matrix), intent(in) :: dcsr + type(csr_matrix) :: csr - end subroutine csr_addto + integer :: rows, columns, nentries, i, rowptr, rowlen + integer, dimension(1) :: rowpos + type(csr_sparsity) :: sparsity - subroutine csr_iaddto(matrix, i, j, val, save_pos) - !!< Add val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i,j - integer, intent(in) :: val - integer, intent(inout), optional :: save_pos + rows=size(dcsr,1) + columns=size(dcsr,2) + nentries=entries(dcsr) - integer :: mpos + if (len_trim(dcsr%name)==0) then + call allocate(sparsity, rows, columns, nentries, name="dcsr2csrSparsity") + else + call allocate(sparsity, rows, columns, nentries, & + name=trim(dcsr%name)//'Sparsity') + end if + call allocate(csr, sparsity, name=dcsr%name) + ! Drop the excess reference + call deallocate(sparsity) - mpos = pos(matrix,i,j,save_pos=save_pos) + rowptr=1 + do i=1,rows + csr%sparsity%findrm(i)=rowptr - if (val==0) return ! No point doing nothing. + rowlen=size(dcsr%colm(i)%ptr) - if (associated(matrix%val)) then - matrix%val(mpos)=matrix%val(mpos)+val - else if (associated(matrix%ival)) then - matrix%ival(mpos)=matrix%ival(mpos)+val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if + csr%sparsity%colm(rowptr:rowptr+rowlen-1)=dcsr%colm(i)%ptr - end subroutine csr_iaddto + csr%val(rowptr:rowptr+rowlen-1)=dcsr%val(i)%ptr - subroutine csr_vaddto(matrix, i, j, val, mask) - !!< Add val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i,j - real, dimension(size(i),size(j)), intent(in) :: val - logical, dimension(size(i), size(j)), intent(in), optional :: mask + if (any(dcsr%colm(i)%ptr==i)) then - integer :: iloc, jloc - logical, dimension(size(i), size(j)) :: l_mask + rowpos=minloc(dcsr%colm(i)%ptr,mask=dcsr%colm(i)%ptr==i) - if(present(mask)) then - l_mask = mask - else - l_mask = .true. - end if + csr%sparsity%centrm(i)=rowptr+rowpos(1)-1 - do iloc=1,size(i) - do jloc=1,size(j) - if(.not.l_mask(iloc,jloc)) cycle - call addto(matrix, i(iloc), j(jloc), val(iloc,jloc)) - end do - end do + else +! ewrite(1,*) "Missing diagonal element" - end subroutine csr_vaddto + csr%sparsity%centrm(i)=0 + end if - subroutine block_csr_addto(matrix, blocki, blockj, i, j, val, save_pos) - !!< Add val to matrix(i,j) - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj,i,j - real, intent(in) :: val - integer, intent(inout), optional :: save_pos + rowptr = rowptr + rowlen - integer :: mpos + end do - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if + csr%sparsity%findrm(rows+1) = rowptr - mpos = pos(matrix, i, j, save_pos=save_pos) + ! dcsr rows are sorted (by construction in dcsr_rowpos_add) + csr%sparsity%sorted_rows=.true. - if (associated(matrix%val)) then - matrix%val(blocki, blockj)%ptr(mpos)& - =matrix%val(blocki, blockj)%ptr(mpos)+val + end function dcsr2csr - else if (associated(matrix%ival)) then - matrix%ival(blocki, blockj)%ptr(mpos)& - =matrix%ival(blocki, blockj)%ptr(mpos)+val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine block_csr_addto - - subroutine block_csr_vaddto(matrix, blocki, blockj, i, j, val, mask) - !!< Add val to matrix(i,j) - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj - integer, dimension(:), intent(in) :: i,j - real, dimension(size(i),size(j)), intent(in) :: val - logical, dimension(size(i), size(j)), intent(in), optional :: mask - - integer :: iloc, jloc - logical, dimension(size(i), size(j)) :: l_mask - - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - if(present(mask)) then - l_mask = mask - else - l_mask = .true. - end if - - do iloc=1,size(i) - do jloc=1,size(j) - if(.not.l_mask(iloc, jloc)) cycle - call addto(matrix, blocki,blockj, & - & i(iloc),j(jloc), val(iloc,jloc)) - end do - end do - - end subroutine block_csr_vaddto - - subroutine block_csr_blocks_addto(matrix, i, j, val, block_mask) - !!< Add the (blocki, blockj, :, :) th matrix of val onto the (blocki, blockj) th - !!< block of the block csr matrix, for all blocks of the block csr matrix. - - type(block_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i - integer, dimension(:), intent(in) :: j - real, dimension(matrix%blocks(1), matrix%blocks(2), size(i), size(j)), intent(in) :: val - logical, dimension(matrix%blocks(1), matrix%blocks(2)), intent(in), optional :: block_mask - - integer, dimension(size(i), size(j)) :: positions - logical, dimension(matrix%blocks(1), matrix%blocks(2)) :: l_block_mask - - integer :: blocki, blockj, iloc, jloc - - if(present(block_mask)) then - l_block_mask = block_mask - else - l_block_mask = .true. - end if - - ! this is optimised so that row searches are only done once - ! we do however want to want to keep the block loops on the outside - ! to improve data locality. - - do iloc = 1, size(positions, 1) - do jloc = 1, size(positions, 2) - if (all(val(:, :, iloc, jloc)==0.0)) cycle - positions(iloc,jloc)=pos(matrix%sparsity,i(iloc),j(jloc)) - end do - end do - - do blocki = 1, matrix%blocks(1) - do blockj = 1, matrix%blocks(2) - if(.not.l_block_mask(blocki, blockj)) cycle - do iloc = 1, size(positions, 1) - do jloc = 1, size(positions, 2) - ! Don't add zeros into the matrix, especially as these may be - ! at invalid locations. - if(val(blocki, blockj, iloc, jloc)==0) cycle - matrix%val(blocki, blockj)%ptr(positions(iloc,jloc))= & - matrix%val(blocki, blockj)%ptr(positions(iloc,jloc)) + & - val(blocki, blockj, iloc, jloc) - end do - end do - end do - end do - - end subroutine block_csr_blocks_addto - - subroutine block_csr_baddto(matrix, blocki, blockj, mblock, scalar) - !!< Add csr_matrix to a block_csr_matrix, where the csr_matrix has the same - !!< sparsity (or a subset of it) as the blocks of the block_csr_matrix - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj - type(csr_matrix), intent(in):: mblock - !! if present add scalar*mblock: - real, optional, intent(in):: scalar - - real, pointer:: blockijval(:), val_ptr(:) - integer, pointer:: col_ptr(:) - real lscalar - integer row, col - - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - if (mblock%clone .or. matrix%clone) then - ! if one of matrix and mblock is a clone of the other, or both are clones - ! of the same original, we only have to copy the values: - if (associated(matrix%sparsity%findrm, mblock%sparsity%findrm) .and. & - associated(matrix%sparsity%colm, mblock%sparsity%colm)) then + function csr2dcsr(csr) result (dcsr) + !!< Given a csr matrix return a dcsr matrix. The csr matrix is left + !!< untouched. + type(csr_matrix), intent(in) :: csr + type(dynamic_csr_matrix) :: dcsr - blockijval => matrix%val(blocki, blockj)%ptr - if (present(scalar)) then - blockijval=blockijval+mblock%val*scalar - else - blockijval=blockijval+mblock%val - end if - return - end if - end if - - ! the safe way: all entries are add in one by one... - if (present(scalar)) then - lscalar=scalar - else - lscalar=1.0 - end if - - do row=1, size(mblock,1) - col_ptr => row_m_ptr(mblock, row) - val_ptr => row_val_ptr(mblock, row) - do col=1, size(col_ptr) - call addto(matrix, blocki, blockj, row, col_ptr(col), & - val_ptr(col)*lscalar) - end do - end do + integer i, j, rows, columns - end subroutine block_csr_baddto + rows=size(csr,1) + columns=size(csr,2) - subroutine block_csr_bset(matrix, blocki, blockj, mblock) - !!< Assign csr_matrix to a block_csr_matrix, where the csr_matrix has the same - !!< sparsity - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj - type(csr_matrix), intent(in):: mblock + call allocate(dcsr, rows, columns) - real, pointer:: blockijval(:), val_ptr(:) - integer, pointer:: col_ptr(:) - integer row, col + do i=1,rows - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if + do j=csr%sparsity%findrm(i), csr%sparsity%findrm(i+1)-1 - if (associated(matrix%sparsity%findrm, mblock%sparsity%findrm) .and. & - associated(matrix%sparsity%colm, mblock%sparsity%colm)) then + call set(dcsr, i, csr%sparsity%colm(j), csr%val(j)) - blockijval => matrix%val(blocki, blockj)%ptr - blockijval=mblock%val - return - else - do row=1, size(mblock,1) - col_ptr => row_m_ptr(mblock, row) - val_ptr => row_val_ptr(mblock, row) - do col=1, size(col_ptr) - call set(matrix, blocki, blockj, row, col_ptr(col), & - val_ptr(col)) end do - end do - end if - end subroutine block_csr_bset - - subroutine csr_scale(matrix, scale) - !!< Scale matrix by scale. - type(csr_matrix), intent(inout) :: matrix - real, intent(in) :: scale - - matrix%val=matrix%val*scale - - end subroutine csr_scale - - subroutine block_csr_scale(matrix, scale) - !!< Scale matrix by scale. - type(block_csr_matrix), intent(inout) :: matrix - real, intent(in) :: scale - ! - integer :: d1,d2 - - do d1 = 1, matrix%blocks(1) - do d2 = 1, matrix%blocks(2) - matrix%val(d1,d2)%ptr=matrix%val(d1,d2)%ptr*scale - end do - end do - - end subroutine block_csr_scale - - subroutine block_csr_bvaddto(matrixA, blocki, blockj, matrixB, scalar) - !!< Add all blocks of a block_csr_matrix to another block_csr_matrix, - !!< where the same sparsity pattern but possibly more blocks - type(block_csr_matrix), intent(inout) :: matrixA - type(block_csr_matrix), intent(in):: matrixB - ! The compiler on AIX has some unreasonable obkection to the blocks - ! function. -!!$ integer, dimension(blocks(matrixB,1)), intent(in) :: blocki -!!$ integer, dimension(blocks(matrixB,2)), intent(in) :: blockj - integer, dimension(matrixB%blocks(1)), intent(in) :: blocki - integer, dimension(matrixB%blocks(2)), intent(in) :: blockj - !! if present add scalar*matrixB: - real, optional, intent(in):: scalar - - type(csr_matrix) blockij - integer :: i, j - - do i=1, size(blocki) - do j=1, size(blockj) - if(matrixB%diagonal.and.(i/=j)) then - FLAbort("Attempting to retrive an off-diagonal block of a diagonal block_csr_matrix.") - end if - if(matrixA%diagonal.and.(blocki(i)/=blockj(j))) then - FLAbort("Attempting to set values in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - blockij=block(matrixB, i, j) - call addto(matrixA, blocki(i), blockj(j), blockij, scalar=scalar) - end do - end do - - end subroutine block_csr_bvaddto - - subroutine dcsr_addto(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i, j - real, intent(in) :: val - - integer :: rowpos - - ! Because pos has side effects, it is a very good idea to call it - ! before the assemble. - rowpos=pos(matrix, i, j, add=.true.) - - matrix%val(i)%ptr(rowpos)=matrix%val(i)%ptr(rowpos)+val - - end subroutine dcsr_addto - - subroutine dcsr_dcsraddto(matrix1,matrix2) - !!< Add matrix2 to matrix1 - !!< could probably do with optimizing - type(dynamic_csr_matrix), intent(inout) :: matrix1 - type(dynamic_csr_matrix), intent(in) :: matrix2 - - !locals - integer :: i,j - assert(size(matrix1,1)==size(matrix2,1)) - assert(size(matrix1,2)==size(matrix2,2)) + end do - do i = 1,size(matrix2%colm) - do j = 1,size(matrix2%colm(i)%ptr) - call addto(matrix1,i,matrix2%colm(i)%ptr(j),matrix2%val(i)%ptr(j)) - end do - end do + end function csr2dcsr - end subroutine dcsr_dcsraddto + subroutine csr_mult(vector_out,mat,vector_in) + !!< Multiply a csr_matrix by a vector, + !!< result is written to vector_out - subroutine csr_csraddto(matrix1,matrix2, scale) - !!< Add matrix2 to matrix1: sparsity must be the same though - type(csr_matrix), intent(inout) :: matrix1 - type(csr_matrix), intent(in) :: matrix2 - real, optional, intent(in) :: scale + !interface variables + real, dimension(:), intent(in) :: vector_in + type(csr_matrix), intent(in) :: mat + real, dimension(:), intent(out) :: vector_out - !locals - integer :: i,j - real :: l_scale + !local variables + integer :: i, j - assert(size(matrix1,1)==size(matrix2,1)) - assert(size(matrix1,2)==size(matrix2,2)) + assert(size(vector_in)==size(mat,2)) + assert(size(vector_out)==size(mat,1)) - if(present(scale)) then - l_scale=scale - else - l_scale=1.0 - end if + do i = 1, size(vector_out) + vector_out(i) = 0.0 + do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 + vector_out(i) = vector_out(i) + mat%val(j) * vector_in(mat%sparsity%colm(j)) + end do + end do - do i = 1,size(matrix2%sparsity%findrm)-1 - do j = matrix2%sparsity%findrm(i),matrix2%sparsity%findrm(i+1)-1 - call addto(matrix1,i,matrix2%sparsity%colm(j),l_scale*matrix2%val(j)) - end do - end do + end subroutine csr_mult - end subroutine csr_csraddto + subroutine csr_mult_addto(vector_out,mat,vector_in) + !!< Multiply a csr_matrix by a vector, + !!< result is added vector_out - subroutine dcsr_vaddto(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i, j - real, dimension(size(i),size(j)), intent(in) :: val + !interface variables + real, dimension(:), intent(in) :: vector_in + type(csr_matrix), intent(in) :: mat + real, dimension(:), intent(inout) :: vector_out - integer :: iloc, jloc + !local variables + integer :: i, j - do iloc=1,size(i) - do jloc=1,size(j) - call addto(matrix, i(iloc), j(jloc), val(iloc,jloc)) - end do - end do + assert(size(vector_in)==size(mat,2)) + assert(size(vector_out)==size(mat,1)) - end subroutine dcsr_vaddto + do i = 1, size(vector_out) + do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 + vector_out(i) = vector_out(i) + mat%val(j) * vector_in(mat%sparsity%colm(j)) + end do + end do - subroutine dcsr_vaddto1(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - integer, dimension(:), intent(in) :: j - real, dimension(size(j)), intent(in) :: val + end subroutine csr_mult_addto - integer :: jloc + subroutine dcsr_mult(m,v,mv) + type(dynamic_csr_matrix), intent(in) :: m + real, dimension(:), intent(in) :: v + real, dimension(:), intent(out) :: mv - do jloc=1,size(j) - call addto(matrix, i, j(jloc), val(jloc)) - end do + !locals + integer :: i - end subroutine dcsr_vaddto1 + if(size(m,1).ne.size(mv)) FLAbort('Bad vector size out.') + if(size(m,2).ne.size(v)) FLAbort('Bad vector size in.') - subroutine dcsr_vaddto2(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i - integer, intent(in) :: j - real, dimension(size(i)), intent(in) :: val + mv = 0. - integer :: iloc + do i = 1, size(mv) + mv(i) = sum(v(row_m(m,i)) * row_val_ptr(m,i)) + end do - do iloc=1,size(i) - call addto(matrix, i(iloc), j, val(iloc)) - end do + end subroutine dcsr_mult - end subroutine dcsr_vaddto2 - subroutine dcsr_set(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i, j - real, intent(in) :: val + subroutine csr_mult_T(vector_out,mat,vector_in) + !!< Multiply the transpose of a csr_matrix by a vector, + !!< result is written to vector_out - integer :: rowpos + !interface variables + real, dimension(:), intent(in) :: vector_in + type(csr_matrix), intent(in) :: mat + real, dimension(:), intent(out) :: vector_out - ! Because pos has side effects, it is a very good idea to call it - ! before the assemble. - rowpos=pos(matrix, i, j, add=.true.) + !local variables + integer :: i, j, k - matrix%val(i)%ptr(rowpos)=val + ewrite(2,*) 'size(vector_in) = ', size(vector_in) + ewrite(2,*) 'size(mat,1) = ', size(mat,1) + assert(size(vector_in)==size(mat,1)) + ewrite(2,*) 'size(vector_out) = ', size(vector_out) + ewrite(2,*) 'size(mat,2) = ', size(mat,2) + assert(size(vector_out)==size(mat,2)) - end subroutine dcsr_set + vector_out=0 + do i = 1, size(vector_in) + do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 + k = mat%sparsity%colm(j) + vector_out(k) = vector_out(k) + mat%val(j) * vector_in(i) + end do + end do - subroutine dcsr_vset(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i, j - real, dimension(size(i),size(j)), intent(in) :: val + end subroutine csr_mult_T - integer :: iloc, jloc + subroutine csr_mult_T_addto(vector_out,mat,vector_in) + !!< Multiply the transpose of a csr_matrix by a vector, + !!< result is added to vector_out - do iloc=1,size(i) - do jloc=1,size(j) - call set(matrix, i(iloc), j(jloc), val(iloc,jloc)) - end do - end do + !interface variables + real, dimension(:), intent(in) :: vector_in + type(csr_matrix), intent(in) :: mat + real, dimension(:), intent(out) :: vector_out - end subroutine dcsr_vset + !local variables + integer :: i, j, k - subroutine dcsr_set_row(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - integer, dimension(:), intent(in) :: j - real, dimension(size(j)), intent(in) :: val + ewrite(2,*) 'size(vector_in) = ', size(vector_in) + ewrite(2,*) 'size(mat,1) = ', size(mat,1) + assert(size(vector_in)==size(mat,1)) + ewrite(2,*) 'size(vector_out) = ', size(vector_out) + ewrite(2,*) 'size(mat,2) = ', size(mat,2) + assert(size(vector_out)==size(mat,2)) - integer :: jloc + do i = 1, size(vector_in) + do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 + k = mat%sparsity%colm(j) + vector_out(k) = vector_out(k) + mat%val(j) * vector_in(i) + end do + end do - do jloc=1,size(j) - call set(matrix, i, j(jloc), val(jloc)) - end do + end subroutine csr_mult_T_addto - end subroutine dcsr_set_row + subroutine dcsr_mult_T(m,v,mv) + type(dynamic_csr_matrix), intent(in) :: m + real, dimension(:), intent(in) :: v + real, dimension(:), intent(out) :: mv - subroutine dcsr_set_col(matrix, i, j, val) - !!< Add val to matrix(i,j) - type(dynamic_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i - integer, intent(in) :: j - real, dimension(size(i)), intent(in) :: val + !locals + integer :: i - integer :: iloc + if(size(m,2).ne.size(mv)) FLAbort('Bad vector size out.') + if(size(m,1).ne.size(v)) FLAbort('Bad vector size in.') - do iloc=1,size(i) - call set(matrix, i(iloc), j, val(iloc)) - end do + mv = 0. - end subroutine dcsr_set_col + do i = 1, size(v) + mv(row_m(m,i)) = mv(row_m(m,i)) & + + v(i) * row_val_ptr(m,i) + end do - subroutine csr_addto_diag(matrix, i, val, scale, save_pos) - !!< Add val to matrix(i,i) - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - real, intent(in) :: val - real, intent(in), optional ::scale - integer, intent(inout), optional :: save_pos + end subroutine dcsr_mult_T + + function dcsr_matmul_T(matrix1, matrix2, model,check) result (product) + !!< Perform the matrix multiplication: + !!< + !!< matrix1*matrix2^T + !!< + type(dynamic_csr_matrix), intent(in) :: matrix1, matrix2 + type(dynamic_csr_matrix) :: product + type(dynamic_csr_matrix), intent(in), optional :: model + logical, intent(in), optional :: check + + type(integer_vector), dimension(:), allocatable :: hitlist + integer, dimension(:), allocatable :: size_hitlist + + integer, dimension(:), pointer :: row, col + integer :: i,j,k1,k2,jrow,jcol + real :: entry + logical :: addflag + logical :: l_check + real , allocatable, dimension(:) :: vec, m2Tvec, m1m2tvec, productvec + + l_check = .false. + if(present(check)) then + L_check = check + end if - integer :: mpos + assert(size(matrix1,2)==size(matrix2,2)) - if(associated(matrix%sparsity%centrm)) then - mpos = matrix%sparsity%centrm(i) - else - mpos = pos(matrix,i,i,save_pos=save_pos) - end if + call allocate(product, size(matrix1,1), size(matrix2,1)) + call zero(product) - if (associated(matrix%val)) then - if(present(scale)) then - matrix%val(mpos)=matrix%val(mpos)+val*scale - else - matrix%val(mpos)=matrix%val(mpos)+val - end if - else if (associated(matrix%ival)) then - if(present(scale)) then - matrix%ival(mpos)=matrix%ival(mpos)+val*scale - else - matrix%ival(mpos)=matrix%ival(mpos)+val - end if - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine csr_addto_diag - - subroutine csr_vaddto_diag(matrix, i, val, scale) - !!< Add val to matrix(i,i) - type(csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i - real, dimension(size(i)), intent(in) :: val - real, intent(in), optional :: scale - - integer :: iloc - - do iloc=1,size(i) - call addto_diag(matrix, i(iloc), val(iloc), scale=scale) - end do - - end subroutine csr_vaddto_diag - - subroutine block_csr_addto_diag(matrix, blocki, blockj, i, val, scale, save_pos) - !!< Add val to matrix(i,i) - !!< Adding to the diagonal of a non-diagonal block is supported. - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj, i - real, intent(in) :: val - real, intent(in), optional :: scale - integer, intent(inout), optional :: save_pos - - integer :: mpos - - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - if(associated(matrix%sparsity%centrm)) then - mpos = matrix%sparsity%centrm(i) - else - mpos = pos(matrix,i,i,save_pos=save_pos) - end if - - if (associated(matrix%val)) then - if(present(scale)) then - matrix%val(blocki,blockj)%ptr(mpos)& - =matrix%val(blocki, blockj)%ptr(mpos)+val*scale - else - matrix%val(blocki,blockj)%ptr(mpos)& - =matrix%val(blocki, blockj)%ptr(mpos)+val - end if - else if (associated(matrix%ival)) then - if(present(scale)) then - matrix%ival(blocki, blockj)%ptr(mpos)& - =matrix%ival(blocki, blockj)%ptr(mpos)+val*scale - else - matrix%ival(blocki, blockj)%ptr(mpos)& - =matrix%ival(blocki, blockj)%ptr(mpos)+val - end if - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine block_csr_addto_diag - - subroutine block_csr_vaddto_diag(matrix, blocki, blockj, i, val, scale) - !!< Add val to matrix(i,i) - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki, blockj - integer, dimension(:), intent(in) :: i - real, dimension(size(i)), intent(in) :: val - real, intent(in), optional :: scale - - integer :: iloc - - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - do iloc=1,size(i) - call addto_diag(matrix, blocki, blockj, i(iloc), val(iloc), scale=scale) - end do - - end subroutine block_csr_vaddto_diag - - subroutine csr_set(matrix, i, j, val, save_pos) - !!< Add val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i,j - real, intent(in) :: val - integer, intent(inout), optional :: save_pos - - integer :: mpos - - mpos = pos(matrix,i,j,save_pos=save_pos) - !In debugging mode, check that the entry actually exists. - assert(mpos>0) - - if (associated(matrix%val)) then - matrix%val(mpos)=val - else if (associated(matrix%ival)) then - matrix%ival(mpos)=val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine csr_set - - subroutine csr_csr_set(out_matrix, in_matrix) - !!< Set out_matrix to in_matrix. This will only work if the matrices have - !!< the same sparsity. - type(csr_matrix), intent(inout) :: out_matrix - type(csr_matrix), intent(in) :: in_matrix - - ! - integer :: row, i - integer, dimension(:), pointer:: cols - real, dimension(:), pointer :: vals -#ifdef DDEBUG - logical :: matrix_same_shape -#endif + ewrite(2,*) 'Measuring structure' - if(in_matrix%sparsity%refcount%id==out_matrix%sparsity%refcount%id) then - !Code for the same sparsity - if (associated(out_matrix%ival)) then - assert(associated(in_matrix%ival)) - else - assert((associated(out_matrix%val).and.associated(in_matrix%val))) - end if - - if(associated(out_matrix%val)) then - out_matrix%val=in_matrix%val - else if (associated(out_matrix%ival)) then - out_matrix%ival=in_matrix%ival - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - else - ewrite(-1,*) 'Warning, not same sparsity' - !Code for different sparsity, we assume that in_matrix%sparsity - !is contained in out_matrix%sparsity -#ifdef DDEBUG - matrix_same_shape=size(out_matrix,1)==size(in_matrix,1) - assert(matrix_same_shape) - matrix_same_shape=size(out_matrix,2)==size(in_matrix,2) - assert(matrix_same_shape) -#endif + allocate( hitlist(size(matrix2,2)), size_hitlist(size(matrix2,2)) ) - if (associated(out_matrix%ival)) then - assert(associated(in_matrix%ival)) - else - assert((associated(out_matrix%val).and.associated(in_matrix%val))) - end if - - call zero(out_matrix) - - do row = 1, size(out_matrix,1) - cols => row_m_ptr(in_matrix, row) - vals => row_val_ptr(in_matrix, row) - do i = 1, size(cols) - call set(out_matrix,row,cols(i),vals(i)) - end do - end do - end if - end subroutine csr_csr_set - - subroutine csr_block_csr_set(out_matrix, in_matrix, blocki, blockj) - !!< Set out_matrix to (blocki, blockj) of in_matrix. This will - !!< only work if the matrices have the same sparsity. - type(csr_matrix), intent(inout) :: out_matrix - type(block_csr_matrix), intent(in) :: in_matrix - integer, intent(in) :: blocki, blockj - - ! - integer :: row, i - integer, dimension(:), pointer:: cols - real, dimension(:), pointer :: vals -#ifdef DDEBUG - logical :: matrix_same_shape -#endif + if(.not.present(model)) then + size_hitlist = 0 - if(in_matrix%sparsity%refcount%id==out_matrix%sparsity%refcount%id) then - !Code for the same sparsity - if (associated(out_matrix%ival)) then - assert(associated(in_matrix%ival)) - else - assert((associated(out_matrix%val).and.associated(in_matrix%val))) - end if - - if(associated(out_matrix%val)) then - assert(associated(in_matrix%val(blocki,blockj)%ptr)) - out_matrix%val=in_matrix%val(blocki,blockj)%ptr - else if (associated(out_matrix%ival)) then - assert(associated(in_matrix%ival(blocki,blockj)%ptr)) - out_matrix%ival=in_matrix%ival(blocki,blockj)%ptr - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - else - ewrite(-1,*) 'Warning, not same sparsity' - !Code for different sparsity, we assume that in_matrix%sparsity - !is contained in out_matrix%sparsity -#ifdef DDEBUG - matrix_same_shape=size(out_matrix,1)==size(in_matrix,1) - assert(matrix_same_shape) - matrix_same_shape=size(out_matrix,2)==size(in_matrix,2) - assert(matrix_same_shape) -#endif + !count the number of rows of matrix2 which contain an element + !in the column + do j = 1, size(matrix2,1) + col=>matrix2%colm(j)%ptr + if(size(col)>0) then + do k1 = 1, size(col) + size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 + end do + end if + end do - if (associated(out_matrix%ival)) then - assert(associated(in_matrix%ival)) - else - assert((associated(out_matrix%val).and.associated(in_matrix%val))) - end if - - call zero(out_matrix) - - do row = 1, size(out_matrix,1) - cols => row_m_ptr(in_matrix, row) - vals => row_val_ptr(in_matrix, blocki, blockj, row) - do i = 1, size(cols) - call set(out_matrix,row,cols(i),vals(i)) - end do - end do - end if - - end subroutine csr_block_csr_set - - subroutine csr_vset(matrix, i, j, val) - !!< Set val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i, j - real, dimension(size(i),size(j)), intent(in) :: val - - integer :: iloc, jloc - - do iloc=1,size(i) - do jloc=1,size(j) - call set(matrix, i(iloc), j(jloc), val(iloc,jloc)) - end do - end do - - end subroutine csr_vset - - subroutine csr_rset(matrix, i, j, val) - !!< Set val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: j - integer, intent(in) :: i - real, dimension(size(j)), intent(in) :: val - - integer :: jloc - - do jloc=1,size(j) - call set(matrix, i, j(jloc), val(jloc)) - end do - - end subroutine csr_rset - - subroutine csr_iset(matrix, i, j, val, save_pos) - !!< Add val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i,j - integer, intent(in) :: val - integer, intent(inout), optional :: save_pos - - integer :: mpos - - mpos = pos(matrix,i,j,save_pos=save_pos) - !In debugging mode, check that the entry actually exists. - assert(mpos>0) - - if (associated(matrix%val)) then - matrix%val(mpos)=val - else if (associated(matrix%ival)) then - matrix%ival(mpos)=val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine csr_iset - - subroutine block_csr_vset(matrix, blocki, blockj, i, j, val) - !!< Add val to matrix(i,j) - type(block_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i, j - integer, intent(in) :: blocki, blockj - real, dimension(size(i),size(j)), intent(in) :: val - - integer :: iloc, jloc - - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - do iloc=1,size(i) - do jloc=1,size(j) - call block_csr_set(matrix, blocki, blockj, i(iloc), j(jloc), val(iloc,jloc)) - end do - end do - - end subroutine block_csr_vset - - subroutine block_csr_set(matrix, blocki, blockj, i, j, val, save_pos) - !!< Add val to matrix(i,j) - type(block_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj,i,j - real, intent(in) :: val - integer, intent(inout), optional :: save_pos - - integer :: mpos - - if(matrix%diagonal.and.(blocki/=blockj)) then - FLAbort("Attempting to set value in an off-diagonal block of a diagonal block_csr_matrix.") - end if - - mpos = pos(matrix,i,j,save_pos=save_pos) - - !In debugging mode, check that the entry actually exists. - assert(mpos>0) -! assert(blocki<=matrix%blocks(1).and.blockj<=matrix%blocks(j)) + do j = 1, size(matrix1,2) + allocate( hitlist(j)%ptr(size_hitlist(j)) ) + end do - if (associated(matrix%val)) then - matrix%val(blocki,blockj)%ptr(mpos)=val - else if (associated(matrix%ival)) then - matrix%ival(blocki,blockj)%ptr(mpos)=val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine block_csr_set - - subroutine csr_set_diag(matrix, i, val, save_pos) - !!< Set val to matrix(i,j) - type(csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - real, intent(in) :: val - integer, intent(inout), optional :: save_pos - - integer :: mpos - - if(associated(matrix%sparsity%centrm)) then - mpos = matrix%sparsity%centrm(i) - else - mpos = pos(matrix,i,i,save_pos=save_pos) - end if - - !In debugging mode, check that the entry actually exists. - assert(mpos>0) - - if (associated(matrix%val)) then - matrix%val(mpos)=val - else if (associated(matrix%ival)) then - matrix%ival(mpos)=val - else - FLAbort("Attempting to set value in a matrix with no value space.") - end if - - end subroutine csr_set_diag - - function csr_val(matrix, i, j, save_pos) result(val) - !!< Return the value at matrix(i,j) - real :: val - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i,j - integer, intent(inout), optional :: save_pos - - integer :: mpos - - mpos=pos(matrix,i,j,save_pos=save_pos) - - if (associated(matrix%val)) then - if (mpos/=0) then - val=matrix%val(mpos) - else - ! i,j not in nonzero part of matrix. - val=0 - end if - else if (associated(matrix%ival)) then - if (mpos/=0) then - val=matrix%ival(mpos) - else - ! i,j not in nonzero part of matrix. - val=0 - end if - - else - FLAbort("Attempting to extract value in a matrix with no value space.") - end if - - end function csr_val - - function csr_ival(matrix, i, j, save_pos) result(val) - !!< Return the value at matrix(i,j) - integer :: val - type(csr_matrix), intent(in) :: matrix - integer, intent(in) :: i,j - integer, intent(inout), optional :: save_pos - - integer :: mpos - - mpos=pos(matrix,i,j,save_pos=save_pos) - - if (associated(matrix%val)) then - if (mpos/=0) then - val=matrix%val(mpos) - else - ! i,j not in nonzero part of matrix. - val=0 - end if - - else if (associated(matrix%ival)) then - if (mpos/=0) then - val=matrix%ival(mpos) - else - ! i,j not in nonzero part of matrix. - val=0 - end if - - else - FLAbort("Attempting to extract value in a matrix with no value space.") - end if - - end function csr_ival - - function block_csr_val(matrix, blocki, blockj, i, j, save_pos) result(val) - !!< Return the value at matrix(i,j) - real :: val - type(block_csr_matrix), intent(in) :: matrix - integer, intent(in) :: blocki, blockj, i,j - integer, intent(inout), optional :: save_pos + size_hitlist = 1 + + !make a list of rows of matrix2 which contain element i in the column + do j = 1, size(matrix2,1) + col=>matrix2%colm(j)%ptr + if(size(col)>0) then + do k1 = 1, size(col) + hitlist(col(k1))%ptr(size_hitlist(col(k1))) = j + size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 + end do + end if + end do - integer :: mpos + deallocate( size_hitlist ) + + do i=1, size(matrix1,1) + row=>matrix1%colm(i)%ptr + if(size(row)>0) then + do jrow = 1,size(row) + !need to visit all points hit by i + do jcol = 1,size(hitlist(row(jrow))%ptr) + j = hitlist(row(jrow))%ptr(jcol) + assert(j.ne.0) + col=>matrix2%colm(j)%ptr + + if(size(col)>0) then + entry=0.0 + + addflag = .false. + + k1 = 1 + k2 = 1 + do + if(addflag) exit + if((k1.gt.size(row)).or.(k2.gt.size(col))) exit + if(row(k1)matrix1%colm(i)%ptr - function dcsr_val(matrix, i, j) result (val) - !!< Return the value at matrix(i,j) - real :: val - type(dynamic_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i,j + if(size(row)>0) then + do jcol = 1, size(product%colm(i)%ptr) + j = product%colm(i)%ptr(jcol) + col=>matrix2%colm(j)%ptr - integer :: mpos + if(size(col)>0) then + entry=0.0 - mpos=pos(matrix,i,j) + addflag = .false. - if (mpos/=0) then - val=matrix%val(i)%ptr(mpos) - else - ! i,j not in nonzero part of matrix. - val=0 - end if + k1 = 1 + k2 = 1 + do + if((k1.gt.size(row)).or.(k2.gt.size(col))) exit + if(row(k1)abs(productvec)*1.0e-8)) then - csr_dense_i=0 + ewrite(2,*) maxval(abs(productvec-m1m2tvec)) - do i=1,size(matrix,1) - csr_dense_i(i,row_m_ptr(matrix,i))=csr_row_ival_ptr(matrix,i) - end do + call dcsr_matrix2file('matrix1',matrix1) + call dcsr_matrix2file('matrix2',matrix2) + call dcsr_matrix2file('product',product) + ewrite(2,*) size(matrix1,1), size(matrix1,2) + ewrite(2,*) size(matrix2,1), size(matrix2,2) + ewrite(2,*) size(product,1), size(product,2) + FLAbort('Matmul_t error.') + end if + end if - end function csr_dense_i + end function dcsr_matmul_T - function csr_dense(matrix) result(dense) - !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! - type(csr_matrix), intent(in) :: matrix - real, dimension(size(matrix,1), size(matrix,2)) :: dense + function csr_matmul_T(matrix1, matrix2, model) result (product) + !!< Perform the matrix multiplication: + !!< + !!< matrix1*matrix2^T + !!< + !!< Only works on csr matrices with monotonic row entries in colm + type(csr_matrix), intent(in) :: matrix1, matrix2 + type(csr_sparsity), intent(in), optional :: model + type(csr_matrix) :: product + type(dynamic_csr_matrix) :: product_d - integer :: i + type(integer_vector), dimension(:), allocatable :: hitlist + integer, dimension(:), allocatable :: size_hitlist - dense=0.0 + integer, dimension(:), pointer :: row, col + integer :: i,j,k1,k2 - do i=1,size(matrix,1) - dense(i,row_m_ptr(matrix,i))=row_val_ptr(matrix,i) - end do + ewrite(1,*) 'Entering csr_matmul_T' - end function csr_dense + assert(size(matrix1,2)==size(matrix2,2)) + if(.not.matrix1%sparsity%sorted_rows.or..not.matrix2%sparsity%sorted_rows) then + FLAbort("csr_matmul_T assumes sorted rows.") + end if - function block_csr_dense(matrix) result(dense) - !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! - type(block_csr_matrix), intent(in) :: matrix - real, dimension(size(matrix,1), size(matrix,2)) :: dense + if(.not.present(model)) then + ewrite(2,*) 'Measuring structure' - integer :: i, blocki, blockj, blockstarti, blockstartj + allocate( hitlist(size(matrix2,2)), size_hitlist(size(matrix2,2)) ) + size_hitlist = 0 - dense=0.0 + !count the number of rows of matrix2 which contain an element + !in the column + do j = 1, size(matrix2,1) + col=>row_m_ptr(matrix2,j) + do k1 = 1, size(col) + size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 + end do + end do - do blocki=1,matrix%blocks(1) + do j = 1, size(matrix1,2) + allocate( hitlist(j)%ptr(size_hitlist(j)) ) + end do - blockstarti=(blocki-1)*block_size(matrix,1) + size_hitlist = 1 + + !make a list of rows of matrix2 which contain element i in the column + do j = 1, size(matrix2,1) + col=>row_m_ptr(matrix2,j) + if(size(col)>0) then + do k1 = 1, size(col) + hitlist(col(k1))%ptr(size_hitlist(col(k1))) = j + size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 + end do + end if + end do - do blockj=1,matrix%blocks(2) + deallocate( size_hitlist ) - if(matrix%diagonal.and.(blocki/=blockj)) cycle + call allocate(product_d, size(matrix1,1), size(matrix2,1)) + do i=1, size(matrix1,1) + row=>row_m_ptr(matrix1, i) + do k1 = 1,size(row) + do k2 = 1,size(hitlist(row(k1))%ptr) + call addto(product_d,i,hitlist(row(k1))%ptr(k2),0.0) + end do + end do + end do - blockstartj=(blockj-1)*block_size(matrix,2) + deallocate( hitlist ) - do i=1,block_size(matrix,1) + product = dcsr2csr(product_d) + call deallocate( product_d) + else + call allocate(product, model) + end if - dense(blockstarti+i,blockstartj+row_m_ptr(matrix,i))& - =row_val_ptr(matrix,blocki, blockj, i) - end do + product%name="matmul_T"//trim(matrix1%name)//"*"//trim(matrix2%name) - end do - end do + call csr_matmul_t_preallocated& + (matrix1, matrix2, product = product, set_sparsity = .not. present(model)) - end function block_csr_dense + end function csr_matmul_T + + subroutine csr_matmul_t_preallocated(matrix1, matrix2, product, set_sparsity) + !!< Perform the matrix multiplication: + !!< + !!< matrix1*matrix2^T + !!< + !!< Only works on csr matrices with monotonic row entries in colm. Returns + !!< the result in the pre-allocated csr matrix product. + + type(csr_matrix), intent(in) :: matrix1 + type(csr_matrix), intent(in) :: matrix2 + type(csr_matrix), intent(inout) :: product + !! If present and .true., set the product sparsity as well as performing + !! the product + logical, optional, intent(in) :: set_sparsity + + integer, dimension(:), pointer :: row, col, row_product + real, dimension(:), pointer :: row_val, col_val + integer :: i,j,k1,k2,jcol + real :: entry0 + integer :: nentry0 + logical :: addflag, lset_sparsity + + lset_sparsity = present_and_true(set_sparsity) + + ewrite(2,*) 'adding in data' + + assert(size(matrix1,2)==size(matrix2,2)) + if(.not.matrix1%sparsity%sorted_rows.or..not.matrix2%sparsity%sorted_rows) then + FLAbort("csr_matmul_T assumes sorted rows.") + end if - function dcsr_dense(matrix) - !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! - type(dynamic_csr_matrix), intent(in) :: matrix - real, dimension(size(matrix,1), size(matrix,2)) :: dcsr_dense + call zero(product) - integer :: i + nentry0 = 0 - dcsr_dense=0 + do i=1, size(matrix1,1) + row=>row_m_ptr(matrix1, i) + row_val=>row_val_ptr(matrix1, i) - do i=1,size(matrix,1) - dcsr_dense(i,matrix%colm(i)%ptr)=matrix%val(i)%ptr - end do + if(size(row)>0) then + row_product=>row_m_ptr(product, i) + do jcol = 1, size(row_product) + j = row_product(jcol) - end function dcsr_dense + col=>row_m_ptr(matrix2, j) + col_val=>row_val_ptr(matrix2, j) - function block_dcsr_dense(matrix) result (dense) - !!< Return the dense form of matrix. WARNING! THIS CAN EASILY BE HUGE!!! - type(block_dynamic_csr_matrix), intent(in) :: matrix - integer, dimension(size(matrix,1), size(matrix,2)) :: dense + if(size(col)>0) then + entry0=0.0 - integer :: i,j - integer, dimension(blocks(matrix,1)+1) :: sizes_i - integer, dimension(blocks(matrix,2)+1) :: sizes_j + addflag = .false. - sizes_i(1)=0 - do i=2,blocks(matrix,1)+1 - sizes_i(i)=sizes_i(i-1)+block_size(matrix, i-1, 1, dim=1) - end do + k1 = 1 + k2 = 1 + do + if((k1.gt.size(row)).or.(k2.gt.size(col))) exit + if(row(k1) row_m_ptr(A, i) + call allocate(iset) + do k=1, size(rowA_i) + rowB_k => row_m_ptr(B, rowA_i(k)) + call insert(iset, rowB_k) + end do + nnz(i)=key_count(iset) + call deallocate(iset) - do i=1, blocks(matrix,1) - do j=1,blocks(matrix,2) + end do - dense(sizes_i(i)+1:sizes_i(i+1),sizes_j(j)+1:sizes_j(j+1))=& - dcsr_dense(matrix%blocks(i,j)) + ! the sparsity for C + call allocate(C, size(A,1), size(B,2), nnz=nnz, & + name="matmul_"//trim(A%name)//"*"//trim(B%name)) + + ! same thing, now actually filling in the column indices in the rows of C + do i=1, size(A, 1) + rowA_i => row_m_ptr(A, i) + rowC_i => row_m_ptr(C, i) + call allocate(iset) + do k=1, size(rowA_i) + rowB_k => row_m_ptr(B, rowA_i(k)) + call insert(iset, rowB_k) + end do + assert(key_count(iset)==size(rowC_i)) + rowC_i=set2vector(iset) + call deallocate(iset) + end do - end do - end do - ! call reset_debug_level() - This shouldn't be in the trunk! + end function csr_sparsity_matmul - end function block_dcsr_dense + function csr_matmul(A, B, model) result (C) + !!< Perform the matrix multiplication: + !!< + !!< C_ij = \sum_j A_ik * B_kj + !!< + type(csr_matrix), intent(in) :: A, B + type(csr_sparsity), intent(in), optional :: model + type(csr_matrix) :: C - function dcsr2csr(dcsr) result (csr) - !!< Given a dcsr matrix return a csr matrix. The dcsr matrix is left - !!< untouched. - type(dynamic_csr_matrix), intent(in) :: dcsr - type(csr_matrix) :: csr + type(csr_sparsity):: sparsity - integer :: rows, columns, nentries, i, rowptr, rowlen - integer, dimension(1) :: rowpos - type(csr_sparsity) :: sparsity + ewrite(1,*) 'Entering csr_matmul' - rows=size(dcsr,1) - columns=size(dcsr,2) - nentries=entries(dcsr) + assert(size(A,2)==size(B,1)) - if (len_trim(dcsr%name)==0) then - call allocate(sparsity, rows, columns, nentries, name="dcsr2csrSparsity") - else - call allocate(sparsity, rows, columns, nentries, & - name=trim(dcsr%name)//'Sparsity') - end if - call allocate(csr, sparsity, name=dcsr%name) - ! Drop the excess reference - call deallocate(sparsity) + if(.not.present(model)) then + sparsity = csr_sparsity_matmul(A%sparsity, B%sparsity) + call allocate(C, sparsity) + else + call allocate(C, model) + end if - rowptr=1 - do i=1,rows - csr%sparsity%findrm(i)=rowptr + C%name="matmul_"//trim(A%name)//"*"//trim(B%name) - rowlen=size(dcsr%colm(i)%ptr) + call csr_matmul_preallocated(A, B, product = C) - csr%sparsity%colm(rowptr:rowptr+rowlen-1)=dcsr%colm(i)%ptr + end function csr_matmul - csr%val(rowptr:rowptr+rowlen-1)=dcsr%val(i)%ptr + subroutine csr_matmul_preallocated(A, B, product) + !!< Perform the matrix multiplication: + !!< + !!< A*B + !!< + !!< Returns the result in the pre-allocated csr matrix product. - if (any(dcsr%colm(i)%ptr==i)) then + type(csr_matrix), intent(in) :: A + type(csr_matrix), intent(in) :: B + ! we use intent(in) here as only the value space gets changed + ! this allows eg. using block() as input + type(csr_matrix), intent(inout) :: product - rowpos=minloc(dcsr%colm(i)%ptr,mask=dcsr%colm(i)%ptr==i) + ewrite(1,*) 'Entering csr_matmul_preallocated' - csr%sparsity%centrm(i)=rowptr+rowpos(1)-1 + call zero(product) + call matmul_addto(A, B, product=product) - else -! ewrite(1,*) "Missing diagonal element" + end subroutine csr_matmul_preallocated - csr%sparsity%centrm(i)=0 - end if + subroutine csr_matmul_addto(A, B, product) + !!< Perform the matrix multiplication: + !!< + !!< C=C+A*B + !!< + !!< Returns the result in the pre-allocated csr matrix product. - rowptr = rowptr + rowlen + type(csr_matrix), intent(in) :: A + type(csr_matrix), intent(in) :: B + type(csr_matrix), intent(inout) :: product - end do + real, dimension(:), pointer:: A_i, B_k + integer, dimension(:), pointer:: rowA_i, rowB_k + integer:: i, j, k - csr%sparsity%findrm(rows+1) = rowptr + ewrite(1,*) 'Entering csr_matmul_preallocated_addto' - ! dcsr rows are sorted (by construction in dcsr_rowpos_add) - csr%sparsity%sorted_rows=.true. + assert(size(A,2)==size(B,1)) + assert(size(product,1)==size(A,1)) + assert(size(product,2)==size(B,2)) - end function dcsr2csr + ! perform C_ij=\sum_k A_ik B_kj - function csr2dcsr(csr) result (dcsr) - !!< Given a csr matrix return a dcsr matrix. The csr matrix is left - !!< untouched. - type(csr_matrix), intent(in) :: csr - type(dynamic_csr_matrix) :: dcsr + do i=1, size(A, 1) + A_i => row_val_ptr(A, i) + rowA_i => row_m_ptr(A, i) + do k=1, size(rowA_i) + B_k => row_val_ptr(B, rowA_i(k)) + rowB_k => row_m_ptr(B, rowA_i(k)) + do j=1, size(rowB_k) + call addto(product, i, rowB_k(j), A_i(k)*B_k(j)) + end do + end do + end do - integer i, j, rows, columns + end subroutine csr_matmul_addto - rows=size(csr,1) - columns=size(csr,2) + function block_csr_matmul(A, B, model) result (C) + !!< Perform the matrix multiplication: + !!< + !!< C_ij = \sum_j A_ik * B_kj + !!< + type(block_csr_matrix), intent(in) :: A, B + type(csr_sparsity), intent(in), optional :: model + type(block_csr_matrix) :: C - call allocate(dcsr, rows, columns) + type(csr_sparsity):: sparsity - do i=1,rows + ewrite(1,*) 'Entering csr_matmul' - do j=csr%sparsity%findrm(i), csr%sparsity%findrm(i+1)-1 + assert(size(A,2)==size(B,1)) + assert(blocks(A,2)==blocks(B,1)) - call set(dcsr, i, csr%sparsity%colm(j), csr%val(j)) + if(.not.present(model)) then + sparsity = csr_sparsity_matmul(A%sparsity, B%sparsity) + call allocate(C, sparsity, blocks=(/ blocks(A,1), blocks(B,2) /)) + else + call allocate(C, model, blocks=(/ blocks(A,1), blocks(B,2) /)) + end if - end do + C%name="matmul_"//trim(A%name)//"*"//trim(B%name) - end do + call block_csr_matmul_preallocated(A, B, product = C) - end function csr2dcsr + end function block_csr_matmul - subroutine csr_mult(vector_out,mat,vector_in) - !!< Multiply a csr_matrix by a vector, - !!< result is written to vector_out + subroutine block_csr_matmul_preallocated(A, B, product) + !!< Perform the matrix multiplication: + !!< + !!< A*B + !!< + !!< Returns the result in the pre-allocated csr matrix product. - !interface variables - real, dimension(:), intent(in) :: vector_in - type(csr_matrix), intent(in) :: mat - real, dimension(:), intent(out) :: vector_out + type(block_csr_matrix), intent(in) :: A + type(block_csr_matrix), intent(in) :: B + type(block_csr_matrix), intent(inout) :: product - !local variables - integer :: i, j + ewrite(1,*) 'Entering csr_matmul_preallocated' - assert(size(vector_in)==size(mat,2)) - assert(size(vector_out)==size(mat,1)) + call zero(product) + call matmul_addto(A, B, product=product) - do i = 1, size(vector_out) - vector_out(i) = 0.0 - do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 - vector_out(i) = vector_out(i) + mat%val(j) * vector_in(mat%sparsity%colm(j)) - end do - end do + end subroutine block_csr_matmul_preallocated - end subroutine csr_mult + subroutine block_csr_matmul_addto(A, B, product) + !!< Perform the matrix multiplication: + !!< + !!< C=C+A*B + !!< + !!< Returns the result in the pre-allocated csr matrix product. - subroutine csr_mult_addto(vector_out,mat,vector_in) - !!< Multiply a csr_matrix by a vector, - !!< result is added vector_out + type(block_csr_matrix), intent(in) :: A + type(block_csr_matrix), intent(in) :: B + type(block_csr_matrix), intent(inout) :: product - !interface variables - real, dimension(:), intent(in) :: vector_in - type(csr_matrix), intent(in) :: mat - real, dimension(:), intent(inout) :: vector_out + real, dimension(:), pointer:: A_i, B_k + integer, dimension(:), pointer:: rowA_i, rowB_k + integer:: blocki, blockj, blockk, i, j, k - !local variables - integer :: i, j + ewrite(1,*) 'Entering csr_matmul_preallocated_addto' - assert(size(vector_in)==size(mat,2)) - assert(size(vector_out)==size(mat,1)) + assert(size(A,2)==size(B,1)) + assert(blocks(A,2)==blocks(B,1)) + assert(size(product,1)==size(A,1)) + assert(size(product,2)==size(B,2)) + assert(blocks(product,1)==blocks(A,1)) + assert(blocks(product,2)==blocks(B,2)) - do i = 1, size(vector_out) - do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 - vector_out(i) = vector_out(i) + mat%val(j) * vector_in(mat%sparsity%colm(j)) - end do - end do + ! perform C_ij=C_ij+\sum_k A_ik B_kj - end subroutine csr_mult_addto + do blocki=1, blocks(A,1) + do blockk=1, blocks(A,2) + do blockj=1, blocks(B,2) - subroutine dcsr_mult(m,v,mv) - type(dynamic_csr_matrix), intent(in) :: m - real, dimension(:), intent(in) :: v - real, dimension(:), intent(out) :: mv - !locals - integer :: i + do i=1, size(A, 1) + A_i = row_val_ptr(A, blocki, blockk, i) + rowA_i => row_m_ptr(A, i) + do k=1, size(rowA_i) + B_k => row_val_ptr(B, blockk, blockj, rowA_i(k)) + rowB_k => row_m_ptr(B, rowA_i(k)) + do j=1, size(rowB_k) + call addto(product, i, blocki, blockj, rowB_k(j), A_i(k)*B_k(j)) + end do + end do + end do - if(size(m,1).ne.size(mv)) FLAbort('Bad vector size out.') - if(size(m,2).ne.size(v)) FLAbort('Bad vector size in.') + end do + end do + end do - mv = 0. + end subroutine block_csr_matmul_addto - do i = 1, size(mv) - mv(i) = sum(v(row_m(m,i)) * row_val_ptr(m,i)) - end do + function csr_sparsity_transpose(sparsity) result(sparsity_T) + !!< Provides the transpose of the given sparsity + type(csr_sparsity), intent(in):: sparsity + type(csr_sparsity) sparsity_T - end subroutine dcsr_mult + integer, dimension(:), allocatable:: rowlen + integer, dimension(:), pointer:: cols + integer i, j, row, col, count + logical have_diag + have_diag=associated(sparsity%centrm) - subroutine csr_mult_T(vector_out,mat,vector_in) - !!< Multiply the transpose of a csr_matrix by a vector, - !!< result is written to vector_out + ! just swap n/o rows and cols + call allocate(sparsity_T, size(sparsity,2), size(sparsity,1), & + entries=size(sparsity%colm), diag=have_diag, & + name=trim(sparsity%name)//"Transpose") - !interface variables - real, dimension(:), intent(in) :: vector_in - type(csr_matrix), intent(in) :: mat - real, dimension(:), intent(out) :: vector_out + ! Also swap the row and column halos if present. + if (associated(sparsity%row_halo)) then + allocate(sparsity_T%column_halo) + sparsity_T%column_halo=sparsity%row_halo + call incref(sparsity_T%column_halo) + end if + if (associated(sparsity%column_halo)) then + allocate(sparsity_T%row_halo) + sparsity_T%row_halo=sparsity%column_halo + call incref(sparsity_T%row_halo) + end if - !local variables - integer :: i, j, k + ! work out row lengths of the transpose + allocate( rowlen(1:size(sparsity_T,1)) ) + rowlen=0 + do i=1, size(sparsity%colm) + col=sparsity%colm(i) + if (col>0) then + rowlen(col)=rowlen(col)+1 + end if + end do - ewrite(2,*) 'size(vector_in) = ', size(vector_in) - ewrite(2,*) 'size(mat,1) = ', size(mat,1) - assert(size(vector_in)==size(mat,1)) - ewrite(2,*) 'size(vector_out) = ', size(vector_out) - ewrite(2,*) 'size(mat,2) = ', size(mat,2) - assert(size(vector_out)==size(mat,2)) + ! work out sparsity_T%findrm + count=1 + do row=1, size(sparsity_T,1) + sparsity_T%findrm(row)=count + count=count+rowlen(row) + end do + sparsity_T%findrm(row)=count - vector_out=0 - do i = 1, size(vector_in) - do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 - k = mat%sparsity%colm(j) - vector_out(k) = vector_out(k) + mat%val(j) * vector_in(i) + rowlen=0 ! use rowlen again as counter + do row=1, size(sparsity,1) + cols => row_m_ptr(sparsity, row) + do j=1, size(cols) + col=cols(j) + if (col>0) then + sparsity_T%colm(sparsity_T%findrm(col)+rowlen(col))=row + rowlen(col)=rowlen(col)+1 + end if + end do end do - end do + ! note that the above procedure inserts the entries in increasing order + sparsity_T%sorted_rows=.true. - end subroutine csr_mult_T + if (have_diag) then + do row=1, size(sparsity_T%centrm) + sparsity_T%centrm(row)=csr_sparsity_pos(sparsity_T, row, row) + end do + end if - subroutine csr_mult_T_addto(vector_out,mat,vector_in) - !!< Multiply the transpose of a csr_matrix by a vector, - !!< result is added to vector_out + end function csr_sparsity_transpose - !interface variables - real, dimension(:), intent(in) :: vector_in - type(csr_matrix), intent(in) :: mat - real, dimension(:), intent(out) :: vector_out + function block_csr_transpose(block_A, symmetric_sparsity) result (block_AT) + type(block_csr_matrix), intent(in) :: block_A + ! If the sparsity is symmetric, don't create a new one + logical, intent(in), optional :: symmetric_sparsity - !local variables - integer :: i, j, k + type(block_csr_matrix) block_AT + type(csr_matrix) :: A, AT + type(csr_sparsity):: sparsity + integer :: i, j - ewrite(2,*) 'size(vector_in) = ', size(vector_in) - ewrite(2,*) 'size(mat,1) = ', size(mat,1) - assert(size(vector_in)==size(mat,1)) - ewrite(2,*) 'size(vector_out) = ', size(vector_out) - ewrite(2,*) 'size(mat,2) = ', size(mat,2) - assert(size(vector_out)==size(mat,2)) + if (present_and_true(symmetric_sparsity)) then + call allocate(block_AT, block_A%sparsity, (/ block_A%blocks(2), block_A%blocks(1) /), name=trim(block_A%name) // "Transpose") + else + sparsity=transpose(block_A%sparsity) + call allocate(block_AT, sparsity, (/ block_A%blocks(2), block_A%blocks(1) /), name=trim(block_A%name) // "Transpose") + call deallocate(sparsity) + end if - do i = 1, size(vector_in) - do j=mat%sparsity%findrm(i), mat%sparsity%findrm(i+1)-1 - k = mat%sparsity%colm(j) - vector_out(k) = vector_out(k) + mat%val(j) * vector_in(i) + do i = 1, blocks(block_A, 1) + do j = 1, blocks(block_A, 2) + A = block(block_A, i, j) + AT = transpose(A, symmetric_sparsity=symmetric_sparsity) + call set(block_AT, j, i, AT) + call deallocate(AT) + end do end do - end do - - end subroutine csr_mult_T_addto - - subroutine dcsr_mult_T(m,v,mv) - type(dynamic_csr_matrix), intent(in) :: m - real, dimension(:), intent(in) :: v - real, dimension(:), intent(out) :: mv - !locals - integer :: i + end function block_csr_transpose - if(size(m,2).ne.size(mv)) FLAbort('Bad vector size out.') - if(size(m,1).ne.size(v)) FLAbort('Bad vector size in.') + function csr_transpose(A, symmetric_sparsity) result (AT) + !!< Provides the transpose of the given matrix + type(csr_matrix), intent(in):: A + ! If the sparsity is symmetric, don't create a new one + logical, intent(in), optional :: symmetric_sparsity + type(csr_matrix) AT - mv = 0. + type(csr_sparsity):: sparsity + integer, dimension(:), allocatable:: rowlen + integer, dimension(:), pointer:: cols + real, dimension(:), pointer:: vals + integer row, j, col - do i = 1, size(v) - mv(row_m(m,i)) = mv(row_m(m,i)) & - + v(i) * row_val_ptr(m,i) - end do - - end subroutine dcsr_mult_T - - function dcsr_matmul_T(matrix1, matrix2, model,check) result (product) - !!< Perform the matrix multiplication: - !!< - !!< matrix1*matrix2^T - !!< - type(dynamic_csr_matrix), intent(in) :: matrix1, matrix2 - type(dynamic_csr_matrix) :: product - type(dynamic_csr_matrix), intent(in), optional :: model - logical, intent(in), optional :: check - - type(integer_vector), dimension(:), allocatable :: hitlist - integer, dimension(:), allocatable :: size_hitlist - - integer, dimension(:), pointer :: row, col - integer :: i,j,k1,k2,jrow,jcol - real :: entry - logical :: addflag - logical :: l_check - real , allocatable, dimension(:) :: vec, m2Tvec, m1m2tvec, productvec - - l_check = .false. - if(present(check)) then - L_check = check - end if - - assert(size(matrix1,2)==size(matrix2,2)) - - call allocate(product, size(matrix1,1), size(matrix2,1)) - call zero(product) - - ewrite(2,*) 'Measuring structure' - - allocate( hitlist(size(matrix2,2)), size_hitlist(size(matrix2,2)) ) - - if(.not.present(model)) then - size_hitlist = 0 - - !count the number of rows of matrix2 which contain an element - !in the column - do j = 1, size(matrix2,1) - col=>matrix2%colm(j)%ptr - if(size(col)>0) then - do k1 = 1, size(col) - size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 - end do - end if - end do - - do j = 1, size(matrix1,2) - allocate( hitlist(j)%ptr(size_hitlist(j)) ) - end do - - size_hitlist = 1 - - !make a list of rows of matrix2 which contain element i in the column - do j = 1, size(matrix2,1) - col=>matrix2%colm(j)%ptr - if(size(col)>0) then - do k1 = 1, size(col) - hitlist(col(k1))%ptr(size_hitlist(col(k1))) = j - size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 - end do - end if - end do - - deallocate( size_hitlist ) - - do i=1, size(matrix1,1) - row=>matrix1%colm(i)%ptr - if(size(row)>0) then - do jrow = 1,size(row) - !need to visit all points hit by i - do jcol = 1,size(hitlist(row(jrow))%ptr) - j = hitlist(row(jrow))%ptr(jcol) - assert(j.ne.0) - col=>matrix2%colm(j)%ptr - - if(size(col)>0) then - entry=0.0 - - addflag = .false. - - k1 = 1 - k2 = 1 - do - if(addflag) exit - if((k1.gt.size(row)).or.(k2.gt.size(col))) exit - if(row(k1)matrix1%colm(i)%ptr - - if(size(row)>0) then - do jcol = 1, size(product%colm(i)%ptr) - j = product%colm(i)%ptr(jcol) - col=>matrix2%colm(j)%ptr - - if(size(col)>0) then - entry=0.0 - - addflag = .false. - - k1 = 1 - k2 = 1 - do - if((k1.gt.size(row)).or.(k2.gt.size(col))) exit - if(row(k1)abs(productvec)*1.0e-8)) then - - ewrite(2,*) maxval(abs(productvec-m1m2tvec)) - - call dcsr_matrix2file('matrix1',matrix1) - call dcsr_matrix2file('matrix2',matrix2) - call dcsr_matrix2file('product',product) - ewrite(2,*) size(matrix1,1), size(matrix1,2) - ewrite(2,*) size(matrix2,1), size(matrix2,2) - ewrite(2,*) size(product,1), size(product,2) - FLAbort('Matmul_t error.') - end if - end if - - end function dcsr_matmul_T - - function csr_matmul_T(matrix1, matrix2, model) result (product) - !!< Perform the matrix multiplication: - !!< - !!< matrix1*matrix2^T - !!< - !!< Only works on csr matrices with monotonic row entries in colm - type(csr_matrix), intent(in) :: matrix1, matrix2 - type(csr_sparsity), intent(in), optional :: model - type(csr_matrix) :: product - type(dynamic_csr_matrix) :: product_d - - type(integer_vector), dimension(:), allocatable :: hitlist - integer, dimension(:), allocatable :: size_hitlist - - integer, dimension(:), pointer :: row, col - integer :: i,j,k1,k2 - - ewrite(1,*) 'Entering csr_matmul_T' - - assert(size(matrix1,2)==size(matrix2,2)) - if(.not.matrix1%sparsity%sorted_rows.or..not.matrix2%sparsity%sorted_rows) then - FLAbort("csr_matmul_T assumes sorted rows.") - end if - - if(.not.present(model)) then - ewrite(2,*) 'Measuring structure' - - allocate( hitlist(size(matrix2,2)), size_hitlist(size(matrix2,2)) ) - size_hitlist = 0 - - !count the number of rows of matrix2 which contain an element - !in the column - do j = 1, size(matrix2,1) - col=>row_m_ptr(matrix2,j) - do k1 = 1, size(col) - size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 - end do - end do - - do j = 1, size(matrix1,2) - allocate( hitlist(j)%ptr(size_hitlist(j)) ) - end do - - size_hitlist = 1 - - !make a list of rows of matrix2 which contain element i in the column - do j = 1, size(matrix2,1) - col=>row_m_ptr(matrix2,j) - if(size(col)>0) then - do k1 = 1, size(col) - hitlist(col(k1))%ptr(size_hitlist(col(k1))) = j - size_hitlist(col(k1)) = size_hitlist(col(k1)) + 1 - end do - end if - end do - - deallocate( size_hitlist ) - - call allocate(product_d, size(matrix1,1), size(matrix2,1)) - do i=1, size(matrix1,1) - row=>row_m_ptr(matrix1, i) - do k1 = 1,size(row) - do k2 = 1,size(hitlist(row(k1))%ptr) - call addto(product_d,i,hitlist(row(k1))%ptr(k2),0.0) - end do - end do - end do - - deallocate( hitlist ) - - product = dcsr2csr(product_d) - call deallocate( product_d) - else - call allocate(product, model) - end if - - product%name="matmul_T"//trim(matrix1%name)//"*"//trim(matrix2%name) - - call csr_matmul_t_preallocated& - (matrix1, matrix2, product = product, set_sparsity = .not. present(model)) - - end function csr_matmul_T - - subroutine csr_matmul_t_preallocated(matrix1, matrix2, product, set_sparsity) - !!< Perform the matrix multiplication: - !!< - !!< matrix1*matrix2^T - !!< - !!< Only works on csr matrices with monotonic row entries in colm. Returns - !!< the result in the pre-allocated csr matrix product. - - type(csr_matrix), intent(in) :: matrix1 - type(csr_matrix), intent(in) :: matrix2 - type(csr_matrix), intent(inout) :: product - !! If present and .true., set the product sparsity as well as performing - !! the product - logical, optional, intent(in) :: set_sparsity - - integer, dimension(:), pointer :: row, col, row_product - real, dimension(:), pointer :: row_val, col_val - integer :: i,j,k1,k2,jcol - real :: entry0 - integer :: nentry0 - logical :: addflag, lset_sparsity - - lset_sparsity = present_and_true(set_sparsity) - - ewrite(2,*) 'adding in data' - - assert(size(matrix1,2)==size(matrix2,2)) - if(.not.matrix1%sparsity%sorted_rows.or..not.matrix2%sparsity%sorted_rows) then - FLAbort("csr_matmul_T assumes sorted rows.") - end if - - call zero(product) - - nentry0 = 0 - - do i=1, size(matrix1,1) - row=>row_m_ptr(matrix1, i) - row_val=>row_val_ptr(matrix1, i) - - if(size(row)>0) then - row_product=>row_m_ptr(product, i) - do jcol = 1, size(row_product) - j = row_product(jcol) - - col=>row_m_ptr(matrix2, j) - col_val=>row_val_ptr(matrix2, j) - - if(size(col)>0) then - entry0=0.0 - - addflag = .false. - - k1 = 1 - k2 = 1 - do - if((k1.gt.size(row)).or.(k2.gt.size(col))) exit - if(row(k1) row_m_ptr(A, i) - call allocate(iset) - do k=1, size(rowA_i) - rowB_k => row_m_ptr(B, rowA_i(k)) - call insert(iset, rowB_k) - end do - nnz(i)=key_count(iset) - call deallocate(iset) - - end do - - ! the sparsity for C - call allocate(C, size(A,1), size(B,2), nnz=nnz, & - name="matmul_"//trim(A%name)//"*"//trim(B%name)) - - ! same thing, now actually filling in the column indices in the rows of C - do i=1, size(A, 1) - rowA_i => row_m_ptr(A, i) - rowC_i => row_m_ptr(C, i) - call allocate(iset) - do k=1, size(rowA_i) - rowB_k => row_m_ptr(B, rowA_i(k)) - call insert(iset, rowB_k) - end do - assert(key_count(iset)==size(rowC_i)) - rowC_i=set2vector(iset) - call deallocate(iset) - end do - - end function csr_sparsity_matmul - - function csr_matmul(A, B, model) result (C) - !!< Perform the matrix multiplication: - !!< - !!< C_ij = \sum_j A_ik * B_kj - !!< - type(csr_matrix), intent(in) :: A, B - type(csr_sparsity), intent(in), optional :: model - type(csr_matrix) :: C - - type(csr_sparsity):: sparsity - - ewrite(1,*) 'Entering csr_matmul' - - assert(size(A,2)==size(B,1)) - - if(.not.present(model)) then - sparsity = csr_sparsity_matmul(A%sparsity, B%sparsity) - call allocate(C, sparsity) - else - call allocate(C, model) - end if - - C%name="matmul_"//trim(A%name)//"*"//trim(B%name) - - call csr_matmul_preallocated(A, B, product = C) - - end function csr_matmul - - subroutine csr_matmul_preallocated(A, B, product) - !!< Perform the matrix multiplication: - !!< - !!< A*B - !!< - !!< Returns the result in the pre-allocated csr matrix product. - - type(csr_matrix), intent(in) :: A - type(csr_matrix), intent(in) :: B - ! we use intent(in) here as only the value space gets changed - ! this allows eg. using block() as input - type(csr_matrix), intent(inout) :: product - - ewrite(1,*) 'Entering csr_matmul_preallocated' - - call zero(product) - call matmul_addto(A, B, product=product) - - end subroutine csr_matmul_preallocated - - subroutine csr_matmul_addto(A, B, product) - !!< Perform the matrix multiplication: - !!< - !!< C=C+A*B - !!< - !!< Returns the result in the pre-allocated csr matrix product. - - type(csr_matrix), intent(in) :: A - type(csr_matrix), intent(in) :: B - type(csr_matrix), intent(inout) :: product - - real, dimension(:), pointer:: A_i, B_k - integer, dimension(:), pointer:: rowA_i, rowB_k - integer:: i, j, k - - ewrite(1,*) 'Entering csr_matmul_preallocated_addto' - - assert(size(A,2)==size(B,1)) - assert(size(product,1)==size(A,1)) - assert(size(product,2)==size(B,2)) - - ! perform C_ij=\sum_k A_ik B_kj - - do i=1, size(A, 1) - A_i => row_val_ptr(A, i) - rowA_i => row_m_ptr(A, i) - do k=1, size(rowA_i) - B_k => row_val_ptr(B, rowA_i(k)) - rowB_k => row_m_ptr(B, rowA_i(k)) - do j=1, size(rowB_k) - call addto(product, i, rowB_k(j), A_i(k)*B_k(j)) - end do - end do - end do - - end subroutine csr_matmul_addto - - function block_csr_matmul(A, B, model) result (C) - !!< Perform the matrix multiplication: - !!< - !!< C_ij = \sum_j A_ik * B_kj - !!< - type(block_csr_matrix), intent(in) :: A, B - type(csr_sparsity), intent(in), optional :: model - type(block_csr_matrix) :: C - - type(csr_sparsity):: sparsity + if (present_and_true(symmetric_sparsity) .and. .not. A%sparsity%sorted_rows) then + FLAbort("csr_tranpose on symmetric sparsities works only with sorted_rows.") + end if - ewrite(1,*) 'Entering csr_matmul' +#ifdef DDEBUG + ! Check that the supplied sparsity is indeed symmetric + if (present_and_true(symmetric_sparsity)) then + if (.not. is_symmetric(A%sparsity)) then + FLAbort("The symmetric flag is supplied, but the sparsity is not symmetric.") + end if + end if +#endif - assert(size(A,2)==size(B,1)) - assert(blocks(A,2)==blocks(B,1)) - - if(.not.present(model)) then - sparsity = csr_sparsity_matmul(A%sparsity, B%sparsity) - call allocate(C, sparsity, blocks=(/ blocks(A,1), blocks(B,2) /)) - else - call allocate(C, model, blocks=(/ blocks(A,1), blocks(B,2) /)) - end if + if (present_and_true(symmetric_sparsity)) then + call allocate(AT, A%sparsity, name=trim(A%name) // "Transpose") + else + sparsity=transpose(A%sparsity) + call allocate(AT, sparsity, name=trim(A%name) // "Transpose") + call deallocate(sparsity) + end if - C%name="matmul_"//trim(A%name)//"*"//trim(B%name) + ! we use the same insertion procedure as above in csr_sparsity_transpose + ! rowlen is used to count the number of inserted entries thus far per row + allocate( rowlen(1:size(AT,1)) ) + rowlen=0 + do row=1, size(A,1) + cols => row_m_ptr(A, row) + vals => row_val_ptr(A, row) + do j=1, size(cols) + col=cols(j) + if (col>0) then + AT%val(AT%sparsity%findrm(col)+rowlen(col))=vals(j) + ! check that this is indeed the right column: + assert(AT%sparsity%colm(AT%sparsity%findrm(col)+rowlen(col))==row) + rowlen(col)=rowlen(col)+1 + else if (present_and_true(symmetric_sparsity)) then + FLAbort("Found a zero entry in the colm of the given sparsity which is currently not supported if the symmetric flag.") + end if + end do + end do - call block_csr_matmul_preallocated(A, B, product = C) + end function csr_transpose - end function block_csr_matmul + subroutine sparsity_sort(sparsity) + !!< In-place sort of the rows of the given sparsity to increasing column index + !!< Only for internal usage within sparsity creating routines. Should not be + !!< called after any matrix has been based upon it. + type(csr_sparsity), intent(inout):: sparsity - subroutine block_csr_matmul_preallocated(A, B, product) - !!< Perform the matrix multiplication: - !!< - !!< A*B - !!< - !!< Returns the result in the pre-allocated csr matrix product. + integer, dimension(:), pointer:: cols + integer i, j, col + logical sorted - type(block_csr_matrix), intent(in) :: A - type(block_csr_matrix), intent(in) :: B - type(block_csr_matrix), intent(inout) :: product - - ewrite(1,*) 'Entering csr_matmul_preallocated' - - call zero(product) - call matmul_addto(A, B, product=product) - - end subroutine block_csr_matmul_preallocated - - subroutine block_csr_matmul_addto(A, B, product) - !!< Perform the matrix multiplication: - !!< - !!< C=C+A*B - !!< - !!< Returns the result in the pre-allocated csr matrix product. + if (associated(sparsity%refcount)) then + if (sparsity%refcount%count>1) then + ewrite(-1,*) "For health and safety reasons sparsities should not" + FLAbort("be sorted after they are referenced.") + end if + end if - type(block_csr_matrix), intent(in) :: A - type(block_csr_matrix), intent(in) :: B - type(block_csr_matrix), intent(inout) :: product + do i=1, size(sparsity,1) + cols => row_m_ptr(sparsity, i) + ! hurray for the bubble sort + do + sorted=.true. ! let's be optimistic + do j=1, size(cols)-1 + if (cols(j)>cols(j+1)) then + col=cols(j) + cols(j)=cols(j+1) + cols(j+1)=col + sorted=.false. ! not quite there yet + end if + end do + if (sorted) exit + end do + end do - real, dimension(:), pointer:: A_i, B_k - integer, dimension(:), pointer:: rowA_i, rowB_k - integer:: blocki, blockj, blockk, i, j, k - - ewrite(1,*) 'Entering csr_matmul_preallocated_addto' - - assert(size(A,2)==size(B,1)) - assert(blocks(A,2)==blocks(B,1)) - assert(size(product,1)==size(A,1)) - assert(size(product,2)==size(B,2)) - assert(blocks(product,1)==blocks(A,1)) - assert(blocks(product,2)==blocks(B,2)) - - ! perform C_ij=C_ij+\sum_k A_ik B_kj + sparsity%sorted_rows=.true. - do blocki=1, blocks(A,1) - do blockk=1, blocks(A,2) - do blockj=1, blocks(B,2) + end subroutine sparsity_sort + function sparsity_is_symmetric(sparsity) result(symmetric) + !!< Checks if the given sparsity is symmetric + type(csr_sparsity), intent(in):: sparsity - do i=1, size(A, 1) - A_i = row_val_ptr(A, blocki, blockk, i) - rowA_i => row_m_ptr(A, i) - do k=1, size(rowA_i) - B_k => row_val_ptr(B, blockk, blockj, rowA_i(k)) - rowB_k => row_m_ptr(B, rowA_i(k)) - do j=1, size(rowB_k) - call addto(product, i, blocki, blockj, rowB_k(j), A_i(k)*B_k(j)) - end do - end do - end do - - end do - end do - end do - - end subroutine block_csr_matmul_addto - - function csr_sparsity_transpose(sparsity) result(sparsity_T) - !!< Provides the transpose of the given sparsity - type(csr_sparsity), intent(in):: sparsity - type(csr_sparsity) sparsity_T - - integer, dimension(:), allocatable:: rowlen - integer, dimension(:), pointer:: cols - integer i, j, row, col, count - logical have_diag - - have_diag=associated(sparsity%centrm) - - ! just swap n/o rows and cols - call allocate(sparsity_T, size(sparsity,2), size(sparsity,1), & - entries=size(sparsity%colm), diag=have_diag, & - name=trim(sparsity%name)//"Transpose") - - ! Also swap the row and column halos if present. - if (associated(sparsity%row_halo)) then - allocate(sparsity_T%column_halo) - sparsity_T%column_halo=sparsity%row_halo - call incref(sparsity_T%column_halo) - end if - if (associated(sparsity%column_halo)) then - allocate(sparsity_T%row_halo) - sparsity_T%row_halo=sparsity%column_halo - call incref(sparsity_T%row_halo) - end if - - ! work out row lengths of the transpose - allocate( rowlen(1:size(sparsity_T,1)) ) - rowlen=0 - do i=1, size(sparsity%colm) - col=sparsity%colm(i) - if (col>0) then - rowlen(col)=rowlen(col)+1 - end if - end do - - ! work out sparsity_T%findrm - count=1 - do row=1, size(sparsity_T,1) - sparsity_T%findrm(row)=count - count=count+rowlen(row) - end do - sparsity_T%findrm(row)=count - - rowlen=0 ! use rowlen again as counter - do row=1, size(sparsity,1) - cols => row_m_ptr(sparsity, row) - do j=1, size(cols) - col=cols(j) - if (col>0) then - sparsity_T%colm(sparsity_T%findrm(col)+rowlen(col))=row - rowlen(col)=rowlen(col)+1 - end if - end do - end do - ! note that the above procedure inserts the entries in increasing order - sparsity_T%sorted_rows=.true. + integer, dimension(:), pointer :: cols, colsT + integer :: row, col + logical :: symmetric - if (have_diag) then - do row=1, size(sparsity_T%centrm) - sparsity_T%centrm(row)=csr_sparsity_pos(sparsity_T, row, row) + if (.not. size(sparsity,1) == size(sparsity,2)) then + ! The dimensions dont even match + symmetric = .false. + return + end if + symmetric = .true. + do row=1, size(sparsity,1) + cols => row_m_ptr(sparsity, row) + do col=1, size(cols) + colsT => row_m_ptr(sparsity, cols(col)) + if (.not. any(colsT==row)) then + ! There is a nonzero entry in row X cols(col), + ! but not at cols(col) X row + symmetric = .false. + return + end if + end do end do - end if - end function csr_sparsity_transpose + end function sparsity_is_symmetric - function block_csr_transpose(block_A, symmetric_sparsity) result (block_AT) - type(block_csr_matrix), intent(in) :: block_A - ! If the sparsity is symmetric, don't create a new one - logical, intent(in), optional :: symmetric_sparsity + function sparsity_is_sorted(sparsity) result(sorted) + !!< Checks if the rows of the given sparsity is sorted to increasing column index + type(csr_sparsity), intent(in):: sparsity - type(block_csr_matrix) block_AT - type(csr_matrix) :: A, AT - type(csr_sparsity):: sparsity - integer :: i, j + integer, dimension(:), pointer:: cols + integer i, j + logical sorted - if (present_and_true(symmetric_sparsity)) then - call allocate(block_AT, block_A%sparsity, (/ block_A%blocks(2), block_A%blocks(1) /), name=trim(block_A%name) // "Transpose") - else - sparsity=transpose(block_A%sparsity) - call allocate(block_AT, sparsity, (/ block_A%blocks(2), block_A%blocks(1) /), name=trim(block_A%name) // "Transpose") - call deallocate(sparsity) - end if - - do i = 1, blocks(block_A, 1) - do j = 1, blocks(block_A, 2) - A = block(block_A, i, j) - AT = transpose(A, symmetric_sparsity=symmetric_sparsity) - call set(block_AT, j, i, AT) - call deallocate(AT) + do i=1, size(sparsity,1) + cols => row_m_ptr(sparsity, i) + do j=1, size(cols)-1 + if (cols(j)>cols(j+1)) then + sorted=.false. + return + end if + end do end do - end do - end function block_csr_transpose + sorted=.true. + end function sparsity_is_sorted - function csr_transpose(A, symmetric_sparsity) result (AT) - !!< Provides the transpose of the given matrix - type(csr_matrix), intent(in):: A - ! If the sparsity is symmetric, don't create a new one - logical, intent(in), optional :: symmetric_sparsity - type(csr_matrix) AT + function sparsity_merge(sparsityA, sparsityB, name) result (sparsityC) + !!< Merges sparsityA and sparsityB such that: + !!< all (i,j) in either sparsityA or sparsityB are in sparsityC + type(csr_sparsity), intent(in):: sparsityA, sparsityB + character(len=*), optional, intent(in):: name - type(csr_sparsity):: sparsity - integer, dimension(:), allocatable:: rowlen - integer, dimension(:), pointer:: cols - real, dimension(:), pointer:: vals - integer row, j, col + type(csr_sparsity) sparsityC + integer, dimension(:), allocatable:: colm, findrm + integer, dimension(:), pointer:: colsA, colsB + integer i, k, k1, k2, colA, colB, count + logical have_diag - if (present_and_true(symmetric_sparsity) .and. .not. A%sparsity%sorted_rows) then - FLAbort("csr_tranpose on symmetric sparsities works only with sorted_rows.") - end if - -#ifdef DDEBUG - ! Check that the supplied sparsity is indeed symmetric - if (present_and_true(symmetric_sparsity)) then - if (.not. is_symmetric(A%sparsity)) then - FLAbort("The symmetric flag is supplied, but the sparsity is not symmetric.") + if(.not.sparsityA%sorted_rows.or..not.sparsityB%sorted_rows) then + FLAbort("sparsity_merge assumes sorted rows.") end if - end if -#endif - if (present_and_true(symmetric_sparsity)) then - call allocate(AT, A%sparsity, name=trim(A%name) // "Transpose") - else - sparsity=transpose(A%sparsity) - call allocate(AT, sparsity, name=trim(A%name) // "Transpose") - call deallocate(sparsity) - end if - - ! we use the same insertion procedure as above in csr_sparsity_transpose - ! rowlen is used to count the number of inserted entries thus far per row - allocate( rowlen(1:size(AT,1)) ) - rowlen=0 - do row=1, size(A,1) - cols => row_m_ptr(A, row) - vals => row_val_ptr(A, row) - do j=1, size(cols) - col=cols(j) - if (col>0) then - AT%val(AT%sparsity%findrm(col)+rowlen(col))=vals(j) - ! check that this is indeed the right column: - assert(AT%sparsity%colm(AT%sparsity%findrm(col)+rowlen(col))==row) - rowlen(col)=rowlen(col)+1 - else if (present_and_true(symmetric_sparsity)) then - FLAbort("Found a zero entry in the colm of the given sparsity which is currently not supported if the symmetric flag.") - end if - end do - end do - - end function csr_transpose - - subroutine sparsity_sort(sparsity) - !!< In-place sort of the rows of the given sparsity to increasing column index - !!< Only for internal usage within sparsity creating routines. Should not be - !!< called after any matrix has been based upon it. - type(csr_sparsity), intent(inout):: sparsity - - integer, dimension(:), pointer:: cols - integer i, j, col - logical sorted - - if (associated(sparsity%refcount)) then - if (sparsity%refcount%count>1) then - ewrite(-1,*) "For health and safety reasons sparsities should not" - FLAbort("be sorted after they are referenced.") - end if - end if - - do i=1, size(sparsity,1) - cols => row_m_ptr(sparsity, i) - ! hurray for the bubble sort - do - sorted=.true. ! let's be optimistic - do j=1, size(cols)-1 - if (cols(j)>cols(j+1)) then - col=cols(j) - cols(j)=cols(j+1) - cols(j+1)=col - sorted=.false. ! not quite there yet - end if - end do - if (sorted) exit - end do - end do - - sparsity%sorted_rows=.true. - - end subroutine sparsity_sort - - function sparsity_is_symmetric(sparsity) result(symmetric) - !!< Checks if the given sparsity is symmetric - type(csr_sparsity), intent(in):: sparsity - - integer, dimension(:), pointer :: cols, colsT - integer :: row, col - logical :: symmetric - - if (.not. size(sparsity,1) == size(sparsity,2)) then - ! The dimensions dont even match - symmetric = .false. - return - end if - symmetric = .true. - do row=1, size(sparsity,1) - cols => row_m_ptr(sparsity, row) - do col=1, size(cols) - colsT => row_m_ptr(sparsity, cols(col)) - if (.not. any(colsT==row)) then - ! There is a nonzero entry in row X cols(col), - ! but not at cols(col) X row - symmetric = .false. - return - end if - end do - end do - - end function sparsity_is_symmetric - - function sparsity_is_sorted(sparsity) result(sorted) - !!< Checks if the rows of the given sparsity is sorted to increasing column index - type(csr_sparsity), intent(in):: sparsity - - integer, dimension(:), pointer:: cols - integer i, j - logical sorted - - do i=1, size(sparsity,1) - cols => row_m_ptr(sparsity, i) - do j=1, size(cols)-1 - if (cols(j)>cols(j+1)) then - sorted=.false. - return - end if - end do - end do - - sorted=.true. - end function sparsity_is_sorted - - function sparsity_merge(sparsityA, sparsityB, name) result (sparsityC) - !!< Merges sparsityA and sparsityB such that: - !!< all (i,j) in either sparsityA or sparsityB are in sparsityC - type(csr_sparsity), intent(in):: sparsityA, sparsityB - character(len=*), optional, intent(in):: name - - type(csr_sparsity) sparsityC - integer, dimension(:), allocatable:: colm, findrm - integer, dimension(:), pointer:: colsA, colsB - integer i, k, k1, k2, colA, colB, count - logical have_diag - - if(.not.sparsityA%sorted_rows.or..not.sparsityB%sorted_rows) then - FLAbort("sparsity_merge assumes sorted rows.") - end if - - assert( size(sparsityA,1)==size(sparsityB,1) ) - - ! allocate oversized, temp. sparsity: - allocate( colm(1:size(sparsityA%colm)+size(sparsityB)), & - findrm(1:size(sparsityA,1)+1) ) - count=0 - do i=1, size(sparsityA,1) - findrm(i)=count+1 - colsA => row_m_ptr(sparsityA, i) - colsB => row_m_ptr(sparsityB, i) - k1=1 - k2=1 - if (k1<=size(colsA)) then - colA=colsA(k1) - if (k2<=size(colsB)) then - colB=colsB(k2) - ! this loop only if both rows are nonzero - do - count=count+1 - if (colAsize(colsA)) exit - colA=colsA(k1) - else if (colA>colB) then - colm(count)=colB - k2=k2+1 - if (k2>size(colsB)) exit + assert( size(sparsityA,1)==size(sparsityB,1) ) + + ! allocate oversized, temp. sparsity: + allocate( colm(1:size(sparsityA%colm)+size(sparsityB)), & + findrm(1:size(sparsityA,1)+1) ) + count=0 + do i=1, size(sparsityA,1) + findrm(i)=count+1 + colsA => row_m_ptr(sparsityA, i) + colsB => row_m_ptr(sparsityB, i) + k1=1 + k2=1 + if (k1<=size(colsA)) then + colA=colsA(k1) + if (k2<=size(colsB)) then colB=colsB(k2) - else - ! colA==colB - colm(count)=colA - k1=k1+1 - k2=k2+1 - if (k1>size(colsA) .or. k2>size(colsB)) exit - colA=colsA(k1) - colB=colsB(k2) - end if - end do + ! this loop only if both rows are nonzero + do + count=count+1 + if (colAsize(colsA)) exit + colA=colsA(k1) + else if (colA>colB) then + colm(count)=colB + k2=k2+1 + if (k2>size(colsB)) exit + colB=colsB(k2) + else + ! colA==colB + colm(count)=colA + k1=k1+1 + k2=k2+1 + if (k1>size(colsA) .or. k2>size(colsB)) exit + colA=colsA(k1) + colB=colsB(k2) + end if + end do + end if end if - end if - ! now copy the left over bits from either colsA or colsB - do k=k1, size(colsA) - count=count+1 - colm(count)=colsA(k) - end do - do k=k2, size(colsB) - count=count+1 - colm(count)=colsB(k) - end do - end do - findrm(i)=count+1 - - have_diag=associated(sparsityA%centrm) .or. associated(sparsityB%centrm) - call allocate(sparsityC, size(sparsityA,1), & - max(size(sparsityA,2), size(sparsityB,2)), & - entries=count, diag=have_diag, name=name) - sparsityC%findrm=findrm - sparsityC%colm=colm(1:count) - - if (have_diag) then - do i=1, size(sparsityC,1) - sparsityC%centrm(i)=csr_sparsity_pos(sparsityC, i, i) + ! now copy the left over bits from either colsA or colsB + do k=k1, size(colsA) + count=count+1 + colm(count)=colsA(k) + end do + do k=k2, size(colsB) + count=count+1 + colm(count)=colsB(k) + end do end do - end if + findrm(i)=count+1 + + have_diag=associated(sparsityA%centrm) .or. associated(sparsityB%centrm) + call allocate(sparsityC, size(sparsityA,1), & + max(size(sparsityA,2), size(sparsityB,2)), & + entries=count, diag=have_diag, name=name) + sparsityC%findrm=findrm + sparsityC%colm=colm(1:count) + + if (have_diag) then + do i=1, size(sparsityC,1) + sparsityC%centrm(i)=csr_sparsity_pos(sparsityC, i, i) + end do + end if - sparsityC%sorted_rows=.true. + sparsityC%sorted_rows=.true. - end function sparsity_merge + end function sparsity_merge - subroutine csr_matrix2file(filename, matrix) - !!< Write the dense form of matrix to filename. - !!< - !!< WARNING! - The dense form of a sparse matrix can get bloody big. - character(len=*), intent(in) :: filename - type(csr_matrix), intent(in) :: matrix + subroutine csr_matrix2file(filename, matrix) + !!< Write the dense form of matrix to filename. + !!< + !!< WARNING! - The dense form of a sparse matrix can get bloody big. + character(len=*), intent(in) :: filename + type(csr_matrix), intent(in) :: matrix - character(len=42) :: format - integer :: unit + character(len=42) :: format + integer :: unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - ! Construct the correct format for a matrix row. - write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" - write(unit, format) transpose(dense(matrix)) + ! Construct the correct format for a matrix row. + write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" + write(unit, format) transpose(dense(matrix)) - close(unit) + close(unit) - end subroutine csr_matrix2file + end subroutine csr_matrix2file - subroutine block_csr_matrix2file(filename, matrix) - !!< Write the dense form of matrix to filename. - !!< - !!< WARNING! - The dense form of a sparse matrix can get bloody big. - character(len=*), intent(in) :: filename - type(block_csr_matrix), intent(in) :: matrix + subroutine block_csr_matrix2file(filename, matrix) + !!< Write the dense form of matrix to filename. + !!< + !!< WARNING! - The dense form of a sparse matrix can get bloody big. + character(len=*), intent(in) :: filename + type(block_csr_matrix), intent(in) :: matrix - character(len=42) :: format - integer :: unit + character(len=42) :: format + integer :: unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - ! Construct the correct format for a matrix row. - write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" - write(unit, format) transpose(dense(matrix)) + ! Construct the correct format for a matrix row. + write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" + write(unit, format) transpose(dense(matrix)) - close(unit) + close(unit) - end subroutine block_csr_matrix2file + end subroutine block_csr_matrix2file - subroutine dcsr_matrix2file(filename, matrix) - !!< Write the dense form of matrix to filename. - !!< - !!< WARNING! - The dense form of a sparse matrix can get bloody big. - character(len=*), intent(in) :: filename - type(dynamic_csr_matrix), intent(in) :: matrix + subroutine dcsr_matrix2file(filename, matrix) + !!< Write the dense form of matrix to filename. + !!< + !!< WARNING! - The dense form of a sparse matrix can get bloody big. + character(len=*), intent(in) :: filename + type(dynamic_csr_matrix), intent(in) :: matrix - character(len=42) :: format - integer :: unit + character(len=42) :: format + integer :: unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - ! Construct the correct format for a matrix row. - write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" - write(unit, format) transpose(dense(matrix)) + ! Construct the correct format for a matrix row. + write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" + write(unit, format) transpose(dense(matrix)) - close(unit) + close(unit) - end subroutine dcsr_matrix2file + end subroutine dcsr_matrix2file - subroutine block_dcsr_matrix2file(filename, matrix) - !!< Write the dense form of matrix to filename. - !!< - !!< WARNING! - The dense form of a sparse matrix can get bloody big. - character(len=*), intent(in) :: filename - type(block_dynamic_csr_matrix), intent(in) :: matrix + subroutine block_dcsr_matrix2file(filename, matrix) + !!< Write the dense form of matrix to filename. + !!< + !!< WARNING! - The dense form of a sparse matrix can get bloody big. + character(len=*), intent(in) :: filename + type(block_dynamic_csr_matrix), intent(in) :: matrix - character(len=42) :: format - integer :: unit + character(len=42) :: format + integer :: unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - ! Construct the correct format for a matrix row. - write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" - write(unit, format) transpose(dense(matrix)) + ! Construct the correct format for a matrix row. + write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" + write(unit, format) transpose(dense(matrix)) - close(unit) + close(unit) - end subroutine block_dcsr_matrix2file + end subroutine block_dcsr_matrix2file - subroutine dense_matrix2file(filename, matrix) - !!< Write matrix to filename. - character(len=*), intent(in) :: filename - real, dimension(:,:), intent(in) :: matrix + subroutine dense_matrix2file(filename, matrix) + !!< Write matrix to filename. + character(len=*), intent(in) :: filename + real, dimension(:,:), intent(in) :: matrix - character(len=42) :: format - integer :: unit + character(len=42) :: format + integer :: unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - ! Construct the correct format for a matrix row. - write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" - write(unit, format) transpose(matrix) + ! Construct the correct format for a matrix row. + write(format,'(a,i0,a)')"(",size(matrix,2),"g22.8e4)" + write(unit, format) transpose(matrix) - close(unit) + close(unit) - end subroutine dense_matrix2file + end subroutine dense_matrix2file - ! I/O routines to read/write matrices in MatrixMarket format - ! from http://math.nist.gov/MatrixMarket/formats.html: - !----------------------------------------------------------------------------------- - ! %%MatrixMarket matrix coordinate real general - ! %================================================================================= - ! % - ! % This ASCII file represents a sparse MxN matrix with L - ! % nonzeros in the following Matrix Market format: - ! % - ! % +----------------------------------------------+ - ! % |%%MatrixMarket matrix coordinate real general | <--- header line - ! % |% | <--+ - ! % |% comments | |-- 0 or more comment lines - ! % |% | <--+ - ! % | M N L | <--- rows, columns, entries - ! % | I1 J1 A(I1, J1) | <--+ - ! % | I2 J2 A(I2, J2) | | - ! % | I3 J3 A(I3, J3) | |-- L lines - ! % | . . . | | - ! % | IL JL A(IL, JL) | <--+ - ! % +----------------------------------------------+ - ! % - ! % Indices are 1-based, i.e. A(1,1) is the first element. - ! % - ! %================================================================================= - ! 5 5 8 - ! 1 1 1.000e+00 - ! 2 2 1.050e+01 - ! 3 3 1.500e-02 - ! 1 4 6.000e+00 - ! 4 2 2.505e+02 - ! 4 4 -2.800e+02 - ! 4 5 3.332e+01 - ! 5 5 1.200e+01 - ! - !----------------------------------------------------------------------------------- - - subroutine csr_mmwrite(filename, matrix) - character(len=*), intent(in) :: filename - type(csr_matrix), intent(in) :: matrix - - real, dimension(:), pointer:: vals - integer, dimension(:), pointer:: cols - integer i, j, unit - - unit=free_unit() - - open(unit=unit, file=filename, action="write") - - ! this will include a leading blank that we will overwrite in the end. - write(unit, *) "%MatrixMarket matrix coordinate real general" - - write(unit, *) size(matrix,1), size(matrix, 2), entries(matrix) - - do i=1, size(matrix,1) - cols => row_m_ptr(matrix, i) - vals => row_val_ptr(matrix, i) - do j=1, size(cols) - write(unit, *) i, cols(j), vals(j) + ! I/O routines to read/write matrices in MatrixMarket format + ! from http://math.nist.gov/MatrixMarket/formats.html: + !----------------------------------------------------------------------------------- + ! %%MatrixMarket matrix coordinate real general + ! %================================================================================= + ! % + ! % This ASCII file represents a sparse MxN matrix with L + ! % nonzeros in the following Matrix Market format: + ! % + ! % +----------------------------------------------+ + ! % |%%MatrixMarket matrix coordinate real general | <--- header line + ! % |% | <--+ + ! % |% comments | |-- 0 or more comment lines + ! % |% | <--+ + ! % | M N L | <--- rows, columns, entries + ! % | I1 J1 A(I1, J1) | <--+ + ! % | I2 J2 A(I2, J2) | | + ! % | I3 J3 A(I3, J3) | |-- L lines + ! % | . . . | | + ! % | IL JL A(IL, JL) | <--+ + ! % +----------------------------------------------+ + ! % + ! % Indices are 1-based, i.e. A(1,1) is the first element. + ! % + ! %================================================================================= + ! 5 5 8 + ! 1 1 1.000e+00 + ! 2 2 1.050e+01 + ! 3 3 1.500e-02 + ! 1 4 6.000e+00 + ! 4 2 2.505e+02 + ! 4 4 -2.800e+02 + ! 4 5 3.332e+01 + ! 5 5 1.200e+01 + ! + !----------------------------------------------------------------------------------- + + subroutine csr_mmwrite(filename, matrix) + character(len=*), intent(in) :: filename + type(csr_matrix), intent(in) :: matrix + + real, dimension(:), pointer:: vals + integer, dimension(:), pointer:: cols + integer i, j, unit + + unit=free_unit() + + open(unit=unit, file=filename, action="write") + + ! this will include a leading blank that we will overwrite in the end. + write(unit, *) "%MatrixMarket matrix coordinate real general" + + write(unit, *) size(matrix,1), size(matrix, 2), entries(matrix) + + do i=1, size(matrix,1) + cols => row_m_ptr(matrix, i) + vals => row_val_ptr(matrix, i) + do j=1, size(cols) + write(unit, *) i, cols(j), vals(j) + end do end do - end do - close(unit) + close(unit) - ! overwrite leading blank with % - open(unit=unit, file=filename, access='direct', form='formatted', recl=1, & - action='write') - write(unit, '(a1)', rec=1) '%' - close(unit) + ! overwrite leading blank with % + open(unit=unit, file=filename, access='direct', form='formatted', recl=1, & + action='write') + write(unit, '(a1)', rec=1) '%' + close(unit) - end subroutine csr_mmwrite + end subroutine csr_mmwrite - subroutine dcsr_mmwrite(filename, matrix) - character(len=*), intent(in) :: filename - type(dynamic_csr_matrix), intent(in) :: matrix + subroutine dcsr_mmwrite(filename, matrix) + character(len=*), intent(in) :: filename + type(dynamic_csr_matrix), intent(in) :: matrix - real, dimension(:), pointer:: vals - integer, dimension(:), pointer:: cols - integer i, j, unit + real, dimension(:), pointer:: vals + integer, dimension(:), pointer:: cols + integer i, j, unit - unit=free_unit() + unit=free_unit() - open(unit=unit, file=filename, action="write") + open(unit=unit, file=filename, action="write") - ! write header line - ! this will include a leading blank that we will overwrite in the end. - write(unit, *) "%MatrixMarket matrix coordinate real general" + ! write header line + ! this will include a leading blank that we will overwrite in the end. + write(unit, *) "%MatrixMarket matrix coordinate real general" - write(unit, *) size(matrix,1), size(matrix, 2), entries(matrix) + write(unit, *) size(matrix,1), size(matrix, 2), entries(matrix) - do i=1, size(matrix,1) - cols => row_m_ptr(matrix, i) - vals => row_val_ptr(matrix, i) - do j=1, size(cols) - write(unit, *) i, cols(j), vals(j) + do i=1, size(matrix,1) + cols => row_m_ptr(matrix, i) + vals => row_val_ptr(matrix, i) + do j=1, size(cols) + write(unit, *) i, cols(j), vals(j) + end do end do - end do - close(unit) + close(unit) - ! overwrite leading blank with % - open(unit=unit, file=filename, access='direct', form='formatted', recl=1, & - action='write') - write(unit, '(a1)', rec=1) '%' - close(unit) + ! overwrite leading blank with % + open(unit=unit, file=filename, access='direct', form='formatted', recl=1, & + action='write') + write(unit, '(a1)', rec=1) '%' + close(unit) - end subroutine dcsr_mmwrite + end subroutine dcsr_mmwrite - subroutine dcsr_mmread(filename, matrix) - character(len=*), intent(in) :: filename - type(dynamic_csr_matrix), intent(out) :: matrix + subroutine dcsr_mmread(filename, matrix) + character(len=*), intent(in) :: filename + type(dynamic_csr_matrix), intent(out) :: matrix - character(len=MMmaxlinelen) line - integer unit, rows, cols, nnz, row, col - real value + character(len=MMmaxlinelen) line + integer unit, rows, cols, nnz, row, col + real value - call mmreadheader(filename, unit, rows, cols, nnz) + call mmreadheader(filename, unit, rows, cols, nnz) - call allocate(matrix, rows, cols) + call allocate(matrix, rows, cols) - do - read(unit, fmt=MMlineformat) line - if (len_trim(line)==0) cycle - read(line, *) row, col, value - call set(matrix, row, col, value) - nnz=nnz-1 - if (nnz==0) exit - end do + do + read(unit, fmt=MMlineformat) line + if (len_trim(line)==0) cycle + read(line, *) row, col, value + call set(matrix, row, col, value) + nnz=nnz-1 + if (nnz==0) exit + end do - close(unit) + close(unit) - end subroutine dcsr_mmread + end subroutine dcsr_mmread - subroutine mmreadheader(filename, unit, rows, cols, nnz) - ! Opens MatrixMarket file with returned unit number, - ! reads in the header of the file and checks that - ! it says 'coordinate real general' (only thing we support right now) - character(len=*), intent(in) :: filename - integer, intent(out):: unit, rows, cols, nnz + subroutine mmreadheader(filename, unit, rows, cols, nnz) + ! Opens MatrixMarket file with returned unit number, + ! reads in the header of the file and checks that + ! it says 'coordinate real general' (only thing we support right now) + character(len=*), intent(in) :: filename + integer, intent(out):: unit, rows, cols, nnz - character(len=*), parameter:: headerword(1:5)=(/ & - '%%MatrixMarket', & - 'matrix ', & - 'coordinate ', & - 'real ', & - 'general ' /) + character(len=*), parameter:: headerword(1:5)=(/ & + '%%MatrixMarket', & + 'matrix ', & + 'coordinate ', & + 'real ', & + 'general ' /) - character(len=MMmaxlinelen) line - integer i, j + character(len=MMmaxlinelen) line + integer i, j - unit=free_unit() + unit=free_unit() - ewrite(2, *) 'Opening MatrixMarket file: ', trim(filename) - open(unit=unit, file=filename, action="read") + ewrite(2, *) 'Opening MatrixMarket file: ', trim(filename) + open(unit=unit, file=filename, action="read") - ! read header line - read(unit, fmt=MMlineformat) line + ! read header line + read(unit, fmt=MMlineformat) line - i=1 - j=1 - do - if (line(i:i)==' ') then - i=i+1 - cycle - end if + i=1 + j=1 + do + if (line(i:i)==' ') then + i=i+1 + cycle + end if - if (i+len_trim(headerword(j))-1>len_trim(line) .or. & - line(i:i+len_trim(headerword(j))-1)/=headerword(j)) then - ewrite(-1,*) 'First line reads:' - ewrite(-1,*) trim(line) - ewrite(-1,*) "MatrixMarket file not in 'matrix coordinate", & - & "real general' format." - FLAbort("MatrixMarket file cannot be generated.") - end if + if (i+len_trim(headerword(j))-1>len_trim(line) .or. & + line(i:i+len_trim(headerword(j))-1)/=headerword(j)) then + ewrite(-1,*) 'First line reads:' + ewrite(-1,*) trim(line) + ewrite(-1,*) "MatrixMarket file not in 'matrix coordinate", & + & "real general' format." + FLAbort("MatrixMarket file cannot be generated.") + end if - i=i+len_trim(headerword(j)) - j=j+1 - if (j>size(headerword)) exit - end do + i=i+len_trim(headerword(j)) + j=j+1 + if (j>size(headerword)) exit + end do - do - read(unit, fmt=MMlineformat) line - line=adjustl(line) - if (len_trim(line)/=0 .and. line(1:1)/='%') exit - end do + do + read(unit, fmt=MMlineformat) line + line=adjustl(line) + if (len_trim(line)/=0 .and. line(1:1)/='%') exit + end do - read(line, *) rows, cols, nnz - ewrite(2,*) 'rows, cols, nnz: ', rows, cols, nnz + read(line, *) rows, cols, nnz + ewrite(2,*) 'rows, cols, nnz: ', rows, cols, nnz - end subroutine mmreadheader + end subroutine mmreadheader - subroutine csr_write_minmax(matrix, matrix_expression) - ! the matrix to print its min and max of - type(csr_matrix), intent(in):: matrix - ! the actual matrix in the code - character(len=*), intent(in):: matrix_expression + subroutine csr_write_minmax(matrix, matrix_expression) + ! the matrix to print its min and max of + type(csr_matrix), intent(in):: matrix + ! the actual matrix in the code + character(len=*), intent(in):: matrix_expression - ewrite(2,*) 'Min, max of '//trim(matrix_expression)//' "'// & - trim(matrix%name)//'" = ', minval(matrix%val), maxval(matrix%val) + ewrite(2,*) 'Min, max of '//trim(matrix_expression)//' "'// & + trim(matrix%name)//'" = ', minval(matrix%val), maxval(matrix%val) - end subroutine csr_write_minmax + end subroutine csr_write_minmax - subroutine block_csr_write_minmax(matrix, matrix_expression) - ! the matrix to print its min and max of - type(block_csr_matrix), intent(in):: matrix - ! the actual matrix in the code - character(len=*), intent(in):: matrix_expression + subroutine block_csr_write_minmax(matrix, matrix_expression) + ! the matrix to print its min and max of + type(block_csr_matrix), intent(in):: matrix + ! the actual matrix in the code + character(len=*), intent(in):: matrix_expression - integer:: i, j + integer:: i, j - do i=1, blocks(matrix, 1) - do j=1, blocks(matrix, 2) - if (associated(matrix%val(i,j)%ptr)) then - ewrite(2,*) 'Min, max of '//trim(matrix_expression)//' "'// & - trim(matrix%name)//'%'//int2str(i)//','//int2str(j)// & - '" = ', minval(matrix%val(i,j)%ptr), maxval(matrix%val(i,j)%ptr) - end if + do i=1, blocks(matrix, 1) + do j=1, blocks(matrix, 2) + if (associated(matrix%val(i,j)%ptr)) then + ewrite(2,*) 'Min, max of '//trim(matrix_expression)//' "'// & + trim(matrix%name)//'%'//int2str(i)//','//int2str(j)// & + '" = ', minval(matrix%val(i,j)%ptr), maxval(matrix%val(i,j)%ptr) + end if + end do end do - end do - end subroutine block_csr_write_minmax + end subroutine block_csr_write_minmax #include "Reference_count_csr_matrix.F90" #include "Reference_count_csr_sparsity.F90" diff --git a/femtools/Sparse_Tools_Petsc.F90 b/femtools/Sparse_Tools_Petsc.F90 index de1a55a3c0..7dfa5a5b7c 100644 --- a/femtools/Sparse_Tools_Petsc.F90 +++ b/femtools/Sparse_Tools_Petsc.F90 @@ -26,692 +26,692 @@ ! USA #include "fdebug.h" module sparse_tools_petsc - !!< This module is an extension to the sparse_tools module that - !!< implements a csr matrix type 'petsc_csr_matrix' that directly - !!< stores the matrix in petsc format. - use FLDebug - use global_parameters, only: FIELD_NAME_LEN - use futils - use Reference_Counting - use data_structures - use parallel_tools - use halo_data_types - use halos_allocates - use petsc - use Sparse_Tools - use fields_data_types - use fields_base - use fields_allocates - use fields_manipulation - use petsc_tools - implicit none + !!< This module is an extension to the sparse_tools module that + !!< implements a csr matrix type 'petsc_csr_matrix' that directly + !!< stores the matrix in petsc format. + use FLDebug + use global_parameters, only: FIELD_NAME_LEN + use futils + use Reference_Counting + use data_structures + use parallel_tools + use halo_data_types + use halos_allocates + use petsc + use Sparse_Tools + use fields_data_types + use fields_base + use fields_allocates + use fields_manipulation + use petsc_tools + implicit none #include "petsc_legacy.h" - private - - type petsc_csr_matrix - !! the matrix in PETSc format - Mat :: M - !! petsc numbering for rows and columns - type(petsc_numbering_type) :: row_numbering, column_numbering - - !! The halos associated with the rows and columns of the matrix. - type(halo_type), pointer :: row_halo => null(), column_halo => null() - !! Reference counting - type(refcount_type), pointer :: refcount => null() - !! Name - character(len=FIELD_NAME_LEN) :: name="" - !! if .false. we need to call assemble before extracting info - !! and or go into a solve: - logical:: is_assembled=.false. - !! this ksp solver object can be used to cache ksp/pc setup between subsequent solves: - !! ( should always be allocated, to ensure different references all point to the same KSP) - KSP, pointer :: ksp => null() - end type petsc_csr_matrix - - type petsc_csr_matrix_pointer - type(petsc_csr_matrix), pointer :: ptr => null() - end type petsc_csr_matrix_pointer - - - interface allocate - module procedure allocate_petsc_csr_matrix_from_sparsity, & - allocate_petsc_csr_matrix_from_nnz, & - allocate_petsc_csr_matrix_from_petsc_matrix - end interface - - interface deallocate - module procedure deallocate_petsc_csr_matrix - end interface - - interface size - module procedure petsc_csr_size - end interface - - interface block_size - module procedure petsc_csr_block_size - end interface - - interface blocks - module procedure petsc_csr_blocks_withdim !, petsc_csr_blocks_nodim - end interface - - interface entries - module procedure petsc_csr_entries - end interface - - interface zero - module procedure petsc_csr_zero - end interface - - interface addto - module procedure petsc_csr_addto, petsc_csr_vaddto, & - petsc_csr_blocks_addto_withmask, petsc_csr_block_addto, & - petsc_csr_blocks_addto - end interface - - interface addto_diag - module procedure petsc_csr_addto_diag, petsc_csr_vaddto_diag - end interface - - interface scale - module procedure petsc_csr_scale - end interface - - interface extract_diagonal - ! this one would be more logical in Sparse_Matrices_Fields - ! but it depends on petsc headers - module procedure petsc_csr_extract_diagonal - end interface - - interface mult_T - module procedure petsc_csr_mult_T_vector, petsc_csr_mult_T_scalar_to_vector - end interface - - interface mult - module procedure petsc_csr_mult_vector, petsc_csr_mult_vector_to_scalar - end interface - - interface assemble - module procedure petsc_csr_assemble - end interface + private + + type petsc_csr_matrix + !! the matrix in PETSc format + Mat :: M + !! petsc numbering for rows and columns + type(petsc_numbering_type) :: row_numbering, column_numbering + + !! The halos associated with the rows and columns of the matrix. + type(halo_type), pointer :: row_halo => null(), column_halo => null() + !! Reference counting + type(refcount_type), pointer :: refcount => null() + !! Name + character(len=FIELD_NAME_LEN) :: name="" + !! if .false. we need to call assemble before extracting info + !! and or go into a solve: + logical:: is_assembled=.false. + !! this ksp solver object can be used to cache ksp/pc setup between subsequent solves: + !! ( should always be allocated, to ensure different references all point to the same KSP) + KSP, pointer :: ksp => null() + end type petsc_csr_matrix + + type petsc_csr_matrix_pointer + type(petsc_csr_matrix), pointer :: ptr => null() + end type petsc_csr_matrix_pointer + + + interface allocate + module procedure allocate_petsc_csr_matrix_from_sparsity, & + allocate_petsc_csr_matrix_from_nnz, & + allocate_petsc_csr_matrix_from_petsc_matrix + end interface + + interface deallocate + module procedure deallocate_petsc_csr_matrix + end interface + + interface size + module procedure petsc_csr_size + end interface + + interface block_size + module procedure petsc_csr_block_size + end interface + + interface blocks + module procedure petsc_csr_blocks_withdim !, petsc_csr_blocks_nodim + end interface + + interface entries + module procedure petsc_csr_entries + end interface + + interface zero + module procedure petsc_csr_zero + end interface + + interface addto + module procedure petsc_csr_addto, petsc_csr_vaddto, & + petsc_csr_blocks_addto_withmask, petsc_csr_block_addto, & + petsc_csr_blocks_addto + end interface + + interface addto_diag + module procedure petsc_csr_addto_diag, petsc_csr_vaddto_diag + end interface + + interface scale + module procedure petsc_csr_scale + end interface + + interface extract_diagonal + ! this one would be more logical in Sparse_Matrices_Fields + ! but it depends on petsc headers + module procedure petsc_csr_extract_diagonal + end interface + + interface mult_T + module procedure petsc_csr_mult_T_vector, petsc_csr_mult_T_scalar_to_vector + end interface + + interface mult + module procedure petsc_csr_mult_vector, petsc_csr_mult_vector_to_scalar + end interface + + interface assemble + module procedure petsc_csr_assemble + end interface #include "Reference_count_interface_petsc_csr_matrix.F90" - public :: petsc_csr_matrix, petsc_csr_matrix_pointer, & - allocate, deallocate, & - size, block_size, blocks, entries, & - zero, addto, addto_diag, scale, & - extract_diagonal, assemble, incref_petsc_csr_matrix, & - ptap, mult, mult_T, lift_boundary_conditions, dump_matrix, & - csr2petsc_csr, dump_petsc_csr_matrix + public :: petsc_csr_matrix, petsc_csr_matrix_pointer, & + allocate, deallocate, & + size, block_size, blocks, entries, & + zero, addto, addto_diag, scale, & + extract_diagonal, assemble, incref_petsc_csr_matrix, & + ptap, mult, mult_T, lift_boundary_conditions, dump_matrix, & + csr2petsc_csr, dump_petsc_csr_matrix contains - subroutine allocate_petsc_csr_matrix_from_sparsity(matrix, sparsity, blocks, & + subroutine allocate_petsc_csr_matrix_from_sparsity(matrix, sparsity, blocks, & name, diagonal, use_inodes, group_size) - !!< Allocates a petsc_csr_matrix, i.e. a csr_matrix variant - !!< that directly stores in petsc format. The provided sparsity - !!< is only used to workout the number of nonzeros per row and may be - !!< thrown away after this call. - type(petsc_csr_matrix), intent(out) :: matrix - type(csr_sparsity), optional, intent(in):: sparsity - integer, dimension(2), intent(in):: blocks - character(len=*) :: name - !! only take diagonal blocks into account when estimating matrix sparsity - !! does not change the matrix structure otherwise - logical, optional, intent(in):: diagonal - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - !! in the numbering of petsc dofs, split the blocks in 'g' groups of size 'group_size', where - !! g=blocks/group_size and the petsc numbers within each group are contiguous. Thus the petsc - !! numbering, going from major to minor, is given by g x nodes x group_size - !! Default is group_size=(1,1), i.e. no grouping is taking place and all dofs are numbered such that - !! all dofs of the first block are numbered continuously first, followed by those of the second block, etc. - integer, dimension(2), intent(in), optional:: group_size - - PetscErrorCode:: ierr - logical:: ldiagonal - integer, dimension(2):: lgroup_size - integer:: nprows - - ldiagonal=present_and_true(diagonal) - - if (present(group_size)) then - lgroup_size=group_size - else - lgroup_size=(/ 1,1 /) - end if - - matrix%name = name - - call allocate( matrix%row_numbering, & - nnodes=size(sparsity,1), & - nfields=blocks(1), & - group_size=lgroup_size(1), & - halo=sparsity%row_halo ) - - if (size(sparsity,1)==size(sparsity,2) .and. blocks(1)==blocks(2) .and. & - lgroup_size(1)==lgroup_size(2) .and. & - associated(sparsity%row_halo, sparsity%column_halo)) then - - ! row and column numbering are the same - matrix%column_numbering=matrix%row_numbering - call incref(matrix%column_numbering) + !!< Allocates a petsc_csr_matrix, i.e. a csr_matrix variant + !!< that directly stores in petsc format. The provided sparsity + !!< is only used to workout the number of nonzeros per row and may be + !!< thrown away after this call. + type(petsc_csr_matrix), intent(out) :: matrix + type(csr_sparsity), optional, intent(in):: sparsity + integer, dimension(2), intent(in):: blocks + character(len=*) :: name + !! only take diagonal blocks into account when estimating matrix sparsity + !! does not change the matrix structure otherwise + logical, optional, intent(in):: diagonal + !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") + !! that's why we default to not use them + logical, intent(in), optional:: use_inodes + !! in the numbering of petsc dofs, split the blocks in 'g' groups of size 'group_size', where + !! g=blocks/group_size and the petsc numbers within each group are contiguous. Thus the petsc + !! numbering, going from major to minor, is given by g x nodes x group_size + !! Default is group_size=(1,1), i.e. no grouping is taking place and all dofs are numbered such that + !! all dofs of the first block are numbered continuously first, followed by those of the second block, etc. + integer, dimension(2), intent(in), optional:: group_size + + PetscErrorCode:: ierr + logical:: ldiagonal + integer, dimension(2):: lgroup_size + integer:: nprows + + ldiagonal=present_and_true(diagonal) + + if (present(group_size)) then + lgroup_size=group_size + else + lgroup_size=(/ 1,1 /) + end if - else + matrix%name = name - ! create seperate column numbering - call allocate( matrix%column_numbering, & - nnodes=size(sparsity,2), & - nfields=blocks(2), & - group_size=lgroup_size(2), & - halo=sparsity%column_halo ) - end if + call allocate( matrix%row_numbering, & + nnodes=size(sparsity,1), & + nfields=blocks(1), & + group_size=lgroup_size(1), & + halo=sparsity%row_halo ) - if (.not. IsParallel()) then + if (size(sparsity,1)==size(sparsity,2) .and. blocks(1)==blocks(2) .and. & + lgroup_size(1)==lgroup_size(2) .and. & + associated(sparsity%row_halo, sparsity%column_halo)) then - ! Create serial matrix: - matrix%M=csr2petsc_CreateSeqAIJ(sparsity, matrix%row_numbering, & - matrix%column_numbering, ldiagonal, use_inodes=use_inodes) + ! row and column numbering are the same + matrix%column_numbering=matrix%row_numbering + call incref(matrix%column_numbering) - else + else - if (associated(sparsity%row_halo)) then - if (sparsity%row_halo%data_type==HALO_TYPE_CG_NODE) then - ! Mask out non-local rows. FIXME: with local assembly this - ! shouldn't be needed - nprows=matrix%row_numbering%nprivatenodes - matrix%row_numbering%gnn2unn(nprows+1:,:)=-1 - end if + ! create seperate column numbering + call allocate( matrix%column_numbering, & + nnodes=size(sparsity,2), & + nfields=blocks(2), & + group_size=lgroup_size(2), & + halo=sparsity%column_halo ) end if - ! Create parallel matrix: - matrix%M=csr2petsc_CreateMPIAIJ(sparsity, matrix%row_numbering, & - matrix%column_numbering, ldiagonal, use_inodes=use_inodes) + if (.not. IsParallel()) then + + ! Create serial matrix: + matrix%M=csr2petsc_CreateSeqAIJ(sparsity, matrix%row_numbering, & + matrix%column_numbering, ldiagonal, use_inodes=use_inodes) + + else + + if (associated(sparsity%row_halo)) then + if (sparsity%row_halo%data_type==HALO_TYPE_CG_NODE) then + ! Mask out non-local rows. FIXME: with local assembly this + ! shouldn't be needed + nprows=matrix%row_numbering%nprivatenodes + matrix%row_numbering%gnn2unn(nprows+1:,:)=-1 + end if + end if + + ! Create parallel matrix: + matrix%M=csr2petsc_CreateMPIAIJ(sparsity, matrix%row_numbering, & + matrix%column_numbering, ldiagonal, use_inodes=use_inodes) + + ! this is very important for assembly routines (e.g. DG IP viscosity) + ! that try to add zeros outside the provided sparsity; if we go outside + ! the provided n/o nonzeros the assembly will become very slow!!! + call MatSetOption(matrix%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr) + + endif + + call MatSetBlockSizes(matrix%M, lgroup_size(1), lgroup_size(2), ierr) ! this is very important for assembly routines (e.g. DG IP viscosity) ! that try to add zeros outside the provided sparsity; if we go outside ! the provided n/o nonzeros the assembly will become very slow!!! call MatSetOption(matrix%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr) - endif + ! Necessary for local assembly: we don't want to communicate non-local dofs + call MatSetOption(matrix%M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) - call MatSetBlockSizes(matrix%M, lgroup_size(1), lgroup_size(2), ierr) + ! to make sure we're not underestimating the number of nonzeros ever, make + ! petsc fail if new allocations are necessary. If uncommenting the setting of this + ! option fixes your problem the number of no + call MatSetOption(matrix%M, MAT_NEW_NONZERO_ALLOCATION_ERR, PETSC_TRUE, ierr) - ! this is very important for assembly routines (e.g. DG IP viscosity) - ! that try to add zeros outside the provided sparsity; if we go outside - ! the provided n/o nonzeros the assembly will become very slow!!! - call MatSetOption(matrix%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr) + ! saves us from doing a transpose for block inserts + call MatSetOption(matrix%M, MAT_ROW_ORIENTED, PETSC_FALSE, ierr) + + if (associated(sparsity%row_halo)) then + ! these are also pointed to in the row_numbering + ! but only refcounted here + allocate(matrix%row_halo) + matrix%row_halo = sparsity%row_halo + call incref(matrix%row_halo) + end if - ! Necessary for local assembly: we don't want to communicate non-local dofs - call MatSetOption(matrix%M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) + if (associated(sparsity%column_halo)) then + ! these are also pointed to in the column_numbering + ! but only refcounted here + allocate(matrix%column_halo) + matrix%column_halo = sparsity%column_halo + call incref(matrix%column_halo) + end if - ! to make sure we're not underestimating the number of nonzeros ever, make - ! petsc fail if new allocations are necessary. If uncommenting the setting of this - ! option fixes your problem the number of no - call MatSetOption(matrix%M, MAT_NEW_NONZERO_ALLOCATION_ERR, PETSC_TRUE, ierr) + allocate(matrix%ksp) + matrix%ksp = PETSC_NULL_KSP - ! saves us from doing a transpose for block inserts - call MatSetOption(matrix%M, MAT_ROW_ORIENTED, PETSC_FALSE, ierr) + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) - if (associated(sparsity%row_halo)) then - ! these are also pointed to in the row_numbering - ! but only refcounted here - allocate(matrix%row_halo) - matrix%row_halo = sparsity%row_halo - call incref(matrix%row_halo) - end if + end subroutine allocate_petsc_csr_matrix_from_sparsity - if (associated(sparsity%column_halo)) then - ! these are also pointed to in the column_numbering - ! but only refcounted here - allocate(matrix%column_halo) - matrix%column_halo = sparsity%column_halo - call incref(matrix%column_halo) - end if + subroutine allocate_petsc_csr_matrix_from_nnz(matrix, rows, columns, & + dnnz, onnz, blocks, name, halo, row_halo, column_halo, & + element_size, use_inodes, group_size) + !!< Allocates a petsc_csr_matrix, i.e. a csr_matrix variant + !!< that directly stores in petsc format. For this version the number + !!< of nonzeros in each row needs to be provided explicitly. This allows + !!< for a more fine-grained nnz estimate in case of different sparsities + !!< on off-diagonal blocks (i.e. for component to component coupling) + !!< dnnz is the number of local entries in the row (i.e. owned by this + !!< process) onnz is the number of non-local/not-owned entries. This has + !!< to be specified for all rows of the different vertical blocks, i.e. + !!< size(dnnz)==size(onnz)==nprows*blocks(1), where nprows is the number + !!< of private rows (contiguisly numbered). In serial only dnnz is used + !!< and size(dnnz)==rows*blocks(1). + type(petsc_csr_matrix), intent(out) :: matrix + integer, intent(in):: rows, columns + integer, dimension(:), intent(in):: dnnz, onnz + integer, dimension(2), intent(in):: blocks + character(len=*), intent(in) :: name + type(halo_type), pointer, optional:: halo, row_halo, column_halo + !! If provided, the actual PETSc matrix will employ a block structure + !! where each local block consists of the degrees of freedom + !! of 'element_size' subsequent indices. Note that these blocks are + !! something entirely different than the blocks of the previous 'blocks' + !! argument, which only refer to dim argument in the set/addto interface + !! i.e. call addto(M, dim1, dim2, i1, i2, val) where + !! 1<=dim1<=blocks(1) and 1<=dim2<=blocks(2). + !! To distinguish the element_size blocks will be referred to as + !! element blocks. They consist of entries that have the same + !! value for (i1-1)/element_size and (i2-1)/element_size (integer division) + !! At the moment entries which have a different dim1 or dim2 are not + !! included in the element block (this might be a future option). + !! If provided the arguments rows and columns change their meaning + !! to be the number of element block rows and columns. The size of dnnz and onnz + !! is still nprows*blocks(1), but they now contain the number of + !! nonzero element blocks in an element block row. + integer, intent(in), optional:: element_size + !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") + !! that's why we default to not use them + logical, intent(in), optional:: use_inodes + !! in the numbering of petsc dofs, split the blocks in 'g' groups of size 'group_size', where + !! g=blocks/group_size and the petsc numbers within each group are contiguous. Thus the petsc + !! numbering, going from major to minor, is given by g x nodes x group_size + !! Default is group_size=(1,1), i.e. no grouping is taking place and all dofs are numbered such that + !! all dofs of the first block are numbered continously first, followed by those of the second block, etc. + integer, dimension(2), intent(in), optional:: group_size + + type(halo_type), pointer:: lrow_halo, lcolumn_halo + integer, dimension(2):: lgroup_size + PetscErrorCode:: ierr + integer:: nprows, npcols, urows, ucols + integer:: index_rows, index_columns + logical:: use_element_blocks + + matrix%name = name + + nullify( lrow_halo ) + nullify( lcolumn_halo ) + if (present(halo)) then + lrow_halo => halo + lcolumn_halo => halo + end if + if(present(row_halo)) then + lrow_halo => row_halo + end if + if(present(column_halo)) then + lcolumn_halo => column_halo + end if - allocate(matrix%ksp) - matrix%ksp = PETSC_NULL_KSP + if (present(element_size)) then + index_rows=rows*element_size + index_columns=columns*element_size + use_element_blocks= element_size>1 + else + index_rows=rows + index_columns=columns + use_element_blocks=.false. + end if - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) + if (present(group_size)) then + lgroup_size=group_size + else + lgroup_size=(/ 1,1 /) + end if - end subroutine allocate_petsc_csr_matrix_from_sparsity + call allocate( matrix%row_numbering, & + nnodes=index_rows, & + nfields=blocks(1), & + halo=lrow_halo, & + group_size=lgroup_size(1) ) - subroutine allocate_petsc_csr_matrix_from_nnz(matrix, rows, columns, & - dnnz, onnz, blocks, name, halo, row_halo, column_halo, & - element_size, use_inodes, group_size) - !!< Allocates a petsc_csr_matrix, i.e. a csr_matrix variant - !!< that directly stores in petsc format. For this version the number - !!< of nonzeros in each row needs to be provided explicitly. This allows - !!< for a more fine-grained nnz estimate in case of different sparsities - !!< on off-diagonal blocks (i.e. for component to component coupling) - !!< dnnz is the number of local entries in the row (i.e. owned by this - !!< process) onnz is the number of non-local/not-owned entries. This has - !!< to be specified for all rows of the different vertical blocks, i.e. - !!< size(dnnz)==size(onnz)==nprows*blocks(1), where nprows is the number - !!< of private rows (contiguisly numbered). In serial only dnnz is used - !!< and size(dnnz)==rows*blocks(1). - type(petsc_csr_matrix), intent(out) :: matrix - integer, intent(in):: rows, columns - integer, dimension(:), intent(in):: dnnz, onnz - integer, dimension(2), intent(in):: blocks - character(len=*), intent(in) :: name - type(halo_type), pointer, optional:: halo, row_halo, column_halo - !! If provided, the actual PETSc matrix will employ a block structure - !! where each local block consists of the degrees of freedom - !! of 'element_size' subsequent indices. Note that these blocks are - !! something entirely different than the blocks of the previous 'blocks' - !! argument, which only refer to dim argument in the set/addto interface - !! i.e. call addto(M, dim1, dim2, i1, i2, val) where - !! 1<=dim1<=blocks(1) and 1<=dim2<=blocks(2). - !! To distinguish the element_size blocks will be referred to as - !! element blocks. They consist of entries that have the same - !! value for (i1-1)/element_size and (i2-1)/element_size (integer division) - !! At the moment entries which have a different dim1 or dim2 are not - !! included in the element block (this might be a future option). - !! If provided the arguments rows and columns change their meaning - !! to be the number of element block rows and columns. The size of dnnz and onnz - !! is still nprows*blocks(1), but they now contain the number of - !! nonzero element blocks in an element block row. - integer, intent(in), optional:: element_size - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - !! in the numbering of petsc dofs, split the blocks in 'g' groups of size 'group_size', where - !! g=blocks/group_size and the petsc numbers within each group are contiguous. Thus the petsc - !! numbering, going from major to minor, is given by g x nodes x group_size - !! Default is group_size=(1,1), i.e. no grouping is taking place and all dofs are numbered such that - !! all dofs of the first block are numbered continously first, followed by those of the second block, etc. - integer, dimension(2), intent(in), optional:: group_size - - type(halo_type), pointer:: lrow_halo, lcolumn_halo - integer, dimension(2):: lgroup_size - PetscErrorCode:: ierr - integer:: nprows, npcols, urows, ucols - integer:: index_rows, index_columns - logical:: use_element_blocks - - matrix%name = name - - nullify( lrow_halo ) - nullify( lcolumn_halo ) - if (present(halo)) then - lrow_halo => halo - lcolumn_halo => halo - end if - if(present(row_halo)) then - lrow_halo => row_halo - end if - if(present(column_halo)) then - lcolumn_halo => column_halo - end if - - if (present(element_size)) then - index_rows=rows*element_size - index_columns=columns*element_size - use_element_blocks= element_size>1 - else - index_rows=rows - index_columns=columns - use_element_blocks=.false. - end if - - if (present(group_size)) then - lgroup_size=group_size - else - lgroup_size=(/ 1,1 /) - end if - - call allocate( matrix%row_numbering, & - nnodes=index_rows, & - nfields=blocks(1), & - halo=lrow_halo, & - group_size=lgroup_size(1) ) - - if (rows==columns .and. blocks(1)==blocks(2) .and. & - associated(lrow_halo, lcolumn_halo) .and. & - lgroup_size(1)==lgroup_size(2)) then - - ! row and column numbering are the same - matrix%column_numbering=matrix%row_numbering - call incref(matrix%column_numbering) + if (rows==columns .and. blocks(1)==blocks(2) .and. & + associated(lrow_halo, lcolumn_halo) .and. & + lgroup_size(1)==lgroup_size(2)) then - else + ! row and column numbering are the same + matrix%column_numbering=matrix%row_numbering + call incref(matrix%column_numbering) - ! create seperate column numbering - call allocate( matrix%column_numbering, & - nnodes=index_columns, & - nfields=blocks(2), & - halo=lcolumn_halo, & - group_size=lgroup_size(2) ) - end if + else - urows=matrix%row_numbering%universal_length - ucols=matrix%column_numbering%universal_length + ! create seperate column numbering + call allocate( matrix%column_numbering, & + nnodes=index_columns, & + nfields=blocks(2), & + halo=lcolumn_halo, & + group_size=lgroup_size(2) ) + end if - if (IsParallel()) then - nprows=matrix%row_numbering%nprivatenodes - npcols=matrix%column_numbering%nprivatenodes - if (associated(lrow_halo)) then - if (lrow_halo%data_type==HALO_TYPE_CG_NODE) then - ! Mask out non-local rows. FIXME: with local assembly this - ! shouldn't be needed - matrix%row_numbering%gnn2unn(nprows+1:,:)=-1 - end if + urows=matrix%row_numbering%universal_length + ucols=matrix%column_numbering%universal_length + + if (IsParallel()) then + nprows=matrix%row_numbering%nprivatenodes + npcols=matrix%column_numbering%nprivatenodes + if (associated(lrow_halo)) then + if (lrow_halo%data_type==HALO_TYPE_CG_NODE) then + ! Mask out non-local rows. FIXME: with local assembly this + ! shouldn't be needed + matrix%row_numbering%gnn2unn(nprows+1:,:)=-1 + end if + end if end if - end if - if (use_element_blocks .and. .not. IsParallel()) then + if (use_element_blocks .and. .not. IsParallel()) then - assert( size(dnnz)==urows/element_size ) + assert( size(dnnz)==urows/element_size ) - ! Create serial block matrix: - call MatCreateBAIJ(MPI_COMM_SELF, element_size, & - urows, ucols, urows, ucols, & - 0, dnnz, 0, PETSC_NULL_INTEGER, matrix%M, ierr) + ! Create serial block matrix: + call MatCreateBAIJ(MPI_COMM_SELF, element_size, & + urows, ucols, urows, ucols, & + 0, dnnz, 0, PETSC_NULL_INTEGER, matrix%M, ierr) - elseif (use_element_blocks) then + elseif (use_element_blocks) then - assert( size(dnnz)==nprows*blocks(1)/element_size ) - assert( size(onnz)==nprows*blocks(1)/element_size ) + assert( size(dnnz)==nprows*blocks(1)/element_size ) + assert( size(onnz)==nprows*blocks(1)/element_size ) - call MatCreateBAIJ(MPI_COMM_FEMTOOLS, element_size, & - nprows*blocks(1), npcols*blocks(2), & - urows, ucols, & - 0, dnnz, 0, onnz, matrix%M, ierr) + call MatCreateBAIJ(MPI_COMM_FEMTOOLS, element_size, & + nprows*blocks(1), npcols*blocks(2), & + urows, ucols, & + 0, dnnz, 0, onnz, matrix%M, ierr) - else if (.not. IsParallel()) then + else if (.not. IsParallel()) then - assert( size(dnnz)==urows ) + assert( size(dnnz)==urows ) - ! Create serial matrix: - call MatCreateAIJ(MPI_COMM_SELF, urows, ucols, urows, ucols, & - 0, dnnz, 0, PETSC_NULL_INTEGER, matrix%M, ierr) - call MatSetBlockSizes(matrix%M, lgroup_size(1), lgroup_size(2), ierr) + ! Create serial matrix: + call MatCreateAIJ(MPI_COMM_SELF, urows, ucols, urows, ucols, & + 0, dnnz, 0, PETSC_NULL_INTEGER, matrix%M, ierr) + call MatSetBlockSizes(matrix%M, lgroup_size(1), lgroup_size(2), ierr) - else + else - assert( size(dnnz)==nprows*blocks(1) ) - assert( size(onnz)==nprows*blocks(1) ) + assert( size(dnnz)==nprows*blocks(1) ) + assert( size(onnz)==nprows*blocks(1) ) - call MatCreateAIJ(MPI_COMM_FEMTOOLS, nprows*blocks(1), npcols*blocks(2), & - urows, ucols, & - 0, dnnz, 0, onnz, matrix%M, ierr) - call MatSetBlockSizes(matrix%M, lgroup_size(1), lgroup_size(2), ierr) + call MatCreateAIJ(MPI_COMM_FEMTOOLS, nprows*blocks(1), npcols*blocks(2), & + urows, ucols, & + 0, dnnz, 0, onnz, matrix%M, ierr) + call MatSetBlockSizes(matrix%M, lgroup_size(1), lgroup_size(2), ierr) + + endif + call MatSetup(matrix%M, ierr) + + if (.not. use_element_blocks) then + ! this is very important for assembly routines (e.g. DG IP viscosity) + ! that try to add zeros outside the provided sparsity; if we go outside + ! the provided n/o nonzeros the assembly will become very slow!!! + call MatSetOption(matrix%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr) + end if + + ! Necessary for local assembly: we don't want to communicate non-local dofs + call MatSetOption(matrix%M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) + + ! to make sure we're not underestimating the number of nonzeros ever, make + ! petsc fail if new allocations are necessary. If uncommenting the setting of this + ! option fixes your problem the number of no + call MatSetOption(matrix%M, MAT_NEW_NONZERO_ALLOCATION_ERR, PETSC_TRUE, ierr) - endif - call MatSetup(matrix%M, ierr) + ! saves us from doing a transpose for block inserts + call MatSetOption(matrix%M, MAT_ROW_ORIENTED, PETSC_FALSE, ierr) + + if (.not. (present_and_true(use_inodes) .or. use_element_blocks)) then + call MatSetOption(matrix%M, MAT_USE_INODES, PETSC_FALSE, ierr) + end if + + if (associated(lrow_halo)) then + ! these are also pointed to in the row_numbering + ! but only refcounted here + allocate(matrix%row_halo) + matrix%row_halo = lrow_halo + call incref(matrix%row_halo) + end if + + if (associated(lcolumn_halo)) then + ! these are also pointed to in the column_numbering + ! but only refcounted here + allocate(matrix%column_halo) + matrix%column_halo = lcolumn_halo + call incref(matrix%column_halo) + end if + + allocate(matrix%ksp) + matrix%ksp = PETSC_NULL_KSP + + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) + + end subroutine allocate_petsc_csr_matrix_from_nnz + + subroutine allocate_petsc_csr_matrix_from_petsc_matrix(matrix, & + M, row_numbering, column_numbering, name, use_inodes) + !!< Allocates a petsc_csr_matrix using an already created real petsc matrix + !!< row_numbering and column_numbering have to be supplied to specify the + !!< relation between the numbering used inside the petsc matrix and the + !!< numbering to be used for the interface. References to those numberings + !!< will be added. The supplied petsc matrix must be in assembled state. + !!< After this it should be possible to add new entries and zero the matrix + !!< through the petsc_csr_matrix interface, but only if all nonzero + !!< entries have been preallocated. + type(petsc_csr_matrix), intent(out):: matrix + Mat, intent(in):: M + type(petsc_numbering_type), intent(in):: row_numbering, column_numbering + character(len=*), intent(in):: name + !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") + !! that's why we default to not use them + logical, intent(in), optional:: use_inodes + + MatType:: mat_type + PetscErrorCode:: ierr + + matrix%M=M + matrix%name=name + matrix%is_assembled=.true. + + matrix%row_numbering=row_numbering + call incref(matrix%row_numbering) + + matrix%column_numbering=column_numbering + call incref(matrix%column_numbering) + + if (associated(row_numbering%halo)) then + allocate(matrix%row_halo) + matrix%row_halo = row_numbering%halo + call incref(row_numbering%halo) + end if + + if (associated(column_numbering%halo)) then + allocate(matrix%column_halo) + matrix%column_halo = column_numbering%halo + call incref(column_numbering%halo) + end if + + ! make sure the matrix options are consistent with petsc_csr_matrix interface - if (.not. use_element_blocks) then ! this is very important for assembly routines (e.g. DG IP viscosity) ! that try to add zeros outside the provided sparsity; if we go outside ! the provided n/o nonzeros the assembly will become very slow!!! call MatSetOption(matrix%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr) - end if - - ! Necessary for local assembly: we don't want to communicate non-local dofs - call MatSetOption(matrix%M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) - - ! to make sure we're not underestimating the number of nonzeros ever, make - ! petsc fail if new allocations are necessary. If uncommenting the setting of this - ! option fixes your problem the number of no - call MatSetOption(matrix%M, MAT_NEW_NONZERO_ALLOCATION_ERR, PETSC_TRUE, ierr) - - ! saves us from doing a transpose for block inserts - call MatSetOption(matrix%M, MAT_ROW_ORIENTED, PETSC_FALSE, ierr) - - if (.not. (present_and_true(use_inodes) .or. use_element_blocks)) then - call MatSetOption(matrix%M, MAT_USE_INODES, PETSC_FALSE, ierr) - end if - - if (associated(lrow_halo)) then - ! these are also pointed to in the row_numbering - ! but only refcounted here - allocate(matrix%row_halo) - matrix%row_halo = lrow_halo - call incref(matrix%row_halo) - end if - - if (associated(lcolumn_halo)) then - ! these are also pointed to in the column_numbering - ! but only refcounted here - allocate(matrix%column_halo) - matrix%column_halo = lcolumn_halo - call incref(matrix%column_halo) - end if - - allocate(matrix%ksp) - matrix%ksp = PETSC_NULL_KSP - - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) - - end subroutine allocate_petsc_csr_matrix_from_nnz - - subroutine allocate_petsc_csr_matrix_from_petsc_matrix(matrix, & - M, row_numbering, column_numbering, name, use_inodes) - !!< Allocates a petsc_csr_matrix using an already created real petsc matrix - !!< row_numbering and column_numbering have to be supplied to specify the - !!< relation between the numbering used inside the petsc matrix and the - !!< numbering to be used for the interface. References to those numberings - !!< will be added. The supplied petsc matrix must be in assembled state. - !!< After this it should be possible to add new entries and zero the matrix - !!< through the petsc_csr_matrix interface, but only if all nonzero - !!< entries have been preallocated. - type(petsc_csr_matrix), intent(out):: matrix - Mat, intent(in):: M - type(petsc_numbering_type), intent(in):: row_numbering, column_numbering - character(len=*), intent(in):: name - !! petsc's inodes don't work with certain preconditioners ("mg" and "eisenstat") - !! that's why we default to not use them - logical, intent(in), optional:: use_inodes - - MatType:: mat_type - PetscErrorCode:: ierr - - matrix%M=M - matrix%name=name - matrix%is_assembled=.true. - - matrix%row_numbering=row_numbering - call incref(matrix%row_numbering) - - matrix%column_numbering=column_numbering - call incref(matrix%column_numbering) - - if (associated(row_numbering%halo)) then - allocate(matrix%row_halo) - matrix%row_halo = row_numbering%halo - call incref(row_numbering%halo) - end if - - if (associated(column_numbering%halo)) then - allocate(matrix%column_halo) - matrix%column_halo = column_numbering%halo - call incref(column_numbering%halo) - end if - - ! make sure the matrix options are consistent with petsc_csr_matrix interface - - ! this is very important for assembly routines (e.g. DG IP viscosity) - ! that try to add zeros outside the provided sparsity; if we go outside - ! the provided n/o nonzeros the assembly will become very slow!!! - call MatSetOption(matrix%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr) - - ! Necessary for local assembly: we don't want to communicate non-local dofs - call MatSetOption(matrix%M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) - - ! to make sure we're not underestimating the number of nonzeros ever, make - ! petsc fail if new allocations are necessary. If uncommenting the setting of this - ! option fixes your problem the number of no - call MatSetOption(matrix%M, MAT_NEW_NONZERO_ALLOCATION_ERR, PETSC_TRUE, ierr) - - ! saves us from doing a transpose for block inserts - call MatSetOption(matrix%M, MAT_ROW_ORIENTED, PETSC_FALSE, ierr) - - if (.not. present_and_true(use_inodes)) then - call MatGetType(matrix%M, mat_type, ierr) - if (mat_type==MATSEQAIJ .or. mat_type==MATMPIAIJ) then - call MatSetOption(matrix%M, MAT_USE_INODES, PETSC_FALSE, ierr) + + ! Necessary for local assembly: we don't want to communicate non-local dofs + call MatSetOption(matrix%M, MAT_IGNORE_OFF_PROC_ENTRIES, PETSC_TRUE, ierr) + + ! to make sure we're not underestimating the number of nonzeros ever, make + ! petsc fail if new allocations are necessary. If uncommenting the setting of this + ! option fixes your problem the number of no + call MatSetOption(matrix%M, MAT_NEW_NONZERO_ALLOCATION_ERR, PETSC_TRUE, ierr) + + ! saves us from doing a transpose for block inserts + call MatSetOption(matrix%M, MAT_ROW_ORIENTED, PETSC_FALSE, ierr) + + if (.not. present_and_true(use_inodes)) then + call MatGetType(matrix%M, mat_type, ierr) + if (mat_type==MATSEQAIJ .or. mat_type==MATMPIAIJ) then + call MatSetOption(matrix%M, MAT_USE_INODES, PETSC_FALSE, ierr) + end if end if - end if - allocate(matrix%ksp) - matrix%ksp = PETSC_NULL_KSP + allocate(matrix%ksp) + matrix%ksp = PETSC_NULL_KSP + + nullify(matrix%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(matrix) + + end subroutine allocate_petsc_csr_matrix_from_petsc_matrix + + subroutine deallocate_petsc_csr_matrix(matrix, stat) + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(out), optional :: stat + + integer :: lstat + + lstat=0 + + call decref(matrix) + if (has_references(matrix)) then + goto 42 + end if - nullify(matrix%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(matrix) + call MatDestroy(matrix%M, lstat) + if (lstat/=0) goto 42 - end subroutine allocate_petsc_csr_matrix_from_petsc_matrix + call deallocate(matrix%row_numbering) - subroutine deallocate_petsc_csr_matrix(matrix, stat) - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(out), optional :: stat + call deallocate(matrix%column_numbering) - integer :: lstat + if (associated(matrix%row_halo)) then + call deallocate(matrix%row_halo) + deallocate(matrix%row_halo) + end if - lstat=0 + if (associated(matrix%column_halo)) then + call deallocate(matrix%column_halo) + deallocate(matrix%column_halo) + end if - call decref(matrix) - if (has_references(matrix)) then - goto 42 - end if + if (.not. associated(matrix%ksp)) then + FLAbort("Attempt made to deallocate a non-allocated or damaged petsc_csr_matrix.") + end if - call MatDestroy(matrix%M, lstat) - if (lstat/=0) goto 42 + if (matrix%ksp/=PETSC_NULL_KSP) then + call KSPDestroy(matrix%ksp, lstat) + if (lstat/=0) then + if (present(stat)) then + ewrite(0,*) "Error from KSPDestroy in deallocate_csr_matrix." + stat=lstat + return + end if + FLAbort("Error from KSPDestroy in deallocate_csr_matrix.") + end if + end if + deallocate(matrix%ksp) + +42 if (present(stat)) then + stat=lstat + else + if (lstat/=0) then + FLAbort("Failed to deallocate matrix") + end if + end if - call deallocate(matrix%row_numbering) + end subroutine deallocate_petsc_csr_matrix - call deallocate(matrix%column_numbering) + pure function petsc_csr_size(matrix, dim) + !!< Clone of size function. + integer :: petsc_csr_size + type(petsc_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim - if (associated(matrix%row_halo)) then - call deallocate(matrix%row_halo) - deallocate(matrix%row_halo) - end if + integer :: rows, cols - if (associated(matrix%column_halo)) then - call deallocate(matrix%column_halo) - deallocate(matrix%column_halo) - end if + rows = size(matrix%row_numbering%gnn2unn) + cols = size(matrix%column_numbering%gnn2unn) - if (.not. associated(matrix%ksp)) then - FLAbort("Attempt made to deallocate a non-allocated or damaged petsc_csr_matrix.") - end if + if (.not.present(dim)) then + petsc_csr_size = rows * cols + else if (dim==1) then + petsc_csr_size = rows + else if (dim==2) then + petsc_csr_size = cols + else + ! not allowed to flabort in pure function + petsc_csr_size = 0 + end if - if (matrix%ksp/=PETSC_NULL_KSP) then - call KSPDestroy(matrix%ksp, lstat) - if (lstat/=0) then - if (present(stat)) then - ewrite(0,*) "Error from KSPDestroy in deallocate_csr_matrix." - stat=lstat - return - end if - FLAbort("Error from KSPDestroy in deallocate_csr_matrix.") + end function petsc_csr_size + + function petsc_must_assemble_by_column_array(matrix, i) result(ret) + logical :: ret + type(petsc_csr_matrix), intent(in) :: matrix + integer, dimension(:), intent(in) :: i + + ret = .false. + end function petsc_must_assemble_by_column_array + + function petsc_must_assemble_by_column_scalar(matrix, i) result(ret) + logical :: ret + type(petsc_csr_matrix), intent(in) :: matrix + integer, intent(in) :: i + ret = .false. + end function petsc_must_assemble_by_column_scalar + + pure function petsc_csr_block_size(matrix, dim) + !!< size of each block + integer :: petsc_csr_block_size + type(petsc_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim + + integer :: rows, cols + + rows = size(matrix%row_numbering%gnn2unn,1) + cols = size(matrix%column_numbering%gnn2unn,1) + + if (.not.present(dim)) then + petsc_csr_block_size = rows * cols + else if (dim==1) then + petsc_csr_block_size = rows + else if (dim==2) then + petsc_csr_block_size = cols + else + ! not allowed to flabort in pure function + petsc_csr_block_size = 0 end if - end if - deallocate(matrix%ksp) - -42 if (present(stat)) then - stat=lstat - else - if (lstat/=0) then - FLAbort("Failed to deallocate matrix") - end if - end if - - end subroutine deallocate_petsc_csr_matrix - - pure function petsc_csr_size(matrix, dim) - !!< Clone of size function. - integer :: petsc_csr_size - type(petsc_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim - - integer :: rows, cols - - rows = size(matrix%row_numbering%gnn2unn) - cols = size(matrix%column_numbering%gnn2unn) - - if (.not.present(dim)) then - petsc_csr_size = rows * cols - else if (dim==1) then - petsc_csr_size = rows - else if (dim==2) then - petsc_csr_size = cols - else - ! not allowed to flabort in pure function - petsc_csr_size = 0 - end if - - end function petsc_csr_size - - function petsc_must_assemble_by_column_array(matrix, i) result(ret) - logical :: ret - type(petsc_csr_matrix), intent(in) :: matrix - integer, dimension(:), intent(in) :: i - - ret = .false. - end function petsc_must_assemble_by_column_array - - function petsc_must_assemble_by_column_scalar(matrix, i) result(ret) - logical :: ret - type(petsc_csr_matrix), intent(in) :: matrix - integer, intent(in) :: i - ret = .false. - end function petsc_must_assemble_by_column_scalar - - pure function petsc_csr_block_size(matrix, dim) - !!< size of each block - integer :: petsc_csr_block_size - type(petsc_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim - - integer :: rows, cols - - rows = size(matrix%row_numbering%gnn2unn,1) - cols = size(matrix%column_numbering%gnn2unn,1) - - if (.not.present(dim)) then - petsc_csr_block_size = rows * cols - else if (dim==1) then - petsc_csr_block_size = rows - else if (dim==2) then - petsc_csr_block_size = cols - else - ! not allowed to flabort in pure function - petsc_csr_block_size = 0 - end if - - end function petsc_csr_block_size - - pure function petsc_csr_blocks_withdim(matrix, dim) result (blocks) - !!< Number of blocks - integer :: blocks - type(petsc_csr_matrix), intent(in) :: matrix - integer, optional, intent(in) :: dim - - integer :: rows, cols - - rows = size(matrix%row_numbering%gnn2unn,2) - cols = size(matrix%column_numbering%gnn2unn,2) - - if (.not.present(dim)) then - blocks = rows * cols - else if (dim==1) then - blocks = rows - else if (dim==2) then - blocks = cols - else - ! not allowed to flabort in pure function - blocks = 0 - end if - - end function petsc_csr_blocks_withdim + + end function petsc_csr_block_size + + pure function petsc_csr_blocks_withdim(matrix, dim) result (blocks) + !!< Number of blocks + integer :: blocks + type(petsc_csr_matrix), intent(in) :: matrix + integer, optional, intent(in) :: dim + + integer :: rows, cols + + rows = size(matrix%row_numbering%gnn2unn,2) + cols = size(matrix%column_numbering%gnn2unn,2) + + if (.not.present(dim)) then + blocks = rows * cols + else if (dim==1) then + blocks = rows + else if (dim==2) then + blocks = cols + else + ! not allowed to flabort in pure function + blocks = 0 + end if + + end function petsc_csr_blocks_withdim ! causes gfortran to complain about ambiguous generic interface: ! @@ -730,599 +730,599 @@ end function petsc_csr_blocks_withdim ! end function petsc_csr_blocks_nodim ! ============================================================================ - function petsc_csr_entries(matrix) result (entries) - !!< Return the number of (potentially) non-zero entries in matrix. - integer :: entries - type(petsc_csr_matrix), intent(in) :: matrix + function petsc_csr_entries(matrix) result (entries) + !!< Return the number of (potentially) non-zero entries in matrix. + integer :: entries + type(petsc_csr_matrix), intent(in) :: matrix - double precision, dimension(MAT_INFO_SIZE):: matrixinfo - PetscErrorCode:: ierr + double precision, dimension(MAT_INFO_SIZE):: matrixinfo + PetscErrorCode:: ierr - ! get the necessary info about the matrix: - call MatGetInfo(matrix%M, MAT_LOCAL, matrixinfo, ierr) - entries=matrixinfo(MAT_INFO_NZ_USED) + ! get the necessary info about the matrix: + call MatGetInfo(matrix%M, MAT_LOCAL, matrixinfo, ierr) + entries=matrixinfo(MAT_INFO_NZ_USED) - end function petsc_csr_entries + end function petsc_csr_entries - subroutine petsc_csr_zero(matrix) - !!< Zero the entries of a csr matrix. - type(petsc_csr_matrix), intent(inout) :: matrix + subroutine petsc_csr_zero(matrix) + !!< Zero the entries of a csr matrix. + type(petsc_csr_matrix), intent(inout) :: matrix - PetscErrorCode:: ierr + PetscErrorCode:: ierr - call MatZeroEntries(matrix%M, ierr) - matrix%is_assembled=.true. + call MatZeroEntries(matrix%M, ierr) + matrix%is_assembled=.true. - end subroutine petsc_csr_zero + end subroutine petsc_csr_zero - subroutine petsc_csr_addto(matrix, blocki, blockj, i, j, val) - !!< Add value to matrix(blocki, blockj, i,j) - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj,i,j - real, intent(in) :: val + subroutine petsc_csr_addto(matrix, blocki, blockj, i, j, val) + !!< Add value to matrix(blocki, blockj, i,j) + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj,i,j + real, intent(in) :: val - PetscErrorCode:: ierr - integer:: row, col + PetscErrorCode:: ierr + integer:: row, col - row=matrix%row_numbering%gnn2unn(i,blocki) - col=matrix%column_numbering%gnn2unn(j,blockj) + row=matrix%row_numbering%gnn2unn(i,blocki) + col=matrix%column_numbering%gnn2unn(j,blockj) - call MatSetValue(matrix%M, row, col, val, ADD_VALUES, ierr) - matrix%is_assembled=.false. + call MatSetValue(matrix%M, row, col, val, ADD_VALUES, ierr) + matrix%is_assembled=.false. - end subroutine petsc_csr_addto + end subroutine petsc_csr_addto - subroutine petsc_csr_vaddto(matrix, blocki, blockj, i, j, val) - !!< Add multiple values to matrix(blocki, blockj, i,j) - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj - integer, dimension(:), intent(in) :: i,j - real, dimension(size(i),size(j)), intent(in) :: val + subroutine petsc_csr_vaddto(matrix, blocki, blockj, i, j, val) + !!< Add multiple values to matrix(blocki, blockj, i,j) + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj + integer, dimension(:), intent(in) :: i,j + real, dimension(size(i),size(j)), intent(in) :: val - PetscInt, dimension(size(i)):: idxm - PetscInt, dimension(size(j)):: idxn - PetscErrorCode:: ierr + PetscInt, dimension(size(i)):: idxm + PetscInt, dimension(size(j)):: idxn + PetscErrorCode:: ierr - idxm=matrix%row_numbering%gnn2unn(i,blocki) - idxn=matrix%column_numbering%gnn2unn(j,blockj) + idxm=matrix%row_numbering%gnn2unn(i,blocki) + idxn=matrix%column_numbering%gnn2unn(j,blockj) - call MatSetValues(matrix%M, size(i), idxm, size(j), idxn, real(val, kind=PetscScalar_kind), & - ADD_VALUES, ierr) + call MatSetValues(matrix%M, size(i), idxm, size(j), idxn, real(val, kind=PetscScalar_kind), & + ADD_VALUES, ierr) - matrix%is_assembled=.false. + matrix%is_assembled=.false. - end subroutine petsc_csr_vaddto + end subroutine petsc_csr_vaddto - subroutine petsc_csr_block_addto(matrix, i, j, val) - !!< Adds a local matrix for all components of entry (i,j) in the matrix + subroutine petsc_csr_block_addto(matrix, i, j, val) + !!< Adds a local matrix for all components of entry (i,j) in the matrix - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: i - integer, intent(in) :: j - real, dimension(:,:), intent(in) :: val + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: i + integer, intent(in) :: j + real, dimension(:,:), intent(in) :: val - PetscInt, dimension(size(matrix%row_numbering%gnn2unn,2)):: idxm - PetscInt, dimension(size(matrix%column_numbering%gnn2unn,2)):: idxn - PetscErrorCode:: ierr + PetscInt, dimension(size(matrix%row_numbering%gnn2unn,2)):: idxm + PetscInt, dimension(size(matrix%column_numbering%gnn2unn,2)):: idxn + PetscErrorCode:: ierr - idxm=matrix%row_numbering%gnn2unn(i,:) - idxn=matrix%column_numbering%gnn2unn(j,:) + idxm=matrix%row_numbering%gnn2unn(i,:) + idxn=matrix%column_numbering%gnn2unn(j,:) - call MatSetValues(matrix%M, size(idxm), idxm, size(idxn), idxn, & - real(val, kind=PetscScalar_kind), ADD_VALUES, ierr) + call MatSetValues(matrix%M, size(idxm), idxm, size(idxn), idxn, & + real(val, kind=PetscScalar_kind), ADD_VALUES, ierr) - matrix%is_assembled=.false. + matrix%is_assembled=.false. - end subroutine petsc_csr_block_addto + end subroutine petsc_csr_block_addto - subroutine petsc_csr_blocks_addto(matrix, i, j, val) - !!< Add the (blocki, blockj, :, :) th matrix of val onto the (blocki, blockj) th - !!< block of the block csr matrix, for all blocks of the block csr matrix. + subroutine petsc_csr_blocks_addto(matrix, i, j, val) + !!< Add the (blocki, blockj, :, :) th matrix of val onto the (blocki, blockj) th + !!< block of the block csr matrix, for all blocks of the block csr matrix. - type(petsc_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i - integer, dimension(:), intent(in) :: j - real, dimension(:,:,:,:), intent(in) :: val + type(petsc_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i + integer, dimension(:), intent(in) :: j + real, dimension(:,:,:,:), intent(in) :: val - PetscScalar, dimension(size(i), size(j)):: value - PetscInt, dimension(size(i)):: idxm - PetscInt, dimension(size(j)):: idxn - PetscErrorCode:: ierr - integer:: blocki, blockj + PetscScalar, dimension(size(i), size(j)):: value + PetscInt, dimension(size(i)):: idxm + PetscInt, dimension(size(j)):: idxn + PetscErrorCode:: ierr + integer:: blocki, blockj - do blocki=1, size(matrix%row_numbering%gnn2unn,2) - idxm=matrix%row_numbering%gnn2unn(i,blocki) - do blockj=1, size(matrix%column_numbering%gnn2unn,2) - idxn=matrix%column_numbering%gnn2unn(j,blockj) - ! unfortunately we need a copy here to pass contiguous memory - value=val(blocki, blockj, :, :) - call MatSetValues(matrix%M, size(i), idxm, size(j), idxn, & - value, ADD_VALUES, ierr) + do blocki=1, size(matrix%row_numbering%gnn2unn,2) + idxm=matrix%row_numbering%gnn2unn(i,blocki) + do blockj=1, size(matrix%column_numbering%gnn2unn,2) + idxn=matrix%column_numbering%gnn2unn(j,blockj) + ! unfortunately we need a copy here to pass contiguous memory + value=val(blocki, blockj, :, :) + call MatSetValues(matrix%M, size(i), idxm, size(j), idxn, & + value, ADD_VALUES, ierr) + end do end do - end do - matrix%is_assembled=.false. + matrix%is_assembled=.false. + + end subroutine petsc_csr_blocks_addto + + subroutine petsc_csr_blocks_addto_withmask(matrix, i, j, val, block_mask) + !!< Add the (blocki, blockj, :, :) th matrix of val onto the (blocki, blockj) th + !!< block of the block csr matrix, for all blocks of the block csr matrix. + + type(petsc_csr_matrix), intent(inout) :: matrix + integer, dimension(:), intent(in) :: i + integer, dimension(:), intent(in) :: j + real, dimension(:,:,:,:), intent(in) :: val + logical, dimension(:,:), intent(in) :: block_mask + + PetscScalar, dimension(size(i), size(j)):: value + PetscInt, dimension(size(i)):: idxm + PetscInt, dimension(size(j)):: idxn + PetscErrorCode:: ierr + integer:: blocki, blockj + + do blocki=1, size(matrix%row_numbering%gnn2unn,2) + idxm=matrix%row_numbering%gnn2unn(i,blocki) + do blockj=1, size(matrix%column_numbering%gnn2unn,2) + if (block_mask(blocki,blockj)) then + idxn=matrix%column_numbering%gnn2unn(j,blockj) + ! unfortunately we need a copy here to pass contiguous memory + value=val(blocki, blockj, :, :) + call MatSetValues(matrix%M, size(i), idxm, size(j), idxn, & + value, ADD_VALUES, ierr) + end if + end do + end do - end subroutine petsc_csr_blocks_addto + matrix%is_assembled=.false. - subroutine petsc_csr_blocks_addto_withmask(matrix, i, j, val, block_mask) - !!< Add the (blocki, blockj, :, :) th matrix of val onto the (blocki, blockj) th - !!< block of the block csr matrix, for all blocks of the block csr matrix. + end subroutine petsc_csr_blocks_addto_withmask - type(petsc_csr_matrix), intent(inout) :: matrix - integer, dimension(:), intent(in) :: i - integer, dimension(:), intent(in) :: j - real, dimension(:,:,:,:), intent(in) :: val - logical, dimension(:,:), intent(in) :: block_mask + subroutine petsc_csr_scale(matrix, scale) + !!< Scale matrix by scale. + type(petsc_csr_matrix), intent(inout) :: matrix + real, intent(in) :: scale - PetscScalar, dimension(size(i), size(j)):: value - PetscInt, dimension(size(i)):: idxm - PetscInt, dimension(size(j)):: idxn - PetscErrorCode:: ierr - integer:: blocki, blockj + PetscErrorCode:: ierr - do blocki=1, size(matrix%row_numbering%gnn2unn,2) - idxm=matrix%row_numbering%gnn2unn(i,blocki) - do blockj=1, size(matrix%column_numbering%gnn2unn,2) - if (block_mask(blocki,blockj)) then - idxn=matrix%column_numbering%gnn2unn(j,blockj) - ! unfortunately we need a copy here to pass contiguous memory - value=val(blocki, blockj, :, :) - call MatSetValues(matrix%M, size(i), idxm, size(j), idxn, & - value, ADD_VALUES, ierr) - end if + call MatScale(matrix%M, real(scale ,kind=PetscScalar_kind), ierr) + matrix%is_assembled=.false. ! I think? + + end subroutine petsc_csr_scale + + subroutine petsc_csr_addto_diag(matrix, blocki, blockj, i, val) + !!< Add val to matrix(i,i) + !!< Adding to the diagonal of a non-diagonal block is supported. + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki,blockj, i + real, intent(in) :: val + + call addto(matrix, blocki, blockj, i, i, val) + matrix%is_assembled=.false. + + end subroutine petsc_csr_addto_diag + + subroutine petsc_csr_vaddto_diag(matrix, blocki, blockj, i, val) + !!< Add val to matrix(i,i) + type(petsc_csr_matrix), intent(inout) :: matrix + integer, intent(in) :: blocki, blockj + integer, dimension(:), intent(in) :: i + real, dimension(size(i)), intent(in) :: val + + integer:: k + + ! can't think of a more efficient way + do k=1, size(i) + call addto(matrix, blocki, blockj, i(k), i(k), val(k)) end do - end do + matrix%is_assembled=.false. - matrix%is_assembled=.false. + end subroutine petsc_csr_vaddto_diag - end subroutine petsc_csr_blocks_addto_withmask + subroutine petsc_csr_extract_diagonal(matrix,diagonal) + !!< Extracts diagonal components of a block_csr matrix. + !!< The vector field diagonal needs to be allocated before the call. - subroutine petsc_csr_scale(matrix, scale) - !!< Scale matrix by scale. - type(petsc_csr_matrix), intent(inout) :: matrix - real, intent(in) :: scale + type(petsc_csr_matrix), intent(inout) :: matrix + type(vector_field), intent(inout) :: diagonal - PetscErrorCode:: ierr + PetscErrorCode:: ierr + Vec:: diagonal_vec - call MatScale(matrix%M, real(scale ,kind=PetscScalar_kind), ierr) - matrix%is_assembled=.false. ! I think? + assert( diagonal%dim==blocks(matrix,1) ) + assert( node_count(diagonal)==block_size(matrix,1)) + assert( block_size(matrix,1)==block_size(matrix,2)) + assert( blocks(matrix,1)==blocks(matrix,2)) - end subroutine petsc_csr_scale + call petsc_csr_assemble(matrix) - subroutine petsc_csr_addto_diag(matrix, blocki, blockj, i, val) - !!< Add val to matrix(i,i) - !!< Adding to the diagonal of a non-diagonal block is supported. - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki,blockj, i - real, intent(in) :: val + diagonal_vec=PetscNumberingCreateVec(matrix%row_numbering) + call MatGetDiagonal(matrix%M, diagonal_vec, ierr) - call addto(matrix, blocki, blockj, i, i, val) - matrix%is_assembled=.false. + call petsc2field(diagonal_vec, matrix%row_numbering, diagonal) - end subroutine petsc_csr_addto_diag + call VecDestroy(diagonal_vec,ierr) - subroutine petsc_csr_vaddto_diag(matrix, blocki, blockj, i, val) - !!< Add val to matrix(i,i) - type(petsc_csr_matrix), intent(inout) :: matrix - integer, intent(in) :: blocki, blockj - integer, dimension(:), intent(in) :: i - real, dimension(size(i)), intent(in) :: val + end subroutine petsc_csr_extract_diagonal - integer:: k + subroutine petsc_csr_assemble(matrix) + !!< if necessary assemble the matrix + type(petsc_csr_matrix), intent(inout) :: matrix - ! can't think of a more efficient way - do k=1, size(i) - call addto(matrix, blocki, blockj, i(k), i(k), val(k)) - end do - matrix%is_assembled=.false. + PetscErrorCode:: ierr - end subroutine petsc_csr_vaddto_diag + call alland(matrix%is_assembled) + if (.not. matrix%is_assembled) then + call MatAssemblyBegin(matrix%M, MAT_FINAL_ASSEMBLY, ierr) + call MatAssemblyEnd(matrix%M, MAT_FINAL_ASSEMBLY, ierr) + end if + matrix%is_assembled=.true. - subroutine petsc_csr_extract_diagonal(matrix,diagonal) - !!< Extracts diagonal components of a block_csr matrix. - !!< The vector field diagonal needs to be allocated before the call. + end subroutine petsc_csr_assemble - type(petsc_csr_matrix), intent(inout) :: matrix - type(vector_field), intent(inout) :: diagonal + subroutine ptap(c, a, p) + !!< Perform the matrix multiplication A=P^T A P + type(petsc_csr_matrix), intent(out):: c + type(petsc_csr_matrix), intent(inout):: a + type(petsc_csr_matrix), intent(inout):: p - PetscErrorCode:: ierr - Vec:: diagonal_vec + PetscErrorCode:: ierr - assert( diagonal%dim==blocks(matrix,1) ) - assert( node_count(diagonal)==block_size(matrix,1)) - assert( block_size(matrix,1)==block_size(matrix,2)) - assert( blocks(matrix,1)==blocks(matrix,2)) + call assemble(a) + call assemble(p) - call petsc_csr_assemble(matrix) + ! this creates the petsc ptap matrix and computes it + call MatPTAP(a%M, p%M, MAT_INITIAL_MATRIX, 1.5_PETSCSCALAR_KIND, c%M, ierr) - diagonal_vec=PetscNumberingCreateVec(matrix%row_numbering) - call MatGetDiagonal(matrix%M, diagonal_vec, ierr) + ! rest of internals for c is copied from A + c%row_numbering=a%row_numbering + call incref(c%row_numbering) + c%column_numbering=a%column_numbering + call incref(c%column_numbering) - call petsc2field(diagonal_vec, matrix%row_numbering, diagonal) + if (associated(a%row_halo)) then + allocate(c%row_halo) + c%row_halo = a%row_halo + call incref(c%row_halo) + else + nullify(c%row_halo) + end if + if (associated(a%column_halo)) then + allocate(c%column_halo) + c%column_halo = a%column_halo + call incref(c%column_halo) + else + nullify(c%column_halo) + end if - call VecDestroy(diagonal_vec,ierr) + ! I think it is assembled now? + c%is_assembled=.true. - end subroutine petsc_csr_extract_diagonal + ! make up a name + c%name=trim(a%name)//"_"//trim(p%name)//"_ptap" - subroutine petsc_csr_assemble(matrix) - !!< if necessary assemble the matrix - type(petsc_csr_matrix), intent(inout) :: matrix + allocate(c%ksp) + c%ksp = PETSC_NULL_KSP - PetscErrorCode:: ierr + ! the new c get its own reference: + nullify(c%refcount) ! Hack for gfortran component initialisation + ! bug. + call addref(c) - call alland(matrix%is_assembled) - if (.not. matrix%is_assembled) then - call MatAssemblyBegin(matrix%M, MAT_FINAL_ASSEMBLY, ierr) - call MatAssemblyEnd(matrix%M, MAT_FINAL_ASSEMBLY, ierr) - end if - matrix%is_assembled=.true. + end subroutine ptap - end subroutine petsc_csr_assemble + subroutine petsc_csr_mult_vector(x, A, b) + !!< Performs the matrix-vector multiplication x=Ab + type(vector_field), intent(inout):: x + type(petsc_csr_matrix), intent(inout):: A + type(vector_field), intent(in):: b - subroutine ptap(c, a, p) - !!< Perform the matrix multiplication A=P^T A P - type(petsc_csr_matrix), intent(out):: c - type(petsc_csr_matrix), intent(inout):: a - type(petsc_csr_matrix), intent(inout):: p + PetscErrorCode:: ierr + Vec:: bvec, xvec - PetscErrorCode:: ierr + assert( node_count(x)==block_size(A, 1) ) + assert( node_count(b)==block_size(A, 2) ) + assert( x%dim==blocks(A,1) ) + assert( b%dim==blocks(A,2) ) - call assemble(a) - call assemble(p) + call petsc_csr_assemble(A) - ! this creates the petsc ptap matrix and computes it - call MatPTAP(a%M, p%M, MAT_INITIAL_MATRIX, 1.5_PETSCSCALAR_KIND, c%M, ierr) + ! copy b to petsc vector + bvec=PetscNumberingCreateVec(A%column_numbering) + call field2petsc(b, A%column_numbering, bvec) + ! creates PETSc solution vec of the right size: + xvec=PetscNumberingCreateVec(A%row_numbering) - ! rest of internals for c is copied from A - c%row_numbering=a%row_numbering - call incref(c%row_numbering) - c%column_numbering=a%column_numbering - call incref(c%column_numbering) - - if (associated(a%row_halo)) then - allocate(c%row_halo) - c%row_halo = a%row_halo - call incref(c%row_halo) - else - nullify(c%row_halo) - end if - if (associated(a%column_halo)) then - allocate(c%column_halo) - c%column_halo = a%column_halo - call incref(c%column_halo) - else - nullify(c%column_halo) - end if - - ! I think it is assembled now? - c%is_assembled=.true. - - ! make up a name - c%name=trim(a%name)//"_"//trim(p%name)//"_ptap" - - allocate(c%ksp) - c%ksp = PETSC_NULL_KSP - - ! the new c get its own reference: - nullify(c%refcount) ! Hack for gfortran component initialisation - ! bug. - call addref(c) - - end subroutine ptap - - subroutine petsc_csr_mult_vector(x, A, b) - !!< Performs the matrix-vector multiplication x=Ab - type(vector_field), intent(inout):: x - type(petsc_csr_matrix), intent(inout):: A - type(vector_field), intent(in):: b - - PetscErrorCode:: ierr - Vec:: bvec, xvec - - assert( node_count(x)==block_size(A, 1) ) - assert( node_count(b)==block_size(A, 2) ) - assert( x%dim==blocks(A,1) ) - assert( b%dim==blocks(A,2) ) - - call petsc_csr_assemble(A) - - ! copy b to petsc vector - bvec=PetscNumberingCreateVec(A%column_numbering) - call field2petsc(b, A%column_numbering, bvec) - ! creates PETSc solution vec of the right size: - xvec=PetscNumberingCreateVec(A%row_numbering) - - ! perform the multiply - call MatMult(A%M, bvec, xvec, ierr) - ! copy answer back to vector_field - call petsc2field(xvec, A%row_numbering, x) - ! destroy the PETSc vecs - call VecDestroy(bvec, ierr) - call VecDestroy(xvec, ierr) - - end subroutine petsc_csr_mult_vector - - subroutine petsc_csr_mult_vector_to_scalar(x, A, b) - !!< Performs the matrix-scalar multiplication x=Ab - type(scalar_field), intent(inout):: x - type(petsc_csr_matrix), intent(inout):: A - type(vector_field), intent(in):: b - - PetscErrorCode:: ierr - Vec:: bvec, xvec - - assert( node_count(x)==block_size(A, 1) ) - assert( node_count(b)==block_size(A, 2) ) - assert( 1==blocks(A,1) ) - assert( b%dim==blocks(A,2) ) - - call petsc_csr_assemble(A) - - ! copy b to petsc vector - bvec=PetscNumberingCreateVec(A%column_numbering) - call field2petsc(b, A%column_numbering, bvec) - ! creates PETSc solution vec of the right size: - xvec=PetscNumberingCreateVec(A%row_numbering) - ! perform the multiply - call MatMult(A%M, bvec, xvec, ierr) - ! copy answer back to vector_field - call petsc2field(xvec, A%row_numbering, x) - ! destroy the PETSc vecs - call VecDestroy(bvec, ierr) - call VecDestroy(xvec, ierr) - - end subroutine petsc_csr_mult_vector_to_scalar - - subroutine petsc_csr_mult_T_vector(x, A, b) - !!< Performs the matrix-vector multiplication x=Ab - type(vector_field), intent(inout):: x - type(petsc_csr_matrix), intent(inout):: A - type(vector_field), intent(in):: b - - PetscErrorCode:: ierr - Vec:: bvec, xvec - - assert( node_count(x)==block_size(A, 2) ) - assert( node_count(b)==block_size(A, 1) ) - assert( x%dim==blocks(A,2) ) - assert( b%dim==blocks(A,1) ) - - call petsc_csr_assemble(A) - - ! copy b to petsc vector - bvec=PetscNumberingCreateVec(A%row_numbering) - call field2petsc(b, A%row_numbering, bvec) - ! creates PETSc solution vec of the right size: - xvec=PetscNumberingCreateVec(A%column_numbering) - ! perform the multiply - call MatMultTranspose(A%M, bvec, xvec, ierr) - ! copy answer back to vector_field - call petsc2field(xvec, A%column_numbering, x) - ! destroy the PETSc vecs - call VecDestroy(bvec, ierr) - call VecDestroy(xvec, ierr) - - end subroutine petsc_csr_mult_T_vector - - subroutine petsc_csr_mult_T_scalar_to_vector(x, A, b) - !!< Performs the matrix-scalar multiplication x=Ab - type(vector_field), intent(inout):: x - type(petsc_csr_matrix), intent(inout):: A - type(scalar_field), intent(in):: b - - PetscErrorCode:: ierr - Vec:: bvec, xvec - - assert( node_count(x)==block_size(A, 2) ) - assert( node_count(b)==block_size(A, 1) ) - assert( x%dim==blocks(A,2) ) - assert( 1==blocks(A,1) ) - - call petsc_csr_assemble(A) - - ! copy b to petsc vector - bvec=PetscNumberingCreateVec(A%row_numbering) - call field2petsc(b, A%row_numbering, bvec) - ! creates PETSc solution vec of the right size: - xvec=PetscNumberingCreateVec(A%column_numbering) - ! perform the multiply - call MatMultTranspose(A%M, bvec, xvec, ierr) - ! copy answer back to vector_field - call petsc2field(xvec, A%column_numbering, x) - ! destroy the PETSc vecs - call VecDestroy(bvec, ierr) - call VecDestroy(xvec, ierr) - - end subroutine petsc_csr_mult_T_scalar_to_vector - - subroutine lift_boundary_conditions(A, boundary_nodes, rhs) - type(petsc_csr_matrix), intent(inout):: A - type(integer_set), dimension(:):: boundary_nodes - type(vector_field), intent(inout), optional:: rhs - - Vec:: bvec, xvec, diag - type(integer_set):: row_set - PetscInt, dimension(:), allocatable:: node_list - PetscScalar, dimension(:), allocatable:: old_diagonal_values, unscaled_rhs_values - PetscScalar, parameter:: pivot = 1.0 - PetscErrorCode:: ierr - integer:: i, j, row - - logical, parameter:: fix_scaling = .true. - - assert( blocks(A,1)==size(boundary_nodes) ) - - call assemble(A) - - ! MatZeroRowsColumns seems to not ignore negative row indices - ! so first, create a set of petsc rows with negatives removed: - call allocate(row_set) - - do i=1, size(boundary_nodes) - do j=1, key_count(boundary_nodes(i)) - row = A%row_numbering%gnn2unn(fetch(boundary_nodes(i), j), i) - if (row>=0) then - call insert(row_set, row) - end if - end do - end do + ! perform the multiply + call MatMult(A%M, bvec, xvec, ierr) + ! copy answer back to vector_field + call petsc2field(xvec, A%row_numbering, x) + ! destroy the PETSc vecs + call VecDestroy(bvec, ierr) + call VecDestroy(xvec, ierr) + + end subroutine petsc_csr_mult_vector + + subroutine petsc_csr_mult_vector_to_scalar(x, A, b) + !!< Performs the matrix-scalar multiplication x=Ab + type(scalar_field), intent(inout):: x + type(petsc_csr_matrix), intent(inout):: A + type(vector_field), intent(in):: b + + PetscErrorCode:: ierr + Vec:: bvec, xvec + + assert( node_count(x)==block_size(A, 1) ) + assert( node_count(b)==block_size(A, 2) ) + assert( 1==blocks(A,1) ) + assert( b%dim==blocks(A,2) ) + + call petsc_csr_assemble(A) + + ! copy b to petsc vector + bvec=PetscNumberingCreateVec(A%column_numbering) + call field2petsc(b, A%column_numbering, bvec) + ! creates PETSc solution vec of the right size: + xvec=PetscNumberingCreateVec(A%row_numbering) + ! perform the multiply + call MatMult(A%M, bvec, xvec, ierr) + ! copy answer back to vector_field + call petsc2field(xvec, A%row_numbering, x) + ! destroy the PETSc vecs + call VecDestroy(bvec, ierr) + call VecDestroy(xvec, ierr) - allocate(node_list(1:key_count(row_set))) - node_list = set2vector(row_set) - call deallocate(row_set) + end subroutine petsc_csr_mult_vector_to_scalar + subroutine petsc_csr_mult_T_vector(x, A, b) + !!< Performs the matrix-vector multiplication x=Ab + type(vector_field), intent(inout):: x + type(petsc_csr_matrix), intent(inout):: A + type(vector_field), intent(in):: b + PetscErrorCode:: ierr + Vec:: bvec, xvec - if (present(rhs)) then + assert( node_count(x)==block_size(A, 2) ) + assert( node_count(b)==block_size(A, 1) ) + assert( x%dim==blocks(A,2) ) + assert( b%dim==blocks(A,1) ) - assert( blocks(A,1)==rhs%dim ) - assert( block_size(A,1)==node_count(rhs) ) + call petsc_csr_assemble(A) + ! copy b to petsc vector bvec=PetscNumberingCreateVec(A%row_numbering) - call field2petsc(rhs, A%row_numbering, bvec) - - ! make a copy xvec - the boundary values are taken from xvec - ! I suspect supplying bvec twice to MatZeroRowsColumns wouldn't give the - ! right answer as the entry associated with a boundary node might be modified - ! before being used as boundary value - call VecDuplicate(bvec, xvec, ierr) - call VecCopy(bvec, xvec, ierr) - if (fix_scaling) then - call VecDuplicate(bvec, diag, ierr) - end if + call field2petsc(b, A%row_numbering, bvec) + ! creates PETSc solution vec of the right size: + xvec=PetscNumberingCreateVec(A%column_numbering) + ! perform the multiply + call MatMultTranspose(A%M, bvec, xvec, ierr) + ! copy answer back to vector_field + call petsc2field(xvec, A%column_numbering, x) + ! destroy the PETSc vecs + call VecDestroy(bvec, ierr) + call VecDestroy(xvec, ierr) - else + end subroutine petsc_csr_mult_T_vector - xvec = PETSC_NULL_VEC - bvec = PETSC_NULL_VEC - if (fix_scaling) then - diag = PetscNumberingCreateVec(A%row_numbering) - end if + subroutine petsc_csr_mult_T_scalar_to_vector(x, A, b) + !!< Performs the matrix-scalar multiplication x=Ab + type(vector_field), intent(inout):: x + type(petsc_csr_matrix), intent(inout):: A + type(scalar_field), intent(in):: b - end if + PetscErrorCode:: ierr + Vec:: bvec, xvec - if (fix_scaling) then - ! save current diagonal to fix scaling afterwards - call MatGetDiagonal(A%M, diag, ierr) - end if + assert( node_count(x)==block_size(A, 2) ) + assert( node_count(b)==block_size(A, 1) ) + assert( x%dim==blocks(A,2) ) + assert( 1==blocks(A,1) ) + + call petsc_csr_assemble(A) + + ! copy b to petsc vector + bvec=PetscNumberingCreateVec(A%row_numbering) + call field2petsc(b, A%row_numbering, bvec) + ! creates PETSc solution vec of the right size: + xvec=PetscNumberingCreateVec(A%column_numbering) + ! perform the multiply + call MatMultTranspose(A%M, bvec, xvec, ierr) + ! copy answer back to vector_field + call petsc2field(xvec, A%column_numbering, x) + ! destroy the PETSc vecs + call VecDestroy(bvec, ierr) + call VecDestroy(xvec, ierr) + + end subroutine petsc_csr_mult_T_scalar_to_vector + + subroutine lift_boundary_conditions(A, boundary_nodes, rhs) + type(petsc_csr_matrix), intent(inout):: A + type(integer_set), dimension(:):: boundary_nodes + type(vector_field), intent(inout), optional:: rhs + + Vec:: bvec, xvec, diag + type(integer_set):: row_set + PetscInt, dimension(:), allocatable:: node_list + PetscScalar, dimension(:), allocatable:: old_diagonal_values, unscaled_rhs_values + PetscScalar, parameter:: pivot = 1.0 + PetscErrorCode:: ierr + integer:: i, j, row + + logical, parameter:: fix_scaling = .true. + + assert( blocks(A,1)==size(boundary_nodes) ) + + call assemble(A) + + ! MatZeroRowsColumns seems to not ignore negative row indices + ! so first, create a set of petsc rows with negatives removed: + call allocate(row_set) + + do i=1, size(boundary_nodes) + do j=1, key_count(boundary_nodes(i)) + row = A%row_numbering%gnn2unn(fetch(boundary_nodes(i), j), i) + if (row>=0) then + call insert(row_set, row) + end if + end do + end do + + allocate(node_list(1:key_count(row_set))) + node_list = set2vector(row_set) + call deallocate(row_set) - call MatZeroRowsColumns(A%M, size(node_list), node_list, & - pivot, xvec, bvec, ierr) - if (fix_scaling) then - ! fix_scaling is an option to rescale the pivots used on the diagonal for the lifted bc rows - ! this is to work around an issue with GAMG on a matrix where the blocksize is set - where - ! the pivot value may change the strong connection criterion for the entire block - thus a strong - ! free slip node may become decoupled from the rest of the problem in the aggregation procedure - allocate(old_diagonal_values(1:size(node_list))) - if (size(node_list)>0) then ! work around bug in vecgetvalues for 0-lenght arrays - call VecGetValues(diag, size(node_list), node_list, old_diagonal_values, ierr) - end if if (present(rhs)) then - allocate(unscaled_rhs_values(1:size(node_list))) - if (size(node_list)>0) then ! work around bug in vecgetvalues for 0-lenght arrays - call VecGetValues(bvec, size(node_list), node_list, unscaled_rhs_values, ierr) - end if + + assert( blocks(A,1)==rhs%dim ) + assert( block_size(A,1)==node_count(rhs) ) + + bvec=PetscNumberingCreateVec(A%row_numbering) + call field2petsc(rhs, A%row_numbering, bvec) + + ! make a copy xvec - the boundary values are taken from xvec + ! I suspect supplying bvec twice to MatZeroRowsColumns wouldn't give the + ! right answer as the entry associated with a boundary node might be modified + ! before being used as boundary value + call VecDuplicate(bvec, xvec, ierr) + call VecCopy(bvec, xvec, ierr) + if (fix_scaling) then + call VecDuplicate(bvec, diag, ierr) + end if + + else + + xvec = PETSC_NULL_VEC + bvec = PETSC_NULL_VEC + if (fix_scaling) then + diag = PetscNumberingCreateVec(A%row_numbering) + end if + end if - do i=1, size(node_list) - j=node_list(i) - call MatSetValue(A%M, j, j, old_diagonal_values(i), INSERT_VALUES, ierr) - if (present(rhs)) then - call VecSetValue(bvec, j, old_diagonal_values(i)*unscaled_rhs_values(i), INSERT_VALUES, ierr) - end if - end do - call MatAssemblyBegin(A%M, MAT_FINAL_ASSEMBLY, ierr) - call MatAssemblyEnd(A%M, MAT_FINAL_ASSEMBLY, ierr) - deallocate(old_diagonal_values) - call VecDestroy(diag, ierr) + + if (fix_scaling) then + ! save current diagonal to fix scaling afterwards + call MatGetDiagonal(A%M, diag, ierr) + end if + + call MatZeroRowsColumns(A%M, size(node_list), node_list, & + pivot, xvec, bvec, ierr) + + if (fix_scaling) then + ! fix_scaling is an option to rescale the pivots used on the diagonal for the lifted bc rows + ! this is to work around an issue with GAMG on a matrix where the blocksize is set - where + ! the pivot value may change the strong connection criterion for the entire block - thus a strong + ! free slip node may become decoupled from the rest of the problem in the aggregation procedure + allocate(old_diagonal_values(1:size(node_list))) + if (size(node_list)>0) then ! work around bug in vecgetvalues for 0-lenght arrays + call VecGetValues(diag, size(node_list), node_list, old_diagonal_values, ierr) + end if + + if (present(rhs)) then + allocate(unscaled_rhs_values(1:size(node_list))) + if (size(node_list)>0) then ! work around bug in vecgetvalues for 0-lenght arrays + call VecGetValues(bvec, size(node_list), node_list, unscaled_rhs_values, ierr) + end if + end if + do i=1, size(node_list) + j=node_list(i) + call MatSetValue(A%M, j, j, old_diagonal_values(i), INSERT_VALUES, ierr) + if (present(rhs)) then + call VecSetValue(bvec, j, old_diagonal_values(i)*unscaled_rhs_values(i), INSERT_VALUES, ierr) + end if + end do + call MatAssemblyBegin(A%M, MAT_FINAL_ASSEMBLY, ierr) + call MatAssemblyEnd(A%M, MAT_FINAL_ASSEMBLY, ierr) + deallocate(old_diagonal_values) + call VecDestroy(diag, ierr) + if (present(rhs)) then + call VecAssemblyBegin(bvec, ierr) + call VecAssemblyEnd(bvec, ierr) + deallocate(unscaled_rhs_values) + end if + end if + + deallocate(node_list) if (present(rhs)) then - call VecAssemblyBegin(bvec, ierr) - call VecAssemblyEnd(bvec, ierr) - deallocate(unscaled_rhs_values) + call petsc2field(bvec, A%row_numbering, rhs) + call VecDestroy(xvec, ierr) + call VecDestroy(bvec, ierr) end if - end if - deallocate(node_list) - if (present(rhs)) then - call petsc2field(bvec, A%row_numbering, rhs) - call VecDestroy(xvec, ierr) - call VecDestroy(bvec, ierr) - end if - - end subroutine lift_boundary_conditions - - subroutine dump_matrix(name,A) - character(len=*), intent(in):: name - type(petsc_csr_matrix):: A - Vec:: x0, b - - x0=PetscNumberingCreateVec(A%column_numbering) - b=PetscNumberingCreateVec(A%row_numbering) - call DumpMatrixEquation(name, x0, A%M, b) - - end subroutine dump_matrix - - function csr2petsc_csr(matrix, use_inodes) result (A) - type(csr_matrix), intent(in):: matrix - logical, intent(in), optional:: use_inodes - type(petsc_csr_matrix):: A - - Mat:: M - type(petsc_numbering_type):: row_numbering, column_numbering - logical, dimension(:), pointer:: inactive_mask - integer, dimension(:), allocatable:: ghost_nodes - integer:: i, j - - inactive_mask => get_inactive_mask(matrix) - ! create list of inactive, ghost_nodes - if (associated(inactive_mask)) then - allocate( ghost_nodes(1:count(inactive_mask)) ) - j=0 - do i=1, size(matrix,1) - if (inactive_mask(i)) then - j=j+1 - ghost_nodes(j)=i - end if - end do - else - allocate( ghost_nodes(1:0) ) - end if + end subroutine lift_boundary_conditions + + subroutine dump_matrix(name,A) + character(len=*), intent(in):: name + type(petsc_csr_matrix):: A + Vec:: x0, b + + x0=PetscNumberingCreateVec(A%column_numbering) + b=PetscNumberingCreateVec(A%row_numbering) + call DumpMatrixEquation(name, x0, A%M, b) + + end subroutine dump_matrix + + function csr2petsc_csr(matrix, use_inodes) result (A) + type(csr_matrix), intent(in):: matrix + logical, intent(in), optional:: use_inodes + type(petsc_csr_matrix):: A + + Mat:: M + type(petsc_numbering_type):: row_numbering, column_numbering + logical, dimension(:), pointer:: inactive_mask + integer, dimension(:), allocatable:: ghost_nodes + integer:: i, j + + inactive_mask => get_inactive_mask(matrix) + ! create list of inactive, ghost_nodes + if (associated(inactive_mask)) then + allocate( ghost_nodes(1:count(inactive_mask)) ) + j=0 + do i=1, size(matrix,1) + if (inactive_mask(i)) then + j=j+1 + ghost_nodes(j)=i + end if + end do + else + allocate( ghost_nodes(1:0) ) + end if - ! note: the row/column_halo is passed as a pointer, and is allowed to be disassociated - call allocate(row_numbering, size(matrix, 1), 1, & - halo=matrix%sparsity%row_halo, ghost_nodes=ghost_nodes) - call allocate(column_numbering, size(matrix, 2), 1, & - halo=matrix%sparsity%column_halo, ghost_nodes=ghost_nodes) - M=csr2petsc(matrix, row_numbering, column_numbering) - call allocate(A, M, row_numbering, column_numbering, & - name=trim(matrix%name), use_inodes=use_inodes) - call deallocate(row_numbering) - call deallocate(column_numbering) + ! note: the row/column_halo is passed as a pointer, and is allowed to be disassociated + call allocate(row_numbering, size(matrix, 1), 1, & + halo=matrix%sparsity%row_halo, ghost_nodes=ghost_nodes) + call allocate(column_numbering, size(matrix, 2), 1, & + halo=matrix%sparsity%column_halo, ghost_nodes=ghost_nodes) + M=csr2petsc(matrix, row_numbering, column_numbering) + call allocate(A, M, row_numbering, column_numbering, & + name=trim(matrix%name), use_inodes=use_inodes) + call deallocate(row_numbering) + call deallocate(column_numbering) - end function csr2petsc_csr + end function csr2petsc_csr - subroutine dump_petsc_csr_matrix(matrix) - !! Dumps a petsc_csr_matrix, along with dummy solution and RHS vectors, - !! that can be used by petscreadnsolve. + subroutine dump_petsc_csr_matrix(matrix) + !! Dumps a petsc_csr_matrix, along with dummy solution and RHS vectors, + !! that can be used by petscreadnsolve. - type(petsc_csr_matrix), intent(inout) :: matrix + type(petsc_csr_matrix), intent(inout) :: matrix - PetscErrorCode:: ierr - Vec:: diagonal_vec - integer, save:: index=1 + PetscErrorCode:: ierr + Vec:: diagonal_vec + integer, save:: index=1 - call petsc_csr_assemble(matrix) + call petsc_csr_assemble(matrix) - diagonal_vec=PetscNumberingCreateVec(matrix%row_numbering) + diagonal_vec=PetscNumberingCreateVec(matrix%row_numbering) - call DumpMatrixEquation('PetscCSRdump'//int2str(index), diagonal_vec, matrix%M, diagonal_vec) - index=index+1 + call DumpMatrixEquation('PetscCSRdump'//int2str(index), diagonal_vec, matrix%M, diagonal_vec) + index=index+1 - call VecDestroy(diagonal_vec, ierr) + call VecDestroy(diagonal_vec, ierr) - end subroutine dump_petsc_csr_matrix + end subroutine dump_petsc_csr_matrix #include "Reference_count_petsc_csr_matrix.F90" end module sparse_tools_petsc diff --git a/femtools/Sparsity_Patterns.F90 b/femtools/Sparsity_Patterns.F90 index fe3d6c6ad0..24f655d394 100644 --- a/femtools/Sparsity_Patterns.F90 +++ b/femtools/Sparsity_Patterns.F90 @@ -27,404 +27,404 @@ #include "fdebug.h" module sparsity_patterns - ! This module produces sparsity patterns for matrices. - use fldebug - use linked_lists - use elements - use sparse_tools - use fields_data_types - use fields_base - implicit none + ! This module produces sparsity patterns for matrices. + use fldebug + use linked_lists + use elements + use sparse_tools + use fields_data_types + use fields_base + implicit none - private + private - public :: make_sparsity, make_sparsity_transpose, make_sparsity_mult,& - make_sparsity_dg_mass, make_sparsity_compactdgdouble,& - make_sparsity_lists, lists2csr_sparsity + public :: make_sparsity, make_sparsity_transpose, make_sparsity_mult,& + make_sparsity_dg_mass, make_sparsity_compactdgdouble,& + make_sparsity_lists, lists2csr_sparsity contains - function make_sparsity(rowmesh, colmesh, name) result (sparsity) - ! Produce the sparsity of a first degree operator mapping from colmesh - ! to rowmesh. - type(ilist), dimension(:), pointer :: list_matrix - type(csr_sparsity) :: sparsity - type(mesh_type), intent(in) :: colmesh, rowmesh - character(len=*), intent(in) :: name - - integer :: row_count, i + function make_sparsity(rowmesh, colmesh, name) result (sparsity) + ! Produce the sparsity of a first degree operator mapping from colmesh + ! to rowmesh. + type(ilist), dimension(:), pointer :: list_matrix + type(csr_sparsity) :: sparsity + type(mesh_type), intent(in) :: colmesh, rowmesh + character(len=*), intent(in) :: name + + integer :: row_count, i - row_count=node_count(rowmesh) - - allocate(list_matrix(row_count)) + row_count=node_count(rowmesh) + + allocate(list_matrix(row_count)) - list_matrix=make_sparsity_lists(rowmesh, colmesh) - - sparsity=lists2csr_sparsity(list_matrix, name) - sparsity%columns=node_count(colmesh) - sparsity%sorted_rows=.true. - - do i=1,row_count - call flush_list(list_matrix(i)) - end do - - ! Since this is a degree one operator, use the first halo. - if (associated(rowmesh%halos)) then - allocate(sparsity%row_halo) - sparsity%row_halo=rowmesh%halos(1) - call incref(sparsity%row_halo) - end if - if (associated(colmesh%halos)) then - allocate(sparsity%column_halo) - sparsity%column_halo=colmesh%halos(1) - call incref(sparsity%column_halo) - end if - - deallocate(list_matrix) - - end function make_sparsity - - function make_sparsity_transpose(outsidemesh, insidemesh, name) result (sparsity) - ! Produce the sparsity of a second degree operator formed by the - ! operation C^TC. C is insidemesh by outsidemesh so the resulting - ! sparsity is outsidemesh squared. - type(csr_sparsity) :: sparsity - type(mesh_type), intent(in) :: outsidemesh, insidemesh - character(len=*), intent(in) :: name - - type(ilist), dimension(:), pointer :: list_matrix, list_matrix_out - integer :: row_count, row_count_out, i, j, k - integer, dimension(:), allocatable :: row - - row_count=node_count(insidemesh) - row_count_out=node_count(outsidemesh) - - allocate(list_matrix(row_count)) - allocate(list_matrix_out(row_count_out)) - - ! Generate the first order operator C. - list_matrix=make_sparsity_lists(insidemesh, outsidemesh) - - - ! Generate the sparsity of C^TC - do i=1,row_count - allocate(row(list_matrix(i)%length)) - - row=list2vector(list_matrix(i)) - - do j=1,size(row) - do k=1,size(row) - call insert_ascending(list_matrix_out(row(j)),row(k)) - end do - end do - - deallocate(row) - end do - - sparsity=lists2csr_sparsity(list_matrix_out, name) - ! Note that the resulting sparsity is outsidemesh square. - sparsity%columns=node_count(outsidemesh) - sparsity%sorted_rows=.true. - - ! Second order operater so halo(2) - if (associated(outsidemesh%halos)) then - allocate(sparsity%row_halo) - sparsity%row_halo=outsidemesh%halos(2) - call incref(sparsity%row_halo) - allocate(sparsity%column_halo) - sparsity%column_halo=outsidemesh%halos(2) - call incref(sparsity%column_halo) - end if - - do i=1,row_count - call flush_list(list_matrix(i)) - end do - do i=1,row_count_out - call flush_list(list_matrix_out(i)) - end do - - deallocate(list_matrix, list_matrix_out) - - end function make_sparsity_transpose - - function make_sparsity_mult(mesh1, mesh2, mesh3, name) result (sparsity) - ! Produce the sparsity of a second degree operator formed by the - ! operation A B, where A is mesh1 x mesh2 and B is mesh2 x mesh3 - type(csr_sparsity) :: sparsity - type(mesh_type), intent(in) :: mesh1, mesh2, mesh3 - character(len=*), intent(in) :: name - - type(ilist), dimension(:), pointer :: list_matrix_1, list_matrix_3, list_matrix_out - integer :: count_1, count_2, count_3, i, j, k - integer, dimension(:), allocatable :: row_1, row_3 - - count_1=node_count(mesh1) - count_2=node_count(mesh2) - count_3=node_count(mesh3) - - allocate(list_matrix_1(count_2)) - allocate(list_matrix_3(count_2)) - allocate(list_matrix_out(count_1)) - - list_matrix_1=make_sparsity_lists(mesh2, mesh1) - list_matrix_3=make_sparsity_lists(mesh2, mesh3) - - ! Generate the sparsity of A B - do i=1,count_2 - allocate(row_1(list_matrix_1(i)%length)) - allocate(row_3(list_matrix_3(i)%length)) - - row_1=list2vector(list_matrix_1(i)) - row_3=list2vector(list_matrix_3(i)) - - do j=1,size(row_3) - do k=1,size(row_1) - call insert_ascending(list_matrix_out(row_1(k)),row_3(j)) - end do - end do - - deallocate(row_1) - deallocate(row_3) - end do - - sparsity=lists2csr_sparsity(list_matrix_out, name) - sparsity%columns=count_3 - sparsity%sorted_rows=.true. - - ! Second order operater so halo(2) - if (associated(mesh1%halos)) then - assert(associated(mesh3%halos)) - allocate(sparsity%row_halo) - sparsity%row_halo=mesh1%halos(2) - call incref(sparsity%row_halo) - allocate(sparsity%column_halo) - sparsity%column_halo=mesh3%halos(2) - call incref(sparsity%column_halo) - end if - - call deallocate(list_matrix_1) - call deallocate(list_matrix_3) - call deallocate(list_matrix_out) - deallocate(list_matrix_1, list_matrix_3, list_matrix_out) - - end function make_sparsity_mult - - function make_sparsity_dg_mass(mesh) result (sparsity) - !!< Produce the sparsity pattern of a DG mass matrix. These matrices - !!< are block diagonal as there is no communication between the - !!< elements. - !!< - !!< Note that this currently assumes that the mesh has uniform - !!< elements. - type(csr_sparsity) :: sparsity - type(mesh_type), intent(in) :: mesh - - integer :: nonzeros, nodes, elements, nloc - integer :: i,j,k - - nloc=mesh%shape%loc ! Nodes per element - nodes=node_count(mesh) ! Total nodes - elements=element_count(mesh) ! Total elements - nonzeros=nloc**2*elements - - call allocate(sparsity, rows=nodes, columns=nodes,& - & entries=nonzeros, diag=.false., name="DGMassSparsity") - - forall (i=1:elements, j=1:nloc, k=1:nloc) - sparsity%colm((i-1)*nloc**2+(j-1)*nloc+k)& + list_matrix=make_sparsity_lists(rowmesh, colmesh) + + sparsity=lists2csr_sparsity(list_matrix, name) + sparsity%columns=node_count(colmesh) + sparsity%sorted_rows=.true. + + do i=1,row_count + call flush_list(list_matrix(i)) + end do + + ! Since this is a degree one operator, use the first halo. + if (associated(rowmesh%halos)) then + allocate(sparsity%row_halo) + sparsity%row_halo=rowmesh%halos(1) + call incref(sparsity%row_halo) + end if + if (associated(colmesh%halos)) then + allocate(sparsity%column_halo) + sparsity%column_halo=colmesh%halos(1) + call incref(sparsity%column_halo) + end if + + deallocate(list_matrix) + + end function make_sparsity + + function make_sparsity_transpose(outsidemesh, insidemesh, name) result (sparsity) + ! Produce the sparsity of a second degree operator formed by the + ! operation C^TC. C is insidemesh by outsidemesh so the resulting + ! sparsity is outsidemesh squared. + type(csr_sparsity) :: sparsity + type(mesh_type), intent(in) :: outsidemesh, insidemesh + character(len=*), intent(in) :: name + + type(ilist), dimension(:), pointer :: list_matrix, list_matrix_out + integer :: row_count, row_count_out, i, j, k + integer, dimension(:), allocatable :: row + + row_count=node_count(insidemesh) + row_count_out=node_count(outsidemesh) + + allocate(list_matrix(row_count)) + allocate(list_matrix_out(row_count_out)) + + ! Generate the first order operator C. + list_matrix=make_sparsity_lists(insidemesh, outsidemesh) + + + ! Generate the sparsity of C^TC + do i=1,row_count + allocate(row(list_matrix(i)%length)) + + row=list2vector(list_matrix(i)) + + do j=1,size(row) + do k=1,size(row) + call insert_ascending(list_matrix_out(row(j)),row(k)) + end do + end do + + deallocate(row) + end do + + sparsity=lists2csr_sparsity(list_matrix_out, name) + ! Note that the resulting sparsity is outsidemesh square. + sparsity%columns=node_count(outsidemesh) + sparsity%sorted_rows=.true. + + ! Second order operater so halo(2) + if (associated(outsidemesh%halos)) then + allocate(sparsity%row_halo) + sparsity%row_halo=outsidemesh%halos(2) + call incref(sparsity%row_halo) + allocate(sparsity%column_halo) + sparsity%column_halo=outsidemesh%halos(2) + call incref(sparsity%column_halo) + end if + + do i=1,row_count + call flush_list(list_matrix(i)) + end do + do i=1,row_count_out + call flush_list(list_matrix_out(i)) + end do + + deallocate(list_matrix, list_matrix_out) + + end function make_sparsity_transpose + + function make_sparsity_mult(mesh1, mesh2, mesh3, name) result (sparsity) + ! Produce the sparsity of a second degree operator formed by the + ! operation A B, where A is mesh1 x mesh2 and B is mesh2 x mesh3 + type(csr_sparsity) :: sparsity + type(mesh_type), intent(in) :: mesh1, mesh2, mesh3 + character(len=*), intent(in) :: name + + type(ilist), dimension(:), pointer :: list_matrix_1, list_matrix_3, list_matrix_out + integer :: count_1, count_2, count_3, i, j, k + integer, dimension(:), allocatable :: row_1, row_3 + + count_1=node_count(mesh1) + count_2=node_count(mesh2) + count_3=node_count(mesh3) + + allocate(list_matrix_1(count_2)) + allocate(list_matrix_3(count_2)) + allocate(list_matrix_out(count_1)) + + list_matrix_1=make_sparsity_lists(mesh2, mesh1) + list_matrix_3=make_sparsity_lists(mesh2, mesh3) + + ! Generate the sparsity of A B + do i=1,count_2 + allocate(row_1(list_matrix_1(i)%length)) + allocate(row_3(list_matrix_3(i)%length)) + + row_1=list2vector(list_matrix_1(i)) + row_3=list2vector(list_matrix_3(i)) + + do j=1,size(row_3) + do k=1,size(row_1) + call insert_ascending(list_matrix_out(row_1(k)),row_3(j)) + end do + end do + + deallocate(row_1) + deallocate(row_3) + end do + + sparsity=lists2csr_sparsity(list_matrix_out, name) + sparsity%columns=count_3 + sparsity%sorted_rows=.true. + + ! Second order operater so halo(2) + if (associated(mesh1%halos)) then + assert(associated(mesh3%halos)) + allocate(sparsity%row_halo) + sparsity%row_halo=mesh1%halos(2) + call incref(sparsity%row_halo) + allocate(sparsity%column_halo) + sparsity%column_halo=mesh3%halos(2) + call incref(sparsity%column_halo) + end if + + call deallocate(list_matrix_1) + call deallocate(list_matrix_3) + call deallocate(list_matrix_out) + deallocate(list_matrix_1, list_matrix_3, list_matrix_out) + + end function make_sparsity_mult + + function make_sparsity_dg_mass(mesh) result (sparsity) + !!< Produce the sparsity pattern of a DG mass matrix. These matrices + !!< are block diagonal as there is no communication between the + !!< elements. + !!< + !!< Note that this currently assumes that the mesh has uniform + !!< elements. + type(csr_sparsity) :: sparsity + type(mesh_type), intent(in) :: mesh + + integer :: nonzeros, nodes, elements, nloc + integer :: i,j,k + + nloc=mesh%shape%loc ! Nodes per element + nodes=node_count(mesh) ! Total nodes + elements=element_count(mesh) ! Total elements + nonzeros=nloc**2*elements + + call allocate(sparsity, rows=nodes, columns=nodes,& + & entries=nonzeros, diag=.false., name="DGMassSparsity") + + forall (i=1:elements, j=1:nloc, k=1:nloc) + sparsity%colm((i-1)*nloc**2+(j-1)*nloc+k)& =(i-1)*nloc+k - end forall - - forall (i=1:nodes+1) - sparsity%findrm(i)=(i-1)*nloc+1 - end forall - sparsity%sorted_rows=.true. - - if (associated(mesh%halos)) then - allocate(sparsity%row_halo) - sparsity%row_halo=mesh%halos(1) - call incref(sparsity%row_halo) - allocate(sparsity%column_halo) - sparsity%column_halo=mesh%halos(1) - call incref(sparsity%column_halo) - end if - - end function make_sparsity_dg_mass - - function make_sparsity_compactdgdouble(& - mesh, name) result (sparsity) - !!< Produce the sparsity pattern of a second order compact dg stencil. - !!< This means: Each node is coupled to the nodes in that element, - !!< plus the nodes in all other elements which share a face with that - !!< element. - !!< - !!< Note that this currently assumes that the mesh has uniform - !!< elements. - type(ilist), dimension(:), pointer :: list_matrix - type(csr_sparsity) :: sparsity - type(mesh_type), intent(in) :: mesh - character(len=*), intent(in) :: name - - integer :: row_count, i - - row_count=node_count(mesh) - - allocate(list_matrix(row_count)) - - list_matrix=make_sparsity_lists(mesh,mesh, & - & include_all_neighbour_element_nodes = .true.) - - sparsity=lists2csr_sparsity(list_matrix, name) - sparsity%columns=node_count(mesh) - sparsity%sorted_rows=.true. - - do i=1,row_count - call flush_list(list_matrix(i)) - end do - - deallocate(list_matrix) - - ! Since the operator is compact, the level 1 halo should suffice. - if (associated(mesh%halos)) then - allocate(sparsity%row_halo) - sparsity%row_halo=mesh%halos(1) - call incref(sparsity%row_halo) - allocate(sparsity%column_halo) - sparsity%column_halo=mesh%halos(1) - call incref(sparsity%column_halo) - end if - - end function make_sparsity_compactdgdouble - - function make_sparsity_lists(rowmesh, colmesh, & - & include_all_neighbour_element_nodes) result (list_matrix) - ! Produce the sparsity of a first degree operator mapping from colmesh - ! to rowmesh. Return a listmatrix - ! Note this really ought to be mesh_type. - type(mesh_type), intent(in) :: colmesh, rowmesh - type(ilist), dimension(node_count(rowmesh)) :: list_matrix - logical, intent(in), optional :: & + end forall + + forall (i=1:nodes+1) + sparsity%findrm(i)=(i-1)*nloc+1 + end forall + sparsity%sorted_rows=.true. + + if (associated(mesh%halos)) then + allocate(sparsity%row_halo) + sparsity%row_halo=mesh%halos(1) + call incref(sparsity%row_halo) + allocate(sparsity%column_halo) + sparsity%column_halo=mesh%halos(1) + call incref(sparsity%column_halo) + end if + + end function make_sparsity_dg_mass + + function make_sparsity_compactdgdouble(& + mesh, name) result (sparsity) + !!< Produce the sparsity pattern of a second order compact dg stencil. + !!< This means: Each node is coupled to the nodes in that element, + !!< plus the nodes in all other elements which share a face with that + !!< element. + !!< + !!< Note that this currently assumes that the mesh has uniform + !!< elements. + type(ilist), dimension(:), pointer :: list_matrix + type(csr_sparsity) :: sparsity + type(mesh_type), intent(in) :: mesh + character(len=*), intent(in) :: name + + integer :: row_count, i + + row_count=node_count(mesh) + + allocate(list_matrix(row_count)) + + list_matrix=make_sparsity_lists(mesh,mesh, & + & include_all_neighbour_element_nodes = .true.) + + sparsity=lists2csr_sparsity(list_matrix, name) + sparsity%columns=node_count(mesh) + sparsity%sorted_rows=.true. + + do i=1,row_count + call flush_list(list_matrix(i)) + end do + + deallocate(list_matrix) + + ! Since the operator is compact, the level 1 halo should suffice. + if (associated(mesh%halos)) then + allocate(sparsity%row_halo) + sparsity%row_halo=mesh%halos(1) + call incref(sparsity%row_halo) + allocate(sparsity%column_halo) + sparsity%column_halo=mesh%halos(1) + call incref(sparsity%column_halo) + end if + + end function make_sparsity_compactdgdouble + + function make_sparsity_lists(rowmesh, colmesh, & + & include_all_neighbour_element_nodes) result (list_matrix) + ! Produce the sparsity of a first degree operator mapping from colmesh + ! to rowmesh. Return a listmatrix + ! Note this really ought to be mesh_type. + type(mesh_type), intent(in) :: colmesh, rowmesh + type(ilist), dimension(node_count(rowmesh)) :: list_matrix + logical, intent(in), optional :: & + & include_all_neighbour_element_nodes + + integer :: ele, i, j, face, neigh + integer, dimension(:), pointer :: row_ele, col_ele, face_ele, col_neigh + + logical :: l_include_all_neighbour_element_nodes + + l_include_all_neighbour_element_nodes = .false. + if(present(include_all_neighbour_element_nodes)) then + l_include_all_neighbour_element_nodes = & & include_all_neighbour_element_nodes - - integer :: ele, i, j, face, neigh - integer, dimension(:), pointer :: row_ele, col_ele, face_ele, col_neigh - - logical :: l_include_all_neighbour_element_nodes - - l_include_all_neighbour_element_nodes = .false. - if(present(include_all_neighbour_element_nodes)) then - l_include_all_neighbour_element_nodes = & - & include_all_neighbour_element_nodes - end if - - ! this should happen automatically through the initialisations - ! statements, but not in old gcc4s: - list_matrix%length=0 - - do ele=1,element_count(rowmesh) - row_ele=>ele_nodes(rowmesh, ele) - col_ele=>ele_nodes(colmesh, ele) - - do i=1,size(row_ele) - do j=1,size(col_ele) - ! Every node in row_ele receives contribution from every node - ! in col_ele - call insert_ascending(list_matrix(row_ele(i)),col_ele(j)) - end do - end do - - end do - - ! add in entries for boundary integrals if both row and column mesh are discontinuous - ! if rowmesh is continuous then we're only interested in coupling between continuous face nodes - ! and discontinuous nodes on the same face pair - the connection to the discontinuous nodes on the other - ! side will be added from the adjacent element, so nothing extra to do in this case - if (continuity(colmesh)<0 .and. (continuity(rowmesh)<0 .or. l_include_all_neighbour_element_nodes)) then - assert(has_faces(colmesh)) - - do ele=1,element_count(colmesh) - row_ele=>ele_nodes(rowmesh, ele) - col_neigh=>ele_neigh(colmesh, ele) - - do neigh=1,size(col_neigh) - ! Skip external faces - if (col_neigh(neigh)<=0) cycle - - face=ele_face(colmesh, col_neigh(neigh), ele) - face_ele=>face_local_nodes(colmesh, face) - col_ele=>ele_nodes(colmesh, col_neigh(neigh)) - - if(l_include_all_neighbour_element_nodes) then - do i=1,size(row_ele) - do j=1,size(col_ele) - call insert_ascending(list_matrix(row_ele(i))& - &,col_ele(j)) - end do - end do - else - - do i=1,size(row_ele) - do j=1,size(face_ele) - call insert_ascending(list_matrix(row_ele(i))& - &,col_ele(face_ele(j))) - end do - end do - end if - end do - - end do - - end if - - end function make_sparsity_lists - - function lists2csr_sparsity(lists, name) result (sparsity) - ! Take a dynamically assembled set of row lists and return a sparsity. - type(csr_sparsity) :: sparsity - character(len=*), intent(in):: name - type(ilist), dimension(:), intent(in) :: lists - - integer :: i, count, pos - - integer :: columns - - ! We have to figure out how many columns we have in this matrix - columns = -1 - do i=1,size(lists) - if(lists(i)%length/=0) columns = max(columns, maxval(lists(i))) - end do - - call allocate(sparsity, rows=size(lists), columns=columns, & + end if + + ! this should happen automatically through the initialisations + ! statements, but not in old gcc4s: + list_matrix%length=0 + + do ele=1,element_count(rowmesh) + row_ele=>ele_nodes(rowmesh, ele) + col_ele=>ele_nodes(colmesh, ele) + + do i=1,size(row_ele) + do j=1,size(col_ele) + ! Every node in row_ele receives contribution from every node + ! in col_ele + call insert_ascending(list_matrix(row_ele(i)),col_ele(j)) + end do + end do + + end do + + ! add in entries for boundary integrals if both row and column mesh are discontinuous + ! if rowmesh is continuous then we're only interested in coupling between continuous face nodes + ! and discontinuous nodes on the same face pair - the connection to the discontinuous nodes on the other + ! side will be added from the adjacent element, so nothing extra to do in this case + if (continuity(colmesh)<0 .and. (continuity(rowmesh)<0 .or. l_include_all_neighbour_element_nodes)) then + assert(has_faces(colmesh)) + + do ele=1,element_count(colmesh) + row_ele=>ele_nodes(rowmesh, ele) + col_neigh=>ele_neigh(colmesh, ele) + + do neigh=1,size(col_neigh) + ! Skip external faces + if (col_neigh(neigh)<=0) cycle + + face=ele_face(colmesh, col_neigh(neigh), ele) + face_ele=>face_local_nodes(colmesh, face) + col_ele=>ele_nodes(colmesh, col_neigh(neigh)) + + if(l_include_all_neighbour_element_nodes) then + do i=1,size(row_ele) + do j=1,size(col_ele) + call insert_ascending(list_matrix(row_ele(i))& + &,col_ele(j)) + end do + end do + else + + do i=1,size(row_ele) + do j=1,size(face_ele) + call insert_ascending(list_matrix(row_ele(i))& + &,col_ele(face_ele(j))) + end do + end do + end if + end do + + end do + + end if + + end function make_sparsity_lists + + function lists2csr_sparsity(lists, name) result (sparsity) + ! Take a dynamically assembled set of row lists and return a sparsity. + type(csr_sparsity) :: sparsity + character(len=*), intent(in):: name + type(ilist), dimension(:), intent(in) :: lists + + integer :: i, count, pos + + integer :: columns + + ! We have to figure out how many columns we have in this matrix + columns = -1 + do i=1,size(lists) + if(lists(i)%length/=0) columns = max(columns, maxval(lists(i))) + end do + + call allocate(sparsity, rows=size(lists), columns=columns, & entries=sum(lists(:)%length), name=name) - ! Lay out space for column indices. - count=1 - do i=1,size(lists) - sparsity%findrm(i)=count - count=count+lists(i)%length - end do - sparsity%findrm(size(lists)+1)=count - - ! Insert column indices. - do i=1,size(lists) - sparsity%colm(sparsity%findrm(i):sparsity%findrm(i+1)-1)& - &=list2vector(lists(i)) - end do - - ! Find diagonal. - do i=1,size(sparsity%centrm) - pos=0 - pos=minloc(row_m(sparsity,i), dim=1, mask=row_m(sparsity,i)==i) - if (pos>0) then - sparsity%centrm(i)=sparsity%findrm(i)+pos-1 - else - sparsity%centrm(i)=0 - ! The following warning was removed as it produces too many - ! spurious warnings. - !ewrite(2,*) "Warning: missing diagonal in lists2csr_sparsity" - end if - end do - - end function lists2csr_sparsity + ! Lay out space for column indices. + count=1 + do i=1,size(lists) + sparsity%findrm(i)=count + count=count+lists(i)%length + end do + sparsity%findrm(size(lists)+1)=count + + ! Insert column indices. + do i=1,size(lists) + sparsity%colm(sparsity%findrm(i):sparsity%findrm(i+1)-1)& + &=list2vector(lists(i)) + end do + + ! Find diagonal. + do i=1,size(sparsity%centrm) + pos=0 + pos=minloc(row_m(sparsity,i), dim=1, mask=row_m(sparsity,i)==i) + if (pos>0) then + sparsity%centrm(i)=sparsity%findrm(i)+pos-1 + else + sparsity%centrm(i)=0 + ! The following warning was removed as it produces too many + ! spurious warnings. + !ewrite(2,*) "Warning: missing diagonal in lists2csr_sparsity" + end if + end do + + end function lists2csr_sparsity end module sparsity_patterns diff --git a/femtools/Sparsity_Patterns_Meshes.F90 b/femtools/Sparsity_Patterns_Meshes.F90 index 4675876284..2791d5347c 100644 --- a/femtools/Sparsity_Patterns_Meshes.F90 +++ b/femtools/Sparsity_Patterns_Meshes.F90 @@ -26,176 +26,176 @@ ! USA #include "fdebug.h" module sparsity_patterns_meshes - !! Calculate shape functions and sparsity patterns. - use fldebug - use global_parameters, only : FIELD_NAME_LEN - use sparse_tools - use shape_functions - use sparsity_patterns - use fields - use state_module + !! Calculate shape functions and sparsity patterns. + use fldebug + use global_parameters, only : FIELD_NAME_LEN + use sparse_tools + use shape_functions + use sparsity_patterns + use fields + use state_module - implicit none + implicit none - private - public :: get_csr_sparsity_firstorder, get_csr_sparsity_secondorder, & - & get_csr_sparsity_compactdgdouble + private + public :: get_csr_sparsity_firstorder, get_csr_sparsity_secondorder, & + & get_csr_sparsity_compactdgdouble - interface get_csr_sparsity_firstorder - module procedure get_csr_sparsity_firstorder_single_state, get_csr_sparsity_firstorder_multiple_states - end interface + interface get_csr_sparsity_firstorder + module procedure get_csr_sparsity_firstorder_single_state, get_csr_sparsity_firstorder_multiple_states + end interface - interface get_csr_sparsity_secondorder - module procedure get_csr_sparsity_secondorder_single_state, get_csr_sparsity_secondorder_multiple_states - end interface + interface get_csr_sparsity_secondorder + module procedure get_csr_sparsity_secondorder_single_state, get_csr_sparsity_secondorder_multiple_states + end interface - interface get_csr_sparsity_compactdgdouble - module procedure get_csr_sparsity_compactdgdouble_single_state, get_csr_sparsity_compactdgdouble_multiple_states - end interface + interface get_csr_sparsity_compactdgdouble + module procedure get_csr_sparsity_compactdgdouble_single_state, get_csr_sparsity_compactdgdouble_multiple_states + end interface contains - function get_csr_sparsity_firstorder_single_state(state, rowmesh, colmesh) result(sparsity) - !!< Tries to extract a first order csr_sparsity from the supplied state using the name - !!< formula rowmesh%name//colmesh%name//Sparsity - !!< - !!< If unsuccesful it creates that sparsity and inserts it into state - !!< before returning a pointer to the newly created sparsity. - type(csr_sparsity), pointer :: sparsity - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: rowmesh, colmesh - - type(state_type), dimension(1) :: states - - states = (/state/) - sparsity=>get_csr_sparsity_firstorder(states, rowmesh, colmesh) - state = states(1) - - end function get_csr_sparsity_firstorder_single_state - - function get_csr_sparsity_firstorder_multiple_states(states, rowmesh, colmesh) result(sparsity) - !!< Tries to extract a first order csr_sparsity from any of the supplied states using the name - !!< formula rowmesh%name//colmesh%name//Sparsity - !!< - !!< If unsuccesful it creates that sparsity and inserts (and aliases) it into states - !!< before returning a pointer to the newly created sparsity. - type(csr_sparsity), pointer :: sparsity - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: rowmesh, colmesh - - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(csr_sparsity) :: temp_sparsity - - name = trim(rowmesh%name)//trim(colmesh%name)//"Sparsity" - - sparsity => extract_csr_sparsity(states, trim(name), stat) - - if(stat/=0) then - temp_sparsity=make_sparsity(rowmesh, colmesh, trim(name)) - call insert(states, temp_sparsity, trim(name)) - call deallocate(temp_sparsity) - - sparsity => extract_csr_sparsity(states, trim(name)) - end if - - end function get_csr_sparsity_firstorder_multiple_states - - function get_csr_sparsity_secondorder_single_state(state, rowmesh, colmesh) result(sparsity) - !!< Tries to extract a second order csr_sparsity from the supplied state using the name - !!< formula rowmesh%name//colmesh%name//DoubleSparsity - !!< - !!< If unsuccesful it creates that sparsity and inserts it into state - !!< before returning a pointer to the newly created sparsity. - type(csr_sparsity), pointer :: sparsity - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: rowmesh, colmesh - - type(state_type), dimension(1) :: states - - states = (/state/) - sparsity=>get_csr_sparsity_secondorder(states, rowmesh, colmesh) - state = states(1) - - end function get_csr_sparsity_secondorder_single_state - - function get_csr_sparsity_secondorder_multiple_states(states, rowmesh, colmesh) result(sparsity) - !!< Tries to extract a second order csr_sparsity from any of the supplied states using the name - !!< formula rowmesh%name//colmesh%name//DoubleSparsity - !!< - !!< If unsuccesful it creates that sparsity and inserts (and aliases) it into states - !!< before returning a pointer to the newly created sparsity. - type(csr_sparsity), pointer :: sparsity - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: rowmesh, colmesh - - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(csr_sparsity) :: temp_sparsity - - name = trim(rowmesh%name)//trim(colmesh%name)//"DoubleSparsity" - - sparsity => extract_csr_sparsity(states, trim(name), stat) - - if(stat/=0) then - temp_sparsity=make_sparsity_transpose(rowmesh, colmesh, trim(name)) - call insert(states, temp_sparsity, trim(name)) - call deallocate(temp_sparsity) - - sparsity => extract_csr_sparsity(states, trim(name)) - end if - - end function get_csr_sparsity_secondorder_multiple_states - - function get_csr_sparsity_compactdgdouble_single_state(state, mesh) & - & result(sparsity) - !!< Tries to extract a compactdgdouble - !!< csr_sparsity from the supplied state using the name - !!< formula rowmesh%name//colmesh%name//CompactDGDoubleSparsity - !!< - !!< If unsuccesful it creates that sparsity and inserts it into state - !!< before returning a pointer to the newly created sparsity. - type(csr_sparsity), pointer :: sparsity - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh - - type(state_type), dimension(1) :: states - - states = (/state/) - sparsity=>get_csr_sparsity_compactdgdouble(states, mesh) - state = states(1) - - end function get_csr_sparsity_compactdgdouble_single_state - - function get_csr_sparsity_compactdgdouble_multiple_states(states, mesh) & - & result(sparsity) - !!< Tries to extract a compactdgdouble - !!< csr_sparsity from the supplied state using the name - !!< formula mesh%name//CompactDGDoubleSparsity - !!< - !!< If unsuccesful it creates that sparsity and inserts - !!< (and aliases) it into states - !!< before returning a pointer to the newly created sparsity. - type(csr_sparsity), pointer :: sparsity - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: mesh - - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(csr_sparsity) :: temp_sparsity - - name = trim(mesh%name)//"CompactDGDoubleSparsity" - - sparsity => extract_csr_sparsity(states, trim(name), stat) - - if(stat/=0) then - temp_sparsity=make_sparsity_compactdgdouble(mesh, trim(name)) - call insert(states, temp_sparsity, trim(name)) - call deallocate(temp_sparsity) - - sparsity => extract_csr_sparsity(states, trim(name)) - end if - - end function get_csr_sparsity_compactdgdouble_multiple_states + function get_csr_sparsity_firstorder_single_state(state, rowmesh, colmesh) result(sparsity) + !!< Tries to extract a first order csr_sparsity from the supplied state using the name + !!< formula rowmesh%name//colmesh%name//Sparsity + !!< + !!< If unsuccesful it creates that sparsity and inserts it into state + !!< before returning a pointer to the newly created sparsity. + type(csr_sparsity), pointer :: sparsity + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: rowmesh, colmesh + + type(state_type), dimension(1) :: states + + states = (/state/) + sparsity=>get_csr_sparsity_firstorder(states, rowmesh, colmesh) + state = states(1) + + end function get_csr_sparsity_firstorder_single_state + + function get_csr_sparsity_firstorder_multiple_states(states, rowmesh, colmesh) result(sparsity) + !!< Tries to extract a first order csr_sparsity from any of the supplied states using the name + !!< formula rowmesh%name//colmesh%name//Sparsity + !!< + !!< If unsuccesful it creates that sparsity and inserts (and aliases) it into states + !!< before returning a pointer to the newly created sparsity. + type(csr_sparsity), pointer :: sparsity + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: rowmesh, colmesh + + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(csr_sparsity) :: temp_sparsity + + name = trim(rowmesh%name)//trim(colmesh%name)//"Sparsity" + + sparsity => extract_csr_sparsity(states, trim(name), stat) + + if(stat/=0) then + temp_sparsity=make_sparsity(rowmesh, colmesh, trim(name)) + call insert(states, temp_sparsity, trim(name)) + call deallocate(temp_sparsity) + + sparsity => extract_csr_sparsity(states, trim(name)) + end if + + end function get_csr_sparsity_firstorder_multiple_states + + function get_csr_sparsity_secondorder_single_state(state, rowmesh, colmesh) result(sparsity) + !!< Tries to extract a second order csr_sparsity from the supplied state using the name + !!< formula rowmesh%name//colmesh%name//DoubleSparsity + !!< + !!< If unsuccesful it creates that sparsity and inserts it into state + !!< before returning a pointer to the newly created sparsity. + type(csr_sparsity), pointer :: sparsity + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: rowmesh, colmesh + + type(state_type), dimension(1) :: states + + states = (/state/) + sparsity=>get_csr_sparsity_secondorder(states, rowmesh, colmesh) + state = states(1) + + end function get_csr_sparsity_secondorder_single_state + + function get_csr_sparsity_secondorder_multiple_states(states, rowmesh, colmesh) result(sparsity) + !!< Tries to extract a second order csr_sparsity from any of the supplied states using the name + !!< formula rowmesh%name//colmesh%name//DoubleSparsity + !!< + !!< If unsuccesful it creates that sparsity and inserts (and aliases) it into states + !!< before returning a pointer to the newly created sparsity. + type(csr_sparsity), pointer :: sparsity + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: rowmesh, colmesh + + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(csr_sparsity) :: temp_sparsity + + name = trim(rowmesh%name)//trim(colmesh%name)//"DoubleSparsity" + + sparsity => extract_csr_sparsity(states, trim(name), stat) + + if(stat/=0) then + temp_sparsity=make_sparsity_transpose(rowmesh, colmesh, trim(name)) + call insert(states, temp_sparsity, trim(name)) + call deallocate(temp_sparsity) + + sparsity => extract_csr_sparsity(states, trim(name)) + end if + + end function get_csr_sparsity_secondorder_multiple_states + + function get_csr_sparsity_compactdgdouble_single_state(state, mesh) & + & result(sparsity) + !!< Tries to extract a compactdgdouble + !!< csr_sparsity from the supplied state using the name + !!< formula rowmesh%name//colmesh%name//CompactDGDoubleSparsity + !!< + !!< If unsuccesful it creates that sparsity and inserts it into state + !!< before returning a pointer to the newly created sparsity. + type(csr_sparsity), pointer :: sparsity + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh + + type(state_type), dimension(1) :: states + + states = (/state/) + sparsity=>get_csr_sparsity_compactdgdouble(states, mesh) + state = states(1) + + end function get_csr_sparsity_compactdgdouble_single_state + + function get_csr_sparsity_compactdgdouble_multiple_states(states, mesh) & + & result(sparsity) + !!< Tries to extract a compactdgdouble + !!< csr_sparsity from the supplied state using the name + !!< formula mesh%name//CompactDGDoubleSparsity + !!< + !!< If unsuccesful it creates that sparsity and inserts + !!< (and aliases) it into states + !!< before returning a pointer to the newly created sparsity. + type(csr_sparsity), pointer :: sparsity + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: mesh + + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(csr_sparsity) :: temp_sparsity + + name = trim(mesh%name)//"CompactDGDoubleSparsity" + + sparsity => extract_csr_sparsity(states, trim(name), stat) + + if(stat/=0) then + temp_sparsity=make_sparsity_compactdgdouble(mesh, trim(name)) + call insert(states, temp_sparsity, trim(name)) + call deallocate(temp_sparsity) + + sparsity => extract_csr_sparsity(states, trim(name)) + end if + + end function get_csr_sparsity_compactdgdouble_multiple_states end module sparsity_patterns_meshes diff --git a/femtools/State.F90 b/femtools/State.F90 index d94db0bd32..3316931d56 100644 --- a/femtools/State.F90 +++ b/femtools/State.F90 @@ -27,3090 +27,3090 @@ #include "fdebug.h" module state_module - !!< This module provides a wrapper object which allows related groups of - !!< fields to be passed around together. - use fldebug - use global_parameters, only:OPTION_PATH_LEN, FIELD_NAME_LEN, empty_path - use futils, only: int2str, present_and_false, present_and_true - use halo_data_types - use halos_allocates - use sparse_tools - use fields_data_types - use fields_base - use linked_lists - use halos_communications - use fields_allocates - use fields_manipulation - use sparse_tools_petsc - implicit none - - private - - type state_type - !!< This type allows sets of fields and meshes to be passed around - !!< together and retrieved by name. - - !! name for the state - character(len=FIELD_NAME_LEN) :: name ="" - - !! option path for state + !!< This module provides a wrapper object which allows related groups of + !!< fields to be passed around together. + use fldebug + use global_parameters, only:OPTION_PATH_LEN, FIELD_NAME_LEN, empty_path + use futils, only: int2str, present_and_false, present_and_true + use halo_data_types + use halos_allocates + use sparse_tools + use fields_data_types + use fields_base + use linked_lists + use halos_communications + use fields_allocates + use fields_manipulation + use sparse_tools_petsc + implicit none + + private + + type state_type + !!< This type allows sets of fields and meshes to be passed around + !!< together and retrieved by name. + + !! name for the state + character(len=FIELD_NAME_LEN) :: name ="" + + !! option path for state #ifdef DDEBUG - character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" + character(len=OPTION_PATH_LEN) :: option_path="/uninitialised_path/" #else - character(len=OPTION_PATH_LEN) :: option_path + character(len=OPTION_PATH_LEN) :: option_path #endif - !! The names used for fields should, where possible, be taken from the - !! the CGNS SIDS. - character(len=FIELD_NAME_LEN), dimension(:), pointer :: & - vector_names=>null(), scalar_names=>null(), mesh_names=>null(), & - halo_names=>null(), tensor_names=>null(), & - csr_sparsity_names=>null(), csr_matrix_names=>null(), & - block_csr_matrix_names=>null(), petsc_csr_matrix_names=>null() - type(vector_field_pointer), dimension(:), pointer :: vector_fields=>null() - type(tensor_field_pointer), dimension(:), pointer :: tensor_fields=>null() - type(scalar_field_pointer), dimension(:), pointer :: scalar_fields=>null() - type(mesh_pointer), dimension(:), pointer :: meshes=>null() - type(halo_pointer), dimension(:), pointer :: halos=>null() - type(csr_sparsity_pointer), dimension(:), pointer :: csr_sparsities => null() - type(csr_matrix_pointer), dimension(:), pointer :: csr_matrices=>null() - type(block_csr_matrix_pointer), dimension(:), pointer :: block_csr_matrices=>null() - type(petsc_csr_matrix_pointer), dimension(:), pointer :: petsc_csr_matrices=>null() - end type state_type - - interface deallocate - module procedure deallocate_state, deallocate_state_vector, deallocate_state_rank_2 - end interface - - interface nullify - module procedure nullify_state - end interface - - interface insert - module procedure insert_tensor_field, insert_vector_field, insert_scalar_field, & - insert_mesh, insert_halo, insert_csr_sparsity, insert_csr_matrix, insert_block_csr_matrix, & - insert_and_alias_scalar_field, insert_and_alias_vector_field, insert_and_alias_tensor_field, & - insert_and_alias_csr_matrix, insert_and_alias_block_csr_matrix, insert_and_alias_mesh, & - insert_and_alias_halo, insert_and_alias_csr_sparsity, insert_petsc_csr_matrix, & - insert_and_alias_petsc_csr_matrix, insert_state_fields - end interface - - interface extract_scalar_field - module procedure extract_from_one_scalar_field, extract_from_any_scalar_field, & - & extract_scalar_field_by_index - end interface - - interface extract_vector_field - module procedure extract_from_one_vector_field, extract_from_any_vector_field, & - extract_vector_field_by_index - end interface - - interface extract_tensor_field - module procedure extract_tensor_field, extract_tensor_field_by_index - end interface - - interface extract_mesh - module procedure extract_mesh_from_one, extract_mesh_from_any, extract_mesh_by_index - end interface - - interface extract_halo - module procedure extract_halo, extract_halo_by_index - end interface extract_halo - - interface extract_csr_sparsity - module procedure extract_from_one_csr_sparsity, & - & extract_from_any_csr_sparsity, extract_csr_sparsity_by_index - end interface - - interface extract_csr_matrix + !! The names used for fields should, where possible, be taken from the + !! the CGNS SIDS. + character(len=FIELD_NAME_LEN), dimension(:), pointer :: & + vector_names=>null(), scalar_names=>null(), mesh_names=>null(), & + halo_names=>null(), tensor_names=>null(), & + csr_sparsity_names=>null(), csr_matrix_names=>null(), & + block_csr_matrix_names=>null(), petsc_csr_matrix_names=>null() + type(vector_field_pointer), dimension(:), pointer :: vector_fields=>null() + type(tensor_field_pointer), dimension(:), pointer :: tensor_fields=>null() + type(scalar_field_pointer), dimension(:), pointer :: scalar_fields=>null() + type(mesh_pointer), dimension(:), pointer :: meshes=>null() + type(halo_pointer), dimension(:), pointer :: halos=>null() + type(csr_sparsity_pointer), dimension(:), pointer :: csr_sparsities => null() + type(csr_matrix_pointer), dimension(:), pointer :: csr_matrices=>null() + type(block_csr_matrix_pointer), dimension(:), pointer :: block_csr_matrices=>null() + type(petsc_csr_matrix_pointer), dimension(:), pointer :: petsc_csr_matrices=>null() + end type state_type + + interface deallocate + module procedure deallocate_state, deallocate_state_vector, deallocate_state_rank_2 + end interface + + interface nullify + module procedure nullify_state + end interface + + interface insert + module procedure insert_tensor_field, insert_vector_field, insert_scalar_field, & + insert_mesh, insert_halo, insert_csr_sparsity, insert_csr_matrix, insert_block_csr_matrix, & + insert_and_alias_scalar_field, insert_and_alias_vector_field, insert_and_alias_tensor_field, & + insert_and_alias_csr_matrix, insert_and_alias_block_csr_matrix, insert_and_alias_mesh, & + insert_and_alias_halo, insert_and_alias_csr_sparsity, insert_petsc_csr_matrix, & + insert_and_alias_petsc_csr_matrix, insert_state_fields + end interface + + interface extract_scalar_field + module procedure extract_from_one_scalar_field, extract_from_any_scalar_field, & + & extract_scalar_field_by_index + end interface + + interface extract_vector_field + module procedure extract_from_one_vector_field, extract_from_any_vector_field, & + extract_vector_field_by_index + end interface + + interface extract_tensor_field + module procedure extract_tensor_field, extract_tensor_field_by_index + end interface + + interface extract_mesh + module procedure extract_mesh_from_one, extract_mesh_from_any, extract_mesh_by_index + end interface + + interface extract_halo + module procedure extract_halo, extract_halo_by_index + end interface extract_halo + + interface extract_csr_sparsity + module procedure extract_from_one_csr_sparsity, & + & extract_from_any_csr_sparsity, extract_csr_sparsity_by_index + end interface + + interface extract_csr_matrix module procedure extract_from_one_csr_matrix,& - & extract_from_any_csr_matrix, extract_csr_matrix_by_index - end interface + & extract_from_any_csr_matrix, extract_csr_matrix_by_index + end interface - interface extract_block_csr_matrix + interface extract_block_csr_matrix module procedure extract_from_one_block_csr_matrix,& - & extract_from_any_block_csr_matrix,& - & extract_block_csr_matrix_by_index - end interface + & extract_from_any_block_csr_matrix,& + & extract_block_csr_matrix_by_index + end interface - interface extract_petsc_csr_matrix + interface extract_petsc_csr_matrix module procedure extract_from_one_petsc_csr_matrix,& - & extract_from_any_petsc_csr_matrix,& - & extract_petsc_csr_matrix_by_index - end interface + & extract_from_any_petsc_csr_matrix,& + & extract_petsc_csr_matrix_by_index + end interface - interface has_halo + interface has_halo module procedure state_has_halo - end interface has_halo + end interface has_halo - interface halo_count + interface halo_count module procedure halo_count_state - end interface halo_count + end interface halo_count - interface collapse_state + interface collapse_state module procedure collapse_single_state, collapse_multiple_states - end interface + end interface - interface collapse_fields_in_state + interface collapse_fields_in_state module procedure collapse_fields_in_single_state, & - & collapse_fields_in_multiple_states - end interface + & collapse_fields_in_multiple_states + end interface - interface halo_update + interface halo_update module procedure halo_update_state, halo_update_states - end interface + end interface - interface aliased + interface aliased module procedure aliased_scalar, aliased_vector, aliased_tensor - end interface - - public state_type, deallocate, insert, nullify - public field_rank, extract_scalar_field, extract_vector_field, extract_tensor_field - public extract_field_mesh, extract_mesh, extract_halo - public extract_csr_sparsity, extract_csr_matrix, extract_block_csr_matrix, extract_petsc_csr_matrix - public has_scalar_field, has_vector_field, has_tensor_field, has_mesh, has_halo - public has_csr_sparsity, has_csr_matrix, has_block_csr_matrix, has_petsc_csr_matrix - public get_state_index, print_state, select_state_by_mesh - public remove_tensor_field, remove_vector_field, remove_scalar_field - public remove_csr_sparsity, remove_csr_matrix, remove_block_csr_matrix, remove_petsc_csr_matrix - public scalar_field_count, vector_field_count, tensor_field_count, field_count - public mesh_count, halo_count, csr_sparsity_count, csr_matrix_count,& - & block_csr_matrix_count, petsc_csr_matrix_count - public set_vector_field_in_state - public collapse_state, extract_state, collapse_fields_in_state - public set_option_path - public unique_mesh_count, sort_states_by_mesh, halo_update - public aliased - - !! Fields which exist only so that extract does not return null - type(vector_field), save, target :: fake_vector_field - type(scalar_field), save, target :: fake_scalar_field - type(tensor_field), save, target :: fake_tensor_field - type(mesh_type), save, target :: fake_mesh - type(halo_type), save, target :: fake_halo - type(csr_sparsity), save, target :: fake_csr_sparsity - type(csr_matrix), save, target :: fake_csr_matrix - type(block_csr_matrix), save, target :: fake_block_csr_matrix - type(petsc_csr_matrix), save, target :: fake_petsc_csr_matrix + end interface + + public state_type, deallocate, insert, nullify + public field_rank, extract_scalar_field, extract_vector_field, extract_tensor_field + public extract_field_mesh, extract_mesh, extract_halo + public extract_csr_sparsity, extract_csr_matrix, extract_block_csr_matrix, extract_petsc_csr_matrix + public has_scalar_field, has_vector_field, has_tensor_field, has_mesh, has_halo + public has_csr_sparsity, has_csr_matrix, has_block_csr_matrix, has_petsc_csr_matrix + public get_state_index, print_state, select_state_by_mesh + public remove_tensor_field, remove_vector_field, remove_scalar_field + public remove_csr_sparsity, remove_csr_matrix, remove_block_csr_matrix, remove_petsc_csr_matrix + public scalar_field_count, vector_field_count, tensor_field_count, field_count + public mesh_count, halo_count, csr_sparsity_count, csr_matrix_count,& + & block_csr_matrix_count, petsc_csr_matrix_count + public set_vector_field_in_state + public collapse_state, extract_state, collapse_fields_in_state + public set_option_path + public unique_mesh_count, sort_states_by_mesh, halo_update + public aliased + + !! Fields which exist only so that extract does not return null + type(vector_field), save, target :: fake_vector_field + type(scalar_field), save, target :: fake_scalar_field + type(tensor_field), save, target :: fake_tensor_field + type(mesh_type), save, target :: fake_mesh + type(halo_type), save, target :: fake_halo + type(csr_sparsity), save, target :: fake_csr_sparsity + type(csr_matrix), save, target :: fake_csr_matrix + type(block_csr_matrix), save, target :: fake_block_csr_matrix + type(petsc_csr_matrix), save, target :: fake_petsc_csr_matrix contains - subroutine deallocate_state(state) - !!< Clear out all references in state. Note that since state grows to - !!< the right size, it is neither necessary nor possible to allocate - !!< state. - type(state_type), intent(inout) :: state - integer :: i - - if (associated(state%vector_names)) then - deallocate(state%vector_names) - end if - if (associated(state%scalar_names)) then - deallocate(state%scalar_names) - end if - if (associated(state%mesh_names)) then - deallocate(state%mesh_names) - end if - if (associated(state%halo_names)) then - deallocate(state%halo_names) - end if - if (associated(state%tensor_names)) then - deallocate(state%tensor_names) - end if - if (associated(state%csr_sparsity_names)) then - deallocate(state%csr_sparsity_names) - end if - if (associated(state%csr_matrix_names)) then - deallocate(state%csr_matrix_names) - end if - if (associated(state%block_csr_matrix_names)) then - deallocate(state%block_csr_matrix_names) - end if - if (associated(state%petsc_csr_matrix_names)) then - deallocate(state%petsc_csr_matrix_names) - end if - if (associated(state%vector_fields)) then - do i=1,size(state%vector_fields) - call deallocate(state%vector_fields(i)%ptr) - deallocate(state%vector_fields(i)%ptr) - end do - deallocate(state%vector_fields) - end if - if (associated(state%scalar_fields)) then - do i=1,size(state%scalar_fields) - call deallocate(state%scalar_fields(i)%ptr) - deallocate(state%scalar_fields(i)%ptr) - end do - deallocate(state%scalar_fields) - end if - if (associated(state%tensor_fields)) then - do i=1,size(state%tensor_fields) - call deallocate(state%tensor_fields(i)%ptr) - deallocate(state%tensor_fields(i)%ptr) - end do - deallocate(state%tensor_fields) - end if - if (associated(state%meshes)) then - do i=1,size(state%meshes) - call deallocate(state%meshes(i)%ptr) - deallocate(state%meshes(i)%ptr) - end do - deallocate(state%meshes) - end if - if (associated(state%halos)) then - do i=1,size(state%halos) - call deallocate(state%halos(i)%ptr) - deallocate(state%halos(i)%ptr) - end do - end if - if (associated(state%csr_sparsities)) then - do i=1,size(state%csr_sparsities) - call deallocate(state%csr_sparsities(i)%ptr) - deallocate(state%csr_sparsities(i)%ptr) - end do - deallocate(state%csr_sparsities) - end if - if (associated(state%csr_matrices)) then - do i=1,size(state%csr_matrices) - call deallocate(state%csr_matrices(i)%ptr) - deallocate(state%csr_matrices(i)%ptr) - end do - deallocate(state%csr_matrices) - end if - if (associated(state%block_csr_matrices)) then - do i=1,size(state%block_csr_matrices) - call deallocate(state%block_csr_matrices(i)%ptr) - deallocate(state%block_csr_matrices(i)%ptr) - end do - deallocate(state%block_csr_matrices) - end if - if (associated(state%petsc_csr_matrices)) then - do i=1,size(state%petsc_csr_matrices) - call deallocate(state%petsc_csr_matrices(i)%ptr) - deallocate(state%petsc_csr_matrices(i)%ptr) - end do - deallocate(state%petsc_csr_matrices) - end if - - end subroutine deallocate_state - - subroutine deallocate_state_vector(state) - type(state_type), dimension(:), intent(inout) :: state - - integer :: i - - do i = 1, size(state) - call deallocate(state(i)) - end do - - end subroutine deallocate_state_vector - - subroutine deallocate_state_rank_2(state) - type(state_type), dimension(:,:), intent(inout) :: state - integer :: i, j - - do i=1,size(state, 1) - do j=1,size(state, 2) - call deallocate(state(i,j)) - end do - end do - end subroutine deallocate_state_rank_2 - - elemental subroutine nullify_state(state) - !!< Nullify all the pointers in state. This should not be necessary but - !!< it appears there is a gfortran bug which causes array components - !!< not to be nullified. - type(state_type), intent(inout) :: state - - state%vector_names=>null() - state%scalar_names=>null() - state%mesh_names=>null() - state%halo_names=>null() - state%tensor_names=>null() - state%vector_fields=>null() - state%tensor_fields=>null() - state%scalar_fields=>null() - state%meshes=>null() - state%halos=>null() - state%csr_sparsities=>null() - state%csr_matrices=>null() - state%block_csr_matrices=>null() - state%petsc_csr_matrices=>null() - state%option_path=empty_path - - end subroutine nullify_state - - subroutine set_option_path(state, path) - !!< Set the option path in state. - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: path - - state%option_path = trim(path) - - end subroutine set_option_path - - subroutine insert_tensor_field(state, field, name) - !!< Insert a tensor field into state. - !!< - !!< If a field with this name is already present then it is replaced. - type(state_type), intent(inout) :: state - type(tensor_field), intent(in) :: field - character(len=*), intent(in) :: name - - type(tensor_field_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - - integer :: i - integer :: old_size - - if (.not.associated(state%tensor_fields)) then - ! Special case first entry. - allocate(state%tensor_fields(1)) - allocate(state%tensor_fields(1)%ptr) - allocate(state%tensor_names(1)) - - state%tensor_fields(1)%ptr = field - state%tensor_names(1) = name - call incref(field) - - else - - ! Check if the name is already present. - do i=1,size(state%tensor_fields) - if (trim(name)==trim(state%tensor_names(i))) then - ! The name is present! - call incref(field) - call deallocate(state%tensor_fields(i)%ptr) - state%tensor_fields(i)%ptr = field - return - end if - end do - - ! If we get to here then this is a new field. - tmp_fields=>state%tensor_fields - tmp_names=>state%tensor_names - - old_size=size(tmp_fields) - - allocate(state%tensor_fields(old_size+1)) - allocate(state%tensor_fields(old_size+1)%ptr) - allocate(state%tensor_names(old_size+1)) - - forall (i=1:old_size) - state%tensor_fields(i)%ptr => tmp_fields(i)%ptr - end forall - state%tensor_names(1:old_size) = tmp_names - - state%tensor_fields(old_size+1)%ptr = field - state%tensor_names(old_size+1) = name - call incref(field) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end if - - end subroutine insert_tensor_field - - subroutine insert_and_alias_tensor_field(state, field, name) - !!< Insert a tensor field into state(1) and alias it in all others. - !!< - !!< If a field with this name is already present then it is replaced. - type(state_type), dimension(:), intent(inout) :: state - type(tensor_field), intent(in) :: field - character(len=*), intent(in) :: name - - type(tensor_field) :: p_field - integer :: i - - call insert(state(1), field, trim(name)) - - p_field=extract_tensor_field(state(1), trim(name)) - p_field%aliased = .true. - do i = 2, size(state) - call insert(state(i), p_field, trim(name)) - end do - - end subroutine insert_and_alias_tensor_field - - subroutine insert_vector_field(state, field, name) - !!< Insert a vector field into state. - !!< - !!< If a field with this name is already present then it is replaced. - type(state_type), intent(inout) :: state - type(vector_field), intent(in) :: field - character(len=*), intent(in) :: name + subroutine deallocate_state(state) + !!< Clear out all references in state. Note that since state grows to + !!< the right size, it is neither necessary nor possible to allocate + !!< state. + type(state_type), intent(inout) :: state + integer :: i + + if (associated(state%vector_names)) then + deallocate(state%vector_names) + end if + if (associated(state%scalar_names)) then + deallocate(state%scalar_names) + end if + if (associated(state%mesh_names)) then + deallocate(state%mesh_names) + end if + if (associated(state%halo_names)) then + deallocate(state%halo_names) + end if + if (associated(state%tensor_names)) then + deallocate(state%tensor_names) + end if + if (associated(state%csr_sparsity_names)) then + deallocate(state%csr_sparsity_names) + end if + if (associated(state%csr_matrix_names)) then + deallocate(state%csr_matrix_names) + end if + if (associated(state%block_csr_matrix_names)) then + deallocate(state%block_csr_matrix_names) + end if + if (associated(state%petsc_csr_matrix_names)) then + deallocate(state%petsc_csr_matrix_names) + end if + if (associated(state%vector_fields)) then + do i=1,size(state%vector_fields) + call deallocate(state%vector_fields(i)%ptr) + deallocate(state%vector_fields(i)%ptr) + end do + deallocate(state%vector_fields) + end if + if (associated(state%scalar_fields)) then + do i=1,size(state%scalar_fields) + call deallocate(state%scalar_fields(i)%ptr) + deallocate(state%scalar_fields(i)%ptr) + end do + deallocate(state%scalar_fields) + end if + if (associated(state%tensor_fields)) then + do i=1,size(state%tensor_fields) + call deallocate(state%tensor_fields(i)%ptr) + deallocate(state%tensor_fields(i)%ptr) + end do + deallocate(state%tensor_fields) + end if + if (associated(state%meshes)) then + do i=1,size(state%meshes) + call deallocate(state%meshes(i)%ptr) + deallocate(state%meshes(i)%ptr) + end do + deallocate(state%meshes) + end if + if (associated(state%halos)) then + do i=1,size(state%halos) + call deallocate(state%halos(i)%ptr) + deallocate(state%halos(i)%ptr) + end do + end if + if (associated(state%csr_sparsities)) then + do i=1,size(state%csr_sparsities) + call deallocate(state%csr_sparsities(i)%ptr) + deallocate(state%csr_sparsities(i)%ptr) + end do + deallocate(state%csr_sparsities) + end if + if (associated(state%csr_matrices)) then + do i=1,size(state%csr_matrices) + call deallocate(state%csr_matrices(i)%ptr) + deallocate(state%csr_matrices(i)%ptr) + end do + deallocate(state%csr_matrices) + end if + if (associated(state%block_csr_matrices)) then + do i=1,size(state%block_csr_matrices) + call deallocate(state%block_csr_matrices(i)%ptr) + deallocate(state%block_csr_matrices(i)%ptr) + end do + deallocate(state%block_csr_matrices) + end if + if (associated(state%petsc_csr_matrices)) then + do i=1,size(state%petsc_csr_matrices) + call deallocate(state%petsc_csr_matrices(i)%ptr) + deallocate(state%petsc_csr_matrices(i)%ptr) + end do + deallocate(state%petsc_csr_matrices) + end if - type(vector_field_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + end subroutine deallocate_state - integer :: i - integer :: old_size + subroutine deallocate_state_vector(state) + type(state_type), dimension(:), intent(inout) :: state - if (.not.associated(state%vector_fields)) then - ! Special case first entry. - allocate(state%vector_fields(1)) - allocate(state%vector_fields(1)%ptr) - allocate(state%vector_names(1)) - - state%vector_fields(1)%ptr = field - state%vector_names(1) = name - - call incref(field) - - else + integer :: i - ! Check if the name is already present. - do i=1,size(state%vector_fields) - if (trim(name)==trim(state%vector_names(i))) then - ! The name is present! - call incref(field) - call deallocate(state%vector_fields(i)%ptr) - state%vector_fields(i)%ptr = field - return - end if - end do - - ! If we get to here then this is a new field. - tmp_fields=>state%vector_fields - tmp_names=>state%vector_names + do i = 1, size(state) + call deallocate(state(i)) + end do - old_size=size(tmp_fields) + end subroutine deallocate_state_vector - allocate(state%vector_fields(old_size+1)) - allocate(state%vector_fields(old_size+1)%ptr) - allocate(state%vector_names(old_size+1)) + subroutine deallocate_state_rank_2(state) + type(state_type), dimension(:,:), intent(inout) :: state + integer :: i, j - forall(i=1:old_size) - state%vector_fields(i)%ptr => tmp_fields(i)%ptr - end forall - state%vector_names(1:old_size)= tmp_names + do i=1,size(state, 1) + do j=1,size(state, 2) + call deallocate(state(i,j)) + end do + end do + end subroutine deallocate_state_rank_2 + + elemental subroutine nullify_state(state) + !!< Nullify all the pointers in state. This should not be necessary but + !!< it appears there is a gfortran bug which causes array components + !!< not to be nullified. + type(state_type), intent(inout) :: state + + state%vector_names=>null() + state%scalar_names=>null() + state%mesh_names=>null() + state%halo_names=>null() + state%tensor_names=>null() + state%vector_fields=>null() + state%tensor_fields=>null() + state%scalar_fields=>null() + state%meshes=>null() + state%halos=>null() + state%csr_sparsities=>null() + state%csr_matrices=>null() + state%block_csr_matrices=>null() + state%petsc_csr_matrices=>null() + state%option_path=empty_path + + end subroutine nullify_state + + subroutine set_option_path(state, path) + !!< Set the option path in state. + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: path + + state%option_path = trim(path) + + end subroutine set_option_path + + subroutine insert_tensor_field(state, field, name) + !!< Insert a tensor field into state. + !!< + !!< If a field with this name is already present then it is replaced. + type(state_type), intent(inout) :: state + type(tensor_field), intent(in) :: field + character(len=*), intent(in) :: name + + type(tensor_field_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + + integer :: i + integer :: old_size + + if (.not.associated(state%tensor_fields)) then + ! Special case first entry. + allocate(state%tensor_fields(1)) + allocate(state%tensor_fields(1)%ptr) + allocate(state%tensor_names(1)) + + state%tensor_fields(1)%ptr = field + state%tensor_names(1) = name + call incref(field) - state%vector_fields(old_size+1)%ptr = field - state%vector_names(old_size+1) = name - call incref(field) + else - deallocate(tmp_fields) - deallocate(tmp_names) + ! Check if the name is already present. + do i=1,size(state%tensor_fields) + if (trim(name)==trim(state%tensor_names(i))) then + ! The name is present! + call incref(field) + call deallocate(state%tensor_fields(i)%ptr) + state%tensor_fields(i)%ptr = field + return + end if + end do - end if + ! If we get to here then this is a new field. + tmp_fields=>state%tensor_fields + tmp_names=>state%tensor_names - end subroutine insert_vector_field + old_size=size(tmp_fields) - subroutine insert_and_alias_vector_field(state, field, name) - !!< Insert a vector field into state(1) and alias it in all others. - !!< - !!< If a field with this name is already present then it is replaced. - type(state_type), dimension(:), intent(inout) :: state - type(vector_field), intent(in) :: field - character(len=*), intent(in) :: name + allocate(state%tensor_fields(old_size+1)) + allocate(state%tensor_fields(old_size+1)%ptr) + allocate(state%tensor_names(old_size+1)) - type(vector_field) :: p_field - integer :: i + forall (i=1:old_size) + state%tensor_fields(i)%ptr => tmp_fields(i)%ptr + end forall + state%tensor_names(1:old_size) = tmp_names - call insert(state(1), field, trim(name)) + state%tensor_fields(old_size+1)%ptr = field + state%tensor_names(old_size+1) = name + call incref(field) - p_field=extract_vector_field(state(1), trim(name)) - p_field%aliased = .true. - do i = 2, size(state) - call insert(state(i), p_field, trim(name)) - end do + deallocate(tmp_fields) + deallocate(tmp_names) - end subroutine insert_and_alias_vector_field + end if - subroutine insert_scalar_field(state, field, name) - !!< Insert a scalar field into state. - type(state_type), intent(inout) :: state - type(scalar_field), intent(in) :: field - character(len=*), intent(in) :: name + end subroutine insert_tensor_field - type(scalar_field_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + subroutine insert_and_alias_tensor_field(state, field, name) + !!< Insert a tensor field into state(1) and alias it in all others. + !!< + !!< If a field with this name is already present then it is replaced. + type(state_type), dimension(:), intent(inout) :: state + type(tensor_field), intent(in) :: field + character(len=*), intent(in) :: name - integer :: i - integer :: old_size + type(tensor_field) :: p_field + integer :: i - if (.not.associated(state%scalar_fields)) then - ! Special case first entry. - allocate(state%scalar_fields(1)) - allocate(state%scalar_fields(1)%ptr) - allocate(state%scalar_names(1)) + call insert(state(1), field, trim(name)) - state%scalar_fields(1)%ptr = field - state%scalar_names(1) = name + p_field=extract_tensor_field(state(1), trim(name)) + p_field%aliased = .true. + do i = 2, size(state) + call insert(state(i), p_field, trim(name)) + end do - call incref(field) + end subroutine insert_and_alias_tensor_field - else + subroutine insert_vector_field(state, field, name) + !!< Insert a vector field into state. + !!< + !!< If a field with this name is already present then it is replaced. + type(state_type), intent(inout) :: state + type(vector_field), intent(in) :: field + character(len=*), intent(in) :: name - ! Check if the name is already present. - do i=1,size(state%scalar_fields) - if (trim(name)==trim(state%scalar_names(i))) then - ! The name is present! - call incref(field) - call deallocate(state%scalar_fields(i)%ptr) - state%scalar_fields(i)%ptr = field - return - end if - end do + type(vector_field_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - ! If we get to here then this is a new field. - tmp_fields=>state%scalar_fields - tmp_names=>state%scalar_names + integer :: i + integer :: old_size - old_size=size(tmp_fields) + if (.not.associated(state%vector_fields)) then + ! Special case first entry. + allocate(state%vector_fields(1)) + allocate(state%vector_fields(1)%ptr) + allocate(state%vector_names(1)) - allocate(state%scalar_fields(old_size+1)) - allocate(state%scalar_fields(old_size+1)%ptr) - allocate(state%scalar_names(old_size+1)) + state%vector_fields(1)%ptr = field + state%vector_names(1) = name - forall(i=1:old_size) - state%scalar_fields(i)%ptr => tmp_fields(i)%ptr - end forall - state%scalar_names(1:old_size)= tmp_names + call incref(field) - state%scalar_fields(old_size+1)%ptr = field - state%scalar_names(old_size+1) = name + else - call incref(field) + ! Check if the name is already present. + do i=1,size(state%vector_fields) + if (trim(name)==trim(state%vector_names(i))) then + ! The name is present! + call incref(field) + call deallocate(state%vector_fields(i)%ptr) + state%vector_fields(i)%ptr = field + return + end if + end do - deallocate(tmp_fields) - deallocate(tmp_names) + ! If we get to here then this is a new field. + tmp_fields=>state%vector_fields + tmp_names=>state%vector_names - end if + old_size=size(tmp_fields) - end subroutine insert_scalar_field + allocate(state%vector_fields(old_size+1)) + allocate(state%vector_fields(old_size+1)%ptr) + allocate(state%vector_names(old_size+1)) - subroutine insert_and_alias_scalar_field(state, field, name) - !!< Insert a scalar field into state(1) and alias it in all others. - !!< - !!< If a field with this name is already present then it is replaced. - type(state_type), dimension(:), intent(inout) :: state - type(scalar_field), intent(in) :: field - character(len=*), intent(in) :: name + forall(i=1:old_size) + state%vector_fields(i)%ptr => tmp_fields(i)%ptr + end forall + state%vector_names(1:old_size)= tmp_names - type(scalar_field) :: p_field - integer :: i + state%vector_fields(old_size+1)%ptr = field + state%vector_names(old_size+1) = name + call incref(field) - call insert(state(1), field, trim(name)) + deallocate(tmp_fields) + deallocate(tmp_names) - p_field=extract_scalar_field(state(1), trim(name)) - p_field%aliased = .true. - do i = 2, size(state) - call insert(state(i), p_field, trim(name)) - end do + end if - end subroutine insert_and_alias_scalar_field + end subroutine insert_vector_field - subroutine insert_mesh(state, mesh, name) - !!< Insert a mesh into state. - type(state_type), intent(inout) :: state - type(mesh_type), intent(in) :: mesh - character(len=*), intent(in) :: name + subroutine insert_and_alias_vector_field(state, field, name) + !!< Insert a vector field into state(1) and alias it in all others. + !!< + !!< If a field with this name is already present then it is replaced. + type(state_type), dimension(:), intent(inout) :: state + type(vector_field), intent(in) :: field + character(len=*), intent(in) :: name - type(mesh_pointer), dimension(:), pointer :: tmp_meshes - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + type(vector_field) :: p_field + integer :: i - integer :: i - integer :: old_size + call insert(state(1), field, trim(name)) - if (.not.associated(state%meshes)) then - ! Special case first entry. - allocate(state%meshes(1)) - allocate(state%meshes(1)%ptr) - allocate(state%mesh_names(1)) + p_field=extract_vector_field(state(1), trim(name)) + p_field%aliased = .true. + do i = 2, size(state) + call insert(state(i), p_field, trim(name)) + end do - state%meshes(1)%ptr = mesh - state%mesh_names(1) = name + end subroutine insert_and_alias_vector_field - else + subroutine insert_scalar_field(state, field, name) + !!< Insert a scalar field into state. + type(state_type), intent(inout) :: state + type(scalar_field), intent(in) :: field + character(len=*), intent(in) :: name - ! Check if the name is already present. - do i=1,size(state%meshes) - if (trim(name)==trim(state%mesh_names(i))) then - ! The name is present! - call deallocate(state%meshes(i)%ptr) - state%meshes(i)%ptr = mesh - call incref(mesh) - return - end if - end do + type(scalar_field_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - ! If we get to here then this is a new mesh. - tmp_meshes=>state%meshes - tmp_names=>state%mesh_names + integer :: i + integer :: old_size - old_size=size(tmp_meshes) + if (.not.associated(state%scalar_fields)) then + ! Special case first entry. + allocate(state%scalar_fields(1)) + allocate(state%scalar_fields(1)%ptr) + allocate(state%scalar_names(1)) - allocate(state%meshes(old_size+1)) - allocate(state%meshes(old_size+1)%ptr) - allocate(state%mesh_names(old_size+1)) + state%scalar_fields(1)%ptr = field + state%scalar_names(1) = name - forall(i=1:old_size) - state%meshes(i)%ptr => tmp_meshes(i)%ptr - end forall - state%mesh_names(1:old_size)= tmp_names + call incref(field) - state%meshes(old_size+1)%ptr = mesh - state%mesh_names(old_size+1) = name + else - deallocate(tmp_names) - deallocate(tmp_meshes) + ! Check if the name is already present. + do i=1,size(state%scalar_fields) + if (trim(name)==trim(state%scalar_names(i))) then + ! The name is present! + call incref(field) + call deallocate(state%scalar_fields(i)%ptr) + state%scalar_fields(i)%ptr = field + return + end if + end do - end if + ! If we get to here then this is a new field. + tmp_fields=>state%scalar_fields + tmp_names=>state%scalar_names - call incref(mesh) + old_size=size(tmp_fields) - end subroutine insert_mesh + allocate(state%scalar_fields(old_size+1)) + allocate(state%scalar_fields(old_size+1)%ptr) + allocate(state%scalar_names(old_size+1)) - subroutine insert_and_alias_mesh(state, mesh, name) - !!< Insert a mesh into state(1) and alias it in all others. - !!< - !!< If a field with this name is already present then it is replaced. - type(state_type), dimension(:), intent(inout) :: state - type(mesh_type), intent(in) :: mesh - character(len=*), intent(in) :: name + forall(i=1:old_size) + state%scalar_fields(i)%ptr => tmp_fields(i)%ptr + end forall + state%scalar_names(1:old_size)= tmp_names - type(mesh_type) :: p_mesh - integer :: i + state%scalar_fields(old_size+1)%ptr = field + state%scalar_names(old_size+1) = name - call insert(state(1), mesh, trim(name)) + call incref(field) - p_mesh=extract_mesh(state(1), trim(name)) - do i = 2, size(state) - call insert(state(i), p_mesh, trim(name)) - end do + deallocate(tmp_fields) + deallocate(tmp_names) - end subroutine insert_and_alias_mesh + end if - subroutine insert_halo(state, halo, name) - !!< Insert a halo into state. - type(state_type), intent(inout) :: state - type(halo_type), intent(in) :: halo - character(len=*), intent(in) :: name + end subroutine insert_scalar_field - type(halo_pointer), dimension(:), pointer :: tmp_halos - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + subroutine insert_and_alias_scalar_field(state, field, name) + !!< Insert a scalar field into state(1) and alias it in all others. + !!< + !!< If a field with this name is already present then it is replaced. + type(state_type), dimension(:), intent(inout) :: state + type(scalar_field), intent(in) :: field + character(len=*), intent(in) :: name - integer :: i - integer :: old_size + type(scalar_field) :: p_field + integer :: i - if (.not.associated(state%halos)) then - ! Special case first entry. - allocate(state%halos(1)) - allocate(state%halos(1)%ptr) - allocate(state%halo_names(1)) + call insert(state(1), field, trim(name)) - state%halos(1)%ptr = halo - state%halo_names(1) = name + p_field=extract_scalar_field(state(1), trim(name)) + p_field%aliased = .true. + do i = 2, size(state) + call insert(state(i), p_field, trim(name)) + end do - else + end subroutine insert_and_alias_scalar_field - ! Check if the name is already present. - do i=1,size(state%halos) - if (trim(name)==trim(state%halo_names(i))) then - ! The name is present! - call deallocate(state%halos(i)%ptr) - state%halos(i)%ptr = halo - call incref(halo) - return - end if - end do + subroutine insert_mesh(state, mesh, name) + !!< Insert a mesh into state. + type(state_type), intent(inout) :: state + type(mesh_type), intent(in) :: mesh + character(len=*), intent(in) :: name - ! If we get to here then this is a new halo. - tmp_halos=>state%halos - tmp_names=>state%halo_names + type(mesh_pointer), dimension(:), pointer :: tmp_meshes + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - old_size=size(tmp_halos) + integer :: i + integer :: old_size - allocate(state%halos(old_size+1)) - allocate(state%halos(old_size+1)%ptr) - allocate(state%halo_names(old_size+1)) + if (.not.associated(state%meshes)) then + ! Special case first entry. + allocate(state%meshes(1)) + allocate(state%meshes(1)%ptr) + allocate(state%mesh_names(1)) - forall(i=1:old_size) - state%halos(i)%ptr => tmp_halos(i)%ptr - end forall - state%halo_names(1:old_size)= tmp_names + state%meshes(1)%ptr = mesh + state%mesh_names(1) = name - state%halos(old_size+1)%ptr = halo - state%halo_names(old_size+1) = name + else - deallocate(tmp_names) - deallocate(tmp_halos) + ! Check if the name is already present. + do i=1,size(state%meshes) + if (trim(name)==trim(state%mesh_names(i))) then + ! The name is present! + call deallocate(state%meshes(i)%ptr) + state%meshes(i)%ptr = mesh + call incref(mesh) + return + end if + end do - end if + ! If we get to here then this is a new mesh. + tmp_meshes=>state%meshes + tmp_names=>state%mesh_names - call incref(halo) + old_size=size(tmp_meshes) - end subroutine insert_halo + allocate(state%meshes(old_size+1)) + allocate(state%meshes(old_size+1)%ptr) + allocate(state%mesh_names(old_size+1)) - subroutine insert_and_alias_halo(state, halo, name) - !!< Insert a halo into state(1) and alias it in all others. - !!< - !!< If a halo with this name is already present then it is replaced. - type(state_type), dimension(:), intent(inout) :: state - type(halo_type), intent(in) :: halo - character(len=*), intent(in) :: name + forall(i=1:old_size) + state%meshes(i)%ptr => tmp_meshes(i)%ptr + end forall + state%mesh_names(1:old_size)= tmp_names - type(halo_type) :: p_halo - integer :: i + state%meshes(old_size+1)%ptr = mesh + state%mesh_names(old_size+1) = name - call insert(state(1), halo, trim(name)) + deallocate(tmp_names) + deallocate(tmp_meshes) - p_halo=extract_halo(state(1), trim(name)) - do i = 2, size(state) - call insert(state(i), p_halo, trim(name)) - end do + end if - end subroutine insert_and_alias_halo + call incref(mesh) - subroutine insert_csr_sparsity(state, sparsity, name) - !!< Insert a sparsity into state. - type(state_type), intent(inout) :: state - type(csr_sparsity), intent(in) :: sparsity - character(len=*), intent(in) :: name + end subroutine insert_mesh - type(csr_sparsity_pointer), dimension(:), pointer :: tmp_csr_sparsities - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + subroutine insert_and_alias_mesh(state, mesh, name) + !!< Insert a mesh into state(1) and alias it in all others. + !!< + !!< If a field with this name is already present then it is replaced. + type(state_type), dimension(:), intent(inout) :: state + type(mesh_type), intent(in) :: mesh + character(len=*), intent(in) :: name - integer :: i - integer :: old_size + type(mesh_type) :: p_mesh + integer :: i - if (.not.associated(state%csr_sparsities)) then - ! Special case first entry. - allocate(state%csr_sparsities(1)) - allocate(state%csr_sparsities(1)%ptr) - allocate(state%csr_sparsity_names(1)) + call insert(state(1), mesh, trim(name)) - state%csr_sparsities(1)%ptr = sparsity - state%csr_sparsity_names(1) = name + p_mesh=extract_mesh(state(1), trim(name)) + do i = 2, size(state) + call insert(state(i), p_mesh, trim(name)) + end do - else + end subroutine insert_and_alias_mesh - ! Check if the name is already present. - do i=1,size(state%csr_sparsities) - if (trim(name)==trim(state%csr_sparsity_names(i))) then - ! The name is present! - call deallocate(state%csr_sparsities(i)%ptr) - state%csr_sparsities(i)%ptr = sparsity - call incref(sparsity) - return - end if - end do + subroutine insert_halo(state, halo, name) + !!< Insert a halo into state. + type(state_type), intent(inout) :: state + type(halo_type), intent(in) :: halo + character(len=*), intent(in) :: name - ! If we get to here then this is a new sparsity. - tmp_csr_sparsities=>state%csr_sparsities - tmp_names=>state%csr_sparsity_names + type(halo_pointer), dimension(:), pointer :: tmp_halos + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - old_size=size(tmp_csr_sparsities) + integer :: i + integer :: old_size - allocate(state%csr_sparsities(old_size+1)) - allocate(state%csr_sparsities(old_size+1)%ptr) - allocate(state%csr_sparsity_names(old_size+1)) + if (.not.associated(state%halos)) then + ! Special case first entry. + allocate(state%halos(1)) + allocate(state%halos(1)%ptr) + allocate(state%halo_names(1)) - forall(i=1:old_size) - state%csr_sparsities(i)%ptr => tmp_csr_sparsities(i)%ptr - end forall - state%csr_sparsity_names(1:old_size)= tmp_names + state%halos(1)%ptr = halo + state%halo_names(1) = name - state%csr_sparsities(old_size+1)%ptr = sparsity - state%csr_sparsity_names(old_size+1) = name + else - deallocate(tmp_names) - deallocate(tmp_csr_sparsities) + ! Check if the name is already present. + do i=1,size(state%halos) + if (trim(name)==trim(state%halo_names(i))) then + ! The name is present! + call deallocate(state%halos(i)%ptr) + state%halos(i)%ptr = halo + call incref(halo) + return + end if + end do + + ! If we get to here then this is a new halo. + tmp_halos=>state%halos + tmp_names=>state%halo_names + + old_size=size(tmp_halos) + + allocate(state%halos(old_size+1)) + allocate(state%halos(old_size+1)%ptr) + allocate(state%halo_names(old_size+1)) - end if + forall(i=1:old_size) + state%halos(i)%ptr => tmp_halos(i)%ptr + end forall + state%halo_names(1:old_size)= tmp_names - call incref(sparsity) + state%halos(old_size+1)%ptr = halo + state%halo_names(old_size+1) = name - end subroutine insert_csr_sparsity + deallocate(tmp_names) + deallocate(tmp_halos) - subroutine insert_csr_matrix(state, matrix, name) - !!< Insert a matrix into state. - type(state_type), intent(inout) :: state - type(csr_matrix), intent(in) :: matrix - character(len=*), intent(in) :: name + end if - type(csr_matrix_pointer), dimension(:), pointer :: tmp_csr_matrices - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + call incref(halo) - integer :: i - integer :: old_size + end subroutine insert_halo - if (.not.associated(state%csr_matrices)) then - ! Special case first entry. - allocate(state%csr_matrices(1)) - allocate(state%csr_matrices(1)%ptr) - allocate(state%csr_matrix_names(1)) + subroutine insert_and_alias_halo(state, halo, name) + !!< Insert a halo into state(1) and alias it in all others. + !!< + !!< If a halo with this name is already present then it is replaced. + type(state_type), dimension(:), intent(inout) :: state + type(halo_type), intent(in) :: halo + character(len=*), intent(in) :: name - state%csr_matrices(1)%ptr = matrix - state%csr_matrix_names(1) = name + type(halo_type) :: p_halo + integer :: i - else + call insert(state(1), halo, trim(name)) - ! Check if the name is already present. - do i=1,size(state%csr_matrices) - if (trim(name)==trim(state%csr_matrix_names(i))) then - ! The name is present! - call deallocate(state%csr_matrices(i)%ptr) - state%csr_matrices(i)%ptr = matrix - call incref(matrix) - return - end if - end do + p_halo=extract_halo(state(1), trim(name)) + do i = 2, size(state) + call insert(state(i), p_halo, trim(name)) + end do - ! If we get to here then this is a new matrix. - tmp_csr_matrices=>state%csr_matrices - tmp_names=>state%csr_matrix_names + end subroutine insert_and_alias_halo - old_size=size(tmp_csr_matrices) + subroutine insert_csr_sparsity(state, sparsity, name) + !!< Insert a sparsity into state. + type(state_type), intent(inout) :: state + type(csr_sparsity), intent(in) :: sparsity + character(len=*), intent(in) :: name - allocate(state%csr_matrices(old_size+1)) - allocate(state%csr_matrices(old_size+1)%ptr) - allocate(state%csr_matrix_names(old_size+1)) + type(csr_sparsity_pointer), dimension(:), pointer :: tmp_csr_sparsities + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - forall(i=1:old_size) - state%csr_matrices(i)%ptr => tmp_csr_matrices(i)%ptr - end forall - state%csr_matrix_names(1:old_size)= tmp_names + integer :: i + integer :: old_size - state%csr_matrices(old_size+1)%ptr = matrix - state%csr_matrix_names(old_size+1) = name + if (.not.associated(state%csr_sparsities)) then + ! Special case first entry. + allocate(state%csr_sparsities(1)) + allocate(state%csr_sparsities(1)%ptr) + allocate(state%csr_sparsity_names(1)) - deallocate(tmp_names) - deallocate(tmp_csr_matrices) + state%csr_sparsities(1)%ptr = sparsity + state%csr_sparsity_names(1) = name - end if + else - call incref(matrix) + ! Check if the name is already present. + do i=1,size(state%csr_sparsities) + if (trim(name)==trim(state%csr_sparsity_names(i))) then + ! The name is present! + call deallocate(state%csr_sparsities(i)%ptr) + state%csr_sparsities(i)%ptr = sparsity + call incref(sparsity) + return + end if + end do - end subroutine insert_csr_matrix + ! If we get to here then this is a new sparsity. + tmp_csr_sparsities=>state%csr_sparsities + tmp_names=>state%csr_sparsity_names - subroutine insert_and_alias_csr_matrix(state, matrix, name) - !!< Insert a matrix into all states - type(state_type), dimension(:), intent(inout) :: state - type(csr_matrix), intent(in) :: matrix - character(len=*), intent(in) :: name + old_size=size(tmp_csr_sparsities) - type(csr_matrix) :: p_matrix - integer :: i + allocate(state%csr_sparsities(old_size+1)) + allocate(state%csr_sparsities(old_size+1)%ptr) + allocate(state%csr_sparsity_names(old_size+1)) - ! insert into state(1) - call insert(state(1), matrix, trim(name)) + forall(i=1:old_size) + state%csr_sparsities(i)%ptr => tmp_csr_sparsities(i)%ptr + end forall + state%csr_sparsity_names(1:old_size)= tmp_names - p_matrix=extract_csr_matrix(state(1), trim(name)) + state%csr_sparsities(old_size+1)%ptr = sparsity + state%csr_sparsity_names(old_size+1) = name - do i = 2, size(state) - call insert(state(i), p_matrix, trim(name)) - end do + deallocate(tmp_names) + deallocate(tmp_csr_sparsities) - end subroutine insert_and_alias_csr_matrix + end if - subroutine insert_and_alias_csr_sparsity(state, sparsity, name) - !!< Insert a sparsity into state all states - type(state_type), dimension(:), intent(inout) :: state - type(csr_sparsity), intent(in) :: sparsity - character(len=*), intent(in) :: name + call incref(sparsity) - type(csr_sparsity) :: p_sparsity - integer :: i + end subroutine insert_csr_sparsity - ! insert into state(1) - call insert(state(1), sparsity, trim(name)) + subroutine insert_csr_matrix(state, matrix, name) + !!< Insert a matrix into state. + type(state_type), intent(inout) :: state + type(csr_matrix), intent(in) :: matrix + character(len=*), intent(in) :: name - p_sparsity=extract_csr_sparsity(state(1), trim(name)) + type(csr_matrix_pointer), dimension(:), pointer :: tmp_csr_matrices + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - do i = 2, size(state) - call insert(state(i), p_sparsity, trim(name)) - end do + integer :: i + integer :: old_size - end subroutine insert_and_alias_csr_sparsity + if (.not.associated(state%csr_matrices)) then + ! Special case first entry. + allocate(state%csr_matrices(1)) + allocate(state%csr_matrices(1)%ptr) + allocate(state%csr_matrix_names(1)) - subroutine insert_block_csr_matrix(state, matrix, name) - !!< Insert a block matrix into state. - type(state_type), intent(inout) :: state - type(block_csr_matrix), intent(in) :: matrix - character(len=*), intent(in) :: name + state%csr_matrices(1)%ptr = matrix + state%csr_matrix_names(1) = name - type(block_csr_matrix_pointer), dimension(:), pointer :: tmp_block_csr_matrices - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + else - integer :: i - integer :: old_size + ! Check if the name is already present. + do i=1,size(state%csr_matrices) + if (trim(name)==trim(state%csr_matrix_names(i))) then + ! The name is present! + call deallocate(state%csr_matrices(i)%ptr) + state%csr_matrices(i)%ptr = matrix + call incref(matrix) + return + end if + end do - if (.not.associated(state%block_csr_matrices)) then - ! Special case first entry. - allocate(state%block_csr_matrices(1)) - allocate(state%block_csr_matrices(1)%ptr) - allocate(state%block_csr_matrix_names(1)) + ! If we get to here then this is a new matrix. + tmp_csr_matrices=>state%csr_matrices + tmp_names=>state%csr_matrix_names - state%block_csr_matrices(1)%ptr = matrix - state%block_csr_matrix_names(1) = name + old_size=size(tmp_csr_matrices) - else + allocate(state%csr_matrices(old_size+1)) + allocate(state%csr_matrices(old_size+1)%ptr) + allocate(state%csr_matrix_names(old_size+1)) - ! Check if the name is already present. - do i=1,size(state%block_csr_matrices) - if (trim(name)==trim(state%block_csr_matrix_names(i))) then - ! The name is present! - call deallocate(state%block_csr_matrices(i)%ptr) - state%block_csr_matrices(i)%ptr = matrix - call incref(matrix) - return - end if - end do + forall(i=1:old_size) + state%csr_matrices(i)%ptr => tmp_csr_matrices(i)%ptr + end forall + state%csr_matrix_names(1:old_size)= tmp_names - ! If we get to here then this is a new matrix. - tmp_block_csr_matrices=>state%block_csr_matrices - tmp_names=>state%block_csr_matrix_names + state%csr_matrices(old_size+1)%ptr = matrix + state%csr_matrix_names(old_size+1) = name - old_size=size(tmp_block_csr_matrices) + deallocate(tmp_names) + deallocate(tmp_csr_matrices) - allocate(state%block_csr_matrices(old_size+1)) - allocate(state%block_csr_matrices(old_size+1)%ptr) - allocate(state%block_csr_matrix_names(old_size+1)) + end if - forall(i=1:old_size) - state%block_csr_matrices(i)%ptr => tmp_block_csr_matrices(i)%ptr - end forall - state%block_csr_matrix_names(1:old_size)= tmp_names + call incref(matrix) - state%block_csr_matrices(old_size+1)%ptr = matrix - state%block_csr_matrix_names(old_size+1) = name + end subroutine insert_csr_matrix - deallocate(tmp_names) - deallocate(tmp_block_csr_matrices) + subroutine insert_and_alias_csr_matrix(state, matrix, name) + !!< Insert a matrix into all states + type(state_type), dimension(:), intent(inout) :: state + type(csr_matrix), intent(in) :: matrix + character(len=*), intent(in) :: name - end if + type(csr_matrix) :: p_matrix + integer :: i - call incref(matrix) + ! insert into state(1) + call insert(state(1), matrix, trim(name)) - end subroutine insert_block_csr_matrix + p_matrix=extract_csr_matrix(state(1), trim(name)) - subroutine insert_petsc_csr_matrix(state, matrix, name) - !!< Insert a block matrix into state. - type(state_type), intent(inout) :: state - type(petsc_csr_matrix), intent(in) :: matrix - character(len=*), intent(in) :: name + do i = 2, size(state) + call insert(state(i), p_matrix, trim(name)) + end do - type(petsc_csr_matrix_pointer), dimension(:), pointer :: tmp_petsc_csr_matrices - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + end subroutine insert_and_alias_csr_matrix - integer :: i - integer :: old_size + subroutine insert_and_alias_csr_sparsity(state, sparsity, name) + !!< Insert a sparsity into state all states + type(state_type), dimension(:), intent(inout) :: state + type(csr_sparsity), intent(in) :: sparsity + character(len=*), intent(in) :: name - if (.not.associated(state%petsc_csr_matrices)) then - ! Special case first entry. - allocate(state%petsc_csr_matrices(1)) - allocate(state%petsc_csr_matrices(1)%ptr) - allocate(state%petsc_csr_matrix_names(1)) + type(csr_sparsity) :: p_sparsity + integer :: i - state%petsc_csr_matrices(1)%ptr = matrix - state%petsc_csr_matrix_names(1) = name + ! insert into state(1) + call insert(state(1), sparsity, trim(name)) - else + p_sparsity=extract_csr_sparsity(state(1), trim(name)) - ! Check if the name is already present. - do i=1,size(state%petsc_csr_matrices) - if (trim(name)==trim(state%petsc_csr_matrix_names(i))) then - ! The name is present! - call deallocate(state%petsc_csr_matrices(i)%ptr) - state%petsc_csr_matrices(i)%ptr = matrix - !call incref(matrix) - call incref_petsc_csr_matrix(matrix) - return - end if - end do + do i = 2, size(state) + call insert(state(i), p_sparsity, trim(name)) + end do - ! If we get to here then this is a new matrix. - tmp_petsc_csr_matrices=>state%petsc_csr_matrices - tmp_names=>state%petsc_csr_matrix_names + end subroutine insert_and_alias_csr_sparsity - old_size=size(tmp_petsc_csr_matrices) + subroutine insert_block_csr_matrix(state, matrix, name) + !!< Insert a block matrix into state. + type(state_type), intent(inout) :: state + type(block_csr_matrix), intent(in) :: matrix + character(len=*), intent(in) :: name - allocate(state%petsc_csr_matrices(old_size+1)) - allocate(state%petsc_csr_matrices(old_size+1)%ptr) - allocate(state%petsc_csr_matrix_names(old_size+1)) + type(block_csr_matrix_pointer), dimension(:), pointer :: tmp_block_csr_matrices + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - forall(i=1:old_size) - state%petsc_csr_matrices(i)%ptr => tmp_petsc_csr_matrices(i)%ptr - end forall - state%petsc_csr_matrix_names(1:old_size)= tmp_names + integer :: i + integer :: old_size - state%petsc_csr_matrices(old_size+1)%ptr = matrix - state%petsc_csr_matrix_names(old_size+1) = name + if (.not.associated(state%block_csr_matrices)) then + ! Special case first entry. + allocate(state%block_csr_matrices(1)) + allocate(state%block_csr_matrices(1)%ptr) + allocate(state%block_csr_matrix_names(1)) - deallocate(tmp_names) - deallocate(tmp_petsc_csr_matrices) + state%block_csr_matrices(1)%ptr = matrix + state%block_csr_matrix_names(1) = name - end if - call incref_petsc_csr_matrix(matrix) - !call incref(matrix) + else - end subroutine insert_petsc_csr_matrix + ! Check if the name is already present. + do i=1,size(state%block_csr_matrices) + if (trim(name)==trim(state%block_csr_matrix_names(i))) then + ! The name is present! + call deallocate(state%block_csr_matrices(i)%ptr) + state%block_csr_matrices(i)%ptr = matrix + call incref(matrix) + return + end if + end do - subroutine insert_and_alias_block_csr_matrix(state, matrix, name) - !!< Insert a matrix into state. - type(state_type), dimension(:), intent(inout) :: state - type(block_csr_matrix), intent(in) :: matrix - character(len=*), intent(in) :: name + ! If we get to here then this is a new matrix. + tmp_block_csr_matrices=>state%block_csr_matrices + tmp_names=>state%block_csr_matrix_names - type(block_csr_matrix) :: p_matrix - integer :: i + old_size=size(tmp_block_csr_matrices) - ! insert into state(1) - call insert(state(1), matrix, trim(name)) + allocate(state%block_csr_matrices(old_size+1)) + allocate(state%block_csr_matrices(old_size+1)%ptr) + allocate(state%block_csr_matrix_names(old_size+1)) - p_matrix=extract_block_csr_matrix(state(1), trim(name)) + forall(i=1:old_size) + state%block_csr_matrices(i)%ptr => tmp_block_csr_matrices(i)%ptr + end forall + state%block_csr_matrix_names(1:old_size)= tmp_names - do i = 2, size(state) - call insert(state(i), p_matrix, trim(name)) - end do + state%block_csr_matrices(old_size+1)%ptr = matrix + state%block_csr_matrix_names(old_size+1) = name - end subroutine insert_and_alias_block_csr_matrix + deallocate(tmp_names) + deallocate(tmp_block_csr_matrices) - subroutine insert_and_alias_petsc_csr_matrix(state, matrix, name) - !!< Insert a matrix into state. - type(state_type), dimension(:), intent(inout) :: state - type(petsc_csr_matrix), intent(in) :: matrix - character(len=*), intent(in) :: name + end if - type(petsc_csr_matrix) :: p_matrix - integer :: i + call incref(matrix) - ! insert into state(1) - call insert(state(1), matrix, trim(name)) + end subroutine insert_block_csr_matrix - p_matrix=extract_petsc_csr_matrix(state(1), trim(name)) + subroutine insert_petsc_csr_matrix(state, matrix, name) + !!< Insert a block matrix into state. + type(state_type), intent(inout) :: state + type(petsc_csr_matrix), intent(in) :: matrix + character(len=*), intent(in) :: name - do i = 2, size(state) - call insert(state(i), p_matrix, trim(name)) - end do - - end subroutine insert_and_alias_petsc_csr_matrix - - subroutine insert_state_fields(state, donor) - !!< Insert fields contained in donor into state + type(petsc_csr_matrix_pointer), dimension(:), pointer :: tmp_petsc_csr_matrices + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - type(state_type), intent(inout) :: state - type(state_type), intent(in) :: donor - - integer :: i - type(scalar_field), pointer :: s_field - type(tensor_field), pointer :: t_field - type(vector_field), pointer :: v_field - - do i = 1, scalar_field_count(donor) - s_field => extract_scalar_field(donor, i) - call insert(state, s_field, s_field%name) - end do - - do i = 1, vector_field_count(donor) - v_field => extract_vector_field(donor, i) - call insert(state, v_field, v_field%name) - end do - - do i = 1, tensor_field_count(donor) - t_field => extract_tensor_field(donor, i) - call insert(state, t_field, t_field%name) - end do - - end subroutine insert_state_fields - - subroutine remove_tensor_field(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat + integer :: i + integer :: old_size - type(tensor_field_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size + if (.not.associated(state%petsc_csr_matrices)) then + ! Special case first entry. + allocate(state%petsc_csr_matrices(1)) + allocate(state%petsc_csr_matrices(1)%ptr) + allocate(state%petsc_csr_matrix_names(1)) - if (.not. has_tensor_field(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Field name: "//trim(name) - FLExit("You're trying to remove a tensor field .. that isn't there!") - end if - end if - - tmp_fields=>state%tensor_fields - tmp_names=>state%tensor_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%tensor_fields(old_size-1)) - allocate(state%tensor_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%tensor_fields(j)%ptr => tmp_fields(i)%ptr - state%tensor_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_tensor_field - - subroutine remove_vector_field(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat - - type(vector_field_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size - - if (.not. has_vector_field(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Field name: "//trim(name) - FLExit("You're trying to remove a vector field .. that isn't there!") - end if - end if - - tmp_fields=>state%vector_fields - tmp_names=>state%vector_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%vector_fields(old_size-1)) - allocate(state%vector_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%vector_fields(j)%ptr => tmp_fields(i)%ptr - state%vector_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_vector_field - - subroutine remove_scalar_field(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat - - type(scalar_field_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size - - if (.not. has_scalar_field(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Field name: "//trim(name) - FLExit("You're trying to remove a scalar field .. that isn't there!") - end if - end if - - tmp_fields=>state%scalar_fields - tmp_names=>state%scalar_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%scalar_fields(old_size-1)) - allocate(state%scalar_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%scalar_fields(j)%ptr => tmp_fields(i)%ptr - state%scalar_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_scalar_field - - subroutine remove_csr_sparsity(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat - - type(csr_sparsity_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size - - if (.not. has_csr_sparsity(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Sparsity name: "//trim(name) - FLExit("You're trying to remove a csr sparsity .. that isn't there!") - end if - end if - - tmp_fields=>state%csr_sparsities - tmp_names=>state%csr_sparsity_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%csr_sparsities(old_size-1)) - allocate(state%csr_sparsity_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%csr_sparsities(j)%ptr => tmp_fields(i)%ptr - state%csr_sparsity_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_csr_sparsity - - subroutine remove_csr_matrix(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat - - type(csr_matrix_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size - - if (.not. has_csr_matrix(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Matrix name: "//trim(name) - FLExit("You're trying to remove a csr matrix .. that isn't there!") - end if - end if - - tmp_fields=>state%csr_matrices - tmp_names=>state%csr_matrix_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%csr_matrices(old_size-1)) - allocate(state%csr_matrix_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%csr_matrices(j)%ptr => tmp_fields(i)%ptr - state%csr_matrix_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_csr_matrix - - subroutine remove_block_csr_matrix(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat - - type(block_csr_matrix_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size - - if (.not. has_block_csr_matrix(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Matrix name: "//trim(name) - FLExit("You're trying to remove a block csr matrix .. that isn't there!") - end if - end if - - tmp_fields=>state%block_csr_matrices - tmp_names=>state%block_csr_matrix_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%block_csr_matrices(old_size-1)) - allocate(state%block_csr_matrix_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%block_csr_matrices(j)%ptr => tmp_fields(i)%ptr - state%block_csr_matrix_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_block_csr_matrix - - subroutine remove_petsc_csr_matrix(state, name, stat) - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: name - integer, optional, intent(out) :: stat - - type(petsc_csr_matrix_pointer), dimension(:), pointer :: tmp_fields - character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names - integer :: idx, i, j, old_size - - if (.not. has_petsc_csr_matrix(state, name)) then - if (present(stat)) then - stat=1 - else - ewrite(-1,*) "State: "//trim(state%name) - ewrite(-1,*) "Matrix name: "//trim(name) - FLExit("You're trying to remove a block csr matrix .. that isn't there!") - end if - end if - - tmp_fields=>state%petsc_csr_matrices - tmp_names=>state%petsc_csr_matrix_names - - old_size=size(tmp_fields) - - do i=1,old_size - if (trim(tmp_names(i)) == name) then - idx = i - exit - end if - end do - - allocate(state%petsc_csr_matrices(old_size-1)) - allocate(state%petsc_csr_matrix_names(old_size-1)) - - j = 0 - do i=1,old_size - if (i /= idx) then - j = j + 1 - state%petsc_csr_matrices(j)%ptr => tmp_fields(i)%ptr - state%petsc_csr_matrix_names(j) = tmp_names(i) - end if - end do - - call deallocate(tmp_fields(idx)%ptr) - deallocate(tmp_fields(idx)%ptr) - - deallocate(tmp_fields) - deallocate(tmp_names) - - end subroutine remove_petsc_csr_matrix - - function field_rank(state, name, stat) - !!< Return the rank of the named field in state - - type(state_type), intent(in) :: state - character(len = *), intent(in) :: name - integer, optional, intent(out) :: stat - - integer :: field_rank - - logical :: s_field, v_field, t_field - - if(present(stat)) stat = 0 - - s_field = has_scalar_field(state, name) - v_field = has_vector_field(state, name) - t_field = has_tensor_field(state, name) + state%petsc_csr_matrices(1)%ptr = matrix + state%petsc_csr_matrix_names(1) = name - if(count((/s_field, v_field, t_field/)) > 1) then - if(present(stat)) then - stat = 2 - else - FLAbort("Multiple field types found for field " // trim(name)) - end if - else if(s_field) then - field_rank = 0 - else if(v_field) then - field_rank = 1 - else if(t_field) then - field_rank = 2 - else - if(present(stat)) then - stat = 1 else - FLExit(trim(name) // " is not a field name in this state") - end if - end if - end function field_rank + ! Check if the name is already present. + do i=1,size(state%petsc_csr_matrices) + if (trim(name)==trim(state%petsc_csr_matrix_names(i))) then + ! The name is present! + call deallocate(state%petsc_csr_matrices(i)%ptr) + state%petsc_csr_matrices(i)%ptr = matrix + !call incref(matrix) + call incref_petsc_csr_matrix(matrix) + return + end if + end do - function extract_tensor_field(state, name, stat) result (field) - !!< Return a pointer to the tensor field with the correct name. - type(tensor_field), pointer :: field - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat + ! If we get to here then this is a new matrix. + tmp_petsc_csr_matrices=>state%petsc_csr_matrices + tmp_names=>state%petsc_csr_matrix_names - integer :: i + old_size=size(tmp_petsc_csr_matrices) - if (present(stat)) stat=0 - field => fake_tensor_field + allocate(state%petsc_csr_matrices(old_size+1)) + allocate(state%petsc_csr_matrices(old_size+1)%ptr) + allocate(state%petsc_csr_matrix_names(old_size+1)) - if (associated(state%tensor_fields)) then - do i=1,size(state%tensor_fields) - if (trim(name)==trim(state%tensor_names(i))) then - ! Found the right field + forall(i=1:old_size) + state%petsc_csr_matrices(i)%ptr => tmp_petsc_csr_matrices(i)%ptr + end forall + state%petsc_csr_matrix_names(1:old_size)= tmp_names - field=>state%tensor_fields(i)%ptr - return - end if - end do - end if + state%petsc_csr_matrices(old_size+1)%ptr = matrix + state%petsc_csr_matrix_names(old_size+1) = name + + deallocate(tmp_names) + deallocate(tmp_petsc_csr_matrices) - ! We didn't find name! - if (present(stat)) then - stat=1 - else - if (associated(state%tensor_names)) then - do i=1,size(state%tensor_names) - ewrite(-1,*) "i: ", i, " -- ", state%tensor_names(i) - end do - end if - FLExit(trim(name)//" is not a field name in this state") - end if - - end function extract_tensor_field - - function extract_from_one_vector_field(state, name, stat) result (field) - !!< Return a pointer to the vector field with the correct name. - type(vector_field), pointer :: field - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i - - if (present(stat)) stat=0 - field => fake_vector_field - - if (associated(state%vector_fields)) then - do i=1,size(state%vector_fields) - if (trim(name)==trim(state%vector_names(i))) then - ! Found the right field - - field=>state%vector_fields(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - if (associated(state%vector_names)) then - do i=1,size(state%vector_names) - ewrite(-1,*) "i: ", i, " -- ", state%vector_names(i) - end do - end if - FLExit(trim(name)//" is not a field name in this state") - end if - - end function extract_from_one_vector_field - - function extract_from_one_scalar_field(state, name, stat, allocated) result (field) - !!< Return a pointer to the scalar field with the correct name. - type(scalar_field), pointer :: field - type(scalar_field), pointer :: mem - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - logical, intent(out), optional :: allocated - type(vector_field), pointer :: vfield - - integer :: i, lstat, idx, dim - - if (present(stat)) stat=0 - field => fake_scalar_field - - ! if the allocated flag is present - ! then you can look in the vector and tensor - ! fields for names of the form - ! Velocity%1 - if (present(allocated)) then - allocated = .false. - idx = index(name, "%") - if (idx /= 0) then - read(name(idx+1:len(name)), *) dim - vfield => extract_vector_field(state, name(1:idx-1), lstat) - if (lstat == 0) then - allocate(mem) - allocated = .true. - mem = extract_scalar_field(vfield, dim, lstat) - if (lstat /= 0) then - deallocate(mem) - allocated = .false. - if (present(stat)) then - stat = 1 - else - ewrite(-1,*) "name: ", name - FLExit("Couldn't find vector/tensor component!") - end if - end if - field => mem - return - end if - end if - end if - - if (associated(state%scalar_fields)) then - do i=1,size(state%scalar_fields) - if (trim(name)==trim(state%scalar_names(i))) then - ! Found the right field - - field=>state%scalar_fields(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - if (associated(state%scalar_names)) then - do i=1,size(state%scalar_names) - ewrite(-1,*) "i: ", i, " -- ", state%scalar_names(i) - end do - end if - FLExit(trim(name)//" is not a field name in this state") - end if - - end function extract_from_one_scalar_field - - function extract_from_any_scalar_field(state, name, stat, allocated) result (field) - !!< Return a pointer to the scalar field with the correct name. - type(scalar_field), pointer :: field - type(scalar_field), pointer :: mem - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - logical, intent(out), optional :: allocated - type(vector_field), pointer :: vfield - - integer :: i, j, lstat, idx, dim - - if (present(stat)) stat=0 - field => fake_scalar_field - - ! if the allocated flag is present - ! then you can look in the vector and tensor - ! fields for names of the form - ! Velocity%1 - if (present(allocated)) then - allocated = .false. - idx = index(name, "%") - if (idx /= 0) then - read(name(idx+1:len(name)), *) dim - do i = 1, size(state) - vfield => extract_vector_field(state(i), name(1:idx-1), lstat) - if (lstat == 0) then - allocate(mem) - allocated = .true. - mem = extract_scalar_field(vfield, dim, lstat) - if (lstat /= 0) then - deallocate(mem) - allocated = .false. - if (present(stat)) then - stat = 1 - else - ewrite(-1,*) "name: ", name - FLExit("Couldn't find vector/tensor component!") - end if - end if - field => mem - return - end if - end do end if - end if + call incref_petsc_csr_matrix(matrix) + !call incref(matrix) - do i = 1, size(state) - if (associated(state(i)%scalar_fields)) then - do j=1,size(state(i)%scalar_fields) - if (trim(name)==trim(state(i)%scalar_names(j))) then - ! Found the right field + end subroutine insert_petsc_csr_matrix - field=>state(i)%scalar_fields(j)%ptr - return - end if - end do - end if - end do + subroutine insert_and_alias_block_csr_matrix(state, matrix, name) + !!< Insert a matrix into state. + type(state_type), dimension(:), intent(inout) :: state + type(block_csr_matrix), intent(in) :: matrix + character(len=*), intent(in) :: name - ! We didn't find name! - if (present(stat)) then - stat=1 - else - do i = 1, size(state) - if (associated(state(i)%scalar_names)) then - do j=1,size(state(i)%scalar_names) - ewrite(-1,*) "i, j: ", i, j, " -- ", state(i)%scalar_names(j) - end do - end if - end do - FLExit(trim(name)//" is not a field name in these states") - end if + type(block_csr_matrix) :: p_matrix + integer :: i + + ! insert into state(1) + call insert(state(1), matrix, trim(name)) - end function extract_from_any_scalar_field + p_matrix=extract_block_csr_matrix(state(1), trim(name)) - function extract_from_any_vector_field(state, name, stat) result (field) - !!< Return a pointer to the vector field with the correct name. - type(vector_field), pointer :: field - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat + do i = 2, size(state) + call insert(state(i), p_matrix, trim(name)) + end do - integer :: i, j + end subroutine insert_and_alias_block_csr_matrix - if (present(stat)) stat=0 - field => fake_vector_field + subroutine insert_and_alias_petsc_csr_matrix(state, matrix, name) + !!< Insert a matrix into state. + type(state_type), dimension(:), intent(inout) :: state + type(petsc_csr_matrix), intent(in) :: matrix + character(len=*), intent(in) :: name - do i = 1, size(state) - if (associated(state(i)%vector_fields)) then - do j=1,size(state(i)%vector_fields) - if (trim(name)==trim(state(i)%vector_names(j))) then - ! Found the right field + type(petsc_csr_matrix) :: p_matrix + integer :: i - field=>state(i)%vector_fields(j)%ptr - return - end if - end do - end if - end do + ! insert into state(1) + call insert(state(1), matrix, trim(name)) - ! We didn't find name! - if (present(stat)) then - stat=1 - else - do i = 1, size(state) - if (associated(state(i)%vector_names)) then - do j=1,size(state(i)%vector_names) - ewrite(-1,*) "i, j: ", i, j, " -- ", state(i)%vector_names(j) - end do - end if + p_matrix=extract_petsc_csr_matrix(state(1), trim(name)) + + do i = 2, size(state) + call insert(state(i), p_matrix, trim(name)) end do - FLExit(trim(name)//" is not a field name in these states") - end if - end function extract_from_any_vector_field + end subroutine insert_and_alias_petsc_csr_matrix - function extract_field_mesh(state, name, stat) result(mesh) - !!< Return the mesh for the named field in state + subroutine insert_state_fields(state, donor) + !!< Insert fields contained in donor into state - type(state_type), intent(in) :: state - character(len = *), intent(in) :: name - integer, optional, intent(out) :: stat + type(state_type), intent(inout) :: state + type(state_type), intent(in) :: donor - type(mesh_type), pointer :: mesh + integer :: i + type(scalar_field), pointer :: s_field + type(tensor_field), pointer :: t_field + type(vector_field), pointer :: v_field - integer :: s_stat, v_stat, t_stat - type(scalar_field), pointer :: s_field - type(tensor_field), pointer :: t_field - type(vector_field), pointer :: v_field + do i = 1, scalar_field_count(donor) + s_field => extract_scalar_field(donor, i) + call insert(state, s_field, s_field%name) + end do - if(present(stat)) stat = 0 + do i = 1, vector_field_count(donor) + v_field => extract_vector_field(donor, i) + call insert(state, v_field, v_field%name) + end do - s_field => extract_scalar_field(state, name, s_stat) - v_field => extract_vector_field(state, name, v_stat) - t_field => extract_tensor_field(state, name, t_stat) + do i = 1, tensor_field_count(donor) + t_field => extract_tensor_field(donor, i) + call insert(state, t_field, t_field%name) + end do - if(count((/s_stat == 0, v_stat == 0, t_stat == 0/)) > 1) then - if(present(stat)) then - stat = 2 - else - FLAbort("Multiple field types found for field " // trim(name)) - end if - else if(s_stat == 0) then - mesh => s_field%mesh - else if(v_stat == 0) then - mesh => v_field%mesh - else if(t_stat == 0) then - mesh => t_field%mesh - else - if(present(stat)) then - stat = 1 - else - FLExit(trim(name) // " is not a field name in this state") + end subroutine insert_state_fields + + subroutine remove_tensor_field(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(tensor_field_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_tensor_field(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Field name: "//trim(name) + FLExit("You're trying to remove a tensor field .. that isn't there!") + end if end if - end if - end function extract_field_mesh + tmp_fields=>state%tensor_fields + tmp_names=>state%tensor_names - function extract_mesh_from_one(state, name, stat) result (mesh) - !!< Return a pointer to the mesh with the correct name. - type(mesh_type), pointer :: mesh - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat + old_size=size(tmp_fields) - integer :: i + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - if (present(stat)) stat=0 - mesh => fake_mesh + allocate(state%tensor_fields(old_size-1)) + allocate(state%tensor_names(old_size-1)) - if (associated(state%meshes)) then - do i=1,size(state%meshes) - if (trim(name)==trim(state%mesh_names(i))) then - ! Found the right field + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%tensor_fields(j)%ptr => tmp_fields(i)%ptr + state%tensor_names(j) = tmp_names(i) + end if + end do - mesh=>state%meshes(i)%ptr - return - end if - end do - end if + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a mesh name in this state") - end if + deallocate(tmp_fields) + deallocate(tmp_names) - end function extract_mesh_from_one + end subroutine remove_tensor_field + + subroutine remove_vector_field(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(vector_field_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_vector_field(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Field name: "//trim(name) + FLExit("You're trying to remove a vector field .. that isn't there!") + end if + end if - function extract_mesh_from_any(state, name, stat) result (mesh) - !!< Return a pointer to the mesh with the correct name. - type(mesh_type), pointer :: mesh - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat + tmp_fields=>state%vector_fields + tmp_names=>state%vector_names - integer :: i, j + old_size=size(tmp_fields) - if (present(stat)) stat=0 - mesh => fake_mesh + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - do i = 1, size(state) - if (associated(state(i)%meshes)) then - do j=1,size(state(i)%meshes) - if (trim(name)==trim(state(i)%mesh_names(j))) then - ! Found the right field + allocate(state%vector_fields(old_size-1)) + allocate(state%vector_names(old_size-1)) - mesh=>state(i)%meshes(j)%ptr - return - end if - end do - end if - end do - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a mesh name in these state") - end if - - end function extract_mesh_from_any - - function extract_halo(state, name, stat) result (halo) - !!< Return a pointer to the halo with the correct name. - type(halo_type), pointer :: halo - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i - - if (present(stat)) stat=0 - halo => fake_halo - - if (associated(state%halos)) then - do i=1,size(state%halos) - if (trim(name)==trim(state%halo_names(i))) then - ! Found the right halo - - halo=>state%halos(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a halo name in this state") - end if - - end function extract_halo - - function extract_from_one_csr_sparsity(state, name, stat) result (sparsity) - !!< Return a pointer to the sparsity with the correct name. - type(csr_sparsity), pointer :: sparsity - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i - - if (present(stat)) stat=0 - sparsity => fake_csr_sparsity - - if (associated(state%csr_sparsities)) then - do i=1,size(state%csr_sparsities) - if (trim(name)==trim(state%csr_sparsity_names(i))) then - ! Found the right field - - sparsity=>state%csr_sparsities(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a sparsity name in this state") - end if - - end function extract_from_one_csr_sparsity - - function extract_from_any_csr_sparsity(state, name, stat) result (sparsity) - !!< Return a pointer to the sparsity with the correct name. - type(csr_sparsity), pointer :: sparsity - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i, j - - if (present(stat)) stat=0 - sparsity => fake_csr_sparsity - - do i = 1, size(state) - if (associated(state(i)%csr_sparsities)) then - do j=1,size(state(i)%csr_sparsities) - if (trim(name)==trim(state(i)%csr_sparsity_names(j))) then - ! Found the right field - - sparsity=>state(i)%csr_sparsities(j)%ptr - return - end if - end do - end if - end do - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a sparsity name in this state") - end if - - end function extract_from_any_csr_sparsity - - function extract_from_one_csr_matrix(state, name, stat) result (matrix) - !!< Return a pointer to the matrix with the correct name. - type(csr_matrix), pointer :: matrix - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i - - if (present(stat)) stat=0 - matrix => fake_csr_matrix - - if (associated(state%csr_matrices)) then - do i=1,size(state%csr_matrices) - if (trim(name)==trim(state%csr_matrix_names(i))) then - ! Found the right field - matrix=>state%csr_matrices(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a matrix name in this state") - end if - - end function extract_from_one_csr_matrix - - function extract_from_any_csr_matrix(state, name, stat) result (matrix) - !!< Return a pointer to the matrix with the correct name. - type(csr_matrix), pointer :: matrix - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i, j - - if (present(stat)) stat=0 - matrix => fake_csr_matrix - - do i = 1, size(state) - if (associated(state(i)%csr_matrices)) then - do j=1,size(state(i)%csr_matrices) - if (trim(name)==trim(state(i)%csr_matrix_names(j))) then - ! Found the right field - matrix=>state(i)%csr_matrices(j)%ptr - return - end if - end do - end if - end do - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a matrix name in these states") - end if - - end function extract_from_any_csr_matrix - - function extract_from_one_block_csr_matrix(state, name, stat) result (matrix) - !!< Return a pointer to the block matrix with the correct name. - type(block_csr_matrix), pointer :: matrix - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i - - if (present(stat)) stat=0 - matrix => fake_block_csr_matrix - - if (associated(state%block_csr_matrices)) then - do i=1,size(state%block_csr_matrices) - if (trim(name)==trim(state%block_csr_matrix_names(i))) then - ! Found the right field - matrix=>state%block_csr_matrices(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a block matrix name in this state") - end if - - end function extract_from_one_block_csr_matrix - - function extract_from_one_petsc_csr_matrix(state, name, stat) result (matrix) - !!< Return a pointer to the block matrix with the correct name. - type(petsc_csr_matrix), pointer :: matrix - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i - - if (present(stat)) stat=0 - matrix => fake_petsc_csr_matrix - - if (associated(state%petsc_csr_matrices)) then - do i=1,size(state%petsc_csr_matrices) - if (trim(name)==trim(state%petsc_csr_matrix_names(i))) then - ! Found the right field - matrix=>state%petsc_csr_matrices(i)%ptr - return - end if - end do - end if - - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a petsc matrix name in this state") - end if - - end function extract_from_one_petsc_csr_matrix - - function extract_from_any_block_csr_matrix(state, name, stat) result (matrix) - !!< Return a pointer to the block matrix with the correct name. - type(block_csr_matrix), pointer :: matrix - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat - - integer :: i, j - - if (present(stat)) stat=0 - matrix => fake_block_csr_matrix - - do i = 1, size(state) - if (associated(state(i)%block_csr_matrices)) then - do j=1,size(state(i)%block_csr_matrices) - if (trim(name)==trim(state(i)%block_csr_matrix_names(j))) then - ! Found the right field - matrix=>state(i)%block_csr_matrices(j)%ptr - return - end if - end do + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%vector_fields(j)%ptr => tmp_fields(i)%ptr + state%vector_names(j) = tmp_names(i) + end if + end do + + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) + + deallocate(tmp_fields) + deallocate(tmp_names) + + end subroutine remove_vector_field + + subroutine remove_scalar_field(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(scalar_field_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_scalar_field(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Field name: "//trim(name) + FLExit("You're trying to remove a scalar field .. that isn't there!") + end if end if - end do - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a block matrix name in these states") - end if + tmp_fields=>state%scalar_fields + tmp_names=>state%scalar_names - end function extract_from_any_block_csr_matrix + old_size=size(tmp_fields) - function extract_from_any_petsc_csr_matrix(state, name, stat) result (matrix) - !!< Return a pointer to the block matrix with the correct name. - type(petsc_csr_matrix), pointer :: matrix - type(state_type), dimension(:), intent(in) :: state - character(len=*), intent(in) :: name - integer, intent(out), optional :: stat + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - integer :: i, j + allocate(state%scalar_fields(old_size-1)) + allocate(state%scalar_names(old_size-1)) - if (present(stat)) stat=0 - matrix => fake_petsc_csr_matrix + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%scalar_fields(j)%ptr => tmp_fields(i)%ptr + state%scalar_names(j) = tmp_names(i) + end if + end do - do i = 1, size(state) - if (associated(state(i)%petsc_csr_matrices)) then - do j=1,size(state(i)%petsc_csr_matrices) - if (trim(name)==trim(state(i)%petsc_csr_matrix_names(j))) then - ! Found the right field - matrix=>state(i)%petsc_csr_matrices(j)%ptr - return - end if - end do - end if - end do + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) - ! We didn't find name! - if (present(stat)) then - stat=1 - else - FLExit(trim(name)//" is not a petsc matrix name in these states") - end if + deallocate(tmp_fields) + deallocate(tmp_names) - end function extract_from_any_petsc_csr_matrix + end subroutine remove_scalar_field + + subroutine remove_csr_sparsity(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(csr_sparsity_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_csr_sparsity(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Sparsity name: "//trim(name) + FLExit("You're trying to remove a csr sparsity .. that isn't there!") + end if + end if - function extract_scalar_field_by_index(state, index) result (field) - !!< Return a pointer to the indexth scalar field in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(scalar_field), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + tmp_fields=>state%csr_sparsities + tmp_names=>state%csr_sparsity_names - assert(index<=scalar_field_count(state)) + old_size=size(tmp_fields) - field=>state%scalar_fields(index)%ptr + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - end function extract_scalar_field_by_index + allocate(state%csr_sparsities(old_size-1)) + allocate(state%csr_sparsity_names(old_size-1)) - function extract_vector_field_by_index(state, index) result (field) - !!< Return a pointer to the indexth vector field in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(vector_field), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%csr_sparsities(j)%ptr => tmp_fields(i)%ptr + state%csr_sparsity_names(j) = tmp_names(i) + end if + end do - assert(index<=vector_field_count(state)) + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) - field=>state%vector_fields(index)%ptr + deallocate(tmp_fields) + deallocate(tmp_names) - end function extract_vector_field_by_index + end subroutine remove_csr_sparsity + + subroutine remove_csr_matrix(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(csr_matrix_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_csr_matrix(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Matrix name: "//trim(name) + FLExit("You're trying to remove a csr matrix .. that isn't there!") + end if + end if - function extract_tensor_field_by_index(state, index) result (field) - !!< Return a pointer to the indexth tensor field in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(tensor_field), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + tmp_fields=>state%csr_matrices + tmp_names=>state%csr_matrix_names - assert(index<=tensor_field_count(state)) + old_size=size(tmp_fields) - field=>state%tensor_fields(index)%ptr + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - end function extract_tensor_field_by_index + allocate(state%csr_matrices(old_size-1)) + allocate(state%csr_matrix_names(old_size-1)) - function extract_mesh_by_index(state, index) result (field) - !!< Return a pointer to the indexth mesh in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(mesh_type), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%csr_matrices(j)%ptr => tmp_fields(i)%ptr + state%csr_matrix_names(j) = tmp_names(i) + end if + end do - assert(index<=mesh_count(state)) + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) - field=>state%meshes(index)%ptr + deallocate(tmp_fields) + deallocate(tmp_names) - end function extract_mesh_by_index + end subroutine remove_csr_matrix + + subroutine remove_block_csr_matrix(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(block_csr_matrix_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_block_csr_matrix(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Matrix name: "//trim(name) + FLExit("You're trying to remove a block csr matrix .. that isn't there!") + end if + end if - function extract_halo_by_index(state, index) result (field) - !!< Return a pointer to the indexth halo in state. - !!< This is primarily useful for looping over all the halos in a - !!< state. - type(halo_type), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + tmp_fields=>state%block_csr_matrices + tmp_names=>state%block_csr_matrix_names - assert(index<=halo_count(state)) + old_size=size(tmp_fields) - field=>state%halos(index)%ptr + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - end function extract_halo_by_index + allocate(state%block_csr_matrices(old_size-1)) + allocate(state%block_csr_matrix_names(old_size-1)) - function extract_csr_sparsity_by_index(state, index) result (field) - !!< Return a pointer to the indexth csr sparsity in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(csr_sparsity), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%block_csr_matrices(j)%ptr => tmp_fields(i)%ptr + state%block_csr_matrix_names(j) = tmp_names(i) + end if + end do - assert(index<=csr_sparsity_count(state)) + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) - field=>state%csr_sparsities(index)%ptr + deallocate(tmp_fields) + deallocate(tmp_names) - end function extract_csr_sparsity_by_index + end subroutine remove_block_csr_matrix + + subroutine remove_petsc_csr_matrix(state, name, stat) + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: name + integer, optional, intent(out) :: stat + + type(petsc_csr_matrix_pointer), dimension(:), pointer :: tmp_fields + character(len=FIELD_NAME_LEN), dimension(:), pointer :: tmp_names + integer :: idx, i, j, old_size + + if (.not. has_petsc_csr_matrix(state, name)) then + if (present(stat)) then + stat=1 + else + ewrite(-1,*) "State: "//trim(state%name) + ewrite(-1,*) "Matrix name: "//trim(name) + FLExit("You're trying to remove a block csr matrix .. that isn't there!") + end if + end if - function extract_csr_matrix_by_index(state, index) result (field) - !!< Return a pointer to the indexth csr matrix in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(csr_matrix), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + tmp_fields=>state%petsc_csr_matrices + tmp_names=>state%petsc_csr_matrix_names - assert(index<=csr_matrix_count(state)) + old_size=size(tmp_fields) - field=>state%csr_matrices(index)%ptr + do i=1,old_size + if (trim(tmp_names(i)) == name) then + idx = i + exit + end if + end do - end function extract_csr_matrix_by_index + allocate(state%petsc_csr_matrices(old_size-1)) + allocate(state%petsc_csr_matrix_names(old_size-1)) - function extract_block_csr_matrix_by_index(state, index) result (field) - !!< Return a pointer to the indexth block csr matrix in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(block_csr_matrix), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + j = 0 + do i=1,old_size + if (i /= idx) then + j = j + 1 + state%petsc_csr_matrices(j)%ptr => tmp_fields(i)%ptr + state%petsc_csr_matrix_names(j) = tmp_names(i) + end if + end do - assert(index<=block_csr_matrix_count(state)) + call deallocate(tmp_fields(idx)%ptr) + deallocate(tmp_fields(idx)%ptr) - field=>state%block_csr_matrices(index)%ptr + deallocate(tmp_fields) + deallocate(tmp_names) - end function extract_block_csr_matrix_by_index + end subroutine remove_petsc_csr_matrix - function extract_petsc_csr_matrix_by_index(state, index) result (field) - !!< Return a pointer to the indexth block csr matrix in state. - !!< This is primarily useful for looping over all the fields in a - !!< state. - type(petsc_csr_matrix), pointer :: field - type(state_type), intent(in) :: state - integer, intent(in) :: index + function field_rank(state, name, stat) + !!< Return the rank of the named field in state - assert(index<=petsc_csr_matrix_count(state)) + type(state_type), intent(in) :: state + character(len = *), intent(in) :: name + integer, optional, intent(out) :: stat - field=>state%petsc_csr_matrices(index)%ptr + integer :: field_rank - end function extract_petsc_csr_matrix_by_index + logical :: s_field, v_field, t_field - function has_scalar_field(state, name) result(present) - !!< Return true if there is a field named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name + if(present(stat)) stat = 0 - if (associated(state%scalar_names)) then - present=any(trim(name)==state%scalar_names) - else - present=.false. - end if + s_field = has_scalar_field(state, name) + v_field = has_vector_field(state, name) + t_field = has_tensor_field(state, name) - end function has_scalar_field + if(count((/s_field, v_field, t_field/)) > 1) then + if(present(stat)) then + stat = 2 + else + FLAbort("Multiple field types found for field " // trim(name)) + end if + else if(s_field) then + field_rank = 0 + else if(v_field) then + field_rank = 1 + else if(t_field) then + field_rank = 2 + else + if(present(stat)) then + stat = 1 + else + FLExit(trim(name) // " is not a field name in this state") + end if + end if - function has_vector_field(state, name) result(present) - !!< Return true if there is a field named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%vector_names)) then - present=any(trim(name)==state%vector_names) - else - present=.false. - end if + end function field_rank - end function has_vector_field - - function has_tensor_field(state, name) result(present) - !!< Return true if there is a field named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%tensor_names)) then - present=any(trim(name)==state%tensor_names) - else - present=.false. - end if - - end function has_tensor_field - - function has_mesh(state, name) result(present) - !!< Return true if there is a mesh named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%mesh_names)) then - present=any(trim(name)==state%mesh_names) - else - present=.false. - end if - - end function has_mesh - - function state_has_halo(state, name) result(present) - !!< Return true if there is a halo named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%halo_names)) then - present=any(trim(name)==state%halo_names) - else - present=.false. - end if - - end function state_has_halo - - function has_csr_sparsity(state, name) result(present) - !!< Return true if there is a sparsity named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%csr_sparsity_names)) then - present=any(trim(name)==state%csr_sparsity_names) - else - present=.false. - end if - - end function has_csr_sparsity - - function has_csr_matrix(state, name) result(present) - !!< Return true if there is a matrix named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%csr_matrix_names)) then - present=any(trim(name)==state%csr_matrix_names) - else - present=.false. - end if - - end function has_csr_matrix - - function has_block_csr_matrix(state, name) result(present) - !!< Return true if there is a matrix named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%block_csr_matrix_names)) then - present=any(trim(name)==state%block_csr_matrix_names) - else - present=.false. - end if - - end function has_block_csr_matrix - - function has_petsc_csr_matrix(state, name) result(present) - !!< Return true if there is a matrix named name in state. - logical :: present - type(state_type), intent(in) :: state - character(len=*), intent(in) :: name - - if (associated(state%petsc_csr_matrix_names)) then - present=any(trim(name)==state%petsc_csr_matrix_names) - else - present=.false. - end if - - end function has_petsc_csr_matrix - - pure function field_count(state) - integer field_count - type(state_type), intent(in) :: state - - field_count = scalar_field_count(state) + & - vector_field_count(state) + & - tensor_field_count(state) - - end function field_count - - pure function scalar_field_count(state) - !!< Return the number of scalar fields in state. - integer :: scalar_field_count - type(state_type), intent(in) :: state - - if (associated(state%scalar_fields)) then - scalar_field_count=size(state%scalar_fields) - else - scalar_field_count=0 - end if - - end function scalar_field_count - - pure function vector_field_count(state) - !!< Return the number of vector fields in state. - integer :: vector_field_count - type(state_type), intent(in) :: state - - if (associated(state%vector_fields)) then - vector_field_count=size(state%vector_fields) - else - vector_field_count=0 - end if - - end function vector_field_count - - pure function tensor_field_count(state) - !!< Return the number of tensor fields in state. - integer :: tensor_field_count - type(state_type), intent(in) :: state - - if (associated(state%tensor_fields)) then - tensor_field_count=size(state%tensor_fields) - else - tensor_field_count=0 - end if - - end function tensor_field_count - - pure function mesh_count(state) - !!< Return the number of meshes in state. - integer :: mesh_count - type(state_type), intent(in) :: state - - if (associated(state%meshes)) then - mesh_count=size(state%meshes) - else - mesh_count=0 - end if - - end function mesh_count - - pure function halo_count_state(state) result(halo_count) - !!< Return the number of halos in state. - integer :: halo_count - type(state_type), intent(in) :: state + function extract_tensor_field(state, name, stat) result (field) + !!< Return a pointer to the tensor field with the correct name. + type(tensor_field), pointer :: field + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - if (associated(state%halos)) then - halo_count=size(state%halos) - else - halo_count=0 - end if - - end function halo_count_state - - pure function csr_sparsity_count(state) - !!< Return the number of csr_sparsities in state. - integer :: csr_sparsity_count - type(state_type), intent(in) :: state - - if (associated(state%csr_sparsities)) then - csr_sparsity_count=size(state%csr_sparsities) - else - csr_sparsity_count=0 - end if - - end function csr_sparsity_count - - pure function csr_matrix_count(state) - !!< Return the number of csr_matrices in state. - integer :: csr_matrix_count - type(state_type), intent(in) :: state - - if (associated(state%csr_matrices)) then - csr_matrix_count=size(state%csr_matrices) - else - csr_matrix_count=0 - end if + integer :: i - end function csr_matrix_count - - pure function block_csr_matrix_count(state) - !!< Return the number of csr_matrices in state. - integer :: block_csr_matrix_count - type(state_type), intent(in) :: state - - if (associated(state%block_csr_matrices)) then - block_csr_matrix_count=size(state%block_csr_matrices) - else - block_csr_matrix_count=0 - end if - - end function block_csr_matrix_count - - pure function petsc_csr_matrix_count(state) - !!< Return the number of csr_matrices in state. - integer :: petsc_csr_matrix_count - type(state_type), intent(in) :: state + if (present(stat)) stat=0 + field => fake_tensor_field - if (associated(state%petsc_csr_matrices)) then - petsc_csr_matrix_count=size(state%petsc_csr_matrices) - else - petsc_csr_matrix_count=0 - end if - - end function petsc_csr_matrix_count + if (associated(state%tensor_fields)) then + do i=1,size(state%tensor_fields) + if (trim(name)==trim(state%tensor_names(i))) then + ! Found the right field - subroutine set_vector_field_in_state(state, to_field_name, from_field_name) - !!< Set the value of to_field to the value of from_field. - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: to_field_name, from_field_name + field=>state%tensor_fields(i)%ptr + return + end if + end do + end if - type(vector_field), pointer :: to_field, from_field + ! We didn't find name! + if (present(stat)) then + stat=1 + else + if (associated(state%tensor_names)) then + do i=1,size(state%tensor_names) + ewrite(-1,*) "i: ", i, " -- ", state%tensor_names(i) + end do + end if + FLExit(trim(name)//" is not a field name in this state") + end if - to_field=>extract_vector_field(state, to_field_name) - from_field=>extract_vector_field(state, from_field_name) - - call set(to_field, from_field) + end function extract_tensor_field - end subroutine set_vector_field_in_state + function extract_from_one_vector_field(state, name, stat) result (field) + !!< Return a pointer to the vector field with the correct name. + type(vector_field), pointer :: field + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - integer function get_state_index(states, name, stat) - !!< Auxillary function to search in a set of states by name - type(state_type), dimension(:), intent(in):: states - character(len=*), intent(in):: name - integer, optional, intent(out):: stat + integer :: i - integer i + if (present(stat)) stat=0 + field => fake_vector_field - do i=1, size(states) - if (states(i)%name==name) then + if (associated(state%vector_fields)) then + do i=1,size(state%vector_fields) + if (trim(name)==trim(state%vector_names(i))) then + ! Found the right field - get_state_index=i - if (present(stat)) stat=0 - return + field=>state%vector_fields(i)%ptr + return + end if + end do + end if + ! We didn't find name! + if (present(stat)) then + stat=1 + else + if (associated(state%vector_names)) then + do i=1,size(state%vector_names) + ewrite(-1,*) "i: ", i, " -- ", state%vector_names(i) + end do + end if + FLExit(trim(name)//" is not a field name in this state") end if - end do - !! failed to find - if (present(stat)) then - stat=1 - else - FLExit(name//" is not the name of any of the given states.") - end if - end function get_state_index + end function extract_from_one_vector_field + + function extract_from_one_scalar_field(state, name, stat, allocated) result (field) + !!< Return a pointer to the scalar field with the correct name. + type(scalar_field), pointer :: field + type(scalar_field), pointer :: mem + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + logical, intent(out), optional :: allocated + type(vector_field), pointer :: vfield + + integer :: i, lstat, idx, dim + + if (present(stat)) stat=0 + field => fake_scalar_field + + ! if the allocated flag is present + ! then you can look in the vector and tensor + ! fields for names of the form + ! Velocity%1 + if (present(allocated)) then + allocated = .false. + idx = index(name, "%") + if (idx /= 0) then + read(name(idx+1:len(name)), *) dim + vfield => extract_vector_field(state, name(1:idx-1), lstat) + if (lstat == 0) then + allocate(mem) + allocated = .true. + mem = extract_scalar_field(vfield, dim, lstat) + if (lstat /= 0) then + deallocate(mem) + allocated = .false. + if (present(stat)) then + stat = 1 + else + ewrite(-1,*) "name: ", name + FLExit("Couldn't find vector/tensor component!") + end if + end if + field => mem + return + end if + end if + end if - subroutine print_state(state, unit) - !!< Prints the names of all objects in state - type(state_type), intent(in) :: state - integer, intent(in), optional :: unit - integer :: i, lunit + if (associated(state%scalar_fields)) then + do i=1,size(state%scalar_fields) + if (trim(name)==trim(state%scalar_names(i))) then + ! Found the right field - if (present(unit)) then - lunit=unit - else - lunit=0 - end if + field=>state%scalar_fields(i)%ptr + return + end if + end do + end if - write(lunit,'(a)') "State: "// trim(state%name) + ! We didn't find name! + if (present(stat)) then + stat=1 + else + if (associated(state%scalar_names)) then + do i=1,size(state%scalar_names) + ewrite(-1,*) "i: ", i, " -- ", state%scalar_names(i) + end do + end if + FLExit(trim(name)//" is not a field name in this state") + end if - write(lunit,'(a)') "Meshes: " - if (associated(state%mesh_names)) then - do i=1,size(state%mesh_names) - write(lunit,'(a)') " +" // trim(state%mesh_names(i)) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "Halos: " - if (associated(state%halo_names)) then - do i=1,size(state%halo_names) - write(lunit,'(a)') " +" // trim(state%halo_names(i)) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "Scalar fields: " - if (associated(state%scalar_names)) then - do i=1,size(state%scalar_names) - write(lunit,'(a)') " +" // trim(state%scalar_names(i)) & - // " (" // trim(state%scalar_fields(i)%ptr%name) // ") " & - // " on " // trim(state%scalar_fields(i)%ptr%mesh%name) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "Vector fields: " - if (associated(state%vector_names)) then - do i=1,size(state%vector_names) - write(lunit,'(a)') " +" // trim(state%vector_names(i)) & - // " (" // trim(state%vector_fields(i)%ptr%name) // ") " & - // " on " // trim(state%vector_fields(i)%ptr%mesh%name) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "Tensor fields: " - if (associated(state%tensor_names)) then - do i=1,size(state%tensor_names) - write(lunit,'(a)') " +" // trim(state%tensor_names(i)) & - // " (" // trim(state%tensor_fields(i)%ptr%name) // ") " & - // " on " // trim(state%tensor_fields(i)%ptr%mesh%name) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "CSR sparsities: " - if (associated(state%csr_sparsity_names)) then - do i=1,size(state%csr_sparsity_names) - write(lunit,'(a)') " +" // trim(state%csr_sparsity_names(i)) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "CSR Matrices: " - if (associated(state%csr_matrix_names)) then - do i=1,size(state%csr_matrix_names) - write(lunit,'(a)') " +" // trim(state%csr_matrix_names(i)) - end do - else - write(lunit, '(a)') " none" - end if - - write(lunit,'(a)') "Block CSR Matrices: " - if (associated(state%block_csr_matrix_names)) then - do i=1,size(state%block_csr_matrix_names) - write(lunit,'(a)') " +" // trim(state%block_csr_matrix_names(i)) + end function extract_from_one_scalar_field + + function extract_from_any_scalar_field(state, name, stat, allocated) result (field) + !!< Return a pointer to the scalar field with the correct name. + type(scalar_field), pointer :: field + type(scalar_field), pointer :: mem + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + logical, intent(out), optional :: allocated + type(vector_field), pointer :: vfield + + integer :: i, j, lstat, idx, dim + + if (present(stat)) stat=0 + field => fake_scalar_field + + ! if the allocated flag is present + ! then you can look in the vector and tensor + ! fields for names of the form + ! Velocity%1 + if (present(allocated)) then + allocated = .false. + idx = index(name, "%") + if (idx /= 0) then + read(name(idx+1:len(name)), *) dim + do i = 1, size(state) + vfield => extract_vector_field(state(i), name(1:idx-1), lstat) + if (lstat == 0) then + allocate(mem) + allocated = .true. + mem = extract_scalar_field(vfield, dim, lstat) + if (lstat /= 0) then + deallocate(mem) + allocated = .false. + if (present(stat)) then + stat = 1 + else + ewrite(-1,*) "name: ", name + FLExit("Couldn't find vector/tensor component!") + end if + end if + field => mem + return + end if + end do + end if + end if + + do i = 1, size(state) + if (associated(state(i)%scalar_fields)) then + do j=1,size(state(i)%scalar_fields) + if (trim(name)==trim(state(i)%scalar_names(j))) then + ! Found the right field + + field=>state(i)%scalar_fields(j)%ptr + return + end if + end do + end if end do - else - write(lunit, '(a)') " none" - end if - end subroutine print_state + ! We didn't find name! + if (present(stat)) then + stat=1 + else + do i = 1, size(state) + if (associated(state(i)%scalar_names)) then + do j=1,size(state(i)%scalar_names) + ewrite(-1,*) "i, j: ", i, j, " -- ", state(i)%scalar_names(j) + end do + end if + end do + FLExit(trim(name)//" is not a field name in these states") + end if - subroutine select_state_by_mesh(state, mesh_name, mesh_state) - !!< Returns a state "mesh_state" with only those fields from "state" - !!< that are defined on a mesh "mesh_name" - type(state_type), intent(in):: state - character(len=*), intent(in):: mesh_name - type(state_type), intent(out):: mesh_state + end function extract_from_any_scalar_field - type(scalar_field), pointer:: sfield - type(vector_field), pointer:: vfield - type(tensor_field), pointer:: tfield - type(mesh_type), pointer :: old_mesh + function extract_from_any_vector_field(state, name, stat) result (field) + !!< Return a pointer to the vector field with the correct name. + type(vector_field), pointer :: field + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - integer j + integer :: i, j - call nullify(mesh_state) - old_mesh => extract_mesh(state, trim(mesh_name)) - call insert(mesh_state, old_mesh, trim(mesh_name)) + if (present(stat)) stat=0 + field => fake_vector_field - ! insert scalar fields defined on "mesh_name" - do j=1, scalar_field_count(state) - sfield => extract_scalar_field(state, j) - if (trim(sfield%mesh%name)==trim(mesh_name)) then - call insert(mesh_state, sfield, name=trim(sfield%name)) - end if - end do + do i = 1, size(state) + if (associated(state(i)%vector_fields)) then + do j=1,size(state(i)%vector_fields) + if (trim(name)==trim(state(i)%vector_names(j))) then + ! Found the right field + + field=>state(i)%vector_fields(j)%ptr + return + end if + end do + end if + end do - ! insert vector fields defined on "mesh_name" - do j=1, vector_field_count(state) - vfield => extract_vector_field(state, j) - if (trim(vfield%mesh%name)==trim(mesh_name)) then - call insert(mesh_state, vfield, name=trim(vfield%name)) + ! We didn't find name! + if (present(stat)) then + stat=1 + else + do i = 1, size(state) + if (associated(state(i)%vector_names)) then + do j=1,size(state(i)%vector_names) + ewrite(-1,*) "i, j: ", i, j, " -- ", state(i)%vector_names(j) + end do + end if + end do + FLExit(trim(name)//" is not a field name in these states") end if - end do - ! insert tensor fields defined on "mesh_name" - do j=1, tensor_field_count(state) - tfield => extract_tensor_field(state, j) - if (trim(tfield%mesh%name)==trim(mesh_name)) then - call insert(mesh_state, tfield, name=trim(tfield%name)) - end if - end do + end function extract_from_any_vector_field - end subroutine select_state_by_mesh + function extract_field_mesh(state, name, stat) result(mesh) + !!< Return the mesh for the named field in state - function extract_state(states, name, stat) result (state) - !!< searches a state by name a returns a pointer to it - type(state_type), pointer:: state - type(state_type), dimension(:), intent(in), target:: states - character(len=*), intent(in):: name - integer, optional, intent(out):: stat + type(state_type), intent(in) :: state + character(len = *), intent(in) :: name + integer, optional, intent(out) :: stat - integer i + type(mesh_type), pointer :: mesh - do i=1, size(states) - if (states(i)%name==name) exit - end do + integer :: s_stat, v_stat, t_stat + type(scalar_field), pointer :: s_field + type(tensor_field), pointer :: t_field + type(vector_field), pointer :: v_field - if (i>size(states)) then - if (present(stat)) then - stat=1 - return + if(present(stat)) stat = 0 + + s_field => extract_scalar_field(state, name, s_stat) + v_field => extract_vector_field(state, name, v_stat) + t_field => extract_tensor_field(state, name, t_stat) + + if(count((/s_stat == 0, v_stat == 0, t_stat == 0/)) > 1) then + if(present(stat)) then + stat = 2 + else + FLAbort("Multiple field types found for field " // trim(name)) + end if + else if(s_stat == 0) then + mesh => s_field%mesh + else if(v_stat == 0) then + mesh => v_field%mesh + else if(t_stat == 0) then + mesh => t_field%mesh else - ewrite(-1,*) "Looking for state: "//trim(name) - FLExit("No such state!") - end if - end if - - state => states(i) - if (present(stat)) stat=0 - - end function extract_state - - subroutine collapse_single_state(state, fields) - !!< Sometimes it is useful to treat everything in state - !!< as a big bunch of scalar fields -- adapting and - !!< interpolating spring to mind. Collapse all the fields - !!< in state down to an array of scalar fields. - type(state_type), intent(in) :: state - type(scalar_field), dimension(:), pointer :: fields - integer :: field, i, j, k, field_count - type(vector_field), pointer :: field_v - type(tensor_field), pointer :: field_t - - field_count = scalar_field_count(state) - do field=1,vector_field_count(state) - field_v => extract_vector_field(state, field) - if(trim(field_v%name)=="Coordinate") cycle ! skip Coordinate - field_count = field_count + field_v%dim - end do - - do field=1,tensor_field_count(state) - field_t => extract_tensor_field(state, field) - field_count = field_count + product(field_t%dim) - end do - - allocate(fields(field_count)) - - i = 1 - do field=1,scalar_field_count(state) - fields(i) = extract_scalar_field(state, field) - i = i + 1 - end do - - do field=1,vector_field_count(state) - field_v => extract_vector_field(state, field) - if (trim(field_v%name) /= "Coordinate") then - do j=1,field_v%dim - fields(i) = extract_scalar_field(field_v, j) - i = i + 1 - end do - end if - end do - - do field=1,tensor_field_count(state) - field_t => extract_tensor_field(state, field) - do j=1,field_t%dim(1) - do k=1,field_t%dim(2) - fields(i) = extract_scalar_field(field_t, j, k) - i = i + 1 - end do - end do - end do - end subroutine collapse_single_state - - subroutine collapse_multiple_states(states, fields) - !!< Sometimes it is useful to treat everything in state - !!< as a big bunch of scalar fields -- adapting and - !!< interpolating spring to mind. Collapse all the fields - !!< in state down to an array of scalar fields. - type(state_type), dimension(:), intent(in) :: states - type(scalar_field), dimension(:), pointer :: fields - integer :: field, i, j, k, field_count - type(vector_field), pointer :: field_v - type(tensor_field), pointer :: field_t - integer :: state - - field_count = 0 - do state=1,size(states) - field_count = field_count + scalar_field_count(states(state)) - do field=1,vector_field_count(states(state)) - field_v => extract_vector_field(states(state), field) - if(trim(field_v%name)=="Coordinate") cycle ! skip Coordinate - field_count = field_count + field_v%dim - end do + if(present(stat)) then + stat = 1 + else + FLExit(trim(name) // " is not a field name in this state") + end if + end if - do field=1,tensor_field_count(states(state)) - field_t => extract_tensor_field(states(state), field) - field_count = field_count + product(field_t%dim) - end do - end do + end function extract_field_mesh - allocate(fields(field_count)) + function extract_mesh_from_one(state, name, stat) result (mesh) + !!< Return a pointer to the mesh with the correct name. + type(mesh_type), pointer :: mesh + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - i = 1 - do state=1,size(states) - do field=1,scalar_field_count(states(state)) - fields(i) = extract_scalar_field(states(state), field) - i = i + 1 - end do + integer :: i - do field=1,vector_field_count(states(state)) - field_v => extract_vector_field(states(state), field) - if (trim(field_v%name) /= "Coordinate") then - do j=1,field_v%dim - fields(i) = extract_scalar_field(field_v, j) - i = i + 1 - end do - end if - end do + if (present(stat)) stat=0 + mesh => fake_mesh - do field=1,tensor_field_count(states(state)) - field_t => extract_tensor_field(states(state), field) - do j=1,field_t%dim(1) - do k=1,field_t%dim(2) - fields(i) = extract_scalar_field(field_t, j, k) - i = i + 1 - end do - end do - end do - end do - end subroutine collapse_multiple_states - - subroutine collapse_fields_in_single_state(input_state, output_state) - !!< Sometimes it is useful to treat everything in state - !!< as a big bunch of scalar fields -- adapting and - !!< interpolating spring to mind. Collapse all the fields - !!< in input_state down to scalar fields in output_state. - type(state_type), intent(in) :: input_state - type(state_type), intent(out) :: output_state - - type(state_type), dimension(1) :: linput_state, loutput_state - - linput_state = (/input_state/) - call collapse_fields_in_state(linput_state, loutput_state) - output_state = loutput_state(1) - - end subroutine collapse_fields_in_single_state - - subroutine collapse_fields_in_multiple_states(input_states, output_states) - !!< Sometimes it is useful to treat everything in state - !!< as a big bunch of scalar fields -- adapting and - !!< interpolating spring to mind. Collapse all the fields - !!< in input_states down to scalar fields in output_states. - type(state_type), dimension(:), intent(in) :: input_states - type(state_type), dimension(:), intent(inout) :: output_states - integer :: i, j, k, l - type(scalar_field) :: field_s - type(vector_field), pointer :: field_v - type(tensor_field), pointer :: field_t - - assert(size(input_states)==size(output_states)) - - do l = 1, size(input_states) - do i=1,scalar_field_count(input_states(l)) - field_s = extract_scalar_field(input_states(l), i) - call insert(output_states(l), field_s, trim(input_states(l)%scalar_names(i))) - end do + if (associated(state%meshes)) then + do i=1,size(state%meshes) + if (trim(name)==trim(state%mesh_names(i))) then + ! Found the right field - do i=1,vector_field_count(input_states(l)) - field_v => extract_vector_field(input_states(l), i) - if (trim(field_v%name) /= "Coordinate") then - do j=1,field_v%dim - field_s = extract_scalar_field(field_v, j) - call insert(output_states(l), field_s, & - trim(input_states(l)%vector_names(i))//"%"//int2str(j)) - end do - end if - end do + mesh=>state%meshes(i)%ptr + return + end if + end do + end if - do i=1,tensor_field_count(input_states(l)) - field_t => extract_tensor_field(input_states(l), i) - do j=1,field_t%dim(1) - do k=1,field_t%dim(2) - field_s = extract_scalar_field(field_t, j, k) - call insert(output_states(l), field_s, & - trim(input_states(l)%tensor_names(i))//"%"//int2str((j-1)*field_t%dim(1)+k)) - end do - end do - end do - end do - - end subroutine collapse_fields_in_multiple_states - - function unique_mesh_count(states, seen_ids) result(cnt) - ! Here we are, reimplementing in an extremely complex manner - ! something that can be trivially interrogated from spud. - ! This is stupid. - type(state_type), intent(in), dimension(:) :: states - integer :: cnt - - ! We need to have some way of uniquely identifying meshes, so that - ! we can tell if we've seen this mesh before. - ! Oh! But Wait! Fortran's hash table support is nonexistent. - ! So what the blazes are you going to do? - type(ilist), intent(out), optional :: seen_ids - type(ilist) :: lseen_ids - integer :: state, mesh - type(mesh_type), pointer :: mesh_t - - cnt = 0 - - ! This is quadratic. Do you care? - do state=1,size(states) - do mesh=1,mesh_count(states(state)) - mesh_t => extract_mesh(states(state), mesh) - if (.not. has_value(lseen_ids, mesh_t%refcount%id)) then - cnt = cnt + 1 - call insert(lseen_ids, mesh_t%refcount%id) - end if - end do - end do - - if (present(seen_ids)) then - seen_ids = lseen_ids - else - call deallocate(lseen_ids) - end if - end function unique_mesh_count - - subroutine sort_states_by_mesh(states_in, mesh_states) - type(state_type), intent(in), dimension(:) :: states_in - type(state_type), dimension(:), allocatable, intent(out) :: mesh_states - - type(ilist) :: seen_ids - type(inode), pointer :: current_id - integer :: mesh_count - - integer :: field - integer :: mesh - integer :: state - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - - mesh_count = unique_mesh_count(states_in, seen_ids) - allocate(mesh_states(mesh_count)) - - mesh = 0 - current_id => seen_ids%firstnode - - do while(associated(current_id)) - mesh = mesh + 1 - - do state=1,size(states_in) - do field=1,scalar_field_count(states_in(state)) - sfield => extract_scalar_field(states_in(state), field) - if (sfield%mesh%refcount%id == current_id%value) then - call insert(mesh_states(mesh), sfield, trim(states_in(state)%name) // trim(sfield%name)) - end if - end do - do field=1,vector_field_count(states_in(state)) - vfield => extract_vector_field(states_in(state), field) - if (vfield%mesh%refcount%id == current_id%value) then - call insert(mesh_states(mesh), vfield, trim(states_in(state)%name) // trim(vfield%name)) - end if - end do - do field=1,tensor_field_count(states_in(state)) - tfield => extract_tensor_field(states_in(state), field) - if (tfield%mesh%refcount%id == current_id%value) then - call insert(mesh_states(mesh), tfield, trim(states_in(state)%name) // trim(tfield%name)) - end if - end do + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a mesh name in this state") + end if + + end function extract_mesh_from_one + + function extract_mesh_from_any(state, name, stat) result (mesh) + !!< Return a pointer to the mesh with the correct name. + type(mesh_type), pointer :: mesh + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i, j + + if (present(stat)) stat=0 + mesh => fake_mesh + + do i = 1, size(state) + if (associated(state(i)%meshes)) then + do j=1,size(state(i)%meshes) + if (trim(name)==trim(state(i)%mesh_names(j))) then + ! Found the right field + + mesh=>state(i)%meshes(j)%ptr + return + end if + end do + end if end do - current_id => current_id%next - end do - call deallocate(seen_ids) + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a mesh name in these state") + end if - end subroutine sort_states_by_mesh + end function extract_mesh_from_any - subroutine halo_update_state(state, level, update_aliased, update_positions) - !!< Update the halos of fields in the supplied state. If level is not - !!< supplied, the fields are updated on their largest halo. + function extract_halo(state, name, stat) result (halo) + !!< Return a pointer to the halo with the correct name. + type(halo_type), pointer :: halo + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - type(state_type), intent(inout) :: state - integer, optional, intent(in) :: level - !! If present and false, do *not* update aliased fields - logical, optional, intent(in) :: update_aliased - !! If present and true, *do* update the positions field - logical, optional, intent(in) :: update_positions + integer :: i - integer :: i - type(scalar_field), pointer :: s_field => null() - type(tensor_field), pointer :: t_field => null() - type(vector_field), pointer :: v_field => null() + if (present(stat)) stat=0 + halo => fake_halo - ewrite(2, *) "Updating halos for state " // trim(state%name) + if (associated(state%halos)) then + do i=1,size(state%halos) + if (trim(name)==trim(state%halo_names(i))) then + ! Found the right halo - do i = 1, scalar_field_count(state) - s_field => extract_scalar_field(state, i) - if(s_field%field_type == FIELD_TYPE_NORMAL .and. & - & (.not. present_and_false(update_aliased) .or. & - & .not. aliased(s_field))) then - call halo_update(s_field, level = level) + halo=>state%halos(i)%ptr + return + end if + end do end if - end do - do i = 1, vector_field_count(state) - v_field => extract_vector_field(state, i) - if(index(v_field%name,"Coordinate")==len_trim(v_field%name)-9 & - .and. .not. present_and_true(update_positions)) cycle - if(v_field%field_type == FIELD_TYPE_NORMAL .and. & - & (.not. present_and_false(update_aliased) .or. & - & .not. aliased(v_field))) then - call halo_update(v_field, level = level) + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a halo name in this state") end if - end do - do i = 1, tensor_field_count(state) - t_field => extract_tensor_field(state, i) - if(t_field%field_type == FIELD_TYPE_NORMAL .and. & - & (.not. present_and_false(update_aliased) .or. & - & .not. aliased(t_field))) then - call halo_update(t_field, level = level) - end if - end do + end function extract_halo - end subroutine halo_update_state + function extract_from_one_csr_sparsity(state, name, stat) result (sparsity) + !!< Return a pointer to the sparsity with the correct name. + type(csr_sparsity), pointer :: sparsity + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat - subroutine halo_update_states(states, level, update_aliased, update_positions) - !!< Update the halos of fields in the supplied states. If level is not - !!< supplied, the fields are updated on their largest halo. + integer :: i - type(state_type), dimension(:), intent(inout) :: states - integer, optional, intent(in) :: level - !! If present and true, *do* update aliased fields - logical, optional, intent(in) :: update_aliased - !! If present and true, *do* update the positions field - logical, optional, intent(in) :: update_positions + if (present(stat)) stat=0 + sparsity => fake_csr_sparsity - integer :: i + if (associated(state%csr_sparsities)) then + do i=1,size(state%csr_sparsities) + if (trim(name)==trim(state%csr_sparsity_names(i))) then + ! Found the right field + + sparsity=>state%csr_sparsities(i)%ptr + return + end if + end do + end if - do i = 1, size(states) - call halo_update(states(i), level = level, update_aliased = present_and_true(update_aliased), update_positions = update_positions) - end do + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a sparsity name in this state") + end if + + end function extract_from_one_csr_sparsity + + function extract_from_any_csr_sparsity(state, name, stat) result (sparsity) + !!< Return a pointer to the sparsity with the correct name. + type(csr_sparsity), pointer :: sparsity + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i, j + + if (present(stat)) stat=0 + sparsity => fake_csr_sparsity + + do i = 1, size(state) + if (associated(state(i)%csr_sparsities)) then + do j=1,size(state(i)%csr_sparsities) + if (trim(name)==trim(state(i)%csr_sparsity_names(j))) then + ! Found the right field + + sparsity=>state(i)%csr_sparsities(j)%ptr + return + end if + end do + end if + end do + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a sparsity name in this state") + end if + + end function extract_from_any_csr_sparsity + + function extract_from_one_csr_matrix(state, name, stat) result (matrix) + !!< Return a pointer to the matrix with the correct name. + type(csr_matrix), pointer :: matrix + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i + + if (present(stat)) stat=0 + matrix => fake_csr_matrix + + if (associated(state%csr_matrices)) then + do i=1,size(state%csr_matrices) + if (trim(name)==trim(state%csr_matrix_names(i))) then + ! Found the right field + matrix=>state%csr_matrices(i)%ptr + return + end if + end do + end if + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a matrix name in this state") + end if + + end function extract_from_one_csr_matrix + + function extract_from_any_csr_matrix(state, name, stat) result (matrix) + !!< Return a pointer to the matrix with the correct name. + type(csr_matrix), pointer :: matrix + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i, j + + if (present(stat)) stat=0 + matrix => fake_csr_matrix + + do i = 1, size(state) + if (associated(state(i)%csr_matrices)) then + do j=1,size(state(i)%csr_matrices) + if (trim(name)==trim(state(i)%csr_matrix_names(j))) then + ! Found the right field + matrix=>state(i)%csr_matrices(j)%ptr + return + end if + end do + end if + end do + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a matrix name in these states") + end if + + end function extract_from_any_csr_matrix + + function extract_from_one_block_csr_matrix(state, name, stat) result (matrix) + !!< Return a pointer to the block matrix with the correct name. + type(block_csr_matrix), pointer :: matrix + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i + + if (present(stat)) stat=0 + matrix => fake_block_csr_matrix + + if (associated(state%block_csr_matrices)) then + do i=1,size(state%block_csr_matrices) + if (trim(name)==trim(state%block_csr_matrix_names(i))) then + ! Found the right field + matrix=>state%block_csr_matrices(i)%ptr + return + end if + end do + end if + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a block matrix name in this state") + end if + + end function extract_from_one_block_csr_matrix + + function extract_from_one_petsc_csr_matrix(state, name, stat) result (matrix) + !!< Return a pointer to the block matrix with the correct name. + type(petsc_csr_matrix), pointer :: matrix + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i + + if (present(stat)) stat=0 + matrix => fake_petsc_csr_matrix + + if (associated(state%petsc_csr_matrices)) then + do i=1,size(state%petsc_csr_matrices) + if (trim(name)==trim(state%petsc_csr_matrix_names(i))) then + ! Found the right field + matrix=>state%petsc_csr_matrices(i)%ptr + return + end if + end do + end if + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a petsc matrix name in this state") + end if + + end function extract_from_one_petsc_csr_matrix + + function extract_from_any_block_csr_matrix(state, name, stat) result (matrix) + !!< Return a pointer to the block matrix with the correct name. + type(block_csr_matrix), pointer :: matrix + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i, j + + if (present(stat)) stat=0 + matrix => fake_block_csr_matrix + + do i = 1, size(state) + if (associated(state(i)%block_csr_matrices)) then + do j=1,size(state(i)%block_csr_matrices) + if (trim(name)==trim(state(i)%block_csr_matrix_names(j))) then + ! Found the right field + matrix=>state(i)%block_csr_matrices(j)%ptr + return + end if + end do + end if + end do + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a block matrix name in these states") + end if + + end function extract_from_any_block_csr_matrix + + function extract_from_any_petsc_csr_matrix(state, name, stat) result (matrix) + !!< Return a pointer to the block matrix with the correct name. + type(petsc_csr_matrix), pointer :: matrix + type(state_type), dimension(:), intent(in) :: state + character(len=*), intent(in) :: name + integer, intent(out), optional :: stat + + integer :: i, j + + if (present(stat)) stat=0 + matrix => fake_petsc_csr_matrix + + do i = 1, size(state) + if (associated(state(i)%petsc_csr_matrices)) then + do j=1,size(state(i)%petsc_csr_matrices) + if (trim(name)==trim(state(i)%petsc_csr_matrix_names(j))) then + ! Found the right field + matrix=>state(i)%petsc_csr_matrices(j)%ptr + return + end if + end do + end if + end do + + ! We didn't find name! + if (present(stat)) then + stat=1 + else + FLExit(trim(name)//" is not a petsc matrix name in these states") + end if + + end function extract_from_any_petsc_csr_matrix + + function extract_scalar_field_by_index(state, index) result (field) + !!< Return a pointer to the indexth scalar field in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(scalar_field), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=scalar_field_count(state)) + + field=>state%scalar_fields(index)%ptr + + end function extract_scalar_field_by_index + + function extract_vector_field_by_index(state, index) result (field) + !!< Return a pointer to the indexth vector field in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(vector_field), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=vector_field_count(state)) + + field=>state%vector_fields(index)%ptr + + end function extract_vector_field_by_index + + function extract_tensor_field_by_index(state, index) result (field) + !!< Return a pointer to the indexth tensor field in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(tensor_field), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=tensor_field_count(state)) + + field=>state%tensor_fields(index)%ptr + + end function extract_tensor_field_by_index + + function extract_mesh_by_index(state, index) result (field) + !!< Return a pointer to the indexth mesh in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(mesh_type), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=mesh_count(state)) + + field=>state%meshes(index)%ptr + + end function extract_mesh_by_index + + function extract_halo_by_index(state, index) result (field) + !!< Return a pointer to the indexth halo in state. + !!< This is primarily useful for looping over all the halos in a + !!< state. + type(halo_type), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=halo_count(state)) + + field=>state%halos(index)%ptr + + end function extract_halo_by_index + + function extract_csr_sparsity_by_index(state, index) result (field) + !!< Return a pointer to the indexth csr sparsity in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(csr_sparsity), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=csr_sparsity_count(state)) + + field=>state%csr_sparsities(index)%ptr + + end function extract_csr_sparsity_by_index + + function extract_csr_matrix_by_index(state, index) result (field) + !!< Return a pointer to the indexth csr matrix in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(csr_matrix), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=csr_matrix_count(state)) + + field=>state%csr_matrices(index)%ptr + + end function extract_csr_matrix_by_index + + function extract_block_csr_matrix_by_index(state, index) result (field) + !!< Return a pointer to the indexth block csr matrix in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(block_csr_matrix), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=block_csr_matrix_count(state)) + + field=>state%block_csr_matrices(index)%ptr + + end function extract_block_csr_matrix_by_index + + function extract_petsc_csr_matrix_by_index(state, index) result (field) + !!< Return a pointer to the indexth block csr matrix in state. + !!< This is primarily useful for looping over all the fields in a + !!< state. + type(petsc_csr_matrix), pointer :: field + type(state_type), intent(in) :: state + integer, intent(in) :: index + + assert(index<=petsc_csr_matrix_count(state)) + + field=>state%petsc_csr_matrices(index)%ptr + + end function extract_petsc_csr_matrix_by_index + + function has_scalar_field(state, name) result(present) + !!< Return true if there is a field named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%scalar_names)) then + present=any(trim(name)==state%scalar_names) + else + present=.false. + end if + + end function has_scalar_field + + function has_vector_field(state, name) result(present) + !!< Return true if there is a field named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%vector_names)) then + present=any(trim(name)==state%vector_names) + else + present=.false. + end if + + end function has_vector_field + + function has_tensor_field(state, name) result(present) + !!< Return true if there is a field named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%tensor_names)) then + present=any(trim(name)==state%tensor_names) + else + present=.false. + end if + + end function has_tensor_field + + function has_mesh(state, name) result(present) + !!< Return true if there is a mesh named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%mesh_names)) then + present=any(trim(name)==state%mesh_names) + else + present=.false. + end if + + end function has_mesh + + function state_has_halo(state, name) result(present) + !!< Return true if there is a halo named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%halo_names)) then + present=any(trim(name)==state%halo_names) + else + present=.false. + end if + + end function state_has_halo + + function has_csr_sparsity(state, name) result(present) + !!< Return true if there is a sparsity named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%csr_sparsity_names)) then + present=any(trim(name)==state%csr_sparsity_names) + else + present=.false. + end if + + end function has_csr_sparsity + + function has_csr_matrix(state, name) result(present) + !!< Return true if there is a matrix named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%csr_matrix_names)) then + present=any(trim(name)==state%csr_matrix_names) + else + present=.false. + end if + + end function has_csr_matrix + + function has_block_csr_matrix(state, name) result(present) + !!< Return true if there is a matrix named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%block_csr_matrix_names)) then + present=any(trim(name)==state%block_csr_matrix_names) + else + present=.false. + end if + + end function has_block_csr_matrix + + function has_petsc_csr_matrix(state, name) result(present) + !!< Return true if there is a matrix named name in state. + logical :: present + type(state_type), intent(in) :: state + character(len=*), intent(in) :: name + + if (associated(state%petsc_csr_matrix_names)) then + present=any(trim(name)==state%petsc_csr_matrix_names) + else + present=.false. + end if + + end function has_petsc_csr_matrix + + pure function field_count(state) + integer field_count + type(state_type), intent(in) :: state + + field_count = scalar_field_count(state) + & + vector_field_count(state) + & + tensor_field_count(state) + + end function field_count + + pure function scalar_field_count(state) + !!< Return the number of scalar fields in state. + integer :: scalar_field_count + type(state_type), intent(in) :: state + + if (associated(state%scalar_fields)) then + scalar_field_count=size(state%scalar_fields) + else + scalar_field_count=0 + end if + + end function scalar_field_count + + pure function vector_field_count(state) + !!< Return the number of vector fields in state. + integer :: vector_field_count + type(state_type), intent(in) :: state + + if (associated(state%vector_fields)) then + vector_field_count=size(state%vector_fields) + else + vector_field_count=0 + end if + + end function vector_field_count + + pure function tensor_field_count(state) + !!< Return the number of tensor fields in state. + integer :: tensor_field_count + type(state_type), intent(in) :: state + + if (associated(state%tensor_fields)) then + tensor_field_count=size(state%tensor_fields) + else + tensor_field_count=0 + end if + + end function tensor_field_count + + pure function mesh_count(state) + !!< Return the number of meshes in state. + integer :: mesh_count + type(state_type), intent(in) :: state + + if (associated(state%meshes)) then + mesh_count=size(state%meshes) + else + mesh_count=0 + end if + + end function mesh_count + + pure function halo_count_state(state) result(halo_count) + !!< Return the number of halos in state. + integer :: halo_count + type(state_type), intent(in) :: state + + if (associated(state%halos)) then + halo_count=size(state%halos) + else + halo_count=0 + end if + + end function halo_count_state + + pure function csr_sparsity_count(state) + !!< Return the number of csr_sparsities in state. + integer :: csr_sparsity_count + type(state_type), intent(in) :: state + + if (associated(state%csr_sparsities)) then + csr_sparsity_count=size(state%csr_sparsities) + else + csr_sparsity_count=0 + end if + + end function csr_sparsity_count + + pure function csr_matrix_count(state) + !!< Return the number of csr_matrices in state. + integer :: csr_matrix_count + type(state_type), intent(in) :: state + + if (associated(state%csr_matrices)) then + csr_matrix_count=size(state%csr_matrices) + else + csr_matrix_count=0 + end if + + end function csr_matrix_count + + pure function block_csr_matrix_count(state) + !!< Return the number of csr_matrices in state. + integer :: block_csr_matrix_count + type(state_type), intent(in) :: state + + if (associated(state%block_csr_matrices)) then + block_csr_matrix_count=size(state%block_csr_matrices) + else + block_csr_matrix_count=0 + end if + + end function block_csr_matrix_count + + pure function petsc_csr_matrix_count(state) + !!< Return the number of csr_matrices in state. + integer :: petsc_csr_matrix_count + type(state_type), intent(in) :: state + + if (associated(state%petsc_csr_matrices)) then + petsc_csr_matrix_count=size(state%petsc_csr_matrices) + else + petsc_csr_matrix_count=0 + end if + + end function petsc_csr_matrix_count + + subroutine set_vector_field_in_state(state, to_field_name, from_field_name) + !!< Set the value of to_field to the value of from_field. + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: to_field_name, from_field_name + + type(vector_field), pointer :: to_field, from_field + + to_field=>extract_vector_field(state, to_field_name) + from_field=>extract_vector_field(state, from_field_name) + + call set(to_field, from_field) + + end subroutine set_vector_field_in_state + + integer function get_state_index(states, name, stat) + !!< Auxillary function to search in a set of states by name + type(state_type), dimension(:), intent(in):: states + character(len=*), intent(in):: name + integer, optional, intent(out):: stat + + integer i + + do i=1, size(states) + if (states(i)%name==name) then + + get_state_index=i + if (present(stat)) stat=0 + return + + end if + end do + !! failed to find + if (present(stat)) then + stat=1 + else + FLExit(name//" is not the name of any of the given states.") + end if + + end function get_state_index + + subroutine print_state(state, unit) + !!< Prints the names of all objects in state + type(state_type), intent(in) :: state + integer, intent(in), optional :: unit + integer :: i, lunit + + if (present(unit)) then + lunit=unit + else + lunit=0 + end if + + write(lunit,'(a)') "State: "// trim(state%name) + + write(lunit,'(a)') "Meshes: " + if (associated(state%mesh_names)) then + do i=1,size(state%mesh_names) + write(lunit,'(a)') " +" // trim(state%mesh_names(i)) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "Halos: " + if (associated(state%halo_names)) then + do i=1,size(state%halo_names) + write(lunit,'(a)') " +" // trim(state%halo_names(i)) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "Scalar fields: " + if (associated(state%scalar_names)) then + do i=1,size(state%scalar_names) + write(lunit,'(a)') " +" // trim(state%scalar_names(i)) & + // " (" // trim(state%scalar_fields(i)%ptr%name) // ") " & + // " on " // trim(state%scalar_fields(i)%ptr%mesh%name) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "Vector fields: " + if (associated(state%vector_names)) then + do i=1,size(state%vector_names) + write(lunit,'(a)') " +" // trim(state%vector_names(i)) & + // " (" // trim(state%vector_fields(i)%ptr%name) // ") " & + // " on " // trim(state%vector_fields(i)%ptr%mesh%name) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "Tensor fields: " + if (associated(state%tensor_names)) then + do i=1,size(state%tensor_names) + write(lunit,'(a)') " +" // trim(state%tensor_names(i)) & + // " (" // trim(state%tensor_fields(i)%ptr%name) // ") " & + // " on " // trim(state%tensor_fields(i)%ptr%mesh%name) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "CSR sparsities: " + if (associated(state%csr_sparsity_names)) then + do i=1,size(state%csr_sparsity_names) + write(lunit,'(a)') " +" // trim(state%csr_sparsity_names(i)) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "CSR Matrices: " + if (associated(state%csr_matrix_names)) then + do i=1,size(state%csr_matrix_names) + write(lunit,'(a)') " +" // trim(state%csr_matrix_names(i)) + end do + else + write(lunit, '(a)') " none" + end if + + write(lunit,'(a)') "Block CSR Matrices: " + if (associated(state%block_csr_matrix_names)) then + do i=1,size(state%block_csr_matrix_names) + write(lunit,'(a)') " +" // trim(state%block_csr_matrix_names(i)) + end do + else + write(lunit, '(a)') " none" + end if + + end subroutine print_state + + subroutine select_state_by_mesh(state, mesh_name, mesh_state) + !!< Returns a state "mesh_state" with only those fields from "state" + !!< that are defined on a mesh "mesh_name" + type(state_type), intent(in):: state + character(len=*), intent(in):: mesh_name + type(state_type), intent(out):: mesh_state + + type(scalar_field), pointer:: sfield + type(vector_field), pointer:: vfield + type(tensor_field), pointer:: tfield + type(mesh_type), pointer :: old_mesh + + integer j + + call nullify(mesh_state) + old_mesh => extract_mesh(state, trim(mesh_name)) + call insert(mesh_state, old_mesh, trim(mesh_name)) + + ! insert scalar fields defined on "mesh_name" + do j=1, scalar_field_count(state) + sfield => extract_scalar_field(state, j) + if (trim(sfield%mesh%name)==trim(mesh_name)) then + call insert(mesh_state, sfield, name=trim(sfield%name)) + end if + end do + + ! insert vector fields defined on "mesh_name" + do j=1, vector_field_count(state) + vfield => extract_vector_field(state, j) + if (trim(vfield%mesh%name)==trim(mesh_name)) then + call insert(mesh_state, vfield, name=trim(vfield%name)) + end if + end do + + ! insert tensor fields defined on "mesh_name" + do j=1, tensor_field_count(state) + tfield => extract_tensor_field(state, j) + if (trim(tfield%mesh%name)==trim(mesh_name)) then + call insert(mesh_state, tfield, name=trim(tfield%name)) + end if + end do + + end subroutine select_state_by_mesh + + function extract_state(states, name, stat) result (state) + !!< searches a state by name a returns a pointer to it + type(state_type), pointer:: state + type(state_type), dimension(:), intent(in), target:: states + character(len=*), intent(in):: name + integer, optional, intent(out):: stat + + integer i + + do i=1, size(states) + if (states(i)%name==name) exit + end do + + if (i>size(states)) then + if (present(stat)) then + stat=1 + return + else + ewrite(-1,*) "Looking for state: "//trim(name) + FLExit("No such state!") + end if + end if + + state => states(i) + if (present(stat)) stat=0 + + end function extract_state + + subroutine collapse_single_state(state, fields) + !!< Sometimes it is useful to treat everything in state + !!< as a big bunch of scalar fields -- adapting and + !!< interpolating spring to mind. Collapse all the fields + !!< in state down to an array of scalar fields. + type(state_type), intent(in) :: state + type(scalar_field), dimension(:), pointer :: fields + integer :: field, i, j, k, field_count + type(vector_field), pointer :: field_v + type(tensor_field), pointer :: field_t + + field_count = scalar_field_count(state) + do field=1,vector_field_count(state) + field_v => extract_vector_field(state, field) + if(trim(field_v%name)=="Coordinate") cycle ! skip Coordinate + field_count = field_count + field_v%dim + end do + + do field=1,tensor_field_count(state) + field_t => extract_tensor_field(state, field) + field_count = field_count + product(field_t%dim) + end do + + allocate(fields(field_count)) + + i = 1 + do field=1,scalar_field_count(state) + fields(i) = extract_scalar_field(state, field) + i = i + 1 + end do + + do field=1,vector_field_count(state) + field_v => extract_vector_field(state, field) + if (trim(field_v%name) /= "Coordinate") then + do j=1,field_v%dim + fields(i) = extract_scalar_field(field_v, j) + i = i + 1 + end do + end if + end do + + do field=1,tensor_field_count(state) + field_t => extract_tensor_field(state, field) + do j=1,field_t%dim(1) + do k=1,field_t%dim(2) + fields(i) = extract_scalar_field(field_t, j, k) + i = i + 1 + end do + end do + end do + end subroutine collapse_single_state + + subroutine collapse_multiple_states(states, fields) + !!< Sometimes it is useful to treat everything in state + !!< as a big bunch of scalar fields -- adapting and + !!< interpolating spring to mind. Collapse all the fields + !!< in state down to an array of scalar fields. + type(state_type), dimension(:), intent(in) :: states + type(scalar_field), dimension(:), pointer :: fields + integer :: field, i, j, k, field_count + type(vector_field), pointer :: field_v + type(tensor_field), pointer :: field_t + integer :: state + + field_count = 0 + do state=1,size(states) + field_count = field_count + scalar_field_count(states(state)) + do field=1,vector_field_count(states(state)) + field_v => extract_vector_field(states(state), field) + if(trim(field_v%name)=="Coordinate") cycle ! skip Coordinate + field_count = field_count + field_v%dim + end do + + do field=1,tensor_field_count(states(state)) + field_t => extract_tensor_field(states(state), field) + field_count = field_count + product(field_t%dim) + end do + end do + + allocate(fields(field_count)) + + i = 1 + do state=1,size(states) + do field=1,scalar_field_count(states(state)) + fields(i) = extract_scalar_field(states(state), field) + i = i + 1 + end do + + do field=1,vector_field_count(states(state)) + field_v => extract_vector_field(states(state), field) + if (trim(field_v%name) /= "Coordinate") then + do j=1,field_v%dim + fields(i) = extract_scalar_field(field_v, j) + i = i + 1 + end do + end if + end do + + do field=1,tensor_field_count(states(state)) + field_t => extract_tensor_field(states(state), field) + do j=1,field_t%dim(1) + do k=1,field_t%dim(2) + fields(i) = extract_scalar_field(field_t, j, k) + i = i + 1 + end do + end do + end do + end do + end subroutine collapse_multiple_states + + subroutine collapse_fields_in_single_state(input_state, output_state) + !!< Sometimes it is useful to treat everything in state + !!< as a big bunch of scalar fields -- adapting and + !!< interpolating spring to mind. Collapse all the fields + !!< in input_state down to scalar fields in output_state. + type(state_type), intent(in) :: input_state + type(state_type), intent(out) :: output_state + + type(state_type), dimension(1) :: linput_state, loutput_state + + linput_state = (/input_state/) + call collapse_fields_in_state(linput_state, loutput_state) + output_state = loutput_state(1) + + end subroutine collapse_fields_in_single_state + + subroutine collapse_fields_in_multiple_states(input_states, output_states) + !!< Sometimes it is useful to treat everything in state + !!< as a big bunch of scalar fields -- adapting and + !!< interpolating spring to mind. Collapse all the fields + !!< in input_states down to scalar fields in output_states. + type(state_type), dimension(:), intent(in) :: input_states + type(state_type), dimension(:), intent(inout) :: output_states + integer :: i, j, k, l + type(scalar_field) :: field_s + type(vector_field), pointer :: field_v + type(tensor_field), pointer :: field_t + + assert(size(input_states)==size(output_states)) + + do l = 1, size(input_states) + do i=1,scalar_field_count(input_states(l)) + field_s = extract_scalar_field(input_states(l), i) + call insert(output_states(l), field_s, trim(input_states(l)%scalar_names(i))) + end do + + do i=1,vector_field_count(input_states(l)) + field_v => extract_vector_field(input_states(l), i) + if (trim(field_v%name) /= "Coordinate") then + do j=1,field_v%dim + field_s = extract_scalar_field(field_v, j) + call insert(output_states(l), field_s, & + trim(input_states(l)%vector_names(i))//"%"//int2str(j)) + end do + end if + end do + + do i=1,tensor_field_count(input_states(l)) + field_t => extract_tensor_field(input_states(l), i) + do j=1,field_t%dim(1) + do k=1,field_t%dim(2) + field_s = extract_scalar_field(field_t, j, k) + call insert(output_states(l), field_s, & + trim(input_states(l)%tensor_names(i))//"%"//int2str((j-1)*field_t%dim(1)+k)) + end do + end do + end do + end do + + end subroutine collapse_fields_in_multiple_states + + function unique_mesh_count(states, seen_ids) result(cnt) + ! Here we are, reimplementing in an extremely complex manner + ! something that can be trivially interrogated from spud. + ! This is stupid. + type(state_type), intent(in), dimension(:) :: states + integer :: cnt + + ! We need to have some way of uniquely identifying meshes, so that + ! we can tell if we've seen this mesh before. + ! Oh! But Wait! Fortran's hash table support is nonexistent. + ! So what the blazes are you going to do? + type(ilist), intent(out), optional :: seen_ids + type(ilist) :: lseen_ids + integer :: state, mesh + type(mesh_type), pointer :: mesh_t + + cnt = 0 + + ! This is quadratic. Do you care? + do state=1,size(states) + do mesh=1,mesh_count(states(state)) + mesh_t => extract_mesh(states(state), mesh) + if (.not. has_value(lseen_ids, mesh_t%refcount%id)) then + cnt = cnt + 1 + call insert(lseen_ids, mesh_t%refcount%id) + end if + end do + end do + + if (present(seen_ids)) then + seen_ids = lseen_ids + else + call deallocate(lseen_ids) + end if + end function unique_mesh_count + + subroutine sort_states_by_mesh(states_in, mesh_states) + type(state_type), intent(in), dimension(:) :: states_in + type(state_type), dimension(:), allocatable, intent(out) :: mesh_states + + type(ilist) :: seen_ids + type(inode), pointer :: current_id + integer :: mesh_count + + integer :: field + integer :: mesh + integer :: state + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + + mesh_count = unique_mesh_count(states_in, seen_ids) + allocate(mesh_states(mesh_count)) + + mesh = 0 + current_id => seen_ids%firstnode + + do while(associated(current_id)) + mesh = mesh + 1 + + do state=1,size(states_in) + do field=1,scalar_field_count(states_in(state)) + sfield => extract_scalar_field(states_in(state), field) + if (sfield%mesh%refcount%id == current_id%value) then + call insert(mesh_states(mesh), sfield, trim(states_in(state)%name) // trim(sfield%name)) + end if + end do + do field=1,vector_field_count(states_in(state)) + vfield => extract_vector_field(states_in(state), field) + if (vfield%mesh%refcount%id == current_id%value) then + call insert(mesh_states(mesh), vfield, trim(states_in(state)%name) // trim(vfield%name)) + end if + end do + do field=1,tensor_field_count(states_in(state)) + tfield => extract_tensor_field(states_in(state), field) + if (tfield%mesh%refcount%id == current_id%value) then + call insert(mesh_states(mesh), tfield, trim(states_in(state)%name) // trim(tfield%name)) + end if + end do + end do + + current_id => current_id%next + end do + call deallocate(seen_ids) + + end subroutine sort_states_by_mesh + + subroutine halo_update_state(state, level, update_aliased, update_positions) + !!< Update the halos of fields in the supplied state. If level is not + !!< supplied, the fields are updated on their largest halo. + + type(state_type), intent(inout) :: state + integer, optional, intent(in) :: level + !! If present and false, do *not* update aliased fields + logical, optional, intent(in) :: update_aliased + !! If present and true, *do* update the positions field + logical, optional, intent(in) :: update_positions + + integer :: i + type(scalar_field), pointer :: s_field => null() + type(tensor_field), pointer :: t_field => null() + type(vector_field), pointer :: v_field => null() + + ewrite(2, *) "Updating halos for state " // trim(state%name) + + do i = 1, scalar_field_count(state) + s_field => extract_scalar_field(state, i) + if(s_field%field_type == FIELD_TYPE_NORMAL .and. & + & (.not. present_and_false(update_aliased) .or. & + & .not. aliased(s_field))) then + call halo_update(s_field, level = level) + end if + end do + + do i = 1, vector_field_count(state) + v_field => extract_vector_field(state, i) + if(index(v_field%name,"Coordinate")==len_trim(v_field%name)-9 & + .and. .not. present_and_true(update_positions)) cycle + if(v_field%field_type == FIELD_TYPE_NORMAL .and. & + & (.not. present_and_false(update_aliased) .or. & + & .not. aliased(v_field))) then + call halo_update(v_field, level = level) + end if + end do + + do i = 1, tensor_field_count(state) + t_field => extract_tensor_field(state, i) + if(t_field%field_type == FIELD_TYPE_NORMAL .and. & + & (.not. present_and_false(update_aliased) .or. & + & .not. aliased(t_field))) then + call halo_update(t_field, level = level) + end if + end do + + end subroutine halo_update_state + + subroutine halo_update_states(states, level, update_aliased, update_positions) + !!< Update the halos of fields in the supplied states. If level is not + !!< supplied, the fields are updated on their largest halo. + + type(state_type), dimension(:), intent(inout) :: states + integer, optional, intent(in) :: level + !! If present and true, *do* update aliased fields + logical, optional, intent(in) :: update_aliased + !! If present and true, *do* update the positions field + logical, optional, intent(in) :: update_positions + + integer :: i + + do i = 1, size(states) + call halo_update(states(i), level = level, update_aliased = present_and_true(update_aliased), update_positions = update_positions) + end do - end subroutine halo_update_states + end subroutine halo_update_states - pure function aliased_scalar(field) result(aliased) - !!< Checks whether a field is aliased - !! field to be checked - type(scalar_field), intent(in) :: field - logical :: aliased + pure function aliased_scalar(field) result(aliased) + !!< Checks whether a field is aliased + !! field to be checked + type(scalar_field), intent(in) :: field + logical :: aliased - aliased=field%aliased + aliased=field%aliased - end function aliased_scalar + end function aliased_scalar - pure function aliased_vector(field) result(aliased) - !!< Checks whether a field is aliased - !! field to be checked - type(vector_field), intent(in) :: field - logical :: aliased + pure function aliased_vector(field) result(aliased) + !!< Checks whether a field is aliased + !! field to be checked + type(vector_field), intent(in) :: field + logical :: aliased - aliased=field%aliased + aliased=field%aliased - end function aliased_vector + end function aliased_vector - pure function aliased_tensor(field) result(aliased) - !!< Checks whether a field is aliased - !! field to be checked - type(tensor_field), intent(in) :: field - logical :: aliased + pure function aliased_tensor(field) result(aliased) + !!< Checks whether a field is aliased + !! field to be checked + type(tensor_field), intent(in) :: field + logical :: aliased - aliased=field%aliased + aliased=field%aliased - end function aliased_tensor + end function aliased_tensor end module state_module diff --git a/femtools/State_Fields.F90 b/femtools/State_Fields.F90 index ee2fd1327c..230a943907 100644 --- a/femtools/State_Fields.F90 +++ b/femtools/State_Fields.F90 @@ -26,262 +26,262 @@ ! USA #include "fdebug.h" module state_fields_module - !!< Module containing general tools for discretising Finite Element problems. + !!< Module containing general tools for discretising Finite Element problems. - use global_parameters, only: FIELD_NAME_LEN - use sparse_tools - use eventcounter - use fields - use state_module - use fefields - use sparsity_patterns_meshes - use dgtools, only: get_dg_inverse_mass_matrix - implicit none + use global_parameters, only: FIELD_NAME_LEN + use sparse_tools + use eventcounter + use fields + use state_module + use fefields + use sparsity_patterns_meshes + use dgtools, only: get_dg_inverse_mass_matrix + implicit none - interface get_cv_mass - module procedure get_cv_mass_single_state, get_cv_mass_multiple_states - end interface get_cv_mass + interface get_cv_mass + module procedure get_cv_mass_single_state, get_cv_mass_multiple_states + end interface get_cv_mass - interface get_lumped_mass - module procedure get_lumped_mass_single_state, get_lumped_mass_multiple_states - end interface get_lumped_mass + interface get_lumped_mass + module procedure get_lumped_mass_single_state, get_lumped_mass_multiple_states + end interface get_lumped_mass - interface get_mass_matrix - module procedure get_mass_matrix_single_state, get_mass_matrix_multiple_states - end interface get_mass_matrix + interface get_mass_matrix + module procedure get_mass_matrix_single_state, get_mass_matrix_multiple_states + end interface get_mass_matrix - interface get_dg_inverse_mass - module procedure get_dg_inverse_mass_single_state, get_dg_inverse_mass_multiple_states - end interface get_dg_inverse_mass + interface get_dg_inverse_mass + module procedure get_dg_inverse_mass_single_state, get_dg_inverse_mass_multiple_states + end interface get_dg_inverse_mass - interface get_lumped_mass_on_submesh - module procedure get_lumped_mass_on_submesh_single_state, get_lumped_mass_on_submesh_multiple_states - end interface get_lumped_mass_on_submesh + interface get_lumped_mass_on_submesh + module procedure get_lumped_mass_on_submesh_single_state, get_lumped_mass_on_submesh_multiple_states + end interface get_lumped_mass_on_submesh - private - public :: get_cv_mass, get_lumped_mass, get_lumped_mass_on_submesh, get_mass_matrix, get_dg_inverse_mass + private + public :: get_cv_mass, get_lumped_mass, get_lumped_mass_on_submesh, get_mass_matrix, get_dg_inverse_mass contains - function get_cv_mass_single_state(state, mesh) result(cv_mass) - !!< extracts the cv mass from states or creates it if it doesn't find it - type(scalar_field), pointer :: cv_mass - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh + function get_cv_mass_single_state(state, mesh) result(cv_mass) + !!< extracts the cv mass from states or creates it if it doesn't find it + type(scalar_field), pointer :: cv_mass + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - cv_mass => get_cv_mass(states, mesh) - state = states(1) + states = (/state/) + cv_mass => get_cv_mass(states, mesh) + state = states(1) - end function get_cv_mass_single_state + end function get_cv_mass_single_state - function get_cv_mass_multiple_states(states, mesh) result(cv_mass) - !!< extracts the cv mass from states or creates it if it doesn't find it - type(scalar_field), pointer :: cv_mass - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: mesh + function get_cv_mass_multiple_states(states, mesh) result(cv_mass) + !!< extracts the cv mass from states or creates it if it doesn't find it + type(scalar_field), pointer :: cv_mass + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: mesh - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(scalar_field) :: temp_cv_mass - type(vector_field), pointer :: positions - integer, save :: last_mesh_movement = -1 + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(scalar_field) :: temp_cv_mass + type(vector_field), pointer :: positions + integer, save :: last_mesh_movement = -1 - name = trim(mesh%name)//"CVMass" + name = trim(mesh%name)//"CVMass" - cv_mass => extract_scalar_field(states, trim(name), stat) + cv_mass => extract_scalar_field(states, trim(name), stat) - if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then + if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then - positions => extract_vector_field(states(1), "Coordinate") - call allocate(temp_cv_mass, mesh, name=trim(name)) - call compute_cv_mass(positions, temp_cv_mass) - call insert(states, temp_cv_mass, trim(name)) - call deallocate(temp_cv_mass) + positions => extract_vector_field(states(1), "Coordinate") + call allocate(temp_cv_mass, mesh, name=trim(name)) + call compute_cv_mass(positions, temp_cv_mass) + call insert(states, temp_cv_mass, trim(name)) + call deallocate(temp_cv_mass) - cv_mass => extract_scalar_field(states, trim(name)) - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end if + cv_mass => extract_scalar_field(states, trim(name)) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end if - end function get_cv_mass_multiple_states + end function get_cv_mass_multiple_states - function get_lumped_mass_single_state(state, mesh) result(lumped_mass) - !!< extracts the lumped mass from states or creates it if it doesn't find it - type(scalar_field), pointer :: lumped_mass - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh + function get_lumped_mass_single_state(state, mesh) result(lumped_mass) + !!< extracts the lumped mass from states or creates it if it doesn't find it + type(scalar_field), pointer :: lumped_mass + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - lumped_mass => get_lumped_mass(states, mesh) - state = states(1) + states = (/state/) + lumped_mass => get_lumped_mass(states, mesh) + state = states(1) - end function get_lumped_mass_single_state + end function get_lumped_mass_single_state - function get_lumped_mass_multiple_states(states, mesh) result(lumped_mass) - !!< extracts the lumped mass from states or creates it if it doesn't find it - type(scalar_field), pointer :: lumped_mass - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: mesh + function get_lumped_mass_multiple_states(states, mesh) result(lumped_mass) + !!< extracts the lumped mass from states or creates it if it doesn't find it + type(scalar_field), pointer :: lumped_mass + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: mesh - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(scalar_field) :: temp_lumped_mass - type(vector_field), pointer :: positions - integer, save :: last_mesh_movement = -1 + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(scalar_field) :: temp_lumped_mass + type(vector_field), pointer :: positions + integer, save :: last_mesh_movement = -1 - name = trim(mesh%name)//"LumpedMass" + name = trim(mesh%name)//"LumpedMass" - lumped_mass => extract_scalar_field(states, trim(name), stat) + lumped_mass => extract_scalar_field(states, trim(name), stat) - if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then + if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then - positions => extract_vector_field(states(1), "Coordinate") - call allocate(temp_lumped_mass, mesh, name=trim(name)) - call compute_lumped_mass(positions, temp_lumped_mass) - call insert(states, temp_lumped_mass, trim(name)) - call deallocate(temp_lumped_mass) + positions => extract_vector_field(states(1), "Coordinate") + call allocate(temp_lumped_mass, mesh, name=trim(name)) + call compute_lumped_mass(positions, temp_lumped_mass) + call insert(states, temp_lumped_mass, trim(name)) + call deallocate(temp_lumped_mass) - lumped_mass => extract_scalar_field(states, trim(name)) - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end if + lumped_mass => extract_scalar_field(states, trim(name)) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end if - end function get_lumped_mass_multiple_states + end function get_lumped_mass_multiple_states - function get_mass_matrix_single_state(state, mesh) result(mass) - !!< extracts the mass from states or creates it if it doesn't find it - type(csr_matrix), pointer :: mass - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh + function get_mass_matrix_single_state(state, mesh) result(mass) + !!< extracts the mass from states or creates it if it doesn't find it + type(csr_matrix), pointer :: mass + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - mass => get_mass_matrix(states, mesh) - state = states(1) + states = (/state/) + mass => get_mass_matrix(states, mesh) + state = states(1) - end function get_mass_matrix_single_state + end function get_mass_matrix_single_state - function get_mass_matrix_multiple_states(states, mesh) result(mass) - !!< extracts the mass from states or creates it if it doesn't find it - type(csr_matrix), pointer :: mass - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: mesh + function get_mass_matrix_multiple_states(states, mesh) result(mass) + !!< extracts the mass from states or creates it if it doesn't find it + type(csr_matrix), pointer :: mass + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: mesh - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(csr_matrix) :: temp_mass - type(csr_sparsity), pointer :: temp_mass_sparsity - type(vector_field), pointer :: positions + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(csr_matrix) :: temp_mass + type(csr_sparsity), pointer :: temp_mass_sparsity + type(vector_field), pointer :: positions - integer, save :: last_mesh_movement = -1 + integer, save :: last_mesh_movement = -1 - name = trim(mesh%name)//"MassMatrix" + name = trim(mesh%name)//"MassMatrix" - mass => extract_csr_matrix(states, trim(name), stat) + mass => extract_csr_matrix(states, trim(name), stat) - if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then - positions => extract_vector_field(states(1), "Coordinate") + if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then + positions => extract_vector_field(states(1), "Coordinate") - temp_mass_sparsity => get_csr_sparsity_firstorder(states, mesh, mesh) - call allocate(temp_mass, temp_mass_sparsity, name=trim(name)) - call compute_mass(positions, mesh, temp_mass) - call insert(states, temp_mass, trim(name)) - call deallocate(temp_mass) + temp_mass_sparsity => get_csr_sparsity_firstorder(states, mesh, mesh) + call allocate(temp_mass, temp_mass_sparsity, name=trim(name)) + call compute_mass(positions, mesh, temp_mass) + call insert(states, temp_mass, trim(name)) + call deallocate(temp_mass) - mass => extract_csr_matrix(states, trim(name)) - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end if + mass => extract_csr_matrix(states, trim(name)) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end if - end function get_mass_matrix_multiple_states + end function get_mass_matrix_multiple_states - function get_dg_inverse_mass_single_state(state, mesh) result(inverse_mass) - !!< extracts the dg inverse mass from state or creates it if it doesn't find it - type(csr_matrix), pointer :: inverse_mass - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh + function get_dg_inverse_mass_single_state(state, mesh) result(inverse_mass) + !!< extracts the dg inverse mass from state or creates it if it doesn't find it + type(csr_matrix), pointer :: inverse_mass + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - inverse_mass => get_dg_inverse_mass(states, mesh) - state = states(1) + states = (/state/) + inverse_mass => get_dg_inverse_mass(states, mesh) + state = states(1) - end function get_dg_inverse_mass_single_state + end function get_dg_inverse_mass_single_state - function get_dg_inverse_mass_multiple_states(states, mesh) result(inverse_mass) - !!< extracts the dg inverse mass from states or creates it if it doesn't find it - type(csr_matrix), pointer :: inverse_mass - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: mesh + function get_dg_inverse_mass_multiple_states(states, mesh) result(inverse_mass) + !!< extracts the dg inverse mass from states or creates it if it doesn't find it + type(csr_matrix), pointer :: inverse_mass + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: mesh - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(csr_matrix) :: temp_inverse_mass - type(vector_field), pointer :: positions + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(csr_matrix) :: temp_inverse_mass + type(vector_field), pointer :: positions - integer, save :: last_mesh_movement = -1 + integer, save :: last_mesh_movement = -1 - name = trim(mesh%name)//"DGInverseMassMatrix" + name = trim(mesh%name)//"DGInverseMassMatrix" - inverse_mass => extract_csr_matrix(states, trim(name), stat) + inverse_mass => extract_csr_matrix(states, trim(name), stat) - if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then - positions => extract_vector_field(states(1), "Coordinate") + if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then + positions => extract_vector_field(states(1), "Coordinate") - call get_dg_inverse_mass_matrix(temp_inverse_mass, mesh, positions) - call insert(states, temp_inverse_mass, trim(name)) - call deallocate(temp_inverse_mass) + call get_dg_inverse_mass_matrix(temp_inverse_mass, mesh, positions) + call insert(states, temp_inverse_mass, trim(name)) + call deallocate(temp_inverse_mass) - inverse_mass => extract_csr_matrix(states, trim(name)) - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end if + inverse_mass => extract_csr_matrix(states, trim(name)) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end if - end function get_dg_inverse_mass_multiple_states + end function get_dg_inverse_mass_multiple_states - function get_lumped_mass_on_submesh_single_state(state, mesh) result(lumped_mass) - !!< extracts the lumped mass from states or creates it if it doesn't find it - type(scalar_field), pointer :: lumped_mass - type(state_type), intent(inout) :: state - type(mesh_type), intent(inout) :: mesh + function get_lumped_mass_on_submesh_single_state(state, mesh) result(lumped_mass) + !!< extracts the lumped mass from states or creates it if it doesn't find it + type(scalar_field), pointer :: lumped_mass + type(state_type), intent(inout) :: state + type(mesh_type), intent(inout) :: mesh - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states = (/state/) - lumped_mass => get_lumped_mass_on_submesh(states, mesh) - state = states(1) + states = (/state/) + lumped_mass => get_lumped_mass_on_submesh(states, mesh) + state = states(1) - end function get_lumped_mass_on_submesh_single_state + end function get_lumped_mass_on_submesh_single_state - function get_lumped_mass_on_submesh_multiple_states(states, mesh) result(lumped_mass) - !!< extracts the lumped mass from states or creates it if it doesn't find it - type(scalar_field), pointer :: lumped_mass - type(state_type), dimension(:), intent(inout) :: states - type(mesh_type), intent(inout) :: mesh + function get_lumped_mass_on_submesh_multiple_states(states, mesh) result(lumped_mass) + !!< extracts the lumped mass from states or creates it if it doesn't find it + type(scalar_field), pointer :: lumped_mass + type(state_type), dimension(:), intent(inout) :: states + type(mesh_type), intent(inout) :: mesh - integer :: stat - character(len=FIELD_NAME_LEN) :: name - type(scalar_field) :: temp_lumped_mass + integer :: stat + character(len=FIELD_NAME_LEN) :: name + type(scalar_field) :: temp_lumped_mass - integer, save :: last_mesh_movement = -1 + integer, save :: last_mesh_movement = -1 - name = trim(mesh%name)//"SubMeshLumpedMass" + name = trim(mesh%name)//"SubMeshLumpedMass" - lumped_mass => extract_scalar_field(states, trim(name), stat) + lumped_mass => extract_scalar_field(states, trim(name), stat) - if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then - call allocate(temp_lumped_mass, mesh, name=trim(name)) - call compute_lumped_mass_on_submesh(states(1), temp_lumped_mass) - call insert(states, temp_lumped_mass, trim(name)) - call deallocate(temp_lumped_mass) + if((stat/=0).or.(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement)) then + call allocate(temp_lumped_mass, mesh, name=trim(name)) + call compute_lumped_mass_on_submesh(states(1), temp_lumped_mass) + call insert(states, temp_lumped_mass, trim(name)) + call deallocate(temp_lumped_mass) - lumped_mass => extract_scalar_field(states, trim(name)) - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - end if + lumped_mass => extract_scalar_field(states, trim(name)) + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end if - end function get_lumped_mass_on_submesh_multiple_states + end function get_lumped_mass_on_submesh_multiple_states end module state_fields_module diff --git a/femtools/Streamfunction.F90 b/femtools/Streamfunction.F90 index c820c8b1d6..af79440c9a 100644 --- a/femtools/Streamfunction.F90 +++ b/femtools/Streamfunction.F90 @@ -28,337 +28,337 @@ #include "fdebug.h" module streamfunction - use spud - use fldebug - use global_parameters, only: OPTION_PATH_LEN - use futils, only: present_and_nonzero, nullify - use parallel_tools - use sparse_tools - use vector_tools - use eventcounter - use elements - use transform_elements - use linked_lists - use parallel_fields - use fetools, only: dshape_dot_dshape, shape_curl_shape_2d - use fields - use state_module - use sparsity_patterns - use solvers - use boundary_conditions - use sparsity_patterns_meshes - - implicit none - - private - public :: calculate_stream_function_multipath_2d - - type(integer_vector), dimension(:), allocatable, save :: flux_face_list - real, dimension(:,:), allocatable, save :: flux_normal - - integer, save :: last_adapt=-1 + use spud + use fldebug + use global_parameters, only: OPTION_PATH_LEN + use futils, only: present_and_nonzero, nullify + use parallel_tools + use sparse_tools + use vector_tools + use eventcounter + use elements + use transform_elements + use linked_lists + use parallel_fields + use fetools, only: dshape_dot_dshape, shape_curl_shape_2d + use fields + use state_module + use sparsity_patterns + use solvers + use boundary_conditions + use sparsity_patterns_meshes + + implicit none + + private + public :: calculate_stream_function_multipath_2d + + type(integer_vector), dimension(:), allocatable, save :: flux_face_list + real, dimension(:,:), allocatable, save :: flux_normal + + integer, save :: last_adapt=-1 contains - subroutine find_stream_paths(X, streamfunc) - !!< Find the paths through the mesh over which the velocity will be - !!< integrated to calculate the flux. - type(vector_field), intent(in) :: X - type(scalar_field), intent(inout) :: streamfunc + subroutine find_stream_paths(X, streamfunc) + !!< Find the paths through the mesh over which the velocity will be + !!< integrated to calculate the flux. + type(vector_field), intent(in) :: X + type(scalar_field), intent(inout) :: streamfunc - type(ilist) :: tmp_face_list + type(ilist) :: tmp_face_list - integer :: bc_count - character(len=OPTION_PATH_LEN) :: option_path - real, dimension(2) :: start, end, dx, face_c + integer :: bc_count + character(len=OPTION_PATH_LEN) :: option_path + real, dimension(2) :: start, end, dx, face_c - integer, dimension(:), pointer :: neigh - integer :: face, p, ele1, ele2, e2, i - real :: dx2, c1, c2 + integer, dimension(:), pointer :: neigh + integer :: face, p, ele1, ele2, e2, i + real :: dx2, c1, c2 - bc_count=get_boundary_condition_count(streamfunc) + bc_count=get_boundary_condition_count(streamfunc) - if(.not.(allocated(flux_face_list))) then - allocate(flux_face_list(bc_count)) - CALL nullify(flux_face_list) - allocate(flux_normal(2, bc_count)) - end if + if(.not.(allocated(flux_face_list))) then + allocate(flux_face_list(bc_count)) + CALL nullify(flux_face_list) + allocate(flux_normal(2, bc_count)) + end if - bc_loop: do i=1, bc_count - call get_boundary_condition(streamfunc, i, option_path=option_path) + bc_loop: do i=1, bc_count + call get_boundary_condition(streamfunc, i, option_path=option_path) - if (have_option(trim(option_path)//"/primary_boundary")) then - ! No path on the primary boundary. + if (have_option(trim(option_path)//"/primary_boundary")) then + ! No path on the primary boundary. - if (associated(flux_face_list(i)%ptr)) then - deallocate(flux_face_list(i)%ptr) - end if - allocate(flux_face_list(i)%ptr(0)) + if (associated(flux_face_list(i)%ptr)) then + deallocate(flux_face_list(i)%ptr) + end if + allocate(flux_face_list(i)%ptr(0)) - cycle bc_loop - end if + cycle bc_loop + end if - ! We must be on a secondary boundary. - call get_option(trim(option_path)//"/secondary_boundary/primary_point"& - &, start) - call get_option(trim(option_path)//"/secondary_boundary/secondary_point"& - &, end) + ! We must be on a secondary boundary. + call get_option(trim(option_path)//"/secondary_boundary/primary_point"& + &, start) + call get_option(trim(option_path)//"/secondary_boundary/secondary_point"& + &, end) - dx=-abs(start-end) + dx=-abs(start-end) - dx2=dot_product(dx,dx) + dx2=dot_product(dx,dx) - do ele1=1, element_count(streamfunc) - neigh=>ele_neigh(X, ele1) + do ele1=1, element_count(streamfunc) + neigh=>ele_neigh(X, ele1) - do e2=1,size(neigh) - ele2=neigh(e2) - ! Don't do boundaries - if (ele2<=0) cycle - ! Do each edge only once - if (ele1>ele2) cycle + do e2=1,size(neigh) + ele2=neigh(e2) + ! Don't do boundaries + if (ele2<=0) cycle + ! Do each edge only once + if (ele1>ele2) cycle - !for parallel check that we own the node - if (.not.element_owned(streamfunc, ele1)) cycle + !for parallel check that we own the node + if (.not.element_owned(streamfunc, ele1)) cycle - face=ele_face(streamfunc, ele1, ele2) + face=ele_face(streamfunc, ele1, ele2) - face_c=sum(face_val(X,face),2)/face_loc(X,face) + face_c=sum(face_val(X,face),2)/face_loc(X,face) - p=dot_product(face_c,dx)/dx2 + p=dot_product(face_c,dx)/dx2 - ! If the face is not within the limits of the line, don't do it. - if (p<0.or.p>1) cycle + ! If the face is not within the limits of the line, don't do it. + if (p<0.or.p>1) cycle - c1=cross_product2(sum(ele_val(X,ele1),2)/ele_loc(X,ele1)-start, dx) - c2=cross_product2(sum(ele_val(X,ele2),2)/ele_loc(X,ele2)-start, dx) + c1=cross_product2(sum(ele_val(X,ele1),2)/ele_loc(X,ele1)-start, dx) + c2=cross_product2(sum(ele_val(X,ele2),2)/ele_loc(X,ele2)-start, dx) - if(C1<0 .and. C2>=0) then - continue - else if (C1>=0 .and. C2<0) then - continue - else - cycle - end if + if(C1<0 .and. C2>=0) then + continue + else if (C1>=0 .and. C2<0) then + continue + else + cycle + end if - call insert(tmp_face_list, face) + call insert(tmp_face_list, face) - end do + end do - end do + end do - if (associated(flux_face_list(i)%ptr)) then - deallocate(flux_face_list(i)%ptr) - end if - allocate(flux_face_list(i)%ptr(tmp_face_list%length)) + if (associated(flux_face_list(i)%ptr)) then + deallocate(flux_face_list(i)%ptr) + end if + allocate(flux_face_list(i)%ptr(tmp_face_list%length)) - flux_face_list(i)%ptr=list2vector(tmp_face_list) - call flush_list(tmp_face_list) + flux_face_list(i)%ptr=list2vector(tmp_face_list) + call flush_list(tmp_face_list) - ! Work out the orthonormal to the line. - dx=start-end - dx=dx/sqrt(dx2) - flux_normal(:,i)=(/-dx(2), dx(1)/) + ! Work out the orthonormal to the line. + dx=start-end + dx=dx/sqrt(dx2) + flux_normal(:,i)=(/-dx(2), dx(1)/) - end do bc_loop + end do bc_loop - end subroutine find_stream_paths + end subroutine find_stream_paths - function boundary_value(X, U, bc_num) - !!< Calculate the value of the streamfunction on the boundary provided - !!< by integrating the velocity flux across a line between this - !!< boundary and the primary boundary. - real :: boundary_value - type(vector_field), intent(in) :: X, U - integer, intent(in) :: bc_num + function boundary_value(X, U, bc_num) + !!< Calculate the value of the streamfunction on the boundary provided + !!< by integrating the velocity flux across a line between this + !!< boundary and the primary boundary. + real :: boundary_value + type(vector_field), intent(in) :: X, U + integer, intent(in) :: bc_num - integer :: face, i + integer :: face, i - boundary_value=0.0 + boundary_value=0.0 - do i=1, size(flux_face_list(bc_num)%ptr) - face=flux_face_list(bc_num)%ptr(i) + do i=1, size(flux_face_list(bc_num)%ptr) + face=flux_face_list(bc_num)%ptr(i) - boundary_value=boundary_value + face_flux(face, X, U, bc_num) + boundary_value=boundary_value + face_flux(face, X, U, bc_num) - end do + end do - ! for parallel so each partitition calculates the bit of the flux that it owns and they sum along the boundary so they all have the correct bd. condition - call allsum(boundary_value) + ! for parallel so each partitition calculates the bit of the flux that it owns and they sum along the boundary so they all have the correct bd. condition + call allsum(boundary_value) - contains + contains - function face_flux(face, X, U, bc_num) - real :: face_flux - integer, intent(in) :: face, bc_num - type(vector_field), intent(in) :: X, U + function face_flux(face, X, U, bc_num) + real :: face_flux + integer, intent(in) :: face, bc_num + type(vector_field), intent(in) :: X, U - real, dimension(face_ngi(U, face)) :: detwei - real, dimension(U%dim,face_ngi(U, face)) :: normal, U_quad - integer :: gi + real, dimension(face_ngi(U, face)) :: detwei + real, dimension(U%dim,face_ngi(U, face)) :: normal, U_quad + integer :: gi - call transform_facet_to_physical(X, face, detwei_f=detwei, normal=normal) + call transform_facet_to_physical(X, face, detwei_f=detwei, normal=normal) - U_quad=face_val_at_quad(U,face) + U_quad=face_val_at_quad(U,face) - face_flux=0.0 + face_flux=0.0 - do gi=1, size(detwei) - face_flux=face_flux+abs(dot_product(flux_normal(:,bc_num),normal(:,gi)))& - * dot_product(U_quad(:,gi),flux_normal(:,bc_num))& - * detwei(gi) - end do + do gi=1, size(detwei) + face_flux=face_flux+abs(dot_product(flux_normal(:,bc_num),normal(:,gi)))& + * dot_product(U_quad(:,gi),flux_normal(:,bc_num))& + * detwei(gi) + end do - end function face_flux + end function face_flux - end function boundary_value + end function boundary_value - subroutine calculate_stream_function_multipath_2d(state, streamfunc) - !!< Calculate the stream function for a - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: streamfunc + subroutine calculate_stream_function_multipath_2d(state, streamfunc) + !!< Calculate the stream function for a + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: streamfunc - integer :: i, ele, stat - type(vector_field), pointer :: X, U - type(csr_sparsity), pointer :: psi_sparsity - type(csr_matrix) :: psi_mat - type(scalar_field) :: rhs - real :: flux_val - type(scalar_field), pointer :: surface_field + integer :: i, ele, stat + type(vector_field), pointer :: X, U + type(csr_sparsity), pointer :: psi_sparsity + type(csr_matrix) :: psi_mat + type(scalar_field) :: rhs + real :: flux_val + type(scalar_field), pointer :: surface_field - integer :: mesh_movement - integer, save :: last_mesh_movement = -1 + integer :: mesh_movement + integer, save :: last_mesh_movement = -1 - X => extract_vector_field(state, "Coordinate", stat) - if(present_and_nonzero(stat)) return - U => extract_vector_field(state, "Velocity", stat) - if(present_and_nonzero(stat)) return + X => extract_vector_field(state, "Coordinate", stat) + if(present_and_nonzero(stat)) return + U => extract_vector_field(state, "Velocity", stat) + if(present_and_nonzero(stat)) return - if (X%dim/=2) then - FLExit("Streamfunction is only valid in 2d") - end if - ! No discontinuous stream functions. - if (continuity(streamfunc)<0) then - FLExit("Streamfunction must be a continuous field") - end if + if (X%dim/=2) then + FLExit("Streamfunction is only valid in 2d") + end if + ! No discontinuous stream functions. + if (continuity(streamfunc)<0) then + FLExit("Streamfunction must be a continuous field") + end if - if (last_adapt get_csr_sparsity_firstorder(state, streamfunc%mesh, streamfunc%mesh) + if(stat /= 0) then + psi_sparsity => get_csr_sparsity_firstorder(state, streamfunc%mesh, streamfunc%mesh) - call allocate(psi_mat, psi_sparsity, name="StreamFunctionMatrix") - call zero(psi_mat) + call allocate(psi_mat, psi_sparsity, name="StreamFunctionMatrix") + call zero(psi_mat) - call allocate(rhs, streamfunc%mesh, "StreamFunctionRHS") - call zero(rhs) + call allocate(rhs, streamfunc%mesh, "StreamFunctionRHS") + call zero(rhs) - do ele=1, element_count(streamfunc) + do ele=1, element_count(streamfunc) - call calculate_streamfunc_ele(rhs, ele, X, U, psi_mat = psi_mat) + call calculate_streamfunc_ele(rhs, ele, X, U, psi_mat = psi_mat) - end do + end do - call insert(state, psi_mat, psi_mat%name) - else - call incref(psi_mat) + call insert(state, psi_mat, psi_mat%name) + else + call incref(psi_mat) - call allocate(rhs, streamfunc%mesh, "StreamFunctionRHS") - call zero(rhs) + call allocate(rhs, streamfunc%mesh, "StreamFunctionRHS") + call zero(rhs) - do ele=1, element_count(streamfunc) + do ele=1, element_count(streamfunc) - call calculate_streamfunc_ele(rhs, ele, X, U) + call calculate_streamfunc_ele(rhs, ele, X, U) - end do - end if - last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) + end do + end if + last_mesh_movement = eventcount(EVENT_MESH_MOVEMENT) - do i = 1, get_boundary_condition_count(streamfunc) + do i = 1, get_boundary_condition_count(streamfunc) - surface_field=>extract_surface_field(streamfunc, i, "value") + surface_field=>extract_surface_field(streamfunc, i, "value") - flux_val=boundary_value(X,U,i) + flux_val=boundary_value(X,U,i) - call set(surface_field, flux_val) + call set(surface_field, flux_val) - end do + end do - call zero(streamfunc) + call zero(streamfunc) - call apply_dirichlet_conditions(psi_mat, rhs, streamfunc) + call apply_dirichlet_conditions(psi_mat, rhs, streamfunc) - call petsc_solve(streamfunc, psi_mat, rhs) + call petsc_solve(streamfunc, psi_mat, rhs) - call deallocate(rhs) - call deallocate(psi_mat) + call deallocate(rhs) + call deallocate(psi_mat) - contains + contains - subroutine calculate_streamfunc_ele(rhs, ele, X, U, psi_mat) - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: X,U - integer, intent(in) :: ele - type(csr_matrix), optional, intent(inout) :: psi_mat + subroutine calculate_streamfunc_ele(rhs, ele, X, U, psi_mat) + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: X,U + integer, intent(in) :: ele + type(csr_matrix), optional, intent(inout) :: psi_mat - ! Transformed gradient function for velocity. - real, dimension(ele_loc(U, ele), ele_ngi(U, ele), mesh_dim(U)) :: du_t - ! Ditto for the stream function, psi - real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), mesh_dim(rhs))& - & :: dpsi_t + ! Transformed gradient function for velocity. + real, dimension(ele_loc(U, ele), ele_ngi(U, ele), mesh_dim(U)) :: du_t + ! Ditto for the stream function, psi + real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), mesh_dim(rhs))& + & :: dpsi_t - ! Local vorticity_matrix - real, dimension(2, ele_loc(rhs, ele), ele_loc(U, ele)) ::& - & lvorticity_mat - ! Local vorticity - real, dimension(ele_loc(rhs, ele)) :: lvorticity + ! Local vorticity_matrix + real, dimension(2, ele_loc(rhs, ele), ele_loc(U, ele)) ::& + & lvorticity_mat + ! Local vorticity + real, dimension(ele_loc(rhs, ele)) :: lvorticity - ! Variable transform times quadrature weights. - real, dimension(ele_ngi(U,ele)) :: detwei + ! Variable transform times quadrature weights. + real, dimension(ele_ngi(U,ele)) :: detwei - type(element_type), pointer :: U_shape, psi_shape - integer, dimension(:), pointer :: psi_ele - integer :: i + type(element_type), pointer :: U_shape, psi_shape + integer, dimension(:), pointer :: psi_ele + integer :: i - U_shape=> ele_shape(U, ele) - psi_shape=> ele_shape(rhs, ele) - psi_ele=>ele_nodes(rhs, ele) + U_shape=> ele_shape(U, ele) + psi_shape=> ele_shape(rhs, ele) + psi_ele=>ele_nodes(rhs, ele) - ! Transform U derivatives and weights into physical space. - call transform_to_physical(X, ele, U_shape, dshape=du_t, detwei=detwei) - ! Ditto psi. - call transform_to_physical(X, ele, psi_shape, dshape=dpsi_t) + ! Transform U derivatives and weights into physical space. + call transform_to_physical(X, ele, U_shape, dshape=du_t, detwei=detwei) + ! Ditto psi. + call transform_to_physical(X, ele, psi_shape, dshape=dpsi_t) - if(present(psi_mat)) then - call addto(psi_mat, psi_ele, psi_ele, & - dshape_dot_dshape(dpsi_t, dpsi_t, detwei)) - end if + if(present(psi_mat)) then + call addto(psi_mat, psi_ele, psi_ele, & + dshape_dot_dshape(dpsi_t, dpsi_t, detwei)) + end if - lvorticity_mat=shape_curl_shape_2d(psi_shape, du_t, detwei) + lvorticity_mat=shape_curl_shape_2d(psi_shape, du_t, detwei) - lvorticity=0.0 - do i=1,2 - lvorticity=lvorticity & - +matmul(lvorticity_mat(i,:,:), ele_val(U, i, ele)) - end do + lvorticity=0.0 + do i=1,2 + lvorticity=lvorticity & + +matmul(lvorticity_mat(i,:,:), ele_val(U, i, ele)) + end do - call addto(rhs, psi_ele, -lvorticity) + call addto(rhs, psi_ele, -lvorticity) - end subroutine calculate_streamfunc_ele + end subroutine calculate_streamfunc_ele - end subroutine calculate_stream_function_multipath_2d + end subroutine calculate_stream_function_multipath_2d end module streamfunction diff --git a/femtools/Superconvergence.F90 b/femtools/Superconvergence.F90 index f8d20b0241..0bc75b166e 100644 --- a/femtools/Superconvergence.F90 +++ b/femtools/Superconvergence.F90 @@ -7,87 +7,87 @@ module superconvergence !!< Zienkiewicz & Zhu, Int. J. Numer. Methods Eng, 33, 1331-1364 (1992) !! This is primarily used by field_derivatives. -use fldebug -use vector_tools -use elements - -implicit none - -integer, parameter, public :: MATRIX_SIZE_SPR=4 -integer, parameter, public :: MATRIX_SIZE_QF=11 -integer, parameter, public :: MATRIX_SIZE_CF=20 -integer, parameter, public :: MATRIX_SIZE_CF_2D=10 -integer, parameter, public :: MATRIX_SIZE_QF_2D=6 -integer, dimension(MATRIX_SIZE_QF_2D), parameter, public ::& - QF_2D_X = (/1, 3, 4, 6, 7, 10/) -integer, dimension(MATRIX_SIZE_QF_2D), parameter, public ::& - QF_2D_Y = (/1, 2, 4, 5, 7, 9/) -integer, dimension(MATRIX_SIZE_QF_2D), parameter, public ::& - QF_2D_Z = (/1, 2, 3, 5, 6, 8/) -integer, dimension(MATRIX_SIZE_CF_2D), parameter, public ::& - CF_2D_X = (/1, 3, 4, 7, 9, 10, 15, 17, 19, 20/) -integer, dimension(MATRIX_SIZE_CF_2D), parameter, public ::& - CF_2D_Y = (/1, 2, 4, 6, 8, 10, 13, 16, 18, 20/) -integer, dimension(MATRIX_SIZE_CF_2D), parameter, public ::& - CF_2D_Z = (/1, 2, 3, 5, 8, 9, 12, 14, 18, 19/) -type(superconvergence_type), save, target :: superconvergence_tet_array(1) - -private - -public :: initialise_superconvergence, get_superconvergence, getP_spr,& - compute_matrix_contribution_cf, getP_qf, compute_rhs_contribution_qf,& - compute_rhs_contribution_spr, compute_rhs_contribution_cf,& - compute_matrix_contribution_qf, compute_matrix_contribution_spr,& - evaluate_cf, evaluate_qf + use fldebug + use vector_tools + use elements + + implicit none + + integer, parameter, public :: MATRIX_SIZE_SPR=4 + integer, parameter, public :: MATRIX_SIZE_QF=11 + integer, parameter, public :: MATRIX_SIZE_CF=20 + integer, parameter, public :: MATRIX_SIZE_CF_2D=10 + integer, parameter, public :: MATRIX_SIZE_QF_2D=6 + integer, dimension(MATRIX_SIZE_QF_2D), parameter, public ::& + QF_2D_X = (/1, 3, 4, 6, 7, 10/) + integer, dimension(MATRIX_SIZE_QF_2D), parameter, public ::& + QF_2D_Y = (/1, 2, 4, 5, 7, 9/) + integer, dimension(MATRIX_SIZE_QF_2D), parameter, public ::& + QF_2D_Z = (/1, 2, 3, 5, 6, 8/) + integer, dimension(MATRIX_SIZE_CF_2D), parameter, public ::& + CF_2D_X = (/1, 3, 4, 7, 9, 10, 15, 17, 19, 20/) + integer, dimension(MATRIX_SIZE_CF_2D), parameter, public ::& + CF_2D_Y = (/1, 2, 4, 6, 8, 10, 13, 16, 18, 20/) + integer, dimension(MATRIX_SIZE_CF_2D), parameter, public ::& + CF_2D_Z = (/1, 2, 3, 5, 8, 9, 12, 14, 18, 19/) + type(superconvergence_type), save, target :: superconvergence_tet_array(1) + + private + + public :: initialise_superconvergence, get_superconvergence, getP_spr,& + compute_matrix_contribution_cf, getP_qf, compute_rhs_contribution_qf,& + compute_rhs_contribution_spr, compute_rhs_contribution_cf,& + compute_matrix_contribution_qf, compute_matrix_contribution_spr,& + evaluate_cf, evaluate_qf contains - subroutine initialise_superconvergence - logical, save :: initialised = .false. + subroutine initialise_superconvergence + logical, save :: initialised = .false. - if (initialised) return - initialised = .true. + if (initialised) return + initialised = .true. - superconvergence_tet_array(1)%nsp = 6 - allocate(superconvergence_tet_array(1)%l(6, 4)) - allocate(superconvergence_tet_array(1)%n(4, 6)) - allocate(superconvergence_tet_array(1)%dn(4, 6, 3)) + superconvergence_tet_array(1)%nsp = 6 + allocate(superconvergence_tet_array(1)%l(6, 4)) + allocate(superconvergence_tet_array(1)%n(4, 6)) + allocate(superconvergence_tet_array(1)%dn(4, 6, 3)) - ! The midpoints of the edges. - superconvergence_tet_array(1)%l(1, :) = (/0.50, 0.50, 0.00, 0.00/) - superconvergence_tet_array(1)%l(2, :) = (/0.50, 0.00, 0.50, 0.00/) - superconvergence_tet_array(1)%l(3, :) = (/0.50, 0.00, 0.00, 0.50/) - superconvergence_tet_array(1)%l(4, :) = (/0.00, 0.50, 0.50, 0.00/) - superconvergence_tet_array(1)%l(5, :) = (/0.00, 0.50, 0.00, 0.50/) - superconvergence_tet_array(1)%l(6, :) = (/0.00, 0.00, 0.50, 0.50/) - end subroutine initialise_superconvergence + ! The midpoints of the edges. + superconvergence_tet_array(1)%l(1, :) = (/0.50, 0.50, 0.00, 0.00/) + superconvergence_tet_array(1)%l(2, :) = (/0.50, 0.00, 0.50, 0.00/) + superconvergence_tet_array(1)%l(3, :) = (/0.50, 0.00, 0.00, 0.50/) + superconvergence_tet_array(1)%l(4, :) = (/0.00, 0.50, 0.50, 0.00/) + superconvergence_tet_array(1)%l(5, :) = (/0.00, 0.50, 0.00, 0.50/) + superconvergence_tet_array(1)%l(6, :) = (/0.00, 0.00, 0.50, 0.50/) + end subroutine initialise_superconvergence - function get_superconvergence(element) result(superconvergence) - type(superconvergence_type), pointer :: superconvergence - type(element_type), intent(in) :: element + function get_superconvergence(element) result(superconvergence) + type(superconvergence_type), pointer :: superconvergence + type(element_type), intent(in) :: element - integer :: i, j + integer :: i, j - call initialise_superconvergence + call initialise_superconvergence - if (element%dim == 3 .and. element%degree == 1 .and. element%loc == 4) then - superconvergence => superconvergence_tet_array(1) + if (element%dim == 3 .and. element%degree == 1 .and. element%loc == 4) then + superconvergence => superconvergence_tet_array(1) + do j=1,superconvergence%nsp + superconvergence%n(:, j) = eval_shape(element, superconvergence%l(j, :)) + end do + do i=1,element%loc do j=1,superconvergence%nsp - superconvergence%n(:, j) = eval_shape(element, superconvergence%l(j, :)) - end do - do i=1,element%loc - do j=1,superconvergence%nsp - superconvergence%dn(i, j, :) = eval_dshape(element, i, superconvergence%l(j, :)) - end do + superconvergence%dn(i, j, :) = eval_dshape(element, i, superconvergence%l(j, :)) end do + end do - else - superconvergence => null() - end if + else + superconvergence => null() + end if - end function get_superconvergence + end function get_superconvergence !------------------------------------ ! pure function matrix_size_spr() @@ -97,21 +97,21 @@ end function get_superconvergence ! end function matrix_size_spr !------------------------------------ - function getP_spr(positions, element) result(P) + function getP_spr(positions, element) result(P) !!< This computes P as defined in the SPR paper. See the ref above. real, intent(in) :: positions(:) type(element_type) :: element real, dimension(MATRIX_SIZE_SPR) :: P if (element%dim == 3 .and. element%degree == 1 .and. element%loc == 4) then - P(1) = 1.0 - P(2:4) = positions(1:3) + P(1) = 1.0 + P(2:4) = positions(1:3) else - FLAbort("P not coded for this element type!") + FLAbort("P not coded for this element type!") end if - end function + end function - function compute_matrix_contribution_spr(positions, element) result(pTp) + function compute_matrix_contribution_spr(positions, element) result(pTp) !!< See the superconvergent patch recovery paper (reference is available above) !!< for this. P is a vector function of position, depending on the element. !!< For a given node, the algorithm solves Ax = b, where @@ -128,12 +128,12 @@ function compute_matrix_contribution_spr(positions, element) result(pTp) P = getP_spr(positions, element) pTp= outer_product(P, P) - end function compute_matrix_contribution_spr + end function compute_matrix_contribution_spr - function compute_rhs_contribution_spr(positions, element, derivative) result(b) - !!< This function is the same as above, but for the right hand side. - !!< Unlike the matrix, the rhs depends on which derivative you're taking. - !!< Here b = sum(over superconvergent points) of P^T(x, y, z) * diff(field, coordinate)(x, y, z) + function compute_rhs_contribution_spr(positions, element, derivative) result(b) + !!< This function is the same as above, but for the right hand side. + !!< Unlike the matrix, the rhs depends on which derivative you're taking. + !!< Here b = sum(over superconvergent points) of P^T(x, y, z) * diff(field, coordinate)(x, y, z) type(element_type), intent(in) :: element real :: positions(:) @@ -143,7 +143,7 @@ function compute_rhs_contribution_spr(positions, element, derivative) result(b) assert(element%dim .eq. size(positions)) b = derivative * getP_spr(positions, element) - end function compute_rhs_contribution_spr + end function compute_rhs_contribution_spr !----------------------------------- ! pure function matrix_size_qf() @@ -153,7 +153,7 @@ end function compute_rhs_contribution_spr ! end function matrix_size_qf !----------------------------------- - function getP_qf(positions) result(P) + function getP_qf(positions) result(P) !!< This computes P as defined in the QF paper. See the ref above. real, intent(in) :: positions(:) real, dimension(MATRIX_SIZE_QF) :: P @@ -169,9 +169,9 @@ function getP_qf(positions) result(P) P(9) = x * z P(10) = y * z P(11) = x * y * z - end function + end function - function compute_matrix_contribution_qf(positions) result(pTp) + function compute_matrix_contribution_qf(positions) result(pTp) !!< P is a vector function of position, representing a quadratic fit. !!< For a given node, the algorithm solves Ax = b, where !!< A = sum(over superconvergent points) of P^T(x, y, z) * P(x, y, z) @@ -183,32 +183,32 @@ function compute_matrix_contribution_qf(positions) result(pTp) P = getP_qf(positions) pTp = outer_product(P, P) - end function compute_matrix_contribution_qf + end function compute_matrix_contribution_qf - function compute_rhs_contribution_qf(positions, derivative) result(b) - !!< This function is the same as above, but for the right hand side. - !!< Here b = sum(over patch points) of P^T(x, y, z) * diff(field, coordinate)(x, y, z) + function compute_rhs_contribution_qf(positions, derivative) result(b) + !!< This function is the same as above, but for the right hand side. + !!< Here b = sum(over patch points) of P^T(x, y, z) * diff(field, coordinate)(x, y, z) real :: positions(:) real, intent(in) :: derivative real, dimension(MATRIX_SIZE_QF) :: b b = derivative * getP_qf(positions) - end function compute_rhs_contribution_qf + end function compute_rhs_contribution_qf - function evaluate_qf(b, positions) result(fitted) - !!< Evaluate the quadratic fit at the position given. + function evaluate_qf(b, positions) result(fitted) + !!< Evaluate the quadratic fit at the position given. real, dimension(:), intent(in) :: b, positions real :: fitted, x, y, z x = positions(1); y = positions(2); z = positions(3) fitted = b(1) + x * b(2) + y * b(3) + z * b(4) + & - x**2 * b(5) + y**2 * b(6) + z**2 * b(7) + & - x * y * b(8) + x * z * b(9) + y * z * b(10) + & - x * y * z * b(11) - end function evaluate_qf + x**2 * b(5) + y**2 * b(6) + z**2 * b(7) + & + x * y * b(8) + x * z * b(9) + y * z * b(10) + & + x * y * z * b(11) + end function evaluate_qf - function getP_cf(positions) result(P) + function getP_cf(positions) result(P) !!< This computes P as defined in the QF paper. See the ref above. real, intent(in) :: positions(:) real, dimension(MATRIX_SIZE_CF) :: P @@ -233,9 +233,9 @@ function getP_cf(positions) result(P) P(18) = x**3 P(19) = y**3 P(20) = z**3 - end function + end function - function compute_matrix_contribution_cf(positions) result(pTp) + function compute_matrix_contribution_cf(positions) result(pTp) !!< P is a vector function of position, representing a cubic fit. !!< For a given node, the algorithm solves Ax = b, where !!< A = sum(over superconvergent points) of P^T(x, y, z) * P(x, y, z) @@ -247,31 +247,31 @@ function compute_matrix_contribution_cf(positions) result(pTp) P = getP_cf(positions) pTp = outer_product(P, P) - end function compute_matrix_contribution_cf + end function compute_matrix_contribution_cf - function compute_rhs_contribution_cf(positions, derivative) result(b) - !!< This function is the same as above, but for the right hand side. - !!< Here b = sum(over patch points) of P^T(x, y, z) * diff(field, coordinate)(x, y, z) + function compute_rhs_contribution_cf(positions, derivative) result(b) + !!< This function is the same as above, but for the right hand side. + !!< Here b = sum(over patch points) of P^T(x, y, z) * diff(field, coordinate)(x, y, z) real :: positions(:) real, intent(in) :: derivative real, dimension(MATRIX_SIZE_CF) :: b b = derivative * getP_cf(positions) - end function compute_rhs_contribution_cf + end function compute_rhs_contribution_cf - function evaluate_cf(b, positions) result(fitted) - !!< Evaluate the cubic fit at the position given. + function evaluate_cf(b, positions) result(fitted) + !!< Evaluate the cubic fit at the position given. real, dimension(:), intent(in) :: b, positions real :: fitted, x, y, z x = positions(1); y = positions(2); z = positions(3) fitted = b(1) + x * b(2) + y * b(3) + z * b(4) + & - x * y * b(5) + x * z * b(6) + y * z * b(7) + & - x**2 * b(8) + y**2 * b(9) + z**2 * b(10) + & - x * y * z * b(11) + & - x**2 * y * b(12) + x**2 * z * b(13) + y**2 * x * b(14) + & - y**2 * z * b(15) + z**2 * x * b(16) + z**2 * y * b(17) + & - x**3 * b(18) + y**3 * b(19) + z**3 * b(20) - end function evaluate_cf + x * y * b(5) + x * z * b(6) + y * z * b(7) + & + x**2 * b(8) + y**2 * b(9) + z**2 * b(10) + & + x * y * z * b(11) + & + x**2 * y * b(12) + x**2 * z * b(13) + y**2 * x * b(14) + & + y**2 * z * b(15) + z**2 * x * b(16) + z**2 * y * b(17) + & + x**3 * b(18) + y**3 * b(19) + z**3 * b(20) + end function evaluate_cf end module superconvergence diff --git a/femtools/Supermesh.F90 b/femtools/Supermesh.F90 index 955e63241d..077492b3a6 100644 --- a/femtools/Supermesh.F90 +++ b/femtools/Supermesh.F90 @@ -1,425 +1,425 @@ #include "fdebug.h" module supermesh_construction - use iso_c_binding, only: c_float, c_double - use fldebug - use futils - use sparse_tools - use elements - use fields_data_types - use fields_base - use linked_lists - use fields_allocates - use fields_manipulation - use metric_tools - use unify_meshes_module - use transform_elements + use iso_c_binding, only: c_float, c_double + use fldebug + use futils + use sparse_tools + use elements + use fields_data_types + use fields_base + use linked_lists + use fields_allocates + use fields_manipulation + use metric_tools + use unify_meshes_module + use transform_elements #ifdef HAVE_LIBSUPERMESH - use libsupermesh, only : libsupermesh_intersect_elements => intersect_elements + use libsupermesh, only : libsupermesh_intersect_elements => intersect_elements #endif - use tetrahedron_intersection_module - implicit none + use tetrahedron_intersection_module + implicit none #ifdef HAVE_LIBSUPERMESH - real, dimension(:, :, :), allocatable, save :: elements_c + real, dimension(:, :, :), allocatable, save :: elements_c #else - interface cintersector_set_input - module procedure intersector_set_input_sp - - subroutine cintersector_set_input(nodes_A, nodes_B, ndim, loc) - use iso_c_binding, only: c_double - implicit none - real(kind = c_double), dimension(ndim, loc), intent(in) :: nodes_A, nodes_B - integer, intent(in) :: ndim, loc - end subroutine cintersector_set_input - end interface cintersector_set_input - - interface - subroutine cintersector_drive - end subroutine cintersector_drive - end interface - - interface - subroutine cintersector_query(nonods, totele) - implicit none - integer, intent(out) :: nonods, totele - end subroutine cintersector_query - end interface - - interface cintersector_get_output - module procedure intersector_get_output_sp - - subroutine cintersector_get_output(nonods, totele, ndim, loc, nodes, enlist) - use iso_c_binding, only: c_double - implicit none - integer, intent(in) :: nonods, totele, ndim, loc - real(kind = c_double), dimension(nonods * ndim), intent(out) :: nodes - integer, dimension(totele * loc), intent(out) :: enlist - end subroutine cintersector_get_output - end interface cintersector_get_output - - interface intersector_set_dimension - subroutine cintersector_set_dimension(ndim) - implicit none - integer, intent(in) :: ndim - end subroutine cintersector_set_dimension - end interface intersector_set_dimension - - interface - subroutine cintersector_set_exactness(exact) - implicit none - integer, intent(in) :: exact - end subroutine cintersector_set_exactness - end interface - - ! I hope this is big enough ... - real, dimension(1024), save :: nodes_tmp + interface cintersector_set_input + module procedure intersector_set_input_sp + + subroutine cintersector_set_input(nodes_A, nodes_B, ndim, loc) + use iso_c_binding, only: c_double + implicit none + real(kind = c_double), dimension(ndim, loc), intent(in) :: nodes_A, nodes_B + integer, intent(in) :: ndim, loc + end subroutine cintersector_set_input + end interface cintersector_set_input + + interface + subroutine cintersector_drive + end subroutine cintersector_drive + end interface + + interface + subroutine cintersector_query(nonods, totele) + implicit none + integer, intent(out) :: nonods, totele + end subroutine cintersector_query + end interface + + interface cintersector_get_output + module procedure intersector_get_output_sp + + subroutine cintersector_get_output(nonods, totele, ndim, loc, nodes, enlist) + use iso_c_binding, only: c_double + implicit none + integer, intent(in) :: nonods, totele, ndim, loc + real(kind = c_double), dimension(nonods * ndim), intent(out) :: nodes + integer, dimension(totele * loc), intent(out) :: enlist + end subroutine cintersector_get_output + end interface cintersector_get_output + + interface intersector_set_dimension + subroutine cintersector_set_dimension(ndim) + implicit none + integer, intent(in) :: ndim + end subroutine cintersector_set_dimension + end interface intersector_set_dimension + + interface + subroutine cintersector_set_exactness(exact) + implicit none + integer, intent(in) :: exact + end subroutine cintersector_set_exactness + end interface + + ! I hope this is big enough ... + real, dimension(1024), save :: nodes_tmp #endif - logical, save :: intersector_exactness = .false. + logical, save :: intersector_exactness = .false. - private + private - public :: intersect_elements, intersector_set_dimension, intersector_set_exactness - public :: construct_supermesh, compute_projection_error, intersector_exactness + public :: intersect_elements, intersector_set_dimension, intersector_set_exactness + public :: construct_supermesh, compute_projection_error, intersector_exactness - contains +contains #ifdef HAVE_LIBSUPERMESH - subroutine intersector_set_dimension(ndim) - integer, intent(in) :: ndim - - if(allocated(elements_c)) then - if(size(elements_c, 1) == ndim) return - deallocate(elements_c) - end if - - select case(ndim) - case(1) - allocate(elements_c(1, 2, 2)) - case(2) - allocate(elements_c(2, 3, 62)) - case(3) - allocate(elements_c(3, 4, 3645)) - case default - FLAbort("Invalid dimension") - end select - - end subroutine intersector_set_dimension - - function intersect_elements(positions_A, ele_A, posB, shape, empty_intersection) result(intersection) - type(vector_field), intent(in) :: positions_A - integer, intent(in) :: ele_A - real, dimension(:, :), intent(in) :: posB - type(element_type), intent(in) :: shape - ! if present, returns whether the intersection is empty or not - ! if present and the intersection is empty, no intersection mesh is returned (should be discarded and not deallocated) - ! if not present and the intersection is empty, a valid 0-element mesh is returned - ! this is an optimisation that avoids allocating lots of empty meshes inside supermesh loops - logical, optional, intent(out) :: empty_intersection - - type(vector_field) :: intersection - - integer :: i, n_elements_c - type(mesh_type) :: intersection_mesh - - call libsupermesh_intersect_elements(reordered(ele_val(positions_A, ele_A)), reordered(posB), elements_c, n_elements_c) - - if (present(empty_intersection)) then - if (n_elements_c==0) then - empty_intersection = .true. - return - else - empty_intersection = .false. + subroutine intersector_set_dimension(ndim) + integer, intent(in) :: ndim + + if(allocated(elements_c)) then + if(size(elements_c, 1) == ndim) return + deallocate(elements_c) end if - end if - call allocate(intersection_mesh, size(elements_c, 2) * n_elements_c, n_elements_c, shape, "IntersectionMesh") - intersection_mesh%continuity = -1 - forall(i = 1:size(elements_c, 2) * n_elements_c) - intersection_mesh%ndglno(i) = i - end forall + select case(ndim) + case(1) + allocate(elements_c(1, 2, 2)) + case(2) + allocate(elements_c(2, 3, 62)) + case(3) + allocate(elements_c(3, 4, 3645)) + case default + FLAbort("Invalid dimension") + end select + + end subroutine intersector_set_dimension + + function intersect_elements(positions_A, ele_A, posB, shape, empty_intersection) result(intersection) + type(vector_field), intent(in) :: positions_A + integer, intent(in) :: ele_A + real, dimension(:, :), intent(in) :: posB + type(element_type), intent(in) :: shape + ! if present, returns whether the intersection is empty or not + ! if present and the intersection is empty, no intersection mesh is returned (should be discarded and not deallocated) + ! if not present and the intersection is empty, a valid 0-element mesh is returned + ! this is an optimisation that avoids allocating lots of empty meshes inside supermesh loops + logical, optional, intent(out) :: empty_intersection + + type(vector_field) :: intersection + + integer :: i, n_elements_c + type(mesh_type) :: intersection_mesh + + call libsupermesh_intersect_elements(reordered(ele_val(positions_A, ele_A)), reordered(posB), elements_c, n_elements_c) + + if (present(empty_intersection)) then + if (n_elements_c==0) then + empty_intersection = .true. + return + else + empty_intersection = .false. + end if + end if - call allocate(intersection, size(elements_c, 1), intersection_mesh, "IntersectionCoordinates") - do i = 1, n_elements_c - call set(intersection, ele_nodes(intersection, i), elements_c(:, :, i)) - end do + call allocate(intersection_mesh, size(elements_c, 2) * n_elements_c, n_elements_c, shape, "IntersectionMesh") + intersection_mesh%continuity = -1 + forall(i = 1:size(elements_c, 2) * n_elements_c) + intersection_mesh%ndglno(i) = i + end forall - call deallocate(intersection_mesh) + call allocate(intersection, size(elements_c, 1), intersection_mesh, "IntersectionCoordinates") + do i = 1, n_elements_c + call set(intersection, ele_nodes(intersection, i), elements_c(:, :, i)) + end do - contains + call deallocate(intersection_mesh) - function reordered(element) - ! dim x loc - real, dimension(:, :), intent(in) :: element + contains - real, dimension(size(element, 1), size(element, 2)) :: reordered + function reordered(element) + ! dim x loc + real, dimension(:, :), intent(in) :: element - ! See toFluidityElementNodeOrdering in femtools/GMSH_Common.F90 - if(size(element, 1) == 2 .and. size(element, 2) == 4) then - reordered = element(:, (/1, 2, 4, 3/)) - else if(size(element, 1) == 3 .and. size(element, 2) == 8) then - reordered = element(:, (/1, 2, 4, 3, 5, 6, 8, 7/)) - else - reordered = element - end if + real, dimension(size(element, 1), size(element, 2)) :: reordered - end function reordered + ! See toFluidityElementNodeOrdering in femtools/GMSH_Common.F90 + if(size(element, 1) == 2 .and. size(element, 2) == 4) then + reordered = element(:, (/1, 2, 4, 3/)) + else if(size(element, 1) == 3 .and. size(element, 2) == 8) then + reordered = element(:, (/1, 2, 4, 3, 5, 6, 8, 7/)) + else + reordered = element + end if - end function intersect_elements + end function reordered + + end function intersect_elements #else - subroutine intersector_set_input_sp(nodes_A, nodes_B, ndim, loc) - real(kind = c_float), dimension(ndim, loc), intent(in) :: nodes_A - real(kind = c_float), dimension(ndim, loc), intent(in) :: nodes_B - integer, intent(in) :: ndim - integer, intent(in) :: loc - - call cintersector_set_input(real(nodes_A, kind = c_double), real(nodes_B, kind = c_double), ndim, loc) - - end subroutine intersector_set_input_sp - - subroutine intersector_get_output_sp(nonods, totele, ndim, loc, nodes, enlist) - integer, intent(in) :: nonods - integer, intent(in) :: totele - integer, intent(in) :: ndim - integer, intent(in) :: loc - real(kind = c_float), dimension(nonods * ndim), intent(out) :: nodes - integer, dimension(totele * loc), intent(out) :: enlist - - real(kind = c_double), dimension(size(nodes)) :: lnodes - - call cintersector_get_output(nonods, totele, ndim, loc, lnodes, enlist) - nodes = lnodes - - end subroutine intersector_get_output_sp - - function intersect_elements(positions_A, ele_A, posB, shape, empty_intersection) result(intersection) - type(vector_field), intent(in) :: positions_A - integer, intent(in) :: ele_A - type(vector_field) :: intersection - type(mesh_type) :: intersection_mesh - type(element_type), intent(in) :: shape - real, dimension(:, :), intent(in) :: posB - ! if present, returns whether the intersection is empty or not - ! if present and the intersection is empty, no intersection mesh is returned (should be discarded and not deallocated) - ! if not present and the intersection is empty, a valid 0-element mesh is returned - ! this is an optimisation that avoids allocating lots of empty meshes inside supermesh loops - logical, optional, intent(out) :: empty_intersection - - integer :: dim, loc - integer :: nonods, totele - integer :: i - - dim = positions_A%dim + subroutine intersector_set_input_sp(nodes_A, nodes_B, ndim, loc) + real(kind = c_float), dimension(ndim, loc), intent(in) :: nodes_A + real(kind = c_float), dimension(ndim, loc), intent(in) :: nodes_B + integer, intent(in) :: ndim + integer, intent(in) :: loc + + call cintersector_set_input(real(nodes_A, kind = c_double), real(nodes_B, kind = c_double), ndim, loc) + + end subroutine intersector_set_input_sp + + subroutine intersector_get_output_sp(nonods, totele, ndim, loc, nodes, enlist) + integer, intent(in) :: nonods + integer, intent(in) :: totele + integer, intent(in) :: ndim + integer, intent(in) :: loc + real(kind = c_float), dimension(nonods * ndim), intent(out) :: nodes + integer, dimension(totele * loc), intent(out) :: enlist + + real(kind = c_double), dimension(size(nodes)) :: lnodes + + call cintersector_get_output(nonods, totele, ndim, loc, lnodes, enlist) + nodes = lnodes + + end subroutine intersector_get_output_sp + + function intersect_elements(positions_A, ele_A, posB, shape, empty_intersection) result(intersection) + type(vector_field), intent(in) :: positions_A + integer, intent(in) :: ele_A + type(vector_field) :: intersection + type(mesh_type) :: intersection_mesh + type(element_type), intent(in) :: shape + real, dimension(:, :), intent(in) :: posB + ! if present, returns whether the intersection is empty or not + ! if present and the intersection is empty, no intersection mesh is returned (should be discarded and not deallocated) + ! if not present and the intersection is empty, a valid 0-element mesh is returned + ! this is an optimisation that avoids allocating lots of empty meshes inside supermesh loops + logical, optional, intent(out) :: empty_intersection + + integer :: dim, loc + integer :: nonods, totele + integer :: i + + dim = positions_A%dim #ifdef DDEBUG - select case(dim) - case(2) - assert(shape%loc == 3) - case(3) - assert(shape%loc == 4) - end select + select case(dim) + case(2) + assert(shape%loc == 3) + case(3) + assert(shape%loc == 4) + end select #endif - loc = ele_loc(positions_A, ele_A) + loc = ele_loc(positions_A, ele_A) - call cintersector_set_input(ele_val(positions_A, ele_A), posB, dim, loc) - call cintersector_drive - call cintersector_query(nonods, totele) + call cintersector_set_input(ele_val(positions_A, ele_A), posB, dim, loc) + call cintersector_drive + call cintersector_query(nonods, totele) - if (present(empty_intersection)) then - if (totele==0) then - empty_intersection = .true. - return - else - empty_intersection = .false. + if (present(empty_intersection)) then + if (totele==0) then + empty_intersection = .true. + return + else + empty_intersection = .false. + end if end if - end if - call allocate(intersection_mesh, nonods, totele, shape, "IntersectionMesh") - intersection_mesh%continuity = -1 - call allocate(intersection, dim, intersection_mesh, "IntersectionCoordinates") - if (nonods > 0) then + call allocate(intersection_mesh, nonods, totele, shape, "IntersectionMesh") + intersection_mesh%continuity = -1 + call allocate(intersection, dim, intersection_mesh, "IntersectionCoordinates") + if (nonods > 0) then #ifdef DDEBUG - intersection_mesh%ndglno = -1 + intersection_mesh%ndglno = -1 #endif - call cintersector_get_output(nonods, totele, dim, dim + 1, nodes_tmp, intersection_mesh%ndglno) + call cintersector_get_output(nonods, totele, dim, dim + 1, nodes_tmp, intersection_mesh%ndglno) - do i = 1, dim - intersection%val(i,:) = nodes_tmp((i - 1) * nonods + 1:i * nonods) - end do - end if + do i = 1, dim + intersection%val(i,:) = nodes_tmp((i - 1) * nonods + 1:i * nonods) + end do + end if - call deallocate(intersection_mesh) + call deallocate(intersection_mesh) - end function intersect_elements + end function intersect_elements #endif - subroutine intersector_set_exactness(exactness) - logical, intent(in) :: exactness + subroutine intersector_set_exactness(exactness) + logical, intent(in) :: exactness #ifdef HAVE_LIBSUPERMESH - if(exactness) then - FLAbort("Arbitrary precision arithmetic not supported by libsupermesh") - end if + if(exactness) then + FLAbort("Arbitrary precision arithmetic not supported by libsupermesh") + end if #else - integer :: exact + integer :: exact - if (exactness) then - exact = 1 - else - exact = 0 - end if - intersector_exactness = exactness + if (exactness) then + exact = 1 + else + exact = 0 + end if + intersector_exactness = exactness - call cintersector_set_exactness(exact) + call cintersector_set_exactness(exact) #endif - end subroutine intersector_set_exactness - - ! A higher-level interface to supermesh construction. - subroutine construct_supermesh(new_positions, ele_B, old_positions, map_BA, supermesh_shape, supermesh) - type(vector_field), intent(in) :: new_positions, old_positions - integer, intent(in) :: ele_B - type(ilist) :: map_BA - type(element_type), intent(in) :: supermesh_shape - type(vector_field), intent(out) :: supermesh - integer :: ele_A - type(inode), pointer :: llnode - type(vector_field), dimension(map_BA%length) :: intersection - real, dimension(new_positions%dim, ele_loc(new_positions, ele_B)) :: pos_B - type(plane_type), dimension(4) :: planes_B - type(tet_type) :: tet_A, tet_B - integer :: lstat, dim, j, i - logical :: empty_intersection - - dim = new_positions%dim - - if (dim == 3) then - tet_B%V = ele_val(new_positions, ele_B) - planes_B = get_planes(tet_B) - else - pos_B = ele_val(new_positions, ele_B) - end if - - j = 1 - - llnode => map_BA%firstnode - do while(associated(llnode)) - ele_A = llnode%value + end subroutine intersector_set_exactness + + ! A higher-level interface to supermesh construction. + subroutine construct_supermesh(new_positions, ele_B, old_positions, map_BA, supermesh_shape, supermesh) + type(vector_field), intent(in) :: new_positions, old_positions + integer, intent(in) :: ele_B + type(ilist) :: map_BA + type(element_type), intent(in) :: supermesh_shape + type(vector_field), intent(out) :: supermesh + integer :: ele_A + type(inode), pointer :: llnode + type(vector_field), dimension(map_BA%length) :: intersection + real, dimension(new_positions%dim, ele_loc(new_positions, ele_B)) :: pos_B + type(plane_type), dimension(4) :: planes_B + type(tet_type) :: tet_A, tet_B + integer :: lstat, dim, j, i + logical :: empty_intersection + + dim = new_positions%dim + if (dim == 3) then - tet_A%V = ele_val(old_positions, ele_A) - call intersect_tets(tet_A, planes_B, supermesh_shape, stat=lstat, output=intersection(j)) - if (lstat == 1) then - llnode => llnode%next - cycle - end if - assert(continuity(intersection(j)) < 0) + tet_B%V = ele_val(new_positions, ele_B) + planes_B = get_planes(tet_B) else - intersection(j) = intersect_elements(old_positions, ele_A, pos_B, supermesh_shape, empty_intersection) - if (empty_intersection) then - llnode => llnode%next - cycle - end if - assert(continuity(intersection(j)) < 0) + pos_B = ele_val(new_positions, ele_B) end if + j = 1 + + llnode => map_BA%firstnode + do while(associated(llnode)) + ele_A = llnode%value + if (dim == 3) then + tet_A%V = ele_val(old_positions, ele_A) + call intersect_tets(tet_A, planes_B, supermesh_shape, stat=lstat, output=intersection(j)) + if (lstat == 1) then + llnode => llnode%next + cycle + end if + assert(continuity(intersection(j)) < 0) + else + intersection(j) = intersect_elements(old_positions, ele_A, pos_B, supermesh_shape, empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if + assert(continuity(intersection(j)) < 0) + end if + + + if (ele_count(intersection(j)) > 0) then + allocate(intersection(j)%mesh%region_ids(ele_count(intersection(j)))) + intersection(j)%mesh%region_ids = ele_A + j = j + 1 + else + call deallocate(intersection(j)) + end if + + llnode => llnode%next + end do - if (ele_count(intersection(j)) > 0) then - allocate(intersection(j)%mesh%region_ids(ele_count(intersection(j)))) - intersection(j)%mesh%region_ids = ele_A - j = j + 1 - else - call deallocate(intersection(j)) - end if + supermesh = unify_meshes(intersection(1:j-1)) + supermesh%name = "Coordinate" - llnode => llnode%next - end do - - supermesh = unify_meshes(intersection(1:j-1)) - supermesh%name = "Coordinate" - - do i=1,j-1 - deallocate(intersection(i)%mesh%region_ids) - call deallocate(intersection(i)) - end do - call finalise_tet_intersector - - end subroutine construct_supermesh - - subroutine compute_projection_error(old_field, old_positions, supermesh_field_shape, element_value, new_positions, ele_B, supermesh,& - & inversion_matrices_A, inversion_matrix_B, error) - type(scalar_field), intent(in) :: old_field - type(vector_field), intent(in) :: old_positions, new_positions, supermesh - type(element_type), intent(in), target :: supermesh_field_shape - real, dimension(:), intent(in) :: element_value - integer, intent(in) :: ele_B - real, dimension(:, :, :), intent(in) :: inversion_matrices_A - real, dimension(:, :), intent(in) :: inversion_matrix_B - real, intent(out) :: error - - type(mesh_type) :: supermesh_field_mesh - type(scalar_field) :: new_field_on_supermesh, old_field_on_supermesh, projection_error - real, dimension(ele_loc(old_positions, 1), ele_loc(old_positions, 1)) :: inversion_matrix_A - - integer :: ele_C - real, dimension(ele_ngi(supermesh, 1)) :: detwei_C - integer, dimension(:), pointer :: nodes - integer :: node_C, i - - integer :: ele_A - real, dimension(ele_loc(new_positions, ele_B)) :: local_coords - integer :: dim - real :: val - type(vector_field) :: supermesh_positions_remapped - real, dimension(ele_loc(old_field, 1)) :: old_values - - dim = old_positions%dim - - supermesh_field_mesh = make_mesh(supermesh%mesh, supermesh_field_shape, -1, "SupermeshFieldMesh") - call allocate(supermesh_positions_remapped, dim, supermesh_field_mesh, "SupermeshPositionsRemapped") - call remap_field(supermesh, supermesh_positions_remapped) - - call allocate(old_field_on_supermesh, supermesh_field_mesh, "SubmeshField") - call zero(old_field_on_supermesh) - call allocate(new_field_on_supermesh, supermesh_field_mesh, "SubmeshField") - call zero(new_field_on_supermesh) - - do ele_C=1,ele_count(supermesh) - nodes => ele_nodes(old_field_on_supermesh, ele_C) - ele_A = ele_region_id(supermesh, ele_C) - inversion_matrix_A = inversion_matrices_A(:, :, ele_A) - do i=1,size(nodes) - node_C = nodes(i) - - local_coords(1:dim) = node_val(supermesh_positions_remapped, node_C); local_coords(dim+1) = 1.0 - local_coords = matmul(inversion_matrix_A, local_coords) - old_values = ele_val(old_field, ele_A) - val = dot_product(eval_shape(ele_shape(old_field, ele_A), local_coords), old_values) - call set(old_field_on_supermesh, node_C, val) - - local_coords(1:dim) = node_val(supermesh_positions_remapped, node_C); local_coords(dim+1) = 1.0 - local_coords = matmul(inversion_matrix_B, local_coords) - val = dot_product(eval_shape(supermesh_field_shape, local_coords), element_value) - call set(new_field_on_supermesh, node_C, val) + do i=1,j-1 + deallocate(intersection(i)%mesh%region_ids) + call deallocate(intersection(i)) end do - end do - - call deallocate(supermesh_positions_remapped) - - call allocate(projection_error, supermesh_field_mesh, "ProjectionError") - call set(projection_error, new_field_on_supermesh) - call addto(projection_error, old_field_on_supermesh, -1.0) - - error = 0.0 - do ele_C=1,ele_count(supermesh) - call transform_to_physical(supermesh, ele_C, detwei_C) - assert(ele_ngi(supermesh, ele_C) == ele_ngi(projection_error, ele_C)) - error = error + dot_product(ele_val_at_quad(projection_error, ele_C)**2, detwei_C) - end do - - call deallocate(supermesh_field_mesh) - call deallocate(old_field_on_supermesh) - call deallocate(new_field_on_supermesh) - call deallocate(projection_error) - end subroutine compute_projection_error + call finalise_tet_intersector + + end subroutine construct_supermesh + + subroutine compute_projection_error(old_field, old_positions, supermesh_field_shape, element_value, new_positions, ele_B, supermesh,& + & inversion_matrices_A, inversion_matrix_B, error) + type(scalar_field), intent(in) :: old_field + type(vector_field), intent(in) :: old_positions, new_positions, supermesh + type(element_type), intent(in), target :: supermesh_field_shape + real, dimension(:), intent(in) :: element_value + integer, intent(in) :: ele_B + real, dimension(:, :, :), intent(in) :: inversion_matrices_A + real, dimension(:, :), intent(in) :: inversion_matrix_B + real, intent(out) :: error + + type(mesh_type) :: supermesh_field_mesh + type(scalar_field) :: new_field_on_supermesh, old_field_on_supermesh, projection_error + real, dimension(ele_loc(old_positions, 1), ele_loc(old_positions, 1)) :: inversion_matrix_A + + integer :: ele_C + real, dimension(ele_ngi(supermesh, 1)) :: detwei_C + integer, dimension(:), pointer :: nodes + integer :: node_C, i + + integer :: ele_A + real, dimension(ele_loc(new_positions, ele_B)) :: local_coords + integer :: dim + real :: val + type(vector_field) :: supermesh_positions_remapped + real, dimension(ele_loc(old_field, 1)) :: old_values + + dim = old_positions%dim + + supermesh_field_mesh = make_mesh(supermesh%mesh, supermesh_field_shape, -1, "SupermeshFieldMesh") + call allocate(supermesh_positions_remapped, dim, supermesh_field_mesh, "SupermeshPositionsRemapped") + call remap_field(supermesh, supermesh_positions_remapped) + + call allocate(old_field_on_supermesh, supermesh_field_mesh, "SubmeshField") + call zero(old_field_on_supermesh) + call allocate(new_field_on_supermesh, supermesh_field_mesh, "SubmeshField") + call zero(new_field_on_supermesh) + + do ele_C=1,ele_count(supermesh) + nodes => ele_nodes(old_field_on_supermesh, ele_C) + ele_A = ele_region_id(supermesh, ele_C) + inversion_matrix_A = inversion_matrices_A(:, :, ele_A) + do i=1,size(nodes) + node_C = nodes(i) + + local_coords(1:dim) = node_val(supermesh_positions_remapped, node_C); local_coords(dim+1) = 1.0 + local_coords = matmul(inversion_matrix_A, local_coords) + old_values = ele_val(old_field, ele_A) + val = dot_product(eval_shape(ele_shape(old_field, ele_A), local_coords), old_values) + call set(old_field_on_supermesh, node_C, val) + + local_coords(1:dim) = node_val(supermesh_positions_remapped, node_C); local_coords(dim+1) = 1.0 + local_coords = matmul(inversion_matrix_B, local_coords) + val = dot_product(eval_shape(supermesh_field_shape, local_coords), element_value) + call set(new_field_on_supermesh, node_C, val) + end do + end do + + call deallocate(supermesh_positions_remapped) + + call allocate(projection_error, supermesh_field_mesh, "ProjectionError") + call set(projection_error, new_field_on_supermesh) + call addto(projection_error, old_field_on_supermesh, -1.0) + + error = 0.0 + do ele_C=1,ele_count(supermesh) + call transform_to_physical(supermesh, ele_C, detwei_C) + assert(ele_ngi(supermesh, ele_C) == ele_ngi(projection_error, ele_C)) + error = error + dot_product(ele_val_at_quad(projection_error, ele_C)**2, detwei_C) + end do + + call deallocate(supermesh_field_mesh) + call deallocate(old_field_on_supermesh) + call deallocate(new_field_on_supermesh) + call deallocate(projection_error) + end subroutine compute_projection_error end module supermesh_construction diff --git a/femtools/Supermesh_Assembly.F90 b/femtools/Supermesh_Assembly.F90 index 88e41d261f..7662d84282 100644 --- a/femtools/Supermesh_Assembly.F90 +++ b/femtools/Supermesh_Assembly.F90 @@ -29,1038 +29,1038 @@ module supermesh_assembly - use fldebug - use vector_tools, only: solve - use futils, only: present_and_true, present_and_false, int2str - use quadrature - use element_numbering - use elements - use sparse_tools - use linked_lists - use transform_elements - use supermesh_construction - use intersection_finder_module - use fetools, only: shape_rhs, shape_shape - use fields - use state_module - use solvers - use adaptive_interpolation_module - use field_options - use interpolation_module - use state_fields_module - - implicit none - - private - - public :: project_donor_shape_to_supermesh, & - & project_target_shape_to_supermesh, construct_supermesh_ele, & - & extruded_shape_function, generate_supermesh_node_ownership, & - & project_donor_field_to_supermesh, project_target_field_to_supermesh, & - & galerkin_projection_scalars, compute_inner_product_sa - - interface generate_supermesh_local_coords - module procedure generate_supermesh_local_coords_ele, & + use fldebug + use vector_tools, only: solve + use futils, only: present_and_true, present_and_false, int2str + use quadrature + use element_numbering + use elements + use sparse_tools + use linked_lists + use transform_elements + use supermesh_construction + use intersection_finder_module + use fetools, only: shape_rhs, shape_shape + use fields + use state_module + use solvers + use adaptive_interpolation_module + use field_options + use interpolation_module + use state_fields_module + + implicit none + + private + + public :: project_donor_shape_to_supermesh, & + & project_target_shape_to_supermesh, construct_supermesh_ele, & + & extruded_shape_function, generate_supermesh_node_ownership, & + & project_donor_field_to_supermesh, project_target_field_to_supermesh, & + & galerkin_projection_scalars, compute_inner_product_sa + + interface generate_supermesh_local_coords + module procedure generate_supermesh_local_coords_ele, & & generate_supermesh_local_coords_eles - end interface generate_supermesh_local_coords + end interface generate_supermesh_local_coords - interface project_donor_shape_to_supermesh - module procedure project_donor_shape_to_supermesh_mesh, & + interface project_donor_shape_to_supermesh + module procedure project_donor_shape_to_supermesh_mesh, & & project_donor_shape_to_supermesh_shape - end interface project_donor_shape_to_supermesh + end interface project_donor_shape_to_supermesh - interface project_target_shape_to_supermesh - module procedure project_target_shape_to_supermesh_mesh, & + interface project_target_shape_to_supermesh + module procedure project_target_shape_to_supermesh_mesh, & & project_target_shape_to_supermesh_shape - end interface project_target_shape_to_supermesh + end interface project_target_shape_to_supermesh - interface construct_supermesh_dn - module procedure construct_supermesh_dn_ele, construct_supermesh_dn_eles, & + interface construct_supermesh_dn + module procedure construct_supermesh_dn_ele, construct_supermesh_dn_eles, & & construct_supermesh_dn_ele_ele_c - end interface construct_supermesh_dn + end interface construct_supermesh_dn - interface project_donor_field_to_supermesh - module procedure project_donor_field_to_supermesh_scalar - end interface project_donor_field_to_supermesh + interface project_donor_field_to_supermesh + module procedure project_donor_field_to_supermesh_scalar + end interface project_donor_field_to_supermesh - interface project_target_field_to_supermesh - module procedure project_target_field_to_supermesh_scalar - end interface project_target_field_to_supermesh + interface project_target_field_to_supermesh + module procedure project_target_field_to_supermesh_scalar + end interface project_target_field_to_supermesh - interface construct_supermesh_ele - module procedure construct_supermesh_ele_single_state, & + interface construct_supermesh_ele + module procedure construct_supermesh_ele_single_state, & & construct_supermesh_ele_multiple_states - end interface construct_supermesh_ele + end interface construct_supermesh_ele contains - subroutine generate_supermesh_local_coords_ele(ele, positions, positions_c, base_shape_c, & - & l_coords) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: positions_c - type(element_type), intent(in) :: base_shape_c - - real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), ele_count(positions_c)) :: l_coords - - integer :: ele_c - type(mesh_type) :: positions_c_remap_mesh - type(vector_field) :: positions_c_remap - - if(ele_shape(positions_c, ele) == base_shape_c) then - positions_c_remap = positions_c - call incref(positions_c_remap) - else - positions_c_remap_mesh = make_mesh(positions_c%mesh, base_shape_c, continuity = -1, name = "CoordinateRemapMesh") - call allocate(positions_c_remap, positions_c%dim, positions_c_remap_mesh, name = "CoordinateRemap") - call deallocate(positions_c_remap_mesh) - call remap_field(positions_c, positions_c_remap) - end if - - do ele_c = 1, size(l_coords, 3) - l_coords(:, :, ele_c) = local_coords(positions, ele, ele_val_at_quad(positions_c_remap, ele_c)) - end do - - call deallocate(positions_c_remap) - - end subroutine generate_supermesh_local_coords_ele - - subroutine generate_supermesh_local_coords_eles(eles, positions, positions_c, base_shape_c, & - & l_coords) - type(vector_field), intent(in) :: positions_c - integer, dimension(ele_count(positions_c)), intent(in) :: eles - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: base_shape_c - - real, dimension(ele_loc(positions, 1), ele_ngi(positions, 1), ele_count(positions_c)) :: l_coords - - integer :: ele_c - type(mesh_type) :: positions_c_remap_mesh - type(vector_field) :: positions_c_remap - - assert(ele_count(positions_c) > 0) - if(ele_shape(positions_c, 1) == base_shape_c) then - positions_c_remap = positions_c - call incref(positions_c_remap) - else - positions_c_remap_mesh = make_mesh(positions_c%mesh, base_shape_c, continuity = -1, name = "CoordinateRemapMesh") - call allocate(positions_c_remap, positions_c%dim, positions_c_remap_mesh, name = "CoordinateRemap") - call deallocate(positions_c_remap_mesh) - call remap_field(positions_c, positions_c_remap) - end if - - do ele_c = 1, size(l_coords, 3) - l_coords(:, :, ele_c) = local_coords(positions, eles(ele_c), ele_val_at_quad(positions_c_remap, ele_c)) - end do - - call deallocate(positions_c_remap) - - end subroutine generate_supermesh_local_coords_eles - - subroutine project_donor_shape_to_supermesh_mesh(positions_a, shape_mesh, positions_c, & - & shapes_c, form_dn) - type(vector_field), intent(in) :: positions_a - type(mesh_type), intent(in) :: shape_mesh - type(vector_field), intent(in) :: positions_c - type(element_type), dimension(:), allocatable, intent(out) :: shapes_c - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - - assert(ele_count(shape_mesh) > 0) - call project_donor_shape_to_supermesh(positions_a, ele_shape(shape_mesh, 1), positions_c, & + subroutine generate_supermesh_local_coords_ele(ele, positions, positions_c, base_shape_c, & + & l_coords) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: positions_c + type(element_type), intent(in) :: base_shape_c + + real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), ele_count(positions_c)) :: l_coords + + integer :: ele_c + type(mesh_type) :: positions_c_remap_mesh + type(vector_field) :: positions_c_remap + + if(ele_shape(positions_c, ele) == base_shape_c) then + positions_c_remap = positions_c + call incref(positions_c_remap) + else + positions_c_remap_mesh = make_mesh(positions_c%mesh, base_shape_c, continuity = -1, name = "CoordinateRemapMesh") + call allocate(positions_c_remap, positions_c%dim, positions_c_remap_mesh, name = "CoordinateRemap") + call deallocate(positions_c_remap_mesh) + call remap_field(positions_c, positions_c_remap) + end if + + do ele_c = 1, size(l_coords, 3) + l_coords(:, :, ele_c) = local_coords(positions, ele, ele_val_at_quad(positions_c_remap, ele_c)) + end do + + call deallocate(positions_c_remap) + + end subroutine generate_supermesh_local_coords_ele + + subroutine generate_supermesh_local_coords_eles(eles, positions, positions_c, base_shape_c, & + & l_coords) + type(vector_field), intent(in) :: positions_c + integer, dimension(ele_count(positions_c)), intent(in) :: eles + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: base_shape_c + + real, dimension(ele_loc(positions, 1), ele_ngi(positions, 1), ele_count(positions_c)) :: l_coords + + integer :: ele_c + type(mesh_type) :: positions_c_remap_mesh + type(vector_field) :: positions_c_remap + + assert(ele_count(positions_c) > 0) + if(ele_shape(positions_c, 1) == base_shape_c) then + positions_c_remap = positions_c + call incref(positions_c_remap) + else + positions_c_remap_mesh = make_mesh(positions_c%mesh, base_shape_c, continuity = -1, name = "CoordinateRemapMesh") + call allocate(positions_c_remap, positions_c%dim, positions_c_remap_mesh, name = "CoordinateRemap") + call deallocate(positions_c_remap_mesh) + call remap_field(positions_c, positions_c_remap) + end if + + do ele_c = 1, size(l_coords, 3) + l_coords(:, :, ele_c) = local_coords(positions, eles(ele_c), ele_val_at_quad(positions_c_remap, ele_c)) + end do + + call deallocate(positions_c_remap) + + end subroutine generate_supermesh_local_coords_eles + + subroutine project_donor_shape_to_supermesh_mesh(positions_a, shape_mesh, positions_c, & + & shapes_c, form_dn) + type(vector_field), intent(in) :: positions_a + type(mesh_type), intent(in) :: shape_mesh + type(vector_field), intent(in) :: positions_c + type(element_type), dimension(:), allocatable, intent(out) :: shapes_c + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + + assert(ele_count(shape_mesh) > 0) + call project_donor_shape_to_supermesh(positions_a, ele_shape(shape_mesh, 1), positions_c, & & shapes_c, form_dn = form_dn) - end subroutine project_donor_shape_to_supermesh_mesh - - subroutine project_donor_shape_to_supermesh_shape(positions_a, base_shape_c, positions_c, & - & shapes_c, form_dn) - type(vector_field), intent(in) :: positions_a - type(element_type), target, intent(in) :: base_shape_c - type(vector_field), intent(in) :: positions_c - type(element_type), dimension(:), allocatable, intent(out) :: shapes_c - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - - integer :: dim, degree, coords, i, j, loc, ngi - integer, dimension(:), pointer :: eles_a - logical :: lform_dn - real, dimension(ele_loc(positions_a, 1), ele_ngi(positions_a, 1), ele_count(positions_c)) :: l_coords - type(quadrature_type), pointer :: quad - type(ele_numbering_type), pointer :: ele_num - - lform_dn = .not. present_and_false(form_dn) - - eles_a => ele_region_ids(positions_c) - - quad => base_shape_c%quadrature - - dim = base_shape_c%dim - loc = base_shape_c%loc - ngi = quad%ngi - coords = local_coord_count(base_shape_c) - degree = base_shape_c%degree - - if(base_shape_c%degree > 0 .or. lform_dn) then - call generate_supermesh_local_coords(eles_a, positions_a, positions_c, base_shape_c, & - & l_coords) - end if - - allocate(shapes_c(ele_count(positions_c))) - do i = 1, size(shapes_c) - ele_num => find_element_numbering(& - &vertices = base_shape_c%numbering%vertices, & - &dimension = dim, degree =& - & degree) - call allocate(shapes_c(i), ele_num=ele_num, ngi = ngi) - - shapes_c(i)%degree = degree - shapes_c(i)%numbering => find_element_numbering(& + end subroutine project_donor_shape_to_supermesh_mesh + + subroutine project_donor_shape_to_supermesh_shape(positions_a, base_shape_c, positions_c, & + & shapes_c, form_dn) + type(vector_field), intent(in) :: positions_a + type(element_type), target, intent(in) :: base_shape_c + type(vector_field), intent(in) :: positions_c + type(element_type), dimension(:), allocatable, intent(out) :: shapes_c + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + + integer :: dim, degree, coords, i, j, loc, ngi + integer, dimension(:), pointer :: eles_a + logical :: lform_dn + real, dimension(ele_loc(positions_a, 1), ele_ngi(positions_a, 1), ele_count(positions_c)) :: l_coords + type(quadrature_type), pointer :: quad + type(ele_numbering_type), pointer :: ele_num + + lform_dn = .not. present_and_false(form_dn) + + eles_a => ele_region_ids(positions_c) + + quad => base_shape_c%quadrature + + dim = base_shape_c%dim + loc = base_shape_c%loc + ngi = quad%ngi + coords = local_coord_count(base_shape_c) + degree = base_shape_c%degree + + if(base_shape_c%degree > 0 .or. lform_dn) then + call generate_supermesh_local_coords(eles_a, positions_a, positions_c, base_shape_c, & + & l_coords) + end if + + allocate(shapes_c(ele_count(positions_c))) + do i = 1, size(shapes_c) + ele_num => find_element_numbering(& + &vertices = base_shape_c%numbering%vertices, & + &dimension = dim, degree =& + & degree) + call allocate(shapes_c(i), ele_num=ele_num, ngi = ngi) + + shapes_c(i)%degree = degree + shapes_c(i)%numbering => find_element_numbering(& vertices = base_shape_c%numbering%vertices, & dimension = dim, degree = degree) - shapes_c(i)%quadrature = quad - call incref(quad) - - shapes_c(i)%dn = huge(0.0) - assert(.not. associated(shapes_c(i)%dn_s)) - assert(.not. associated(shapes_c(i)%n_s)) - deallocate(shapes_c(i)%spoly) - nullify(shapes_c(i)%spoly) - deallocate(shapes_c(i)%dspoly) - nullify(shapes_c(i)%dspoly) - - select case(base_shape_c%degree) - case(0) - shapes_c(i)%n = 1.0 - case(1) - if(ele_numbering_family(base_shape_c) == FAMILY_SIMPLEX) then - shapes_c(i)%n = l_coords(:, :, i) - else + shapes_c(i)%quadrature = quad + call incref(quad) + + shapes_c(i)%dn = huge(0.0) + assert(.not. associated(shapes_c(i)%dn_s)) + assert(.not. associated(shapes_c(i)%n_s)) + deallocate(shapes_c(i)%spoly) + nullify(shapes_c(i)%spoly) + deallocate(shapes_c(i)%dspoly) + nullify(shapes_c(i)%dspoly) + + select case(base_shape_c%degree) + case(0) + shapes_c(i)%n = 1.0 + case(1) + if(ele_numbering_family(base_shape_c) == FAMILY_SIMPLEX) then + shapes_c(i)%n = l_coords(:, :, i) + else + do j = 1, ngi + shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) + end do + end if + case default do j = 1, ngi - shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) + shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) end do - end if - case default - do j = 1, ngi - shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) - end do - end select - end do - - if(lform_dn) then - call construct_supermesh_dn(eles_a, positions_a, positions_c, l_coords, base_shape_c, shapes_c) - end if - - end subroutine project_donor_shape_to_supermesh_shape - - subroutine project_target_shape_to_supermesh_mesh(ele_b, & - & positions_b, shape_mesh, positions_c, & - & shapes_c, form_dn) - integer, intent(in) :: ele_b - type(vector_field), intent(in) :: positions_b - type(mesh_type), intent(in) :: shape_mesh - type(vector_field), intent(in) :: positions_c - type(element_type), dimension(:), allocatable, intent(out) :: shapes_c - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - - call project_target_shape_to_supermesh(ele_b, & + end select + end do + + if(lform_dn) then + call construct_supermesh_dn(eles_a, positions_a, positions_c, l_coords, base_shape_c, shapes_c) + end if + + end subroutine project_donor_shape_to_supermesh_shape + + subroutine project_target_shape_to_supermesh_mesh(ele_b, & + & positions_b, shape_mesh, positions_c, & + & shapes_c, form_dn) + integer, intent(in) :: ele_b + type(vector_field), intent(in) :: positions_b + type(mesh_type), intent(in) :: shape_mesh + type(vector_field), intent(in) :: positions_c + type(element_type), dimension(:), allocatable, intent(out) :: shapes_c + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + + call project_target_shape_to_supermesh(ele_b, & & positions_b, ele_shape(shape_mesh, ele_b), positions_c, & & shapes_c, form_dn = form_dn) - end subroutine project_target_shape_to_supermesh_mesh - - subroutine project_target_shape_to_supermesh_shape(ele_b, & - & positions_b, base_shape_c, positions_c, & - & shapes_c, form_dn) - integer, intent(in) :: ele_b - type(vector_field), intent(in) :: positions_b - type(element_type), target, intent(in) :: base_shape_c - type(vector_field), intent(in) :: positions_c - type(element_type), dimension(:), allocatable, intent(out) :: shapes_c - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - - integer :: dim, degree, coords, i, j, loc, ngi - logical :: lform_dn - real, dimension(ele_loc(positions_b, ele_b), ele_ngi(positions_b, ele_b), ele_count(positions_c)) :: l_coords - type(quadrature_type), pointer :: quad - type(ele_numbering_type), pointer :: ele_num - - lform_dn = .not. present_and_false(form_dn) - - quad => base_shape_c%quadrature - - dim = base_shape_c%dim - loc = base_shape_c%loc - ngi = quad%ngi - coords = local_coord_count(base_shape_c) - degree = base_shape_c%degree - - if(base_shape_c%degree > 0 .or. lform_dn) then - call generate_supermesh_local_coords(ele_b, positions_b, positions_c, base_shape_c, & - & l_coords) - end if - - allocate(shapes_c(ele_count(positions_c))) - do i = 1, size(shapes_c) - ele_num => find_element_numbering(& - vertices = base_shape_c%numbering%vertices, dimension = dim, degree =& - & degree) - call allocate(shapes_c(i), ele_num, ngi = ngi) - - shapes_c(i)%degree = degree - shapes_c(i)%numbering => find_element_numbering(vertices = base_shape_c%numbering%vertices, dimension = dim, degree = degree) - shapes_c(i)%quadrature = quad - call incref(quad) + end subroutine project_target_shape_to_supermesh_mesh + + subroutine project_target_shape_to_supermesh_shape(ele_b, & + & positions_b, base_shape_c, positions_c, & + & shapes_c, form_dn) + integer, intent(in) :: ele_b + type(vector_field), intent(in) :: positions_b + type(element_type), target, intent(in) :: base_shape_c + type(vector_field), intent(in) :: positions_c + type(element_type), dimension(:), allocatable, intent(out) :: shapes_c + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + + integer :: dim, degree, coords, i, j, loc, ngi + logical :: lform_dn + real, dimension(ele_loc(positions_b, ele_b), ele_ngi(positions_b, ele_b), ele_count(positions_c)) :: l_coords + type(quadrature_type), pointer :: quad + type(ele_numbering_type), pointer :: ele_num + + lform_dn = .not. present_and_false(form_dn) + + quad => base_shape_c%quadrature + + dim = base_shape_c%dim + loc = base_shape_c%loc + ngi = quad%ngi + coords = local_coord_count(base_shape_c) + degree = base_shape_c%degree + + if(base_shape_c%degree > 0 .or. lform_dn) then + call generate_supermesh_local_coords(ele_b, positions_b, positions_c, base_shape_c, & + & l_coords) + end if - shapes_c(i)%dn = huge(0.0) - assert(.not. associated(shapes_c(i)%dn_s)) - assert(.not. associated(shapes_c(i)%n_s)) - deallocate(shapes_c(i)%spoly) - nullify(shapes_c(i)%spoly) - deallocate(shapes_c(i)%dspoly) - nullify(shapes_c(i)%dspoly) - - select case(base_shape_c%degree) - case(0) - shapes_c(i)%n = 1.0 - case(1) - if(ele_numbering_family(base_shape_c) == FAMILY_SIMPLEX) then - shapes_c(i)%n = l_coords(:, :, i) - else + allocate(shapes_c(ele_count(positions_c))) + do i = 1, size(shapes_c) + ele_num => find_element_numbering(& + vertices = base_shape_c%numbering%vertices, dimension = dim, degree =& + & degree) + call allocate(shapes_c(i), ele_num, ngi = ngi) + + shapes_c(i)%degree = degree + shapes_c(i)%numbering => find_element_numbering(vertices = base_shape_c%numbering%vertices, dimension = dim, degree = degree) + shapes_c(i)%quadrature = quad + call incref(quad) + + shapes_c(i)%dn = huge(0.0) + assert(.not. associated(shapes_c(i)%dn_s)) + assert(.not. associated(shapes_c(i)%n_s)) + deallocate(shapes_c(i)%spoly) + nullify(shapes_c(i)%spoly) + deallocate(shapes_c(i)%dspoly) + nullify(shapes_c(i)%dspoly) + + select case(base_shape_c%degree) + case(0) + shapes_c(i)%n = 1.0 + case(1) + if(ele_numbering_family(base_shape_c) == FAMILY_SIMPLEX) then + shapes_c(i)%n = l_coords(:, :, i) + else + do j = 1, ngi + shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) + end do + end if + case default do j = 1, ngi - shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) + shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) end do - end if - case default - do j = 1, ngi - shapes_c(i)%n(:, j) = eval_shape(base_shape_c, l_coords(:, j, i)) - end do - end select - end do + end select + end do - if(lform_dn) then - call construct_supermesh_dn(ele_b, positions_b, positions_c, l_coords, base_shape_c, shapes_c) - end if + if(lform_dn) then + call construct_supermesh_dn(ele_b, positions_b, positions_c, l_coords, base_shape_c, shapes_c) + end if - end subroutine project_target_shape_to_supermesh_shape + end subroutine project_target_shape_to_supermesh_shape + + subroutine construct_supermesh_dn_ele(ele, positions, positions_c, l_coords, base_shape, shapes_c) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: positions_c + real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), ele_count(positions_c)), intent(in) :: l_coords + type(element_type), intent(in) :: base_shape + type(element_type), dimension(ele_count(positions_c)), intent(inout) :: shapes_c + + integer :: i, j, k + real, dimension(positions%dim, positions%dim, ele_ngi(positions, ele)) :: invj + real, dimension(positions_c%dim, positions_c%dim, ele_ngi(positions, ele)) :: j_c + + if(base_shape%degree == 0) then + ! This case is nice and easy + do i = 1, size(shapes_c) + shapes_c(i)%dn = 0.0 + end do + return + end if - subroutine construct_supermesh_dn_ele(ele, positions, positions_c, l_coords, base_shape, shapes_c) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: positions_c - real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), ele_count(positions_c)), intent(in) :: l_coords - type(element_type), intent(in) :: base_shape - type(element_type), dimension(ele_count(positions_c)), intent(inout) :: shapes_c + ! We need to form dn such that a transform_to_physical gives us the + ! transformed shape function derivatives at the quadrature points of the + ! supermesh element. A simple eval_dshape(...) isn't going to cut it, so we: - integer :: i, j, k - real, dimension(positions%dim, positions%dim, ele_ngi(positions, ele)) :: invj - real, dimension(positions_c%dim, positions_c%dim, ele_ngi(positions, ele)) :: j_c + call compute_inverse_jacobian(positions, ele, invj) - if(base_shape%degree == 0) then - ! This case is nice and easy do i = 1, size(shapes_c) - shapes_c(i)%dn = 0.0 + assert(ele_ngi(positions, ele) == ele_ngi(positions_c, i)) + + ! First evaluate the transformed shape function derivatives at the + ! quadrature points of the supermesh element (what we want a + ! transform_to_physical to give us) + do j = 1, size(shapes_c(i)%dn, 2) + shapes_c(i)%dn(:, j, :) = eval_dshape_transformed(base_shape, l_coords(:, j, i), invj) + end do + + ! Then apply the inverse transform on the supermesh element + call compute_jacobian(positions_c, i, j_c) + forall(j = 1:size(shapes_c(i)%dn, 1), k = 1:size(shapes_c(i)%dn, 2)) + shapes_c(i)%dn(j, k, :) = matmul(j_c(:, :, k), shapes_c(i)%dn(j, k, :)) + end forall end do - return - end if - ! We need to form dn such that a transform_to_physical gives us the - ! transformed shape function derivatives at the quadrature points of the - ! supermesh element. A simple eval_dshape(...) isn't going to cut it, so we: + end subroutine construct_supermesh_dn_ele + + subroutine construct_supermesh_dn_eles(eles, positions, positions_c, l_coords, base_shape, shapes_c) + type(vector_field), intent(in) :: positions_c + integer, dimension(ele_count(positions_c)), intent(in) :: eles + type(vector_field), intent(in) :: positions + real, dimension(ele_loc(positions, 1), ele_ngi(positions, 1), ele_count(positions_c)), intent(in) :: l_coords + type(element_type), intent(in) :: base_shape + type(element_type), dimension(ele_count(positions_c)), intent(inout) :: shapes_c + + integer :: ele_c + + do ele_c = 1, size(shapes_c) + call construct_supermesh_dn(eles(ele_c), ele_c, positions, positions_c, l_coords(:, :, ele_c), base_shape, shapes_c(ele_c)) + end do + + end subroutine construct_supermesh_dn_eles + + subroutine construct_supermesh_dn_ele_ele_c(ele, ele_c, positions, positions_c, l_coords, base_shape, shape_c) + integer, intent(in) :: ele + integer, intent(in) :: ele_c + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: positions_c + real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele)), intent(in) :: l_coords + type(element_type), intent(in) :: base_shape + type(element_type), intent(inout) :: shape_c - call compute_inverse_jacobian(positions, ele, invj) + integer :: i, j + real, dimension(positions%dim, positions%dim, ele_ngi(positions, ele)) :: invj + real, dimension(positions_c%dim, positions_c%dim, ele_ngi(positions, ele)) :: j_c - do i = 1, size(shapes_c) - assert(ele_ngi(positions, ele) == ele_ngi(positions_c, i)) + assert(ele_ngi(positions, ele) == ele_ngi(positions_c, ele_c)) + + if(base_shape%degree == 0) then + ! This case is nice and easy + shape_c%dn = 0.0 + return + end if + + ! We need to form dn such that a transform_to_physical gives us the + ! transformed shape function derivatives at the quadrature points of the + ! supermesh element. A simple eval_dshape(...) isn't going to cut it, so we: + + call compute_inverse_jacobian(positions, ele, invj) ! First evaluate the transformed shape function derivatives at the ! quadrature points of the supermesh element (what we want a ! transform_to_physical to give us) - do j = 1, size(shapes_c(i)%dn, 2) - shapes_c(i)%dn(:, j, :) = eval_dshape_transformed(base_shape, l_coords(:, j, i), invj) + do i = 1, size(shape_c%dn, 2) + shape_c%dn(:, i, :) = eval_dshape_transformed(base_shape, l_coords(:, i), invj) end do ! Then apply the inverse transform on the supermesh element - call compute_jacobian(positions_c, i, j_c) - forall(j = 1:size(shapes_c(i)%dn, 1), k = 1:size(shapes_c(i)%dn, 2)) - shapes_c(i)%dn(j, k, :) = matmul(j_c(:, :, k), shapes_c(i)%dn(j, k, :)) + call compute_jacobian(positions_c, ele_c, j_c) + forall(i = 1:size(shape_c%dn, 1), j = 1:size(shape_c%dn, 2)) + shape_c%dn(i, j, :) = matmul(j_c(:, :, j), shape_c%dn(i, j, :)) end forall - end do - - end subroutine construct_supermesh_dn_ele - - subroutine construct_supermesh_dn_eles(eles, positions, positions_c, l_coords, base_shape, shapes_c) - type(vector_field), intent(in) :: positions_c - integer, dimension(ele_count(positions_c)), intent(in) :: eles - type(vector_field), intent(in) :: positions - real, dimension(ele_loc(positions, 1), ele_ngi(positions, 1), ele_count(positions_c)), intent(in) :: l_coords - type(element_type), intent(in) :: base_shape - type(element_type), dimension(ele_count(positions_c)), intent(inout) :: shapes_c - - integer :: ele_c - - do ele_c = 1, size(shapes_c) - call construct_supermesh_dn(eles(ele_c), ele_c, positions, positions_c, l_coords(:, :, ele_c), base_shape, shapes_c(ele_c)) - end do - - end subroutine construct_supermesh_dn_eles - - subroutine construct_supermesh_dn_ele_ele_c(ele, ele_c, positions, positions_c, l_coords, base_shape, shape_c) - integer, intent(in) :: ele - integer, intent(in) :: ele_c - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: positions_c - real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele)), intent(in) :: l_coords - type(element_type), intent(in) :: base_shape - type(element_type), intent(inout) :: shape_c - - integer :: i, j - real, dimension(positions%dim, positions%dim, ele_ngi(positions, ele)) :: invj - real, dimension(positions_c%dim, positions_c%dim, ele_ngi(positions, ele)) :: j_c - - assert(ele_ngi(positions, ele) == ele_ngi(positions_c, ele_c)) - - if(base_shape%degree == 0) then - ! This case is nice and easy - shape_c%dn = 0.0 - return - end if - - ! We need to form dn such that a transform_to_physical gives us the - ! transformed shape function derivatives at the quadrature points of the - ! supermesh element. A simple eval_dshape(...) isn't going to cut it, so we: - - call compute_inverse_jacobian(positions, ele, invj) - - ! First evaluate the transformed shape function derivatives at the - ! quadrature points of the supermesh element (what we want a - ! transform_to_physical to give us) - do i = 1, size(shape_c%dn, 2) - shape_c%dn(:, i, :) = eval_dshape_transformed(base_shape, l_coords(:, i), invj) - end do - - ! Then apply the inverse transform on the supermesh element - call compute_jacobian(positions_c, ele_c, j_c) - forall(i = 1:size(shape_c%dn, 1), j = 1:size(shape_c%dn, 2)) - shape_c%dn(i, j, :) = matmul(j_c(:, :, j), shape_c%dn(i, j, :)) - end forall - - end subroutine construct_supermesh_dn_ele_ele_c - - function extruded_shape_function(ele_surf, ele_vol, positions_surf, positions_vol, shape_surf, shape_vol, & - & form_dn) result(shape_surf_ext) - !!< Extrude a surface shape function - - integer, intent(in) :: ele_surf - integer, intent(in) :: ele_vol - type(vector_field), intent(in) :: positions_surf - type(vector_field), intent(in) :: positions_vol - type(element_type), intent(in) :: shape_surf - type(element_type), target, intent(in) :: shape_vol - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - type(ele_numbering_type), pointer :: ele_num - type(element_type) :: shape_surf_ext - - integer :: coords, degree, dim, i, loc, ngi - real, dimension(positions_vol%dim - 1, ele_ngi(positions_vol, ele_vol)) :: positions_gi_vol - real, dimension(ele_loc(positions_surf, ele_surf), ele_ngi(positions_vol, ele_vol)) :: l_coords - logical :: lform_dn - type(quadrature_type), pointer :: quad - - lform_dn = .not. present_and_false(form_dn) - - quad => shape_vol%quadrature - - dim = positions_vol%dim - loc = shape_surf%loc - ngi = quad%ngi - coords = local_coord_count(shape_vol) - degree = shape_surf%degree - ele_num => & - &find_element_numbering(vertices = shape_surf%numbering%vertices, & - &dimension = dim - 1, degree = degree) - ! Note that the extruded surface mesh shape function takes its number of - ! quadrature points from the volume shape function - call allocate(shape_surf_ext, ele_num=ele_num, ngi = ngi) - shape_surf_ext%degree = degree - shape_surf_ext%numbering => find_element_numbering(vertices = loc, dimension = dim - 1, degree = degree) - shape_surf_ext%quadrature = quad - call incref(quad) - - shape_surf_ext%dn = huge(0.0) - assert(.not. associated(shape_surf_ext%dn_s)) - assert(.not. associated(shape_surf_ext%n_s)) - deallocate(shape_surf_ext%spoly) - nullify(shape_surf_ext%spoly) - deallocate(shape_surf_ext%dspoly) - nullify(shape_surf_ext%dspoly) - - select case(degree) - case(0) - shape_surf_ext%n = 1.0 - case(1) - do i = 1, dim - 1 - positions_gi_vol(i, :) = ele_val_at_quad(positions_vol, ele_vol, i) - end do - l_coords = local_coords(positions_surf, ele_surf, positions_gi_vol) - - if(ele_numbering_family(shape_surf) == FAMILY_SIMPLEX) then - shape_surf_ext%n = l_coords - else - do i = 1, ngi + + end subroutine construct_supermesh_dn_ele_ele_c + + function extruded_shape_function(ele_surf, ele_vol, positions_surf, positions_vol, shape_surf, shape_vol, & + & form_dn) result(shape_surf_ext) + !!< Extrude a surface shape function + + integer, intent(in) :: ele_surf + integer, intent(in) :: ele_vol + type(vector_field), intent(in) :: positions_surf + type(vector_field), intent(in) :: positions_vol + type(element_type), intent(in) :: shape_surf + type(element_type), target, intent(in) :: shape_vol + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + type(ele_numbering_type), pointer :: ele_num + type(element_type) :: shape_surf_ext + + integer :: coords, degree, dim, i, loc, ngi + real, dimension(positions_vol%dim - 1, ele_ngi(positions_vol, ele_vol)) :: positions_gi_vol + real, dimension(ele_loc(positions_surf, ele_surf), ele_ngi(positions_vol, ele_vol)) :: l_coords + logical :: lform_dn + type(quadrature_type), pointer :: quad + + lform_dn = .not. present_and_false(form_dn) + + quad => shape_vol%quadrature + + dim = positions_vol%dim + loc = shape_surf%loc + ngi = quad%ngi + coords = local_coord_count(shape_vol) + degree = shape_surf%degree + ele_num => & + &find_element_numbering(vertices = shape_surf%numbering%vertices, & + &dimension = dim - 1, degree = degree) + ! Note that the extruded surface mesh shape function takes its number of + ! quadrature points from the volume shape function + call allocate(shape_surf_ext, ele_num=ele_num, ngi = ngi) + shape_surf_ext%degree = degree + shape_surf_ext%numbering => find_element_numbering(vertices = loc, dimension = dim - 1, degree = degree) + shape_surf_ext%quadrature = quad + call incref(quad) + + shape_surf_ext%dn = huge(0.0) + assert(.not. associated(shape_surf_ext%dn_s)) + assert(.not. associated(shape_surf_ext%n_s)) + deallocate(shape_surf_ext%spoly) + nullify(shape_surf_ext%spoly) + deallocate(shape_surf_ext%dspoly) + nullify(shape_surf_ext%dspoly) + + select case(degree) + case(0) + shape_surf_ext%n = 1.0 + case(1) + do i = 1, dim - 1 + positions_gi_vol(i, :) = ele_val_at_quad(positions_vol, ele_vol, i) + end do + l_coords = local_coords(positions_surf, ele_surf, positions_gi_vol) + + if(ele_numbering_family(shape_surf) == FAMILY_SIMPLEX) then + shape_surf_ext%n = l_coords + else + do i = 1, ngi + shape_surf_ext%n(:, i) = eval_shape(shape_surf, l_coords(:, i)) + end do + end if + case default + do i = 1, dim - 1 + positions_gi_vol(i, :) = ele_val_at_quad(positions_vol, ele_vol, i) + end do + l_coords = local_coords(positions_surf, ele_surf, positions_gi_vol) + + do i = 1, ngi shape_surf_ext%n(:, i) = eval_shape(shape_surf, l_coords(:, i)) - end do - end if - case default - do i = 1, dim - 1 - positions_gi_vol(i, :) = ele_val_at_quad(positions_vol, ele_vol, i) - end do - l_coords = local_coords(positions_surf, ele_surf, positions_gi_vol) - - do i = 1, ngi - shape_surf_ext%n(:, i) = eval_shape(shape_surf, l_coords(:, i)) - end do - end select - - if(lform_dn) then - FLAbort("Shape function derivative extrude not yet available") - end if - - end function extruded_shape_function - - subroutine generate_supermesh_node_ownership(positions_c, mesh_c, map) - type(vector_field), intent(in) :: positions_c - type(mesh_type), intent(in) :: mesh_c - integer, dimension(:), allocatable, intent(out) :: map - - integer :: i - - assert(ele_count(mesh_c) > 0) - allocate(map(ele_count(mesh_c) * ele_loc(mesh_c, 1))) - do i = 1, ele_count(mesh_c) - map(ele_nodes(mesh_c, i)) = ele_region_id(positions_c, i) - end do - - end subroutine generate_supermesh_node_ownership - - function project_donor_field_to_supermesh_scalar(positions_a, positions_c, field_a) result(field_a_c) - !!< Project a donor field onto the supermesh - - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_c - type(scalar_field), intent(in) :: field_a - - type(scalar_field) :: field_a_c - - integer, dimension(:), allocatable :: map - type(mesh_type) :: mesh_a_c - type(vector_field) :: positions_c_remap - - ! Allocate the supermesh field - assert(ele_count(field_a) > 0) - mesh_a_c = make_mesh(positions_c%mesh, ele_shape(field_a, 1), continuity = -1) - call allocate(field_a_c, mesh_a_c, name = trim(field_a%name) // "Supermesh") - call deallocate(mesh_a_c) - - ! Generate the map from nodes in the supermesh field to elements in the - ! donor field - call generate_supermesh_node_ownership(positions_c, mesh_a_c, map) - - ! We need the "target" positions handed to linear_interpolation to share its - ! mesh with the supermesh field - if(positions_c%mesh == mesh_a_c) then - positions_c_remap = positions_c - call incref(positions_c_remap) - else - call allocate(positions_c_remap, positions_c%dim, mesh_a_c, name = "CoordinateRemap") - call remap_field(positions_c, positions_c_remap) - end if - - ! Project - consistent interpolation onto the supermesh is lossless - call linear_interpolation(field_a, positions_a, field_a_c, positions_c_remap, map = map) - - ! Cleanup - deallocate(map) - call deallocate(positions_c_remap) - - end function project_donor_field_to_supermesh_scalar - - function project_target_field_to_supermesh_scalar(ele_b, positions_b, positions_c, field_b) result(field_b_c) - !!< Project a target field onto the supermesh - - integer, intent(in) :: ele_b - type(vector_field), intent(in) :: positions_b - type(vector_field), intent(in) :: positions_c - type(scalar_field), intent(in) :: field_b - - type(scalar_field) :: field_b_c - - type(mesh_type) :: mesh_b_c - type(vector_field) :: positions_c_remap - - ! Allocate the supermesh field - assert(ele_count(field_b) > 0) - mesh_b_c = make_mesh(positions_c%mesh, ele_shape(field_b, 1), continuity = -1) - call allocate(field_b_c, mesh_b_c, name = trim(field_b%name) // "Supermesh") - call deallocate(mesh_b_c) - - ! We need the "target" positions handed to linear_interpolation to share its - ! mesh with the supermesh field - if(positions_c%mesh == mesh_b_c) then - positions_c_remap = positions_c - call incref(positions_c_remap) - else - call allocate(positions_c_remap, positions_c%dim, mesh_b_c, name = "CoordinateRemap") - call remap_field(positions_c, positions_c_remap) - end if - - ! Project - consistent interpolation onto the supermesh is lossless - assert(ele_count(mesh_b_c) > 0) - call linear_interpolation(field_b, positions_b, field_b_c, positions_c_remap, map = spread(ele_b, 1, ele_count(mesh_b_c) * ele_loc(mesh_b_c, 1))) - - ! Cleanup - call deallocate(positions_c_remap) - - end function project_target_field_to_supermesh_scalar - - subroutine construct_supermesh_ele_single_state(ele_b, positions_a, positions_b, map_ba, & - & state_a, shape_mesh_b, & - & state_c, positions_c, shapes_c, & - & form_dn, single_mesh_state) - integer, intent(in) :: ele_b - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - type(ilist), intent(in) :: map_ba - type(state_type), intent(in) :: state_a - type(mesh_type), intent(in) :: shape_mesh_b - type(state_type), intent(out) :: state_c - type(vector_field), intent(out) :: positions_c - type(element_type), dimension(:), allocatable, intent(out) :: shapes_c - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - ! If present and .true., assume state_a contains fields all on the same mesh - logical, optional, intent(in) :: single_mesh_state - - type(state_type), dimension(1) :: states_a, states_c - - states_a = (/state_a/) - call construct_supermesh_ele(ele_b, positions_a, positions_b, map_ba, & + end do + end select + + if(lform_dn) then + FLAbort("Shape function derivative extrude not yet available") + end if + + end function extruded_shape_function + + subroutine generate_supermesh_node_ownership(positions_c, mesh_c, map) + type(vector_field), intent(in) :: positions_c + type(mesh_type), intent(in) :: mesh_c + integer, dimension(:), allocatable, intent(out) :: map + + integer :: i + + assert(ele_count(mesh_c) > 0) + allocate(map(ele_count(mesh_c) * ele_loc(mesh_c, 1))) + do i = 1, ele_count(mesh_c) + map(ele_nodes(mesh_c, i)) = ele_region_id(positions_c, i) + end do + + end subroutine generate_supermesh_node_ownership + + function project_donor_field_to_supermesh_scalar(positions_a, positions_c, field_a) result(field_a_c) + !!< Project a donor field onto the supermesh + + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_c + type(scalar_field), intent(in) :: field_a + + type(scalar_field) :: field_a_c + + integer, dimension(:), allocatable :: map + type(mesh_type) :: mesh_a_c + type(vector_field) :: positions_c_remap + + ! Allocate the supermesh field + assert(ele_count(field_a) > 0) + mesh_a_c = make_mesh(positions_c%mesh, ele_shape(field_a, 1), continuity = -1) + call allocate(field_a_c, mesh_a_c, name = trim(field_a%name) // "Supermesh") + call deallocate(mesh_a_c) + + ! Generate the map from nodes in the supermesh field to elements in the + ! donor field + call generate_supermesh_node_ownership(positions_c, mesh_a_c, map) + + ! We need the "target" positions handed to linear_interpolation to share its + ! mesh with the supermesh field + if(positions_c%mesh == mesh_a_c) then + positions_c_remap = positions_c + call incref(positions_c_remap) + else + call allocate(positions_c_remap, positions_c%dim, mesh_a_c, name = "CoordinateRemap") + call remap_field(positions_c, positions_c_remap) + end if + + ! Project - consistent interpolation onto the supermesh is lossless + call linear_interpolation(field_a, positions_a, field_a_c, positions_c_remap, map = map) + + ! Cleanup + deallocate(map) + call deallocate(positions_c_remap) + + end function project_donor_field_to_supermesh_scalar + + function project_target_field_to_supermesh_scalar(ele_b, positions_b, positions_c, field_b) result(field_b_c) + !!< Project a target field onto the supermesh + + integer, intent(in) :: ele_b + type(vector_field), intent(in) :: positions_b + type(vector_field), intent(in) :: positions_c + type(scalar_field), intent(in) :: field_b + + type(scalar_field) :: field_b_c + + type(mesh_type) :: mesh_b_c + type(vector_field) :: positions_c_remap + + ! Allocate the supermesh field + assert(ele_count(field_b) > 0) + mesh_b_c = make_mesh(positions_c%mesh, ele_shape(field_b, 1), continuity = -1) + call allocate(field_b_c, mesh_b_c, name = trim(field_b%name) // "Supermesh") + call deallocate(mesh_b_c) + + ! We need the "target" positions handed to linear_interpolation to share its + ! mesh with the supermesh field + if(positions_c%mesh == mesh_b_c) then + positions_c_remap = positions_c + call incref(positions_c_remap) + else + call allocate(positions_c_remap, positions_c%dim, mesh_b_c, name = "CoordinateRemap") + call remap_field(positions_c, positions_c_remap) + end if + + ! Project - consistent interpolation onto the supermesh is lossless + assert(ele_count(mesh_b_c) > 0) + call linear_interpolation(field_b, positions_b, field_b_c, positions_c_remap, map = spread(ele_b, 1, ele_count(mesh_b_c) * ele_loc(mesh_b_c, 1))) + + ! Cleanup + call deallocate(positions_c_remap) + + end function project_target_field_to_supermesh_scalar + + subroutine construct_supermesh_ele_single_state(ele_b, positions_a, positions_b, map_ba, & + & state_a, shape_mesh_b, & + & state_c, positions_c, shapes_c, & + & form_dn, single_mesh_state) + integer, intent(in) :: ele_b + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + type(ilist), intent(in) :: map_ba + type(state_type), intent(in) :: state_a + type(mesh_type), intent(in) :: shape_mesh_b + type(state_type), intent(out) :: state_c + type(vector_field), intent(out) :: positions_c + type(element_type), dimension(:), allocatable, intent(out) :: shapes_c + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + ! If present and .true., assume state_a contains fields all on the same mesh + logical, optional, intent(in) :: single_mesh_state + + type(state_type), dimension(1) :: states_a, states_c + + states_a = (/state_a/) + call construct_supermesh_ele(ele_b, positions_a, positions_b, map_ba, & & states_a, shape_mesh_b, & & states_c, positions_c, shapes_c, & & form_dn = form_dn, mesh_sorted_states = single_mesh_state) - state_c = states_c(1) - - end subroutine construct_supermesh_ele_single_state - - subroutine construct_supermesh_ele_multiple_states(ele_b, positions_a, positions_b, map_ba, & - & states_a, shape_mesh_b, & - & states_c, positions_c, shapes_c, & - & form_dn, mesh_sorted_states) - integer, intent(in) :: ele_b - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - type(ilist), intent(in) :: map_ba - type(state_type), dimension(:), intent(in) :: states_a - type(mesh_type), intent(in) :: shape_mesh_b - type(state_type), dimension(size(states_a)), intent(out) :: states_c - type(vector_field), intent(out) :: positions_c - type(element_type), dimension(:), allocatable, intent(out) :: shapes_c - ! If present and .false., do not form the shape function derivatives - logical, optional, intent(in) :: form_dn - ! If present and .true., assume states_a is sorted by meshes - logical, optional, intent(in) :: mesh_sorted_states - - integer :: i, j, stat - integer, dimension(:), allocatable :: map - type(element_type), pointer :: shape_c - type(mesh_type) :: mesh_c - type(mesh_type), pointer :: mesh_a - type(scalar_field), pointer :: s_field_a - type(scalar_field) :: s_field_c - type(state_type), dimension(:), allocatable :: sorted_states_a, sorted_states_c - type(tensor_field), pointer :: t_field_a - type(tensor_field) :: t_field_c - type(vector_field), pointer :: v_field_a - type(vector_field) :: v_field_c - - ! Supermesh - shape_c => ele_shape(positions_b, ele_b) - call construct_supermesh(positions_b, ele_b, positions_a, map_ba, shape_c, positions_c) - call insert(states_c, positions_c, "Coordinate") - call insert(states_c, positions_c%mesh, "CoordinateMesh") - - ! Generate the supermesh shape functions. These are the shape functions of - ! the target mesh projected onto the supermesh. - call project_target_shape_to_supermesh(ele_b, & + state_c = states_c(1) + + end subroutine construct_supermesh_ele_single_state + + subroutine construct_supermesh_ele_multiple_states(ele_b, positions_a, positions_b, map_ba, & + & states_a, shape_mesh_b, & + & states_c, positions_c, shapes_c, & + & form_dn, mesh_sorted_states) + integer, intent(in) :: ele_b + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + type(ilist), intent(in) :: map_ba + type(state_type), dimension(:), intent(in) :: states_a + type(mesh_type), intent(in) :: shape_mesh_b + type(state_type), dimension(size(states_a)), intent(out) :: states_c + type(vector_field), intent(out) :: positions_c + type(element_type), dimension(:), allocatable, intent(out) :: shapes_c + ! If present and .false., do not form the shape function derivatives + logical, optional, intent(in) :: form_dn + ! If present and .true., assume states_a is sorted by meshes + logical, optional, intent(in) :: mesh_sorted_states + + integer :: i, j, stat + integer, dimension(:), allocatable :: map + type(element_type), pointer :: shape_c + type(mesh_type) :: mesh_c + type(mesh_type), pointer :: mesh_a + type(scalar_field), pointer :: s_field_a + type(scalar_field) :: s_field_c + type(state_type), dimension(:), allocatable :: sorted_states_a, sorted_states_c + type(tensor_field), pointer :: t_field_a + type(tensor_field) :: t_field_c + type(vector_field), pointer :: v_field_a + type(vector_field) :: v_field_c + + ! Supermesh + shape_c => ele_shape(positions_b, ele_b) + call construct_supermesh(positions_b, ele_b, positions_a, map_ba, shape_c, positions_c) + call insert(states_c, positions_c, "Coordinate") + call insert(states_c, positions_c%mesh, "CoordinateMesh") + + ! Generate the supermesh shape functions. These are the shape functions of + ! the target mesh projected onto the supermesh. + call project_target_shape_to_supermesh(ele_b, & & positions_b, shape_mesh_b, positions_c, & & shapes_c, form_dn = form_dn) - ! Generate the supermesh fields. These are the fields of the donor mesh - ! projected onto the supermesh. - if(present_and_true(mesh_sorted_states)) then - do i = 1, size(states_a) - mesh_a => single_state_mesh(states_a(i), stat = stat) - if(stat /= 0) cycle - - assert(ele_count(mesh_a) > 0) - shape_c => ele_shape(mesh_a, 1) - mesh_c = make_mesh(positions_c%mesh, shape_c, continuity = -1, name = mesh_a%name) - call insert(states_c(i), mesh_c, mesh_c%name) - - do j = 1, scalar_field_count(states_a(i)) - s_field_a => extract_scalar_field(states_a(i), j) - ! We set all fields to have type FIELD_TYPE_NORMAL to keep the - ! interpolation routines happy. Alternatively, we could modify the - ! linear interpolation code to handle FIELD_TYPE_CONSTANT fields. - call allocate(s_field_c, mesh_c, s_field_a%name, field_type = FIELD_TYPE_NORMAL) - call insert(states_c(i), s_field_c, s_field_c%name) - call deallocate(s_field_c) - end do - - do j = 1, vector_field_count(states_a(i)) - v_field_a => extract_vector_field(states_a(i), j) - if(trim(v_field_a%name) == "Coordinate") cycle - call allocate(v_field_c, v_field_a%dim, mesh_c, v_field_a%name, field_type = FIELD_TYPE_NORMAL) - call insert(states_c(i), v_field_c, v_field_c%name) - call deallocate(v_field_c) - end do - - do j = 1, tensor_field_count(states_a(i)) - t_field_a => extract_tensor_field(states_a(i), j) - call allocate(t_field_c, mesh_c, t_field_a%name, field_type = FIELD_TYPE_NORMAL) - call insert(states_c(i), t_field_c, t_field_c%name) - call deallocate(t_field_c) - end do - - call generate_supermesh_node_ownership(positions_c, mesh_c, map) - call linear_interpolation(states_a(i), states_c(i), map = map) - deallocate(map) - - call deallocate(mesh_c) - end do - else - do i = 1, size(states_a) - do j = 1, mesh_count(states_a(i)) - mesh_a => extract_mesh(states_a(i), j) - assert(ele_count(mesh_a) > 0) - shape_c => ele_shape(mesh_a, 1) - mesh_c = make_mesh(positions_c%mesh, shape_c, continuity = -1, name = mesh_a%name) - call insert(states_c(i), mesh_c, mesh_c%name) - call deallocate(mesh_c) - end do - - do j = 1, scalar_field_count(states_a(i)) - s_field_a => extract_scalar_field(states_a(i), j) - mesh_c = extract_mesh(states_c(i), s_field_a%mesh%name) - call allocate(s_field_c, mesh_c, s_field_a%name, field_type = FIELD_TYPE_NORMAL) - call insert(states_c(i), s_field_c, s_field_c%name) - call deallocate(s_field_c) - end do - - do j = 1, vector_field_count(states_a(i)) - v_field_a => extract_vector_field(states_a(i), j) - if(trim(v_field_a%name) == "Coordinate") cycle - mesh_c = extract_mesh(states_c(i), v_field_a%mesh%name) - call allocate(v_field_c, v_field_a%dim, mesh_c, v_field_a%name, field_type = FIELD_TYPE_NORMAL) - call insert(states_c(i), v_field_c, v_field_c%name) - call deallocate(v_field_c) - end do - - do j = 1, tensor_field_count(states_a(i)) - t_field_a => extract_tensor_field(states_a(i), j) - mesh_c = extract_mesh(states_c(i), t_field_a%mesh%name) - call allocate(t_field_c, mesh_c, t_field_a%name, field_type = FIELD_TYPE_NORMAL) - call insert(states_c(i), t_field_c, t_field_c%name) - call deallocate(t_field_c) - end do - end do + ! Generate the supermesh fields. These are the fields of the donor mesh + ! projected onto the supermesh. + if(present_and_true(mesh_sorted_states)) then + do i = 1, size(states_a) + mesh_a => single_state_mesh(states_a(i), stat = stat) + if(stat /= 0) cycle + + assert(ele_count(mesh_a) > 0) + shape_c => ele_shape(mesh_a, 1) + mesh_c = make_mesh(positions_c%mesh, shape_c, continuity = -1, name = mesh_a%name) + call insert(states_c(i), mesh_c, mesh_c%name) + + do j = 1, scalar_field_count(states_a(i)) + s_field_a => extract_scalar_field(states_a(i), j) + ! We set all fields to have type FIELD_TYPE_NORMAL to keep the + ! interpolation routines happy. Alternatively, we could modify the + ! linear interpolation code to handle FIELD_TYPE_CONSTANT fields. + call allocate(s_field_c, mesh_c, s_field_a%name, field_type = FIELD_TYPE_NORMAL) + call insert(states_c(i), s_field_c, s_field_c%name) + call deallocate(s_field_c) + end do - call sort_states_by_mesh(states_a, sorted_states_a) - call sort_states_by_mesh(states_c, sorted_states_c) + do j = 1, vector_field_count(states_a(i)) + v_field_a => extract_vector_field(states_a(i), j) + if(trim(v_field_a%name) == "Coordinate") cycle + call allocate(v_field_c, v_field_a%dim, mesh_c, v_field_a%name, field_type = FIELD_TYPE_NORMAL) + call insert(states_c(i), v_field_c, v_field_c%name) + call deallocate(v_field_c) + end do - do i = 1, size(sorted_states_c) - mesh_c = single_state_mesh(sorted_states_c(i), stat = stat) - if(stat == 0) then - call generate_supermesh_node_ownership(positions_c, mesh_c, map) - call linear_interpolation(sorted_states_a(i), sorted_states_c(i), map = map) - deallocate(map) - end if + do j = 1, tensor_field_count(states_a(i)) + t_field_a => extract_tensor_field(states_a(i), j) + call allocate(t_field_c, mesh_c, t_field_a%name, field_type = FIELD_TYPE_NORMAL) + call insert(states_c(i), t_field_c, t_field_c%name) + call deallocate(t_field_c) + end do - call deallocate(sorted_states_a(i)) - call deallocate(sorted_states_c(i)) - end do + call generate_supermesh_node_ownership(positions_c, mesh_c, map) + call linear_interpolation(states_a(i), states_c(i), map = map) + deallocate(map) - deallocate(sorted_states_a) - deallocate(sorted_states_c) - end if - - end subroutine construct_supermesh_ele_multiple_states - - function single_state_mesh(state, stat) result(mesh) - type(state_type), intent(in) :: state - integer, optional, intent(out) :: stat - - type(mesh_type), pointer :: mesh - - type(scalar_field), pointer :: s_field - type(vector_field), pointer :: v_field - type(tensor_field), pointer :: t_field - - if(present(stat)) stat = 0 - - if(scalar_field_count(state) > 0) then - s_field => extract_scalar_field(state, 1) - mesh => s_field%mesh - else if(vector_field_count(state) > 0) then - v_field => extract_vector_field(state, 1) - mesh => v_field%mesh - else if(tensor_field_count(state) > 0) then - t_field => extract_tensor_field(state, 1) - mesh => t_field%mesh - else - if(present(stat)) then - stat = 1 - return + call deallocate(mesh_c) + end do else - ewrite(-1, *) "For state " // trim(state%name) - FLAbort("No mesh found") + do i = 1, size(states_a) + do j = 1, mesh_count(states_a(i)) + mesh_a => extract_mesh(states_a(i), j) + assert(ele_count(mesh_a) > 0) + shape_c => ele_shape(mesh_a, 1) + mesh_c = make_mesh(positions_c%mesh, shape_c, continuity = -1, name = mesh_a%name) + call insert(states_c(i), mesh_c, mesh_c%name) + call deallocate(mesh_c) + end do + + do j = 1, scalar_field_count(states_a(i)) + s_field_a => extract_scalar_field(states_a(i), j) + mesh_c = extract_mesh(states_c(i), s_field_a%mesh%name) + call allocate(s_field_c, mesh_c, s_field_a%name, field_type = FIELD_TYPE_NORMAL) + call insert(states_c(i), s_field_c, s_field_c%name) + call deallocate(s_field_c) + end do + + do j = 1, vector_field_count(states_a(i)) + v_field_a => extract_vector_field(states_a(i), j) + if(trim(v_field_a%name) == "Coordinate") cycle + mesh_c = extract_mesh(states_c(i), v_field_a%mesh%name) + call allocate(v_field_c, v_field_a%dim, mesh_c, v_field_a%name, field_type = FIELD_TYPE_NORMAL) + call insert(states_c(i), v_field_c, v_field_c%name) + call deallocate(v_field_c) + end do + + do j = 1, tensor_field_count(states_a(i)) + t_field_a => extract_tensor_field(states_a(i), j) + mesh_c = extract_mesh(states_c(i), t_field_a%mesh%name) + call allocate(t_field_c, mesh_c, t_field_a%name, field_type = FIELD_TYPE_NORMAL) + call insert(states_c(i), t_field_c, t_field_c%name) + call deallocate(t_field_c) + end do + end do + + call sort_states_by_mesh(states_a, sorted_states_a) + call sort_states_by_mesh(states_c, sorted_states_c) + + do i = 1, size(sorted_states_c) + mesh_c = single_state_mesh(sorted_states_c(i), stat = stat) + if(stat == 0) then + call generate_supermesh_node_ownership(positions_c, mesh_c, map) + call linear_interpolation(sorted_states_a(i), sorted_states_c(i), map = map) + deallocate(map) + end if + + call deallocate(sorted_states_a(i)) + call deallocate(sorted_states_c(i)) + end do + + deallocate(sorted_states_a) + deallocate(sorted_states_c) + end if + + end subroutine construct_supermesh_ele_multiple_states + + function single_state_mesh(state, stat) result(mesh) + type(state_type), intent(in) :: state + integer, optional, intent(out) :: stat + + type(mesh_type), pointer :: mesh + + type(scalar_field), pointer :: s_field + type(vector_field), pointer :: v_field + type(tensor_field), pointer :: t_field + + if(present(stat)) stat = 0 + + if(scalar_field_count(state) > 0) then + s_field => extract_scalar_field(state, 1) + mesh => s_field%mesh + else if(vector_field_count(state) > 0) then + v_field => extract_vector_field(state, 1) + mesh => v_field%mesh + else if(tensor_field_count(state) > 0) then + t_field => extract_tensor_field(state, 1) + mesh => t_field%mesh + else + if(present(stat)) then + stat = 1 + return + else + ewrite(-1, *) "For state " // trim(state%name) + FLAbort("No mesh found") + end if end if - end if - - end function single_state_mesh - - subroutine galerkin_projection_scalars(states_a, positions_a, states_b, positions_b) - type(state_type), dimension(:), intent(in) :: states_a - type(vector_field), intent(in) :: positions_a - type(state_type), dimension(size(states_a)), intent(inout) :: states_b - type(vector_field), intent(in) :: positions_b - - integer :: ele_b, ele_c, field_count, i, j - type(csr_matrix), pointer :: mass_matrix - type(element_type), dimension(:), allocatable :: shapes_c - type(ilist), dimension(ele_count(positions_b)) :: map_ba - type(mesh_type), pointer :: mesh_b - type(scalar_field), dimension(:), allocatable :: rhs - type(scalar_field), pointer :: s_field_b - type(state_type) :: state_c - type(vector_field) :: positions_c - - call intersector_set_dimension(positions_b%dim) - - map_ba = intersection_finder(positions_b, positions_a) - - do i = 1, size(states_b) - field_count = scalar_field_count(states_b(i)) - if(field_count == 0) cycle - - s_field_b => extract_scalar_field(states_b(i), 1) - mesh_b => s_field_b%mesh - - select case(mesh_b%continuity) - case(0) - mass_matrix => get_mass_matrix(states_b(i), mesh_b) - allocate(rhs(scalar_field_count(states_b(i)))) - do j = 1, field_count - call allocate(rhs(j), mesh_b, "GalerkinProjectionRHS" // int2str(j)) - call zero(rhs(j)) - end do - - do ele_b = 1, ele_count(positions_b) - call construct_supermesh_ele(ele_b, positions_a, positions_b, map_ba(ele_b), & - & states_a(i), mesh_b, & - & state_c, positions_c, shapes_c, & - & form_dn = .false., single_mesh_state = .true.) - - do ele_c = 1, ele_count(positions_c) - call assemble_galerkin_projection_scalars_ele(ele_c, ele_b, positions_c, state_c, shapes_c(ele_c), rhs) + + end function single_state_mesh + + subroutine galerkin_projection_scalars(states_a, positions_a, states_b, positions_b) + type(state_type), dimension(:), intent(in) :: states_a + type(vector_field), intent(in) :: positions_a + type(state_type), dimension(size(states_a)), intent(inout) :: states_b + type(vector_field), intent(in) :: positions_b + + integer :: ele_b, ele_c, field_count, i, j + type(csr_matrix), pointer :: mass_matrix + type(element_type), dimension(:), allocatable :: shapes_c + type(ilist), dimension(ele_count(positions_b)) :: map_ba + type(mesh_type), pointer :: mesh_b + type(scalar_field), dimension(:), allocatable :: rhs + type(scalar_field), pointer :: s_field_b + type(state_type) :: state_c + type(vector_field) :: positions_c + + call intersector_set_dimension(positions_b%dim) + + map_ba = intersection_finder(positions_b, positions_a) + + do i = 1, size(states_b) + field_count = scalar_field_count(states_b(i)) + if(field_count == 0) cycle + + s_field_b => extract_scalar_field(states_b(i), 1) + mesh_b => s_field_b%mesh + + select case(mesh_b%continuity) + case(0) + mass_matrix => get_mass_matrix(states_b(i), mesh_b) + allocate(rhs(scalar_field_count(states_b(i)))) + do j = 1, field_count + call allocate(rhs(j), mesh_b, "GalerkinProjectionRHS" // int2str(j)) + call zero(rhs(j)) end do - call deallocate(state_c) - call deallocate(positions_c) - do j = 1, size(shapes_c) - call deallocate(shapes_c(j)) + do ele_b = 1, ele_count(positions_b) + call construct_supermesh_ele(ele_b, positions_a, positions_b, map_ba(ele_b), & + & states_a(i), mesh_b, & + & state_c, positions_c, shapes_c, & + & form_dn = .false., single_mesh_state = .true.) + + do ele_c = 1, ele_count(positions_c) + call assemble_galerkin_projection_scalars_ele(ele_c, ele_b, positions_c, state_c, shapes_c(ele_c), rhs) + end do + + call deallocate(state_c) + call deallocate(positions_c) + do j = 1, size(shapes_c) + call deallocate(shapes_c(j)) + end do + deallocate(shapes_c) end do - deallocate(shapes_c) - end do - - do j = 1, field_count - s_field_b => extract_scalar_field(states_b(i), j) - call petsc_solve(s_field_b, mass_matrix, rhs(j), & - & option_path = trim(complete_field_path(s_field_b%option_path)) // "/galerkin_projection/continuous") - - call deallocate(rhs(j)) - end do - deallocate(rhs) - case(-1) - do ele_b = 1, ele_count(positions_b) - call construct_supermesh_ele(ele_b, positions_a, positions_b, map_ba(ele_b), & - & states_a(i), mesh_b, & - & state_c, positions_c, shapes_c, & - & form_dn = .false., single_mesh_state = .true.) - - call solve_galerkin_projection_scalars_dg_ele(ele_b, positions_b, positions_c, mesh_b, states_b(i), state_c, shapes_c) - - call deallocate(state_c) - call deallocate(positions_c) - do j = 1, size(shapes_c) - call deallocate(shapes_c(j)) + + do j = 1, field_count + s_field_b => extract_scalar_field(states_b(i), j) + call petsc_solve(s_field_b, mass_matrix, rhs(j), & + & option_path = trim(complete_field_path(s_field_b%option_path)) // "/galerkin_projection/continuous") + + call deallocate(rhs(j)) end do - deallocate(shapes_c) - end do - case default - ewrite(-1, "(a,i0)") "For mesh continuity ", mesh_b%continuity - FLAbort("Unrecognised mesh continuity") - end select - end do - - do i = 1, size(map_ba) - call deallocate(map_ba(i)) - end do - - end subroutine galerkin_projection_scalars - - subroutine assemble_galerkin_projection_scalars_ele(ele, ele_out, positions, state, shape, rhs) - integer, intent(in) :: ele - integer, intent(in) :: ele_out - type(vector_field), intent(in) :: positions - type(state_type), intent(in) :: state - type(element_type), intent(in) :: shape - type(scalar_field), intent(inout), dimension(:) :: rhs - - integer :: field - real, dimension(ele_ngi(positions, ele)) :: detwei - type(scalar_field), pointer :: s_field - - assert(size(rhs) == scalar_field_count(state)) - - call transform_to_physical(positions, ele, detwei = detwei) - do field = 1, size(rhs) - s_field => extract_scalar_field(state, field) - call addto(rhs(field), ele_nodes(rhs(field), ele_out), & - & shape_rhs(shape, detwei * ele_val_at_quad(s_field, ele))) - end do - - end subroutine assemble_galerkin_projection_scalars_ele - - subroutine solve_galerkin_projection_scalars_dg_ele(ele_b, positions_b, positions_c, mesh_b, state_b, state_c, shapes_c) - integer, intent(in) :: ele_b - type(vector_field), intent(in) :: positions_b - type(vector_field), intent(in) :: positions_c - type(mesh_type), intent(in) :: mesh_b - type(state_type), intent(in) :: state_b - type(state_type), intent(in) :: state_c - type(element_type), dimension(ele_count(positions_c)), intent(in) :: shapes_c - - integer :: i, j - real, dimension(ele_loc(mesh_b, ele_b), scalar_field_count(state_c)) :: little_rhs - real, dimension(ele_ngi(positions_b, ele_b)) :: detwei - real, dimension(ele_loc(mesh_b, ele_b), ele_loc(mesh_b, ele_b)) :: little_mass - type(scalar_field), pointer :: s_field_b - - call transform_to_physical(positions_b, ele_b, detwei = detwei) - - little_mass = shape_shape(ele_shape(mesh_b, ele_b), ele_shape(mesh_b, ele_b), detwei) - little_rhs = 0.0 - do i = 1, scalar_field_count(state_b) - do j = 1, ele_count(positions_c) - call assemble_galerkin_projection_scalars_dg_ele(j, positions_c, state_c, shapes_c(j), little_rhs) + deallocate(rhs) + case(-1) + do ele_b = 1, ele_count(positions_b) + call construct_supermesh_ele(ele_b, positions_a, positions_b, map_ba(ele_b), & + & states_a(i), mesh_b, & + & state_c, positions_c, shapes_c, & + & form_dn = .false., single_mesh_state = .true.) + + call solve_galerkin_projection_scalars_dg_ele(ele_b, positions_b, positions_c, mesh_b, states_b(i), state_c, shapes_c) + + call deallocate(state_c) + call deallocate(positions_c) + do j = 1, size(shapes_c) + call deallocate(shapes_c(j)) + end do + deallocate(shapes_c) + end do + case default + ewrite(-1, "(a,i0)") "For mesh continuity ", mesh_b%continuity + FLAbort("Unrecognised mesh continuity") + end select end do - end do - call solve(little_mass, little_rhs) + do i = 1, size(map_ba) + call deallocate(map_ba(i)) + end do - do i = 1, scalar_field_count(state_b) - s_field_b => extract_scalar_field(state_b, i) - call set(s_field_b, ele_nodes(s_field_b, ele_b), little_rhs(:, i)) - end do + end subroutine galerkin_projection_scalars - end subroutine solve_galerkin_projection_scalars_dg_ele + subroutine assemble_galerkin_projection_scalars_ele(ele, ele_out, positions, state, shape, rhs) + integer, intent(in) :: ele + integer, intent(in) :: ele_out + type(vector_field), intent(in) :: positions + type(state_type), intent(in) :: state + type(element_type), intent(in) :: shape + type(scalar_field), intent(inout), dimension(:) :: rhs - subroutine assemble_galerkin_projection_scalars_dg_ele(ele, positions, state, shape, little_rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(state_type), intent(in) :: state - type(element_type), intent(in) :: shape - real, dimension(shape%loc, scalar_field_count(state)), intent(inout) :: little_rhs + integer :: field + real, dimension(ele_ngi(positions, ele)) :: detwei + type(scalar_field), pointer :: s_field - integer :: i - real, dimension(ele_ngi(positions, ele)) :: detwei - type(scalar_field), pointer :: s_field + assert(size(rhs) == scalar_field_count(state)) - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) + do field = 1, size(rhs) + s_field => extract_scalar_field(state, field) + call addto(rhs(field), ele_nodes(rhs(field), ele_out), & + & shape_rhs(shape, detwei * ele_val_at_quad(s_field, ele))) + end do - do i = 1, scalar_field_count(state) - s_field => extract_scalar_field(state, i) - little_rhs(:, i) = little_rhs(:, i) + shape_rhs(shape, detwei * ele_val_at_quad(s_field, ele)) - end do + end subroutine assemble_galerkin_projection_scalars_ele + + subroutine solve_galerkin_projection_scalars_dg_ele(ele_b, positions_b, positions_c, mesh_b, state_b, state_c, shapes_c) + integer, intent(in) :: ele_b + type(vector_field), intent(in) :: positions_b + type(vector_field), intent(in) :: positions_c + type(mesh_type), intent(in) :: mesh_b + type(state_type), intent(in) :: state_b + type(state_type), intent(in) :: state_c + type(element_type), dimension(ele_count(positions_c)), intent(in) :: shapes_c + + integer :: i, j + real, dimension(ele_loc(mesh_b, ele_b), scalar_field_count(state_c)) :: little_rhs + real, dimension(ele_ngi(positions_b, ele_b)) :: detwei + real, dimension(ele_loc(mesh_b, ele_b), ele_loc(mesh_b, ele_b)) :: little_mass + type(scalar_field), pointer :: s_field_b + + call transform_to_physical(positions_b, ele_b, detwei = detwei) + + little_mass = shape_shape(ele_shape(mesh_b, ele_b), ele_shape(mesh_b, ele_b), detwei) + little_rhs = 0.0 + do i = 1, scalar_field_count(state_b) + do j = 1, ele_count(positions_c) + call assemble_galerkin_projection_scalars_dg_ele(j, positions_c, state_c, shapes_c(j), little_rhs) + end do + end do - end subroutine assemble_galerkin_projection_scalars_dg_ele + call solve(little_mass, little_rhs) - function compute_inner_product_sa(positions_a, positions_b, a, b) result(val) - type(vector_field), intent(in) :: positions_a - type(vector_field), intent(in) :: positions_b - type(scalar_field), intent(in) :: a - type(scalar_field), intent(in) :: b + do i = 1, scalar_field_count(state_b) + s_field_b => extract_scalar_field(state_b, i) + call set(s_field_b, ele_nodes(s_field_b, ele_b), little_rhs(:, i)) + end do - real :: val + end subroutine solve_galerkin_projection_scalars_dg_ele - integer :: ele_b, ele_c - type(ilist), dimension(ele_count(positions_b)) :: map_ba - type(scalar_field) :: a_c, b_c - type(vector_field) :: positions_c + subroutine assemble_galerkin_projection_scalars_dg_ele(ele, positions, state, shape, little_rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(state_type), intent(in) :: state + type(element_type), intent(in) :: shape + real, dimension(shape%loc, scalar_field_count(state)), intent(inout) :: little_rhs - val = 0.0 + integer :: i + real, dimension(ele_ngi(positions, ele)) :: detwei + type(scalar_field), pointer :: s_field - call intersector_set_dimension(positions_a%dim) + call transform_to_physical(positions, ele, detwei = detwei) - map_ba = intersection_finder(positions_b, positions_a) + do i = 1, scalar_field_count(state) + s_field => extract_scalar_field(state, i) + little_rhs(:, i) = little_rhs(:, i) + shape_rhs(shape, detwei * ele_val_at_quad(s_field, ele)) + end do - do ele_b = 1, ele_count(positions_b) - ! Supermesh - call construct_supermesh(positions_b, ele_b, positions_a, map_ba(ele_b), ele_shape(positions_b, ele_b), positions_c) - if(ele_count(positions_c) == 0) then - call deallocate(positions_c) - cycle - end if + end subroutine assemble_galerkin_projection_scalars_dg_ele - ! Project a onto the supermesh - a_c = project_donor_field_to_supermesh(positions_a, positions_c, a) - ! Project b onto the supermesh - b_c = project_target_field_to_supermesh(ele_b, positions_b, positions_c, b) + function compute_inner_product_sa(positions_a, positions_b, a, b) result(val) + type(vector_field), intent(in) :: positions_a + type(vector_field), intent(in) :: positions_b + type(scalar_field), intent(in) :: a + type(scalar_field), intent(in) :: b - do ele_c = 1, ele_count(positions_c) - ! Compute the contribution to the inner product - call add_inner_product_ele(ele_c, positions_c, a_c, b_c, val) - end do + real :: val - ! Cleanup - call deallocate(positions_c) - call deallocate(a_c) - call deallocate(b_c) - end do + integer :: ele_b, ele_c + type(ilist), dimension(ele_count(positions_b)) :: map_ba + type(scalar_field) :: a_c, b_c + type(vector_field) :: positions_c + + val = 0.0 + + call intersector_set_dimension(positions_a%dim) + + map_ba = intersection_finder(positions_b, positions_a) - do ele_b = 1, ele_count(positions_b) - call deallocate(map_ba(ele_b)) - end do + do ele_b = 1, ele_count(positions_b) + ! Supermesh + call construct_supermesh(positions_b, ele_b, positions_a, map_ba(ele_b), ele_shape(positions_b, ele_b), positions_c) + if(ele_count(positions_c) == 0) then + call deallocate(positions_c) + cycle + end if + + ! Project a onto the supermesh + a_c = project_donor_field_to_supermesh(positions_a, positions_c, a) + ! Project b onto the supermesh + b_c = project_target_field_to_supermesh(ele_b, positions_b, positions_c, b) + + do ele_c = 1, ele_count(positions_c) + ! Compute the contribution to the inner product + call add_inner_product_ele(ele_c, positions_c, a_c, b_c, val) + end do + + ! Cleanup + call deallocate(positions_c) + call deallocate(a_c) + call deallocate(b_c) + end do + + do ele_b = 1, ele_count(positions_b) + call deallocate(map_ba(ele_b)) + end do - end function compute_inner_product_sa + end function compute_inner_product_sa - subroutine add_inner_product_ele(ele, positions, a, b, val) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: a - type(scalar_field), intent(in) :: b - real, intent(inout) :: val + subroutine add_inner_product_ele(ele, positions, a, b, val) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: a + type(scalar_field), intent(in) :: b + real, intent(inout) :: val - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - val = val + dot_product(ele_val(a, ele), matmul(& - & shape_shape(ele_shape(a, ele), ele_shape(b, ele), detwei), ele_val(b, ele))) + val = val + dot_product(ele_val(a, ele), matmul(& + & shape_shape(ele_shape(a, ele), ele_shape(b, ele), detwei), ele_val(b, ele))) - end subroutine add_inner_product_ele + end subroutine add_inner_product_ele end module supermesh_assembly diff --git a/femtools/Surface_Integrals.F90 b/femtools/Surface_Integrals.F90 index 8da829f790..44d1c01d06 100644 --- a/femtools/Surface_Integrals.F90 +++ b/femtools/Surface_Integrals.F90 @@ -29,926 +29,926 @@ module surface_integrals - use fldebug - use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN - use spud - use futils - use quadrature - use element_numbering, only: FAMILY_SIMPLEX - use elements - use parallel_tools - use parallel_fields - use transform_elements - use fields - use state_module - use field_options - - implicit none - - private - - public :: calculate_surface_integral, gradient_normal_surface_integral, & - & normal_surface_integral, surface_integral, surface_gradient_normal, & - & surface_normal_distance_sele, calculate_surface_l2norm, surface_l2norm - public :: diagnostic_body_drag - - interface integrate_over_surface_element - module procedure integrate_over_surface_element_mesh, & + use fldebug + use global_parameters, only : OPTION_PATH_LEN, FIELD_NAME_LEN + use spud + use futils + use quadrature + use element_numbering, only: FAMILY_SIMPLEX + use elements + use parallel_tools + use parallel_fields + use transform_elements + use fields + use state_module + use field_options + + implicit none + + private + + public :: calculate_surface_integral, gradient_normal_surface_integral, & + & normal_surface_integral, surface_integral, surface_gradient_normal, & + & surface_normal_distance_sele, calculate_surface_l2norm, surface_l2norm + public :: diagnostic_body_drag + + interface integrate_over_surface_element + module procedure integrate_over_surface_element_mesh, & & integrate_over_surface_element_scalar, & & integrate_over_surface_element_vector, & & integrate_over_surface_element_tensor - end interface + end interface - interface calculate_surface_integral - module procedure calculate_surface_integral_scalar, & + interface calculate_surface_integral + module procedure calculate_surface_integral_scalar, & & calculate_surface_integral_vector - end interface + end interface - interface calculate_surface_l2norm - module procedure calculate_surface_l2norm_scalar, & + interface calculate_surface_l2norm + module procedure calculate_surface_l2norm_scalar, & & calculate_surface_l2norm_vector - end interface + end interface - interface surface_l2norm - module procedure surface_l2norm_scalar, & + interface surface_l2norm + module procedure surface_l2norm_scalar, & & surface_l2norm_vector - end interface + end interface contains - function surface_integral(s_field, positions, surface_ids, normalise) result(integral) - !!< Integrate the given scalar field over the surface of its mesh. The - !!< surface elements integrated over are defined by - !!< integrate_over_surface_element(...). If normalise is present and true, - !!< then the surface integral is normalised by surface area. - - type(scalar_field), intent(in) :: s_field - type(vector_field), target, intent(in) :: positions - integer, dimension(:), optional, intent(in) :: surface_ids - logical, optional, intent(in) :: normalise - - real :: integral - - integer :: i - logical :: integrate_over_element - real :: area, face_area, face_integral - - if(present_and_true(normalise)) then - area = 0.0 - end if - integral = 0.0 - - do i = 1, surface_element_count(s_field) - integrate_over_element = integrate_over_surface_element(s_field, i, surface_ids=surface_ids) - - if(integrate_over_element) then - if(present_and_true(normalise)) then - call surface_integral_face(s_field, i, positions, face_integral, area = face_area) - area = area + face_area - else - call surface_integral_face(s_field, i, positions, face_integral) - end if - integral = integral + face_integral - end if - end do - - call allsum(integral, communicator = halo_communicator(s_field)) - if(present_and_true(normalise)) then - call allsum(area, communicator = halo_communicator(s_field)) - integral = integral / area - end if - - end function surface_integral - - subroutine surface_integral_face(s_field, face, positions, integral, area) - type(scalar_field), intent(in) :: s_field - type(vector_field), intent(in) :: positions - integer, intent(in) :: face - real, intent(out) :: integral - real, optional, intent(out) :: area - - real, dimension(face_ngi(s_field, face)) :: detwei - - assert(face_ngi(s_field, face) == face_ngi(positions, face)) - - call transform_facet_to_physical(positions, face, detwei) - - integral = dot_product(face_val_at_quad(s_field, face), detwei) - if(present(area)) then - area = sum(detwei) - end if - - end subroutine surface_integral_face - - function normal_surface_integral(v_field, positions, surface_ids, normalise) result(integral) - !!< Evaluate: - !!< / - !!< | v_field dot dn - !!< / - !!< over the surface of v_field's mesh. The surface elements integrated - !!< over are defined by integrate_over_surface_element(...). If normalise is - !!< present and true, then the surface integral is normalised by surface - !!< area. - - type(vector_field), intent(in) :: v_field - type(vector_field), target, intent(in) :: positions - integer, dimension(:), optional, intent(in) :: surface_ids - logical, optional, intent(in) :: normalise - - real :: integral - - integer :: i - logical :: integrate_over_element - real :: area, face_area, face_integral - - if(present_and_true(normalise)) then - area = 0.0 - end if - integral = 0.0 - do i = 1, surface_element_count(v_field) - integrate_over_element = integrate_over_surface_element(v_field, i, surface_ids=surface_ids) - - if(integrate_over_element) then - if(present_and_true(normalise)) then - call normal_surface_integral_face(v_field, i, positions, face_integral, area = face_area) - area = area + face_area - else - call normal_surface_integral_face(v_field, i, positions, face_integral) - end if - integral = integral + face_integral - end if - end do - - call allsum(integral, communicator = halo_communicator(v_field)) - if(present_and_true(normalise)) then - call allsum(area, communicator = halo_communicator(v_field)) - integral = integral / area - end if - - end function normal_surface_integral - - subroutine normal_surface_integral_face(v_field, face, positions, integral, area) - type(vector_field), intent(in) :: v_field - integer, intent(in) :: face - type(vector_field), intent(in) :: positions - real, intent(out) :: integral - real, optional, intent(out) :: area - - integer :: ele, i - real, dimension(face_ngi(v_field, face)) :: detwei, v_dot_n_at_quad - real, dimension(v_field%dim, face_ngi(v_field, face)) :: normal, v_at_quad - type(element_type), pointer :: element_shape, face_element_shape - - ele = face_ele(v_field, face) - - assert(face_ngi(v_field, face) == face_ngi(positions, face)) - assert(ele_ngi(v_field, ele) == ele_ngi(positions, ele)) - assert(v_field%dim == positions%dim) - - face_element_shape => face_shape(v_field, face) - element_shape => ele_shape(v_field, ele) - - call transform_facet_to_physical( & - positions, face, detwei_f = detwei, normal = normal) - - ! Find value of v_field at the surface element quadrature points - v_at_quad = face_val_at_quad(v_field, face) - - ! Find the value of v_field . normal at the surface element quadrature - ! points - do i = 1, face_ngi(v_field, face) - v_dot_n_at_quad(i) = dot_product(v_at_quad(:, i), normal(:, i)) - end do - - ! Integrate over this surface element - integral = dot_product(v_dot_n_at_quad, detwei) - if(present(area)) then - area = sum(detwei) - end if - - end subroutine normal_surface_integral_face - - function gradient_normal_surface_integral(s_field, positions, surface_ids, normalise) result(integral) - !!< Evaluate: - !!< / - !!< | grad s_field dot dn - !!< / - !!< over the surface of s_field's mesh. The surface elements integrated - !!< over are defined by integrate_over_surface_element(...). If normalise is - !!< present and true, then the surface integral is normalised by surface - !!< area. - - type(scalar_field), intent(in) :: s_field - type(vector_field), target, intent(in) :: positions - integer, dimension(:), optional, intent(in) :: surface_ids - logical, optional, intent(in) :: normalise - - real :: integral - - integer :: i - logical :: integrate_over_element - real :: area, face_area, face_integral - - if(present_and_true(normalise)) then - area = 0.0 - end if - integral = 0.0 - - do i = 1, surface_element_count(s_field) - integrate_over_element = integrate_over_surface_element(s_field, i, surface_ids=surface_ids) - - if(integrate_over_element) then - if(present_and_true(normalise)) then - call gradient_normal_surface_integral_face(s_field, i, positions, face_integral, area = face_area) - area = area + face_area - else - call gradient_normal_surface_integral_face(s_field, i, positions, face_integral) - end if - integral = integral + face_integral - end if - end do - - call allsum(integral, communicator = halo_communicator(s_field)) - if(present_and_true(normalise)) then - call allsum(area, communicator = halo_communicator(s_field)) - integral = integral / area - end if - - end function gradient_normal_surface_integral - - subroutine gradient_normal_surface_integral_face(s_field, face, positions, integral, area) - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: face - type(vector_field), intent(in) :: positions - real, intent(out) :: integral - real, optional, intent(out) :: area - - integer :: ele, i, j - real, dimension(ele_loc(s_field, face_ele(s_field, face))) :: s_ele_val - real, dimension(face_ngi(s_field, face)) :: detwei, grad_s_dot_n_at_quad - real, dimension(ele_loc(s_field, face_ele(s_field, face)),face_ngi(s_field, face),mesh_dim(s_field)) :: ele_dshape_at_face_quad - real, dimension(mesh_dim(s_field), face_ngi(s_field, face)) :: grad_s_at_quad, normal - type(element_type), pointer :: element_shape - - ele = face_ele(s_field, face) - - assert(face_ngi(s_field, face) == face_ngi(positions, face)) - assert(ele_ngi(s_field, ele) == ele_ngi(positions, ele)) - assert(mesh_dim(s_field) == positions%dim) - - element_shape => ele_shape(s_field, ele) - - call transform_facet_to_physical( & - positions, face, element_shape, ele_dshape_at_face_quad, detwei_f = detwei, normal = normal) - - ! Calculate grad s_field at the surface element quadrature points - s_ele_val = ele_val(s_field, ele) - forall(i = 1:mesh_dim(s_field), j = 1:face_ngi(s_field, face)) - grad_s_at_quad(i, j) = dot_product(s_ele_val, ele_dshape_at_face_quad(:, j, i)) - end forall - - ! Calculate grad s_field dot dn at the surface element quadrature points - do i = 1, face_ngi(s_field, face) - grad_s_dot_n_at_quad(i) = dot_product(grad_s_at_quad(:, i), normal(:, i)) - end do - - ! Integrate over the surface element - integral = dot_product(grad_s_dot_n_at_quad, detwei) - if(present(area)) then - area = sum(detwei) - end if - - end subroutine gradient_normal_surface_integral_face - - subroutine surface_gradient_normal(source, positions, output, surface_ids) - !!< Return a field containing: - !!< / - !!< | grad source dot dn - !!< / - !!< The output field is P0 over the surface. Here, output is a volume field, - !!< hence there will be errors at edges. - - type(scalar_field), intent(in) :: source - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: output - integer, dimension(:), optional, intent(in) :: surface_ids - - integer :: i - real :: face_area, face_integral - - if(continuity(output) /= -1) then - FLAbort("surface_gradient_normal requires a discontinuous mesh") - end if - - call zero(output) - do i = 1, surface_element_count(output) - if(.not. include_face(i, source, surface_ids = surface_ids)) cycle - call gradient_normal_surface_integral_face(source, i, positions, face_integral, area = face_area) - call set(output, face_global_nodes(output, i), spread(face_integral / face_area, 1, face_loc(output, i))) - end do - - contains - - function include_face(face, source, surface_ids) + function surface_integral(s_field, positions, surface_ids, normalise) result(integral) + !!< Integrate the given scalar field over the surface of its mesh. The + !!< surface elements integrated over are defined by + !!< integrate_over_surface_element(...). If normalise is present and true, + !!< then the surface integral is normalised by surface area. + + type(scalar_field), intent(in) :: s_field + type(vector_field), target, intent(in) :: positions + integer, dimension(:), optional, intent(in) :: surface_ids + logical, optional, intent(in) :: normalise + + real :: integral + + integer :: i + logical :: integrate_over_element + real :: area, face_area, face_integral + + if(present_and_true(normalise)) then + area = 0.0 + end if + integral = 0.0 + + do i = 1, surface_element_count(s_field) + integrate_over_element = integrate_over_surface_element(s_field, i, surface_ids=surface_ids) + + if(integrate_over_element) then + if(present_and_true(normalise)) then + call surface_integral_face(s_field, i, positions, face_integral, area = face_area) + area = area + face_area + else + call surface_integral_face(s_field, i, positions, face_integral) + end if + integral = integral + face_integral + end if + end do + + call allsum(integral, communicator = halo_communicator(s_field)) + if(present_and_true(normalise)) then + call allsum(area, communicator = halo_communicator(s_field)) + integral = integral / area + end if + + end function surface_integral + + subroutine surface_integral_face(s_field, face, positions, integral, area) + type(scalar_field), intent(in) :: s_field + type(vector_field), intent(in) :: positions + integer, intent(in) :: face + real, intent(out) :: integral + real, optional, intent(out) :: area + + real, dimension(face_ngi(s_field, face)) :: detwei + + assert(face_ngi(s_field, face) == face_ngi(positions, face)) + + call transform_facet_to_physical(positions, face, detwei) + + integral = dot_product(face_val_at_quad(s_field, face), detwei) + if(present(area)) then + area = sum(detwei) + end if + + end subroutine surface_integral_face + + function normal_surface_integral(v_field, positions, surface_ids, normalise) result(integral) + !!< Evaluate: + !!< / + !!< | v_field dot dn + !!< / + !!< over the surface of v_field's mesh. The surface elements integrated + !!< over are defined by integrate_over_surface_element(...). If normalise is + !!< present and true, then the surface integral is normalised by surface + !!< area. + + type(vector_field), intent(in) :: v_field + type(vector_field), target, intent(in) :: positions + integer, dimension(:), optional, intent(in) :: surface_ids + logical, optional, intent(in) :: normalise + + real :: integral + + integer :: i + logical :: integrate_over_element + real :: area, face_area, face_integral + + if(present_and_true(normalise)) then + area = 0.0 + end if + integral = 0.0 + do i = 1, surface_element_count(v_field) + integrate_over_element = integrate_over_surface_element(v_field, i, surface_ids=surface_ids) + + if(integrate_over_element) then + if(present_and_true(normalise)) then + call normal_surface_integral_face(v_field, i, positions, face_integral, area = face_area) + area = area + face_area + else + call normal_surface_integral_face(v_field, i, positions, face_integral) + end if + integral = integral + face_integral + end if + end do + + call allsum(integral, communicator = halo_communicator(v_field)) + if(present_and_true(normalise)) then + call allsum(area, communicator = halo_communicator(v_field)) + integral = integral / area + end if + + end function normal_surface_integral + + subroutine normal_surface_integral_face(v_field, face, positions, integral, area) + type(vector_field), intent(in) :: v_field + integer, intent(in) :: face + type(vector_field), intent(in) :: positions + real, intent(out) :: integral + real, optional, intent(out) :: area + + integer :: ele, i + real, dimension(face_ngi(v_field, face)) :: detwei, v_dot_n_at_quad + real, dimension(v_field%dim, face_ngi(v_field, face)) :: normal, v_at_quad + type(element_type), pointer :: element_shape, face_element_shape + + ele = face_ele(v_field, face) + + assert(face_ngi(v_field, face) == face_ngi(positions, face)) + assert(ele_ngi(v_field, ele) == ele_ngi(positions, ele)) + assert(v_field%dim == positions%dim) + + face_element_shape => face_shape(v_field, face) + element_shape => ele_shape(v_field, ele) + + call transform_facet_to_physical( & + positions, face, detwei_f = detwei, normal = normal) + + ! Find value of v_field at the surface element quadrature points + v_at_quad = face_val_at_quad(v_field, face) + + ! Find the value of v_field . normal at the surface element quadrature + ! points + do i = 1, face_ngi(v_field, face) + v_dot_n_at_quad(i) = dot_product(v_at_quad(:, i), normal(:, i)) + end do + + ! Integrate over this surface element + integral = dot_product(v_dot_n_at_quad, detwei) + if(present(area)) then + area = sum(detwei) + end if + + end subroutine normal_surface_integral_face + + function gradient_normal_surface_integral(s_field, positions, surface_ids, normalise) result(integral) + !!< Evaluate: + !!< / + !!< | grad s_field dot dn + !!< / + !!< over the surface of s_field's mesh. The surface elements integrated + !!< over are defined by integrate_over_surface_element(...). If normalise is + !!< present and true, then the surface integral is normalised by surface + !!< area. + + type(scalar_field), intent(in) :: s_field + type(vector_field), target, intent(in) :: positions + integer, dimension(:), optional, intent(in) :: surface_ids + logical, optional, intent(in) :: normalise + + real :: integral + + integer :: i + logical :: integrate_over_element + real :: area, face_area, face_integral + + if(present_and_true(normalise)) then + area = 0.0 + end if + integral = 0.0 + + do i = 1, surface_element_count(s_field) + integrate_over_element = integrate_over_surface_element(s_field, i, surface_ids=surface_ids) + + if(integrate_over_element) then + if(present_and_true(normalise)) then + call gradient_normal_surface_integral_face(s_field, i, positions, face_integral, area = face_area) + area = area + face_area + else + call gradient_normal_surface_integral_face(s_field, i, positions, face_integral) + end if + integral = integral + face_integral + end if + end do + + call allsum(integral, communicator = halo_communicator(s_field)) + if(present_and_true(normalise)) then + call allsum(area, communicator = halo_communicator(s_field)) + integral = integral / area + end if + + end function gradient_normal_surface_integral + + subroutine gradient_normal_surface_integral_face(s_field, face, positions, integral, area) + type(scalar_field), intent(in) :: s_field integer, intent(in) :: face + type(vector_field), intent(in) :: positions + real, intent(out) :: integral + real, optional, intent(out) :: area + + integer :: ele, i, j + real, dimension(ele_loc(s_field, face_ele(s_field, face))) :: s_ele_val + real, dimension(face_ngi(s_field, face)) :: detwei, grad_s_dot_n_at_quad + real, dimension(ele_loc(s_field, face_ele(s_field, face)),face_ngi(s_field, face),mesh_dim(s_field)) :: ele_dshape_at_face_quad + real, dimension(mesh_dim(s_field), face_ngi(s_field, face)) :: grad_s_at_quad, normal + type(element_type), pointer :: element_shape + + ele = face_ele(s_field, face) + + assert(face_ngi(s_field, face) == face_ngi(positions, face)) + assert(ele_ngi(s_field, ele) == ele_ngi(positions, ele)) + assert(mesh_dim(s_field) == positions%dim) + + element_shape => ele_shape(s_field, ele) + + call transform_facet_to_physical( & + positions, face, element_shape, ele_dshape_at_face_quad, detwei_f = detwei, normal = normal) + + ! Calculate grad s_field at the surface element quadrature points + s_ele_val = ele_val(s_field, ele) + forall(i = 1:mesh_dim(s_field), j = 1:face_ngi(s_field, face)) + grad_s_at_quad(i, j) = dot_product(s_ele_val, ele_dshape_at_face_quad(:, j, i)) + end forall + + ! Calculate grad s_field dot dn at the surface element quadrature points + do i = 1, face_ngi(s_field, face) + grad_s_dot_n_at_quad(i) = dot_product(grad_s_at_quad(:, i), normal(:, i)) + end do + + ! Integrate over the surface element + integral = dot_product(grad_s_dot_n_at_quad, detwei) + if(present(area)) then + area = sum(detwei) + end if + + end subroutine gradient_normal_surface_integral_face + + subroutine surface_gradient_normal(source, positions, output, surface_ids) + !!< Return a field containing: + !!< / + !!< | grad source dot dn + !!< / + !!< The output field is P0 over the surface. Here, output is a volume field, + !!< hence there will be errors at edges. + type(scalar_field), intent(in) :: source + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: output integer, dimension(:), optional, intent(in) :: surface_ids - logical :: include_face + integer :: i + real :: face_area, face_integral - if(present(surface_ids)) then - if(.not. associated(source%mesh%faces)) then - include_face = .false. - else if(.not. associated(source%mesh%faces%boundary_ids)) then - include_face = .false. - else - include_face = any(surface_ids == surface_element_id(source, face)) - end if - else - include_face = .true. + if(continuity(output) /= -1) then + FLAbort("surface_gradient_normal requires a discontinuous mesh") end if - end function include_face + call zero(output) + do i = 1, surface_element_count(output) + if(.not. include_face(i, source, surface_ids = surface_ids)) cycle + call gradient_normal_surface_integral_face(source, i, positions, face_integral, area = face_area) + call set(output, face_global_nodes(output, i), spread(face_integral / face_area, 1, face_loc(output, i))) + end do - end subroutine surface_gradient_normal + contains - function surface_l2norm_scalar(s_field, positions, surface_ids, normalise) result(integral) - !!< Calculate the L2 norm over the surface of the mesh. - !!< surface elements integrated over are defined by - !!< integrate_over_surface_element(...). If normalise is present and true, - !!< the result is divided by the sqrt of the surface area + function include_face(face, source, surface_ids) + integer, intent(in) :: face + type(scalar_field), intent(in) :: source + integer, dimension(:), optional, intent(in) :: surface_ids - type(scalar_field), intent(in) :: s_field - type(vector_field), target, intent(in) :: positions - integer, dimension(:), optional, intent(in) :: surface_ids - logical, optional, intent(in) :: normalise + logical :: include_face - real :: integral + if(present(surface_ids)) then + if(.not. associated(source%mesh%faces)) then + include_face = .false. + else if(.not. associated(source%mesh%faces%boundary_ids)) then + include_face = .false. + else + include_face = any(surface_ids == surface_element_id(source, face)) + end if + else + include_face = .true. + end if - integer :: i - real :: area, face_area, face_integral + end function include_face - if(present_and_true(normalise)) then - area = 0.0 - end if - integral = 0.0 + end subroutine surface_gradient_normal - do i = 1, surface_element_count(s_field) - if (integrate_over_surface_element(s_field, i, surface_ids=surface_ids)) then - if(present_and_true(normalise)) then - call surface_l2norm_scalar_face(s_field, i, positions, face_integral, area = face_area) - area = area + face_area - else - call surface_l2norm_scalar_face(s_field, i, positions, face_integral) - end if - integral = integral + face_integral + function surface_l2norm_scalar(s_field, positions, surface_ids, normalise) result(integral) + !!< Calculate the L2 norm over the surface of the mesh. + !!< surface elements integrated over are defined by + !!< integrate_over_surface_element(...). If normalise is present and true, + !!< the result is divided by the sqrt of the surface area + + type(scalar_field), intent(in) :: s_field + type(vector_field), target, intent(in) :: positions + integer, dimension(:), optional, intent(in) :: surface_ids + logical, optional, intent(in) :: normalise + + real :: integral + + integer :: i + real :: area, face_area, face_integral + + if(present_and_true(normalise)) then + area = 0.0 end if - end do + integral = 0.0 - call allsum(integral, communicator = halo_communicator(s_field)) + do i = 1, surface_element_count(s_field) + if (integrate_over_surface_element(s_field, i, surface_ids=surface_ids)) then + if(present_and_true(normalise)) then + call surface_l2norm_scalar_face(s_field, i, positions, face_integral, area = face_area) + area = area + face_area + else + call surface_l2norm_scalar_face(s_field, i, positions, face_integral) + end if + integral = integral + face_integral + end if + end do - if(present_and_true(normalise)) then - call allsum(area, communicator = halo_communicator(s_field)) - integral = integral / area - end if + call allsum(integral, communicator = halo_communicator(s_field)) - integral = sqrt(integral) + if(present_and_true(normalise)) then + call allsum(area, communicator = halo_communicator(s_field)) + integral = integral / area + end if - end function surface_l2norm_scalar + integral = sqrt(integral) - subroutine surface_l2norm_scalar_face(s_field, face, positions, integral, area) - type(scalar_field), intent(in) :: s_field - type(vector_field), intent(in) :: positions - integer, intent(in) :: face - real, intent(out) :: integral - real, optional, intent(out) :: area + end function surface_l2norm_scalar - real, dimension(face_ngi(s_field, face)) :: detwei + subroutine surface_l2norm_scalar_face(s_field, face, positions, integral, area) + type(scalar_field), intent(in) :: s_field + type(vector_field), intent(in) :: positions + integer, intent(in) :: face + real, intent(out) :: integral + real, optional, intent(out) :: area - assert(face_ngi(s_field, face) == face_ngi(positions, face)) + real, dimension(face_ngi(s_field, face)) :: detwei - call transform_facet_to_physical(positions, face, detwei) + assert(face_ngi(s_field, face) == face_ngi(positions, face)) - integral = dot_product(face_val_at_quad(s_field, face)**2, detwei) - if(present(area)) then - area = sum(detwei) - end if + call transform_facet_to_physical(positions, face, detwei) - end subroutine surface_l2norm_scalar_face + integral = dot_product(face_val_at_quad(s_field, face)**2, detwei) + if(present(area)) then + area = sum(detwei) + end if - function surface_l2norm_vector(v_field, positions, surface_ids, normalise) result(integral) - !!< Calculate the L2 norm over the surface of the mesh. - !!< surface elements integrated over are defined by - !!< integrate_over_surface_element(...). If normalise is present and true, - !!< the result is divided by the sqrt of the surface area + end subroutine surface_l2norm_scalar_face - type(vector_field), intent(in) :: v_field - type(vector_field), target, intent(in) :: positions - integer, dimension(:), optional, intent(in) :: surface_ids - logical, optional, intent(in) :: normalise + function surface_l2norm_vector(v_field, positions, surface_ids, normalise) result(integral) + !!< Calculate the L2 norm over the surface of the mesh. + !!< surface elements integrated over are defined by + !!< integrate_over_surface_element(...). If normalise is present and true, + !!< the result is divided by the sqrt of the surface area - real :: integral + type(vector_field), intent(in) :: v_field + type(vector_field), target, intent(in) :: positions + integer, dimension(:), optional, intent(in) :: surface_ids + logical, optional, intent(in) :: normalise - integer :: i - real :: area, face_area, face_integral + real :: integral - if(present_and_true(normalise)) then - area = 0.0 - end if - integral = 0.0 + integer :: i + real :: area, face_area, face_integral - do i = 1, surface_element_count(v_field) - if (integrate_over_surface_element(v_field, i, surface_ids=surface_ids)) then - if(present_and_true(normalise)) then - call surface_l2norm_vector_face(v_field, i, positions, face_integral, area = face_area) - area = area + face_area - else - call surface_l2norm_vector_face(v_field, i, positions, face_integral) - end if - integral = integral + face_integral + if(present_and_true(normalise)) then + area = 0.0 end if - end do + integral = 0.0 - call allsum(integral, communicator = halo_communicator(v_field)) + do i = 1, surface_element_count(v_field) + if (integrate_over_surface_element(v_field, i, surface_ids=surface_ids)) then + if(present_and_true(normalise)) then + call surface_l2norm_vector_face(v_field, i, positions, face_integral, area = face_area) + area = area + face_area + else + call surface_l2norm_vector_face(v_field, i, positions, face_integral) + end if + integral = integral + face_integral + end if + end do + + call allsum(integral, communicator = halo_communicator(v_field)) + + if(present_and_true(normalise)) then + call allsum(area, communicator = halo_communicator(v_field)) + integral = integral / area + end if - if(present_and_true(normalise)) then - call allsum(area, communicator = halo_communicator(v_field)) - integral = integral / area - end if + integral = sqrt(integral) - integral = sqrt(integral) + end function surface_l2norm_vector - end function surface_l2norm_vector + subroutine surface_l2norm_vector_face(v_field, face, positions, integral, area) + type(vector_field), intent(in) :: v_field + type(vector_field), intent(in) :: positions + integer, intent(in) :: face + real, intent(out) :: integral + real, optional, intent(out) :: area - subroutine surface_l2norm_vector_face(v_field, face, positions, integral, area) - type(vector_field), intent(in) :: v_field - type(vector_field), intent(in) :: positions - integer, intent(in) :: face - real, intent(out) :: integral - real, optional, intent(out) :: area + real, dimension(face_ngi(v_field, face)) :: detwei - real, dimension(face_ngi(v_field, face)) :: detwei + assert(face_ngi(v_field, face) == face_ngi(positions, face)) - assert(face_ngi(v_field, face) == face_ngi(positions, face)) + call transform_facet_to_physical(positions, face, detwei) - call transform_facet_to_physical(positions, face, detwei) + integral = sum(matmul(face_val_at_quad(v_field, face)**2, detwei)) + if(present(area)) then + area = sum(detwei) + end if - integral = sum(matmul(face_val_at_quad(v_field, face)**2, detwei)) - if(present(area)) then - area = sum(detwei) - end if + end subroutine surface_l2norm_vector_face - end subroutine surface_l2norm_vector_face + function surface_normal_distance_sele(positions, sele, ele) result(h) + ! calculate wall-normal element size + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele, sele + real :: h + type(element_type), pointer :: shape + integer :: i, dim + real, dimension(face_ngi(positions,sele)) :: detwei_bdy + real, dimension(positions%dim,positions%dim) :: J + real, dimension(positions%dim,face_ngi(positions,sele)) :: normal_bdy - function surface_normal_distance_sele(positions, sele, ele) result(h) - ! calculate wall-normal element size - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele, sele - real :: h - type(element_type), pointer :: shape - integer :: i, dim - real, dimension(face_ngi(positions,sele)) :: detwei_bdy - real, dimension(positions%dim,positions%dim) :: J - real, dimension(positions%dim,face_ngi(positions,sele)) :: normal_bdy + shape => ele_shape(positions, ele) + dim = positions%dim - shape => ele_shape(positions, ele) - dim = positions%dim + call transform_facet_to_physical(positions, sele, detwei_f=detwei_bdy, normal=normal_bdy) + J = transpose(matmul(ele_val(positions, ele) , shape%dn(:, 1, :))) + h = maxval((/( abs(dot_product(normal_bdy(:, 1), J(i, :))), i=1, dim)/)) - call transform_facet_to_physical(positions, sele, detwei_f=detwei_bdy, normal=normal_bdy) - J = transpose(matmul(ele_val(positions, ele) , shape%dn(:, 1, :))) - h = maxval((/( abs(dot_product(normal_bdy(:, 1), J(i, :))), i=1, dim)/)) + end function surface_normal_distance_sele - end function surface_normal_distance_sele + function integrate_over_surface_element_mesh(mesh, face_number, surface_ids) result(integrate_over_element) + !!< Return whether the given surface element should be integrated over when + !!< performing a surface integral - function integrate_over_surface_element_mesh(mesh, face_number, surface_ids) result(integrate_over_element) - !!< Return whether the given surface element should be integrated over when - !!< performing a surface integral + type(mesh_type), intent(in) :: mesh + integer, intent(in) :: face_number + integer, dimension(:), optional, intent(in) :: surface_ids - type(mesh_type), intent(in) :: mesh - integer, intent(in) :: face_number - integer, dimension(:), optional, intent(in) :: surface_ids + logical :: integrate_over_element - logical :: integrate_over_element + if(present(surface_ids)) then + ! If surface_ids have been supplied, only integrate over the element + ! if the surface element surface ID exists and is in the list of supplied + ! surface IDs + if(.not. associated(mesh%faces)) then + integrate_over_element = .false. + return + else if(.not. associated(mesh%faces%boundary_ids)) then + integrate_over_element = .false. + return + else if(.not. any(surface_ids == surface_element_id(mesh, face_number))) then + integrate_over_element = .false. + return + end if + end if - if(present(surface_ids)) then - ! If surface_ids have been supplied, only integrate over the element - ! if the surface element surface ID exists and is in the list of supplied - ! surface IDs - if(.not. associated(mesh%faces)) then - integrate_over_element = .false. - return - else if(.not. associated(mesh%faces%boundary_ids)) then - integrate_over_element = .false. - return - else if(.not. any(surface_ids == surface_element_id(mesh, face_number))) then - integrate_over_element = .false. - return - end if - end if - - if(isparallel()) then - ! In parallel, only integrate over the surface element if it is owned by - ! this process - if(.not. surface_element_owned(mesh, face_number)) then - integrate_over_element = .false. - return - end if - end if - - integrate_over_element = .true. - - end function integrate_over_surface_element_mesh - - function integrate_over_surface_element_scalar(s_field, face_number, surface_ids) result(integrate_over_element) - !!< Return whether the given surface element on the mesh for the given field - !!< should be integrated over when performing a surface integral - - type(scalar_field), intent(in) :: s_field - integer, intent(in) :: face_number - integer, dimension(:), optional, intent(in) :: surface_ids - - logical :: integrate_over_element - - integrate_over_element = integrate_over_surface_element(s_field%mesh, face_number, surface_ids=surface_ids) - - end function integrate_over_surface_element_scalar - - function integrate_over_surface_element_vector(v_field, face_number, surface_ids) result(integrate_over_element) - !!< Return whether the given surface element on the mesh for the given field - !!< should be integrated over when performing a surface integral - - type(vector_field), intent(in) :: v_field - integer, intent(in) :: face_number - integer, dimension(:), optional, intent(in) :: surface_ids - - logical :: integrate_over_element - - integrate_over_element = integrate_over_surface_element(v_field%mesh, face_number, surface_ids=surface_ids) - - end function integrate_over_surface_element_vector - - function integrate_over_surface_element_tensor(t_field, face_number, surface_ids) result(integrate_over_element) - !!< Return whether the given surface element on the mesh for the given field - !!< should be integrated over when performing a surface integral - - type(tensor_field), intent(in) :: t_field - integer, intent(in) :: face_number - integer, dimension(:), optional, intent(in) :: surface_ids - - logical :: integrate_over_element - - integrate_over_element = integrate_over_surface_element(t_field%mesh, face_number, surface_ids=surface_ids) - - end function integrate_over_surface_element_tensor - - subroutine diagnostic_body_drag(state, force, surface_integral_name, pressure_force, viscous_force) - type(state_type), intent(in) :: state - real, dimension(:) :: force - character(len = FIELD_NAME_LEN), intent(in) :: surface_integral_name - real, dimension(size(force)), optional, intent(out) :: pressure_force - real, dimension(size(force)), optional, intent(out) :: viscous_force - - type(vector_field), pointer :: velocity, position - type(tensor_field), pointer :: viscosity - type(scalar_field), pointer :: pressure - type(element_type), pointer :: x_f_shape, x_shape, u_shape, u_f_shape - character(len=OPTION_PATH_LEN) :: option_path - integer :: ele,sele,nloc,snloc,sngi,ngi,stotel,nfaces,meshdim, gi - integer, dimension(:), allocatable :: surface_ids - integer, dimension(2) :: shape_option - real, dimension(:), allocatable :: face_detwei, face_pressure - real, dimension(:,:), allocatable :: velocity_ele, normal, strain, force_at_quad - real, dimension(:,:,:), allocatable :: dn_t,viscosity_ele, tau, vol_dshape_face - real :: sarea - integer :: stat - logical :: have_viscosity - - ewrite(1,*) 'In diagnostic_body_drag' - ewrite(1,*) 'Computing body forces for label "'//trim(surface_integral_name)//'"' - - position => extract_vector_field(state, "Coordinate") - pressure => extract_scalar_field(state, "Pressure") - velocity => extract_vector_field(state, "Velocity") - viscosity=> extract_tensor_field(state, "Viscosity", stat) - have_viscosity = stat == 0 - - assert(size(force) == position%dim) - - meshdim = mesh_dim(velocity) - x_shape => ele_shape(position, 1) - u_shape => ele_shape(velocity, 1) - x_f_shape => face_shape(position, 1) - u_f_shape => face_shape(velocity, 1) - nloc = ele_loc(velocity, 1) - snloc = face_loc(velocity, 1) - ngi = ele_ngi(velocity, 1) - sngi = face_ngi(velocity, 1) - stotel = surface_element_count(velocity) - option_path = velocity%option_path - shape_option = option_shape(trim(option_path)//'/prognostic/stat/compute_body_forces_on_surfaces::'//trim(surface_integral_name)//'/surface_ids') - allocate( surface_ids(shape_option(1)), face_detwei(sngi), & - dn_t(nloc, ngi, meshdim), & - velocity_ele(meshdim, nloc), normal(meshdim, sngi), & - face_pressure(sngi), viscosity_ele(meshdim, meshdim, sngi), & - tau(meshdim, meshdim, sngi), strain(meshdim, meshdim), & - force_at_quad(meshdim, sngi)) - - allocate(vol_dshape_face(ele_loc(velocity, 1), face_ngi(velocity, 1),meshdim)) - - call get_option(trim(option_path)//'/prognostic/stat/compute_body_forces_on_surfaces::'//trim(surface_integral_name)//'/surface_ids', surface_ids) - ewrite(2,*) 'Calculating forces on surfaces with these IDs: ', surface_ids - - sarea = 0.0 - nfaces = 0 - force = 0.0 - if(present(pressure_force)) pressure_force = 0.0 - if(present(viscous_force)) viscous_force = 0.0 - do sele=1,stotel - if(integrate_over_surface_element(velocity, sele, surface_ids = surface_ids)) then - ! Get face_detwei and normal - ele = face_ele(velocity, sele) - call transform_facet_to_physical( & - position, sele, detwei_f=face_detwei, normal=normal) - call transform_to_physical(position, ele, & - shape=u_shape, dshape=dn_t) - velocity_ele = ele_val(velocity,ele) - - ! Compute tau only if viscosity is present - if(have_viscosity) then - viscosity_ele = face_val_at_quad(viscosity,sele) - - ! - ! Form the stress tensor - ! - - if (u_shape%degree == 1 .and. u_shape%numbering%family == FAMILY_SIMPLEX) then - strain = matmul(velocity_ele, dn_t(:, 1, :)) - strain = (strain + transpose(strain)) / 2.0 - do gi=1,sngi - tau(:, :, gi) = 2 * matmul(viscosity_ele(:, :, gi), strain) - end do + if(isparallel()) then + ! In parallel, only integrate over the surface element if it is owned by + ! this process + if(.not. surface_element_owned(mesh, face_number)) then + integrate_over_element = .false. + return + end if + end if + + integrate_over_element = .true. + + end function integrate_over_surface_element_mesh + + function integrate_over_surface_element_scalar(s_field, face_number, surface_ids) result(integrate_over_element) + !!< Return whether the given surface element on the mesh for the given field + !!< should be integrated over when performing a surface integral + + type(scalar_field), intent(in) :: s_field + integer, intent(in) :: face_number + integer, dimension(:), optional, intent(in) :: surface_ids + + logical :: integrate_over_element + + integrate_over_element = integrate_over_surface_element(s_field%mesh, face_number, surface_ids=surface_ids) + + end function integrate_over_surface_element_scalar + + function integrate_over_surface_element_vector(v_field, face_number, surface_ids) result(integrate_over_element) + !!< Return whether the given surface element on the mesh for the given field + !!< should be integrated over when performing a surface integral + + type(vector_field), intent(in) :: v_field + integer, intent(in) :: face_number + integer, dimension(:), optional, intent(in) :: surface_ids + + logical :: integrate_over_element + + integrate_over_element = integrate_over_surface_element(v_field%mesh, face_number, surface_ids=surface_ids) + + end function integrate_over_surface_element_vector + + function integrate_over_surface_element_tensor(t_field, face_number, surface_ids) result(integrate_over_element) + !!< Return whether the given surface element on the mesh for the given field + !!< should be integrated over when performing a surface integral + + type(tensor_field), intent(in) :: t_field + integer, intent(in) :: face_number + integer, dimension(:), optional, intent(in) :: surface_ids + + logical :: integrate_over_element + + integrate_over_element = integrate_over_surface_element(t_field%mesh, face_number, surface_ids=surface_ids) + + end function integrate_over_surface_element_tensor + + subroutine diagnostic_body_drag(state, force, surface_integral_name, pressure_force, viscous_force) + type(state_type), intent(in) :: state + real, dimension(:) :: force + character(len = FIELD_NAME_LEN), intent(in) :: surface_integral_name + real, dimension(size(force)), optional, intent(out) :: pressure_force + real, dimension(size(force)), optional, intent(out) :: viscous_force + + type(vector_field), pointer :: velocity, position + type(tensor_field), pointer :: viscosity + type(scalar_field), pointer :: pressure + type(element_type), pointer :: x_f_shape, x_shape, u_shape, u_f_shape + character(len=OPTION_PATH_LEN) :: option_path + integer :: ele,sele,nloc,snloc,sngi,ngi,stotel,nfaces,meshdim, gi + integer, dimension(:), allocatable :: surface_ids + integer, dimension(2) :: shape_option + real, dimension(:), allocatable :: face_detwei, face_pressure + real, dimension(:,:), allocatable :: velocity_ele, normal, strain, force_at_quad + real, dimension(:,:,:), allocatable :: dn_t,viscosity_ele, tau, vol_dshape_face + real :: sarea + integer :: stat + logical :: have_viscosity + + ewrite(1,*) 'In diagnostic_body_drag' + ewrite(1,*) 'Computing body forces for label "'//trim(surface_integral_name)//'"' + + position => extract_vector_field(state, "Coordinate") + pressure => extract_scalar_field(state, "Pressure") + velocity => extract_vector_field(state, "Velocity") + viscosity=> extract_tensor_field(state, "Viscosity", stat) + have_viscosity = stat == 0 + + assert(size(force) == position%dim) + + meshdim = mesh_dim(velocity) + x_shape => ele_shape(position, 1) + u_shape => ele_shape(velocity, 1) + x_f_shape => face_shape(position, 1) + u_f_shape => face_shape(velocity, 1) + nloc = ele_loc(velocity, 1) + snloc = face_loc(velocity, 1) + ngi = ele_ngi(velocity, 1) + sngi = face_ngi(velocity, 1) + stotel = surface_element_count(velocity) + option_path = velocity%option_path + shape_option = option_shape(trim(option_path)//'/prognostic/stat/compute_body_forces_on_surfaces::'//trim(surface_integral_name)//'/surface_ids') + allocate( surface_ids(shape_option(1)), face_detwei(sngi), & + dn_t(nloc, ngi, meshdim), & + velocity_ele(meshdim, nloc), normal(meshdim, sngi), & + face_pressure(sngi), viscosity_ele(meshdim, meshdim, sngi), & + tau(meshdim, meshdim, sngi), strain(meshdim, meshdim), & + force_at_quad(meshdim, sngi)) + + allocate(vol_dshape_face(ele_loc(velocity, 1), face_ngi(velocity, 1),meshdim)) + + call get_option(trim(option_path)//'/prognostic/stat/compute_body_forces_on_surfaces::'//trim(surface_integral_name)//'/surface_ids', surface_ids) + ewrite(2,*) 'Calculating forces on surfaces with these IDs: ', surface_ids + + sarea = 0.0 + nfaces = 0 + force = 0.0 + if(present(pressure_force)) pressure_force = 0.0 + if(present(viscous_force)) viscous_force = 0.0 + do sele=1,stotel + if(integrate_over_surface_element(velocity, sele, surface_ids = surface_ids)) then + ! Get face_detwei and normal + ele = face_ele(velocity, sele) + call transform_facet_to_physical( & + position, sele, detwei_f=face_detwei, normal=normal) + call transform_to_physical(position, ele, & + shape=u_shape, dshape=dn_t) + velocity_ele = ele_val(velocity,ele) + + ! Compute tau only if viscosity is present + if(have_viscosity) then + viscosity_ele = face_val_at_quad(viscosity,sele) + + ! + ! Form the stress tensor + ! + + if (u_shape%degree == 1 .and. u_shape%numbering%family == FAMILY_SIMPLEX) then + strain = matmul(velocity_ele, dn_t(:, 1, :)) + strain = (strain + transpose(strain)) / 2.0 + do gi=1,sngi + tau(:, :, gi) = 2 * matmul(viscosity_ele(:, :, gi), strain) + end do + else + call transform_facet_to_physical(position, sele, u_shape, vol_dshape_face) + + do gi=1,sngi + strain = matmul(velocity_ele, vol_dshape_face(:, gi, :)) + strain = (strain + transpose(strain)) / 2.0 + tau(:, :, gi) = 2 * matmul(viscosity_ele(:, :, gi), strain) + end do + end if + + end if + + face_pressure = face_val_at_quad(pressure, sele) + nfaces = nfaces + 1 + sarea = sarea + sum(face_detwei) + + + if(have_viscosity) then + do gi=1,sngi + force_at_quad(:, gi) = normal(:, gi) * face_pressure(gi) - matmul(normal(:, gi), tau(:, :, gi)) + end do else - call transform_facet_to_physical(position, sele, u_shape, vol_dshape_face) + do gi=1,sngi + force_at_quad(:, gi) = normal(:, gi) * face_pressure(gi) + end do + end if + force = force + matmul(force_at_quad, face_detwei) - do gi=1,sngi - strain = matmul(velocity_ele, vol_dshape_face(:, gi, :)) - strain = (strain + transpose(strain)) / 2.0 - tau(:, :, gi) = 2 * matmul(viscosity_ele(:, :, gi), strain) - end do + if(present(pressure_force)) then + do gi=1,sngi + force_at_quad(:, gi) = normal(:, gi) * face_pressure(gi) + end do + pressure_force = pressure_force + matmul(force_at_quad, face_detwei) end if + if(present(viscous_force)) then + do gi=1,sngi + force_at_quad(:, gi) = - matmul(normal(:, gi), tau(:, :, gi)) + end do + viscous_force = viscous_force + matmul(force_at_quad, face_detwei) + end if + end if + enddo + + call allsum(nfaces) + call allsum(sarea) + call allsum(force) + if(present(pressure_force)) call allsum(pressure_force) + if(present(viscous_force)) call allsum(viscous_force) + + ewrite(2,*) 'Integrated over this number of faces and total area: ', nfaces, sarea + ewrite(2, *) "Force on surface: ", force + if(present(pressure_force)) then + ewrite(2,*) 'Pressure force on surface: ', pressure_force + end if + if(present(viscous_force)) then + ewrite(2,*) 'Viscous force on surface: ', viscous_force + end if + + ewrite(1, *) "Exiting diagnostic_body_drag" + + end subroutine diagnostic_body_drag + + function calculate_surface_integral_scalar(s_field, positions, option_path) result(integral) + !!< Calculates a surface integral for the specified scalar field based upon + !!< options defined in the options tree + + type(scalar_field), intent(in) :: s_field + type(vector_field), intent(in) :: positions + character(len=*), intent(in) :: option_path + + real :: integral + + character(len = real_format_len() + 4) :: format_buffer + character(len = FIELD_NAME_LEN) :: integral_name, integral_type + integer, dimension(2) :: shape + integer, dimension(:), allocatable :: surface_ids + logical :: normalise + + if(have_option(trim(option_path) // "/surface_ids")) then + shape = option_shape(trim(option_path) // "/surface_ids") + assert(shape(1) >= 0) + allocate(surface_ids(shape(1))) + call get_option(trim(option_path) // "/surface_ids", surface_ids) + end if + + normalise = have_option(trim(option_path) // "/normalise") + + call get_option(trim(option_path) // "/type", integral_type) + select case(trim(integral_type)) + case("value") + if(allocated(surface_ids)) then + integral = surface_integral(s_field, positions, surface_ids = surface_ids, normalise = normalise) + else + integral = surface_integral(s_field, positions, normalise = normalise) + end if + case("gradient_normal") + if(allocated(surface_ids)) then + integral = gradient_normal_surface_integral(s_field, positions, surface_ids = surface_ids, normalise = normalise) + else + integral = gradient_normal_surface_integral(s_field, positions, normalise = normalise) + end if + case default + FLAbort("Invalid scalar field surface integral type: " // trim(integral_type)) + end select + + if(allocated(surface_ids)) then + deallocate(surface_ids) + end if + + call get_option(trim(option_path) // "/name", integral_name) + if(normalise) then + ewrite(2, *) "Normalised surface integral of type " // trim(integral_type) // " for field " // trim(s_field%name) // ":" + else + ewrite(2, *) "Surface integral of type " // trim(integral_type) // " for field " // trim(s_field%name) // ":" + end if + format_buffer = "(a," // real_format() // ")" + ewrite(2, format_buffer) trim(integral_name) // " = ", integral + + end function calculate_surface_integral_scalar + + function calculate_surface_integral_vector(v_field, positions, option_path) result(integral) + !!< Calculates a surface integral for the specified vector field based upon + !!< options defined in the options tree + + type(vector_field), intent(in) :: v_field + type(vector_field), intent(in) :: positions + character(len=*), intent(in) :: option_path + + real :: integral + + character(len = real_format_len() + 4) :: format_buffer + character(len = FIELD_NAME_LEN) :: integral_name, integral_type + integer, dimension(2) :: shape + integer, dimension(:), allocatable :: surface_ids + logical :: normalise + + if(have_option(trim(option_path) // "/surface_ids")) then + shape = option_shape(trim(option_path) // "/surface_ids") + assert(shape(1) >= 0) + allocate(surface_ids(shape(1))) + call get_option(trim(option_path) // "/surface_ids", surface_ids) + end if + + normalise = have_option(trim(option_path) // "/normalise") + + call get_option(trim(option_path) // "/type", integral_type) + select case(trim(integral_type)) + case("normal") + if(allocated(surface_ids)) then + integral = normal_surface_integral(v_field, positions, surface_ids = surface_ids, normalise = normalise) + else + integral = normal_surface_integral(v_field, positions, normalise = normalise) + end if + case default + FLAbort("Invalid vector field surface integral type: " // trim(integral_type)) + end select + + if(allocated(surface_ids)) then + deallocate(surface_ids) + end if + + call get_option(trim(option_path) // "/name", integral_name) + if(normalise) then + ewrite(2, *) "Normalised surface integral of type " // trim(integral_type) // " for field " // trim(v_field%name) // ":" + else + ewrite(2, *) "Surface integral of type " // trim(integral_type) // " for field " // trim(v_field%name) // ":" + end if + format_buffer = "(a," // real_format() // ")" + ewrite(2, format_buffer) trim(integral_name) // " = ", integral + + end function calculate_surface_integral_vector + + function calculate_surface_l2norm_scalar(s_field, positions, option_path) result(integral) + !!< Calculates a surface integral for the specified scalar field based upon + !!< options defined in the options tree + + type(scalar_field), intent(in) :: s_field + type(vector_field), intent(in) :: positions + character(len=*), intent(in) :: option_path + + real :: integral + + character(len = real_format_len() + 4) :: format_buffer + character(len = FIELD_NAME_LEN) :: integral_name + integer, dimension(2) :: shape + integer, dimension(:), allocatable :: surface_ids + logical :: normalise + + if(have_option(trim(option_path) // "/surface_ids")) then + shape = option_shape(trim(option_path) // "/surface_ids") + assert(shape(1) >= 0) + allocate(surface_ids(shape(1))) + call get_option(trim(option_path) // "/surface_ids", surface_ids) + end if + + normalise = have_option(trim(option_path) // "/normalise") + + if(allocated(surface_ids)) then + integral = surface_l2norm(s_field, positions, surface_ids = surface_ids, normalise = normalise) + else + integral = surface_l2norm(s_field, positions, normalise = normalise) + end if + + if(allocated(surface_ids)) then + deallocate(surface_ids) + end if + + call get_option(trim(option_path) // "/name", integral_name) + if(normalise) then + ewrite(2, *) "Normalised surface l2norm of field " // trim(s_field%name) // ":" + else + ewrite(2, *) "Surface l2norm of field " // trim(s_field%name) // ":" + end if + format_buffer = "(a," // real_format() // ")" + ewrite(2, format_buffer) trim(integral_name) // " = ", integral + + end function calculate_surface_l2norm_scalar + + function calculate_surface_l2norm_vector(v_field, positions, option_path) result(integral) + !!< Calculates a surface integral for the specified vector field based upon + !!< options defined in the options tree + + type(vector_field), intent(in) :: v_field + type(vector_field), intent(in) :: positions + character(len=*), intent(in) :: option_path + + real :: integral + + character(len = real_format_len() + 4) :: format_buffer + character(len = FIELD_NAME_LEN) :: integral_name + integer, dimension(2) :: shape + integer, dimension(:), allocatable :: surface_ids + logical :: normalise + + if(have_option(trim(option_path) // "/surface_ids")) then + shape = option_shape(trim(option_path) // "/surface_ids") + assert(shape(1) >= 0) + allocate(surface_ids(shape(1))) + call get_option(trim(option_path) // "/surface_ids", surface_ids) + end if + + normalise = have_option(trim(option_path) // "/normalise") + + if(allocated(surface_ids)) then + integral = surface_l2norm(v_field, positions, surface_ids = surface_ids, normalise = normalise) + else + integral = surface_l2norm(v_field, positions, normalise = normalise) + end if + + if(allocated(surface_ids)) then + deallocate(surface_ids) + end if + + call get_option(trim(option_path) // "/name", integral_name) + if(normalise) then + ewrite(2, *) "Normalised surface integral of field " // trim(v_field%name) // ":" + else + ewrite(2, *) "Surface integral of field " // trim(v_field%name) // ":" + end if + format_buffer = "(a," // real_format() // ")" + ewrite(2, format_buffer) trim(integral_name) // " = ", integral - end if - - face_pressure = face_val_at_quad(pressure, sele) - nfaces = nfaces + 1 - sarea = sarea + sum(face_detwei) - - - if(have_viscosity) then - do gi=1,sngi - force_at_quad(:, gi) = normal(:, gi) * face_pressure(gi) - matmul(normal(:, gi), tau(:, :, gi)) - end do - else - do gi=1,sngi - force_at_quad(:, gi) = normal(:, gi) * face_pressure(gi) - end do - end if - force = force + matmul(force_at_quad, face_detwei) - - if(present(pressure_force)) then - do gi=1,sngi - force_at_quad(:, gi) = normal(:, gi) * face_pressure(gi) - end do - pressure_force = pressure_force + matmul(force_at_quad, face_detwei) - end if - if(present(viscous_force)) then - do gi=1,sngi - force_at_quad(:, gi) = - matmul(normal(:, gi), tau(:, :, gi)) - end do - viscous_force = viscous_force + matmul(force_at_quad, face_detwei) - end if - end if - enddo - - call allsum(nfaces) - call allsum(sarea) - call allsum(force) - if(present(pressure_force)) call allsum(pressure_force) - if(present(viscous_force)) call allsum(viscous_force) - - ewrite(2,*) 'Integrated over this number of faces and total area: ', nfaces, sarea - ewrite(2, *) "Force on surface: ", force - if(present(pressure_force)) then - ewrite(2,*) 'Pressure force on surface: ', pressure_force - end if - if(present(viscous_force)) then - ewrite(2,*) 'Viscous force on surface: ', viscous_force - end if - - ewrite(1, *) "Exiting diagnostic_body_drag" - - end subroutine diagnostic_body_drag - - function calculate_surface_integral_scalar(s_field, positions, option_path) result(integral) - !!< Calculates a surface integral for the specified scalar field based upon - !!< options defined in the options tree - - type(scalar_field), intent(in) :: s_field - type(vector_field), intent(in) :: positions - character(len=*), intent(in) :: option_path - - real :: integral - - character(len = real_format_len() + 4) :: format_buffer - character(len = FIELD_NAME_LEN) :: integral_name, integral_type - integer, dimension(2) :: shape - integer, dimension(:), allocatable :: surface_ids - logical :: normalise - - if(have_option(trim(option_path) // "/surface_ids")) then - shape = option_shape(trim(option_path) // "/surface_ids") - assert(shape(1) >= 0) - allocate(surface_ids(shape(1))) - call get_option(trim(option_path) // "/surface_ids", surface_ids) - end if - - normalise = have_option(trim(option_path) // "/normalise") - - call get_option(trim(option_path) // "/type", integral_type) - select case(trim(integral_type)) - case("value") - if(allocated(surface_ids)) then - integral = surface_integral(s_field, positions, surface_ids = surface_ids, normalise = normalise) - else - integral = surface_integral(s_field, positions, normalise = normalise) - end if - case("gradient_normal") - if(allocated(surface_ids)) then - integral = gradient_normal_surface_integral(s_field, positions, surface_ids = surface_ids, normalise = normalise) - else - integral = gradient_normal_surface_integral(s_field, positions, normalise = normalise) - end if - case default - FLAbort("Invalid scalar field surface integral type: " // trim(integral_type)) - end select - - if(allocated(surface_ids)) then - deallocate(surface_ids) - end if - - call get_option(trim(option_path) // "/name", integral_name) - if(normalise) then - ewrite(2, *) "Normalised surface integral of type " // trim(integral_type) // " for field " // trim(s_field%name) // ":" - else - ewrite(2, *) "Surface integral of type " // trim(integral_type) // " for field " // trim(s_field%name) // ":" - end if - format_buffer = "(a," // real_format() // ")" - ewrite(2, format_buffer) trim(integral_name) // " = ", integral - - end function calculate_surface_integral_scalar - - function calculate_surface_integral_vector(v_field, positions, option_path) result(integral) - !!< Calculates a surface integral for the specified vector field based upon - !!< options defined in the options tree - - type(vector_field), intent(in) :: v_field - type(vector_field), intent(in) :: positions - character(len=*), intent(in) :: option_path - - real :: integral - - character(len = real_format_len() + 4) :: format_buffer - character(len = FIELD_NAME_LEN) :: integral_name, integral_type - integer, dimension(2) :: shape - integer, dimension(:), allocatable :: surface_ids - logical :: normalise - - if(have_option(trim(option_path) // "/surface_ids")) then - shape = option_shape(trim(option_path) // "/surface_ids") - assert(shape(1) >= 0) - allocate(surface_ids(shape(1))) - call get_option(trim(option_path) // "/surface_ids", surface_ids) - end if - - normalise = have_option(trim(option_path) // "/normalise") - - call get_option(trim(option_path) // "/type", integral_type) - select case(trim(integral_type)) - case("normal") - if(allocated(surface_ids)) then - integral = normal_surface_integral(v_field, positions, surface_ids = surface_ids, normalise = normalise) - else - integral = normal_surface_integral(v_field, positions, normalise = normalise) - end if - case default - FLAbort("Invalid vector field surface integral type: " // trim(integral_type)) - end select - - if(allocated(surface_ids)) then - deallocate(surface_ids) - end if - - call get_option(trim(option_path) // "/name", integral_name) - if(normalise) then - ewrite(2, *) "Normalised surface integral of type " // trim(integral_type) // " for field " // trim(v_field%name) // ":" - else - ewrite(2, *) "Surface integral of type " // trim(integral_type) // " for field " // trim(v_field%name) // ":" - end if - format_buffer = "(a," // real_format() // ")" - ewrite(2, format_buffer) trim(integral_name) // " = ", integral - - end function calculate_surface_integral_vector - - function calculate_surface_l2norm_scalar(s_field, positions, option_path) result(integral) - !!< Calculates a surface integral for the specified scalar field based upon - !!< options defined in the options tree - - type(scalar_field), intent(in) :: s_field - type(vector_field), intent(in) :: positions - character(len=*), intent(in) :: option_path - - real :: integral - - character(len = real_format_len() + 4) :: format_buffer - character(len = FIELD_NAME_LEN) :: integral_name - integer, dimension(2) :: shape - integer, dimension(:), allocatable :: surface_ids - logical :: normalise - - if(have_option(trim(option_path) // "/surface_ids")) then - shape = option_shape(trim(option_path) // "/surface_ids") - assert(shape(1) >= 0) - allocate(surface_ids(shape(1))) - call get_option(trim(option_path) // "/surface_ids", surface_ids) - end if - - normalise = have_option(trim(option_path) // "/normalise") - - if(allocated(surface_ids)) then - integral = surface_l2norm(s_field, positions, surface_ids = surface_ids, normalise = normalise) - else - integral = surface_l2norm(s_field, positions, normalise = normalise) - end if - - if(allocated(surface_ids)) then - deallocate(surface_ids) - end if - - call get_option(trim(option_path) // "/name", integral_name) - if(normalise) then - ewrite(2, *) "Normalised surface l2norm of field " // trim(s_field%name) // ":" - else - ewrite(2, *) "Surface l2norm of field " // trim(s_field%name) // ":" - end if - format_buffer = "(a," // real_format() // ")" - ewrite(2, format_buffer) trim(integral_name) // " = ", integral - - end function calculate_surface_l2norm_scalar - - function calculate_surface_l2norm_vector(v_field, positions, option_path) result(integral) - !!< Calculates a surface integral for the specified vector field based upon - !!< options defined in the options tree - - type(vector_field), intent(in) :: v_field - type(vector_field), intent(in) :: positions - character(len=*), intent(in) :: option_path - - real :: integral - - character(len = real_format_len() + 4) :: format_buffer - character(len = FIELD_NAME_LEN) :: integral_name - integer, dimension(2) :: shape - integer, dimension(:), allocatable :: surface_ids - logical :: normalise - - if(have_option(trim(option_path) // "/surface_ids")) then - shape = option_shape(trim(option_path) // "/surface_ids") - assert(shape(1) >= 0) - allocate(surface_ids(shape(1))) - call get_option(trim(option_path) // "/surface_ids", surface_ids) - end if - - normalise = have_option(trim(option_path) // "/normalise") - - if(allocated(surface_ids)) then - integral = surface_l2norm(v_field, positions, surface_ids = surface_ids, normalise = normalise) - else - integral = surface_l2norm(v_field, positions, normalise = normalise) - end if - - if(allocated(surface_ids)) then - deallocate(surface_ids) - end if - - call get_option(trim(option_path) // "/name", integral_name) - if(normalise) then - ewrite(2, *) "Normalised surface integral of field " // trim(v_field%name) // ":" - else - ewrite(2, *) "Surface integral of field " // trim(v_field%name) // ":" - end if - format_buffer = "(a," // real_format() // ")" - ewrite(2, format_buffer) trim(integral_name) // " = ", integral - - end function calculate_surface_l2norm_vector + end function calculate_surface_l2norm_vector end module surface_integrals diff --git a/femtools/Surface_Labels.F90 b/femtools/Surface_Labels.F90 index 0020f9e35a..fc38dd05ec 100644 --- a/femtools/Surface_Labels.F90 +++ b/femtools/Surface_Labels.F90 @@ -28,766 +28,766 @@ #include "fdebug.h" module SurfaceLabels - !!< These IDs are used to indicate how surface - !!< elements can be coarsened or refined. - - use fldebug - use vector_tools - use linked_lists - use mpi_interfaces - use parallel_tools - use data_structures - use sparse_tools - use elements - use adjacency_lists - use transform_elements, only: transform_facet_to_physical - use fetools, only : X_, Y_, Z_ - use fields - use merge_tensors - use vtk_interfaces - use halos - - implicit none - - private - public :: FindGeometryConstraints, & - get_coplanar_ids, reset_coplanar_ids, & - minimum_distance_to_line_segment - public :: connected_surfaces_count, surface_connectivity, & - & get_connected_surface_eles - - ! The magic numbers corresponds to what's used in libadapt - real, parameter:: COPLANAR_MAGIC_NUMBER=0.999999 + !!< These IDs are used to indicate how surface + !!< elements can be coarsened or refined. + + use fldebug + use vector_tools + use linked_lists + use mpi_interfaces + use parallel_tools + use data_structures + use sparse_tools + use elements + use adjacency_lists + use transform_elements, only: transform_facet_to_physical + use fetools, only : X_, Y_, Z_ + use fields + use merge_tensors + use vtk_interfaces + use halos + + implicit none + + private + public :: FindGeometryConstraints, & + get_coplanar_ids, reset_coplanar_ids, & + minimum_distance_to_line_segment + public :: connected_surfaces_count, surface_connectivity, & + & get_connected_surface_eles + + ! The magic numbers corresponds to what's used in libadapt + real, parameter:: COPLANAR_MAGIC_NUMBER=0.999999 contains - subroutine FindGeometryConstraints(positions, gconstraint) - type(vector_field), target, intent(in):: positions - real, dimension(:), intent(out):: gconstraint(:) - - integer :: NNodes, NElements, SNLOC - integer, dimension(:), allocatable:: ENList - integer, dimension(:), pointer:: SurfaceIds - real, dimension(:), pointer:: X, Y, Z - - integer i,j,nid,npatches,p - type(ilist), allocatable, dimension(:)::neigh - type(ilist) :: border, corner - type(elist) :: geom_edges - type(edgenode), pointer :: edge - type(inode), pointer::node, node_a, node_b - real bbox(6), V(9), A(3) - real length, u1, u2, u3, min_eigenvalue, dist, max_dist, min_dist - integer start_ele, n1, n2, ele - real, pointer, dimension(:, :)::tensor1, gtensor - - if (positions%dim/=3) then - FLExit("Geometric constraints currently only work in 3D.") - end if - - NNodes=node_count(positions) - NElements=unique_surface_element_count(positions%mesh) - SNLOC=face_loc(positions, 1) - X => positions%val(X_,:) - Y => positions%val(Y_,:) - Z => positions%val(Z_,:) - SurfaceIds => positions%mesh%faces%coplanar_ids - ! get surface element (global) node list - allocate(ENList(1:NElements*SNLOC)) - call getsndgln(positions%mesh, ENLIST) - - ! What surfaces meet at each node. - allocate(neigh(NNodes)) - do i=1, NElements - do j=1, snloc - nid = ENList((i-1)*snloc+j) - call insert_ascending(neigh(nid), SurfaceIds(i)) - end do - end do - - ! Find bounding box - bbox(1) = X(1) ; bbox(2) = X(1) - bbox(3) = Y(1) ; bbox(4) = Y(1) - bbox(5) = Z(1) ; bbox(6) = Z(1) - do i=2, NNodes - bbox(1) = min(X(i), bbox(1)) ; bbox(2) = max(X(i), bbox(2)) - bbox(3) = min(Y(i), bbox(3)) ; bbox(4) = max(Y(i), bbox(4)) - bbox(5) = min(Z(i), bbox(5)) ; bbox(6) = max(Z(i), bbox(6)) - end do - - ! Find the minimum eigenvalue that will be used for constraining - ! the metric. - max_dist = max(max(bbox(2)-bbox(1), bbox(4)-bbox(3)), bbox(6)-bbox(5)) - min_eigenvalue = 1.0/(max_dist**2) - - ! Initialise geometry constraints - gconstraint = 0.0 - do i=0, NNodes-1 - gconstraint(i*9+1) = 1.0/(bbox(2)-bbox(1))**2 - gconstraint(i*9+5) = 1.0/(bbox(4)-bbox(3))**2 - gconstraint(i*9+9) = 1.0/(bbox(6)-bbox(5))**2 - end do - - allocate(tensor1(3, 3), gtensor(3, 3)) - npatches = maxval(SurfaceIds) - - ! Loop over each patch, merging in the constraints from each patch - ! into the nodes that lie along geometry edges. - do p=1, npatches - - !ewrite(-1,*) "p == ", p - start_ele = -1 - ! identify border and corner nodes of this patch, na ja? - do ele=1,NElements - if(SurfaceIds(ele).ne.p) cycle - if (start_ele == -1) then - start_ele = ele - !ewrite(-1,*) "start_ele == ", start_ele - end if - do j=1,snloc - n1 = ENList((ele-1)*snloc+j) - if (neigh(n1)%length > 1) then - call insert(border, n1) - if (neigh(n1)%length > 2) then - call insert(corner, n1) - end if - end if - end do + subroutine FindGeometryConstraints(positions, gconstraint) + type(vector_field), target, intent(in):: positions + real, dimension(:), intent(out):: gconstraint(:) + + integer :: NNodes, NElements, SNLOC + integer, dimension(:), allocatable:: ENList + integer, dimension(:), pointer:: SurfaceIds + real, dimension(:), pointer:: X, Y, Z + + integer i,j,nid,npatches,p + type(ilist), allocatable, dimension(:)::neigh + type(ilist) :: border, corner + type(elist) :: geom_edges + type(edgenode), pointer :: edge + type(inode), pointer::node, node_a, node_b + real bbox(6), V(9), A(3) + real length, u1, u2, u3, min_eigenvalue, dist, max_dist, min_dist + integer start_ele, n1, n2, ele + real, pointer, dimension(:, :)::tensor1, gtensor + + if (positions%dim/=3) then + FLExit("Geometric constraints currently only work in 3D.") + end if + + NNodes=node_count(positions) + NElements=unique_surface_element_count(positions%mesh) + SNLOC=face_loc(positions, 1) + X => positions%val(X_,:) + Y => positions%val(Y_,:) + Z => positions%val(Z_,:) + SurfaceIds => positions%mesh%faces%coplanar_ids + ! get surface element (global) node list + allocate(ENList(1:NElements*SNLOC)) + call getsndgln(positions%mesh, ENLIST) + + ! What surfaces meet at each node. + allocate(neigh(NNodes)) + do i=1, NElements + do j=1, snloc + nid = ENList((i-1)*snloc+j) + call insert_ascending(neigh(nid), SurfaceIds(i)) + end do end do - ! in parallel we have global coplanar ids, that are non-consecutive on the local process - if (start_ele == -1) cycle - - ! from the corner nodes, identify the geometry edges - node_A => corner%firstnode - do while(associated(node_A)) - node_B => corner%firstnode - do while(associated(node_B)) - if (node_A%value /= node_B%value) then - if (size_intersection(neigh(node_A%value), neigh(node_B%value)) > 1) then - if (.not. has_value(geom_edges, node_A%value, node_B%value) .and. & - .not. has_value(geom_edges, node_B%value, node_A%value)) then - !ewrite(-1,'(a, i0, a, i0, a)') "edge: (", node_A%value, ", ", node_B%value, ")" - call insert(geom_edges, node_A%value, node_B%value) - end if - end if - end if - node_B => node_B%next - end do - node_A => node_A%next + ! Find bounding box + bbox(1) = X(1) ; bbox(2) = X(1) + bbox(3) = Y(1) ; bbox(4) = Y(1) + bbox(5) = Z(1) ; bbox(6) = Z(1) + do i=2, NNodes + bbox(1) = min(X(i), bbox(1)) ; bbox(2) = max(X(i), bbox(2)) + bbox(3) = min(Y(i), bbox(3)) ; bbox(4) = max(Y(i), bbox(4)) + bbox(5) = min(Z(i), bbox(5)) ; bbox(6) = max(Z(i), bbox(6)) end do - ! Let the first eigenvector be the first edge of the surface - V(1) = x(enlist((start_ele-1)*snloc+1))-x(enlist((start_ele-1)*snloc+2)) - V(2) = y(enlist((start_ele-1)*snloc+1))-y(enlist((start_ele-1)*snloc+2)) - V(3) = z(enlist((start_ele-1)*snloc+1))-z(enlist((start_ele-1)*snloc+2)) - length = sqrt(V(1)**2+V(2)**2+V(3)**2) - V(1) = V(1)/length - V(2) = V(2)/length - V(3) = V(3)/length - - !ewrite(-1,*) "1st eigenvector: ", (/v(1), v(2), v(3)/) - - ! The second eigenvector is the surface normal - u1 = x(enlist((start_ele-1)*snloc+1))-x(enlist((start_ele-1)*snloc+3)) - u2 = y(enlist((start_ele-1)*snloc+1))-y(enlist((start_ele-1)*snloc+3)) - u3 = z(enlist((start_ele-1)*snloc+1))-z(enlist((start_ele-1)*snloc+3)) - V(4) = u2*V(3) - u3*V(2) - V(5) = -u1*V(3) + u3*V(1) - V(6) = u1*V(2) - u2*V(1) - length = sqrt(V(4)**2+V(5)**2+V(6)**2) - V(4) = V(4)/length - V(5) = V(5)/length - V(6) = V(6)/length - - !ewrite(-1,*) "2nd eigenvector: ", (/v(4), v(5), v(6)/) - - ! The third eigenvector is the cross product of the other two - V(7:9) = cross_product(V(1:3), V(4:6)) - - !ewrite(-1,*) "3rd eigenvector: ", (/v(7), v(8), v(9)/) - - ! Loop through all boundary nodes and get distance to the - ! geometry edges which it's not a element of. - node => border%firstnode - do while(associated(node)) - !ewrite(-1,*) "---------------------------------------------------" - !ewrite(-1,*) "node == ", node%value - !ewrite(-1,*) "position == ", x(node%value), y(node%value), z(node%value) - min_dist = max_dist - edge => geom_edges%firstnode - do while(associated(edge)) - n1 = edge%i - n2 = edge%j - if (node%value /= n1 .and. node%value /= n2) then - dist = minimum_distance_to_line_segment( & - (/X(node%value), Y(node%value), Z(node%value)/), & - (/X(n1), Y(n1), Z(n1)/), & - (/X(n2), Y(n2), Z(n2)/)) - - !ewrite(-1,*) " -- n1: == ", n1, ";", (/X(n1), Y(n1), Z(n1)/) - !ewrite(-1,*) " -- n2: == ", n2, ";", (/X(n2), Y(n2), Z(n2)/) - !ewrite(-1,*) " -- dist == ", dist - - if (dist > epsilon(0.0_4)) then - min_dist = min(min_dist, dist) + ! Find the minimum eigenvalue that will be used for constraining + ! the metric. + max_dist = max(max(bbox(2)-bbox(1), bbox(4)-bbox(3)), bbox(6)-bbox(5)) + min_eigenvalue = 1.0/(max_dist**2) + + ! Initialise geometry constraints + gconstraint = 0.0 + do i=0, NNodes-1 + gconstraint(i*9+1) = 1.0/(bbox(2)-bbox(1))**2 + gconstraint(i*9+5) = 1.0/(bbox(4)-bbox(3))**2 + gconstraint(i*9+9) = 1.0/(bbox(6)-bbox(5))**2 + end do + + allocate(tensor1(3, 3), gtensor(3, 3)) + npatches = maxval(SurfaceIds) + + ! Loop over each patch, merging in the constraints from each patch + ! into the nodes that lie along geometry edges. + do p=1, npatches + + !ewrite(-1,*) "p == ", p + start_ele = -1 + ! identify border and corner nodes of this patch, na ja? + do ele=1,NElements + if(SurfaceIds(ele).ne.p) cycle + if (start_ele == -1) then + start_ele = ele + !ewrite(-1,*) "start_ele == ", start_ele end if + do j=1,snloc + n1 = ENList((ele-1)*snloc+j) + if (neigh(n1)%length > 1) then + call insert(border, n1) + if (neigh(n1)%length > 2) then + call insert(corner, n1) + end if + end if + end do + end do + + ! in parallel we have global coplanar ids, that are non-consecutive on the local process + if (start_ele == -1) cycle + + ! from the corner nodes, identify the geometry edges + node_A => corner%firstnode + do while(associated(node_A)) + node_B => corner%firstnode + do while(associated(node_B)) + if (node_A%value /= node_B%value) then + if (size_intersection(neigh(node_A%value), neigh(node_B%value)) > 1) then + if (.not. has_value(geom_edges, node_A%value, node_B%value) .and. & + .not. has_value(geom_edges, node_B%value, node_A%value)) then + !ewrite(-1,'(a, i0, a, i0, a)') "edge: (", node_A%value, ", ", node_B%value, ")" + call insert(geom_edges, node_A%value, node_B%value) + end if + end if + end if + node_B => node_B%next + end do + node_A => node_A%next + end do + + ! Let the first eigenvector be the first edge of the surface + V(1) = x(enlist((start_ele-1)*snloc+1))-x(enlist((start_ele-1)*snloc+2)) + V(2) = y(enlist((start_ele-1)*snloc+1))-y(enlist((start_ele-1)*snloc+2)) + V(3) = z(enlist((start_ele-1)*snloc+1))-z(enlist((start_ele-1)*snloc+2)) + length = sqrt(V(1)**2+V(2)**2+V(3)**2) + V(1) = V(1)/length + V(2) = V(2)/length + V(3) = V(3)/length + + !ewrite(-1,*) "1st eigenvector: ", (/v(1), v(2), v(3)/) + + ! The second eigenvector is the surface normal + u1 = x(enlist((start_ele-1)*snloc+1))-x(enlist((start_ele-1)*snloc+3)) + u2 = y(enlist((start_ele-1)*snloc+1))-y(enlist((start_ele-1)*snloc+3)) + u3 = z(enlist((start_ele-1)*snloc+1))-z(enlist((start_ele-1)*snloc+3)) + V(4) = u2*V(3) - u3*V(2) + V(5) = -u1*V(3) + u3*V(1) + V(6) = u1*V(2) - u2*V(1) + length = sqrt(V(4)**2+V(5)**2+V(6)**2) + V(4) = V(4)/length + V(5) = V(5)/length + V(6) = V(6)/length + + !ewrite(-1,*) "2nd eigenvector: ", (/v(4), v(5), v(6)/) + + ! The third eigenvector is the cross product of the other two + V(7:9) = cross_product(V(1:3), V(4:6)) + + !ewrite(-1,*) "3rd eigenvector: ", (/v(7), v(8), v(9)/) + + ! Loop through all boundary nodes and get distance to the + ! geometry edges which it's not a element of. + node => border%firstnode + do while(associated(node)) + !ewrite(-1,*) "---------------------------------------------------" + !ewrite(-1,*) "node == ", node%value + !ewrite(-1,*) "position == ", x(node%value), y(node%value), z(node%value) + min_dist = max_dist + edge => geom_edges%firstnode + do while(associated(edge)) + n1 = edge%i + n2 = edge%j + if (node%value /= n1 .and. node%value /= n2) then + dist = minimum_distance_to_line_segment( & + (/X(node%value), Y(node%value), Z(node%value)/), & + (/X(n1), Y(n1), Z(n1)/), & + (/X(n2), Y(n2), Z(n2)/)) + + !ewrite(-1,*) " -- n1: == ", n1, ";", (/X(n1), Y(n1), Z(n1)/) + !ewrite(-1,*) " -- n2: == ", n2, ";", (/X(n2), Y(n2), Z(n2)/) + !ewrite(-1,*) " -- dist == ", dist + + if (dist > epsilon(0.0_4)) then + min_dist = min(min_dist, dist) + end if + !ewrite(-1,*) " -- min_dist == ", min_dist + end if + edge => edge%next + end do + !ewrite(-1,*) " -- min_dist == ", min_dist - end if - edge => edge%next - end do - - !ewrite(-1,*) " -- min_dist == ", min_dist - min_dist = min_dist - ! Form eigenvalues - A(1) = 1.0/min_dist**2 - A(2) = 1.0/min_dist**2 - !A(2) = min_eigenvalue; - A(3) = 1.0/min_dist**2 - - ! Form g-constraint tensor - call eigenrecomposition(gtensor, reshape(V, (/3, 3/)), A) - - ! Merge constraints - tensor1 = reshape(gconstraint((node%value-1)*9+1:node%value*9), (/3, 3/)) - call merge_tensor(tensor1, gtensor) - - gconstraint((node%value-1)*9+1:node%value*9) = reshape(tensor1, (/9/)) - node => node%next + min_dist = min_dist + ! Form eigenvalues + A(1) = 1.0/min_dist**2 + A(2) = 1.0/min_dist**2 + !A(2) = min_eigenvalue; + A(3) = 1.0/min_dist**2 + + ! Form g-constraint tensor + call eigenrecomposition(gtensor, reshape(V, (/3, 3/)), A) + + ! Merge constraints + tensor1 = reshape(gconstraint((node%value-1)*9+1:node%value*9), (/3, 3/)) + call merge_tensor(tensor1, gtensor) + + gconstraint((node%value-1)*9+1:node%value*9) = reshape(tensor1, (/9/)) + node => node%next + end do + + call flush_list(border) + call flush_list(corner) + call flush_list(geom_edges) end do - call flush_list(border) - call flush_list(corner) - call flush_list(geom_edges) - end do - - ! Delete neighbour list - do i=1, NNodes - call flush_list(neigh(i)) - end do - deallocate(neigh) - - ! Delete various arrays - deallocate(tensor1, gtensor) - deallocate(ENList) - - end subroutine FindGeometryConstraints - - subroutine get_coplanar_ids(mesh, positions, coplanar_ids) - !!< Returns a pointer to an array of coplanar ids that assigns - !!< a unique id to each coplanar patch of the surface mesh of "mesh". - !!< The calculated coplanar_ids are caches inside the mesh, so that if - !!< this routine is called again they are exactly the same. - type(mesh_type), intent(inout):: mesh - type(vector_field), intent(in):: positions - integer, dimension(:), pointer:: coplanar_ids - type(mesh_type), pointer:: surface_mesh - type(ilist) front - real, allocatable, dimension(:,:):: normalgi, normals - real, allocatable, dimension(:):: detwei_f - real coplanar - integer, dimension(:), pointer:: neigh, nodes - integer current_id, sngi, stotel - integer j, k, sele, sele2, pos, ele - - ewrite(1,*) "Inside get_coplanar_ids" - - if (.not. has_faces(mesh)) then - call add_faces(mesh) - end if - - stotel = surface_element_count(mesh) - - if (.not. associated(mesh%faces%coplanar_ids)) then - allocate(mesh%faces%coplanar_ids(1:stotel)) - coplanar_ids => mesh%faces%coplanar_ids - else - ! we assume they have been calculated already: - coplanar_ids => mesh%faces%coplanar_ids - return - end if - - if(stotel == 0) then - sngi = 0 - else - sngi = face_ngi(mesh, 1) - end if - surface_mesh => mesh%faces%surface_mesh - - allocate(normalgi(positions%dim,sngi), detwei_f(sngi)) - - ! Calculate element normals for all surface elements - allocate(normals(positions%dim, stotel)) - do sele=1, stotel - ele=face_ele(mesh, sele) - call transform_facet_to_physical( & - positions, sele, detwei_f, normalgi) - ! average over gauss points: - normals(:,sele)=matmul(normalgi, detwei_f)/sum(detwei_f) - end do - deallocate(normalgi, detwei_f) - - ! create node-element list for surface mesh - ! (Note that we can't always construct an eelist, which would have been - ! more useful, because the surface mesh may split (for instance where an - ! external boundary meets an internal boundary) in which case multiple - ! surface elements can be connected via the same edge (facet of the surface element)) - call add_nelist(surface_mesh) - - coplanar_ids = 0 - current_id = 1 - pos = 1 - do while (.true.) - ! Create a new starting point by finding a surface element without coplanar id - do sele=pos, stotel - if(coplanar_ids(sele)==0) exit - end do - - ! Jump out of this while loop if we are finished - if (sele>stotel) exit - - ! This is the first element in the new patch - pos = sele - coplanar_ids(pos) = current_id - ! Initialise the front - call insert_ascending(front, pos) - - ! Advance this front - do while (front%length.ne.0) - sele = pop(front) - - ! surrounding surface elements: - ! note that we not only consider directly adjacent surface elements, - ! but also surface elements that only connect via one other node, as - ! long as they have a normal in the same direction however they should - ! be on the same plane - nodes => ele_nodes(surface_mesh, sele) - do j=1, size(nodes) - ! loop over surface elements connected to nodes(j) - neigh => node_neigh(surface_mesh, nodes(j)) - do k=1, size(neigh) - sele2 = neigh(k) - if(coplanar_ids(sele2)==0) then - coplanar = abs(dot_product(normals(:,pos), normals(:,sele2))) - if(coplanar>=COPLANAR_MAGIC_NUMBER) then - - call insert_ascending(front, sele2) - coplanar_ids(sele2) = current_id - end if - end if - end do - end do - end do - - current_id = current_id + 1 - pos = pos + 1 - end do - deallocate(normals) - - ewrite(2,*) "Before merge_surface_ids, n/o local coplanes:", current_id-1 - - call merge_surface_ids(mesh, coplanar_ids, max_id = current_id - 1) - - end subroutine get_coplanar_ids - - subroutine vtk_write_coplanar_ids(filename, positions, coplanar_ids) - character(len = *), intent(in) :: filename - type(vector_field), intent(inout) :: positions - integer, dimension(surface_element_count(positions)), intent(in) :: coplanar_ids - - integer, dimension(:), allocatable :: old_coplanar_ids - - assert(has_faces(positions%mesh)) - if(.not. associated(positions%mesh%faces%coplanar_ids)) then - allocate(positions%mesh%faces%coplanar_ids(size(coplanar_ids))) - positions%mesh%faces%coplanar_ids = coplanar_ids - - call vtk_write_surface_mesh(filename, position = positions) - - deallocate(positions%mesh%faces%coplanar_ids) - nullify(positions%mesh%faces%coplanar_ids) - else - allocate(old_coplanar_ids(size(coplanar_ids))) - old_coplanar_ids = positions%mesh%faces%coplanar_ids - positions%mesh%faces%coplanar_ids = coplanar_ids - - call vtk_write_surface_mesh(filename, position = positions) - - positions%mesh%faces%coplanar_ids = old_coplanar_ids - deallocate(old_coplanar_ids) - end if - - end subroutine vtk_write_coplanar_ids - - subroutine merge_surface_ids(mesh, surface_ids, max_id) - !!< Given a local set of surface IDs on a mesh, merge the surface IDs - !!< across all processes - - type(mesh_type), intent(inout) :: mesh - integer, dimension(surface_element_count(mesh)), intent(inout) :: surface_ids - integer, optional, intent(in) :: max_id + ! Delete neighbour list + do i=1, NNodes + call flush_list(neigh(i)) + end do + deallocate(neigh) + + ! Delete various arrays + deallocate(tensor1, gtensor) + deallocate(ENList) + + end subroutine FindGeometryConstraints + + subroutine get_coplanar_ids(mesh, positions, coplanar_ids) + !!< Returns a pointer to an array of coplanar ids that assigns + !!< a unique id to each coplanar patch of the surface mesh of "mesh". + !!< The calculated coplanar_ids are caches inside the mesh, so that if + !!< this routine is called again they are exactly the same. + type(mesh_type), intent(inout):: mesh + type(vector_field), intent(in):: positions + integer, dimension(:), pointer:: coplanar_ids + type(mesh_type), pointer:: surface_mesh + type(ilist) front + real, allocatable, dimension(:,:):: normalgi, normals + real, allocatable, dimension(:):: detwei_f + real coplanar + integer, dimension(:), pointer:: neigh, nodes + integer current_id, sngi, stotel + integer j, k, sele, sele2, pos, ele + + ewrite(1,*) "Inside get_coplanar_ids" + + if (.not. has_faces(mesh)) then + call add_faces(mesh) + end if -#ifdef HAVE_MPI - integer :: comm, communicator, face, i, id_base, ierr, j, lmax_id, new_id, & - & nhalos, nprocs, nsele, old_id, procno - integer, dimension(:), allocatable :: requests, statuses - integer, parameter :: max_comm_count = 100 - logical :: complete - type(integer_hash_table) :: id_map - type(integer_vector), dimension(:), allocatable :: receive_buffer, & - & send_buffer - type(halo_type) :: sele_halo - type(halo_type), pointer :: ele_halo - integer tag + stotel = surface_element_count(mesh) + + if (.not. associated(mesh%faces%coplanar_ids)) then + allocate(mesh%faces%coplanar_ids(1:stotel)) + coplanar_ids => mesh%faces%coplanar_ids + else + ! we assume they have been calculated already: + coplanar_ids => mesh%faces%coplanar_ids + return + end if - ewrite(1, *) "In merge_surface_ids" + if(stotel == 0) then + sngi = 0 + else + sngi = face_ngi(mesh, 1) + end if + surface_mesh => mesh%faces%surface_mesh + + allocate(normalgi(positions%dim,sngi), detwei_f(sngi)) + + ! Calculate element normals for all surface elements + allocate(normals(positions%dim, stotel)) + do sele=1, stotel + ele=face_ele(mesh, sele) + call transform_facet_to_physical( & + positions, sele, detwei_f, normalgi) + ! average over gauss points: + normals(:,sele)=matmul(normalgi, detwei_f)/sum(detwei_f) + end do + deallocate(normalgi, detwei_f) + + ! create node-element list for surface mesh + ! (Note that we can't always construct an eelist, which would have been + ! more useful, because the surface mesh may split (for instance where an + ! external boundary meets an internal boundary) in which case multiple + ! surface elements can be connected via the same edge (facet of the surface element)) + call add_nelist(surface_mesh) + + coplanar_ids = 0 + current_id = 1 + pos = 1 + do while (.true.) + ! Create a new starting point by finding a surface element without coplanar id + do sele=pos, stotel + if(coplanar_ids(sele)==0) exit + end do + + ! Jump out of this while loop if we are finished + if (sele>stotel) exit + + ! This is the first element in the new patch + pos = sele + coplanar_ids(pos) = current_id + ! Initialise the front + call insert_ascending(front, pos) + + ! Advance this front + do while (front%length.ne.0) + sele = pop(front) + + ! surrounding surface elements: + ! note that we not only consider directly adjacent surface elements, + ! but also surface elements that only connect via one other node, as + ! long as they have a normal in the same direction however they should + ! be on the same plane + nodes => ele_nodes(surface_mesh, sele) + do j=1, size(nodes) + ! loop over surface elements connected to nodes(j) + neigh => node_neigh(surface_mesh, nodes(j)) + do k=1, size(neigh) + sele2 = neigh(k) + if(coplanar_ids(sele2)==0) then + coplanar = abs(dot_product(normals(:,pos), normals(:,sele2))) + if(coplanar>=COPLANAR_MAGIC_NUMBER) then + + call insert_ascending(front, sele2) + coplanar_ids(sele2) = current_id + end if + end if + end do + end do + end do + + current_id = current_id + 1 + pos = pos + 1 + end do + deallocate(normals) - nhalos = element_halo_count(mesh) - if(nhalos == 0) return - ele_halo => mesh%element_halos(nhalos) - if(serial_storage_halo(ele_halo)) return + ewrite(2,*) "Before merge_surface_ids, n/o local coplanes:", current_id-1 - communicator = halo_communicator(ele_halo) - nprocs = halo_proc_count(ele_halo) - procno = getprocno(communicator = communicator) - nsele = surface_element_count(mesh) + call merge_surface_ids(mesh, coplanar_ids, max_id = current_id - 1) - ! First things first: Make sure all IDs are unique across all processes + end subroutine get_coplanar_ids - if(present(max_id)) then - lmax_id = max_id - else - lmax_id = maxval(surface_ids) - end if - call mpi_scan(lmax_id, id_base, 1, getpinteger(), MPI_SUM, communicator, ierr) - assert(ierr == MPI_SUCCESS) - id_base = id_base - lmax_id - surface_ids = surface_ids + id_base + subroutine vtk_write_coplanar_ids(filename, positions, coplanar_ids) + character(len = *), intent(in) :: filename + type(vector_field), intent(inout) :: positions + integer, dimension(surface_element_count(positions)), intent(in) :: coplanar_ids - ! Derive the maximal surface element halo + integer, dimension(:), allocatable :: old_coplanar_ids - sele_halo = derive_maximal_surface_element_halo(mesh, ele_halo, & - & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) + assert(has_faces(positions%mesh)) + if(.not. associated(positions%mesh%faces%coplanar_ids)) then + allocate(positions%mesh%faces%coplanar_ids(size(coplanar_ids))) + positions%mesh%faces%coplanar_ids = coplanar_ids + + call vtk_write_surface_mesh(filename, position = positions) + + deallocate(positions%mesh%faces%coplanar_ids) + nullify(positions%mesh%faces%coplanar_ids) + else + allocate(old_coplanar_ids(size(coplanar_ids))) + old_coplanar_ids = positions%mesh%faces%coplanar_ids + positions%mesh%faces%coplanar_ids = coplanar_ids + + call vtk_write_surface_mesh(filename, position = positions) - allocate(send_buffer(nprocs)) - allocate(receive_buffer(nprocs)) - do i = 1, nprocs - allocate(send_buffer(i)%ptr(halo_send_count(sele_halo, i))) - allocate(receive_buffer(i)%ptr(halo_receive_count(sele_halo, i))) - end do - allocate(requests(nprocs * 2)) - allocate(statuses(MPI_STATUS_SIZE * size(requests))) - comm = 0 - comm_loop: do - ! We loop until all new surface IDs match the incoming old surface IDs. - ! This can take multiple communications, as we may need to merge areas of - ! the surface on non-adjacent processes. - - comm = comm + 1 - if(comm > max_comm_count) then - ! Congratulations, you have two processes more than max_comm_count - ! partitions apart on a single surface. Increase max_comm_count or write - ! a divide and conquer algorithm for the indirect merges. - FLAbort("Maximum communication count encountered in merge_surface_ids") + positions%mesh%faces%coplanar_ids = old_coplanar_ids + deallocate(old_coplanar_ids) end if - ewrite(2, *) "Performing surface merge ", comm - ! Pack the old surface IDs for sending + end subroutine vtk_write_coplanar_ids - do i = 1, nprocs - do j = 1, halo_send_count(sele_halo, i) - face = halo_send(sele_halo, i, j) - old_id = surface_ids(face) - send_buffer(i)%ptr(j) = old_id - end do - end do + subroutine merge_surface_ids(mesh, surface_ids, max_id) + !!< Given a local set of surface IDs on a mesh, merge the surface IDs + !!< across all processes - ! Communicate the old surface IDs - requests = MPI_REQUEST_NULL - tag = next_mpi_tag() + type(mesh_type), intent(inout) :: mesh + integer, dimension(surface_element_count(mesh)), intent(inout) :: surface_ids + integer, optional, intent(in) :: max_id - do i = 1, nprocs - ! Non-blocking sends - if(size(send_buffer(i)%ptr) > 0) then - call mpi_isend(send_buffer(i)%ptr, size(send_buffer(i)%ptr), getpinteger(), i - 1, tag, communicator, requests(i), ierr) - assert(ierr == MPI_SUCCESS) - end if - - ! Non-blocking receives - if(size(receive_buffer(i)%ptr) > 0) then - call mpi_irecv(receive_buffer(i)%ptr, size(receive_buffer(i)%ptr), getpinteger(), i - 1, tag, communicator, requests(i + nprocs), ierr) - assert(ierr == MPI_SUCCESS) - end if - end do +#ifdef HAVE_MPI + integer :: comm, communicator, face, i, id_base, ierr, j, lmax_id, new_id, & + & nhalos, nprocs, nsele, old_id, procno + integer, dimension(:), allocatable :: requests, statuses + integer, parameter :: max_comm_count = 100 + logical :: complete + type(integer_hash_table) :: id_map + type(integer_vector), dimension(:), allocatable :: receive_buffer, & + & send_buffer + type(halo_type) :: sele_halo + type(halo_type), pointer :: ele_halo + integer tag - ! Wait for all non-blocking communications to complete - call mpi_waitall(size(requests), requests, statuses, ierr) - assert(ierr == MPI_SUCCESS) + ewrite(1, *) "In merge_surface_ids" - ! Generate a map "id_map", mapping surface IDs to their new (merged) - ! values. The new surface ID chosen is the lowest ID received overlaying - ! the old surface ID. + nhalos = element_halo_count(mesh) + if(nhalos == 0) return + ele_halo => mesh%element_halos(nhalos) + if(serial_storage_halo(ele_halo)) return - call allocate(id_map) - do i = 1, nprocs - do j = 1, halo_receive_count(sele_halo, i) - new_id = receive_buffer(i)%ptr(j) - old_id = surface_ids(halo_receive(sele_halo, i, j)) - - if(new_id == old_id) then - ! This has already been merged - cycle - else if(new_id > old_id) then - ! The incoming ID is larger than the existing ID. The sender should - ! be swapping out its corresponding ID for the one on this process. - cycle - else if(has_key(id_map, old_id)) then - if(fetch(id_map, old_id) <= new_id) then - ! This is already being mapped to a lower or equal ID - cycle - end if - end if + communicator = halo_communicator(ele_halo) + nprocs = halo_proc_count(ele_halo) + procno = getprocno(communicator = communicator) + nsele = surface_element_count(mesh) - call insert(id_map, old_id, new_id) - end do - end do + ! First things first: Make sure all IDs are unique across all processes - ! This is where a divide and conquer algorithm would live. We need to - ! communicate (for comm > 1) information from the map id_map: - ! old_id -> new_id - ! between each process sharing a given common old_id. - - ewrite(2, *) "Number of merged surface IDs: ", key_count(id_map) - complete = (key_count(id_map) == 0) - call alland(complete, communicator = communicator) - if(complete) then - ! We have no more indirect merges - we're done - call deallocate(id_map) - exit comm_loop + if(present(max_id)) then + lmax_id = max_id + else + lmax_id = maxval(surface_ids) end if - ! We're changing IDs. Hence we have to check for indirect merges. + call mpi_scan(lmax_id, id_base, 1, getpinteger(), MPI_SUM, communicator, ierr) + assert(ierr == MPI_SUCCESS) + id_base = id_base - lmax_id + surface_ids = surface_ids + id_base + + ! Derive the maximal surface element halo - ! Remap the surface IDs + sele_halo = derive_maximal_surface_element_halo(mesh, ele_halo, & + & ordering_scheme = HALO_ORDER_GENERAL, create_caches = .false.) - do i = 1, nsele - if(has_key(id_map, surface_ids(i))) then - surface_ids(i) = fetch(id_map, surface_ids(i)) - end if + allocate(send_buffer(nprocs)) + allocate(receive_buffer(nprocs)) + do i = 1, nprocs + allocate(send_buffer(i)%ptr(halo_send_count(sele_halo, i))) + allocate(receive_buffer(i)%ptr(halo_receive_count(sele_halo, i))) end do - call deallocate(id_map) - - ! We have to check for indirect merges (merges with processes that are not - ! adjacent to this one). Let's go around again ... - end do comm_loop - call deallocate(sele_halo) - do i = 1, nprocs - deallocate(send_buffer(i)%ptr) - deallocate(receive_buffer(i)%ptr) - end do - deallocate(send_buffer) - deallocate(receive_buffer) - deallocate(statuses) - deallocate(requests) - - ewrite(1, *) "Exiting merge_surface_ids" + allocate(requests(nprocs * 2)) + allocate(statuses(MPI_STATUS_SIZE * size(requests))) + comm = 0 + comm_loop: do + ! We loop until all new surface IDs match the incoming old surface IDs. + ! This can take multiple communications, as we may need to merge areas of + ! the surface on non-adjacent processes. + + comm = comm + 1 + if(comm > max_comm_count) then + ! Congratulations, you have two processes more than max_comm_count + ! partitions apart on a single surface. Increase max_comm_count or write + ! a divide and conquer algorithm for the indirect merges. + FLAbort("Maximum communication count encountered in merge_surface_ids") + end if + ewrite(2, *) "Performing surface merge ", comm + + ! Pack the old surface IDs for sending + + do i = 1, nprocs + do j = 1, halo_send_count(sele_halo, i) + face = halo_send(sele_halo, i, j) + old_id = surface_ids(face) + send_buffer(i)%ptr(j) = old_id + end do + end do + + ! Communicate the old surface IDs + requests = MPI_REQUEST_NULL + tag = next_mpi_tag() + + do i = 1, nprocs + ! Non-blocking sends + if(size(send_buffer(i)%ptr) > 0) then + call mpi_isend(send_buffer(i)%ptr, size(send_buffer(i)%ptr), getpinteger(), i - 1, tag, communicator, requests(i), ierr) + assert(ierr == MPI_SUCCESS) + end if + + ! Non-blocking receives + if(size(receive_buffer(i)%ptr) > 0) then + call mpi_irecv(receive_buffer(i)%ptr, size(receive_buffer(i)%ptr), getpinteger(), i - 1, tag, communicator, requests(i + nprocs), ierr) + assert(ierr == MPI_SUCCESS) + end if + end do + + ! Wait for all non-blocking communications to complete + call mpi_waitall(size(requests), requests, statuses, ierr) + assert(ierr == MPI_SUCCESS) + + ! Generate a map "id_map", mapping surface IDs to their new (merged) + ! values. The new surface ID chosen is the lowest ID received overlaying + ! the old surface ID. + + call allocate(id_map) + do i = 1, nprocs + do j = 1, halo_receive_count(sele_halo, i) + new_id = receive_buffer(i)%ptr(j) + old_id = surface_ids(halo_receive(sele_halo, i, j)) + + if(new_id == old_id) then + ! This has already been merged + cycle + else if(new_id > old_id) then + ! The incoming ID is larger than the existing ID. The sender should + ! be swapping out its corresponding ID for the one on this process. + cycle + else if(has_key(id_map, old_id)) then + if(fetch(id_map, old_id) <= new_id) then + ! This is already being mapped to a lower or equal ID + cycle + end if + end if + + call insert(id_map, old_id, new_id) + end do + end do + + ! This is where a divide and conquer algorithm would live. We need to + ! communicate (for comm > 1) information from the map id_map: + ! old_id -> new_id + ! between each process sharing a given common old_id. + + ewrite(2, *) "Number of merged surface IDs: ", key_count(id_map) + complete = (key_count(id_map) == 0) + call alland(complete, communicator = communicator) + if(complete) then + ! We have no more indirect merges - we're done + call deallocate(id_map) + exit comm_loop + end if + ! We're changing IDs. Hence we have to check for indirect merges. + + ! Remap the surface IDs + + do i = 1, nsele + if(has_key(id_map, surface_ids(i))) then + surface_ids(i) = fetch(id_map, surface_ids(i)) + end if + end do + call deallocate(id_map) + + ! We have to check for indirect merges (merges with processes that are not + ! adjacent to this one). Let's go around again ... + end do comm_loop + call deallocate(sele_halo) + do i = 1, nprocs + deallocate(send_buffer(i)%ptr) + deallocate(receive_buffer(i)%ptr) + end do + deallocate(send_buffer) + deallocate(receive_buffer) + deallocate(statuses) + deallocate(requests) + + ewrite(1, *) "Exiting merge_surface_ids" #endif - end subroutine merge_surface_ids + end subroutine merge_surface_ids - subroutine reset_coplanar_ids(mesh) - type(mesh_type), intent(inout):: mesh + subroutine reset_coplanar_ids(mesh) + type(mesh_type), intent(inout):: mesh - if (.not. has_faces(mesh)) then - FLAbort("Need to have faces to reset_coplanar_ids") - end if - nullify(mesh%faces%coplanar_ids) + if (.not. has_faces(mesh)) then + FLAbort("Need to have faces to reset_coplanar_ids") + end if + nullify(mesh%faces%coplanar_ids) - end subroutine reset_coplanar_ids + end subroutine reset_coplanar_ids - function distance_to_line(point, line_start, line_end) result(dist) - real, dimension(3), intent(in) :: point, line_start, line_end - real :: u, dist - real, dimension(3) :: intersection, line + function distance_to_line(point, line_start, line_end) result(dist) + real, dimension(3), intent(in) :: point, line_start, line_end + real :: u, dist + real, dimension(3) :: intersection, line - line = line_end - line_start + line = line_end - line_start - u = (((point(1) - line_start(1))*(line_end(1) - line_start(1))) + & - & ((point(2) - line_start(2))*(line_end(2) - line_start(2))) + & - & ((point(3) - line_start(3))*(line_end(3) - line_start(3)))) / & - dot_product(line, line) + u = (((point(1) - line_start(1))*(line_end(1) - line_start(1))) + & + & ((point(2) - line_start(2))*(line_end(2) - line_start(2))) + & + & ((point(3) - line_start(3))*(line_end(3) - line_start(3)))) / & + dot_product(line, line) - if (u < 0.0 .or. u > 1.0) then - FLAbort("the perpendicular projection of the point is not on the line segment") - end if + if (u < 0.0 .or. u > 1.0) then + FLAbort("the perpendicular projection of the point is not on the line segment") + end if - intersection = line_start + u*(line_end - line_start) - dist = norm2(point - intersection) - end function distance_to_line + intersection = line_start + u*(line_end - line_start) + dist = norm2(point - intersection) + end function distance_to_line - function minimum_distance_to_line_segment(point, line_start, line_end) result(dist) - real, dimension(3), intent(in) :: point, line_start, line_end - real, dimension(3) :: line, vec1, vec2 - real :: epsilon, dist + function minimum_distance_to_line_segment(point, line_start, line_end) result(dist) + real, dimension(3), intent(in) :: point, line_start, line_end + real, dimension(3) :: line, vec1, vec2 + real :: epsilon, dist - epsilon = 1e-3 + epsilon = 1e-3 - vec1 = point - line_start - vec2 = point - line_end - line = line_end - line_start + vec1 = point - line_start + vec2 = point - line_end + line = line_end - line_start - if (dot_product(vec1, line) < epsilon) then - dist = norm2(line_start - point) - else if (-1 * dot_product(vec2, line) < epsilon) then - dist = norm2(line_end - point) - else - dist = distance_to_line(point, line_start, line_end) - end if - end function minimum_distance_to_line_segment + if (dot_product(vec1, line) < epsilon) then + dist = norm2(line_start - point) + else if (-1 * dot_product(vec2, line) < epsilon) then + dist = norm2(line_end - point) + else + dist = distance_to_line(point, line_start, line_end) + end if + end function minimum_distance_to_line_segment - function connected_surfaces_count(mesh) result(nconnected_surfaces) - !!< Count the number of connected surfaces + function connected_surfaces_count(mesh) result(nconnected_surfaces) + !!< Count the number of connected surfaces - type(mesh_type), intent(in) :: mesh + type(mesh_type), intent(in) :: mesh - integer :: nconnected_surfaces + integer :: nconnected_surfaces - integer, dimension(surface_element_count(mesh)) :: connected_surface + integer, dimension(surface_element_count(mesh)) :: connected_surface - connected_surface = surface_connectivity(mesh, nconnected_surfaces = nconnected_surfaces) + connected_surface = surface_connectivity(mesh, nconnected_surfaces = nconnected_surfaces) - end function connected_surfaces_count + end function connected_surfaces_count - function surface_connectivity(mesh, nconnected_surfaces) result(connected_surface) - !!< Mark connected surface elements + function surface_connectivity(mesh, nconnected_surfaces) result(connected_surface) + !!< Mark connected surface elements - type(mesh_type), intent(in) :: mesh - integer, optional, intent(out) :: nconnected_surfaces + type(mesh_type), intent(in) :: mesh + integer, optional, intent(out) :: nconnected_surfaces - integer, dimension(surface_element_count(mesh)) :: connected_surface + integer, dimension(surface_element_count(mesh)) :: connected_surface - integer :: face, first_face, i, lnconnected_surfaces - integer, dimension(:), pointer :: neigh, surface_nodes - type(csr_sparsity), pointer :: eelist - type(ilist) :: next - type(mesh_type) :: surface_mesh + integer :: face, first_face, i, lnconnected_surfaces + integer, dimension(:), pointer :: neigh, surface_nodes + type(csr_sparsity), pointer :: eelist + type(ilist) :: next + type(mesh_type) :: surface_mesh - ewrite(1, *) "In surface_connectivity" + ewrite(1, *) "In surface_connectivity" - call create_surface_mesh(surface_mesh, surface_nodes, mesh, name = trim(mesh%name) // "Surface") - assert(continuity(surface_mesh) == 0) - eelist => extract_eelist(surface_mesh) + call create_surface_mesh(surface_mesh, surface_nodes, mesh, name = trim(mesh%name) // "Surface") + assert(continuity(surface_mesh) == 0) + eelist => extract_eelist(surface_mesh) - connected_surface = 0 + connected_surface = 0 - first_face = 1 - lnconnected_surfaces = 0 - do while(first_face /= 0) - face = first_face - assert(face > 0) - assert(face <= ele_count(surface_mesh)) - assert(connected_surface(face) == 0) + first_face = 1 + lnconnected_surfaces = 0 + do while(first_face /= 0) + face = first_face + assert(face > 0) + assert(face <= ele_count(surface_mesh)) + assert(connected_surface(face) == 0) - lnconnected_surfaces = lnconnected_surfaces + 1 - connected_surface(face) = lnconnected_surfaces + lnconnected_surfaces = lnconnected_surfaces + 1 + connected_surface(face) = lnconnected_surfaces - neigh => row_m_ptr(eelist, face) - do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - if(connected_surface(neigh(i)) > 0) cycle + neigh => row_m_ptr(eelist, face) + do i = 1, size(neigh) + if(neigh(i) <= 0) cycle + if(connected_surface(neigh(i)) > 0) cycle - call insert(next, neigh(i)) - end do + call insert(next, neigh(i)) + end do - do while(next%length > 0) - face = pop(next) - if(connected_surface(face) > 0) cycle + do while(next%length > 0) + face = pop(next) + if(connected_surface(face) > 0) cycle - connected_surface(face) = lnconnected_surfaces + connected_surface(face) = lnconnected_surfaces - neigh => row_m_ptr(eelist, face) - do i = 1, size(neigh) - if(neigh(i) <= 0) cycle - if(connected_surface(neigh(i)) > 0) cycle - ! Should check if neigh(i) is already in the list + neigh => row_m_ptr(eelist, face) + do i = 1, size(neigh) + if(neigh(i) <= 0) cycle + if(connected_surface(neigh(i)) > 0) cycle + ! Should check if neigh(i) is already in the list - call insert(next, neigh(i)) - end do - end do + call insert(next, neigh(i)) + end do + end do - first_face = next_zero_loc(first_face + 1, connected_surface) - end do - assert(all(connected_surface > 0)) - ewrite(2, *) "Connected surfaces: ", lnconnected_surfaces + first_face = next_zero_loc(first_face + 1, connected_surface) + end do + assert(all(connected_surface > 0)) + ewrite(2, *) "Connected surfaces: ", lnconnected_surfaces - call deallocate(surface_mesh) + call deallocate(surface_mesh) - if(present(nconnected_surfaces)) nconnected_surfaces = lnconnected_surfaces + if(present(nconnected_surfaces)) nconnected_surfaces = lnconnected_surfaces - ewrite(1, *) "Exiting surface_connectivity" + ewrite(1, *) "Exiting surface_connectivity" - contains + contains - pure function next_zero_loc(start_index, integer_vector) result(loc) - integer, intent(in) :: start_index - integer, dimension(:), intent(in) :: integer_vector + pure function next_zero_loc(start_index, integer_vector) result(loc) + integer, intent(in) :: start_index + integer, dimension(:), intent(in) :: integer_vector - integer :: loc + integer :: loc - integer :: i + integer :: i - do i = start_index, size(integer_vector) - if(integer_vector(i) == 0) then - loc = i - return - end if - end do + do i = start_index, size(integer_vector) + if(integer_vector(i) == 0) then + loc = i + return + end if + end do - loc = 0 + loc = 0 - end function next_zero_loc + end function next_zero_loc - end function surface_connectivity + end function surface_connectivity - subroutine get_connected_surface_eles(mesh, surface_eles, connected_surface, nconnected_surfaces) - !!< Return lists of connected surface elements + subroutine get_connected_surface_eles(mesh, surface_eles, connected_surface, nconnected_surfaces) + !!< Return lists of connected surface elements - type(mesh_type), intent(in) :: mesh - type(integer_vector), dimension(:), allocatable, intent(out) :: surface_eles - integer, dimension(surface_element_count(mesh)), optional, intent(out) :: connected_surface - integer, optional, intent(out) :: nconnected_surfaces + type(mesh_type), intent(in) :: mesh + type(integer_vector), dimension(:), allocatable, intent(out) :: surface_eles + integer, dimension(surface_element_count(mesh)), optional, intent(out) :: connected_surface + integer, optional, intent(out) :: nconnected_surfaces - integer :: i, npaint - integer, dimension(:), allocatable :: nsurface_eles - integer, dimension(surface_element_count(mesh)) :: paint + integer :: i, npaint + integer, dimension(:), allocatable :: nsurface_eles + integer, dimension(surface_element_count(mesh)) :: paint - ewrite(1, *) "In get_connected_surface_eles" + ewrite(1, *) "In get_connected_surface_eles" - paint = surface_connectivity(mesh, nconnected_surfaces = npaint) + paint = surface_connectivity(mesh, nconnected_surfaces = npaint) - allocate(nsurface_eles(npaint)) - nsurface_eles = 0 - do i = 1, size(paint) - nsurface_eles(paint(i)) = nsurface_eles(paint(i)) + 1 - end do + allocate(nsurface_eles(npaint)) + nsurface_eles = 0 + do i = 1, size(paint) + nsurface_eles(paint(i)) = nsurface_eles(paint(i)) + 1 + end do - allocate(surface_eles(npaint)) - do i = 1, npaint - allocate(surface_eles(i)%ptr(nsurface_eles(i))) - end do + allocate(surface_eles(npaint)) + do i = 1, npaint + allocate(surface_eles(i)%ptr(nsurface_eles(i))) + end do - nsurface_eles = 0 - do i = 1, size(paint) - nsurface_eles(paint(i)) = nsurface_eles(paint(i)) + 1 - surface_eles(paint(i))%ptr(nsurface_eles(paint(i))) = i - end do - deallocate(nsurface_eles) + nsurface_eles = 0 + do i = 1, size(paint) + nsurface_eles(paint(i)) = nsurface_eles(paint(i)) + 1 + surface_eles(paint(i))%ptr(nsurface_eles(paint(i))) = i + end do + deallocate(nsurface_eles) - if(present(connected_surface)) connected_surface = paint - if(present(nconnected_surfaces)) nconnected_surfaces = npaint + if(present(connected_surface)) connected_surface = paint + if(present(nconnected_surfaces)) nconnected_surfaces = npaint - ewrite(1, *) "Exiting get_connected_surface_eles" + ewrite(1, *) "Exiting get_connected_surface_eles" - end subroutine get_connected_surface_eles + end subroutine get_connected_surface_eles end module SurfaceLabels diff --git a/femtools/Tensors.F90 b/femtools/Tensors.F90 index 292b430dc4..c9fbb78659 100644 --- a/femtools/Tensors.F90 +++ b/femtools/Tensors.F90 @@ -26,123 +26,123 @@ ! USA #include "fdebug.h" module tensors - !!< This module provides tensor operations on arrays. - use FLDebug - implicit none + !!< This module provides tensor operations on arrays. + use FLDebug + implicit none - interface tensormul - module procedure tensormul_3_1, tensormul_3_2, tensormul_4_1, tensormul_3_1_last - end interface + interface tensormul + module procedure tensormul_3_1, tensormul_3_2, tensormul_4_1, tensormul_3_1_last + end interface - private + private - public :: exclude, tensormul + public :: exclude, tensormul contains - pure function exclude(i, j) - !!< Choose dimension for the result of tensor contraction. - integer, intent(in) :: i, j - integer :: exclude - - if (i < j) then - exclude = i - else - exclude = i +1 - end if - end function exclude - - pure function tensormul_3_1(tensor1, vec, d) result(prod) - !!< Tensor contraction on two tensors by contraction of the index specified. - real, dimension(:, :, :), intent(in) :: tensor1 - real, dimension(:), intent(in) :: vec - integer, intent(in) :: d - - integer, pointer :: m1, m2 - integer, dimension(3), target :: n - integer :: i - - real, dimension(size(tensor1, exclude(1, d)), size(tensor1, exclude(2, d))) :: prod - - prod = 0.0 - - n = 1 - m1 => n(exclude(1, d)); m2 => n(exclude(2,d)) - - do i=1,size(tensor1) - prod(m1, m2) = prod(m1, m2) + tensor1(n(1), n(2), n(3)) * vec(n(d)) - n(1) = n(1) + 1 - if (n(1) > size(tensor1, 1)) then - n(1) = 1 - n(2) = n(2) + 1 - if (n(2) > size(tensor1, 2)) then - n(2) = 1 - n(3) = n(3) + 1 - end if - end if - end do - end function tensormul_3_1 - - function tensormul_3_1_last(tensor1, vec) result(prod) - real, dimension(:, :, :), intent(in) :: tensor1 - real, dimension(:), intent(in) :: vec - real, dimension(size(tensor1, 1), size(tensor1, 2)) :: prod - integer :: i - - prod = 0.0 - do i=1,size(vec) - prod = prod + vec(i) * tensor1(:, :, i) - end do - end function tensormul_3_1_last - - pure function tensormul_3_2(tensor1, tensor2) result (product) - !!< Tensor contraction on two tensors by innermost dimension. - real, dimension(:,:,:), intent(in) :: tensor1 - real, dimension(:,:), intent(in) :: tensor2 - real, dimension(size(tensor1,1), size(tensor1,2), size(tensor2,2)) ::& - & product - - integer :: i - - forall (i=1:size(tensor1,1)) - product(i,:,:)=matmul(tensor1(i,:,:),tensor2) - end forall - - end function tensormul_3_2 - - pure function tensormul_4_1(tensor1, vec, d) result(prod) - !!< Tensor contraction on two tensors by contraction of the index specified. - real, dimension(:, :, :, :), intent(in) :: tensor1 - real, dimension(:), intent(in) :: vec - integer, intent(in) :: d - - integer, pointer :: m1, m2, m3 - integer, dimension(4), target :: n - integer :: i - - real, dimension(size(tensor1, exclude(1, d)), size(tensor1, exclude(2, d)), size(tensor1, exclude(3, d))) :: prod - - prod = 0.0 - - n = 1 - m1 => n(exclude(1, d)); m2 => n(exclude(2,d)); m3 => n(exclude(3,d)) - - do i=1,size(tensor1) - prod(m1, m2, m3) = prod(m1, m2, m3) + tensor1(n(1), n(2), n(3), n(4)) * vec(n(d)) - n(1) = n(1) + 1 - if (n(1) > size(tensor1, 1)) then - n(1) = 1 - n(2) = n(2) + 1 - if (n(2) > size(tensor1, 2)) then - n(2) = 1 - n(3) = n(3) + 1 - if (n(3) > size(tensor1, 3)) then - n(3) = 1 - n(4) = n(4) + 1 - end if - end if + pure function exclude(i, j) + !!< Choose dimension for the result of tensor contraction. + integer, intent(in) :: i, j + integer :: exclude + + if (i < j) then + exclude = i + else + exclude = i +1 end if - end do - end function tensormul_4_1 + end function exclude + + pure function tensormul_3_1(tensor1, vec, d) result(prod) + !!< Tensor contraction on two tensors by contraction of the index specified. + real, dimension(:, :, :), intent(in) :: tensor1 + real, dimension(:), intent(in) :: vec + integer, intent(in) :: d + + integer, pointer :: m1, m2 + integer, dimension(3), target :: n + integer :: i + + real, dimension(size(tensor1, exclude(1, d)), size(tensor1, exclude(2, d))) :: prod + + prod = 0.0 + + n = 1 + m1 => n(exclude(1, d)); m2 => n(exclude(2,d)) + + do i=1,size(tensor1) + prod(m1, m2) = prod(m1, m2) + tensor1(n(1), n(2), n(3)) * vec(n(d)) + n(1) = n(1) + 1 + if (n(1) > size(tensor1, 1)) then + n(1) = 1 + n(2) = n(2) + 1 + if (n(2) > size(tensor1, 2)) then + n(2) = 1 + n(3) = n(3) + 1 + end if + end if + end do + end function tensormul_3_1 + + function tensormul_3_1_last(tensor1, vec) result(prod) + real, dimension(:, :, :), intent(in) :: tensor1 + real, dimension(:), intent(in) :: vec + real, dimension(size(tensor1, 1), size(tensor1, 2)) :: prod + integer :: i + + prod = 0.0 + do i=1,size(vec) + prod = prod + vec(i) * tensor1(:, :, i) + end do + end function tensormul_3_1_last + + pure function tensormul_3_2(tensor1, tensor2) result (product) + !!< Tensor contraction on two tensors by innermost dimension. + real, dimension(:,:,:), intent(in) :: tensor1 + real, dimension(:,:), intent(in) :: tensor2 + real, dimension(size(tensor1,1), size(tensor1,2), size(tensor2,2)) ::& + & product + + integer :: i + + forall (i=1:size(tensor1,1)) + product(i,:,:)=matmul(tensor1(i,:,:),tensor2) + end forall + + end function tensormul_3_2 + + pure function tensormul_4_1(tensor1, vec, d) result(prod) + !!< Tensor contraction on two tensors by contraction of the index specified. + real, dimension(:, :, :, :), intent(in) :: tensor1 + real, dimension(:), intent(in) :: vec + integer, intent(in) :: d + + integer, pointer :: m1, m2, m3 + integer, dimension(4), target :: n + integer :: i + + real, dimension(size(tensor1, exclude(1, d)), size(tensor1, exclude(2, d)), size(tensor1, exclude(3, d))) :: prod + + prod = 0.0 + + n = 1 + m1 => n(exclude(1, d)); m2 => n(exclude(2,d)); m3 => n(exclude(3,d)) + + do i=1,size(tensor1) + prod(m1, m2, m3) = prod(m1, m2, m3) + tensor1(n(1), n(2), n(3), n(4)) * vec(n(d)) + n(1) = n(1) + 1 + if (n(1) > size(tensor1, 1)) then + n(1) = 1 + n(2) = n(2) + 1 + if (n(2) > size(tensor1, 2)) then + n(2) = 1 + n(3) = n(3) + 1 + if (n(3) > size(tensor1, 3)) then + n(3) = 1 + n(4) = n(4) + 1 + end if + end if + end if + end do + end function tensormul_4_1 end module tensors diff --git a/femtools/Tetrahedron_intersection.F90 b/femtools/Tetrahedron_intersection.F90 index 7540fa546a..0258e2385b 100644 --- a/femtools/Tetrahedron_intersection.F90 +++ b/femtools/Tetrahedron_intersection.F90 @@ -7,508 +7,508 @@ module tetrahedron_intersection_module - use fldebug - use vector_tools - use element_numbering, only: FAMILY_CUBE, FAMILY_SIMPLEX - use elements - use fields_data_types - use fields_base - use fields_allocates - use fields_manipulation - use transform_elements + use fldebug + use vector_tools + use element_numbering, only: FAMILY_CUBE, FAMILY_SIMPLEX + use elements + use fields_data_types + use fields_base + use fields_allocates + use fields_manipulation + use transform_elements #ifdef HAVE_LIBSUPERMESH - use libsupermesh, only : tet_type, plane_type, intersect_polys + use libsupermesh, only : tet_type, plane_type, intersect_polys #endif - implicit none + implicit none #ifndef HAVE_LIBSUPERMESH - type tet_type - real, dimension(3, 4) :: V ! vertices of the tet - integer, dimension(4) :: colours = -1 ! surface colours - end type tet_type + type tet_type + real, dimension(3, 4) :: V ! vertices of the tet + integer, dimension(4) :: colours = -1 ! surface colours + end type tet_type - type plane_type - real, dimension(3) :: normal - real :: c - end type plane_type + type plane_type + real, dimension(3) :: normal + real :: c + end type plane_type - integer :: tet_cnt_tmp = 0 + integer :: tet_cnt_tmp = 0 #endif - type(tet_type), dimension(BUF_SIZE), save :: tet_array, tet_array_tmp - integer :: tet_cnt = 0 - type(mesh_type), save :: intersection_mesh - logical, save :: mesh_allocated = .false. - - private - - public :: tet_type, plane_type, intersect_tets, get_planes, finalise_tet_intersector - - interface intersect_tets - module procedure intersect_tets_dt - end interface - - interface get_planes - module procedure get_planes_tet, get_planes_hex - end interface - - contains - - subroutine finalise_tet_intersector - if (mesh_allocated) then - call deallocate(intersection_mesh) - mesh_allocated = .false. - end if - end subroutine finalise_tet_intersector - - subroutine intersect_tets_dt(tetA, planesB, shape, stat, output, surface_shape, surface_positions, surface_colours) - type(tet_type), intent(in) :: tetA - type(plane_type), dimension(:), intent(in) :: planesB - type(element_type), intent(in) :: shape - type(vector_field), intent(inout) :: output - type(vector_field), intent(out), optional :: surface_positions - type(scalar_field), intent(out), optional :: surface_colours - type(element_type), intent(in), optional :: surface_shape - integer :: ele - integer, intent(out) :: stat - - integer :: i, j, k, l - integer, dimension(3) :: idx_tmp - integer :: surface_eles - type(mesh_type) :: surface_mesh, pwc_surface_mesh + type(tet_type), dimension(BUF_SIZE), save :: tet_array, tet_array_tmp + integer :: tet_cnt = 0 + type(mesh_type), save :: intersection_mesh + logical, save :: mesh_allocated = .false. + + private + + public :: tet_type, plane_type, intersect_tets, get_planes, finalise_tet_intersector + + interface intersect_tets + module procedure intersect_tets_dt + end interface + + interface get_planes + module procedure get_planes_tet, get_planes_hex + end interface + +contains + + subroutine finalise_tet_intersector + if (mesh_allocated) then + call deallocate(intersection_mesh) + mesh_allocated = .false. + end if + end subroutine finalise_tet_intersector + + subroutine intersect_tets_dt(tetA, planesB, shape, stat, output, surface_shape, surface_positions, surface_colours) + type(tet_type), intent(in) :: tetA + type(plane_type), dimension(:), intent(in) :: planesB + type(element_type), intent(in) :: shape + type(vector_field), intent(inout) :: output + type(vector_field), intent(out), optional :: surface_positions + type(scalar_field), intent(out), optional :: surface_colours + type(element_type), intent(in), optional :: surface_shape + integer :: ele + integer, intent(out) :: stat + + integer :: i, j, k, l + integer, dimension(3) :: idx_tmp + integer :: surface_eles + type(mesh_type) :: surface_mesh, pwc_surface_mesh #ifndef HAVE_LIBSUPERMESH - real :: vol - real, dimension(3) :: vec_tmp - integer :: colour_tmp + real :: vol + real, dimension(3) :: vec_tmp + integer :: colour_tmp #endif - if (present(surface_colours) .or. present(surface_positions) .or. present(surface_shape)) then - assert(present(surface_positions)) - assert(present(surface_colours)) - assert(present(surface_shape)) - end if + if (present(surface_colours) .or. present(surface_positions) .or. present(surface_shape)) then + assert(present(surface_positions)) + assert(present(surface_colours)) + assert(present(surface_shape)) + end if - assert(shape%degree == 1) - assert(shape%numbering%family == FAMILY_SIMPLEX) - assert(shape%dim == 3) + assert(shape%degree == 1) + assert(shape%numbering%family == FAMILY_SIMPLEX) + assert(shape%dim == 3) - if (.not. mesh_allocated) then - call allocate(intersection_mesh, BUF_SIZE * 4, BUF_SIZE, shape, name="IntersectionMesh") - intersection_mesh%ndglno = (/ (i, i=1,BUF_SIZE*4) /) - intersection_mesh%continuity = -1 - mesh_allocated = .true. - end if + if (.not. mesh_allocated) then + call allocate(intersection_mesh, BUF_SIZE * 4, BUF_SIZE, shape, name="IntersectionMesh") + intersection_mesh%ndglno = (/ (i, i=1,BUF_SIZE*4) /) + intersection_mesh%continuity = -1 + mesh_allocated = .true. + end if #ifdef HAVE_LIBSUPERMESH - call intersect_polys(tetA, planesB, tet_array, tet_cnt, work = tet_array_tmp) + call intersect_polys(tetA, planesB, tet_array, tet_cnt, work = tet_array_tmp) #else - tet_cnt = 1 - tet_array(1) = tetA + tet_cnt = 1 + tet_array(1) = tetA + + do i=1,size(planesB) + ! Clip the tet_array against the i'th plane + tet_cnt_tmp = 0 + + do j=1,tet_cnt + call clip(planesB(i), tet_array(j)) + end do + + if (i /= size(planesB)) then + tet_cnt = tet_cnt_tmp + tet_array(1:tet_cnt) = tet_array_tmp(1:tet_cnt) + else + ! Copy the result if the volume is > epsilon + tet_cnt = 0 + do j=1,tet_cnt_tmp + vol = tet_volume(tet_array_tmp(j)) + if (vol < 0.0) then + vec_tmp = tet_array_tmp(j)%V(:, 1) + colour_tmp = tet_array_tmp(j)%colours(1) + tet_array_tmp(j)%V(:, 1) = tet_array_tmp(j)%V(:, 2) + tet_array_tmp(j)%colours(1) = tet_array_tmp(j)%colours(2) + tet_array_tmp(j)%V(:, 2) = vec_tmp + tet_array_tmp(j)%colours(2) = colour_tmp + vol = -vol + end if + + if (vol > epsilon(0.0)) then + tet_cnt = tet_cnt + 1 + tet_array(tet_cnt) = tet_array_tmp(j) + end if + end do + end if + end do +#endif + + if (tet_cnt == 0) then + stat=1 + return + end if - do i=1,size(planesB) - ! Clip the tet_array against the i'th plane - tet_cnt_tmp = 0 + stat = 0 + intersection_mesh%nodes = tet_cnt*4 + intersection_mesh%elements = tet_cnt + call allocate(output, 3, intersection_mesh, "IntersectionCoordinates") - do j=1,tet_cnt - call clip(planesB(i), tet_array(j)) + do ele=1,tet_cnt + call set(output, ele_nodes(output, ele), tet_array(ele)%V) end do - if (i /= size(planesB)) then - tet_cnt = tet_cnt_tmp - tet_array(1:tet_cnt) = tet_array_tmp(1:tet_cnt) - else - ! Copy the result if the volume is > epsilon - tet_cnt = 0 - do j=1,tet_cnt_tmp - vol = tet_volume(tet_array_tmp(j)) - if (vol < 0.0) then - vec_tmp = tet_array_tmp(j)%V(:, 1) - colour_tmp = tet_array_tmp(j)%colours(1) - tet_array_tmp(j)%V(:, 1) = tet_array_tmp(j)%V(:, 2) - tet_array_tmp(j)%colours(1) = tet_array_tmp(j)%colours(2) - tet_array_tmp(j)%V(:, 2) = vec_tmp - tet_array_tmp(j)%colours(2) = colour_tmp - vol = -vol - end if - - if (vol > epsilon(0.0)) then - tet_cnt = tet_cnt + 1 - tet_array(tet_cnt) = tet_array_tmp(j) - end if - end do + if (present(surface_positions)) then + ! OK! Let's loop through all the tets we have and see which faces have positive + ! colour. These are the ones we want to record in the mesh + surface_eles = 0 + do ele=1,tet_cnt + surface_eles = surface_eles + count(tet_array(ele)%colours > 0) + end do + + call allocate(surface_mesh, surface_eles * 3, surface_eles, surface_shape, name="SurfaceMesh") + surface_mesh%ndglno = (/ (i, i=1,surface_eles * 3) /) + call allocate(surface_positions, 3, surface_mesh, "OutputSurfaceCoordinate") + pwc_surface_mesh = piecewise_constant_mesh(surface_mesh, "PWCSurfaceMesh") + call allocate(surface_colours, pwc_surface_mesh, "SurfaceColours") + call deallocate(surface_mesh) + call deallocate(pwc_surface_mesh) + + j = 1 + do ele=1,tet_cnt + do i=1,4 + if (tet_array(ele)%colours(i) > 0) then + + ! In python, this is + ! idx_tmp = [x for x in range(4) if x != i] + ! Hopefully that will make it clearer + k = 1 + do l=1,4 + if (l /= i) then + idx_tmp(k) = l + k = k + 1 + end if + end do + call set(surface_positions, ele_nodes(surface_positions, j), tet_array(ele)%V(:, idx_tmp)) + call set(surface_colours, j, float(tet_array(ele)%colours(i))) + j = j + 1 + end if + end do + end do end if - end do -#endif - if (tet_cnt == 0) then - stat=1 - return - end if + end subroutine intersect_tets_dt - stat = 0 - intersection_mesh%nodes = tet_cnt*4 - intersection_mesh%elements = tet_cnt - call allocate(output, 3, intersection_mesh, "IntersectionCoordinates") +#ifndef HAVE_LIBSUPERMESH + subroutine clip(plane, tet) + ! Clip tet against the plane + ! and append any output to tet_array_tmp. + type(plane_type), intent(in) :: plane + type(tet_type), intent(in) :: tet - do ele=1,tet_cnt - call set(output, ele_nodes(output, ele), tet_array(ele)%V) - end do + real, dimension(4) :: dists + integer :: neg_cnt, pos_cnt, zer_cnt + integer, dimension(4) :: neg_idx, pos_idx, zer_idx + integer :: i - if (present(surface_positions)) then - ! OK! Let's loop through all the tets we have and see which faces have positive - ! colour. These are the ones we want to record in the mesh - surface_eles = 0 - do ele=1,tet_cnt - surface_eles = surface_eles + count(tet_array(ele)%colours > 0) - end do + real :: invdiff, w0, w1 + type(tet_type) :: tet_tmp - call allocate(surface_mesh, surface_eles * 3, surface_eles, surface_shape, name="SurfaceMesh") - surface_mesh%ndglno = (/ (i, i=1,surface_eles * 3) /) - call allocate(surface_positions, 3, surface_mesh, "OutputSurfaceCoordinate") - pwc_surface_mesh = piecewise_constant_mesh(surface_mesh, "PWCSurfaceMesh") - call allocate(surface_colours, pwc_surface_mesh, "SurfaceColours") - call deallocate(surface_mesh) - call deallocate(pwc_surface_mesh) + ! Negative == inside + ! Positive == outside - j = 1 - do ele=1,tet_cnt - do i=1,4 - if (tet_array(ele)%colours(i) > 0) then - - ! In python, this is - ! idx_tmp = [x for x in range(4) if x != i] - ! Hopefully that will make it clearer - k = 1 - do l=1,4 - if (l /= i) then - idx_tmp(k) = l - k = k + 1 - end if - end do - call set(surface_positions, ele_nodes(surface_positions, j), tet_array(ele)%V(:, idx_tmp)) - call set(surface_colours, j, float(tet_array(ele)%colours(i))) - j = j + 1 - end if - end do + neg_cnt = 0 + pos_cnt = 0 + zer_cnt = 0 + + dists = distances_to_plane(plane, tet) + do i=1,4 + if (abs(dists(i)) < epsilon(0.0)) then + zer_cnt = zer_cnt + 1 + zer_idx(zer_cnt) = i + else if (dists(i) < 0.0) then + neg_cnt = neg_cnt + 1 + neg_idx(neg_cnt) = i + else if (dists(i) > 0.0) then + pos_cnt = pos_cnt + 1 + pos_idx(pos_cnt) = i + end if end do - end if - end subroutine intersect_tets_dt + if (neg_cnt == 0) then + ! tet is completely on positive side of plane, full clip + return + end if -#ifndef HAVE_LIBSUPERMESH - subroutine clip(plane, tet) - ! Clip tet against the plane - ! and append any output to tet_array_tmp. - type(plane_type), intent(in) :: plane - type(tet_type), intent(in) :: tet - - real, dimension(4) :: dists - integer :: neg_cnt, pos_cnt, zer_cnt - integer, dimension(4) :: neg_idx, pos_idx, zer_idx - integer :: i - - real :: invdiff, w0, w1 - type(tet_type) :: tet_tmp - - ! Negative == inside - ! Positive == outside - - neg_cnt = 0 - pos_cnt = 0 - zer_cnt = 0 - - dists = distances_to_plane(plane, tet) - do i=1,4 - if (abs(dists(i)) < epsilon(0.0)) then - zer_cnt = zer_cnt + 1 - zer_idx(zer_cnt) = i - else if (dists(i) < 0.0) then - neg_cnt = neg_cnt + 1 - neg_idx(neg_cnt) = i - else if (dists(i) > 0.0) then - pos_cnt = pos_cnt + 1 - pos_idx(pos_cnt) = i + if (pos_cnt == 0) then + ! tet is completely on negative side of plane, no clip + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + return end if - end do - - if (neg_cnt == 0) then - ! tet is completely on positive side of plane, full clip - return - end if - - if (pos_cnt == 0) then - ! tet is completely on negative side of plane, no clip - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - return - end if - - ! The tet is split by the plane, so we have more work to do. - - select case(pos_cnt) - case(3) - ! +++- - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - do i=1,pos_cnt - invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(1)) ) - w0 = -dists(neg_idx(1)) * invdiff - w1 = dists(pos_idx(i)) * invdiff - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) = & - w0 * tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) + & - w1 * tet_array_tmp(tet_cnt_tmp)%V(:, neg_idx(1)) - end do - ! The colours will have been inherited already; we just need to zero - ! the one corresponding to the plane cut - tet_array_tmp(tet_cnt_tmp)%colours(face_no(pos_idx(1), pos_idx(2), pos_idx(3))) = 0 - case(2) - select case(neg_cnt) - case(2) - ! ++-- - do i=1,pos_cnt - invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(1)) ) - w0 = -dists(neg_idx(1)) * invdiff - w1 = dists(pos_idx(i)) * invdiff - tet_tmp%V(:, i) = w0 * tet%V(:, pos_idx(i)) + w1 * tet%V(:, neg_idx(1)) - end do - do i=1,neg_cnt - invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(2)) ) - w0 = -dists(neg_idx(2)) * invdiff - w1 = dists(pos_idx(i)) * invdiff - tet_tmp%V(:, i+2) = w0 * tet%V(:, pos_idx(i)) + w1 * tet%V(:, neg_idx(2)) - end do - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = tet_tmp%V(:, 3) - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(2)) = tet_tmp%V(:, 2) - tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 - tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(2)) = 0 - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet%V(:, neg_idx(2)) - tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet_tmp%V(:, 4) - tet_array_tmp(tet_cnt_tmp)%colours(2) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet_tmp%V(:, 3) - tet_array_tmp(tet_cnt_tmp)%colours(3) = tet%colours(pos_idx(1)) - tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 2) - tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(1)) - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet%V(:, neg_idx(1)) - tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet_tmp%V(:, 1) - tet_array_tmp(tet_cnt_tmp)%colours(2) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet_tmp%V(:, 2) - tet_array_tmp(tet_cnt_tmp)%colours(3) = tet%colours(pos_idx(2)) - tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 3) - tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(2)) - case(1) - ! ++-0 - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - do i=1,pos_cnt - invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(1)) ) - w0 = -dists(neg_idx(1)) * invdiff - w1 = dists(pos_idx(i)) * invdiff - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) = & - w0 * tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) + & - w1 * tet_array_tmp(tet_cnt_tmp)%V(:, neg_idx(1)) - end do - tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 - end select - case(1) - select case(neg_cnt) - case(3) - ! +--- - do i=1,neg_cnt - invdiff = 1.0 / ( dists(pos_idx(1)) - dists(neg_idx(i)) ) - w0 = -dists(neg_idx(i)) * invdiff - w1 = dists(pos_idx(1)) * invdiff - tet_tmp%V(:, i) = w0 * tet%V(:, pos_idx(1)) + w1 * tet%V(:, neg_idx(i)) - end do - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = tet_tmp%V(:, 1) - tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet_tmp%V(:, 1) - tet_array_tmp(tet_cnt_tmp)%colours(1) = tet%colours(neg_idx(1)) - tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet%V(:, neg_idx(2)) - tet_array_tmp(tet_cnt_tmp)%colours(2) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet%V(:, neg_idx(3)) - tet_array_tmp(tet_cnt_tmp)%colours(3) = tet%colours(neg_idx(3)) - tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 2) - tet_array_tmp(tet_cnt_tmp)%colours(4) = 0 - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet%V(:, neg_idx(3)) - tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet_tmp%V(:, 2) - tet_array_tmp(tet_cnt_tmp)%colours(2) = tet%colours(neg_idx(2)) - tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet_tmp%V(:, 3) - tet_array_tmp(tet_cnt_tmp)%colours(3) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 1) - tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(1)) - case(2) - ! +--0 - do i=1,neg_cnt - invdiff = 1.0 / ( dists(pos_idx(1)) - dists(neg_idx(i)) ) - w0 = -dists(neg_idx(i)) * invdiff - w1 = dists(pos_idx(1)) * invdiff - tet_tmp%V(:, i) = w0 * tet%V(:, pos_idx(1)) + w1 * tet%V(:, neg_idx(i)) - end do - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = tet_tmp%V(:, 1) - tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet_tmp%V(:, 2) - tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet%V(:, zer_idx(1)) - tet_array_tmp(tet_cnt_tmp)%colours(2) = tet%colours(zer_idx(1)) - tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet%V(:, neg_idx(2)) - tet_array_tmp(tet_cnt_tmp)%colours(3) = 0 - tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 1) - tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(1)) - case(1) - ! +-00 - invdiff = 1.0 / ( dists(pos_idx(1)) - dists(neg_idx(1)) ) - w0 = -dists(neg_idx(1)) * invdiff - w1 = dists(pos_idx(1)) * invdiff - - tet_cnt_tmp = tet_cnt_tmp + 1 - tet_array_tmp(tet_cnt_tmp) = tet - tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = w0 * tet%V(:, pos_idx(1)) + w1 * tet%V(:, neg_idx(1)) - tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 - end select - end select - end subroutine clip -#endif + ! The tet is split by the plane, so we have more work to do. + + select case(pos_cnt) + case(3) + ! +++- + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + do i=1,pos_cnt + invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(1)) ) + w0 = -dists(neg_idx(1)) * invdiff + w1 = dists(pos_idx(i)) * invdiff + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) = & + w0 * tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) + & + w1 * tet_array_tmp(tet_cnt_tmp)%V(:, neg_idx(1)) + end do + ! The colours will have been inherited already; we just need to zero + ! the one corresponding to the plane cut + tet_array_tmp(tet_cnt_tmp)%colours(face_no(pos_idx(1), pos_idx(2), pos_idx(3))) = 0 + case(2) + select case(neg_cnt) + case(2) + ! ++-- + do i=1,pos_cnt + invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(1)) ) + w0 = -dists(neg_idx(1)) * invdiff + w1 = dists(pos_idx(i)) * invdiff + tet_tmp%V(:, i) = w0 * tet%V(:, pos_idx(i)) + w1 * tet%V(:, neg_idx(1)) + end do + do i=1,neg_cnt + invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(2)) ) + w0 = -dists(neg_idx(2)) * invdiff + w1 = dists(pos_idx(i)) * invdiff + tet_tmp%V(:, i+2) = w0 * tet%V(:, pos_idx(i)) + w1 * tet%V(:, neg_idx(2)) + end do - pure function get_planes_tet(tet) result(plane) - type(tet_type), intent(in) :: tet - type(plane_type), dimension(4) :: plane + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = tet_tmp%V(:, 3) + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(2)) = tet_tmp%V(:, 2) + tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 + tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(2)) = 0 + + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet%V(:, neg_idx(2)) + tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet_tmp%V(:, 4) + tet_array_tmp(tet_cnt_tmp)%colours(2) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet_tmp%V(:, 3) + tet_array_tmp(tet_cnt_tmp)%colours(3) = tet%colours(pos_idx(1)) + tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 2) + tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(1)) + + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet%V(:, neg_idx(1)) + tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet_tmp%V(:, 1) + tet_array_tmp(tet_cnt_tmp)%colours(2) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet_tmp%V(:, 2) + tet_array_tmp(tet_cnt_tmp)%colours(3) = tet%colours(pos_idx(2)) + tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 3) + tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(2)) + case(1) + ! ++-0 + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + do i=1,pos_cnt + invdiff = 1.0 / ( dists(pos_idx(i)) - dists(neg_idx(1)) ) + w0 = -dists(neg_idx(1)) * invdiff + w1 = dists(pos_idx(i)) * invdiff + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) = & + w0 * tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(i)) + & + w1 * tet_array_tmp(tet_cnt_tmp)%V(:, neg_idx(1)) + end do + tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 + end select + case(1) + select case(neg_cnt) + case(3) + ! +--- + do i=1,neg_cnt + invdiff = 1.0 / ( dists(pos_idx(1)) - dists(neg_idx(i)) ) + w0 = -dists(neg_idx(i)) * invdiff + w1 = dists(pos_idx(1)) * invdiff + tet_tmp%V(:, i) = w0 * tet%V(:, pos_idx(1)) + w1 * tet%V(:, neg_idx(i)) + end do - real, dimension(3) :: edge10, edge20, edge30, edge21, edge31 - real :: det - integer :: i + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = tet_tmp%V(:, 1) + tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 + + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet_tmp%V(:, 1) + tet_array_tmp(tet_cnt_tmp)%colours(1) = tet%colours(neg_idx(1)) + tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet%V(:, neg_idx(2)) + tet_array_tmp(tet_cnt_tmp)%colours(2) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet%V(:, neg_idx(3)) + tet_array_tmp(tet_cnt_tmp)%colours(3) = tet%colours(neg_idx(3)) + tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 2) + tet_array_tmp(tet_cnt_tmp)%colours(4) = 0 + + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet%V(:, neg_idx(3)) + tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet_tmp%V(:, 2) + tet_array_tmp(tet_cnt_tmp)%colours(2) = tet%colours(neg_idx(2)) + tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet_tmp%V(:, 3) + tet_array_tmp(tet_cnt_tmp)%colours(3) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 1) + tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(1)) + case(2) + ! +--0 + do i=1,neg_cnt + invdiff = 1.0 / ( dists(pos_idx(1)) - dists(neg_idx(i)) ) + w0 = -dists(neg_idx(i)) * invdiff + w1 = dists(pos_idx(1)) * invdiff + tet_tmp%V(:, i) = w0 * tet%V(:, pos_idx(1)) + w1 * tet%V(:, neg_idx(i)) + end do - edge10 = tet%V(:, 2) - tet%V(:, 1); - edge20 = tet%V(:, 3) - tet%V(:, 1); - edge30 = tet%V(:, 4) - tet%V(:, 1); - edge21 = tet%V(:, 3) - tet%V(:, 2); - edge31 = tet%V(:, 4) - tet%V(:, 2); + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = tet_tmp%V(:, 1) + tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 + + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp)%V(:, 1) = tet_tmp%V(:, 2) + tet_array_tmp(tet_cnt_tmp)%colours(1) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 2) = tet%V(:, zer_idx(1)) + tet_array_tmp(tet_cnt_tmp)%colours(2) = tet%colours(zer_idx(1)) + tet_array_tmp(tet_cnt_tmp)%V(:, 3) = tet%V(:, neg_idx(2)) + tet_array_tmp(tet_cnt_tmp)%colours(3) = 0 + tet_array_tmp(tet_cnt_tmp)%V(:, 4) = tet_tmp%V(:, 1) + tet_array_tmp(tet_cnt_tmp)%colours(4) = tet%colours(neg_idx(1)) + case(1) + ! +-00 + invdiff = 1.0 / ( dists(pos_idx(1)) - dists(neg_idx(1)) ) + w0 = -dists(neg_idx(1)) * invdiff + w1 = dists(pos_idx(1)) * invdiff + + tet_cnt_tmp = tet_cnt_tmp + 1 + tet_array_tmp(tet_cnt_tmp) = tet + tet_array_tmp(tet_cnt_tmp)%V(:, pos_idx(1)) = w0 * tet%V(:, pos_idx(1)) + w1 * tet%V(:, neg_idx(1)) + tet_array_tmp(tet_cnt_tmp)%colours(neg_idx(1)) = 0 + end select + end select + + end subroutine clip +#endif - plane(1)%normal = unit_cross(edge20, edge10) - plane(2)%normal = unit_cross(edge10, edge30) - plane(3)%normal = unit_cross(edge30, edge20) - plane(4)%normal = unit_cross(edge21, edge31) + pure function get_planes_tet(tet) result(plane) + type(tet_type), intent(in) :: tet + type(plane_type), dimension(4) :: plane + + real, dimension(3) :: edge10, edge20, edge30, edge21, edge31 + real :: det + integer :: i + + edge10 = tet%V(:, 2) - tet%V(:, 1); + edge20 = tet%V(:, 3) - tet%V(:, 1); + edge30 = tet%V(:, 4) - tet%V(:, 1); + edge21 = tet%V(:, 3) - tet%V(:, 2); + edge31 = tet%V(:, 4) - tet%V(:, 2); + + plane(1)%normal = unit_cross(edge20, edge10) + plane(2)%normal = unit_cross(edge10, edge30) + plane(3)%normal = unit_cross(edge30, edge20) + plane(4)%normal = unit_cross(edge21, edge31) + + det = dot_product(edge10, plane(4)%normal) + if (det < 0) then + do i=1,4 + plane(i)%normal = -plane(i)%normal + end do + end if - det = dot_product(edge10, plane(4)%normal) - if (det < 0) then + ! And calibrate what is the zero of this plane by dotting with + ! a point we know to be on it do i=1,4 - plane(i)%normal = -plane(i)%normal + plane(i)%c = dot_product(tet%V(:, i), plane(i)%normal) end do - end if - - ! And calibrate what is the zero of this plane by dotting with - ! a point we know to be on it - do i=1,4 - plane(i)%c = dot_product(tet%V(:, i), plane(i)%normal) - end do - end function get_planes_tet + end function get_planes_tet - function get_planes_hex(positions, ele) result(plane) - type(vector_field), intent(in) :: positions - integer, intent(in) :: ele - type(plane_type), dimension(6) :: plane - integer, dimension(:), pointer :: faces - integer :: i, face - integer, dimension(4) :: fnodes - real, dimension(positions%dim, face_ngi(positions, ele)) :: normals + function get_planes_hex(positions, ele) result(plane) + type(vector_field), intent(in) :: positions + integer, intent(in) :: ele + type(plane_type), dimension(6) :: plane + integer, dimension(:), pointer :: faces + integer :: i, face + integer, dimension(4) :: fnodes + real, dimension(positions%dim, face_ngi(positions, ele)) :: normals - ! This could be done much more efficiently by exploiting - ! more information about how we number faces and such on a hex + ! This could be done much more efficiently by exploiting + ! more information about how we number faces and such on a hex - assert(positions%mesh%shape%numbering%family == FAMILY_CUBE) - assert(positions%mesh%faces%shape%numbering%family == FAMILY_CUBE) - assert(positions%mesh%shape%degree == 1) - assert(has_faces(positions%mesh)) + assert(positions%mesh%shape%numbering%family == FAMILY_CUBE) + assert(positions%mesh%faces%shape%numbering%family == FAMILY_CUBE) + assert(positions%mesh%shape%degree == 1) + assert(has_faces(positions%mesh)) - faces => ele_faces(positions, ele) - assert(size(faces) == 6) + faces => ele_faces(positions, ele) + assert(size(faces) == 6) - do i=1,size(faces) - face = faces(i) - fnodes = face_global_nodes(positions, face) + do i=1,size(faces) + face = faces(i) + fnodes = face_global_nodes(positions, face) - call transform_facet_to_physical(positions, face, normal=normals) - plane(i)%normal = normals(:, 1) + call transform_facet_to_physical(positions, face, normal=normals) + plane(i)%normal = normals(:, 1) - ! Now we calibrate the constant (setting the 'zero level' of the plane, as it were) - ! with a node we know is on the face - plane(i)%c = dot_product(plane(i)%normal, node_val(positions, fnodes(1))) + ! Now we calibrate the constant (setting the 'zero level' of the plane, as it were) + ! with a node we know is on the face + plane(i)%c = dot_product(plane(i)%normal, node_val(positions, fnodes(1))) - end do - end function get_planes_hex + end do + end function get_planes_hex - pure function unit_cross(vecA, vecB) result(cross) - real, dimension(3), intent(in) :: vecA, vecB - real, dimension(3) :: cross - cross(1) = vecA(2) * vecB(3) - vecA(3) * vecB(2) - cross(2) = vecA(3) * vecB(1) - vecA(1) * vecB(3) - cross(3) = vecA(1) * vecB(2) - vecA(2) * vecB(1) + pure function unit_cross(vecA, vecB) result(cross) + real, dimension(3), intent(in) :: vecA, vecB + real, dimension(3) :: cross + cross(1) = vecA(2) * vecB(3) - vecA(3) * vecB(2) + cross(2) = vecA(3) * vecB(1) - vecA(1) * vecB(3) + cross(3) = vecA(1) * vecB(2) - vecA(2) * vecB(1) - cross = cross / norm2(cross) - end function unit_cross + cross = cross / norm2(cross) + end function unit_cross #ifndef HAVE_LIBSUPERMESH - pure function distances_to_plane(plane, tet) result(dists) - type(plane_type), intent(in) :: plane - type(tet_type), intent(in) :: tet - real, dimension(4) :: dists - integer :: i - - forall(i=1:4) - dists(i) = dot_product(plane%normal, tet%V(:, i)) - plane%c - end forall - end function distances_to_plane - - pure function tet_volume(tet) result(vol) - type(tet_type), intent(in) :: tet - real :: vol - real, dimension(3) :: cross, vecA, vecB, vecC - - vecA = tet%V(:, 1) - tet%V(:, 4) - vecB = tet%V(:, 2) - tet%V(:, 4) - vecC = tet%V(:, 3) - tet%V(:, 4) - - cross(1) = vecB(2) * vecC(3) - vecB(3) * vecC(2) - cross(2) = vecB(3) * vecC(1) - vecB(1) * vecC(3) - cross(3) = vecB(1) * vecC(2) - vecB(2) * vecC(1) - - vol = dot_product(vecA, cross) / 6.0 - end function tet_volume - - function face_no(i, j, k) result(face) - ! Given three local node numbers, what is the face that they share? - integer, intent(in) :: i, j, k - integer :: face - - do face=1,4 - if (face /= i .and. face /= j .and. face /= k) return - end do - - end function face_no + pure function distances_to_plane(plane, tet) result(dists) + type(plane_type), intent(in) :: plane + type(tet_type), intent(in) :: tet + real, dimension(4) :: dists + integer :: i + + forall(i=1:4) + dists(i) = dot_product(plane%normal, tet%V(:, i)) - plane%c + end forall + end function distances_to_plane + + pure function tet_volume(tet) result(vol) + type(tet_type), intent(in) :: tet + real :: vol + real, dimension(3) :: cross, vecA, vecB, vecC + + vecA = tet%V(:, 1) - tet%V(:, 4) + vecB = tet%V(:, 2) - tet%V(:, 4) + vecC = tet%V(:, 3) - tet%V(:, 4) + + cross(1) = vecB(2) * vecC(3) - vecB(3) * vecC(2) + cross(2) = vecB(3) * vecC(1) - vecB(1) * vecC(3) + cross(3) = vecB(1) * vecC(2) - vecB(2) * vecC(1) + + vol = dot_product(vecA, cross) / 6.0 + end function tet_volume + + function face_no(i, j, k) result(face) + ! Given three local node numbers, what is the face that they share? + integer, intent(in) :: i, j, k + integer :: face + + do face=1,4 + if (face /= i .and. face /= j .and. face /= k) return + end do + + end function face_no #endif end module tetrahedron_intersection_module diff --git a/femtools/Time_Period.F90 b/femtools/Time_Period.F90 index 511d706017..b70697a421 100644 --- a/femtools/Time_Period.F90 +++ b/femtools/Time_Period.F90 @@ -3,225 +3,225 @@ #include "fdebug.h" module time_period - use FLDebug - use global_parameters, only: OPTION_PATH_LEN - use embed_python - use spud - use parallel_tools - use timers - - implicit none - - !! Type for holding information about a previous dump period - type time_period_type - private - - !! whether the previous dump times have been initialised - logical :: last_times_initialised = .false. - - !! the requested time between dumps in model seconds - real :: real_dump_period = 0.0 - !! the requested time between dumps in timesteps - integer :: int_dump_period = 0 - !! the last model time at which a dump was performed (or when this - !! control struct was initialised) - real :: last_dump_time - - !! the last cpu time at which a dump was performed - real :: last_dump_cpu_time - !! the last wall time at which a dump was performed - real :: last_dump_wall_time - end type time_period_type + use FLDebug + use global_parameters, only: OPTION_PATH_LEN + use embed_python + use spud + use parallel_tools + use timers + + implicit none + + !! Type for holding information about a previous dump period + type time_period_type + private + + !! whether the previous dump times have been initialised + logical :: last_times_initialised = .false. + + !! the requested time between dumps in model seconds + real :: real_dump_period = 0.0 + !! the requested time between dumps in timesteps + integer :: int_dump_period = 0 + !! the last model time at which a dump was performed (or when this + !! control struct was initialised) + real :: last_dump_time + + !! the last cpu time at which a dump was performed + real :: last_dump_cpu_time + !! the last wall time at which a dump was performed + real :: last_dump_wall_time + end type time_period_type contains - function should_output(CS, current_time, timestep, option_path) - !!< Given a time period control struct, should a new dump be - !!< created at this moment in time (considering model time, the - !!< current timestep, CPU time, and walltime)? + function should_output(CS, current_time, timestep, option_path) + !!< Given a time period control struct, should a new dump be + !!< created at this moment in time (considering model time, the + !!< current timestep, CPU time, and walltime)? - logical :: should_output + logical :: should_output - type(time_period_type), intent(inout) :: CS - real, intent(in) :: current_time - integer, intent(in) :: timestep + type(time_period_type), intent(inout) :: CS + real, intent(in) :: current_time + integer, intent(in) :: timestep - character(len=*), intent(in) :: option_path + character(len=*), intent(in) :: option_path - integer :: stat - real :: current_cpu_time, current_wall_time - character(len=OPTION_PATH_LEN) :: func + integer :: stat + real :: current_cpu_time, current_wall_time + character(len=OPTION_PATH_LEN) :: func - should_output = .false. + should_output = .false. - if (have_option(trim(option_path) // "/exclude_from_output")) then - ! this group will never be output - return - end if - - if (.not. CS%last_times_initialised) then - ! if the last_dump*_time variables have not been initialised, assume there should be output + if (have_option(trim(option_path) // "/exclude_from_output")) then + ! this group will never be output + return + end if - should_output = .true. - return - end if + if (.not. CS%last_times_initialised) then + ! if the last_dump*_time variables have not been initialised, assume there should be output - if (have_option(trim(option_path) // "/dump_period")) then - ! dump period isn't set, or dump period has elapsed since the last time there was a dump + should_output = .true. + return + end if - ! avoid division by zero due to non-short-circuiting operator - if (CS%real_dump_period == 0.0) then - should_output = .true. - else if (dump_count_greater(current_time, CS%last_dump_time, CS%real_dump_period)) then - should_output = .true. + if (have_option(trim(option_path) // "/dump_period")) then + ! dump period isn't set, or dump period has elapsed since the last time there was a dump + + ! avoid division by zero due to non-short-circuiting operator + if (CS%real_dump_period == 0.0) then + should_output = .true. + else if (dump_count_greater(current_time, CS%last_dump_time, CS%real_dump_period)) then + should_output = .true. + end if + + if (should_output) then + if (have_option(trim(option_path) // "/dump_period/constant")) then + call get_option(trim(option_path) // "/dump_period/constant", CS%real_dump_period) + else if (have_option(trim(option_path) // "/dump_period/python")) then + call get_option(trim(option_path) // "/dump_period/python", func) + call real_from_python(func, current_time, CS%real_dump_period) + else + FLAbort("Unable to determine dump period type.") + end if + + if (CS%real_dump_period < 0.0) then + FLExit("Dump period cannot be negative.") + end if + + return + end if end if - if (should_output) then - if (have_option(trim(option_path) // "/dump_period/constant")) then - call get_option(trim(option_path) // "/dump_period/constant", CS%real_dump_period) - else if (have_option(trim(option_path) // "/dump_period/python")) then - call get_option(trim(option_path) // "/dump_period/python", func) - call real_from_python(func, current_time, CS%real_dump_period) - else - FLAbort("Unable to determine dump period type.") - end if - - if (CS%real_dump_period < 0.0) then - FLExit("Dump period cannot be negative.") - end if - - return + if (have_option(trim(option_path) // "/dump_period_in_timesteps")) then + ! timestep dump period isn't set, or the required number of timesteps has passed since the last dump + + if (CS%int_dump_period == 0) then + should_output = .true. + else if (mod(timestep, CS%int_dump_period) == 0) then + should_output = .true. + end if + + if (should_output) then + if (have_option(trim(option_path) // "/dump_period_in_timesteps/constant")) then + call get_option(trim(option_path) // "/dump_period_in_timesteps/constant", CS%int_dump_period) + else if (have_option(trim(option_path) // "/dump_period_in_timesteps/python")) then + call get_option(trim(option_path) // "/dump_period_in_timesteps/python", func) + call integer_from_python(func, current_time, CS%int_dump_period) + else + FLAbort("Unable to determine dump period type.") + end if + + if (CS%int_dump_period < 0) then + FLExit("Dump period cannot be negative.") + end if + + return + end if end if - end if - if (have_option(trim(option_path) // "/dump_period_in_timesteps")) then - ! timestep dump period isn't set, or the required number of timesteps has passed since the last dump + if (.not. have_option(trim(option_path) // "/dump_period") .and. .not. have_option(trim(option_path) // "/dump_period_in_timesteps")) then + ! if the option isn't set, assume always output - if (CS%int_dump_period == 0) then - should_output = .true. - else if (mod(timestep, CS%int_dump_period) == 0) then - should_output = .true. + should_output = .true. + return end if - if (should_output) then - if (have_option(trim(option_path) // "/dump_period_in_timesteps/constant")) then - call get_option(trim(option_path) // "/dump_period_in_timesteps/constant", CS%int_dump_period) - else if (have_option(trim(option_path) // "/dump_period_in_timesteps/python")) then - call get_option(trim(option_path) // "/dump_period_in_timesteps/python", func) - call integer_from_python(func, current_time, CS%int_dump_period) - else - FLAbort("Unable to determine dump period type.") - end if - - if (CS%int_dump_period < 0) then - FLExit("Dump period cannot be negative.") - end if - - return + call cpu_time(current_cpu_time) + call allmax(current_cpu_time) + call get_option(trim(option_path) // "/cpu_dump_period", CS%real_dump_period, stat) + if (stat == SPUD_NO_ERROR) then + if (CS%real_dump_period == 0.0) then + should_output = .true. + return + else if (dump_count_greater(current_cpu_time, CS%last_dump_cpu_time, CS%real_dump_period)) then + should_output = .true. + return + end if end if - end if - - if (.not. have_option(trim(option_path) // "/dump_period") .and. .not. have_option(trim(option_path) // "/dump_period_in_timesteps")) then - ! if the option isn't set, assume always output - - should_output = .true. - return - end if - - call cpu_time(current_cpu_time) - call allmax(current_cpu_time) - call get_option(trim(option_path) // "/cpu_dump_period", CS%real_dump_period, stat) - if (stat == SPUD_NO_ERROR) then - if (CS%real_dump_period == 0.0) then - should_output = .true. - return - else if (dump_count_greater(current_cpu_time, CS%last_dump_cpu_time, CS%real_dump_period)) then - should_output = .true. - return - end if - end if - - current_wall_time = wall_time() - call allmax(current_wall_time) - call get_option(trim(option_path) // "/wall_time_dump_period", CS%real_dump_period, stat) - if (stat == SPUD_NO_ERROR) then - if (CS%real_dump_period == 0.0) then - should_output = .true. - return - else if (dump_count_greater(current_wall_time, CS%last_dump_wall_time, CS%real_dump_period)) then - should_output = .true. - return + + current_wall_time = wall_time() + call allmax(current_wall_time) + call get_option(trim(option_path) // "/wall_time_dump_period", CS%real_dump_period, stat) + if (stat == SPUD_NO_ERROR) then + if (CS%real_dump_period == 0.0) then + should_output = .true. + return + else if (dump_count_greater(current_wall_time, CS%last_dump_wall_time, CS%real_dump_period)) then + should_output = .true. + return + end if end if - end if - contains - pure function dump_count_greater(later_time, earlier_time, dump_period) - !!< Return whether the total number of dumps at time later_time is greater - !!< than the total number of dumps at time earlier_time. + contains + pure function dump_count_greater(later_time, earlier_time, dump_period) + !!< Return whether the total number of dumps at time later_time is greater + !!< than the total number of dumps at time earlier_time. - logical :: dump_count_greater + logical :: dump_count_greater - real, intent(in) :: later_time, earlier_time, dump_period + real, intent(in) :: later_time, earlier_time, dump_period - dump_count_greater = floor(later_time / dump_period) > floor(earlier_time / dump_period) - end function dump_count_greater - end function should_output + dump_count_greater = floor(later_time / dump_period) > floor(earlier_time / dump_period) + end function dump_count_greater + end function should_output - subroutine init_output_CS(CS, option_path) - !!< Initialise a time period control structure, reading options - !!< from the specified option_path. + subroutine init_output_CS(CS, option_path) + !!< Initialise a time period control structure, reading options + !!< from the specified option_path. - type(time_period_type), intent(inout) :: CS - character(len=*), intent(in) :: option_path !! path prefix for reading options + type(time_period_type), intent(inout) :: CS + character(len=*), intent(in) :: option_path !! path prefix for reading options - character(len=OPTION_PATH_LEN) :: func + character(len=OPTION_PATH_LEN) :: func - call get_option("/timestepping/current_time", CS%last_dump_time) + call get_option("/timestepping/current_time", CS%last_dump_time) - if (have_option(trim(option_path) // "/dump_period/constant")) then - call get_option(trim(option_path) // "/dump_period/constant", CS%real_dump_period) + if (have_option(trim(option_path) // "/dump_period/constant")) then + call get_option(trim(option_path) // "/dump_period/constant", CS%real_dump_period) - else if (have_option(trim(option_path) // "/dump_period/python")) then - ! set a dummy dump period and call to the set function -- we don't count this as - ! initialising the last dump time (unlike update_output_CS) - CS%real_dump_period = huge(0.0) - call get_option(trim(option_path) // "/dump_period/python", func) - call real_from_python(func, CS%last_dump_time, CS%real_dump_period) + else if (have_option(trim(option_path) // "/dump_period/python")) then + ! set a dummy dump period and call to the set function -- we don't count this as + ! initialising the last dump time (unlike update_output_CS) + CS%real_dump_period = huge(0.0) + call get_option(trim(option_path) // "/dump_period/python", func) + call real_from_python(func, CS%last_dump_time, CS%real_dump_period) - if (CS%real_dump_period < 0.0) then - FLExit("Dump period cannot be negative.") - end if + if (CS%real_dump_period < 0.0) then + FLExit("Dump period cannot be negative.") + end if - else if (have_option(trim(option_path) // "/dump_period_in_timesteps/constant")) then - call get_option(trim(option_path) // "/dump_period_in_timesteps/constant", CS%int_dump_period) + else if (have_option(trim(option_path) // "/dump_period_in_timesteps/constant")) then + call get_option(trim(option_path) // "/dump_period_in_timesteps/constant", CS%int_dump_period) - else if (have_option(trim(option_path) // "/dump_period_in_timesteps/python")) then - ! set a dummy period and call the function - CS%int_dump_period = huge(0) - call get_option(trim(option_path) // "/dump_period_in_timesteps/python", func) - call integer_from_python(func, CS%last_dump_time, CS%int_dump_period) + else if (have_option(trim(option_path) // "/dump_period_in_timesteps/python")) then + ! set a dummy period and call the function + CS%int_dump_period = huge(0) + call get_option(trim(option_path) // "/dump_period_in_timesteps/python", func) + call integer_from_python(func, CS%last_dump_time, CS%int_dump_period) - if (CS%int_dump_period < 0) then - FLExit("Dump period cannot be negative.") + if (CS%int_dump_period < 0) then + FLExit("Dump period cannot be negative.") + end if end if - end if - end subroutine init_output_CS + end subroutine init_output_CS - subroutine update_output_CS(CS, current_time) - !!< Update the given time period control structure after - !!< a dump has been made. + subroutine update_output_CS(CS, current_time) + !!< Update the given time period control structure after + !!< a dump has been made. - type(time_period_type), intent(inout) :: CS - real, intent(in) :: current_time + type(time_period_type), intent(inout) :: CS + real, intent(in) :: current_time - CS%last_times_initialised = .true. + CS%last_times_initialised = .true. - ! update model, cpu and walltimes in the structure - CS%last_dump_time = current_time + ! update model, cpu and walltimes in the structure + CS%last_dump_time = current_time - call cpu_time(CS%last_dump_cpu_time) - call allmax(CS%last_dump_cpu_time) + call cpu_time(CS%last_dump_cpu_time) + call allmax(CS%last_dump_cpu_time) - CS%last_dump_wall_time = wall_time() - call allmax(CS%last_dump_wall_time) - end subroutine update_output_CS + CS%last_dump_wall_time = wall_time() + call allmax(CS%last_dump_wall_time) + end subroutine update_output_CS end module time_period diff --git a/femtools/Timers.F90 b/femtools/Timers.F90 index 0eee66ef57..8be6366c7a 100644 --- a/femtools/Timers.F90 +++ b/femtools/Timers.F90 @@ -30,83 +30,83 @@ module timers ! !!< This module contains routines which time the fluidity run - use iso_c_binding, only: c_double - use fldebug - use mpi_interfaces + use iso_c_binding, only: c_double + use fldebug + use mpi_interfaces - implicit none + implicit none - private + private - public :: wall_time, wall_time_supported + public :: wall_time, wall_time_supported contains - function wall_time() - ! This function returns the wall clock time from when the - ! simulation started. - ! - ! It must be called at the start of the simulation to get the clock - ! running. - real(kind = c_double):: wall_time - logical, save :: started=.false. + function wall_time() + ! This function returns the wall clock time from when the + ! simulation started. + ! + ! It must be called at the start of the simulation to get the clock + ! running. + real(kind = c_double):: wall_time + logical, save :: started=.false. #ifdef HAVE_MPI - real(kind = c_double), save :: wall_time0 - - wall_time = MPI_Wtime() - if(.not.started) then - wall_time0 = wall_time - wall_time = 0.0 - started=.true. - else - wall_time = wall_time - wall_time0 - endif + real(kind = c_double), save :: wall_time0 + + wall_time = MPI_Wtime() + if(.not.started) then + wall_time0 = wall_time + wall_time = 0.0 + started=.true. + else + wall_time = wall_time - wall_time0 + endif #else - integer, save :: clock0 - integer, save :: clock1,clockmax,clockrate, ticks - real secs - logical, save :: clock_support=.true. - - ! Initialize - wall_time = -1.0 - - ! Return -1.0 if no clock support - IF(.not.clock_support) return - - IF(.not.started) THEN - call system_clock(count_max=clockmax, count_rate=clockrate) - call system_clock(clock0) - - IF(clockrate==0) THEN - clock_support=.false. - ewrite(-1, *) "No wall time support" - else - wall_time = 0.0 - ENDIF - - started=.true. - ELSE - call system_clock(clock1) - ticks=clock1-clock0 - ! reset -ve numbers - ticks=mod(ticks+clockmax, clockmax) - secs= real(ticks)/real(clockrate) - wall_time=secs - ENDIF + integer, save :: clock0 + integer, save :: clock1,clockmax,clockrate, ticks + real secs + logical, save :: clock_support=.true. + + ! Initialize + wall_time = -1.0 + + ! Return -1.0 if no clock support + IF(.not.clock_support) return + + IF(.not.started) THEN + call system_clock(count_max=clockmax, count_rate=clockrate) + call system_clock(clock0) + + IF(clockrate==0) THEN + clock_support=.false. + ewrite(-1, *) "No wall time support" + else + wall_time = 0.0 + ENDIF + + started=.true. + ELSE + call system_clock(clock1) + ticks=clock1-clock0 + ! reset -ve numbers + ticks=mod(ticks+clockmax, clockmax) + secs= real(ticks)/real(clockrate) + wall_time=secs + ENDIF #endif - end function wall_time + end function wall_time - function wall_time_supported() result(supported) + function wall_time_supported() result(supported) ! !!< Return whether wall time is supported - logical :: supported + logical :: supported #ifdef HAVE_MPI - supported = .true. + supported = .true. #else - supported = (wall_time() >= 0.0) + supported = (wall_time() >= 0.0) #endif - end function wall_time_supported + end function wall_time_supported end module timers diff --git a/femtools/Transform_elements.F90 b/femtools/Transform_elements.F90 index 19c89e4e6a..84df94b29b 100644 --- a/femtools/Transform_elements.F90 +++ b/femtools/Transform_elements.F90 @@ -27,909 +27,909 @@ #include "fdebug.h" module transform_elements - ! Module to calculate element transformations from local to physical - ! coordinates. - use fldebug - use futils, only: present_and_true - use vector_tools - use quadrature - use element_numbering - use elements - use parallel_tools, only: abort_if_in_parallel_region - use memory_diagnostics - use fields_data_types - use fields_base - use cv_faces, only: cv_faces_type - use eventcounter - - implicit none - - interface transform_to_physical - module procedure transform_to_physical_full, transform_to_physical_detwei - end interface - - interface transform_facet_to_physical - module procedure transform_facet_to_physical_full, & - transform_facet_to_physical_detwei, transform_full_facet_to_physical_full - end interface transform_facet_to_physical - - interface retrieve_cached_transform - module procedure retrieve_cached_transform_full, & - retrieve_cached_transform_det - end interface - - interface retrieve_cached_face_transform - module procedure retrieve_cached_face_transform_full, retrieve_cached_full_face_transform_full - end interface - - interface local_coords - module procedure local_coords_interpolation - end interface - - private - public :: transform_to_physical, transform_facet_to_physical, & - transform_cvsurf_to_physical, transform_cvsurf_facet_to_physical, & - transform_superconvergent_to_physical, transform_horizontal_to_physical, & - compute_jacobian, compute_inverse_jacobian, & - compute_facet_full_inverse_jacobian, element_volume,& - cache_transform_elements, deallocate_transform_cache, & - prepopulate_transform_cache, set_analytical_spherical_mapping, & - local_coords, local_coords_interpolation - - integer, parameter :: cyc3(1:5)=(/ 1, 2, 3, 1, 2 /) - - logical, save :: cache_transform_elements=.true. - real, dimension(:,:,:), allocatable, save :: invJ_cache - real, dimension(:,:,:), allocatable, save :: J_T_cache - real, dimension(:), allocatable, save :: detJ_cache - - real, dimension(:,:), allocatable, save :: face_normal_cache - real, dimension(:), allocatable, save :: face_detJ_cache - real, dimension(:,:,:), allocatable, save :: face_invJ_cache - real, dimension(:,:,:), allocatable, save :: face_J_T_cache - ! Record which element is on the other side of the last n/2 elements. - integer, dimension(:), allocatable, save :: face_cache - - - ! The reference count id of the positions mesh being cached. - integer, save :: position_id=-1 - integer, save :: last_mesh_movement=-1 - integer, save :: face_position_id=-1 - integer, save :: face_last_mesh_movement=-1 - integer, save :: full_face_position_id=-1 - integer, save :: full_face_last_mesh_movement=-1 - - integer, save :: analytical_spherical_position_id=-1 - logical, save :: analytical_spherical_mapping=.false. + ! Module to calculate element transformations from local to physical + ! coordinates. + use fldebug + use futils, only: present_and_true + use vector_tools + use quadrature + use element_numbering + use elements + use parallel_tools, only: abort_if_in_parallel_region + use memory_diagnostics + use fields_data_types + use fields_base + use cv_faces, only: cv_faces_type + use eventcounter + + implicit none + + interface transform_to_physical + module procedure transform_to_physical_full, transform_to_physical_detwei + end interface + + interface transform_facet_to_physical + module procedure transform_facet_to_physical_full, & + transform_facet_to_physical_detwei, transform_full_facet_to_physical_full + end interface transform_facet_to_physical + + interface retrieve_cached_transform + module procedure retrieve_cached_transform_full, & + retrieve_cached_transform_det + end interface + + interface retrieve_cached_face_transform + module procedure retrieve_cached_face_transform_full, retrieve_cached_full_face_transform_full + end interface + + interface local_coords + module procedure local_coords_interpolation + end interface + + private + public :: transform_to_physical, transform_facet_to_physical, & + transform_cvsurf_to_physical, transform_cvsurf_facet_to_physical, & + transform_superconvergent_to_physical, transform_horizontal_to_physical, & + compute_jacobian, compute_inverse_jacobian, & + compute_facet_full_inverse_jacobian, element_volume,& + cache_transform_elements, deallocate_transform_cache, & + prepopulate_transform_cache, set_analytical_spherical_mapping, & + local_coords, local_coords_interpolation + + integer, parameter :: cyc3(1:5)=(/ 1, 2, 3, 1, 2 /) + + logical, save :: cache_transform_elements=.true. + real, dimension(:,:,:), allocatable, save :: invJ_cache + real, dimension(:,:,:), allocatable, save :: J_T_cache + real, dimension(:), allocatable, save :: detJ_cache + + real, dimension(:,:), allocatable, save :: face_normal_cache + real, dimension(:), allocatable, save :: face_detJ_cache + real, dimension(:,:,:), allocatable, save :: face_invJ_cache + real, dimension(:,:,:), allocatable, save :: face_J_T_cache + ! Record which element is on the other side of the last n/2 elements. + integer, dimension(:), allocatable, save :: face_cache + + + ! The reference count id of the positions mesh being cached. + integer, save :: position_id=-1 + integer, save :: last_mesh_movement=-1 + integer, save :: face_position_id=-1 + integer, save :: face_last_mesh_movement=-1 + integer, save :: full_face_position_id=-1 + integer, save :: full_face_last_mesh_movement=-1 + + integer, save :: analytical_spherical_position_id=-1 + logical, save :: analytical_spherical_mapping=.false. contains - subroutine set_analytical_spherical_mapping() - !!< Set the global analytical spherical mapping flag - analytical_spherical_mapping = .true. - end subroutine + subroutine set_analytical_spherical_mapping() + !!< Set the global analytical spherical mapping flag + analytical_spherical_mapping = .true. + end subroutine - function use_analytical_spherical_mapping(X) - !!< Determine whether we are using analytical spherical mapping for this positions field - type(vector_field), intent(in) :: X - logical use_analytical_spherical_mapping + function use_analytical_spherical_mapping(X) + !!< Determine whether we are using analytical spherical mapping for this positions field + type(vector_field), intent(in) :: X + logical use_analytical_spherical_mapping - use_analytical_spherical_mapping=.false. - if (analytical_spherical_mapping) then - if (X%refcount%id==analytical_spherical_position_id) then - use_analytical_spherical_mapping = .true. - else - if (X%name=="Coordinate") then - analytical_spherical_position_id = X%refcount%id - use_analytical_spherical_mapping = .true. - end if + use_analytical_spherical_mapping=.false. + if (analytical_spherical_mapping) then + if (X%refcount%id==analytical_spherical_position_id) then + use_analytical_spherical_mapping = .true. + else + if (X%name=="Coordinate") then + analytical_spherical_position_id = X%refcount%id + use_analytical_spherical_mapping = .true. + end if + end if + end if + + end function + + function is_cache_valid(X) result (cache_valid) + !!< Is the cache (still) valid for the given coordinate field + !!< (e.g. has it been initialised at all, have we adapted, moved the mesh etc.) + !!< If *not*, reconstruct the cache, and then return .true. + !!< For nonlinear coordinates this always returns .false. + type(vector_field), intent(in) :: X + logical :: cache_valid + + logical :: x_spherical, x_nonlinear + + cache_valid=.true. + + if (X%refcount%id/=position_id) then + cache_valid=.false. + if (X%name/="Coordinate") then + ! If Someone is not calling this on the main Coordinate field + ! then we're screwed anyway. + return + end if + + else if(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) then + cache_valid=.false. + end if + + x_spherical = use_analytical_spherical_mapping(X) + + x_nonlinear = x_spherical .or. .not.(X%mesh%shape%degree==1 .and. X%mesh%shape%numbering%family==FAMILY_SIMPLEX) + if (x_nonlinear) then + cache_valid=.false. + return + end if + + if (.not.cache_valid) then + call construct_cache(X) + cache_valid=.true. end if - end if - - end function - - function is_cache_valid(X) result (cache_valid) - !!< Is the cache (still) valid for the given coordinate field - !!< (e.g. has it been initialised at all, have we adapted, moved the mesh etc.) - !!< If *not*, reconstruct the cache, and then return .true. - !!< For nonlinear coordinates this always returns .false. - type(vector_field), intent(in) :: X - logical :: cache_valid - - logical :: x_spherical, x_nonlinear - - cache_valid=.true. - - if (X%refcount%id/=position_id) then - cache_valid=.false. - if (X%name/="Coordinate") then - ! If Someone is not calling this on the main Coordinate field - ! then we're screwed anyway. - return - end if - - else if(eventcount(EVENT_MESH_MOVEMENT)/=last_mesh_movement) then - cache_valid=.false. - end if - - x_spherical = use_analytical_spherical_mapping(X) - - x_nonlinear = x_spherical .or. .not.(X%mesh%shape%degree==1 .and. X%mesh%shape%numbering%family==FAMILY_SIMPLEX) - if (x_nonlinear) then - cache_valid=.false. - return - end if - - if (.not.cache_valid) then - call construct_cache(X) - cache_valid=.true. - end if - - end function is_cache_valid - - function retrieve_cached_transform_full(X, ele, J_local_T, invJ_local,& - & detJ_local) result (cache_valid) - !!< Determine whether the transform cache is valid for this operation. - !!< - !!< If caching is applicable and the cache is not ready, set up the - !!< cache and then return true. - type(vector_field), intent(in) :: X - integer, intent(in) :: ele - !! Local versions of the Jacobian matrix and its inverse. (dim x dim) - real, dimension(:,:), intent(out) :: J_local_T, invJ_local - !! Local version of the determinant of J - real, intent(out) :: detJ_local - logical :: cache_valid - - cache_valid = is_cache_valid(X) - if (.not. cache_valid) return - - - J_local_T=J_T_cache(:, :, ele) - invJ_local=invJ_cache(:, :, ele) - detJ_local=detJ_cache(ele) - - end function retrieve_cached_transform_full - - function retrieve_cached_transform_det(X, ele, detJ_local) & - result (cache_valid) - !!< Determine whether the transform cache is valid for this operation. - !!< - !!< If caching is applicable and the cache is not ready, set up the - !!< cache and then return true. - type(vector_field), intent(in) :: X - integer, intent(in) :: ele - !! Local version of the determinant of J - real, intent(out) :: detJ_local - logical :: cache_valid - - cache_valid = is_cache_valid(X) - if (.not. cache_valid) return - - detJ_local=detJ_cache(ele) - - end function retrieve_cached_transform_det - - function prepopulate_transform_cache(X) result (cache_valid) - !!< Prepopulate the caches for transform_to_physical and - !!< transform_face_to_physical - !! - !!< If you're going to call transform_to_physical on a coordinate - !!< field inside a threaded region, you need to call this on the - !!< same field before entering the region. - type(vector_field), intent(in) :: X - logical :: cache_valid - - cache_valid = is_cache_valid(X) .and. is_face_cache_valid(X) - - end function prepopulate_transform_cache - - subroutine construct_cache(X) - !!< The cache is invalid so make a new one. - type(vector_field), intent(in) :: X - - integer :: elements, ele, i, k - !! Note that if X is not all linear simplices we are screwed. - real, dimension(X%dim, ele_loc(X,1)) :: X_val - type(element_type), pointer :: X_shape + + end function is_cache_valid + + function retrieve_cached_transform_full(X, ele, J_local_T, invJ_local,& + & detJ_local) result (cache_valid) + !!< Determine whether the transform cache is valid for this operation. + !!< + !!< If caching is applicable and the cache is not ready, set up the + !!< cache and then return true. + type(vector_field), intent(in) :: X + integer, intent(in) :: ele + !! Local versions of the Jacobian matrix and its inverse. (dim x dim) + real, dimension(:,:), intent(out) :: J_local_T, invJ_local + !! Local version of the determinant of J + real, intent(out) :: detJ_local + logical :: cache_valid + + cache_valid = is_cache_valid(X) + if (.not. cache_valid) return + + + J_local_T=J_T_cache(:, :, ele) + invJ_local=invJ_cache(:, :, ele) + detJ_local=detJ_cache(ele) + + end function retrieve_cached_transform_full + + function retrieve_cached_transform_det(X, ele, detJ_local) & + result (cache_valid) + !!< Determine whether the transform cache is valid for this operation. + !!< + !!< If caching is applicable and the cache is not ready, set up the + !!< cache and then return true. + type(vector_field), intent(in) :: X + integer, intent(in) :: ele + !! Local version of the determinant of J + real, intent(out) :: detJ_local + logical :: cache_valid + + cache_valid = is_cache_valid(X) + if (.not. cache_valid) return + + detJ_local=detJ_cache(ele) + + end function retrieve_cached_transform_det + + function prepopulate_transform_cache(X) result (cache_valid) + !!< Prepopulate the caches for transform_to_physical and + !!< transform_face_to_physical + !! + !!< If you're going to call transform_to_physical on a coordinate + !!< field inside a threaded region, you need to call this on the + !!< same field before entering the region. + type(vector_field), intent(in) :: X + logical :: cache_valid + + cache_valid = is_cache_valid(X) .and. is_face_cache_valid(X) + + end function prepopulate_transform_cache + + subroutine construct_cache(X) + !!< The cache is invalid so make a new one. + type(vector_field), intent(in) :: X + + integer :: elements, ele, i, k + !! Note that if X is not all linear simplices we are screwed. + real, dimension(X%dim, ele_loc(X,1)) :: X_val + type(element_type), pointer :: X_shape ! ewrite(1,*) "Reconstructing element geometry cache." - call abort_if_in_parallel_region + call abort_if_in_parallel_region - position_id=X%refcount%id - last_mesh_movement=eventcount(EVENT_MESH_MOVEMENT) + position_id=X%refcount%id + last_mesh_movement=eventcount(EVENT_MESH_MOVEMENT) - if (allocated(invJ_cache)) then + if (allocated(invJ_cache)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("transform_cache", & + call register_deallocation("transform_cache", & "real", size(invJ_cache)+size(J_T_cache)+size(detJ_cache)) #endif - deallocate(invJ_cache, J_T_cache, detJ_cache) - end if + deallocate(invJ_cache, J_T_cache, detJ_cache) + end if - elements=element_count(X) + elements=element_count(X) - allocate(invJ_cache(X%dim,X%dim,elements), & + allocate(invJ_cache(X%dim,X%dim,elements), & J_T_cache(X%dim,X%dim,elements), & detJ_cache(elements)) #ifdef HAVE_MEMORY_STATS - call register_allocation("transform_cache", & + call register_allocation("transform_cache", & "real", size(invJ_cache)+size(J_T_cache)+size(detJ_cache)) #endif - x_shape=>ele_shape(X,1) + x_shape=>ele_shape(X,1) - do ele=1,elements - X_val=ele_val(X, ele) - ! |- dx dx dx -| - ! | dL1 dL2 dL3 | - ! | | - ! | dy dy dy | - ! J = | dL1 dL2 dL3 | - ! | | - ! | dz dz dz | - ! |- dL1 dL2 dL3 -| + do ele=1,elements + X_val=ele_val(X, ele) + ! |- dx dx dx -| + ! | dL1 dL2 dL3 | + ! | | + ! | dy dy dy | + ! J = | dL1 dL2 dL3 | + ! | | + ! | dz dz dz | + ! |- dL1 dL2 dL3 -| - ! Form Jacobian. - ! Since X is linear we need only do this at quadrature point 1. - J_T_cache(:,:,ele)=matmul(X_val(:,:), x_shape%dn(:, 1, :)) + ! Form Jacobian. + ! Since X is linear we need only do this at quadrature point 1. + J_T_cache(:,:,ele)=matmul(X_val(:,:), x_shape%dn(:, 1, :)) - select case (X%dim) - case(1) - invJ_cache(:,:,ele)=1.0 - case(2) - invJ_cache(:,:,ele)=reshape(& + select case (X%dim) + case(1) + invJ_cache(:,:,ele)=1.0 + case(2) + invJ_cache(:,:,ele)=reshape(& (/ J_T_cache(2,2,ele),-J_T_cache(1,2,ele),& - & -J_T_cache(2,1,ele), J_T_cache(1,1,ele)/),(/2,2/)) - case(3) - ! Calculate (scaled) inverse using recursive determinants. - forall (i=1:3,k=1:3) - invJ_cache(i, k, ele)= & + & -J_T_cache(2,1,ele), J_T_cache(1,1,ele)/),(/2,2/)) + case(3) + ! Calculate (scaled) inverse using recursive determinants. + forall (i=1:3,k=1:3) + invJ_cache(i, k, ele)= & J_T_cache(cyc3(i+1),cyc3(k+1),ele)& - & *J_T_cache(cyc3(i+2),cyc3(k+2),ele) & + & *J_T_cache(cyc3(i+2),cyc3(k+2),ele) & -J_T_cache(cyc3(i+2),cyc3(k+1),ele)& - & *J_T_cache(cyc3(i+1),cyc3(k+2),ele) - end forall - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - ! Form determinant by expanding minors. - detJ_cache(ele)=dot_product(J_T_cache(:,1,ele),invJ_cache(:,1,ele)) - - ! Scale inverse by determinant. - invJ_cache(:,:,ele)=invJ_cache(:,:,ele)/detJ_cache(ele) - - end do - - end subroutine construct_cache - - function is_face_cache_valid(X) result (cache_valid) - !!< Is the face cache (still) valid for the given coordinate field - !!< (e.g. has it been initialised at all, have we adapted, moved the mesh etc.) - !!< If *not*, reconstruct the face cache, and then return .true. - !!< For nonlinear coordinates and the coordinates of an embedded manifold, - !!< X%dim/=mesh_dim, this always returns .false. - type(vector_field), intent(in) :: X - logical :: cache_valid - - logical :: x_spherical, xf_nonlinear - - cache_valid=.true. - - if (X%refcount%id/=face_position_id) then - cache_valid=.false. - if (X%name/="Coordinate") then - !!< If Someone is not calling this on the main Coordinate field - !!< then we're screwed anyway. - return - end if - else if(eventcount(EVENT_MESH_MOVEMENT)/=face_last_mesh_movement) then - cache_valid=.false. - end if - - if (X%dim/=mesh_dim(X)) then - ! this is an embedded (manifold) mesh - construct_face_cache() does not handle this - ! tranform_facet_to_physical_full() hopefully does? - cache_valid = .false. - return - end if - - x_spherical = use_analytical_spherical_mapping(X) - - xf_nonlinear = x_spherical .or. .not.(X%mesh%faces%shape%degree==1 .and. X%mesh%faces%shape%numbering%family==FAMILY_SIMPLEX) - if (xf_nonlinear) then - cache_valid=.false. - return - end if - - if (.not.cache_valid) then - call construct_face_cache(X) - cache_valid=.true. - end if - - end function is_face_cache_valid - - function retrieve_cached_face_transform_full(X, face, & - & normal_local, detJ_local) result (cache_valid) - !!< Determine whether the transform cache is valid for this operation. - !!< - !!< If caching is applicable and the cache is not ready, set up the - !!< cache and then return true. - type(vector_field), intent(in) :: X - integer, intent(in) :: face - !! Face determinant - real, intent(out) :: detJ_local - !! Face normal - real, dimension(X%dim), intent(out) :: normal_local - logical :: cache_valid - - cache_valid = is_face_cache_valid(X) - if (.not. cache_valid) return - - detJ_local=face_detJ_cache(abs(face_cache(face))) - normal_local=sign(1,face_cache(face))*face_normal_cache(:,abs(face_cache(face))) - - end function retrieve_cached_face_transform_full - - function retrieve_cached_full_face_transform_full(X, face, & - & normal_local, detJ_local, J_local_T, invJ_local) result (cache_valid) - !!< Determine whether the transform cache is valid for this operation. - !!< - !!< If caching is applicable and the cache is not ready, set up the - !!< cache and then return true. - type(vector_field), intent(in) :: X - integer, intent(in) :: face - !! Face determinant - real, intent(out) :: detJ_local - !! Face normal - real, dimension(X%dim), intent(out) :: normal_local - !! invJ - real, intent(out), dimension(:,:) :: J_local_T, invJ_local - logical :: cache_valid - - cache_valid = is_face_cache_valid(X) - if (.not. cache_valid) return - - ! if the face cache is valid, we should always be able to construct the full_face_cache as well - ! just need to check whether it is still up-to-date - if (X%refcount%id/=full_face_position_id .or. eventcount(EVENT_MESH_MOVEMENT)/=full_face_last_mesh_movement) then - call construct_full_face_cache(X) - end if - - detJ_local=face_detJ_cache(abs(face_cache(face))) - normal_local=sign(1,face_cache(face))*face_normal_cache(:,abs(face_cache(face))) - invJ_local = face_invJ_cache(:,:,face) - J_local_T = face_J_T_cache(:,:,face) - - end function retrieve_cached_full_face_transform_full - - subroutine construct_face_cache(X) - !!< The cache is invalid so make a new one. - type(vector_field), intent(in) :: X - - integer :: elements, ele, i, current_face, face, face2, faces, n,& - & unique_faces - !! Note that if X is not all linear simplices we are screwed. - real, dimension(X%dim, ele_loc(X,1)) :: X_val - real, dimension(X%dim, face_loc(X,1)) :: X_f - real, dimension(X%dim) :: X_centroid_ele, X_centroid_face - real, dimension(X%dim, X%dim-1) :: J - type(element_type), pointer :: X_shape_f - real :: detJ - integer, dimension(:), pointer :: neigh + & *J_T_cache(cyc3(i+1),cyc3(k+2),ele) + end forall + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + ! Form determinant by expanding minors. + detJ_cache(ele)=dot_product(J_T_cache(:,1,ele),invJ_cache(:,1,ele)) + + ! Scale inverse by determinant. + invJ_cache(:,:,ele)=invJ_cache(:,:,ele)/detJ_cache(ele) + + end do + + end subroutine construct_cache + + function is_face_cache_valid(X) result (cache_valid) + !!< Is the face cache (still) valid for the given coordinate field + !!< (e.g. has it been initialised at all, have we adapted, moved the mesh etc.) + !!< If *not*, reconstruct the face cache, and then return .true. + !!< For nonlinear coordinates and the coordinates of an embedded manifold, + !!< X%dim/=mesh_dim, this always returns .false. + type(vector_field), intent(in) :: X + logical :: cache_valid + + logical :: x_spherical, xf_nonlinear + + cache_valid=.true. + + if (X%refcount%id/=face_position_id) then + cache_valid=.false. + if (X%name/="Coordinate") then + !!< If Someone is not calling this on the main Coordinate field + !!< then we're screwed anyway. + return + end if + else if(eventcount(EVENT_MESH_MOVEMENT)/=face_last_mesh_movement) then + cache_valid=.false. + end if + + if (X%dim/=mesh_dim(X)) then + ! this is an embedded (manifold) mesh - construct_face_cache() does not handle this + ! tranform_facet_to_physical_full() hopefully does? + cache_valid = .false. + return + end if + + x_spherical = use_analytical_spherical_mapping(X) + + xf_nonlinear = x_spherical .or. .not.(X%mesh%faces%shape%degree==1 .and. X%mesh%faces%shape%numbering%family==FAMILY_SIMPLEX) + if (xf_nonlinear) then + cache_valid=.false. + return + end if + + if (.not.cache_valid) then + call construct_face_cache(X) + cache_valid=.true. + end if + + end function is_face_cache_valid + + function retrieve_cached_face_transform_full(X, face, & + & normal_local, detJ_local) result (cache_valid) + !!< Determine whether the transform cache is valid for this operation. + !!< + !!< If caching is applicable and the cache is not ready, set up the + !!< cache and then return true. + type(vector_field), intent(in) :: X + integer, intent(in) :: face + !! Face determinant + real, intent(out) :: detJ_local + !! Face normal + real, dimension(X%dim), intent(out) :: normal_local + logical :: cache_valid + + cache_valid = is_face_cache_valid(X) + if (.not. cache_valid) return + + detJ_local=face_detJ_cache(abs(face_cache(face))) + normal_local=sign(1,face_cache(face))*face_normal_cache(:,abs(face_cache(face))) + + end function retrieve_cached_face_transform_full + + function retrieve_cached_full_face_transform_full(X, face, & + & normal_local, detJ_local, J_local_T, invJ_local) result (cache_valid) + !!< Determine whether the transform cache is valid for this operation. + !!< + !!< If caching is applicable and the cache is not ready, set up the + !!< cache and then return true. + type(vector_field), intent(in) :: X + integer, intent(in) :: face + !! Face determinant + real, intent(out) :: detJ_local + !! Face normal + real, dimension(X%dim), intent(out) :: normal_local + !! invJ + real, intent(out), dimension(:,:) :: J_local_T, invJ_local + logical :: cache_valid + + cache_valid = is_face_cache_valid(X) + if (.not. cache_valid) return + + ! if the face cache is valid, we should always be able to construct the full_face_cache as well + ! just need to check whether it is still up-to-date + if (X%refcount%id/=full_face_position_id .or. eventcount(EVENT_MESH_MOVEMENT)/=full_face_last_mesh_movement) then + call construct_full_face_cache(X) + end if + + detJ_local=face_detJ_cache(abs(face_cache(face))) + normal_local=sign(1,face_cache(face))*face_normal_cache(:,abs(face_cache(face))) + invJ_local = face_invJ_cache(:,:,face) + J_local_T = face_J_T_cache(:,:,face) + + end function retrieve_cached_full_face_transform_full + + subroutine construct_face_cache(X) + !!< The cache is invalid so make a new one. + type(vector_field), intent(in) :: X + + integer :: elements, ele, i, current_face, face, face2, faces, n,& + & unique_faces + !! Note that if X is not all linear simplices we are screwed. + real, dimension(X%dim, ele_loc(X,1)) :: X_val + real, dimension(X%dim, face_loc(X,1)) :: X_f + real, dimension(X%dim) :: X_centroid_ele, X_centroid_face + real, dimension(X%dim, X%dim-1) :: J + type(element_type), pointer :: X_shape_f + real :: detJ + integer, dimension(:), pointer :: neigh ! ewrite(1,*) "Reconstructing element geometry cache." - call abort_if_in_parallel_region + call abort_if_in_parallel_region - face_position_id=X%refcount%id - face_last_mesh_movement=eventcount(EVENT_MESH_MOVEMENT) + face_position_id=X%refcount%id + face_last_mesh_movement=eventcount(EVENT_MESH_MOVEMENT) - if (allocated(face_detJ_cache)) then + if (allocated(face_detJ_cache)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("transform_cache", "real", & - & size(face_detJ_cache)+size(face_normal_cache)) - call register_deallocation("transform_cache", "integer", & - & size(face_cache)) + call register_deallocation("transform_cache", "real", & + & size(face_detJ_cache)+size(face_normal_cache)) + call register_deallocation("transform_cache", "integer", & + & size(face_cache)) #endif - deallocate(face_detJ_cache, face_normal_cache, face_cache) - end if + deallocate(face_detJ_cache, face_normal_cache, face_cache) + end if - elements=element_count(X) - faces=face_count(X) - !! This counts 1/2 for each interior face and 1 for each surface face. - unique_faces=unique_face_count(X%mesh) + elements=element_count(X) + faces=face_count(X) + !! This counts 1/2 for each interior face and 1 for each surface face. + unique_faces=unique_face_count(X%mesh) - allocate(face_detJ_cache(unique_faces), & + allocate(face_detJ_cache(unique_faces), & face_normal_cache(X%dim,unique_faces), & face_cache(faces)) #ifdef HAVE_MEMORY_STATS - call register_allocation("transform_cache", "real", & - & size(face_detJ_cache)+size(face_normal_cache)) - call register_allocation("transform_cache", "integer", & - & size(face_cache)) + call register_allocation("transform_cache", "real", & + & size(face_detJ_cache)+size(face_normal_cache)) + call register_allocation("transform_cache", "integer", & + & size(face_cache)) #endif - current_face=0 - do ele=1,elements - neigh=>ele_neigh(X, ele) - X_val=ele_val(X,ele) - - X_centroid_ele = sum(X_val, 2)/size(X_val, 2) + current_face=0 + do ele=1,elements + neigh=>ele_neigh(X, ele) + X_val=ele_val(X,ele) - do n=1,size(neigh) + X_centroid_ele = sum(X_val, 2)/size(X_val, 2) - if (neigh(n)<0) then - face=ele_face(X, ele, neigh(n)) + do n=1,size(neigh) - current_face=current_face+1 - face_cache(face)=current_face + if (neigh(n)<0) then + face=ele_face(X, ele, neigh(n)) - else + current_face=current_face+1 + face_cache(face)=current_face - face=ele_face(X, ele, neigh(n)) - face2=ele_face(X, neigh(n), ele) + else - ! Only do this once for each face pairl - if (face>face2) then - cycle - end if + face=ele_face(X, ele, neigh(n)) + face2=ele_face(X, neigh(n), ele) - current_face=current_face+1 - - face_cache(face)=current_face - face_cache(face2)=-current_face - - end if + ! Only do this once for each face pairl + if (face>face2) then + cycle + end if + current_face=current_face+1 - X_f=face_val(X,face) - X_centroid_face = sum(X_f, 2)/size(X_f, 2) - X_shape_f=>face_shape(X,face) + face_cache(face)=current_face + face_cache(face2)=-current_face - ! |- dx dx -| - ! | dL1 dL2 | - ! | | - ! | dy dy | - ! J = | dL1 dL2 | - ! | | - ! | dz dz | - ! |- dL1 dL2 -| + end if - ! Form Jacobian. - J=matmul(X_f(:,:), x_shape_f%dn(:, 1, :)) - detJ=0.0 - ! Calculate determinant. - select case (X%dim) - case(1) - detJ=1.0 - case(2) - detJ = sqrt(J(1,1)**2 + J(2,1)**2) - case(3) - do i=1,3 - detJ=detJ+ & + X_f=face_val(X,face) + X_centroid_face = sum(X_f, 2)/size(X_f, 2) + X_shape_f=>face_shape(X,face) + + ! |- dx dx -| + ! | dL1 dL2 | + ! | | + ! | dy dy | + ! J = | dL1 dL2 | + ! | | + ! | dz dz | + ! |- dL1 dL2 -| + + ! Form Jacobian. + J=matmul(X_f(:,:), x_shape_f%dn(:, 1, :)) + + detJ=0.0 + ! Calculate determinant. + select case (X%dim) + case(1) + detJ=1.0 + case(2) + detJ = sqrt(J(1,1)**2 + J(2,1)**2) + case(3) + do i=1,3 + detJ=detJ+ & (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i+1),1))**2 - end do - detJ=sqrt(detJ) - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select + end do + detJ=sqrt(detJ) + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select - ! Calculate normal. - face_normal_cache(:,current_face)=facet_normal(J, X_centroid_face-X_centroid_ele) - face_detJ_cache(current_face)=detJ + ! Calculate normal. + face_normal_cache(:,current_face)=facet_normal(J, X_centroid_face-X_centroid_ele) + face_detJ_cache(current_face)=detJ - end do - end do - assert(current_face==unique_faces) + end do + end do + assert(current_face==unique_faces) - end subroutine construct_face_cache + end subroutine construct_face_cache - subroutine construct_full_face_cache(X) - !!< The cache is invalid so make a new one. - type(vector_field), intent(in) :: X + subroutine construct_full_face_cache(X) + !!< The cache is invalid so make a new one. + type(vector_field), intent(in) :: X - integer :: elements, ele, i, k, current_face, face, faces, n - !! Note that if X is not all linear simplices we are screwed. - real, dimension(X%dim, ele_loc(X,1)) :: X_val - type(element_type), pointer :: X_shape - integer, dimension(:), pointer :: neigh - real, dimension(:,:,:), allocatable :: dn_s - !! Local version of the determinant of J - real :: detJ_local + integer :: elements, ele, i, k, current_face, face, faces, n + !! Note that if X is not all linear simplices we are screwed. + real, dimension(X%dim, ele_loc(X,1)) :: X_val + type(element_type), pointer :: X_shape + integer, dimension(:), pointer :: neigh + real, dimension(:,:,:), allocatable :: dn_s + !! Local version of the determinant of J + real :: detJ_local ! ewrite(1,*) "Reconstructing element geometry cache." - assert(associated(X%mesh%shape%surface_quadrature)) - assert(associated(X%mesh%shape%dn_s)) - allocate(dn_s(size(X%mesh%shape%dn_s,1), size(X%mesh%shape%dn_s,2), size(X%mesh%shape%dn_s,3))) + assert(associated(X%mesh%shape%surface_quadrature)) + assert(associated(X%mesh%shape%dn_s)) + allocate(dn_s(size(X%mesh%shape%dn_s,1), size(X%mesh%shape%dn_s,2), size(X%mesh%shape%dn_s,3))) - call abort_if_in_parallel_region + call abort_if_in_parallel_region - full_face_position_id=X%refcount%id - full_face_last_mesh_movement=eventcount(EVENT_MESH_MOVEMENT) + full_face_position_id=X%refcount%id + full_face_last_mesh_movement=eventcount(EVENT_MESH_MOVEMENT) - if (allocated(face_invJ_cache)) then + if (allocated(face_invJ_cache)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("transform_cache", "real", & - & size(face_invJ_cache)+size(face_J_T_cache)) + call register_deallocation("transform_cache", "real", & + & size(face_invJ_cache)+size(face_J_T_cache)) #endif - deallocate(face_invJ_cache, face_J_T_cache) - end if + deallocate(face_invJ_cache, face_J_T_cache) + end if - elements=element_count(X) - faces=face_count(X) + elements=element_count(X) + faces=face_count(X) - allocate(face_invJ_cache(X%dim,X%dim,faces), & + allocate(face_invJ_cache(X%dim,X%dim,faces), & face_J_T_cache(X%dim,X%dim,faces)) #ifdef HAVE_MEMORY_STATS - call register_allocation("transform_cache", "real", & - & size(face_invJ_cache)+size(face_J_T_cache)) + call register_allocation("transform_cache", "real", & + & size(face_invJ_cache)+size(face_J_T_cache)) #endif - current_face=0 - do ele=1,elements - neigh=>ele_neigh(X, ele) - X_val=ele_val(X,ele) - - do n=1,size(neigh) - - face=ele_face(X, ele, neigh(n)) - current_face = current_face + 1 - X_shape => ele_shape(X, ele) - dn_s = face_dn_s(X_shape, X%mesh, face) - - ! |- dx dx dx -| - ! | dL1 dL2 dL3 | - ! | | - ! | dy dy dy | - ! J = | dL1 dL2 dL3 | - ! | | - ! | dz dz dz | - ! |- dL1 dL2 dL3 -| - - ! Form Jacobian. - face_J_T_cache(:,:,face)=matmul(X_val(:,:), dn_s(:,1,:)) - - select case (X%dim) - case(1) - face_invJ_cache(:,:,face)=1.0 - case(2) - face_invJ_cache(:,:,face)=reshape(& + current_face=0 + do ele=1,elements + neigh=>ele_neigh(X, ele) + X_val=ele_val(X,ele) + + do n=1,size(neigh) + + face=ele_face(X, ele, neigh(n)) + current_face = current_face + 1 + X_shape => ele_shape(X, ele) + dn_s = face_dn_s(X_shape, X%mesh, face) + + ! |- dx dx dx -| + ! | dL1 dL2 dL3 | + ! | | + ! | dy dy dy | + ! J = | dL1 dL2 dL3 | + ! | | + ! | dz dz dz | + ! |- dL1 dL2 dL3 -| + + ! Form Jacobian. + face_J_T_cache(:,:,face)=matmul(X_val(:,:), dn_s(:,1,:)) + + select case (X%dim) + case(1) + face_invJ_cache(:,:,face)=1.0 + case(2) + face_invJ_cache(:,:,face)=reshape(& (/ face_J_T_cache(2,2,face),-face_J_T_cache(1,2,face),& - & -face_J_T_cache(2,1,face), face_J_T_cache(1,1,face)/),(/2,2/)) - case(3) - ! Calculate (scaled) inverse using recursive determinants. - forall (i=1:3,k=1:3) - face_invJ_cache(i, k, face)= & + & -face_J_T_cache(2,1,face), face_J_T_cache(1,1,face)/),(/2,2/)) + case(3) + ! Calculate (scaled) inverse using recursive determinants. + forall (i=1:3,k=1:3) + face_invJ_cache(i, k, face)= & face_J_T_cache(cyc3(i+1),cyc3(k+1),face)& - & *face_J_T_cache(cyc3(i+2),cyc3(k+2),face) & + & *face_J_T_cache(cyc3(i+2),cyc3(k+2),face) & -face_J_T_cache(cyc3(i+2),cyc3(k+1),face)& - & *face_J_T_cache(cyc3(i+1),cyc3(k+2),face) - end forall - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - ! Form determinant by expanding minors. - detJ_local=dot_product(face_J_T_cache(:,1,face),face_invJ_cache(:,1,face)) + & *face_J_T_cache(cyc3(i+1),cyc3(k+2),face) + end forall + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + ! Form determinant by expanding minors. + detJ_local=dot_product(face_J_T_cache(:,1,face),face_invJ_cache(:,1,face)) - ! Form determinant by expanding minors. - face_J_T_cache(:,:,face)=dot_product(face_J_T_cache(:,1,face),face_invJ_cache(:,1,face)) + ! Form determinant by expanding minors. + face_J_T_cache(:,:,face)=dot_product(face_J_T_cache(:,1,face),face_invJ_cache(:,1,face)) - ! Scale inverse by determinant. - face_invJ_cache(:,:,face)=face_invJ_cache(:,:,face)/detJ_local + ! Scale inverse by determinant. + face_invJ_cache(:,:,face)=face_invJ_cache(:,:,face)/detJ_local - end do - end do - assert(current_face==faces) - deallocate(dn_s) + end do + end do + assert(current_face==faces) + deallocate(dn_s) - end subroutine construct_full_face_cache + end subroutine construct_full_face_cache - function unique_face_count(mesh) result (face_count) - !!< Count the number of geometrically unique faces in mesh, - type(mesh_type), intent(in) :: mesh - integer :: face_count + function unique_face_count(mesh) result (face_count) + !!< Count the number of geometrically unique faces in mesh, + type(mesh_type), intent(in) :: mesh + integer :: face_count - integer :: ele - integer, dimension(:), pointer :: neigh + integer :: ele + integer, dimension(:), pointer :: neigh - face_count=0 + face_count=0 - do ele=1,element_count(mesh) - neigh=>ele_neigh(mesh, ele) + do ele=1,element_count(mesh) + neigh=>ele_neigh(mesh, ele) - ! Count 1 for interior and 2 for surface. - face_count=face_count+sum(merge(1,2,neigh>0)) + ! Count 1 for interior and 2 for surface. + face_count=face_count+sum(merge(1,2,neigh>0)) - end do + end do - face_count=(face_count+1)/2 + face_count=(face_count+1)/2 - end function unique_face_count + end function unique_face_count - subroutine deallocate_transform_cache + subroutine deallocate_transform_cache - if (allocated(invJ_cache)) then + if (allocated(invJ_cache)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("transform_cache", "real",& - & size(invJ_cache)+size(J_T_cache)+size(detJ_cache)) + call register_deallocation("transform_cache", "real",& + & size(invJ_cache)+size(J_T_cache)+size(detJ_cache)) #endif - deallocate(invJ_cache, J_T_cache, detJ_cache) - end if + deallocate(invJ_cache, J_T_cache, detJ_cache) + end if - if (allocated(face_detJ_cache)) then + if (allocated(face_detJ_cache)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("transform_cache", "real", & - & size(face_detJ_cache)+size(face_normal_cache)) - call register_deallocation("transform_cache", "integer", & - & size(face_cache)) + call register_deallocation("transform_cache", "real", & + & size(face_detJ_cache)+size(face_normal_cache)) + call register_deallocation("transform_cache", "integer", & + & size(face_cache)) #endif - deallocate(face_detJ_cache, face_normal_cache, face_cache) - end if + deallocate(face_detJ_cache, face_normal_cache, face_cache) + end if - if (allocated(face_invJ_cache)) then + if (allocated(face_invJ_cache)) then #ifdef HAVE_MEMORY_STATS - call register_deallocation("transform_cache", "real", & - & size(face_invJ_cache)+size(face_J_T_cache)) + call register_deallocation("transform_cache", "real", & + & size(face_invJ_cache)+size(face_J_T_cache)) #endif - deallocate(face_invJ_cache, face_J_T_cache) - end if - - position_id=-1 - last_mesh_movement=-1 - face_position_id=-1 - face_last_mesh_movement=-1 - full_face_position_id=-1 - full_face_last_mesh_movement=-1 - - end subroutine deallocate_transform_cache - - subroutine transform_to_physical_full(X, ele, shape, dshape, detwei, J,& - & invJ, detJ, x_shape) - !!< Calculate the derivatives of a shape function shape in physical - !!< space using the positions x. Calculate the transformed quadrature - !!< weights as a side bonus. - !!< - !!< Do this by calculating the Jacobian of the transform and inverting it. - - !! X is the positions field. - type(vector_field), intent(in) :: X - !! The index of the current element - integer :: ele - !! Reference element of which the derivatives are to be transformed - type(element_type), intent(in) :: shape - !! Derivatives of this shape function transformed to physical space (loc x ngi x dim) - real, dimension(:,:,:), intent(out) :: dshape - - !! Quadrature weights for physical coordinates. - real, dimension(:), intent(out), optional :: detwei(:) - !! Jacobian matrix and its inverse at each quadrature point (dim x dim x x_shape%ngi) - !! Facilitates access to this information externally - real, dimension(:,:,:), intent(out), optional :: J, invJ - !! Determinant of the Jacobian at each quadrature point (x_shape%ngi) - !! Facilitates access to this information externally - real, dimension(:), intent(out), optional :: detJ - !! Shape function to use for the coordinate field. ONLY SUPPLY THIS IF - !! YOU DO NOT WANT TO USE THE SHAPE FUNCTION IN THE COORDINATE FIELD. - !! This is mostly useful for control volumes. - type(element_type), intent(in), optional, target :: X_shape - - !! Column n of X is the position of the nth node. (dim x x_shape%loc) - !! only need position of n nodes since Jacobian is only calculated once - real, dimension(X%dim,ele_loc(X,ele)) :: X_val - !! radius (l2norm) of X_val at the nodes (used for spherical positions) - real, dimension(ele_loc(X,ele)) :: r_val - !! Shape function to be used for coordinate interpolation. - type(element_type), pointer :: lx_shape - - !! Local copy of element gradients. This is an attempt to induce a - !! prefetch. - real, dimension(size(shape%dn,1), size(shape%dn,3)) :: dn_local - - !! Local versions of the Jacobian matrix and its inverse. (dim x dim) - real, dimension(X%dim, X%dim) :: J_local_T, invJ_local - !! Local version of the determinant of J - real :: detJ_local - - integer :: gi, i, k, dim - logical :: x_nonlinear, m_nonlinear, cache_valid, x_spherical - - if (present(X_shape)) then - lx_shape=>X_shape - else - lx_shape=>ele_shape(X,ele) - end if - - x_spherical = use_analytical_spherical_mapping(X) - - ! Optimisation checks. Optimisations apply to linear elements. - x_nonlinear= x_spherical .or. .not.(lx_shape%degree==1 .and. lx_shape%numbering%family==FAMILY_SIMPLEX) - m_nonlinear= .not.(shape%degree==1 .and. shape%numbering%family==FAMILY_SIMPLEX .and. shape%numbering%type==ELEMENT_LAGRANGIAN) - - dim=X%dim + deallocate(face_invJ_cache, face_J_T_cache) + end if + + position_id=-1 + last_mesh_movement=-1 + face_position_id=-1 + face_last_mesh_movement=-1 + full_face_position_id=-1 + full_face_last_mesh_movement=-1 + + end subroutine deallocate_transform_cache + + subroutine transform_to_physical_full(X, ele, shape, dshape, detwei, J,& + & invJ, detJ, x_shape) + !!< Calculate the derivatives of a shape function shape in physical + !!< space using the positions x. Calculate the transformed quadrature + !!< weights as a side bonus. + !!< + !!< Do this by calculating the Jacobian of the transform and inverting it. + + !! X is the positions field. + type(vector_field), intent(in) :: X + !! The index of the current element + integer :: ele + !! Reference element of which the derivatives are to be transformed + type(element_type), intent(in) :: shape + !! Derivatives of this shape function transformed to physical space (loc x ngi x dim) + real, dimension(:,:,:), intent(out) :: dshape + + !! Quadrature weights for physical coordinates. + real, dimension(:), intent(out), optional :: detwei(:) + !! Jacobian matrix and its inverse at each quadrature point (dim x dim x x_shape%ngi) + !! Facilitates access to this information externally + real, dimension(:,:,:), intent(out), optional :: J, invJ + !! Determinant of the Jacobian at each quadrature point (x_shape%ngi) + !! Facilitates access to this information externally + real, dimension(:), intent(out), optional :: detJ + !! Shape function to use for the coordinate field. ONLY SUPPLY THIS IF + !! YOU DO NOT WANT TO USE THE SHAPE FUNCTION IN THE COORDINATE FIELD. + !! This is mostly useful for control volumes. + type(element_type), intent(in), optional, target :: X_shape + + !! Column n of X is the position of the nth node. (dim x x_shape%loc) + !! only need position of n nodes since Jacobian is only calculated once + real, dimension(X%dim,ele_loc(X,ele)) :: X_val + !! radius (l2norm) of X_val at the nodes (used for spherical positions) + real, dimension(ele_loc(X,ele)) :: r_val + !! Shape function to be used for coordinate interpolation. + type(element_type), pointer :: lx_shape + + !! Local copy of element gradients. This is an attempt to induce a + !! prefetch. + real, dimension(size(shape%dn,1), size(shape%dn,3)) :: dn_local + + !! Local versions of the Jacobian matrix and its inverse. (dim x dim) + real, dimension(X%dim, X%dim) :: J_local_T, invJ_local + !! Local version of the determinant of J + real :: detJ_local + + integer :: gi, i, k, dim + logical :: x_nonlinear, m_nonlinear, cache_valid, x_spherical + + if (present(X_shape)) then + lx_shape=>X_shape + else + lx_shape=>ele_shape(X,ele) + end if + + x_spherical = use_analytical_spherical_mapping(X) + + ! Optimisation checks. Optimisations apply to linear elements. + x_nonlinear= x_spherical .or. .not.(lx_shape%degree==1 .and. lx_shape%numbering%family==FAMILY_SIMPLEX) + m_nonlinear= .not.(shape%degree==1 .and. shape%numbering%family==FAMILY_SIMPLEX .and. shape%numbering%type==ELEMENT_LAGRANGIAN) + + dim=X%dim #ifdef DDEBUG - if (present(detwei)) then - assert(size(detwei)==lx_shape%ngi) - end if - !if (present(dshape)) then - assert(size(dshape,1)==shape%loc) - assert(size(dshape,2)==shape%ngi) - assert(size(dshape,3)==dim) - !end if + if (present(detwei)) then + assert(size(detwei)==lx_shape%ngi) + end if + !if (present(dshape)) then + assert(size(dshape,1)==shape%loc) + assert(size(dshape,2)==shape%ngi) + assert(size(dshape,3)==dim) + !end if #endif - if ((.not.x_nonlinear).and.cache_transform_elements) then - cache_valid=retrieve_cached_transform(X, ele, J_local_T, invJ_local,& - & detJ_local) + if ((.not.x_nonlinear).and.cache_transform_elements) then + cache_valid=retrieve_cached_transform(X, ele, J_local_T, invJ_local,& + & detJ_local) - if (cache_valid) then - if (m_nonlinear) then - do gi=1,lx_shape%ngi - dshape(:,gi,:)& + if (cache_valid) then + if (m_nonlinear) then + do gi=1,lx_shape%ngi + dshape(:,gi,:)& =matmul(shape%dn(:,gi,:),transpose(invJ_local)) - end do - else - dn_local=matmul(shape%dn(:,1,:),transpose(invJ_local)) - forall(gi=1:lx_shape%ngi) - dshape(:,gi,:)=dn_local - end forall - end if - - if (present(J)) then - J_local_T=transpose(J_local_T) - forall(gi=1:lx_shape%ngi) - J(:,:,gi)=J_local_T - end forall - end if - if (present(invJ)) then - forall(gi=1:lx_shape%ngi) - invJ(:,:,gi)=invJ_local - end forall - end if - if(present(detJ)) then - detJ=detJ_local - end if - if (present(detwei)) then - detwei=abs(detJ_local)*lx_shape%quadrature%weight - end if - - return - end if - else - cache_valid = .false. - end if - - X_val=ele_val(X, ele) - if (x_spherical) then - r_val = sqrt(sum(X_val**2, dim=1)) - end if - - ! Loop over quadrature points. - quad_loop: do gi=1,lx_shape%ngi - - if ((x_nonlinear.or.gi==1).and..not.cache_valid) then - ! For linear space elements only calculate Jacobian once. - - ! |- dx dx dx -| - ! | dL1 dL2 dL3 | - ! | | - ! | dy dy dy | - ! J = | dL1 dL2 dL3 | - ! | | - ! | dz dz dz | - ! |- dL1 dL2 dL3 -| - - ! Form Jacobian. - J_local_T=matmul(X_val(:,:), lx_shape%dn(:, gi, :)) - - if (x_spherical) then - J_local_T = jacobian_on_sphere(lx_shape, gi, X_val, r_val, J_local_T) - end if - - - select case (dim) - case(1) - invJ_local=1.0 - case(2) - invJ_local=reshape((/ J_local_T(2,2),-J_local_T(1,2),& - & -J_local_T(2,1), J_local_T(1,1)/),(/2,2/)) - case(3) - ! Calculate (scaled) inverse using recursive determinants. - forall (i=1:3,k=1:3) - invJ_local(i, k)= & + end do + else + dn_local=matmul(shape%dn(:,1,:),transpose(invJ_local)) + forall(gi=1:lx_shape%ngi) + dshape(:,gi,:)=dn_local + end forall + end if + + if (present(J)) then + J_local_T=transpose(J_local_T) + forall(gi=1:lx_shape%ngi) + J(:,:,gi)=J_local_T + end forall + end if + if (present(invJ)) then + forall(gi=1:lx_shape%ngi) + invJ(:,:,gi)=invJ_local + end forall + end if + if(present(detJ)) then + detJ=detJ_local + end if + if (present(detwei)) then + detwei=abs(detJ_local)*lx_shape%quadrature%weight + end if + + return + end if + else + cache_valid = .false. + end if + + X_val=ele_val(X, ele) + if (x_spherical) then + r_val = sqrt(sum(X_val**2, dim=1)) + end if + + ! Loop over quadrature points. + quad_loop: do gi=1,lx_shape%ngi + + if ((x_nonlinear.or.gi==1).and..not.cache_valid) then + ! For linear space elements only calculate Jacobian once. + + ! |- dx dx dx -| + ! | dL1 dL2 dL3 | + ! | | + ! | dy dy dy | + ! J = | dL1 dL2 dL3 | + ! | | + ! | dz dz dz | + ! |- dL1 dL2 dL3 -| + + ! Form Jacobian. + J_local_T=matmul(X_val(:,:), lx_shape%dn(:, gi, :)) + + if (x_spherical) then + J_local_T = jacobian_on_sphere(lx_shape, gi, X_val, r_val, J_local_T) + end if + + + select case (dim) + case(1) + invJ_local=1.0 + case(2) + invJ_local=reshape((/ J_local_T(2,2),-J_local_T(1,2),& + & -J_local_T(2,1), J_local_T(1,1)/),(/2,2/)) + case(3) + ! Calculate (scaled) inverse using recursive determinants. + forall (i=1:3,k=1:3) + invJ_local(i, k)= & J_local_T(cyc3(i+1),cyc3(k+1))*J_local_T(cyc3(i+2),cyc3(k+2)) & - -J_local_T(cyc3(i+2),cyc3(k+1))*J_local_T(cyc3(i+1),cyc3(k+2)) - end forall - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - ! Form determinant by expanding minors. - detJ_local=dot_product(J_local_T(:,1),invJ_local(:,1)) - - ! Scale inverse by determinant. - invJ_local=invJ_local/detJ_local - - end if - - ! Evaluate derivatives in physical space. - ! If both space and the derivatives are linear then we only need - ! to do this once. - if (x_nonlinear.or.m_nonlinear.or.gi==1) then - do i=1,shape%loc - dshape(i,gi,:)=matmul(invJ_local, shape%dn(i,gi,:)) - end do - else - dshape(:,gi,:)=dshape(:,1,:) - end if - - ! Calculate transformed quadrature weights. - if (present(detwei)) then - detwei(gi)=abs(detJ_local)*lx_shape%quadrature%weight(gi) - end if - - ! Copy the Jacobian and related variables to externally accessible memory - if (present(J)) then - if (x_nonlinear.or.gi==1) then - J(:,:,gi) = transpose(J_local_T(:,:)) - else - J(:,:,gi) = J(:,:,1) - end if - end if - if (present(invJ)) invJ(:,:,gi) = invJ_local(:,:) - if (present(detJ)) detJ(gi) = detJ_local - - end do quad_loop - - end subroutine transform_to_physical_full - - subroutine transform_to_physical_detwei(X, ele, detwei) - !!< Fast version of transform_to_physical that only calculates detwei - - !! Coordinate field - type(vector_field), intent(in) :: X - !! Current element - integer :: ele - !! Quadrature weights for physical coordinates. - real, dimension(:), intent(out):: detwei(:) - - !! Shape function used for coordinate interpolation - type(element_type), pointer :: x_shape - !! Column n of X is the position of the nth node. (dim x x_shape%loc) - !! only need position of n nodes since Jacobian is only calculated once - real, dimension(X%dim,ele_loc(X,ele)) :: X_val - !! radius (l2norm) of X_val at the nodes (used for spherical positions) - real, dimension(ele_loc(X,ele)) :: r_val - - real :: J(X%dim, mesh_dim(X)), det - integer :: gi, dim, ldim - logical :: x_nonlinear, cache_valid, x_spherical - - x_shape=>ele_shape(X, ele) - - x_spherical = use_analytical_spherical_mapping(X) - - ! Optimisation checks. Optimisations apply to linear elements. - x_nonlinear= x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX) - - dim=X%dim ! dimension of space (n/o real coordinates) - ldim=size(x_shape%dn,3) ! dimension of element (n/o local coordinates) - if (dim==ldim) then - - if ((.not.x_nonlinear).and.cache_transform_elements) then - cache_valid=retrieve_cached_transform(X, ele, det) - - if (cache_valid) then - detwei=abs(det)*x_shape%quadrature%weight - return - end if - - end if + -J_local_T(cyc3(i+2),cyc3(k+1))*J_local_T(cyc3(i+1),cyc3(k+2)) + end forall + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + ! Form determinant by expanding minors. + detJ_local=dot_product(J_local_T(:,1),invJ_local(:,1)) + + ! Scale inverse by determinant. + invJ_local=invJ_local/detJ_local + + end if + + ! Evaluate derivatives in physical space. + ! If both space and the derivatives are linear then we only need + ! to do this once. + if (x_nonlinear.or.m_nonlinear.or.gi==1) then + do i=1,shape%loc + dshape(i,gi,:)=matmul(invJ_local, shape%dn(i,gi,:)) + end do + else + dshape(:,gi,:)=dshape(:,1,:) + end if + + ! Calculate transformed quadrature weights. + if (present(detwei)) then + detwei(gi)=abs(detJ_local)*lx_shape%quadrature%weight(gi) + end if + + ! Copy the Jacobian and related variables to externally accessible memory + if (present(J)) then + if (x_nonlinear.or.gi==1) then + J(:,:,gi) = transpose(J_local_T(:,:)) + else + J(:,:,gi) = J(:,:,1) + end if + end if + if (present(invJ)) invJ(:,:,gi) = invJ_local(:,:) + if (present(detJ)) detJ(gi) = detJ_local + + end do quad_loop + + end subroutine transform_to_physical_full + + subroutine transform_to_physical_detwei(X, ele, detwei) + !!< Fast version of transform_to_physical that only calculates detwei + + !! Coordinate field + type(vector_field), intent(in) :: X + !! Current element + integer :: ele + !! Quadrature weights for physical coordinates. + real, dimension(:), intent(out):: detwei(:) + + !! Shape function used for coordinate interpolation + type(element_type), pointer :: x_shape + !! Column n of X is the position of the nth node. (dim x x_shape%loc) + !! only need position of n nodes since Jacobian is only calculated once + real, dimension(X%dim,ele_loc(X,ele)) :: X_val + !! radius (l2norm) of X_val at the nodes (used for spherical positions) + real, dimension(ele_loc(X,ele)) :: r_val + + real :: J(X%dim, mesh_dim(X)), det + integer :: gi, dim, ldim + logical :: x_nonlinear, cache_valid, x_spherical + + x_shape=>ele_shape(X, ele) + + x_spherical = use_analytical_spherical_mapping(X) + + ! Optimisation checks. Optimisations apply to linear elements. + x_nonlinear= x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX) + + dim=X%dim ! dimension of space (n/o real coordinates) + ldim=size(x_shape%dn,3) ! dimension of element (n/o local coordinates) + if (dim==ldim) then + + if ((.not.x_nonlinear).and.cache_transform_elements) then + cache_valid=retrieve_cached_transform(X, ele, det) + + if (cache_valid) then + detwei=abs(det)*x_shape%quadrature%weight + return + end if + + end if !#ifdef DDEBUG ! if (ele==1) then @@ -937,1554 +937,1649 @@ subroutine transform_to_physical_detwei(X, ele, detwei) ! end if !#endif - X_val=ele_val(X, ele) - if (x_spherical) then - r_val = sqrt(sum(X_val**2, dim=1)) - end if + X_val=ele_val(X, ele) + if (x_spherical) then + r_val = sqrt(sum(X_val**2, dim=1)) + end if - select case (dim) - case (1) - do gi=1, x_shape%ngi - J(1,1)=dot_product(X_val(1,:), x_shape%dn(:,gi,1)) - detwei(gi)=abs(J(1,1))*x_shape%quadrature%weight(gi) - end do - case (2) - do gi=1, x_shape%ngi - if (x_nonlinear.or.gi==1) then - ! the Jacobian is the transpose of this - J=matmul(X_val(:,:), x_shape%dn(:, gi, :)) - if (x_spherical) then - J = jacobian_on_sphere(x_shape, gi, X_val, r_val, J) + select case (dim) + case (1) + do gi=1, x_shape%ngi + J(1,1)=dot_product(X_val(1,:), x_shape%dn(:,gi,1)) + detwei(gi)=abs(J(1,1))*x_shape%quadrature%weight(gi) + end do + case (2) + do gi=1, x_shape%ngi + if (x_nonlinear.or.gi==1) then + ! the Jacobian is the transpose of this + J=matmul(X_val(:,:), x_shape%dn(:, gi, :)) + if (x_spherical) then + J = jacobian_on_sphere(x_shape, gi, X_val, r_val, J) + end if + ! but that doesn't matter for determinant: + det=abs(J(1,1)*J(2,2)-J(1,2)*J(2,1)) end if - ! but that doesn't matter for determinant: - det=abs(J(1,1)*J(2,2)-J(1,2)*J(2,1)) - end if - detwei(gi)=det*x_shape%quadrature%weight(gi) - end do - case (3) - do gi=1, x_shape%ngi - if (x_nonlinear.or.gi==1) then - ! the Jacobian is the transpose of this - J=matmul(X_val(:,:), x_shape%dn(:, gi, :)) - if (x_spherical) then - J = jacobian_on_sphere(x_shape, gi, X_val, r_val, J) + detwei(gi)=det*x_shape%quadrature%weight(gi) + end do + case (3) + do gi=1, x_shape%ngi + if (x_nonlinear.or.gi==1) then + ! the Jacobian is the transpose of this + J=matmul(X_val(:,:), x_shape%dn(:, gi, :)) + if (x_spherical) then + J = jacobian_on_sphere(x_shape, gi, X_val, r_val, J) + end if + ! but that doesn't matter for determinant: + det=abs( & + J(1,1)*(J(2,2)*J(3,3)-J(2,3)*J(3,2)) & + -J(1,2)*(J(2,1)*J(3,3)-J(2,3)*J(3,1)) & + +J(1,3)*(J(2,1)*J(3,2)-J(2,2)*J(3,1)) & + ) end if - ! but that doesn't matter for determinant: - det=abs( & - J(1,1)*(J(2,2)*J(3,3)-J(2,3)*J(3,2)) & - -J(1,2)*(J(2,1)*J(3,3)-J(2,3)*J(3,1)) & - +J(1,3)*(J(2,1)*J(3,2)-J(2,2)*J(3,1)) & - ) - end if - detwei(gi)= det *x_shape%quadrature%weight(gi) - end do - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - else if (ldim ele_shape(X, ele) - - assert(size(invJ,1)==X%dim) - assert(size(invJ,2)==X%dim) - assert(size(invJ,3)==x_shape%ngi) - assert(X%dim==mesh_dim(X)) ! this routine doesn't work for embedded coordinates - if (present(detwei)) then - assert(size(detwei)==x_shape%ngi) - end if - if (present(detJ)) then - assert(size(detJ)==x_shape%ngi) - end if - - if (is_cache_valid(X)) then - do gi=1, size(invJ, 3) - invJ(:,:,gi) = invJ_cache(:, :, ele) - end do - if (present(detJ)) then - detJ = detJ_cache(ele) - end if - if (present(detwei)) then - detwei = abs(detJ_cache(ele)) * x_shape%quadrature%weight - end if - return - end if - - x_spherical = use_analytical_spherical_mapping(X) - - if (x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX)) then - ! for non-linear compute on all gauss points - compute_ngi=x_shape%ngi - else - ! for linear: compute only the first and copy the rest - compute_ngi=1 - end if - - x_val = ele_val(X, ele) - if (x_spherical) then - r_val = sqrt(sum(x_val**2, dim=1)) - end if - - select case (X%dim) - case(1) - - do gi=1,compute_ngi - J_local(1,1)=dot_product(x_val(1,:), x_shape%dn(:, gi, 1)) - detJ_local(gi)=J_local(1,1) - invJ(1,1,gi)=1.0/detJ_local(gi) - end do - ! copy the rest - do gi=compute_ngi+1, x_shape%ngi - detJ_local(gi) = detJ_local(1) - invJ(1,1,gi)=invJ(1,1,1) - end do - - case(2) - - do gi=1, compute_ngi + end if + ! outer product times quad. weight + detwei(gi)=det *x_shape%quadrature%weight(gi) + end do + end select - J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) - if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) - end if + else + FLAbort("Don't know how to compute higher-dimensional elements in a lower-dimensional space.") - ! Form determinant by expanding minors. - detJ_local(gi)=J_local(1,1)*J_local(2,2)-J_local(2,1)*J_local(1,2) - ! take inverse *and* transpose - invJ(:,:,gi)=reshape((/ J_local(2,2),-J_local(1,2), & - & -J_local(2,1), J_local(1,1)/),(/2,2/)) & - / detJ_local(gi) - end do - ! copy the rest - do gi=compute_ngi+1, x_shape%ngi - detJ_local(gi) = detJ_local(1) - invJ(:,:,gi)=invJ(:,:,1) - end do + end if - case(3) + end subroutine transform_to_physical_detwei + + subroutine compute_inverse_jacobian(X, ele, invJ, detwei, detJ) + !!< Fast version of transform_to_physical that only calculates detwei and invJ + + !! positions field and element to compute inv. jacobian for + type(vector_field), intent(in):: X + integer, intent(in):: ele + !! Inverse of the jacobian matrix at each quadrature point (dim x dim x x_shape%ngi) + !! Facilitates access to this information externally + real, dimension(:,:,:), intent(out) :: invJ + !! Quadrature weights for physical coordinates. + real, dimension(:), optional, intent(out) :: detwei (:) + !! Determinant of the Jacobian at each quadrature point (x_shape%ngi) + !! Facilitates access to this information externally + real, dimension(:), intent(out), optional :: detJ + + !! coordinates of the nodes + real, dimension(X%dim, ele_loc(X,ele)):: x_val + !! radius (l2norm) of x_val at the nodes (used for spherical positions) + real, dimension(size(x_val,2)) :: r_val + + !! Shape function to be used for coordinate interpolation. + type(element_type), pointer :: x_shape + !! Local versions of the Jacobian matrix + real, dimension(size(invJ,1),size(invJ,1)) :: J_local + !! Local version of the determinant of J + real, dimension(size(invJ,3)) :: detJ_local + logical :: x_spherical + + integer gi, i, k, compute_ngi - do gi=1, compute_ngi + x_shape => ele_shape(X, ele) - J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) - if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) - end if - ! Calculate (scaled) inverse (of the transpose of J_local) using recursive determinants. - forall (i=1:X%dim,k=1:X%dim) - invJ(i,k,gi)=J_local(cyc3(i+1),cyc3(k+1))*J_local(cyc3(i+2),cyc3(k+2)) & - -J_local(cyc3(i+2),cyc3(k+1))*J_local(cyc3(i+1),cyc3(k+2)) - end forall - ! Form determinant by expanding minors. - detJ_local(gi)=dot_product(J_local(:,1), invJ(:,1,gi)) + assert(size(invJ,1)==X%dim) + assert(size(invJ,2)==X%dim) + assert(size(invJ,3)==x_shape%ngi) + assert(X%dim==mesh_dim(X)) ! this routine doesn't work for embedded coordinates + if (present(detwei)) then + assert(size(detwei)==x_shape%ngi) + end if + if (present(detJ)) then + assert(size(detJ)==x_shape%ngi) + end if - ! Scale inverse by determinant. - invJ(:,:,gi)=invJ(:,:,gi)/detJ_local(gi) + if (is_cache_valid(X)) then + do gi=1, size(invJ, 3) + invJ(:,:,gi) = invJ_cache(:, :, ele) + end do + if (present(detJ)) then + detJ = detJ_cache(ele) + end if + if (present(detwei)) then + detwei = abs(detJ_cache(ele)) * x_shape%quadrature%weight + end if + return + end if - end do + x_spherical = use_analytical_spherical_mapping(X) - ! copy the rest - do gi=compute_ngi+1, x_shape%ngi - detJ_local(gi) = detJ_local(1) - invJ(:,:,gi)=invJ(:,:,1) - end do + if (x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX)) then + ! for non-linear compute on all gauss points + compute_ngi=x_shape%ngi + else + ! for linear: compute only the first and copy the rest + compute_ngi=1 + end if - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - if (present(detJ)) then - detJ = detJ_local - end if - - if (present(detwei)) then - detwei = abs(detJ_local)*x_shape%quadrature%weight - end if - - end subroutine compute_inverse_jacobian - - subroutine compute_jacobian(X, ele, J, detwei, detJ, facet) - !!< Fast version of transform_to_physical that only calculates detwei and J - - !! positions field and element to compute inv. jacobian for - type(vector_field), intent(in):: X - integer, intent(in):: ele - !! Jacobian matrix at each quadrature point (dim x dim x x_shape%ngi) - !! Facilitates access to this information externally - real, dimension(:,:,:), intent(out) :: J - !! Quadrature weights for physical coordinates. - real, dimension(:), optional, intent(out) :: detwei (:) - !! Determinant of the Jacobian at each quadrature point (x_shape%ngi) - !! Facilitates access to this information externally - real, dimension(:), intent(out), optional :: detJ - !! if present and true, compute the jacobian of a facet, ele then refers to the facet number - logical, optional, intent(in):: facet - - !! Column n of X is the position of the nth node. (dim x x_shape%loc) - !! only need position of n nodes since Jacobian is only calculated once - real, dimension(X%dim,ele_loc(X,ele)), target :: ele_X_val - !! radius (l2norm) of X_val at the nodes (used for spherical positions) - real, dimension(size(ele_X_val,2)), target :: ele_r_val - real, dimension(:,:), pointer :: x_val - real, dimension(:), pointer :: r_val - !! Shape function to be used for coordinate interpolation. - type(element_type), pointer :: x_shape - !! transpose of J in one gauss point - real, dimension(size(J,2), size(J,1)):: J_local - !! Local version of the determinant of J - real, dimension(size(J,3)) :: detJ_local - - integer gi, dim, ldim, compute_ngi - logical:: x_spherical - - if (present_and_true(facet)) then - x_shape => face_shape(X, ele) - ele_x_val(:,1:face_loc(X,ele)) = face_val(X, ele) - x_val => ele_x_val(:,1:face_loc(X,ele)) - else - x_shape => ele_shape(X, ele) - ele_x_val = ele_val(X, ele) - x_val => ele_x_val - end if - dim=X%dim ! dimension of space - ldim=x_shape%dim ! dimension of element - - assert(size(J,1)==ldim) - assert(size(J,2)==dim) - assert(size(J,3)==x_shape%ngi) - if (present(detwei)) then - assert(size(detwei)==x_shape%ngi) - end if - if (present(detJ)) then - assert(size(detJ)==x_shape%ngi) - end if - - x_spherical = use_analytical_spherical_mapping(X) - - if (x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX)) then - ! for non-linear compute on all gauss points - compute_ngi=x_shape%ngi - else - ! for linear: compute only the first and copy the rest - compute_ngi=1 - end if - - if (x_spherical) then - r_val => ele_r_val(1:size(x_val,2)) - r_val = sqrt(sum(x_val**2, dim=1)) - end if - - select case (dim) - case(1) - - do gi=1,compute_ngi - J(1,1,gi)=dot_product(x_val(1,:), x_shape%dn(:, gi, 1)) - detJ_local(gi)=J(1,1,gi) - end do - ! copy the rest - do gi=compute_ngi+1, x_shape%ngi - J(1,1,gi)=J(1,1,1) - detJ_local(gi)=detJ_local(1) - end do + x_val = ele_val(X, ele) + if (x_spherical) then + r_val = sqrt(sum(x_val**2, dim=1)) + end if - case(2) + select case (X%dim) + case(1) - select case(ldim) - case(1) do gi=1,compute_ngi - J_local(:,1)=matmul(x_val(:,:), x_shape%dn(:, gi, 1)) - if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) - end if - J(1,:,gi)=J_local(:,1) - detJ_local(gi)=sum(sqrt(abs(J(:,:,gi)))) + J_local(1,1)=dot_product(x_val(1,:), x_shape%dn(:, gi, 1)) + detJ_local(gi)=J_local(1,1) + invJ(1,1,gi)=1.0/detJ_local(gi) end do - case(2) + ! copy the rest + do gi=compute_ngi+1, x_shape%ngi + detJ_local(gi) = detJ_local(1) + invJ(1,1,gi)=invJ(1,1,1) + end do + + case(2) + do gi=1, compute_ngi + J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) end if - J(:,:,gi)=transpose(J_local) + ! Form determinant by expanding minors. - detJ_local(gi)=J(1,1,gi)*J(2,2,gi)-J(2,1,gi)*J(1,2,gi) + detJ_local(gi)=J_local(1,1)*J_local(2,2)-J_local(2,1)*J_local(1,2) + ! take inverse *and* transpose + invJ(:,:,gi)=reshape((/ J_local(2,2),-J_local(1,2), & + & -J_local(2,1), J_local(1,1)/),(/2,2/)) & + / detJ_local(gi) + end do + ! copy the rest + do gi=compute_ngi+1, x_shape%ngi + detJ_local(gi) = detJ_local(1) + invJ(:,:,gi)=invJ(:,:,1) end do - case default - FLAbort("oh dear, dimension of element > spatial dimension") - end select - ! copy the rest - do gi=compute_ngi+1, x_shape%ngi - J(:,:,gi)=J(:,:,1) - detJ_local(gi)=detJ_local(1) - end do + case(3) - case(3) + do gi=1, compute_ngi - select case(ldim) - case(1) - do gi=1,compute_ngi - J_local(:,1)=matmul(x_val(:,:), x_shape%dn(:, gi, 1)) - if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) - end if - J(1,:,gi)=J_local(:,1) - detJ_local(gi)=sqrt(sum(J(:, :, gi)**2)) - end do - case(2) - do gi=1,compute_ngi J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) end if - J(:,:,gi)=transpose(J_local) - detJ_local(gi)=sqrt((J(1,2,gi)*J(2,3,gi)-J(1,3,gi)*J(2,2,gi))**2+ & - (J(1,3,gi)*J(2,1,gi)-J(1,1,gi)*J(2,3,gi))**2+ & - (J(1,1,gi)*J(2,2,gi)-J(1,2,gi)*J(2,1,gi))**2) + ! Calculate (scaled) inverse (of the transpose of J_local) using recursive determinants. + forall (i=1:X%dim,k=1:X%dim) + invJ(i,k,gi)=J_local(cyc3(i+1),cyc3(k+1))*J_local(cyc3(i+2),cyc3(k+2)) & + -J_local(cyc3(i+2),cyc3(k+1))*J_local(cyc3(i+1),cyc3(k+2)) + end forall + ! Form determinant by expanding minors. + detJ_local(gi)=dot_product(J_local(:,1), invJ(:,1,gi)) + + ! Scale inverse by determinant. + invJ(:,:,gi)=invJ(:,:,gi)/detJ_local(gi) end do - case(3) - do gi=1,compute_ngi - J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) - if (x_spherical) then - J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) - end if - J(:,:,gi)=transpose(J_local) - detJ_local(gi)=det_3(J_local) + + ! copy the rest + do gi=compute_ngi+1, x_shape%ngi + detJ_local(gi) = detJ_local(1) + invJ(:,:,gi)=invJ(:,:,1) end do - case default - FLAbort("oh dear, dimension of element > spatial dimension") - end select - ! copy the rest - do gi=compute_ngi+1, x_shape%ngi - J(:,:,gi)=J(:,:,1) - detJ_local(gi)=detJ_local(1) - end do + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - if (present(detJ)) then - detJ=detJ_local - end if - - if (present(detwei)) then - detwei = abs(detJ_local)*x_shape%quadrature%weight - end if - - end subroutine compute_jacobian - - subroutine transform_facet_to_physical_full(X, face, detwei_f, normal) - - ! Coordinate transformations for facet integrals. - ! Calculate the transformed quadrature - ! weights as a side bonus. - ! - ! For facet integrals, we also need to know the facet outward - ! pointing normal. - ! - ! In this case it is only the determinant of the Jacobian which is - ! required. - - ! Column n of X is the position of the nth node of the adjacent element - ! (this is only used to work out the orientation of the boundary) - type(vector_field), intent(in) :: X - ! The face to transform. - integer, intent(in) :: face - ! Quadrature weights for physical coordinates for integration over the boundary. - real, dimension(:), intent(out), optional :: detwei_f - ! Outward normal vector. (dim x x_shape_f%ngi) - real, dimension(:,:), intent(out) :: normal - - ! Column n of X_f is the position of the nth node on the facet. - real, dimension(X%dim,face_loc(X,face)) :: X_f - ! Column n of X_f is the position of the nth node on the facet. - real, dimension(X%dim,ele_loc(X,face_ele(X,face))) :: X_val - ! radius (l2norm) of X_f at the facet nodes (used for spherical positions) - real, dimension(size(X_f,2)) :: r_f - ! shape function coordinate interpolation on the boundary - type(element_type), pointer :: x_shape_f - ! element shape functions derivatives evaluated at the facet: - real, dimension(size(X_val,2), X%mesh%faces%shape%ngi, X%mesh%shape%dim) :: dn_s - ! vector pointing outward (from element to outside facet) - real, dimension(X%dim) :: outward_vector - - - ! Jacobian matrix and its inverse. - real, dimension(X%dim,mesh_dim(X)-1) :: J - ! Determinant of J - real :: detJ - ! Whether the cache can be used - logical :: cache_valid, x_spherical - - - integer :: gi, i, compute_ngi - - x_shape_f=>face_shape(X,face) + if (present(detJ)) then + detJ = detJ_local + end if -#ifdef DDEBUG - assert(size(normal,1)==X%dim) -#endif -#ifdef DDEBUG - if (present(detwei_f)) then - assert(size(detwei_f)==x_shape_f%ngi) - end if -#endif + if (present(detwei)) then + detwei = abs(detJ_local)*x_shape%quadrature%weight + end if - x_spherical = use_analytical_spherical_mapping(X) - - if (x_spherical .or. .not.(x_shape_f%degree==1 .and. x_shape_f%numbering%family==FAMILY_SIMPLEX)) then - ! for non-linear compute on all gauss points - compute_ngi=x_shape_f%ngi - cache_valid=.false. - else - ! for linear: compute only the first and copy the rest - if (cache_transform_elements) then - cache_valid=retrieve_cached_face_transform(X, face, normal(:,1),& - & detJ) + end subroutine compute_inverse_jacobian + + subroutine compute_jacobian(X, ele, J, detwei, detJ, facet) + !!< Fast version of transform_to_physical that only calculates detwei and J + + !! positions field and element to compute inv. jacobian for + type(vector_field), intent(in):: X + integer, intent(in):: ele + !! Jacobian matrix at each quadrature point (dim x dim x x_shape%ngi) + !! Facilitates access to this information externally + real, dimension(:,:,:), intent(out) :: J + !! Quadrature weights for physical coordinates. + real, dimension(:), optional, intent(out) :: detwei (:) + !! Determinant of the Jacobian at each quadrature point (x_shape%ngi) + !! Facilitates access to this information externally + real, dimension(:), intent(out), optional :: detJ + !! if present and true, compute the jacobian of a facet, ele then refers to the facet number + logical, optional, intent(in):: facet + + !! Column n of X is the position of the nth node. (dim x x_shape%loc) + !! only need position of n nodes since Jacobian is only calculated once + real, dimension(X%dim,ele_loc(X,ele)), target :: ele_X_val + !! radius (l2norm) of X_val at the nodes (used for spherical positions) + real, dimension(size(ele_X_val,2)), target :: ele_r_val + real, dimension(:,:), pointer :: x_val + real, dimension(:), pointer :: r_val + !! Shape function to be used for coordinate interpolation. + type(element_type), pointer :: x_shape + !! transpose of J in one gauss point + real, dimension(size(J,2), size(J,1)):: J_local + !! Local version of the determinant of J + real, dimension(size(J,3)) :: detJ_local + + integer gi, dim, ldim, compute_ngi + logical:: x_spherical + + if (present_and_true(facet)) then + x_shape => face_shape(X, ele) + ele_x_val(:,1:face_loc(X,ele)) = face_val(X, ele) + x_val => ele_x_val(:,1:face_loc(X,ele)) else - cache_valid=.false. + x_shape => ele_shape(X, ele) + ele_x_val = ele_val(X, ele) + x_val => ele_x_val + end if + dim=X%dim ! dimension of space + ldim=x_shape%dim ! dimension of element + + assert(size(J,1)==ldim) + assert(size(J,2)==dim) + assert(size(J,3)==x_shape%ngi) + if (present(detwei)) then + assert(size(detwei)==x_shape%ngi) + end if + if (present(detJ)) then + assert(size(detJ)==x_shape%ngi) end if - if (cache_valid) then - compute_ngi=0 + + x_spherical = use_analytical_spherical_mapping(X) + + if (x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX)) then + ! for non-linear compute on all gauss points + compute_ngi=x_shape%ngi else + ! for linear: compute only the first and copy the rest compute_ngi=1 end if - end if - - if (.not.cache_valid) then - X_val=ele_val(X, face_ele(X,face)) - X_f=face_val(X, face) - if (x_spherical) then - r_f = sqrt(sum(X_f**2, dim=1)) - end if - if (x_spherical .or. .not. (x_shape_f%degree==1)) then - assert(x_shape_f%numbering%family==FAMILY_SIMPLEX) - assert(associated(X%mesh%shape%surface_quadrature)) - assert(associated(X%mesh%shape%dn_s)) - dn_s = face_dn_s(X%mesh%shape, X%mesh, face) - else - ! linear element, an outward vector is found between the element and face centroid - outward_vector = sum(X_f,2)/size(X_f,2) - sum(X_val, 2)/size(X_val,2) - end if - end if - - ! Loop over quadrature points. - quad_loop: do gi=1, compute_ngi - - ! |- dx dx -| - ! | dL1 dL2 | - ! | | - ! | dy dy | - ! J = | dL1 dL2 | - ! | | - ! | dz dz | - ! |- dL1 dL2 -| - - ! Form Jacobian. - J=matmul(X_f(:,:), x_shape_f%dn(:, gi, :)) - if (x_spherical) then - J = jacobian_on_sphere(x_shape_f, gi, X_f, r_f, J) - end if - - detJ=0.0 - ! Calculate determinant. - select case (mesh_dim(X)) + if (x_spherical) then + r_val => ele_r_val(1:size(x_val,2)) + r_val = sqrt(sum(x_val**2, dim=1)) + end if + + select case (dim) case(1) - detJ=1.0 + + do gi=1,compute_ngi + J(1,1,gi)=dot_product(x_val(1,:), x_shape%dn(:, gi, 1)) + detJ_local(gi)=J(1,1,gi) + end do + ! copy the rest + do gi=compute_ngi+1, x_shape%ngi + J(1,1,gi)=J(1,1,1) + detJ_local(gi)=detJ_local(1) + end do + case(2) - select case (X%dim) + + select case(ldim) + case(1) + do gi=1,compute_ngi + J_local(:,1)=matmul(x_val(:,:), x_shape%dn(:, gi, 1)) + if (x_spherical) then + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + end if + J(1,:,gi)=J_local(:,1) + detJ_local(gi)=sum(sqrt(abs(J(:,:,gi)))) + end do case(2) - detJ = sqrt(J(1,1)**2 + J(2,1)**2) - case(3) - detJ = sqrt(sum(J(:,1)**2)) + do gi=1, compute_ngi + J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) + if (x_spherical) then + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + end if + J(:,:,gi)=transpose(J_local) + ! Form determinant by expanding minors. + detJ_local(gi)=J(1,1,gi)*J(2,2,gi)-J(2,1,gi)*J(1,2,gi) + end do case default - FLAbort("Unsupported dimension specified") - end select + FLAbort("oh dear, dimension of element > spatial dimension") + end select + + ! copy the rest + do gi=compute_ngi+1, x_shape%ngi + J(:,:,gi)=J(:,:,1) + detJ_local(gi)=detJ_local(1) + end do + case(3) - select case (X%dim) + + select case(ldim) + case(1) + do gi=1,compute_ngi + J_local(:,1)=matmul(x_val(:,:), x_shape%dn(:, gi, 1)) + if (x_spherical) then + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + end if + J(1,:,gi)=J_local(:,1) + detJ_local(gi)=sqrt(sum(J(:, :, gi)**2)) + end do + case(2) + do gi=1,compute_ngi + J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) + if (x_spherical) then + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + end if + J(:,:,gi)=transpose(J_local) + detJ_local(gi)=sqrt((J(1,2,gi)*J(2,3,gi)-J(1,3,gi)*J(2,2,gi))**2+ & + (J(1,3,gi)*J(2,1,gi)-J(1,1,gi)*J(2,3,gi))**2+ & + (J(1,1,gi)*J(2,2,gi)-J(1,2,gi)*J(2,1,gi))**2) + + end do case(3) - do i=1,3 - detJ=detJ+ & - (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i& - &+1),1))**2 - end do - detJ=sqrt(detJ) + do gi=1,compute_ngi + J_local=matmul(x_val(:,:), x_shape%dn(:, gi, :)) + if (x_spherical) then + J_local = jacobian_on_sphere(x_shape, gi, x_val, r_val, J_local) + end if + J(:,:,gi)=transpose(J_local) + detJ_local(gi)=det_3(J_local) + end do case default - FLAbort("Unsupported dimension specified") - end select + FLAbort("oh dear, dimension of element > spatial dimension") + end select + + ! copy the rest + do gi=compute_ngi+1, x_shape%ngi + J(:,:,gi)=J(:,:,1) + detJ_local(gi)=detJ_local(1) + end do + case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - ! Calculate transformed quadrature weights. - if(present(detwei_f)) then - detwei_f(gi)=detJ*x_shape_f%quadrature%weight(gi) - end if - - ! Calculate normal. - if (x_spherical .or. .not. (x_shape_f%degree==1)) then - ! the 1st local coordinate L_1 in dn_s is the one associated - ! with the vertex opposite the facet. The outward_vector - ! is chosen as -dX/dL_1 (NOTE: it is not yet orthogonal to the facet) - outward_vector = -matmul(X_val, dn_s(:, gi, 1)) - end if - normal(:,gi) = facet_normal(J, outward_vector) - - end do quad_loop - - ! copy the value at gi==1 to the rest of the gauss points - if(present(detwei_f)) then - do gi=compute_ngi+1, x_shape_f%ngi - ! uses detJ from above - detwei_f=detJ*x_shape_f%quadrature%weight - end do - end if - - do gi=compute_ngi+1, x_shape_f%ngi - normal(:,gi)=normal(:,1) - end do - - end subroutine transform_facet_to_physical_full - - function facet_normal(J, outward_vector) - ! Calculate the normal at a point on a facet - ! facet Jacobian J_ij = dX_i/dL_j where L_j are local coords of the facet - real, dimension(:,:), intent(in) :: J - ! Since we don't know the orientation of the facet, the sign of the normal - ! will be such that dot(normal, outward_vector)>0 - real, dimension(:), intent(in) :: outward_vector - real, dimension(size(J,1)) :: facet_normal - - select case (size(J,1)) - case(1) - facet_normal = 1.0 - case (2) - facet_normal = (/ -J(2,1), J(1,1) /) - case (3) - facet_normal = cross_product(J(:,1),J(:,2)) - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - ! Set correct orientation. - facet_normal=facet_normal*dot_product(facet_normal, outward_vector) - - ! normalise - facet_normal=facet_normal/sqrt(sum(facet_normal**2)) - - end function facet_normal - - subroutine transform_facet_to_physical_detwei(X, face, detwei_f) - - ! Coordinate transformed quadrature weights for facet integrals. - ! - type(vector_field), intent(in) :: X - ! The face to transform. - integer, intent(in) :: face - ! Quadrature weights for physical coordinates for integration over the boundary. - real, dimension(:), intent(out), optional :: detwei_f - - ! Column n of X_f is the position of the nth node on the facet. - real, dimension(X%dim,face_loc(X,face)) :: X_f - ! radius (l2norm) of X_f at the facet nodes (used for spherical positions) - real, dimension(size(X_f,2)) :: r_f - ! Column n of X_f is the position of the nth node on the facet. - real, dimension(X%dim,ele_loc(X,face_ele(X,face))) :: X_val - ! shape function coordinate interpolation on the boundary - type(element_type), pointer :: x_shape_f - - - ! Jacobian matrix and its inverse. - real, dimension(X%dim, mesh_dim(X)-1) :: J - ! Determinant of J - real :: detJ - ! Whether the cache can be used - logical :: cache_valid - ! Outward normal vector. This is a dummy. - real, dimension(X%dim) :: lnormal - logical :: x_spherical - - - integer :: gi, i, compute_ngi - - x_shape_f=>face_shape(X,face) + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + if (present(detJ)) then + detJ=detJ_local + end if + + if (present(detwei)) then + detwei = abs(detJ_local)*x_shape%quadrature%weight + end if + + end subroutine compute_jacobian + + subroutine transform_facet_to_physical_full(X, face, detwei_f, normal) + + ! Coordinate transformations for facet integrals. + ! Calculate the transformed quadrature + ! weights as a side bonus. + ! + ! For facet integrals, we also need to know the facet outward + ! pointing normal. + ! + ! In this case it is only the determinant of the Jacobian which is + ! required. + + ! Column n of X is the position of the nth node of the adjacent element + ! (this is only used to work out the orientation of the boundary) + type(vector_field), intent(in) :: X + ! The face to transform. + integer, intent(in) :: face + ! Quadrature weights for physical coordinates for integration over the boundary. + real, dimension(:), intent(out), optional :: detwei_f + ! Outward normal vector. (dim x x_shape_f%ngi) + real, dimension(:,:), intent(out) :: normal + + ! Column n of X_f is the position of the nth node on the facet. + real, dimension(X%dim,face_loc(X,face)) :: X_f + ! Column n of X_f is the position of the nth node on the facet. + real, dimension(X%dim,ele_loc(X,face_ele(X,face))) :: X_val + ! radius (l2norm) of X_f at the facet nodes (used for spherical positions) + real, dimension(size(X_f,2)) :: r_f + ! shape function coordinate interpolation on the boundary + type(element_type), pointer :: x_shape_f + ! element shape functions derivatives evaluated at the facet: + real, dimension(size(X_val,2), X%mesh%faces%shape%ngi, X%mesh%shape%dim) :: dn_s + ! vector pointing outward (from element to outside facet) + real, dimension(X%dim) :: outward_vector + + + ! Jacobian matrix and its inverse. + real, dimension(X%dim,mesh_dim(X)-1) :: J + ! Determinant of J + real :: detJ + ! Whether the cache can be used + logical :: cache_valid, x_spherical + + + integer :: gi, i, compute_ngi + + x_shape_f=>face_shape(X,face) #ifdef DDEBUG - if (present(detwei_f)) then - assert(size(detwei_f)==x_shape_f%ngi) - end if + assert(size(normal,1)==X%dim) +#endif +#ifdef DDEBUG + if (present(detwei_f)) then + assert(size(detwei_f)==x_shape_f%ngi) + end if #endif - x_spherical = use_analytical_spherical_mapping(X) + x_spherical = use_analytical_spherical_mapping(X) - if (x_spherical .or. .not.(x_shape_f%degree==1 .and. x_shape_f%numbering%family==FAMILY_SIMPLEX)) then - ! for non-linear compute on all gauss points - compute_ngi=x_shape_f%ngi - cache_valid=.false. - else - ! for linear: compute only the first and copy the rest - if (cache_transform_elements) then - cache_valid=retrieve_cached_face_transform(X, face, lnormal(:),& - & detJ) - else + if (x_spherical .or. .not.(x_shape_f%degree==1 .and. x_shape_f%numbering%family==FAMILY_SIMPLEX)) then + ! for non-linear compute on all gauss points + compute_ngi=x_shape_f%ngi cache_valid=.false. - end if - if (cache_valid) then - compute_ngi=0 else - compute_ngi=1 + ! for linear: compute only the first and copy the rest + if (cache_transform_elements) then + cache_valid=retrieve_cached_face_transform(X, face, normal(:,1),& + & detJ) + else + cache_valid=.false. + end if + if (cache_valid) then + compute_ngi=0 + else + compute_ngi=1 + end if + end if - end if - - if (.not.cache_valid) then - X_val=ele_val(X, face_ele(X,face)) - X_f=face_val(X, face) - if (x_spherical) then - r_f = sqrt(sum(X_f**2, dim=1)) - end if - end if - - ! Loop over quadrature points. - quad_loop: do gi=1, compute_ngi - - ! |- dx dx -| - ! | dL1 dL2 | - ! | | - ! | dy dy | - ! J = | dL1 dL2 | - ! | | - ! | dz dz | - ! |- dL1 dL2 -| - - ! Form Jacobian. - J=matmul(X_f(:,:), x_shape_f%dn(:, gi, :)) - if (x_spherical) then - J = jacobian_on_sphere(x_shape_f, gi, X_f, r_f, J) - end if - - detJ=0.0 - ! Calculate determinant. - select case (mesh_dim(X)) - case(1) - detJ=1.0 - case(2) - select case (X%dim) + if (.not.cache_valid) then + X_val=ele_val(X, face_ele(X,face)) + X_f=face_val(X, face) + if (x_spherical) then + r_f = sqrt(sum(X_f**2, dim=1)) + end if + if (x_spherical .or. .not. (x_shape_f%degree==1)) then + assert(x_shape_f%numbering%family==FAMILY_SIMPLEX) + assert(associated(X%mesh%shape%surface_quadrature)) + assert(associated(X%mesh%shape%dn_s)) + dn_s = face_dn_s(X%mesh%shape, X%mesh, face) + else + ! linear element, an outward vector is found between the element and face centroid + outward_vector = sum(X_f,2)/size(X_f,2) - sum(X_val, 2)/size(X_val,2) + end if + end if + + ! Loop over quadrature points. + quad_loop: do gi=1, compute_ngi + + ! |- dx dx -| + ! | dL1 dL2 | + ! | | + ! | dy dy | + ! J = | dL1 dL2 | + ! | | + ! | dz dz | + ! |- dL1 dL2 -| + + ! Form Jacobian. + J=matmul(X_f(:,:), x_shape_f%dn(:, gi, :)) + if (x_spherical) then + J = jacobian_on_sphere(x_shape_f, gi, X_f, r_f, J) + end if + + detJ=0.0 + ! Calculate determinant. + select case (mesh_dim(X)) + case(1) + detJ=1.0 case(2) - detJ = sqrt(J(1,1)**2 + J(2,1)**2) + select case (X%dim) + case(2) + detJ = sqrt(J(1,1)**2 + J(2,1)**2) + case(3) + detJ = sqrt(sum(J(:,1)**2)) + case default + FLAbort("Unsupported dimension specified") + end select case(3) - detJ = sqrt(sum(J(:,1)**2)) - case default - FLAbort("Unsupported dimension specified") - end select - case(3) - select case (X%dim) - case(3) - do i=1,3 - detJ=detJ+ & + select case (X%dim) + case(3) + do i=1,3 + detJ=detJ+ & (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i& - &+1),1))**2 - end do - detJ=sqrt(detJ) + &+1),1))**2 + end do + detJ=sqrt(detJ) + case default + FLAbort("Unsupported dimension specified") + end select case default - FLAbort("Unsupported dimension specified") - end select - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select - ! Calculate transformed quadrature weights. - if(present(detwei_f)) then - detwei_f(gi)=detJ*x_shape_f%quadrature%weight(gi) - end if + ! Calculate transformed quadrature weights. + if(present(detwei_f)) then + detwei_f(gi)=detJ*x_shape_f%quadrature%weight(gi) + end if + + ! Calculate normal. + if (x_spherical .or. .not. (x_shape_f%degree==1)) then + ! the 1st local coordinate L_1 in dn_s is the one associated + ! with the vertex opposite the facet. The outward_vector + ! is chosen as -dX/dL_1 (NOTE: it is not yet orthogonal to the facet) + outward_vector = -matmul(X_val, dn_s(:, gi, 1)) + end if + normal(:,gi) = facet_normal(J, outward_vector) + + end do quad_loop - end do quad_loop + ! copy the value at gi==1 to the rest of the gauss points + if(present(detwei_f)) then + do gi=compute_ngi+1, x_shape_f%ngi + ! uses detJ from above + detwei_f=detJ*x_shape_f%quadrature%weight + end do + end if - ! copy the value at gi==1 to the rest of the gauss points - if(present(detwei_f)) then do gi=compute_ngi+1, x_shape_f%ngi - ! uses detJ from above - detwei_f=detJ*x_shape_f%quadrature%weight + normal(:,gi)=normal(:,1) end do - end if - - end subroutine transform_facet_to_physical_detwei - - subroutine transform_full_facet_to_physical_full(X, face, shape, dshape, detwei_f, normal, J,& - & invJ, detJ) - !!< Calculate the derivatives of a shape function shape in physical - !!< space using the positions x on face face. Calculate the transformed quadrature - !!< weights as a side bonus. - !!< - !!< Do this by calculating the Jacobian of the transform and inverting it. - - !! X is the positions field. - type(vector_field), intent(in) :: X - !! The index of the current face - integer, intent(in) :: face - !! Reference element of which the derivatives are to be transformed - type(element_type), intent(in) :: shape - !! Derivatives of this shape function transformed to physical space (ele_loc x sngi x dim) - real, dimension(:,:,:), intent(out) :: dshape - - !! Quadrature weights for physical coordinates. - real, dimension(:), intent(out), optional :: detwei_f - ! Outward normal vector. (dim x sngi) - real, dimension(:,:), intent(out), optional :: normal - !! Jacobian matrix and its inverse at each quadrature point (dim x dim x sngi) - !! Facilitates access to this information externally - real, dimension(:,:,:), intent(out), optional :: J, invJ - !! Determinant of the Jacobian at each quadrature point (sngi) - !! Facilitates access to this information externally - real, dimension(:), intent(out), optional :: detJ - - !! Column n of X is the position of the nth node. (dim x x_shape%loc) - !! only need position of n nodes since Jacobian is only calculated once - real, dimension(X%dim,X%mesh%shape%loc) :: X_val - real, dimension(X%dim,X%mesh%faces%shape%loc) :: X_f - !! radius (l2norm) of X_val at the nodes (used for spherical positions) - real, dimension(size(X_val,2)) :: r_val - !! Shape function to be used for coordinate interpolation. - type(element_type), pointer :: x_shape - - !! Local versions of the Jacobian matrix and its inverse. (dim x dim) - real, dimension(X%dim, X%dim) :: J_local_T, invJ_local - !! Local version of the determinant of J - real :: detJ_local, detJ_local_full - !! reorientated shape functions - real, dimension(size(X_val,2),size(dshape,2)) :: n_s - ! element shape functions derivatives evaluated at the facet: - real, dimension(size(X_val,2),size(dshape,2),mesh_dim(X)) :: dn_s - real, dimension(shape%loc,size(dshape,2),mesh_dim(X)) :: dm_s - real, dimension(X%dim) :: lnormal - - integer :: gi, i, k, dim, ele - logical :: x_nonlinear, m_nonlinear, cache_valid, x_spherical - - ele = face_ele(X, face) - x_shape=>ele_shape(X,ele) -#ifdef DDEBUG - assert(associated(x_shape%surface_quadrature)) - if(present(detwei_f)) then - assert(size(detwei_f) == x_shape%surface_quadrature%ngi) - end if - if(present(normal)) then - assert(size(normal,1) == x_shape%dim) - assert(size(normal,2) == x_shape%surface_quadrature%ngi) - end if - if(present(invJ)) then - assert(size(invJ, 1) == x_shape%dim) - assert(size(invJ, 2) == x_shape%dim) - assert(size(invJ, 3) == x_shape%surface_quadrature%ngi) - end if - if(present(J)) then - assert(size(J, 1) == x_shape%dim) - assert(size(J, 2) == x_shape%dim) - assert(size(J, 3) == x_shape%surface_quadrature%ngi) - end if - if(present(detJ)) then - assert(size(detJ) == x_shape%surface_quadrature%ngi) - end if - - assert(associated(x_shape%n_s)) - assert(x_shape%loc == size(x_shape%n_s, 1)) - assert(x_shape%surface_quadrature%ngi == size(x_shape%n_s, 2)) - assert(size(n_s,1) == size(x_shape%n_s, 1)) - assert(size(n_s,2) == size(x_shape%n_s, 2)) - - assert(associated(x_shape%dn_s)) - assert(x_shape%loc == size(x_shape%dn_s, 1)) - assert(x_shape%surface_quadrature%ngi == size(x_shape%dn_s, 2)) - assert(x_shape%dim == size(x_shape%dn_s, 3)) - assert(size(dn_s,1) == size(x_shape%dn_s, 1)) - assert(size(dn_s,2) == size(x_shape%dn_s, 2)) - assert(size(dn_s,3) == size(x_shape%dn_s, 3)) - - assert(associated(shape%surface_quadrature)) - assert(shape%surface_quadrature%ngi==x_shape%surface_quadrature%ngi) - assert(size(dshape, 1) == shape%loc) - assert(size(dshape, 2) == shape%surface_quadrature%ngi) - assert(size(dshape, 3) == X%dim) - - assert(associated(shape%dn_s)) - assert(shape%loc == size(shape%dn_s, 1)) - assert(shape%surface_quadrature%ngi == size(shape%dn_s, 2)) - assert(X%dim == size(shape%dn_s, 3)) - assert(size(dm_s,1) == size(shape%dn_s, 1)) - assert(size(dm_s,2) == size(shape%dn_s, 2)) - assert(size(dm_s,3) == size(shape%dn_s, 3)) -#endif + end subroutine transform_facet_to_physical_full - x_spherical = use_analytical_spherical_mapping(X) + function facet_normal(J, outward_vector) + ! Calculate the normal at a point on a facet + ! facet Jacobian J_ij = dX_i/dL_j where L_j are local coords of the facet + real, dimension(:,:), intent(in) :: J + ! Since we don't know the orientation of the facet, the sign of the normal + ! will be such that dot(normal, outward_vector)>0 + real, dimension(:), intent(in) :: outward_vector + real, dimension(size(J,1)) :: facet_normal - dn_s = face_dn_s(x_shape, X%mesh, face) - dm_s = face_dn_s(shape, X%mesh, face) ! this should be safe to call even if X%mesh and shape aren't the same degree/continuity - if(x_spherical) then - n_s = face_n_s(x_shape, X%mesh, face) - end if + select case (size(J,1)) + case(1) + facet_normal = 1.0 + case (2) + facet_normal = (/ -J(2,1), J(1,1) /) + case (3) + facet_normal = cross_product(J(:,1),J(:,2)) + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + ! Set correct orientation. + facet_normal=facet_normal*dot_product(facet_normal, outward_vector) - ! Optimisation checks. Optimisations apply to linear elements. - x_nonlinear= x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX) - m_nonlinear= .not.(shape%degree==1 .and. shape%numbering%family==FAMILY_SIMPLEX .and. shape%numbering%type==ELEMENT_LAGRANGIAN) + ! normalise + facet_normal=facet_normal/sqrt(sum(facet_normal**2)) - dim=X%dim + end function facet_normal - if ((.not.x_nonlinear).and.cache_transform_elements) then - cache_valid=retrieve_cached_face_transform(X, face, lnormal(:),& - & detJ_local, J_local_T, invJ_local) - if (cache_valid.and.present(normal)) then - normal(:,1) = lnormal(:) - end if - else - cache_valid = .false. - end if + subroutine transform_facet_to_physical_detwei(X, face, detwei_f) - if (.not.cache_valid) then - X_val=ele_val(X, ele) - if (x_spherical) then - r_val = sqrt(sum(X_val**2, dim=1)) - end if - if (present(normal)) then - X_f=face_val(X,face) + ! Coordinate transformed quadrature weights for facet integrals. + ! + type(vector_field), intent(in) :: X + ! The face to transform. + integer, intent(in) :: face + ! Quadrature weights for physical coordinates for integration over the boundary. + real, dimension(:), intent(out), optional :: detwei_f + + ! Column n of X_f is the position of the nth node on the facet. + real, dimension(X%dim,face_loc(X,face)) :: X_f + ! radius (l2norm) of X_f at the facet nodes (used for spherical positions) + real, dimension(size(X_f,2)) :: r_f + ! Column n of X_f is the position of the nth node on the facet. + real, dimension(X%dim,ele_loc(X,face_ele(X,face))) :: X_val + ! shape function coordinate interpolation on the boundary + type(element_type), pointer :: x_shape_f + + + ! Jacobian matrix and its inverse. + real, dimension(X%dim, mesh_dim(X)-1) :: J + ! Determinant of J + real :: detJ + ! Whether the cache can be used + logical :: cache_valid + ! Outward normal vector. This is a dummy. + real, dimension(X%dim) :: lnormal + logical :: x_spherical + + + integer :: gi, i, compute_ngi + + x_shape_f=>face_shape(X,face) + +#ifdef DDEBUG + if (present(detwei_f)) then + assert(size(detwei_f)==x_shape_f%ngi) end if - end if +#endif - ! Loop over quadrature points. - quad_loop: do gi=1,x_shape%surface_quadrature%ngi + x_spherical = use_analytical_spherical_mapping(X) - if ((x_nonlinear.or.gi==1).and..not.cache_valid) then - ! For linear space elements only calculate Jacobian once. + if (x_spherical .or. .not.(x_shape_f%degree==1 .and. x_shape_f%numbering%family==FAMILY_SIMPLEX)) then + ! for non-linear compute on all gauss points + compute_ngi=x_shape_f%ngi + cache_valid=.false. + else + ! for linear: compute only the first and copy the rest + if (cache_transform_elements) then + cache_valid=retrieve_cached_face_transform(X, face, lnormal(:),& + & detJ) + else + cache_valid=.false. + end if + if (cache_valid) then + compute_ngi=0 + else + compute_ngi=1 + end if + + end if - ! |- dx dx dx -| - ! | dL1 dL2 dL3 | - ! | | - ! | dy dy dy | - ! J = | dL1 dL2 dL3 | - ! | | - ! | dz dz dz | - ! |- dL1 dL2 dL3 -| + if (.not.cache_valid) then + X_val=ele_val(X, face_ele(X,face)) + X_f=face_val(X, face) + if (x_spherical) then + r_f = sqrt(sum(X_f**2, dim=1)) + end if + end if + + ! Loop over quadrature points. + quad_loop: do gi=1, compute_ngi - ! Form Jacobian. - J_local_T=matmul(X_val(:,:), dn_s(:, gi, :)) + ! |- dx dx -| + ! | dL1 dL2 | + ! | | + ! | dy dy | + ! J = | dL1 dL2 | + ! | | + ! | dz dz | + ! |- dL1 dL2 -| - if (x_spherical) then - J_local_T = facet_full_jacobian_on_sphere(n_s, dn_s, gi, X_val, r_val, J_local_T) - end if + ! Form Jacobian. + J=matmul(X_f(:,:), x_shape_f%dn(:, gi, :)) + if (x_spherical) then + J = jacobian_on_sphere(x_shape_f, gi, X_f, r_f, J) + end if - select case (dim) + detJ=0.0 + ! Calculate determinant. + select case (mesh_dim(X)) case(1) - invJ_local=1.0 + detJ=1.0 case(2) - invJ_local=reshape((/ J_local_T(2,2),-J_local_T(1,2),& - & -J_local_T(2,1), J_local_T(1,1)/),(/2,2/)) + select case (X%dim) + case(2) + detJ = sqrt(J(1,1)**2 + J(2,1)**2) + case(3) + detJ = sqrt(sum(J(:,1)**2)) + case default + FLAbort("Unsupported dimension specified") + end select case(3) - ! Calculate (scaled) inverse using recursive determinants. - forall (i=1:3,k=1:3) - invJ_local(i, k)= & - J_local_T(cyc3(i+1),cyc3(k+1))*J_local_T(cyc3(i+2),cyc3(k+2)) & - -J_local_T(cyc3(i+2),cyc3(k+1))*J_local_T(cyc3(i+1),cyc3(k+2)) - end forall + select case (X%dim) + case(3) + do i=1,3 + detJ=detJ+ & + (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i& + &+1),1))**2 + end do + detJ=sqrt(detJ) + case default + FLAbort("Unsupported dimension specified") + end select case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select - ! Form determinant by expanding minors. - detJ_local_full=dot_product(J_local_T(:,1),invJ_local(:,1)) + ! Calculate transformed quadrature weights. + if(present(detwei_f)) then + detwei_f(gi)=detJ*x_shape_f%quadrature%weight(gi) + end if - ! Scale inverse by determinant. - invJ_local=invJ_local/detJ_local_full + end do quad_loop - detJ_local=0.0 - ! Calculate facet determinant. - select case (dim) - case(1) - detJ_local=1.0 - case(2) - detJ_local = sqrt(J_local_T(1,2)**2 + J_local_T(2,2)**2) - case(3) - do i=1,3 - detJ_local=detJ_local+ & + ! copy the value at gi==1 to the rest of the gauss points + if(present(detwei_f)) then + do gi=compute_ngi+1, x_shape_f%ngi + ! uses detJ from above + detwei_f=detJ*x_shape_f%quadrature%weight + end do + end if + + end subroutine transform_facet_to_physical_detwei + + subroutine transform_full_facet_to_physical_full(X, face, shape, dshape, detwei_f, normal, J,& + & invJ, detJ) + !!< Calculate the derivatives of a shape function shape in physical + !!< space using the positions x on face face. Calculate the transformed quadrature + !!< weights as a side bonus. + !!< + !!< Do this by calculating the Jacobian of the transform and inverting it. + + !! X is the positions field. + type(vector_field), intent(in) :: X + !! The index of the current face + integer, intent(in) :: face + !! Reference element of which the derivatives are to be transformed + type(element_type), intent(in) :: shape + !! Derivatives of this shape function transformed to physical space (ele_loc x sngi x dim) + real, dimension(:,:,:), intent(out) :: dshape + + !! Quadrature weights for physical coordinates. + real, dimension(:), intent(out), optional :: detwei_f + ! Outward normal vector. (dim x sngi) + real, dimension(:,:), intent(out), optional :: normal + !! Jacobian matrix and its inverse at each quadrature point (dim x dim x sngi) + !! Facilitates access to this information externally + real, dimension(:,:,:), intent(out), optional :: J, invJ + !! Determinant of the Jacobian at each quadrature point (sngi) + !! Facilitates access to this information externally + real, dimension(:), intent(out), optional :: detJ + + !! Column n of X is the position of the nth node. (dim x x_shape%loc) + !! only need position of n nodes since Jacobian is only calculated once + real, dimension(X%dim,X%mesh%shape%loc) :: X_val + real, dimension(X%dim,X%mesh%faces%shape%loc) :: X_f + !! radius (l2norm) of X_val at the nodes (used for spherical positions) + real, dimension(size(X_val,2)) :: r_val + !! Shape function to be used for coordinate interpolation. + type(element_type), pointer :: x_shape + + !! Local versions of the Jacobian matrix and its inverse. (dim x dim) + real, dimension(X%dim, X%dim) :: J_local_T, invJ_local + !! Local version of the determinant of J + real :: detJ_local, detJ_local_full + !! reorientated shape functions + real, dimension(size(X_val,2),size(dshape,2)) :: n_s + ! element shape functions derivatives evaluated at the facet: + real, dimension(size(X_val,2),size(dshape,2),mesh_dim(X)) :: dn_s + real, dimension(shape%loc,size(dshape,2),mesh_dim(X)) :: dm_s + real, dimension(X%dim) :: lnormal + + integer :: gi, i, k, dim, ele + logical :: x_nonlinear, m_nonlinear, cache_valid, x_spherical + + ele = face_ele(X, face) + x_shape=>ele_shape(X,ele) + +#ifdef DDEBUG + assert(associated(x_shape%surface_quadrature)) + if(present(detwei_f)) then + assert(size(detwei_f) == x_shape%surface_quadrature%ngi) + end if + if(present(normal)) then + assert(size(normal,1) == x_shape%dim) + assert(size(normal,2) == x_shape%surface_quadrature%ngi) + end if + if(present(invJ)) then + assert(size(invJ, 1) == x_shape%dim) + assert(size(invJ, 2) == x_shape%dim) + assert(size(invJ, 3) == x_shape%surface_quadrature%ngi) + end if + if(present(J)) then + assert(size(J, 1) == x_shape%dim) + assert(size(J, 2) == x_shape%dim) + assert(size(J, 3) == x_shape%surface_quadrature%ngi) + end if + if(present(detJ)) then + assert(size(detJ) == x_shape%surface_quadrature%ngi) + end if + + assert(associated(x_shape%n_s)) + assert(x_shape%loc == size(x_shape%n_s, 1)) + assert(x_shape%surface_quadrature%ngi == size(x_shape%n_s, 2)) + assert(size(n_s,1) == size(x_shape%n_s, 1)) + assert(size(n_s,2) == size(x_shape%n_s, 2)) + + assert(associated(x_shape%dn_s)) + assert(x_shape%loc == size(x_shape%dn_s, 1)) + assert(x_shape%surface_quadrature%ngi == size(x_shape%dn_s, 2)) + assert(x_shape%dim == size(x_shape%dn_s, 3)) + assert(size(dn_s,1) == size(x_shape%dn_s, 1)) + assert(size(dn_s,2) == size(x_shape%dn_s, 2)) + assert(size(dn_s,3) == size(x_shape%dn_s, 3)) + + assert(associated(shape%surface_quadrature)) + assert(shape%surface_quadrature%ngi==x_shape%surface_quadrature%ngi) + assert(size(dshape, 1) == shape%loc) + assert(size(dshape, 2) == shape%surface_quadrature%ngi) + assert(size(dshape, 3) == X%dim) + + assert(associated(shape%dn_s)) + assert(shape%loc == size(shape%dn_s, 1)) + assert(shape%surface_quadrature%ngi == size(shape%dn_s, 2)) + assert(X%dim == size(shape%dn_s, 3)) + assert(size(dm_s,1) == size(shape%dn_s, 1)) + assert(size(dm_s,2) == size(shape%dn_s, 2)) + assert(size(dm_s,3) == size(shape%dn_s, 3)) +#endif + + x_spherical = use_analytical_spherical_mapping(X) + + dn_s = face_dn_s(x_shape, X%mesh, face) + dm_s = face_dn_s(shape, X%mesh, face) ! this should be safe to call even if X%mesh and shape aren't the same degree/continuity + if(x_spherical) then + n_s = face_n_s(x_shape, X%mesh, face) + end if + + ! Optimisation checks. Optimisations apply to linear elements. + x_nonlinear= x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX) + m_nonlinear= .not.(shape%degree==1 .and. shape%numbering%family==FAMILY_SIMPLEX .and. shape%numbering%type==ELEMENT_LAGRANGIAN) + + dim=X%dim + + if ((.not.x_nonlinear).and.cache_transform_elements) then + cache_valid=retrieve_cached_face_transform(X, face, lnormal(:),& + & detJ_local, J_local_T, invJ_local) + if (cache_valid.and.present(normal)) then + normal(:,1) = lnormal(:) + end if + else + cache_valid = .false. + end if + + if (.not.cache_valid) then + X_val=ele_val(X, ele) + if (x_spherical) then + r_val = sqrt(sum(X_val**2, dim=1)) + end if + if (present(normal)) then + X_f=face_val(X,face) + end if + end if + + ! Loop over quadrature points. + quad_loop: do gi=1,x_shape%surface_quadrature%ngi + + if ((x_nonlinear.or.gi==1).and..not.cache_valid) then + ! For linear space elements only calculate Jacobian once. + + ! |- dx dx dx -| + ! | dL1 dL2 dL3 | + ! | | + ! | dy dy dy | + ! J = | dL1 dL2 dL3 | + ! | | + ! | dz dz dz | + ! |- dL1 dL2 dL3 -| + + ! Form Jacobian. + J_local_T=matmul(X_val(:,:), dn_s(:, gi, :)) + + if (x_spherical) then + J_local_T = facet_full_jacobian_on_sphere(n_s, dn_s, gi, X_val, r_val, J_local_T) + end if + + select case (dim) + case(1) + invJ_local=1.0 + case(2) + invJ_local=reshape((/ J_local_T(2,2),-J_local_T(1,2),& + & -J_local_T(2,1), J_local_T(1,1)/),(/2,2/)) + case(3) + ! Calculate (scaled) inverse using recursive determinants. + forall (i=1:3,k=1:3) + invJ_local(i, k)= & + J_local_T(cyc3(i+1),cyc3(k+1))*J_local_T(cyc3(i+2),cyc3(k+2)) & + -J_local_T(cyc3(i+2),cyc3(k+1))*J_local_T(cyc3(i+1),cyc3(k+2)) + end forall + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + ! Form determinant by expanding minors. + detJ_local_full=dot_product(J_local_T(:,1),invJ_local(:,1)) + + ! Scale inverse by determinant. + invJ_local=invJ_local/detJ_local_full + + detJ_local=0.0 + ! Calculate facet determinant. + select case (dim) + case(1) + detJ_local=1.0 + case(2) + detJ_local = sqrt(J_local_T(1,2)**2 + J_local_T(2,2)**2) + case(3) + do i=1,3 + detJ_local=detJ_local+ & (J_local_T(cyc3(i+2),2)*J_local_T(cyc3(i+1),3)& -J_local_T(cyc3(i+2),3)*J_local_T(cyc3(i+1),2))**2 - end do - detJ_local=sqrt(detJ_local) - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - end if - - ! Evaluate derivatives in physical space. - ! If both space and the derivatives are linear then we only need - ! to do this once. - if (x_nonlinear.or.m_nonlinear.or.gi==1) then - do i=1,shape%loc - dshape(i,gi,:)=matmul(invJ_local, dm_s(i,gi,:)) - end do - else - dshape(:,gi,:)=dshape(:,1,:) - end if - - ! Calculate transformed quadrature weights. - if (present(detwei_f)) then - detwei_f(gi)=abs(detJ_local)*x_shape%surface_quadrature%weight(gi) - end if - - ! Copy the Jacobian and related variables to externally accessible memory - if (present(J)) then - if (x_nonlinear.or.gi==1) then - J(:,:,gi) = transpose(J_local_T(:,:)) - else - J(:,:,gi) = J(:,:,1) - end if - end if - if (present(invJ)) invJ(:,:,gi) = invJ_local(:,:) - if (present(detJ)) detJ(gi) = detJ_local - if (present(normal)) then - if ((x_nonlinear.or.gi==1).and..not.cache_valid) then - ! Calculate normal. - ! the 1st local coordinate L_1 in dn_s is the one associated - ! with the vertex opposite the facet. The outward_vector - ! is chosen as J(:,1)=-dX/dL_1 (NOTE: it is not yet orthogonal to the facet) - normal(:,gi) = facet_normal(J_local_T(:,2:), -J_local_T(:,1)) + end do + detJ_local=sqrt(detJ_local) + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + end if + + ! Evaluate derivatives in physical space. + ! If both space and the derivatives are linear then we only need + ! to do this once. + if (x_nonlinear.or.m_nonlinear.or.gi==1) then + do i=1,shape%loc + dshape(i,gi,:)=matmul(invJ_local, dm_s(i,gi,:)) + end do else - normal(:,gi)=normal(:,1) + dshape(:,gi,:)=dshape(:,1,:) end if - end if - - end do quad_loop - - end subroutine transform_full_facet_to_physical_full - - subroutine compute_facet_full_inverse_jacobian(X, face, invJ, detwei, detJ) - !!< Fast version of transform_to_physical that only calculates detwei and full invJ on a facet. - !!< NOTE: the detJ and detwei that this (optionally) returns is based on - !!< the determinant of the full facet Jacobian. This is different to the - !!< detJ and detwei returned by transform_facet_to_physical, which is lower - !!< dimensional and only based on the facet. - - !! positions field and element to compute inv. jacobian for - type(vector_field), intent(in):: X - integer, intent(in):: face - !! Inverse of the jacobian matrix at each quadrature point (dim x dim x x_shape%surface_quadrature%ngi) - !! Facilitates access to this information externally - real, dimension(:,:,:), intent(out) :: invJ - !! Quadrature weights for physical coordinates. - real, dimension(:), optional, intent(out) :: detwei (:) - !! Determinant of the Jacobian at each quadrature point (x_shape%surface_quadrature%ngi) - !! Facilitates access to this information externally - real, dimension(:), intent(out), optional :: detJ - - !! coordinates of the nodes - real, dimension(X%dim, ele_loc(X,face_ele(X, face))):: x_val - !! radius (l2norm) of x_val at the nodes (used for spherical positions) - real, dimension(size(x_val,2)) :: r_val - - !! Shape function to be used for coordinate interpolation. - type(element_type), pointer :: x_shape - !! Local versions of the Jacobian matrix - real, dimension(size(invJ,1),size(invJ,1)) :: J_local - !! Local version of the determinant of J - real, dimension(size(invJ,3)) :: detJ_local - logical :: x_spherical - - integer gi, i, k, compute_ngi, ele - real, dimension(size(x_val,2),size(invJ,3)) :: n_s - real, dimension(size(x_val,2),size(invJ,3),X%dim) :: dn_s - - ele = face_ele(X, face) - x_shape => ele_shape(X, ele) - - assert(associated(x_shape%surface_quadrature)) - assert(size(invJ, 1) == x_shape%dim) - assert(size(invJ, 2) == x_shape%dim) - assert(size(invJ, 3) == x_shape%surface_quadrature%ngi) - - assert(associated(x_shape%n_s)) - assert(x_shape%loc == size(x_shape%n_s, 1)) - assert(x_shape%surface_quadrature%ngi == size(x_shape%n_s, 2)) - assert(size(n_s,1) == size(x_shape%n_s, 1)) - assert(size(n_s,2) == size(x_shape%n_s, 2)) - - assert(associated(x_shape%dn_s)) - assert(x_shape%loc == size(x_shape%dn_s, 1)) - assert(x_shape%surface_quadrature%ngi == size(x_shape%dn_s, 2)) - assert(x_shape%dim == size(x_shape%dn_s, 3)) - assert(size(dn_s,1) == size(x_shape%dn_s, 1)) - assert(size(dn_s,2) == size(x_shape%dn_s, 2)) - assert(size(dn_s,3) == size(x_shape%dn_s, 3)) - - assert(X%dim==mesh_dim(X)) ! this routine doesn't work for embedded coordinates - - if (present(detwei)) then - assert(size(detwei)==x_shape%surface_quadrature%ngi) - end if - if (present(detJ)) then - assert(size(detJ)==x_shape%surface_quadrature%ngi) - end if - - n_s = face_n_s(x_shape, X%mesh, face) - dn_s = face_dn_s(x_shape, X%mesh, face) - - x_spherical = use_analytical_spherical_mapping(X) - - if (x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX)) then - ! for non-linear compute on all gauss points - compute_ngi=x_shape%surface_quadrature%ngi - else - ! for linear: compute only the first and copy the rest - compute_ngi=1 - end if - - x_val = ele_val(X, ele) - if (x_spherical) then - r_val = sqrt(sum(x_val**2, dim=1)) - end if - - select case (X%dim) - case(1) - - do gi=1,compute_ngi - J_local(1,1)=dot_product(x_val(1,:), dn_s(:, gi, 1)) - detJ_local(gi)=J_local(1,1) - invJ(1,1,gi)=1.0/detJ_local(gi) - end do - ! copy the rest - do gi=compute_ngi+1, x_shape%surface_quadrature%ngi - detJ_local(gi) = detJ_local(1) - invJ(1,1,gi)=invJ(1,1,1) - end do - case(2) + ! Calculate transformed quadrature weights. + if (present(detwei_f)) then + detwei_f(gi)=abs(detJ_local)*x_shape%surface_quadrature%weight(gi) + end if - do gi=1, compute_ngi + ! Copy the Jacobian and related variables to externally accessible memory + if (present(J)) then + if (x_nonlinear.or.gi==1) then + J(:,:,gi) = transpose(J_local_T(:,:)) + else + J(:,:,gi) = J(:,:,1) + end if + end if + if (present(invJ)) invJ(:,:,gi) = invJ_local(:,:) + if (present(detJ)) detJ(gi) = detJ_local + if (present(normal)) then + if ((x_nonlinear.or.gi==1).and..not.cache_valid) then + ! Calculate normal. + ! the 1st local coordinate L_1 in dn_s is the one associated + ! with the vertex opposite the facet. The outward_vector + ! is chosen as J(:,1)=-dX/dL_1 (NOTE: it is not yet orthogonal to the facet) + normal(:,gi) = facet_normal(J_local_T(:,2:), -J_local_T(:,1)) + else + normal(:,gi)=normal(:,1) + end if + end if - J_local=matmul(x_val(:,:), dn_s(:, gi, :)) - if (x_spherical) then - J_local = facet_full_jacobian_on_sphere(n_s, dn_s, gi, x_val, r_val, J_local) - end if + end do quad_loop - ! Form determinant by expanding minors. - detJ_local(gi)=J_local(1,1)*J_local(2,2)-J_local(2,1)*J_local(1,2) - ! take inverse *and* transpose - invJ(:,:,gi)=reshape((/ J_local(2,2),-J_local(1,2), & - & -J_local(2,1), J_local(1,1)/),(/2,2/)) & - / detJ_local(gi) - end do - ! copy the rest - do gi=compute_ngi+1, x_shape%surface_quadrature%ngi - detJ_local(gi) = detJ_local(1) - invJ(:,:,gi)=invJ(:,:,1) - end do + end subroutine transform_full_facet_to_physical_full + + subroutine compute_facet_full_inverse_jacobian(X, face, invJ, detwei, detJ) + !!< Fast version of transform_to_physical that only calculates detwei and full invJ on a facet. + !!< NOTE: the detJ and detwei that this (optionally) returns is based on + !!< the determinant of the full facet Jacobian. This is different to the + !!< detJ and detwei returned by transform_facet_to_physical, which is lower + !!< dimensional and only based on the facet. + + !! positions field and element to compute inv. jacobian for + type(vector_field), intent(in):: X + integer, intent(in):: face + !! Inverse of the jacobian matrix at each quadrature point (dim x dim x x_shape%surface_quadrature%ngi) + !! Facilitates access to this information externally + real, dimension(:,:,:), intent(out) :: invJ + !! Quadrature weights for physical coordinates. + real, dimension(:), optional, intent(out) :: detwei (:) + !! Determinant of the Jacobian at each quadrature point (x_shape%surface_quadrature%ngi) + !! Facilitates access to this information externally + real, dimension(:), intent(out), optional :: detJ + + !! coordinates of the nodes + real, dimension(X%dim, ele_loc(X,face_ele(X, face))):: x_val + !! radius (l2norm) of x_val at the nodes (used for spherical positions) + real, dimension(size(x_val,2)) :: r_val + + !! Shape function to be used for coordinate interpolation. + type(element_type), pointer :: x_shape + !! Local versions of the Jacobian matrix + real, dimension(size(invJ,1),size(invJ,1)) :: J_local + !! Local version of the determinant of J + real, dimension(size(invJ,3)) :: detJ_local + logical :: x_spherical + + integer gi, i, k, compute_ngi, ele + real, dimension(size(x_val,2),size(invJ,3)) :: n_s + real, dimension(size(x_val,2),size(invJ,3),X%dim) :: dn_s + + ele = face_ele(X, face) + x_shape => ele_shape(X, ele) - case(3) + assert(associated(x_shape%surface_quadrature)) + assert(size(invJ, 1) == x_shape%dim) + assert(size(invJ, 2) == x_shape%dim) + assert(size(invJ, 3) == x_shape%surface_quadrature%ngi) - do gi=1, compute_ngi + assert(associated(x_shape%n_s)) + assert(x_shape%loc == size(x_shape%n_s, 1)) + assert(x_shape%surface_quadrature%ngi == size(x_shape%n_s, 2)) + assert(size(n_s,1) == size(x_shape%n_s, 1)) + assert(size(n_s,2) == size(x_shape%n_s, 2)) - J_local=matmul(x_val(:,:), dn_s(:, gi, :)) - if (x_spherical) then - J_local = facet_full_jacobian_on_sphere(n_s, dn_s, gi, x_val, r_val, J_local) - end if - ! Calculate (scaled) inverse (of the transpose of J_local) using recursive determinants. - forall (i=1:X%dim,k=1:X%dim) - invJ(i,k,gi)=J_local(cyc3(i+1),cyc3(k+1))*J_local(cyc3(i+2),cyc3(k+2)) & - -J_local(cyc3(i+2),cyc3(k+1))*J_local(cyc3(i+1),cyc3(k+2)) - end forall - ! Form determinant by expanding minors. - detJ_local(gi)=dot_product(J_local(:,1), invJ(:,1,gi)) + assert(associated(x_shape%dn_s)) + assert(x_shape%loc == size(x_shape%dn_s, 1)) + assert(x_shape%surface_quadrature%ngi == size(x_shape%dn_s, 2)) + assert(x_shape%dim == size(x_shape%dn_s, 3)) + assert(size(dn_s,1) == size(x_shape%dn_s, 1)) + assert(size(dn_s,2) == size(x_shape%dn_s, 2)) + assert(size(dn_s,3) == size(x_shape%dn_s, 3)) - ! Scale inverse by determinant. - invJ(:,:,gi)=invJ(:,:,gi)/detJ_local(gi) + assert(X%dim==mesh_dim(X)) ! this routine doesn't work for embedded coordinates - end do + if (present(detwei)) then + assert(size(detwei)==x_shape%surface_quadrature%ngi) + end if + if (present(detJ)) then + assert(size(detJ)==x_shape%surface_quadrature%ngi) + end if - ! copy the rest - do gi=compute_ngi+1, x_shape%surface_quadrature%ngi - detJ_local(gi) = detJ_local(1) - invJ(:,:,gi)=invJ(:,:,1) - end do + n_s = face_n_s(x_shape, X%mesh, face) + dn_s = face_dn_s(x_shape, X%mesh, face) - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - - if (present(detJ)) then - detJ = detJ_local - end if - - if (present(detwei)) then - detwei = abs(detJ_local)*x_shape%surface_quadrature%weight - end if - - end subroutine compute_facet_full_inverse_jacobian - - function jacobian_on_sphere(x_shape, gi, x_val, r_val, Jt) result (Jsphere) - type(element_type), intent(in):: x_shape - integer, intent(in):: gi ! which gauss point are we computing? - real, dimension(:,:), intent(in):: x_val ! coordinates of the nodes (xdim x nloc) - real, dimension(:), intent(in):: r_val ! radius (l2norm) of x_val at the nodes - real, dimension(:,:), intent(in):: Jt ! dX/dxi of linearly interpolated X - real, dimension(size(Jt,1),size(Jt,2)):: Jsphere - - real, dimension(size(x_val,1)) :: xgi, xhat - real, dimension(size(x_shape%dn,3)) :: drdxi - real, dimension(size(xgi),size(xgi)) :: dxhatdx - real :: normx, rgi - integer :: i, j - - xgi = matmul(x_val, x_shape%n(:,gi)) - normx = sqrt(sum(xgi**2)) - xhat = xgi/normx - rgi = dot_product(r_val, x_shape%n(:,gi)) - drdxi = matmul(r_val, x_shape%dn(:,gi,:)) - - do i=1, size(xhat) - do j=1, size(xhat) - dxhatdx(i,j) = -xhat(i)*xhat(j) - end do - end do - do i=1, size(xhat) - dxhatdx(i,i) = dxhatdx(i,i) + 1.0 - end do - dxhatdx = dxhatdx/normx + x_spherical = use_analytical_spherical_mapping(X) + + if (x_spherical .or. .not.(x_shape%degree==1 .and. x_shape%numbering%family==FAMILY_SIMPLEX)) then + ! for non-linear compute on all gauss points + compute_ngi=x_shape%surface_quadrature%ngi + else + ! for linear: compute only the first and copy the rest + compute_ngi=1 + end if + + x_val = ele_val(X, ele) + if (x_spherical) then + r_val = sqrt(sum(x_val**2, dim=1)) + end if + + select case (X%dim) + case(1) + + do gi=1,compute_ngi + J_local(1,1)=dot_product(x_val(1,:), dn_s(:, gi, 1)) + detJ_local(gi)=J_local(1,1) + invJ(1,1,gi)=1.0/detJ_local(gi) + end do + ! copy the rest + do gi=compute_ngi+1, x_shape%surface_quadrature%ngi + detJ_local(gi) = detJ_local(1) + invJ(1,1,gi)=invJ(1,1,1) + end do + + case(2) + + do gi=1, compute_ngi + + J_local=matmul(x_val(:,:), dn_s(:, gi, :)) + if (x_spherical) then + J_local = facet_full_jacobian_on_sphere(n_s, dn_s, gi, x_val, r_val, J_local) + end if + + ! Form determinant by expanding minors. + detJ_local(gi)=J_local(1,1)*J_local(2,2)-J_local(2,1)*J_local(1,2) + ! take inverse *and* transpose + invJ(:,:,gi)=reshape((/ J_local(2,2),-J_local(1,2), & + & -J_local(2,1), J_local(1,1)/),(/2,2/)) & + / detJ_local(gi) + end do + ! copy the rest + do gi=compute_ngi+1, x_shape%surface_quadrature%ngi + detJ_local(gi) = detJ_local(1) + invJ(:,:,gi)=invJ(:,:,1) + end do + + case(3) + + do gi=1, compute_ngi - Jsphere = matmul(dxhatdx, Jt)*rgi + J_local=matmul(x_val(:,:), dn_s(:, gi, :)) + if (x_spherical) then + J_local = facet_full_jacobian_on_sphere(n_s, dn_s, gi, x_val, r_val, J_local) + end if + ! Calculate (scaled) inverse (of the transpose of J_local) using recursive determinants. + forall (i=1:X%dim,k=1:X%dim) + invJ(i,k,gi)=J_local(cyc3(i+1),cyc3(k+1))*J_local(cyc3(i+2),cyc3(k+2)) & + -J_local(cyc3(i+2),cyc3(k+1))*J_local(cyc3(i+1),cyc3(k+2)) + end forall + ! Form determinant by expanding minors. + detJ_local(gi)=dot_product(J_local(:,1), invJ(:,1,gi)) + + ! Scale inverse by determinant. + invJ(:,:,gi)=invJ(:,:,gi)/detJ_local(gi) - do i=1, size(xhat) - do j=1, size(drdxi) - Jsphere(i,j) = Jsphere(i,j) + xhat(i)*drdxi(j) + end do + + ! copy the rest + do gi=compute_ngi+1, x_shape%surface_quadrature%ngi + detJ_local(gi) = detJ_local(1) + invJ(:,:,gi)=invJ(:,:,1) + end do + + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + if (present(detJ)) then + detJ = detJ_local + end if + + if (present(detwei)) then + detwei = abs(detJ_local)*x_shape%surface_quadrature%weight + end if + + end subroutine compute_facet_full_inverse_jacobian + + function jacobian_on_sphere(x_shape, gi, x_val, r_val, Jt) result (Jsphere) + type(element_type), intent(in):: x_shape + integer, intent(in):: gi ! which gauss point are we computing? + real, dimension(:,:), intent(in):: x_val ! coordinates of the nodes (xdim x nloc) + real, dimension(:), intent(in):: r_val ! radius (l2norm) of x_val at the nodes + real, dimension(:,:), intent(in):: Jt ! dX/dxi of linearly interpolated X + real, dimension(size(Jt,1),size(Jt,2)):: Jsphere + + real, dimension(size(x_val,1)) :: xgi, xhat + real, dimension(size(x_shape%dn,3)) :: drdxi + real, dimension(size(xgi),size(xgi)) :: dxhatdx + real :: normx, rgi + integer :: i, j + + xgi = matmul(x_val, x_shape%n(:,gi)) + normx = sqrt(sum(xgi**2)) + xhat = xgi/normx + rgi = dot_product(r_val, x_shape%n(:,gi)) + drdxi = matmul(r_val, x_shape%dn(:,gi,:)) + + do i=1, size(xhat) + do j=1, size(xhat) + dxhatdx(i,j) = -xhat(i)*xhat(j) + end do end do - end do - - end function jacobian_on_sphere - - function facet_full_jacobian_on_sphere(n_s, dn_s, gi, x_val, r_val, Jt) result (Jsphere) - real, dimension(:,:) :: n_s - real, dimension(:,:,:) :: dn_s - integer, intent(in):: gi ! which gauss point are we computing? - real, dimension(:,:), intent(in):: x_val ! coordinates of the nodes (xdim x nloc) - real, dimension(:), intent(in):: r_val ! radius (l2norm) of x_val at the nodes - real, dimension(:,:), intent(in):: Jt ! dX/dxi of linearly interpolated X - real, dimension(size(Jt,1),size(Jt,2)):: Jsphere - - real, dimension(size(x_val,1)) :: xgi, xhat - real, dimension(size(dn_s,3)) :: drdxi - real, dimension(size(xgi),size(xgi)) :: dxhatdx - real :: normx, rgi - integer :: i, j - - xgi = matmul(x_val, n_s(:,gi)) - normx = sqrt(sum(xgi**2)) - xhat = xgi/normx - rgi = dot_product(r_val, n_s(:,gi)) - drdxi = matmul(r_val, dn_s(:,gi,:)) - - do i=1, size(xhat) - do j=1, size(xhat) - dxhatdx(i,j) = -xhat(i)*xhat(j) + do i=1, size(xhat) + dxhatdx(i,i) = dxhatdx(i,i) + 1.0 end do - end do - do i=1, size(xhat) - dxhatdx(i,i) = dxhatdx(i,i) + 1.0 - end do - dxhatdx = dxhatdx/normx + dxhatdx = dxhatdx/normx - Jsphere = matmul(dxhatdx, Jt)*rgi + Jsphere = matmul(dxhatdx, Jt)*rgi + + do i=1, size(xhat) + do j=1, size(drdxi) + Jsphere(i,j) = Jsphere(i,j) + xhat(i)*drdxi(j) + end do + end do - do i=1, size(xhat) - do j=1, size(drdxi) - Jsphere(i,j) = Jsphere(i,j) + xhat(i)*drdxi(j) + end function jacobian_on_sphere + + function facet_full_jacobian_on_sphere(n_s, dn_s, gi, x_val, r_val, Jt) result (Jsphere) + real, dimension(:,:) :: n_s + real, dimension(:,:,:) :: dn_s + integer, intent(in):: gi ! which gauss point are we computing? + real, dimension(:,:), intent(in):: x_val ! coordinates of the nodes (xdim x nloc) + real, dimension(:), intent(in):: r_val ! radius (l2norm) of x_val at the nodes + real, dimension(:,:), intent(in):: Jt ! dX/dxi of linearly interpolated X + real, dimension(size(Jt,1),size(Jt,2)):: Jsphere + + real, dimension(size(x_val,1)) :: xgi, xhat + real, dimension(size(dn_s,3)) :: drdxi + real, dimension(size(xgi),size(xgi)) :: dxhatdx + real :: normx, rgi + integer :: i, j + + xgi = matmul(x_val, n_s(:,gi)) + normx = sqrt(sum(xgi**2)) + xhat = xgi/normx + rgi = dot_product(r_val, n_s(:,gi)) + drdxi = matmul(r_val, dn_s(:,gi,:)) + + do i=1, size(xhat) + do j=1, size(xhat) + dxhatdx(i,j) = -xhat(i)*xhat(j) + end do + end do + do i=1, size(xhat) + dxhatdx(i,i) = dxhatdx(i,i) + 1.0 end do - end do + dxhatdx = dxhatdx/normx - end function facet_full_jacobian_on_sphere + Jsphere = matmul(dxhatdx, Jt)*rgi - subroutine transform_cvsurf_to_physical(X, x_shape, detwei, normal, cvfaces) - !!< Coordinate transformations for control volume surface integrals. - !!< Calculates the quadrature weights and unorientated face normals as a side bonus. + do i=1, size(xhat) + do j=1, size(drdxi) + Jsphere(i,j) = Jsphere(i,j) + xhat(i)*drdxi(j) + end do + end do - ! Column n of X is the position of the nth node on the facet. - real, dimension(:,:), intent(in) :: X - ! Reference coordinate control volume surface element: - type(element_type), intent(in) :: x_shape - ! Quadrature weights for physical coordinates. - real, dimension(:), intent(out) :: detwei - ! face normals - not necessarily correctly orientated - real, dimension(:,:), intent(out) :: normal - ! control volume face information - allows optimisation - type(cv_faces_type), intent(in) :: cvfaces + end function facet_full_jacobian_on_sphere - ! Jacobian matrix - real, dimension(size(X,1), size(x_shape%dn, 3)) :: J + subroutine transform_cvsurf_to_physical(X, x_shape, detwei, normal, cvfaces) + !!< Coordinate transformations for control volume surface integrals. + !!< Calculates the quadrature weights and unorientated face normals as a side bonus. - ! Determinant of J - real :: detJ + ! Column n of X is the position of the nth node on the facet. + real, dimension(:,:), intent(in) :: X + ! Reference coordinate control volume surface element: + type(element_type), intent(in) :: x_shape + ! Quadrature weights for physical coordinates. + real, dimension(:), intent(out) :: detwei + ! face normals - not necessarily correctly orientated + real, dimension(:,:), intent(out) :: normal + ! control volume face information - allows optimisation + type(cv_faces_type), intent(in) :: cvfaces - integer :: gi, i, dim, ggi, face - logical :: x_nonlinear + ! Jacobian matrix + real, dimension(size(X,1), size(x_shape%dn, 3)) :: J - dim=size(X,1) + ! Determinant of J + real :: detJ - assert(size(detwei)==x_shape%ngi) + integer :: gi, i, dim, ggi, face + logical :: x_nonlinear - ! Optimisation checks. Optimisations apply to linear elements. - x_nonlinear= .not.(x_shape%degree==1.and.x_shape%numbering%family==FAMILY_SIMPLEX) + dim=size(X,1) - face_loop: do face = 1, cvfaces%faces + assert(size(detwei)==x_shape%ngi) - quad_loop: do gi = 1, cvfaces%shape%ngi + ! Optimisation checks. Optimisations apply to linear elements. + x_nonlinear= .not.(x_shape%degree==1.and.x_shape%numbering%family==FAMILY_SIMPLEX) + + face_loop: do face = 1, cvfaces%faces + + quad_loop: do gi = 1, cvfaces%shape%ngi + + ! global gauss pt index + ggi = (face-1)*cvfaces%shape%ngi + gi + + ! assemble the jacobian... + ! this needs to be done at every gauss point if space is nonlinear + ! but if space is linear then it only needs to be done at the + ! first gauss point of each cv face + if(x_nonlinear.or.(gi==1)) then + + ! |- dx dx -| + ! | dL1 dL2 | + ! | | + ! | dy dy | + ! J = | dL1 dL2 | + ! | | + ! | dz dz | + ! |- dL1 dL2 -| + + ! Form Jacobian. + J=matmul(X(:,:), x_shape%dn(:, ggi, :)) + + detJ=0.0 + ! Calculate determinant. + select case (dim) + case(1) + detJ=1.0 + case(2) + detJ = sqrt(J(1,1)**2 + J(2,1)**2) + case(3) + do i=1,3 + detJ=detJ+ & + (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i+1),1))**2 + end do + detJ=sqrt(detJ) + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + end if + + ! Calculate transformed quadrature weights. + detwei(ggi)=detJ*x_shape%quadrature%weight(ggi) + + ! find the normal... + ! this needs to be done at every gauss point if space is nonlinear + ! otherwise it only needs to be done for the first gauss point on each + ! cv face - other faces have their normals set to that of the first gauss + ! point of the same face + if(x_nonlinear.or.(gi==1)) then + normal(:,ggi)=normgi(J) + else + normal(:,ggi)=normal(:,(face-1)*cvfaces%shape%ngi+1) + end if - ! global gauss pt index - ggi = (face-1)*cvfaces%shape%ngi + gi + end do quad_loop - ! assemble the jacobian... - ! this needs to be done at every gauss point if space is nonlinear - ! but if space is linear then it only needs to be done at the - ! first gauss point of each cv face - if(x_nonlinear.or.(gi==1)) then + end do face_loop - ! |- dx dx -| - ! | dL1 dL2 | - ! | | - ! | dy dy | - ! J = | dL1 dL2 | - ! | | - ! | dz dz | - ! |- dL1 dL2 -| + contains - ! Form Jacobian. - J=matmul(X(:,:), x_shape%dn(:, ggi, :)) + function normgi(J) + ! Calculate the normal at a given quadrature point, + ! Control volume surface Jacobian. + real, dimension(:,:), intent(in) :: J + real, dimension(size(J,1)) :: normgi - detJ=0.0 - ! Calculate determinant. - select case (dim) + select case (dim) case(1) - detJ=1.0 - case(2) - detJ = sqrt(J(1,1)**2 + J(2,1)**2) - case(3) - do i=1,3 - detJ=detJ+ & - (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i+1),1))**2 - end do - detJ=sqrt(detJ) + normgi = 1.0 + case (2) + normgi = (/ -J(2,1), J(1,1) /) + case (3) + normgi=cross_product(J(:,1),J(:,2)) case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - end if - - ! Calculate transformed quadrature weights. - detwei(ggi)=detJ*x_shape%quadrature%weight(ggi) - - ! find the normal... - ! this needs to be done at every gauss point if space is nonlinear - ! otherwise it only needs to be done for the first gauss point on each - ! cv face - other faces have their normals set to that of the first gauss - ! point of the same face - if(x_nonlinear.or.(gi==1)) then - normal(:,ggi)=normgi(J) - else - normal(:,ggi)=normal(:,(face-1)*cvfaces%shape%ngi+1) - end if + FLAbort('Unsupported dimension selected.') + end select - end do quad_loop + end function normgi - end do face_loop + pure function cross_product(vector1,vector2) + real, dimension(3) :: cross_product + real, dimension(3), intent(in) :: vector1, vector2 - contains + integer :: i - function normgi(J) - ! Calculate the normal at a given quadrature point, - ! Control volume surface Jacobian. - real, dimension(:,:), intent(in) :: J - real, dimension(size(J,1)) :: normgi + forall(i=1:3) + cross_product(i)=vector1(cyc3(i+1))*vector2(cyc3(i+2))& + -vector1(cyc3(i+2))*vector2(cyc3(i+1)) + end forall - select case (dim) - case(1) - normgi = 1.0 - case (2) - normgi = (/ -J(2,1), J(1,1) /) - case (3) - normgi=cross_product(J(:,1),J(:,2)) - case default - FLAbort('Unsupported dimension selected.') - end select + end function cross_product - end function normgi - - pure function cross_product(vector1,vector2) - real, dimension(3) :: cross_product - real, dimension(3), intent(in) :: vector1, vector2 - - integer :: i - - forall(i=1:3) - cross_product(i)=vector1(cyc3(i+1))*vector2(cyc3(i+2))& - -vector1(cyc3(i+2))*vector2(cyc3(i+1)) - end forall - - end function cross_product - - end subroutine transform_cvsurf_to_physical - - subroutine transform_cvsurf_facet_to_physical(X, X_f, x_shape_f, & - normal, detwei) - - ! Coordinate transformations for facet integrals around control volumes. - ! Calculate the transformed quadrature - ! weights as a side bonus. - ! - ! For facet integrals, we also need to know the facet outward - ! pointing normal. - ! - ! In this case it is only the determinant of the Jacobian which is - ! required. - - ! Coordinate facet element: - type(element_type), intent(in) :: x_shape_f - ! Column n of X is the position of the nth node. - real, dimension(:,:), intent(in) :: X - ! Column n of X_f is the position of the nth node on the facet. - real, dimension(:,:), intent(in) :: X_f - ! Quadrature weights for physical coordinates. - real, dimension(:), intent(out), optional :: detwei - ! Outward normal vector. (dim x x_shape_f%ngi) - real, dimension(:,:), intent(out) :: normal - - ! Jacobian matrix and its inverse. - real, dimension(size(X,1),x_shape_f%numbering%dimension) :: J - ! Determinant of J - real :: detJ - - integer :: gi, i, dim - - logical :: x_nonlinear - - dim=size(X,1) - assert(size(X_f,1)==dim) - assert(size(X_f,2)==x_shape_f%loc) - - assert(size(normal,1)==dim) - - if(present(detwei)) then - assert(size(detwei)==x_shape_f%ngi) - end if - - ! Optimisation checks. Optimisations apply to linear space elements. - x_nonlinear= .not.(x_shape_f%degree==1.and.x_shape_f%numbering%family==FAMILY_SIMPLEX) - - ! Loop over quadrature points. - quad_loop: do gi=1,x_shape_f%ngi - - if (x_nonlinear.or.gi==1) then - ! For linear space elements only calculate Jacobian once. - ! |- dx dx -| - ! | dL1 dL2 | - ! | | - ! | dy dy | - ! J = | dL1 dL2 | - ! | | - ! | dz dz | - ! |- dL1 dL2 -| - - ! Form Jacobian. - J=matmul(X_f(:,:), x_shape_f%dn(:, gi, :)) - - detJ=0.0 - ! Calculate determinant. - select case (dim) - case(1) - detJ=1.0 - case(2) - detJ = sqrt(J(1,1)**2 + J(2,1)**2) - case(3) - do i=1,3 - detJ=detJ+ & - (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i+1),1))**2 - end do - detJ=sqrt(detJ) - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select - end if + end subroutine transform_cvsurf_to_physical - ! Calculate transformed quadrature weights. - if(present(detwei)) then - detwei(gi)=detJ*x_shape_f%quadrature%weight(gi) - end if + subroutine transform_cvsurf_facet_to_physical(X, X_f, x_shape_f, & + normal, detwei) - if (x_nonlinear.or.gi==1) then - ! Calculate normal. - normal(:,gi)=normgi(X,X_f,J) - else - normal(:,gi)=normal(:,1) - end if + ! Coordinate transformations for facet integrals around control volumes. + ! Calculate the transformed quadrature + ! weights as a side bonus. + ! + ! For facet integrals, we also need to know the facet outward + ! pointing normal. + ! + ! In this case it is only the determinant of the Jacobian which is + ! required. - end do quad_loop + ! Coordinate facet element: + type(element_type), intent(in) :: x_shape_f + ! Column n of X is the position of the nth node. + real, dimension(:,:), intent(in) :: X + ! Column n of X_f is the position of the nth node on the facet. + real, dimension(:,:), intent(in) :: X_f + ! Quadrature weights for physical coordinates. + real, dimension(:), intent(out), optional :: detwei + ! Outward normal vector. (dim x x_shape_f%ngi) + real, dimension(:,:), intent(out) :: normal - contains + ! Jacobian matrix and its inverse. + real, dimension(size(X,1),x_shape_f%numbering%dimension) :: J + ! Determinant of J + real :: detJ - function normgi(X, X_f, J) - ! Calculate the normal at a given quadrature point, - real, dimension(:,:), intent(in) :: J - real, dimension(size(J,1)) :: normgi - ! Element and normal node locations respectively. - real, dimension (:,:), intent(in) :: X, X_f - ! Facet Jacobian. + integer :: gi, i, dim - ! Outward pointing not necessarily normal vector. - real, dimension(3) :: outv + logical :: x_nonlinear - integer :: ldim + dim=size(X,1) + assert(size(X_f,1)==dim) + assert(size(X_f,2)==x_shape_f%loc) - ldim = size(J,1) + assert(size(normal,1)==dim) - ! Outv is the vector from the element centroid to the facet centroid. - outv(1:ldim) = sum(X_f,2)/size(X_f,2)-sum(X,2)/size(X,2) + if(present(detwei)) then + assert(size(detwei)==x_shape_f%ngi) + end if - select case (dim) - case(1) - normgi = 1.0 - case (2) - normgi = (/ -J(2,1), J(1,1) /) - case (3) - normgi=cross_product(J(:,1),J(:,2)) - case default - FLAbort('Unsupported dimension selected.') - end select + ! Optimisation checks. Optimisations apply to linear space elements. + x_nonlinear= .not.(x_shape_f%degree==1.and.x_shape_f%numbering%family==FAMILY_SIMPLEX) + + ! Loop over quadrature points. + quad_loop: do gi=1,x_shape_f%ngi + + if (x_nonlinear.or.gi==1) then + ! For linear space elements only calculate Jacobian once. + ! |- dx dx -| + ! | dL1 dL2 | + ! | | + ! | dy dy | + ! J = | dL1 dL2 | + ! | | + ! | dz dz | + ! |- dL1 dL2 -| + + ! Form Jacobian. + J=matmul(X_f(:,:), x_shape_f%dn(:, gi, :)) + + detJ=0.0 + ! Calculate determinant. + select case (dim) + case(1) + detJ=1.0 + case(2) + detJ = sqrt(J(1,1)**2 + J(2,1)**2) + case(3) + do i=1,3 + detJ=detJ+ & + (J(cyc3(i+2),1)*J(cyc3(i+1),2)-J(cyc3(i+2),2)*J(cyc3(i+1),1))**2 + end do + detJ=sqrt(detJ) + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + end if - ! Set correct orientation. - normgi=normgi*dot_product(normgi, outv(1:ldim) ) + ! Calculate transformed quadrature weights. + if(present(detwei)) then + detwei(gi)=detJ*x_shape_f%quadrature%weight(gi) + end if - ! normalise - normgi=normgi/sqrt(sum(normgi**2)) + if (x_nonlinear.or.gi==1) then + ! Calculate normal. + normal(:,gi)=normgi(X,X_f,J) + else + normal(:,gi)=normal(:,1) + end if - end function normgi + end do quad_loop + + contains - function cross_product(vector1,vector2) result (prod) - real, dimension(3) :: prod - real, dimension(3), intent(in) :: vector1, vector2 + function normgi(X, X_f, J) + ! Calculate the normal at a given quadrature point, + real, dimension(:,:), intent(in) :: J + real, dimension(size(J,1)) :: normgi + ! Element and normal node locations respectively. + real, dimension (:,:), intent(in) :: X, X_f + ! Facet Jacobian. - integer :: i + ! Outward pointing not necessarily normal vector. + real, dimension(3) :: outv - forall(i=1:3) - prod(i)=vector1(cyc3(i+1))*vector2(cyc3(i+2))& - -vector1(cyc3(i+2))*vector2(cyc3(i+1)) - end forall + integer :: ldim - end function cross_product + ldim = size(J,1) - end subroutine transform_cvsurf_facet_to_physical + ! Outv is the vector from the element centroid to the facet centroid. + outv(1:ldim) = sum(X_f,2)/size(X_f,2)-sum(X,2)/size(X,2) - subroutine transform_superconvergent_to_physical(X, x_shape, n_shape, dnsp_t) - !!< Given a positions shape function and node positions return the - !!< return the transformed derivatives of X at the superconvergent - !!< points. - !! Column n of X is the position of the nth node. (dim x x_shape%loc) - !! only need position of n nodes since Jacobian is only calculated once - real, dimension(:,:), intent(in) :: X - !! Shape function used for coordinate interpolation - type(element_type), intent(in) :: x_shape, n_shape - !! Derivatives at superconvergent points in physical coordinates. - !! (x_shape%loc x x_shape%superconvergence%nsp x dim) - real, dimension(:,:,:), intent(out) :: dnsp_t + select case (dim) + case(1) + normgi = 1.0 + case (2) + normgi = (/ -J(2,1), J(1,1) /) + case (3) + normgi=cross_product(J(:,1),J(:,2)) + case default + FLAbort('Unsupported dimension selected.') + end select - ! Jacobian matrix and its inverse. (dim x dim) - real :: detJ - real, dimension(size(X,1),size(X,1)) :: J, invJ + ! Set correct orientation. + normgi=normgi*dot_product(normgi, outv(1:ldim) ) + + ! normalise + normgi=normgi/sqrt(sum(normgi**2)) + + end function normgi + + function cross_product(vector1,vector2) result (prod) + real, dimension(3) :: prod + real, dimension(3), intent(in) :: vector1, vector2 + + integer :: i + + forall(i=1:3) + prod(i)=vector1(cyc3(i+1))*vector2(cyc3(i+2))& + -vector1(cyc3(i+2))*vector2(cyc3(i+1)) + end forall + + end function cross_product + + end subroutine transform_cvsurf_facet_to_physical + + subroutine transform_superconvergent_to_physical(X, x_shape, n_shape, dnsp_t) + !!< Given a positions shape function and node positions return the + !!< return the transformed derivatives of X at the superconvergent + !!< points. + !! Column n of X is the position of the nth node. (dim x x_shape%loc) + !! only need position of n nodes since Jacobian is only calculated once + real, dimension(:,:), intent(in) :: X + !! Shape function used for coordinate interpolation + type(element_type), intent(in) :: x_shape, n_shape + !! Derivatives at superconvergent points in physical coordinates. + !! (x_shape%loc x x_shape%superconvergence%nsp x dim) + real, dimension(:,:,:), intent(out) :: dnsp_t + + ! Jacobian matrix and its inverse. (dim x dim) + real :: detJ + real, dimension(size(X,1),size(X,1)) :: J, invJ + + integer :: sp, i, k, dim + + dim=size(X,1) + + assert(size(X,2)==x_shape%loc) + assert(size(dnsp_t,1)==n_shape%loc) + assert(size(dnsp_t,2)==n_shape%superconvergence%nsp) + assert(size(dnsp_t,3)==dim) + + ! Loop over superconvergent points. + super_point_loop: do sp=1,n_shape%superconvergence%nsp + + if ((sp==1).or.(x_shape%degree>1)) then + ! |- dx dx dx -| + ! | dL1 dL2 dL3 | + ! | | + ! | dy dy dy | + ! J = | dL1 dL2 dL3 | + ! | | + ! | dz dz dz | + ! |- dL1 dL2 dL3 -| + + ! Form Jacobian. + J=transpose(matmul(X, x_shape%superconvergence%dn(:, sp, :))) + + select case (dim) + case(1) + invJ=1.0 + case(2) + invJ=reshape((/J(2,2),-J(2,1),-J(1,2),J(1,1)/),(/2,2/)) + case(3) + ! Calculate (scaled) inverse using recursive determinants. + forall (i=1:dim,k=1:dim) + invJ(k,i)=J(cyc3(i+1),cyc3(k+1))*J(cyc3(i+2),cyc3(k+2)) & + -J(cyc3(i+2),cyc3(k+1))*J(cyc3(i+1),cyc3(k+2)) + end forall + case default + FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") + end select + + detJ=dot_product(J(1,:),invJ(:,1)) + invJ=invJ/detJ + end if - integer :: sp, i, k, dim + ! Evaluate derivatives in physical space. + do i=1,n_shape%loc + dnsp_t(i,sp,:)=matmul(invJ, n_shape%superconvergence%dn(i,sp,:)) + end do - dim=size(X,1) + end do super_point_loop + + end subroutine transform_superconvergent_to_physical + + subroutine transform_horizontal_to_physical(X_f, X_face_shape, vertical_normal, & + m_f, dm_hor, detwei_hor) + !!< Given the 'dim+1'-dimensional coordinates of a 'dim'-dimensional face + !!< and its shape function on that face, return the inverse Jacobian + !!< associated with the transformation between the local 'dim' coordinates + !!< on the face augmented with an auxiliary local vertical coordinate, + !!< and the 'dim+1' physical coordinates. + !!< This can be used to transform derivatives of fields defined on the face + !!< to a horizontal derivative. + !!< Also returned is detwei_hor which can be used to perform an integration + !!< of fields defined on the face integrated over the face projected in + !!< the horizontal plane. + !! NOTE: in the following nloc are the number of nodes, and ngi + !! the number of gausspoints on the FACE + !! positions of the nodes on the face (dim+1 x nloc) + real, dimension(:,:):: X_f + !! element shape used to interpolate these positions + type(element_type), intent(in):: X_face_shape + !! vertical normal vector at the gauss points of the face (dim+1 x ngi) + real, dimension(:,:):: vertical_normal + !! element shape of field on the face, you wish to transform + type(element_type), optional, intent(in):: m_f + !! transformed derivatives (nloc x ngi x dim+1): + real, dimension(:,:,:), optional, intent(out):: dm_hor + !! integration weights at gausspoint for horizontal integration (ngi): + real, dimension(:), optional, intent(out):: detwei_hor + + real, dimension(size(X_f,1),size(X_f,1)):: J, invJ + real det + logical x_nonlinear + integer i, gi, dim, cdim + + dim=X_face_shape%dim + cdim=size(X_f,1) + + ! make sure everything is the right size: + assert(cdim==dim+1) + assert(size(vertical_normal,1)==cdim) + assert(X_face_shape%quadrature%ngi==size(vertical_normal,2)) + if (present(dm_hor)) then + assert(size(X_f,2)==size(dm_hor,1)) + assert(size(vertical_normal,2)==size(dm_hor,2)) + assert(m_f%quadrature%ngi==size(dm_hor,2)) + assert(size(dm_hor,3)==cdim) + end if + if (present(detwei_hor)) then + assert(size(vertical_normal,2)==size(detwei_hor)) + end if - assert(size(X,2)==x_shape%loc) - assert(size(dnsp_t,1)==n_shape%loc) - assert(size(dnsp_t,2)==n_shape%superconvergence%nsp) - assert(size(dnsp_t,3)==dim) + ! Optimisation checks. Optimisations apply to linear elements. + x_nonlinear= .not. (X_face_shape%degree==1 .and. X_face_shape%numbering%family==FAMILY_SIMPLEX) - ! Loop over superconvergent points. - super_point_loop: do sp=1,n_shape%superconvergence%nsp + do gi=1, X_face_shape%ngi - if ((sp==1).or.(x_shape%degree>1)) then + ! in 3 dimensions: ! |- dx dx dx -| ! | dL1 dL2 dL3 | ! | | @@ -2493,223 +2588,128 @@ subroutine transform_superconvergent_to_physical(X, x_shape, n_shape, dnsp_t) ! | | ! | dz dz dz | ! |- dL1 dL2 dL3 -| + ! where L1 and L2 are the 2 local coordinates of the face + ! and L3 is an auxillary vertical local coordinate. + if (gi==1 .or. x_nonlinear) then + ! we do follow the definition of J as above + ! (as opposed to tranform_to_physical where J is defined as its transpose) + J(:,1:dim)=matmul(X_f, x_face_shape%dn(:, gi, :)) + ! make extra local coordinate (L_3) in the vertical direction + J(:,cdim)=vertical_normal(:,gi) + + if (cdim==3) then + ! Cross product gives area spanned by local coordinate unit vectors + ! times the surface normal. Taking dot_product with vertical normal + ! then gives the area in the projected in the horizontal direction. + det=abs(dot_product( J(:,3), cross_product( J(:,1), J(:,2) ) )) + else + ! cross product of the local coordinate unit vector and + ! the vertical normal gives projection of the unit vector + ! in horizontal direction. + det=abs(J(1,1)*J(2,2)-J(1,2)*J(2,1)) + end if - ! Form Jacobian. - J=transpose(matmul(X, x_shape%superconvergence%dn(:, sp, :))) + end if - select case (dim) - case(1) - invJ=1.0 - case(2) - invJ=reshape((/J(2,2),-J(2,1),-J(1,2),J(1,1)/),(/2,2/)) - case(3) - ! Calculate (scaled) inverse using recursive determinants. - forall (i=1:dim,k=1:dim) - invJ(k,i)=J(cyc3(i+1),cyc3(k+1))*J(cyc3(i+2),cyc3(k+2)) & - -J(cyc3(i+2),cyc3(k+1))*J(cyc3(i+1),cyc3(k+2)) - end forall - case default - FLAbort("Unsupported dimension specified. Universe is 3 dimensional (sorry Albert).") - end select + if (present(detwei_hor)) then + detwei_hor(gi)=det*X_face_shape%quadrature%weight(gi) + end if + + if (present(m_f)) then + + assert(present(dm_hor)) + + invJ=inverse(J) + + do i=1, size(dm_hor,1) + dm_hor(i,gi,:)=matmul( m_f%dn(i,gi,:), invJ(1:dim,:) ) + ! assume no change of in-field in vertical direction (L_3) + ! thereby effectively taking horizontal derivative + end do + end if + + end do + + end subroutine transform_horizontal_to_physical + + function element_volume(position, ele) + !!< Return the volume of element in the positions field. + real :: element_volume + type(vector_field), intent(in) :: position + integer, intent(in) :: ele + + real, dimension(ele_ngi(position, ele)) :: detwei + + call transform_to_physical_detwei(position, ele, detwei) + + element_volume=sum(detwei) + + end function element_volume + + function local_coords_interpolation(X, ele, position) result(local_coords) + !!< Given a position field, this returns the local coordinates of + !!< position with respect to element "ele". + !!< + !!< This assumes the position field is linear. For higher order + !!< only the coordinates of the vertices are considered + type(vector_field), intent(in) :: X + integer, intent(in) :: ele + real, dimension(:), intent(in) :: position + real, dimension(size(position) + 1) :: local_coords + + integer, dimension(:), pointer:: nodes + integer :: dim + + dim = size(position) + + assert(dim == mesh_dim(X)) + assert(X%mesh%shape%numbering%family==FAMILY_SIMPLEX) + assert(X%mesh%shape%numbering%type==ELEMENT_LAGRANGIAN) + + if (is_cache_valid(X)) then + ! currently we only cache linear meshes + assert(X%mesh%shape%degree==1) + nodes => ele_nodes(X, ele) + + ! we seek local coords xi[1:dim+1] s.t. \sum_i X_i xi_i = X + ! (where X_i are the vertex locations and X is the location we search for) + ! the last local coordinate can be expressed as xi_{dim+1} = 1 - \sum_{i=1}^dim xi_i + ! so that we can write X as a function of the first 1:dim local coordinates xi only: + ! X(xi[1:dim]) = \sum_{i=1}^dim X_i xi_i + X_dim (1 - \sum_{i=1}^dim xi_i) + ! = [X_i - X_dim] xi[1:dim] + X_dim + ! where [X_i-X_dim] is a dim X dim matrix that we can obtain from J = dX/dxi (seeing X as a function + ! of the first 1:dim local coordinates only). Therefore: + ! xi = J^{-1} X-X_dim + + ! the Js and invJ used above are actually the transpose, so we use invJ^T * (X-X_dim) = (X-X_dim)^T invJ + local_coords(1:dim) = matmul(position-node_val(X, nodes(dim+1)), invJ_cache(:, :, ele)) + ! and the final local coordinate, using \sum_i xi_i=1 + local_coords(dim+1) = 1.0 - sum(local_coords(1:dim)) + else + call local_coords_slow + end if - detJ=dot_product(J(1,:),invJ(:,1)) - invJ=invJ/detJ - end if - - ! Evaluate derivatives in physical space. - do i=1,n_shape%loc - dnsp_t(i,sp,:)=matmul(invJ, n_shape%superconvergence%dn(i,sp,:)) - end do - - end do super_point_loop - - end subroutine transform_superconvergent_to_physical - - subroutine transform_horizontal_to_physical(X_f, X_face_shape, vertical_normal, & - m_f, dm_hor, detwei_hor) - !!< Given the 'dim+1'-dimensional coordinates of a 'dim'-dimensional face - !!< and its shape function on that face, return the inverse Jacobian - !!< associated with the transformation between the local 'dim' coordinates - !!< on the face augmented with an auxiliary local vertical coordinate, - !!< and the 'dim+1' physical coordinates. - !!< This can be used to transform derivatives of fields defined on the face - !!< to a horizontal derivative. - !!< Also returned is detwei_hor which can be used to perform an integration - !!< of fields defined on the face integrated over the face projected in - !!< the horizontal plane. - !! NOTE: in the following nloc are the number of nodes, and ngi - !! the number of gausspoints on the FACE - !! positions of the nodes on the face (dim+1 x nloc) - real, dimension(:,:):: X_f - !! element shape used to interpolate these positions - type(element_type), intent(in):: X_face_shape - !! vertical normal vector at the gauss points of the face (dim+1 x ngi) - real, dimension(:,:):: vertical_normal - !! element shape of field on the face, you wish to transform - type(element_type), optional, intent(in):: m_f - !! transformed derivatives (nloc x ngi x dim+1): - real, dimension(:,:,:), optional, intent(out):: dm_hor - !! integration weights at gausspoint for horizontal integration (ngi): - real, dimension(:), optional, intent(out):: detwei_hor - - real, dimension(size(X_f,1),size(X_f,1)):: J, invJ - real det - logical x_nonlinear - integer i, gi, dim, cdim - - dim=X_face_shape%dim - cdim=size(X_f,1) - - ! make sure everything is the right size: - assert(cdim==dim+1) - assert(size(vertical_normal,1)==cdim) - assert(X_face_shape%quadrature%ngi==size(vertical_normal,2)) - if (present(dm_hor)) then - assert(size(X_f,2)==size(dm_hor,1)) - assert(size(vertical_normal,2)==size(dm_hor,2)) - assert(m_f%quadrature%ngi==size(dm_hor,2)) - assert(size(dm_hor,3)==cdim) - end if - if (present(detwei_hor)) then - assert(size(vertical_normal,2)==size(detwei_hor)) - end if - - ! Optimisation checks. Optimisations apply to linear elements. - x_nonlinear= .not. (X_face_shape%degree==1 .and. X_face_shape%numbering%family==FAMILY_SIMPLEX) - - do gi=1, X_face_shape%ngi - - ! in 3 dimensions: - ! |- dx dx dx -| - ! | dL1 dL2 dL3 | - ! | | - ! | dy dy dy | - ! J = | dL1 dL2 dL3 | - ! | | - ! | dz dz dz | - ! |- dL1 dL2 dL3 -| - ! where L1 and L2 are the 2 local coordinates of the face - ! and L3 is an auxillary vertical local coordinate. - if (gi==1 .or. x_nonlinear) then - ! we do follow the definition of J as above - ! (as opposed to tranform_to_physical where J is defined as its transpose) - J(:,1:dim)=matmul(X_f, x_face_shape%dn(:, gi, :)) - ! make extra local coordinate (L_3) in the vertical direction - J(:,cdim)=vertical_normal(:,gi) - - if (cdim==3) then - ! Cross product gives area spanned by local coordinate unit vectors - ! times the surface normal. Taking dot_product with vertical normal - ! then gives the area in the projected in the horizontal direction. - det=abs(dot_product( J(:,3), cross_product( J(:,1), J(:,2) ) )) - else - ! cross product of the local coordinate unit vector and - ! the vertical normal gives projection of the unit vector - ! in horizontal direction. - det=abs(J(1,1)*J(2,2)-J(1,2)*J(2,1)) - end if - - end if - - if (present(detwei_hor)) then - detwei_hor(gi)=det*X_face_shape%quadrature%weight(gi) - end if - - if (present(m_f)) then - - assert(present(dm_hor)) - - invJ=inverse(J) - - do i=1, size(dm_hor,1) - dm_hor(i,gi,:)=matmul( m_f%dn(i,gi,:), invJ(1:dim,:) ) - ! assume no change of in-field in vertical direction (L_3) - ! thereby effectively taking horizontal derivative - end do - end if - - end do - - end subroutine transform_horizontal_to_physical - - function element_volume(position, ele) - !!< Return the volume of element in the positions field. - real :: element_volume - type(vector_field), intent(in) :: position - integer, intent(in) :: ele - - real, dimension(ele_ngi(position, ele)) :: detwei - - call transform_to_physical_detwei(position, ele, detwei) - - element_volume=sum(detwei) - - end function element_volume - - function local_coords_interpolation(X, ele, position) result(local_coords) - !!< Given a position field, this returns the local coordinates of - !!< position with respect to element "ele". - !!< - !!< This assumes the position field is linear. For higher order - !!< only the coordinates of the vertices are considered - type(vector_field), intent(in) :: X - integer, intent(in) :: ele - real, dimension(:), intent(in) :: position - real, dimension(size(position) + 1) :: local_coords - - integer, dimension(:), pointer:: nodes - integer :: dim - - dim = size(position) - - assert(dim == mesh_dim(X)) - assert(X%mesh%shape%numbering%family==FAMILY_SIMPLEX) - assert(X%mesh%shape%numbering%type==ELEMENT_LAGRANGIAN) - - if (is_cache_valid(X)) then - ! currently we only cache linear meshes - assert(X%mesh%shape%degree==1) - nodes => ele_nodes(X, ele) - - ! we seek local coords xi[1:dim+1] s.t. \sum_i X_i xi_i = X - ! (where X_i are the vertex locations and X is the location we search for) - ! the last local coordinate can be expressed as xi_{dim+1} = 1 - \sum_{i=1}^dim xi_i - ! so that we can write X as a function of the first 1:dim local coordinates xi only: - ! X(xi[1:dim]) = \sum_{i=1}^dim X_i xi_i + X_dim (1 - \sum_{i=1}^dim xi_i) - ! = [X_i - X_dim] xi[1:dim] + X_dim - ! where [X_i-X_dim] is a dim X dim matrix that we can obtain from J = dX/dxi (seeing X as a function - ! of the first 1:dim local coordinates only). Therefore: - ! xi = J^{-1} X-X_dim - - ! the Js and invJ used above are actually the transpose, so we use invJ^T * (X-X_dim) = (X-X_dim)^T invJ - local_coords(1:dim) = matmul(position-node_val(X, nodes(dim+1)), invJ_cache(:, :, ele)) - ! and the final local coordinate, using \sum_i xi_i=1 - local_coords(dim+1) = 1.0 - sum(local_coords(1:dim)) - else - call local_coords_slow - end if - - contains + contains subroutine local_coords_slow() - real, dimension(mesh_dim(X) + 1, size(position) + 1) :: matrix - real, dimension(mesh_dim(X), size(position) + 1) :: tmp_matrix - integer, dimension(X%mesh%shape%numbering%vertices):: vertices - - ! the slow way: invert a matrix each time - ! NOTE that for nonlinear meshes, we linearize using the vertex positions only - nodes => ele_nodes(X, ele) - vertices=local_vertices(X%mesh%shape%numbering) - tmp_matrix = node_val(X, nodes(vertices) ) - matrix(1:dim, :) = tmp_matrix - matrix(dim+1, :) = 1.0 - - local_coords(1:dim) = position - local_coords(dim+1) = 1.0 - call solve(matrix, local_coords) + real, dimension(mesh_dim(X) + 1, size(position) + 1) :: matrix + real, dimension(mesh_dim(X), size(position) + 1) :: tmp_matrix + integer, dimension(X%mesh%shape%numbering%vertices):: vertices + + ! the slow way: invert a matrix each time + ! NOTE that for nonlinear meshes, we linearize using the vertex positions only + nodes => ele_nodes(X, ele) + vertices=local_vertices(X%mesh%shape%numbering) + tmp_matrix = node_val(X, nodes(vertices) ) + matrix(1:dim, :) = tmp_matrix + matrix(dim+1, :) = 1.0 + + local_coords(1:dim) = position + local_coords(dim+1) = 1.0 + call solve(matrix, local_coords) end subroutine local_coords_slow - end function local_coords_interpolation + end function local_coords_interpolation end module transform_elements diff --git a/femtools/Unify_meshes.F90 b/femtools/Unify_meshes.F90 index f0c559f239..bd56621849 100644 --- a/femtools/Unify_meshes.F90 +++ b/femtools/Unify_meshes.F90 @@ -28,160 +28,160 @@ module unify_meshes_module - use fldebug - use fields_data_types - use fields_base - use fields_allocates - use fields_manipulation, only: set, remap_field, set_ele_nodes - implicit none - - interface unify_meshes - module procedure unify_meshes_linear - end interface - - private - - public :: unify_meshes, unify_meshes_quadratic - - contains - - function unify_meshes_linear(meshes) result(union) - type(vector_field), intent(in), dimension(:) :: meshes - type(vector_field) :: union - integer :: mesh, nodes - integer :: total_elements, ele_accum - integer :: ele_mesh, i - type(mesh_type) :: union_mesh - integer :: loc - integer, dimension(:), pointer :: old_nodes - integer, dimension(ele_loc(meshes(1), 1)) :: new_nodes - - total_elements = 0 - do mesh=1,size(meshes) - total_elements = total_elements + ele_count(meshes(mesh)) - end do - loc = ele_loc(meshes(1), 1) - nodes = total_elements * loc - - call allocate(union_mesh, nodes, total_elements, meshes(1)%mesh%shape, "AccumulatedMesh") - union_mesh%continuity = -1 - if (associated(meshes(1)%mesh%region_ids)) then - allocate(union_mesh%region_ids(total_elements)) - end if - call allocate(union, meshes(1)%dim, union_mesh, "AccumulatedPositions") - call deallocate(union_mesh) - - ele_accum = 1 - - do mesh=1,size(meshes) - assert(continuity(meshes(mesh)) < 0) - assert(ele_loc(meshes(mesh), 1) == loc) - if (associated(union%mesh%region_ids)) then - assert(associated(meshes(mesh)%mesh%region_ids)) - union%mesh%region_ids(ele_accum:ele_accum + ele_count(meshes(mesh))-1) = meshes(mesh)%mesh%region_ids + use fldebug + use fields_data_types + use fields_base + use fields_allocates + use fields_manipulation, only: set, remap_field, set_ele_nodes + implicit none + + interface unify_meshes + module procedure unify_meshes_linear + end interface + + private + + public :: unify_meshes, unify_meshes_quadratic + +contains + + function unify_meshes_linear(meshes) result(union) + type(vector_field), intent(in), dimension(:) :: meshes + type(vector_field) :: union + integer :: mesh, nodes + integer :: total_elements, ele_accum + integer :: ele_mesh, i + type(mesh_type) :: union_mesh + integer :: loc + integer, dimension(:), pointer :: old_nodes + integer, dimension(ele_loc(meshes(1), 1)) :: new_nodes + + total_elements = 0 + do mesh=1,size(meshes) + total_elements = total_elements + ele_count(meshes(mesh)) + end do + loc = ele_loc(meshes(1), 1) + nodes = total_elements * loc + + call allocate(union_mesh, nodes, total_elements, meshes(1)%mesh%shape, "AccumulatedMesh") + union_mesh%continuity = -1 + if (associated(meshes(1)%mesh%region_ids)) then + allocate(union_mesh%region_ids(total_elements)) end if + call allocate(union, meshes(1)%dim, union_mesh, "AccumulatedPositions") + call deallocate(union_mesh) + + ele_accum = 1 + + do mesh=1,size(meshes) + assert(continuity(meshes(mesh)) < 0) + assert(ele_loc(meshes(mesh), 1) == loc) + if (associated(union%mesh%region_ids)) then + assert(associated(meshes(mesh)%mesh%region_ids)) + union%mesh%region_ids(ele_accum:ele_accum + ele_count(meshes(mesh))-1) = meshes(mesh)%mesh%region_ids + end if + + do ele_mesh=1,ele_count(meshes(mesh)) + new_nodes = (/ (i, i=loc * (ele_accum-1)+1,loc*ele_accum) /) + call set_ele_nodes(union%mesh, ele_accum, new_nodes) + + old_nodes => ele_nodes(meshes(mesh), ele_mesh) + do i=1,size(old_nodes) + call set(union, new_nodes(i), node_val(meshes(mesh), old_nodes(i))) + end do + + ele_accum = ele_accum + 1 + end do + end do - do ele_mesh=1,ele_count(meshes(mesh)) - new_nodes = (/ (i, i=loc * (ele_accum-1)+1,loc*ele_accum) /) - call set_ele_nodes(union%mesh, ele_accum, new_nodes) + end function unify_meshes_linear + + subroutine unify_meshes_quadratic(posA, posB, posC) + ! Given two volume-disjoint discontinuous positions fields, + ! unify them together. For example, this is useful for + ! stitching together the supermesh. + ! For now, we assume the element types (triangles/quads etc) + ! are the same. + type(vector_field), intent(in) :: posA, posB + type(vector_field), intent(out) :: posC + + type(mesh_type) :: meshA, meshB, meshC, tmp_meshC + type(vector_field) :: lposA, lposB + + integer :: eles, nodes + integer :: ele, ele_accum, node_accum, i + integer, dimension(:), pointer :: old_nodes + integer, dimension(ele_loc(posA, 1)) :: new_nodes + + ewrite(1,*) "Warning! This algorithm is quadratic" + + if (continuity(posA) < 0) then + meshA = posA%mesh + call incref(meshA) + lposA = posA + call incref(lposA) + else + meshA = make_mesh(posA%mesh, posA%mesh%shape, -1, 'DiscontinuousVersion') + call allocate(lposA, posA%dim, meshA, "DiscontinuousPosA") + call remap_field(posA, lposA) + end if - old_nodes => ele_nodes(meshes(mesh), ele_mesh) - do i=1,size(old_nodes) - call set(union, new_nodes(i), node_val(meshes(mesh), old_nodes(i))) - end do + if (continuity(posB) < 0) then + meshB = posB%mesh + call incref(meshB) + lposB = posB + call incref(lposB) + else + meshB = make_mesh(posB%mesh, posB%mesh%shape, -1, 'DiscontinuousVersion') + call allocate(lposB, posB%dim, meshB, "DiscontinuousPosA") + call remap_field(posB, lposB) + end if - ele_accum = ele_accum + 1 - end do - end do - - end function unify_meshes_linear - - subroutine unify_meshes_quadratic(posA, posB, posC) - ! Given two volume-disjoint discontinuous positions fields, - ! unify them together. For example, this is useful for - ! stitching together the supermesh. - ! For now, we assume the element types (triangles/quads etc) - ! are the same. - type(vector_field), intent(in) :: posA, posB - type(vector_field), intent(out) :: posC - - type(mesh_type) :: meshA, meshB, meshC, tmp_meshC - type(vector_field) :: lposA, lposB - - integer :: eles, nodes - integer :: ele, ele_accum, node_accum, i - integer, dimension(:), pointer :: old_nodes - integer, dimension(ele_loc(posA, 1)) :: new_nodes - - ewrite(1,*) "Warning! This algorithm is quadratic" - - if (continuity(posA) < 0) then - meshA = posA%mesh - call incref(meshA) - lposA = posA - call incref(lposA) - else - meshA = make_mesh(posA%mesh, posA%mesh%shape, -1, 'DiscontinuousVersion') - call allocate(lposA, posA%dim, meshA, "DiscontinuousPosA") - call remap_field(posA, lposA) - end if - - if (continuity(posB) < 0) then - meshB = posB%mesh - call incref(meshB) - lposB = posB - call incref(lposB) - else - meshB = make_mesh(posB%mesh, posB%mesh%shape, -1, 'DiscontinuousVersion') - call allocate(lposB, posB%dim, meshB, "DiscontinuousPosA") - call remap_field(posB, lposB) - end if - - eles = ele_count(lposA) + ele_count(lposB) - nodes = node_count(lposA) + node_count(lposB) - call allocate(tmp_meshC, nodes, eles, posA%mesh%shape, "AccumulatedMesh") - meshC = make_mesh(tmp_meshC, tmp_meshC%shape, -1, "DiscontinuousAccumulatedMesh") - call deallocate(tmp_meshC) - - if (associated(meshA%region_ids) .and. associated(meshB%region_ids)) then - allocate(meshC%region_ids(eles)) - meshC%region_ids(1:ele_count(lposA)) = meshA%region_ids - meshC%region_ids(ele_count(lposA)+1:) = meshB%region_ids - end if - - call allocate(posC, posA%dim, meshC, "AccumulatedPositions") - - ! Now fill in the ndglno and the positions. - ele_accum = 1 - node_accum = 1 - do ele=1,ele_count(lposA) - new_nodes = (/ (i, i=posA%mesh%shape%loc * (ele_accum-1)+1,posA%mesh%shape%loc*ele_accum) /) - call set_ele_nodes(meshC, ele_accum, new_nodes) - - old_nodes => ele_nodes(lposA, ele) - do i=1,size(old_nodes) - call set(posC, new_nodes(i), node_val(lposA, old_nodes(i))) - end do + eles = ele_count(lposA) + ele_count(lposB) + nodes = node_count(lposA) + node_count(lposB) + call allocate(tmp_meshC, nodes, eles, posA%mesh%shape, "AccumulatedMesh") + meshC = make_mesh(tmp_meshC, tmp_meshC%shape, -1, "DiscontinuousAccumulatedMesh") + call deallocate(tmp_meshC) - ele_accum = ele_accum + 1 - end do - do ele=1,ele_count(lposB) - new_nodes = (/ (i, i=posA%mesh%shape%loc * (ele_accum-1)+1,posA%mesh%shape%loc*ele_accum) /) - call set_ele_nodes(meshC, ele_accum, new_nodes) + if (associated(meshA%region_ids) .and. associated(meshB%region_ids)) then + allocate(meshC%region_ids(eles)) + meshC%region_ids(1:ele_count(lposA)) = meshA%region_ids + meshC%region_ids(ele_count(lposA)+1:) = meshB%region_ids + end if + + call allocate(posC, posA%dim, meshC, "AccumulatedPositions") + + ! Now fill in the ndglno and the positions. + ele_accum = 1 + node_accum = 1 + do ele=1,ele_count(lposA) + new_nodes = (/ (i, i=posA%mesh%shape%loc * (ele_accum-1)+1,posA%mesh%shape%loc*ele_accum) /) + call set_ele_nodes(meshC, ele_accum, new_nodes) - old_nodes => ele_nodes(lposB, ele) - do i=1,size(old_nodes) - call set(posC, new_nodes(i), node_val(lposB, old_nodes(i))) + old_nodes => ele_nodes(lposA, ele) + do i=1,size(old_nodes) + call set(posC, new_nodes(i), node_val(lposA, old_nodes(i))) + end do + + ele_accum = ele_accum + 1 end do + do ele=1,ele_count(lposB) + new_nodes = (/ (i, i=posA%mesh%shape%loc * (ele_accum-1)+1,posA%mesh%shape%loc*ele_accum) /) + call set_ele_nodes(meshC, ele_accum, new_nodes) + + old_nodes => ele_nodes(lposB, ele) + do i=1,size(old_nodes) + call set(posC, new_nodes(i), node_val(lposB, old_nodes(i))) + end do - ele_accum = ele_accum + 1 - end do + ele_accum = ele_accum + 1 + end do - call deallocate(meshC) + call deallocate(meshC) - call deallocate(meshA) - call deallocate(meshB) - call deallocate(lposA) - call deallocate(lposB) - end subroutine unify_meshes_quadratic + call deallocate(meshA) + call deallocate(meshB) + call deallocate(lposA) + call deallocate(lposB) + end subroutine unify_meshes_quadratic end module unify_meshes_module diff --git a/femtools/Unittest_tools.F90 b/femtools/Unittest_tools.F90 index a5c8157d0a..16f19e6d53 100644 --- a/femtools/Unittest_tools.F90 +++ b/femtools/Unittest_tools.F90 @@ -2,455 +2,455 @@ module unittest_tools !!< This module contains utility functions for the unit testing framework. - use fldebug - use vector_tools - use reference_counting - use sparse_tools - implicit none + use fldebug + use vector_tools + use reference_counting + use sparse_tools + implicit none + + private + public operator(.flt.), operator(.fgt.), operator(.feq.), operator(.fne.), & + fequals, fnequals, write_vector, report_test, write_matrix, & + is_nan, mat_is_symmetric, mat_zero, mat_diag, random_vector, random_matrix, & + random_symmetric_matrix, random_posdef_matrix, random_sparse_matrix, & + get_mat_diag, get_matrix_identity, mat_clean, vec_clean, flt, fgt, & + report_test_no_references + + interface operator(.flt.) + module procedure flt_op + end interface + + interface operator(.fgt.) + module procedure fgt_op + end interface + + interface operator(.feq.) + module procedure fequals_scalar_op, fequals_array_op, fequals_array_scalar_op, fequals_matrix_op, fequals_matrix_scalar_op + end interface + + interface operator(.fne.) + module procedure fne_scalar_op, fne_array_op, fne_array_scalar_op, fne_matrix_op, fne_matrix_scalar_op + end interface + + interface fequals + module procedure fequals_scalar, fequals_array, fequals_array_scalar, fequals_matrix, fequals_matrix_scalar, dcsr_fequals + end interface + + interface fnequals + module procedure fne_scalar, fne_array, fne_array_scalar, fne_matrix, fne_matrix_scalar + end interface + + interface write_vector + module procedure write_vector_real, write_vector_integer + end interface + +contains + + subroutine report_test(title, fail, warn, msg) + !!< This is the subroutine used by unit tests to report the output of + !!< a test case. + + !! Title: the name of the test case. + character(len=*), intent(in) :: title + !! Msg: an explanatory message printed if the test case fails. + character(len=*), intent(in) :: msg + !! Has the test case failed, or triggered a warning? Set fail or warn to .true. if so. + logical, intent(in) :: fail, warn + + if (fail) then + print "('Fail: ',a,'; error: ',a)", title, msg + else if (warn) then + print "('Warn: ',a,'; error: ',a)", title, msg + else + print "('Pass: ',a)", title + end if - private - public operator(.flt.), operator(.fgt.), operator(.feq.), operator(.fne.), & - fequals, fnequals, write_vector, report_test, write_matrix, & - is_nan, mat_is_symmetric, mat_zero, mat_diag, random_vector, random_matrix, & - random_symmetric_matrix, random_posdef_matrix, random_sparse_matrix, & - get_mat_diag, get_matrix_identity, mat_clean, vec_clean, flt, fgt, & - report_test_no_references + end subroutine report_test - interface operator(.flt.) - module procedure flt_op - end interface + subroutine report_test_no_references() + !!< Report the output of a test for the absence of references - interface operator(.fgt.) - module procedure fgt_op - end interface + logical :: fail - interface operator(.feq.) - module procedure fequals_scalar_op, fequals_array_op, fequals_array_scalar_op, fequals_matrix_op, fequals_matrix_scalar_op - end interface + fail = associated(refcount_list%next) - interface operator(.fne.) - module procedure fne_scalar_op, fne_array_op, fne_array_scalar_op, fne_matrix_op, fne_matrix_scalar_op - end interface + call report_test("[No references]", fail, .false., "Have references remaining") + if(fail) then + ewrite(0, *) "References remaining:" + call print_references(0) + end if - interface fequals - module procedure fequals_scalar, fequals_array, fequals_array_scalar, fequals_matrix, fequals_matrix_scalar, dcsr_fequals - end interface + end subroutine report_test_no_references - interface fnequals - module procedure fne_scalar, fne_array, fne_array_scalar, fne_matrix, fne_matrix_scalar - end interface + pure function fequals_scalar_op(float1, float2) result(equals) + real, intent(in) :: float1 + real, intent(in) :: float2 - interface write_vector - module procedure write_vector_real, write_vector_integer - end interface + logical :: equals - contains + equals = fequals(float1, float2) - subroutine report_test(title, fail, warn, msg) - !!< This is the subroutine used by unit tests to report the output of - !!< a test case. + end function fequals_scalar_op - !! Title: the name of the test case. - character(len=*), intent(in) :: title - !! Msg: an explanatory message printed if the test case fails. - character(len=*), intent(in) :: msg - !! Has the test case failed, or triggered a warning? Set fail or warn to .true. if so. - logical, intent(in) :: fail, warn + pure function fne_scalar_op(float1, float2) result(nequals) + real, intent(in) :: float1 + real, intent(in) :: float2 - if (fail) then - print "('Fail: ',a,'; error: ',a)", title, msg - else if (warn) then - print "('Warn: ',a,'; error: ',a)", title, msg - else - print "('Pass: ',a)", title - end if + logical :: nequals - end subroutine report_test + nequals = .not. (float1 .feq. float2) - subroutine report_test_no_references() - !!< Report the output of a test for the absence of references + end function fne_scalar_op - logical :: fail + pure function fequals_array_op(array1, array2) result(equals) + real, dimension(:), intent(in) :: array1 + real, dimension(size(array1)), intent(in) :: array2 - fail = associated(refcount_list%next) + logical :: equals - call report_test("[No references]", fail, .false., "Have references remaining") - if(fail) then - ewrite(0, *) "References remaining:" - call print_references(0) - end if + equals = fequals(array1, array2) - end subroutine report_test_no_references + end function fequals_array_op - pure function fequals_scalar_op(float1, float2) result(equals) - real, intent(in) :: float1 - real, intent(in) :: float2 + pure function fne_array_op(array1, array2) result(nequals) + real, intent(in), dimension(:) :: array1, array2 - logical :: equals + logical :: nequals - equals = fequals(float1, float2) + nequals = .not. fequals(array1, array2) - end function fequals_scalar_op + end function fne_array_op - pure function fne_scalar_op(float1, float2) result(nequals) - real, intent(in) :: float1 - real, intent(in) :: float2 + pure function fequals_array_scalar_op(array1, float2) result(equals) + real, dimension(:), intent(in) :: array1 + real, intent(in) :: float2 - logical :: nequals + logical :: equals - nequals = .not. (float1 .feq. float2) + equals = fequals(array1, float2) - end function fne_scalar_op + end function fequals_array_scalar_op - pure function fequals_array_op(array1, array2) result(equals) - real, dimension(:), intent(in) :: array1 - real, dimension(size(array1)), intent(in) :: array2 + pure function fne_array_scalar_op(array1, float2) result(nequals) + real, dimension(:), intent(in) :: array1 + real, intent(in) :: float2 - logical :: equals + logical :: nequals - equals = fequals(array1, array2) + nequals = .not. fequals(array1, float2) - end function fequals_array_op + end function fne_array_scalar_op - pure function fne_array_op(array1, array2) result(nequals) - real, intent(in), dimension(:) :: array1, array2 + pure function fequals_matrix_op(mat1, mat2) result(equals) + real, dimension(:, :), intent(in) :: mat1 + real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 - logical :: nequals + logical :: equals - nequals = .not. fequals(array1, array2) + equals = fequals(mat1, mat2) - end function fne_array_op + end function fequals_matrix_op - pure function fequals_array_scalar_op(array1, float2) result(equals) - real, dimension(:), intent(in) :: array1 - real, intent(in) :: float2 + pure function fne_matrix_op(mat1, mat2) result (nequals) + real, dimension(:, :), intent(in) :: mat1 + real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 - logical :: equals + logical :: nequals - equals = fequals(array1, float2) + nequals = fnequals(mat1, mat2) - end function fequals_array_scalar_op + end function fne_matrix_op - pure function fne_array_scalar_op(array1, float2) result(nequals) - real, dimension(:), intent(in) :: array1 - real, intent(in) :: float2 + pure function fequals_matrix_scalar_op(mat1, float2) result(equals) + real, dimension(:, :), intent(in) :: mat1 + real, intent(in) :: float2 - logical :: nequals + logical :: equals - nequals = .not. fequals(array1, float2) + equals = fequals(mat1, float2) - end function fne_array_scalar_op + end function fequals_matrix_scalar_op - pure function fequals_matrix_op(mat1, mat2) result(equals) - real, dimension(:, :), intent(in) :: mat1 - real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 + pure function fne_matrix_scalar_op(mat1, float2) result (nequals) + real, dimension(:, :), intent(in) :: mat1 + real, intent(in) :: float2 - logical :: equals + logical :: nequals - equals = fequals(mat1, mat2) + nequals = fnequals(mat1, float2) - end function fequals_matrix_op + end function fne_matrix_scalar_op - pure function fne_matrix_op(mat1, mat2) result (nequals) - real, dimension(:, :), intent(in) :: mat1 - real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 + pure function fequals_scalar(float1, float2, tol) result(equals) + !!< This function checks if float1 == float2, to within tol (or + !!< 100.0 * epsilon(0.0) if tol is not set). + real, intent(in) :: float1 + real, intent(in) :: float2 + real, intent(in), optional :: tol - logical :: nequals + logical :: equals - nequals = fnequals(mat1, mat2) + real :: eps - end function fne_matrix_op + if(present(tol)) then + eps = tol + else + eps = 100.0 * epsilon(0.0) + end if - pure function fequals_matrix_scalar_op(mat1, float2) result(equals) - real, dimension(:, :), intent(in) :: mat1 - real, intent(in) :: float2 + equals = abs(float1 - float2) < max(eps, abs(float1) * eps) - logical :: equals + end function fequals_scalar - equals = fequals(mat1, float2) + pure function fne_scalar(float1, float2, tol) result(nequals) + real, intent(in) :: float1 + real, intent(in) :: float2 + real, optional, intent(in) :: tol - end function fequals_matrix_scalar_op + logical :: nequals - pure function fne_matrix_scalar_op(mat1, float2) result (nequals) - real, dimension(:, :), intent(in) :: mat1 - real, intent(in) :: float2 + nequals = .not. fequals(float1, float2, tol = tol) - logical :: nequals + end function fne_scalar - nequals = fnequals(mat1, float2) + pure function fequals_array(array1, array2, tol) result (equals) + real, dimension(:), intent(in) :: array1 + real, dimension(size(array1)), intent(in) :: array2 + real, intent(in), optional :: tol - end function fne_matrix_scalar_op + logical :: equals - pure function fequals_scalar(float1, float2, tol) result(equals) - !!< This function checks if float1 == float2, to within tol (or - !!< 100.0 * epsilon(0.0) if tol is not set). - real, intent(in) :: float1 - real, intent(in) :: float2 - real, intent(in), optional :: tol + integer :: i - logical :: equals + equals = .true. + do i=1,size(array1) + if (.not. fequals(array1(i), array2(i), tol)) then + equals = .false. + return + end if + end do - real :: eps + end function fequals_array - if(present(tol)) then - eps = tol - else - eps = 100.0 * epsilon(0.0) - end if + pure function fne_array(array1, array2, tol) result(nequals) + !!< floating point not equals + real, dimension(:), intent(in) :: array1 + real, dimension(size(array1)), intent(in) :: array2 + real, intent(in), optional :: tol - equals = abs(float1 - float2) < max(eps, abs(float1) * eps) + logical :: nequals - end function fequals_scalar + nequals = .not. fequals(array1, array2, tol) - pure function fne_scalar(float1, float2, tol) result(nequals) - real, intent(in) :: float1 - real, intent(in) :: float2 - real, optional, intent(in) :: tol + end function fne_array - logical :: nequals + pure function fequals_array_scalar(array1, float2, tol) result(equals) + real, dimension(:), intent(in) :: array1 + real, intent(in) :: float2 + real, intent(in), optional :: tol - nequals = .not. fequals(float1, float2, tol = tol) + logical :: equals - end function fne_scalar + integer :: i + + do i = 1, size(array1) + if(.not. fequals(array1(i), float2, tol = tol)) then + equals = .false. + return + end if + end do - pure function fequals_array(array1, array2, tol) result (equals) - real, dimension(:), intent(in) :: array1 - real, dimension(size(array1)), intent(in) :: array2 - real, intent(in), optional :: tol + equals = .true. - logical :: equals + end function fequals_array_scalar - integer :: i + pure function fne_array_scalar(array1, float2, tol) result(nequals) + real, dimension(:), intent(in) :: array1 + real, intent(in) :: float2 + real, intent(in), optional :: tol - equals = .true. - do i=1,size(array1) - if (.not. fequals(array1(i), array2(i), tol)) then - equals = .false. - return - end if - end do + logical :: nequals - end function fequals_array + nequals = .not. fequals(array1, float2, tol = tol) - pure function fne_array(array1, array2, tol) result(nequals) - !!< floating point not equals - real, dimension(:), intent(in) :: array1 - real, dimension(size(array1)), intent(in) :: array2 - real, intent(in), optional :: tol + end function fne_array_scalar - logical :: nequals + pure function fequals_matrix(mat1, mat2, tol) result(equals) + real, dimension(:, :), intent(in) :: mat1 + real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 + real, optional, intent(in) :: tol - nequals = .not. fequals(array1, array2, tol) + logical :: equals - end function fne_array + integer :: i - pure function fequals_array_scalar(array1, float2, tol) result(equals) - real, dimension(:), intent(in) :: array1 - real, intent(in) :: float2 - real, intent(in), optional :: tol + do i = 1, size(mat1, 1) + if(fnequals(mat1(i, :), mat2(i, :), tol = tol)) then + equals = .false. + return + end if + end do - logical :: equals + equals = .true. - integer :: i + end function fequals_matrix - do i = 1, size(array1) - if(.not. fequals(array1(i), float2, tol = tol)) then - equals = .false. - return - end if - end do + pure function fne_matrix(mat1, mat2, tol) result (nequals) + real, dimension(:, :), intent(in) :: mat1 + real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 + real, optional, intent(in) :: tol + + logical :: nequals + + nequals = .not. fequals(mat1, mat2, tol = tol) - equals = .true. + end function fne_matrix - end function fequals_array_scalar + pure function fequals_matrix_scalar(mat1, float2, tol) result(equals) + real, dimension(:, :), intent(in) :: mat1 + real, intent(in) :: float2 + real, optional, intent(in) :: tol - pure function fne_array_scalar(array1, float2, tol) result(nequals) - real, dimension(:), intent(in) :: array1 - real, intent(in) :: float2 - real, intent(in), optional :: tol + logical :: equals + + integer :: i + + do i = 1, size(mat1, 1) + if(fnequals(mat1(i, :), float2, tol = tol)) then + equals = .false. + return + end if + end do - logical :: nequals + equals = .true. - nequals = .not. fequals(array1, float2, tol = tol) + end function fequals_matrix_scalar - end function fne_array_scalar + pure function fne_matrix_scalar(mat1, float2, tol) result (nequals) + real, dimension(:, :), intent(in) :: mat1 + real, intent(in) :: float2 + real, optional, intent(in) :: tol - pure function fequals_matrix(mat1, mat2, tol) result(equals) - real, dimension(:, :), intent(in) :: mat1 - real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 - real, optional, intent(in) :: tol + logical :: nequals - logical :: equals + nequals = .not. fequals(mat1, float2, tol = tol) - integer :: i + end function fne_matrix_scalar - do i = 1, size(mat1, 1) - if(fnequals(mat1(i, :), mat2(i, :), tol = tol)) then - equals = .false. - return + function dcsr_fequals(A, B, tol) + !!< Checks if the dynamic matrices A and B are the same + logical dcsr_fequals + type(dynamic_csr_matrix), intent(in):: A, B + real, intent(in), optional :: tol + + integer, dimension(:), pointer:: cols + integer i, j + + if (size(A,1)/=size(B,1) .or. size(A,2)/=size(B,2)) then + dcsr_fequals=.false. + return end if - end do - equals = .true. + do i=1, size(A,1) + cols => row_m_ptr(A, i) + if (size(cols)/=row_length(B,i)) then + dcsr_fequals=.false. + return + end if + + do j=1, size(cols) + if (.not. & + fequals( val(A, i, cols(j)), val(B, i, cols(j)) , tol) & + ) then + dcsr_fequals=.false. + return + end if + end do + end do - end function fequals_matrix + dcsr_fequals=.true. - pure function fne_matrix(mat1, mat2, tol) result (nequals) - real, dimension(:, :), intent(in) :: mat1 - real, dimension(size(mat1, 1), size(mat1, 2)), intent(in) :: mat2 - real, optional, intent(in) :: tol + end function dcsr_fequals - logical :: nequals + function flt_op(float1, float2) result(less_than) + real, intent(in) :: float1, float2 + logical :: less_than - nequals = .not. fequals(mat1, mat2, tol = tol) + less_than = flt(float1, float2) + end function flt_op - end function fne_matrix + function fgt_op(float1, float2) result(greater_than) + real, intent(in) :: float1, float2 + logical :: greater_than - pure function fequals_matrix_scalar(mat1, float2, tol) result(equals) - real, dimension(:, :), intent(in) :: mat1 - real, intent(in) :: float2 - real, optional, intent(in) :: tol + greater_than = fgt(float1, float2) + end function fgt_op - logical :: equals + function flt(float1, float2, tol) result(less_than) + !!< This function checks if float1 < float2, to within tol (or + !!< 100.0 * epsilon(0.0) if tol is not set). + real, intent(in) :: float1, float2 + real :: eps + real, intent(in), optional :: tol + logical :: less_than - integer :: i + if (present(tol)) then + eps = tol + else + eps = 100.0 * epsilon(0.0) + end if - do i = 1, size(mat1, 1) - if(fnequals(mat1(i, :), float2, tol = tol)) then - equals = .false. - return + less_than = .false. + if (float1 < float2) then + if (abs(float1 - float2) > eps) less_than = .true. end if - end do - equals = .true. + end function flt - end function fequals_matrix_scalar + function fgt(float1, float2, tol) result(greater_than) + !!< This function checks if float1 > float2, to within tol (or + !!< 100.0 * epsilon(0.0) if tol is not set). + real, intent(in) :: float1, float2 + real :: eps + real, intent(in), optional :: tol + logical :: greater_than - pure function fne_matrix_scalar(mat1, float2, tol) result (nequals) - real, dimension(:, :), intent(in) :: mat1 - real, intent(in) :: float2 - real, optional, intent(in) :: tol + if (present(tol)) then + eps = tol + else + eps = 100.0 * epsilon(0.0) + end if - logical :: nequals + greater_than = .false. + if (float1 > float2) then + if (abs(float1 - float2) > eps) greater_than = .true. + end if - nequals = .not. fequals(mat1, float2, tol = tol) + end function fgt - end function fne_matrix_scalar + elemental function is_nan(x) result(nan) + !! Check if a number is NaN. Should be safe to use with aggressive optimisations. + !! Additional information can be found at: + !! https://stackoverflow.com/q/35638400/10640534 + !! https://stackoverflow.com/q/17389958/10640534 + !! + !! @note ieee_is_nan(val) or the older check val /= val are always + !! optimised to .false. whenever finite math optimisations are ebaled - function dcsr_fequals(A, B, tol) - !!< Checks if the dynamic matrices A and B are the same - logical dcsr_fequals - type(dynamic_csr_matrix), intent(in):: A, B - real, intent(in), optional :: tol + real, intent(in) :: x + logical :: nan - integer, dimension(:), pointer:: cols - integer i, j + nan = (.not. (x <= huge(x) .and. x >= -huge(x))) .and. (.not. abs(x) > huge(x)) - if (size(A,1)/=size(B,1) .or. size(A,2)/=size(B,2)) then - dcsr_fequals=.false. - return - end if + end function is_nan - do i=1, size(A,1) - cols => row_m_ptr(A, i) - if (size(cols)/=row_length(B,i)) then - dcsr_fequals=.false. - return - end if + function mat_is_symmetric(mat) result(symmetric) + !!< This function checks if mat is a symmetric matrix. + real, dimension(:, :), intent(in) :: mat + logical :: symmetric + real, dimension(size(mat, 1), size(mat, 1)) :: tmp - do j=1, size(cols) - if (.not. & - fequals( val(A, i, cols(j)), val(B, i, cols(j)) , tol) & - ) then - dcsr_fequals=.false. - return - end if - end do - end do - - dcsr_fequals=.true. - - end function dcsr_fequals - - function flt_op(float1, float2) result(less_than) - real, intent(in) :: float1, float2 - logical :: less_than - - less_than = flt(float1, float2) - end function flt_op - - function fgt_op(float1, float2) result(greater_than) - real, intent(in) :: float1, float2 - logical :: greater_than - - greater_than = fgt(float1, float2) - end function fgt_op - - function flt(float1, float2, tol) result(less_than) - !!< This function checks if float1 < float2, to within tol (or - !!< 100.0 * epsilon(0.0) if tol is not set). - real, intent(in) :: float1, float2 - real :: eps - real, intent(in), optional :: tol - logical :: less_than - - if (present(tol)) then - eps = tol - else - eps = 100.0 * epsilon(0.0) - end if - - less_than = .false. - if (float1 < float2) then - if (abs(float1 - float2) > eps) less_than = .true. - end if - - end function flt - - function fgt(float1, float2, tol) result(greater_than) - !!< This function checks if float1 > float2, to within tol (or - !!< 100.0 * epsilon(0.0) if tol is not set). - real, intent(in) :: float1, float2 - real :: eps - real, intent(in), optional :: tol - logical :: greater_than - - if (present(tol)) then - eps = tol - else - eps = 100.0 * epsilon(0.0) - end if - - greater_than = .false. - if (float1 > float2) then - if (abs(float1 - float2) > eps) greater_than = .true. - end if - - end function fgt - - elemental function is_nan(x) result(nan) - !! Check if a number is NaN. Should be safe to use with aggressive optimisations. - !! Additional information can be found at: - !! https://stackoverflow.com/q/35638400/10640534 - !! https://stackoverflow.com/q/17389958/10640534 - !! - !! @note ieee_is_nan(val) or the older check val /= val are always - !! optimised to .false. whenever finite math optimisations are ebaled - - real, intent(in) :: x - logical :: nan - - nan = (.not. (x <= huge(x) .and. x >= -huge(x))) .and. (.not. abs(x) > huge(x)) - - end function is_nan - - function mat_is_symmetric(mat) result(symmetric) - !!< This function checks if mat is a symmetric matrix. - real, dimension(:, :), intent(in) :: mat - logical :: symmetric - real, dimension(size(mat, 1), size(mat, 1)) :: tmp - - symmetric = .false. + symmetric = .false. ! do i=1,size(mat,1) ! do j=1,size(mat,2) ! if (.not. fequals(mat(i, j), mat(j, i))) then @@ -459,158 +459,158 @@ function mat_is_symmetric(mat) result(symmetric) ! end do ! end do - if (.not. symmetric) then - tmp = mat - transpose(mat) - if (mat_zero(tmp,1e-3)) symmetric = .true. - end if - end function mat_is_symmetric - - function mat_zero(mat, tol) result(zero) - !!< This function checks if mat is zero. - !!< It does this by computing the Frobenius norm of the matrix. - - real, dimension(:, :), intent(in) :: mat - real, optional :: tol - real :: ltol - logical :: zero - real :: frobenius - integer :: i, j - - if (present(tol)) then - ltol = tol - else - ltol = 100.0 * epsilon(0.0) - end if - - zero = .false. - frobenius = 0.0 - - do i=1,size(mat,1) - do j=1,size(mat,2) - frobenius = frobenius + mat(i, j) * mat(i, j) - end do - end do - - frobenius = sqrt(frobenius) - - if (frobenius .lt. ltol) zero = .true. - end function mat_zero - - function mat_diag(mat) result(diag) - !!< This function checks if the matrix is diagonal; that is, - !!< all non-diagonal entries are zero. (For my purposes the zero - !!< matrix is diagonal, for example.) - - real, dimension(:, :), intent(in) :: mat - logical :: diag - integer :: i, j - - diag = .true. - - do i=1,size(mat, 1) - do j=1,size(mat, 2) - if (i == j) cycle - if (.not. fequals(mat(i, j), 0.0)) then - diag = .false. - exit - end if + if (.not. symmetric) then + tmp = mat - transpose(mat) + if (mat_zero(tmp,1e-3)) symmetric = .true. + end if + end function mat_is_symmetric + + function mat_zero(mat, tol) result(zero) + !!< This function checks if mat is zero. + !!< It does this by computing the Frobenius norm of the matrix. + + real, dimension(:, :), intent(in) :: mat + real, optional :: tol + real :: ltol + logical :: zero + real :: frobenius + integer :: i, j + + if (present(tol)) then + ltol = tol + else + ltol = 100.0 * epsilon(0.0) + end if + + zero = .false. + frobenius = 0.0 + + do i=1,size(mat,1) + do j=1,size(mat,2) + frobenius = frobenius + mat(i, j) * mat(i, j) + end do end do - end do - end function mat_diag + frobenius = sqrt(frobenius) + + if (frobenius .lt. ltol) zero = .true. + end function mat_zero - function random_vector(dim) result(vec) - !!< This function generates a random vector of dimension dim. + function mat_diag(mat) result(diag) + !!< This function checks if the matrix is diagonal; that is, + !!< all non-diagonal entries are zero. (For my purposes the zero + !!< matrix is diagonal, for example.) - integer, intent(in) :: dim - real, dimension(dim) :: vec - real :: rand - integer :: i + real, dimension(:, :), intent(in) :: mat + logical :: diag + integer :: i, j - do i=1,dim - call random_number(rand) - vec(i) = rand - end do - end function random_vector + diag = .true. - function random_matrix(dim) result(mat) - !!< This function generates a random matrix of dimension dim. + do i=1,size(mat, 1) + do j=1,size(mat, 2) + if (i == j) cycle + if (.not. fequals(mat(i, j), 0.0)) then + diag = .false. + exit + end if + end do + end do + + end function mat_diag - integer, intent(in) :: dim - real, dimension(dim, dim) :: mat - real :: rand - integer :: i, j + function random_vector(dim) result(vec) + !!< This function generates a random vector of dimension dim. - do i=1,dim - do j=1,dim - call random_number(rand) - mat(i, j) = rand + integer, intent(in) :: dim + real, dimension(dim) :: vec + real :: rand + integer :: i + + do i=1,dim + call random_number(rand) + vec(i) = rand end do - end do - end function random_matrix - - function random_symmetric_matrix(dim) result(mat) - !!< This function generates a random symmetric matrix of dimension dim. - - integer, intent(in) :: dim - real, dimension(dim, dim) :: mat - real :: rand - integer :: i, j - - do i=1,dim - call random_number(rand) - mat(i, i) = rand - end do - - do i=1,dim - do j=i+1,dim - call random_number(rand) - mat(i, j) = rand; mat(j, i) = rand + end function random_vector + + function random_matrix(dim) result(mat) + !!< This function generates a random matrix of dimension dim. + + integer, intent(in) :: dim + real, dimension(dim, dim) :: mat + real :: rand + integer :: i, j + + do i=1,dim + do j=1,dim + call random_number(rand) + mat(i, j) = rand + end do end do - end do + end function random_matrix - end function random_symmetric_matrix + function random_symmetric_matrix(dim) result(mat) + !!< This function generates a random symmetric matrix of dimension dim. - function random_posdef_matrix(dim) result(mat) - !!< This function generates a random symmetric positive definite matrix of dimension dim. + integer, intent(in) :: dim + real, dimension(dim, dim) :: mat + real :: rand + integer :: i, j - integer, intent(in) :: dim - real, dimension(dim, dim) :: mat, evecs - real, dimension(dim) :: evals - integer :: i + do i=1,dim + call random_number(rand) + mat(i, i) = rand + end do + + do i=1,dim + do j=i+1,dim + call random_number(rand) + mat(i, j) = rand; mat(j, i) = rand + end do + end do + + end function random_symmetric_matrix + + function random_posdef_matrix(dim) result(mat) + !!< This function generates a random symmetric positive definite matrix of dimension dim. + + integer, intent(in) :: dim + real, dimension(dim, dim) :: mat, evecs + real, dimension(dim) :: evals + integer :: i - mat = random_symmetric_matrix(dim) - call eigendecomposition_symmetric(mat, evecs, evals) - do i=1,dim - evals(i) = max(0.1, abs(evals(i))) - end do - call eigenrecomposition(mat, evecs, evals) + mat = random_symmetric_matrix(dim) + call eigendecomposition_symmetric(mat, evecs, evals) + do i=1,dim + evals(i) = max(0.1, abs(evals(i))) + end do + call eigenrecomposition(mat, evecs, evals) - end function random_posdef_matrix + end function random_posdef_matrix - function random_sparse_matrix(rows, cols, nnz) result(mat) + function random_sparse_matrix(rows, cols, nnz) result(mat) !!< This function returns a random rows x cols sparse_matrix !!< with at most nnz entries. - type(dynamic_csr_matrix) mat - integer, intent(in):: rows, cols, nnz + type(dynamic_csr_matrix) mat + integer, intent(in):: rows, cols, nnz integer i, row, col real val, rand call allocate(mat, rows, cols) do i=1, nnz - call random_number(rand) - row=floor(rand*rows)+1 - call random_number(rand) - col=floor(rand*cols)+1 - call random_number(rand) - val=(rand-0.5)*1e10 - call set(mat, row, col, val) + call random_number(rand) + row=floor(rand*rows)+1 + call random_number(rand) + col=floor(rand*cols)+1 + call random_number(rand) + val=(rand-0.5)*1e10 + call set(mat, row, col, val) end do - end function random_sparse_matrix + end function random_sparse_matrix - function get_mat_diag(vec) result(mat) + function get_mat_diag(vec) result(mat) !!< This function returns the matrix whose diagonal is vec. real, dimension(:), intent(in) :: vec @@ -619,11 +619,11 @@ function get_mat_diag(vec) result(mat) mat = 0.0 do i=1,size(vec) - mat(i, i) = vec(i) + mat(i, i) = vec(i) end do - end function get_mat_diag + end function get_mat_diag - function get_matrix_identity(dim) result(id) + function get_matrix_identity(dim) result(id) !!< Return the identity matrix integer, intent(in) :: dim real, dimension(dim, dim) :: id @@ -631,63 +631,63 @@ function get_matrix_identity(dim) result(id) id = 0.0 do i=1,dim - id(i, i) = 1.0 + id(i, i) = 1.0 end do - end function - - subroutine mat_clean(mat, tol) - !!< This subroutine goes through the matrix mat - !!< and replaces any values less than tol with 0.0. - !!< The spurious numerical errors (on the order of 1e-20) - !!< can cause problems with the eigenvalue decomposition. - real, dimension(:, :), intent(inout) :: mat - real, intent(in) :: tol - integer :: i, j - - do i=1,size(mat, 1) - do j=1,size(mat, 2) - if (abs(mat(i, j)) .lt. tol) mat(i, j) = 0.0 + end function + + subroutine mat_clean(mat, tol) + !!< This subroutine goes through the matrix mat + !!< and replaces any values less than tol with 0.0. + !!< The spurious numerical errors (on the order of 1e-20) + !!< can cause problems with the eigenvalue decomposition. + real, dimension(:, :), intent(inout) :: mat + real, intent(in) :: tol + integer :: i, j + + do i=1,size(mat, 1) + do j=1,size(mat, 2) + if (abs(mat(i, j)) .lt. tol) mat(i, j) = 0.0 + end do end do - end do - end subroutine mat_clean - - subroutine vec_clean(vec, tol) - !!< This routine does the same as mat_clean, but for a vector instead. - real, dimension(:), intent(inout) :: vec - real, intent(in) :: tol - integer :: i - - do i=1,size(vec) - if (abs(vec(i)) .lt. tol) vec(i) = 0.0 - end do - end subroutine vec_clean - - subroutine write_matrix(mat, namestr) - real, dimension(:, :), intent(in) :: mat - character(len=*), intent(in) :: namestr - - integer :: i - - write(0,'(a)') namestr // ":" - do i=1,size(mat,1) - write(0,'(3e28.20)') mat(i, :) - end do - end subroutine write_matrix - - subroutine write_vector_real(rvec, namestr) - real, dimension(:), intent(in) :: rvec - character(len=*), intent(in) :: namestr - - write(0, '(a)') namestr // ":" - write(0,'(3e28.20)') rvec - end subroutine write_vector_real - - subroutine write_vector_integer(ivec, namestr) - integer, dimension(:), intent(in) :: ivec - character(len=*), intent(in) :: namestr - - write(0, '(a)') namestr // ":" - write(0,'(i14)') ivec - end subroutine write_vector_integer + end subroutine mat_clean + + subroutine vec_clean(vec, tol) + !!< This routine does the same as mat_clean, but for a vector instead. + real, dimension(:), intent(inout) :: vec + real, intent(in) :: tol + integer :: i + + do i=1,size(vec) + if (abs(vec(i)) .lt. tol) vec(i) = 0.0 + end do + end subroutine vec_clean + + subroutine write_matrix(mat, namestr) + real, dimension(:, :), intent(in) :: mat + character(len=*), intent(in) :: namestr + + integer :: i + + write(0,'(a)') namestr // ":" + do i=1,size(mat,1) + write(0,'(3e28.20)') mat(i, :) + end do + end subroutine write_matrix + + subroutine write_vector_real(rvec, namestr) + real, dimension(:), intent(in) :: rvec + character(len=*), intent(in) :: namestr + + write(0, '(a)') namestr // ":" + write(0,'(3e28.20)') rvec + end subroutine write_vector_real + + subroutine write_vector_integer(ivec, namestr) + integer, dimension(:), intent(in) :: ivec + character(len=*), intent(in) :: namestr + + write(0, '(a)') namestr // ":" + write(0,'(i14)') ivec + end subroutine write_vector_integer end module unittest_tools diff --git a/femtools/VTK_interfaces.F90 b/femtools/VTK_interfaces.F90 index 1fa3210d26..26748d51be 100644 --- a/femtools/VTK_interfaces.F90 +++ b/femtools/VTK_interfaces.F90 @@ -27,186 +27,186 @@ #include "fdebug.h" module vtk_interfaces - ! This module exists purely to provide explicit interfaces to - ! libvtkfortran. It provides generic interfaces which ensure that the - ! calls work in both single and double precision. - - use fldebug - use global_parameters, only : FIELD_NAME_LEN - use futils, only: present_and_true, int2str - use quadrature - use elements - use mpi_interfaces - use parallel_tools - use spud - use data_structures - use sparse_tools - use global_numbering - use fetools, only: X_,Y_,Z_ - use parallel_fields - use fields - use state_module - use vtkfortran - - implicit none - - private - - public :: vtk_write_state, vtk_write_fields, vtk_read_state, & - vtk_write_surface_mesh, vtk_write_internal_face_mesh, & - vtk_get_sizes, vtk_read_file, vtk_mesh2fluidity_numbering, fluidity_mesh2vtk_numbering - - interface - subroutine vtk_read_file(& - filename, namelen, nnod, nelm, szenls,& - nfield_components, nprop_components,& - nfields, nproperties, & - ndimensions, maxnamelen, & - x, y, z, & - field_components, prop_components, & - fields, properties,& - enlbas, enlist, field_names, prop_names) - implicit none - character*(*) filename - integer namelen, nnod, nelm, szenls - integer nfield_components, nprop_components, nfields, nproperties - integer ndimensions, maxnamelen - real x(nnod), y(nnod), z(nnod) - integer field_components(nfields), prop_components(nproperties) - real fields(nnod,nfields), & + ! This module exists purely to provide explicit interfaces to + ! libvtkfortran. It provides generic interfaces which ensure that the + ! calls work in both single and double precision. + + use fldebug + use global_parameters, only : FIELD_NAME_LEN + use futils, only: present_and_true, int2str + use quadrature + use elements + use mpi_interfaces + use parallel_tools + use spud + use data_structures + use sparse_tools + use global_numbering + use fetools, only: X_,Y_,Z_ + use parallel_fields + use fields + use state_module + use vtkfortran + + implicit none + + private + + public :: vtk_write_state, vtk_write_fields, vtk_read_state, & + vtk_write_surface_mesh, vtk_write_internal_face_mesh, & + vtk_get_sizes, vtk_read_file, vtk_mesh2fluidity_numbering, fluidity_mesh2vtk_numbering + + interface + subroutine vtk_read_file(& + filename, namelen, nnod, nelm, szenls,& + nfield_components, nprop_components,& + nfields, nproperties, & + ndimensions, maxnamelen, & + x, y, z, & + field_components, prop_components, & + fields, properties,& + enlbas, enlist, field_names, prop_names) + implicit none + character*(*) filename + integer namelen, nnod, nelm, szenls + integer nfield_components, nprop_components, nfields, nproperties + integer ndimensions, maxnamelen + real x(nnod), y(nnod), z(nnod) + integer field_components(nfields), prop_components(nproperties) + real fields(nnod,nfields), & properties(nelm,nproperties) - integer enlbas(nelm+1), enlist(szenls) - character(len=maxnamelen) field_names(nfields) - character(len=maxnamelen) prop_names(nproperties) - end subroutine vtk_read_file - end interface - - interface - subroutine vtk_get_sizes( filename, namelen, nnod, nelm, szenls, & - nfield_components, nprop_components, & - nfields, nproperties, ndimensions, maxnamelen ) - implicit none - character*(*) filename - integer namelen - integer nnod, nelm, szenls - integer nfield_components, nprop_components - integer nfields, nproperties, ndimensions, maxnamelen - end subroutine vtk_get_sizes - end interface - - interface vtkwritecellghostarray - subroutine vtkwritecellghostarray(ghosts) - implicit none - integer ghosts(*) - end subroutine vtkwritecellghostarray - end interface + integer enlbas(nelm+1), enlist(szenls) + character(len=maxnamelen) field_names(nfields) + character(len=maxnamelen) prop_names(nproperties) + end subroutine vtk_read_file + end interface + + interface + subroutine vtk_get_sizes( filename, namelen, nnod, nelm, szenls, & + nfield_components, nprop_components, & + nfields, nproperties, ndimensions, maxnamelen ) + implicit none + character*(*) filename + integer namelen + integer nnod, nelm, szenls + integer nfield_components, nprop_components + integer nfields, nproperties, ndimensions, maxnamelen + end subroutine vtk_get_sizes + end interface + + interface vtkwritecellghostarray + subroutine vtkwritecellghostarray(ghosts) + implicit none + integer ghosts(*) + end subroutine vtkwritecellghostarray + end interface contains - subroutine vtk_write_state(filename, index, model, state, write_region_ids, write_columns, stat) - !!< Write the state variables out to a vtu file. Two different elements - !!< are supported along with fields corresponding to each of them. - !!< - !!< All the fields will be promoted/reduced to the degree of model and - !!< all elements will be discontinuous (which is required for the - !!< promotion/reduction to be general). - implicit none - character(len=*), intent(in) :: filename !! Base filename with no - !!< trailing _number.vtu - integer, intent(in), optional :: index !! Index number of dump for filename. - character(len=*), intent(in), optional :: model - type(state_type), dimension(:), intent(in) :: state - logical, intent(in), optional :: write_region_ids - logical, intent(in), optional :: write_columns - integer, intent(out), optional :: stat - type(mesh_type), pointer :: model_mesh - - ! It is necessary to make local copies of the fields lists because of - ! the pointer storage mechanism in state - type(scalar_field), dimension(:), allocatable :: lsfields - type(vector_field), dimension(:), allocatable :: lvfields - type(tensor_field), dimension(:), allocatable :: ltfields - integer :: i, f, counter, size_lsfields, size_lvfields, size_ltfields - character(len=FIELD_NAME_LEN) :: mesh_name - - if (present(model)) then - model_mesh => extract_mesh(state(1), model) - else if (have_option("/io/output_mesh")) then - ! use the one specified by the options tree: - call get_option("/io/output_mesh[0]/name", mesh_name) - model_mesh => extract_mesh(state(1), trim(mesh_name)) - else if (mesh_count(state(1))==1) then - ! if there's only one mesh, use that: - model_mesh => extract_mesh(state(1), 1) - else - ewrite(-1,*) "In vtk_write_state:" - FLExit("Don't know which mesh to use as model.") - end if - - size_lsfields = 0 - do i = 1, size(state) - if (associated(state(i)%scalar_fields)) then - size_lsfields = size_lsfields + size(state(i)%scalar_fields) - end if - end do - - allocate(lsfields(size_lsfields)) - counter = 0 - do i = 1, size(state) - if (associated(state(i)%scalar_fields)) then - do f = 1, size(state(i)%scalar_fields) - counter = counter + 1 - lsfields(counter)=state(i)%scalar_fields(f)%ptr - if (size(state) > 1) then - lsfields(counter)%name = trim(state(i)%name)//'::'//trim(lsfields(counter)%name) - end if - end do + subroutine vtk_write_state(filename, index, model, state, write_region_ids, write_columns, stat) + !!< Write the state variables out to a vtu file. Two different elements + !!< are supported along with fields corresponding to each of them. + !!< + !!< All the fields will be promoted/reduced to the degree of model and + !!< all elements will be discontinuous (which is required for the + !!< promotion/reduction to be general). + implicit none + character(len=*), intent(in) :: filename !! Base filename with no + !!< trailing _number.vtu + integer, intent(in), optional :: index !! Index number of dump for filename. + character(len=*), intent(in), optional :: model + type(state_type), dimension(:), intent(in) :: state + logical, intent(in), optional :: write_region_ids + logical, intent(in), optional :: write_columns + integer, intent(out), optional :: stat + type(mesh_type), pointer :: model_mesh + + ! It is necessary to make local copies of the fields lists because of + ! the pointer storage mechanism in state + type(scalar_field), dimension(:), allocatable :: lsfields + type(vector_field), dimension(:), allocatable :: lvfields + type(tensor_field), dimension(:), allocatable :: ltfields + integer :: i, f, counter, size_lsfields, size_lvfields, size_ltfields + character(len=FIELD_NAME_LEN) :: mesh_name + + if (present(model)) then + model_mesh => extract_mesh(state(1), model) + else if (have_option("/io/output_mesh")) then + ! use the one specified by the options tree: + call get_option("/io/output_mesh[0]/name", mesh_name) + model_mesh => extract_mesh(state(1), trim(mesh_name)) + else if (mesh_count(state(1))==1) then + ! if there's only one mesh, use that: + model_mesh => extract_mesh(state(1), 1) + else + ewrite(-1,*) "In vtk_write_state:" + FLExit("Don't know which mesh to use as model.") end if - end do - size_lvfields = 0 - do i = 1, size(state) - if (associated(state(i)%vector_fields)) then - size_lvfields = size_lvfields + size(state(i)%vector_fields) - end if - end do - - allocate(lvfields(size_lvfields)) - counter = 0 - do i = 1, size(state) - if (associated(state(i)%vector_fields)) then - do f = 1, size(state(i)%vector_fields) - counter = counter + 1 - lvfields(counter) = state(i)%vector_fields(f)%ptr - if (size(state) > 1) then - lvfields(counter)%name = trim(state(i)%name)//'::'//trim(lvfields(counter)%name) - end if - end do - end if - end do + size_lsfields = 0 + do i = 1, size(state) + if (associated(state(i)%scalar_fields)) then + size_lsfields = size_lsfields + size(state(i)%scalar_fields) + end if + end do - size_ltfields = 0 - do i = 1, size(state) - if (associated(state(i)%tensor_fields)) then - size_ltfields = size_ltfields + size(state(i)%tensor_fields) - end if - end do - - allocate(ltfields(size_ltfields)) - counter = 0 - do i = 1, size(state) - if (associated(state(i)%tensor_fields)) then - do f = 1, size(state(i)%tensor_fields) - counter = counter + 1 - ltfields(counter) = state(i)%tensor_fields(f)%ptr - if (size(state) > 1) then - ltfields(counter)%name = trim(state(i)%name)//'::'//trim(ltfields(counter)%name) - end if - end do - end if - end do + allocate(lsfields(size_lsfields)) + counter = 0 + do i = 1, size(state) + if (associated(state(i)%scalar_fields)) then + do f = 1, size(state(i)%scalar_fields) + counter = counter + 1 + lsfields(counter)=state(i)%scalar_fields(f)%ptr + if (size(state) > 1) then + lsfields(counter)%name = trim(state(i)%name)//'::'//trim(lsfields(counter)%name) + end if + end do + end if + end do + + size_lvfields = 0 + do i = 1, size(state) + if (associated(state(i)%vector_fields)) then + size_lvfields = size_lvfields + size(state(i)%vector_fields) + end if + end do + + allocate(lvfields(size_lvfields)) + counter = 0 + do i = 1, size(state) + if (associated(state(i)%vector_fields)) then + do f = 1, size(state(i)%vector_fields) + counter = counter + 1 + lvfields(counter) = state(i)%vector_fields(f)%ptr + if (size(state) > 1) then + lvfields(counter)%name = trim(state(i)%name)//'::'//trim(lvfields(counter)%name) + end if + end do + end if + end do - call vtk_write_fields(filename, index, & + size_ltfields = 0 + do i = 1, size(state) + if (associated(state(i)%tensor_fields)) then + size_ltfields = size_ltfields + size(state(i)%tensor_fields) + end if + end do + + allocate(ltfields(size_ltfields)) + counter = 0 + do i = 1, size(state) + if (associated(state(i)%tensor_fields)) then + do f = 1, size(state(i)%tensor_fields) + counter = counter + 1 + ltfields(counter) = state(i)%tensor_fields(f)%ptr + if (size(state) > 1) then + ltfields(counter)%name = trim(state(i)%name)//'::'//trim(ltfields(counter)%name) + end if + end do + end if + end do + + call vtk_write_fields(filename, index, & extract_vector_field(state(1), "Coordinate"), & model_mesh, & sfields=lsfields, & @@ -216,1108 +216,1108 @@ subroutine vtk_write_state(filename, index, model, state, write_region_ids, writ write_columns=write_columns, & stat=stat) - end subroutine vtk_write_state - - subroutine vtk_write_fields(filename, index, position, model, sfields,& - & vfields, tfields, write_region_ids, write_columns, number_of_partitions, stat) - !!< Write the state variables out to a vtu file. Two different elements - !!< are supported along with fields corresponding to each of them. - !!< - !!< All the fields will be promoted/reduced to the degree of model and - !!< all elements will be discontinuous (which is required for the - !!< promotion/reduction to be general). - implicit none - - character(len=*), intent(in) :: filename ! Base filename with no - ! trailing _number.vtu - integer, intent(in), optional :: index ! Index number of dump for filename. - type(vector_field), intent(in) :: position - type(mesh_type), intent(in) :: model - type(scalar_field), dimension(:), intent(in), optional :: sfields - type(vector_field), dimension(:), intent(in), optional :: vfields - type(tensor_field), dimension(:), intent(in), optional :: tfields - logical, intent(in), optional :: write_region_ids - logical, intent(in), optional :: write_columns - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions - integer, intent(out), optional :: stat - - integer :: NNod, sz_enlist, i, dim, j, k, nparts - real, dimension(:,:,:), allocatable, target :: t_field_buffer, tensor_values - real, dimension(:,:), allocatable, target :: v_field_buffer - real, dimension(:), allocatable, target :: field_buffer - integer, dimension(:), allocatable, target :: ndglno, ENList, ELsize, ELType - character(len=FIELD_NAME_LEN) :: dumpnum - type(mesh_type) :: model_mesh - type(scalar_field) :: l_model - type(vector_field) :: v_model(3) - type(tensor_field) :: t_model - logical :: dgify_fields ! should we DG-ify the fields -- make them discontinous? - integer, allocatable, dimension(:) :: ghosts - real, allocatable, dimension(:,:) :: tempval - integer :: lstat - - if (present(stat)) stat = 0 - - dgify_fields = .false. - if (present(sfields)) then - do i=1,size(sfields) - if ( (sfields(i)%mesh%continuity .lt. 0 .and. sfields(i)%mesh%shape%degree /= 0) ) dgify_fields = .true. - end do - end if - if (present(vfields)) then - do i=1,size(vfields) - if ( (vfields(i)%mesh%continuity .lt. 0 .and. vfields(i)%mesh%shape%degree /= 0) ) dgify_fields = .true. - end do - end if - if (present(tfields)) then - do i=1,size(tfields) - if ( (tfields(i)%mesh%continuity .lt. 0 .and. tfields(i)%mesh%shape%degree /= 0) ) dgify_fields = .true. - end do - end if - - if (present(number_of_partitions)) then - nparts = number_of_partitions - else - nparts = getnprocs() - end if - - if(model%shape%degree /= 0) then - - ! Note that the following fails for variable element types. - sz_enlist = element_count(model)*ele_loc(model, 1) - - allocate(ndglno(sz_enlist),ENList(sz_enlist), ELsize(element_count(model)),ELtype(element_count(model))) - - if (dgify_fields.and.(continuity(model)>=0)) then - - ! Note that the following fails for variable element types. - NNod=sz_enlist - - allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) - v_field_buffer=0.0 - - call make_global_numbering_DG(NNod, ndglno, element_count(model),& - & ele_shape(model,1)) - - ! Discontinuous version of model. - model_mesh=wrap_mesh(ndglno, ele_shape(model,1), "DGIfiedModelMesh") - ! Fix bug in gfortran - model_mesh%shape=ele_shape(model,1) - ! this mesh is discontinuous - model_mesh%continuity = -1 - if (associated(model%region_ids)) then - allocate(model_mesh%region_ids(ele_count(model_mesh))) - model_mesh%region_ids = model%region_ids - end if - ! Copy element_halos to ensure values for the vtk CellGhostArray are output - if (associated(model%element_halos)) then - allocate(model_mesh%element_halos(size(model%element_halos))) - do i = 1, size(model_mesh%element_halos) - call allocate(model_mesh%element_halos(i), model%element_halos(i)) - end do - end if - else - - NNod=node_count(model) - allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) - v_field_buffer=0.0 - - model_mesh = model - ! Grab an extra reference to make the deallocate at the end safe. - call incref(model_mesh) - ndglno = model%ndglno(1:sz_enlist) + end subroutine vtk_write_state + + subroutine vtk_write_fields(filename, index, position, model, sfields,& + & vfields, tfields, write_region_ids, write_columns, number_of_partitions, stat) + !!< Write the state variables out to a vtu file. Two different elements + !!< are supported along with fields corresponding to each of them. + !!< + !!< All the fields will be promoted/reduced to the degree of model and + !!< all elements will be discontinuous (which is required for the + !!< promotion/reduction to be general). + implicit none + + character(len=*), intent(in) :: filename ! Base filename with no + ! trailing _number.vtu + integer, intent(in), optional :: index ! Index number of dump for filename. + type(vector_field), intent(in) :: position + type(mesh_type), intent(in) :: model + type(scalar_field), dimension(:), intent(in), optional :: sfields + type(vector_field), dimension(:), intent(in), optional :: vfields + type(tensor_field), dimension(:), intent(in), optional :: tfields + logical, intent(in), optional :: write_region_ids + logical, intent(in), optional :: write_columns + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions + integer, intent(out), optional :: stat + + integer :: NNod, sz_enlist, i, dim, j, k, nparts + real, dimension(:,:,:), allocatable, target :: t_field_buffer, tensor_values + real, dimension(:,:), allocatable, target :: v_field_buffer + real, dimension(:), allocatable, target :: field_buffer + integer, dimension(:), allocatable, target :: ndglno, ENList, ELsize, ELType + character(len=FIELD_NAME_LEN) :: dumpnum + type(mesh_type) :: model_mesh + type(scalar_field) :: l_model + type(vector_field) :: v_model(3) + type(tensor_field) :: t_model + logical :: dgify_fields ! should we DG-ify the fields -- make them discontinous? + integer, allocatable, dimension(:) :: ghosts + real, allocatable, dimension(:,:) :: tempval + integer :: lstat + + if (present(stat)) stat = 0 + + dgify_fields = .false. + if (present(sfields)) then + do i=1,size(sfields) + if ( (sfields(i)%mesh%continuity .lt. 0 .and. sfields(i)%mesh%shape%degree /= 0) ) dgify_fields = .true. + end do end if - else - ! if the model mesh is p/q0 then use the position mesh to output the mesh - - ! Note that the following fails for variable element types. - sz_enlist = element_count(position%mesh)*ele_loc(position%mesh, 1) - - allocate(ndglno(sz_enlist),ENList(sz_enlist), ELsize(element_count(model)),ELtype(element_count(model))) - - if(dgify_fields) then - - ! Note that the following fails for variable element types. - NNod=sz_enlist - - allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) - v_field_buffer=0.0 - - call make_global_numbering_DG(NNod, ndglno, element_count(position%mesh),& - & ele_shape(position%mesh,1)) - ! Discontinuous version of position mesh. - model_mesh=wrap_mesh(ndglno, ele_shape(position%mesh,1), "") - ! Fix bug in gfortran - model_mesh%shape=ele_shape(position%mesh,1) - ! this mesh is discontinuous - model_mesh%continuity = -1 - if (associated(model%region_ids)) then - allocate(model_mesh%region_ids(ele_count(model_mesh))) - model_mesh%region_ids = model%region_ids - end if - else - - NNod=node_count(position%mesh) - allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) - v_field_buffer=0.0 - - model_mesh = position%mesh - ! Grab an extra reference to make the deallocate at the end safe. - call incref(model_mesh) - ndglno = position%mesh%ndglno + if (present(vfields)) then + do i=1,size(vfields) + if ( (vfields(i)%mesh%continuity .lt. 0 .and. vfields(i)%mesh%shape%degree /= 0) ) dgify_fields = .true. + end do end if - end if - - l_model= wrap_scalar_field(model_mesh, field_buffer, "TempVTKModel") - - ! vector fields may be of any dimension - do i=1, 3 - call allocate(v_model(i), i, model_mesh, name="TempVTKModel") - end do - - t_model=wrap_tensor_field(model_mesh,t_field_buffer, name="TempVTKModel") - - ! Size and type are currently uniform - ELsize=ele_loc(model_mesh,1) - ELtype=vtk_element_type(ele_shape(model_mesh,1)) - - ENList=fluidity_mesh2vtk_numbering(ndglno, ele_shape(model_mesh,1)) - - - !---------------------------------------------------------------------- - ! Open the file - !---------------------------------------------------------------------- - - if (present(index)) then - ! Write index number: - if(nparts > 1) then - write(dumpnum,"(a,i0,a)") "_",index,".pvtu" - else - write(dumpnum,"(a,i0,a)") "_",index,".vtu" - end if - else - ! If no index is provided then assume the filename was complete. - if(nparts > 1) then - if (len_trim(filename)<=4) then - dumpnum=".pvtu" - else if ((filename(len_trim(filename)-4:len_trim(filename))==".pvtu")) then - dumpnum="" - else if (filename(len_trim(filename)-3:len_trim(filename))==".vtu") then - FLAbort("Parallel vtk write - extension must be .pvtu") - else - dumpnum=".pvtu" - end if - else - if (len_trim(filename)<=3) then - dumpnum=".vtu" - else if (filename(len_trim(filename)-3:)==".vtu") then - dumpnum="" - else - dumpnum=".vtu" - end if - end if - end if - - if(getprocno() > nparts) then - return - end if - - call vtkopen(trim(filename)//trim(dumpnum),trim(filename)) - - !---------------------------------------------------------------------- - ! Output the mesh - !---------------------------------------------------------------------- - - ! Remap the position coordinates. - call remap_field(from_field=position, to_field=v_model(position%dim), stat=lstat) - ! if this is being called from something other than the main output routines - ! then these tests can be disabled by passing in the optional stat argument - ! to vtk_write_fields - if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from a discontinuous to a continuous field!") + if (present(tfields)) then + do i=1,size(tfields) + if ( (tfields(i)%mesh%continuity .lt. 0 .and. tfields(i)%mesh%shape%degree /= 0) ) dgify_fields = .true. + end do end if - else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(present(stat)) then - stat = lstat + + if (present(number_of_partitions)) then + nparts = number_of_partitions else - ewrite(-1,*) 'While outputting to vtu the coordinates were remapped from' - ewrite(-1,*) 'a continuous non-periodic to a continuous periodic mesh.' - ewrite(-1,*) 'This suggests that the output_mesh requested is periodic,' - ewrite(-1,*) 'which generally produces strange vtus.' - ewrite(-1,*) "Please switch to a non-periodic output_mesh." - FLExit("Just remapped from an unperiodic to a periodic continuous field!") + nparts = getnprocs() end if - else if ((lstat/=0).and. & - (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & - (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then - if(present(stat)) then - stat = lstat + + if(model%shape%degree /= 0) then + + ! Note that the following fails for variable element types. + sz_enlist = element_count(model)*ele_loc(model, 1) + + allocate(ndglno(sz_enlist),ENList(sz_enlist), ELsize(element_count(model)),ELtype(element_count(model))) + + if (dgify_fields.and.(continuity(model)>=0)) then + + ! Note that the following fails for variable element types. + NNod=sz_enlist + + allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) + v_field_buffer=0.0 + + call make_global_numbering_DG(NNod, ndglno, element_count(model),& + & ele_shape(model,1)) + + ! Discontinuous version of model. + model_mesh=wrap_mesh(ndglno, ele_shape(model,1), "DGIfiedModelMesh") + ! Fix bug in gfortran + model_mesh%shape=ele_shape(model,1) + ! this mesh is discontinuous + model_mesh%continuity = -1 + if (associated(model%region_ids)) then + allocate(model_mesh%region_ids(ele_count(model_mesh))) + model_mesh%region_ids = model%region_ids + end if + ! Copy element_halos to ensure values for the vtk CellGhostArray are output + if (associated(model%element_halos)) then + allocate(model_mesh%element_halos(size(model%element_halos))) + do i = 1, size(model_mesh%element_halos) + call allocate(model_mesh%element_halos(i), model%element_halos(i)) + end do + end if + else + + NNod=node_count(model) + allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) + v_field_buffer=0.0 + + model_mesh = model + ! Grab an extra reference to make the deallocate at the end safe. + call incref(model_mesh) + ndglno = model%ndglno(1:sz_enlist) + end if else - FLAbort("Unknown error when remapping coordinates while outputting to vtu.") - end if - end if - ! we've just allowed remapping from a higher order to a lower order continuous field - - ! Write the mesh coordinates. - do i=1, position%dim - v_field_buffer(:,i)=v_model(position%dim)%val(i,:) - end do - do i=position%dim+1, 3 - v_field_buffer(:,i)=0.0 - end do - call VTKWRITEMESH(node_count(model_mesh), element_count(model_mesh), & - v_field_buffer(:,X_), v_field_buffer(:,Y_), v_field_buffer(:,Z_)& - &, ENLIST, ELtype, ELsize) - - !---------------------------------------------------------------------- - ! Output scalar fields - !---------------------------------------------------------------------- - - if (present(sfields)) then - do i=1,size(sfields) - if(mesh_dim(sfields(i))/=mesh_dim(l_model)) cycle - - if (sfields(i)%mesh%shape%degree /= 0) then - - call remap_field(from_field=sfields(i), to_field=l_model, stat=lstat) - ! if this is being called from something other than the main output routines - ! then these tests can be disabled by passing in the optional stat argument - ! to vtk_write_fields - if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from a discontinuous to a continuous field!") - end if - else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from an unperiodic to a periodic continuous field!") - end if - else if ((lstat/=0).and. & - (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & - (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then - if(present(stat)) then - stat = lstat - else - FLAbort("Unknown error when remapping field.") - end if + ! if the model mesh is p/q0 then use the position mesh to output the mesh + + ! Note that the following fails for variable element types. + sz_enlist = element_count(position%mesh)*ele_loc(position%mesh, 1) + + allocate(ndglno(sz_enlist),ENList(sz_enlist), ELsize(element_count(model)),ELtype(element_count(model))) + + if(dgify_fields) then + + ! Note that the following fails for variable element types. + NNod=sz_enlist + + allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) + v_field_buffer=0.0 + + call make_global_numbering_DG(NNod, ndglno, element_count(position%mesh),& + & ele_shape(position%mesh,1)) + ! Discontinuous version of position mesh. + model_mesh=wrap_mesh(ndglno, ele_shape(position%mesh,1), "") + ! Fix bug in gfortran + model_mesh%shape=ele_shape(position%mesh,1) + ! this mesh is discontinuous + model_mesh%continuity = -1 + if (associated(model%region_ids)) then + allocate(model_mesh%region_ids(ele_count(model_mesh))) + model_mesh%region_ids = model%region_ids end if - ! we've just allowed remapping from a higher order to a lower order continuous field + else + + NNod=node_count(position%mesh) + allocate(field_buffer(NNod), v_field_buffer(NNod, 3), t_field_buffer(NNod, 3, 3)) + v_field_buffer=0.0 + + model_mesh = position%mesh + ! Grab an extra reference to make the deallocate at the end safe. + call incref(model_mesh) + ndglno = position%mesh%ndglno + end if + end if + + l_model= wrap_scalar_field(model_mesh, field_buffer, "TempVTKModel") + + ! vector fields may be of any dimension + do i=1, 3 + call allocate(v_model(i), i, model_mesh, name="TempVTKModel") + end do + + t_model=wrap_tensor_field(model_mesh,t_field_buffer, name="TempVTKModel") - call vtkwritesn(l_model%val, trim(sfields(i)%name)) + ! Size and type are currently uniform + ELsize=ele_loc(model_mesh,1) + ELtype=vtk_element_type(ele_shape(model_mesh,1)) - else + ENList=fluidity_mesh2vtk_numbering(ndglno, ele_shape(model_mesh,1)) - if(sfields(i)%field_type==FIELD_TYPE_CONSTANT) then - allocate(tempval(element_count(l_model),1)) - tempval = sfields(i)%val(1) - call vtkwritesc(tempval(:,1), trim(sfields(i)%name)) + !---------------------------------------------------------------------- + ! Open the file + !---------------------------------------------------------------------- - deallocate(tempval) + if (present(index)) then + ! Write index number: + if(nparts > 1) then + write(dumpnum,"(a,i0,a)") "_",index,".pvtu" + else + write(dumpnum,"(a,i0,a)") "_",index,".vtu" + end if + else + ! If no index is provided then assume the filename was complete. + if(nparts > 1) then + if (len_trim(filename)<=4) then + dumpnum=".pvtu" + else if ((filename(len_trim(filename)-4:len_trim(filename))==".pvtu")) then + dumpnum="" + else if (filename(len_trim(filename)-3:len_trim(filename))==".vtu") then + FLAbort("Parallel vtk write - extension must be .pvtu") else - call vtkwritesc(sfields(i)%val, trim(sfields(i)%name)) + dumpnum=".pvtu" end if - - end if - - end do - - ! set first field to be active: - if (size(sfields)>0) call vtksetactivescalars( sfields(1)%name ) - end if - - - !---------------------------------------------------------------------- - ! Output the region ids - !---------------------------------------------------------------------- - - ! You could possibly check for preserving the mesh regions here. - if (present_and_true(write_region_ids)) then - if (associated(model_mesh%region_ids)) then - call vtkwritesc(model_mesh%region_ids, "RegionIds") - end if - end if - - !---------------------------------------------------------------------- - ! Output the columns - !---------------------------------------------------------------------- - - if (present_and_true(write_columns)) then - if (associated(model_mesh%columns)) then - call vtkwritesn(model_mesh%columns, "Columns") - end if - end if - - !---------------------------------------------------------------------- - ! Output values for the vtk CellGhostArray - !---------------------------------------------------------------------- - if(element_halo_count(model_mesh) > 0) then - allocate(ghosts(element_count(model_mesh))) - ghosts = 0 - do i=1, element_count(model_mesh) - if(.not. element_owned(model, i)) ghosts(i) = 1 - end do - - call vtkwritecellghostarray(ghosts) - end if - - - !---------------------------------------------------------------------- - ! Output vector fields - !---------------------------------------------------------------------- - - if (present(vfields)) then - do i=1,size(vfields) - if(trim(vfields(i)%name)=="Coordinate") then - cycle - end if - if(mesh_dim(vfields(i))/=mesh_dim(v_model(vfields(i)%dim))) cycle - - if(vfields(i)%mesh%shape%degree /= 0) then - - call remap_field(from_field=vfields(i), to_field=v_model(vfields(i)%dim), stat=lstat) - ! if this is being called from something other than the main output routines - ! then these tests can be disabled by passing in the optional stat argument - ! to vtk_write_fields - if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from a discontinuous to a continuous field!") - end if - else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from an unperiodic to a periodic continuous field!") - end if - else if ((lstat/=0).and. & - (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & - (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then - if(present(stat)) then - stat = lstat - else - FLAbort("Unknown error when remapping field.") - end if + else + if (len_trim(filename)<=3) then + dumpnum=".vtu" + else if (filename(len_trim(filename)-3:)==".vtu") then + dumpnum="" + else + dumpnum=".vtu" end if - ! we've just allowed remapping from a higher order to a lower order continuous field + end if + end if - do k=1, vfields(i)%dim - v_field_buffer(:,k)=v_model(vfields(i)%dim)%val(k,:) - end do - do k=vfields(i)%dim+1, 3 - v_field_buffer(:,k)=0.0 - end do - call vtkwritevn(& - v_field_buffer(:,X_), v_field_buffer(:,Y_), & - v_field_buffer(:,Z_), & - trim(vfields(i)%name)) + if(getprocno() > nparts) then + return + end if - else + call vtkopen(trim(filename)//trim(dumpnum),trim(filename)) + + !---------------------------------------------------------------------- + ! Output the mesh + !---------------------------------------------------------------------- + + ! Remap the position coordinates. + call remap_field(from_field=position, to_field=v_model(position%dim), stat=lstat) + ! if this is being called from something other than the main output routines + ! then these tests can be disabled by passing in the optional stat argument + ! to vtk_write_fields + if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from a discontinuous to a continuous field!") + end if + else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(present(stat)) then + stat = lstat + else + ewrite(-1,*) 'While outputting to vtu the coordinates were remapped from' + ewrite(-1,*) 'a continuous non-periodic to a continuous periodic mesh.' + ewrite(-1,*) 'This suggests that the output_mesh requested is periodic,' + ewrite(-1,*) 'which generally produces strange vtus.' + ewrite(-1,*) "Please switch to a non-periodic output_mesh." + FLExit("Just remapped from an unperiodic to a periodic continuous field!") + end if + else if ((lstat/=0).and. & + (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & + (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then + if(present(stat)) then + stat = lstat + else + FLAbort("Unknown error when remapping coordinates while outputting to vtu.") + end if + end if + ! we've just allowed remapping from a higher order to a lower order continuous field - allocate(tempval(element_count(model_mesh),3)) + ! Write the mesh coordinates. + do i=1, position%dim + v_field_buffer(:,i)=v_model(position%dim)%val(i,:) + end do + do i=position%dim+1, 3 + v_field_buffer(:,i)=0.0 + end do + call VTKWRITEMESH(node_count(model_mesh), element_count(model_mesh), & + v_field_buffer(:,X_), v_field_buffer(:,Y_), v_field_buffer(:,Z_)& + &, ENLIST, ELtype, ELsize) + + !---------------------------------------------------------------------- + ! Output scalar fields + !---------------------------------------------------------------------- + + if (present(sfields)) then + do i=1,size(sfields) + if(mesh_dim(sfields(i))/=mesh_dim(l_model)) cycle + + if (sfields(i)%mesh%shape%degree /= 0) then + + call remap_field(from_field=sfields(i), to_field=l_model, stat=lstat) + ! if this is being called from something other than the main output routines + ! then these tests can be disabled by passing in the optional stat argument + ! to vtk_write_fields + if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from a discontinuous to a continuous field!") + end if + else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from an unperiodic to a periodic continuous field!") + end if + else if ((lstat/=0).and. & + (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & + (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then + if(present(stat)) then + stat = lstat + else + FLAbort("Unknown error when remapping field.") + end if + end if + ! we've just allowed remapping from a higher order to a lower order continuous field + + call vtkwritesn(l_model%val, trim(sfields(i)%name)) - tempval = 0.0 - if(vfields(i)%field_type==FIELD_TYPE_CONSTANT) then - do j = 1, vfields(i)%dim - tempval(:,j) = vfields(i)%val(j,1) - end do else - do j = 1, vfields(i)%dim - tempval(:,j) = vfields(i)%val(j,:) - end do + + if(sfields(i)%field_type==FIELD_TYPE_CONSTANT) then + allocate(tempval(element_count(l_model),1)) + + tempval = sfields(i)%val(1) + call vtkwritesc(tempval(:,1), trim(sfields(i)%name)) + + deallocate(tempval) + else + call vtkwritesc(sfields(i)%val, trim(sfields(i)%name)) + end if + end if - call vtkwritevc(& - tempval(:,X_), tempval(:,Y_), & - tempval(:,Z_), trim(vfields(i)%name)) + end do - deallocate(tempval) + ! set first field to be active: + if (size(sfields)>0) call vtksetactivescalars( sfields(1)%name ) + end if - end if - end do + !---------------------------------------------------------------------- + ! Output the region ids + !---------------------------------------------------------------------- - ! set first field to be active: - do i=1,size(vfields) - if(trim(vfields(i)%name)=="Coordinate") then - cycle + ! You could possibly check for preserving the mesh regions here. + if (present_and_true(write_region_ids)) then + if (associated(model_mesh%region_ids)) then + call vtkwritesc(model_mesh%region_ids, "RegionIds") end if - call vtksetactivevectors( vfields(i)%name ) - exit - end do - end if - - - !---------------------------------------------------------------------- - ! Output tensor fields - !---------------------------------------------------------------------- - - if (present(tfields)) then - - do i=1,size(tfields) - dim = tfields(i)%dim(1) - ! Can't output non-square tensors. - if(tfields(i)%dim(1)/=tfields(i)%dim(2)) cycle - - if(tfields(i)%dim(1)/=t_model%dim(1)) cycle - - if(tfields(i)%mesh%shape%degree /= 0) then - - call remap_field(from_field=tfields(i), to_field=t_model, stat=lstat) - ! if this is being called from something other than the main output routines - ! then these tests can be disabled by passing in the optional stat argument - ! to vtk_write_fields - if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from a discontinuous to a continuous field!") - end if - else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then - if(present(stat)) then - stat = lstat - else - FLAbort("Just remapped from an unperiodic to a periodic continuous field!") - end if - else if ((lstat/=0).and. & - (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & - (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then - if(present(stat)) then - stat = lstat - else - FLAbort("Unknown error when remapping field.") - end if + end if + + !---------------------------------------------------------------------- + ! Output the columns + !---------------------------------------------------------------------- + + if (present_and_true(write_columns)) then + if (associated(model_mesh%columns)) then + call vtkwritesn(model_mesh%columns, "Columns") + end if + end if + + !---------------------------------------------------------------------- + ! Output values for the vtk CellGhostArray + !---------------------------------------------------------------------- + if(element_halo_count(model_mesh) > 0) then + allocate(ghosts(element_count(model_mesh))) + ghosts = 0 + do i=1, element_count(model_mesh) + if(.not. element_owned(model, i)) ghosts(i) = 1 + end do + + call vtkwritecellghostarray(ghosts) + end if + + + !---------------------------------------------------------------------- + ! Output vector fields + !---------------------------------------------------------------------- + + if (present(vfields)) then + do i=1,size(vfields) + if(trim(vfields(i)%name)=="Coordinate") then + cycle end if - ! we've just allowed remapping from a higher order to a lower order continuous field - - allocate(tensor_values(node_count(t_model), 3, 3)) - tensor_values=0.0 - do j=1,dim - do k=1,dim - tensor_values(:, j, k) = t_model%val(j, k, :) - end do - end do + if(mesh_dim(vfields(i))/=mesh_dim(v_model(vfields(i)%dim))) cycle + + if(vfields(i)%mesh%shape%degree /= 0) then + + call remap_field(from_field=vfields(i), to_field=v_model(vfields(i)%dim), stat=lstat) + ! if this is being called from something other than the main output routines + ! then these tests can be disabled by passing in the optional stat argument + ! to vtk_write_fields + if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from a discontinuous to a continuous field!") + end if + else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from an unperiodic to a periodic continuous field!") + end if + else if ((lstat/=0).and. & + (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & + (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then + if(present(stat)) then + stat = lstat + else + FLAbort("Unknown error when remapping field.") + end if + end if + ! we've just allowed remapping from a higher order to a lower order continuous field + + do k=1, vfields(i)%dim + v_field_buffer(:,k)=v_model(vfields(i)%dim)%val(k,:) + end do + do k=vfields(i)%dim+1, 3 + v_field_buffer(:,k)=0.0 + end do + call vtkwritevn(& + v_field_buffer(:,X_), v_field_buffer(:,Y_), & + v_field_buffer(:,Z_), & + trim(vfields(i)%name)) - call vtkwritetn(tensor_values(:, 1, 1), & - tensor_values(:, 1, 2), & - tensor_values(:, 1, 3), & - tensor_values(:, 2, 1), & - tensor_values(:, 2, 2), & - tensor_values(:, 2, 3), & - tensor_values(:, 3, 1), & - tensor_values(:, 3, 2), & - tensor_values(:, 3, 3), & - trim(tfields(i)%name)) - deallocate(tensor_values) - - else - - allocate(tensor_values(element_count(t_model), 3, 3)) - tensor_values=0.0 - if(tfields(i)%field_type==FIELD_TYPE_CONSTANT) then - do j=1,dim - do k=1,dim - tensor_values(:, j, k) = tfields(i)%val(j, k, 1) - end do - end do else - do j=1,dim - do k=1,dim - tensor_values(:, j, k) = tfields(i)%val(j, k, :) - end do - end do + + allocate(tempval(element_count(model_mesh),3)) + + tempval = 0.0 + if(vfields(i)%field_type==FIELD_TYPE_CONSTANT) then + do j = 1, vfields(i)%dim + tempval(:,j) = vfields(i)%val(j,1) + end do + else + do j = 1, vfields(i)%dim + tempval(:,j) = vfields(i)%val(j,:) + end do + end if + + call vtkwritevc(& + tempval(:,X_), tempval(:,Y_), & + tempval(:,Z_), trim(vfields(i)%name)) + + deallocate(tempval) + + end if + + end do + + ! set first field to be active: + do i=1,size(vfields) + if(trim(vfields(i)%name)=="Coordinate") then + cycle end if + call vtksetactivevectors( vfields(i)%name ) + exit + end do + end if + - call vtkwritetc(tensor_values(:, 1, 1), & - tensor_values(:, 1, 2), & - tensor_values(:, 1, 3), & - tensor_values(:, 2, 1), & - tensor_values(:, 2, 2), & - tensor_values(:, 2, 3), & - tensor_values(:, 3, 1), & - tensor_values(:, 3, 2), & - tensor_values(:, 3, 3), & - trim(tfields(i)%name)) + !---------------------------------------------------------------------- + ! Output tensor fields + !---------------------------------------------------------------------- + + if (present(tfields)) then + + do i=1,size(tfields) + dim = tfields(i)%dim(1) + ! Can't output non-square tensors. + if(tfields(i)%dim(1)/=tfields(i)%dim(2)) cycle + + if(tfields(i)%dim(1)/=t_model%dim(1)) cycle + + if(tfields(i)%mesh%shape%degree /= 0) then + + call remap_field(from_field=tfields(i), to_field=t_model, stat=lstat) + ! if this is being called from something other than the main output routines + ! then these tests can be disabled by passing in the optional stat argument + ! to vtk_write_fields + if(lstat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from a discontinuous to a continuous field!") + end if + else if(lstat==REMAP_ERR_UNPERIODIC_PERIODIC) then + if(present(stat)) then + stat = lstat + else + FLAbort("Just remapped from an unperiodic to a periodic continuous field!") + end if + else if ((lstat/=0).and. & + (lstat/=REMAP_ERR_BUBBLE_LAGRANGE).and. & + (lstat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS)) then + if(present(stat)) then + stat = lstat + else + FLAbort("Unknown error when remapping field.") + end if + end if + ! we've just allowed remapping from a higher order to a lower order continuous field + + allocate(tensor_values(node_count(t_model), 3, 3)) + tensor_values=0.0 + do j=1,dim + do k=1,dim + tensor_values(:, j, k) = t_model%val(j, k, :) + end do + end do + + call vtkwritetn(tensor_values(:, 1, 1), & + tensor_values(:, 1, 2), & + tensor_values(:, 1, 3), & + tensor_values(:, 2, 1), & + tensor_values(:, 2, 2), & + tensor_values(:, 2, 3), & + tensor_values(:, 3, 1), & + tensor_values(:, 3, 2), & + tensor_values(:, 3, 3), & + trim(tfields(i)%name)) + deallocate(tensor_values) - deallocate(tensor_values) + else + + allocate(tensor_values(element_count(t_model), 3, 3)) + tensor_values=0.0 + if(tfields(i)%field_type==FIELD_TYPE_CONSTANT) then + do j=1,dim + do k=1,dim + tensor_values(:, j, k) = tfields(i)%val(j, k, 1) + end do + end do + else + do j=1,dim + do k=1,dim + tensor_values(:, j, k) = tfields(i)%val(j, k, :) + end do + end do + end if + + call vtkwritetc(tensor_values(:, 1, 1), & + tensor_values(:, 1, 2), & + tensor_values(:, 1, 3), & + tensor_values(:, 2, 1), & + tensor_values(:, 2, 2), & + tensor_values(:, 2, 3), & + tensor_values(:, 3, 1), & + tensor_values(:, 3, 2), & + tensor_values(:, 3, 3), & + trim(tfields(i)%name)) + + deallocate(tensor_values) - end if + end if - end do + end do - ! set first field to be active: - if (size(tfields)>0) call vtksetactivetensors( tfields(1)%name ) + ! set first field to be active: + if (size(tfields)>0) call vtksetactivetensors( tfields(1)%name ) - end if + end if - !---------------------------------------------------------------------- - ! Close the file - !---------------------------------------------------------------------- - call deallocate(l_model) - do i=1, 3 - call deallocate(v_model(i)) - end do - call deallocate(t_model) - call deallocate(model_mesh) + !---------------------------------------------------------------------- + ! Close the file + !---------------------------------------------------------------------- + call deallocate(l_model) + do i=1, 3 + call deallocate(v_model(i)) + end do + call deallocate(t_model) + call deallocate(model_mesh) - if(nparts > 1) then - call vtkpclose(getrank(), nparts) - else - call vtkclose() - end if + if(nparts > 1) then + call vtkpclose(getrank(), nparts) + else + call vtkclose() + end if - end subroutine vtk_write_fields + end subroutine vtk_write_fields - function fluidity_mesh2vtk_numbering(ndglno, element) result (renumber) - type(element_type), intent(in) :: element - integer, dimension(:), intent(in) :: ndglno - integer, dimension(size(ndglno)) :: renumber + function fluidity_mesh2vtk_numbering(ndglno, element) result (renumber) + type(element_type), intent(in) :: element + integer, dimension(:), intent(in) :: ndglno + integer, dimension(size(ndglno)) :: renumber - integer, dimension(element%loc) :: ele_num - integer :: i, nloc + integer, dimension(element%loc) :: ele_num + integer :: i, nloc - ele_num=vtk2fluidity_ordering(element) + ele_num=vtk2fluidity_ordering(element) - nloc=element%loc + nloc=element%loc - forall (i=1:size(ndglno)/nloc) - renumber((i-1)*nloc+1:i*nloc)=ndglno((i-1)*nloc+ele_num) - end forall + forall (i=1:size(ndglno)/nloc) + renumber((i-1)*nloc+1:i*nloc)=ndglno((i-1)*nloc+ele_num) + end forall - end function fluidity_mesh2vtk_numbering + end function fluidity_mesh2vtk_numbering - function vtk_mesh2fluidity_numbering(vtk_ndglno, element) result (fl_ndglno) - type(element_type), intent(in) :: element - integer, dimension(:), intent(in) :: vtk_ndglno - integer, dimension(size(vtk_ndglno)) :: fl_ndglno + function vtk_mesh2fluidity_numbering(vtk_ndglno, element) result (fl_ndglno) + type(element_type), intent(in) :: element + integer, dimension(:), intent(in) :: vtk_ndglno + integer, dimension(size(vtk_ndglno)) :: fl_ndglno - integer, dimension(element%loc) :: ele_num - integer :: i, nloc + integer, dimension(element%loc) :: ele_num + integer :: i, nloc - ele_num=vtk2fluidity_ordering(element) + ele_num=vtk2fluidity_ordering(element) - nloc=element%loc + nloc=element%loc - forall (i=1:size(vtk_ndglno)/nloc) - fl_ndglno((i-1)*nloc+ele_num)=vtk_ndglno((i-1)*nloc+1:i*nloc) - end forall + forall (i=1:size(vtk_ndglno)/nloc) + fl_ndglno((i-1)*nloc+ele_num)=vtk_ndglno((i-1)*nloc+1:i*nloc) + end forall - end function vtk_mesh2fluidity_numbering + end function vtk_mesh2fluidity_numbering - function vtk_element_type(element) result (type) - ! Return the vtk element type corresponding to element. - ! return 0 if no match is found. - integer :: type - type(element_type), intent(in) :: element + function vtk_element_type(element) result (type) + ! Return the vtk element type corresponding to element. + ! return 0 if no match is found. + integer :: type + type(element_type), intent(in) :: element - type=0 + type=0 - select case (element%dim) - case (1) - ! Interval elements. - select case (element%numbering%degree) - case (0) - type=VTK_VERTEX + select case (element%dim) case (1) - type=VTK_LINE - case(2) - type=VTK_QUADRATIC_EDGE - case default - ewrite(0,*) "Polynomial degree: ", element%numbering%degree - FLExit("Unsupported polynomial degree for vtk.") - end select - case(2) - select case(element%numbering%vertices) - case (3) - select case (element%numbering%degree) - case (0) - type=VTK_VERTEX - case(1) - type=VTK_TRIANGLE - case(2) - type=VTK_QUADRATIC_TRIANGLE - case default - ewrite(0,*) "Polynomial degree: ", element%numbering%degree - FLExit("Unsupported polynomial degree for vtk.") - end select - case (4) - select case (element%numbering%degree) + ! Interval elements. + select case (element%numbering%degree) case (0) - type=VTK_VERTEX - case(1) - type=VTK_QUAD + type=VTK_VERTEX + case (1) + type=VTK_LINE case(2) - type=VTK_QUADRATIC_QUAD + type=VTK_QUADRATIC_EDGE case default - ewrite(0,*) "Polynomial degree: ", element%numbering%degree - FLExit("Unsupported polynomial degree for vtk.") - end select - case default - ewrite(0,*) "Dimension: ", element%dim - ewrite(0,*) "Vertices: ", element%numbering%vertices - FLExit("Unsupported element type for vtk.") - end select - case(3) - select case(element%numbering%vertices) - case (4) - select case (element%numbering%degree) - case (0) - type=VTK_VERTEX - case(1) - type=VTK_TETRA - case(2) - type=VTK_QUADRATIC_TETRA + ewrite(0,*) "Polynomial degree: ", element%numbering%degree + FLExit("Unsupported polynomial degree for vtk.") + end select + case(2) + select case(element%numbering%vertices) + case (3) + select case (element%numbering%degree) + case (0) + type=VTK_VERTEX + case(1) + type=VTK_TRIANGLE + case(2) + type=VTK_QUADRATIC_TRIANGLE + case default + ewrite(0,*) "Polynomial degree: ", element%numbering%degree + FLExit("Unsupported polynomial degree for vtk.") + end select + case (4) + select case (element%numbering%degree) + case (0) + type=VTK_VERTEX + case(1) + type=VTK_QUAD + case(2) + type=VTK_QUADRATIC_QUAD + case default + ewrite(0,*) "Polynomial degree: ", element%numbering%degree + FLExit("Unsupported polynomial degree for vtk.") + end select case default - ewrite(0,*) "Polynomial degree: ", element%numbering%degree - FLExit("Unsupported polynomial degree for vtk.") - end select - case (8) - select case (element%numbering%degree) - case (0) - type=VTK_VERTEX - case(1) - type=VTK_HEXAHEDRON - case(2) - type=VTK_QUADRATIC_HEXAHEDRON + ewrite(0,*) "Dimension: ", element%dim + ewrite(0,*) "Vertices: ", element%numbering%vertices + FLExit("Unsupported element type for vtk.") + end select + case(3) + select case(element%numbering%vertices) + case (4) + select case (element%numbering%degree) + case (0) + type=VTK_VERTEX + case(1) + type=VTK_TETRA + case(2) + type=VTK_QUADRATIC_TETRA + case default + ewrite(0,*) "Polynomial degree: ", element%numbering%degree + FLExit("Unsupported polynomial degree for vtk.") + end select + case (8) + select case (element%numbering%degree) + case (0) + type=VTK_VERTEX + case(1) + type=VTK_HEXAHEDRON + case(2) + type=VTK_QUADRATIC_HEXAHEDRON + case default + ewrite(0,*) "Polynomial degree: ", element%numbering%degree + FLExit("Unsupported polynomial degree for vtk.") + end select case default - ewrite(0,*) "Polynomial degree: ", element%numbering%degree - FLExit("Unsupported polynomial degree for vtk.") - end select - case default - ewrite(0,*) "Dimension: ", element%dim - ewrite(0,*) "Vertices: ", element%numbering%vertices - FLExit("Unsupported element type for vtk.") - end select - case default - ewrite(0,*) "Dimension: ", element%dim - FLExit("Unsupported dimension for vtk.") - end select - - end function vtk_element_type - - function vtk2fluidity_ordering(element) result (order) - ! Return the One True Element Numbering for element relative to the VTK ordering. - ! - ! Note that the one true element numbering does not contain information - ! on chirality so transformed elements may have the oposite chirality - ! to that expected by VTK. - type(element_type), intent(in) :: element - integer, dimension(element%loc) :: order - - integer :: type - - type=vtk_element_type(element) - - order=0 - - select case(type) - case(VTK_VERTEX) - order=(/1/) - case(VTK_LINE) - order=(/1,2/) - case(VTK_QUADRATIC_EDGE) - order=(/1,3,2/) - case(VTK_TRIANGLE) - order=(/1,2,3/) - case(VTK_QUADRATIC_TRIANGLE) - order=(/1,3,6,2,5,4/) - case(VTK_QUAD) - order=(/1,2,4,3/) - case(VTK_TETRA) - order=(/1,2,3,4/) - case(VTK_QUADRATIC_TETRA) - order=(/1,3,6,10,2,5,4,7,8,9/) - case(VTK_HEXAHEDRON) - order=(/1,2,4,3,5,6,8,7/) - ! NOTE: quadratic quads and hexes are not supported as - ! vtk quadratic quads/hexes are only quadratic along the edges - ! i.e. there are no internal nodes. - case default - ewrite(0,*) "VTK element type: ", type - FLExit("Unsupported element type") - end select - - end function vtk2fluidity_ordering - - subroutine vtk_read_state(lfilename, state, quad_degree) - !!< This routine uses the vtkmeshio operations - !!< to extract mesh and field information from a VTU file. - character(len=*), intent(in) :: lfilename - type(state_type), intent(inout) :: state - integer, intent(in), optional :: quad_degree - - type(quadrature_type) :: quad - type(element_type) :: shape - type(mesh_type) :: mesh, p0_mesh - type(vector_field) :: position_field - - integer :: i - - integer :: nodes, elements, dim, sz_enlist - integer :: nfields, nprops, nfield_components, nprop_components - integer :: degree, maxnamelen - real, allocatable :: X(:), Y(:), Z(:) - real, dimension(:,:), allocatable :: fields, properties - integer, dimension(:), allocatable :: field_components, prop_components - integer, allocatable :: ENLBAS(:), NDGLNO(:) - character(len=FIELD_NAME_LEN), allocatable :: field_names(:), prop_names(:) - character(len=1024) :: filename - - integer :: nloc, quaddegree, nvertices, loc - logical :: file_exists - - call nullify(state) - - filename = trim(lfilename) - inquire(file = trim(filename), exist=file_exists) - if(.not.file_exists .and. len_trim(lfilename)>4) then - loc = scan(lfilename, "_", back=.true.) - filename(loc:loc+len_trim(lfilename)+1) = "/"//trim(lfilename) - end if - - ! needed for fgetvtksizes, to tell it to work out the dimension - dim = 0 - - call vtk_get_sizes(trim(filename), len_trim(filename), nodes, elements,& - & sz_enlist, nfield_components, nprop_components, & - & nfields, nprops, dim, maxnamelen) - - nloc = sz_enlist/elements - ! set quadrature to max available - select case(dim) - case(3) - select case (nloc) - case (4, 10) ! tets - quaddegree = 8 - case (8, 27) ! hexes - quaddegree = 7 - case default - FLAbort("Unknown element type!") + ewrite(0,*) "Dimension: ", element%dim + ewrite(0,*) "Vertices: ", element%numbering%vertices + FLExit("Unsupported element type for vtk.") + end select + case default + ewrite(0,*) "Dimension: ", element%dim + FLExit("Unsupported dimension for vtk.") end select - case(2) - select case (nloc) - case (3, 6) ! triangles - quaddegree = 8 - case (4, 9) ! quads - quaddegree = 9 - case default - FLAbort("Unknown element type!") + + end function vtk_element_type + + function vtk2fluidity_ordering(element) result (order) + ! Return the One True Element Numbering for element relative to the VTK ordering. + ! + ! Note that the one true element numbering does not contain information + ! on chirality so transformed elements may have the oposite chirality + ! to that expected by VTK. + type(element_type), intent(in) :: element + integer, dimension(element%loc) :: order + + integer :: type + + type=vtk_element_type(element) + + order=0 + + select case(type) + case(VTK_VERTEX) + order=(/1/) + case(VTK_LINE) + order=(/1,2/) + case(VTK_QUADRATIC_EDGE) + order=(/1,3,2/) + case(VTK_TRIANGLE) + order=(/1,2,3/) + case(VTK_QUADRATIC_TRIANGLE) + order=(/1,3,6,2,5,4/) + case(VTK_QUAD) + order=(/1,2,4,3/) + case(VTK_TETRA) + order=(/1,2,3,4/) + case(VTK_QUADRATIC_TETRA) + order=(/1,3,6,10,2,5,4,7,8,9/) + case(VTK_HEXAHEDRON) + order=(/1,2,4,3,5,6,8,7/) + ! NOTE: quadratic quads and hexes are not supported as + ! vtk quadratic quads/hexes are only quadratic along the edges + ! i.e. there are no internal nodes. + case default + ewrite(0,*) "VTK element type: ", type + FLExit("Unsupported element type") end select - case(1) - select case(nloc) - case(2, 3) - quaddegree = 8 ! simplices - case default - FLAbort("Unknown element type!") + + end function vtk2fluidity_ordering + + subroutine vtk_read_state(lfilename, state, quad_degree) + !!< This routine uses the vtkmeshio operations + !!< to extract mesh and field information from a VTU file. + character(len=*), intent(in) :: lfilename + type(state_type), intent(inout) :: state + integer, intent(in), optional :: quad_degree + + type(quadrature_type) :: quad + type(element_type) :: shape + type(mesh_type) :: mesh, p0_mesh + type(vector_field) :: position_field + + integer :: i + + integer :: nodes, elements, dim, sz_enlist + integer :: nfields, nprops, nfield_components, nprop_components + integer :: degree, maxnamelen + real, allocatable :: X(:), Y(:), Z(:) + real, dimension(:,:), allocatable :: fields, properties + integer, dimension(:), allocatable :: field_components, prop_components + integer, allocatable :: ENLBAS(:), NDGLNO(:) + character(len=FIELD_NAME_LEN), allocatable :: field_names(:), prop_names(:) + character(len=1024) :: filename + + integer :: nloc, quaddegree, nvertices, loc + logical :: file_exists + + call nullify(state) + + filename = trim(lfilename) + inquire(file = trim(filename), exist=file_exists) + if(.not.file_exists .and. len_trim(lfilename)>4) then + loc = scan(lfilename, "_", back=.true.) + filename(loc:loc+len_trim(lfilename)+1) = "/"//trim(lfilename) + end if + + ! needed for fgetvtksizes, to tell it to work out the dimension + dim = 0 + + call vtk_get_sizes(trim(filename), len_trim(filename), nodes, elements,& + & sz_enlist, nfield_components, nprop_components, & + & nfields, nprops, dim, maxnamelen) + + nloc = sz_enlist/elements + ! set quadrature to max available + select case(dim) + case(3) + select case (nloc) + case (4, 10) ! tets + quaddegree = 8 + case (8, 27) ! hexes + quaddegree = 7 + case default + FLAbort("Unknown element type!") + end select + case(2) + select case (nloc) + case (3, 6) ! triangles + quaddegree = 8 + case (4, 9) ! quads + quaddegree = 9 + case default + FLAbort("Unknown element type!") + end select + case(1) + select case(nloc) + case(2, 3) + quaddegree = 8 ! simplices + case default + FLAbort("Unknown element type!") + end select + case(0) + ewrite(-1, *) "For vtu filename: " // trim(filename) + FLExit("vtu not found") + case default + ewrite(-1, *) "For dimension: ", dim + FLAbort("Invalid dimension") end select - case(0) - ewrite(-1, *) "For vtu filename: " // trim(filename) - FLExit("vtu not found") - case default - ewrite(-1, *) "For dimension: ", dim - FLAbort("Invalid dimension") - end select - if (present(quad_degree)) then - quaddegree=quad_degree - end if - - allocate(X(nodes), Y(nodes), Z(nodes)) - allocate(FIELDS(nodes, nfield_components), PROPERTIES(elements, nprop_components)) - allocate(field_components(nfields), prop_components(nprops)) - allocate(ENLBAS(elements+1), NDGLNO(sz_enlist)) - allocate(field_names(nfields), prop_names(nprops)) - - do i=1, nfields - field_names(i) = ' ' - end do - do i=1, nprops - prop_names(i) = ' ' - end do - - call vtk_read_file(trim(filename), len_trim(filename), & - & nodes, elements, sz_enlist, & - & nfield_components, nprop_components, & - & nfields, nprops, dim, FIELD_NAME_LEN, & - & X, Y, Z, & - & field_components, prop_components, & - & FIELDS, PROPERTIES, & - & ENLBAS, NDGLNO, & - & field_names, prop_names) - - if (nloc == 10 .and. dim==3) then - nvertices=4 ! quadratic tets - degree=2 - else if (nloc == 6 .and. dim==2) then - nvertices=3 ! quadratic triangles - degree=2 - else if (nloc == 27 .and. dim==3) then - nvertices=8 ! quadratic hexes - degree=2 - else if (nloc == 9 .and. dim==2) then - nvertices=4 ! quadratic quads - degree=2 - else - ! linear: - nvertices=nloc - degree=1 - end if - - quad = make_quadrature(vertices=nvertices, dim=dim, degree=quaddegree) - shape = make_element_shape(vertices=nvertices, dim=dim, degree=degree, quad=quad) - call allocate(mesh, nodes, elements, shape, name="Mesh") - mesh%ndglno=vtk_mesh2fluidity_numbering(ndglno, shape) - call deallocate(shape) - ! heuristic check for discontinous meshes - if (nloc*elements==nodes .and. elements > 1) then - mesh%continuity=-1 - end if - call insert(state, mesh, "Mesh") - - call allocate(position_field, dim, mesh, name="Coordinate") - call set_all(position_field, 1, x) - if (dim>1) then - call set_all(position_field, 2, y) - end if - if (dim>2) then - call set_all(position_field, 3, z) - end if - - call insert(state, position_field, "Coordinate") - - if (nprops>0) then - ! cell-wise data is stored in the arrays properties(:,1:nprops) - ! this is returned as fields on a p0 mesh - shape = make_element_shape(vertices=nvertices, dim=dim, degree=0, quad=quad) - p0_mesh=make_mesh(mesh, shape=shape, continuity=-1, name="P0Mesh") + if (present(quad_degree)) then + quaddegree=quad_degree + end if + + allocate(X(nodes), Y(nodes), Z(nodes)) + allocate(FIELDS(nodes, nfield_components), PROPERTIES(elements, nprop_components)) + allocate(field_components(nfields), prop_components(nprops)) + allocate(ENLBAS(elements+1), NDGLNO(sz_enlist)) + allocate(field_names(nfields), prop_names(nprops)) + + do i=1, nfields + field_names(i) = ' ' + end do + do i=1, nprops + prop_names(i) = ' ' + end do + + call vtk_read_file(trim(filename), len_trim(filename), & + & nodes, elements, sz_enlist, & + & nfield_components, nprop_components, & + & nfields, nprops, dim, FIELD_NAME_LEN, & + & X, Y, Z, & + & field_components, prop_components, & + & FIELDS, PROPERTIES, & + & ENLBAS, NDGLNO, & + & field_names, prop_names) + + if (nloc == 10 .and. dim==3) then + nvertices=4 ! quadratic tets + degree=2 + else if (nloc == 6 .and. dim==2) then + nvertices=3 ! quadratic triangles + degree=2 + else if (nloc == 27 .and. dim==3) then + nvertices=8 ! quadratic hexes + degree=2 + else if (nloc == 9 .and. dim==2) then + nvertices=4 ! quadratic quads + degree=2 + else + ! linear: + nvertices=nloc + degree=1 + end if + + quad = make_quadrature(vertices=nvertices, dim=dim, degree=quaddegree) + shape = make_element_shape(vertices=nvertices, dim=dim, degree=degree, quad=quad) + call allocate(mesh, nodes, elements, shape, name="Mesh") + mesh%ndglno=vtk_mesh2fluidity_numbering(ndglno, shape) call deallocate(shape) - call insert(state, p0_mesh, name="P0Mesh") - end if + ! heuristic check for discontinous meshes + if (nloc*elements==nodes .and. elements > 1) then + mesh%continuity=-1 + end if + call insert(state, mesh, "Mesh") + + call allocate(position_field, dim, mesh, name="Coordinate") + call set_all(position_field, 1, x) + if (dim>1) then + call set_all(position_field, 2, y) + end if + if (dim>2) then + call set_all(position_field, 3, z) + end if + + call insert(state, position_field, "Coordinate") - ! insert point-wise fields - call vtk_insert_fields_in_state(state, & - mesh, field_components, fields, field_names, dim) + if (nprops>0) then + ! cell-wise data is stored in the arrays properties(:,1:nprops) + ! this is returned as fields on a p0 mesh + shape = make_element_shape(vertices=nvertices, dim=dim, degree=0, quad=quad) + p0_mesh=make_mesh(mesh, shape=shape, continuity=-1, name="P0Mesh") + call deallocate(shape) + call insert(state, p0_mesh, name="P0Mesh") + end if - if (nprops>0) then - ! insert cell-wise fields + ! insert point-wise fields call vtk_insert_fields_in_state(state, & - p0_mesh, prop_components, properties, prop_names, dim) - end if - - deallocate(enlbas, ndglno, field_names, prop_names) - deallocate(properties, fields) - deallocate(field_components, prop_components) - deallocate(x, y, z) - call deallocate(quad) - call deallocate(mesh) - if (nprops>0) call deallocate(p0_mesh) - call deallocate(position_field) - - end subroutine vtk_read_state - - subroutine vtk_insert_fields_in_state(state, & - mesh, components, fields, names, ndim) - ! insert the fields returned by vtk_read_file in state - type(state_type), intent(inout):: state - integer, dimension(:), intent(in):: components - type(mesh_type), intent(inout):: mesh - real, dimension(:,:):: fields - character(len=*), dimension(:), intent(in):: names - integer, intent(in):: ndim - - type(tensor_field):: tfield - type(vector_field):: vfield - type(scalar_field):: sfield - integer:: i, j, k, component, ndim2 - - component = 1 - do i=1, size(names) - - if (components(i)==9 .or. components(i)==4) then - - if (components(i)==9) then - ndim2=3 - else - ndim2=2 - end if - ! Let's make a tensor field, see? - call allocate(tfield, mesh, names(i)) - call zero(tfield) - do j=1, ndim2 - do k=1, ndim2 - if (j<=ndim .and. k<=ndim) then - call set_all(tfield, dim1=j, dim2=k, & - val=fields(:, component)) + mesh, field_components, fields, field_names, dim) + + if (nprops>0) then + ! insert cell-wise fields + call vtk_insert_fields_in_state(state, & + p0_mesh, prop_components, properties, prop_names, dim) + end if + + deallocate(enlbas, ndglno, field_names, prop_names) + deallocate(properties, fields) + deallocate(field_components, prop_components) + deallocate(x, y, z) + call deallocate(quad) + call deallocate(mesh) + if (nprops>0) call deallocate(p0_mesh) + call deallocate(position_field) + + end subroutine vtk_read_state + + subroutine vtk_insert_fields_in_state(state, & + mesh, components, fields, names, ndim) + ! insert the fields returned by vtk_read_file in state + type(state_type), intent(inout):: state + integer, dimension(:), intent(in):: components + type(mesh_type), intent(inout):: mesh + real, dimension(:,:):: fields + character(len=*), dimension(:), intent(in):: names + integer, intent(in):: ndim + + type(tensor_field):: tfield + type(vector_field):: vfield + type(scalar_field):: sfield + integer:: i, j, k, component, ndim2 + + component = 1 + do i=1, size(names) + + if (components(i)==9 .or. components(i)==4) then + + if (components(i)==9) then + ndim2=3 + else + ndim2=2 end if + ! Let's make a tensor field, see? + call allocate(tfield, mesh, names(i)) + call zero(tfield) + do j=1, ndim2 + do k=1, ndim2 + if (j<=ndim .and. k<=ndim) then + call set_all(tfield, dim1=j, dim2=k, & + val=fields(:, component)) + end if + component = component+1 + end do + end do + call insert(state, tfield, names(i)) + call deallocate(tfield) + + else if (components(i)==2 .or. components(i)==3) then + ! Let's make a vector field. + call allocate(vfield, ndim, mesh, NAMES(i)) + call zero(vfield) + do j=1, components(i) + if (j<=ndim) then + call set_all(vfield, dim=j, val=fields(:, component)) + end if + component = component+1 + end do + call insert(state, vfield, NAMES(i)) + call deallocate(vfield) + + else if (components(i)==1) then + ! a scalar field + call allocate(sfield, mesh, names(i)) + call set_all(sfield, fields(:, component)) + call insert(state, sfield, names(i)) component = component+1 - end do - end do - call insert(state, tfield, names(i)) - call deallocate(tfield) - - else if (components(i)==2 .or. components(i)==3) then - ! Let's make a vector field. - call allocate(vfield, ndim, mesh, NAMES(i)) - call zero(vfield) - do j=1, components(i) - if (j<=ndim) then - call set_all(vfield, dim=j, val=fields(:, component)) - end if - component = component+1 - end do - call insert(state, vfield, NAMES(i)) - call deallocate(vfield) - - else if (components(i)==1) then - ! a scalar field - call allocate(sfield, mesh, names(i)) - call set_all(sfield, fields(:, component)) - call insert(state, sfield, names(i)) - component = component+1 - call deallocate(sfield) + call deallocate(sfield) + + else + + ewrite(-1,*) "In vtk_read_state ***" + ewrite(-1,*) "Field ", trim(names(i)), " has ", components(i), " components." + FLAbort("Don't know what to do with that number of components") + + end if + + end do + + end subroutine vtk_insert_fields_in_state + + subroutine vtk_write_surface_mesh(filename, index, position) + character(len=*), intent(in):: filename + integer, intent(in), optional:: index + type(vector_field), intent(in), target:: position + + type(vector_field):: surface_position + type(scalar_field), dimension(:), allocatable:: sfields + type(mesh_type), pointer:: mesh + type(mesh_type):: pwc_mesh + integer, dimension(:), allocatable:: surface_element_list + integer:: i + if (position%dim==1) return + + mesh => position%mesh + + assert( has_faces(mesh) ) + pwc_mesh = piecewise_constant_mesh(mesh%faces%surface_mesh, "PWCSurfaceMesh") + if (associated(mesh%faces%coplanar_ids)) then + allocate( sfields(1:2) ) else + allocate( sfields(1) ) + end if + + call allocate( sfields(1), pwc_mesh, name="BoundaryIDs") + call set(sfields(1), (/ ( i, i=1,node_count(pwc_mesh)) /), & + float(mesh%faces%boundary_ids)) + + if (associated(mesh%faces%coplanar_ids)) then + call allocate( sfields(2), pwc_mesh, name="CoplanarIDs") + call set(sfields(2), (/ ( i, i=1,node_count(pwc_mesh)) /), & + float(mesh%faces%coplanar_ids)) + end if + call deallocate(pwc_mesh) + + allocate(surface_element_list(1:surface_element_count(position))) + call allocate(surface_position, position%dim, mesh%faces%surface_mesh, "SurfacePositions") + do i=1, surface_element_count(position) + surface_element_list(i)=i + end do + call remap_field_to_surface(position, surface_position, surface_element_list) - ewrite(-1,*) "In vtk_read_state ***" - ewrite(-1,*) "Field ", trim(names(i)), " has ", components(i), " components." - FLAbort("Don't know what to do with that number of components") + call vtk_write_fields(filename, index=index, position=surface_position, & + model=mesh%faces%surface_mesh, sfields=sfields) + call deallocate(sfields(1)) + if (associated(mesh%faces%coplanar_ids)) then + call deallocate(sfields(2)) end if + call deallocate(surface_position) + + deallocate(sfields, surface_element_list) + + end subroutine vtk_write_surface_mesh + + subroutine vtk_write_internal_face_mesh(filename, index, position, face_sets) + character(len=*), intent(in):: filename + integer, intent(in), optional:: index + type(vector_field), intent(in), target:: position + type(integer_set), dimension(:), intent(in), optional :: face_sets - end do + type(vector_field):: face_position + type(mesh_type):: face_mesh, pwc_mesh + integer:: i, j, faces, nloc + type(scalar_field), dimension(:), allocatable :: sfields + integer :: face, opp_face - end subroutine vtk_insert_fields_in_state - - subroutine vtk_write_surface_mesh(filename, index, position) - character(len=*), intent(in):: filename - integer, intent(in), optional:: index - type(vector_field), intent(in), target:: position - - type(vector_field):: surface_position - type(scalar_field), dimension(:), allocatable:: sfields - type(mesh_type), pointer:: mesh - type(mesh_type):: pwc_mesh - integer, dimension(:), allocatable:: surface_element_list - integer:: i - - if (position%dim==1) return - - mesh => position%mesh - - assert( has_faces(mesh) ) - pwc_mesh = piecewise_constant_mesh(mesh%faces%surface_mesh, "PWCSurfaceMesh") - if (associated(mesh%faces%coplanar_ids)) then - allocate( sfields(1:2) ) - else - allocate( sfields(1) ) - end if - - call allocate( sfields(1), pwc_mesh, name="BoundaryIDs") - call set(sfields(1), (/ ( i, i=1,node_count(pwc_mesh)) /), & - float(mesh%faces%boundary_ids)) - - if (associated(mesh%faces%coplanar_ids)) then - call allocate( sfields(2), pwc_mesh, name="CoplanarIDs") - call set(sfields(2), (/ ( i, i=1,node_count(pwc_mesh)) /), & - float(mesh%faces%coplanar_ids)) - end if - call deallocate(pwc_mesh) - - allocate(surface_element_list(1:surface_element_count(position))) - call allocate(surface_position, position%dim, mesh%faces%surface_mesh, "SurfacePositions") - do i=1, surface_element_count(position) - surface_element_list(i)=i - end do - call remap_field_to_surface(position, surface_position, surface_element_list) - - call vtk_write_fields(filename, index=index, position=surface_position, & - model=mesh%faces%surface_mesh, sfields=sfields) - - call deallocate(sfields(1)) - if (associated(mesh%faces%coplanar_ids)) then - call deallocate(sfields(2)) - end if - call deallocate(surface_position) - - deallocate(sfields, surface_element_list) - - end subroutine vtk_write_surface_mesh - - subroutine vtk_write_internal_face_mesh(filename, index, position, face_sets) - character(len=*), intent(in):: filename - integer, intent(in), optional:: index - type(vector_field), intent(in), target:: position - type(integer_set), dimension(:), intent(in), optional :: face_sets - - type(vector_field):: face_position - type(mesh_type):: face_mesh, pwc_mesh - integer:: i, j, faces, nloc - type(scalar_field), dimension(:), allocatable :: sfields - integer :: face, opp_face - - if (position%dim==1) return - - ! this isn't really exposed through the interface - faces=size(position%mesh%faces%face_element_list) - - nloc=face_loc(position,1) - - call allocate( face_mesh, node_count(position), faces, & - position%mesh%faces%shape, name="InternalFaceMesh") - - do i=1, faces - face_mesh%ndglno( (i-1)*nloc+1:i*nloc ) = face_global_nodes(position, i) - end do - - call allocate( face_position, position%dim, face_mesh, name="InternalFaceMeshCoordinate") - - ! the node number is the same, so we can just copy, even though the mesh is entirely different - do i=1, position%dim - face_position%val(i,:)=position%val(i,:) - end do - - if (present(face_sets)) then - pwc_mesh = piecewise_constant_mesh(face_position%mesh, "PWCMesh") - - allocate(sfields(size(face_sets))) - do i=1,size(face_sets) - call allocate(sfields(i), pwc_mesh, "FaceSet" // int2str(i)) - call zero(sfields(i)) - do j=1,key_count(face_sets(i)) - face = fetch(face_sets(i), j) - call set(sfields(i), face, 1.0) - opp_face = face_opposite(position, face) - if (opp_face > 0) then - call set(sfields(i), opp_face, 1.0) - end if - end do + if (position%dim==1) return + + ! this isn't really exposed through the interface + faces=size(position%mesh%faces%face_element_list) + + nloc=face_loc(position,1) + + call allocate( face_mesh, node_count(position), faces, & + position%mesh%faces%shape, name="InternalFaceMesh") + + do i=1, faces + face_mesh%ndglno( (i-1)*nloc+1:i*nloc ) = face_global_nodes(position, i) end do - call vtk_write_fields(filename, index=index, position=face_position, & - model=face_mesh, sfields=sfields) + call allocate( face_position, position%dim, face_mesh, name="InternalFaceMeshCoordinate") - do i=1,size(face_sets) - call deallocate(sfields(i)) + ! the node number is the same, so we can just copy, even though the mesh is entirely different + do i=1, position%dim + face_position%val(i,:)=position%val(i,:) end do - deallocate(sfields) - call deallocate(pwc_mesh) - else - call vtk_write_fields(filename, index=index, position=face_position, & - model=face_mesh) - end if + if (present(face_sets)) then + pwc_mesh = piecewise_constant_mesh(face_position%mesh, "PWCMesh") + + allocate(sfields(size(face_sets))) + do i=1,size(face_sets) + call allocate(sfields(i), pwc_mesh, "FaceSet" // int2str(i)) + call zero(sfields(i)) + do j=1,key_count(face_sets(i)) + face = fetch(face_sets(i), j) + call set(sfields(i), face, 1.0) + opp_face = face_opposite(position, face) + if (opp_face > 0) then + call set(sfields(i), opp_face, 1.0) + end if + end do + end do + + call vtk_write_fields(filename, index=index, position=face_position, & + model=face_mesh, sfields=sfields) + + do i=1,size(face_sets) + call deallocate(sfields(i)) + end do + + deallocate(sfields) + call deallocate(pwc_mesh) + else + call vtk_write_fields(filename, index=index, position=face_position, & + model=face_mesh) + end if - call deallocate(face_position) - call deallocate(face_mesh) + call deallocate(face_position) + call deallocate(face_mesh) - end subroutine vtk_write_internal_face_mesh + end subroutine vtk_write_internal_face_mesh end module vtk_interfaces diff --git a/femtools/Vector_Tools.F90 b/femtools/Vector_Tools.F90 index 07b1605036..92beb5b253 100644 --- a/femtools/Vector_Tools.F90 +++ b/femtools/Vector_Tools.F90 @@ -1,24 +1,24 @@ #include "fdebug.h" module vector_tools - !!< This module contains dense matrix operations such as interfaces to - !!< LAPACK. + !!< This module contains dense matrix operations such as interfaces to + !!< LAPACK. - use fldebug + use fldebug - implicit none + implicit none - interface blasmul - module procedure blasmul_mm, blasmul_mv - end interface blasmul + interface blasmul + module procedure blasmul_mm, blasmul_mv + end interface blasmul - interface solve - module procedure solve_single, solve_multiple - end interface + interface solve + module procedure solve_single, solve_multiple + end interface - interface invert - module procedure invert_matrix - end interface invert + interface invert + module procedure invert_matrix + end interface invert ! interface operator(.cross.) ! module procedure cross_product @@ -28,610 +28,610 @@ module vector_tools ! module procedure dot_product_op ! end interface - interface norm2 - module procedure norm2_vector, norm2_tensor - end interface + interface norm2 + module procedure norm2_vector, norm2_tensor + end interface - interface cross_product - module procedure cross_product_array - end interface + interface cross_product + module procedure cross_product_array + end interface - interface outer_product - module procedure outer_product - end interface + interface outer_product + module procedure outer_product + end interface - private - public blasmul, solve, norm2, cross_product, invert, inverse, cholesky_factor, & - mat_diag_mat, eigendecomposition, eigendecomposition_symmetric, eigenrecomposition, & - outer_product, det, det_2, det_3, scalar_triple_product, svd, cross_product2 + private + public blasmul, solve, norm2, cross_product, invert, inverse, cholesky_factor, & + mat_diag_mat, eigendecomposition, eigendecomposition_symmetric, eigenrecomposition, & + outer_product, det, det_2, det_3, scalar_triple_product, svd, cross_product2 contains - pure function dot_product_op(vector1, vector2) result(dot) - !!< Dot product. Need to wrap dot_product to make .dot. operator. - real, dimension(:), intent(in) :: vector1, vector2 - real :: dot + pure function dot_product_op(vector1, vector2) result(dot) + !!< Dot product. Need to wrap dot_product to make .dot. operator. + real, dimension(:), intent(in) :: vector1, vector2 + real :: dot - dot = dot_product(vector1, vector2) - end function dot_product_op + dot = dot_product(vector1, vector2) + end function dot_product_op - pure function norm2_vector(vector) - !!< Calculate the 2-norm of vector - real :: norm2_vector - real, dimension(:), intent(in) :: vector + pure function norm2_vector(vector) + !!< Calculate the 2-norm of vector + real :: norm2_vector + real, dimension(:), intent(in) :: vector - norm2_vector=sqrt(dot_product(vector, vector)) + norm2_vector=sqrt(dot_product(vector, vector)) - end function norm2_vector + end function norm2_vector - pure function norm2_tensor(tensor) - !!< Calculate the 2-norm of tensor - real :: norm2_tensor - real, dimension(:,:), intent(in) :: tensor + pure function norm2_tensor(tensor) + !!< Calculate the 2-norm of tensor + real :: norm2_tensor + real, dimension(:,:), intent(in) :: tensor - norm2_tensor=sqrt(sum(tensor(:,:)*tensor(:,:))) + norm2_tensor=sqrt(sum(tensor(:,:)*tensor(:,:))) - end function norm2_tensor + end function norm2_tensor - pure function cross_product_array(vector1, vector2) result(prod) - !!< Calculate the cross product of the vectors provided. - real, dimension(3) :: prod - real, dimension(3), intent(in) :: vector1, vector2 + pure function cross_product_array(vector1, vector2) result(prod) + !!< Calculate the cross product of the vectors provided. + real, dimension(3) :: prod + real, dimension(3), intent(in) :: vector1, vector2 - prod(1)=vector1(2)*vector2(3) - vector1(3)*vector2(2) - prod(2)=vector1(3)*vector2(1) - vector1(1)*vector2(3) - prod(3)=vector1(1)*vector2(2) - vector1(2)*vector2(1) + prod(1)=vector1(2)*vector2(3) - vector1(3)*vector2(2) + prod(2)=vector1(3)*vector2(1) - vector1(1)*vector2(3) + prod(3)=vector1(1)*vector2(2) - vector1(2)*vector2(1) - end function cross_product_array + end function cross_product_array - pure function cross_product2(vector1, vector2) result(prod) - !!< 2-dimensional cross-product analog - real :: prod - real, dimension(2), intent(in) :: vector1, vector2 + pure function cross_product2(vector1, vector2) result(prod) + !!< 2-dimensional cross-product analog + real :: prod + real, dimension(2), intent(in) :: vector1, vector2 - prod=vector1(1)*vector2(2) - vector1(2)*vector2(1) + prod=vector1(1)*vector2(2) - vector1(2)*vector2(1) - end function cross_product2 + end function cross_product2 - pure function scalar_triple_product(vector1, vector2, vector3) result (prod) - ! returns a scalar triple product - real, dimension(3), intent(in) :: vector1, vector2, vector3 - real :: prod + pure function scalar_triple_product(vector1, vector2, vector3) result (prod) + ! returns a scalar triple product + real, dimension(3), intent(in) :: vector1, vector2, vector3 + real :: prod - prod=vector1(1)*(vector2(2)*vector3(3) - vector2(3)*vector3(2)) + & + prod=vector1(1)*(vector2(2)*vector3(3) - vector2(3)*vector3(2)) + & vector1(2)*(vector2(3)*vector3(1) - vector2(1)*vector3(3)) + & vector1(3)*(vector2(1)*vector3(2) - vector2(2)*vector3(1)) - end function scalar_triple_product + end function scalar_triple_product - subroutine solve_single(A, b, info) - !!< Solve Ax=b for one right hand side b, putting the result in b. - real, dimension(:, :), intent(in) :: A - real, dimension(:), intent(inout) :: b - integer, optional, intent(out) :: info + subroutine solve_single(A, b, info) + !!< Solve Ax=b for one right hand side b, putting the result in b. + real, dimension(:, :), intent(in) :: A + real, dimension(:), intent(inout) :: b + integer, optional, intent(out) :: info - real, dimension(size(b), 1) :: b_tmp + real, dimension(size(b), 1) :: b_tmp - b_tmp(:, 1) = b - call solve_multiple(A, b_tmp, info) - b = b_tmp(:, 1) - end subroutine solve_single + b_tmp(:, 1) = b + call solve_multiple(A, b_tmp, info) + b = b_tmp(:, 1) + end subroutine solve_single - subroutine solve_multiple(A,B, stat) - !!< Solve Ax=b for multiple right hand sides B putting the result in B. - !!< - !!< This is simply a wrapper for lapack. - real, dimension(:,:), intent(in) :: A - real, dimension(:,:), intent(inout) :: B - integer, optional, intent(out) :: stat + subroutine solve_multiple(A,B, stat) + !!< Solve Ax=b for multiple right hand sides B putting the result in B. + !!< + !!< This is simply a wrapper for lapack. + real, dimension(:,:), intent(in) :: A + real, dimension(:,:), intent(inout) :: B + integer, optional, intent(out) :: stat - real, dimension(size(A,1), size(A,2)) :: Atmp - integer, dimension(size(A,1)) :: ipiv - integer :: info + real, dimension(size(A,1), size(A,2)) :: Atmp + integer, dimension(size(A,1)) :: ipiv + integer :: info - interface + interface #ifdef DOUBLEP - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - INTEGER :: INFO, LDA, LDB, N, NRHS - INTEGER :: IPIV( * ) - REAL :: A( LDA, * ), B( LDB, * ) - END SUBROUTINE DGESV + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + INTEGER :: INFO, LDA, LDB, N, NRHS + INTEGER :: IPIV( * ) + REAL :: A( LDA, * ), B( LDB, * ) + END SUBROUTINE DGESV #else - SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - INTEGER :: INFO, LDA, LDB, N, NRHS - INTEGER :: IPIV( * ) - REAL :: A( LDA, * ), B( LDB, * ) - END SUBROUTINE SGESV + SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + INTEGER :: INFO, LDA, LDB, N, NRHS + INTEGER :: IPIV( * ) + REAL :: A( LDA, * ), B( LDB, * ) + END SUBROUTINE SGESV #endif - end interface + end interface - if (present(stat)) stat = 0 + if (present(stat)) stat = 0 - ASSERT(size(A,1)==size(A,2)) - ASSERT(size(A,1)==size(B,1)) + ASSERT(size(A,1)==size(A,2)) + ASSERT(size(A,1)==size(B,1)) - Atmp=A + Atmp=A #ifdef DOUBLEP - call dgesv(size(A,1), size(B,2), Atmp, size(A,1), ipiv, B, size(B,1),& - & info) + call dgesv(size(A,1), size(B,2), Atmp, size(A,1), ipiv, B, size(B,1),& + & info) #else - call sgesv(size(A,1), size(B,2), Atmp, size(A,1), ipiv, B, size(B,1),& - & info) + call sgesv(size(A,1), size(B,2), Atmp, size(A,1), ipiv, B, size(B,1),& + & info) #endif - if (.not. present(stat)) then - ASSERT(info==0) - else - stat = info - end if + if (.not. present(stat)) then + ASSERT(info==0) + else + stat = info + end if - end subroutine solve_multiple + end subroutine solve_multiple - subroutine invert_matrix(A, stat) - !!< Replace the matrix A with its inverse. - real, dimension(:,:), intent(inout) :: A - real, dimension(size(A,1),size(A,2)) :: rhs - integer, intent(out), optional :: stat + subroutine invert_matrix(A, stat) + !!< Replace the matrix A with its inverse. + real, dimension(:,:), intent(inout) :: A + real, dimension(size(A,1),size(A,2)) :: rhs + integer, intent(out), optional :: stat - real, dimension(3,3):: a33 - real det, tmp - integer i + real, dimension(3,3):: a33 + real det, tmp + integer i - assert(size(A,1)==size(A,2)) + assert(size(A,1)==size(A,2)) - if(present(stat)) stat=0 + if(present(stat)) stat=0 - select case (size(A,1)) - case (3) ! I put this one first in the hope the compiler keeps it there - det=A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3)) & - -A(2,1)*(A(1,2)*A(3,3)-A(3,2)*A(1,3)) & - +A(3,1)*(A(1,2)*A(2,3)-A(2,2)*A(1,3)) + select case (size(A,1)) + case (3) ! I put this one first in the hope the compiler keeps it there + det=A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3)) & + -A(2,1)*(A(1,2)*A(3,3)-A(3,2)*A(1,3)) & + +A(3,1)*(A(1,2)*A(2,3)-A(2,2)*A(1,3)) - a33(1,1)=A(2,2)*A(3,3)-A(3,2)*A(2,3) - a33(1,2)=A(3,2)*A(1,3)-A(1,2)*A(3,3) - a33(1,3)=A(1,2)*A(2,3)-A(2,2)*A(1,3) + a33(1,1)=A(2,2)*A(3,3)-A(3,2)*A(2,3) + a33(1,2)=A(3,2)*A(1,3)-A(1,2)*A(3,3) + a33(1,3)=A(1,2)*A(2,3)-A(2,2)*A(1,3) - a33(2,1)=A(2,3)*A(3,1)-A(3,3)*A(2,1) - a33(2,2)=A(3,3)*A(1,1)-A(1,3)*A(3,1) - a33(2,3)=A(1,3)*A(2,1)-A(2,3)*A(1,1) + a33(2,1)=A(2,3)*A(3,1)-A(3,3)*A(2,1) + a33(2,2)=A(3,3)*A(1,1)-A(1,3)*A(3,1) + a33(2,3)=A(1,3)*A(2,1)-A(2,3)*A(1,1) - a33(3,1)=A(2,1)*A(3,2)-A(3,1)*A(2,2) - a33(3,2)=A(3,1)*A(1,2)-A(1,1)*A(3,2) - a33(3,3)=A(1,1)*A(2,2)-A(2,1)*A(1,2) + a33(3,1)=A(2,1)*A(3,2)-A(3,1)*A(2,2) + a33(3,2)=A(3,1)*A(1,2)-A(1,1)*A(3,2) + a33(3,3)=A(1,1)*A(2,2)-A(2,1)*A(1,2) - A=a33/det + A=a33/det - case (2) - det=A(1,1)*A(2,2)-A(1,2)*A(2,1) - tmp=A(1,1) - A(1,1)=A(2,2) - A(2,2)=tmp - A(1,2)=-A(1,2) - A(2,1)=-A(2,1) - A=A/det + case (2) + det=A(1,1)*A(2,2)-A(1,2)*A(2,1) + tmp=A(1,1) + A(1,1)=A(2,2) + A(2,2)=tmp + A(1,2)=-A(1,2) + A(2,1)=-A(2,1) + A=A/det - case (1) - A(1,1)=1.0/A(1,1) + case (1) + A(1,1)=1.0/A(1,1) - case default ! otherwise use LAPACK - rhs=0.0 + case default ! otherwise use LAPACK + rhs=0.0 - forall(i=1:size(A,1)) - rhs(i,i)=1.0 - end forall + forall(i=1:size(A,1)) + rhs(i,i)=1.0 + end forall - call solve(A, rhs, stat) + call solve(A, rhs, stat) - A=rhs - end select + A=rhs + end select - end subroutine invert_matrix + end subroutine invert_matrix - function inverse(A) - !!< Function version of invert. - real, dimension(:,:), intent(in) :: A - real, dimension(size(A,1),size(A,2)) :: inverse + function inverse(A) + !!< Function version of invert. + real, dimension(:,:), intent(in) :: A + real, dimension(size(A,1),size(A,2)) :: inverse - real det - integer i + real det + integer i - assert(size(A,1)==size(A,2)) + assert(size(A,1)==size(A,2)) - select case (size(A,1)) - case (3) ! I put this one first in the hope the compiler keeps it there - det=A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3)) & - -A(2,1)*(A(1,2)*A(3,3)-A(3,2)*A(1,3)) & - +A(3,1)*(A(1,2)*A(2,3)-A(2,2)*A(1,3)) + select case (size(A,1)) + case (3) ! I put this one first in the hope the compiler keeps it there + det=A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3)) & + -A(2,1)*(A(1,2)*A(3,3)-A(3,2)*A(1,3)) & + +A(3,1)*(A(1,2)*A(2,3)-A(2,2)*A(1,3)) - inverse(1,1)=A(2,2)*A(3,3)-A(3,2)*A(2,3) - inverse(1,2)=A(3,2)*A(1,3)-A(1,2)*A(3,3) - inverse(1,3)=A(1,2)*A(2,3)-A(2,2)*A(1,3) + inverse(1,1)=A(2,2)*A(3,3)-A(3,2)*A(2,3) + inverse(1,2)=A(3,2)*A(1,3)-A(1,2)*A(3,3) + inverse(1,3)=A(1,2)*A(2,3)-A(2,2)*A(1,3) - inverse(2,1)=A(2,3)*A(3,1)-A(3,3)*A(2,1) - inverse(2,2)=A(3,3)*A(1,1)-A(1,3)*A(3,1) - inverse(2,3)=A(1,3)*A(2,1)-A(2,3)*A(1,1) + inverse(2,1)=A(2,3)*A(3,1)-A(3,3)*A(2,1) + inverse(2,2)=A(3,3)*A(1,1)-A(1,3)*A(3,1) + inverse(2,3)=A(1,3)*A(2,1)-A(2,3)*A(1,1) - inverse(3,1)=A(2,1)*A(3,2)-A(3,1)*A(2,2) - inverse(3,2)=A(3,1)*A(1,2)-A(1,1)*A(3,2) - inverse(3,3)=A(1,1)*A(2,2)-A(2,1)*A(1,2) + inverse(3,1)=A(2,1)*A(3,2)-A(3,1)*A(2,2) + inverse(3,2)=A(3,1)*A(1,2)-A(1,1)*A(3,2) + inverse(3,3)=A(1,1)*A(2,2)-A(2,1)*A(1,2) - inverse=inverse/det + inverse=inverse/det - case (2) - det=A(1,1)*A(2,2)-A(1,2)*A(2,1) - inverse(1,1)=A(2,2) - inverse(2,2)=A(1,1) - inverse(1,2)=-A(1,2) - inverse(2,1)=-A(2,1) - inverse=inverse/det + case (2) + det=A(1,1)*A(2,2)-A(1,2)*A(2,1) + inverse(1,1)=A(2,2) + inverse(2,2)=A(1,1) + inverse(1,2)=-A(1,2) + inverse(2,1)=-A(2,1) + inverse=inverse/det - case (1) - inverse(1,1)=1.0/A(1,1) + case (1) + inverse(1,1)=1.0/A(1,1) - case default - inverse=0.0 + case default + inverse=0.0 - forall(i=1:size(A,1)) - inverse(i,i)=1.0 - end forall + forall(i=1:size(A,1)) + inverse(i,i)=1.0 + end forall - call solve(A, inverse) + call solve(A, inverse) - end select + end select - end function inverse + end function inverse - subroutine cholesky_factor(A) - !!< Replace the matrix A with an Upper triangular factor such that - !!< U^TU=A - !!< - !!< This is simply a wrapper for lapack. - real, dimension(:,:), intent(inout) :: A + subroutine cholesky_factor(A) + !!< Replace the matrix A with an Upper triangular factor such that + !!< U^TU=A + !!< + !!< This is simply a wrapper for lapack. + real, dimension(:,:), intent(inout) :: A - integer :: info + integer :: info - integer :: i,j + integer :: i,j - interface + interface #ifdef DOUBLEP - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) - CHARACTER(len=1) :: UPLO - INTEGER :: INFO, LDA, N - REAL :: A( LDA, * ) - END SUBROUTINE DPOTRF + SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) + CHARACTER(len=1) :: UPLO + INTEGER :: INFO, LDA, N + REAL :: A( LDA, * ) + END SUBROUTINE DPOTRF #else - SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) - CHARACTER(len=1) :: UPLO - INTEGER :: INFO, LDA, N - REAL :: A( LDA, * ) - END SUBROUTINE SPOTRF + SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) + CHARACTER(len=1) :: UPLO + INTEGER :: INFO, LDA, N + REAL :: A( LDA, * ) + END SUBROUTINE SPOTRF #endif - end interface + end interface - ASSERT(size(A,1)==size(A,2)) + ASSERT(size(A,1)==size(A,2)) - ! Zero lower triangular entries. - forall(i=1:size(A,1),j=1:size(a,2),j extract_scalar_field(state, name) - ! its first boundary condition is on the related top or bottom mesh - call get_boundary_condition(distance, 1, & - surface_element_list=surface_element_list) - positions => extract_vector_field(state, "Coordinate") - vertical_normal => extract_vector_field(state, "GravityDirection") - - ! in each node of the mesh, set "distance" to the vertical coordinate - ! of this node projected to the above/below surface mesh - call VerticalExtrapolation(vertical_coordinate, distance, positions, & - vertical_normal, surface_element_list, surface_name=name) - - ! the distance is then calculated by subtracting its own vertical coordinate - call addto(distance, vertical_coordinate, scale=-1.0) - - if (name=="DistanceToBottom") then - ! make distance to bottom positive - call scale(distance, -1.0) - end if - -end subroutine UpdateDistanceField - -subroutine CalculateTopBottomDistance(state) - !! This sub calculates the vertical distance to the free surface - !! and bottom of the ocean to all nodes. The results are stored - !! in the 'DistanceToBottom/Top' fields from state. - type(state_type), intent(inout):: state - - type(mesh_type), pointer:: xmesh - type(scalar_field):: vertical_coordinate - - xmesh => extract_mesh(state, "CoordinateMesh") - call allocate(vertical_coordinate, xmesh, "VerticalCoordinate") - call calculate_vertical_coordinate(state, vertical_coordinate) - call UpdateDistanceField(state, "DistanceToTop", vertical_coordinate) - call UpdateDistanceField(state, "DistanceToBottom", vertical_coordinate) - call deallocate(vertical_coordinate) - -end subroutine CalculateTopBottomDistance - -subroutine calculate_vertical_coordinate(state, vertical_coordinate) - !! Computes a vertical coordinate, i.e. a scalar field such that - !! for each 2 nodes above each other, the difference of the field - !! in these nodes gives the distance between them. - type(state_type), intent(inout):: state - type(scalar_field), intent(inout):: vertical_coordinate - - type(vector_field), pointer:: positions, gravity_normal - type(scalar_field):: positions_magnitude - - positions => extract_vector_field(state, "Coordinate") - if(have_option('/geometry/spherical_earth')) then - ! use the radius as vertical coordinate - ! that is, the l2-norm of the coordinate field - positions_magnitude=magnitude(positions) - call set(vertical_coordinate, positions_magnitude) - call deallocate(positions_magnitude) - else - gravity_normal => extract_vector_field(state, "GravityDirection") - assert(gravity_normal%field_type==FIELD_TYPE_CONSTANT) - call inner_product(vertical_coordinate, gravity_normal, positions) - ! gravity points down, we want a vertical coordinate that increases upward - call scale(vertical_coordinate, -1.0) - end if - -end subroutine calculate_vertical_coordinate - -subroutine VerticalExtrapolationScalar(from_field, to_field, & - positions, vertical_normal, surface_element_list, surface_name) - !!< This sub extrapolates the values on a horizontal 2D surface - !!< in the vertical direction to 3D fields - !! The from_fields should be 3D fields of which only the values on the - !! 2D horizontal surface are used. - type(scalar_field), intent(in):: from_field - !! Resulting extrapolated field. May be the same field or a field on - !! a different mesh (different degree). - type(scalar_field), intent(inout):: to_field - !! positions, and upward normal vector on the whole domain - type(vector_field), target, intent(inout):: positions - type(vector_field), target, intent(in):: vertical_normal - !! the surface elements (faces numbers) that make up the surface - integer, dimension(:), intent(in):: surface_element_list - !! If provided the projected surface mesh onto horizontal coordinates - !! and its associated rtree/pickers are cached under this name and - !! attached to the 'positions'. In this case when called again with - !! the same 'positions' and the same surface_name, - !! the same surface_element_list should again be provided. - character(len=*), optional, intent(in):: surface_name - - type(scalar_field), dimension(1):: to_fields - - to_fields=(/ to_field /) - call VerticalExtrapolationMultiple( (/ from_field /) , to_fields, & - positions, vertical_normal, surface_element_list, & - surface_name=surface_name) - -end subroutine VerticalExtrapolationScalar - -subroutine VerticalExtrapolationVector(from_field, to_field, & - positions, vertical_normal, surface_element_list, surface_name) - !!< This sub extrapolates the values on a horizontal 2D surface - !!< in the vertical direction to 3D fields - !! The from_fields should be 3D fields of which only the values on the - !! 2D horizontal surface are used. - type(vector_field), intent(in):: from_field - !! Resulting extrapolated field. May be the same field or a field on - !! a different mesh (different degree). - type(vector_field), intent(inout):: to_field - !! positions, and upward normal vector on the whole domain - type(vector_field), target, intent(inout):: positions - type(vector_field), target, intent(in):: vertical_normal - !! the surface elements (faces numbers) that make up the surface - integer, dimension(:), intent(in):: surface_element_list - !! If provided the projected surface mesh onto horizontal coordinates - !! and its associated rtree/pickers are cached under this name and - !! attached to the 'positions'. In this case when called again with - !! the same 'positions' and the same surface_name, - !! the same surface_element_list should again be provided. - character(len=*), optional, intent(in):: surface_name - - type(scalar_field), dimension(from_field%dim):: from_field_components, to_field_components - integer i - - assert(from_field%dim==to_field%dim) - - do i=1, from_field%dim - from_field_components(i)=extract_scalar_field(from_field, i) - to_field_components(i)=extract_scalar_field(to_field, i) - end do - - call VerticalExtrapolationMultiple( from_field_components, to_field_components, & - positions, vertical_normal, surface_element_list, & - surface_name=surface_name) - -end subroutine VerticalExtrapolationVector - -subroutine VerticalExtrapolationMultiple(from_fields, to_fields, & - positions, vertical_normal, surface_element_list, surface_name) - !!< This sub extrapolates the values on a horizontal 2D surface - !!< in the vertical direction to 3D fields - !! The from_fields should be 3D fields of which only the values on the - !! 2D horizontal surface are used. - !! This version takes multiple from_fields at the same time and extrapolates - !! to to_fields, such that the surface search only has to be done once. This - !! will only work if all the from_fields are on the same mesh, and all the - !! to_fields are on the same (possibly a different) mesh. - !! (also works with 1D surface mesh and 2D fields of course) - type(scalar_field), dimension(:), intent(in), target :: from_fields - !! Resulting extrapolated field. May be the same fields or a fields on - !! a different mesh (different degree) than from_fields, but all - !! to_fields need to be on the same mesh - type(scalar_field), dimension(:), intent(inout), target :: to_fields - !! positions, and upward normal vector on the whole domain - type(vector_field), target, intent(inout):: positions - type(vector_field), target, intent(in):: vertical_normal - - !! the surface elements (faces numbers) that make up the surface - integer, dimension(:), intent(in), target :: surface_element_list - !! If provided the projected surface mesh onto horizontal coordinates - !! and its associated rtree/pickers are cached under this name and - !! attached to the 'positions'. In this case when called again with - !! the same 'positions' and the same surface_name, - !! the same surface_element_list should again be provided. - character(len=*), optional, intent(in):: surface_name - - type(vector_field), pointer :: horizontal_positions - type(mesh_type), pointer:: to_mesh, from_mesh - character(len=FIELD_NAME_LEN):: lsurface_name - real, dimension(:,:), allocatable:: loc_coords, horizontal_coordinate - integer, dimension(:), pointer:: horizontal_surface_element_list - integer, dimension(:), allocatable:: eles - integer i, j, to_nodes, face - logical parallel_not_extruded - - assert(size(from_fields)==size(to_fields)) - assert(element_count(from_fields(1))==element_count(to_fields(1))) - to_mesh => to_fields(1)%mesh - from_mesh => from_fields(1)%mesh - do i=2, size(to_fields) - assert(to_fields(i)%mesh==to_mesh) - assert(from_fields(i)%mesh==from_mesh) - end do - - to_nodes=nowned_nodes(to_mesh) - ! local coordinates is one more than horizontal coordinate dim - allocate( eles(to_nodes), loc_coords(1:positions%dim, 1:to_nodes) ) - - if (present(surface_name)) then - lsurface_name=surface_name - else - lsurface_name="TempSurfaceName" - end if - - parallel_not_extruded = IsParallel() .and. option_count('/geometry/mesh/from_mesh/extrude')==0 - - call get_horizontal_positions(positions, surface_element_list, & - vertical_normal, lsurface_name, & - horizontal_positions, horizontal_surface_element_list) - - call create_horizontal_owned_nodal_coordinates(to_mesh, positions, vertical_normal, horizontal_coordinate) - - call picker_inquire(horizontal_positions, horizontal_coordinate, & - eles, loc_coords, global=.false. ) - - if (parallel_not_extruded) then - call vertical_interpolate_parallel(positions, eles, loc_coords, to_fields, from_fields, lsurface_name) - else - ! interpolate directly from from_fields face values - ! eles are element numbers inf horizontal_positions%mesh which is a surface mesh - ! with potentially duplicated facets (on sphere) - horizontal_surface_element_list maps these - ! element numbers to facet numbers of the full mesh - do i=1, size(to_fields) - do j=1, to_nodes - face=horizontal_surface_element_list(eles(j)) - call set(to_fields(i), j, & - dot_product( eval_shape( face_shape(from_fields(i), face), loc_coords(:,j) ), & - face_val( from_fields(i), face ) )) - end do - end do - end if - - if (IsParallel()) then - do i=1, size(to_fields) - call halo_update(to_fields(i)) - end do - end if - - if (.not. present(surface_name)) then - call remove_boundary_condition(positions, "TempSurfaceName") - end if - -end subroutine VerticalExtrapolationMultiple - -subroutine vertical_interpolate_parallel(positions, eles, loc_coords, to_fields, from_fields, surface_name) - !!< In parallel, without extrusion we use a redudant surface mesh (i.e. each process sees the entire - !!< global surface mesh). This requires us to first gather the values on this redundant surface mesh - !!< from all other processes that own parts of the surface mesh - type(vector_field), target, intent(inout):: positions - !! result of picker enquire in the horizontal_positions mesh - integer, dimension(:), intent(in):: eles - real, dimension(:, :), intent(in):: loc_coords - !! to_field, from_fields and surface_name as passed into VerticalExtrapolationMultiple above - type(scalar_field), dimension(:), intent(inout), target :: to_fields - type(scalar_field), dimension(:), intent(in), target :: from_fields - character(len=*), intent(in):: surface_name - - integer, dimension(:), pointer :: reduced_surface_element_list, surface_node_list - type(scalar_field) :: redundant_field - type(mesh_type), pointer:: to_mesh, from_mesh - type(mesh_type):: surface_mesh, redundant_mesh - integer i, j, ele - - assert(size(from_fields)==size(to_fields)) - assert(element_count(from_fields(1))==element_count(to_fields(1))) - to_mesh => to_fields(1)%mesh - from_mesh => from_fields(1)%mesh - do i=2, size(to_fields) - assert(to_fields(i)%mesh==to_mesh) - assert(from_fields(i)%mesh==from_mesh) - end do - - ! reduced_surface_element_list is a subset of surface_element_list passed into VerticalExtrapolationMultiple - ! as it only contains "owned" surface elements - call get_boundary_condition(positions, name=surface_name, & - surface_element_list=reduced_surface_element_list) - - ! pick up any previous created scalar field on a redundant version of the surface_mesh derived from from_mesh - if (.not. has_scalar_surface_field(positions, surface_name, trim(from_mesh%name)//"RedundantField")) then - ! if not yet created, do it now - call create_surface_mesh(surface_mesh, surface_node_list, & - from_mesh, reduced_surface_element_list, name=trim(from_mesh%name)//"SurfaceMesh") - redundant_mesh = create_parallel_redundant_mesh(surface_mesh) - call deallocate(surface_mesh) - ! store a field under the magic name (which encodes from from_mesh%name) for reuse in subs. calls - call allocate(redundant_field, redundant_mesh, name=trim(from_mesh%name)//"RedundantField") - call insert_surface_field(positions, surface_name, redundant_field) - ! change to redundant_field to borrowed reference (as if we'd extracted in the first place) - call decref(redundant_field) - call deallocate(redundant_mesh) - if (have_option('/geometry/spherical_earth')) then - ! need to implement re-duplication of facets - FLExit("Parallel, vertical extrapolation (ocean boundaries) on the sphere without extrusion not yet implemented") - end if - else - redundant_field = extract_scalar_surface_field(positions, surface_name, trim(from_mesh%name)//"RedundantField") - end if - - do i=1, size(from_fields) - ! this remap uses the fact that the first elements of redundant_field (the owned elements) - ! are the same as those of the reduced_surface_element_list based surface_mesh - ! (we don't actually need to remap, this is just for convenience) - call remap_field_to_surface(from_fields(i), redundant_field, reduced_surface_element_list) - ! now the owned part of redundant_field is filled in, sent it to all other processes: - call halo_update(redundant_field) - ! this is now straight-forward interpolation in the redudant mesh - do j=1, size(eles) - ele = eles(j) - call set(to_fields(i), j, & - dot_product( eval_shape( ele_shape(redundant_field, ele), loc_coords(:,j) ), & - ele_val(redundant_field, ele) )) - end do - end do - -end subroutine vertical_interpolate_parallel - -subroutine horizontal_picker(mesh, positions, vertical_normal, & - surface_element_list, surface_name, & - seles, loc_coords) - !! Searches the nodes of 'mesh' in the surface mesh above. - !! Returns the surface elements 'seles' that each node lies under - !! and the loc_coords in this element of this node projected - !! upward (radially on the sphere) onto the surface mesh - - !! mesh - type(mesh_type), intent(in):: mesh - !! a valid positions field for the whole domain, not necessarily on 'mesh' - !! for instance in a periodic domain, mesh is periodic and positions should not be - type(vector_field), target, intent(inout):: positions - !! upward normal vector on the whole domain - type(vector_field), target, intent(in):: vertical_normal - !! the surface elements (faces numbers) that make up the surface - integer, dimension(:), target, intent(in):: surface_element_list - !! The projected surface mesh onto horizontal coordinates - !! and its associated rtree/pickers are cached under this name and - !! attached to the 'positions'. When called again with - !! the same 'positions' and the same surface_name, - !! the same surface_element_list should again be provided. - character(len=*), intent(in):: surface_name - - !! returned surface elements (facet numbers in 'mesh') - !! and loc coords each node has been found in - !! size(seles)==size(loc_coords,2)==nowned_nodes(mesh) - integer, dimension(:), intent(out):: seles - real, dimension(:,:), intent(out):: loc_coords - - type(vector_field), pointer:: horizontal_positions - integer, dimension(:), pointer:: horizontal_mesh_list - real, dimension(:,:), allocatable:: horizontal_coordinate - integer:: i - - call create_horizontal_owned_nodal_coordinates(mesh, positions, vertical_normal, horizontal_coordinate) - - call get_horizontal_positions(positions, surface_element_list, & - vertical_normal, surface_name, & - horizontal_positions, horizontal_mesh_list) + subroutine UpdateDistanceField(state, name, vertical_coordinate) + ! This sub calculates the vertical distance to the free surface + ! and bottom of the ocean to all nodes. The results are stored + ! in the 'DistanceToBottom/FreeSurface' fields from state. + type(state_type), intent(inout):: state + character(len=*), intent(in):: name + type(scalar_field), intent(in):: vertical_coordinate + + ! Local variables + type(vector_field), pointer:: positions, vertical_normal + type(scalar_field), pointer:: distance + + integer, pointer, dimension(:):: surface_element_list + + ! the distance field to compute: + distance => extract_scalar_field(state, name) + ! its first boundary condition is on the related top or bottom mesh + call get_boundary_condition(distance, 1, & + surface_element_list=surface_element_list) + positions => extract_vector_field(state, "Coordinate") + vertical_normal => extract_vector_field(state, "GravityDirection") + + ! in each node of the mesh, set "distance" to the vertical coordinate + ! of this node projected to the above/below surface mesh + call VerticalExtrapolation(vertical_coordinate, distance, positions, & + vertical_normal, surface_element_list, surface_name=name) + + ! the distance is then calculated by subtracting its own vertical coordinate + call addto(distance, vertical_coordinate, scale=-1.0) + + if (name=="DistanceToBottom") then + ! make distance to bottom positive + call scale(distance, -1.0) + end if + + end subroutine UpdateDistanceField + + subroutine CalculateTopBottomDistance(state) + !! This sub calculates the vertical distance to the free surface + !! and bottom of the ocean to all nodes. The results are stored + !! in the 'DistanceToBottom/Top' fields from state. + type(state_type), intent(inout):: state + + type(mesh_type), pointer:: xmesh + type(scalar_field):: vertical_coordinate + + xmesh => extract_mesh(state, "CoordinateMesh") + call allocate(vertical_coordinate, xmesh, "VerticalCoordinate") + call calculate_vertical_coordinate(state, vertical_coordinate) + call UpdateDistanceField(state, "DistanceToTop", vertical_coordinate) + call UpdateDistanceField(state, "DistanceToBottom", vertical_coordinate) + call deallocate(vertical_coordinate) + + end subroutine CalculateTopBottomDistance + + subroutine calculate_vertical_coordinate(state, vertical_coordinate) + !! Computes a vertical coordinate, i.e. a scalar field such that + !! for each 2 nodes above each other, the difference of the field + !! in these nodes gives the distance between them. + type(state_type), intent(inout):: state + type(scalar_field), intent(inout):: vertical_coordinate + + type(vector_field), pointer:: positions, gravity_normal + type(scalar_field):: positions_magnitude + + positions => extract_vector_field(state, "Coordinate") + if(have_option('/geometry/spherical_earth')) then + ! use the radius as vertical coordinate + ! that is, the l2-norm of the coordinate field + positions_magnitude=magnitude(positions) + call set(vertical_coordinate, positions_magnitude) + call deallocate(positions_magnitude) + else + gravity_normal => extract_vector_field(state, "GravityDirection") + assert(gravity_normal%field_type==FIELD_TYPE_CONSTANT) + call inner_product(vertical_coordinate, gravity_normal, positions) + ! gravity points down, we want a vertical coordinate that increases upward + call scale(vertical_coordinate, -1.0) + end if + + end subroutine calculate_vertical_coordinate + + subroutine VerticalExtrapolationScalar(from_field, to_field, & + positions, vertical_normal, surface_element_list, surface_name) + !!< This sub extrapolates the values on a horizontal 2D surface + !!< in the vertical direction to 3D fields + !! The from_fields should be 3D fields of which only the values on the + !! 2D horizontal surface are used. + type(scalar_field), intent(in):: from_field + !! Resulting extrapolated field. May be the same field or a field on + !! a different mesh (different degree). + type(scalar_field), intent(inout):: to_field + !! positions, and upward normal vector on the whole domain + type(vector_field), target, intent(inout):: positions + type(vector_field), target, intent(in):: vertical_normal + !! the surface elements (faces numbers) that make up the surface + integer, dimension(:), intent(in):: surface_element_list + !! If provided the projected surface mesh onto horizontal coordinates + !! and its associated rtree/pickers are cached under this name and + !! attached to the 'positions'. In this case when called again with + !! the same 'positions' and the same surface_name, + !! the same surface_element_list should again be provided. + character(len=*), optional, intent(in):: surface_name + + type(scalar_field), dimension(1):: to_fields + + to_fields=(/ to_field /) + call VerticalExtrapolationMultiple( (/ from_field /) , to_fields, & + positions, vertical_normal, surface_element_list, & + surface_name=surface_name) + + end subroutine VerticalExtrapolationScalar + + subroutine VerticalExtrapolationVector(from_field, to_field, & + positions, vertical_normal, surface_element_list, surface_name) + !!< This sub extrapolates the values on a horizontal 2D surface + !!< in the vertical direction to 3D fields + !! The from_fields should be 3D fields of which only the values on the + !! 2D horizontal surface are used. + type(vector_field), intent(in):: from_field + !! Resulting extrapolated field. May be the same field or a field on + !! a different mesh (different degree). + type(vector_field), intent(inout):: to_field + !! positions, and upward normal vector on the whole domain + type(vector_field), target, intent(inout):: positions + type(vector_field), target, intent(in):: vertical_normal + !! the surface elements (faces numbers) that make up the surface + integer, dimension(:), intent(in):: surface_element_list + !! If provided the projected surface mesh onto horizontal coordinates + !! and its associated rtree/pickers are cached under this name and + !! attached to the 'positions'. In this case when called again with + !! the same 'positions' and the same surface_name, + !! the same surface_element_list should again be provided. + character(len=*), optional, intent(in):: surface_name + + type(scalar_field), dimension(from_field%dim):: from_field_components, to_field_components + integer i + + assert(from_field%dim==to_field%dim) + + do i=1, from_field%dim + from_field_components(i)=extract_scalar_field(from_field, i) + to_field_components(i)=extract_scalar_field(to_field, i) + end do + + call VerticalExtrapolationMultiple( from_field_components, to_field_components, & + positions, vertical_normal, surface_element_list, & + surface_name=surface_name) + + end subroutine VerticalExtrapolationVector + + subroutine VerticalExtrapolationMultiple(from_fields, to_fields, & + positions, vertical_normal, surface_element_list, surface_name) + !!< This sub extrapolates the values on a horizontal 2D surface + !!< in the vertical direction to 3D fields + !! The from_fields should be 3D fields of which only the values on the + !! 2D horizontal surface are used. + !! This version takes multiple from_fields at the same time and extrapolates + !! to to_fields, such that the surface search only has to be done once. This + !! will only work if all the from_fields are on the same mesh, and all the + !! to_fields are on the same (possibly a different) mesh. + !! (also works with 1D surface mesh and 2D fields of course) + type(scalar_field), dimension(:), intent(in), target :: from_fields + !! Resulting extrapolated field. May be the same fields or a fields on + !! a different mesh (different degree) than from_fields, but all + !! to_fields need to be on the same mesh + type(scalar_field), dimension(:), intent(inout), target :: to_fields + !! positions, and upward normal vector on the whole domain + type(vector_field), target, intent(inout):: positions + type(vector_field), target, intent(in):: vertical_normal + + !! the surface elements (faces numbers) that make up the surface + integer, dimension(:), intent(in), target :: surface_element_list + !! If provided the projected surface mesh onto horizontal coordinates + !! and its associated rtree/pickers are cached under this name and + !! attached to the 'positions'. In this case when called again with + !! the same 'positions' and the same surface_name, + !! the same surface_element_list should again be provided. + character(len=*), optional, intent(in):: surface_name + + type(vector_field), pointer :: horizontal_positions + type(mesh_type), pointer:: to_mesh, from_mesh + character(len=FIELD_NAME_LEN):: lsurface_name + real, dimension(:,:), allocatable:: loc_coords, horizontal_coordinate + integer, dimension(:), pointer:: horizontal_surface_element_list + integer, dimension(:), allocatable:: eles + integer i, j, to_nodes, face + logical parallel_not_extruded + + assert(size(from_fields)==size(to_fields)) + assert(element_count(from_fields(1))==element_count(to_fields(1))) + to_mesh => to_fields(1)%mesh + from_mesh => from_fields(1)%mesh + do i=2, size(to_fields) + assert(to_fields(i)%mesh==to_mesh) + assert(from_fields(i)%mesh==from_mesh) + end do + + to_nodes=nowned_nodes(to_mesh) + ! local coordinates is one more than horizontal coordinate dim + allocate( eles(to_nodes), loc_coords(1:positions%dim, 1:to_nodes) ) + + if (present(surface_name)) then + lsurface_name=surface_name + else + lsurface_name="TempSurfaceName" + end if + + parallel_not_extruded = IsParallel() .and. option_count('/geometry/mesh/from_mesh/extrude')==0 + + call get_horizontal_positions(positions, surface_element_list, & + vertical_normal, lsurface_name, & + horizontal_positions, horizontal_surface_element_list) + + call create_horizontal_owned_nodal_coordinates(to_mesh, positions, vertical_normal, horizontal_coordinate) + + call picker_inquire(horizontal_positions, horizontal_coordinate, & + eles, loc_coords, global=.false. ) + + if (parallel_not_extruded) then + call vertical_interpolate_parallel(positions, eles, loc_coords, to_fields, from_fields, lsurface_name) + else + ! interpolate directly from from_fields face values + ! eles are element numbers inf horizontal_positions%mesh which is a surface mesh + ! with potentially duplicated facets (on sphere) - horizontal_surface_element_list maps these + ! element numbers to facet numbers of the full mesh + do i=1, size(to_fields) + do j=1, to_nodes + face=horizontal_surface_element_list(eles(j)) + call set(to_fields(i), j, & + dot_product( eval_shape( face_shape(from_fields(i), face), loc_coords(:,j) ), & + face_val( from_fields(i), face ) )) + end do + end do + end if + + if (IsParallel()) then + do i=1, size(to_fields) + call halo_update(to_fields(i)) + end do + end if + + if (.not. present(surface_name)) then + call remove_boundary_condition(positions, "TempSurfaceName") + end if - call picker_inquire(horizontal_positions, horizontal_coordinate, & - seles, loc_coords, global=.false. ) + end subroutine VerticalExtrapolationMultiple + + subroutine vertical_interpolate_parallel(positions, eles, loc_coords, to_fields, from_fields, surface_name) + !!< In parallel, without extrusion we use a redudant surface mesh (i.e. each process sees the entire + !!< global surface mesh). This requires us to first gather the values on this redundant surface mesh + !!< from all other processes that own parts of the surface mesh + type(vector_field), target, intent(inout):: positions + !! result of picker enquire in the horizontal_positions mesh + integer, dimension(:), intent(in):: eles + real, dimension(:, :), intent(in):: loc_coords + !! to_field, from_fields and surface_name as passed into VerticalExtrapolationMultiple above + type(scalar_field), dimension(:), intent(inout), target :: to_fields + type(scalar_field), dimension(:), intent(in), target :: from_fields + character(len=*), intent(in):: surface_name + + integer, dimension(:), pointer :: reduced_surface_element_list, surface_node_list + type(scalar_field) :: redundant_field + type(mesh_type), pointer:: to_mesh, from_mesh + type(mesh_type):: surface_mesh, redundant_mesh + integer i, j, ele + + assert(size(from_fields)==size(to_fields)) + assert(element_count(from_fields(1))==element_count(to_fields(1))) + to_mesh => to_fields(1)%mesh + from_mesh => from_fields(1)%mesh + do i=2, size(to_fields) + assert(to_fields(i)%mesh==to_mesh) + assert(from_fields(i)%mesh==from_mesh) + end do + + ! reduced_surface_element_list is a subset of surface_element_list passed into VerticalExtrapolationMultiple + ! as it only contains "owned" surface elements + call get_boundary_condition(positions, name=surface_name, & + surface_element_list=reduced_surface_element_list) + + ! pick up any previous created scalar field on a redundant version of the surface_mesh derived from from_mesh + if (.not. has_scalar_surface_field(positions, surface_name, trim(from_mesh%name)//"RedundantField")) then + ! if not yet created, do it now + call create_surface_mesh(surface_mesh, surface_node_list, & + from_mesh, reduced_surface_element_list, name=trim(from_mesh%name)//"SurfaceMesh") + redundant_mesh = create_parallel_redundant_mesh(surface_mesh) + call deallocate(surface_mesh) + ! store a field under the magic name (which encodes from from_mesh%name) for reuse in subs. calls + call allocate(redundant_field, redundant_mesh, name=trim(from_mesh%name)//"RedundantField") + call insert_surface_field(positions, surface_name, redundant_field) + ! change to redundant_field to borrowed reference (as if we'd extracted in the first place) + call decref(redundant_field) + call deallocate(redundant_mesh) + if (have_option('/geometry/spherical_earth')) then + ! need to implement re-duplication of facets + FLExit("Parallel, vertical extrapolation (ocean boundaries) on the sphere without extrusion not yet implemented") + end if + else + redundant_field = extract_scalar_surface_field(positions, surface_name, trim(from_mesh%name)//"RedundantField") + end if + + do i=1, size(from_fields) + ! this remap uses the fact that the first elements of redundant_field (the owned elements) + ! are the same as those of the reduced_surface_element_list based surface_mesh + ! (we don't actually need to remap, this is just for convenience) + call remap_field_to_surface(from_fields(i), redundant_field, reduced_surface_element_list) + ! now the owned part of redundant_field is filled in, sent it to all other processes: + call halo_update(redundant_field) + ! this is now straight-forward interpolation in the redudant mesh + do j=1, size(eles) + ele = eles(j) + call set(to_fields(i), j, & + dot_product( eval_shape( ele_shape(redundant_field, ele), loc_coords(:,j) ), & + ele_val(redundant_field, ele) )) + end do + end do + + end subroutine vertical_interpolate_parallel + + subroutine horizontal_picker(mesh, positions, vertical_normal, & + surface_element_list, surface_name, & + seles, loc_coords) + !! Searches the nodes of 'mesh' in the surface mesh above. + !! Returns the surface elements 'seles' that each node lies under + !! and the loc_coords in this element of this node projected + !! upward (radially on the sphere) onto the surface mesh + + !! mesh + type(mesh_type), intent(in):: mesh + !! a valid positions field for the whole domain, not necessarily on 'mesh' + !! for instance in a periodic domain, mesh is periodic and positions should not be + type(vector_field), target, intent(inout):: positions + !! upward normal vector on the whole domain + type(vector_field), target, intent(in):: vertical_normal + !! the surface elements (faces numbers) that make up the surface + integer, dimension(:), target, intent(in):: surface_element_list + !! The projected surface mesh onto horizontal coordinates + !! and its associated rtree/pickers are cached under this name and + !! attached to the 'positions'. When called again with + !! the same 'positions' and the same surface_name, + !! the same surface_element_list should again be provided. + character(len=*), intent(in):: surface_name + + !! returned surface elements (facet numbers in 'mesh') + !! and loc coords each node has been found in + !! size(seles)==size(loc_coords,2)==nowned_nodes(mesh) + integer, dimension(:), intent(out):: seles + real, dimension(:,:), intent(out):: loc_coords + + type(vector_field), pointer:: horizontal_positions + integer, dimension(:), pointer:: horizontal_mesh_list + real, dimension(:,:), allocatable:: horizontal_coordinate + integer:: i + + call create_horizontal_owned_nodal_coordinates(mesh, positions, vertical_normal, horizontal_coordinate) + + call get_horizontal_positions(positions, surface_element_list, & + vertical_normal, surface_name, & + horizontal_positions, horizontal_mesh_list) + + call picker_inquire(horizontal_positions, horizontal_coordinate, & + seles, loc_coords, global=.false. ) + + ! in the spherical case some of the surface elements may be duplicated + ! within horizontal positions, the returned seles should refer to entries + ! in surface_element_list however - also check for nodes not found + do i=1, size(seles) + if (seles(i)<0) then + if (mesh==positions%mesh) then + ewrite(-1,*) "For node with coordinate", node_val(positions, i) + else + ewrite(-1,*) "For node with horizontal coordinate", horizontal_coordinate(:, i) + end if + ewrite(-1,*) "no top surface node was found." + FLAbort("Something wrong with the geometry.") + else + seles(i) = horizontal_mesh_list(seles(i)) + end if + end do + + end subroutine horizontal_picker + + subroutine create_horizontal_owned_nodal_coordinates(mesh, positions, vertical_normal, horizontal_coordinate) + !!< creates array of the horizontal coordinates of the owned nodes in mesh + + type(mesh_type), intent(in):: mesh + !! a valid positions field for the whole domain, not necessarily on 'mesh' + type(vector_field), intent(inout):: positions + !! upward normal vector on the whole domain + type(vector_field), target, intent(in):: vertical_normal + !! return array of dimension positions%dim-1 x nowned_nodes(mesh) + real, dimension(:, :), allocatable, intent(out) :: horizontal_coordinate + + type(vector_field):: mesh_positions + real, dimension(vertical_normal%dim):: normal_vector + integer nodes, stat, i + + assert(.not. mesh_periodic(positions)) + + nodes=nowned_nodes(mesh) + allocate( horizontal_coordinate(1:positions%dim-1, 1:nodes) ) - ! in the spherical case some of the surface elements may be duplicated - ! within horizontal positions, the returned seles should refer to entries - ! in surface_element_list however - also check for nodes not found - do i=1, size(seles) - if (seles(i)<0) then if (mesh==positions%mesh) then - ewrite(-1,*) "For node with coordinate", node_val(positions, i) + mesh_positions=positions + ! make mesh_positions indep. ref. of the field, so we can deallocate it + ! safely without destroying positions + call incref(mesh_positions) else - ewrite(-1,*) "For node with horizontal coordinate", horizontal_coordinate(:, i) + call allocate(mesh_positions, positions%dim, mesh, & + name='ToPositions_VerticalExtrapolation') + call remap_field(positions, mesh_positions, stat) + if (stat/=0 .and. stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS .and. & + stat/=REMAP_ERR_UNPERIODIC_PERIODIC) then + ! Mapping from higher order to lower order is allowed for coordinates + ! (well depends on how the higher order is derived from the lower order) + ! + ! Mapping to periodic coordinates is ok in this case as we only need + ! locations for the nodes individually (i.e. we don't care about elements + ! in 'mesh') - the created horizontal_positions will be non-periodic + ! So that we should be able to find nodes on the periodic boundary on + ! either side. Using this to interpolate is consistent as long as + ! the interpolated from field is indeed periodic. + FLAbort("Unknown error in remmaping positions in horizontal_picker.") + end if end if - ewrite(-1,*) "no top surface node was found." - FLAbort("Something wrong with the geometry.") - else - seles(i) = horizontal_mesh_list(seles(i)) - end if - end do - -end subroutine horizontal_picker - -subroutine create_horizontal_owned_nodal_coordinates(mesh, positions, vertical_normal, horizontal_coordinate) - !!< creates array of the horizontal coordinates of the owned nodes in mesh - - type(mesh_type), intent(in):: mesh - !! a valid positions field for the whole domain, not necessarily on 'mesh' - type(vector_field), intent(inout):: positions - !! upward normal vector on the whole domain - type(vector_field), target, intent(in):: vertical_normal - !! return array of dimension positions%dim-1 x nowned_nodes(mesh) - real, dimension(:, :), allocatable, intent(out) :: horizontal_coordinate - - type(vector_field):: mesh_positions - real, dimension(vertical_normal%dim):: normal_vector - integer nodes, stat, i - - assert(.not. mesh_periodic(positions)) - - nodes=nowned_nodes(mesh) - allocate( horizontal_coordinate(1:positions%dim-1, 1:nodes) ) - - if (mesh==positions%mesh) then - mesh_positions=positions - ! make mesh_positions indep. ref. of the field, so we can deallocate it - ! safely without destroying positions - call incref(mesh_positions) - else - call allocate(mesh_positions, positions%dim, mesh, & - name='ToPositions_VerticalExtrapolation') - call remap_field(positions, mesh_positions, stat) - if (stat/=0 .and. stat/=REMAP_ERR_HIGHER_LOWER_CONTINUOUS .and. & - stat/=REMAP_ERR_UNPERIODIC_PERIODIC) then - ! Mapping from higher order to lower order is allowed for coordinates - ! (well depends on how the higher order is derived from the lower order) - ! - ! Mapping to periodic coordinates is ok in this case as we only need - ! locations for the nodes individually (i.e. we don't care about elements - ! in 'mesh') - the created horizontal_positions will be non-periodic - ! So that we should be able to find nodes on the periodic boundary on - ! either side. Using this to interpolate is consistent as long as - ! the interpolated from field is indeed periodic. - FLAbort("Unknown error in remmaping positions in horizontal_picker.") - end if - end if - - - if (have_option('/geometry/spherical_earth')) then - do i=1, nodes - horizontal_coordinate(:,i) = map2horizontal_sphere(node_val(mesh_positions, i)) - end do - else - assert( vertical_normal%field_type==FIELD_TYPE_CONSTANT ) - normal_vector=node_val(vertical_normal,1) - - do i=1, nodes - horizontal_coordinate(:,i) = map2horizontal(node_val(mesh_positions, i), normal_vector) - end do - end if - - call deallocate(mesh_positions) - -end subroutine create_horizontal_owned_nodal_coordinates - -subroutine get_horizontal_positions(positions, surface_element_list, vertical_normal, surface_name, & - horizontal_positions, horizontal_mesh_list) + + + if (have_option('/geometry/spherical_earth')) then + do i=1, nodes + horizontal_coordinate(:,i) = map2horizontal_sphere(node_val(mesh_positions, i)) + end do + else + assert( vertical_normal%field_type==FIELD_TYPE_CONSTANT ) + normal_vector=node_val(vertical_normal,1) + + do i=1, nodes + horizontal_coordinate(:,i) = map2horizontal(node_val(mesh_positions, i), normal_vector) + end do + end if + + call deallocate(mesh_positions) + + end subroutine create_horizontal_owned_nodal_coordinates + + subroutine get_horizontal_positions(positions, surface_element_list, vertical_normal, surface_name, & + horizontal_positions, horizontal_mesh_list) ! returns a horizontal positions field over the surface mesh indicated by ! 'surface_element_list'. This field will be created and cached on 'positions' ! as a surface field attached to a dummy boundary condition under the name surface_name - type(vector_field), intent(inout):: positions - type(vector_field), intent(in):: vertical_normal - integer, dimension(:), target, intent(in):: surface_element_list - character(len=*), intent(in):: surface_name - - ! Returns the horizontal positions on a horizontal mesh, this mesh - ! may have some of the facets in surface_element_list duplicated - - ! this is only in the spherical case where the horizontal mesh - ! consists of multiple disjoint regions representing the sides of a cubed sphere - ! and surface elements near the boundaries of these regions may be represented multiple times. - ! Therefore we also return a map between elements in the horizontal positions mesh - ! and facet numbers in the full mesh (in the planar case this is the same as surface_element_list) - ! horizontal_positions is a borrowed reference, don't deallocate - ! also horizontal_mesh_list should not be deallocated - type(vector_field), pointer:: horizontal_positions - integer, dimension(:), pointer:: horizontal_mesh_list - - if (.not. has_boundary_condition_name(positions, surface_name)) then - call create_horizontal_positions(positions, & - surface_element_list, vertical_normal, surface_name) - end if - - horizontal_positions => extract_surface_field(positions, surface_name, & - trim(surface_name)//"HorizontalCoordinate") - - call get_boundary_condition(positions, surface_name, & - surface_element_list=horizontal_mesh_list) - -end subroutine get_horizontal_positions - -subroutine create_horizontal_positions(positions, surface_element_list, vertical_normal, surface_name) + type(vector_field), intent(inout):: positions + type(vector_field), intent(in):: vertical_normal + integer, dimension(:), target, intent(in):: surface_element_list + character(len=*), intent(in):: surface_name + + ! Returns the horizontal positions on a horizontal mesh, this mesh + ! may have some of the facets in surface_element_list duplicated - + ! this is only in the spherical case where the horizontal mesh + ! consists of multiple disjoint regions representing the sides of a cubed sphere + ! and surface elements near the boundaries of these regions may be represented multiple times. + ! Therefore we also return a map between elements in the horizontal positions mesh + ! and facet numbers in the full mesh (in the planar case this is the same as surface_element_list) + ! horizontal_positions is a borrowed reference, don't deallocate + ! also horizontal_mesh_list should not be deallocated + type(vector_field), pointer:: horizontal_positions + integer, dimension(:), pointer:: horizontal_mesh_list + + if (.not. has_boundary_condition_name(positions, surface_name)) then + call create_horizontal_positions(positions, & + surface_element_list, vertical_normal, surface_name) + end if + + horizontal_positions => extract_surface_field(positions, surface_name, & + trim(surface_name)//"HorizontalCoordinate") + + call get_boundary_condition(positions, surface_name, & + surface_element_list=horizontal_mesh_list) + + end subroutine get_horizontal_positions + + subroutine create_horizontal_positions(positions, surface_element_list, vertical_normal, surface_name) ! adds a "boundary condition" to 'positions' with an associated vector surface field containing a dim-1 ! horizontal coordinate field that can be used to map from the surface mesh specified ! by 'surface_element_list'. This "boundary condition" will be stored under the name 'surface_name' - type(vector_field), intent(inout):: positions - type(vector_field), intent(in):: vertical_normal - integer, dimension(:), intent(in):: surface_element_list - character(len=*), intent(in):: surface_name - - type(vector_field) :: surface_positions, horizontal_positions - type(scalar_field) :: redundant_scalar_field - type(mesh_type), pointer:: surface_mesh - type(mesh_type) :: redundant_mesh, redundant_sphere_mesh - type(halo_type), pointer:: halo - real, dimension(vertical_normal%dim) :: normal_vector - integer, dimension(:), pointer:: surface_node_list, element_list, reduced_surface_element_list - integer, dimension(:), allocatable:: nodes, owned_elements - integer:: i, j, sele - integer:: nprocs, owner, procno, nowned - logical parallel_not_extruded - - call add_boundary_condition_surface_elements(positions, & - name=surface_name, type="verticalextrapolation", & - surface_element_list=surface_element_list) - ! now get back the created surface mesh - ! and surface_node_list a mapping between nodes in surface_mesh and nodes in positions%mesh - call get_boundary_condition(positions, name=surface_name, & - surface_mesh=surface_mesh, surface_node_list=surface_node_list) - - parallel_not_extruded = IsParallel() .and. option_count('/geometry/mesh/from_mesh/extrude')==0 - - if (parallel_not_extruded) then - allocate(nodes(1: surface_mesh%shape%loc), owned_elements(1:element_count(surface_mesh))) - nprocs = getnprocs() - procno = getprocno() - halo => positions%mesh%halos(2) - nowned = 0 - do i=1, element_count(surface_mesh) - sele = surface_element_list(i) - nodes = face_global_nodes(positions, sele) - owner = nprocs - do j=1, face_loc(positions, sele) - owner = min(owner, halo_node_owner(halo, nodes(j))) + type(vector_field), intent(inout):: positions + type(vector_field), intent(in):: vertical_normal + integer, dimension(:), intent(in):: surface_element_list + character(len=*), intent(in):: surface_name + + type(vector_field) :: surface_positions, horizontal_positions + type(scalar_field) :: redundant_scalar_field + type(mesh_type), pointer:: surface_mesh + type(mesh_type) :: redundant_mesh, redundant_sphere_mesh + type(halo_type), pointer:: halo + real, dimension(vertical_normal%dim) :: normal_vector + integer, dimension(:), pointer:: surface_node_list, element_list, reduced_surface_element_list + integer, dimension(:), allocatable:: nodes, owned_elements + integer:: i, j, sele + integer:: nprocs, owner, procno, nowned + logical parallel_not_extruded + + call add_boundary_condition_surface_elements(positions, & + name=surface_name, type="verticalextrapolation", & + surface_element_list=surface_element_list) + ! now get back the created surface mesh + ! and surface_node_list a mapping between nodes in surface_mesh and nodes in positions%mesh + call get_boundary_condition(positions, name=surface_name, & + surface_mesh=surface_mesh, surface_node_list=surface_node_list) + + parallel_not_extruded = IsParallel() .and. option_count('/geometry/mesh/from_mesh/extrude')==0 + + if (parallel_not_extruded) then + allocate(nodes(1: surface_mesh%shape%loc), owned_elements(1:element_count(surface_mesh))) + nprocs = getnprocs() + procno = getprocno() + halo => positions%mesh%halos(2) + nowned = 0 + do i=1, element_count(surface_mesh) + sele = surface_element_list(i) + nodes = face_global_nodes(positions, sele) + owner = nprocs + do j=1, face_loc(positions, sele) + owner = min(owner, halo_node_owner(halo, nodes(j))) + end do + if (owner/=procno) cycle + nowned = nowned + 1 + owned_elements(nowned) = i + end do + + call remove_boundary_condition(positions, surface_name) + call add_boundary_condition_surface_elements(positions, surface_name, & + "_internal", surface_element_list(owned_elements(1:nowned))) + ! re-obtain bc info based on the new reduced surface mesh + call get_boundary_condition(positions, surface_name, surface_mesh=surface_mesh, & + surface_node_list=surface_node_list, surface_element_list=reduced_surface_element_list) + + ! create redundant version of surface mesh with massive halo that represent the entire global surface mesh + redundant_mesh = create_parallel_redundant_mesh(surface_mesh) + + call allocate(surface_positions, positions%dim, redundant_mesh, "VerticalExtrapolationSurfaceCoordinate") + ! the owned nodes in the redundant mesh are all the nodes in the (reduced) surface mesh + ! even if they were not owned (receive *nodes*) in positions%mesh + assert(halo_nowned_nodes(redundant_mesh%halos(1)) == size(surface_node_list)) + ! their value can be set by remapping only going through reduced_surface_element_list, which are the + ! first size(reduced_surface_element_list) elements in redundant_mesh, i.e. we only go through a subset of + ! the elements of surface_positions + call remap_field_to_surface(positions, surface_positions, reduced_surface_element_list) + ! the rest of the elements are (surface) elements owned by other processes, the nodes in these elements are + ! all considered owned by these other processes. To simplify, nodes are duplicated if contained in elements + ! owned by different processes. All these receive nodes are updated in the following halo update in which all processes send + ! their owned nodes (according to redundant_mesh) to *all* other processes + call halo_update(surface_positions) + + else + call allocate(surface_positions, positions%dim, surface_mesh, "VerticalExtrapolationSurfaceCoordinate") + call remap_field_to_surface(positions, surface_positions, surface_element_list) + end if + + if (have_option('/geometry/spherical_earth')) then + call allocate(surface_positions, dim=positions%dim, mesh=surface_mesh, & + name="TempSurfacePositions") + call remap_field_to_surface(positions, surface_positions, surface_element_list) + call create_horizontal_positions_sphere(surface_positions, & + horizontal_positions, element_list, surface_name) + + if (.not. parallel_not_extruded) then + call remove_boundary_condition(positions, surface_name) + call add_boundary_condition_surface_elements(positions, surface_name, & + "_internal", surface_element_list(element_list)) + else + call allocate(redundant_sphere_mesh, node_count(redundant_mesh), element_count(horizontal_positions), & + surface_mesh%shape, name=redundant_mesh%name) + do i=1, element_count(horizontal_positions) + call set_ele_nodes(redundant_sphere_mesh, i, ele_nodes(redundant_mesh, element_list(i))) + end do + allocate(redundant_sphere_mesh%halos(1)) + redundant_sphere_mesh%halos(1) = redundant_mesh%halos(1) + call incref(redundant_sphere_mesh%halos(1)) + call deallocate(redundant_mesh) + redundant_mesh = redundant_sphere_mesh + end if + deallocate(element_list) + + else + + ! flat case + + assert(vertical_normal%field_type==FIELD_TYPE_CONSTANT) + normal_vector=node_val(vertical_normal, 1) + + call allocate(horizontal_positions, dim=positions%dim-1, mesh=surface_positions%mesh, & + name=trim(surface_name)//"HorizontalCoordinate" ) + do i=1, node_count(surface_positions) + call set(horizontal_positions, i, & + map2horizontal(node_val(surface_positions, i), normal_vector)) + end do + end if + + call insert_surface_field(positions, name=surface_name, & + surface_field=horizontal_positions) + + call deallocate(surface_positions) + call deallocate(horizontal_positions) + + if (parallel_not_extruded) then + call allocate(redundant_scalar_field, redundant_mesh, name=trim(positions%mesh%name)//"RedundantField") + call insert_surface_field(positions, surface_name, redundant_scalar_field) + call deallocate(redundant_scalar_field) + call deallocate(redundant_mesh) + end if + + end subroutine create_horizontal_positions + + subroutine create_horizontal_positions_sphere(surface_positions, & + horizontal_positions, element_map, mesh_name) + type(vector_field), intent(in) :: surface_positions + type(vector_field), intent(out) :: horizontal_positions + integer, dimension(:), pointer :: element_map + character(len=*), intent(in):: mesh_name + + type(mesh_type) :: horizontal_mesh + real, dimension(1:surface_positions%dim, ele_loc(surface_positions,1)) :: xyz + real, dimension(:,:), allocatable :: hxy + integer, dimension(:), allocatable :: ele_start + real shift + integer ele, i, nele, dim, nloc + + dim = surface_positions%dim + nloc = size(xyz, 2) + + allocate(hxy(dim-1, nloc*element_count(surface_positions)*3)) + allocate(ele_start(1:element_count(surface_positions)+1)) + + nele = 0 + do ele = 1, element_count(surface_positions) + xyz = ele_val(surface_positions, ele) + ele_start(ele) = nele + 1 + do i = 1, dim + if (all(abs(xyz(:,:)/spread(xyz(i,:),1,dim))0.) .or. all(xyz(i,:)<0.))) cycle + shift = sign(3*i*GNOMONIC_BOX_WIDTH, xyz(i,1)) + nele = nele + 1 + call add_horizontal_ele(hxy(:, (nele-1)*nloc+1:nele*nloc), i, shift) + end if + end do + if (nele0.) .or. all(xyz(i,:)<0.))) cycle - shift = sign(3*i*GNOMONIC_BOX_WIDTH, xyz(i,1)) - nele = nele + 1 - call add_horizontal_ele(hxy(:, (nele-1)*nloc+1:nele*nloc), i, shift) + ! preliminary matrix: + allocate( mat(1:entries), findrm(1:rows+1), & + colm(1:entries) ) + + if (.not. present(surface_mesh)) then + ! We use the entire surface mesh of 'mesh' + lsurface_mesh => mesh%faces%surface_mesh + ! Not all surface nodes may be used (i.e. interpolated from) - even + ! within surface elements that /are/ in surface_element-list. + ! We need a map between global surface node numbering and + ! a consecutive numbering of used surface nodes. + ! (this will be the column numbering) + allocate(snod2used_snod(1:node_count(lsurface_mesh))) + snod2used_snod=0 + count=0 ! counts number of used surface nodes + else + lsurface_mesh => surface_mesh + ! seles are facet element numbers in 'mesh' + ! need to invert surface_element_list to convert these to element numbers in surface_mesh + call invert_set(surface_element_list, facet2sele) + do i=1, size(seles) + seles(i) = fetch(facet2sele, seles(i)) + end do end if - end do - if (nele mesh%faces%surface_mesh - ! Not all surface nodes may be used (i.e. interpolated from) - even - ! within surface elements that /are/ in surface_element-list. - ! We need a map between global surface node numbering and - ! a consecutive numbering of used surface nodes. - ! (this will be the column numbering) - allocate(snod2used_snod(1:node_count(lsurface_mesh))) - snod2used_snod=0 - count=0 ! counts number of used surface nodes - else - lsurface_mesh => surface_mesh - ! seles are facet element numbers in 'mesh' - ! need to invert surface_element_list to convert these to element numbers in surface_mesh - call invert_set(surface_element_list, facet2sele) - do i=1, size(seles) - seles(i) = fetch(facet2sele, seles(i)) - end do - end if - - allocate(coefs(1:lsurface_mesh%shape%loc)) - entries=0 ! this time only count nonzero entries - do i=1, rows - - ! beginning of each row in mat - findrm(i)=entries+1 - - sele = seles(i) - snodes => ele_nodes(lsurface_mesh, sele) - coefs = eval_shape(ele_shape(lsurface_mesh, sele), loc_coords(:,i)) - - do j=1, size(snodes) - snod=snodes(j) - if (abs(coefs(j))>COEF_EPS) then - if (.not. present(surface_mesh)) then - if (snod2used_snod(snod)==0) then - ! as of yet unused surface node - count=count+1 - snod2used_snod(snod)=count - end if - ! this is the column index we're gonna use instead - snod=snod2used_snod(snod) - end if - entries=entries+1 - colm(entries)=snod - mat(entries)=coefs(j) - end if - end do - - end do - findrm(i)=entries+1 - - if (present(surface_mesh)) then - ! we haven't counted used surface nodes, instead we're using all - ! nodes of surface mesh as columns - count=node_count(surface_mesh) - end if - - call allocate(sparsity, rows, count, & - entries, diag=.false., name="VerticalProlongationSparsity") - sparsity%findrm=findrm - sparsity%colm=colm(1:entries) - ! for lots of applications it's good to have sorted rows - call sparsity_sort(sparsity) - - call allocate(VerticalProlongationOperator, sparsity, & - name="VerticalProlongationOperator") - call deallocate(sparsity) - - ! as the sparsity has been sorted the ordering of mat(:) no longer - ! matches that of sparsity%colm, however it still matches the original - ! unsorted colm(:) - do i=1, rows - do k=findrm(i), findrm(i+1)-1 - j=colm(k) - call set(VerticalProlongationOperator, i, j, mat(k)) - end do - end do - - if (.not. present(surface_mesh)) then - deallocate( snod2used_snod ) - else - call deallocate(facet2sele) - end if - deallocate( findrm, colm, mat, coefs ) - deallocate( seles, loc_coords ) - - call remove_boundary_condition(positions, "TempSurfaceName") - -end function VerticalProlongationOperator - -subroutine vertical_element_ordering(ordered_elements, face_normal_gravity, optimal_ordering) + allocate(coefs(1:lsurface_mesh%shape%loc)) + entries=0 ! this time only count nonzero entries + do i=1, rows + + ! beginning of each row in mat + findrm(i)=entries+1 + + sele = seles(i) + snodes => ele_nodes(lsurface_mesh, sele) + coefs = eval_shape(ele_shape(lsurface_mesh, sele), loc_coords(:,i)) + + do j=1, size(snodes) + snod=snodes(j) + if (abs(coefs(j))>COEF_EPS) then + if (.not. present(surface_mesh)) then + if (snod2used_snod(snod)==0) then + ! as of yet unused surface node + count=count+1 + snod2used_snod(snod)=count + end if + ! this is the column index we're gonna use instead + snod=snod2used_snod(snod) + end if + entries=entries+1 + colm(entries)=snod + mat(entries)=coefs(j) + end if + end do + + end do + findrm(i)=entries+1 + + if (present(surface_mesh)) then + ! we haven't counted used surface nodes, instead we're using all + ! nodes of surface mesh as columns + count=node_count(surface_mesh) + end if + + call allocate(sparsity, rows, count, & + entries, diag=.false., name="VerticalProlongationSparsity") + sparsity%findrm=findrm + sparsity%colm=colm(1:entries) + ! for lots of applications it's good to have sorted rows + call sparsity_sort(sparsity) + + call allocate(VerticalProlongationOperator, sparsity, & + name="VerticalProlongationOperator") + call deallocate(sparsity) + + ! as the sparsity has been sorted the ordering of mat(:) no longer + ! matches that of sparsity%colm, however it still matches the original + ! unsorted colm(:) + do i=1, rows + do k=findrm(i), findrm(i+1)-1 + j=colm(k) + call set(VerticalProlongationOperator, i, j, mat(k)) + end do + end do + + if (.not. present(surface_mesh)) then + deallocate( snod2used_snod ) + else + call deallocate(facet2sele) + end if + deallocate( findrm, colm, mat, coefs ) + deallocate( seles, loc_coords ) + + call remove_boundary_condition(positions, "TempSurfaceName") + + end function VerticalProlongationOperator + + subroutine vertical_element_ordering(ordered_elements, face_normal_gravity, optimal_ordering) !!< Calculates an element ordering such that each element is !!< is preceded by all elements above it. -integer, dimension(:), intent(out):: ordered_elements + integer, dimension(:), intent(out):: ordered_elements !! need to supply face_normal_gravity matrix, !! created by compute_face_normal_gravity() subroutine below -type(csr_matrix), intent(in):: face_normal_gravity + type(csr_matrix), intent(in):: face_normal_gravity !! returns .true. if an optimal ordering is found, i.e there are no !! cycles, i.o.w. elements that are (indirectly) above and below each other !! at the same time (deck of cards problem). -logical, optional, intent(out):: optimal_ordering - - type(dynamic_bin_type) dbin - real, dimension(:), pointer:: inn - integer, dimension(:), pointer:: neigh - integer, dimension(:), allocatable:: bin_list - integer i, j, elm, bin_no - logical warning - - assert( size(ordered_elements)==size(face_normal_gravity,1) ) - - ! create binlist, i.e. assign each element to a bin, according to - ! the number of elements above it - allocate(bin_list(1:size(ordered_elements))) - do i=1, size(ordered_elements) - neigh => row_m_ptr(face_normal_gravity, i) - inn => row_val_ptr(face_normal_gravity, i) - ! elements with no element above it go in bin 1 - ! elements with n elements above it go in bin n+1 - ! neigh>0 so we don't count exterior boundary faces - bin_list(i)=count( inn<-VERTICAL_INTEGRATION_EPS .and. neigh>0 )+1 - end do - - call allocate(dbin, bin_list) - - warning=.false. - do i=1, size(ordered_elements) - ! pull an element from the first non-empty bin - ! (hopefully an element with no unprocessed elements above) - call pull_element(dbin, elm, bin_no) - ordered_elements(i)=elm - ! if this is bin one then it is indeed an element with no unprocessed - ! elements above, otherwise issue a warning - if (bin_no>1) warning=.true. - - ! update elements below: - - ! adjacent elements: - neigh => row_m_ptr(face_normal_gravity, elm) - inn => row_val_ptr(face_normal_gravity, elm) - do j=1, size(neigh) - if (inn(j)>VERTICAL_INTEGRATION_EPS .and. neigh(j)>0) then - ! element neigh(j) is below element i, therefore now has one - ! less unprocessed element above it, so can be moved to - ! lower bin. - if (.not. element_pulled(dbin, neigh(j))) then - ! but only if neigh(j) itself hasn't been selected yet - ! (which might happen for imperfect vertical orderings) - call move_element(dbin, neigh(j), bin_list(neigh(j))-1) - end if - end if - end do - end do + logical, optional, intent(out):: optimal_ordering + + type(dynamic_bin_type) dbin + real, dimension(:), pointer:: inn + integer, dimension(:), pointer:: neigh + integer, dimension(:), allocatable:: bin_list + integer i, j, elm, bin_no + logical warning + + assert( size(ordered_elements)==size(face_normal_gravity,1) ) + + ! create binlist, i.e. assign each element to a bin, according to + ! the number of elements above it + allocate(bin_list(1:size(ordered_elements))) + do i=1, size(ordered_elements) + neigh => row_m_ptr(face_normal_gravity, i) + inn => row_val_ptr(face_normal_gravity, i) + ! elements with no element above it go in bin 1 + ! elements with n elements above it go in bin n+1 + ! neigh>0 so we don't count exterior boundary faces + bin_list(i)=count( inn<-VERTICAL_INTEGRATION_EPS .and. neigh>0 )+1 + end do - if (warning) then - ! this warning may be reduced (in verbosity level) if it occurs frequently: - ewrite(-1,*) "Warning: vertical_element_ordering has detected a cycle." - ewrite(-1,*) "(deck of cards problem). This may reduce the efficiency" - ewrite(-1,*) "of your vertically sweeping solve." - end if + call allocate(dbin, bin_list) + + warning=.false. + do i=1, size(ordered_elements) + ! pull an element from the first non-empty bin + ! (hopefully an element with no unprocessed elements above) + call pull_element(dbin, elm, bin_no) + ordered_elements(i)=elm + ! if this is bin one then it is indeed an element with no unprocessed + ! elements above, otherwise issue a warning + if (bin_no>1) warning=.true. + + ! update elements below: + + ! adjacent elements: + neigh => row_m_ptr(face_normal_gravity, elm) + inn => row_val_ptr(face_normal_gravity, elm) + do j=1, size(neigh) + if (inn(j)>VERTICAL_INTEGRATION_EPS .and. neigh(j)>0) then + ! element neigh(j) is below element i, therefore now has one + ! less unprocessed element above it, so can be moved to + ! lower bin. + if (.not. element_pulled(dbin, neigh(j))) then + ! but only if neigh(j) itself hasn't been selected yet + ! (which might happen for imperfect vertical orderings) + call move_element(dbin, neigh(j), bin_list(neigh(j))-1) + end if + end if + end do + end do - if (present(optimal_ordering)) then - optimal_ordering=.not. warning - end if + if (warning) then + ! this warning may be reduced (in verbosity level) if it occurs frequently: + ewrite(-1,*) "Warning: vertical_element_ordering has detected a cycle." + ewrite(-1,*) "(deck of cards problem). This may reduce the efficiency" + ewrite(-1,*) "of your vertically sweeping solve." + end if + + if (present(optimal_ordering)) then + optimal_ordering=.not. warning + end if - call deallocate(dbin) + call deallocate(dbin) -end subroutine vertical_element_ordering + end subroutine vertical_element_ordering -subroutine compute_face_normal_gravity(face_normal_gravity, & - positions, vertical_normal) + subroutine compute_face_normal_gravity(face_normal_gravity, & + positions, vertical_normal) !!< Returns a matrix where A_ij is the inner product of the face normal !!< and the gravity normal vector of the face between element i and j. -type(csr_matrix), intent(out):: face_normal_gravity -type(vector_field), target, intent(in):: positions, vertical_normal - - type(mesh_type), pointer:: mesh - real, dimension(:), pointer:: face_normal_gravity_val - real, dimension(:), allocatable:: detwei_f - real, dimension(:,:), allocatable:: face_normal, gravity_normal - integer, dimension(:), pointer:: neigh, faces - real inn, area - integer sngi, nloc, i, k - - mesh => positions%mesh - call allocate(face_normal_gravity, mesh%faces%face_list%sparsity) - call zero(face_normal_gravity) - - sngi=face_ngi(mesh, 1) - nloc=ele_loc(mesh,1) - allocate( detwei_f(1:sngi), & - face_normal(1:positions%dim, 1:sngi), & - gravity_normal(1:positions%dim, 1:sngi)) - - do i=1, element_count(mesh) - ! elements adjacent to element i - ! this is a row (column indices) in the mesh%faces%face_list matrix - neigh => ele_neigh(mesh, i) - ! the surrounding faces - ! this is a row (integer values) in the mesh%faces%face_list matrix - faces => ele_faces(mesh, i) - do k=1, size(neigh) - if (neigh(k)>i .or. neigh(k)<=0) then - ! only handling neigh(k)>i to ensure anti-symmetry of the matrix - ! (and more efficient of course) - call transform_facet_to_physical(positions, faces(k), & - detwei_f=detwei_f, & - normal=face_normal) - gravity_normal=face_val_at_quad(vertical_normal, faces(k)) - area=sum(detwei_f) - ! inner product of face normal and vertical normal - ! integrated over face - inn=sum(matmul(face_normal*gravity_normal, detwei_f))/area - if (neigh(k)>0) then - call set(face_normal_gravity, i, neigh(k), inn) - call set(face_normal_gravity, neigh(k), i, -inn) - else - ! exterior surface: matrix entry does not have valid - ! column index, still want to store its value, so we - ! use a pointer - face_normal_gravity_val => row_val_ptr(face_normal_gravity, i) - face_normal_gravity_val(k)=inn - end if - end if - end do - - end do - -end subroutine compute_face_normal_gravity - -subroutine vertical_integration_scalar(from_field, to_field, & - positions, vertical_normal, surface_element_list, rhs) + type(csr_matrix), intent(out):: face_normal_gravity + type(vector_field), target, intent(in):: positions, vertical_normal + + type(mesh_type), pointer:: mesh + real, dimension(:), pointer:: face_normal_gravity_val + real, dimension(:), allocatable:: detwei_f + real, dimension(:,:), allocatable:: face_normal, gravity_normal + integer, dimension(:), pointer:: neigh, faces + real inn, area + integer sngi, nloc, i, k + + mesh => positions%mesh + call allocate(face_normal_gravity, mesh%faces%face_list%sparsity) + call zero(face_normal_gravity) + + sngi=face_ngi(mesh, 1) + nloc=ele_loc(mesh,1) + allocate( detwei_f(1:sngi), & + face_normal(1:positions%dim, 1:sngi), & + gravity_normal(1:positions%dim, 1:sngi)) + + do i=1, element_count(mesh) + ! elements adjacent to element i + ! this is a row (column indices) in the mesh%faces%face_list matrix + neigh => ele_neigh(mesh, i) + ! the surrounding faces + ! this is a row (integer values) in the mesh%faces%face_list matrix + faces => ele_faces(mesh, i) + do k=1, size(neigh) + if (neigh(k)>i .or. neigh(k)<=0) then + ! only handling neigh(k)>i to ensure anti-symmetry of the matrix + ! (and more efficient of course) + call transform_facet_to_physical(positions, faces(k), & + detwei_f=detwei_f, & + normal=face_normal) + gravity_normal=face_val_at_quad(vertical_normal, faces(k)) + area=sum(detwei_f) + ! inner product of face normal and vertical normal + ! integrated over face + inn=sum(matmul(face_normal*gravity_normal, detwei_f))/area + if (neigh(k)>0) then + call set(face_normal_gravity, i, neigh(k), inn) + call set(face_normal_gravity, neigh(k), i, -inn) + else + ! exterior surface: matrix entry does not have valid + ! column index, still want to store its value, so we + ! use a pointer + face_normal_gravity_val => row_val_ptr(face_normal_gravity, i) + face_normal_gravity_val(k)=inn + end if + end if + end do + + end do + + end subroutine compute_face_normal_gravity + + subroutine vertical_integration_scalar(from_field, to_field, & + positions, vertical_normal, surface_element_list, rhs) !!< See description vertical_integration_multiple -type(scalar_field), intent(in):: from_field -type(scalar_field), intent(in):: to_field -type(vector_field), intent(in):: positions, vertical_normal -integer, dimension(:), intent(in):: surface_element_list -type(scalar_field), optional, intent(in):: rhs - - type(scalar_field) to_fields(1) - - to_fields=(/ to_field /) - if (present(rhs)) then - call vertical_integration_multiple( (/ from_field /), to_fields, & - positions, vertical_normal, surface_element_list, rhs=(/ rhs /) ) - else - call vertical_integration_multiple( (/ from_field /), to_fields, & - positions, vertical_normal, surface_element_list) - end if - -end subroutine vertical_integration_scalar - -subroutine vertical_integration_vector(from_field, to_field, & - positions, vertical_normal, surface_element_list, rhs) + type(scalar_field), intent(in):: from_field + type(scalar_field), intent(in):: to_field + type(vector_field), intent(in):: positions, vertical_normal + integer, dimension(:), intent(in):: surface_element_list + type(scalar_field), optional, intent(in):: rhs + + type(scalar_field) to_fields(1) + + to_fields=(/ to_field /) + if (present(rhs)) then + call vertical_integration_multiple( (/ from_field /), to_fields, & + positions, vertical_normal, surface_element_list, rhs=(/ rhs /) ) + else + call vertical_integration_multiple( (/ from_field /), to_fields, & + positions, vertical_normal, surface_element_list) + end if + + end subroutine vertical_integration_scalar + + subroutine vertical_integration_vector(from_field, to_field, & + positions, vertical_normal, surface_element_list, rhs) !!< See description vertical_integration_multiple -type(vector_field), intent(in):: from_field -type(vector_field), intent(in):: to_field -type(vector_field), intent(in):: positions, vertical_normal -integer, dimension(:), intent(in):: surface_element_list -type(vector_field), optional, intent(in):: rhs - - type(scalar_field), dimension(from_field%dim):: from_field_components, & - to_field_components, rhs_components - integer i - - assert(from_field%dim==to_field%dim) - - do i=1, from_field%dim - from_field_components(i)=extract_scalar_field(from_field, i) - to_field_components(i)=extract_scalar_field(to_field, i) - if (present(rhs)) then - rhs_components(i)=extract_scalar_field(rhs, i) - end if - end do - - if (present(rhs)) then - call vertical_integration_multiple( from_field_components, & - to_field_components, positions, vertical_normal, & - surface_element_list, rhs=rhs_components) - else - call vertical_integration_multiple( from_field_components, & - to_field_components, positions, vertical_normal, & - surface_element_list) - end if - -end subroutine vertical_integration_vector - -subroutine vertical_integration_multiple(from_fields, to_fields, & - positions, vertical_normal, surface_element_list, rhs) + type(vector_field), intent(in):: from_field + type(vector_field), intent(in):: to_field + type(vector_field), intent(in):: positions, vertical_normal + integer, dimension(:), intent(in):: surface_element_list + type(vector_field), optional, intent(in):: rhs + + type(scalar_field), dimension(from_field%dim):: from_field_components, & + to_field_components, rhs_components + integer i + + assert(from_field%dim==to_field%dim) + + do i=1, from_field%dim + from_field_components(i)=extract_scalar_field(from_field, i) + to_field_components(i)=extract_scalar_field(to_field, i) + if (present(rhs)) then + rhs_components(i)=extract_scalar_field(rhs, i) + end if + end do + + if (present(rhs)) then + call vertical_integration_multiple( from_field_components, & + to_field_components, positions, vertical_normal, & + surface_element_list, rhs=rhs_components) + else + call vertical_integration_multiple( from_field_components, & + to_field_components, positions, vertical_normal, & + surface_element_list) + end if + + end subroutine vertical_integration_vector + + subroutine vertical_integration_multiple(from_fields, to_fields, & + positions, vertical_normal, surface_element_list, rhs) !!< This subroutine solves: dP/dz=rhs using DG !!< It can be used for vertical integration downwards (dP/dz=0) as a drop !!< in replacement of VerticalExtrapolation hence its similar interface. @@ -1192,174 +1192,174 @@ subroutine vertical_integration_multiple(from_fields, to_fields, & !!< If not specified rhs is assumed zero. !!< !!< This version accepts multiple from_fields, to_fields and rhs -type(scalar_field), dimension(:), intent(in):: from_fields -type(scalar_field), dimension(:), intent(inout):: to_fields -type(vector_field), intent(in):: positions, vertical_normal -integer, dimension(:), intent(in):: surface_element_list -type(scalar_field), dimension(:), optional, intent(in):: rhs - - type(csr_matrix) face_normal_gravity - type(element_type), pointer:: ele_shp, face_shp, x_face_shp - real, dimension(:), pointer:: inn - real, dimension(:,:,:), allocatable:: surface_rhs, dele_shp - real, dimension(:,:), allocatable:: ele_mat, face_mat, ele_rhs - real, dimension(:), allocatable:: detwei, detwei_f - integer, dimension(:), pointer:: neigh, ele_nds, faces, face_lnds - integer, dimension(:), allocatable:: ordered_elements, face_nds, face_nds2 - integer nloc, snloc, ngi, sngi - integer i, j, k, f, f2, elm, it, noit - logical optimal_ordering, from_surface_fields - - assert( size(from_fields)==size(to_fields) ) - - ! computes inner product of face normal and gravity (see above) - call compute_face_normal_gravity(face_normal_gravity, & - positions, vertical_normal) - - ! determine an ordering for the elements based on this - allocate( ordered_elements(1:element_count(positions)) ) - call vertical_element_ordering(ordered_elements, face_normal_gravity, & - optimal_ordering) - - ! General initalisation - !----------------------- - ! various grid numbers - nloc=ele_loc(to_fields(1), 1) - snloc=face_loc(to_fields(1), 1) - ngi=ele_ngi(positions, 1) - sngi=face_ngi(positions, 1) - ! shape functions - ele_shp => ele_shape(to_fields(1), 1) - face_shp => face_shape(to_fields(1), 1) - x_face_shp => face_shape(positions, 1) - ! various allocations: - allocate( & - surface_rhs(1:snloc, 1:size(to_fields), 1:surface_element_count(positions)), & - ele_mat(1:nloc, 1:nloc), ele_rhs(1:nloc,1:size(to_fields)), & - dele_shp(1:nloc, 1:ngi, 1:positions%dim), & - face_mat(1:snloc, 1:snloc), face_nds(1:snloc), face_nds2(1:snloc), & - detwei(1:ngi), detwei_f(1:sngi)) - - if (element_count(from_fields(1))==size(surface_element_list)) then - ! from_fields are fields over the surface mesh only - ! so we're using all of its values: - from_surface_fields=.true. - ! check the other fields as well: - do k=2, size(from_fields) - assert( element_count(from_fields(k))==size(surface_element_list) ) - end do - else - ! from_fields are on the full mesh and we only extract its values - ! at the specified elements - - from_surface_fields=.false. - end if - - surface_rhs=0 - ! Compute contribution of exterior surface integral (boundary condition) to rhs - !----------------------- - do i=1, size(surface_element_list) - f=surface_element_list(i) - call transform_facet_to_physical(positions, f, detwei_f) - face_mat=-shape_shape(face_shp, face_shp, detwei_f) - do k=1, size(from_fields) - if (from_surface_fields) then - ! we need to use ele_val, where i is the element number in the surface_mesh - surface_rhs(:,k,f)=surface_rhs(:,k,f)+ & - matmul(face_mat, ele_val(from_fields(k), i)) - else - ! we can simply use face_val with face number f - surface_rhs(:,k,f)=surface_rhs(:,k,f)+ & - matmul(face_mat, face_val(from_fields(k), f)) - end if - end do - end do - - ! Solution loop - !----------------------- - if (optimal_ordering) then - noit=1 - else - noit=10 - end if - - do it=1, noit - do i=1, element_count(positions) - - elm=ordered_elements(i) - - ! construct diagonal matrix block for this element - call transform_to_physical(positions, elm, & - shape=ele_shp, dshape=dele_shp, detwei=detwei) - ele_mat=shape_vector_dot_dshape(ele_shp, & - ele_val_at_quad(vertical_normal,elm), & - dele_shp, detwei) - - ! initialise rhs - if (present(rhs)) then - do k=1, size(to_fields) - ele_rhs(:,k)=shape_rhs(ele_shp, detwei*ele_val_at_quad(rhs(k), elm)) - end do - else - ele_rhs=0.0 - end if - - - ! then add contribution of surface integrals of incoming - ! faces to the rhs and matrix - neigh => row_m_ptr(face_normal_gravity, elm) - inn => row_val_ptr(face_normal_gravity, elm) - faces => ele_faces(positions, elm) - do j=1, size(neigh) - if (inn(j)<-VERTICAL_INTEGRATION_EPS) then - call transform_facet_to_physical(positions, faces(j), & - detwei_f) - face_mat=-shape_shape(face_shp, face_shp, detwei_f)*inn(j) - - face_nds=face_global_nodes(to_fields(1), faces(j)) - face_lnds => face_local_nodes(to_fields(1)%mesh, faces(j)) - ele_mat(face_lnds,face_lnds)=ele_mat(face_lnds,face_lnds)+face_mat - - if (neigh(j)>0) then - ! face of element neigh(j), facing elm: - f2=ele_face(positions, neigh(j), elm) - face_nds2=face_global_nodes(to_fields(1), f2) + type(scalar_field), dimension(:), intent(in):: from_fields + type(scalar_field), dimension(:), intent(inout):: to_fields + type(vector_field), intent(in):: positions, vertical_normal + integer, dimension(:), intent(in):: surface_element_list + type(scalar_field), dimension(:), optional, intent(in):: rhs + + type(csr_matrix) face_normal_gravity + type(element_type), pointer:: ele_shp, face_shp, x_face_shp + real, dimension(:), pointer:: inn + real, dimension(:,:,:), allocatable:: surface_rhs, dele_shp + real, dimension(:,:), allocatable:: ele_mat, face_mat, ele_rhs + real, dimension(:), allocatable:: detwei, detwei_f + integer, dimension(:), pointer:: neigh, ele_nds, faces, face_lnds + integer, dimension(:), allocatable:: ordered_elements, face_nds, face_nds2 + integer nloc, snloc, ngi, sngi + integer i, j, k, f, f2, elm, it, noit + logical optimal_ordering, from_surface_fields + + assert( size(from_fields)==size(to_fields) ) + + ! computes inner product of face normal and gravity (see above) + call compute_face_normal_gravity(face_normal_gravity, & + positions, vertical_normal) + + ! determine an ordering for the elements based on this + allocate( ordered_elements(1:element_count(positions)) ) + call vertical_element_ordering(ordered_elements, face_normal_gravity, & + optimal_ordering) + + ! General initalisation + !----------------------- + ! various grid numbers + nloc=ele_loc(to_fields(1), 1) + snloc=face_loc(to_fields(1), 1) + ngi=ele_ngi(positions, 1) + sngi=face_ngi(positions, 1) + ! shape functions + ele_shp => ele_shape(to_fields(1), 1) + face_shp => face_shape(to_fields(1), 1) + x_face_shp => face_shape(positions, 1) + ! various allocations: + allocate( & + surface_rhs(1:snloc, 1:size(to_fields), 1:surface_element_count(positions)), & + ele_mat(1:nloc, 1:nloc), ele_rhs(1:nloc,1:size(to_fields)), & + dele_shp(1:nloc, 1:ngi, 1:positions%dim), & + face_mat(1:snloc, 1:snloc), face_nds(1:snloc), face_nds2(1:snloc), & + detwei(1:ngi), detwei_f(1:sngi)) + + if (element_count(from_fields(1))==size(surface_element_list)) then + ! from_fields are fields over the surface mesh only + ! so we're using all of its values: + from_surface_fields=.true. + ! check the other fields as well: + do k=2, size(from_fields) + assert( element_count(from_fields(k))==size(surface_element_list) ) + end do + else + ! from_fields are on the full mesh and we only extract its values + ! at the specified elements + + from_surface_fields=.false. + end if + + surface_rhs=0 + ! Compute contribution of exterior surface integral (boundary condition) to rhs + !----------------------- + do i=1, size(surface_element_list) + f=surface_element_list(i) + call transform_facet_to_physical(positions, f, detwei_f) + face_mat=-shape_shape(face_shp, face_shp, detwei_f) + do k=1, size(from_fields) + if (from_surface_fields) then + ! we need to use ele_val, where i is the element number in the surface_mesh + surface_rhs(:,k,f)=surface_rhs(:,k,f)+ & + matmul(face_mat, ele_val(from_fields(k), i)) + else + ! we can simply use face_val with face number f + surface_rhs(:,k,f)=surface_rhs(:,k,f)+ & + matmul(face_mat, face_val(from_fields(k), f)) + end if + end do + end do + ! Solution loop + !----------------------- + if (optimal_ordering) then + noit=1 + else + noit=10 + end if + + do it=1, noit + do i=1, element_count(positions) + + elm=ordered_elements(i) + + ! construct diagonal matrix block for this element + call transform_to_physical(positions, elm, & + shape=ele_shp, dshape=dele_shp, detwei=detwei) + ele_mat=shape_vector_dot_dshape(ele_shp, & + ele_val_at_quad(vertical_normal,elm), & + dele_shp, detwei) + + ! initialise rhs + if (present(rhs)) then do k=1, size(to_fields) - ele_rhs(face_lnds,k)=ele_rhs(face_lnds,k)+ & - matmul(face_mat, node_val(to_fields(k), face_nds2)) + ele_rhs(:,k)=shape_rhs(ele_shp, detwei*ele_val_at_quad(rhs(k), elm)) end do else - ! note that we've already multiplied with face_mat above, but not with inn(j) - ele_rhs(face_lnds,:)=ele_rhs(face_lnds,:)+surface_rhs(:,:,faces(j))*inn(j) + ele_rhs=0.0 end if - end if - end do - call invert(ele_mat) - ! compute values for the to_fields: - ele_nds => ele_nodes(to_fields(1), elm) - do k=1, size(to_fields) - call set( to_fields(k), ele_nds, matmul(ele_mat, ele_rhs(:,k)) ) - end do - end do - end do + ! then add contribution of surface integrals of incoming + ! faces to the rhs and matrix + neigh => row_m_ptr(face_normal_gravity, elm) + inn => row_val_ptr(face_normal_gravity, elm) + faces => ele_faces(positions, elm) + do j=1, size(neigh) + if (inn(j)<-VERTICAL_INTEGRATION_EPS) then + call transform_facet_to_physical(positions, faces(j), & + detwei_f) + face_mat=-shape_shape(face_shp, face_shp, detwei_f)*inn(j) + + face_nds=face_global_nodes(to_fields(1), faces(j)) + face_lnds => face_local_nodes(to_fields(1)%mesh, faces(j)) + ele_mat(face_lnds,face_lnds)=ele_mat(face_lnds,face_lnds)+face_mat + + if (neigh(j)>0) then + ! face of element neigh(j), facing elm: + f2=ele_face(positions, neigh(j), elm) + face_nds2=face_global_nodes(to_fields(1), f2) + + do k=1, size(to_fields) + ele_rhs(face_lnds,k)=ele_rhs(face_lnds,k)+ & + matmul(face_mat, node_val(to_fields(k), face_nds2)) + end do + else + ! note that we've already multiplied with face_mat above, but not with inn(j) + ele_rhs(face_lnds,:)=ele_rhs(face_lnds,:)+surface_rhs(:,:,faces(j))*inn(j) + end if + end if + end do + + call invert(ele_mat) + + ! compute values for the to_fields: + ele_nds => ele_nodes(to_fields(1), elm) + do k=1, size(to_fields) + call set( to_fields(k), ele_nds, matmul(ele_mat, ele_rhs(:,k)) ) + end do + end do + end do - call deallocate(face_normal_gravity) + call deallocate(face_normal_gravity) -end subroutine vertical_integration_multiple + end subroutine vertical_integration_multiple -subroutine vertical_extrapolation_module_check_options + subroutine vertical_extrapolation_module_check_options - if (have_option("/geometry/ocean_boundaries")) then - if (.not. have_option("/physical_parameters/gravity")) then - ewrite(-1,*) "If you select /geometry/ocean_boundaries, you also need to "//& - &"set /physical_parameters/gravity" - FLExit("Missing gravity!") - end if - end if + if (have_option("/geometry/ocean_boundaries")) then + if (.not. have_option("/physical_parameters/gravity")) then + ewrite(-1,*) "If you select /geometry/ocean_boundaries, you also need to "//& + &"set /physical_parameters/gravity" + FLExit("Missing gravity!") + end if + end if -end subroutine vertical_extrapolation_module_check_options + end subroutine vertical_extrapolation_module_check_options end module vertical_extrapolation_module diff --git a/femtools/Wandzura_Quadrature.F90 b/femtools/Wandzura_Quadrature.F90 index a05d26de0d..8dee8ed457 100644 --- a/femtools/Wandzura_Quadrature.F90 +++ b/femtools/Wandzura_Quadrature.F90 @@ -1,2080 +1,2080 @@ module wandzura_quadrature - use iso_c_binding, only: c_float, c_double - - implicit none - - interface wandzura_rule - module procedure wandzura_rule_sp, wandzura_rule_orig - end interface wandzura_rule - - contains - function i4_wrap ( ival, ilo, ihi ) - - !*****************************************************************************80 - ! - !! I4_WRAP forces an I4 to lie between given limits by wrapping. - ! - ! Example: - ! - ! ILO = 4, IHI = 8 - ! - ! I Value - ! - ! -2 8 - ! -1 4 - ! 0 5 - ! 1 6 - ! 2 7 - ! 3 8 - ! 4 4 - ! 5 5 - ! 6 6 - ! 7 7 - ! 8 8 - ! 9 4 - ! 10 5 - ! 11 6 - ! 12 7 - ! 13 8 - ! 14 4 - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 19 August 2003 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) IVAL, an integer value. - ! - ! Input, integer ( kind = 4 ) ILO, IHI, the desired bounds for the integer value. - ! - ! Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of IVAL. - ! - implicit none - - integer ( kind = 4 ) i4_wrap - integer ( kind = 4 ) ihi - integer ( kind = 4 ) ilo - integer ( kind = 4 ) ival - integer ( kind = 4 ) jhi - integer ( kind = 4 ) jlo - integer ( kind = 4 ) value - integer ( kind = 4 ) wide - - jlo = min ( ilo, ihi ) - jhi = max ( ilo, ihi ) - - wide = jhi - jlo + 1 - - if ( wide == 1 ) then - value = jlo - else - value = jlo + i4_modp ( ival - jlo, wide ) - end if - - i4_wrap = value - - return - end function - subroutine file_name_inc ( file_name ) - - !*****************************************************************************80 - ! - !! FILE_NAME_INC increments a partially numeric filename. - ! - ! Discussion: - ! - ! It is assumed that the digits in the name, whether scattered or - ! connected, represent a number that is to be increased by 1 on - ! each call. If this number is all 9's on input, the output number - ! is all 0's. Non-numeric letters of the name are unaffected. - ! - ! If the name is empty, then the routine stops. - ! - ! If the name contains no digits, the empty string is returned. - ! - ! Example: - ! - ! Input Output - ! ----- ------ - ! 'a7to11.txt' 'a7to12.txt' - ! 'a7to99.txt' 'a8to00.txt' - ! 'a9to99.txt' 'a0to00.txt' - ! 'cat.txt' ' ' - ! ' ' STOP! - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 14 September 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input/output, character ( len = * ) FILE_NAME. - ! On input, a character string to be incremented. - ! On output, the incremented string. - ! - implicit none - - character c - integer ( kind = 4 ) change - integer ( kind = 4 ) digit - character ( len = * ) file_name - integer ( kind = 4 ) i - integer ( kind = 4 ) lens - - lens = len_trim ( file_name ) - - if ( lens <= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'FILE_NAME_INC - Fatal error!' - write ( *, '(a)' ) ' The input string is empty.' - stop - end if - - change = 0 - - do i = lens, 1, -1 - - c = file_name(i:i) - - if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then - - change = change + 1 - - digit = ichar ( c ) - 48 - digit = digit + 1 - - if ( digit == 10 ) then - digit = 0 - end if - - c = char ( digit + 48 ) - - file_name(i:i) = c - - if ( c /= '0' ) then - return - end if + use iso_c_binding, only: c_float, c_double + + implicit none + + interface wandzura_rule + module procedure wandzura_rule_sp, wandzura_rule_orig + end interface wandzura_rule + +contains + function i4_wrap ( ival, ilo, ihi ) + + !*****************************************************************************80 + ! + !! I4_WRAP forces an I4 to lie between given limits by wrapping. + ! + ! Example: + ! + ! ILO = 4, IHI = 8 + ! + ! I Value + ! + ! -2 8 + ! -1 4 + ! 0 5 + ! 1 6 + ! 2 7 + ! 3 8 + ! 4 4 + ! 5 5 + ! 6 6 + ! 7 7 + ! 8 8 + ! 9 4 + ! 10 5 + ! 11 6 + ! 12 7 + ! 13 8 + ! 14 4 + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 19 August 2003 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) IVAL, an integer value. + ! + ! Input, integer ( kind = 4 ) ILO, IHI, the desired bounds for the integer value. + ! + ! Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of IVAL. + ! + implicit none + + integer ( kind = 4 ) i4_wrap + integer ( kind = 4 ) ihi + integer ( kind = 4 ) ilo + integer ( kind = 4 ) ival + integer ( kind = 4 ) jhi + integer ( kind = 4 ) jlo + integer ( kind = 4 ) value + integer ( kind = 4 ) wide + + jlo = min ( ilo, ihi ) + jhi = max ( ilo, ihi ) + + wide = jhi - jlo + 1 + + if ( wide == 1 ) then + value = jlo + else + value = jlo + i4_modp ( ival - jlo, wide ) + end if + i4_wrap = value + + return + end function + subroutine file_name_inc ( file_name ) + + !*****************************************************************************80 + ! + !! FILE_NAME_INC increments a partially numeric filename. + ! + ! Discussion: + ! + ! It is assumed that the digits in the name, whether scattered or + ! connected, represent a number that is to be increased by 1 on + ! each call. If this number is all 9's on input, the output number + ! is all 0's. Non-numeric letters of the name are unaffected. + ! + ! If the name is empty, then the routine stops. + ! + ! If the name contains no digits, the empty string is returned. + ! + ! Example: + ! + ! Input Output + ! ----- ------ + ! 'a7to11.txt' 'a7to12.txt' + ! 'a7to99.txt' 'a8to00.txt' + ! 'a9to99.txt' 'a0to00.txt' + ! 'cat.txt' ' ' + ! ' ' STOP! + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 14 September 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input/output, character ( len = * ) FILE_NAME. + ! On input, a character string to be incremented. + ! On output, the incremented string. + ! + implicit none + + character c + integer ( kind = 4 ) change + integer ( kind = 4 ) digit + character ( len = * ) file_name + integer ( kind = 4 ) i + integer ( kind = 4 ) lens + + lens = len_trim ( file_name ) + + if ( lens <= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'FILE_NAME_INC - Fatal error!' + write ( *, '(a)' ) ' The input string is empty.' + stop end if - end do + change = 0 + + do i = lens, 1, -1 + + c = file_name(i:i) + + if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then + + change = change + 1 + + digit = ichar ( c ) - 48 + digit = digit + 1 + + if ( digit == 10 ) then + digit = 0 + end if + + c = char ( digit + 48 ) + + file_name(i:i) = c + + if ( c /= '0' ) then + return + end if + + end if + + end do + + if ( change == 0 ) then + file_name = ' ' + return + end if - if ( change == 0 ) then - file_name = ' ' return - end if - - return - end subroutine - subroutine get_unit ( iunit ) - - !*****************************************************************************80 - ! - !! GET_UNIT returns a free FORTRAN unit number. - ! - ! Discussion: - ! - ! A "free" FORTRAN unit number is an integer between 1 and 99 which - ! is not currently associated with an I/O device. A free FORTRAN unit - ! number is needed in order to open a file with the OPEN command. - ! - ! If IUNIT = 0, then no free FORTRAN unit could be found, although - ! all 99 units were checked (except for units 5, 6 and 9, which - ! are commonly reserved for console I/O). - ! - ! Otherwise, IUNIT is an integer between 1 and 99, representing a - ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 - ! are special, and will never return those values. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 18 September 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Output, integer ( kind = 4 ) IUNIT, the free unit number. - ! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) ios - integer ( kind = 4 ) iunit - logical lopen - - iunit = 0 - - do i = 1, 99 - - if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then - - inquire ( unit = i, opened = lopen, iostat = ios ) - - if ( ios == 0 ) then - if ( .not. lopen ) then - iunit = i - return - end if - end if + end subroutine + subroutine get_unit ( iunit ) + + !*****************************************************************************80 + ! + !! GET_UNIT returns a free FORTRAN unit number. + ! + ! Discussion: + ! + ! A "free" FORTRAN unit number is an integer between 1 and 99 which + ! is not currently associated with an I/O device. A free FORTRAN unit + ! number is needed in order to open a file with the OPEN command. + ! + ! If IUNIT = 0, then no free FORTRAN unit could be found, although + ! all 99 units were checked (except for units 5, 6 and 9, which + ! are commonly reserved for console I/O). + ! + ! Otherwise, IUNIT is an integer between 1 and 99, representing a + ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 + ! are special, and will never return those values. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 18 September 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Output, integer ( kind = 4 ) IUNIT, the free unit number. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) ios + integer ( kind = 4 ) iunit + logical lopen + + iunit = 0 + + do i = 1, 99 + + if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then + + inquire ( unit = i, opened = lopen, iostat = ios ) + + if ( ios == 0 ) then + if ( .not. lopen ) then + iunit = i + return + end if + end if + + end if + end do + + return + end subroutine + function i4_modp ( i, j ) + + !*****************************************************************************80 + ! + !! I4_MODP returns the nonnegative remainder of I4 division. + ! + ! Discussion: + ! + ! If + ! NREM = I4_MODP ( I, J ) + ! NMULT = ( I - NREM ) / J + ! then + ! I = J * NMULT + NREM + ! where NREM is always nonnegative. + ! + ! The MOD function computes a result with the same sign as the + ! quantity being divided. Thus, suppose you had an angle A, + ! and you wanted to ensure that it was between 0 and 360. + ! Then mod(A,360) would do, if A was positive, but if A + ! was negative, your result would be between -360 and 0. + ! + ! On the other hand, I4_MODP(A,360) is between 0 and 360, always. + ! + ! Example: + ! + ! I J MOD I4_MODP Factorization + ! + ! 107 50 7 7 107 = 2 * 50 + 7 + ! 107 -50 7 7 107 = -2 * -50 + 7 + ! -107 50 -7 43 -107 = -3 * 50 + 43 + ! -107 -50 -7 43 -107 = 3 * -50 + 43 + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 02 March 1999 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) I, the number to be divided. + ! + ! Input, integer ( kind = 4 ) J, the number that divides I. + ! + ! Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder when I is + ! divided by J. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_modp + integer ( kind = 4 ) j + integer ( kind = 4 ) value + + if ( j == 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'I4_MODP - Fatal error!' + write ( *, '(a,i8)' ) ' Illegal divisor J = ', j + stop end if - end do - - return - end subroutine - function i4_modp ( i, j ) - - !*****************************************************************************80 - ! - !! I4_MODP returns the nonnegative remainder of I4 division. - ! - ! Discussion: - ! - ! If - ! NREM = I4_MODP ( I, J ) - ! NMULT = ( I - NREM ) / J - ! then - ! I = J * NMULT + NREM - ! where NREM is always nonnegative. - ! - ! The MOD function computes a result with the same sign as the - ! quantity being divided. Thus, suppose you had an angle A, - ! and you wanted to ensure that it was between 0 and 360. - ! Then mod(A,360) would do, if A was positive, but if A - ! was negative, your result would be between -360 and 0. - ! - ! On the other hand, I4_MODP(A,360) is between 0 and 360, always. - ! - ! Example: - ! - ! I J MOD I4_MODP Factorization - ! - ! 107 50 7 7 107 = 2 * 50 + 7 - ! 107 -50 7 7 107 = -2 * -50 + 7 - ! -107 50 -7 43 -107 = -3 * 50 + 43 - ! -107 -50 -7 43 -107 = 3 * -50 + 43 - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 02 March 1999 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) I, the number to be divided. - ! - ! Input, integer ( kind = 4 ) J, the number that divides I. - ! - ! Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder when I is - ! divided by J. - ! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) i4_modp - integer ( kind = 4 ) j - integer ( kind = 4 ) value - - if ( j == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_MODP - Fatal error!' - write ( *, '(a,i8)' ) ' Illegal divisor J = ', j - stop - end if - - value = mod ( i, j ) - - if ( value < 0 ) then - value = value + abs ( j ) - end if - - i4_modp = value - - return - end function - subroutine reference_to_physical_t3 ( node_xy, n, ref, phy ) - - !*****************************************************************************80 - ! - !! REFERENCE_TO_PHYSICAL_T3 maps T3 reference points to physical points. - ! - ! Discussion: - ! - ! Given the vertices of an order 3 physical triangle and a point - ! (XSI,ETA) in the reference triangle, the routine computes the value - ! of the corresponding image point (X,Y) in physical space. - ! - ! This routine is also appropriate for an order 4 triangle, - ! as long as the fourth node is the centroid of the triangle. - ! - ! This routine may also be appropriate for an order 6 - ! triangle, if the mapping between reference and physical space - ! is linear. This implies, in particular, that the sides of the - ! image triangle are straight and that the "midside" nodes in the - ! physical triangle are literally halfway along the sides of - ! the physical triangle. - ! - ! Reference Element T3: - ! - ! | - ! 1 3 - ! | |\ - ! | | \ - ! S | \ - ! | | \ - ! | | \ - ! 0 1-----2 - ! | - ! +--0--R--1--> - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 May 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, real ( kind = 8 ) NODE_XY(2,3), the coordinates of the vertices. - ! The vertices are assumed to be the images of (0,0), (1,0) and - ! (0,1) respectively. - ! - ! Input, integer ( kind = 4 ) N, the number of objects to transform. - ! - ! Input, real ( kind = 8 ) REF(2,N), points in the reference triangle. - ! - ! Output, real ( kind = 8 ) PHY(2,N), corresponding points in the - ! physical triangle. - ! - implicit none - - integer ( kind = 4 ) n - - integer ( kind = 4 ) i - real ( kind = 8 ) node_xy(2,3) - real ( kind = 8 ) phy(2,n) - real ( kind = 8 ) ref(2,n) - - do i = 1, 2 - phy(i,1:n) = node_xy(i,1) * ( 1.0D+00 - ref(1,1:n) - ref(2,1:n) ) & - + node_xy(i,2) * ref(1,1:n) & - + node_xy(i,3) * ref(2,1:n) - end do - - return - end subroutine - subroutine timestamp ( ) - - !*****************************************************************************80 - ! - !! TIMESTAMP prints the current YMDHMS date as a time stamp. - ! - ! Example: - ! - ! 31 May 2001 9:45:54.872 AM - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 06 August 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! None - ! - implicit none - - character ( len = 8 ) ampm - integer ( kind = 4 ) d - integer ( kind = 4 ) h - integer ( kind = 4 ) m - integer ( kind = 4 ) mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer ( kind = 4 ) n - integer ( kind = 4 ) s - integer ( kind = 4 ) values(8) - integer ( kind = 4 ) y - - call date_and_time ( values = values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' + value = mod ( i, j ) + + if ( value < 0 ) then + value = value + abs ( j ) end if - else - h = h - 12 + + i4_modp = value + + return + end function + subroutine reference_to_physical_t3 ( node_xy, n, ref, phy ) + + !*****************************************************************************80 + ! + !! REFERENCE_TO_PHYSICAL_T3 maps T3 reference points to physical points. + ! + ! Discussion: + ! + ! Given the vertices of an order 3 physical triangle and a point + ! (XSI,ETA) in the reference triangle, the routine computes the value + ! of the corresponding image point (X,Y) in physical space. + ! + ! This routine is also appropriate for an order 4 triangle, + ! as long as the fourth node is the centroid of the triangle. + ! + ! This routine may also be appropriate for an order 6 + ! triangle, if the mapping between reference and physical space + ! is linear. This implies, in particular, that the sides of the + ! image triangle are straight and that the "midside" nodes in the + ! physical triangle are literally halfway along the sides of + ! the physical triangle. + ! + ! Reference Element T3: + ! + ! | + ! 1 3 + ! | |\ + ! | | \ + ! S | \ + ! | | \ + ! | | \ + ! 0 1-----2 + ! | + ! +--0--R--1--> + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 May 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, real ( kind = 8 ) NODE_XY(2,3), the coordinates of the vertices. + ! The vertices are assumed to be the images of (0,0), (1,0) and + ! (0,1) respectively. + ! + ! Input, integer ( kind = 4 ) N, the number of objects to transform. + ! + ! Input, real ( kind = 8 ) REF(2,N), points in the reference triangle. + ! + ! Output, real ( kind = 8 ) PHY(2,N), corresponding points in the + ! physical triangle. + ! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + real ( kind = 8 ) node_xy(2,3) + real ( kind = 8 ) phy(2,n) + real ( kind = 8 ) ref(2,n) + + do i = 1, 2 + phy(i,1:n) = node_xy(i,1) * ( 1.0D+00 - ref(1,1:n) - ref(2,1:n) ) & + + node_xy(i,2) * ref(1,1:n) & + + node_xy(i,3) * ref(2,1:n) + end do + + return + end subroutine + subroutine timestamp ( ) + + !*****************************************************************************80 + ! + !! TIMESTAMP prints the current YMDHMS date as a time stamp. + ! + ! Example: + ! + ! 31 May 2001 9:45:54.872 AM + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 06 August 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! None + ! + implicit none + + character ( len = 8 ) ampm + integer ( kind = 4 ) d + integer ( kind = 4 ) h + integer ( kind = 4 ) m + integer ( kind = 4 ) mm + character ( len = 9 ), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December ' /) + integer ( kind = 4 ) n + integer ( kind = 4 ) s + integer ( kind = 4 ) values(8) + integer ( kind = 4 ) y + + call date_and_time ( values = values ) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + if ( h < 12 ) then - ampm = 'PM' + ampm = 'AM' else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return - end subroutine - subroutine timestring ( string ) - - !*****************************************************************************80 - ! - !! TIMESTRING writes the current YMDHMS date into a string. - ! - ! Example: - ! - ! STRING = '31 May 2001 9:45:54.872 AM' - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 06 August 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Output, character ( len = * ) STRING, the date information. - ! A character length of 40 should always be sufficient. - ! - implicit none - - character ( len = 8 ) ampm - integer ( kind = 4 ) d - integer ( kind = 4 ) h - integer ( kind = 4 ) m - integer ( kind = 4 ) mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer ( kind = 4 ) n - integer ( kind = 4 ) s - character ( len = * ) string - integer ( kind = 4 ) values(8) - integer ( kind = 4 ) y - - call date_and_time ( values = values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' + if ( n == 0 .and. s == 0 ) then + ampm = 'Noon' + else + ampm = 'PM' + end if else - ampm = 'PM' + h = h - 12 + if ( h < 12 ) then + ampm = 'PM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if end if - else - h = h - 12 + + write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & + d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) + + return + end subroutine + subroutine timestring ( string ) + + !*****************************************************************************80 + ! + !! TIMESTRING writes the current YMDHMS date into a string. + ! + ! Example: + ! + ! STRING = '31 May 2001 9:45:54.872 AM' + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 06 August 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Output, character ( len = * ) STRING, the date information. + ! A character length of 40 should always be sufficient. + ! + implicit none + + character ( len = 8 ) ampm + integer ( kind = 4 ) d + integer ( kind = 4 ) h + integer ( kind = 4 ) m + integer ( kind = 4 ) mm + character ( len = 9 ), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December ' /) + integer ( kind = 4 ) n + integer ( kind = 4 ) s + character ( len = * ) string + integer ( kind = 4 ) values(8) + integer ( kind = 4 ) y + + call date_and_time ( values = values ) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + if ( h < 12 ) then - ampm = 'PM' + ampm = 'AM' else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if + if ( n == 0 .and. s == 0 ) then + ampm = 'Noon' + else + ampm = 'PM' + end if + else + h = h - 12 + if ( h < 12 ) then + ampm = 'PM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if end if - end if - - write ( string, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return - end subroutine - subroutine triangle_area ( node_xy, area ) - - !*****************************************************************************80 - ! - !! TRIANGLE_AREA computes the area of a triangle. - ! - ! Discussion: - ! - ! If the triangle's vertices are given in counterclockwise order, - ! the area will be positive. If the triangle's vertices are given - ! in clockwise order, the area will be negative! - ! - ! If you cannot guarantee counterclockwise order, and you need to - ! have the area positive, then you can simply take the absolute value - ! of the result of this routine. - ! - ! An earlier version of this routine always returned the absolute - ! value of the computed area. I am convinced now that that is - ! a less useful result! For instance, by returning the signed - ! area of a triangle, it is possible to easily compute the area - ! of a nonconvex polygon as the sum of the (possibly negative) - ! areas of triangles formed by node 1 and successive pairs of vertices. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 17 October 2005 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, real ( kind = 8 ) NODE_XY(2,3), the triangle vertices. - ! - ! Output, real ( kind = 8 ) AREA, the area of the triangle. - ! - implicit none - - real ( kind = 8 ) area - real ( kind = 8 ) node_xy(2,3) - - area = 0.5D+00 * ( & - node_xy(1,1) * ( node_xy(2,2) - node_xy(2,3) ) & - + node_xy(1,2) * ( node_xy(2,3) - node_xy(2,1) ) & - + node_xy(1,3) * ( node_xy(2,1) - node_xy(2,2) ) ) - - return - end subroutine - subroutine triangle_points_plot ( file_name, node_xy, node_show, point_num, & - point_xy, point_show ) - - !*****************************************************************************80 - ! - !! TRIANGLE_POINTS_PLOT plots a triangle and some points. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 03 October 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Parameters: - ! - ! Input, character ( len = * ) FILE_NAME, the name of the output file. - ! - ! Input, real ( kind = 8 ) NODE_XY(2,3), the coordinates of the nodes - ! of the triangle. - ! - ! Input, integer ( kind = 4 ) NODE_SHOW, - ! -1, do not show the triangle, or the nodes. - ! 0, show the triangle, do not show the nodes; - ! 1, show the triangle and the nodes; - ! 2, show the triangle, the nodes and number them. - ! - ! Input, integer ( kind = 4 ) POINT_NUM, the number of points. - ! - ! Input, real ( kind = 8 ) POINT_XY(2,POINT_NUM), the coordinates of the - ! points. - ! - ! Input, integer ( kind = 4 ) POINT_SHOW, - ! 0, do not show the points; - ! 1, show the points; - ! 2, show the points and number them. - ! - implicit none - - integer ( kind = 4 ), parameter :: node_num = 3 - integer ( kind = 4 ) point_num - - character ( len = 40 ) date_time - integer ( kind = 4 ) :: circle_size - integer ( kind = 4 ) delta - character ( len = * ) file_name - integer ( kind = 4 ) file_unit - integer ( kind = 4 ) i - integer ( kind = 4 ), parameter :: i4_1 = 1 - integer ( kind = 4 ), parameter :: i4_3 = 3 - integer ( kind = 4 ) ios - integer ( kind = 4 ) node - integer ( kind = 4 ) node_show - real ( kind = 8 ) node_xy(2,node_num) - integer ( kind = 4 ) point - integer ( kind = 4 ) point_show - real ( kind = 8 ) point_xy(2,point_num) - character ( len = 40 ) string - real ( kind = 8 ) x_max - real ( kind = 8 ) x_min - integer ( kind = 4 ) x_ps - integer ( kind = 4 ) :: x_ps_max = 576 - integer ( kind = 4 ) :: x_ps_max_clip = 594 - integer ( kind = 4 ) :: x_ps_min = 36 - integer ( kind = 4 ) :: x_ps_min_clip = 18 - real ( kind = 8 ) x_scale - real ( kind = 8 ) y_max - real ( kind = 8 ) y_min - integer ( kind = 4 ) y_ps - integer ( kind = 4 ) :: y_ps_max = 666 - integer ( kind = 4 ) :: y_ps_max_clip = 684 - integer ( kind = 4 ) :: y_ps_min = 126 - integer ( kind = 4 ) :: y_ps_min_clip = 108 - real ( kind = 8 ) y_scale - - call timestring ( date_time ) - ! - ! We need to do some figuring here, so that we can determine - ! the range of the data, and hence the height and width - ! of the piece of paper. - ! - x_max = max ( maxval ( node_xy(1,1:node_num) ), & - maxval ( point_xy(1,1:point_num) ) ) - x_min = min ( minval ( node_xy(1,1:node_num) ), & - minval ( point_xy(1,1:point_num) ) ) - x_scale = x_max - x_min - - x_max = x_max + 0.05D+00 * x_scale - x_min = x_min - 0.05D+00 * x_scale - x_scale = x_max - x_min - - y_max = max ( maxval ( node_xy(2,1:node_num) ), & - maxval ( point_xy(2,1:point_num) ) ) - y_min = min ( minval ( node_xy(2,1:node_num) ), & - minval ( point_xy(2,1:point_num) ) ) - y_scale = y_max - y_min - - y_max = y_max + 0.05D+00 * y_scale - y_min = y_min - 0.05D+00 * y_scale - y_scale = y_max - y_min - - if ( x_scale < y_scale ) then - - delta = nint ( real ( x_ps_max - x_ps_min, kind = 8 ) & - * ( y_scale - x_scale ) / ( 2.0D+00 * y_scale ) ) - - x_ps_max = x_ps_max - delta - x_ps_min = x_ps_min + delta - - x_ps_max_clip = x_ps_max_clip - delta - x_ps_min_clip = x_ps_min_clip + delta - - x_scale = y_scale - - else if ( y_scale < x_scale ) then - - delta = nint ( real ( y_ps_max - y_ps_min, kind = 8 ) & - * ( x_scale - y_scale ) / ( 2.0D+00 * x_scale ) ) - - y_ps_max = y_ps_max - delta - y_ps_min = y_ps_min + delta - - y_ps_max_clip = y_ps_max_clip - delta - y_ps_min_clip = y_ps_min_clip + delta - - y_scale = x_scale - - end if - - call get_unit ( file_unit ) - - open ( unit = file_unit, file = file_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'TRIANGLE_POINTS_PLOT - Fatal error!' - write ( *, '(a)' ) ' Can not open output file.' - return - end if - - write ( file_unit, '(a)' ) '%!PS-Adobe-3.0 EPSF-3.0' - write ( file_unit, '(a)' ) '%%Creator: triangulation_order3_plot.f90' - write ( file_unit, '(a)' ) '%%Title: ' // trim ( file_name ) - write ( file_unit, '(a)' ) '%%CreationDate: ' // trim ( date_time ) - write ( file_unit, '(a)' ) '%%Pages: 1' - write ( file_unit, '(a,i3,2x,i3,2x,i3,2x,i3)' ) '%%BoundingBox: ', & - x_ps_min, y_ps_min, x_ps_max, y_ps_max - write ( file_unit, '(a)' ) '%%Document-Fonts: Times-Roman' - write ( file_unit, '(a)' ) '%%LanguageLevel: 1' - write ( file_unit, '(a)' ) '%%EndComments' - write ( file_unit, '(a)' ) '%%BeginProlog' - write ( file_unit, '(a)' ) '/inch {72 mul} def' - write ( file_unit, '(a)' ) '%%EndProlog' - write ( file_unit, '(a)' ) '%%Page: 1 1' - write ( file_unit, '(a)' ) 'save' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB line color to very light gray.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.900 0.900 0.900 setrgbcolor' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Draw a gray border around the page.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) 'newpath' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_min, ' moveto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_max, y_ps_min, ' lineto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_max, y_ps_max, ' lineto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_max, ' lineto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_min, ' lineto' - write ( file_unit, '(a)' ) 'stroke' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB color to black.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.000 0.000 0.000 setrgbcolor' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the font and its size.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '/Times-Roman findfont' - write ( file_unit, '(a)' ) '0.50 inch scalefont' - write ( file_unit, '(a)' ) 'setfont' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Print a title.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% 210 702 moveto' - write ( file_unit, '(a)' ) '% (Triangulation) show' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Define a clipping polygon.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) 'newpath' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & - x_ps_min_clip, y_ps_min_clip, ' moveto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & - x_ps_max_clip, y_ps_min_clip, ' lineto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & - x_ps_max_clip, y_ps_max_clip, ' lineto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & - x_ps_min_clip, y_ps_max_clip, ' lineto' - write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & - x_ps_min_clip, y_ps_min_clip, ' lineto' - write ( file_unit, '(a)' ) 'clip newpath' - ! - ! Draw the nodes. - ! - if ( 1 <= node_show ) then - - circle_size = 5 - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Draw filled dots at the nodes.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB color to blue.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.000 0.150 0.750 setrgbcolor' - write ( file_unit, '(a)' ) '%' + write ( string, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & + d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - do node = 1, 3 + return + end subroutine + subroutine triangle_area ( node_xy, area ) + + !*****************************************************************************80 + ! + !! TRIANGLE_AREA computes the area of a triangle. + ! + ! Discussion: + ! + ! If the triangle's vertices are given in counterclockwise order, + ! the area will be positive. If the triangle's vertices are given + ! in clockwise order, the area will be negative! + ! + ! If you cannot guarantee counterclockwise order, and you need to + ! have the area positive, then you can simply take the absolute value + ! of the result of this routine. + ! + ! An earlier version of this routine always returned the absolute + ! value of the computed area. I am convinced now that that is + ! a less useful result! For instance, by returning the signed + ! area of a triangle, it is possible to easily compute the area + ! of a nonconvex polygon as the sum of the (possibly negative) + ! areas of triangles formed by node 1 and successive pairs of vertices. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 17 October 2005 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, real ( kind = 8 ) NODE_XY(2,3), the triangle vertices. + ! + ! Output, real ( kind = 8 ) AREA, the area of the triangle. + ! + implicit none + + real ( kind = 8 ) area + real ( kind = 8 ) node_xy(2,3) + + area = 0.5D+00 * ( & + node_xy(1,1) * ( node_xy(2,2) - node_xy(2,3) ) & + + node_xy(1,2) * ( node_xy(2,3) - node_xy(2,1) ) & + + node_xy(1,3) * ( node_xy(2,1) - node_xy(2,2) ) ) - x_ps = int ( & - ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & - + ( node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & - / ( x_max - x_min ) ) + return + end subroutine + subroutine triangle_points_plot ( file_name, node_xy, node_show, point_num, & + point_xy, point_show ) + + !*****************************************************************************80 + ! + !! TRIANGLE_POINTS_PLOT plots a triangle and some points. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 03 October 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, character ( len = * ) FILE_NAME, the name of the output file. + ! + ! Input, real ( kind = 8 ) NODE_XY(2,3), the coordinates of the nodes + ! of the triangle. + ! + ! Input, integer ( kind = 4 ) NODE_SHOW, + ! -1, do not show the triangle, or the nodes. + ! 0, show the triangle, do not show the nodes; + ! 1, show the triangle and the nodes; + ! 2, show the triangle, the nodes and number them. + ! + ! Input, integer ( kind = 4 ) POINT_NUM, the number of points. + ! + ! Input, real ( kind = 8 ) POINT_XY(2,POINT_NUM), the coordinates of the + ! points. + ! + ! Input, integer ( kind = 4 ) POINT_SHOW, + ! 0, do not show the points; + ! 1, show the points; + ! 2, show the points and number them. + ! + implicit none + + integer ( kind = 4 ), parameter :: node_num = 3 + integer ( kind = 4 ) point_num + + character ( len = 40 ) date_time + integer ( kind = 4 ) :: circle_size + integer ( kind = 4 ) delta + character ( len = * ) file_name + integer ( kind = 4 ) file_unit + integer ( kind = 4 ) i + integer ( kind = 4 ), parameter :: i4_1 = 1 + integer ( kind = 4 ), parameter :: i4_3 = 3 + integer ( kind = 4 ) ios + integer ( kind = 4 ) node + integer ( kind = 4 ) node_show + real ( kind = 8 ) node_xy(2,node_num) + integer ( kind = 4 ) point + integer ( kind = 4 ) point_show + real ( kind = 8 ) point_xy(2,point_num) + character ( len = 40 ) string + real ( kind = 8 ) x_max + real ( kind = 8 ) x_min + integer ( kind = 4 ) x_ps + integer ( kind = 4 ) :: x_ps_max = 576 + integer ( kind = 4 ) :: x_ps_max_clip = 594 + integer ( kind = 4 ) :: x_ps_min = 36 + integer ( kind = 4 ) :: x_ps_min_clip = 18 + real ( kind = 8 ) x_scale + real ( kind = 8 ) y_max + real ( kind = 8 ) y_min + integer ( kind = 4 ) y_ps + integer ( kind = 4 ) :: y_ps_max = 666 + integer ( kind = 4 ) :: y_ps_max_clip = 684 + integer ( kind = 4 ) :: y_ps_min = 126 + integer ( kind = 4 ) :: y_ps_min_clip = 108 + real ( kind = 8 ) y_scale + + call timestring ( date_time ) + ! + ! We need to do some figuring here, so that we can determine + ! the range of the data, and hence the height and width + ! of the piece of paper. + ! + x_max = max ( maxval ( node_xy(1,1:node_num) ), & + maxval ( point_xy(1,1:point_num) ) ) + x_min = min ( minval ( node_xy(1,1:node_num) ), & + minval ( point_xy(1,1:point_num) ) ) + x_scale = x_max - x_min + + x_max = x_max + 0.05D+00 * x_scale + x_min = x_min - 0.05D+00 * x_scale + x_scale = x_max - x_min + + y_max = max ( maxval ( node_xy(2,1:node_num) ), & + maxval ( point_xy(2,1:point_num) ) ) + y_min = min ( minval ( node_xy(2,1:node_num) ), & + minval ( point_xy(2,1:point_num) ) ) + y_scale = y_max - y_min + + y_max = y_max + 0.05D+00 * y_scale + y_min = y_min - 0.05D+00 * y_scale + y_scale = y_max - y_min + + if ( x_scale < y_scale ) then + + delta = nint ( real ( x_ps_max - x_ps_min, kind = 8 ) & + * ( y_scale - x_scale ) / ( 2.0D+00 * y_scale ) ) + + x_ps_max = x_ps_max - delta + x_ps_min = x_ps_min + delta + + x_ps_max_clip = x_ps_max_clip - delta + x_ps_min_clip = x_ps_min_clip + delta + + x_scale = y_scale + + else if ( y_scale < x_scale ) then + + delta = nint ( real ( y_ps_max - y_ps_min, kind = 8 ) & + * ( x_scale - y_scale ) / ( 2.0D+00 * x_scale ) ) + + y_ps_max = y_ps_max - delta + y_ps_min = y_ps_min + delta + + y_ps_max_clip = y_ps_max_clip - delta + y_ps_min_clip = y_ps_min_clip + delta + + y_scale = x_scale - y_ps = int ( & - ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & - + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & - / ( y_max - y_min ) ) + end if - write ( file_unit, '(a,i4,2x,i4,2x,i4,2x,a)' ) 'newpath ', x_ps, y_ps, & - circle_size, '0 360 arc closepath fill' + call get_unit ( file_unit ) - end do + open ( unit = file_unit, file = file_name, status = 'replace', & + iostat = ios ) - end if - ! - ! Label the nodes. - ! - if ( 2 <= node_show ) then + if ( ios /= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'TRIANGLE_POINTS_PLOT - Fatal error!' + write ( *, '(a)' ) ' Can not open output file.' + return + end if + write ( file_unit, '(a)' ) '%!PS-Adobe-3.0 EPSF-3.0' + write ( file_unit, '(a)' ) '%%Creator: triangulation_order3_plot.f90' + write ( file_unit, '(a)' ) '%%Title: ' // trim ( file_name ) + write ( file_unit, '(a)' ) '%%CreationDate: ' // trim ( date_time ) + write ( file_unit, '(a)' ) '%%Pages: 1' + write ( file_unit, '(a,i3,2x,i3,2x,i3,2x,i3)' ) '%%BoundingBox: ', & + x_ps_min, y_ps_min, x_ps_max, y_ps_max + write ( file_unit, '(a)' ) '%%Document-Fonts: Times-Roman' + write ( file_unit, '(a)' ) '%%LanguageLevel: 1' + write ( file_unit, '(a)' ) '%%EndComments' + write ( file_unit, '(a)' ) '%%BeginProlog' + write ( file_unit, '(a)' ) '/inch {72 mul} def' + write ( file_unit, '(a)' ) '%%EndProlog' + write ( file_unit, '(a)' ) '%%Page: 1 1' + write ( file_unit, '(a)' ) 'save' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB line color to very light gray.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.900 0.900 0.900 setrgbcolor' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw a gray border around the page.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) 'newpath' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_min, ' moveto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_max, y_ps_min, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_max, y_ps_max, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_max, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_min, ' lineto' + write ( file_unit, '(a)' ) 'stroke' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to black.' write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Label the nodes:' + write ( file_unit, '(a)' ) '0.000 0.000 0.000 setrgbcolor' write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB color to darker blue.' + write ( file_unit, '(a)' ) '% Set the font and its size.' write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.000 0.250 0.850 setrgbcolor' write ( file_unit, '(a)' ) '/Times-Roman findfont' - write ( file_unit, '(a)' ) '0.20 inch scalefont' + write ( file_unit, '(a)' ) '0.50 inch scalefont' write ( file_unit, '(a)' ) 'setfont' write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Print a title.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% 210 702 moveto' + write ( file_unit, '(a)' ) '% (Triangulation) show' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Define a clipping polygon.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) 'newpath' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_min_clip, y_ps_min_clip, ' moveto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_max_clip, y_ps_min_clip, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_max_clip, y_ps_max_clip, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_min_clip, y_ps_max_clip, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_min_clip, y_ps_min_clip, ' lineto' + write ( file_unit, '(a)' ) 'clip newpath' + ! + ! Draw the nodes. + ! + if ( 1 <= node_show ) then + + circle_size = 5 + + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw filled dots at the nodes.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to blue.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.000 0.150 0.750 setrgbcolor' + write ( file_unit, '(a)' ) '%' + + do node = 1, 3 + + x_ps = int ( & + ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & + + ( node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & + + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + write ( file_unit, '(a,i4,2x,i4,2x,i4,2x,a)' ) 'newpath ', x_ps, y_ps, & + circle_size, '0 360 arc closepath fill' + + end do - do node = 1, node_num + end if + ! + ! Label the nodes. + ! + if ( 2 <= node_show ) then + + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Label the nodes:' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to darker blue.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.000 0.250 0.850 setrgbcolor' + write ( file_unit, '(a)' ) '/Times-Roman findfont' + write ( file_unit, '(a)' ) '0.20 inch scalefont' + write ( file_unit, '(a)' ) 'setfont' + write ( file_unit, '(a)' ) '%' + + do node = 1, node_num + + x_ps = int ( & + ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & + + ( + node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & + + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + write ( string, '(i4)' ) node + string = adjustl ( string ) + + write ( file_unit, '(i4,2x,i4,a)' ) x_ps, y_ps+5, & + ' moveto (' // trim ( string ) // ') show' + + end do - x_ps = int ( & - ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & - + ( + node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & - / ( x_max - x_min ) ) + end if + ! + ! Draw the points. + ! + if ( point_num <= 200 ) then + circle_size = 5 + else if ( point_num <= 500 ) then + circle_size = 4 + else if ( point_num <= 1000 ) then + circle_size = 3 + else if ( point_num <= 5000 ) then + circle_size = 2 + else + circle_size = 1 + end if - y_ps = int ( & - ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & - + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & - / ( y_max - y_min ) ) + if ( 1 <= point_show ) then + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw filled dots at the points.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to green.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.150 0.750 0.000 setrgbcolor' + write ( file_unit, '(a)' ) '%' - write ( string, '(i4)' ) node - string = adjustl ( string ) + do point = 1, point_num - write ( file_unit, '(i4,2x,i4,a)' ) x_ps, y_ps+5, & - ' moveto (' // trim ( string ) // ') show' + x_ps = int ( & + ( ( x_max - point_xy(1,point) ) * real ( x_ps_min, kind = 8 ) & + + ( point_xy(1,point) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) - end do + y_ps = int ( & + ( ( y_max - point_xy(2,point) ) * real ( y_ps_min, kind = 8 ) & + + ( point_xy(2,point) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) - end if - ! - ! Draw the points. - ! - if ( point_num <= 200 ) then - circle_size = 5 - else if ( point_num <= 500 ) then - circle_size = 4 - else if ( point_num <= 1000 ) then - circle_size = 3 - else if ( point_num <= 5000 ) then - circle_size = 2 - else - circle_size = 1 - end if - - if ( 1 <= point_show ) then - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Draw filled dots at the points.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB color to green.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.150 0.750 0.000 setrgbcolor' - write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a,i4,2x,i4,2x,i4,2x,a)' ) 'newpath ', x_ps, y_ps, & + circle_size, '0 360 arc closepath fill' - do point = 1, point_num + end do - x_ps = int ( & - ( ( x_max - point_xy(1,point) ) * real ( x_ps_min, kind = 8 ) & - + ( point_xy(1,point) - x_min ) * real ( x_ps_max, kind = 8 ) ) & - / ( x_max - x_min ) ) + end if + ! + ! Label the points. + ! + if ( 2 <= point_show ) then + + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Label the point:' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to darker green.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.250 0.850 0.000 setrgbcolor' + write ( file_unit, '(a)' ) '/Times-Roman findfont' + write ( file_unit, '(a)' ) '0.20 inch scalefont' + write ( file_unit, '(a)' ) 'setfont' + write ( file_unit, '(a)' ) '%' + + do point = 1, point_num + + x_ps = int ( & + ( ( x_max - point_xy(1,point) ) * real ( x_ps_min, kind = 8 ) & + + ( + point_xy(1,point) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - point_xy(2,point) ) * real ( y_ps_min, kind = 8 ) & + + ( point_xy(2,point) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + write ( string, '(i4)' ) point + string = adjustl ( string ) + + write ( file_unit, '(i4,2x,i4,a)' ) x_ps, y_ps+5, & + ' moveto (' // trim ( string ) // ') show' + + end do - y_ps = int ( & - ( ( y_max - point_xy(2,point) ) * real ( y_ps_min, kind = 8 ) & - + ( point_xy(2,point) - y_min ) * real ( y_ps_max, kind = 8 ) ) & - / ( y_max - y_min ) ) + end if + ! + ! Draw the triangle. + ! + if ( 0 <= node_show ) then + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to red.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.900 0.200 0.100 setrgbcolor' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw the triangle.' + write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a,i4,2x,i4,2x,i4,2x,a)' ) 'newpath ', x_ps, y_ps, & - circle_size, '0 360 arc closepath fill' + write ( file_unit, '(a)' ) 'newpath' - end do + do i = 1, 4 - end if - ! - ! Label the points. - ! - if ( 2 <= point_show ) then + node = i4_wrap ( i, i4_1, i4_3 ) + + x_ps = int ( & + ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & + + ( node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & + + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + if ( i == 1 ) then + write ( file_unit, '(i3,2x,i3,2x,a)' ) x_ps, y_ps, ' moveto' + else + write ( file_unit, '(i3,2x,i3,2x,a)' ) x_ps, y_ps, ' lineto' + end if + + end do + + write ( file_unit, '(a)' ) 'stroke' + + end if write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Label the point:' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB color to darker green.' + write ( file_unit, '(a)' ) 'restore showpage' write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.250 0.850 0.000 setrgbcolor' - write ( file_unit, '(a)' ) '/Times-Roman findfont' - write ( file_unit, '(a)' ) '0.20 inch scalefont' - write ( file_unit, '(a)' ) 'setfont' + write ( file_unit, '(a)' ) '% End of page.' write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '%%Trailer' + write ( file_unit, '(a)' ) '%%EOF' + close ( unit = file_unit ) - do point = 1, point_num + return + end subroutine + subroutine wandzura_degree ( rule, degree ) + + !*****************************************************************************80 + ! + !! WANDZURA_DEGREE returns the degree of a given Wandzura rule for the triangle. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 December 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Output, integer ( kind = 4 ) DEGREE, the polynomial degree of exactness of + ! the rule. + ! + implicit none + + integer ( kind = 4 ) degree + integer ( kind = 4 ) rule + + if ( rule == 1 ) then + degree = 5 + else if ( rule == 2 ) then + degree = 10 + else if ( rule == 3 ) then + degree = 15 + else if ( rule == 4 ) then + degree = 20 + else if ( rule == 5 ) then + degree = 25 + else if ( rule == 6 ) then + degree = 30 + else - x_ps = int ( & - ( ( x_max - point_xy(1,point) ) * real ( x_ps_min, kind = 8 ) & - + ( + point_xy(1,point) - x_min ) * real ( x_ps_max, kind = 8 ) ) & - / ( x_max - x_min ) ) + degree = -1 + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'WANDZURA_DEGREE - Fatal error!' + write ( *, '(a,i8)' ) ' Illegal RULE = ', rule + stop - y_ps = int ( & - ( ( y_max - point_xy(2,point) ) * real ( y_ps_min, kind = 8 ) & - + ( point_xy(2,point) - y_min ) * real ( y_ps_max, kind = 8 ) ) & - / ( y_max - y_min ) ) + end if - write ( string, '(i4)' ) point - string = adjustl ( string ) + return + end subroutine + subroutine wandzura_order_num ( rule, order_num ) + + !*****************************************************************************80 + ! + !! WANDZURA_ORDER_NUM returns the order of a Wandzura rule for the triangle. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 December 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Output, integer ( kind = 4 ) ORDER_NUM, the order (number of points) of the rule. + ! + implicit none + + integer ( kind = 4 ) order_num + integer ( kind = 4 ) rule + integer ( kind = 4 ), allocatable, dimension ( : ) :: suborder + integer ( kind = 4 ) suborder_num + + call wandzura_suborder_num ( rule, suborder_num ) + + allocate ( suborder(1:suborder_num) ) + + call wandzura_suborder ( rule, suborder_num, suborder ) + + order_num = sum ( suborder(1:suborder_num) ) + + deallocate ( suborder ) - write ( file_unit, '(i4,2x,i4,a)' ) x_ps, y_ps+5, & - ' moveto (' // trim ( string ) // ') show' + return + end subroutine + + subroutine wandzura_rule_sp(rule, order_num, xy, w) + integer, intent(in) :: rule + integer, intent(in) :: order_num + real(kind = c_float), dimension(2, order_num), intent(out) :: xy + real(kind = c_float), dimension(order_num), intent(out) :: w + + real(kind = c_double), dimension(2, order_num) :: lxy + real(kind = c_double), dimension(order_num) :: lw + + call wandzura_rule(rule, order_num, lxy, lw) + xy = lxy + w = lw + + end subroutine wandzura_rule_sp + + subroutine wandzura_rule_orig ( rule, order_num, xy, w ) + + !*****************************************************************************80 + ! + !! WANDZURA_RULE returns the points and weights of a Wandzura rule. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 December 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Input, integer ( kind = 4 ) ORDER_NUM, the order (number of points) + ! of the rule. + ! + ! Output, real ( kind = 8 ) XY(2,ORDER_NUM), the points of the rule. + ! + ! Output, real ( kind = 8 ) W(ORDER_NUM), the weights of the rule. + ! + implicit none + + integer ( kind = 4 ) order_num + + integer ( kind = 4 ), parameter :: i4_1 = 1 + integer ( kind = 4 ), parameter :: i4_3 = 3 + integer ( kind = 4 ) k + integer ( kind = 4 ) o + integer ( kind = 4 ) rule + integer ( kind = 4 ) s + integer ( kind = 4 ), allocatable, dimension ( : ) :: suborder + integer ( kind = 4 ) suborder_num + real ( kind = 8 ), allocatable, dimension ( : ) :: suborder_w + real ( kind = 8 ), allocatable, dimension ( :, : ) :: suborder_xyz + real ( kind = 8 ) w(order_num) + real ( kind = 8 ) xy(2,order_num) + ! + ! Get the suborder information. + ! + call wandzura_suborder_num ( rule, suborder_num ) + + allocate ( suborder(suborder_num) ) + allocate ( suborder_xyz(3,suborder_num) ) + allocate ( suborder_w(suborder_num) ) + + call wandzura_suborder ( rule, suborder_num, suborder ) + + call wandzura_subrule ( rule, suborder_num, suborder_xyz, suborder_w ) + ! + ! Expand the suborder information to a full order rule. + ! + o = 0 + + do s = 1, suborder_num + + if ( suborder(s) == 1 ) then + + o = o + 1 + xy(1:2,o) = suborder_xyz(1:2,s) + w(o) = 0.5D+00 * suborder_w(s) + + else if ( suborder(s) == 3 ) then + + do k = 1, 3 + o = o + 1 + xy(1,o) = suborder_xyz ( i4_wrap(k, i4_1,i4_3), s ) + xy(2,o) = suborder_xyz ( i4_wrap(k+i4_1,i4_1,i4_3), s ) + w(o) = 0.5D+00 * suborder_w(s) + end do + + else if ( suborder(s) == 6 ) then + + do k = 1, 3 + o = o + 1 + xy(1,o) = suborder_xyz ( i4_wrap(k, i4_1,i4_3), s ) + xy(2,o) = suborder_xyz ( i4_wrap(k+i4_1,i4_1,i4_3), s ) + w(o) = 0.5D+00 * suborder_w(s) + end do + + do k = 1, 3 + o = o + 1 + xy(1,o) = suborder_xyz ( i4_wrap(k+i4_1,i4_1,i4_3), s ) + xy(2,o) = suborder_xyz ( i4_wrap(k, i4_1,i4_3), s ) + w(o) = 0.5D+00 * suborder_w(s) + end do + + else + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'WANDZURA_RULE - Fatal error!' + write ( *, '(a,i8,a,i8)' ) ' Illegal SUBORDER(', s, ') = ', suborder(s) + stop + + end if end do - end if - ! - ! Draw the triangle. - ! - if ( 0 <= node_show ) then - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Set the RGB color to red.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '0.900 0.200 0.100 setrgbcolor' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% Draw the triangle.' - write ( file_unit, '(a)' ) '%' + deallocate ( suborder ) + deallocate ( suborder_xyz ) + deallocate ( suborder_w ) - write ( file_unit, '(a)' ) 'newpath' + return + end subroutine + subroutine wandzura_rule_num ( rule_num ) + + !*****************************************************************************80 + ! + !! WANDZURA_RULE_NUM returns the number of Wandzura rules available. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 December 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Output, integer ( kind = 4 ) RULE_NUM, the number of rules available. + ! + implicit none + + integer ( kind = 4 ) rule_num + + rule_num = 6 + + return + end subroutine + subroutine wandzura_suborder ( rule, suborder_num, suborder ) + + !*****************************************************************************80 + ! + !! WANDZURA_SUBORDER returns the suborders for a Wandzura rule. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 December 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Input, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders + ! of the rule. + ! + ! Output, integer ( kind = 4 ) SUBORDER(SUBORDER_NUM), the suborders + ! of the rule. + ! + implicit none + + integer ( kind = 4 ) suborder_num + + integer ( kind = 4 ) rule + integer ( kind = 4 ) suborder(suborder_num) + + if ( rule == 1 ) then + suborder(1:suborder_num) = (/ & + 1, 3, 3 /) + else if ( rule == 2 ) then + suborder(1:suborder_num) = (/ & + 1, 3, 3, 3, 3, 6, 6 /) + else if ( rule == 3 ) then + suborder(1:suborder_num) = (/ & + 3, 3, 3, 3, 3, 3, 6, 6, 6, 6, & + 6, 6 /) + else if ( rule == 4 ) then + suborder(1:suborder_num) = (/ & + 1, 3, 3, 3, 3, 3, 3, 3, 3, 6, & + 6, 6, 6, 6, 6, 6, 6, 6, 6 /) + else if ( rule == 5 ) then + suborder(1:suborder_num) = (/ & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 6 /) + else if ( rule == 6 ) then + suborder(1:suborder_num) = (/ & + 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 6 /) + else - do i = 1, 4 + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'WANDZURA_SUBORDER - Fatal error!' + write ( *, '(a,i8)' ) ' Illegal RULE = ', rule + stop - node = i4_wrap ( i, i4_1, i4_3 ) + end if - x_ps = int ( & - ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & - + ( node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & - / ( x_max - x_min ) ) + return + end subroutine + subroutine wandzura_suborder_num ( rule, suborder_num ) + + !*****************************************************************************80 + ! + !! WANDZURA_SUBORDER_NUM returns the number of suborders for a Wandzura rule. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 December 2006 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Output, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders of the rule. + ! + implicit none + + integer ( kind = 4 ) rule + integer ( kind = 4 ) suborder_num + + if ( rule == 1 ) then + suborder_num = 3 + else if ( rule == 2 ) then + suborder_num = 7 + else if ( rule == 3 ) then + suborder_num = 12 + else if ( rule == 4 ) then + suborder_num = 19 + else if ( rule == 5 ) then + suborder_num = 26 + else if ( rule == 6 ) then + suborder_num = 36 + else - y_ps = int ( & - ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & - + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & - / ( y_max - y_min ) ) + suborder_num = -1 + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'WANDZURA_SUBORDER_NUM - Fatal error!' + write ( *, '(a,i8)' ) ' Illegal RULE = ', rule + stop - if ( i == 1 ) then - write ( file_unit, '(i3,2x,i3,2x,a)' ) x_ps, y_ps, ' moveto' - else - write ( file_unit, '(i3,2x,i3,2x,a)' ) x_ps, y_ps, ' lineto' - end if + end if - end do + return + end subroutine + subroutine wandzura_subrule ( rule, suborder_num, suborder_xyz, suborder_w ) + + !*****************************************************************************80 + ! + !! WANDZURA_SUBRULE returns a compressed Wandzura rule. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 10 May 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Input, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders + ! of the rule. + ! + ! Output, real ( kind = 8 ) SUBORDER_XYZ(3,SUBORDER_NUM), + ! the barycentric coordinates of the abscissas. + ! + ! Output, real ( kind = 8 ) SUBORDER_W(SUBORDER_NUM), the + ! suborder weights. + ! + implicit none + + integer ( kind = 4 ) suborder_num + + integer ( kind = 4 ), parameter :: i4_3 = 3 + integer ( kind = 4 ) rule + real ( kind = 8 ) suborder_w(suborder_num) + real ( kind = 8 ) suborder_xyz(3,suborder_num) + + if ( rule == 1 ) then + + suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & + 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & + 0.05971587178977D+00, 0.47014206410512D+00, 0.47014206410512D+00, & + 0.79742698535309D+00, 0.10128650732346D+00, 0.10128650732346D+00 & + /), (/ i4_3, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.2250000000000000D+00, & + 0.1323941527885062D+00, & + 0.1259391805448271D+00 & + /) + + else if ( rule == 2 ) then + + suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & + 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & + 0.00426913409105D+00, 0.49786543295447D+00, 0.49786543295447D+00, & + 0.14397510054189D+00, 0.42801244972906D+00, 0.42801244972906D+00, & + 0.63048717451355D+00, 0.18475641274322D+00, 0.18475641274322D+00, & + 0.95903756285664D+00, 0.02048121857168D+00, 0.02048121857168D+00, & + 0.03500298989727D+00, 0.13657357625603D+00, 0.82842343384669D+00, & + 0.03754907025844D+00, 0.33274360058864D+00, 0.62970732915292D+00 & + /), (/ i4_3, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.8352339980519638D-01, & + 0.7229850592056743D-02, & + 0.7449217792098051D-01, & + 0.7864647340310853D-01, & + 0.6928323087107504D-02, & + 0.2951832033477940D-01, & + 0.3957936719606124D-01 & + /) + + else if ( rule == 3 ) then + + suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & + 0.08343840726175D+00, 0.45828079636912D+00, 0.45828079636913D+00, & + 0.19277907084174D+00, 0.40361046457913D+00, 0.40361046457913D+00, & + 0.41360566417395D+00, 0.29319716791303D+00, 0.29319716791303D+00, & + 0.70706442611445D+00, 0.14646778694277D+00, 0.14646778694277D+00, & + 0.88727426466879D+00, 0.05636286766560D+00, 0.05636286766560D+00, & + 0.96684974628326D+00, 0.01657512685837D+00, 0.01657512685837D+00, & + 0.00991220330923D+00, 0.23953455415479D+00, 0.75055324253598D+00, & + 0.01580377063023D+00, 0.40487880731834D+00, 0.57931742205143D+00, & + 0.00514360881697D+00, 0.09500211311304D+00, 0.89985427806998D+00, & + 0.04892232575299D+00, 0.14975310732227D+00, 0.80132456692474D+00, & + 0.06876874863252D+00, 0.28691961244133D+00, 0.64431163892615D+00, & + 0.16840441812470D+00, 0.28183566809908D+00, 0.54975991377622D+00 & + /), (/ i4_3, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.3266181884880529D-01, & + 0.2741281803136436D-01, & + 0.2651003659870330D-01, & + 0.2921596213648611D-01, & + 0.1058460806624399D-01, & + 0.3614643064092035D-02, & + 0.8527748101709436D-02, & + 0.1391617651669193D-01, & + 0.4291932940734835D-02, & + 0.1623532928177489D-01, & + 0.2560734092126239D-01, & + 0.3308819553164567D-01 & + /) + + else if ( rule == 4 ) then + + suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & + 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & + 0.00150064932443D+00, 0.49924967533779D+00, 0.49924967533779D+00, & + 0.09413975193895D+00, 0.45293012403052D+00, 0.45293012403052D+00, & + 0.20447212408953D+00, 0.39776393795524D+00, 0.39776393795524D+00, & + 0.47099959493443D+00, 0.26450020253279D+00, 0.26450020253279D+00, & + 0.57796207181585D+00, 0.21101896409208D+00, 0.21101896409208D+00, & + 0.78452878565746D+00, 0.10773560717127D+00, 0.10773560717127D+00, & + 0.92186182432439D+00, 0.03906908783780D+00, 0.03906908783780D+00, & + 0.97765124054134D+00, 0.01117437972933D+00, 0.01117437972933D+00, & + 0.00534961818734D+00, 0.06354966590835D+00, 0.93110071590431D+00, & + 0.00795481706620D+00, 0.15710691894071D+00, 0.83493826399309D+00, & + 0.01042239828126D+00, 0.39564211436437D+00, 0.59393548735436D+00, & + 0.01096441479612D+00, 0.27316757071291D+00, 0.71586801449097D+00, & + 0.03856671208546D+00, 0.10178538248502D+00, 0.85964790542952D+00, & + 0.03558050781722D+00, 0.44665854917641D+00, 0.51776094300637D+00, & + 0.04967081636276D+00, 0.19901079414950D+00, 0.75131838948773D+00, & + 0.05851972508433D+00, 0.32426118369228D+00, 0.61721909122339D+00, & + 0.12149778700439D+00, 0.20853136321013D+00, 0.66997084978547D+00, & + 0.14071084494394D+00, 0.32317056653626D+00, 0.53611858851980D+00 & + /), (/ i4_3, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.2761042699769952D-01, & + 0.1779029547326740D-02, & + 0.2011239811396117D-01, & + 0.2681784725933157D-01, & + 0.2452313380150201D-01, & + 0.1639457841069539D-01, & + 0.1479590739864960D-01, & + 0.4579282277704251D-02, & + 0.1651826515576217D-02, & + 0.2349170908575584D-02, & + 0.4465925754181793D-02, & + 0.6099566807907972D-02, & + 0.6891081327188203D-02, & + 0.7997475072478163D-02, & + 0.7386134285336024D-02, & + 0.1279933187864826D-01, & + 0.1725807117569655D-01, & + 0.1867294590293547D-01, & + 0.2281822405839526D-01 & + /) + + else if ( rule == 5 ) then + + suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & + 0.02794648307317D+00, 0.48602675846341D+00, 0.48602675846341D+00, & + 0.13117860132765D+00, 0.43441069933617D+00, 0.43441069933617D+00, & + 0.22022172951207D+00, 0.38988913524396D+00, 0.38988913524396D+00, & + 0.40311353196039D+00, 0.29844323401980D+00, 0.29844323401980D+00, & + 0.53191165532526D+00, 0.23404417233737D+00, 0.23404417233737D+00, & + 0.69706333078196D+00, 0.15146833460902D+00, 0.15146833460902D+00, & + 0.77453221290801D+00, 0.11273389354599D+00, 0.11273389354599D+00, & + 0.84456861581695D+00, 0.07771569209153D+00, 0.07771569209153D+00, & + 0.93021381277141D+00, 0.03489309361430D+00, 0.03489309361430D+00, & + 0.98548363075813D+00, 0.00725818462093D+00, 0.00725818462093D+00, & + 0.00129235270444D+00, 0.22721445215336D+00, 0.77149319514219D+00, & + 0.00539970127212D+00, 0.43501055485357D+00, 0.55958974387431D+00, & + 0.00638400303398D+00, 0.32030959927220D+00, 0.67330639769382D+00, & + 0.00502821150199D+00, 0.09175032228001D+00, 0.90322146621800D+00, & + 0.00682675862178D+00, 0.03801083585872D+00, 0.95516240551949D+00, & + 0.01001619963993D+00, 0.15742521848531D+00, 0.83255858187476D+00, & + 0.02575781317339D+00, 0.23988965977853D+00, 0.73435252704808D+00, & + 0.03022789811992D+00, 0.36194311812606D+00, 0.60782898375402D+00, & + 0.03050499010716D+00, 0.08355196095483D+00, 0.88594304893801D+00, & + 0.04595654736257D+00, 0.14844322073242D+00, 0.80560023190501D+00, & + 0.06744280054028D+00, 0.28373970872753D+00, 0.64881749073219D+00, & + 0.07004509141591D+00, 0.40689937511879D+00, 0.52305553346530D+00, & + 0.08391152464012D+00, 0.19411398702489D+00, 0.72197448833499D+00, & + 0.12037553567715D+00, 0.32413434700070D+00, 0.55549011732214D+00, & + 0.14806689915737D+00, 0.22927748355598D+00, 0.62265561728665D+00, & + 0.19177186586733D+00, 0.32561812259598D+00, 0.48261001153669D+00 & + /), (/ i4_3, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.8005581880020417D-02, & + 0.1594707683239050D-01, & + 0.1310914123079553D-01, & + 0.1958300096563562D-01, & + 0.1647088544153727D-01, & + 0.8547279074092100D-02, & + 0.8161885857226492D-02, & + 0.6121146539983779D-02, & + 0.2908498264936665D-02, & + 0.6922752456619963D-03, & + 0.1248289199277397D-02, & + 0.3404752908803022D-02, & + 0.3359654326064051D-02, & + 0.1716156539496754D-02, & + 0.1480856316715606D-02, & + 0.3511312610728685D-02, & + 0.7393550149706484D-02, & + 0.7983087477376558D-02, & + 0.4355962613158041D-02, & + 0.7365056701417832D-02, & + 0.1096357284641955D-01, & + 0.1174996174354112D-01, & + 0.1001560071379857D-01, & + 0.1330964078762868D-01, & + 0.1415444650522614D-01, & + 0.1488137956116801D-01 & + /) + + else if ( rule == 6 ) then + + suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & + 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & + 0.00733011643277D+00, 0.49633494178362D+00, 0.49633494178362D+00, & + 0.08299567580296D+00, 0.45850216209852D+00, 0.45850216209852D+00, & + 0.15098095612541D+00, 0.42450952193729D+00, 0.42450952193729D+00, & + 0.23590585989217D+00, 0.38204707005392D+00, 0.38204707005392D+00, & + 0.43802430840785D+00, 0.28098784579608D+00, 0.28098784579608D+00, & + 0.54530204829193D+00, 0.22734897585403D+00, 0.22734897585403D+00, & + 0.65088177698254D+00, 0.17455911150873D+00, 0.17455911150873D+00, & + 0.75348314559713D+00, 0.12325842720144D+00, 0.12325842720144D+00, & + 0.83983154221561D+00, 0.08008422889220D+00, 0.08008422889220D+00, & + 0.90445106518420D+00, 0.04777446740790D+00, 0.04777446740790D+00, & + 0.95655897063972D+00, 0.02172051468014D+00, 0.02172051468014D+00, & + 0.99047064476913D+00, 0.00476467761544D+00, 0.00476467761544D+00, & + 0.00092537119335D+00, 0.41529527091331D+00, 0.58377935789334D+00, & + 0.00138592585556D+00, 0.06118990978535D+00, 0.93742416435909D+00, & + 0.00368241545591D+00, 0.16490869013691D+00, 0.83140889440718D+00, & + 0.00390322342416D+00, 0.02503506223200D+00, 0.97106171434384D+00, & + 0.00323324815501D+00, 0.30606446515110D+00, 0.69070228669389D+00, & + 0.00646743211224D+00, 0.10707328373022D+00, 0.88645928415754D+00, & + 0.00324747549133D+00, 0.22995754934558D+00, 0.76679497516308D+00, & + 0.00867509080675D+00, 0.33703663330578D+00, 0.65428827588746D+00, & + 0.01559702646731D+00, 0.05625657618206D+00, 0.92814639735063D+00, & + 0.01797672125369D+00, 0.40245137521240D+00, 0.57957190353391D+00, & + 0.01712424535389D+00, 0.24365470201083D+00, 0.73922105263528D+00, & + 0.02288340534658D+00, 0.16538958561453D+00, 0.81172700903888D+00, & + 0.03273759728777D+00, 0.09930187449585D+00, 0.86796052821639D+00, & + 0.03382101234234D+00, 0.30847833306905D+00, 0.65770065458860D+00, & + 0.03554761446002D+00, 0.46066831859211D+00, 0.50378406694787D+00, & + 0.05053979030687D+00, 0.21881529945393D+00, 0.73064491023920D+00, & + 0.05701471491573D+00, 0.37920955156027D+00, 0.56377573352399D+00, & + 0.06415280642120D+00, 0.14296081941819D+00, 0.79288637416061D+00, & + 0.08050114828763D+00, 0.28373128210592D+00, 0.63576756960645D+00, & + 0.10436706813453D+00, 0.19673744100444D+00, 0.69889549086103D+00, & + 0.11384489442875D+00, 0.35588914121166D+00, 0.53026596435959D+00, & + 0.14536348771552D+00, 0.25981868535191D+00, 0.59481782693256D+00, & + 0.18994565282198D+00, 0.32192318123130D+00, 0.48813116594672D+00 & + /), (/ i4_3, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.1557996020289920D-01, & + 0.3177233700534134D-02, & + 0.1048342663573077D-01, & + 0.1320945957774363D-01, & + 0.1497500696627150D-01, & + 0.1498790444338419D-01, & + 0.1333886474102166D-01, & + 0.1088917111390201D-01, & + 0.8189440660893461D-02, & + 0.5575387588607785D-02, & + 0.3191216473411976D-02, & + 0.1296715144327045D-02, & + 0.2982628261349172D-03, & + 0.9989056850788964D-03, & + 0.4628508491732533D-03, & + 0.1234451336382413D-02, & + 0.5707198522432062D-03, & + 0.1126946125877624D-02, & + 0.1747866949407337D-02, & + 0.1182818815031657D-02, & + 0.1990839294675034D-02, & + 0.1900412795035980D-02, & + 0.4498365808817451D-02, & + 0.3478719460274719D-02, & + 0.4102399036723953D-02, & + 0.4021761549744162D-02, & + 0.6033164660795066D-02, & + 0.3946290302129598D-02, & + 0.6644044537680268D-02, & + 0.8254305856078458D-02, & + 0.6496056633406411D-02, & + 0.9252778144146602D-02, & + 0.9164920726294280D-02, & + 0.1156952462809767D-01, & + 0.1176111646760917D-01, & + 0.1382470218216540D-01 & + /) - write ( file_unit, '(a)' ) 'stroke' + else + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'WANDZURA_SUBRULE - Fatal error!' + write ( *, '(a,i8)' ) ' Illegal RULE = ', rule + stop + + end if - end if - - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) 'restore showpage' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '% End of page.' - write ( file_unit, '(a)' ) '%' - write ( file_unit, '(a)' ) '%%Trailer' - write ( file_unit, '(a)' ) '%%EOF' - close ( unit = file_unit ) - - return - end subroutine - subroutine wandzura_degree ( rule, degree ) - - !*****************************************************************************80 - ! - !! WANDZURA_DEGREE returns the degree of a given Wandzura rule for the triangle. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 December 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Output, integer ( kind = 4 ) DEGREE, the polynomial degree of exactness of - ! the rule. - ! - implicit none - - integer ( kind = 4 ) degree - integer ( kind = 4 ) rule - - if ( rule == 1 ) then - degree = 5 - else if ( rule == 2 ) then - degree = 10 - else if ( rule == 3 ) then - degree = 15 - else if ( rule == 4 ) then - degree = 20 - else if ( rule == 5 ) then - degree = 25 - else if ( rule == 6 ) then - degree = 30 - else - - degree = -1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'WANDZURA_DEGREE - Fatal error!' - write ( *, '(a,i8)' ) ' Illegal RULE = ', rule - stop - - end if - - return - end subroutine - subroutine wandzura_order_num ( rule, order_num ) - - !*****************************************************************************80 - ! - !! WANDZURA_ORDER_NUM returns the order of a Wandzura rule for the triangle. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 December 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Output, integer ( kind = 4 ) ORDER_NUM, the order (number of points) of the rule. - ! - implicit none - - integer ( kind = 4 ) order_num - integer ( kind = 4 ) rule - integer ( kind = 4 ), allocatable, dimension ( : ) :: suborder - integer ( kind = 4 ) suborder_num - - call wandzura_suborder_num ( rule, suborder_num ) - - allocate ( suborder(1:suborder_num) ) - - call wandzura_suborder ( rule, suborder_num, suborder ) - - order_num = sum ( suborder(1:suborder_num) ) - - deallocate ( suborder ) - - return - end subroutine - - subroutine wandzura_rule_sp(rule, order_num, xy, w) - integer, intent(in) :: rule - integer, intent(in) :: order_num - real(kind = c_float), dimension(2, order_num), intent(out) :: xy - real(kind = c_float), dimension(order_num), intent(out) :: w - - real(kind = c_double), dimension(2, order_num) :: lxy - real(kind = c_double), dimension(order_num) :: lw - - call wandzura_rule(rule, order_num, lxy, lw) - xy = lxy - w = lw - - end subroutine wandzura_rule_sp - - subroutine wandzura_rule_orig ( rule, order_num, xy, w ) - - !*****************************************************************************80 - ! - !! WANDZURA_RULE returns the points and weights of a Wandzura rule. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 December 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Input, integer ( kind = 4 ) ORDER_NUM, the order (number of points) - ! of the rule. - ! - ! Output, real ( kind = 8 ) XY(2,ORDER_NUM), the points of the rule. - ! - ! Output, real ( kind = 8 ) W(ORDER_NUM), the weights of the rule. - ! - implicit none - - integer ( kind = 4 ) order_num - - integer ( kind = 4 ), parameter :: i4_1 = 1 - integer ( kind = 4 ), parameter :: i4_3 = 3 - integer ( kind = 4 ) k - integer ( kind = 4 ) o - integer ( kind = 4 ) rule - integer ( kind = 4 ) s - integer ( kind = 4 ), allocatable, dimension ( : ) :: suborder - integer ( kind = 4 ) suborder_num - real ( kind = 8 ), allocatable, dimension ( : ) :: suborder_w - real ( kind = 8 ), allocatable, dimension ( :, : ) :: suborder_xyz - real ( kind = 8 ) w(order_num) - real ( kind = 8 ) xy(2,order_num) - ! - ! Get the suborder information. - ! - call wandzura_suborder_num ( rule, suborder_num ) - - allocate ( suborder(suborder_num) ) - allocate ( suborder_xyz(3,suborder_num) ) - allocate ( suborder_w(suborder_num) ) - - call wandzura_suborder ( rule, suborder_num, suborder ) - - call wandzura_subrule ( rule, suborder_num, suborder_xyz, suborder_w ) - ! - ! Expand the suborder information to a full order rule. - ! - o = 0 - - do s = 1, suborder_num - - if ( suborder(s) == 1 ) then - - o = o + 1 - xy(1:2,o) = suborder_xyz(1:2,s) - w(o) = 0.5D+00 * suborder_w(s) - - else if ( suborder(s) == 3 ) then - - do k = 1, 3 - o = o + 1 - xy(1,o) = suborder_xyz ( i4_wrap(k, i4_1,i4_3), s ) - xy(2,o) = suborder_xyz ( i4_wrap(k+i4_1,i4_1,i4_3), s ) - w(o) = 0.5D+00 * suborder_w(s) - end do - - else if ( suborder(s) == 6 ) then - - do k = 1, 3 - o = o + 1 - xy(1,o) = suborder_xyz ( i4_wrap(k, i4_1,i4_3), s ) - xy(2,o) = suborder_xyz ( i4_wrap(k+i4_1,i4_1,i4_3), s ) - w(o) = 0.5D+00 * suborder_w(s) - end do - - do k = 1, 3 - o = o + 1 - xy(1,o) = suborder_xyz ( i4_wrap(k+i4_1,i4_1,i4_3), s ) - xy(2,o) = suborder_xyz ( i4_wrap(k, i4_1,i4_3), s ) - w(o) = 0.5D+00 * suborder_w(s) - end do + return + end subroutine + subroutine wandzura_subrule2 ( rule, suborder_num, suborder_xy, suborder_w ) + + !*****************************************************************************80 + ! + !! WANDZURA_SUBRULE2 returns a compressed Wandzura rule. + ! + ! Discussion: + ! + ! This version of the rules uses as reference the equilateral + ! triangle whose vertices are (-1/2,-sqrt(3)/2), (1,0), (-1/2,sqrt(3)/2). + ! + ! This, in fact, is the data as printed in the reference. + ! + ! Currently, we don't use this routine at all. The values of + ! X and Y here could be converted to lie XSI and ETA in the + ! standard (0,0), (1,0), (0,1) reference triangle by + ! + ! XSI = ( 2/3) * X + 1/3 + ! ETA = (-1/3) * X + sqrt(3)/3 * Y + 1/3 + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 11 May 2007 + ! + ! Author: + ! + ! John Burkardt + ! + ! Reference: + ! + ! Stephen Wandzura, Hong Xiao, + ! Symmetric Quadrature Rules on a Triangle, + ! Computers and Mathematics with Applications, + ! Volume 45, Number 12, June 2003, pages 1829-1840. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) RULE, the index of the rule. + ! + ! Input, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders + ! of the rule. + ! + ! Output, real ( kind = 8 ) SUBORDER_XY(2,SUBORDER_NUM), + ! the (X,Y) coordinates of the abscissas. + ! + ! Output, real ( kind = 8 ) SUBORDER_W(SUBORDER_NUM), the + ! suborder weights. + ! + implicit none + + integer ( kind = 4 ) suborder_num + + integer ( kind = 4 ), parameter :: i4_2 = 2 + integer ( kind = 4 ) rule + real ( kind = 8 ) suborder_w(suborder_num) + real ( kind = 8 ) suborder_xy(3,suborder_num) + + if ( rule == 1 ) then + + suborder_xy(1:2,1:suborder_num) = reshape ( (/ & + 0.0000000000000000D+00, 0.0000000000000000D+00, & + -0.4104261923153453D+00, 0.0000000000000000D+00, & + 0.6961404780296310D+00, 0.0000000000000000D+00 & + /), (/ i4_2, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.2250000000000000D+00, & + 0.1323941527885062D+00, & + 0.1259391805448271D+00 & + /) + + else if ( rule == 2 ) then + + suborder_xy(1:2,1:suborder_num) = reshape ( (/ & + 0.0000000000000000D+00, 0.0000000000000000D+00, & + -0.4935962988634245D+00, 0.0000000000000000D+00, & + -0.2840373491871686D+00, 0.0000000000000000D+00, & + 0.4457307617703263D+00, 0.0000000000000000D+00, & + 0.9385563442849673D+00, 0.0000000000000000D+00, & + -0.4474955151540920D+00, -0.5991595522781586D+00, & + -0.4436763946123360D+00, -0.2571781329392130D+00 & + /), (/ i4_2, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.8352339980519638D-01, & + 0.7229850592056743D-02, & + 0.7449217792098051D-01, & + 0.7864647340310853D-01, & + 0.6928323087107504D-02, & + 0.2951832033477940D-01, & + 0.3957936719606124D-01 & + /) + + else if ( rule == 3 ) then + + suborder_xy(1:2,1:suborder_num) = reshape ( (/ & + -0.3748423891073751D+00, 0.0000000000000000D+00, & + -0.2108313937373917D+00, 0.0000000000000000D+00, & + 0.1204084962609239D+00, 0.0000000000000000D+00, & + 0.5605966391716812D+00, 0.0000000000000000D+00, & + 0.8309113970031897D+00, 0.0000000000000000D+00, & + 0.9502746194248890D+00, 0.0000000000000000D+00, & + -0.4851316950361628D+00, -0.4425551659467111D+00, & + -0.4762943440546580D+00, -0.1510682717598242D+00, & + -0.4922845867745440D+00, -0.6970224211436132D+00, & + -0.4266165113705168D+00, -0.5642774363966393D+00, & + -0.3968468770512212D+00, -0.3095105740458471D+00, & + -0.2473933728129512D+00, -0.2320292030461791D+00 & + /), (/ i4_2, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.3266181884880529D-01, & + 0.2741281803136436D-01, & + 0.2651003659870330D-01, & + 0.2921596213648611D-01, & + 0.1058460806624399D-01, & + 0.3614643064092035D-02, & + 0.8527748101709436D-02, & + 0.1391617651669193D-01, & + 0.4291932940734835D-02, & + 0.1623532928177489D-01, & + 0.2560734092126239D-01, & + 0.3308819553164567D-01 & + /) + + else if ( rule == 4 ) then + + suborder_xy(1:2,1:suborder_num) = reshape ( (/ & + 0.0000000000000000D+00, 0.0000000000000000D+00, & + -0.4977490260133565D+00, 0.0000000000000000D+00, & + -0.3587903720915737D+00, 0.0000000000000000D+00, & + -0.1932918138657104D+00, 0.0000000000000000D+00, & + 0.2064993924016380D+00, 0.0000000000000000D+00, & + 0.3669431077237697D+00, 0.0000000000000000D+00, & + 0.6767931784861860D+00, 0.0000000000000000D+00, & + 0.8827927364865920D+00, 0.0000000000000000D+00, & + 0.9664768608120111D+00, 0.0000000000000000D+00, & + -0.4919755727189941D+00, -0.7513212483763635D+00, & + -0.4880677744007016D+00, -0.5870191642967427D+00, & + -0.4843664025781043D+00, -0.1717270984114328D+00, & + -0.4835533778058150D+00, -0.3833898305784408D+00, & + -0.4421499318718065D+00, -0.6563281974461070D+00, & + -0.4466292382741727D+00, -0.6157647932662624D-01, & + -0.4254937754558538D+00, -0.4783124082660027D+00, & + -0.4122204123735024D+00, -0.2537089901614676D+00, & + -0.3177533194934086D+00, -0.3996183176834929D+00, & + -0.2889337325840919D+00, -0.1844183967233982D+00 & + /), (/ i4_2, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.2761042699769952D-01, & + 0.1779029547326740D-02, & + 0.2011239811396117D-01, & + 0.2681784725933157D-01, & + 0.2452313380150201D-01, & + 0.1639457841069539D-01, & + 0.1479590739864960D-01, & + 0.4579282277704251D-02, & + 0.1651826515576217D-02, & + 0.2349170908575584D-02, & + 0.4465925754181793D-02, & + 0.6099566807907972D-02, & + 0.6891081327188203D-02, & + 0.7997475072478163D-02, & + 0.7386134285336024D-02, & + 0.1279933187864826D-01, & + 0.1725807117569655D-01, & + 0.1867294590293547D-01, & + 0.2281822405839526D-01 & + /) + + else if ( rule == 5 ) then + + suborder_xy(1:2,1:suborder_num) = reshape ( (/ & + -0.4580802753902387D+00, 0.0000000000000000D+00, & + -0.3032320980085228D+00, 0.0000000000000000D+00, & + -0.1696674057318916D+00, 0.0000000000000000D+00, & + 0.1046702979405866D+00, 0.0000000000000000D+00, & + 0.2978674829878846D+00, 0.0000000000000000D+00, & + 0.5455949961729473D+00, 0.0000000000000000D+00, & + 0.6617983193620190D+00, 0.0000000000000000D+00, & + 0.7668529237254211D+00, 0.0000000000000000D+00, & + 0.8953207191571090D+00, 0.0000000000000000D+00, & + 0.9782254461372029D+00, 0.0000000000000000D+00, & + -0.4980614709433367D+00, -0.4713592181681879D+00, & + -0.4919004480918257D+00, -0.1078887424748246D+00, & + -0.4904239954490375D+00, -0.3057041948876942D+00, & + -0.4924576827470104D+00, -0.7027546250883238D+00, & + -0.4897598620673272D+00, -0.7942765584469995D+00, & + -0.4849757005401057D+00, -0.5846826436376921D+00, & + -0.4613632802399150D+00, -0.4282174042835178D+00, & + -0.4546581528201263D+00, -0.2129434060653430D+00, & + -0.4542425148392569D+00, -0.6948910659636692D+00, & + -0.4310651789561460D+00, -0.5691146659505208D+00, & + -0.3988357991895837D+00, -0.3161666335733065D+00, & + -0.3949323628761341D+00, -0.1005941839340892D+00, & + -0.3741327130398251D+00, -0.4571406037889341D+00, & + -0.3194366964842710D+00, -0.2003599744104858D+00, & + -0.2778996512639500D+00, -0.3406754571040736D+00, & + -0.2123422011990124D+00, -0.1359589640107579D+00 & + /), (/ i4_2, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.8005581880020417D-02, & + 0.1594707683239050D-01, & + 0.1310914123079553D-01, & + 0.1958300096563562D-01, & + 0.1647088544153727D-01, & + 0.8547279074092100D-02, & + 0.8161885857226492D-02, & + 0.6121146539983779D-02, & + 0.2908498264936665D-02, & + 0.6922752456619963D-03, & + 0.1248289199277397D-02, & + 0.3404752908803022D-02, & + 0.3359654326064051D-02, & + 0.1716156539496754D-02, & + 0.1480856316715606D-02, & + 0.3511312610728685D-02, & + 0.7393550149706484D-02, & + 0.7983087477376558D-02, & + 0.4355962613158041D-02, & + 0.7365056701417832D-02, & + 0.1096357284641955D-01, & + 0.1174996174354112D-01, & + 0.1001560071379857D-01, & + 0.1330964078762868D-01, & + 0.1415444650522614D-01, & + 0.1488137956116801D-01 & + /) + + else if ( rule == 6 ) then + + suborder_xy(1:2,1:suborder_num) = reshape ( (/ & + 0.0000000000000000D+00, 0.0000000000000000D+00, & + -0.4890048253508517D+00, 0.0000000000000000D+00, & + -0.3755064862955532D+00, 0.0000000000000000D+00, & + -0.2735285658118844D+00, 0.0000000000000000D+00, & + -0.1461412101617502D+00, 0.0000000000000000D+00, & + 0.1570364626117722D+00, 0.0000000000000000D+00, & + 0.3179530724378968D+00, 0.0000000000000000D+00, & + 0.4763226654738105D+00, 0.0000000000000000D+00, & + 0.6302247183956902D+00, 0.0000000000000000D+00, & + 0.7597473133234094D+00, 0.0000000000000000D+00, & + 0.8566765977763036D+00, 0.0000000000000000D+00, & + 0.9348384559595755D+00, 0.0000000000000000D+00, & + 0.9857059671536891D+00, 0.0000000000000000D+00, & + -0.4986119432099803D+00, -0.1459114994581331D+00, & + -0.4979211112166541D+00, -0.7588411241269780D+00, & + -0.4944763768161339D+00, -0.5772061085255766D+00, & + -0.4941451648637610D+00, -0.8192831133859931D+00, & + -0.4951501277674842D+00, -0.3331061247123685D+00, & + -0.4902988518316453D+00, -0.6749680757240147D+00, & + -0.4951287867630010D+00, -0.4649148484601980D+00, & + -0.4869873637898693D+00, -0.2747479818680760D+00, & + -0.4766044602990292D+00, -0.7550787344330482D+00, & + -0.4730349181194722D+00, -0.1533908770581512D+00, & + -0.4743136319691660D+00, -0.4291730489015232D+00, & + -0.4656748919801272D+00, -0.5597446281020688D+00, & + -0.4508936040683500D+00, -0.6656779209607333D+00, & + -0.4492684814864886D+00, -0.3024354020045064D+00, & + -0.4466785783099771D+00, -0.3733933337926417D-01, & + -0.4241903145397002D+00, -0.4432574453491491D+00, & + -0.4144779276264017D+00, -0.1598390022600824D+00, & + -0.4037707903681949D+00, -0.5628520409756346D+00, & + -0.3792482775685616D+00, -0.3048723680294163D+00, & + -0.3434493977982042D+00, -0.4348816278906578D+00, & + -0.3292326583568731D+00, -0.1510147586773290D+00, & + -0.2819547684267144D+00, -0.2901177668548256D+00, & + -0.2150815207670319D+00, -0.1439403370753732D+00 & + /), (/ i4_2, suborder_num /) ) + + suborder_w(1:suborder_num) = (/ & + 0.1557996020289920D-01, & + 0.3177233700534134D-02, & + 0.1048342663573077D-01, & + 0.1320945957774363D-01, & + 0.1497500696627150D-01, & + 0.1498790444338419D-01, & + 0.1333886474102166D-01, & + 0.1088917111390201D-01, & + 0.8189440660893461D-02, & + 0.5575387588607785D-02, & + 0.3191216473411976D-02, & + 0.1296715144327045D-02, & + 0.2982628261349172D-03, & + 0.9989056850788964D-03, & + 0.4628508491732533D-03, & + 0.1234451336382413D-02, & + 0.5707198522432062D-03, & + 0.1126946125877624D-02, & + 0.1747866949407337D-02, & + 0.1182818815031657D-02, & + 0.1990839294675034D-02, & + 0.1900412795035980D-02, & + 0.4498365808817451D-02, & + 0.3478719460274719D-02, & + 0.4102399036723953D-02, & + 0.4021761549744162D-02, & + 0.6033164660795066D-02, & + 0.3946290302129598D-02, & + 0.6644044537680268D-02, & + 0.8254305856078458D-02, & + 0.6496056633406411D-02, & + 0.9252778144146602D-02, & + 0.9164920726294280D-02, & + 0.1156952462809767D-01, & + 0.1176111646760917D-01, & + 0.1382470218216540D-01 & + /) else - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'WANDZURA_RULE - Fatal error!' - write ( *, '(a,i8,a,i8)' ) ' Illegal SUBORDER(', s, ') = ', suborder(s) - stop + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'WANDZURA_SUBRULE2 - Fatal error!' + write ( *, '(a,i8)' ) ' Illegal RULE = ', rule + stop end if - end do - - deallocate ( suborder ) - deallocate ( suborder_xyz ) - deallocate ( suborder_w ) - - return - end subroutine - subroutine wandzura_rule_num ( rule_num ) - - !*****************************************************************************80 - ! - !! WANDZURA_RULE_NUM returns the number of Wandzura rules available. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 December 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Output, integer ( kind = 4 ) RULE_NUM, the number of rules available. - ! - implicit none - - integer ( kind = 4 ) rule_num - - rule_num = 6 - - return - end subroutine - subroutine wandzura_suborder ( rule, suborder_num, suborder ) - - !*****************************************************************************80 - ! - !! WANDZURA_SUBORDER returns the suborders for a Wandzura rule. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 December 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Input, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders - ! of the rule. - ! - ! Output, integer ( kind = 4 ) SUBORDER(SUBORDER_NUM), the suborders - ! of the rule. - ! - implicit none - - integer ( kind = 4 ) suborder_num - - integer ( kind = 4 ) rule - integer ( kind = 4 ) suborder(suborder_num) - - if ( rule == 1 ) then - suborder(1:suborder_num) = (/ & - 1, 3, 3 /) - else if ( rule == 2 ) then - suborder(1:suborder_num) = (/ & - 1, 3, 3, 3, 3, 6, 6 /) - else if ( rule == 3 ) then - suborder(1:suborder_num) = (/ & - 3, 3, 3, 3, 3, 3, 6, 6, 6, 6, & - 6, 6 /) - else if ( rule == 4 ) then - suborder(1:suborder_num) = (/ & - 1, 3, 3, 3, 3, 3, 3, 3, 3, 6, & - 6, 6, 6, 6, 6, 6, 6, 6, 6 /) - else if ( rule == 5 ) then - suborder(1:suborder_num) = (/ & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 6 /) - else if ( rule == 6 ) then - suborder(1:suborder_num) = (/ & - 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 6 /) - else - - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'WANDZURA_SUBORDER - Fatal error!' - write ( *, '(a,i8)' ) ' Illegal RULE = ', rule - stop - - end if - - return - end subroutine - subroutine wandzura_suborder_num ( rule, suborder_num ) - - !*****************************************************************************80 - ! - !! WANDZURA_SUBORDER_NUM returns the number of suborders for a Wandzura rule. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 December 2006 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Output, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders of the rule. - ! - implicit none - - integer ( kind = 4 ) rule - integer ( kind = 4 ) suborder_num - - if ( rule == 1 ) then - suborder_num = 3 - else if ( rule == 2 ) then - suborder_num = 7 - else if ( rule == 3 ) then - suborder_num = 12 - else if ( rule == 4 ) then - suborder_num = 19 - else if ( rule == 5 ) then - suborder_num = 26 - else if ( rule == 6 ) then - suborder_num = 36 - else - - suborder_num = -1 - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'WANDZURA_SUBORDER_NUM - Fatal error!' - write ( *, '(a,i8)' ) ' Illegal RULE = ', rule - stop - - end if - - return - end subroutine - subroutine wandzura_subrule ( rule, suborder_num, suborder_xyz, suborder_w ) - - !*****************************************************************************80 - ! - !! WANDZURA_SUBRULE returns a compressed Wandzura rule. - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 10 May 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Input, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders - ! of the rule. - ! - ! Output, real ( kind = 8 ) SUBORDER_XYZ(3,SUBORDER_NUM), - ! the barycentric coordinates of the abscissas. - ! - ! Output, real ( kind = 8 ) SUBORDER_W(SUBORDER_NUM), the - ! suborder weights. - ! - implicit none - - integer ( kind = 4 ) suborder_num - - integer ( kind = 4 ), parameter :: i4_3 = 3 - integer ( kind = 4 ) rule - real ( kind = 8 ) suborder_w(suborder_num) - real ( kind = 8 ) suborder_xyz(3,suborder_num) - - if ( rule == 1 ) then - - suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & - 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & - 0.05971587178977D+00, 0.47014206410512D+00, 0.47014206410512D+00, & - 0.79742698535309D+00, 0.10128650732346D+00, 0.10128650732346D+00 & - /), (/ i4_3, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.2250000000000000D+00, & - 0.1323941527885062D+00, & - 0.1259391805448271D+00 & - /) - - else if ( rule == 2 ) then - - suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & - 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & - 0.00426913409105D+00, 0.49786543295447D+00, 0.49786543295447D+00, & - 0.14397510054189D+00, 0.42801244972906D+00, 0.42801244972906D+00, & - 0.63048717451355D+00, 0.18475641274322D+00, 0.18475641274322D+00, & - 0.95903756285664D+00, 0.02048121857168D+00, 0.02048121857168D+00, & - 0.03500298989727D+00, 0.13657357625603D+00, 0.82842343384669D+00, & - 0.03754907025844D+00, 0.33274360058864D+00, 0.62970732915292D+00 & - /), (/ i4_3, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.8352339980519638D-01, & - 0.7229850592056743D-02, & - 0.7449217792098051D-01, & - 0.7864647340310853D-01, & - 0.6928323087107504D-02, & - 0.2951832033477940D-01, & - 0.3957936719606124D-01 & - /) - - else if ( rule == 3 ) then - - suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & - 0.08343840726175D+00, 0.45828079636912D+00, 0.45828079636913D+00, & - 0.19277907084174D+00, 0.40361046457913D+00, 0.40361046457913D+00, & - 0.41360566417395D+00, 0.29319716791303D+00, 0.29319716791303D+00, & - 0.70706442611445D+00, 0.14646778694277D+00, 0.14646778694277D+00, & - 0.88727426466879D+00, 0.05636286766560D+00, 0.05636286766560D+00, & - 0.96684974628326D+00, 0.01657512685837D+00, 0.01657512685837D+00, & - 0.00991220330923D+00, 0.23953455415479D+00, 0.75055324253598D+00, & - 0.01580377063023D+00, 0.40487880731834D+00, 0.57931742205143D+00, & - 0.00514360881697D+00, 0.09500211311304D+00, 0.89985427806998D+00, & - 0.04892232575299D+00, 0.14975310732227D+00, 0.80132456692474D+00, & - 0.06876874863252D+00, 0.28691961244133D+00, 0.64431163892615D+00, & - 0.16840441812470D+00, 0.28183566809908D+00, 0.54975991377622D+00 & - /), (/ i4_3, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.3266181884880529D-01, & - 0.2741281803136436D-01, & - 0.2651003659870330D-01, & - 0.2921596213648611D-01, & - 0.1058460806624399D-01, & - 0.3614643064092035D-02, & - 0.8527748101709436D-02, & - 0.1391617651669193D-01, & - 0.4291932940734835D-02, & - 0.1623532928177489D-01, & - 0.2560734092126239D-01, & - 0.3308819553164567D-01 & - /) - - else if ( rule == 4 ) then - - suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & - 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & - 0.00150064932443D+00, 0.49924967533779D+00, 0.49924967533779D+00, & - 0.09413975193895D+00, 0.45293012403052D+00, 0.45293012403052D+00, & - 0.20447212408953D+00, 0.39776393795524D+00, 0.39776393795524D+00, & - 0.47099959493443D+00, 0.26450020253279D+00, 0.26450020253279D+00, & - 0.57796207181585D+00, 0.21101896409208D+00, 0.21101896409208D+00, & - 0.78452878565746D+00, 0.10773560717127D+00, 0.10773560717127D+00, & - 0.92186182432439D+00, 0.03906908783780D+00, 0.03906908783780D+00, & - 0.97765124054134D+00, 0.01117437972933D+00, 0.01117437972933D+00, & - 0.00534961818734D+00, 0.06354966590835D+00, 0.93110071590431D+00, & - 0.00795481706620D+00, 0.15710691894071D+00, 0.83493826399309D+00, & - 0.01042239828126D+00, 0.39564211436437D+00, 0.59393548735436D+00, & - 0.01096441479612D+00, 0.27316757071291D+00, 0.71586801449097D+00, & - 0.03856671208546D+00, 0.10178538248502D+00, 0.85964790542952D+00, & - 0.03558050781722D+00, 0.44665854917641D+00, 0.51776094300637D+00, & - 0.04967081636276D+00, 0.19901079414950D+00, 0.75131838948773D+00, & - 0.05851972508433D+00, 0.32426118369228D+00, 0.61721909122339D+00, & - 0.12149778700439D+00, 0.20853136321013D+00, 0.66997084978547D+00, & - 0.14071084494394D+00, 0.32317056653626D+00, 0.53611858851980D+00 & - /), (/ i4_3, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.2761042699769952D-01, & - 0.1779029547326740D-02, & - 0.2011239811396117D-01, & - 0.2681784725933157D-01, & - 0.2452313380150201D-01, & - 0.1639457841069539D-01, & - 0.1479590739864960D-01, & - 0.4579282277704251D-02, & - 0.1651826515576217D-02, & - 0.2349170908575584D-02, & - 0.4465925754181793D-02, & - 0.6099566807907972D-02, & - 0.6891081327188203D-02, & - 0.7997475072478163D-02, & - 0.7386134285336024D-02, & - 0.1279933187864826D-01, & - 0.1725807117569655D-01, & - 0.1867294590293547D-01, & - 0.2281822405839526D-01 & - /) - - else if ( rule == 5 ) then - - suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & - 0.02794648307317D+00, 0.48602675846341D+00, 0.48602675846341D+00, & - 0.13117860132765D+00, 0.43441069933617D+00, 0.43441069933617D+00, & - 0.22022172951207D+00, 0.38988913524396D+00, 0.38988913524396D+00, & - 0.40311353196039D+00, 0.29844323401980D+00, 0.29844323401980D+00, & - 0.53191165532526D+00, 0.23404417233737D+00, 0.23404417233737D+00, & - 0.69706333078196D+00, 0.15146833460902D+00, 0.15146833460902D+00, & - 0.77453221290801D+00, 0.11273389354599D+00, 0.11273389354599D+00, & - 0.84456861581695D+00, 0.07771569209153D+00, 0.07771569209153D+00, & - 0.93021381277141D+00, 0.03489309361430D+00, 0.03489309361430D+00, & - 0.98548363075813D+00, 0.00725818462093D+00, 0.00725818462093D+00, & - 0.00129235270444D+00, 0.22721445215336D+00, 0.77149319514219D+00, & - 0.00539970127212D+00, 0.43501055485357D+00, 0.55958974387431D+00, & - 0.00638400303398D+00, 0.32030959927220D+00, 0.67330639769382D+00, & - 0.00502821150199D+00, 0.09175032228001D+00, 0.90322146621800D+00, & - 0.00682675862178D+00, 0.03801083585872D+00, 0.95516240551949D+00, & - 0.01001619963993D+00, 0.15742521848531D+00, 0.83255858187476D+00, & - 0.02575781317339D+00, 0.23988965977853D+00, 0.73435252704808D+00, & - 0.03022789811992D+00, 0.36194311812606D+00, 0.60782898375402D+00, & - 0.03050499010716D+00, 0.08355196095483D+00, 0.88594304893801D+00, & - 0.04595654736257D+00, 0.14844322073242D+00, 0.80560023190501D+00, & - 0.06744280054028D+00, 0.28373970872753D+00, 0.64881749073219D+00, & - 0.07004509141591D+00, 0.40689937511879D+00, 0.52305553346530D+00, & - 0.08391152464012D+00, 0.19411398702489D+00, 0.72197448833499D+00, & - 0.12037553567715D+00, 0.32413434700070D+00, 0.55549011732214D+00, & - 0.14806689915737D+00, 0.22927748355598D+00, 0.62265561728665D+00, & - 0.19177186586733D+00, 0.32561812259598D+00, 0.48261001153669D+00 & - /), (/ i4_3, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.8005581880020417D-02, & - 0.1594707683239050D-01, & - 0.1310914123079553D-01, & - 0.1958300096563562D-01, & - 0.1647088544153727D-01, & - 0.8547279074092100D-02, & - 0.8161885857226492D-02, & - 0.6121146539983779D-02, & - 0.2908498264936665D-02, & - 0.6922752456619963D-03, & - 0.1248289199277397D-02, & - 0.3404752908803022D-02, & - 0.3359654326064051D-02, & - 0.1716156539496754D-02, & - 0.1480856316715606D-02, & - 0.3511312610728685D-02, & - 0.7393550149706484D-02, & - 0.7983087477376558D-02, & - 0.4355962613158041D-02, & - 0.7365056701417832D-02, & - 0.1096357284641955D-01, & - 0.1174996174354112D-01, & - 0.1001560071379857D-01, & - 0.1330964078762868D-01, & - 0.1415444650522614D-01, & - 0.1488137956116801D-01 & - /) - - else if ( rule == 6 ) then - - suborder_xyz(1:3,1:suborder_num) = reshape ( (/ & - 0.33333333333333D+00, 0.33333333333333D+00, 0.33333333333333D+00, & - 0.00733011643277D+00, 0.49633494178362D+00, 0.49633494178362D+00, & - 0.08299567580296D+00, 0.45850216209852D+00, 0.45850216209852D+00, & - 0.15098095612541D+00, 0.42450952193729D+00, 0.42450952193729D+00, & - 0.23590585989217D+00, 0.38204707005392D+00, 0.38204707005392D+00, & - 0.43802430840785D+00, 0.28098784579608D+00, 0.28098784579608D+00, & - 0.54530204829193D+00, 0.22734897585403D+00, 0.22734897585403D+00, & - 0.65088177698254D+00, 0.17455911150873D+00, 0.17455911150873D+00, & - 0.75348314559713D+00, 0.12325842720144D+00, 0.12325842720144D+00, & - 0.83983154221561D+00, 0.08008422889220D+00, 0.08008422889220D+00, & - 0.90445106518420D+00, 0.04777446740790D+00, 0.04777446740790D+00, & - 0.95655897063972D+00, 0.02172051468014D+00, 0.02172051468014D+00, & - 0.99047064476913D+00, 0.00476467761544D+00, 0.00476467761544D+00, & - 0.00092537119335D+00, 0.41529527091331D+00, 0.58377935789334D+00, & - 0.00138592585556D+00, 0.06118990978535D+00, 0.93742416435909D+00, & - 0.00368241545591D+00, 0.16490869013691D+00, 0.83140889440718D+00, & - 0.00390322342416D+00, 0.02503506223200D+00, 0.97106171434384D+00, & - 0.00323324815501D+00, 0.30606446515110D+00, 0.69070228669389D+00, & - 0.00646743211224D+00, 0.10707328373022D+00, 0.88645928415754D+00, & - 0.00324747549133D+00, 0.22995754934558D+00, 0.76679497516308D+00, & - 0.00867509080675D+00, 0.33703663330578D+00, 0.65428827588746D+00, & - 0.01559702646731D+00, 0.05625657618206D+00, 0.92814639735063D+00, & - 0.01797672125369D+00, 0.40245137521240D+00, 0.57957190353391D+00, & - 0.01712424535389D+00, 0.24365470201083D+00, 0.73922105263528D+00, & - 0.02288340534658D+00, 0.16538958561453D+00, 0.81172700903888D+00, & - 0.03273759728777D+00, 0.09930187449585D+00, 0.86796052821639D+00, & - 0.03382101234234D+00, 0.30847833306905D+00, 0.65770065458860D+00, & - 0.03554761446002D+00, 0.46066831859211D+00, 0.50378406694787D+00, & - 0.05053979030687D+00, 0.21881529945393D+00, 0.73064491023920D+00, & - 0.05701471491573D+00, 0.37920955156027D+00, 0.56377573352399D+00, & - 0.06415280642120D+00, 0.14296081941819D+00, 0.79288637416061D+00, & - 0.08050114828763D+00, 0.28373128210592D+00, 0.63576756960645D+00, & - 0.10436706813453D+00, 0.19673744100444D+00, 0.69889549086103D+00, & - 0.11384489442875D+00, 0.35588914121166D+00, 0.53026596435959D+00, & - 0.14536348771552D+00, 0.25981868535191D+00, 0.59481782693256D+00, & - 0.18994565282198D+00, 0.32192318123130D+00, 0.48813116594672D+00 & - /), (/ i4_3, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.1557996020289920D-01, & - 0.3177233700534134D-02, & - 0.1048342663573077D-01, & - 0.1320945957774363D-01, & - 0.1497500696627150D-01, & - 0.1498790444338419D-01, & - 0.1333886474102166D-01, & - 0.1088917111390201D-01, & - 0.8189440660893461D-02, & - 0.5575387588607785D-02, & - 0.3191216473411976D-02, & - 0.1296715144327045D-02, & - 0.2982628261349172D-03, & - 0.9989056850788964D-03, & - 0.4628508491732533D-03, & - 0.1234451336382413D-02, & - 0.5707198522432062D-03, & - 0.1126946125877624D-02, & - 0.1747866949407337D-02, & - 0.1182818815031657D-02, & - 0.1990839294675034D-02, & - 0.1900412795035980D-02, & - 0.4498365808817451D-02, & - 0.3478719460274719D-02, & - 0.4102399036723953D-02, & - 0.4021761549744162D-02, & - 0.6033164660795066D-02, & - 0.3946290302129598D-02, & - 0.6644044537680268D-02, & - 0.8254305856078458D-02, & - 0.6496056633406411D-02, & - 0.9252778144146602D-02, & - 0.9164920726294280D-02, & - 0.1156952462809767D-01, & - 0.1176111646760917D-01, & - 0.1382470218216540D-01 & - /) - - else - - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'WANDZURA_SUBRULE - Fatal error!' - write ( *, '(a,i8)' ) ' Illegal RULE = ', rule - stop - - end if - - return - end subroutine - subroutine wandzura_subrule2 ( rule, suborder_num, suborder_xy, suborder_w ) - - !*****************************************************************************80 - ! - !! WANDZURA_SUBRULE2 returns a compressed Wandzura rule. - ! - ! Discussion: - ! - ! This version of the rules uses as reference the equilateral - ! triangle whose vertices are (-1/2,-sqrt(3)/2), (1,0), (-1/2,sqrt(3)/2). - ! - ! This, in fact, is the data as printed in the reference. - ! - ! Currently, we don't use this routine at all. The values of - ! X and Y here could be converted to lie XSI and ETA in the - ! standard (0,0), (1,0), (0,1) reference triangle by - ! - ! XSI = ( 2/3) * X + 1/3 - ! ETA = (-1/3) * X + sqrt(3)/3 * Y + 1/3 - ! - ! Licensing: - ! - ! This code is distributed under the GNU LGPL license. - ! - ! Modified: - ! - ! 11 May 2007 - ! - ! Author: - ! - ! John Burkardt - ! - ! Reference: - ! - ! Stephen Wandzura, Hong Xiao, - ! Symmetric Quadrature Rules on a Triangle, - ! Computers and Mathematics with Applications, - ! Volume 45, Number 12, June 2003, pages 1829-1840. - ! - ! Parameters: - ! - ! Input, integer ( kind = 4 ) RULE, the index of the rule. - ! - ! Input, integer ( kind = 4 ) SUBORDER_NUM, the number of suborders - ! of the rule. - ! - ! Output, real ( kind = 8 ) SUBORDER_XY(2,SUBORDER_NUM), - ! the (X,Y) coordinates of the abscissas. - ! - ! Output, real ( kind = 8 ) SUBORDER_W(SUBORDER_NUM), the - ! suborder weights. - ! - implicit none - - integer ( kind = 4 ) suborder_num - - integer ( kind = 4 ), parameter :: i4_2 = 2 - integer ( kind = 4 ) rule - real ( kind = 8 ) suborder_w(suborder_num) - real ( kind = 8 ) suborder_xy(3,suborder_num) - - if ( rule == 1 ) then - - suborder_xy(1:2,1:suborder_num) = reshape ( (/ & - 0.0000000000000000D+00, 0.0000000000000000D+00, & - -0.4104261923153453D+00, 0.0000000000000000D+00, & - 0.6961404780296310D+00, 0.0000000000000000D+00 & - /), (/ i4_2, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.2250000000000000D+00, & - 0.1323941527885062D+00, & - 0.1259391805448271D+00 & - /) - - else if ( rule == 2 ) then - - suborder_xy(1:2,1:suborder_num) = reshape ( (/ & - 0.0000000000000000D+00, 0.0000000000000000D+00, & - -0.4935962988634245D+00, 0.0000000000000000D+00, & - -0.2840373491871686D+00, 0.0000000000000000D+00, & - 0.4457307617703263D+00, 0.0000000000000000D+00, & - 0.9385563442849673D+00, 0.0000000000000000D+00, & - -0.4474955151540920D+00, -0.5991595522781586D+00, & - -0.4436763946123360D+00, -0.2571781329392130D+00 & - /), (/ i4_2, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.8352339980519638D-01, & - 0.7229850592056743D-02, & - 0.7449217792098051D-01, & - 0.7864647340310853D-01, & - 0.6928323087107504D-02, & - 0.2951832033477940D-01, & - 0.3957936719606124D-01 & - /) - - else if ( rule == 3 ) then - - suborder_xy(1:2,1:suborder_num) = reshape ( (/ & - -0.3748423891073751D+00, 0.0000000000000000D+00, & - -0.2108313937373917D+00, 0.0000000000000000D+00, & - 0.1204084962609239D+00, 0.0000000000000000D+00, & - 0.5605966391716812D+00, 0.0000000000000000D+00, & - 0.8309113970031897D+00, 0.0000000000000000D+00, & - 0.9502746194248890D+00, 0.0000000000000000D+00, & - -0.4851316950361628D+00, -0.4425551659467111D+00, & - -0.4762943440546580D+00, -0.1510682717598242D+00, & - -0.4922845867745440D+00, -0.6970224211436132D+00, & - -0.4266165113705168D+00, -0.5642774363966393D+00, & - -0.3968468770512212D+00, -0.3095105740458471D+00, & - -0.2473933728129512D+00, -0.2320292030461791D+00 & - /), (/ i4_2, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.3266181884880529D-01, & - 0.2741281803136436D-01, & - 0.2651003659870330D-01, & - 0.2921596213648611D-01, & - 0.1058460806624399D-01, & - 0.3614643064092035D-02, & - 0.8527748101709436D-02, & - 0.1391617651669193D-01, & - 0.4291932940734835D-02, & - 0.1623532928177489D-01, & - 0.2560734092126239D-01, & - 0.3308819553164567D-01 & - /) - - else if ( rule == 4 ) then - - suborder_xy(1:2,1:suborder_num) = reshape ( (/ & - 0.0000000000000000D+00, 0.0000000000000000D+00, & - -0.4977490260133565D+00, 0.0000000000000000D+00, & - -0.3587903720915737D+00, 0.0000000000000000D+00, & - -0.1932918138657104D+00, 0.0000000000000000D+00, & - 0.2064993924016380D+00, 0.0000000000000000D+00, & - 0.3669431077237697D+00, 0.0000000000000000D+00, & - 0.6767931784861860D+00, 0.0000000000000000D+00, & - 0.8827927364865920D+00, 0.0000000000000000D+00, & - 0.9664768608120111D+00, 0.0000000000000000D+00, & - -0.4919755727189941D+00, -0.7513212483763635D+00, & - -0.4880677744007016D+00, -0.5870191642967427D+00, & - -0.4843664025781043D+00, -0.1717270984114328D+00, & - -0.4835533778058150D+00, -0.3833898305784408D+00, & - -0.4421499318718065D+00, -0.6563281974461070D+00, & - -0.4466292382741727D+00, -0.6157647932662624D-01, & - -0.4254937754558538D+00, -0.4783124082660027D+00, & - -0.4122204123735024D+00, -0.2537089901614676D+00, & - -0.3177533194934086D+00, -0.3996183176834929D+00, & - -0.2889337325840919D+00, -0.1844183967233982D+00 & - /), (/ i4_2, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.2761042699769952D-01, & - 0.1779029547326740D-02, & - 0.2011239811396117D-01, & - 0.2681784725933157D-01, & - 0.2452313380150201D-01, & - 0.1639457841069539D-01, & - 0.1479590739864960D-01, & - 0.4579282277704251D-02, & - 0.1651826515576217D-02, & - 0.2349170908575584D-02, & - 0.4465925754181793D-02, & - 0.6099566807907972D-02, & - 0.6891081327188203D-02, & - 0.7997475072478163D-02, & - 0.7386134285336024D-02, & - 0.1279933187864826D-01, & - 0.1725807117569655D-01, & - 0.1867294590293547D-01, & - 0.2281822405839526D-01 & - /) - - else if ( rule == 5 ) then - - suborder_xy(1:2,1:suborder_num) = reshape ( (/ & - -0.4580802753902387D+00, 0.0000000000000000D+00, & - -0.3032320980085228D+00, 0.0000000000000000D+00, & - -0.1696674057318916D+00, 0.0000000000000000D+00, & - 0.1046702979405866D+00, 0.0000000000000000D+00, & - 0.2978674829878846D+00, 0.0000000000000000D+00, & - 0.5455949961729473D+00, 0.0000000000000000D+00, & - 0.6617983193620190D+00, 0.0000000000000000D+00, & - 0.7668529237254211D+00, 0.0000000000000000D+00, & - 0.8953207191571090D+00, 0.0000000000000000D+00, & - 0.9782254461372029D+00, 0.0000000000000000D+00, & - -0.4980614709433367D+00, -0.4713592181681879D+00, & - -0.4919004480918257D+00, -0.1078887424748246D+00, & - -0.4904239954490375D+00, -0.3057041948876942D+00, & - -0.4924576827470104D+00, -0.7027546250883238D+00, & - -0.4897598620673272D+00, -0.7942765584469995D+00, & - -0.4849757005401057D+00, -0.5846826436376921D+00, & - -0.4613632802399150D+00, -0.4282174042835178D+00, & - -0.4546581528201263D+00, -0.2129434060653430D+00, & - -0.4542425148392569D+00, -0.6948910659636692D+00, & - -0.4310651789561460D+00, -0.5691146659505208D+00, & - -0.3988357991895837D+00, -0.3161666335733065D+00, & - -0.3949323628761341D+00, -0.1005941839340892D+00, & - -0.3741327130398251D+00, -0.4571406037889341D+00, & - -0.3194366964842710D+00, -0.2003599744104858D+00, & - -0.2778996512639500D+00, -0.3406754571040736D+00, & - -0.2123422011990124D+00, -0.1359589640107579D+00 & - /), (/ i4_2, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.8005581880020417D-02, & - 0.1594707683239050D-01, & - 0.1310914123079553D-01, & - 0.1958300096563562D-01, & - 0.1647088544153727D-01, & - 0.8547279074092100D-02, & - 0.8161885857226492D-02, & - 0.6121146539983779D-02, & - 0.2908498264936665D-02, & - 0.6922752456619963D-03, & - 0.1248289199277397D-02, & - 0.3404752908803022D-02, & - 0.3359654326064051D-02, & - 0.1716156539496754D-02, & - 0.1480856316715606D-02, & - 0.3511312610728685D-02, & - 0.7393550149706484D-02, & - 0.7983087477376558D-02, & - 0.4355962613158041D-02, & - 0.7365056701417832D-02, & - 0.1096357284641955D-01, & - 0.1174996174354112D-01, & - 0.1001560071379857D-01, & - 0.1330964078762868D-01, & - 0.1415444650522614D-01, & - 0.1488137956116801D-01 & - /) - - else if ( rule == 6 ) then - - suborder_xy(1:2,1:suborder_num) = reshape ( (/ & - 0.0000000000000000D+00, 0.0000000000000000D+00, & - -0.4890048253508517D+00, 0.0000000000000000D+00, & - -0.3755064862955532D+00, 0.0000000000000000D+00, & - -0.2735285658118844D+00, 0.0000000000000000D+00, & - -0.1461412101617502D+00, 0.0000000000000000D+00, & - 0.1570364626117722D+00, 0.0000000000000000D+00, & - 0.3179530724378968D+00, 0.0000000000000000D+00, & - 0.4763226654738105D+00, 0.0000000000000000D+00, & - 0.6302247183956902D+00, 0.0000000000000000D+00, & - 0.7597473133234094D+00, 0.0000000000000000D+00, & - 0.8566765977763036D+00, 0.0000000000000000D+00, & - 0.9348384559595755D+00, 0.0000000000000000D+00, & - 0.9857059671536891D+00, 0.0000000000000000D+00, & - -0.4986119432099803D+00, -0.1459114994581331D+00, & - -0.4979211112166541D+00, -0.7588411241269780D+00, & - -0.4944763768161339D+00, -0.5772061085255766D+00, & - -0.4941451648637610D+00, -0.8192831133859931D+00, & - -0.4951501277674842D+00, -0.3331061247123685D+00, & - -0.4902988518316453D+00, -0.6749680757240147D+00, & - -0.4951287867630010D+00, -0.4649148484601980D+00, & - -0.4869873637898693D+00, -0.2747479818680760D+00, & - -0.4766044602990292D+00, -0.7550787344330482D+00, & - -0.4730349181194722D+00, -0.1533908770581512D+00, & - -0.4743136319691660D+00, -0.4291730489015232D+00, & - -0.4656748919801272D+00, -0.5597446281020688D+00, & - -0.4508936040683500D+00, -0.6656779209607333D+00, & - -0.4492684814864886D+00, -0.3024354020045064D+00, & - -0.4466785783099771D+00, -0.3733933337926417D-01, & - -0.4241903145397002D+00, -0.4432574453491491D+00, & - -0.4144779276264017D+00, -0.1598390022600824D+00, & - -0.4037707903681949D+00, -0.5628520409756346D+00, & - -0.3792482775685616D+00, -0.3048723680294163D+00, & - -0.3434493977982042D+00, -0.4348816278906578D+00, & - -0.3292326583568731D+00, -0.1510147586773290D+00, & - -0.2819547684267144D+00, -0.2901177668548256D+00, & - -0.2150815207670319D+00, -0.1439403370753732D+00 & - /), (/ i4_2, suborder_num /) ) - - suborder_w(1:suborder_num) = (/ & - 0.1557996020289920D-01, & - 0.3177233700534134D-02, & - 0.1048342663573077D-01, & - 0.1320945957774363D-01, & - 0.1497500696627150D-01, & - 0.1498790444338419D-01, & - 0.1333886474102166D-01, & - 0.1088917111390201D-01, & - 0.8189440660893461D-02, & - 0.5575387588607785D-02, & - 0.3191216473411976D-02, & - 0.1296715144327045D-02, & - 0.2982628261349172D-03, & - 0.9989056850788964D-03, & - 0.4628508491732533D-03, & - 0.1234451336382413D-02, & - 0.5707198522432062D-03, & - 0.1126946125877624D-02, & - 0.1747866949407337D-02, & - 0.1182818815031657D-02, & - 0.1990839294675034D-02, & - 0.1900412795035980D-02, & - 0.4498365808817451D-02, & - 0.3478719460274719D-02, & - 0.4102399036723953D-02, & - 0.4021761549744162D-02, & - 0.6033164660795066D-02, & - 0.3946290302129598D-02, & - 0.6644044537680268D-02, & - 0.8254305856078458D-02, & - 0.6496056633406411D-02, & - 0.9252778144146602D-02, & - 0.9164920726294280D-02, & - 0.1156952462809767D-01, & - 0.1176111646760917D-01, & - 0.1382470218216540D-01 & - /) - - else - - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'WANDZURA_SUBRULE2 - Fatal error!' - write ( *, '(a,i8)' ) ' Illegal RULE = ', rule - stop - - end if - - return - end subroutine + return + end subroutine end module wandzura_quadrature diff --git a/femtools/Write_GMSH.F90 b/femtools/Write_GMSH.F90 index 215b0c8abf..242494c2c0 100644 --- a/femtools/Write_GMSH.F90 +++ b/femtools/Write_GMSH.F90 @@ -29,475 +29,475 @@ module write_gmsh - use fldebug + use fldebug - use global_parameters, only : OPTION_PATH_LEN - use futils - use elements - use parallel_tools - use fields - use state_module - use field_options - use gmsh_common + use global_parameters, only : OPTION_PATH_LEN + use futils + use elements + use parallel_tools + use fields + use state_module + use field_options + use gmsh_common - implicit none + implicit none - private + private - public :: write_gmsh_file + public :: write_gmsh_file - interface write_gmsh_file - module procedure write_mesh_to_gmsh, write_positions_to_gmsh - end interface + interface write_gmsh_file + module procedure write_mesh_to_gmsh, write_positions_to_gmsh + end interface - ! Writes to GMSH binary format - can set to ASCII (handy for debugging) - logical, parameter :: useBinaryGMSH=.true. + ! Writes to GMSH binary format - can set to ASCII (handy for debugging) + logical, parameter :: useBinaryGMSH=.true. contains - ! ----------------------------------------------------------------- - ! GMSH equivalents of write_triangle. Have been a bit - ! naughty and assumed you want to write to binary - ! GMSH format. - ! ----------------------------------------------------------------- + ! ----------------------------------------------------------------- + ! GMSH equivalents of write_triangle. Have been a bit + ! naughty and assumed you want to write to binary + ! GMSH format. + ! ----------------------------------------------------------------- - subroutine write_mesh_to_gmsh(filename, state, mesh, number_of_partitions) + subroutine write_mesh_to_gmsh(filename, state, mesh, number_of_partitions) - character(len = *), intent(in) :: filename - type(state_type), intent(in) :: state - type(mesh_type), intent(in) :: mesh - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions + character(len = *), intent(in) :: filename + type(state_type), intent(in) :: state + type(mesh_type), intent(in) :: mesh + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions - type(vector_field) :: positions + type(vector_field) :: positions - positions = get_nodal_coordinate_field( state, mesh ) + positions = get_nodal_coordinate_field( state, mesh ) - call write_gmsh_file( filename, positions, number_of_partitions=number_of_partitions) + call write_gmsh_file( filename, positions, number_of_partitions=number_of_partitions) - ! Deallocate node and element memory structures - call deallocate(positions) + ! Deallocate node and element memory structures + call deallocate(positions) - end subroutine write_mesh_to_gmsh + end subroutine write_mesh_to_gmsh - ! ----------------------------------------------------------------- + ! ----------------------------------------------------------------- - subroutine write_positions_to_gmsh(filename, positions, number_of_partitions) - !!< Write out the mesh given by the position field in GMSH file: - !!< In parallel, empty trailing processes are not written. - character(len=*), intent(in):: filename - type(vector_field), intent(in):: positions - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions + subroutine write_positions_to_gmsh(filename, positions, number_of_partitions) + !!< Write out the mesh given by the position field in GMSH file: + !!< In parallel, empty trailing processes are not written. + character(len=*), intent(in):: filename + type(vector_field), intent(in):: positions + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions - character(len=longStringLen) :: meshFile - integer :: numParts, fileDesc + character(len=longStringLen) :: meshFile + integer :: numParts, fileDesc - if (present(number_of_partitions)) then - numParts = number_of_partitions - else - numParts = getnprocs() - end if + if (present(number_of_partitions)) then + numParts = number_of_partitions + else + numParts = getnprocs() + end if - ! Write out data only for those processes that contain data - SPMD requires - ! that there be no early return - if( getprocno() <= numParts ) then + ! Write out data only for those processes that contain data - SPMD requires + ! that there be no early return + if( getprocno() <= numParts ) then - fileDesc=free_unit() + fileDesc=free_unit() - meshFile = trim(filename) // ".msh" + meshFile = trim(filename) // ".msh" - open( fileDesc, file=trim(meshFile), status="replace", access="stream", & - action="write", err=101 ) + open( fileDesc, file=trim(meshFile), status="replace", access="stream", & + action="write", err=101 ) - end if + end if - if( getprocno() <= numParts ) then - ! Writing GMSH file header - call write_gmsh_header( fileDesc, meshFile, useBinaryGMSH ) - call write_gmsh_nodes( fileDesc, meshFile, positions, useBinaryGMSH ) - call write_gmsh_faces_and_elements( fileDesc, meshFile, & + if( getprocno() <= numParts ) then + ! Writing GMSH file header + call write_gmsh_header( fileDesc, meshFile, useBinaryGMSH ) + call write_gmsh_nodes( fileDesc, meshFile, positions, useBinaryGMSH ) + call write_gmsh_faces_and_elements( fileDesc, meshFile, & positions%mesh, useBinaryGMSH ) - ! write columns data if present - if (associated(positions%mesh%columns)) then - call write_gmsh_node_columns( fileDesc, meshFile, positions, & + ! write columns data if present + if (associated(positions%mesh%columns)) then + call write_gmsh_node_columns( fileDesc, meshFile, positions, & useBinaryGMSH ) - end if + end if - ! Close GMSH file - close( fileDesc ) + ! Close GMSH file + close( fileDesc ) - end if + end if - return + return -101 FLExit("Failed to open " // trim(meshFile) // " for writing") +101 FLExit("Failed to open " // trim(meshFile) // " for writing") - end subroutine write_positions_to_gmsh + end subroutine write_positions_to_gmsh - ! ----------------------------------------------------------------- - ! Write out GMSH header + ! ----------------------------------------------------------------- + ! Write out GMSH header - subroutine write_gmsh_header( fd, lfilename, useBinaryGMSH ) - integer :: fd - character(len=*) :: lfilename - logical :: useBinaryGMSH - character(len=999) :: GMSHVersionStr, GMSHFileFormat, GMSHdoubleNumBytes + subroutine write_gmsh_header( fd, lfilename, useBinaryGMSH ) + integer :: fd + character(len=*) :: lfilename + logical :: useBinaryGMSH + character(len=999) :: GMSHVersionStr, GMSHFileFormat, GMSHdoubleNumBytes - integer, parameter :: oneInt = 1 + integer, parameter :: oneInt = 1 - call ascii_formatting(fd, lfilename, "write") + call ascii_formatting(fd, lfilename, "write") - GMSHVersionStr="2.1" + GMSHVersionStr="2.1" - if(useBinaryGMSH) then - ! GMSH binary format - GMSHFileFormat="1" - else - GMSHFileFormat="0" - end if + if(useBinaryGMSH) then + ! GMSH binary format + GMSHFileFormat="1" + else + GMSHFileFormat="0" + end if - write(GMSHdoubleNumBytes, *) doubleNumBytes - write(fd, "(A)") "$MeshFormat" - write(fd, "(A)") trim(GMSHVersionStr)//" "//trim(GMSHFileFormat)//" " & + write(GMSHdoubleNumBytes, *) doubleNumBytes + write(fd, "(A)") "$MeshFormat" + write(fd, "(A)") trim(GMSHVersionStr)//" "//trim(GMSHFileFormat)//" " & //trim(adjustl(GMSHdoubleNumBytes)) - if(useBinaryGMSH) then - call binary_formatting(fd, lfilename, "write") + if(useBinaryGMSH) then + call binary_formatting(fd, lfilename, "write") - ! The 32-bit integer "1", followed by a newline - write(fd) oneInt, char(10) - call ascii_formatting(fd, lfilename, "write") - end if + ! The 32-bit integer "1", followed by a newline + write(fd) oneInt, char(10) + call ascii_formatting(fd, lfilename, "write") + end if - write(fd, "(A)") "$EndMeshFormat" + write(fd, "(A)") "$EndMeshFormat" - end subroutine write_gmsh_header + end subroutine write_gmsh_header - ! ----------------------------------------------------------------- - ! Write out GMSH nodes + ! ----------------------------------------------------------------- + ! Write out GMSH nodes - subroutine write_gmsh_nodes( fd, lfilename, field, useBinaryGMSH ) - ! Writes out nodes for the given position field - integer fd - character(len=*) :: lfilename - type(vector_field), intent(in):: field - logical :: useBinaryGMSH - integer numNodes, numDimen, numCoords, i - real :: coords(3) + subroutine write_gmsh_nodes( fd, lfilename, field, useBinaryGMSH ) + ! Writes out nodes for the given position field + integer fd + character(len=*) :: lfilename + type(vector_field), intent(in):: field + logical :: useBinaryGMSH + integer numNodes, numDimen, numCoords, i + real :: coords(3) - numNodes = node_count(field) - numDimen = mesh_dim(field) - numCoords = field%dim + numNodes = node_count(field) + numDimen = mesh_dim(field) + numCoords = field%dim - ! Sanity check. - if (numNodes==0) then - FLAbort("write_gmsh_nodes(): no nodes to write out") - end if + ! Sanity check. + if (numNodes==0) then + FLAbort("write_gmsh_nodes(): no nodes to write out") + end if - ! header line: nodes, dim, no attributes, no boundary markers - write(fd, "(A)", err=201) "$Nodes" - write(fd, "(I0)", err=201) numNodes + ! header line: nodes, dim, no attributes, no boundary markers + write(fd, "(A)", err=201) "$Nodes" + write(fd, "(I0)", err=201) numNodes - if( useBinaryGMSH) then - ! Write out nodes in binary format - call binary_formatting( fd, lfilename, "write" ) - end if + if( useBinaryGMSH) then + ! Write out nodes in binary format + call binary_formatting( fd, lfilename, "write" ) + end if -5959 format( I0, 999(X, F0.10) ) +5959 format( I0, 999(X, F0.10) ) - do i=1, numNodes - coords = 0 - coords(1:numCoords) = node_val(field, i) + do i=1, numNodes + coords = 0 + coords(1:numCoords) = node_val(field, i) - if(useBinaryGMSH) then - write( fd ) i, coords - else - write(fd, 5959) i, coords - end if - end do + if(useBinaryGMSH) then + write( fd ) i, coords + else + write(fd, 5959) i, coords + end if + end do - if( useBinaryGMSH) then - ! Write newline character - write(fd) char(10) + if( useBinaryGMSH) then + ! Write newline character + write(fd) char(10) - call ascii_formatting(fd, lfilename, "write") - end if + call ascii_formatting(fd, lfilename, "write") + end if - write( fd, "(A)" ) "$EndNodes" + write( fd, "(A)" ) "$EndNodes" - return + return -201 FLExit("Failed to write nodes to .msh file") +201 FLExit("Failed to write nodes to .msh file") - end subroutine write_gmsh_nodes + end subroutine write_gmsh_nodes - ! ----------------------------------------------------------------- + ! ----------------------------------------------------------------- - subroutine write_gmsh_faces_and_elements( fd, lfilename, mesh, & - useBinaryGMSH ) - ! Writes out elements for the given mesh - type(mesh_type), intent(in):: mesh - logical :: useBinaryGMSH + subroutine write_gmsh_faces_and_elements( fd, lfilename, mesh, & + useBinaryGMSH ) + ! Writes out elements for the given mesh + type(mesh_type), intent(in):: mesh + logical :: useBinaryGMSH - character(len=*) :: lfilename + character(len=*) :: lfilename - integer :: fd, numGMSHElems, numElements, numFaces - integer :: numTags, nloc, sloc, faceType, elemType - integer, pointer :: lnodelist(:) + integer :: fd, numGMSHElems, numElements, numFaces + integer :: numTags, nloc, sloc, faceType, elemType + integer, pointer :: lnodelist(:) - integer :: e, f, elemID - character, parameter :: newLineChar=char(10) + integer :: e, f, elemID + character, parameter :: newLineChar=char(10) - logical :: needs_element_owners + logical :: needs_element_owners - ! Gather some info about the mesh - numElements = ele_count(mesh) - numFaces = unique_surface_element_count(mesh) - needs_element_owners = has_discontinuous_internal_boundaries(mesh) + ! Gather some info about the mesh + numElements = ele_count(mesh) + numFaces = unique_surface_element_count(mesh) + needs_element_owners = has_discontinuous_internal_boundaries(mesh) - ! In the GMSH format, faces are also elements. - numGMSHElems = numElements + numFaces + ! In the GMSH format, faces are also elements. + numGMSHElems = numElements + numFaces - ! Sanity check. - if (numGMSHElems==0) then - FLAbort("write_gmsh_faces_and_elements(): none of either!") - end if + ! Sanity check. + if (numGMSHElems==0) then + FLAbort("write_gmsh_faces_and_elements(): none of either!") + end if - ! Number of nodes for elements and faces - nloc = ele_loc(mesh, 1) - sloc = 0 - if (numFaces > 0) then - sloc = face_loc(mesh,1) - end if + ! Number of nodes for elements and faces + nloc = ele_loc(mesh, 1) + sloc = 0 + if (numFaces > 0) then + sloc = face_loc(mesh,1) + end if - ! Working out face and element types now - faceType=0 - elemType=0 + ! Working out face and element types now + faceType=0 + elemType=0 - select case(mesh_dim(mesh)) - ! One dimension - case(1) - faceType=15 - elemType=1 + select case(mesh_dim(mesh)) + ! One dimension + case(1) + faceType=15 + elemType=1 - ! Two dimensions - case(2) - if (nloc==3 .and. (sloc==2 .or. numFaces==0)) then - faceType=1 - elemType=2 - else if(nloc==4 .and. (sloc==2 .or. numFaces==0)) then - faceType=1 - elemType=3 - end if + ! Two dimensions + case(2) + if (nloc==3 .and. (sloc==2 .or. numFaces==0)) then + faceType=1 + elemType=2 + else if(nloc==4 .and. (sloc==2 .or. numFaces==0)) then + faceType=1 + elemType=3 + end if - ! Three dimensions - case(3) - if(nloc==4 .and. (sloc==3 .or. numFaces==0)) then - faceType=2 - elemType=4 - else if(nloc==8 .and. (sloc==4 .or. numFaces==0)) then - faceType=3 - elemType=5 - end if - end select + ! Three dimensions + case(3) + if(nloc==4 .and. (sloc==3 .or. numFaces==0)) then + faceType=2 + elemType=4 + else if(nloc==8 .and. (sloc==4 .or. numFaces==0)) then + faceType=3 + elemType=5 + end if + end select - ! If we've not managed to identify the element and faces, exit - if(faceType==0 .and. elemType==0) then - FLExit("Unknown combination of elements and faces.") - end if + ! If we've not managed to identify the element and faces, exit + if(faceType==0 .and. elemType==0) then + FLExit("Unknown combination of elements and faces.") + end if - ! Write out element label - call ascii_formatting(fd, lfilename, "write") - write(fd, "(A)") "$Elements" + ! Write out element label + call ascii_formatting(fd, lfilename, "write") + write(fd, "(A)") "$Elements" - ! First, the number of GMSH elements (= elements+ faces) - write(fd, "(I0)" ) numGMSHElems + ! First, the number of GMSH elements (= elements+ faces) + write(fd, "(I0)" ) numGMSHElems - ! Faces written out first + ! Faces written out first - ! Number of tags associated with elements - if(needs_element_owners) then - ! write surface id and element owner - numTags = 4 - else - ! only surface id - numTags = 2 - end if + ! Number of tags associated with elements + if(needs_element_owners) then + ! write surface id and element owner + numTags = 4 + else + ! only surface id + numTags = 2 + end if - if(useBinaryGMSH) then - call binary_formatting( fd, lfilename, "write" ) - write(fd) faceType, numFaces, numTags - end if - - ! Correct format for ASCII mode element lines -6969 format (I0, 999(X,I0)) - - do f=1, numFaces - allocate( lnodelist(sloc) ) - - lnodelist = face_global_nodes(mesh, f) - call toGMSHElementNodeOrdering(lnodelist, faceType) - - ! Output face data - select case(numTags) - - case (2) - - if(useBinaryGMSH) then - write(fd, err=301) f, surface_element_id(mesh, f), 0, lnodelist - else - write(fd, 6969, err=301) f, faceType, numTags, surface_element_id(mesh, f), 0, lnodelist - end if - - case (4) - - if(useBinaryGMSH) then - write(fd, err=301) f, surface_element_id(mesh, f), 0, 0, face_ele(mesh, f), lnodelist - else - write(fd, 6969, err=301) f, faceType, numTags, surface_element_id(mesh,f), 0, 0, & + if(useBinaryGMSH) then + call binary_formatting( fd, lfilename, "write" ) + write(fd) faceType, numFaces, numTags + end if + + ! Correct format for ASCII mode element lines +6969 format (I0, 999(X,I0)) + + do f=1, numFaces + allocate( lnodelist(sloc) ) + + lnodelist = face_global_nodes(mesh, f) + call toGMSHElementNodeOrdering(lnodelist, faceType) + + ! Output face data + select case(numTags) + + case (2) + + if(useBinaryGMSH) then + write(fd, err=301) f, surface_element_id(mesh, f), 0, lnodelist + else + write(fd, 6969, err=301) f, faceType, numTags, surface_element_id(mesh, f), 0, lnodelist + end if + + case (4) + + if(useBinaryGMSH) then + write(fd, err=301) f, surface_element_id(mesh, f), 0, 0, face_ele(mesh, f), lnodelist + else + write(fd, 6969, err=301) f, faceType, numTags, surface_element_id(mesh,f), 0, 0, & face_ele(mesh,f), lnodelist - end if + end if - end select + end select - deallocate(lnodelist) - end do + deallocate(lnodelist) + end do - ! Then regular GMSH elements (i.e. the real volume elements) + ! Then regular GMSH elements (i.e. the real volume elements) - if(useBinaryGMSH) then - ! we always write 2 taqs - without region ids we just write an extra 0 - write(fd) elemType, numElements, 2 - end if + if(useBinaryGMSH) then + ! we always write 2 taqs - without region ids we just write an extra 0 + write(fd) elemType, numElements, 2 + end if - do e=1, numElements - elemID = e + numFaces - allocate( lnodelist(nloc) ) + do e=1, numElements + elemID = e + numFaces + allocate( lnodelist(nloc) ) - lnodelist = ele_nodes(mesh, e) - call toGMSHElementNodeOrdering(lnodelist, elemType) + lnodelist = ele_nodes(mesh, e) + call toGMSHElementNodeOrdering(lnodelist, elemType) - ! Output element data - if(associated(mesh%region_ids)) then + ! Output element data + if(associated(mesh%region_ids)) then - if(useBinaryGMSH) then - write(fd, err=301) elemID, ele_region_id(mesh, e), 0, lnodelist - else - write(fd, 6969, err=301) elemID, elemType, 2, & + if(useBinaryGMSH) then + write(fd, err=301) elemID, ele_region_id(mesh, e), 0, lnodelist + else + write(fd, 6969, err=301) elemID, elemType, 2, & ele_region_id(mesh, e), 0, lnodelist - end if + end if - else + else - if(useBinaryGMSH) then - write(fd, err=301) elemID, 0, 0, lnodelist - else - write(fd, 6969, err=301) elemID, elemType, 2, & + if(useBinaryGMSH) then + write(fd, err=301) elemID, 0, 0, lnodelist + else + write(fd, 6969, err=301) elemID, elemType, 2, & 0, 0, lnodelist - end if + end if - end if + end if - deallocate(lnodelist) - end do + deallocate(lnodelist) + end do - if(useBinaryGMSH) then - write(fd, err=301) newLineChar - end if + if(useBinaryGMSH) then + write(fd, err=301) newLineChar + end if - ! Back to ASCII for end of elements section - call ascii_formatting( fd, lfilename, "write" ) - write(fd, "(A)") "$EndElements" + ! Back to ASCII for end of elements section + call ascii_formatting( fd, lfilename, "write" ) + write(fd, "(A)") "$EndElements" - return + return -301 FLExit("Error while writing elements in .msh file.") +301 FLExit("Error while writing elements in .msh file.") - end subroutine write_gmsh_faces_and_elements + end subroutine write_gmsh_faces_and_elements - ! ----------------------------------------------------------------- - ! Write out node colum data + ! ----------------------------------------------------------------- + ! Write out node colum data - subroutine write_gmsh_node_columns( fd, meshFile, field, useBinaryGMSH ) - integer :: fd - character(len=*) :: meshFile - type(vector_field), intent(in) :: field - logical :: useBinaryGMSH + subroutine write_gmsh_node_columns( fd, meshFile, field, useBinaryGMSH ) + integer :: fd + character(len=*) :: meshFile + type(vector_field), intent(in) :: field + logical :: useBinaryGMSH - integer :: numNodes, timeStepNum, numComponents, i - real :: columnID + integer :: numNodes, timeStepNum, numComponents, i + real :: columnID - numNodes = node_count(field) + numNodes = node_count(field) - ! Not currently used - timeStepNum = 0 - ! Number of field components for node (only 1 : column ID) - numComponents = 1 + ! Not currently used + timeStepNum = 0 + ! Number of field components for node (only 1 : column ID) + numComponents = 1 - ! Sanity check. - if (numNodes==0) then - FLAbort("write_gmsh_node_columns(): no nodes to write out") - end if + ! Sanity check. + if (numNodes==0) then + FLAbort("write_gmsh_node_columns(): no nodes to write out") + end if - call ascii_formatting(fd, meshFile, "write") + call ascii_formatting(fd, meshFile, "write") - write(fd, "(A)") "$NodeData" - ! Telling GMSH we have one string tag ('node_column_ids') - write(fd, "(I0)" ) 1 - write(fd, "(A)") "column_ids" + write(fd, "(A)") "$NodeData" + ! Telling GMSH we have one string tag ('node_column_ids') + write(fd, "(I0)" ) 1 + write(fd, "(A)") "column_ids" - ! No real number tag - write(fd, "(I0)" ) 0 + ! No real number tag + write(fd, "(I0)" ) 0 - ! And 3 integer tags (needed) - write(fd, "(I0)") 3 + ! And 3 integer tags (needed) + write(fd, "(I0)") 3 - ! Which are: - write(fd, "(I0)") timeStepNum - write(fd, "(I0)") numComponents - write(fd, "(I0)") numNodes + ! Which are: + write(fd, "(I0)") timeStepNum + write(fd, "(I0)") numComponents + write(fd, "(I0)") numNodes - ! Switch to binary format and write out node column IDs - if(useBinaryGMSH) call binary_formatting(fd, meshFile, "write") - do i=1, numNodes - columnID = real(field%mesh%columns(i)) - if(useBinaryGMSH) then - write(fd) i, columnID - else - write(fd, "(I0, X, F0.8)") i, columnID - end if - end do - ! Newline + ! Switch to binary format and write out node column IDs + if(useBinaryGMSH) call binary_formatting(fd, meshFile, "write") + do i=1, numNodes + columnID = real(field%mesh%columns(i)) + if(useBinaryGMSH) then + write(fd) i, columnID + else + write(fd, "(I0, X, F0.8)") i, columnID + end if + end do + ! Newline - if(useBinaryGMSH) then - write(fd) char(10) - call ascii_formatting(fd, meshFile, "write") - end if + if(useBinaryGMSH) then + write(fd) char(10) + call ascii_formatting(fd, meshFile, "write") + end if - ! Write out end tag and return - write(fd, "(A)") "$EndNodeData" + ! Write out end tag and return + write(fd, "(A)") "$EndNodeData" - end subroutine write_gmsh_node_columns + end subroutine write_gmsh_node_columns end module write_gmsh diff --git a/femtools/Write_State.F90 b/femtools/Write_State.F90 index 63da604782..cdbca3d0f0 100644 --- a/femtools/Write_State.F90 +++ b/femtools/Write_State.F90 @@ -3,364 +3,364 @@ #include "fdebug.h" module write_state_module - !!< Data output routines - - use FLDebug - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use embed_python - use spud - use futils - use parallel_tools - use fields - use Profiler - use state_module - use timers - use vtk_interfaces - use field_options - use halos - - implicit none - - private - - public :: initialise_write_state, do_write_state, write_state, write_state_module_check_options, & - vtk_write_state_new_options - - ! Static variables set by update_dump_times and used by do_write_state - logical, save :: last_times_initialised = .false. - real, save :: last_dump_time - real, save :: last_dump_cpu_time - real, save :: last_dump_wall_time - real, save :: real_dump_period - integer, save :: int_dump_period + !!< Data output routines + + use FLDebug + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use embed_python + use spud + use futils + use parallel_tools + use fields + use Profiler + use state_module + use timers + use vtk_interfaces + use field_options + use halos + + implicit none + + private + + public :: initialise_write_state, do_write_state, write_state, write_state_module_check_options, & + vtk_write_state_new_options + + ! Static variables set by update_dump_times and used by do_write_state + logical, save :: last_times_initialised = .false. + real, save :: last_dump_time + real, save :: last_dump_cpu_time + real, save :: last_dump_wall_time + real, save :: real_dump_period + integer, save :: int_dump_period contains - subroutine initialise_write_state - !!< Initialises the write_state module (setting the last_write_state_*time - !!< variables) - - call update_dump_times - - end subroutine initialise_write_state - - function do_write_state(current_time, timestep) - !!< Data output test routine. Test conditions listed under /io. Returns true - !!< if these conditions are satisfied and false otherwise. - - real, intent(in) :: current_time - integer, intent(in) :: timestep - - logical :: do_write_state - - character(len = OPTION_PATH_LEN) :: func - - integer :: i, stat - real :: current_cpu_time, current_wall_time - logical :: dump - - do_write_state = .false. - - do i = 1, 5 - select case(i) - case(1) - if(.not. last_times_initialised) then - ! if the last_dump*_time variables have not been initialised, assume write_state should be called - do_write_state = .true. - exit - end if - case(2) - if(have_option("/io/dump_period")) then - if(real_dump_period == 0.0 .or. dump_count_greater(current_time, last_dump_time, real_dump_period)) then - if(have_option("/io/dump_period/constant")) then - call get_option("/io/dump_period/constant", real_dump_period) - else if (have_option("/io/dump_period/python")) then - call get_option("/io/dump_period/python", func) - call real_from_python(func, current_time, real_dump_period) - else - FLAbort("Unable to determine dump period type.") - end if - if(real_dump_period < 0.0) then - FLExit("Dump period cannot be negative.") - end if - do_write_state = .true. - exit - end if - end if - case(3) - if(have_option("/io/dump_period_in_timesteps")) then - if (int_dump_period == 0) then - dump = .true. - else if (mod(timestep, int_dump_period) == 0) then - dump = .true. - else - dump = .false. - end if - if (dump) then - if(have_option("/io/dump_period_in_timesteps/constant")) then - call get_option("/io/dump_period_in_timesteps/constant", int_dump_period) - else if (have_option("/io/dump_period_in_timesteps/python")) then - call get_option("/io/dump_period_in_timesteps/python", func) - call integer_from_python(func, current_time, int_dump_period) - else - FLAbort("Unable to determine dump period type.") - end if - if(int_dump_period < 0) then - FLExit("Dump period cannot be negative.") - END if - do_write_state = .true. - exit + subroutine initialise_write_state + !!< Initialises the write_state module (setting the last_write_state_*time + !!< variables) + + call update_dump_times + + end subroutine initialise_write_state + + function do_write_state(current_time, timestep) + !!< Data output test routine. Test conditions listed under /io. Returns true + !!< if these conditions are satisfied and false otherwise. + + real, intent(in) :: current_time + integer, intent(in) :: timestep + + logical :: do_write_state + + character(len = OPTION_PATH_LEN) :: func + + integer :: i, stat + real :: current_cpu_time, current_wall_time + logical :: dump + + do_write_state = .false. + + do i = 1, 5 + select case(i) + case(1) + if(.not. last_times_initialised) then + ! if the last_dump*_time variables have not been initialised, assume write_state should be called + do_write_state = .true. + exit end if - end if - case(4) - call cpu_time(current_cpu_time) - call allmax(current_cpu_time) - call get_option("/io/cpu_dump_period", real_dump_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_dump_period == 0.0 .or. dump_count_greater(current_cpu_time, last_dump_cpu_time, real_dump_period)) then - do_write_state = .true. - exit + case(2) + if(have_option("/io/dump_period")) then + if(real_dump_period == 0.0 .or. dump_count_greater(current_time, last_dump_time, real_dump_period)) then + if(have_option("/io/dump_period/constant")) then + call get_option("/io/dump_period/constant", real_dump_period) + else if (have_option("/io/dump_period/python")) then + call get_option("/io/dump_period/python", func) + call real_from_python(func, current_time, real_dump_period) + else + FLAbort("Unable to determine dump period type.") + end if + if(real_dump_period < 0.0) then + FLExit("Dump period cannot be negative.") + end if + do_write_state = .true. + exit + end if end if - end if - case(5) - current_wall_time = wall_time() - call allmax(current_wall_time) - call get_option("/io/wall_time_dump_period", real_dump_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_dump_period == 0.0 .or. dump_count_greater(current_wall_time, last_dump_wall_time, real_dump_period)) then - do_write_state = .true. - exit + case(3) + if(have_option("/io/dump_period_in_timesteps")) then + if (int_dump_period == 0) then + dump = .true. + else if (mod(timestep, int_dump_period) == 0) then + dump = .true. + else + dump = .false. + end if + if (dump) then + if(have_option("/io/dump_period_in_timesteps/constant")) then + call get_option("/io/dump_period_in_timesteps/constant", int_dump_period) + else if (have_option("/io/dump_period_in_timesteps/python")) then + call get_option("/io/dump_period_in_timesteps/python", func) + call integer_from_python(func, current_time, int_dump_period) + else + FLAbort("Unable to determine dump period type.") + end if + if(int_dump_period < 0) then + FLExit("Dump period cannot be negative.") + END if + do_write_state = .true. + exit + end if end if - end if - case default - FLAbort("Invalid loop index.") - end select - end do - - if(do_write_state) then - ewrite(2, *) "do_write_state returning .true." - else - ewrite(2, *) "do_write_state returning .false." - end if - - contains - - pure function dump_count_greater(later_time, earlier_time, dump_period) - !!< Return if the total number of dumps at time later_time is greater - !!< than the total number of dumps at time earlier_time. - - real, intent(in) :: later_time - real, intent(in) :: earlier_time - real, intent(in) :: dump_period - - logical :: dump_count_greater - - dump_count_greater = (floor(later_time / dump_period) > floor(earlier_time / dump_period)) - - end function dump_count_greater - - end function do_write_state - - subroutine update_dump_times - !!< Update the last_dump_*time variables. - character(len = OPTION_PATH_LEN) :: func - - last_times_initialised = .true. - real_dump_period = huge(0.0) - int_dump_period = huge(0) - - call get_option("/timestepping/current_time", last_dump_time) - call cpu_time(last_dump_cpu_time) - call allmax(last_dump_cpu_time) - last_dump_wall_time = wall_time() - call allmax(last_dump_wall_time) - if(have_option("/io/dump_period/constant")) then - call get_option("/io/dump_period/constant", real_dump_period) - else if (have_option("/io/dump_period/python")) then - call get_option("/io/dump_period/python", func) - call real_from_python(func, last_dump_time, real_dump_period) - if(real_dump_period < 0.0) then - FLExit("Dump period cannot be negative.") - end if - else if(have_option("/io/dump_period_in_timesteps/constant")) then - call get_option("/io/dump_period_in_timesteps/constant", int_dump_period) - else if (have_option("/io/dump_period_in_timesteps/python")) then - call get_option("/io/dump_period_in_timesteps/python", func) - call integer_from_python(func, last_dump_time, int_dump_period) - if(int_dump_period < 0) then - FLExit("Dump period cannot be negative.") - end if - else - FLExit("Dump period must be specified (in either simulated time or timesteps).") - end if - - end subroutine update_dump_times - - subroutine write_state(dump_no, state) - !!< Data output routine. Write output data. - - integer, intent(inout) :: dump_no - type(state_type), dimension(:), intent(inout) :: state - - character(len = OPTION_PATH_LEN) :: dump_filename, dump_format - integer :: max_dump_no, stat - - ewrite(1, *) "In write_state" - call profiler_tic("I/O") - - call get_option("/simulation_name", dump_filename) - call get_option("/io/max_dump_file_count", max_dump_no, stat, default = huge(0)) - - dump_no = modulo(dump_no, max_dump_no) - - call get_option("/io/dump_format", dump_format) - select case(trim(dump_format)) - case("vtk") - ewrite(2, *) "Writing output " // int2str(dump_no) // " to vtu" - call vtk_write_state_new_options(dump_filename, dump_no, state) - case default - FLAbort("Unrecognised dump file format.") - end select - - dump_no = modulo(dump_no + 1, max_dump_no) - call update_dump_times - - call profiler_toc("I/O") - ewrite(1, *) "Exiting write_state" - - end subroutine write_state - - subroutine vtk_write_state_new_options(filename, index, state, write_region_ids) - !!< Write the state variables out to a vtu file according to options - !!< set in the options tree. Only fields present in the option tree - !!< will be written, except for those disabled in the same options tree. - !!< - !!< All the fields will be promoted/reduced to the degree of the - !!< chosen mesh. - - character(len=*), intent(in) :: filename !! Base filename with no trailing _number.vtu - integer, intent(in), optional :: index !! Index number of dump for filename. - type(state_type), dimension(:), intent(inout) :: state - logical, intent(in), optional :: write_region_ids - - type(vector_field), pointer :: model_coordinate - type(mesh_type), pointer :: model_mesh - - type(scalar_field), dimension(:), allocatable :: lsfields - type(vector_field), dimension(:), allocatable :: lvfields - type(tensor_field), dimension(:), allocatable :: ltfields - character(len = FIELD_NAME_LEN) :: field_name, mesh_name - integer :: i, f, counter - logical :: multi_state - - ewrite(1, *) "In vtk_write_state_new_options" - - call get_option("/io/output_mesh[0]/name", mesh_name) - model_mesh => extract_mesh(state(1), mesh_name) - - multi_state = size(state) > 1 - - ! count number of scalar fields in output: - counter = 0 - do i = 1, size(state) - if (associated(state(i)%scalar_fields)) then - do f = 1, size(state(i)%scalar_fields) - field_name = state(i)%scalar_fields(f)%ptr%name - if (include_scalar_field_in_vtu(state, i, field_name)) then - counter = counter + 1 - end if - end do - end if - end do - - ! collect scalar fields: - allocate(lsfields(1:counter)) - counter = 0 - do i = 1, size(state) - if (associated(state(i)%scalar_fields)) then - do f = 1, size(state(i)%scalar_fields) - field_name = state(i)%scalar_fields(f)%ptr%name - if (include_scalar_field_in_vtu(state, i, field_name)) then - counter = counter + 1 - lsfields(counter)=extract_scalar_field(state(i), field_name) - if (multi_state) then - lsfields(counter)%name = trim(state(i)%name)//'::'//trim(field_name) + case(4) + call cpu_time(current_cpu_time) + call allmax(current_cpu_time) + call get_option("/io/cpu_dump_period", real_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_dump_period == 0.0 .or. dump_count_greater(current_cpu_time, last_dump_cpu_time, real_dump_period)) then + do_write_state = .true. + exit + end if end if - end if - end do - end if - end do - - ! count number of vector fields in output: - counter = 0 - do i = 1, size(state) - if (associated(state(i)%vector_fields)) then - do f = 1, size(state(i)%vector_fields) - field_name = state(i)%vector_fields(f)%ptr%name - if (include_vector_field_in_vtu(state, i, field_name)) then - counter = counter + 1 - end if - end do - end if - end do - - ! collect vector fields: - allocate(lvfields(1:counter)) - counter = 0 - do i = 1, size(state) - if (associated(state(i)%vector_fields)) then - do f = 1, size(state(i)%vector_fields) - field_name = state(i)%vector_fields(f)%ptr%name - if (include_vector_field_in_vtu(state, i, field_name)) then - counter = counter + 1 - lvfields(counter)=extract_vector_field(state(i), field_name) - if (multi_state) then - lvfields(counter)%name = trim(state(i)%name)//'::'//trim(field_name) + case(5) + current_wall_time = wall_time() + call allmax(current_wall_time) + call get_option("/io/wall_time_dump_period", real_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_dump_period == 0.0 .or. dump_count_greater(current_wall_time, last_dump_wall_time, real_dump_period)) then + do_write_state = .true. + exit + end if end if - end if - end do - end if - end do - - ! count number of tensor fields in output: - counter = 0 - do i = 1, size(state) - if (associated(state(i)%tensor_fields)) then - do f = 1, size(state(i)%tensor_fields) - field_name = state(i)%tensor_fields(f)%ptr%name - if (include_tensor_field_in_vtu(state, i, field_name)) then - counter = counter + 1 - end if - end do + case default + FLAbort("Invalid loop index.") + end select + end do + + if(do_write_state) then + ewrite(2, *) "do_write_state returning .true." + else + ewrite(2, *) "do_write_state returning .false." end if - end do - - ! collect tensor fields: - allocate(ltfields(1:counter)) - counter = 0 - do i = 1, size(state) - if (associated(state(i)%tensor_fields)) then - do f = 1, size(state(i)%tensor_fields) - field_name = state(i)%tensor_fields(f)%ptr%name - if (include_tensor_field_in_vtu(state, i, field_name)) then - counter = counter + 1 - ltfields(counter)=extract_tensor_field(state(i), field_name) - if (multi_state) then - ltfields(counter)%name = trim(state(i)%name)//'::'//trim(field_name) - end if - end if - end do + + contains + + pure function dump_count_greater(later_time, earlier_time, dump_period) + !!< Return if the total number of dumps at time later_time is greater + !!< than the total number of dumps at time earlier_time. + + real, intent(in) :: later_time + real, intent(in) :: earlier_time + real, intent(in) :: dump_period + + logical :: dump_count_greater + + dump_count_greater = (floor(later_time / dump_period) > floor(earlier_time / dump_period)) + + end function dump_count_greater + + end function do_write_state + + subroutine update_dump_times + !!< Update the last_dump_*time variables. + character(len = OPTION_PATH_LEN) :: func + + last_times_initialised = .true. + real_dump_period = huge(0.0) + int_dump_period = huge(0) + + call get_option("/timestepping/current_time", last_dump_time) + call cpu_time(last_dump_cpu_time) + call allmax(last_dump_cpu_time) + last_dump_wall_time = wall_time() + call allmax(last_dump_wall_time) + if(have_option("/io/dump_period/constant")) then + call get_option("/io/dump_period/constant", real_dump_period) + else if (have_option("/io/dump_period/python")) then + call get_option("/io/dump_period/python", func) + call real_from_python(func, last_dump_time, real_dump_period) + if(real_dump_period < 0.0) then + FLExit("Dump period cannot be negative.") + end if + else if(have_option("/io/dump_period_in_timesteps/constant")) then + call get_option("/io/dump_period_in_timesteps/constant", int_dump_period) + else if (have_option("/io/dump_period_in_timesteps/python")) then + call get_option("/io/dump_period_in_timesteps/python", func) + call integer_from_python(func, last_dump_time, int_dump_period) + if(int_dump_period < 0) then + FLExit("Dump period cannot be negative.") + end if + else + FLExit("Dump period must be specified (in either simulated time or timesteps).") end if - end do - ewrite(2, *) "Writing using mesh " // trim(mesh_name) - ewrite(2, "(a,i0,a)") "Writing ", size(lsfields), " scalar field(s)" - ewrite(2, "(a,i0,a)") "Writing ", size(lvfields), " vector field(s)" - ewrite(2, "(a,i0,a)") "Writing ", size(ltfields), " tensor field(s)" + end subroutine update_dump_times + + subroutine write_state(dump_no, state) + !!< Data output routine. Write output data. - model_coordinate=>get_external_coordinate_field(state(1), model_mesh) + integer, intent(inout) :: dump_no + type(state_type), dimension(:), intent(inout) :: state - call vtk_write_fields(filename, index, & + character(len = OPTION_PATH_LEN) :: dump_filename, dump_format + integer :: max_dump_no, stat + + ewrite(1, *) "In write_state" + call profiler_tic("I/O") + + call get_option("/simulation_name", dump_filename) + call get_option("/io/max_dump_file_count", max_dump_no, stat, default = huge(0)) + + dump_no = modulo(dump_no, max_dump_no) + + call get_option("/io/dump_format", dump_format) + select case(trim(dump_format)) + case("vtk") + ewrite(2, *) "Writing output " // int2str(dump_no) // " to vtu" + call vtk_write_state_new_options(dump_filename, dump_no, state) + case default + FLAbort("Unrecognised dump file format.") + end select + + dump_no = modulo(dump_no + 1, max_dump_no) + call update_dump_times + + call profiler_toc("I/O") + ewrite(1, *) "Exiting write_state" + + end subroutine write_state + + subroutine vtk_write_state_new_options(filename, index, state, write_region_ids) + !!< Write the state variables out to a vtu file according to options + !!< set in the options tree. Only fields present in the option tree + !!< will be written, except for those disabled in the same options tree. + !!< + !!< All the fields will be promoted/reduced to the degree of the + !!< chosen mesh. + + character(len=*), intent(in) :: filename !! Base filename with no trailing _number.vtu + integer, intent(in), optional :: index !! Index number of dump for filename. + type(state_type), dimension(:), intent(inout) :: state + logical, intent(in), optional :: write_region_ids + + type(vector_field), pointer :: model_coordinate + type(mesh_type), pointer :: model_mesh + + type(scalar_field), dimension(:), allocatable :: lsfields + type(vector_field), dimension(:), allocatable :: lvfields + type(tensor_field), dimension(:), allocatable :: ltfields + character(len = FIELD_NAME_LEN) :: field_name, mesh_name + integer :: i, f, counter + logical :: multi_state + + ewrite(1, *) "In vtk_write_state_new_options" + + call get_option("/io/output_mesh[0]/name", mesh_name) + model_mesh => extract_mesh(state(1), mesh_name) + + multi_state = size(state) > 1 + + ! count number of scalar fields in output: + counter = 0 + do i = 1, size(state) + if (associated(state(i)%scalar_fields)) then + do f = 1, size(state(i)%scalar_fields) + field_name = state(i)%scalar_fields(f)%ptr%name + if (include_scalar_field_in_vtu(state, i, field_name)) then + counter = counter + 1 + end if + end do + end if + end do + + ! collect scalar fields: + allocate(lsfields(1:counter)) + counter = 0 + do i = 1, size(state) + if (associated(state(i)%scalar_fields)) then + do f = 1, size(state(i)%scalar_fields) + field_name = state(i)%scalar_fields(f)%ptr%name + if (include_scalar_field_in_vtu(state, i, field_name)) then + counter = counter + 1 + lsfields(counter)=extract_scalar_field(state(i), field_name) + if (multi_state) then + lsfields(counter)%name = trim(state(i)%name)//'::'//trim(field_name) + end if + end if + end do + end if + end do + + ! count number of vector fields in output: + counter = 0 + do i = 1, size(state) + if (associated(state(i)%vector_fields)) then + do f = 1, size(state(i)%vector_fields) + field_name = state(i)%vector_fields(f)%ptr%name + if (include_vector_field_in_vtu(state, i, field_name)) then + counter = counter + 1 + end if + end do + end if + end do + + ! collect vector fields: + allocate(lvfields(1:counter)) + counter = 0 + do i = 1, size(state) + if (associated(state(i)%vector_fields)) then + do f = 1, size(state(i)%vector_fields) + field_name = state(i)%vector_fields(f)%ptr%name + if (include_vector_field_in_vtu(state, i, field_name)) then + counter = counter + 1 + lvfields(counter)=extract_vector_field(state(i), field_name) + if (multi_state) then + lvfields(counter)%name = trim(state(i)%name)//'::'//trim(field_name) + end if + end if + end do + end if + end do + + ! count number of tensor fields in output: + counter = 0 + do i = 1, size(state) + if (associated(state(i)%tensor_fields)) then + do f = 1, size(state(i)%tensor_fields) + field_name = state(i)%tensor_fields(f)%ptr%name + if (include_tensor_field_in_vtu(state, i, field_name)) then + counter = counter + 1 + end if + end do + end if + end do + + ! collect tensor fields: + allocate(ltfields(1:counter)) + counter = 0 + do i = 1, size(state) + if (associated(state(i)%tensor_fields)) then + do f = 1, size(state(i)%tensor_fields) + field_name = state(i)%tensor_fields(f)%ptr%name + if (include_tensor_field_in_vtu(state, i, field_name)) then + counter = counter + 1 + ltfields(counter)=extract_tensor_field(state(i), field_name) + if (multi_state) then + ltfields(counter)%name = trim(state(i)%name)//'::'//trim(field_name) + end if + end if + end do + end if + end do + + ewrite(2, *) "Writing using mesh " // trim(mesh_name) + ewrite(2, "(a,i0,a)") "Writing ", size(lsfields), " scalar field(s)" + ewrite(2, "(a,i0,a)") "Writing ", size(lvfields), " vector field(s)" + ewrite(2, "(a,i0,a)") "Writing ", size(ltfields), " tensor field(s)" + + model_coordinate=>get_external_coordinate_field(state(1), model_mesh) + + call vtk_write_fields(filename, index, & model_coordinate, & model_mesh, & sfields=lsfields, & @@ -368,377 +368,377 @@ subroutine vtk_write_state_new_options(filename, index, state, write_region_ids) tfields=ltfields, & write_region_ids=write_region_ids) - ewrite(1, *) "Exiting vtk_write_state_new_options" + ewrite(1, *) "Exiting vtk_write_state_new_options" - end subroutine vtk_write_state_new_options + end subroutine vtk_write_state_new_options - logical function include_scalar_field_in_vtu(state, istate, field_name) - !!< function that uses optionpath and state number to work out - !!< if a field should be written out (skipping aliased fields) + logical function include_scalar_field_in_vtu(state, istate, field_name) + !!< function that uses optionpath and state number to work out + !!< if a field should be written out (skipping aliased fields) - type(state_type), dimension(:), intent(in):: state - integer, intent(in):: istate - character(len=*), intent(in):: field_name + type(state_type), dimension(:), intent(in):: state + integer, intent(in):: istate + character(len=*), intent(in):: field_name - type(scalar_field), pointer:: field - character(len=OPTION_PATH_LEN) output_option_path - logical is_old_field, is_nonlinear_field, is_iterated_field + type(scalar_field), pointer:: field + character(len=OPTION_PATH_LEN) output_option_path + logical is_old_field, is_nonlinear_field, is_iterated_field - integer :: stat + integer :: stat - if (field_name=='Time') then - field => extract_scalar_field(state(istate), field_name) - ! Time is special, always included (unless it's aliased) - include_scalar_field_in_vtu=.not.aliased(field) - return - end if - - if (.not. has_scalar_field(state(istate), field_name)) then - ! not even in state, so no - include_scalar_field_in_vtu=.false. - return - end if - - is_old_field=.false. - is_nonlinear_field=.false. - is_iterated_field=.false. - - field => extract_scalar_field(state(istate), field_name) - if (len_trim(field%option_path)==0) then - ! fields without option paths - if (starts_with(field_name, 'Old')) then - is_old_field=.true. - field => extract_scalar_field(state(istate), field_name(4:), stat=stat) - if (stat /= 0) then - include_scalar_field_in_vtu = .false. - return - end if - else if (starts_with(field_name, 'Nonlinear')) then - is_nonlinear_field=.true. - field => extract_scalar_field(state(istate), field_name(10:), stat=stat) - if (stat /= 0) then - include_scalar_field_in_vtu = .false. - return - end if - else if (starts_with(field_name, 'Iterated')) then - is_iterated_field=.true. - field => extract_scalar_field(state(istate), field_name(9:), stat=stat) - if (stat /= 0) then - include_scalar_field_in_vtu = .false. - return - end if - else - include_scalar_field_in_vtu=.false. - return + if (field_name=='Time') then + field => extract_scalar_field(state(istate), field_name) + ! Time is special, always included (unless it's aliased) + include_scalar_field_in_vtu=.not.aliased(field) + return end if - end if - - if (starts_with(field%option_path,'/material_phase[')) then - if (aliased(field)) then - ! option_path points to other material_phase - ! must be an aliased field - include_scalar_field_in_vtu=.false. - return + + if (.not. has_scalar_field(state(istate), field_name)) then + ! not even in state, so no + include_scalar_field_in_vtu=.false. + return end if - else - ! fields outside any material_phase - ! only output once for first state: - if (istate/=1) then - include_scalar_field_in_vtu=.false. - return + + is_old_field=.false. + is_nonlinear_field=.false. + is_iterated_field=.false. + + field => extract_scalar_field(state(istate), field_name) + if (len_trim(field%option_path)==0) then + ! fields without option paths + if (starts_with(field_name, 'Old')) then + is_old_field=.true. + field => extract_scalar_field(state(istate), field_name(4:), stat=stat) + if (stat /= 0) then + include_scalar_field_in_vtu = .false. + return + end if + else if (starts_with(field_name, 'Nonlinear')) then + is_nonlinear_field=.true. + field => extract_scalar_field(state(istate), field_name(10:), stat=stat) + if (stat /= 0) then + include_scalar_field_in_vtu = .false. + return + end if + else if (starts_with(field_name, 'Iterated')) then + is_iterated_field=.true. + field => extract_scalar_field(state(istate), field_name(9:), stat=stat) + if (stat /= 0) then + include_scalar_field_in_vtu = .false. + return + end if + else + include_scalar_field_in_vtu=.false. + return + end if end if - end if - - ! if we get here the field is not aliased and has an option_path - ! now we let the user decide! - - output_option_path=trim(complete_field_path(field%option_path, name=trim(field_name)))//'/output' - - if (is_old_field) then - include_scalar_field_in_vtu=have_option(trim(output_option_path)//'/include_previous_time_step') - else if (is_nonlinear_field) then - include_scalar_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') - else if (is_iterated_field) then - include_scalar_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') - else - include_scalar_field_in_vtu=.not. have_option(trim(output_option_path)//'/exclude_from_vtu') - end if - - end function include_scalar_field_in_vtu - - logical function include_vector_field_in_vtu(state, istate, field_name) - !!< function that uses optionpath and state number to work out - !!< if a field should be written to vtu (skipping aliased fields) - - type(state_type), dimension(:), intent(in):: state - integer, intent(in):: istate - character(len=*), intent(in):: field_name - - type(vector_field), pointer:: field - character(len=OPTION_PATH_LEN) output_option_path - logical is_old_field, is_nonlinear_field, is_iterated_field - - integer :: stat - - if (.not. has_vector_field(state(istate), field_name)) then - ! not even in state, so no - include_vector_field_in_vtu=.false. - return - end if - - is_old_field=.false. - is_nonlinear_field=.false. - is_iterated_field=.false. - - field => extract_vector_field(state(istate), field_name) - if (len_trim(field%option_path)==0) then - ! fields without option paths - if (field_name=="OldCoordinate") then - include_vector_field_in_vtu=.false. - return - else if (field_name=="IteratedCoordinate") then - include_vector_field_in_vtu=.false. - return - else if (field_name=="OldGridVelocity") then - include_vector_field_in_vtu=.false. - return - else if (field_name=="IteratedGridVelocity") then - include_vector_field_in_vtu=.false. - return - else if (starts_with(field_name, 'Old')) then - is_old_field=.true. - field => extract_vector_field(state(istate), field_name(4:), stat=stat) - if (stat /= 0) then - include_vector_field_in_vtu = .false. - return - end if - else if (starts_with(field_name, 'Nonlinear')) then - is_nonlinear_field=.true. - field => extract_vector_field(state(istate), field_name(10:), stat=stat) - if (stat /= 0) then - include_vector_field_in_vtu = .false. - return - end if - else if (starts_with(field_name, 'Iterated')) then - is_iterated_field=.true. - field => extract_vector_field(state(istate), field_name(9:), stat=stat) - if (stat /= 0) then - include_vector_field_in_vtu = .false. - return - end if + + if (starts_with(field%option_path,'/material_phase[')) then + if (aliased(field)) then + ! option_path points to other material_phase + ! must be an aliased field + include_scalar_field_in_vtu=.false. + return + end if else - include_vector_field_in_vtu=.false. - return + ! fields outside any material_phase + ! only output once for first state: + if (istate/=1) then + include_scalar_field_in_vtu=.false. + return + end if end if - end if - - if (starts_with(field%option_path,'/material_phase[')) then - if (aliased(field)) then - ! option_path points to other material_phase - ! must be an aliased field - include_vector_field_in_vtu=.false. - return - end if - else - ! fields outside any material_phase - ! only output once for first state: - if (istate/=1) then - include_vector_field_in_vtu=.false. - return - end if - end if - - ! if we get here the field is not aliased and has an option_path - ! now we let the user decide! - - output_option_path=trim(complete_field_path(field%option_path))//'/output' - - if (is_old_field) then - include_vector_field_in_vtu=have_option(trim(output_option_path)//'/include_previous_time_step') - else if (is_nonlinear_field) then - include_vector_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') - else if (is_iterated_field) then - include_vector_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') - else - include_vector_field_in_vtu=.not. have_option(trim(output_option_path)//'/exclude_from_vtu') - end if - - end function include_vector_field_in_vtu - - logical function include_tensor_field_in_vtu(state, istate, field_name) - !!< function that uses optionpath and state number to work out - !!< if a field should be written to vtu (skipping aliased fields) - - type(state_type), dimension(:), intent(in):: state - integer, intent(in):: istate - character(len=*), intent(in):: field_name - - type(tensor_field), pointer:: field - character(len=OPTION_PATH_LEN) output_option_path - logical is_old_field, is_nonlinear_field, is_iterated_field - - integer :: stat - - if (.not. has_tensor_field(state(istate), field_name)) then - ! not even in state, so no - include_tensor_field_in_vtu=.false. - return - end if - - is_old_field=.false. - is_nonlinear_field=.false. - is_iterated_field=.false. - - field => extract_tensor_field(state(istate), field_name) - if (len_trim(field%option_path)==0) then - ! fields without option paths - if (starts_with(field_name, 'Old')) then - is_old_field=.true. - field => extract_tensor_field(state(istate), field_name(4:), stat=stat) - if (stat /= 0) then - include_tensor_field_in_vtu = .false. - return - end if - else if (starts_with(field_name, 'Nonlinear')) then - is_nonlinear_field=.true. - field => extract_tensor_field(state(istate), field_name(10:), stat=stat) - if (stat /= 0) then - include_tensor_field_in_vtu = .false. - return - end if - else if (starts_with(field_name, 'Iterated')) then - is_iterated_field=.true. - field => extract_tensor_field(state(istate), field_name(9:), stat=stat) - if (stat /= 0) then - include_tensor_field_in_vtu = .false. - return - end if + + ! if we get here the field is not aliased and has an option_path + ! now we let the user decide! + + output_option_path=trim(complete_field_path(field%option_path, name=trim(field_name)))//'/output' + + if (is_old_field) then + include_scalar_field_in_vtu=have_option(trim(output_option_path)//'/include_previous_time_step') + else if (is_nonlinear_field) then + include_scalar_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') + else if (is_iterated_field) then + include_scalar_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') else - include_tensor_field_in_vtu=.false. - return + include_scalar_field_in_vtu=.not. have_option(trim(output_option_path)//'/exclude_from_vtu') end if - end if - - if (starts_with(field%option_path,'/material_phase[')) then - if (aliased(field)) then - ! option_path points to other material_phase - ! must be an aliased field - include_tensor_field_in_vtu=.false. - return + + end function include_scalar_field_in_vtu + + logical function include_vector_field_in_vtu(state, istate, field_name) + !!< function that uses optionpath and state number to work out + !!< if a field should be written to vtu (skipping aliased fields) + + type(state_type), dimension(:), intent(in):: state + integer, intent(in):: istate + character(len=*), intent(in):: field_name + + type(vector_field), pointer:: field + character(len=OPTION_PATH_LEN) output_option_path + logical is_old_field, is_nonlinear_field, is_iterated_field + + integer :: stat + + if (.not. has_vector_field(state(istate), field_name)) then + ! not even in state, so no + include_vector_field_in_vtu=.false. + return end if - else - ! fields outside any material_phase - ! only output once for first state: - if (istate/=1) then - include_tensor_field_in_vtu=.false. - return + + is_old_field=.false. + is_nonlinear_field=.false. + is_iterated_field=.false. + + field => extract_vector_field(state(istate), field_name) + if (len_trim(field%option_path)==0) then + ! fields without option paths + if (field_name=="OldCoordinate") then + include_vector_field_in_vtu=.false. + return + else if (field_name=="IteratedCoordinate") then + include_vector_field_in_vtu=.false. + return + else if (field_name=="OldGridVelocity") then + include_vector_field_in_vtu=.false. + return + else if (field_name=="IteratedGridVelocity") then + include_vector_field_in_vtu=.false. + return + else if (starts_with(field_name, 'Old')) then + is_old_field=.true. + field => extract_vector_field(state(istate), field_name(4:), stat=stat) + if (stat /= 0) then + include_vector_field_in_vtu = .false. + return + end if + else if (starts_with(field_name, 'Nonlinear')) then + is_nonlinear_field=.true. + field => extract_vector_field(state(istate), field_name(10:), stat=stat) + if (stat /= 0) then + include_vector_field_in_vtu = .false. + return + end if + else if (starts_with(field_name, 'Iterated')) then + is_iterated_field=.true. + field => extract_vector_field(state(istate), field_name(9:), stat=stat) + if (stat /= 0) then + include_vector_field_in_vtu = .false. + return + end if + else + include_vector_field_in_vtu=.false. + return + end if end if - end if - ! if we get here the field is not aliased and has an option_path - ! now we let the user decide! + if (starts_with(field%option_path,'/material_phase[')) then + if (aliased(field)) then + ! option_path points to other material_phase + ! must be an aliased field + include_vector_field_in_vtu=.false. + return + end if + else + ! fields outside any material_phase + ! only output once for first state: + if (istate/=1) then + include_vector_field_in_vtu=.false. + return + end if + end if - output_option_path=trim(complete_field_path(field%option_path))//'/output' + ! if we get here the field is not aliased and has an option_path + ! now we let the user decide! - if (is_old_field) then - include_tensor_field_in_vtu=have_option(trim(output_option_path)//'/include_previous_time_step') - else if (is_nonlinear_field) then - include_tensor_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') - else if (is_iterated_field) then - include_tensor_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') - else - include_tensor_field_in_vtu=.not. have_option(trim(output_option_path)//'/exclude_from_vtu') - end if + output_option_path=trim(complete_field_path(field%option_path))//'/output' - end function include_tensor_field_in_vtu + if (is_old_field) then + include_vector_field_in_vtu=have_option(trim(output_option_path)//'/include_previous_time_step') + else if (is_nonlinear_field) then + include_vector_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') + else if (is_iterated_field) then + include_vector_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') + else + include_vector_field_in_vtu=.not. have_option(trim(output_option_path)//'/exclude_from_vtu') + end if - subroutine write_state_module_check_options - !!< Check output related options + end function include_vector_field_in_vtu - character(len = OPTION_PATH_LEN) :: dump_format, output_mesh_name, func - integer :: int_dump_period, max_dump_file_count, stat - real :: real_dump_period, current_time + logical function include_tensor_field_in_vtu(state, istate, field_name) + !!< function that uses optionpath and state number to work out + !!< if a field should be written to vtu (skipping aliased fields) - ewrite(2, *) "Checking output options" + type(state_type), dimension(:), intent(in):: state + integer, intent(in):: istate + character(len=*), intent(in):: field_name - call get_option("/timestepping/current_time", current_time) + type(tensor_field), pointer:: field + character(len=OPTION_PATH_LEN) output_option_path + logical is_old_field, is_nonlinear_field, is_iterated_field - call get_option("/io/dump_format", dump_format, stat) - if(stat == SPUD_NO_ERROR) then - if(trim(dump_format) == "vtk") then - call get_option("/io/output_mesh[0]/name", output_mesh_name, stat = stat) - if(stat /= SPUD_NO_ERROR) then - FLExit("An output mesh must be specified if using a VTK dump format.") - else if(option_count("/geometry/mesh::" // output_mesh_name) == 0) then - FLExit("Output mesh " // trim(output_mesh_name) // " is not defined.") - end if - else - FLExit('Unrecognised dump format "' // trim(dump_format) // '"specified.') + integer :: stat + + if (.not. has_tensor_field(state(istate), field_name)) then + ! not even in state, so no + include_tensor_field_in_vtu=.false. + return end if - else - FLExit("Dump format must be specified.") - end if - if(have_option("/io/dump_period/constant")) then - call get_option("/io/dump_period/constant", real_dump_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_dump_period < 0.0) then - FLExit("Dump period cannot be negative.") - end if + is_old_field=.false. + is_nonlinear_field=.false. + is_iterated_field=.false. + + field => extract_tensor_field(state(istate), field_name) + if (len_trim(field%option_path)==0) then + ! fields without option paths + if (starts_with(field_name, 'Old')) then + is_old_field=.true. + field => extract_tensor_field(state(istate), field_name(4:), stat=stat) + if (stat /= 0) then + include_tensor_field_in_vtu = .false. + return + end if + else if (starts_with(field_name, 'Nonlinear')) then + is_nonlinear_field=.true. + field => extract_tensor_field(state(istate), field_name(10:), stat=stat) + if (stat /= 0) then + include_tensor_field_in_vtu = .false. + return + end if + else if (starts_with(field_name, 'Iterated')) then + is_iterated_field=.true. + field => extract_tensor_field(state(istate), field_name(9:), stat=stat) + if (stat /= 0) then + include_tensor_field_in_vtu = .false. + return + end if + else + include_tensor_field_in_vtu=.false. + return + end if end if - else if(have_option("/io/dump_period/python")) then - call get_option("/io/dump_period/python", func) - call real_from_python(func, current_time, real_dump_period, STAT) - if(stat == SPUD_NO_ERROR) then - if(real_dump_period < 0.0) then - FLExit("Dump period cannot be negative.") - end if + + if (starts_with(field%option_path,'/material_phase[')) then + if (aliased(field)) then + ! option_path points to other material_phase + ! must be an aliased field + include_tensor_field_in_vtu=.false. + return + end if + else + ! fields outside any material_phase + ! only output once for first state: + if (istate/=1) then + include_tensor_field_in_vtu=.false. + return + end if end if - else if(have_option("/io/dump_period_in_timesteps/constant")) then - call get_option("/io/dump_period_in_timesteps/constant", int_dump_period, stat) - if(stat == SPUD_NO_ERROR) then - if(int_dump_period < 0) then - FLExit("Dump period cannot be negative.") - end if + + ! if we get here the field is not aliased and has an option_path + ! now we let the user decide! + + output_option_path=trim(complete_field_path(field%option_path))//'/output' + + if (is_old_field) then + include_tensor_field_in_vtu=have_option(trim(output_option_path)//'/include_previous_time_step') + else if (is_nonlinear_field) then + include_tensor_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') + else if (is_iterated_field) then + include_tensor_field_in_vtu=have_option(trim(output_option_path)//'/include_nonlinear_field') + else + include_tensor_field_in_vtu=.not. have_option(trim(output_option_path)//'/exclude_from_vtu') end if - else if(have_option("/io/dump_period_in_timesteps/python")) then - call get_option("/io/dump_period_in_timesteps/python", func) - call integer_from_python(func, current_time, int_dump_period, stat) + + end function include_tensor_field_in_vtu + + subroutine write_state_module_check_options + !!< Check output related options + + character(len = OPTION_PATH_LEN) :: dump_format, output_mesh_name, func + integer :: int_dump_period, max_dump_file_count, stat + real :: real_dump_period, current_time + + ewrite(2, *) "Checking output options" + + call get_option("/timestepping/current_time", current_time) + + call get_option("/io/dump_format", dump_format, stat) if(stat == SPUD_NO_ERROR) then - if(int_dump_period < 0) then - FLExit("Dump period cannot be negative.") - end if + if(trim(dump_format) == "vtk") then + call get_option("/io/output_mesh[0]/name", output_mesh_name, stat = stat) + if(stat /= SPUD_NO_ERROR) then + FLExit("An output mesh must be specified if using a VTK dump format.") + else if(option_count("/geometry/mesh::" // output_mesh_name) == 0) then + FLExit("Output mesh " // trim(output_mesh_name) // " is not defined.") + end if + else + FLExit('Unrecognised dump format "' // trim(dump_format) // '"specified.') + end if + else + FLExit("Dump format must be specified.") end if - else - FLExit("Dump period must be specified (in either simulated time or timesteps).") - end if - - call get_option("/io/cpu_dump_period", real_dump_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_dump_period < 0.0) then - FLExit("CPU dump period cannot be negative.") + + if(have_option("/io/dump_period/constant")) then + call get_option("/io/dump_period/constant", real_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_dump_period < 0.0) then + FLExit("Dump period cannot be negative.") + end if + end if + else if(have_option("/io/dump_period/python")) then + call get_option("/io/dump_period/python", func) + call real_from_python(func, current_time, real_dump_period, STAT) + if(stat == SPUD_NO_ERROR) then + if(real_dump_period < 0.0) then + FLExit("Dump period cannot be negative.") + end if + end if + else if(have_option("/io/dump_period_in_timesteps/constant")) then + call get_option("/io/dump_period_in_timesteps/constant", int_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(int_dump_period < 0) then + FLExit("Dump period cannot be negative.") + end if + end if + else if(have_option("/io/dump_period_in_timesteps/python")) then + call get_option("/io/dump_period_in_timesteps/python", func) + call integer_from_python(func, current_time, int_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(int_dump_period < 0) then + FLExit("Dump period cannot be negative.") + end if + end if + else + FLExit("Dump period must be specified (in either simulated time or timesteps).") end if - end if - call get_option("/io/wall_time_dump_period", real_dump_period, stat) - if(stat == SPUD_NO_ERROR) then - if(real_dump_period < 0.0) then - FLExit("Wall time dump period cannot be negative.") + call get_option("/io/cpu_dump_period", real_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_dump_period < 0.0) then + FLExit("CPU dump period cannot be negative.") + end if end if - if(.not. wall_time_supported()) then - FLExit("Wall time dump period supplied, but wall time is not available.") + + call get_option("/io/wall_time_dump_period", real_dump_period, stat) + if(stat == SPUD_NO_ERROR) then + if(real_dump_period < 0.0) then + FLExit("Wall time dump period cannot be negative.") + end if + if(.not. wall_time_supported()) then + FLExit("Wall time dump period supplied, but wall time is not available.") + end if end if - end if - call get_option("/io/max_dump_file_count", max_dump_file_count, stat) - if(stat == SPUD_NO_ERROR) then - if(max_dump_file_count <= 0) then - FLExit("Max dump file count must be positive.") + call get_option("/io/max_dump_file_count", max_dump_file_count, stat) + if(stat == SPUD_NO_ERROR) then + if(max_dump_file_count <= 0) then + FLExit("Max dump file count must be positive.") + end if end if - end if - ewrite(2, *) "Finished checking output options." + ewrite(2, *) "Finished checking output options." - end subroutine write_state_module_check_options + end subroutine write_state_module_check_options end module write_state_module diff --git a/femtools/Write_Triangle.F90 b/femtools/Write_Triangle.F90 index a668681e47..6e9b72ed10 100644 --- a/femtools/Write_Triangle.F90 +++ b/femtools/Write_Triangle.F90 @@ -29,332 +29,332 @@ module write_triangle - use fldebug - use futils - use elements - use parallel_tools - use fields - use state_module - use field_options + use fldebug + use futils + use elements + use parallel_tools + use fields + use state_module + use field_options - implicit none + implicit none - private + private - public :: write_triangle_files + public :: write_triangle_files - interface write_triangle_files - module procedure write_mesh_to_triangles, & + interface write_triangle_files + module procedure write_mesh_to_triangles, & & write_positions_to_triangles - end interface write_triangle_files + end interface write_triangle_files contains - subroutine write_mesh_to_triangles(filename, state, mesh, number_of_partitions) - !!< Write out the supplied mesh to the specified filename as triangle files. + subroutine write_mesh_to_triangles(filename, state, mesh, number_of_partitions) + !!< Write out the supplied mesh to the specified filename as triangle files. - character(len = *), intent(in) :: filename - type(state_type), intent(in) :: state - type(mesh_type), intent(in) :: mesh - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions + character(len = *), intent(in) :: filename + type(state_type), intent(in) :: state + type(mesh_type), intent(in) :: mesh + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions - type(vector_field):: positions + type(vector_field):: positions - ! gets a coordinate field for the given mesh, if necessary - ! interpolated from "Coordinate", always takes a reference: - positions = get_nodal_coordinate_field(state, mesh) + ! gets a coordinate field for the given mesh, if necessary + ! interpolated from "Coordinate", always takes a reference: + positions = get_nodal_coordinate_field(state, mesh) - call write_triangle_files(filename, positions, number_of_partitions=number_of_partitions) + call write_triangle_files(filename, positions, number_of_partitions=number_of_partitions) - call deallocate(positions) + call deallocate(positions) - end subroutine write_mesh_to_triangles + end subroutine write_mesh_to_triangles - subroutine write_positions_to_triangles(filename, positions, print_internal_faces, number_of_partitions) - !!< Write out the mesh given by the position field in triangle files: - !!< a .node and a .ele-file (and a .face file if the mesh has a %faces - !!< component with more than 0 surface elements) - !!< In parallel, empty trailing processes are not written. - character(len=*), intent(in):: filename - type(vector_field), intent(in):: positions - logical, intent(in), optional :: print_internal_faces - !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) - integer, optional, intent(in):: number_of_partitions + subroutine write_positions_to_triangles(filename, positions, print_internal_faces, number_of_partitions) + !!< Write out the mesh given by the position field in triangle files: + !!< a .node and a .ele-file (and a .face file if the mesh has a %faces + !!< component with more than 0 surface elements) + !!< In parallel, empty trailing processes are not written. + character(len=*), intent(in):: filename + type(vector_field), intent(in):: positions + logical, intent(in), optional :: print_internal_faces + !!< If present, only write for processes 1:number_of_partitions (assumes the other partitions are empty) + integer, optional, intent(in):: number_of_partitions - integer :: nparts + integer :: nparts - if (present(number_of_partitions)) then - nparts = number_of_partitions - else - nparts = getnprocs() - end if + if (present(number_of_partitions)) then + nparts = number_of_partitions + else + nparts = getnprocs() + end if - ! Write out data only for those processes that contain data - SPMD requires - ! that there be no early return + ! Write out data only for those processes that contain data - SPMD requires + ! that there be no early return - if(getprocno() <= nparts) then + if(getprocno() <= nparts) then - ! write .node file with columns if present - if (associated(positions%mesh%columns)) then - call write_triangle_node_file_with_columns(filename, positions) - else - call write_triangle_node_file(filename, positions) - end if + ! write .node file with columns if present + if (associated(positions%mesh%columns)) then + call write_triangle_node_file_with_columns(filename, positions) + else + call write_triangle_node_file(filename, positions) + end if - call write_triangle_ele_file(filename, positions%mesh) - end if + call write_triangle_ele_file(filename, positions%mesh) + end if - if (present_and_true(print_internal_faces) .and. .not. has_faces(positions%mesh)) then - call add_faces(positions%mesh) - end if + if (present_and_true(print_internal_faces) .and. .not. has_faces(positions%mesh)) then + call add_faces(positions%mesh) + end if - if(getprocno() <= nparts) then - if (present_and_true(print_internal_faces)) then - call write_triangle_face_file_full(filename, positions%mesh) - else - call write_triangle_face_file(filename, positions%mesh) - end if - end if + if(getprocno() <= nparts) then + if (present_and_true(print_internal_faces)) then + call write_triangle_face_file_full(filename, positions%mesh) + else + call write_triangle_face_file(filename, positions%mesh) + end if + end if - end subroutine write_positions_to_triangles + end subroutine write_positions_to_triangles - subroutine write_triangle_node_file(filename, field) - !!< Writes out .node-file for the given position field - character(len=*), intent(in):: filename - type(vector_field), intent(in):: field + subroutine write_triangle_node_file(filename, field) + !!< Writes out .node-file for the given position field + character(len=*), intent(in):: filename + type(vector_field), intent(in):: field - character(len = 7 + int2str_len(huge(0)) + real_format_len(padding = 1)) :: format_buffer - integer unit, nodes, dim, no_coords, i + character(len = 7 + int2str_len(huge(0)) + real_format_len(padding = 1)) :: format_buffer + integer unit, nodes, dim, no_coords, i - unit=free_unit() + unit=free_unit() - nodes=node_count(field) - dim=mesh_dim(field) - no_coords=field%dim + nodes=node_count(field) + dim=mesh_dim(field) + no_coords=field%dim - open(unit=unit, file=trim(filename)//'.node', action='write', err=41) + open(unit=unit, file=trim(filename)//'.node', action='write', err=41) - ! header line: nodes, dim, no attributes, no boundary markers - write(unit, *, err=42) nodes, dim, 0, 0 + ! header line: nodes, dim, no attributes, no boundary markers + write(unit, *, err=42) nodes, dim, 0, 0 - format_buffer = "(i0,a," // int2str(no_coords) // real_format(padding = 1) // ")" - do i=1, nodes - write(unit, trim(format_buffer), err=42) i, " ", node_val(field, i) - end do + format_buffer = "(i0,a," // int2str(no_coords) // real_format(padding = 1) // ")" + do i=1, nodes + write(unit, trim(format_buffer), err=42) i, " ", node_val(field, i) + end do - close(unit=unit, err=43) - ! succesful return - return + close(unit=unit, err=43) + ! succesful return + return -41 FLExit("Failed to open .node file for writing.") +41 FLExit("Failed to open .node file for writing.") -42 FLExit("Error while writing .node file.") +42 FLExit("Error while writing .node file.") -43 FLExit("Failed to close .node file for writing.") +43 FLExit("Failed to close .node file for writing.") - end subroutine write_triangle_node_file + end subroutine write_triangle_node_file - subroutine write_triangle_node_file_with_columns(filename, field) - !!< Writes out .node-file for the given position field - !!< Write field%mesh%columns as node attribute - character(len=*), intent(in):: filename - type(vector_field), intent(in):: field + subroutine write_triangle_node_file_with_columns(filename, field) + !!< Writes out .node-file for the given position field + !!< Write field%mesh%columns as node attribute + character(len=*), intent(in):: filename + type(vector_field), intent(in):: field - character(len = 12 + int2str_len(huge(0)) + real_format_len(padding = 1)) :: format_buffer - integer unit, nodes, dim, i + character(len = 12 + int2str_len(huge(0)) + real_format_len(padding = 1)) :: format_buffer + integer unit, nodes, dim, i - unit=free_unit() + unit=free_unit() - nodes=node_count(field) - dim=mesh_dim(field) + nodes=node_count(field) + dim=mesh_dim(field) - open(unit=unit, file=trim(filename)//'.node', action='write', err=41) + open(unit=unit, file=trim(filename)//'.node', action='write', err=41) - ! header line: nodes, dim, no attributes (=1 for columns), no boundary markers - write(unit, *, err=42) nodes, dim, 1, 0 + ! header line: nodes, dim, no attributes (=1 for columns), no boundary markers + write(unit, *, err=42) nodes, dim, 1, 0 - format_buffer = "(i0,a," // int2str(dim) // real_format(padding = 1) // ",a,i0)" - do i=1, nodes - write(unit, trim(format_buffer), err=42) i, " ", node_val(field, i), " ", field%mesh%columns(i) - end do + format_buffer = "(i0,a," // int2str(dim) // real_format(padding = 1) // ",a,i0)" + do i=1, nodes + write(unit, trim(format_buffer), err=42) i, " ", node_val(field, i), " ", field%mesh%columns(i) + end do - close(unit=unit, err=43) - ! succesful return - return + close(unit=unit, err=43) + ! succesful return + return -41 FLExit("Failed to open .node file for writing.") +41 FLExit("Failed to open .node file for writing.") -42 FLExit("Error while writing .node file.") +42 FLExit("Error while writing .node file.") -43 FLExit("Failed to close .node file for writing.") +43 FLExit("Failed to close .node file for writing.") - end subroutine write_triangle_node_file_with_columns + end subroutine write_triangle_node_file_with_columns - subroutine write_triangle_ele_file(filename, mesh) - !!< Writes out .ele-file for the given mesh - character(len=*), intent(in):: filename - type(mesh_type), intent(in):: mesh + subroutine write_triangle_ele_file(filename, mesh) + !!< Writes out .ele-file for the given mesh + character(len=*), intent(in):: filename + type(mesh_type), intent(in):: mesh - integer unit, elements, nloc, i + integer unit, elements, nloc, i - unit=free_unit() + unit=free_unit() - elements=ele_count(mesh) - nloc=ele_loc(mesh, 1) + elements=ele_count(mesh) + nloc=ele_loc(mesh, 1) - open(unit=unit, file=trim(filename)//'.ele', action='write', err=41) + open(unit=unit, file=trim(filename)//'.ele', action='write', err=41) - ! Currently region_ids are lost in adapts (can remove the associated tests - ! when this is fixed) - if(associated(mesh%region_ids)) then - ! header line: elements, nloc, 1 attribute - write(unit, *, err=42) elements, nloc, 1 - else - ! header line: elements, nloc, no attributes - write(unit, *, err=42) elements, nloc, 0 - end if + ! Currently region_ids are lost in adapts (can remove the associated tests + ! when this is fixed) + if(associated(mesh%region_ids)) then + ! header line: elements, nloc, 1 attribute + write(unit, *, err=42) elements, nloc, 1 + else + ! header line: elements, nloc, no attributes + write(unit, *, err=42) elements, nloc, 0 + end if - do i=1, elements - if(associated(mesh%region_ids)) then - write(unit, *, err=42) i, ele_nodes(mesh, i), ele_region_id(mesh, i) - else - write(unit, *, err=42) i, ele_nodes(mesh, i) - end if - end do + do i=1, elements + if(associated(mesh%region_ids)) then + write(unit, *, err=42) i, ele_nodes(mesh, i), ele_region_id(mesh, i) + else + write(unit, *, err=42) i, ele_nodes(mesh, i) + end if + end do - close(unit=unit, err=43) - ! succesful return - return + close(unit=unit, err=43) + ! succesful return + return + +41 FLExit("Failed to open .ele file for writing.") + +42 FLExit("Error while writing .ele file.") + +43 FLExit("Failed to close .ele file for writing.") + + end subroutine write_triangle_ele_file + + subroutine write_triangle_face_file_full(filename, mesh) + !!< Writes out .face-file for the given mesh + character(len=*), intent(in):: filename + type(mesh_type), intent(in):: mesh + + integer unit, dim, nofaces, i + integer :: dg_total ! dg_total counts each internal face twice + integer :: ele, neigh, j, face + integer, dimension(:), pointer :: neighbours + + unit=free_unit() + + dim=mesh_dim(mesh) + dg_total=size(mesh%faces%face_list%sparsity%colm) + + nofaces = (dg_total - surface_element_count(mesh)) / 2 ! internal faces, only once + nofaces = nofaces + unique_surface_element_count(mesh) ! and the surface mesh (again counting internal facets only once) + + select case(dim) + case(3) + open(unit=unit, file=trim(filename)//'.face', action='write', err=41) + case(2) + open(unit=unit, file=trim(filename)//'.edge', action='write', err=41) + case(1) + open(unit=unit, file=trim(filename)//'.bound', action='write', err=41) + case default + ewrite(-1, "(a,i0)") "For dimension ", dim + FLAbort("Invalid dimension") + end select + + ! header line: nofaces, no boundary marker + write(unit, *, err=42) nofaces, 0 + + i = 1 + do ele=1,ele_count(mesh) + neighbours => ele_neigh(mesh, ele) + do j=1,size(neighbours) + neigh = neighbours(j) + ! we need to not count the internal face twice + ! so only print out the internal face for the ele < neigh + ! case; thus we don't print out the neigh > ele case + ! and we only do it once. + if (neigh < ele) then + face = ele_face(mesh, ele, neigh) + write(unit, *, err=42) i, face_global_nodes(mesh, face), 0 + i = i + 1 + end if + end do + end do -41 FLExit("Failed to open .ele file for writing.") + close(unit=unit, err=43) + ! succesful return + return -42 FLExit("Error while writing .ele file.") +41 FLExit("Failed to open .face/.edge/.bound file for writing.") -43 FLExit("Failed to close .ele file for writing.") +42 FLExit("Error while writing .face/.edge/.bound file.") - end subroutine write_triangle_ele_file +43 FLExit("Failed to close .face/.edge/.bound file for writing.") - subroutine write_triangle_face_file_full(filename, mesh) - !!< Writes out .face-file for the given mesh - character(len=*), intent(in):: filename - type(mesh_type), intent(in):: mesh + end subroutine write_triangle_face_file_full - integer unit, dim, nofaces, i - integer :: dg_total ! dg_total counts each internal face twice - integer :: ele, neigh, j, face - integer, dimension(:), pointer :: neighbours + subroutine write_triangle_face_file(filename, mesh) + !!< Writes out .face-file for the given mesh + character(len=*), intent(in):: filename + type(mesh_type), intent(in):: mesh - unit=free_unit() + integer :: unit, dim, nofaces, i + integer :: nolabels - dim=mesh_dim(mesh) - dg_total=size(mesh%faces%face_list%sparsity%colm) + unit=free_unit() - nofaces = (dg_total - surface_element_count(mesh)) / 2 ! internal faces, only once - nofaces = nofaces + unique_surface_element_count(mesh) ! and the surface mesh (again counting internal facets only once) + dim=mesh_dim(mesh) + nofaces=unique_surface_element_count(mesh) - select case(dim) - case(3) - open(unit=unit, file=trim(filename)//'.face', action='write', err=41) - case(2) - open(unit=unit, file=trim(filename)//'.edge', action='write', err=41) - case(1) - open(unit=unit, file=trim(filename)//'.bound', action='write', err=41) - case default - ewrite(-1, "(a,i0)") "For dimension ", dim - FLAbort("Invalid dimension") - end select - - ! header line: nofaces, no boundary marker - write(unit, *, err=42) nofaces, 0 - - i = 1 - do ele=1,ele_count(mesh) - neighbours => ele_neigh(mesh, ele) - do j=1,size(neighbours) - neigh = neighbours(j) - ! we need to not count the internal face twice - ! so only print out the internal face for the ele < neigh - ! case; thus we don't print out the neigh > ele case - ! and we only do it once. - if (neigh < ele) then - face = ele_face(mesh, ele, neigh) - write(unit, *, err=42) i, face_global_nodes(mesh, face), 0 - i = i + 1 - end if - end do - end do - - close(unit=unit, err=43) - ! succesful return - return - -41 FLExit("Failed to open .face/.edge/.bound file for writing.") - -42 FLExit("Error while writing .face/.edge/.bound file.") - -43 FLExit("Failed to close .face/.edge/.bound file for writing.") - - end subroutine write_triangle_face_file_full - - subroutine write_triangle_face_file(filename, mesh) - !!< Writes out .face-file for the given mesh - character(len=*), intent(in):: filename - type(mesh_type), intent(in):: mesh - - integer :: unit, dim, nofaces, i - integer :: nolabels - - unit=free_unit() - - dim=mesh_dim(mesh) - nofaces=unique_surface_element_count(mesh) - - select case(dim) - case(3) - open(unit=unit, file=trim(filename)//'.face', action='write', err=41) - case(2) - open(unit=unit, file=trim(filename)//'.edge', action='write', err=41) - case(1) - open(unit=unit, file=trim(filename)//'.bound', action='write', err=41) - case default - ewrite(-1, "(a,i0)") "For dimension ", dim - FLAbort("Invalid dimension") - end select - - if (has_discontinuous_internal_boundaries(mesh)) then - ! If the mesh is periodic, we want to write out the parent element of every face - nolabels = 2 - else - nolabels = 1 - end if - - ! header line: nofaces, and number of boundary markers - write(unit, *, err=42) nofaces, nolabels - - if (.not. has_discontinuous_internal_boundaries(mesh)) then - do i=1, nofaces - write(unit, *, err=42) i, face_global_nodes(mesh, i), & - surface_element_id(mesh, i) - end do - else - do i=1, nofaces - write(unit, *, err=42) i, face_global_nodes(mesh, i), & - surface_element_id(mesh, i), face_ele(mesh, i) - end do - end if + select case(dim) + case(3) + open(unit=unit, file=trim(filename)//'.face', action='write', err=41) + case(2) + open(unit=unit, file=trim(filename)//'.edge', action='write', err=41) + case(1) + open(unit=unit, file=trim(filename)//'.bound', action='write', err=41) + case default + ewrite(-1, "(a,i0)") "For dimension ", dim + FLAbort("Invalid dimension") + end select + + if (has_discontinuous_internal_boundaries(mesh)) then + ! If the mesh is periodic, we want to write out the parent element of every face + nolabels = 2 + else + nolabels = 1 + end if + + ! header line: nofaces, and number of boundary markers + write(unit, *, err=42) nofaces, nolabels + + if (.not. has_discontinuous_internal_boundaries(mesh)) then + do i=1, nofaces + write(unit, *, err=42) i, face_global_nodes(mesh, i), & + surface_element_id(mesh, i) + end do + else + do i=1, nofaces + write(unit, *, err=42) i, face_global_nodes(mesh, i), & + surface_element_id(mesh, i), face_ele(mesh, i) + end do + end if - close(unit=unit, err=43) - ! succesful return - return + close(unit=unit, err=43) + ! succesful return + return -41 FLExit("Failed to open .face/.edge/.bound file for writing.") +41 FLExit("Failed to open .face/.edge/.bound file for writing.") -42 FLExit("Error while writing .face/.edge/.bound file.") +42 FLExit("Error while writing .face/.edge/.bound file.") -43 FLExit("Failed to close .face/.edge/.bound file for writing.") +43 FLExit("Failed to close .face/.edge/.bound file for writing.") - end subroutine write_triangle_face_file + end subroutine write_triangle_face_file end module write_triangle diff --git a/femtools/python_state.F90 b/femtools/python_state.F90 index 072696e338..be0cd93a14 100644 --- a/femtools/python_state.F90 +++ b/femtools/python_state.F90 @@ -22,618 +22,618 @@ #include "fdebug.h" module python_state - use fldebug - use global_parameters, only:FIELD_NAME_LEN, current_debug_level, OPTION_PATH_LEN, PYTHON_FUNC_LEN - use futils, only: int2str - use quadrature - use sparse_tools - use element_numbering - use elements - use fields - use state_module - - implicit none - - private - - public :: python_init, python_reset - public :: python_add_array, python_add_field - public :: python_add_state, python_add_states, python_add_states_time - public :: python_run_string, python_run_file - public :: python_shell - public :: python_fetch_real - - interface - !! Python init and end - subroutine python_init() - end subroutine python_init - subroutine python_reset() - end subroutine python_reset - subroutine python_end() - end subroutine python_end - - !! Add a state_type object into the Python interpreter - subroutine python_add_statec(name,nlen) - implicit none - integer :: nlen - character(len=nlen) :: name - end subroutine python_add_statec - - !! Run a python string and file - subroutine python_run_stringc(s, slen, stat) - implicit none - integer, intent(in) :: slen - character(len = slen), intent(in) :: s - integer, intent(out) :: stat - end subroutine python_run_stringc - - subroutine python_run_filec(s, slen, stat) - implicit none - integer, intent(in) :: slen - character(len = slen), intent(in) :: s - integer, intent(out) :: stat - end subroutine python_run_filec - - end interface - - interface python_shell - module procedure python_shell_state, python_shell_states - end interface - - interface python_add_array - subroutine python_add_array_double_1d(arr,sizex,name,name_len) - implicit none - integer :: name_len,sizex - character(len=name_len) :: name - real,dimension(sizex) :: arr - end subroutine python_add_array_double_1d - subroutine python_add_array_double_2d(arr,sizex,sizey,name,name_len) - implicit none - integer :: name_len,sizex,sizey - character(len=name_len) :: name - real,dimension(sizex,sizey) :: arr - end subroutine python_add_array_double_2d - subroutine python_add_array_double_3d(arr,sizex,sizey,sizez,name,name_len) - implicit none - integer :: name_len,sizex,sizey,sizez - character(len=name_len) :: name - real,dimension(sizex,sizey,sizez) :: arr - end subroutine python_add_array_double_3d - - subroutine python_add_array_integer_1d(arr,sizex,name,name_len) - implicit none - integer :: name_len,sizex - character(len=name_len) :: name - integer,dimension(sizex) :: arr - end subroutine python_add_array_integer_1d - subroutine python_add_array_integer_2d(arr,sizex,sizey,name,name_len) - implicit none - integer :: name_len,sizex,sizey - character(len=name_len) :: name - integer,dimension(sizex,sizey) :: arr - end subroutine python_add_array_integer_2d - subroutine python_add_array_integer_3d(arr,sizex,sizey,sizez,name,name_len) - implicit none - integer :: name_len,sizex,sizey,sizez - character(len=name_len) :: name - integer,dimension(sizex,sizey,sizez) :: arr - end subroutine python_add_array_integer_3d - - module procedure python_add_array_d_1d_directly - module procedure python_add_array_d_2d_directly - module procedure python_add_array_d_3d_directly - - module procedure python_add_array_i_1d_directly - module procedure python_add_array_i_2d_directly - module procedure python_add_array_i_3d_directly - end interface python_add_array - - - !! Add a field to a State (these are for the C-interface, python_add_field_directly() is what you want probably) - interface python_add_field - subroutine python_add_scalar(sx,x,name,nlen,field_type,option_path,oplen,state_name,snlen,& + use fldebug + use global_parameters, only:FIELD_NAME_LEN, current_debug_level, OPTION_PATH_LEN, PYTHON_FUNC_LEN + use futils, only: int2str + use quadrature + use sparse_tools + use element_numbering + use elements + use fields + use state_module + + implicit none + + private + + public :: python_init, python_reset + public :: python_add_array, python_add_field + public :: python_add_state, python_add_states, python_add_states_time + public :: python_run_string, python_run_file + public :: python_shell + public :: python_fetch_real + + interface + !! Python init and end + subroutine python_init() + end subroutine python_init + subroutine python_reset() + end subroutine python_reset + subroutine python_end() + end subroutine python_end + + !! Add a state_type object into the Python interpreter + subroutine python_add_statec(name,nlen) + implicit none + integer :: nlen + character(len=nlen) :: name + end subroutine python_add_statec + + !! Run a python string and file + subroutine python_run_stringc(s, slen, stat) + implicit none + integer, intent(in) :: slen + character(len = slen), intent(in) :: s + integer, intent(out) :: stat + end subroutine python_run_stringc + + subroutine python_run_filec(s, slen, stat) + implicit none + integer, intent(in) :: slen + character(len = slen), intent(in) :: s + integer, intent(out) :: stat + end subroutine python_run_filec + + end interface + + interface python_shell + module procedure python_shell_state, python_shell_states + end interface + + interface python_add_array + subroutine python_add_array_double_1d(arr,sizex,name,name_len) + implicit none + integer :: name_len,sizex + character(len=name_len) :: name + real,dimension(sizex) :: arr + end subroutine python_add_array_double_1d + subroutine python_add_array_double_2d(arr,sizex,sizey,name,name_len) + implicit none + integer :: name_len,sizex,sizey + character(len=name_len) :: name + real,dimension(sizex,sizey) :: arr + end subroutine python_add_array_double_2d + subroutine python_add_array_double_3d(arr,sizex,sizey,sizez,name,name_len) + implicit none + integer :: name_len,sizex,sizey,sizez + character(len=name_len) :: name + real,dimension(sizex,sizey,sizez) :: arr + end subroutine python_add_array_double_3d + + subroutine python_add_array_integer_1d(arr,sizex,name,name_len) + implicit none + integer :: name_len,sizex + character(len=name_len) :: name + integer,dimension(sizex) :: arr + end subroutine python_add_array_integer_1d + subroutine python_add_array_integer_2d(arr,sizex,sizey,name,name_len) + implicit none + integer :: name_len,sizex,sizey + character(len=name_len) :: name + integer,dimension(sizex,sizey) :: arr + end subroutine python_add_array_integer_2d + subroutine python_add_array_integer_3d(arr,sizex,sizey,sizez,name,name_len) + implicit none + integer :: name_len,sizex,sizey,sizez + character(len=name_len) :: name + integer,dimension(sizex,sizey,sizez) :: arr + end subroutine python_add_array_integer_3d + + module procedure python_add_array_d_1d_directly + module procedure python_add_array_d_2d_directly + module procedure python_add_array_d_3d_directly + + module procedure python_add_array_i_1d_directly + module procedure python_add_array_i_2d_directly + module procedure python_add_array_i_3d_directly + end interface python_add_array + + + !! Add a field to a State (these are for the C-interface, python_add_field_directly() is what you want probably) + interface python_add_field + subroutine python_add_scalar(sx,x,name,nlen,field_type,option_path,oplen,state_name,snlen,& &mesh_name,mesh_name_len) - implicit none - integer :: sx,nlen,field_type,oplen,snlen,mesh_name_len - real, dimension(sx) :: x - character(len=nlen) :: name - character(len=snlen) :: state_name - character(len=oplen) :: option_path - character(len=mesh_name_len) :: mesh_name - end subroutine python_add_scalar - - subroutine python_add_csr_matrix(valuesSize, values, col_indSize, col_ind, row_ptrSize, & - row_ptr, name, namelen, state_name,snlen, numCols) - implicit none - integer :: valuesSize,col_indSize,row_ptrSize,namelen,snlen,numCols - real, dimension(valuesSize) :: values - integer, dimension(col_indSize) :: col_ind - integer, dimension(row_ptrSize) :: row_ptr - character(len=namelen) :: name - character(len=snlen) :: state_name - end subroutine python_add_csr_matrix - - subroutine python_add_vector(numdim,sx,x,& + implicit none + integer :: sx,nlen,field_type,oplen,snlen,mesh_name_len + real, dimension(sx) :: x + character(len=nlen) :: name + character(len=snlen) :: state_name + character(len=oplen) :: option_path + character(len=mesh_name_len) :: mesh_name + end subroutine python_add_scalar + + subroutine python_add_csr_matrix(valuesSize, values, col_indSize, col_ind, row_ptrSize, & + row_ptr, name, namelen, state_name,snlen, numCols) + implicit none + integer :: valuesSize,col_indSize,row_ptrSize,namelen,snlen,numCols + real, dimension(valuesSize) :: values + integer, dimension(col_indSize) :: col_ind + integer, dimension(row_ptrSize) :: row_ptr + character(len=namelen) :: name + character(len=snlen) :: state_name + end subroutine python_add_csr_matrix + + subroutine python_add_vector(numdim,sx,x,& &name,nlen,field_type,option_path,oplen,state_name,snlen,& &mesh_name,mesh_name_len) - implicit none - integer :: sx,numdim,nlen,field_type,oplen,snlen,mesh_name_len - real, dimension(sx) :: x - character(len=nlen) :: name - character(len=snlen) :: state_name - character(len=oplen) :: option_path - character(len=mesh_name_len) :: mesh_name - end subroutine python_add_vector - subroutine python_add_tensor(sx,sy,sz,x,numdim,name,nlen,field_type,option_path,oplen,state_name,snlen,& + implicit none + integer :: sx,numdim,nlen,field_type,oplen,snlen,mesh_name_len + real, dimension(sx) :: x + character(len=nlen) :: name + character(len=snlen) :: state_name + character(len=oplen) :: option_path + character(len=mesh_name_len) :: mesh_name + end subroutine python_add_vector + subroutine python_add_tensor(sx,sy,sz,x,numdim,name,nlen,field_type,option_path,oplen,state_name,snlen,& &mesh_name,mesh_name_len) - implicit none - integer :: sx,sy,sz,nlen,field_type,oplen,snlen,mesh_name_len - integer, dimension(2) :: numdim - real, dimension(sx,sy,sz) :: x - character(len=nlen) :: name - character(len=snlen) :: state_name - character(len=oplen) :: option_path - character(len=mesh_name_len) :: mesh_name - end subroutine python_add_tensor - - subroutine python_add_mesh(ndglno,sndglno,elements,nodes,name,nlen,option_path,oplen,& + implicit none + integer :: sx,sy,sz,nlen,field_type,oplen,snlen,mesh_name_len + integer, dimension(2) :: numdim + real, dimension(sx,sy,sz) :: x + character(len=nlen) :: name + character(len=snlen) :: state_name + character(len=oplen) :: option_path + character(len=mesh_name_len) :: mesh_name + end subroutine python_add_tensor + + subroutine python_add_mesh(ndglno,sndglno,elements,nodes,name,nlen,option_path,oplen,& &continuity,region_ids,sregion_ids,state_name,state_name_len) - !! Add a mesh to the state called state_name - implicit none - integer, dimension(*) :: ndglno,region_ids !! might cause a problem - integer :: sndglno, elements, nodes, nlen, oplen, continuity, sregion_ids, state_name_len - character(len=nlen) :: name - character(len=oplen) :: option_path - character(len=state_name_len) :: state_name - end subroutine python_add_mesh - - subroutine python_add_element(dim,loc,ngi,degree,stname,slen,mname,mlen,n,nx,ny,dn,dnx,dny,dnz,& + !! Add a mesh to the state called state_name + implicit none + integer, dimension(*) :: ndglno,region_ids !! might cause a problem + integer :: sndglno, elements, nodes, nlen, oplen, continuity, sregion_ids, state_name_len + character(len=nlen) :: name + character(len=oplen) :: option_path + character(len=state_name_len) :: state_name + end subroutine python_add_mesh + + subroutine python_add_element(dim,loc,ngi,degree,stname,slen,mname,mlen,n,nx,ny,dn,dnx,dny,dnz,& &size_spoly_x,size_spoly_y,size_dspoly_x,size_dspoly_y, family_name, family_name_len, & & type_name, type_name_len, & & coords, size_coords_x, size_coords_y) - !! Add an element to the state with stname and mesh with mname - implicit none - integer :: dim,loc,ngi,degree,slen,mlen,nx,ny,dnx,dny,dnz, family_name_len, type_name_len - integer :: size_spoly_x,size_spoly_y,size_dspoly_x,size_dspoly_y, size_coords_x, size_coords_y - real,dimension(nx,ny) :: n - real,dimension(dnx,dny,dnz) :: dn - character(len=slen) :: stname - character(len=mlen) :: mname - character(len=family_name_len) :: family_name - character(len=type_name_len) :: type_name - real, dimension(size_coords_x,size_coords_y) :: coords - end subroutine python_add_element - - subroutine python_add_quadrature(dim,loc,ngi,degree,weight,weight_size,locations,loc_size,surfacequad) - !! Add a quadrature to the last added element - implicit none - integer :: weight_size, loc_size, dim,loc,ngi,degree - integer :: surfacequad !! Specifies whether this quadrature is the normal quadr. or surface_quadr. - real, dimension(weight_size) :: weight - real, dimension(loc_size) :: locations - end subroutine python_add_quadrature - - subroutine python_add_polynomial(coefs, scoefs, degree, x,y, is_spoly) - !! Add a polynomial to the last added element at position x,y - !! is_spoly==1 <-> will be added to spoly, 0 to dspoly - implicit none - integer :: scoefs, degree, x,y,is_spoly - real, dimension(scoefs) :: coefs - end subroutine python_add_polynomial - - subroutine python_fetch_real_c(name, len, output) - character(len=*), intent(in) :: name - integer, intent(in) :: len - real, intent(out) :: output - end subroutine python_fetch_real_c - - module procedure python_add_scalar_directly - module procedure python_add_vector_directly - module procedure python_add_tensor_directly - module procedure python_add_csr_matrix_directly - end interface - - - - - - - !! The function versions called in Fortran, mainly simplified arguments, then - !! unwrapped and called to the interface to C - contains - - subroutine python_add_scalar_directly(S,st) - type(scalar_field) :: S - type(state_type) :: st - integer :: snlen,slen,oplen,mesh_name_len - slen = len(trim(S%name)) - snlen = len(trim(st%name)) - oplen = len(trim(S%option_path)) - mesh_name_len = len(trim(S%mesh%name)) - call python_add_scalar(size(S%val,1),S%val,& - trim(S%name),slen, S%field_type,S%option_path,oplen,trim(st%name),snlen,S%mesh%name,mesh_name_len) - end subroutine python_add_scalar_directly - - subroutine python_add_csr_matrix_directly(csrMatrix,st) - type(csr_matrix) :: csrMatrix - type(state_type) :: st - integer :: valSize, col_indSize, row_ptrSize, nameLen, statenameLen,numCols - type(csr_sparsity) :: csrSparsity - real, dimension(:), pointer :: values - integer, dimension(:), pointer :: col_ind - integer, dimension(:), pointer :: row_ptr - - csrSparsity = csrMatrix%sparsity - values => csrMatrix%val - - ! For CSR_INTEGER matrices, %val is not allocated. To ensure that python state - ! does not try to wrap it in an array, we return if this is the case. - if (.not. associated(values)) then - ewrite(2,*) "Skipping "//trim(csrMatrix%name)//" insertion into python state." - return - end if - - valSize = size(csrMatrix%val,1) - col_ind => csrSparsity%colm - col_indSize = valSize - row_ptr => csrSparsity%findrm - row_ptrSize = size(csrSparsity%findrm,1) - nameLen = len(trim(csrMatrix%name)) - statenameLen = len(trim(st%name)) - numCols = csrSparsity%columns - call python_add_csr_matrix(valSize, values, col_indSize, col_ind, row_ptrSize, row_ptr, & - trim(csrMatrix%name), nameLen, trim(st%name),statenameLen,numCols) - end subroutine python_add_csr_matrix_directly - - subroutine python_add_vector_directly(V,st) - type(vector_field) :: V - type(state_type) :: st - integer :: snlen,slen,oplen,mesh_name_len - real, dimension(0), target :: zero - - slen = len(trim(V%name)) - snlen = len(trim(st%name)) - oplen = len(trim(V%option_path)) - mesh_name_len = len(trim(V%mesh%name)) - - assert(v%dim==size(v%val,1)) - call python_add_vector(V%dim, size(V%val,2), V%val, & - trim(V%name), slen, V%field_type, V%option_path, oplen,trim(st%name),snlen,V%mesh%name,mesh_name_len) - - end subroutine python_add_vector_directly - - subroutine python_add_tensor_directly(T,st) - type(tensor_field) :: T - type(state_type) :: st - integer :: snlen,slen,oplen,mesh_name_len - slen = len(trim(T%name)) - snlen = len(trim(st%name)) - oplen = len(trim(T%option_path)) - mesh_name_len = len(trim(T%mesh%name)) - call python_add_tensor(size(T%val,1),size(T%val,2),size(T%val,3),T%val, T%dim,& - trim(T%name),slen, T%field_type,T%option_path,oplen,trim(st%name),snlen,T%mesh%name,mesh_name_len) - end subroutine python_add_tensor_directly - - subroutine python_add_mesh_directly(M,st) - type(mesh_type) :: M - type(state_type) :: st - integer :: snlen,slen,oplen - integer, dimension(:), allocatable :: temp_region_ids - - slen = len(trim(M%name)) - snlen = len(trim(st%name)) - oplen = len(trim(M%option_path)) - - if(associated(M%region_ids)) then - call python_add_mesh(M%ndglno,size(M%ndglno,1),M%elements,M%nodes,& - trim(M%name),slen,M%option_path,oplen,& - M%continuity, M%region_ids, size(M%region_ids),& - trim(st%name),snlen) - else - allocate(temp_region_ids(0)) - call python_add_mesh(M%ndglno,size(M%ndglno,1),M%elements,M%nodes,& - trim(M%name),slen,M%option_path,oplen,& - M%continuity, temp_region_ids, size(temp_region_ids),& - trim(st%name),snlen) - deallocate(temp_region_ids) - end if - end subroutine python_add_mesh_directly - - subroutine python_add_element_directly(E,M,st) - !! Add an element to the mesh M, by adding first the element and then its - !! attributes one by one the element's - !! 1) basic attributes - !! 2) quadrature - !! 3) spoly - !! 4) dspoly - type(element_type) :: E - type(mesh_type) :: M - type(state_type) :: st - real, dimension(E%loc, size(E%numbering%number2count, 1)) :: coords - integer :: snlen,mlen - integer :: i, j - character(len=20) :: family_name, type_name - integer :: l - - snlen = len(trim(st%name)) - mlen = len(trim(M%name)) - - family_name = "unknown" - if (E%numbering%family == FAMILY_SIMPLEX) then - family_name = "simplex" - else if (E%numbering%family == FAMILY_CUBE) then - family_name = "cube" - end if - - type_name = "unknown" - if (E%numbering%type == ELEMENT_LAGRANGIAN) then - type_name = "lagrangian" - else if (E%numbering%type == ELEMENT_BUBBLE) then - type_name = "bubble" - else if (E%numbering%type == ELEMENT_NONCONFORMING) then - type_name = "nonconforming" - end if - - do l=1,E%loc - coords(l,:) = local_coords(l, E) - end do - - call python_add_element(E%dim, E%loc, E%ngi, E%degree,& + !! Add an element to the state with stname and mesh with mname + implicit none + integer :: dim,loc,ngi,degree,slen,mlen,nx,ny,dnx,dny,dnz, family_name_len, type_name_len + integer :: size_spoly_x,size_spoly_y,size_dspoly_x,size_dspoly_y, size_coords_x, size_coords_y + real,dimension(nx,ny) :: n + real,dimension(dnx,dny,dnz) :: dn + character(len=slen) :: stname + character(len=mlen) :: mname + character(len=family_name_len) :: family_name + character(len=type_name_len) :: type_name + real, dimension(size_coords_x,size_coords_y) :: coords + end subroutine python_add_element + + subroutine python_add_quadrature(dim,loc,ngi,degree,weight,weight_size,locations,loc_size,surfacequad) + !! Add a quadrature to the last added element + implicit none + integer :: weight_size, loc_size, dim,loc,ngi,degree + integer :: surfacequad !! Specifies whether this quadrature is the normal quadr. or surface_quadr. + real, dimension(weight_size) :: weight + real, dimension(loc_size) :: locations + end subroutine python_add_quadrature + + subroutine python_add_polynomial(coefs, scoefs, degree, x,y, is_spoly) + !! Add a polynomial to the last added element at position x,y + !! is_spoly==1 <-> will be added to spoly, 0 to dspoly + implicit none + integer :: scoefs, degree, x,y,is_spoly + real, dimension(scoefs) :: coefs + end subroutine python_add_polynomial + + subroutine python_fetch_real_c(name, len, output) + character(len=*), intent(in) :: name + integer, intent(in) :: len + real, intent(out) :: output + end subroutine python_fetch_real_c + + module procedure python_add_scalar_directly + module procedure python_add_vector_directly + module procedure python_add_tensor_directly + module procedure python_add_csr_matrix_directly + end interface + + + + + + + !! The function versions called in Fortran, mainly simplified arguments, then + !! unwrapped and called to the interface to C +contains + + subroutine python_add_scalar_directly(S,st) + type(scalar_field) :: S + type(state_type) :: st + integer :: snlen,slen,oplen,mesh_name_len + slen = len(trim(S%name)) + snlen = len(trim(st%name)) + oplen = len(trim(S%option_path)) + mesh_name_len = len(trim(S%mesh%name)) + call python_add_scalar(size(S%val,1),S%val,& + trim(S%name),slen, S%field_type,S%option_path,oplen,trim(st%name),snlen,S%mesh%name,mesh_name_len) + end subroutine python_add_scalar_directly + + subroutine python_add_csr_matrix_directly(csrMatrix,st) + type(csr_matrix) :: csrMatrix + type(state_type) :: st + integer :: valSize, col_indSize, row_ptrSize, nameLen, statenameLen,numCols + type(csr_sparsity) :: csrSparsity + real, dimension(:), pointer :: values + integer, dimension(:), pointer :: col_ind + integer, dimension(:), pointer :: row_ptr + + csrSparsity = csrMatrix%sparsity + values => csrMatrix%val + + ! For CSR_INTEGER matrices, %val is not allocated. To ensure that python state + ! does not try to wrap it in an array, we return if this is the case. + if (.not. associated(values)) then + ewrite(2,*) "Skipping "//trim(csrMatrix%name)//" insertion into python state." + return + end if + + valSize = size(csrMatrix%val,1) + col_ind => csrSparsity%colm + col_indSize = valSize + row_ptr => csrSparsity%findrm + row_ptrSize = size(csrSparsity%findrm,1) + nameLen = len(trim(csrMatrix%name)) + statenameLen = len(trim(st%name)) + numCols = csrSparsity%columns + call python_add_csr_matrix(valSize, values, col_indSize, col_ind, row_ptrSize, row_ptr, & + trim(csrMatrix%name), nameLen, trim(st%name),statenameLen,numCols) + end subroutine python_add_csr_matrix_directly + + subroutine python_add_vector_directly(V,st) + type(vector_field) :: V + type(state_type) :: st + integer :: snlen,slen,oplen,mesh_name_len + real, dimension(0), target :: zero + + slen = len(trim(V%name)) + snlen = len(trim(st%name)) + oplen = len(trim(V%option_path)) + mesh_name_len = len(trim(V%mesh%name)) + + assert(v%dim==size(v%val,1)) + call python_add_vector(V%dim, size(V%val,2), V%val, & + trim(V%name), slen, V%field_type, V%option_path, oplen,trim(st%name),snlen,V%mesh%name,mesh_name_len) + + end subroutine python_add_vector_directly + + subroutine python_add_tensor_directly(T,st) + type(tensor_field) :: T + type(state_type) :: st + integer :: snlen,slen,oplen,mesh_name_len + slen = len(trim(T%name)) + snlen = len(trim(st%name)) + oplen = len(trim(T%option_path)) + mesh_name_len = len(trim(T%mesh%name)) + call python_add_tensor(size(T%val,1),size(T%val,2),size(T%val,3),T%val, T%dim,& + trim(T%name),slen, T%field_type,T%option_path,oplen,trim(st%name),snlen,T%mesh%name,mesh_name_len) + end subroutine python_add_tensor_directly + + subroutine python_add_mesh_directly(M,st) + type(mesh_type) :: M + type(state_type) :: st + integer :: snlen,slen,oplen + integer, dimension(:), allocatable :: temp_region_ids + + slen = len(trim(M%name)) + snlen = len(trim(st%name)) + oplen = len(trim(M%option_path)) + + if(associated(M%region_ids)) then + call python_add_mesh(M%ndglno,size(M%ndglno,1),M%elements,M%nodes,& + trim(M%name),slen,M%option_path,oplen,& + M%continuity, M%region_ids, size(M%region_ids),& + trim(st%name),snlen) + else + allocate(temp_region_ids(0)) + call python_add_mesh(M%ndglno,size(M%ndglno,1),M%elements,M%nodes,& + trim(M%name),slen,M%option_path,oplen,& + M%continuity, temp_region_ids, size(temp_region_ids),& + trim(st%name),snlen) + deallocate(temp_region_ids) + end if + end subroutine python_add_mesh_directly + + subroutine python_add_element_directly(E,M,st) + !! Add an element to the mesh M, by adding first the element and then its + !! attributes one by one the element's + !! 1) basic attributes + !! 2) quadrature + !! 3) spoly + !! 4) dspoly + type(element_type) :: E + type(mesh_type) :: M + type(state_type) :: st + real, dimension(E%loc, size(E%numbering%number2count, 1)) :: coords + integer :: snlen,mlen + integer :: i, j + character(len=20) :: family_name, type_name + integer :: l + + snlen = len(trim(st%name)) + mlen = len(trim(M%name)) + + family_name = "unknown" + if (E%numbering%family == FAMILY_SIMPLEX) then + family_name = "simplex" + else if (E%numbering%family == FAMILY_CUBE) then + family_name = "cube" + end if + + type_name = "unknown" + if (E%numbering%type == ELEMENT_LAGRANGIAN) then + type_name = "lagrangian" + else if (E%numbering%type == ELEMENT_BUBBLE) then + type_name = "bubble" + else if (E%numbering%type == ELEMENT_NONCONFORMING) then + type_name = "nonconforming" + end if + + do l=1,E%loc + coords(l,:) = local_coords(l, E) + end do + + call python_add_element(E%dim, E%loc, E%ngi, E%degree,& &trim(st%name),snlen,trim(M%name),mlen,& &E%n,size(E%n,1), size(E%n,2),E%dn, size(E%dn,1), size(E%dn,2), size(E%dn,3),& &size(E%spoly,1),size(E%spoly,2),size(E%dspoly,1),size(E%dspoly,2), family_name, len_trim(family_name), & &type_name, len_trim(type_name), & &coords, size(coords,1), size(coords,2)) - !! Add quadrature and surface_quadrature to this element - call python_add_quadrature(E%quadrature%dim, E%quadrature%degree, E%quadrature%vertices,E%quadrature%ngi,& + !! Add quadrature and surface_quadrature to this element + call python_add_quadrature(E%quadrature%dim, E%quadrature%degree, E%quadrature%vertices,E%quadrature%ngi,& &E%quadrature%weight, size(E%quadrature%weight), & &E%quadrature%l, size(E%quadrature%l),0) - if (associated(E%surface_quadrature)) then - call python_add_quadrature(E%surface_quadrature%dim, E%surface_quadrature%degree, E%surface_quadrature%vertices,E%surface_quadrature%ngi,& - &E%surface_quadrature%weight, size(E%surface_quadrature%weight), & - &E%surface_quadrature%l, size(E%surface_quadrature%l),1) - end if - - !! Since these are in an array, the polynomials must be added one by one, passing their indices - if (associated(E%spoly)) then - do i=1,size(E%spoly,1) - do j=1,size(E%spoly,2) - if(associated(E%spoly(i,j)%coefs)) then - call python_add_polynomial(E%spoly(i,j)%coefs,size(E%spoly(i,j)%coefs),E%spoly(i,j)%degree,i,j,1) - end if - end do - end do - endif - !! Do the same for dspoly - if (associated(E%dspoly)) then - do i=1,size(E%dspoly,1) - do j=1,size(E%dspoly,2) - if(associated(E%dspoly(i,j)%coefs)) then - call python_add_polynomial(E%dspoly(i,j)%coefs,size(E%dspoly(i,j)%coefs),E%dspoly(i,j)%degree,i,j,0) - end if - end do - end do - endif - end subroutine python_add_element_directly - - !! Insert a complete state into the python interpreter - subroutine python_add_state(S) - type(state_type) :: S - integer :: i,nlen - nlen = len(trim(S%name)) - call python_add_statec(trim(S%name),nlen) - - if ( associated(S%meshes) ) then - do i=1,(size(S%meshes)) - call python_add_mesh_directly(S%meshes(i)%ptr,S) - call python_add_element_directly(S%meshes(i)%ptr%shape,S%meshes(i)%ptr,S) - end do - end if - if ( associated(S%scalar_fields) ) then - do i=1,(size(S%scalar_fields)) - call python_add_field(S%scalar_fields(i)%ptr,S) - end do - end if - if ( associated(S%vector_fields) ) then - do i=1,(size(S%vector_fields)) - call python_add_field(S%vector_fields(i)%ptr,S) - end do - end if - if ( associated(S%tensor_fields) ) then - do i=1,(size(S%tensor_fields)) - call python_add_field(S%tensor_fields(i)%ptr,S) - end do - end if - if ( associated(S%csr_matrices) ) then - do i=1,(size(S%csr_matrices)) - call python_add_field(S%csr_matrices(i)%ptr,S) - end do - end if + if (associated(E%surface_quadrature)) then + call python_add_quadrature(E%surface_quadrature%dim, E%surface_quadrature%degree, E%surface_quadrature%vertices,E%surface_quadrature%ngi,& + &E%surface_quadrature%weight, size(E%surface_quadrature%weight), & + &E%surface_quadrature%l, size(E%surface_quadrature%l),1) + end if + + !! Since these are in an array, the polynomials must be added one by one, passing their indices + if (associated(E%spoly)) then + do i=1,size(E%spoly,1) + do j=1,size(E%spoly,2) + if(associated(E%spoly(i,j)%coefs)) then + call python_add_polynomial(E%spoly(i,j)%coefs,size(E%spoly(i,j)%coefs),E%spoly(i,j)%degree,i,j,1) + end if + end do + end do + endif + !! Do the same for dspoly + if (associated(E%dspoly)) then + do i=1,size(E%dspoly,1) + do j=1,size(E%dspoly,2) + if(associated(E%dspoly(i,j)%coefs)) then + call python_add_polynomial(E%dspoly(i,j)%coefs,size(E%dspoly(i,j)%coefs),E%dspoly(i,j)%degree,i,j,0) + end if + end do + end do + endif + end subroutine python_add_element_directly + + !! Insert a complete state into the python interpreter + subroutine python_add_state(S) + type(state_type) :: S + integer :: i,nlen + nlen = len(trim(S%name)) + call python_add_statec(trim(S%name),nlen) + + if ( associated(S%meshes) ) then + do i=1,(size(S%meshes)) + call python_add_mesh_directly(S%meshes(i)%ptr,S) + call python_add_element_directly(S%meshes(i)%ptr%shape,S%meshes(i)%ptr,S) + end do + end if + if ( associated(S%scalar_fields) ) then + do i=1,(size(S%scalar_fields)) + call python_add_field(S%scalar_fields(i)%ptr,S) + end do + end if + if ( associated(S%vector_fields) ) then + do i=1,(size(S%vector_fields)) + call python_add_field(S%vector_fields(i)%ptr,S) + end do + end if + if ( associated(S%tensor_fields) ) then + do i=1,(size(S%tensor_fields)) + call python_add_field(S%tensor_fields(i)%ptr,S) + end do + end if + if ( associated(S%csr_matrices) ) then + do i=1,(size(S%csr_matrices)) + call python_add_field(S%csr_matrices(i)%ptr,S) + end do + end if - end subroutine python_add_state + end subroutine python_add_state - subroutine python_add_states(S) - type(state_type), dimension(:) :: S - integer :: i + subroutine python_add_states(S) + type(state_type), dimension(:) :: S + integer :: i - do i = 1, size(S) - call python_add_state(S(i)) - end do + do i = 1, size(S) + call python_add_state(S(i)) + end do - end subroutine python_add_states + end subroutine python_add_states - subroutine python_add_states_time(S) - type(state_type), dimension(:,:), intent(in), pointer :: S ! material_phases (1:n) x timesteps (p:q) - integer :: min_timestep - integer :: max_timestep - integer :: i + subroutine python_add_states_time(S) + type(state_type), dimension(:,:), intent(in), pointer :: S ! material_phases (1:n) x timesteps (p:q) + integer :: min_timestep + integer :: max_timestep + integer :: i - min_timestep = lbound(S, 2) - max_timestep = ubound(S, 2) + min_timestep = lbound(S, 2) + max_timestep = ubound(S, 2) - call python_run_string("megastates = [0] * " // int2str(max_timestep+1)) - do i=min_timestep,max_timestep - call python_add_states(S(:, i)) - ! So right now, state = to the i'th state to be considered. - ! Let's pack it into states[i-1] - call python_run_string("megastates[" // int2str(i) // "] = states; states = {}") - end do + call python_run_string("megastates = [0] * " // int2str(max_timestep+1)) + do i=min_timestep,max_timestep + call python_add_states(S(:, i)) + ! So right now, state = to the i'th state to be considered. + ! Let's pack it into states[i-1] + call python_run_string("megastates[" // int2str(i) // "] = states; states = {}") + end do - call python_run_string("states = megastates; del megastates; del state") + call python_run_string("states = megastates; del megastates; del state") - end subroutine python_add_states_time + end subroutine python_add_states_time - subroutine python_shell_state(state) - !!< Wrapper to allow python_shell to be called with a single state as - !!< an argument. - type(state_type), target, intent(inout) :: state + subroutine python_shell_state(state) + !!< Wrapper to allow python_shell to be called with a single state as + !!< an argument. + type(state_type), target, intent(inout) :: state - type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: states - states(1)=state + states(1)=state - call python_shell_states(states) + call python_shell_states(states) - end subroutine python_shell_state + end subroutine python_shell_state - subroutine python_shell_states(states) - !!< Launch a python shell with access to the current state(s) provided. This is mostly - !!< useful for debugging. + subroutine python_shell_states(states) + !!< Launch a python shell with access to the current state(s) provided. This is mostly + !!< useful for debugging. - type(state_type), dimension(:), target, intent(inout) :: states + type(state_type), dimension(:), target, intent(inout) :: states #ifdef HAVE_NUMPY - ! Clean up to make sure that nothing else interferes - call python_reset() + ! Clean up to make sure that nothing else interferes + call python_reset() - call python_add_states(states) + call python_add_states(states) - call python_run_string("import fluidity_tools") + call python_run_string("import fluidity_tools") - call python_run_string("fluidity_tools.shell()()") + call python_run_string("fluidity_tools.shell()()") - ! Cleanup - call python_reset() + ! Cleanup + call python_reset() #else - FLExit("Python shell requires NumPy, which cannot be located.") + FLExit("Python shell requires NumPy, which cannot be located.") #endif - end subroutine python_shell_states - - - !! Wrapper procedures to add arrays to the Python interpreter - - subroutine python_add_array_d_1d_directly(arr,var_name) - real,dimension(:) :: arr - character(len=*) :: var_name - integer :: name_len, sizex - sizex = size(arr) - name_len = len(var_name) - call python_add_array_double_1d(arr,sizex,var_name,name_len) - end subroutine python_add_array_d_1d_directly - subroutine python_add_array_d_2d_directly(arr,var_name) - real,dimension(:,:) :: arr - character(len=*) :: var_name - integer :: name_len, sizex, sizey - sizex = size(arr,1) - sizey = size(arr,2) - name_len = len(var_name) - call python_add_array_double_2d(arr,sizex,sizey,var_name,name_len) - end subroutine python_add_array_d_2d_directly - subroutine python_add_array_d_3d_directly(arr,var_name) - real,dimension(:,:,:) :: arr - character(len=*) :: var_name - integer :: name_len, sizex, sizey, sizez - sizex = size(arr,1) - sizey = size(arr,2) - sizez = size(arr,3) - name_len = len(var_name) - call python_add_array_double_3d(arr,sizex,sizey,sizez,var_name,name_len) - end subroutine python_add_array_d_3d_directly - - subroutine python_add_array_i_1d_directly(arr,var_name) - integer,dimension(:) :: arr - character(len=*) :: var_name - integer :: name_len, sizex - sizex = size(arr) - name_len = len(var_name) - call python_add_array_integer_1d(arr,sizex,var_name,name_len) - end subroutine python_add_array_i_1d_directly - subroutine python_add_array_i_2d_directly(arr,var_name) - integer,dimension(:,:) :: arr - character(len=*) :: var_name - integer :: name_len, sizex, sizey - sizex = size(arr,1) - sizey = size(arr,2) - name_len = len(var_name) - call python_add_array_integer_2d(arr,sizex,sizey,var_name,name_len) - end subroutine python_add_array_i_2d_directly - subroutine python_add_array_i_3d_directly(arr,var_name) - integer,dimension(:,:,:) :: arr - character(len=*) :: var_name - integer :: name_len, sizex, sizey, sizez - sizex = size(arr,1) - sizey = size(arr,2) - sizez = size(arr,3) - name_len = len(var_name) - call python_add_array_integer_3d(arr,sizex,sizey,sizez,var_name,name_len) - end subroutine python_add_array_i_3d_directly - - subroutine python_run_string(s, stat) - !!< Wrapper for function for python_run_stringc - - character(len = *), intent(in) :: s - integer, optional, intent(out) :: stat - - integer :: lstat - - if(present(stat)) stat = 0 - - call python_run_stringc(s, len_trim(s), lstat) - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - else - ewrite(-1, *) "Python error, Python string was:" - ewrite(-1, *) trim(s) - FLExit("Dying") + end subroutine python_shell_states + + + !! Wrapper procedures to add arrays to the Python interpreter + + subroutine python_add_array_d_1d_directly(arr,var_name) + real,dimension(:) :: arr + character(len=*) :: var_name + integer :: name_len, sizex + sizex = size(arr) + name_len = len(var_name) + call python_add_array_double_1d(arr,sizex,var_name,name_len) + end subroutine python_add_array_d_1d_directly + subroutine python_add_array_d_2d_directly(arr,var_name) + real,dimension(:,:) :: arr + character(len=*) :: var_name + integer :: name_len, sizex, sizey + sizex = size(arr,1) + sizey = size(arr,2) + name_len = len(var_name) + call python_add_array_double_2d(arr,sizex,sizey,var_name,name_len) + end subroutine python_add_array_d_2d_directly + subroutine python_add_array_d_3d_directly(arr,var_name) + real,dimension(:,:,:) :: arr + character(len=*) :: var_name + integer :: name_len, sizex, sizey, sizez + sizex = size(arr,1) + sizey = size(arr,2) + sizez = size(arr,3) + name_len = len(var_name) + call python_add_array_double_3d(arr,sizex,sizey,sizez,var_name,name_len) + end subroutine python_add_array_d_3d_directly + + subroutine python_add_array_i_1d_directly(arr,var_name) + integer,dimension(:) :: arr + character(len=*) :: var_name + integer :: name_len, sizex + sizex = size(arr) + name_len = len(var_name) + call python_add_array_integer_1d(arr,sizex,var_name,name_len) + end subroutine python_add_array_i_1d_directly + subroutine python_add_array_i_2d_directly(arr,var_name) + integer,dimension(:,:) :: arr + character(len=*) :: var_name + integer :: name_len, sizex, sizey + sizex = size(arr,1) + sizey = size(arr,2) + name_len = len(var_name) + call python_add_array_integer_2d(arr,sizex,sizey,var_name,name_len) + end subroutine python_add_array_i_2d_directly + subroutine python_add_array_i_3d_directly(arr,var_name) + integer,dimension(:,:,:) :: arr + character(len=*) :: var_name + integer :: name_len, sizex, sizey, sizez + sizex = size(arr,1) + sizey = size(arr,2) + sizez = size(arr,3) + name_len = len(var_name) + call python_add_array_integer_3d(arr,sizex,sizey,sizez,var_name,name_len) + end subroutine python_add_array_i_3d_directly + + subroutine python_run_string(s, stat) + !!< Wrapper for function for python_run_stringc + + character(len = *), intent(in) :: s + integer, optional, intent(out) :: stat + + integer :: lstat + + if(present(stat)) stat = 0 + + call python_run_stringc(s, len_trim(s), lstat) + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + else + ewrite(-1, *) "Python error, Python string was:" + ewrite(-1, *) trim(s) + FLExit("Dying") + end if end if - end if - end subroutine python_run_string + end subroutine python_run_string - subroutine python_run_file(s, stat) - !!< Wrapper for function for python_run_filec + subroutine python_run_file(s, stat) + !!< Wrapper for function for python_run_filec - character(len = *), intent(in) :: s - integer, optional, intent(out) :: stat + character(len = *), intent(in) :: s + integer, optional, intent(out) :: stat - integer :: lstat + integer :: lstat - if(present(stat)) stat = 0 + if(present(stat)) stat = 0 - call python_run_filec(s, len_trim(s), lstat) - if(lstat /= 0) then - if(present(stat)) then - stat = lstat - else - ewrite(-1, *) "Python error, Python file was:" - ewrite(-1, *) trim(s) - FLExit("Dying") + call python_run_filec(s, len_trim(s), lstat) + if(lstat /= 0) then + if(present(stat)) then + stat = lstat + else + ewrite(-1, *) "Python error, Python file was:" + ewrite(-1, *) trim(s) + FLExit("Dying") + end if end if - end if - end subroutine python_run_file + end subroutine python_run_file - function python_fetch_real(name) result(output) - character(len=*), intent(in) :: name - real :: output + function python_fetch_real(name) result(output) + character(len=*), intent(in) :: name + real :: output - call python_fetch_real_c(name, len(name), output) - end function python_fetch_real + call python_fetch_real_c(name, len(name), output) + end function python_fetch_real end module python_state diff --git a/femtools/qsortd.F90 b/femtools/qsortd.F90 index d2d4cbfa20..2cb9d7a952 100644 --- a/femtools/qsortd.F90 +++ b/femtools/qsortd.F90 @@ -2,32 +2,32 @@ module quicksort - use iso_c_binding, only: c_float - use fldebug + use iso_c_binding, only: c_float + use fldebug - implicit none + implicit none - private + private - public :: qsort, sort, count_unique, inverse_permutation, apply_permutation, apply_reverse_permutation + public :: qsort, sort, count_unique, inverse_permutation, apply_permutation, apply_reverse_permutation - interface qsort - module procedure qsortd, qsortsp, qsorti - end interface qsort + interface qsort + module procedure qsortd, qsortsp, qsorti + end interface qsort - interface sort - module procedure sort_integer_array, sort_real_array - end interface + interface sort + module procedure sort_integer_array, sort_real_array + end interface - interface apply_permutation - module procedure apply_permutation_integer_array, & + interface apply_permutation + module procedure apply_permutation_integer_array, & & apply_permutation_real_array, apply_permutation_integer, & & apply_permutation_real - end interface apply_permutation + end interface apply_permutation - interface apply_reverse_permutation - module procedure apply_reverse_permutation_real, apply_reverse_permutation_integer - end interface apply_reverse_permutation + interface apply_reverse_permutation + module procedure apply_reverse_permutation_real, apply_reverse_permutation_integer + end interface apply_reverse_permutation contains @@ -36,17 +36,17 @@ module quicksort ! Believed to be public domain as it is the work of ! a US government employee. -SUBROUTINE qsortd(x, ind) + SUBROUTINE qsortd(x, ind) ! Code converted using TO_F90 by Alan Miller ! Date: 2002-12-18 Time: 11:55:47 -IMPLICIT NONE -INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) + IMPLICIT NONE + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) -REAL (dp), INTENT(IN) :: x(:) -INTEGER, INTENT(OUT) :: ind(:) -INTEGER :: n + REAL (dp), INTENT(IN) :: x(:) + INTEGER, INTENT(OUT) :: ind(:) + INTEGER :: n !*************************************************************************** @@ -85,12 +85,12 @@ SUBROUTINE qsortd(x, ind) !********************************************************************* -INTEGER :: iu(21), il(21) -INTEGER :: m, i, j, k, l, ij, it, itt, indx -REAL :: r -REAL (dp) :: t + INTEGER :: iu(21), il(21) + INTEGER :: m, i, j, k, l, ij, it, itt, indx + REAL :: r + REAL (dp) :: t -n = size(x) + n = size(x) ! LOCAL PARAMETERS - @@ -105,154 +105,154 @@ SUBROUTINE qsortd(x, ind) ! R = PSEUDO RANDOM NUMBER FOR GENERATING IJ ! T = CENTRAL ELEMENT OF X -IF (n <= 0) RETURN + IF (n <= 0) RETURN ! INITIALIZE IND, M, I, J, AND R -DO i = 1, n - ind(i) = i -END DO -m = 1 -i = 1 -j = n -r = .375 + DO i = 1, n + ind(i) = i + END DO + m = 1 + i = 1 + j = n + r = .375 ! TOP OF LOOP -20 IF (i >= j) GO TO 70 -IF (r <= .5898437) THEN - r = r + .0390625 -ELSE - r = r - .21875 -END IF +20 IF (i >= j) GO TO 70 + IF (r <= .5898437) THEN + r = r + .0390625 + ELSE + r = r - .21875 + END IF ! INITIALIZE K -30 k = i +30 k = i ! SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T -ij = i + r*(j-i) -it = ind(ij) -t = x(it) + ij = i + r*(j-i) + it = ind(ij) + t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T -indx = ind(i) -IF (x(indx) > t) THEN - ind(ij) = indx - ind(i) = it - it = indx - t = x(it) -END IF + indx = ind(i) + IF (x(indx) > t) THEN + ind(ij) = indx + ind(i) = it + it = indx + t = x(it) + END IF ! INITIALIZE L -l = j + l = j ! IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, ! INTERCHANGE IT WITH T -indx = ind(j) -IF (x(indx) >= t) GO TO 50 -ind(ij) = indx -ind(j) = it -it = indx -t = x(it) + indx = ind(j) + IF (x(indx) >= t) GO TO 50 + ind(ij) = indx + ind(j) = it + it = indx + t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T -indx = ind(i) -IF (x(indx) <= t) GO TO 50 -ind(ij) = indx -ind(i) = it -it = indx -t = x(it) -GO TO 50 + indx = ind(i) + IF (x(indx) <= t) GO TO 50 + ind(ij) = indx + ind(i) = it + it = indx + t = x(it) + GO TO 50 ! INTERCHANGE ELEMENTS K AND L -40 itt = ind(l) -ind(l) = ind(k) -ind(k) = itt +40 itt = ind(l) + ind(l) = ind(k) + ind(k) = itt ! FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS ! NOT LARGER THAN T -50 l = l - 1 -indx = ind(l) -IF (x(indx) > t) GO TO 50 +50 l = l - 1 + indx = ind(l) + IF (x(indx) > t) GO TO 50 ! FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS NOT SMALLER THAN T -60 k = k + 1 -indx = ind(k) -IF (x(indx) < t) GO TO 60 +60 k = k + 1 + indx = ind(k) + IF (x(indx) < t) GO TO 60 ! IF K <= L, INTERCHANGE ELEMENTS K AND L -IF (k <= l) GO TO 40 + IF (k <= l) GO TO 40 ! SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE ! ARRAY YET TO BE SORTED -IF (l-i > j-k) THEN - il(m) = i - iu(m) = l - i = k - m = m + 1 - GO TO 80 -END IF + IF (l-i > j-k) THEN + il(m) = i + iu(m) = l + i = k + m = m + 1 + GO TO 80 + END IF -il(m) = k -iu(m) = j -j = l -m = m + 1 -GO TO 80 + il(m) = k + iu(m) = j + j = l + m = m + 1 + GO TO 80 ! BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY -70 m = m - 1 -IF (m == 0) RETURN -i = il(m) -j = iu(m) +70 m = m - 1 + IF (m == 0) RETURN + i = il(m) + j = iu(m) -80 IF (j-i >= 11) GO TO 30 -IF (i == 1) GO TO 20 -i = i - 1 +80 IF (j-i >= 11) GO TO 30 + IF (i == 1) GO TO 20 + i = i - 1 ! SORT ELEMENTS I+1,...,J. NOTE THAT 1 <= I < J AND J-I < 11. -90 i = i + 1 -IF (i == j) GO TO 70 -indx = ind(i+1) -t = x(indx) -it = indx -indx = ind(i) -IF (x(indx) <= t) GO TO 90 -k = i +90 i = i + 1 + IF (i == j) GO TO 70 + indx = ind(i+1) + t = x(indx) + it = indx + indx = ind(i) + IF (x(indx) <= t) GO TO 90 + k = i -100 ind(k+1) = ind(k) -k = k - 1 -indx = ind(k) -IF (t < x(indx)) GO TO 100 +100 ind(k+1) = ind(k) + k = k - 1 + indx = ind(k) + IF (t < x(indx)) GO TO 100 -ind(k+1) = it -GO TO 90 -END SUBROUTINE qsortd + ind(k+1) = it + GO TO 90 + END SUBROUTINE qsortd -SUBROUTINE qsortsp(x, ind) + SUBROUTINE qsortsp(x, ind) ! Code converted using TO_F90 by Alan Miller ! Date: 2002-12-18 Time: 11:55:47 -IMPLICIT NONE + IMPLICIT NONE -REAL (kind = c_float), INTENT(IN) :: x(:) -INTEGER, INTENT(OUT) :: ind(:) -INTEGER :: n + REAL (kind = c_float), INTENT(IN) :: x(:) + INTEGER, INTENT(OUT) :: ind(:) + INTEGER :: n !*************************************************************************** @@ -291,12 +291,12 @@ SUBROUTINE qsortsp(x, ind) !********************************************************************* -INTEGER :: iu(21), il(21) -INTEGER :: m, i, j, k, l, ij, it, itt, indx -REAL :: r -REAL (kind = c_float) :: t + INTEGER :: iu(21), il(21) + INTEGER :: m, i, j, k, l, ij, it, itt, indx + REAL :: r + REAL (kind = c_float) :: t -n = size(x) + n = size(x) ! LOCAL PARAMETERS - @@ -311,154 +311,154 @@ SUBROUTINE qsortsp(x, ind) ! R = PSEUDO RANDOM NUMBER FOR GENERATING IJ ! T = CENTRAL ELEMENT OF X -IF (n <= 0) RETURN + IF (n <= 0) RETURN ! INITIALIZE IND, M, I, J, AND R -DO i = 1, n - ind(i) = i -END DO -m = 1 -i = 1 -j = n -r = .375 + DO i = 1, n + ind(i) = i + END DO + m = 1 + i = 1 + j = n + r = .375 ! TOP OF LOOP -20 IF (i >= j) GO TO 70 -IF (r <= .5898437) THEN - r = r + .0390625 -ELSE - r = r - .21875 -END IF +20 IF (i >= j) GO TO 70 + IF (r <= .5898437) THEN + r = r + .0390625 + ELSE + r = r - .21875 + END IF ! INITIALIZE K -30 k = i +30 k = i ! SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T -ij = i + r*(j-i) -it = ind(ij) -t = x(it) + ij = i + r*(j-i) + it = ind(ij) + t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T -indx = ind(i) -IF (x(indx) > t) THEN - ind(ij) = indx - ind(i) = it - it = indx - t = x(it) -END IF + indx = ind(i) + IF (x(indx) > t) THEN + ind(ij) = indx + ind(i) = it + it = indx + t = x(it) + END IF ! INITIALIZE L -l = j + l = j ! IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, ! INTERCHANGE IT WITH T -indx = ind(j) -IF (x(indx) >= t) GO TO 50 -ind(ij) = indx -ind(j) = it -it = indx -t = x(it) + indx = ind(j) + IF (x(indx) >= t) GO TO 50 + ind(ij) = indx + ind(j) = it + it = indx + t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T -indx = ind(i) -IF (x(indx) <= t) GO TO 50 -ind(ij) = indx -ind(i) = it -it = indx -t = x(it) -GO TO 50 + indx = ind(i) + IF (x(indx) <= t) GO TO 50 + ind(ij) = indx + ind(i) = it + it = indx + t = x(it) + GO TO 50 ! INTERCHANGE ELEMENTS K AND L -40 itt = ind(l) -ind(l) = ind(k) -ind(k) = itt +40 itt = ind(l) + ind(l) = ind(k) + ind(k) = itt ! FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS ! NOT LARGER THAN T -50 l = l - 1 -indx = ind(l) -IF (x(indx) > t) GO TO 50 +50 l = l - 1 + indx = ind(l) + IF (x(indx) > t) GO TO 50 ! FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS NOT SMALLER THAN T -60 k = k + 1 -indx = ind(k) -IF (x(indx) < t) GO TO 60 +60 k = k + 1 + indx = ind(k) + IF (x(indx) < t) GO TO 60 ! IF K <= L, INTERCHANGE ELEMENTS K AND L -IF (k <= l) GO TO 40 + IF (k <= l) GO TO 40 ! SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE ! ARRAY YET TO BE SORTED -IF (l-i > j-k) THEN - il(m) = i - iu(m) = l - i = k - m = m + 1 - GO TO 80 -END IF + IF (l-i > j-k) THEN + il(m) = i + iu(m) = l + i = k + m = m + 1 + GO TO 80 + END IF -il(m) = k -iu(m) = j -j = l -m = m + 1 -GO TO 80 + il(m) = k + iu(m) = j + j = l + m = m + 1 + GO TO 80 ! BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY -70 m = m - 1 -IF (m == 0) RETURN -i = il(m) -j = iu(m) +70 m = m - 1 + IF (m == 0) RETURN + i = il(m) + j = iu(m) -80 IF (j-i >= 11) GO TO 30 -IF (i == 1) GO TO 20 -i = i - 1 +80 IF (j-i >= 11) GO TO 30 + IF (i == 1) GO TO 20 + i = i - 1 ! SORT ELEMENTS I+1,...,J. NOTE THAT 1 <= I < J AND J-I < 11. -90 i = i + 1 -IF (i == j) GO TO 70 -indx = ind(i+1) -t = x(indx) -it = indx -indx = ind(i) -IF (x(indx) <= t) GO TO 90 -k = i +90 i = i + 1 + IF (i == j) GO TO 70 + indx = ind(i+1) + t = x(indx) + it = indx + indx = ind(i) + IF (x(indx) <= t) GO TO 90 + k = i -100 ind(k+1) = ind(k) -k = k - 1 -indx = ind(k) -IF (t < x(indx)) GO TO 100 +100 ind(k+1) = ind(k) + k = k - 1 + indx = ind(k) + IF (t < x(indx)) GO TO 100 -ind(k+1) = it -GO TO 90 -END SUBROUTINE qsortsp + ind(k+1) = it + GO TO 90 + END SUBROUTINE qsortsp -SUBROUTINE qsorti(x, ind) + SUBROUTINE qsorti(x, ind) ! Code converted using TO_F90 by Alan Miller ! Date: 2002-12-18 Time: 11:55:47 -IMPLICIT NONE + IMPLICIT NONE -INTEGER, INTENT(IN) :: x(:) -INTEGER, INTENT(OUT) :: ind(:) -INTEGER :: n + INTEGER, INTENT(IN) :: x(:) + INTEGER, INTENT(OUT) :: ind(:) + INTEGER :: n !*************************************************************************** @@ -497,12 +497,12 @@ SUBROUTINE qsorti(x, ind) !********************************************************************* -INTEGER :: iu(21), il(21) -INTEGER :: m, i, j, k, l, ij, it, itt, indx -REAL :: r -INTEGER :: t + INTEGER :: iu(21), il(21) + INTEGER :: m, i, j, k, l, ij, it, itt, indx + REAL :: r + INTEGER :: t -n = size(x) + n = size(x) ! LOCAL PARAMETERS - @@ -517,453 +517,453 @@ SUBROUTINE qsorti(x, ind) ! R = PSEUDO RANDOM NUMBER FOR GENERATING IJ ! T = CENTRAL ELEMENT OF X -IF (n <= 0) RETURN + IF (n <= 0) RETURN ! INITIALIZE IND, M, I, J, AND R -DO i = 1, n - ind(i) = i -END DO -m = 1 -i = 1 -j = n -r = .375 + DO i = 1, n + ind(i) = i + END DO + m = 1 + i = 1 + j = n + r = .375 ! TOP OF LOOP -20 IF (i >= j) GO TO 70 -IF (r <= .5898437) THEN - r = r + .0390625 -ELSE - r = r - .21875 -END IF +20 IF (i >= j) GO TO 70 + IF (r <= .5898437) THEN + r = r + .0390625 + ELSE + r = r - .21875 + END IF ! INITIALIZE K -30 k = i +30 k = i ! SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T -ij = i + r*(j-i) -it = ind(ij) -t = x(it) + ij = i + r*(j-i) + it = ind(ij) + t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T -indx = ind(i) -IF (x(indx) > t) THEN - ind(ij) = indx - ind(i) = it - it = indx - t = x(it) -END IF + indx = ind(i) + IF (x(indx) > t) THEN + ind(ij) = indx + ind(i) = it + it = indx + t = x(it) + END IF ! INITIALIZE L -l = j + l = j ! IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, ! INTERCHANGE IT WITH T -indx = ind(j) -IF (x(indx) >= t) GO TO 50 -ind(ij) = indx -ind(j) = it -it = indx -t = x(it) + indx = ind(j) + IF (x(indx) >= t) GO TO 50 + ind(ij) = indx + ind(j) = it + it = indx + t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T -indx = ind(i) -IF (x(indx) <= t) GO TO 50 -ind(ij) = indx -ind(i) = it -it = indx -t = x(it) -GO TO 50 + indx = ind(i) + IF (x(indx) <= t) GO TO 50 + ind(ij) = indx + ind(i) = it + it = indx + t = x(it) + GO TO 50 ! INTERCHANGE ELEMENTS K AND L -40 itt = ind(l) -ind(l) = ind(k) -ind(k) = itt +40 itt = ind(l) + ind(l) = ind(k) + ind(k) = itt ! FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS ! NOT LARGER THAN T -50 l = l - 1 -indx = ind(l) -IF (x(indx) > t) GO TO 50 +50 l = l - 1 + indx = ind(l) + IF (x(indx) > t) GO TO 50 ! FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS NOT SMALLER THAN T -60 k = k + 1 -indx = ind(k) -IF (x(indx) < t) GO TO 60 +60 k = k + 1 + indx = ind(k) + IF (x(indx) < t) GO TO 60 ! IF K <= L, INTERCHANGE ELEMENTS K AND L -IF (k <= l) GO TO 40 + IF (k <= l) GO TO 40 ! SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE ! ARRAY YET TO BE SORTED -IF (l-i > j-k) THEN - il(m) = i - iu(m) = l - i = k - m = m + 1 - GO TO 80 -END IF + IF (l-i > j-k) THEN + il(m) = i + iu(m) = l + i = k + m = m + 1 + GO TO 80 + END IF -il(m) = k -iu(m) = j -j = l -m = m + 1 -GO TO 80 + il(m) = k + iu(m) = j + j = l + m = m + 1 + GO TO 80 ! BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY -70 m = m - 1 -IF (m == 0) RETURN -i = il(m) -j = iu(m) +70 m = m - 1 + IF (m == 0) RETURN + i = il(m) + j = iu(m) -80 IF (j-i >= 11) GO TO 30 -IF (i == 1) GO TO 20 -i = i - 1 +80 IF (j-i >= 11) GO TO 30 + IF (i == 1) GO TO 20 + i = i - 1 ! SORT ELEMENTS I+1,...,J. NOTE THAT 1 <= I < J AND J-I < 11. -90 i = i + 1 -IF (i == j) GO TO 70 -indx = ind(i+1) -t = x(indx) -it = indx -indx = ind(i) -IF (x(indx) <= t) GO TO 90 -k = i - -100 ind(k+1) = ind(k) -k = k - 1 -indx = ind(k) -IF (t < x(indx)) GO TO 100 - -ind(k+1) = it -GO TO 90 -END SUBROUTINE qsorti - - recursive subroutine sort_integer_array(integer_array, permutation) - !!< Sort integer_array along integer_array(:, 1), then integer_array(:, 2), etc. - - integer, dimension(:, :), intent(in) :: integer_array - integer, dimension(size(integer_array, 1)), intent(out) :: permutation - - integer :: end_index, i, j, start_index - integer, dimension(:), allocatable :: sub_permutation - logical :: do_sub_permute - integer, dimension(:, :), allocatable :: sorted_integer_array - - permutation = 0 - - if(size(integer_array, 2) == 1) then - ! Terminating case - - ! Sort along integer_array(:, 1) - call qsort(integer_array(:, 1), permutation) - else - ! Recursing case - - ! Sort along integer_array(:, 1) - call qsort(integer_array(:, 1), permutation) - ! Now we need to sort equal consecutive entries in - ! integer_array(permutation, 1) using integer_array(permutation, 2:) - start_index = -1 ! When this is > 0, it indicates we're iterating over - ! equal consecutive entries in - ! integer_array(permutation, 1) - do i = 2, size(integer_array, 1) + 1 - if(start_index < 0) then - ! We haven't yet found equal consecutive entries in - ! integer_array(permutation, 1) over which to sort - - if(i <= size(integer_array, 1)) then - ! We're not yet at the end of the array - if(abs(integer_array(permutation(i), 1) - integer_array(permutation(i - 1), 1)) == 0) then - ! We've found equal entries in integer_array(permutation, 1) - this - ! gives us a start index over which to sort - start_index = i - 1 +90 i = i + 1 + IF (i == j) GO TO 70 + indx = ind(i+1) + t = x(indx) + it = indx + indx = ind(i) + IF (x(indx) <= t) GO TO 90 + k = i + +100 ind(k+1) = ind(k) + k = k - 1 + indx = ind(k) + IF (t < x(indx)) GO TO 100 + + ind(k+1) = it + GO TO 90 + END SUBROUTINE qsorti + + recursive subroutine sort_integer_array(integer_array, permutation) + !!< Sort integer_array along integer_array(:, 1), then integer_array(:, 2), etc. + + integer, dimension(:, :), intent(in) :: integer_array + integer, dimension(size(integer_array, 1)), intent(out) :: permutation + + integer :: end_index, i, j, start_index + integer, dimension(:), allocatable :: sub_permutation + logical :: do_sub_permute + integer, dimension(:, :), allocatable :: sorted_integer_array + + permutation = 0 + + if(size(integer_array, 2) == 1) then + ! Terminating case + + ! Sort along integer_array(:, 1) + call qsort(integer_array(:, 1), permutation) + else + ! Recursing case + + ! Sort along integer_array(:, 1) + call qsort(integer_array(:, 1), permutation) + ! Now we need to sort equal consecutive entries in + ! integer_array(permutation, 1) using integer_array(permutation, 2:) + start_index = -1 ! When this is > 0, it indicates we're iterating over + ! equal consecutive entries in + ! integer_array(permutation, 1) + do i = 2, size(integer_array, 1) + 1 + if(start_index < 0) then + ! We haven't yet found equal consecutive entries in + ! integer_array(permutation, 1) over which to sort + + if(i <= size(integer_array, 1)) then + ! We're not yet at the end of the array + if(abs(integer_array(permutation(i), 1) - integer_array(permutation(i - 1), 1)) == 0) then + ! We've found equal entries in integer_array(permutation, 1) - this + ! gives us a start index over which to sort + start_index = i - 1 + end if + end if + else + ! We're already iterating over equal entries in + ! integer_array(permutation, 1) + + ! We've found an end index over which to sort if ... + ! ... we're at the end of the array ... + do_sub_permute = i == size(integer_array, 1) + 1 + if(.not. do_sub_permute) then + ! ... or we've hit non-equal consecutive entries + do_sub_permute = abs(integer_array(permutation(i), 1) - integer_array(permutation(i - 1), 1)) > 0 + end if + if(do_sub_permute) then + ! We've found an end index + end_index = i - 1 + + ! Sort using integer_array(permutation(start_index:end_index), 2:) + allocate(sorted_integer_array(end_index - start_index + 1, size(integer_array, 2) - 1)) + do j = 1, size(sorted_integer_array, 1) + assert(permutation(j + start_index - 1) >= 1) + assert(permutation(j + start_index - 1) <= size(integer_array, 1)) + sorted_integer_array(j, :) = integer_array(permutation(j + start_index - 1), 2:) + end do + allocate(sub_permutation(end_index - start_index + 1)) + call sort(sorted_integer_array, sub_permutation) + call apply_permutation(permutation(start_index:end_index), sub_permutation) + deallocate(sub_permutation) + deallocate(sorted_integer_array) + + ! Now we need to find a new start index + start_index = -1 + end if end if - end if - else - ! We're already iterating over equal entries in - ! integer_array(permutation, 1) - - ! We've found an end index over which to sort if ... - ! ... we're at the end of the array ... - do_sub_permute = i == size(integer_array, 1) + 1 - if(.not. do_sub_permute) then - ! ... or we've hit non-equal consecutive entries - do_sub_permute = abs(integer_array(permutation(i), 1) - integer_array(permutation(i - 1), 1)) > 0 - end if - if(do_sub_permute) then - ! We've found an end index - end_index = i - 1 - - ! Sort using integer_array(permutation(start_index:end_index), 2:) - allocate(sorted_integer_array(end_index - start_index + 1, size(integer_array, 2) - 1)) - do j = 1, size(sorted_integer_array, 1) - assert(permutation(j + start_index - 1) >= 1) - assert(permutation(j + start_index - 1) <= size(integer_array, 1)) - sorted_integer_array(j, :) = integer_array(permutation(j + start_index - 1), 2:) - end do - allocate(sub_permutation(end_index - start_index + 1)) - call sort(sorted_integer_array, sub_permutation) - call apply_permutation(permutation(start_index:end_index), sub_permutation) - deallocate(sub_permutation) - deallocate(sorted_integer_array) - - ! Now we need to find a new start index - start_index = -1 - end if - end if - end do - end if - - end subroutine sort_integer_array - - recursive subroutine sort_real_array(real_array, permutation) - !!< Sort real_array along real_array(:, 1), then real_array(:, 2), etc. - - real, dimension(:, :), intent(in) :: real_array - integer, dimension(size(real_array, 1)), intent(out) :: permutation - - integer :: end_index, i, j, start_index - integer, dimension(:), allocatable :: sub_permutation - logical :: do_sub_permute - real, dimension(:, :), allocatable :: sorted_real_array - - permutation = 0 - - if(size(real_array, 2) == 1) then - ! Terminating case - - ! Sort along real_array(:, 1) - call qsort(real_array(:, 1), permutation) - else - ! Recursing case - - ! Sort along real_array(:, 1) - call qsort(real_array(:, 1), permutation) - ! Now we need to sort equal consecutive entries in - ! real_array(permutation, 1) using real_array(permutation, 2:) - start_index = -1 ! When this is > 0, it indicates we're iterating over - ! equal consecutive entries in - ! real_array(permutation, 1) - do i = 2, size(real_array, 1) + 1 - if(start_index < 0) then - ! We haven't yet found equal consecutive entries in - ! real_array(permutation, 1) over which to sort - - if(i <= size(real_array, 1)) then - ! We're not yet at the end of the array - if(abs(real_array(permutation(i), 1) - real_array(permutation(i - 1), 1)) == 0.0) then - ! We've found equal entries in real_array(permutation, 1) - this - ! gives us a start index over which to sort - start_index = i - 1 + end do + end if + + end subroutine sort_integer_array + + recursive subroutine sort_real_array(real_array, permutation) + !!< Sort real_array along real_array(:, 1), then real_array(:, 2), etc. + + real, dimension(:, :), intent(in) :: real_array + integer, dimension(size(real_array, 1)), intent(out) :: permutation + + integer :: end_index, i, j, start_index + integer, dimension(:), allocatable :: sub_permutation + logical :: do_sub_permute + real, dimension(:, :), allocatable :: sorted_real_array + + permutation = 0 + + if(size(real_array, 2) == 1) then + ! Terminating case + + ! Sort along real_array(:, 1) + call qsort(real_array(:, 1), permutation) + else + ! Recursing case + + ! Sort along real_array(:, 1) + call qsort(real_array(:, 1), permutation) + ! Now we need to sort equal consecutive entries in + ! real_array(permutation, 1) using real_array(permutation, 2:) + start_index = -1 ! When this is > 0, it indicates we're iterating over + ! equal consecutive entries in + ! real_array(permutation, 1) + do i = 2, size(real_array, 1) + 1 + if(start_index < 0) then + ! We haven't yet found equal consecutive entries in + ! real_array(permutation, 1) over which to sort + + if(i <= size(real_array, 1)) then + ! We're not yet at the end of the array + if(abs(real_array(permutation(i), 1) - real_array(permutation(i - 1), 1)) == 0.0) then + ! We've found equal entries in real_array(permutation, 1) - this + ! gives us a start index over which to sort + start_index = i - 1 + end if + end if + else + ! We're already iterating over equal entries in + ! real_array(permutation, 1) + + ! We've found an end index over which to sort if ... + ! ... we're at the end of the array ... + do_sub_permute = i == size(real_array, 1) + 1 + if(.not. do_sub_permute) then + ! ... or we've hit non-equal consecutive entries + do_sub_permute = abs(real_array(permutation(i), 1) - real_array(permutation(i - 1), 1)) > 0.0 + end if + if(do_sub_permute) then + ! We've found an end index + end_index = i - 1 + + ! Sort using real_array(permutation(start_index:end_index), 2:) + allocate(sorted_real_array(end_index - start_index + 1, size(real_array, 2) - 1)) + do j = 1, size(sorted_real_array, 1) + assert(permutation(j + start_index - 1) >= 1 .and. permutation(j + start_index - 1) <= size(real_array, 1)) + sorted_real_array(j, :) = real_array(permutation(j + start_index - 1), 2:) + end do + allocate(sub_permutation(end_index - start_index + 1)) + call sort(sorted_real_array, sub_permutation) + call apply_permutation(permutation(start_index:end_index), sub_permutation) + deallocate(sub_permutation) + deallocate(sorted_real_array) + + ! Now we need to find a new start index + start_index = -1 + end if end if - end if - else - ! We're already iterating over equal entries in - ! real_array(permutation, 1) - - ! We've found an end index over which to sort if ... - ! ... we're at the end of the array ... - do_sub_permute = i == size(real_array, 1) + 1 - if(.not. do_sub_permute) then - ! ... or we've hit non-equal consecutive entries - do_sub_permute = abs(real_array(permutation(i), 1) - real_array(permutation(i - 1), 1)) > 0.0 - end if - if(do_sub_permute) then - ! We've found an end index - end_index = i - 1 - - ! Sort using real_array(permutation(start_index:end_index), 2:) - allocate(sorted_real_array(end_index - start_index + 1, size(real_array, 2) - 1)) - do j = 1, size(sorted_real_array, 1) - assert(permutation(j + start_index - 1) >= 1 .and. permutation(j + start_index - 1) <= size(real_array, 1)) - sorted_real_array(j, :) = real_array(permutation(j + start_index - 1), 2:) - end do - allocate(sub_permutation(end_index - start_index + 1)) - call sort(sorted_real_array, sub_permutation) - call apply_permutation(permutation(start_index:end_index), sub_permutation) - deallocate(sub_permutation) - deallocate(sorted_real_array) - - ! Now we need to find a new start index - start_index = -1 - end if - end if - end do - end if + end do + end if - end subroutine sort_real_array + end subroutine sort_real_array - function count_unique(int_array) result(unique) - !!< Count the unique entries in the supplied array of integers + function count_unique(int_array) result(unique) + !!< Count the unique entries in the supplied array of integers - integer, dimension(:), intent(in) :: int_array + integer, dimension(:), intent(in) :: int_array - integer :: unique + integer :: unique - integer :: i - integer, dimension(size(int_array)) :: permutation + integer :: i + integer, dimension(size(int_array)) :: permutation - call qsort(int_array, permutation) + call qsort(int_array, permutation) - unique = 0 - if(size(int_array) > 0) then - unique = unique + 1 - end if - do i = 2, size(int_array) - if(int_array(permutation(i)) == int_array(permutation(i - 1))) cycle - unique = unique + 1 - end do + unique = 0 + if(size(int_array) > 0) then + unique = unique + 1 + end if + do i = 2, size(int_array) + if(int_array(permutation(i)) == int_array(permutation(i - 1))) cycle + unique = unique + 1 + end do - end function count_unique + end function count_unique - pure function inverse_permutation(permutation) - !!< Return the inverse of the supplied permutation + pure function inverse_permutation(permutation) + !!< Return the inverse of the supplied permutation - integer, dimension(:), intent(in) :: permutation + integer, dimension(:), intent(in) :: permutation - integer, dimension(size(permutation)) :: inverse_permutation + integer, dimension(size(permutation)) :: inverse_permutation - integer :: i + integer :: i - do i = 1, size(permutation) - inverse_permutation(permutation(i)) = i - end do + do i = 1, size(permutation) + inverse_permutation(permutation(i)) = i + end do - end function inverse_permutation + end function inverse_permutation - subroutine apply_permutation_integer_array(permutation, applied_permutation) - !!< Apply the given applied_permutation to the array permutation - !!< Use this instead of permutation = permutation(applied_permutation), as - !!< the inline form can cause intermittent errors on some compilers. + subroutine apply_permutation_integer_array(permutation, applied_permutation) + !!< Apply the given applied_permutation to the array permutation + !!< Use this instead of permutation = permutation(applied_permutation), as + !!< the inline form can cause intermittent errors on some compilers. - integer, dimension(:, :), intent(inout) :: permutation - integer, dimension(size(permutation, 1)), intent(in) :: applied_permutation + integer, dimension(:, :), intent(inout) :: permutation + integer, dimension(size(permutation, 1)), intent(in) :: applied_permutation - integer :: i - integer, dimension(size(permutation, 1), size(permutation, 2)) :: temp_permutation + integer :: i + integer, dimension(size(permutation, 1), size(permutation, 2)) :: temp_permutation - temp_permutation = permutation + temp_permutation = permutation - do i = 1, size(applied_permutation) - assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) - permutation(i, :) = temp_permutation(applied_permutation(i), :) - end do + do i = 1, size(applied_permutation) + assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) + permutation(i, :) = temp_permutation(applied_permutation(i), :) + end do - end subroutine apply_permutation_integer_array + end subroutine apply_permutation_integer_array - subroutine apply_permutation_real_array(permutation, applied_permutation) - !!< Apply the given applied_permutation to the array permutation - !!< Use this instead of permutation = permutation(applied_permutation), as - !!< the inline form can cause intermittent errors on some compilers. + subroutine apply_permutation_real_array(permutation, applied_permutation) + !!< Apply the given applied_permutation to the array permutation + !!< Use this instead of permutation = permutation(applied_permutation), as + !!< the inline form can cause intermittent errors on some compilers. - real, dimension(:, :), intent(inout) :: permutation - integer, dimension(size(permutation, 1)), intent(in) :: applied_permutation + real, dimension(:, :), intent(inout) :: permutation + integer, dimension(size(permutation, 1)), intent(in) :: applied_permutation - integer :: i - real, dimension(size(permutation, 1), size(permutation, 2)) :: temp_permutation + integer :: i + real, dimension(size(permutation, 1), size(permutation, 2)) :: temp_permutation - temp_permutation = permutation + temp_permutation = permutation - do i = 1, size(applied_permutation) - assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) - permutation(i, :) = temp_permutation(applied_permutation(i), :) - end do + do i = 1, size(applied_permutation) + assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) + permutation(i, :) = temp_permutation(applied_permutation(i), :) + end do - end subroutine apply_permutation_real_array + end subroutine apply_permutation_real_array - subroutine apply_permutation_integer(permutation, applied_permutation) - !!< Apply the given applied_permutation to the array permutation - !!< Use this instead of permutation = permutation(applied_permutation), as - !!< the inline form can cause intermittent errors on some compilers. + subroutine apply_permutation_integer(permutation, applied_permutation) + !!< Apply the given applied_permutation to the array permutation + !!< Use this instead of permutation = permutation(applied_permutation), as + !!< the inline form can cause intermittent errors on some compilers. - integer, dimension(:), intent(inout) :: permutation - integer, dimension(size(permutation)), intent(in) :: applied_permutation + integer, dimension(:), intent(inout) :: permutation + integer, dimension(size(permutation)), intent(in) :: applied_permutation - integer :: i - integer, dimension(size(permutation)) :: temp_permutation + integer :: i + integer, dimension(size(permutation)) :: temp_permutation - temp_permutation = permutation + temp_permutation = permutation - do i = 1, size(applied_permutation) - assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) - permutation(i) = temp_permutation(applied_permutation(i)) - end do + do i = 1, size(applied_permutation) + assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) + permutation(i) = temp_permutation(applied_permutation(i)) + end do - end subroutine apply_permutation_integer + end subroutine apply_permutation_integer - subroutine apply_permutation_real(permutation, applied_permutation) - !!< Apply the given applied_permutation to the array permutation - !!< Use this instead of permutation = permutation(applied_permutation), as - !!< the inline form can cause intermittent errors on some compilers. + subroutine apply_permutation_real(permutation, applied_permutation) + !!< Apply the given applied_permutation to the array permutation + !!< Use this instead of permutation = permutation(applied_permutation), as + !!< the inline form can cause intermittent errors on some compilers. - real, dimension(:), intent(inout) :: permutation - integer, dimension(size(permutation)), intent(in) :: applied_permutation + real, dimension(:), intent(inout) :: permutation + integer, dimension(size(permutation)), intent(in) :: applied_permutation - integer :: i - real, dimension(size(permutation)) :: temp_permutation + integer :: i + real, dimension(size(permutation)) :: temp_permutation - temp_permutation = permutation + temp_permutation = permutation - do i = 1, size(applied_permutation) - assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) - permutation(i) = temp_permutation(applied_permutation(i)) - end do + do i = 1, size(applied_permutation) + assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) + permutation(i) = temp_permutation(applied_permutation(i)) + end do - end subroutine apply_permutation_real + end subroutine apply_permutation_real - subroutine apply_reverse_permutation_real(permutation, applied_permutation) - !!< Apply the reverse of the given applied_permutation to the array permutation + subroutine apply_reverse_permutation_real(permutation, applied_permutation) + !!< Apply the reverse of the given applied_permutation to the array permutation - real, dimension(:), intent(inout) :: permutation - integer, dimension(size(permutation)), intent(in) :: applied_permutation + real, dimension(:), intent(inout) :: permutation + integer, dimension(size(permutation)), intent(in) :: applied_permutation - integer :: i, length - real, dimension(size(permutation)) :: temp_permutation + integer :: i, length + real, dimension(size(permutation)) :: temp_permutation - temp_permutation = permutation + temp_permutation = permutation - length = size(applied_permutation)+1 - do i = 1, size(applied_permutation) - assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) - permutation(i) = temp_permutation(applied_permutation(length-i)) - end do + length = size(applied_permutation)+1 + do i = 1, size(applied_permutation) + assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) + permutation(i) = temp_permutation(applied_permutation(length-i)) + end do - end subroutine apply_reverse_permutation_real + end subroutine apply_reverse_permutation_real - subroutine apply_reverse_permutation_integer(permutation, applied_permutation) - !!< Apply the reverse of the given applied_permutation to the array permutation + subroutine apply_reverse_permutation_integer(permutation, applied_permutation) + !!< Apply the reverse of the given applied_permutation to the array permutation - integer, dimension(:), intent(inout) :: permutation - integer, dimension(size(permutation)), intent(in) :: applied_permutation + integer, dimension(:), intent(inout) :: permutation + integer, dimension(size(permutation)), intent(in) :: applied_permutation - integer :: i, length - integer, dimension(size(permutation)) :: temp_permutation + integer :: i, length + integer, dimension(size(permutation)) :: temp_permutation - temp_permutation = permutation + temp_permutation = permutation - length = size(applied_permutation)+1 - do i = 1, size(applied_permutation) - assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) - permutation(i) = temp_permutation(applied_permutation(length-i)) - end do + length = size(applied_permutation)+1 + do i = 1, size(applied_permutation) + assert(applied_permutation(i) >= 1 .and. applied_permutation(i) <= size(permutation)) + permutation(i) = temp_permutation(applied_permutation(length-i)) + end do - end subroutine apply_reverse_permutation_integer + end subroutine apply_reverse_permutation_integer end module quicksort diff --git a/femtools/signal_handlers.F90 b/femtools/signal_handlers.F90 index 580e6ab642..0cdbe57115 100644 --- a/femtools/signal_handlers.F90 +++ b/femtools/signal_handlers.F90 @@ -30,57 +30,57 @@ #include "fdebug.h" function handle_sighup(signal) - use signal_vars + use signal_vars - implicit none - integer :: handle_sighup - integer, intent(in) :: signal + implicit none + integer :: handle_sighup + integer, intent(in) :: signal - sig_hup=.true. + sig_hup=.true. - handle_sighup=0 + handle_sighup=0 end function handle_sighup function handle_sigint(signal) - use signal_vars + use signal_vars - implicit none - integer :: handle_sigint - integer, intent(in) :: signal + implicit none + integer :: handle_sigint + integer, intent(in) :: signal - sig_int=.true. + sig_int=.true. - handle_sigint=0 + handle_sigint=0 end function handle_sigint function handle_sigterm(signal) - use signal_vars + use signal_vars - implicit none - integer :: handle_sigterm - integer, intent(in) :: signal + implicit none + integer :: handle_sigterm + integer, intent(in) :: signal - sig_int=.true. + sig_int=.true. - handle_sigterm=0 + handle_sigterm=0 end function handle_sigterm function handle_sigfpe(signal) - use FLDebug - use signal_vars + use FLDebug + use signal_vars - implicit none - integer :: handle_sigfpe - integer, intent(in) :: signal + implicit none + integer :: handle_sigfpe + integer, intent(in) :: signal - handle_sigfpe = 0 + handle_sigfpe = 0 - FLAbort("Floating point exception") + FLAbort("Floating point exception") - handle_sigfpe=0 + handle_sigfpe=0 end function handle_sigfpe diff --git a/femtools/testpolynomials.F90 b/femtools/testpolynomials.F90 index cff7b0bc06..5f1bbde727 100644 --- a/femtools/testpolynomials.F90 +++ b/femtools/testpolynomials.F90 @@ -26,19 +26,19 @@ ! USA program testpolynomials - use polynomials - ! Implicit none. + use polynomials + ! Implicit none. - type(polynomial), dimension(10) :: poly + type(polynomial), dimension(10) :: poly - poly(1)=(/1.0, 1.0/) - poly(2)=(/2.0, 1.0/) - poly(3)=(/1.0, 1.0, 1.0/) + poly(1)=(/1.0, 1.0/) + poly(2)=(/2.0, 1.0/) + poly(3)=(/1.0, 1.0, 1.0/) - print '(100f10.3)', poly(1)*poly(1)*poly(1)+poly(2) - print '(100f10.3)', 2.0*poly(2) - print '(100f10.3)', ddx(poly(1)*poly(1)*poly(1)) + print '(100f10.3)', poly(1)*poly(1)*poly(1)+poly(2) + print '(100f10.3)', 2.0*poly(2) + print '(100f10.3)', ddx(poly(1)*poly(1)*poly(1)) end program testpolynomials diff --git a/femtools/tests/compare_intersection_finder.F90 b/femtools/tests/compare_intersection_finder.F90 index 0ddde9c2cd..e0f3e37bfc 100644 --- a/femtools/tests/compare_intersection_finder.F90 +++ b/femtools/tests/compare_intersection_finder.F90 @@ -1,106 +1,106 @@ #include "fdebug.h" subroutine compare_intersection_finder - !!< Compares intersection finder algorithms. For intersection finding paper - !!< results. + !!< Compares intersection finder algorithms. For intersection finding paper + !!< results. - use fields - use global_parameters, only : debug_error_unit - use intersection_finder_module - use linked_lists - use mesh_files + use fields + use global_parameters, only : debug_error_unit + use intersection_finder_module + use linked_lists + use mesh_files - implicit none + implicit none - character(len = 255) :: base1, base2 - integer :: i, intersections, j, k - real :: end_cpu_time, start_cpu_time - type(ilist), dimension(:), allocatable :: map_ab, map_ab_af - type(vector_field) :: mesh_field_a, mesh_field_b + character(len = 255) :: base1, base2 + integer :: i, intersections, j, k + real :: end_cpu_time, start_cpu_time + type(ilist), dimension(:), allocatable :: map_ab, map_ab_af + type(vector_field) :: mesh_field_a, mesh_field_b - do i = 8, 1, -1 - base1 = int2str(i) // ".1" - base2 = int2str(i) // ".2" + do i = 8, 1, -1 + base1 = int2str(i) // ".1" + base2 = int2str(i) // ".2" - ewrite(0, *), "################" - ewrite(0, *), "### New base ###" - ewrite(0, *), "################" - ewrite(0, *), "Base1 = " // trim(base1) - ewrite(0, *), "Base2 = " // trim(base2) + ewrite(0, *), "################" + ewrite(0, *), "### New base ###" + ewrite(0, *), "################" + ewrite(0, *), "Base1 = " // trim(base1) + ewrite(0, *), "Base2 = " // trim(base2) - ! Load in the mesh fields - mesh_field_a = read_mesh_files("data/" // trim(base1), quad_degree = 1, format="gmsh") - mesh_field_b = read_mesh_files("data/" // trim(base2), quad_degree = 1, format="gmsh") + ! Load in the mesh fields + mesh_field_a = read_mesh_files("data/" // trim(base1), quad_degree = 1, format="gmsh") + mesh_field_b = read_mesh_files("data/" // trim(base2), quad_degree = 1, format="gmsh") - allocate(map_ab_af(ele_count(mesh_field_a))) - allocate(map_ab(ele_count(mesh_field_a))) + allocate(map_ab_af(ele_count(mesh_field_a))) + allocate(map_ab(ele_count(mesh_field_a))) ! do j = 1, 3 - do j = 1, 1 + do j = 1, 1 - ! Advancing front - call reset_intersection_tests_counter() + ! Advancing front + call reset_intersection_tests_counter() ! call cpu_time(start_cpu_time) - map_ab_af = advancing_front_intersection_finder(mesh_field_a, mesh_field_b) + map_ab_af = advancing_front_intersection_finder(mesh_field_a, mesh_field_b) ! call cpu_time(end_cpu_time) ! ewrite(0, *), "Advancing front, loop " // int2str(j) // ", CPU time: ", end_cpu_time - start_cpu_time - intersections = 0 - do k = 1, size(map_ab_af) - intersections = intersections + map_ab_af(k)%length - end do - ewrite(0, *) "Advancing front, loop " // int2str(j) // ", intersections: " // int2str(intersections) - ewrite(0, *) "Advancing front, loop " // int2str(j) // ", intersection tests: " // int2str(intersection_tests()) + intersections = 0 + do k = 1, size(map_ab_af) + intersections = intersections + map_ab_af(k)%length + end do + ewrite(0, *) "Advancing front, loop " // int2str(j) // ", intersections: " // int2str(intersections) + ewrite(0, *) "Advancing front, loop " // int2str(j) // ", intersection tests: " // int2str(intersection_tests()) - call flush(debug_error_unit) + call flush(debug_error_unit) ! ! Rtree ! call cpu_time(start_cpu_time) - map_ab = rtree_intersection_finder(mesh_field_a, mesh_field_b) + map_ab = rtree_intersection_finder(mesh_field_a, mesh_field_b) ! call cpu_time(end_cpu_time) ! ewrite(0, *), "Rtree, loop " // int2str(j) // ", CPU time: ", end_cpu_time - start_cpu_time - intersections = 0 - do k = 1, size(map_ab) - intersections = intersections + map_ab(k)%length - end do - ewrite(0, *) "Rtree, loop " // int2str(j) // ", intersections: " // int2str(intersections) - if(j == 1) then - call verify_map(mesh_field_a, mesh_field_b, map_ab_af, map_ab) - ewrite(0, *), "Advancing front map verified against rtree" - end if - call flush_lists(map_ab) - - call flush(debug_error_unit) + intersections = 0 + do k = 1, size(map_ab) + intersections = intersections + map_ab(k)%length + end do + ewrite(0, *) "Rtree, loop " // int2str(j) // ", intersections: " // int2str(intersections) + if(j == 1) then + call verify_map(mesh_field_a, mesh_field_b, map_ab_af, map_ab) + ewrite(0, *), "Advancing front map verified against rtree" + end if + call flush_lists(map_ab) + + call flush(debug_error_unit) ! ! Brute force - call reset_intersection_tests_counter() + call reset_intersection_tests_counter() ! call cpu_time(start_cpu_time) - map_ab = brute_force_intersection_finder(mesh_field_a, mesh_field_b) + map_ab = brute_force_intersection_finder(mesh_field_a, mesh_field_b) ! call cpu_time(end_cpu_time) - ewrite(0, *), "Brute force, loop " // int2str(j) // ", CPU time: ", end_cpu_time - start_cpu_time - intersections = 0 - do k = 1, size(map_ab) - intersections = intersections + map_ab(k)%length + ewrite(0, *), "Brute force, loop " // int2str(j) // ", CPU time: ", end_cpu_time - start_cpu_time + intersections = 0 + do k = 1, size(map_ab) + intersections = intersections + map_ab(k)%length + end do + if(j == 1) then + call verify_map(mesh_field_a, mesh_field_b, map_ab_af, map_ab) + ewrite(0, *), "Advancing front map verified against brute force" + end if + ewrite(0, *) "Brute force, loop " // int2str(j) // ", intersections: " // int2str(intersections) + ewrite(0, *) "Brute force, loop " // int2str(j) // ", intersection tests: " // int2str(intersection_tests()) + call flush_lists(map_ab) + + call flush(debug_error_unit) + + call flush_lists(map_ab_af) end do - if(j == 1) then - call verify_map(mesh_field_a, mesh_field_b, map_ab_af, map_ab) - ewrite(0, *), "Advancing front map verified against brute force" - end if - ewrite(0, *) "Brute force, loop " // int2str(j) // ", intersections: " // int2str(intersections) - ewrite(0, *) "Brute force, loop " // int2str(j) // ", intersection tests: " // int2str(intersection_tests()) - call flush_lists(map_ab) - - call flush(debug_error_unit) - - call flush_lists(map_ab_af) - end do - ! Deallocate - call deallocate(mesh_field_a) - call deallocate(mesh_field_b) + ! Deallocate + call deallocate(mesh_field_a) + call deallocate(mesh_field_b) - deallocate(map_ab_af) - deallocate(map_ab) + deallocate(map_ab_af) + deallocate(map_ab) - end do + end do end subroutine compare_intersection_finder diff --git a/femtools/tests/test_1d.F90 b/femtools/tests/test_1d.F90 index 30bf3aedc0..f507ee4d17 100644 --- a/femtools/tests/test_1d.F90 +++ b/femtools/tests/test_1d.F90 @@ -26,96 +26,96 @@ ! USA subroutine test_1d - !!< Test that basic integration and differentiation of 1d elements works. - use shape_functions - use fetools - use fields - use mesh_files - use vector_tools - use unittest_tools - implicit none + !!< Test that basic integration and differentiation of 1d elements works. + use shape_functions + use fetools + use fields + use mesh_files + use vector_tools + use unittest_tools + implicit none - logical :: fail - real :: integral + logical :: fail + real :: integral - type(vector_field) :: X - type(scalar_field) :: T, dT - interface - function func_1d(X) - real :: func_1d - real, dimension(:), intent(in) :: X - end function func_1d - end interface + type(vector_field) :: X + type(scalar_field) :: T, dT + interface + function func_1d(X) + real :: func_1d + real, dimension(:), intent(in) :: X + end function func_1d + end interface - integer :: ele - real, dimension(:,:), allocatable :: mass - real, dimension(:), allocatable :: detwei - integer, dimension(:), pointer :: T_ele - real, dimension(:,:,:), allocatable :: dT_ele - type(element_type), pointer :: T_shape + integer :: ele + real, dimension(:,:), allocatable :: mass + real, dimension(:), allocatable :: detwei + integer, dimension(:), pointer :: T_ele + real, dimension(:,:,:), allocatable :: dT_ele + type(element_type), pointer :: T_shape - X=read_mesh_files("data/interval", quad_degree=4, format="gmsh") + X=read_mesh_files("data/interval", quad_degree=4, format="gmsh") - call allocate(T, X%mesh, "tracer") + call allocate(T, X%mesh, "tracer") - call set_from_function(T, func_1d, X) + call set_from_function(T, func_1d, X) - ! Test 1 Integrate T over the interval. + ! Test 1 Integrate T over the interval. - integral=field_integral(T,X) + integral=field_integral(T,X) - fail=integral/=0.5 + fail=integral/=0.5 - call report_test("[test_1d Integral]", fail, .false., "int_0^1 x dx should& - & be 0.5.") + call report_test("[test_1d Integral]", fail, .false., "int_0^1 x dx should& + & be 0.5.") - ! Test 2 Calculate the derivative of T over the interval. + ! Test 2 Calculate the derivative of T over the interval. - allocate(mass(node_count(T),node_count(T))) - allocate(detwei(ele_ngi(T,1))) - allocate(dT_ele(ele_loc(T,1), ele_ngi(T,1), X%dim)) + allocate(mass(node_count(T),node_count(T))) + allocate(detwei(ele_ngi(T,1))) + allocate(dT_ele(ele_loc(T,1), ele_ngi(T,1), X%dim)) - dT=clone(T) + dT=clone(T) - call zero(dT) + call zero(dT) - mass=0.0 + mass=0.0 - do ele=1,element_count(T) + do ele=1,element_count(T) - T_ele=>ele_nodes(T,ele) - T_shape=>ele_shape(T,ele) + T_ele=>ele_nodes(T,ele) + T_shape=>ele_shape(T,ele) - call transform_to_physical(X, ele, T_shape, & - dm_t=dT_ele, detwei=detwei) + call transform_to_physical(X, ele, T_shape, & + dm_t=dT_ele, detwei=detwei) - mass(T_ele, T_ele)=mass(T_ele, T_ele) & - + shape_shape(T_shape, T_shape, detwei) + mass(T_ele, T_ele)=mass(T_ele, T_ele) & + + shape_shape(T_shape, T_shape, detwei) - call addto(dT, T_ele, matmul(sum(shape_dshape(T_shape, dT_ele, detwei),1),& - & ele_val(T, ele))) + call addto(dT, T_ele, matmul(sum(shape_dshape(T_shape, dT_ele, detwei),1),& + & ele_val(T, ele))) - end do + end do - call invert(mass) + call invert(mass) - dT%val=matmul(mass,dT%val) + dT%val=matmul(mass,dT%val) - fail=any(abs(dT%val-1.0)>1e-14) - call report_test("[test_1d Derivative]", fail, .false., "dx/dx should& - & be 1.0.") + fail=any(abs(dT%val-1.0)>1e-14) + call report_test("[test_1d Derivative]", fail, .false., "dx/dx should& + & be 1.0.") - deallocate(mass) - deallocate(detwei) - deallocate(dT_ele) + deallocate(mass) + deallocate(detwei) + deallocate(dT_ele) end subroutine test_1d function func_1d(x) - real :: func_1d - real, dimension(:), intent(in) :: x + real :: func_1d + real, dimension(:), intent(in) :: x - func_1d=X(1) + func_1d=X(1) end function func_1d diff --git a/femtools/tests/test_1d_pickers.F90 b/femtools/tests/test_1d_pickers.F90 index f99f63993b..d58f441633 100644 --- a/femtools/tests/test_1d_pickers.F90 +++ b/femtools/tests/test_1d_pickers.F90 @@ -29,32 +29,32 @@ subroutine test_1d_pickers - use fields - use fldebug - use pickers - use mesh_files - use unittest_tools + use fields + use fldebug + use pickers + use mesh_files + use unittest_tools - implicit none + implicit none - integer :: ele - type(vector_field) :: positions + integer :: ele + type(vector_field) :: positions - positions = read_mesh_files("data/interval", quad_degree = 1, format="gmsh") + positions = read_mesh_files("data/interval", quad_degree = 1, format="gmsh") - call report_test("[Picker pointer allocated]", .not. associated(positions%picker), .false., "Picker pointer not allocated") - call report_test("[No picker attached]", associated(positions%picker%ptr), .false., "Picker already attached") + call report_test("[Picker pointer allocated]", .not. associated(positions%picker), .false., "Picker pointer not allocated") + call report_test("[No picker attached]", associated(positions%picker%ptr), .false., "Picker already attached") - call picker_inquire(positions, (/-1.0 /), ele) - call report_test("[Point not contained]", ele > 0, .false., "Incorrectly reported point contained in mesh") + call picker_inquire(positions, (/-1.0 /), ele) + call report_test("[Point not contained]", ele > 0, .false., "Incorrectly reported point contained in mesh") - call report_test("[Picker cached]", .not. associated(positions%picker%ptr), .false., "Picker not cached") + call report_test("[Picker cached]", .not. associated(positions%picker%ptr), .false., "Picker not cached") - call picker_inquire(positions, (/ 0.25 /), ele) - call report_test("[Point contained]", ele /= 3, .false., "Reported incorrect containing element") + call picker_inquire(positions, (/ 0.25 /), ele) + call report_test("[Point contained]", ele /= 3, .false., "Reported incorrect containing element") - call deallocate(positions) + call deallocate(positions) - call report_test_no_references() + call report_test_no_references() end subroutine test_1d_pickers diff --git a/femtools/tests/test_adaptive_interpolation_pass.F90 b/femtools/tests/test_adaptive_interpolation_pass.F90 index 190f2cbb6d..7a6a804e6e 100644 --- a/femtools/tests/test_adaptive_interpolation_pass.F90 +++ b/femtools/tests/test_adaptive_interpolation_pass.F90 @@ -1,52 +1,52 @@ subroutine test_adaptive_interpolation_pass - use quadrature - use fields - use adaptive_interpolation_module - use mesh_files - use unittest_tools - implicit none + use quadrature + use fields + use adaptive_interpolation_module + use mesh_files + use unittest_tools + implicit none - type(vector_field) :: positionsA, positionsB - type(mesh_type) :: dg_mesh - type(scalar_field) :: in_field, out_field - real :: achieved_error - integer :: no_refinements - logical :: fail - real :: error_tolerance + type(vector_field) :: positionsA, positionsB + type(mesh_type) :: dg_mesh + type(scalar_field) :: in_field, out_field + real :: achieved_error + integer :: no_refinements + logical :: fail + real :: error_tolerance - interface - function field_func(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface + interface + function field_func(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface - positionsA = read_mesh_files("data/pslgA", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") - positionsB = read_mesh_files("data/pslgA", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") + positionsA = read_mesh_files("data/pslgA", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") + positionsB = read_mesh_files("data/pslgA", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") - call allocate(in_field, positionsA%mesh, "InField") - call set_from_function(in_field, field_func, positionsA) + call allocate(in_field, positionsA%mesh, "InField") + call set_from_function(in_field, field_func, positionsA) - dg_mesh = make_mesh(positionsB%mesh, positionsB%mesh%shape, -1, "DgMesh") - call allocate(out_field, dg_mesh, "OutField") - call set(out_field, -10000.0) + dg_mesh = make_mesh(positionsB%mesh, positionsB%mesh%shape, -1, "DgMesh") + call allocate(out_field, dg_mesh, "OutField") + call set(out_field, -10000.0) - error_tolerance = 1.0e-14 + error_tolerance = 1.0e-14 - call adaptive_interpolation(in_field, positionsA, out_field, positionsB, error_tolerance, achieved_error, no_refinements) + call adaptive_interpolation(in_field, positionsA, out_field, positionsB, error_tolerance, achieved_error, no_refinements) - fail = (achieved_error > error_tolerance) - call report_test("[adaptive interpolation pass]", fail, .false., "Achieved error must be less than tolerance") + fail = (achieved_error > error_tolerance) + call report_test("[adaptive interpolation pass]", fail, .false., "Achieved error must be less than tolerance") - fail = (no_refinements /= 0) - call report_test("[adaptive interpolation pass]", fail, .false., "And you shouldn't need to refine to get it!") + fail = (no_refinements /= 0) + call report_test("[adaptive interpolation pass]", fail, .false., "And you shouldn't need to refine to get it!") end subroutine test_adaptive_interpolation_pass function field_func(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1) + pos(2) + f = pos(1) + pos(2) end function field_func diff --git a/femtools/tests/test_adaptive_interpolation_refine.F90 b/femtools/tests/test_adaptive_interpolation_refine.F90 index 60ad64d662..f472d8c431 100644 --- a/femtools/tests/test_adaptive_interpolation_refine.F90 +++ b/femtools/tests/test_adaptive_interpolation_refine.F90 @@ -1,63 +1,63 @@ subroutine test_adaptive_interpolation_refine - use quadrature - use fields - use adaptive_interpolation_module - use mesh_files - use unittest_tools - use vtk_interfaces - implicit none + use quadrature + use fields + use adaptive_interpolation_module + use mesh_files + use unittest_tools + use vtk_interfaces + implicit none - type(vector_field) :: positionsA, positionsB - type(mesh_type) :: dg_mesh, quadratic_mesh - type(scalar_field) :: in_field, out_field - type(element_type) :: quadratic_shape - real :: achieved_error - integer :: no_refinements - logical :: fail - real :: error_tolerance + type(vector_field) :: positionsA, positionsB + type(mesh_type) :: dg_mesh, quadratic_mesh + type(scalar_field) :: in_field, out_field + type(element_type) :: quadratic_shape + real :: achieved_error + integer :: no_refinements + logical :: fail + real :: error_tolerance - interface - function field_func(pos) - real, dimension(:) :: pos - real :: solution - end function - end interface + interface + function field_func(pos) + real, dimension(:) :: pos + real :: solution + end function + end interface - call set_global_debug_level(3) + call set_global_debug_level(3) - positionsA = read_mesh_files("data/laplacian_grid.2", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") - positionsB = read_mesh_files("data/laplacian_grid.3", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") + positionsA = read_mesh_files("data/laplacian_grid.2", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") + positionsB = read_mesh_files("data/laplacian_grid.3", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") - quadratic_shape = make_element_shape(vertices = ele_loc(positionsA, 1), dim =positionsA%dim, degree=2, quad=positionsA%mesh%shape%quadrature) - quadratic_mesh = make_mesh(positionsA%mesh, quadratic_shape, -1, "QuadraticDgMesh") - call allocate(in_field, quadratic_mesh, "InField") - call set_from_function(in_field, field_func, positionsA) + quadratic_shape = make_element_shape(vertices = ele_loc(positionsA, 1), dim =positionsA%dim, degree=2, quad=positionsA%mesh%shape%quadrature) + quadratic_mesh = make_mesh(positionsA%mesh, quadratic_shape, -1, "QuadraticDgMesh") + call allocate(in_field, quadratic_mesh, "InField") + call set_from_function(in_field, field_func, positionsA) - dg_mesh = make_mesh(positionsB%mesh, positionsB%mesh%shape, -1, "DgMesh") - call allocate(out_field, dg_mesh, "OutField") - call set(out_field, -10000.0) + dg_mesh = make_mesh(positionsB%mesh, positionsB%mesh%shape, -1, "DgMesh") + call allocate(out_field, dg_mesh, "OutField") + call set(out_field, -10000.0) - error_tolerance = 5.0e-12 + error_tolerance = 5.0e-12 - call adaptive_interpolation(in_field, positionsA, out_field, positionsB, error_tolerance, achieved_error, no_refinements) + call adaptive_interpolation(in_field, positionsA, out_field, positionsB, error_tolerance, achieved_error, no_refinements) - call vtk_write_fields("data/adaptive_interpolation_p", position=positionsB, model=out_field%mesh, write_region_ids=.true.) + call vtk_write_fields("data/adaptive_interpolation_p", position=positionsB, model=out_field%mesh, write_region_ids=.true.) - write(0,*) "achieved_error: ", achieved_error - write(0,*) "error_tolerance: ", error_tolerance + write(0,*) "achieved_error: ", achieved_error + write(0,*) "error_tolerance: ", error_tolerance - fail = (achieved_error > error_tolerance) - call report_test("[adaptive interpolation refine]", fail, .false., "Achieved error must be less than tolerance") + fail = (achieved_error > error_tolerance) + call report_test("[adaptive interpolation refine]", fail, .false., "Achieved error must be less than tolerance") - fail = (no_refinements /= 3) - call report_test("[adaptive interpolation refine]", fail, .false., "And you shouldn't need to refine to get it!") + fail = (no_refinements /= 3) + call report_test("[adaptive interpolation refine]", fail, .false., "And you shouldn't need to refine to get it!") end subroutine test_adaptive_interpolation_refine function field_func(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1)**3 + 3*pos(2)**2 + f = pos(1)**3 + 3*pos(2)**2 end function field_func diff --git a/femtools/tests/test_adaptive_interpolation_supermesh.F90 b/femtools/tests/test_adaptive_interpolation_supermesh.F90 index 754f813ada..1233c8804f 100644 --- a/femtools/tests/test_adaptive_interpolation_supermesh.F90 +++ b/femtools/tests/test_adaptive_interpolation_supermesh.F90 @@ -1,62 +1,62 @@ subroutine test_adaptive_interpolation_supermesh - use quadrature - use elements - use fields - use adaptive_interpolation_module - use mesh_files - use unittest_tools - implicit none - - type(vector_field) :: positionsA, positionsB - type(mesh_type) :: dg_mesh, quadratic_mesh - type(scalar_field) :: in_field, out_field - type(element_type) :: quadratic_shape - real :: achieved_error - integer :: no_refinements - logical :: fail - real :: error_tolerance - - interface - function field_func(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - - subroutine set_global_debug_level(level) - integer :: level - end subroutine set_global_debug_level - end interface - - call set_global_debug_level(3) - - positionsA = read_mesh_files("data/pslgA", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") - positionsB = read_mesh_files("data/pslgB", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") - - quadratic_shape = make_element_shape(vertices = ele_loc(positionsA, 1), dim =positionsA%dim, degree=2, quad=positionsA%mesh%shape%quadrature) - quadratic_mesh = make_mesh(positionsB%mesh, quadratic_shape, -1, "QuadraticDgMesh") - call allocate(in_field, quadratic_mesh, "InField") - call set_from_function(in_field, field_func, positionsA) - - dg_mesh = make_mesh(positionsB%mesh, positionsB%mesh%shape, -1, "DgMesh") - call allocate(out_field, dg_mesh, "OutField") - call set(out_field, -10000.0) - - error_tolerance = 1.3e-8 - - call adaptive_interpolation(in_field, positionsA, out_field, positionsB, error_tolerance, achieved_error, no_refinements) - - write(0,*) "achieved_error: ", achieved_error - write(0,*) "error_tolerance: ", error_tolerance - - fail = (achieved_error > error_tolerance) - call report_test("[adaptive interpolation supermesh]", fail, .false., "Achieved error must be less than tolerance") + use quadrature + use elements + use fields + use adaptive_interpolation_module + use mesh_files + use unittest_tools + implicit none + + type(vector_field) :: positionsA, positionsB + type(mesh_type) :: dg_mesh, quadratic_mesh + type(scalar_field) :: in_field, out_field + type(element_type) :: quadratic_shape + real :: achieved_error + integer :: no_refinements + logical :: fail + real :: error_tolerance + + interface + function field_func(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + + subroutine set_global_debug_level(level) + integer :: level + end subroutine set_global_debug_level + end interface + + call set_global_debug_level(3) + + positionsA = read_mesh_files("data/pslgA", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") + positionsB = read_mesh_files("data/pslgB", quad_degree=2*max_ai_degree, quad_family=FAMILY_GM, format="gmsh") + + quadratic_shape = make_element_shape(vertices = ele_loc(positionsA, 1), dim =positionsA%dim, degree=2, quad=positionsA%mesh%shape%quadrature) + quadratic_mesh = make_mesh(positionsB%mesh, quadratic_shape, -1, "QuadraticDgMesh") + call allocate(in_field, quadratic_mesh, "InField") + call set_from_function(in_field, field_func, positionsA) + + dg_mesh = make_mesh(positionsB%mesh, positionsB%mesh%shape, -1, "DgMesh") + call allocate(out_field, dg_mesh, "OutField") + call set(out_field, -10000.0) + + error_tolerance = 1.3e-8 + + call adaptive_interpolation(in_field, positionsA, out_field, positionsB, error_tolerance, achieved_error, no_refinements) + + write(0,*) "achieved_error: ", achieved_error + write(0,*) "error_tolerance: ", error_tolerance + + fail = (achieved_error > error_tolerance) + call report_test("[adaptive interpolation supermesh]", fail, .false., "Achieved error must be less than tolerance") end subroutine test_adaptive_interpolation_supermesh function field_func(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1)**3 + f = pos(1)**3 end function field_func diff --git a/femtools/tests/test_adaptive_timestepping.F90 b/femtools/tests/test_adaptive_timestepping.F90 index 1683cd3aae..507fcd0c61 100644 --- a/femtools/tests/test_adaptive_timestepping.F90 +++ b/femtools/tests/test_adaptive_timestepping.F90 @@ -26,44 +26,44 @@ ! USA subroutine test_adaptive_timestepping - !!< Test adaptive timestepping + !!< Test adaptive timestepping - use adaptive_timestepping - use fields - use fields_data_types - use mesh_files - use unittest_tools + use adaptive_timestepping + use fields + use fields_data_types + use mesh_files + use unittest_tools - implicit none + implicit none - real :: dt - type(scalar_field) :: cflnumber_field - type(vector_field) :: mesh_field + real :: dt + type(scalar_field) :: cflnumber_field + type(vector_field) :: mesh_field - mesh_field = read_mesh_files("data/tet", quad_degree = 1, format="gmsh") + mesh_field = read_mesh_files("data/tet", quad_degree = 1, format="gmsh") - call allocate(cflnumber_field, mesh_field%mesh, "CFLNumber") + call allocate(cflnumber_field, mesh_field%mesh, "CFLNumber") - call set(cflnumber_field, 0.1) + call set(cflnumber_field, 0.1) - dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = huge(0.0), increase_tolerance = huge(0.0) * epsilon(0.0)) - call report_test("[Correct timestep size (increasing dt)]", dt .fne. 10.0, .false., "Incorrect timestep size") + dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = huge(0.0), increase_tolerance = huge(0.0) * epsilon(0.0)) + call report_test("[Correct timestep size (increasing dt)]", dt .fne. 10.0, .false., "Incorrect timestep size") - dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = 5.0, increase_tolerance = huge(0.0) * epsilon(0.0)) - call report_test("[Max timestep size (set via max_dt)]", dt .fne. 5.0, .false., "Incorrect timestep size") + dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = 5.0, increase_tolerance = huge(0.0) * epsilon(0.0)) + call report_test("[Max timestep size (set via max_dt)]", dt .fne. 5.0, .false., "Incorrect timestep size") - dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = huge(0.0), increase_tolerance = 5.0) - call report_test("[Max timestep size (set via increase_tolerance)]", dt .fne. 5.0, .false., "Incorrect timestep size") + dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = huge(0.0), increase_tolerance = 5.0) + call report_test("[Max timestep size (set via increase_tolerance)]", dt .fne. 5.0, .false., "Incorrect timestep size") - call set(cflnumber_field, 10.0) + call set(cflnumber_field, 10.0) - dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = huge(0.0), increase_tolerance = huge(0.0) * epsilon(0.0)) - call report_test("[Correct timestep size (decreasing dt)]", dt .fne. 0.1, .false., "Incorrect timestep size") + dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = tiny(0.0), max_dt = huge(0.0), increase_tolerance = huge(0.0) * epsilon(0.0)) + call report_test("[Correct timestep size (decreasing dt)]", dt .fne. 0.1, .false., "Incorrect timestep size") - dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = 0.2, max_dt = huge(0.0), increase_tolerance = huge(0.0) * epsilon(0.0)) - call report_test("[Min timestep size]", dt .fne. 0.2, .false., "Incorrect timestep size") + dt = cflnumber_field_based_dt(cflnumber_field, current_dt = 1.0, max_cfl_requested = 1.0, min_dt = 0.2, max_dt = huge(0.0), increase_tolerance = huge(0.0) * epsilon(0.0)) + call report_test("[Min timestep size]", dt .fne. 0.2, .false., "Incorrect timestep size") - call deallocate(cflnumber_field) - call deallocate(mesh_field) + call deallocate(cflnumber_field) + call deallocate(mesh_field) end subroutine test_adaptive_timestepping diff --git a/femtools/tests/test_array_permutation.F90 b/femtools/tests/test_array_permutation.F90 index 4febceadf2..23295b8aeb 100644 --- a/femtools/tests/test_array_permutation.F90 +++ b/femtools/tests/test_array_permutation.F90 @@ -1,16 +1,16 @@ subroutine test_array_permutation - use unittest_tools + use unittest_tools - implicit none + implicit none - integer :: i - integer, dimension(5) :: integer_data, permutation + integer :: i + integer, dimension(5) :: integer_data, permutation - permutation = (/(size(permutation) - i, i = 0, size(permutation) - 1)/) - integer_data = (/(i, i = 1, size(integer_data))/) + permutation = (/(size(permutation) - i, i = 0, size(permutation) - 1)/) + integer_data = (/(i, i = 1, size(integer_data))/) - integer_data = integer_data(permutation) - call report_test("[array permutation]", any(integer_data /= permutation), .false., "Incorrect permutation") + integer_data = integer_data(permutation) + call report_test("[array permutation]", any(integer_data /= permutation), .false., "Incorrect permutation") end subroutine test_array_permutation diff --git a/femtools/tests/test_blasmul.F90 b/femtools/tests/test_blasmul.F90 index 8e66a66665..88e9c7e352 100644 --- a/femtools/tests/test_blasmul.F90 +++ b/femtools/tests/test_blasmul.F90 @@ -1,42 +1,42 @@ subroutine test_blasmul - use vector_tools - use unittest_tools - implicit none + use vector_tools + use unittest_tools + implicit none - real, dimension(3, 3) :: A, B, C, D - real, dimension(3) :: x, e, f, g - integer :: i - logical :: fail - character(len=20) :: buf + real, dimension(3, 3) :: A, B, C, D + real, dimension(3) :: x, e, f, g + integer :: i + logical :: fail + character(len=20) :: buf - do i=1,5 - write(buf,'(i0)') i - fail = .false. + do i=1,5 + write(buf,'(i0)') i + fail = .false. - A = random_matrix(3) - B = random_matrix(3) + A = random_matrix(3) + B = random_matrix(3) - C = blasmul(A, B) - D = matmul(A, B) + C = blasmul(A, B) + D = matmul(A, B) - if (any(C /= D)) fail = .true. + if (any(C /= D)) fail = .true. - call report_test("[blasmul_mm " // trim(buf) // "]", fail, .false., "The output of blasmul and matmul should be identical.") - end do + call report_test("[blasmul_mm " // trim(buf) // "]", fail, .false., "The output of blasmul and matmul should be identical.") + end do - do i=1,5 - write(buf,'(i0)') i - fail = .false. + do i=1,5 + write(buf,'(i0)') i + fail = .false. - A = random_matrix(3) - e = random_vector(3) + A = random_matrix(3) + e = random_vector(3) - f = blasmul(A, e) - g = matmul(A, e) + f = blasmul(A, e) + g = matmul(A, e) - if (any(f /= g)) fail = .true. + if (any(f /= g)) fail = .true. - call report_test("[blasmul_mv " // trim(buf) // "]", fail, .false., "The output of blasmul and matmul should be identical.") - end do + call report_test("[blasmul_mv " // trim(buf) // "]", fail, .false., "The output of blasmul and matmul should be identical.") + end do end subroutine test_blasmul diff --git a/femtools/tests/test_block_csr_transpose.F90 b/femtools/tests/test_block_csr_transpose.F90 index 5c1d618e3c..c90d5cb6f0 100644 --- a/femtools/tests/test_block_csr_transpose.F90 +++ b/femtools/tests/test_block_csr_transpose.F90 @@ -28,40 +28,40 @@ subroutine test_block_csr_transpose - use Sparse_Tools - use unittest_tools + use Sparse_Tools + use unittest_tools - type(csr_sparsity) :: sparsity - type(csr_matrix) :: A - type(block_csr_matrix) :: block_mat, block_mat_T, block_mat_TT - integer :: i, j + type(csr_sparsity) :: sparsity + type(csr_matrix) :: A + type(block_csr_matrix) :: block_mat, block_mat_T, block_mat_TT + integer :: i, j - call allocate(sparsity, 2, 3, nnz = (/ 1, 2 /), name="Sparsity") - sparsity%colm = (/ 1, 2, 3 /) - sparsity%sorted_rows = .true. + call allocate(sparsity, 2, 3, nnz = (/ 1, 2 /), name="Sparsity") + sparsity%colm = (/ 1, 2, 3 /) + sparsity%sorted_rows = .true. - call allocate(A, sparsity, name="A") - call set(A, (/ 1 /) , (/ 1 /) , reshape( (/ 1.0 /), (/ 1, 1/) ) ) - call set(A, (/ 2 /), (/ 2, 3 /), reshape( (/ 2.0, 3.0 /), (/ 1, 2 /) ) ) + call allocate(A, sparsity, name="A") + call set(A, (/ 1 /) , (/ 1 /) , reshape( (/ 1.0 /), (/ 1, 1/) ) ) + call set(A, (/ 2 /), (/ 2, 3 /), reshape( (/ 2.0, 3.0 /), (/ 1, 2 /) ) ) - call allocate(block_mat, sparsity, (/ 2, 2 /), name="BlockMat") - call set(block_mat, 1, 1, A) - call set(block_mat, 1, 2, A) - call set(block_mat, 2, 1, A) - call set(block_mat, 2, 2, A) + call allocate(block_mat, sparsity, (/ 2, 2 /), name="BlockMat") + call set(block_mat, 1, 1, A) + call set(block_mat, 1, 2, A) + call set(block_mat, 2, 1, A) + call set(block_mat, 2, 2, A) - block_mat_T = transpose(block_mat, symmetric_sparsity=.false.) - block_mat_TT = transpose(block_mat_T) + block_mat_T = transpose(block_mat, symmetric_sparsity=.false.) + block_mat_TT = transpose(block_mat_T) - call report_test("[blocks are the same]", .not. all(block_mat%blocks == block_mat_TT%blocks), .false., "the blocks do not match") - do i=1,block_mat%blocks(1) - do j=1,block_mat%blocks(2) - call report_test("[values are the same]", .not. all(block_mat%val(i,j)%ptr == block_mat_TT%val(i, j)%ptr), .false., "the values do not match") - end do - end do + call report_test("[blocks are the same]", .not. all(block_mat%blocks == block_mat_TT%blocks), .false., "the blocks do not match") + do i=1,block_mat%blocks(1) + do j=1,block_mat%blocks(2) + call report_test("[values are the same]", .not. all(block_mat%val(i,j)%ptr == block_mat_TT%val(i, j)%ptr), .false., "the values do not match") + end do + end do - call deallocate(block_mat_T) - call deallocate(block_mat) + call deallocate(block_mat_T) + call deallocate(block_mat) end subroutine test_block_csr_transpose diff --git a/femtools/tests/test_block_csr_transpose_diagonal.F90 b/femtools/tests/test_block_csr_transpose_diagonal.F90 index f9cf9b6858..8c32e878ea 100644 --- a/femtools/tests/test_block_csr_transpose_diagonal.F90 +++ b/femtools/tests/test_block_csr_transpose_diagonal.F90 @@ -28,38 +28,38 @@ subroutine test_block_csr_transpose_diagonal - use Sparse_Tools - use unittest_tools + use Sparse_Tools + use unittest_tools - type(csr_sparsity) :: sparsity - type(csr_matrix) :: A - type(block_csr_matrix) :: block_mat, block_mat_T, block_mat_TT - integer :: i, j + type(csr_sparsity) :: sparsity + type(csr_matrix) :: A + type(block_csr_matrix) :: block_mat, block_mat_T, block_mat_TT + integer :: i, j - call allocate(sparsity, 2, 2, nnz = (/ 1, 1 /), name="Sparsity", diag=.true.) - sparsity%colm = (/ 1, 2 /) - sparsity%sorted_rows = .true. + call allocate(sparsity, 2, 2, nnz = (/ 1, 1 /), name="Sparsity", diag=.true.) + sparsity%colm = (/ 1, 2 /) + sparsity%sorted_rows = .true. - call allocate(A, sparsity, name="A") - call set(A, (/ 1 /) , (/ 1 /) , reshape( (/ 1.0 /), (/ 1, 1/) ) ) - call set(A, (/ 2 /) , (/ 2 /) , reshape( (/ 2.0 /), (/ 1, 1/) ) ) + call allocate(A, sparsity, name="A") + call set(A, (/ 1 /) , (/ 1 /) , reshape( (/ 1.0 /), (/ 1, 1/) ) ) + call set(A, (/ 2 /) , (/ 2 /) , reshape( (/ 2.0 /), (/ 1, 1/) ) ) - call allocate(block_mat, sparsity, (/ 1, 3 /), name="BlockMat") - call set(block_mat, 1, 1, A) - call set(block_mat, 1, 2, A) - call set(block_mat, 1, 3, A) + call allocate(block_mat, sparsity, (/ 1, 3 /), name="BlockMat") + call set(block_mat, 1, 1, A) + call set(block_mat, 1, 2, A) + call set(block_mat, 1, 3, A) - block_mat_T = transpose(block_mat, symmetric_sparsity=.true.) - block_mat_TT = transpose(block_mat_T, symmetric_sparsity=.true.) + block_mat_T = transpose(block_mat, symmetric_sparsity=.true.) + block_mat_TT = transpose(block_mat_T, symmetric_sparsity=.true.) - call report_test("[blocks are the same]", .not. all(block_mat%blocks == block_mat_TT%blocks), .false., "the blocks do not match") - do i=1,block_mat%blocks(1) - do j=1,block_mat%blocks(2) - call report_test("[values are the same]", .not. all(block_mat%val(i,j)%ptr == block_mat_TT%val(i, j)%ptr), .false., "the values do not match") - end do - end do + call report_test("[blocks are the same]", .not. all(block_mat%blocks == block_mat_TT%blocks), .false., "the blocks do not match") + do i=1,block_mat%blocks(1) + do j=1,block_mat%blocks(2) + call report_test("[values are the same]", .not. all(block_mat%val(i,j)%ptr == block_mat_TT%val(i, j)%ptr), .false., "the values do not match") + end do + end do - call deallocate(block_mat_T) - call deallocate(block_mat) + call deallocate(block_mat_T) + call deallocate(block_mat) end subroutine test_block_csr_transpose_diagonal diff --git a/femtools/tests/test_block_csr_transpose_symmetric_sparsity.F90 b/femtools/tests/test_block_csr_transpose_symmetric_sparsity.F90 index 32894a3123..d6e56196d2 100644 --- a/femtools/tests/test_block_csr_transpose_symmetric_sparsity.F90 +++ b/femtools/tests/test_block_csr_transpose_symmetric_sparsity.F90 @@ -28,44 +28,44 @@ subroutine test_block_csr_transpose_symmetric_sparsity - use Sparse_Tools - use unittest_tools + use Sparse_Tools + use unittest_tools - type(csr_sparsity) :: sparsity - type(csr_matrix) :: A - type(block_csr_matrix) :: block_mat, block_mat_T, block_mat_TT - integer :: i, j + type(csr_sparsity) :: sparsity + type(csr_matrix) :: A + type(block_csr_matrix) :: block_mat, block_mat_T, block_mat_TT + integer :: i, j - call allocate(sparsity, 2, 2, nnz = (/ 2, 1 /), name="Sparsity") - sparsity%colm = (/ 2, 1, 1 /) - call report_test("[sparsity is symmetric]", .not. is_symmetric(sparsity), .false., "sparsity is not symmetric") - call report_test("[sparsity is not yet sorted]", sparsity_is_sorted(sparsity), .false., "sparsity should be not sorted before calling sort(sparsity).") - call sparsity_sort(sparsity) - call report_test("[sparsity is sorted]", .not. sparsity_is_sorted(sparsity), .false., "sparsity is not sorted after calling sort(sparsity).") + call allocate(sparsity, 2, 2, nnz = (/ 2, 1 /), name="Sparsity") + sparsity%colm = (/ 2, 1, 1 /) + call report_test("[sparsity is symmetric]", .not. is_symmetric(sparsity), .false., "sparsity is not symmetric") + call report_test("[sparsity is not yet sorted]", sparsity_is_sorted(sparsity), .false., "sparsity should be not sorted before calling sort(sparsity).") + call sparsity_sort(sparsity) + call report_test("[sparsity is sorted]", .not. sparsity_is_sorted(sparsity), .false., "sparsity is not sorted after calling sort(sparsity).") - sparsity%sorted_rows = .true. + sparsity%sorted_rows = .true. - call allocate(A, sparsity, name="A") - call set(A, (/ 1 /) , (/ 2 /) , reshape( (/ 1.0, 2.0 /), (/ 1, 2/) ) ) - call set(A, (/ 2 /), (/ 1 /), reshape( (/ 3.0 /), (/ 1, 1 /) ) ) + call allocate(A, sparsity, name="A") + call set(A, (/ 1 /) , (/ 2 /) , reshape( (/ 1.0, 2.0 /), (/ 1, 2/) ) ) + call set(A, (/ 2 /), (/ 1 /), reshape( (/ 3.0 /), (/ 1, 1 /) ) ) - call allocate(block_mat, sparsity, (/ 1, 3 /), name="BlockMat") - call set(block_mat, 1, 1, A) - call set(block_mat, 1, 2, A) - call set(block_mat, 1, 3, A) + call allocate(block_mat, sparsity, (/ 1, 3 /), name="BlockMat") + call set(block_mat, 1, 1, A) + call set(block_mat, 1, 2, A) + call set(block_mat, 1, 3, A) - block_mat_T = transpose(block_mat, symmetric_sparsity=.true.) - block_mat_TT = transpose(block_mat_T, symmetric_sparsity=.true.) + block_mat_T = transpose(block_mat, symmetric_sparsity=.true.) + block_mat_TT = transpose(block_mat_T, symmetric_sparsity=.true.) - call report_test("[blocks are the same]", .not. all(block_mat%blocks == block_mat_TT%blocks), .false., "the blocks do not match") - do i=1,block_mat%blocks(1) - do j=1,block_mat%blocks(2) - call report_test("[values are the same]", .not. all(block_mat%val(i,j)%ptr == block_mat_TT%val(i, j)%ptr), .false., "the values do not match") - end do - end do + call report_test("[blocks are the same]", .not. all(block_mat%blocks == block_mat_TT%blocks), .false., "the blocks do not match") + do i=1,block_mat%blocks(1) + do j=1,block_mat%blocks(2) + call report_test("[values are the same]", .not. all(block_mat%val(i,j)%ptr == block_mat_TT%val(i, j)%ptr), .false., "the values do not match") + end do + end do - call deallocate(block_mat_T) - call deallocate(block_mat) + call deallocate(block_mat_T) + call deallocate(block_mat) end subroutine test_block_csr_transpose_symmetric_sparsity diff --git a/femtools/tests/test_cartesian_2_lon_lat_height.F90 b/femtools/tests/test_cartesian_2_lon_lat_height.F90 index d6ab1a5255..69d9e13673 100644 --- a/femtools/tests/test_cartesian_2_lon_lat_height.F90 +++ b/femtools/tests/test_cartesian_2_lon_lat_height.F90 @@ -25,46 +25,46 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_cartesian_2_lon_lat_height - !Subroutine for testing correct conversion of point coordinates from Cartesian - ! into longitude-latitude-height coordinates. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine for testing correct conversion of point coordinates from Cartesian + ! into longitude-latitude-height coordinates. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: LonLatHeightCoordinate - type(vector_field), pointer :: CartesianCoordinate - type(vector_field) :: difference - integer :: node - real, dimension(3) :: LLH, XYZ !Arrays containing a single node's position vector - ! components in lon-lat-height & Cartesian coordinates. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: LonLatHeightCoordinate + type(vector_field), pointer :: CartesianCoordinate + type(vector_field) :: difference + integer :: node + real, dimension(3) :: LLH, XYZ !Arrays containing a single node's position vector + ! components in lon-lat-height & Cartesian coordinates. + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - !Extract the components of points in vtu file in Cartesian, apply transformation and - ! compare with position-vector in lon-lat-radius coordinates. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - call cartesian_2_lon_lat_height(XYZ(1), XYZ(2), XYZ(3), & - LLH(1), LLH(2), LLH(3), & - 0.0) - call set(difference, node, LLH) - enddo - call addto(difference, LonLatHeightCoordinate, -1.0) + !Extract the components of points in vtu file in Cartesian, apply transformation and + ! compare with position-vector in lon-lat-radius coordinates. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + call cartesian_2_lon_lat_height(XYZ(1), XYZ(2), XYZ(3), & + LLH(1), LLH(2), LLH(3), & + 0.0) + call set(difference, node, LLH) + enddo + call addto(difference, LonLatHeightCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: Cartesian to lon-lat-height.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: Cartesian to lon-lat-height.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_cartesian_2_spherical_polar.F90 b/femtools/tests/test_cartesian_2_spherical_polar.F90 index a42ab71937..6bbd11bcac 100644 --- a/femtools/tests/test_cartesian_2_spherical_polar.F90 +++ b/femtools/tests/test_cartesian_2_spherical_polar.F90 @@ -25,45 +25,45 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_cartesian_2_spherical_polar - !Subroutine for testing conversion of the position vector components from a Cartesian - ! basis to a spherical-polar basis. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine for testing conversion of the position vector components from a Cartesian + ! basis to a spherical-polar basis. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - integer :: node - real, dimension(3) :: X, RTP !Arrays containing a single node's position vector - ! components in Cartesian & spherical-polar bases. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + integer :: node + real, dimension(3) :: X, RTP !Arrays containing a single node's position vector + ! components in Cartesian & spherical-polar bases. + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Extract the components of points in vtu file in Cartesian coordinates, - ! apply transformation and compare with position-vector is spherical-polar - ! coordinates. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(CartesianCoordinate) - X = node_val(CartesianCoordinate, node) - call cartesian_2_spherical_polar(X(1), X(2), X(3), RTP(1), RTP(2), RTP(3)) - call set(difference, node, RTP) - enddo - call addto(difference, PolarCoordinate, -1.0) + !Extract the components of points in vtu file in Cartesian coordinates, + ! apply transformation and compare with position-vector is spherical-polar + ! coordinates. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(CartesianCoordinate) + X = node_val(CartesianCoordinate, node) + call cartesian_2_spherical_polar(X(1), X(2), X(3), RTP(1), RTP(2), RTP(3)) + call set(difference, node, RTP) + enddo + call addto(difference, PolarCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: Cartesian to Spherical-polar.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: Cartesian to Spherical-polar.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_cartesian_2_spherical_polar_c.F90 b/femtools/tests/test_cartesian_2_spherical_polar_c.F90 index 02d267b500..d63c2748fc 100644 --- a/femtools/tests/test_cartesian_2_spherical_polar_c.F90 +++ b/femtools/tests/test_cartesian_2_spherical_polar_c.F90 @@ -25,49 +25,49 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_cartesian_2_spherical_polar_c - !Subroutine/unit-test of correct transformation of point coordinates from a - ! Cartesian system to a spherical-polar system. This subroutine will test - ! the C-inoperable version of the conversion. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - use iso_c_binding - implicit none + !Subroutine/unit-test of correct transformation of point coordinates from a + ! Cartesian system to a spherical-polar system. This subroutine will test + ! the C-inoperable version of the conversion. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + use iso_c_binding + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - integer :: node - real(kind=c_double), dimension(3) :: XYZ, RTP !Arrays containing a single node's - ! position vector components in Cartesian & - ! spherical-polar bases. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + integer :: node + real(kind=c_double), dimension(3) :: XYZ, RTP !Arrays containing a single node's + ! position vector components in Cartesian & + ! spherical-polar bases. + logical :: fail - !Extract the vector fields of position in vtu file in polar coordinates and - ! cartesian coordiantes - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + !Extract the vector fields of position in vtu file in polar coordinates and + ! cartesian coordiantes + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Apply transformation to Cartesian components and compare with components of - ! spherical-polar position-vector. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(PolarCoordinate) - XYZ = node_val(CartesianCoordinate, node) - call cartesian_2_spherical_polar_c(XYZ(1), XYZ(2), XYZ(3), RTP(1), RTP(2), RTP(3)) - call set(difference, node, RTP) - enddo - call addto(difference, PolarCoordinate, -1.0) + !Apply transformation to Cartesian components and compare with components of + ! spherical-polar position-vector. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(PolarCoordinate) + XYZ = node_val(CartesianCoordinate, node) + call cartesian_2_spherical_polar_c(XYZ(1), XYZ(2), XYZ(3), RTP(1), RTP(2), RTP(3)) + call set(difference, node, RTP) + enddo + call addto(difference, PolarCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: Cartesian to Spherical-polar(C-types).]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: Cartesian to Spherical-polar(C-types).]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_cartesian_2_spherical_polar_field.F90 b/femtools/tests/test_cartesian_2_spherical_polar_field.F90 index 0ce28d9482..3b774c7ffc 100644 --- a/femtools/tests/test_cartesian_2_spherical_polar_field.F90 +++ b/femtools/tests/test_cartesian_2_spherical_polar_field.F90 @@ -25,39 +25,39 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_cartesian_2_spherical_polar_field - !Test for routine test_cartesian_2_spherical_polar_field: Conversion of a vector field - ! containing the position vector in Cartesian coordiantes into a vector field containing - ! the position vector in spherical-polar coordinates. + !Test for routine test_cartesian_2_spherical_polar_field: Conversion of a vector field + ! containing the position vector in Cartesian coordiantes into a vector field containing + ! the position vector in spherical-polar coordinates. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Apply transformation to Cartesian field obtained from vtu file and - ! compare with spherical-polar position-vector. - call allocate(difference, 3 , mesh, 'difference') - call cartesian_2_spherical_polar(CartesianCoordinate, difference) - call addto(difference, PolarCoordinate, -1.0) + !Apply transformation to Cartesian field obtained from vtu file and + ! compare with spherical-polar position-vector. + call allocate(difference, 3 , mesh, 'difference') + call cartesian_2_spherical_polar(CartesianCoordinate, difference) + call addto(difference, PolarCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change of whole field: Cartesian to spherical-polar.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change of whole field: Cartesian to spherical-polar.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_cfl_number_1d.F90 b/femtools/tests/test_cfl_number_1d.F90 index 9fd617105c..236b37abc9 100644 --- a/femtools/tests/test_cfl_number_1d.F90 +++ b/femtools/tests/test_cfl_number_1d.F90 @@ -29,60 +29,60 @@ subroutine test_cfl_number_1d - use diagnostic_fields - use quadrature - use elements - use fields - use fldebug - use state_module - use unittest_tools + use diagnostic_fields + use quadrature + use elements + use fields + use fldebug + use state_module + use unittest_tools - implicit none + implicit none - type(element_type) :: shape - type(quadrature_type) :: quad - type(mesh_type) :: coordinate_mesh, velocity_mesh - type(scalar_field) :: cfl_no - type(state_type) :: state - type(vector_field) :: positions, velocity + type(element_type) :: shape + type(quadrature_type) :: quad + type(mesh_type) :: coordinate_mesh, velocity_mesh + type(scalar_field) :: cfl_no + type(state_type) :: state + type(vector_field) :: positions, velocity - quad = make_quadrature(vertices = 2, dim = 1, degree = 2) - shape = make_element_shape(vertices = 2, dim = 1, degree = 1, quad = quad) - call deallocate(quad) + quad = make_quadrature(vertices = 2, dim = 1, degree = 2) + shape = make_element_shape(vertices = 2, dim = 1, degree = 1, quad = quad) + call deallocate(quad) - call allocate(coordinate_mesh, nodes = 4, elements = 3, shape = shape, name = "CoordinateMesh") - call deallocate(shape) + call allocate(coordinate_mesh, nodes = 4, elements = 3, shape = shape, name = "CoordinateMesh") + call deallocate(shape) - call set_ele_nodes(coordinate_mesh, 1, (/1, 2/)) - call set_ele_nodes(coordinate_mesh, 2, (/2, 3/)) - call set_ele_nodes(coordinate_mesh, 3, (/3, 4/)) + call set_ele_nodes(coordinate_mesh, 1, (/1, 2/)) + call set_ele_nodes(coordinate_mesh, 2, (/2, 3/)) + call set_ele_nodes(coordinate_mesh, 3, (/3, 4/)) - velocity_mesh = piecewise_constant_mesh(coordinate_mesh, name = "CFLNumberMesh") + velocity_mesh = piecewise_constant_mesh(coordinate_mesh, name = "CFLNumberMesh") - call allocate(positions, 1, coordinate_mesh, name = "Coordinate") - call allocate(velocity, 1, velocity_mesh, name = "Velocity") - call allocate(cfl_no, velocity_mesh, name = "CFLNumber") + call allocate(positions, 1, coordinate_mesh, name = "Coordinate") + call allocate(velocity, 1, velocity_mesh, name = "Velocity") + call allocate(cfl_no, velocity_mesh, name = "CFLNumber") - call deallocate(coordinate_mesh) - call deallocate(velocity_mesh) + call deallocate(coordinate_mesh) + call deallocate(velocity_mesh) - call set(positions, (/1, 2, 3, 4/), spread((/0.0, 1.0, 11.0, 111.0/), 1, 1)) - call set(velocity, (/1, 2, 3/), spread((/1.0, 1.0, 5.0/), 1, 1)) + call set(positions, (/1, 2, 3, 4/), spread((/0.0, 1.0, 11.0, 111.0/), 1, 1)) + call set(velocity, (/1, 2, 3/), spread((/1.0, 1.0, 5.0/), 1, 1)) - call insert(state, positions, name = positions%name) - call insert(state, velocity, name = velocity%name) - call deallocate(positions) - call deallocate(velocity) + call insert(state, positions, name = positions%name) + call insert(state, velocity, name = velocity%name) + call deallocate(positions) + call deallocate(velocity) - call calculate_cfl_number(state, cfl_no, dt = 1.0) - call report_test("[cfl no]", node_val(cfl_no, (/1, 2, 3/)) .fne. (/1.0, 0.1, 0.05/), .false., "Incorrect CFL number") + call calculate_cfl_number(state, cfl_no, dt = 1.0) + call report_test("[cfl no]", node_val(cfl_no, (/1, 2, 3/)) .fne. (/1.0, 0.1, 0.05/), .false., "Incorrect CFL number") - call calculate_cfl_number(state, cfl_no, dt = 10.0) - call report_test("[cfl no]", node_val(cfl_no, (/1, 2, 3/)) .fne. (/10.0, 1.0, 0.5/), .false., "Incorrect CFL number") + call calculate_cfl_number(state, cfl_no, dt = 10.0) + call report_test("[cfl no]", node_val(cfl_no, (/1, 2, 3/)) .fne. (/10.0, 1.0, 0.5/), .false., "Incorrect CFL number") - call deallocate(state) - call deallocate(cfl_no) + call deallocate(state) + call deallocate(cfl_no) - call report_test_no_references() + call report_test_no_references() end subroutine test_cfl_number_1d diff --git a/femtools/tests/test_colouring.F90 b/femtools/tests/test_colouring.F90 index b0b0cd5a0f..e7c8f24e4a 100644 --- a/femtools/tests/test_colouring.F90 +++ b/femtools/tests/test_colouring.F90 @@ -26,70 +26,70 @@ ! USA #include "fdebug.h" - subroutine test_colouring - use fldebug - use sparse_tools - use fields_data_types - use fields_manipulation - use state_module - use vtk_interfaces - use colouring - use sparsity_patterns - use unittest_tools - use mesh_files - use data_structures +subroutine test_colouring + use fldebug + use sparse_tools + use fields_data_types + use fields_manipulation + use state_module + use vtk_interfaces + use colouring + use sparsity_patterns + use unittest_tools + use mesh_files + use data_structures - implicit none + implicit none - type(vector_field) :: positions - type(mesh_type) :: mesh - type(csr_sparsity) :: sparsity - integer :: maxdgr, i, j, len, sum1, sum2 - logical :: fail=.false. - type(scalar_field) :: node_colour - integer :: no_colours - type(integer_set), dimension(:), allocatable :: clr_sets + type(vector_field) :: positions + type(mesh_type) :: mesh + type(csr_sparsity) :: sparsity + integer :: maxdgr, i, j, len, sum1, sum2 + logical :: fail=.false. + type(scalar_field) :: node_colour + integer :: no_colours + type(integer_set), dimension(:), allocatable :: clr_sets - positions = read_mesh_files('data/square-cavity-2d', quad_degree=4, format="gmsh") - mesh = piecewise_constant_mesh(positions%mesh, "P0Mesh") - sparsity = make_sparsity_compactdgdouble(mesh, "cdG Sparsity") + positions = read_mesh_files('data/square-cavity-2d', quad_degree=4, format="gmsh") + mesh = piecewise_constant_mesh(positions%mesh, "P0Mesh") + sparsity = make_sparsity_compactdgdouble(mesh, "cdG Sparsity") - ! The sparsity matrix is the adjacency matrix of the graph and should therefore have dimension nodes X nodes - assert(size(sparsity,1)==size(sparsity,2)) + ! The sparsity matrix is the adjacency matrix of the graph and should therefore have dimension nodes X nodes + assert(size(sparsity,1)==size(sparsity,2)) - maxdgr=0 - do i=1, size(sparsity, 1) - maxdgr=max(maxdgr, row_length(sparsity, i)) - enddo - call colour_sparsity(sparsity, mesh, node_colour, no_colours) + maxdgr=0 + do i=1, size(sparsity, 1) + maxdgr=max(maxdgr, row_length(sparsity, i)) + enddo + call colour_sparsity(sparsity, mesh, node_colour, no_colours) - if (no_colours > maxdgr+1) fail = .true. ! The +1 is needed for sparsities with zeros on the diagonal - call report_test("colour sets", fail, .false., "there are more colours than the degree of the graph") + if (no_colours > maxdgr+1) fail = .true. ! The +1 is needed for sparsities with zeros on the diagonal + call report_test("colour sets", fail, .false., "there are more colours than the degree of the graph") - fail=.not. verify_colour_sparsity(sparsity, node_colour) - call report_test("colour sets", fail, .false., "the colouring is not valid") + fail=.not. verify_colour_sparsity(sparsity, node_colour) + call report_test("colour sets", fail, .false., "the colouring is not valid") - fail= .false. - allocate(clr_sets(no_colours)) - call allocate(clr_sets) - clr_sets=colour_sets(sparsity, node_colour, no_colours) + fail= .false. + allocate(clr_sets(no_colours)) + call allocate(clr_sets) + clr_sets=colour_sets(sparsity, node_colour, no_colours) - sum1=0 - sum2=0 - do i=1, size(sparsity, 1) - sum1=sum1+i - enddo + sum1=0 + sum2=0 + do i=1, size(sparsity, 1) + sum1=sum1+i + enddo - do i=1, no_colours - len=key_count(clr_sets(i)) - do j= 1, len - sum2=sum2+fetch(clr_sets(i), j) - enddo - enddo + do i=1, no_colours + len=key_count(clr_sets(i)) + do j= 1, len + sum2=sum2+fetch(clr_sets(i), j) + enddo + enddo - fail = .not.(sum1 .eq. sum2) - call report_test("colour sets", fail, .false., "there are something wrong in construction of colour_sets") - call deallocate(clr_sets) - deallocate(clr_sets) + fail = .not.(sum1 .eq. sum2) + call report_test("colour sets", fail, .false., "there are something wrong in construction of colour_sets") + call deallocate(clr_sets) + deallocate(clr_sets) - end subroutine test_colouring +end subroutine test_colouring diff --git a/femtools/tests/test_compute_hessian.F90 b/femtools/tests/test_compute_hessian.F90 index c7baeaa892..52fe4ca1b2 100644 --- a/femtools/tests/test_compute_hessian.F90 +++ b/femtools/tests/test_compute_hessian.F90 @@ -1,80 +1,80 @@ subroutine test_compute_hessian - use field_derivatives - use state_module - use vtk_interfaces - use unittest_tools + use field_derivatives + use state_module + use vtk_interfaces + use unittest_tools - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field) :: pressure_field - type(tensor_field) :: hessian - logical :: fail = .false., warn = .false. - integer :: i - real :: x, y, z + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field) :: pressure_field + type(tensor_field) :: hessian + logical :: fail = .false., warn = .false. + integer :: i + real :: x, y, z - call vtk_read_state("data/test_spr.vtu", state) + call vtk_read_state("data/test_spr.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - call allocate(pressure_field, mesh, "Pressure") + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + call allocate(pressure_field, mesh, "Pressure") - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = 0.5 * x * x + 0.5 * y * y - !pressure_field%val(i) = x - end do + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = 0.5 * x * x + 0.5 * y * y + !pressure_field%val(i) = x + end do - call allocate(hessian, mesh, "Hessian") + call allocate(hessian, mesh, "Hessian") - call compute_hessian(pressure_field, position_field, hessian) + call compute_hessian(pressure_field, position_field, hessian) - fail = .false. + fail = .false. - ! X,X derivative should be 1, +/- 0.3 - do i=1,mesh%nodes - if (.not. fequals(hessian%val(1, 1, i), 1.0, 0.3)) fail = .true. - end do + ! X,X derivative should be 1, +/- 0.3 + do i=1,mesh%nodes + if (.not. fequals(hessian%val(1, 1, i), 1.0, 0.3)) fail = .true. + end do - call report_test("[cube x, x component]", fail, warn, "X, X component should be 1.0") + call report_test("[cube x, x component]", fail, warn, "X, X component should be 1.0") - fail = .false. + fail = .false. - ! Y,Y derivative should be 1, +/- 0.3 - do i=1,mesh%nodes - if (.not. fequals(hessian%val(2, 2, i), 1.0, 0.3)) fail = .true. - end do + ! Y,Y derivative should be 1, +/- 0.3 + do i=1,mesh%nodes + if (.not. fequals(hessian%val(2, 2, i), 1.0, 0.3)) fail = .true. + end do - call report_test("[cube y, y component]", fail, warn, "Y, Y component should be 1.0") + call report_test("[cube y, y component]", fail, warn, "Y, Y component should be 1.0") - fail = .false. + fail = .false. - ! Z,Z derivative should be 0.0 - do i=1,mesh%nodes - if (.not. fequals(hessian%val(3, 3, i), 0.0)) fail = .true. - end do + ! Z,Z derivative should be 0.0 + do i=1,mesh%nodes + if (.not. fequals(hessian%val(3, 3, i), 0.0)) fail = .true. + end do - call report_test("[cube z, z component]", fail, warn, "Z, Z component should be 0.0") + call report_test("[cube z, z component]", fail, warn, "Z, Z component should be 0.0") - fail = .false. + fail = .false. - ! X,Y derivative should be 0.0, +/- 0.20 - do i=1,mesh%nodes - if (.not. fequals(hessian%val(1, 2, i), 0.0, 0.20)) then - print *, "i == ", i, "; hessian(1, 2) == ", hessian%val(1, 2, i) - fail = .true. - end if - end do + ! X,Y derivative should be 0.0, +/- 0.20 + do i=1,mesh%nodes + if (.not. fequals(hessian%val(1, 2, i), 0.0, 0.20)) then + print *, "i == ", i, "; hessian(1, 2) == ", hessian%val(1, 2, i) + fail = .true. + end if + end do - call report_test("[cube x, y component]", fail, warn, "X, Y component should be 0.0") + call report_test("[cube x, y component]", fail, warn, "X, Y component should be 0.0") - call vtk_write_fields("data/compute_hessian", 0, position_field, mesh, sfields=(/pressure_field/), & - tfields=(/hessian/)) + call vtk_write_fields("data/compute_hessian", 0, position_field, mesh, sfields=(/pressure_field/), & + tfields=(/hessian/)) - call deallocate(pressure_field) - call deallocate(state) - call deallocate(hessian) + call deallocate(pressure_field) + call deallocate(state) + call deallocate(hessian) end subroutine test_compute_hessian diff --git a/femtools/tests/test_compute_inner_product_sa.F90 b/femtools/tests/test_compute_inner_product_sa.F90 index eedc19bc36..9ab04657a9 100644 --- a/femtools/tests/test_compute_inner_product_sa.F90 +++ b/femtools/tests/test_compute_inner_product_sa.F90 @@ -1,219 +1,219 @@ subroutine test_compute_inner_product_sa - use conservative_interpolation_module - use vector_tools, only: solve - use elements - use transform_elements - use fetools - use fields - use interpolation_module - use mesh_files - use state_module - use supermesh_assembly - use unittest_tools - - implicit none - - type(vector_field) :: positions_a, positions_b, positions_remap - type(mesh_type) :: mesh_a, mesh_b, mesh_b_proj - type(scalar_field) :: field_a, field_b, field_b_proj - type(element_type) :: shape, positions_shape - type(state_type), dimension(1) :: state_a, state_b - integer :: i - real :: prod - logical :: fail - - positions_a = read_mesh_files("data/laplacian_grid.1", quad_degree=4, format="gmsh") - positions_b = read_mesh_files("data/laplacian_grid.2", quad_degree=4, format="gmsh") - !positions_a%val(1,:) = positions_a%val(1,:) + 3.0 - !call scale(positions_a, 1.0 / 6.0) - !positions_b%val(1,:) = positions_b%val(1,:) + 3.0 - !call scale(positions_b, 1.0 / 6.0) - !positions_b = positions_a - !call incref(positions_b) - - positions_shape = ele_shape(positions_a, 1) - shape = make_element_shape(vertices = ele_loc(positions_a, 1), dim = positions_a%dim, degree = 1, quad = positions_shape%quadrature) - mesh_a = make_mesh(positions_a%mesh, shape = shape, continuity = +1, name = "MeshA") - mesh_b = make_mesh(positions_b%mesh, shape = shape, continuity = +1, name = "MeshB") - call deallocate(shape) - - call allocate(field_a, mesh_a, "FieldA", field_type = FIELD_TYPE_CONSTANT) - call allocate(field_b, mesh_b, "FieldB", field_type = FIELD_TYPE_CONSTANT) - call deallocate(mesh_a) - call deallocate(mesh_b) - - call set(field_a, 2.5) - call set(field_b, 1.2) - - prod = compute_inner_product_sa(positions_a, positions_b, field_a, field_b) - fail = (prod .fne. 3.0) - call report_test("[test_compute_inner_product_sa]", fail, .false., "Should be 3") - if(fail) then - print *, "But got ", prod - end if - - call deallocate(field_a) - call deallocate(field_b) - - shape = make_element_shape(vertices = ele_loc(positions_a, 1), dim = positions_a%dim, degree = 1, quad = positions_shape%quadrature) - mesh_a = make_mesh(positions_a%mesh, shape = shape, continuity = +1, name = "MeshA") - call deallocate(shape) - shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 1, quad = positions_shape%quadrature) - mesh_b = make_mesh(positions_b%mesh, shape = shape, continuity = +1, name = "MeshB") - call deallocate(shape) - - call allocate(field_a, mesh_a, "FieldA") - call allocate(field_b, mesh_b, "FieldB") - - call allocate(positions_remap, positions_a%dim, mesh_a, "CoordinateRemap") - call remap_field(positions_a, positions_remap) - do i = 1, node_count(field_a) - call set(field_a, i, node_val(positions_remap, 1, i)) - end do - call deallocate(positions_remap) - - call allocate(positions_remap, positions_a%dim, mesh_b, "CoordinateRemap") - call remap_field(positions_b, positions_remap) - do i = 1, node_count(field_b) - call set(field_b, i, node_val(positions_remap, 1, i)) - end do - call deallocate(positions_remap) - - prod = compute_inner_product_sa(positions_a, positions_b, field_a, field_b) - fail = (prod .fne. 1.0/3.0) - call report_test("[test_compute_inner_product_sa]", fail, .false., "Should be 1.0 / 3.0") - if(fail) then - print *, "But got ", prod - end if - - call deallocate(field_a) - call deallocate(field_b) - call deallocate(mesh_a) - call deallocate(mesh_b) - - shape = make_element_shape(vertices = ele_loc(positions_a, 1), dim = positions_a%dim, degree = 1, quad = positions_shape%quadrature) - mesh_a = make_mesh(positions_a%mesh, shape = shape, continuity = -1, name = "MeshA") - call deallocate(shape) - shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 2, quad = positions_shape%quadrature) - mesh_b = make_mesh(positions_b%mesh, shape = shape, continuity = -1, name = "MeshB") - call deallocate(shape) - - call allocate(field_a, mesh_a, "FieldA") - call allocate(field_b, mesh_b, "FieldB") - - call allocate(positions_remap, positions_a%dim, mesh_a, "CoordinateRemap") - call remap_field(positions_a, positions_remap) - do i = 1, node_count(field_a) - call set(field_a, i,node_val(positions_remap, 1, i)) - end do - call deallocate(positions_remap) - - call allocate(positions_remap, positions_a%dim, mesh_b, "CoordinateRemap") - call remap_field(positions_b, positions_remap) - do i = 1, node_count(field_b) - call set(field_b, i, node_val(positions_remap, 1, i) ** 2) - end do - call deallocate(positions_remap) - - prod = compute_inner_product_sa(positions_a, positions_b, field_a, field_b) - fail = (prod .fne. 0.25) - call report_test("[test_compute_inner_product_sa]", fail, .false., "Should be 0.25") - - print *, prod - - !shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 2, quad = positions_shape%quadrature) - shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 1, quad = positions_shape%quadrature) - - mesh_b_proj = make_mesh(positions_a%mesh, shape = shape, continuity = -1, name = "MeshBProj") - call deallocate(shape) - call allocate(field_b_proj, mesh_b_proj, "FieldBProjected") - call deallocate(mesh_b_proj) - call insert(state_a(1), field_b_proj, name = field_a%name) - call insert(state_b(1), field_b, name = field_a%name) - - call insert(state_a(1), positions_a, name = positions_a%name) - call insert(state_b(1), positions_b, name = positions_b%name) - call insert(state_a(1), mesh_a, name = mesh_a%name) - call insert(state_b(1), mesh_b, name = mesh_b%name) - call linear_interpolation(state_b(1), state_a(1)) - !call interpolation_galerkin(state_b, positions_b, state_a, positions_a) - - call deallocate(state_a(1)) - call deallocate(state_b(1)) - - !call allocate(field_b_proj2, mesh_a, "FieldBProjected") - !do i = 1, ele_count(field_b_proj) - ! call gp_ele(i, positions_a, field_b_proj, field_b_proj2) - !end do - !print *, compute_inner_product(positions_a, field_a, field_b_proj2) - !print *, compute_inner_product(positions_a, field_a, field_b_proj) - - call deallocate(field_b_proj) - !call deallocate(field_b_proj2) - - call deallocate(field_a) - call deallocate(field_b) - call deallocate(mesh_a) - call deallocate(mesh_b) - - call deallocate(positions_a) - call deallocate(positions_b) - - call report_test_no_references() + use conservative_interpolation_module + use vector_tools, only: solve + use elements + use transform_elements + use fetools + use fields + use interpolation_module + use mesh_files + use state_module + use supermesh_assembly + use unittest_tools + + implicit none + + type(vector_field) :: positions_a, positions_b, positions_remap + type(mesh_type) :: mesh_a, mesh_b, mesh_b_proj + type(scalar_field) :: field_a, field_b, field_b_proj + type(element_type) :: shape, positions_shape + type(state_type), dimension(1) :: state_a, state_b + integer :: i + real :: prod + logical :: fail + + positions_a = read_mesh_files("data/laplacian_grid.1", quad_degree=4, format="gmsh") + positions_b = read_mesh_files("data/laplacian_grid.2", quad_degree=4, format="gmsh") + !positions_a%val(1,:) = positions_a%val(1,:) + 3.0 + !call scale(positions_a, 1.0 / 6.0) + !positions_b%val(1,:) = positions_b%val(1,:) + 3.0 + !call scale(positions_b, 1.0 / 6.0) + !positions_b = positions_a + !call incref(positions_b) + + positions_shape = ele_shape(positions_a, 1) + shape = make_element_shape(vertices = ele_loc(positions_a, 1), dim = positions_a%dim, degree = 1, quad = positions_shape%quadrature) + mesh_a = make_mesh(positions_a%mesh, shape = shape, continuity = +1, name = "MeshA") + mesh_b = make_mesh(positions_b%mesh, shape = shape, continuity = +1, name = "MeshB") + call deallocate(shape) + + call allocate(field_a, mesh_a, "FieldA", field_type = FIELD_TYPE_CONSTANT) + call allocate(field_b, mesh_b, "FieldB", field_type = FIELD_TYPE_CONSTANT) + call deallocate(mesh_a) + call deallocate(mesh_b) + + call set(field_a, 2.5) + call set(field_b, 1.2) + + prod = compute_inner_product_sa(positions_a, positions_b, field_a, field_b) + fail = (prod .fne. 3.0) + call report_test("[test_compute_inner_product_sa]", fail, .false., "Should be 3") + if(fail) then + print *, "But got ", prod + end if + + call deallocate(field_a) + call deallocate(field_b) + + shape = make_element_shape(vertices = ele_loc(positions_a, 1), dim = positions_a%dim, degree = 1, quad = positions_shape%quadrature) + mesh_a = make_mesh(positions_a%mesh, shape = shape, continuity = +1, name = "MeshA") + call deallocate(shape) + shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 1, quad = positions_shape%quadrature) + mesh_b = make_mesh(positions_b%mesh, shape = shape, continuity = +1, name = "MeshB") + call deallocate(shape) + + call allocate(field_a, mesh_a, "FieldA") + call allocate(field_b, mesh_b, "FieldB") + + call allocate(positions_remap, positions_a%dim, mesh_a, "CoordinateRemap") + call remap_field(positions_a, positions_remap) + do i = 1, node_count(field_a) + call set(field_a, i, node_val(positions_remap, 1, i)) + end do + call deallocate(positions_remap) + + call allocate(positions_remap, positions_a%dim, mesh_b, "CoordinateRemap") + call remap_field(positions_b, positions_remap) + do i = 1, node_count(field_b) + call set(field_b, i, node_val(positions_remap, 1, i)) + end do + call deallocate(positions_remap) + + prod = compute_inner_product_sa(positions_a, positions_b, field_a, field_b) + fail = (prod .fne. 1.0/3.0) + call report_test("[test_compute_inner_product_sa]", fail, .false., "Should be 1.0 / 3.0") + if(fail) then + print *, "But got ", prod + end if + + call deallocate(field_a) + call deallocate(field_b) + call deallocate(mesh_a) + call deallocate(mesh_b) + + shape = make_element_shape(vertices = ele_loc(positions_a, 1), dim = positions_a%dim, degree = 1, quad = positions_shape%quadrature) + mesh_a = make_mesh(positions_a%mesh, shape = shape, continuity = -1, name = "MeshA") + call deallocate(shape) + shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 2, quad = positions_shape%quadrature) + mesh_b = make_mesh(positions_b%mesh, shape = shape, continuity = -1, name = "MeshB") + call deallocate(shape) + + call allocate(field_a, mesh_a, "FieldA") + call allocate(field_b, mesh_b, "FieldB") + + call allocate(positions_remap, positions_a%dim, mesh_a, "CoordinateRemap") + call remap_field(positions_a, positions_remap) + do i = 1, node_count(field_a) + call set(field_a, i,node_val(positions_remap, 1, i)) + end do + call deallocate(positions_remap) + + call allocate(positions_remap, positions_a%dim, mesh_b, "CoordinateRemap") + call remap_field(positions_b, positions_remap) + do i = 1, node_count(field_b) + call set(field_b, i, node_val(positions_remap, 1, i) ** 2) + end do + call deallocate(positions_remap) + + prod = compute_inner_product_sa(positions_a, positions_b, field_a, field_b) + fail = (prod .fne. 0.25) + call report_test("[test_compute_inner_product_sa]", fail, .false., "Should be 0.25") + + print *, prod + + !shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 2, quad = positions_shape%quadrature) + shape = make_element_shape(vertices = ele_loc(positions_b, 1), dim = positions_b%dim, degree = 1, quad = positions_shape%quadrature) + + mesh_b_proj = make_mesh(positions_a%mesh, shape = shape, continuity = -1, name = "MeshBProj") + call deallocate(shape) + call allocate(field_b_proj, mesh_b_proj, "FieldBProjected") + call deallocate(mesh_b_proj) + call insert(state_a(1), field_b_proj, name = field_a%name) + call insert(state_b(1), field_b, name = field_a%name) + + call insert(state_a(1), positions_a, name = positions_a%name) + call insert(state_b(1), positions_b, name = positions_b%name) + call insert(state_a(1), mesh_a, name = mesh_a%name) + call insert(state_b(1), mesh_b, name = mesh_b%name) + call linear_interpolation(state_b(1), state_a(1)) + !call interpolation_galerkin(state_b, positions_b, state_a, positions_a) + + call deallocate(state_a(1)) + call deallocate(state_b(1)) + + !call allocate(field_b_proj2, mesh_a, "FieldBProjected") + !do i = 1, ele_count(field_b_proj) + ! call gp_ele(i, positions_a, field_b_proj, field_b_proj2) + !end do + !print *, compute_inner_product(positions_a, field_a, field_b_proj2) + !print *, compute_inner_product(positions_a, field_a, field_b_proj) + + call deallocate(field_b_proj) + !call deallocate(field_b_proj2) + + call deallocate(field_a) + call deallocate(field_b) + call deallocate(mesh_a) + call deallocate(mesh_b) + + call deallocate(positions_a) + call deallocate(positions_b) + + call report_test_no_references() contains - subroutine gp_ele(ele, positions, field_a, field_b) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: field_a - type(scalar_field), intent(inout) :: field_b + subroutine gp_ele(ele, positions, field_a, field_b) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: field_a + type(scalar_field), intent(inout) :: field_b - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(field_b, ele), ele_loc(field_b, ele)) :: mass - real, dimension(ele_loc(field_b, ele)) :: rhs + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(field_b, ele), ele_loc(field_b, ele)) :: mass + real, dimension(ele_loc(field_b, ele)) :: rhs - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - mass = shape_shape(ele_shape(field_b, ele), ele_shape(field_b, ele), detwei) - rhs = shape_rhs(ele_shape(field_b, ele), detwei * ele_val_at_quad(field_a, ele)) + mass = shape_shape(ele_shape(field_b, ele), ele_shape(field_b, ele), detwei) + rhs = shape_rhs(ele_shape(field_b, ele), detwei * ele_val_at_quad(field_a, ele)) - call solve(mass, rhs) - call set(field_b, ele_nodes(field_b, ele), rhs) + call solve(mass, rhs) + call set(field_b, ele_nodes(field_b, ele), rhs) - end subroutine gp_ele + end subroutine gp_ele - function compute_inner_product(positions, field_a, field_b) result(val) - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: field_a - type(scalar_field), intent(in) :: field_b + function compute_inner_product(positions, field_a, field_b) result(val) + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: field_a + type(scalar_field), intent(in) :: field_b - real :: val + real :: val - integer :: i + integer :: i - val = 0.0 - do i = 1, ele_count(positions) - call add_inner_product_ele(i, positions, field_a, field_b, val) - end do + val = 0.0 + do i = 1, ele_count(positions) + call add_inner_product_ele(i, positions, field_a, field_b, val) + end do - end function compute_inner_product + end function compute_inner_product - subroutine add_inner_product_ele(ele, positions, field_a, field_b, val) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: field_a - type(scalar_field), intent(in) :: field_b - real, intent(inout) :: val + subroutine add_inner_product_ele(ele, positions, field_a, field_b, val) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: field_a + type(scalar_field), intent(in) :: field_b + real, intent(inout) :: val - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - val = val + dot_product(ele_val(field_a, ele), matmul(& + val = val + dot_product(ele_val(field_a, ele), matmul(& & shape_shape(ele_shape(field_a, ele), ele_shape(field_b, ele), detwei), ele_val(field_b, ele))) - end subroutine add_inner_product_ele + end subroutine add_inner_product_ele end subroutine test_compute_inner_product_sa diff --git a/femtools/tests/test_conservative_interpolation.F90 b/femtools/tests/test_conservative_interpolation.F90 index d0f5418d70..8e1109e1cf 100644 --- a/femtools/tests/test_conservative_interpolation.F90 +++ b/femtools/tests/test_conservative_interpolation.F90 @@ -2,164 +2,164 @@ subroutine test_conservative_interpolation - use fields - use mesh_files - use conservative_interpolation_module, only: interpolation_galerkin - use unittest_tools - use futils - use solvers - use state_module - implicit none - - interface - function field_func_const(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_linear(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_quadratic(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_cubic(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_exp(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - type(vector_field) :: positionsA, positionsB - type(scalar_field), dimension(5) :: fieldA, fieldB - real :: integralA, integralB - logical :: fail - integer :: field, no_field - type(state_type), dimension(1) :: stateA, stateB - - positionsA = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") - - no_field = 5 - - do field=1,no_field - call allocate(fieldA(field), positionsA%mesh, "Field" // int2str(field)) - fieldA(field)%option_path = "/fieldA" // int2str(field) // "/prognostic/galerkin_projection/continuous" - call set_solver_options(fieldA(field), ksptype='cg', pctype='sor', rtol=1.0e-7, max_its=10000) - fieldA(field)%option_path = "/fieldA" // int2str(field) - call allocate(fieldB(field), positionsB%mesh, "Field" // int2str(field)) - fieldB(field)%option_path = "/fieldB" // int2str(field) // "/prognostic/galerkin_projection/continuous" - call set_solver_options(fieldB(field), ksptype='cg', pctype='sor', rtol=1.0e-7, max_its=10000) - fieldB(field)%option_path = "/fieldB" // int2str(field) - end do - - call set_from_function(fieldA(1), field_func_const, positionsA) - call set_from_function(fieldA(2), field_func_linear, positionsA) - call set_from_function(fieldA(3), field_func_quadratic, positionsA) - call set_from_function(fieldA(4), field_func_cubic, positionsA) - call set_from_function(fieldA(5), field_func_exp, positionsA) - - do field=1,no_field - call zero(fieldB(field)) - - call insert(stateA(1), fieldA(field), name=trim(fieldA(field)%name)) - call insert(stateB(1), fieldB(field), name=trim(fieldB(field)%name)) - end do - - call interpolation_galerkin(stateA, positionsA, stateB, positionsB) - - call deallocate(stateA(1)) - call deallocate(stateB(1)) - - do field=1,no_field - integralA = field_integral(fieldA(field), positionsA) - integralB = field_integral(fieldB(field), positionsB) - - fail=(abs(integralA - integralB) > epsilon(0.0_4)) - call report_test("[conservative interpolation galerkin]", fail, .false., "") - - if (fail) then - write(0,*) "integralA == ", integralA - write(0,*) "integralB == ", integralB - write(0,*) "integralB - integralA == ", integralB - integralA - end if - end do - - do field=1,no_field - call zero(fieldB(field)) - - call insert(stateA(1), fieldA(field), name=trim(fieldA(field)%name)) - call insert(stateB(1), fieldB(field), name=trim(fieldB(field)%name)) - end do - - call interpolation_galerkin(stateA, positionsA, stateB, positionsB, force_bounded=.true.) - - call deallocate(stateA(1)) - call deallocate(stateB(1)) - - do field=1,no_field - integralA = field_integral(fieldA(field), positionsA) - integralB = field_integral(fieldB(field), positionsB) - - fail=(abs(integralA - integralB) > epsilon(0.0_4)) - call report_test("[conservative interpolation bounded]", fail, .false., "") - - if (fail) then - write(0,*) "integralA == ", integralA - write(0,*) "integralB == ", integralB - write(0,*) "integralB - integralA == ", integralB - integralA - end if - end do + use fields + use mesh_files + use conservative_interpolation_module, only: interpolation_galerkin + use unittest_tools + use futils + use solvers + use state_module + implicit none + + interface + function field_func_const(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_linear(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_quadratic(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_cubic(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_exp(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + type(vector_field) :: positionsA, positionsB + type(scalar_field), dimension(5) :: fieldA, fieldB + real :: integralA, integralB + logical :: fail + integer :: field, no_field + type(state_type), dimension(1) :: stateA, stateB + + positionsA = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") + + no_field = 5 + + do field=1,no_field + call allocate(fieldA(field), positionsA%mesh, "Field" // int2str(field)) + fieldA(field)%option_path = "/fieldA" // int2str(field) // "/prognostic/galerkin_projection/continuous" + call set_solver_options(fieldA(field), ksptype='cg', pctype='sor', rtol=1.0e-7, max_its=10000) + fieldA(field)%option_path = "/fieldA" // int2str(field) + call allocate(fieldB(field), positionsB%mesh, "Field" // int2str(field)) + fieldB(field)%option_path = "/fieldB" // int2str(field) // "/prognostic/galerkin_projection/continuous" + call set_solver_options(fieldB(field), ksptype='cg', pctype='sor', rtol=1.0e-7, max_its=10000) + fieldB(field)%option_path = "/fieldB" // int2str(field) + end do + + call set_from_function(fieldA(1), field_func_const, positionsA) + call set_from_function(fieldA(2), field_func_linear, positionsA) + call set_from_function(fieldA(3), field_func_quadratic, positionsA) + call set_from_function(fieldA(4), field_func_cubic, positionsA) + call set_from_function(fieldA(5), field_func_exp, positionsA) + + do field=1,no_field + call zero(fieldB(field)) + + call insert(stateA(1), fieldA(field), name=trim(fieldA(field)%name)) + call insert(stateB(1), fieldB(field), name=trim(fieldB(field)%name)) + end do + + call interpolation_galerkin(stateA, positionsA, stateB, positionsB) + + call deallocate(stateA(1)) + call deallocate(stateB(1)) + + do field=1,no_field + integralA = field_integral(fieldA(field), positionsA) + integralB = field_integral(fieldB(field), positionsB) + + fail=(abs(integralA - integralB) > epsilon(0.0_4)) + call report_test("[conservative interpolation galerkin]", fail, .false., "") + + if (fail) then + write(0,*) "integralA == ", integralA + write(0,*) "integralB == ", integralB + write(0,*) "integralB - integralA == ", integralB - integralA + end if + end do + + do field=1,no_field + call zero(fieldB(field)) + + call insert(stateA(1), fieldA(field), name=trim(fieldA(field)%name)) + call insert(stateB(1), fieldB(field), name=trim(fieldB(field)%name)) + end do + + call interpolation_galerkin(stateA, positionsA, stateB, positionsB, force_bounded=.true.) + + call deallocate(stateA(1)) + call deallocate(stateB(1)) + + do field=1,no_field + integralA = field_integral(fieldA(field), positionsA) + integralB = field_integral(fieldB(field), positionsB) + + fail=(abs(integralA - integralB) > epsilon(0.0_4)) + call report_test("[conservative interpolation bounded]", fail, .false., "") + + if (fail) then + write(0,*) "integralA == ", integralA + write(0,*) "integralB == ", integralB + write(0,*) "integralB - integralA == ", integralB - integralA + end if + end do end subroutine test_conservative_interpolation function field_func_const(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 1.0 + f = 1.0 end function field_func_const function field_func_linear(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1) + pos(2) + f = pos(1) + pos(2) end function field_func_linear function field_func_quadratic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1)**2 + 2.0 * pos(2) + 3.0 + f = pos(1)**2 + 2.0 * pos(2) + 3.0 end function field_func_quadratic function field_func_cubic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 5.0 * pos(2)**3 + pos(1)**2 + 2.0 * pos(2) + 3.0 + f = 5.0 * pos(2)**3 + pos(1)**2 + 2.0 * pos(2) + 3.0 end function field_func_cubic function field_func_exp(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = exp(pos(1)**2 + 2.0 * pos(2)) + f = exp(pos(1)**2 + 2.0 * pos(2)) end function field_func_exp diff --git a/femtools/tests/test_conservative_interpolation_sa.F90 b/femtools/tests/test_conservative_interpolation_sa.F90 index dea9e4b8a1..4223ad53d9 100644 --- a/femtools/tests/test_conservative_interpolation_sa.F90 +++ b/femtools/tests/test_conservative_interpolation_sa.F90 @@ -2,179 +2,179 @@ subroutine test_conservative_interpolation_sa - use elements - use fields - use mesh_files - use conservative_interpolation_module, only: interpolation_galerkin - use unittest_tools - use futils - use solvers - use state_module - use supermesh_assembly - - implicit none - - interface - function field_func_const(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_linear(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_quadratic(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_cubic(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - interface - function field_func_exp(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - type(vector_field) :: positionsA, positionsB - type(scalar_field), dimension(5) :: fieldA, fieldB, fieldC - real :: integralA, integralB - logical :: fail - integer :: field, no_field - type(state_type), dimension(1) :: stateA, stateB, stateC - type(element_type) :: field_element - type(mesh_type) :: donor_mesh, target_mesh - - positionsA = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") - - field_element = make_element_shape(positionsA%mesh%shape%loc, positionsA%mesh%shape%dim, 2, positionsA%mesh%shape%quadrature) - donor_mesh = make_mesh(positionsA%mesh, field_element, continuity=0, name="DonorMesh") - target_mesh = make_mesh(positionsA%mesh, field_element, continuity=0, name="TargetMesh") - - no_field = size(fieldA) - - do field=1,no_field - call allocate(fieldA(field), donor_mesh, "Field" // int2str(field)) - fieldA(field)%option_path = "/fieldA" // int2str(field) // "/prognostic/galerkin_projection/continuous" - call set_solver_options(fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - fieldA(field)%option_path = "/fieldA" // int2str(field) - call allocate(fieldB(field), target_mesh, "Field" // int2str(field)) - fieldB(field)%option_path = "/fieldB" // int2str(field) // "/prognostic/galerkin_projection/continuous" - call set_solver_options(fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - fieldB(field)%option_path = "/fieldB" // int2str(field) - call allocate(fieldC(field), target_mesh, "Field" // int2str(field)) - fieldC(field)%option_path = "/fieldC" // int2str(field) // "/prognostic/galerkin_projection/continuous" - call set_solver_options(fieldC(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) - fieldC(field)%option_path = "/fieldC" // int2str(field) - end do - - call insert(stateA, positionsA, "Coordinate") - call insert(stateA, positionsA%mesh, "CoordinateMesh") - call insert(stateB, positionsB, "Coordinate") - call insert(stateB, positionsB%mesh, "CoordinateMesh") - call insert(stateC, positionsB, "Coordinate") - call insert(stateC, positionsB%mesh, "CoordinateMesh") - - call set_from_function(fieldA(1), field_func_const, positionsA) - call set_from_function(fieldA(2), field_func_linear, positionsA) - call set_from_function(fieldA(3), field_func_quadratic, positionsA) - call set_from_function(fieldA(4), field_func_cubic, positionsA) - call set_from_function(fieldA(5), field_func_exp, positionsA) - - do field=1,no_field - call zero(fieldB(field)) - call zero(fieldC(field)) - - call insert(stateA(1), fieldA(field), name=trim(fieldA(field)%name)) - call insert(stateB(1), fieldB(field), name=trim(fieldB(field)%name)) - call insert(stateC(1), fieldC(field), name=trim(fieldC(field)%name)) - end do - - call galerkin_projection_scalars(stateA, positionsA, stateB, positionsB) - call interpolation_galerkin(stateA, positionsA, stateC, positionsB) - - call deallocate(stateA(1)) - call deallocate(stateB(1)) - call deallocate(stateC(1)) - - do field = 1, no_field - call report_test("[Same result as interpolation_galerkin]", fieldB(field)%val .fne. fieldC(field)%val, .false., "Result differs from that returned by interpolation_galerkin") - end do - - do field=1,no_field - integralA = field_integral(fieldA(field), positionsA) - integralB = field_integral(fieldB(field), positionsB) - - fail=(abs(integralA - integralB) > epsilon(0.0_4)) - call report_test("[conservative interpolation galerkin]", fail, .false., "") - - if (fail) then - write(0,*) "integralA == ", integralA - write(0,*) "integralB == ", integralB - write(0,*) "integralB - integralA == ", integralB - integralA - end if - end do - - call deallocate(target_mesh) - call deallocate(donor_mesh) - call deallocate(field_element) - call deallocate(positionsA) - call deallocate(positionsB) - do field=1,no_field - call deallocate(fieldA(field)) - call deallocate(fieldB(field)) - call deallocate(fieldC(field)) - end do - - call report_test_no_references() + use elements + use fields + use mesh_files + use conservative_interpolation_module, only: interpolation_galerkin + use unittest_tools + use futils + use solvers + use state_module + use supermesh_assembly + + implicit none + + interface + function field_func_const(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_linear(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_quadratic(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_cubic(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + interface + function field_func_exp(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + type(vector_field) :: positionsA, positionsB + type(scalar_field), dimension(5) :: fieldA, fieldB, fieldC + real :: integralA, integralB + logical :: fail + integer :: field, no_field + type(state_type), dimension(1) :: stateA, stateB, stateC + type(element_type) :: field_element + type(mesh_type) :: donor_mesh, target_mesh + + positionsA = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") + + field_element = make_element_shape(positionsA%mesh%shape%loc, positionsA%mesh%shape%dim, 2, positionsA%mesh%shape%quadrature) + donor_mesh = make_mesh(positionsA%mesh, field_element, continuity=0, name="DonorMesh") + target_mesh = make_mesh(positionsA%mesh, field_element, continuity=0, name="TargetMesh") + + no_field = size(fieldA) + + do field=1,no_field + call allocate(fieldA(field), donor_mesh, "Field" // int2str(field)) + fieldA(field)%option_path = "/fieldA" // int2str(field) // "/prognostic/galerkin_projection/continuous" + call set_solver_options(fieldA(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + fieldA(field)%option_path = "/fieldA" // int2str(field) + call allocate(fieldB(field), target_mesh, "Field" // int2str(field)) + fieldB(field)%option_path = "/fieldB" // int2str(field) // "/prognostic/galerkin_projection/continuous" + call set_solver_options(fieldB(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + fieldB(field)%option_path = "/fieldB" // int2str(field) + call allocate(fieldC(field), target_mesh, "Field" // int2str(field)) + fieldC(field)%option_path = "/fieldC" // int2str(field) // "/prognostic/galerkin_projection/continuous" + call set_solver_options(fieldC(field), ksptype='cg', pctype='eisenstat', rtol=1.0e-7, max_its=10000) + fieldC(field)%option_path = "/fieldC" // int2str(field) + end do + + call insert(stateA, positionsA, "Coordinate") + call insert(stateA, positionsA%mesh, "CoordinateMesh") + call insert(stateB, positionsB, "Coordinate") + call insert(stateB, positionsB%mesh, "CoordinateMesh") + call insert(stateC, positionsB, "Coordinate") + call insert(stateC, positionsB%mesh, "CoordinateMesh") + + call set_from_function(fieldA(1), field_func_const, positionsA) + call set_from_function(fieldA(2), field_func_linear, positionsA) + call set_from_function(fieldA(3), field_func_quadratic, positionsA) + call set_from_function(fieldA(4), field_func_cubic, positionsA) + call set_from_function(fieldA(5), field_func_exp, positionsA) + + do field=1,no_field + call zero(fieldB(field)) + call zero(fieldC(field)) + + call insert(stateA(1), fieldA(field), name=trim(fieldA(field)%name)) + call insert(stateB(1), fieldB(field), name=trim(fieldB(field)%name)) + call insert(stateC(1), fieldC(field), name=trim(fieldC(field)%name)) + end do + + call galerkin_projection_scalars(stateA, positionsA, stateB, positionsB) + call interpolation_galerkin(stateA, positionsA, stateC, positionsB) + + call deallocate(stateA(1)) + call deallocate(stateB(1)) + call deallocate(stateC(1)) + + do field = 1, no_field + call report_test("[Same result as interpolation_galerkin]", fieldB(field)%val .fne. fieldC(field)%val, .false., "Result differs from that returned by interpolation_galerkin") + end do + + do field=1,no_field + integralA = field_integral(fieldA(field), positionsA) + integralB = field_integral(fieldB(field), positionsB) + + fail=(abs(integralA - integralB) > epsilon(0.0_4)) + call report_test("[conservative interpolation galerkin]", fail, .false., "") + + if (fail) then + write(0,*) "integralA == ", integralA + write(0,*) "integralB == ", integralB + write(0,*) "integralB - integralA == ", integralB - integralA + end if + end do + + call deallocate(target_mesh) + call deallocate(donor_mesh) + call deallocate(field_element) + call deallocate(positionsA) + call deallocate(positionsB) + do field=1,no_field + call deallocate(fieldA(field)) + call deallocate(fieldB(field)) + call deallocate(fieldC(field)) + end do + + call report_test_no_references() end subroutine test_conservative_interpolation_sa function field_func_const(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 1.0 + f = 1.0 end function field_func_const function field_func_linear(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1) + pos(2) + f = pos(1) + pos(2) end function field_func_linear function field_func_quadratic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = pos(1)**2 + 2.0 * pos(2) + 3.0 + f = pos(1)**2 + 2.0 * pos(2) + 3.0 end function field_func_quadratic function field_func_cubic(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = 5.0 * pos(2)**3 + pos(1)**2 + 2.0 * pos(2) + 3.0 + f = 5.0 * pos(2)**3 + pos(1)**2 + 2.0 * pos(2) + 3.0 end function field_func_cubic function field_func_exp(pos) result(f) - real, dimension(:), intent(in) :: pos - real :: f + real, dimension(:), intent(in) :: pos + real :: f - f = exp(pos(1)**2 + 2.0 * pos(2)) + f = exp(pos(1)**2 + 2.0 * pos(2)) end function field_func_exp diff --git a/femtools/tests/test_constant_fields.F90 b/femtools/tests/test_constant_fields.F90 index c1061203ed..540f396200 100644 --- a/femtools/tests/test_constant_fields.F90 +++ b/femtools/tests/test_constant_fields.F90 @@ -1,148 +1,148 @@ subroutine test_constant_fields - use fields - use vtk_interfaces - use state_module - use unittest_tools - implicit none - - type(scalar_field) :: sfield - type(vector_field) :: vfield - type(tensor_field) :: tfield - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - logical :: fail - real, dimension(4) :: ele_s - real, dimension(3, 4) :: ele_v - real, dimension(3, 3, 4) :: ele_t - real :: node_s - real, dimension(3) :: node_v - real, dimension(3, 3) :: node_t - integer :: i, j, k, l - - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - - call allocate(sfield, mesh, "ScalarField", FIELD_TYPE_CONSTANT) - call set(sfield, 1.0) - - fail = .false. - if (node_count(sfield) /= node_count(mesh)) then - fail = .true. - end if - call report_test("[constant scalar fields]", fail, .false., "Constant fields have the same number of nodes.") - - fail = .false. - do i=1,node_count(sfield) - node_s = node_val(sfield, i) - if (node_s /= 1.0) then + use fields + use vtk_interfaces + use state_module + use unittest_tools + implicit none + + type(scalar_field) :: sfield + type(vector_field) :: vfield + type(tensor_field) :: tfield + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + logical :: fail + real, dimension(4) :: ele_s + real, dimension(3, 4) :: ele_v + real, dimension(3, 3, 4) :: ele_t + real :: node_s + real, dimension(3) :: node_v + real, dimension(3, 3) :: node_t + integer :: i, j, k, l + + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + + call allocate(sfield, mesh, "ScalarField", FIELD_TYPE_CONSTANT) + call set(sfield, 1.0) + + fail = .false. + if (node_count(sfield) /= node_count(mesh)) then fail = .true. - end if - end do - call report_test("[constant scalar fields]", fail, .false., "Constant fields should return the value you give them.") - - fail = .false. - do i=1,ele_count(sfield) - ele_s = ele_val(sfield, i) - if (any(ele_s /= 1.0)) then + end if + call report_test("[constant scalar fields]", fail, .false., "Constant fields have the same number of nodes.") + + fail = .false. + do i=1,node_count(sfield) + node_s = node_val(sfield, i) + if (node_s /= 1.0) then + fail = .true. + end if + end do + call report_test("[constant scalar fields]", fail, .false., "Constant fields should return the value you give them.") + + fail = .false. + do i=1,ele_count(sfield) + ele_s = ele_val(sfield, i) + if (any(ele_s /= 1.0)) then + fail = .true. + end if + end do + call report_test("[constant scalar fields]", fail, .false., "Constant fields should return the value you give them.") + + fail = .false. + if (size(sfield%val) /= 1) then fail = .true. - end if - end do - call report_test("[constant scalar fields]", fail, .false., "Constant fields should return the value you give them.") - - fail = .false. - if (size(sfield%val) /= 1) then - fail = .true. - write(0,*) "size(sfield%val) == ", size(sfield%val) - end if - call report_test("[constant scalar fields]", fail, .false., "Constant fields shouldn't allocate more than they need to.") - - call deallocate(sfield) - call allocate(vfield, 3, mesh, "VectorField", FIELD_TYPE_CONSTANT) - call set(vfield, (/1.0, 2.0, 3.0/)) - - fail = .false. - if (node_count(vfield) /= node_count(mesh)) then - fail = .true. - end if - call report_test("[constant vector fields]", fail, .false., "Constant fields have the same number of nodes.") - - fail = .false. - do i=1,node_count(vfield) - node_v = node_val(vfield, i) - if (any(node_v /= (/1.0, 2.0, 3.0/))) then + write(0,*) "size(sfield%val) == ", size(sfield%val) + end if + call report_test("[constant scalar fields]", fail, .false., "Constant fields shouldn't allocate more than they need to.") + + call deallocate(sfield) + call allocate(vfield, 3, mesh, "VectorField", FIELD_TYPE_CONSTANT) + call set(vfield, (/1.0, 2.0, 3.0/)) + + fail = .false. + if (node_count(vfield) /= node_count(mesh)) then fail = .true. - end if - end do - call report_test("[constant vector fields]", fail, .false., "Constant fields should return the value you give them.") - - fail = .false. - do i=1,ele_count(vfield) - ele_v = ele_val(vfield, i) - do j=1,ele_loc(mesh, 1) - do k=1,3 - if (ele_v(k, j) /= float(k)) then - fail = .true. - end if + end if + call report_test("[constant vector fields]", fail, .false., "Constant fields have the same number of nodes.") + + fail = .false. + do i=1,node_count(vfield) + node_v = node_val(vfield, i) + if (any(node_v /= (/1.0, 2.0, 3.0/))) then + fail = .true. + end if + end do + call report_test("[constant vector fields]", fail, .false., "Constant fields should return the value you give them.") + + fail = .false. + do i=1,ele_count(vfield) + ele_v = ele_val(vfield, i) + do j=1,ele_loc(mesh, 1) + do k=1,3 + if (ele_v(k, j) /= float(k)) then + fail = .true. + end if + end do end do - end do - end do - call report_test("[constant vector fields]", fail, .false., "Constant fields should return the value you give them.") - - fail = .false. - if (size(vfield%val(1,:)) /= 1) then - fail = .true. - end if - call report_test("[constant vector fields]", fail, .false., "Constant fields shouldn't allocate more than they need to.") - - call deallocate(vfield) - call allocate(tfield, mesh, "TensorField", FIELD_TYPE_CONSTANT) - node_t(1, :) = (/1.0, 2.0, 3.0/) - node_t(2, :) = (/4.0, 5.0, 6.0/) - node_t(3, :) = (/7.0, 8.0, 9.0/) - call set(tfield, node_t) - - fail = .false. - if (node_count(tfield) /= node_count(mesh)) then - fail = .true. - end if - call report_test("[constant tensor fields]", fail, .false., "Constant fields have the same number of nodes.") - - fail = .false. - do i=1,node_count(tfield) - node_t = node_val(tfield, i) - do j=1,3 - do k=1,3 - if (node_t(j, k) /= 3.0 * (j-1) + k) then - fail = .true. - end if + end do + call report_test("[constant vector fields]", fail, .false., "Constant fields should return the value you give them.") + + fail = .false. + if (size(vfield%val(1,:)) /= 1) then + fail = .true. + end if + call report_test("[constant vector fields]", fail, .false., "Constant fields shouldn't allocate more than they need to.") + + call deallocate(vfield) + call allocate(tfield, mesh, "TensorField", FIELD_TYPE_CONSTANT) + node_t(1, :) = (/1.0, 2.0, 3.0/) + node_t(2, :) = (/4.0, 5.0, 6.0/) + node_t(3, :) = (/7.0, 8.0, 9.0/) + call set(tfield, node_t) + + fail = .false. + if (node_count(tfield) /= node_count(mesh)) then + fail = .true. + end if + call report_test("[constant tensor fields]", fail, .false., "Constant fields have the same number of nodes.") + + fail = .false. + do i=1,node_count(tfield) + node_t = node_val(tfield, i) + do j=1,3 + do k=1,3 + if (node_t(j, k) /= 3.0 * (j-1) + k) then + fail = .true. + end if + end do end do - end do - end do - call report_test("[constant tensor fields]", fail, .false., "Constant fields should return the value you give them.") - - fail = .false. - do i=1,ele_count(tfield) - ele_t = ele_val(tfield, i) - do j=1,ele_loc(mesh, 1) - do k=1,3 - do l=1,3 - if (ele_t(k, l, j) /= 3.0 * (k-1) + l) then - fail = .true. - end if - end do + end do + call report_test("[constant tensor fields]", fail, .false., "Constant fields should return the value you give them.") + + fail = .false. + do i=1,ele_count(tfield) + ele_t = ele_val(tfield, i) + do j=1,ele_loc(mesh, 1) + do k=1,3 + do l=1,3 + if (ele_t(k, l, j) /= 3.0 * (k-1) + l) then + fail = .true. + end if + end do + end do end do - end do - end do - call report_test("[constant tensor fields]", fail, .false., "Constant fields should return the value you give them.") + end do + call report_test("[constant tensor fields]", fail, .false., "Constant fields should return the value you give them.") - fail = .false. - if (size(tfield%val, 3) /= 1) then - fail = .true. - end if - call report_test("[constant tensor fields]", fail, .false., "Constant fields shouldn't allocate more than they need to.") + fail = .false. + if (size(tfield%val, 3) /= 1) then + fail = .true. + end if + call report_test("[constant tensor fields]", fail, .false., "Constant fields shouldn't allocate more than they need to.") - !call vtk_write_fields("data/const_field", 0, positions, mesh, sfields=(/sfield/)) + !call vtk_write_fields("data/const_field", 0, positions, mesh, sfields=(/sfield/)) end subroutine test_constant_fields diff --git a/femtools/tests/test_cross_product.F90 b/femtools/tests/test_cross_product.F90 index bd33a3f6c5..afcada1aed 100644 --- a/femtools/tests/test_cross_product.F90 +++ b/femtools/tests/test_cross_product.F90 @@ -1,26 +1,26 @@ subroutine test_cross_product - use vector_tools - use unittest_tools - implicit none + use vector_tools + use unittest_tools + implicit none - real, dimension(3) :: a, b, cross - integer :: i - logical :: fail - character(len=20) :: buf + real, dimension(3) :: a, b, cross + integer :: i + logical :: fail + character(len=20) :: buf - do i=1,5 - write(buf,'(i0)') i + do i=1,5 + write(buf,'(i0)') i - a = random_vector(3) - b = random_vector(3) - cross = cross_product(a, b) + a = random_vector(3) + b = random_vector(3) + cross = cross_product(a, b) - fail = .false. - if (.not. fequals(dot_product(a, cross), 0.0)) fail = .true. - if (.not. fequals(dot_product(b, cross), 0.0)) fail = .true. - call report_test("[cross product " // trim(buf) // "]", fail, .false., & - "The cross product of two vectors is orthogonal to both.") - end do + fail = .false. + if (.not. fequals(dot_product(a, cross), 0.0)) fail = .true. + if (.not. fequals(dot_product(b, cross), 0.0)) fail = .true. + call report_test("[cross product " // trim(buf) // "]", fail, .false., & + "The cross product of two vectors is orthogonal to both.") + end do end subroutine test_cross_product diff --git a/femtools/tests/test_curl.F90 b/femtools/tests/test_curl.F90 index 744ce4e51f..de410e026e 100644 --- a/femtools/tests/test_curl.F90 +++ b/femtools/tests/test_curl.F90 @@ -1,54 +1,54 @@ subroutine test_curl - use fields - use field_derivatives - use vtk_interfaces - use state_module - use unittest_tools - implicit none - - type(scalar_field) :: field - type(vector_field) :: grad_field, curl_field - type(scalar_field) :: curl_norm - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - logical :: fail - - interface - function solution(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, mesh, "Field") - call allocate(grad_field, 3, mesh, "Vfield") - call allocate(curl_norm, mesh, "Norm of curl") - call allocate(curl_field, 3, mesh, "Curl") - - - call set_from_function(field, solution, positions) - call grad(field, positions, grad_field) - call curl(grad_field, positions, curl_norm=curl_norm, curl_field=curl_field) - - call vtk_write_fields("data/curl_out", 0, positions, mesh, sfields=(/field, curl_norm/), & - & vfields=(/curl_field/)) - - - fail = curl_norm%val .fne. 0.0 - call report_test("[curl]", fail, .false., "curl(grad(phi)) == 0 everywhere, remember?") + use fields + use field_derivatives + use vtk_interfaces + use state_module + use unittest_tools + implicit none + + type(scalar_field) :: field + type(vector_field) :: grad_field, curl_field + type(scalar_field) :: curl_norm + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + logical :: fail + + interface + function solution(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, mesh, "Field") + call allocate(grad_field, 3, mesh, "Vfield") + call allocate(curl_norm, mesh, "Norm of curl") + call allocate(curl_field, 3, mesh, "Curl") + + + call set_from_function(field, solution, positions) + call grad(field, positions, grad_field) + call curl(grad_field, positions, curl_norm=curl_norm, curl_field=curl_field) + + call vtk_write_fields("data/curl_out", 0, positions, mesh, sfields=(/field, curl_norm/), & + & vfields=(/curl_field/)) + + + fail = curl_norm%val .fne. 0.0 + call report_test("[curl]", fail, .false., "curl(grad(phi)) == 0 everywhere, remember?") end subroutine test_curl function solution(pos) - real :: solution - real, dimension(:) :: pos - real :: x,y,z - x = pos(1); y = pos(2); z = pos(3) + real :: solution + real, dimension(:) :: pos + real :: x,y,z + x = pos(1); y = pos(2); z = pos(3) - solution = x + y + solution = x + y end function solution diff --git a/femtools/tests/test_cv_faces.F90 b/femtools/tests/test_cv_faces.F90 index b2a6d953df..09b3f1b9d9 100644 --- a/femtools/tests/test_cv_faces.F90 +++ b/femtools/tests/test_cv_faces.F90 @@ -1,159 +1,159 @@ subroutine test_cv_faces - use cv_faces - use elements - use cv_shape_functions - - implicit none - - type(cv_faces_type) :: linear, quadratic, linear_tet - type(element_type) :: cv_p1p1, cv_p1p2, cv_p2p1, cv_p2p2, cv_p1p1_tet - type(element_type) :: cv_p1p1_bdy, cv_p1p2_bdy, cv_p2p1_bdy, cv_p2p2_bdy - integer :: i, j - - linear = find_cv_faces(vertices=3, dimension=2, polydegree=1, quaddegree=1) - linear_tet = find_cv_faces(vertices=4, dimension=3, polydegree=1, quaddegree=1) - quadratic = find_cv_faces(vertices=3, dimension=2, polydegree=2, quaddegree=2) - - write(0,*) 'linear' - do i = 1, size(linear%corners,1) - write(0,*) 'face = ', i - do j = 1, size(linear%corners,3) - write(0,*) 'corner = ', j - write(0,*) linear%corners(i,:,j) - end do - write(0,*) 'neiloc = ', linear%neiloc(:,i) - end do - do i = 1, size(linear%scorners,1) - write(0,*) 'sface = ', i - do j = 1, size(linear%scorners,3) - write(0,*) 'scorner = ', j - write(0,*) linear%scorners(i,:,j) - end do - write(0,*) 'sneiloc = ', linear%sneiloc(:,i) - end do - - write(0,*) 'quadratic' - do i = 1, size(quadratic%corners,1) - write(0,*) 'face = ', i - do j = 1, size(quadratic%corners,3) - write(0,*) 'corner = ', j - write(0,*) quadratic%corners(i,:,j) - end do - write(0,*) 'neiloc = ', quadratic%neiloc(:,i) - end do - do i = 1, size(quadratic%scorners,1) - write(0,*) 'sface = ', i - do j = 1, size(quadratic%scorners,3) - write(0,*) 'scorner = ', j - write(0,*) quadratic%scorners(i,:,j) - end do - write(0,*) 'sneiloc = ', quadratic%sneiloc(:,i) - end do - - cv_p1p1=make_cv_element_shape(linear, 1) - cv_p1p1_tet=make_cv_element_shape(linear_tet, 1) - cv_p2p1=make_cv_element_shape(linear, 2) - cv_p1p2=make_cv_element_shape(quadratic,1) - cv_p2p2=make_cv_element_shape(quadratic,2) - - write(0,*) 'p1p1' - do i = 1, size(cv_p1p1%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p1%n(:,gi) = ', cv_p1p1%n(:,i) - do j = 1,size(cv_p1p1%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p1p1%dn(:,gi,dim) = ', cv_p1p1%dn(:,i,j) - end do - write(0,*) 'cv_p1p1%quadrature%weight(gi) = ', cv_p1p1%quadrature%weight(i) - end do - - write(0,*) 'p1p1_tet' - do i = 1, size(cv_p1p1_tet%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p1_tet%n(:,gi) = ', cv_p1p1_tet%n(:,i) - do j = 1,size(cv_p1p1_tet%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p1p1_tet%dn(:,gi,dim) = ', cv_p1p1_tet%dn(:,i,j) - end do - write(0,*) 'cv_p1p1_tet%quadrature%weight(gi) = ', cv_p1p1_tet%quadrature%weight(i) - end do - - write(0,*) 'p2p1' - do i = 1, size(cv_p2p1%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p2p1%n(:,gi) = ', cv_p2p1%n(:,i) - do j = 1,size(cv_p2p1%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p2p1%dn(:,gi,dim) = ', cv_p2p1%dn(:,i,j) - end do - end do - - write(0,*) 'p1p2' - do i = 1, size(cv_p1p2%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p2%n(:,gi) = ', cv_p1p2%n(:,i) - do j = 1,size(cv_p1p2%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p1p2%dn(:,gi,dim) = ', cv_p1p2%dn(:,i,j) - end do - end do - - write(0,*) 'p2p2' - do i = 1, size(cv_p2p2%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p2p2%n(:,gi) = ', cv_p2p2%n(:,i) - do j = 1,size(cv_p2p2%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p2p2%dn(:,gi,dim) = ', cv_p2p2%dn(:,i,j) - end do - end do - - cv_p1p1_bdy=make_cvbdy_element_shape(linear, 1) - cv_p2p1_bdy=make_cvbdy_element_shape(linear, 2) - cv_p1p2_bdy=make_cvbdy_element_shape(quadratic,1) - cv_p2p2_bdy=make_cvbdy_element_shape(quadratic,2) - - write(0,*) 'p1p1_bdy' - do i = 1, size(cv_p1p1_bdy%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p1_bdy%n(:,gi) = ', cv_p1p1_bdy%n(:,i) - do j = 1,size(cv_p1p1_bdy%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p1p1_bdy%dn(:,gi,dim) = ', cv_p1p1_bdy%dn(:,i,j) - end do - end do - - write(0,*) 'p2p1_bdy' - do i = 1, size(cv_p2p1_bdy%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p2p1_bdy%n(:,gi) = ', cv_p2p1_bdy%n(:,i) - do j = 1,size(cv_p2p1_bdy%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p2p1_bdy%dn(:,gi,dim) = ', cv_p2p1_bdy%dn(:,i,j) - end do - end do - - write(0,*) 'p1p2_bdy' - do i = 1, size(cv_p1p2_bdy%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p1p2_bdy%n(:,gi) = ', cv_p1p2_bdy%n(:,i) - do j = 1,size(cv_p1p2_bdy%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p1p2_bdy%dn(:,gi,dim) = ', cv_p1p2_bdy%dn(:,i,j) - end do - end do - - write(0,*) 'p2p2_bdy' - do i = 1, size(cv_p2p2_bdy%n,2) - write(0,*) 'gi = ', i - write(0,*) 'cv_p2p2_bdy%n(:,gi) = ', cv_p2p2_bdy%n(:,i) - do j = 1,size(cv_p2p2_bdy%dn,3) - write(0,*) 'dim = ', j - write(0,*) 'cv_p2p2_bdy%dn(:,gi,dim) = ', cv_p2p2_bdy%dn(:,i,j) - end do - end do - - write(0,*) 'ending' + use cv_faces + use elements + use cv_shape_functions + + implicit none + + type(cv_faces_type) :: linear, quadratic, linear_tet + type(element_type) :: cv_p1p1, cv_p1p2, cv_p2p1, cv_p2p2, cv_p1p1_tet + type(element_type) :: cv_p1p1_bdy, cv_p1p2_bdy, cv_p2p1_bdy, cv_p2p2_bdy + integer :: i, j + + linear = find_cv_faces(vertices=3, dimension=2, polydegree=1, quaddegree=1) + linear_tet = find_cv_faces(vertices=4, dimension=3, polydegree=1, quaddegree=1) + quadratic = find_cv_faces(vertices=3, dimension=2, polydegree=2, quaddegree=2) + + write(0,*) 'linear' + do i = 1, size(linear%corners,1) + write(0,*) 'face = ', i + do j = 1, size(linear%corners,3) + write(0,*) 'corner = ', j + write(0,*) linear%corners(i,:,j) + end do + write(0,*) 'neiloc = ', linear%neiloc(:,i) + end do + do i = 1, size(linear%scorners,1) + write(0,*) 'sface = ', i + do j = 1, size(linear%scorners,3) + write(0,*) 'scorner = ', j + write(0,*) linear%scorners(i,:,j) + end do + write(0,*) 'sneiloc = ', linear%sneiloc(:,i) + end do + + write(0,*) 'quadratic' + do i = 1, size(quadratic%corners,1) + write(0,*) 'face = ', i + do j = 1, size(quadratic%corners,3) + write(0,*) 'corner = ', j + write(0,*) quadratic%corners(i,:,j) + end do + write(0,*) 'neiloc = ', quadratic%neiloc(:,i) + end do + do i = 1, size(quadratic%scorners,1) + write(0,*) 'sface = ', i + do j = 1, size(quadratic%scorners,3) + write(0,*) 'scorner = ', j + write(0,*) quadratic%scorners(i,:,j) + end do + write(0,*) 'sneiloc = ', quadratic%sneiloc(:,i) + end do + + cv_p1p1=make_cv_element_shape(linear, 1) + cv_p1p1_tet=make_cv_element_shape(linear_tet, 1) + cv_p2p1=make_cv_element_shape(linear, 2) + cv_p1p2=make_cv_element_shape(quadratic,1) + cv_p2p2=make_cv_element_shape(quadratic,2) + + write(0,*) 'p1p1' + do i = 1, size(cv_p1p1%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p1%n(:,gi) = ', cv_p1p1%n(:,i) + do j = 1,size(cv_p1p1%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p1p1%dn(:,gi,dim) = ', cv_p1p1%dn(:,i,j) + end do + write(0,*) 'cv_p1p1%quadrature%weight(gi) = ', cv_p1p1%quadrature%weight(i) + end do + + write(0,*) 'p1p1_tet' + do i = 1, size(cv_p1p1_tet%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p1_tet%n(:,gi) = ', cv_p1p1_tet%n(:,i) + do j = 1,size(cv_p1p1_tet%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p1p1_tet%dn(:,gi,dim) = ', cv_p1p1_tet%dn(:,i,j) + end do + write(0,*) 'cv_p1p1_tet%quadrature%weight(gi) = ', cv_p1p1_tet%quadrature%weight(i) + end do + + write(0,*) 'p2p1' + do i = 1, size(cv_p2p1%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p2p1%n(:,gi) = ', cv_p2p1%n(:,i) + do j = 1,size(cv_p2p1%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p2p1%dn(:,gi,dim) = ', cv_p2p1%dn(:,i,j) + end do + end do + + write(0,*) 'p1p2' + do i = 1, size(cv_p1p2%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p2%n(:,gi) = ', cv_p1p2%n(:,i) + do j = 1,size(cv_p1p2%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p1p2%dn(:,gi,dim) = ', cv_p1p2%dn(:,i,j) + end do + end do + + write(0,*) 'p2p2' + do i = 1, size(cv_p2p2%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p2p2%n(:,gi) = ', cv_p2p2%n(:,i) + do j = 1,size(cv_p2p2%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p2p2%dn(:,gi,dim) = ', cv_p2p2%dn(:,i,j) + end do + end do + + cv_p1p1_bdy=make_cvbdy_element_shape(linear, 1) + cv_p2p1_bdy=make_cvbdy_element_shape(linear, 2) + cv_p1p2_bdy=make_cvbdy_element_shape(quadratic,1) + cv_p2p2_bdy=make_cvbdy_element_shape(quadratic,2) + + write(0,*) 'p1p1_bdy' + do i = 1, size(cv_p1p1_bdy%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p1_bdy%n(:,gi) = ', cv_p1p1_bdy%n(:,i) + do j = 1,size(cv_p1p1_bdy%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p1p1_bdy%dn(:,gi,dim) = ', cv_p1p1_bdy%dn(:,i,j) + end do + end do + + write(0,*) 'p2p1_bdy' + do i = 1, size(cv_p2p1_bdy%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p2p1_bdy%n(:,gi) = ', cv_p2p1_bdy%n(:,i) + do j = 1,size(cv_p2p1_bdy%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p2p1_bdy%dn(:,gi,dim) = ', cv_p2p1_bdy%dn(:,i,j) + end do + end do + + write(0,*) 'p1p2_bdy' + do i = 1, size(cv_p1p2_bdy%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p1p2_bdy%n(:,gi) = ', cv_p1p2_bdy%n(:,i) + do j = 1,size(cv_p1p2_bdy%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p1p2_bdy%dn(:,gi,dim) = ', cv_p1p2_bdy%dn(:,i,j) + end do + end do + + write(0,*) 'p2p2_bdy' + do i = 1, size(cv_p2p2_bdy%n,2) + write(0,*) 'gi = ', i + write(0,*) 'cv_p2p2_bdy%n(:,gi) = ', cv_p2p2_bdy%n(:,i) + do j = 1,size(cv_p2p2_bdy%dn,3) + write(0,*) 'dim = ', j + write(0,*) 'cv_p2p2_bdy%dn(:,gi,dim) = ', cv_p2p2_bdy%dn(:,i,j) + end do + end do + + write(0,*) 'ending' end subroutine test_cv_faces diff --git a/femtools/tests/test_cylinder_hessian.F90 b/femtools/tests/test_cylinder_hessian.F90 index ad07e4f572..54ae902cc3 100644 --- a/femtools/tests/test_cylinder_hessian.F90 +++ b/femtools/tests/test_cylinder_hessian.F90 @@ -1,65 +1,65 @@ subroutine test_cylinder_hessian - use fields - use field_derivatives - use state_module - use vtk_interfaces - use unittest_tools - implicit none + use fields + use field_derivatives + use state_module + use vtk_interfaces + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field) :: pressure_field - type(tensor_field) :: hessian - logical :: fail = .false., warn = .false. - integer :: i, j, k - real :: x, y, z + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field) :: pressure_field + type(tensor_field) :: hessian + logical :: fail = .false., warn = .false. + integer :: i, j, k + real :: x, y, z - call vtk_read_state("data/test_cyl.vtu", state) + call vtk_read_state("data/test_cyl.vtu", state) - mesh => extract_mesh(state, "Mesh") - call add_faces(mesh) - position_field => extract_vector_field(state, "Coordinate") - ! Update mesh descriptor on positons - position_field%mesh=mesh + mesh => extract_mesh(state, "Mesh") + call add_faces(mesh) + position_field => extract_vector_field(state, "Coordinate") + ! Update mesh descriptor on positons + position_field%mesh=mesh - call allocate(pressure_field, mesh, "Pressure") + call allocate(pressure_field, mesh, "Pressure") - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = x - end do + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = x + end do - call allocate(hessian, mesh, "Hessian") - hessian%val = -99999.9 + call allocate(hessian, mesh, "Hessian") + hessian%val = -99999.9 - call compute_hessian(pressure_field, position_field, hessian) + call compute_hessian(pressure_field, position_field, hessian) - fail = .false. + fail = .false. - ! No element of val should be -99999.9 - if (any(hessian%val == -99999.9)) fail = .true. + ! No element of val should be -99999.9 + if (any(hessian%val == -99999.9)) fail = .true. - call report_test("[every value set]", fail, warn, "No element of val should be unwritten.") + call report_test("[every value set]", fail, warn, "No element of val should be unwritten.") - fail = .false. + fail = .false. - ! Every element of val should be 0.0 - do i=1,mesh%nodes - do j=1,3 - do k=1,3 - if (abs(hessian%val(j, k, i)) > epsilon(0.0_4)) then - print *, "i == ", i, "; j == ", j, "; k == ", k, "; val == ", hessian%val(j, k, i) - fail = .true. - end if + ! Every element of val should be 0.0 + do i=1,mesh%nodes + do j=1,3 + do k=1,3 + if (abs(hessian%val(j, k, i)) > epsilon(0.0_4)) then + print *, "i == ", i, "; j == ", j, "; k == ", k, "; val == ", hessian%val(j, k, i) + fail = .true. + end if + end do end do - end do - end do + end do - call report_test("[every value correct]", fail, warn, "The Hessian of a linear field is identically zero.") - call vtk_write_fields("data/cylinder_hessian", 0, position_field, mesh, sfields=(/pressure_field/), tfields=(/hessian/)) + call report_test("[every value correct]", fail, warn, "The Hessian of a linear field is identically zero.") + call vtk_write_fields("data/cylinder_hessian", 0, position_field, mesh, sfields=(/pressure_field/), tfields=(/hessian/)) end subroutine test_cylinder_hessian diff --git a/femtools/tests/test_dcsr_dcsraddto.F90 b/femtools/tests/test_dcsr_dcsraddto.F90 index 40edc97b6e..f40cdb91a3 100644 --- a/femtools/tests/test_dcsr_dcsraddto.F90 +++ b/femtools/tests/test_dcsr_dcsraddto.F90 @@ -1,41 +1,41 @@ !program to test dcsr_dcsraddto subroutine test_dcsr_dcsraddto - use sparse_tools - use unittest_tools - implicit none - ! - logical :: fail - type(dynamic_csr_matrix) :: m1,m2 - type(csr_matrix) :: m - real, dimension(3,3) :: mat - ! - call allocate(m1,3,3) - call allocate(m2,3,3) + use sparse_tools + use unittest_tools + implicit none + ! + logical :: fail + type(dynamic_csr_matrix) :: m1,m2 + type(csr_matrix) :: m + real, dimension(3,3) :: mat + ! + call allocate(m1,3,3) + call allocate(m2,3,3) - call set(m1,1,1,-1.0) - call set(m1,2,2,-1.0) - call set(m1,3,3,-1.0) - call set(m2,1,1,-1.0) - call set(m2,2,2,-1.0) - call set(m2,3,3,-1.0) - call set(m1,1,2,1.0) - call set(m1,2,1,1.0) - call set(m1,2,3,1.0) - call set(m1,3,2,1.0) + call set(m1,1,1,-1.0) + call set(m1,2,2,-1.0) + call set(m1,3,3,-1.0) + call set(m2,1,1,-1.0) + call set(m2,2,2,-1.0) + call set(m2,3,3,-1.0) + call set(m1,1,2,1.0) + call set(m1,2,1,1.0) + call set(m1,2,3,1.0) + call set(m1,3,2,1.0) - call addto(m1,m2) - m = dcsr2csr(m1) + call addto(m1,m2) + m = dcsr2csr(m1) - mat = 0. - mat(1,1) = -2. - mat(2,2) = -2. - mat(3,3) = -2. - mat(1,2) = 1. - mat(2,1) = 1. - mat(2,3) = 1. - mat(3,2) = 1. + mat = 0. + mat(1,1) = -2. + mat(2,2) = -2. + mat(3,3) = -2. + mat(1,2) = 1. + mat(2,1) = 1. + mat(2,3) = 1. + mat(3,2) = 1. - fail = maxval(abs(dense(m)-mat))>1.0e-5 - call report_test("[dcsr_dscr_addto]", fail, .false., "dscr_dcsraddto doesnt work") + fail = maxval(abs(dense(m)-mat))>1.0e-5 + call report_test("[dcsr_dscr_addto]", fail, .false., "dscr_dcsraddto doesnt work") end subroutine test_dcsr_dcsraddto diff --git a/femtools/tests/test_differentiate_field.F90 b/femtools/tests/test_differentiate_field.F90 index 5f1b5aefd7..81133c744c 100644 --- a/femtools/tests/test_differentiate_field.F90 +++ b/femtools/tests/test_differentiate_field.F90 @@ -1,120 +1,120 @@ subroutine test_differentiate_field - use elements - use fields - use field_derivatives - use state_module - use vtk_interfaces - use unittest_tools - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field) :: pressure_field - type(scalar_field), dimension(3) :: outfields - logical, dimension(3) :: derivatives = .true. - logical :: fail = .false., warn = .false. - integer :: i - character(len=20) :: buf - real :: x, y, z - - call vtk_read_state("data/test_spr.vtu", state) - - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - call allocate(pressure_field, mesh, "Pressure") - - do i=1,3 - write(buf,'(i0)') i - call allocate(outfields(i), mesh, "Derivative " // trim(buf)) - end do - - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = 2.0 * x + 3.0 * y - end do - - call differentiate_field(pressure_field, position_field, derivatives, outfields) - call vtk_write_fields("data/differentiate_field", 0, position_field, mesh, sfields=(/pressure_field, & - outfields/)) - - ! X derivative - do i=1,mesh%nodes - if (.not. fequals(outfields(1)%val(i), 2.0)) fail = .true. - end do - - call report_test("[linear exact x derivative]", fail, warn, "X derivative should be constant 2.0") - - fail = .false. - - ! Y derivative - do i=1,mesh%nodes - if (.not. fequals(outfields(2)%val(i), 3.0)) fail = .true. - end do - - call report_test("[linear exact y derivative]", fail, warn, "Y derivative should be constant 3.0") - - fail = .false. - - ! Z derivative - do i=1,mesh%nodes - if (.not. fequals(outfields(3)%val(i), 0.0)) fail = .true. - end do - - call report_test("[linear exact z derivative]", fail, warn, "Z derivative should be constant 0.0") - - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = 0.5 * x * x + 0.5 * y * y - end do - - call differentiate_field(pressure_field, position_field, derivatives, outfields) - call vtk_write_fields("data/differentiate_field", 1, position_field, mesh, sfields=(/pressure_field, & - outfields/)) - - fail = .false. - - ! X derivative - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - if (.not. fequals(outfields(1)%val(i), x, 0.15)) then - print *," i == ", i, "; x == ", x, "; diffx == ", outfields(1)%val(i) - fail = .true. - end if - end do - - call report_test("[quadratic exact x derivative]", fail, warn, "X derivative should be x") - - fail = .false. - - ! Y derivative - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - if (.not. fequals(outfields(2)%val(i), y, 0.15)) then - print *," i == ", i, "; y == ", y, "; diffy == ", outfields(2)%val(i) - fail = .true. - end if - end do - - call report_test("[quadratic exact y derivative]", fail, warn, "Y derivative should be y") - - fail = .false. - - ! Z derivative - do i=1,mesh%nodes - if (abs(outfields(3)%val(i)) .gt. epsilon(0.0_4)) then - print *," i == ", i, "; diffz == ", outfields(3)%val(i) - fail = .true. - end if - end do - - call report_test("[quadratic exact z derivative]", fail, warn, "Z derivative should be 0.0") + use elements + use fields + use field_derivatives + use state_module + use vtk_interfaces + use unittest_tools + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field) :: pressure_field + type(scalar_field), dimension(3) :: outfields + logical, dimension(3) :: derivatives = .true. + logical :: fail = .false., warn = .false. + integer :: i + character(len=20) :: buf + real :: x, y, z + + call vtk_read_state("data/test_spr.vtu", state) + + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + call allocate(pressure_field, mesh, "Pressure") + + do i=1,3 + write(buf,'(i0)') i + call allocate(outfields(i), mesh, "Derivative " // trim(buf)) + end do + + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = 2.0 * x + 3.0 * y + end do + + call differentiate_field(pressure_field, position_field, derivatives, outfields) + call vtk_write_fields("data/differentiate_field", 0, position_field, mesh, sfields=(/pressure_field, & + outfields/)) + + ! X derivative + do i=1,mesh%nodes + if (.not. fequals(outfields(1)%val(i), 2.0)) fail = .true. + end do + + call report_test("[linear exact x derivative]", fail, warn, "X derivative should be constant 2.0") + + fail = .false. + + ! Y derivative + do i=1,mesh%nodes + if (.not. fequals(outfields(2)%val(i), 3.0)) fail = .true. + end do + + call report_test("[linear exact y derivative]", fail, warn, "Y derivative should be constant 3.0") + + fail = .false. + + ! Z derivative + do i=1,mesh%nodes + if (.not. fequals(outfields(3)%val(i), 0.0)) fail = .true. + end do + + call report_test("[linear exact z derivative]", fail, warn, "Z derivative should be constant 0.0") + + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = 0.5 * x * x + 0.5 * y * y + end do + + call differentiate_field(pressure_field, position_field, derivatives, outfields) + call vtk_write_fields("data/differentiate_field", 1, position_field, mesh, sfields=(/pressure_field, & + outfields/)) + + fail = .false. + + ! X derivative + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + if (.not. fequals(outfields(1)%val(i), x, 0.15)) then + print *," i == ", i, "; x == ", x, "; diffx == ", outfields(1)%val(i) + fail = .true. + end if + end do + + call report_test("[quadratic exact x derivative]", fail, warn, "X derivative should be x") + + fail = .false. + + ! Y derivative + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + if (.not. fequals(outfields(2)%val(i), y, 0.15)) then + print *," i == ", i, "; y == ", y, "; diffy == ", outfields(2)%val(i) + fail = .true. + end if + end do + + call report_test("[quadratic exact y derivative]", fail, warn, "Y derivative should be y") + + fail = .false. + + ! Z derivative + do i=1,mesh%nodes + if (abs(outfields(3)%val(i)) .gt. epsilon(0.0_4)) then + print *," i == ", i, "; diffz == ", outfields(3)%val(i) + fail = .true. + end if + end do + + call report_test("[quadratic exact z derivative]", fail, warn, "Z derivative should be 0.0") end subroutine test_differentiate_field diff --git a/femtools/tests/test_differentiate_field_discontinuous.F90 b/femtools/tests/test_differentiate_field_discontinuous.F90 index 8c71f669d9..44e9e27c3e 100644 --- a/femtools/tests/test_differentiate_field_discontinuous.F90 +++ b/femtools/tests/test_differentiate_field_discontinuous.F90 @@ -1,88 +1,88 @@ subroutine test_differentiate_field_discontinuous - ! unit test to test differentiate_field_discontinuous in field_derivatives - ! computes linear discontuous gradient of pressure field from - ! quadratic polynomial, so should give the exact answer - use elements - use quadrature - use fields - use field_derivatives - use state_module - use vtk_interfaces - use unittest_tools - implicit none + ! unit test to test differentiate_field_discontinuous in field_derivatives + ! computes linear discontuous gradient of pressure field from + ! quadratic polynomial, so should give the exact answer + use elements + use quadrature + use fields + use field_derivatives + use state_module + use vtk_interfaces + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(mesh_type) qmesh, dgmesh - type(vector_field), pointer :: position_field - type(vector_field) qposition_field - type(scalar_field) :: pressure_field - type(scalar_field), dimension(3) :: outfields - type(element_type) qshape - logical, dimension(3) :: derivatives - logical :: failx, faily, failz, warn - integer :: i, ele - integer, dimension(:), pointer:: cgnodes, dgnodes - character(len=20) :: buf - real :: x, y, z, xyz(3), derx, dery, derz + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(mesh_type) qmesh, dgmesh + type(vector_field), pointer :: position_field + type(vector_field) qposition_field + type(scalar_field) :: pressure_field + type(scalar_field), dimension(3) :: outfields + type(element_type) qshape + logical, dimension(3) :: derivatives + logical :: failx, faily, failz, warn + integer :: i, ele + integer, dimension(:), pointer:: cgnodes, dgnodes + character(len=20) :: buf + real :: x, y, z, xyz(3), derx, dery, derz - call vtk_read_state("data/test_spr.vtu", state) + call vtk_read_state("data/test_spr.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - ! quadratic shape and quadratic continuous mesh - qshape=make_element_shape(4, 3, 2, mesh%shape%quadrature) - qmesh=make_mesh(mesh, qshape, name="QuadraticMesh") - ! linear discontinuous mesh - dgmesh=make_mesh(mesh, continuity=-1, name="LinearDGMesh") + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + ! quadratic shape and quadratic continuous mesh + qshape=make_element_shape(4, 3, 2, mesh%shape%quadrature) + qmesh=make_mesh(mesh, qshape, name="QuadraticMesh") + ! linear discontinuous mesh + dgmesh=make_mesh(mesh, continuity=-1, name="LinearDGMesh") - call allocate(pressure_field, qmesh, "Pressure") - call allocate(qposition_field, 3, qmesh, "QuadraticCoordinate") - call remap_field(position_field, qposition_field) + call allocate(pressure_field, qmesh, "Pressure") + call allocate(qposition_field, 3, qmesh, "QuadraticCoordinate") + call remap_field(position_field, qposition_field) - do i=1,3 - write(buf,'(i0)') i - call allocate(outfields(i), dgmesh, "Derivative " // trim(buf)) - end do + do i=1,3 + write(buf,'(i0)') i + call allocate(outfields(i), dgmesh, "Derivative " // trim(buf)) + end do - do i=1, node_count(qmesh) - xyz=node_val(qposition_field, i) - x = xyz(1) - y = xyz(2) - z = xyz(3) - call set(pressure_field, i, (x+2*y+3*z+7)*(4*x+5*y+6*z+8)) - end do - - derivatives=.true. ! ask for all derivatives - call differentiate_field(pressure_field, position_field, derivatives, outfields) - call vtk_write_fields("data/differentiate_field", 0, position_field, dgmesh, sfields=outfields) - failx=.false. - faily=.false. - failz=.false. - - do ele=1, ele_count(dgmesh) - cgnodes => ele_nodes(mesh, ele) - dgnodes => ele_nodes(dgmesh, ele) - do i=1, ele_loc(dgmesh, ele) - xyz=node_val(position_field, cgnodes(i)) + do i=1, node_count(qmesh) + xyz=node_val(qposition_field, i) x = xyz(1) y = xyz(2) z = xyz(3) - derx=node_val(outfields(1), dgnodes(i)) - if (.not. fequals(derx, 8*x+13*y+18*z+36, tol = 1.0e-10)) failx=.true. - dery=node_val(outfields(2), dgnodes(i)) - if (.not. fequals(dery, 13*x+20*y+27*z+51, tol = 1.0e-10)) faily=.true. - derz=node_val(outfields(3), dgnodes(i)) - if (.not. fequals(derz, 18*x+27*y+36*z+66, tol = 1.0e-10)) failz=.true. - end do - end do + call set(pressure_field, i, (x+2*y+3*z+7)*(4*x+5*y+6*z+8)) + end do + + derivatives=.true. ! ask for all derivatives + call differentiate_field(pressure_field, position_field, derivatives, outfields) + call vtk_write_fields("data/differentiate_field", 0, position_field, dgmesh, sfields=outfields) + failx=.false. + faily=.false. + failz=.false. + + do ele=1, ele_count(dgmesh) + cgnodes => ele_nodes(mesh, ele) + dgnodes => ele_nodes(dgmesh, ele) + do i=1, ele_loc(dgmesh, ele) + xyz=node_val(position_field, cgnodes(i)) + x = xyz(1) + y = xyz(2) + z = xyz(3) + derx=node_val(outfields(1), dgnodes(i)) + if (.not. fequals(derx, 8*x+13*y+18*z+36, tol = 1.0e-10)) failx=.true. + dery=node_val(outfields(2), dgnodes(i)) + if (.not. fequals(dery, 13*x+20*y+27*z+51, tol = 1.0e-10)) faily=.true. + derz=node_val(outfields(3), dgnodes(i)) + if (.not. fequals(derz, 18*x+27*y+36*z+66, tol = 1.0e-10)) failz=.true. + end do + end do - warn=.false. + warn=.false. - call report_test("[linear discontinous exact x derivative]", failx, warn, "X derivative is wrong") + call report_test("[linear discontinous exact x derivative]", failx, warn, "X derivative is wrong") - call report_test("[linear discontinous exact y derivative]", faily, warn, "Y derivative is wrong") + call report_test("[linear discontinous exact y derivative]", faily, warn, "Y derivative is wrong") - call report_test("[linear discontinous exact z derivative]", failz, warn, "Z derivative is wrong") + call report_test("[linear discontinous exact z derivative]", failz, warn, "Z derivative is wrong") end subroutine test_differentiate_field_discontinuous diff --git a/femtools/tests/test_distance_to_line.F90 b/femtools/tests/test_distance_to_line.F90 index 8cfaddfede..f95cf8acd7 100644 --- a/femtools/tests/test_distance_to_line.F90 +++ b/femtools/tests/test_distance_to_line.F90 @@ -1,31 +1,31 @@ subroutine test_distance_to_line - use unittest_tools - use surfacelabels, only: minimum_distance_to_line_segment - implicit none + use unittest_tools + use surfacelabels, only: minimum_distance_to_line_segment + implicit none - real, dimension(3) :: a, b, c - real :: correct, computed - logical :: fail + real, dimension(3) :: a, b, c + real :: correct, computed + logical :: fail - a = (/0.0, 0.0, 0.0/) - b = (/1.0, 0.0, 0.0/) - c = (/2.0, 0.0, 0.0/) - correct = 1.0 - computed = minimum_distance_to_line_segment(c, a, b) - fail = (correct .fne. computed) - call report_test("[distance_to_line]", fail, .false., "Dumdum") + a = (/0.0, 0.0, 0.0/) + b = (/1.0, 0.0, 0.0/) + c = (/2.0, 0.0, 0.0/) + correct = 1.0 + computed = minimum_distance_to_line_segment(c, a, b) + fail = (correct .fne. computed) + call report_test("[distance_to_line]", fail, .false., "Dumdum") - c = (/0.5, 0.5, 0.0/) - correct = 0.5 - computed = minimum_distance_to_line_segment(c, a, b) - fail = (correct .fne. computed) - call report_test("[distance_to_line]", fail, .false., "Dumdum") + c = (/0.5, 0.5, 0.0/) + correct = 0.5 + computed = minimum_distance_to_line_segment(c, a, b) + fail = (correct .fne. computed) + call report_test("[distance_to_line]", fail, .false., "Dumdum") - c = (/5.0, 1.0, 0.0/) - correct = sqrt(17.0) - computed = minimum_distance_to_line_segment(c, a, b) - fail = (correct .fne. computed) - call report_test("[distance_to_line]", fail, .false., "Dumdum") + c = (/5.0, 1.0, 0.0/) + correct = sqrt(17.0) + computed = minimum_distance_to_line_segment(c, a, b) + fail = (correct .fne. computed) + call report_test("[distance_to_line]", fail, .false., "Dumdum") end subroutine test_distance_to_line diff --git a/femtools/tests/test_div.F90 b/femtools/tests/test_div.F90 index 5724014795..631c3bb179 100644 --- a/femtools/tests/test_div.F90 +++ b/femtools/tests/test_div.F90 @@ -1,50 +1,50 @@ subroutine test_div - use fields - use field_derivatives - use vtk_interfaces - use state_module - use unittest_tools - implicit none + use fields + use field_derivatives + use vtk_interfaces + use state_module + use unittest_tools + implicit none - type(vector_field) :: field - type(scalar_field) :: divergence - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - logical :: fail + type(vector_field) :: field + type(scalar_field) :: divergence + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + logical :: fail - interface - function solution(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: solution - end function - end interface + interface + function solution(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: solution + end function + end interface - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") - call allocate(field, 3, mesh, "Field") - call allocate(divergence, mesh, "Div") + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") + call allocate(field, 3, mesh, "Field") + call allocate(divergence, mesh, "Div") - call set_from_function(field, solution, positions) - call div(field, positions, divergence) + call set_from_function(field, solution, positions) + call div(field, positions, divergence) - call vtk_write_fields("data/div_out", 0, positions, mesh, sfields=(/divergence/), & - & vfields=(/field/)) + call vtk_write_fields("data/div_out", 0, positions, mesh, sfields=(/divergence/), & + & vfields=(/field/)) - fail = any(divergence%val > 1e-12) - call report_test("[div]", fail, .false., "div(constant) == 0 everywhere, remember?") + fail = any(divergence%val > 1e-12) + call report_test("[div]", fail, .false., "div(constant) == 0 everywhere, remember?") end subroutine test_div function solution(pos) - real, dimension(:) :: pos - real, dimension(size(pos)) :: solution - real :: x,y,z - x = pos(1); y = pos(2); z = pos(3) + real, dimension(:) :: pos + real, dimension(size(pos)) :: solution + real :: x,y,z + x = pos(1); y = pos(2); z = pos(3) - solution = (/1.0, 2.0, 3.0/) + solution = (/1.0, 2.0, 3.0/) end function solution diff --git a/femtools/tests/test_dynamic_bin_sort.F90 b/femtools/tests/test_dynamic_bin_sort.F90 index 202f293dde..ca09276361 100644 --- a/femtools/tests/test_dynamic_bin_sort.F90 +++ b/femtools/tests/test_dynamic_bin_sort.F90 @@ -1,49 +1,49 @@ subroutine test_dynamic_bin_sort() ! tests the dynamic bin sort algorithm ! (a bin sort where entries may jump bin during the sort) -use dynamic_bin_sort_module -use unittest_tools -implicit none + use dynamic_bin_sort_module + use unittest_tools + implicit none - type(dynamic_bin_type) dbin - integer, parameter:: NBINS=10, NELEMENTS=10000 - integer, dimension(1:NELEMENTS):: binlist, sorted_list - logical sorted - real rnd - integer i, elm, bin_no + type(dynamic_bin_type) dbin + integer, parameter:: NBINS=10, NELEMENTS=10000 + integer, dimension(1:NELEMENTS):: binlist, sorted_list + logical sorted + real rnd + integer i, elm, bin_no - do i=1, NELEMENTS - call random_number(rnd) - binlist(i)=floor(rnd*NBINS)+1 - end do + do i=1, NELEMENTS + call random_number(rnd) + binlist(i)=floor(rnd*NBINS)+1 + end do - call allocate(dbin, binlist) + call allocate(dbin, binlist) - do i=1, NELEMENTS - call pull_element(dbin, sorted_list(i), bin_no) + do i=1, NELEMENTS + call pull_element(dbin, sorted_list(i), bin_no) - ! select random element: - call random_number(rnd) - elm=floor(rnd*NELEMENTS)+1 + ! select random element: + call random_number(rnd) + elm=floor(rnd*NELEMENTS)+1 - if (.not. element_pulled(dbin, elm)) then - ! element not pulled yet - ! move to somewhere >=bin_no - call random_number(rnd) - call move_element(dbin, elm, floor(rnd*(NBINS+1-bin_no))+bin_no) + if (.not. element_pulled(dbin, elm)) then + ! element not pulled yet + ! move to somewhere >=bin_no + call random_number(rnd) + call move_element(dbin, elm, floor(rnd*(NBINS+1-bin_no))+bin_no) - end if + end if - end do + end do - ! check if the resulting list is sorted: - sorted=.true. - do i=1, NELEMENTS-1 - sorted=sorted .and. (binlist(sorted_list(i))<=binlist(sorted_list(i+1))) - end do + ! check if the resulting list is sorted: + sorted=.true. + do i=1, NELEMENTS-1 + sorted=sorted .and. (binlist(sorted_list(i))<=binlist(sorted_list(i+1))) + end do - call deallocate(dbin) + call deallocate(dbin) - call report_test("[test_dynamic_bin_sort]", .not. sorted, .false., "resulting list not sorted") + call report_test("[test_dynamic_bin_sort]", .not. sorted, .false., "resulting list not sorted") end subroutine test_dynamic_bin_sort diff --git a/femtools/tests/test_eigendecomposition.F90 b/femtools/tests/test_eigendecomposition.F90 index fb88d4497b..18388bb06b 100644 --- a/femtools/tests/test_eigendecomposition.F90 +++ b/femtools/tests/test_eigendecomposition.F90 @@ -1,52 +1,52 @@ subroutine test_eigendecomposition - use unittest_tools - use vector_tools - implicit none + use unittest_tools + use vector_tools + implicit none - real, dimension(3, 3) :: mat, evecs, matout, tmp - real, dimension(3) :: evals, dot - logical :: fail, warn - integer :: i - character(len=20) :: buf + real, dimension(3, 3) :: mat, evecs, matout, tmp + real, dimension(3) :: evals, dot + logical :: fail, warn + integer :: i + character(len=20) :: buf - do i=1,5 - write(buf,'(i0)') i - fail = .false. - warn = .false. - mat = random_symmetric_matrix(3) - call eigendecomposition_symmetric(mat, evecs, evals) - matout = matmul(evecs, matmul(get_mat_diag(evals), transpose(evecs))) - tmp = mat - matout + do i=1,5 + write(buf,'(i0)') i + fail = .false. + warn = .false. + mat = random_symmetric_matrix(3) + call eigendecomposition_symmetric(mat, evecs, evals) + matout = matmul(evecs, matmul(get_mat_diag(evals), transpose(evecs))) + tmp = mat - matout - if (.not. mat_zero(tmp)) fail = .true. - call report_test("[eigendecomposition " // trim(buf) // "]", fail, warn, "M == V * A * V^T") - end do + if (.not. mat_zero(tmp)) fail = .true. + call report_test("[eigendecomposition " // trim(buf) // "]", fail, warn, "M == V * A * V^T") + end do - write(buf,'(i0)') 6 - fail = .false. - mat(1, :) = (/1.0, 0.0, 0.0/) - mat(2, :) = (/0.0, 1.0, 0.0/) - mat(3, :) = (/0.0, 0.0, 0.0/) - call eigendecomposition_symmetric(mat, evecs, evals) - if (.not. fequals(evals(1), 0.0)) fail = .true. - if (.not. fequals(evals(2), 1.0)) fail = .true. - if (.not. fequals(evals(3), 1.0)) fail = .true. - call report_test("[eigendecomposition " // trim(buf) // "]", fail, warn, "Eigendecomposition should handle degenerate matrices.") + write(buf,'(i0)') 6 + fail = .false. + mat(1, :) = (/1.0, 0.0, 0.0/) + mat(2, :) = (/0.0, 1.0, 0.0/) + mat(3, :) = (/0.0, 0.0, 0.0/) + call eigendecomposition_symmetric(mat, evecs, evals) + if (.not. fequals(evals(1), 0.0)) fail = .true. + if (.not. fequals(evals(2), 1.0)) fail = .true. + if (.not. fequals(evals(3), 1.0)) fail = .true. + call report_test("[eigendecomposition " // trim(buf) // "]", fail, warn, "Eigendecomposition should handle degenerate matrices.") - write(buf, '(i0)') 7 - fail = .false. - mat(:, 1) = (/1.00967933380561, 5.243225984041118E-003, -5.382979992872267E-005/) - mat(:, 2) = (/5.243225984041118E-003, 1.00284021806375, -2.915921812107133E-005/) - mat(:, 3) = (/-5.382979992872245E-005, -2.915921812107133E-005, 1.00000029936434/) - call eigendecomposition_symmetric(mat, evecs, evals) - dot(1) = dot_product(evecs(:, 1), evecs(:, 2)) - dot(2) = dot_product(evecs(:, 1), evecs(:, 3)) - dot(3) = dot_product(evecs(:, 2), evecs(:, 3)) - do i=1,3 - if (.not. fequals(dot(i), 0.0)) fail = .true. - end do - call report_test("[eigendecomposition " // trim(buf) // "]", fail, warn, "Eigendecomposition of symmetric & - & matrices should yield orthogonal eigenvectors.") + write(buf, '(i0)') 7 + fail = .false. + mat(:, 1) = (/1.00967933380561, 5.243225984041118E-003, -5.382979992872267E-005/) + mat(:, 2) = (/5.243225984041118E-003, 1.00284021806375, -2.915921812107133E-005/) + mat(:, 3) = (/-5.382979992872245E-005, -2.915921812107133E-005, 1.00000029936434/) + call eigendecomposition_symmetric(mat, evecs, evals) + dot(1) = dot_product(evecs(:, 1), evecs(:, 2)) + dot(2) = dot_product(evecs(:, 1), evecs(:, 3)) + dot(3) = dot_product(evecs(:, 2), evecs(:, 3)) + do i=1,3 + if (.not. fequals(dot(i), 0.0)) fail = .true. + end do + call report_test("[eigendecomposition " // trim(buf) // "]", fail, warn, "Eigendecomposition of symmetric & + & matrices should yield orthogonal eigenvectors.") end subroutine test_eigendecomposition diff --git a/femtools/tests/test_eigeninverse.F90 b/femtools/tests/test_eigeninverse.F90 index d104469d76..3639054308 100644 --- a/femtools/tests/test_eigeninverse.F90 +++ b/femtools/tests/test_eigeninverse.F90 @@ -1,24 +1,24 @@ subroutine test_eigeninverse - use unittest_tools - use vector_tools - implicit none + use unittest_tools + use vector_tools + implicit none - real, dimension(3, 3) :: mat, evecs - real, dimension(3) :: evals - logical :: fail + real, dimension(3, 3) :: mat, evecs + real, dimension(3) :: evals + logical :: fail - evecs(1, :) = (/-6.54163386e-01, -7.56353267e-01, 5.39898168e-16/) - evecs(2, :) = (/2.19406960e-16, -1.91603257e-15, -1.00000000e-00/) - evecs(3, :) = (/-7.56353267e-01, 6.54163386e-01, -6.41747296e-16/) - evals = (/2.51855956e+07, 2.49437236e+06+0, 1.94481173e-24/) + evecs(1, :) = (/-6.54163386e-01, -7.56353267e-01, 5.39898168e-16/) + evecs(2, :) = (/2.19406960e-16, -1.91603257e-15, -1.00000000e-00/) + evecs(3, :) = (/-7.56353267e-01, 6.54163386e-01, -6.41747296e-16/) + evals = (/2.51855956e+07, 2.49437236e+06+0, 1.94481173e-24/) - call eigenrecomposition(mat, evecs, evals) - call eigendecomposition(mat, evecs, evals) + call eigenrecomposition(mat, evecs, evals) + call eigendecomposition(mat, evecs, evals) - fail = .false. - if (any(evals < 0.0)) fail = .true. - call report_test("[inverse relationship of eigenrecomposition and decomposition]", & - fail, .false., "These operations should be inverses.") + fail = .false. + if (any(evals < 0.0)) fail = .true. + call report_test("[inverse relationship of eigenrecomposition and decomposition]", & + fail, .false., "These operations should be inverses.") end subroutine test_eigeninverse diff --git a/femtools/tests/test_eigenrecomposition.F90 b/femtools/tests/test_eigenrecomposition.F90 index 002280da0e..a16c9e2e0c 100644 --- a/femtools/tests/test_eigenrecomposition.F90 +++ b/femtools/tests/test_eigenrecomposition.F90 @@ -1,66 +1,66 @@ subroutine test_eigenrecomposition - use vector_tools - use unittest_tools - implicit none + use vector_tools + use unittest_tools + implicit none - real, dimension(3, 3) :: mat, matout, diff, vecs, newvecs - real, dimension(3) :: vals, newvals - real :: norm - integer :: i, j, k - logical :: fail = .false. - logical :: warn = .false. - character(len=12) :: buf + real, dimension(3, 3) :: mat, matout, diff, vecs, newvecs + real, dimension(3) :: vals, newvals + real :: norm + integer :: i, j, k + logical :: fail = .false. + logical :: warn = .false. + character(len=12) :: buf - do k=1,5 - mat = random_symmetric_matrix(3) + do k=1,5 + mat = random_symmetric_matrix(3) - matout = mat + matout = mat - call eigendecomposition_symmetric(mat, vecs, vals) - call eigenrecomposition(matout, vecs, vals) + call eigendecomposition_symmetric(mat, vecs, vals) + call eigenrecomposition(matout, vecs, vals) - diff = matout - mat + diff = matout - mat - do i=1,3 - do j=1,3 - if (.not. fequals(diff(i, j), 0.0)) fail = .true. + do i=1,3 + do j=1,3 + if (.not. fequals(diff(i, j), 0.0)) fail = .true. + end do end do - end do - - write(buf,'(i0)') k - call report_test("[eigenrecomposition " // trim(buf) // "]", fail, warn, & - "Eigenrecomposition and eigendecomposition should be inverses.") - end do - - do k=6,10 - write(buf,'(i0)') k - mat = random_symmetric_matrix(3) - - matout = mat - - call eigendecomposition_symmetric(mat, vecs, vals) - call eigenrecomposition(matout, vecs, vals) - call eigendecomposition_symmetric(matout, newvecs, newvals) - - norm = 0.0 - do i=1,3 - norm = norm + abs(newvals(i) - vals(i))**2 - end do - if (.not. fequals(norm, 0.0)) fail = .true. - call report_test("[eigenrecomposition values " // trim(buf) // "]", fail, warn, "Eigenvalues should stay the same.") - - fail = .false. - diff = newvecs - vecs - do i=1,3 - do j=1,3 - if (.not. fequals(diff(i, j), 0.0)) fail = .true. + + write(buf,'(i0)') k + call report_test("[eigenrecomposition " // trim(buf) // "]", fail, warn, & + "Eigenrecomposition and eigendecomposition should be inverses.") + end do + + do k=6,10 + write(buf,'(i0)') k + mat = random_symmetric_matrix(3) + + matout = mat + + call eigendecomposition_symmetric(mat, vecs, vals) + call eigenrecomposition(matout, vecs, vals) + call eigendecomposition_symmetric(matout, newvecs, newvals) + + norm = 0.0 + do i=1,3 + norm = norm + abs(newvals(i) - vals(i))**2 + end do + if (.not. fequals(norm, 0.0)) fail = .true. + call report_test("[eigenrecomposition values " // trim(buf) // "]", fail, warn, "Eigenvalues should stay the same.") + + fail = .false. + diff = newvecs - vecs + do i=1,3 + do j=1,3 + if (.not. fequals(diff(i, j), 0.0)) fail = .true. + end do end do - end do - call report_test("[eigenrecomposition vectors " // trim(buf) // "]", fail, warn, "Eigenvectors should stay the same.") - end do + call report_test("[eigenrecomposition vectors " // trim(buf) // "]", fail, warn, "Eigenvectors should stay the same.") + end do ! vals = (/1.00000000000000, 1.00000000000000, 1.00000000000000/) ! vecs(:, 1) = (/0.879271809685662, 0.476295258761135, -4.889905291923050E-003/) diff --git a/femtools/tests/test_ele_local_num.F90 b/femtools/tests/test_ele_local_num.F90 index 7cb167c063..8e1e44ab94 100644 --- a/femtools/tests/test_ele_local_num.F90 +++ b/femtools/tests/test_ele_local_num.F90 @@ -1,73 +1,73 @@ subroutine test_ele_local_num - use element_numbering - use unittest_tools - implicit none + use element_numbering + use unittest_tools + implicit none - type(ele_numbering_type), pointer:: ele_num - integer:: i - logical:: pass + type(ele_numbering_type), pointer:: ele_num + integer:: i + logical:: pass - ! 4th degree interval - ele_num => find_element_numbering(2, 1, 4) + ! 4th degree interval + ele_num => find_element_numbering(2, 1, 4) - pass = all( ele_local_num( (/1,2/), ele_num)==(/ 1, 2, 3, 4, 5 /) ) - call report_test("[ele_local_num on 4th degree interval]", .not. pass, .false., "wrong output") + pass = all( ele_local_num( (/1,2/), ele_num)==(/ 1, 2, 3, 4, 5 /) ) + call report_test("[ele_local_num on 4th degree interval]", .not. pass, .false., "wrong output") - pass = all( ele_local_num( (/2,1/), ele_num)==(/ 5, 4, 3, 2, 1 /) ) - call report_test("[ele_local_num on 4th degree interval reversed]", .not. pass, .false., "wrong output") + pass = all( ele_local_num( (/2,1/), ele_num)==(/ 5, 4, 3, 2, 1 /) ) + call report_test("[ele_local_num on 4th degree interval reversed]", .not. pass, .false., "wrong output") - ! 2nd degree triangle - ele_num => find_element_numbering(3, 2, 2) + ! 2nd degree triangle + ele_num => find_element_numbering(3, 2, 2) - pass = all( ele_local_num( (/1,2,3/), ele_num)==(/ 1, 2, 3, 4, 5, 6 /) ) - call report_test("[ele_local_num on 2nd degree triangle]", .not. pass, .false., "wrong output") + pass = all( ele_local_num( (/1,2,3/), ele_num)==(/ 1, 2, 3, 4, 5, 6 /) ) + call report_test("[ele_local_num on 2nd degree triangle]", .not. pass, .false., "wrong output") - pass = all( ele_local_num( (/3,2,1/), ele_num)==(/ 6, 5, 3, 4, 2, 1 /) ) - call report_test("[ele_local_num on 2nd degree triangle reordered]", .not. pass, .false., "wrong output") + pass = all( ele_local_num( (/3,2,1/), ele_num)==(/ 6, 5, 3, 4, 2, 1 /) ) + call report_test("[ele_local_num on 2nd degree triangle reordered]", .not. pass, .false., "wrong output") - ! 2nd degree tet - ele_num => find_element_numbering(4, 3, 2) + ! 2nd degree tet + ele_num => find_element_numbering(4, 3, 2) - pass = all( ele_local_num( (/1,2,3,4/), ele_num)==(/ (i, i=1,10) /) ) - call report_test("[ele_local_num on 2nd degree tet]", .not. pass, .false., "wrong output") + pass = all( ele_local_num( (/1,2,3,4/), ele_num)==(/ (i, i=1,10) /) ) + call report_test("[ele_local_num on 2nd degree tet]", .not. pass, .false., "wrong output") - pass = all( ele_local_num( (/3,1,4,2/), ele_num)==(/ 6, 4, 1, 9, 7, 10, 5, 2, 8, 3 /)) - call report_test("[ele_local_num on 2nd degree tet reordered]", .not. pass, .false., "wrong output") + pass = all( ele_local_num( (/3,1,4,2/), ele_num)==(/ 6, 4, 1, 9, 7, 10, 5, 2, 8, 3 /)) + call report_test("[ele_local_num on 2nd degree tet reordered]", .not. pass, .false., "wrong output") - ! edges of linear quad - ele_num => find_element_numbering(4, 2, 1) + ! edges of linear quad + ele_num => find_element_numbering(4, 2, 1) - pass = all( edge_local_num( (/1,2/), ele_num, interior = .false.) == (/ 1,3 /)) - call report_test("[edge_local_num on linear quad vertices 1 and 2]", .not. pass, .false., "wrong output") + pass = all( edge_local_num( (/1,2/), ele_num, interior = .false.) == (/ 1,3 /)) + call report_test("[edge_local_num on linear quad vertices 1 and 2]", .not. pass, .false., "wrong output") - pass = all( edge_local_num( (/3,4/), ele_num, interior = .false.) == (/ 2,4 /)) - call report_test("[edge_local_num on linear quad vertices 4 and 3]", .not. pass, .false., "wrong output") + pass = all( edge_local_num( (/3,4/), ele_num, interior = .false.) == (/ 2,4 /)) + call report_test("[edge_local_num on linear quad vertices 4 and 3]", .not. pass, .false., "wrong output") - pass = all( edge_local_num( (/1,3/), ele_num, interior = .false.) == (/ 1,2 /)) - call report_test("[edge_local_num on linear quad vertices 1 and 3]", .not. pass, .false., "wrong output") + pass = all( edge_local_num( (/1,3/), ele_num, interior = .false.) == (/ 1,2 /)) + call report_test("[edge_local_num on linear quad vertices 1 and 3]", .not. pass, .false., "wrong output") - pass = all( edge_local_num( (/2,4/), ele_num, interior = .false.) == (/ 3,4 /)) - call report_test("[edge_local_num on linear quad vertices 4 and 2]", .not. pass, .false., "wrong output") + pass = all( edge_local_num( (/2,4/), ele_num, interior = .false.) == (/ 3,4 /)) + call report_test("[edge_local_num on linear quad vertices 4 and 2]", .not. pass, .false., "wrong output") - ! Faces of linear hex - ele_num => find_element_numbering(8, 3, 1) + ! Faces of linear hex + ele_num => find_element_numbering(8, 3, 1) - pass = all( face_local_num( (/7,3,5,1/), ele_num, interior = .false.) == (/4,3,2,1/)) - call report_test("[face_local_num on linear hex vertices 7,3,5,1]", .not. pass, .false., "wrong output") + pass = all( face_local_num( (/7,3,5,1/), ele_num, interior = .false.) == (/4,3,2,1/)) + call report_test("[face_local_num on linear hex vertices 7,3,5,1]", .not. pass, .false., "wrong output") - pass = all( face_local_num( (/2,4,6,8/), ele_num, interior = .false.) == (/5,7,6,8/)) - call report_test("[face_local_num on linear hex vertices 2,4,6,7]", .not. pass, .false., "wrong output") + pass = all( face_local_num( (/2,4,6,8/), ele_num, interior = .false.) == (/5,7,6,8/)) + call report_test("[face_local_num on linear hex vertices 2,4,6,7]", .not. pass, .false., "wrong output") - pass = all( face_local_num( (/1,5,2,6/), ele_num, interior = .false.) == (/1,2,5,6/)) - call report_test("[face_local_num on linear hex vertices 1,5,2,6]", .not. pass, .false., "wrong output") + pass = all( face_local_num( (/1,5,2,6/), ele_num, interior = .false.) == (/1,2,5,6/)) + call report_test("[face_local_num on linear hex vertices 1,5,2,6]", .not. pass, .false., "wrong output") - pass = all( face_local_num( (/3,4,7,8/), ele_num, interior = .false.) == (/3,7,4,8/)) - call report_test("[face_local_num on linear hex vertices 3,4,7,8]", .not. pass, .false., "wrong output") + pass = all( face_local_num( (/3,4,7,8/), ele_num, interior = .false.) == (/3,7,4,8/)) + call report_test("[face_local_num on linear hex vertices 3,4,7,8]", .not. pass, .false., "wrong output") - pass = all( face_local_num( (/1,3,2,4/), ele_num, interior = .false.) == (/1,3,5,7/)) - call report_test("[face_local_num on linear hex vertices 1,3,2,4]", .not. pass, .false., "wrong output") + pass = all( face_local_num( (/1,3,2,4/), ele_num, interior = .false.) == (/1,3,5,7/)) + call report_test("[face_local_num on linear hex vertices 1,3,2,4]", .not. pass, .false., "wrong output") - pass = all( face_local_num( (/5,6,7,8/), ele_num, interior = .false.) == (/2,6,4,8/)) - call report_test("[face_local_num on linear hex vertices 5,6,7,8]", .not. pass, .false., "wrong output") + pass = all( face_local_num( (/5,6,7,8/), ele_num, interior = .false.) == (/2,6,4,8/)) + call report_test("[face_local_num on linear hex vertices 5,6,7,8]", .not. pass, .false., "wrong output") end subroutine test_ele_local_num diff --git a/femtools/tests/test_elementwise_fields.F90 b/femtools/tests/test_elementwise_fields.F90 index 135dd99d82..9563f8a853 100644 --- a/femtools/tests/test_elementwise_fields.F90 +++ b/femtools/tests/test_elementwise_fields.F90 @@ -1,27 +1,27 @@ subroutine test_elementwise_fields - use vtk_interfaces - use fields - use sparsity_patterns - use state_module - use unittest_tools - implicit none + use vtk_interfaces + use fields + use sparsity_patterns + use state_module + use unittest_tools + implicit none - type(state_type) :: state - type(scalar_field) :: elementwise - integer :: i + type(state_type) :: state + type(scalar_field) :: elementwise + integer :: i - call vtk_read_state("data/sparsity_0.vtu", state) - elementwise = piecewise_constant_field(state%meshes(1), "Element numbering") + call vtk_read_state("data/sparsity_0.vtu", state) + elementwise = piecewise_constant_field(state%meshes(1), "Element numbering") - do i=1,element_count(elementwise) - call addto(elementwise, i, float(i)) - end do + do i=1,element_count(elementwise) + call addto(elementwise, i, float(i)) + end do - call insert(state, elementwise, "Element numbering") - call vtk_write_state("data/elementwise", 0, state=state) + call insert(state, elementwise, "Element numbering") + call vtk_write_state("data/elementwise", 0, state=state) - call report_test("[elementwise fields]", .false., .false., "If it doesn't crash you're on to a winner") + call report_test("[elementwise fields]", .false., .false., "If it doesn't crash you're on to a winner") - call deallocate(state) + call deallocate(state) end subroutine test_elementwise_fields diff --git a/femtools/tests/test_fields_reference_counting.F90 b/femtools/tests/test_fields_reference_counting.F90 index 70bd6fef44..76e115022d 100644 --- a/femtools/tests/test_fields_reference_counting.F90 +++ b/femtools/tests/test_fields_reference_counting.F90 @@ -26,24 +26,24 @@ ! USA subroutine test_fields_reference_counting - !!< Test that basic integration and differentiation of 1d elements works. - use fields - use mesh_files - use unittest_tools - implicit none + !!< Test that basic integration and differentiation of 1d elements works. + use fields + use mesh_files + use unittest_tools + implicit none - logical :: fail - type(vector_field) :: X + logical :: fail + type(vector_field) :: X - X=read_mesh_files("data/interval", quad_degree=4, format="gmsh") + X=read_mesh_files("data/interval", quad_degree=4, format="gmsh") - call incref(X%mesh) + call incref(X%mesh) - call decref(X%mesh) + call decref(X%mesh) - fail=(X%mesh%refcount%count/=1) + fail=(X%mesh%refcount%count/=1) - call report_test("[test_fields_reference_counting]", fail, .false., & - "Reference count is not 1") + call report_test("[test_fields_reference_counting]", fail, .false., & + "Reference count is not 1") end subroutine test_fields_reference_counting diff --git a/femtools/tests/test_find_node_ownership_af.F90 b/femtools/tests/test_find_node_ownership_af.F90 index d9468dcf3e..a081bc3863 100644 --- a/femtools/tests/test_find_node_ownership_af.F90 +++ b/femtools/tests/test_find_node_ownership_af.F90 @@ -29,47 +29,47 @@ subroutine test_find_node_ownership_af - use fields - use fldebug - use node_ownership - use mesh_files - use unittest_tools - use transform_elements + use fields + use fldebug + use node_ownership + use mesh_files + use unittest_tools + use transform_elements - implicit none + implicit none - integer :: i - real, dimension(:), allocatable :: l_coords - integer, dimension(:), allocatable :: nodeownership - logical :: fail - type(vector_field) :: positions1, positions2 + integer :: i + real, dimension(:), allocatable :: l_coords + integer, dimension(:), allocatable :: nodeownership + logical :: fail + type(vector_field) :: positions1, positions2 - positions1 = read_mesh_files("data/rotated_square.1", quad_degree = 1, format="gmsh") - positions2 = read_mesh_files("data/rotated_square.2", quad_degree = 1, format="gmsh") + positions1 = read_mesh_files("data/rotated_square.1", quad_degree = 1, format="gmsh") + positions2 = read_mesh_files("data/rotated_square.2", quad_degree = 1, format="gmsh") - allocate(nodeownership(node_count(positions2))) - call find_node_ownership_af(positions1, positions2, nodeownership) + allocate(nodeownership(node_count(positions2))) + call find_node_ownership_af(positions1, positions2, nodeownership) - call report_test("[All node owners found]", any(nodeownership < 0), .false., "Not all node owners found") + call report_test("[All node owners found]", any(nodeownership < 0), .false., "Not all node owners found") - call report_test("[Correct map size]", size(nodeownership) /= node_count(positions2), .false., "Incorrect map size") - fail = .false. - do i = 1, node_count(positions2) - allocate(l_coords(ele_loc(positions1, nodeownership(i)))) - l_coords = local_coords(positions1, nodeownership(i), node_val(positions2, i)) - if(any(l_coords < - default_ownership_tolerance)) then - fail = .true. - exit - end if - deallocate(l_coords) - end do - call report_test("[Valid map]", fail, .false., "Invalid map") + call report_test("[Correct map size]", size(nodeownership) /= node_count(positions2), .false., "Incorrect map size") + fail = .false. + do i = 1, node_count(positions2) + allocate(l_coords(ele_loc(positions1, nodeownership(i)))) + l_coords = local_coords(positions1, nodeownership(i), node_val(positions2, i)) + if(any(l_coords < - default_ownership_tolerance)) then + fail = .true. + exit + end if + deallocate(l_coords) + end do + call report_test("[Valid map]", fail, .false., "Invalid map") - deallocate(nodeownership) + deallocate(nodeownership) - call deallocate(positions1) - call deallocate(positions2) + call deallocate(positions1) + call deallocate(positions2) - call report_test_no_references() + call report_test_no_references() end subroutine test_find_node_ownership_af diff --git a/femtools/tests/test_find_node_ownership_if.F90 b/femtools/tests/test_find_node_ownership_if.F90 index b5bc098545..f3ca6ed441 100644 --- a/femtools/tests/test_find_node_ownership_if.F90 +++ b/femtools/tests/test_find_node_ownership_if.F90 @@ -29,47 +29,47 @@ subroutine test_find_node_ownership_if - use fields - use fldebug - use node_ownership - use mesh_files - use unittest_tools - use transform_elements + use fields + use fldebug + use node_ownership + use mesh_files + use unittest_tools + use transform_elements - implicit none + implicit none - integer :: i - real, dimension(:), allocatable :: l_coords - integer, dimension(:), allocatable :: nodeownership - logical :: fail - type(vector_field) :: positions1, positions2 + integer :: i + real, dimension(:), allocatable :: l_coords + integer, dimension(:), allocatable :: nodeownership + logical :: fail + type(vector_field) :: positions1, positions2 - positions1 = read_mesh_files("data/rotated_square.1", quad_degree = 1, format="gmsh") - positions2 = read_mesh_files("data/rotated_square.2", quad_degree = 1, format="gmsh") + positions1 = read_mesh_files("data/rotated_square.1", quad_degree = 1, format="gmsh") + positions2 = read_mesh_files("data/rotated_square.2", quad_degree = 1, format="gmsh") - allocate(nodeownership(node_count(positions2))) - call find_node_ownership_if(positions1, positions2, nodeownership) + allocate(nodeownership(node_count(positions2))) + call find_node_ownership_if(positions1, positions2, nodeownership) - call report_test("[All node owners found]", any(nodeownership < 0), .false., "Not all node owners found") + call report_test("[All node owners found]", any(nodeownership < 0), .false., "Not all node owners found") - call report_test("[Correct map size]", size(nodeownership) /= node_count(positions2), .false., "Incorrect map size") - fail = .false. - do i = 1, node_count(positions2) - allocate(l_coords(ele_loc(positions1, nodeownership(i)))) - l_coords = local_coords(positions1, nodeownership(i), node_val(positions2, i)) - if(any(l_coords < - default_ownership_tolerance)) then - fail = .true. - exit - end if - deallocate(l_coords) - end do - call report_test("[Valid map]", fail, .false., "Invalid map") + call report_test("[Correct map size]", size(nodeownership) /= node_count(positions2), .false., "Incorrect map size") + fail = .false. + do i = 1, node_count(positions2) + allocate(l_coords(ele_loc(positions1, nodeownership(i)))) + l_coords = local_coords(positions1, nodeownership(i), node_val(positions2, i)) + if(any(l_coords < - default_ownership_tolerance)) then + fail = .true. + exit + end if + deallocate(l_coords) + end do + call report_test("[Valid map]", fail, .false., "Invalid map") - deallocate(nodeownership) + deallocate(nodeownership) - call deallocate(positions1) - call deallocate(positions2) + call deallocate(positions1) + call deallocate(positions2) - call report_test_no_references() + call report_test_no_references() end subroutine test_find_node_ownership_if diff --git a/femtools/tests/test_find_node_ownership_rtree.F90 b/femtools/tests/test_find_node_ownership_rtree.F90 index d085b9632e..28f3f5d342 100644 --- a/femtools/tests/test_find_node_ownership_rtree.F90 +++ b/femtools/tests/test_find_node_ownership_rtree.F90 @@ -29,47 +29,47 @@ subroutine test_find_node_ownership_rtree - use fields - use fldebug - use node_ownership - use mesh_files - use unittest_tools - use transform_elements + use fields + use fldebug + use node_ownership + use mesh_files + use unittest_tools + use transform_elements - implicit none + implicit none - integer :: i - real, dimension(:), allocatable :: l_coords - integer, dimension(:), allocatable :: nodeownership - logical :: fail - type(vector_field) :: positions1, positions2 + integer :: i + real, dimension(:), allocatable :: l_coords + integer, dimension(:), allocatable :: nodeownership + logical :: fail + type(vector_field) :: positions1, positions2 - positions1 = read_mesh_files("data/rotated_square.1", quad_degree = 1, format="gmsh") - positions2 = read_mesh_files("data/rotated_square.2", quad_degree = 1, format="gmsh") + positions1 = read_mesh_files("data/rotated_square.1", quad_degree = 1, format="gmsh") + positions2 = read_mesh_files("data/rotated_square.2", quad_degree = 1, format="gmsh") - allocate(nodeownership(node_count(positions2))) - call find_node_ownership_rtree(positions1, positions2, nodeownership) + allocate(nodeownership(node_count(positions2))) + call find_node_ownership_rtree(positions1, positions2, nodeownership) - call report_test("[All node owners found]", any(nodeownership < 0), .false., "Not all node owners found") + call report_test("[All node owners found]", any(nodeownership < 0), .false., "Not all node owners found") - call report_test("[Correct map size]", size(nodeownership) /= node_count(positions2), .false., "Incorrect map size") - fail = .false. - do i = 1, node_count(positions2) - allocate(l_coords(ele_loc(positions1, nodeownership(i)))) - l_coords = local_coords(positions1, nodeownership(i), node_val(positions2, i)) - if(any(l_coords < - default_ownership_tolerance)) then - fail = .true. - exit - end if - deallocate(l_coords) - end do - call report_test("[Valid map]", fail, .false., "Invalid map") + call report_test("[Correct map size]", size(nodeownership) /= node_count(positions2), .false., "Incorrect map size") + fail = .false. + do i = 1, node_count(positions2) + allocate(l_coords(ele_loc(positions1, nodeownership(i)))) + l_coords = local_coords(positions1, nodeownership(i), node_val(positions2, i)) + if(any(l_coords < - default_ownership_tolerance)) then + fail = .true. + exit + end if + deallocate(l_coords) + end do + call report_test("[Valid map]", fail, .false., "Invalid map") - deallocate(nodeownership) + deallocate(nodeownership) - call deallocate(positions1) - call deallocate(positions2) + call deallocate(positions1) + call deallocate(positions2) - call report_test_no_references() + call report_test_no_references() end subroutine test_find_node_ownership_rtree diff --git a/femtools/tests/test_galerkin_projection_diagnostic.F90 b/femtools/tests/test_galerkin_projection_diagnostic.F90 index 8faca4df1c..06ce55abb2 100644 --- a/femtools/tests/test_galerkin_projection_diagnostic.F90 +++ b/femtools/tests/test_galerkin_projection_diagnostic.F90 @@ -1,54 +1,54 @@ subroutine test_galerkin_projection_diagnostic - use diagnostic_fields - use state_module - use fields - use mesh_files - use unittest_tools - use solvers - use spud - implicit none - - interface - function field_func_tensor(pos) result(solution) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos), size(pos)) :: solution - end function - end interface - - type(vector_field) :: positions - type(tensor_field) :: tensA, tensB - type(mesh_type) :: pwc_mesh - character(len=255) :: path = "/solvers" - type(state_type) :: state - integer :: stat - logical :: fail - - positions = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") - pwc_mesh = piecewise_constant_mesh(positions%mesh, "PiecewiseConstantMesh") - call allocate(tensA, pwc_mesh, "TensorA") - call set_from_function(tensA, field_func_tensor, positions) - - call allocate(tensB, positions%mesh, "TensorB") - call zero(tensB) - tensB%option_path = "/hello" - call set_option(trim(tensB%option_path) // '/diagnostic/source_field_name', 'TensorA', stat=stat) - - call set_solver_options(path, ksptype='cg', pctype='sor', rtol=1.0e-10, max_its=10000) - call insert(state, tensA, "TensorA") - call insert(state, positions, "Coordinate") - - call calculate_galerkin_projection(state, tensB, path) - - fail = node_val(tensA, 1) .fne. node_val(tensB, 1) - call report_test("[galerkin_projection_diagnostic]", fail, .false., "") + use diagnostic_fields + use state_module + use fields + use mesh_files + use unittest_tools + use solvers + use spud + implicit none + + interface + function field_func_tensor(pos) result(solution) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos), size(pos)) :: solution + end function + end interface + + type(vector_field) :: positions + type(tensor_field) :: tensA, tensB + type(mesh_type) :: pwc_mesh + character(len=255) :: path = "/solvers" + type(state_type) :: state + integer :: stat + logical :: fail + + positions = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") + pwc_mesh = piecewise_constant_mesh(positions%mesh, "PiecewiseConstantMesh") + call allocate(tensA, pwc_mesh, "TensorA") + call set_from_function(tensA, field_func_tensor, positions) + + call allocate(tensB, positions%mesh, "TensorB") + call zero(tensB) + tensB%option_path = "/hello" + call set_option(trim(tensB%option_path) // '/diagnostic/source_field_name', 'TensorA', stat=stat) + + call set_solver_options(path, ksptype='cg', pctype='sor', rtol=1.0e-10, max_its=10000) + call insert(state, tensA, "TensorA") + call insert(state, positions, "Coordinate") + + call calculate_galerkin_projection(state, tensB, path) + + fail = node_val(tensA, 1) .fne. node_val(tensB, 1) + call report_test("[galerkin_projection_diagnostic]", fail, .false., "") end subroutine test_galerkin_projection_diagnostic function field_func_tensor(pos) result(solution) - use unittest_tools - real, dimension(:) :: pos - real, dimension(size(pos), size(pos)) :: solution + use unittest_tools + real, dimension(:) :: pos + real, dimension(size(pos), size(pos)) :: solution - solution = get_matrix_identity(size(pos)) + solution = get_matrix_identity(size(pos)) end function diff --git a/femtools/tests/test_get_connected_surface_eles.F90 b/femtools/tests/test_get_connected_surface_eles.F90 index 1bae1aa5d7..6dcb0d07d4 100644 --- a/femtools/tests/test_get_connected_surface_eles.F90 +++ b/femtools/tests/test_get_connected_surface_eles.F90 @@ -29,49 +29,49 @@ subroutine test_get_connected_surface_eles - use futils - use fields - use fldebug - use mesh_files - use surfacelabels - use unittest_tools + use futils + use fields + use fldebug + use mesh_files + use surfacelabels + use unittest_tools - implicit none + implicit none - integer :: i - integer, parameter :: quad_degree = 1 - type(integer_vector), dimension(:), allocatable :: connected_surface_eles - type(vector_field) :: positions + integer :: i + integer, parameter :: quad_degree = 1 + type(integer_vector), dimension(:), allocatable :: connected_surface_eles + type(vector_field) :: positions - positions = read_mesh_files("data/interval", quad_degree = quad_degree, format="gmsh") + positions = read_mesh_files("data/interval", quad_degree = quad_degree, format="gmsh") - call get_connected_surface_eles(positions%mesh, connected_surface_eles) + call get_connected_surface_eles(positions%mesh, connected_surface_eles) - call report_test("[Correct number of surfaces]", size(connected_surface_eles) /= 2, .false., "Incorrect number of surfaces") - call report_test("[Correct surface]", any(connected_surface_eles(1)%ptr /= (/1/)), .false., "Incorrect surface") - call report_test("[Correct surface]", any(connected_surface_eles(2)%ptr /= (/2/)), .false., "Incorrect surface") + call report_test("[Correct number of surfaces]", size(connected_surface_eles) /= 2, .false., "Incorrect number of surfaces") + call report_test("[Correct surface]", any(connected_surface_eles(1)%ptr /= (/1/)), .false., "Incorrect surface") + call report_test("[Correct surface]", any(connected_surface_eles(2)%ptr /= (/2/)), .false., "Incorrect surface") - do i = 1, size(connected_surface_eles) - deallocate(connected_surface_eles(i)%ptr) - end do - deallocate(connected_surface_eles) - call deallocate(positions) + do i = 1, size(connected_surface_eles) + deallocate(connected_surface_eles(i)%ptr) + end do + deallocate(connected_surface_eles) + call deallocate(positions) - call report_test_no_references() + call report_test_no_references() - positions = read_mesh_files("data/tet", quad_degree = quad_degree, format="gmsh") + positions = read_mesh_files("data/tet", quad_degree = quad_degree, format="gmsh") - call get_connected_surface_eles(positions%mesh, connected_surface_eles) + call get_connected_surface_eles(positions%mesh, connected_surface_eles) - call report_test("[Correct number of surfaces]", size(connected_surface_eles) /= 1, .false., "Incorrect number of surfaces") - call report_test("[Correct surface]", any(connected_surface_eles(1)%ptr /= (/1, 2, 3, 4/)), .false., "Incorrect surface") + call report_test("[Correct number of surfaces]", size(connected_surface_eles) /= 1, .false., "Incorrect number of surfaces") + call report_test("[Correct surface]", any(connected_surface_eles(1)%ptr /= (/1, 2, 3, 4/)), .false., "Incorrect surface") - do i = 1, size(connected_surface_eles) - deallocate(connected_surface_eles(i)%ptr) - end do - deallocate(connected_surface_eles) - call deallocate(positions) + do i = 1, size(connected_surface_eles) + deallocate(connected_surface_eles(i)%ptr) + end do + deallocate(connected_surface_eles) + call deallocate(positions) - call report_test_no_references() + call report_test_no_references() end subroutine test_get_connected_surface_eles diff --git a/femtools/tests/test_gm_quadrature.F90 b/femtools/tests/test_gm_quadrature.F90 index 44e80bbd28..2b01512eb3 100644 --- a/femtools/tests/test_gm_quadrature.F90 +++ b/femtools/tests/test_gm_quadrature.F90 @@ -26,58 +26,58 @@ ! USA subroutine test_gm_quadrature - use quadrature_test - use unittest_tools - implicit none + use quadrature_test + use unittest_tools + implicit none - integer :: dim, vertices - logical :: fail - integer :: degree, stat - type(quadrature_type) :: quadrature - character(len=254) :: error_message, test_message + integer :: dim, vertices + logical :: fail + integer :: degree, stat + type(quadrature_type) :: quadrature + character(len=254) :: error_message, test_message - dim = 2 - vertices = 3 + dim = 2 + vertices = 3 - do dim=1,3 - vertices = dim+1 - degree = 0 - degreeloop: do - degree = degree + 1 + do dim=1,3 + vertices = dim+1 + degree = 0 + degreeloop: do + degree = degree + 1 - quadrature = make_quadrature(vertices, dim, degree=degree, family=FAMILY_GM, stat=stat) + quadrature = make_quadrature(vertices, dim, degree=degree, family=FAMILY_GM, stat=stat) - select case (stat) - case (QUADRATURE_DEGREE_ERROR) - exit degreeloop - case (0) - continue - case default - fail = .true. - call report_test("[test_gm_quadrature]", fail, .false., "Making quadrature failed") - end select + select case (stat) + case (QUADRATURE_DEGREE_ERROR) + exit degreeloop + case (0) + continue + case default + fail = .true. + call report_test("[test_gm_quadrature]", fail, .false., "Making quadrature failed") + end select - degree = quadrature%degree + degree = quadrature%degree - do power=0,degree - if(fnequals(quad_integrate(monic, quadrature), simplex_answer(), tol = 1.0e5 * epsilon(0.0))) then - fail = .true. - write(error_message, '(e15.7)') quad_integrate(monic, quadrature)-simplex_answer() - else - fail = .false. - error_message = "" - end if + do power=0,degree + if(fnequals(quad_integrate(monic, quadrature), simplex_answer(), tol = 1.0e5 * epsilon(0.0))) then + fail = .true. + write(error_message, '(e15.7)') quad_integrate(monic, quadrature)-simplex_answer() + else + fail = .false. + error_message = "" + end if - write(test_message, '(3(a,i0),a)') "[",dim,"-simplex, quad degree ",degree," power ",power," ]" - call report_test(trim(test_message), fail, .false., trim(error_message)) - end do + write(test_message, '(3(a,i0),a)') "[",dim,"-simplex, quad degree ",degree," power ",power," ]" + call report_test(trim(test_message), fail, .false., trim(error_message)) + end do - call deallocate(quadrature) - end do degreeloop - end do + call deallocate(quadrature) + end do degreeloop + end do - contains - function simplex_answer() +contains + function simplex_answer() ! Analytic solution to integrating monic over a simplex. ! This formula is eq. 7.38 and 7.48 in Zienkiewicz and Taylor real :: simplex_answer @@ -85,11 +85,11 @@ function simplex_answer() simplex_answer = 1.0 do i=0,dim-1 - j = power + dim - i - if (j <= 1) exit - simplex_answer = simplex_answer * j + j = power + dim - i + if (j <= 1) exit + simplex_answer = simplex_answer * j end do simplex_answer = 1.0/simplex_answer - end function simplex_answer + end function simplex_answer end subroutine test_gm_quadrature diff --git a/femtools/tests/test_halo_allocation.F90 b/femtools/tests/test_halo_allocation.F90 index 30d84bf3b9..a3e4c04644 100644 --- a/femtools/tests/test_halo_allocation.F90 +++ b/femtools/tests/test_halo_allocation.F90 @@ -28,89 +28,89 @@ #include "fdebug.h" subroutine test_halo_allocation - !!< Test allocation of the halo_type derived type - - use halos - use reference_counting - use unittest_tools - - implicit none - - integer :: i - integer, dimension(:), allocatable :: nreceives, nsends - integer, parameter :: nowned_nodes = 42, nprocs = 1 - logical :: fail - type(halo_type) :: halo - - ! Set up halo node counts - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - do i = 1, nprocs - nsends(i) = i * 5 - nreceives(i) = i * 10 - end do - - ! Allocate a halo - call allocate(halo, nsends, nreceives, nprocs = nprocs, name = "TestHalo", nowned_nodes = nowned_nodes) - call report_test("[Has references]", .not. has_references(halo), .false., "Halo does not have references") - call report_test("[References]", .not. associated(refcount_list%next), .false., "Have no references") - - call report_test("[Correct nprocs]", halo%nprocs /= nprocs, .false., "Incorrect nprocs") - call report_test("[Correct nprocs]", halo_proc_count(halo) /= nprocs, .false., "Incorrect nprocs") - - call report_test("[Correct name]", trim(halo%name) /= "TestHalo", .false., "Incorrect name") - - call report_test("[Correct nowned_nodes]", halo%nowned_nodes /= nowned_nodes, .false., "Incorrect nowned_nodes") - call report_test("[Correct nowned_nodes]", halo_nowned_nodes(halo) /= nowned_nodes, .false., "Incorrect nowned_nodes") - - call report_test("[sends allocated]", .not. associated(halo%sends), .false., "sends array not allocated") - call report_test("[receives allocated]", .not. associated(halo%receives), .false., "receives array not allocated") - call report_test("[sends has correct size]", size(halo%sends) /= nprocs, .false., "sends array has incorrect size") - call report_test("[receives has correct size]", size(halo%receives) /= nprocs, .false., "receives array has incorrect size") - - fail = .false. - do i = 1, halo_proc_count(halo) - if(.not. associated(halo%sends(i)%ptr)) then - fail = .true. - exit - end if - end do - call report_test("[sends elements allocated]", fail, .false., "At least one element of sends array not allocated") - fail = .false. - do i = 1, halo_proc_count(halo) - if(.not. associated(halo%receives(i)%ptr)) then - fail = .true. - exit - end if - end do - call report_test("[receives elements allocated]", fail, .false., "At least one element of receives array not allocated") - fail = .false. - do i = 1, halo_proc_count(halo) - if(halo_send_count(halo, i) /= nsends(i)) then - fail = .true. - exit - end if - end do - call report_test("[sends elements have correct sizes]", fail, .false., "At least one element of sends array has incorrect size") - fail = .false. - do i = 1, halo_proc_count(halo) - if(halo_receive_count(halo, i) /= nreceives(i)) then - fail = .true. - exit - end if - end do - call report_test("[receives elements have correct sizes]", fail, .false., "At least one element of receives array has incorrect size") - - ! Deallocate the halo - call deallocate(halo) - - call report_test_no_references() - - call report_test("[Name reset]", len_trim(halo%name) > 0, .false., "Halo name not reset") - call report_test("[sends not associated]", associated(halo%sends), .false., "sends still associated") - call report_test("[receives not associated]", associated(halo%receives), .false., "receives still associated") - - deallocate(nsends) - deallocate(nreceives) + !!< Test allocation of the halo_type derived type + + use halos + use reference_counting + use unittest_tools + + implicit none + + integer :: i + integer, dimension(:), allocatable :: nreceives, nsends + integer, parameter :: nowned_nodes = 42, nprocs = 1 + logical :: fail + type(halo_type) :: halo + + ! Set up halo node counts + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + do i = 1, nprocs + nsends(i) = i * 5 + nreceives(i) = i * 10 + end do + + ! Allocate a halo + call allocate(halo, nsends, nreceives, nprocs = nprocs, name = "TestHalo", nowned_nodes = nowned_nodes) + call report_test("[Has references]", .not. has_references(halo), .false., "Halo does not have references") + call report_test("[References]", .not. associated(refcount_list%next), .false., "Have no references") + + call report_test("[Correct nprocs]", halo%nprocs /= nprocs, .false., "Incorrect nprocs") + call report_test("[Correct nprocs]", halo_proc_count(halo) /= nprocs, .false., "Incorrect nprocs") + + call report_test("[Correct name]", trim(halo%name) /= "TestHalo", .false., "Incorrect name") + + call report_test("[Correct nowned_nodes]", halo%nowned_nodes /= nowned_nodes, .false., "Incorrect nowned_nodes") + call report_test("[Correct nowned_nodes]", halo_nowned_nodes(halo) /= nowned_nodes, .false., "Incorrect nowned_nodes") + + call report_test("[sends allocated]", .not. associated(halo%sends), .false., "sends array not allocated") + call report_test("[receives allocated]", .not. associated(halo%receives), .false., "receives array not allocated") + call report_test("[sends has correct size]", size(halo%sends) /= nprocs, .false., "sends array has incorrect size") + call report_test("[receives has correct size]", size(halo%receives) /= nprocs, .false., "receives array has incorrect size") + + fail = .false. + do i = 1, halo_proc_count(halo) + if(.not. associated(halo%sends(i)%ptr)) then + fail = .true. + exit + end if + end do + call report_test("[sends elements allocated]", fail, .false., "At least one element of sends array not allocated") + fail = .false. + do i = 1, halo_proc_count(halo) + if(.not. associated(halo%receives(i)%ptr)) then + fail = .true. + exit + end if + end do + call report_test("[receives elements allocated]", fail, .false., "At least one element of receives array not allocated") + fail = .false. + do i = 1, halo_proc_count(halo) + if(halo_send_count(halo, i) /= nsends(i)) then + fail = .true. + exit + end if + end do + call report_test("[sends elements have correct sizes]", fail, .false., "At least one element of sends array has incorrect size") + fail = .false. + do i = 1, halo_proc_count(halo) + if(halo_receive_count(halo, i) /= nreceives(i)) then + fail = .true. + exit + end if + end do + call report_test("[receives elements have correct sizes]", fail, .false., "At least one element of receives array has incorrect size") + + ! Deallocate the halo + call deallocate(halo) + + call report_test_no_references() + + call report_test("[Name reset]", len_trim(halo%name) > 0, .false., "Halo name not reset") + call report_test("[sends not associated]", associated(halo%sends), .false., "sends still associated") + call report_test("[receives not associated]", associated(halo%receives), .false., "receives still associated") + + deallocate(nsends) + deallocate(nreceives) end subroutine test_halo_allocation diff --git a/femtools/tests/test_halo_communication.F90 b/femtools/tests/test_halo_communication.F90 index 84ee754c18..3b568c400f 100644 --- a/femtools/tests/test_halo_communication.F90 +++ b/femtools/tests/test_halo_communication.F90 @@ -28,141 +28,141 @@ #include "fdebug.h" subroutine test_halo_communication - !!< Test communication using halo_type derived type. Parallel test - requires - !!< exactly two processes. + !!< Test communication using halo_type derived type. Parallel test - requires + !!< exactly two processes. #ifdef HAVE_MPI - use futils - use halos - use mpi_interfaces - use parallel_tools - use unittest_tools - - implicit none - - integer :: i, ierr, nprocs, procno - integer, dimension(2) :: nreceives, nsends - integer, dimension(7) :: integer_data - integer :: communicator = MPI_COMM_FEMTOOLS - logical :: fail - real, dimension(7) :: real_data - type(halo_type) :: halo - - call mpi_comm_size(communicator, nprocs, ierr) - call report_test("[mpi_comm_size]", ierr /= MPI_SUCCESS, .false., "Failed to read communicator size") - call report_test("[2 processes]", nprocs /= 2, .false., "Incorrect number of processes") - - procno = getprocno(communicator) - - ! Construct a halo - if(procno == 1) then - nsends(1) = 0 - nsends(2) = 2 - nreceives(1) = 0 - nreceives(2) = 3 - - call allocate(halo, nsends, nreceives, communicator = communicator, name = "TestHalo") - - call zero(halo) - call set_halo_send(halo, 2, 1, 2) - call set_halo_send(halo, 2, 2, 6) - call set_halo_receive(halo, 2, 1, 3) - call set_halo_receive(halo, 2, 2, 5) - call set_halo_receive(halo, 2, 3, 4) - else - nsends(1) = 3 - nsends(2) = 0 - nreceives(1) = 2 - nreceives(2) = 0 - - call allocate(halo, nsends, nreceives, communicator = communicator, name = "TestHalo") - - call zero(halo) - call set_halo_send(halo, 1, 1, 3) - call set_halo_send(halo, 1, 2, 5) - call set_halo_send(halo, 1, 3, 4) - call set_halo_receive(halo, 1, 1, 2) - call set_halo_receive(halo, 1, 2, 6) - end if - - call report_test("[valid_halo_communicator]", .not. valid_halo_communicator(halo), .false., "Invalid halo communicator") - call report_test("[valid_halo_node_counts]", .not. valid_halo_node_counts(halo), .false., "Invalid halo node counts") - call report_test("[halo_valid_for_communication]", .not. halo_valid_for_communication(halo), .false., "Halo not valid for communication") - - ! Construct integer data to send/receive - if(procno == 1) then - integer_data(1) = 1 - integer_data(2) = 2 - integer_data(3) = -3 - integer_data(4) = -4 - integer_data(5) = -5 - integer_data(6) = 6 - integer_data(7) = 7 - else - integer_data(1) = 1 - integer_data(2) = -2 - integer_data(3) = 3 - integer_data(4) = 4 - integer_data(5) = 5 - integer_data(6) = -6 - integer_data(7) = 7 - end if - - call halo_update(halo, integer_data) - - fail = .false. - do i = 1, 5 - if(integer_data(i) /= i) then - fail = .true. - exit - end if - end do - - call report_test("[Integer array halo communication]", fail, .false., "Error in halo communication") - - ! Construct real data to send/receive - if(procno == 1) then - real_data(1) = 1.0 - real_data(2) = 2.0 - real_data(3) = -3.0 - real_data(4) = -4.0 - real_data(5) = -5.0 - real_data(6) = 6.0 - real_data(7) = 7.0 - else - real_data(1) = 1.0 - real_data(2) = -2.0 - real_data(3) = 3.0 - real_data(4) = 4.0 - real_data(5) = 5.0 - real_data(6) = -6.0 - real_data(7) = 7.0 - end if - - call halo_update(halo, real_data) - - fail = .false. - do i = 1, 5 - if(real_data(i) .fne. float(i)) then - fail = .true. - exit - end if - end do - - call report_test("[Real array halo communication]", fail, .false., "Error in halo communication") - - call report_test("[No pending communications]", pending_communication(halo), .false., "Pending communications") - - call deallocate(halo) - - call report_test_no_references() + use futils + use halos + use mpi_interfaces + use parallel_tools + use unittest_tools + + implicit none + + integer :: i, ierr, nprocs, procno + integer, dimension(2) :: nreceives, nsends + integer, dimension(7) :: integer_data + integer :: communicator = MPI_COMM_FEMTOOLS + logical :: fail + real, dimension(7) :: real_data + type(halo_type) :: halo + + call mpi_comm_size(communicator, nprocs, ierr) + call report_test("[mpi_comm_size]", ierr /= MPI_SUCCESS, .false., "Failed to read communicator size") + call report_test("[2 processes]", nprocs /= 2, .false., "Incorrect number of processes") + + procno = getprocno(communicator) + + ! Construct a halo + if(procno == 1) then + nsends(1) = 0 + nsends(2) = 2 + nreceives(1) = 0 + nreceives(2) = 3 + + call allocate(halo, nsends, nreceives, communicator = communicator, name = "TestHalo") + + call zero(halo) + call set_halo_send(halo, 2, 1, 2) + call set_halo_send(halo, 2, 2, 6) + call set_halo_receive(halo, 2, 1, 3) + call set_halo_receive(halo, 2, 2, 5) + call set_halo_receive(halo, 2, 3, 4) + else + nsends(1) = 3 + nsends(2) = 0 + nreceives(1) = 2 + nreceives(2) = 0 + + call allocate(halo, nsends, nreceives, communicator = communicator, name = "TestHalo") + + call zero(halo) + call set_halo_send(halo, 1, 1, 3) + call set_halo_send(halo, 1, 2, 5) + call set_halo_send(halo, 1, 3, 4) + call set_halo_receive(halo, 1, 1, 2) + call set_halo_receive(halo, 1, 2, 6) + end if + + call report_test("[valid_halo_communicator]", .not. valid_halo_communicator(halo), .false., "Invalid halo communicator") + call report_test("[valid_halo_node_counts]", .not. valid_halo_node_counts(halo), .false., "Invalid halo node counts") + call report_test("[halo_valid_for_communication]", .not. halo_valid_for_communication(halo), .false., "Halo not valid for communication") + + ! Construct integer data to send/receive + if(procno == 1) then + integer_data(1) = 1 + integer_data(2) = 2 + integer_data(3) = -3 + integer_data(4) = -4 + integer_data(5) = -5 + integer_data(6) = 6 + integer_data(7) = 7 + else + integer_data(1) = 1 + integer_data(2) = -2 + integer_data(3) = 3 + integer_data(4) = 4 + integer_data(5) = 5 + integer_data(6) = -6 + integer_data(7) = 7 + end if + + call halo_update(halo, integer_data) + + fail = .false. + do i = 1, 5 + if(integer_data(i) /= i) then + fail = .true. + exit + end if + end do + + call report_test("[Integer array halo communication]", fail, .false., "Error in halo communication") + + ! Construct real data to send/receive + if(procno == 1) then + real_data(1) = 1.0 + real_data(2) = 2.0 + real_data(3) = -3.0 + real_data(4) = -4.0 + real_data(5) = -5.0 + real_data(6) = 6.0 + real_data(7) = 7.0 + else + real_data(1) = 1.0 + real_data(2) = -2.0 + real_data(3) = 3.0 + real_data(4) = 4.0 + real_data(5) = 5.0 + real_data(6) = -6.0 + real_data(7) = 7.0 + end if + + call halo_update(halo, real_data) + + fail = .false. + do i = 1, 5 + if(real_data(i) .fne. float(i)) then + fail = .true. + exit + end if + end do + + call report_test("[Real array halo communication]", fail, .false., "Error in halo communication") + + call report_test("[No pending communications]", pending_communication(halo), .false., "Pending communications") + + call deallocate(halo) + + call report_test_no_references() #else - use unittest_tools + use unittest_tools - implicit none + implicit none - call report_test("[test disabled]", .false., .true., "Test compiled without MPI support") + call report_test("[test disabled]", .false., .true., "Test compiled without MPI support") #endif end subroutine test_halo_communication diff --git a/femtools/tests/test_halo_io.F90 b/femtools/tests/test_halo_io.F90 index 4c19b059ee..9d3f113935 100644 --- a/femtools/tests/test_halo_io.F90 +++ b/femtools/tests/test_halo_io.F90 @@ -29,110 +29,110 @@ subroutine test_halo_io - use fldebug - use fields - use halos - use mesh_files - use unittest_tools + use fldebug + use fields + use halos + use mesh_files + use unittest_tools - implicit none + implicit none - integer :: i - type(mesh_type) :: mesh_2 - type(halo_type), pointer :: halo, halo_2 - type(vector_field) :: positions, positions_2 + integer :: i + type(mesh_type) :: mesh_2 + type(halo_type), pointer :: halo, halo_2 + type(vector_field) :: positions, positions_2 - positions = read_mesh_files("data/cube-parallel_0", quad_degree = 1, format="gmsh") - ! Use make_mesh to create a copy of positions%mesh with no halos, for use - ! with positions_2 later - mesh_2 = make_mesh(positions%mesh) + positions = read_mesh_files("data/cube-parallel_0", quad_degree = 1, format="gmsh") + ! Use make_mesh to create a copy of positions%mesh with no halos, for use + ! with positions_2 later + mesh_2 = make_mesh(positions%mesh) - call report_test("[No halos]", halo_count(positions) /= 0, .false., "Coordinate field has halos") - call read_halos("data/cube-parallel", positions) - call report_test("[Halos]", halo_count(positions) == 0, .false., "Coordinate field has no halos") - call report_test("[2 halos]", halo_count(positions) /= 2, .false., "Coordinate field has incorrect number of halos") + call report_test("[No halos]", halo_count(positions) /= 0, .false., "Coordinate field has halos") + call read_halos("data/cube-parallel", positions) + call report_test("[Halos]", halo_count(positions) == 0, .false., "Coordinate field has no halos") + call report_test("[2 halos]", halo_count(positions) /= 2, .false., "Coordinate field has incorrect number of halos") - do i = 1, 2 - halo => positions%mesh%halos(i) - call report_test("[nowned_nodes]", halo_nowned_nodes(halo) /= 665, .false., "Incorrect number of owned nodes") - call report_test("[nprocs]", halo_proc_count(halo) /= 1, .false., "Incorrect number of processes") - select case(i) - case(1) - call report_test("[nsends]", halo_send_count(halo, 1) /= 121, .false., "Incorrect number of sends") - call report_test("[nreceives]", halo_receive_count(halo, 1) /= 121, .false., "Incorrect number of receives") - case(2) - call report_test("[nsends]", halo_send_count(halo, 1) /= 243, .false., "Incorrect number of sends") - call report_test("[nreceives]", halo_receive_count(halo, 1) /= 242, .false., "Incorrect number of receives") - case default - FLAbort("Invalid loop index") - end select - call report_test("[trailing_receives_consistent]", .not. trailing_receives_consistent(halo), .false., "Not trailing receives consistent") - end do + do i = 1, 2 + halo => positions%mesh%halos(i) + call report_test("[nowned_nodes]", halo_nowned_nodes(halo) /= 665, .false., "Incorrect number of owned nodes") + call report_test("[nprocs]", halo_proc_count(halo) /= 1, .false., "Incorrect number of processes") + select case(i) + case(1) + call report_test("[nsends]", halo_send_count(halo, 1) /= 121, .false., "Incorrect number of sends") + call report_test("[nreceives]", halo_receive_count(halo, 1) /= 121, .false., "Incorrect number of receives") + case(2) + call report_test("[nsends]", halo_send_count(halo, 1) /= 243, .false., "Incorrect number of sends") + call report_test("[nreceives]", halo_receive_count(halo, 1) /= 242, .false., "Incorrect number of receives") + case default + FLAbort("Invalid loop index") + end select + call report_test("[trailing_receives_consistent]", .not. trailing_receives_consistent(halo), .false., "Not trailing receives consistent") + end do - ! Overwrite test output - call allocate(positions_2, positions%dim, mesh_2, name = positions%name) - call deallocate(mesh_2) - call set(positions_2, positions) - call report_test("[No halos]", halo_count(positions_2) /= 0, .false., "Coordinate field has halos") - ! We need at least one halo for write_halos to do anything - allocate(positions_2%mesh%halos(1)) - halo_2 => positions_2%mesh%halos(1) - call allocate(halo_2, nsends = (/0/), nreceives = (/1/), nprocs = 1) - call set_halo_nowned_nodes(halo_2, 0) - call set_halo_receives(halo_2, 1, (/1/)) - call write_halos("data/test_halo_io_out", positions_2%mesh) - call deallocate(halo_2) - deallocate(positions_2%mesh%halos) - nullify(positions_2%mesh%halos) + ! Overwrite test output + call allocate(positions_2, positions%dim, mesh_2, name = positions%name) + call deallocate(mesh_2) + call set(positions_2, positions) + call report_test("[No halos]", halo_count(positions_2) /= 0, .false., "Coordinate field has halos") + ! We need at least one halo for write_halos to do anything + allocate(positions_2%mesh%halos(1)) + halo_2 => positions_2%mesh%halos(1) + call allocate(halo_2, nsends = (/0/), nreceives = (/1/), nprocs = 1) + call set_halo_nowned_nodes(halo_2, 0) + call set_halo_receives(halo_2, 1, (/1/)) + call write_halos("data/test_halo_io_out", positions_2%mesh) + call deallocate(halo_2) + deallocate(positions_2%mesh%halos) + nullify(positions_2%mesh%halos) - ! Check that test output was overwritten - call report_test("[No halos]", halo_count(positions_2) /= 0, .false., "Coordinate field has halos") - call read_halos("data/test_halo_io_out", positions_2) - call report_test("[Halos]", halo_count(positions_2) == 0, .false., "Coordinate field has no halos") - call report_test("[2 halos]", halo_count(positions_2) /= 2, .false., "Coordinate field has incorrect number of halos") - do i = 1, 2 - halo_2 => positions_2%mesh%halos(i) - call report_test("[nowned_nodes]", halo_nowned_nodes(halo_2) /= 0, .false., "Incorrect number of owned nodes") - call report_test("[nprocs]", halo_proc_count(halo_2) /= 1, .false., "Incorrect number of processes") - call report_test("[nsends]", halo_send_count(halo_2, 1) /= 0, .false., "Incorrect number of sends") - select case(i) - case(1) - call report_test("[nreceives]", halo_receive_count(halo_2, 1) /= 1, .false., "Incorrect number of receives") - call report_test("[receives]", any(halo_receives(halo_2, 1) /= (/1/)), .false., "Incorrect sends") - case(2) - call report_test("[nreceives]", halo_receive_count(halo_2, 1) /= 0, .false., "Incorrect number of receives") - case default - FLAbort("Invalid loop index") - end select - call deallocate(halo_2) - end do - deallocate(positions_2%mesh%halos) - nullify(positions_2%mesh%halos) - deallocate(positions_2%mesh%element_halos) - nullify(positions_2%mesh%element_halos) + ! Check that test output was overwritten + call report_test("[No halos]", halo_count(positions_2) /= 0, .false., "Coordinate field has halos") + call read_halos("data/test_halo_io_out", positions_2) + call report_test("[Halos]", halo_count(positions_2) == 0, .false., "Coordinate field has no halos") + call report_test("[2 halos]", halo_count(positions_2) /= 2, .false., "Coordinate field has incorrect number of halos") + do i = 1, 2 + halo_2 => positions_2%mesh%halos(i) + call report_test("[nowned_nodes]", halo_nowned_nodes(halo_2) /= 0, .false., "Incorrect number of owned nodes") + call report_test("[nprocs]", halo_proc_count(halo_2) /= 1, .false., "Incorrect number of processes") + call report_test("[nsends]", halo_send_count(halo_2, 1) /= 0, .false., "Incorrect number of sends") + select case(i) + case(1) + call report_test("[nreceives]", halo_receive_count(halo_2, 1) /= 1, .false., "Incorrect number of receives") + call report_test("[receives]", any(halo_receives(halo_2, 1) /= (/1/)), .false., "Incorrect sends") + case(2) + call report_test("[nreceives]", halo_receive_count(halo_2, 1) /= 0, .false., "Incorrect number of receives") + case default + FLAbort("Invalid loop index") + end select + call deallocate(halo_2) + end do + deallocate(positions_2%mesh%halos) + nullify(positions_2%mesh%halos) + deallocate(positions_2%mesh%element_halos) + nullify(positions_2%mesh%element_halos) - ! Now write test output - call write_halos("data/test_halo_io_out", positions%mesh) + ! Now write test output + call write_halos("data/test_halo_io_out", positions%mesh) - ! Check the test output - call report_test("[No halos]", halo_count(positions_2) /= 0, .false., "Coordinate field has halos") - call read_halos("data/test_halo_io_out", positions_2) - call report_test("[Halos]", halo_count(positions_2) == 0, .false., "Coordinate field has no halos") - call report_test("[2 halos]", halo_count(positions_2) /= 2, .false., "Coordinate field has incorrect number of halos") - do i = 1, 2 - halo => positions%mesh%halos(i) - halo_2 => positions_2%mesh%halos(i) - call report_test("[nowned_nodes]", halo_nowned_nodes(halo) /= halo_nowned_nodes(halo_2), .false., "Incorrect number of owned nodes") - call report_test("[nprocs]", halo_proc_count(halo) /= halo_proc_count(halo_2), .false., "Incorrect number of processes") - call report_test("[nsends]", halo_send_count(halo, 1) /= halo_send_count(halo_2, 1), .false., "Incorrect number of sends") - call report_test("[nreceives]", halo_receive_count(halo, 1) /= halo_receive_count(halo_2, 1), .false., "Incorrect number of receives") - call report_test("[sends]", any(halo_sends(halo, 1) /= halo_sends(halo_2, 1)), .false., "Incorrect sends") - call report_test("[receives]", any(halo_receives(halo, 1) /= halo_receives(halo_2, 1)), .false., "Incorrect receives") - call report_test("[trailing_receives_consistent]", .not. trailing_receives_consistent(halo_2), .false., "Not trailing receives consistent") - end do + ! Check the test output + call report_test("[No halos]", halo_count(positions_2) /= 0, .false., "Coordinate field has halos") + call read_halos("data/test_halo_io_out", positions_2) + call report_test("[Halos]", halo_count(positions_2) == 0, .false., "Coordinate field has no halos") + call report_test("[2 halos]", halo_count(positions_2) /= 2, .false., "Coordinate field has incorrect number of halos") + do i = 1, 2 + halo => positions%mesh%halos(i) + halo_2 => positions_2%mesh%halos(i) + call report_test("[nowned_nodes]", halo_nowned_nodes(halo) /= halo_nowned_nodes(halo_2), .false., "Incorrect number of owned nodes") + call report_test("[nprocs]", halo_proc_count(halo) /= halo_proc_count(halo_2), .false., "Incorrect number of processes") + call report_test("[nsends]", halo_send_count(halo, 1) /= halo_send_count(halo_2, 1), .false., "Incorrect number of sends") + call report_test("[nreceives]", halo_receive_count(halo, 1) /= halo_receive_count(halo_2, 1), .false., "Incorrect number of receives") + call report_test("[sends]", any(halo_sends(halo, 1) /= halo_sends(halo_2, 1)), .false., "Incorrect sends") + call report_test("[receives]", any(halo_receives(halo, 1) /= halo_receives(halo_2, 1)), .false., "Incorrect receives") + call report_test("[trailing_receives_consistent]", .not. trailing_receives_consistent(halo_2), .false., "Not trailing receives consistent") + end do - call deallocate(positions) - call deallocate(positions_2) - call report_test_no_references() + call deallocate(positions) + call deallocate(positions_2) + call report_test_no_references() end subroutine test_halo_io diff --git a/femtools/tests/test_halos_legacy.F90 b/femtools/tests/test_halos_legacy.F90 index 9a9c31cc30..a0a8271f88 100644 --- a/femtools/tests/test_halos_legacy.F90 +++ b/femtools/tests/test_halos_legacy.F90 @@ -28,133 +28,133 @@ #include "fdebug.h" subroutine test_halos_legacy - !!< Test halo_type derived type legacy interoperability - - use halos - use unittest_tools - - implicit none - - integer :: i, index, j, npnodes - integer, dimension(:), allocatable :: atorec, atosen, colgat, nreceives, nsends, scater - integer, parameter :: nowned_nodes = 42, nprocs = 1 - logical :: fail - type(halo_type) :: input_halo, output_halo - - ! Set up halo node counts - allocate(nsends(nprocs)) - allocate(nreceives(nprocs)) - do i = 1, nprocs - nsends(i) = i * 10 - nreceives(i) = i * 10 - end do - - ! Allocate a halo - call allocate(input_halo, nsends, nreceives, nprocs = nprocs, name = "TestHalo", nowned_nodes = nowned_nodes) - - ! Set the halo nodes - call zero(input_halo) - index = 1 - do i = 1, halo_proc_count(input_halo) - do j = 1, halo_send_count(input_halo, i) - call set_halo_send(input_halo, i, j, index) - index = index + 1 - end do - end do - index=nowned_nodes+1 - do i = 1, halo_proc_count(input_halo) - do j = 1, halo_receive_count(input_halo, i) - call set_halo_receive(input_halo, i, j, index) - index = index + 1 - end do - end do - - ! Allocate the legacy datatypes - allocate(colgat(halo_all_sends_count(input_halo))) - allocate(atosen(halo_proc_count(input_halo) + 1)) - allocate(scater(halo_all_receives_count(input_halo))) - allocate(atorec(halo_proc_count(input_halo) + 1)) - - ! Extract the legacy data - call extract_raw_halo_data(input_halo, colgat, atosen, scater, atorec, nowned_nodes = npnodes) - - ! Form a new halo from the legacy data - call form_halo_from_raw_data(output_halo, nprocs, colgat, atosen, scater, atorec, nowned_nodes = npnodes) - - ! Note: Test output halo against input halo and against raw data - - call report_test("[Correct nowned_nodes]", halo_nowned_nodes(output_halo) /= nowned_nodes, .false., "Incorrect nowned_nodes") - call report_test("[Correct nowned_nodes]", halo_nowned_nodes(output_halo) /= halo_nowned_nodes(input_halo), .false., "Incorrect nowned_nodes") - - fail = .false. - index = 1 - do i = 1, nprocs - do j = 1, nsends(i) - if(halo_send(output_halo, i, j) /= index) then - fail = .true. - exit + !!< Test halo_type derived type legacy interoperability + + use halos + use unittest_tools + + implicit none + + integer :: i, index, j, npnodes + integer, dimension(:), allocatable :: atorec, atosen, colgat, nreceives, nsends, scater + integer, parameter :: nowned_nodes = 42, nprocs = 1 + logical :: fail + type(halo_type) :: input_halo, output_halo + + ! Set up halo node counts + allocate(nsends(nprocs)) + allocate(nreceives(nprocs)) + do i = 1, nprocs + nsends(i) = i * 10 + nreceives(i) = i * 10 + end do + + ! Allocate a halo + call allocate(input_halo, nsends, nreceives, nprocs = nprocs, name = "TestHalo", nowned_nodes = nowned_nodes) + + ! Set the halo nodes + call zero(input_halo) + index = 1 + do i = 1, halo_proc_count(input_halo) + do j = 1, halo_send_count(input_halo, i) + call set_halo_send(input_halo, i, j, index) + index = index + 1 + end do + end do + index=nowned_nodes+1 + do i = 1, halo_proc_count(input_halo) + do j = 1, halo_receive_count(input_halo, i) + call set_halo_receive(input_halo, i, j, index) + index = index + 1 + end do + end do + + ! Allocate the legacy datatypes + allocate(colgat(halo_all_sends_count(input_halo))) + allocate(atosen(halo_proc_count(input_halo) + 1)) + allocate(scater(halo_all_receives_count(input_halo))) + allocate(atorec(halo_proc_count(input_halo) + 1)) + + ! Extract the legacy data + call extract_raw_halo_data(input_halo, colgat, atosen, scater, atorec, nowned_nodes = npnodes) + + ! Form a new halo from the legacy data + call form_halo_from_raw_data(output_halo, nprocs, colgat, atosen, scater, atorec, nowned_nodes = npnodes) + + ! Note: Test output halo against input halo and against raw data + + call report_test("[Correct nowned_nodes]", halo_nowned_nodes(output_halo) /= nowned_nodes, .false., "Incorrect nowned_nodes") + call report_test("[Correct nowned_nodes]", halo_nowned_nodes(output_halo) /= halo_nowned_nodes(input_halo), .false., "Incorrect nowned_nodes") + + fail = .false. + index = 1 + do i = 1, nprocs + do j = 1, nsends(i) + if(halo_send(output_halo, i, j) /= index) then + fail = .true. + exit + end if + index = index + 1 + end do + if(fail) then + exit end if - index = index + 1 - end do - if(fail) then - exit - end if - end do - call report_test("[Correct send nodes]", fail, .false., "Incorrect send nodes") - fail = .false. - do i = 1, halo_proc_count(output_halo) - do j = 1, halo_send_count(output_halo, i) - if(halo_send(output_halo, i, j) /= halo_send(input_halo, i, j)) then - fail = .true. - exit + end do + call report_test("[Correct send nodes]", fail, .false., "Incorrect send nodes") + fail = .false. + do i = 1, halo_proc_count(output_halo) + do j = 1, halo_send_count(output_halo, i) + if(halo_send(output_halo, i, j) /= halo_send(input_halo, i, j)) then + fail = .true. + exit + end if + end do + if(fail) then + exit end if - end do - if(fail) then - exit - end if - end do - call report_test("[Correct send nodes]", fail, .false., "Incorrect send nodes") - - fail = .false. - index = nowned_nodes + 1 - do i = 1, nprocs - do j = 1, nreceives(i) - if(halo_receive(output_halo, i, j) /= index) then - fail = .true. - exit + end do + call report_test("[Correct send nodes]", fail, .false., "Incorrect send nodes") + + fail = .false. + index = nowned_nodes + 1 + do i = 1, nprocs + do j = 1, nreceives(i) + if(halo_receive(output_halo, i, j) /= index) then + fail = .true. + exit + end if + index = index + 1 + end do + if(fail) then + exit end if - index = index + 1 - end do - if(fail) then - exit - end if - end do - call report_test("[Correct receive nodes]", fail, .false., "Incorrect receive nodes") - fail = .false. - do i = 1, halo_proc_count(output_halo) - do j = 1, halo_receive_count(output_halo, i) - if(halo_receive(output_halo, i, j) /= halo_receive(input_halo, i, j)) then - fail = .true. - exit + end do + call report_test("[Correct receive nodes]", fail, .false., "Incorrect receive nodes") + fail = .false. + do i = 1, halo_proc_count(output_halo) + do j = 1, halo_receive_count(output_halo, i) + if(halo_receive(output_halo, i, j) /= halo_receive(input_halo, i, j)) then + fail = .true. + exit + end if + end do + if(fail) then + exit end if - end do - if(fail) then - exit - end if - end do - call report_test("[Correct receive nodes]", fail, .false., "Incorrect receive nodes") + end do + call report_test("[Correct receive nodes]", fail, .false., "Incorrect receive nodes") - deallocate(colgat) - deallocate(atosen) - deallocate(scater) - deallocate(atorec) + deallocate(colgat) + deallocate(atosen) + deallocate(scater) + deallocate(atorec) - call deallocate(input_halo) - call deallocate(output_halo) + call deallocate(input_halo) + call deallocate(output_halo) - deallocate(nsends) - deallocate(nreceives) + deallocate(nsends) + deallocate(nreceives) - call report_test_no_references() + call report_test_no_references() end subroutine test_halos_legacy diff --git a/femtools/tests/test_hex_tet_intersector.F90 b/femtools/tests/test_hex_tet_intersector.F90 index 1ca1aad5b5..73e8af439e 100644 --- a/femtools/tests/test_hex_tet_intersector.F90 +++ b/femtools/tests/test_hex_tet_intersector.F90 @@ -1,38 +1,38 @@ subroutine test_hex_tet_intersector - use mesh_files - use tetrahedron_intersection_module - use fields - use unittest_tools - use vtk_interfaces + use mesh_files + use tetrahedron_intersection_module + use fields + use unittest_tools + use vtk_interfaces - type(vector_field) :: cube, tet, intersection - integer :: stat - type(plane_type), dimension(6) :: planes - type(tet_type) :: tet_t - logical :: fail - real :: tet_vol, int_vol + type(vector_field) :: cube, tet, intersection + integer :: stat + type(plane_type), dimension(6) :: planes + type(tet_type) :: tet_t + logical :: fail + real :: tet_vol, int_vol - cube = read_mesh_files("data/unit_cube", quad_degree=1, format="gmsh") - tet = read_mesh_files("data/unit_tet", quad_degree=1, format="gmsh") + cube = read_mesh_files("data/unit_cube", quad_degree=1, format="gmsh") + tet = read_mesh_files("data/unit_tet", quad_degree=1, format="gmsh") - planes = get_planes(cube, 1) - tet_t%v = ele_val(tet, 1) + planes = get_planes(cube, 1) + tet_t%v = ele_val(tet, 1) - call intersect_tets(tet_t, planes, ele_shape(tet, 1), stat=stat, output=intersection) - fail = (stat /= 0) + call intersect_tets(tet_t, planes, ele_shape(tet, 1), stat=stat, output=intersection) + fail = (stat /= 0) - call report_test("[hex tet intersector existence]", fail, .false., "") + call report_test("[hex tet intersector existence]", fail, .false., "") - tet_vol = simplex_volume(tet, 1) - int_vol = abs(simplex_volume(intersection, 1)) + tet_vol = simplex_volume(tet, 1) + int_vol = abs(simplex_volume(intersection, 1)) - fail = (tet_vol .fne. int_vol) + fail = (tet_vol .fne. int_vol) - call report_test("[hex tet intersector volume]", fail, .false., "") + call report_test("[hex tet intersector volume]", fail, .false., "") - call deallocate(cube) - call deallocate(tet) - call deallocate(intersection) + call deallocate(cube) + call deallocate(tet) + call deallocate(intersection) end subroutine test_hex_tet_intersector diff --git a/femtools/tests/test_integer_from_python.F90 b/femtools/tests/test_integer_from_python.F90 index c9652fd8e0..ec7ffe2b66 100644 --- a/femtools/tests/test_integer_from_python.F90 +++ b/femtools/tests/test_integer_from_python.F90 @@ -29,23 +29,23 @@ subroutine test_integer_from_python - use embed_python - use fldebug - use unittest_tools + use embed_python + use fldebug + use unittest_tools - implicit none + implicit none - character(len = *), parameter :: func = & - & "def val(t):" // new_line("") // & - & " return int(t)" - integer :: result, stat + character(len = *), parameter :: func = & + & "def val(t):" // new_line("") // & + & " return int(t)" + integer :: result, stat - call integer_from_python(func, 0.1, result, stat = stat) - call report_test("[integer_from_python]", stat /= 0, .false., "integer_from_python returned an error") - call report_test("[Expected result]", result /= 0, .false., "integer_from_python returned incorrect integer") + call integer_from_python(func, 0.1, result, stat = stat) + call report_test("[integer_from_python]", stat /= 0, .false., "integer_from_python returned an error") + call report_test("[Expected result]", result /= 0, .false., "integer_from_python returned incorrect integer") - call integer_from_python(func, 1.1, result, stat = stat) - call report_test("[integer_from_python]", stat /= 0, .false., "integer_from_python returned an error") - call report_test("[Expected result]", result /= 1, .false., "integer_from_python returned incorrect integer") + call integer_from_python(func, 1.1, result, stat = stat) + call report_test("[integer_from_python]", stat /= 0, .false., "integer_from_python returned an error") + call report_test("[Expected result]", result /= 1, .false., "integer_from_python returned incorrect integer") end subroutine test_integer_from_python diff --git a/femtools/tests/test_integer_hash_table.F90 b/femtools/tests/test_integer_hash_table.F90 index 858e76bed7..a0f102f09a 100644 --- a/femtools/tests/test_integer_hash_table.F90 +++ b/femtools/tests/test_integer_hash_table.F90 @@ -1,36 +1,36 @@ subroutine test_integer_hash_table - use data_structures - use unittest_tools - implicit none + use data_structures + use unittest_tools + implicit none - type(integer_hash_table) :: ihash - integer :: len, i - logical :: fail + type(integer_hash_table) :: ihash + integer :: len, i + logical :: fail - call allocate(ihash) - call insert(ihash, 4, 40) - call insert(ihash, 5, 50) - call insert(ihash, 6, 60) + call allocate(ihash) + call insert(ihash, 4, 40) + call insert(ihash, 5, 50) + call insert(ihash, 6, 60) - len = key_count(ihash) - fail = (len /= 3) - call report_test("[key_count]", fail, .false., "Should be 3") + len = key_count(ihash) + fail = (len /= 3) + call report_test("[key_count]", fail, .false., "Should be 3") - do i=4,6 - fail = (fetch(ihash, i) /= i*10) - call report_test("[fetch]", fail, .false., "Should give i*10") - end do + do i=4,6 + fail = (fetch(ihash, i) /= i*10) + call report_test("[fetch]", fail, .false., "Should give i*10") + end do - fail = has_key(ihash, 99) - call report_test("[integer_hash_table_has_value]", fail, .false., "Should be .false.!") + fail = has_key(ihash, 99) + call report_test("[integer_hash_table_has_value]", fail, .false., "Should be .false.!") - fail = .not. has_key(ihash, 5) - call report_test("[integer_hash_table_has_value]", fail, .false., "Should be .true.!") + fail = .not. has_key(ihash, 5) + call report_test("[integer_hash_table_has_value]", fail, .false., "Should be .true.!") - call remove(ihash, 5) - fail = has_key(ihash, 5) - call report_test("[integer_hash_table_has_value]", fail, .false., "Should be .false.!") + call remove(ihash, 5) + fail = has_key(ihash, 5) + call report_test("[integer_hash_table_has_value]", fail, .false., "Should be .false.!") - call deallocate(ihash) + call deallocate(ihash) end subroutine test_integer_hash_table diff --git a/femtools/tests/test_integer_set.F90 b/femtools/tests/test_integer_set.F90 index 777e0dbbae..0e4507619d 100644 --- a/femtools/tests/test_integer_set.F90 +++ b/femtools/tests/test_integer_set.F90 @@ -1,45 +1,45 @@ subroutine test_integer_set - use data_structures - use unittest_tools - implicit none + use data_structures + use unittest_tools + implicit none - type(integer_set) :: iset - integer :: len, i - logical :: fail, changed + type(integer_set) :: iset + integer :: len, i + logical :: fail, changed - call allocate(iset) - call insert(iset, 4) - call insert(iset, 5) - call insert(iset, 6) + call allocate(iset) + call insert(iset, 4) + call insert(iset, 5) + call insert(iset, 6) - len = key_count(iset) - fail = (len /= 3) - call report_test("[key_count]", fail, .false., "Should be 3") + len = key_count(iset) + fail = (len /= 3) + call report_test("[key_count]", fail, .false., "Should be 3") - do i=1,len - fail = (fetch(iset, i) /= i+3) - call report_test("[fetch]", fail, .false., "Should give i+3") - end do + do i=1,len + fail = (fetch(iset, i) /= i+3) + call report_test("[fetch]", fail, .false., "Should give i+3") + end do - fail = has_value(iset, 99) - call report_test("[integer_set_has_value]", fail, .false., "Should be .false.!") + fail = has_value(iset, 99) + call report_test("[integer_set_has_value]", fail, .false., "Should be .false.!") - fail = .not. has_value(iset, 5) - call report_test("[integer_set_has_value]", fail, .false., "Should be .true.!") + fail = .not. has_value(iset, 5) + call report_test("[integer_set_has_value]", fail, .false., "Should be .true.!") - call insert(iset, 4, changed=changed) - fail = changed - call report_test("[integer_set_insert]", fail, .false., "Should not change") + call insert(iset, 4, changed=changed) + fail = changed + call report_test("[integer_set_insert]", fail, .false., "Should not change") - len = key_count(iset) - fail = (len /= 3) - call report_test("[key_count]", fail, .false., "Should be 3") + len = key_count(iset) + fail = (len /= 3) + call report_test("[key_count]", fail, .false., "Should be 3") - call remove(iset, 4) - len = key_count(iset) - fail = (len /= 2) .or. has_value(iset, 4) - call report_test("[key_count]", fail, .false., "Should change") + call remove(iset, 4) + len = key_count(iset) + fail = (len /= 2) .or. has_value(iset, 4) + call report_test("[key_count]", fail, .false., "Should change") - call deallocate(iset) + call deallocate(iset) end subroutine test_integer_set diff --git a/femtools/tests/test_interpolation.F90 b/femtools/tests/test_interpolation.F90 index 6ac4504406..d3226f7dc4 100644 --- a/femtools/tests/test_interpolation.F90 +++ b/femtools/tests/test_interpolation.F90 @@ -26,45 +26,45 @@ ! USA subroutine test_interpolation - !!< Test that we can interpolate from one field to another - use fields - use mesh_files - use unittest_tools - use vtk_interfaces - use conservative_interpolation - implicit none + !!< Test that we can interpolate from one field to another + use fields + use mesh_files + use unittest_tools + use vtk_interfaces + use conservative_interpolation + implicit none - type(vector_field) :: X_in, X_out - type(scalar_field) :: T_in, T_out - type(interpolator_type) :: interpolator - real :: fmin_in, fmax_in, fnorm2_in, fintegral_in - real :: fmin_out, fmax_out, fnorm2_out, fintegral_out - logical :: fail + type(vector_field) :: X_in, X_out + type(scalar_field) :: T_in, T_out + type(interpolator_type) :: interpolator + real :: fmin_in, fmax_in, fnorm2_in, fintegral_in + real :: fmin_out, fmax_out, fnorm2_out, fintegral_out + logical :: fail - X_in=read_mesh_files("square.1", quad_degree=4, format="gmsh") - X_out=read_mesh_files("square.2", quad_degree=4, format="gmsh") + X_in=read_mesh_files("square.1", quad_degree=4, format="gmsh") + X_out=read_mesh_files("square.2", quad_degree=4, format="gmsh") - call allocate(T_in, X_in%mesh, "tracer") - call allocate(T_in, X_out%mesh, "tracer") + call allocate(T_in, X_in%mesh, "tracer") + call allocate(T_in, X_out%mesh, "tracer") - call set_from_python_function(T_in, & - "def val(X,t): import math; return math.cos(X[0])", X, 0.0) + call set_from_python_function(T_in, & + "def val(X,t): import math; return math.cos(X[0])", X, 0.0) - interpolator=make_interpolator(X_in, X_out) + interpolator=make_interpolator(X_in, X_out) - call interpolate_field(interpolator, T_in, T_out) + call interpolate_field(interpolator, T_in, T_out) - call field_stats(T_in, X_in, fmin_in, fmax_in, fnorm2_in, fintegral_in) + call field_stats(T_in, X_in, fmin_in, fmax_in, fnorm2_in, fintegral_in) - call field_stats(T_out, X_out, fmin_out, fmax_out, fnorm2_out, fintegral_out) + call field_stats(T_out, X_out, fmin_out, fmax_out, fnorm2_out, fintegral_out) - print '(a10, 2a22)', " ","T_in","T_out" - print '(a10, g22.8, g22.8)', "Minimum", fmin_in, fmin_out - print '(a10, g22.8, g22.8)', "Maximum", fmax_in, fmax_out - print '(a10, g22.8, g22.8)', "2-norm", fnorm2_in, fnorm2_out - print '(a10, g22.8, g22.8)', "integral", integral_in, integral_out + print '(a10, 2a22)', " ","T_in","T_out" + print '(a10, g22.8, g22.8)', "Minimum", fmin_in, fmin_out + print '(a10, g22.8, g22.8)', "Maximum", fmax_in, fmax_out + print '(a10, g22.8, g22.8)', "2-norm", fnorm2_in, fnorm2_out + print '(a10, g22.8, g22.8)', "integral", integral_in, integral_out - call vtk_write_fields("interpolation_in", 0, X_in, X_in%mesh, (/T_in/)) - call vtk_write_fields("interpolation_out", 0, X_in, X_in%mesh, (/T_out/)) + call vtk_write_fields("interpolation_in", 0, X_in, X_in%mesh, (/T_in/)) + call vtk_write_fields("interpolation_out", 0, X_in, X_in%mesh, (/T_out/)) end subroutine test_interpolation diff --git a/femtools/tests/test_interpolation_quadratic.F90 b/femtools/tests/test_interpolation_quadratic.F90 index d37aaeb946..0971979a87 100644 --- a/femtools/tests/test_interpolation_quadratic.F90 +++ b/femtools/tests/test_interpolation_quadratic.F90 @@ -1,69 +1,69 @@ subroutine test_interpolation_quadratic - use elements - use mesh_files - use fields - use state_module - use vector_tools - use unittest_tools - use interpolation_module - use vtk_interfaces - implicit none - - type(vector_field) :: old_positions, new_positions - type(mesh_type) :: p2_old_mesh, p2_new_mesh - type(scalar_field) :: p2_old_field, p2_new_field - type(element_type) :: p2_shape - type(state_type) :: old_state, new_state - real :: old_integral, new_integral - - logical :: fail - - interface - function solution(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - old_positions = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") - new_positions = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") - - p2_shape = make_element_shape(vertices = 3, dim =2, degree=2, quad=old_positions%mesh%shape%quadrature) - p2_old_mesh = make_mesh(old_positions%mesh, p2_shape, name="QuadraticMesh") - call allocate(p2_old_field, p2_old_mesh, "P2Field") - call set_from_function(p2_old_field, solution, old_positions) - old_integral = field_integral(p2_old_field, old_positions) - - p2_new_mesh = make_mesh(new_positions%mesh, p2_shape, name="QuadraticMesh") - call allocate(p2_new_field, p2_new_mesh, "P2Field") - call zero(p2_new_field) - - call insert(old_state, old_positions, "Coordinate") - call insert(old_state, p2_old_mesh, "Mesh") - call insert(old_state, p2_old_field, "P2Field") - - call insert(new_state, new_positions, "Coordinate") - call insert(new_state, p2_new_mesh, "Mesh") - call insert(new_state, p2_new_field, "P2Field") - - call linear_interpolation(old_state, new_state) - - call vtk_write_state("data/quadratic_interpolation", 0, state=(/old_state/)) - call vtk_write_state("data/quadratic_interpolation", 1, state=(/new_state/)) - - new_integral = field_integral(p2_new_field, new_positions) - - fail = (abs(old_integral - new_integral) > epsilon(0.0)) - call report_test("[test_interpolation_quadratic]", fail, .false., "Should be exact") + use elements + use mesh_files + use fields + use state_module + use vector_tools + use unittest_tools + use interpolation_module + use vtk_interfaces + implicit none + + type(vector_field) :: old_positions, new_positions + type(mesh_type) :: p2_old_mesh, p2_new_mesh + type(scalar_field) :: p2_old_field, p2_new_field + type(element_type) :: p2_shape + type(state_type) :: old_state, new_state + real :: old_integral, new_integral + + logical :: fail + + interface + function solution(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + old_positions = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") + new_positions = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") + + p2_shape = make_element_shape(vertices = 3, dim =2, degree=2, quad=old_positions%mesh%shape%quadrature) + p2_old_mesh = make_mesh(old_positions%mesh, p2_shape, name="QuadraticMesh") + call allocate(p2_old_field, p2_old_mesh, "P2Field") + call set_from_function(p2_old_field, solution, old_positions) + old_integral = field_integral(p2_old_field, old_positions) + + p2_new_mesh = make_mesh(new_positions%mesh, p2_shape, name="QuadraticMesh") + call allocate(p2_new_field, p2_new_mesh, "P2Field") + call zero(p2_new_field) + + call insert(old_state, old_positions, "Coordinate") + call insert(old_state, p2_old_mesh, "Mesh") + call insert(old_state, p2_old_field, "P2Field") + + call insert(new_state, new_positions, "Coordinate") + call insert(new_state, p2_new_mesh, "Mesh") + call insert(new_state, p2_new_field, "P2Field") + + call linear_interpolation(old_state, new_state) + + call vtk_write_state("data/quadratic_interpolation", 0, state=(/old_state/)) + call vtk_write_state("data/quadratic_interpolation", 1, state=(/new_state/)) + + new_integral = field_integral(p2_new_field, new_positions) + + fail = (abs(old_integral - new_integral) > epsilon(0.0)) + call report_test("[test_interpolation_quadratic]", fail, .false., "Should be exact") end subroutine test_interpolation_quadratic function solution(pos) - real, dimension(:) :: pos - real :: solution - real :: x,y - x = pos(1); y = pos(2) + real, dimension(:) :: pos + real :: solution + real :: x,y + x = pos(1); y = pos(2) - solution = x**2 + solution = x**2 end function solution diff --git a/femtools/tests/test_intersection_finder_2d.F90 b/femtools/tests/test_intersection_finder_2d.F90 index cd65275e3c..92b909c6b3 100644 --- a/femtools/tests/test_intersection_finder_2d.F90 +++ b/femtools/tests/test_intersection_finder_2d.F90 @@ -1,51 +1,51 @@ subroutine test_intersection_finder_2d - use unittest_tools - use mesh_files - use fields - use linked_lists - use intersection_finder_module - - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(1) :: map_AB - type(ilist), dimension(3) :: bigger_map_AB - !type(inode), pointer :: node - - integer :: i - logical :: fail - - positionsA = read_mesh_files("data/triangle.1", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/triangle.1", quad_degree=4, format="gmsh") - map_AB = advancing_front_intersection_finder(positionsA, positionsB) - - fail = (map_AB(1)%length /= 1) - call report_test("[intersection finder: length]", fail, .false., "There shall be only one") - - i = fetch(map_AB(1), 1) - fail = (i /= 1) - call report_test("[intersection finder: correct]", fail, .false., "The answer should be one") - - call deallocate(positionsB) - positionsB = read_mesh_files("data/triangle.2", quad_degree=4, format="gmsh") - map_AB = advancing_front_intersection_finder(positionsA, positionsB) - - fail = (map_AB(1)%length /= 3) - call report_test("[intersection finder: length]", fail, .false., "There shall be three elements") - !node => map_AB(1)%firstnode - !do while (associated(node)) - ! write(0,*) "node%value: ", node%value - ! node => node%next - !end do - - call deallocate(positionsA) - positionsA = read_mesh_files("data/triangle.2", quad_degree=4, format="gmsh") - bigger_map_AB = advancing_front_intersection_finder(positionsA, positionsB) - do i=1,ele_count(positionsA) - fail = (bigger_map_AB(i)%length < 1) - call report_test("[intersection finder: length]", fail, .false., "There shall be only one") - - fail = (.not. has_value(bigger_map_AB(i), i)) - call report_test("[intersection finder: correct]", fail, .false., "The answer should be correct") - end do + use unittest_tools + use mesh_files + use fields + use linked_lists + use intersection_finder_module + + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(1) :: map_AB + type(ilist), dimension(3) :: bigger_map_AB + !type(inode), pointer :: node + + integer :: i + logical :: fail + + positionsA = read_mesh_files("data/triangle.1", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/triangle.1", quad_degree=4, format="gmsh") + map_AB = advancing_front_intersection_finder(positionsA, positionsB) + + fail = (map_AB(1)%length /= 1) + call report_test("[intersection finder: length]", fail, .false., "There shall be only one") + + i = fetch(map_AB(1), 1) + fail = (i /= 1) + call report_test("[intersection finder: correct]", fail, .false., "The answer should be one") + + call deallocate(positionsB) + positionsB = read_mesh_files("data/triangle.2", quad_degree=4, format="gmsh") + map_AB = advancing_front_intersection_finder(positionsA, positionsB) + + fail = (map_AB(1)%length /= 3) + call report_test("[intersection finder: length]", fail, .false., "There shall be three elements") + !node => map_AB(1)%firstnode + !do while (associated(node)) + ! write(0,*) "node%value: ", node%value + ! node => node%next + !end do + + call deallocate(positionsA) + positionsA = read_mesh_files("data/triangle.2", quad_degree=4, format="gmsh") + bigger_map_AB = advancing_front_intersection_finder(positionsA, positionsB) + do i=1,ele_count(positionsA) + fail = (bigger_map_AB(i)%length < 1) + call report_test("[intersection finder: length]", fail, .false., "There shall be only one") + + fail = (.not. has_value(bigger_map_AB(i), i)) + call report_test("[intersection finder: correct]", fail, .false., "The answer should be correct") + end do end subroutine test_intersection_finder_2d diff --git a/femtools/tests/test_intersection_finder_3d.F90 b/femtools/tests/test_intersection_finder_3d.F90 index c4802f83e9..329df08015 100644 --- a/femtools/tests/test_intersection_finder_3d.F90 +++ b/femtools/tests/test_intersection_finder_3d.F90 @@ -1,26 +1,26 @@ subroutine test_intersection_finder_3d - use unittest_tools - use mesh_files - use fields - use linked_lists - use intersection_finder_module + use unittest_tools + use mesh_files + use fields + use linked_lists + use intersection_finder_module - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(1) :: map_AB + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(1) :: map_AB - integer :: i - logical :: fail + integer :: i + logical :: fail - positionsA = read_mesh_files("data/tet", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/tet", quad_degree=4, format="gmsh") - map_AB = advancing_front_intersection_finder(positionsA, positionsB) + positionsA = read_mesh_files("data/tet", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/tet", quad_degree=4, format="gmsh") + map_AB = advancing_front_intersection_finder(positionsA, positionsB) - fail = (map_AB(1)%length /= 1) - call report_test("[intersection finder: length]", fail, .false., "There shall be only one") + fail = (map_AB(1)%length /= 1) + call report_test("[intersection finder: length]", fail, .false., "There shall be only one") - i = fetch(map_AB(1), 1) - fail = (i /= 1) - call report_test("[intersection finder: correct]", fail, .false., "The answer should be one") + i = fetch(map_AB(1), 1) + fail = (i /= 1) + call report_test("[intersection finder: correct]", fail, .false., "The answer should be one") end subroutine test_intersection_finder_3d diff --git a/femtools/tests/test_intersection_finder_completeness.F90 b/femtools/tests/test_intersection_finder_completeness.F90 index 92f55a1454..5a26e82994 100644 --- a/femtools/tests/test_intersection_finder_completeness.F90 +++ b/femtools/tests/test_intersection_finder_completeness.F90 @@ -2,60 +2,60 @@ subroutine test_intersection_finder_completeness - use unittest_tools - use mesh_files - use fields - use linked_lists - use intersection_finder_module - use transform_elements - use elements - use supermesh_construction - - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(:), allocatable :: map_BA - real, dimension(:), allocatable :: detwei - integer :: ele_A, ele_B, ele_C - real :: vol_B, vols_C - logical :: fail, empty_intersection - type(inode), pointer :: llnode - type(vector_field) :: intersection - - positionsA = read_mesh_files("data/intersection_finder.1", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/intersection_finder.2", quad_degree=4, format="gmsh") - - allocate(map_BA(ele_count(positionsB))) - allocate(detwei(ele_ngi(positionsA, 1))) - - map_BA = advancing_front_intersection_finder(positionsB, positionsA) - call intersector_set_dimension(positionsA%dim) - - do ele_B=1,ele_count(positionsB) - call transform_to_physical(positionsB, ele_B, detwei=detwei) - vol_B = sum(detwei) - - llnode => map_BA(ele_B)%firstnode - vols_C = 0.0 - do while(associated(llnode)) - ele_A = llnode%value - intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), ele_shape(positionsB, ele_B), empty_intersection=empty_intersection) - if (empty_intersection) then + use unittest_tools + use mesh_files + use fields + use linked_lists + use intersection_finder_module + use transform_elements + use elements + use supermesh_construction + + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(:), allocatable :: map_BA + real, dimension(:), allocatable :: detwei + integer :: ele_A, ele_B, ele_C + real :: vol_B, vols_C + logical :: fail, empty_intersection + type(inode), pointer :: llnode + type(vector_field) :: intersection + + positionsA = read_mesh_files("data/intersection_finder.1", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/intersection_finder.2", quad_degree=4, format="gmsh") + + allocate(map_BA(ele_count(positionsB))) + allocate(detwei(ele_ngi(positionsA, 1))) + + map_BA = advancing_front_intersection_finder(positionsB, positionsA) + call intersector_set_dimension(positionsA%dim) + + do ele_B=1,ele_count(positionsB) + call transform_to_physical(positionsB, ele_B, detwei=detwei) + vol_B = sum(detwei) + + llnode => map_BA(ele_B)%firstnode + vols_C = 0.0 + do while(associated(llnode)) + ele_A = llnode%value + intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), ele_shape(positionsB, ele_B), empty_intersection=empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if + do ele_C=1,ele_count(intersection) + call transform_to_physical(intersection, ele_C, detwei=detwei) + vols_C = vols_C + sum(detwei) + end do llnode => llnode%next - cycle - end if - do ele_C=1,ele_count(intersection) - call transform_to_physical(intersection, ele_C, detwei=detwei) - vols_C = vols_C + sum(detwei) end do - llnode => llnode%next - end do - - fail = (vol_B .fne. vols_C) - call report_test("[intersection finder: completeness]", fail, .false., "Need to have the same volume!") - if (fail) then - write(0,*) "ele_B: ", ele_B - write(0,*) "vol_B: ", vol_B - write(0,*) "vols_C: ", vols_C - end if - end do + + fail = (vol_B .fne. vols_C) + call report_test("[intersection finder: completeness]", fail, .false., "Need to have the same volume!") + if (fail) then + write(0,*) "ele_B: ", ele_B + write(0,*) "vol_B: ", vol_B + write(0,*) "vols_C: ", vols_C + end if + end do end subroutine test_intersection_finder_completeness diff --git a/femtools/tests/test_intersection_finder_completeness_3d.F90 b/femtools/tests/test_intersection_finder_completeness_3d.F90 index 6b0a00528e..cc6264f918 100644 --- a/femtools/tests/test_intersection_finder_completeness_3d.F90 +++ b/femtools/tests/test_intersection_finder_completeness_3d.F90 @@ -2,63 +2,63 @@ subroutine test_intersection_finder_completeness_3d - use unittest_tools - use mesh_files - use fields - use linked_lists - use intersection_finder_module - use transform_elements - use elements - use supermesh_construction + use unittest_tools + use mesh_files + use fields + use linked_lists + use intersection_finder_module + use transform_elements + use elements + use supermesh_construction - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(:), allocatable :: map_BA - real, dimension(:), allocatable :: detwei - integer :: ele_A, ele_B, ele_C - real :: vol_B, vols_C - logical :: fail, empty_intersection - type(inode), pointer :: llnode - type(vector_field) :: intersection + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(:), allocatable :: map_BA + real, dimension(:), allocatable :: detwei + integer :: ele_A, ele_B, ele_C + real :: vol_B, vols_C + logical :: fail, empty_intersection + type(inode), pointer :: llnode + type(vector_field) :: intersection - positionsA = read_mesh_files("data/cube.1", quad_degree=6, format="gmsh") - positionsB = read_mesh_files("data/cube.2", quad_degree=6, format="gmsh") + positionsA = read_mesh_files("data/cube.1", quad_degree=6, format="gmsh") + positionsB = read_mesh_files("data/cube.2", quad_degree=6, format="gmsh") - allocate(map_BA(ele_count(positionsB))) - allocate(detwei(ele_ngi(positionsA, 1))) + allocate(map_BA(ele_count(positionsB))) + allocate(detwei(ele_ngi(positionsA, 1))) - map_BA = advancing_front_intersection_finder(positionsB, positionsA) - call intersector_set_dimension(positionsA%dim) + map_BA = advancing_front_intersection_finder(positionsB, positionsA) + call intersector_set_dimension(positionsA%dim) #ifdef HAVE_CGAL - call intersector_set_exactness(.true.) + call intersector_set_exactness(.true.) #endif - do ele_B=1,ele_count(positionsB) - call transform_to_physical(positionsB, ele_B, detwei=detwei) - vol_B = sum(detwei) + do ele_B=1,ele_count(positionsB) + call transform_to_physical(positionsB, ele_B, detwei=detwei) + vol_B = sum(detwei) - llnode => map_BA(ele_B)%firstnode - vols_C = 0.0 - do while(associated(llnode)) - ele_A = llnode%value - intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), ele_shape(positionsB, ele_B), empty_intersection=empty_intersection) - if (empty_intersection) then + llnode => map_BA(ele_B)%firstnode + vols_C = 0.0 + do while(associated(llnode)) + ele_A = llnode%value + intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), ele_shape(positionsB, ele_B), empty_intersection=empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if + do ele_C=1,ele_count(intersection) + call transform_to_physical(intersection, ele_C, detwei=detwei) + vols_C = vols_C + sum(detwei) + end do llnode => llnode%next - cycle - end if - do ele_C=1,ele_count(intersection) - call transform_to_physical(intersection, ele_C, detwei=detwei) - vols_C = vols_C + sum(detwei) end do - llnode => llnode%next - end do - fail = (vol_B .fne. vols_C) - call report_test("[intersection finder 3D: completeness]", fail, .false., "Need to have the same volume!") - if (fail) then - write(0,*) "ele_B: ", ele_B - write(0,*) "vol_B: ", vol_B - write(0,*) "vols_C: ", vols_C - end if - end do + fail = (vol_B .fne. vols_C) + call report_test("[intersection finder 3D: completeness]", fail, .false., "Need to have the same volume!") + if (fail) then + write(0,*) "ele_B: ", ele_B + write(0,*) "vol_B: ", vol_B + write(0,*) "vols_C: ", vols_C + end if + end do end subroutine test_intersection_finder_completeness_3d diff --git a/femtools/tests/test_intersection_finder_periodic.F90 b/femtools/tests/test_intersection_finder_periodic.F90 index 8d397b4eef..9b497d7818 100644 --- a/femtools/tests/test_intersection_finder_periodic.F90 +++ b/femtools/tests/test_intersection_finder_periodic.F90 @@ -1,25 +1,25 @@ subroutine test_intersection_finder_periodic - use intersection_finder_module - use fields - use linked_lists - use mesh_files - use unittest_tools - implicit none + use intersection_finder_module + use fields + use linked_lists + use mesh_files + use unittest_tools + implicit none - type(vector_field) :: posA, posB - type(ilist), dimension(1) :: map_AB - logical :: fail + type(vector_field) :: posA, posB + type(ilist), dimension(1) :: map_AB + logical :: fail - ! A has one element - ! B has two disconnected elements + ! A has one element + ! B has two disconnected elements - posA = read_mesh_files("data/intersection_finder_periodic_A", quad_degree=4, format="gmsh") - posB = read_mesh_files("data/intersection_finder_periodic_B", quad_degree=4, format="gmsh") + posA = read_mesh_files("data/intersection_finder_periodic_A", quad_degree=4, format="gmsh") + posB = read_mesh_files("data/intersection_finder_periodic_B", quad_degree=4, format="gmsh") - map_AB = intersection_finder(posA, posB) + map_AB = intersection_finder(posA, posB) - fail = (map_AB(1)%length /= 2) - call report_test("[intersection finder periodic]", fail, .false., "") + fail = (map_AB(1)%length /= 2) + call report_test("[intersection finder periodic]", fail, .false., "") end subroutine test_intersection_finder_periodic diff --git a/femtools/tests/test_intersection_finder_seeds.F90 b/femtools/tests/test_intersection_finder_seeds.F90 index 85e1857037..c4ad8a8399 100644 --- a/femtools/tests/test_intersection_finder_seeds.F90 +++ b/femtools/tests/test_intersection_finder_seeds.F90 @@ -29,85 +29,85 @@ subroutine test_intersection_finder_seeds - use elements - use fields - use linked_lists - use quadrature - use unittest_tools - use intersection_finder_module - - implicit none - - integer :: i - integer, dimension(2) :: seeds_vec - logical, dimension(4) :: ele_found - type(element_type) :: shape - type(ilist) :: seeds - type(ilist), dimension(4) :: map - type(inode), pointer :: node - type(mesh_type) :: mesh - type(quadrature_type) :: quad - type(vector_field) :: positions - - quad = make_quadrature(vertices = 2, dim = 1, degree = 1) - shape = make_element_shape(vertices = 2, dim = 1, degree = 1, quad = quad) - call deallocate(quad) - - call allocate(mesh, nodes = 6, elements = 4, shape = shape, name = "CoordinateMesh") - call deallocate(shape) - call set_ele_nodes(mesh, 1, (/1, 2/)) - call set_ele_nodes(mesh, 2, (/2, 3/)) - call set_ele_nodes(mesh, 3, (/4, 5/)) - call set_ele_nodes(mesh, 4, (/5, 6/)) - - call allocate(positions, 1, mesh, "Coordinate") - call deallocate(mesh) - do i = 1, node_count(positions) - call set(positions, i, spread(float(i), 1, 1)) - end do - - seeds = advancing_front_intersection_finder_seeds(positions) - - call report_test("[number of seeds]", seeds%length /= 2, .false., "Incorrect number of seeds") - seeds_vec = list2vector(seeds) - call report_test("[seed]", seeds_vec(1) /= 1, .false., "Incorrect seed") - call report_test("[seed]", seeds_vec(2) /= 3, .false., "Incorrect seed") + use elements + use fields + use linked_lists + use quadrature + use unittest_tools + use intersection_finder_module + + implicit none + + integer :: i + integer, dimension(2) :: seeds_vec + logical, dimension(4) :: ele_found + type(element_type) :: shape + type(ilist) :: seeds + type(ilist), dimension(4) :: map + type(inode), pointer :: node + type(mesh_type) :: mesh + type(quadrature_type) :: quad + type(vector_field) :: positions + + quad = make_quadrature(vertices = 2, dim = 1, degree = 1) + shape = make_element_shape(vertices = 2, dim = 1, degree = 1, quad = quad) + call deallocate(quad) + + call allocate(mesh, nodes = 6, elements = 4, shape = shape, name = "CoordinateMesh") + call deallocate(shape) + call set_ele_nodes(mesh, 1, (/1, 2/)) + call set_ele_nodes(mesh, 2, (/2, 3/)) + call set_ele_nodes(mesh, 3, (/4, 5/)) + call set_ele_nodes(mesh, 4, (/5, 6/)) + + call allocate(positions, 1, mesh, "Coordinate") + call deallocate(mesh) + do i = 1, node_count(positions) + call set(positions, i, spread(float(i), 1, 1)) + end do + + seeds = advancing_front_intersection_finder_seeds(positions) + + call report_test("[number of seeds]", seeds%length /= 2, .false., "Incorrect number of seeds") + seeds_vec = list2vector(seeds) + call report_test("[seed]", seeds_vec(1) /= 1, .false., "Incorrect seed") + call report_test("[seed]", seeds_vec(2) /= 3, .false., "Incorrect seed") #ifndef HAVE_LIBSUPERMESH - map = advancing_front_intersection_finder(positions, positions, seed = seeds_vec(1)) - ele_found = .false. - do i = 1, size(map) - node => map(i)%firstnode - do while(associated(node)) - ele_found(node%value) = .true. - - node => node%next - end do - end do - call report_test("[intersection_finder]", .not. all(ele_found .eqv. (/.true., .true., .false., .false./)), .false., "Incorrect intersections reported") - do i = 1, size(map) - call deallocate(map(i)) - end do - - map = advancing_front_intersection_finder(positions, positions, seed = seeds_vec(2)) - ele_found = .false. - do i = 1, size(map) - node => map(i)%firstnode - do while(associated(node)) - ele_found(node%value) = .true. - - node => node%next - end do - end do - call report_test("[intersection_finder]", .not. all(ele_found .eqv. (/.false., .false., .true., .true./)), .false., "Incorrect intersections reported") - do i = 1, size(map) - call deallocate(map(i)) - end do + map = advancing_front_intersection_finder(positions, positions, seed = seeds_vec(1)) + ele_found = .false. + do i = 1, size(map) + node => map(i)%firstnode + do while(associated(node)) + ele_found(node%value) = .true. + + node => node%next + end do + end do + call report_test("[intersection_finder]", .not. all(ele_found .eqv. (/.true., .true., .false., .false./)), .false., "Incorrect intersections reported") + do i = 1, size(map) + call deallocate(map(i)) + end do + + map = advancing_front_intersection_finder(positions, positions, seed = seeds_vec(2)) + ele_found = .false. + do i = 1, size(map) + node => map(i)%firstnode + do while(associated(node)) + ele_found(node%value) = .true. + + node => node%next + end do + end do + call report_test("[intersection_finder]", .not. all(ele_found .eqv. (/.false., .false., .true., .true./)), .false., "Incorrect intersections reported") + do i = 1, size(map) + call deallocate(map(i)) + end do #endif - call deallocate(seeds) - call deallocate(positions) + call deallocate(seeds) + call deallocate(positions) - call report_test_no_references() + call report_test_no_references() end subroutine test_intersection_finder_seeds diff --git a/femtools/tests/test_invert.F90 b/femtools/tests/test_invert.F90 index 97f5f16592..1e0299cda1 100644 --- a/femtools/tests/test_invert.F90 +++ b/femtools/tests/test_invert.F90 @@ -1,15 +1,15 @@ subroutine test_invert - use vector_tools - use unittest_tools - implicit none + use vector_tools + use unittest_tools + implicit none - real, dimension(10, 10) :: mat, inv, tmp, id - logical :: fail, warn - integer :: i - character(len=20) :: buf + real, dimension(10, 10) :: mat, inv, tmp, id + logical :: fail, warn + integer :: i + character(len=20) :: buf - id = get_matrix_identity(10) + id = get_matrix_identity(10) !!$ mat=reshape((/0.0002083333333333334, -7.9576252343771758e-05, & @@ -72,17 +72,17 @@ subroutine test_invert !!$ if (.not. mat_zero(tmp)) fail = .true. !!$ call report_test("[invert " // trim(buf) // "]", fail, warn, "Invert should produce inverses.") - do i=1,5 - write(buf,'(i0)') i - fail = .false.; warn = .false. - mat = random_posdef_matrix(10) - inv = mat; call invert(inv) - tmp = matmul(mat, inv) - tmp = tmp - id + do i=1,5 + write(buf,'(i0)') i + fail = .false.; warn = .false. + mat = random_posdef_matrix(10) + inv = mat; call invert(inv) + tmp = matmul(mat, inv) + tmp = tmp - id - if (.not. mat_zero(tmp)) fail = .true. - call report_test("[invert " // trim(buf) // "]", fail, warn, "Invert should produce inverses.") - end do + if (.not. mat_zero(tmp)) fail = .true. + call report_test("[invert " // trim(buf) // "]", fail, warn, "Invert should produce inverses.") + end do ! mat(1, :) = (/1.0, 5.0, 2.0/) ! mat(2, :) = (/1.0, 1.0, 7.0/) diff --git a/femtools/tests/test_invert_dg_mass_matrix.F90 b/femtools/tests/test_invert_dg_mass_matrix.F90 index e4af7f4230..70acef6d97 100644 --- a/femtools/tests/test_invert_dg_mass_matrix.F90 +++ b/femtools/tests/test_invert_dg_mass_matrix.F90 @@ -1,54 +1,54 @@ subroutine test_invert_dg_mass_matrix - use fldebug - use quadrature - use fields - use mesh_files - use DGtools - use sparse_tools - use transform_elements - use Unittest_tools - use FETOols + use fldebug + use quadrature + use fields + use mesh_files + use DGtools + use sparse_tools + use transform_elements + use Unittest_tools + use FETOols - type(csr_matrix) :: inverse_mass - type(scalar_field), target :: u, rhs, u_check - integer :: quad_degree - type(quadrature_type), target :: quad - type(element_type), target :: X_shape, u_shape - type(mesh_type) :: u_mesh - type(vector_field) :: positions + type(csr_matrix) :: inverse_mass + type(scalar_field), target :: u, rhs, u_check + integer :: quad_degree + type(quadrature_type), target :: quad + type(element_type), target :: X_shape, u_shape + type(mesh_type) :: u_mesh + type(vector_field) :: positions - logical :: fail, warn + logical :: fail, warn - quad_degree = 4 - quad=make_quadrature(vertices = 3, dim =2, degree=quad_degree) - X_shape=make_element_shape(vertices = 3, dim =2, degree=1, quad=quad) - positions=read_mesh_files('data/square.1', quad_degree=quad_degree, format="gmsh") - u_shape=make_element_shape(vertices = 3, dim =2, degree=1, quad=quad) - u_mesh = make_mesh(positions%mesh,u_shape,-1,'u_mesh') + quad_degree = 4 + quad=make_quadrature(vertices = 3, dim =2, degree=quad_degree) + X_shape=make_element_shape(vertices = 3, dim =2, degree=1, quad=quad) + positions=read_mesh_files('data/square.1', quad_degree=quad_degree, format="gmsh") + u_shape=make_element_shape(vertices = 3, dim =2, degree=1, quad=quad) + u_mesh = make_mesh(positions%mesh,u_shape,-1,'u_mesh') - call get_dg_inverse_mass_matrix(inverse_mass,u_mesh,positions) + call get_dg_inverse_mass_matrix(inverse_mass,u_mesh,positions) - call allocate(rhs,u_mesh,'RHS') - call allocate(u,u_mesh,'u') - call allocate(u_check,u_mesh,'u_check') + call allocate(rhs,u_mesh,'RHS') + call allocate(u,u_mesh,'u') + call allocate(u_check,u_mesh,'u_check') - u%val = 1.0 + u%val = 1.0 - call get_rhs(rhs,u,positions) + call get_rhs(rhs,u,positions) - u_check%val = 0.0 - call mult(u_check%val,inverse_mass,rhs%val) + u_check%val = 0.0 + call mult(u_check%val,inverse_mass,rhs%val) - warn = maxval(abs(u%val-u_check%val))>1.0e-13 - fail = maxval(abs(u%val-u_check%val))>1.0e-10 + warn = maxval(abs(u%val-u_check%val))>1.0e-13 + fail = maxval(abs(u%val-u_check%val))>1.0e-10 - call report_test("[inverse dg mass matrix formed correctly using dynamic csr matrices]", warn, fail, & - "Inverse dg mass matrix not formed correctly") + call report_test("[inverse dg mass matrix formed correctly using dynamic csr matrices]", warn, fail, & + "Inverse dg mass matrix not formed correctly") - contains +contains - subroutine get_rhs(rhs,u,positions) + subroutine get_rhs(rhs,u,positions) type(scalar_field), intent(in) :: u type(scalar_field), intent(inout) :: rhs type(vector_field), intent(in) :: positions @@ -64,9 +64,9 @@ subroutine get_rhs(rhs,u,positions) end do - end subroutine get_rhs + end subroutine get_rhs - subroutine assemble_rhs(ele,rhs,u,positions) + subroutine assemble_rhs(ele,rhs,u,positions) integer, intent(in) :: ele type(scalar_field), intent(in) :: u type(scalar_field), intent(inout) :: rhs @@ -90,6 +90,6 @@ subroutine assemble_rhs(ele,rhs,u,positions) call addto(rhs,ele_u,matmul(mass_loc,u%val(ele_u))) - end subroutine assemble_rhs + end subroutine assemble_rhs end subroutine test_invert_dg_mass_matrix diff --git a/femtools/tests/test_is_nan.F90 b/femtools/tests/test_is_nan.F90 index b51116d02b..0210fdfba3 100644 --- a/femtools/tests/test_is_nan.F90 +++ b/femtools/tests/test_is_nan.F90 @@ -1,23 +1,23 @@ subroutine test_is_nan - use unittest_tools - implicit none + use unittest_tools + implicit none - real :: nan, zero, zero2, rand - logical :: fail, isnan_output + real :: nan, zero, zero2, rand + logical :: fail, isnan_output - call random_number(rand) + call random_number(rand) - fail = .false. - zero = 0.0 - zero2 = 0.0 - zero2 = zero2 * zero * rand - nan = zero2 / zero + fail = .false. + zero = 0.0 + zero2 = 0.0 + zero2 = zero2 * zero * rand + nan = zero2 / zero - isnan_output = is_nan(nan) + isnan_output = is_nan(nan) - if (.not. is_nan(nan)) fail = .true. - call report_test("[is NaN]", fail, .false., "is_nan should report & - & true for NaN.") + if (.not. is_nan(nan)) fail = .true. + call report_test("[is NaN]", fail, .false., "is_nan should report & + & true for NaN.") end subroutine test_is_nan diff --git a/femtools/tests/test_ispcolouring.F90 b/femtools/tests/test_ispcolouring.F90 index 897bd44cdd..7537f621c9 100644 --- a/femtools/tests/test_ispcolouring.F90 +++ b/femtools/tests/test_ispcolouring.F90 @@ -26,38 +26,38 @@ ! USA #include "fdebug.h" - subroutine test_ispcolouring - use sparse_tools - use fields_data_types - use fields_manipulation - use state_module - use vtk_interfaces - use colouring - use sparsity_patterns - use unittest_tools - use mesh_files - implicit none - - type(vector_field) :: positions - type(mesh_type) :: mesh - type(csr_sparsity) :: sparsity - type(csr_sparsity) :: isp_sparsity - logical :: fail=.false. - type(scalar_field) :: node_colour - integer :: no_colours - - positions = read_mesh_files('data/square-cavity-2d', quad_degree=4, format="gmsh") - mesh = piecewise_constant_mesh(positions%mesh, "P0Mesh") - sparsity = make_sparsity_compactdgdouble(mesh, "cdG Sparsity") - - isp_sparsity=mat_sparsity_to_isp_sparsity(sparsity) - - call colour_sparsity(isp_sparsity, mesh, node_colour, no_colours) - - fail=.not. verify_colour_sparsity(isp_sparsity, node_colour) - call report_test("colour sets", fail, .false., "the adjacency sparsity colouring is not valid") - - fail=.not. verify_colour_ispsparsity(sparsity, node_colour) - call report_test("colour sets", fail, .false., "the csr sparcity colouring is not valid") - - end subroutine test_ispcolouring +subroutine test_ispcolouring + use sparse_tools + use fields_data_types + use fields_manipulation + use state_module + use vtk_interfaces + use colouring + use sparsity_patterns + use unittest_tools + use mesh_files + implicit none + + type(vector_field) :: positions + type(mesh_type) :: mesh + type(csr_sparsity) :: sparsity + type(csr_sparsity) :: isp_sparsity + logical :: fail=.false. + type(scalar_field) :: node_colour + integer :: no_colours + + positions = read_mesh_files('data/square-cavity-2d', quad_degree=4, format="gmsh") + mesh = piecewise_constant_mesh(positions%mesh, "P0Mesh") + sparsity = make_sparsity_compactdgdouble(mesh, "cdG Sparsity") + + isp_sparsity=mat_sparsity_to_isp_sparsity(sparsity) + + call colour_sparsity(isp_sparsity, mesh, node_colour, no_colours) + + fail=.not. verify_colour_sparsity(isp_sparsity, node_colour) + call report_test("colour sets", fail, .false., "the adjacency sparsity colouring is not valid") + + fail=.not. verify_colour_ispsparsity(sparsity, node_colour) + call report_test("colour sets", fail, .false., "the csr sparcity colouring is not valid") + +end subroutine test_ispcolouring diff --git a/femtools/tests/test_jacobian.F90 b/femtools/tests/test_jacobian.F90 index b034a89fc1..6e3557d5e7 100644 --- a/femtools/tests/test_jacobian.F90 +++ b/femtools/tests/test_jacobian.F90 @@ -1,48 +1,48 @@ subroutine test_jacobian - !!< test computation of jacobian for a 2D triangle embedded in 3D space - - use transform_elements - use elements - use quadrature - use shape_functions - use fields - use unittest_tools - - implicit none - - integer, parameter :: dim=2, loc=3, quad_degree=4 - integer, parameter :: xdim=3 - - type(mesh_type):: mesh - type(vector_field):: X - type(element_type), pointer :: shape - type(quadrature_type), pointer :: quad - real, allocatable, dimension(:,:,:) :: J - real, allocatable, dimension(:) :: detwei - logical :: fail - - allocate(quad) - allocate(shape) - - quad=make_quadrature(loc, dim, quad_degree) - shape=make_element_shape(loc, dim, 1, quad) - allocate(J(dim,xdim,shape%ngi)) - allocate(detwei(shape%ngi)) - - ! create single triangle mesh - call allocate(mesh, loc, 1, shape, "OneElementMesh") - call set_ele_nodes(mesh, 1, (/1,2,3/)) - - ! and 3D positions field on it - call allocate(X, 3, mesh, "Coordinate") - call set(X, 1, (/0.0, 0.0, 0.0/)) - call set(X, 2, (/2.0, 0.0, 0.0/)) - call set(X, 3, (/0.0, 1.0, 1.0/)) - - ! compute jacobian - call compute_jacobian(X, 1, J, detwei=detwei) - - fail = abs(sum(detwei)-sqrt(2.0))>1e-10 - call report_test("[compute_jacobian]", fail, .false., "Incorrect Jacobian") + !!< test computation of jacobian for a 2D triangle embedded in 3D space + + use transform_elements + use elements + use quadrature + use shape_functions + use fields + use unittest_tools + + implicit none + + integer, parameter :: dim=2, loc=3, quad_degree=4 + integer, parameter :: xdim=3 + + type(mesh_type):: mesh + type(vector_field):: X + type(element_type), pointer :: shape + type(quadrature_type), pointer :: quad + real, allocatable, dimension(:,:,:) :: J + real, allocatable, dimension(:) :: detwei + logical :: fail + + allocate(quad) + allocate(shape) + + quad=make_quadrature(loc, dim, quad_degree) + shape=make_element_shape(loc, dim, 1, quad) + allocate(J(dim,xdim,shape%ngi)) + allocate(detwei(shape%ngi)) + + ! create single triangle mesh + call allocate(mesh, loc, 1, shape, "OneElementMesh") + call set_ele_nodes(mesh, 1, (/1,2,3/)) + + ! and 3D positions field on it + call allocate(X, 3, mesh, "Coordinate") + call set(X, 1, (/0.0, 0.0, 0.0/)) + call set(X, 2, (/2.0, 0.0, 0.0/)) + call set(X, 3, (/0.0, 1.0, 1.0/)) + + ! compute jacobian + call compute_jacobian(X, 1, J, detwei=detwei) + + fail = abs(sum(detwei)-sqrt(2.0))>1e-10 + call report_test("[compute_jacobian]", fail, .false., "Incorrect Jacobian") end subroutine test_jacobian diff --git a/femtools/tests/test_length_scale_tensor.F90 b/femtools/tests/test_length_scale_tensor.F90 index b45b6075c0..7fcd447ce1 100644 --- a/femtools/tests/test_length_scale_tensor.F90 +++ b/femtools/tests/test_length_scale_tensor.F90 @@ -64,8 +64,8 @@ subroutine test_length_scale_tensor ! This is only correct for regular right-angled triangles edge = edge**2/4. expected_result = reshape(& - (/ edge*5., -edge,& - & -edge, edge*5. /),(/2,2/)) + (/ edge*5., -edge,& + & -edge, edge*5. /),(/2,2/)) fail = .not.fequals(computed_result(:,:,1), expected_result, 1.0e-9) call report_test("[length_scale_tensor]", fail, .false., "Result from length_scale_tensor is incorrect.") diff --git a/femtools/tests/test_linked_edge_list.F90 b/femtools/tests/test_linked_edge_list.F90 index 0d1b8f2275..1298b35a4c 100644 --- a/femtools/tests/test_linked_edge_list.F90 +++ b/femtools/tests/test_linked_edge_list.F90 @@ -1,47 +1,47 @@ subroutine test_linked_edge_list - use linked_lists - use unittest_tools - implicit none - - type(elist) :: edgelist - logical :: fail - integer :: i, j - - fail = .false. - - if (edgelist%length /= 0) fail = .true. - call report_test("[edgelist initialised]", fail, .false., "Initial length & - & should be zero.") - - fail = .false. - call insert(edgelist, 1, 2) - if (edgelist%length /= 1) fail = .true. - if (.not. associated(edgelist%firstnode)) fail = .true. - if (.not. associated(edgelist%lastnode)) fail = .true. - call report_test("[edgelist first insert]", fail, .false., "After & - & first inserting, the list length should be 1.") - - fail = .false. - call insert(edgelist, 1, 3) - if (edgelist%length /= 2) fail = .true. - call report_test("[edgelist second insert]", fail, .false., "After & - & a second insert, the state should be correct.") - - fail = .false. - call spop(edgelist, i, j) - if (i /= 1) fail = .true. - if (j /= 2) fail = .true. - if (edgelist%length /= 1) fail = .true. - call report_test("[edgelist pop]", fail, .false., "Popping & - & from a list should give the first value inserted.") - - fail = .false. - call spop(edgelist, i, j) - if (i /= 1) fail = .true. - if (j /= 3) fail = .true. - if (edgelist%length /= 0) fail = .true. - call report_test("[edgelist clear]", fail, .false., "Popping & - & the last element should clear the list.") + use linked_lists + use unittest_tools + implicit none + + type(elist) :: edgelist + logical :: fail + integer :: i, j + + fail = .false. + + if (edgelist%length /= 0) fail = .true. + call report_test("[edgelist initialised]", fail, .false., "Initial length & + & should be zero.") + + fail = .false. + call insert(edgelist, 1, 2) + if (edgelist%length /= 1) fail = .true. + if (.not. associated(edgelist%firstnode)) fail = .true. + if (.not. associated(edgelist%lastnode)) fail = .true. + call report_test("[edgelist first insert]", fail, .false., "After & + & first inserting, the list length should be 1.") + + fail = .false. + call insert(edgelist, 1, 3) + if (edgelist%length /= 2) fail = .true. + call report_test("[edgelist second insert]", fail, .false., "After & + & a second insert, the state should be correct.") + + fail = .false. + call spop(edgelist, i, j) + if (i /= 1) fail = .true. + if (j /= 2) fail = .true. + if (edgelist%length /= 1) fail = .true. + call report_test("[edgelist pop]", fail, .false., "Popping & + & from a list should give the first value inserted.") + + fail = .false. + call spop(edgelist, i, j) + if (i /= 1) fail = .true. + if (j /= 3) fail = .true. + if (edgelist%length /= 0) fail = .true. + call report_test("[edgelist clear]", fail, .false., "Popping & + & the last element should clear the list.") end subroutine test_linked_edge_list diff --git a/femtools/tests/test_lon_lat_height_2_cartesian.F90 b/femtools/tests/test_lon_lat_height_2_cartesian.F90 index b935567b2a..25fb903e59 100644 --- a/femtools/tests/test_lon_lat_height_2_cartesian.F90 +++ b/femtools/tests/test_lon_lat_height_2_cartesian.F90 @@ -25,46 +25,46 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_lon_lat_height_2_cartesian - !Subroutine for testing correct conversion of point coordinates from longitude- - ! latitude-height into Cartesian coordinates. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine for testing correct conversion of point coordinates from longitude- + ! latitude-height into Cartesian coordinates. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: LonLatHeightCoordinate - type(vector_field), pointer :: CartesianCoordinate - type(vector_field) :: difference - integer :: node - real, dimension(3) :: LLH, XYZ !Arrays containing a single node's position vector - ! components in lon-lat-height & Cartesian coordinates. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: LonLatHeightCoordinate + type(vector_field), pointer :: CartesianCoordinate + type(vector_field) :: difference + integer :: node + real, dimension(3) :: LLH, XYZ !Arrays containing a single node's position vector + ! components in lon-lat-height & Cartesian coordinates. + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - !Extract the components of points in vtu file in lon-lat-radius, apply transformation and - ! compare with position-vector in Cartesian coordinates. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - call lon_lat_height_2_cartesian(LLH(1), LLH(2), LLH(3), & - XYZ(1), XYZ(2), XYZ(3), & - 0.0) - call set(difference, node, XYZ) - enddo - call addto(difference, CartesianCoordinate, -1.0) + !Extract the components of points in vtu file in lon-lat-radius, apply transformation and + ! compare with position-vector in Cartesian coordinates. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + call lon_lat_height_2_cartesian(LLH(1), LLH(2), LLH(3), & + XYZ(1), XYZ(2), XYZ(3), & + 0.0) + call set(difference, node, XYZ) + enddo + call addto(difference, CartesianCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: lon-lat-height to Cartesian.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: lon-lat-height to Cartesian.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_lon_lat_height_2_spherical_polar.F90 b/femtools/tests/test_lon_lat_height_2_spherical_polar.F90 index f63420b40d..270258ba7b 100644 --- a/femtools/tests/test_lon_lat_height_2_spherical_polar.F90 +++ b/femtools/tests/test_lon_lat_height_2_spherical_polar.F90 @@ -25,46 +25,46 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_lon_lat_height_2_spherical_polar - !Subroutine for testing correct conversion of point coordinates from longitude- - ! latitude-height into spherical-polar coordinates. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine for testing correct conversion of point coordinates from longitude- + ! latitude-height into spherical-polar coordinates. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: LonLatHeightCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - integer :: node - real, dimension(3) :: LLH, RTP !Arrays containing a single node's position vector - ! components in lon-lat-height & spherical-polar bases. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: LonLatHeightCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + integer :: node + real, dimension(3) :: LLH, RTP !Arrays containing a single node's position vector + ! components in lon-lat-height & spherical-polar bases. + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Extract the components of points in vtu file in lon-lat-radius, apply transformation and - ! compare with position-vector in spherical-polar coordinates. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - call lon_lat_height_2_spherical_polar(LLH(1), LLH(2), LLH(3), & - RTP(1), RTP(2), RTP(3), & - 0.0) - call set(difference, node, RTP) - enddo - call addto(difference, PolarCoordinate, -1.0) + !Extract the components of points in vtu file in lon-lat-radius, apply transformation and + ! compare with position-vector in spherical-polar coordinates. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + call lon_lat_height_2_spherical_polar(LLH(1), LLH(2), LLH(3), & + RTP(1), RTP(2), RTP(3), & + 0.0) + call set(difference, node, RTP) + enddo + call addto(difference, PolarCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: lon-lat-height to Spherical-polar.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: lon-lat-height to Spherical-polar.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_make_mesh_1d.F90 b/femtools/tests/test_make_mesh_1d.F90 index e6a9892bf1..950f288b62 100644 --- a/femtools/tests/test_make_mesh_1d.F90 +++ b/femtools/tests/test_make_mesh_1d.F90 @@ -29,99 +29,99 @@ subroutine test_make_mesh_1d - use futils - use element_numbering, only: FAMILY_SIMPLEX - use elements - use fields - use fldebug - use mesh_files - use unittest_tools - - implicit none - - integer :: degree, ele, node - integer, parameter :: min_degree = 1, max_degree = 20 - logical :: fail - real, dimension(:, :), allocatable :: l_coords, otn_l_coords - type(element_type) :: derived_shape - type(element_type), pointer :: base_shape - type(mesh_type) :: derived_mesh - type(mesh_type), pointer :: base_mesh - type(vector_field) :: positions_remap - type(vector_field), target :: positions - - positions = read_mesh_files("data/interval", quad_degree = 1, format="gmsh") - base_mesh => positions%mesh - base_shape => ele_shape(base_mesh, 1) - call report_test("[1-simplex input mesh]", & - & ele_numbering_family(base_shape) /= FAMILY_SIMPLEX .or. base_shape%degree /= 1 .or. base_shape%dim /= 1, .false., & - & "Input mesh not composed of 1-simplices") - - do degree = min_degree, max_degree - print "(a,i0)", "Degree = ", degree - - derived_shape = make_element_shape(base_shape, degree = degree) - call report_test("[Derived loc]", & + use futils + use element_numbering, only: FAMILY_SIMPLEX + use elements + use fields + use fldebug + use mesh_files + use unittest_tools + + implicit none + + integer :: degree, ele, node + integer, parameter :: min_degree = 1, max_degree = 20 + logical :: fail + real, dimension(:, :), allocatable :: l_coords, otn_l_coords + type(element_type) :: derived_shape + type(element_type), pointer :: base_shape + type(mesh_type) :: derived_mesh + type(mesh_type), pointer :: base_mesh + type(vector_field) :: positions_remap + type(vector_field), target :: positions + + positions = read_mesh_files("data/interval", quad_degree = 1, format="gmsh") + base_mesh => positions%mesh + base_shape => ele_shape(base_mesh, 1) + call report_test("[1-simplex input mesh]", & + & ele_numbering_family(base_shape) /= FAMILY_SIMPLEX .or. base_shape%degree /= 1 .or. base_shape%dim /= 1, .false., & + & "Input mesh not composed of 1-simplices") + + do degree = min_degree, max_degree + print "(a,i0)", "Degree = ", degree + + derived_shape = make_element_shape(base_shape, degree = degree) + call report_test("[Derived loc]", & & derived_shape%loc /= degree + 1, .false., & & "Incorrect local node count") - derived_mesh = make_mesh(base_mesh, derived_shape) - call report_test("[Derived ele_count]", & + derived_mesh = make_mesh(base_mesh, derived_shape) + call report_test("[Derived ele_count]", & & ele_count(derived_mesh) /= ele_count(base_mesh), .false., & & "Incorrect element count") - call allocate(positions_remap, positions%dim, derived_mesh, name = positions%name) - call remap_field(positions, positions_remap) - allocate(otn_l_coords(base_shape%loc, derived_shape%loc)) - otn_l_coords = d1_otn_local_coords(degree) - allocate(l_coords(base_shape%loc, derived_shape%loc)) - fail = .false. - ele_loop: do ele = 1, ele_count(derived_mesh) - fail = ele_loc(derived_mesh, ele) /= derived_shape%loc - if(fail) exit ele_loop - - l_coords = local_coords(positions, ele, ele_val(positions_remap, ele)) - fail = fnequals(l_coords, otn_l_coords, tol = 1.0e3 * epsilon(0.0)) - if(fail) then - do node = 1, size(l_coords, 2) - print *, node, l_coords(:, node) - print *, node, otn_l_coords(:, node) - end do - exit ele_loop - end if - end do ele_loop - deallocate(l_coords) - deallocate(otn_l_coords) - call deallocate(positions_remap) - - call report_test("[Derived mesh numbering]", fail, .false., "Invalid derived mesh numbering, failed on element " // int2str(ele)) - - call deallocate(derived_shape) - call deallocate(derived_mesh) - end do - - call deallocate(positions) - call report_test_no_references() + call allocate(positions_remap, positions%dim, derived_mesh, name = positions%name) + call remap_field(positions, positions_remap) + allocate(otn_l_coords(base_shape%loc, derived_shape%loc)) + otn_l_coords = d1_otn_local_coords(degree) + allocate(l_coords(base_shape%loc, derived_shape%loc)) + fail = .false. + ele_loop: do ele = 1, ele_count(derived_mesh) + fail = ele_loc(derived_mesh, ele) /= derived_shape%loc + if(fail) exit ele_loop + + l_coords = local_coords(positions, ele, ele_val(positions_remap, ele)) + fail = fnequals(l_coords, otn_l_coords, tol = 1.0e3 * epsilon(0.0)) + if(fail) then + do node = 1, size(l_coords, 2) + print *, node, l_coords(:, node) + print *, node, otn_l_coords(:, node) + end do + exit ele_loop + end if + end do ele_loop + deallocate(l_coords) + deallocate(otn_l_coords) + call deallocate(positions_remap) + + call report_test("[Derived mesh numbering]", fail, .false., "Invalid derived mesh numbering, failed on element " // int2str(ele)) + + call deallocate(derived_shape) + call deallocate(derived_mesh) + end do + + call deallocate(positions) + call report_test_no_references() contains - function d1_otn_local_coords(degree) result(l_coords) - !!< Return the node local coords according to the One True Element Numbering + function d1_otn_local_coords(degree) result(l_coords) + !!< Return the node local coords according to the One True Element Numbering - integer, intent(in) :: degree + integer, intent(in) :: degree - integer :: i, index - real, dimension(2, degree + 1) :: l_coords + integer :: i, index + real, dimension(2, degree + 1) :: l_coords - index = 1 - do i = 0, degree - assert(index <= size(l_coords, 2)) - l_coords(2, index) = float(i) / float(degree) - l_coords(1, index) = 1.0 - l_coords(2, index) - index = index + 1 - end do - assert(index == size(l_coords, 2) + 1) + index = 1 + do i = 0, degree + assert(index <= size(l_coords, 2)) + l_coords(2, index) = float(i) / float(degree) + l_coords(1, index) = 1.0 - l_coords(2, index) + index = index + 1 + end do + assert(index == size(l_coords, 2) + 1) - end function d1_otn_local_coords + end function d1_otn_local_coords end subroutine test_make_mesh_1d diff --git a/femtools/tests/test_make_mesh_tet.F90 b/femtools/tests/test_make_mesh_tet.F90 index 08f070a597..cf846c3623 100644 --- a/femtools/tests/test_make_mesh_tet.F90 +++ b/femtools/tests/test_make_mesh_tet.F90 @@ -29,105 +29,105 @@ subroutine test_make_mesh_tet - use futils, only: int2str - use element_numbering, only: FAMILY_SIMPLEX, te - use elements - use fields - use fldebug - use mesh_files - use unittest_tools - - implicit none - - integer :: degree, ele, node - integer, parameter :: min_degree = 1, max_degree = 3 - logical :: fail - real, dimension(:, :), allocatable :: l_coords, otn_l_coords - type(element_type) :: derived_shape - type(element_type), pointer :: base_shape - type(mesh_type) :: derived_mesh - type(mesh_type), pointer :: base_mesh - type(vector_field) :: positions_remap - type(vector_field), target :: positions - - positions = read_mesh_files("data/cube.3", quad_degree = 1, format="gmsh") - base_mesh => positions%mesh - base_shape => ele_shape(base_mesh, 1) - call report_test("[Linear tet input mesh]", & - & ele_numbering_family(base_shape) /= FAMILY_SIMPLEX .or. base_shape%degree /= 1 .or. base_shape%dim /= 3, .false., & - & "Input mesh not composed of linear tets") - - do degree = min_degree, max_degree - print "(a,i0)", "Degree = ", degree - - derived_shape = make_element_shape(base_shape, degree = degree) - call report_test("[Derived loc]", & + use futils, only: int2str + use element_numbering, only: FAMILY_SIMPLEX, te + use elements + use fields + use fldebug + use mesh_files + use unittest_tools + + implicit none + + integer :: degree, ele, node + integer, parameter :: min_degree = 1, max_degree = 3 + logical :: fail + real, dimension(:, :), allocatable :: l_coords, otn_l_coords + type(element_type) :: derived_shape + type(element_type), pointer :: base_shape + type(mesh_type) :: derived_mesh + type(mesh_type), pointer :: base_mesh + type(vector_field) :: positions_remap + type(vector_field), target :: positions + + positions = read_mesh_files("data/cube.3", quad_degree = 1, format="gmsh") + base_mesh => positions%mesh + base_shape => ele_shape(base_mesh, 1) + call report_test("[Linear tet input mesh]", & + & ele_numbering_family(base_shape) /= FAMILY_SIMPLEX .or. base_shape%degree /= 1 .or. base_shape%dim /= 3, .false., & + & "Input mesh not composed of linear tets") + + do degree = min_degree, max_degree + print "(a,i0)", "Degree = ", degree + + derived_shape = make_element_shape(base_shape, degree = degree) + call report_test("[Derived loc]", & & derived_shape%loc /= te(degree + 1), .false., & & "Incorrect local node count") - derived_mesh = make_mesh(base_mesh, derived_shape) - call report_test("[Derived ele_count]", & + derived_mesh = make_mesh(base_mesh, derived_shape) + call report_test("[Derived ele_count]", & & ele_count(derived_mesh) /= ele_count(base_mesh), .false., & & "Incorrect element count") - call allocate(positions_remap, positions%dim, derived_mesh, name = positions%name) - call remap_field(positions, positions_remap) - allocate(otn_l_coords(base_shape%loc, derived_shape%loc)) - otn_l_coords = tet_otn_local_coords(degree) - allocate(l_coords(base_shape%loc, derived_shape%loc)) - fail = .false. - ele_loop: do ele = 1, ele_count(derived_mesh) - fail = ele_loc(derived_mesh, ele) /= derived_shape%loc - if(fail) exit ele_loop - - l_coords = local_coords(positions, ele, ele_val(positions_remap, ele)) - fail = fnequals(l_coords, otn_l_coords, tol = 1.0e3 * epsilon(0.0)) - if(fail) then - do node = 1, size(l_coords, 2) - print *, node, l_coords(:, node) - print *, node, otn_l_coords(:, node) - end do - exit ele_loop - end if - end do ele_loop - deallocate(l_coords) - deallocate(otn_l_coords) - call deallocate(positions_remap) - - call report_test("[Derived mesh numbering]", fail, .false., "Invalid derived mesh numbering, failed on element " // int2str(ele)) - - call deallocate(derived_shape) - call deallocate(derived_mesh) - end do - - call deallocate(positions) - call report_test_no_references() + call allocate(positions_remap, positions%dim, derived_mesh, name = positions%name) + call remap_field(positions, positions_remap) + allocate(otn_l_coords(base_shape%loc, derived_shape%loc)) + otn_l_coords = tet_otn_local_coords(degree) + allocate(l_coords(base_shape%loc, derived_shape%loc)) + fail = .false. + ele_loop: do ele = 1, ele_count(derived_mesh) + fail = ele_loc(derived_mesh, ele) /= derived_shape%loc + if(fail) exit ele_loop + + l_coords = local_coords(positions, ele, ele_val(positions_remap, ele)) + fail = fnequals(l_coords, otn_l_coords, tol = 1.0e3 * epsilon(0.0)) + if(fail) then + do node = 1, size(l_coords, 2) + print *, node, l_coords(:, node) + print *, node, otn_l_coords(:, node) + end do + exit ele_loop + end if + end do ele_loop + deallocate(l_coords) + deallocate(otn_l_coords) + call deallocate(positions_remap) + + call report_test("[Derived mesh numbering]", fail, .false., "Invalid derived mesh numbering, failed on element " // int2str(ele)) + + call deallocate(derived_shape) + call deallocate(derived_mesh) + end do + + call deallocate(positions) + call report_test_no_references() contains - function tet_otn_local_coords(degree) result(l_coords) - !!< Return the node local coords according to the One True Element Numbering - - integer, intent(in) :: degree - - integer :: i, index, j, k - real, dimension(4, te(degree + 1)) :: l_coords - - index = 1 - do i = 0, degree - do j = 0, degree - i - do k = 0, degree - (i + j) - assert(index <= size(l_coords, 2)) - l_coords(2, index) = float(k) / float(degree) - l_coords(3, index) = float(j) / float(degree) - l_coords(4, index) = float(i) / float(degree) - l_coords(1, index) = 1.0 - sum(l_coords(2:4, index)) - index = index + 1 - end do + function tet_otn_local_coords(degree) result(l_coords) + !!< Return the node local coords according to the One True Element Numbering + + integer, intent(in) :: degree + + integer :: i, index, j, k + real, dimension(4, te(degree + 1)) :: l_coords + + index = 1 + do i = 0, degree + do j = 0, degree - i + do k = 0, degree - (i + j) + assert(index <= size(l_coords, 2)) + l_coords(2, index) = float(k) / float(degree) + l_coords(3, index) = float(j) / float(degree) + l_coords(4, index) = float(i) / float(degree) + l_coords(1, index) = 1.0 - sum(l_coords(2:4, index)) + index = index + 1 + end do + end do end do - end do - assert(index == size(l_coords, 2) + 1) + assert(index == size(l_coords, 2) + 1) - end function tet_otn_local_coords + end function tet_otn_local_coords end subroutine test_make_mesh_tet diff --git a/femtools/tests/test_make_mesh_tri.F90 b/femtools/tests/test_make_mesh_tri.F90 index 5d561b6ed7..c407036d5b 100644 --- a/femtools/tests/test_make_mesh_tri.F90 +++ b/femtools/tests/test_make_mesh_tri.F90 @@ -29,102 +29,102 @@ subroutine test_make_mesh_tri - use futils - use element_numbering - use elements - use fields - use fldebug - use mesh_files - use unittest_tools - - implicit none - - integer :: degree, ele, node - integer, parameter :: min_degree = 1, max_degree = 20 - logical :: fail - real, dimension(:, :), allocatable :: l_coords, otn_l_coords - type(element_type) :: derived_shape - type(element_type), pointer :: base_shape - type(mesh_type) :: derived_mesh - type(mesh_type), pointer :: base_mesh - type(vector_field) :: positions_remap - type(vector_field), target :: positions - - positions = read_mesh_files("data/laplacian_grid.2", quad_degree = 1, format="gmsh") - base_mesh => positions%mesh - base_shape => ele_shape(base_mesh, 1) - call report_test("[Linear triangle input mesh]", & - & ele_numbering_family(base_shape) /= FAMILY_SIMPLEX .or. base_shape%degree /= 1 .or. base_shape%dim /= 2, .false., & - & "Input mesh not composed of linear triangles") - - do degree = min_degree, max_degree - print "(a,i0)", "Degree = ", degree - - derived_shape = make_element_shape(base_shape, degree = degree) - call report_test("[Derived loc]", & + use futils + use element_numbering + use elements + use fields + use fldebug + use mesh_files + use unittest_tools + + implicit none + + integer :: degree, ele, node + integer, parameter :: min_degree = 1, max_degree = 20 + logical :: fail + real, dimension(:, :), allocatable :: l_coords, otn_l_coords + type(element_type) :: derived_shape + type(element_type), pointer :: base_shape + type(mesh_type) :: derived_mesh + type(mesh_type), pointer :: base_mesh + type(vector_field) :: positions_remap + type(vector_field), target :: positions + + positions = read_mesh_files("data/laplacian_grid.2", quad_degree = 1, format="gmsh") + base_mesh => positions%mesh + base_shape => ele_shape(base_mesh, 1) + call report_test("[Linear triangle input mesh]", & + & ele_numbering_family(base_shape) /= FAMILY_SIMPLEX .or. base_shape%degree /= 1 .or. base_shape%dim /= 2, .false., & + & "Input mesh not composed of linear triangles") + + do degree = min_degree, max_degree + print "(a,i0)", "Degree = ", degree + + derived_shape = make_element_shape(base_shape, degree = degree) + call report_test("[Derived loc]", & & derived_shape%loc /= tr(degree + 1), .false., & & "Incorrect local node count") - derived_mesh = make_mesh(base_mesh, derived_shape) - call report_test("[Derived ele_count]", & + derived_mesh = make_mesh(base_mesh, derived_shape) + call report_test("[Derived ele_count]", & & ele_count(derived_mesh) /= ele_count(base_mesh), .false., & & "Incorrect element count") - call allocate(positions_remap, positions%dim, derived_mesh, name = positions%name) - call remap_field(positions, positions_remap) - allocate(otn_l_coords(base_shape%loc, derived_shape%loc)) - otn_l_coords = tri_otn_local_coords(degree) - allocate(l_coords(base_shape%loc, derived_shape%loc)) - fail = .false. - ele_loop: do ele = 1, ele_count(derived_mesh) - fail = ele_loc(derived_mesh, ele) /= derived_shape%loc - if(fail) exit ele_loop - - l_coords = local_coords(positions, ele, ele_val(positions_remap, ele)) - fail = fnequals(l_coords, otn_l_coords, tol = 1.0e3 * epsilon(0.0)) - if(fail) then - do node = 1, size(l_coords, 2) - print *, node, l_coords(:, node) - print *, node, otn_l_coords(:, node) - end do - exit ele_loop - end if - end do ele_loop - deallocate(l_coords) - deallocate(otn_l_coords) - call deallocate(positions_remap) - - call report_test("[Derived mesh numbering]", fail, .false., "Invalid derived mesh numbering, failed on element " // int2str(ele)) - - call deallocate(derived_shape) - call deallocate(derived_mesh) - end do - - call deallocate(positions) - call report_test_no_references() + call allocate(positions_remap, positions%dim, derived_mesh, name = positions%name) + call remap_field(positions, positions_remap) + allocate(otn_l_coords(base_shape%loc, derived_shape%loc)) + otn_l_coords = tri_otn_local_coords(degree) + allocate(l_coords(base_shape%loc, derived_shape%loc)) + fail = .false. + ele_loop: do ele = 1, ele_count(derived_mesh) + fail = ele_loc(derived_mesh, ele) /= derived_shape%loc + if(fail) exit ele_loop + + l_coords = local_coords(positions, ele, ele_val(positions_remap, ele)) + fail = fnequals(l_coords, otn_l_coords, tol = 1.0e3 * epsilon(0.0)) + if(fail) then + do node = 1, size(l_coords, 2) + print *, node, l_coords(:, node) + print *, node, otn_l_coords(:, node) + end do + exit ele_loop + end if + end do ele_loop + deallocate(l_coords) + deallocate(otn_l_coords) + call deallocate(positions_remap) + + call report_test("[Derived mesh numbering]", fail, .false., "Invalid derived mesh numbering, failed on element " // int2str(ele)) + + call deallocate(derived_shape) + call deallocate(derived_mesh) + end do + + call deallocate(positions) + call report_test_no_references() contains - function tri_otn_local_coords(degree) result(l_coords) - !!< Return the node local coords according to the One True Element Numbering + function tri_otn_local_coords(degree) result(l_coords) + !!< Return the node local coords according to the One True Element Numbering - integer, intent(in) :: degree + integer, intent(in) :: degree - integer :: i, index, j - real, dimension(3, tr(degree + 1)) :: l_coords + integer :: i, index, j + real, dimension(3, tr(degree + 1)) :: l_coords - index = 1 - do i = 0, degree - do j = 0, degree - i - assert(index <= size(l_coords, 2)) - l_coords(2, index) = float(j) / float(degree) - l_coords(3, index) = float(i) / float(degree) - l_coords(1, index) = 1.0 - sum(l_coords(2:3, index)) - index = index + 1 + index = 1 + do i = 0, degree + do j = 0, degree - i + assert(index <= size(l_coords, 2)) + l_coords(2, index) = float(j) / float(degree) + l_coords(3, index) = float(i) / float(degree) + l_coords(1, index) = 1.0 - sum(l_coords(2:3, index)) + index = index + 1 + end do end do - end do - assert(index == size(l_coords, 2) + 1) + assert(index == size(l_coords, 2) + 1) - end function tri_otn_local_coords + end function tri_otn_local_coords end subroutine test_make_mesh_tri diff --git a/femtools/tests/test_make_sparsity.F90 b/femtools/tests/test_make_sparsity.F90 index b8fcb02a25..b1b2603b02 100644 --- a/femtools/tests/test_make_sparsity.F90 +++ b/femtools/tests/test_make_sparsity.F90 @@ -1,27 +1,27 @@ subroutine test_make_sparsity - use vtk_interfaces - use fields - use sparse_tools - use sparsity_patterns - use state_module - use unittest_tools - implicit none + use vtk_interfaces + use fields + use sparse_tools + use sparsity_patterns + use state_module + use unittest_tools + implicit none - type(mesh_type), pointer :: rowmesh, colmesh - type(state_type) :: state1, state2 - type(csr_sparsity) :: sparsity + type(mesh_type), pointer :: rowmesh, colmesh + type(state_type) :: state1, state2 + type(csr_sparsity) :: sparsity - call vtk_read_state("data/sparsity_0.vtu", state1) - rowmesh => extract_mesh(state1, "Mesh") + call vtk_read_state("data/sparsity_0.vtu", state1) + rowmesh => extract_mesh(state1, "Mesh") - call vtk_read_state("data/sparsity_1.vtu", state2) - colmesh => extract_mesh(state2, "Mesh") + call vtk_read_state("data/sparsity_1.vtu", state2) + colmesh => extract_mesh(state2, "Mesh") - sparsity = make_sparsity(rowmesh, colmesh, name='Sparsity') + sparsity = make_sparsity(rowmesh, colmesh, name='Sparsity') - call report_test("[make sparsity]", .false., .false., "Make sparsity should run") + call report_test("[make sparsity]", .false., .false., "Make sparsity should run") - call deallocate(state1) - call deallocate(state2) + call deallocate(state1) + call deallocate(state2) end subroutine test_make_sparsity diff --git a/femtools/tests/test_mat_symmetric.F90 b/femtools/tests/test_mat_symmetric.F90 index 4ef1bd11d8..6713a7258e 100644 --- a/femtools/tests/test_mat_symmetric.F90 +++ b/femtools/tests/test_mat_symmetric.F90 @@ -1,18 +1,18 @@ subroutine test_mat_symmetric - use unittest_tools - implicit none + use unittest_tools + implicit none - real, dimension(3, 3) :: mat - logical :: fail, warn + real, dimension(3, 3) :: mat + logical :: fail, warn - mat(1, :) = (/5821120296.70721, -288935353.239809, -43439838442.8431/) - mat(2, :) = (/-288935353.239809, 14341517.9712309, 2156165379.10662/) - mat(3, :) = (/-43439838442.8430, 2156165379.10662, 324167903664.234/) + mat(1, :) = (/5821120296.70721, -288935353.239809, -43439838442.8431/) + mat(2, :) = (/-288935353.239809, 14341517.9712309, 2156165379.10662/) + mat(3, :) = (/-43439838442.8430, 2156165379.10662, 324167903664.234/) - fail = .false.; warn = .false. - if (.not. mat_is_symmetric(mat)) fail = .true. + fail = .false.; warn = .false. + if (.not. mat_is_symmetric(mat)) fail = .true. - call report_test("[mat_symmetric]", fail, warn, "A symmetric matrix should be regarded as symmetric.") + call report_test("[mat_symmetric]", fail, warn, "A symmetric matrix should be regarded as symmetric.") end subroutine test_mat_symmetric diff --git a/femtools/tests/test_matmul_t.F90 b/femtools/tests/test_matmul_t.F90 index fdb013b324..55c50f2ff9 100644 --- a/femtools/tests/test_matmul_t.F90 +++ b/femtools/tests/test_matmul_t.F90 @@ -1,47 +1,47 @@ subroutine test_matmul_t - use vector_tools - use sparse_tools - use unittest_tools - implicit none + use vector_tools + use sparse_tools + use unittest_tools + implicit none - real, dimension(3, 3) :: A, B, C, D - type(dynamic_csr_matrix) :: A_d, B_d, C_d - integer :: i, j, k - logical :: fail - character(len=20) :: buf + real, dimension(3, 3) :: A, B, C, D + type(dynamic_csr_matrix) :: A_d, B_d, C_d + integer :: i, j, k + logical :: fail + character(len=20) :: buf - call allocate(A_d, 3, 3) - call allocate(B_d, 3, 3) + call allocate(A_d, 3, 3) + call allocate(B_d, 3, 3) - do k=1,5 - write(buf,'(i0)') k - fail = .false. + do k=1,5 + write(buf,'(i0)') k + fail = .false. - A = random_matrix(3) - B = random_matrix(3) + A = random_matrix(3) + B = random_matrix(3) - call zero(A_d) - call zero(B_d) + call zero(A_d) + call zero(B_d) - do i=1,3 - do j=1,3 - call addto(A_d,i,j,A(i,j)) - call addto(B_d,i,j,B(i,j)) - end do - end do + do i=1,3 + do j=1,3 + call addto(A_d,i,j,A(i,j)) + call addto(B_d,i,j,B(i,j)) + end do + end do - C_d = matmul_T(A_d,B_d) + C_d = matmul_T(A_d,B_d) - C=dense(C_d) + C=dense(C_d) - call deallocate(C_d) + call deallocate(C_d) - D = matmul(A, transpose(B)) + D = matmul(A, transpose(B)) - if (any(abs(C-D)>2.0*epsilon(0.0))) fail = .true. + if (any(abs(C-D)>2.0*epsilon(0.0))) fail = .true. - call report_test("[matmul_t " // trim(buf) // "]", fail, .false., "The output of matmul_t and matmul should be identical.") - end do + call report_test("[matmul_t " // trim(buf) // "]", fail, .false., "The output of matmul_t and matmul should be identical.") + end do end subroutine test_matmul_t diff --git a/femtools/tests/test_matmul_t_sparse.F90 b/femtools/tests/test_matmul_t_sparse.F90 index 9d2a44eed9..4d5b099d17 100644 --- a/femtools/tests/test_matmul_t_sparse.F90 +++ b/femtools/tests/test_matmul_t_sparse.F90 @@ -1,113 +1,113 @@ subroutine test_matmul_t_sparse - use vector_tools - use sparse_tools - use unittest_tools - implicit none - - integer, parameter :: size_mat = 50 - integer, parameter :: n_samples = 100 - real, dimension(size_mat,size_mat) :: A, B, C, D - type(dynamic_csr_matrix) :: A_d, B_d, C_d - type(csr_matrix) :: A_c, B_c, C_dc - integer :: i, j, k, n - logical :: fail,fail1,fail2, fail3 - character(len=size_mat) :: buf - real, dimension(4) :: rand0 - - do k=1,5 - - call allocate(A_d, size_mat,size_mat) - call allocate(B_d, size_mat,size_mat) - - write(buf,'(i0)') k - fail = .false. - fail1 = .false. - fail2 = .false. - fail3 = .false. - - A = 0. - B = 0. - call zero(A_d) - call zero(B_d) - - do n = 1, n_samples - call random_number(rand0) - i = ceiling(rand0(1)*size_mat) - j = ceiling(rand0(2)*size_mat) - A(i,j) = A(i,j) +1.0 - B(i,j) = B(i,j) + 1.0 - !call addto(A_d,i,j,rand0(3)) - !call addto(B_d,i,j,rand0(4)) - call addto(A_d,i,j,1.0) - call addto(B_d,i,j,1.0) - end do - - if (any(A /= dense(A_d))) then - write(0,*) 'A assembly bungled' - write(0,*) '---' - write(0,*) A - write(0,*) '---' - write(0,*) dense(A_d) - stop - end if - if (any(B /= dense(B_d))) then - write(0,*) 'B assembly bungled' - stop - end if - - A_c = dcsr2csr(A_d) - B_c = dcsr2csr(B_d) - - C_d = matmul_T(A_d,B_d) - !C_c = matmul_T(A_c,B_c) - - C_dc = dcsr2csr(C_d) - - C=dense(C_d) - !E = dense(C_c) - - if (any(abs(C-dense(C_dc))>1.0e-14)) fail3 = .true. - - - do i = 1, size(B_d%colm) - if(any(C_d%val(i)%ptr<0.5)) fail2=.true. - end do - - call deallocate(C_d) - call deallocate(A_c) - call deallocate(B_c) - !call deallocate(C_c) - call deallocate(C_dc) - - D = matmul(A, transpose(B)) - - if (any(abs(C-D)>1.0e-14)) fail = .true. - !if (any(abs(E-D)>1.0e-14)) fail2 = .true. - do i = 1, size(A_d%colm) - do j = 2, size(A_d%colm(i)%ptr) - if(A_d%colm(i)%ptr(j).le.A_d%colm(i)%ptr(j-1)) then - fail1 = .true. - end if - end do - end do - - do i = 1, size(B_d%colm) - do j = 2, size(B_d%colm(i)%ptr) - if(B_d%colm(i)%ptr(j).le.B_d%colm(i)%ptr(j-1)) then - fail1 = .true. - end if - end do - end do - - call report_test("[matmul_t_sparse dcsr " // trim(buf) // "]", fail, .false., "The output of matmul_t and matmul should be identical.") - call report_test("[matmul_t_sparse dcsr dense " // trim(buf) // "]", fail3, .false., "The output of dense(dscr_matrix) and dense(dcsr2csr(dcsr_matrix)) should be identical.") - call report_test("[matmul_t_sparse zeros " // trim(buf) // "]", fail2, .false., "The sparsity pattern should not contain zeros") - call report_test("[matmul_t_sparse " // trim(buf) // " ordering]", fail1, .false., "We expect the rows to be incrementally ordered in dcsr matrices") - - call deallocate(A_d) - call deallocate(B_d) - - end do + use vector_tools + use sparse_tools + use unittest_tools + implicit none + + integer, parameter :: size_mat = 50 + integer, parameter :: n_samples = 100 + real, dimension(size_mat,size_mat) :: A, B, C, D + type(dynamic_csr_matrix) :: A_d, B_d, C_d + type(csr_matrix) :: A_c, B_c, C_dc + integer :: i, j, k, n + logical :: fail,fail1,fail2, fail3 + character(len=size_mat) :: buf + real, dimension(4) :: rand0 + + do k=1,5 + + call allocate(A_d, size_mat,size_mat) + call allocate(B_d, size_mat,size_mat) + + write(buf,'(i0)') k + fail = .false. + fail1 = .false. + fail2 = .false. + fail3 = .false. + + A = 0. + B = 0. + call zero(A_d) + call zero(B_d) + + do n = 1, n_samples + call random_number(rand0) + i = ceiling(rand0(1)*size_mat) + j = ceiling(rand0(2)*size_mat) + A(i,j) = A(i,j) +1.0 + B(i,j) = B(i,j) + 1.0 + !call addto(A_d,i,j,rand0(3)) + !call addto(B_d,i,j,rand0(4)) + call addto(A_d,i,j,1.0) + call addto(B_d,i,j,1.0) + end do + + if (any(A /= dense(A_d))) then + write(0,*) 'A assembly bungled' + write(0,*) '---' + write(0,*) A + write(0,*) '---' + write(0,*) dense(A_d) + stop + end if + if (any(B /= dense(B_d))) then + write(0,*) 'B assembly bungled' + stop + end if + + A_c = dcsr2csr(A_d) + B_c = dcsr2csr(B_d) + + C_d = matmul_T(A_d,B_d) + !C_c = matmul_T(A_c,B_c) + + C_dc = dcsr2csr(C_d) + + C=dense(C_d) + !E = dense(C_c) + + if (any(abs(C-dense(C_dc))>1.0e-14)) fail3 = .true. + + + do i = 1, size(B_d%colm) + if(any(C_d%val(i)%ptr<0.5)) fail2=.true. + end do + + call deallocate(C_d) + call deallocate(A_c) + call deallocate(B_c) + !call deallocate(C_c) + call deallocate(C_dc) + + D = matmul(A, transpose(B)) + + if (any(abs(C-D)>1.0e-14)) fail = .true. + !if (any(abs(E-D)>1.0e-14)) fail2 = .true. + do i = 1, size(A_d%colm) + do j = 2, size(A_d%colm(i)%ptr) + if(A_d%colm(i)%ptr(j).le.A_d%colm(i)%ptr(j-1)) then + fail1 = .true. + end if + end do + end do + + do i = 1, size(B_d%colm) + do j = 2, size(B_d%colm(i)%ptr) + if(B_d%colm(i)%ptr(j).le.B_d%colm(i)%ptr(j-1)) then + fail1 = .true. + end if + end do + end do + + call report_test("[matmul_t_sparse dcsr " // trim(buf) // "]", fail, .false., "The output of matmul_t and matmul should be identical.") + call report_test("[matmul_t_sparse dcsr dense " // trim(buf) // "]", fail3, .false., "The output of dense(dscr_matrix) and dense(dcsr2csr(dcsr_matrix)) should be identical.") + call report_test("[matmul_t_sparse zeros " // trim(buf) // "]", fail2, .false., "The sparsity pattern should not contain zeros") + call report_test("[matmul_t_sparse " // trim(buf) // " ordering]", fail1, .false., "We expect the rows to be incrementally ordered in dcsr matrices") + + call deallocate(A_d) + call deallocate(B_d) + + end do end subroutine test_matmul_t_sparse diff --git a/femtools/tests/test_matrix_conversions.F90 b/femtools/tests/test_matrix_conversions.F90 index 7d38f6782e..6cc12da9d1 100644 --- a/femtools/tests/test_matrix_conversions.F90 +++ b/femtools/tests/test_matrix_conversions.F90 @@ -1,39 +1,39 @@ #include "fdebug.h" subroutine test_matrix_conversions - use sparse_tools - use petsc_tools - use unittest_tools - use petsc - implicit none + use sparse_tools + use petsc_tools + use unittest_tools + use petsc + implicit none #include "petsc_legacy.h" - Mat:: M - type(dynamic_csr_matrix):: R, S - type(csr_matrix):: A, B - logical fail + Mat:: M + type(dynamic_csr_matrix):: R, S + type(csr_matrix):: A, B + logical fail - R=random_sparse_matrix(99, 100, 1001) + R=random_sparse_matrix(99, 100, 1001) - A=dcsr2csr(R) + A=dcsr2csr(R) - S=csr2dcsr(A) + S=csr2dcsr(A) - fail= .not. fequals(R, S, 1e-8) + fail= .not. fequals(R, S, 1e-8) - call report_test("[dcsr2csr2dcsr]", fail, .false., & - "Converting from dcsr_matrix to csr_matrix and back failed.") + call report_test("[dcsr2csr2dcsr]", fail, .false., & + "Converting from dcsr_matrix to csr_matrix and back failed.") - M=csr2petsc(A) + M=csr2petsc(A) - B=petsc2csr(M) + B=petsc2csr(M) - S=csr2dcsr(B) + S=csr2dcsr(B) - fail= .not. fequals(R, S, 1e-8) + fail= .not. fequals(R, S, 1e-8) - call report_test("[csr2petsc2csr]", fail, .false., & - "Converting from csr_matrix to PETSc Mat and back failed.") + call report_test("[csr2petsc2csr]", fail, .false., & + "Converting from csr_matrix to PETSc Mat and back failed.") end subroutine test_matrix_conversions diff --git a/femtools/tests/test_matrixmarket_read_write.F90 b/femtools/tests/test_matrixmarket_read_write.F90 index 4ecc780f59..e6275a0245 100644 --- a/femtools/tests/test_matrixmarket_read_write.F90 +++ b/femtools/tests/test_matrixmarket_read_write.F90 @@ -1,40 +1,40 @@ subroutine test_matrixmarket_read_write - use sparse_tools - use unittest_tools - implicit none + use sparse_tools + use unittest_tools + implicit none - type(dynamic_csr_matrix):: A, B - logical fail + type(dynamic_csr_matrix):: A, B + logical fail - call mmread('data/matrix.mm', A) + call mmread('data/matrix.mm', A) - call allocate(B, 5, 6) + call allocate(B, 5, 6) - call set(B, 1, 1, 1.0) - call set(B, 1, 2, 3.0) - call set(B, 2, 1, 0.0) - call set(B, 4, 5, 6.0) - call set(B, 5, 3, -99.0) - call set(B, 5, 4, -5e20) - call set(B, 5, 6, 20.0/3.0) + call set(B, 1, 1, 1.0) + call set(B, 1, 2, 3.0) + call set(B, 2, 1, 0.0) + call set(B, 4, 5, 6.0) + call set(B, 5, 3, -99.0) + call set(B, 5, 4, -5e20) + call set(B, 5, 6, 20.0/3.0) - fail= .not. fequals(A, B, 1e-8) + fail= .not. fequals(A, B, 1e-8) - call report_test("[matrixmarket_read]", fail, .false., & - "Read matrix is not the same as in file matrix.mm") + call report_test("[matrixmarket_read]", fail, .false., & + "Read matrix is not the same as in file matrix.mm") - call deallocate(A) - call deallocate(B) + call deallocate(A) + call deallocate(B) - A=random_sparse_matrix(99, 100, 1001) + A=random_sparse_matrix(99, 100, 1001) - call mmwrite('data/matrix2.mm', A) - call mmread('data/matrix2.mm', B) + call mmwrite('data/matrix2.mm', A) + call mmread('data/matrix2.mm', B) - fail= .not. fequals(A, B, 1e-8) + fail= .not. fequals(A, B, 1e-8) - call report_test("[matrixmarket_read_write]", fail, .false., & - "Written matrix is not the same after reading back in.") + call report_test("[matrixmarket_read_write]", fail, .false., & + "Written matrix is not the same after reading back in.") end subroutine test_matrixmarket_read_write diff --git a/femtools/tests/test_multigrid.F90 b/femtools/tests/test_multigrid.F90 index 7a98ca37ba..58904f81ab 100644 --- a/femtools/tests/test_multigrid.F90 +++ b/femtools/tests/test_multigrid.F90 @@ -1,112 +1,112 @@ #include "fdebug.h" subroutine test_multigrid - ! Testing of the "mg" solver using the petsc_solve_setup, petsc_solve_core - ! and petsc_solve_destroy components of petsc_solve. - ! This test, tests whether 2 "mg" preconditioner can be set up - ! simultaneously. - use global_parameters - use sparse_tools - use petsc_tools - use unittest_tools - use fldebug - use solvers - use fields - use parallel_tools - use petsc - implicit none + ! Testing of the "mg" solver using the petsc_solve_setup, petsc_solve_core + ! and petsc_solve_destroy components of petsc_solve. + ! This test, tests whether 2 "mg" preconditioner can be set up + ! simultaneously. + use global_parameters + use sparse_tools + use petsc_tools + use unittest_tools + use fldebug + use solvers + use fields + use parallel_tools + use petsc + implicit none #include "petsc_legacy.h" - integer, parameter:: DIM=100, NNZ=1000 - logical fail + integer, parameter:: DIM=100, NNZ=1000 + logical fail - KSP ksp1, ksp2 - Mat A1, A2 - Vec y1, b1, y2, b2 - Vec xex1, xex2 - PetscErrorCode ierr - PetscScalar norm - PetscRandom rctx + KSP ksp1, ksp2 + Mat A1, A2 + Vec y1, b1, y2, b2 + Vec xex1, xex2 + PetscErrorCode ierr + PetscScalar norm + PetscRandom rctx - type(petsc_numbering_type) petsc_numbering1, petsc_numbering2 - type(dynamic_csr_matrix) dcsr1, dcsr2 - type(csr_matrix) csr1, csr2 - type(scalar_field):: sfield1, sfield2 - character(len=OPTION_PATH_LEN) solver_option_path1 - character(len=OPTION_PATH_LEN) solver_option_path2 - integer literations1, literations2 - logical lstartfromzero1, lstartfromzero2 - integer i + type(petsc_numbering_type) petsc_numbering1, petsc_numbering2 + type(dynamic_csr_matrix) dcsr1, dcsr2 + type(csr_matrix) csr1, csr2 + type(scalar_field):: sfield1, sfield2 + character(len=OPTION_PATH_LEN) solver_option_path1 + character(len=OPTION_PATH_LEN) solver_option_path2 + integer literations1, literations2 + logical lstartfromzero1, lstartfromzero2 + integer i - call allocate(dcsr1, DIM, DIM, name='matrix1') - call allocate(dcsr2, DIM, DIM, name='matrix2') - do i=1, DIM - call set(dcsr1, i, i, 1.0) - call set(dcsr2, i, i, 2.0) - call addto(dcsr1, i, min(i+1, DIM), 0.2) - call addto(dcsr1, i, max(i-1, 1), 0.2) - call addto(dcsr2, i, min(i+2, DIM), 0.4) - call addto(dcsr2, i, max(i-2, 1), 0.4) - end do - csr1=dcsr2csr(dcsr1) - csr2=dcsr2csr(dcsr2) + call allocate(dcsr1, DIM, DIM, name='matrix1') + call allocate(dcsr2, DIM, DIM, name='matrix2') + do i=1, DIM + call set(dcsr1, i, i, 1.0) + call set(dcsr2, i, i, 2.0) + call addto(dcsr1, i, min(i+1, DIM), 0.2) + call addto(dcsr1, i, max(i-1, 1), 0.2) + call addto(dcsr2, i, min(i+2, DIM), 0.4) + call addto(dcsr2, i, max(i-2, 1), 0.4) + end do + csr1=dcsr2csr(dcsr1) + csr2=dcsr2csr(dcsr2) - ! uncomment this to see some solver output: - call set_debug_level(3) + ! uncomment this to see some solver output: + call set_debug_level(3) - call set_solver_options("/scalar_field::Field", ksptype=KSPCG, & - pctype=PCMG, atol=1e-10, rtol=0.0) - ! horrible hack - petsc_solve_setup/core only use %name and %option_path - sfield1%name="Field1" - sfield1%option_path="/scalar_field::Field" - sfield2%name="Field2" - sfield2%option_path="/scalar_field::Field" + call set_solver_options("/scalar_field::Field", ksptype=KSPCG, & + pctype=PCMG, atol=1e-10, rtol=0.0) + ! horrible hack - petsc_solve_setup/core only use %name and %option_path + sfield1%name="Field1" + sfield1%option_path="/scalar_field::Field" + sfield2%name="Field2" + sfield2%option_path="/scalar_field::Field" - ! setup PETSc objects and petsc_numbering from options and - ! compute rhs from "exact" solution - call petsc_solve_setup(y1, A1, b1, ksp1, petsc_numbering1, & - solver_option_path1, lstartfromzero1, & - matrix=csr1, sfield=sfield1, & - option_path="/scalar_field::Field") - call PetscRandomCreate(MPI_COMM_FEMTOOLS, rctx, ierr) - call PetscRandomSetFromOptions(rctx, ierr) - call VecDuplicate(y1, xex1, ierr) - call VecSetRandom(xex1, rctx, ierr) - call MatMult(A1, xex1, b1, ierr) + ! setup PETSc objects and petsc_numbering from options and + ! compute rhs from "exact" solution + call petsc_solve_setup(y1, A1, b1, ksp1, petsc_numbering1, & + solver_option_path1, lstartfromzero1, & + matrix=csr1, sfield=sfield1, & + option_path="/scalar_field::Field") + call PetscRandomCreate(MPI_COMM_FEMTOOLS, rctx, ierr) + call PetscRandomSetFromOptions(rctx, ierr) + call VecDuplicate(y1, xex1, ierr) + call VecSetRandom(xex1, rctx, ierr) + call MatMult(A1, xex1, b1, ierr) - ! setup PETSc objects and petsc_numbering from options and - ! compute rhs from "exact" solution - call petsc_solve_setup(y2, A2, b2, ksp2, petsc_numbering2, & - solver_option_path2, lstartfromzero2, & - matrix=csr2, sfield=sfield2, & - option_path="/scalar_field::Field") - call VecDuplicate(y2, xex2, ierr) - call VecSetRandom(xex2, rctx, ierr) - call MatMult(A2, xex2, b2, ierr) + ! setup PETSc objects and petsc_numbering from options and + ! compute rhs from "exact" solution + call petsc_solve_setup(y2, A2, b2, ksp2, petsc_numbering2, & + solver_option_path2, lstartfromzero2, & + matrix=csr2, sfield=sfield2, & + option_path="/scalar_field::Field") + call VecDuplicate(y2, xex2, ierr) + call VecSetRandom(xex2, rctx, ierr) + call MatMult(A2, xex2, b2, ierr) - call petsc_solve_core(y1, A1, b1, ksp1, petsc_numbering1, & - solver_option_path1, lstartfromzero1, & - literations1, sfield=sfield2) - call petsc_solve_core(y2, A2, b2, ksp2, petsc_numbering2, & - solver_option_path2, lstartfromzero2, & - literations2, sfield=sfield2) + call petsc_solve_core(y1, A1, b1, ksp1, petsc_numbering1, & + solver_option_path1, lstartfromzero1, & + literations1, sfield=sfield2) + call petsc_solve_core(y2, A2, b2, ksp2, petsc_numbering2, & + solver_option_path2, lstartfromzero2, & + literations2, sfield=sfield2) - ! check answer of first solve - call VecAXPY(y1, real(-1.0, kind = PetscScalar_kind), xex1, ierr) - call VecNorm(y1, NORM_2, norm, ierr) - fail = (norm > 1e-7) - call report_test("[test_multigrid1]", fail, .false., "Error too large in multigrid.") + ! check answer of first solve + call VecAXPY(y1, real(-1.0, kind = PetscScalar_kind), xex1, ierr) + call VecNorm(y1, NORM_2, norm, ierr) + fail = (norm > 1e-7) + call report_test("[test_multigrid1]", fail, .false., "Error too large in multigrid.") - ! check answer of second solve - call VecAXPY(y2, real(-1.0, kind = PetscScalar_kind), xex2, ierr) - call VecNorm(y2, NORM_2, norm, ierr) - fail = (norm > 1e-7) - call report_test("[test_multigrid2]", fail, .false., "Error too large in multigrid.") + ! check answer of second solve + call VecAXPY(y2, real(-1.0, kind = PetscScalar_kind), xex2, ierr) + call VecNorm(y2, NORM_2, norm, ierr) + fail = (norm > 1e-7) + call report_test("[test_multigrid2]", fail, .false., "Error too large in multigrid.") - ! destroying of PETSc objects, check for remaining references by - ! running with ./test_multigrid -log_summary - call petsc_solve_destroy(y1, A1, b1, ksp1, petsc_numbering1, solver_option_path1) - call petsc_solve_destroy(y2, A2, b2, ksp2, petsc_numbering2, solver_option_path2) - call PetscRandomDestroy(rctx, ierr) - call VecDestroy(xex1, ierr) - call VecDestroy(xex2, ierr) + ! destroying of PETSc objects, check for remaining references by + ! running with ./test_multigrid -log_summary + call petsc_solve_destroy(y1, A1, b1, ksp1, petsc_numbering1, solver_option_path1) + call petsc_solve_destroy(y2, A2, b2, ksp2, petsc_numbering2, solver_option_path2) + call PetscRandomDestroy(rctx, ierr) + call VecDestroy(xex1, ierr) + call VecDestroy(xex2, ierr) end subroutine test_multigrid diff --git a/femtools/tests/test_multiindex.F90 b/femtools/tests/test_multiindex.F90 index 68489ef3e1..328345ef57 100644 --- a/femtools/tests/test_multiindex.F90 +++ b/femtools/tests/test_multiindex.F90 @@ -1,32 +1,32 @@ subroutine test_multiindex - use unittest_tools - use futils - implicit none + use unittest_tools + use futils + implicit none - integer, dimension(3) :: result - integer :: charcount - logical :: fail + integer, dimension(3) :: result + integer :: charcount + logical :: fail - charcount = count_chars("This is a string", " ") - if (charcount /= 3) then - fail = .true. - else - fail = .false. - end if + charcount = count_chars("This is a string", " ") + if (charcount /= 3) then + fail = .true. + else + fail = .false. + end if - call report_test("[count_chars]", fail, .false., & - & "Give the right answer, please") + call report_test("[count_chars]", fail, .false., & + & "Give the right answer, please") - result = multiindex("This is a string", " ") - if (any(result /= (/5, 8, 10/))) then - write(0,*) "result == ", result - fail = .true. - else - fail = .false. - end if + result = multiindex("This is a string", " ") + if (any(result /= (/5, 8, 10/))) then + write(0,*) "result == ", result + fail = .true. + else + fail = .false. + end if - call report_test("[multi-index]", fail, .false., & - & "Multiindex should give the right answer.") + call report_test("[multi-index]", fail, .false., & + & "Multiindex should give the right answer.") end subroutine test_multiindex diff --git a/femtools/tests/test_node_lies_on_boundary.F90 b/femtools/tests/test_node_lies_on_boundary.F90 index 782010f476..15deabc79b 100644 --- a/femtools/tests/test_node_lies_on_boundary.F90 +++ b/femtools/tests/test_node_lies_on_boundary.F90 @@ -1,68 +1,68 @@ subroutine test_node_lies_on_boundary - use node_boundary - use surfacelabels - use fields - use state_module - use vtk_interfaces - use unittest_tools - use node_boundary, only: pseudo2d_coord - implicit none + use node_boundary + use surfacelabels + use fields + use state_module + use vtk_interfaces + use unittest_tools + use node_boundary, only: pseudo2d_coord + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - integer :: i - real :: x, y, z - logical :: fail, expected, output - integer, dimension(:), pointer:: surf_ids + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + integer :: i + real :: x, y, z + logical :: fail, expected, output + integer, dimension(:), pointer:: surf_ids - pseudo2d_coord = 3 + pseudo2d_coord = 3 - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") - call add_faces(mesh) - ! Update the mesh descriptor on positions to have faces. - positions%mesh=mesh + call add_faces(mesh) + ! Update the mesh descriptor on positions to have faces. + positions%mesh=mesh - allocate(surf_ids(surface_element_count(mesh))) - call get_coplanar_ids(mesh, positions, surf_ids) - call initialise_boundcount(mesh, positions) + allocate(surf_ids(surface_element_count(mesh))) + call get_coplanar_ids(mesh, positions, surf_ids) + call initialise_boundcount(mesh, positions) - fail = .false. - do i=1,mesh%nodes - x = positions%val(1,i) - y = positions%val(2,i) - z = positions%val(3,i) + fail = .false. + do i=1,mesh%nodes + x = positions%val(1,i) + y = positions%val(2,i) + z = positions%val(3,i) - output = node_lies_on_boundary(mesh, positions, i, expected=1) - if (x == 0.0 .or. x == 30.0 .or. y == 0.0 .or. y == 15.0) then - expected = .true. - else - expected = .false. - end if + output = node_lies_on_boundary(mesh, positions, i, expected=1) + if (x == 0.0 .or. x == 30.0 .or. y == 0.0 .or. y == 15.0) then + expected = .true. + else + expected = .false. + end if - if (output .neqv. expected) then - fail = .true. - write(0,*) "node: ", i - write(0,*) "position: (", x, ", ", y, ", ", z, ")" - write(0,*) "expected: ", expected - write(0,*) "output: ", output - end if - end do + if (output .neqv. expected) then + fail = .true. + write(0,*) "node: ", i + write(0,*) "position: (", x, ", ", y, ", ", z, ")" + write(0,*) "expected: ", expected + write(0,*) "output: ", output + end if + end do - positions%mesh=mesh - call vtk_write_surface_mesh("coplanar_ids", index = 0, position = positions) + positions%mesh=mesh + call vtk_write_surface_mesh("coplanar_ids", index = 0, position = positions) - call report_test("[node_lies_on_boundary 2d]", fail, .false., "Output & - & should match expected output.") + call report_test("[node_lies_on_boundary 2d]", fail, .false., "Output & + & should match expected output.") - fail = .false. - if (maxval(surf_ids) /= 6) fail = .true. - call report_test("[surface ids]", fail, .false., "The maximal surface id should be 6!") + fail = .false. + if (maxval(surf_ids) /= 6) fail = .true. + call report_test("[surface ids]", fail, .false., "The maximal surface id should be 6!") - call deallocate(state) + call deallocate(state) end subroutine test_node_lies_on_boundary diff --git a/femtools/tests/test_norm2_difference.F90 b/femtools/tests/test_norm2_difference.F90 index 6a8403e49f..cbad8eaf40 100644 --- a/femtools/tests/test_norm2_difference.F90 +++ b/femtools/tests/test_norm2_difference.F90 @@ -1,64 +1,64 @@ subroutine test_norm2_difference - use mesh_files - use elements - use fields - use unittest_tools - implicit none + use mesh_files + use elements + use fields + use unittest_tools + implicit none - type(vector_field) :: positionsA, positionsB - type(mesh_type) :: meshA, meshB - type(element_type) :: shape - type(scalar_field) :: fieldA, fieldB - integer :: degree - real :: norm - logical :: fail - integer :: i - real :: domain_volume - integer :: ele + type(vector_field) :: positionsA, positionsB + type(mesh_type) :: meshA, meshB + type(element_type) :: shape + type(scalar_field) :: fieldA, fieldB + integer :: degree + real :: norm + logical :: fail + integer :: i + real :: domain_volume + integer :: ele - positionsA = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") + positionsA = read_mesh_files("data/pslgA", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/pslgB", quad_degree=4, format="gmsh") - domain_volume = 0.0 - do ele=1,ele_count(positionsA) - domain_volume = domain_volume + simplex_volume(positionsA, ele) - end do + domain_volume = 0.0 + do ele=1,ele_count(positionsA) + domain_volume = domain_volume + simplex_volume(positionsA, ele) + end do - do degree=1,3 - shape = make_element_shape(vertices = ele_loc(positionsA, 1), dim = positionsA%dim, degree = degree, quad = positionsA%mesh%shape%quadrature) - meshA = make_mesh(positionsA%mesh, shape, name="MeshA") - meshB = make_mesh(positionsB%mesh, shape, name="MeshB") - call allocate(fieldA, meshA, "FieldA") - call allocate(fieldB, meshB, "FieldB") + do degree=1,3 + shape = make_element_shape(vertices = ele_loc(positionsA, 1), dim = positionsA%dim, degree = degree, quad = positionsA%mesh%shape%quadrature) + meshA = make_mesh(positionsA%mesh, shape, name="MeshA") + meshB = make_mesh(positionsB%mesh, shape, name="MeshB") + call allocate(fieldA, meshA, "FieldA") + call allocate(fieldB, meshB, "FieldB") - fieldA%val = 1.0 - fieldB%val = 0.0 + fieldA%val = 1.0 + fieldB%val = 0.0 - norm = norm2_difference(fieldA, positionsA, fieldB, positionsB) - fail = (norm .fne. norm2(fieldA, positionsA)) - call report_test("[norm2 difference]", fail, .false., "|A - 0| = |A|") + norm = norm2_difference(fieldA, positionsA, fieldB, positionsB) + fail = (norm .fne. norm2(fieldA, positionsA)) + call report_test("[norm2 difference]", fail, .false., "|A - 0| = |A|") - do i=1,size(fieldA%val) - call random_number(fieldA%val(i)) - end do + do i=1,size(fieldA%val) + call random_number(fieldA%val(i)) + end do - norm = norm2_difference(fieldA, positionsA, fieldA, positionsA) - fail = (norm .fne. 0.0) - call report_test("[norm2 difference]", fail, .false., "|A - A| = |0| = 0") + norm = norm2_difference(fieldA, positionsA, fieldA, positionsA) + fail = (norm .fne. 0.0) + call report_test("[norm2 difference]", fail, .false., "|A - A| = |0| = 0") - fieldA%val = 1.0 - fieldB%val = 2.0 + fieldA%val = 1.0 + fieldB%val = 2.0 - norm = norm2_difference(fieldA, positionsA, fieldB, positionsB) - fail = (norm .fne. sqrt(domain_volume)) - call report_test("[norm2 difference]", fail, .false., "|1| = |\Omega|**0.5") + norm = norm2_difference(fieldA, positionsA, fieldB, positionsB) + fail = (norm .fne. sqrt(domain_volume)) + call report_test("[norm2 difference]", fail, .false., "|1| = |\Omega|**0.5") - call deallocate(fieldA) - call deallocate(fieldB) - call deallocate(meshA) - call deallocate(meshB) - call deallocate(shape) - end do + call deallocate(fieldA) + call deallocate(fieldB) + call deallocate(meshA) + call deallocate(meshB) + call deallocate(shape) + end do end subroutine test_norm2_difference diff --git a/femtools/tests/test_outer_product.F90 b/femtools/tests/test_outer_product.F90 index 57b96cfc53..fcffd5a5ee 100644 --- a/femtools/tests/test_outer_product.F90 +++ b/femtools/tests/test_outer_product.F90 @@ -1,20 +1,20 @@ subroutine test_outer_product - use vector_tools - use unittest_tools - implicit none + use vector_tools + use unittest_tools + implicit none - real, dimension(4) :: ones = 1.0 - real, dimension(4, 4) :: output, correct - logical :: fail + real, dimension(4) :: ones = 1.0 + real, dimension(4, 4) :: output, correct + logical :: fail - correct = 1.0 + correct = 1.0 - output = outer_product(ones, ones) + output = outer_product(ones, ones) - fail = .false. - if (any(output /= correct)) fail = .true. + fail = .false. + if (any(output /= correct)) fail = .true. - call report_test("[outer product]", fail, .false., "Outer product should give known good values.") + call report_test("[outer product]", fail, .false., "Outer product should give known good values.") end subroutine test_outer_product diff --git a/femtools/tests/test_pe_number_1d.F90 b/femtools/tests/test_pe_number_1d.F90 index bdbfd576ad..1c9db6b372 100644 --- a/femtools/tests/test_pe_number_1d.F90 +++ b/femtools/tests/test_pe_number_1d.F90 @@ -29,80 +29,80 @@ subroutine test_pe_number_1d - use diagnostic_fields - use quadrature - use elements - use fields - use fldebug - use spud - use state_module - use unittest_tools - use field_options - - implicit none - - integer :: stat - type(element_type) :: shape - type(quadrature_type) :: quad - type(mesh_type) :: coordinate_mesh, velocity_mesh - type(scalar_field) :: pe_no, phi - type(state_type) :: state - type(tensor_field) :: diffusivity - type(vector_field) :: positions, velocity - - quad = make_quadrature(vertices = 2, dim = 1, degree = 2) - shape = make_element_shape(vertices = 2, dim = 1, degree = 1, quad = quad) - call deallocate(quad) - - call allocate(coordinate_mesh, nodes = 4, elements = 3, shape = shape, name = "CoordinateMesh") - call deallocate(shape) - - call set_ele_nodes(coordinate_mesh, 1, (/1, 2/)) - call set_ele_nodes(coordinate_mesh, 2, (/2, 3/)) - call set_ele_nodes(coordinate_mesh, 3, (/3, 4/)) - - velocity_mesh = piecewise_constant_mesh(coordinate_mesh, name = "PeNumberMesh") - - call allocate(positions, 1, coordinate_mesh, name = "Coordinate") - call allocate(velocity, 1, velocity_mesh, name = "Velocity") - call allocate(diffusivity, velocity_mesh, name = "PhiDiffusivity") - call allocate(phi, velocity_mesh, name = "Phi") - call allocate(pe_no, velocity_mesh, name = "PeNumber") - - call deallocate(coordinate_mesh) - call deallocate(velocity_mesh) - - call set(positions, (/1, 2, 3, 4/), spread((/0.0, 1.0, 11.0, 111.0/), 1, 1)) - call set(velocity, (/1, 2, 3/), spread((/1.0, 1.0, 5.0/), 1, 1)) - - call insert(state, positions, name = positions%name) - call insert(state, velocity, name = velocity%name) - call insert(state, diffusivity, name = diffusivity%name) - call insert(state, phi, name = phi%name) - call deallocate(positions) - call deallocate(velocity) - call deallocate(phi) - - pe_no%option_path = "/material_phase::Fluid/scalar_field::GridPecletNumber" - call add_option(trim(pe_no%option_path) // "/diagnostic", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call set_option(trim(complete_field_path(pe_no%option_path)) // "/field_name", "Phi", stat = stat) - assert(stat == SPUD_NEW_KEY_WARNING) - - call set(diffusivity, (/1, 2, 3/), spread(spread((/1.0, 1.0, 1.0/), 1, 1), 1, 1)) - - call calculate_diagnostic_variable(state, "GridPecletNumber", pe_no) - call report_test("[pe no]", node_val(pe_no, (/1, 2, 3/)) .fne. (/1.0, 10.0, 500.0/), .false., "Incorrect pe number") - - call set(diffusivity, (/1, 2, 3/), spread(spread((/2.0, 5.0, 10.0/), 1, 1), 1, 1)) - - call calculate_diagnostic_variable(state, "GridPecletNumber", pe_no) - call report_test("[pe no]", node_val(pe_no, (/1, 2, 3/)) .fne. (/0.5, 2.0, 50.0/), .false., "Incorrect pe number") - - call deallocate(state) - call deallocate(diffusivity) - call deallocate(pe_no) - - call report_test_no_references() + use diagnostic_fields + use quadrature + use elements + use fields + use fldebug + use spud + use state_module + use unittest_tools + use field_options + + implicit none + + integer :: stat + type(element_type) :: shape + type(quadrature_type) :: quad + type(mesh_type) :: coordinate_mesh, velocity_mesh + type(scalar_field) :: pe_no, phi + type(state_type) :: state + type(tensor_field) :: diffusivity + type(vector_field) :: positions, velocity + + quad = make_quadrature(vertices = 2, dim = 1, degree = 2) + shape = make_element_shape(vertices = 2, dim = 1, degree = 1, quad = quad) + call deallocate(quad) + + call allocate(coordinate_mesh, nodes = 4, elements = 3, shape = shape, name = "CoordinateMesh") + call deallocate(shape) + + call set_ele_nodes(coordinate_mesh, 1, (/1, 2/)) + call set_ele_nodes(coordinate_mesh, 2, (/2, 3/)) + call set_ele_nodes(coordinate_mesh, 3, (/3, 4/)) + + velocity_mesh = piecewise_constant_mesh(coordinate_mesh, name = "PeNumberMesh") + + call allocate(positions, 1, coordinate_mesh, name = "Coordinate") + call allocate(velocity, 1, velocity_mesh, name = "Velocity") + call allocate(diffusivity, velocity_mesh, name = "PhiDiffusivity") + call allocate(phi, velocity_mesh, name = "Phi") + call allocate(pe_no, velocity_mesh, name = "PeNumber") + + call deallocate(coordinate_mesh) + call deallocate(velocity_mesh) + + call set(positions, (/1, 2, 3, 4/), spread((/0.0, 1.0, 11.0, 111.0/), 1, 1)) + call set(velocity, (/1, 2, 3/), spread((/1.0, 1.0, 5.0/), 1, 1)) + + call insert(state, positions, name = positions%name) + call insert(state, velocity, name = velocity%name) + call insert(state, diffusivity, name = diffusivity%name) + call insert(state, phi, name = phi%name) + call deallocate(positions) + call deallocate(velocity) + call deallocate(phi) + + pe_no%option_path = "/material_phase::Fluid/scalar_field::GridPecletNumber" + call add_option(trim(pe_no%option_path) // "/diagnostic", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call set_option(trim(complete_field_path(pe_no%option_path)) // "/field_name", "Phi", stat = stat) + assert(stat == SPUD_NEW_KEY_WARNING) + + call set(diffusivity, (/1, 2, 3/), spread(spread((/1.0, 1.0, 1.0/), 1, 1), 1, 1)) + + call calculate_diagnostic_variable(state, "GridPecletNumber", pe_no) + call report_test("[pe no]", node_val(pe_no, (/1, 2, 3/)) .fne. (/1.0, 10.0, 500.0/), .false., "Incorrect pe number") + + call set(diffusivity, (/1, 2, 3/), spread(spread((/2.0, 5.0, 10.0/), 1, 1), 1, 1)) + + call calculate_diagnostic_variable(state, "GridPecletNumber", pe_no) + call report_test("[pe no]", node_val(pe_no, (/1, 2, 3/)) .fne. (/0.5, 2.0, 50.0/), .false., "Incorrect pe number") + + call deallocate(state) + call deallocate(diffusivity) + call deallocate(pe_no) + + call report_test_no_references() end subroutine test_pe_number_1d diff --git a/femtools/tests/test_petsc_csr_matrix.F90 b/femtools/tests/test_petsc_csr_matrix.F90 index 1ecbb2e272..86c71dc629 100644 --- a/femtools/tests/test_petsc_csr_matrix.F90 +++ b/femtools/tests/test_petsc_csr_matrix.F90 @@ -1,99 +1,99 @@ #include "fdebug.h" subroutine test_petsc_csr_matrix() - use sparse_tools - use sparse_tools_petsc - use parallel_tools - use petsc_tools - use unittest_tools - use petsc - implicit none + use sparse_tools + use sparse_tools_petsc + use parallel_tools + use petsc_tools + use unittest_tools + use petsc + implicit none #include "petsc_legacy.h" - type(petsc_csr_matrix):: A - type(csr_matrix):: B - PetscErrorCode:: ierr - PetscInt:: ctx - real, dimension(4,4):: vals - logical:: fail - integer:: i, j + type(petsc_csr_matrix):: A + type(csr_matrix):: B + PetscErrorCode:: ierr + PetscInt:: ctx + real, dimension(4,4):: vals + logical:: fail + integer:: i, j - ! ---- first check assembly using petsc_csr_vaddto --- + ! ---- first check assembly using petsc_csr_vaddto --- - call allocate(A, 4, 4, & - dnnz=(/ 4, 4, 4, 4 /), & - onnz=(/ 0, 0, 0, 0 /), & - blocks=(/ 1, 1 /), & - name="TestMatrix") + call allocate(A, 4, 4, & + dnnz=(/ 4, 4, 4, 4 /), & + onnz=(/ 0, 0, 0, 0 /), & + blocks=(/ 1, 1 /), & + name="TestMatrix") - call zero(A) + call zero(A) - ! make a trivial 4x4 matrix: - ! 1. 2. 3. 4. - ! 5. 6. 7. 8. - ! 9. 10. 11. 12. - ! 13. 14. 15. 16. + ! make a trivial 4x4 matrix: + ! 1. 2. 3. 4. + ! 5. 6. 7. 8. + ! 9. 10. 11. 12. + ! 13. 14. 15. 16. - vals=transpose(reshape((/ ( real(i), i=1, 16 ) /), (/ 4, 4 /))) + vals=transpose(reshape((/ ( real(i), i=1, 16 ) /), (/ 4, 4 /))) - call addto(A, 1, 1, (/ 1, 2, 3, 4 /), (/ 1, 2, 3, 4/), & - vals) + call addto(A, 1, 1, (/ 1, 2, 3, 4 /), (/ 1, 2, 3, 4/), & + vals) - ! assemble and copy into csr_matrix - call assemble(A) - B=petsc2csr(A%M) + ! assemble and copy into csr_matrix + call assemble(A) + B=petsc2csr(A%M) - ! then check B has the righ values - fail = any(abs(B%val-(/ ( real(i), i=1, 16 ) /))>1e-12) - call report_test("[petsc_csr_matrix]", fail, .false., "Correct values in matrix.") + ! then check B has the righ values + fail = any(abs(B%val-(/ ( real(i), i=1, 16 ) /))>1e-12) + call report_test("[petsc_csr_matrix]", fail, .false., "Correct values in matrix.") - ! and column indices - fail = any(B%sparsity%colm/=(/ ( ( i, i=1, 4 ), j=1,4 ) /)) - call report_test("[petsc_csr_matrix]", fail, .false., "Correct column indices.") + ! and column indices + fail = any(B%sparsity%colm/=(/ ( ( i, i=1, 4 ), j=1,4 ) /)) + call report_test("[petsc_csr_matrix]", fail, .false., "Correct column indices.") - call deallocate(B) + call deallocate(B) - ! now add the same thing again - call addto(A, 1, 1, (/ 1, 2, 3, 4 /), (/ 1, 2, 3, 4/), & - vals ) + ! now add the same thing again + call addto(A, 1, 1, (/ 1, 2, 3, 4 /), (/ 1, 2, 3, 4/), & + vals ) - ! reassemble and copy into csr_matrix - call assemble(A) - B=petsc2csr(A%M) + ! reassemble and copy into csr_matrix + call assemble(A) + B=petsc2csr(A%M) - ! and check its new values - fail = any(abs(B%val-2.0*(/ ( real(i), i=1, 16 ) /))>1e-12) - call report_test("[petsc_csr_matrix]", fail, .false., "Correct values in matrix.") + ! and check its new values + fail = any(abs(B%val-2.0*(/ ( real(i), i=1, 16 ) /))>1e-12) + call report_test("[petsc_csr_matrix]", fail, .false., "Correct values in matrix.") - ! column indices should remain unchanged - fail = any(B%sparsity%colm/=(/ ( ( i, i=1, 4 ), j=1,4 ) /)) - call report_test("[petsc_csr_matrix]", fail, .false., "Correct values in matrix.") + ! column indices should remain unchanged + fail = any(B%sparsity%colm/=(/ ( ( i, i=1, 4 ), j=1,4 ) /)) + call report_test("[petsc_csr_matrix]", fail, .false., "Correct values in matrix.") - call deallocate(B) - call deallocate(A) + call deallocate(B) + call deallocate(A) - ! ---- now check for a fail if we under estimate nnz --- + ! ---- now check for a fail if we under estimate nnz --- - ! set error handler to catch the petsc error (use the one from petsc_tools) - call PetscPushErrorHandler(petsc_test_error_handler, ctx, ierr) + ! set error handler to catch the petsc error (use the one from petsc_tools) + call PetscPushErrorHandler(petsc_test_error_handler, ctx, ierr) - call allocate(A, 4, 4, & - dnnz=(/ 1, 1, 1, 1 /), & - onnz=(/ 0, 0, 0, 0 /), & - blocks=(/ 1, 1 /), & - name="TestMatrix") + call allocate(A, 4, 4, & + dnnz=(/ 1, 1, 1, 1 /), & + onnz=(/ 0, 0, 0, 0 /), & + blocks=(/ 1, 1 /), & + name="TestMatrix") - call zero(A) + call zero(A) - ! this is a module variable in petsc_tools that gets set to .true. in the error handler - petsc_test_error_handler_called = .false. + ! this is a module variable in petsc_tools that gets set to .true. in the error handler + petsc_test_error_handler_called = .false. - ! addition that over runs preallocated memory - call addto(A, 1, 1, (/ 1 /), (/ 1, 2 /), & - reshape( (/ 2.0, 3.0 /), (/ 1, 2 /)) ) + ! addition that over runs preallocated memory + call addto(A, 1, 1, (/ 1 /), (/ 1, 2 /), & + reshape( (/ 2.0, 3.0 /), (/ 1, 2 /)) ) - fail = .not. petsc_test_error_handler_called - call report_test("[petsc_csr_matrix]", fail, .false., "PETSc should give an error when overrunning nnz.") + fail = .not. petsc_test_error_handler_called + call report_test("[petsc_csr_matrix]", fail, .false., "PETSc should give an error when overrunning nnz.") - call deallocate(A) + call deallocate(A) end subroutine test_petsc_csr_matrix diff --git a/femtools/tests/test_pickers.F90 b/femtools/tests/test_pickers.F90 index 961316021d..54c5967b6b 100644 --- a/femtools/tests/test_pickers.F90 +++ b/femtools/tests/test_pickers.F90 @@ -29,32 +29,32 @@ subroutine test_pickers - use fields - use fldebug - use pickers - use mesh_files - use unittest_tools + use fields + use fldebug + use pickers + use mesh_files + use unittest_tools - implicit none + implicit none - integer :: ele - type(vector_field) :: positions + integer :: ele + type(vector_field) :: positions - positions = read_mesh_files("data/triangle.1", quad_degree = 1, format="gmsh") + positions = read_mesh_files("data/triangle.1", quad_degree = 1, format="gmsh") - call report_test("[Picker pointer allocated]", .not. associated(positions%picker), .false., "Picker pointer not allocated") - call report_test("[No picker attached]", associated(positions%picker%ptr), .false., "Picker already attached") + call report_test("[Picker pointer allocated]", .not. associated(positions%picker), .false., "Picker pointer not allocated") + call report_test("[No picker attached]", associated(positions%picker%ptr), .false., "Picker already attached") - call picker_inquire(positions, (/-1.0, 0.0/), ele) - call report_test("[Point not contained]", ele > 0, .false., "Incorrectly reported point contained in mesh") + call picker_inquire(positions, (/-1.0, 0.0/), ele) + call report_test("[Point not contained]", ele > 0, .false., "Incorrectly reported point contained in mesh") - call report_test("[Picker cached]", .not. associated(positions%picker%ptr), .false., "Picker not cached") + call report_test("[Picker cached]", .not. associated(positions%picker%ptr), .false., "Picker not cached") - call picker_inquire(positions, (/0.25, 0.0/), ele) - call report_test("[Point contained]", ele /= 1, .false., "Reported incorrect containing element") + call picker_inquire(positions, (/0.25, 0.0/), ele) + call report_test("[Point contained]", ele /= 1, .false., "Reported incorrect containing element") - call deallocate(positions) + call deallocate(positions) - call report_test_no_references() + call report_test_no_references() end subroutine test_pickers diff --git a/femtools/tests/test_polynomials.F90 b/femtools/tests/test_polynomials.F90 index a81c6cdb9b..5f5ff9272d 100644 --- a/femtools/tests/test_polynomials.F90 +++ b/femtools/tests/test_polynomials.F90 @@ -1,20 +1,20 @@ subroutine test_polynomials - use polynomials - use unittest_tools - implicit none + use polynomials + use unittest_tools + implicit none - type(polynomial) :: poly - character(len=100) :: buffer + type(polynomial) :: poly + character(len=100) :: buffer - logical :: fail + logical :: fail - poly=(/3.,2.,1./) + poly=(/3.,2.,1./) - buffer= poly2string(poly) + buffer= poly2string(poly) - fail=.not.(buffer==" 3.000x^2 + 2.000x + 1.000") + fail=.not.(buffer==" 3.000x^2 + 2.000x + 1.000") - call report_test("[polynomial2string]", fail, .false., "Wrote the poly wrong.") + call report_test("[polynomial2string]", fail, .false., "Wrote the poly wrong.") end subroutine test_polynomials diff --git a/femtools/tests/test_pseudo2d_hessian.F90 b/femtools/tests/test_pseudo2d_hessian.F90 index f4fb9470ff..4848bf9b2b 100644 --- a/femtools/tests/test_pseudo2d_hessian.F90 +++ b/femtools/tests/test_pseudo2d_hessian.F90 @@ -1,113 +1,113 @@ subroutine test_pseudo2d_hessian - use vtk_interfaces - use field_derivatives - use unittest_tools - use state_module - use node_boundary, only: pseudo2d_coord - implicit none - - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field) :: pressure_field - type(tensor_field) :: hessian - real, dimension(3, 3) :: answer - integer :: i - logical :: fail - real :: x, y, z - - pseudo2d_coord = 3 - - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - call allocate(pressure_field, mesh, "Pressure") - call allocate(hessian, mesh, "Hessian") - - do i=1,mesh%nodes - x = position_field%val(1,i) - y = position_field%val(2,i) - z = position_field%val(3,i) - pressure_field%val(i) = x * x - end do - - call compute_hessian(pressure_field, position_field, hessian) - call vtk_write_fields("data/pseudo2d_hessian", 0, position_field, mesh, sfields=(/pressure_field/), tfields=(/hessian/)) - - answer = 0.0; answer(1, 1) = 2.0 - - fail = .false. - do i=1,mesh%nodes - x = position_field%val(1,i) - if (x <= 1.0 .or. x >= 29.0) cycle - - y = position_field%val(2,i) - if (y <= 1.0 .or. y >= 14.0) cycle - - if (.not. fequals(hessian%val(1, 1, i), answer(1, 1), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(1, 1, i) == ", hessian%val(1, 1, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - end do - - call report_test("[pseudo2d hessian x,x]", fail, .false., "The hessian of x^2 is not what it should be!") - - fail = .false. - do i=1,mesh%nodes - x = position_field%val(1,i) - if (x <= 1.0 .or. x >= 29.0) cycle - - y = position_field%val(2,i) - if (y <= 1.0 .or. y >= 14.0) cycle - - if (.not. fequals(hessian%val(1, 2, i), answer(1, 2), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(1, 2, i) == ", hessian%val(1, 2, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(1, 3, i), answer(1, 3), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(1, 3, i) == ", hessian%val(1, 3, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(2, 1, i), answer(2, 1), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(2, 1, i) == ", hessian%val(2, 1, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(2, 2, i), answer(2, 2), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(2, 2, i) == ", hessian%val(2, 2, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(2, 3, i), answer(2, 3), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(2, 3, i) == ", hessian%val(2, 3, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(3, 1, i), answer(3, 1), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(3, 1, i) == ", hessian%val(3, 1, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(3, 2, i), answer(3, 2), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(3, 2, i) == ", hessian%val(3, 2, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - if (.not. fequals(hessian%val(3, 3, i), answer(3, 3), 0.15)) then - write(0,*) "i == ", i, "; hessian%val(3, 3, i) == ", hessian%val(3, 3, i) - write(0,*) "x == ", x, "; y == ", y - fail = .true. - end if - end do - - call report_test("[pseudo2d hessian others]", fail, .false., "The hessian of x^2 is not what it should be!") - - call deallocate(hessian) - call deallocate(pressure_field) - call deallocate(state) + use vtk_interfaces + use field_derivatives + use unittest_tools + use state_module + use node_boundary, only: pseudo2d_coord + implicit none + + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field) :: pressure_field + type(tensor_field) :: hessian + real, dimension(3, 3) :: answer + integer :: i + logical :: fail + real :: x, y, z + + pseudo2d_coord = 3 + + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + call allocate(pressure_field, mesh, "Pressure") + call allocate(hessian, mesh, "Hessian") + + do i=1,mesh%nodes + x = position_field%val(1,i) + y = position_field%val(2,i) + z = position_field%val(3,i) + pressure_field%val(i) = x * x + end do + + call compute_hessian(pressure_field, position_field, hessian) + call vtk_write_fields("data/pseudo2d_hessian", 0, position_field, mesh, sfields=(/pressure_field/), tfields=(/hessian/)) + + answer = 0.0; answer(1, 1) = 2.0 + + fail = .false. + do i=1,mesh%nodes + x = position_field%val(1,i) + if (x <= 1.0 .or. x >= 29.0) cycle + + y = position_field%val(2,i) + if (y <= 1.0 .or. y >= 14.0) cycle + + if (.not. fequals(hessian%val(1, 1, i), answer(1, 1), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(1, 1, i) == ", hessian%val(1, 1, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + end do + + call report_test("[pseudo2d hessian x,x]", fail, .false., "The hessian of x^2 is not what it should be!") + + fail = .false. + do i=1,mesh%nodes + x = position_field%val(1,i) + if (x <= 1.0 .or. x >= 29.0) cycle + + y = position_field%val(2,i) + if (y <= 1.0 .or. y >= 14.0) cycle + + if (.not. fequals(hessian%val(1, 2, i), answer(1, 2), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(1, 2, i) == ", hessian%val(1, 2, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(1, 3, i), answer(1, 3), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(1, 3, i) == ", hessian%val(1, 3, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(2, 1, i), answer(2, 1), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(2, 1, i) == ", hessian%val(2, 1, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(2, 2, i), answer(2, 2), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(2, 2, i) == ", hessian%val(2, 2, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(2, 3, i), answer(2, 3), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(2, 3, i) == ", hessian%val(2, 3, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(3, 1, i), answer(3, 1), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(3, 1, i) == ", hessian%val(3, 1, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(3, 2, i), answer(3, 2), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(3, 2, i) == ", hessian%val(3, 2, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + if (.not. fequals(hessian%val(3, 3, i), answer(3, 3), 0.15)) then + write(0,*) "i == ", i, "; hessian%val(3, 3, i) == ", hessian%val(3, 3, i) + write(0,*) "x == ", x, "; y == ", y + fail = .true. + end if + end do + + call report_test("[pseudo2d hessian others]", fail, .false., "The hessian of x^2 is not what it should be!") + + call deallocate(hessian) + call deallocate(pressure_field) + call deallocate(state) end subroutine test_pseudo2d_hessian diff --git a/femtools/tests/test_python.F90 b/femtools/tests/test_python.F90 index 8949939676..65fc2a18db 100644 --- a/femtools/tests/test_python.F90 +++ b/femtools/tests/test_python.F90 @@ -28,65 +28,65 @@ #include "fdebug.h" subroutine test_python - !!< Test that we can set a field using python. - use fields - use mesh_files - use unittest_tools - use futils - implicit none + !!< Test that we can set a field using python. + use fields + use mesh_files + use unittest_tools + use futils + implicit none - type(vector_field) :: X - type(scalar_field) :: T - logical :: fail + type(vector_field) :: X + type(scalar_field) :: T + logical :: fail - logical :: file_exists - integer :: unit - character(len=10000) :: func, buffer + logical :: file_exists + integer :: unit + character(len=10000) :: func, buffer #ifdef HAVE_PYTHON - X=read_mesh_files("data/interval", quad_degree=4, format="gmsh") + X=read_mesh_files("data/interval", quad_degree=4, format="gmsh") - call allocate(T, X%mesh, "tracer") + call allocate(T, X%mesh, "tracer") - call set_from_python_function(T, & - "def val(X,t): import math; return math.cos(X[0])", X, 0.0) + call set_from_python_function(T, & + "def val(X,t): import math; return math.cos(X[0])", X, 0.0) - fail=any(abs(T%val-cos(X%val(1,:)))>1e-14) - call report_test("[test_python 1D function fields]", fail, .false., & - "python and fortran should produce the same answer.") + fail=any(abs(T%val-cos(X%val(1,:)))>1e-14) + call report_test("[test_python 1D function fields]", fail, .false., & + "python and fortran should produce the same answer.") - call set_from_python_function(T%val, & - "def val(X,t): import math; return math.cos(X[0])", X%val(1,:),& - & time=0.0) + call set_from_python_function(T%val, & + "def val(X,t): import math; return math.cos(X[0])", X%val(1,:),& + & time=0.0) - fail=any(abs(T%val-cos(X%val(1,:)))>1e-14) - call report_test("[test_python 1D function values]", fail, .false., & - "python and fortran should produce the same answer.") + fail=any(abs(T%val-cos(X%val(1,:)))>1e-14) + call report_test("[test_python 1D function values]", fail, .false., & + "python and fortran should produce the same answer.") - inquire(file="stflux.py",exist=file_exists) + inquire(file="stflux.py",exist=file_exists) - if (.not.file_exists) return + if (.not.file_exists) return - unit=free_unit() - open(unit, file="stflux.py", action="read",& - & status="old") - read(unit, '(a)', end=42) func + unit=free_unit() + open(unit, file="stflux.py", action="read",& + & status="old") + read(unit, '(a)', end=42) func - ! Read all the lines of the file and put in newlines between them. - do - read(unit, '(a)', end=42) buffer + ! Read all the lines of the file and put in newlines between them. + do + read(unit, '(a)', end=42) buffer - func=trim(func)//achar(10)//trim(buffer) + func=trim(func)//achar(10)//trim(buffer) - end do + end do 42 func=trim(func)//achar(10) - close(unit) + close(unit) - call set_from_python_function(T%val, & - trim(func), X%val(1,:),& - & time=0.0) + call set_from_python_function(T%val, & + trim(func), X%val(1,:),& + & time=0.0) #endif diff --git a/femtools/tests/test_python_2d.F90 b/femtools/tests/test_python_2d.F90 index b3b2f707d6..2e92cf116d 100644 --- a/femtools/tests/test_python_2d.F90 +++ b/femtools/tests/test_python_2d.F90 @@ -28,49 +28,49 @@ #include "fdebug.h" subroutine test_python_2d - !!< Test that we can set a field using python. - use fields - use mesh_files - use unittest_tools - use futils - implicit none - - type(vector_field) :: X - type(scalar_field) :: T - type(tensor_field) :: Q - logical :: fail + !!< Test that we can set a field using python. + use fields + use mesh_files + use unittest_tools + use futils + implicit none + + type(vector_field) :: X + type(scalar_field) :: T + type(tensor_field) :: Q + logical :: fail #ifdef HAVE_PYTHON - X=read_mesh_files("data/square.1", quad_degree=4, format="gmsh") + X=read_mesh_files("data/square.1", quad_degree=4, format="gmsh") - call allocate(T, X%mesh, "tracer") + call allocate(T, X%mesh, "tracer") - call set_from_python_function(T, & - "def val(X,t): import math; return math.cos(X[0]*X[1])", X, 0.0) + call set_from_python_function(T, & + "def val(X,t): import math; return math.cos(X[0]*X[1])", X, 0.0) - fail=any(abs(T%val-cos(X%val(1,:)*X%val(2,:)))>1e-14) - call report_test("[test_python 2D function fields]", fail, .false., & - "python and fortran should produce the same answer.") + fail=any(abs(T%val-cos(X%val(1,:)*X%val(2,:)))>1e-14) + call report_test("[test_python 2D function fields]", fail, .false., & + "python and fortran should produce the same answer.") - call set_from_python_function(T%val, & - "def val(X,t): import math; return math.cos(X[0]*X[1])", X%val(1,:),& - & X%val(2,:), time=0.0) + call set_from_python_function(T%val, & + "def val(X,t): import math; return math.cos(X[0]*X[1])", X%val(1,:),& + & X%val(2,:), time=0.0) - fail=any(abs(T%val-cos(X%val(1,:)*X%val(2,:)))>1e-14) - call report_test("[test_python 2D function values]", fail, .false., & - "python and fortran should produce the same answer.") + fail=any(abs(T%val-cos(X%val(1,:)*X%val(2,:)))>1e-14) + call report_test("[test_python 2D function values]", fail, .false., & + "python and fortran should produce the same answer.") #ifdef HAVE_NUMPY - call allocate(Q, X%mesh, "Tensor") + call allocate(Q, X%mesh, "Tensor") - call set_from_python_function(Q, & - "def val(X,t): return [[1, 2], [3, 4]]", X, 0.0) + call set_from_python_function(Q, & + "def val(X,t): return [[1, 2], [3, 4]]", X, 0.0) - fail=any(node_val(Q,1)/= reshape((/1.,3.,2.,4./),(/2,2/))) + fail=any(node_val(Q,1)/= reshape((/1.,3.,2.,4./),(/2,2/))) - call report_test("[test_python 2D tensor field]", fail, .false., & - "Tensor field value is set correctly.") + call report_test("[test_python 2D tensor field]", fail, .false., & + "Tensor field value is set correctly.") #endif diff --git a/femtools/tests/test_python_fields.F90 b/femtools/tests/test_python_fields.F90 index 707ae76c56..40cfe3b12d 100644 --- a/femtools/tests/test_python_fields.F90 +++ b/femtools/tests/test_python_fields.F90 @@ -1,79 +1,79 @@ subroutine test_python_fields - use fields - use vtk_interfaces - use state_module - use unittest_tools - use global_parameters, only: PYTHON_FUNC_LEN, ACCTIM - implicit none + use fields + use vtk_interfaces + use state_module + use unittest_tools + use global_parameters, only: PYTHON_FUNC_LEN, ACCTIM + implicit none - type(scalar_field) :: sfield - type(vector_field) :: vfield - type(tensor_field) :: tfield - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: positions - logical :: fail - real, dimension(4) :: ele_s - real, dimension(4) :: posx_s - real, dimension(3, 4) :: ele_v - real, dimension(3, 3, 4) :: ele_t - real :: node_s - real, dimension(3) :: node_v - real, dimension(3, 3) :: node_t - integer :: i, j, k, l - character, parameter:: NEWLINE_CHAR=achar(10) - character(len=*), parameter:: func = & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return X[0]" - external :: compute_nodes_python, compute_nodes_stored + type(scalar_field) :: sfield + type(vector_field) :: vfield + type(tensor_field) :: tfield + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: positions + logical :: fail + real, dimension(4) :: ele_s + real, dimension(4) :: posx_s + real, dimension(3, 4) :: ele_v + real, dimension(3, 3, 4) :: ele_t + real :: node_s + real, dimension(3) :: node_v + real, dimension(3, 3) :: node_t + integer :: i, j, k, l + character, parameter:: NEWLINE_CHAR=achar(10) + character(len=*), parameter:: func = & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return X[0]" + external :: compute_nodes_python, compute_nodes_stored - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - positions => extract_vector_field(state, "Coordinate") + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + positions => extract_vector_field(state, "Coordinate") - ACCTIM = 0.0 + ACCTIM = 0.0 - call allocate(sfield, mesh, "ScalarField", FIELD_TYPE_PYTHON, py_func=func, py_positions=positions) + call allocate(sfield, mesh, "ScalarField", FIELD_TYPE_PYTHON, py_func=func, py_positions=positions) - do i=1,5 - call compute_nodes_python(sfield) - call compute_nodes_stored(positions) - end do + do i=1,5 + call compute_nodes_python(sfield) + call compute_nodes_stored(positions) + end do - call deallocate(sfield) + call deallocate(sfield) end subroutine test_python_fields subroutine compute_nodes_python(sfield) - use fields - type(scalar_field), intent(in) :: sfield + use fields + type(scalar_field), intent(in) :: sfield - integer :: node, ele - real :: whatever - real, dimension(4) :: whatever_n + integer :: node, ele + real :: whatever + real, dimension(4) :: whatever_n ! do node=1,node_count(sfield) ! whatever = node_val(sfield, node) ! end do - do ele=1,ele_count(sfield) - whatever_n = ele_val(sfield, ele) - end do + do ele=1,ele_count(sfield) + whatever_n = ele_val(sfield, ele) + end do end subroutine compute_nodes_python subroutine compute_nodes_stored(vfield) - use fields - type(vector_field), intent(in) :: vfield + use fields + type(vector_field), intent(in) :: vfield - integer :: node, ele - real :: whatever - real, dimension(4) :: whatever_n + integer :: node, ele + real :: whatever + real, dimension(4) :: whatever_n ! do node=1,node_count(vfield) ! whatever = node_val(vfield, node, 1) ! end do - do ele=1,ele_count(vfield) - whatever_n = ele_val(vfield, ele, 1) - end do + do ele=1,ele_count(vfield) + whatever_n = ele_val(vfield, ele, 1) + end do end subroutine compute_nodes_stored diff --git a/femtools/tests/test_python_real_vector.F90 b/femtools/tests/test_python_real_vector.F90 index 2dd43c479c..49581f1455 100644 --- a/femtools/tests/test_python_real_vector.F90 +++ b/femtools/tests/test_python_real_vector.F90 @@ -28,29 +28,29 @@ #include "fdebug.h" subroutine test_python_real_vector - !!< Test that we can set a field using python. - use embed_python - use unittest_tools - use futils - implicit none + !!< Test that we can set a field using python. + use embed_python + use unittest_tools + use futils + implicit none #ifdef HAVE_PYTHON - logical :: fail - real, dimension(:), pointer :: result - integer :: stat + logical :: fail + real, dimension(:), pointer :: result + integer :: stat - call real_vector_from_python(& - "def val(t): return (1.0, 2.0, 3.0, 4.0)", 0.0, result, stat) + call real_vector_from_python(& + "def val(t): return (1.0, 2.0, 3.0, 4.0)", 0.0, result, stat) - fail=any(result/=(/1.0, 2.0, 3.0, 4.0/)) + fail=any(result/=(/1.0, 2.0, 3.0, 4.0/)) - call report_test("[test_python_real_vector]", fail, .false., & - "python and fortran should produce the same answer.") + call report_test("[test_python_real_vector]", fail, .false., & + "python and fortran should produce the same answer.") - deallocate(result, stat=stat) + deallocate(result, stat=stat) - call report_test("[test_python_real_vector deallocate]", fail, .false., & - "failed to deallocate result vector") + call report_test("[test_python_real_vector deallocate]", fail, .false., & + "failed to deallocate result vector") #endif diff --git a/femtools/tests/test_python_state.F90 b/femtools/tests/test_python_state.F90 index 19b06d20b0..f9f339ed6e 100644 --- a/femtools/tests/test_python_state.F90 +++ b/femtools/tests/test_python_state.F90 @@ -29,129 +29,129 @@ subroutine test_python_state - use fields - use fldebug - use python_state - use mesh_files - use state_module - use unittest_tools - - implicit none - - integer :: dim, i, stat - logical :: fail - type(scalar_field) :: s_field - type(state_type) :: state - type(tensor_field) :: t_field - type(vector_field) :: positions, v_field - - positions = read_mesh_files("data/interval", quad_degree = 1, format="gmsh") - dim = positions%dim - call insert(state, positions, name = "Coordinate") - call insert(state, positions%mesh, name = "CoordinateMesh") - - call allocate(s_field, positions%mesh, name = "ScalarField") - call insert(state, s_field, name = s_field%name) - - call zero(s_field) - - fail = .false. - do i = 1, node_count(s_field) - if(node_val(s_field, i) .fne. 0.0) then - fail = .true. - exit - end if - end do - call report_test("[Zero valued scalar]", fail, .false., "Scalar field is not zero valued") - - call python_add_state(state) - call python_run_string('s_field = state.scalar_fields["ScalarField"]' // new_line("") // & - & 'for i in range(s_field.node_count):' // new_line("") // & - & ' s_field.set(i, i + 1)' // new_line(""), & - & stat = stat) - call python_reset() - - call report_test("[python_run_string]", stat /= 0, .false., "python_run_string returned an error") - - fail = .false. - do i = 1, node_count(s_field) - if(node_val(s_field, i) .fne. float(i)) then - fail = .true. - exit - end if - end do - call report_test("[Scalar field value set in python]", fail, .false., "Failed to set scalar field value") - - call allocate(v_field, positions%dim, positions%mesh, name = "VectorField") - call insert(state, v_field, name = v_field%name) - - call zero(v_field) - - call allocate(t_field, positions%mesh, name = "TensorField") - call insert(state, t_field, name = t_field%name) - - fail = .false. - do i = 1, node_count(v_field) - if(node_val(v_field, i) .fne. spread(0.0, 1, dim)) then - fail = .true. - exit - end if - end do - call report_test("[Zero valued vector]", fail, .false., "Vector field is not zero valued") - - call python_add_state(state) - call python_run_string('v_field = state.vector_fields["VectorField"]' // new_line("") // & - & 'for i in range(v_field.node_count):' // new_line("") // & - & ' v_field.set(i, numpy.array([i + 1]))' // new_line(""), & - & stat = stat) - call python_reset() - - call report_test("[python_run_string]", stat /= 0, .false., "python_run_string returned an error") - - fail = .false. - do i = 1, node_count(v_field) - if(node_val(v_field, i) .fne. spread(float(i), 1, dim)) then - fail = .true. - exit - end if - end do - call report_test("[Vector field value set in python]", fail, .false., "Failed to set vector field value") - - call zero(t_field) - - fail = .false. - do i = 1, node_count(t_field) - if(.not. mat_zero(node_val(t_field, i))) then - fail = .true. - exit - end if - end do - call report_test("[Zero valued tensor]", fail, .false., "Tensor field is not zero valued") - - call python_add_state(state) - call python_run_string('t_field = state.tensor_fields["TensorField"]' // new_line("") // & - & 'for i in range(t_field.node_count):' // new_line("") // & - & ' t_field.set(i, numpy.array([[i + 1]]))' // new_line(""), & - & stat = stat) - call python_reset() - - call report_test("[python_run_string]", stat /= 0, .false., "python_run_string returned an error") - - fail = .false. - do i = 1, node_count(t_field) - if(node_val(t_field, i) .fne. reshape(spread(float(i), 1, dim * dim), (/dim, dim/))) then - fail = .true. - exit - end if - end do - call report_test("[Tensor field value set in python]", fail, .false., "Failed to set tensor field value") - - call deallocate(state) - call deallocate(s_field) - call deallocate(v_field) - call deallocate(t_field) - call deallocate(positions) - - call report_test_no_references() + use fields + use fldebug + use python_state + use mesh_files + use state_module + use unittest_tools + + implicit none + + integer :: dim, i, stat + logical :: fail + type(scalar_field) :: s_field + type(state_type) :: state + type(tensor_field) :: t_field + type(vector_field) :: positions, v_field + + positions = read_mesh_files("data/interval", quad_degree = 1, format="gmsh") + dim = positions%dim + call insert(state, positions, name = "Coordinate") + call insert(state, positions%mesh, name = "CoordinateMesh") + + call allocate(s_field, positions%mesh, name = "ScalarField") + call insert(state, s_field, name = s_field%name) + + call zero(s_field) + + fail = .false. + do i = 1, node_count(s_field) + if(node_val(s_field, i) .fne. 0.0) then + fail = .true. + exit + end if + end do + call report_test("[Zero valued scalar]", fail, .false., "Scalar field is not zero valued") + + call python_add_state(state) + call python_run_string('s_field = state.scalar_fields["ScalarField"]' // new_line("") // & + & 'for i in range(s_field.node_count):' // new_line("") // & + & ' s_field.set(i, i + 1)' // new_line(""), & + & stat = stat) + call python_reset() + + call report_test("[python_run_string]", stat /= 0, .false., "python_run_string returned an error") + + fail = .false. + do i = 1, node_count(s_field) + if(node_val(s_field, i) .fne. float(i)) then + fail = .true. + exit + end if + end do + call report_test("[Scalar field value set in python]", fail, .false., "Failed to set scalar field value") + + call allocate(v_field, positions%dim, positions%mesh, name = "VectorField") + call insert(state, v_field, name = v_field%name) + + call zero(v_field) + + call allocate(t_field, positions%mesh, name = "TensorField") + call insert(state, t_field, name = t_field%name) + + fail = .false. + do i = 1, node_count(v_field) + if(node_val(v_field, i) .fne. spread(0.0, 1, dim)) then + fail = .true. + exit + end if + end do + call report_test("[Zero valued vector]", fail, .false., "Vector field is not zero valued") + + call python_add_state(state) + call python_run_string('v_field = state.vector_fields["VectorField"]' // new_line("") // & + & 'for i in range(v_field.node_count):' // new_line("") // & + & ' v_field.set(i, numpy.array([i + 1]))' // new_line(""), & + & stat = stat) + call python_reset() + + call report_test("[python_run_string]", stat /= 0, .false., "python_run_string returned an error") + + fail = .false. + do i = 1, node_count(v_field) + if(node_val(v_field, i) .fne. spread(float(i), 1, dim)) then + fail = .true. + exit + end if + end do + call report_test("[Vector field value set in python]", fail, .false., "Failed to set vector field value") + + call zero(t_field) + + fail = .false. + do i = 1, node_count(t_field) + if(.not. mat_zero(node_val(t_field, i))) then + fail = .true. + exit + end if + end do + call report_test("[Zero valued tensor]", fail, .false., "Tensor field is not zero valued") + + call python_add_state(state) + call python_run_string('t_field = state.tensor_fields["TensorField"]' // new_line("") // & + & 'for i in range(t_field.node_count):' // new_line("") // & + & ' t_field.set(i, numpy.array([[i + 1]]))' // new_line(""), & + & stat = stat) + call python_reset() + + call report_test("[python_run_string]", stat /= 0, .false., "python_run_string returned an error") + + fail = .false. + do i = 1, node_count(t_field) + if(node_val(t_field, i) .fne. reshape(spread(float(i), 1, dim * dim), (/dim, dim/))) then + fail = .true. + exit + end if + end do + call report_test("[Tensor field value set in python]", fail, .false., "Failed to set tensor field value") + + call deallocate(state) + call deallocate(s_field) + call deallocate(v_field) + call deallocate(t_field) + call deallocate(positions) + + call report_test_no_references() end subroutine test_python_state diff --git a/femtools/tests/test_qsort.F90 b/femtools/tests/test_qsort.F90 index 5e55c8f5b1..8f90a98d46 100644 --- a/femtools/tests/test_qsort.F90 +++ b/femtools/tests/test_qsort.F90 @@ -1,20 +1,20 @@ subroutine test_qsort - use quicksort - use unittest_tools + use quicksort + use unittest_tools - implicit none + implicit none - integer, dimension(5) :: integer_data, permutation - real, dimension(5) :: real_data + integer, dimension(5) :: integer_data, permutation + real, dimension(5) :: real_data - integer_data = (/4, 2, 1, 5, 3/) - call qsort(integer_data, permutation) - call report_test("[Input data unchanged]", any(integer_data /= (/4, 2, 1, 5, 3/)), .false., "Input data changed") - call report_test("[Correct permutation]", any(permutation /= (/3, 2, 5, 1, 4/)), .false., "Incorrect permutation") + integer_data = (/4, 2, 1, 5, 3/) + call qsort(integer_data, permutation) + call report_test("[Input data unchanged]", any(integer_data /= (/4, 2, 1, 5, 3/)), .false., "Input data changed") + call report_test("[Correct permutation]", any(permutation /= (/3, 2, 5, 1, 4/)), .false., "Incorrect permutation") - real_data = (/4.0, 2.0, 1.0, 5.0, 3.0/) - call report_test("[Input data unchanged]", any(abs(real_data - (/4.0, 2.0, 1.0, 5.0, 3.0/)) > epsilon(0.0)), .false., "Input data changed") - call report_test("[Correct permutation]", any(permutation /= (/3, 2, 5, 1, 4/)), .false., "Incorrect permutation") + real_data = (/4.0, 2.0, 1.0, 5.0, 3.0/) + call report_test("[Input data unchanged]", any(abs(real_data - (/4.0, 2.0, 1.0, 5.0, 3.0/)) > epsilon(0.0)), .false., "Input data changed") + call report_test("[Correct permutation]", any(permutation /= (/3, 2, 5, 1, 4/)), .false., "Incorrect permutation") end subroutine test_qsort diff --git a/femtools/tests/test_quad_quadrature.F90 b/femtools/tests/test_quad_quadrature.F90 index 653f24a33e..8b7cf93ca1 100644 --- a/femtools/tests/test_quad_quadrature.F90 +++ b/femtools/tests/test_quad_quadrature.F90 @@ -1,103 +1,103 @@ subroutine test_quad_quadrature - use unittest_tools - use elements - use fetools - use shape_functions - use fields - implicit none + use unittest_tools + use elements + use fetools + use shape_functions + use fields + implicit none - logical :: fail - type(mesh_type) :: tri_mesh, quad_mesh - type(vector_field) :: tri_X, quad_X - type(element_type) :: quad_shape, tri_shape - type(quadrature_type) :: quad_quadrature, tri_quadrature - real, dimension(:,:,:), allocatable :: J_quad, J_tri - real, dimension(:), allocatable :: detwei_quad, detwei_tri - real, dimension(4,4) :: quad_mass - real, dimension(6,6) :: l_tri_mass - real, dimension(4,4) :: global_tri_mass - real, dimension(4,6) :: local2global + logical :: fail + type(mesh_type) :: tri_mesh, quad_mesh + type(vector_field) :: tri_X, quad_X + type(element_type) :: quad_shape, tri_shape + type(quadrature_type) :: quad_quadrature, tri_quadrature + real, dimension(:,:,:), allocatable :: J_quad, J_tri + real, dimension(:), allocatable :: detwei_quad, detwei_tri + real, dimension(4,4) :: quad_mass + real, dimension(6,6) :: l_tri_mass + real, dimension(4,4) :: global_tri_mass + real, dimension(4,6) :: local2global - quad_quadrature = make_quadrature(vertices=4,dim=2,degree=2) - tri_quadrature = make_quadrature(vertices=3,dim=2,degree=4) + quad_quadrature = make_quadrature(vertices=4,dim=2,degree=2) + tri_quadrature = make_quadrature(vertices=3,dim=2,degree=4) - allocate(J_quad(2,2,quad_quadrature%ngi)) - allocate(J_tri(2,2,tri_quadrature%ngi)) - allocate(detwei_quad(quad_quadrature%ngi)) - allocate(detwei_tri(tri_quadrature%ngi)) + allocate(J_quad(2,2,quad_quadrature%ngi)) + allocate(J_tri(2,2,tri_quadrature%ngi)) + allocate(detwei_quad(quad_quadrature%ngi)) + allocate(detwei_tri(tri_quadrature%ngi)) - quad_shape=make_element_shape(vertices=4, dim=2, degree=1, & - &quad= quad_quadrature) - tri_shape=make_element_shape(vertices=3, dim=2, degree=2, & - &quad= tri_quadrature) + quad_shape=make_element_shape(vertices=4, dim=2, degree=1, & + &quad= quad_quadrature) + tri_shape=make_element_shape(vertices=3, dim=2, degree=2, & + &quad= tri_quadrature) - !This unit test is based on the fact that the Q1 space on a single - !quadrilateral can be represented exactly by the P2 space on the same - !quadrilateral subdivided into two quadratically-mapped triangles. The - !dividing line between the triangles is quadratic and passes through the - !mean of the four vertices. + !This unit test is based on the fact that the Q1 space on a single + !quadrilateral can be represented exactly by the P2 space on the same + !quadrilateral subdivided into two quadratically-mapped triangles. The + !dividing line between the triangles is quadratic and passes through the + !mean of the four vertices. - ! create single quad mesh - ! numbering: 3 4 - ! 1 2 - call allocate(quad_mesh, 4, 1, quad_shape, "OneElementMesh") - call set_ele_nodes(quad_mesh, 1, (/1,2,3,4/)) + ! create single quad mesh + ! numbering: 3 4 + ! 1 2 + call allocate(quad_mesh, 4, 1, quad_shape, "OneElementMesh") + call set_ele_nodes(quad_mesh, 1, (/1,2,3,4/)) - ! and 2D positions field on it - call allocate(quad_X, 2, quad_mesh, "Coordinate") - call set(quad_X, 1, (/0.0, 0.0/)) - call set(quad_X, 2, (/1.0, 0.0/)) - call set(quad_X, 3, (/0.2, 1.2/)) - call set(quad_X, 4, (/1.3, 1.5/)) + ! and 2D positions field on it + call allocate(quad_X, 2, quad_mesh, "Coordinate") + call set(quad_X, 1, (/0.0, 0.0/)) + call set(quad_X, 2, (/1.0, 0.0/)) + call set(quad_X, 3, (/0.2, 1.2/)) + call set(quad_X, 4, (/1.3, 1.5/)) - !compute the mass matrix using quadrilateral quadrature - call compute_jacobian(quad_X, 1, J=J_quad,detwei=detwei_quad) - quad_mass = shape_shape(quad_shape,quad_shape,detwei_quad) + !compute the mass matrix using quadrilateral quadrature + call compute_jacobian(quad_X, 1, J=J_quad,detwei=detwei_quad) + quad_mass = shape_shape(quad_shape,quad_shape,detwei_quad) - ! create 2 P2 triangles mesh - !numbering: 6 5 3 3 4 - ! 4 2 8 - ! 1 7 9 1 2 - call allocate(tri_mesh, 9, 2, tri_shape, "TwoElementMesh") - call set_ele_nodes(tri_mesh, 1, (/ 1,2,3,4,5,6 /)) - call set_ele_nodes(tri_mesh, 2, (/ 3,2,1,8,7,9 /)) + ! create 2 P2 triangles mesh + !numbering: 6 5 3 3 4 + ! 4 2 8 + ! 1 7 9 1 2 + call allocate(tri_mesh, 9, 2, tri_shape, "TwoElementMesh") + call set_ele_nodes(tri_mesh, 1, (/ 1,2,3,4,5,6 /)) + call set_ele_nodes(tri_mesh, 2, (/ 3,2,1,8,7,9 /)) - ! and 2D positions field on it - call allocate(tri_X, 2, tri_mesh, "Coordinate") - call set(tri_X, 1, node_val(quad_X, 1)) - call set(tri_X, 2, sum(quad_X%val, 2)/4.0) - call set(tri_X, 3, node_val(quad_X, 4)) - call set(tri_X, 4, (node_val(quad_X, 1)+node_val(quad_X,3))/2.0) - call set(tri_X, 5, (node_val(quad_X, 3)+node_val(quad_X,4))/2.0) - call set(tri_X, 6, node_val(quad_X, 3)) - call set(tri_X, 7, (node_val(quad_X, 1)+node_val(quad_X,2))/2.0) - call set(tri_X, 8, (node_val(quad_X, 2)+node_val(quad_X,4))/2.0) - call set(tri_X, 9, node_val(quad_X, 2)) + ! and 2D positions field on it + call allocate(tri_X, 2, tri_mesh, "Coordinate") + call set(tri_X, 1, node_val(quad_X, 1)) + call set(tri_X, 2, sum(quad_X%val, 2)/4.0) + call set(tri_X, 3, node_val(quad_X, 4)) + call set(tri_X, 4, (node_val(quad_X, 1)+node_val(quad_X,3))/2.0) + call set(tri_X, 5, (node_val(quad_X, 3)+node_val(quad_X,4))/2.0) + call set(tri_X, 6, node_val(quad_X, 3)) + call set(tri_X, 7, (node_val(quad_X, 1)+node_val(quad_X,2))/2.0) + call set(tri_X, 8, (node_val(quad_X, 2)+node_val(quad_X,4))/2.0) + call set(tri_X, 9, node_val(quad_X, 2)) - !compute the mass matrix using triangular quadrature - call compute_jacobian(tri_X, 1, J=J_tri,detwei=detwei_tri) - l_tri_mass = shape_shape(tri_shape,tri_shape,detwei_tri) - !local2global(i,:) gives coefficients of expansion of Q1 basis function i - !into P2 basis functions in this triangle - local2global(1,:) = (/1.,0.25,0.,0.5,0.,0./) - local2global(2,:) = (/0.,0.25,0.,0.,0.,0./) - local2global(3,:) = (/0.,0.25,0.,0.5,0.5,1./) - local2global(4,:) = (/0.,0.25,1.,0.,0.5,0./) - global_tri_mass = matmul(local2global,matmul(l_tri_mass,transpose(local2global))) + !compute the mass matrix using triangular quadrature + call compute_jacobian(tri_X, 1, J=J_tri,detwei=detwei_tri) + l_tri_mass = shape_shape(tri_shape,tri_shape,detwei_tri) + !local2global(i,:) gives coefficients of expansion of Q1 basis function i + !into P2 basis functions in this triangle + local2global(1,:) = (/1.,0.25,0.,0.5,0.,0./) + local2global(2,:) = (/0.,0.25,0.,0.,0.,0./) + local2global(3,:) = (/0.,0.25,0.,0.5,0.5,1./) + local2global(4,:) = (/0.,0.25,1.,0.,0.5,0./) + global_tri_mass = matmul(local2global,matmul(l_tri_mass,transpose(local2global))) - call compute_jacobian(tri_X, 2, J=J_tri,detwei=detwei_tri) - l_tri_mass = shape_shape(tri_shape,tri_shape,detwei_tri) - !local2global(i,:) gives coefficients of expansion of Q1 basis function i - !into P2 basis functions in this triangle - local2global(1,:) = (/0.,0.25,1.,0.,0.5,0./) - local2global(2,:) = (/0.,0.25,0.,0.5,0.5,1./) - local2global(3,:) = (/0.,0.25,0.,0.,0.,0./) - local2global(4,:) = (/1.,0.25,0.,0.5,0.,0./) - global_tri_mass = global_tri_mass + & - matmul(local2global,matmul(l_tri_mass,transpose(local2global))) + call compute_jacobian(tri_X, 2, J=J_tri,detwei=detwei_tri) + l_tri_mass = shape_shape(tri_shape,tri_shape,detwei_tri) + !local2global(i,:) gives coefficients of expansion of Q1 basis function i + !into P2 basis functions in this triangle + local2global(1,:) = (/0.,0.25,1.,0.,0.5,0./) + local2global(2,:) = (/0.,0.25,0.,0.5,0.5,1./) + local2global(3,:) = (/0.,0.25,0.,0.,0.,0./) + local2global(4,:) = (/1.,0.25,0.,0.5,0.,0./) + global_tri_mass = global_tri_mass + & + matmul(local2global,matmul(l_tri_mass,transpose(local2global))) - fail = any(abs(quad_mass - global_tri_mass) > 1e-12) - call report_test("[quad_quadrature]", fail, .false., "matrices not the same") + fail = any(abs(quad_mass - global_tri_mass) > 1e-12) + call report_test("[quad_quadrature]", fail, .false., "matrices not the same") end subroutine test_quad_quadrature diff --git a/femtools/tests/test_quad_supermesh.F90 b/femtools/tests/test_quad_supermesh.F90 index 2b2bb54523..65fce4cfe7 100644 --- a/femtools/tests/test_quad_supermesh.F90 +++ b/femtools/tests/test_quad_supermesh.F90 @@ -3,94 +3,94 @@ subroutine test_quad_supermesh - use fldebug - use unittest_tools - use mesh_files - use quadrature - use fields - use linked_lists - use intersection_finder_module - use transform_elements - use elements - use supermesh_construction - use vtk_interfaces + use fldebug + use unittest_tools + use mesh_files + use quadrature + use fields + use linked_lists + use intersection_finder_module + use transform_elements + use elements + use supermesh_construction + use vtk_interfaces - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(:), allocatable :: map_BA - real, dimension(:), allocatable :: quad_detwei, tri_detwei - integer :: ele_A, ele_B, ele_C - real :: vol_B, vols_C, total_B, total_C - logical :: fail, empty_intersection - type(element_type), pointer :: shape - type(inode), pointer :: llnode - type(vector_field) :: intersection - type(element_type) :: supermesh_shape - type(quadrature_type) :: supermesh_quad - integer :: dim - integer :: dump_idx + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(:), allocatable :: map_BA + real, dimension(:), allocatable :: quad_detwei, tri_detwei + integer :: ele_A, ele_B, ele_C + real :: vol_B, vols_C, total_B, total_C + logical :: fail, empty_intersection + type(element_type), pointer :: shape + type(inode), pointer :: llnode + type(vector_field) :: intersection + type(element_type) :: supermesh_shape + type(quadrature_type) :: supermesh_quad + integer :: dim + integer :: dump_idx - positionsA = read_mesh_files("data/dg_interpolation_quads_A", quad_degree=1, format="gmsh") - positionsB = read_mesh_files("data/dg_interpolation_quads_B", quad_degree=1, format="gmsh") + positionsA = read_mesh_files("data/dg_interpolation_quads_A", quad_degree=1, format="gmsh") + positionsB = read_mesh_files("data/dg_interpolation_quads_B", quad_degree=1, format="gmsh") - dim = positionsA%dim + dim = positionsA%dim - allocate(map_BA(ele_count(positionsB))) - allocate(quad_detwei(ele_ngi(positionsA, 1))) - shape => ele_shape(positionsA, 1) - assert(sum(shape%quadrature%weight) == 4) + allocate(map_BA(ele_count(positionsB))) + allocate(quad_detwei(ele_ngi(positionsA, 1))) + shape => ele_shape(positionsA, 1) + assert(sum(shape%quadrature%weight) == 4) - supermesh_quad = make_quadrature(vertices = dim+1, dim =dim, degree=5) - supermesh_shape = make_element_shape(vertices = dim+1, dim =dim, degree=1, quad=supermesh_quad) - allocate(tri_detwei(supermesh_shape%ngi)) + supermesh_quad = make_quadrature(vertices = dim+1, dim =dim, degree=5) + supermesh_shape = make_element_shape(vertices = dim+1, dim =dim, degree=1, quad=supermesh_quad) + allocate(tri_detwei(supermesh_shape%ngi)) - dump_idx = 0 - total_B = 0.0 - total_C = 0.0 + dump_idx = 0 + total_B = 0.0 + total_C = 0.0 - map_BA = intersection_finder(positionsB, positionsA) - call intersector_set_dimension(dim) + map_BA = intersection_finder(positionsB, positionsA) + call intersector_set_dimension(dim) - do ele_B=1,ele_count(positionsB) - call transform_to_physical(positionsB, ele_B, detwei=quad_detwei) - vol_B = sum(quad_detwei) + do ele_B=1,ele_count(positionsB) + call transform_to_physical(positionsB, ele_B, detwei=quad_detwei) + vol_B = sum(quad_detwei) - llnode => map_BA(ele_B)%firstnode - vols_C = 0.0 - do while(associated(llnode)) - ele_A = llnode%value - intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), supermesh_shape, empty_intersection=empty_intersection) - if (empty_intersection) then - llnode => llnode%next - cycle - end if + llnode => map_BA(ele_B)%firstnode + vols_C = 0.0 + do while(associated(llnode)) + ele_A = llnode%value + intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), supermesh_shape, empty_intersection=empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if #define DUMP_SUPERMESH_INTERSECTIONS #ifdef DUMP_SUPERMESH_INTERSECTIONS - if (ele_count(intersection) /= 0) then - call vtk_write_fields("intersection", dump_idx, intersection, intersection%mesh) - dump_idx = dump_idx + 1 - end if + if (ele_count(intersection) /= 0) then + call vtk_write_fields("intersection", dump_idx, intersection, intersection%mesh) + dump_idx = dump_idx + 1 + end if #endif - do ele_C=1,ele_count(intersection) - call transform_to_physical(intersection, ele_C, detwei=tri_detwei) - vols_C = vols_C + sum(tri_detwei) + do ele_C=1,ele_count(intersection) + call transform_to_physical(intersection, ele_C, detwei=tri_detwei) + vols_C = vols_C + sum(tri_detwei) + end do + llnode => llnode%next end do - llnode => llnode%next - end do - total_B = total_B + vol_B - total_C = total_C + vols_C - fail = (vol_B .fne. vols_C) - !call report_test("[quad supermesh: completeness]", fail, .false., "Need to have the same volume!") - if (fail) then - write(0,*) "ele_B: ", ele_B - write(0,*) "vol_B: ", vol_B - write(0,*) "vols_C: ", vols_C - end if - end do + total_B = total_B + vol_B + total_C = total_C + vols_C + fail = (vol_B .fne. vols_C) + !call report_test("[quad supermesh: completeness]", fail, .false., "Need to have the same volume!") + if (fail) then + write(0,*) "ele_B: ", ele_B + write(0,*) "vol_B: ", vol_B + write(0,*) "vols_C: ", vols_C + end if + end do - fail = total_B .fne. total_C - call report_test("[quad supermesh: completeness]", fail, .false., "Need to have the same volume!") - !write(0,*) "total_B: ", total_B - !write(0,*) "total_C: ", total_C + fail = total_B .fne. total_C + call report_test("[quad supermesh: completeness]", fail, .false., "Need to have the same volume!") + !write(0,*) "total_B: ", total_B + !write(0,*) "total_C: ", total_C end subroutine test_quad_supermesh diff --git a/femtools/tests/test_quadrature.F90 b/femtools/tests/test_quadrature.F90 index 1570529957..2c0c40cabd 100644 --- a/femtools/tests/test_quadrature.F90 +++ b/femtools/tests/test_quadrature.F90 @@ -27,154 +27,154 @@ #include "fdebug.h" subroutine test_quadrature - use FLDebug - use quadrature - use quadrature_test - use unittest_tools + use FLDebug + use quadrature + use quadrature_test + use unittest_tools - type(quadrature_type) :: quad - type(quadrature_template), dimension(:), pointer :: template + type(quadrature_type) :: quad + type(quadrature_template), dimension(:), pointer :: template - integer :: dim, vertices, degree, stat, i + integer :: dim, vertices, degree, stat, i - character(len=254) :: test_message, error_message - logical :: fail + character(len=254) :: test_message, error_message + logical :: fail - call construct_quadrature_templates + call construct_quadrature_templates - ! Test for simplices. - do dim=1,3 + ! Test for simplices. + do dim=1,3 - vertices=dim+1 - degree=0 + vertices=dim+1 + degree=0 - degreeloop:do - degree=degree+1 + degreeloop:do + degree=degree+1 - quad=make_quadrature(vertices, dim, degree=degree, stat=stat) + quad=make_quadrature(vertices, dim, degree=degree, stat=stat) - select case (stat) - case (QUADRATURE_DEGREE_ERROR) - ! Reached highest available degree. - exit degreeloop - case (0) - ! Success - continue - case default - ! Some other error - FLAbort(quadrature_error_message) - end select + select case (stat) + case (QUADRATURE_DEGREE_ERROR) + ! Reached highest available degree. + exit degreeloop + case (0) + ! Success + continue + case default + ! Some other error + FLAbort(quadrature_error_message) + end select - ! Skip any degrees which don't exist. - degree=quad%degree + ! Skip any degrees which don't exist. + degree=quad%degree - do power=0,degree + do power=0,degree - if(quad_integrate(monic, quad) .fne. simplex_answer()) then - write(error_message,'(e15.7)') & - quad_integrate(monic, quad)-simplex_answer() - fail=.true. - else - error_message="" - fail=.false. - end if + if(quad_integrate(monic, quad) .fne. simplex_answer()) then + write(error_message,'(e15.7)') & + quad_integrate(monic, quad)-simplex_answer() + fail=.true. + else + error_message="" + fail=.false. + end if - write(test_message, '(3(a,i0),a)') "[",dim,"-simplex, qua& - &d degree ",degree," power ",power," ]" + write(test_message, '(3(a,i0),a)') "[",dim,"-simplex, qua& + &d degree ",degree," power ",power," ]" - call report_test(trim(test_message), fail, .false.,& - & trim(error_message)) + call report_test(trim(test_message), fail, .false.,& + & trim(error_message)) - end do + end do - call deallocate(quad) + call deallocate(quad) - end do degreeloop + end do degreeloop - end do + end do - ! Test for hypercubes - do dim=2,3 + ! Test for hypercubes + do dim=2,3 - vertices=2**dim + vertices=2**dim - select case(dim) - case(2) - template=>quad_quads - case(3) - template=>hex_quads - end select + select case(dim) + case(2) + template=>quad_quads + case(3) + template=>hex_quads + end select - quadloop: do i=1,size(template) - degree=template(i)%degree + quadloop: do i=1,size(template) + degree=template(i)%degree - quad=make_quadrature(vertices, dim, degree=degree, stat=stat) + quad=make_quadrature(vertices, dim, degree=degree, stat=stat) - select case (stat) - case (0) - ! Success - continue - case default - ! Some other error - FLAbort(quadrature_error_message) - end select + select case (stat) + case (0) + ! Success + continue + case default + ! Some other error + FLAbort(quadrature_error_message) + end select - do power=0,degree + do power=0,degree - if(quad_integrate(cube_monic, quad) .fne. cube_answer()) then - write(error_message,'(e15.7)') & - quad_integrate(cube_monic, quad)-cube_answer() - fail=.true. - else - error_message="" - fail=.false. - end if + if(quad_integrate(cube_monic, quad) .fne. cube_answer()) then + write(error_message,'(e15.7)') & + quad_integrate(cube_monic, quad)-cube_answer() + fail=.true. + else + error_message="" + fail=.false. + end if - write(test_message, '(4(a,i0),a)') "[",dim,"-cube, qua& - &d number ",i," degree ",degree," power ",power," ]" + write(test_message, '(4(a,i0),a)') "[",dim,"-cube, qua& + &d number ",i," degree ",degree," power ",power," ]" - call report_test(trim(test_message), fail, .false.,& - & trim(error_message)) + call report_test(trim(test_message), fail, .false.,& + & trim(error_message)) - end do + end do - call deallocate(quad) + call deallocate(quad) - end do quadloop + end do quadloop - end do + end do contains - recursive function factorial(n) result(f) - ! Calculate n! - integer :: f - integer, intent(in) :: n + recursive function factorial(n) result(f) + ! Calculate n! + integer :: f + integer, intent(in) :: n - if (n==0) then - f=1 - else - f=n*factorial(n-1) - end if + if (n==0) then + f=1 + else + f=n*factorial(n-1) + end if - end function factorial + end function factorial - function simplex_answer() - ! Analytic solution to integrating monic over a simplex. - ! This formula is eq. 7.38 and 7.48 in Zienkiewicz and Taylor - real :: simplex_answer + function simplex_answer() + ! Analytic solution to integrating monic over a simplex. + ! This formula is eq. 7.38 and 7.48 in Zienkiewicz and Taylor + real :: simplex_answer - simplex_answer=real(factorial(power))& + simplex_answer=real(factorial(power))& /factorial(power+dim) - end function simplex_answer + end function simplex_answer - function cube_answer() - ! Analytic solution to integrating ((1-x)/2)**power over a hypercube. - real :: cube_answer + function cube_answer() + ! Analytic solution to integrating ((1-x)/2)**power over a hypercube. + real :: cube_answer - cube_answer=(2.0**dim)/(power+1) + cube_answer=(2.0**dim)/(power+1) - end function cube_answer + end function cube_answer end subroutine test_quadrature diff --git a/femtools/tests/test_random_posdef_matrix.F90 b/femtools/tests/test_random_posdef_matrix.F90 index 2252c22928..a4f0df23d0 100644 --- a/femtools/tests/test_random_posdef_matrix.F90 +++ b/femtools/tests/test_random_posdef_matrix.F90 @@ -1,32 +1,32 @@ subroutine test_random_posdef_matrix - use unittest_tools - use vector_tools - implicit none + use unittest_tools + use vector_tools + implicit none - real, dimension(3, 3) :: mat, evecs - real, dimension(3) :: evals - integer :: i, j, dim = 3 - logical :: fail, warn - character(len=20) :: buf + real, dimension(3, 3) :: mat, evecs + real, dimension(3) :: evals + integer :: i, j, dim = 3 + logical :: fail, warn + character(len=20) :: buf - do i=1,5 + do i=1,5 - fail = .false. - warn = .false. + fail = .false. + warn = .false. - mat = random_posdef_matrix(dim) - call eigendecomposition_symmetric(mat, evecs, evals) - do j=1,dim - if (evals(j) .flt. 0.0) then - print *, "i == ", i, "; j == ", j, "; evals(j) == ", evals(j) - fail = .true. - end if - end do + mat = random_posdef_matrix(dim) + call eigendecomposition_symmetric(mat, evecs, evals) + do j=1,dim + if (evals(j) .flt. 0.0) then + print *, "i == ", i, "; j == ", j, "; evals(j) == ", evals(j) + fail = .true. + end if + end do - write(buf,'(i0)') i - call report_test("[positive definite matrix " // trim(buf) // "]", fail, warn, & - "Positive definite matrices have positive eigenvalues.") - end do + write(buf,'(i0)') i + call report_test("[positive definite matrix " // trim(buf) // "]", fail, warn, & + "Positive definite matrices have positive eigenvalues.") + end do end subroutine test_random_posdef_matrix diff --git a/femtools/tests/test_real_from_python.F90 b/femtools/tests/test_real_from_python.F90 index 00a4e16d81..922ac35b66 100644 --- a/femtools/tests/test_real_from_python.F90 +++ b/femtools/tests/test_real_from_python.F90 @@ -29,24 +29,24 @@ subroutine test_real_from_python - use embed_python - use fldebug - use unittest_tools + use embed_python + use fldebug + use unittest_tools - implicit none + implicit none - character(len = *), parameter :: func = & - & "def val(t):" // new_line("") // & - & " return t" - integer :: stat - real :: result + character(len = *), parameter :: func = & + & "def val(t):" // new_line("") // & + & " return t" + integer :: stat + real :: result - call real_from_python(func, 0.1, result, stat = stat) - call report_test("[real_from_python]", stat /= 0, .false., "real_from_python returned an error") - call report_test("[Expected result]", result .fne. 0.1, .false., "real_from_python returned incorrect real") + call real_from_python(func, 0.1, result, stat = stat) + call report_test("[real_from_python]", stat /= 0, .false., "real_from_python returned an error") + call report_test("[Expected result]", result .fne. 0.1, .false., "real_from_python returned incorrect real") - call real_from_python(func, 1.1, result, stat = stat) - call report_test("[real_from_python]", stat /= 0, .false., "real_from_python returned an error") - call report_test("[Expected result]", result .fne. 1.1, .false., "real_from_python returned incorrect real") + call real_from_python(func, 1.1, result, stat = stat) + call report_test("[real_from_python]", stat /= 0, .false., "real_from_python returned an error") + call report_test("[Expected result]", result .fne. 1.1, .false., "real_from_python returned incorrect real") end subroutine test_real_from_python diff --git a/femtools/tests/test_remap_coordinate.F90 b/femtools/tests/test_remap_coordinate.F90 index 6161003ad8..87aff97b50 100644 --- a/femtools/tests/test_remap_coordinate.F90 +++ b/femtools/tests/test_remap_coordinate.F90 @@ -1,63 +1,63 @@ subroutine test_remap_coordinate - use elements - use fields - use fields_data_types - use reference_counting - use state_module - use unittest_tools - use fefields - - implicit none - - type(quadrature_type) :: quad - type(element_type) :: baseshape, toshape - type(mesh_type) :: basemesh, tomesh - type(vector_field) :: basex, tox - - integer :: i, j, dim, vertices - - dim = 2 - vertices = 3 - - ! Make a P1 single triangle mesh - quad = make_quadrature(vertices = vertices, dim = dim, degree = 1) - baseshape = make_element_shape(vertices = vertices, dim = dim, degree = 1, quad = quad) - toshape = make_element_shape(vertices = vertices, dim = dim, degree = 0, quad = quad) - call allocate(basemesh, nodes = baseshape%loc, elements = 1, shape = baseshape, name = "BaseMesh") - call allocate(tomesh, nodes = toshape%loc, elements = 1, shape = toshape, name = "ToMesh") - call allocate(basex, mesh_dim(basemesh), basemesh, "BaseCoordinate") - call allocate(tox, mesh_dim(tomesh), tomesh, "ToCoordinate") - - do i = 1, size(basemesh%ndglno) - basemesh%ndglno(i) = i - end do - - do i = 1, size(tomesh%ndglno) - tomesh%ndglno(i) = i - end do - - call set(basex, 1, (/0.0, 0.0/)) - call set(basex, 2, (/1.0, 0.0/)) - call set(basex, 3, (/0.0, 1.0/)) + use elements + use fields + use fields_data_types + use reference_counting + use state_module + use unittest_tools + use fefields + + implicit none + + type(quadrature_type) :: quad + type(element_type) :: baseshape, toshape + type(mesh_type) :: basemesh, tomesh + type(vector_field) :: basex, tox + + integer :: i, j, dim, vertices + + dim = 2 + vertices = 3 + + ! Make a P1 single triangle mesh + quad = make_quadrature(vertices = vertices, dim = dim, degree = 1) + baseshape = make_element_shape(vertices = vertices, dim = dim, degree = 1, quad = quad) + toshape = make_element_shape(vertices = vertices, dim = dim, degree = 0, quad = quad) + call allocate(basemesh, nodes = baseshape%loc, elements = 1, shape = baseshape, name = "BaseMesh") + call allocate(tomesh, nodes = toshape%loc, elements = 1, shape = toshape, name = "ToMesh") + call allocate(basex, mesh_dim(basemesh), basemesh, "BaseCoordinate") + call allocate(tox, mesh_dim(tomesh), tomesh, "ToCoordinate") + + do i = 1, size(basemesh%ndglno) + basemesh%ndglno(i) = i + end do + + do i = 1, size(tomesh%ndglno) + tomesh%ndglno(i) = i + end do + + call set(basex, 1, (/0.0, 0.0/)) + call set(basex, 2, (/1.0, 0.0/)) + call set(basex, 3, (/0.0, 1.0/)) ! call set(basex, 3, (/0.5, sqrt(3.0)/2.0/)) - do i = 1, node_count(basex) - write(0,*) 'i = ', i - do j = 1, mesh_dim(basex) - write(0,*) 'dim = ', j - write(0,*) node_val(basex, i, j) - end do - end do - - call remap_field(from_field=basex, to_field=tox) - - do i = 1, node_count(tox) - write(0,*) 'i = ', i - do j = 1, mesh_dim(tox) - write(0,*) 'dim = ', j - write(0,*) node_val(tox, i, j) - end do - end do + do i = 1, node_count(basex) + write(0,*) 'i = ', i + do j = 1, mesh_dim(basex) + write(0,*) 'dim = ', j + write(0,*) node_val(basex, i, j) + end do + end do + + call remap_field(from_field=basex, to_field=tox) + + do i = 1, node_count(tox) + write(0,*) 'i = ', i + do j = 1, mesh_dim(tox) + write(0,*) 'dim = ', j + write(0,*) node_val(tox, i, j) + end do + end do end subroutine test_remap_coordinate diff --git a/femtools/tests/test_remove_scalar_field.F90 b/femtools/tests/test_remove_scalar_field.F90 index e77b7abb65..22f5ade780 100644 --- a/femtools/tests/test_remove_scalar_field.F90 +++ b/femtools/tests/test_remove_scalar_field.F90 @@ -1,28 +1,28 @@ subroutine test_remove_scalar_field - use vtk_interfaces - use state_module - use unittest_tools - use fields - implicit none + use vtk_interfaces + use state_module + use unittest_tools + use fields + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(scalar_field) :: t_field - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(scalar_field) :: t_field + logical :: fail - call vtk_read_state("data/mesh_0.vtu", state) - mesh => extract_mesh(state, "Mesh") - call allocate(t_field, mesh, "ScalarField") + call vtk_read_state("data/mesh_0.vtu", state) + mesh => extract_mesh(state, "Mesh") + call allocate(t_field, mesh, "ScalarField") - call insert(state, t_field, "ScalarField") + call insert(state, t_field, "ScalarField") - fail = .not. has_scalar_field(state, "ScalarField") - call report_test("[remove_scalar_field]", fail, .false., "") + fail = .not. has_scalar_field(state, "ScalarField") + call report_test("[remove_scalar_field]", fail, .false., "") - call remove_scalar_field(state, "ScalarField") - fail = has_scalar_field(state, "ScalarField") - call report_test("[remove_scalar_field]", fail, .false., "") + call remove_scalar_field(state, "ScalarField") + fail = has_scalar_field(state, "ScalarField") + call report_test("[remove_scalar_field]", fail, .false., "") - call deallocate(state) + call deallocate(state) end subroutine test_remove_scalar_field diff --git a/femtools/tests/test_remove_tensor_field.F90 b/femtools/tests/test_remove_tensor_field.F90 index 199468d770..96898797f5 100644 --- a/femtools/tests/test_remove_tensor_field.F90 +++ b/femtools/tests/test_remove_tensor_field.F90 @@ -1,28 +1,28 @@ subroutine test_remove_tensor_field - use vtk_interfaces - use state_module - use unittest_tools - use fields - implicit none + use vtk_interfaces + use state_module + use unittest_tools + use fields + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(tensor_field) :: t_field - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(tensor_field) :: t_field + logical :: fail - call vtk_read_state("data/mesh_0.vtu", state) - mesh => extract_mesh(state, "Mesh") - call allocate(t_field, mesh, "TensorField") + call vtk_read_state("data/mesh_0.vtu", state) + mesh => extract_mesh(state, "Mesh") + call allocate(t_field, mesh, "TensorField") - call insert(state, t_field, "TensorField") + call insert(state, t_field, "TensorField") - fail = .not. has_tensor_field(state, "TensorField") - call report_test("[remove_tensor_field]", fail, .false., "") + fail = .not. has_tensor_field(state, "TensorField") + call report_test("[remove_tensor_field]", fail, .false., "") - call remove_tensor_field(state, "TensorField") - fail = has_tensor_field(state, "TensorField") - call report_test("[remove_tensor_field]", fail, .false., "") + call remove_tensor_field(state, "TensorField") + fail = has_tensor_field(state, "TensorField") + call report_test("[remove_tensor_field]", fail, .false., "") - call deallocate(state) + call deallocate(state) end subroutine test_remove_tensor_field diff --git a/femtools/tests/test_remove_vector_field.F90 b/femtools/tests/test_remove_vector_field.F90 index e263097e46..df45fa7218 100644 --- a/femtools/tests/test_remove_vector_field.F90 +++ b/femtools/tests/test_remove_vector_field.F90 @@ -1,28 +1,28 @@ subroutine test_remove_vector_field - use vtk_interfaces - use state_module - use unittest_tools - use fields - implicit none + use vtk_interfaces + use state_module + use unittest_tools + use fields + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field) :: t_field - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field) :: t_field + logical :: fail - call vtk_read_state("data/mesh_0.vtu", state) - mesh => extract_mesh(state, "Mesh") - call allocate(t_field, 3, mesh, "VectorField") + call vtk_read_state("data/mesh_0.vtu", state) + mesh => extract_mesh(state, "Mesh") + call allocate(t_field, 3, mesh, "VectorField") - call insert(state, t_field, "VectorField") + call insert(state, t_field, "VectorField") - fail = .not. has_vector_field(state, "VectorField") - call report_test("[remove_vector_field]", fail, .false., "") + fail = .not. has_vector_field(state, "VectorField") + call report_test("[remove_vector_field]", fail, .false., "") - call remove_vector_field(state, "VectorField") - fail = has_vector_field(state, "VectorField") - call report_test("[remove_vector_field]", fail, .false., "") + call remove_vector_field(state, "VectorField") + fail = has_vector_field(state, "VectorField") + call report_test("[remove_vector_field]", fail, .false., "") - call deallocate(state) + call deallocate(state) end subroutine test_remove_vector_field diff --git a/femtools/tests/test_scalar_field_view.F90 b/femtools/tests/test_scalar_field_view.F90 index 702852bb4a..b5807d2638 100644 --- a/femtools/tests/test_scalar_field_view.F90 +++ b/femtools/tests/test_scalar_field_view.F90 @@ -1,25 +1,25 @@ subroutine test_scalar_field_view - use fields - use state_module - use vtk_interfaces - use unittest_tools - implicit none + use fields + use state_module + use vtk_interfaces + use unittest_tools + implicit none - type(state_type) :: state - type(scalar_field), pointer :: x - integer :: stat - logical :: allocated - logical :: fail + type(state_type) :: state + type(scalar_field), pointer :: x + integer :: stat + logical :: allocated + logical :: fail - call vtk_read_state("data/pseudo2d.vtu", state) - x => extract_scalar_field(state, "Coordinatz%1", stat=stat, allocated=allocated) ! should fail - fail = (stat == 0 .or. allocated) - call report_test("[scalar field view]", fail, .false., "Searching for a component of a nonexistant field is a problem.") - x => extract_scalar_field(state, "Coordinate%10", stat=stat, allocated=allocated) ! should fail - fail = (stat == 0 .or. allocated) - call report_test("[scalar field view]", fail, .false., "Searching for a nonexistant component of a field is a problem.") - x => extract_scalar_field(state, "Coordinate%1", stat=stat, allocated=allocated) ! should work - fail = (stat /= 0 .or. (allocated .eqv. .false.) .or. (.not. associated(x))) - call report_test("[scalar field view]", fail, .false., "Searching for a component of a field should work.") + call vtk_read_state("data/pseudo2d.vtu", state) + x => extract_scalar_field(state, "Coordinatz%1", stat=stat, allocated=allocated) ! should fail + fail = (stat == 0 .or. allocated) + call report_test("[scalar field view]", fail, .false., "Searching for a component of a nonexistant field is a problem.") + x => extract_scalar_field(state, "Coordinate%10", stat=stat, allocated=allocated) ! should fail + fail = (stat == 0 .or. allocated) + call report_test("[scalar field view]", fail, .false., "Searching for a nonexistant component of a field is a problem.") + x => extract_scalar_field(state, "Coordinate%1", stat=stat, allocated=allocated) ! should work + fail = (stat /= 0 .or. (allocated .eqv. .false.) .or. (.not. associated(x))) + call report_test("[scalar field view]", fail, .false., "Searching for a component of a field should work.") end subroutine test_scalar_field_view diff --git a/femtools/tests/test_seamount_hessian.F90 b/femtools/tests/test_seamount_hessian.F90 index ce6cb70703..dacafec089 100644 --- a/femtools/tests/test_seamount_hessian.F90 +++ b/femtools/tests/test_seamount_hessian.F90 @@ -1,31 +1,31 @@ subroutine test_seamount_hessian - use vtk_interfaces - use field_derivatives - use unittest_tools - use state_module - implicit none + use vtk_interfaces + use field_derivatives + use unittest_tools + use state_module + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: position_field - type(scalar_field), pointer :: temp - type(tensor_field) :: hessian - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: position_field + type(scalar_field), pointer :: temp + type(tensor_field) :: hessian + logical :: fail - call vtk_read_state("data/seamount.vtu", state) - mesh => extract_mesh(state, "Mesh") - position_field => extract_vector_field(state, "Coordinate") - temp => extract_scalar_field(state, "Temperature") - call allocate(hessian, mesh, "Hessian") + call vtk_read_state("data/seamount.vtu", state) + mesh => extract_mesh(state, "Mesh") + position_field => extract_vector_field(state, "Coordinate") + temp => extract_scalar_field(state, "Temperature") + call allocate(hessian, mesh, "Hessian") - call compute_hessian(temp, position_field, hessian) - call vtk_write_fields("data/seamount_hessian", 0, position_field, mesh, sfields=(/temp/), tfields=(/hessian/)) + call compute_hessian(temp, position_field, hessian) + call vtk_write_fields("data/seamount_hessian", 0, position_field, mesh, sfields=(/temp/), tfields=(/hessian/)) - fail = .false. - call report_test("[seamount hessian]", fail, .false., "The hessian of x^2 is not what it should be!") + fail = .false. + call report_test("[seamount hessian]", fail, .false., "The hessian of x^2 is not what it should be!") - call deallocate(hessian) - call deallocate(state) + call deallocate(hessian) + call deallocate(state) end subroutine test_seamount_hessian diff --git a/femtools/tests/test_shape_functions.F90 b/femtools/tests/test_shape_functions.F90 index 44299834a8..114ed814a4 100644 --- a/femtools/tests/test_shape_functions.F90 +++ b/femtools/tests/test_shape_functions.F90 @@ -26,193 +26,193 @@ ! USA subroutine test_shape_functions - !!< Generic element test function. - use quadrature - use shape_functions_test - use unittest_tools - type(element_type) :: element - type(quadrature_type) :: quad + !!< Generic element test function. + use quadrature + use shape_functions_test + use unittest_tools + type(element_type) :: element + type(quadrature_type) :: quad - character(len=500) :: error_message, test_message - integer :: dim, degree, vertices - logical :: fail + character(len=500) :: error_message, test_message + integer :: dim, degree, vertices + logical :: fail - ! Rounding error tolerance. - real, parameter :: eps=1E-12 + ! Rounding error tolerance. + real, parameter :: eps=1E-12 - ! Test for simplices. - do dim=1,3 + ! Test for simplices. + do dim=1,3 - vertices=dim+1 + vertices=dim+1 - quad=make_quadrature(vertices, dim, degree=7) + quad=make_quadrature(vertices, dim, degree=7) - do degree=0,7 + do degree=0,7 - element=make_element_shape(vertices=vertices, dim=dim, degree=degree,& - quad=quad) + element=make_element_shape(vertices=vertices, dim=dim, degree=degree,& + quad=quad) - do power=0,degree + do power=0,degree - ! Shape function itself - if (.not.(abs(shape_integrate(monic, element)& - -simplex_answer(power, dim)) extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + !Extract the vector fields of position in vtu file in polar coordinates and + ! cartesian coordiantes + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Apply transformation to spherical-polar components and compare with components of - ! cartesian position-vector. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - call spherical_polar_2_cartesian(RTP(1), RTP(2), RTP(3), XYZ(1), XYZ(2), XYZ(3)) - call set(difference, node, XYZ) - enddo - call addto(difference, CartesianCoordinate, -1.0) + !Apply transformation to spherical-polar components and compare with components of + ! cartesian position-vector. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + call spherical_polar_2_cartesian(RTP(1), RTP(2), RTP(3), XYZ(1), XYZ(2), XYZ(3)) + call set(difference, node, XYZ) + enddo + call addto(difference, CartesianCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: Spherical-polar to Cartesian.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: Spherical-polar to Cartesian.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_spherical_polar_2_cartesian_c.F90 b/femtools/tests/test_spherical_polar_2_cartesian_c.F90 index a7a55dca4c..f90e616e35 100644 --- a/femtools/tests/test_spherical_polar_2_cartesian_c.F90 +++ b/femtools/tests/test_spherical_polar_2_cartesian_c.F90 @@ -25,49 +25,49 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_spherical_polar_2_cartesian_C - !Subroutine/unit-test of correct transformation of point coordinates from a - ! spherical-polar system to a Cartesian system. This subroutine will test - ! the C-inter-operable version of the conversion. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - use iso_c_binding - implicit none + !Subroutine/unit-test of correct transformation of point coordinates from a + ! spherical-polar system to a Cartesian system. This subroutine will test + ! the C-inter-operable version of the conversion. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + use iso_c_binding + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - integer :: node - real(kind=c_double), dimension(3) :: XYZ, RTP !Arrays containing a single node's - ! position vector components in Cartesian & - ! spherical-polar bases. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + integer :: node + real(kind=c_double), dimension(3) :: XYZ, RTP !Arrays containing a single node's + ! position vector components in Cartesian & + ! spherical-polar bases. + logical :: fail - !Extract the vector fields of position in vtu file in polar coordinates and - ! cartesian coordiantes - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + !Extract the vector fields of position in vtu file in polar coordinates and + ! cartesian coordiantes + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Apply transformation to spherical-polar components and compare with components of - ! cartesian position-vector. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - call spherical_polar_2_cartesian_c(RTP(1), RTP(2), RTP(3), XYZ(1), XYZ(2), XYZ(3)) - call set(difference, node, XYZ) - enddo - call addto(difference, CartesianCoordinate, -1.0) + !Apply transformation to spherical-polar components and compare with components of + ! cartesian position-vector. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + call spherical_polar_2_cartesian_c(RTP(1), RTP(2), RTP(3), XYZ(1), XYZ(2), XYZ(3)) + call set(difference, node, XYZ) + enddo + call addto(difference, CartesianCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: Spherical-polar to Cartesian (C-types).]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: Spherical-polar to Cartesian (C-types).]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_spherical_polar_2_cartesian_field.F90 b/femtools/tests/test_spherical_polar_2_cartesian_field.F90 index e6338d7dd8..9f5eb0891c 100644 --- a/femtools/tests/test_spherical_polar_2_cartesian_field.F90 +++ b/femtools/tests/test_spherical_polar_2_cartesian_field.F90 @@ -1,37 +1,37 @@ subroutine test_spherical_polar_2_cartesian_field - !Test for routine test_spherical_polar_2_cartesian_field, ensuring conversion of a vector field - ! containing the position vector in sperical-polar coordiantes into a vector field containing - ! the position vector in Cartesian coordinates is correct. + !Test for routine test_spherical_polar_2_cartesian_field, ensuring conversion of a vector field + ! containing the position vector in sperical-polar coordiantes into a vector field containing + ! the position vector in Cartesian coordinates is correct. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Apply transformation to polar-coordinate field obtained from vtu file and - ! compare with cartesian position-vector. - call allocate(difference, 3 , mesh, 'difference') - call spherical_polar_2_cartesian(PolarCoordinate, difference) - call addto(difference, CartesianCoordinate, -1.0) + !Apply transformation to polar-coordinate field obtained from vtu file and + ! compare with cartesian position-vector. + call allocate(difference, 3 , mesh, 'difference') + call spherical_polar_2_cartesian(PolarCoordinate, difference) + call addto(difference, CartesianCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change of whole field: Spherical-polar to Cartesian.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change of whole field: Spherical-polar to Cartesian.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_spherical_polar_2_lon_lat_height.F90 b/femtools/tests/test_spherical_polar_2_lon_lat_height.F90 index 17746e1733..cd6680cca6 100644 --- a/femtools/tests/test_spherical_polar_2_lon_lat_height.F90 +++ b/femtools/tests/test_spherical_polar_2_lon_lat_height.F90 @@ -25,46 +25,46 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_spherical_polar_2_lon_lat_height - !Subroutine for testing correct conversion of point coordinates from spherical- - ! polar into longitude-latitude-height coordinates. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine for testing correct conversion of point coordinates from spherical- + ! polar into longitude-latitude-height coordinates. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: LonLatHeightCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field) :: difference - integer :: node - real, dimension(3) :: LLH, RTP !Arrays containing a single node's position vector - ! components in lon-lat-height & spherical-polar bases. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: LonLatHeightCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field) :: difference + integer :: node + real, dimension(3) :: LLH, RTP !Arrays containing a single node's position vector + ! components in lon-lat-height & spherical-polar bases. + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - !Extract the components of points in vtu file in spherical-polar cooridnates, - ! apply transformation and compare with position-vector in lon-lat-radius coordinates. - call allocate(difference, 3 , mesh, 'difference') - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - call spherical_polar_2_lon_lat_height(RTP(1), RTP(2), RTP(3), & - LLH(1), LLH(2), LLH(3), & - 0.0) - call set(difference, node, LLH) - enddo - call addto(difference, LonLatHeightCoordinate, -1.0) + !Extract the components of points in vtu file in spherical-polar cooridnates, + ! apply transformation and compare with position-vector in lon-lat-radius coordinates. + call allocate(difference, 3 , mesh, 'difference') + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + call spherical_polar_2_lon_lat_height(RTP(1), RTP(2), RTP(3), & + LLH(1), LLH(2), LLH(3), & + 0.0) + call set(difference, node, LLH) + enddo + call addto(difference, LonLatHeightCoordinate, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Coordinate change: Spherical-polar to lon-lat-height.]", & - fail, .false., "Position vector components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Coordinate change: Spherical-polar to lon-lat-height.]", & + fail, .false., "Position vector components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_strain_rate.F90 b/femtools/tests/test_strain_rate.F90 index cafec88ab5..4577677060 100644 --- a/femtools/tests/test_strain_rate.F90 +++ b/femtools/tests/test_strain_rate.F90 @@ -1,82 +1,82 @@ subroutine test_strain_rate - use fields - use field_derivatives - use vtk_interfaces - use mesh_files - use state_module - use unittest_tools - implicit none - - type(vector_field) :: field - type(tensor_field) :: strain_rate_field, solution_field, diff_field - type(mesh_type), pointer :: mesh - type(vector_field), target :: positions - logical :: fail - - interface - function velocity(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos)) :: velocity - end function - function solution(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos),size(pos)) :: solution - end function - end interface - - positions=read_mesh_files("data/cube.3", quad_degree=4, format="gmsh") - mesh => positions%mesh - - call allocate(field, 3, mesh, "Field") - call allocate(strain_rate_field, mesh, "StrainRate") - call allocate(solution_field, mesh, "Solution") - call allocate(diff_field, mesh, "Difference") - - ! set our input velocity - call set_from_function(field, velocity, positions) - ! compute the strain rate - call strain_rate(field, positions, strain_rate_field) - ! now compute the expected solution - call set_from_function(solution_field, solution, positions) - - call set(diff_field, strain_rate_field) - call addto(diff_field, solution_field, scale=-1.0) - - call vtk_write_fields("data/strain_rate_out", 0, positions, mesh, & - vfields=(/ field/), tfields=(/ strain_rate_field, solution_field, diff_field /)) - - fail = maxval( abs( diff_field%val ))> 1e-10 - call report_test("[strain_rate]", fail, .false., "strain_rate different than expected") + use fields + use field_derivatives + use vtk_interfaces + use mesh_files + use state_module + use unittest_tools + implicit none + + type(vector_field) :: field + type(tensor_field) :: strain_rate_field, solution_field, diff_field + type(mesh_type), pointer :: mesh + type(vector_field), target :: positions + logical :: fail + + interface + function velocity(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos)) :: velocity + end function + function solution(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos),size(pos)) :: solution + end function + end interface + + positions=read_mesh_files("data/cube.3", quad_degree=4, format="gmsh") + mesh => positions%mesh + + call allocate(field, 3, mesh, "Field") + call allocate(strain_rate_field, mesh, "StrainRate") + call allocate(solution_field, mesh, "Solution") + call allocate(diff_field, mesh, "Difference") + + ! set our input velocity + call set_from_function(field, velocity, positions) + ! compute the strain rate + call strain_rate(field, positions, strain_rate_field) + ! now compute the expected solution + call set_from_function(solution_field, solution, positions) + + call set(diff_field, strain_rate_field) + call addto(diff_field, solution_field, scale=-1.0) + + call vtk_write_fields("data/strain_rate_out", 0, positions, mesh, & + vfields=(/ field/), tfields=(/ strain_rate_field, solution_field, diff_field /)) + + fail = maxval( abs( diff_field%val ))> 1e-10 + call report_test("[strain_rate]", fail, .false., "strain_rate different than expected") end subroutine test_strain_rate function velocity(pos) - real, dimension(3) :: velocity - real, dimension(:) :: pos - real :: x,y,z - x = pos(1); y = pos(2); z = pos(3) + real, dimension(3) :: velocity + real, dimension(:) :: pos + real :: x,y,z + x = pos(1); y = pos(2); z = pos(3) - velocity(1) = x + 2*y + 3*z - velocity(2) = 4*x + 5*y + 6*z - velocity(3) = 7*x + 8*y + 9*z + velocity(1) = x + 2*y + 3*z + velocity(2) = 4*x + 5*y + 6*z + velocity(3) = 7*x + 8*y + 9*z end function velocity function solution(pos) - real, dimension(3,3) :: solution - real, dimension(:) :: pos - real :: x,y,z - x = pos(1); y = pos(2); z = pos(3) - - solution(1,1)=1 - solution(1,2)=3 - solution(1,3)=5 - solution(2,1)=3 - solution(2,2)=5 - solution(2,3)=7 - solution(3,1)=5 - solution(3,2)=7 - solution(3,3)=9 + real, dimension(3,3) :: solution + real, dimension(:) :: pos + real :: x,y,z + x = pos(1); y = pos(2); z = pos(3) + + solution(1,1)=1 + solution(1,2)=3 + solution(1,3)=5 + solution(2,1)=3 + solution(2,2)=5 + solution(2,3)=7 + solution(3,1)=5 + solution(3,2)=7 + solution(3,3)=9 end function solution diff --git a/femtools/tests/test_stream_io.F90 b/femtools/tests/test_stream_io.F90 index a905066e44..6e2131563d 100644 --- a/femtools/tests/test_stream_io.F90 +++ b/femtools/tests/test_stream_io.F90 @@ -29,65 +29,65 @@ subroutine test_stream_io - use fldebug - use futils - use unittest_tools + use fldebug + use futils + use unittest_tools - implicit none + implicit none #ifdef STREAM_IO - integer :: stat, unit - real :: test_var + integer :: stat, unit + real :: test_var - unit = free_unit() + unit = free_unit() - open(unit = unit, file = "data/test_stream_io_out", status = "replace", access = "stream", form = "unformatted", action = "write", iostat = stat) - call report_test("[stream open]", stat /= 0, .false., "open failure") + open(unit = unit, file = "data/test_stream_io_out", status = "replace", access = "stream", form = "unformatted", action = "write", iostat = stat) + call report_test("[stream open]", stat /= 0, .false., "open failure") - test_var = 42.0 - write(unit, iostat = stat) test_var - call report_test("[stream write]", stat /= 0, .false., "write failure") + test_var = 42.0 + write(unit, iostat = stat) test_var + call report_test("[stream write]", stat /= 0, .false., "write failure") - close(unit, iostat = stat) - call report_test("[stream close]", stat /= 0, .false., "close failure") + close(unit, iostat = stat) + call report_test("[stream close]", stat /= 0, .false., "close failure") - open(unit = unit, file = "data/test_stream_io_out", access = "stream", form = "unformatted", action = "read", iostat = stat) - call report_test("[stream open]", stat /= 0, .false., "open failure") + open(unit = unit, file = "data/test_stream_io_out", access = "stream", form = "unformatted", action = "read", iostat = stat) + call report_test("[stream open]", stat /= 0, .false., "open failure") - test_var = 0.0 - read(unit, iostat = stat) test_var - call report_test("[stream read]", stat /= 0, .false., "read failure") + test_var = 0.0 + read(unit, iostat = stat) test_var + call report_test("[stream read]", stat /= 0, .false., "read failure") - close(unit, iostat = stat) - call report_test("[stream close]", stat /= 0, .false., "close failure") + close(unit, iostat = stat) + call report_test("[stream close]", stat /= 0, .false., "close failure") - call report_test("[stream read value]", test_var .fne. 42.0, .false., "Read incorrect value") + call report_test("[stream read value]", test_var .fne. 42.0, .false., "Read incorrect value") - open(unit = unit, file = "data/test_stream_io_out", status = "replace", access = "stream", form = "unformatted", action = "write", iostat = stat) - call report_test("[stream open]", stat /= 0, .false., "open failure") + open(unit = unit, file = "data/test_stream_io_out", status = "replace", access = "stream", form = "unformatted", action = "write", iostat = stat) + call report_test("[stream open]", stat /= 0, .false., "open failure") - test_var = 43.0 - write(unit, iostat = stat) test_var - call report_test("[stream write]", stat /= 0, .false., "write failure") + test_var = 43.0 + write(unit, iostat = stat) test_var + call report_test("[stream write]", stat /= 0, .false., "write failure") - close(unit, iostat = stat) - call report_test("[stream close]", stat /= 0, .false., "close failure") + close(unit, iostat = stat) + call report_test("[stream close]", stat /= 0, .false., "close failure") - open(unit = unit, file = "data/test_stream_io_out", access = "stream", form = "unformatted", action = "read", iostat = stat) - call report_test("[stream open]", stat /= 0, .false., "open failure") + open(unit = unit, file = "data/test_stream_io_out", access = "stream", form = "unformatted", action = "read", iostat = stat) + call report_test("[stream open]", stat /= 0, .false., "open failure") - test_var = 0.0 - read(unit, iostat = stat) test_var - call report_test("[stream read]", stat /= 0, .false., "read failure") + test_var = 0.0 + read(unit, iostat = stat) test_var + call report_test("[stream read]", stat /= 0, .false., "read failure") - close(unit, iostat = stat) - call report_test("[stream close]", stat /= 0, .false., "close failure") + close(unit, iostat = stat) + call report_test("[stream close]", stat /= 0, .false., "close failure") - call report_test("[stream read value]", test_var .fne. 43.0, .false., "Read incorrect value") + call report_test("[stream read value]", test_var .fne. 43.0, .false., "Read incorrect value") #else - call report_test("[dummy]", .false., .false., "Dummy") + call report_test("[dummy]", .false., .false., "Dummy") #endif end subroutine test_stream_io diff --git a/femtools/tests/test_string_from_python.F90 b/femtools/tests/test_string_from_python.F90 index 92216b19c7..c8d116a524 100644 --- a/femtools/tests/test_string_from_python.F90 +++ b/femtools/tests/test_string_from_python.F90 @@ -29,28 +29,28 @@ subroutine test_string_from_python - use embed_python - use fldebug - use global_parameters, only : PYTHON_FUNC_LEN - use unittest_tools - - implicit none - - character(len = *), parameter :: func = & - & 'def val(t):' // new_line("") // & - & ' if t >= 0.0:' // new_line("") // & - & ' return "Positive"' // new_line("") // & - & ' else:' // new_line("") // & - & ' return "Negative"' - character(len = PYTHON_FUNC_LEN) :: result - integer :: stat - - call string_from_python(func, -1.0, result, stat = stat) - call report_test("[string_from_python]", stat /= 0, .false., "string_from_python returned an error") - call report_test("[Expected result]", result /= "Negative", .false., "string_from_python returned incorrect string") - - call string_from_python(func, 1.0, result, stat = stat) - call report_test("[string_from_python]", stat /= 0, .false., "string_from_python returned an error") - call report_test("[Expected result]", result /= "Positive", .false., "string_from_python returned incorrect string") + use embed_python + use fldebug + use global_parameters, only : PYTHON_FUNC_LEN + use unittest_tools + + implicit none + + character(len = *), parameter :: func = & + & 'def val(t):' // new_line("") // & + & ' if t >= 0.0:' // new_line("") // & + & ' return "Positive"' // new_line("") // & + & ' else:' // new_line("") // & + & ' return "Negative"' + character(len = PYTHON_FUNC_LEN) :: result + integer :: stat + + call string_from_python(func, -1.0, result, stat = stat) + call report_test("[string_from_python]", stat /= 0, .false., "string_from_python returned an error") + call report_test("[Expected result]", result /= "Negative", .false., "string_from_python returned incorrect string") + + call string_from_python(func, 1.0, result, stat = stat) + call report_test("[string_from_python]", stat /= 0, .false., "string_from_python returned an error") + call report_test("[Expected result]", result /= "Positive", .false., "string_from_python returned incorrect string") end subroutine test_string_from_python diff --git a/femtools/tests/test_submesh.F90 b/femtools/tests/test_submesh.F90 index 7c6abdaede..6633118de7 100644 --- a/femtools/tests/test_submesh.F90 +++ b/femtools/tests/test_submesh.F90 @@ -1,173 +1,173 @@ subroutine test_submesh - use elements - use fields - use fields_data_types - use reference_counting - use state_module - use unittest_tools - use fefields - - implicit none - - type(quadrature_type) :: quad - type(element_type) :: baseshape, highshape - type(mesh_type) :: basemesh, parmesh, highmesh, submesh1, submesh2 - type(vector_field) :: basex, parx, highx, subx1, subx2 - type(scalar_field) :: baselump, parlump, highlump, sublump1, sublump2 - - integer :: i, j, dim, vertices - - do dim = 2,3 - write(0,*) - write(0,*) 'dim = ', dim - - if(dim==3) then - vertices = 4 - elseif(dim==2) then - vertices = 3 - else - write(0,*) "unsupported dimension count" - return - endif - - ! Make a P1 single triangle mesh - quad = make_quadrature(vertices = vertices, dim = dim, degree = 1) - baseshape = make_element_shape(vertices = vertices, dim = dim, degree = 1, quad = quad) - call allocate(basemesh, nodes = vertices, elements = 1, shape = baseshape, name = "BaseMesh") - call allocate(basex, mesh_dim(basemesh), basemesh, "BaseCoordinate") - - do i = 1, size(basemesh%ndglno) - basemesh%ndglno(i) = i - end do - - if(dim==3) then - call set(basex, 1, (/0.0, 0.0, 0.0/)) - call set(basex, 2, (/1.0, 0.0, 0.0/)) - call set(basex, 3, (/0.0, sqrt(3.0)/2.0, 0.0/)) - call set(basex, 4, (/0.5, sqrt(3.0)/4.0, 0.75/)) - else - call set(basex, 1, (/0.0, 0.0/)) - call set(basex, 2, (/1.0, 0.0/)) - call set(basex, 3, (/0.5, sqrt(3.0)/2.0/)) - end if - - call allocate(baselump, basemesh, "BaseLump") - call compute_lumped_mass(basex, baselump) - - parmesh = make_mesh(basemesh, shape = baseshape, name="ParallelMesh") - call allocate(parx, mesh_dim(parmesh), parmesh, "ParallelCoordinate") - call remap_field(basex, parx) - call allocate(parlump, parmesh, "ParallelLump") - call compute_lumped_mass(parx, parlump) - - highshape = make_element_shape(vertices = vertices, dim = dim, degree = 2, quad=quad) - highmesh = make_mesh(basemesh, shape=highshape, name="HigherOrderMesh") - call allocate(highx, mesh_dim(highmesh), highmesh, "HigherOrderCoordinate") - call remap_field(basex, highx) - call allocate(highlump, highmesh, "HigherOrderLump") - call compute_lumped_mass(highx, highlump) - - submesh1 = make_submesh(parmesh, name="SubMesh1") - call allocate(subx1, mesh_dim(submesh1), submesh1, name="SubCoordinate1") - call set_to_submesh(parx, subx1) - call allocate(sublump1, submesh1, "SubLump1") - call compute_lumped_mass(subx1, sublump1) - - submesh2 = make_submesh(highmesh, name="SumMesh2") - call allocate(subx2, mesh_dim(submesh2), submesh2, name="SubCoordinate2") - call set_to_submesh(highx, subx2) - call allocate(sublump2, submesh2, "SubLump1") - call compute_lumped_mass(subx2, sublump2) - - write(0,*) "BaseMesh" - do i = 1, basemesh%elements - write(0,*) "Element ", i - write(0,*) ele_nodes(basemesh, i) - do j = 1, mesh_dim(basemesh) - write(0,*) "dim ", j - write(0,*) ele_val(basex, i, j) + use elements + use fields + use fields_data_types + use reference_counting + use state_module + use unittest_tools + use fefields + + implicit none + + type(quadrature_type) :: quad + type(element_type) :: baseshape, highshape + type(mesh_type) :: basemesh, parmesh, highmesh, submesh1, submesh2 + type(vector_field) :: basex, parx, highx, subx1, subx2 + type(scalar_field) :: baselump, parlump, highlump, sublump1, sublump2 + + integer :: i, j, dim, vertices + + do dim = 2,3 + write(0,*) + write(0,*) 'dim = ', dim + + if(dim==3) then + vertices = 4 + elseif(dim==2) then + vertices = 3 + else + write(0,*) "unsupported dimension count" + return + endif + + ! Make a P1 single triangle mesh + quad = make_quadrature(vertices = vertices, dim = dim, degree = 1) + baseshape = make_element_shape(vertices = vertices, dim = dim, degree = 1, quad = quad) + call allocate(basemesh, nodes = vertices, elements = 1, shape = baseshape, name = "BaseMesh") + call allocate(basex, mesh_dim(basemesh), basemesh, "BaseCoordinate") + + do i = 1, size(basemesh%ndglno) + basemesh%ndglno(i) = i end do - end do - write(0,*) 'BaseLump' - write(0,*) baselump%val - write(0,*) 'sum = ', sum(baselump%val) - write(0,*) - - write(0,*) "ParallelMesh" - do i = 1, parmesh%elements - write(0,*) "Element ", i - write(0,*) ele_nodes(parmesh, i) - do j = 1, mesh_dim(parmesh) - write(0,*) "dim ", j - write(0,*) ele_val(parx, i, j) + + if(dim==3) then + call set(basex, 1, (/0.0, 0.0, 0.0/)) + call set(basex, 2, (/1.0, 0.0, 0.0/)) + call set(basex, 3, (/0.0, sqrt(3.0)/2.0, 0.0/)) + call set(basex, 4, (/0.5, sqrt(3.0)/4.0, 0.75/)) + else + call set(basex, 1, (/0.0, 0.0/)) + call set(basex, 2, (/1.0, 0.0/)) + call set(basex, 3, (/0.5, sqrt(3.0)/2.0/)) + end if + + call allocate(baselump, basemesh, "BaseLump") + call compute_lumped_mass(basex, baselump) + + parmesh = make_mesh(basemesh, shape = baseshape, name="ParallelMesh") + call allocate(parx, mesh_dim(parmesh), parmesh, "ParallelCoordinate") + call remap_field(basex, parx) + call allocate(parlump, parmesh, "ParallelLump") + call compute_lumped_mass(parx, parlump) + + highshape = make_element_shape(vertices = vertices, dim = dim, degree = 2, quad=quad) + highmesh = make_mesh(basemesh, shape=highshape, name="HigherOrderMesh") + call allocate(highx, mesh_dim(highmesh), highmesh, "HigherOrderCoordinate") + call remap_field(basex, highx) + call allocate(highlump, highmesh, "HigherOrderLump") + call compute_lumped_mass(highx, highlump) + + submesh1 = make_submesh(parmesh, name="SubMesh1") + call allocate(subx1, mesh_dim(submesh1), submesh1, name="SubCoordinate1") + call set_to_submesh(parx, subx1) + call allocate(sublump1, submesh1, "SubLump1") + call compute_lumped_mass(subx1, sublump1) + + submesh2 = make_submesh(highmesh, name="SumMesh2") + call allocate(subx2, mesh_dim(submesh2), submesh2, name="SubCoordinate2") + call set_to_submesh(highx, subx2) + call allocate(sublump2, submesh2, "SubLump1") + call compute_lumped_mass(subx2, sublump2) + + write(0,*) "BaseMesh" + do i = 1, basemesh%elements + write(0,*) "Element ", i + write(0,*) ele_nodes(basemesh, i) + do j = 1, mesh_dim(basemesh) + write(0,*) "dim ", j + write(0,*) ele_val(basex, i, j) + end do + end do + write(0,*) 'BaseLump' + write(0,*) baselump%val + write(0,*) 'sum = ', sum(baselump%val) + write(0,*) + + write(0,*) "ParallelMesh" + do i = 1, parmesh%elements + write(0,*) "Element ", i + write(0,*) ele_nodes(parmesh, i) + do j = 1, mesh_dim(parmesh) + write(0,*) "dim ", j + write(0,*) ele_val(parx, i, j) + end do end do - end do - write(0,*) 'ParLump' - write(0,*) parlump%val - write(0,*) 'sum = ', sum(parlump%val) - write(0,*) - - write(0,*) "HigherOrderMesh" - do i = 1, highmesh%elements - write(0,*) "Element ", i - write(0,*) ele_nodes(highmesh,i) - do j = 1, mesh_dim(highmesh) - write(0,*) "dim ", j - write(0,*) ele_val(highx, i, j) + write(0,*) 'ParLump' + write(0,*) parlump%val + write(0,*) 'sum = ', sum(parlump%val) + write(0,*) + + write(0,*) "HigherOrderMesh" + do i = 1, highmesh%elements + write(0,*) "Element ", i + write(0,*) ele_nodes(highmesh,i) + do j = 1, mesh_dim(highmesh) + write(0,*) "dim ", j + write(0,*) ele_val(highx, i, j) + end do end do - end do - write(0,*) 'HighLump' - write(0,*) highlump%val - write(0,*) 'sum = ', sum(highlump%val) - write(0,*) - - write(0,*) "SubMesh1" - do i = 1, submesh1%elements - write(0,*) "Element ", i - write(0,*) ele_nodes(submesh1,i) - do j = 1, mesh_dim(submesh1) - write(0,*) "dim ", j - write(0,*) ele_val(subx1, i, j) + write(0,*) 'HighLump' + write(0,*) highlump%val + write(0,*) 'sum = ', sum(highlump%val) + write(0,*) + + write(0,*) "SubMesh1" + do i = 1, submesh1%elements + write(0,*) "Element ", i + write(0,*) ele_nodes(submesh1,i) + do j = 1, mesh_dim(submesh1) + write(0,*) "dim ", j + write(0,*) ele_val(subx1, i, j) + end do end do - end do - write(0,*) 'SubLump1' - write(0,*) sublump1%val - write(0,*) 'sum = ', sum(sublump1%val) - write(0,*) - - write(0,*) "SubMesh2" - do i = 1, submesh2%elements - write(0,*) "Element ", i - write(0,*) ele_nodes(submesh2,i) - do j = 1, mesh_dim(submesh2) - write(0,*) "dim ", j - write(0,*) ele_val(subx2, i, j) + write(0,*) 'SubLump1' + write(0,*) sublump1%val + write(0,*) 'sum = ', sum(sublump1%val) + write(0,*) + + write(0,*) "SubMesh2" + do i = 1, submesh2%elements + write(0,*) "Element ", i + write(0,*) ele_nodes(submesh2,i) + do j = 1, mesh_dim(submesh2) + write(0,*) "dim ", j + write(0,*) ele_val(subx2, i, j) + end do end do - end do - write(0,*) 'SubLump2' - write(0,*) sublump2%val - write(0,*) 'sum = ', sum(sublump2%val) - write(0,*) - - call deallocate(quad) - call deallocate(baseshape) - call deallocate(highshape) - call deallocate(basemesh) - call deallocate(basex) - call deallocate(parmesh) - call deallocate(parx) - call deallocate(highmesh) - call deallocate(highx) - call deallocate(submesh1) - call deallocate(submesh2) - call deallocate(subx1) - call deallocate(subx2) - call deallocate(sublump1) - call deallocate(sublump2) - call deallocate(parlump) - call deallocate(highlump) - call deallocate(baselump) - end do + write(0,*) 'SubLump2' + write(0,*) sublump2%val + write(0,*) 'sum = ', sum(sublump2%val) + write(0,*) + + call deallocate(quad) + call deallocate(baseshape) + call deallocate(highshape) + call deallocate(basemesh) + call deallocate(basex) + call deallocate(parmesh) + call deallocate(parx) + call deallocate(highmesh) + call deallocate(highx) + call deallocate(submesh1) + call deallocate(submesh2) + call deallocate(subx1) + call deallocate(subx2) + call deallocate(sublump1) + call deallocate(sublump2) + call deallocate(parlump) + call deallocate(highlump) + call deallocate(baselump) + end do end subroutine test_submesh diff --git a/femtools/tests/test_supermesh_shapes_aa.F90 b/femtools/tests/test_supermesh_shapes_aa.F90 index fb5f786e67..3117da5c0e 100644 --- a/femtools/tests/test_supermesh_shapes_aa.F90 +++ b/femtools/tests/test_supermesh_shapes_aa.F90 @@ -29,128 +29,128 @@ subroutine test_supermesh_shapes_aa - use fetools - use quadrature - use elements - use transform_elements - use fields - use fldebug - use supermesh_assembly - use unittest_tools - - implicit none - - integer :: degree, i - real, dimension(:), allocatable :: shape_rhs_integral_a, shape_rhs_integral_c - real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c - type(element_type) :: shape_a, shape_c - type(element_type), dimension(:), allocatable :: shapes_c - type(mesh_type) :: mesh_a, shape_mesh - type(quadrature_type) :: quad - type(vector_field) :: positions_a, positions_c - - do degree = 0, 4 - print *, "Degree = ", degree - - quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) - shape_a = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) - shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) - call deallocate(quad) - - call allocate(mesh_a, nodes = 3, elements = 1, shape = shape_a, name = "TargetMesh") - call set_ele_nodes(mesh_a, 1, (/1, 2, 3/)) - allocate(mesh_a%region_ids(1)) - mesh_a%region_ids = (/1/) - - call allocate(positions_a, dim = 2, mesh = mesh_a, name = "TargetCoordinate") - call deallocate(mesh_a) - call set(positions_a, 1, (/0.0, 0.0/)) - call set(positions_a, 2, (/1.0, 0.0/)) - call set(positions_a, 3, (/0.0, 1.0/)) - - call deallocate(shape_a) - - positions_c = positions_a - call incref(positions_c) - - shape_mesh = make_mesh(positions_a%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") - call deallocate(shape_c) - - call project_donor_shape_to_supermesh(positions_a, shape_mesh, positions_c, & + use fetools + use quadrature + use elements + use transform_elements + use fields + use fldebug + use supermesh_assembly + use unittest_tools + + implicit none + + integer :: degree, i + real, dimension(:), allocatable :: shape_rhs_integral_a, shape_rhs_integral_c + real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c + type(element_type) :: shape_a, shape_c + type(element_type), dimension(:), allocatable :: shapes_c + type(mesh_type) :: mesh_a, shape_mesh + type(quadrature_type) :: quad + type(vector_field) :: positions_a, positions_c + + do degree = 0, 4 + print *, "Degree = ", degree + + quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) + shape_a = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) + shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) + call deallocate(quad) + + call allocate(mesh_a, nodes = 3, elements = 1, shape = shape_a, name = "TargetMesh") + call set_ele_nodes(mesh_a, 1, (/1, 2, 3/)) + allocate(mesh_a%region_ids(1)) + mesh_a%region_ids = (/1/) + + call allocate(positions_a, dim = 2, mesh = mesh_a, name = "TargetCoordinate") + call deallocate(mesh_a) + call set(positions_a, 1, (/0.0, 0.0/)) + call set(positions_a, 2, (/1.0, 0.0/)) + call set(positions_a, 3, (/0.0, 1.0/)) + + call deallocate(shape_a) + + positions_c = positions_a + call incref(positions_c) + + shape_mesh = make_mesh(positions_a%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") + call deallocate(shape_c) + + call project_donor_shape_to_supermesh(positions_a, shape_mesh, positions_c, & & shapes_c, form_dn = .true.) - allocate(shape_rhs_integral_a(ele_loc(shape_mesh, 1))) - shape_rhs_integral_a = shape_rhs_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) + allocate(shape_rhs_integral_a(ele_loc(shape_mesh, 1))) + shape_rhs_integral_a = shape_rhs_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) - allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) - shape_rhs_integral_c = 0.0 - do i = 1, ele_count(positions_c) - shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) + shape_rhs_integral_c = 0.0 + do i = 1, ele_count(positions_c) + shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[shape_rhs on supermesh]", shape_rhs_integral_a .fne. shape_rhs_integral_c, .false., "Incorrect integral") + call report_test("[shape_rhs on supermesh]", shape_rhs_integral_a .fne. shape_rhs_integral_c, .false., "Incorrect integral") - deallocate(shape_rhs_integral_a) - deallocate(shape_rhs_integral_c) + deallocate(shape_rhs_integral_a) + deallocate(shape_rhs_integral_c) - allocate(dshape_dot_dshape_integral_a(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_a = dshape_dot_dshape_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) + allocate(dshape_dot_dshape_integral_a(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_a = dshape_dot_dshape_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) - allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_c = 0.0 - do i = 1, ele_count(positions_c) - dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_c = 0.0 + do i = 1, ele_count(positions_c) + dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") + call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") - deallocate(dshape_dot_dshape_integral_a) - deallocate(dshape_dot_dshape_integral_c) + deallocate(dshape_dot_dshape_integral_a) + deallocate(dshape_dot_dshape_integral_c) - do i = 1, size(shapes_c) - call deallocate(shapes_c(i)) - end do - deallocate(shapes_c) + do i = 1, size(shapes_c) + call deallocate(shapes_c(i)) + end do + deallocate(shapes_c) - call deallocate(positions_a) - call deallocate(positions_c) - call deallocate(shape_mesh) + call deallocate(positions_a) + call deallocate(positions_c) + call deallocate(shape_mesh) - call report_test_no_references() - end do + call report_test_no_references() + end do contains - function shape_rhs_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function shape_rhs_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc) :: integral + real, dimension(shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - integral = shape_rhs(shape, detwei) + integral = shape_rhs(shape, detwei) - end function shape_rhs_integral_ele + end function shape_rhs_integral_ele - function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc, shape%loc) :: integral + real, dimension(shape%loc, shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn - call transform_to_physical(positions, ele, shape, & + call transform_to_physical(positions, ele, shape, & & dshape = dn, detwei = detwei) - integral = dshape_dot_dshape(dn, dn, detwei) + integral = dshape_dot_dshape(dn, dn, detwei) - end function dshape_dot_dshape_integral_ele + end function dshape_dot_dshape_integral_ele end subroutine test_supermesh_shapes_aa diff --git a/femtools/tests/test_supermesh_shapes_ac.F90 b/femtools/tests/test_supermesh_shapes_ac.F90 index 8c580b25d6..ac6853e5c2 100644 --- a/femtools/tests/test_supermesh_shapes_ac.F90 +++ b/femtools/tests/test_supermesh_shapes_ac.F90 @@ -29,135 +29,135 @@ subroutine test_supermesh_shapes_ac - use quadrature - use elements - use fetools - use fields - use fldebug - use supermesh_assembly - use unittest_tools - - implicit none - - integer :: degree, i - real, dimension(:), allocatable :: shape_rhs_integral_a, shape_rhs_integral_c - real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c - type(element_type) :: shape_a, shape_c - type(element_type), dimension(:), allocatable :: shapes_c - type(mesh_type) :: mesh_a, mesh_c, shape_mesh - type(quadrature_type) :: quad - type(vector_field) :: positions_a, positions_c - - do degree = 0, 4 - print *, "Degree = ", degree - - quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) - shape_a = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) - shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) - call deallocate(quad) - - call allocate(mesh_a, nodes = 3, elements = 1, shape = shape_a, name = "TargetMesh") - call set_ele_nodes(mesh_a, 1, (/1, 2, 3/)) - - call allocate(positions_a, dim = 2, mesh = mesh_a, name = "TargetCoordinate") - call deallocate(mesh_a) - call set(positions_a, 1, (/0.0, 0.0/)) - call set(positions_a, 2, (/1.0, 0.0/)) - call set(positions_a, 3, (/0.0, 1.0/)) - - call allocate(mesh_c, nodes = 4, elements = 3, shape = shape_a, name = "Supermesh") - call deallocate(shape_a) - call set_ele_nodes(mesh_c, 1, (/1, 2, 4/)) - call set_ele_nodes(mesh_c, 2, (/4, 2, 3/)) - call set_ele_nodes(mesh_c, 3, (/3, 1, 4/)) - allocate(mesh_c%region_ids(3)) - mesh_c%region_ids = (/1, 1, 1/) - - call allocate(positions_c, dim = 2, mesh = mesh_c, name = "SupermeshCoordinate") - call deallocate(mesh_c) - call set(positions_c, 1, (/0.0, 0.0/)) - call set(positions_c, 2, (/1.0, 0.0/)) - call set(positions_c, 3, (/0.0, 1.0/)) - call set(positions_c, 4, (/0.25, 0.25/)) - - shape_mesh = make_mesh(positions_a%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") - call deallocate(shape_c) - - call project_donor_shape_to_supermesh(positions_a, shape_mesh, positions_c, & + use quadrature + use elements + use fetools + use fields + use fldebug + use supermesh_assembly + use unittest_tools + + implicit none + + integer :: degree, i + real, dimension(:), allocatable :: shape_rhs_integral_a, shape_rhs_integral_c + real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c + type(element_type) :: shape_a, shape_c + type(element_type), dimension(:), allocatable :: shapes_c + type(mesh_type) :: mesh_a, mesh_c, shape_mesh + type(quadrature_type) :: quad + type(vector_field) :: positions_a, positions_c + + do degree = 0, 4 + print *, "Degree = ", degree + + quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) + shape_a = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) + shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) + call deallocate(quad) + + call allocate(mesh_a, nodes = 3, elements = 1, shape = shape_a, name = "TargetMesh") + call set_ele_nodes(mesh_a, 1, (/1, 2, 3/)) + + call allocate(positions_a, dim = 2, mesh = mesh_a, name = "TargetCoordinate") + call deallocate(mesh_a) + call set(positions_a, 1, (/0.0, 0.0/)) + call set(positions_a, 2, (/1.0, 0.0/)) + call set(positions_a, 3, (/0.0, 1.0/)) + + call allocate(mesh_c, nodes = 4, elements = 3, shape = shape_a, name = "Supermesh") + call deallocate(shape_a) + call set_ele_nodes(mesh_c, 1, (/1, 2, 4/)) + call set_ele_nodes(mesh_c, 2, (/4, 2, 3/)) + call set_ele_nodes(mesh_c, 3, (/3, 1, 4/)) + allocate(mesh_c%region_ids(3)) + mesh_c%region_ids = (/1, 1, 1/) + + call allocate(positions_c, dim = 2, mesh = mesh_c, name = "SupermeshCoordinate") + call deallocate(mesh_c) + call set(positions_c, 1, (/0.0, 0.0/)) + call set(positions_c, 2, (/1.0, 0.0/)) + call set(positions_c, 3, (/0.0, 1.0/)) + call set(positions_c, 4, (/0.25, 0.25/)) + + shape_mesh = make_mesh(positions_a%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") + call deallocate(shape_c) + + call project_donor_shape_to_supermesh(positions_a, shape_mesh, positions_c, & & shapes_c, form_dn = .true.) - allocate(shape_rhs_integral_a(ele_loc(shape_mesh, 1))) - shape_rhs_integral_a = shape_rhs_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) + allocate(shape_rhs_integral_a(ele_loc(shape_mesh, 1))) + shape_rhs_integral_a = shape_rhs_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) - allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) - shape_rhs_integral_c = 0.0 - do i = 1, ele_count(positions_c) - shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) + shape_rhs_integral_c = 0.0 + do i = 1, ele_count(positions_c) + shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[shape_rhs on supermesh]", shape_rhs_integral_a .fne. shape_rhs_integral_c, .false., "Incorrect integral") + call report_test("[shape_rhs on supermesh]", shape_rhs_integral_a .fne. shape_rhs_integral_c, .false., "Incorrect integral") - deallocate(shape_rhs_integral_a) - deallocate(shape_rhs_integral_c) + deallocate(shape_rhs_integral_a) + deallocate(shape_rhs_integral_c) - allocate(dshape_dot_dshape_integral_a(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_a = dshape_dot_dshape_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) + allocate(dshape_dot_dshape_integral_a(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_a = dshape_dot_dshape_integral_ele(1, positions_a, ele_shape(shape_mesh, 1)) - allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_c = 0.0 - do i = 1, ele_count(positions_c) - dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_c = 0.0 + do i = 1, ele_count(positions_c) + dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") + call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_a, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") - deallocate(dshape_dot_dshape_integral_a) - deallocate(dshape_dot_dshape_integral_c) + deallocate(dshape_dot_dshape_integral_a) + deallocate(dshape_dot_dshape_integral_c) - do i = 1, size(shapes_c) - call deallocate(shapes_c(i)) - end do - deallocate(shapes_c) + do i = 1, size(shapes_c) + call deallocate(shapes_c(i)) + end do + deallocate(shapes_c) - call deallocate(positions_a) - call deallocate(positions_c) - call deallocate(shape_mesh) + call deallocate(positions_a) + call deallocate(positions_c) + call deallocate(shape_mesh) - call report_test_no_references() - end do + call report_test_no_references() + end do contains - function shape_rhs_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function shape_rhs_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc) :: integral + real, dimension(shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - integral = shape_rhs(shape, detwei) + integral = shape_rhs(shape, detwei) - end function shape_rhs_integral_ele + end function shape_rhs_integral_ele - function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc, shape%loc) :: integral + real, dimension(shape%loc, shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn - call transform_to_physical(positions, ele, shape, & + call transform_to_physical(positions, ele, shape, & & dshape = dn, detwei = detwei) - integral = dshape_dot_dshape(dn, dn, detwei) + integral = dshape_dot_dshape(dn, dn, detwei) - end function dshape_dot_dshape_integral_ele + end function dshape_dot_dshape_integral_ele end subroutine test_supermesh_shapes_ac diff --git a/femtools/tests/test_supermesh_shapes_bb.F90 b/femtools/tests/test_supermesh_shapes_bb.F90 index 4a5045a6c0..2d7f6d6a4c 100644 --- a/femtools/tests/test_supermesh_shapes_bb.F90 +++ b/femtools/tests/test_supermesh_shapes_bb.F90 @@ -29,126 +29,126 @@ subroutine test_supermesh_shapes_bb - use quadrature - use elements - use fetools - use fields - use fldebug - use supermesh_assembly - use unittest_tools - - implicit none - - integer :: degree, i - real, dimension(:), allocatable :: shape_rhs_integral_b, shape_rhs_integral_c - real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c - type(element_type) :: shape_b, shape_c - type(element_type), dimension(:), allocatable :: shapes_c - type(mesh_type) :: mesh_b, shape_mesh - type(quadrature_type) :: quad - type(vector_field) :: positions_b, positions_c - - do degree = 0, 4 - print *, "Degree = ", degree - - quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) - shape_b = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) - shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) - call deallocate(quad) - - call allocate(mesh_b, nodes = 3, elements = 1, shape = shape_b, name = "TargetMesh") - call set_ele_nodes(mesh_b, 1, (/1, 2, 3/)) - - call allocate(positions_b, dim = 2, mesh = mesh_b, name = "TargetCoordinate") - call deallocate(mesh_b) - call set(positions_b, 1, (/0.0, 0.0/)) - call set(positions_b, 2, (/1.0, 0.0/)) - call set(positions_b, 3, (/0.0, 1.0/)) - - call deallocate(shape_b) - - positions_c = positions_b - call incref(positions_c) - - shape_mesh = make_mesh(positions_b%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") - call deallocate(shape_c) - - call project_target_shape_to_supermesh(1, & + use quadrature + use elements + use fetools + use fields + use fldebug + use supermesh_assembly + use unittest_tools + + implicit none + + integer :: degree, i + real, dimension(:), allocatable :: shape_rhs_integral_b, shape_rhs_integral_c + real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c + type(element_type) :: shape_b, shape_c + type(element_type), dimension(:), allocatable :: shapes_c + type(mesh_type) :: mesh_b, shape_mesh + type(quadrature_type) :: quad + type(vector_field) :: positions_b, positions_c + + do degree = 0, 4 + print *, "Degree = ", degree + + quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) + shape_b = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) + shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) + call deallocate(quad) + + call allocate(mesh_b, nodes = 3, elements = 1, shape = shape_b, name = "TargetMesh") + call set_ele_nodes(mesh_b, 1, (/1, 2, 3/)) + + call allocate(positions_b, dim = 2, mesh = mesh_b, name = "TargetCoordinate") + call deallocate(mesh_b) + call set(positions_b, 1, (/0.0, 0.0/)) + call set(positions_b, 2, (/1.0, 0.0/)) + call set(positions_b, 3, (/0.0, 1.0/)) + + call deallocate(shape_b) + + positions_c = positions_b + call incref(positions_c) + + shape_mesh = make_mesh(positions_b%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") + call deallocate(shape_c) + + call project_target_shape_to_supermesh(1, & & positions_b, shape_mesh, positions_c, & & shapes_c, form_dn = .true.) - allocate(shape_rhs_integral_b(ele_loc(shape_mesh, 1))) - shape_rhs_integral_b = shape_rhs_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) + allocate(shape_rhs_integral_b(ele_loc(shape_mesh, 1))) + shape_rhs_integral_b = shape_rhs_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) - allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) - shape_rhs_integral_c = 0.0 - do i = 1, ele_count(positions_c) - shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) + shape_rhs_integral_c = 0.0 + do i = 1, ele_count(positions_c) + shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[shape_rhs on supermesh]", shape_rhs_integral_b .fne. shape_rhs_integral_c, .false., "Incorrect integral") + call report_test("[shape_rhs on supermesh]", shape_rhs_integral_b .fne. shape_rhs_integral_c, .false., "Incorrect integral") - deallocate(shape_rhs_integral_b) - deallocate(shape_rhs_integral_c) + deallocate(shape_rhs_integral_b) + deallocate(shape_rhs_integral_c) - allocate(dshape_dot_dshape_integral_b(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_b = dshape_dot_dshape_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) + allocate(dshape_dot_dshape_integral_b(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_b = dshape_dot_dshape_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) - allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_c = 0.0 - do i = 1, ele_count(positions_c) - dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_c = 0.0 + do i = 1, ele_count(positions_c) + dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") + call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") - deallocate(dshape_dot_dshape_integral_b) - deallocate(dshape_dot_dshape_integral_c) + deallocate(dshape_dot_dshape_integral_b) + deallocate(dshape_dot_dshape_integral_c) - do i = 1, size(shapes_c) - call deallocate(shapes_c(i)) - end do - deallocate(shapes_c) + do i = 1, size(shapes_c) + call deallocate(shapes_c(i)) + end do + deallocate(shapes_c) - call deallocate(positions_b) - call deallocate(positions_c) - call deallocate(shape_mesh) + call deallocate(positions_b) + call deallocate(positions_c) + call deallocate(shape_mesh) - call report_test_no_references() - end do + call report_test_no_references() + end do contains - function shape_rhs_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function shape_rhs_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc) :: integral + real, dimension(shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - integral = shape_rhs(shape, detwei) + integral = shape_rhs(shape, detwei) - end function shape_rhs_integral_ele + end function shape_rhs_integral_ele - function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc, shape%loc) :: integral + real, dimension(shape%loc, shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn - call transform_to_physical(positions, ele, shape, & + call transform_to_physical(positions, ele, shape, & & dshape = dn, detwei = detwei) - integral = dshape_dot_dshape(dn, dn, detwei) + integral = dshape_dot_dshape(dn, dn, detwei) - end function dshape_dot_dshape_integral_ele + end function dshape_dot_dshape_integral_ele end subroutine test_supermesh_shapes_bb diff --git a/femtools/tests/test_supermesh_shapes_bc.F90 b/femtools/tests/test_supermesh_shapes_bc.F90 index 80b3a09717..c89dd9e4fa 100644 --- a/femtools/tests/test_supermesh_shapes_bc.F90 +++ b/femtools/tests/test_supermesh_shapes_bc.F90 @@ -29,134 +29,134 @@ subroutine test_supermesh_shapes_bc - use quadrature - use elements - use fetools - use fields - use fldebug - use supermesh_assembly - use unittest_tools - - implicit none - - integer :: degree, i - real, dimension(:), allocatable :: shape_rhs_integral_b, shape_rhs_integral_c - real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c - type(element_type) :: shape_b, shape_c - type(element_type), dimension(:), allocatable :: shapes_c - type(mesh_type) :: mesh_b, mesh_c, shape_mesh - type(quadrature_type) :: quad - type(vector_field) :: positions_b, positions_c - - do degree = 0, 4 - print *, "Degree = ", degree - - quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) - shape_b = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) - shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) - call deallocate(quad) - - call allocate(mesh_b, nodes = 3, elements = 1, shape = shape_b, name = "TargetMesh") - call set_ele_nodes(mesh_b, 1, (/1, 2, 3/)) - - call allocate(positions_b, dim = 2, mesh = mesh_b, name = "TargetCoordinate") - call deallocate(mesh_b) - call set(positions_b, 1, (/0.0, 0.0/)) - call set(positions_b, 2, (/1.0, 0.0/)) - call set(positions_b, 3, (/0.0, 1.0/)) - - call allocate(mesh_c, nodes = 4, elements = 3, shape = shape_b, name = "Supermesh") - call deallocate(shape_b) - call set_ele_nodes(mesh_c, 1, (/1, 2, 4/)) - call set_ele_nodes(mesh_c, 2, (/4, 2, 3/)) - call set_ele_nodes(mesh_c, 3, (/3, 1, 4/)) - - call allocate(positions_c, dim = 2, mesh = mesh_c, name = "SupermeshCoordinate") - call deallocate(mesh_c) - call set(positions_c, 1, (/0.0, 0.0/)) - call set(positions_c, 2, (/1.0, 0.0/)) - call set(positions_c, 3, (/0.0, 1.0/)) - call set(positions_c, 4, (/0.25, 0.25/)) - - shape_mesh = make_mesh(positions_b%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") - call deallocate(shape_c) - - call project_target_shape_to_supermesh(1, & + use quadrature + use elements + use fetools + use fields + use fldebug + use supermesh_assembly + use unittest_tools + + implicit none + + integer :: degree, i + real, dimension(:), allocatable :: shape_rhs_integral_b, shape_rhs_integral_c + real, dimension(:, :), allocatable :: dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c + type(element_type) :: shape_b, shape_c + type(element_type), dimension(:), allocatable :: shapes_c + type(mesh_type) :: mesh_b, mesh_c, shape_mesh + type(quadrature_type) :: quad + type(vector_field) :: positions_b, positions_c + + do degree = 0, 4 + print *, "Degree = ", degree + + quad = make_quadrature(vertices = 3, dim = 2, degree = max(degree * 2, 1)) + shape_b = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) + shape_c = make_element_shape(vertices = 3, dim = 2, degree = degree, quad = quad) + call deallocate(quad) + + call allocate(mesh_b, nodes = 3, elements = 1, shape = shape_b, name = "TargetMesh") + call set_ele_nodes(mesh_b, 1, (/1, 2, 3/)) + + call allocate(positions_b, dim = 2, mesh = mesh_b, name = "TargetCoordinate") + call deallocate(mesh_b) + call set(positions_b, 1, (/0.0, 0.0/)) + call set(positions_b, 2, (/1.0, 0.0/)) + call set(positions_b, 3, (/0.0, 1.0/)) + + call allocate(mesh_c, nodes = 4, elements = 3, shape = shape_b, name = "Supermesh") + call deallocate(shape_b) + call set_ele_nodes(mesh_c, 1, (/1, 2, 4/)) + call set_ele_nodes(mesh_c, 2, (/4, 2, 3/)) + call set_ele_nodes(mesh_c, 3, (/3, 1, 4/)) + + call allocate(positions_c, dim = 2, mesh = mesh_c, name = "SupermeshCoordinate") + call deallocate(mesh_c) + call set(positions_c, 1, (/0.0, 0.0/)) + call set(positions_c, 2, (/1.0, 0.0/)) + call set(positions_c, 3, (/0.0, 1.0/)) + call set(positions_c, 4, (/0.25, 0.25/)) + + shape_mesh = make_mesh(positions_b%mesh, shape = shape_c, continuity = -1, name = "ShapeMesh") + call deallocate(shape_c) + + call project_target_shape_to_supermesh(1, & & positions_b, shape_mesh, positions_c, & & shapes_c, form_dn = .true.) - allocate(shape_rhs_integral_b(ele_loc(shape_mesh, 1))) - shape_rhs_integral_b = shape_rhs_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) + allocate(shape_rhs_integral_b(ele_loc(shape_mesh, 1))) + shape_rhs_integral_b = shape_rhs_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) - allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) - shape_rhs_integral_c = 0.0 - do i = 1, ele_count(positions_c) - shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(shape_rhs_integral_c(ele_loc(shape_mesh, 1))) + shape_rhs_integral_c = 0.0 + do i = 1, ele_count(positions_c) + shape_rhs_integral_c = shape_rhs_integral_c + shape_rhs_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[shape_rhs on supermesh]", shape_rhs_integral_b .fne. shape_rhs_integral_c, .false., "Incorrect integral") + call report_test("[shape_rhs on supermesh]", shape_rhs_integral_b .fne. shape_rhs_integral_c, .false., "Incorrect integral") - deallocate(shape_rhs_integral_b) - deallocate(shape_rhs_integral_c) + deallocate(shape_rhs_integral_b) + deallocate(shape_rhs_integral_c) - allocate(dshape_dot_dshape_integral_b(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_b = dshape_dot_dshape_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) + allocate(dshape_dot_dshape_integral_b(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_b = dshape_dot_dshape_integral_ele(1, positions_b, ele_shape(shape_mesh, 1)) - allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) - dshape_dot_dshape_integral_c = 0.0 - do i = 1, ele_count(positions_c) - dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) - end do + allocate(dshape_dot_dshape_integral_c(ele_loc(shape_mesh, 1), ele_loc(shape_mesh, 1))) + dshape_dot_dshape_integral_c = 0.0 + do i = 1, ele_count(positions_c) + dshape_dot_dshape_integral_c = dshape_dot_dshape_integral_c + dshape_dot_dshape_integral_ele(i, positions_c, shapes_c(i)) + end do - call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") + call report_test("[dshape_dot_dshape on supermesh]", fnequals(dshape_dot_dshape_integral_b, dshape_dot_dshape_integral_c, tol = 1.0e3 * epsilon(0.0)), .false., "Incorrect integral") - deallocate(dshape_dot_dshape_integral_b) - deallocate(dshape_dot_dshape_integral_c) + deallocate(dshape_dot_dshape_integral_b) + deallocate(dshape_dot_dshape_integral_c) - do i = 1, size(shapes_c) - call deallocate(shapes_c(i)) - end do - deallocate(shapes_c) + do i = 1, size(shapes_c) + call deallocate(shapes_c(i)) + end do + deallocate(shapes_c) - call deallocate(positions_b) - call deallocate(positions_c) - call deallocate(shape_mesh) + call deallocate(positions_b) + call deallocate(positions_c) + call deallocate(shape_mesh) - call report_test_no_references() - end do + call report_test_no_references() + end do contains - function shape_rhs_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function shape_rhs_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc) :: integral + real, dimension(shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - integral = shape_rhs(shape, detwei) + integral = shape_rhs(shape, detwei) - end function shape_rhs_integral_ele + end function shape_rhs_integral_ele - function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(element_type), intent(in) :: shape + function dshape_dot_dshape_integral_ele(ele, positions, shape) result(integral) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(element_type), intent(in) :: shape - real, dimension(shape%loc, shape%loc) :: integral + real, dimension(shape%loc, shape%loc) :: integral - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(shape%loc, ele_ngi(positions, ele), positions%dim) :: dn - call transform_to_physical(positions, ele, shape, & + call transform_to_physical(positions, ele, shape, & & dshape = dn, detwei = detwei) - integral = dshape_dot_dshape(dn, dn, detwei) + integral = dshape_dot_dshape(dn, dn, detwei) - end function dshape_dot_dshape_integral_ele + end function dshape_dot_dshape_integral_ele end subroutine test_supermesh_shapes_bc diff --git a/femtools/tests/test_surface_integrals_2d.F90 b/femtools/tests/test_surface_integrals_2d.F90 index a42f5d9180..4d8f1f6e15 100644 --- a/femtools/tests/test_surface_integrals_2d.F90 +++ b/femtools/tests/test_surface_integrals_2d.F90 @@ -28,233 +28,233 @@ #include "fdebug.h" subroutine test_surface_integrals_2d - !!< Test 2D surface integrals + !!< Test 2D surface integrals - use fldebug - use elements - use fields - use mesh_files - use surface_integrals - use unittest_tools + use fldebug + use elements + use fields + use mesh_files + use surface_integrals + use unittest_tools - implicit none + implicit none - integer :: i - real :: integral - real, dimension(:), allocatable :: pos - type(element_type) :: derived_shape - type(mesh_type) :: derived_mesh - type(scalar_field) :: test_s_field - type(vector_field) :: mesh_field, test_v_field, derived_mesh_field + integer :: i + real :: integral + real, dimension(:), allocatable :: pos + type(element_type) :: derived_shape + type(mesh_type) :: derived_mesh + type(scalar_field) :: test_s_field + type(vector_field) :: mesh_field, test_v_field, derived_mesh_field - mesh_field = read_mesh_files("data/square-cavity-2d", quad_degree = 4, format="gmsh") + mesh_field = read_mesh_files("data/square-cavity-2d", quad_degree = 4, format="gmsh") - assert(mesh_dim(mesh_field) == 2) + assert(mesh_dim(mesh_field) == 2) - call allocate(test_s_field, mesh_field%mesh, "TestScalar") + call allocate(test_s_field, mesh_field%mesh, "TestScalar") - call zero(test_s_field) + call zero(test_s_field) - integral = surface_integral(test_s_field, mesh_field) - call report_test("[Zero valued scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field) + call report_test("[Zero valued scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Zero valued scalar, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Zero valued scalar, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom - call report_test("[Zero valued scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom + call report_test("[Zero valued scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - call set(test_s_field, 1.0) + call set(test_s_field, 1.0) - integral = surface_integral(test_s_field, mesh_field) - call report_test("[Constant valued scalar, whole mesh]", integral .fne. 4.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field) + call report_test("[Constant valued scalar, whole mesh]", integral .fne. 4.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Constant valued scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Constant valued scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom - call report_test("[Constant valued scalar, multiple present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom + call report_test("[Constant valued scalar, multiple present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) - call report_test("[Constant valued scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) + call report_test("[Constant valued scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) - call report_test("[Constant valued scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) + call report_test("[Constant valued scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3, 6, 7/)) - call report_test("[Constant valued scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3, 6, 7/)) + call report_test("[Constant valued scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - allocate(pos(mesh_dim(mesh_field))) - do i = 1, node_count(mesh_field) - pos = node_val(mesh_field, i) - call set(test_s_field, i, pos(1)) - end do + allocate(pos(mesh_dim(mesh_field))) + do i = 1, node_count(mesh_field) + pos = node_val(mesh_field, i) + call set(test_s_field, i, pos(1)) + end do - integral = surface_integral(test_s_field, mesh_field) - call report_test("[Linearly varying scalar, whole mesh]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field) + call report_test("[Linearly varying scalar, whole mesh]", integral .fne. 2.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Linearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Linearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom - call report_test("[Linearly varying scalar, multiple present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom + call report_test("[Linearly varying scalar, multiple present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) - call report_test("[Linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) + call report_test("[Linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) - call report_test("[Linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) + call report_test("[Linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3, 6, 7/)) - call report_test("[Linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3, 6, 7/)) + call report_test("[Linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field) - call report_test("[Gradient of linearly varying scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field) + call report_test("[Gradient of linearly varying scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/4/)) ! Left - call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. -1.0, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/4/)) ! Left + call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. -1.0, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/5/)) ! Right - call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/5/)) ! Right + call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/4, 5/)) ! Left, right - call report_test("[Gradient of linearly varying scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/4, 5/)) ! Left, right + call report_test("[Gradient of linearly varying scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) - call report_test("[Gradient of linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) + call report_test("[Gradient of linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) - call report_test("[Gradient of linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) + call report_test("[Gradient of linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/5, 6, 7/)) - call report_test("[Gradient of linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/5, 6, 7/)) + call report_test("[Gradient of linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - do i = 1, node_count(mesh_field) - pos = node_val(mesh_field, i) - call set(test_s_field, i, pos(1) + pos(2)) - end do + do i = 1, node_count(mesh_field) + pos = node_val(mesh_field, i) + call set(test_s_field, i, pos(1) + pos(2)) + end do - integral = surface_integral(test_s_field, mesh_field) - call report_test("[Bilinearly varying scalar, whole mesh]", integral .fne. 4.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field) + call report_test("[Bilinearly varying scalar, whole mesh]", integral .fne. 4.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 1.5, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 1.5, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/3/)) ! Bottom - call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/3/)) ! Bottom + call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/4/)) ! Left - call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/4/)) ! Left + call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/5/)) ! Right - call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 1.5, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/5/)) ! Right + call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 1.5, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 5/)) ! Top, right - call report_test("[Bilinearly varying scalar, multiple present surface IDs]", integral .fne. 3.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 5/)) ! Top, right + call report_test("[Bilinearly varying scalar, multiple present surface IDs]", integral .fne. 3.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) - call report_test("[Bilinearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) + call report_test("[Bilinearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) - call report_test("[Bilinearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/6, 7/)) + call report_test("[Bilinearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3, 6, 7/)) - call report_test("[Bilinearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/2, 3, 6, 7/)) + call report_test("[Bilinearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - call deallocate(test_s_field) - call allocate(test_v_field, mesh_dim(mesh_field), mesh_field%mesh, "TestVector") + call deallocate(test_s_field) + call allocate(test_v_field, mesh_dim(mesh_field), mesh_field%mesh, "TestVector") - call zero(test_v_field) + call zero(test_v_field) - integral = normal_surface_integral(test_v_field, mesh_field) - call report_test("[Zero valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field) + call report_test("[Zero valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Zero valued vector, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Zero valued vector, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom - call report_test("[Zero valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom + call report_test("[Zero valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - call set(test_v_field, (/0.0, 1.0/)) + call set(test_v_field, (/0.0, 1.0/)) - integral = normal_surface_integral(test_v_field, mesh_field) - call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field) + call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/3/)) ! Bottom - call report_test("[Constant valued vector, single present surface ID]", integral .fne. -1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/3/)) ! Bottom + call report_test("[Constant valued vector, single present surface ID]", integral .fne. -1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom - call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom + call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6/)) - call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6/)) + call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 6, 7/)) - call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 6, 7/)) + call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6, 7/)) - call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6, 7/)) + call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - call set(test_v_field, (/1.0, 1.0/)) + call set(test_v_field, (/1.0, 1.0/)) - integral = normal_surface_integral(test_v_field, mesh_field) - call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field) + call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/3/)) ! Bottom - call report_test("[Constant valued vector, single present surface ID]", integral .fne. -1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/3/)) ! Bottom + call report_test("[Constant valued vector, single present surface ID]", integral .fne. -1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom - call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 3/)) ! Top, bottom + call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6/)) - call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6/)) + call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6, 7/)) - call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/6, 7/)) + call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 6, 7/)) - call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/2, 6, 7/)) + call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - call deallocate(test_v_field) + call deallocate(test_v_field) - call deallocate(mesh_field) + call deallocate(mesh_field) - mesh_field = read_mesh_files("data/square", quad_degree = 6, format="gmsh") + mesh_field = read_mesh_files("data/square", quad_degree = 6, format="gmsh") - derived_shape = make_element_shape(mesh_field%mesh%shape, degree = 2) - derived_mesh = make_mesh(mesh_field%mesh, derived_shape) - call deallocate(derived_shape) + derived_shape = make_element_shape(mesh_field%mesh%shape, degree = 2) + derived_mesh = make_mesh(mesh_field%mesh, derived_shape) + call deallocate(derived_shape) - call allocate(test_s_field, derived_mesh) - call allocate(derived_mesh_field, 2, derived_mesh) - call deallocate(derived_mesh) - call remap_field(mesh_field, derived_mesh_field) + call allocate(test_s_field, derived_mesh) + call allocate(derived_mesh_field, 2, derived_mesh) + call deallocate(derived_mesh) + call remap_field(mesh_field, derived_mesh_field) - do i = 1, node_count(derived_mesh_field) - pos = node_val(derived_mesh_field, i) - call set(test_s_field, i, pos(1)**2*pos(2)) - end do + do i = 1, node_count(derived_mesh_field) + pos = node_val(derived_mesh_field, i) + call set(test_s_field, i, pos(1)**2*pos(2)) + end do - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top - call report_test("[Gradient of cubic scalar on quadratic mesh]", integral .fne. 0.25, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/2/)) ! Top + call report_test("[Gradient of cubic scalar on quadratic mesh]", integral .fne. 0.25, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/4/)) ! Side - call report_test("[Gradient of cubic scalar on quadratic mesh]", integral .fne. 1.25, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/4/)) ! Side + call report_test("[Gradient of cubic scalar on quadratic mesh]", integral .fne. 1.25, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) ! Internal - call report_test("[Gradient of cubic scalar on quadratic mesh]", integral .fne. -0.5, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/6/)) ! Internal + call report_test("[Gradient of cubic scalar on quadratic mesh]", integral .fne. -0.5, .false., "Incorrect integral") - call deallocate(derived_mesh_field) - call deallocate(mesh_field) - call deallocate(test_s_field) + call deallocate(derived_mesh_field) + call deallocate(mesh_field) + call deallocate(test_s_field) - deallocate(pos) + deallocate(pos) end subroutine test_surface_integrals_2d diff --git a/femtools/tests/test_surface_integrals_3d.F90 b/femtools/tests/test_surface_integrals_3d.F90 index 115f92c51c..67efb166d6 100644 --- a/femtools/tests/test_surface_integrals_3d.F90 +++ b/femtools/tests/test_surface_integrals_3d.F90 @@ -28,185 +28,185 @@ #include "fdebug.h" subroutine test_surface_integrals_3d - !!< Test 3D surface integrals + !!< Test 3D surface integrals - use fldebug - use fields - use fields_data_types - use mesh_files - use surface_integrals - use unittest_tools + use fldebug + use fields + use fields_data_types + use mesh_files + use surface_integrals + use unittest_tools - implicit none + implicit none - integer :: i - real :: integral - real, dimension(:), allocatable :: pos - type(scalar_field) :: test_s_field - type(vector_field) :: mesh_field, test_v_field + integer :: i + real :: integral + real, dimension(:), allocatable :: pos + type(scalar_field) :: test_s_field + type(vector_field) :: mesh_field, test_v_field - mesh_field = read_mesh_files("data/square-cavity", quad_degree = 4, format="gmsh") - assert(mesh_dim(mesh_field) == 3) + mesh_field = read_mesh_files("data/square-cavity", quad_degree = 4, format="gmsh") + assert(mesh_dim(mesh_field) == 3) - call allocate(test_s_field, mesh_field%mesh, "TestScalar") + call allocate(test_s_field, mesh_field%mesh, "TestScalar") - call zero(test_s_field) + call zero(test_s_field) - integral = surface_integral(test_s_field, mesh_field) - call report_test("[Zero valued scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field) + call report_test("[Zero valued scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Zero valued scalar, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Zero valued scalar, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Zero valued scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Zero valued scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - call set(test_s_field, 1.0) + call set(test_s_field, 1.0) - integral = surface_integral(test_s_field, mesh_field) - call report_test("[Constant valued scalar, whole mesh]", integral .fne. 2.2, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field) + call report_test("[Constant valued scalar, whole mesh]", integral .fne. 2.2, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Constant valued scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Constant valued scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Constant valued scalar, multiple present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Constant valued scalar, multiple present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) - call report_test("[Constant valued scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) + call report_test("[Constant valued scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) - call report_test("[Constant valued scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) + call report_test("[Constant valued scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29, 34, 35/)) - call report_test("[Constant valued scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29, 34, 35/)) + call report_test("[Constant valued scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - allocate(pos(mesh_dim(mesh_field))) - do i = 1, node_count(mesh_field) - pos = node_val(mesh_field, i) - call set(test_s_field, i, pos(1)) - end do + allocate(pos(mesh_dim(mesh_field))) + do i = 1, node_count(mesh_field) + pos = node_val(mesh_field, i) + call set(test_s_field, i, pos(1)) + end do - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Linearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Linearly varying scalar, single present surface ID]", integral .fne. 0.5, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Linearly varying scalar, multiple present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Linearly varying scalar, multiple present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) - call report_test("[Linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) + call report_test("[Linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) - call report_test("[Linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) + call report_test("[Linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29, 34, 35/)) - call report_test("[Linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29, 34, 35/)) + call report_test("[Linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field) - call report_test("[Gradient of linearly varying scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field) + call report_test("[Gradient of linearly varying scalar, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/30/)) ! Left - call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. -0.05, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/30/)) ! Left + call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. -0.05, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/32/)) ! Right - call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. 0.05, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/32/)) ! Right + call report_test("[Gradient of linearly varying scalar, single present surface ID]", integral .fne. 0.05, .false., "Incorrect integral") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/30, 32/)) ! Left, right - call report_test("[Gradient of linearly varying scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/30, 32/)) ! Left, right + call report_test("[Gradient of linearly varying scalar, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) - call report_test("[Gradient of linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) + call report_test("[Gradient of linearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) - call report_test("[Gradient of linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) + call report_test("[Gradient of linearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/32, 34, 35/)) - call report_test("[Gradient of linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 0.05, .false., "Incorrect integral") + integral = gradient_normal_surface_integral(test_s_field, mesh_field, surface_ids = (/32, 34, 35/)) + call report_test("[Gradient of linearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 0.05, .false., "Incorrect integral") - do i = 1, node_count(mesh_field) - pos = node_val(mesh_field, i) - call set(test_s_field, i, pos(1) + pos(3)) - end do + do i = 1, node_count(mesh_field) + pos = node_val(mesh_field, i) + call set(test_s_field, i, pos(1) + pos(3)) + end do - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Bilinearly varying scalar, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Bilinearly varying scalar, multiple present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Bilinearly varying scalar, multiple present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) - call report_test("[Bilinearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34/)) + call report_test("[Bilinearly varying scalar, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) - call report_test("[Bilinearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/34, 35/)) + call report_test("[Bilinearly varying scalar, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29, 34, 35/)) - call report_test("[Bilinearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") + integral = surface_integral(test_s_field, mesh_field, surface_ids = (/28, 29, 34, 35/)) + call report_test("[Bilinearly varying scalar, mix of present and non-present surface IDs]", integral .fne. 2.0, .false., "Incorrect integral") - call deallocate(test_s_field) - call allocate(test_v_field, mesh_dim(mesh_field), mesh_field%mesh, "TestVector") + call deallocate(test_s_field) + call allocate(test_v_field, mesh_dim(mesh_field), mesh_field%mesh, "TestVector") - call zero(test_v_field) + call zero(test_v_field) - integral = normal_surface_integral(test_v_field, mesh_field) - call report_test("[Zero valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field) + call report_test("[Zero valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Zero valued vector, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Zero valued vector, single present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Zero valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Zero valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - call set(test_v_field, (/0.0, 1.0, 0.0/)) + call set(test_v_field, (/0.0, 1.0, 0.0/)) - integral = normal_surface_integral(test_v_field, mesh_field) - call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field) + call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/29/)) ! Back - call report_test("[Constant valued vector, single present surface ID]", integral .fne. - 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/29/)) ! Back + call report_test("[Constant valued vector, single present surface ID]", integral .fne. - 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34/)) - call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34/)) + call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34, 35/)) - call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34, 35/)) + call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 34, 35/)) - call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 34, 35/)) + call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - call set(test_v_field, (/1.0, 1.0, 1.0/)) + call set(test_v_field, (/1.0, 1.0, 1.0/)) - integral = normal_surface_integral(test_v_field, mesh_field) - call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field) + call report_test("[Constant valued vector, whole mesh]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28/)) ! Front - call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28/)) ! Front + call report_test("[Constant valued vector, single present surface ID]", integral .fne. 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/29/)) ! Back - call report_test("[Constant valued vector, single present surface ID]", integral .fne. - 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/29/)) ! Back + call report_test("[Constant valued vector, single present surface ID]", integral .fne. - 1.0, .false., "Incorrect integral") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back - call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 29/)) ! Front, back + call report_test("[Constant valued vector, multiple present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34/)) - call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34/)) + call report_test("[Constant valued vector, single non-present surface ID]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34, 35/)) - call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/34, 35/)) + call report_test("[Constant valued vector, multiple non-present surface IDs]", integral .fne. 0.0, .false., "Integral non-zero") - integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 34, 35/)) - call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") + integral = normal_surface_integral(test_v_field, mesh_field, surface_ids = (/28, 34, 35/)) + call report_test("[Constant valued vector, mix of present and non-present surface IDs]", integral .fne. 1.0, .false., "Incorrect integral") - call deallocate(test_v_field) + call deallocate(test_v_field) - deallocate(pos) + deallocate(pos) - call deallocate(mesh_field) + call deallocate(mesh_field) end subroutine test_surface_integrals_3d diff --git a/femtools/tests/test_tensor_second_invariant.F90 b/femtools/tests/test_tensor_second_invariant.F90 index 6f22a8ff4e..7bd6e95af1 100644 --- a/femtools/tests/test_tensor_second_invariant.F90 +++ b/femtools/tests/test_tensor_second_invariant.F90 @@ -1,86 +1,86 @@ subroutine test_tensor_second_invariant - use fields - use field_derivatives - use vtk_interfaces - use mesh_files - use state_module - use unittest_tools - implicit none - - type(scalar_field) :: solution_field, tensor_second_invariant_field, diff_field - type(tensor_field) :: field - type(mesh_type), pointer :: mesh - type(vector_field), target :: positions - logical :: fail - - interface - function strainrate(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos), size(pos)) :: strainrate - end function - function solution(pos) - real, dimension(:), intent(in) :: pos - real :: solution - end function - end interface - - positions=read_mesh_files("data/cube.3", quad_degree=4, format="gmsh") - mesh => positions%mesh - - call allocate(field, mesh, "Field") - call allocate(tensor_second_invariant_field, mesh, "TensorSecondInvariant") - call allocate(solution_field, mesh, "Solution") - call allocate(diff_field, mesh, "Difference") - - ! set our input strain rate - call set_from_function(field, strainrate, positions) - ! compute the second invariant of the strain rate tensor - call tensor_second_invariant(field, tensor_second_invariant_field) - ! now compute the expected solution - call set_from_function(solution_field, solution, positions) - - call set(diff_field, tensor_second_invariant_field) - call addto(diff_field, solution_field, scale=-1.0) - - call vtk_write_fields("data/tensor_second_invariant_out", 0, positions, mesh, & - sfields=(/ tensor_second_invariant_field, solution_field, diff_field /), & - tfields=(/ field /)) - - fail = maxval( abs( diff_field%val ))> 1e-10 - call report_test("[tensor_second_invariant]", fail, .false., "second invariant different than expected") + use fields + use field_derivatives + use vtk_interfaces + use mesh_files + use state_module + use unittest_tools + implicit none + + type(scalar_field) :: solution_field, tensor_second_invariant_field, diff_field + type(tensor_field) :: field + type(mesh_type), pointer :: mesh + type(vector_field), target :: positions + logical :: fail + + interface + function strainrate(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos), size(pos)) :: strainrate + end function + function solution(pos) + real, dimension(:), intent(in) :: pos + real :: solution + end function + end interface + + positions=read_mesh_files("data/cube.3", quad_degree=4, format="gmsh") + mesh => positions%mesh + + call allocate(field, mesh, "Field") + call allocate(tensor_second_invariant_field, mesh, "TensorSecondInvariant") + call allocate(solution_field, mesh, "Solution") + call allocate(diff_field, mesh, "Difference") + + ! set our input strain rate + call set_from_function(field, strainrate, positions) + ! compute the second invariant of the strain rate tensor + call tensor_second_invariant(field, tensor_second_invariant_field) + ! now compute the expected solution + call set_from_function(solution_field, solution, positions) + + call set(diff_field, tensor_second_invariant_field) + call addto(diff_field, solution_field, scale=-1.0) + + call vtk_write_fields("data/tensor_second_invariant_out", 0, positions, mesh, & + sfields=(/ tensor_second_invariant_field, solution_field, diff_field /), & + tfields=(/ field /)) + + fail = maxval( abs( diff_field%val ))> 1e-10 + call report_test("[tensor_second_invariant]", fail, .false., "second invariant different than expected") end subroutine test_tensor_second_invariant function strainrate(pos) - real, dimension(3,3) :: strainrate - real, dimension(:) :: pos - real :: x,y,z - x = pos(1); y = pos(2); z = pos(3) - - strainrate(1,1)=1*x*z - strainrate(1,2)=3*x - strainrate(1,3)=5*z - strainrate(2,1)=3*x - strainrate(2,2)=-2*x*z - strainrate(2,3)=7 - strainrate(3,1)=5*z - strainrate(3,2)=7 - strainrate(3,3)=1*x*z + real, dimension(3,3) :: strainrate + real, dimension(:) :: pos + real :: x,y,z + x = pos(1); y = pos(2); z = pos(3) + + strainrate(1,1)=1*x*z + strainrate(1,2)=3*x + strainrate(1,3)=5*z + strainrate(2,1)=3*x + strainrate(2,2)=-2*x*z + strainrate(2,3)=7 + strainrate(3,1)=5*z + strainrate(3,2)=7 + strainrate(3,3)=1*x*z end function strainrate function solution(pos) - real, dimension(:) :: pos - real :: solution - real :: x,y,z, sum + real, dimension(:) :: pos + real :: solution + real :: x,y,z, sum - x = pos(1); y = pos(2) ; z = pos(3) + x = pos(1); y = pos(2) ; z = pos(3) - sum = (1*x*z)**2 + (3*x)**2 + (5*z)**2 & + sum = (1*x*z)**2 + (3*x)**2 + (5*z)**2 & + (3*x)**2 + (-2*x*z)**2 + (7)**2 & + (5*z)**2 + (7)**2 + (1*x*z)**2 - solution = sqrt(sum / 2.) + solution = sqrt(sum / 2.) end function solution diff --git a/femtools/tests/test_tensor_spherical_polar_2_cartesian.F90 b/femtools/tests/test_tensor_spherical_polar_2_cartesian.F90 index 93f597a241..bb2d3c3f4f 100644 --- a/femtools/tests/test_tensor_spherical_polar_2_cartesian.F90 +++ b/femtools/tests/test_tensor_spherical_polar_2_cartesian.F90 @@ -25,60 +25,60 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_tensor_spherical_polar_2_cartesian - !Subroutine/unit-test of correct transformation of tensor components from a - ! spherical-polar system to a Cartesian system. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine/unit-test of correct transformation of tensor components from a + ! spherical-polar system to a Cartesian system. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(tensor_field), pointer :: tensor_cartesian - type(tensor_field), pointer :: tensor_sphericalPolar - type(tensor_field) :: difference - integer :: node - real, dimension(3) :: XYZ, RTP !Arrays containing a signle node's position vector - ! components in Cartesian & spherical-polar bases. - real, dimension(3,3) :: sphericalPolarComponents !Array containing the tensor - ! components in a spherical-polar basis, at - ! a sinlge point. - real, dimension(3,3) :: cartesianComponents !Array containing the tensor - ! components in a spherical-polar basis, at - ! a sinlge point. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(tensor_field), pointer :: tensor_cartesian + type(tensor_field), pointer :: tensor_sphericalPolar + type(tensor_field) :: difference + integer :: node + real, dimension(3) :: XYZ, RTP !Arrays containing a signle node's position vector + ! components in Cartesian & spherical-polar bases. + real, dimension(3,3) :: sphericalPolarComponents !Array containing the tensor + ! components in a spherical-polar basis, at + ! a sinlge point. + real, dimension(3,3) :: cartesianComponents !Array containing the tensor + ! components in a spherical-polar basis, at + ! a sinlge point. + logical :: fail - !Extract the vector fields of position in vtu file in polar coordinates and - ! cartesian coordiantes - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - tensor_cartesian => extract_tensor_field(state, "Tensor_inCartesian") - tensor_sphericalPolar => extract_tensor_field(state, "Tensor_inPolar") + !Extract the vector fields of position in vtu file in polar coordinates and + ! cartesian coordiantes + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + tensor_cartesian => extract_tensor_field(state, "Tensor_inCartesian") + tensor_sphericalPolar => extract_tensor_field(state, "Tensor_inPolar") - !Apply transformation to spherical-polar components and compare with components - ! in Cartesian basis. - call allocate(difference, mesh, 'difference') - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - sphericalPolarComponents = node_val(tensor_sphericalPolar, node) - call tensor_spherical_polar_2_cartesian(sphericalPolarComponents, & - RTP(1), RTP(2), RTP(3), & - cartesianComponents, & - XYZ(1), XYZ(2), XYZ(3)) - call set(difference, node, cartesianComponents) - enddo - call addto(difference, tensor_cartesian, -1.0) + !Apply transformation to spherical-polar components and compare with components + ! in Cartesian basis. + call allocate(difference, mesh, 'difference') + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + sphericalPolarComponents = node_val(tensor_sphericalPolar, node) + call tensor_spherical_polar_2_cartesian(sphericalPolarComponents, & + RTP(1), RTP(2), RTP(3), & + cartesianComponents, & + XYZ(1), XYZ(2), XYZ(3)) + call set(difference, node, cartesianComponents) + enddo + call addto(difference, tensor_cartesian, -1.0) - fail = any(difference%val > 1e-8) - call report_test("[Tensor change of basis: Spherical-polar to Cartesian.]", & - fail, .false., "Tensor components not transformed correctly.") + fail = any(difference%val > 1e-8) + call report_test("[Tensor change of basis: Spherical-polar to Cartesian.]", & + fail, .false., "Tensor components not transformed correctly.") - call deallocate(difference) + call deallocate(difference) end subroutine diff --git a/femtools/tests/test_tensormul.F90 b/femtools/tests/test_tensormul.F90 index 35399131f1..a77bb13d3c 100644 --- a/femtools/tests/test_tensormul.F90 +++ b/femtools/tests/test_tensormul.F90 @@ -1,49 +1,49 @@ subroutine test_tensormul - use tensors - use unittest_tools - implicit none + use tensors + use unittest_tools + implicit none - real, dimension(4, 5, 6, 7) :: tensorA - real, dimension(6) :: vec6 - real, dimension(7) :: vec7 + real, dimension(4, 5, 6, 7) :: tensorA + real, dimension(6) :: vec6 + real, dimension(7) :: vec7 - real, dimension(4, 5, 7) :: resA - real, dimension(4, 5, 6) :: resB + real, dimension(4, 5, 7) :: resA + real, dimension(4, 5, 6) :: resB - real, dimension(2, 2, 2, 2) :: tensorB - real, dimension(2) :: vec2 + real, dimension(2, 2, 2, 2) :: tensorB + real, dimension(2) :: vec2 - real, dimension(2, 2, 2) :: resC + real, dimension(2, 2, 2) :: resC - logical :: fail + logical :: fail - tensorA = 1.0 ; vec6 = 1.0 ; vec7 = 1.0 + tensorA = 1.0 ; vec6 = 1.0 ; vec7 = 1.0 - resA = tensormul(tensorA, vec6, 3) + resA = tensormul(tensorA, vec6, 3) - fail = .false. - if (any(resA /= 6.0)) fail = .true. + fail = .false. + if (any(resA /= 6.0)) fail = .true. - call report_test("[tensormul_4_1]", fail, .false., "Tensormul should give & - & known output for known input.") + call report_test("[tensormul_4_1]", fail, .false., "Tensormul should give & + & known output for known input.") - resB = tensormul(tensorA, vec7, 4) + resB = tensormul(tensorA, vec7, 4) - fail = .false. - if (any(resB /= 7.0)) fail = .true. + fail = .false. + if (any(resB /= 7.0)) fail = .true. - call report_test("[tensormul_4_1]", fail, .false., "Tensormul should give & - & known output for known input.") + call report_test("[tensormul_4_1]", fail, .false., "Tensormul should give & + & known output for known input.") - tensorB = 1.0 ; vec2 = 1.0 + tensorB = 1.0 ; vec2 = 1.0 - resC = tensormul(tensorB, vec2, 3) + resC = tensormul(tensorB, vec2, 3) - fail = .false. - if (any(resC /= 2.0)) fail = .true. + fail = .false. + if (any(resC /= 2.0)) fail = .true. - call report_test("[tensormul_4_1]", fail, .false., "Tensormul should give & - & known output for known input.") + call report_test("[tensormul_4_1]", fail, .false., "Tensormul should give & + & known output for known input.") end subroutine test_tensormul diff --git a/femtools/tests/test_tet_intersector.F90 b/femtools/tests/test_tet_intersector.F90 index 3a775a86aa..2bf70ec479 100644 --- a/femtools/tests/test_tet_intersector.F90 +++ b/femtools/tests/test_tet_intersector.F90 @@ -1,61 +1,61 @@ subroutine test_tet_intersector - use mesh_files - use tetrahedron_intersection_module - use supermesh_construction - use fields - use unittest_tools - implicit none - - type(vector_field) :: positionsA, positionsB - type(vector_field) :: libwm, fort - integer :: ele_A, ele_B, ele_C - real :: vol_libwm, vol_fort - logical :: fail - integer :: stat - type(tet_type) :: tet_A, tet_B - type(plane_type), dimension(4) :: planes_B - - positionsA = read_mesh_files("data/plcA", quad_degree=4, format="gmsh") - positionsB = read_mesh_files("data/plcB", quad_degree=4, format="gmsh") - - call intersector_set_dimension(3) - call intersector_set_exactness(.false.) - - do ele_A=1,ele_count(positionsA) - do ele_B=1,ele_count(positionsB) - libwm = intersect_elements(positionsB, ele_B, ele_val(positionsA, ele_A), ele_shape(positionsB, 1)) - tet_A%v = ele_val(positionsA, ele_A) - tet_B%v = ele_val(positionsB, ele_B) - planes_B = get_planes(tet_B) - call intersect_tets(tet_A, planes_B, shape=ele_shape(positionsB, 1), stat=stat, output=fort) - - fail = (ele_count(libwm) /= ele_count(fort)) + use mesh_files + use tetrahedron_intersection_module + use supermesh_construction + use fields + use unittest_tools + implicit none + + type(vector_field) :: positionsA, positionsB + type(vector_field) :: libwm, fort + integer :: ele_A, ele_B, ele_C + real :: vol_libwm, vol_fort + logical :: fail + integer :: stat + type(tet_type) :: tet_A, tet_B + type(plane_type), dimension(4) :: planes_B + + positionsA = read_mesh_files("data/plcA", quad_degree=4, format="gmsh") + positionsB = read_mesh_files("data/plcB", quad_degree=4, format="gmsh") + + call intersector_set_dimension(3) + call intersector_set_exactness(.false.) + + do ele_A=1,ele_count(positionsA) + do ele_B=1,ele_count(positionsB) + libwm = intersect_elements(positionsB, ele_B, ele_val(positionsA, ele_A), ele_shape(positionsB, 1)) + tet_A%v = ele_val(positionsA, ele_A) + tet_B%v = ele_val(positionsB, ele_B) + planes_B = get_planes(tet_B) + call intersect_tets(tet_A, planes_B, shape=ele_shape(positionsB, 1), stat=stat, output=fort) + + fail = (ele_count(libwm) /= ele_count(fort)) ! call report_test("[tet_intersector counts]", fail, .false., "Should give the same number of elements") - vol_libwm = 0.0 - do ele_C=1,ele_count(libwm) - vol_libwm = vol_libwm + abs(simplex_volume(libwm, ele_C)) + vol_libwm = 0.0 + do ele_C=1,ele_count(libwm) + vol_libwm = vol_libwm + abs(simplex_volume(libwm, ele_C)) + end do + vol_fort = 0.0 + if (stat == 0) then + do ele_C=1,ele_count(fort) + vol_fort = vol_fort + abs(simplex_volume(fort, ele_C)) + end do + end if + + fail = (vol_libwm .fne. vol_fort) + call report_test("[tet_intersector volumes]", fail, .false., "Should give the same volumes of intersection") + + if (has_references(libwm)) then + call deallocate(libwm) + end if + if (stat == 0) then + call deallocate(fort) + end if end do - vol_fort = 0.0 - if (stat == 0) then - do ele_C=1,ele_count(fort) - vol_fort = vol_fort + abs(simplex_volume(fort, ele_C)) - end do - end if - - fail = (vol_libwm .fne. vol_fort) - call report_test("[tet_intersector volumes]", fail, .false., "Should give the same volumes of intersection") - - if (has_references(libwm)) then - call deallocate(libwm) - end if - if (stat == 0) then - call deallocate(fort) - end if - end do - end do - call deallocate(positionsA) - call deallocate(positionsB) + end do + call deallocate(positionsA) + call deallocate(positionsB) end subroutine test_tet_intersector diff --git a/femtools/tests/test_tictoc.F90 b/femtools/tests/test_tictoc.F90 index cd3ab3f14d..5fb2a03785 100644 --- a/femtools/tests/test_tictoc.F90 +++ b/femtools/tests/test_tictoc.F90 @@ -1,23 +1,23 @@ subroutine test_tictoc - use tictoc - use unittest_tools + use tictoc + use unittest_tools - implicit none + implicit none - real :: current_cpu_time, start_cpu_time + real :: current_cpu_time, start_cpu_time - call tictoc_reset() - call tic(TICTOC_ID_SIMULATION) + call tictoc_reset() + call tic(TICTOC_ID_SIMULATION) - call cpu_time(start_cpu_time) - current_cpu_time = start_cpu_time - do while(current_cpu_time - start_cpu_time < 0.1) - call cpu_time(current_cpu_time) - end do + call cpu_time(start_cpu_time) + current_cpu_time = start_cpu_time + do while(current_cpu_time - start_cpu_time < 0.1) + call cpu_time(current_cpu_time) + end do - call toc(TICTOC_ID_SIMULATION) + call toc(TICTOC_ID_SIMULATION) - call report_test("[tictoc]", tictoc_time(TICTOC_ID_SIMULATION) < epsilon(0.0), .false., "Tictoc did not time") + call report_test("[tictoc]", tictoc_time(TICTOC_ID_SIMULATION) < epsilon(0.0), .false., "Tictoc did not time") end subroutine test_tictoc diff --git a/femtools/tests/test_tokenize.F90 b/femtools/tests/test_tokenize.F90 index 6c886dfa25..7598e337e6 100644 --- a/femtools/tests/test_tokenize.F90 +++ b/femtools/tests/test_tokenize.F90 @@ -29,36 +29,36 @@ subroutine test_tokenize - use fldebug - use futils - use unittest_tools + use fldebug + use futils + use unittest_tools - implicit none + implicit none - character(len = 255), dimension(:), allocatable :: tokens + character(len = 255), dimension(:), allocatable :: tokens - call tokenize("One:Two:Three", tokens, ":") - call report_test("[allocated(tokens)]", .not. allocated(tokens), .false., "tokens not allocated") - call report_test("[size(tokens)]", size(tokens) /= 3, .false., "Incorrect tokens size") - call report_test("[tokens(1)]", trim(tokens(1)) /= "One", .false., "Incorrect split") - call report_test("[tokens(2)]", trim(tokens(2)) /= "Two", .false., "Incorrect split") - call report_test("[tokens(3)]", trim(tokens(3)) /= "Three", .false., "Incorrect split") - deallocate(tokens) + call tokenize("One:Two:Three", tokens, ":") + call report_test("[allocated(tokens)]", .not. allocated(tokens), .false., "tokens not allocated") + call report_test("[size(tokens)]", size(tokens) /= 3, .false., "Incorrect tokens size") + call report_test("[tokens(1)]", trim(tokens(1)) /= "One", .false., "Incorrect split") + call report_test("[tokens(2)]", trim(tokens(2)) /= "Two", .false., "Incorrect split") + call report_test("[tokens(3)]", trim(tokens(3)) /= "Three", .false., "Incorrect split") + deallocate(tokens) - call tokenize("One::Two::Three", tokens, "::") - call report_test("[allocated(tokens)]", .not. allocated(tokens), .false., "tokens not allocated") - call report_test("[size(tokens)]", size(tokens) /= 3, .false., "Incorrect tokens size") - call report_test("[tokens(1)]", trim(tokens(1)) /= "One", .false., "Incorrect split") - call report_test("[tokens(2)]", trim(tokens(2)) /= "Two", .false., "Incorrect split") - call report_test("[tokens(3)]", trim(tokens(3)) /= "Three", .false., "Incorrect split") - deallocate(tokens) + call tokenize("One::Two::Three", tokens, "::") + call report_test("[allocated(tokens)]", .not. allocated(tokens), .false., "tokens not allocated") + call report_test("[size(tokens)]", size(tokens) /= 3, .false., "Incorrect tokens size") + call report_test("[tokens(1)]", trim(tokens(1)) /= "One", .false., "Incorrect split") + call report_test("[tokens(2)]", trim(tokens(2)) /= "Two", .false., "Incorrect split") + call report_test("[tokens(3)]", trim(tokens(3)) /= "Three", .false., "Incorrect split") + deallocate(tokens) - call tokenize("One:::Two:::Three", tokens, ":::") - call report_test("[allocated(tokens)]", .not. allocated(tokens), .false., "tokens not allocated") - call report_test("[size(tokens)]", size(tokens) /= 3, .false., "Incorrect tokens size") - call report_test("[tokens(1)]", trim(tokens(1)) /= "One", .false., "Incorrect split") - call report_test("[tokens(2)]", trim(tokens(2)) /= "Two", .false., "Incorrect split") - call report_test("[tokens(3)]", trim(tokens(3)) /= "Three", .false., "Incorrect split") - deallocate(tokens) + call tokenize("One:::Two:::Three", tokens, ":::") + call report_test("[allocated(tokens)]", .not. allocated(tokens), .false., "tokens not allocated") + call report_test("[size(tokens)]", size(tokens) /= 3, .false., "Incorrect tokens size") + call report_test("[tokens(1)]", trim(tokens(1)) /= "One", .false., "Incorrect split") + call report_test("[tokens(2)]", trim(tokens(2)) /= "Two", .false., "Incorrect split") + call report_test("[tokens(3)]", trim(tokens(3)) /= "Three", .false., "Incorrect split") + deallocate(tokens) end subroutine test_tokenize diff --git a/femtools/tests/test_u_dot_nabla.F90 b/femtools/tests/test_u_dot_nabla.F90 index 0e4c09ea3c..f43197500b 100644 --- a/femtools/tests/test_u_dot_nabla.F90 +++ b/femtools/tests/test_u_dot_nabla.F90 @@ -4,60 +4,60 @@ subroutine test_u_dot_nabla - use fldebug - use field_derivatives - use fields - use fields_data_types - use state_module - use unittest_tools - use vtk_interfaces - - implicit none - - character(len = 32) :: buffer - integer :: i - real :: max_norm, max_val - real, dimension(3) :: pos - type(mesh_type), pointer :: mesh - type(state_type) :: state - type(vector_field) :: u_dot_nabla_field, vel_field - type(vector_field), pointer :: positions - - call vtk_read_state("data/pseudo2d.vtu", state) - mesh => extract_mesh(state, "Mesh") - assert(mesh_dim(mesh) == 3) - - call allocate(u_dot_nabla_field, 3, mesh, "UDotNabla") - call allocate(vel_field, 3, mesh, "Velocity") - - positions => extract_vector_field(state, "Coordinate") - do i = 1, node_count(vel_field) - pos = node_val(positions, i) - call set(vel_field, i, (/pos(2), pos(1), 0.0/)) - end do - - call u_dot_nabla(vel_field, vel_field, positions, u_dot_nabla_field) - - call vtk_write_fields("data/test_u_dot_nabla_out", 0, positions, mesh, & - & vfields = (/positions, u_dot_nabla_field, vel_field/)) - - max_val = 0.0 - max_norm = 0.0 - do i = 1, node_count(u_dot_nabla_field) - pos = node_val(positions, i) - max_norm = max(max_norm, norm2(node_val(u_dot_nabla_field, i))) - max_val = max(max_val, & + use fldebug + use field_derivatives + use fields + use fields_data_types + use state_module + use unittest_tools + use vtk_interfaces + + implicit none + + character(len = 32) :: buffer + integer :: i + real :: max_norm, max_val + real, dimension(3) :: pos + type(mesh_type), pointer :: mesh + type(state_type) :: state + type(vector_field) :: u_dot_nabla_field, vel_field + type(vector_field), pointer :: positions + + call vtk_read_state("data/pseudo2d.vtu", state) + mesh => extract_mesh(state, "Mesh") + assert(mesh_dim(mesh) == 3) + + call allocate(u_dot_nabla_field, 3, mesh, "UDotNabla") + call allocate(vel_field, 3, mesh, "Velocity") + + positions => extract_vector_field(state, "Coordinate") + do i = 1, node_count(vel_field) + pos = node_val(positions, i) + call set(vel_field, i, (/pos(2), pos(1), 0.0/)) + end do + + call u_dot_nabla(vel_field, vel_field, positions, u_dot_nabla_field) + + call vtk_write_fields("data/test_u_dot_nabla_out", 0, positions, mesh, & + & vfields = (/positions, u_dot_nabla_field, vel_field/)) + + max_val = 0.0 + max_norm = 0.0 + do i = 1, node_count(u_dot_nabla_field) + pos = node_val(positions, i) + max_norm = max(max_norm, norm2(node_val(u_dot_nabla_field, i))) + max_val = max(max_val, & & norm2((/pos(1), pos(2), 0.0/) - node_val(u_dot_nabla_field, i))) - end do + end do - write(buffer, *) max_val - call report_test("[(u dot nabla) test: Solid body rotation]", & - & fnequals(max_val, 0.0, tol = spacing(max_norm) * 100.0), .false., & - & "(u dot nabla) u /= r - Max. difference norm2: " // buffer) + write(buffer, *) max_val + call report_test("[(u dot nabla) test: Solid body rotation]", & + & fnequals(max_val, 0.0, tol = spacing(max_norm) * 100.0), .false., & + & "(u dot nabla) u /= r - Max. difference norm2: " // buffer) - call deallocate(u_dot_nabla_field) - call deallocate(vel_field) + call deallocate(u_dot_nabla_field) + call deallocate(vel_field) - call deallocate(state) + call deallocate(state) end subroutine test_u_dot_nabla diff --git a/femtools/tests/test_unify_meshes.F90 b/femtools/tests/test_unify_meshes.F90 index 3189eb7acd..4ef7c24a45 100644 --- a/femtools/tests/test_unify_meshes.F90 +++ b/femtools/tests/test_unify_meshes.F90 @@ -3,94 +3,94 @@ subroutine test_unify_meshes - use fldebug - use unittest_tools - use mesh_files - use quadrature - use elements - use fields - use linked_lists - use intersection_finder_module - use transform_elements - use elements - use supermesh_construction - use vtk_interfaces - use unify_meshes_module - - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(:), allocatable :: map_BA - real, dimension(:), allocatable :: quad_detwei, tri_detwei - integer :: ele_A, ele_B, ele_C - real :: vol_B, vols_C, total_B, total_C - logical :: fail, empty_intersection - type(element_type), pointer :: shape - type(inode), pointer :: llnode - type(vector_field) :: intersection - type(element_type) :: supermesh_shape - type(quadrature_type) :: supermesh_quad - integer :: dim - - type(mesh_type) :: accum_mesh - type(vector_field) :: accum_positions, accum_positions_tmp - - positionsA = read_mesh_files("data/dg_interpolation_quads_A", quad_degree=1, format="gmsh") - positionsB = read_mesh_files("data/dg_interpolation_quads_B", quad_degree=1, format="gmsh") - - dim = positionsA%dim - - allocate(map_BA(ele_count(positionsB))) - allocate(quad_detwei(ele_ngi(positionsA, 1))) - shape => ele_shape(positionsA, 1) - assert(sum(shape%quadrature%weight) == 4) - - supermesh_quad = make_quadrature(vertices = dim+1, dim =dim, degree=5) - supermesh_shape = make_element_shape(vertices = dim+1, dim =dim, degree=1, quad=supermesh_quad) - allocate(tri_detwei(supermesh_shape%ngi)) - - call allocate(accum_mesh, 0, 0, supermesh_shape, "AccumulatedMesh") - call allocate(accum_positions, dim, accum_mesh, "AccumulatedPositions") - - total_B = 0.0 - - map_BA = intersection_finder(positionsB, positionsA) - call intersector_set_dimension(dim) - - do ele_B=1,ele_count(positionsB) - call transform_to_physical(positionsB, ele_B, detwei=quad_detwei) - vol_B = sum(quad_detwei) - - llnode => map_BA(ele_B)%firstnode - vols_C = 0.0 - do while(associated(llnode)) - ele_A = llnode%value - intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), supermesh_shape, empty_intersection=empty_intersection) - if (empty_intersection) then - llnode => llnode%next - cycle - end if - - call unify_meshes_quadratic(accum_positions, intersection, accum_positions_tmp) - call deallocate(accum_positions) - accum_positions = accum_positions_tmp - - llnode => llnode%next - - call deallocate(intersection) - end do - - total_B = total_B + vol_B - end do - - total_C = 0.0 - do ele_C=1,ele_count(accum_positions) - call transform_to_physical(accum_positions, ele_C, detwei=tri_detwei) - vols_C = sum(tri_detwei) - total_C = total_C + vols_C - end do - - fail = total_B .fne. total_C - call report_test("[unify meshes: completeness]", fail, .false., "Need to have the same volume!") - - call vtk_write_fields("unified_mesh", 0, accum_positions, accum_positions%mesh) + use fldebug + use unittest_tools + use mesh_files + use quadrature + use elements + use fields + use linked_lists + use intersection_finder_module + use transform_elements + use elements + use supermesh_construction + use vtk_interfaces + use unify_meshes_module + + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(:), allocatable :: map_BA + real, dimension(:), allocatable :: quad_detwei, tri_detwei + integer :: ele_A, ele_B, ele_C + real :: vol_B, vols_C, total_B, total_C + logical :: fail, empty_intersection + type(element_type), pointer :: shape + type(inode), pointer :: llnode + type(vector_field) :: intersection + type(element_type) :: supermesh_shape + type(quadrature_type) :: supermesh_quad + integer :: dim + + type(mesh_type) :: accum_mesh + type(vector_field) :: accum_positions, accum_positions_tmp + + positionsA = read_mesh_files("data/dg_interpolation_quads_A", quad_degree=1, format="gmsh") + positionsB = read_mesh_files("data/dg_interpolation_quads_B", quad_degree=1, format="gmsh") + + dim = positionsA%dim + + allocate(map_BA(ele_count(positionsB))) + allocate(quad_detwei(ele_ngi(positionsA, 1))) + shape => ele_shape(positionsA, 1) + assert(sum(shape%quadrature%weight) == 4) + + supermesh_quad = make_quadrature(vertices = dim+1, dim =dim, degree=5) + supermesh_shape = make_element_shape(vertices = dim+1, dim =dim, degree=1, quad=supermesh_quad) + allocate(tri_detwei(supermesh_shape%ngi)) + + call allocate(accum_mesh, 0, 0, supermesh_shape, "AccumulatedMesh") + call allocate(accum_positions, dim, accum_mesh, "AccumulatedPositions") + + total_B = 0.0 + + map_BA = intersection_finder(positionsB, positionsA) + call intersector_set_dimension(dim) + + do ele_B=1,ele_count(positionsB) + call transform_to_physical(positionsB, ele_B, detwei=quad_detwei) + vol_B = sum(quad_detwei) + + llnode => map_BA(ele_B)%firstnode + vols_C = 0.0 + do while(associated(llnode)) + ele_A = llnode%value + intersection = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), supermesh_shape, empty_intersection=empty_intersection) + if (empty_intersection) then + llnode => llnode%next + cycle + end if + + call unify_meshes_quadratic(accum_positions, intersection, accum_positions_tmp) + call deallocate(accum_positions) + accum_positions = accum_positions_tmp + + llnode => llnode%next + + call deallocate(intersection) + end do + + total_B = total_B + vol_B + end do + + total_C = 0.0 + do ele_C=1,ele_count(accum_positions) + call transform_to_physical(accum_positions, ele_C, detwei=tri_detwei) + vols_C = sum(tri_detwei) + total_C = total_C + vols_C + end do + + fail = total_B .fne. total_C + call report_test("[unify meshes: completeness]", fail, .false., "Need to have the same volume!") + + call vtk_write_fields("unified_mesh", 0, accum_positions, accum_positions%mesh) end subroutine test_unify_meshes diff --git a/femtools/tests/test_vecset.F90 b/femtools/tests/test_vecset.F90 index 25afaeade0..00338e6c86 100644 --- a/femtools/tests/test_vecset.F90 +++ b/femtools/tests/test_vecset.F90 @@ -1,20 +1,20 @@ subroutine test_vecset - use vector_set - use unittest_tools - implicit none + use vector_set + use unittest_tools + implicit none - integer :: idx - logical :: path_taken - logical :: fail + integer :: idx + logical :: path_taken + logical :: fail - call vecset_create(idx) - call vecset_add(idx, (/float(15210), float(15211)/), path_taken) - fail = path_taken - call report_test("[vector_set]", fail, .false., "path_taken should be false") - call vecset_add(idx, (/float(15210), float(15211)/), path_taken) - fail = .not. path_taken - call report_test("[vector_set]", fail, .false., "path_taken should be true") - call vecset_destroy(idx) + call vecset_create(idx) + call vecset_add(idx, (/float(15210), float(15211)/), path_taken) + fail = path_taken + call report_test("[vector_set]", fail, .false., "path_taken should be false") + call vecset_add(idx, (/float(15210), float(15211)/), path_taken) + fail = .not. path_taken + call report_test("[vector_set]", fail, .false., "path_taken should be true") + call vecset_destroy(idx) end subroutine test_vecset diff --git a/femtools/tests/test_vector_cartesian_2_lon_lat_height.F90 b/femtools/tests/test_vector_cartesian_2_lon_lat_height.F90 index 2643f341b9..1dcd5b7124 100644 --- a/femtools/tests/test_vector_cartesian_2_lon_lat_height.F90 +++ b/femtools/tests/test_vector_cartesian_2_lon_lat_height.F90 @@ -25,136 +25,136 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_cartesian_2_lon_lat_height - !Subroutine/unit-test of correct vector basis change from a - ! Cartesian system to a meridional-zonal-vertical system. + !Subroutine/unit-test of correct vector basis change from a + ! Cartesian system to a meridional-zonal-vertical system. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial - type(vector_field) :: radialVectorDifference, & - polarVectorDifference, & - azimuthalVectorDifference - real, dimension(3) :: meridionalZonalVerticalVectorComponents, & - cartesianVectorComponents - real, dimension(3) :: XYZ, LLH !Arrays containing a signle node's position vector - ! components in Cartesian & lon-lat-height bases. - integer :: node - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial + type(vector_field) :: radialVectorDifference, & + polarVectorDifference, & + azimuthalVectorDifference + real, dimension(3) :: meridionalZonalVerticalVectorComponents, & + cartesianVectorComponents + real, dimension(3) :: XYZ, LLH !Arrays containing a signle node's position vector + ! components in Cartesian & lon-lat-height bases. + integer :: node + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitRadialVector_inZonalMeridionalRadial") - UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitPolarVector_inZonalMeridionalRadial") - UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitAzimuthalVector_inZonalMeridionalRadial") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitRadialVector_inZonalMeridionalRadial") + UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitPolarVector_inZonalMeridionalRadial") + UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitAzimuthalVector_inZonalMeridionalRadial") - call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') - call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') - call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') + call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') + call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') + call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') - !Convert unit-radial vector components into zonal-meridional-vertical basis. - ! Then compare with vector already in that basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = & - node_val(UnitRadialVector_inCartesian, node) - call vector_cartesian_2_lon_lat_height(cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3), & - meridionalZonalVerticalVectorComponents(1), & - meridionalZonalVerticalVectorComponents(2), & - meridionalZonalVerticalVectorComponents(3), & - LLH(1), & - LLH(2), & - LLH(3)) - call set(radialVectorDifference, node, meridionalZonalVerticalVectorComponents) - enddo - call addto(radialVectorDifference, UnitRadialVector_inZonalMeridionalRadial, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-radial vector.]", & - fail, .false., "Radial unit vector components not transformed correctly.") + !Convert unit-radial vector components into zonal-meridional-vertical basis. + ! Then compare with vector already in that basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = & + node_val(UnitRadialVector_inCartesian, node) + call vector_cartesian_2_lon_lat_height(cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3), & + meridionalZonalVerticalVectorComponents(1), & + meridionalZonalVerticalVectorComponents(2), & + meridionalZonalVerticalVectorComponents(3), & + LLH(1), & + LLH(2), & + LLH(3)) + call set(radialVectorDifference, node, meridionalZonalVerticalVectorComponents) + enddo + call addto(radialVectorDifference, UnitRadialVector_inZonalMeridionalRadial, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-radial vector.]", & + fail, .false., "Radial unit vector components not transformed correctly.") - !Convert unit-polar vector components into zonal-meridional-vertical basis. - ! Then compare with vector already in that basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = & - node_val(UnitPolarVector_inCartesian, node) - call vector_cartesian_2_lon_lat_height(cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3), & - meridionalZonalVerticalVectorComponents(1), & - meridionalZonalVerticalVectorComponents(2), & - meridionalZonalVerticalVectorComponents(3), & - LLH(1), & - LLH(2), & - LLH(3)) - call set(polarVectorDifference, node, meridionalZonalVerticalVectorComponents) - enddo - call addto(polarVectorDifference, UnitPolarVector_inZonalMeridionalRadial, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-polar vector.]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Convert unit-polar vector components into zonal-meridional-vertical basis. + ! Then compare with vector already in that basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = & + node_val(UnitPolarVector_inCartesian, node) + call vector_cartesian_2_lon_lat_height(cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3), & + meridionalZonalVerticalVectorComponents(1), & + meridionalZonalVerticalVectorComponents(2), & + meridionalZonalVerticalVectorComponents(3), & + LLH(1), & + LLH(2), & + LLH(3)) + call set(polarVectorDifference, node, meridionalZonalVerticalVectorComponents) + enddo + call addto(polarVectorDifference, UnitPolarVector_inZonalMeridionalRadial, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-polar vector.]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Convert unit-azimuthal vector components into zonal-meridional-vertical basis. - ! Then compare with vector already in that basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = & - node_val(UnitAzimuthalVector_inCartesian, node) - call vector_cartesian_2_lon_lat_height(cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3), & - meridionalZonalVerticalVectorComponents(1), & - meridionalZonalVerticalVectorComponents(2), & - meridionalZonalVerticalVectorComponents(3), & - LLH(1), & - LLH(2), & - LLH(3)) - call set(azimuthalVectorDifference, node, meridionalZonalVerticalVectorComponents) - enddo - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inZonalMeridionalRadial, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-azimuthal vector.]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Convert unit-azimuthal vector components into zonal-meridional-vertical basis. + ! Then compare with vector already in that basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = & + node_val(UnitAzimuthalVector_inCartesian, node) + call vector_cartesian_2_lon_lat_height(cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3), & + meridionalZonalVerticalVectorComponents(1), & + meridionalZonalVerticalVectorComponents(2), & + meridionalZonalVerticalVectorComponents(3), & + LLH(1), & + LLH(2), & + LLH(3)) + call set(azimuthalVectorDifference, node, meridionalZonalVerticalVectorComponents) + enddo + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inZonalMeridionalRadial, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-azimuthal vector.]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vector_cartesian_2_lon_lat_height_c.F90 b/femtools/tests/test_vector_cartesian_2_lon_lat_height_c.F90 index 0a8cec3968..497d740c3c 100644 --- a/femtools/tests/test_vector_cartesian_2_lon_lat_height_c.F90 +++ b/femtools/tests/test_vector_cartesian_2_lon_lat_height_c.F90 @@ -25,159 +25,159 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_cartesian_2_lon_lat_height_c - !Subroutine/unit-test of correct vector basis change from a - ! Cartesian system to a meridional-zonal-vertical system. - ! This subroutine will test the C-inter-operable version of the conversion. + !Subroutine/unit-test of correct vector basis change from a + ! Cartesian system to a meridional-zonal-vertical system. + ! This subroutine will test the C-inter-operable version of the conversion. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - use iso_c_binding - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + use iso_c_binding + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial - type(vector_field) :: radialVectorDifference, & - polarVectorDifference, & - azimuthalVectorDifference - real(kind=c_double), dimension(3) :: & - meridionalZonalVerticalVectorComponents_c, & - cartesianVectorComponents_c !C-inter-operable arrays containing - ! the vector components in Cartesian - ! & lon-lat-height bases. - real(kind=c_double), dimension(3) :: & - XYZ_c, LLH_c !C-inter-operable arrays containing a signle - ! node's position vector components in Cartesian - ! & lon-lat-height bases. - real, dimension(3) :: meridionalZonalVerticalVectorComponents, & - cartesianVectorComponents - real, dimension(3) :: XYZ, LLH !Arrays containing a signle node's position vector - ! components in Cartesian & lon-lat-height bases. - integer :: node - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial + type(vector_field) :: radialVectorDifference, & + polarVectorDifference, & + azimuthalVectorDifference + real(kind=c_double), dimension(3) :: & + meridionalZonalVerticalVectorComponents_c, & + cartesianVectorComponents_c !C-inter-operable arrays containing + ! the vector components in Cartesian + ! & lon-lat-height bases. + real(kind=c_double), dimension(3) :: & + XYZ_c, LLH_c !C-inter-operable arrays containing a signle + ! node's position vector components in Cartesian + ! & lon-lat-height bases. + real, dimension(3) :: meridionalZonalVerticalVectorComponents, & + cartesianVectorComponents + real, dimension(3) :: XYZ, LLH !Arrays containing a signle node's position vector + ! components in Cartesian & lon-lat-height bases. + integer :: node + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitRadialVector_inZonalMeridionalRadial") - UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitPolarVector_inZonalMeridionalRadial") - UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitAzimuthalVector_inZonalMeridionalRadial") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitRadialVector_inZonalMeridionalRadial") + UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitPolarVector_inZonalMeridionalRadial") + UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitAzimuthalVector_inZonalMeridionalRadial") - call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') - call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') - call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') + call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') + call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') + call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') - !Convert unit-radial vector components into to zonal-meridional-vertical basis. - ! Then compare with vector already in that basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = & - node_val(UnitRadialVector_inCartesian, node) - XYZ_c = real(XYZ, kind=c_double) - cartesianVectorComponents_c = real(cartesianVectorComponents, kind=c_double) - call vector_cartesian_2_lon_lat_height_c(cartesianVectorComponents_c(1), & - cartesianVectorComponents_c(2), & - cartesianVectorComponents_c(3), & - XYZ_c(1), & - XYZ_c(2), & - XYZ_c(3), & - meridionalZonalVerticalVectorComponents_c(1), & - meridionalZonalVerticalVectorComponents_c(2), & - meridionalZonalVerticalVectorComponents_c(3), & - LLH_c(1), & - LLH_c(2), & - LLH_c(3), 0.0) - meridionalZonalVerticalVectorComponents = real(meridionalZonalVerticalVectorComponents_c) - LLH = real(LLH_c) - call set(radialVectorDifference, node, meridionalZonalVerticalVectorComponents) - enddo - call addto(radialVectorDifference, UnitRadialVector_inZonalMeridionalRadial, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-radial vector (C-types).]", & - fail, .false., "Radial unit vector components not transformed correctly.") + !Convert unit-radial vector components into to zonal-meridional-vertical basis. + ! Then compare with vector already in that basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = & + node_val(UnitRadialVector_inCartesian, node) + XYZ_c = real(XYZ, kind=c_double) + cartesianVectorComponents_c = real(cartesianVectorComponents, kind=c_double) + call vector_cartesian_2_lon_lat_height_c(cartesianVectorComponents_c(1), & + cartesianVectorComponents_c(2), & + cartesianVectorComponents_c(3), & + XYZ_c(1), & + XYZ_c(2), & + XYZ_c(3), & + meridionalZonalVerticalVectorComponents_c(1), & + meridionalZonalVerticalVectorComponents_c(2), & + meridionalZonalVerticalVectorComponents_c(3), & + LLH_c(1), & + LLH_c(2), & + LLH_c(3), 0.0) + meridionalZonalVerticalVectorComponents = real(meridionalZonalVerticalVectorComponents_c) + LLH = real(LLH_c) + call set(radialVectorDifference, node, meridionalZonalVerticalVectorComponents) + enddo + call addto(radialVectorDifference, UnitRadialVector_inZonalMeridionalRadial, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-radial vector (C-types).]", & + fail, .false., "Radial unit vector components not transformed correctly.") - !Convert unit-polar vector components into zonal-meridional-vertical basis. - ! Then compare with vector already in that basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = & - node_val(UnitPolarVector_inCartesian, node) - XYZ_c = real(XYZ, kind=c_double) - cartesianVectorComponents_c = real(cartesianVectorComponents, kind=c_double) - call vector_cartesian_2_lon_lat_height_c(cartesianVectorComponents_c(1), & - cartesianVectorComponents_c(2), & - cartesianVectorComponents_c(3), & - XYZ_c(1), & - XYZ_c(2), & - XYZ_c(3), & - meridionalZonalVerticalVectorComponents_c(1), & - meridionalZonalVerticalVectorComponents_c(2), & - meridionalZonalVerticalVectorComponents_c(3), & - LLH_c(1), & - LLH_c(2), & - LLH_c(3), 0.0) - meridionalZonalVerticalVectorComponents = real(meridionalZonalVerticalVectorComponents_c) - LLH = real(LLH_c) - call set(polarVectorDifference, node, meridionalZonalVerticalVectorComponents) - enddo - call addto(polarVectorDifference, UnitPolarVector_inZonalMeridionalRadial, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-polar vector (C-types).]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Convert unit-polar vector components into zonal-meridional-vertical basis. + ! Then compare with vector already in that basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = & + node_val(UnitPolarVector_inCartesian, node) + XYZ_c = real(XYZ, kind=c_double) + cartesianVectorComponents_c = real(cartesianVectorComponents, kind=c_double) + call vector_cartesian_2_lon_lat_height_c(cartesianVectorComponents_c(1), & + cartesianVectorComponents_c(2), & + cartesianVectorComponents_c(3), & + XYZ_c(1), & + XYZ_c(2), & + XYZ_c(3), & + meridionalZonalVerticalVectorComponents_c(1), & + meridionalZonalVerticalVectorComponents_c(2), & + meridionalZonalVerticalVectorComponents_c(3), & + LLH_c(1), & + LLH_c(2), & + LLH_c(3), 0.0) + meridionalZonalVerticalVectorComponents = real(meridionalZonalVerticalVectorComponents_c) + LLH = real(LLH_c) + call set(polarVectorDifference, node, meridionalZonalVerticalVectorComponents) + enddo + call addto(polarVectorDifference, UnitPolarVector_inZonalMeridionalRadial, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-polar vector (C-types).]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Convert unit-azimuthal vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = & - node_val(UnitAzimuthalVector_inCartesian, node) - XYZ_c = real(XYZ, kind=c_double) - cartesianVectorComponents_c = real(cartesianVectorComponents, kind=c_double) - call vector_cartesian_2_lon_lat_height_c(cartesianVectorComponents_c(1), & - cartesianVectorComponents_c(2), & - cartesianVectorComponents_c(3), & - XYZ_c(1), & - XYZ_c(2), & - XYZ_c(3), & - meridionalZonalVerticalVectorComponents_c(1), & - meridionalZonalVerticalVectorComponents_c(2), & - meridionalZonalVerticalVectorComponents_c(3), & - LLH_c(1), & - LLH_c(2), & - LLH_c(3), 0.0) - meridionalZonalVerticalVectorComponents = real(meridionalZonalVerticalVectorComponents_c) - LLH = real(LLH_c) - call set(azimuthalVectorDifference, node, meridionalZonalVerticalVectorComponents) - enddo - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inZonalMeridionalRadial, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-azimuthal vector (C-types).]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Convert unit-azimuthal vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = & + node_val(UnitAzimuthalVector_inCartesian, node) + XYZ_c = real(XYZ, kind=c_double) + cartesianVectorComponents_c = real(cartesianVectorComponents, kind=c_double) + call vector_cartesian_2_lon_lat_height_c(cartesianVectorComponents_c(1), & + cartesianVectorComponents_c(2), & + cartesianVectorComponents_c(3), & + XYZ_c(1), & + XYZ_c(2), & + XYZ_c(3), & + meridionalZonalVerticalVectorComponents_c(1), & + meridionalZonalVerticalVectorComponents_c(2), & + meridionalZonalVerticalVectorComponents_c(3), & + LLH_c(1), & + LLH_c(2), & + LLH_c(3), 0.0) + meridionalZonalVerticalVectorComponents = real(meridionalZonalVerticalVectorComponents_c) + LLH = real(LLH_c) + call set(azimuthalVectorDifference, node, meridionalZonalVerticalVectorComponents) + enddo + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inZonalMeridionalRadial, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Zonal-Meridional-Vertical of unit-azimuthal vector (C-types).]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vector_cartesian_2_spherical_polar.F90 b/femtools/tests/test_vector_cartesian_2_spherical_polar.F90 index fa0586db0c..e46621ed13 100644 --- a/femtools/tests/test_vector_cartesian_2_spherical_polar.F90 +++ b/femtools/tests/test_vector_cartesian_2_spherical_polar.F90 @@ -25,133 +25,133 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_cartesian_2_spherical_polar - !Subroutine/unit-test of correct vector basis change from a - ! Cartesian system to a spherical-polar system. + !Subroutine/unit-test of correct vector basis change from a + ! Cartesian system to a spherical-polar system. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate, PolarCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inPolar - type(vector_field), pointer :: UnitPolarVector_inPolar - type(vector_field), pointer :: UnitAzimuthalVector_inPolar - type(vector_field) :: radialVectorDifference, & - polarVectorDifference, & - azimuthalVectorDifference - real, dimension(3) :: sphericalPolarVectorComponents, & - cartesianVectorComponents - real, dimension(3) :: XYZ, RTP !Arrays containing a single node's position vector - ! components in Cartesian & spherical-polar bases. - integer :: node - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate, PolarCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inPolar + type(vector_field), pointer :: UnitPolarVector_inPolar + type(vector_field), pointer :: UnitAzimuthalVector_inPolar + type(vector_field) :: radialVectorDifference, & + polarVectorDifference, & + azimuthalVectorDifference + real, dimension(3) :: sphericalPolarVectorComponents, & + cartesianVectorComponents + real, dimension(3) :: XYZ, RTP !Arrays containing a single node's position vector + ! components in Cartesian & spherical-polar bases. + integer :: node + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inPolar => extract_vector_field(state, "UnitRadialVector_inPolar") - UnitPolarVector_inPolar => extract_vector_field(state, "UnitPolarVector_inPolar") - UnitAzimuthalVector_inPolar => extract_vector_field(state, & - "UnitAzimuthalVector_inPolar") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inPolar => extract_vector_field(state, "UnitRadialVector_inPolar") + UnitPolarVector_inPolar => extract_vector_field(state, "UnitPolarVector_inPolar") + UnitAzimuthalVector_inPolar => extract_vector_field(state, & + "UnitAzimuthalVector_inPolar") - !Test the change of basis from spherical-polar to Cartesian. + !Test the change of basis from spherical-polar to Cartesian. - call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') - call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') - call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') + call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') + call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') + call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') - !Convert unit-radial vector into spherical-polar basis. Then compare with - ! vector already in spherical-polar basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = node_val(UnitRadialVector_inCartesian, node) - call vector_cartesian_2_spherical_polar(cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3), & - sphericalPolarVectorComponents(1), & - sphericalPolarVectorComponents(2), & - sphericalPolarVectorComponents(3), & - RTP(1), & - RTP(2), & - RTP(3)) - call set(radialVectorDifference, node, sphericalPolarVectorComponents) - enddo - call addto(radialVectorDifference, UnitRadialVector_inPolar, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & + !Convert unit-radial vector into spherical-polar basis. Then compare with + ! vector already in spherical-polar basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = node_val(UnitRadialVector_inCartesian, node) + call vector_cartesian_2_spherical_polar(cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3), & + sphericalPolarVectorComponents(1), & + sphericalPolarVectorComponents(2), & + sphericalPolarVectorComponents(3), & + RTP(1), & + RTP(2), & + RTP(3)) + call set(radialVectorDifference, node, sphericalPolarVectorComponents) + enddo + call addto(radialVectorDifference, UnitRadialVector_inPolar, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & "[Vector basis change: Cartesian to Spherical-polar of unit-radial vector.]", & fail, .false., "Radial unit vector components not transformed correctly.") - !Convert unit-polar vector into spherical-polar basis. Then compare with - ! vector already in spherical-polar basis, obtained from vtu. - do node=1,node_count(CartesianCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = node_val(UnitPolarVector_inCartesian, node) - call vector_cartesian_2_spherical_polar(cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3), & - sphericalPolarVectorComponents(1), & - sphericalPolarVectorComponents(2), & - sphericalPolarVectorComponents(3), & - RTP(1), & - RTP(2), & - RTP(3)) - call set(polarVectorDifference, node, sphericalPolarVectorComponents) - enddo - call addto(polarVectorDifference, UnitPolarVector_inPolar, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to spherical-polar of unit-polar vector.]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Convert unit-polar vector into spherical-polar basis. Then compare with + ! vector already in spherical-polar basis, obtained from vtu. + do node=1,node_count(CartesianCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = node_val(UnitPolarVector_inCartesian, node) + call vector_cartesian_2_spherical_polar(cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3), & + sphericalPolarVectorComponents(1), & + sphericalPolarVectorComponents(2), & + sphericalPolarVectorComponents(3), & + RTP(1), & + RTP(2), & + RTP(3)) + call set(polarVectorDifference, node, sphericalPolarVectorComponents) + enddo + call addto(polarVectorDifference, UnitPolarVector_inPolar, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to spherical-polar of unit-polar vector.]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Convert unit-azimuthal vector into spherical-polar basis. Then compare with - ! vector already in spherical-polar basis, obtained from vtu. - do node=1,node_count(PolarCoordinate) - XYZ = node_val(CartesianCoordinate, node) - cartesianVectorComponents = node_val(UnitAzimuthalVector_inCartesian, node) - call vector_cartesian_2_spherical_polar(cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3), & - sphericalPolarVectorComponents(1), & - sphericalPolarVectorComponents(2), & - sphericalPolarVectorComponents(3), & - RTP(1), & - RTP(2), & - RTP(3)) - call set(azimuthalVectorDifference, node, sphericalPolarVectorComponents) - enddo - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inPolar, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Cartesian to Spherical-polar of unit-azimuthal vector.]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Convert unit-azimuthal vector into spherical-polar basis. Then compare with + ! vector already in spherical-polar basis, obtained from vtu. + do node=1,node_count(PolarCoordinate) + XYZ = node_val(CartesianCoordinate, node) + cartesianVectorComponents = node_val(UnitAzimuthalVector_inCartesian, node) + call vector_cartesian_2_spherical_polar(cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3), & + sphericalPolarVectorComponents(1), & + sphericalPolarVectorComponents(2), & + sphericalPolarVectorComponents(3), & + RTP(1), & + RTP(2), & + RTP(3)) + call set(azimuthalVectorDifference, node, sphericalPolarVectorComponents) + enddo + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inPolar, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Cartesian to Spherical-polar of unit-azimuthal vector.]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vector_lon_lat_height_2_cartesian.F90 b/femtools/tests/test_vector_lon_lat_height_2_cartesian.F90 index 72170aca79..5ab62063c8 100644 --- a/femtools/tests/test_vector_lon_lat_height_2_cartesian.F90 +++ b/femtools/tests/test_vector_lon_lat_height_2_cartesian.F90 @@ -25,138 +25,138 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_lon_lat_height_2_cartesian - !Subroutine/unit-test of correct vector basis change from a - ! meridional-zonal-vertical system to a Cartesian system. + !Subroutine/unit-test of correct vector basis change from a + ! meridional-zonal-vertical system to a Cartesian system. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial - type(vector_field) :: radialVectorDifference, & - polarVectorDifference, & - azimuthalVectorDifference - real, dimension(3) :: meridionalZonalVerticalVectorComponents, & - cartesianVectorComponents - real, dimension(3) :: XYZ, LLH !Arrays containing a signle node's position vector - ! components in Cartesian & lon-lat-height bases. - integer :: node - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial + type(vector_field) :: radialVectorDifference, & + polarVectorDifference, & + azimuthalVectorDifference + real, dimension(3) :: meridionalZonalVerticalVectorComponents, & + cartesianVectorComponents + real, dimension(3) :: XYZ, LLH !Arrays containing a signle node's position vector + ! components in Cartesian & lon-lat-height bases. + integer :: node + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitRadialVector_inZonalMeridionalRadial") - UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitPolarVector_inZonalMeridionalRadial") - UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitAzimuthalVector_inZonalMeridionalRadial") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitRadialVector_inZonalMeridionalRadial") + UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitPolarVector_inZonalMeridionalRadial") + UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitAzimuthalVector_inZonalMeridionalRadial") - !Test the change of basis from spherical-polar to Cartesian. + !Test the change of basis from spherical-polar to Cartesian. - call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') - call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') - call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') + call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') + call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') + call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') - !Convert unit-radial vector components into to Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - meridionalZonalVerticalVectorComponents = & - node_val(UnitRadialVector_inZonalMeridionalRadial, node) - call vector_lon_lat_height_2_cartesian(meridionalZonalVerticalVectorComponents(1), & - meridionalZonalVerticalVectorComponents(2), & - meridionalZonalVerticalVectorComponents(3), & - LLH(1), & - LLH(2), & - LLH(3), & - cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3)) - call set(radialVectorDifference, node, cartesianVectorComponents) - enddo - call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-radial vector.]", & - fail, .false., "Radial unit vector components not transformed correctly.") + !Convert unit-radial vector components into to Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + meridionalZonalVerticalVectorComponents = & + node_val(UnitRadialVector_inZonalMeridionalRadial, node) + call vector_lon_lat_height_2_cartesian(meridionalZonalVerticalVectorComponents(1), & + meridionalZonalVerticalVectorComponents(2), & + meridionalZonalVerticalVectorComponents(3), & + LLH(1), & + LLH(2), & + LLH(3), & + cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3)) + call set(radialVectorDifference, node, cartesianVectorComponents) + enddo + call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-radial vector.]", & + fail, .false., "Radial unit vector components not transformed correctly.") - !Convert unit-polar vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - meridionalZonalVerticalVectorComponents = & - node_val(UnitPolarVector_inZonalMeridionalRadial, node) - call vector_lon_lat_height_2_cartesian(meridionalZonalVerticalVectorComponents(1), & - meridionalZonalVerticalVectorComponents(2), & - meridionalZonalVerticalVectorComponents(3), & - LLH(1), & - LLH(2), & - LLH(3), & - cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3)) - call set(polarVectorDifference, node, cartesianVectorComponents) - enddo - call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-polar vector.]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Convert unit-polar vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + meridionalZonalVerticalVectorComponents = & + node_val(UnitPolarVector_inZonalMeridionalRadial, node) + call vector_lon_lat_height_2_cartesian(meridionalZonalVerticalVectorComponents(1), & + meridionalZonalVerticalVectorComponents(2), & + meridionalZonalVerticalVectorComponents(3), & + LLH(1), & + LLH(2), & + LLH(3), & + cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3)) + call set(polarVectorDifference, node, cartesianVectorComponents) + enddo + call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-polar vector.]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Convert unit-azimuthal vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - meridionalZonalVerticalVectorComponents = & - node_val(UnitAzimuthalVector_inZonalMeridionalRadial, node) - call vector_lon_lat_height_2_cartesian(meridionalZonalVerticalVectorComponents(1), & - meridionalZonalVerticalVectorComponents(2), & - meridionalZonalVerticalVectorComponents(3), & - LLH(1), & - LLH(2), & - LLH(3), & - cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3)) - call set(azimuthalVectorDifference, node, cartesianVectorComponents) - enddo - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-azimuthal vector.]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Convert unit-azimuthal vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + meridionalZonalVerticalVectorComponents = & + node_val(UnitAzimuthalVector_inZonalMeridionalRadial, node) + call vector_lon_lat_height_2_cartesian(meridionalZonalVerticalVectorComponents(1), & + meridionalZonalVerticalVectorComponents(2), & + meridionalZonalVerticalVectorComponents(3), & + LLH(1), & + LLH(2), & + LLH(3), & + cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3)) + call set(azimuthalVectorDifference, node, cartesianVectorComponents) + enddo + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-azimuthal vector.]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vector_lon_lat_height_2_cartesian_c.F90 b/femtools/tests/test_vector_lon_lat_height_2_cartesian_c.F90 index 5f6ab1ba47..471c6ea197 100644 --- a/femtools/tests/test_vector_lon_lat_height_2_cartesian_c.F90 +++ b/femtools/tests/test_vector_lon_lat_height_2_cartesian_c.F90 @@ -25,164 +25,164 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_lon_lat_height_2_cartesian_c - !Subroutine/unit-test of correct vector basis change from a - ! meridional-zonal-vertical system to a Cartesian system. - ! This subroutine will test the C-inter-operable version of the conversion. + !Subroutine/unit-test of correct vector basis change from a + ! meridional-zonal-vertical system to a Cartesian system. + ! This subroutine will test the C-inter-operable version of the conversion. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - use iso_c_binding - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + use iso_c_binding + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial - type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial - type(vector_field) :: radialVectorDifference, & - polarVectorDifference, & - azimuthalVectorDifference - real(kind=c_double), dimension(3) :: & - meridionalZonalVerticalVectorComponents_c, & - cartesianVectorComponents_c !C-inter-operable arrays containing - ! the vector components in Cartesian - ! & lon-lat-height bases. - real(kind=c_double), dimension(3) :: & - XYZ_c, LLH_c !C-inter-operable arrays containing a signle - ! node's position vector components in Cartesian - ! & lon-lat-height bases. - real, dimension(3) :: meridionalZonalVerticalVectorComponents, & - cartesianVectorComponents - real, dimension(3) :: XYZ, LLH !Arrays containing a single node's position vector - ! components in Cartesian & lon-lat-height bases. - integer :: node - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate, LonLatHeightCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitPolarVector_inZonalMeridionalRadial + type(vector_field), pointer :: UnitAzimuthalVector_inZonalMeridionalRadial + type(vector_field) :: radialVectorDifference, & + polarVectorDifference, & + azimuthalVectorDifference + real(kind=c_double), dimension(3) :: & + meridionalZonalVerticalVectorComponents_c, & + cartesianVectorComponents_c !C-inter-operable arrays containing + ! the vector components in Cartesian + ! & lon-lat-height bases. + real(kind=c_double), dimension(3) :: & + XYZ_c, LLH_c !C-inter-operable arrays containing a signle + ! node's position vector components in Cartesian + ! & lon-lat-height bases. + real, dimension(3) :: meridionalZonalVerticalVectorComponents, & + cartesianVectorComponents + real, dimension(3) :: XYZ, LLH !Arrays containing a single node's position vector + ! components in Cartesian & lon-lat-height bases. + integer :: node + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitRadialVector_inZonalMeridionalRadial") - UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitPolarVector_inZonalMeridionalRadial") - UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & - "UnitAzimuthalVector_inZonalMeridionalRadial") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + LonLatHeightCoordinate => extract_vector_field(state, "lonlatradius") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitRadialVector_inZonalMeridionalRadial") + UnitPolarVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitPolarVector_inZonalMeridionalRadial") + UnitAzimuthalVector_inZonalMeridionalRadial => extract_vector_field(state, & + "UnitAzimuthalVector_inZonalMeridionalRadial") - !Test the change of basis from spherical-polar to Cartesian. + !Test the change of basis from spherical-polar to Cartesian. - call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') - call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') - call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') + call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') + call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') + call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') - !Convert unit-radial vector components into to Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - meridionalZonalVerticalVectorComponents = & - node_val(UnitRadialVector_inZonalMeridionalRadial, node) - LLH_c = real(LLH, kind=c_double) - meridionalZonalVerticalVectorComponents_c = & - real(meridionalZonalVerticalVectorComponents, kind=c_double) - call vector_lon_lat_height_2_cartesian_c(meridionalZonalVerticalVectorComponents_c(1), & - meridionalZonalVerticalVectorComponents_c(2), & - meridionalZonalVerticalVectorComponents_c(3), & - LLH_c(1), & - LLH_c(2), & - LLH_c(3), & - cartesianVectorComponents_c(1), & - cartesianVectorComponents_c(2), & - cartesianVectorComponents_c(3), & - XYZ_c(1), & - XYZ_c(2), & - XYZ_c(3), 0.0) - cartesianVectorComponents = real(cartesianVectorComponents_c) - XYZ = real(XYZ_c) - call set(radialVectorDifference, node, cartesianVectorComponents) - enddo - call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-radial vector (C-types).]", & - fail, .false., "Radial unit vector components not transformed correctly.") + !Convert unit-radial vector components into to Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + meridionalZonalVerticalVectorComponents = & + node_val(UnitRadialVector_inZonalMeridionalRadial, node) + LLH_c = real(LLH, kind=c_double) + meridionalZonalVerticalVectorComponents_c = & + real(meridionalZonalVerticalVectorComponents, kind=c_double) + call vector_lon_lat_height_2_cartesian_c(meridionalZonalVerticalVectorComponents_c(1), & + meridionalZonalVerticalVectorComponents_c(2), & + meridionalZonalVerticalVectorComponents_c(3), & + LLH_c(1), & + LLH_c(2), & + LLH_c(3), & + cartesianVectorComponents_c(1), & + cartesianVectorComponents_c(2), & + cartesianVectorComponents_c(3), & + XYZ_c(1), & + XYZ_c(2), & + XYZ_c(3), 0.0) + cartesianVectorComponents = real(cartesianVectorComponents_c) + XYZ = real(XYZ_c) + call set(radialVectorDifference, node, cartesianVectorComponents) + enddo + call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-radial vector (C-types).]", & + fail, .false., "Radial unit vector components not transformed correctly.") - !Convert unit-polar vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - meridionalZonalVerticalVectorComponents = & - node_val(UnitPolarVector_inZonalMeridionalRadial, node) - LLH_c = real(LLH, kind=c_double) - meridionalZonalVerticalVectorComponents_c = & - real(meridionalZonalVerticalVectorComponents, kind=c_double) - call vector_lon_lat_height_2_cartesian_c(meridionalZonalVerticalVectorComponents_c(1), & - meridionalZonalVerticalVectorComponents_c(2), & - meridionalZonalVerticalVectorComponents_c(3), & - LLH_c(1), & - LLH_c(2), & - LLH_c(3), & - cartesianVectorComponents_c(1), & - cartesianVectorComponents_c(2), & - cartesianVectorComponents_c(3), & - XYZ_c(1), & - XYZ_c(2), & - XYZ_c(3), 0.0) - cartesianVectorComponents = real(cartesianVectorComponents_c) - XYZ = real(XYZ_c) - call set(polarVectorDifference, node, cartesianVectorComponents) - enddo - call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-polar vector (C-types).]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Convert unit-polar vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + meridionalZonalVerticalVectorComponents = & + node_val(UnitPolarVector_inZonalMeridionalRadial, node) + LLH_c = real(LLH, kind=c_double) + meridionalZonalVerticalVectorComponents_c = & + real(meridionalZonalVerticalVectorComponents, kind=c_double) + call vector_lon_lat_height_2_cartesian_c(meridionalZonalVerticalVectorComponents_c(1), & + meridionalZonalVerticalVectorComponents_c(2), & + meridionalZonalVerticalVectorComponents_c(3), & + LLH_c(1), & + LLH_c(2), & + LLH_c(3), & + cartesianVectorComponents_c(1), & + cartesianVectorComponents_c(2), & + cartesianVectorComponents_c(3), & + XYZ_c(1), & + XYZ_c(2), & + XYZ_c(3), 0.0) + cartesianVectorComponents = real(cartesianVectorComponents_c) + XYZ = real(XYZ_c) + call set(polarVectorDifference, node, cartesianVectorComponents) + enddo + call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-polar vector (C-types).]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Convert unit-azimuthal vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(LonLatHeightCoordinate) - LLH = node_val(LonLatHeightCoordinate, node) - meridionalZonalVerticalVectorComponents = & - node_val(UnitAzimuthalVector_inZonalMeridionalRadial, node) - LLH_c = real(LLH, kind=c_double) - meridionalZonalVerticalVectorComponents_c = & - real(meridionalZonalVerticalVectorComponents, kind=c_double) - call vector_lon_lat_height_2_cartesian_c(meridionalZonalVerticalVectorComponents_c(1), & - meridionalZonalVerticalVectorComponents_c(2), & - meridionalZonalVerticalVectorComponents_c(3), & - LLH_c(1), & - LLH_c(2), & - LLH_c(3), & - cartesianVectorComponents_c(1), & - cartesianVectorComponents_c(2), & - cartesianVectorComponents_c(3), & - XYZ_c(1), & - XYZ_c(2), & - XYZ_c(3), 0.0) - cartesianVectorComponents = real(cartesianVectorComponents_c) - XYZ = real(XYZ_c) - call set(azimuthalVectorDifference, node, cartesianVectorComponents) - enddo - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-azimuthal vector (C-types).]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Convert unit-azimuthal vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(LonLatHeightCoordinate) + LLH = node_val(LonLatHeightCoordinate, node) + meridionalZonalVerticalVectorComponents = & + node_val(UnitAzimuthalVector_inZonalMeridionalRadial, node) + LLH_c = real(LLH, kind=c_double) + meridionalZonalVerticalVectorComponents_c = & + real(meridionalZonalVerticalVectorComponents, kind=c_double) + call vector_lon_lat_height_2_cartesian_c(meridionalZonalVerticalVectorComponents_c(1), & + meridionalZonalVerticalVectorComponents_c(2), & + meridionalZonalVerticalVectorComponents_c(3), & + LLH_c(1), & + LLH_c(2), & + LLH_c(3), & + cartesianVectorComponents_c(1), & + cartesianVectorComponents_c(2), & + cartesianVectorComponents_c(3), & + XYZ_c(1), & + XYZ_c(2), & + XYZ_c(3), 0.0) + cartesianVectorComponents = real(cartesianVectorComponents_c) + XYZ = real(XYZ_c) + call set(azimuthalVectorDifference, node, cartesianVectorComponents) + enddo + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Zonal-Meridional-Vertical to Cartesian of unit-azimuthal vector (C-types).]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vector_spherical_polar_2_cartesian.F90 b/femtools/tests/test_vector_spherical_polar_2_cartesian.F90 index 5c18d209cc..9913bfba03 100644 --- a/femtools/tests/test_vector_spherical_polar_2_cartesian.F90 +++ b/femtools/tests/test_vector_spherical_polar_2_cartesian.F90 @@ -25,136 +25,136 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_spherical_polar_2_cartesian - !Subroutine/unit-test of correct vector basis change from a - ! spherical-polar system to a Cartesian system. + !Subroutine/unit-test of correct vector basis change from a + ! spherical-polar system to a Cartesian system. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate, PolarCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inPolar - type(vector_field), pointer :: UnitPolarVector_inPolar - type(vector_field), pointer :: UnitAzimuthalVector_inPolar - type(vector_field) :: radialVectorDifference, & - polarVectorDifference, & - azimuthalVectorDifference - real, dimension(3) :: sphericalPolarVectorComponents, & - cartesianVectorComponents - real, dimension(3) :: XYZ, RTP !Arrays containing a single node's position vector - ! components in Cartesian & spherical-polar bases. - integer :: node - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate, PolarCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inPolar + type(vector_field), pointer :: UnitPolarVector_inPolar + type(vector_field), pointer :: UnitAzimuthalVector_inPolar + type(vector_field) :: radialVectorDifference, & + polarVectorDifference, & + azimuthalVectorDifference + real, dimension(3) :: sphericalPolarVectorComponents, & + cartesianVectorComponents + real, dimension(3) :: XYZ, RTP !Arrays containing a single node's position vector + ! components in Cartesian & spherical-polar bases. + integer :: node + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inPolar => extract_vector_field(state, "UnitRadialVector_inPolar") - UnitPolarVector_inPolar => extract_vector_field(state, "UnitPolarVector_inPolar") - UnitAzimuthalVector_inPolar => extract_vector_field(state, & - "UnitAzimuthalVector_inPolar") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inPolar => extract_vector_field(state, "UnitRadialVector_inPolar") + UnitPolarVector_inPolar => extract_vector_field(state, "UnitPolarVector_inPolar") + UnitAzimuthalVector_inPolar => extract_vector_field(state, & + "UnitAzimuthalVector_inPolar") - !Test the change of basis from spherical-polar to Cartesian. + !Test the change of basis from spherical-polar to Cartesian. - call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') - call zero(radialVectorDifference) - call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') - call zero(polarVectorDifference) - call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') - call zero(azimuthalVectorDifference) + call allocate(radialVectorDifference, 3 , mesh, 'radialVectorDifference') + call zero(radialVectorDifference) + call allocate(polarVectorDifference, 3 , mesh, 'polarVectorDifference') + call zero(polarVectorDifference) + call allocate(azimuthalVectorDifference, 3 , mesh, 'azimuthalVectorDifference') + call zero(azimuthalVectorDifference) - !Convert unit-radial vector components into to Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - sphericalPolarVectorComponents = node_val(UnitRadialVector_inPolar, node) - call vector_spherical_polar_2_cartesian(sphericalPolarVectorComponents(1), & - sphericalPolarVectorComponents(2), & - sphericalPolarVectorComponents(3), & - RTP(1), & - RTP(2), & - RTP(3), & - cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3)) - call set(radialVectorDifference, node, cartesianVectorComponents) - enddo - call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & + !Convert unit-radial vector components into to Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + sphericalPolarVectorComponents = node_val(UnitRadialVector_inPolar, node) + call vector_spherical_polar_2_cartesian(sphericalPolarVectorComponents(1), & + sphericalPolarVectorComponents(2), & + sphericalPolarVectorComponents(3), & + RTP(1), & + RTP(2), & + RTP(3), & + cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3)) + call set(radialVectorDifference, node, cartesianVectorComponents) + enddo + call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & "[Vector basis change: Spherical-polar to Cartesian of unit-radial vector.]", & fail, .false., "Radial unit vector components not transformed correctly.") - !Convert unit-polar vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - sphericalPolarVectorComponents = node_val(UnitPolarVector_inPolar, node) - call vector_spherical_polar_2_cartesian(sphericalPolarVectorComponents(1), & - sphericalPolarVectorComponents(2), & - sphericalPolarVectorComponents(3), & - RTP(1), & - RTP(2), & - RTP(3), & - cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3)) - call set(polarVectorDifference, node, cartesianVectorComponents) - enddo - call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Spherical-polar to Cartesian of unit-polar vector.]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Convert unit-polar vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + sphericalPolarVectorComponents = node_val(UnitPolarVector_inPolar, node) + call vector_spherical_polar_2_cartesian(sphericalPolarVectorComponents(1), & + sphericalPolarVectorComponents(2), & + sphericalPolarVectorComponents(3), & + RTP(1), & + RTP(2), & + RTP(3), & + cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3)) + call set(polarVectorDifference, node, cartesianVectorComponents) + enddo + call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Spherical-polar to Cartesian of unit-polar vector.]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Convert unit-azimuthal vector components into Cartesian basis. Then compare - ! with vector already in Cartesian basis, obtained from vtu. - do node=1,node_count(PolarCoordinate) - RTP = node_val(PolarCoordinate, node) - sphericalPolarVectorComponents = node_val(UnitAzimuthalVector_inPolar, node) - call vector_spherical_polar_2_cartesian(sphericalPolarVectorComponents(1), & - sphericalPolarVectorComponents(2), & - sphericalPolarVectorComponents(3), & - RTP(1), & - RTP(2), & - RTP(3), & - cartesianVectorComponents(1), & - cartesianVectorComponents(2), & - cartesianVectorComponents(3), & - XYZ(1), & - XYZ(2), & - XYZ(3)) - call set(azimuthalVectorDifference, node, cartesianVectorComponents) - enddo - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Spherical-polar to Cartesian of unit-azimuthal vector.]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Convert unit-azimuthal vector components into Cartesian basis. Then compare + ! with vector already in Cartesian basis, obtained from vtu. + do node=1,node_count(PolarCoordinate) + RTP = node_val(PolarCoordinate, node) + sphericalPolarVectorComponents = node_val(UnitAzimuthalVector_inPolar, node) + call vector_spherical_polar_2_cartesian(sphericalPolarVectorComponents(1), & + sphericalPolarVectorComponents(2), & + sphericalPolarVectorComponents(3), & + RTP(1), & + RTP(2), & + RTP(3), & + cartesianVectorComponents(1), & + cartesianVectorComponents(2), & + cartesianVectorComponents(3), & + XYZ(1), & + XYZ(2), & + XYZ(3)) + call set(azimuthalVectorDifference, node, cartesianVectorComponents) + enddo + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Spherical-polar to Cartesian of unit-azimuthal vector.]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vector_spherical_polar_2_cartesian_field.F90 b/femtools/tests/test_vector_spherical_polar_2_cartesian_field.F90 index 55bee11ea5..9c51f33676 100644 --- a/femtools/tests/test_vector_spherical_polar_2_cartesian_field.F90 +++ b/femtools/tests/test_vector_spherical_polar_2_cartesian_field.F90 @@ -25,98 +25,98 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! USA subroutine test_vector_spherical_polar_2_cartesian_field - !Subroutine/unit-test of correct vector basis change from a - ! spherical-polar system to a Cartesian system, for a femtools - ! vector field. - use fields - use vtk_interfaces - use state_module - use Coordinates - use unittest_tools - implicit none + !Subroutine/unit-test of correct vector basis change from a + ! spherical-polar system to a Cartesian system, for a femtools + ! vector field. + use fields + use vtk_interfaces + use state_module + use Coordinates + use unittest_tools + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: CartesianCoordinate - type(vector_field), pointer :: PolarCoordinate - type(vector_field), pointer :: UnitRadialVector_inCartesian - type(vector_field), pointer :: UnitPolarVector_inCartesian - type(vector_field), pointer :: UnitAzimuthalVector_inCartesian - type(vector_field), pointer :: UnitRadialVector_inPolar - type(vector_field), pointer :: UnitPolarVector_inPolar - type(vector_field), pointer :: UnitAzimuthalVector_inPolar - type(vector_field), target :: & !Vector fields used for temporary - radialVectorDifference, & ! storage of the vector fields in - polarVectorDifference, & ! Cartesian basis, as well as the - azimuthalVectorDifference ! difference between calculated - ! and expected values. - logical :: fail + type(state_type) :: state + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: CartesianCoordinate + type(vector_field), pointer :: PolarCoordinate + type(vector_field), pointer :: UnitRadialVector_inCartesian + type(vector_field), pointer :: UnitPolarVector_inCartesian + type(vector_field), pointer :: UnitAzimuthalVector_inCartesian + type(vector_field), pointer :: UnitRadialVector_inPolar + type(vector_field), pointer :: UnitPolarVector_inPolar + type(vector_field), pointer :: UnitAzimuthalVector_inPolar + type(vector_field), target :: & !Vector fields used for temporary + radialVectorDifference, & ! storage of the vector fields in + polarVectorDifference, & ! Cartesian basis, as well as the + azimuthalVectorDifference ! difference between calculated + ! and expected values. + logical :: fail - call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) - mesh => extract_mesh(state, "Mesh") - CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") - PolarCoordinate => extract_vector_field(state, "PolarCoordinate") - UnitRadialVector_inCartesian => extract_vector_field(state, & - "UnitRadialVector_inCartesian") - UnitPolarVector_inCartesian => extract_vector_field(state, & - "UnitPolarVector_inCartesian") - UnitAzimuthalVector_inCartesian => extract_vector_field(state, & - "UnitAzimuthalVector_inCartesian") - UnitRadialVector_inPolar => extract_vector_field(state, "UnitRadialVector_inPolar") - UnitPolarVector_inPolar => extract_vector_field(state, "UnitPolarVector_inPolar") - UnitAzimuthalVector_inPolar => extract_vector_field(state, & - "UnitAzimuthalVector_inPolar") + call vtk_read_state("data/on_sphere_rotations/spherical_shell_withFields.vtu", state) + mesh => extract_mesh(state, "Mesh") + CartesianCoordinate => extract_vector_field(state, "CartesianCoordinate") + PolarCoordinate => extract_vector_field(state, "PolarCoordinate") + UnitRadialVector_inCartesian => extract_vector_field(state, & + "UnitRadialVector_inCartesian") + UnitPolarVector_inCartesian => extract_vector_field(state, & + "UnitPolarVector_inCartesian") + UnitAzimuthalVector_inCartesian => extract_vector_field(state, & + "UnitAzimuthalVector_inCartesian") + UnitRadialVector_inPolar => extract_vector_field(state, "UnitRadialVector_inPolar") + UnitPolarVector_inPolar => extract_vector_field(state, "UnitPolarVector_inPolar") + UnitAzimuthalVector_inPolar => extract_vector_field(state, & + "UnitAzimuthalVector_inPolar") - !Test the change of basis from spherical-polar to Cartesian. + !Test the change of basis from spherical-polar to Cartesian. - call allocate(radialVectorDifference, 3, mesh, 'radialVectorDifference') - call zero(radialVectorDifference) - call allocate(polarVectorDifference, 3, mesh, 'polarVectorDifference') - call zero(polarVectorDifference) - call allocate(azimuthalVectorDifference, 3, mesh, 'azimuthalVectorDifference') - call zero(azimuthalVectorDifference) + call allocate(radialVectorDifference, 3, mesh, 'radialVectorDifference') + call zero(radialVectorDifference) + call allocate(polarVectorDifference, 3, mesh, 'polarVectorDifference') + call zero(polarVectorDifference) + call allocate(azimuthalVectorDifference, 3, mesh, 'azimuthalVectorDifference') + call zero(azimuthalVectorDifference) - !Set the components difference-vector equal to the unit radial vector, and apply - ! transformation to Cartesian basis. Then compare with vector already in Cartesian - ! basis, obtained from vtu. - call vector_spherical_polar_2_cartesian(UnitRadialVector_inPolar, & - PolarCoordinate, & - radialVectorDifference, & - CartesianCoordinate) - call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) - fail = any(radialVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Spherical-polar to Cartesian of unit-radial vector field.]", & - fail, .false., "Radial unit vector components not transformed correctly.") + !Set the components difference-vector equal to the unit radial vector, and apply + ! transformation to Cartesian basis. Then compare with vector already in Cartesian + ! basis, obtained from vtu. + call vector_spherical_polar_2_cartesian(UnitRadialVector_inPolar, & + PolarCoordinate, & + radialVectorDifference, & + CartesianCoordinate) + call addto(radialVectorDifference, UnitRadialVector_inCartesian, -1.0) + fail = any(radialVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Spherical-polar to Cartesian of unit-radial vector field.]", & + fail, .false., "Radial unit vector components not transformed correctly.") - !Set the components difference-vector equal to the unit-polar vector, and apply - ! transformation to Cartesian basis. Then compare with vector already in Cartesian - ! basis, obtained from vtu. - call vector_spherical_polar_2_cartesian(UnitPolarVector_inPolar, & - PolarCoordinate, & - polarVectorDifference, & - CartesianCoordinate) - call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) - fail = any(polarVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Spherical-polar to Cartesian of unit-polar vector field.]", & - fail, .false., "Polar unit vector components not transformed correctly.") + !Set the components difference-vector equal to the unit-polar vector, and apply + ! transformation to Cartesian basis. Then compare with vector already in Cartesian + ! basis, obtained from vtu. + call vector_spherical_polar_2_cartesian(UnitPolarVector_inPolar, & + PolarCoordinate, & + polarVectorDifference, & + CartesianCoordinate) + call addto(polarVectorDifference, UnitPolarVector_inCartesian, -1.0) + fail = any(polarVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Spherical-polar to Cartesian of unit-polar vector field.]", & + fail, .false., "Polar unit vector components not transformed correctly.") - !Set the components difference-vector equal to the unit-azimuthal vector, and apply - ! transformation to Cartesian basis. Then compare with vector already in Cartesian - ! basis, obtained from vtu. - call vector_spherical_polar_2_cartesian(UnitAzimuthalVector_inPolar, & - PolarCoordinate, & - azimuthalVectorDifference, & - CartesianCoordinate) - call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) - fail = any(azimuthalVectorDifference%val > 1e-12) - call report_test( & - "[Vector basis change: Spherical-polar to Cartesian of unit-azimuthal vector field.]", & - fail, .false., "Azimuthal unit vector components not transformed correctly.") + !Set the components difference-vector equal to the unit-azimuthal vector, and apply + ! transformation to Cartesian basis. Then compare with vector already in Cartesian + ! basis, obtained from vtu. + call vector_spherical_polar_2_cartesian(UnitAzimuthalVector_inPolar, & + PolarCoordinate, & + azimuthalVectorDifference, & + CartesianCoordinate) + call addto(azimuthalVectorDifference, UnitAzimuthalVector_inCartesian, -1.0) + fail = any(azimuthalVectorDifference%val > 1e-12) + call report_test( & + "[Vector basis change: Spherical-polar to Cartesian of unit-azimuthal vector field.]", & + fail, .false., "Azimuthal unit vector components not transformed correctly.") - call deallocate(radialVectorDifference) - call deallocate(polarVectorDifference) - call deallocate(azimuthalVectorDifference) + call deallocate(radialVectorDifference) + call deallocate(polarVectorDifference) + call deallocate(azimuthalVectorDifference) end subroutine diff --git a/femtools/tests/test_vtk_elements.F90 b/femtools/tests/test_vtk_elements.F90 index b70e4a65b6..1130bdc42b 100644 --- a/femtools/tests/test_vtk_elements.F90 +++ b/femtools/tests/test_vtk_elements.F90 @@ -49,7 +49,7 @@ subroutine test_vtk_elements mesh_in => extract_mesh(state, "Mesh") call report_test("[vtk_triangle]", .not. all(mesh%ndglno == mesh_in%ndglno),& - .false., "DOFs are not in Fluidity ordering") + .false., "DOFs are not in Fluidity ordering") call deallocate(quad); call deallocate(ele); call deallocate(mesh) call deallocate(pos); call deallocate(sfields(1)); call deallocate(state) @@ -76,7 +76,7 @@ subroutine test_vtk_elements mesh_in => extract_mesh(state, "Mesh") call report_test("[vtk_quad]", .not. all(mesh%ndglno == mesh_in%ndglno), & - .false., "DOFs are not in Fluidity ordering") + .false., "DOFs are not in Fluidity ordering") call deallocate(quad); call deallocate(ele); call deallocate(mesh) call deallocate(pos); call deallocate(sfields(1)); call deallocate(state) @@ -104,7 +104,7 @@ subroutine test_vtk_elements mesh_in => extract_mesh(state, "Mesh") call report_test("[vtk_tetra]", .not. all(mesh%ndglno == mesh_in%ndglno), & - .false., "DOFs are not in Fluidity ordering") + .false., "DOFs are not in Fluidity ordering") call deallocate(quad); call deallocate(ele); call deallocate(mesh) call deallocate(pos); call deallocate(sfields(1)); call deallocate(state) @@ -120,17 +120,17 @@ subroutine test_vtk_elements call allocate(pos, 3, mesh, "Pos") pos%val(1,:) = [0.5, 0.6, 0.6, 0.5, 0.0, 1.2, 1.2, 0.0, & - 0.7, 1.9, 1.9, 0.7, 1.2, 1.3, 1.3, 1.2, & - 1.9, 2.0, 2.0, 1.9, 1.4, 2.6, 2.6, 1.4, & - 2.1, 3.3, 3.3, 2.1, 2.6, 2.7, 2.7, 2.6 ] + 0.7, 1.9, 1.9, 0.7, 1.2, 1.3, 1.3, 1.2, & + 1.9, 2.0, 2.0, 1.9, 1.4, 2.6, 2.6, 1.4, & + 2.1, 3.3, 3.3, 2.1, 2.6, 2.7, 2.7, 2.6 ] pos%val(2,:) = [0.0, 0.0, 1.2, 1.2, 0.5, 0.5, 0.6, 0.6, & - 0.5, 0.5, 0.6, 0.6, 0.0, 0.0, 1.2, 1.2, & - 0.0, 0.0, 1.2, 1.2, 0.5, 0.5, 0.6, 0.6, & - 0.5, 0.5, 0.6, 0.6, 0.0, 0.0, 1.2, 1.2 ] + 0.5, 0.5, 0.6, 0.6, 0.0, 0.0, 1.2, 1.2, & + 0.0, 0.0, 1.2, 1.2, 0.5, 0.5, 0.6, 0.6, & + 0.5, 0.5, 0.6, 0.6, 0.0, 0.0, 1.2, 1.2 ] pos%val(3,:) = [0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, & - 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, & - 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, & - 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0 ] + 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, & + 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, & + 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0, 2.0 ] call allocate(sfields(1), mesh, "TestField") sfields(1)%val = [(i, i=1, n_nodes)] @@ -140,7 +140,7 @@ subroutine test_vtk_elements mesh_in => extract_mesh(state, "Mesh") call report_test("[vtk_hexahedra]", .not. all(mesh%ndglno == mesh_in%ndglno), & - .false., "DOFs are not in Fluidity ordering") + .false., "DOFs are not in Fluidity ordering") call deallocate(quad); call deallocate(ele); call deallocate(mesh) call deallocate(pos); call deallocate(sfields(1)); call deallocate(state) diff --git a/femtools/tests/test_vtk_precision.F90 b/femtools/tests/test_vtk_precision.F90 index daa08d67f3..63c15daac3 100644 --- a/femtools/tests/test_vtk_precision.F90 +++ b/femtools/tests/test_vtk_precision.F90 @@ -28,121 +28,121 @@ #include "fdebug.h" subroutine test_vtk_precision - !!< Test the precision of VTK I/O - - use iso_c_binding, only: c_float, c_double - use quadrature - use elements - use fields - use fields_data_types - use state_module - use unittest_tools - use vtk_interfaces - - implicit none - - character(len = 255) :: filename - integer :: i, stat - integer, parameter :: D = c_double, S = c_float - type(element_type) :: shape - type(mesh_type) :: mesh - type(quadrature_type) :: quad - type(scalar_field) :: written_s_field - type(scalar_field), pointer :: read_s_field - type(state_type) :: read_state, written_state - type(vector_field) :: mesh_field, written_v_field - type(vector_field), pointer :: read_v_field - - filename = "data/test_vtk_precision_out.vtu" - - ! Allocate a mesh - quad = make_quadrature(vertices = 3, dim = 2, degree = 1) - shape = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) - call allocate(mesh, nodes = 3, elements = 1, shape = shape, name = "CoordinateMesh") - call allocate(mesh_field, mesh_dim(mesh), mesh, "Coordinate") - - ! Create a single triangle mesh - do i = 1, size(mesh%ndglno) - mesh%ndglno(i) = i - end do - call set(mesh_field, 1, (/0.0, 0.0/)) - call set(mesh_field, 2, (/1.0, 0.0/)) - call set(mesh_field, 3, (/1.0, 1.0/)) - - call deallocate(quad) - call deallocate(shape) - call deallocate(mesh) - - call insert(written_state, mesh_field%mesh, "CoordinateMesh") - call insert(written_state, mesh_field, "Coordinate") - - ! Insert empty fields into the state to be written - call allocate(written_s_field, mesh_field%mesh, "TestScalarField", field_type = FIELD_TYPE_CONSTANT) - call zero(written_s_field) - call insert(written_state, written_s_field, "TestScalarField") - call allocate(written_v_field, mesh_dim(mesh_field%mesh), mesh_field%mesh, "TestVectorField", field_type = FIELD_TYPE_CONSTANT) - call zero(written_v_field) - call insert(written_state, written_v_field, "TestVectorField") - - ! Clean existing output - call vtk_write_state(filename, model = "CoordinateMesh", state = (/written_state/), stat = stat) - call report_test("[Clean]", stat /= 0, .false., "Failed to clean output") - call vtk_read_state(filename, state = read_state) - read_v_field => extract_vector_field(read_state, "Coordinate") - call report_test("[Clean]", abs(read_v_field%val(1,1)) > 0.0, .false., "[Failed to clean output]") - read_s_field => extract_scalar_field(read_state, "TestScalarField") - call report_test("[Clean]", any(abs(read_s_field%val) > 0.0), .false., "[Failed to clean output]") - read_v_field => extract_vector_field(read_state, "TestVectorField") - do i = 1, mesh_dim(mesh_field) - call report_test("[Clean]", any(abs(read_v_field%val(1,:)) > 0.0), .false., "[Failed to clean output]") - end do - call deallocate(read_state) - nullify(read_s_field) - nullify(read_v_field) - - call set(mesh_field, 1, real((/tiny(0.0_S) * 1.0_S, 0.0_S/))) - call set(written_s_field, real(tiny(0.0_S) * 1.0_S)) - call set(written_v_field, real((/tiny(0.0_S) * 1.0_S, 0.0_S/))) - call vtk_write_state(filename, model = "CoordinateMesh", state = (/written_state/), stat = stat) - call report_test("[vtk_write_state]", stat /= 0, .false., "Failed to write state") - - call vtk_read_state(filename, state = read_state) - read_v_field => extract_vector_field(read_state, "Coordinate") - call report_test("[Coordinate field, tiny, c_float precision]", read_v_field%val(1,1) < tiny(0.0_S), .false., "[Insufficient precision]") - read_s_field => extract_scalar_field(read_state, "TestScalarField") - read_v_field => extract_vector_field(read_state, "TestVectorField") - call report_test("[Scalar field, tiny, c_float precision]", any(read_s_field%val < tiny(0.0_S)), .false., "[Insufficient precision]") - call report_test("[Vector field, tiny, c_float precision]", any(read_v_field%val(1,:) < tiny(0.0_S)), .false., "[Insufficient precision]") - call deallocate(read_state) - nullify(read_s_field) - nullify(read_v_field) + !!< Test the precision of VTK I/O + + use iso_c_binding, only: c_float, c_double + use quadrature + use elements + use fields + use fields_data_types + use state_module + use unittest_tools + use vtk_interfaces + + implicit none + + character(len = 255) :: filename + integer :: i, stat + integer, parameter :: D = c_double, S = c_float + type(element_type) :: shape + type(mesh_type) :: mesh + type(quadrature_type) :: quad + type(scalar_field) :: written_s_field + type(scalar_field), pointer :: read_s_field + type(state_type) :: read_state, written_state + type(vector_field) :: mesh_field, written_v_field + type(vector_field), pointer :: read_v_field + + filename = "data/test_vtk_precision_out.vtu" + + ! Allocate a mesh + quad = make_quadrature(vertices = 3, dim = 2, degree = 1) + shape = make_element_shape(vertices = 3, dim = 2, degree = 1, quad = quad) + call allocate(mesh, nodes = 3, elements = 1, shape = shape, name = "CoordinateMesh") + call allocate(mesh_field, mesh_dim(mesh), mesh, "Coordinate") + + ! Create a single triangle mesh + do i = 1, size(mesh%ndglno) + mesh%ndglno(i) = i + end do + call set(mesh_field, 1, (/0.0, 0.0/)) + call set(mesh_field, 2, (/1.0, 0.0/)) + call set(mesh_field, 3, (/1.0, 1.0/)) + + call deallocate(quad) + call deallocate(shape) + call deallocate(mesh) + + call insert(written_state, mesh_field%mesh, "CoordinateMesh") + call insert(written_state, mesh_field, "Coordinate") + + ! Insert empty fields into the state to be written + call allocate(written_s_field, mesh_field%mesh, "TestScalarField", field_type = FIELD_TYPE_CONSTANT) + call zero(written_s_field) + call insert(written_state, written_s_field, "TestScalarField") + call allocate(written_v_field, mesh_dim(mesh_field%mesh), mesh_field%mesh, "TestVectorField", field_type = FIELD_TYPE_CONSTANT) + call zero(written_v_field) + call insert(written_state, written_v_field, "TestVectorField") + + ! Clean existing output + call vtk_write_state(filename, model = "CoordinateMesh", state = (/written_state/), stat = stat) + call report_test("[Clean]", stat /= 0, .false., "Failed to clean output") + call vtk_read_state(filename, state = read_state) + read_v_field => extract_vector_field(read_state, "Coordinate") + call report_test("[Clean]", abs(read_v_field%val(1,1)) > 0.0, .false., "[Failed to clean output]") + read_s_field => extract_scalar_field(read_state, "TestScalarField") + call report_test("[Clean]", any(abs(read_s_field%val) > 0.0), .false., "[Failed to clean output]") + read_v_field => extract_vector_field(read_state, "TestVectorField") + do i = 1, mesh_dim(mesh_field) + call report_test("[Clean]", any(abs(read_v_field%val(1,:)) > 0.0), .false., "[Failed to clean output]") + end do + call deallocate(read_state) + nullify(read_s_field) + nullify(read_v_field) + + call set(mesh_field, 1, real((/tiny(0.0_S) * 1.0_S, 0.0_S/))) + call set(written_s_field, real(tiny(0.0_S) * 1.0_S)) + call set(written_v_field, real((/tiny(0.0_S) * 1.0_S, 0.0_S/))) + call vtk_write_state(filename, model = "CoordinateMesh", state = (/written_state/), stat = stat) + call report_test("[vtk_write_state]", stat /= 0, .false., "Failed to write state") + + call vtk_read_state(filename, state = read_state) + read_v_field => extract_vector_field(read_state, "Coordinate") + call report_test("[Coordinate field, tiny, c_float precision]", read_v_field%val(1,1) < tiny(0.0_S), .false., "[Insufficient precision]") + read_s_field => extract_scalar_field(read_state, "TestScalarField") + read_v_field => extract_vector_field(read_state, "TestVectorField") + call report_test("[Scalar field, tiny, c_float precision]", any(read_s_field%val < tiny(0.0_S)), .false., "[Insufficient precision]") + call report_test("[Vector field, tiny, c_float precision]", any(read_v_field%val(1,:) < tiny(0.0_S)), .false., "[Insufficient precision]") + call deallocate(read_state) + nullify(read_s_field) + nullify(read_v_field) #ifdef DOUBLEP - call set(mesh_field, 1, (/tiny(0.0_D) * 1.0_D, 0.0_D/)) - call set(written_s_field, tiny(0.0_D) * 1.0_D) - call set(written_v_field, (/tiny(0.0_D) * 1.0_D, 0.0_D/)) - call vtk_write_state(filename, model = "CoordinateMesh", state = (/written_state/), stat = stat) - call report_test("[vtk_write_state]", stat /= 0, .false., "Failed to write state") - - call vtk_read_state(filename, state = read_state) - read_v_field => extract_vector_field(read_state, "Coordinate") - call report_test("[Coordinate field, tiny, c_double precision]", read_v_field%val(1,1) < tiny(0.0_D), .false., "[Insufficient precision]") - read_s_field => extract_scalar_field(read_state, "TestScalarField") - read_v_field => extract_vector_field(read_state, "TestVectorField") - call report_test("[Scalar field, tiny, c_double precision]", any(read_s_field%val < tiny(0.0_D)), .false., "[Insufficient precision]") - call report_test("[Vector field, tiny, c_double precision]", any(read_v_field%val(1,:) < tiny(0.0_D)), .false., "[Insufficient precision]") - call deallocate(read_state) - nullify(read_s_field) - nullify(read_v_field) + call set(mesh_field, 1, (/tiny(0.0_D) * 1.0_D, 0.0_D/)) + call set(written_s_field, tiny(0.0_D) * 1.0_D) + call set(written_v_field, (/tiny(0.0_D) * 1.0_D, 0.0_D/)) + call vtk_write_state(filename, model = "CoordinateMesh", state = (/written_state/), stat = stat) + call report_test("[vtk_write_state]", stat /= 0, .false., "Failed to write state") + + call vtk_read_state(filename, state = read_state) + read_v_field => extract_vector_field(read_state, "Coordinate") + call report_test("[Coordinate field, tiny, c_double precision]", read_v_field%val(1,1) < tiny(0.0_D), .false., "[Insufficient precision]") + read_s_field => extract_scalar_field(read_state, "TestScalarField") + read_v_field => extract_vector_field(read_state, "TestVectorField") + call report_test("[Scalar field, tiny, c_double precision]", any(read_s_field%val < tiny(0.0_D)), .false., "[Insufficient precision]") + call report_test("[Vector field, tiny, c_double precision]", any(read_v_field%val(1,:) < tiny(0.0_D)), .false., "[Insufficient precision]") + call deallocate(read_state) + nullify(read_s_field) + nullify(read_v_field) #endif - ! TODO: Similar tests for tensor fields, similar tests using epsilon + ! TODO: Similar tests for tensor fields, similar tests using epsilon - call deallocate(written_s_field) - call deallocate(written_v_field) - call deallocate(mesh_field) - call deallocate(written_state) + call deallocate(written_s_field) + call deallocate(written_v_field) + call deallocate(mesh_field) + call deallocate(written_state) - call report_test_no_references() + call report_test_no_references() end subroutine test_vtk_precision diff --git a/femtools/tests/test_vtk_read_state.F90 b/femtools/tests/test_vtk_read_state.F90 index bd7a8584a4..e9fa7837af 100644 --- a/femtools/tests/test_vtk_read_state.F90 +++ b/femtools/tests/test_vtk_read_state.F90 @@ -1,51 +1,51 @@ subroutine test_vtk_read_state - !!< Does vtk_read_state read in a mesh properly? + !!< Does vtk_read_state read in a mesh properly? - use vtk_interfaces - use elements - use state_module - use unittest_tools - use fields - implicit none + use vtk_interfaces + use elements + use state_module + use unittest_tools + use fields + implicit none - type(state_type) :: state - type(mesh_type), pointer :: mesh + type(state_type) :: state + type(mesh_type), pointer :: mesh - ! This is what it SHOULD be. - integer :: nodes = 8 - integer :: elementcnt = 6 + ! This is what it SHOULD be. + integer :: nodes = 8 + integer :: elementcnt = 6 ! integer, dimension(24) :: ndglno = (/2, 4, 3, 7, 6, 7, 8, 4, 2, 7, 6, 4, 2, 1, 4, 5, 6, 8, 5, 4, 2, 6, 5, 4/) - integer :: loccount = 4 - integer :: dim = 3 - integer :: degree = 1 - logical :: fail = .false., warn = .false. + integer :: loccount = 4 + integer :: dim = 3 + integer :: degree = 1 + logical :: fail = .false., warn = .false. - call vtk_read_state("data/mesh_0.vtu", state) - mesh => extract_mesh(state, "Mesh") + call vtk_read_state("data/mesh_0.vtu", state) + mesh => extract_mesh(state, "Mesh") - if (mesh%nodes /= nodes) fail = .true. - call report_test("[vtk_read_state nodecount]", fail, warn, "Nodecount should be the known value.") + if (mesh%nodes /= nodes) fail = .true. + call report_test("[vtk_read_state nodecount]", fail, warn, "Nodecount should be the known value.") - fail = .false. - if (mesh%elements /= elementcnt) fail = .true. - call report_test("[vtk_read_state element count]", fail, warn, "Element count should be the known value.") + fail = .false. + if (mesh%elements /= elementcnt) fail = .true. + call report_test("[vtk_read_state element count]", fail, warn, "Element count should be the known value.") - fail = .false. - if (ele_loc(mesh, 1) /= loccount) fail = .true. - call report_test("[vtk_read_state loccount]", fail, warn, "Element type should be the known value.") + fail = .false. + if (ele_loc(mesh, 1) /= loccount) fail = .true. + call report_test("[vtk_read_state loccount]", fail, warn, "Element type should be the known value.") - fail = .false. - if (mesh%shape%dim /= dim) fail = .true. - call report_test("[vtk_read_state dim]", fail, warn, "Dimension should be the known value.") + fail = .false. + if (mesh%shape%dim /= dim) fail = .true. + call report_test("[vtk_read_state dim]", fail, warn, "Dimension should be the known value.") - fail = .false. - if (mesh%shape%degree /= degree) fail = .true. - call report_test("[vtk_read_state degree]", fail, warn, "Polynomial degree should be the known value") + fail = .false. + if (mesh%shape%degree /= degree) fail = .true. + call report_test("[vtk_read_state degree]", fail, warn, "Polynomial degree should be the known value") - fail = .false. - if (associated(state%scalar_fields)) fail = .true. - call report_test("[vtk_read_state fields]", fail, warn, "This VTU has no scalar fields.") + fail = .false. + if (associated(state%scalar_fields)) fail = .true. + call report_test("[vtk_read_state fields]", fail, warn, "This VTU has no scalar fields.") - call deallocate(state) + call deallocate(state) end subroutine test_vtk_read_state diff --git a/femtools/tests/test_vtk_read_surface.F90 b/femtools/tests/test_vtk_read_surface.F90 index 7ca6d77188..cbad755d66 100644 --- a/femtools/tests/test_vtk_read_surface.F90 +++ b/femtools/tests/test_vtk_read_surface.F90 @@ -30,33 +30,33 @@ subroutine test_vtk_read_surface - use fields - use fldebug - use state_module - use unittest_tools - use vtk_interfaces + use fields + use fldebug + use state_module + use unittest_tools + use vtk_interfaces - !use mesh_files + !use mesh_files - implicit none + implicit none - type(mesh_type), pointer :: mesh - type(state_type) :: state + type(mesh_type), pointer :: mesh + type(state_type) :: state - !type(vector_field), target :: coordinate + !type(vector_field), target :: coordinate - call vtk_read_state("data/tet.vtu", state = state) - mesh => extract_mesh(state, "Mesh") - !coordinate = read_mesh_files("data/tet", quad_degree = 1, format="gmsh") - !mesh => coordinate%mesh + call vtk_read_state("data/tet.vtu", state = state) + mesh => extract_mesh(state, "Mesh") + !coordinate = read_mesh_files("data/tet", quad_degree = 1, format="gmsh") + !mesh => coordinate%mesh - call report_test("[node_count]", node_count(mesh) /= 4, .false., "Incorrect element count") - call report_test("[ele_count]", ele_count(mesh) /= 1, .false., "Incorrect element count") - call report_test("[surface_element_count]", surface_element_count(mesh) /= 4, .false., "Incorrect element count") + call report_test("[node_count]", node_count(mesh) /= 4, .false., "Incorrect element count") + call report_test("[ele_count]", ele_count(mesh) /= 1, .false., "Incorrect element count") + call report_test("[surface_element_count]", surface_element_count(mesh) /= 4, .false., "Incorrect element count") - call deallocate(state) - !call deallocate(coordinate) + call deallocate(state) + !call deallocate(coordinate) - call report_test_no_references() + call report_test_no_references() end subroutine test_vtk_read_surface diff --git a/femtools/tests/test_wall_time_support.F90 b/femtools/tests/test_wall_time_support.F90 index 7fb5f677a8..17174a44b0 100644 --- a/femtools/tests/test_wall_time_support.F90 +++ b/femtools/tests/test_wall_time_support.F90 @@ -1,10 +1,10 @@ subroutine test_wall_time_support - use timers - use unittest_tools + use timers + use unittest_tools - implicit none + implicit none - call report_test("[Wall time supported]", .not. wall_time_supported(), .false., "Wall time not supported") + call report_test("[Wall time supported]", .not. wall_time_supported(), .false., "Wall time not supported") end subroutine test_wall_time_support diff --git a/femtools/tests/test_wandzura_quadrature.F90 b/femtools/tests/test_wandzura_quadrature.F90 index b6a4ec5007..b1cf8c212d 100644 --- a/femtools/tests/test_wandzura_quadrature.F90 +++ b/femtools/tests/test_wandzura_quadrature.F90 @@ -26,54 +26,54 @@ ! USA subroutine test_wandzura_quadrature - use quadrature_test - use unittest_tools - implicit none + use quadrature_test + use unittest_tools + implicit none - integer :: dim, vertices - logical :: fail - integer :: degree, stat - type(quadrature_type) :: quadrature - character(len=254) :: error_message, test_message + integer :: dim, vertices + logical :: fail + integer :: degree, stat + type(quadrature_type) :: quadrature + character(len=254) :: error_message, test_message - dim = 2 - vertices = 3 + dim = 2 + vertices = 3 - degree = 0 - degreeloop: do - degree = degree + 1 - quadrature = make_quadrature(vertices, dim, degree=degree, family=FAMILY_WANDZURA, stat=stat) + degree = 0 + degreeloop: do + degree = degree + 1 + quadrature = make_quadrature(vertices, dim, degree=degree, family=FAMILY_WANDZURA, stat=stat) - select case (stat) - case (QUADRATURE_DEGREE_ERROR) - exit degreeloop - case (0) - continue - case default - fail = .true. - call report_test("[test_wandzura_quadrature]", fail, .false., "Making quadrature failed") - end select + select case (stat) + case (QUADRATURE_DEGREE_ERROR) + exit degreeloop + case (0) + continue + case default + fail = .true. + call report_test("[test_wandzura_quadrature]", fail, .false., "Making quadrature failed") + end select - degree = quadrature%degree + degree = quadrature%degree - do power=0,degree - if(quad_integrate(monic, quadrature) .fne. simplex_answer()) then - fail = .true. - write(error_message, '(e15.7)') quad_integrate(monic, quadrature)-simplex_answer() - else - fail = .false. - error_message = "" - end if + do power=0,degree + if(quad_integrate(monic, quadrature) .fne. simplex_answer()) then + fail = .true. + write(error_message, '(e15.7)') quad_integrate(monic, quadrature)-simplex_answer() + else + fail = .false. + error_message = "" + end if - write(test_message, '(3(a,i0),a)') "[",dim,"-simplex, quad degree ",degree," power ",power," ]" - call report_test(trim(test_message), fail, .false., trim(error_message)) - end do + write(test_message, '(3(a,i0),a)') "[",dim,"-simplex, quad degree ",degree," power ",power," ]" + call report_test(trim(test_message), fail, .false., trim(error_message)) + end do - call deallocate(quadrature) - end do degreeloop + call deallocate(quadrature) + end do degreeloop - contains - function simplex_answer() +contains + function simplex_answer() ! Analytic solution to integrating monic over a simplex. ! This formula is eq. 7.38 and 7.48 in Zienkiewicz and Taylor real :: simplex_answer @@ -81,11 +81,11 @@ function simplex_answer() simplex_answer = 1.0 do i=0,dim-1 - j = power + dim - i - if (j <= 1) exit - simplex_answer = simplex_answer * j + j = power + dim - i + if (j <= 1) exit + simplex_answer = simplex_answer * j end do simplex_answer = 1.0/simplex_answer - end function simplex_answer + end function simplex_answer end subroutine test_wandzura_quadrature diff --git a/femtools/testvectortools.F90 b/femtools/testvectortools.F90 index 1cdd7b41a5..dcac1fae5d 100644 --- a/femtools/testvectortools.F90 +++ b/femtools/testvectortools.F90 @@ -1,37 +1,37 @@ #include "fdebug.h" program testvectortools - use vector_tools - implicit none + use vector_tools + implicit none - integer, parameter :: N=50 - real, dimension(N,N) :: ident, A, Ainv - integer :: i,j,k + integer, parameter :: N=50 + real, dimension(N,N) :: ident, A, Ainv + integer :: i,j,k - ident=0.0 + ident=0.0 - forall(i=1:N) ident(i,i)=1.0 + forall(i=1:N) ident(i,i)=1.0 - k=0 - do i=1,N - do j=1,N - k=k+1 - A(i,j)=-1 - end do - end do + k=0 + do i=1,N + do j=1,N + k=k+1 + A(i,j)=-1 + end do + end do - forall(i=1:N) A(i,i)=N + forall(i=1:N) A(i,i)=N - Ainv=A + Ainv=A - call invert(Ainv) + call invert(Ainv) - print *,'Error in invert:', maxval(abs(matmul(A,Ainv)-ident)) + print *,'Error in invert:', maxval(abs(matmul(A,Ainv)-ident)) - Ainv=A + Ainv=A - call cholesky_factor(Ainv) + call cholesky_factor(Ainv) - print *,'Error in cholesky_factor:', & - maxval(abs(matmul(transpose(Ainv),Ainv)-A)) + print *,'Error in cholesky_factor:', & + maxval(abs(matmul(transpose(Ainv),Ainv)-A)) end program testvectortools diff --git a/femtools/tictoc.F90 b/femtools/tictoc.F90 index 300538e2bc..e9bc7e5f90 100644 --- a/femtools/tictoc.F90 +++ b/femtools/tictoc.F90 @@ -29,193 +29,193 @@ module tictoc - use fldebug - use mpi_interfaces - use parallel_tools - use timers + use fldebug + use mpi_interfaces + use parallel_tools + use timers - implicit none + implicit none - private + private - public :: tic, toc, tictoc_reset, tictoc_clear, tictoc_time, & - & tictoc_imbalance, tictoc_report + public :: tic, toc, tictoc_reset, tictoc_clear, tictoc_time, & + & tictoc_imbalance, tictoc_report - integer, parameter :: MAX_TIC_ID = 1024 - integer, parameter, public :: TICTOC_ID_SIMULATION = 1, & - & TICTOC_ID_SERIAL_ADAPT = 2, TICTOC_ID_DATA_MIGRATION = 3, & - & TICTOC_ID_ADAPT = 4, TICTOC_ID_IO_READ = 5, TICTOC_ID_DATA_REMAP = 6, & - & TICTOC_ID_INTERPOLATION = 7, TICTOC_ID_ASSEMBLE_METRIC = 8, TICTOC_ID_TIMESTEP = 9 + integer, parameter :: MAX_TIC_ID = 1024 + integer, parameter, public :: TICTOC_ID_SIMULATION = 1, & + & TICTOC_ID_SERIAL_ADAPT = 2, TICTOC_ID_DATA_MIGRATION = 3, & + & TICTOC_ID_ADAPT = 4, TICTOC_ID_IO_READ = 5, TICTOC_ID_DATA_REMAP = 6, & + & TICTOC_ID_INTERPOLATION = 7, TICTOC_ID_ASSEMBLE_METRIC = 8, TICTOC_ID_TIMESTEP = 9 - real :: starttime(MAX_TIC_ID) = 0.0, totaltime(MAX_TIC_ID) = 0.0 + real :: starttime(MAX_TIC_ID) = 0.0, totaltime(MAX_TIC_ID) = 0.0 #ifdef DDEBUG - logical :: timer_running(MAX_TIC_ID) = .false. + logical :: timer_running(MAX_TIC_ID) = .false. #endif contains - subroutine tic(id) - integer, intent(in) :: id + subroutine tic(id) + integer, intent(in) :: id - assert(id > 0) - assert(id <= MAX_TIC_ID) + assert(id > 0) + assert(id <= MAX_TIC_ID) - starttime(id) = wall_time() + starttime(id) = wall_time() #ifdef DDEBUG - timer_running(id) = .true. + timer_running(id) = .true. #endif - end subroutine tic + end subroutine tic - subroutine toc(id) - integer, intent(in) :: id + subroutine toc(id) + integer, intent(in) :: id - real :: finish_time + real :: finish_time - assert(id > 0) - assert(id <= MAX_TIC_ID) + assert(id > 0) + assert(id <= MAX_TIC_ID) #ifdef DDEBUG - assert(timer_running(id)) + assert(timer_running(id)) #endif - finish_time = wall_time() - totaltime(id) = totaltime(id) + (finish_time - starttime(id)) + finish_time = wall_time() + totaltime(id) = totaltime(id) + (finish_time - starttime(id)) #ifdef DDEBUG - timer_running(id) = .false. + timer_running(id) = .false. #endif - end subroutine toc + end subroutine toc - subroutine tictoc_reset() - starttime = 0.0 - totaltime = 0.0 - end subroutine tictoc_reset + subroutine tictoc_reset() + starttime = 0.0 + totaltime = 0.0 + end subroutine tictoc_reset - subroutine tictoc_clear(id) - integer, intent(in) :: id + subroutine tictoc_clear(id) + integer, intent(in) :: id - assert(id > 0) - assert(id <= MAX_TIC_ID) + assert(id > 0) + assert(id <= MAX_TIC_ID) - starttime(id) = 0.0 - totaltime(id) = 0.0 + starttime(id) = 0.0 + totaltime(id) = 0.0 - end subroutine tictoc_clear + end subroutine tictoc_clear - real function tictoc_time(id) - integer, intent(in) :: id + real function tictoc_time(id) + integer, intent(in) :: id - assert(id > 0) - assert(id <= MAX_TIC_ID) + assert(id > 0) + assert(id <= MAX_TIC_ID) - tictoc_time = totaltime(id) + tictoc_time = totaltime(id) - end function tictoc_time + end function tictoc_time - real function tictoc_imbalance(id) - integer, intent(in) :: id + real function tictoc_imbalance(id) + integer, intent(in) :: id #ifdef HAVE_MPI - real :: dt, max_time, mean_time - real, dimension(:), allocatable :: times - integer :: i, nprocs, rank, ierr + real :: dt, max_time, mean_time + real, dimension(:), allocatable :: times + integer :: i, nprocs, rank, ierr #endif - assert(id > 0) - assert(id <= MAX_TIC_ID) + assert(id > 0) + assert(id <= MAX_TIC_ID) - tictoc_imbalance = 0.0 + tictoc_imbalance = 0.0 #ifdef HAVE_MPI - if(isparallel()) then - dt = tictoc_time(id) - nprocs = getnprocs() - rank = getrank() - allocate(times(nprocs)) - call MPI_Gather(dt, 1, getpreal(), times, 1, getpreal(), 0, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) - - if(rank == 0) then - mean_time = times(1) - max_time = times(1) - - do i = 2, nprocs - mean_time = mean_time + times(i) - max_time = max(max_time, times(i)) - end do - - mean_time = mean_time / nprocs - - tictoc_imbalance = (max_time - mean_time) / mean_time - end if + if(isparallel()) then + dt = tictoc_time(id) + nprocs = getnprocs() + rank = getrank() + allocate(times(nprocs)) + call MPI_Gather(dt, 1, getpreal(), times, 1, getpreal(), 0, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) + + if(rank == 0) then + mean_time = times(1) + max_time = times(1) + + do i = 2, nprocs + mean_time = mean_time + times(i) + max_time = max(max_time, times(i)) + end do + + mean_time = mean_time / nprocs + + tictoc_imbalance = (max_time - mean_time) / mean_time + end if - call MPI_BCast(tictoc_imbalance, 1, getpreal(), 0, MPI_COMM_FEMTOOLS, ierr) - assert(ierr == MPI_SUCCESS) + call MPI_BCast(tictoc_imbalance, 1, getpreal(), 0, MPI_COMM_FEMTOOLS, ierr) + assert(ierr == MPI_SUCCESS) - deallocate(times) - end if + deallocate(times) + end if #endif - end function tictoc_imbalance - - subroutine tictoc_report(debug_level, id) - - integer, intent(in) :: debug_level - integer, intent(in) :: id - - real :: imbalance, max_time, min_time, time - - assert(id > 0) - assert(id <= MAX_TIC_ID) - - if(debug_level > current_debug_level) return - - time = tictoc_time(id) - - if(isparallel()) then - min_time = time - max_time = time - call allmin(min_time) - call allmax(max_time) - imbalance = tictoc_imbalance(id) - end if - - if(getrank() == 0) then - select case(id) - case(TICTOC_ID_SIMULATION) - ewrite(debug_level, *) "For TICTOC_ID_SIMULATION" - case(TICTOC_ID_SERIAL_ADAPT) - ewrite(debug_level, *) "For TICTOC_ID_SERIAL_ADAPT" - case(TICTOC_ID_DATA_MIGRATION) - ewrite(debug_level, *) "For TICTOC_DATA_MIGRATION" - case(TICTOC_ID_DATA_REMAP) - ewrite(debug_level, *) "For TICTOC_DATA_REMAP" - case(TICTOC_ID_ADAPT) - ewrite(debug_level, *) "For TICTOC_ID_ADAPT" - case(TICTOC_ID_IO_READ) - ewrite(debug_level, *) "For TICTOC_ID_IO_READ" - case(TICTOC_ID_INTERPOLATION) - ewrite(debug_level, *) "For TICTOC_ID_INTERPOLATION" - case(TICTOC_ID_ASSEMBLE_METRIC) - ewrite(debug_level, *) "For TICTOC_ID_ASSEMBLE_METRIC" - case(TICTOC_ID_TIMESTEP) - ewrite(debug_level, *) "For TICTOC_ID_TIMESTEP (excluding time in mesh adaptivity, if applicable)" - case default - ewrite(debug_level, "(a,i0)") "For tictoc ID: ", id - end select - - if(isparallel()) then - ewrite(debug_level, *) "Time (process 0) = ", time - ewrite(debug_level, *) "Min. time = ", min_time - ewrite(debug_level, *) "Max. time = ", max_time - ewrite(debug_level, *) "Imbalance = ", imbalance - else - ewrite(debug_level, *) "Time = ", time - end if - end if - - end subroutine tictoc_report + end function tictoc_imbalance + + subroutine tictoc_report(debug_level, id) + + integer, intent(in) :: debug_level + integer, intent(in) :: id + + real :: imbalance, max_time, min_time, time + + assert(id > 0) + assert(id <= MAX_TIC_ID) + + if(debug_level > current_debug_level) return + + time = tictoc_time(id) + + if(isparallel()) then + min_time = time + max_time = time + call allmin(min_time) + call allmax(max_time) + imbalance = tictoc_imbalance(id) + end if + + if(getrank() == 0) then + select case(id) + case(TICTOC_ID_SIMULATION) + ewrite(debug_level, *) "For TICTOC_ID_SIMULATION" + case(TICTOC_ID_SERIAL_ADAPT) + ewrite(debug_level, *) "For TICTOC_ID_SERIAL_ADAPT" + case(TICTOC_ID_DATA_MIGRATION) + ewrite(debug_level, *) "For TICTOC_DATA_MIGRATION" + case(TICTOC_ID_DATA_REMAP) + ewrite(debug_level, *) "For TICTOC_DATA_REMAP" + case(TICTOC_ID_ADAPT) + ewrite(debug_level, *) "For TICTOC_ID_ADAPT" + case(TICTOC_ID_IO_READ) + ewrite(debug_level, *) "For TICTOC_ID_IO_READ" + case(TICTOC_ID_INTERPOLATION) + ewrite(debug_level, *) "For TICTOC_ID_INTERPOLATION" + case(TICTOC_ID_ASSEMBLE_METRIC) + ewrite(debug_level, *) "For TICTOC_ID_ASSEMBLE_METRIC" + case(TICTOC_ID_TIMESTEP) + ewrite(debug_level, *) "For TICTOC_ID_TIMESTEP (excluding time in mesh adaptivity, if applicable)" + case default + ewrite(debug_level, "(a,i0)") "For tictoc ID: ", id + end select + + if(isparallel()) then + ewrite(debug_level, *) "Time (process 0) = ", time + ewrite(debug_level, *) "Min. time = ", min_time + ewrite(debug_level, *) "Max. time = ", max_time + ewrite(debug_level, *) "Imbalance = ", imbalance + else + ewrite(debug_level, *) "Time = ", time + end if + end if + + end subroutine tictoc_report end module tictoc diff --git a/forward_interfaces/Diagnostic_Fields_Wrapper_New.F90 b/forward_interfaces/Diagnostic_Fields_Wrapper_New.F90 index 07bf7945d9..7ff298021a 100644 --- a/forward_interfaces/Diagnostic_Fields_Wrapper_New.F90 +++ b/forward_interfaces/Diagnostic_Fields_Wrapper_New.F90 @@ -29,116 +29,116 @@ module diagnostic_fields_wrapper_new - use global_parameters, only : empty_path, OPTION_PATH_LEN - use futils, only: present_and_true - use fields - use state_module - - implicit none - - private - - public :: calculate_diagnostic_variables, calculate_diagnostic_variable, calculate_diagnostic_variable_dep - - interface calculate_diagnostic_variables_ext - subroutine calculate_diagnostic_variables_multiple(states, states_size, exclude_nonrecalculated) - use state_module - implicit none - integer, intent(in) :: states_size - type(state_type), dimension(states_size), intent(inout) :: states - logical, intent(in) :: exclude_nonrecalculated - end subroutine calculate_diagnostic_variables_multiple - end interface calculate_diagnostic_variables_ext - - interface calculate_diagnostic_variable_ext - subroutine calculate_diagnostic_variable_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, stat) - use fields_data_types, only : scalar_field - use state_module - implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - character(len = algorithm_len), intent(in) :: algorithm - integer, pointer :: stat - end subroutine calculate_diagnostic_variable_scalar - - subroutine calculate_diagnostic_variable_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, stat) - use fields_data_types, only : vector_field - use state_module - implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - character(len = algorithm_len), intent(in) :: algorithm - integer, pointer :: stat - end subroutine calculate_diagnostic_variable_vector - - subroutine calculate_diagnostic_variable_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, stat) - use fields_data_types, only : tensor_field - use state_module - implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - character(len = algorithm_len), intent(in) :: algorithm - integer, pointer :: stat - end subroutine calculate_diagnostic_variable_tensor - end interface calculate_diagnostic_variable_ext - - - interface calculate_diagnostic_variable_dep_ext - subroutine calculate_diagnostic_variable_dep_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, dep_states_mask, stat) - use fields_data_types, only : scalar_field - use state_module - implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - character(len = algorithm_len), intent(in) :: algorithm - type(state_type), dimension(:), pointer :: dep_states_mask - integer, pointer :: stat - end subroutine calculate_diagnostic_variable_dep_scalar - - subroutine calculate_diagnostic_variable_dep_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, dep_states_mask, stat) - use fields_data_types, only : vector_field - use state_module - implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - character(len = algorithm_len), intent(in) :: algorithm - type(state_type), dimension(:), pointer :: dep_states_mask - integer, pointer :: stat - end subroutine calculate_diagnostic_variable_dep_vector - - subroutine calculate_diagnostic_variable_dep_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, dep_states_mask, stat) - use fields_data_types, only : tensor_field - use state_module - implicit none - integer, intent(in) :: states_size - integer, intent(in) :: algorithm_len - type(state_type), dimension(states_size), intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - character(len = algorithm_len), intent(in) :: algorithm - type(state_type), dimension(:), pointer :: dep_states_mask - integer, pointer :: stat - end subroutine calculate_diagnostic_variable_dep_tensor - end interface calculate_diagnostic_variable_dep_ext - - - interface calculate_diagnostic_variable - module procedure calculate_diagnostic_variable_scalar_single, & + use global_parameters, only : empty_path, OPTION_PATH_LEN + use futils, only: present_and_true + use fields + use state_module + + implicit none + + private + + public :: calculate_diagnostic_variables, calculate_diagnostic_variable, calculate_diagnostic_variable_dep + + interface calculate_diagnostic_variables_ext + subroutine calculate_diagnostic_variables_multiple(states, states_size, exclude_nonrecalculated) + use state_module + implicit none + integer, intent(in) :: states_size + type(state_type), dimension(states_size), intent(inout) :: states + logical, intent(in) :: exclude_nonrecalculated + end subroutine calculate_diagnostic_variables_multiple + end interface calculate_diagnostic_variables_ext + + interface calculate_diagnostic_variable_ext + subroutine calculate_diagnostic_variable_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, stat) + use fields_data_types, only : scalar_field + use state_module + implicit none + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + character(len = algorithm_len), intent(in) :: algorithm + integer, pointer :: stat + end subroutine calculate_diagnostic_variable_scalar + + subroutine calculate_diagnostic_variable_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, stat) + use fields_data_types, only : vector_field + use state_module + implicit none + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + character(len = algorithm_len), intent(in) :: algorithm + integer, pointer :: stat + end subroutine calculate_diagnostic_variable_vector + + subroutine calculate_diagnostic_variable_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, stat) + use fields_data_types, only : tensor_field + use state_module + implicit none + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + character(len = algorithm_len), intent(in) :: algorithm + integer, pointer :: stat + end subroutine calculate_diagnostic_variable_tensor + end interface calculate_diagnostic_variable_ext + + + interface calculate_diagnostic_variable_dep_ext + subroutine calculate_diagnostic_variable_dep_scalar(states, states_size, state_index, s_field, algorithm, algorithm_len, dep_states_mask, stat) + use fields_data_types, only : scalar_field + use state_module + implicit none + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + character(len = algorithm_len), intent(in) :: algorithm + type(state_type), dimension(:), pointer :: dep_states_mask + integer, pointer :: stat + end subroutine calculate_diagnostic_variable_dep_scalar + + subroutine calculate_diagnostic_variable_dep_vector(states, states_size, state_index, v_field, algorithm, algorithm_len, dep_states_mask, stat) + use fields_data_types, only : vector_field + use state_module + implicit none + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + character(len = algorithm_len), intent(in) :: algorithm + type(state_type), dimension(:), pointer :: dep_states_mask + integer, pointer :: stat + end subroutine calculate_diagnostic_variable_dep_vector + + subroutine calculate_diagnostic_variable_dep_tensor(states, states_size, state_index, t_field, algorithm, algorithm_len, dep_states_mask, stat) + use fields_data_types, only : tensor_field + use state_module + implicit none + integer, intent(in) :: states_size + integer, intent(in) :: algorithm_len + type(state_type), dimension(states_size), intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + character(len = algorithm_len), intent(in) :: algorithm + type(state_type), dimension(:), pointer :: dep_states_mask + integer, pointer :: stat + end subroutine calculate_diagnostic_variable_dep_tensor + end interface calculate_diagnostic_variable_dep_ext + + + interface calculate_diagnostic_variable + module procedure calculate_diagnostic_variable_scalar_single, & & calculate_diagnostic_variable_scalar_multiple_non_indexed, & & calculate_diagnostic_variable_scalar_multiple_indexed, & & calculate_diagnostic_variable_vector_single, & @@ -147,11 +147,11 @@ end subroutine calculate_diagnostic_variable_dep_tensor & calculate_diagnostic_variable_tensor_single, & & calculate_diagnostic_variable_tensor_multiple_non_indexed, & & calculate_diagnostic_variable_tensor_multiple_indexed - end interface calculate_diagnostic_variable + end interface calculate_diagnostic_variable - interface calculate_diagnostic_variable_dep - module procedure calculate_diagnostic_variable_dep_scalar_single, & + interface calculate_diagnostic_variable_dep + module procedure calculate_diagnostic_variable_dep_scalar_single, & & calculate_diagnostic_variable_dep_scalar_multiple_non_indexed, & & calculate_diagnostic_variable_dep_scalar_multiple_indexed, & & calculate_diagnostic_variable_dep_vector_single, & @@ -160,358 +160,358 @@ end subroutine calculate_diagnostic_variable_dep_tensor & calculate_diagnostic_variable_dep_tensor_single, & & calculate_diagnostic_variable_dep_tensor_multiple_non_indexed, & & calculate_diagnostic_variable_dep_tensor_multiple_indexed - end interface calculate_diagnostic_variable_dep + end interface calculate_diagnostic_variable_dep contains - subroutine calculate_diagnostic_variables(states, exclude_nonrecalculated) - type(state_type), dimension(:), intent(inout) :: states - logical, optional, intent(in) :: exclude_nonrecalculated + subroutine calculate_diagnostic_variables(states, exclude_nonrecalculated) + type(state_type), dimension(:), intent(inout) :: states + logical, optional, intent(in) :: exclude_nonrecalculated + + call calculate_diagnostic_variables_ext(states, size(states), present_and_true(exclude_nonrecalculated)) + + end subroutine calculate_diagnostic_variables + + subroutine calculate_diagnostic_variable_scalar_single(state, s_field, algorithm, stat) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, intent(out) :: stat + + type(state_type), dimension(1) :: states + + states = (/state/) + call calculate_diagnostic_variable(states, 1, s_field, algorithm = algorithm, stat = stat) + state = states(1) + + end subroutine calculate_diagnostic_variable_scalar_single + + subroutine calculate_diagnostic_variable_scalar_multiple_non_indexed(states, s_field, algorithm, stat) + type(state_type), dimension(:), intent(inout) :: states + type(scalar_field), intent(inout) :: s_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, intent(out) :: stat + + call calculate_diagnostic_variable(states, 1, s_field, algorithm = algorithm, stat = stat) + + end subroutine calculate_diagnostic_variable_scalar_multiple_non_indexed + + subroutine calculate_diagnostic_variable_scalar_multiple_indexed(states, state_index, s_field, algorithm, stat) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, target, intent(out) :: stat + + character(len = OPTION_PATH_LEN) :: lalgorithm + integer, pointer :: lstat + + if(present(algorithm)) then + lalgorithm = algorithm + else + lalgorithm = empty_path + end if + if(present(stat)) then + lstat => stat + else + lstat => null() + end if + + call calculate_diagnostic_variable_ext(states, size(states), state_index, s_field, lalgorithm, len_trim(lalgorithm), lstat) + + end subroutine calculate_diagnostic_variable_scalar_multiple_indexed + + subroutine calculate_diagnostic_variable_vector_single(state, v_field, algorithm, stat) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, intent(out) :: stat - call calculate_diagnostic_variables_ext(states, size(states), present_and_true(exclude_nonrecalculated)) + type(state_type), dimension(1) :: states - end subroutine calculate_diagnostic_variables + states = (/state/) + call calculate_diagnostic_variable(states, 1, v_field, algorithm = algorithm, stat = stat) + state = states(1) - subroutine calculate_diagnostic_variable_scalar_single(state, s_field, algorithm, stat) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, intent(out) :: stat + end subroutine calculate_diagnostic_variable_vector_single - type(state_type), dimension(1) :: states + subroutine calculate_diagnostic_variable_vector_multiple_non_indexed(states, v_field, algorithm, stat) + type(state_type), dimension(:), intent(inout) :: states + type(vector_field), intent(inout) :: v_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, intent(out) :: stat - states = (/state/) - call calculate_diagnostic_variable(states, 1, s_field, algorithm = algorithm, stat = stat) - state = states(1) + call calculate_diagnostic_variable(states, 1, v_field, algorithm = algorithm, stat = stat) - end subroutine calculate_diagnostic_variable_scalar_single + end subroutine calculate_diagnostic_variable_vector_multiple_non_indexed - subroutine calculate_diagnostic_variable_scalar_multiple_non_indexed(states, s_field, algorithm, stat) - type(state_type), dimension(:), intent(inout) :: states - type(scalar_field), intent(inout) :: s_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, intent(out) :: stat + subroutine calculate_diagnostic_variable_vector_multiple_indexed(states, state_index, v_field, algorithm, stat) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, target, intent(out) :: stat - call calculate_diagnostic_variable(states, 1, s_field, algorithm = algorithm, stat = stat) + character(len = OPTION_PATH_LEN) :: lalgorithm + integer, pointer :: lstat - end subroutine calculate_diagnostic_variable_scalar_multiple_non_indexed + if(present(algorithm)) then + lalgorithm = algorithm + else + lalgorithm = empty_path + end if + if(present(stat)) then + lstat => stat + else + lstat => null() + end if - subroutine calculate_diagnostic_variable_scalar_multiple_indexed(states, state_index, s_field, algorithm, stat) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, target, intent(out) :: stat + call calculate_diagnostic_variable_ext(states, size(states), state_index, v_field, lalgorithm, len_trim(lalgorithm), lstat) - character(len = OPTION_PATH_LEN) :: lalgorithm - integer, pointer :: lstat + end subroutine calculate_diagnostic_variable_vector_multiple_indexed - if(present(algorithm)) then - lalgorithm = algorithm - else - lalgorithm = empty_path - end if - if(present(stat)) then - lstat => stat - else - lstat => null() - end if + subroutine calculate_diagnostic_variable_tensor_single(state, t_field, algorithm, stat) + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, intent(out) :: stat - call calculate_diagnostic_variable_ext(states, size(states), state_index, s_field, lalgorithm, len_trim(lalgorithm), lstat) + type(state_type), dimension(1) :: states - end subroutine calculate_diagnostic_variable_scalar_multiple_indexed + states = (/state/) + call calculate_diagnostic_variable(states, 1, t_field, algorithm = algorithm, stat = stat) + state = states(1) - subroutine calculate_diagnostic_variable_vector_single(state, v_field, algorithm, stat) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, intent(out) :: stat + end subroutine calculate_diagnostic_variable_tensor_single - type(state_type), dimension(1) :: states + subroutine calculate_diagnostic_variable_tensor_multiple_non_indexed(states, t_field, algorithm, stat) + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), intent(inout) :: t_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, intent(out) :: stat + + call calculate_diagnostic_variable(states, 1, t_field, algorithm = algorithm, stat = stat) - states = (/state/) - call calculate_diagnostic_variable(states, 1, v_field, algorithm = algorithm, stat = stat) - state = states(1) + end subroutine calculate_diagnostic_variable_tensor_multiple_non_indexed + + subroutine calculate_diagnostic_variable_tensor_multiple_indexed(states, state_index, t_field, algorithm, stat) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + character(len = *), optional, intent(in) :: algorithm + integer, optional, target, intent(out) :: stat + + character(len = OPTION_PATH_LEN) :: lalgorithm + integer, pointer :: lstat + + if(present(algorithm)) then + lalgorithm = algorithm + else + lalgorithm = empty_path + end if + if(present(stat)) then + lstat => stat + else + lstat => null() + end if + + call calculate_diagnostic_variable_ext(states, size(states), state_index, t_field, lalgorithm, len_trim(lalgorithm), lstat) + + end subroutine calculate_diagnostic_variable_tensor_multiple_indexed + + subroutine calculate_diagnostic_variable_dep_scalar_single(state, s_field, algorithm, dep_states_mask, stat) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: s_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), optional :: dep_states_mask + integer, optional, intent(out) :: stat + + type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: dep_states_masks + + states = (/state/) + if (present(dep_states_mask)) then + dep_states_masks = (/dep_states_mask/) + call calculate_diagnostic_variable_dep(states, 1, s_field, algorithm = algorithm, dep_states_mask=dep_states_masks, stat = stat) + dep_states_mask = dep_states_masks(1) + else + call calculate_diagnostic_variable_dep(states, 1, s_field, algorithm = algorithm, stat = stat) + end if + state = states(1) + + end subroutine calculate_diagnostic_variable_dep_scalar_single + + subroutine calculate_diagnostic_variable_dep_scalar_multiple_non_indexed(states, s_field, algorithm, dep_states_mask, stat) + type(state_type), dimension(:), intent(inout) :: states + type(scalar_field), intent(inout) :: s_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), dimension(size(states)), optional :: dep_states_mask + integer, optional, intent(out) :: stat - end subroutine calculate_diagnostic_variable_vector_single - - subroutine calculate_diagnostic_variable_vector_multiple_non_indexed(states, v_field, algorithm, stat) - type(state_type), dimension(:), intent(inout) :: states - type(vector_field), intent(inout) :: v_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, intent(out) :: stat + call calculate_diagnostic_variable_dep(states, 1, s_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = stat) - call calculate_diagnostic_variable(states, 1, v_field, algorithm = algorithm, stat = stat) - - end subroutine calculate_diagnostic_variable_vector_multiple_non_indexed - - subroutine calculate_diagnostic_variable_vector_multiple_indexed(states, state_index, v_field, algorithm, stat) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, target, intent(out) :: stat + end subroutine calculate_diagnostic_variable_dep_scalar_multiple_non_indexed - character(len = OPTION_PATH_LEN) :: lalgorithm - integer, pointer :: lstat - - if(present(algorithm)) then - lalgorithm = algorithm - else - lalgorithm = empty_path - end if - if(present(stat)) then - lstat => stat - else - lstat => null() - end if - - call calculate_diagnostic_variable_ext(states, size(states), state_index, v_field, lalgorithm, len_trim(lalgorithm), lstat) - - end subroutine calculate_diagnostic_variable_vector_multiple_indexed - - subroutine calculate_diagnostic_variable_tensor_single(state, t_field, algorithm, stat) - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, intent(out) :: stat - - type(state_type), dimension(1) :: states - - states = (/state/) - call calculate_diagnostic_variable(states, 1, t_field, algorithm = algorithm, stat = stat) - state = states(1) - - end subroutine calculate_diagnostic_variable_tensor_single - - subroutine calculate_diagnostic_variable_tensor_multiple_non_indexed(states, t_field, algorithm, stat) - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), intent(inout) :: t_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, intent(out) :: stat - - call calculate_diagnostic_variable(states, 1, t_field, algorithm = algorithm, stat = stat) - - end subroutine calculate_diagnostic_variable_tensor_multiple_non_indexed - - subroutine calculate_diagnostic_variable_tensor_multiple_indexed(states, state_index, t_field, algorithm, stat) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - character(len = *), optional, intent(in) :: algorithm - integer, optional, target, intent(out) :: stat - - character(len = OPTION_PATH_LEN) :: lalgorithm - integer, pointer :: lstat - - if(present(algorithm)) then - lalgorithm = algorithm - else - lalgorithm = empty_path - end if - if(present(stat)) then - lstat => stat - else - lstat => null() - end if - - call calculate_diagnostic_variable_ext(states, size(states), state_index, t_field, lalgorithm, len_trim(lalgorithm), lstat) - - end subroutine calculate_diagnostic_variable_tensor_multiple_indexed - - subroutine calculate_diagnostic_variable_dep_scalar_single(state, s_field, algorithm, dep_states_mask, stat) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: s_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), optional :: dep_states_mask - integer, optional, intent(out) :: stat - - type(state_type), dimension(1) :: states - type(state_type), dimension(1) :: dep_states_masks - - states = (/state/) - if (present(dep_states_mask)) then - dep_states_masks = (/dep_states_mask/) - call calculate_diagnostic_variable_dep(states, 1, s_field, algorithm = algorithm, dep_states_mask=dep_states_masks, stat = stat) - dep_states_mask = dep_states_masks(1) - else - call calculate_diagnostic_variable_dep(states, 1, s_field, algorithm = algorithm, stat = stat) - end if - state = states(1) - - end subroutine calculate_diagnostic_variable_dep_scalar_single - - subroutine calculate_diagnostic_variable_dep_scalar_multiple_non_indexed(states, s_field, algorithm, dep_states_mask, stat) - type(state_type), dimension(:), intent(inout) :: states - type(scalar_field), intent(inout) :: s_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), dimension(size(states)), optional :: dep_states_mask - integer, optional, intent(out) :: stat - - call calculate_diagnostic_variable_dep(states, 1, s_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = stat) - - end subroutine calculate_diagnostic_variable_dep_scalar_multiple_non_indexed - - subroutine calculate_diagnostic_variable_dep_scalar_multiple_indexed(states, state_index, s_field, algorithm, dep_states_mask, stat) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(scalar_field), intent(inout) :: s_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), dimension(size(states)), optional, target :: dep_states_mask - integer, optional, target, intent(out) :: stat - - character(len = OPTION_PATH_LEN) :: lalgorithm - type(state_type), dimension(:), pointer :: ldep_states_mask - integer, pointer :: lstat - - if(present(algorithm)) then - lalgorithm = algorithm - else - lalgorithm = empty_path - end if - if(present(stat)) then - lstat => stat - else - lstat => null() - end if - if(present(dep_states_mask)) then - ldep_states_mask => dep_states_mask - else - ldep_states_mask => null() - end if - - call calculate_diagnostic_variable_dep_ext(states, size(states), state_index, s_field, lalgorithm, len_trim(lalgorithm), ldep_states_mask, lstat) - - end subroutine calculate_diagnostic_variable_dep_scalar_multiple_indexed - - subroutine calculate_diagnostic_variable_dep_vector_single(state, v_field, algorithm, dep_states_mask, stat) - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: v_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), optional :: dep_states_mask - integer, optional, intent(out) :: stat - - type(state_type), dimension(1) :: states - type(state_type), dimension(1) :: dep_states_masks - - states = (/state/) - if (present(dep_states_mask)) then - dep_states_masks = (/dep_states_mask/) - call calculate_diagnostic_variable_dep(states, 1, v_field, algorithm = algorithm, dep_states_mask=dep_states_masks, stat = stat) - dep_states_mask = dep_states_masks(1) - else - call calculate_diagnostic_variable_dep(states, 1, v_field, algorithm = algorithm, stat = stat) - end if - state = states(1) - - end subroutine calculate_diagnostic_variable_dep_vector_single - - subroutine calculate_diagnostic_variable_dep_vector_multiple_non_indexed(states, v_field, algorithm, dep_states_mask, stat) - type(state_type), dimension(:), intent(inout) :: states - type(vector_field), intent(inout) :: v_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), dimension(size(states)), optional :: dep_states_mask - integer, optional, intent(out) :: stat - - call calculate_diagnostic_variable_dep(states, 1, v_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = stat) - - end subroutine calculate_diagnostic_variable_dep_vector_multiple_non_indexed - - subroutine calculate_diagnostic_variable_dep_vector_multiple_indexed(states, state_index, v_field, algorithm, dep_states_mask, stat) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(vector_field), intent(inout) :: v_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), dimension(size(states)), optional, target :: dep_states_mask - integer, optional, target, intent(out) :: stat - - type(state_type), dimension(:), pointer :: ldep_states_mask - character(len = OPTION_PATH_LEN) :: lalgorithm - integer, pointer :: lstat - - if(present(algorithm)) then - lalgorithm = algorithm - else - lalgorithm = empty_path - end if - if(present(stat)) then - lstat => stat - else - lstat => null() - end if - if(present(dep_states_mask)) then - ldep_states_mask => dep_states_mask - else - ldep_states_mask => null() - end if - - call calculate_diagnostic_variable_dep_ext(states, size(states), state_index, v_field, lalgorithm, len_trim(lalgorithm), ldep_states_mask, lstat) - - end subroutine calculate_diagnostic_variable_dep_vector_multiple_indexed - - subroutine calculate_diagnostic_variable_dep_tensor_single(state, t_field, algorithm, dep_states_mask, stat) - type(state_type), intent(inout) :: state - type(tensor_field), intent(inout) :: t_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), optional :: dep_states_mask - integer, optional, intent(out) :: stat - - type(state_type), dimension(1) :: states - type(state_type), dimension(1) :: dep_states_masks - - states = (/state/) - if (present(dep_states_mask)) then - dep_states_masks = (/dep_states_mask/) - call calculate_diagnostic_variable_dep(states, 1, t_field, algorithm = algorithm, dep_states_mask=dep_states_masks, stat = stat) - dep_states_mask = dep_states_masks(1) - else - call calculate_diagnostic_variable_dep(states, 1, t_field, algorithm = algorithm, stat = stat) - end if - state = states(1) - - end subroutine calculate_diagnostic_variable_dep_tensor_single - - subroutine calculate_diagnostic_variable_dep_tensor_multiple_non_indexed(states, t_field, algorithm, dep_states_mask,stat) - type(state_type), dimension(:), intent(inout) :: states - type(tensor_field), intent(inout) :: t_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), dimension(size(states)), optional :: dep_states_mask - integer, optional, intent(out) :: stat - - call calculate_diagnostic_variable_dep(states, 1, t_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = stat) - - end subroutine calculate_diagnostic_variable_dep_tensor_multiple_non_indexed - - subroutine calculate_diagnostic_variable_dep_tensor_multiple_indexed(states, state_index, t_field, algorithm, dep_states_mask, stat) - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: state_index - type(tensor_field), intent(inout) :: t_field - character(len = *), optional, intent(in) :: algorithm - type(state_type), dimension(size(states)), optional, target :: dep_states_mask - integer, optional, target, intent(out) :: stat - - type(state_type), dimension(:), pointer :: ldep_states_mask - character(len = OPTION_PATH_LEN) :: lalgorithm - integer, pointer :: lstat - - if(present(algorithm)) then - lalgorithm = algorithm - else - lalgorithm = empty_path - end if - if(present(stat)) then - lstat => stat - else - lstat => null() - end if - if(present(dep_states_mask)) then - ldep_states_mask => dep_states_mask - else - ldep_states_mask => null() - end if - - call calculate_diagnostic_variable_dep_ext(states, size(states), state_index, t_field, lalgorithm, len_trim(lalgorithm), ldep_states_mask, lstat) - - end subroutine calculate_diagnostic_variable_dep_tensor_multiple_indexed + subroutine calculate_diagnostic_variable_dep_scalar_multiple_indexed(states, state_index, s_field, algorithm, dep_states_mask, stat) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(scalar_field), intent(inout) :: s_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), dimension(size(states)), optional, target :: dep_states_mask + integer, optional, target, intent(out) :: stat + + character(len = OPTION_PATH_LEN) :: lalgorithm + type(state_type), dimension(:), pointer :: ldep_states_mask + integer, pointer :: lstat + + if(present(algorithm)) then + lalgorithm = algorithm + else + lalgorithm = empty_path + end if + if(present(stat)) then + lstat => stat + else + lstat => null() + end if + if(present(dep_states_mask)) then + ldep_states_mask => dep_states_mask + else + ldep_states_mask => null() + end if + + call calculate_diagnostic_variable_dep_ext(states, size(states), state_index, s_field, lalgorithm, len_trim(lalgorithm), ldep_states_mask, lstat) + + end subroutine calculate_diagnostic_variable_dep_scalar_multiple_indexed + + subroutine calculate_diagnostic_variable_dep_vector_single(state, v_field, algorithm, dep_states_mask, stat) + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: v_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), optional :: dep_states_mask + integer, optional, intent(out) :: stat + + type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: dep_states_masks + + states = (/state/) + if (present(dep_states_mask)) then + dep_states_masks = (/dep_states_mask/) + call calculate_diagnostic_variable_dep(states, 1, v_field, algorithm = algorithm, dep_states_mask=dep_states_masks, stat = stat) + dep_states_mask = dep_states_masks(1) + else + call calculate_diagnostic_variable_dep(states, 1, v_field, algorithm = algorithm, stat = stat) + end if + state = states(1) + + end subroutine calculate_diagnostic_variable_dep_vector_single + + subroutine calculate_diagnostic_variable_dep_vector_multiple_non_indexed(states, v_field, algorithm, dep_states_mask, stat) + type(state_type), dimension(:), intent(inout) :: states + type(vector_field), intent(inout) :: v_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), dimension(size(states)), optional :: dep_states_mask + integer, optional, intent(out) :: stat + + call calculate_diagnostic_variable_dep(states, 1, v_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = stat) + + end subroutine calculate_diagnostic_variable_dep_vector_multiple_non_indexed + + subroutine calculate_diagnostic_variable_dep_vector_multiple_indexed(states, state_index, v_field, algorithm, dep_states_mask, stat) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(vector_field), intent(inout) :: v_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), dimension(size(states)), optional, target :: dep_states_mask + integer, optional, target, intent(out) :: stat + + type(state_type), dimension(:), pointer :: ldep_states_mask + character(len = OPTION_PATH_LEN) :: lalgorithm + integer, pointer :: lstat + + if(present(algorithm)) then + lalgorithm = algorithm + else + lalgorithm = empty_path + end if + if(present(stat)) then + lstat => stat + else + lstat => null() + end if + if(present(dep_states_mask)) then + ldep_states_mask => dep_states_mask + else + ldep_states_mask => null() + end if + + call calculate_diagnostic_variable_dep_ext(states, size(states), state_index, v_field, lalgorithm, len_trim(lalgorithm), ldep_states_mask, lstat) + + end subroutine calculate_diagnostic_variable_dep_vector_multiple_indexed + + subroutine calculate_diagnostic_variable_dep_tensor_single(state, t_field, algorithm, dep_states_mask, stat) + type(state_type), intent(inout) :: state + type(tensor_field), intent(inout) :: t_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), optional :: dep_states_mask + integer, optional, intent(out) :: stat + + type(state_type), dimension(1) :: states + type(state_type), dimension(1) :: dep_states_masks + + states = (/state/) + if (present(dep_states_mask)) then + dep_states_masks = (/dep_states_mask/) + call calculate_diagnostic_variable_dep(states, 1, t_field, algorithm = algorithm, dep_states_mask=dep_states_masks, stat = stat) + dep_states_mask = dep_states_masks(1) + else + call calculate_diagnostic_variable_dep(states, 1, t_field, algorithm = algorithm, stat = stat) + end if + state = states(1) + + end subroutine calculate_diagnostic_variable_dep_tensor_single + + subroutine calculate_diagnostic_variable_dep_tensor_multiple_non_indexed(states, t_field, algorithm, dep_states_mask,stat) + type(state_type), dimension(:), intent(inout) :: states + type(tensor_field), intent(inout) :: t_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), dimension(size(states)), optional :: dep_states_mask + integer, optional, intent(out) :: stat + + call calculate_diagnostic_variable_dep(states, 1, t_field, algorithm = algorithm, dep_states_mask=dep_states_mask, stat = stat) + + end subroutine calculate_diagnostic_variable_dep_tensor_multiple_non_indexed + + subroutine calculate_diagnostic_variable_dep_tensor_multiple_indexed(states, state_index, t_field, algorithm, dep_states_mask, stat) + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: state_index + type(tensor_field), intent(inout) :: t_field + character(len = *), optional, intent(in) :: algorithm + type(state_type), dimension(size(states)), optional, target :: dep_states_mask + integer, optional, target, intent(out) :: stat + + type(state_type), dimension(:), pointer :: ldep_states_mask + character(len = OPTION_PATH_LEN) :: lalgorithm + integer, pointer :: lstat + + if(present(algorithm)) then + lalgorithm = algorithm + else + lalgorithm = empty_path + end if + if(present(stat)) then + lstat => stat + else + lstat => null() + end if + if(present(dep_states_mask)) then + ldep_states_mask => dep_states_mask + else + ldep_states_mask => null() + end if + + call calculate_diagnostic_variable_dep_ext(states, size(states), state_index, t_field, lalgorithm, len_trim(lalgorithm), ldep_states_mask, lstat) + + end subroutine calculate_diagnostic_variable_dep_tensor_multiple_indexed end module diagnostic_fields_wrapper_new diff --git a/horizontal_adaptivity/Advancing_front.F90 b/horizontal_adaptivity/Advancing_front.F90 index ff9151b741..7f4a9d11d9 100644 --- a/horizontal_adaptivity/Advancing_front.F90 +++ b/horizontal_adaptivity/Advancing_front.F90 @@ -2,651 +2,651 @@ module hadapt_advancing_front - use fldebug - use global_parameters, only: OPTION_PATH_LEN - use futils - use quicksort - use data_structures - use spud - use parallel_tools - use sparse_tools - use linked_lists - use adjacency_lists - use parallel_fields - use fields - use meshdiagnostics - use halos_derivation - use halos - - implicit none - - private - - public :: generate_layered_mesh, create_columns_sparsity - - contains - - subroutine generate_layered_mesh(mesh, h_mesh, layer_nodes) - !! Given a columnar mesh with the positions of the vertical - !! nodes, fill in the elements. - type(vector_field), intent(inout) :: mesh - type(vector_field), intent(inout) :: h_mesh - !! Indicates first owned and recv node in each layer - owned nodes and recv nodes - !! are (seperately) numbered consecutively within each layer - these arrays have an extra entry for convenience - type(integer_set), dimension(:), intent(in) :: layer_nodes - - type(csr_sparsity), pointer :: nelist - type(scalar_field) :: height_field - type(mesh_type) :: in_mesh - type(integer_hash_table):: old2new_ele - character(len=OPTION_PATH_LEN) :: region_option_path, layer_path - - ! the maximum amount of faces you could possibly want to add is - ! number of elements in the extruded mesh (ele_count(mesh)) - ! x number of faces per element (in the absence of face_count, use ele_loc) - integer, dimension(:), allocatable :: element_owners, boundary_ids - integer, dimension(:), target, allocatable :: sndgln - integer, dimension(:), allocatable :: bottom_surface_ids, top_surface_ids, extruded_region_ids - integer, dimension(:), allocatable :: sorted, unn, integer_heights - real, dimension(:), allocatable :: heights - integer, dimension(:), allocatable :: hanging_node, column_size, column_count - integer, dimension(mesh_dim(mesh) - 1) :: other_column_heads - - integer, dimension(:), allocatable :: region_ids - integer, dimension(:), allocatable:: halo_level - integer, dimension(:), pointer :: ndglno_ptr, h_elements, h_ndglno - integer, dimension(:), pointer :: facet_nodes, faces, neigh - - logical:: adjacent_to_owned_element, adjacent_to_owned_column, shared_face - logical :: top_element, bottom_element - logical :: multiple_regions - integer, dimension(:), allocatable :: old_element_data - - integer, dimension(2) :: shape_option - integer, dimension(1) :: other_node - integer :: top_surface_id, bottom_surface_id, extruded_region_id, extruded_region_id_stat - integer :: faces_seen - integer :: h_node, node, column, dim - integer :: n_regions, r, layer - integer :: ele, h_ele, snloc - integer :: i, j, k, l - - logical :: radial_layering - - real :: vol - - ! allocate our arrays - allocate(element_owners(ele_count(mesh) * ele_loc(mesh, 1))) - allocate(boundary_ids(ele_count(mesh) * ele_loc(mesh, 1))) - allocate(sndgln(ele_count(mesh) * ele_loc(mesh, 1) * mesh_dim(mesh))) - - allocate(bottom_surface_ids(ele_count(h_mesh))) - allocate(top_surface_ids(ele_count(h_mesh))) - allocate(extruded_region_ids(ele_count(h_mesh))) - - allocate(hanging_node(node_count(h_mesh))) - allocate(column_size(node_count(h_mesh))) - allocate(column_count(node_count(h_mesh))) - - dim = mesh_dim(mesh) - - nelist => extract_nelist(h_mesh) - - radial_layering = have_option('/geometry/spherical_earth') - ! Sort the new nodes by height - if (radial_layering) then - ! sort on radius - height_field = magnitude(mesh) - else - ! sort on last coordinate - height_field = extract_scalar_field(mesh, mesh%dim) - end if - - if (associated(h_mesh%mesh%halos)) then - assert(has_faces(h_mesh%mesh)) ! needed for halo1 element recognition - allocate(halo_level(1:element_count(mesh))) - allocate(unn(1:node_count(mesh)), integer_heights(1:node_count(mesh))) - call get_universal_numbering(mesh%mesh%halos(2), unn) - call create_integer_heights(height_field, mesh%mesh%halos(2), integer_heights) - end if - - assert(associated(mesh%mesh%columns)) - assert(associated(mesh%mesh%element_columns)) - - mesh%mesh%region_ids = 0 - - faces_seen = 0 - if (has_faces(h_mesh%mesh)) then - snloc = dim - assert( snloc==face_loc(h_mesh,1)+1 ) - end if - - ele = 0 - - n_regions = option_count(trim(mesh%mesh%option_path)//'/from_mesh/extrude/regions') - if (n_regions>0) then - ! regions directly under extrude/: single layer layer only which is specified directly under regions/ - layer_path = trim(mesh%mesh%option_path)//'/from_mesh/extrude' - assert(size(layer_nodes)==1) - else - layer_path = trim(mesh%mesh%option_path)//'/from_mesh/extrude/layer[0]' - end if - - ! The main loop. - layers: do layer = 1, size(layer_nodes) - ! order nodes within layer - allocate(sorted(key_count(layer_nodes(layer)))) - if (associated(h_mesh%mesh%halos)) then - call parallel_consistent_ordering(integer_heights, unn, sorted, layer_nodes(layer)) + use fldebug + use global_parameters, only: OPTION_PATH_LEN + use futils + use quicksort + use data_structures + use spud + use parallel_tools + use sparse_tools + use linked_lists + use adjacency_lists + use parallel_fields + use fields + use meshdiagnostics + use halos_derivation + use halos + + implicit none + + private + + public :: generate_layered_mesh, create_columns_sparsity + +contains + + subroutine generate_layered_mesh(mesh, h_mesh, layer_nodes) + !! Given a columnar mesh with the positions of the vertical + !! nodes, fill in the elements. + type(vector_field), intent(inout) :: mesh + type(vector_field), intent(inout) :: h_mesh + !! Indicates first owned and recv node in each layer - owned nodes and recv nodes + !! are (seperately) numbered consecutively within each layer - these arrays have an extra entry for convenience + type(integer_set), dimension(:), intent(in) :: layer_nodes + + type(csr_sparsity), pointer :: nelist + type(scalar_field) :: height_field + type(mesh_type) :: in_mesh + type(integer_hash_table):: old2new_ele + character(len=OPTION_PATH_LEN) :: region_option_path, layer_path + + ! the maximum amount of faces you could possibly want to add is + ! number of elements in the extruded mesh (ele_count(mesh)) + ! x number of faces per element (in the absence of face_count, use ele_loc) + integer, dimension(:), allocatable :: element_owners, boundary_ids + integer, dimension(:), target, allocatable :: sndgln + integer, dimension(:), allocatable :: bottom_surface_ids, top_surface_ids, extruded_region_ids + integer, dimension(:), allocatable :: sorted, unn, integer_heights + real, dimension(:), allocatable :: heights + integer, dimension(:), allocatable :: hanging_node, column_size, column_count + integer, dimension(mesh_dim(mesh) - 1) :: other_column_heads + + integer, dimension(:), allocatable :: region_ids + integer, dimension(:), allocatable:: halo_level + integer, dimension(:), pointer :: ndglno_ptr, h_elements, h_ndglno + integer, dimension(:), pointer :: facet_nodes, faces, neigh + + logical:: adjacent_to_owned_element, adjacent_to_owned_column, shared_face + logical :: top_element, bottom_element + logical :: multiple_regions + integer, dimension(:), allocatable :: old_element_data + + integer, dimension(2) :: shape_option + integer, dimension(1) :: other_node + integer :: top_surface_id, bottom_surface_id, extruded_region_id, extruded_region_id_stat + integer :: faces_seen + integer :: h_node, node, column, dim + integer :: n_regions, r, layer + integer :: ele, h_ele, snloc + integer :: i, j, k, l + + logical :: radial_layering + + real :: vol + + ! allocate our arrays + allocate(element_owners(ele_count(mesh) * ele_loc(mesh, 1))) + allocate(boundary_ids(ele_count(mesh) * ele_loc(mesh, 1))) + allocate(sndgln(ele_count(mesh) * ele_loc(mesh, 1) * mesh_dim(mesh))) + + allocate(bottom_surface_ids(ele_count(h_mesh))) + allocate(top_surface_ids(ele_count(h_mesh))) + allocate(extruded_region_ids(ele_count(h_mesh))) + + allocate(hanging_node(node_count(h_mesh))) + allocate(column_size(node_count(h_mesh))) + allocate(column_count(node_count(h_mesh))) + + dim = mesh_dim(mesh) + + nelist => extract_nelist(h_mesh) + + radial_layering = have_option('/geometry/spherical_earth') + ! Sort the new nodes by height + if (radial_layering) then + ! sort on radius + height_field = magnitude(mesh) else - allocate(heights(size(sorted))) - heights = -height_field%val(set2vector(layer_nodes(layer))) - call qsort(heights, sorted) - do i=1, size(sorted) - sorted(i) = fetch(layer_nodes(layer), sorted(i)) - end do - deallocate(heights) + ! sort on last coordinate + height_field = extract_scalar_field(mesh, mesh%dim) end if - ! column_count and column_size are used to determine top and bottom elements in each column - ! column_size: for each column, find out how many nodes there are in this layer - column_size = 0 - do i = 1, size(sorted) - node = sorted(i) - column = mesh%mesh%columns(node) - column_size(column) = column_size(column) + 1 - end do - ! column_count: how many we've encountered so far - at the moment that's 1 (the top) node per column - column_count = 1 - - if (layer==1) then - ! for the top layer, find what the starting node is, - hanging_node = 0 - ! we start with the top nodes - l = 0 - do i = 1, size(sorted) - node = sorted(i) - column = mesh%mesh%columns(node) - if (hanging_node(column)==0) then - l = l + 1 - hanging_node(column) = node - end if - if (l==size(hanging_node)) exit - end do - assert(l==size(hanging_node)) - else - ! for layers below we continue with the nodes from the prev. layer - ! that means we've forgotten to count it in column_size - column_size = column_size + 1 + if (associated(h_mesh%mesh%halos)) then + assert(has_faces(h_mesh%mesh)) ! needed for halo1 element recognition + allocate(halo_level(1:element_count(mesh))) + allocate(unn(1:node_count(mesh)), integer_heights(1:node_count(mesh))) + call get_universal_numbering(mesh%mesh%halos(2), unn) + call create_integer_heights(height_field, mesh%mesh%halos(2), integer_heights) end if - ! get the region id information used for extrusion (if any) plus the top and bottom surface ids - n_regions = option_count(trim(layer_path) // '/regions') - multiple_regions = (n_regions>1) + assert(associated(mesh%mesh%columns)) + assert(associated(mesh%mesh%element_columns)) - if (multiple_regions .and. .not. associated(h_mesh%mesh%region_ids)) then - FLAbort("Multiple extrude regions in options tree but no region ids in mesh") - end if + mesh%mesh%region_ids = 0 - if (layer>1) then - ! layers below take over the bottom_surface_id from the layer above as their top_surface_id - top_surface_ids = bottom_surface_ids + faces_seen = 0 + if (has_faces(h_mesh%mesh)) then + snloc = dim + assert( snloc==face_loc(h_mesh,1)+1 ) end if + ele = 0 - do r = 0, n_regions-1 - - region_option_path = trim(layer_path) // "/regions[" // int2str(r) // "]" - if(multiple_regions) then - shape_option=option_shape(trim(region_option_path)// "/region_ids") - allocate(region_ids(1:shape_option(1))) - call get_option(trim(region_option_path) // "/region_ids", region_ids) - end if - - if (layer==1) then - ! only the top layer specifies a top_surface_id - call get_option(trim(region_option_path) // '/top_surface_id', top_surface_id, default=0) - end if - call get_option(trim(region_option_path) // '/bottom_surface_id', bottom_surface_id, default=0) - call get_option(trim(region_option_path) // '/extruded_region_id', extruded_region_id, stat=extruded_region_id_stat) - - do h_ele = 1, size(top_surface_ids) - if(multiple_regions) then - if(.not. any(h_mesh%mesh%region_ids(h_ele)==region_ids)) cycle - end if - - if (layer==1) then - top_surface_ids(h_ele) = top_surface_id - end if - bottom_surface_ids(h_ele) = bottom_surface_id - if (extruded_region_id_stat==0) then - extruded_region_ids(h_ele) = extruded_region_id - else if (associated(h_mesh%mesh%region_ids)) then - extruded_region_ids(h_ele) = h_mesh%mesh%region_ids(h_ele) - end if - end do - - if(multiple_regions) deallocate(region_ids) - - end do + n_regions = option_count(trim(mesh%mesh%option_path)//'/from_mesh/extrude/regions') + if (n_regions>0) then + ! regions directly under extrude/: single layer layer only which is specified directly under regions/ + layer_path = trim(mesh%mesh%option_path)//'/from_mesh/extrude' + assert(size(layer_nodes)==1) + else + layer_path = trim(mesh%mesh%option_path)//'/from_mesh/extrude/layer[0]' + end if - nodes: do i=1, size(sorted) - - node = sorted(i) - - ! Get the column we're dealing with - column = mesh%mesh%columns(node) - - if (hanging_node(column)==node) then - if (column_count(column)==1) then - ! this is simply the top node, we only start adding elements - ! when we have at least 2 nodes in this column - cycle - else - ! this node has already been added to the column, something - ! must have gone wrong horribly - FLAbort("Internal error in mesh extrustion, generate_layered_mesh") - end if - end if - - ! So we're going to form an element. - ! It's going to have nodes - ! [node, hanging_node(column), [others]] - ! where others are the hanging_nodes of the neighbouring columns - - h_elements => row_m_ptr(nelist, column) - do j=1,size(h_elements) - h_ele = h_elements(j) - ! Get the columns in sele that are NOT the current column. - h_ndglno => ele_nodes(h_mesh, h_ele) - l = 0 - ! we're adding a top element if all associated columns are still at top - top_element = all(column_count(h_ndglno)==1) - ! we're adding a bottom element if this column is one-but-last - ! and the other columns are at the last node (checked in the loop below) - bottom_element = column_count(column)==column_size(column)-1 - do k=1,size(h_ndglno) - h_node = h_ndglno(k) - if (h_node /= column) then - ! add other column - l = l +1 - other_column_heads(l) = hanging_node(h_node) - ! as promised check that other columns are at the last node - bottom_element = bottom_element .and. column_count(h_node)==column_size(h_node) + ! The main loop. + layers: do layer = 1, size(layer_nodes) + ! order nodes within layer + allocate(sorted(key_count(layer_nodes(layer)))) + if (associated(h_mesh%mesh%halos)) then + call parallel_consistent_ordering(integer_heights, unn, sorted, layer_nodes(layer)) + else + allocate(heights(size(sorted))) + heights = -height_field%val(set2vector(layer_nodes(layer))) + call qsort(heights, sorted) + do i=1, size(sorted) + sorted(i) = fetch(layer_nodes(layer), sorted(i)) + end do + deallocate(heights) + end if + + ! column_count and column_size are used to determine top and bottom elements in each column + ! column_size: for each column, find out how many nodes there are in this layer + column_size = 0 + do i = 1, size(sorted) + node = sorted(i) + column = mesh%mesh%columns(node) + column_size(column) = column_size(column) + 1 + end do + ! column_count: how many we've encountered so far - at the moment that's 1 (the top) node per column + column_count = 1 + + if (layer==1) then + ! for the top layer, find what the starting node is, + hanging_node = 0 + ! we start with the top nodes + l = 0 + do i = 1, size(sorted) + node = sorted(i) + column = mesh%mesh%columns(node) + if (hanging_node(column)==0) then + l = l + 1 + hanging_node(column) = node + end if + if (l==size(hanging_node)) exit + end do + assert(l==size(hanging_node)) + else + ! for layers below we continue with the nodes from the prev. layer + ! that means we've forgotten to count it in column_size + column_size = column_size + 1 + end if + + ! get the region id information used for extrusion (if any) plus the top and bottom surface ids + n_regions = option_count(trim(layer_path) // '/regions') + multiple_regions = (n_regions>1) + + if (multiple_regions .and. .not. associated(h_mesh%mesh%region_ids)) then + FLAbort("Multiple extrude regions in options tree but no region ids in mesh") + end if + + if (layer>1) then + ! layers below take over the bottom_surface_id from the layer above as their top_surface_id + top_surface_ids = bottom_surface_ids + end if + + + do r = 0, n_regions-1 + + region_option_path = trim(layer_path) // "/regions[" // int2str(r) // "]" + if(multiple_regions) then + shape_option=option_shape(trim(region_option_path)// "/region_ids") + allocate(region_ids(1:shape_option(1))) + call get_option(trim(region_option_path) // "/region_ids", region_ids) end if - end do - - ! So now we know the heads of the columns next to us. - ! Let's form the element! Quick! quick! - ele = ele + 1 - ndglno_ptr => ele_nodes(mesh, ele) - - ndglno_ptr(1) = hanging_node(column) - ndglno_ptr(2) = node - ndglno_ptr(3:dim+1) = other_column_heads - - ! Now we have to orient the element. - - vol = simplex_volume(mesh, ele) - assert(abs(vol) /= 0.0) - if (vol < 0.0) then - l = ndglno_ptr(1) - ndglno_ptr(1) = ndglno_ptr(2) - ndglno_ptr(2) = l - end if - - mesh%mesh%region_ids(ele) = extruded_region_ids(h_ele) - - ! we now know the relationship between the mesh element and the h_mesh surface element - ! save this for later... - mesh%mesh%element_columns(ele) = h_ele - - ! if the horizontal element has any surface faces, add them to the extruded surface mesh - if (has_faces(h_mesh%mesh)) then - ! first the top and bottom faces - if (top_element) then - faces_seen = faces_seen + 1 - element_owners(faces_seen) = ele - boundary_ids(faces_seen) = top_surface_ids(h_ele) - facet_nodes => sndgln((faces_seen-1)*snloc+1:faces_seen*snloc) - facet_nodes(1) = hanging_node(column) - facet_nodes(2:dim) = other_column_heads + + if (layer==1) then + ! only the top layer specifies a top_surface_id + call get_option(trim(region_option_path) // '/top_surface_id', top_surface_id, default=0) end if - if (bottom_element) then - faces_seen = faces_seen + 1 - element_owners(faces_seen) = ele - boundary_ids(faces_seen) = bottom_surface_ids(h_ele) - facet_nodes => sndgln((faces_seen-1)*snloc+1:faces_seen*snloc) - facet_nodes(1) = node - facet_nodes(2:dim) = other_column_heads + call get_option(trim(region_option_path) // '/bottom_surface_id', bottom_surface_id, default=0) + call get_option(trim(region_option_path) // '/extruded_region_id', extruded_region_id, stat=extruded_region_id_stat) + + do h_ele = 1, size(top_surface_ids) + if(multiple_regions) then + if(.not. any(h_mesh%mesh%region_ids(h_ele)==region_ids)) cycle + end if + + if (layer==1) then + top_surface_ids(h_ele) = top_surface_id + end if + bottom_surface_ids(h_ele) = bottom_surface_id + if (extruded_region_id_stat==0) then + extruded_region_ids(h_ele) = extruded_region_id + else if (associated(h_mesh%mesh%region_ids)) then + extruded_region_ids(h_ele) = h_mesh%mesh%region_ids(h_ele) + end if + end do + + if(multiple_regions) deallocate(region_ids) + + end do + + nodes: do i=1, size(sorted) + + node = sorted(i) + + ! Get the column we're dealing with + column = mesh%mesh%columns(node) + + if (hanging_node(column)==node) then + if (column_count(column)==1) then + ! this is simply the top node, we only start adding elements + ! when we have at least 2 nodes in this column + cycle + else + ! this node has already been added to the column, something + ! must have gone wrong horribly + FLAbort("Internal error in mesh extrustion, generate_layered_mesh") + end if end if - faces => ele_faces(h_mesh, h_ele) - neigh => ele_neigh(h_mesh, h_ele) - adjacent_to_owned_element=.false. - adjacent_to_owned_column=.false. - do k=1, size(faces) - ! whether this horizontal face is above a face of our new element - shared_face = any(column == face_global_nodes(h_mesh, faces(k))) - if (shared_face .and. faces(k)<=surface_element_count(h_mesh)) then - faces_seen = faces_seen + 1 - element_owners(faces_seen) = ele - boundary_ids(faces_seen) = surface_element_id(h_mesh, faces(k)) - facet_nodes => sndgln((faces_seen-1)*snloc+1:faces_seen*snloc) - facet_nodes(1) = hanging_node(column) - facet_nodes(2) = node - - if (dim == 3) then - other_node = pack(face_global_nodes(h_mesh, faces(k)), mask=face_global_nodes(h_mesh, faces(k)) /= column) - facet_nodes(3) = hanging_node(other_node(1)) - end if - end if - ! grab the opportunity to see whether this is a halo1 or halo2 element - if (neigh(k)>0) then - if (element_owned(h_mesh%mesh, neigh(k))) then - adjacent_to_owned_column = .true. - if (shared_face) then - adjacent_to_owned_element = .true. + ! So we're going to form an element. + ! It's going to have nodes + ! [node, hanging_node(column), [others]] + ! where others are the hanging_nodes of the neighbouring columns + + h_elements => row_m_ptr(nelist, column) + do j=1,size(h_elements) + h_ele = h_elements(j) + ! Get the columns in sele that are NOT the current column. + h_ndglno => ele_nodes(h_mesh, h_ele) + l = 0 + ! we're adding a top element if all associated columns are still at top + top_element = all(column_count(h_ndglno)==1) + ! we're adding a bottom element if this column is one-but-last + ! and the other columns are at the last node (checked in the loop below) + bottom_element = column_count(column)==column_size(column)-1 + do k=1,size(h_ndglno) + h_node = h_ndglno(k) + if (h_node /= column) then + ! add other column + l = l +1 + other_column_heads(l) = hanging_node(h_node) + ! as promised check that other columns are at the last node + bottom_element = bottom_element .and. column_count(h_node)==column_size(h_node) + end if + end do + + ! So now we know the heads of the columns next to us. + ! Let's form the element! Quick! quick! + ele = ele + 1 + ndglno_ptr => ele_nodes(mesh, ele) + + ndglno_ptr(1) = hanging_node(column) + ndglno_ptr(2) = node + ndglno_ptr(3:dim+1) = other_column_heads + + ! Now we have to orient the element. + + vol = simplex_volume(mesh, ele) + assert(abs(vol) /= 0.0) + if (vol < 0.0) then + l = ndglno_ptr(1) + ndglno_ptr(1) = ndglno_ptr(2) + ndglno_ptr(2) = l + end if + + mesh%mesh%region_ids(ele) = extruded_region_ids(h_ele) + + ! we now know the relationship between the mesh element and the h_mesh surface element + ! save this for later... + mesh%mesh%element_columns(ele) = h_ele + + ! if the horizontal element has any surface faces, add them to the extruded surface mesh + if (has_faces(h_mesh%mesh)) then + ! first the top and bottom faces + if (top_element) then + faces_seen = faces_seen + 1 + element_owners(faces_seen) = ele + boundary_ids(faces_seen) = top_surface_ids(h_ele) + facet_nodes => sndgln((faces_seen-1)*snloc+1:faces_seen*snloc) + facet_nodes(1) = hanging_node(column) + facet_nodes(2:dim) = other_column_heads end if - end if - end if + if (bottom_element) then + faces_seen = faces_seen + 1 + element_owners(faces_seen) = ele + boundary_ids(faces_seen) = bottom_surface_ids(h_ele) + facet_nodes => sndgln((faces_seen-1)*snloc+1:faces_seen*snloc) + facet_nodes(1) = node + facet_nodes(2:dim) = other_column_heads + end if + + faces => ele_faces(h_mesh, h_ele) + neigh => ele_neigh(h_mesh, h_ele) + adjacent_to_owned_element=.false. + adjacent_to_owned_column=.false. + do k=1, size(faces) + ! whether this horizontal face is above a face of our new element + shared_face = any(column == face_global_nodes(h_mesh, faces(k))) + if (shared_face .and. faces(k)<=surface_element_count(h_mesh)) then + faces_seen = faces_seen + 1 + element_owners(faces_seen) = ele + boundary_ids(faces_seen) = surface_element_id(h_mesh, faces(k)) + facet_nodes => sndgln((faces_seen-1)*snloc+1:faces_seen*snloc) + facet_nodes(1) = hanging_node(column) + facet_nodes(2) = node + + if (dim == 3) then + other_node = pack(face_global_nodes(h_mesh, faces(k)), mask=face_global_nodes(h_mesh, faces(k)) /= column) + facet_nodes(3) = hanging_node(other_node(1)) + end if + end if + ! grab the opportunity to see whether this is a halo1 or halo2 element + if (neigh(k)>0) then + if (element_owned(h_mesh%mesh, neigh(k))) then + adjacent_to_owned_column = .true. + if (shared_face) then + adjacent_to_owned_element = .true. + end if + end if + end if + end do + end if + + if (associated(h_mesh%mesh%halos)) then + if(element_owned(h_mesh%mesh, h_ele)) then + ! element ownership (based on the process with lowest rank + ! owning any node in the element), nicely transfers to the columns + halo_level(ele)=0 + else if (adjacent_to_owned_element) then + ! this is not true for halo1 - only those that directly face owned elements + halo_level(ele)=1 + else if (adjacent_to_owned_column) then + ! extruded halo2 elements are necessarily in a column under + ! a halo1 element + halo_level(ele)=2 + else + ! misc elements - not owned, not in any receive lists + halo_level(ele)=3 + end if + end if + end do - end if - - if (associated(h_mesh%mesh%halos)) then - if(element_owned(h_mesh%mesh, h_ele)) then - ! element ownership (based on the process with lowest rank - ! owning any node in the element), nicely transfers to the columns - halo_level(ele)=0 - else if (adjacent_to_owned_element) then - ! this is not true for halo1 - only those that directly face owned elements - halo_level(ele)=1 - else if (adjacent_to_owned_column) then - ! extruded halo2 elements are necessarily in a column under - ! a halo1 element - halo_level(ele)=2 - else - ! misc elements - not owned, not in any receive lists - halo_level(ele)=3 - end if - end if - end do + ! And advance down the column + hanging_node(column) = node + column_count(column) = column_count(column) + 1 + assert( column_count(column)<=column_size(column) ) + end do nodes - ! And advance down the column - hanging_node(column) = node - column_count(column) = column_count(column) + 1 - assert( column_count(column)<=column_size(column) ) - end do nodes + assert(all(column_count==column_size)) - assert(all(column_count==column_size)) + deallocate(sorted) - deallocate(sorted) + ! if #layers>1, set layer path for next layer + layer_path = trim(mesh%mesh%option_path) // & + "/from_mesh/extrude/layer[" // int2str(layer) // ']' - ! if #layers>1, set layer path for next layer - layer_path = trim(mesh%mesh%option_path) // & - "/from_mesh/extrude/layer[" // int2str(layer) // ']' + end do layers - end do layers + assert(ele==element_count(mesh)) + assert(all(mesh%mesh%element_columns>0)) - assert(ele==element_count(mesh)) - assert(all(mesh%mesh%element_columns>0)) + if (radial_layering) then + call deallocate( height_field ) + end if - if (radial_layering) then - call deallocate( height_field ) - end if + if (associated(h_mesh%mesh%halos)) then + ! now reorder the elements according to halo level + + ! preserve %ndglno on in_mesh + in_mesh = mesh%mesh + ! get a new one for mesh + allocate(mesh%mesh%ndglno(size(in_mesh%ndglno))) + call allocate( old2new_ele ) + + ! first the owned elements + ele = 0 ! new element nr. in mesh + do i=0, 3 + ! loop over old element nrs j: + do j=1, element_count(in_mesh) + if (halo_level(j)==i) then + ele = ele + 1 ! new nr. + call set_ele_nodes(mesh%mesh, ele, ele_nodes(in_mesh, j)) + call insert(old2new_ele, j, ele) + end if + end do + end do + + deallocate(in_mesh%ndglno) + deallocate(halo_level) + + ! renumber element ownership of faces + do i=1, faces_seen + element_owners(i) = fetch(old2new_ele, element_owners(i)) + end do + + ! renumber the element columns + allocate(old_element_data(size(mesh%mesh%element_columns))) + old_element_data = mesh%mesh%element_columns + do i = 1, size(mesh%mesh%element_columns) + mesh%mesh%element_columns(fetch(old2new_ele, i)) = old_element_data(i) + end do + deallocate(old_element_data) + + allocate(old_element_data(size(mesh%mesh%region_ids))) + old_element_data = mesh%mesh%region_ids + do i = 1, size(mesh%mesh%region_ids) + mesh%mesh%region_ids(fetch(old2new_ele, i)) = old_element_data(i) + end do + deallocate(old_element_data) + + call deallocate(old2new_ele) + + call derive_other_extruded_halos(h_mesh%mesh, mesh%mesh) + end if - if (associated(h_mesh%mesh%halos)) then - ! now reorder the elements according to halo level + if (has_faces(h_mesh%mesh)) then + if (has_discontinuous_internal_boundaries(h_mesh%mesh)) then + ! horizontal has element ownership information allowing internal facet pairs + ! to have seperate surface ids (used in periodic meshes) - this means + ! the same holds for the extruded mesh + call add_faces(mesh%mesh, sndgln=sndgln(1:faces_seen*snloc), & + element_owner=element_owners(1:faces_seen), & + boundary_ids=boundary_ids(1:faces_seen)) + else + ! no element ownership is necessary, but in this case only one of each + ! pair of internal facets should be provided in sndgln unless we tell + ! add_faces() to filter these out (reordering the facets) + call add_faces(mesh%mesh, sndgln=sndgln(1:faces_seen*snloc), & + boundary_ids=boundary_ids(1:faces_seen), & + allow_duplicate_internal_facets=.true.) + end if + end if - ! preserve %ndglno on in_mesh - in_mesh = mesh%mesh - ! get a new one for mesh - allocate(mesh%mesh%ndglno(size(in_mesh%ndglno))) - call allocate( old2new_ele ) + if (associated(h_mesh%mesh%halos)) then + ! make sure we obey zoltan's ordering convention + call reorder_element_numbering(mesh) + end if - ! first the owned elements - ele = 0 ! new element nr. in mesh - do i=0, 3 - ! loop over old element nrs j: - do j=1, element_count(in_mesh) - if (halo_level(j)==i) then - ele = ele + 1 ! new nr. - call set_ele_nodes(mesh%mesh, ele, ele_nodes(in_mesh, j)) - call insert(old2new_ele, j, ele) - end if - end do - end do + deallocate(element_owners) + deallocate(boundary_ids) + deallocate(sndgln) + deallocate(bottom_surface_ids) + deallocate(top_surface_ids) + deallocate(extruded_region_ids) + deallocate(hanging_node) + deallocate(column_size) + deallocate(column_count) - deallocate(in_mesh%ndglno) - deallocate(halo_level) - ! renumber element ownership of faces - do i=1, faces_seen - element_owners(i) = fetch(old2new_ele, element_owners(i)) - end do + end subroutine generate_layered_mesh - ! renumber the element columns - allocate(old_element_data(size(mesh%mesh%element_columns))) - old_element_data = mesh%mesh%element_columns - do i = 1, size(mesh%mesh%element_columns) - mesh%mesh%element_columns(fetch(old2new_ele, i)) = old_element_data(i) - end do - deallocate(old_element_data) + subroutine create_columns_sparsity(columns, mesh, positions) + !! Auxillary routine that creates a sparsity of which the rows + !! are the columns in a mesh, i.e. column indices of the sparsity correspond + !! to nodes in a mesh column. This is created from the node to column map mesh%columns + type(csr_sparsity), intent(out):: columns + type(mesh_type), intent(in):: mesh + ! pass in the positions if you want to guarantee that the columns are sorted in descending order + type(vector_field), intent(in), optional :: positions - allocate(old_element_data(size(mesh%mesh%region_ids))) - old_element_data = mesh%mesh%region_ids - do i = 1, size(mesh%mesh%region_ids) - mesh%mesh%region_ids(fetch(old2new_ele, i)) = old_element_data(i) - end do - deallocate(old_element_data) + type(csr_sparsity):: node2column_sparsity + integer:: i, no_nodes, no_columns - call deallocate(old2new_ele) + integer, dimension(:), pointer :: column_nodes + integer, dimension(:), allocatable :: permutation - call derive_other_extruded_halos(h_mesh%mesh, mesh%mesh) - end if + if (.not. associated(mesh%columns)) then + FLAbort("Called create_columns_sparsity on a mesh without columns") + end if - if (has_faces(h_mesh%mesh)) then - if (has_discontinuous_internal_boundaries(h_mesh%mesh)) then - ! horizontal has element ownership information allowing internal facet pairs - ! to have seperate surface ids (used in periodic meshes) - this means - ! the same holds for the extruded mesh - call add_faces(mesh%mesh, sndgln=sndgln(1:faces_seen*snloc), & - element_owner=element_owners(1:faces_seen), & - boundary_ids=boundary_ids(1:faces_seen)) + no_nodes=node_count(mesh) + if (no_nodes==0) then + no_columns = 0 else - ! no element ownership is necessary, but in this case only one of each - ! pair of internal facets should be provided in sndgln unless we tell - ! add_faces() to filter these out (reordering the facets) - call add_faces(mesh%mesh, sndgln=sndgln(1:faces_seen*snloc), & - boundary_ids=boundary_ids(1:faces_seen), & - allow_duplicate_internal_facets=.true.) + no_columns=maxval(mesh%columns) end if - end if - - if (associated(h_mesh%mesh%halos)) then - ! make sure we obey zoltan's ordering convention - call reorder_element_numbering(mesh) - end if - - deallocate(element_owners) - deallocate(boundary_ids) - deallocate(sndgln) - deallocate(bottom_surface_ids) - deallocate(top_surface_ids) - deallocate(extruded_region_ids) - deallocate(hanging_node) - deallocate(column_size) - deallocate(column_count) - - - end subroutine generate_layered_mesh - - subroutine create_columns_sparsity(columns, mesh, positions) - !! Auxillary routine that creates a sparsity of which the rows - !! are the columns in a mesh, i.e. column indices of the sparsity correspond - !! to nodes in a mesh column. This is created from the node to column map mesh%columns - type(csr_sparsity), intent(out):: columns - type(mesh_type), intent(in):: mesh - ! pass in the positions if you want to guarantee that the columns are sorted in descending order - type(vector_field), intent(in), optional :: positions - - type(csr_sparsity):: node2column_sparsity - integer:: i, no_nodes, no_columns - - integer, dimension(:), pointer :: column_nodes - integer, dimension(:), allocatable :: permutation - - if (.not. associated(mesh%columns)) then - FLAbort("Called create_columns_sparsity on a mesh without columns") - end if - - no_nodes=node_count(mesh) - if (no_nodes==0) then - no_columns = 0 - else - no_columns=maxval(mesh%columns) - end if - - ! first create trivial node to column sparsity - call allocate(node2column_sparsity, no_nodes, no_columns, no_nodes, & - diag=.false., name="Node2ColumnSparsity") - - ! each row (corresp. to a node) only has one entry - do i=1, no_nodes+1 - node2column_sparsity%findrm(i)=i - end do - - node2column_sparsity%colm=mesh%columns - - ! now "columns" is the transpose of that: - columns=transpose(node2column_sparsity) - columns%name=trim(mesh%name)//"ColumnsSparsity" - - call deallocate(node2column_sparsity) - - if(present(positions)) then - do i = 1, no_columns - column_nodes => row_m_ptr(columns, i) - allocate(permutation(size(column_nodes))) - ! NOTE WELL: here we assume that we only care about the last dimension - ! i.e. broken on the sphere like everything else! - call qsort(node_val(positions, positions%dim, column_nodes), permutation) - call apply_reverse_permutation(column_nodes, permutation) - deallocate(permutation) + + ! first create trivial node to column sparsity + call allocate(node2column_sparsity, no_nodes, no_columns, no_nodes, & + diag=.false., name="Node2ColumnSparsity") + + ! each row (corresp. to a node) only has one entry + do i=1, no_nodes+1 + node2column_sparsity%findrm(i)=i end do - columns%sorted_rows = .false. - end if + node2column_sparsity%colm=mesh%columns - end subroutine create_columns_sparsity + ! now "columns" is the transpose of that: + columns=transpose(node2column_sparsity) + columns%name=trim(mesh%name)//"ColumnsSparsity" - subroutine create_integer_heights(height_field, halo, integer_heights) - type(scalar_field), intent(in):: height_field - type(halo_type), intent(in):: halo - integer, dimension(:), intent(out):: integer_heights + call deallocate(node2column_sparsity) - real :: minv, maxv, int_base, int_range + if(present(positions)) then + do i = 1, no_columns + column_nodes => row_m_ptr(columns, i) + allocate(permutation(size(column_nodes))) + ! NOTE WELL: here we assume that we only care about the last dimension + ! i.e. broken on the sphere like everything else! + call qsort(node_val(positions, positions%dim, column_nodes), permutation) + call apply_reverse_permutation(column_nodes, permutation) + deallocate(permutation) + end do - ! NOTE: these are the min and max of -height_field%val - minv=-maxval(height_field) - maxv=-minval(height_field) - call allmin(minv) - call allmax(maxv) + columns%sorted_rows = .false. + end if - ! range of floats that can be rounded to integers - ! we use -huge/2 to +huge/2, just to be sure - int_base=-real(huge(1)/2) - int_range=real(huge(1)) - ! ah what the heck, heterogenous cluster computing is all the rage - call allmax(int_base) - call allmin(int_range) + end subroutine create_columns_sparsity - ! round the real heights to integer with as much precision as possible - integer_heights=floor( int_base+(-height_field%val-minv)/(maxv-minv)*int_range ) + subroutine create_integer_heights(height_field, halo, integer_heights) + type(scalar_field), intent(in):: height_field + type(halo_type), intent(in):: halo + integer, dimension(:), intent(out):: integer_heights - call halo_update(halo, integer_heights) + real :: minv, maxv, int_base, int_range - end subroutine create_integer_heights + ! NOTE: these are the min and max of -height_field%val + minv=-maxval(height_field) + maxv=-minval(height_field) + call allmin(minv) + call allmax(maxv) - subroutine parallel_consistent_ordering(ints, unn, index, layer_nodes) + ! range of floats that can be rounded to integers + ! we use -huge/2 to +huge/2, just to be sure + int_base=-real(huge(1)/2) + int_range=real(huge(1)) + ! ah what the heck, heterogenous cluster computing is all the rage + call allmax(int_base) + call allmin(int_range) - ! ints and unn are over the entire local node numbering - integer, dimension(:), intent(in):: ints ! integer heights - integer, dimension(:), intent(in):: unn ! for equal integer height, sort on unn secondly - ! returns a sorted index into the local node numbering, whose length is the number of nodes in the layer - integer, dimension(:), intent(out):: index - type(integer_set), intent(in) :: layer_nodes ! nodes in this layer + ! round the real heights to integer with as much precision as possible + integer_heights=floor( int_base+(-height_field%val-minv)/(maxv-minv)*int_range ) - integer, dimension(:), allocatable :: ints_packed, unn_packed, reindex - integer :: i, start, int1, int2 + call halo_update(halo, integer_heights) - if (key_count(layer_nodes)==0) return + end subroutine create_integer_heights - allocate(ints_packed(1:key_count(layer_nodes)), unn_packed(1:key_count(layer_nodes)), reindex(1:key_count(layer_nodes))) + subroutine parallel_consistent_ordering(ints, unn, index, layer_nodes) - ! ints_packed: integer heights for layer nodes only - do i=1, key_count(layer_nodes) - ints_packed(i) = ints(fetch(layer_nodes, i)) - end do + ! ints and unn are over the entire local node numbering + integer, dimension(:), intent(in):: ints ! integer heights + integer, dimension(:), intent(in):: unn ! for equal integer height, sort on unn secondly + ! returns a sorted index into the local node numbering, whose length is the number of nodes in the layer + integer, dimension(:), intent(out):: index + type(integer_set), intent(in) :: layer_nodes ! nodes in this layer - ! sort it (preliminary) - call qsort(ints_packed, index) + integer, dimension(:), allocatable :: ints_packed, unn_packed, reindex + integer :: i, start, int1, int2 - ! unn_packed: unn for layer nodes in preliminary order - do i=1, size(index) - unn_packed(i) = unn(fetch(layer_nodes, index(i))) - end do + if (key_count(layer_nodes)==0) return - ! now go through to order equal heights on universal node number - start=1 - int1=ints_packed(index(1)) - do i=2, size(ints_packed)+1 - if (i<=size(ints_packed)) then - int2=ints_packed(index(i)) - else - int2=int1+1 - end if - if (int2>int1) then - if (i-start>1) then - ! sort entries start to i-1 on unn - call qsort(unn_packed(start:i-1), reindex(1:i-start)) - index(start:i-1)=index(start+reindex(1:i-start)-1) - end if - ! start new series - start=i - int1=int2 - else if (int2int1) then + if (i-start>1) then + ! sort entries start to i-1 on unn + call qsort(unn_packed(start:i-1), reindex(1:i-start)) + index(start:i-1)=index(start+reindex(1:i-start)-1) + end if + ! start new series + start=i + int1=int2 + else if (int21) - else - call append_to_structures(column, z_meshes(layer, column), h_mesh, out_mesh, last_seen, skip_top_node=layer>1) - end if - call insert(layer_nodes(layer), (/ (i, i=first_node, last_seen) /)) - end do + !!< Extrude a given 2D mesh to a full 3D mesh. + !!< The layer depths are specified by a sizing function + !!< which can be arbitrary python. + + use fldebug + use global_parameters + use global_parameters + use futils, only: present_and_true + use quadrature + use quadrature + use elements + use spud + use data_structures + use sparse_tools + use linked_lists + use parallel_fields + use fields + use halos + use hadapt_advancing_front + + implicit none + + private + + public :: combine_z_meshes + +contains + + subroutine combine_z_meshes(h_mesh, z_meshes, out_mesh, & + full_shape, mesh_name, option_path, sl) + !! Given the h_mesh and a z_mesh under each node of it combines these + !! into a full horiz+vertic. mesh + type(vector_field), intent(inout):: h_mesh + type(vector_field), dimension(:,:), intent(in):: z_meshes + type(vector_field), intent(out):: out_mesh + type(element_type), intent(in):: full_shape + !! the name of the topol. mesh to be created, not the coordinate field + character(len=*), intent(in):: mesh_name, option_path + logical, dimension(:), intent(in), optional :: sl + + type(csr_sparsity):: out_columns + type(mesh_type):: mesh + integer, dimension(:, :), allocatable:: no_hanging_nodes + type(integer_set), dimension(size(z_meshes,1)) :: layer_nodes + integer:: layer, column, total_out_nodes, total_out_elements, z_elements, last_seen, first_node, i + logical, dimension(size(z_meshes,1)) :: sigma_layers + + if (present(sl)) then + sigma_layers = sl else - ! for non-owned columns we reserve node numbers, - ! but don't fill in out_mesh positions yet - ! note that in this way out_mesh will obtain the same halo ordering - ! convention as h_mesh - - ! first the top node in layer 1 - last_seen = last_seen + 1 - out_mesh%mesh%columns(last_seen) = column - call insert(layer_nodes(1), last_seen) - - do layer=1, size(z_meshes, 1) - out_mesh%mesh%columns(last_seen+1:last_seen+no_hanging_nodes(layer, column)) = column - call insert(layer_nodes(layer), (/ (i, i=last_seen+1, last_seen+no_hanging_nodes(layer,column)) /)) - last_seen = last_seen + no_hanging_nodes(layer, column) - end do + sigma_layers = .false. end if - end do - assert(last_seen==node_count(out_mesh)) - assert(all(out_mesh%mesh%columns>0)) - call create_columns_sparsity(out_columns, out_mesh%mesh) - - if (associated(h_mesh%mesh%halos)) then - ! derive l2 node halo for the out_mesh - call derive_extruded_l2_node_halo(h_mesh%mesh, out_mesh%mesh, out_columns) - ! positions in the non-owned columns can now simply be halo-updated - call halo_update(out_mesh) - end if + allocate(no_hanging_nodes(size(z_meshes,1), size(z_meshes,2))) + no_hanging_nodes=0 + do layer=1, size(z_meshes,1) + do column=1, size(z_meshes,2) + if (node_owned(h_mesh, column)) then + no_hanging_nodes(layer, column) = no_hanging_nodes(layer, column) + ele_count(z_meshes(layer, column)) + end if + end do + if (associated(h_mesh%mesh%halos)) then + call halo_update(h_mesh%mesh%halos(2), no_hanging_nodes(layer,:)) + end if + call allocate(layer_nodes(layer)) + end do - call generate_layered_mesh(out_mesh, h_mesh, layer_nodes) - call deallocate(layer_nodes) + total_out_nodes = 0 + ! For each column, + ! add (number of nodes hanging off (== number of 1d elements)) * (element connectivity of chain) + ! to compute the number of elements the extrusion routine will produce + total_out_elements = 0 + do column=1, size(z_meshes, 2) + z_elements = sum(no_hanging_nodes(:,column)) + total_out_nodes = total_out_nodes + z_elements + 1 + assert(associated(h_mesh%mesh%adj_lists)) + assert(associated(h_mesh%mesh%adj_lists%nelist)) + total_out_elements = total_out_elements + z_elements * row_length(h_mesh%mesh%adj_lists%nelist, column) + end do - ! If we have sigma layers we now populate the vector field with the actual positions - last_seen = 0 - do column=1, node_count(h_mesh) - do layer=1, size(z_meshes,1) - if (sigma_layers(layer) .and. node_owned(h_mesh, column)) then - call append_to_structures(column, z_meshes(layer, column), h_mesh, out_mesh, last_seen, skip_top_node=layer>1) - else - if (layer==1) last_seen = last_seen + 1 - last_seen = last_seen + no_hanging_nodes(layer, column) - end if + call allocate(mesh, total_out_nodes, total_out_elements, & + full_shape, mesh_name) + ! allocate mapping between extruded nodes to surface node (column number) + ! it lies under + allocate(mesh%columns(total_out_nodes)) + mesh%columns = 0 + ! allocate mapping between extruded elements to surface elements in horizontal mesh + ! it lies under + allocate(mesh%element_columns(total_out_elements)) + mesh%element_columns = 0 + ! to keep things simple, always allocate region_ids for the extruded mesh, regardless of whether h_mesh has them + allocate(mesh%region_ids(total_out_elements)) + if (mesh_name=="CoordinateMesh") then + call allocate(out_mesh, mesh_dim(h_mesh)+1, mesh, "Coordinate") + else + call allocate(out_mesh, mesh_dim(h_mesh)+1, mesh, trim(mesh_name)//"Coordinate") + end if + call deallocate(mesh) + + out_mesh%mesh%option_path=option_path + out_mesh%option_path="" + out_mesh%mesh%periodic = mesh_periodic(h_mesh) + + last_seen = 0 + do column=1, size(z_meshes, 2) + if (node_owned(h_mesh, column)) then + do layer=1, size(z_meshes, 1) + first_node = last_seen+1 + if (sigma_layers(layer)) then + ! If we have sigma layers we will first use one chain to create a dummy + ! 'mesh' that has the correct topological properties. We will later over write the + ! vector field with the correct one. We always have chain '1', so we'll use that now. + call append_to_structures(column, z_meshes(layer, 1), h_mesh, out_mesh, last_seen, skip_top_node=layer>1) + else + call append_to_structures(column, z_meshes(layer, column), h_mesh, out_mesh, last_seen, skip_top_node=layer>1) + end if + call insert(layer_nodes(layer), (/ (i, i=first_node, last_seen) /)) + end do + else + ! for non-owned columns we reserve node numbers, + ! but don't fill in out_mesh positions yet + ! note that in this way out_mesh will obtain the same halo ordering + ! convention as h_mesh + + ! first the top node in layer 1 + last_seen = last_seen + 1 + out_mesh%mesh%columns(last_seen) = column + call insert(layer_nodes(1), last_seen) + + do layer=1, size(z_meshes, 1) + out_mesh%mesh%columns(last_seen+1:last_seen+no_hanging_nodes(layer, column)) = column + call insert(layer_nodes(layer), (/ (i, i=last_seen+1, last_seen+no_hanging_nodes(layer,column)) /)) + last_seen = last_seen + no_hanging_nodes(layer, column) + end do + end if end do - end do - if (any(sigma_layers)) then - call halo_update(out_mesh) - end if + assert(last_seen==node_count(out_mesh)) + assert(all(out_mesh%mesh%columns>0)) + + call create_columns_sparsity(out_columns, out_mesh%mesh) - call deallocate(out_columns) + if (associated(h_mesh%mesh%halos)) then + ! derive l2 node halo for the out_mesh + call derive_extruded_l2_node_halo(h_mesh%mesh, out_mesh%mesh, out_columns) + ! positions in the non-owned columns can now simply be halo-updated + call halo_update(out_mesh) + end if - end subroutine combine_z_meshes + call generate_layered_mesh(out_mesh, h_mesh, layer_nodes) + call deallocate(layer_nodes) + + ! If we have sigma layers we now populate the vector field with the actual positions + last_seen = 0 + do column=1, node_count(h_mesh) + do layer=1, size(z_meshes,1) + if (sigma_layers(layer) .and. node_owned(h_mesh, column)) then + call append_to_structures(column, z_meshes(layer, column), h_mesh, out_mesh, last_seen, skip_top_node=layer>1) + else + if (layer==1) last_seen = last_seen + 1 + last_seen = last_seen + no_hanging_nodes(layer, column) + end if + end do + end do + if (any(sigma_layers)) then + call halo_update(out_mesh) + end if - subroutine append_to_structures(column, z_mesh, h_mesh, out_mesh, last_seen, skip_top_node) - integer, intent(in) :: column - type(vector_field), intent(in) :: z_mesh, h_mesh - type(vector_field), intent(inout) :: out_mesh - integer, intent(inout) :: last_seen ! last added node anywhere in mesh - logical, intent(in) :: skip_top_node ! for layers below, we skip the top node + call deallocate(out_columns) - integer :: j, start - integer :: v_dim - logical :: radial_extrusion + end subroutine combine_z_meshes - real, dimension(mesh_dim(out_mesh)) :: pos, origin, direction + subroutine append_to_structures(column, z_mesh, h_mesh, out_mesh, last_seen, skip_top_node) + integer, intent(in) :: column + type(vector_field), intent(in) :: z_mesh, h_mesh + type(vector_field), intent(inout) :: out_mesh + integer, intent(inout) :: last_seen ! last added node anywhere in mesh + logical, intent(in) :: skip_top_node ! for layers below, we skip the top node - radial_extrusion = have_option("/geometry/spherical_earth") + integer :: j, start + integer :: v_dim + logical :: radial_extrusion - v_dim = mesh_dim(out_mesh) + real, dimension(mesh_dim(out_mesh)) :: pos, origin, direction - origin = 0.0 - origin(1:h_mesh%dim) = node_val(h_mesh, column) - if (skip_top_node) then - start = 2 ! skip the first node in z_mesh as this is the same as the last one from the previous layer - else - start = 1 - end if + radial_extrusion = have_option("/geometry/spherical_earth") - if (radial_extrusion) direction = origin/norm2(origin) + v_dim = mesh_dim(out_mesh) - do j=start, node_count(z_mesh) - last_seen = last_seen + 1 - out_mesh%mesh%columns(last_seen)=column - if (radial_extrusion) then - pos = origin + direction*node_val(z_mesh, 1, j) + origin = 0.0 + origin(1:h_mesh%dim) = node_val(h_mesh, column) + if (skip_top_node) then + start = 2 ! skip the first node in z_mesh as this is the same as the last one from the previous layer else - pos = origin - pos(v_dim) = origin(v_dim) + node_val(z_mesh, 1, j) + start = 1 end if - call set(out_mesh, last_seen, pos) - end do - end subroutine append_to_structures + if (radial_extrusion) direction = origin/norm2(origin) + + do j=start, node_count(z_mesh) + last_seen = last_seen + 1 + out_mesh%mesh%columns(last_seen)=column + if (radial_extrusion) then + pos = origin + direction*node_val(z_mesh, 1, j) + else + pos = origin + pos(v_dim) = origin(v_dim) + node_val(z_mesh, 1, j) + end if + call set(out_mesh, last_seen, pos) + end do - subroutine derive_extruded_l2_node_halo(h_mesh, out_mesh, columns) - ! derive the l2 node halo for the extruded mesh - type(mesh_type), intent(in):: h_mesh - type(mesh_type), intent(inout):: out_mesh - type(csr_sparsity), intent(in):: columns + end subroutine append_to_structures - integer, dimension(:), allocatable:: nsends, nreceives, sends, receives - integer:: proc_count, nowned_nodes - integer:: i, j, l, node, proc + subroutine derive_extruded_l2_node_halo(h_mesh, out_mesh, columns) + ! derive the l2 node halo for the extruded mesh + type(mesh_type), intent(in):: h_mesh + type(mesh_type), intent(inout):: out_mesh + type(csr_sparsity), intent(in):: columns - assert(halo_count(h_mesh) == 2) - assert(halo_valid_for_communication(h_mesh%halos(1))) - assert(halo_valid_for_communication(h_mesh%halos(2))) + integer, dimension(:), allocatable:: nsends, nreceives, sends, receives + integer:: proc_count, nowned_nodes + integer:: i, j, l, node, proc - assert(halo_count(out_mesh) == 0) - assert(size(columns,1)==node_count(h_mesh)) - assert(size(columns,2)==node_count(out_mesh)) + assert(halo_count(h_mesh) == 2) + assert(halo_valid_for_communication(h_mesh%halos(1))) + assert(halo_valid_for_communication(h_mesh%halos(2))) - ! this is easy, ownership of a node is determined by ownership - ! of the column it is in, where columns correspond to nodes in h_mesh - allocate(out_mesh%halos(2)) + assert(halo_count(out_mesh) == 0) + assert(size(columns,1)==node_count(h_mesh)) + assert(size(columns,2)==node_count(out_mesh)) - nowned_nodes = 0 - do i=1, node_count(h_mesh) - if (node_owned(h_mesh%halos(2), i)) then - nowned_nodes = nowned_nodes + row_length(columns, i) - end if - end do + ! this is easy, ownership of a node is determined by ownership + ! of the column it is in, where columns correspond to nodes in h_mesh + allocate(out_mesh%halos(2)) - proc_count = halo_proc_count(h_mesh%halos(2)) - allocate(nsends(proc_count), nreceives(proc_count)) - do proc=1, proc_count - - nsends(proc) = 0 - do i=1, halo_send_count(h_mesh%halos(2), proc) - node = halo_send(h_mesh%halos(2), proc, i) - nsends(proc) = nsends(proc) + row_length(columns, node) + nowned_nodes = 0 + do i=1, node_count(h_mesh) + if (node_owned(h_mesh%halos(2), i)) then + nowned_nodes = nowned_nodes + row_length(columns, i) + end if end do - nreceives(proc) = 0 - do i=1, halo_receive_count(h_mesh%halos(2), proc) - node = halo_receive(h_mesh%halos(2), proc, i) - nreceives(proc) = nreceives(proc) + row_length(columns, node) - end do - end do - - call allocate(out_mesh%halos(2), & - nsends = nsends, & - nreceives = nreceives, & - name = trim(out_mesh%name) // "Level2Halo", & - communicator = halo_communicator(h_mesh%halos(2)), & - nowned_nodes = nowned_nodes, & - data_type = halo_data_type(h_mesh%halos(2)), & - ordering_scheme = halo_ordering_scheme(h_mesh%halos(2))) - - do proc=1, proc_count - - allocate( sends(1:nsends(proc)) ) - j=1 - do i=1, halo_send_count(h_mesh%halos(2), proc) - node = halo_send(h_mesh%halos(2), proc, i) - l = row_length(columns, node) - sends(j:j+l-1) = row_m(columns, node) - j=j+l - end do - assert( j==nsends(proc)+1 ) - call set_halo_sends(out_mesh%halos(2), proc, sends) - deallocate(sends) - - allocate( receives(1:nreceives(proc)) ) - j=1 - do i=1, halo_receive_count(h_mesh%halos(2), proc) - node = halo_receive(h_mesh%halos(2), proc, i) - l = row_length(columns, node) - receives(j:j+l-1) = row_m(columns, node) - j=j+l + proc_count = halo_proc_count(h_mesh%halos(2)) + allocate(nsends(proc_count), nreceives(proc_count)) + do proc=1, proc_count + + nsends(proc) = 0 + do i=1, halo_send_count(h_mesh%halos(2), proc) + node = halo_send(h_mesh%halos(2), proc, i) + nsends(proc) = nsends(proc) + row_length(columns, node) + end do + + nreceives(proc) = 0 + do i=1, halo_receive_count(h_mesh%halos(2), proc) + node = halo_receive(h_mesh%halos(2), proc, i) + nreceives(proc) = nreceives(proc) + row_length(columns, node) + end do end do - assert( j==nreceives(proc)+1 ) - call set_halo_receives(out_mesh%halos(2), proc, receives) - deallocate(receives) - end do + call allocate(out_mesh%halos(2), & + nsends = nsends, & + nreceives = nreceives, & + name = trim(out_mesh%name) // "Level2Halo", & + communicator = halo_communicator(h_mesh%halos(2)), & + nowned_nodes = nowned_nodes, & + data_type = halo_data_type(h_mesh%halos(2)), & + ordering_scheme = halo_ordering_scheme(h_mesh%halos(2))) + + do proc=1, proc_count + + allocate( sends(1:nsends(proc)) ) + j=1 + do i=1, halo_send_count(h_mesh%halos(2), proc) + node = halo_send(h_mesh%halos(2), proc, i) + l = row_length(columns, node) + sends(j:j+l-1) = row_m(columns, node) + j=j+l + end do + assert( j==nsends(proc)+1 ) + call set_halo_sends(out_mesh%halos(2), proc, sends) + deallocate(sends) + + allocate( receives(1:nreceives(proc)) ) + j=1 + do i=1, halo_receive_count(h_mesh%halos(2), proc) + node = halo_receive(h_mesh%halos(2), proc, i) + l = row_length(columns, node) + receives(j:j+l-1) = row_m(columns, node) + j=j+l + end do + assert( j==nreceives(proc)+1 ) + call set_halo_receives(out_mesh%halos(2), proc, receives) + deallocate(receives) + + end do - assert(halo_valid_for_communication(out_mesh%halos(2))) + assert(halo_valid_for_communication(out_mesh%halos(2))) - deallocate( nsends, nreceives ) + deallocate( nsends, nreceives ) - call create_global_to_universal_numbering(out_mesh%halos(2)) - call create_ownership(out_mesh%halos(2)) + call create_global_to_universal_numbering(out_mesh%halos(2)) + call create_ownership(out_mesh%halos(2)) - end subroutine derive_extruded_l2_node_halo + end subroutine derive_extruded_l2_node_halo end module hadapt_combine_meshes diff --git a/horizontal_adaptivity/Extrude.F90 b/horizontal_adaptivity/Extrude.F90 index 8234fb4a32..ef753cf6df 100644 --- a/horizontal_adaptivity/Extrude.F90 +++ b/horizontal_adaptivity/Extrude.F90 @@ -1,661 +1,661 @@ #include "fdebug.h" module hadapt_extrude - !!< Extrude a given 2D mesh to a full 3D mesh. - !!< The layer depths are specified by a sizing function - !!< which can be arbitrary python. - - use fldebug - use global_parameters - use global_parameters - use futils, only: int2str - use quadrature - use quadrature - use elements - use spud - use data_structures - use parallel_tools - use sparse_tools - use linked_lists - use parallel_fields - use fields - use vtk_interfaces - use halos - use hadapt_combine_meshes - - implicit none - - private - - public :: extrude, compute_z_nodes, hadapt_extrude_check_options, populate_depth_vector - - interface compute_z_nodes - module procedure compute_z_nodes_wrapper, compute_z_nodes_sizing - end interface compute_z_nodes - - contains - - subroutine extrude(h_mesh, option_path, out_mesh) - !!< The horizontal 2D mesh. - !!< Note: this must be linear. - type(vector_field), intent(inout) :: h_mesh - !!< options to be set for out_mesh, - !!< at the moment: /name, and under from_mesh/extrude/: - !!< depth, sizing_function optionally top_surface_id and bottom_surface_id - character(len=*), intent(in) :: option_path - !!< The full extruded 3D mesh. - type(vector_field), intent(out) :: out_mesh - - character(len=FIELD_NAME_LEN):: mesh_name - type(quadrature_type) :: quad - type(element_type) :: full_shape - type(vector_field), dimension(:,:), allocatable :: z_meshes - real, dimension(:), allocatable :: top_depth - integer:: h_dim, column, quadrature_degree - - logical, dimension(:), allocatable :: sigma_layers - integer :: nlayers, nregions - - integer :: i, layer - - !! Checking linearity of h_mesh. - assert(h_mesh%mesh%shape%degree == 1) - assert(h_mesh%mesh%continuity >= 0) - - - call add_nelist(h_mesh%mesh) - - nlayers = option_count(trim(option_path)//"/from_mesh/extrude/layer") - nregions = option_count(trim(option_path)//"/from_mesh/extrude/regions") - if (nregions>0) then - ! regions directly under extrude/ - assume a single layer - if (nlayers>0) then - FLExit("Cannot specify regions and layers at the top level of extrude options") + !!< Extrude a given 2D mesh to a full 3D mesh. + !!< The layer depths are specified by a sizing function + !!< which can be arbitrary python. + + use fldebug + use global_parameters + use global_parameters + use futils, only: int2str + use quadrature + use quadrature + use elements + use spud + use data_structures + use parallel_tools + use sparse_tools + use linked_lists + use parallel_fields + use fields + use vtk_interfaces + use halos + use hadapt_combine_meshes + + implicit none + + private + + public :: extrude, compute_z_nodes, hadapt_extrude_check_options, populate_depth_vector + + interface compute_z_nodes + module procedure compute_z_nodes_wrapper, compute_z_nodes_sizing + end interface compute_z_nodes + +contains + + subroutine extrude(h_mesh, option_path, out_mesh) + !!< The horizontal 2D mesh. + !!< Note: this must be linear. + type(vector_field), intent(inout) :: h_mesh + !!< options to be set for out_mesh, + !!< at the moment: /name, and under from_mesh/extrude/: + !!< depth, sizing_function optionally top_surface_id and bottom_surface_id + character(len=*), intent(in) :: option_path + !!< The full extruded 3D mesh. + type(vector_field), intent(out) :: out_mesh + + character(len=FIELD_NAME_LEN):: mesh_name + type(quadrature_type) :: quad + type(element_type) :: full_shape + type(vector_field), dimension(:,:), allocatable :: z_meshes + real, dimension(:), allocatable :: top_depth + integer:: h_dim, column, quadrature_degree + + logical, dimension(:), allocatable :: sigma_layers + integer :: nlayers, nregions + + integer :: i, layer + + !! Checking linearity of h_mesh. + assert(h_mesh%mesh%shape%degree == 1) + assert(h_mesh%mesh%continuity >= 0) + + + call add_nelist(h_mesh%mesh) + + nlayers = option_count(trim(option_path)//"/from_mesh/extrude/layer") + nregions = option_count(trim(option_path)//"/from_mesh/extrude/regions") + if (nregions>0) then + ! regions directly under extrude/ - assume a single layer + if (nlayers>0) then + FLExit("Cannot specify regions and layers at the top level of extrude options") + end if + nlayers = 1 end if - nlayers = 1 - end if - - allocate(z_meshes(nlayers, node_count(h_mesh))) - allocate(sigma_layers(nlayers)) - - ! depth of top surface (==0.0 for top layer, but increases for layers below) - allocate(top_depth(node_count(h_mesh))) - top_depth = 0.0 - - if (nregions>0) then - ! if regions are specified directly under extrude/ the options under extrude/ - ! are the same as if we would have a top layer (first of one or more layers specified) - ! we therefore simply skip that level in the options hierarchy - call compute_z_meshes_layer(h_mesh, trim(option_path) // "/from_mesh/extrude", z_meshes(1,:), top_depth, sigma_layers(1)) - else - do i=0, nlayers-1 - call compute_z_meshes_layer(h_mesh, trim(option_path) // "/from_mesh/extrude/layer[" // int2str(i) // "]", & - z_meshes(i+1,:), top_depth, sigma_layers(i+1)) - end do - end if - ! Now the tiresome business of making a shape function. - h_dim = mesh_dim(h_mesh) - call get_option("/geometry/quadrature/degree", quadrature_degree) - quad = make_quadrature(vertices=h_dim + 2, dim=h_dim + 1, degree=quadrature_degree) - full_shape = make_element_shape(vertices=h_dim + 2, dim=h_dim + 1, degree=1, quad=quad) - call deallocate(quad) + allocate(z_meshes(nlayers, node_count(h_mesh))) + allocate(sigma_layers(nlayers)) + + ! depth of top surface (==0.0 for top layer, but increases for layers below) + allocate(top_depth(node_count(h_mesh))) + top_depth = 0.0 + + if (nregions>0) then + ! if regions are specified directly under extrude/ the options under extrude/ + ! are the same as if we would have a top layer (first of one or more layers specified) + ! we therefore simply skip that level in the options hierarchy + call compute_z_meshes_layer(h_mesh, trim(option_path) // "/from_mesh/extrude", z_meshes(1,:), top_depth, sigma_layers(1)) + else + do i=0, nlayers-1 + call compute_z_meshes_layer(h_mesh, trim(option_path) // "/from_mesh/extrude/layer[" // int2str(i) // "]", & + z_meshes(i+1,:), top_depth, sigma_layers(i+1)) + end do + end if - call get_option(trim(option_path)//'/name', mesh_name) + ! Now the tiresome business of making a shape function. + h_dim = mesh_dim(h_mesh) + call get_option("/geometry/quadrature/degree", quadrature_degree) + quad = make_quadrature(vertices=h_dim + 2, dim=h_dim + 1, degree=quadrature_degree) + full_shape = make_element_shape(vertices=h_dim + 2, dim=h_dim + 1, degree=1, quad=quad) + call deallocate(quad) - ! combine the 1d vertical meshes into a full mesh - call combine_z_meshes(h_mesh, z_meshes, out_mesh, & - full_shape, mesh_name, option_path, sl=sigma_layers) + call get_option(trim(option_path)//'/name', mesh_name) - do layer=1, nlayers - do column=1, node_count(h_mesh) - if (.not. node_owned(h_mesh, column)) cycle - call deallocate(z_meshes(layer, column)) + ! combine the 1d vertical meshes into a full mesh + call combine_z_meshes(h_mesh, z_meshes, out_mesh, & + full_shape, mesh_name, option_path, sl=sigma_layers) + + do layer=1, nlayers + do column=1, node_count(h_mesh) + if (.not. node_owned(h_mesh, column)) cycle + call deallocate(z_meshes(layer, column)) + end do end do - end do - call deallocate(full_shape) - deallocate(z_meshes) - deallocate(sigma_layers) - - end subroutine extrude - - subroutine compute_z_meshes_layer(h_mesh, layer_option_path, z_meshes, top_depth, sigma_layers) - !!< The horizontal 2D mesh. - type(vector_field), intent(inout) :: h_mesh - !!< options to be set for this layer - character(len=*), intent(in) :: layer_option_path - !!< a 1D column mesh for each node in h_mesh - type(vector_field), dimension(:), intent(out) :: z_meshes - !!< in: starting top depth for this layer, out: bottom depth for this layer, will be top depth for the next - real, dimension(:), intent(inout) :: top_depth - !!< whether the nodes in this layer should be connected as sigma layers - logical, intent(out) :: sigma_layers - - type(integer_set), dimension(:), allocatable :: region_columns - character(len=OPTION_PATH_LEN):: region_option_path - character(len=FIELD_NAME_LEN):: file_name - type(vector_field) :: constant_z_mesh - character(len=PYTHON_FUNC_LEN) :: sizing_function, depth_function - real, dimension(:), allocatable :: sizing_vector - logical:: depth_from_python, depth_from_map, have_min_depth, radial_extrusion, regional_sigma_layers - real, dimension(:), allocatable :: depth_vector - real:: min_depth, surface_height - logical:: sizing_is_constant, depth_is_constant, varies_only_in_depth, list_sizing - real:: constant_sizing, depth, min_bottom_layer_frac - integer:: column - - integer :: number_sigma_layers, nregions - - integer :: i, ele, r, visit_count - integer, dimension(:), pointer :: nodes - logical, dimension(:), allocatable :: column_visited - integer, dimension(:), allocatable :: region_ids - integer, dimension(2) :: shape_option - - assert(size(z_meshes)==node_count(h_mesh)) - assert(size(top_depth)==node_count(h_mesh)) - - nregions = option_count(trim(layer_option_path)//'/regions') - if(nregions==0) then - ewrite(-1,*) "I've been told to extrude but have found no regions options." - FLExit("No regions options found under extrude.") - elseif(nregions<0) then - FLAbort("Negative number of regions options found under extrude.") - end if - - allocate(region_columns(nregions)) - - if (nregions>1) then - - allocate(column_visited(1:node_count(h_mesh))) - column_visited = .false. - visit_count = 0 - ! work out which nodes are associated with each region spec. - ! loop backwards so the last region-spec. wins for shared nodes - regions1: do r = nregions, 1, -1 - region_option_path = trim(layer_option_path)//"/regions["//int2str(r-1)//"]" - call allocate(region_columns(r)) - shape_option=option_shape(trim(region_option_path)//"/region_ids") - allocate(region_ids(1:shape_option(1))) - call get_option(trim(region_option_path)//"/region_ids", region_ids) - do ele = 1, element_count(h_mesh) - if (any(region_ids==ele_region_id(h_mesh, ele))) then - nodes => ele_nodes(h_mesh, ele) - do i=1, size(nodes) - column = nodes(i) - if (node_owned(h_mesh, column) .and. .not. column_visited(column)) then - call insert(region_columns(r), column) - column_visited(column) = .true. - visit_count = visit_count+1 - end if + call deallocate(full_shape) + deallocate(z_meshes) + deallocate(sigma_layers) + + end subroutine extrude + + subroutine compute_z_meshes_layer(h_mesh, layer_option_path, z_meshes, top_depth, sigma_layers) + !!< The horizontal 2D mesh. + type(vector_field), intent(inout) :: h_mesh + !!< options to be set for this layer + character(len=*), intent(in) :: layer_option_path + !!< a 1D column mesh for each node in h_mesh + type(vector_field), dimension(:), intent(out) :: z_meshes + !!< in: starting top depth for this layer, out: bottom depth for this layer, will be top depth for the next + real, dimension(:), intent(inout) :: top_depth + !!< whether the nodes in this layer should be connected as sigma layers + logical, intent(out) :: sigma_layers + + type(integer_set), dimension(:), allocatable :: region_columns + character(len=OPTION_PATH_LEN):: region_option_path + character(len=FIELD_NAME_LEN):: file_name + type(vector_field) :: constant_z_mesh + character(len=PYTHON_FUNC_LEN) :: sizing_function, depth_function + real, dimension(:), allocatable :: sizing_vector + logical:: depth_from_python, depth_from_map, have_min_depth, radial_extrusion, regional_sigma_layers + real, dimension(:), allocatable :: depth_vector + real:: min_depth, surface_height + logical:: sizing_is_constant, depth_is_constant, varies_only_in_depth, list_sizing + real:: constant_sizing, depth, min_bottom_layer_frac + integer:: column + + integer :: number_sigma_layers, nregions + + integer :: i, ele, r, visit_count + integer, dimension(:), pointer :: nodes + logical, dimension(:), allocatable :: column_visited + integer, dimension(:), allocatable :: region_ids + integer, dimension(2) :: shape_option + + assert(size(z_meshes)==node_count(h_mesh)) + assert(size(top_depth)==node_count(h_mesh)) + + nregions = option_count(trim(layer_option_path)//'/regions') + if(nregions==0) then + ewrite(-1,*) "I've been told to extrude but have found no regions options." + FLExit("No regions options found under extrude.") + elseif(nregions<0) then + FLAbort("Negative number of regions options found under extrude.") + end if + + allocate(region_columns(nregions)) + + if (nregions>1) then + + allocate(column_visited(1:node_count(h_mesh))) + column_visited = .false. + visit_count = 0 + ! work out which nodes are associated with each region spec. + ! loop backwards so the last region-spec. wins for shared nodes + regions1: do r = nregions, 1, -1 + region_option_path = trim(layer_option_path)//"/regions["//int2str(r-1)//"]" + call allocate(region_columns(r)) + shape_option=option_shape(trim(region_option_path)//"/region_ids") + allocate(region_ids(1:shape_option(1))) + call get_option(trim(region_option_path)//"/region_ids", region_ids) + do ele = 1, element_count(h_mesh) + if (any(region_ids==ele_region_id(h_mesh, ele))) then + nodes => ele_nodes(h_mesh, ele) + do i=1, size(nodes) + column = nodes(i) + if (node_owned(h_mesh, column) .and. .not. column_visited(column)) then + call insert(region_columns(r), column) + column_visited(column) = .true. + visit_count = visit_count+1 + end if + end do + end if end do - end if - end do - deallocate(region_ids) - end do regions1 - if (nowned_nodes(h_mesh)/=visit_count) then - FLExit("Not all parts of the horizontal mesh have extruded mesh regions associated with them.") + deallocate(region_ids) + end do regions1 + if (nowned_nodes(h_mesh)/=visit_count) then + FLExit("Not all parts of the horizontal mesh have extruded mesh regions associated with them.") + end if + deallocate(column_visited) + else + call allocate(region_columns(1)) + do column=1, node_count(h_mesh) + if (node_owned(h_mesh, column)) then + call insert(region_columns(1), column) + end if + end do end if - deallocate(column_visited) - else - call allocate(region_columns(1)) - do column=1, node_count(h_mesh) - if (node_owned(h_mesh, column)) then - call insert(region_columns(1), column) - end if - end do - end if - ! auxillary array for depth_from_map: - allocate(depth_vector(node_count(h_mesh))) + ! auxillary array for depth_from_map: + allocate(depth_vector(node_count(h_mesh))) - radial_extrusion = have_option("/geometry/spherical_earth") + radial_extrusion = have_option("/geometry/spherical_earth") - regions2: do r = 1, nregions + regions2: do r = 1, nregions - region_option_path = trim(layer_option_path)//"/regions["//int2str(r-1)//"]" + region_option_path = trim(layer_option_path)//"/regions["//int2str(r-1)//"]" - call get_regional_extrusion_options(region_option_path, & - depth_is_constant, depth, depth_from_python, depth_function, depth_from_map, & - file_name, have_min_depth, min_depth, surface_height, sizing_is_constant, constant_sizing, list_sizing, & - sizing_function, sizing_vector, min_bottom_layer_frac, varies_only_in_depth, regional_sigma_layers, number_sigma_layers) - if (r>1 .and. (regional_sigma_layers .neqv. sigma_layers)) then - ewrite(-1,*) "In extrusion options for layer: ", trim(layer_option_path) - FLExit("When using sigma layers, in one region this should be done in every region") - else - sigma_layers = regional_sigma_layers - end if + call get_regional_extrusion_options(region_option_path, & + depth_is_constant, depth, depth_from_python, depth_function, depth_from_map, & + file_name, have_min_depth, min_depth, surface_height, sizing_is_constant, constant_sizing, list_sizing, & + sizing_function, sizing_vector, min_bottom_layer_frac, varies_only_in_depth, regional_sigma_layers, number_sigma_layers) + if (r>1 .and. (regional_sigma_layers .neqv. sigma_layers)) then + ewrite(-1,*) "In extrusion options for layer: ", trim(layer_option_path) + FLExit("When using sigma layers, in one region this should be done in every region") + else + sigma_layers = regional_sigma_layers + end if - ! note that a region having no nodal columns to extrude, does not mean it has no elemental columns - if (key_count(region_columns(r))==0) cycle + ! note that a region having no nodal columns to extrude, does not mean it has no elemental columns + if (key_count(region_columns(r))==0) cycle - if (depth_from_map) then - call populate_depth_vector(h_mesh,file_name,depth_vector,surface_height,radial_extrusion) - end if + if (depth_from_map) then + call populate_depth_vector(h_mesh,file_name,depth_vector,surface_height,radial_extrusion) + end if - if(varies_only_in_depth .and. depth_is_constant) then - column = fetch(region_columns(r), 1) - call compute_z_nodes(constant_z_mesh, node_val(h_mesh, column), min_bottom_layer_frac, & - top_depth(column), & - depth_is_constant, depth, depth_from_python, depth_function, & - depth_from_map, depth_vector(column), have_min_depth, min_depth, & - sizing_is_constant, constant_sizing, list_sizing, sizing_function, sizing_vector, & - sigma_layers, number_sigma_layers, radial_extrusion) - do i=1, key_count(region_columns(r)) - column = fetch(region_columns(r), i) - call get_previous_z_nodes(z_meshes(column), constant_z_mesh) - end do - call deallocate(constant_z_mesh) - else - do i=1, key_count(region_columns(r)) - column = fetch(region_columns(r), i) - call compute_z_nodes(z_meshes(column), node_val(h_mesh, column), min_bottom_layer_frac, & - top_depth(column), & - depth_is_constant, depth, depth_from_python, depth_function, & - depth_from_map, depth_vector(column), have_min_depth, min_depth, & - sizing_is_constant, constant_sizing, list_sizing, sizing_function, sizing_vector, & - sigma_layers, number_sigma_layers, radial_extrusion) - end do - end if + if(varies_only_in_depth .and. depth_is_constant) then + column = fetch(region_columns(r), 1) + call compute_z_nodes(constant_z_mesh, node_val(h_mesh, column), min_bottom_layer_frac, & + top_depth(column), & + depth_is_constant, depth, depth_from_python, depth_function, & + depth_from_map, depth_vector(column), have_min_depth, min_depth, & + sizing_is_constant, constant_sizing, list_sizing, sizing_function, sizing_vector, & + sigma_layers, number_sigma_layers, radial_extrusion) + do i=1, key_count(region_columns(r)) + column = fetch(region_columns(r), i) + call get_previous_z_nodes(z_meshes(column), constant_z_mesh) + end do + call deallocate(constant_z_mesh) + else + do i=1, key_count(region_columns(r)) + column = fetch(region_columns(r), i) + call compute_z_nodes(z_meshes(column), node_val(h_mesh, column), min_bottom_layer_frac, & + top_depth(column), & + depth_is_constant, depth, depth_from_python, depth_function, & + depth_from_map, depth_vector(column), have_min_depth, min_depth, & + sizing_is_constant, constant_sizing, list_sizing, sizing_function, sizing_vector, & + sigma_layers, number_sigma_layers, radial_extrusion) + end do + end if - call deallocate(region_columns(r)) + call deallocate(region_columns(r)) - end do regions2 + end do regions2 - deallocate(depth_vector) + deallocate(depth_vector) - end subroutine compute_z_meshes_layer + end subroutine compute_z_meshes_layer - subroutine get_regional_extrusion_options(region_option_path, & - depth_is_constant, depth, depth_from_python, depth_function, depth_from_map, & - file_name, have_min_depth, min_depth, surface_height, & - sizing_is_constant, constant_sizing, list_sizing, & - sizing_function, sizing_vector, min_bottom_layer_frac, & - varies_only_in_depth, sigma_layers, number_sigma_layers) + subroutine get_regional_extrusion_options(region_option_path, & + depth_is_constant, depth, depth_from_python, depth_function, depth_from_map, & + file_name, have_min_depth, min_depth, surface_height, & + sizing_is_constant, constant_sizing, list_sizing, & + sizing_function, sizing_vector, min_bottom_layer_frac, & + varies_only_in_depth, sigma_layers, number_sigma_layers) - character(len=*), intent(in) :: region_option_path + character(len=*), intent(in) :: region_option_path - logical, intent(out) :: depth_is_constant, depth_from_python, depth_from_map - real, intent(out) :: depth - character(len=PYTHON_FUNC_LEN), intent(out) :: depth_function + logical, intent(out) :: depth_is_constant, depth_from_python, depth_from_map + real, intent(out) :: depth + character(len=PYTHON_FUNC_LEN), intent(out) :: depth_function - logical, intent(out) :: sizing_is_constant, list_sizing - real, intent(out) :: constant_sizing - character(len=PYTHON_FUNC_LEN), intent(out) :: sizing_function - real, dimension(:), allocatable, intent(out) :: sizing_vector + logical, intent(out) :: sizing_is_constant, list_sizing + real, intent(out) :: constant_sizing + character(len=PYTHON_FUNC_LEN), intent(out) :: sizing_function + real, dimension(:), allocatable, intent(out) :: sizing_vector - character(len=FIELD_NAME_LEN), intent(out) :: file_name - logical, intent(out) :: have_min_depth - real, intent(out) :: min_depth, surface_height + character(len=FIELD_NAME_LEN), intent(out) :: file_name + logical, intent(out) :: have_min_depth + real, intent(out) :: min_depth, surface_height - logical, intent(out) :: varies_only_in_depth + logical, intent(out) :: varies_only_in_depth - real, intent(out) :: min_bottom_layer_frac + real, intent(out) :: min_bottom_layer_frac - logical, intent(out) :: sigma_layers - integer, intent(out) :: number_sigma_layers + logical, intent(out) :: sigma_layers + integer, intent(out) :: number_sigma_layers - integer, dimension(2) :: shape_option - integer :: stat + integer, dimension(2) :: shape_option + integer :: stat - ! options under bottom_depth - depth_from_python=.false. - depth_from_map=.false. - have_min_depth=.false. - call get_option(trim(region_option_path)//'/bottom_depth/constant', depth, stat=stat) - if (stat==0) then - depth_is_constant = .true. - else - depth_is_constant = .false. - call get_option(trim(region_option_path)//'/bottom_depth/python', depth_function, stat=stat) + ! options under bottom_depth + depth_from_python=.false. + depth_from_map=.false. + have_min_depth=.false. + call get_option(trim(region_option_path)//'/bottom_depth/constant', depth, stat=stat) if (stat==0) then - depth_from_python = .true. + depth_is_constant = .true. else - call get_option(trim(region_option_path)//'/bottom_depth/from_map/file_name', file_name, stat=stat) - if (stat==0) then - depth_from_map = .true. - else - FLAbort("Unknown way of specifying bottom depth function in mesh extrusion") - end if + depth_is_constant = .false. + call get_option(trim(region_option_path)//'/bottom_depth/python', depth_function, stat=stat) + if (stat==0) then + depth_from_python = .true. + else + call get_option(trim(region_option_path)//'/bottom_depth/from_map/file_name', file_name, stat=stat) + if (stat==0) then + depth_from_map = .true. + else + FLAbort("Unknown way of specifying bottom depth function in mesh extrusion") + end if + end if end if - end if - - if (depth_from_map) then - call get_option(trim(region_option_path)//'/bottom_depth/from_map/min_depth',min_depth, stat=stat) - have_min_depth = stat==0 - call get_option(trim(region_option_path)//'/bottom_depth/from_map/surface_height',surface_height, default=0.0) - end if - - ! options under sizing_function - list_sizing=.false. - sigma_layers=.false. - call get_option(trim(region_option_path)//'/sizing_function/constant', constant_sizing, stat=stat) - if (stat==0) then - sizing_is_constant=.true. - else - sizing_is_constant=.false. - call get_option(trim(region_option_path)//'/sizing_function/python', sizing_function, stat=stat) - if (stat/=0) then - if (have_option(trim(region_option_path)//"/sizing_function/list")) then - list_sizing=.true. - shape_option=option_shape(trim(region_option_path)//"/sizing_function/list") - allocate(sizing_vector(1:shape_option(1))) - call get_option(trim(region_option_path)//'/sizing_function/list', sizing_vector) - else - call get_option(trim(region_option_path)//'/sizing_function/sigma_layers/standard', & - number_sigma_layers, stat=stat) - if (stat==0) then - sigma_layers = .true. - else - FLAbort("Unknown way of specifying sizing function in mesh extrusion") - end if - end if + + if (depth_from_map) then + call get_option(trim(region_option_path)//'/bottom_depth/from_map/min_depth',min_depth, stat=stat) + have_min_depth = stat==0 + call get_option(trim(region_option_path)//'/bottom_depth/from_map/surface_height',surface_height, default=0.0) end if - end if - varies_only_in_depth = have_option(trim(region_option_path)//'/sizing_function/varies_only_in_depth') + ! options under sizing_function + list_sizing=.false. + sigma_layers=.false. + call get_option(trim(region_option_path)//'/sizing_function/constant', constant_sizing, stat=stat) + if (stat==0) then + sizing_is_constant=.true. + else + sizing_is_constant=.false. + call get_option(trim(region_option_path)//'/sizing_function/python', sizing_function, stat=stat) + if (stat/=0) then + if (have_option(trim(region_option_path)//"/sizing_function/list")) then + list_sizing=.true. + shape_option=option_shape(trim(region_option_path)//"/sizing_function/list") + allocate(sizing_vector(1:shape_option(1))) + call get_option(trim(region_option_path)//'/sizing_function/list', sizing_vector) + else + call get_option(trim(region_option_path)//'/sizing_function/sigma_layers/standard', & + number_sigma_layers, stat=stat) + if (stat==0) then + sigma_layers = .true. + else + FLAbort("Unknown way of specifying sizing function in mesh extrusion") + end if + end if + end if + end if - call get_option(trim(region_option_path)//'/minimum_bottom_layer_fraction', & - min_bottom_layer_frac, default=1.e-3) + varies_only_in_depth = have_option(trim(region_option_path)//'/sizing_function/varies_only_in_depth') - end subroutine get_regional_extrusion_options + call get_option(trim(region_option_path)//'/minimum_bottom_layer_fraction', & + min_bottom_layer_frac, default=1.e-3) - subroutine populate_depth_vector(h_mesh,file_name,depth_vector,surface_height,radial_extrusion) + end subroutine get_regional_extrusion_options - type(vector_field), intent(in) :: h_mesh - character(len=FIELD_NAME_LEN), intent(in):: file_name - real, intent(in) :: surface_height - real, dimension(:,:), allocatable :: tmp_pos_vector - real, dimension(:), intent(inout) :: depth_vector - logical :: radial_extrusion + subroutine populate_depth_vector(h_mesh,file_name,depth_vector,surface_height,radial_extrusion) - integer :: column + type(vector_field), intent(in) :: h_mesh + character(len=FIELD_NAME_LEN), intent(in):: file_name + real, intent(in) :: surface_height + real, dimension(:,:), allocatable :: tmp_pos_vector + real, dimension(:), intent(inout) :: depth_vector + logical :: radial_extrusion - if(radial_extrusion) then + integer :: column - allocate(tmp_pos_vector(mesh_dim(h_mesh)+1, size(depth_vector))) + if(radial_extrusion) then - do column=1, node_count(h_mesh) - tmp_pos_vector(:,column) = node_val(h_mesh, column) - end do + allocate(tmp_pos_vector(mesh_dim(h_mesh)+1, size(depth_vector))) - call set_from_map(trim(file_name)//char(0), tmp_pos_vector(1,:), tmp_pos_vector(2,:), tmp_pos_vector(3,:), & - depth_vector, size(depth_vector), surface_height) + do column=1, node_count(h_mesh) + tmp_pos_vector(:,column) = node_val(h_mesh, column) + end do - else + call set_from_map(trim(file_name)//char(0), tmp_pos_vector(1,:), tmp_pos_vector(2,:), tmp_pos_vector(3,:), & + depth_vector, size(depth_vector), surface_height) - allocate(tmp_pos_vector(mesh_dim(h_mesh), size(depth_vector))) + else - do column=1, node_count(h_mesh) - tmp_pos_vector(:,column) = node_val(h_mesh, column) - end do + allocate(tmp_pos_vector(mesh_dim(h_mesh), size(depth_vector))) - call set_from_map_beta(trim(file_name)//char(0), tmp_pos_vector(1,:), tmp_pos_vector(2,:), & - depth_vector, size(depth_vector), surface_height) - - end if - - if (associated(h_mesh%mesh%halos)) then - call halo_update(h_mesh%mesh%halos(2), depth_vector) - end if - - deallocate(tmp_pos_vector) - - end subroutine populate_depth_vector - - subroutine compute_z_nodes_wrapper(z_mesh, xy, min_bottom_layer_frac, & - top_depth, & - depth_is_constant, depth, depth_from_python, depth_function, & - depth_from_map, map_depth, have_min_depth, min_depth, & - sizing_is_constant, constant_sizing, list_sizing, sizing_function, sizing_vector, & - sigma_layers, number_sigma_layers, radial_extrusion) - - type(vector_field), intent(out) :: z_mesh - real, dimension(:), intent(in) :: xy - real, intent(in) :: min_bottom_layer_frac - real, intent(inout) :: top_depth ! IN: depth of top node, OUT: depth of bottom node - logical, intent(in) :: depth_is_constant, sizing_is_constant, depth_from_python, depth_from_map, list_sizing - logical, intent(in) :: have_min_depth, sigma_layers - real, intent(in) :: map_depth, min_depth - real, intent(in) :: depth, constant_sizing - character(len=*), intent(in) :: depth_function, sizing_function - real, dimension(:), allocatable, intent(in) :: sizing_vector - integer, intent(in) :: number_sigma_layers - logical, intent(in) :: radial_extrusion - - real, dimension(1) :: tmp_depth - real, dimension(size(xy), 1) :: tmp_pos - real :: ldepth - - if(depth_is_constant) then - ldepth = depth - else - tmp_pos(:,1) = xy - if (depth_from_python) then - call set_from_python_function(tmp_depth, trim(depth_function), tmp_pos, time=0.0) - ldepth = tmp_depth(1) - else if (depth_from_map) then - ldepth = map_depth - if (have_min_depth) then - if (ldepth < min_depth) ldepth=min_depth - end if + do column=1, node_count(h_mesh) + tmp_pos_vector(:,column) = node_val(h_mesh, column) + end do + + call set_from_map_beta(trim(file_name)//char(0), tmp_pos_vector(1,:), tmp_pos_vector(2,:), & + depth_vector, size(depth_vector), surface_height) + + end if + + if (associated(h_mesh%mesh%halos)) then + call halo_update(h_mesh%mesh%halos(2), depth_vector) + end if + + deallocate(tmp_pos_vector) + + end subroutine populate_depth_vector + + subroutine compute_z_nodes_wrapper(z_mesh, xy, min_bottom_layer_frac, & + top_depth, & + depth_is_constant, depth, depth_from_python, depth_function, & + depth_from_map, map_depth, have_min_depth, min_depth, & + sizing_is_constant, constant_sizing, list_sizing, sizing_function, sizing_vector, & + sigma_layers, number_sigma_layers, radial_extrusion) + + type(vector_field), intent(out) :: z_mesh + real, dimension(:), intent(in) :: xy + real, intent(in) :: min_bottom_layer_frac + real, intent(inout) :: top_depth ! IN: depth of top node, OUT: depth of bottom node + logical, intent(in) :: depth_is_constant, sizing_is_constant, depth_from_python, depth_from_map, list_sizing + logical, intent(in) :: have_min_depth, sigma_layers + real, intent(in) :: map_depth, min_depth + real, intent(in) :: depth, constant_sizing + character(len=*), intent(in) :: depth_function, sizing_function + real, dimension(:), allocatable, intent(in) :: sizing_vector + integer, intent(in) :: number_sigma_layers + logical, intent(in) :: radial_extrusion + + real, dimension(1) :: tmp_depth + real, dimension(size(xy), 1) :: tmp_pos + real :: ldepth + + if(depth_is_constant) then + ldepth = depth else - FLAbort("Unknown way of specifying the bottom_depth.") + tmp_pos(:,1) = xy + if (depth_from_python) then + call set_from_python_function(tmp_depth, trim(depth_function), tmp_pos, time=0.0) + ldepth = tmp_depth(1) + else if (depth_from_map) then + ldepth = map_depth + if (have_min_depth) then + if (ldepth < min_depth) ldepth=min_depth + end if + else + FLAbort("Unknown way of specifying the bottom_depth.") + end if end if - end if - - if (sizing_is_constant) then - call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & - min_bottom_layer_frac, radial_extrusion, sizing=constant_sizing) - else - if (list_sizing) then - call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & - min_bottom_layer_frac, radial_extrusion, sizing_vector=sizing_vector) - else if (sigma_layers) then - call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & - min_bottom_layer_frac, radial_extrusion, number_sigma_layers=number_sigma_layers) + + if (sizing_is_constant) then + call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & + min_bottom_layer_frac, radial_extrusion, sizing=constant_sizing) else - call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & - min_bottom_layer_frac, radial_extrusion, sizing_function=sizing_function) + if (list_sizing) then + call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & + min_bottom_layer_frac, radial_extrusion, sizing_vector=sizing_vector) + else if (sigma_layers) then + call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & + min_bottom_layer_frac, radial_extrusion, number_sigma_layers=number_sigma_layers) + else + call compute_z_nodes(z_mesh, ldepth, xy, top_depth, & + min_bottom_layer_frac, radial_extrusion, sizing_function=sizing_function) + end if end if - end if - - end subroutine compute_z_nodes_wrapper - - subroutine get_previous_z_nodes(z_mesh, z_mesh_previous) - type(vector_field), intent(inout) :: z_mesh, z_mesh_previous - z_mesh = z_mesh_previous - call incref(z_mesh) - end subroutine get_previous_z_nodes - - subroutine compute_z_nodes_sizing(z_mesh, depth, xy, top_depth, min_bottom_layer_frac, & - radial_extrusion, sizing, & - sizing_function, sizing_vector, number_sigma_layers) - !!< Figure out at what depths to put the layers. - type(vector_field), intent(out) :: z_mesh - real, intent(in):: depth - real, dimension(:), intent(in):: xy - real, intent(inout) :: top_depth ! IN: depth of top node, OUT: depth of bottom node - ! to prevent infinitesimally thin bottom layer if sizing function - ! is an integer mulitple of total depth, the bottom layer needs - ! to have at least this fraction of the layer depth above it. - ! The recommended value is 1e-3. - real, intent(in) :: min_bottom_layer_frac - logical, intent(in) :: radial_extrusion - real, optional, intent(in):: sizing - character(len=*), optional, intent(in):: sizing_function - real, dimension(:), optional, intent(in) :: sizing_vector - integer, optional, intent(in) :: number_sigma_layers - ! this is a safety gap: - integer, parameter:: MAX_VERTICAL_NODES=1e6 - - integer :: elements - logical :: is_constant - real :: constant_value - - type(rlist):: depths - type(mesh_type) :: mesh - type(element_type) :: oned_shape - type(quadrature_type) :: oned_quad - integer :: quadrature_degree - integer :: ele - integer, parameter :: loc=2 - integer :: node - real, dimension(:), allocatable:: xyz - real, dimension(size(xy)) :: radial_dir - real :: delta_h, d - character(len=PYTHON_FUNC_LEN) :: py_func - integer :: list_size - - call get_option("/geometry/quadrature/degree", quadrature_degree) - oned_quad = make_quadrature(vertices=loc, dim=1, degree=quadrature_degree) - oned_shape = make_element_shape(vertices=loc, dim=1, degree=1, quad=oned_quad) - call deallocate(oned_quad) - - if (present(sizing)) then - is_constant=.true. - constant_value=sizing - py_func = " " - else if (present(sizing_function)) then - is_constant=.false. - constant_value=-1.0 - py_func = sizing_function - else if (present(sizing_vector)) then - is_constant=.false. - constant_value=-1.0 - list_size=size(sizing_vector) - else if (present(number_sigma_layers)) then - is_constant=.true. - constant_value=(depth-top_depth)/float(number_sigma_layers) - py_func = " " - else - FLAbort("Need to supply either sizing or sizing_function") - end if - - ! Start the mesh at the top (d=0 for the top layer) and work down to d=-depth. - d = top_depth - node=2 - ! first size(xy) coordinates remain fixed, - ! the last entry will be replaced with the appropriate depth - if (radial_extrusion) then - allocate(xyz(size(xy))) - else - allocate(xyz(size(xy)+1)) - end if - xyz(1:size(xy))=xy - radial_dir = 0.0 - if (radial_extrusion) radial_dir = xy/sqrt(sum(xy**2)) - call insert(depths, d) - do - if (radial_extrusion) then - xyz = xy - radial_dir*d + + end subroutine compute_z_nodes_wrapper + + subroutine get_previous_z_nodes(z_mesh, z_mesh_previous) + type(vector_field), intent(inout) :: z_mesh, z_mesh_previous + z_mesh = z_mesh_previous + call incref(z_mesh) + end subroutine get_previous_z_nodes + + subroutine compute_z_nodes_sizing(z_mesh, depth, xy, top_depth, min_bottom_layer_frac, & + radial_extrusion, sizing, & + sizing_function, sizing_vector, number_sigma_layers) + !!< Figure out at what depths to put the layers. + type(vector_field), intent(out) :: z_mesh + real, intent(in):: depth + real, dimension(:), intent(in):: xy + real, intent(inout) :: top_depth ! IN: depth of top node, OUT: depth of bottom node + ! to prevent infinitesimally thin bottom layer if sizing function + ! is an integer mulitple of total depth, the bottom layer needs + ! to have at least this fraction of the layer depth above it. + ! The recommended value is 1e-3. + real, intent(in) :: min_bottom_layer_frac + logical, intent(in) :: radial_extrusion + real, optional, intent(in):: sizing + character(len=*), optional, intent(in):: sizing_function + real, dimension(:), optional, intent(in) :: sizing_vector + integer, optional, intent(in) :: number_sigma_layers + ! this is a safety gap: + integer, parameter:: MAX_VERTICAL_NODES=1e6 + + integer :: elements + logical :: is_constant + real :: constant_value + + type(rlist):: depths + type(mesh_type) :: mesh + type(element_type) :: oned_shape + type(quadrature_type) :: oned_quad + integer :: quadrature_degree + integer :: ele + integer, parameter :: loc=2 + integer :: node + real, dimension(:), allocatable:: xyz + real, dimension(size(xy)) :: radial_dir + real :: delta_h, d + character(len=PYTHON_FUNC_LEN) :: py_func + integer :: list_size + + call get_option("/geometry/quadrature/degree", quadrature_degree) + oned_quad = make_quadrature(vertices=loc, dim=1, degree=quadrature_degree) + oned_shape = make_element_shape(vertices=loc, dim=1, degree=1, quad=oned_quad) + call deallocate(oned_quad) + + if (present(sizing)) then + is_constant=.true. + constant_value=sizing + py_func = " " + else if (present(sizing_function)) then + is_constant=.false. + constant_value=-1.0 + py_func = sizing_function + else if (present(sizing_vector)) then + is_constant=.false. + constant_value=-1.0 + list_size=size(sizing_vector) + else if (present(number_sigma_layers)) then + is_constant=.true. + constant_value=(depth-top_depth)/float(number_sigma_layers) + py_func = " " else - xyz(size(xy)+1)=-d + FLAbort("Need to supply either sizing or sizing_function") end if - if (present(sizing_vector)) then - if ((node-1)<=list_size) then - delta_h = sizing_vector(node-1) - else - delta_h = sizing_vector(list_size) - end if - node=node+1 + + ! Start the mesh at the top (d=0 for the top layer) and work down to d=-depth. + d = top_depth + node=2 + ! first size(xy) coordinates remain fixed, + ! the last entry will be replaced with the appropriate depth + if (radial_extrusion) then + allocate(xyz(size(xy))) else - delta_h = get_delta_h( xyz, is_constant, constant_value, py_func) + allocate(xyz(size(xy)+1)) end if - d=d + sign(delta_h, depth) - if (abs(d)>abs(depth)-min_bottom_layer_frac*delta_h) exit + xyz(1:size(xy))=xy + radial_dir = 0.0 + if (radial_extrusion) radial_dir = xy/sqrt(sum(xy**2)) call insert(depths, d) - if (depths%length>MAX_VERTICAL_NODES) then - ewrite(-1,*) "Check your extrude/sizing_function" - FLExit("Maximum number of vertical layers reached") - end if - end do - call insert(depths, depth) - elements=depths%length-1 - top_depth = depth + do + if (radial_extrusion) then + xyz = xy - radial_dir*d + else + xyz(size(xy)+1)=-d + end if + if (present(sizing_vector)) then + if ((node-1)<=list_size) then + delta_h = sizing_vector(node-1) + else + delta_h = sizing_vector(list_size) + end if + node=node+1 + else + delta_h = get_delta_h( xyz, is_constant, constant_value, py_func) + end if + d=d + sign(delta_h, depth) + if (abs(d)>abs(depth)-min_bottom_layer_frac*delta_h) exit + call insert(depths, d) + if (depths%length>MAX_VERTICAL_NODES) then + ewrite(-1,*) "Check your extrude/sizing_function" + FLExit("Maximum number of vertical layers reached") + end if + end do + call insert(depths, depth) + elements=depths%length-1 + top_depth = depth - call allocate(mesh, elements+1, elements, oned_shape, "ZMesh") - do ele=1,elements - mesh%ndglno((ele-1) * loc + 1: ele*loc) = (/ele, ele+1/) - end do + call allocate(mesh, elements+1, elements, oned_shape, "ZMesh") + do ele=1,elements + mesh%ndglno((ele-1) * loc + 1: ele*loc) = (/ele, ele+1/) + end do - call allocate(z_mesh, 1, mesh, "ZMeshCoordinates") - call deallocate(mesh) - call deallocate(oned_shape) + call allocate(z_mesh, 1, mesh, "ZMeshCoordinates") + call deallocate(mesh) + call deallocate(oned_shape) - do node=1, elements+1 - call set(z_mesh, node, (/ -pop(depths) /) ) - end do - deallocate(xyz) + do node=1, elements+1 + call set(z_mesh, node, (/ -pop(depths) /) ) + end do + deallocate(xyz) - ! For pathological sizing functions the mesh might have gotten inverted at the last step. - ! If you encounter this, make this logic smarter. - assert(abs(node_val(z_mesh, 1, elements)) < abs(node_val(z_mesh, 1, elements+1))) + ! For pathological sizing functions the mesh might have gotten inverted at the last step. + ! If you encounter this, make this logic smarter. + assert(abs(node_val(z_mesh, 1, elements)) < abs(node_val(z_mesh, 1, elements+1))) - assert(oned_quad%refcount%count == 1) - assert(oned_shape%refcount%count == 1) - assert(z_mesh%refcount%count == 1) - assert(mesh%refcount%count == 1) + assert(oned_quad%refcount%count == 1) + assert(oned_shape%refcount%count == 1) + assert(z_mesh%refcount%count == 1) + assert(mesh%refcount%count == 1) - contains + contains function get_delta_h(pos, is_constant, constant_value, py_func) result(delta_h) - real, dimension(:), intent(in) :: pos - logical, intent(in) :: is_constant - real, intent(in) :: constant_value - character(len=PYTHON_FUNC_LEN), intent(in) :: py_func - - real :: delta_h - real, dimension(1) :: delta_h_tmp - real, dimension(size(pos), 1) :: pos_tmp - - if (is_constant) then - delta_h = constant_value - else - pos_tmp(:, 1) = pos - call set_from_python_function(delta_h_tmp, trim(py_func), pos_tmp, time=0.0) - delta_h = delta_h_tmp(1) - end if - assert(delta_h > 0.0) + real, dimension(:), intent(in) :: pos + logical, intent(in) :: is_constant + real, intent(in) :: constant_value + character(len=PYTHON_FUNC_LEN), intent(in) :: py_func + + real :: delta_h + real, dimension(1) :: delta_h_tmp + real, dimension(size(pos), 1) :: pos_tmp + + if (is_constant) then + delta_h = constant_value + else + pos_tmp(:, 1) = pos + call set_from_python_function(delta_h_tmp, trim(py_func), pos_tmp, time=0.0) + delta_h = delta_h_tmp(1) + end if + assert(delta_h > 0.0) end function get_delta_h - end subroutine compute_z_nodes_sizing + end subroutine compute_z_nodes_sizing - ! hadapt_extrude options checking - subroutine hadapt_extrude_check_options + ! hadapt_extrude options checking + subroutine hadapt_extrude_check_options - integer :: nmeshes, m, nregions, nlayers - character(len=OPTION_PATH_LEN) :: mesh_path + integer :: nmeshes, m, nregions, nlayers + character(len=OPTION_PATH_LEN) :: mesh_path - nmeshes=option_count("/geometry/mesh") - do m = 0, nmeshes-1 - mesh_path="/geometry/mesh["//int2str(m)//"]" - nregions=option_count(trim(mesh_path)//'/from_mesh/extrude/regions') - nlayers =option_count(trim(mesh_path)//'/from_mesh/extrude/layer') - if (nregions>0 .and. nlayers>0) then - FLExit("Cannot specify regions and layers at the top level of extrude options") - end if - if (nlayers>1 .and.have_option('/mesh_adaptivity/hr_adaptivity')) then - ! note we do allow a single layer under extrude/ (although this obv. does not add any functionality) - ! the reason multiple layers don't work is because it needs implementing in Metric_based_extrude.F90 - ! where we currently hardcode nlayers=1 - FLExit('Cannot combine layered extrusion with mesh adaptivity') - end if - if (nregions>1 .or. option_count(trim(mesh_path)//'/from_mesh/extrude/layer/regions')>1) then - ! we're using region ids to extrude - if (have_option('/mesh_adaptivity/hr_adaptivity') & - .and. .not. have_option('/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions')) then - ewrite(-1,*) "You are using region ids to specify mesh extrusion" - ewrite(-1,*) "However in your adaptivity settings you have not selected " // & - & "/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions" - ewrite(-1,*) "This means fluidity will not be able to extrude your mesh again after the adapt." - FLExit("Missing /mesh_adaptivity/hr_adaptivity/preserve_mesh_regions option") - end if - end if - end do + nmeshes=option_count("/geometry/mesh") + do m = 0, nmeshes-1 + mesh_path="/geometry/mesh["//int2str(m)//"]" + nregions=option_count(trim(mesh_path)//'/from_mesh/extrude/regions') + nlayers =option_count(trim(mesh_path)//'/from_mesh/extrude/layer') + if (nregions>0 .and. nlayers>0) then + FLExit("Cannot specify regions and layers at the top level of extrude options") + end if + if (nlayers>1 .and.have_option('/mesh_adaptivity/hr_adaptivity')) then + ! note we do allow a single layer under extrude/ (although this obv. does not add any functionality) + ! the reason multiple layers don't work is because it needs implementing in Metric_based_extrude.F90 + ! where we currently hardcode nlayers=1 + FLExit('Cannot combine layered extrusion with mesh adaptivity') + end if + if (nregions>1 .or. option_count(trim(mesh_path)//'/from_mesh/extrude/layer/regions')>1) then + ! we're using region ids to extrude + if (have_option('/mesh_adaptivity/hr_adaptivity') & + .and. .not. have_option('/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions')) then + ewrite(-1,*) "You are using region ids to specify mesh extrusion" + ewrite(-1,*) "However in your adaptivity settings you have not selected " // & + & "/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions" + ewrite(-1,*) "This means fluidity will not be able to extrude your mesh again after the adapt." + FLExit("Missing /mesh_adaptivity/hr_adaptivity/preserve_mesh_regions option") + end if + end if + end do - end subroutine hadapt_extrude_check_options + end subroutine hadapt_extrude_check_options end module hadapt_extrude diff --git a/horizontal_adaptivity/Metric_based_extrude.F90 b/horizontal_adaptivity/Metric_based_extrude.F90 index e764e043c0..dd18d80764 100644 --- a/horizontal_adaptivity/Metric_based_extrude.F90 +++ b/horizontal_adaptivity/Metric_based_extrude.F90 @@ -2,801 +2,801 @@ module hadapt_metric_based_extrude - use fldebug - use vector_tools - use global_parameters - use futils, only: present_and_true - use quadrature - use elements - use spud - use quicksort - use data_structures - use sparse_tools - use metric_tools - use parallel_fields - use fields - use meshdiagnostics - use vtk_interfaces - use halos - use hadapt_advancing_front - use hadapt_combine_meshes - use interpolation_module - - implicit none - - private - - public :: metric_based_extrude, recombine_metric, get_1d_mesh, get_1d_tensor,& - adapt_1d - - contains - - subroutine metric_based_extrude(h_positions_new, h_positions_old, out_mesh, & - full_metric, full_positions, map) - !! Given a background mesh, and a metric on that background mesh, - !! solve a load of 1d adaptivity problems for each column's vertical - !! resolution. - type(vector_field), intent(inout) :: h_positions_new - type(vector_field), intent(inout) :: h_positions_old ! inout to allow pickers caching - type(vector_field), intent(out) :: out_mesh - ! the full metric, on the old full mesh - ! (i.e. this metric is not on a mesh related to the current/new - ! horizontal or extruded meshes) - type(tensor_field), intent(in) :: full_metric - type(vector_field), intent(in) :: full_positions - ! map from new nodal positions in h_position_new to - integer, dimension(:), intent(in), optional, target :: map - - !! A bunch of 1d meshes for each column in the background mesh - !! and for each column in the adapted mesh - !! We could assume here that all the columns of the background mesh - !! are the same. However, to get a better adaptive result, we might - !! want to adapt more than once with the same metric, so I won't make - !! that assumption. Instead, we just assume that the background mesh - !! is columnar. - type(vector_field), dimension(:,:), allocatable :: out_z_meshes - type(vector_field) :: back_z_mesh - type(mesh_type) :: mesh - type(scalar_field) :: back_sizing - - type(element_type) :: oned_shape - type(quadrature_type) :: oned_quad - integer :: quadrature_degree - integer, parameter :: loc=2 - - integer :: i, column, h_old_ele, old_ele, prev_old_ele, old_face, nlayers - - type(csr_sparsity) :: columns_sparsity - integer, dimension(:), pointer :: column_nodes - integer, dimension(:), pointer :: lmap - integer, dimension(:), pointer :: old_ele_nodes, old_ele_faces, & - h_old_ele_nodes, neigh_old_eles, & - old_ele_neigh - - real, dimension(h_positions_new%dim) :: new_column_positions - - type(integer_set) :: top_surface_nodes, bottom_surface_nodes - type(integer_set) :: shared_elements - - real :: intersection_metric_comp, intersection_pos, mesh_size - - integer :: old_face_count, h_old_ele_loc - type(integer_set) :: face_columns - type(integer_hash_table) :: column_faces - - ! all of this is broken for variable element types! - real, dimension(full_positions%dim, face_loc(full_positions, 1)) :: old_face_positions - real, dimension(face_loc(full_positions, 1)) :: local_coords - integer, dimension(face_loc(full_positions, 1)) :: current_face_global_nodes, prev_face_global_nodes - type(integer_set), dimension(face_loc(full_positions, 1)) :: all_elements - - ewrite(1,*) "Inside metric_based_extrude" - - call get_option("/geometry/quadrature/degree", quadrature_degree) - oned_quad = make_quadrature(vertices=loc, dim=1, degree=quadrature_degree) - oned_shape = make_element_shape(vertices=loc, dim=1, degree=1, quad=oned_quad) - call deallocate(oned_quad) - - if (present(map)) then - assert(node_count(h_positions_new) == size(map)) - lmap => map - else - allocate(lmap(node_count(h_positions_new))) - lmap = get_element_mapping(h_positions_old, h_positions_new, only_owned=.true.) - end if - - nlayers = 1 - allocate(out_z_meshes(1:nlayers, 1:node_count(h_positions_new))) - call allocate(top_surface_nodes) - call allocate(bottom_surface_nodes) - - ! we need to make sure that the columns are descending ordered - ! so pass in full_positions - call create_columns_sparsity(columns_sparsity, full_positions%mesh, positions=full_positions) - - do column=1,node_count(h_positions_old) - column_nodes => row_m_ptr(columns_sparsity, column) - call insert(top_surface_nodes, column_nodes(1)) - call insert(bottom_surface_nodes, column_nodes(size(column_nodes))) - end do - - ! create a 1d vertical mesh under each surface node - do column=1,node_count(h_positions_new) - - if(.not.node_owned(h_positions_new, column)) cycle - - new_column_positions = node_val(h_positions_new, column) - - ! In what element of the old horizontal mesh does the new column lie? - h_old_ele = lmap(column) - h_old_ele_loc = ele_loc(h_positions_old, h_old_ele) - - ! we need to find the element at the top of the full mesh - ! first let's find out the nodes neighbouring this elements in the horizontal mesh - h_old_ele_nodes => ele_nodes(h_positions_old, h_old_ele) - - call allocate(all_elements) - do i = 1, size(h_old_ele_nodes) - ! then we work out the corresponding top node in the full mesh - column_nodes => row_m_ptr(columns_sparsity, h_old_ele_nodes(i)) - ! and work out the full mesh elements connected to that node - neigh_old_eles => node_neigh(full_positions, column_nodes(1)) - ! insert it into a set - call insert(all_elements(i), neigh_old_eles) + use fldebug + use vector_tools + use global_parameters + use futils, only: present_and_true + use quadrature + use elements + use spud + use quicksort + use data_structures + use sparse_tools + use metric_tools + use parallel_fields + use fields + use meshdiagnostics + use vtk_interfaces + use halos + use hadapt_advancing_front + use hadapt_combine_meshes + use interpolation_module + + implicit none + + private + + public :: metric_based_extrude, recombine_metric, get_1d_mesh, get_1d_tensor,& + adapt_1d + +contains + + subroutine metric_based_extrude(h_positions_new, h_positions_old, out_mesh, & + full_metric, full_positions, map) + !! Given a background mesh, and a metric on that background mesh, + !! solve a load of 1d adaptivity problems for each column's vertical + !! resolution. + type(vector_field), intent(inout) :: h_positions_new + type(vector_field), intent(inout) :: h_positions_old ! inout to allow pickers caching + type(vector_field), intent(out) :: out_mesh + ! the full metric, on the old full mesh + ! (i.e. this metric is not on a mesh related to the current/new + ! horizontal or extruded meshes) + type(tensor_field), intent(in) :: full_metric + type(vector_field), intent(in) :: full_positions + ! map from new nodal positions in h_position_new to + integer, dimension(:), intent(in), optional, target :: map + + !! A bunch of 1d meshes for each column in the background mesh + !! and for each column in the adapted mesh + !! We could assume here that all the columns of the background mesh + !! are the same. However, to get a better adaptive result, we might + !! want to adapt more than once with the same metric, so I won't make + !! that assumption. Instead, we just assume that the background mesh + !! is columnar. + type(vector_field), dimension(:,:), allocatable :: out_z_meshes + type(vector_field) :: back_z_mesh + type(mesh_type) :: mesh + type(scalar_field) :: back_sizing + + type(element_type) :: oned_shape + type(quadrature_type) :: oned_quad + integer :: quadrature_degree + integer, parameter :: loc=2 + + integer :: i, column, h_old_ele, old_ele, prev_old_ele, old_face, nlayers + + type(csr_sparsity) :: columns_sparsity + integer, dimension(:), pointer :: column_nodes + integer, dimension(:), pointer :: lmap + integer, dimension(:), pointer :: old_ele_nodes, old_ele_faces, & + h_old_ele_nodes, neigh_old_eles, & + old_ele_neigh + + real, dimension(h_positions_new%dim) :: new_column_positions + + type(integer_set) :: top_surface_nodes, bottom_surface_nodes + type(integer_set) :: shared_elements + + real :: intersection_metric_comp, intersection_pos, mesh_size + + integer :: old_face_count, h_old_ele_loc + type(integer_set) :: face_columns + type(integer_hash_table) :: column_faces + + ! all of this is broken for variable element types! + real, dimension(full_positions%dim, face_loc(full_positions, 1)) :: old_face_positions + real, dimension(face_loc(full_positions, 1)) :: local_coords + integer, dimension(face_loc(full_positions, 1)) :: current_face_global_nodes, prev_face_global_nodes + type(integer_set), dimension(face_loc(full_positions, 1)) :: all_elements + + ewrite(1,*) "Inside metric_based_extrude" + + call get_option("/geometry/quadrature/degree", quadrature_degree) + oned_quad = make_quadrature(vertices=loc, dim=1, degree=quadrature_degree) + oned_shape = make_element_shape(vertices=loc, dim=1, degree=1, quad=oned_quad) + call deallocate(oned_quad) + + if (present(map)) then + assert(node_count(h_positions_new) == size(map)) + lmap => map + else + allocate(lmap(node_count(h_positions_new))) + lmap = get_element_mapping(h_positions_old, h_positions_new, only_owned=.true.) + end if + + nlayers = 1 + allocate(out_z_meshes(1:nlayers, 1:node_count(h_positions_new))) + call allocate(top_surface_nodes) + call allocate(bottom_surface_nodes) + + ! we need to make sure that the columns are descending ordered + ! so pass in full_positions + call create_columns_sparsity(columns_sparsity, full_positions%mesh, positions=full_positions) + + do column=1,node_count(h_positions_old) + column_nodes => row_m_ptr(columns_sparsity, column) + call insert(top_surface_nodes, column_nodes(1)) + call insert(bottom_surface_nodes, column_nodes(size(column_nodes))) end do - call set_intersection(shared_elements, all_elements) + ! create a 1d vertical mesh under each surface node + do column=1,node_count(h_positions_new) + + if(.not.node_owned(h_positions_new, column)) cycle + + new_column_positions = node_val(h_positions_new, column) + + ! In what element of the old horizontal mesh does the new column lie? + h_old_ele = lmap(column) + h_old_ele_loc = ele_loc(h_positions_old, h_old_ele) + + ! we need to find the element at the top of the full mesh + ! first let's find out the nodes neighbouring this elements in the horizontal mesh + h_old_ele_nodes => ele_nodes(h_positions_old, h_old_ele) + + call allocate(all_elements) + do i = 1, size(h_old_ele_nodes) + ! then we work out the corresponding top node in the full mesh + column_nodes => row_m_ptr(columns_sparsity, h_old_ele_nodes(i)) + ! and work out the full mesh elements connected to that node + neigh_old_eles => node_neigh(full_positions, column_nodes(1)) + ! insert it into a set + call insert(all_elements(i), neigh_old_eles) + end do + + call set_intersection(shared_elements, all_elements) + + ! there should now only be one entry in shared_elements + if(key_count(shared_elements)/=1) then + ewrite(-1,*) 'key_count(shared_elements) = ', key_count(shared_elements) + FLAbort("Something has gone wrong finding the shared element.") + end if + + ! and that entry will be the top element... woo! + old_ele = fetch(shared_elements, 1) + + call deallocate(shared_elements) + call deallocate(all_elements) + + ! find the top facet (which won't be between any of my elements so can't + ! be included in the main loop) + old_ele_nodes => ele_nodes(full_positions, old_ele) + top_ele_node_loop: do i = 1, size(old_ele_nodes) + if(.not.has_value(top_surface_nodes, old_ele_nodes(i))) exit top_ele_node_loop + end do top_ele_node_loop + assert(i<=size(old_ele_nodes)) + ! i is now the local face number of the face on the top surface... woo! + + ! convert this to a global face number + old_ele_faces => ele_faces(full_positions, old_ele) + old_face = old_ele_faces(i) + + call allocate(column_faces) + old_face_count = 1 + ! insert the top face into the integer hash table + call insert(column_faces, old_face_count, old_face) + + ! record the top element as visited + prev_old_ele = old_ele + + infinite_loop: do + ! in this loop we work our way down the column of elements + ! let's hope we get to the exit criterion eventually! + + old_ele_faces => ele_faces(full_positions, old_ele) + old_ele_neigh => ele_neigh(full_positions, old_ele) + + face_loop: do i = 1, size(old_ele_faces) + call allocate(face_columns) + call insert(face_columns, full_positions%mesh%columns(face_global_nodes(full_positions, old_ele_faces(i)))) + ! the face between old_ele and the next element is the one with as many vertices as + ! the top element and isn't facing into the abyss or the previous element + if ((key_count(face_columns)==h_old_ele_loc).and.& + (old_ele_neigh(i)>0).and.(old_ele_neigh(i)/=prev_old_ele)) then + exit face_loop ! we found it + end if + call deallocate(face_columns) + end do face_loop + + if(i==size(old_ele_faces)+1) then + ! we didn't find a face that meets our criterion so we must be at the bottom of the column + exit infinite_loop + else + ! we found a face but didn't clean up... + call deallocate(face_columns) + end if - ! there should now only be one entry in shared_elements - if(key_count(shared_elements)/=1) then - ewrite(-1,*) 'key_count(shared_elements) = ', key_count(shared_elements) - FLAbort("Something has gone wrong finding the shared element.") - end if + ! remember where we were + prev_old_ele = old_ele + ! where we are now + old_ele = old_ele_neigh(i) - ! and that entry will be the top element... woo! - old_ele = fetch(shared_elements, 1) - - call deallocate(shared_elements) - call deallocate(all_elements) - - ! find the top facet (which won't be between any of my elements so can't - ! be included in the main loop) - old_ele_nodes => ele_nodes(full_positions, old_ele) - top_ele_node_loop: do i = 1, size(old_ele_nodes) - if(.not.has_value(top_surface_nodes, old_ele_nodes(i))) exit top_ele_node_loop - end do top_ele_node_loop - assert(i<=size(old_ele_nodes)) - ! i is now the local face number of the face on the top surface... woo! - - ! convert this to a global face number - old_ele_faces => ele_faces(full_positions, old_ele) - old_face = old_ele_faces(i) - - call allocate(column_faces) - old_face_count = 1 - ! insert the top face into the integer hash table - call insert(column_faces, old_face_count, old_face) - - ! record the top element as visited - prev_old_ele = old_ele - - infinite_loop: do - ! in this loop we work our way down the column of elements - ! let's hope we get to the exit criterion eventually! - - old_ele_faces => ele_faces(full_positions, old_ele) - old_ele_neigh => ele_neigh(full_positions, old_ele) - - face_loop: do i = 1, size(old_ele_faces) - call allocate(face_columns) - call insert(face_columns, full_positions%mesh%columns(face_global_nodes(full_positions, old_ele_faces(i)))) - ! the face between old_ele and the next element is the one with as many vertices as - ! the top element and isn't facing into the abyss or the previous element - if ((key_count(face_columns)==h_old_ele_loc).and.& - (old_ele_neigh(i)>0).and.(old_ele_neigh(i)/=prev_old_ele)) then - exit face_loop ! we found it - end if - call deallocate(face_columns) - end do face_loop - - if(i==size(old_ele_faces)+1) then - ! we didn't find a face that meets our criterion so we must be at the bottom of the column - exit infinite_loop - else - ! we found a face but didn't clean up... - call deallocate(face_columns) - end if - - ! remember where we were - prev_old_ele = old_ele - ! where we are now - old_ele = old_ele_neigh(i) - - ! the face between them - remember it! - old_face = old_ele_faces(i) - old_face_count = old_face_count + 1 - call insert(column_faces, old_face_count, old_face) - - end do infinite_loop - - ! the search above won't have found the bottom face so let's search for it too - old_ele_nodes => ele_nodes(full_positions, old_ele) - bottom_ele_node_loop: do i = 1, size(old_ele_nodes) - if(.not.has_value(bottom_surface_nodes, old_ele_nodes(i))) exit bottom_ele_node_loop - end do bottom_ele_node_loop - assert(i<=size(old_ele_nodes)) - ! i is now the local face number of the face on the bottom surface... woo! - - ! convert this to a global face number and save it - old_ele_faces => ele_faces(full_positions, old_ele) - old_face = old_ele_faces(i) - old_face_count = old_face_count + 1 - call insert(column_faces, old_face_count, old_face) - assert(key_count(column_faces)==old_face_count) - - - ! allocate the mesh and the fields we want - call allocate(mesh, old_face_count, old_face_count-1, oned_shape, "VerticalIntersectionMesh") - call allocate(back_z_mesh, 1, mesh, "BackVerticalMesh") - call allocate(back_sizing, mesh, "BackSizing") - call deallocate(mesh) + ! the face between them - remember it! + old_face = old_ele_faces(i) + old_face_count = old_face_count + 1 + call insert(column_faces, old_face_count, old_face) + end do infinite_loop - ! work out the local coordinates on the top face - ! only works for linear coordinates at the moment as adaptivity can - ! only deal with this anyway - local_coords(1:h_positions_new%dim) = new_column_positions - local_coords(h_positions_new%dim+1) = 1.0 + ! the search above won't have found the bottom face so let's search for it too + old_ele_nodes => ele_nodes(full_positions, old_ele) + bottom_ele_node_loop: do i = 1, size(old_ele_nodes) + if(.not.has_value(bottom_surface_nodes, old_ele_nodes(i))) exit bottom_ele_node_loop + end do bottom_ele_node_loop + assert(i<=size(old_ele_nodes)) + ! i is now the local face number of the face on the bottom surface... woo! - ! and find the values of the positions - old_face = fetch(column_faces, 1) - old_face_positions = face_val(full_positions, old_face) - ! wipe out the z component - i.e. assuming a horizontal face on the top surface - old_face_positions(h_positions_new%dim+1, :) = 1.0 + ! convert this to a global face number and save it + old_ele_faces => ele_faces(full_positions, old_ele) + old_face = old_ele_faces(i) + old_face_count = old_face_count + 1 + call insert(column_faces, old_face_count, old_face) + assert(key_count(column_faces)==old_face_count) - ! and hey presto... we have the local_coords - call solve(old_face_positions, local_coords) + ! allocate the mesh and the fields we want + call allocate(mesh, old_face_count, old_face_count-1, oned_shape, "VerticalIntersectionMesh") + call allocate(back_z_mesh, 1, mesh, "BackVerticalMesh") + call allocate(back_sizing, mesh, "BackSizing") + call deallocate(mesh) - ! work out the position of the intersection of the column with the top face - intersection_pos = face_eval_field(old_face, full_positions, full_positions%dim, local_coords) - call set(back_z_mesh, 1, (/intersection_pos/)) - ! work out the value of the dim, dim component of the full_metric at the intersection point - ! NOTE WELL: this is where we assume that up is in the vertical direction (i.e. not - ! safe on the sphere but that's not supported yet anyway and this is assumed in - ! lots of places) - intersection_metric_comp = face_eval_field(old_face, full_metric, full_metric%dim(1), full_metric%dim(2), local_coords) - mesh_size = edge_length_from_eigenvalue(intersection_metric_comp) - call set(back_sizing, 1, mesh_size) - ! finally find the global nodes of the first face - prev_face_global_nodes = face_global_nodes(full_positions, old_face) + ! work out the local coordinates on the top face + ! only works for linear coordinates at the moment as adaptivity can + ! only deal with this anyway + local_coords(1:h_positions_new%dim) = new_column_positions + local_coords(h_positions_new%dim+1) = 1.0 - do i = 2, old_face_count + ! and find the values of the positions + old_face = fetch(column_faces, 1) + old_face_positions = face_val(full_positions, old_face) + ! wipe out the z component - i.e. assuming a horizontal face on the top surface + old_face_positions(h_positions_new%dim+1, :) = 1.0 - old_face = fetch(column_faces, i) + ! and hey presto... we have the local_coords + call solve(old_face_positions, local_coords) - current_face_global_nodes = face_global_nodes(full_positions, old_face) - call permute_local_coords(local_coords, current_face_global_nodes, prev_face_global_nodes) + ! work out the position of the intersection of the column with the top face + intersection_pos = face_eval_field(old_face, full_positions, full_positions%dim, local_coords) + call set(back_z_mesh, 1, (/intersection_pos/)) + ! work out the value of the dim, dim component of the full_metric at the intersection point + ! NOTE WELL: this is where we assume that up is in the vertical direction (i.e. not + ! safe on the sphere but that's not supported yet anyway and this is assumed in + ! lots of places) + intersection_metric_comp = face_eval_field(old_face, full_metric, full_metric%dim(1), full_metric%dim(2), local_coords) + mesh_size = edge_length_from_eigenvalue(intersection_metric_comp) + call set(back_sizing, 1, mesh_size) - ! work out the position of the intersection of the column with the old face - intersection_pos = face_eval_field(old_face, full_positions, full_positions%dim, local_coords) - call set(back_z_mesh, i, (/intersection_pos/)) - ! work out the value of the dim, dim component of the full_metric at the intersection point - ! NOTE WELL: this is where we assume that up is in the vertical direction (i.e. not - ! safe on the sphere but that's not supported yet anyway and this is assumed in - ! lots of places) - intersection_metric_comp = face_eval_field(old_face, full_metric, full_metric%dim(1), full_metric%dim(2), local_coords) - mesh_size = edge_length_from_eigenvalue(intersection_metric_comp) - call set(back_sizing, i, mesh_size) + ! finally find the global nodes of the first face + prev_face_global_nodes = face_global_nodes(full_positions, old_face) - ! record the current global nodes as the previous ones for the next iteration - prev_face_global_nodes = current_face_global_nodes + do i = 2, old_face_count - end do + old_face = fetch(column_faces, i) + + current_face_global_nodes = face_global_nodes(full_positions, old_face) - ! and we're done... we've worked out the intersection positions in back_z_mesh and the intersection sizing - ! function in back_sizing. - call deallocate(column_faces) + call permute_local_coords(local_coords, current_face_global_nodes, prev_face_global_nodes) - ! now let's adapt that and put the adapted mesh in out_z_meshes(column)... - call adapt_1d(back_z_mesh, back_sizing, oned_shape, out_z_meshes(1, column)) + ! work out the position of the intersection of the column with the old face + intersection_pos = face_eval_field(old_face, full_positions, full_positions%dim, local_coords) + call set(back_z_mesh, i, (/intersection_pos/)) + ! work out the value of the dim, dim component of the full_metric at the intersection point + ! NOTE WELL: this is where we assume that up is in the vertical direction (i.e. not + ! safe on the sphere but that's not supported yet anyway and this is assumed in + ! lots of places) + intersection_metric_comp = face_eval_field(old_face, full_metric, full_metric%dim(1), full_metric%dim(2), local_coords) + mesh_size = edge_length_from_eigenvalue(intersection_metric_comp) + call set(back_sizing, i, mesh_size) - ! we're done with all that beautiful intersection work - call deallocate(back_z_mesh) - call deallocate(back_sizing) + ! record the current global nodes as the previous ones for the next iteration + prev_face_global_nodes = current_face_global_nodes - end do + end do - if (.not. present(map)) then - deallocate(lmap) - end if - call deallocate(columns_sparsity) - call deallocate(top_surface_nodes) - call deallocate(bottom_surface_nodes) + ! and we're done... we've worked out the intersection positions in back_z_mesh and the intersection sizing + ! function in back_sizing. + call deallocate(column_faces) - ! combine these into a full mesh - call add_nelist(h_positions_new%mesh) - call combine_z_meshes(h_positions_new, out_z_meshes, out_mesh, & - ele_shape(full_positions, 1), full_positions%mesh%name, & - trim(full_positions%mesh%option_path)) + ! now let's adapt that and put the adapted mesh in out_z_meshes(column)... + call adapt_1d(back_z_mesh, back_sizing, oned_shape, out_z_meshes(1, column)) - call deallocate(oned_shape) - do column=1,node_count(h_positions_new) - if(node_owned(h_positions_new, column)) then - call deallocate(out_z_meshes(1, column)) + ! we're done with all that beautiful intersection work + call deallocate(back_z_mesh) + call deallocate(back_sizing) + + end do + + if (.not. present(map)) then + deallocate(lmap) end if - end do - - contains - - subroutine permute_local_coords(local_coords, current_face_global_nodes, prev_face_global_nodes) - real, dimension(:), intent(inout) :: local_coords - integer, dimension(:), intent(in) :: current_face_global_nodes - integer, dimension(:), intent(in) :: prev_face_global_nodes - - integer :: g1, g2, missing_ind - integer, dimension(size(current_face_global_nodes)) :: permutation, notfound - - assert(size(current_face_global_nodes)==size(prev_face_global_nodes)) - assert(size(current_face_global_nodes)==size(local_coords)) - - ! because the local face numbers may have shifted between one face and the next - ! it is necessary to work out a permutation for the local coords to be valid - permutation = -1 - notfound = 1 - do g1 = 1, size(prev_face_global_nodes) - do g2 = 1, size(current_face_global_nodes) - if(prev_face_global_nodes(g1)==current_face_global_nodes(g2)) then - permutation(g2) = g1 - notfound(g2) = 0 - exit - end if - end do - if(g2==size(prev_face_global_nodes)+1) then - missing_ind = g1 - end if + call deallocate(columns_sparsity) + call deallocate(top_surface_nodes) + call deallocate(bottom_surface_nodes) + + ! combine these into a full mesh + call add_nelist(h_positions_new%mesh) + call combine_z_meshes(h_positions_new, out_z_meshes, out_mesh, & + ele_shape(full_positions, 1), full_positions%mesh%name, & + trim(full_positions%mesh%option_path)) + + call deallocate(oned_shape) + do column=1,node_count(h_positions_new) + if(node_owned(h_positions_new, column)) then + call deallocate(out_z_meshes(1, column)) + end if end do - assert(sum(notfound)==1) ! debugging check that only one position hasn't been found - permutation(minloc(permutation)) = missing_ind - assert(all(permutation>0)) - - ! now permute the local coordinates so that the local node ordering is - ! correct - call apply_permutation(local_coords, permutation) - - end subroutine permute_local_coords - - end subroutine metric_based_extrude - - subroutine get_1d_mesh(column, back_mesh, back_columns, metric, oned_shape, z_mesh, & - sizing) - integer, intent(in) :: column - type(vector_field), intent(in) :: back_mesh - type(csr_sparsity), intent(in) :: back_columns - type(tensor_field), intent(in) :: metric - type(element_type), intent(inout) :: oned_shape - type(vector_field), intent(out) :: z_mesh - type(scalar_field), intent(out), optional :: sizing - - type(mesh_type) :: mesh - - integer :: nodes, elements - integer, dimension(:), pointer :: column_nodes - integer :: i, j - integer :: dim - integer, parameter :: loc=2 - - real, dimension(mesh_dim(back_mesh)) :: normal - real :: mesh_size - - nodes = row_length(back_columns, column) - elements = nodes - 1 - dim = mesh_dim(back_mesh) - column_nodes => row_m_ptr(back_columns, column) - - call allocate(mesh, nodes, elements, oned_shape, "Mesh") - do i=1,elements - mesh%ndglno((i-1) * loc + 1: i*loc) = (/i, i+1/) - end do - - call allocate(z_mesh, 1, mesh, "ZMesh") - if(present(sizing)) then - call allocate(sizing, mesh, "SizingFunction") - end if - call deallocate(mesh) - - ! normal here should be made smarter if this is on the globe. - normal = 0.0 - normal(dim) = 1.0 - - do i=1,nodes - j = column_nodes(i) - call set(z_mesh, i, (/node_val(back_mesh, dim, j)/)) + contains + + subroutine permute_local_coords(local_coords, current_face_global_nodes, prev_face_global_nodes) + real, dimension(:), intent(inout) :: local_coords + integer, dimension(:), intent(in) :: current_face_global_nodes + integer, dimension(:), intent(in) :: prev_face_global_nodes + + integer :: g1, g2, missing_ind + integer, dimension(size(current_face_global_nodes)) :: permutation, notfound + + assert(size(current_face_global_nodes)==size(prev_face_global_nodes)) + assert(size(current_face_global_nodes)==size(local_coords)) + + ! because the local face numbers may have shifted between one face and the next + ! it is necessary to work out a permutation for the local coords to be valid + permutation = -1 + notfound = 1 + do g1 = 1, size(prev_face_global_nodes) + do g2 = 1, size(current_face_global_nodes) + if(prev_face_global_nodes(g1)==current_face_global_nodes(g2)) then + permutation(g2) = g1 + notfound(g2) = 0 + exit + end if + end do + if(g2==size(prev_face_global_nodes)+1) then + missing_ind = g1 + end if + end do + assert(sum(notfound)==1) ! debugging check that only one position hasn't been found + permutation(minloc(permutation)) = missing_ind + assert(all(permutation>0)) + + ! now permute the local coordinates so that the local node ordering is + ! correct + call apply_permutation(local_coords, permutation) + + end subroutine permute_local_coords + + end subroutine metric_based_extrude + + subroutine get_1d_mesh(column, back_mesh, back_columns, metric, oned_shape, z_mesh, & + sizing) + integer, intent(in) :: column + type(vector_field), intent(in) :: back_mesh + type(csr_sparsity), intent(in) :: back_columns + type(tensor_field), intent(in) :: metric + type(element_type), intent(inout) :: oned_shape + type(vector_field), intent(out) :: z_mesh + type(scalar_field), intent(out), optional :: sizing + + type(mesh_type) :: mesh + + integer :: nodes, elements + integer, dimension(:), pointer :: column_nodes + integer :: i, j + integer :: dim + integer, parameter :: loc=2 + + real, dimension(mesh_dim(back_mesh)) :: normal + real :: mesh_size + + nodes = row_length(back_columns, column) + elements = nodes - 1 + dim = mesh_dim(back_mesh) + column_nodes => row_m_ptr(back_columns, column) + + call allocate(mesh, nodes, elements, oned_shape, "Mesh") + do i=1,elements + mesh%ndglno((i-1) * loc + 1: i*loc) = (/i, i+1/) + end do + + call allocate(z_mesh, 1, mesh, "ZMesh") if(present(sizing)) then - mesh_size = edge_length_from_eigenvalue(dot_product(matmul(normal, node_val(metric, j)), normal)) - call set(sizing, i, mesh_size) + call allocate(sizing, mesh, "SizingFunction") end if - end do + call deallocate(mesh) - end subroutine get_1d_mesh + ! normal here should be made smarter if this is on the globe. + normal = 0.0 + normal(dim) = 1.0 - subroutine get_1d_sizing(metric, sizing) - ! this is a full dimensional metric defined on a 1d mesh - type(tensor_field), intent(inout) :: metric - ! and we want to get the sizing based on the vertical component of the metric - type(scalar_field), intent(out) :: sizing + do i=1,nodes + j = column_nodes(i) + call set(z_mesh, i, (/node_val(back_mesh, dim, j)/)) + + if(present(sizing)) then + mesh_size = edge_length_from_eigenvalue(dot_product(matmul(normal, node_val(metric, j)), normal)) + call set(sizing, i, mesh_size) + end if + end do + + end subroutine get_1d_mesh - real, dimension(metric%dim(1)) :: normal - real :: mesh_size - integer :: node + subroutine get_1d_sizing(metric, sizing) + ! this is a full dimensional metric defined on a 1d mesh + type(tensor_field), intent(inout) :: metric + ! and we want to get the sizing based on the vertical component of the metric + type(scalar_field), intent(out) :: sizing - call allocate(sizing, metric%mesh, "Back1DSizingFunction") + real, dimension(metric%dim(1)) :: normal + real :: mesh_size + integer :: node + + call allocate(sizing, metric%mesh, "Back1DSizingFunction") + + ! normal here should be made smarter if this is on the globe. + normal = 0.0 + normal(metric%dim(1)) = 1.0 + + do node=1,node_count(sizing) + mesh_size = edge_length_from_eigenvalue(dot_product(matmul(normal, node_val(metric, node)), normal)) + call set(sizing, node, mesh_size) + end do - ! normal here should be made smarter if this is on the globe. - normal = 0.0 - normal(metric%dim(1)) = 1.0 + end subroutine get_1d_sizing - do node=1,node_count(sizing) - mesh_size = edge_length_from_eigenvalue(dot_product(matmul(normal, node_val(metric, node)), normal)) - call set(sizing, node, mesh_size) - end do + subroutine get_1d_tensor(column, back_tensor, oned_tensor, back_columns) + integer, intent(in) :: column + type(tensor_field), intent(in) :: back_tensor + type(tensor_field), intent(inout) :: oned_tensor + type(csr_sparsity), intent(in) :: back_columns - end subroutine get_1d_sizing + integer :: nodes + integer, dimension(:), pointer :: column_nodes + integer :: i, j + integer :: dim - subroutine get_1d_tensor(column, back_tensor, oned_tensor, back_columns) - integer, intent(in) :: column - type(tensor_field), intent(in) :: back_tensor - type(tensor_field), intent(inout) :: oned_tensor - type(csr_sparsity), intent(in) :: back_columns + real, dimension(mesh_dim(back_tensor)) :: normal + real :: oned_value - integer :: nodes - integer, dimension(:), pointer :: column_nodes - integer :: i, j - integer :: dim + ! normal here should be made smarter if this is on the globe. + dim = mesh_dim(back_tensor) + normal = 0.0 + normal(dim) = 1.0 - real, dimension(mesh_dim(back_tensor)) :: normal - real :: oned_value + if(back_tensor%field_type==FIELD_TYPE_CONSTANT) then - ! normal here should be made smarter if this is on the globe. - dim = mesh_dim(back_tensor) - normal = 0.0 - normal(dim) = 1.0 + oned_value = dot_product(matmul(normal, node_val(back_tensor, 1)), normal) + call set(oned_tensor, spread(spread(oned_value, 1, oned_tensor%dim(1)), 2, oned_tensor%dim(1))) - if(back_tensor%field_type==FIELD_TYPE_CONSTANT) then + else - oned_value = dot_product(matmul(normal, node_val(back_tensor, 1)), normal) - call set(oned_tensor, spread(spread(oned_value, 1, oned_tensor%dim(1)), 2, oned_tensor%dim(1))) + nodes = row_length(back_columns, column) + column_nodes => row_m_ptr(back_columns, column) - else + do i=1,nodes + j = column_nodes(i) + + oned_value = dot_product(matmul(normal, node_val(back_tensor, j)), normal) + call set(oned_tensor, i, spread(spread(oned_value, 1, oned_tensor%dim(1)), 2, oned_tensor%dim(1))) + end do + + end if + + end subroutine get_1d_tensor + + subroutine recombine_metric(metric, column, oned_metric, back_columns) + type(tensor_field), intent(inout) :: metric + integer, intent(in) :: column + type(tensor_field), intent(in) :: oned_metric + type(csr_sparsity), intent(in) :: back_columns + + integer :: nodes + integer, dimension(:), pointer :: column_nodes + integer :: i, j + real, dimension(1, 1) :: oned_val nodes = row_length(back_columns, column) column_nodes => row_m_ptr(back_columns, column) - do i=1,nodes - j = column_nodes(i) + ! NOTE WELL: just as in get_1d_mesh, we're about to assume that the + ! 1d metric belongs in the last entry of the full metric! + ! We should be cleverer than this (i.e. on a sphere). + do i = 1, nodes + j = column_nodes(i) - oned_value = dot_product(matmul(normal, node_val(back_tensor, j)), normal) - call set(oned_tensor, i, spread(spread(oned_value, 1, oned_tensor%dim(1)), 2, oned_tensor%dim(1))) + oned_val = node_val(oned_metric, i) + call set(metric, metric%dim(1), metric%dim(2), j, oned_val(1,1)) end do - end if - - end subroutine get_1d_tensor - - subroutine recombine_metric(metric, column, oned_metric, back_columns) - type(tensor_field), intent(inout) :: metric - integer, intent(in) :: column - type(tensor_field), intent(in) :: oned_metric - type(csr_sparsity), intent(in) :: back_columns - - integer :: nodes - integer, dimension(:), pointer :: column_nodes - integer :: i, j - real, dimension(1, 1) :: oned_val - - nodes = row_length(back_columns, column) - column_nodes => row_m_ptr(back_columns, column) - - ! NOTE WELL: just as in get_1d_mesh, we're about to assume that the - ! 1d metric belongs in the last entry of the full metric! - ! We should be cleverer than this (i.e. on a sphere). - do i = 1, nodes - j = column_nodes(i) - - oned_val = node_val(oned_metric, i) - call set(metric, metric%dim(1), metric%dim(2), j, oned_val(1,1)) - end do - - end subroutine recombine_metric - - function get_expected_elements(z_mesh, sizing) result(elements) - type(vector_field), intent(inout) :: z_mesh - type(scalar_field), intent(in) :: sizing - - type(scalar_field) :: sizing_inverse - integer :: elements - - call allocate(sizing_inverse, z_mesh%mesh, trim(sizing%name) // "Inverse") - call invert(sizing, sizing_inverse) - elements = field_integral(sizing_inverse, z_mesh) - call deallocate(sizing_inverse) - assert(elements > 0) - end function get_expected_elements - - subroutine adapt_1d(back_mesh, sizing, oned_shape, z_mesh, preserve_regions) - type(vector_field), intent(in) :: back_mesh - type(scalar_field), intent(in) :: sizing - type(vector_field), intent(inout) :: z_mesh - type(element_type), intent(inout) :: oned_shape - logical, intent(in), optional :: preserve_regions - - integer :: elements - integer :: node - - type(mesh_type) :: mesh - - real, dimension(:), allocatable :: metric_step_length - real, dimension(element_count(back_mesh)) :: desired_ele_lengths - real, dimension(element_count(back_mesh)) :: metric_ele_lengths - integer :: old_node_counter, new_node_counter - real :: old_metric_back, old_metric_front, new_metric_back, new_metric_front - real :: new_node_position, real_step_length - - logical :: l_preserve_regions - integer, dimension(:), allocatable :: nodes_per_region, tmp_region_bdy_nodes, region_bdy_nodes - integer, dimension(:), allocatable :: tmp_region_ids, region_ids - integer :: ele, ele_2, ni, no_region_bdys, face, region_bdy - integer :: total_nodes, tmp_size - integer, dimension(:), pointer :: neigh - integer, dimension(1) :: node_array - - l_preserve_regions = present_and_true(preserve_regions) - - ! don't make the decision to preserve regions based on - ! the options tree because then it would happen during - ! mesh extrusion as well as 1d adaptivity, which would - ! be a wasted effort (also region ids might not be available) - if(l_preserve_regions) then - assert(associated(back_mesh%mesh%region_ids)) - - ! let's hope the region ids don't go too high! - ! needs to have a minimum length of 2 (for both of the ends) - ! but we're probably going to overestimate the size here - ! (especially as we're catering for the possibility of negative - ! region ids which may not even be possible!) - tmp_size = abs(minval(back_mesh%mesh%region_ids)) + & - abs(maxval(back_mesh%mesh%region_ids)) + 2 - allocate(tmp_region_bdy_nodes(tmp_size)) - tmp_region_bdy_nodes = 0 - - allocate(tmp_region_ids(tmp_size)) - tmp_region_ids = -1 - - ! find the depths of the boundaries between region ids - no_region_bdys = 0 - do ele = 1, ele_count(back_mesh) - neigh => ele_neigh(back_mesh, ele) - do ni = 1, size(neigh) - ele_2 = neigh(ni) - if (ele_2>0) then - ! Internal faces only. - if(back_mesh%mesh%region_ids(ele)/=back_mesh%mesh%region_ids(ele_2)) then - face=ele_face(back_mesh, ele, ele_2) - node_array=face_global_nodes(back_mesh, face) - if(.not.(any(node_array(1)==tmp_region_bdy_nodes))) then - ! only include this node if we haven't visited it from - ! another element - no_region_bdys = no_region_bdys + 1 - tmp_region_bdy_nodes(no_region_bdys) = node_array(1) ! remember if we've visited this node - - ! always take the region_id from the region higher up - if((0.5*sum(ele_val(back_mesh, 1, ele)))>(0.5*sum(ele_val(back_mesh, 1, ele_2)))) then + end subroutine recombine_metric + + function get_expected_elements(z_mesh, sizing) result(elements) + type(vector_field), intent(inout) :: z_mesh + type(scalar_field), intent(in) :: sizing + + type(scalar_field) :: sizing_inverse + integer :: elements + + call allocate(sizing_inverse, z_mesh%mesh, trim(sizing%name) // "Inverse") + call invert(sizing, sizing_inverse) + elements = field_integral(sizing_inverse, z_mesh) + call deallocate(sizing_inverse) + assert(elements > 0) + end function get_expected_elements + + subroutine adapt_1d(back_mesh, sizing, oned_shape, z_mesh, preserve_regions) + type(vector_field), intent(in) :: back_mesh + type(scalar_field), intent(in) :: sizing + type(vector_field), intent(inout) :: z_mesh + type(element_type), intent(inout) :: oned_shape + logical, intent(in), optional :: preserve_regions + + integer :: elements + integer :: node + + type(mesh_type) :: mesh + + real, dimension(:), allocatable :: metric_step_length + real, dimension(element_count(back_mesh)) :: desired_ele_lengths + real, dimension(element_count(back_mesh)) :: metric_ele_lengths + integer :: old_node_counter, new_node_counter + real :: old_metric_back, old_metric_front, new_metric_back, new_metric_front + real :: new_node_position, real_step_length + + logical :: l_preserve_regions + integer, dimension(:), allocatable :: nodes_per_region, tmp_region_bdy_nodes, region_bdy_nodes + integer, dimension(:), allocatable :: tmp_region_ids, region_ids + integer :: ele, ele_2, ni, no_region_bdys, face, region_bdy + integer :: total_nodes, tmp_size + integer, dimension(:), pointer :: neigh + integer, dimension(1) :: node_array + + l_preserve_regions = present_and_true(preserve_regions) + + ! don't make the decision to preserve regions based on + ! the options tree because then it would happen during + ! mesh extrusion as well as 1d adaptivity, which would + ! be a wasted effort (also region ids might not be available) + if(l_preserve_regions) then + assert(associated(back_mesh%mesh%region_ids)) + + ! let's hope the region ids don't go too high! + ! needs to have a minimum length of 2 (for both of the ends) + ! but we're probably going to overestimate the size here + ! (especially as we're catering for the possibility of negative + ! region ids which may not even be possible!) + tmp_size = abs(minval(back_mesh%mesh%region_ids)) + & + abs(maxval(back_mesh%mesh%region_ids)) + 2 + allocate(tmp_region_bdy_nodes(tmp_size)) + tmp_region_bdy_nodes = 0 + + allocate(tmp_region_ids(tmp_size)) + tmp_region_ids = -1 + + ! find the depths of the boundaries between region ids + no_region_bdys = 0 + do ele = 1, ele_count(back_mesh) + neigh => ele_neigh(back_mesh, ele) + do ni = 1, size(neigh) + ele_2 = neigh(ni) + if (ele_2>0) then + ! Internal faces only. + if(back_mesh%mesh%region_ids(ele)/=back_mesh%mesh%region_ids(ele_2)) then + face=ele_face(back_mesh, ele, ele_2) + node_array=face_global_nodes(back_mesh, face) + if(.not.(any(node_array(1)==tmp_region_bdy_nodes))) then + ! only include this node if we haven't visited it from + ! another element + no_region_bdys = no_region_bdys + 1 + tmp_region_bdy_nodes(no_region_bdys) = node_array(1) ! remember if we've visited this node + + ! always take the region_id from the region higher up + if((0.5*sum(ele_val(back_mesh, 1, ele)))>(0.5*sum(ele_val(back_mesh, 1, ele_2)))) then + tmp_region_ids(no_region_bdys) = back_mesh%mesh%region_ids(ele) + else + tmp_region_ids(no_region_bdys) = back_mesh%mesh%region_ids(ele_2) + end if + + end if + end if + else + ! External faces get added too but they're easier - they definitely get counted as region_bdys + face = ele_face(back_mesh, ele, ele_2) + node_array=face_global_nodes(back_mesh, face) + ! should be no need to check if we've visited this face already + no_region_bdys = no_region_bdys + 1 + tmp_region_bdy_nodes(no_region_bdys) = node_array(1) tmp_region_ids(no_region_bdys) = back_mesh%mesh%region_ids(ele) - else - tmp_region_ids(no_region_bdys) = back_mesh%mesh%region_ids(ele_2) - end if - - end if + end if + end do + end do + + ! check the region bdys have been found at the ends of the domain + ! (this uses the assumption that the back_mesh is coordinate ordered) + assert(maxval(tmp_region_bdy_nodes)==node_count(back_mesh)) + assert(no_region_bdys>1) + + ! take off 1 region bdy for the first node + no_region_bdys = no_region_bdys - 1 + + allocate(region_bdy_nodes(0:no_region_bdys)) + region_bdy_nodes = 0 + region_bdy_nodes(0) = 1 ! include the first node + + ! there's a region id for every bdy except the first node (index 0 in region_bdy_nodes) + ! these ids correspond to the region_id from the region higher up than the boundary + ! (i.e. we ditch a region_id from tmp_region_ids from the top node) + allocate(region_ids(no_region_bdys)) + region_ids = -1 + + ! sort the region bdy nodes into increasing order (corresponds to decreasing depth order) + do region_bdy = no_region_bdys, 1, -1 + node_array = maxloc(tmp_region_bdy_nodes) + if(tmp_region_bdy_nodes(node_array(1))>0) then + region_bdy_nodes(region_bdy) = tmp_region_bdy_nodes(node_array(1)) + tmp_region_bdy_nodes(node_array(1)) = 0 ! blank it so we don't find it again + ! assign the region id to this boundary from the region higher up + region_ids(region_bdy) = tmp_region_ids(node_array(1)) end if - else - ! External faces get added too but they're easier - they definitely get counted as region_bdys - face = ele_face(back_mesh, ele, ele_2) - node_array=face_global_nodes(back_mesh, face) - ! should be no need to check if we've visited this face already - no_region_bdys = no_region_bdys + 1 - tmp_region_bdy_nodes(no_region_bdys) = node_array(1) - tmp_region_ids(no_region_bdys) = back_mesh%mesh%region_ids(ele) - end if - end do - end do - - ! check the region bdys have been found at the ends of the domain - ! (this uses the assumption that the back_mesh is coordinate ordered) - assert(maxval(tmp_region_bdy_nodes)==node_count(back_mesh)) - assert(no_region_bdys>1) - - ! take off 1 region bdy for the first node - no_region_bdys = no_region_bdys - 1 - - allocate(region_bdy_nodes(0:no_region_bdys)) - region_bdy_nodes = 0 - region_bdy_nodes(0) = 1 ! include the first node - - ! there's a region id for every bdy except the first node (index 0 in region_bdy_nodes) - ! these ids correspond to the region_id from the region higher up than the boundary - ! (i.e. we ditch a region_id from tmp_region_ids from the top node) - allocate(region_ids(no_region_bdys)) - region_ids = -1 - - ! sort the region bdy nodes into increasing order (corresponds to decreasing depth order) - do region_bdy = no_region_bdys, 1, -1 - node_array = maxloc(tmp_region_bdy_nodes) - if(tmp_region_bdy_nodes(node_array(1))>0) then - region_bdy_nodes(region_bdy) = tmp_region_bdy_nodes(node_array(1)) - tmp_region_bdy_nodes(node_array(1)) = 0 ! blank it so we don't find it again - ! assign the region id to this boundary from the region higher up - region_ids(region_bdy) = tmp_region_ids(node_array(1)) - end if - end do - ! check the region bdys have been found at the ends of the domain - ! (this uses the assumption that the back_mesh is coordinate ordered) - assert(maxval(tmp_region_bdy_nodes)==1) ! should only be the first node remaining (everything else should be 0) - assert(maxval(region_bdy_nodes)==node_count(back_mesh)) - assert(minval(region_bdy_nodes)==1) - assert(all(region_bdy_nodes>0)) - assert(all(region_ids>=0)) - - deallocate(tmp_region_bdy_nodes) - deallocate(tmp_region_ids) - - ewrite(2,*) 'in adapt_1d' - ewrite(2,*) 'no_region_bdys = ', no_region_bdys - ewrite(2,*) 'region_bdy_nodes = ', region_bdy_nodes - ewrite(2,*) 'region_ids = ', region_ids - - else - no_region_bdys = 1 - allocate(region_bdy_nodes(0:no_region_bdys)) - region_bdy_nodes(0) = 1 ! include the first node - region_bdy_nodes(no_region_bdys) = node_count(back_mesh) ! include the last node - end if - - ! First we need to see how many nodes we will have. - ! I do this by basically doing the work twice. - ! You could be more clever and record the steps and positions, - ! but I don't have dynamically-sized arrays :-( - - allocate(nodes_per_region(0:no_region_bdys)) - nodes_per_region = 0 - - ! the first node - nodes_per_region(0) = 1 - - allocate(metric_step_length(no_region_bdys)) - metric_step_length = 1.0 - - do region_bdy = 1, no_region_bdys - do node = region_bdy_nodes(region_bdy-1), region_bdy_nodes(region_bdy)-1 - ! project the sizing function to an array over the old elements - desired_ele_lengths(node) = 0.5*(node_val(sizing, node)+node_val(sizing, node+1)) - ! translate the current element lengths into metric space by dividing by the desired elemental length - metric_ele_lengths(node) = (abs(node_val(back_mesh, 1, node)-node_val(back_mesh, 1, node+1))) & - /desired_ele_lengths(node) - end do - ! work out the number of nodes in this region by summing the metric lengths (then rounding up to ensure an integer value) - nodes_per_region(region_bdy) = ceiling(sum(metric_ele_lengths(region_bdy_nodes(region_bdy-1):(region_bdy_nodes(region_bdy)-1)))) - ! work out the step length in metric space (ideal is 1 but this will be less than that due to rounding up on previous line) - metric_step_length(region_bdy) = (sum(metric_ele_lengths(region_bdy_nodes(region_bdy-1):(region_bdy_nodes(region_bdy)-1)))) & - /nodes_per_region(region_bdy) - end do - - total_nodes = sum(nodes_per_region) - elements = total_nodes - 1 - call allocate(mesh, total_nodes, elements, oned_shape, "Mesh") - if(l_preserve_regions) then - allocate(mesh%region_ids(elements)) - mesh%region_ids = 0 - end if - call allocate(z_mesh, 1, mesh, "AdaptedZMesh") - call set(z_mesh, (/huge(0.0)/)) ! a bug catcher - call deallocate(mesh) - - call set(z_mesh, region_bdy_nodes(0), node_val(back_mesh, 1, region_bdy_nodes(0))) - - do region_bdy = 1, no_region_bdys - ! the node at the start of this region in the old mesh - old_node_counter = region_bdy_nodes(region_bdy-1) - ! the front and back positions of the next old element - ! (in metric space and relative to the start of this region) - old_metric_back = 0.0 - old_metric_front = metric_ele_lengths(old_node_counter) - - ! the node at the start of this region in the new mesh - new_node_counter = sum(nodes_per_region(0:region_bdy-1)) - - ! the last new node position (in real space at the start of this region) - new_node_position = node_val(back_mesh, 1, old_node_counter) - - ! the front and back positions of the next new element - ! (in metric space and relative to the start of this region) - new_metric_back = 0.0 - new_metric_front = metric_step_length(region_bdy) - - do node = 1, nodes_per_region(region_bdy)-1 - new_node_counter = new_node_counter + 1 - - real_step_length = 0.0 - - if(l_preserve_regions) then - ! here we assume that the elements are also ordered - ! this subroutine doesn't take care of the node to element list - ! so anything that does will have to reorder the region_id list as - ! well if it doesn't have the same assumption - z_mesh%mesh%region_ids(new_node_counter-1) = region_ids(region_bdy) - end if - - do while (old_metric_front < new_metric_front) - ! add an increment of real space to the position - ! (this equals the desired edge length times the metric step length) - if((old_metric_front-old_metric_back)>(old_metric_front-new_metric_back)) then - ! in this case the new element straddles an element boundary in the old mesh - real_step_length = real_step_length + & - desired_ele_lengths(old_node_counter)*(old_metric_front-new_metric_back) - else - ! in this case the old element falls entirely within an element of the new mesh - real_step_length = real_step_length + & - desired_ele_lengths(old_node_counter)*(old_metric_front-old_metric_back) - end if - - ! move the back of the old element to the current position of the front - old_metric_back = old_metric_front - ! and then move the front on to the next element (i.e. step through the old elements) - old_node_counter = old_node_counter + 1 - old_metric_front = old_metric_front + metric_ele_lengths(old_node_counter) - end do - - ! so now the old_metric_front is ahead of the new_metric_front, we need to know by how much - ! so we can add in that contribution to the new element edge length - if((new_metric_front-new_metric_back)>(new_metric_front-old_metric_back)) then - ! in this case the new element straddles an element boundary in the old mesh - real_step_length = real_step_length + & - desired_ele_lengths(old_node_counter)*(new_metric_front-old_metric_back) - else - ! in this case the new element falls entirely within an old element - real_step_length = real_step_length + & - desired_ele_lengths(old_node_counter)*(new_metric_front-new_metric_back) - end if - - new_node_position = new_node_position - real_step_length - - call set(z_mesh, new_node_counter, (/new_node_position/)) - - new_metric_back = new_metric_front - new_metric_front = new_metric_front+metric_step_length(region_bdy) + end do + ! check the region bdys have been found at the ends of the domain + ! (this uses the assumption that the back_mesh is coordinate ordered) + assert(maxval(tmp_region_bdy_nodes)==1) ! should only be the first node remaining (everything else should be 0) + assert(maxval(region_bdy_nodes)==node_count(back_mesh)) + assert(minval(region_bdy_nodes)==1) + assert(all(region_bdy_nodes>0)) + assert(all(region_ids>=0)) + + deallocate(tmp_region_bdy_nodes) + deallocate(tmp_region_ids) + + ewrite(2,*) 'in adapt_1d' + ewrite(2,*) 'no_region_bdys = ', no_region_bdys + ewrite(2,*) 'region_bdy_nodes = ', region_bdy_nodes + ewrite(2,*) 'region_ids = ', region_ids + + else + no_region_bdys = 1 + allocate(region_bdy_nodes(0:no_region_bdys)) + region_bdy_nodes(0) = 1 ! include the first node + region_bdy_nodes(no_region_bdys) = node_count(back_mesh) ! include the last node + end if + ! First we need to see how many nodes we will have. + ! I do this by basically doing the work twice. + ! You could be more clever and record the steps and positions, + ! but I don't have dynamically-sized arrays :-( + + allocate(nodes_per_region(0:no_region_bdys)) + nodes_per_region = 0 + + ! the first node + nodes_per_region(0) = 1 + + allocate(metric_step_length(no_region_bdys)) + metric_step_length = 1.0 + + do region_bdy = 1, no_region_bdys + do node = region_bdy_nodes(region_bdy-1), region_bdy_nodes(region_bdy)-1 + ! project the sizing function to an array over the old elements + desired_ele_lengths(node) = 0.5*(node_val(sizing, node)+node_val(sizing, node+1)) + ! translate the current element lengths into metric space by dividing by the desired elemental length + metric_ele_lengths(node) = (abs(node_val(back_mesh, 1, node)-node_val(back_mesh, 1, node+1))) & + /desired_ele_lengths(node) + end do + ! work out the number of nodes in this region by summing the metric lengths (then rounding up to ensure an integer value) + nodes_per_region(region_bdy) = ceiling(sum(metric_ele_lengths(region_bdy_nodes(region_bdy-1):(region_bdy_nodes(region_bdy)-1)))) + ! work out the step length in metric space (ideal is 1 but this will be less than that due to rounding up on previous line) + metric_step_length(region_bdy) = (sum(metric_ele_lengths(region_bdy_nodes(region_bdy-1):(region_bdy_nodes(region_bdy)-1)))) & + /nodes_per_region(region_bdy) end do - ! include the bottom node in this depth (but not the top node) - new_node_counter = new_node_counter + 1 - call set(z_mesh, new_node_counter, (/node_val(back_mesh, 1, region_bdy_nodes(region_bdy))/)) + total_nodes = sum(nodes_per_region) + elements = total_nodes - 1 + call allocate(mesh, total_nodes, elements, oned_shape, "Mesh") if(l_preserve_regions) then - ! here we assume that the elements are also ordered - ! this subroutine doesn't take care of the node to element list - ! so anything that does will have to reorder the region_id list as - ! well if it doesn't have the same assumption - z_mesh%mesh%region_ids(new_node_counter-1) = region_ids(region_bdy) + allocate(mesh%region_ids(elements)) + mesh%region_ids = 0 end if + call allocate(z_mesh, 1, mesh, "AdaptedZMesh") + call set(z_mesh, (/huge(0.0)/)) ! a bug catcher + call deallocate(mesh) + + call set(z_mesh, region_bdy_nodes(0), node_val(back_mesh, 1, region_bdy_nodes(0))) + + do region_bdy = 1, no_region_bdys + ! the node at the start of this region in the old mesh + old_node_counter = region_bdy_nodes(region_bdy-1) + ! the front and back positions of the next old element + ! (in metric space and relative to the start of this region) + old_metric_back = 0.0 + old_metric_front = metric_ele_lengths(old_node_counter) - end do + ! the node at the start of this region in the new mesh + new_node_counter = sum(nodes_per_region(0:region_bdy-1)) - if(l_preserve_regions) then - ewrite_minmax(z_mesh) - ewrite_minmax(z_mesh%mesh%region_ids) - end if + ! the last new node position (in real space at the start of this region) + new_node_position = node_val(back_mesh, 1, old_node_counter) + + ! the front and back positions of the next new element + ! (in metric space and relative to the start of this region) + new_metric_back = 0.0 + new_metric_front = metric_step_length(region_bdy) + + do node = 1, nodes_per_region(region_bdy)-1 + new_node_counter = new_node_counter + 1 + + real_step_length = 0.0 + + if(l_preserve_regions) then + ! here we assume that the elements are also ordered + ! this subroutine doesn't take care of the node to element list + ! so anything that does will have to reorder the region_id list as + ! well if it doesn't have the same assumption + z_mesh%mesh%region_ids(new_node_counter-1) = region_ids(region_bdy) + end if + + do while (old_metric_front < new_metric_front) + ! add an increment of real space to the position + ! (this equals the desired edge length times the metric step length) + if((old_metric_front-old_metric_back)>(old_metric_front-new_metric_back)) then + ! in this case the new element straddles an element boundary in the old mesh + real_step_length = real_step_length + & + desired_ele_lengths(old_node_counter)*(old_metric_front-new_metric_back) + else + ! in this case the old element falls entirely within an element of the new mesh + real_step_length = real_step_length + & + desired_ele_lengths(old_node_counter)*(old_metric_front-old_metric_back) + end if + + ! move the back of the old element to the current position of the front + old_metric_back = old_metric_front + ! and then move the front on to the next element (i.e. step through the old elements) + old_node_counter = old_node_counter + 1 + old_metric_front = old_metric_front + metric_ele_lengths(old_node_counter) + end do + + ! so now the old_metric_front is ahead of the new_metric_front, we need to know by how much + ! so we can add in that contribution to the new element edge length + if((new_metric_front-new_metric_back)>(new_metric_front-old_metric_back)) then + ! in this case the new element straddles an element boundary in the old mesh + real_step_length = real_step_length + & + desired_ele_lengths(old_node_counter)*(new_metric_front-old_metric_back) + else + ! in this case the new element falls entirely within an old element + real_step_length = real_step_length + & + desired_ele_lengths(old_node_counter)*(new_metric_front-new_metric_back) + end if + + new_node_position = new_node_position - real_step_length + + call set(z_mesh, new_node_counter, (/new_node_position/)) + + new_metric_back = new_metric_front + new_metric_front = new_metric_front+metric_step_length(region_bdy) + + end do + + ! include the bottom node in this depth (but not the top node) + new_node_counter = new_node_counter + 1 + call set(z_mesh, new_node_counter, (/node_val(back_mesh, 1, region_bdy_nodes(region_bdy))/)) + if(l_preserve_regions) then + ! here we assume that the elements are also ordered + ! this subroutine doesn't take care of the node to element list + ! so anything that does will have to reorder the region_id list as + ! well if it doesn't have the same assumption + z_mesh%mesh%region_ids(new_node_counter-1) = region_ids(region_bdy) + end if + + end do + + if(l_preserve_regions) then + ewrite_minmax(z_mesh) + ewrite_minmax(z_mesh%mesh%region_ids) + end if - end subroutine adapt_1d + end subroutine adapt_1d end module hadapt_metric_based_extrude diff --git a/horizontal_adaptivity/tests/test_compute_z_nodes.F90 b/horizontal_adaptivity/tests/test_compute_z_nodes.F90 index ca4658ed8c..5bcfc8abfc 100644 --- a/horizontal_adaptivity/tests/test_compute_z_nodes.F90 +++ b/horizontal_adaptivity/tests/test_compute_z_nodes.F90 @@ -1,28 +1,28 @@ subroutine test_compute_z_nodes - use hadapt_extrude - use fields - use spud - use unittest_tools - use vtk_interfaces - implicit none + use hadapt_extrude + use fields + use spud + use unittest_tools + use vtk_interfaces + implicit none - type(vector_field) :: z_mesh - real :: top_depth - integer :: stat - logical :: fail + type(vector_field) :: z_mesh + real :: top_depth + integer :: stat + logical :: fail - call set_option("/geometry/quadrature/degree", 4, stat=stat) + call set_option("/geometry/quadrature/degree", 4, stat=stat) - top_depth = 0.0 - call compute_z_nodes(z_mesh, 1.0, (/ 0.0 /), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=0.1) + top_depth = 0.0 + call compute_z_nodes(z_mesh, 1.0, (/ 0.0 /), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=0.1) - fail = ele_count(z_mesh) /= 10 - call report_test("[compute_z_mesh: ele_count]", fail, .false., "Should be 10") - fail = node_count(z_mesh) /= 11 - call report_test("[compute_z_mesh: node_count]", fail, .false., "Should be 11") - fail = abs(top_depth-1.0)>1e-9 - call report_test("[compute_z_mesh: top_depth]", fail, .false., "Should be 1.0") + fail = ele_count(z_mesh) /= 10 + call report_test("[compute_z_mesh: ele_count]", fail, .false., "Should be 10") + fail = node_count(z_mesh) /= 11 + call report_test("[compute_z_mesh: node_count]", fail, .false., "Should be 11") + fail = abs(top_depth-1.0)>1e-9 + call report_test("[compute_z_mesh: top_depth]", fail, .false., "Should be 1.0") - call vtk_write_fields("data/z_mesh", 0, z_mesh, z_mesh%mesh, vfields=(/z_mesh/)) + call vtk_write_fields("data/z_mesh", 0, z_mesh, z_mesh%mesh, vfields=(/z_mesh/)) end subroutine test_compute_z_nodes diff --git a/horizontal_adaptivity/tests/test_extrude.F90 b/horizontal_adaptivity/tests/test_extrude.F90 index e7b5874467..624cfd0633 100644 --- a/horizontal_adaptivity/tests/test_extrude.F90 +++ b/horizontal_adaptivity/tests/test_extrude.F90 @@ -1,31 +1,31 @@ subroutine test_extrude - use hadapt_extrude - use fields - use spud - use unittest_tools - use vtk_interfaces - use read_triangle - use write_triangle - use sparse_tools - use global_parameters - implicit none + use hadapt_extrude + use fields + use spud + use unittest_tools + use vtk_interfaces + use read_triangle + use write_triangle + use sparse_tools + use global_parameters + implicit none - character(len=OPTION_PATH_LEN):: option_PATH - integer, parameter:: QUAD_DEGREE=4 - type(vector_field) :: h_mesh, out_mesh - integer :: stat + character(len=OPTION_PATH_LEN):: option_PATH + integer, parameter:: QUAD_DEGREE=4 + type(vector_field) :: h_mesh, out_mesh + integer :: stat - call set_option("/geometry/quadrature/degree", 4, stat=stat) - call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/bottom_depth/constant", 1.0, stat=stat) - call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/sizing_function/constant", 0.1, stat=stat) - call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/bottom_surface_id", 4, stat=stat) - call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/top_surface_id", 5, stat=stat) + call set_option("/geometry/quadrature/degree", 4, stat=stat) + call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/bottom_depth/constant", 1.0, stat=stat) + call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/sizing_function/constant", 0.1, stat=stat) + call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/bottom_surface_id", 4, stat=stat) + call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/top_surface_id", 5, stat=stat) - h_mesh=read_triangle_files('data/square-2d_A', quad_degree=QUAD_DEGREE) + h_mesh=read_triangle_files('data/square-2d_A', quad_degree=QUAD_DEGREE) - option_path='/geometry/mesh::ExtrudedMesh' - call extrude(h_mesh, option_path, out_mesh) + option_path='/geometry/mesh::ExtrudedMesh' + call extrude(h_mesh, option_path, out_mesh) - call write_triangle_files('extrude', out_mesh) + call write_triangle_files('extrude', out_mesh) end subroutine test_extrude diff --git a/horizontal_adaptivity/tests/test_generate_layered_mesh_2d.F90 b/horizontal_adaptivity/tests/test_generate_layered_mesh_2d.F90 index 5468004546..b40e23624e 100644 --- a/horizontal_adaptivity/tests/test_generate_layered_mesh_2d.F90 +++ b/horizontal_adaptivity/tests/test_generate_layered_mesh_2d.F90 @@ -1,70 +1,70 @@ subroutine test_generate_layered_mesh_2d - use data_structures - use hadapt_extrude - use hadapt_advancing_front - use hadapt_metric_based_extrude - use hadapt_combine_meshes - use quadrature - use elements - use fields - use spud - use unittest_tools - use vtk_interfaces - use sparse_tools - implicit none + use data_structures + use hadapt_extrude + use hadapt_advancing_front + use hadapt_metric_based_extrude + use hadapt_combine_meshes + use quadrature + use elements + use fields + use spud + use unittest_tools + use vtk_interfaces + use sparse_tools + implicit none - type(vector_field) :: z_mesh, h_mesh - real :: top_depth - integer :: stat - logical :: fail - integer :: node + type(vector_field) :: z_mesh, h_mesh + real :: top_depth + integer :: stat + logical :: fail + integer :: node - type(integer_set), dimension(1) :: layer_nodes - type(vector_field), dimension(:,:), allocatable:: z_meshes - type(quadrature_type) :: quad - type(element_type) :: full_shape - type(vector_field) :: out_mesh + type(integer_set), dimension(1) :: layer_nodes + type(vector_field), dimension(:,:), allocatable:: z_meshes + type(quadrature_type) :: quad + type(element_type) :: full_shape + type(vector_field) :: out_mesh - call set_option("/geometry/quadrature/degree", 4, stat=stat) + call set_option("/geometry/quadrature/degree", 4, stat=stat) - top_depth = 0.0 - call compute_z_nodes(z_mesh, 1.0, (/ 0.0 /), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=0.5) - call vtk_write_fields("data/layered_mesh", 0, z_mesh, z_mesh%mesh, vfields=(/z_mesh/)) + top_depth = 0.0 + call compute_z_nodes(z_mesh, 1.0, (/ 0.0 /), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=0.5) + call vtk_write_fields("data/layered_mesh", 0, z_mesh, z_mesh%mesh, vfields=(/z_mesh/)) - fail = node_count(z_mesh) /= 3 - call report_test("[z_mesh: node_count]", fail, .false., "Should be 3") + fail = node_count(z_mesh) /= 3 + call report_test("[z_mesh: node_count]", fail, .false., "Should be 3") - allocate( z_meshes(1, 1:node_count(z_mesh)) ) + allocate( z_meshes(1, 1:node_count(z_mesh)) ) - call allocate(h_mesh, z_mesh%dim, z_mesh%mesh, "HMeshCoordinate") - do node=1,node_count(z_mesh) - call set(h_mesh, node, (/abs(node_val(z_mesh, node))/)) - z_meshes(1, node)=z_mesh - end do - call add_nelist(h_mesh%mesh) + call allocate(h_mesh, z_mesh%dim, z_mesh%mesh, "HMeshCoordinate") + do node=1,node_count(z_mesh) + call set(h_mesh, node, (/abs(node_val(z_mesh, node))/)) + z_meshes(1, node)=z_mesh + end do + call add_nelist(h_mesh%mesh) - call vtk_write_fields("data/layered_mesh", 1, h_mesh, h_mesh%mesh, vfields=(/h_mesh/)) + call vtk_write_fields("data/layered_mesh", 1, h_mesh, h_mesh%mesh, vfields=(/h_mesh/)) - ! Now the tiresome business of making a shape function. - quad = make_quadrature(vertices = 3, dim =2, degree=4) - full_shape = make_element_shape(vertices = 3, dim =2, degree=1, quad=quad) - call deallocate(quad) - call combine_z_meshes(h_mesh, z_meshes, out_mesh, & - full_shape, "Mesh", option_path="") + ! Now the tiresome business of making a shape function. + quad = make_quadrature(vertices = 3, dim =2, degree=4) + full_shape = make_element_shape(vertices = 3, dim =2, degree=1, quad=quad) + call deallocate(quad) + call combine_z_meshes(h_mesh, z_meshes, out_mesh, & + full_shape, "Mesh", option_path="") - fail = node_count(out_mesh) /= 9 - call report_test("[out_mesh: node_count]", fail, .false., "Should be 9") - fail = ele_count(out_mesh) /= 8 - call report_test("[out_mesh: ele_count]", fail, .false., "Should be 8") - fail = mesh_dim(out_mesh) /= 2 - call report_test("[out_mesh: mesh_dim]", fail, .false., "Should be 2") + fail = node_count(out_mesh) /= 9 + call report_test("[out_mesh: node_count]", fail, .false., "Should be 9") + fail = ele_count(out_mesh) /= 8 + call report_test("[out_mesh: ele_count]", fail, .false., "Should be 8") + fail = mesh_dim(out_mesh) /= 2 + call report_test("[out_mesh: mesh_dim]", fail, .false., "Should be 2") - ! we only have one layer so all nodes should be in this one layer - call allocate(layer_nodes(1)) - call insert(layer_nodes(1), (/ (node, node=1, node_count(out_mesh)) /)) + ! we only have one layer so all nodes should be in this one layer + call allocate(layer_nodes(1)) + call insert(layer_nodes(1), (/ (node, node=1, node_count(out_mesh)) /)) - call generate_layered_mesh(out_mesh, h_mesh, layer_nodes) + call generate_layered_mesh(out_mesh, h_mesh, layer_nodes) - call vtk_write_fields("data/layered_mesh", 2, out_mesh, out_mesh%mesh, vfields=(/out_mesh/)) + call vtk_write_fields("data/layered_mesh", 2, out_mesh, out_mesh%mesh, vfields=(/out_mesh/)) end subroutine test_generate_layered_mesh_2d diff --git a/horizontal_adaptivity/tests/test_metric_based_extrusion.F90 b/horizontal_adaptivity/tests/test_metric_based_extrusion.F90 index 60caee90ae..14c6607576 100644 --- a/horizontal_adaptivity/tests/test_metric_based_extrusion.F90 +++ b/horizontal_adaptivity/tests/test_metric_based_extrusion.F90 @@ -1,75 +1,75 @@ subroutine test_metric_based_extrusion - use hadapt_extrude - use hadapt_advancing_front - use hadapt_metric_based_extrude - use fields - use spud - use unittest_tools - use vtk_interfaces - use sparse_tools - use metric_tools - implicit none + use hadapt_extrude + use hadapt_advancing_front + use hadapt_metric_based_extrude + use fields + use spud + use unittest_tools + use vtk_interfaces + use sparse_tools + use metric_tools + implicit none - type(vector_field) :: z_mesh, old_z_mesh, old_mesh - real :: top_depth - integer :: stat - logical :: fail + type(vector_field) :: z_mesh, old_z_mesh, old_mesh + real :: top_depth + integer :: stat + logical :: fail - type(tensor_field) :: metric - type(vector_field) :: adapted_mesh + type(tensor_field) :: metric + type(vector_field) :: adapted_mesh - interface - function metric_func(pos) - real, dimension(:), intent(in) :: pos - real, dimension(size(pos), size(pos)) :: metric_func - end function - end interface + interface + function metric_func(pos) + real, dimension(:), intent(in) :: pos + real, dimension(size(pos), size(pos)) :: metric_func + end function + end interface - call set_option("/geometry/quadrature/degree", 4, stat=stat) - call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/bottom_depth/constant", 1.0, stat=stat) - call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/sizing_function/constant", 1.0, stat=stat) + call set_option("/geometry/quadrature/degree", 4, stat=stat) + call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/bottom_depth/constant", 1.0, stat=stat) + call set_option("/geometry/mesh::ExtrudedMesh/from_mesh/extrude/regions[0]/sizing_function/constant", 1.0, stat=stat) - top_depth = 0.0 - call compute_z_nodes(z_mesh, 1.0, (/ 0.0 /), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=1.0) - call add_faces(z_mesh%mesh) - call vtk_write_fields("data/layered_mesh", 0, z_mesh, z_mesh%mesh, vfields=(/z_mesh/)) - call allocate(old_z_mesh, z_mesh%dim, z_mesh%mesh, "OldZMesh") - call set(old_z_mesh, z_mesh) + top_depth = 0.0 + call compute_z_nodes(z_mesh, 1.0, (/ 0.0 /), top_depth, min_bottom_layer_frac=1e-3, radial_extrusion=.false., sizing=1.0) + call add_faces(z_mesh%mesh) + call vtk_write_fields("data/layered_mesh", 0, z_mesh, z_mesh%mesh, vfields=(/z_mesh/)) + call allocate(old_z_mesh, z_mesh%dim, z_mesh%mesh, "OldZMesh") + call set(old_z_mesh, z_mesh) - call extrude(z_mesh, "/geometry/mesh::ExtrudedMesh", old_mesh) + call extrude(z_mesh, "/geometry/mesh::ExtrudedMesh", old_mesh) - ! OK. So now old_mesh is just a square in 2d - ! with 4 nodes, we hope. Let's set the metric. - call allocate(metric, old_mesh%mesh, "Metric") - call set_from_function(metric, metric_func, old_mesh) + ! OK. So now old_mesh is just a square in 2d + ! with 4 nodes, we hope. Let's set the metric. + call allocate(metric, old_mesh%mesh, "Metric") + call set_from_function(metric, metric_func, old_mesh) - ! OK. Now let's adapt? - call metric_based_extrude(z_mesh, old_z_mesh, adapted_mesh, metric, old_mesh) - call vtk_write_fields("data/metric_based_extrusion", 0, adapted_mesh, adapted_mesh%mesh) + ! OK. Now let's adapt? + call metric_based_extrude(z_mesh, old_z_mesh, adapted_mesh, metric, old_mesh) + call vtk_write_fields("data/metric_based_extrusion", 0, adapted_mesh, adapted_mesh%mesh) - ! .. and check some statistics - fail = (node_count(adapted_mesh) /= 5) - call report_test("[adapted mesh node count]", fail, .false., "Should be 5") + ! .. and check some statistics + fail = (node_count(adapted_mesh) /= 5) + call report_test("[adapted mesh node count]", fail, .false., "Should be 5") - fail = (ele_count(adapted_mesh) /= 3) - call report_test("[adapted mesh ele count]", fail, .false., "Should be 3") + fail = (ele_count(adapted_mesh) /= 3) + call report_test("[adapted mesh ele count]", fail, .false., "Should be 3") end subroutine test_metric_based_extrusion function metric_func(pos) - use metric_tools - real, dimension(:) :: pos - real, dimension(size(pos), size(pos)) :: metric_func + use metric_tools + real, dimension(:) :: pos + real, dimension(size(pos), size(pos)) :: metric_func - real :: x, z + real :: x, z - metric_func = 0.0 + metric_func = 0.0 - metric_func(1, 1) = 1.0 - x = pos(1); z = pos(2) - if (x < -0.5) then - metric_func(2, 2) = eigenvalue_from_edge_length(0.9*abs(z) + 0.1) - else - metric_func(2, 2) = 1.0 - end if + metric_func(1, 1) = 1.0 + x = pos(1); z = pos(2) + if (x < -0.5) then + metric_func(2, 2) = eigenvalue_from_edge_length(0.9*abs(z) + 0.1) + else + metric_func(2, 2) = 1.0 + end if end function metric_func diff --git a/hyperlight/Hyperlight_interface.F90 b/hyperlight/Hyperlight_interface.F90 index 99cce2865c..4f121ed565 100644 --- a/hyperlight/Hyperlight_interface.F90 +++ b/hyperlight/Hyperlight_interface.F90 @@ -27,127 +27,127 @@ #include "fdebug.h" module hyperlight - use spud - use global_parameters, only: OPTION_PATH_LEN - use fields - use state_module - use fluxes + use spud + use global_parameters, only: OPTION_PATH_LEN + use fields + use state_module + use fluxes - implicit none + implicit none contains - subroutine set_irradiance_from_hyperlight(state) - type(state_type), intent(inout) :: state - type(vector_field),pointer :: coord - type(scalar_field),pointer :: chlorophyll, irradiance_field - character(len=OPTION_PATH_LEN) :: field_name - character(len=1024) :: time_units - integer :: node, date, f - real :: x, y, z, lat_long(2), chl, bf_chl, cdom, wind, wind_u, wind_v, cloud, time - real :: irradiance, lambda, timestep, scalar, scalars(9), euphotic_ratio - - ewrite(1,*) "Running Hyperlight" - call hyperlight_reset() - ewrite(2,*) "Hyperlight: setting default parameters" - - ! passing current and start time to Hyperlight - call get_option("/timestepping/current_time/time_units/date", time_units) - call get_option("/timestepping/current_time", time) - call hyperlight_set_date_time(time, trim(time_units)) - - ! passing lat long (single position only, for now...) - if (have_option("/ocean_forcing/bulk_formulae/position/single_location")) then - call hyperlight_set_single_position(1) - call get_option("/ocean_forcing/bulk_formulae/position", lat_long) - call hyperlight_set_coords(lat_long(1), lat_long(2)) - else - ewrite(-1,*) "Hyperlight currently requires ocean forcing with single_location!" - FLExit("Hyperlight: Incorrect latitude and longitude specified.") - end if - - ! passing BF and CDOM ratio as specified - call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/BF_chl", bf_chl) - call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/CDOM", cdom) - - ! getting windspeed and cloudcover - if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/CloudCover")) then - call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/CloudCover", cloud) - else - call fluxes_getscalar("tcc", lat_long(2), lat_long(1), cloud) - end if - if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/WindSpeed")) then - call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/WindSpeed", wind) - else - call fluxes_getscalar("u10", lat_long(2), lat_long(1), wind_u) - call fluxes_getscalar("v10", lat_long(2), lat_long(1), wind_v) - wind = sqrt(wind_u**2.0 + wind_v**2.0); - end if - call hyperlight_set_params(bf_chl, cdom, wind, cloud) - - ! Performance parameter: set the percentage of surface irradiance after which Hyperlight stops computing - if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/EuphoticRatio")) then - call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/EuphoticRatio", euphotic_ratio) - call hyperlight_set_euphotic_ratio(euphotic_ratio) - else - call hyperlight_set_euphotic_ratio(0.0) - end if - - ! set nodes on Hyperlight grid - ewrite(2,*) "Hyperlight: creating grid" - coord=>extract_vector_field(state, "Coordinate") - chlorophyll=>extract_scalar_field(state, "Chlorophyll") - do node=1,node_count(coord) - chl = node_val(chlorophyll, node) - call hyperlight_set_node(node_val(coord, node), chl) - end do - - ! run it - ewrite(2,*) "Hyperlight: run()" - call hyperlight_run() - - ! copy Hyperlight result to irradiance fields - ewrite(2,*) "Hyperlight: setting irradiance fields" - frequency_field_loop: do f=0,35 - lambda = 350.0 + (f * 10.0) - field_name="Irradiance_"//int2str(NINT(lambda)) - irradiance_field=>extract_scalar_field(state, field_name) - node_loop: do node=1,node_count(coord) - call hyperlight_query_node(node_val(coord, node), lambda, irradiance) - call set(irradiance_field, node, irradiance) - end do node_loop - end do frequency_field_loop - - end subroutine set_irradiance_from_hyperlight - - subroutine hyperlight_init() - call hyperlight_grid_init - end subroutine hyperlight_init - - subroutine hyperlight_set_node(coord, chl) - real, intent(in) :: chl - real, dimension(:), intent(in) :: coord - real :: z - - assert(size(coord)==3) - z = coord(3) - if (z .lt. 0.0) then - z = -coord(3) - end if - call hyperlight_grid_set_node(coord(1), coord(2), z, chl) - end subroutine hyperlight_set_node - - subroutine hyperlight_query_node(coord, lambda, irradiance) - real, intent(in) :: lambda - real, dimension(:), intent(in) :: coord - real, intent(out) :: irradiance - real :: z - - assert(size(coord)==3) - z = coord(3) - if (z .lt. 0.0) then - z = -coord(3) - end if - call hyperlight_grid_query_node(coord(1), coord(2), z, lambda, irradiance) - end subroutine hyperlight_query_node + subroutine set_irradiance_from_hyperlight(state) + type(state_type), intent(inout) :: state + type(vector_field),pointer :: coord + type(scalar_field),pointer :: chlorophyll, irradiance_field + character(len=OPTION_PATH_LEN) :: field_name + character(len=1024) :: time_units + integer :: node, date, f + real :: x, y, z, lat_long(2), chl, bf_chl, cdom, wind, wind_u, wind_v, cloud, time + real :: irradiance, lambda, timestep, scalar, scalars(9), euphotic_ratio + + ewrite(1,*) "Running Hyperlight" + call hyperlight_reset() + ewrite(2,*) "Hyperlight: setting default parameters" + + ! passing current and start time to Hyperlight + call get_option("/timestepping/current_time/time_units/date", time_units) + call get_option("/timestepping/current_time", time) + call hyperlight_set_date_time(time, trim(time_units)) + + ! passing lat long (single position only, for now...) + if (have_option("/ocean_forcing/bulk_formulae/position/single_location")) then + call hyperlight_set_single_position(1) + call get_option("/ocean_forcing/bulk_formulae/position", lat_long) + call hyperlight_set_coords(lat_long(1), lat_long(2)) + else + ewrite(-1,*) "Hyperlight currently requires ocean forcing with single_location!" + FLExit("Hyperlight: Incorrect latitude and longitude specified.") + end if + + ! passing BF and CDOM ratio as specified + call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/BF_chl", bf_chl) + call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/CDOM", cdom) + + ! getting windspeed and cloudcover + if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/CloudCover")) then + call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/CloudCover", cloud) + else + call fluxes_getscalar("tcc", lat_long(2), lat_long(1), cloud) + end if + if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/WindSpeed")) then + call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/WindSpeed", wind) + else + call fluxes_getscalar("u10", lat_long(2), lat_long(1), wind_u) + call fluxes_getscalar("v10", lat_long(2), lat_long(1), wind_v) + wind = sqrt(wind_u**2.0 + wind_v**2.0); + end if + call hyperlight_set_params(bf_chl, cdom, wind, cloud) + + ! Performance parameter: set the percentage of surface irradiance after which Hyperlight stops computing + if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/EuphoticRatio")) then + call get_option("/ocean_biology/lagrangian_ensemble/hyperlight/EuphoticRatio", euphotic_ratio) + call hyperlight_set_euphotic_ratio(euphotic_ratio) + else + call hyperlight_set_euphotic_ratio(0.0) + end if + + ! set nodes on Hyperlight grid + ewrite(2,*) "Hyperlight: creating grid" + coord=>extract_vector_field(state, "Coordinate") + chlorophyll=>extract_scalar_field(state, "Chlorophyll") + do node=1,node_count(coord) + chl = node_val(chlorophyll, node) + call hyperlight_set_node(node_val(coord, node), chl) + end do + + ! run it + ewrite(2,*) "Hyperlight: run()" + call hyperlight_run() + + ! copy Hyperlight result to irradiance fields + ewrite(2,*) "Hyperlight: setting irradiance fields" + frequency_field_loop: do f=0,35 + lambda = 350.0 + (f * 10.0) + field_name="Irradiance_"//int2str(NINT(lambda)) + irradiance_field=>extract_scalar_field(state, field_name) + node_loop: do node=1,node_count(coord) + call hyperlight_query_node(node_val(coord, node), lambda, irradiance) + call set(irradiance_field, node, irradiance) + end do node_loop + end do frequency_field_loop + + end subroutine set_irradiance_from_hyperlight + + subroutine hyperlight_init() + call hyperlight_grid_init + end subroutine hyperlight_init + + subroutine hyperlight_set_node(coord, chl) + real, intent(in) :: chl + real, dimension(:), intent(in) :: coord + real :: z + + assert(size(coord)==3) + z = coord(3) + if (z .lt. 0.0) then + z = -coord(3) + end if + call hyperlight_grid_set_node(coord(1), coord(2), z, chl) + end subroutine hyperlight_set_node + + subroutine hyperlight_query_node(coord, lambda, irradiance) + real, intent(in) :: lambda + real, dimension(:), intent(in) :: coord + real, intent(out) :: irradiance + real :: z + + assert(size(coord)==3) + z = coord(3) + if (z .lt. 0.0) then + z = -coord(3) + end if + call hyperlight_grid_query_node(coord(1), coord(2), z, lambda, irradiance) + end subroutine hyperlight_query_node end module hyperlight diff --git a/include/Dgtools.F90 b/include/Dgtools.F90 index a40bc200fd..791acb2ce0 100644 --- a/include/Dgtools.F90 +++ b/include/Dgtools.F90 @@ -2,189 +2,189 @@ module dgtools -use elements -use sparse_tools -implicit none + use elements + use sparse_tools + implicit none contains - function local_node_map(m, m_f, bdy, bdy_2) result(local_glno) - ! Fill in the number map for the DG double element. - type(element_type), intent(in) :: m, m_f - integer, dimension(m_f%loc) :: bdy, bdy_2 - integer, dimension(m%loc,2) :: local_glno - - integer :: i,j - - local_glno=0 - - ! First m_f%loc places are for the bdy between the elements. - forall(i=1:m_f%loc) - local_glno(bdy(i),1)=i - end forall - - ! Remaining spots go to elements. - j=m_f%loc - do i=1, m%loc - if(local_glno(i,1)==0) then - j=j+1 - local_glno(i,1)=j - end if - end do - - ASSERT(j==m%loc) - - ! First m_f%loc places are for the bdy between the elements. - forall(i=1:m_f%loc) - local_glno(bdy_2(i),2)=i - end forall - - ! Remaining spots go to elements. - j=m%loc - do i=1, m%loc - if(local_glno(i,2)==0) then - j=j+1 - local_glno(i,2)=j - end if - end do - - ASSERT(j==2*m%loc-m_f%loc) - - end function local_node_map - - subroutine local_node_map_nc(nh_f,nu,b_seg, b_seg_2, & - u_ele, u_ele_2, & - local_glno, local2global_glno) - ! Fill in the number map for the NC double element. - ! only works for the P1nc element - ! higher order elements require deeper thinking - - type(element_type) :: nu, nh_f ! Shape Functions - integer, dimension(nh_f%loc), intent(in) :: b_seg, b_seg_2 - integer, dimension(:), intent(in) :: u_ele, u_ele_2 - integer, dimension(nu%loc,2), intent(out) :: local_glno - integer, dimension(2*nu%loc-1), intent(out) :: local2global_glno - - integer :: i,j - - local_glno=0 - - ! First 2 places are for nodes in element 1 away from the - ! shared b_seg - forall(i=1:2) - local_glno(b_seg(i),1)=i - local2global_glno(i) = u_ele(b_seg(i)) - end forall - - ! spot 3 goes to the node on the shared b_seg - do i=1, 3 - if(local_glno(i,1)==0) then - local_glno(i,1)=3 - local2global_glno(3) = u_ele(i) - end if - end do - - ! last 2 places are for the nodes in element 2 away from the - ! shared b_seg - forall(i=1:2) - local_glno(b_seg_2(i),2)=i+3 - local2global_glno(i+3) = u_ele_2(b_seg_2(i)) - end forall - - ! spot 3 goes to the node on the shared b_seg - do i=1, 3 - if(local_glno(i,2)==0) then - local_glno(i,2)=3 - end if - end do - - end subroutine local_node_map_nc - - function get_nc_coefficients(b_seg_n,loc,f_loc) result(coeff) - implicit none - - ! need a local b_seg ordering - ! nodes not on the b_seg, node on the b_seg. - ! b_seg_nh_lno gives local node numbers for h on b_seg - ! these are the same as the local node numbers which are - ! not on the b_seg for u - ! on the b_seg, basis functions for u nodes not on the b_seg - ! take value 0.5 on the side of the b_seg they are on, and - ! value -0.5 on the other side - ! we'll need to calculate which one is which - ! we already have that information as the local node number - ! for the b_seg h node is the same as the volume u node opposite - ! the basis function corresponding to the node that is on - ! the b_seg is ==1 on the b_seg - - integer, intent(in):: loc, f_loc - integer, dimension(f_loc), intent(in) :: b_seg_n - real, dimension(loc,2) :: coeff - - !local variables - integer, dimension(loc) :: flag - integer :: i - - flag = 0. - - do i = 1,f_loc - flag(b_seg_n(i)) = i - end do - - do i = 1,loc - select case (flag(i)) - case (0) - coeff(i,:) = 1.0 - case (1) - coeff(i,:) = (/ -0.5, 0.5 /) - case (2) - coeff(i,:) = (/ 0.5, -0.5 /) - case default - ERROR('NC coefficients disaster -- cjc') - end select - end do - - end function get_nc_coefficients - - subroutine solve(A,B) - ! Solve Ax=b for multiple right hand sides B putting the result in B. - ! - ! This is simply a wrapper for lapack. - real, dimension(:,:), intent(in) :: A - real, dimension(:,:), intent(inout) :: B - - integer, dimension(size(A,1)) :: ipiv - integer :: info - - interface + function local_node_map(m, m_f, bdy, bdy_2) result(local_glno) + ! Fill in the number map for the DG double element. + type(element_type), intent(in) :: m, m_f + integer, dimension(m_f%loc) :: bdy, bdy_2 + integer, dimension(m%loc,2) :: local_glno + + integer :: i,j + + local_glno=0 + + ! First m_f%loc places are for the bdy between the elements. + forall(i=1:m_f%loc) + local_glno(bdy(i),1)=i + end forall + + ! Remaining spots go to elements. + j=m_f%loc + do i=1, m%loc + if(local_glno(i,1)==0) then + j=j+1 + local_glno(i,1)=j + end if + end do + + ASSERT(j==m%loc) + + ! First m_f%loc places are for the bdy between the elements. + forall(i=1:m_f%loc) + local_glno(bdy_2(i),2)=i + end forall + + ! Remaining spots go to elements. + j=m%loc + do i=1, m%loc + if(local_glno(i,2)==0) then + j=j+1 + local_glno(i,2)=j + end if + end do + + ASSERT(j==2*m%loc-m_f%loc) + + end function local_node_map + + subroutine local_node_map_nc(nh_f,nu,b_seg, b_seg_2, & + u_ele, u_ele_2, & + local_glno, local2global_glno) + ! Fill in the number map for the NC double element. + ! only works for the P1nc element + ! higher order elements require deeper thinking + + type(element_type) :: nu, nh_f ! Shape Functions + integer, dimension(nh_f%loc), intent(in) :: b_seg, b_seg_2 + integer, dimension(:), intent(in) :: u_ele, u_ele_2 + integer, dimension(nu%loc,2), intent(out) :: local_glno + integer, dimension(2*nu%loc-1), intent(out) :: local2global_glno + + integer :: i,j + + local_glno=0 + + ! First 2 places are for nodes in element 1 away from the + ! shared b_seg + forall(i=1:2) + local_glno(b_seg(i),1)=i + local2global_glno(i) = u_ele(b_seg(i)) + end forall + + ! spot 3 goes to the node on the shared b_seg + do i=1, 3 + if(local_glno(i,1)==0) then + local_glno(i,1)=3 + local2global_glno(3) = u_ele(i) + end if + end do + + ! last 2 places are for the nodes in element 2 away from the + ! shared b_seg + forall(i=1:2) + local_glno(b_seg_2(i),2)=i+3 + local2global_glno(i+3) = u_ele_2(b_seg_2(i)) + end forall + + ! spot 3 goes to the node on the shared b_seg + do i=1, 3 + if(local_glno(i,2)==0) then + local_glno(i,2)=3 + end if + end do + + end subroutine local_node_map_nc + + function get_nc_coefficients(b_seg_n,loc,f_loc) result(coeff) + implicit none + + ! need a local b_seg ordering + ! nodes not on the b_seg, node on the b_seg. + ! b_seg_nh_lno gives local node numbers for h on b_seg + ! these are the same as the local node numbers which are + ! not on the b_seg for u + ! on the b_seg, basis functions for u nodes not on the b_seg + ! take value 0.5 on the side of the b_seg they are on, and + ! value -0.5 on the other side + ! we'll need to calculate which one is which + ! we already have that information as the local node number + ! for the b_seg h node is the same as the volume u node opposite + ! the basis function corresponding to the node that is on + ! the b_seg is ==1 on the b_seg + + integer, intent(in):: loc, f_loc + integer, dimension(f_loc), intent(in) :: b_seg_n + real, dimension(loc,2) :: coeff + + !local variables + integer, dimension(loc) :: flag + integer :: i + + flag = 0. + + do i = 1,f_loc + flag(b_seg_n(i)) = i + end do + + do i = 1,loc + select case (flag(i)) + case (0) + coeff(i,:) = 1.0 + case (1) + coeff(i,:) = (/ -0.5, 0.5 /) + case (2) + coeff(i,:) = (/ 0.5, -0.5 /) + case default + ERROR('NC coefficients disaster -- cjc') + end select + end do + + end function get_nc_coefficients + + subroutine solve(A,B) + ! Solve Ax=b for multiple right hand sides B putting the result in B. + ! + ! This is simply a wrapper for lapack. + real, dimension(:,:), intent(in) :: A + real, dimension(:,:), intent(inout) :: B + + integer, dimension(size(A,1)) :: ipiv + integer :: info + + interface #ifdef DOUBLEP - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - INTEGER :: INFO, LDA, LDB, N, NRHS - INTEGER :: IPIV( * ) - REAL :: A( LDA, * ), B( LDB, * ) - END SUBROUTINE DGESV + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + INTEGER :: INFO, LDA, LDB, N, NRHS + INTEGER :: IPIV( * ) + REAL :: A( LDA, * ), B( LDB, * ) + END SUBROUTINE DGESV #else - SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - INTEGER :: INFO, LDA, LDB, N, NRHS - INTEGER :: IPIV( * ) - REAL :: A( LDA, * ), B( LDB, * ) - END SUBROUTINE SGESV + SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + INTEGER :: INFO, LDA, LDB, N, NRHS + INTEGER :: IPIV( * ) + REAL :: A( LDA, * ), B( LDB, * ) + END SUBROUTINE SGESV #endif - end interface + end interface - ASSERT(size(A,1)==size(A,2)) - ASSERT(size(A,1)==size(B,1)) + ASSERT(size(A,1)==size(A,2)) + ASSERT(size(A,1)==size(B,1)) #ifdef DOUBLEP - call dgesv(size(A,1), size(B,2), A, size(A,1), ipiv, B, size(B,1),& - & info) + call dgesv(size(A,1), size(B,2), A, size(A,1), ipiv, B, size(B,1),& + & info) #else - call sgesv(size(A,1), size(B,2), A, size(A,1), ipiv, B, size(B,1),& - & info) + call sgesv(size(A,1), size(B,2), A, size(A,1), ipiv, B, size(B,1),& + & info) #endif - ASSERT(info==0) + ASSERT(info==0) - end subroutine solve + end subroutine solve end module dgtools diff --git a/libadaptivity/adapt3d/src/AdaptProgress.F90 b/libadaptivity/adapt3d/src/AdaptProgress.F90 index 744fd5e14e..1aa6d8db3c 100644 --- a/libadaptivity/adapt3d/src/AdaptProgress.F90 +++ b/libadaptivity/adapt3d/src/AdaptProgress.F90 @@ -28,106 +28,106 @@ #include "confdefs.h" module AdaptProgress - implicit none + implicit none - private + private - public::initialise, finalize, should_exit + public::initialise, finalize, should_exit #ifdef HAVE_MPI - include 'mpif.h' + include 'mpif.h' #endif - logical::initialised=.false. - integer, dimension(:), allocatable::load, rrequest - integer::myrank, nprocs - real::imbalance_tol=0.5 - integer win + logical::initialised=.false. + integer, dimension(:), allocatable::load, rrequest + integer::myrank, nprocs + real::imbalance_tol=0.5 + integer win contains - subroutine initialise(count, tol) - integer, intent(in)::count - real, intent(in)::tol + subroutine initialise(count, tol) + integer, intent(in)::count + real, intent(in)::tol #ifdef HAVE_MPI - integer have_mpi_init, i, ierr - if(.not.initialised) then - call MPI_Initialized(have_mpi_init, ierr) - if(have_mpi_init.eq.0) then - nprocs=1 - else - call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr) - endif - - if(nprocs.gt.1) then - call MPI_Comm_rank(MPI_COMM_WORLD, myrank, ierr) - allocate(load(0:nprocs-1)) - call MPI_Allgather(count, 1, MPI_INTEGER, load, 1, & + integer have_mpi_init, i, ierr + if(.not.initialised) then + call MPI_Initialized(have_mpi_init, ierr) + if(have_mpi_init.eq.0) then + nprocs=1 + else + call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr) + endif + + if(nprocs.gt.1) then + call MPI_Comm_rank(MPI_COMM_WORLD, myrank, ierr) + allocate(load(0:nprocs-1)) + call MPI_Allgather(count, 1, MPI_INTEGER, load, 1, & MPI_INTEGER, MPI_COMM_WORLD, ierr) - allocate(rrequest(0:nprocs-1)) + allocate(rrequest(0:nprocs-1)) - do i=0, nprocs-1 - if(i.ne.myrank) then - call MPI_Irecv(load(i), 1, MPI_INTEGER, i, 1, & + do i=0, nprocs-1 + if(i.ne.myrank) then + call MPI_Irecv(load(i), 1, MPI_INTEGER, i, 1, & MPI_COMM_WORLD, rrequest(i), ierr) - else - rrequest(i) = MPI_REQUEST_NULL - end if - end do + else + rrequest(i) = MPI_REQUEST_NULL + end if + end do - imbalance_tol = tol - end if + imbalance_tol = tol + end if - initialised = .true. - end if + initialised = .true. + end if #endif - end subroutine initialise + end subroutine initialise - subroutine finalize(count) - integer, intent(in)::count + subroutine finalize(count) + integer, intent(in)::count #ifdef HAVE_MPI - integer i, ierr - integer, allocatable, dimension(:)::request - integer, allocatable, dimension(:, :)::status + integer i, ierr + integer, allocatable, dimension(:)::request + integer, allocatable, dimension(:, :)::status - if(nprocs.gt.1) then - allocate(request(0:nprocs-1)) - allocate(status(MPI_STATUS_SIZE, 0:nprocs-1)) + if(nprocs.gt.1) then + allocate(request(0:nprocs-1)) + allocate(status(MPI_STATUS_SIZE, 0:nprocs-1)) - do i=0, nprocs-1 - if(i.ne.myrank) then - call MPI_Isend(count, 1, MPI_INTEGER, i, 1, & + do i=0, nprocs-1 + if(i.ne.myrank) then + call MPI_Isend(count, 1, MPI_INTEGER, i, 1, & MPI_COMM_WORLD, request(i), ierr) - else - request(i) = MPI_REQUEST_NULL - end if - end do + else + request(i) = MPI_REQUEST_NULL + end if + end do - call MPI_Waitall(nprocs, rrequest, status, ierr) - call MPI_Waitall(nprocs, request, status, ierr) + call MPI_Waitall(nprocs, rrequest, status, ierr) + call MPI_Waitall(nprocs, request, status, ierr) - deallocate(request, rrequest, status, load) - end if - initialised = .false. + deallocate(request, rrequest, status, load) + end if + initialised = .false. #endif - end subroutine finalize + end subroutine finalize - logical function should_exit(count) - integer, intent(in)::count + logical function should_exit(count) + integer, intent(in)::count #ifdef HAVE_MPI - real imbalance - integer ierr + real imbalance + integer ierr - if(nprocs.gt.1) then - load(myrank) = count + if(nprocs.gt.1) then + load(myrank) = count - imbalance = 1.0 - real(sum(load))/(nprocs*maxval(load)) + imbalance = 1.0 - real(sum(load))/(nprocs*maxval(load)) - should_exit = (imbalance>imbalance_tol) - else - should_exit = .false. - end if + should_exit = (imbalance>imbalance_tol) + else + should_exit = .false. + end if #else - should_exit = .false. + should_exit = .false. #endif - end function should_exit + end function should_exit end module AdaptProgress diff --git a/libadaptivity/adapt3d/src/expected_elements.F90 b/libadaptivity/adapt3d/src/expected_elements.F90 index 0c63deaff2..1903df14ee 100644 --- a/libadaptivity/adapt3d/src/expected_elements.F90 +++ b/libadaptivity/adapt3d/src/expected_elements.F90 @@ -28,125 +28,125 @@ !< Given a metric tensor field and a mesh, calculate the number of !< tetrahedral elements we would expect after adapting to that metric. module predicted_elements - implicit none - private - public::predicted_number_elements + implicit none + private + public::predicted_number_elements contains - integer function predicted_number_elements(Metric, X, Y, Z, NDGLNO,& - NNodes, NTetra, nloc) - integer, intent(in)::NNodes - real, intent(in)::Metric(NNodes*9), X(NNodes), Y(NNodes), Z(NNodes) - integer, intent(in)::NTetra, nloc, NDGLNO(NTetra*NLOC) - - ! The quantity to scale the predicted no of elements - real, parameter::VOLSCA=1.2 - - ! Volume of unit tetrahedral(VOL1TE) =1./sqrt(72). (each side has length 1.) - real, parameter::VOL1EL=0.11785113 - - real VOLUME, VOL, DET, MEANM(9), XX(4), YY(4), ZZ(4), MXDET, SMDET - integer ELE, Node, I, ILOC - - VOLUME=0.0 - MXDET = -1E+30 - SMDET = 0.0 - do ELE=1,NTetra - do I=1,9 - MEANM(I) = 0.0 - END DO - do ILOC=1,4 - Node = NDGLNO((ELE-1)*NLOC+ILOC) - XX(ILOC) = X(Node) - YY(ILOC) = Y(Node) - ZZ(ILOC) = Z(Node) - do I=1,9 - MEANM(I) = MEANM(I) + Metric((Node-1)*9+I)*0.25 - END DO - END DO - - CALL JACVOL(VOL, XX, YY, ZZ, .TRUE.) - if (vol <= 0.0) then - write(0, *) "WARNING: Volume of element", ele, "not positive!" - write(0, *) "WARNING: Bad news! Your inputs to adaptivity are fecked." - end if - CALL JACDET(DET, MEANM, 3) - MXDET = MAX(MXDET,DET) - SMDET = SMDET + DET - - VOLUME = VOLUME + VOL*SQRT(MAX(0.0,DET)) - END DO - - I = INT(VOLSCA*VOLUME/VOL1EL) - IF( I .LT. 2 ) THEN - write(0, *) 'WARNING: predicted number of elements looks wrong: ',I - write(0, *) 'VOLSCA,VOLUME,VOL1EL = ',VOLSCA,VOLUME,VOL1EL - write(0, *) 'Determinant max & sum = ',MXDET,SMDET - write(0, *) 'NNOD,NELM,NLOC = ',NNodes,NTetra,NLOC - END IF - - predicted_number_elements = I - end function predicted_number_elements - - ! This sub calculates the volume of an element. - ! X,Y,Z are the coords of the 4 nodes. - subroutine jacvol(VOL, X, Y, Z, D3) - real, intent(out)::vol - real, intent(in)::X(4),Y(4),Z(4) - LOGICAL, intent(in)::D3 - - REAL X12,X13,X14,Y12,Y13,Y14,Z12,Z13,Z14 - - IF(D3) THEN - X12 = X(2) - X(1) - X13 = X(3) - X(1) - X14 = X(4) - X(1) - Y12 = Y(2) - Y(1) - Y13 = Y(3) - Y(1) - Y14 = Y(4) - Y(1) - Z12 = Z(2) - Z(1) - Z13 = Z(3) - Z(1) - Z14 = Z(4) - Z(1) - - VOL=ABS(X12*Y13*Z14 + X13*Y14*Z12 + X14*Y12*Z13& - & - X14*Y13*Z12 - X13*Y12*Z14 - X12*Y14*Z13)/6. - ELSE - ! Caculate area=VOL in 2-D. (half base x height) - VOL=0.5*( (X(2)-X(1))*(Y(3)-Y(1)) & - & -(X(3)-X(1))*(Y(2)-Y(1)) ) - ENDIF - - end subroutine jacvol - - ! This sub calculates the volume of an element. - ! X,Y,Z are the coords of the 4 nodes. - subroutine jacdet(DET,M,NDIM) - integer, intent(in)::NDIM - real, intent(out)::DET - real, intent(in)::M(NDIM,NDIM) - - IF(NDIM.EQ.3) THEN - DET = M(1,1)*( M(2,2)*M(3,3) - M(2,3)*M(3,2) )& - & + M(2,1)*( M(3,2)*M(1,3) - M(1,2)*M(3,3) )& - & + M(3,1)*( M(1,2)*M(2,3) - M(2,2)*M(1,3) ) - ELSE - DET = M(1,1)*M(2,2)-M(1,2)*M(2,1) - ENDIF - - end subroutine jacdet + integer function predicted_number_elements(Metric, X, Y, Z, NDGLNO,& + NNodes, NTetra, nloc) + integer, intent(in)::NNodes + real, intent(in)::Metric(NNodes*9), X(NNodes), Y(NNodes), Z(NNodes) + integer, intent(in)::NTetra, nloc, NDGLNO(NTetra*NLOC) + + ! The quantity to scale the predicted no of elements + real, parameter::VOLSCA=1.2 + + ! Volume of unit tetrahedral(VOL1TE) =1./sqrt(72). (each side has length 1.) + real, parameter::VOL1EL=0.11785113 + + real VOLUME, VOL, DET, MEANM(9), XX(4), YY(4), ZZ(4), MXDET, SMDET + integer ELE, Node, I, ILOC + + VOLUME=0.0 + MXDET = -1E+30 + SMDET = 0.0 + do ELE=1,NTetra + do I=1,9 + MEANM(I) = 0.0 + END DO + do ILOC=1,4 + Node = NDGLNO((ELE-1)*NLOC+ILOC) + XX(ILOC) = X(Node) + YY(ILOC) = Y(Node) + ZZ(ILOC) = Z(Node) + do I=1,9 + MEANM(I) = MEANM(I) + Metric((Node-1)*9+I)*0.25 + END DO + END DO + + CALL JACVOL(VOL, XX, YY, ZZ, .TRUE.) + if (vol <= 0.0) then + write(0, *) "WARNING: Volume of element", ele, "not positive!" + write(0, *) "WARNING: Bad news! Your inputs to adaptivity are fecked." + end if + CALL JACDET(DET, MEANM, 3) + MXDET = MAX(MXDET,DET) + SMDET = SMDET + DET + + VOLUME = VOLUME + VOL*SQRT(MAX(0.0,DET)) + END DO + + I = INT(VOLSCA*VOLUME/VOL1EL) + IF( I .LT. 2 ) THEN + write(0, *) 'WARNING: predicted number of elements looks wrong: ',I + write(0, *) 'VOLSCA,VOLUME,VOL1EL = ',VOLSCA,VOLUME,VOL1EL + write(0, *) 'Determinant max & sum = ',MXDET,SMDET + write(0, *) 'NNOD,NELM,NLOC = ',NNodes,NTetra,NLOC + END IF + + predicted_number_elements = I + end function predicted_number_elements + + ! This sub calculates the volume of an element. + ! X,Y,Z are the coords of the 4 nodes. + subroutine jacvol(VOL, X, Y, Z, D3) + real, intent(out)::vol + real, intent(in)::X(4),Y(4),Z(4) + LOGICAL, intent(in)::D3 + + REAL X12,X13,X14,Y12,Y13,Y14,Z12,Z13,Z14 + + IF(D3) THEN + X12 = X(2) - X(1) + X13 = X(3) - X(1) + X14 = X(4) - X(1) + Y12 = Y(2) - Y(1) + Y13 = Y(3) - Y(1) + Y14 = Y(4) - Y(1) + Z12 = Z(2) - Z(1) + Z13 = Z(3) - Z(1) + Z14 = Z(4) - Z(1) + + VOL=ABS(X12*Y13*Z14 + X13*Y14*Z12 + X14*Y12*Z13& + & - X14*Y13*Z12 - X13*Y12*Z14 - X12*Y14*Z13)/6. + ELSE + ! Caculate area=VOL in 2-D. (half base x height) + VOL=0.5*( (X(2)-X(1))*(Y(3)-Y(1)) & + & -(X(3)-X(1))*(Y(2)-Y(1)) ) + ENDIF + + end subroutine jacvol + + ! This sub calculates the volume of an element. + ! X,Y,Z are the coords of the 4 nodes. + subroutine jacdet(DET,M,NDIM) + integer, intent(in)::NDIM + real, intent(out)::DET + real, intent(in)::M(NDIM,NDIM) + + IF(NDIM.EQ.3) THEN + DET = M(1,1)*( M(2,2)*M(3,3) - M(2,3)*M(3,2) )& + & + M(2,1)*( M(3,2)*M(1,3) - M(1,2)*M(3,3) )& + & + M(3,1)*( M(1,2)*M(2,3) - M(2,2)*M(1,3) ) + ELSE + DET = M(1,1)*M(2,2)-M(1,2)*M(2,1) + ENDIF + + end subroutine jacdet end module predicted_elements ! I don't feel up to hacking at at F90 name mangling for C ! interfacing, therefore: integer function get_predicted_nelements(Metric, X, Y, Z, NDGLNO, & - NNodes, NTetra, nloc) - use predicted_elements - integer, intent(in)::NNodes - real, intent(in)::Metric(NNodes*9), X(NNodes), Y(NNodes), Z(NNodes) - integer, intent(in)::NTetra, nloc, NDGLNO(NTetra*NLOC) - - get_predicted_nelements = predicted_number_elements(Metric, X, Y, Z, NDGLNO, & - NNodes, NTetra, nloc) - return + NNodes, NTetra, nloc) + use predicted_elements + integer, intent(in)::NNodes + real, intent(in)::Metric(NNodes*9), X(NNodes), Y(NNodes), Z(NNodes) + integer, intent(in)::NTetra, nloc, NDGLNO(NTetra*NLOC) + + get_predicted_nelements = predicted_number_elements(Metric, X, Y, Z, NDGLNO, & + NNodes, NTetra, nloc) + return end function get_predicted_nelements diff --git a/libspud/examples/ballistics.F90 b/libspud/examples/ballistics.F90 index ea0fb681be..39e7b6fadf 100644 --- a/libspud/examples/ballistics.F90 +++ b/libspud/examples/ballistics.F90 @@ -1,206 +1,206 @@ program ballistics - !!< This is a simple program which illustrates the use of spud to drive a - !!< trivial simulation. - use spud - implicit none + !!< This is a simple program which illustrates the use of spud to drive a + !!< trivial simulation. + use spud + implicit none - integer, parameter :: D=kind(0.0D0) - - type projectile_type - character(len=256) :: name - real(D), dimension(2) :: velocity - real(D), dimension(2) :: position - ! Whether this projectile is still airbourne. - logical :: active = .true. - end type projectile_type + integer, parameter :: D=kind(0.0D0) - ! The list of projectiles to be evolved - type(projectile_type), dimension(:), allocatable :: projectiles + type projectile_type + character(len=256) :: name + real(D), dimension(2) :: velocity + real(D), dimension(2) :: position + ! Whether this projectile is still airbourne. + logical :: active = .true. + end type projectile_type - ! The acceleration due to gravity. - real(D) :: gravity - - real(D) :: current_time, finish_time, dt - - character(len=1024) :: time_integration_scheme + ! The list of projectiles to be evolved + type(projectile_type), dimension(:), allocatable :: projectiles - character(len=1024) :: filename + ! The acceleration due to gravity. + real(D) :: gravity - integer, parameter :: output_unit=42 + real(D) :: current_time, finish_time, dt - integer :: i + character(len=1024) :: time_integration_scheme - !------------------------------------------------------------------------ - ! Program starts here - !------------------------------------------------------------------------ + character(len=1024) :: filename - ! Read the input file name from the command line. - call read_command_line(filename) + integer, parameter :: output_unit=42 - ! Load the input options into the dictionary. - call load_options(filename) - - call setup_projectiles(projectiles) + integer :: i - call setup_output_file(projectiles, output_unit) + !------------------------------------------------------------------------ + ! Program starts here + !------------------------------------------------------------------------ - call get_option("/timestepping/finish_time", finish_time) - call get_option("/timestepping/dt", dt) - call get_option("/timestepping/time_integration_scheme",& - & time_integration_scheme) - call get_option("/gravity", gravity) + ! Read the input file name from the command line. + call read_command_line(filename) - current_time=0.0 - timeloop: do while (current_time" - - end subroutine usage - - subroutine setup_projectiles(projectiles) - ! Read in the starting positions and velocities of the projectiles. - type(projectile_type), dimension(:), allocatable, intent(inout)& + subroutine read_command_line(filename) + ! Read the input filename on the command line. + character(len=*), intent(out) :: filename + integer :: status + + call get_command_argument(1, value=filename, status=status) + + select case(status) + case(1:) + call usage + stop + case(:-1) + write(0,*) "Warning: truncating filename" + end select + + end subroutine read_command_line + + subroutine usage + + write (0,*) "usage: ballistics " + + end subroutine usage + + subroutine setup_projectiles(projectiles) + ! Read in the starting positions and velocities of the projectiles. + type(projectile_type), dimension(:), allocatable, intent(inout)& :: projectiles - integer :: projectile_count, i - character(len=1024) :: path + integer :: projectile_count, i + character(len=1024) :: path + + projectile_count=option_count("/projectile") + + allocate(projectiles(projectile_count)) - projectile_count=option_count("/projectile") - - allocate(projectiles(projectile_count)) + do i=1,projectile_count - do i=1,projectile_count - - write(path, '(a,i0,a)') "/projectile[",i-1,"]" + write(path, '(a,i0,a)') "/projectile[",i-1,"]" - call get_option(trim(path)//"/name", projectiles(i)%name) + call get_option(trim(path)//"/name", projectiles(i)%name) - call get_option(trim(path)//"/initial_velocity", & + call get_option(trim(path)//"/initial_velocity", & projectiles(i)%velocity) - ! Note that the launch position is measured along the x axis. - call get_option(trim(path)//"/launch_position", & + ! Note that the launch position is measured along the x axis. + call get_option(trim(path)//"/launch_position", & projectiles(i)%position(1:1)) - - end do - - end subroutine setup_projectiles - - subroutine setup_output_file(projectiles, output_unit) - ! Open the output file and populate the header line. - type(projectile_type), dimension(:), intent(in) :: projectiles - integer, intent(in) :: output_unit - - character(len=1024) :: output_filename - integer :: i - - call get_option("/simulation_name", output_filename) - - open(unit=output_unit, file=trim(output_filename)//".csv", & - action="write") - - write(output_unit, '(a)', advance="no") "time" - - do i=1,size(projectiles) - write(output_unit, '(a)', advance="no") & + + end do + + end subroutine setup_projectiles + + subroutine setup_output_file(projectiles, output_unit) + ! Open the output file and populate the header line. + type(projectile_type), dimension(:), intent(in) :: projectiles + integer, intent(in) :: output_unit + + character(len=1024) :: output_filename + integer :: i + + call get_option("/simulation_name", output_filename) + + open(unit=output_unit, file=trim(output_filename)//".csv", & + action="write") + + write(output_unit, '(a)', advance="no") "time" + + do i=1,size(projectiles) + write(output_unit, '(a)', advance="no") & ", "//trim(projectiles(i)%name)//"_x, "& - //trim(projectiles(i)%name)//"_y" - end do - - ! Finish the line. - write(output_unit, '(a)') "" - - end subroutine setup_output_file - - subroutine output_projectile_positions(current_time, projectiles, output_unit) - !!< Simply dump the time and the positions to the output file. - real(D), intent(in) :: current_time - type(projectile_type), dimension(:), intent(in) :: projectiles - integer, intent(in) :: output_unit - - integer :: i - - write(output_unit, '(e15.8,",")', advance="no") current_time - - do i=1,size(projectiles) - write(output_unit, '(2(e15.8,","))', advance="no") projectiles(i)%position - end do - - ! Finish the line. - write(output_unit, '(a)') "" - - end subroutine output_projectile_positions - - subroutine move_projectile(projectile, dt) - !!< Move the current projectile by dt. - type(projectile_type), intent(inout) :: projectile - real(D), intent(in) :: dt - - select case(time_integration_scheme) - - case("explicit_euler") - ! Move the projectile using the existing velocity. - - projectile%position=projectile%position + dt * projectile%velocity - - case("analytic") - ! Move the projectile using s= u*dt + 0.5*a*dt**2 - - projectile%position=projectile%position + dt * projectile%velocity & - & + 0.5_D*dt**2*(/0.0_D, -gravity/) - - case default - write(0,*) "Unknown time integration scheme" - - end select - - ! Calculate the new velocity. - projectile%velocity=projectile%velocity + dt * (/0.0_D, -gravity/) - - ! Deactivate projectiles which touch the ground. - if (projectile%position(2)<=0.0) then - projectile%active=.false. - end if - - end subroutine move_projectile - + //trim(projectiles(i)%name)//"_y" + end do + + ! Finish the line. + write(output_unit, '(a)') "" + + end subroutine setup_output_file + + subroutine output_projectile_positions(current_time, projectiles, output_unit) + !!< Simply dump the time and the positions to the output file. + real(D), intent(in) :: current_time + type(projectile_type), dimension(:), intent(in) :: projectiles + integer, intent(in) :: output_unit + + integer :: i + + write(output_unit, '(e15.8,",")', advance="no") current_time + + do i=1,size(projectiles) + write(output_unit, '(2(e15.8,","))', advance="no") projectiles(i)%position + end do + + ! Finish the line. + write(output_unit, '(a)') "" + + end subroutine output_projectile_positions + + subroutine move_projectile(projectile, dt) + !!< Move the current projectile by dt. + type(projectile_type), intent(inout) :: projectile + real(D), intent(in) :: dt + + select case(time_integration_scheme) + + case("explicit_euler") + ! Move the projectile using the existing velocity. + + projectile%position=projectile%position + dt * projectile%velocity + + case("analytic") + ! Move the projectile using s= u*dt + 0.5*a*dt**2 + + projectile%position=projectile%position + dt * projectile%velocity & + & + 0.5_D*dt**2*(/0.0_D, -gravity/) + + case default + write(0,*) "Unknown time integration scheme" + + end select + + ! Calculate the new velocity. + projectile%velocity=projectile%velocity + dt * (/0.0_D, -gravity/) + + ! Deactivate projectiles which touch the ground. + if (projectile%position(2)<=0.0) then + projectile%active=.false. + end if + + end subroutine move_projectile + end program ballistics diff --git a/libvtkfortran/fvtkfortran.F90 b/libvtkfortran/fvtkfortran.F90 index 281d93b9f5..e178984520 100644 --- a/libvtkfortran/fvtkfortran.F90 +++ b/libvtkfortran/fvtkfortran.F90 @@ -26,444 +26,444 @@ !!$ USA module vtkfortran - !!< This module merely contains explicit interfaces to allow the - !!< convenient use of vtkfortran in fortran. - use iso_c_binding - - private - - ! Element types from VTK - integer, public, parameter :: VTK_VERTEX=1 - integer, public, parameter :: VTK_POLY_VERTEX=2 - integer, public, parameter :: VTK_LINE=3 - integer, public, parameter :: VTK_POLY_LINE=4 - integer, public, parameter :: VTK_TRIANGLE=5 - integer, public, parameter :: VTK_TRIANGLE_STRIP=6 - integer, public, parameter :: VTK_POLYGON=7 - integer, public, parameter :: VTK_PIXEL=8 - integer, public, parameter :: VTK_QUAD=9 - integer, public, parameter :: VTK_TETRA=10 - integer, public, parameter :: VTK_VOXEL=11 - integer, public, parameter :: VTK_HEXAHEDRON=12 - integer, public, parameter :: VTK_WEDGE=13 - integer, public, parameter :: VTK_PYRAMID=14 - - integer, public, parameter :: VTK_QUADRATIC_EDGE=21 - integer, public, parameter :: VTK_QUADRATIC_TRIANGLE=22 - integer, public, parameter :: VTK_QUADRATIC_QUAD=23 - integer, public, parameter :: VTK_QUADRATIC_TETRA=24 - integer, public, parameter :: VTK_QUADRATIC_HEXAHEDRON=25 - - public :: vtkopen, vtkclose, vtkpclose, vtkwritemesh, vtkwritesn,& - & vtkwritesc, vtkwritevn, vtkwritevc, vtkwritetn, vtkwritetc, & - & vtksetactivescalars, vtksetactivevectors, & - & vtksetactivetensors - - interface vtkopen - subroutine vtkopen_c(outName, len1, vtkTitle, len2) bind(c,name="vtkopen") - use iso_c_binding - implicit none - character(kind=c_char,len=1), dimension(*) :: outName - integer(kind=c_int) :: len1 - character(kind=c_char,len=1), dimension(*) :: vtkTitle - integer(kind=c_int) :: len2 - end subroutine vtkopen_c - module procedure vtkopen_f90 - end interface - - interface vtkclose - ! Close the current vtk file. - subroutine vtkclose() bind(c) - end subroutine vtkclose - end interface - - interface vtkpclose - ! Close the current vtk file - creates a parallel file. - subroutine vtkpclose(rank, npartitions) bind(c) - use iso_c_binding - implicit none - integer(kind=c_int) :: rank, npartitions - end subroutine vtkpclose - end interface - - interface vtkwritemesh - ! Write mesh information to the current vtk file. - SUBROUTINE VTKWRITEMESH(NNodes, NElems, x, y, z, enlist, & - elementTypes, elementSizes) bind(c) - use iso_c_binding - implicit none - integer(kind=c_int) :: NNodes - integer(kind=c_int) :: NElems - REAL(c_float) :: x(*) - REAL(c_float) :: y(*) - REAL(c_float) :: z(*) - integer(kind=c_int) :: enlist(*) - integer(kind=c_int) :: elementTypes(*) - integer(kind=c_int) :: elementSizes(*) - end SUBROUTINE VTKWRITEMESH - SUBROUTINE VTKWRITEMESHD(NNodes, NElems, x, y, z, enlist, & - elementTypes, elementSizes) bind(c) - use iso_c_binding - implicit none - integer(kind=c_int) :: NNodes - integer(kind=c_int) :: NElems - REAL(c_double) :: x(*) - REAL(c_double) :: y(*) - REAL(c_double) :: z(*) - integer(kind=c_int) :: enlist(*) - integer(kind=c_int) :: elementTypes(*) - integer(kind=c_int) :: elementSizes(*) - end SUBROUTINE VTKWRITEMESHD - end interface - - interface vtkwritesn - ! Write a scalar field to the current vtk file. - SUBROUTINE VTKWRITEISN_C(vect, name, len) bind(c,name="vtkwriteisn") - use iso_c_binding - implicit none - integer(kind=c_int) :: vect(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEISN_C - SUBROUTINE VTKWRITEFSN_C(vect, name, len) bind(c,name="vtkwritefsn") - use iso_c_binding - implicit none - REAL(c_float) :: vect(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEFSN_C - SUBROUTINE VTKWRITEDSN_C(vect, name, len) bind(c,name="vtkwritedsn") - use iso_c_binding - implicit none - REAL(c_double) :: vect(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEDSN_C - module procedure vtkwriteisn_f90, vtkwritefsn_f90, vtkwritedsn_f90 - end interface - - interface vtkwritesc - ! Write a scalar field (cell-based) to the current vtk file. - SUBROUTINE VTKWRITEISC_C(vect, name, len) bind(c,name="vtkwriteisc") - use iso_c_binding - implicit none - integer(kind=c_int) :: vect(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEISC_C - SUBROUTINE VTKWRITEFSC_C(vect, name, len) bind(c,name="vtkwritefsc") - use iso_c_binding - implicit none - REAL(c_float) :: vect(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEFSC_C - SUBROUTINE VTKWRITEDSC_C(vect, name, len) bind(c,name="vtkwritedsc") - use iso_c_binding - implicit none - REAL(c_double) :: vect(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEDSC_C - module procedure vtkwriteisc_f90, vtkwritefsc_f90, vtkwritedsc_f90 - end interface - - interface vtkwritevn - ! Write a vector field to the current vtk file. - SUBROUTINE VTKWRITEFVN_C(vx, vy, vz, name, len) bind(c,name="vtkwritefvn") - use iso_c_binding - implicit none - REAL(c_float) :: vx(*) - REAL(c_float) :: vy(*) - REAL(c_float) :: vz(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEFVN_C - SUBROUTINE VTKWRITEDVN_C(vx, vy, vz, name, len) bind(c,name="vtkwritedvn") - use iso_c_binding - implicit none - REAL(c_double) :: vx(*) - REAL(c_double) :: vy(*) - REAL(c_double) :: vz(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEDVN_C - module procedure vtkwritefvn_f90, vtkwritedvn_f90 - end interface - - interface vtkwritevc - ! Write a vector field (cell-based) to the current vtk file. - SUBROUTINE VTKWRITEFVC_C(vx, vy, vz, name, len) bind(c,name="vtkwritefvc") - use iso_c_binding - implicit none - REAL(c_float) :: vx(*) - REAL(c_float) :: vy(*) - REAL(c_float) :: vz(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEFVC_C - SUBROUTINE VTKWRITEDVC_C(vx, vy, vz, name, len) bind(c,name="vtkwritedvc") - use iso_c_binding - implicit none - REAL(c_double) :: vx(*) - REAL(c_double) :: vy(*) - REAL(c_double) :: vz(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEDVC_C - module procedure vtkwritefvc_f90, vtkwritedvc_f90 - end interface - - interface vtkwritetn - ! Write a tensor field to the current vtk file. - SUBROUTINE VTKWRITEFTN_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name,& - & len) bind(c,name="vtkwriteftn") - use iso_c_binding - implicit none - REAL(c_float) :: v1(*) - REAL(c_float) :: v2(*) - REAL(c_float) :: v3(*) - REAL(c_float) :: v4(*) - REAL(c_float) :: v5(*) - REAL(c_float) :: v6(*) - REAL(c_float) :: v7(*) - REAL(c_float) :: v8(*) - REAL(c_float) :: v9(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEFTN_C - SUBROUTINE VTKWRITEDTN_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len)& - & bind(c,name="vtkwritedtn") - use iso_c_binding - implicit none - REAL(c_double) :: v1(*) - REAL(c_double) :: v2(*) - REAL(c_double) :: v3(*) - REAL(c_double) :: v4(*) - REAL(c_double) :: v5(*) - REAL(c_double) :: v6(*) - REAL(c_double) :: v7(*) - REAL(c_double) :: v8(*) - REAL(c_double) :: v9(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEDTN_C - module procedure vtkwriteftn_f90, vtkwritedtn_f90 - end interface - - interface vtkwritetc - ! Write a tensor field (cell-based) to the current vtk file. - SUBROUTINE VTKWRITEFTC_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name,& - & len) bind(c,name="vtkwriteftc") - use iso_c_binding - implicit none - REAL(c_float) :: v1(*) - REAL(c_float) :: v2(*) - REAL(c_float) :: v3(*) - REAL(c_float) :: v4(*) - REAL(c_float) :: v5(*) - REAL(c_float) :: v6(*) - REAL(c_float) :: v7(*) - REAL(c_float) :: v8(*) - REAL(c_float) :: v9(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEFTC_C - SUBROUTINE VTKWRITEDTC_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name,& - & len) bind(c,name="vtkwritedtc") - use iso_c_binding - implicit none - REAL(c_double) :: v1(*) - REAL(c_double) :: v2(*) - REAL(c_double) :: v3(*) - REAL(c_double) :: v4(*) - REAL(c_double) :: v5(*) - REAL(c_double) :: v6(*) - REAL(c_double) :: v7(*) - REAL(c_double) :: v8(*) - REAL(c_double) :: v9(*) - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end SUBROUTINE VTKWRITEDTC_C - module procedure vtkwriteftc_f90, vtkwritedtc_f90 - end interface - - interface vtksetactivescalars - subroutine vtksetactivescalars_c(name, len) bind(c,name="vtksetactivescalars") - use iso_c_binding - implicit none - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end subroutine vtksetactivescalars_c - module procedure vtksetactivescalars_f90 - end interface - - interface vtksetactivevectors - subroutine vtksetactivevectors_c(name, len) bind(c,name="vtksetactivevectors") - use iso_c_binding - implicit none - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end subroutine vtksetactivevectors_c - module procedure vtksetactivevectors_f90 - end interface - - interface vtksetactivetensors - subroutine vtksetactivetensors_c(name, len) bind(c,name="vtksetactivetensors") - use iso_c_binding - implicit none - character(kind=c_char,len=1), dimension(*) :: name - integer(kind=c_int) :: len - end subroutine vtksetactivetensors_c - module procedure vtksetactivetensors_f90 - end interface + !!< This module merely contains explicit interfaces to allow the + !!< convenient use of vtkfortran in fortran. + use iso_c_binding + + private + + ! Element types from VTK + integer, public, parameter :: VTK_VERTEX=1 + integer, public, parameter :: VTK_POLY_VERTEX=2 + integer, public, parameter :: VTK_LINE=3 + integer, public, parameter :: VTK_POLY_LINE=4 + integer, public, parameter :: VTK_TRIANGLE=5 + integer, public, parameter :: VTK_TRIANGLE_STRIP=6 + integer, public, parameter :: VTK_POLYGON=7 + integer, public, parameter :: VTK_PIXEL=8 + integer, public, parameter :: VTK_QUAD=9 + integer, public, parameter :: VTK_TETRA=10 + integer, public, parameter :: VTK_VOXEL=11 + integer, public, parameter :: VTK_HEXAHEDRON=12 + integer, public, parameter :: VTK_WEDGE=13 + integer, public, parameter :: VTK_PYRAMID=14 + + integer, public, parameter :: VTK_QUADRATIC_EDGE=21 + integer, public, parameter :: VTK_QUADRATIC_TRIANGLE=22 + integer, public, parameter :: VTK_QUADRATIC_QUAD=23 + integer, public, parameter :: VTK_QUADRATIC_TETRA=24 + integer, public, parameter :: VTK_QUADRATIC_HEXAHEDRON=25 + + public :: vtkopen, vtkclose, vtkpclose, vtkwritemesh, vtkwritesn,& + & vtkwritesc, vtkwritevn, vtkwritevc, vtkwritetn, vtkwritetc, & + & vtksetactivescalars, vtksetactivevectors, & + & vtksetactivetensors + + interface vtkopen + subroutine vtkopen_c(outName, len1, vtkTitle, len2) bind(c,name="vtkopen") + use iso_c_binding + implicit none + character(kind=c_char,len=1), dimension(*) :: outName + integer(kind=c_int) :: len1 + character(kind=c_char,len=1), dimension(*) :: vtkTitle + integer(kind=c_int) :: len2 + end subroutine vtkopen_c + module procedure vtkopen_f90 + end interface + + interface vtkclose + ! Close the current vtk file. + subroutine vtkclose() bind(c) + end subroutine vtkclose + end interface + + interface vtkpclose + ! Close the current vtk file - creates a parallel file. + subroutine vtkpclose(rank, npartitions) bind(c) + use iso_c_binding + implicit none + integer(kind=c_int) :: rank, npartitions + end subroutine vtkpclose + end interface + + interface vtkwritemesh + ! Write mesh information to the current vtk file. + SUBROUTINE VTKWRITEMESH(NNodes, NElems, x, y, z, enlist, & + elementTypes, elementSizes) bind(c) + use iso_c_binding + implicit none + integer(kind=c_int) :: NNodes + integer(kind=c_int) :: NElems + REAL(c_float) :: x(*) + REAL(c_float) :: y(*) + REAL(c_float) :: z(*) + integer(kind=c_int) :: enlist(*) + integer(kind=c_int) :: elementTypes(*) + integer(kind=c_int) :: elementSizes(*) + end SUBROUTINE VTKWRITEMESH + SUBROUTINE VTKWRITEMESHD(NNodes, NElems, x, y, z, enlist, & + elementTypes, elementSizes) bind(c) + use iso_c_binding + implicit none + integer(kind=c_int) :: NNodes + integer(kind=c_int) :: NElems + REAL(c_double) :: x(*) + REAL(c_double) :: y(*) + REAL(c_double) :: z(*) + integer(kind=c_int) :: enlist(*) + integer(kind=c_int) :: elementTypes(*) + integer(kind=c_int) :: elementSizes(*) + end SUBROUTINE VTKWRITEMESHD + end interface + + interface vtkwritesn + ! Write a scalar field to the current vtk file. + SUBROUTINE VTKWRITEISN_C(vect, name, len) bind(c,name="vtkwriteisn") + use iso_c_binding + implicit none + integer(kind=c_int) :: vect(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEISN_C + SUBROUTINE VTKWRITEFSN_C(vect, name, len) bind(c,name="vtkwritefsn") + use iso_c_binding + implicit none + REAL(c_float) :: vect(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEFSN_C + SUBROUTINE VTKWRITEDSN_C(vect, name, len) bind(c,name="vtkwritedsn") + use iso_c_binding + implicit none + REAL(c_double) :: vect(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEDSN_C + module procedure vtkwriteisn_f90, vtkwritefsn_f90, vtkwritedsn_f90 + end interface + + interface vtkwritesc + ! Write a scalar field (cell-based) to the current vtk file. + SUBROUTINE VTKWRITEISC_C(vect, name, len) bind(c,name="vtkwriteisc") + use iso_c_binding + implicit none + integer(kind=c_int) :: vect(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEISC_C + SUBROUTINE VTKWRITEFSC_C(vect, name, len) bind(c,name="vtkwritefsc") + use iso_c_binding + implicit none + REAL(c_float) :: vect(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEFSC_C + SUBROUTINE VTKWRITEDSC_C(vect, name, len) bind(c,name="vtkwritedsc") + use iso_c_binding + implicit none + REAL(c_double) :: vect(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEDSC_C + module procedure vtkwriteisc_f90, vtkwritefsc_f90, vtkwritedsc_f90 + end interface + + interface vtkwritevn + ! Write a vector field to the current vtk file. + SUBROUTINE VTKWRITEFVN_C(vx, vy, vz, name, len) bind(c,name="vtkwritefvn") + use iso_c_binding + implicit none + REAL(c_float) :: vx(*) + REAL(c_float) :: vy(*) + REAL(c_float) :: vz(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEFVN_C + SUBROUTINE VTKWRITEDVN_C(vx, vy, vz, name, len) bind(c,name="vtkwritedvn") + use iso_c_binding + implicit none + REAL(c_double) :: vx(*) + REAL(c_double) :: vy(*) + REAL(c_double) :: vz(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEDVN_C + module procedure vtkwritefvn_f90, vtkwritedvn_f90 + end interface + + interface vtkwritevc + ! Write a vector field (cell-based) to the current vtk file. + SUBROUTINE VTKWRITEFVC_C(vx, vy, vz, name, len) bind(c,name="vtkwritefvc") + use iso_c_binding + implicit none + REAL(c_float) :: vx(*) + REAL(c_float) :: vy(*) + REAL(c_float) :: vz(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEFVC_C + SUBROUTINE VTKWRITEDVC_C(vx, vy, vz, name, len) bind(c,name="vtkwritedvc") + use iso_c_binding + implicit none + REAL(c_double) :: vx(*) + REAL(c_double) :: vy(*) + REAL(c_double) :: vz(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEDVC_C + module procedure vtkwritefvc_f90, vtkwritedvc_f90 + end interface + + interface vtkwritetn + ! Write a tensor field to the current vtk file. + SUBROUTINE VTKWRITEFTN_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name,& + & len) bind(c,name="vtkwriteftn") + use iso_c_binding + implicit none + REAL(c_float) :: v1(*) + REAL(c_float) :: v2(*) + REAL(c_float) :: v3(*) + REAL(c_float) :: v4(*) + REAL(c_float) :: v5(*) + REAL(c_float) :: v6(*) + REAL(c_float) :: v7(*) + REAL(c_float) :: v8(*) + REAL(c_float) :: v9(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEFTN_C + SUBROUTINE VTKWRITEDTN_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len)& + & bind(c,name="vtkwritedtn") + use iso_c_binding + implicit none + REAL(c_double) :: v1(*) + REAL(c_double) :: v2(*) + REAL(c_double) :: v3(*) + REAL(c_double) :: v4(*) + REAL(c_double) :: v5(*) + REAL(c_double) :: v6(*) + REAL(c_double) :: v7(*) + REAL(c_double) :: v8(*) + REAL(c_double) :: v9(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEDTN_C + module procedure vtkwriteftn_f90, vtkwritedtn_f90 + end interface + + interface vtkwritetc + ! Write a tensor field (cell-based) to the current vtk file. + SUBROUTINE VTKWRITEFTC_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name,& + & len) bind(c,name="vtkwriteftc") + use iso_c_binding + implicit none + REAL(c_float) :: v1(*) + REAL(c_float) :: v2(*) + REAL(c_float) :: v3(*) + REAL(c_float) :: v4(*) + REAL(c_float) :: v5(*) + REAL(c_float) :: v6(*) + REAL(c_float) :: v7(*) + REAL(c_float) :: v8(*) + REAL(c_float) :: v9(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEFTC_C + SUBROUTINE VTKWRITEDTC_C(v1, v2, v3, v4, v5, v6, v7, v8, v9, name,& + & len) bind(c,name="vtkwritedtc") + use iso_c_binding + implicit none + REAL(c_double) :: v1(*) + REAL(c_double) :: v2(*) + REAL(c_double) :: v3(*) + REAL(c_double) :: v4(*) + REAL(c_double) :: v5(*) + REAL(c_double) :: v6(*) + REAL(c_double) :: v7(*) + REAL(c_double) :: v8(*) + REAL(c_double) :: v9(*) + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end SUBROUTINE VTKWRITEDTC_C + module procedure vtkwriteftc_f90, vtkwritedtc_f90 + end interface + + interface vtksetactivescalars + subroutine vtksetactivescalars_c(name, len) bind(c,name="vtksetactivescalars") + use iso_c_binding + implicit none + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end subroutine vtksetactivescalars_c + module procedure vtksetactivescalars_f90 + end interface + + interface vtksetactivevectors + subroutine vtksetactivevectors_c(name, len) bind(c,name="vtksetactivevectors") + use iso_c_binding + implicit none + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end subroutine vtksetactivevectors_c + module procedure vtksetactivevectors_f90 + end interface + + interface vtksetactivetensors + subroutine vtksetactivetensors_c(name, len) bind(c,name="vtksetactivetensors") + use iso_c_binding + implicit none + character(kind=c_char,len=1), dimension(*) :: name + integer(kind=c_int) :: len + end subroutine vtksetactivetensors_c + module procedure vtksetactivetensors_f90 + end interface contains - subroutine vtkopen_f90(outName, vtkTitle) - ! Wrapper routine with nicer interface. - character(len=*), intent(in) :: outName, vtkTitle + subroutine vtkopen_f90(outName, vtkTitle) + ! Wrapper routine with nicer interface. + character(len=*), intent(in) :: outName, vtkTitle - call vtkopen_c(outName, len(outName), vtkTitle, len(vtkTitle)) + call vtkopen_c(outName, len(outName), vtkTitle, len(vtkTitle)) - end subroutine vtkopen_f90 + end subroutine vtkopen_f90 - subroutine vtkwriteisn_f90(vect, name) - ! Wrapper routine with nicer interface. - integer, intent(in) :: vect(*) - character(len=*), intent(in) :: name + subroutine vtkwriteisn_f90(vect, name) + ! Wrapper routine with nicer interface. + integer, intent(in) :: vect(*) + character(len=*), intent(in) :: name - call vtkwriteisn_c(vect, name, len(name)) + call vtkwriteisn_c(vect, name, len(name)) - end subroutine vtkwriteisn_f90 + end subroutine vtkwriteisn_f90 - subroutine vtkwritefsn_f90(vect, name) - ! Wrapper routine with nicer interface. - real(c_float), intent(in) :: vect(*) - character(len=*), intent(in) :: name + subroutine vtkwritefsn_f90(vect, name) + ! Wrapper routine with nicer interface. + real(c_float), intent(in) :: vect(*) + character(len=*), intent(in) :: name - call vtkwritefsn_c(vect, name, len(name)) + call vtkwritefsn_c(vect, name, len(name)) - end subroutine vtkwritefsn_f90 + end subroutine vtkwritefsn_f90 - subroutine vtkwritedsn_f90(vect, name) - ! Wrapper routine with nicer interface. - real(c_double), intent(in) :: vect(*) - character(len=*), intent(in) :: name + subroutine vtkwritedsn_f90(vect, name) + ! Wrapper routine with nicer interface. + real(c_double), intent(in) :: vect(*) + character(len=*), intent(in) :: name - call vtkwritedsn_c(vect, name, len(name)) - end subroutine vtkwritedsn_f90 + call vtkwritedsn_c(vect, name, len(name)) + end subroutine vtkwritedsn_f90 - subroutine vtkwriteisc_f90(vect, name) - ! Wrapper routine with nicer interface. - integer, intent(in) :: vect(*) - character(len=*), intent(in) :: name + subroutine vtkwriteisc_f90(vect, name) + ! Wrapper routine with nicer interface. + integer, intent(in) :: vect(*) + character(len=*), intent(in) :: name - call vtkwriteisc_c(vect, name, len(name)) + call vtkwriteisc_c(vect, name, len(name)) - end subroutine vtkwriteisc_f90 + end subroutine vtkwriteisc_f90 - subroutine vtkwritefsc_f90(vect, name) - ! Wrapper routine with nicer interface. - real(c_float), intent(in) :: vect(*) - character(len=*), intent(in) :: name + subroutine vtkwritefsc_f90(vect, name) + ! Wrapper routine with nicer interface. + real(c_float), intent(in) :: vect(*) + character(len=*), intent(in) :: name - call vtkwritefsc_c(vect, name, len(name)) + call vtkwritefsc_c(vect, name, len(name)) - end subroutine vtkwritefsc_f90 + end subroutine vtkwritefsc_f90 - subroutine vtkwritedsc_f90(vect, name) - ! Wrapper routine with nicer interface. - real(c_double), intent(in) :: vect(*) - character(len=*), intent(in) :: name + subroutine vtkwritedsc_f90(vect, name) + ! Wrapper routine with nicer interface. + real(c_double), intent(in) :: vect(*) + character(len=*), intent(in) :: name - call vtkwritedsc_c(vect, name, len(name)) - end subroutine vtkwritedsc_f90 + call vtkwritedsc_c(vect, name, len(name)) + end subroutine vtkwritedsc_f90 - subroutine vtkwritefvn_f90(vx, vy, vz, name) - REAL(c_float), intent(in) :: vx(*), vy(*), vz(*) - character(len=*) name + subroutine vtkwritefvn_f90(vx, vy, vz, name) + REAL(c_float), intent(in) :: vx(*), vy(*), vz(*) + character(len=*) name - call vtkwritefvn_c(vx, vy, vz, name, len(name)) + call vtkwritefvn_c(vx, vy, vz, name, len(name)) - end subroutine vtkwritefvn_f90 + end subroutine vtkwritefvn_f90 - subroutine vtkwritedvn_f90(vx, vy, vz, name) - REAL(c_double), intent(in) :: vx(*), vy(*), vz(*) - character(len=*) name + subroutine vtkwritedvn_f90(vx, vy, vz, name) + REAL(c_double), intent(in) :: vx(*), vy(*), vz(*) + character(len=*) name - call vtkwritedvn_c(vx, vy, vz, name, len(name)) + call vtkwritedvn_c(vx, vy, vz, name, len(name)) - end subroutine vtkwritedvn_f90 + end subroutine vtkwritedvn_f90 - subroutine vtkwritefvc_f90(vx, vy, vz, name) - REAL(c_float), intent(in) :: vx(*), vy(*), vz(*) - character(len=*) name + subroutine vtkwritefvc_f90(vx, vy, vz, name) + REAL(c_float), intent(in) :: vx(*), vy(*), vz(*) + character(len=*) name - call vtkwritefvc_c(vx, vy, vz, name, len(name)) + call vtkwritefvc_c(vx, vy, vz, name, len(name)) - end subroutine vtkwritefvc_f90 + end subroutine vtkwritefvc_f90 - subroutine vtkwritedvc_f90(vx, vy, vz, name) - REAL(c_double), intent(in) :: vx(*), vy(*), vz(*) - character(len=*) name + subroutine vtkwritedvc_f90(vx, vy, vz, name) + REAL(c_double), intent(in) :: vx(*), vy(*), vz(*) + character(len=*) name - call vtkwritedvc_c(vx, vy, vz, name, len(name)) + call vtkwritedvc_c(vx, vy, vz, name, len(name)) - end subroutine vtkwritedvc_f90 + end subroutine vtkwritedvc_f90 - subroutine vtkwriteftn_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) - REAL(c_float), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) - character(len=*) name + subroutine vtkwriteftn_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) + REAL(c_float), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) + character(len=*) name - call vtkwriteftn_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) + call vtkwriteftn_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) - end subroutine vtkwriteftn_f90 + end subroutine vtkwriteftn_f90 - subroutine vtkwritedtn_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) - REAL(c_double), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) - character(len=*) name + subroutine vtkwritedtn_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) + REAL(c_double), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) + character(len=*) name - call vtkwritedtn_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) + call vtkwritedtn_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) - end subroutine vtkwritedtn_f90 + end subroutine vtkwritedtn_f90 - subroutine vtkwriteftc_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) - REAL(c_float), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) - character(len=*) name + subroutine vtkwriteftc_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) + REAL(c_float), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) + character(len=*) name - call vtkwriteftc_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) + call vtkwriteftc_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) - end subroutine vtkwriteftc_f90 + end subroutine vtkwriteftc_f90 - subroutine vtkwritedtc_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) - REAL(c_double), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) - character(len=*) name + subroutine vtkwritedtc_f90(v1, v2, v3, v4, v5, v6, v7, v8, v9, name) + REAL(c_double), intent(in) :: v1(*), v2(*), v3(*), v4(*), v5(*), v6(*), v7(*), v8(*), v9(*) + character(len=*) name - call vtkwritedtc_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) + call vtkwritedtc_c(v1, v2, v3, v4, v5, v6, v7, v8, v9, name, len(name)) - end subroutine vtkwritedtc_f90 + end subroutine vtkwritedtc_f90 - subroutine vtksetactivescalars_f90(name) - character(len=*) name + subroutine vtksetactivescalars_f90(name) + character(len=*) name - call vtksetactivescalars_c(name, len_trim(name)) + call vtksetactivescalars_c(name, len_trim(name)) - end subroutine vtksetactivescalars_f90 + end subroutine vtksetactivescalars_f90 - subroutine vtksetactivevectors_f90(name) - character(len=*) name + subroutine vtksetactivevectors_f90(name) + character(len=*) name - call vtksetactivevectors_c(name, len_trim(name)) + call vtksetactivevectors_c(name, len_trim(name)) - end subroutine vtksetactivevectors_f90 + end subroutine vtksetactivevectors_f90 - subroutine vtksetactivetensors_f90(name) - character(len=*) name + subroutine vtksetactivetensors_f90(name) + character(len=*) name - call vtksetactivetensors_c(name, len_trim(name)) + call vtksetactivetensors_c(name, len_trim(name)) - end subroutine vtksetactivetensors_f90 + end subroutine vtksetactivetensors_f90 end module vtkfortran diff --git a/main/Fluids.F90 b/main/Fluids.F90 index ed35435e22..d186565a78 100644 --- a/main/Fluids.F90 +++ b/main/Fluids.F90 @@ -29,1096 +29,1096 @@ module fluids_module - use fldebug - use auxilaryoptions - use spud - use global_parameters, only: current_time, dt, timestep, OPTION_PATH_LEN, & - simulation_start_time, & - simulation_start_cpu_time, & - simulation_start_wall_time, & - topology_mesh_name, FIELD_NAME_LEN - use futils, only: int2str - use reference_counting, only: print_references - use parallel_tools - use memory_diagnostics - use sparse_tools - use elements - use adjacency_lists - use eventcounter - use transform_elements, only: cache_transform_elements, deallocate_transform_cache - use meshdiagnostics - use signal_vars - use fields - use state_module - use vtk_interfaces - use boundary_conditions - use halos - use equation_of_state - use timers - use synthetic_bc - use k_epsilon, only: keps_advdif_diagnostics - use tictoc - use boundary_conditions_from_options - use reserve_state_module - use write_state_module - use detector_parallel, only: sync_detector_coordinates, deallocate_detector_list_array - use particles - use diagnostic_variables - use populate_state_module - use vertical_extrapolation_module - use field_priority_lists - use multiphase_module - use multimaterial_module - use free_surface_module - use momentum_diagnostic_fields, only: calculate_densities - use sediment_diagnostics, only: calculate_sediment_flux - use dqmom - use diagnostic_fields_wrapper - use particle_diagnostics, only: calculate_diagnostic_fields_from_particles, calculate_particle_material_fields, & - initialise_constant_particle_diagnostics, particle_cv_check - use checkpoint - use goals - use adaptive_timestepping - use conformity_measurement - use timeloop_utilities - use discrete_properties_module - use adapt_state_module - use adapt_state_prescribed_module - use populate_sub_state_module - use diagnostic_fields_new, only : & - & calculate_diagnostic_variables_new => calculate_diagnostic_variables, & - & check_diagnostic_dependencies - use diagnostic_children - use advection_diffusion_cg - use advection_diffusion_dg - use advection_diffusion_fv - use field_equations_cv, only: solve_field_eqn_cv, initialise_advection_convergence, coupled_cv_field_eqn - use qmesh_module - use write_triangle - use meshmovement - use biology - use foam_flow_module, only: calculate_potential_flow, calculate_foam_velocity - use momentum_equation - use gls - use iceshelf_meltrate_surf_normal + use fldebug + use auxilaryoptions + use spud + use global_parameters, only: current_time, dt, timestep, OPTION_PATH_LEN, & + simulation_start_time, & + simulation_start_cpu_time, & + simulation_start_wall_time, & + topology_mesh_name, FIELD_NAME_LEN + use futils, only: int2str + use reference_counting, only: print_references + use parallel_tools + use memory_diagnostics + use sparse_tools + use elements + use adjacency_lists + use eventcounter + use transform_elements, only: cache_transform_elements, deallocate_transform_cache + use meshdiagnostics + use signal_vars + use fields + use state_module + use vtk_interfaces + use boundary_conditions + use halos + use equation_of_state + use timers + use synthetic_bc + use k_epsilon, only: keps_advdif_diagnostics + use tictoc + use boundary_conditions_from_options + use reserve_state_module + use write_state_module + use detector_parallel, only: sync_detector_coordinates, deallocate_detector_list_array + use particles + use diagnostic_variables + use populate_state_module + use vertical_extrapolation_module + use field_priority_lists + use multiphase_module + use multimaterial_module + use free_surface_module + use momentum_diagnostic_fields, only: calculate_densities + use sediment_diagnostics, only: calculate_sediment_flux + use dqmom + use diagnostic_fields_wrapper + use particle_diagnostics, only: calculate_diagnostic_fields_from_particles, calculate_particle_material_fields, & + initialise_constant_particle_diagnostics, particle_cv_check + use checkpoint + use goals + use adaptive_timestepping + use conformity_measurement + use timeloop_utilities + use discrete_properties_module + use adapt_state_module + use adapt_state_prescribed_module + use populate_sub_state_module + use diagnostic_fields_new, only : & + & calculate_diagnostic_variables_new => calculate_diagnostic_variables, & + & check_diagnostic_dependencies + use diagnostic_children + use advection_diffusion_cg + use advection_diffusion_dg + use advection_diffusion_fv + use field_equations_cv, only: solve_field_eqn_cv, initialise_advection_convergence, coupled_cv_field_eqn + use qmesh_module + use write_triangle + use meshmovement + use biology + use foam_flow_module, only: calculate_potential_flow, calculate_foam_velocity + use momentum_equation + use gls + use iceshelf_meltrate_surf_normal #ifdef HAVE_HYPERLIGHT - use hyperlight + use hyperlight #endif - implicit none + implicit none - private + private - public :: fluids, fluids_module_check_options + public :: fluids, fluids_module_check_options - interface - subroutine check_options - end subroutine check_options - end interface + interface + subroutine check_options + end subroutine check_options + end interface contains - SUBROUTINE FLUIDS() - character(len = OPTION_PATH_LEN) :: filename + SUBROUTINE FLUIDS() + character(len = OPTION_PATH_LEN) :: filename - INTEGER :: & - & NTSOL, & - & nonlinear_iterations, & - & nonlinear_iterations_adapt + INTEGER :: & + & NTSOL, & + & nonlinear_iterations, & + & nonlinear_iterations_adapt - REAL :: & - & finish_time, & - & steady_state_tolerance + REAL :: & + & finish_time, & + & steady_state_tolerance - real:: nonlinear_iteration_tolerance + real:: nonlinear_iteration_tolerance - ! System state wrapper. - type(state_type), dimension(:), pointer :: state => null() - type(state_type), dimension(:), pointer :: sub_state => null() + ! System state wrapper. + type(state_type), dimension(:), pointer :: state => null() + type(state_type), dimension(:), pointer :: sub_state => null() - type(tensor_field) :: metric_tensor - ! Dump index - integer :: dump_no = 0 - ! Temporary buffer for any string options which may be required. - character(len=OPTION_PATH_LEN) :: option_buffer - character(len=OPTION_PATH_LEN):: option_path - REAL :: CHANGE,CHAOLD + type(tensor_field) :: metric_tensor + ! Dump index + integer :: dump_no = 0 + ! Temporary buffer for any string options which may be required. + character(len=OPTION_PATH_LEN) :: option_buffer + character(len=OPTION_PATH_LEN):: option_path + REAL :: CHANGE,CHAOLD - integer :: i, it, its + integer :: i, it, its - logical :: not_to_move_det_yet = .false. + logical :: not_to_move_det_yet = .false. - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - ! An array of submaterials of the current phase in state(istate). - ! Needed for k-epsilon VelocityBuoyancyDensity calculation line:~630 - ! S Parkinson 31-08-12 - type(state_type), dimension(:), pointer :: submaterials + ! An array of submaterials of the current phase in state(istate). + ! Needed for k-epsilon VelocityBuoyancyDensity calculation line:~630 + ! S Parkinson 31-08-12 + type(state_type), dimension(:), pointer :: submaterials - ! Pointers for scalars and velocity fields - type(scalar_field), pointer :: sfield - type(scalar_field) :: foam_velocity_potential - type(vector_field), pointer :: foamvel - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + ! Pointers for scalars and velocity fields + type(scalar_field), pointer :: sfield + type(scalar_field) :: foam_velocity_potential + type(vector_field), pointer :: foamvel + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - ! backward compatibility with new option structure - crgw 21/12/07 - logical::use_advdif=.true. ! decide whether we enter advdif or not + ! backward compatibility with new option structure - crgw 21/12/07 + logical::use_advdif=.true. ! decide whether we enter advdif or not - INTEGER :: adapt_count + INTEGER :: adapt_count - ! Absolute first thing: check that the options, if present, are valid. - call check_options - ewrite(1,*) "Options sanity check successful" + ! Absolute first thing: check that the options, if present, are valid. + call check_options + ewrite(1,*) "Options sanity check successful" - call get_option("/simulation_name",filename) + call get_option("/simulation_name",filename) - call set_simulation_start_times() - call initialise_walltime - timestep = 0 + call set_simulation_start_times() + call initialise_walltime + timestep = 0 #ifdef HAVE_MEMORY_STATS - ! this is to make sure the option /io/log_output/memory_diagnostics is read - call reset_memory_logs() + ! this is to make sure the option /io/log_output/memory_diagnostics is read + call reset_memory_logs() #endif - call initialise_qmesh - call initialise_write_state + call initialise_qmesh + call initialise_write_state - ! Initialise Hyperlight + ! Initialise Hyperlight #ifdef HAVE_HYPERLIGHT - if (have_option("ocean_biology/lagrangian_ensemble/hyperlight")) then - if (.not.have_option("/material_phase[0]/scalar_field::Chlorophyll")) then - FLExit("You need Chlorophyll scalar field for Hyperlight") - else - call hyperlight_init() - end if - end if + if (have_option("ocean_biology/lagrangian_ensemble/hyperlight")) then + if (.not.have_option("/material_phase[0]/scalar_field::Chlorophyll")) then + FLExit("You need Chlorophyll scalar field for Hyperlight") + else + call hyperlight_init() + end if + end if #else - if (have_option("ocean_biology/lagrangian_ensemble/hyperlight")) then - ewrite(-1,*) "Hyperlight module was selected, but not compiled." - FLExit("Please re-compile fluidity with the --enable-hyperlight option.") - end if + if (have_option("ocean_biology/lagrangian_ensemble/hyperlight")) then + ewrite(-1,*) "Hyperlight module was selected, but not compiled." + FLExit("Please re-compile fluidity with the --enable-hyperlight option.") + end if #endif - if (have_option("/geometry/disable_geometric_data_cache")) then - ewrite(1,*) "Disabling geometric data cache" - cache_transform_elements=.false. - end if + if (have_option("/geometry/disable_geometric_data_cache")) then + ewrite(1,*) "Disabling geometric data cache" + cache_transform_elements=.false. + end if - adapt_count = 0 + adapt_count = 0 - ! Read state from .flml file - call populate_state(state) + ! Read state from .flml file + call populate_state(state) - ewrite(3,*)'before have_option test' + ewrite(3,*)'before have_option test' - ! Check the diagnostic field dependencies for circular dependencies - call check_diagnostic_dependencies(state) + ! Check the diagnostic field dependencies for circular dependencies + call check_diagnostic_dependencies(state) - default_stat%zoltan_drive_call=.false. + default_stat%zoltan_drive_call=.false. - ! For multiphase simulations, we have to call calculate_diagnostic_phase_volume_fraction *before* - ! copy_to_stored(state,"Old") is called below. Otherwise, OldPhaseVolumeFraction (in the phase - ! containing the diagnostic PhaseVolumeFraction) will be zero and - ! NonlinearPhaseVolumeFraction will be calculated incorrectly at t=0. - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - call calculate_diagnostic_phase_volume_fraction(state) - end if + ! For multiphase simulations, we have to call calculate_diagnostic_phase_volume_fraction *before* + ! copy_to_stored(state,"Old") is called below. Otherwise, OldPhaseVolumeFraction (in the phase + ! containing the diagnostic PhaseVolumeFraction) will be zero and + ! NonlinearPhaseVolumeFraction will be calculated incorrectly at t=0. + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + call calculate_diagnostic_phase_volume_fraction(state) + end if - ! set the nonlinear timestepping options, needs to be before the adapt at first timestep - call get_option('/timestepping/nonlinear_iterations',nonlinear_iterations,& - & default=1) - call get_option("/timestepping/nonlinear_iterations/tolerance", & - & nonlinear_iteration_tolerance, default=0.0) + ! set the nonlinear timestepping options, needs to be before the adapt at first timestep + call get_option('/timestepping/nonlinear_iterations',nonlinear_iterations,& + & default=1) + call get_option("/timestepping/nonlinear_iterations/tolerance", & + & nonlinear_iteration_tolerance, default=0.0) - ! Initialise positions of particles before adapt_at_first_timestep - call initialise_particles(filename, state) + ! Initialise positions of particles before adapt_at_first_timestep + call initialise_particles(filename, state) - if(have_option("/mesh_adaptivity/hr_adaptivity/adapt_at_first_timestep")) then + if(have_option("/mesh_adaptivity/hr_adaptivity/adapt_at_first_timestep")) then - if(have_option("/timestepping/nonlinear_iterations/nonlinear_iterations_at_adapt")) then - call get_option('/timestepping/nonlinear_iterations/nonlinear_iterations_at_adapt',nonlinear_iterations_adapt) - nonlinear_iterations = nonlinear_iterations_adapt - end if + if(have_option("/timestepping/nonlinear_iterations/nonlinear_iterations_at_adapt")) then + call get_option('/timestepping/nonlinear_iterations/nonlinear_iterations_at_adapt',nonlinear_iterations_adapt) + nonlinear_iterations = nonlinear_iterations_adapt + end if - ! set population balance initial conditions - for first adaptivity - call dqmom_init(state) + ! set population balance initial conditions - for first adaptivity + call dqmom_init(state) - call adapt_state_first_timestep(state) + call adapt_state_first_timestep(state) - ! Auxilliary fields. - call allocate_and_insert_auxilliary_fields(state) - call copy_to_stored_values(state,"Old") - call copy_to_stored_values(state,"Iterated") - call relax_to_nonlinear(state) + ! Auxilliary fields. + call allocate_and_insert_auxilliary_fields(state) + call copy_to_stored_values(state,"Old") + call copy_to_stored_values(state,"Iterated") + call relax_to_nonlinear(state) - call enforce_discrete_properties(state) + call enforce_discrete_properties(state) - ! Ensure that checkpoints do not adapt at first timestep. - call delete_option(& + ! Ensure that checkpoints do not adapt at first timestep. + call delete_option(& "/mesh_adaptivity/hr_adaptivity/adapt_at_first_timestep") - else - ! Auxilliary fields. - call allocate_and_insert_auxilliary_fields(state) - call copy_to_stored_values(state,"Old") - call copy_to_stored_values(state,"Iterated") - call relax_to_nonlinear(state) - - call enforce_discrete_properties(state) - end if - - ! set the remaining timestepping options, needs to be before any diagnostics are calculated - call get_option("/timestepping/timestep", dt) - if(have_option("/timestepping/adaptive_timestep/at_first_timestep")) then - call calc_cflnumber_field_based_dt(state, dt, force_calculation = .true.) - call set_option("/timestepping/timestep", dt) - end if - - call get_option("/timestepping/current_time", current_time) - call get_option("/timestepping/finish_time", finish_time) - - call get_option("/timestepping/steady_state/tolerance", & - & steady_state_tolerance, default = -666.01) - - if(use_sub_state()) then - call populate_sub_state(state,sub_state) - end if - - ! set population balance initial conditions - call dqmom_init(state) - - ! Calculate the number of scalar fields to solve for and their correct - ! solve order taking into account dependencies. - call get_ntsol(ntsol) - - call initialise_field_lists_from_options(state, ntsol) - - call check_old_code_path() - - ! Initialisation of distance to top and bottom field - ! Currently only needed for free surface - if (has_scalar_field(state(1), "DistanceToTop")) then - if (.not. have_option('/geometry/ocean_boundaries')) then - ewrite(-1,*) "Warning: You have a field called DistanceToTop" - ewrite(-1,*) "but you don't have ocean_boundaries switched on." - else - call CalculateTopBottomDistance(state(1)) - ! Initialise the OriginalDistanceToBottom field used for wetting and drying - if (have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then - call insert_original_distance_to_bottom(state(1)) - ! Wetting and drying only works with no poisson guess ... let's check that - call get_option("/material_phase[0]/scalar_field::Pressure/prognostic/scheme/poisson_pressure_solution", option_buffer) - if (.not. trim(option_buffer) == "never") then - FLExit("Please choose 'never' under /material_phase[0]/scalar_field::Pressure/prognostic/scheme/poisson_pressure_solution when using wetting and drying") - end if - end if - end if - end if - - ! move mesh according to inital free surface: - ! top/bottom distance needs to be up-to-date before this call, after the movement - ! they will be updated (inside the call) - call move_mesh_free_surface(state, initialise=.true.) - - call run_diagnostics(state) - - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - if (have_option("/mesh_adaptivity/hr_adaptivity")) then - call allocate(metric_tensor, extract_mesh(state(1), topology_mesh_name), "ErrorMetric") - end if - - ! Determine the output format. - call get_option('/io/dump_format', option_buffer) - if(trim(option_buffer) /= "vtk") then - ewrite(-1,*) "You must specify a dump format and it must be vtk." - FLExit("Rejig your FLML: /io/dump_format") - end if - - ! Initialise multimaterial fields: - call initialise_diagnostic_material_properties(state) - - ! Spawn particles to specified meshes - call particle_cv_check(state) - - ! Initialise MVF fields based on particles: - call initialise_constant_particle_diagnostics(state) - call calculate_particle_material_fields(state) - - ! Calculate diagnostic variables: - call calculate_diagnostic_variables(state) - call calculate_diagnostic_variables_new(state) - - ! Initialise particle attributes and dependent fields - call update_particle_attributes_and_fields(state, current_time, dt) - call calculate_diagnostic_fields_from_particles(state) - - ! This is mostly to ensure that the photosynthetic radiation - ! has a non-zero value before the first adapt. - if (have_option("/ocean_biology")) then - call calculate_biology_terms(state(1)) - end if - - call initialise_diagnostics(filename, state) - - ! Initialise ice_meltrate, read constatns, allocate surface, and calculate melt rate - if (have_option("/ocean_forcing/iceshelf_meltrate/Holland08")) then - call melt_surf_init(state(1)) - call melt_allocate_surface(state(1)) - call melt_surf_calc(state(1)) + else + ! Auxilliary fields. + call allocate_and_insert_auxilliary_fields(state) + call copy_to_stored_values(state,"Old") + call copy_to_stored_values(state,"Iterated") + call relax_to_nonlinear(state) + + call enforce_discrete_properties(state) + end if + + ! set the remaining timestepping options, needs to be before any diagnostics are calculated + call get_option("/timestepping/timestep", dt) + if(have_option("/timestepping/adaptive_timestep/at_first_timestep")) then + call calc_cflnumber_field_based_dt(state, dt, force_calculation = .true.) + call set_option("/timestepping/timestep", dt) + end if + + call get_option("/timestepping/current_time", current_time) + call get_option("/timestepping/finish_time", finish_time) + + call get_option("/timestepping/steady_state/tolerance", & + & steady_state_tolerance, default = -666.01) + + if(use_sub_state()) then + call populate_sub_state(state,sub_state) + end if + + ! set population balance initial conditions + call dqmom_init(state) + + ! Calculate the number of scalar fields to solve for and their correct + ! solve order taking into account dependencies. + call get_ntsol(ntsol) + + call initialise_field_lists_from_options(state, ntsol) + + call check_old_code_path() + + ! Initialisation of distance to top and bottom field + ! Currently only needed for free surface + if (has_scalar_field(state(1), "DistanceToTop")) then + if (.not. have_option('/geometry/ocean_boundaries')) then + ewrite(-1,*) "Warning: You have a field called DistanceToTop" + ewrite(-1,*) "but you don't have ocean_boundaries switched on." + else + call CalculateTopBottomDistance(state(1)) + ! Initialise the OriginalDistanceToBottom field used for wetting and drying + if (have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then + call insert_original_distance_to_bottom(state(1)) + ! Wetting and drying only works with no poisson guess ... let's check that + call get_option("/material_phase[0]/scalar_field::Pressure/prognostic/scheme/poisson_pressure_solution", option_buffer) + if (.not. trim(option_buffer) == "never") then + FLExit("Please choose 'never' under /material_phase[0]/scalar_field::Pressure/prognostic/scheme/poisson_pressure_solution when using wetting and drying") + end if + end if + end if + end if + + ! move mesh according to inital free surface: + ! top/bottom distance needs to be up-to-date before this call, after the movement + ! they will be updated (inside the call) + call move_mesh_free_surface(state, initialise=.true.) + + call run_diagnostics(state) + + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + if (have_option("/mesh_adaptivity/hr_adaptivity")) then + call allocate(metric_tensor, extract_mesh(state(1), topology_mesh_name), "ErrorMetric") + end if + + ! Determine the output format. + call get_option('/io/dump_format', option_buffer) + if(trim(option_buffer) /= "vtk") then + ewrite(-1,*) "You must specify a dump format and it must be vtk." + FLExit("Rejig your FLML: /io/dump_format") + end if + + ! Initialise multimaterial fields: + call initialise_diagnostic_material_properties(state) + + ! Spawn particles to specified meshes + call particle_cv_check(state) + + ! Initialise MVF fields based on particles: + call initialise_constant_particle_diagnostics(state) + call calculate_particle_material_fields(state) + + ! Calculate diagnostic variables: + call calculate_diagnostic_variables(state) + call calculate_diagnostic_variables_new(state) + + ! Initialise particle attributes and dependent fields + call update_particle_attributes_and_fields(state, current_time, dt) + call calculate_diagnostic_fields_from_particles(state) + + ! This is mostly to ensure that the photosynthetic radiation + ! has a non-zero value before the first adapt. + if (have_option("/ocean_biology")) then + call calculate_biology_terms(state(1)) + end if + + call initialise_diagnostics(filename, state) + + ! Initialise ice_meltrate, read constatns, allocate surface, and calculate melt rate + if (have_option("/ocean_forcing/iceshelf_meltrate/Holland08")) then + call melt_surf_init(state(1)) + call melt_allocate_surface(state(1)) + call melt_surf_calc(state(1)) !BC for ice melt - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries')) then + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries')) then call melt_bc(state(1)) - endif - end if - - ! Checkpoint at start - if(do_checkpoint_simulation(dump_no)) call checkpoint_simulation(state, cp_no = dump_no) - ! Dump at start - if( & - ! if this is not a zero timestep simulation (otherwise, there would - ! be two identical dump files) - & current_time < finish_time & - ! unless explicitly disabled - & .and. .not. have_option("/io/disable_dump_at_start") & + endif + end if + + ! Checkpoint at start + if(do_checkpoint_simulation(dump_no)) call checkpoint_simulation(state, cp_no = dump_no) + ! Dump at start + if( & + ! if this is not a zero timestep simulation (otherwise, there would + ! be two identical dump files) + & current_time < finish_time & + ! unless explicitly disabled + & .and. .not. have_option("/io/disable_dump_at_start") & + & ) then + call write_state(dump_no, state) + call write_particles_loop(state, timestep, current_time) + end if + + call initialise_convergence(filename, state) + call initialise_steady_state(filename, state) + call initialise_advection_convergence(state) + + if(have_option("/io/stat/output_at_start")) call write_diagnostics(state, current_time, dt, timestep) + + not_to_move_det_yet=.false. + + ! Initialise GLS + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/option")) then + call gls_init(state(1)) + end if + + ! ****************************** + ! *** Start of timestep loop *** + ! ****************************** + + timestep_loop: do + timestep = timestep + 1 + + ewrite(1, *) "********************" + ewrite(1, *) "*** NEW TIMESTEP ***" + ewrite(1, *) "********************" + ewrite(1, *) "Current simulation time: ", current_time + ewrite(1, *) "Timestep number: ", timestep + ewrite(1, *) "Timestep size (dt): ", dt + if(.not. allfequals(dt)) then + ewrite(-1, *) "Timestep size (dt): ", dt + FLAbort("The timestep is not global across all processes!") + end if + + if(simulation_completed(current_time, timestep)) exit timestep_loop + + call tic(TICTOC_ID_TIMESTEP) + + if( & + ! Do not dump at the start of the simulation (this is handled by write_state call earlier) + & current_time > simulation_start_time & + ! Do not dump at the end of the simulation (this is handled by later write_state call) + & .and. current_time < finish_time & + ! Test write_state conditions + & .and. do_write_state(current_time, timestep) & & ) then - call write_state(dump_no, state) - call write_particles_loop(state, timestep, current_time) - end if - - call initialise_convergence(filename, state) - call initialise_steady_state(filename, state) - call initialise_advection_convergence(state) - - if(have_option("/io/stat/output_at_start")) call write_diagnostics(state, current_time, dt, timestep) - - not_to_move_det_yet=.false. - - ! Initialise GLS - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/option")) then - call gls_init(state(1)) - end if - - ! ****************************** - ! *** Start of timestep loop *** - ! ****************************** - - timestep_loop: do - timestep = timestep + 1 - - ewrite(1, *) "********************" - ewrite(1, *) "*** NEW TIMESTEP ***" - ewrite(1, *) "********************" - ewrite(1, *) "Current simulation time: ", current_time - ewrite(1, *) "Timestep number: ", timestep - ewrite(1, *) "Timestep size (dt): ", dt - if(.not. allfequals(dt)) then - ewrite(-1, *) "Timestep size (dt): ", dt - FLAbort("The timestep is not global across all processes!") - end if - - if(simulation_completed(current_time, timestep)) exit timestep_loop - - call tic(TICTOC_ID_TIMESTEP) - - if( & - ! Do not dump at the start of the simulation (this is handled by write_state call earlier) - & current_time > simulation_start_time & - ! Do not dump at the end of the simulation (this is handled by later write_state call) - & .and. current_time < finish_time & - ! Test write_state conditions - & .and. do_write_state(current_time, timestep) & - & ) then - - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - ! Regular during run state dump. - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - ! Intermediate dumps - if(do_checkpoint_simulation(dump_no)) then - call checkpoint_simulation(state, cp_no = dump_no) - end if - call write_state(dump_no, state) - end if - - ewrite(2,*)'steady_state_tolerance,nonlinear_iterations:',steady_state_tolerance,nonlinear_iterations - - call copy_to_stored_values(state,"Old") - if (have_option('/mesh_adaptivity/mesh_movement') .and. .not. have_option('/mesh_adaptivity/mesh_movement/free_surface')) then - ! Coordinate isn't handled by the standard timeloop utility calls. - ! During the nonlinear iterations of a timestep, Coordinate is - ! evaluated at n+theta, i.e. (1-theta)*OldCoordinate+theta*IteratedCoordinate. - ! At the end of the previous timestep however, the most up-to-date Coordinate, - ! i.e. IteratedCoordinate, has been copied into Coordinate. This value - ! is now used as the Coordinate at the beginning of the time step. - ! For the free surface this is dealt with within move_mesh_free_surface() below - call set_vector_field_in_state(state(1), "OldCoordinate", "Coordinate") - end if - ! if we're using an implicit (prognostic) viscous free surface then there will be a surface field stored - ! under the boundary condition _implicit_free_surface on the FreeSurface field that we need to update - ! - it has an old and a new timelevel and the old one needs to be set to the now old new values. - call update_implicit_scaled_free_surface(state) - - ! this may already have been done in populate_state, but now - ! we evaluate at the correct "shifted" time level: - call set_boundary_conditions_values(state, shift_time=.true.) - if(use_sub_state()) call set_boundary_conditions_values(sub_state, shift_time=.true.) - - ! evaluate prescribed fields at time = current_time+dt - call set_prescribed_field_values(state, exclude_interpolated=.true., & + + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + ! Regular during run state dump. + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + ! Intermediate dumps + if(do_checkpoint_simulation(dump_no)) then + call checkpoint_simulation(state, cp_no = dump_no) + end if + call write_state(dump_no, state) + end if + + ewrite(2,*)'steady_state_tolerance,nonlinear_iterations:',steady_state_tolerance,nonlinear_iterations + + call copy_to_stored_values(state,"Old") + if (have_option('/mesh_adaptivity/mesh_movement') .and. .not. have_option('/mesh_adaptivity/mesh_movement/free_surface')) then + ! Coordinate isn't handled by the standard timeloop utility calls. + ! During the nonlinear iterations of a timestep, Coordinate is + ! evaluated at n+theta, i.e. (1-theta)*OldCoordinate+theta*IteratedCoordinate. + ! At the end of the previous timestep however, the most up-to-date Coordinate, + ! i.e. IteratedCoordinate, has been copied into Coordinate. This value + ! is now used as the Coordinate at the beginning of the time step. + ! For the free surface this is dealt with within move_mesh_free_surface() below + call set_vector_field_in_state(state(1), "OldCoordinate", "Coordinate") + end if + ! if we're using an implicit (prognostic) viscous free surface then there will be a surface field stored + ! under the boundary condition _implicit_free_surface on the FreeSurface field that we need to update + ! - it has an old and a new timelevel and the old one needs to be set to the now old new values. + call update_implicit_scaled_free_surface(state) + + ! this may already have been done in populate_state, but now + ! we evaluate at the correct "shifted" time level: + call set_boundary_conditions_values(state, shift_time=.true.) + if(use_sub_state()) call set_boundary_conditions_values(sub_state, shift_time=.true.) + + ! evaluate prescribed fields at time = current_time+dt + call set_prescribed_field_values(state, exclude_interpolated=.true., & exclude_nonreprescribed=.true., time=current_time+dt) - if(use_sub_state()) call set_full_domain_prescribed_fields(state,time=current_time+dt) - - ! move the mesh according to a prescribed grid velocity - ! NOTE: there may be a chicken and egg situation here. This update - ! has to come after the setting of the prescribed fields so that - ! the grid velocity is not advected (in a lagrangian way) with the mesh - ! after the previous timestep of mesh movement. However, this means - ! that other prescribed fields are actually set up according to an old - ! Coordinate field. - ! NOTE ALSO: this must come before the enforcement of discrete properties - ! to ensure those properties are satisfied on the new mesh not the old one. - call move_mesh_imposed_velocity(state) - call move_mesh_pseudo_lagrangian(state) - - call enforce_discrete_properties(state, only_prescribed=.true., & + if(use_sub_state()) call set_full_domain_prescribed_fields(state,time=current_time+dt) + + ! move the mesh according to a prescribed grid velocity + ! NOTE: there may be a chicken and egg situation here. This update + ! has to come after the setting of the prescribed fields so that + ! the grid velocity is not advected (in a lagrangian way) with the mesh + ! after the previous timestep of mesh movement. However, this means + ! that other prescribed fields are actually set up according to an old + ! Coordinate field. + ! NOTE ALSO: this must come before the enforcement of discrete properties + ! to ensure those properties are satisfied on the new mesh not the old one. + call move_mesh_imposed_velocity(state) + call move_mesh_pseudo_lagrangian(state) + + call enforce_discrete_properties(state, only_prescribed=.true., & exclude_interpolated=.true., & exclude_nonreprescribed=.true.) #ifdef HAVE_HYPERLIGHT - ! Calculate multispectral irradiance fields from hyperlight - if(have_option("/ocean_biology/lagrangian_ensemble/hyperlight")) then - call set_irradiance_from_hyperlight(state(1)) - end if + ! Calculate multispectral irradiance fields from hyperlight + if(have_option("/ocean_biology/lagrangian_ensemble/hyperlight")) then + call set_irradiance_from_hyperlight(state(1)) + end if #endif - ! nonlinear_iterations=maximum no of iterations within a time step - - nonlinear_iteration_loop: do ITS=1,nonlinear_iterations - - ewrite(1,*)'###################' - ewrite(1,*)'Start of another nonlinear iteration; ITS,nonlinear_iterations=',ITS,nonlinear_iterations - ewrite(1,*)'###################' - - ! For each field, set the iterated field, if present: - call copy_to_stored_values(state, "Iterated") - ! For each field, set the nonlinear field, if present: - call relax_to_nonlinear(state) - call copy_from_stored_values(state, "Old") - - ! move the mesh according to the free surface algorithm - ! this should not be at the end of the nonlinear iteration: - ! if nonlinear_iterations==1: - ! OldCoordinate is based on p^{n-1}, as it has been moved at the beginning of the previous timestep - ! IteratedCoordinate will be moved to p^n, the current pressure achieved at the end of the previous timestep - ! GridVelocity=(IteratedCoordinate-OldCoordinate)/dt - ! so the coordinates and grid velocity are lagging one timestep behind the computed p, which is inevitable - ! if nonlinear_iteration>1: - ! In the first nonlinear iteration we use the same values of OldCoordinate (based on p^{n-1}) - ! and IteratedCoordinate (based on p at the beginning of last iteration of previous timestep, say p^n*) - ! In subsequent iterations, we have a reasonable approximation of p^{n+1}, so we base - ! OldCoordinate on p^n* and IteratedCoordinate on p^(n+1)*, the best approximation p^{n+1} thus - ! far. Note that OldCoordinate should not be based on p^n (the value of p at the end of the - ! last iteration of the previous timestep) but on p^n* (the value at the beginning of the last iteration - ! of previous timestep). - - if (nonlinear_iterations==1) then - call move_mesh_free_surface(state) - else - call move_mesh_free_surface(state, nonlinear_iteration=its) - end if - - call compute_goals(state) - - ! Calculate source terms for population balance scalars - call dqmom_calculate_source_terms(state, ITS) - - if (have_option("/ocean_biology")) then - call calculate_biology_terms(state(1)) - end if - - ! Do we have the k-epsilon turbulence model? - ! If we do then we want to calculate source terms and diffusivity for the k and epsilon - ! fields and also tracer field diffusivities at n + theta_nl - do i= 1, size(state) - if(have_option("/material_phase["//& + ! nonlinear_iterations=maximum no of iterations within a time step + + nonlinear_iteration_loop: do ITS=1,nonlinear_iterations + + ewrite(1,*)'###################' + ewrite(1,*)'Start of another nonlinear iteration; ITS,nonlinear_iterations=',ITS,nonlinear_iterations + ewrite(1,*)'###################' + + ! For each field, set the iterated field, if present: + call copy_to_stored_values(state, "Iterated") + ! For each field, set the nonlinear field, if present: + call relax_to_nonlinear(state) + call copy_from_stored_values(state, "Old") + + ! move the mesh according to the free surface algorithm + ! this should not be at the end of the nonlinear iteration: + ! if nonlinear_iterations==1: + ! OldCoordinate is based on p^{n-1}, as it has been moved at the beginning of the previous timestep + ! IteratedCoordinate will be moved to p^n, the current pressure achieved at the end of the previous timestep + ! GridVelocity=(IteratedCoordinate-OldCoordinate)/dt + ! so the coordinates and grid velocity are lagging one timestep behind the computed p, which is inevitable + ! if nonlinear_iteration>1: + ! In the first nonlinear iteration we use the same values of OldCoordinate (based on p^{n-1}) + ! and IteratedCoordinate (based on p at the beginning of last iteration of previous timestep, say p^n*) + ! In subsequent iterations, we have a reasonable approximation of p^{n+1}, so we base + ! OldCoordinate on p^n* and IteratedCoordinate on p^(n+1)*, the best approximation p^{n+1} thus + ! far. Note that OldCoordinate should not be based on p^n (the value of p at the end of the + ! last iteration of the previous timestep) but on p^n* (the value at the beginning of the last iteration + ! of previous timestep). + + if (nonlinear_iterations==1) then + call move_mesh_free_surface(state) + else + call move_mesh_free_surface(state, nonlinear_iteration=its) + end if + + call compute_goals(state) + + ! Calculate source terms for population balance scalars + call dqmom_calculate_source_terms(state, ITS) + + if (have_option("/ocean_biology")) then + call calculate_biology_terms(state(1)) + end if + + ! Do we have the k-epsilon turbulence model? + ! If we do then we want to calculate source terms and diffusivity for the k and epsilon + ! fields and also tracer field diffusivities at n + theta_nl + do i= 1, size(state) + if(have_option("/material_phase["//& int2str(i-1)//"]/subgridscale_parameterisations/k-epsilon")) then - if(timestep == 1 .and. its == 1 .and. have_option('/physical_parameters/gravity')) then - ! The very first time k-epsilon is called, VelocityBuoyancyDensity - ! is set to zero until calculate_densities is called in the momentum equation - ! solve. Calling calculate_densities here is a work-around for this problem. - sfield => extract_scalar_field(state, 'VelocityBuoyancyDensity') - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - call get_phase_submaterials(state, i, submaterials) - call calculate_densities(submaterials, buoyancy_density=sfield) - deallocate(submaterials) - else - call calculate_densities(state, buoyancy_density=sfield) - end if - ewrite_minmax(sfield) - end if - call keps_advdif_diagnostics(state(i)) - end if - end do - - field_loop: do it = 1, ntsol - ewrite(2, "(a,i0,a,i0)") "Considering scalar field ", it, " of ", ntsol - ewrite(1, *) "Considering scalar field " // trim(field_name_list(it)) // " in state " // trim(state(field_state_list(it))%name) - - ! do we have the generic length scale vertical turbulence model? - if( have_option("/material_phase[0]/subgridscale_parameterisations/GLS/option")) then - if( (trim(field_name_list(it))=="GLSTurbulentKineticEnergy")) then - call gls_tke(state(1)) - else if( (trim(field_name_list(it))=="GLSGenericSecondQuantity")) then - call gls_psi(state(1)) - end if - end if - - ! Calculate the meltrate - if(have_option("/ocean_forcing/iceshelf_meltrate/Holland08/") ) then - if( (trim(field_name_list(it))=="MeltRate")) then - call melt_surf_calc(state(1)) - endif - end if - - call get_option(trim(field_optionpath_list(it))//& + if(timestep == 1 .and. its == 1 .and. have_option('/physical_parameters/gravity')) then + ! The very first time k-epsilon is called, VelocityBuoyancyDensity + ! is set to zero until calculate_densities is called in the momentum equation + ! solve. Calling calculate_densities here is a work-around for this problem. + sfield => extract_scalar_field(state, 'VelocityBuoyancyDensity') + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + call get_phase_submaterials(state, i, submaterials) + call calculate_densities(submaterials, buoyancy_density=sfield) + deallocate(submaterials) + else + call calculate_densities(state, buoyancy_density=sfield) + end if + ewrite_minmax(sfield) + end if + call keps_advdif_diagnostics(state(i)) + end if + end do + + field_loop: do it = 1, ntsol + ewrite(2, "(a,i0,a,i0)") "Considering scalar field ", it, " of ", ntsol + ewrite(1, *) "Considering scalar field " // trim(field_name_list(it)) // " in state " // trim(state(field_state_list(it))%name) + + ! do we have the generic length scale vertical turbulence model? + if( have_option("/material_phase[0]/subgridscale_parameterisations/GLS/option")) then + if( (trim(field_name_list(it))=="GLSTurbulentKineticEnergy")) then + call gls_tke(state(1)) + else if( (trim(field_name_list(it))=="GLSGenericSecondQuantity")) then + call gls_psi(state(1)) + end if + end if + + ! Calculate the meltrate + if(have_option("/ocean_forcing/iceshelf_meltrate/Holland08/") ) then + if( (trim(field_name_list(it))=="MeltRate")) then + call melt_surf_calc(state(1)) + endif + end if + + call get_option(trim(field_optionpath_list(it))//& '/prognostic/equation[0]/name', & option_buffer, default="UnknownEquationType") - select case(trim(option_buffer)) - case ( "AdvectionDiffusion", "ConservationOfMass", "ReducedConservationOfMass", "InternalEnergy", "HeatTransfer", "KEpsilon" ) - use_advdif=.true. - case default - use_advdif=.false. - end select + select case(trim(option_buffer)) + case ( "AdvectionDiffusion", "ConservationOfMass", "ReducedConservationOfMass", "InternalEnergy", "HeatTransfer", "KEpsilon" ) + use_advdif=.true. + case default + use_advdif=.false. + end select - IF(use_advdif)THEN + IF(use_advdif)THEN - sfield => extract_scalar_field(state(field_state_list(it)), field_name_list(it)) - call calculate_diagnostic_children(state, field_state_list(it), sfield) + sfield => extract_scalar_field(state(field_state_list(it)), field_name_list(it)) + call calculate_diagnostic_children(state, field_state_list(it), sfield) - !-------------------------------------------------- - !This addition creates a field that is a copy of - !another to be used, i.e.: for diffusing. - call get_copied_field(field_name_list(it), state(field_state_list(it))) - !-------------------------------------------------- + !-------------------------------------------------- + !This addition creates a field that is a copy of + !another to be used, i.e.: for diffusing. + call get_copied_field(field_name_list(it), state(field_state_list(it))) + !-------------------------------------------------- - IF(have_option(trim(field_optionpath_list(it))//& - & "/prognostic/spatial_discretisation/discontinuous_galerkin")) then + IF(have_option(trim(field_optionpath_list(it))//& + & "/prognostic/spatial_discretisation/discontinuous_galerkin")) then - ! Solve the DG form of the equations. - call solve_advection_diffusion_dg(field_name=field_name_list(it), & - & state=state(field_state_list(it))) + ! Solve the DG form of the equations. + call solve_advection_diffusion_dg(field_name=field_name_list(it), & + & state=state(field_state_list(it))) - ELSEIF(have_option(trim(field_optionpath_list(it))//& - & "/prognostic/spatial_discretisation/finite_volume")) then + ELSEIF(have_option(trim(field_optionpath_list(it))//& + & "/prognostic/spatial_discretisation/finite_volume")) then - ! Solve the FV form of the equations. - call solve_advection_diffusion_fv(field_name=field_name_list(it), & - & state=state(field_state_list(it))) + ! Solve the FV form of the equations. + call solve_advection_diffusion_fv(field_name=field_name_list(it), & + & state=state(field_state_list(it))) - ELSEIF(have_option(trim(field_optionpath_list(it))//& - & "/prognostic/spatial_discretisation/control_volumes")) then + ELSEIF(have_option(trim(field_optionpath_list(it))//& + & "/prognostic/spatial_discretisation/control_volumes")) then - ! Solve the pure control volume form of the equations - call solve_field_eqn_cv(field_name=trim(field_name_list(it)), & + ! Solve the pure control volume form of the equations + call solve_field_eqn_cv(field_name=trim(field_name_list(it)), & state=state, istate=field_state_list(it), global_it=its) - else if(have_option(trim(field_optionpath_list(it)) // & - & "/prognostic/spatial_discretisation/continuous_galerkin")) then + else if(have_option(trim(field_optionpath_list(it)) // & + & "/prognostic/spatial_discretisation/continuous_galerkin")) then + + call solve_field_equation_cg(field_name_list(it), state, field_state_list(it), dt) + else - call solve_field_equation_cg(field_name_list(it), state, field_state_list(it), dt) - else + ewrite(2, *) "Not solving scalar field " // trim(field_name_list(it)) // " in state " // trim(state(field_state_list(it))%name) //" in an advdif-like subroutine." - ewrite(2, *) "Not solving scalar field " // trim(field_name_list(it)) // " in state " // trim(state(field_state_list(it))%name) //" in an advdif-like subroutine." + end if ! End of dg/cv/cg choice. - end if ! End of dg/cv/cg choice. + ! ENDOF IF((TELEDI(IT).EQ.1).AND.D3) THEN ELSE... + ENDIF - ! ENDOF IF((TELEDI(IT).EQ.1).AND.D3) THEN ELSE... - ENDIF + ewrite(1, *) "Finished field " // trim(field_name_list(it)) // " in state " // trim(state(field_state_list(it))%name) + end do field_loop - ewrite(1, *) "Finished field " // trim(field_name_list(it)) // " in state " // trim(state(field_state_list(it))%name) - end do field_loop + ! Sort out the dregs of GLS after the solve on Psi (GenericSecondQuantity) has finished + if( have_option("/material_phase[0]/subgridscale_parameterisations/GLS/option")) then + call gls_diffusivity(state(1)) + end if - ! Sort out the dregs of GLS after the solve on Psi (GenericSecondQuantity) has finished - if( have_option("/material_phase[0]/subgridscale_parameterisations/GLS/option")) then - call gls_diffusivity(state(1)) - end if + !BC for ice melt + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries')) then + call melt_bc(state(1)) + endif - !BC for ice melt - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries')) then - call melt_bc(state(1)) - endif - - if(option_count("/material_phase/scalar_field/prognostic/spatial_discretisation/coupled_cv")>0) then - call coupled_cv_field_eqn(state, global_it=its) - end if - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - ! - ! Assemble and solve N.S equations. - ! - - do i=1, option_count("/material_phase") - option_path="/material_phase["//int2str(i-1)//"]/scalar_field::FoamVelocityPotential" - if( have_option(trim(option_path)//"/prognostic")) then - call calculate_potential_flow(state(i), phi=foam_velocity_potential) - call calculate_foam_velocity(state(i), foamvel=foamvel) - ! avoid outflow bc's for velocity being zero after adapts - call set_boundary_conditions_values(state, shift_time=.true.) + if(option_count("/material_phase/scalar_field/prognostic/spatial_discretisation/coupled_cv")>0) then + call coupled_cv_field_eqn(state, global_it=its) + end if + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + ! + ! Assemble and solve N.S equations. + ! + + do i=1, option_count("/material_phase") + option_path="/material_phase["//int2str(i-1)//"]/scalar_field::FoamVelocityPotential" + if( have_option(trim(option_path)//"/prognostic")) then + call calculate_potential_flow(state(i), phi=foam_velocity_potential) + call calculate_foam_velocity(state(i), foamvel=foamvel) + ! avoid outflow bc's for velocity being zero after adapts + call set_boundary_conditions_values(state, shift_time=.true.) + end if + end do + + ! This is where the non-legacy momentum stuff happens + ! a loop over state (hence over phases) is incorporated into this subroutine call + ! hence this lives outside the phase_loop + + if(use_sub_state()) then + call update_subdomain_fields(state,sub_state) + call solve_momentum(sub_state,at_first_timestep=((timestep==1).and.(its==1)),timestep=timestep) + call sub_state_remap_to_full_mesh(state, sub_state) + else + call solve_momentum(state,at_first_timestep=((timestep==1).and.(its==1)),timestep=timestep) + end if + + ! Apply minimum weight condition on weights - population balance + call dqmom_apply_min_weight(state) + + ! calculate abscissa in the population balance equation + ! this must be done at the end of each non-linear iteration + call dqmom_calculate_abscissa(state) + do i = 1, size(state) + call dqmom_calculate_moments(state(i)) + call dqmom_calculate_statistics(state(i)) + end do + + if(nonlinear_iterations > 1) then + ! Check for convergence between non linear iteration loops + call test_and_write_convergence(state, current_time + dt, dt, its, change) + if(its == 1) chaold = change + + if (have_option("/timestepping/nonlinear_iterations/& + &tolerance")) then + ewrite(2, *) "Nonlinear iteration change = ", change + ewrite(2, *) "Nonlinear iteration tolerance = ", nonlinear_iteration_tolerance + + if(change < abs(nonlinear_iteration_tolerance)) then + ewrite(1, *) "Nonlinear iteration tolerance has been reached" + ewrite(1, "(a,i0,a)") "Exiting nonlinear iteration loop after ", its, " iterations" + exit nonlinear_iteration_loop + endif + end if end if - end do - - ! This is where the non-legacy momentum stuff happens - ! a loop over state (hence over phases) is incorporated into this subroutine call - ! hence this lives outside the phase_loop - - if(use_sub_state()) then - call update_subdomain_fields(state,sub_state) - call solve_momentum(sub_state,at_first_timestep=((timestep==1).and.(its==1)),timestep=timestep) - call sub_state_remap_to_full_mesh(state, sub_state) - else - call solve_momentum(state,at_first_timestep=((timestep==1).and.(its==1)),timestep=timestep) - end if - - ! Apply minimum weight condition on weights - population balance - call dqmom_apply_min_weight(state) - - ! calculate abscissa in the population balance equation - ! this must be done at the end of each non-linear iteration - call dqmom_calculate_abscissa(state) - do i = 1, size(state) - call dqmom_calculate_moments(state(i)) - call dqmom_calculate_statistics(state(i)) - end do - - if(nonlinear_iterations > 1) then - ! Check for convergence between non linear iteration loops - call test_and_write_convergence(state, current_time + dt, dt, its, change) - if(its == 1) chaold = change - - if (have_option("/timestepping/nonlinear_iterations/& - &tolerance")) then - ewrite(2, *) "Nonlinear iteration change = ", change - ewrite(2, *) "Nonlinear iteration tolerance = ", nonlinear_iteration_tolerance - - if(change < abs(nonlinear_iteration_tolerance)) then - ewrite(1, *) "Nonlinear iteration tolerance has been reached" - ewrite(1, "(a,i0,a)") "Exiting nonlinear iteration loop after ", its, " iterations" - exit nonlinear_iteration_loop - endif - end if - end if - - end do nonlinear_iteration_loop - - ! Calculate prognostic sediment deposit fields - call calculate_sediment_flux(state(1)) - - ! Reset the number of nonlinear iterations in case it was overwritten by nonlinear_iterations_adapt - call get_option('/timestepping/nonlinear_iterations',nonlinear_iterations,& + + end do nonlinear_iteration_loop + + ! Calculate prognostic sediment deposit fields + call calculate_sediment_flux(state(1)) + + ! Reset the number of nonlinear iterations in case it was overwritten by nonlinear_iterations_adapt + call get_option('/timestepping/nonlinear_iterations',nonlinear_iterations,& & default=1) - if(have_option("/timestepping/nonlinear_iterations/terminate_if_not_converged")) then - if(its >= nonlinear_iterations .and. change >= abs(nonlinear_iteration_tolerance)) then - ewrite(0, *) "Nonlinear iteration tolerance not reached - termininating" - exit timestep_loop - end if - end if - - if (have_option('/mesh_adaptivity/mesh_movement')) then - ! During the timestep Coordinate is evaluated at n+theta, i.e. - ! (1-theta)*OldCoordinate+theta*IteratedCoordinate. For writing - ! the diagnostics we use the end-of-timestep n+1 coordinate however, - ! so that we can check conservation properties. - ! Using state(1) should be safe as they are aliased across all states. - call set_vector_field_in_state(state(1), "Coordinate", "IteratedCoordinate") - call IncrementEventCounter(EVENT_MESH_MOVEMENT) - - call sync_detector_coordinates(state(1)) - end if - - current_time=current_time+DT + if(have_option("/timestepping/nonlinear_iterations/terminate_if_not_converged")) then + if(its >= nonlinear_iterations .and. change >= abs(nonlinear_iteration_tolerance)) then + ewrite(0, *) "Nonlinear iteration tolerance not reached - termininating" + exit timestep_loop + end if + end if + + if (have_option('/mesh_adaptivity/mesh_movement')) then + ! During the timestep Coordinate is evaluated at n+theta, i.e. + ! (1-theta)*OldCoordinate+theta*IteratedCoordinate. For writing + ! the diagnostics we use the end-of-timestep n+1 coordinate however, + ! so that we can check conservation properties. + ! Using state(1) should be safe as they are aliased across all states. + call set_vector_field_in_state(state(1), "Coordinate", "IteratedCoordinate") + call IncrementEventCounter(EVENT_MESH_MOVEMENT) + + call sync_detector_coordinates(state(1)) + end if + + current_time=current_time+DT ! ! Calculate the meltrate ! if(have_option("/ocean_forcing/iceshelf_meltrate/Holland08/") ) then ! call melt_surf_calc(state(1)) ! end if - ! Call move and write particles - call move_particles(state, dt) - call initialise_particles_during_simulation(state, current_time) - call particle_cv_check(state) - call update_particle_attributes_and_fields(state, current_time, dt) - call calculate_particle_material_fields(state) - call calculate_diagnostic_fields_from_particles(state) - call write_particles_loop(state, timestep, current_time) - - ! calculate and write diagnostics before the timestep gets changed - call calculate_diagnostic_variables(State, exclude_nonrecalculated=.true.) - call calculate_diagnostic_variables_new(state, exclude_nonrecalculated = .true.) + ! Call move and write particles + call move_particles(state, dt) + call initialise_particles_during_simulation(state, current_time) + call particle_cv_check(state) + call update_particle_attributes_and_fields(state, current_time, dt) + call calculate_particle_material_fields(state) + call calculate_diagnostic_fields_from_particles(state) + call write_particles_loop(state, timestep, current_time) - ! Call the modern and significantly less satanic version of study - call write_diagnostics(state, current_time, dt, timestep) - ! Work out the domain volume by integrating the water depth function over the surface if using wetting and drying - if (have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then - ewrite(1, *) "Domain volume (\int_{fs} (\eta.-b)n.n_z)): ", calculate_volume_by_surface_integral(state(1)) - end if + ! calculate and write diagnostics before the timestep gets changed + call calculate_diagnostic_variables(State, exclude_nonrecalculated=.true.) + call calculate_diagnostic_variables_new(state, exclude_nonrecalculated = .true.) + ! Call the modern and significantly less satanic version of study + call write_diagnostics(state, current_time, dt, timestep) + ! Work out the domain volume by integrating the water depth function over the surface if using wetting and drying + if (have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then + ewrite(1, *) "Domain volume (\int_{fs} (\eta.-b)n.n_z)): ", calculate_volume_by_surface_integral(state(1)) + end if - if(have_option("/timestepping/adaptive_timestep")) call calc_cflnumber_field_based_dt(state, dt) - ! Update the options dictionary for the new timestep and current_time. - call set_option("/timestepping/timestep", dt) - call set_option("/timestepping/current_time", current_time) + if(have_option("/timestepping/adaptive_timestep")) call calc_cflnumber_field_based_dt(state, dt) - ! if strong bc or weak that overwrite then enforce the bc on the fields - ! (should only do something for weak bcs with that options switched on) - call set_dirichlet_consistent(state) + ! Update the options dictionary for the new timestep and current_time. + call set_option("/timestepping/timestep", dt) + call set_option("/timestepping/current_time", current_time) - if(have_option("/timestepping/steady_state")) then + ! if strong bc or weak that overwrite then enforce the bc on the fields + ! (should only do something for weak bcs with that options switched on) + call set_dirichlet_consistent(state) - call test_and_write_steady_state(state, change) - if(change0) then - prev_field_names => nemo_scalar_field_names - end if - allocate(nemo_scalar_field_names(1:no_nemo_scalar_fields+1)) - nemo_scalar_field_names(no_nemo_scalar_fields+1)=field%name - if (no_nemo_scalar_fields>0) then - nemo_scalar_field_names(1:no_nemo_scalar_fields)=prev_field_names - deallocate(prev_field_names) - end if + if (no_nemo_scalar_fields>0) then + prev_field_names => nemo_scalar_field_names + end if + allocate(nemo_scalar_field_names(1:no_nemo_scalar_fields+1)) + nemo_scalar_field_names(no_nemo_scalar_fields+1)=field%name + if (no_nemo_scalar_fields>0) then + nemo_scalar_field_names(1:no_nemo_scalar_fields)=prev_field_names + deallocate(prev_field_names) + end if - no_nemo_scalar_fields = no_nemo_scalar_fields+1 + no_nemo_scalar_fields = no_nemo_scalar_fields+1 -end subroutine + end subroutine -subroutine insert_nemo_vector_field(field) + subroutine insert_nemo_vector_field(field) - type(vector_field), intent(in) :: field + type(vector_field), intent(in) :: field - character(len=FIELD_NAME_LEN), dimension(:), pointer:: prev_field_names + character(len=FIELD_NAME_LEN), dimension(:), pointer:: prev_field_names - if (no_nemo_vector_fields>0) then - prev_field_names => nemo_vector_field_names - end if - allocate(nemo_vector_field_names(1:no_nemo_vector_fields+1)) - nemo_vector_field_names(no_nemo_vector_fields+1)=field%name - if (no_nemo_vector_fields>0) then - nemo_vector_field_names(1:no_nemo_vector_fields)=prev_field_names - end if + if (no_nemo_vector_fields>0) then + prev_field_names => nemo_vector_field_names + end if + allocate(nemo_vector_field_names(1:no_nemo_vector_fields+1)) + nemo_vector_field_names(no_nemo_vector_fields+1)=field%name + if (no_nemo_vector_fields>0) then + nemo_vector_field_names(1:no_nemo_vector_fields)=prev_field_names + end if - no_nemo_vector_fields = no_nemo_vector_fields+1 + no_nemo_vector_fields = no_nemo_vector_fields+1 -end subroutine + end subroutine -subroutine set_nemo_fields(state) + subroutine set_nemo_fields(state) - type(state_type), intent(in) :: state + type(state_type), intent(in) :: state - logical, save:: first_time=.true. - integer :: i - type(scalar_field), pointer:: sfield - type(vector_field), pointer:: vfield - character(len=OPTION_PATH_LEN) :: format + logical, save:: first_time=.true. + integer :: i + type(scalar_field), pointer:: sfield + type(vector_field), pointer:: vfield + character(len=OPTION_PATH_LEN) :: format - call load_nemo_values(state) + call load_nemo_values(state) - if (first_time) then - do i=1, no_nemo_scalar_fields + if (first_time) then + do i=1, no_nemo_scalar_fields - sfield => extract_scalar_field(state, nemo_scalar_field_names(i)) + sfield => extract_scalar_field(state, nemo_scalar_field_names(i)) - if (have_option(trim(sfield%option_path)//"/prognostic")) then + if (have_option(trim(sfield%option_path)//"/prognostic")) then - call get_option(trim(sfield%option_path) // "/prognostic/initial_condition/NEMO_data/format", format) + call get_option(trim(sfield%option_path) // "/prognostic/initial_condition/NEMO_data/format", format) - select case (format) - case ("Temperature") - call remap_field(temperature_t, sfield) - case ("Salinity") - call remap_field(salinity_t, sfield) - case ("Free-surface height") - call remap_field(pressure_t, sfield) - end select + select case (format) + case ("Temperature") + call remap_field(temperature_t, sfield) + case ("Salinity") + call remap_field(salinity_t, sfield) + case ("Free-surface height") + call remap_field(pressure_t, sfield) + end select - endif - enddo - do i=1, no_nemo_vector_fields + endif + enddo + do i=1, no_nemo_vector_fields - vfield => extract_vector_field(state, nemo_vector_field_names(i)) + vfield => extract_vector_field(state, nemo_vector_field_names(i)) - if (have_option(trim(vfield%option_path)//"/prognostic")) then + if (have_option(trim(vfield%option_path)//"/prognostic")) then - call get_option(trim(vfield%option_path) // "/prognostic/initial_condition/NEMO_data/format", format) + call get_option(trim(vfield%option_path) // "/prognostic/initial_condition/NEMO_data/format", format) - select case (format) - case ("Velocity") - call remap_field(velocity_t, vfield) - end select + select case (format) + case ("Velocity") + call remap_field(velocity_t, vfield) + end select - endif - enddo - first_time=.false. - end if + endif + enddo + first_time=.false. + end if - do i=1, no_nemo_scalar_fields + do i=1, no_nemo_scalar_fields - sfield => extract_scalar_field(state, nemo_scalar_field_names(i)) + sfield => extract_scalar_field(state, nemo_scalar_field_names(i)) - if (have_option(trim(sfield%option_path)//"/prescribed")) then + if (have_option(trim(sfield%option_path)//"/prescribed")) then - call get_option(trim(sfield%option_path) // "/prescribed/value/NEMO_data/format", format) + call get_option(trim(sfield%option_path) // "/prescribed/value/NEMO_data/format", format) - select case (format) - case ("Temperature") - call remap_field(temperature_t, sfield) - case ("Salinity") - call remap_field(salinity_t, sfield) - case ("Free-surface height") - call remap_field(pressure_t, sfield) - end select + select case (format) + case ("Temperature") + call remap_field(temperature_t, sfield) + case ("Salinity") + call remap_field(salinity_t, sfield) + case ("Free-surface height") + call remap_field(pressure_t, sfield) + end select - endif - enddo - do i=1, no_nemo_vector_fields - vfield => extract_vector_field(state, nemo_vector_field_names(i)) - if (have_option(trim(vfield%option_path)//"/prescribed")) then - call get_option(trim(vfield%option_path) // "/prescribed/value/NEMO_data/format", format) - select case (format) - case ("Velocity") - call remap_field(velocity_t, vfield) - end select - endif - enddo + endif + enddo + do i=1, no_nemo_vector_fields + vfield => extract_vector_field(state, nemo_vector_field_names(i)) + if (have_option(trim(vfield%option_path)//"/prescribed")) then + call get_option(trim(vfield%option_path) // "/prescribed/value/NEMO_data/format", format) + select case (format) + case ("Velocity") + call remap_field(velocity_t, vfield) + end select + endif + enddo - call deallocate_temp_fields + call deallocate_temp_fields -end subroutine + end subroutine -subroutine load_nemo_values(state) + subroutine load_nemo_values(state) - type(state_type), intent(in) :: state + type(state_type), intent(in) :: state - type(mesh_type) :: input_mesh - character(len=FIELD_NAME_LEN) input_mesh_name + type(mesh_type) :: input_mesh + character(len=FIELD_NAME_LEN) input_mesh_name - real :: current_time - logical*1 :: on_sphere + real :: current_time + logical*1 :: on_sphere - real :: gravity_magnitude + real :: gravity_magnitude - ! Temporary arrays to store the data read from the netCDF - real, dimension(3) :: temp_vector_3D - real, dimension(:), allocatable :: X, Y, Z, Temperature, Salinity - real, dimension(:), allocatable :: U, V, W, SSH, Pressure - integer :: NNodes, i + ! Temporary arrays to store the data read from the netCDF + real, dimension(3) :: temp_vector_3D + real, dimension(:), allocatable :: X, Y, Z, Temperature, Salinity + real, dimension(:), allocatable :: U, V, W, SSH, Pressure + integer :: NNodes, i - ! A radius array and a depth array to pass to get_nemo_variables - real, dimension(:), allocatable :: radius, depth - real :: rsphere + ! A radius array and a depth array to pass to get_nemo_variables + real, dimension(:), allocatable :: radius, depth + real :: rsphere - ! The input mesh was previously set in the flml file. As this is no longer - ! the case it is by default set to the coordinate mesh. This may need to be - ! re-though in the future. - input_mesh_name="CoordinateMesh" - input_mesh = extract_mesh(state, input_mesh_name) - position = get_coordinate_field(state, input_mesh) + ! The input mesh was previously set in the flml file. As this is no longer + ! the case it is by default set to the coordinate mesh. This may need to be + ! re-though in the future. + input_mesh_name="CoordinateMesh" + input_mesh = extract_mesh(state, input_mesh_name) + position = get_coordinate_field(state, input_mesh) - NNodes=node_count(input_mesh) + NNodes=node_count(input_mesh) - allocate(X(NNodes), Y(NNodes), Z(NNodes), radius(NNodes), depth(NNodes), Temperature(NNodes), & - Salinity(NNodes), U(NNodes), V(NNodes), W(NNodes), SSH(NNodes), Pressure(NNodes)) + allocate(X(NNodes), Y(NNodes), Z(NNodes), radius(NNodes), depth(NNodes), Temperature(NNodes), & + Salinity(NNodes), U(NNodes), V(NNodes), W(NNodes), SSH(NNodes), Pressure(NNodes)) - do i=1,NNodes - temp_vector_3D = node_val(position,i) - X(i) = temp_vector_3D(1) - Y(i) = temp_vector_3D(2) - Z(i) = temp_vector_3D(3) - radius(i) = sqrt(X(i)*X(i)+Y(i)*Y(i)+Z(i)*Z(i)) - enddo + do i=1,NNodes + temp_vector_3D = node_val(position,i) + X(i) = temp_vector_3D(1) + Y(i) = temp_vector_3D(2) + Z(i) = temp_vector_3D(3) + radius(i) = sqrt(X(i)*X(i)+Y(i)*Y(i)+Z(i)*Z(i)) + enddo - rsphere=maxval(radius) + rsphere=maxval(radius) - do i=1,NNodes - depth(i) = rsphere - radius(i) - enddo + do i=1,NNodes + depth(i) = rsphere - radius(i) + enddo - call get_option("/timestepping/current_time",current_time) - on_sphere=have_option('/geometry/spherical_earth') - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + call get_option("/timestepping/current_time",current_time) + on_sphere=have_option('/geometry/spherical_earth') + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - call get_nemo_variables(current_time, X, Y, Z, depth, Temperature, Salinity, U, V, W, & - SSH, NNodes) + call get_nemo_variables(current_time, X, Y, Z, depth, Temperature, Salinity, U, V, W, & + SSH, NNodes) - call allocate(temperature_t, input_mesh, name="temperature") - call allocate(salinity_t, input_mesh, name="salinity") - call allocate(pressure_t, input_mesh, name="pressure") - call allocate(velocity_t, 3, input_mesh, name="velocity") + call allocate(temperature_t, input_mesh, name="temperature") + call allocate(salinity_t, input_mesh, name="salinity") + call allocate(pressure_t, input_mesh, name="pressure") + call allocate(velocity_t, 3, input_mesh, name="velocity") - do i=1,NNodes - call set(temperature_t,i,Temperature(i)) - call set(salinity_t,i,Salinity(i)) - call set(pressure_t,i,gravity_magnitude*SSH(i)) - enddo + do i=1,NNodes + call set(temperature_t,i,Temperature(i)) + call set(salinity_t,i,Salinity(i)) + call set(pressure_t,i,gravity_magnitude*SSH(i)) + enddo - do i=1,NNodes - temp_vector_3D(1)=U(i) - temp_vector_3D(2)=V(i) - temp_vector_3D(3)=W(i) - call set(velocity_t,i,temp_vector_3D) - enddo - - deallocate(X, Y, Z, radius, depth, Temperature, Salinity, & - U, V, W, SSH, Pressure) - -end subroutine + do i=1,NNodes + temp_vector_3D(1)=U(i) + temp_vector_3D(2)=V(i) + temp_vector_3D(3)=W(i) + call set(velocity_t,i,temp_vector_3D) + enddo + + deallocate(X, Y, Z, radius, depth, Temperature, Salinity, & + U, V, W, SSH, Pressure) + + end subroutine end module nemo_states_module diff --git a/ocean_forcing/NEMO_load_fields_vars.F90 b/ocean_forcing/NEMO_load_fields_vars.F90 index 98573b8dac..d5dacc2d27 100644 --- a/ocean_forcing/NEMO_load_fields_vars.F90 +++ b/ocean_forcing/NEMO_load_fields_vars.F90 @@ -1,30 +1,30 @@ ! This module contains the temporary fields used in the NEMO data loading process module NEMO_load_fields_vars - use fldebug - use global_parameters, only: OPTION_PATH_LEN, pi, current_debug_level - use spud - use fields - use state_module + use fldebug + use global_parameters, only: OPTION_PATH_LEN, pi, current_debug_level + use spud + use fields + use state_module - type(scalar_field), public, save :: salinity_t, temperature_t, pressure_t - type(vector_field), public, save :: velocity_t - type(vector_field), public, save :: position + type(scalar_field), public, save :: salinity_t, temperature_t, pressure_t + type(vector_field), public, save :: velocity_t + type(vector_field), public, save :: position - private + private - public :: deallocate_temp_fields + public :: deallocate_temp_fields - contains +contains -subroutine deallocate_temp_fields + subroutine deallocate_temp_fields - call deallocate(temperature_t) - call deallocate(salinity_t) - call deallocate(pressure_t) - call deallocate(velocity_t) - call deallocate(position) + call deallocate(temperature_t) + call deallocate(salinity_t) + call deallocate(pressure_t) + call deallocate(velocity_t) + call deallocate(position) -end subroutine + end subroutine end module NEMO_load_fields_vars diff --git a/ocean_forcing/NEMOdataload_rotation.F90 b/ocean_forcing/NEMOdataload_rotation.F90 index 1a14a1b0b2..0737dfef04 100644 --- a/ocean_forcing/NEMOdataload_rotation.F90 +++ b/ocean_forcing/NEMOdataload_rotation.F90 @@ -1,11 +1,11 @@ ! Wrapper for the ll2r3_rotate subroutine in femtools/Coordinates.F90 subroutine rotate_ll2cart(longitude, latitude, u, v, r3u, r3v, r3w) bind(c) - use, intrinsic :: iso_c_binding - use Coordinates - implicit none - real(c_double), intent(in):: longitude, latitude, u, v - real(c_double), intent(out):: r3u, r3v, r3w + use, intrinsic :: iso_c_binding + use Coordinates + implicit none + real(c_double), intent(in):: longitude, latitude, u, v + real(c_double), intent(out):: r3u, r3v, r3w - call ll2r3_rotate(longitude, latitude, u, v, r3u, r3v, r3w) + call ll2r3_rotate(longitude, latitude, u, v, r3u, r3v, r3w) end subroutine diff --git a/ocean_forcing/NemoReader_interface.F90 b/ocean_forcing/NemoReader_interface.F90 index ca46b5fe9c..81b0999fae 100644 --- a/ocean_forcing/NemoReader_interface.F90 +++ b/ocean_forcing/NemoReader_interface.F90 @@ -26,91 +26,91 @@ ! USA module nemo_v2 - use FLDebug - use global_parameters - use, intrinsic :: iso_c_binding - - implicit none - - interface - subroutine nemo_v2_AddFieldOfInterest_c(scalar) bind(c) - use, intrinsic :: iso_c_binding - character(c_char), intent(in) :: scalar - end subroutine nemo_v2_AddFieldOfInterest_c - - subroutine nemo_v2_ClearFields_c() bind(c) - use, intrinsic :: iso_c_binding - end subroutine nemo_v2_ClearFields_c - - subroutine nemo_v2_GetScalars_c(longitude, latitude, p_depth, scalars) bind(c) - use, intrinsic :: iso_c_binding - real(c_double), intent(in) :: longitude, latitude, p_depth - real(c_double), dimension(*), intent(out) :: scalars - end subroutine nemo_v2_GetScalars_c - - subroutine nemo_v2_RegisterDataFile_c(filename) bind(c) - use, intrinsic :: iso_c_binding - character(c_char), intent(in) :: filename - end subroutine nemo_v2_RegisterDataFile_c - - subroutine nemo_v2_SetSimulationTimeUnits_c(units) bind(c) - use, intrinsic :: iso_c_binding - character(c_char), intent(in) :: units - end subroutine nemo_v2_SetSimulationTimeUnits_c - - subroutine nemo_v2_SetTimeSeconds_c(time) bind(c) - use, intrinsic :: iso_c_binding - real(c_double), intent(in) :: time - end subroutine nemo_v2_SetTimeSeconds_c - - subroutine get_nemo_variables_c(time, X, Y, Z, DEPTH, Te, Sa, U, V, W, SSH, NNodes) bind(c) - use, intrinsic :: iso_c_binding - real(c_double), intent(in) :: time - real(c_double), dimension(*), intent(in) :: X, Y, Z, DEPTH - real(c_double), dimension(*), intent(out) :: Te, Sa, U, V, W, SSH - integer(c_int), intent(in) :: NNodes - end subroutine get_nemo_variables_c - end interface + use FLDebug + use global_parameters + use, intrinsic :: iso_c_binding + + implicit none + + interface + subroutine nemo_v2_AddFieldOfInterest_c(scalar) bind(c) + use, intrinsic :: iso_c_binding + character(c_char), intent(in) :: scalar + end subroutine nemo_v2_AddFieldOfInterest_c + + subroutine nemo_v2_ClearFields_c() bind(c) + use, intrinsic :: iso_c_binding + end subroutine nemo_v2_ClearFields_c + + subroutine nemo_v2_GetScalars_c(longitude, latitude, p_depth, scalars) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), intent(in) :: longitude, latitude, p_depth + real(c_double), dimension(*), intent(out) :: scalars + end subroutine nemo_v2_GetScalars_c + + subroutine nemo_v2_RegisterDataFile_c(filename) bind(c) + use, intrinsic :: iso_c_binding + character(c_char), intent(in) :: filename + end subroutine nemo_v2_RegisterDataFile_c + + subroutine nemo_v2_SetSimulationTimeUnits_c(units) bind(c) + use, intrinsic :: iso_c_binding + character(c_char), intent(in) :: units + end subroutine nemo_v2_SetSimulationTimeUnits_c + + subroutine nemo_v2_SetTimeSeconds_c(time) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), intent(in) :: time + end subroutine nemo_v2_SetTimeSeconds_c + + subroutine get_nemo_variables_c(time, X, Y, Z, DEPTH, Te, Sa, U, V, W, SSH, NNodes) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), intent(in) :: time + real(c_double), dimension(*), intent(in) :: X, Y, Z, DEPTH + real(c_double), dimension(*), intent(out) :: Te, Sa, U, V, W, SSH + integer(c_int), intent(in) :: NNodes + end subroutine get_nemo_variables_c + end interface contains - subroutine nemo_v2_AddFieldOfInterest(scalar) - character(len=*), intent(in) :: scalar - call nemo_v2_AddFieldOfInterest_c(trim(scalar)//c_null_char) - end subroutine nemo_v2_AddFieldOfInterest - - subroutine nemo_v2_ClearFields() - call nemo_v2_ClearFields_c() - end subroutine nemo_v2_ClearFields - - subroutine nemo_v2_GetScalars(longitude, latitude, p_depth, scalars) - real, intent(in) :: longitude, latitude, p_depth - real, dimension(:), intent(out) :: scalars - call nemo_v2_GetScalars_c(longitude, latitude, p_depth, scalars) - end subroutine nemo_v2_GetScalars - - subroutine nemo_v2_RegisterDataFile(filename) - character(len=*), intent(in) :: filename - call nemo_v2_RegisterDataFile_c(trim(filename)//c_null_char) - end subroutine nemo_v2_RegisterDataFile - - subroutine nemo_v2_SetSimulationTimeunits(units) - character(len=*), intent(in) :: units - call nemo_v2_SetSimulationTimeunits_c(trim(units)//c_null_char) - end subroutine nemo_v2_SetSimulationTimeunits - - subroutine nemo_v2_SetTimeSeconds(time) - real(c_double), intent(in) :: time - call nemo_v2_SetTimeSeconds_c(time) - end subroutine nemo_v2_SetTimeSeconds - - subroutine get_nemo_variables(time, X, Y, Z, DEPTH, Te, Sa, U, V, W, SSH, NNodes) - use, intrinsic :: iso_c_binding - real(c_double), intent(in) :: time - real, dimension(:), intent(in) :: X, Y, Z, DEPTH - real, dimension(:), intent(out) :: Te, Sa, U, V, W, SSH - integer, intent(in) :: NNodes - call get_nemo_variables_c(time, X, Y, Z, DEPTH, Te, Sa, U, V, W, SSH, NNodes) - end subroutine get_nemo_variables + subroutine nemo_v2_AddFieldOfInterest(scalar) + character(len=*), intent(in) :: scalar + call nemo_v2_AddFieldOfInterest_c(trim(scalar)//c_null_char) + end subroutine nemo_v2_AddFieldOfInterest + + subroutine nemo_v2_ClearFields() + call nemo_v2_ClearFields_c() + end subroutine nemo_v2_ClearFields + + subroutine nemo_v2_GetScalars(longitude, latitude, p_depth, scalars) + real, intent(in) :: longitude, latitude, p_depth + real, dimension(:), intent(out) :: scalars + call nemo_v2_GetScalars_c(longitude, latitude, p_depth, scalars) + end subroutine nemo_v2_GetScalars + + subroutine nemo_v2_RegisterDataFile(filename) + character(len=*), intent(in) :: filename + call nemo_v2_RegisterDataFile_c(trim(filename)//c_null_char) + end subroutine nemo_v2_RegisterDataFile + + subroutine nemo_v2_SetSimulationTimeunits(units) + character(len=*), intent(in) :: units + call nemo_v2_SetSimulationTimeunits_c(trim(units)//c_null_char) + end subroutine nemo_v2_SetSimulationTimeunits + + subroutine nemo_v2_SetTimeSeconds(time) + real(c_double), intent(in) :: time + call nemo_v2_SetTimeSeconds_c(time) + end subroutine nemo_v2_SetTimeSeconds + + subroutine get_nemo_variables(time, X, Y, Z, DEPTH, Te, Sa, U, V, W, SSH, NNodes) + use, intrinsic :: iso_c_binding + real(c_double), intent(in) :: time + real, dimension(:), intent(in) :: X, Y, Z, DEPTH + real, dimension(:), intent(out) :: Te, Sa, U, V, W, SSH + integer, intent(in) :: NNodes + call get_nemo_variables_c(time, X, Y, Z, DEPTH, Te, Sa, U, V, W, SSH, NNodes) + end subroutine get_nemo_variables end module nemo_v2 diff --git a/ocean_forcing/NetCDFWriter.F90 b/ocean_forcing/NetCDFWriter.F90 index 5925a2701f..7422587007 100644 --- a/ocean_forcing/NetCDFWriter.F90 +++ b/ocean_forcing/NetCDFWriter.F90 @@ -29,285 +29,285 @@ ! Tries to be CF 1.4 complient module NetCDFWriter - private - public::NetCDFWriter_init, NetCDFWriter_write_variable + private + public::NetCDFWriter_init, NetCDFWriter_write_variable - integer, save::ncid - integer, save::latitude_dim, longitude_dim, time_dim - character(len=4096), save::ncfilename - integer(selected_int_kind(3)), save::fillvalue=32767 + integer, save::ncid + integer, save::latitude_dim, longitude_dim, time_dim + character(len=4096), save::ncfilename + integer(selected_int_kind(3)), save::fillvalue=32767 contains - subroutine NetCDFWriter_init(filename, longitude, latitude, & - time_coord, time_units, & - title, institution, history, source, references, comment) - use FLDebug - implicit none - character(len=*), intent(in)::filename - real, intent(in)::longitude(:), latitude(:) - integer, optional, intent(in)::time_coord(:) - character(len=*), optional, intent(in)::time_units - - ! A succinct description of what is in the dataset. - character(len=*), optional, intent(in)::title - - ! Specifies where the original data was produced. - character(len=*), optional, intent(in)::institution - - ! The method of production of the original data. If it was - ! model-generated, source should name the model and its version, - ! as specifically as could be useful. If it is observational, - ! source should characterize it (e.g., "surface observation" or - ! "radiosonde"). - character(len=*), optional, intent(in)::history - - ! Provides an audit trail for modifications to the original - ! data. Well-behaved generic netCDF filters will automatically - ! append their name and the parameters with which they were - ! invoked to the global history attribute of an input netCDF - ! file. We recommend that each line begin with a timestamp - ! indicating the date and time of day that the program was - ! executed. - character(len=*), optional, intent(in)::source - - - ! Published or web-based references that describe the data or - ! methods used to produce it. - character(len=*), optional, intent(in)::references - - ! Miscellaneous information about the data or methods used to produce it. - character(len=*), optional, intent(in)::comment + subroutine NetCDFWriter_init(filename, longitude, latitude, & + time_coord, time_units, & + title, institution, history, source, references, comment) + use FLDebug + implicit none + character(len=*), intent(in)::filename + real, intent(in)::longitude(:), latitude(:) + integer, optional, intent(in)::time_coord(:) + character(len=*), optional, intent(in)::time_units + + ! A succinct description of what is in the dataset. + character(len=*), optional, intent(in)::title + + ! Specifies where the original data was produced. + character(len=*), optional, intent(in)::institution + + ! The method of production of the original data. If it was + ! model-generated, source should name the model and its version, + ! as specifically as could be useful. If it is observational, + ! source should characterize it (e.g., "surface observation" or + ! "radiosonde"). + character(len=*), optional, intent(in)::history + + ! Provides an audit trail for modifications to the original + ! data. Well-behaved generic netCDF filters will automatically + ! append their name and the parameters with which they were + ! invoked to the global history attribute of an input netCDF + ! file. We recommend that each line begin with a timestamp + ! indicating the date and time of day that the program was + ! executed. + character(len=*), optional, intent(in)::source + + + ! Published or web-based references that describe the data or + ! methods used to produce it. + character(len=*), optional, intent(in)::references + + ! Miscellaneous information about the data or methods used to produce it. + character(len=*), optional, intent(in)::comment #ifdef HAVE_LIBNETCDF - include 'netcdf.inc' + include 'netcdf.inc' - character(len=256)::conventions="CF-1.4" - character(len=256)::units_latitude="degrees_north" - character(len=256)::units_longitude="degrees_east" + character(len=256)::conventions="CF-1.4" + character(len=256)::units_latitude="degrees_north" + character(len=256)::units_longitude="degrees_east" #ifdef DOUBLEP - integer, parameter::ncreal=ncdouble + integer, parameter::ncreal=ncdouble #else - integer, parameter::ncreal=ncfloat + integer, parameter::ncreal=ncfloat #endif - integer varid, dims(1) - integer ierr - real default_time(1) + integer varid, dims(1) + integer ierr + real default_time(1) - default_time(1) = 0 + default_time(1) = 0 - ! Open up a netcdf file for writing. - ncfilename = filename - ncid = nccre(filename, NCCLOB, ierr) - assert(ierr.eq.0) + ! Open up a netcdf file for writing. + ncfilename = filename + ncid = nccre(filename, NCCLOB, ierr) + assert(ierr.eq.0) - call ncaptc(ncid, NF_GLOBAL, "Conventions", NCCHAR, & + call ncaptc(ncid, NF_GLOBAL, "Conventions", NCCHAR, & len_trim(conventions), conventions, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) - if(present(title)) then - call ncaptc(ncid, NF_GLOBAL, "title", NCCHAR, & + if(present(title)) then + call ncaptc(ncid, NF_GLOBAL, "title", NCCHAR, & len_trim(title), title, ierr) - assert(ierr.eq.0) - end if + assert(ierr.eq.0) + end if - if(present(institution)) then - call ncaptc(ncid, NF_GLOBAL, "institution", NCCHAR, & + if(present(institution)) then + call ncaptc(ncid, NF_GLOBAL, "institution", NCCHAR, & len_trim(institution), institution, ierr) - assert(ierr.eq.0) - end if + assert(ierr.eq.0) + end if - if(present(history)) then - call ncaptc(ncid, NF_GLOBAL, "history", NCCHAR, & + if(present(history)) then + call ncaptc(ncid, NF_GLOBAL, "history", NCCHAR, & len_trim(history), history, ierr) - assert(ierr.eq.0) - end if + assert(ierr.eq.0) + end if - if(present(source)) then - call ncaptc(ncid, NF_GLOBAL, "source", NCCHAR, & + if(present(source)) then + call ncaptc(ncid, NF_GLOBAL, "source", NCCHAR, & len_trim(source), source, ierr) - assert(ierr.eq.0) - end if + assert(ierr.eq.0) + end if - if(present(references)) then - call ncaptc(ncid, NF_GLOBAL, "references", NCCHAR, & + if(present(references)) then + call ncaptc(ncid, NF_GLOBAL, "references", NCCHAR, & len_trim(references), references, ierr) - assert(ierr.eq.0) - end if + assert(ierr.eq.0) + end if - if(present(comment)) then - call ncaptc(ncid, NF_GLOBAL, "comment", NCCHAR, & + if(present(comment)) then + call ncaptc(ncid, NF_GLOBAL, "comment", NCCHAR, & len_trim(comment), comment, ierr) - assert(ierr.eq.0) - end if + assert(ierr.eq.0) + end if - time_dim = ncddef(ncid, 'time', NCUNLIM, ierr) - assert(ierr.eq.0) + time_dim = ncddef(ncid, 'time', NCUNLIM, ierr) + assert(ierr.eq.0) - dims(1) = time_dim - varid = ncvdef(ncid, "time", ncreal, 1, dims, ierr) - assert(ierr.eq.0) + dims(1) = time_dim + varid = ncvdef(ncid, "time", ncreal, 1, dims, ierr) + assert(ierr.eq.0) - call ncaptc(ncid, varid, "long_name", NCCHAR, 4, "time", ierr) - assert(ierr.eq.0) + call ncaptc(ncid, varid, "long_name", NCCHAR, 4, "time", ierr) + assert(ierr.eq.0) - ! Variables representing time must always explicitly include - ! the units attribute; there is no default value. The units - ! attribute takes a string value formatted as per the - ! recommendations in the Udunits package [UDUNITS]. - if(present(time_units)) then - call ncaptc(ncid, varid, "units", NCCHAR, & + ! Variables representing time must always explicitly include + ! the units attribute; there is no default value. The units + ! attribute takes a string value formatted as per the + ! recommendations in the Udunits package [UDUNITS]. + if(present(time_units)) then + call ncaptc(ncid, varid, "units", NCCHAR, & len_trim(time_units), time_units, ierr) - else - call ncaptc(ncid, varid, "units", NCCHAR, & + else + call ncaptc(ncid, varid, "units", NCCHAR, & 27, "seconds since 0-01-01 0:0:0", ierr) - end if - assert(ierr.eq.0) + end if + assert(ierr.eq.0) - ! Define the latitude dimension - latitude_dim = ncddef(ncid, 'latitude', size(latitude), ierr) - assert(ierr.eq.0) + ! Define the latitude dimension + latitude_dim = ncddef(ncid, 'latitude', size(latitude), ierr) + assert(ierr.eq.0) - dims(1) = latitude_dim - varid = ncvdef(ncid, "latitude", ncreal, 1, dims, ierr) - assert(ierr.eq.0) + dims(1) = latitude_dim + varid = ncvdef(ncid, "latitude", ncreal, 1, dims, ierr) + assert(ierr.eq.0) - call ncaptc(ncid, varid, "long_name", NCCHAR, 8, "latitude", ierr) - assert(ierr.eq.0) + call ncaptc(ncid, varid, "long_name", NCCHAR, 8, "latitude", ierr) + assert(ierr.eq.0) - call ncaptc(ncid, varid, "units", NCCHAR, len_trim(units_latitude), units_latitude, ierr) - assert(ierr.eq.0) + call ncaptc(ncid, varid, "units", NCCHAR, len_trim(units_latitude), units_latitude, ierr) + assert(ierr.eq.0) - ! Define the longitude dimension - longitude_dim = ncddef(ncid, 'longitude', size(longitude), ierr) - assert(ierr.eq.0) + ! Define the longitude dimension + longitude_dim = ncddef(ncid, 'longitude', size(longitude), ierr) + assert(ierr.eq.0) - dims(1) = longitude_dim - varid = ncvdef(ncid, "longitude", ncreal, 1, dims, ierr) - assert(ierr.eq.0) + dims(1) = longitude_dim + varid = ncvdef(ncid, "longitude", ncreal, 1, dims, ierr) + assert(ierr.eq.0) - call ncaptc(ncid, varid, "long_name", NCCHAR, 9, "longitude", ierr) - assert(ierr.eq.0) + call ncaptc(ncid, varid, "long_name", NCCHAR, 9, "longitude", ierr) + assert(ierr.eq.0) - call ncaptc(ncid, varid, "units", NCCHAR, len_trim(units_longitude), units_longitude, ierr) - assert(ierr.eq.0) + call ncaptc(ncid, varid, "units", NCCHAR, len_trim(units_longitude), units_longitude, ierr) + assert(ierr.eq.0) - ! Finish defining metadata - call ncendf(ncid, ierr) - assert(ierr.eq.0) + ! Finish defining metadata + call ncendf(ncid, ierr) + assert(ierr.eq.0) - ! Write variable values - varid = ncvid(ncid, "time", ierr) - if(present(time_coord)) then - call ncvpt(ncid, varid, 1, size(time_coord), time_coord, ierr) - else - call ncvpt(ncid, varid, 1, 1, default_time, ierr) - end if + ! Write variable values + varid = ncvid(ncid, "time", ierr) + if(present(time_coord)) then + call ncvpt(ncid, varid, 1, size(time_coord), time_coord, ierr) + else + call ncvpt(ncid, varid, 1, 1, default_time, ierr) + end if - varid = ncvid(ncid, "latitude", ierr) - call ncvpt(ncid, varid, 1, size(latitude), latitude, ierr) + varid = ncvid(ncid, "latitude", ierr) + call ncvpt(ncid, varid, 1, size(latitude), latitude, ierr) - varid = ncvid(ncid, "longitude", ierr) - call ncvpt(ncid, varid, 1, size(longitude), longitude, ierr) + varid = ncvid(ncid, "longitude", ierr) + call ncvpt(ncid, varid, 1, size(longitude), longitude, ierr) - call ncclos(ncid, ierr) - assert(ierr.eq.0) + call ncclos(ncid, ierr) + assert(ierr.eq.0) #endif - return - end subroutine NetCDFWriter_init - - subroutine NetCDFWriter_write_variable(name, long_name, variable, units) - use FLDebug - implicit none - character(len=*), intent(in)::name, long_name, units - real, intent(in)::variable(:,:,:) + return + end subroutine NetCDFWriter_init + + subroutine NetCDFWriter_write_variable(name, long_name, variable, units) + use FLDebug + implicit none + character(len=*), intent(in)::name, long_name, units + real, intent(in)::variable(:,:,:) #ifdef HAVE_LIBNETCDF - integer varid + integer varid - ! dimension IDs - integer dims(3), start(3), count(3) - integer(selected_int_kind(3)), allocatable::short_var(:,:,:) - integer i, j, k - real max_v, min_v - real add_offset, scale_factor - integer ierr + ! dimension IDs + integer dims(3), start(3), count(3) + integer(selected_int_kind(3)), allocatable::short_var(:,:,:) + integer i, j, k + real max_v, min_v + real add_offset, scale_factor + integer ierr - include 'netcdf.inc' + include 'netcdf.inc' #ifdef DOUBLEP - integer, parameter::ncreal=ncdouble + integer, parameter::ncreal=ncdouble #else - integer, parameter::ncreal=ncfloat + integer, parameter::ncreal=ncfloat #endif - ! reopen file - ncid = ncopn(ncfilename, NCWRITE, ierr) + ! reopen file + ncid = ncopn(ncfilename, NCWRITE, ierr) - ! Put file into define mode - call ncredf(ncid, ierr) + ! Put file into define mode + call ncredf(ncid, ierr) - ! Define the variable - dims(1) = longitude_dim - dims(2) = latitude_dim - dims(3) = time_dim + ! Define the variable + dims(1) = longitude_dim + dims(2) = latitude_dim + dims(3) = time_dim - varid = ncvdef(ncid, name, ncshort, 3, dims, ierr) - assert(ierr.eq.0) + varid = ncvdef(ncid, name, ncshort, 3, dims, ierr) + assert(ierr.eq.0) - varid = ncvid(ncid, name, ierr) - call ncaptc(ncid, varid, "long_name", NCCHAR, & + varid = ncvid(ncid, name, ierr) + call ncaptc(ncid, varid, "long_name", NCCHAR, & len_trim(long_name), long_name, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) - call ncaptc(ncid, varid, "units", NCCHAR, & + call ncaptc(ncid, varid, "units", NCCHAR, & len_trim(units), units, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) - call ncapt(ncid, varid, "_FillValue", NCSHORT, & + call ncapt(ncid, varid, "_FillValue", NCSHORT, & 1, fillvalue, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) - call ncapt(ncid, varid, "missing_value", NCSHORT, & + call ncapt(ncid, varid, "missing_value", NCSHORT, & 1, fillvalue, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) - ! Packing algorithm - max_v = maxval(variable) - min_v = minval(variable) + ! Packing algorithm + max_v = maxval(variable) + min_v = minval(variable) - add_offset = (max_v + min_v)*0.5 - call ncapt(ncid, varid, "add_offset", ncdouble, & + add_offset = (max_v + min_v)*0.5 + call ncapt(ncid, varid, "add_offset", ncdouble, & 1, add_offset, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) - scale_factor = (max_v - min_v)/(2**16 - 5) - call ncapt(ncid, varid, "scale_factor", ncdouble, & + scale_factor = (max_v - min_v)/(2**16 - 5) + call ncapt(ncid, varid, "scale_factor", ncdouble, & 1, scale_factor, ierr) - assert(ierr.eq.0) - - ! Finish defining metadata - call ncendf(ncid, ierr) - assert(ierr.eq.0) - - start = 1 - count(1) = size(variable(:, 1, 1)) - count(2) = size(variable(1, :, 1)) - count(3) = size(variable(1, 1, :)) - allocate(short_var(count(1), count(2), count(3))) - - do i=1, count(1) - do j=1, count(2) - do k=1, count(3) - short_var(i, j, k) = nint((variable(i, j, k) - add_offset)/scale_factor) - assert(short_var(i, j, k).ne.fillvalue) - end do - end do - end do - call ncvpt(ncid, varid, start, count, short_var, ierr) - - call ncclos(ncid, ierr) - assert(ierr.eq.0) + assert(ierr.eq.0) + + ! Finish defining metadata + call ncendf(ncid, ierr) + assert(ierr.eq.0) + + start = 1 + count(1) = size(variable(:, 1, 1)) + count(2) = size(variable(1, :, 1)) + count(3) = size(variable(1, 1, :)) + allocate(short_var(count(1), count(2), count(3))) + + do i=1, count(1) + do j=1, count(2) + do k=1, count(3) + short_var(i, j, k) = nint((variable(i, j, k) - add_offset)/scale_factor) + assert(short_var(i, j, k).ne.fillvalue) + end do + end do + end do + call ncvpt(ncid, varid, start, count, short_var, ierr) + + call ncclos(ncid, ierr) + assert(ierr.eq.0) #endif - end subroutine NetCDFWriter_write_variable + end subroutine NetCDFWriter_write_variable end module NetCDFWriter diff --git a/ocean_forcing/bulk_parameterisations.F90 b/ocean_forcing/bulk_parameterisations.F90 index efe8e8a2b1..0fbdd8e7ab 100644 --- a/ocean_forcing/bulk_parameterisations.F90 +++ b/ocean_forcing/bulk_parameterisations.F90 @@ -34,39 +34,39 @@ module bulk_parameterisations - use fldebug - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str - use quadrature - use elements - use spud - use fields - use state_module - use boundary_conditions - use field_options - - implicit none - - private - public :: ncar_forcing, coare_forcing, kara_forcing - public :: bulk_parameterisations_check_options - public :: get_forcing_surface_element_list - - ! physical constants - real, parameter :: air_density = 1.22,& - vapour_latent = 2.5e6, & - air_specificHeat = 1000.5, & - alpha = 0.066, & - sb = 5.67e-8, & - fusion_latent = 3.337e5, & - q1 = 0.98*640380, & - q2 = -5107.4, & - ocean_density = 1027.0, & - OneOverDensity = 1.0 / ocean_density, & - ocean_heat_capacity = 4000.0, & - kelvin_centrigrade = 273.15, & - heat_convert = 1.0 / (ocean_density * ocean_heat_capacity), & - one_over_density = 1.0 / ocean_density + use fldebug + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str + use quadrature + use elements + use spud + use fields + use state_module + use boundary_conditions + use field_options + + implicit none + + private + public :: ncar_forcing, coare_forcing, kara_forcing + public :: bulk_parameterisations_check_options + public :: get_forcing_surface_element_list + + ! physical constants + real, parameter :: air_density = 1.22,& + vapour_latent = 2.5e6, & + air_specificHeat = 1000.5, & + alpha = 0.066, & + sb = 5.67e-8, & + fusion_latent = 3.337e5, & + q1 = 0.98*640380, & + q2 = -5107.4, & + ocean_density = 1027.0, & + OneOverDensity = 1.0 / ocean_density, & + ocean_heat_capacity = 4000.0, & + kelvin_centrigrade = 273.15, & + heat_convert = 1.0 / (ocean_density * ocean_heat_capacity), & + one_over_density = 1.0 / ocean_density contains @@ -98,351 +98,351 @@ module bulk_parameterisations ! Wrapper around routine of Large and Yeager (2004), ! Turns the coefficients from the routine into fluxes - subroutine ncar_forcing(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) + subroutine ncar_forcing(points, speed, air_temp, sst, spec_humidity, & + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) - implicit none + implicit none - integer, intent(in) :: points - real, intent(in), dimension(points) :: speed, air_temp, sst, spec_humidity, sea_surface_humidity - real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal - real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes - real, intent(out), dimension(points) :: F ! Freshwater flux - real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes + integer, intent(in) :: points + real, intent(in), dimension(points) :: speed, air_temp, sst, spec_humidity, sea_surface_humidity + real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal + real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes + real, intent(out), dimension(points) :: F ! Freshwater flux + real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes - real, parameter :: heat_convert = 1.0 / (ocean_density * ocean_heat_capacity) - real, parameter :: one_over_density = 1.0 / ocean_density - real :: tau_temp, E - real, dimension(points) :: z, ustar, bstar, cd, ce, ch - real :: Q_long, Q_latent, Q_sensible, Q_ppt - logical*1, dimension(points) :: avail - integer :: i + real, parameter :: heat_convert = 1.0 / (ocean_density * ocean_heat_capacity) + real, parameter :: one_over_density = 1.0 / ocean_density + real :: tau_temp, E + real, dimension(points) :: z, ustar, bstar, cd, ce, ch + real :: Q_long, Q_latent, Q_sensible, Q_ppt + logical*1, dimension(points) :: avail + integer :: i - z = 2.0 - avail = .true. - ewrite(2,*) "In NCAR bulk parameterisations" + z = 2.0 + avail = .true. + ewrite(2,*) "In NCAR bulk parameterisations" - call ncar_ocean_fluxes(points, speed, air_temp, sst, spec_humidity, sea_surface_humidity, & - z, avail, cd, ch, ce, ustar, bstar) + call ncar_ocean_fluxes(points, speed, air_temp, sst, spec_humidity, sea_surface_humidity, & + z, avail, cd, ch, ce, ustar, bstar) - do i=1,points - ! from cd, ce and ch, calculate fluxes - tau_temp = OneOverDensity * air_density * cd(i) * speed(i); - tau_u(i) = tau_temp * U(i) - tau_v(i) = tau_temp * V(i) - E = air_density * ce(i) * (spec_humidity(i) - sea_surface_humidity(i)) * speed(i) ! evap - Q_solar(i) = solar(i) * (1.0-alpha) - Q_long = thermal(i) - (sb * SST(i)**4.0) - Q_latent = vapour_latent * E - Q_sensible = air_density * air_specificHeat * ch(i) * & - (air_temp(i) - sst(i)) * speed(i) - Q_ppt = -fusion_latent * ppt(i) - ! E seems to be about a factor of a thousand out of the ERA40 data when using - ! it for the freshwater fluxes - ! Dividing by ocean density appears to give the right answer... - E = E / ocean_density - F(i) = ppt(i) + E + runoff(i) + do i=1,points + ! from cd, ce and ch, calculate fluxes + tau_temp = OneOverDensity * air_density * cd(i) * speed(i); + tau_u(i) = tau_temp * U(i) + tau_v(i) = tau_temp * V(i) + E = air_density * ce(i) * (spec_humidity(i) - sea_surface_humidity(i)) * speed(i) ! evap + Q_solar(i) = solar(i) * (1.0-alpha) + Q_long = thermal(i) - (sb * SST(i)**4.0) + Q_latent = vapour_latent * E + Q_sensible = air_density * air_specificHeat * ch(i) * & + (air_temp(i) - sst(i)) * speed(i) + Q_ppt = -fusion_latent * ppt(i) + ! E seems to be about a factor of a thousand out of the ERA40 data when using + ! it for the freshwater fluxes + ! Dividing by ocean density appears to give the right answer... + E = E / ocean_density + F(i) = ppt(i) + E + runoff(i) - Q(i) = heat_convert * (Q_solar(i) + Q_long + Q_latent + Q_sensible + Q_ppt) - F(i) = -1.0 * salinity(i) * F(i) - end do + Q(i) = heat_convert * (Q_solar(i) + Q_long + Q_latent + Q_sensible + Q_ppt) + F(i) = -1.0 * salinity(i) * F(i) + end do - end subroutine ncar_forcing + end subroutine ncar_forcing ! Wrapper around routine of Large and Yeager (2004), ! Turns the coefficients from the routine into fluxes - subroutine coare_forcing(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) - - - implicit none - - integer, intent(in) :: points - real, intent(in), dimension(points) :: speed, spec_humidity, sea_surface_humidity - real, intent(inout), dimension(points) :: sst, air_temp !Need converting to C from K, hence the inout - real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal - real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes - real, intent(out), dimension(points) :: F ! Freshwater flux - real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes - - - real :: tau_temp, E - real, dimension(points) :: cd, ce, ch, hf, ef, rf ! DO WE NEED HF, EF RF ?! - real :: Q_long, Q_latent, Q_sensible, Q_ppt - integer :: i, r - real :: jwave = 0 - real, dimension(points) :: lat - real :: zu, zt, zq - - zu = 15. - zt = 15. - zq = 15. - lat = 0. - ewrite(2,*) "In COARE bulk parameterisations" - - - ! coare v3.0: Temperatures are in C not K - do r=1, points - sst(r) = sst(r) - kelvin_centrigrade - air_temp(r) = air_temp(r) - kelvin_centrigrade - end do - - - call coare30_ocean_fluxes(points, speed, sst, air_temp, sea_surface_humidity, & - solar, thermal, ppt, zu, zt, zq, jwave, & - lat, hf, ef, rf, cd, ch, ce) - - do i=1,points - ! from cd, ce and ch, calculate fluxes - tau_temp = OneOverDensity * air_density * cd(i) * speed(i) - tau_u(i) = tau_temp * U(i) - tau_v(i) = tau_temp * V(i) - E = air_density * ce(i) * (spec_humidity(i) - sea_surface_humidity(i)) * speed(i) ! evap - Q_solar(i) = solar(i) * (1.0-alpha) - Q_long = thermal(i) - (sb * (SST(i) + kelvin_centrigrade)**4.0) - Q_latent = vapour_latent * E - Q_sensible = air_density * air_specificHeat * ch(i) * & - (air_temp(i) - sst(i)) * speed(i) - Q_ppt = -fusion_latent * ppt(i) - ! E seems to be about a factor of a thousand out of the ERA40 data when using - ! it for the freshwater fluxes - ! Dividing by ocean density appears to give the right answer... - E = E / ocean_density - F(i) = ppt(i) + E + runoff(i) - Q(i) = heat_convert * (Q_solar(i) + Q_long + Q_latent + Q_sensible + Q_ppt) - F(i) = -1.0 * salinity(i) * F(i) - end do - - end subroutine coare_forcing - - subroutine kara_forcing (points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) - - implicit none - - integer, intent(in) :: points - real, intent(in), dimension(points) :: spec_humidity, sea_surface_humidity - real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal - real, intent(inout), dimension(points) :: sst, air_temp - real, intent(inout), dimension(points) :: speed ! is inout in the private routine as it gets limited - real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes - real, intent(out), dimension(points) :: F ! Freshwater flux - real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes - - real :: tau_temp, E - real, dimension(points) :: cd, ce, ch, lhf, shf, tau_r - real :: Q_long, Q_latent, Q_sensible, Q_ppt - integer :: i, r - - ewrite(2,*) "In KARA bulk parameterisations" - - ! kara: Temperatures are in C not K - do r=1, points - sst(r) = sst(r) - kelvin_centrigrade - air_temp(r) = air_temp(r) - kelvin_centrigrade - end do - - call kara_ocean_fluxes(points, U, V, ppt, air_temp, sst, speed, lhf, shf, tau_u, tau_v, tau_r, ce, cd, ch); - - do i=1,points - ! from cd, ce and ch, calculate fluxes - tau_temp = OneOverDensity * air_density * cd(i) * speed(i) - tau_u(i) = tau_temp * U(i) - tau_v(i) = tau_temp * V(i) - E = air_density * ce(i) * (spec_humidity(i) - sea_surface_humidity(i)) * speed(i) ! evap - Q_solar(i) = solar(i) * (1.0-alpha) - Q_long = thermal(i) - (sb * (SST(i) + kelvin_centrigrade)**4.0) - Q_latent = vapour_latent * E - Q_sensible = air_density * air_specificHeat * ch(i) * & - (air_temp(i) - sst(i)) * speed(i) - Q_ppt = -fusion_latent * ppt(i) - ! E seems to be about a factor of a thousand out of the ERA40 data when using - ! it for the freshwater fluxes - ! Dividing by ocean density appears to give the right answer... - E = E / ocean_density - F(i) = ppt(i) + E + runoff(i) - - ! Q(i) = lhf(i) + shf(i) - Q(i) = heat_convert * (Q_solar(i) + Q_long + Q_latent + Q_sensible + Q_ppt) - F(i) = -1.0 * salinity(i) * F(i) - end do - - end subroutine kara_forcing - - subroutine get_forcing_surface_element_list(state, surface_element_list, & - force_temperature, force_solar, force_velocity, force_salinity) - - type(state_type), intent(in) :: state - integer, dimension(:), pointer, intent(out) :: surface_element_list - ! set to the BC id of the field or -1 otherwise - integer, intent(out) :: force_temperature, force_solar, force_velocity, force_salinity - - type(vector_field), pointer :: vfield - type(scalar_field), pointer :: sfield - character(len=OPTION_PATH_LEN) :: field_path, bc_path, bc_type, bc_path_i - integer :: nbcs, i, stat - logical :: found_bc = .false. - - ! Check potential bulk_force'd fields until we come across a "bulk_formulae" type - ! bc - this will give us the required info to create our mesh - ! We always have a velocity field, so let's try there first - vfield => extract_vector_field(state, "Velocity") - force_velocity = -1 - field_path=vfield%option_path - if (have_option(trim(field_path)//'/prognostic')) then - ! Get number of boundary conditions - bc_path = trim(field_path)//'/prognostic/boundary_conditions' - nbcs=option_count(trim(bc_path)) - ! Loop over boundary conditions - do i=0, nbcs-1 + subroutine coare_forcing(points, speed, air_temp, sst, spec_humidity, & + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) + + + implicit none + + integer, intent(in) :: points + real, intent(in), dimension(points) :: speed, spec_humidity, sea_surface_humidity + real, intent(inout), dimension(points) :: sst, air_temp !Need converting to C from K, hence the inout + real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal + real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes + real, intent(out), dimension(points) :: F ! Freshwater flux + real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes + + + real :: tau_temp, E + real, dimension(points) :: cd, ce, ch, hf, ef, rf ! DO WE NEED HF, EF RF ?! + real :: Q_long, Q_latent, Q_sensible, Q_ppt + integer :: i, r + real :: jwave = 0 + real, dimension(points) :: lat + real :: zu, zt, zq + + zu = 15. + zt = 15. + zq = 15. + lat = 0. + ewrite(2,*) "In COARE bulk parameterisations" + + + ! coare v3.0: Temperatures are in C not K + do r=1, points + sst(r) = sst(r) - kelvin_centrigrade + air_temp(r) = air_temp(r) - kelvin_centrigrade + end do + + + call coare30_ocean_fluxes(points, speed, sst, air_temp, sea_surface_humidity, & + solar, thermal, ppt, zu, zt, zq, jwave, & + lat, hf, ef, rf, cd, ch, ce) + + do i=1,points + ! from cd, ce and ch, calculate fluxes + tau_temp = OneOverDensity * air_density * cd(i) * speed(i) + tau_u(i) = tau_temp * U(i) + tau_v(i) = tau_temp * V(i) + E = air_density * ce(i) * (spec_humidity(i) - sea_surface_humidity(i)) * speed(i) ! evap + Q_solar(i) = solar(i) * (1.0-alpha) + Q_long = thermal(i) - (sb * (SST(i) + kelvin_centrigrade)**4.0) + Q_latent = vapour_latent * E + Q_sensible = air_density * air_specificHeat * ch(i) * & + (air_temp(i) - sst(i)) * speed(i) + Q_ppt = -fusion_latent * ppt(i) + ! E seems to be about a factor of a thousand out of the ERA40 data when using + ! it for the freshwater fluxes + ! Dividing by ocean density appears to give the right answer... + E = E / ocean_density + F(i) = ppt(i) + E + runoff(i) + Q(i) = heat_convert * (Q_solar(i) + Q_long + Q_latent + Q_sensible + Q_ppt) + F(i) = -1.0 * salinity(i) * F(i) + end do + + end subroutine coare_forcing + + subroutine kara_forcing (points, speed, air_temp, sst, spec_humidity, & + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) + + implicit none + + integer, intent(in) :: points + real, intent(in), dimension(points) :: spec_humidity, sea_surface_humidity + real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal + real, intent(inout), dimension(points) :: sst, air_temp + real, intent(inout), dimension(points) :: speed ! is inout in the private routine as it gets limited + real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes + real, intent(out), dimension(points) :: F ! Freshwater flux + real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes + + real :: tau_temp, E + real, dimension(points) :: cd, ce, ch, lhf, shf, tau_r + real :: Q_long, Q_latent, Q_sensible, Q_ppt + integer :: i, r + + ewrite(2,*) "In KARA bulk parameterisations" + + ! kara: Temperatures are in C not K + do r=1, points + sst(r) = sst(r) - kelvin_centrigrade + air_temp(r) = air_temp(r) - kelvin_centrigrade + end do + + call kara_ocean_fluxes(points, U, V, ppt, air_temp, sst, speed, lhf, shf, tau_u, tau_v, tau_r, ce, cd, ch); + + do i=1,points + ! from cd, ce and ch, calculate fluxes + tau_temp = OneOverDensity * air_density * cd(i) * speed(i) + tau_u(i) = tau_temp * U(i) + tau_v(i) = tau_temp * V(i) + E = air_density * ce(i) * (spec_humidity(i) - sea_surface_humidity(i)) * speed(i) ! evap + Q_solar(i) = solar(i) * (1.0-alpha) + Q_long = thermal(i) - (sb * (SST(i) + kelvin_centrigrade)**4.0) + Q_latent = vapour_latent * E + Q_sensible = air_density * air_specificHeat * ch(i) * & + (air_temp(i) - sst(i)) * speed(i) + Q_ppt = -fusion_latent * ppt(i) + ! E seems to be about a factor of a thousand out of the ERA40 data when using + ! it for the freshwater fluxes + ! Dividing by ocean density appears to give the right answer... + E = E / ocean_density + F(i) = ppt(i) + E + runoff(i) + + ! Q(i) = lhf(i) + shf(i) + Q(i) = heat_convert * (Q_solar(i) + Q_long + Q_latent + Q_sensible + Q_ppt) + F(i) = -1.0 * salinity(i) * F(i) + end do + + end subroutine kara_forcing + + subroutine get_forcing_surface_element_list(state, surface_element_list, & + force_temperature, force_solar, force_velocity, force_salinity) + + type(state_type), intent(in) :: state + integer, dimension(:), pointer, intent(out) :: surface_element_list + ! set to the BC id of the field or -1 otherwise + integer, intent(out) :: force_temperature, force_solar, force_velocity, force_salinity + + type(vector_field), pointer :: vfield + type(scalar_field), pointer :: sfield + character(len=OPTION_PATH_LEN) :: field_path, bc_path, bc_type, bc_path_i + integer :: nbcs, i, stat + logical :: found_bc = .false. + + ! Check potential bulk_force'd fields until we come across a "bulk_formulae" type + ! bc - this will give us the required info to create our mesh + ! We always have a velocity field, so let's try there first + vfield => extract_vector_field(state, "Velocity") + force_velocity = -1 + field_path=vfield%option_path + if (have_option(trim(field_path)//'/prognostic')) then + ! Get number of boundary conditions + bc_path = trim(field_path)//'/prognostic/boundary_conditions' + nbcs=option_count(trim(bc_path)) + ! Loop over boundary conditions + do i=0, nbcs-1 bc_path_i=trim(bc_path)//"["//int2str(i)//"]" call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) if (trim(bc_type) .eq. "bulk_formulae") then - found_bc = .true. - call get_boundary_condition(vfield, i+1, surface_element_list=surface_element_list) - force_velocity = i+1 + found_bc = .true. + call get_boundary_condition(vfield, i+1, surface_element_list=surface_element_list) + force_velocity = i+1 end if - end do - end if - - sfield => extract_scalar_field(state, "Temperature") - force_temperature = -1 - field_path=sfield%option_path - if (have_option(trim(field_path)//'/prognostic')) then - ! Get number of boundary conditions - bc_path = trim(field_path)//'/prognostic/boundary_conditions' - nbcs=option_count(trim(bc_path)) - ! Loop over boundary conditions - do i=0, nbcs-1 + end do + end if + + sfield => extract_scalar_field(state, "Temperature") + force_temperature = -1 + field_path=sfield%option_path + if (have_option(trim(field_path)//'/prognostic')) then + ! Get number of boundary conditions + bc_path = trim(field_path)//'/prognostic/boundary_conditions' + nbcs=option_count(trim(bc_path)) + ! Loop over boundary conditions + do i=0, nbcs-1 bc_path_i=trim(bc_path)//"["//int2str(i)//"]" call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) if (trim(bc_type) .eq. "bulk_formulae") then - force_temperature = i+1 - if (.not. found_bc) then - found_bc = .true. - call get_boundary_condition(sfield, i+1, surface_element_list=surface_element_list) - end if + force_temperature = i+1 + if (.not. found_bc) then + found_bc = .true. + call get_boundary_condition(sfield, i+1, surface_element_list=surface_element_list) + end if end if - end do - end if - - sfield => extract_scalar_field(state, "PhotosyntheticRadiation",stat) - force_solar = -1 - if (stat == 0) then - field_path=sfield%option_path - if (have_option(trim(field_path)//'/prognostic')) then + end do + end if + + sfield => extract_scalar_field(state, "PhotosyntheticRadiation",stat) + force_solar = -1 + if (stat == 0) then + field_path=sfield%option_path + if (have_option(trim(field_path)//'/prognostic')) then ! Get number of boundary conditions bc_path = trim(field_path)//'/prognostic/boundary_conditions' nbcs=option_count(trim(bc_path)) ! Loop over boundary conditions do i=0, nbcs-1 - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) - if (trim(bc_type) .eq. "bulk_formulae") then - force_solar = i+1 - if (.not. found_bc) then - found_bc = .true. - call get_boundary_condition(sfield, i+1, surface_element_list=surface_element_list) - end if - end if + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) + if (trim(bc_type) .eq. "bulk_formulae") then + force_solar = i+1 + if (.not. found_bc) then + found_bc = .true. + call get_boundary_condition(sfield, i+1, surface_element_list=surface_element_list) + end if + end if end do - end if - end if - - ! Salinity?! - sfield => extract_scalar_field(state, "Salinity",stat) - force_salinity = -1 - if (stat == 0) then - field_path=sfield%option_path - if (have_option(trim(field_path)//'/prognostic')) then + end if + end if + + ! Salinity?! + sfield => extract_scalar_field(state, "Salinity",stat) + force_salinity = -1 + if (stat == 0) then + field_path=sfield%option_path + if (have_option(trim(field_path)//'/prognostic')) then ! Get number of boundary conditions bc_path = trim(field_path)//'/prognostic/boundary_conditions' nbcs=option_count(trim(bc_path)) ! Loop over boundary conditions do i=0, nbcs-1 - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) - if (trim(bc_type) .eq. "bulk_formulae") then - force_salinity = i+1 - if (.not. found_bc) then - found_bc = .true. - call get_boundary_condition(sfield, i+1, surface_element_list=surface_element_list) - end if - end if + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) + if (trim(bc_type) .eq. "bulk_formulae") then + force_salinity = i+1 + if (.not. found_bc) then + found_bc = .true. + call get_boundary_condition(sfield, i+1, surface_element_list=surface_element_list) + end if + end if end do - end if - end if - ! reset found_Bc to false, otherwise, next time we come around it's set to - ! .true. for some reason I can't figure out! - found_bc = .false. - - - end subroutine get_forcing_surface_element_list - - subroutine bulk_parameterisations_check_options - - character(len=FIELD_NAME_LEN) :: buffer - integer :: dimension - - ! Don't do BP if it's not included in the model! - if (.not.have_option("/ocean_forcing/bulk_formulae")) return - - ! Only 3 dimensional problems supported - call get_option("/geometry/dimension/", dimension) - if (dimension .ne. 3 .and. have_option("/ocean_forcing/bulk_formulae")) then - FLExit("Bulk parameterisations only supported for dimension == 3") - end if - - call get_option("/problem_type", buffer) - if (buffer/="oceans") then - FLExit("GLS modelling is only supported for problem type oceans.") - end if - - ! checking for required fields - if (.not.have_option("/material_phase[0]/scalar_field::Temperature")) then - FLExit("You need a Temperature field for bulk forumlae") - end if - if (.not.have_option("/material_phase[0]/vector_field::Velocity")) then - FLExit("You need Velocity field for bulk forumlae") - end if - - ! check if the diagnostics are on same mesh as the velocity - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::PhotosyntheticRadiationDownward")) then - call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::PhotosyntheticRadiationDownward/diagnostic/mesh/name",buffer) - if (trim(buffer) .ne. "VelocityMesh") then + end if + end if + ! reset found_Bc to false, otherwise, next time we come around it's set to + ! .true. for some reason I can't figure out! + found_bc = .false. + + + end subroutine get_forcing_surface_element_list + + subroutine bulk_parameterisations_check_options + + character(len=FIELD_NAME_LEN) :: buffer + integer :: dimension + + ! Don't do BP if it's not included in the model! + if (.not.have_option("/ocean_forcing/bulk_formulae")) return + + ! Only 3 dimensional problems supported + call get_option("/geometry/dimension/", dimension) + if (dimension .ne. 3 .and. have_option("/ocean_forcing/bulk_formulae")) then + FLExit("Bulk parameterisations only supported for dimension == 3") + end if + + call get_option("/problem_type", buffer) + if (buffer/="oceans") then + FLExit("GLS modelling is only supported for problem type oceans.") + end if + + ! checking for required fields + if (.not.have_option("/material_phase[0]/scalar_field::Temperature")) then + FLExit("You need a Temperature field for bulk forumlae") + end if + if (.not.have_option("/material_phase[0]/vector_field::Velocity")) then + FLExit("You need Velocity field for bulk forumlae") + end if + + ! check if the diagnostics are on same mesh as the velocity + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::PhotosyntheticRadiationDownward")) then + call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::PhotosyntheticRadiationDownward/diagnostic/mesh/name",buffer) + if (trim(buffer) .ne. "VelocityMesh") then FLExit("The bulk_forcing diagnostic PhotosyntheticRadiationDownward must be on the velocity mesh") - end if - end if - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field:SalinityFlux")) then - call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::SalinityFlux/diagnostic/mesh/name", buffer) - print trim(buffer) - if (trim(buffer) .ne. "VelocityMesh") then + end if + end if + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field:SalinityFlux")) then + call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::SalinityFlux/diagnostic/mesh/name", buffer) + print trim(buffer) + if (trim(buffer) .ne. "VelocityMesh") then FLExit("The bulk_forcing diagnostic SalinityFlux must be on the velocity mesh") - end if - end if - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field:HeatFlux")) then - call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::HeatFlux/diagnostic/mesh/name", buffer) - if (trim(buffer) .ne. "VelocityMesh") then + end if + end if + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field:HeatFlux")) then + call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::HeatFlux/diagnostic/mesh/name", buffer) + if (trim(buffer) .ne. "VelocityMesh") then FLExit("The bulk_forcing diagnostic HeatFlux must be on the velocity mesh") - end if - end if - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/vector_field::MomentumFlux")) then - call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/vector_field::MomentumFlux/diagnostic/mesh/name", buffer) - if (trim(buffer) .ne. "VelocityMesh") then + end if + end if + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/vector_field::MomentumFlux")) then + call get_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/vector_field::MomentumFlux/diagnostic/mesh/name", buffer) + if (trim(buffer) .ne. "VelocityMesh") then FLExit("The bulk_forcing diagnostic MomentumFlux must be on the velocity mesh") - end if - end if + end if + end if - end subroutine bulk_parameterisations_check_options + end subroutine bulk_parameterisations_check_options !----------------------------------------------------------------------------- @@ -459,568 +459,568 @@ end subroutine bulk_parameterisations_check_options ! Stephen.Griffies@noaa.gov updated the code with the bug fix. !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! ! - subroutine ncar_ocean_fluxes (points,u_del, t, ts, q, qs, z, avail, & - cd, ch, ce, ustar, bstar ) - - - implicit none - - real, parameter :: gravity = 9.81 - real, parameter :: VONKARM = 0.40 - integer, intent(in) :: points - real , intent(in) , dimension(points) :: u_del, t, ts, q, qs, z - logical*1, intent(in) , dimension(points) :: avail - real , intent(inout), dimension(points) :: cd, ch, ce, ustar, bstar - - real :: cd_n10, ce_n10, ch_n10, cd_n10_rt ! neutral 10m drag coefficients - real :: cd_rt ! full drag coefficients @ z - real :: zeta, x2, x, psi_m, psi_h ! stability parameters - real :: u, u10, tv, tstar, qstar, z0, xx, stab - integer, parameter :: n_itts = 2 - integer i, j - - ! whats what for a non-ocean modeller: - ! - u_del - wind speed relative to currents (currents usually ignored) - ! - t - temperature - ! - ts - SST - ! - q - specific humidity - ! - qs - saturating humidity - ! - z - height of point i - ! - avail - array of booleans to say if data is available at point i - ! - cd - these are the coefficients calculated by the sub routine - ! - ch - that are then used to calculate QH, E and Tau from - ! - ce - Large and Yeager (2004), eq: 4a-d - ! - ustar - ! - bstar - - do i=1,points - if (avail(i)) then - tv = t(i)*(1+0.608*q(i)); - u = max(u_del(i), 0.5); ! 0.5 m/s floor on wind (undocumented NCAR) - u10 = u; ! first guess 10m wind - - cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3; ! L-Y eqn. 6a - cd_n10_rt = sqrt(cd_n10); - ce_n10 = 34.6 *cd_n10_rt/1e3; ! L-Y eqn. 6b - stab = 0.5 + sign(0.5,t(i)-ts(i)) - ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3; ! L-Y eqn. 6c - - cd(i) = cd_n10; ! first guess for exchange coeff's at z - ch(i) = ch_n10; - ce(i) = ce_n10; - do j=1,n_itts ! Monin-Obukhov iteration - cd_rt = sqrt(cd(i)); - ustar(i) = cd_rt*u; ! L-Y eqn. 7a - tstar = (ch(i)/cd_rt)*(t(i)-ts(i)); ! L-Y eqn. 7b - qstar = (ce(i)/cd_rt)*(q(i)-qs(i)); ! L-Y eqn. 7c - bstar(i) = gravity*(tstar/tv+qstar/(q(i)+1/0.608)); - zeta = vonkarm*bstar(i)*z(i)/(ustar(i)*ustar(i)); ! L-Y eqn. 8a - zeta = sign( min(abs(zeta),10.0), zeta ); ! undocumented NCAR - x2 = sqrt(abs(1-16*zeta)); ! L-Y eqn. 8b - x2 = max(x2, 1.0); ! undocumented NCAR - x = sqrt(x2); - - if (zeta > 0) then - psi_m = -5*zeta; ! L-Y eqn. 8c - psi_h = -5*zeta; ! L-Y eqn. 8c - else - psi_m = log((1+2*x+x2)*(1+x2)/8)-2*(atan(x)-atan(1.0)); ! L-Y eqn. 8d - psi_h = 2*log((1+x2)/2); ! L-Y eqn. 8e - end if - - u10 = u/(1+cd_n10_rt*(log(z(i)/10)-psi_m)/vonkarm); ! L-Y eqn. 9 - cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3; ! L-Y eqn. 6a again - cd_n10_rt = sqrt(cd_n10); - ce_n10 = 34.6*cd_n10_rt/1e3; ! L-Y eqn. 6b again - stab = 0.5 + sign(0.5,zeta) - ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3; ! L-Y eqn. 6c again - z0 = 10*exp(-vonkarm/cd_n10_rt); ! diagnostic - - xx = (log(z(i)/10)-psi_m)/vonkarm; - cd(i) = cd_n10/(1+cd_n10_rt*xx)**2; ! L-Y 10a - xx = (log(z(i)/10)-psi_h)/vonkarm; - ch(i) = ch_n10/(1+ch_n10*xx/cd_n10_rt)*sqrt(cd(i)/cd_n10) ! 10b (corrected code aug2007) - ce(i) = ce_n10/(1+ce_n10*xx/cd_n10_rt)*sqrt(cd(i)/cd_n10) ! 10c (corrected code aug2007) - end do - end if - end do - - end subroutine ncar_ocean_fluxes - - - subroutine coare30_ocean_fluxes (points, u_array, ts_array, t_array, q_array, rs_array, rl_array, rain_array, & - zu, zt, zq, jwave, xlat_array, & - hf_array, ef_array, rf_array, Cdn_array, Chn_array, Cen_array) - - implicit none - - integer, intent (in) :: points - real, intent (in), dimension(points) :: u_array, ts_array, t_array, q_array, rs_array, rl_array, rain_array, xlat_array - real, intent (inout), dimension(points) :: hf_array, ef_array, rf_array, Cdn_array, Chn_array, Cen_array - real, intent (inout) :: zu, zt, zq, jwave - - - real :: hwave - real :: x(19), y(30), hnet(30), hl_webb(30) - real :: u, tsnk, ta, qa, rs, rl, org, lat, msp - real :: jcool - real :: a, b, cd, cdn_10, ce, cen_10, ch, chn_10 - real :: dqer, dter, hlb, hsb - integer :: ibg, l, le - real :: p, q, qs, qsr, rain, rf,rgas - real :: rhoa, rnl, rns, t, taub, tdk, tkt, ts, tsea - real :: tsr, twave, us, usr, visa, wbar, wg, zi, zo, zoq, zot - - ! U true wind speed, m/s etl sonic anemometer - ! tsnk sea snake temperature, C (0.05 m depth) - ! ta air temperature, C (z=14.5 m) - ! qa air specific humidity, g/kg (z=14.5 m) - ! rs downward solar flux, W/m^2 (ETL units) - ! rl downward IR flux, W/m^2 (ETL units) - ! org rainrate, mm/hr (ETL STI optical rain gauge, uncorrected) - ! lat latitude, deg (SCS pcode) - ! msp 6-m deotg T from MSP, C - - !zu=15 !anemometer ht - !zt=15 !air T height - !zq=15 !humidity height - - jcool=1 ! DO WE WANT COOL LAYER CALCULATION ? - !jwave=0 - - !******************* set constants **************** - - tdk=273.15 - Rgas=287.1 - dter=0.3 - - !*********** set variables not in data base ******** - P=1008 !air pressure - us=0 !surface current - zi=600 !inversion ht - - !****************** setup read data loop ********** - - do ibg = 1, points - u=u_array(ibg) - tsnk=ts_array(ibg) - ta=t_array(ibg) - qa=q_array(ibg) - rs=rs_array(ibg) - rl=rl_array(ibg) - org=rain_array(ibg) - lat=xlat_array(ibg) - msp=tsnk ! DO WE HAVE A 6 M DATA FOR THIS?! - - - !******** decode bulk met data **** - - ts = tsnk ! if(ibg .eq. 1) ts=tsnk ! CHECK THIS OUT - tsea=tsnk !bulk sea surface temp - t=ta !air temp - qs=qsee(tsea, P) !bulk sea surface humidity - q=qa !air humidity - Rs=rs !downward solar flux - Rl=rl !doward IR flux - rain=org !rain rate - - !********* set condition dependent stuff ****** - - Le=(2.501-.00237*tsea)*1e6 - rhoa=P*100/(Rgas*(t+tdk)*(1+0.61*q/1000)) - visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) - - ts=tsea - qs=qsee(ts, P) - a=.018 - b=.729 - twave=b*u - hwave=a*u**2.*(1+.015*u) - - x=(/u, us, ts, t, qs, q, Rs, Rl, rain, zi, P, zu, zt, zq, lat, jcool, jwave, twave, hwave/) - - !******** call modified LKB routine ******* - - call cor30a(x,y) - - !****************** output from routine ***************************** - - hsb=y(1) !sensible heat flux W/m/m - hlb=y(2) !latent - taub=y(3) !stress - zo=y(4) !vel roughness - zot=y(5) !temp " - zoq=y(6) !hum " - L=y(7) !Ob Length - usr=y(8) !ustar - tsr=y(9) !tstar - qsr=y(10) !qstar [g/g] - dter=y(11) !cool skin delta T - dqer=y(12) ! " " " q - tkt=y(13) !thickness of cool skin - RF=y(14) !rain heat flux - wbar=y(15) !webb mean w - Cd=y(16) !drag @ zu - Ch=y(17) - Ce=y(18) !Dalton - Cdn_10=y(19) !neutral drag @ 10 [includes gustiness] - Chn_10=y(20) - Cen_10=y(21) - Wg=y(22) - - - !********** new values from this code - hnet(ibg)=Rns-Rnl-hsb-hlb-RF !total heat input to ocean - hl_webb=rhoa*Le*wbar*qa/1000 - - ! OUR OUTPUT HERE - DO WE WANT ANY MORE OUTUPUT, IS Cdn, Chn and Cen stuff correct at 10 - hf_array(ibg) = y(1) - ef_array(ibg) = y(2) - rf_array(ibg) = y(14) - Cdn_array(ibg) = y(19) - Chn_array(ibg) = y(20) - Cen_array(ibg) = y(21) - - enddo - - contains - - - subroutine cor30a(x,y) - - !version with shortened iteration modified Rt and Rq - !uses wave information wave period in s and wave ht in m - !no wave, standard coare 2.6 charnock: jwave=0 - !Oost et al. zo=50/2/pi L (u*/c)**4.5 if jwave=1 - !taylor and yelland zo=1200 h*(L/h)**4.5 jwave=2 + subroutine ncar_ocean_fluxes (points,u_del, t, ts, q, qs, z, avail, & + cd, ch, ce, ustar, bstar ) + implicit none - real x(19), y(22) - real u,us,ts,t,Qs,Q,Rs,Rl,rain,zi,P,zu,zt,zq,lat,jcool,twave,hwave - real Beta,von,fdg,tdk,grav,Rgas,Le,cpa,cpv,rhoa,visa,Al,be,cpw,rhow,visw,tcw,bigc,wetc - real lwave,cwave,Rns,Rnl,du,dt,dq,qout,dels,qcol,alq,xlamx,alfac,bf,cc,cd10,ch10,charn,ct,ct10,dtmp,dwat,hl_webb - real jwave, l10,pi,ribcu,ribu,rr,ta,u10,ut,zet,zetu,zo10,zot10 - real hsb, hlb, tau, zo, zot, zoq, L, usr, tsr, qsr, dter, dqer, tkt, RF, wbar, Cd, Ch, Ce, Cdn_10, Chn_10, Cen_10, ug - integer i,nits - - u=x(1) !wind speed (m/s) at height zu (m) - us=x(2) !surface current speed in the wind direction (m/s) - ts=x(3) !bulk water temperature (C) if jcool=1, interface water T if jcool=0 - t=x(4) !bulk air temperature (C), height zt - Qs=x(5)/1000 !bulk water spec hum (g/kg) if jcool=1, ... - Q=x(6)/1000 !bulk air spec hum (g/kg), height zq - Rs=x(7) !downward solar flux (W/m**2) - Rl=x(8) !downard IR flux (W/m**2) - rain=x(9) !rain rate (mm/hr) - zi=x(10) !PBL depth (m) - P=x(11) !Atmos surface pressure (mb) - zu=x(12) !wind speed measurement height (m) - zt=x(13) !air T measurement height (m) - zq=x(14) !air q measurement height (m) - lat=x(15) !latitude (deg, N=+) - jcool=x(16) !implement cool calculation skin switch, 0=no, 1=yes - jwave=x(17) !implement wave dependent roughness model - twave=x(18) !wave period (s) - hwave=x(19) !wave height (m) - - !***************** set constants ************* - Beta=1.2 - von=0.4 - fdg=1.00 + real, parameter :: gravity = 9.81 + real, parameter :: VONKARM = 0.40 + integer, intent(in) :: points + real , intent(in) , dimension(points) :: u_del, t, ts, q, qs, z + logical*1, intent(in) , dimension(points) :: avail + real , intent(inout), dimension(points) :: cd, ch, ce, ustar, bstar + + real :: cd_n10, ce_n10, ch_n10, cd_n10_rt ! neutral 10m drag coefficients + real :: cd_rt ! full drag coefficients @ z + real :: zeta, x2, x, psi_m, psi_h ! stability parameters + real :: u, u10, tv, tstar, qstar, z0, xx, stab + integer, parameter :: n_itts = 2 + integer i, j + + ! whats what for a non-ocean modeller: + ! - u_del - wind speed relative to currents (currents usually ignored) + ! - t - temperature + ! - ts - SST + ! - q - specific humidity + ! - qs - saturating humidity + ! - z - height of point i + ! - avail - array of booleans to say if data is available at point i + ! - cd - these are the coefficients calculated by the sub routine + ! - ch - that are then used to calculate QH, E and Tau from + ! - ce - Large and Yeager (2004), eq: 4a-d + ! - ustar + ! - bstar + + do i=1,points + if (avail(i)) then + tv = t(i)*(1+0.608*q(i)); + u = max(u_del(i), 0.5); ! 0.5 m/s floor on wind (undocumented NCAR) + u10 = u; ! first guess 10m wind + + cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3; ! L-Y eqn. 6a + cd_n10_rt = sqrt(cd_n10); + ce_n10 = 34.6 *cd_n10_rt/1e3; ! L-Y eqn. 6b + stab = 0.5 + sign(0.5,t(i)-ts(i)) + ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3; ! L-Y eqn. 6c + + cd(i) = cd_n10; ! first guess for exchange coeff's at z + ch(i) = ch_n10; + ce(i) = ce_n10; + do j=1,n_itts ! Monin-Obukhov iteration + cd_rt = sqrt(cd(i)); + ustar(i) = cd_rt*u; ! L-Y eqn. 7a + tstar = (ch(i)/cd_rt)*(t(i)-ts(i)); ! L-Y eqn. 7b + qstar = (ce(i)/cd_rt)*(q(i)-qs(i)); ! L-Y eqn. 7c + bstar(i) = gravity*(tstar/tv+qstar/(q(i)+1/0.608)); + zeta = vonkarm*bstar(i)*z(i)/(ustar(i)*ustar(i)); ! L-Y eqn. 8a + zeta = sign( min(abs(zeta),10.0), zeta ); ! undocumented NCAR + x2 = sqrt(abs(1-16*zeta)); ! L-Y eqn. 8b + x2 = max(x2, 1.0); ! undocumented NCAR + x = sqrt(x2); + + if (zeta > 0) then + psi_m = -5*zeta; ! L-Y eqn. 8c + psi_h = -5*zeta; ! L-Y eqn. 8c + else + psi_m = log((1+2*x+x2)*(1+x2)/8)-2*(atan(x)-atan(1.0)); ! L-Y eqn. 8d + psi_h = 2*log((1+x2)/2); ! L-Y eqn. 8e + end if + + u10 = u/(1+cd_n10_rt*(log(z(i)/10)-psi_m)/vonkarm); ! L-Y eqn. 9 + cd_n10 = (2.7/u10+0.142+0.0764*u10)/1e3; ! L-Y eqn. 6a again + cd_n10_rt = sqrt(cd_n10); + ce_n10 = 34.6*cd_n10_rt/1e3; ! L-Y eqn. 6b again + stab = 0.5 + sign(0.5,zeta) + ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt/1e3; ! L-Y eqn. 6c again + z0 = 10*exp(-vonkarm/cd_n10_rt); ! diagnostic + + xx = (log(z(i)/10)-psi_m)/vonkarm; + cd(i) = cd_n10/(1+cd_n10_rt*xx)**2; ! L-Y 10a + xx = (log(z(i)/10)-psi_h)/vonkarm; + ch(i) = ch_n10/(1+ch_n10*xx/cd_n10_rt)*sqrt(cd(i)/cd_n10) ! 10b (corrected code aug2007) + ce(i) = ce_n10/(1+ce_n10*xx/cd_n10_rt)*sqrt(cd(i)/cd_n10) ! 10c (corrected code aug2007) + end do + end if + end do + + end subroutine ncar_ocean_fluxes + + + subroutine coare30_ocean_fluxes (points, u_array, ts_array, t_array, q_array, rs_array, rl_array, rain_array, & + zu, zt, zq, jwave, xlat_array, & + hf_array, ef_array, rf_array, Cdn_array, Chn_array, Cen_array) + + implicit none + + integer, intent (in) :: points + real, intent (in), dimension(points) :: u_array, ts_array, t_array, q_array, rs_array, rl_array, rain_array, xlat_array + real, intent (inout), dimension(points) :: hf_array, ef_array, rf_array, Cdn_array, Chn_array, Cen_array + real, intent (inout) :: zu, zt, zq, jwave + + + real :: hwave + real :: x(19), y(30), hnet(30), hl_webb(30) + real :: u, tsnk, ta, qa, rs, rl, org, lat, msp + real :: jcool + real :: a, b, cd, cdn_10, ce, cen_10, ch, chn_10 + real :: dqer, dter, hlb, hsb + integer :: ibg, l, le + real :: p, q, qs, qsr, rain, rf,rgas + real :: rhoa, rnl, rns, t, taub, tdk, tkt, ts, tsea + real :: tsr, twave, us, usr, visa, wbar, wg, zi, zo, zoq, zot + + ! U true wind speed, m/s etl sonic anemometer + ! tsnk sea snake temperature, C (0.05 m depth) + ! ta air temperature, C (z=14.5 m) + ! qa air specific humidity, g/kg (z=14.5 m) + ! rs downward solar flux, W/m^2 (ETL units) + ! rl downward IR flux, W/m^2 (ETL units) + ! org rainrate, mm/hr (ETL STI optical rain gauge, uncorrected) + ! lat latitude, deg (SCS pcode) + ! msp 6-m deotg T from MSP, C + + !zu=15 !anemometer ht + !zt=15 !air T height + !zq=15 !humidity height + + jcool=1 ! DO WE WANT COOL LAYER CALCULATION ? + !jwave=0 + + !******************* set constants **************** + tdk=273.15 - pi = 3.141593 - grav=grv(lat) !9.82 - !************* air constants ************ Rgas=287.1 - Le=(2.501-.00237*ts)*1e6 - cpa=1004.67 - cpv=cpa*(1+0.84*Q) - rhoa=P*100/(Rgas*(t+tdk)*(1+0.61*Q)) - visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) - !************ cool skin constants ******* - Al=2.1e-5*(ts+3.2)**0.79 - be=0.026 - cpw=4000 - rhow=1022 - visw=1e-6 - tcw=0.6 - bigc=16*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) - wetc=0.622*Le*Qs/(Rgas*(ts+tdk)**2) - - !*************** wave parameters ********* - lwave=grav/2/pi*twave**2 - cwave=grav/2/pi*twave - - !************** compute aux stuff ******* - Rns=Rs*.945 - Rnl=0.97*(5.67e-8*(ts-0.3*jcool+tdk)**4-Rl) - - !*************** Begin bulk loop ******* - - !*************** first guess ************ - du=u-us - dt=ts-t-.0098*zt - dq=Qs-Q - ta=t+tdk - ug=.5 dter=0.3 - dqer=wetc*dter - ut=sqrt(du*du+ug*ug) - u10=ut*log(10/1e-4)/log(zu/1e-4) - usr=.035*u10 - zo10=0.011*usr*usr/grav+0.11*visa/usr - Cd10=(von/log(10/zo10))**2 - Ch10=0.00115 - Ct10=Ch10/sqrt(Cd10) - zot10=10/exp(von/Ct10) - Cd=(von/log(zu/zo10))**2 - Ct=von/log(zt/zot10) - CC=von*Ct/Cd - Ribcu=-zu/zi/.004/Beta**3 - Ribu=-grav*zu/ta*((dt-dter*jcool)+.61*ta*dq)/ut**2 - nits=3 - if (Ribu .LT. 0) then - zetu=CC*Ribu/(1+Ribu/Ribcu) - else - zetu=CC*Ribu*(1+27/9*Ribu/CC) - endif - L10=zu/zetu - if (zetu .GT. 50) then - nits=1 - endif - usr=ut*von/(log(zu/zo10)-psiuo(zu/L10)) - tsr=-(dt-dter*jcool)*von*fdg/(log(zt/zot10)-psit_30(zt/L10)) - qsr=-(dq-wetc*dter*jcool)*von*fdg/(log(zq/zot10)-psit_30(zq/L10)) - tkt=.001 - charn=0.011 - if (ut .GT. 10) then - charn=0.011+(ut-10)/(18-10)*(0.018-0.011) - endif - if (ut .GT. 18) then - charn=0.018 - endif - - !*************** bulk loop ************ - do i=1, nits - - zet=von*grav*zu/ta*(tsr*(1+0.61*Q)+.61*ta*qsr)/(usr*usr)/(1+0.61*Q) - !disp(usr) - !disp(zet) - if (jwave .EQ. 0) zo=charn*usr*usr/grav+0.11*visa/usr - if (jwave .EQ. 1) zo=50/2/pi*lwave*(usr/cwave)**4.5+0.11*visa/usr !Oost et al - if (jwave .EQ. 2) zo=1200*hwave*(hwave/lwave)**4.5+0.11*visa/usr !Taylor and Yelland - rr=zo*usr/visa - L=zu/zet - zoq=min(1.15e-4,5.5e-5/rr**.6) - zot=zoq - usr=ut*von/(log(zu/zo)-psiuo(zu/L)) - tsr=-(dt-dter*jcool)*von*fdg/(log(zt/zot)-psit_30(zt/L)) - qsr=-(dq-wetc*dter*jcool)*von*fdg/(log(zq/zoq)-psit_30(zq/L)) - Bf=-grav/ta*usr*(tsr+.61*ta*qsr) - if (Bf .GT. 0) then - ug=Beta*(Bf*zi)**.333 + + !*********** set variables not in data base ******** + P=1008 !air pressure + us=0 !surface current + zi=600 !inversion ht + + !****************** setup read data loop ********** + + do ibg = 1, points + u=u_array(ibg) + tsnk=ts_array(ibg) + ta=t_array(ibg) + qa=q_array(ibg) + rs=rs_array(ibg) + rl=rl_array(ibg) + org=rain_array(ibg) + lat=xlat_array(ibg) + msp=tsnk ! DO WE HAVE A 6 M DATA FOR THIS?! + + + !******** decode bulk met data **** + + ts = tsnk ! if(ibg .eq. 1) ts=tsnk ! CHECK THIS OUT + tsea=tsnk !bulk sea surface temp + t=ta !air temp + qs=qsee(tsea, P) !bulk sea surface humidity + q=qa !air humidity + Rs=rs !downward solar flux + Rl=rl !doward IR flux + rain=org !rain rate + + !********* set condition dependent stuff ****** + + Le=(2.501-.00237*tsea)*1e6 + rhoa=P*100/(Rgas*(t+tdk)*(1+0.61*q/1000)) + visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) + + ts=tsea + qs=qsee(ts, P) + a=.018 + b=.729 + twave=b*u + hwave=a*u**2.*(1+.015*u) + + x=(/u, us, ts, t, qs, q, Rs, Rl, rain, zi, P, zu, zt, zq, lat, jcool, jwave, twave, hwave/) + + !******** call modified LKB routine ******* + + call cor30a(x,y) + + !****************** output from routine ***************************** + + hsb=y(1) !sensible heat flux W/m/m + hlb=y(2) !latent + taub=y(3) !stress + zo=y(4) !vel roughness + zot=y(5) !temp " + zoq=y(6) !hum " + L=y(7) !Ob Length + usr=y(8) !ustar + tsr=y(9) !tstar + qsr=y(10) !qstar [g/g] + dter=y(11) !cool skin delta T + dqer=y(12) ! " " " q + tkt=y(13) !thickness of cool skin + RF=y(14) !rain heat flux + wbar=y(15) !webb mean w + Cd=y(16) !drag @ zu + Ch=y(17) + Ce=y(18) !Dalton + Cdn_10=y(19) !neutral drag @ 10 [includes gustiness] + Chn_10=y(20) + Cen_10=y(21) + Wg=y(22) + + + !********** new values from this code + hnet(ibg)=Rns-Rnl-hsb-hlb-RF !total heat input to ocean + hl_webb=rhoa*Le*wbar*qa/1000 + + ! OUR OUTPUT HERE - DO WE WANT ANY MORE OUTUPUT, IS Cdn, Chn and Cen stuff correct at 10 + hf_array(ibg) = y(1) + ef_array(ibg) = y(2) + rf_array(ibg) = y(14) + Cdn_array(ibg) = y(19) + Chn_array(ibg) = y(20) + Cen_array(ibg) = y(21) + + enddo + + contains + + + subroutine cor30a(x,y) + + !version with shortened iteration modified Rt and Rq + !uses wave information wave period in s and wave ht in m + !no wave, standard coare 2.6 charnock: jwave=0 + !Oost et al. zo=50/2/pi L (u*/c)**4.5 if jwave=1 + !taylor and yelland zo=1200 h*(L/h)**4.5 jwave=2 + + implicit none + + real x(19), y(22) + real u,us,ts,t,Qs,Q,Rs,Rl,rain,zi,P,zu,zt,zq,lat,jcool,twave,hwave + real Beta,von,fdg,tdk,grav,Rgas,Le,cpa,cpv,rhoa,visa,Al,be,cpw,rhow,visw,tcw,bigc,wetc + real lwave,cwave,Rns,Rnl,du,dt,dq,qout,dels,qcol,alq,xlamx,alfac,bf,cc,cd10,ch10,charn,ct,ct10,dtmp,dwat,hl_webb + real jwave, l10,pi,ribcu,ribu,rr,ta,u10,ut,zet,zetu,zo10,zot10 + real hsb, hlb, tau, zo, zot, zoq, L, usr, tsr, qsr, dter, dqer, tkt, RF, wbar, Cd, Ch, Ce, Cdn_10, Chn_10, Cen_10, ug + integer i,nits + + u=x(1) !wind speed (m/s) at height zu (m) + us=x(2) !surface current speed in the wind direction (m/s) + ts=x(3) !bulk water temperature (C) if jcool=1, interface water T if jcool=0 + t=x(4) !bulk air temperature (C), height zt + Qs=x(5)/1000 !bulk water spec hum (g/kg) if jcool=1, ... + Q=x(6)/1000 !bulk air spec hum (g/kg), height zq + Rs=x(7) !downward solar flux (W/m**2) + Rl=x(8) !downard IR flux (W/m**2) + rain=x(9) !rain rate (mm/hr) + zi=x(10) !PBL depth (m) + P=x(11) !Atmos surface pressure (mb) + zu=x(12) !wind speed measurement height (m) + zt=x(13) !air T measurement height (m) + zq=x(14) !air q measurement height (m) + lat=x(15) !latitude (deg, N=+) + jcool=x(16) !implement cool calculation skin switch, 0=no, 1=yes + jwave=x(17) !implement wave dependent roughness model + twave=x(18) !wave period (s) + hwave=x(19) !wave height (m) + + !***************** set constants ************* + Beta=1.2 + von=0.4 + fdg=1.00 + tdk=273.15 + pi = 3.141593 + grav=grv(lat) !9.82 + !************* air constants ************ + Rgas=287.1 + Le=(2.501-.00237*ts)*1e6 + cpa=1004.67 + cpv=cpa*(1+0.84*Q) + rhoa=P*100/(Rgas*(t+tdk)*(1+0.61*Q)) + visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) + !************ cool skin constants ******* + Al=2.1e-5*(ts+3.2)**0.79 + be=0.026 + cpw=4000 + rhow=1022 + visw=1e-6 + tcw=0.6 + bigc=16*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) + wetc=0.622*Le*Qs/(Rgas*(ts+tdk)**2) + + !*************** wave parameters ********* + lwave=grav/2/pi*twave**2 + cwave=grav/2/pi*twave + + !************** compute aux stuff ******* + Rns=Rs*.945 + Rnl=0.97*(5.67e-8*(ts-0.3*jcool+tdk)**4-Rl) + + !*************** Begin bulk loop ******* + + !*************** first guess ************ + du=u-us + dt=ts-t-.0098*zt + dq=Qs-Q + ta=t+tdk + ug=.5 + dter=0.3 + dqer=wetc*dter + ut=sqrt(du*du+ug*ug) + u10=ut*log(10/1e-4)/log(zu/1e-4) + usr=.035*u10 + zo10=0.011*usr*usr/grav+0.11*visa/usr + Cd10=(von/log(10/zo10))**2 + Ch10=0.00115 + Ct10=Ch10/sqrt(Cd10) + zot10=10/exp(von/Ct10) + Cd=(von/log(zu/zo10))**2 + Ct=von/log(zt/zot10) + CC=von*Ct/Cd + Ribcu=-zu/zi/.004/Beta**3 + Ribu=-grav*zu/ta*((dt-dter*jcool)+.61*ta*dq)/ut**2 + nits=3 + if (Ribu .LT. 0) then + zetu=CC*Ribu/(1+Ribu/Ribcu) else - ug=.2 + zetu=CC*Ribu*(1+27/9*Ribu/CC) endif - ut=sqrt(du*du+ug*ug) - Rnl=0.97*(5.67e-8*(ts-dter*jcool+tdk)**4-Rl) + L10=zu/zetu + if (zetu .GT. 50) then + nits=1 + endif + usr=ut*von/(log(zu/zo10)-psiuo(zu/L10)) + tsr=-(dt-dter*jcool)*von*fdg/(log(zt/zot10)-psit_30(zt/L10)) + qsr=-(dq-wetc*dter*jcool)*von*fdg/(log(zq/zot10)-psit_30(zq/L10)) + tkt=.001 + charn=0.011 + if (ut .GT. 10) then + charn=0.011+(ut-10)/(18-10)*(0.018-0.011) + endif + if (ut .GT. 18) then + charn=0.018 + endif + + !*************** bulk loop ************ + do i=1, nits + + zet=von*grav*zu/ta*(tsr*(1+0.61*Q)+.61*ta*qsr)/(usr*usr)/(1+0.61*Q) + !disp(usr) + !disp(zet) + if (jwave .EQ. 0) zo=charn*usr*usr/grav+0.11*visa/usr + if (jwave .EQ. 1) zo=50/2/pi*lwave*(usr/cwave)**4.5+0.11*visa/usr !Oost et al + if (jwave .EQ. 2) zo=1200*hwave*(hwave/lwave)**4.5+0.11*visa/usr !Taylor and Yelland + rr=zo*usr/visa + L=zu/zet + zoq=min(1.15e-4,5.5e-5/rr**.6) + zot=zoq + usr=ut*von/(log(zu/zo)-psiuo(zu/L)) + tsr=-(dt-dter*jcool)*von*fdg/(log(zt/zot)-psit_30(zt/L)) + qsr=-(dq-wetc*dter*jcool)*von*fdg/(log(zq/zoq)-psit_30(zq/L)) + Bf=-grav/ta*usr*(tsr+.61*ta*qsr) + if (Bf .GT. 0) then + ug=Beta*(Bf*zi)**.333 + else + ug=.2 + endif + ut=sqrt(du*du+ug*ug) + Rnl=0.97*(5.67e-8*(ts-dter*jcool+tdk)**4-Rl) + hsb=-rhoa*cpa*usr*tsr + hlb=-rhoa*Le*usr*qsr + qout=Rnl+hsb+hlb + dels=Rns*(.065+11*tkt-6.6e-5/tkt*(1-exp(-tkt/8.0e-4))) ! Eq.16 Shortwave + qcol=qout-dels + alq=Al*qcol+be*hlb*cpw/Le ! Eq. 7 Buoy flux water + + if (alq .GT. 0) then + xlamx=6/(1+(bigc*alq/usr**4)**.75)**.333 ! Eq 13 Saunders + tkt=xlamx*visw/(sqrt(rhoa/rhow)*usr) !Eq.11 Sub. thk + + else + xlamx=6.0 + tkt=min(.01,xlamx*visw/(sqrt(rhoa/rhow)*usr)) !Eq.11 Sub. thk + endif + + dter=qcol*tkt/tcw ! Eq.12 Cool skin + dqer=wetc*dter + ! print *,' third guesses=',usr,tsr,qsr,ug,ut + + enddo !bulk iter loop + tau=rhoa*usr*usr*du/ut !stress hsb=-rhoa*cpa*usr*tsr hlb=-rhoa*Le*usr*qsr - qout=Rnl+hsb+hlb - dels=Rns*(.065+11*tkt-6.6e-5/tkt*(1-exp(-tkt/8.0e-4))) ! Eq.16 Shortwave - qcol=qout-dels - alq=Al*qcol+be*hlb*cpw/Le ! Eq. 7 Buoy flux water - if (alq .GT. 0) then - xlamx=6/(1+(bigc*alq/usr**4)**.75)**.333 ! Eq 13 Saunders - tkt=xlamx*visw/(sqrt(rhoa/rhow)*usr) !Eq.11 Sub. thk + !**************** rain heat flux ******** + + dwat=2.11e-5*((t+tdk)/tdk)**1.94 !! water vapour diffusivity + dtmp=(1.+3.309e-3*t-1.44e-6*t*t)*0.02411/(rhoa*cpa) !!heat diffusivity + alfac= 1/(1+(wetc*Le*dwat)/(cpa*dtmp)) !! wet bulb factor + RF= rain*alfac*cpw*((ts-t-dter*jcool)+(Qs-Q-dqer*jcool)*Le/cpa)/3600 + !**************** Webb et al. correection ************ + wbar=1.61*hlb/Le/(1+1.61*Q)/rhoa+hsb/rhoa/cpa/ta !formulation in hlb already includes webb + !wbar=1.61*hlb/Le/rhoa+(1+1.61*Q)*hsb/rhoa/cpa/ta + hl_webb=rhoa*wbar*Q*Le + !************** compute transfer coeffs relative to ut @meas. ht ********** + Cd=tau/rhoa/ut/max(.1,du) + Ch=-usr*tsr/ut/(dt-dter*jcool) + Ce=-usr*qsr/(dq-dqer*jcool)/ut + !************ 10-m neutral coeff realtive to ut ******** + Cdn_10=von*von/log(10/zo)/log(10/zo) + Chn_10=von*von*fdg/log(10/zo)/log(10/zot) + Cen_10=von*von*fdg/log(10/zo)/log(10/zoq) + !**************** the Y array going back tom the main program **************** + y=(/hsb, hlb, tau, zo, zot, zoq, L, usr, tsr, qsr, dter, dqer, tkt, RF, wbar, Cd, Ch, Ce, Cdn_10, Chn_10, Cen_10, ug /) + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 + + end subroutine cor30a + + function qsee(ts,Pa) + real :: ts,Pa + real qsee + real x, es, p + + x=ts + p=Pa + es=6.112*exp(17.502*x/(x+240.97))*.98*(1.0007+3.46e-6*p) + qsee=es*621.97/(p-.378*es) + + end function qsee + + function grv(lat) + real lat + real grv + real, parameter :: gamma=9.7803267715 + real, parameter :: c1=0.0052790414 + real, parameter :: c2=0.0000232718 + real, parameter :: c3=0.0000001262 + real, parameter :: c4=0.0000000007 + real, parameter :: pi=3.141593 + real phi, x + + phi=lat*pi/180 + x=sin(phi) + grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) + + end function grv + + function psiuo(zet) + + real :: psiuo, zet, psik, psic, f, c, x + + x=(1.-15.*zet)**.25 + psik=2.*log((1.+x)/2.)+log((1.+x*x)/2.)-2.*atan(x)+2.*atan(1.) + x=(1.-10.15*zet)**.3333 + psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.) + f=zet*zet/(1+zet*zet) + psiuo=(1-f)*psik+f*psic + if(zet>0)then + c=min(50.,.35*zet) + psiuo=-((1+1.0*zet)**1.0+.667*(zet-14.28)/exp(c)+8.525) + endif + end function psiuo + + function psit_30(zet) - else - xlamx=6.0 - tkt=min(.01,xlamx*visw/(sqrt(rhoa/rhow)*usr)) !Eq.11 Sub. thk + real psit_30, zet, x, psik, psic, f, c + + x=(1.-(15*zet))**.5 + psik=2*log((1+x)/2) + x=(1.-(34.15*zet))**.3333 + psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.) + f=zet*zet/(1+zet*zet) + psit_30=(1-f)*psik+f*psic + + if(zet>0)then + c=min(50.,.35*zet) + psit_30=-((1.+2./3.*zet)**1.5+.6667*(zet-14.28)/exp(c)+8.525) endif + end function psit_30 - dter=qcol*tkt/tcw ! Eq.12 Cool skin - dqer=wetc*dter - ! print *,' third guesses=',usr,tsr,qsr,ug,ut - - enddo !bulk iter loop - tau=rhoa*usr*usr*du/ut !stress - hsb=-rhoa*cpa*usr*tsr - hlb=-rhoa*Le*usr*qsr - - !**************** rain heat flux ******** - - dwat=2.11e-5*((t+tdk)/tdk)**1.94 !! water vapour diffusivity - dtmp=(1.+3.309e-3*t-1.44e-6*t*t)*0.02411/(rhoa*cpa) !!heat diffusivity - alfac= 1/(1+(wetc*Le*dwat)/(cpa*dtmp)) !! wet bulb factor - RF= rain*alfac*cpw*((ts-t-dter*jcool)+(Qs-Q-dqer*jcool)*Le/cpa)/3600 - !**************** Webb et al. correection ************ - wbar=1.61*hlb/Le/(1+1.61*Q)/rhoa+hsb/rhoa/cpa/ta !formulation in hlb already includes webb - !wbar=1.61*hlb/Le/rhoa+(1+1.61*Q)*hsb/rhoa/cpa/ta - hl_webb=rhoa*wbar*Q*Le - !************** compute transfer coeffs relative to ut @meas. ht ********** - Cd=tau/rhoa/ut/max(.1,du) - Ch=-usr*tsr/ut/(dt-dter*jcool) - Ce=-usr*qsr/(dq-dqer*jcool)/ut - !************ 10-m neutral coeff realtive to ut ******** - Cdn_10=von*von/log(10/zo)/log(10/zo) - Chn_10=von*von*fdg/log(10/zo)/log(10/zot) - Cen_10=von*von*fdg/log(10/zo)/log(10/zoq) - !**************** the Y array going back tom the main program **************** - y=(/hsb, hlb, tau, zo, zot, zoq, L, usr, tsr, qsr, dter, dqer, tkt, RF, wbar, Cd, Ch, Ce, Cdn_10, Chn_10, Cen_10, ug /) - ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - - end subroutine cor30a - - function qsee(ts,Pa) - real :: ts,Pa - real qsee - real x, es, p - - x=ts - p=Pa - es=6.112*exp(17.502*x/(x+240.97))*.98*(1.0007+3.46e-6*p) - qsee=es*621.97/(p-.378*es) - - end function qsee - - function grv(lat) - real lat - real grv - real, parameter :: gamma=9.7803267715 - real, parameter :: c1=0.0052790414 - real, parameter :: c2=0.0000232718 - real, parameter :: c3=0.0000001262 - real, parameter :: c4=0.0000000007 - real, parameter :: pi=3.141593 - real phi, x - - phi=lat*pi/180 - x=sin(phi) - grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) - - end function grv - - function psiuo(zet) - - real :: psiuo, zet, psik, psic, f, c, x - - x=(1.-15.*zet)**.25 - psik=2.*log((1.+x)/2.)+log((1.+x*x)/2.)-2.*atan(x)+2.*atan(1.) - x=(1.-10.15*zet)**.3333 - psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.) - f=zet*zet/(1+zet*zet) - psiuo=(1-f)*psik+f*psic - if(zet>0)then - c=min(50.,.35*zet) - psiuo=-((1+1.0*zet)**1.0+.667*(zet-14.28)/exp(c)+8.525) - endif - end function psiuo - - function psit_30(zet) - - real psit_30, zet, x, psik, psic, f, c - - x=(1.-(15*zet))**.5 - psik=2*log((1+x)/2) - x=(1.-(34.15*zet))**.3333 - psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.) - f=zet*zet/(1+zet*zet) - psit_30=(1-f)*psik+f*psic - - if(zet>0)then - c=min(50.,.35*zet) - psit_30=-((1.+2./3.*zet)**1.5+.6667*(zet-14.28)/exp(c)+8.525) - endif - end function psit_30 - - end subroutine coare30_ocean_fluxes - - - subroutine kara_ocean_fluxes(points, u, v, R, Ta, Ts, Va, lhf, shf, & - tau_u, tau_v, tau_r, Ce, Cd, Ch) - - implicit none - - ! INPUT: - ! u = Zonal wins speed component (m s^-1) - ! v = Meridional wins speed component (m s^-1) - ! R = Rain rate (mm h^-1) - ! Ta = Air temp at 10 m above sea level (C) - ! Ts = Sea surface temperature (C) - ! Va = Wind speed at 10 m above sea level (m s^-1) - - ! OUTPUT - ! lhf = Latent heat flux (W m^-2) - ! shf = Sensible heat flux (W m^-2) - ! tau_u = Zonal component of wind stress (N m^-2) - ! tau_v = Zonal component of wind stress (N m^-2) - ! tau_r = Wind stress due to rain fall (N m^-2) - ! Ce = Latent heat flux coefficient - ! Cd = Wind stress drag coefficient - ! Ch = Sensible heat flux coefficient - integer, intent(in) :: points - real , intent(in) , dimension(points) :: u, v, R, Ta, Ts - real , intent(inout), dimension(points) :: Va - real, intent(out), dimension(points) :: lhf, shf, tau_u, tau_v, tau_r, Ce, Cd, Ch - ! Temp variables - real :: Cd0, Cd1, Ce0, Ce1, pa_i, qa, qs - integer :: i + end subroutine coare30_ocean_fluxes + + + subroutine kara_ocean_fluxes(points, u, v, R, Ta, Ts, Va, lhf, shf, & + tau_u, tau_v, tau_r, Ce, Cd, Ch) + + implicit none + + ! INPUT: + ! u = Zonal wins speed component (m s^-1) + ! v = Meridional wins speed component (m s^-1) + ! R = Rain rate (mm h^-1) + ! Ta = Air temp at 10 m above sea level (C) + ! Ts = Sea surface temperature (C) + ! Va = Wind speed at 10 m above sea level (m s^-1) + + ! OUTPUT + ! lhf = Latent heat flux (W m^-2) + ! shf = Sensible heat flux (W m^-2) + ! tau_u = Zonal component of wind stress (N m^-2) + ! tau_v = Zonal component of wind stress (N m^-2) + ! tau_r = Wind stress due to rain fall (N m^-2) + ! Ce = Latent heat flux coefficient + ! Cd = Wind stress drag coefficient + ! Ch = Sensible heat flux coefficient + integer, intent(in) :: points + real , intent(in) , dimension(points) :: u, v, R, Ta, Ts + real , intent(inout), dimension(points) :: Va + real, intent(out), dimension(points) :: lhf, shf, tau_u, tau_v, tau_r, Ce, Cd, Ch + ! Temp variables + real :: Cd0, Cd1, Ce0, Ce1, pa_i, qa, qs + integer :: i - ! Constants here - real :: Cp, L, Pa, Rgas, absT - Cp = 1004.5 ! Specific heat of air (J kg^-1 K^-1) - L = 2.5*10.0**6.0 ! Latent heat of vaporisation (J kg^-1) - Pa = 1013.0 ! Atmospheric pressure at sea surface (mb) - Rgas = 287.1 ! Gas constant (J Kg^-1 K^-1) - absT = 273.16 ! Absolute Temperature + ! Constants here + real :: Cp, L, Pa, Rgas, absT + Cp = 1004.5 ! Specific heat of air (J kg^-1 K^-1) + L = 2.5*10.0**6.0 ! Latent heat of vaporisation (J kg^-1) + Pa = 1013.0 ! Atmospheric pressure at sea surface (mb) + Rgas = 287.1 ! Gas constant (J Kg^-1 K^-1) + absT = 273.16 ! Absolute Temperature - ! Main loop - do i=1,points - Va(i) = max(2.5, min(32.5, Va(i))); - pa_i = 100.0*Pa/(Rgas*(Ta(i) + absT)) + ! Main loop + do i=1,points + Va(i) = max(2.5, min(32.5, Va(i))); + pa_i = 100.0*Pa/(Rgas*(Ta(i) + absT)) - Cd0 = 1.0/1000*(0.862 + 0.088*Va(i) - 0.00089*(Va(i))**2) - Cd1 = 1.0/1000*(0.1034 - 0.00678*Va(i) + 0.0001147*(Va(i))**2) - Cd(i) = Cd0 + Cd1*(Ts(i) - Ta(i)) + Cd0 = 1.0/1000*(0.862 + 0.088*Va(i) - 0.00089*(Va(i))**2) + Cd1 = 1.0/1000*(0.1034 - 0.00678*Va(i) + 0.0001147*(Va(i))**2) + Cd(i) = Cd0 + Cd1*(Ts(i) - Ta(i)) - tau_u(i) = pa_i*Cd(i)*u(i)*sqrt(u(i)**2 + v(i)**2) - tau_v(i) = pa_i*Cd(i)*v(i)*sqrt(u(i)**2 + v(i)**2) - tau_r(i) = R(i)*Va(i)/3600 + tau_u(i) = pa_i*Cd(i)*u(i)*sqrt(u(i)**2 + v(i)**2) + tau_v(i) = pa_i*Cd(i)*v(i)*sqrt(u(i)**2 + v(i)**2) + tau_r(i) = R(i)*Va(i)/3600 - Ce0 = 1.0/1000*(0.994 + 0.061*Va(i) - 0.001*(Va(i))**2) - Ce1 = 1.0/1000*(-0.020 + 0.691*(1/Va(i)) - 0.817*(1/(Va(i)))**2) - Ce(i) = Ce0 + Ce1*(Ts(i) - Ta(i)) - Ch(i) = 0.96*Ce(i) + Ce0 = 1.0/1000*(0.994 + 0.061*Va(i) - 0.001*(Va(i))**2) + Ce1 = 1.0/1000*(-0.020 + 0.691*(1/Va(i)) - 0.817*(1/(Va(i)))**2) + Ce(i) = Ce0 + Ce1*(Ts(i) - Ta(i)) + Ch(i) = 0.96*Ce(i) - shf(i) = Ch(i)*Cp*pa_i*Va(i)*(Ta(i) - Ts(i)) - qa = R(i)*shf(i)*qsat(Ta(i), Pa) - qs = 0.98*qsat(Ts(i), Pa) - lhf(i) = Ce(i)*L*pa_i*Va(i)*(qa - qs) + shf(i) = Ch(i)*Cp*pa_i*Va(i)*(Ta(i) - Ts(i)) + qa = R(i)*shf(i)*qsat(Ta(i), Pa) + qs = 0.98*qsat(Ts(i), Pa) + lhf(i) = Ce(i)*L*pa_i*Va(i)*(qa - qs) - end do + end do - contains + contains - function qsat (T, Pa) + function qsat (T, Pa) - real :: T, Pa, qsat + real :: T, Pa, qsat - qsat = 0.622*es(T, Pa)/(Pa - 0.378*es(T, Pa)) + qsat = 0.622*es(T, Pa)/(Pa - 0.378*es(T, Pa)) - end function qsat + end function qsat - function es (T, Pa) + function es (T, Pa) - real :: T, Pa, es + real :: T, Pa, es - es = (1.0 + 3.46*(10.0**(-6))*Pa)*6.1121*exp(17.50*T/(240.97 + T)) + es = (1.0 + 3.46*(10.0**(-6))*Pa)*6.1121*exp(17.50*T/(240.97 + T)) - end function es + end function es - end subroutine kara_ocean_fluxes + end subroutine kara_ocean_fluxes end module bulk_parameterisations diff --git a/ocean_forcing/forcingERA40_fortran.F90 b/ocean_forcing/forcingERA40_fortran.F90 index e39c35f25f..9b5ebbf8d8 100644 --- a/ocean_forcing/forcingERA40_fortran.F90 +++ b/ocean_forcing/forcingERA40_fortran.F90 @@ -29,58 +29,58 @@ ! Wrap up the public bulk formula routines subroutine ncar_forcing_c(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) - use bulk_parameterisations - implicit none - integer, intent(in) :: points - real, intent(in), dimension(points) :: speed, air_temp, sst, spec_humidity, sea_surface_humidity - real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal - real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes - real, intent(out), dimension(points) :: F ! Freshwater flux - real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) + use bulk_parameterisations + implicit none + integer, intent(in) :: points + real, intent(in), dimension(points) :: speed, air_temp, sst, spec_humidity, sea_surface_humidity + real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal + real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes + real, intent(out), dimension(points) :: F ! Freshwater flux + real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes - call ncar_forcing(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) + call ncar_forcing(points, speed, air_temp, sst, spec_humidity, & + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) end subroutine ncar_forcing_c subroutine coare_forcing_c(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) - use bulk_parameterisations - implicit none - integer, intent(in) :: points - real, intent(in), dimension(points) :: speed, spec_humidity, sea_surface_humidity - real, intent(inout), dimension(points) :: air_temp, sst - real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal - real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes - real, intent(out), dimension(points) :: F ! Freshwater flux - real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) + use bulk_parameterisations + implicit none + integer, intent(in) :: points + real, intent(in), dimension(points) :: speed, spec_humidity, sea_surface_humidity + real, intent(inout), dimension(points) :: air_temp, sst + real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal + real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes + real, intent(out), dimension(points) :: F ! Freshwater flux + real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes - call coare_forcing(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) + call coare_forcing(points, speed, air_temp, sst, spec_humidity, & + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) end subroutine coare_forcing_c subroutine kara_forcing_c(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) - use bulk_parameterisations - implicit none - integer, intent(in) :: points - real, intent(inout), dimension(points) :: speed - real, intent(in), dimension(points) :: spec_humidity, sea_surface_humidity - real, intent(inout), dimension(points) :: air_temp, sst - real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal - real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes - real, intent(out), dimension(points) :: F ! Freshwater flux - real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) + use bulk_parameterisations + implicit none + integer, intent(in) :: points + real, intent(inout), dimension(points) :: speed + real, intent(in), dimension(points) :: spec_humidity, sea_surface_humidity + real, intent(inout), dimension(points) :: air_temp, sst + real, intent(in), dimension(points) :: U, V, ppt, runoff, salinity, solar, thermal + real, intent(out), dimension(points) :: Q_solar, Q ! heat fluxes + real, intent(out), dimension(points) :: F ! Freshwater flux + real, intent(out), dimension(points) :: tau_u, tau_v ! momentum fluxes - call kara_forcing(points, speed, air_temp, sst, spec_humidity, & - sea_surface_humidity, U, V, ppt, runoff, salinity, & - thermal, solar, Q_solar, Q, F, tau_u, tau_v) + call kara_forcing(points, speed, air_temp, sst, spec_humidity, & + sea_surface_humidity, U, V, ppt, runoff, salinity, & + thermal, solar, Q_solar, Q, F, tau_u, tau_v) end subroutine kara_forcing_c diff --git a/ocean_forcing/load_netcdf.F90 b/ocean_forcing/load_netcdf.F90 index 45405a090c..c0f5463bb4 100644 --- a/ocean_forcing/load_netcdf.F90 +++ b/ocean_forcing/load_netcdf.F90 @@ -2,111 +2,111 @@ #include "fdebug.h" module load_netcdf_module -use fldebug -use global_parameters -use spud -use fields -use coordinates -use Field_Options + use fldebug + use global_parameters + use spud + use fields + use coordinates + use Field_Options -implicit none + implicit none -private + private -public :: set_scalar_field_from_netcdf + public :: set_scalar_field_from_netcdf -logical :: on_sphere + logical :: on_sphere contains -subroutine set_scalar_field_from_netcdf(field,path,position) + subroutine set_scalar_field_from_netcdf(field,path,position) - type(scalar_field), intent(inout) :: field - character(len=*), intent(in) :: path - type(vector_field), intent(in) :: position - character(len=OPTION_PATH_LEN) :: format + type(scalar_field), intent(inout) :: field + character(len=*), intent(in) :: path + type(vector_field), intent(in) :: position + character(len=OPTION_PATH_LEN) :: format - ! Are we getting data on a cartesian or lon-lat grid? - on_sphere = have_option('/geometry/spherical_earth/') + ! Are we getting data on a cartesian or lon-lat grid? + on_sphere = have_option('/geometry/spherical_earth/') - call load_netcdf_values(field,path,position) + call load_netcdf_values(field,path,position) - call get_option(trim(path)//"/from_netcdf/format", format) + call get_option(trim(path)//"/from_netcdf/format", format) - select case (format) - ! It is possible to manipulate imported netCDF data here. - ! Note that the 'Free-surface height' format option is no longer supported. - ! In this case the 'free_surface' node under pressure initial conditions should be used. + select case (format) + ! It is possible to manipulate imported netCDF data here. + ! Note that the 'Free-surface height' format option is no longer supported. + ! In this case the 'free_surface' node under pressure initial conditions should be used. - case ("raw") - ewrite(3,*) "The data used to initialise field " // trim(field%name) // & - ", has been treated as the raw values and not post-processed after import." + case ("raw") + ewrite(3,*) "The data used to initialise field " // trim(field%name) // & + ", has been treated as the raw values and not post-processed after import." - case default - ewrite(-1,*) "The format " // trim(format) // ", is not a recognised method to handle netCDF files." - ewrite(-1,*) "Please specify a valid format for initialiasing the field " // trim(field%name) // & - ", at " // trim(path) // "/from_netcdf/format" - FLAbort("Fatal error initialising a field from a netCDF file.") + case default + ewrite(-1,*) "The format " // trim(format) // ", is not a recognised method to handle netCDF files." + ewrite(-1,*) "Please specify a valid format for initialiasing the field " // trim(field%name) // & + ", at " // trim(path) // "/from_netcdf/format" + FLAbort("Fatal error initialising a field from a netCDF file.") - end select + end select -end subroutine + end subroutine -subroutine load_netcdf_values(field,path,position) + subroutine load_netcdf_values(field,path,position) - type(scalar_field), intent(inout) :: field - character(len=*), intent(in) :: path - type(vector_field), intent(in) :: position - real, dimension(position%dim,node_count(position)) :: temp_pos - character(len=FIELD_NAME_LEN) :: filename - real, dimension(:), allocatable :: X, Y, Z - integer :: NNodes, i + type(scalar_field), intent(inout) :: field + character(len=*), intent(in) :: path + type(vector_field), intent(in) :: position + real, dimension(position%dim,node_count(position)) :: temp_pos + character(len=FIELD_NAME_LEN) :: filename + real, dimension(:), allocatable :: X, Y, Z + integer :: NNodes, i - assert(node_count(field)==node_count(position)) + assert(node_count(field)==node_count(position)) - call get_option(trim(path)//"/from_netcdf/file_name", filename) + call get_option(trim(path)//"/from_netcdf/file_name", filename) - ewrite(1,*) "Populating field " // trim(field%name) // & - ", with data from the netCDF file: " // trim(filename) + ewrite(1,*) "Populating field " // trim(field%name) // & + ", with data from the netCDF file: " // trim(filename) - NNodes = node_count(field) + NNodes = node_count(field) - allocate(X(NNodes), Y(NNodes), Z(NNodes)) + allocate(X(NNodes), Y(NNodes), Z(NNodes)) - if (on_sphere) then - ! Convert x,y,z coords to lon,lat - do i=1,NNodes - temp_pos(:,i)=node_val(position,i) - end do - call LongitudeLatitude(temp_pos, X, Y) - else - if (position%dim==2) then - do i=1,NNodes - temp_pos(:,i)=node_val(position,i) - X(i)=temp_pos(1,i) - Y(i)=temp_pos(2,i) - end do - else if (position%dim==3) then - ! Tri-linear interpolation is not currently supported but - ! this is here for when someone needs it. - do i=1,NNodes - temp_pos(:,i)=node_val(position,i) - X(i)=temp_pos(1,i) - Y(i)=temp_pos(2,i) - end do - else - FLExit("This dimension is currently not supported") - end if - end if + if (on_sphere) then + ! Convert x,y,z coords to lon,lat + do i=1,NNodes + temp_pos(:,i)=node_val(position,i) + end do + call LongitudeLatitude(temp_pos, X, Y) + else + if (position%dim==2) then + do i=1,NNodes + temp_pos(:,i)=node_val(position,i) + X(i)=temp_pos(1,i) + Y(i)=temp_pos(2,i) + end do + else if (position%dim==3) then + ! Tri-linear interpolation is not currently supported but + ! this is here for when someone needs it. + do i=1,NNodes + temp_pos(:,i)=node_val(position,i) + X(i)=temp_pos(1,i) + Y(i)=temp_pos(2,i) + end do + else + FLExit("This dimension is currently not supported") + end if + end if - call get_field_values(trim(filename)//char(0), X, Y, Z, NNodes) + call get_field_values(trim(filename)//char(0), X, Y, Z, NNodes) - do i=1,NNodes - call set(field,i,Z(i)) - enddo + do i=1,NNodes + call set(field,i,Z(i)) + enddo - deallocate(X, Y, Z) + deallocate(X, Y, Z) -end subroutine + end subroutine end module load_netcdf_module diff --git a/ocean_forcing/tests/test_fluxes_reader_wrapper.F90 b/ocean_forcing/tests/test_fluxes_reader_wrapper.F90 index 977b130ab5..117ce5e7e9 100644 --- a/ocean_forcing/tests/test_fluxes_reader_wrapper.F90 +++ b/ocean_forcing/tests/test_fluxes_reader_wrapper.F90 @@ -1,49 +1,49 @@ subroutine test_fluxes_reader_wrapper - use unittest_tools - use fluxes - implicit none + use unittest_tools + use fluxes + implicit none - real :: correct, value, correct_d, correct_t, values(2) - logical :: fail + real :: correct, value, correct_d, correct_t, values(2) + logical :: fail - ! Run the first GetScalar(..) test from FluxesReader test via the Fortran wrappers - fail = .true. - call fluxes_registerdatafile("../../tests/data/global_fluxes.nc") - call fluxes_addfieldofinterest("_2t") - call fluxes_setsimulationtimeunits("seconds since 1960-01-01 06:00:0.0") - call fluxes_settimeseconds(0.0) + ! Run the first GetScalar(..) test from FluxesReader test via the Fortran wrappers + fail = .true. + call fluxes_registerdatafile("../../tests/data/global_fluxes.nc") + call fluxes_addfieldofinterest("_2t") + call fluxes_setsimulationtimeunits("seconds since 1960-01-01 06:00:0.0") + call fluxes_settimeseconds(0.0) - correct = 299.237; - call fluxes_getscalar("_2t",210.0,10.0, value) - if(abs(value-correct) < 0.001) then - fail = .false. - else - write(0,*) "Expected ", correct, ", got ", value - end if - call report_test("[test_fluxes_reader_wrapper: GetScalar single point 1]", fail, .false., & - "Got incorrect value") + correct = 299.237; + call fluxes_getscalar("_2t",210.0,10.0, value) + if(abs(value-correct) < 0.001) then + fail = .false. + else + write(0,*) "Expected ", correct, ", got ", value + end if + call report_test("[test_fluxes_reader_wrapper: GetScalar single point 1]", fail, .false., & + "Got incorrect value") - ! Run the first GetScalars(..) test from FluxesReader test via the Fortran wrappers - fail = .true. - call fluxes_addfieldofinterest("_2d") - call fluxes_settimeseconds(0.0) + ! Run the first GetScalars(..) test from FluxesReader test via the Fortran wrappers + fail = .true. + call fluxes_addfieldofinterest("_2d") + call fluxes_settimeseconds(0.0) - correct_t = 299.237; - correct_d = 296.316; - call fluxes_getscalars(210.0,10.0, values) - if(abs(values(1)-correct_t) < 0.001) then - fail = .false. - else - write(0,*) "t expected ", correct, ", got ", value - end if - call report_test("[test_fluxes_reader_wrapper: GetScalars single point: t]", fail, .false., & - "Got incorrect value") - if(abs(values(2)-correct_d) < 0.001) then - fail = .false. - else - write(0,*) "d expected ", correct, ", got ", value - end if - call report_test("[test_fluxes_reader_wrapper: GetScalars single point: d]", fail, .false., & - "Got incorrect value") + correct_t = 299.237; + correct_d = 296.316; + call fluxes_getscalars(210.0,10.0, values) + if(abs(values(1)-correct_t) < 0.001) then + fail = .false. + else + write(0,*) "t expected ", correct, ", got ", value + end if + call report_test("[test_fluxes_reader_wrapper: GetScalars single point: t]", fail, .false., & + "Got incorrect value") + if(abs(values(2)-correct_d) < 0.001) then + fail = .false. + else + write(0,*) "d expected ", correct, ", got ", value + end if + call report_test("[test_fluxes_reader_wrapper: GetScalars single point: d]", fail, .false., & + "Got incorrect value") end subroutine test_fluxes_reader_wrapper diff --git a/parameterisation/Equation_of_State.F90 b/parameterisation/Equation_of_State.F90 index c085b80430..fdd59cad8f 100644 --- a/parameterisation/Equation_of_State.F90 +++ b/parameterisation/Equation_of_State.F90 @@ -27,255 +27,255 @@ #include "fdebug.h" module equation_of_state - !!< This module contains functions used to evaluate the equation of state. + !!< This module contains functions used to evaluate the equation of state. - use fldebug - use global_parameters, only: OPTION_PATH_LEN - use futils, only: int2str - use spud - use fields - use state_module - use sediment, only: get_n_sediment_fields, get_sediment_item + use fldebug + use global_parameters, only: OPTION_PATH_LEN + use futils, only: int2str + use spud + use fields + use state_module + use sediment, only: get_n_sediment_fields, get_sediment_item - implicit none + implicit none - private - public :: calculate_perturbation_density, mcD_J_W_F2002, & - compressible_eos, compressible_material_eos + private + public :: calculate_perturbation_density, mcD_J_W_F2002, & + compressible_eos, compressible_material_eos contains - subroutine calculate_perturbation_density(state, density, reference_density) - !!< Calculates the perturbation density (i.e. the reference density is already subtracted) - !!< of a state with equation_of_state fluids/linear or - !!< fluids/ocean_pade_approximation. - type(state_type), intent(in):: state - type(scalar_field), intent(inout) :: density - real, intent(out), optional :: reference_density - - type(vector_field), pointer:: u - type(scalar_field), pointer:: T, S, oldT, oldS, topdis - type(scalar_field) DeltaT, DeltaS, remapT, remapS, sedimentdensity - character(len=OPTION_PATH_LEN) option_path, dep_option_path, sfield_name - logical, dimension(:), allocatable:: done - logical include_depth_below - real T0, S0, gamma, rho_0, salt, temp, dist, dens, theta - integer, dimension(:), pointer:: density_nodes - integer ele, i, node, n_sediment_fields, f - - ewrite(1,*) 'In calculate_perturbation_density' - - u => extract_vector_field(state, "Velocity") - - call zero(density) - - option_path='/material_phase::'//trim(state%name)//'/equation_of_state/fluids' - - call get_option(trim(u%option_path)//'/prognostic/temporal_discretisation/relaxation', & - theta, default = 1.0) - - rho_0 = 0.0 - - if (have_option(trim(option_path)//'/linear')) then - - option_path=trim(option_path)//'/linear' - - if (have_option(trim(option_path)//'/temperature_dependency')) then - dep_option_path=trim(option_path)//'/temperature_dependency' - call get_option(trim(dep_option_path)//'/reference_temperature', T0) - call get_option(trim(dep_option_path)//'/thermal_expansion_coefficient', gamma) - T => extract_scalar_field(state, "Temperature") - oldT => extract_scalar_field(state, "OldTemperature") - call allocate(deltaT, density%mesh, "DeltaT") - call allocate(remapT, density%mesh, "RemapT") - - ! deltaT=theta*T+(1-theta)*oldT-T0 - call remap_field(T, remapT) - call set(deltaT, remapT) - call scale(deltaT, theta) - - call remap_field(oldT, remapT) - call addto(deltaT, remapT, 1.0-theta) - call addto(deltaT, -T0) - ! density=density-gamma*deltaT - call addto(density, deltaT, scale=-gamma) - call deallocate(deltaT) - call deallocate(remapT) - end if - - if (have_option(trim(option_path)//'/salinity_dependency')) then - dep_option_path=trim(option_path)//'/salinity_dependency' - call get_option(trim(dep_option_path)//'/reference_salinity', S0) - call get_option(trim(dep_option_path)//'/saline_contraction_coefficient', gamma) - S => extract_scalar_field(state, "Salinity") - oldS => extract_scalar_field(state, "OldSalinity") - call allocate(deltaS, density%mesh, "DeltaS") - call allocate(remapS, density%mesh, "RemapS") - - ! deltaS=theta*S+(1-theta)*oldS-S0 - call remap_field(S, remapS) - call set(deltaS, remapS) - call scale(deltaS, theta) - - call remap_field(oldS, remapS) - call addto(deltaS, remapS, 1.0-theta) - call addto(deltaS, -S0) - ! density=density+gamma*deltaS - call addto(density, deltaS, scale=gamma) - call deallocate(deltaS) - call deallocate(remapS) - end if - - if (have_option(trim(option_path)//'/generic_scalar_field_dependency')) then - do f = 1, option_count(trim(option_path)//'/generic_scalar_field_dependency') - dep_option_path=trim(option_path)//'/generic_scalar_field_dependency['//int2str(f-1)//']' - call get_option(trim(dep_option_path)//'/name', sfield_name) - call get_option(trim(dep_option_path)//'/reference_value', T0) - call get_option(trim(dep_option_path)//'/expansion_coefficient', gamma) - T => extract_scalar_field(state, trim(sfield_name)) - oldT => extract_scalar_field(state, "Old"//trim(sfield_name)) - call allocate(deltaT, density%mesh, "DeltaT") - call allocate(remapT, density%mesh, "RemapT") - - ! deltaT=theta*T+(1-theta)*oldT-T0 - call remap_field(T, remapT) - call set(deltaT, remapT) - call scale(deltaT, theta) - - call remap_field(oldT, remapT) - call addto(deltaT, remapT, 1.0-theta) - call addto(deltaT, -T0) - ! density=density-gamma*deltaT - call addto(density, deltaT, scale=-gamma) - call deallocate(deltaT) - call deallocate(remapT) - end do - end if - - call get_option(trim(option_path)//'/reference_density', rho_0) - call scale(density, rho_0) - - elseif (have_option(trim(option_path)//'/ocean_pade_approximation')) then - - option_path=trim(option_path)//'/ocean_pade_approximation' - - include_depth_below=have_option(trim(option_path)//'/include_depth_below_surface') - - T => extract_scalar_field(state, "Temperature") - oldT => extract_scalar_field(state, "OldTemperature") - S => extract_scalar_field(state, "Salinity") - oldS => extract_scalar_field(state, "OldSalinity") - if (include_depth_below) then - topdis => extract_scalar_field(state, "DistanceToTop") - endif - - allocate( done(1:node_count(density)) ) - done=.false. - - do ele=1, element_count(density) - - density_nodes => ele_nodes(density, ele) - - do i=1,size(density_nodes) - node=density_nodes(i) - ! In the continuous case ensure we only do each calculation once. - if (done(node)) cycle - done(node)=.true. - - salt=theta*node_val(S, node)+(1-theta)*node_val(oldS, node) - temp=node_val(T, node)+(1-theta)*node_val(oldT, node) - if (include_depth_below) then - dist=node_val(topdis, node) - else - dist=0.0 - end if - - call mcD_J_W_F2002(dens,temp,salt,dist) - call addto(density, node, dens) - end do - - end do - - ! reference density is assumed 1 for the pade approximation - rho_0=1.0 - - end if - - if (have_option('/material_phase::'//trim(state%name)//'/sediment'))& - & then - - call allocate(deltaS, density%mesh, "DeltaS") - call allocate(remapS, density%mesh, "RemapS") - call allocate(sedimentdensity, density%mesh, "SedimentDensity") - call zero(sedimentdensity) - - n_sediment_fields = get_n_sediment_fields() + subroutine calculate_perturbation_density(state, density, reference_density) + !!< Calculates the perturbation density (i.e. the reference density is already subtracted) + !!< of a state with equation_of_state fluids/linear or + !!< fluids/ocean_pade_approximation. + type(state_type), intent(in):: state + type(scalar_field), intent(inout) :: density + real, intent(out), optional :: reference_density + + type(vector_field), pointer:: u + type(scalar_field), pointer:: T, S, oldT, oldS, topdis + type(scalar_field) DeltaT, DeltaS, remapT, remapS, sedimentdensity + character(len=OPTION_PATH_LEN) option_path, dep_option_path, sfield_name + logical, dimension(:), allocatable:: done + logical include_depth_below + real T0, S0, gamma, rho_0, salt, temp, dist, dens, theta + integer, dimension(:), pointer:: density_nodes + integer ele, i, node, n_sediment_fields, f + + ewrite(1,*) 'In calculate_perturbation_density' + + u => extract_vector_field(state, "Velocity") + + call zero(density) + + option_path='/material_phase::'//trim(state%name)//'/equation_of_state/fluids' + + call get_option(trim(u%option_path)//'/prognostic/temporal_discretisation/relaxation', & + theta, default = 1.0) + + rho_0 = 0.0 + + if (have_option(trim(option_path)//'/linear')) then + + option_path=trim(option_path)//'/linear' + + if (have_option(trim(option_path)//'/temperature_dependency')) then + dep_option_path=trim(option_path)//'/temperature_dependency' + call get_option(trim(dep_option_path)//'/reference_temperature', T0) + call get_option(trim(dep_option_path)//'/thermal_expansion_coefficient', gamma) + T => extract_scalar_field(state, "Temperature") + oldT => extract_scalar_field(state, "OldTemperature") + call allocate(deltaT, density%mesh, "DeltaT") + call allocate(remapT, density%mesh, "RemapT") + + ! deltaT=theta*T+(1-theta)*oldT-T0 + call remap_field(T, remapT) + call set(deltaT, remapT) + call scale(deltaT, theta) + + call remap_field(oldT, remapT) + call addto(deltaT, remapT, 1.0-theta) + call addto(deltaT, -T0) + ! density=density-gamma*deltaT + call addto(density, deltaT, scale=-gamma) + call deallocate(deltaT) + call deallocate(remapT) + end if + + if (have_option(trim(option_path)//'/salinity_dependency')) then + dep_option_path=trim(option_path)//'/salinity_dependency' + call get_option(trim(dep_option_path)//'/reference_salinity', S0) + call get_option(trim(dep_option_path)//'/saline_contraction_coefficient', gamma) + S => extract_scalar_field(state, "Salinity") + oldS => extract_scalar_field(state, "OldSalinity") + call allocate(deltaS, density%mesh, "DeltaS") + call allocate(remapS, density%mesh, "RemapS") + + ! deltaS=theta*S+(1-theta)*oldS-S0 + call remap_field(S, remapS) + call set(deltaS, remapS) + call scale(deltaS, theta) + + call remap_field(oldS, remapS) + call addto(deltaS, remapS, 1.0-theta) + call addto(deltaS, -S0) + ! density=density+gamma*deltaS + call addto(density, deltaS, scale=gamma) + call deallocate(deltaS) + call deallocate(remapS) + end if + + if (have_option(trim(option_path)//'/generic_scalar_field_dependency')) then + do f = 1, option_count(trim(option_path)//'/generic_scalar_field_dependency') + dep_option_path=trim(option_path)//'/generic_scalar_field_dependency['//int2str(f-1)//']' + call get_option(trim(dep_option_path)//'/name', sfield_name) + call get_option(trim(dep_option_path)//'/reference_value', T0) + call get_option(trim(dep_option_path)//'/expansion_coefficient', gamma) + T => extract_scalar_field(state, trim(sfield_name)) + oldT => extract_scalar_field(state, "Old"//trim(sfield_name)) + call allocate(deltaT, density%mesh, "DeltaT") + call allocate(remapT, density%mesh, "RemapT") + + ! deltaT=theta*T+(1-theta)*oldT-T0 + call remap_field(T, remapT) + call set(deltaT, remapT) + call scale(deltaT, theta) + + call remap_field(oldT, remapT) + call addto(deltaT, remapT, 1.0-theta) + call addto(deltaT, -T0) + ! density=density-gamma*deltaT + call addto(density, deltaT, scale=-gamma) + call deallocate(deltaT) + call deallocate(remapT) + end do + end if + + call get_option(trim(option_path)//'/reference_density', rho_0) + call scale(density, rho_0) + + elseif (have_option(trim(option_path)//'/ocean_pade_approximation')) then + + option_path=trim(option_path)//'/ocean_pade_approximation' + + include_depth_below=have_option(trim(option_path)//'/include_depth_below_surface') + + T => extract_scalar_field(state, "Temperature") + oldT => extract_scalar_field(state, "OldTemperature") + S => extract_scalar_field(state, "Salinity") + oldS => extract_scalar_field(state, "OldSalinity") + if (include_depth_below) then + topdis => extract_scalar_field(state, "DistanceToTop") + endif + + allocate( done(1:node_count(density)) ) + done=.false. + + do ele=1, element_count(density) + + density_nodes => ele_nodes(density, ele) + + do i=1,size(density_nodes) + node=density_nodes(i) + ! In the continuous case ensure we only do each calculation once. + if (done(node)) cycle + done(node)=.true. + + salt=theta*node_val(S, node)+(1-theta)*node_val(oldS, node) + temp=node_val(T, node)+(1-theta)*node_val(oldT, node) + if (include_depth_below) then + dist=node_val(topdis, node) + else + dist=0.0 + end if + + call mcD_J_W_F2002(dens,temp,salt,dist) + call addto(density, node, dens) + end do + + end do + + ! reference density is assumed 1 for the pade approximation + rho_0=1.0 - do i=1,n_sediment_fields - - call get_sediment_item(state, i, S) + end if + + if (have_option('/material_phase::'//trim(state%name)//'/sediment'))& + & then + + call allocate(deltaS, density%mesh, "DeltaS") + call allocate(remapS, density%mesh, "RemapS") + call allocate(sedimentdensity, density%mesh, "SedimentDensity") + call zero(sedimentdensity) + + n_sediment_fields = get_n_sediment_fields() - call get_sediment_item(state, i, 'submerged_specific_gravity', gamma) + do i=1,n_sediment_fields - gamma = gamma * rho_0 + call get_sediment_item(state, i, S) - oldS => extract_scalar_field(state, & + call get_sediment_item(state, i, 'submerged_specific_gravity', gamma) + + gamma = gamma * rho_0 + + oldS => extract_scalar_field(state, & "Old"//trim(S%name)) - ! deltaS=theta*S+(1-theta)*oldS-S0 - call remap_field(S, remapS) - call set(deltaS, remapS) - call scale(deltaS, theta) + ! deltaS=theta*S+(1-theta)*oldS-S0 + call remap_field(S, remapS) + call set(deltaS, remapS) + call scale(deltaS, theta) - call remap_field(oldS, remapS) - call addto(deltaS, remapS, 1.0-theta) - ! density=density+gamma*deltaS - call addto(sedimentdensity, deltaS, scale=gamma) + call remap_field(oldS, remapS) + call addto(deltaS, remapS, 1.0-theta) + ! density=density+gamma*deltaS + call addto(sedimentdensity, deltaS, scale=gamma) - end do + end do - call addto(density,sedimentdensity) + call addto(density,sedimentdensity) - call deallocate(deltaS) - call deallocate(remapS) - call deallocate(sedimentdensity) + call deallocate(deltaS) + call deallocate(remapS) + call deallocate(sedimentdensity) - end if + end if - if(present(reference_density)) then - reference_density = rho_0 - end if + if(present(reference_density)) then + reference_density = rho_0 + end if - end subroutine calculate_perturbation_density + end subroutine calculate_perturbation_density - subroutine mcD_J_W_F2002(density,T,Salinity,distance_to_top) - !!< function to evaluate density from the 2002 McDougall, Jackett, - !!< Wright and Feistel equation of state using Pade approximation. - real, intent(out) :: density - real, intent(in) :: T,Salinity,distance_to_top + subroutine mcD_J_W_F2002(density,T,Salinity,distance_to_top) + !!< function to evaluate density from the 2002 McDougall, Jackett, + !!< Wright and Feistel equation of state using Pade approximation. + real, intent(out) :: density + real, intent(in) :: T,Salinity,distance_to_top - real :: p,p1,p2,S + real :: p,p1,p2,S - ! Salinity can be negitive because it's numerically diffused, - ! some regions may be initialised with zero salinity, and - ! therefore undershoot may occur. - S = max(Salinity, 0.0) + ! Salinity can be negitive because it's numerically diffused, + ! some regions may be initialised with zero salinity, and + ! therefore undershoot may occur. + S = max(Salinity, 0.0) - ! calculate pressure in decibars from hydrostatic pressure - ! using reference density 1000 kg m^-2 + ! calculate pressure in decibars from hydrostatic pressure + ! using reference density 1000 kg m^-2 - p = 9.81*1000.0*distance_to_top*1.0e-4 + p = 9.81*1000.0*distance_to_top*1.0e-4 - ! evaluate top and bottom of Pade approximant + ! evaluate top and bottom of Pade approximant - p1 = 9.99843699e2 & + p1 = 9.99843699e2 & + 7.35212840*T - 5.45928211e-2*(T**2) + 3.98476704e-4*(T**3) & + 2.96938239*S - 7.23268813e-3*S*T + 2.12382341e-3*(S**2) & + 1.04004591e-2*p + 1.03970529e-7*p*(T**2) & + 5.18761880e-6*p*S - 3.24041825e-8*(p**2) & - 1.23869360e-11*(p**2)*(t**2) - p2 = 1.0 & + p2 = 1.0 & + 7.28606739e-3*T - 4.60835542e-5*(T**2) + 3.68390573e-7*(T**3) & + 1.80809186e-10*(T**4) & + 2.14691708e-3*S - 9.27062484e-6*S*T - 1.78343643e-10*S*(T**3) & @@ -283,507 +283,507 @@ subroutine mcD_J_W_F2002(density,T,Salinity,distance_to_top) + 5.30848875e-6*p -3.03175128e-16*(p**2)*(t**3) & - 1.27934137e-17*(p**3)*T - ! calculate the resulting density + ! calculate the resulting density - density = p1/p2 + density = p1/p2 - ! the perturbation density + ! the perturbation density - density = (density-1000.0)/1000.0 + density = (density-1000.0)/1000.0 - end subroutine mcD_J_W_F2002 + end subroutine mcD_J_W_F2002 - subroutine compressible_eos(state, density, pressure, drhodp) + subroutine compressible_eos(state, density, pressure, drhodp) - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout), optional :: density, pressure, drhodp + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout), optional :: density, pressure, drhodp - character(len=OPTION_PATH_LEN) :: eos_path - type(scalar_field) :: drhodp_local + character(len=OPTION_PATH_LEN) :: eos_path + type(scalar_field) :: drhodp_local - ewrite(1,*) 'Entering compressible_eos' + ewrite(1,*) 'Entering compressible_eos' - if (present(drhodp)) then - drhodp_local=drhodp - if (present(density)) then - assert(drhodp%mesh==density%mesh) - end if - if (present(pressure)) then - assert(drhodp%mesh==pressure%mesh) + if (present(drhodp)) then + drhodp_local=drhodp + if (present(density)) then + assert(drhodp%mesh==density%mesh) + end if + if (present(pressure)) then + assert(drhodp%mesh==pressure%mesh) + end if + else if (present(density)) then + call allocate(drhodp_local, density%mesh, 'Localdrhop') + else if (present(pressure)) then + call allocate(drhodp_local, pressure%mesh, 'Localdrhop') + else + FLAbort("No point in being in here if you don't want anything out.") end if - else if (present(density)) then - call allocate(drhodp_local, density%mesh, 'Localdrhop') - else if (present(pressure)) then - call allocate(drhodp_local, pressure%mesh, 'Localdrhop') - else - FLAbort("No point in being in here if you don't want anything out.") - end if - eos_path = trim(state%option_path)//'/equation_of_state' + eos_path = trim(state%option_path)//'/equation_of_state' + + if(have_option(trim(eos_path)//'/compressible')) then + + ! each of the following compressible_eos_XXX() routines should always calculate drhodp + ! (zero if density does not depend on pressure) and calculate density and + ! pressure if present - if(have_option(trim(eos_path)//'/compressible')) then + if(have_option(trim(eos_path)//'/compressible/stiffened_gas')) then - ! each of the following compressible_eos_XXX() routines should always calculate drhodp - ! (zero if density does not depend on pressure) and calculate density and - ! pressure if present + ! standard stiffened gas eos - if(have_option(trim(eos_path)//'/compressible/stiffened_gas')) then + call compressible_eos_stiffened_gas(state, eos_path, drhodp_local, & + density=density, pressure=pressure) - ! standard stiffened gas eos + else if(have_option(trim(eos_path)//'/compressible/giraldo')) then - call compressible_eos_stiffened_gas(state, eos_path, drhodp_local, & - density=density, pressure=pressure) + ! Eq. of state commonly used in atmospheric applications. See + ! Giraldo et. al., J. Comp. Phys., vol. 227 (2008), 3849-3877. + ! density= P_0/(R*T)*(P/P_0)^((R+c_v)/c_p) - else if(have_option(trim(eos_path)//'/compressible/giraldo')) then + call compressible_eos_giraldo(state, eos_path, drhodp_local, & + density=density, pressure=pressure) - ! Eq. of state commonly used in atmospheric applications. See - ! Giraldo et. al., J. Comp. Phys., vol. 227 (2008), 3849-3877. - ! density= P_0/(R*T)*(P/P_0)^((R+c_v)/c_p) - call compressible_eos_giraldo(state, eos_path, drhodp_local, & - density=density, pressure=pressure) + elseif(have_option(trim(eos_path)//'/compressible/foam')) then + ! eos used in foam modelling - elseif(have_option(trim(eos_path)//'/compressible/foam')) then + call compressible_eos_foam(state, eos_path, drhodp_local, & + density=density, pressure=pressure) - ! eos used in foam modelling + end if - call compressible_eos_foam(state, eos_path, drhodp_local, & - density=density, pressure=pressure) + else + + ! I presume we dont' actually want to be here + FLAbort('Gone into compressible_eos without having equation_of_state/compressible') end if - else - - ! I presume we dont' actually want to be here - FLAbort('Gone into compressible_eos without having equation_of_state/compressible') - - end if - - if(present(density)) then - ewrite_minmax(density) - end if - - if(present(pressure)) then - ewrite_minmax(pressure) - end if - - if(present(drhodp)) then - ewrite_minmax(drhodp) - else - call deallocate(drhodp_local) - end if - - end subroutine compressible_eos - - subroutine compressible_eos_stiffened_gas(state, eos_path, drhodp, & - density, pressure) - ! Standard stiffened gas equation - type(state_type), intent(inout) :: state - character(len=*), intent(in):: eos_path - type(scalar_field), intent(inout) :: drhodp - type(scalar_field), intent(inout), optional :: density, pressure - - !locals - integer :: stat, gstat, cstat - type(scalar_field), pointer :: pressure_local, energy_local, density_local - real :: reference_density, ratio_specific_heats - real :: bulk_sound_speed_squared, atmospheric_pressure - type(scalar_field) :: energy_remap, pressure_remap, density_remap - logical :: incompressible - - call get_option(trim(eos_path)//'/compressible/stiffened_gas/reference_density', & - reference_density, default=0.0) - - call get_option(trim(eos_path)//'/compressible/stiffened_gas/ratio_specific_heats', & - ratio_specific_heats, stat=gstat) - if(gstat/=0) then - ratio_specific_heats=1.0 - end if - - call get_option(trim(eos_path)//'/compressible/stiffened_gas/bulk_sound_speed_squared', & - bulk_sound_speed_squared, stat=cstat) - if(cstat/=0) then - bulk_sound_speed_squared=0.0 - end if - - incompressible = ((gstat/=0).and.(cstat/=0)) - if(incompressible) then - ewrite(0,*) "Selected compressible eos but not specified a bulk_sound_speed_squared or a ratio_specific_heats." - end if - - call zero(drhodp) - - if(.not.incompressible) then - energy_local=>extract_scalar_field(state,'InternalEnergy',stat=stat) - ! drhodp = 1.0/( bulk_sound_speed_squared + (ratio_specific_heats - 1.0)*energy ) - if((stat==0).and.(gstat==0)) then ! we have an internal energy field and we want to use it - call allocate(energy_remap, drhodp%mesh, 'RemappedInternalEnergy') - call remap_field(energy_local, energy_remap) - - call addto(drhodp, energy_remap, (ratio_specific_heats-1.0)) - - call deallocate(energy_remap) + if(present(density)) then + ewrite_minmax(density) end if - call addto(drhodp, bulk_sound_speed_squared) - call invert(drhodp) - end if - - if(present(density)) then - ! calculate the density - ! density may equal density in state depending on how this - ! subroutine is called - if(incompressible) then - ! density = reference_density - call set(density, reference_density) - else - pressure_local=>extract_scalar_field(state,'Pressure',stat=stat) - if (stat==0) then - assert(density%mesh==drhodp%mesh) - - ! density = drhodp*(pressure_local + atmospheric_pressure - ! + bulk_sound_speed_squared*reference_density) - call get_option(trim(pressure_local%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) - - call allocate(pressure_remap, drhodp%mesh, "RemappedPressure") - call remap_field(pressure_local, pressure_remap) - - call set(density, reference_density*bulk_sound_speed_squared + atmospheric_pressure) - call addto(density, pressure_remap) - call scale(density, drhodp) - - call deallocate(pressure_remap) - else - FLExit('No Pressure in material_phase::'//trim(state%name)) - end if + + if(present(pressure)) then + ewrite_minmax(pressure) end if - end if - if(present(pressure)) then - if(incompressible) then - ! pressure is unrelated to density in this case - call zero(pressure) + if(present(drhodp)) then + ewrite_minmax(drhodp) else - ! calculate the pressure using the eos and the calculated (probably prognostic) - ! density - density_local=>extract_scalar_field(state,'Density',stat=stat) - if (stat==0) then - assert(pressure%mesh==drhodp%mesh) - - ! pressure = density_local/drhodp & - ! - bulk_sound_speed_squared*reference_density - - call allocate(density_remap, drhodp%mesh, "RemappedDensity") - call remap_field(density_local, density_remap) - - call set(pressure, drhodp) - call invert(pressure) - call scale(pressure, density_remap) - call addto(pressure, -bulk_sound_speed_squared*reference_density) - - call deallocate(density_remap) - else - FLExit('No Density in material_phase::'//trim(state%name)) - end if + call deallocate(drhodp_local) end if - end if - - end subroutine compressible_eos_stiffened_gas - - subroutine compressible_eos_giraldo(state, eos_path, drhodp, & - density, pressure) - ! Eq. of state commonly used in atmospheric applications. See - ! Giraldo et. al., J. Comp. Phys., vol. 227 (2008), 3849-3877. - ! density= P_0/(R*T)*(P/P_0)^((R+c_v)/c_p) - type(state_type), intent(inout) :: state - character(len=*), intent(in):: eos_path - type(scalar_field), intent(inout) :: drhodp - type(scalar_field), intent(inout), optional :: density, pressure - - ! locals - integer :: stat, gstat, cstat, pstat, tstat - type(scalar_field), pointer :: pressure_local, density_local, temperature_local - real :: reference_density, p_0, c_p, c_v - real :: drhodp_node, power - real :: R - type(scalar_field) :: pressure_remap, density_remap, temperature_remap - logical :: incompressible - integer :: node - - call get_option(trim(eos_path)//'/compressible/giraldo/reference_pressure', & - p_0, default=1.0e5) - - call get_option(trim(eos_path)//'/compressible/giraldo/C_P', & - c_p, stat=gstat) - if(gstat/=0) then - c_p=1.0 - end if - - call get_option(trim(eos_path)//'/compressible/giraldo/C_V', & - c_v, stat=cstat) - if(cstat/=0) then - c_v=1.0 - end if - - R=c_p-c_v - - incompressible = ((gstat/=0).or.(cstat/=0)) - if(incompressible) then - ewrite(0,*) "Selected compressible eos but not specified either C_P or C_V." - end if - - call zero(drhodp) - - if(.not.incompressible) then - pressure_local=>extract_scalar_field(state,'Pressure',stat=pstat) - temperature_local=>extract_scalar_field(state,'Temperature',stat=tstat) - if ((pstat==0).and.(tstat==0)) then - ! drhodp = ((R+c_v)/c_p)*1.0/( R*T) * (P/P_0)^((R+c_v-c_p)/c_p) - call allocate(pressure_remap, drhodp%mesh, 'RemappedPressure') - call remap_field(pressure_local, pressure_remap) - call allocate(temperature_remap, drhodp%mesh, 'RemappedTemperature') - call remap_field(temperature_local, temperature_remap) - - power=(R+c_v-c_p)/c_p - do node=1,node_count(drhodp) - drhodp_node=((c_v+R)/c_p)*1.0/(R*node_val(temperature_remap,node))*(node_val(pressure_remap,node)/p_0)**(power) - call set(drhodp, node, drhodp_node) - end do - - call deallocate(temperature_remap) - else - FLExit('No Pressure or temperature in material_phase::'//trim(state%name)) - endif - end if - - if(present(density)) then - ! calculate the density - ! density may equal density in state depending on how this - ! subroutine is called + + end subroutine compressible_eos + + subroutine compressible_eos_stiffened_gas(state, eos_path, drhodp, & + density, pressure) + ! Standard stiffened gas equation + type(state_type), intent(inout) :: state + character(len=*), intent(in):: eos_path + type(scalar_field), intent(inout) :: drhodp + type(scalar_field), intent(inout), optional :: density, pressure + + !locals + integer :: stat, gstat, cstat + type(scalar_field), pointer :: pressure_local, energy_local, density_local + real :: reference_density, ratio_specific_heats + real :: bulk_sound_speed_squared, atmospheric_pressure + type(scalar_field) :: energy_remap, pressure_remap, density_remap + logical :: incompressible + + call get_option(trim(eos_path)//'/compressible/stiffened_gas/reference_density', & + reference_density, default=0.0) + + call get_option(trim(eos_path)//'/compressible/stiffened_gas/ratio_specific_heats', & + ratio_specific_heats, stat=gstat) + if(gstat/=0) then + ratio_specific_heats=1.0 + end if + + call get_option(trim(eos_path)//'/compressible/stiffened_gas/bulk_sound_speed_squared', & + bulk_sound_speed_squared, stat=cstat) + if(cstat/=0) then + bulk_sound_speed_squared=0.0 + end if + + incompressible = ((gstat/=0).and.(cstat/=0)) if(incompressible) then - ! density = reference_density - call set(density, reference_density) - else - assert(density%mesh==drhodp%mesh) - call set(density, pressure_remap) - call scale(density, drhodp) - call scale(density, 1.0/(1.0+power)) + ewrite(0,*) "Selected compressible eos but not specified a bulk_sound_speed_squared or a ratio_specific_heats." + end if + + call zero(drhodp) + + if(.not.incompressible) then + energy_local=>extract_scalar_field(state,'InternalEnergy',stat=stat) + ! drhodp = 1.0/( bulk_sound_speed_squared + (ratio_specific_heats - 1.0)*energy ) + if((stat==0).and.(gstat==0)) then ! we have an internal energy field and we want to use it + call allocate(energy_remap, drhodp%mesh, 'RemappedInternalEnergy') + call remap_field(energy_local, energy_remap) + + call addto(drhodp, energy_remap, (ratio_specific_heats-1.0)) + + call deallocate(energy_remap) + end if + call addto(drhodp, bulk_sound_speed_squared) + call invert(drhodp) + end if - call deallocate(pressure_remap) + if(present(density)) then + ! calculate the density + ! density may equal density in state depending on how this + ! subroutine is called + if(incompressible) then + ! density = reference_density + call set(density, reference_density) + else + pressure_local=>extract_scalar_field(state,'Pressure',stat=stat) + if (stat==0) then + assert(density%mesh==drhodp%mesh) + + ! density = drhodp*(pressure_local + atmospheric_pressure + ! + bulk_sound_speed_squared*reference_density) + call get_option(trim(pressure_local%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + + call allocate(pressure_remap, drhodp%mesh, "RemappedPressure") + call remap_field(pressure_local, pressure_remap) + + call set(density, reference_density*bulk_sound_speed_squared + atmospheric_pressure) + call addto(density, pressure_remap) + call scale(density, drhodp) + + call deallocate(pressure_remap) + else + FLExit('No Pressure in material_phase::'//trim(state%name)) + end if + end if end if - end if - if(present(pressure)) then + if(present(pressure)) then + if(incompressible) then + ! pressure is unrelated to density in this case + call zero(pressure) + else + ! calculate the pressure using the eos and the calculated (probably prognostic) + ! density + density_local=>extract_scalar_field(state,'Density',stat=stat) + if (stat==0) then + assert(pressure%mesh==drhodp%mesh) + + ! pressure = density_local/drhodp & + ! - bulk_sound_speed_squared*reference_density + + call allocate(density_remap, drhodp%mesh, "RemappedDensity") + call remap_field(density_local, density_remap) + + call set(pressure, drhodp) + call invert(pressure) + call scale(pressure, density_remap) + call addto(pressure, -bulk_sound_speed_squared*reference_density) + + call deallocate(density_remap) + else + FLExit('No Density in material_phase::'//trim(state%name)) + end if + end if + end if + + end subroutine compressible_eos_stiffened_gas + + subroutine compressible_eos_giraldo(state, eos_path, drhodp, & + density, pressure) + ! Eq. of state commonly used in atmospheric applications. See + ! Giraldo et. al., J. Comp. Phys., vol. 227 (2008), 3849-3877. + ! density= P_0/(R*T)*(P/P_0)^((R+c_v)/c_p) + type(state_type), intent(inout) :: state + character(len=*), intent(in):: eos_path + type(scalar_field), intent(inout) :: drhodp + type(scalar_field), intent(inout), optional :: density, pressure + + ! locals + integer :: stat, gstat, cstat, pstat, tstat + type(scalar_field), pointer :: pressure_local, density_local, temperature_local + real :: reference_density, p_0, c_p, c_v + real :: drhodp_node, power + real :: R + type(scalar_field) :: pressure_remap, density_remap, temperature_remap + logical :: incompressible + integer :: node + + call get_option(trim(eos_path)//'/compressible/giraldo/reference_pressure', & + p_0, default=1.0e5) + + call get_option(trim(eos_path)//'/compressible/giraldo/C_P', & + c_p, stat=gstat) + if(gstat/=0) then + c_p=1.0 + end if + + call get_option(trim(eos_path)//'/compressible/giraldo/C_V', & + c_v, stat=cstat) + if(cstat/=0) then + c_v=1.0 + end if + + R=c_p-c_v + + incompressible = ((gstat/=0).or.(cstat/=0)) if(incompressible) then - ! pressure is unrelated to density in this case - call zero(pressure) - else - ! calculate the pressure using the eos and the calculated (probably prognostic) - ! density - density_local=>extract_scalar_field(state,'Density',stat=stat) - if (stat==0) then - assert(pressure%mesh==drhodp%mesh) - - ! pressure = density_local/drhodp - - call allocate(density_remap, drhodp%mesh, "RemappedDensity") - call remap_field(density_local, density_remap) - - call set(pressure, drhodp) - call invert(pressure) - call scale(pressure, density_remap) - call scale(pressure, (1.0+power)) - - call deallocate(density_remap) - else - FLExit('No Density in material_phase::'//trim(state%name)) - end if + ewrite(0,*) "Selected compressible eos but not specified either C_P or C_V." end if - end if - end subroutine compressible_eos_giraldo + call zero(drhodp) + + if(.not.incompressible) then + pressure_local=>extract_scalar_field(state,'Pressure',stat=pstat) + temperature_local=>extract_scalar_field(state,'Temperature',stat=tstat) + if ((pstat==0).and.(tstat==0)) then + ! drhodp = ((R+c_v)/c_p)*1.0/( R*T) * (P/P_0)^((R+c_v-c_p)/c_p) + call allocate(pressure_remap, drhodp%mesh, 'RemappedPressure') + call remap_field(pressure_local, pressure_remap) + call allocate(temperature_remap, drhodp%mesh, 'RemappedTemperature') + call remap_field(temperature_local, temperature_remap) + + power=(R+c_v-c_p)/c_p + do node=1,node_count(drhodp) + drhodp_node=((c_v+R)/c_p)*1.0/(R*node_val(temperature_remap,node))*(node_val(pressure_remap,node)/p_0)**(power) + call set(drhodp, node, drhodp_node) + end do + + call deallocate(temperature_remap) + else + FLExit('No Pressure or temperature in material_phase::'//trim(state%name)) + endif + end if - subroutine compressible_eos_foam(state, eos_path, drhodp, & - density, pressure) - ! Foam EoS Used with compressible simulations of liquid drainage in foams. - ! It describes the liquid content in the foam as the product of the Plateau - ! border cross sectional area and the local Plateau border length per unit volume (lambda). - type(state_type), intent(inout) :: state - character(len=*), intent(in):: eos_path - type(scalar_field), intent(inout) :: drhodp - type(scalar_field), intent(inout), optional :: density, pressure + if(present(density)) then + ! calculate the density + ! density may equal density in state depending on how this + ! subroutine is called + if(incompressible) then + ! density = reference_density + call set(density, reference_density) + else + assert(density%mesh==drhodp%mesh) + call set(density, pressure_remap) + call scale(density, drhodp) + call scale(density, 1.0/(1.0+power)) + + call deallocate(pressure_remap) + end if + end if - ! locals - integer :: pstat, dstat - type(scalar_field), pointer :: pressure_local, density_local, drainagelambda_local - real :: atmospheric_pressure - type(scalar_field) :: pressure_remap, density_remap, drainagelambda_remap + if(present(pressure)) then + if(incompressible) then + ! pressure is unrelated to density in this case + call zero(pressure) + else + ! calculate the pressure using the eos and the calculated (probably prognostic) + ! density + density_local=>extract_scalar_field(state,'Density',stat=stat) + if (stat==0) then + assert(pressure%mesh==drhodp%mesh) + + ! pressure = density_local/drhodp + + call allocate(density_remap, drhodp%mesh, "RemappedDensity") + call remap_field(density_local, density_remap) + + call set(pressure, drhodp) + call invert(pressure) + call scale(pressure, density_remap) + call scale(pressure, (1.0+power)) + + call deallocate(density_remap) + else + FLExit('No Density in material_phase::'//trim(state%name)) + end if + end if + end if - call zero(drhodp) + end subroutine compressible_eos_giraldo - pressure_local => extract_scalar_field(state,'Pressure', stat=pstat) + subroutine compressible_eos_foam(state, eos_path, drhodp, & + density, pressure) + ! Foam EoS Used with compressible simulations of liquid drainage in foams. + ! It describes the liquid content in the foam as the product of the Plateau + ! border cross sectional area and the local Plateau border length per unit volume (lambda). + type(state_type), intent(inout) :: state + character(len=*), intent(in):: eos_path + type(scalar_field), intent(inout) :: drhodp + type(scalar_field), intent(inout), optional :: density, pressure - drainagelambda_local => extract_scalar_field(state,'DrainageLambda') + ! locals + integer :: pstat, dstat + type(scalar_field), pointer :: pressure_local, density_local, drainagelambda_local + real :: atmospheric_pressure + type(scalar_field) :: pressure_remap, density_remap, drainagelambda_remap - call allocate(drainagelambda_remap, drhodp%mesh, 'RemappedDrainageLambda') - call remap_field(drainagelambda_local, drainagelambda_remap) + call zero(drhodp) - call addto(drhodp, drainagelambda_remap) + pressure_local => extract_scalar_field(state,'Pressure', stat=pstat) - call deallocate(drainagelambda_remap) + drainagelambda_local => extract_scalar_field(state,'DrainageLambda') - if(present(density)) then - if (pstat==0) then - assert(density%mesh==drhodp%mesh) + call allocate(drainagelambda_remap, drhodp%mesh, 'RemappedDrainageLambda') + call remap_field(drainagelambda_local, drainagelambda_remap) - call get_option(trim(pressure_local%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) + call addto(drhodp, drainagelambda_remap) - call allocate(pressure_remap, drhodp%mesh, "RemappedPressure") - call remap_field(pressure_local, pressure_remap) + call deallocate(drainagelambda_remap) - call set(density, atmospheric_pressure) - call addto(density, pressure_remap) - call scale(density, drhodp) + if(present(density)) then + if (pstat==0) then + assert(density%mesh==drhodp%mesh) - call deallocate(pressure_remap) - else - FLExit('No Pressure in material_phase::'//trim(state%name)) + call get_option(trim(pressure_local%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + + call allocate(pressure_remap, drhodp%mesh, "RemappedPressure") + call remap_field(pressure_local, pressure_remap) + + call set(density, atmospheric_pressure) + call addto(density, pressure_remap) + call scale(density, drhodp) + + call deallocate(pressure_remap) + else + FLExit('No Pressure in material_phase::'//trim(state%name)) + end if + end if + + if(present(pressure)) then + density_local=>extract_scalar_field(state,'Density',stat=dstat) + if (dstat==0) then + assert(pressure%mesh==drhodp%mesh) + + call get_option(trim(pressure_local%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + + call allocate(density_remap, drhodp%mesh, "RemappedDensity") + call remap_field(density_local, density_remap) + + call set(pressure, drhodp) + call invert(pressure) + call scale(pressure, density_remap) + + call deallocate(density_remap) + else + FLExit('No Density in material_phase::'//trim(state%name)) + end if end if - end if - if(present(pressure)) then - density_local=>extract_scalar_field(state,'Density',stat=dstat) - if (dstat==0) then - assert(pressure%mesh==drhodp%mesh) + end subroutine compressible_eos_foam + + subroutine compressible_material_eos(state,materialdensity,& + materialpressure,materialdrhodp) - call get_option(trim(pressure_local%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout), optional :: materialdensity, & + materialpressure, materialdrhodp - call allocate(density_remap, drhodp%mesh, "RemappedDensity") - call remap_field(density_local, density_remap) + !locals + integer :: stat, gstat, cstat + type(scalar_field), pointer :: pressure, materialenergy, materialdensity_local + character(len=4000) :: thismaterial_phase, eos_path + real :: reference_density, ratio_specific_heats + real :: bulk_sound_speed_squared, atmospheric_pressure + type(scalar_field) :: drhodp - call set(pressure, drhodp) - call invert(pressure) - call scale(pressure, density_remap) + ewrite(1,*) 'Entering compressible_material_eos' - call deallocate(density_remap) + if (present(materialdensity)) then + call allocate(drhodp, materialdensity%mesh, 'Gradient of density wrt pressure') + else if (present(materialpressure)) then + call allocate(drhodp, materialpressure%mesh, 'Gradient of density wrt pressure') + else if (present(materialdrhodp)) then + call allocate(drhodp, materialdrhodp%mesh, 'Gradient of density wrt pressure') else - FLExit('No Density in material_phase::'//trim(state%name)) + FLAbort("No point in being in here if you don't want anything out.") end if - end if - - end subroutine compressible_eos_foam - - subroutine compressible_material_eos(state,materialdensity,& - materialpressure,materialdrhodp) - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout), optional :: materialdensity, & - materialpressure, materialdrhodp - - !locals - integer :: stat, gstat, cstat - type(scalar_field), pointer :: pressure, materialenergy, materialdensity_local - character(len=4000) :: thismaterial_phase, eos_path - real :: reference_density, ratio_specific_heats - real :: bulk_sound_speed_squared, atmospheric_pressure - type(scalar_field) :: drhodp - - ewrite(1,*) 'Entering compressible_material_eos' - - if (present(materialdensity)) then - call allocate(drhodp, materialdensity%mesh, 'Gradient of density wrt pressure') - else if (present(materialpressure)) then - call allocate(drhodp, materialpressure%mesh, 'Gradient of density wrt pressure') - else if (present(materialdrhodp)) then - call allocate(drhodp, materialdrhodp%mesh, 'Gradient of density wrt pressure') - else - FLAbort("No point in being in here if you don't want anything out.") - end if - - thismaterial_phase = '/material_phase::'//trim(state%name) - eos_path = trim(thismaterial_phase)//'/equation_of_state' - - if(have_option(trim(eos_path)//'/compressible')) then - - if(have_option(trim(eos_path)//'/compressible/stiffened_gas')) then - call get_option(trim(eos_path)//'/compressible/stiffened_gas/reference_density', & - reference_density, default=0.0) - call get_option(trim(eos_path)//'/compressible/stiffened_gas/ratio_specific_heats', & - ratio_specific_heats, stat=gstat) - if(gstat/=0) then - ratio_specific_heats=1.0 - end if - call get_option(trim(eos_path)//'/compressible/stiffened_gas/bulk_sound_speed_squared', & - bulk_sound_speed_squared, stat = cstat) - if(cstat/=0) then - bulk_sound_speed_squared=0.0 - end if - if((gstat/=0).and.(cstat/=0)) then - FLExit("Must set either a bulk_sound_speed_squared or a ratio_specific_heats.") - end if - materialenergy=>extract_scalar_field(state,'MaterialInternalEnergy',stat=stat) - if(stat==0) then ! we have an internal energy field - drhodp%val = 1.0/( bulk_sound_speed_squared + (ratio_specific_heats - 1.0)*materialenergy%val ) - else ! we don't have an internal energy field - call set(drhodp, 1.0/bulk_sound_speed_squared) - end if - - if(present(materialdensity)) then - ! calculate the materialdensity - ! materialdensity can equal materialdensity in state depending on how this - ! subroutine is called - pressure=>extract_scalar_field(state,'Pressure',stat=stat) - if (stat==0) then - call get_option(trim(pressure%option_path)//'/prognostic/atmospheric_pressure', & - atmospheric_pressure, default=0.0) - materialdensity%val = drhodp%val*(pressure%val + atmospheric_pressure & - + bulk_sound_speed_squared*reference_density) - else - FLExit('No Pressure in material_phase::'//trim(state%name)) - end if - end if - - if(present(materialpressure)) then - ! calculate the materialpressure using the eos and the calculated (probably prognostic) - ! materialdensity - ! materialpressure /= bulk pressure - materialdensity_local=>extract_scalar_field(state,'MaterialDensity',stat=stat) - if (stat==0) then - materialpressure%val = materialdensity_local%val/drhodp%val & - - bulk_sound_speed_squared*reference_density - else - FLExit('No MaterialDensity in material_phase::'//trim(state%name)) - end if - end if + + thismaterial_phase = '/material_phase::'//trim(state%name) + eos_path = trim(thismaterial_phase)//'/equation_of_state' + + if(have_option(trim(eos_path)//'/compressible')) then + + if(have_option(trim(eos_path)//'/compressible/stiffened_gas')) then + call get_option(trim(eos_path)//'/compressible/stiffened_gas/reference_density', & + reference_density, default=0.0) + call get_option(trim(eos_path)//'/compressible/stiffened_gas/ratio_specific_heats', & + ratio_specific_heats, stat=gstat) + if(gstat/=0) then + ratio_specific_heats=1.0 + end if + call get_option(trim(eos_path)//'/compressible/stiffened_gas/bulk_sound_speed_squared', & + bulk_sound_speed_squared, stat = cstat) + if(cstat/=0) then + bulk_sound_speed_squared=0.0 + end if + if((gstat/=0).and.(cstat/=0)) then + FLExit("Must set either a bulk_sound_speed_squared or a ratio_specific_heats.") + end if + materialenergy=>extract_scalar_field(state,'MaterialInternalEnergy',stat=stat) + if(stat==0) then ! we have an internal energy field + drhodp%val = 1.0/( bulk_sound_speed_squared + (ratio_specific_heats - 1.0)*materialenergy%val ) + else ! we don't have an internal energy field + call set(drhodp, 1.0/bulk_sound_speed_squared) + end if + + if(present(materialdensity)) then + ! calculate the materialdensity + ! materialdensity can equal materialdensity in state depending on how this + ! subroutine is called + pressure=>extract_scalar_field(state,'Pressure',stat=stat) + if (stat==0) then + call get_option(trim(pressure%option_path)//'/prognostic/atmospheric_pressure', & + atmospheric_pressure, default=0.0) + materialdensity%val = drhodp%val*(pressure%val + atmospheric_pressure & + + bulk_sound_speed_squared*reference_density) + else + FLExit('No Pressure in material_phase::'//trim(state%name)) + end if + end if + + if(present(materialpressure)) then + ! calculate the materialpressure using the eos and the calculated (probably prognostic) + ! materialdensity + ! materialpressure /= bulk pressure + materialdensity_local=>extract_scalar_field(state,'MaterialDensity',stat=stat) + if (stat==0) then + materialpressure%val = materialdensity_local%val/drhodp%val & + - bulk_sound_speed_squared*reference_density + else + FLExit('No MaterialDensity in material_phase::'//trim(state%name)) + end if + end if ! else ! ! place other compressible material eos here - end if + end if ! else ! ! an incompressible option? - end if + end if - if(present(materialdensity)) then - ewrite_minmax(materialdensity) - end if + if(present(materialdensity)) then + ewrite_minmax(materialdensity) + end if - if(present(materialpressure)) then - ewrite_minmax(materialpressure) - end if + if(present(materialpressure)) then + ewrite_minmax(materialpressure) + end if - if(present(materialdrhodp)) then - materialdrhodp%val=drhodp%val - ewrite_minmax(materialdrhodp) - end if + if(present(materialdrhodp)) then + materialdrhodp%val=drhodp%val + ewrite_minmax(materialdrhodp) + end if - call deallocate(drhodp) + call deallocate(drhodp) - end subroutine compressible_material_eos + end subroutine compressible_material_eos end module equation_of_state diff --git a/parameterisation/Gls_vertical_turbulence_model.F90 b/parameterisation/Gls_vertical_turbulence_model.F90 index 365988b889..fd1d34bf3a 100644 --- a/parameterisation/Gls_vertical_turbulence_model.F90 +++ b/parameterisation/Gls_vertical_turbulence_model.F90 @@ -29,82 +29,82 @@ module gls - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use fldebug - use quadrature - use elements - use spud - use sparse_tools - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use sparse_matrices_fields - use fefields - use state_fields_module - use equation_of_state - use coordinates - use vertical_extrapolation_module - - implicit none - - private - - ! These variables are the parameters requried by GLS. - ! They are all private to prevent tampering - ! and save'd so that we don't need to call init every time some GLS-y - ! happens. These are *all* private - real, save :: gls_n, gls_m, gls_p - real, save :: sigma_psi, sigma_k, kappa - integer, save :: nNodes - type(scalar_field), save :: tke_old, ll - type(scalar_field), save :: local_tke ! our local copy of TKE. We amend this - !to add the values of the Dirichlet BC onto the field for calculating the - !diagnostic quantities and for output. See Warner et al 2005. - type(scalar_field), save :: MM2, NN2, eps, Fwall, S_H, S_M - type(scalar_field), save :: K_H, K_M, density, P, B - real, save :: eps_min = 1e-10, psi_min, k_min - real, save :: cm0, cde - ! the a_i's for the ASM - real, save :: a1,a2,a3,a4,a5 - real, save :: at1,at2,at3,at4,at5 - real, save :: cc1 - real, save :: ct1,ctt - real, save :: cc2,cc3,cc4,cc5,cc6 - real, save :: ct2,ct3,ct4,ct5 - real, save :: cPsi1,cPsi2,cPsi3_plus,cPsi3_minus - real, save :: relaxation - - - ! these are the fields and variables for the surface values - type(scalar_field), save :: top_surface_values, bottom_surface_values ! these are used to populate the bcs - type(scalar_field), save :: top_surface_tke_values, bottom_surface_tke_values ! for the Psi BC - type(scalar_field), save :: top_surface_km_values, bottom_surface_km_values ! for the Psi BC - integer, save :: NNodes_sur, NNodes_bot - integer, dimension(:), pointer, save :: bottom_surface_nodes, top_surface_nodes - integer, dimension(:), pointer, save :: top_surface_element_list, bottom_surface_element_list - logical, save :: calculate_bcs, calc_fwall - character(len=FIELD_NAME_LEN), save :: gls_wall_option, gls_stability_option, gls_option - - ! Switch for on sphere simulations to rotate the required tensors - logical, save :: on_sphere - - ! The following are the public subroutines - public :: gls_init, gls_cleanup, gls_tke, gls_diffusivity, gls_psi, gls_adapt_mesh, gls_check_options - - ! General plan is: - ! - Init in main/Fluids.F90 - ! - Populate_State and BoundaryConditionsFromOptions also contain some set up - ! routines such as looking for the GLS fields and setting up the automatic - ! boundary conditions - ! - If solve is about to do TKE, call gls_tke (which calculates NN, MM and set source/absorption for solve) - ! - If solve is about to do Psi, call gls_psi (which fixes TKE surfaces, set source/absorption for solve) - ! - After Psi solve, call gls_diffusivity, which sets the diffusivity and viscosity, via the lengthscale - ! - If we adapt, call gls_adapt, which deallocates and re-allocates the - ! fields on the new mesh. This also sets up the diagnostic fields again, - ! which aren't interpolated - ! - When done, clean-up + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use fldebug + use quadrature + use elements + use spud + use sparse_tools + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use sparse_matrices_fields + use fefields + use state_fields_module + use equation_of_state + use coordinates + use vertical_extrapolation_module + + implicit none + + private + + ! These variables are the parameters requried by GLS. + ! They are all private to prevent tampering + ! and save'd so that we don't need to call init every time some GLS-y + ! happens. These are *all* private + real, save :: gls_n, gls_m, gls_p + real, save :: sigma_psi, sigma_k, kappa + integer, save :: nNodes + type(scalar_field), save :: tke_old, ll + type(scalar_field), save :: local_tke ! our local copy of TKE. We amend this + !to add the values of the Dirichlet BC onto the field for calculating the + !diagnostic quantities and for output. See Warner et al 2005. + type(scalar_field), save :: MM2, NN2, eps, Fwall, S_H, S_M + type(scalar_field), save :: K_H, K_M, density, P, B + real, save :: eps_min = 1e-10, psi_min, k_min + real, save :: cm0, cde + ! the a_i's for the ASM + real, save :: a1,a2,a3,a4,a5 + real, save :: at1,at2,at3,at4,at5 + real, save :: cc1 + real, save :: ct1,ctt + real, save :: cc2,cc3,cc4,cc5,cc6 + real, save :: ct2,ct3,ct4,ct5 + real, save :: cPsi1,cPsi2,cPsi3_plus,cPsi3_minus + real, save :: relaxation + + + ! these are the fields and variables for the surface values + type(scalar_field), save :: top_surface_values, bottom_surface_values ! these are used to populate the bcs + type(scalar_field), save :: top_surface_tke_values, bottom_surface_tke_values ! for the Psi BC + type(scalar_field), save :: top_surface_km_values, bottom_surface_km_values ! for the Psi BC + integer, save :: NNodes_sur, NNodes_bot + integer, dimension(:), pointer, save :: bottom_surface_nodes, top_surface_nodes + integer, dimension(:), pointer, save :: top_surface_element_list, bottom_surface_element_list + logical, save :: calculate_bcs, calc_fwall + character(len=FIELD_NAME_LEN), save :: gls_wall_option, gls_stability_option, gls_option + + ! Switch for on sphere simulations to rotate the required tensors + logical, save :: on_sphere + + ! The following are the public subroutines + public :: gls_init, gls_cleanup, gls_tke, gls_diffusivity, gls_psi, gls_adapt_mesh, gls_check_options + + ! General plan is: + ! - Init in main/Fluids.F90 + ! - Populate_State and BoundaryConditionsFromOptions also contain some set up + ! routines such as looking for the GLS fields and setting up the automatic + ! boundary conditions + ! - If solve is about to do TKE, call gls_tke (which calculates NN, MM and set source/absorption for solve) + ! - If solve is about to do Psi, call gls_psi (which fixes TKE surfaces, set source/absorption for solve) + ! - After Psi solve, call gls_diffusivity, which sets the diffusivity and viscosity, via the lengthscale + ! - If we adapt, call gls_adapt, which deallocates and re-allocates the + ! fields on the new mesh. This also sets up the diagnostic fields again, + ! which aren't interpolated + ! - When done, clean-up contains @@ -114,131 +114,131 @@ module gls ! - initialise GLS parameters based on options ! - allocate space for optional fields, which are module level variables (to save passing them around) !---------- -subroutine gls_init(state) - - type(state_type), intent(inout) :: state - - real :: N,rad,rcm,cmsf - integer :: stat - type(scalar_field), pointer :: psi, tke - - psi => extract_scalar_field(state, "GLSGenericSecondQuantity") - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - - ! Allocate the temporary, module-level variables - call gls_allocate_temps(state) - - ! Check if we're on the sphere - on_sphere = have_option('/geometry/spherical_earth/') - - ! populate some useful variables from options - calculate_bcs = have_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/") - calc_fwall = .false. - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/minimum_value", k_min, stat) - - ! these lot are global - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/relax_diffusivity", relaxation, default=0.0) - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/stability_function", gls_stability_option) - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/option", gls_option) - ! there are lots of alternative formulae for this wall function, so let the - ! user choose! - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/wall_function")) then - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/wall_function",gls_wall_option) - else - gls_wall_option = "none" - end if - - ! Check the model used - we have four choices - then set the parameters appropriately - select case (gls_option) - case ("k-kl") ! Mellor-Yamada 2.5 - gls_p = 0.0 - gls_m = 1.0 - gls_n = 1.0 - sigma_k = 2.44 ! turbinent Schmidt number - sigma_psi = 2.44 ! turbulent Schmidt number - cPsi1 = 0.9 - cPsi2 = 0.5 - cPsi3_plus = 1.0 - ! c3 depends on which stability function has been choosen - select case (trim(gls_stability_option)) - case ("KanthaClayson-94") + subroutine gls_init(state) + + type(state_type), intent(inout) :: state + + real :: N,rad,rcm,cmsf + integer :: stat + type(scalar_field), pointer :: psi, tke + + psi => extract_scalar_field(state, "GLSGenericSecondQuantity") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + + ! Allocate the temporary, module-level variables + call gls_allocate_temps(state) + + ! Check if we're on the sphere + on_sphere = have_option('/geometry/spherical_earth/') + + ! populate some useful variables from options + calculate_bcs = have_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/") + calc_fwall = .false. + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/minimum_value", k_min, stat) + + ! these lot are global + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/relax_diffusivity", relaxation, default=0.0) + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/stability_function", gls_stability_option) + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/option", gls_option) + ! there are lots of alternative formulae for this wall function, so let the + ! user choose! + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/wall_function")) then + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/wall_function",gls_wall_option) + else + gls_wall_option = "none" + end if + + ! Check the model used - we have four choices - then set the parameters appropriately + select case (gls_option) + case ("k-kl") ! Mellor-Yamada 2.5 + gls_p = 0.0 + gls_m = 1.0 + gls_n = 1.0 + sigma_k = 2.44 ! turbinent Schmidt number + sigma_psi = 2.44 ! turbulent Schmidt number + cPsi1 = 0.9 + cPsi2 = 0.5 + cPsi3_plus = 1.0 + ! c3 depends on which stability function has been choosen + select case (trim(gls_stability_option)) + case ("KanthaClayson-94") cPsi3_minus = 2.53 - case ("Canuto-01-A") + case ("Canuto-01-A") cPsi3_minus = 2.681 - case ("Canuto-01-B") + case ("Canuto-01-B") FLExit("GLS - Stability function combination not supported") - case ("GibsonLaunder-78") + case ("GibsonLaunder-78") FLExit("GLS - Stability function combination not supported") - end select - psi_min = 1.e-8 - calc_fwall = .true. - case ("k-epsilon") - gls_p = 3.0 - gls_m = 1.5 - gls_n = -1.0 - sigma_k = 1.3 ! turbulent Schmidt number - sigma_psi = 1.0 ! turbulent Schmidt number - cPsi1 = 1.44 - cPsi2 = 1.92 - cPsi3_plus = 1.0 - select case (trim(gls_stability_option)) - case ("KanthaClayson-94") + end select + psi_min = 1.e-8 + calc_fwall = .true. + case ("k-epsilon") + gls_p = 3.0 + gls_m = 1.5 + gls_n = -1.0 + sigma_k = 1.3 ! turbulent Schmidt number + sigma_psi = 1.0 ! turbulent Schmidt number + cPsi1 = 1.44 + cPsi2 = 1.92 + cPsi3_plus = 1.0 + select case (trim(gls_stability_option)) + case ("KanthaClayson-94") cPsi3_minus = -0.41 - case ("Canuto-01-A") + case ("Canuto-01-A") cPsi3_minus = -0.63 - case ("Canuto-01-B") + case ("Canuto-01-B") cPsi3_minus = -0.57 - case ("GibsonLaunder-78") + case ("GibsonLaunder-78") cPsi3_minus = -0.3700 - end select - psi_min = 1.e-12 - case ("k-omega") - gls_p = -1.0 - gls_m = 0.5 - gls_n = -1.0 - sigma_k = 2.0 ! turbulent Schmidt number - sigma_psi = 2.0 ! turbulent Schmidt number - cPsi1 = 0.555 - cPsi2 = 0.833 - cPsi3_plus = 1.0 - select case (trim(gls_stability_option)) - case ("KanthaClayson-94") + end select + psi_min = 1.e-12 + case ("k-omega") + gls_p = -1.0 + gls_m = 0.5 + gls_n = -1.0 + sigma_k = 2.0 ! turbulent Schmidt number + sigma_psi = 2.0 ! turbulent Schmidt number + cPsi1 = 0.555 + cPsi2 = 0.833 + cPsi3_plus = 1.0 + select case (trim(gls_stability_option)) + case ("KanthaClayson-94") cPsi3_minus = -0.58 - case ("Canuto-01-A") + case ("Canuto-01-A") cPsi3_minus = -0.64 - case ("Canuto-01-B") + case ("Canuto-01-B") cPsi3_minus = -0.61 - case ("GibsonLaunder-78") + case ("GibsonLaunder-78") cPsi3_minus = -0.4920 - end select - psi_min = 1.e-12 - case ("gen") - gls_p = 2.0 - gls_m = 1.0 - gls_n = -0.67 - sigma_k = 0.8 ! turbulent Schmidt number - sigma_psi = 1.07 ! turbulent Schmidt number - cPsi1 = 1.0 - cPsi2 = 1.22 - cPsi3_plus = 1.0 - select case (trim(gls_stability_option)) - case ("KanthaClayson-94") + end select + psi_min = 1.e-12 + case ("gen") + gls_p = 2.0 + gls_m = 1.0 + gls_n = -0.67 + sigma_k = 0.8 ! turbulent Schmidt number + sigma_psi = 1.07 ! turbulent Schmidt number + cPsi1 = 1.0 + cPsi2 = 1.22 + cPsi3_plus = 1.0 + select case (trim(gls_stability_option)) + case ("KanthaClayson-94") cPsi3_minus = 0.1 - case ("Canuto-01-A") + case ("Canuto-01-A") cPsi3_minus = 0.05 - case ("Canuto-01-B") + case ("Canuto-01-B") cPsi3_minus = 0.08 - case ("GibsonLaunder-78") + case ("GibsonLaunder-78") cPsi3_minus = 0.1704 - end select - psi_min = 1.e-12 - case default - FLAbort("Unknown gls_option") - end select - - select case (trim(gls_stability_option)) - case ("KanthaClayson-94") + end select + psi_min = 1.e-12 + case default + FLAbort("Unknown gls_option") + end select + + select case (trim(gls_stability_option)) + case ("KanthaClayson-94") ! parameters for Kantha and Clayson (2004) cc1 = 6.0000 cc2 = 0.3200 @@ -252,7 +252,7 @@ subroutine gls_init(state) ct4 = 0.0000 ct5 = 0.2000 ctt = 0.6102 - case("Canuto-01-B") + case("Canuto-01-B") cc1 = 5.0000 cc2 = 0.6983 cc3 = 1.9664 @@ -265,7 +265,7 @@ subroutine gls_init(state) ct4 = 0.0000 ct5 = 0.3333 ctt = 0.4770 - case("Canuto-01-A") + case("Canuto-01-A") cc1 = 5.0000 cc2 = 0.8000 cc3 = 1.9680 @@ -278,7 +278,7 @@ subroutine gls_init(state) ct4 = 0.0000 ct5 = 0.3333 ctt = 0.720 - case("GibsonLaunder-78") + case("GibsonLaunder-78") cc1 = 3.6000 cc2 = 0.8000 cc3 = 1.2000 @@ -291,549 +291,549 @@ subroutine gls_init(state) ct4 = 0.0000 ct5 = 0.3333 ctt = 0.8000 - case default - FLAbort("Unknown gls_stability_function") - end select - - ! compute the a_i's for the Algebraic Stress Model - a1 = 2./3. - cc2/2. - a2 = 1. - cc3/2. - a3 = 1. - cc4/2. - a4 = cc5/2. - a5 = 1./2. - cc6/2. - - at1 = 1. - ct2 - at2 = 1. - ct3 - at3 = 2. * ( 1. - ct4) - at4 = 2. * ( 1. - ct5) - at5 = 2.*ctt*( 1. - ct5) - - ! compute cm0 - N = cc1/2. - cm0 = ( (a2**2. - 3.*a3**2. + 3.*a1*N)/(3.* N**2.) )**0.25 - cmsf = a1/N/cm0**3 - rad=sigma_psi*(cPsi2-cPsi1)/(gls_n**2.) - kappa = 0.41 - if (gls_option .ne. "k-kl") then - kappa=cm0*sqrt(rad) - end if - rcm = cm0/cmsf - cde = cm0**3. - - ewrite(1,*) "GLS Parameters" - ewrite(1,*) "--------------------------------------------" - ewrite(1,*) "cm0: ",cm0 - ewrite(1,*) "kappa: ",kappa - ewrite(1,*) "p: ",gls_p - ewrite(1,*) "m: ",gls_m - ewrite(1,*) "n: ",gls_n - ewrite(1,*) "sigma_k: ",sigma_k - ewrite(1,*) "sigma_psi: ",sigma_psi - ewrite(1,*) "Calculating BCs: ", calculate_bcs - ewrite(1,*) "Using wall function: ", gls_wall_option - ewrite(1,*) "Smoothing NN2: ", have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_buoyancy/') - ewrite(1,*) "Smoothing MM2: ", have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_shear/') - ewrite(1,*) "--------------------------------------------" - - ! intilise surface - only if we need to though - if (calculate_bcs) then - call gls_init_surfaces(state) - end if - - call gls_init_diagnostics(state) - - call gls_calc_wall_function(state) - - ! we're all done! -end subroutine gls_init + case default + FLAbort("Unknown gls_stability_function") + end select + + ! compute the a_i's for the Algebraic Stress Model + a1 = 2./3. - cc2/2. + a2 = 1. - cc3/2. + a3 = 1. - cc4/2. + a4 = cc5/2. + a5 = 1./2. - cc6/2. + + at1 = 1. - ct2 + at2 = 1. - ct3 + at3 = 2. * ( 1. - ct4) + at4 = 2. * ( 1. - ct5) + at5 = 2.*ctt*( 1. - ct5) + + ! compute cm0 + N = cc1/2. + cm0 = ( (a2**2. - 3.*a3**2. + 3.*a1*N)/(3.* N**2.) )**0.25 + cmsf = a1/N/cm0**3 + rad=sigma_psi*(cPsi2-cPsi1)/(gls_n**2.) + kappa = 0.41 + if (gls_option .ne. "k-kl") then + kappa=cm0*sqrt(rad) + end if + rcm = cm0/cmsf + cde = cm0**3. + + ewrite(1,*) "GLS Parameters" + ewrite(1,*) "--------------------------------------------" + ewrite(1,*) "cm0: ",cm0 + ewrite(1,*) "kappa: ",kappa + ewrite(1,*) "p: ",gls_p + ewrite(1,*) "m: ",gls_m + ewrite(1,*) "n: ",gls_n + ewrite(1,*) "sigma_k: ",sigma_k + ewrite(1,*) "sigma_psi: ",sigma_psi + ewrite(1,*) "Calculating BCs: ", calculate_bcs + ewrite(1,*) "Using wall function: ", gls_wall_option + ewrite(1,*) "Smoothing NN2: ", have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_buoyancy/') + ewrite(1,*) "Smoothing MM2: ", have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_shear/') + ewrite(1,*) "--------------------------------------------" + + ! intilise surface - only if we need to though + if (calculate_bcs) then + call gls_init_surfaces(state) + end if + + call gls_init_diagnostics(state) + + call gls_calc_wall_function(state) + + ! we're all done! + end subroutine gls_init !---------- ! Update TKE !---------- -subroutine gls_tke(state) - - type(state_type), intent(inout) :: state - - type(scalar_field), pointer :: source, absorption, scalarField - type(tensor_field), pointer :: tke_diff, background_diff - type(scalar_field), pointer :: tke - integer :: i, stat, ele - character(len=FIELD_NAME_LEN) :: bc_type - type(scalar_field), pointer :: scalar_surface - type(vector_field), pointer :: positions - type(scalar_field), pointer :: lumped_mass - type(scalar_field) :: inverse_lumped_mass - - - ! Temporary tensor to hold rotated values if on the sphere (note: must be a 3x3 mat) - real, dimension(3,3) :: K_M_sphere_node - - ewrite(1,*) "In gls_tke" - - ! Get N^2 and M^2 -> NN2 and MM2 - call gls_buoyancy(state) - - do i=1,NNodes_sur - call set(NN2,top_surface_nodes(i),0.0) - end do - - ! calculate stability function - call gls_stability_function(state) - - source => extract_scalar_field(state, "GLSTurbulentKineticEnergySource") - absorption => extract_scalar_field(state, "GLSTurbulentKineticEnergyAbsorption") - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - tke_diff => extract_tensor_field(state, "GLSTurbulentKineticEnergyDiffusivity") - positions => extract_vector_field(state, "Coordinate") - - ! Create a local_tke in which we can mess about with the surface values - ! for creating some of the diagnostic values later - call set(tke,local_tke) - ! Assembly loop - call zero(P) - call zero(B) - call allocate(inverse_lumped_mass, P%mesh, "InverseLumpedMass") - lumped_mass => get_lumped_mass(state, P%mesh) - call invert(lumped_mass, inverse_lumped_mass) - ! create production terms, P, B - do ele=1, ele_count(P) - call assemble_tke_prodcution_terms(ele, P, B, mesh_dim(P)) - end do - call scale(P,inverse_lumped_mass) - call scale(B,inverse_lumped_mass) - call deallocate(inverse_lumped_mass) - - call zero(source) - call zero(absorption) - do ele = 1, ele_count(tke) - call assemble_kk_src_abs(ele,tke, mesh_dim(tke)) - end do - call allocate(inverse_lumped_mass, tke%mesh, "InverseLumpedMass") - lumped_mass => get_lumped_mass(state, tke%mesh) - call invert(lumped_mass, inverse_lumped_mass) - ! source and absorption terms are set, apart from the / by lumped mass - call scale(source,inverse_lumped_mass) - call scale(absorption,inverse_lumped_mass) - call deallocate(inverse_lumped_mass) - - ! set diffusivity for tke - call zero(tke_diff) - background_diff => extract_tensor_field(state, "GLSBackgroundDiffusivity") - if (on_sphere) then - do i=1,nNodes - K_M_sphere_node=align_with_radial(node_val(positions,i),node_val(K_M,i)) - K_M_sphere_node=K_M_sphere_node*1./sigma_k - call set(tke_diff,i,K_M_sphere_node) + subroutine gls_tke(state) + + type(state_type), intent(inout) :: state + + type(scalar_field), pointer :: source, absorption, scalarField + type(tensor_field), pointer :: tke_diff, background_diff + type(scalar_field), pointer :: tke + integer :: i, stat, ele + character(len=FIELD_NAME_LEN) :: bc_type + type(scalar_field), pointer :: scalar_surface + type(vector_field), pointer :: positions + type(scalar_field), pointer :: lumped_mass + type(scalar_field) :: inverse_lumped_mass + + + ! Temporary tensor to hold rotated values if on the sphere (note: must be a 3x3 mat) + real, dimension(3,3) :: K_M_sphere_node + + ewrite(1,*) "In gls_tke" + + ! Get N^2 and M^2 -> NN2 and MM2 + call gls_buoyancy(state) + + do i=1,NNodes_sur + call set(NN2,top_surface_nodes(i),0.0) + end do + + ! calculate stability function + call gls_stability_function(state) + + source => extract_scalar_field(state, "GLSTurbulentKineticEnergySource") + absorption => extract_scalar_field(state, "GLSTurbulentKineticEnergyAbsorption") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + tke_diff => extract_tensor_field(state, "GLSTurbulentKineticEnergyDiffusivity") + positions => extract_vector_field(state, "Coordinate") + + ! Create a local_tke in which we can mess about with the surface values + ! for creating some of the diagnostic values later + call set(tke,local_tke) + ! Assembly loop + call zero(P) + call zero(B) + call allocate(inverse_lumped_mass, P%mesh, "InverseLumpedMass") + lumped_mass => get_lumped_mass(state, P%mesh) + call invert(lumped_mass, inverse_lumped_mass) + ! create production terms, P, B + do ele=1, ele_count(P) + call assemble_tke_prodcution_terms(ele, P, B, mesh_dim(P)) + end do + call scale(P,inverse_lumped_mass) + call scale(B,inverse_lumped_mass) + call deallocate(inverse_lumped_mass) + + call zero(source) + call zero(absorption) + do ele = 1, ele_count(tke) + call assemble_kk_src_abs(ele,tke, mesh_dim(tke)) end do - else - call set(tke_diff,tke_diff%dim(1),tke_diff%dim(2),K_M,scale=1./sigma_k) - end if - call addto(tke_diff,background_diff) - - ! boundary conditions - if (calculate_bcs) then - ewrite(1,*) "Calculating BCs" - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/", bc_type) - call gls_tke_bc(state,bc_type) - ! above puts the BC boundary values in top_surface_values and bottom_surface_values module level variables - ! map these onto the actual BCs in tke - scalar_surface => extract_surface_field(tke, 'tke_bottom_boundary', "value") - call remap_field(bottom_surface_values, scalar_surface) - scalar_surface => extract_surface_field(tke, 'tke_top_boundary', "value") - call remap_field(top_surface_values, scalar_surface) - end if - - ! finally, we need a copy of the old TKE for Psi, so grab it before we solve - call set(tke_old,tke) - - ! that's the TKE set up ready for the solve which is the next thing to happen (see Fluids.F90) - ewrite_minmax(source) - ewrite_minmax(absorption) - ! set source and absorption terms in optional output fields - scalarField => extract_scalar_field(state, "GLSSource1", stat) - if(stat == 0) then - call set(scalarField,source) - end if - scalarField => extract_scalar_field(state, "GLSAbsorption1", stat) - if(stat == 0) then - call set(scalarField,absorption) - end if - - contains - - subroutine assemble_tke_prodcution_terms(ele, P, B, dim) - - integer, intent(in) :: ele, dim - type(scalar_field), intent(inout) :: P, B - - real, dimension(ele_loc(P,ele),ele_ngi(P,ele),dim) :: dshape_P - real, dimension(ele_ngi(P,ele)) :: detwei - real, dimension(ele_loc(P,ele)) :: rhs_addto_vel, rhs_addto_buoy - type(element_type), pointer :: shape_p - integer, pointer, dimension(:) :: nodes_p - - nodes_p => ele_nodes(p, ele) - shape_p => ele_shape(p, ele) - call transform_to_physical( positions, ele, shape_p, dshape=dshape_p, detwei=detwei ) - - ! Shear production term: - rhs_addto_vel = shape_rhs(shape_p, detwei*ele_val_at_quad(K_M,ele)*ele_val_at_quad(MM2,ele)) - ! Buoyancy production term: - rhs_addto_buoy = shape_rhs(shape_p, -detwei*ele_val_at_quad(K_H,ele)*ele_val_at_quad(NN2,ele)) - - call addto(P, nodes_p, rhs_addto_vel) - call addto(B, nodes_p, rhs_addto_buoy) - - end subroutine assemble_tke_prodcution_terms - - subroutine assemble_kk_src_abs(ele, kk, dim) - - integer, intent(in) :: ele, dim - type(scalar_field), intent(in) :: kk - - real, dimension(ele_loc(kk,ele),ele_ngi(kk,ele),dim) :: dshape_kk - real, dimension(ele_ngi(kk,ele)) :: detwei - real, dimension(ele_loc(kk,ele)) :: rhs_addto_disip, rhs_addto_src - type(element_type), pointer :: shape_kk - integer, pointer, dimension(:) :: nodes_kk - - nodes_kk => ele_nodes(kk, ele) - shape_kk => ele_shape(kk, ele) - call transform_to_physical( positions, ele, shape_kk, dshape=dshape_kk, detwei=detwei ) - - ! ROMS and GOTM hide the absorption term in the source if the - ! total is > 0. Kinda hard to do that over an element (*what* should - ! be > 0?). So we don't pull this trick. Doesn't seem to make a - ! difference to anything. - rhs_addto_src = shape_rhs(shape_kk, detwei * (& - (ele_val_at_quad(P,ele))) & - ) - rhs_addto_disip = shape_rhs(shape_kk, detwei * ( & - (ele_val_at_quad(eps,ele) - & - ele_val_at_quad(B,ele)) / & - ele_val_at_quad(tke,ele)) & - ) - - call addto(source, nodes_kk, rhs_addto_src) - call addto(absorption, nodes_kk, rhs_addto_disip) - - - end subroutine assemble_kk_src_abs - -end subroutine gls_tke + call allocate(inverse_lumped_mass, tke%mesh, "InverseLumpedMass") + lumped_mass => get_lumped_mass(state, tke%mesh) + call invert(lumped_mass, inverse_lumped_mass) + ! source and absorption terms are set, apart from the / by lumped mass + call scale(source,inverse_lumped_mass) + call scale(absorption,inverse_lumped_mass) + call deallocate(inverse_lumped_mass) + + ! set diffusivity for tke + call zero(tke_diff) + background_diff => extract_tensor_field(state, "GLSBackgroundDiffusivity") + if (on_sphere) then + do i=1,nNodes + K_M_sphere_node=align_with_radial(node_val(positions,i),node_val(K_M,i)) + K_M_sphere_node=K_M_sphere_node*1./sigma_k + call set(tke_diff,i,K_M_sphere_node) + end do + else + call set(tke_diff,tke_diff%dim(1),tke_diff%dim(2),K_M,scale=1./sigma_k) + end if + call addto(tke_diff,background_diff) + + ! boundary conditions + if (calculate_bcs) then + ewrite(1,*) "Calculating BCs" + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/", bc_type) + call gls_tke_bc(state,bc_type) + ! above puts the BC boundary values in top_surface_values and bottom_surface_values module level variables + ! map these onto the actual BCs in tke + scalar_surface => extract_surface_field(tke, 'tke_bottom_boundary', "value") + call remap_field(bottom_surface_values, scalar_surface) + scalar_surface => extract_surface_field(tke, 'tke_top_boundary', "value") + call remap_field(top_surface_values, scalar_surface) + end if + + ! finally, we need a copy of the old TKE for Psi, so grab it before we solve + call set(tke_old,tke) + + ! that's the TKE set up ready for the solve which is the next thing to happen (see Fluids.F90) + ewrite_minmax(source) + ewrite_minmax(absorption) + ! set source and absorption terms in optional output fields + scalarField => extract_scalar_field(state, "GLSSource1", stat) + if(stat == 0) then + call set(scalarField,source) + end if + scalarField => extract_scalar_field(state, "GLSAbsorption1", stat) + if(stat == 0) then + call set(scalarField,absorption) + end if + + contains + + subroutine assemble_tke_prodcution_terms(ele, P, B, dim) + + integer, intent(in) :: ele, dim + type(scalar_field), intent(inout) :: P, B + + real, dimension(ele_loc(P,ele),ele_ngi(P,ele),dim) :: dshape_P + real, dimension(ele_ngi(P,ele)) :: detwei + real, dimension(ele_loc(P,ele)) :: rhs_addto_vel, rhs_addto_buoy + type(element_type), pointer :: shape_p + integer, pointer, dimension(:) :: nodes_p + + nodes_p => ele_nodes(p, ele) + shape_p => ele_shape(p, ele) + call transform_to_physical( positions, ele, shape_p, dshape=dshape_p, detwei=detwei ) + + ! Shear production term: + rhs_addto_vel = shape_rhs(shape_p, detwei*ele_val_at_quad(K_M,ele)*ele_val_at_quad(MM2,ele)) + ! Buoyancy production term: + rhs_addto_buoy = shape_rhs(shape_p, -detwei*ele_val_at_quad(K_H,ele)*ele_val_at_quad(NN2,ele)) + + call addto(P, nodes_p, rhs_addto_vel) + call addto(B, nodes_p, rhs_addto_buoy) + + end subroutine assemble_tke_prodcution_terms + + subroutine assemble_kk_src_abs(ele, kk, dim) + + integer, intent(in) :: ele, dim + type(scalar_field), intent(in) :: kk + + real, dimension(ele_loc(kk,ele),ele_ngi(kk,ele),dim) :: dshape_kk + real, dimension(ele_ngi(kk,ele)) :: detwei + real, dimension(ele_loc(kk,ele)) :: rhs_addto_disip, rhs_addto_src + type(element_type), pointer :: shape_kk + integer, pointer, dimension(:) :: nodes_kk + + nodes_kk => ele_nodes(kk, ele) + shape_kk => ele_shape(kk, ele) + call transform_to_physical( positions, ele, shape_kk, dshape=dshape_kk, detwei=detwei ) + + ! ROMS and GOTM hide the absorption term in the source if the + ! total is > 0. Kinda hard to do that over an element (*what* should + ! be > 0?). So we don't pull this trick. Doesn't seem to make a + ! difference to anything. + rhs_addto_src = shape_rhs(shape_kk, detwei * (& + (ele_val_at_quad(P,ele))) & + ) + rhs_addto_disip = shape_rhs(shape_kk, detwei * ( & + (ele_val_at_quad(eps,ele) - & + ele_val_at_quad(B,ele)) / & + ele_val_at_quad(tke,ele)) & + ) + + call addto(source, nodes_kk, rhs_addto_src) + call addto(absorption, nodes_kk, rhs_addto_disip) + + + end subroutine assemble_kk_src_abs + + end subroutine gls_tke !---------- ! Calculate the second quantity !---------- -subroutine gls_psi(state) - - type(state_type), intent(inout) :: state - - type(scalar_field), pointer :: source, absorption, tke, psi, scalarField - type(tensor_field), pointer :: psi_diff, background_diff - character(len=FIELD_NAME_LEN) :: bc_type - integer :: i, stat, ele - type(scalar_field), pointer :: scalar_surface - type(vector_field), pointer :: positions - type(scalar_field), pointer :: lumped_mass - type(scalar_field) :: inverse_lumped_mass, vel_prod, buoy_prod - ! variables for the ocean parameterisation - type(csr_matrix) :: face_normal_gravity - integer, dimension(:), allocatable :: ordered_elements - logical, dimension(:), allocatable :: node_list - logical :: got_surface - real :: lengthscale, percentage, tke_surface - type(scalar_field), pointer :: distanceToTop, distanceToBottom - type(vector_field), pointer :: vertical_normal - - ! Temporary tensor to hold rotated values (note: must be a 3x3 mat) - real, dimension(3,3) :: psi_sphere_node - - ewrite(1,*) "In gls_psi" - - source => extract_scalar_field(state, "GLSGenericSecondQuantitySource") - absorption => extract_scalar_field(state, "GLSGenericSecondQuantityAbsorption") - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - psi => extract_scalar_field(state, "GLSGenericSecondQuantity") - psi_diff => extract_tensor_field(state, "GLSGenericSecondQuantityDiffusivity") - positions => extract_vector_field(state, "Coordinate") - vertical_normal => extract_vector_field(state, "GravityDirection") - call allocate(vel_prod, psi%mesh, "_vel_prod_psi") - call allocate(buoy_prod, psi%mesh, "_buoy_prod_psi") - ewrite(2,*) "In gls_psi: setting up" - - ! store the tke in an internal field and then - ! add the dirichlet conditions to the upper and lower surfaces. This - ! helps stabilise the diffusivity (e.g. rapid heating cooling of the surface - ! can destabilise the run) - call set(local_tke,tke) - - ! clip at k_min - do i=1,nNodes - call set(tke,i, max(node_val(tke,i),k_min)) - call set(tke_old,i, max(node_val(tke_old,i),k_min)) - call set(local_tke,i, max(node_val(local_tke,i),k_min)) - end do - - ! This is the extra term meant to add in internal wave breaking and the - ! like. Based on a similar term in NEMO - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/ocean_parameterisation")) then - - distanceToTop => extract_scalar_field(state, "DistanceToTop") - distanceToBottom => extract_scalar_field(state, "DistanceToBottom") - - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/ocean_parameterisation/lengthscale",lengthscale) - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/ocean_parameterisation/percentage",percentage) - ewrite(2,*) "Computing extra ocean parameterisation" - allocate(node_list(NNodes)) - node_list = .false. - ! create gravity face normal - call compute_face_normal_gravity(face_normal_gravity, positions, vertical_normal) - allocate(ordered_elements(size(face_normal_gravity,1))) - - ! create an element ordering from the mesh that moves vertically downwards - call vertical_element_ordering(ordered_elements, face_normal_gravity) - ! I assume the above fails gracefully if the mesh isn't suitable, hence - ! no options checks are carried out - - got_surface = .false. - do i=1, size(ordered_elements) + subroutine gls_psi(state) + + type(state_type), intent(inout) :: state + + type(scalar_field), pointer :: source, absorption, tke, psi, scalarField + type(tensor_field), pointer :: psi_diff, background_diff + character(len=FIELD_NAME_LEN) :: bc_type + integer :: i, stat, ele + type(scalar_field), pointer :: scalar_surface + type(vector_field), pointer :: positions + type(scalar_field), pointer :: lumped_mass + type(scalar_field) :: inverse_lumped_mass, vel_prod, buoy_prod + ! variables for the ocean parameterisation + type(csr_matrix) :: face_normal_gravity + integer, dimension(:), allocatable :: ordered_elements + logical, dimension(:), allocatable :: node_list + logical :: got_surface + real :: lengthscale, percentage, tke_surface + type(scalar_field), pointer :: distanceToTop, distanceToBottom + type(vector_field), pointer :: vertical_normal + + ! Temporary tensor to hold rotated values (note: must be a 3x3 mat) + real, dimension(3,3) :: psi_sphere_node + + ewrite(1,*) "In gls_psi" + + source => extract_scalar_field(state, "GLSGenericSecondQuantitySource") + absorption => extract_scalar_field(state, "GLSGenericSecondQuantityAbsorption") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + psi => extract_scalar_field(state, "GLSGenericSecondQuantity") + psi_diff => extract_tensor_field(state, "GLSGenericSecondQuantityDiffusivity") + positions => extract_vector_field(state, "Coordinate") + vertical_normal => extract_vector_field(state, "GravityDirection") + call allocate(vel_prod, psi%mesh, "_vel_prod_psi") + call allocate(buoy_prod, psi%mesh, "_buoy_prod_psi") + ewrite(2,*) "In gls_psi: setting up" + + ! store the tke in an internal field and then + ! add the dirichlet conditions to the upper and lower surfaces. This + ! helps stabilise the diffusivity (e.g. rapid heating cooling of the surface + ! can destabilise the run) + call set(local_tke,tke) + + ! clip at k_min + do i=1,nNodes + call set(tke,i, max(node_val(tke,i),k_min)) + call set(tke_old,i, max(node_val(tke_old,i),k_min)) + call set(local_tke,i, max(node_val(local_tke,i),k_min)) + end do + + ! This is the extra term meant to add in internal wave breaking and the + ! like. Based on a similar term in NEMO + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/ocean_parameterisation")) then + + distanceToTop => extract_scalar_field(state, "DistanceToTop") + distanceToBottom => extract_scalar_field(state, "DistanceToBottom") + + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/ocean_parameterisation/lengthscale",lengthscale) + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/ocean_parameterisation/percentage",percentage) + ewrite(2,*) "Computing extra ocean parameterisation" + allocate(node_list(NNodes)) + node_list = .false. + ! create gravity face normal + call compute_face_normal_gravity(face_normal_gravity, positions, vertical_normal) + allocate(ordered_elements(size(face_normal_gravity,1))) + + ! create an element ordering from the mesh that moves vertically downwards + call vertical_element_ordering(ordered_elements, face_normal_gravity) + ! I assume the above fails gracefully if the mesh isn't suitable, hence + ! no options checks are carried out + + got_surface = .false. + do i=1, size(ordered_elements) if (.not. got_surface) then - ! First time around grab, the surface TKE - ! for this column - tke_surface = maxval(ele_val(tke,i)) - got_surface = .true. + ! First time around grab, the surface TKE + ! for this column + tke_surface = maxval(ele_val(tke,i)) + got_surface = .true. end if if (got_surface) then - call ocean_tke(i,tke,distanceToTop,lengthscale,percentage,tke_surface, node_list) + call ocean_tke(i,tke,distanceToTop,lengthscale,percentage,tke_surface, node_list) end if if (minval(ele_val(distanceToBottom,i)) < 1e-6) then - got_surface = .false. + got_surface = .false. end if - end do - - deallocate(ordered_elements) - call deallocate(face_normal_gravity) - deallocate(node_list) - - end if - - call allocate(inverse_lumped_mass, psi%mesh, "InverseLumpedMass") - lumped_mass => get_lumped_mass(state, psi%mesh) - call invert(lumped_mass, inverse_lumped_mass) - ! Set Psi from previous timestep - do i=1,nNodes - call set(psi,i, cm0**gls_p * node_val(tke_old,i)**gls_m * node_val(ll,i)**gls_n) - call set(psi,i,max(node_val(psi,i),psi_min)) - end do - - ewrite(2,*) "In gls_psi: computing RHS" - call zero(vel_prod) - call zero(buoy_prod) - call zero(source) - call zero(absorption) - do ele = 1, ele_count(psi) - call assemble_production_terms_psi(ele, vel_prod, buoy_prod, psi, mesh_dim(psi)) - end do - call scale(vel_prod,inverse_lumped_mass) - call scale(buoy_prod,inverse_lumped_mass) - - do ele = 1, ele_count(psi) - call assemble_psi_src_abs(ele, psi, tke_old, mesh_dim(psi)) - end do - call scale(source,inverse_lumped_mass) - call scale(absorption,inverse_lumped_mass) - call deallocate(inverse_lumped_mass) - - ewrite(2,*) "In gls_psi: setting diffusivity" - ! Set diffusivity for Psi - call zero(psi_diff) - background_diff => extract_tensor_field(state, "GLSBackgroundDiffusivity") - if (on_sphere) then + end do + + deallocate(ordered_elements) + call deallocate(face_normal_gravity) + deallocate(node_list) + + end if + + call allocate(inverse_lumped_mass, psi%mesh, "InverseLumpedMass") + lumped_mass => get_lumped_mass(state, psi%mesh) + call invert(lumped_mass, inverse_lumped_mass) + ! Set Psi from previous timestep do i=1,nNodes - psi_sphere_node=align_with_radial(node_val(positions,i),node_val(K_M,i)) - psi_sphere_node=psi_sphere_node*1./sigma_psi - call set(psi_diff,i,psi_sphere_node) + call set(psi,i, cm0**gls_p * node_val(tke_old,i)**gls_m * node_val(ll,i)**gls_n) + call set(psi,i,max(node_val(psi,i),psi_min)) + end do + + ewrite(2,*) "In gls_psi: computing RHS" + call zero(vel_prod) + call zero(buoy_prod) + call zero(source) + call zero(absorption) + do ele = 1, ele_count(psi) + call assemble_production_terms_psi(ele, vel_prod, buoy_prod, psi, mesh_dim(psi)) + end do + call scale(vel_prod,inverse_lumped_mass) + call scale(buoy_prod,inverse_lumped_mass) + + do ele = 1, ele_count(psi) + call assemble_psi_src_abs(ele, psi, tke_old, mesh_dim(psi)) end do - else - call set(psi_diff,psi_diff%dim(1),psi_diff%dim(2),K_M,scale=1./sigma_psi) - end if - call addto(psi_diff,background_diff) - - ewrite(2,*) "In gls_psi: setting BCs" - ! boundary conditions - if (calculate_bcs) then - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/", bc_type) - call gls_psi_bc(state,bc_type) - ! above puts the BC boundary values in top_surface_values and bottom_surface_values module level variables - ! map these onto the actual BCs in Psi - scalar_surface => extract_surface_field(psi, 'psi_bottom_boundary', "value") - call remap_field(bottom_surface_values, scalar_surface) - scalar_surface => extract_surface_field(psi, 'psi_top_boundary', "value") - call remap_field(top_surface_values, scalar_surface) - end if - - - ewrite(2,*) "In gls_psi: tearing down" - ! Psi is now ready for solving (see Fluids.F90) - ewrite_minmax(source) - ewrite_minmax(absorption) - ! set source and absorption terms in optional output fields - scalarField => extract_scalar_field(state, "GLSSource2", stat) - if(stat == 0) then - call set(scalarField,source) - end if - scalarField => extract_scalar_field(state, "GLSAbsorption2", stat) - if(stat == 0) then - call set(scalarField,absorption) - end if - - call deallocate(vel_prod) - call deallocate(buoy_prod) - - - contains - - subroutine ocean_tke(ele, tke, distanceToTop, lengthscale, percentage, tke_surface, nodes_done) - type(scalar_field),pointer, intent(in) :: distanceToTop - type(scalar_field),pointer, intent(out) :: tke - real, intent(in) :: lengthscale, percentage, tke_surface - integer, intent(in) :: ele - logical, dimension(:), intent(inout) :: nodes_done - - integer, dimension(:), pointer :: element_nodes - integer :: i, node - real :: current_TKE, depth - - element_nodes => ele_nodes(tke, ele) - - - ! smooth out TKE according to length scale - do i = 1, size(element_nodes) + call scale(source,inverse_lumped_mass) + call scale(absorption,inverse_lumped_mass) + call deallocate(inverse_lumped_mass) + + ewrite(2,*) "In gls_psi: setting diffusivity" + ! Set diffusivity for Psi + call zero(psi_diff) + background_diff => extract_tensor_field(state, "GLSBackgroundDiffusivity") + if (on_sphere) then + do i=1,nNodes + psi_sphere_node=align_with_radial(node_val(positions,i),node_val(K_M,i)) + psi_sphere_node=psi_sphere_node*1./sigma_psi + call set(psi_diff,i,psi_sphere_node) + end do + else + call set(psi_diff,psi_diff%dim(1),psi_diff%dim(2),K_M,scale=1./sigma_psi) + end if + call addto(psi_diff,background_diff) + + ewrite(2,*) "In gls_psi: setting BCs" + ! boundary conditions + if (calculate_bcs) then + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/", bc_type) + call gls_psi_bc(state,bc_type) + ! above puts the BC boundary values in top_surface_values and bottom_surface_values module level variables + ! map these onto the actual BCs in Psi + scalar_surface => extract_surface_field(psi, 'psi_bottom_boundary', "value") + call remap_field(bottom_surface_values, scalar_surface) + scalar_surface => extract_surface_field(psi, 'psi_top_boundary', "value") + call remap_field(top_surface_values, scalar_surface) + end if + + + ewrite(2,*) "In gls_psi: tearing down" + ! Psi is now ready for solving (see Fluids.F90) + ewrite_minmax(source) + ewrite_minmax(absorption) + ! set source and absorption terms in optional output fields + scalarField => extract_scalar_field(state, "GLSSource2", stat) + if(stat == 0) then + call set(scalarField,source) + end if + scalarField => extract_scalar_field(state, "GLSAbsorption2", stat) + if(stat == 0) then + call set(scalarField,absorption) + end if + + call deallocate(vel_prod) + call deallocate(buoy_prod) + + + contains + + subroutine ocean_tke(ele, tke, distanceToTop, lengthscale, percentage, tke_surface, nodes_done) + type(scalar_field),pointer, intent(in) :: distanceToTop + type(scalar_field),pointer, intent(out) :: tke + real, intent(in) :: lengthscale, percentage, tke_surface + integer, intent(in) :: ele + logical, dimension(:), intent(inout) :: nodes_done + + integer, dimension(:), pointer :: element_nodes + integer :: i, node + real :: current_TKE, depth + + element_nodes => ele_nodes(tke, ele) + + + ! smooth out TKE according to length scale + do i = 1, size(element_nodes) node = element_nodes(i) depth = node_val(distanceToTop,node) current_TKE = node_val(tke,node) if (nodes_done(node)) then - cycle + cycle end if current_TKE = current_TKE + & - & percentage*TKE_surface * EXP( -depth / lengthscale ) + & percentage*TKE_surface * EXP( -depth / lengthscale ) call set(tke,node,current_TKE) nodes_done(node) = .true. - end do + end do - end subroutine ocean_tke + end subroutine ocean_tke - subroutine reconstruct_psi(ele, psi, dim) + subroutine reconstruct_psi(ele, psi, dim) - integer, intent(in) :: ele, dim - type(scalar_field), intent(inout) :: psi + integer, intent(in) :: ele, dim + type(scalar_field), intent(inout) :: psi - real, dimension(ele_loc(psi,ele),ele_ngi(psi,ele),dim) :: dshape_psi - real, dimension(ele_ngi(psi,ele)) :: detwei - real, dimension(ele_loc(psi,ele)) :: rhs_addto - type(element_type), pointer :: shape_psi - integer, pointer, dimension(:) :: nodes_psi + real, dimension(ele_loc(psi,ele),ele_ngi(psi,ele),dim) :: dshape_psi + real, dimension(ele_ngi(psi,ele)) :: detwei + real, dimension(ele_loc(psi,ele)) :: rhs_addto + type(element_type), pointer :: shape_psi + integer, pointer, dimension(:) :: nodes_psi - nodes_psi => ele_nodes(psi, ele) - shape_psi => ele_shape(psi, ele) - call transform_to_physical( positions, ele, shape_psi, dshape=dshape_psi, detwei=detwei ) + nodes_psi => ele_nodes(psi, ele) + shape_psi => ele_shape(psi, ele) + call transform_to_physical( positions, ele, shape_psi, dshape=dshape_psi, detwei=detwei ) - rhs_addto = shape_rhs(shape_psi, detwei* & - (cm0**gls_p) * & - ele_val_at_quad(tke_old,ele)**gls_m * & - ele_val_at_quad(ll,ele)**gls_n) + rhs_addto = shape_rhs(shape_psi, detwei* & + (cm0**gls_p) * & + ele_val_at_quad(tke_old,ele)**gls_m * & + ele_val_at_quad(ll,ele)**gls_n) - call addto(psi, nodes_psi, rhs_addto) + call addto(psi, nodes_psi, rhs_addto) - end subroutine reconstruct_psi + end subroutine reconstruct_psi - subroutine assemble_production_terms_psi(ele, vel_prod, buoy_prod, psi, dim) + subroutine assemble_production_terms_psi(ele, vel_prod, buoy_prod, psi, dim) - integer, intent(in) :: ele, dim - type(scalar_field), intent(inout) :: psi, vel_prod, buoy_prod + integer, intent(in) :: ele, dim + type(scalar_field), intent(inout) :: psi, vel_prod, buoy_prod - real, dimension(ele_loc(psi,ele),ele_ngi(psi,ele),dim) :: dshape_psi - real, dimension(ele_ngi(psi,ele)) :: detwei - real, dimension(ele_loc(psi,ele)) :: rhs_addto_vel, rhs_addto_buoy - real, dimension(ele_ngi(psi,ele)) :: cPsi3 - type(element_type), pointer :: shape_psi - integer, pointer, dimension(:) :: nodes_psi + real, dimension(ele_loc(psi,ele),ele_ngi(psi,ele),dim) :: dshape_psi + real, dimension(ele_ngi(psi,ele)) :: detwei + real, dimension(ele_loc(psi,ele)) :: rhs_addto_vel, rhs_addto_buoy + real, dimension(ele_ngi(psi,ele)) :: cPsi3 + type(element_type), pointer :: shape_psi + integer, pointer, dimension(:) :: nodes_psi - nodes_psi => ele_nodes(psi, ele) - shape_psi => ele_shape(psi, ele) - call transform_to_physical( positions, ele, shape_psi, dshape=dshape_psi, detwei=detwei ) + nodes_psi => ele_nodes(psi, ele) + shape_psi => ele_shape(psi, ele) + call transform_to_physical( positions, ele, shape_psi, dshape=dshape_psi, detwei=detwei ) - ! Buoyancy production term: - ! First we need to work out if cPsi3 is for stable or unstable - ! stratification - where(ele_val_at_quad(B,ele) .gt. 0.0) + ! Buoyancy production term: + ! First we need to work out if cPsi3 is for stable or unstable + ! stratification + where(ele_val_at_quad(B,ele) .gt. 0.0) cPsi3 = cPsi3_plus ! unstable strat - elsewhere + elsewhere cPsi3 = cPsi3_minus ! stable strat - end where - rhs_addto_buoy = shape_rhs(shape_psi, detwei*(cPsi3*ele_val_at_quad(B,ele)*& - (ele_val_at_quad(psi, ele)/ele_val_at_quad(local_tke,ele)))) + end where + rhs_addto_buoy = shape_rhs(shape_psi, detwei*(cPsi3*ele_val_at_quad(B,ele)*& + (ele_val_at_quad(psi, ele)/ele_val_at_quad(local_tke,ele)))) - ! shear production term: - rhs_addto_vel = shape_rhs(shape_psi, detwei*(cPsi1*ele_val_at_quad(P,ele)*& - (ele_val_at_quad(psi, ele)/ele_val_at_quad(local_tke,ele)))) + ! shear production term: + rhs_addto_vel = shape_rhs(shape_psi, detwei*(cPsi1*ele_val_at_quad(P,ele)*& + (ele_val_at_quad(psi, ele)/ele_val_at_quad(local_tke,ele)))) - call addto(vel_prod, nodes_psi, rhs_addto_vel) - call addto(buoy_prod, nodes_psi, rhs_addto_buoy) + call addto(vel_prod, nodes_psi, rhs_addto_vel) + call addto(buoy_prod, nodes_psi, rhs_addto_buoy) - end subroutine assemble_production_terms_psi + end subroutine assemble_production_terms_psi - subroutine assemble_psi_src_abs(ele, psi, tke, dim) + subroutine assemble_psi_src_abs(ele, psi, tke, dim) - integer, intent(in) :: ele, dim - type(scalar_field), intent(in) :: psi, tke + integer, intent(in) :: ele, dim + type(scalar_field), intent(in) :: psi, tke - real, dimension(ele_loc(psi,ele),ele_ngi(psi,ele),dim) :: dshape_psi - real, dimension(ele_ngi(psi,ele)) :: detwei - real, dimension(ele_loc(psi,ele)) :: rhs_addto_src, rhs_addto_disip - type(element_type), pointer :: shape_psi - integer, pointer, dimension(:) :: nodes_psi + real, dimension(ele_loc(psi,ele),ele_ngi(psi,ele),dim) :: dshape_psi + real, dimension(ele_ngi(psi,ele)) :: detwei + real, dimension(ele_loc(psi,ele)) :: rhs_addto_src, rhs_addto_disip + type(element_type), pointer :: shape_psi + integer, pointer, dimension(:) :: nodes_psi - nodes_psi => ele_nodes(psi, ele) - shape_psi => ele_shape(psi, ele) - call transform_to_physical( positions, ele, shape_psi, dshape=dshape_psi, detwei=detwei ) + nodes_psi => ele_nodes(psi, ele) + shape_psi => ele_shape(psi, ele) + call transform_to_physical( positions, ele, shape_psi, dshape=dshape_psi, detwei=detwei ) - where (ele_val_at_quad(vel_prod,ele) + ele_val_at_quad(buoy_prod,ele) .gt. 0) + where (ele_val_at_quad(vel_prod,ele) + ele_val_at_quad(buoy_prod,ele) .gt. 0) rhs_addto_src = shape_rhs(shape_psi, detwei* ( & - (ele_val_at_quad(vel_prod,ele)) + & - (ele_val_at_quad(buoy_prod,ele)) & - ) & !detwei - ) ! shape_rhs + (ele_val_at_quad(vel_prod,ele)) + & + (ele_val_at_quad(buoy_prod,ele)) & + ) & !detwei + ) ! shape_rhs rhs_addto_disip = shape_rhs(shape_psi, detwei* (& - (cPsi2*ele_val_at_quad(eps,ele) * & - (ele_val_at_quad(Fwall,ele)*ele_val_at_quad(psi, ele)/ele_val_at_quad(tke,ele))) / & - ele_val_at_quad(psi,ele) & - ) & ! detwei - ) !shape_rhs - elsewhere + (cPsi2*ele_val_at_quad(eps,ele) * & + (ele_val_at_quad(Fwall,ele)*ele_val_at_quad(psi, ele)/ele_val_at_quad(tke,ele))) / & + ele_val_at_quad(psi,ele) & + ) & ! detwei + ) !shape_rhs + elsewhere rhs_addto_src = shape_rhs(shape_psi, detwei * ( & - (ele_val_at_quad(vel_prod,ele)) & - ) & !detwei - ) !shape_rhs + (ele_val_at_quad(vel_prod,ele)) & + ) & !detwei + ) !shape_rhs rhs_addto_disip = shape_rhs(shape_psi, detwei * (& - ((cPsi2*ele_val_at_quad(eps,ele) * & - (ele_val_at_quad(Fwall,ele)*ele_val_at_quad(psi, ele)/ele_val_at_quad(tke,ele))) - &! disipation term - (ele_val_at_quad(buoy_prod,ele)))/ & ! buoyancy term - ele_val_at_quad(psi,ele)& - ) & !detwei - ) !shape_rhs - end where - call addto(source, nodes_psi, rhs_addto_src) - call addto(absorption, nodes_psi, rhs_addto_disip) + ((cPsi2*ele_val_at_quad(eps,ele) * & + (ele_val_at_quad(Fwall,ele)*ele_val_at_quad(psi, ele)/ele_val_at_quad(tke,ele))) - &! disipation term + (ele_val_at_quad(buoy_prod,ele)))/ & ! buoyancy term + ele_val_at_quad(psi,ele)& + ) & !detwei + ) !shape_rhs + end where + call addto(source, nodes_psi, rhs_addto_src) + call addto(absorption, nodes_psi, rhs_addto_disip) - end subroutine assemble_psi_src_abs + end subroutine assemble_psi_src_abs -end subroutine gls_psi + end subroutine gls_psi !---------- @@ -843,423 +843,423 @@ end subroutine gls_psi ! These are placed in the GLS fields ready for other tracer fields to use ! Viscosity is placed in the velocity viscosity !---------- -subroutine gls_diffusivity(state) - - type(state_type), intent(inout) :: state - - type(scalar_field), pointer :: tke_state, psi - type(tensor_field), pointer :: eddy_diff_KH,eddy_visc_KM,viscosity,background_diff,background_visc - real :: exp1, exp2, exp3, x - integer :: i, stat - real :: psi_limit, tke_cur, epslim - real, parameter :: galp = 0.748331 ! sqrt(0.56) - type(vector_field), pointer :: positions, velocity - type(scalar_field) :: remaped_K_M, tke - type(tensor_field) :: remaped_background_visc - - - ! Temporary tensors to hold rotated values (note: must be a 3x3 mat) - real, dimension(3,3) :: eddy_diff_KH_sphere_node, eddy_visc_KM_sphere_node, viscosity_sphere_node - - ewrite(1,*) "In gls_diffusivity" - - tke_state => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - psi => extract_scalar_field(state, "GLSGenericSecondQuantity") - eddy_visc_KM => extract_tensor_field(state, "GLSEddyViscosityKM",stat) - eddy_diff_KH => extract_tensor_field(state, "GLSEddyDiffusivityKH",stat) - viscosity => extract_tensor_field(state, "Viscosity",stat) - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - - call allocate(tke, tke_state%mesh, name="MyLocalTKE") - !if (gls_n > 0) then - ! set the TKE to use below to the unaltered TKE - ! with no changes to the upper/lower surfaces - ! Applies to k-kl model only - ! call set (tke, local_tke) - !else - ! Use the altered TKE to get the surface diffusivity correct - call set (tke, tke_state) - !end if - - exp1 = 3.0 + gls_p/gls_n - exp2 = 1.5 + gls_m/gls_n - exp3 = - 1.0/gls_n - - if (gls_n > 0) then - do i=1,nNodes + subroutine gls_diffusivity(state) + + type(state_type), intent(inout) :: state + + type(scalar_field), pointer :: tke_state, psi + type(tensor_field), pointer :: eddy_diff_KH,eddy_visc_KM,viscosity,background_diff,background_visc + real :: exp1, exp2, exp3, x + integer :: i, stat + real :: psi_limit, tke_cur, epslim + real, parameter :: galp = 0.748331 ! sqrt(0.56) + type(vector_field), pointer :: positions, velocity + type(scalar_field) :: remaped_K_M, tke + type(tensor_field) :: remaped_background_visc + + + ! Temporary tensors to hold rotated values (note: must be a 3x3 mat) + real, dimension(3,3) :: eddy_diff_KH_sphere_node, eddy_visc_KM_sphere_node, viscosity_sphere_node + + ewrite(1,*) "In gls_diffusivity" + + tke_state => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + psi => extract_scalar_field(state, "GLSGenericSecondQuantity") + eddy_visc_KM => extract_tensor_field(state, "GLSEddyViscosityKM",stat) + eddy_diff_KH => extract_tensor_field(state, "GLSEddyDiffusivityKH",stat) + viscosity => extract_tensor_field(state, "Viscosity",stat) + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + + call allocate(tke, tke_state%mesh, name="MyLocalTKE") + !if (gls_n > 0) then + ! set the TKE to use below to the unaltered TKE + ! with no changes to the upper/lower surfaces + ! Applies to k-kl model only + ! call set (tke, local_tke) + !else + ! Use the altered TKE to get the surface diffusivity correct + call set (tke, tke_state) + !end if + + exp1 = 3.0 + gls_p/gls_n + exp2 = 1.5 + gls_m/gls_n + exp3 = - 1.0/gls_n + + if (gls_n > 0) then + do i=1,nNodes tke_cur = node_val(tke,i) psi_limit = (sqrt(0.56) * tke_cur**(exp2) * (1./sqrt(max(node_val(NN2,i)+1e-10,0.))) & - & * cm0**(gls_p / gls_n))**(-gls_n) + & * cm0**(gls_p / gls_n))**(-gls_n) call set(psi,i,max(psi_min,min(node_val(psi,i),psi_limit))) - end do - end if + end do + end if - do i=1,nNodes + do i=1,nNodes - tke_cur = node_val(tke,i) + tke_cur = node_val(tke,i) - ! recover dissipation rate from k and psi - call set(eps,i, cm0**exp1 * tke_cur**exp2 * node_val(psi,i)**exp3) + ! recover dissipation rate from k and psi + call set(eps,i, cm0**exp1 * tke_cur**exp2 * node_val(psi,i)**exp3) - ! limit dissipation rate under stable stratification, - ! see Galperin et al. (1988) - if (node_val(NN2,i) > 0) then + ! limit dissipation rate under stable stratification, + ! see Galperin et al. (1988) + if (node_val(NN2,i) > 0) then epslim = (cde*tke_cur*sqrt(node_val(NN2,i)))/galp - else + else epslim = eps_min - end if - call set(eps,i, max(node_val(eps,i),max(eps_min,epslim))) - - ! compute dissipative scale - call set(ll,i,cde*sqrt(tke_cur**3.)/node_val(eps,i)) - !if (gls_n > 0) then - ! if (node_val(NN2,i) > 0) then - ! limit = sqrt(0.56 * tke_cur / node_val(NN2,i)) - ! call set(ll,i,min(limit,node_val(ll,i))) - ! end if - !end if - - end do - - ! calc fwall - ewrite(2,*) "Calculating the wall function for GLS" - call gls_calc_wall_function(state) - - ! calculate diffusivities for next step and for use in other fields - do i=1,nNodes - x = sqrt(node_val(tke,i))*node_val(ll,i) - ! momentum - call set(K_M,i, relaxation*node_val(K_M,i) + (1-relaxation)*node_val(S_M,i)*x) - ! tracer - call set(K_H,i, relaxation*node_val(K_H,i) + (1-relaxation)*node_val(S_H,i)*x) - end do - - ! put KM onto surface fields for Psi_bc - if (calculate_bcs) then - call remap_field_to_surface(K_M, top_surface_km_values, top_surface_element_list) - call remap_field_to_surface(K_M, bottom_surface_km_values, bottom_surface_element_list) - end if - - !set the eddy_diffusivity and viscosity tensors for use by other fields - call zero(eddy_diff_KH) ! zero it first as we're using an addto below - call zero(eddy_visc_KM) - - if (on_sphere) then - do i=1,nNodes - eddy_diff_KH_sphere_node=align_with_radial(node_val(positions,i),node_val(K_H,i)) - eddy_visc_KM_sphere_node=align_with_radial(node_val(positions,i),node_val(K_M,i)) - call set(eddy_diff_KH,i,eddy_diff_KH_sphere_node) - call set(eddy_visc_KM,i,eddy_visc_KM_sphere_node) - end do - else - call set(eddy_diff_KH,eddy_diff_KH%dim(1),eddy_diff_KH%dim(2),K_H) - call set(eddy_visc_KM,eddy_visc_KM%dim(1),eddy_visc_KM%dim(2),K_M) - end if - - background_diff => extract_tensor_field(state, "GLSBackgroundDiffusivity") - call addto(eddy_diff_KH,background_diff) - background_visc => extract_tensor_field(state, "GLSBackgroundViscosity") - call addto(eddy_visc_KM,background_visc) - - ewrite_minmax(K_H) - ewrite_minmax(K_M) - ewrite_minmax(S_H) - ewrite_minmax(S_M) - ewrite_minmax(ll) - ewrite_minmax(eps) - ewrite_minmax(tke) - ewrite_minmax(psi) - - ! Set viscosity - call allocate(remaped_K_M,velocity%mesh,name="remaped_Km") - call allocate(remaped_background_visc,velocity%mesh,name="remaped_viscosity") - if (K_M%mesh%continuity /= viscosity%mesh%continuity) then - ! remap - call remap_field(K_M,remaped_K_M) - call remap_field(background_visc,remaped_background_visc) - else - ! copy - call set(remaped_K_M,K_M) - call set(remaped_background_visc,background_visc) - end if - call zero(viscosity) - if (on_sphere) then - do i=1,nNodes - viscosity_sphere_node=align_with_radial(node_val(positions,i),node_val(remaped_K_M,i)) - call set(viscosity,i,viscosity_sphere_node) + end if + call set(eps,i, max(node_val(eps,i),max(eps_min,epslim))) + + ! compute dissipative scale + call set(ll,i,cde*sqrt(tke_cur**3.)/node_val(eps,i)) + !if (gls_n > 0) then + ! if (node_val(NN2,i) > 0) then + ! limit = sqrt(0.56 * tke_cur / node_val(NN2,i)) + ! call set(ll,i,min(limit,node_val(ll,i))) + ! end if + !end if + end do - else - call set(viscosity,viscosity%dim(1),viscosity%dim(2),remaped_K_M) - end if - call addto(viscosity,remaped_background_visc) - ! Set output on optional fields - if the field exists, stick something in it - ! We only need to do this to those fields that we haven't pulled from state, but - ! allocated ourselves - call gls_output_fields(state) + ! calc fwall + ewrite(2,*) "Calculating the wall function for GLS" + call gls_calc_wall_function(state) - call deallocate(remaped_background_visc) - call deallocate(remaped_K_M) - call deallocate(tke) + ! calculate diffusivities for next step and for use in other fields + do i=1,nNodes + x = sqrt(node_val(tke,i))*node_val(ll,i) + ! momentum + call set(K_M,i, relaxation*node_val(K_M,i) + (1-relaxation)*node_val(S_M,i)*x) + ! tracer + call set(K_H,i, relaxation*node_val(K_H,i) + (1-relaxation)*node_val(S_H,i)*x) + end do -end subroutine gls_diffusivity + ! put KM onto surface fields for Psi_bc + if (calculate_bcs) then + call remap_field_to_surface(K_M, top_surface_km_values, top_surface_element_list) + call remap_field_to_surface(K_M, bottom_surface_km_values, bottom_surface_element_list) + end if + + !set the eddy_diffusivity and viscosity tensors for use by other fields + call zero(eddy_diff_KH) ! zero it first as we're using an addto below + call zero(eddy_visc_KM) + + if (on_sphere) then + do i=1,nNodes + eddy_diff_KH_sphere_node=align_with_radial(node_val(positions,i),node_val(K_H,i)) + eddy_visc_KM_sphere_node=align_with_radial(node_val(positions,i),node_val(K_M,i)) + call set(eddy_diff_KH,i,eddy_diff_KH_sphere_node) + call set(eddy_visc_KM,i,eddy_visc_KM_sphere_node) + end do + else + call set(eddy_diff_KH,eddy_diff_KH%dim(1),eddy_diff_KH%dim(2),K_H) + call set(eddy_visc_KM,eddy_visc_KM%dim(1),eddy_visc_KM%dim(2),K_M) + end if + + background_diff => extract_tensor_field(state, "GLSBackgroundDiffusivity") + call addto(eddy_diff_KH,background_diff) + background_visc => extract_tensor_field(state, "GLSBackgroundViscosity") + call addto(eddy_visc_KM,background_visc) + + ewrite_minmax(K_H) + ewrite_minmax(K_M) + ewrite_minmax(S_H) + ewrite_minmax(S_M) + ewrite_minmax(ll) + ewrite_minmax(eps) + ewrite_minmax(tke) + ewrite_minmax(psi) + + ! Set viscosity + call allocate(remaped_K_M,velocity%mesh,name="remaped_Km") + call allocate(remaped_background_visc,velocity%mesh,name="remaped_viscosity") + if (K_M%mesh%continuity /= viscosity%mesh%continuity) then + ! remap + call remap_field(K_M,remaped_K_M) + call remap_field(background_visc,remaped_background_visc) + else + ! copy + call set(remaped_K_M,K_M) + call set(remaped_background_visc,background_visc) + end if + call zero(viscosity) + if (on_sphere) then + do i=1,nNodes + viscosity_sphere_node=align_with_radial(node_val(positions,i),node_val(remaped_K_M,i)) + call set(viscosity,i,viscosity_sphere_node) + end do + else + call set(viscosity,viscosity%dim(1),viscosity%dim(2),remaped_K_M) + end if + call addto(viscosity,remaped_background_visc) + + ! Set output on optional fields - if the field exists, stick something in it + ! We only need to do this to those fields that we haven't pulled from state, but + ! allocated ourselves + call gls_output_fields(state) + + call deallocate(remaped_background_visc) + call deallocate(remaped_K_M) + call deallocate(tke) + + end subroutine gls_diffusivity !---------- ! gls_cleanup does...have a guess...go on. !---------- -subroutine gls_cleanup() - - ewrite(1,*) "Cleaning up GLS variables" - ! deallocate all our variables - if (calculate_bcs) then - ewrite(1,*) "Cleaning up GLS surface variables" - call deallocate(bottom_surface_values) - call deallocate(bottom_surface_tke_values) - call deallocate(bottom_surface_km_values) - call deallocate(top_surface_values) - call deallocate(top_surface_tke_values) - call deallocate(top_surface_km_values) - end if - call deallocate(NN2) - call deallocate(MM2) - call deallocate(B) - call deallocate(P) - call deallocate(S_H) - call deallocate(S_M) - call deallocate(K_H) - call deallocate(K_M) - call deallocate(eps) - call deallocate(Fwall) - call deallocate(density) - call deallocate(tke_old) - call deallocate(local_tke) - call deallocate(ll) - ewrite(1,*) "Finished gls_cleanup" - -end subroutine gls_cleanup + subroutine gls_cleanup() + + ewrite(1,*) "Cleaning up GLS variables" + ! deallocate all our variables + if (calculate_bcs) then + ewrite(1,*) "Cleaning up GLS surface variables" + call deallocate(bottom_surface_values) + call deallocate(bottom_surface_tke_values) + call deallocate(bottom_surface_km_values) + call deallocate(top_surface_values) + call deallocate(top_surface_tke_values) + call deallocate(top_surface_km_values) + end if + call deallocate(NN2) + call deallocate(MM2) + call deallocate(B) + call deallocate(P) + call deallocate(S_H) + call deallocate(S_M) + call deallocate(K_H) + call deallocate(K_M) + call deallocate(eps) + call deallocate(Fwall) + call deallocate(density) + call deallocate(tke_old) + call deallocate(local_tke) + call deallocate(ll) + ewrite(1,*) "Finished gls_cleanup" + + end subroutine gls_cleanup !--------- ! Needs to be called after an adapt to reset the fields ! and arrays within the module ! Note that clean_up has already been called in the pre-adapt hook !---------- -subroutine gls_adapt_mesh(state) - - type(state_type), intent(inout) :: state - - ewrite(1,*) "In gls_adapt_mesh" - call gls_allocate_temps(state) ! reallocate everything - if (calculate_bcs) then - call gls_init_surfaces(state) ! re-do the boundaries - end if - call gls_init_diagnostics(state) - -end subroutine gls_adapt_mesh - - -subroutine gls_check_options - - character(len=FIELD_NAME_LEN) :: buffer - integer :: stat - real :: min_tke, relax, nbcs - integer :: dimension - - ! Don't do GLS if it's not included in the model! - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/")) return - - ! one dimensional problems not supported - call get_option("/geometry/dimension/", dimension) - if (dimension .eq. 1 .and. have_option("/material_phase[0]/subgridscale_parameterisations/GLS/")) then - FLExit("GLS modelling is only supported for dimension > 1") - end if - - call get_option("/problem_type", buffer) - if (.not. (buffer .eq. "oceans" .or. buffer .eq. "large_scale_ocean_options")) then - FLExit("GLS modelling is only supported for problem type oceans or large_scale_oceans.") - end if - - if (.not.have_option("/physical_parameters/gravity")) then - ewrite(-1, *) "GLS modelling requires gravity" - FLExit("(otherwise buoyancy is a bit meaningless)") - end if - - ! checking for required fields - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy")) then - FLExit("You need GLSTurbulentKineticEnergy field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity")) then - FLExit("You need GLSGenericSecondQuantity field for GLS") - end if - - ! check that the diffusivity is on for the two turbulent fields and is - ! diagnostic - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/& - &tensor_field::Diffusivity")) then - FLExit("You need GLSTurbulentKineticEnergy Diffusivity field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/& - &tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then - FLExit("You need GLSTurbulentKineticEnergy Diffusivity field set to diagnostic/internal") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/& - &tensor_field::Diffusivity")) then - FLExit("You need GLSGenericSecondQuantity Diffusivity field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/& - &tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then - FLExit("You need GLSGenericSecondQuantity Diffusivity field set to diagnostic/internal") - end if - - - ! source and absorption terms... - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/& - &scalar_field::Source")) then - FLExit("You need GLSTurbulentKineticEnergy Source field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/& - &scalar_field::Source/diagnostic/algorithm::Internal")) then - FLExit("You need GLSTurbulentKineticEnergy Source field set to diagnostic/internal") - end if - - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/& - &scalar_field::Source")) then - FLExit("You need GLSGenericSecondQuantity Source field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/& - &scalar_field::Source/diagnostic/algorithm::Internal")) then - FLExit("You need GLSGenericSecondQuantity Source field set to diagnostic/internal") - end if - - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/& - &scalar_field::Absorption")) then - FLExit("You need GLSTurbulentKineticEnergy Absorption field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/& - &scalar_field::Absorption/diagnostic/algorithm::Internal")) then - FLExit("You need GLSTurbulentKineticEnergy Source field set to diagnostic/internal") - end if - - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/& - &scalar_field::Absorption")) then - FLExit("You need GLSGenericSecondQuantity Absorption field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/& - &scalar_field::Absorption/diagnostic/algorithm::Internal")) then - FLExit("You need GLSGenericSecondQuantity Source field set to diagnostic/internal") - end if - - - ! background diffusivities are also needed - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &tensor_field::GLSBackgroundDiffusivity/prescribed")) then - FLExit("You need GLSBackgroundDiffusivity tensor field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &tensor_field::GLSBackgroundViscosity/prescribed")) then - FLExit("You need GLSBackgroundViscosity tensor field for GLS") - end if - - ! check for some purturbation density and velocity - if (.not.have_option("/material_phase[0]/scalar_field::PerturbationDensity")) then - FLExit("You need PerturbationDensity field for GLS") - end if - if (.not.have_option("/material_phase[0]/vector_field::Velocity")) then - FLExit("You need Velocity field for GLS") - end if - - ! these two fields allow the new diffusivities/viscosities to be used in - ! other calculations - we need them! - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &tensor_field::GLSEddyViscosityKM")) then - FLExit("You need GLSEddyViscosityKM field for GLS") - end if - if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &tensor_field::GLSEddyViscosityKM")) then - FLExit("You need GLSEddyViscosityKM field for GLS") - end if - - - ! check there's a viscosity somewhere - if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/& - &tensor_field::Viscosity/")) then - FLExit("Need viscosity switched on under the Velcotiy field for GLS.") - end if - ! check that the user has switch Velocity/viscosity to diagnostic - if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/& - &tensor_field::Viscosity/diagnostic/")) then - FLExit("You need to switch the viscosity field under Velocity to diagnostic/internal") - end if - - - ! check a minimum value of TKE has been set - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/minimum_value", min_tke, stat) - if (stat/=0) then - FLExit("You need to set a minimum TKE value - recommend a value of around 1e-6") - end if - - ! check if priorities have been set - if so warn the user this might screw - ! things up - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/priority")) then - ewrite(-1,*)("WARNING: Priorities for the GLS fields are set internally. Setting them in the FLML might mess things up") - end if - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSGenericSecondQuantity/prognostic/priority")) then - ewrite(-1,*)("WARNING: Priorities for the GLS fields are set internally. Setting them in the FLML might mess things up") - end if - - ! check the relax option is valid - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/relax_diffusivity")) then - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/relax_diffusivity", relax) - if (relax < 0 .or. relax >= 1.0) then + subroutine gls_adapt_mesh(state) + + type(state_type), intent(inout) :: state + + ewrite(1,*) "In gls_adapt_mesh" + call gls_allocate_temps(state) ! reallocate everything + if (calculate_bcs) then + call gls_init_surfaces(state) ! re-do the boundaries + end if + call gls_init_diagnostics(state) + + end subroutine gls_adapt_mesh + + + subroutine gls_check_options + + character(len=FIELD_NAME_LEN) :: buffer + integer :: stat + real :: min_tke, relax, nbcs + integer :: dimension + + ! Don't do GLS if it's not included in the model! + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/")) return + + ! one dimensional problems not supported + call get_option("/geometry/dimension/", dimension) + if (dimension .eq. 1 .and. have_option("/material_phase[0]/subgridscale_parameterisations/GLS/")) then + FLExit("GLS modelling is only supported for dimension > 1") + end if + + call get_option("/problem_type", buffer) + if (.not. (buffer .eq. "oceans" .or. buffer .eq. "large_scale_ocean_options")) then + FLExit("GLS modelling is only supported for problem type oceans or large_scale_oceans.") + end if + + if (.not.have_option("/physical_parameters/gravity")) then + ewrite(-1, *) "GLS modelling requires gravity" + FLExit("(otherwise buoyancy is a bit meaningless)") + end if + + ! checking for required fields + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy")) then + FLExit("You need GLSTurbulentKineticEnergy field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity")) then + FLExit("You need GLSGenericSecondQuantity field for GLS") + end if + + ! check that the diffusivity is on for the two turbulent fields and is + ! diagnostic + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/& + &tensor_field::Diffusivity")) then + FLExit("You need GLSTurbulentKineticEnergy Diffusivity field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/& + &tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then + FLExit("You need GLSTurbulentKineticEnergy Diffusivity field set to diagnostic/internal") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/& + &tensor_field::Diffusivity")) then + FLExit("You need GLSGenericSecondQuantity Diffusivity field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/& + &tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then + FLExit("You need GLSGenericSecondQuantity Diffusivity field set to diagnostic/internal") + end if + + + ! source and absorption terms... + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/& + &scalar_field::Source")) then + FLExit("You need GLSTurbulentKineticEnergy Source field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/& + &scalar_field::Source/diagnostic/algorithm::Internal")) then + FLExit("You need GLSTurbulentKineticEnergy Source field set to diagnostic/internal") + end if + + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/& + &scalar_field::Source")) then + FLExit("You need GLSGenericSecondQuantity Source field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/& + &scalar_field::Source/diagnostic/algorithm::Internal")) then + FLExit("You need GLSGenericSecondQuantity Source field set to diagnostic/internal") + end if + + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/& + &scalar_field::Absorption")) then + FLExit("You need GLSTurbulentKineticEnergy Absorption field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/& + &scalar_field::Absorption/diagnostic/algorithm::Internal")) then + FLExit("You need GLSTurbulentKineticEnergy Source field set to diagnostic/internal") + end if + + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/& + &scalar_field::Absorption")) then + FLExit("You need GLSGenericSecondQuantity Absorption field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/& + &scalar_field::Absorption/diagnostic/algorithm::Internal")) then + FLExit("You need GLSGenericSecondQuantity Source field set to diagnostic/internal") + end if + + + ! background diffusivities are also needed + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &tensor_field::GLSBackgroundDiffusivity/prescribed")) then + FLExit("You need GLSBackgroundDiffusivity tensor field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &tensor_field::GLSBackgroundViscosity/prescribed")) then + FLExit("You need GLSBackgroundViscosity tensor field for GLS") + end if + + ! check for some purturbation density and velocity + if (.not.have_option("/material_phase[0]/scalar_field::PerturbationDensity")) then + FLExit("You need PerturbationDensity field for GLS") + end if + if (.not.have_option("/material_phase[0]/vector_field::Velocity")) then + FLExit("You need Velocity field for GLS") + end if + + ! these two fields allow the new diffusivities/viscosities to be used in + ! other calculations - we need them! + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &tensor_field::GLSEddyViscosityKM")) then + FLExit("You need GLSEddyViscosityKM field for GLS") + end if + if (.not.have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &tensor_field::GLSEddyViscosityKM")) then + FLExit("You need GLSEddyViscosityKM field for GLS") + end if + + + ! check there's a viscosity somewhere + if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/& + &tensor_field::Viscosity/")) then + FLExit("Need viscosity switched on under the Velcotiy field for GLS.") + end if + ! check that the user has switch Velocity/viscosity to diagnostic + if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/& + &tensor_field::Viscosity/diagnostic/")) then + FLExit("You need to switch the viscosity field under Velocity to diagnostic/internal") + end if + + + ! check a minimum value of TKE has been set + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/minimum_value", min_tke, stat) + if (stat/=0) then + FLExit("You need to set a minimum TKE value - recommend a value of around 1e-6") + end if + + ! check if priorities have been set - if so warn the user this might screw + ! things up + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/priority")) then + ewrite(-1,*)("WARNING: Priorities for the GLS fields are set internally. Setting them in the FLML might mess things up") + end if + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSGenericSecondQuantity/prognostic/priority")) then + ewrite(-1,*)("WARNING: Priorities for the GLS fields are set internally. Setting them in the FLML might mess things up") + end if + + ! check the relax option is valid + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/relax_diffusivity")) then + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/relax_diffusivity", relax) + if (relax < 0 .or. relax >= 1.0) then FLExit("The GLS diffusivity relaxation value should be greater than or equal to zero, but less than 1.0") - end if - if (.not. have_option("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSVerticalViscosity/")) then + end if + if (.not. have_option("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSVerticalViscosity/")) then FLExit("You will need to switch on the GLSVerticalViscosity field when using relaxation") - end if - if (.not. have_option("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSVerticalDiffusivity/")) then + end if + if (.not. have_option("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSVerticalDiffusivity/")) then FLExit("You will need to switch on the GLSVerticalDiffusivity field when using relaxation") - end if - end if + end if + end if - ! Check that the we don't have auto boundaries and user-defined boundaries - if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries")) then - nbcs=option_count(trim("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSTurbulentKineticEnergy/prognostic/boundary_conditions")) - if (nbcs > 0) then + ! Check that the we don't have auto boundaries and user-defined boundaries + if (have_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries")) then + nbcs=option_count(trim("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSTurbulentKineticEnergy/prognostic/boundary_conditions")) + if (nbcs > 0) then FLExit("You have automatic boundary conditions on, but some boundary conditions on the GLS TKE field. Not allowed") - end if - nbcs=option_count(trim("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSGenericSecondQuantity/prognostic/boundary_conditions")) - if (nbcs > 0) then + end if + nbcs=option_count(trim("/material_phase[0]/subgridscale_parameterisations/GLS/scalar_field::GLSGenericSecondQuantity/prognostic/boundary_conditions")) + if (nbcs > 0) then FLExit("You have automatic boundary conditions on, but some boundary conditions on the GLS Psi field. Not allowed") - end if - end if - - ! If the user has selected k-kl we need the ocean surface and bottom fields - ! on in ocean_boundaries - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/option", buffer) - if (trim(buffer) .eq. "k-kl") then - if (.not. have_option("/geometry/ocean_boundaries")) then + end if + end if + + ! If the user has selected k-kl we need the ocean surface and bottom fields + ! on in ocean_boundaries + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/option", buffer) + if (trim(buffer) .eq. "k-kl") then + if (.not. have_option("/geometry/ocean_boundaries")) then FLExit("If you use the k-kl option under GLS, you need to switch on ocean_boundaries under /geometry/ocean_boundaries") - end if - end if + end if + end if - end subroutine gls_check_options + end subroutine gls_check_options !------------------------------------------------------------------! !------------------------------------------------------------------! @@ -1273,281 +1273,281 @@ end subroutine gls_check_options ! Initilise the surface meshes used for the BCS ! Called at startup and after an adapt !---------- -subroutine gls_init_surfaces(state) - type(state_type), intent(in) :: state - - type(scalar_field), pointer :: tke - type(vector_field), pointer :: position - type(mesh_type), pointer :: ocean_mesh - type(mesh_type) :: meshy - - ewrite(1,*) "Initialising the GLS surfaces required for BCs" - - ! grab hold of some essential field - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - position => extract_vector_field(state, "Coordinate") - - ! create a surface mesh to place values onto. This is for the top surface - call get_boundary_condition(tke, 'tke_top_boundary', surface_mesh=ocean_mesh, & - surface_element_list=top_surface_element_list) - NNodes_sur = node_count(ocean_mesh) - call allocate(top_surface_values, ocean_mesh, name="top_surface") - call allocate(top_surface_tke_values,ocean_mesh, name="surface_tke") - call allocate(top_surface_km_values,ocean_mesh, name="surface_km") - ! Creating a surface mesh gives a mapping between to global node number - call create_surface_mesh(meshy, top_surface_nodes, tke%mesh, & - top_surface_element_list, 'OceanTop') - call deallocate(meshy) - - ! bottom - call get_boundary_condition(tke, 'tke_bottom_boundary', surface_mesh=ocean_mesh, & - surface_element_list=bottom_surface_element_list) - NNodes_bot = node_count(ocean_mesh) - call allocate(bottom_surface_values, ocean_mesh, name="bottom_surface") - call allocate(bottom_surface_tke_values,ocean_mesh, name="bottom_tke") - call allocate(bottom_surface_km_values,ocean_mesh, name="bottom_km") - call create_surface_mesh(meshy, bottom_surface_nodes, tke%mesh, & - bottom_surface_element_list, 'OceanBottom') - call deallocate(meshy) - -end subroutine gls_init_surfaces + subroutine gls_init_surfaces(state) + type(state_type), intent(in) :: state + + type(scalar_field), pointer :: tke + type(vector_field), pointer :: position + type(mesh_type), pointer :: ocean_mesh + type(mesh_type) :: meshy + + ewrite(1,*) "Initialising the GLS surfaces required for BCs" + + ! grab hold of some essential field + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + position => extract_vector_field(state, "Coordinate") + + ! create a surface mesh to place values onto. This is for the top surface + call get_boundary_condition(tke, 'tke_top_boundary', surface_mesh=ocean_mesh, & + surface_element_list=top_surface_element_list) + NNodes_sur = node_count(ocean_mesh) + call allocate(top_surface_values, ocean_mesh, name="top_surface") + call allocate(top_surface_tke_values,ocean_mesh, name="surface_tke") + call allocate(top_surface_km_values,ocean_mesh, name="surface_km") + ! Creating a surface mesh gives a mapping between to global node number + call create_surface_mesh(meshy, top_surface_nodes, tke%mesh, & + top_surface_element_list, 'OceanTop') + call deallocate(meshy) + + ! bottom + call get_boundary_condition(tke, 'tke_bottom_boundary', surface_mesh=ocean_mesh, & + surface_element_list=bottom_surface_element_list) + NNodes_bot = node_count(ocean_mesh) + call allocate(bottom_surface_values, ocean_mesh, name="bottom_surface") + call allocate(bottom_surface_tke_values,ocean_mesh, name="bottom_tke") + call allocate(bottom_surface_km_values,ocean_mesh, name="bottom_km") + call create_surface_mesh(meshy, bottom_surface_nodes, tke%mesh, & + bottom_surface_element_list, 'OceanBottom') + call deallocate(meshy) + + end subroutine gls_init_surfaces !---------------------- ! Initialise the diagnostic fields, such as diffusivity, length ! scale, etc. This is called during initialisation and after an ! adapt !---------------------- -subroutine gls_init_diagnostics(state) - type(state_type), intent(inout) :: state + subroutine gls_init_diagnostics(state) + type(state_type), intent(inout) :: state - type(scalar_field), pointer :: tke + type(scalar_field), pointer :: tke - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - ! put tke onto surface fields if we need to - if (calculate_bcs) then - call remap_field_to_surface(tke, top_surface_tke_values, top_surface_element_list) - call remap_field_to_surface(tke, bottom_surface_tke_values, bottom_surface_element_list) - end if + ! put tke onto surface fields if we need to + if (calculate_bcs) then + call remap_field_to_surface(tke, top_surface_tke_values, top_surface_element_list) + call remap_field_to_surface(tke, bottom_surface_tke_values, bottom_surface_element_list) + end if - call set(tke_old,tke) - call set(FWall,1.0) + call set(tke_old,tke) + call set(FWall,1.0) - ! bit complicated here - we need to repopulate the fields internal to this - ! module, post adapt or at initialisation. We need the diffusivity for the first iteration to - ! calculate the TKE src/abs terms, but for diffusivity, we need stability - ! functions, for those we need epsilon, which is calculated in the - ! diffusivity subroutine, but first we need the buoyancy freq. - ! So, working backwards... - call gls_buoyancy(state) ! buoyancy for epsilon calculation - call gls_diffusivity(state) ! gets us epsilon, but K_H and K_M are wrong - call gls_stability_function(state) ! requires espilon, but sets S_H and S_M - call gls_diffusivity(state) ! sets K_H, K_M to correct values - ! and this one sets up the diagnostic fields for output - call gls_output_fields(state) + ! bit complicated here - we need to repopulate the fields internal to this + ! module, post adapt or at initialisation. We need the diffusivity for the first iteration to + ! calculate the TKE src/abs terms, but for diffusivity, we need stability + ! functions, for those we need epsilon, which is calculated in the + ! diffusivity subroutine, but first we need the buoyancy freq. + ! So, working backwards... + call gls_buoyancy(state) ! buoyancy for epsilon calculation + call gls_diffusivity(state) ! gets us epsilon, but K_H and K_M are wrong + call gls_stability_function(state) ! requires espilon, but sets S_H and S_M + call gls_diffusivity(state) ! sets K_H, K_M to correct values + ! and this one sets up the diagnostic fields for output + call gls_output_fields(state) -end subroutine gls_init_diagnostics + end subroutine gls_init_diagnostics !---------- ! Calculate the buoyancy frequency and shear velocities !---------- -subroutine gls_buoyancy(state) - - type(state_type), intent(inout) :: state - - type(scalar_field), pointer :: pert_rho - type(vector_field), pointer :: positions, gravity - type(vector_field), pointer :: velocity - type(scalar_field) :: NU, NV, MM2_av, NN2_av, inverse_lumpedmass - type(scalar_field), pointer :: lumpedmass - real :: g - logical :: on_sphere, smooth_buoyancy, smooth_shear - integer :: ele, i, dim - type(csr_matrix), pointer :: mass - - ! grab variables required from state - already checked in init, so no need to check here - positions => extract_vector_field(state, "Coordinate") - velocity => extract_vector_field(state, "Velocity") - pert_rho => extract_scalar_field(state, "PerturbationDensity") - gravity => extract_vector_field(state, "GravityDirection") - - ! now allocate our temp fields - call allocate(NU, velocity%mesh, "NU") - call allocate(NV, velocity%mesh, "NV") - call set(NU, extract_scalar_field(velocity, 1)) - call set(NV, extract_scalar_field(velocity, 2)) - - call get_option("/physical_parameters/gravity/magnitude", g) - on_sphere = have_option('/geometry/spherical_earth/') - smooth_buoyancy = have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_buoyancy/') - smooth_shear = have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_shear/') - dim = mesh_dim(NN2) - - call zero(NN2) - call zero(MM2) - element_loop: do ele=1, element_count(velocity) - call assemble_elements(ele,MM2,NN2,velocity,pert_rho,NU,NV,on_sphere,dim) - end do element_loop - - ! Solve - lumpedmass => get_lumped_mass(state, NN2%mesh) - NN2%val = NN2%val / lumpedmass%val - lumpedmass => get_lumped_mass(state, MM2%mesh) - MM2%val = MM2%val / lumpedmass%val - - if (smooth_shear) then - call allocate(MM2_av, MM2%mesh, "MM2_averaged") - call allocate(inverse_lumpedmass, MM2%mesh, "InverseLumpedMass") - mass => get_mass_matrix(state, MM2%mesh) - lumpedmass => get_lumped_mass(state, MM2%mesh) - call invert(lumpedmass, inverse_lumpedmass) - call mult( MM2_av, mass, MM2) - call scale(MM2_av, inverse_lumpedmass) ! so the averaging operator is [inv(ML)*M*] - call set(MM2, MM2_av) - call deallocate(inverse_lumpedmass) - call deallocate(MM2_av) - end if - - if (smooth_buoyancy) then - call allocate(NN2_av, NN2%mesh, "NN2_averaged") - call allocate(inverse_lumpedmass, NN2%mesh, "InverseLumpedMass") - mass => get_mass_matrix(state, NN2%mesh) - lumpedmass => get_lumped_mass(state, NN2%mesh) - call invert(lumpedmass, inverse_lumpedmass) - call mult( NN2_av, mass, NN2) - call scale(NN2_av, inverse_lumpedmass) ! so the averaging operator is [inv(ML)*M*] - call set(NN2, NN2_av) - call deallocate(NN2_av) - call deallocate(inverse_lumpedmass) - end if - - call deallocate(NU) - call deallocate(NV) - - contains - subroutine assemble_elements(ele,MM2,NN2,velocity,rho,NU,NV,on_sphere,dim) - - type(vector_field), intent(in), pointer :: velocity - type(scalar_field), intent(in) :: rho - type(scalar_field), intent(inout) :: NN2, MM2 - type(scalar_field), intent(in) :: NU, NV - logical, intent(in) :: on_sphere - integer, intent(in) :: ele, dim - - type(element_type), pointer :: NN2_shape, MM2_shape - real, dimension(ele_ngi(velocity,ele)) :: detwei, shear, drho_dz - real, dimension(dim, ele_ngi(velocity,ele)) :: grad_theta_gi, du_dz - real, dimension(dim,ele_ngi(velocity,ele)) :: grav_at_quads - type(element_type), pointer :: theta_shape, velocity_shape - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_loc(velocity,ele),ele_ngi(velocity,ele),dim) :: dn_t - real, dimension(ele_loc(rho,ele),ele_ngi(rho,ele),dim) :: dtheta_t - real, dimension(ele_loc(velocity, ele),ele_ngi(velocity, ele),dim):: du_t - - NN2_shape => ele_shape(NN2, ele) - MM2_shape => ele_shape(MM2, ele) - velocity_shape => ele_shape(velocity, ele) - theta_shape => ele_shape(rho, ele) - - call transform_to_physical(positions, ele, NN2_shape, & - & dshape = dn_t, detwei = detwei) - if(NN2_shape == velocity_shape) then - du_t = dn_t - else - call transform_to_physical(positions, ele, velocity_shape, dshape = du_t) - end if - if(theta_shape == velocity_shape) then - dtheta_t = dn_t - else - call transform_to_physical(positions, ele, theta_shape, dshape = dtheta_t) - end if - - if (on_sphere) then - grav_at_quads=radial_inward_normal_at_quad_ele(positions, ele) - else - grav_at_quads=ele_val_at_quad(gravity, ele) - end if - grad_theta_gi=ele_grad_at_quad(rho, ele, dtheta_t) - do i=1,ele_ngi(velocity,ele) - drho_dz(i)=dot_product(grad_theta_gi(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? - end do - grad_theta_gi=ele_grad_at_quad(NU, ele, dtheta_t) - do i=1,ele_ngi(velocity,ele) - du_dz(1,i)=dot_product(grad_theta_gi(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? - end do - grad_theta_gi=ele_grad_at_quad(NV, ele, dtheta_t) - do i=1,ele_ngi(velocity,ele) - du_dz(2,i)=dot_product(grad_theta_gi(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? - end do - shear = 0.0 - do i = 1, dim - 1 - shear = shear + du_dz(i,:) ** 2 - end do - - element_nodes => ele_nodes(NN2, ele) - - call addto(NN2, element_nodes, & - ! already in the right direction due to multipling by grav_at_quads - & shape_rhs(NN2_shape, detwei * g * drho_dz) & - & ) - - call addto(MM2, element_nodes, & - & shape_rhs(MM2_shape,detwei * shear) & - & ) - - end subroutine assemble_elements -end subroutine gls_buoyancy + subroutine gls_buoyancy(state) + + type(state_type), intent(inout) :: state + + type(scalar_field), pointer :: pert_rho + type(vector_field), pointer :: positions, gravity + type(vector_field), pointer :: velocity + type(scalar_field) :: NU, NV, MM2_av, NN2_av, inverse_lumpedmass + type(scalar_field), pointer :: lumpedmass + real :: g + logical :: on_sphere, smooth_buoyancy, smooth_shear + integer :: ele, i, dim + type(csr_matrix), pointer :: mass + + ! grab variables required from state - already checked in init, so no need to check here + positions => extract_vector_field(state, "Coordinate") + velocity => extract_vector_field(state, "Velocity") + pert_rho => extract_scalar_field(state, "PerturbationDensity") + gravity => extract_vector_field(state, "GravityDirection") + + ! now allocate our temp fields + call allocate(NU, velocity%mesh, "NU") + call allocate(NV, velocity%mesh, "NV") + call set(NU, extract_scalar_field(velocity, 1)) + call set(NV, extract_scalar_field(velocity, 2)) + + call get_option("/physical_parameters/gravity/magnitude", g) + on_sphere = have_option('/geometry/spherical_earth/') + smooth_buoyancy = have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_buoyancy/') + smooth_shear = have_option('/material_phase[0]/subgridscale_parameterisations/GLS/smooth_shear/') + dim = mesh_dim(NN2) + + call zero(NN2) + call zero(MM2) + element_loop: do ele=1, element_count(velocity) + call assemble_elements(ele,MM2,NN2,velocity,pert_rho,NU,NV,on_sphere,dim) + end do element_loop + + ! Solve + lumpedmass => get_lumped_mass(state, NN2%mesh) + NN2%val = NN2%val / lumpedmass%val + lumpedmass => get_lumped_mass(state, MM2%mesh) + MM2%val = MM2%val / lumpedmass%val + + if (smooth_shear) then + call allocate(MM2_av, MM2%mesh, "MM2_averaged") + call allocate(inverse_lumpedmass, MM2%mesh, "InverseLumpedMass") + mass => get_mass_matrix(state, MM2%mesh) + lumpedmass => get_lumped_mass(state, MM2%mesh) + call invert(lumpedmass, inverse_lumpedmass) + call mult( MM2_av, mass, MM2) + call scale(MM2_av, inverse_lumpedmass) ! so the averaging operator is [inv(ML)*M*] + call set(MM2, MM2_av) + call deallocate(inverse_lumpedmass) + call deallocate(MM2_av) + end if + + if (smooth_buoyancy) then + call allocate(NN2_av, NN2%mesh, "NN2_averaged") + call allocate(inverse_lumpedmass, NN2%mesh, "InverseLumpedMass") + mass => get_mass_matrix(state, NN2%mesh) + lumpedmass => get_lumped_mass(state, NN2%mesh) + call invert(lumpedmass, inverse_lumpedmass) + call mult( NN2_av, mass, NN2) + call scale(NN2_av, inverse_lumpedmass) ! so the averaging operator is [inv(ML)*M*] + call set(NN2, NN2_av) + call deallocate(NN2_av) + call deallocate(inverse_lumpedmass) + end if + + call deallocate(NU) + call deallocate(NV) + + contains + subroutine assemble_elements(ele,MM2,NN2,velocity,rho,NU,NV,on_sphere,dim) + + type(vector_field), intent(in), pointer :: velocity + type(scalar_field), intent(in) :: rho + type(scalar_field), intent(inout) :: NN2, MM2 + type(scalar_field), intent(in) :: NU, NV + logical, intent(in) :: on_sphere + integer, intent(in) :: ele, dim + + type(element_type), pointer :: NN2_shape, MM2_shape + real, dimension(ele_ngi(velocity,ele)) :: detwei, shear, drho_dz + real, dimension(dim, ele_ngi(velocity,ele)) :: grad_theta_gi, du_dz + real, dimension(dim,ele_ngi(velocity,ele)) :: grav_at_quads + type(element_type), pointer :: theta_shape, velocity_shape + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_loc(velocity,ele),ele_ngi(velocity,ele),dim) :: dn_t + real, dimension(ele_loc(rho,ele),ele_ngi(rho,ele),dim) :: dtheta_t + real, dimension(ele_loc(velocity, ele),ele_ngi(velocity, ele),dim):: du_t + + NN2_shape => ele_shape(NN2, ele) + MM2_shape => ele_shape(MM2, ele) + velocity_shape => ele_shape(velocity, ele) + theta_shape => ele_shape(rho, ele) + + call transform_to_physical(positions, ele, NN2_shape, & + & dshape = dn_t, detwei = detwei) + if(NN2_shape == velocity_shape) then + du_t = dn_t + else + call transform_to_physical(positions, ele, velocity_shape, dshape = du_t) + end if + if(theta_shape == velocity_shape) then + dtheta_t = dn_t + else + call transform_to_physical(positions, ele, theta_shape, dshape = dtheta_t) + end if + + if (on_sphere) then + grav_at_quads=radial_inward_normal_at_quad_ele(positions, ele) + else + grav_at_quads=ele_val_at_quad(gravity, ele) + end if + grad_theta_gi=ele_grad_at_quad(rho, ele, dtheta_t) + do i=1,ele_ngi(velocity,ele) + drho_dz(i)=dot_product(grad_theta_gi(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? + end do + grad_theta_gi=ele_grad_at_quad(NU, ele, dtheta_t) + do i=1,ele_ngi(velocity,ele) + du_dz(1,i)=dot_product(grad_theta_gi(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? + end do + grad_theta_gi=ele_grad_at_quad(NV, ele, dtheta_t) + do i=1,ele_ngi(velocity,ele) + du_dz(2,i)=dot_product(grad_theta_gi(:,i),grav_at_quads(:,i)) ! Divide this by rho_0 for non-Boussinesq? + end do + shear = 0.0 + do i = 1, dim - 1 + shear = shear + du_dz(i,:) ** 2 + end do + + element_nodes => ele_nodes(NN2, ele) + + call addto(NN2, element_nodes, & + ! already in the right direction due to multipling by grav_at_quads + & shape_rhs(NN2_shape, detwei * g * drho_dz) & + & ) + + call addto(MM2, element_nodes, & + & shape_rhs(MM2_shape,detwei * shear) & + & ) + + end subroutine assemble_elements + end subroutine gls_buoyancy !---------- ! Stability function based on Caunto et al 2001 !---------- -subroutine gls_stability_function(state) - - type(state_type), intent(in) :: state - - integer :: i - real :: N,Nt,an,anMin,anMinNum,anMinDen - real, parameter :: anLimitFact = 0.5 - real :: d0,d1,d2,d3,d4,d5 - real :: n0,n1,n2,nt0,nt1,nt2 - real :: dCm,nCm,nCmp,cm3_inv - real :: tmp0,tmp1,tmp2,tau2,as - type(scalar_field), pointer :: KK - - ewrite(1,*) "Calculating GLS stability functions" - - ! grab stuff from state - KK => extract_scalar_field(state, 'GLSTurbulentKineticEnergy') - - ! This is written out verbatim as in GOTM v4.3.1 (also GNU GPL) - N = 0.5*cc1 - Nt = ct1 - d0 = 36.* N**3. * Nt**2. - d1 = 84.*a5*at3 * N**2. * Nt + 36.*at5 * N**3. * Nt - d2 = 9.*(at2**2.-at1**2.) * N**3. - 12.*(a2**2.-3.*a3**2.) * N * Nt**2. - d3 = 12.*a5*at3*(a2*at1-3.*a3*at2) * N + 12.*a5*at3*(a3**2.-a2**2.) * Nt & - + 12.*at5*(3.*a3**2.-a2**2.) * N * Nt - d4 = 48.*a5**2.*at3**2. * N + 36.*a5*at3*at5 * N**2. - d5 = 3.*(a2**2.-3.*a3**2.)*(at1**2.-at2**2.) * N - n0 = 36.*a1 * N**2. * Nt**2. - n1 = - 12.*a5*at3*(at1+at2) * N**2. + 8.*a5*at3*(6.*a1-a2-3.*a3) * N * Nt & - + 36.*a1*at5 * N**2. * Nt - n2 = 9.*a1*(at2**2.-at1**2.) * N**2. - nt0 = 12.*at3 * N**3. * Nt - nt1 = 12.*a5*at3**2. * N**2. - nt2 = 9.*a1*at3*(at1-at2) * N**2. + ( 6.*a1*(a2-3.*a3) & - - 4.*(a2**2.-3.*a3**2.) )*at3 * N * Nt - cm3_inv = 1./cm0**3 - - - ! mininum value of "an" to insure that "as" > 0 in equilibrium - anMinNum = -(d1 + nt0) + sqrt((d1+nt0)**2. - 4.*d0*(d4+nt1)) - anMinDen = 2.*(d4+nt1) - anMin = anMinNum / anMinDen - - if (abs(n2-d5) .lt. 1e-7) then - ! (special treatment to avoid a singularity) - do i=1,nNodes + subroutine gls_stability_function(state) + + type(state_type), intent(in) :: state + + integer :: i + real :: N,Nt,an,anMin,anMinNum,anMinDen + real, parameter :: anLimitFact = 0.5 + real :: d0,d1,d2,d3,d4,d5 + real :: n0,n1,n2,nt0,nt1,nt2 + real :: dCm,nCm,nCmp,cm3_inv + real :: tmp0,tmp1,tmp2,tau2,as + type(scalar_field), pointer :: KK + + ewrite(1,*) "Calculating GLS stability functions" + + ! grab stuff from state + KK => extract_scalar_field(state, 'GLSTurbulentKineticEnergy') + + ! This is written out verbatim as in GOTM v4.3.1 (also GNU GPL) + N = 0.5*cc1 + Nt = ct1 + d0 = 36.* N**3. * Nt**2. + d1 = 84.*a5*at3 * N**2. * Nt + 36.*at5 * N**3. * Nt + d2 = 9.*(at2**2.-at1**2.) * N**3. - 12.*(a2**2.-3.*a3**2.) * N * Nt**2. + d3 = 12.*a5*at3*(a2*at1-3.*a3*at2) * N + 12.*a5*at3*(a3**2.-a2**2.) * Nt & + + 12.*at5*(3.*a3**2.-a2**2.) * N * Nt + d4 = 48.*a5**2.*at3**2. * N + 36.*a5*at3*at5 * N**2. + d5 = 3.*(a2**2.-3.*a3**2.)*(at1**2.-at2**2.) * N + n0 = 36.*a1 * N**2. * Nt**2. + n1 = - 12.*a5*at3*(at1+at2) * N**2. + 8.*a5*at3*(6.*a1-a2-3.*a3) * N * Nt & + + 36.*a1*at5 * N**2. * Nt + n2 = 9.*a1*(at2**2.-at1**2.) * N**2. + nt0 = 12.*at3 * N**3. * Nt + nt1 = 12.*a5*at3**2. * N**2. + nt2 = 9.*a1*at3*(at1-at2) * N**2. + ( 6.*a1*(a2-3.*a3) & + - 4.*(a2**2.-3.*a3**2.) )*at3 * N * Nt + cm3_inv = 1./cm0**3 + + + ! mininum value of "an" to insure that "as" > 0 in equilibrium + anMinNum = -(d1 + nt0) + sqrt((d1+nt0)**2. - 4.*d0*(d4+nt1)) + anMinDen = 2.*(d4+nt1) + anMin = anMinNum / anMinDen + + if (abs(n2-d5) .lt. 1e-7) then + ! (special treatment to avoid a singularity) + do i=1,nNodes tau2 = node_val(KK,i)*node_val(KK,i) / ( node_val(eps,i)*node_val(eps,i) ) an = tau2 * node_val(NN2,i) ! clip an at minimum value @@ -1565,10 +1565,10 @@ subroutine gls_stability_function(state) call set(S_M,i, cm3_inv*nCm /dCm) call set(S_H,i, cm3_inv*nCmp/dCm) - end do + end do - else - do i=1,nNodes + else + do i=1,nNodes tau2 = node_val(KK,i)*node_val(KK,i) / ( node_val(eps,i)*node_val(eps,i) ) an = tau2 * node_val(NN2,i) @@ -1587,401 +1587,401 @@ subroutine gls_stability_function(state) nCmp = nt0 + nt1*an + nt2*as call set(S_M,i, cm3_inv*nCm /dCm) call set(S_H,i, cm3_inv*nCmp/dCm) - end do + end do - endif + endif -end subroutine gls_stability_function + end subroutine gls_stability_function !---------- ! gls_tke_bc calculates the boundary conditions on the TKE (tke) field ! Boundary can be either Dirichlet or Neumann. !---------- -subroutine gls_tke_bc(state, bc_type) - - type(state_type), intent(in) :: state - character(len=*), intent(in) :: bc_type - - type(vector_field), pointer :: positions - real :: gravity_magnitude - integer :: i - real, allocatable, dimension(:) :: z0s, z0b, u_taus_squared, u_taub_squared - - ! grab hold of some essential field - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - positions => extract_vector_field(state, "Coordinate") - - ! Top boundary condition - select case(bc_type) - case("neumann") - ! Top TKE flux BC - call set(top_surface_values,0.0) - call set(bottom_surface_values,0.0) - case("dirichlet") - allocate(z0s(NNodes_sur)) - allocate(z0b(NNodes_bot)) - allocate(u_taus_squared(NNodes_sur)) - allocate(u_taub_squared(NNodes_bot)) - call gls_friction(state,z0s,z0b,gravity_magnitude,u_taus_squared,u_taub_squared) - - ! Top TKE value set - do i=1,NNodes_sur + subroutine gls_tke_bc(state, bc_type) + + type(state_type), intent(in) :: state + character(len=*), intent(in) :: bc_type + + type(vector_field), pointer :: positions + real :: gravity_magnitude + integer :: i + real, allocatable, dimension(:) :: z0s, z0b, u_taus_squared, u_taub_squared + + ! grab hold of some essential field + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + positions => extract_vector_field(state, "Coordinate") + + ! Top boundary condition + select case(bc_type) + case("neumann") + ! Top TKE flux BC + call set(top_surface_values,0.0) + call set(bottom_surface_values,0.0) + case("dirichlet") + allocate(z0s(NNodes_sur)) + allocate(z0b(NNodes_bot)) + allocate(u_taus_squared(NNodes_sur)) + allocate(u_taub_squared(NNodes_bot)) + call gls_friction(state,z0s,z0b,gravity_magnitude,u_taus_squared,u_taub_squared) + + ! Top TKE value set + do i=1,NNodes_sur call set(top_surface_values,i,max(u_taus_squared(i)/(cm0**2),k_min)) - end do - do i=1,NNodes_bot + end do + do i=1,NNodes_bot call set(bottom_surface_values,i,max(u_taub_squared(i)/(cm0**2),k_min)) - end do - deallocate(z0s) - deallocate(z0b) - deallocate(u_taus_squared) - deallocate(u_taub_squared) - case default - FLAbort('Unknown BC for TKE') - end select + end do + deallocate(z0s) + deallocate(z0b) + deallocate(u_taus_squared) + deallocate(u_taub_squared) + case default + FLAbort('Unknown BC for TKE') + end select -end subroutine gls_tke_bc + end subroutine gls_tke_bc !---------- ! gls_psi_bc calculates the boundary conditions on the Psi (psi) field ! Boundary can be either Dirichlet or Neumann. !---------- -subroutine gls_psi_bc(state, bc_type) - - type(state_type), intent(in) :: state - character(len=*), intent(in) :: bc_type - - type(vector_field), pointer :: positions - real :: gravity_magnitude - integer :: i - real, allocatable, dimension(:) :: z0s, z0b, u_taus_squared, u_taub_squared - type(scalar_field), pointer :: tke, psi - real :: value - - - ewrite(2,*) "In gls_psi_bc: setting up" - ! grab hold of some essential fields - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - positions => extract_vector_field(state, "Coordinate") - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - psi => extract_scalar_field(state, "GLSGenericSecondQuantity") - - allocate(z0s(NNodes_sur)) - allocate(z0b(NNodes_bot)) - allocate(u_taus_squared(NNodes_sur)) - allocate(u_taub_squared(NNodes_bot)) - - ewrite(2,*) "In gls_psi_bc: friction" - ! get friction - call gls_friction(state,z0s,z0b,gravity_magnitude,u_taus_squared,u_taub_squared) - - ! put tke onto surface fields - call remap_field_to_surface(tke, top_surface_tke_values, top_surface_element_list) - call remap_field_to_surface(tke, bottom_surface_tke_values, bottom_surface_element_list) - - ewrite(2,*) "In gls_psi_bc: setting values" - select case(bc_type) - case("neumann") - do i=1,NNodes_sur + subroutine gls_psi_bc(state, bc_type) + + type(state_type), intent(in) :: state + character(len=*), intent(in) :: bc_type + + type(vector_field), pointer :: positions + real :: gravity_magnitude + integer :: i + real, allocatable, dimension(:) :: z0s, z0b, u_taus_squared, u_taub_squared + type(scalar_field), pointer :: tke, psi + real :: value + + + ewrite(2,*) "In gls_psi_bc: setting up" + ! grab hold of some essential fields + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + positions => extract_vector_field(state, "Coordinate") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + psi => extract_scalar_field(state, "GLSGenericSecondQuantity") + + allocate(z0s(NNodes_sur)) + allocate(z0b(NNodes_bot)) + allocate(u_taus_squared(NNodes_sur)) + allocate(u_taub_squared(NNodes_bot)) + + ewrite(2,*) "In gls_psi_bc: friction" + ! get friction + call gls_friction(state,z0s,z0b,gravity_magnitude,u_taus_squared,u_taub_squared) + + ! put tke onto surface fields + call remap_field_to_surface(tke, top_surface_tke_values, top_surface_element_list) + call remap_field_to_surface(tke, bottom_surface_tke_values, bottom_surface_element_list) + + ewrite(2,*) "In gls_psi_bc: setting values" + select case(bc_type) + case("neumann") + do i=1,NNodes_sur ! GOTM Boundary value = -(gls_n*(cm0**(gls_p+1.))*(kappa**(gls_n+1.)))/sigma_psi & - *node_val(top_surface_tke_values,i)**(gls_m+0.5)*(z0s(i))**gls_n + *node_val(top_surface_tke_values,i)**(gls_m+0.5)*(z0s(i))**gls_n ! Warner 2005 - left here for posterity and debugging !value = -gls_n*(cm0**(gls_p))*(node_val(top_surface_tke_values,i)**gls_m)* & ! (kappa**gls_n)*(z0s(i)**(gls_n-1))*((node_val(top_surface_km_values,i)/sigma_psi)) call set(top_surface_values,i,value) - end do - do i=1,NNodes_bot + end do + do i=1,NNodes_bot if (u_taub_squared(i) < 1e-16) then - value = 0.0 + value = 0.0 else - ! GOTM Boundary - value = - gls_n*cm0**(gls_p+1.)*(kappa**(gls_n+1.)/sigma_psi) & - *node_val(bottom_surface_tke_values,i)**(gls_m+0.5)*(z0b(i))**gls_n - ! Warner 2005 - as above - !value = gls_n*cm0**(gls_p)*node_val(bottom_surface_tke_values,i)**(gls_m)* & - ! kappa**gls_n*(z0b(i)**(gls_n-1))*(node_val(bottom_surface_km_values,i)/sigma_psi) + ! GOTM Boundary + value = - gls_n*cm0**(gls_p+1.)*(kappa**(gls_n+1.)/sigma_psi) & + *node_val(bottom_surface_tke_values,i)**(gls_m+0.5)*(z0b(i))**gls_n + ! Warner 2005 - as above + !value = gls_n*cm0**(gls_p)*node_val(bottom_surface_tke_values,i)**(gls_m)* & + ! kappa**gls_n*(z0b(i)**(gls_n-1))*(node_val(bottom_surface_km_values,i)/sigma_psi) end if call set(bottom_surface_values,i,value) - end do - case("dirichlet") - do i=1,NNodes_sur + end do + case("dirichlet") + do i=1,NNodes_sur value = max(cm0**(gls_p-2.*gls_m)*kappa**gls_n*u_taus_squared(i)**gls_m * & - (z0s(i))**gls_n,psi_min) + (z0s(i))**gls_n,psi_min) call set(top_surface_values,i,value) - end do - do i=1,NNodes_bot + end do + do i=1,NNodes_bot value = max(cm0**(gls_p-2.*gls_m)*kappa**gls_n*u_taub_squared(i)**gls_m * & - (z0b(i))**gls_n,psi_min) + (z0b(i))**gls_n,psi_min) call set(bottom_surface_values,i,value) - end do - case default - FLAbort('Unknown boundary type for Psi') - end select + end do + case default + FLAbort('Unknown boundary type for Psi') + end select - deallocate(z0s) - deallocate(z0b) - deallocate(u_taus_squared) - deallocate(u_taub_squared) + deallocate(z0s) + deallocate(z0b) + deallocate(u_taus_squared) + deallocate(u_taub_squared) -end subroutine gls_psi_bc + end subroutine gls_psi_bc !---------- ! gls_frction works out the depth of the friction layer ! either due to bottom topography roughness or the shear stress ! on the surface !--------- -subroutine gls_friction(state,z0s,z0b,gravity_magnitude,u_taus_squared,u_taub_squared) - - type(state_type), intent(in) :: state - real, intent(in) :: gravity_magnitude - real, dimension(:), intent(inout) :: z0s,z0b,u_taus_squared,u_taub_squared - - integer :: nobcs - integer :: i,ii, MaxIter - real :: rr - real :: charnock_val=18500. - character(len=OPTION_PATH_LEN) :: bctype - type(vector_field), pointer :: wind_surface_field, positions, velocity - type(scalar_field), pointer :: tke - type(vector_field) :: bottom_velocity, surface_forcing, cont_vel, surface_pos - type(mesh_type) :: ocean_mesh - real :: u_taub, z0s_min - real, dimension(1) :: temp_vector_1D ! Obviously, not really a vector, but lets keep the names consistant - real, dimension(2) :: temp_vector_2D - real, dimension(3) :: temp_vector_3D - logical :: surface_allocated - - MaxIter = 10 - z0s_min = 0.003 - surface_allocated = .false. - - ! get meshes - velocity => extract_vector_field(state, "Velocity") - positions => extract_vector_field(state, "Coordinate") - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") - wind_surface_field => null() - - ! grab stresses from velocity field - Surface - nobcs = get_boundary_condition_count(velocity) - do i=1, nobcs - call get_boundary_condition(velocity, i, type=bctype) - if (bctype=='wind_forcing') then + subroutine gls_friction(state,z0s,z0b,gravity_magnitude,u_taus_squared,u_taub_squared) + + type(state_type), intent(in) :: state + real, intent(in) :: gravity_magnitude + real, dimension(:), intent(inout) :: z0s,z0b,u_taus_squared,u_taub_squared + + integer :: nobcs + integer :: i,ii, MaxIter + real :: rr + real :: charnock_val=18500. + character(len=OPTION_PATH_LEN) :: bctype + type(vector_field), pointer :: wind_surface_field, positions, velocity + type(scalar_field), pointer :: tke + type(vector_field) :: bottom_velocity, surface_forcing, cont_vel, surface_pos + type(mesh_type) :: ocean_mesh + real :: u_taub, z0s_min + real, dimension(1) :: temp_vector_1D ! Obviously, not really a vector, but lets keep the names consistant + real, dimension(2) :: temp_vector_2D + real, dimension(3) :: temp_vector_3D + logical :: surface_allocated + + MaxIter = 10 + z0s_min = 0.003 + surface_allocated = .false. + + ! get meshes + velocity => extract_vector_field(state, "Velocity") + positions => extract_vector_field(state, "Coordinate") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy") + wind_surface_field => null() + + ! grab stresses from velocity field - Surface + nobcs = get_boundary_condition_count(velocity) + do i=1, nobcs + call get_boundary_condition(velocity, i, type=bctype) + if (bctype=='wind_forcing') then wind_surface_field => extract_surface_field(velocity, i, "WindSurfaceField") call create_surface_mesh(ocean_mesh, top_surface_nodes, tke%mesh, & - top_surface_element_list, 'OceanTop') + top_surface_element_list, 'OceanTop') call allocate(surface_forcing, wind_surface_field%dim, ocean_mesh, name="surface_velocity") surface_pos = get_coordinates_remapped_to_surface(positions, ocean_mesh, top_surface_element_list) call deallocate(ocean_mesh) if (tke%mesh%continuity == velocity%mesh%continuity) then - call set(surface_forcing,wind_surface_field) + call set(surface_forcing,wind_surface_field) else - ! remap onto same mesh as TKE - call project_field(wind_surface_field, surface_forcing, surface_pos) + ! remap onto same mesh as TKE + call project_field(wind_surface_field, surface_forcing, surface_pos) end if surface_allocated = .true. call deallocate(surface_pos) exit - end if - end do - - ! sort out bottom surface velocity - call create_surface_mesh(ocean_mesh, bottom_surface_nodes, tke%mesh, & - bottom_surface_element_list, 'OceanBottom') - call allocate(bottom_velocity, velocity%dim, ocean_mesh, name="bottom_velocity") - call allocate(cont_vel, velocity%dim, tke%mesh, name="ContVel") - call deallocate(ocean_mesh) - ! Do we need to project or copy? - if (velocity%mesh%continuity == tke%mesh%continuity) then - call set(cont_vel,velocity) - else - ! remap onto same mesh as TKE - call project_field(velocity, cont_vel, positions) - end if - - call remap_field_to_surface(cont_vel, bottom_velocity, & - bottom_surface_element_list) - call deallocate(cont_vel) - ! we now have a bottom velocity surface and a top surface - ! with the wind stress on (note easier to to zero the output array - ! below than set wind_forcing to zero and work through all the calcs - - - ! work out the friction in either 3 or 2 dimensions. - if (positions%dim .eq. 3) then - - if (surface_allocated) then + end if + end do + + ! sort out bottom surface velocity + call create_surface_mesh(ocean_mesh, bottom_surface_nodes, tke%mesh, & + bottom_surface_element_list, 'OceanBottom') + call allocate(bottom_velocity, velocity%dim, ocean_mesh, name="bottom_velocity") + call allocate(cont_vel, velocity%dim, tke%mesh, name="ContVel") + call deallocate(ocean_mesh) + ! Do we need to project or copy? + if (velocity%mesh%continuity == tke%mesh%continuity) then + call set(cont_vel,velocity) + else + ! remap onto same mesh as TKE + call project_field(velocity, cont_vel, positions) + end if + + call remap_field_to_surface(cont_vel, bottom_velocity, & + bottom_surface_element_list) + call deallocate(cont_vel) + ! we now have a bottom velocity surface and a top surface + ! with the wind stress on (note easier to to zero the output array + ! below than set wind_forcing to zero and work through all the calcs + + + ! work out the friction in either 3 or 2 dimensions. + if (positions%dim .eq. 3) then + + if (surface_allocated) then do i=1,NNodes_sur - temp_vector_2D = node_val(surface_forcing,i) - ! big hack! Assumes that the wind stress forcing has ALREADY been divded by ocean density - ! Note that u_taus = sqrt(wind_stress/rho0) - ! we assume here that the wind stress in diamond is already - ! wind_stress/rho0, hence here: - ! u_taus = sqrt(wind_stress) - u_taus_squared(i) = max(1e-12,sqrt(((temp_vector_2D(1))**2+(temp_vector_2D(2))**2))) - ! use the Charnock formula to compute the surface roughness - z0s(i)=charnock_val*u_taus_squared(i)/gravity_magnitude - if (z0s(i).lt.z0s_min) z0s(i)=z0s_min + temp_vector_2D = node_val(surface_forcing,i) + ! big hack! Assumes that the wind stress forcing has ALREADY been divded by ocean density + ! Note that u_taus = sqrt(wind_stress/rho0) + ! we assume here that the wind stress in diamond is already + ! wind_stress/rho0, hence here: + ! u_taus = sqrt(wind_stress) + u_taus_squared(i) = max(1e-12,sqrt(((temp_vector_2D(1))**2+(temp_vector_2D(2))**2))) + ! use the Charnock formula to compute the surface roughness + z0s(i)=charnock_val*u_taus_squared(i)/gravity_magnitude + if (z0s(i).lt.z0s_min) z0s(i)=z0s_min end do - else + else z0s = z0s_min u_taus_squared = 0.0 - end if + end if - do i=1,NNodes_bot + do i=1,NNodes_bot temp_vector_3D = node_val(bottom_velocity,i) u_taub = sqrt(temp_vector_3D(1)**2+temp_vector_3D(2)**2+temp_vector_3D(3)**2) if (u_taub <= 1e-12) then - z0b(i) = z0s_min + z0b(i) = z0s_min else - ! iterate bottom roughness length MaxIter times - do ii=1,MaxIter - z0b(i)=(1e-7/max(1e-6,u_taub)+0.03*0.1) + ! iterate bottom roughness length MaxIter times + do ii=1,MaxIter + z0b(i)=(1e-7/max(1e-6,u_taub)+0.03*0.1) - ! compute the factor r - rr=kappa/log(z0b(i)) + ! compute the factor r + rr=kappa/log(z0b(i)) - ! compute the friction velocity at the bottom - u_taub = rr*sqrt(temp_vector_3D(1)**2+temp_vector_3D(2)**2+temp_vector_3D(3)**2) + ! compute the friction velocity at the bottom + u_taub = rr*sqrt(temp_vector_3D(1)**2+temp_vector_3D(2)**2+temp_vector_3D(3)**2) - end do + end do end if u_taub_squared(i) = u_taub**2 - end do + end do - else if (positions%dim .eq. 2) then - if (surface_allocated) then + else if (positions%dim .eq. 2) then + if (surface_allocated) then do i=1,NNodes_sur - temp_vector_1D = node_val(surface_forcing,i) - u_taus_squared(i) = max(1e-12,abs(temp_vector_1D(1))) - ! use the Charnock formula to compute the surface roughness - z0s(i)=charnock_val*u_taus_squared(i)/gravity_magnitude - if (z0s(i).lt.z0s_min) z0s(i)=z0s_min + temp_vector_1D = node_val(surface_forcing,i) + u_taus_squared(i) = max(1e-12,abs(temp_vector_1D(1))) + ! use the Charnock formula to compute the surface roughness + z0s(i)=charnock_val*u_taus_squared(i)/gravity_magnitude + if (z0s(i).lt.z0s_min) z0s(i)=z0s_min end do - else + else z0s = z0s_min u_taus_squared = 0.0 - end if + end if - do i=1,NNodes_bot + do i=1,NNodes_bot temp_vector_2D = node_val(bottom_velocity,i) u_taub = sqrt(temp_vector_2D(1)**2+temp_vector_2D(2)**2) ! iterate bottom roughness length MaxIter times do ii=1,MaxIter - z0b(i)=(1e-7/(max(1e-6,u_taub)+0.03*0.1)) - rr=kappa/log(z0b(i)) + z0b(i)=(1e-7/(max(1e-6,u_taub)+0.03*0.1)) + rr=kappa/log(z0b(i)) - ! compute the friction velocity at the bottom - u_taub = rr*sqrt((temp_vector_2D(1)**2+temp_vector_2D(2)**2)) + ! compute the friction velocity at the bottom + u_taub = rr*sqrt((temp_vector_2D(1)**2+temp_vector_2D(2)**2)) end do u_taub_squared(i) = u_taub**2 - end do + end do - else - FLAbort("Unsupported dimension in GLS friction") - end if + else + FLAbort("Unsupported dimension in GLS friction") + end if - call deallocate(bottom_velocity) - if (surface_allocated) then - call deallocate(surface_forcing) - end if + call deallocate(bottom_velocity) + if (surface_allocated) then + call deallocate(surface_forcing) + end if - return + return -end subroutine gls_friction + end subroutine gls_friction !--------- ! Output the optional fields if they exist in state !--------- -subroutine gls_output_fields(state) - - type(state_type), intent(in) :: state - - type(scalar_field), pointer :: scalarField - type(tensor_field), pointer :: tensorField - integer :: stat - - scalarField => extract_scalar_field(state, "GLSLengthScale", stat) - if(stat == 0) then - call set(scalarField,ll) - end if - - scalarField => extract_scalar_field(state,"GLSTurbulentKineticEnergyOriginal", stat) - if(stat == 0) then - call set(scalarField,local_tke) - end if - - scalarField => extract_scalar_field(state, "GLSBuoyancyFrequency", stat) - if(stat == 0) then - call set(scalarField,NN2) - end if - - scalarField => extract_scalar_field(state, "GLSVelocityShear", stat) - if(stat == 0) then - call set(scalarField,MM2) - end if - - scalarField => extract_scalar_field(state, "GLSShearProduction", stat) - if(stat == 0) then - call set(scalarField,P) - end if - - scalarField => extract_scalar_field(state, "GLSBuoyancyProduction", stat) - if(stat == 0) then - call set(scalarField,B) - end if - - scalarField => extract_scalar_field(state, "GLSDissipationEpsilon", stat) - if(stat == 0) then - call set(scalarField,eps) - end if - - scalarField => extract_scalar_field(state, "GLSStabilityFunctionSH", stat) - if(stat == 0) then - call set(scalarField,S_H) - end if - - scalarField => extract_scalar_field(state, "GLSStabilityFunctionSM", stat) - if(stat == 0) then - call set(scalarField,S_M) - end if - - scalarField => extract_scalar_field(state, "GLSWallFunction", stat) - if(stat == 0) then - call set(scalarField,Fwall) - end if - - scalarField => extract_scalar_field(state, "GLSVerticalViscosity", stat) - if(stat == 0) then - ! add vertical background - tensorField => extract_tensor_field(state, "GLSBackgroundDiffusivity") - call set(scalarField,K_M) - call addto(scalarField, extract_scalar_field(tensorField, tensorField%dim(1), tensorField%dim(2))) - end if - - scalarField => extract_scalar_field(state, "GLSVerticalDiffusivity", stat) - if(stat == 0) then - ! add vertical background - tensorField => extract_tensor_field(state, "GLSBackgroundDiffusivity") - call set(scalarField,K_H) - call addto(scalarField, extract_scalar_field(tensorField,tensorField%dim(1), tensorField%dim(2))) - end if - - -end subroutine gls_output_fields + subroutine gls_output_fields(state) + + type(state_type), intent(in) :: state + + type(scalar_field), pointer :: scalarField + type(tensor_field), pointer :: tensorField + integer :: stat + + scalarField => extract_scalar_field(state, "GLSLengthScale", stat) + if(stat == 0) then + call set(scalarField,ll) + end if + + scalarField => extract_scalar_field(state,"GLSTurbulentKineticEnergyOriginal", stat) + if(stat == 0) then + call set(scalarField,local_tke) + end if + + scalarField => extract_scalar_field(state, "GLSBuoyancyFrequency", stat) + if(stat == 0) then + call set(scalarField,NN2) + end if + + scalarField => extract_scalar_field(state, "GLSVelocityShear", stat) + if(stat == 0) then + call set(scalarField,MM2) + end if + + scalarField => extract_scalar_field(state, "GLSShearProduction", stat) + if(stat == 0) then + call set(scalarField,P) + end if + + scalarField => extract_scalar_field(state, "GLSBuoyancyProduction", stat) + if(stat == 0) then + call set(scalarField,B) + end if + + scalarField => extract_scalar_field(state, "GLSDissipationEpsilon", stat) + if(stat == 0) then + call set(scalarField,eps) + end if + + scalarField => extract_scalar_field(state, "GLSStabilityFunctionSH", stat) + if(stat == 0) then + call set(scalarField,S_H) + end if + + scalarField => extract_scalar_field(state, "GLSStabilityFunctionSM", stat) + if(stat == 0) then + call set(scalarField,S_M) + end if + + scalarField => extract_scalar_field(state, "GLSWallFunction", stat) + if(stat == 0) then + call set(scalarField,Fwall) + end if + + scalarField => extract_scalar_field(state, "GLSVerticalViscosity", stat) + if(stat == 0) then + ! add vertical background + tensorField => extract_tensor_field(state, "GLSBackgroundDiffusivity") + call set(scalarField,K_M) + call addto(scalarField, extract_scalar_field(tensorField, tensorField%dim(1), tensorField%dim(2))) + end if + + scalarField => extract_scalar_field(state, "GLSVerticalDiffusivity", stat) + if(stat == 0) then + ! add vertical background + tensorField => extract_tensor_field(state, "GLSBackgroundDiffusivity") + call set(scalarField,K_H) + call addto(scalarField, extract_scalar_field(tensorField,tensorField%dim(1), tensorField%dim(2))) + end if + + + end subroutine gls_output_fields !--------- @@ -1989,135 +1989,135 @@ end subroutine gls_output_fields ! Each wall function has been designed with a ! particular problem in mind, so best to have a choice here !--------- -subroutine gls_calc_wall_function(state) - - type(state_type), intent(in) :: state - - type(scalar_field), pointer :: distanceToBottom, distanceToTop, tke - real :: LLL, distTop, distBot - type(scalar_field) :: top, bottom - real, parameter :: E2 = 1.33, E4 = 0.25 - integer :: i, stat - - - ! FWall is initialised in gls_init to 1, so no need to do anything - if (gls_wall_option .eq. "none") return - - tke => extract_scalar_field(state,"GLSTurbulentKineticEnergy") - distanceToTop => extract_scalar_field(state, "DistanceToTop") - distanceToBottom => extract_scalar_field(state, "DistanceToBottom") - call allocate(top,tke%mesh,"TopOnTKEMesh") - call allocate(bottom,tke%mesh,"BottomOnTKEMesh") - call remap_field(distanceToTop,top,stat) - call remap_field(distanceToBottom,bottom,stat) - select case (gls_wall_option) - case ("MellorYamda") - do i=1,nNodes + subroutine gls_calc_wall_function(state) + + type(state_type), intent(in) :: state + + type(scalar_field), pointer :: distanceToBottom, distanceToTop, tke + real :: LLL, distTop, distBot + type(scalar_field) :: top, bottom + real, parameter :: E2 = 1.33, E4 = 0.25 + integer :: i, stat + + + ! FWall is initialised in gls_init to 1, so no need to do anything + if (gls_wall_option .eq. "none") return + + tke => extract_scalar_field(state,"GLSTurbulentKineticEnergy") + distanceToTop => extract_scalar_field(state, "DistanceToTop") + distanceToBottom => extract_scalar_field(state, "DistanceToBottom") + call allocate(top,tke%mesh,"TopOnTKEMesh") + call allocate(bottom,tke%mesh,"BottomOnTKEMesh") + call remap_field(distanceToTop,top,stat) + call remap_field(distanceToBottom,bottom,stat) + select case (gls_wall_option) + case ("MellorYamda") + do i=1,nNodes distTop = max(1.0,node_val(top,i)) distBot = max(1.0,node_val(bottom,i)) LLL = (distBot + distTop) / (distTop * distBot) call set( Fwall, i, 1.0 + E2*( ((node_val(ll,i)/kappa)*( LLL ))**2 )) - end do - case ("Burchard98") - do i=1,nNodes + end do + case ("Burchard98") + do i=1,nNodes distTop = max(1.0,node_val(top,i)) distBot = max(1.0,node_val(bottom,i)) LLL = 1.0 / min(distTop,distBot) call set( Fwall, i, 1.0 + E2*( ((node_val(ll,i)/kappa)*( LLL ))**2 )) - end do - case ("Burchard01") - do i=1,nNodes + end do + case ("Burchard01") + do i=1,nNodes distTop = max(1.0,node_val(top,i)) distBot = max(1.0,node_val(bottom,i)) LLL = 1.0 / distTop call set( Fwall, i, 1.0 + E2*( ((node_val(ll,i)/kappa)*( LLL ))**2 )) - end do - case ("Blumberg") - do i=1,nNodes + end do + case ("Blumberg") + do i=1,nNodes distTop = max(0.1,node_val(top,i)) distBot = max(0.1,node_val(bottom,i)) LLL = E2 * (node_val(ll,i) / (kappa * distBot)) ** 2 LLL = LLL + E4 * (node_val(ll,i) / (kappa * distTop)) ** 2 call set( Fwall, i, 1.0 + LLL) - end do - case default - FLAbort("Unknown wall function") - end select - call deallocate(top) - call deallocate(bottom) - - -end subroutine gls_calc_wall_function - -subroutine gls_allocate_temps(state) - - type(state_type), intent(inout) :: state - type(scalar_field), pointer :: tkeField - - tkeField => extract_scalar_field(state,"GLSTurbulentKineticEnergy") - - ! allocate some space for the fields we need for calculations, but are optional in the model - ! we're going to allocate these on the velocity mesh as we need one of these... - call allocate(ll, tkeField%mesh, "LengthScale") - call allocate(NN2, tkeField%mesh, "BuoyancyFrequency") - call allocate(MM2, tkeField%mesh, "VelocityShear") - call allocate(B, tkeField%mesh, "BuoyancyFrequency") - call allocate(P, tkeField%mesh, "ShearProduction") - call allocate(S_H, tkeField%mesh, "StabilityH") - call allocate(S_M, tkeField%mesh, "StabilityM") - call allocate(K_H, tkeField%mesh, "EddyDiff") - call allocate(K_M, tkeField%mesh, "EddyVisc") - call allocate(eps, tkeField%mesh, "GLS_TKE_Dissipation") - call allocate(Fwall, tkeField%mesh, "GLS_WallFunction") - call allocate(density, tkeField%mesh, "Density") - call allocate(tke_old, tkeField%mesh, "Old_TKE") - call allocate(local_tke, tkeField%mesh, "Local_TKE") - - call set(ll,0.) - call set(NN2,0.) - call set(MM2,0.) - call set(B,0.) - call set(P,0.) - call set(S_H,0.) - call set(S_M,0.) - call set(K_H,0.) - call set(K_M,0.) - call set(eps,0.) - call set(density,0.) - call set(tke_old,0.) - call set(local_tke,tkeField) - - nNodes = node_count(tkeField) - -end subroutine gls_allocate_temps + end do + case default + FLAbort("Unknown wall function") + end select + call deallocate(top) + call deallocate(bottom) + + + end subroutine gls_calc_wall_function + + subroutine gls_allocate_temps(state) + + type(state_type), intent(inout) :: state + type(scalar_field), pointer :: tkeField + + tkeField => extract_scalar_field(state,"GLSTurbulentKineticEnergy") + + ! allocate some space for the fields we need for calculations, but are optional in the model + ! we're going to allocate these on the velocity mesh as we need one of these... + call allocate(ll, tkeField%mesh, "LengthScale") + call allocate(NN2, tkeField%mesh, "BuoyancyFrequency") + call allocate(MM2, tkeField%mesh, "VelocityShear") + call allocate(B, tkeField%mesh, "BuoyancyFrequency") + call allocate(P, tkeField%mesh, "ShearProduction") + call allocate(S_H, tkeField%mesh, "StabilityH") + call allocate(S_M, tkeField%mesh, "StabilityM") + call allocate(K_H, tkeField%mesh, "EddyDiff") + call allocate(K_M, tkeField%mesh, "EddyVisc") + call allocate(eps, tkeField%mesh, "GLS_TKE_Dissipation") + call allocate(Fwall, tkeField%mesh, "GLS_WallFunction") + call allocate(density, tkeField%mesh, "Density") + call allocate(tke_old, tkeField%mesh, "Old_TKE") + call allocate(local_tke, tkeField%mesh, "Local_TKE") + + call set(ll,0.) + call set(NN2,0.) + call set(MM2,0.) + call set(B,0.) + call set(P,0.) + call set(S_H,0.) + call set(S_M,0.) + call set(K_H,0.) + call set(K_M,0.) + call set(eps,0.) + call set(density,0.) + call set(tke_old,0.) + call set(local_tke,tkeField) + + nNodes = node_count(tkeField) + + end subroutine gls_allocate_temps !--------- ! Align the diff/visc tensors with gravity when on the sphere !--------- -function align_with_radial(position, scalar) result(rotated_tensor) - ! Function to align viscosities/diffusivities in the radial direction when on - ! the sphere - real, dimension(:), intent(in) :: position - real, intent(in) :: scalar - real, dimension(size(position),size(position)) :: rotated_tensor - real :: rad, phi, theta - - assert(size(position)==3) - - rad=sqrt(sum(position(:)**2)) - phi=atan2(position(2),position(1)) - theta=acos(position(3)/rad) - - rotated_tensor(1,1)=scalar*sin(theta)**2*cos(phi)**2 - rotated_tensor(1,2)=scalar*sin(theta)**2*sin(phi)*cos(phi) - rotated_tensor(1,3)=scalar*sin(theta)*cos(theta)*cos(phi) - rotated_tensor(2,1)=rotated_tensor(1,2) - rotated_tensor(2,2)=scalar*sin(theta)**2*sin(phi)**2 - rotated_tensor(2,3)=scalar*sin(theta)*cos(theta)*sin(phi) - rotated_tensor(3,1)=rotated_tensor(1,3) - rotated_tensor(3,2)=rotated_tensor(2,3) - rotated_tensor(3,3)=scalar*cos(theta)**2 - -end function align_with_radial + function align_with_radial(position, scalar) result(rotated_tensor) + ! Function to align viscosities/diffusivities in the radial direction when on + ! the sphere + real, dimension(:), intent(in) :: position + real, intent(in) :: scalar + real, dimension(size(position),size(position)) :: rotated_tensor + real :: rad, phi, theta + + assert(size(position)==3) + + rad=sqrt(sum(position(:)**2)) + phi=atan2(position(2),position(1)) + theta=acos(position(3)/rad) + + rotated_tensor(1,1)=scalar*sin(theta)**2*cos(phi)**2 + rotated_tensor(1,2)=scalar*sin(theta)**2*sin(phi)*cos(phi) + rotated_tensor(1,3)=scalar*sin(theta)*cos(theta)*cos(phi) + rotated_tensor(2,1)=rotated_tensor(1,2) + rotated_tensor(2,2)=scalar*sin(theta)**2*sin(phi)**2 + rotated_tensor(2,3)=scalar*sin(theta)*cos(theta)*sin(phi) + rotated_tensor(3,1)=rotated_tensor(1,3) + rotated_tensor(3,2)=rotated_tensor(2,3) + rotated_tensor(3,3)=scalar*cos(theta)**2 + + end function align_with_radial end module gls diff --git a/parameterisation/iceshelf_meltrate_surf_normal.F90 b/parameterisation/iceshelf_meltrate_surf_normal.F90 index 1f44789bc3..21b74d2306 100644 --- a/parameterisation/iceshelf_meltrate_surf_normal.F90 +++ b/parameterisation/iceshelf_meltrate_surf_normal.F90 @@ -29,39 +29,39 @@ module iceshelf_meltrate_surf_normal - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN - use fldebug - use vector_tools - use quadrature - use elements - use spud - use integer_set_module - use fields_allocates - use fields_manipulation - use transform_elements - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use field_options - use state_fields_module - use surface_integrals - use pickers_inquire - use state_fields_module - -implicit none - - private - real, save :: c0, cI, L, TI, & - a, b, gammaT, gammaS,Cd, dist_meltrate - - type(vector_field), save :: surface_positions - type(vector_field), save :: funky_positions - type(integer_set), save :: sf_nodes !Nodes at the surface - ! these are the fields and variables for the surface values - type(scalar_field), save :: ice_surfaceT,ice_surfaceS! these are used to populate the bcs - public :: melt_surf_init, melt_allocate_surface, melt_surf_calc, melt_bc + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use fldebug + use vector_tools + use quadrature + use elements + use spud + use integer_set_module + use fields_allocates + use fields_manipulation + use transform_elements + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use field_options + use state_fields_module + use surface_integrals + use pickers_inquire + use state_fields_module + + implicit none + + private + real, save :: c0, cI, L, TI, & + a, b, gammaT, gammaS,Cd, dist_meltrate + + type(vector_field), save :: surface_positions + type(vector_field), save :: funky_positions + type(integer_set), save :: sf_nodes !Nodes at the surface + ! these are the fields and variables for the surface values + type(scalar_field), save :: ice_surfaceT,ice_surfaceS! these are used to populate the bcs + public :: melt_surf_init, melt_allocate_surface, melt_surf_calc, melt_bc @@ -71,138 +71,138 @@ module iceshelf_meltrate_surf_normal ! initialise parameters based on options !---------- - subroutine melt_surf_init(state) - - type(state_type), intent(inout) :: state - character(len=OPTION_PATH_LEN) :: melt_path - ! hack - type(scalar_field), pointer :: T,S - ! When bc=Dirichlet - character(len=FIELD_NAME_LEN) :: bc_type - type(integer_set) :: surface_ids - integer, dimension(:),allocatable :: surf_id - integer, dimension(2) :: shape_option - type(mesh_type), pointer :: mesh - type(mesh_type) :: surface_mesh - integer, dimension(:), pointer :: surface_nodes ! allocated and returned by create_surface_mesh - integer, dimension(:), allocatable :: surface_element_list - integer :: i,the_node - - melt_path = "/ocean_forcing/iceshelf_meltrate/Holland08" - - - ewrite(1,*) "--------Begin melt_init-------------" - - ! Get the 6 model constants - call get_option(trim(melt_path)//'/c0', c0, default = 3974.0) - call get_option(trim(melt_path)//'/cI', cI, default = 2009.0) - call get_option(trim(melt_path)//'/L', L, default = 3.35e5) - call get_option(trim(melt_path)//'/TI', TI, default = -25.0) - call get_option(trim(melt_path)//'/a', a, default = -0.0573) - call get_option(trim(melt_path)//'/b', b, default = 0.0832) - call get_option(trim(melt_path)//'/Cd', Cd, default = 1.5e-3) - call get_option(trim(melt_path)//'/melt_LayerLength', dist_meltrate) - - gammaT = sqrt(Cd)/(12.5*(7.0**(2.0/3.0))-9.0) - gammaS = sqrt(Cd)/(12.5*(700.0**(2.0/3.0))-9.0) - - !! bc= Dirichlet initialize T and S at the ice-ocean interface - !hack - !This change with bc type - call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries", bc_type) - - select case(bc_type) - case("neumann") - - - case("dirichlet") - !! Define the values at ice-ocean interface - ! Get the surface_id of the ice-ocean interface - shape_option=option_shape(trim(melt_path)//"/melt_surfaceID") - allocate(surf_id(1:shape_option(1))) - call get_option(trim(melt_path)//'/melt_surfaceID',surf_id) - call allocate(surface_ids) - call insert(surface_ids,surf_id) - mesh => extract_mesh(state,"VelocityMesh") - ! Input, mesh, surface_id - ! Output surface_mesh,surface_element_list - call melt_surf_mesh(mesh,surface_ids,surface_mesh,surface_nodes,surface_element_list) - - T => extract_scalar_field(state,"Temperature") - S => extract_scalar_field(state,"Salinity") - do i=1,size(surface_nodes) - the_node = surface_nodes(i) - - call set(T,the_node,0.0) - call set(S,the_node,34.0) - - enddo + subroutine melt_surf_init(state) + + type(state_type), intent(inout) :: state + character(len=OPTION_PATH_LEN) :: melt_path + ! hack + type(scalar_field), pointer :: T,S + ! When bc=Dirichlet + character(len=FIELD_NAME_LEN) :: bc_type + type(integer_set) :: surface_ids + integer, dimension(:),allocatable :: surf_id + integer, dimension(2) :: shape_option + type(mesh_type), pointer :: mesh + type(mesh_type) :: surface_mesh + integer, dimension(:), pointer :: surface_nodes ! allocated and returned by create_surface_mesh + integer, dimension(:), allocatable :: surface_element_list + integer :: i,the_node + + melt_path = "/ocean_forcing/iceshelf_meltrate/Holland08" + + + ewrite(1,*) "--------Begin melt_init-------------" + + ! Get the 6 model constants + call get_option(trim(melt_path)//'/c0', c0, default = 3974.0) + call get_option(trim(melt_path)//'/cI', cI, default = 2009.0) + call get_option(trim(melt_path)//'/L', L, default = 3.35e5) + call get_option(trim(melt_path)//'/TI', TI, default = -25.0) + call get_option(trim(melt_path)//'/a', a, default = -0.0573) + call get_option(trim(melt_path)//'/b', b, default = 0.0832) + call get_option(trim(melt_path)//'/Cd', Cd, default = 1.5e-3) + call get_option(trim(melt_path)//'/melt_LayerLength', dist_meltrate) + + gammaT = sqrt(Cd)/(12.5*(7.0**(2.0/3.0))-9.0) + gammaS = sqrt(Cd)/(12.5*(700.0**(2.0/3.0))-9.0) + + !! bc= Dirichlet initialize T and S at the ice-ocean interface + !hack + !This change with bc type + call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries", bc_type) + + select case(bc_type) + case("neumann") + + + case("dirichlet") + !! Define the values at ice-ocean interface + ! Get the surface_id of the ice-ocean interface + shape_option=option_shape(trim(melt_path)//"/melt_surfaceID") + allocate(surf_id(1:shape_option(1))) + call get_option(trim(melt_path)//'/melt_surfaceID',surf_id) + call allocate(surface_ids) + call insert(surface_ids,surf_id) + mesh => extract_mesh(state,"VelocityMesh") + ! Input, mesh, surface_id + ! Output surface_mesh,surface_element_list + call melt_surf_mesh(mesh,surface_ids,surface_mesh,surface_nodes,surface_element_list) + + T => extract_scalar_field(state,"Temperature") + S => extract_scalar_field(state,"Salinity") + do i=1,size(surface_nodes) + the_node = surface_nodes(i) + + call set(T,the_node,0.0) + call set(S,the_node,34.0) + + enddo ! T_bc => extract_scalar_field(state,"Tb") ! S_bc => extract_scalar_field(state,"Sb") - case default - FLAbort('Unknown BC for TKE') - end select + case default + FLAbort('Unknown BC for TKE') + end select - ewrite(1,*) "---------End melt_surf_init---------------------------------" + ewrite(1,*) "---------End melt_surf_init---------------------------------" - end subroutine melt_surf_init + end subroutine melt_surf_init -subroutine melt_allocate_surface(state) + subroutine melt_allocate_surface(state) - type(state_type), intent(inout) :: state - type(vector_field), pointer :: positions - type(mesh_type), pointer :: mesh - type(mesh_type) :: surface_mesh - integer, dimension(:), pointer :: surface_nodes ! allocated and returned by create_surface_mesh - integer, dimension(:), allocatable :: surface_element_list - integer :: face,i,j,k + type(state_type), intent(inout) :: state + type(vector_field), pointer :: positions + type(mesh_type), pointer :: mesh + type(mesh_type) :: surface_mesh + integer, dimension(:), pointer :: surface_nodes ! allocated and returned by create_surface_mesh + integer, dimension(:), allocatable :: surface_element_list + integer :: face,i,j,k !! The local coordinates of the coordinate in the owning element !! real, dimension(:), allocatable :: local_coord, local_coord_surf - real, dimension(:), allocatable :: coord + real, dimension(:), allocatable :: coord ! for transform_facet_to_physical - real, dimension(:,:), allocatable :: normal - real, dimension(:), allocatable :: av_normal !Average of normal + real, dimension(:,:), allocatable :: normal + real, dimension(:), allocatable :: av_normal !Average of normal !! integer, dimension(:), pointer :: ele_faces,face_neighs - type(element_type), pointer :: x_shape_f - real, dimension(:), allocatable :: xyz !New location of surface_mesh, dist_meltrate away from the boundary + type(element_type), pointer :: x_shape_f + real, dimension(:), allocatable :: xyz !New location of surface_mesh, dist_meltrate away from the boundary !integer, save :: melt_surfaceID - character(len=OPTION_PATH_LEN) :: path - type(integer_set) :: surface_ids - integer, dimension(:),allocatable :: surf_id + character(len=OPTION_PATH_LEN) :: path + type(integer_set) :: surface_ids + integer, dimension(:),allocatable :: surf_id ! For the vector averaging schem, taking the area of the surface element etc - real, dimension(:,:), allocatable :: table - integer, dimension(:,:), allocatable :: node_occupants - integer :: st,en,node,dim_vec - real :: area_sum - integer, dimension(2) :: shape_option - - ewrite(1,*) "-------Begin melt_allocate_surface---------" - path = "/ocean_forcing/iceshelf_meltrate/Holland08" - ! Get the surface_id of the ice-ocean interface - shape_option=option_shape(trim(path)//"/melt_surfaceID") - allocate(surf_id(1:shape_option(1))) - call get_option(trim(path)//'/melt_surfaceID',surf_id) - call allocate(surface_ids) - call insert(surface_ids,surf_id) + real, dimension(:,:), allocatable :: table + integer, dimension(:,:), allocatable :: node_occupants + integer :: st,en,node,dim_vec + real :: area_sum + integer, dimension(2) :: shape_option + + ewrite(1,*) "-------Begin melt_allocate_surface---------" + path = "/ocean_forcing/iceshelf_meltrate/Holland08" + ! Get the surface_id of the ice-ocean interface + shape_option=option_shape(trim(path)//"/melt_surfaceID") + allocate(surf_id(1:shape_option(1))) + call get_option(trim(path)//'/melt_surfaceID',surf_id) + call allocate(surface_ids) + call insert(surface_ids,surf_id) ! deallocate(surf_id) ! ewrite(1,*) "aft_surface_ids: ", set2vector(surface_ids) - mesh => extract_mesh(state,"VelocityMesh") + mesh => extract_mesh(state,"VelocityMesh") ! Input, mesh, surface_id ! Output surface_mesh,surface_element_list - call melt_surf_mesh(mesh,surface_ids,surface_mesh,surface_nodes,surface_element_list) + call melt_surf_mesh(mesh,surface_ids,surface_mesh,surface_nodes,surface_element_list) - positions => extract_vector_field(state,"Coordinate") + positions => extract_vector_field(state,"Coordinate") !SINK THE surface_mesh!! ! call get_option("/geometry/dimension/", dimension) - call allocate(surface_positions,positions%dim,mesh,"MySurfacePosition") - call allocate(funky_positions,surface_positions%dim, surface_positions%mesh,"MyFunkyPosition") + call allocate(surface_positions,positions%dim,mesh,"MySurfacePosition") + call allocate(funky_positions,surface_positions%dim, surface_positions%mesh,"MyFunkyPosition") ! Remap the positions vector to the surface mesh, surface_positions - call remap_field_to_surface(positions, surface_positions, surface_element_list) + call remap_field_to_surface(positions, surface_positions, surface_element_list) ! Loop over # of surface elements !nf = size(surface_element_list) @@ -215,45 +215,45 @@ subroutine melt_allocate_surface(state) ! table(2,:) = normal_x ! table(3,:) = normal_y ! table(4,:) = normal_z - dim_vec = positions%dim - allocate(coord(dim_vec)) - allocate(node_occupants(2,dim_vec*size(surface_element_list))) - allocate(table(dim_vec+1,dim_vec*size(surface_element_list))) - allocate(av_normal(dim_vec)) - allocate(xyz(dim_vec)) - - do i=1,size(surface_element_list) - st = 1+dim_vec*(i-1) - en = dim_vec+dim_vec*(i-1) - face = surface_element_list(i) - node_occupants(2,st:en) = face - node_occupants(1,st:en) = face_global_nodes(positions, face) - ! Calculate the area of the surface element - ! For 2D, the area is the length - if (dim_vec .eq. 2) then + dim_vec = positions%dim + allocate(coord(dim_vec)) + allocate(node_occupants(2,dim_vec*size(surface_element_list))) + allocate(table(dim_vec+1,dim_vec*size(surface_element_list))) + allocate(av_normal(dim_vec)) + allocate(xyz(dim_vec)) + + do i=1,size(surface_element_list) + st = 1+dim_vec*(i-1) + en = dim_vec+dim_vec*(i-1) + face = surface_element_list(i) + node_occupants(2,st:en) = face + node_occupants(1,st:en) = face_global_nodes(positions, face) + ! Calculate the area of the surface element + ! For 2D, the area is the length + if (dim_vec .eq. 2) then table(1,st:en) = calc_area2(positions,node_occupants(1,st:en)) - endif + endif - ! For 3D, the area become the area of the triangle (assumption here). - ! Subroutine calc_area3 uses Heron's formula. - if (dim_vec .eq. 3) then + ! For 3D, the area become the area of the triangle (assumption here). + ! Subroutine calc_area3 uses Heron's formula. + if (dim_vec .eq. 3) then table(1,st:en) = calc_area3(positions,node_occupants(1,st:en)) - endif - ! Compute the normal vector at the surface element. - x_shape_f=>face_shape(positions,face) - allocate(normal(dim_vec,x_shape_f%ngi)) !(dim x x_shape_f%ngi) - call transform_facet_to_physical(positions, face, normal=normal) - av_normal = sum(normal,2) - !"normal" should be the same; since the normal vector on the quadrature point does not change. - av_normal = av_normal/(sum(av_normal*av_normal))**(0.5) ! normalize the vector - deallocate(normal) - !Since av_normal is outward to the boundary, we will put -sign. We want the vector into the boundary - av_normal = -av_normal - ! Store av_normal, the normal vector averaged over quadrature points, in table - do j=1,dim_vec + endif + ! Compute the normal vector at the surface element. + x_shape_f=>face_shape(positions,face) + allocate(normal(dim_vec,x_shape_f%ngi)) !(dim x x_shape_f%ngi) + call transform_facet_to_physical(positions, face, normal=normal) + av_normal = sum(normal,2) + !"normal" should be the same; since the normal vector on the quadrature point does not change. + av_normal = av_normal/(sum(av_normal*av_normal))**(0.5) ! normalize the vector + deallocate(normal) + !Since av_normal is outward to the boundary, we will put -sign. We want the vector into the boundary + av_normal = -av_normal + ! Store av_normal, the normal vector averaged over quadrature points, in table + do j=1,dim_vec table(j+1,st:en)=av_normal(j) - enddo - enddo + enddo + enddo !! Now loop over surface_nodes ! ewrite(1,*) "table(1,1:3): ", table(1,1:3) ! ewrite(1,*) "table(2,1:3),normal_x: ", table(2,1:3) @@ -261,43 +261,43 @@ subroutine melt_allocate_surface(state) ! ewrite(1,*) "table(4,1:3),normal_z: ", table(4,1:3) !!In this loop, we will average adjacent normal vectors, using the area of the surface elements. - !allocate(sf_nodes_ar(size(node_occupants(1,:)))) - call allocate(sf_nodes) + !allocate(sf_nodes_ar(size(node_occupants(1,:)))) + call allocate(sf_nodes) ! call insert(sf_nodes,sf_nodes_ar) - do i=1,size(node_occupants(1,:)) - node = node_occupants(1,i) - av_normal(:) = 0.0 - area_sum = 0.0 - ! This loop average the normal vector based on the areas of surface elements - !, which share the "node". Using hash table may speed up this process - do j=1,size(node_occupants(1,:)) + do i=1,size(node_occupants(1,:)) + node = node_occupants(1,i) + av_normal(:) = 0.0 + area_sum = 0.0 + ! This loop average the normal vector based on the areas of surface elements + !, which share the "node". Using hash table may speed up this process + do j=1,size(node_occupants(1,:)) !Pick the surface elements that sheare the "node" if (node_occupants(1,j) .eq. node) then - do k=1,dim_vec - !table(1,j) = area of the surface element - av_normal(k) = av_normal(k) + table(k+1,j)*table(1,j) - enddo - !The total areas of the surface elements that occupies the "node" - area_sum = area_sum + table(1,j) + do k=1,dim_vec + !table(1,j) = area of the surface element + av_normal(k) = av_normal(k) + table(k+1,j)*table(1,j) + enddo + !The total areas of the surface elements that occupies the "node" + area_sum = area_sum + table(1,j) endif - enddo + enddo - av_normal = av_normal / area_sum - ! normalize - av_normal = av_normal/(sum(av_normal*av_normal))**(0.5) + av_normal = av_normal / area_sum + ! normalize + av_normal = av_normal/(sum(av_normal*av_normal))**(0.5) - dist_meltrate = abs(dist_meltrate) - ! Shift the location of the surface nodes. - !The coordinate of the surface node. + dist_meltrate = abs(dist_meltrate) + ! Shift the location of the surface nodes. + !The coordinate of the surface node. - coord = node_val(positions,node) + coord = node_val(positions,node) - ! dist_meltrate = ||xyz - coord|| xyz and coord are vectors - xyz = av_normal*dist_meltrate + coord + ! dist_meltrate = ||xyz - coord|| xyz and coord are vectors + xyz = av_normal*dist_meltrate + coord - call set(funky_positions,node,xyz) ! Set the coordinate of sinked nodes, funky positions. + call set(funky_positions,node,xyz) ! Set the coordinate of sinked nodes, funky positions. - call set(surface_positions,node,coord) !Original coordinate of the surface + call set(surface_positions,node,coord) !Original coordinate of the surface !! ewrite(1,*) "--------------------------------" !! ewrite(1,*) "node: ", node !! ewrite(1,*) "av_normal: ", av_normal @@ -305,289 +305,289 @@ subroutine melt_allocate_surface(state) !! ewrite(1,*) "coord: ", coord !! ! Save the corresponding node number. !! !sf_nodes_ar(i) = node - call insert(sf_nodes,node) + call insert(sf_nodes,node) - node = 0 - enddo + node = 0 + enddo - deallocate(coord) - deallocate(table) - deallocate(node_occupants) - deallocate(av_normal) - deallocate(xyz) - call deallocate(surface_ids) - ewrite(1,*) "-------End melt_allocate_surface---------" -end subroutine melt_allocate_surface + deallocate(coord) + deallocate(table) + deallocate(node_occupants) + deallocate(av_normal) + deallocate(xyz) + call deallocate(surface_ids) + ewrite(1,*) "-------End melt_allocate_surface---------" + end subroutine melt_allocate_surface ! Calculate the melt rate - subroutine melt_surf_calc(state) - - type(state_type), intent(inout) :: state - type(scalar_field), pointer :: Tb, Sb,MeltRate,Heat_flux,Salt_flux - type(scalar_field), pointer :: scalarfield - type(vector_field), pointer :: velocity,positions - !Debugging purpose pointer - type(scalar_field), pointer :: T_loc,S_loc,P_loc - type(vector_field), pointer :: V_loc,Location,Location_org - real, dimension(:), allocatable :: vel - integer :: i,j - ! Some internal variables - real :: speed, T,S,P,Aa,Bb,Cc,topo - real ::loc_Tb,loc_Sb,loc_meltrate,loc_heatflux,loc_saltflux - ! Aa*Sb^2+Bv*Sb+Cc - real :: arg = -1.0 - !Sink mesh part - integer :: ele,node,stat,the_node - real, dimension(:), allocatable :: local_coord,coord - integer, dimension(:), allocatable :: surface_node_list,node_lists - type(scalar_field) :: re_temperature,re_salinity,re_pressure - type(vector_field) :: re_velocity - - - ewrite(1,*) "-------Begin melt_surf_calc------------" - - MeltRate => extract_scalar_field(state,"MeltRate") - Tb => extract_scalar_field(state,"Tb") - Sb => extract_scalar_field(state,"Sb") - call set(MeltRate,setnan(arg)) - call set(Tb,setnan(arg)) - call set(Sb,setnan(arg)) - Heat_flux => extract_scalar_field(state,"Heat_flux") - Salt_flux => extract_scalar_field(state,"Salt_flux") - call set(Heat_flux,setnan(arg)) - call set(Salt_flux,setnan(arg)) + subroutine melt_surf_calc(state) + + type(state_type), intent(inout) :: state + type(scalar_field), pointer :: Tb, Sb,MeltRate,Heat_flux,Salt_flux + type(scalar_field), pointer :: scalarfield + type(vector_field), pointer :: velocity,positions + !Debugging purpose pointer + type(scalar_field), pointer :: T_loc,S_loc,P_loc + type(vector_field), pointer :: V_loc,Location,Location_org + real, dimension(:), allocatable :: vel + integer :: i,j + ! Some internal variables + real :: speed, T,S,P,Aa,Bb,Cc,topo + real ::loc_Tb,loc_Sb,loc_meltrate,loc_heatflux,loc_saltflux + ! Aa*Sb^2+Bv*Sb+Cc + real :: arg = -1.0 + !Sink mesh part + integer :: ele,node,stat,the_node + real, dimension(:), allocatable :: local_coord,coord + integer, dimension(:), allocatable :: surface_node_list,node_lists + type(scalar_field) :: re_temperature,re_salinity,re_pressure + type(vector_field) :: re_velocity + + + ewrite(1,*) "-------Begin melt_surf_calc------------" + + MeltRate => extract_scalar_field(state,"MeltRate") + Tb => extract_scalar_field(state,"Tb") + Sb => extract_scalar_field(state,"Sb") + call set(MeltRate,setnan(arg)) + call set(Tb,setnan(arg)) + call set(Sb,setnan(arg)) + Heat_flux => extract_scalar_field(state,"Heat_flux") + Salt_flux => extract_scalar_field(state,"Salt_flux") + call set(Heat_flux,setnan(arg)) + call set(Salt_flux,setnan(arg)) ! Debugging - T_loc => extract_scalar_field(state,"Tloc") - S_loc => extract_scalar_field(state,"Sloc") - P_loc => extract_scalar_field(state,"Ploc") - V_loc => extract_vector_field(state,"Vloc") - Location => extract_vector_field(state,"Location") - Location_org => extract_vector_field(state,"Location_org") - call set(T_loc,setnan(arg)) - call set(S_loc,setnan(arg)) - call set(P_loc,setnan(arg)) - allocate(vel(V_loc%dim)) - vel = setnan(arg) - call set(V_loc,vel) - call set(Location,vel) - call set(Location_org,vel) - - positions => extract_vector_field(state,"Coordinate") - !my positions + T_loc => extract_scalar_field(state,"Tloc") + S_loc => extract_scalar_field(state,"Sloc") + P_loc => extract_scalar_field(state,"Ploc") + V_loc => extract_vector_field(state,"Vloc") + Location => extract_vector_field(state,"Location") + Location_org => extract_vector_field(state,"Location_org") + call set(T_loc,setnan(arg)) + call set(S_loc,setnan(arg)) + call set(P_loc,setnan(arg)) + allocate(vel(V_loc%dim)) + vel = setnan(arg) + call set(V_loc,vel) + call set(Location,vel) + call set(Location_org,vel) + + positions => extract_vector_field(state,"Coordinate") + !my positions ! Surface node list - allocate(surface_node_list(key_count(sf_nodes))) - ! Make it to vector from integer_set. - ! sf_nodes is calculated in "melt_allocate_surface" - surface_node_list=set2vector(sf_nodes) + allocate(surface_node_list(key_count(sf_nodes))) + ! Make it to vector from integer_set. + ! sf_nodes is calculated in "melt_allocate_surface" + surface_node_list=set2vector(sf_nodes) - ! Remap temperature, salinity, pressure, and velocity onto positions mesh - scalarfield => extract_scalar_field(state,"Temperature") + ! Remap temperature, salinity, pressure, and velocity onto positions mesh + scalarfield => extract_scalar_field(state,"Temperature") - call allocate(re_temperature,positions%mesh,name="ReTemperature") + call allocate(re_temperature,positions%mesh,name="ReTemperature") - call remap_field(scalarfield,re_temperature,stat) + call remap_field(scalarfield,re_temperature,stat) - ! Salinity - scalarfield=> extract_scalar_field(state,"Salinity") + ! Salinity + scalarfield=> extract_scalar_field(state,"Salinity") - call allocate(re_salinity,positions%mesh, name="ReSalinity") - call remap_field(scalarfield,re_salinity,stat) + call allocate(re_salinity,positions%mesh, name="ReSalinity") + call remap_field(scalarfield,re_salinity,stat) - ! Pressure - scalarfield => extract_scalar_field(state,"Pressure") - call allocate(re_pressure,positions%mesh, name="RePressure") - call remap_field(scalarfield,re_pressure,stat) + ! Pressure + scalarfield => extract_scalar_field(state,"Pressure") + call allocate(re_pressure,positions%mesh, name="RePressure") + call remap_field(scalarfield,re_pressure,stat) - ! Velocity - velocity => extract_vector_field(state,"Velocity") - call allocate(re_velocity,velocity%dim,positions%mesh,name="ReVelocity") - call remap_field(velocity, re_velocity, stat) + ! Velocity + velocity => extract_vector_field(state,"Velocity") + call allocate(re_velocity,velocity%dim,positions%mesh,name="ReVelocity") + call remap_field(velocity, re_velocity, stat) - allocate(local_coord(positions%dim+1)) - allocate(coord(positions%dim)) + allocate(local_coord(positions%dim+1)) + allocate(coord(positions%dim)) !!!!!!!!!!!!!!!!!!!!!!!!! - !surface_positions + !surface_positions - !! Loope over the surface nodes to calculate melt rate etc. - do i=1,size(surface_node_list) - the_node = surface_node_list(i) - !!! Interpolating - coord = node_val(funky_positions,the_node) - call picker_inquire(positions, coord, ele, local_coord,global=.true.) + !! Loope over the surface nodes to calculate melt rate etc. + do i=1,size(surface_node_list) + the_node = surface_node_list(i) + !!! Interpolating + coord = node_val(funky_positions,the_node) + call picker_inquire(positions, coord, ele, local_coord,global=.true.) - !! If sum(local_coord) is not equal to 1, - !! we know that this coord (funky position) does not exist in the domain. + !! If sum(local_coord) is not equal to 1, + !! we know that this coord (funky position) does not exist in the domain. - if (sum(local_coord) .gt. 2.0) then + if (sum(local_coord) .gt. 2.0) then ewrite(1,*) "Funk coord: ", node_val(funky_positions,the_node) !! node_val(surface_positions,the_node) = node_val(positions,the_node) ewrite(1,*) "Original ele: ",ele ewrite(1,*) "sum of local_coord: ", sum(local_coord) FLExit("Your funky_positions is out of the domain. Change melt_LayerLength.") - endif - !Number of nodes per element - allocate(node_lists(ele_and_faces_loc(positions, ele))) - node_lists = ele_nodes(positions,ele) !Lists of nodes that occupies the element. - ! This method of finding values at funky_positions works for P1, which are T,S, and velocity. - coord = 0.0 - T = 0.0 - S = 0.0 - speed = 0.0 - vel = 0.0 - - do j=1,size(node_lists) + endif + !Number of nodes per element + allocate(node_lists(ele_and_faces_loc(positions, ele))) + node_lists = ele_nodes(positions,ele) !Lists of nodes that occupies the element. + ! This method of finding values at funky_positions works for P1, which are T,S, and velocity. + coord = 0.0 + T = 0.0 + S = 0.0 + speed = 0.0 + vel = 0.0 + + do j=1,size(node_lists) node = node_lists(j) coord = coord + node_val(positions,node)*local_coord(j) T = T + node_val(re_temperature,node)*local_coord(j) S = S + node_val(re_salinity,node)*local_coord(j) vel = vel + node_val(re_velocity,node)*local_coord(j) - enddo - deallocate(node_lists) - ! Luckly P needs to be at the surface for the three equations - P = node_val(re_pressure,the_node) - speed = sqrt(sum(vel**2)) + enddo + deallocate(node_lists) + ! Luckly P needs to be at the surface for the three equations + P = node_val(re_pressure,the_node) + speed = sqrt(sum(vel**2)) - if (speed .lt. 0.001) then + if (speed .lt. 0.001) then speed = 0.001 - !ewrite(1,*) "----------iceshelf, speed less----", the_node,speed - endif - topo = -7.53e-8*P ! constant = -7.53e-8 [C Pa^(-1)] comes from Holland and Jenkins Table 1 + !ewrite(1,*) "----------iceshelf, speed less----", the_node,speed + endif + topo = -7.53e-8*P ! constant = -7.53e-8 [C Pa^(-1)] comes from Holland and Jenkins Table 1 - !! Define Aa,Bb,Cc - !! Aa*Sb**2 + Bb*Sb + Cc = 0.0 - Aa = -gammaS*speed*cI*a + a*c0*gammaT*speed + !! Define Aa,Bb,Cc + !! Aa*Sb**2 + Bb*Sb + Cc = 0.0 + Aa = -gammaS*speed*cI*a + a*c0*gammaT*speed - Bb = -gammaS*speed*L + gammaS*speed*S*cI*a - Bb = Bb - gammaS*speed*cI*(b+topo) + gammaS*speed*cI*TI - Bb = Bb - c0*gammaT*speed*T + c0*gammaT*speed*(b+topo) + Bb = -gammaS*speed*L + gammaS*speed*S*cI*a + Bb = Bb - gammaS*speed*cI*(b+topo) + gammaS*speed*cI*TI + Bb = Bb - c0*gammaT*speed*T + c0*gammaT*speed*(b+topo) - Cc = gammaS*speed*S*L +gammaS*speed*S*cI*(b+topo) + gammaS*speed*S*(-cI*TI) + Cc = gammaS*speed*S*L +gammaS*speed*S*cI*(b+topo) + gammaS*speed*S*(-cI*TI) - !! This could be a linear equation if Aa=0 - if (Aa .eq. 0.0) then + !! This could be a linear equation if Aa=0 + if (Aa .eq. 0.0) then loc_Sb = -Cc/Bb - else + else !! Calculate for the 2nd oewrite(1,*) "size(surface_element_list)"rder polynomial. !! We have two solutions. loc_Sb = (-Bb + sqrt(Bb**2 - 4.0*Aa*Cc))/(2.0*Aa) !! loc_Sb has to be larger than 0; since the salinity in the ocean is positive definite. if (loc_Sb .lt. 0.0) then - loc_Sb = (-Bb - sqrt(Bb**2 - 4.0*Aa*Cc))/(2.0*Aa) + loc_Sb = (-Bb - sqrt(Bb**2 - 4.0*Aa*Cc))/(2.0*Aa) endif - endif - !ewrite(1,*) "----------iceshelf, loc_Sb----", loc_Sb - loc_Tb = a*loc_Sb + b + topo - loc_meltrate = gammaS*speed*(S-loc_Sb)/loc_Sb - !! Heat flux to the ocean - loc_heatflux = c0*(gammaT*speed+ loc_meltrate)*(T-loc_Tb) ! or loc_meltrate*L + loc_meltrate*cI*(loc_Tb-TI) - loc_saltflux = (gammaS*speed+loc_meltrate)*(S-loc_Sb) - !! Some debugging - !!ewrite(1,*) "melt_rate: ",loc_meltrate - !!ewrite(1,*) "tLHS: ", c0*gammaT*speed*(T-loc_Tb) - !!ewrite(1,*) "tRHS: ", loc_meltrate*L + loc_meltrate*cI*(loc_Tb-TI) - !!ewrite(1,*) "sLHS: ", gammaS*speed*(S-loc_Sb) - !!ewrite(1,*) "sRHS: ", loc_meltrate*loc_Sb - !!ewrite(1,*) "bLHS: ", loc_Tb - !!ewrite(1,*) "bRHS: ", a*loc_Sb + b + topo - - !! These are needed to implement BCs. - call set(MeltRate, the_node, loc_meltrate) - call set(Tb, the_node, loc_Tb) - call set(Sb, the_node, loc_Sb) - call set(Heat_flux, the_node,loc_heatflux) - call set(Salt_flux, the_node,loc_saltflux) - !! More or less for debugging purposes. - call set(T_loc,the_node,T) - call set(S_loc,the_node,S) - call set(P_loc,the_node,P) - call set(V_loc,the_node,vel) - call set(Location,the_node,node_val(funky_positions,the_node)) - call set(Location_org,the_node,node_val(positions,the_node)) - !! BC test - !!call set(TT,the_node,11.1) + endif + !ewrite(1,*) "----------iceshelf, loc_Sb----", loc_Sb + loc_Tb = a*loc_Sb + b + topo + loc_meltrate = gammaS*speed*(S-loc_Sb)/loc_Sb + !! Heat flux to the ocean + loc_heatflux = c0*(gammaT*speed+ loc_meltrate)*(T-loc_Tb) ! or loc_meltrate*L + loc_meltrate*cI*(loc_Tb-TI) + loc_saltflux = (gammaS*speed+loc_meltrate)*(S-loc_Sb) + !! Some debugging + !!ewrite(1,*) "melt_rate: ",loc_meltrate + !!ewrite(1,*) "tLHS: ", c0*gammaT*speed*(T-loc_Tb) + !!ewrite(1,*) "tRHS: ", loc_meltrate*L + loc_meltrate*cI*(loc_Tb-TI) + !!ewrite(1,*) "sLHS: ", gammaS*speed*(S-loc_Sb) + !!ewrite(1,*) "sRHS: ", loc_meltrate*loc_Sb + !!ewrite(1,*) "bLHS: ", loc_Tb + !!ewrite(1,*) "bRHS: ", a*loc_Sb + b + topo + + !! These are needed to implement BCs. + call set(MeltRate, the_node, loc_meltrate) + call set(Tb, the_node, loc_Tb) + call set(Sb, the_node, loc_Sb) + call set(Heat_flux, the_node,loc_heatflux) + call set(Salt_flux, the_node,loc_saltflux) + !! More or less for debugging purposes. + call set(T_loc,the_node,T) + call set(S_loc,the_node,S) + call set(P_loc,the_node,P) + call set(V_loc,the_node,vel) + call set(Location,the_node,node_val(funky_positions,the_node)) + call set(Location_org,the_node,node_val(positions,the_node)) + !! BC test + !!call set(TT,the_node,11.1) ! ewrite(1,*) "----------iceshelf, loc_saltflux----", the_node,loc_saltflux ! ewrite(1,*) "----------melt_surf_calc, loc_Tb----", the_node,loc_Tb ! ewrite(1,*) "----------iceshelf, surfaceS----",node_val(re_salinity,the_node) ! ewrite(1,*) "----------line 477 iceshelf, loc_meltrate----",loc_meltrate ! ewrite(1,*) "----------iceshelf, node_val(TT,the_node)----",node_val(TT,the_node) - enddo - - deallocate(local_coord) - deallocate(coord) - ewrite(1,*) "-----END melt_surf_calc-------" -end subroutine melt_surf_calc - - -subroutine melt_bc(state) - type(state_type), intent(inout) :: state - !! BC - type(scalar_field), pointer :: TT,SS - type(scalar_field), pointer :: scalar_surface - type(mesh_type), pointer :: ice_mesh - character(len=FIELD_NAME_LEN) :: bc_type - type(scalar_field), pointer :: T_bc,S_bc - integer, dimension(:), allocatable :: surface_node_list - integer :: i, the_node + enddo + + deallocate(local_coord) + deallocate(coord) + ewrite(1,*) "-----END melt_surf_calc-------" + end subroutine melt_surf_calc + + + subroutine melt_bc(state) + type(state_type), intent(inout) :: state + !! BC + type(scalar_field), pointer :: TT,SS + type(scalar_field), pointer :: scalar_surface + type(mesh_type), pointer :: ice_mesh + character(len=FIELD_NAME_LEN) :: bc_type + type(scalar_field), pointer :: T_bc,S_bc + integer, dimension(:), allocatable :: surface_node_list + integer :: i, the_node !! Insert BC for temperature and salinity. This could be a separate subroutine - TT=> extract_scalar_field(state,"Temperature") - SS => extract_scalar_field(state,"Salinity") - - !This change with bc type - call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries", bc_type) - - select case(bc_type) - case("neumann") - T_bc => extract_scalar_field(state,"Heat_flux") - S_bc => extract_scalar_field(state,"Salt_flux") - do i=1,node_count(T_bc) - call set(T_bc,node_val(T_bc,i)*10.0**3) - call set(S_bc,node_val(S_bc,i)*10.0**3) - enddo - - case("dirichlet") - T_bc => extract_scalar_field(state,"Tb") - S_bc => extract_scalar_field(state,"Sb") - case default - FLAbort('Unknown BC for TKE') - end select - - - ! Surface node list - allocate(surface_node_list(key_count(sf_nodes))) - ! Make it to vector from integer_set. - ! sf_nodes is calculated in "melt_allocate_surface" - surface_node_list=set2vector(sf_nodes) - - ! create a surface mesh to place values onto. This is for the top surface - call get_boundary_condition(TT, 'temperature_iceshelf_BC', surface_mesh=ice_mesh) - call allocate(ice_surfaceT, ice_mesh, name="ice_surfaceT") - call get_boundary_condition(SS, 'salinity_iceshelf_BC', surface_mesh=ice_mesh) - call allocate(ice_surfaceS, ice_mesh, name="ice_surfaceS") - ! Define ice_surfaceT according to Heat_flux? - ewrite(1,*) "node_count(ice_surfaceT)",node_count(ice_surfaceT) - do i=1,node_count(ice_surfaceT) - the_node = surface_node_list(i) - call set(ice_surfaceT,i,node_val(T_bc,the_node)) - call set(ice_surfaceS,i,node_val(S_bc,the_node)) - enddo - !! Temperature - scalar_surface => extract_surface_field(TT, 'temperature_iceshelf_BC', "value") - call remap_field(ice_surfaceT, scalar_surface) - !! Salinity - scalar_surface => extract_surface_field(SS, 'salinity_iceshelf_BC', "value") - call remap_field(ice_surfaceS, scalar_surface) + TT=> extract_scalar_field(state,"Temperature") + SS => extract_scalar_field(state,"Salinity") + + !This change with bc type + call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries", bc_type) + + select case(bc_type) + case("neumann") + T_bc => extract_scalar_field(state,"Heat_flux") + S_bc => extract_scalar_field(state,"Salt_flux") + do i=1,node_count(T_bc) + call set(T_bc,node_val(T_bc,i)*10.0**3) + call set(S_bc,node_val(S_bc,i)*10.0**3) + enddo + + case("dirichlet") + T_bc => extract_scalar_field(state,"Tb") + S_bc => extract_scalar_field(state,"Sb") + case default + FLAbort('Unknown BC for TKE') + end select + + + ! Surface node list + allocate(surface_node_list(key_count(sf_nodes))) + ! Make it to vector from integer_set. + ! sf_nodes is calculated in "melt_allocate_surface" + surface_node_list=set2vector(sf_nodes) + + ! create a surface mesh to place values onto. This is for the top surface + call get_boundary_condition(TT, 'temperature_iceshelf_BC', surface_mesh=ice_mesh) + call allocate(ice_surfaceT, ice_mesh, name="ice_surfaceT") + call get_boundary_condition(SS, 'salinity_iceshelf_BC', surface_mesh=ice_mesh) + call allocate(ice_surfaceS, ice_mesh, name="ice_surfaceS") + ! Define ice_surfaceT according to Heat_flux? + ewrite(1,*) "node_count(ice_surfaceT)",node_count(ice_surfaceT) + do i=1,node_count(ice_surfaceT) + the_node = surface_node_list(i) + call set(ice_surfaceT,i,node_val(T_bc,the_node)) + call set(ice_surfaceS,i,node_val(S_bc,the_node)) + enddo + !! Temperature + scalar_surface => extract_surface_field(TT, 'temperature_iceshelf_BC', "value") + call remap_field(ice_surfaceT, scalar_surface) + !! Salinity + scalar_surface => extract_surface_field(SS, 'salinity_iceshelf_BC', "value") + call remap_field(ice_surfaceS, scalar_surface) ! ewrite(1,*) "iceBC, ice_element_list",ice_element_list ! ewrite(1,*) "iceBC, node_count(scalar_surface)", node_count(scalar_surface) ! ewrite(1,*) "node_val(scalar_surface,1): ", node_val(scalar_surface,1) @@ -595,7 +595,7 @@ subroutine melt_bc(state) !! Insert BC for salinity -end subroutine melt_bc + end subroutine melt_bc @@ -603,69 +603,69 @@ end subroutine melt_bc !! Private subroutines ! !!------------------------------------------------------------------! -subroutine melt_surf_mesh(mesh,surface_ids,surface_mesh,surface_nodes,surface_element_list) + subroutine melt_surf_mesh(mesh,surface_ids,surface_mesh,surface_nodes,surface_element_list) - type(mesh_type), intent(in) :: mesh - type(integer_set), intent(in) :: surface_ids - type(mesh_type), intent(out) :: surface_mesh - integer, dimension(:), pointer, intent(out) :: surface_nodes ! allocated and returned by create_surface_mesh - integer, dimension(:), allocatable, intent(out) :: surface_element_list - ! integer, dimension(:), allocatable :: surface_nodes_out - type(integer_set) :: surface_elements - integer :: i - ! create a set of surface elements that have surface id in 'surface_ids' + type(mesh_type), intent(in) :: mesh + type(integer_set), intent(in) :: surface_ids + type(mesh_type), intent(out) :: surface_mesh + integer, dimension(:), pointer, intent(out) :: surface_nodes ! allocated and returned by create_surface_mesh + integer, dimension(:), allocatable, intent(out) :: surface_element_list + ! integer, dimension(:), allocatable :: surface_nodes_out + type(integer_set) :: surface_elements + integer :: i + ! create a set of surface elements that have surface id in 'surface_ids' - call allocate(surface_elements) - do i=1, surface_element_count(mesh) + call allocate(surface_elements) + do i=1, surface_element_count(mesh) ! ewrite(1,*) "surf_normal surface_element_id(mesh, i)", surface_element_id(mesh, i) ! ewrite(1,*) "surf_normal surface_ids", set2vector(surface_ids) - if (has_value(surface_ids, surface_element_id(mesh, i))) then - call insert(surface_elements, i) + if (has_value(surface_ids, surface_element_id(mesh, i))) then + call insert(surface_elements, i) - end if - end do + end if + end do - allocate(surface_element_list(key_count(surface_elements))) - surface_element_list=set2vector(surface_elements) - call create_surface_mesh(surface_mesh, surface_nodes, mesh, surface_element_list, name=trim(mesh%name)//"ToshisMesh") + allocate(surface_element_list(key_count(surface_elements))) + surface_element_list=set2vector(surface_elements) + call create_surface_mesh(surface_mesh, surface_nodes, mesh, surface_element_list, name=trim(mesh%name)//"ToshisMesh") -end subroutine melt_surf_mesh + end subroutine melt_surf_mesh -real function setnan(arg) - real :: arg - setnan = sqrt(arg) -end function + real function setnan(arg) + real :: arg + setnan = sqrt(arg) + end function -real function calc_area2(positions,nodes) - type(vector_field), pointer :: positions - integer, dimension(2) :: nodes - real, dimension(2) :: coord1,coord2 + real function calc_area2(positions,nodes) + type(vector_field), pointer :: positions + integer, dimension(2) :: nodes + real, dimension(2) :: coord1,coord2 ! real :: area - coord1 = node_val(positions,nodes(1)) - coord2 = node_val(positions,nodes(2)) + coord1 = node_val(positions,nodes(1)) + coord2 = node_val(positions,nodes(2)) - calc_area2 = (sum((coord2 - coord1)**2))**0.5 + calc_area2 = (sum((coord2 - coord1)**2))**0.5 -end function + end function -real function calc_area3(positions,nodes) - type(vector_field), pointer :: positions - integer, dimension(3) :: nodes - real, dimension(3) :: coord1,coord2,coord3 - real :: a,b,c,s + real function calc_area3(positions,nodes) + type(vector_field), pointer :: positions + integer, dimension(3) :: nodes + real, dimension(3) :: coord1,coord2,coord3 + real :: a,b,c,s ! real :: area - coord1 = node_val(positions,nodes(1)) - coord2 = node_val(positions,nodes(2)) - coord3 = node_val(positions,nodes(3)) + coord1 = node_val(positions,nodes(1)) + coord2 = node_val(positions,nodes(2)) + coord3 = node_val(positions,nodes(3)) ! Use Heron's formula to calculate the area of triangle - a = (sum((coord2 - coord1)**2))**0.5 - b = (sum((coord3 - coord1)**2))**0.5 - c = (sum((coord2 - coord3)**2))**0.5 - s = 0.5*(a+b+c) - calc_area3 = (s*(s-a)*(s-b)*(s-c))**0.5 + a = (sum((coord2 - coord1)**2))**0.5 + b = (sum((coord3 - coord1)**2))**0.5 + c = (sum((coord2 - coord3)**2))**0.5 + s = 0.5*(a+b+c) + calc_area3 = (s*(s-a)*(s-b)*(s-c))**0.5 -end function + end function end module iceshelf_meltrate_surf_normal diff --git a/parameterisation/k_epsilon.F90 b/parameterisation/k_epsilon.F90 index 81fd5b7f23..f9120b0f6d 100644 --- a/parameterisation/k_epsilon.F90 +++ b/parameterisation/k_epsilon.F90 @@ -29,1337 +29,1337 @@ module k_epsilon - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN, timestep, current_time - use fldebug - use futils, only: int2str - use vector_tools - use quadrature - use spud - use sparse_tools - use elements - use fetools - use parallel_fields - use fields - use state_module - use boundary_conditions - use vtk_interfaces - use field_derivatives - use field_options - use sparsity_patterns_meshes - use state_fields_module - use surface_integrals - use solvers - use smoothing_module - - implicit none - - private - - ! locally allocatad fields - real, save :: fields_min = 1.0e-11 - logical, save :: low_Re = .false. - - public :: keps_advdif_diagnostics, keps_momentum_diagnostics, keps_bcs, & - & k_epsilon_check_options, tensor_inner_product - - ! Outline: - ! - call diagnostics to obtain source terms and calculate eddy viscosity - ! - after each scalar field solve recalculates the eddy viscosity - ! - wall functions are added to selected boundaries in keps_bcs + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN, timestep, current_time + use fldebug + use futils, only: int2str + use vector_tools + use quadrature + use spud + use sparse_tools + use elements + use fetools + use parallel_fields + use fields + use state_module + use boundary_conditions + use vtk_interfaces + use field_derivatives + use field_options + use sparsity_patterns_meshes + use state_fields_module + use surface_integrals + use solvers + use smoothing_module + + implicit none + + private + + ! locally allocatad fields + real, save :: fields_min = 1.0e-11 + logical, save :: low_Re = .false. + + public :: keps_advdif_diagnostics, keps_momentum_diagnostics, keps_bcs, & + & k_epsilon_check_options, tensor_inner_product + + ! Outline: + ! - call diagnostics to obtain source terms and calculate eddy viscosity + ! - after each scalar field solve recalculates the eddy viscosity + ! - wall functions are added to selected boundaries in keps_bcs contains -subroutine keps_advdif_diagnostics(state) + subroutine keps_advdif_diagnostics(state) - type(state_type), intent(inout) :: state + type(state_type), intent(inout) :: state - call keps_damping_functions(state, advdif=.true.) - call keps_eddyvisc(state, advdif=.true.) - call keps_diffusion(state) - call keps_tracer_diffusion(state) - call keps_calculate_rhs(state) + call keps_damping_functions(state, advdif=.true.) + call keps_eddyvisc(state, advdif=.true.) + call keps_diffusion(state) + call keps_tracer_diffusion(state) + call keps_calculate_rhs(state) -end subroutine keps_advdif_diagnostics + end subroutine keps_advdif_diagnostics -subroutine keps_momentum_diagnostics(state) + subroutine keps_momentum_diagnostics(state) - type(state_type), intent(inout) :: state + type(state_type), intent(inout) :: state - call keps_damping_functions(state, advdif=.false.) - call keps_eddyvisc(state, advdif=.false.) + call keps_damping_functions(state, advdif=.false.) + call keps_eddyvisc(state, advdif=.false.) -end subroutine keps_momentum_diagnostics + end subroutine keps_momentum_diagnostics !--------------------------------------------------------------------------------! -subroutine keps_damping_functions(state, advdif) - - type(state_type), intent(in) :: state - logical, intent(in) :: advdif - - type(scalar_field), pointer :: f_1, f_2, f_mu, y, dummydensity, density - type(scalar_field) :: k, eps - type(tensor_field), pointer :: bg_visc - integer :: node, stat - real :: f_mu_val, f_1_val, f_2_val, Re_T, R_y, fields_max - character(len=FIELD_NAME_LEN) :: equation_type - character(len=OPTION_PATH_LEN) :: option_path - - ewrite(1,*) 'in keps_damping_functions' - - option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' - - f_1 => extract_scalar_field(state, "f_1") - f_2 => extract_scalar_field(state, "f_2") - f_mu => extract_scalar_field(state, "f_mu") - - ! initialise low_Re damping functions - call set(f_1, 1.0) - call set(f_2, 1.0) - call set(f_mu, 1.0) - - call get_option(trim(state%option_path)// & - & "/subgridscale_parameterisations/k-epsilon/max_damping_value", fields_max) - - ! Low Reynolds damping functions - ! Check for low reynolds boundary condition and calculate damping functions - ! Lam-Bremhorst model (Wilcox 1998 - Turbulence modelling for CFD) - if (low_Re .or. & - have_option(trim(option_path)//"debugging_options/enable_lowRe_damping")) then - - bg_visc => extract_tensor_field(state, "BackgroundViscosity") - y => extract_scalar_field(state, "DistanceToWall", stat = stat) - if (stat /= 0) then - FLAbort("I need the distance to the wall - enable a DistanceToWall field") - end if - - call time_averaged_value(state, k, 'TurbulentKineticEnergy', advdif, option_path) - call time_averaged_value(state, eps, 'TurbulentDissipation', advdif, option_path) - - allocate(dummydensity) - call allocate(dummydensity, f_1%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) - call set(dummydensity, 1.0) - dummydensity%option_path = "" - - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - call get_option(trim(state%option_path)//& - "/vector_field::Velocity/prognostic/equation[0]/name", equation_type) - select case(equation_type) - case("LinearMomentum") - density=>extract_scalar_field(state, "Density") - case("Boussinesq") - density=>dummydensity - case("Drainage") - density=>dummydensity - case default - ! developer error... out of sync options input and code - FLAbort("Unknown equation type for velocity") - end select - - node_loop: do node = 1, node_count(k) - - ! calc of damping values with error catching - if (node_val(bg_visc,1,1,node) <= fields_min) then - f_mu_val = 1.0 - f_1_val = 1.0 - f_2_val = 1.0 - else if (node_val(eps,node) <= fields_min) then - R_y = (node_val(density,node) * node_val(k,node)**0.5 * node_val(y,node)) / & - node_val(bg_visc,1,1,node) - - f_mu_val = (1.0 - exp(- 0.0165*R_y))**2.0 - f_1_val = (0.05/node_val(f_mu,node))**3.0 + 1.0 - f_2_val = 1.0 - else - Re_T = (node_val(density,node) * node_val(k,node)**2.0) / & - (node_val(eps,node) * node_val(bg_visc,1,1,node)) - R_y = (node_val(density,node) * node_val(k,node)**0.5 * node_val(y,node)) / & - node_val(bg_visc,1,1,node) - - f_mu_val = (1.0 - exp(- 0.0165*R_y))**2.0 * (20.5/Re_T + 1.0) - f_1_val = (0.05/f_mu_val)**3.0 + 1.0 - f_2_val = 1.0 - exp(- Re_T**2.0) - end if - - ! limit values of damping functions - call set(f_mu, node, min(f_mu_val, 1.0)) - call set(f_1, node, min(f_1_val, fields_max)) - call set(f_2, node, min(f_2_val, fields_max)) - - end do node_loop - - call deallocate(k) - call deallocate(eps) - call deallocate(dummydensity) - deallocate(dummydensity) - - end if - -end subroutine keps_damping_functions + subroutine keps_damping_functions(state, advdif) + + type(state_type), intent(in) :: state + logical, intent(in) :: advdif + + type(scalar_field), pointer :: f_1, f_2, f_mu, y, dummydensity, density + type(scalar_field) :: k, eps + type(tensor_field), pointer :: bg_visc + integer :: node, stat + real :: f_mu_val, f_1_val, f_2_val, Re_T, R_y, fields_max + character(len=FIELD_NAME_LEN) :: equation_type + character(len=OPTION_PATH_LEN) :: option_path + + ewrite(1,*) 'in keps_damping_functions' + + option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' + + f_1 => extract_scalar_field(state, "f_1") + f_2 => extract_scalar_field(state, "f_2") + f_mu => extract_scalar_field(state, "f_mu") + + ! initialise low_Re damping functions + call set(f_1, 1.0) + call set(f_2, 1.0) + call set(f_mu, 1.0) + + call get_option(trim(state%option_path)// & + & "/subgridscale_parameterisations/k-epsilon/max_damping_value", fields_max) + + ! Low Reynolds damping functions + ! Check for low reynolds boundary condition and calculate damping functions + ! Lam-Bremhorst model (Wilcox 1998 - Turbulence modelling for CFD) + if (low_Re .or. & + have_option(trim(option_path)//"debugging_options/enable_lowRe_damping")) then + + bg_visc => extract_tensor_field(state, "BackgroundViscosity") + y => extract_scalar_field(state, "DistanceToWall", stat = stat) + if (stat /= 0) then + FLAbort("I need the distance to the wall - enable a DistanceToWall field") + end if + + call time_averaged_value(state, k, 'TurbulentKineticEnergy', advdif, option_path) + call time_averaged_value(state, eps, 'TurbulentDissipation', advdif, option_path) + + allocate(dummydensity) + call allocate(dummydensity, f_1%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) + call set(dummydensity, 1.0) + dummydensity%option_path = "" + + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + call get_option(trim(state%option_path)//& + "/vector_field::Velocity/prognostic/equation[0]/name", equation_type) + select case(equation_type) + case("LinearMomentum") + density=>extract_scalar_field(state, "Density") + case("Boussinesq") + density=>dummydensity + case("Drainage") + density=>dummydensity + case default + ! developer error... out of sync options input and code + FLAbort("Unknown equation type for velocity") + end select + + node_loop: do node = 1, node_count(k) + + ! calc of damping values with error catching + if (node_val(bg_visc,1,1,node) <= fields_min) then + f_mu_val = 1.0 + f_1_val = 1.0 + f_2_val = 1.0 + else if (node_val(eps,node) <= fields_min) then + R_y = (node_val(density,node) * node_val(k,node)**0.5 * node_val(y,node)) / & + node_val(bg_visc,1,1,node) + + f_mu_val = (1.0 - exp(- 0.0165*R_y))**2.0 + f_1_val = (0.05/node_val(f_mu,node))**3.0 + 1.0 + f_2_val = 1.0 + else + Re_T = (node_val(density,node) * node_val(k,node)**2.0) / & + (node_val(eps,node) * node_val(bg_visc,1,1,node)) + R_y = (node_val(density,node) * node_val(k,node)**0.5 * node_val(y,node)) / & + node_val(bg_visc,1,1,node) + + f_mu_val = (1.0 - exp(- 0.0165*R_y))**2.0 * (20.5/Re_T + 1.0) + f_1_val = (0.05/f_mu_val)**3.0 + 1.0 + f_2_val = 1.0 - exp(- Re_T**2.0) + end if + + ! limit values of damping functions + call set(f_mu, node, min(f_mu_val, 1.0)) + call set(f_1, node, min(f_1_val, fields_max)) + call set(f_2, node, min(f_2_val, fields_max)) + + end do node_loop + + call deallocate(k) + call deallocate(eps) + call deallocate(dummydensity) + deallocate(dummydensity) + + end if + + end subroutine keps_damping_functions !------------------------------------------------------------------------------! -subroutine keps_calculate_rhs(state) - - type(state_type), intent(inout) :: state - - type(scalar_field), dimension(3) :: src_abs_terms - type(scalar_field), dimension(2) :: fields - type(scalar_field), pointer :: src, abs, f_1, f_2, debug - type(scalar_field) :: src_to_abs, vfrac - type(vector_field), pointer :: x, u, g - type(scalar_field), pointer :: dummydensity, density, buoyancy_density, scalar_eddy_visc - integer :: i, ele, term, stat - real :: g_magnitude, c_eps_1, c_eps_2, sigma_p - logical :: have_buoyancy_turbulence = .true., lump_mass, multiphase - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN), dimension(2) :: field_names - character(len=FIELD_NAME_LEN) :: equation_type, implementation - - type(vector_field) :: bc_value - integer, dimension(:,:), allocatable :: bc_type - logical :: dg_velocity, dg_keps - - option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' - - if (.not. have_option(trim(option_path))) then - return - end if - - ewrite(1,*) 'In calculate k-epsilon rhs' - - ! get model constants - call get_option(trim(option_path)//'/C_eps_1', c_eps_1, default = 1.44) - call get_option(trim(option_path)//'/C_eps_2', c_eps_2, default = 1.92) - call get_option(trim(option_path)//'/sigma_p', sigma_p, default = 1.0) - - ! get field data - x => extract_vector_field(state, "Coordinate") - u => extract_vector_field(state, "NonlinearVelocity") - scalar_eddy_visc => extract_scalar_field(state, "ScalarEddyViscosity") - f_1 => extract_scalar_field(state, "f_1") - f_2 => extract_scalar_field(state, "f_2") - g => extract_vector_field(state, "GravityDirection", stat) - call get_option('/physical_parameters/gravity/magnitude', g_magnitude, stat) - if (stat /= 0) then - have_buoyancy_turbulence = .false. - end if - - allocate(dummydensity) - call allocate(dummydensity, X%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) - call set(dummydensity, 1.0) - dummydensity%option_path = "" - dg_velocity = continuity(u)<0 - - !! required for dg gradient calculation of u - if(dg_velocity) then - allocate(bc_type(u%dim, 1:surface_element_count(u))) - call get_entire_boundary_condition(u, (/"weakdirichlet"/), bc_value, bc_type) - end if - - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - call get_option(trim(state%option_path)//& - "/vector_field::Velocity/prognostic/equation[0]/name", equation_type) - select case(equation_type) - case("LinearMomentum") - density=>extract_scalar_field(state, "Density") - case("Boussinesq") - density=>dummydensity - case("Drainage") - density=>dummydensity - case default - ! developer error... out of sync options input and code - FLAbort("Unknown equation type for velocity") - end select - - if(have_buoyancy_turbulence) then - buoyancy_density => extract_scalar_field(state, 'VelocityBuoyancyDensity') - else - buoyancy_density => dummydensity - end if - - ! PhaseVolumeFraction for multiphase flow simulations - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - multiphase = .true. - call time_averaged_value(state, vfrac, "PhaseVolumeFraction", .true., option_path) - else - multiphase = .false. - end if - - field_names(1) = 'TurbulentKineticEnergy' - field_names(2) = 'TurbulentDissipation' - - field_loop: do i = 1, 2 - if (have_option(trim(option_path)//'scalar_field::'// & - trim(field_names(i))//'/prescribed')) then - cycle - end if - - !----------------------------------------------------------------------------------- - - ! Setup - src => extract_scalar_field(state, trim(field_names(i))//"Source") - abs => extract_scalar_field(state, trim(field_names(i))//"Absorption") - - call time_averaged_value(state, fields(1), trim(field_names(i)), .true., option_path) - call time_averaged_value(state, fields(2), trim(field_names(3-i)), .true., option_path) - - call allocate(src_abs_terms(1), fields(1)%mesh, name="production_term") - call allocate(src_abs_terms(2), fields(1)%mesh, name="destruction_term") - call allocate(src_abs_terms(3), fields(1)%mesh, name="buoyancy_term") - call zero(src_abs_terms(1)); call zero(src_abs_terms(2)); call zero(src_abs_terms(3)) - call zero(src); call zero(abs) - - !----------------------------------------------------------------------------------- - - ! Check if k and epsilon are on a discontinuous mesh. - ! It is currently assumed here that both fields are on the same mesh. - dg_keps = continuity(fields(1))<0 - - ! Assembly loop - do ele = 1, ele_count(fields(1)) - ! In parallel, we construct terms on elements we own and those in - ! the L1 element halo. - ! This is because we need neighbour info to determin jumps between elements and - ! calculate a dg gradient. - ! Note that element_neighbour_owned(u, ele) may return .false. if - ! ele is owned. For example, if ele is the only owned element on - ! this process. Hence we have to check for element ownership - ! directly as well. - if (.not.dg_keps.or.element_neighbour_owned(u, ele).or.element_owned(u, ele)) then - call assemble_rhs_ele(src_abs_terms, fields(i), fields(3-i), scalar_eddy_visc, u, & - density, buoyancy_density, have_buoyancy_turbulence, g, g_magnitude, multiphase, & - vfrac, x, c_eps_1, c_eps_2, sigma_p, f_1, f_2, ele, i, bc_value, bc_type) - end if - end do - - ! halo update to fill in halo_2 values with a dg velocity - if (dg_keps) then - do term = 1, 3 - call halo_update(src_abs_terms(term)) - end do - end if - - ! For non-DG we apply inverse mass globally - if(continuity(fields(1))>=0) then - lump_mass = have_option(trim(option_path)//'mass_terms/lump_mass') - do term = 1, 3 - call solve_cg_inv_mass(state, src_abs_terms(term), lump_mass, option_path) - end do - end if - !----------------------------------------------------------------------------------- - - ! Source disabling for debugging purposes - do term = 1, 3 - if(have_option(trim(option_path)//'debugging_options/disable_'//& - trim(src_abs_terms(term)%name))) then - call zero(src_abs_terms(term)) - end if - end do - !----------------------------------------------------------------------------------- - - ! Produce debugging output - do term = 1, 3 - debug => extract_scalar_field(state, & - trim(field_names(i))//"_"//trim(src_abs_terms(term)%name), stat) - if (stat == 0) then - call set(debug, src_abs_terms(term)) - end if - end do - !----------------------------------------------------------------------------------- - - ! Implement terms as source or absorbtion - do term = 1, 3 - call get_option(trim(option_path)//& - 'time_discretisation/source_term_implementation/'//& - trim(src_abs_terms(term)%name), implementation) - select case(implementation) - case("source") - call addto(src, src_abs_terms(term)) - case("absorbtion") - call allocate(src_to_abs, fields(1)%mesh, name='SourceToAbsorbtion') - call set(src_to_abs, fields(1)) - where (src_to_abs%val >= fields_min) - src_to_abs%val=1./src_to_abs%val - elsewhere - src_to_abs%val=1./fields_min - end where - call scale(src_abs_terms(term), src_to_abs) - call addto(abs, src_abs_terms(term), -1.0) - call deallocate(src_to_abs) - case default - ! developer error... out of sync options input and code - FLAbort("Unknown implementation type for k-epsilon source terms") - end select - end do - !----------------------------------------------------------------------------------- - - ! This allows user-specified source and absorption terms, so that an MMS test can be - ! set up. - debug => extract_scalar_field(state, & - trim(field_names(i))//"PrescribedSource", stat) - if (stat == 0) then - call addto(src, debug) - end if - !----------------------------------------------------------------------------------- - - ! Deallocate fields - do term = 1, 3 - call deallocate(src_abs_terms(term)) - end do - call deallocate(fields(1)) - call deallocate(fields(2)) - - end do field_loop - - !! deallocate velocity bc_type - if(dg_velocity) then - deallocate(bc_type) - call deallocate(bc_value) - end if - call deallocate(dummydensity) - deallocate(dummydensity) - - if(multiphase) then - call deallocate(vfrac) - end if - -end subroutine keps_calculate_rhs + subroutine keps_calculate_rhs(state) + + type(state_type), intent(inout) :: state + + type(scalar_field), dimension(3) :: src_abs_terms + type(scalar_field), dimension(2) :: fields + type(scalar_field), pointer :: src, abs, f_1, f_2, debug + type(scalar_field) :: src_to_abs, vfrac + type(vector_field), pointer :: x, u, g + type(scalar_field), pointer :: dummydensity, density, buoyancy_density, scalar_eddy_visc + integer :: i, ele, term, stat + real :: g_magnitude, c_eps_1, c_eps_2, sigma_p + logical :: have_buoyancy_turbulence = .true., lump_mass, multiphase + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN), dimension(2) :: field_names + character(len=FIELD_NAME_LEN) :: equation_type, implementation + + type(vector_field) :: bc_value + integer, dimension(:,:), allocatable :: bc_type + logical :: dg_velocity, dg_keps + + option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' + + if (.not. have_option(trim(option_path))) then + return + end if + + ewrite(1,*) 'In calculate k-epsilon rhs' + + ! get model constants + call get_option(trim(option_path)//'/C_eps_1', c_eps_1, default = 1.44) + call get_option(trim(option_path)//'/C_eps_2', c_eps_2, default = 1.92) + call get_option(trim(option_path)//'/sigma_p', sigma_p, default = 1.0) + + ! get field data + x => extract_vector_field(state, "Coordinate") + u => extract_vector_field(state, "NonlinearVelocity") + scalar_eddy_visc => extract_scalar_field(state, "ScalarEddyViscosity") + f_1 => extract_scalar_field(state, "f_1") + f_2 => extract_scalar_field(state, "f_2") + g => extract_vector_field(state, "GravityDirection", stat) + call get_option('/physical_parameters/gravity/magnitude', g_magnitude, stat) + if (stat /= 0) then + have_buoyancy_turbulence = .false. + end if + + allocate(dummydensity) + call allocate(dummydensity, X%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) + call set(dummydensity, 1.0) + dummydensity%option_path = "" + dg_velocity = continuity(u)<0 + + !! required for dg gradient calculation of u + if(dg_velocity) then + allocate(bc_type(u%dim, 1:surface_element_count(u))) + call get_entire_boundary_condition(u, (/"weakdirichlet"/), bc_value, bc_type) + end if + + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + call get_option(trim(state%option_path)//& + "/vector_field::Velocity/prognostic/equation[0]/name", equation_type) + select case(equation_type) + case("LinearMomentum") + density=>extract_scalar_field(state, "Density") + case("Boussinesq") + density=>dummydensity + case("Drainage") + density=>dummydensity + case default + ! developer error... out of sync options input and code + FLAbort("Unknown equation type for velocity") + end select + + if(have_buoyancy_turbulence) then + buoyancy_density => extract_scalar_field(state, 'VelocityBuoyancyDensity') + else + buoyancy_density => dummydensity + end if + + ! PhaseVolumeFraction for multiphase flow simulations + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + multiphase = .true. + call time_averaged_value(state, vfrac, "PhaseVolumeFraction", .true., option_path) + else + multiphase = .false. + end if + + field_names(1) = 'TurbulentKineticEnergy' + field_names(2) = 'TurbulentDissipation' + + field_loop: do i = 1, 2 + if (have_option(trim(option_path)//'scalar_field::'// & + trim(field_names(i))//'/prescribed')) then + cycle + end if + + !----------------------------------------------------------------------------------- + + ! Setup + src => extract_scalar_field(state, trim(field_names(i))//"Source") + abs => extract_scalar_field(state, trim(field_names(i))//"Absorption") + + call time_averaged_value(state, fields(1), trim(field_names(i)), .true., option_path) + call time_averaged_value(state, fields(2), trim(field_names(3-i)), .true., option_path) + + call allocate(src_abs_terms(1), fields(1)%mesh, name="production_term") + call allocate(src_abs_terms(2), fields(1)%mesh, name="destruction_term") + call allocate(src_abs_terms(3), fields(1)%mesh, name="buoyancy_term") + call zero(src_abs_terms(1)); call zero(src_abs_terms(2)); call zero(src_abs_terms(3)) + call zero(src); call zero(abs) + + !----------------------------------------------------------------------------------- + + ! Check if k and epsilon are on a discontinuous mesh. + ! It is currently assumed here that both fields are on the same mesh. + dg_keps = continuity(fields(1))<0 + + ! Assembly loop + do ele = 1, ele_count(fields(1)) + ! In parallel, we construct terms on elements we own and those in + ! the L1 element halo. + ! This is because we need neighbour info to determin jumps between elements and + ! calculate a dg gradient. + ! Note that element_neighbour_owned(u, ele) may return .false. if + ! ele is owned. For example, if ele is the only owned element on + ! this process. Hence we have to check for element ownership + ! directly as well. + if (.not.dg_keps.or.element_neighbour_owned(u, ele).or.element_owned(u, ele)) then + call assemble_rhs_ele(src_abs_terms, fields(i), fields(3-i), scalar_eddy_visc, u, & + density, buoyancy_density, have_buoyancy_turbulence, g, g_magnitude, multiphase, & + vfrac, x, c_eps_1, c_eps_2, sigma_p, f_1, f_2, ele, i, bc_value, bc_type) + end if + end do + + ! halo update to fill in halo_2 values with a dg velocity + if (dg_keps) then + do term = 1, 3 + call halo_update(src_abs_terms(term)) + end do + end if + + ! For non-DG we apply inverse mass globally + if(continuity(fields(1))>=0) then + lump_mass = have_option(trim(option_path)//'mass_terms/lump_mass') + do term = 1, 3 + call solve_cg_inv_mass(state, src_abs_terms(term), lump_mass, option_path) + end do + end if + !----------------------------------------------------------------------------------- + + ! Source disabling for debugging purposes + do term = 1, 3 + if(have_option(trim(option_path)//'debugging_options/disable_'//& + trim(src_abs_terms(term)%name))) then + call zero(src_abs_terms(term)) + end if + end do + !----------------------------------------------------------------------------------- + + ! Produce debugging output + do term = 1, 3 + debug => extract_scalar_field(state, & + trim(field_names(i))//"_"//trim(src_abs_terms(term)%name), stat) + if (stat == 0) then + call set(debug, src_abs_terms(term)) + end if + end do + !----------------------------------------------------------------------------------- + + ! Implement terms as source or absorbtion + do term = 1, 3 + call get_option(trim(option_path)//& + 'time_discretisation/source_term_implementation/'//& + trim(src_abs_terms(term)%name), implementation) + select case(implementation) + case("source") + call addto(src, src_abs_terms(term)) + case("absorbtion") + call allocate(src_to_abs, fields(1)%mesh, name='SourceToAbsorbtion') + call set(src_to_abs, fields(1)) + where (src_to_abs%val >= fields_min) + src_to_abs%val=1./src_to_abs%val + elsewhere + src_to_abs%val=1./fields_min + end where + call scale(src_abs_terms(term), src_to_abs) + call addto(abs, src_abs_terms(term), -1.0) + call deallocate(src_to_abs) + case default + ! developer error... out of sync options input and code + FLAbort("Unknown implementation type for k-epsilon source terms") + end select + end do + !----------------------------------------------------------------------------------- + + ! This allows user-specified source and absorption terms, so that an MMS test can be + ! set up. + debug => extract_scalar_field(state, & + trim(field_names(i))//"PrescribedSource", stat) + if (stat == 0) then + call addto(src, debug) + end if + !----------------------------------------------------------------------------------- + + ! Deallocate fields + do term = 1, 3 + call deallocate(src_abs_terms(term)) + end do + call deallocate(fields(1)) + call deallocate(fields(2)) + + end do field_loop + + !! deallocate velocity bc_type + if(dg_velocity) then + deallocate(bc_type) + call deallocate(bc_value) + end if + call deallocate(dummydensity) + deallocate(dummydensity) + + if(multiphase) then + call deallocate(vfrac) + end if + + end subroutine keps_calculate_rhs !------------------------------------------------------------------------------! -subroutine assemble_rhs_ele(src_abs_terms, k, eps, scalar_eddy_visc, u, density, & - buoyancy_density, have_buoyancy_turbulence, g, g_magnitude, multiphase, vfrac, & - X, c_eps_1, c_eps_2, sigma_p, f_1, f_2, ele, field_id, bc_value, bc_type) - - type(scalar_field), dimension(3), intent(inout) :: src_abs_terms - type(scalar_field), intent(in) :: k, eps, scalar_eddy_visc, f_1, f_2, vfrac - type(vector_field), intent(in) :: X, u, g - type(scalar_field), intent(in) :: density, buoyancy_density - real, intent(in) :: g_magnitude, c_eps_1, c_eps_2, sigma_p - logical, intent(in) :: have_buoyancy_turbulence, multiphase - integer, intent(in) :: ele, field_id - - real, dimension(ele_loc(k, ele), ele_ngi(k, ele), x%dim) :: dshape - real, dimension(ele_ngi(k, ele)) :: detwei, rhs, scalar_eddy_visc_ele, k_ele, eps_ele - real, dimension(3, ele_loc(k, ele)) :: rhs_addto - integer, dimension(ele_loc(k, ele)) :: nodes - real, dimension(ele_loc(k, ele), ele_loc(k, ele)) :: invmass - real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: reynolds_stress, grad_u - type(element_type), pointer :: shape, shape_u - integer :: term, ngi, dim, gi, i - - type(vector_field), intent(in) :: bc_value - integer, dimension(:,:), allocatable, intent(in) :: bc_type - - real, dimension(:, :, :), allocatable :: dshape_u - - ! For buoyancy turbulence stuff - real, dimension(u%dim, ele_ngi(u, ele)) :: vector, u_quad, g_quad - real :: u_z, u_xy - real, dimension(ele_ngi(u, ele)) :: scalar, c_eps_3 - type(element_type), pointer :: shape_density - real, dimension(:, :, :), allocatable :: dshape_density - - shape => ele_shape(k, ele) - nodes = ele_nodes(k, ele) - - call transform_to_physical( X, ele, shape, dshape=dshape, detwei=detwei ) - - ! get bounded values of k and epsilon for source terms - ! this doesn't change the field values of k and epsilon - k_ele = ele_val_at_quad(k,ele) - eps_ele = ele_val_at_quad(eps, ele) - ngi = ele_ngi(u, ele) - do gi = 1, ngi - k_ele(gi) = max(k_ele(gi), fields_min) - eps_ele(gi) = max(eps_ele(gi), fields_min) - end do - - ! Compute Reynolds stress - if(.not.(u%mesh == k%mesh)) then - shape_u => ele_shape(u, ele) - allocate(dshape_u(ele_loc(u, ele), ele_ngi(u, ele), X%dim)) - call transform_to_physical( X, ele, shape_u, dshape=dshape_u ) - grad_u = ele_grad_at_quad(u, ele, dshape_u) - deallocate(dshape_u) - else - if(continuity(u)<0) then - grad_u = dg_ele_grad_at_quad(u, ele, shape, X, bc_value, bc_type) - else - grad_u = ele_grad_at_quad(u, ele, dshape) - end if - end if - - scalar_eddy_visc_ele = ele_val_at_quad(scalar_eddy_visc, ele) - dim = u%dim - do gi = 1, ngi - reynolds_stress(:,:,gi) = scalar_eddy_visc_ele(gi)*(grad_u(:,:,gi) + transpose(grad_u(:,:,gi))) - end do - do i = 1, dim - reynolds_stress(i,i,:) = reynolds_stress(i,i,:) - (2./3.)*k_ele*ele_val_at_quad(density, ele) - end do - - ! Compute P - rhs = tensor_inner_product(reynolds_stress, grad_u) - if (field_id==2) then - rhs = rhs*c_eps_1*ele_val_at_quad(f_1,ele)*eps_ele/k_ele - end if - if(multiphase) then - rhs_addto(1,:) = shape_rhs(shape, detwei*rhs*ele_val_at_quad(vfrac,ele)) - else - rhs_addto(1,:) = shape_rhs(shape, detwei*rhs) - end if - - ! A: - rhs = -1.0*eps_ele*ele_val_at_quad(density, ele) - if (field_id==2) then - rhs = rhs*c_eps_2*ele_val_at_quad(f_2,ele)*eps_ele/k_ele - end if - if(multiphase) then - rhs_addto(2,:) = shape_rhs(shape, detwei*rhs*ele_val_at_quad(vfrac,ele)) - else - rhs_addto(2,:) = shape_rhs(shape, detwei*rhs) - end if - - ! Gk: - ! Calculate buoyancy turbulence term and add to addto array - if(have_buoyancy_turbulence) then - - ! calculate scalar and vector components of the source term - allocate(dshape_density(ele_loc(buoyancy_density, ele), ele_ngi(buoyancy_density, ele), X%dim)) - if(.not.(buoyancy_density%mesh == k%mesh)) then - shape_density => ele_shape(buoyancy_density, ele) - call transform_to_physical( X, ele, shape_density, dshape=dshape_density ) - else - dshape_density = dshape - end if - - scalar = -1.0*g_magnitude*ele_val_at_quad(scalar_eddy_visc, ele)/(sigma_p*ele_val_at_quad(density,ele)) - vector = ele_val_at_quad(g, ele)*ele_grad_at_quad(buoyancy_density, ele, dshape_density) - - ! multiply vector component by scalar and sum across dimensions - note that the - ! vector part has been multiplied by the gravitational direction so that it is - ! zero everywhere apart from in this direction. - do gi = 1, ngi - scalar(gi) = sum(scalar(gi) * vector(:, gi)) - end do - - if (field_id == 2) then - ! calculate c_eps_3 = tanh(v/u) - g_quad = ele_val_at_quad(g, ele) - u_quad = ele_val_at_quad(u, ele) - do gi = 1, ngi - ! get components of velocity in direction of gravity and in other directions - u_z = dot_product(g_quad(:, gi), u_quad(:, gi)) - u_xy = (norm2(u_quad(:, gi))**2.0 - u_z**2.0)**0.5 - if (u_xy > fields_min) then - c_eps_3(gi) = tanh(u_z/u_xy) - else - c_eps_3(gi) = 1.0 - end if - end do - scalar = scalar*c_eps_1*ele_val_at_quad(f_1,ele)*c_eps_3*eps_ele/k_ele - end if - - ! multiply by determinate weights, integrate and assign to rhs - if(multiphase) then - rhs_addto(3,:) = shape_rhs(shape, scalar * detwei * ele_val_at_quad(vfrac,ele)) - else - rhs_addto(3,:) = shape_rhs(shape, scalar * detwei) - end if - - deallocate(dshape_density) - - else - ! No buoyancy term, so set this part of the array to zero. - rhs_addto(3,:) = 0.0 - end if - - ! In the DG case we apply the inverse mass locally. - if(continuity(k)<0) then - invmass = inverse(shape_shape(shape, shape, detwei)) - do term = 1, 3 - rhs_addto(term,:) = matmul(rhs_addto(term,:), invmass) - end do - end if - - do term = 1, 3 - call addto(src_abs_terms(term), nodes, rhs_addto(term,:)) - end do - -end subroutine assemble_rhs_ele + subroutine assemble_rhs_ele(src_abs_terms, k, eps, scalar_eddy_visc, u, density, & + buoyancy_density, have_buoyancy_turbulence, g, g_magnitude, multiphase, vfrac, & + X, c_eps_1, c_eps_2, sigma_p, f_1, f_2, ele, field_id, bc_value, bc_type) + + type(scalar_field), dimension(3), intent(inout) :: src_abs_terms + type(scalar_field), intent(in) :: k, eps, scalar_eddy_visc, f_1, f_2, vfrac + type(vector_field), intent(in) :: X, u, g + type(scalar_field), intent(in) :: density, buoyancy_density + real, intent(in) :: g_magnitude, c_eps_1, c_eps_2, sigma_p + logical, intent(in) :: have_buoyancy_turbulence, multiphase + integer, intent(in) :: ele, field_id + + real, dimension(ele_loc(k, ele), ele_ngi(k, ele), x%dim) :: dshape + real, dimension(ele_ngi(k, ele)) :: detwei, rhs, scalar_eddy_visc_ele, k_ele, eps_ele + real, dimension(3, ele_loc(k, ele)) :: rhs_addto + integer, dimension(ele_loc(k, ele)) :: nodes + real, dimension(ele_loc(k, ele), ele_loc(k, ele)) :: invmass + real, dimension(u%dim, u%dim, ele_ngi(u, ele)) :: reynolds_stress, grad_u + type(element_type), pointer :: shape, shape_u + integer :: term, ngi, dim, gi, i + + type(vector_field), intent(in) :: bc_value + integer, dimension(:,:), allocatable, intent(in) :: bc_type + + real, dimension(:, :, :), allocatable :: dshape_u + + ! For buoyancy turbulence stuff + real, dimension(u%dim, ele_ngi(u, ele)) :: vector, u_quad, g_quad + real :: u_z, u_xy + real, dimension(ele_ngi(u, ele)) :: scalar, c_eps_3 + type(element_type), pointer :: shape_density + real, dimension(:, :, :), allocatable :: dshape_density + + shape => ele_shape(k, ele) + nodes = ele_nodes(k, ele) + + call transform_to_physical( X, ele, shape, dshape=dshape, detwei=detwei ) + + ! get bounded values of k and epsilon for source terms + ! this doesn't change the field values of k and epsilon + k_ele = ele_val_at_quad(k,ele) + eps_ele = ele_val_at_quad(eps, ele) + ngi = ele_ngi(u, ele) + do gi = 1, ngi + k_ele(gi) = max(k_ele(gi), fields_min) + eps_ele(gi) = max(eps_ele(gi), fields_min) + end do + + ! Compute Reynolds stress + if(.not.(u%mesh == k%mesh)) then + shape_u => ele_shape(u, ele) + allocate(dshape_u(ele_loc(u, ele), ele_ngi(u, ele), X%dim)) + call transform_to_physical( X, ele, shape_u, dshape=dshape_u ) + grad_u = ele_grad_at_quad(u, ele, dshape_u) + deallocate(dshape_u) + else + if(continuity(u)<0) then + grad_u = dg_ele_grad_at_quad(u, ele, shape, X, bc_value, bc_type) + else + grad_u = ele_grad_at_quad(u, ele, dshape) + end if + end if + + scalar_eddy_visc_ele = ele_val_at_quad(scalar_eddy_visc, ele) + dim = u%dim + do gi = 1, ngi + reynolds_stress(:,:,gi) = scalar_eddy_visc_ele(gi)*(grad_u(:,:,gi) + transpose(grad_u(:,:,gi))) + end do + do i = 1, dim + reynolds_stress(i,i,:) = reynolds_stress(i,i,:) - (2./3.)*k_ele*ele_val_at_quad(density, ele) + end do + + ! Compute P + rhs = tensor_inner_product(reynolds_stress, grad_u) + if (field_id==2) then + rhs = rhs*c_eps_1*ele_val_at_quad(f_1,ele)*eps_ele/k_ele + end if + if(multiphase) then + rhs_addto(1,:) = shape_rhs(shape, detwei*rhs*ele_val_at_quad(vfrac,ele)) + else + rhs_addto(1,:) = shape_rhs(shape, detwei*rhs) + end if + + ! A: + rhs = -1.0*eps_ele*ele_val_at_quad(density, ele) + if (field_id==2) then + rhs = rhs*c_eps_2*ele_val_at_quad(f_2,ele)*eps_ele/k_ele + end if + if(multiphase) then + rhs_addto(2,:) = shape_rhs(shape, detwei*rhs*ele_val_at_quad(vfrac,ele)) + else + rhs_addto(2,:) = shape_rhs(shape, detwei*rhs) + end if + + ! Gk: + ! Calculate buoyancy turbulence term and add to addto array + if(have_buoyancy_turbulence) then + + ! calculate scalar and vector components of the source term + allocate(dshape_density(ele_loc(buoyancy_density, ele), ele_ngi(buoyancy_density, ele), X%dim)) + if(.not.(buoyancy_density%mesh == k%mesh)) then + shape_density => ele_shape(buoyancy_density, ele) + call transform_to_physical( X, ele, shape_density, dshape=dshape_density ) + else + dshape_density = dshape + end if + + scalar = -1.0*g_magnitude*ele_val_at_quad(scalar_eddy_visc, ele)/(sigma_p*ele_val_at_quad(density,ele)) + vector = ele_val_at_quad(g, ele)*ele_grad_at_quad(buoyancy_density, ele, dshape_density) + + ! multiply vector component by scalar and sum across dimensions - note that the + ! vector part has been multiplied by the gravitational direction so that it is + ! zero everywhere apart from in this direction. + do gi = 1, ngi + scalar(gi) = sum(scalar(gi) * vector(:, gi)) + end do + + if (field_id == 2) then + ! calculate c_eps_3 = tanh(v/u) + g_quad = ele_val_at_quad(g, ele) + u_quad = ele_val_at_quad(u, ele) + do gi = 1, ngi + ! get components of velocity in direction of gravity and in other directions + u_z = dot_product(g_quad(:, gi), u_quad(:, gi)) + u_xy = (norm2(u_quad(:, gi))**2.0 - u_z**2.0)**0.5 + if (u_xy > fields_min) then + c_eps_3(gi) = tanh(u_z/u_xy) + else + c_eps_3(gi) = 1.0 + end if + end do + scalar = scalar*c_eps_1*ele_val_at_quad(f_1,ele)*c_eps_3*eps_ele/k_ele + end if + + ! multiply by determinate weights, integrate and assign to rhs + if(multiphase) then + rhs_addto(3,:) = shape_rhs(shape, scalar * detwei * ele_val_at_quad(vfrac,ele)) + else + rhs_addto(3,:) = shape_rhs(shape, scalar * detwei) + end if + + deallocate(dshape_density) + + else + ! No buoyancy term, so set this part of the array to zero. + rhs_addto(3,:) = 0.0 + end if + + ! In the DG case we apply the inverse mass locally. + if(continuity(k)<0) then + invmass = inverse(shape_shape(shape, shape, detwei)) + do term = 1, 3 + rhs_addto(term,:) = matmul(rhs_addto(term,:), invmass) + end do + end if + + do term = 1, 3 + call addto(src_abs_terms(term), nodes, rhs_addto(term,:)) + end do + + end subroutine assemble_rhs_ele !------------------------------------------------------------------------------! ! calculate inner product for 2xN matrices dim,dim,N ! !------------------------------------------------------------------------------! -function tensor_inner_product(A, B) + function tensor_inner_product(A, B) - real, dimension(:,:,:), intent(in) :: A, B + real, dimension(:,:,:), intent(in) :: A, B - real, dimension(size(A,1), size(A,2), size(A,3)) :: C - real, dimension(size(A,3)) :: tensor_inner_product - integer :: i + real, dimension(size(A,1), size(A,2), size(A,3)) :: C + real, dimension(size(A,3)) :: tensor_inner_product + integer :: i - C = A*B - do i = 1, size(A,3) - tensor_inner_product(i) = sum(C(:,:,i)) - end do + C = A*B + do i = 1, size(A,3) + tensor_inner_product(i) = sum(C(:,:,i)) + end do -end function tensor_inner_product + end function tensor_inner_product !---------- ! eddyvisc calculates the lengthscale and the eddy viscosity ! Eddy viscosity is added to the background viscosity. !---------- -subroutine keps_eddyvisc(state, advdif) - - type(state_type), intent(inout) :: state - logical, intent(in) :: advdif - - type(tensor_field) :: visc_dg - type(tensor_field), pointer :: eddy_visc, viscosity, bg_visc - type(vector_field), pointer :: x, u - type(scalar_field) :: kk, eps - type(scalar_field), pointer :: scalar_eddy_visc, ll, f_mu, density, dummydensity, filter - type(scalar_field) :: ev_rhs - integer :: i, j, ele, stat - - ! Options grabbed from the options tree - real :: c_mu - character(len=OPTION_PATH_LEN) :: option_path - logical :: lump_mass, have_visc = .true. - character(len=FIELD_NAME_LEN) :: equation_type - - option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' - - if (.not. have_option(trim(option_path))) then - return - end if - - ewrite(1,*) "In keps_eddyvisc" - - ! Get model constant - call get_option(trim(option_path)//'/C_mu', c_mu, default = 0.09) - - ! Get field data - call time_averaged_value(state, kk, "TurbulentKineticEnergy", advdif, option_path) - call time_averaged_value(state, eps, "TurbulentDissipation", advdif, option_path) - x => extract_vector_field(state, "Coordinate") - u => extract_vector_field(state, "NonlinearVelocity") - eddy_visc => extract_tensor_field(state, "EddyViscosity") - f_mu => extract_scalar_field(state, "f_mu") - bg_visc => extract_tensor_field(state, "BackgroundViscosity") - scalar_eddy_visc => extract_scalar_field(state, "ScalarEddyViscosity") - ll => extract_scalar_field(state, "LengthScale") - viscosity => extract_tensor_field(state, "Viscosity", stat) - if (stat /= 0) then - have_visc = .false. - end if - - ewrite_minmax(kk) - ewrite_minmax(eps) - ewrite_minmax(scalar_eddy_visc) - - allocate(dummydensity) - call allocate(dummydensity, X%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) - call set(dummydensity, 1.0) - dummydensity%option_path = "" - - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - call get_option(trim(state%option_path)//& - "/vector_field::Velocity/prognostic/equation[0]/name", equation_type) - select case(equation_type) - case("LinearMomentum") - density=>extract_scalar_field(state, "Density") - case("Boussinesq") - density=>dummydensity - case("Drainage") - density=>dummydensity - case default - ! developer error... out of sync options input and code - FLAbort("Unknown equation type for velocity") - end select - - call allocate(ev_rhs, scalar_eddy_visc%mesh, name="EVRHS") - call zero(ev_rhs) - - ! Initialise viscosity to background value - if (have_visc) then - ewrite(1,*) "Entering Initialise Viscosity to Background Viscosity" - ! Checking if the viscosity field is on a discontinuous mesh and the bg_viscosity is on continuous mesh - ! We need to remap before setting the field as the set subroutine does not remap automatically. - if (continuity(viscosity)<0 .and. continuity(bg_visc)>=0) then - ewrite(1,*) "Entering background viscosity remap conditional" - call allocate(visc_dg, viscosity%mesh, "RemappedBackgroundViscosityDG") - call remap_field(bg_visc,visc_dg,stat) - if (stat/=0) then - FLExit('There was some problem remapping the continuous backgroud viscosity to discontinuous mesh') - end if - call set(viscosity, visc_dg) - call deallocate(visc_dg) - else if (continuity(viscosity) == continuity(bg_visc)) then - ewrite(1,*) "Continuity of viscosity is the same as the continuity of bg_visc" - call set(viscosity, bg_visc) - end if - ewrite(1,*) "Exiting initialise viscosity to bg visc" - end if - - ! Compute the length scale diagnostic field here. - do i = 1, node_count(scalar_eddy_visc) - call set(ll, i, max(node_val(kk,i), fields_min)**1.5 / max(node_val(eps,i), fields_min)) - end do - - ! Calculate scalar eddy viscosity by integration over element - do ele = 1, ele_count(scalar_eddy_visc) - call keps_eddyvisc_ele(ele, X, kk, eps, scalar_eddy_visc, f_mu, density, ev_rhs) - end do - - ! For non-DG we apply inverse mass globally - if(continuity(scalar_eddy_visc)>=0) then - lump_mass = have_option(trim(option_path)//'mass_terms/lump_mass') - call solve_cg_inv_mass(state, ev_rhs, lump_mass, option_path) - end if - - ! Allow for prescribed eddy-viscosity - if (.not. have_option(trim(option_path)//'/scalar_field::ScalarEddyViscosity/prescribed')) then - call set(scalar_eddy_visc, ev_rhs) - end if - - ! If VLES then scale by filter function - filter => extract_scalar_field(state, 'VLESFilter', stat) - if (stat == 0) then - call zero(filter) - call vles_filter(filter, scalar_eddy_visc, ll, eps, X) - call scale(scalar_eddy_visc, filter) - end if - - call deallocate(ev_rhs) - call deallocate(kk) - call deallocate(eps) - - call deallocate(dummydensity) - deallocate(dummydensity) - - ewrite(2,*) "Setting k-epsilon eddy-viscosity tensor" - call zero(eddy_visc) - - ! this is skipped if zero_eddy_viscosity is set - this is the easiest way to - ! disable feedback from the k-epsilon model back into the rest of the model - if (.not. have_option(trim(option_path)//'debugging_options/zero_reynolds_stress_tensor')) then - ! Although the k-epsilon model assumes isotropic viscosity all terms of the viscosity tensor are modified - ! because of the way CG method treats the viscosity tensor. - do i = 1, eddy_visc%dim(1) - do j = 1, eddy_visc%dim(1) - call set(eddy_visc, i, j, scalar_eddy_visc) - end do - end do - end if - - ! Add turbulence model contribution to viscosity field - if (have_visc) then - ! Tensor addto subroutine will remap the second tensor to the mesh of tensor1 if they are on different meshes. - ! So we don't need to manually remap in this case. - call addto(viscosity, eddy_visc) - end if - - ewrite_minmax(eddy_visc) - ewrite_minmax(viscosity) - ewrite_minmax(scalar_eddy_visc) - ewrite_minmax(ll) - - contains - - subroutine vles_filter(filter, scalar_eddy_visc, ll, eps, X) - - type(scalar_field), intent(inout) :: scalar_eddy_visc, filter - type(scalar_field), intent(in) :: ll, eps - type(vector_field), intent(in) :: X - type(scalar_field) :: delta - type(patch_type) :: patch - integer :: i, ele - integer, pointer, dimension(:) :: nodes_ev - real, allocatable, dimension(:) :: rhs_addto - real :: f, lcut, lint, lkol - real :: beta=-0.002 ! coefficient calibrated by Speziale (1998) - real :: n=2.0 ! exponent calibrated by Han (2012) - - call allocate(delta, scalar_eddy_visc%mesh, name="FilterWidth") - call zero(delta) + subroutine keps_eddyvisc(state, advdif) - do ele = 1, ele_count(scalar_eddy_visc) - nodes_ev => ele_nodes(scalar_eddy_visc, ele) - allocate(rhs_addto(size(nodes_ev))) - do i=1, size(nodes_ev) - patch = get_patch_ele(scalar_eddy_visc%mesh, nodes_ev(i)) - rhs_addto(i) = sqrt(length_scale_scalar(X, ele))/patch%count - deallocate(patch%elements) - end do - call addto(delta, nodes_ev, rhs_addto) - deallocate(rhs_addto) - end do + type(state_type), intent(inout) :: state + logical, intent(in) :: advdif + + type(tensor_field) :: visc_dg + type(tensor_field), pointer :: eddy_visc, viscosity, bg_visc + type(vector_field), pointer :: x, u + type(scalar_field) :: kk, eps + type(scalar_field), pointer :: scalar_eddy_visc, ll, f_mu, density, dummydensity, filter + type(scalar_field) :: ev_rhs + integer :: i, j, ele, stat + + ! Options grabbed from the options tree + real :: c_mu + character(len=OPTION_PATH_LEN) :: option_path + logical :: lump_mass, have_visc = .true. + character(len=FIELD_NAME_LEN) :: equation_type + + option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' + + if (.not. have_option(trim(option_path))) then + return + end if + + ewrite(1,*) "In keps_eddyvisc" + + ! Get model constant + call get_option(trim(option_path)//'/C_mu', c_mu, default = 0.09) + + ! Get field data + call time_averaged_value(state, kk, "TurbulentKineticEnergy", advdif, option_path) + call time_averaged_value(state, eps, "TurbulentDissipation", advdif, option_path) + x => extract_vector_field(state, "Coordinate") + u => extract_vector_field(state, "NonlinearVelocity") + eddy_visc => extract_tensor_field(state, "EddyViscosity") + f_mu => extract_scalar_field(state, "f_mu") + bg_visc => extract_tensor_field(state, "BackgroundViscosity") + scalar_eddy_visc => extract_scalar_field(state, "ScalarEddyViscosity") + ll => extract_scalar_field(state, "LengthScale") + viscosity => extract_tensor_field(state, "Viscosity", stat) + if (stat /= 0) then + have_visc = .false. + end if + + ewrite_minmax(kk) + ewrite_minmax(eps) + ewrite_minmax(scalar_eddy_visc) + + allocate(dummydensity) + call allocate(dummydensity, X%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) + call set(dummydensity, 1.0) + dummydensity%option_path = "" + + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + call get_option(trim(state%option_path)//& + "/vector_field::Velocity/prognostic/equation[0]/name", equation_type) + select case(equation_type) + case("LinearMomentum") + density=>extract_scalar_field(state, "Density") + case("Boussinesq") + density=>dummydensity + case("Drainage") + density=>dummydensity + case default + ! developer error... out of sync options input and code + FLAbort("Unknown equation type for velocity") + end select + + call allocate(ev_rhs, scalar_eddy_visc%mesh, name="EVRHS") + call zero(ev_rhs) + + ! Initialise viscosity to background value + if (have_visc) then + ewrite(1,*) "Entering Initialise Viscosity to Background Viscosity" + ! Checking if the viscosity field is on a discontinuous mesh and the bg_viscosity is on continuous mesh + ! We need to remap before setting the field as the set subroutine does not remap automatically. + if (continuity(viscosity)<0 .and. continuity(bg_visc)>=0) then + ewrite(1,*) "Entering background viscosity remap conditional" + call allocate(visc_dg, viscosity%mesh, "RemappedBackgroundViscosityDG") + call remap_field(bg_visc,visc_dg,stat) + if (stat/=0) then + FLExit('There was some problem remapping the continuous backgroud viscosity to discontinuous mesh') + end if + call set(viscosity, visc_dg) + call deallocate(visc_dg) + else if (continuity(viscosity) == continuity(bg_visc)) then + ewrite(1,*) "Continuity of viscosity is the same as the continuity of bg_visc" + call set(viscosity, bg_visc) + end if + ewrite(1,*) "Exiting initialise viscosity to bg visc" + end if + ! Compute the length scale diagnostic field here. do i = 1, node_count(scalar_eddy_visc) - ! Nodal values of cutoff, integral and Kolmogorov lengthscales: - lcut = node_val(delta, i) - lint = node_val(ll, i) - lkol = node_val(scalar_eddy_visc, i)**0.75/node_val(eps, i)**0.25 - ! expression for filter in terms of lengthscales: - f = min(1.0, (1.0 - exp(beta*lcut/lkol) )/(1.0 - exp(beta*lint/lkol) ) )**n - call set(filter, i, f) + call set(ll, i, max(node_val(kk,i), fields_min)**1.5 / max(node_val(eps,i), fields_min)) + end do + + ! Calculate scalar eddy viscosity by integration over element + do ele = 1, ele_count(scalar_eddy_visc) + call keps_eddyvisc_ele(ele, X, kk, eps, scalar_eddy_visc, f_mu, density, ev_rhs) end do - call deallocate(delta) + ! For non-DG we apply inverse mass globally + if(continuity(scalar_eddy_visc)>=0) then + lump_mass = have_option(trim(option_path)//'mass_terms/lump_mass') + call solve_cg_inv_mass(state, ev_rhs, lump_mass, option_path) + end if + + ! Allow for prescribed eddy-viscosity + if (.not. have_option(trim(option_path)//'/scalar_field::ScalarEddyViscosity/prescribed')) then + call set(scalar_eddy_visc, ev_rhs) + end if + + ! If VLES then scale by filter function + filter => extract_scalar_field(state, 'VLESFilter', stat) + if (stat == 0) then + call zero(filter) + call vles_filter(filter, scalar_eddy_visc, ll, eps, X) + call scale(scalar_eddy_visc, filter) + end if - end subroutine vles_filter + call deallocate(ev_rhs) + call deallocate(kk) + call deallocate(eps) + + call deallocate(dummydensity) + deallocate(dummydensity) + + ewrite(2,*) "Setting k-epsilon eddy-viscosity tensor" + call zero(eddy_visc) + + ! this is skipped if zero_eddy_viscosity is set - this is the easiest way to + ! disable feedback from the k-epsilon model back into the rest of the model + if (.not. have_option(trim(option_path)//'debugging_options/zero_reynolds_stress_tensor')) then + ! Although the k-epsilon model assumes isotropic viscosity all terms of the viscosity tensor are modified + ! because of the way CG method treats the viscosity tensor. + do i = 1, eddy_visc%dim(1) + do j = 1, eddy_visc%dim(1) + call set(eddy_visc, i, j, scalar_eddy_visc) + end do + end do + end if - subroutine keps_eddyvisc_ele(ele, X, kk, eps, scalar_eddy_visc, f_mu, density, ev_rhs) + ! Add turbulence model contribution to viscosity field + if (have_visc) then + ! Tensor addto subroutine will remap the second tensor to the mesh of tensor1 if they are on different meshes. + ! So we don't need to manually remap in this case. + call addto(viscosity, eddy_visc) + end if - type(vector_field), intent(in) :: x - type(scalar_field), intent(in) :: kk, eps, scalar_eddy_visc, f_mu, density - type(scalar_field), intent(inout):: ev_rhs - integer, intent(in) :: ele + ewrite_minmax(eddy_visc) + ewrite_minmax(viscosity) + ewrite_minmax(scalar_eddy_visc) + ewrite_minmax(ll) + + contains + + subroutine vles_filter(filter, scalar_eddy_visc, ll, eps, X) + + type(scalar_field), intent(inout) :: scalar_eddy_visc, filter + type(scalar_field), intent(in) :: ll, eps + type(vector_field), intent(in) :: X + type(scalar_field) :: delta + type(patch_type) :: patch + integer :: i, ele + integer, pointer, dimension(:) :: nodes_ev + real, allocatable, dimension(:) :: rhs_addto + real :: f, lcut, lint, lkol + real :: beta=-0.002 ! coefficient calibrated by Speziale (1998) + real :: n=2.0 ! exponent calibrated by Han (2012) + + call allocate(delta, scalar_eddy_visc%mesh, name="FilterWidth") + call zero(delta) + + do ele = 1, ele_count(scalar_eddy_visc) + nodes_ev => ele_nodes(scalar_eddy_visc, ele) + allocate(rhs_addto(size(nodes_ev))) + do i=1, size(nodes_ev) + patch = get_patch_ele(scalar_eddy_visc%mesh, nodes_ev(i)) + rhs_addto(i) = sqrt(length_scale_scalar(X, ele))/patch%count + deallocate(patch%elements) + end do + call addto(delta, nodes_ev, rhs_addto) + deallocate(rhs_addto) + end do + + do i = 1, node_count(scalar_eddy_visc) + ! Nodal values of cutoff, integral and Kolmogorov lengthscales: + lcut = node_val(delta, i) + lint = node_val(ll, i) + lkol = node_val(scalar_eddy_visc, i)**0.75/node_val(eps, i)**0.25 + ! expression for filter in terms of lengthscales: + f = min(1.0, (1.0 - exp(beta*lcut/lkol) )/(1.0 - exp(beta*lint/lkol) ) )**n + call set(filter, i, f) + end do + + call deallocate(delta) + + end subroutine vles_filter + + subroutine keps_eddyvisc_ele(ele, X, kk, eps, scalar_eddy_visc, f_mu, density, ev_rhs) + + type(vector_field), intent(in) :: x + type(scalar_field), intent(in) :: kk, eps, scalar_eddy_visc, f_mu, density + type(scalar_field), intent(inout):: ev_rhs + integer, intent(in) :: ele + + type(element_type), pointer :: shape_ev + integer, pointer, dimension(:) :: nodes_ev + real, dimension(ele_ngi(scalar_eddy_visc, ele)) :: detwei + real, dimension(ele_loc(scalar_eddy_visc, ele)) :: rhs_addto + real, dimension(ele_loc(scalar_eddy_visc, ele), ele_loc(scalar_eddy_visc, ele)) :: invmass + real, dimension(ele_ngi(kk, ele)) :: kk_at_quad, eps_at_quad + + + nodes_ev => ele_nodes(scalar_eddy_visc, ele) + shape_ev => ele_shape(scalar_eddy_visc, ele) + + ! Get detwei + call transform_to_physical(X, ele, detwei=detwei) + + ! Get the k and epsilon values at the Gauss points + kk_at_quad = ele_val_at_quad(kk,ele) + eps_at_quad = ele_val_at_quad(eps,ele) + + ! Clip the field values at the Gauss points. + ! Note 1: This isn't a permanent change directly to the field itself, + ! only to the values used in the computation of the eddy viscosity. + ! Note 2: Can't allow negative/zero epsilon or k. + ! Note 3: Here we assume all fields have the same number of + ! Gauss points per element. + where (kk_at_quad < fields_min) + kk_at_quad = fields_min + end where + where (eps_at_quad < fields_min) + eps_at_quad = fields_min + end where + + ! Compute the eddy viscosity + rhs_addto = shape_rhs(shape_ev, detwei*C_mu*ele_val_at_quad(density,ele)*& + ele_val_at_quad(f_mu,ele)*(kk_at_quad**2.0)/eps_at_quad) + + ! In the DG case we will apply the inverse mass locally. + if(continuity(scalar_eddy_visc)<0) then + invmass = inverse(shape_shape(shape_ev, shape_ev, detwei)) + rhs_addto = matmul(rhs_addto, invmass) + end if + + ! Add the element's contribution to the nodes of ev_rhs + call addto(ev_rhs, nodes_ev, rhs_addto) + + end subroutine keps_eddyvisc_ele + + end subroutine keps_eddyvisc + +!--------------------------------------------------------------------------------- - type(element_type), pointer :: shape_ev - integer, pointer, dimension(:) :: nodes_ev - real, dimension(ele_ngi(scalar_eddy_visc, ele)) :: detwei - real, dimension(ele_loc(scalar_eddy_visc, ele)) :: rhs_addto - real, dimension(ele_loc(scalar_eddy_visc, ele), ele_loc(scalar_eddy_visc, ele)) :: invmass - real, dimension(ele_ngi(kk, ele)) :: kk_at_quad, eps_at_quad + subroutine keps_diffusion(state) + ! calculates k and epsilon field diffusivities + type(state_type), intent(inout) :: state - nodes_ev => ele_nodes(scalar_eddy_visc, ele) - shape_ev => ele_shape(scalar_eddy_visc, ele) + type(tensor_field), pointer :: diff, bg_visc, eddy_visc + type(scalar_field) :: vfrac, remapvfrac + real :: sigma_k, sigma_eps + integer :: i, j + character(len=OPTION_PATH_LEN) :: option_path + logical :: multiphase - ! Get detwei - call transform_to_physical(X, ele, detwei=detwei) + ewrite(1,*) 'in keps_diffusion' - ! Get the k and epsilon values at the Gauss points - kk_at_quad = ele_val_at_quad(kk,ele) - eps_at_quad = ele_val_at_quad(eps,ele) + option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' - ! Clip the field values at the Gauss points. - ! Note 1: This isn't a permanent change directly to the field itself, - ! only to the values used in the computation of the eddy viscosity. - ! Note 2: Can't allow negative/zero epsilon or k. - ! Note 3: Here we assume all fields have the same number of - ! Gauss points per element. - where (kk_at_quad < fields_min) - kk_at_quad = fields_min - end where - where (eps_at_quad < fields_min) - eps_at_quad = fields_min - end where + eddy_visc => extract_tensor_field(state, "EddyViscosity") + bg_visc => extract_tensor_field(state, "BackgroundViscosity") + call get_option(trim(option_path)//'/sigma_k', sigma_k, default = 1.0) + call get_option(trim(option_path)//'/sigma_eps', sigma_eps, default = 1.3) - ! Compute the eddy viscosity - rhs_addto = shape_rhs(shape_ev, detwei*C_mu*ele_val_at_quad(density,ele)*& - ele_val_at_quad(f_mu,ele)*(kk_at_quad**2.0)/eps_at_quad) + ! Set diffusivity + diff => extract_tensor_field(state, "TurbulentKineticEnergyDiffusivity") - ! In the DG case we will apply the inverse mass locally. - if(continuity(scalar_eddy_visc)<0) then - invmass = inverse(shape_shape(shape_ev, shape_ev, detwei)) - rhs_addto = matmul(rhs_addto, invmass) + ! PhaseVolumeFraction for multiphase flow simulations + if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then + multiphase = .true. + call time_averaged_value(state, vfrac, "PhaseVolumeFraction", .true., option_path) + call allocate(remapvfrac, diff%mesh, "RemppedPhaseVolumeFraction") + call remap_field(vfrac, remapvfrac) + else + multiphase = .false. end if - ! Add the element's contribution to the nodes of ev_rhs - call addto(ev_rhs, nodes_ev, rhs_addto) + call zero(diff) + do i = 1, node_count(diff) + do j = 1, diff%dim(1) + if(multiphase) then + call addto(diff, j, j, i, node_val(bg_visc, j, j, i)*node_val(remapvfrac, i)) + call addto(diff, j, j, i, node_val(eddy_visc, j, j, i)*node_val(remapvfrac, i) / sigma_k) + else + call addto(diff, j, j, i, node_val(bg_visc, j, j, i)) + call addto(diff, j, j, i, node_val(eddy_visc, j, j, i) / sigma_k) + end if + end do + end do + diff => extract_tensor_field(state, "TurbulentDissipationDiffusivity") + call zero(diff) + do i = 1, node_count(diff) + do j = 1, diff%dim(1) + if(multiphase) then + call addto(diff, j, j, i, node_val(bg_visc, j, j, i)*node_val(remapvfrac, i)) + call addto(diff, j, j, i, node_val(eddy_visc, j, j, i)*node_val(remapvfrac, i) / sigma_eps) + else + call addto(diff, j, j, i, node_val(bg_visc, j, j, i)) + call addto(diff, j, j, i, node_val(eddy_visc, j, j, i) / sigma_eps) + end if + end do + end do - end subroutine keps_eddyvisc_ele + if(multiphase) then + call deallocate(remapvfrac) + call deallocate(vfrac) + end if -end subroutine keps_eddyvisc + end subroutine keps_diffusion !--------------------------------------------------------------------------------- -subroutine keps_diffusion(state) - - ! calculates k and epsilon field diffusivities - type(state_type), intent(inout) :: state - - type(tensor_field), pointer :: diff, bg_visc, eddy_visc - type(scalar_field) :: vfrac, remapvfrac - real :: sigma_k, sigma_eps - integer :: i, j - character(len=OPTION_PATH_LEN) :: option_path - logical :: multiphase - - ewrite(1,*) 'in keps_diffusion' - - option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' - - eddy_visc => extract_tensor_field(state, "EddyViscosity") - bg_visc => extract_tensor_field(state, "BackgroundViscosity") - call get_option(trim(option_path)//'/sigma_k', sigma_k, default = 1.0) - call get_option(trim(option_path)//'/sigma_eps', sigma_eps, default = 1.3) - - ! Set diffusivity - diff => extract_tensor_field(state, "TurbulentKineticEnergyDiffusivity") - - ! PhaseVolumeFraction for multiphase flow simulations - if(option_count("/material_phase/vector_field::Velocity/prognostic") > 1) then - multiphase = .true. - call time_averaged_value(state, vfrac, "PhaseVolumeFraction", .true., option_path) - call allocate(remapvfrac, diff%mesh, "RemppedPhaseVolumeFraction") - call remap_field(vfrac, remapvfrac) - else - multiphase = .false. - end if - - call zero(diff) - do i = 1, node_count(diff) - do j = 1, diff%dim(1) - if(multiphase) then - call addto(diff, j, j, i, node_val(bg_visc, j, j, i)*node_val(remapvfrac, i)) - call addto(diff, j, j, i, node_val(eddy_visc, j, j, i)*node_val(remapvfrac, i) / sigma_k) - else - call addto(diff, j, j, i, node_val(bg_visc, j, j, i)) - call addto(diff, j, j, i, node_val(eddy_visc, j, j, i) / sigma_k) - end if - end do - end do - diff => extract_tensor_field(state, "TurbulentDissipationDiffusivity") - call zero(diff) - do i = 1, node_count(diff) - do j = 1, diff%dim(1) - if(multiphase) then - call addto(diff, j, j, i, node_val(bg_visc, j, j, i)*node_val(remapvfrac, i)) - call addto(diff, j, j, i, node_val(eddy_visc, j, j, i)*node_val(remapvfrac, i) / sigma_eps) - else - call addto(diff, j, j, i, node_val(bg_visc, j, j, i)) - call addto(diff, j, j, i, node_val(eddy_visc, j, j, i) / sigma_eps) - end if - end do - end do - - if(multiphase) then - call deallocate(remapvfrac) - call deallocate(vfrac) - end if - -end subroutine keps_diffusion - -!--------------------------------------------------------------------------------- + subroutine keps_tracer_diffusion(state) + + ! calculates scalar field diffusivity based upon eddy viscosity and background + ! diffusivity + type(state_type), intent(inout) :: state + + type(tensor_field), pointer :: t_field + integer :: i_field, i, stat + real :: sigma_p, local_background_diffusivity + type(scalar_field) :: local_background_diffusivity_field + type(scalar_field), pointer :: scalar_eddy_viscosity, s_field + type(tensor_field), pointer :: global_background_diffusivity + type(tensor_field) :: background_diffusivity + + ewrite(1,*) 'In keps_tracer_diffusion' + + do i_field = 1, scalar_field_count(state) + s_field => extract_scalar_field(state, i_field) + + if (have_option(trim(s_field%option_path)//& + '/prognostic/subgridscale_parameterisation::k-epsilon')) then + + ewrite(1,*) 'Calculating turbulent diffusivity for field: ', s_field%name + + ! check options + if (.not.(have_option(trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon')))& + & then + FLExit('you must have /subgridscale_parameterisations/k-epsilon to be able to calculate diffusivity based upon the k-epsilon model') + end if + + t_field => extract_tensor_field(state, trim(s_field%name)//'Diffusivity', stat=stat) + if (stat /= 0) then + FLExit('you must have a Diffusivity field to be able to calculate diffusivity based upon the k-epsilon model') + else if (.not. have_option(trim(t_field%option_path)//"/diagnostic/algorithm::Internal")) then + FLExit('you must have a diagnostic Diffusivity field with algorithm::Internal to be able to calculate diffusivity based upon the k-epsilon model') + end if + + ! get sigma_p number + call get_option(trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/sigma_p', sigma_p) + + ! allocate and zero required fields + call allocate(background_diffusivity, t_field%mesh, name="background_diffusivity") + call zero(background_diffusivity) + call allocate(local_background_diffusivity_field, t_field%mesh, & + name="local_background_diffusivity_field") + call zero(local_background_diffusivity_field) + + ! set background_diffusivity (local takes precendence over global) + call get_option(trim(s_field%option_path)//& + '/prognostic/subgridscale_parameterisation::k-epsilon/background_diffusivity', & + local_background_diffusivity, stat=stat) + if (stat == 0) then + ! set local isotropic background diffusivity + call addto(local_background_diffusivity_field, local_background_diffusivity) + do i = 1, background_diffusivity%dim(1) + call set(background_diffusivity, i, i, local_background_diffusivity_field) + end do + else + global_background_diffusivity => extract_tensor_field(state, 'BackgroundDiffusivity', stat=stat) + if (stat == 0) then + call set(background_diffusivity, global_background_diffusivity) + end if + end if + + ! get eddy viscosity + scalar_eddy_viscosity => extract_scalar_field(state, 'ScalarEddyViscosity', stat) + + call zero(t_field) + call addto(t_field, background_diffusivity) + do i = 1, t_field%dim(1) + call addto(t_field, i, i, scalar_eddy_viscosity, 1.0/sigma_p) + end do + + call deallocate(background_diffusivity) + call deallocate(local_background_diffusivity_field) + + end if + end do -subroutine keps_tracer_diffusion(state) - - ! calculates scalar field diffusivity based upon eddy viscosity and background - ! diffusivity - type(state_type), intent(inout) :: state - - type(tensor_field), pointer :: t_field - integer :: i_field, i, stat - real :: sigma_p, local_background_diffusivity - type(scalar_field) :: local_background_diffusivity_field - type(scalar_field), pointer :: scalar_eddy_viscosity, s_field - type(tensor_field), pointer :: global_background_diffusivity - type(tensor_field) :: background_diffusivity - - ewrite(1,*) 'In keps_tracer_diffusion' - - do i_field = 1, scalar_field_count(state) - s_field => extract_scalar_field(state, i_field) - - if (have_option(trim(s_field%option_path)//& - '/prognostic/subgridscale_parameterisation::k-epsilon')) then - - ewrite(1,*) 'Calculating turbulent diffusivity for field: ', s_field%name - - ! check options - if (.not.(have_option(trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon')))& - & then - FLExit('you must have /subgridscale_parameterisations/k-epsilon to be able to calculate diffusivity based upon the k-epsilon model') - end if - - t_field => extract_tensor_field(state, trim(s_field%name)//'Diffusivity', stat=stat) - if (stat /= 0) then - FLExit('you must have a Diffusivity field to be able to calculate diffusivity based upon the k-epsilon model') - else if (.not. have_option(trim(t_field%option_path)//"/diagnostic/algorithm::Internal")) then - FLExit('you must have a diagnostic Diffusivity field with algorithm::Internal to be able to calculate diffusivity based upon the k-epsilon model') - end if - - ! get sigma_p number - call get_option(trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/sigma_p', sigma_p) - - ! allocate and zero required fields - call allocate(background_diffusivity, t_field%mesh, name="background_diffusivity") - call zero(background_diffusivity) - call allocate(local_background_diffusivity_field, t_field%mesh, & - name="local_background_diffusivity_field") - call zero(local_background_diffusivity_field) - - ! set background_diffusivity (local takes precendence over global) - call get_option(trim(s_field%option_path)//& - '/prognostic/subgridscale_parameterisation::k-epsilon/background_diffusivity', & - local_background_diffusivity, stat=stat) - if (stat == 0) then - ! set local isotropic background diffusivity - call addto(local_background_diffusivity_field, local_background_diffusivity) - do i = 1, background_diffusivity%dim(1) - call set(background_diffusivity, i, i, local_background_diffusivity_field) - end do - else - global_background_diffusivity => extract_tensor_field(state, 'BackgroundDiffusivity', stat=stat) - if (stat == 0) then - call set(background_diffusivity, global_background_diffusivity) - end if - end if - - ! get eddy viscosity - scalar_eddy_viscosity => extract_scalar_field(state, 'ScalarEddyViscosity', stat) - - call zero(t_field) - call addto(t_field, background_diffusivity) - do i = 1, t_field%dim(1) - call addto(t_field, i, i, scalar_eddy_viscosity, 1.0/sigma_p) - end do - - call deallocate(background_diffusivity) - call deallocate(local_background_diffusivity_field) - - end if - end do - -end subroutine keps_tracer_diffusion + end subroutine keps_tracer_diffusion !--------------------------------------------------------------------------------! ! This gets and applies locally defined boundary conditions (wall functions) ! !--------------------------------------------------------------------------------! -subroutine keps_bcs(state) - - type(state_type), intent(in) :: state - type(scalar_field), pointer :: field1, field2 ! k or epsilon - type(scalar_field), pointer :: f_1, f_2, f_mu - type(scalar_field), pointer :: scalar_eddy_visc - type(scalar_field), pointer :: density, dummydensity - type(vector_field), pointer :: X, u - type(tensor_field), pointer :: bg_visc - integer :: i, index, nbcs, stat - character(len=FIELD_NAME_LEN) :: bc_type, bc_name, wall_fns - character(len=OPTION_PATH_LEN) :: bc_path, bc_path_i, option_path - real :: c_mu - character(len=FIELD_NAME_LEN) :: equation_type - - option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' - - ewrite(2,*) "In keps_bcs" - - X => extract_vector_field(state, "Coordinate") - u => extract_vector_field(state, "Velocity") - scalar_eddy_visc => extract_scalar_field(state, "ScalarEddyViscosity") - bg_visc => extract_tensor_field(state, "BackgroundViscosity") - f_1 => extract_scalar_field(state, "f_1") - f_2 => extract_scalar_field(state, "f_2") - f_mu => extract_scalar_field(state, "f_mu") - - allocate(dummydensity) - call allocate(dummydensity, X%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) - call set(dummydensity, 1.0) - dummydensity%option_path = "" - - ! Depending on the equation type, extract the density or set it to some dummy field allocated above - call get_option(trim(u%option_path)//"/prognostic/equation[0]/name", equation_type) - select case(equation_type) - case("LinearMomentum") - density=>extract_scalar_field(state, "Density") - case("Boussinesq") - density=>dummydensity - case("Drainage") - density=>dummydensity - case default - ! developer error... out of sync options input and code - FLAbort("Unknown equation type for velocity") - end select - - call get_option(trim(option_path)//"C_mu", c_mu, default = 0.09) - - field_loop: do index=1,2 - - if(index==1) then - field1 => extract_scalar_field(state, "TurbulentKineticEnergy") - field2 => null() - else - field1 => extract_scalar_field(state, "TurbulentDissipation") - field2 => extract_scalar_field(state, "TurbulentKineticEnergy") - end if - - bc_path=trim(field1%option_path)//'/prognostic/boundary_conditions' - nbcs=option_count(trim(bc_path)) - - ! Loop over boundary conditions for field1 - boundary_conditions: do i=0, nbcs-1 - - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - - ! Get name and type of boundary condition - call get_option(trim(bc_path_i)//"/name", bc_name) - call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) - ! Do we have low-Reynolds-number wall functions? - call get_option(trim(bc_path_i)//"/type::k_epsilon/", wall_fns, stat=stat) - - if (trim(bc_type)=="k_epsilon" .and. wall_fns=="low_Re") then - ! lowRe BC's are just zero Dirichlet or Neumann - damping functions get calculated in - ! keps_calc_rhs - low_Re = .true. - end if - end do boundary_conditions - end do field_loop - - call deallocate(dummydensity) - deallocate(dummydensity) - -end subroutine keps_bcs + subroutine keps_bcs(state) + + type(state_type), intent(in) :: state + type(scalar_field), pointer :: field1, field2 ! k or epsilon + type(scalar_field), pointer :: f_1, f_2, f_mu + type(scalar_field), pointer :: scalar_eddy_visc + type(scalar_field), pointer :: density, dummydensity + type(vector_field), pointer :: X, u + type(tensor_field), pointer :: bg_visc + integer :: i, index, nbcs, stat + character(len=FIELD_NAME_LEN) :: bc_type, bc_name, wall_fns + character(len=OPTION_PATH_LEN) :: bc_path, bc_path_i, option_path + real :: c_mu + character(len=FIELD_NAME_LEN) :: equation_type + + option_path = trim(state%option_path)//'/subgridscale_parameterisations/k-epsilon/' + + ewrite(2,*) "In keps_bcs" + + X => extract_vector_field(state, "Coordinate") + u => extract_vector_field(state, "Velocity") + scalar_eddy_visc => extract_scalar_field(state, "ScalarEddyViscosity") + bg_visc => extract_tensor_field(state, "BackgroundViscosity") + f_1 => extract_scalar_field(state, "f_1") + f_2 => extract_scalar_field(state, "f_2") + f_mu => extract_scalar_field(state, "f_mu") + + allocate(dummydensity) + call allocate(dummydensity, X%mesh, "DummyDensity", field_type=FIELD_TYPE_CONSTANT) + call set(dummydensity, 1.0) + dummydensity%option_path = "" + + ! Depending on the equation type, extract the density or set it to some dummy field allocated above + call get_option(trim(u%option_path)//"/prognostic/equation[0]/name", equation_type) + select case(equation_type) + case("LinearMomentum") + density=>extract_scalar_field(state, "Density") + case("Boussinesq") + density=>dummydensity + case("Drainage") + density=>dummydensity + case default + ! developer error... out of sync options input and code + FLAbort("Unknown equation type for velocity") + end select + + call get_option(trim(option_path)//"C_mu", c_mu, default = 0.09) + + field_loop: do index=1,2 + + if(index==1) then + field1 => extract_scalar_field(state, "TurbulentKineticEnergy") + field2 => null() + else + field1 => extract_scalar_field(state, "TurbulentDissipation") + field2 => extract_scalar_field(state, "TurbulentKineticEnergy") + end if + + bc_path=trim(field1%option_path)//'/prognostic/boundary_conditions' + nbcs=option_count(trim(bc_path)) + + ! Loop over boundary conditions for field1 + boundary_conditions: do i=0, nbcs-1 + + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + + ! Get name and type of boundary condition + call get_option(trim(bc_path_i)//"/name", bc_name) + call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) + ! Do we have low-Reynolds-number wall functions? + call get_option(trim(bc_path_i)//"/type::k_epsilon/", wall_fns, stat=stat) + + if (trim(bc_type)=="k_epsilon" .and. wall_fns=="low_Re") then + ! lowRe BC's are just zero Dirichlet or Neumann - damping functions get calculated in + ! keps_calc_rhs + low_Re = .true. + end if + end do boundary_conditions + end do field_loop + + call deallocate(dummydensity) + deallocate(dummydensity) + + end subroutine keps_bcs !--------------------------------------------------------------------------------- -subroutine time_averaged_value(state, A, field_name, advdif, option_path) + subroutine time_averaged_value(state, A, field_name, advdif, option_path) - type(state_type), intent(in) :: state - type(scalar_field), intent(inout) :: A - character(len=*), intent(in) :: field_name - logical, intent(in) :: advdif ! advdif or mom - whether to use old or iterated values - character(len=OPTION_PATH_LEN), intent(in) :: option_path + type(state_type), intent(in) :: state + type(scalar_field), intent(inout) :: A + character(len=*), intent(in) :: field_name + logical, intent(in) :: advdif ! advdif or mom - whether to use old or iterated values + character(len=OPTION_PATH_LEN), intent(in) :: option_path - real :: theta - type(scalar_field), pointer :: old, iterated + real :: theta + type(scalar_field), pointer :: old, iterated - call get_option(trim(option_path)//'time_discretisation/theta', theta) + call get_option(trim(option_path)//'time_discretisation/theta', theta) - old => extract_scalar_field(state, "Old"//trim(field_name)) - if (advdif) then - iterated => extract_scalar_field(state, "Iterated"//trim(field_name)) - else - iterated => extract_scalar_field(state, trim(field_name)) - end if + old => extract_scalar_field(state, "Old"//trim(field_name)) + if (advdif) then + iterated => extract_scalar_field(state, "Iterated"//trim(field_name)) + else + iterated => extract_scalar_field(state, trim(field_name)) + end if - call allocate(A, old%mesh, name="Nonlinear"//trim(field_name)) - call zero(A) - call addto(A, old, 1.0-theta) - call addto(A, iterated, theta) + call allocate(A, old%mesh, name="Nonlinear"//trim(field_name)) + call zero(A) + call addto(A, old, 1.0-theta) + call addto(A, iterated, theta) - ewrite_minmax(old) - ewrite_minmax(iterated) - ewrite_minmax(A) + ewrite_minmax(old) + ewrite_minmax(iterated) + ewrite_minmax(A) -end subroutine time_averaged_value + end subroutine time_averaged_value !--------------------------------------------------------------------------------- -subroutine solve_cg_inv_mass(state, A, lump, option_path) - - type(state_type), intent(inout) :: state - type(scalar_field), intent(inout) :: A - logical, intent(in) :: lump - character(len=OPTION_PATH_LEN), intent(in) :: option_path - - type(scalar_field), pointer :: lumped_mass - type(csr_matrix), pointer :: mass_matrix - type(scalar_field) :: inv_lumped_mass, x - - if (lump) then - call allocate(inv_lumped_mass, A%mesh) - lumped_mass => get_lumped_mass(state, A%mesh) - call invert(lumped_mass, inv_lumped_mass) - call scale(A, inv_lumped_mass) - call deallocate(inv_lumped_mass) - else - call allocate(x, A%mesh) - mass_matrix => get_mass_matrix(state, A%mesh) - call petsc_solve(x, mass_matrix, A, & - trim(option_path)//& - 'mass_terms/use_consistent_mass_matrix/') - call set(A, x) - call deallocate(x) - end if - -end subroutine solve_cg_inv_mass + subroutine solve_cg_inv_mass(state, A, lump, option_path) + + type(state_type), intent(inout) :: state + type(scalar_field), intent(inout) :: A + logical, intent(in) :: lump + character(len=OPTION_PATH_LEN), intent(in) :: option_path + + type(scalar_field), pointer :: lumped_mass + type(csr_matrix), pointer :: mass_matrix + type(scalar_field) :: inv_lumped_mass, x + + if (lump) then + call allocate(inv_lumped_mass, A%mesh) + lumped_mass => get_lumped_mass(state, A%mesh) + call invert(lumped_mass, inv_lumped_mass) + call scale(A, inv_lumped_mass) + call deallocate(inv_lumped_mass) + else + call allocate(x, A%mesh) + mass_matrix => get_mass_matrix(state, A%mesh) + call petsc_solve(x, mass_matrix, A, & + trim(option_path)//& + 'mass_terms/use_consistent_mass_matrix/') + call set(A, x) + call deallocate(x) + end if + + end subroutine solve_cg_inv_mass !--------------------------------------------------------------------------------- -subroutine solve_cg_inv_mass_vector(state, A, lump, option_path) - - type(state_type), intent(inout) :: state - type(vector_field), intent(inout) :: A - logical, intent(in) :: lump - character(len=OPTION_PATH_LEN), intent(in) :: option_path - - type(scalar_field), pointer :: lumped_mass - type(csr_matrix), pointer :: mass_matrix - type(scalar_field) :: inv_lumped_mass - type(vector_field) :: x - - if (lump) then - call allocate(inv_lumped_mass, A%mesh) - lumped_mass => get_lumped_mass(state, A%mesh) - call invert(lumped_mass, inv_lumped_mass) - call scale(A, inv_lumped_mass) - call deallocate(inv_lumped_mass) - else - call allocate(x, A%dim, A%mesh) - mass_matrix => get_mass_matrix(state, A%mesh) - call petsc_solve(x, mass_matrix, A, & - trim(option_path)//& - 'mass_terms/use_consistent_mass_matrix/') - call set(A, x) - call deallocate(x) - end if - -end subroutine solve_cg_inv_mass_vector + subroutine solve_cg_inv_mass_vector(state, A, lump, option_path) + + type(state_type), intent(inout) :: state + type(vector_field), intent(inout) :: A + logical, intent(in) :: lump + character(len=OPTION_PATH_LEN), intent(in) :: option_path + + type(scalar_field), pointer :: lumped_mass + type(csr_matrix), pointer :: mass_matrix + type(scalar_field) :: inv_lumped_mass + type(vector_field) :: x + + if (lump) then + call allocate(inv_lumped_mass, A%mesh) + lumped_mass => get_lumped_mass(state, A%mesh) + call invert(lumped_mass, inv_lumped_mass) + call scale(A, inv_lumped_mass) + call deallocate(inv_lumped_mass) + else + call allocate(x, A%dim, A%mesh) + mass_matrix => get_mass_matrix(state, A%mesh) + call petsc_solve(x, mass_matrix, A, & + trim(option_path)//& + 'mass_terms/use_consistent_mass_matrix/') + call set(A, x) + call deallocate(x) + end if + + end subroutine solve_cg_inv_mass_vector !--------------------------------------------------------------------------------- -subroutine k_epsilon_check_options - - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: kmsh, emsh, vmsh - integer :: dimension, stat, n_phases, istate - - ewrite(2,*) "Checking k-epsilon options" - - n_phases = option_count("/material_phase") - - do istate = 0, n_phases-1 - - option_path = "/material_phase["//int2str(istate)//"]/subgridscale_parameterisations/k-epsilon" - - ! one dimensional problems not supported - call get_option("/geometry/dimension/", dimension) - if (dimension .eq. 1 .and. have_option(trim(option_path))) then - FLExit("k-epsilon model is only supported for dimension > 1") - end if - ! Don't do k-epsilon if it's not included in the model! - if (.not.have_option(trim(option_path))) return - - ! checking for required fields - if (have_option(trim(option_path)//"/scalar_field::TurbulentKineticEnergy/prognostic")) then - ! diffusivity is on and diagnostic - if (.not.have_option(trim(option_path)//"/scalar_field::TurbulentKineticEnergy"//& - &"/prognostic/tensor_field::Diffusivity")) then - FLExit("You need TurbulentKineticEnergy Diffusivity field for k-epsilon") - end if - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prognostic/"//& - &"/tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then - FLExit("You need TurbulentKineticEnergy Diffusivity field set to diagnostic/internal") - end if - ! source terms - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prognostic"//& - &"/scalar_field::Source")) then - FLExit("You need TurbulentKineticEnergy Source field for k-epsilon") - end if - if (.not. have_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prognostic"//& - &"/scalar_field::Source/diagnostic/algorithm::Internal")) then - FLExit("You need TurbulentKineticEnergy Source field set to diagnostic/internal") - end if - ! absorption terms - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prognostic"//& - &"/scalar_field::Absorption")) then - FLExit("You need TurbulentKineticEnergy Absorption field for k-epsilon") - end if - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prognostic"//& - &"/scalar_field::Absorption/diagnostic/algorithm::Internal")) then - FLExit("You need TurbulentKineticEnergy Absorption field set to diagnostic/internal") - end if - else if (have_option(trim(option_path)// & - "/scalar_field::TurbulentKineticEnergy/prescribed")) then - ewrite(0,*) "WARNING: TurbulentKineticEnergy field is prescribed" - else - FLExit("You need prognostic/prescribed TurbulentKineticEnergy field for k-epsilon") - end if - if (have_option(trim(option_path)//"/scalar_field::TurbulentDissipation/prognostic")) then - ! diffusivity is on and diagnostic - if (.not.have_option(trim(option_path)//"/scalar_field::TurbulentDissipation"//& - &"/prognostic/tensor_field::Diffusivity")) then - FLExit("You need TurbulentDissipation Diffusivity field for k-epsilon") - end if - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prognostic/"//& - &"/tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then - FLExit("You need TurbulentDissipation Diffusivity field set to diagnostic/internal") - end if - ! source terms - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prognostic"//& - &"/scalar_field::Source")) then - FLExit("You need TurbulentDissipation Source field for k-epsilon") - end if - if (.not. have_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prognostic"//& - &"/scalar_field::Source/diagnostic/algorithm::Internal")) then - FLExit("You need TurbulentDissipation Source field set to diagnostic/internal") - end if - ! absorption terms - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prognostic"//& - &"/scalar_field::Absorption")) then - FLExit("You need TurbulentDissipation Absorption field for k-epsilon") - end if - if (.not.have_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prognostic"//& - &"/scalar_field::Absorption/diagnostic/algorithm::Internal")) then - FLExit("You need TurbulentDissipation Absorption field set to diagnostic/internal") - end if - else if (have_option(trim(option_path)// & - "/scalar_field::TurbulentDissipation/prescribed")) then - ewrite(0,*) "WARNING: TurbulentDissipation field is prescribed" - else - FLExit("You need prognostic/prescribed TurbulentDissipation field for k-epsilon") - end if - - ! Check that TurbulentKineticEnergy and TurbulentDissipation fields are on the same - ! mesh as the velocity - call get_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prognostic/mesh/name", kmsh, stat) - if (stat /= 0) then - call get_option(trim(option_path)//& - &"/scalar_field::TurbulentKineticEnergy/prescribed/mesh/name", kmsh,& - & stat) - end if - call get_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prognostic/mesh/name", emsh, stat) - if (stat /= 0) then - call get_option(trim(option_path)//& - &"/scalar_field::TurbulentDissipation/prescribed/mesh/name", emsh,& - & stat) - end if - call get_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic/mesh/name", vmsh,& - & stat) - if (stat /= 0) then - call get_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prescribed/mesh/name", vmsh,& - & stat) - if (stat /= 0) then - FLExit("You must use a prognostic or prescribed Velocity field") - end if - end if - if(.not. kmsh==emsh) then - FLExit("You must use same mesh for TurbulentKineticEnergy and TurbulentDissipation fields") - end if - - ! Velocity field options - if (.not.have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic"//& - "/tensor_field::Viscosity/") .and. & - .not.have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prescribed")) then - FLExit("Need viscosity switched on under the Velocity field for k-epsilon.") - end if - ! check that the user has switched Velocity/viscosity to diagnostic - if (have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic") .and. & - .not.have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic"//& - "/tensor_field::Viscosity/diagnostic/")) then - FLExit("You need to switch the viscosity field under Velocity to diagnostic/internal") - end if - - ! Check ScalarEddyViscosity is diagnostic - if (have_option(trim(option_path)//'/scalar_field::ScalarEddyViscosity/prescribed')) then - ewrite(0,*) "WARNING: ScalarEddyViscosity field is prescribed" - end if - - end do - - ewrite(1,*) "Finished keps_check_options" - -end subroutine k_epsilon_check_options + subroutine k_epsilon_check_options + + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: kmsh, emsh, vmsh + integer :: dimension, stat, n_phases, istate + + ewrite(2,*) "Checking k-epsilon options" + + n_phases = option_count("/material_phase") + + do istate = 0, n_phases-1 + + option_path = "/material_phase["//int2str(istate)//"]/subgridscale_parameterisations/k-epsilon" + + ! one dimensional problems not supported + call get_option("/geometry/dimension/", dimension) + if (dimension .eq. 1 .and. have_option(trim(option_path))) then + FLExit("k-epsilon model is only supported for dimension > 1") + end if + ! Don't do k-epsilon if it's not included in the model! + if (.not.have_option(trim(option_path))) return + + ! checking for required fields + if (have_option(trim(option_path)//"/scalar_field::TurbulentKineticEnergy/prognostic")) then + ! diffusivity is on and diagnostic + if (.not.have_option(trim(option_path)//"/scalar_field::TurbulentKineticEnergy"//& + &"/prognostic/tensor_field::Diffusivity")) then + FLExit("You need TurbulentKineticEnergy Diffusivity field for k-epsilon") + end if + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prognostic/"//& + &"/tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then + FLExit("You need TurbulentKineticEnergy Diffusivity field set to diagnostic/internal") + end if + ! source terms + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prognostic"//& + &"/scalar_field::Source")) then + FLExit("You need TurbulentKineticEnergy Source field for k-epsilon") + end if + if (.not. have_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prognostic"//& + &"/scalar_field::Source/diagnostic/algorithm::Internal")) then + FLExit("You need TurbulentKineticEnergy Source field set to diagnostic/internal") + end if + ! absorption terms + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prognostic"//& + &"/scalar_field::Absorption")) then + FLExit("You need TurbulentKineticEnergy Absorption field for k-epsilon") + end if + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prognostic"//& + &"/scalar_field::Absorption/diagnostic/algorithm::Internal")) then + FLExit("You need TurbulentKineticEnergy Absorption field set to diagnostic/internal") + end if + else if (have_option(trim(option_path)// & + "/scalar_field::TurbulentKineticEnergy/prescribed")) then + ewrite(0,*) "WARNING: TurbulentKineticEnergy field is prescribed" + else + FLExit("You need prognostic/prescribed TurbulentKineticEnergy field for k-epsilon") + end if + if (have_option(trim(option_path)//"/scalar_field::TurbulentDissipation/prognostic")) then + ! diffusivity is on and diagnostic + if (.not.have_option(trim(option_path)//"/scalar_field::TurbulentDissipation"//& + &"/prognostic/tensor_field::Diffusivity")) then + FLExit("You need TurbulentDissipation Diffusivity field for k-epsilon") + end if + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prognostic/"//& + &"/tensor_field::Diffusivity/diagnostic/algorithm::Internal")) then + FLExit("You need TurbulentDissipation Diffusivity field set to diagnostic/internal") + end if + ! source terms + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prognostic"//& + &"/scalar_field::Source")) then + FLExit("You need TurbulentDissipation Source field for k-epsilon") + end if + if (.not. have_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prognostic"//& + &"/scalar_field::Source/diagnostic/algorithm::Internal")) then + FLExit("You need TurbulentDissipation Source field set to diagnostic/internal") + end if + ! absorption terms + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prognostic"//& + &"/scalar_field::Absorption")) then + FLExit("You need TurbulentDissipation Absorption field for k-epsilon") + end if + if (.not.have_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prognostic"//& + &"/scalar_field::Absorption/diagnostic/algorithm::Internal")) then + FLExit("You need TurbulentDissipation Absorption field set to diagnostic/internal") + end if + else if (have_option(trim(option_path)// & + "/scalar_field::TurbulentDissipation/prescribed")) then + ewrite(0,*) "WARNING: TurbulentDissipation field is prescribed" + else + FLExit("You need prognostic/prescribed TurbulentDissipation field for k-epsilon") + end if + + ! Check that TurbulentKineticEnergy and TurbulentDissipation fields are on the same + ! mesh as the velocity + call get_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prognostic/mesh/name", kmsh, stat) + if (stat /= 0) then + call get_option(trim(option_path)//& + &"/scalar_field::TurbulentKineticEnergy/prescribed/mesh/name", kmsh,& + & stat) + end if + call get_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prognostic/mesh/name", emsh, stat) + if (stat /= 0) then + call get_option(trim(option_path)//& + &"/scalar_field::TurbulentDissipation/prescribed/mesh/name", emsh,& + & stat) + end if + call get_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic/mesh/name", vmsh,& + & stat) + if (stat /= 0) then + call get_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prescribed/mesh/name", vmsh,& + & stat) + if (stat /= 0) then + FLExit("You must use a prognostic or prescribed Velocity field") + end if + end if + if(.not. kmsh==emsh) then + FLExit("You must use same mesh for TurbulentKineticEnergy and TurbulentDissipation fields") + end if + + ! Velocity field options + if (.not.have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic"//& + "/tensor_field::Viscosity/") .and. & + .not.have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prescribed")) then + FLExit("Need viscosity switched on under the Velocity field for k-epsilon.") + end if + ! check that the user has switched Velocity/viscosity to diagnostic + if (have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic") .and. & + .not.have_option("/material_phase["//int2str(istate)//"]/vector_field::Velocity/prognostic"//& + "/tensor_field::Viscosity/diagnostic/")) then + FLExit("You need to switch the viscosity field under Velocity to diagnostic/internal") + end if + + ! Check ScalarEddyViscosity is diagnostic + if (have_option(trim(option_path)//'/scalar_field::ScalarEddyViscosity/prescribed')) then + ewrite(0,*) "WARNING: ScalarEddyViscosity field is prescribed" + end if + + end do + + ewrite(1,*) "Finished keps_check_options" + + end subroutine k_epsilon_check_options end module k_epsilon diff --git a/parameterisation/tests/test_pade_equation_of_state.F90 b/parameterisation/tests/test_pade_equation_of_state.F90 index 1075279930..33c41235ef 100644 --- a/parameterisation/tests/test_pade_equation_of_state.F90 +++ b/parameterisation/tests/test_pade_equation_of_state.F90 @@ -28,45 +28,45 @@ #include "fdebug.h" subroutine test_pade_equation_of_state - !!< Test the nonlinear equation of state against the check values in the - !!< original publication. The checks are from p740 of: - !!< McDougall, T.J., D.R. Jackett, D.G. Wright, and R. Feistel, 2003: - !!< Accurate and Computationally Efficient Algorithms for Potential - !!< Temperature and Density of Seawater. J. Atmos. Oceanic Technol., 20, - !!< 730-741. DOI: 10.1175/1520-0426(2003)20 + !!< Test the nonlinear equation of state against the check values in the + !!< original publication. The checks are from p740 of: + !!< McDougall, T.J., D.R. Jackett, D.G. Wright, and R. Feistel, 2003: + !!< Accurate and Computationally Efficient Algorithms for Potential + !!< Temperature and Density of Seawater. J. Atmos. Oceanic Technol., 20, + !!< 730-741. DOI: 10.1175/1520-0426(2003)20 - use equation_of_state - use unittest_tools - implicit none + use equation_of_state + use unittest_tools + implicit none - real :: rho + real :: rho - call mcD_J_W_F2002(rho, 25., 35., invert_distance(2000.)) + call mcD_J_W_F2002(rho, 25., 35., invert_distance(2000.)) - call report_test("[Pade equation of state: check point 1.]", & - & .not.fequals(1000*rho+1000, 1031.654229, 1.e-6), .false., & - & "Equation of state returned wrong value") + call report_test("[Pade equation of state: check point 1.]", & + & .not.fequals(1000*rho+1000, 1031.654229, 1.e-6), .false., & + & "Equation of state returned wrong value") - call mcD_J_W_F2002(rho, 20., 20., invert_distance(1000.)) + call mcD_J_W_F2002(rho, 20., 20., invert_distance(1000.)) - call report_test("[Pade equation of state: check point 2.]", & - & .not.fequals(1000*rho+1000, 1017.726743, 1.e-6), .false., & - & "Equation of state returned wrong value") + call report_test("[Pade equation of state: check point 2.]", & + & .not.fequals(1000*rho+1000, 1017.726743, 1.e-6), .false., & + & "Equation of state returned wrong value") - call mcD_J_W_F2002(rho, 12., 40., invert_distance(8000.)) + call mcD_J_W_F2002(rho, 12., 40., invert_distance(8000.)) - call report_test("[Pade equation of state: check point 3.]", & - & .not.fequals(1000*rho+1000, 1062.928258, 1.e-6), .false., & - & "Equation of state returned wrong value") + call report_test("[Pade equation of state: check point 3.]", & + & .not.fequals(1000*rho+1000, 1062.928258, 1.e-6), .false., & + & "Equation of state returned wrong value") contains - function invert_distance(pressure) - real :: invert_distance - real, intent(in) :: pressure + function invert_distance(pressure) + real :: invert_distance + real, intent(in) :: pressure - invert_distance=pressure/( 9.81*1000.0*1.0e-4 ) + invert_distance=pressure/( 9.81*1000.0*1.0e-4 ) - end function invert_distance + end function invert_distance end subroutine test_pade_equation_of_state diff --git a/parameterisation/tests/test_tensor_inner_product.F90 b/parameterisation/tests/test_tensor_inner_product.F90 index 4f4c908e65..c349048120 100644 --- a/parameterisation/tests/test_tensor_inner_product.F90 +++ b/parameterisation/tests/test_tensor_inner_product.F90 @@ -32,9 +32,9 @@ subroutine test_tensor_inner_product implicit none interface - function solution() - real, dimension(1) :: solution - end function + function solution() + real, dimension(1) :: solution + end function end interface ! The two input matrices, A and B. @@ -56,6 +56,6 @@ function solution() end subroutine test_tensor_inner_product function solution() - real, dimension(1) :: solution - solution = (/570.0/) + real, dimension(1) :: solution + solution = (/570.0/) end function solution diff --git a/population_balance/DQMOM.F90 b/population_balance/DQMOM.F90 index eb0091fcfe..cf86e702a5 100644 --- a/population_balance/DQMOM.F90 +++ b/population_balance/DQMOM.F90 @@ -29,1272 +29,1272 @@ module dqmom - use fldebug - use vector_tools - use spud - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN - use futils, only: int2str - use elements - use sparse_tools - use fetools - use fields - use state_module - use state_fields_module - use initialise_fields_module - use solvers - - implicit none - - public dqmom_init, dqmom_calculate_source_terms, dqmom_calculate_abscissa,& - & dqmom_check_options, dqmom_calculate_moments, dqmom_calculate_statistics, dqmom_apply_min_weight - - private - - real, save :: fields_min = 1.0e-11 - !! TODO: - !! 1. Make the algorithm work for multiple phases and make sure it works for - !! several pop_balances - currently works for only one population balance - !! 2. Make check_options run - !! 3. Check all prognostic fields are identical (possible bar initial conditions) - !! 4. Check prognostic Source terms are set to diagnostic, Internal - !! 5. Check diagnostic fields are set to Internal + use fldebug + use vector_tools + use spud + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN + use futils, only: int2str + use elements + use sparse_tools + use fetools + use fields + use state_module + use state_fields_module + use initialise_fields_module + use solvers + + implicit none + + public dqmom_init, dqmom_calculate_source_terms, dqmom_calculate_abscissa,& + & dqmom_check_options, dqmom_calculate_moments, dqmom_calculate_statistics, dqmom_apply_min_weight + + private + + real, save :: fields_min = 1.0e-11 + !! TODO: + !! 1. Make the algorithm work for multiple phases and make sure it works for + !! several pop_balances - currently works for only one population balance + !! 2. Make check_options run + !! 3. Check all prognostic fields are identical (possible bar initial conditions) + !! 4. Check prognostic Source terms are set to diagnostic, Internal + !! 5. Check diagnostic fields are set to Internal contains - subroutine get_pop_field(state, i_pop, i_field, type, item, stat, iterated) + subroutine get_pop_field(state, i_pop, i_field, type, item, stat, iterated) - ! Returns the required population balance field + ! Returns the required population balance field - type(state_type), intent(in) :: state - integer, intent(in) :: i_pop, i_field - character(len=FIELD_NAME_LEN) :: type ! moments, weights, ascissa, or weighted_abscissa - type(scalar_field), pointer, intent(out) :: item - integer, intent(out), optional :: stat - logical, intent(in), optional :: iterated + type(state_type), intent(in) :: state + integer, intent(in) :: i_pop, i_field + character(len=FIELD_NAME_LEN) :: type ! moments, weights, ascissa, or weighted_abscissa + type(scalar_field), pointer, intent(out) :: item + integer, intent(out), optional :: stat + logical, intent(in), optional :: iterated - character(len=FIELD_NAME_LEN) :: name - character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: name + character(len=OPTION_PATH_LEN) :: option_path - call get_pop_option_path(state, i_pop, option_path) - call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field -& + call get_pop_option_path(state, i_pop, option_path) + call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field -& 1)//']/name', name) - if (present(iterated)) then - if (iterated) then - name = 'Iterated'//trim(name) - end if - end if - item => extract_scalar_field(state, trim(name), stat) - end subroutine get_pop_field + if (present(iterated)) then + if (iterated) then + name = 'Iterated'//trim(name) + end if + end if + item => extract_scalar_field(state, trim(name), stat) + end subroutine get_pop_field - subroutine get_pop_option_path(state, i_pop, option_path) + subroutine get_pop_option_path(state, i_pop, option_path) - type(state_type), intent(in) :: state - integer, intent(in) :: i_pop - character(len=OPTION_PATH_LEN), intent(out) :: option_path + type(state_type), intent(in) :: state + integer, intent(in) :: i_pop + character(len=OPTION_PATH_LEN), intent(out) :: option_path - option_path = trim(state%option_path)//'/population_balance' - if (option_count(option_path) > 1) then - option_path = trim(state%option_path)//'/population_balance['& - &//int2str(i_pop-1)//']' - end if + option_path = trim(state%option_path)//'/population_balance' + if (option_count(option_path) > 1) then + option_path = trim(state%option_path)//'/population_balance['& + &//int2str(i_pop-1)//']' + end if - end subroutine get_pop_option_path + end subroutine get_pop_option_path - subroutine dqmom_init(states) + subroutine dqmom_init(states) - type(state_type), intent(in), dimension(:) :: states + type(state_type), intent(in), dimension(:) :: states - integer :: i_state, i_pop - character(len=OPTION_PATH_LEN) :: option_path + integer :: i_state, i_pop + character(len=OPTION_PATH_LEN) :: option_path - do i_state = 1, option_count("/material_phase") - do i_pop = 1, option_count(trim(states(i_state)%option_path)//& + do i_state = 1, option_count("/material_phase") + do i_pop = 1, option_count(trim(states(i_state)%option_path)//& '/population_balance') - call get_pop_option_path(states(i_state), i_pop, option_path) - if (have_option(trim(option_path)// & + call get_pop_option_path(states(i_state), i_pop, option_path) + if (have_option(trim(option_path)// & '/calculate_initial_conditions_from_moments')) then - call dqmom_PD_algorithm(states(i_state), i_pop) - end if - end do - end do - - call dqmom_calculate_abscissa(states) - - end subroutine dqmom_init - - subroutine dqmom_PD_algorithm(state, i_pop) - - ! Algorithm for calculating abscissa and weights from the moment of a distribution - ! See Gordon 1968 and Mcgraw 1997 - - type(state_type), intent(in) :: state - integer, intent(in) :: i_pop - - type(scalar_field_pointer), dimension(:), allocatable :: moments - type(scalar_field_pointer), dimension(:), allocatable :: weighted_abscissa - type(scalar_field_pointer), dimension(:), allocatable :: weights - type(vector_field), pointer:: position - - ! J - Jacobi matrix - ! P and alpha are required working arrays - ! e_values - eigenvalues - ! e_vectors - corresponding eigenvectors - real, dimension(:,:), allocatable :: P, Jac, e_vectors - real, dimension(:), allocatable :: alpha, e_values - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: type - integer :: i_field, n_abscissa, i_node, i, j, stat - - call get_pop_option_path(state, i_pop, option_path) - n_abscissa = option_count(trim(option_path)//'/abscissa/scalar_field') - - allocate(moments(2*n_abscissa)) - allocate(weighted_abscissa(n_abscissa)) - allocate(weights(n_abscissa)) - allocate(P(2*n_abscissa + 1,2*n_abscissa + 1)) - allocate(Jac(n_abscissa,n_abscissa)) - allocate(alpha(2*n_abscissa)) - allocate(e_vectors(n_abscissa,n_abscissa)) - allocate(e_values(n_abscissa)) - - position => extract_vector_field(state, "Coordinate") - do i_field = 1, 2*n_abscissa - ! collect moment fields and initialise from initial conditions - ! will not be done automatically as this is a diagnostic field - type = 'moments' - call get_pop_field(state, i_pop, i_field, type, moments(i_field)%ptr) - call zero(moments(i_field)%ptr) - call initialise_field_over_regions(moments(i_field)%ptr, & + call dqmom_PD_algorithm(states(i_state), i_pop) + end if + end do + end do + + call dqmom_calculate_abscissa(states) + + end subroutine dqmom_init + + subroutine dqmom_PD_algorithm(state, i_pop) + + ! Algorithm for calculating abscissa and weights from the moment of a distribution + ! See Gordon 1968 and Mcgraw 1997 + + type(state_type), intent(in) :: state + integer, intent(in) :: i_pop + + type(scalar_field_pointer), dimension(:), allocatable :: moments + type(scalar_field_pointer), dimension(:), allocatable :: weighted_abscissa + type(scalar_field_pointer), dimension(:), allocatable :: weights + type(vector_field), pointer:: position + + ! J - Jacobi matrix + ! P and alpha are required working arrays + ! e_values - eigenvalues + ! e_vectors - corresponding eigenvectors + real, dimension(:,:), allocatable :: P, Jac, e_vectors + real, dimension(:), allocatable :: alpha, e_values + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: type + integer :: i_field, n_abscissa, i_node, i, j, stat + + call get_pop_option_path(state, i_pop, option_path) + n_abscissa = option_count(trim(option_path)//'/abscissa/scalar_field') + + allocate(moments(2*n_abscissa)) + allocate(weighted_abscissa(n_abscissa)) + allocate(weights(n_abscissa)) + allocate(P(2*n_abscissa + 1,2*n_abscissa + 1)) + allocate(Jac(n_abscissa,n_abscissa)) + allocate(alpha(2*n_abscissa)) + allocate(e_vectors(n_abscissa,n_abscissa)) + allocate(e_values(n_abscissa)) + + position => extract_vector_field(state, "Coordinate") + do i_field = 1, 2*n_abscissa + ! collect moment fields and initialise from initial conditions + ! will not be done automatically as this is a diagnostic field + type = 'moments' + call get_pop_field(state, i_pop, i_field, type, moments(i_field)%ptr) + call zero(moments(i_field)%ptr) + call initialise_field_over_regions(moments(i_field)%ptr, & trim(moments(i_field)%ptr%option_path)//'/diagnostic/initial_condition', position) - end do - - do i_field = 1, n_abscissa - ! collect weighted_abscissa and weight fields and zero - type = 'weights' - call get_pop_field(state, i_pop, i_field, type, weights(i_field)%ptr) - type = 'weighted_abscissa' - call get_pop_field(state, i_pop, i_field, type, & + end do + + do i_field = 1, n_abscissa + ! collect weighted_abscissa and weight fields and zero + type = 'weights' + call get_pop_field(state, i_pop, i_field, type, weights(i_field)%ptr) + type = 'weighted_abscissa' + call get_pop_field(state, i_pop, i_field, type, & weighted_abscissa(i_field)%ptr) - call zero(weights(i_field)%ptr) - call zero(weighted_abscissa(i_field)%ptr) - end do - - do i_node = 1, node_count(moments(1)%ptr) - ! zero working arrays - P = 0.0 - Jac = 0.0 - alpha = 0.0 - e_vectors = 0.0 - e_values = 0.0 - - ! Construct P matrix - P(1,1) = 1.0 - ! set the zero'th moment to 1.0 for the purposes of finding the abscissa - ! weights will be multiplied by the zero'th moment later to obtain their correct - ! values - P(1,2) = 1.0 - do i = 2, 2*n_abscissa - P(i,2) = (-1)**(i-1)*(node_val(moments(i)%ptr, i_node)/node_val(moments(1)%ptr, i_node)) - end do - do j = 3, 2*n_abscissa + 1 - do i = 1, (2*n_abscissa + 1) - (j - 1) - P(i,j) = P(1,j-1)*P(i+1,j-2) - P(1,j-2)*P(i+1,j-1) - end do - end do - ! Construct alpha array - alpha(1) = 0.0 - do i = 2, 2*n_abscissa - alpha(i) = P(1,i+1)/(P(1,i)*P(1,i-1)) - end do - ! Construct jacobi matrix - do i = 1, n_abscissa - Jac(i,i) = alpha(2*i) + alpha(2*i - 1) - end do - do i = 1, n_abscissa - 1 - Jac(i, i+1) = ((alpha(2*i + 1)*alpha(2*i))**2.0)**0.25 - Jac(i+1, i) = ((alpha(2*i + 1)*alpha(2*i))**2.0)**0.25 - end do - - ! Calculate eigenvalues and eigenvectors - call eigendecomposition_symmetric(Jac, e_vectors, e_values, stat) - if (stat /= 0) then - FLExit('Cannot compute abscissa and weights using PD algorithm') - end if - - do i_field = 1, n_abscissa - ! set prognostic field values - call set(weights(i_field)%ptr, i_node, & + call zero(weights(i_field)%ptr) + call zero(weighted_abscissa(i_field)%ptr) + end do + + do i_node = 1, node_count(moments(1)%ptr) + ! zero working arrays + P = 0.0 + Jac = 0.0 + alpha = 0.0 + e_vectors = 0.0 + e_values = 0.0 + + ! Construct P matrix + P(1,1) = 1.0 + ! set the zero'th moment to 1.0 for the purposes of finding the abscissa + ! weights will be multiplied by the zero'th moment later to obtain their correct + ! values + P(1,2) = 1.0 + do i = 2, 2*n_abscissa + P(i,2) = (-1)**(i-1)*(node_val(moments(i)%ptr, i_node)/node_val(moments(1)%ptr, i_node)) + end do + do j = 3, 2*n_abscissa + 1 + do i = 1, (2*n_abscissa + 1) - (j - 1) + P(i,j) = P(1,j-1)*P(i+1,j-2) - P(1,j-2)*P(i+1,j-1) + end do + end do + ! Construct alpha array + alpha(1) = 0.0 + do i = 2, 2*n_abscissa + alpha(i) = P(1,i+1)/(P(1,i)*P(1,i-1)) + end do + ! Construct jacobi matrix + do i = 1, n_abscissa + Jac(i,i) = alpha(2*i) + alpha(2*i - 1) + end do + do i = 1, n_abscissa - 1 + Jac(i, i+1) = ((alpha(2*i + 1)*alpha(2*i))**2.0)**0.25 + Jac(i+1, i) = ((alpha(2*i + 1)*alpha(2*i))**2.0)**0.25 + end do + + ! Calculate eigenvalues and eigenvectors + call eigendecomposition_symmetric(Jac, e_vectors, e_values, stat) + if (stat /= 0) then + FLExit('Cannot compute abscissa and weights using PD algorithm') + end if + + do i_field = 1, n_abscissa + ! set prognostic field values + call set(weights(i_field)%ptr, i_node, & node_val(moments(1)%ptr, i_node) * e_vectors(1,i_field)**2) - call set(weighted_abscissa(i_field)%ptr, i_node, & + call set(weighted_abscissa(i_field)%ptr, i_node, & node_val(weights(i_field)%ptr, i_node) * e_values(i_field)) - end do - - end do - - deallocate(moments, weighted_abscissa, weights, P, Jac, alpha, e_vectors, e_values) - - end subroutine dqmom_PD_algorithm - - subroutine dqmom_calculate_abscissa(states) - - type(state_type), dimension(:), intent(in) :: states - - type(scalar_field), pointer :: abscissa, weight, weighted_abscissa - type(scalar_field) :: inv_weight - integer :: i_state, i_pop, i_abscissa - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: type - - ewrite(1, *) "In dqmom_calculate_abscissa" - do i_state = 1, option_count("/material_phase") - do i_pop = 1, option_count(trim(states(i_state)%option_path)//'/population_balance') - call get_pop_option_path(states(i_state), i_pop, option_path) - do i_abscissa = 1, option_count(trim(option_path)//'/abscissa/scalar_field') - ! get required fields - type = 'abscissa' - call get_pop_field(states(i_state), i_pop, i_abscissa, type, abscissa) - type = 'weights' - call get_pop_field(states(i_state), i_pop, i_abscissa, type, weight) - type = 'weighted_abscissa' - call get_pop_field(states(i_state), i_pop, i_abscissa, type, weighted_abscissa) - - ! calculate the inverse of the weights - call allocate(inv_weight, weight%mesh, 'InverseWeight') - call set(inv_weight, weight) - where (inv_weight%val/=0.0) - inv_weight%val=1./inv_weight%val - end where - - ! calculate abscissa - call set(abscissa, weighted_abscissa) - call scale(abscissa, inv_weight) - - call deallocate(inv_weight) - end do - end do - end do - ewrite(1, *) "Exiting dqmom_calculate_abscissa" - end subroutine dqmom_calculate_abscissa - - subroutine dqmom_apply_min_weight(states) - - type(state_type), dimension(:), intent(in) :: states - - type(scalar_field), pointer :: weight, weighted_abscissa - integer :: i_state, i_pop, i_abscissa - real :: minvalue - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: type - - ewrite(1, *) "In dqmom_apply_min_weight" - do i_state = 1, option_count("/material_phase") - do i_pop = 1, option_count(trim(states(i_state)%option_path)//'/population_balance') - call get_pop_option_path(states(i_state), i_pop, option_path) - do i_abscissa = 1, option_count(trim(option_path)//'/abscissa/scalar_field') - ! get required fields - type = 'weights' - call get_pop_field(states(i_state), i_pop, i_abscissa, type, weight) - type = 'weighted_abscissa' - call get_pop_field(states(i_state), i_pop, i_abscissa, type, weighted_abscissa) - - ! Get minimum weight value from the diamond file - call get_option(trim(option_path)//'/minimum_weight', minvalue) - where (weight%val.le.minvalue) - weight%val=minvalue - end where - - if (have_option(trim(option_path)//'/minimum_weighted_abscissa')) then - call get_option(trim(option_path)//'/minimum_weighted_abscissa', minvalue) - where (weighted_abscissa%val.le.minvalue) - weighted_abscissa%val=minvalue - end where - endif - end do - end do - end do - ewrite(1, *) "Exiting dqmom_apply_min_weight" - end subroutine dqmom_apply_min_weight - - subroutine dqmom_calculate_source_terms(states, it) - - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: it - - integer :: i_state, i_pop, cont_state = -1 - character(len=FIELD_NAME_LEN) :: cont_state_name - - ! find the continuous state number - if (have_option("/population_balance_continuous_phase_name")) then - call get_option("/population_balance_continuous_phase_name", cont_state_name) - do i_state = 1, option_count("/material_phase") - if (states(i_state)%name == cont_state_name) then - cont_state = i_state - exit - end if - end do - if (cont_state <0) then - FLAbort("Continuous state name you mentioned could not be located in the population balance calculations.") - end if - end if - - do i_state = 1, option_count("/material_phase") - do i_pop = 1, option_count(trim(states(i_state)%option_path)//'/population_balance') - call dqmom_calculate_source_term_pop(states(i_state), it, i_pop, states, cont_state) - end do - end do - - end subroutine dqmom_calculate_source_terms - - subroutine dqmom_calculate_source_term_pop(state, it, i_pop, states, cont_state) - - type(state_type), intent(inout) :: state - type(state_type), dimension(:), intent(inout) :: states - integer, intent(in) :: it - integer, intent(in) :: cont_state - - type(scalar_field_pointer), dimension(:), allocatable :: abscissa,& + end do + + end do + + deallocate(moments, weighted_abscissa, weights, P, Jac, alpha, e_vectors, e_values) + + end subroutine dqmom_PD_algorithm + + subroutine dqmom_calculate_abscissa(states) + + type(state_type), dimension(:), intent(in) :: states + + type(scalar_field), pointer :: abscissa, weight, weighted_abscissa + type(scalar_field) :: inv_weight + integer :: i_state, i_pop, i_abscissa + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: type + + ewrite(1, *) "In dqmom_calculate_abscissa" + do i_state = 1, option_count("/material_phase") + do i_pop = 1, option_count(trim(states(i_state)%option_path)//'/population_balance') + call get_pop_option_path(states(i_state), i_pop, option_path) + do i_abscissa = 1, option_count(trim(option_path)//'/abscissa/scalar_field') + ! get required fields + type = 'abscissa' + call get_pop_field(states(i_state), i_pop, i_abscissa, type, abscissa) + type = 'weights' + call get_pop_field(states(i_state), i_pop, i_abscissa, type, weight) + type = 'weighted_abscissa' + call get_pop_field(states(i_state), i_pop, i_abscissa, type, weighted_abscissa) + + ! calculate the inverse of the weights + call allocate(inv_weight, weight%mesh, 'InverseWeight') + call set(inv_weight, weight) + where (inv_weight%val/=0.0) + inv_weight%val=1./inv_weight%val + end where + + ! calculate abscissa + call set(abscissa, weighted_abscissa) + call scale(abscissa, inv_weight) + + call deallocate(inv_weight) + end do + end do + end do + ewrite(1, *) "Exiting dqmom_calculate_abscissa" + end subroutine dqmom_calculate_abscissa + + subroutine dqmom_apply_min_weight(states) + + type(state_type), dimension(:), intent(in) :: states + + type(scalar_field), pointer :: weight, weighted_abscissa + integer :: i_state, i_pop, i_abscissa + real :: minvalue + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: type + + ewrite(1, *) "In dqmom_apply_min_weight" + do i_state = 1, option_count("/material_phase") + do i_pop = 1, option_count(trim(states(i_state)%option_path)//'/population_balance') + call get_pop_option_path(states(i_state), i_pop, option_path) + do i_abscissa = 1, option_count(trim(option_path)//'/abscissa/scalar_field') + ! get required fields + type = 'weights' + call get_pop_field(states(i_state), i_pop, i_abscissa, type, weight) + type = 'weighted_abscissa' + call get_pop_field(states(i_state), i_pop, i_abscissa, type, weighted_abscissa) + + ! Get minimum weight value from the diamond file + call get_option(trim(option_path)//'/minimum_weight', minvalue) + where (weight%val.le.minvalue) + weight%val=minvalue + end where + + if (have_option(trim(option_path)//'/minimum_weighted_abscissa')) then + call get_option(trim(option_path)//'/minimum_weighted_abscissa', minvalue) + where (weighted_abscissa%val.le.minvalue) + weighted_abscissa%val=minvalue + end where + endif + end do + end do + end do + ewrite(1, *) "Exiting dqmom_apply_min_weight" + end subroutine dqmom_apply_min_weight + + subroutine dqmom_calculate_source_terms(states, it) + + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: it + + integer :: i_state, i_pop, cont_state = -1 + character(len=FIELD_NAME_LEN) :: cont_state_name + + ! find the continuous state number + if (have_option("/population_balance_continuous_phase_name")) then + call get_option("/population_balance_continuous_phase_name", cont_state_name) + do i_state = 1, option_count("/material_phase") + if (states(i_state)%name == cont_state_name) then + cont_state = i_state + exit + end if + end do + if (cont_state <0) then + FLAbort("Continuous state name you mentioned could not be located in the population balance calculations.") + end if + end if + + do i_state = 1, option_count("/material_phase") + do i_pop = 1, option_count(trim(states(i_state)%option_path)//'/population_balance') + call dqmom_calculate_source_term_pop(states(i_state), it, i_pop, states, cont_state) + end do + end do + + end subroutine dqmom_calculate_source_terms + + subroutine dqmom_calculate_source_term_pop(state, it, i_pop, states, cont_state) + + type(state_type), intent(inout) :: state + type(state_type), dimension(:), intent(inout) :: states + integer, intent(in) :: it + integer, intent(in) :: cont_state + + type(scalar_field_pointer), dimension(:), allocatable :: abscissa,& weight, it_abscissa, it_weight, weighted_abscissa, s_weighted_abscissa, s_weight, a_weighted_abscissa, a_weight - type(scalar_field), pointer :: lumped_mass, turbulent_dissipation, sponge_field - type(tensor_field), pointer :: viscosity_continuous - type(csr_matrix), pointer :: mass_matrix - type(scalar_field), dimension(:), allocatable :: r_abscissa, r_weight - type(tensor_field), pointer :: D - type(vector_field), pointer :: X - type(scalar_field) :: dummy_scalar - real :: theta, cond, growth_r, internal_dispersion_coeff, aggregation_freq_const, breakage_freq_const, breakage_freq_degree, perturb_val, C5 - integer :: i_pop, N, i, j, stat, i_node - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: type, field_name, growth_type, aggregation_freq_type, breakage_freq_type, breakage_dist_type, singular_option - logical :: have_D = .false. - logical :: have_growth = .FALSE. - logical :: have_internal_dispersion = .FALSE. - logical :: have_aggregation = .FALSE. - logical :: have_breakage = .FALSE. - - call get_pop_option_path(state, i_pop, option_path) - N = option_count(trim(option_path)//'/abscissa/scalar_field') - allocate(abscissa(N), weight(N), it_abscissa(N), it_weight(N), & + type(scalar_field), pointer :: lumped_mass, turbulent_dissipation, sponge_field + type(tensor_field), pointer :: viscosity_continuous + type(csr_matrix), pointer :: mass_matrix + type(scalar_field), dimension(:), allocatable :: r_abscissa, r_weight + type(tensor_field), pointer :: D + type(vector_field), pointer :: X + type(scalar_field) :: dummy_scalar + real :: theta, cond, growth_r, internal_dispersion_coeff, aggregation_freq_const, breakage_freq_const, breakage_freq_degree, perturb_val, C5 + integer :: i_pop, N, i, j, stat, i_node + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: type, field_name, growth_type, aggregation_freq_type, breakage_freq_type, breakage_dist_type, singular_option + logical :: have_D = .false. + logical :: have_growth = .FALSE. + logical :: have_internal_dispersion = .FALSE. + logical :: have_aggregation = .FALSE. + logical :: have_breakage = .FALSE. + + call get_pop_option_path(state, i_pop, option_path) + N = option_count(trim(option_path)//'/abscissa/scalar_field') + allocate(abscissa(N), weight(N), it_abscissa(N), it_weight(N), & r_abscissa(N), r_weight(N), weighted_abscissa(N), s_weighted_abscissa(N), s_weight(N), a_weighted_abscissa(N), a_weight(N)) - do i = 1, N - ! collect abscissa and weight fields - type = 'weights' - call get_pop_field(state, i_pop, i, type, weight(i)%ptr) - call get_pop_field(state, i_pop, i, type, it_weight(i)%ptr, iterated=.true.) - type = 'abscissa' - call get_pop_field(state, i_pop, i, type, abscissa(i)%ptr) - call get_pop_field(state, i_pop, i, type, it_abscissa(i)%ptr, iterated=.true.) - type = 'weighted_abscissa' - call get_pop_field(state, i_pop, i, type, weighted_abscissa(i)%ptr) - - ! get source fields (note this is the weighted abscissa source not the abscissa source) - s_weight(i)%ptr => extract_scalar_field(state, trim(weight(i)%ptr%name)//'Source') - call get_option(trim(option_path)//'/weighted_abscissa/scalar_field['// & + do i = 1, N + ! collect abscissa and weight fields + type = 'weights' + call get_pop_field(state, i_pop, i, type, weight(i)%ptr) + call get_pop_field(state, i_pop, i, type, it_weight(i)%ptr, iterated=.true.) + type = 'abscissa' + call get_pop_field(state, i_pop, i, type, abscissa(i)%ptr) + call get_pop_field(state, i_pop, i, type, it_abscissa(i)%ptr, iterated=.true.) + type = 'weighted_abscissa' + call get_pop_field(state, i_pop, i, type, weighted_abscissa(i)%ptr) + + ! get source fields (note this is the weighted abscissa source not the abscissa source) + s_weight(i)%ptr => extract_scalar_field(state, trim(weight(i)%ptr%name)//'Source') + call get_option(trim(option_path)//'/weighted_abscissa/scalar_field['// & int2str(i - 1)//']/name', field_name) - s_weighted_abscissa(i)%ptr => extract_scalar_field(state, trim(field_name)//'Source') - call zero(s_weight(i)%ptr) - call zero(s_weighted_abscissa(i)%ptr) + s_weighted_abscissa(i)%ptr => extract_scalar_field(state, trim(field_name)//'Source') + call zero(s_weight(i)%ptr) + call zero(s_weighted_abscissa(i)%ptr) - ! relax non-linear values - ! all temporal relaxations must be the same - call get_option(trim(weight(i)%ptr%option_path)// & + ! relax non-linear values + ! all temporal relaxations must be the same + call get_option(trim(weight(i)%ptr%option_path)// & '/prognostic/temporal_discretisation/theta', theta) - ! do not recalculate source terms if theta = 0.0 after first non-linear iteration - if ((theta == 0.0) .and. (it /= 1)) then - return - end if - call allocate(r_abscissa(i), abscissa(i)%ptr%mesh, & + ! do not recalculate source terms if theta = 0.0 after first non-linear iteration + if ((theta == 0.0) .and. (it /= 1)) then + return + end if + call allocate(r_abscissa(i), abscissa(i)%ptr%mesh, & "RelaxedAbscissa"//int2str(i)) - call allocate(r_weight(i), weight(i)%ptr%mesh, "RelaxedWeight"//int2str(i)) - call set(r_abscissa(i), it_abscissa(i)%ptr) - call scale(r_abscissa(i), theta) - call addto(r_abscissa(i), abscissa(i)%ptr, 1.0-theta) - call set(r_weight(i), it_weight(i)%ptr) - call scale(r_weight(i), theta) - call addto(r_weight(i), weight(i)%ptr, 1.0-theta) - end do - - call allocate(dummy_scalar, r_abscissa(1)%mesh, name="DummyScalar") - - ! get diffusion - D => extract_tensor_field(state, trim(weight(1)%ptr%name)//'Diffusivity',stat) - if (stat == 0) then - have_D = .true. - end if - - ! check for growth term - if (have_option(trim(option_path)//'/population_balance_source_terms/growth')) then - have_growth = .TRUE. - if (have_option(trim(option_path)//'/population_balance_source_terms/growth/power_law_growth')) then - growth_type = 'power_law_growth'; - call get_option(trim(option_path)//'/population_balance_source_terms/growth/power_law_growth', growth_r) - end if - else - have_growth = .FALSE. - end if - - ! check for internal dispersion term - if (have_option(trim(option_path)//'/population_balance_source_terms/internal_dispersion')) then - have_internal_dispersion = .TRUE. - call get_option(trim(option_path)//'/population_balance_source_terms/internal_dispersion', internal_dispersion_coeff) - else - have_internal_dispersion = .FALSE. - end if - - ! check for aggregation term - if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation')) then - have_aggregation = .TRUE. - if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/constant_aggregation')) then - aggregation_freq_type = 'constant_aggregation' - call get_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/constant_aggregation', aggregation_freq_const) - else if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/hydrodynamic_aggregation')) then - aggregation_freq_type = 'hydrodynamic_aggregation' - else if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/sum_aggregation')) then - aggregation_freq_type = 'sum_aggregation' - call get_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/sum_aggregation', aggregation_freq_const) - else if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/laakkonen_2007_aggregation')) then - aggregation_freq_type = 'laakkonen_2007_aggregation' - call get_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/laakkonen_2007_aggregation/C5', C5, default = 0.88) - if (.not. have_option("/population_balance_continuous_phase_name")) then - FLAbort("Enable the option population_balance_continuous_phase_name and provide a name for the continuous phase& - as it is needed for extracting the turbulence dissipation needed in laakkonen_2007_aggregation kernel") - end if - turbulent_dissipation => extract_scalar_field(states(cont_state), "TurbulentDissipation", stat=stat) - if (stat/=0) then - FLAbort("I can't find the Turbulent Dissipation field of continuous phase for population balance aggregation term calculations.") - end if - if (have_option(trim(states(cont_state)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then - viscosity_continuous => extract_tensor_field(states(cont_state), "BackgroundViscosity", stat=stat) - if (stat/=0) then - FLAbort("I can't find the Background Viscosity field in k-epsilon for continuous phase for population balance aggregation term calculations.") - end if - else - viscosity_continuous => extract_tensor_field(states(cont_state), "Viscosity", stat=stat) - if (stat/=0) then - FLAbort("I can't find the Viscosity field for continuous phase for population balance aggregation term calculations.") - end if - end if - end if - else - have_aggregation = .FALSE. - end if - - ! check for breakage term - if (have_option(trim(option_path)//'/population_balance_source_terms/breakage')) then - have_breakage = .TRUE. - if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/constant_breakage')) then - breakage_freq_type = 'constant_breakage' - call get_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/constant_breakage', breakage_freq_const) - else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/power_law_breakage')) then - breakage_freq_type = 'power_law_breakage' - call get_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/power_law_breakage/coefficient', breakage_freq_const) - call get_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/power_law_breakage/degree', breakage_freq_degree) - else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/laakkonen_breakage')) then - breakage_freq_type = 'laakkonen_frequency' - if (aggregation_freq_type /= 'laakkonen_2007_aggregation') then - if (.not. have_option("/population_balance_continuous_phase_name")) then - FLAbort("Enable the option population_balance_continuous_phase_name and provide a name for the continuous phase & - as it is needed for extracting the turbulence dissipation needed in laakkonen_frequency kernel") - end if - turbulent_dissipation => extract_scalar_field(states(cont_state), "TurbulentDissipation", stat=stat) - if (stat/=0) then - FLAbort("I can't find the Turbulent Dissipation field of continuous phase for population balance breakage term calculations.") - end if - if (have_option(trim(states(cont_state)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then - viscosity_continuous => extract_tensor_field(states(cont_state), "BackgroundViscosity", stat=stat) - if (stat/=0) then - FLAbort("I can't find the Background Viscosity field in k-epsilon for continuous phase for population balance aggregation term calculations.") - end if - else - viscosity_continuous => extract_tensor_field(states(cont_state), "Viscosity", stat=stat) - if (stat/=0) then - FLAbort("I can't find the Viscosity field for continuous phase for population balance aggregation term calculations.") - end if - end if - end if - end if - - if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/distribution_function/symmetric_fragmentation')) then - breakage_dist_type = 'symmetric_fragmentation' - else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/distribution_function/mcCoy_madras_2003')) then - breakage_dist_type = 'mcCoy_madras_2003' - else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/distribution_function/laakkonen_2007')) then - breakage_dist_type = 'laakkonen_2007' - end if - - else - have_breakage = .FALSE. - end if - - ! get ill-conditioned matrix settings - call get_option(trim(option_path)//'/ill_conditioned_matrices/required_condition_number', cond) - if (have_option(trim(option_path)//'/ill_conditioned_matrices/set_source_to_zero')) then - singular_option = 'set_source_to_zero'; - else if (have_option(trim(option_path)//'/ill_conditioned_matrices/perturbate')) then - singular_option = 'perturbate'; - call get_option(trim(option_path)//'/ill_conditioned_matrices/perturbate/perturbation', perturb_val) - else if (have_option(trim(option_path)//'/ill_conditioned_matrices/do_nothing')) then - singular_option = 'do_nothing'; - end if - - X => extract_vector_field(state, 'Coordinate') - - ! assembly loop - do i = 1, ele_count(r_abscissa(1)) - call dqmom_calculate_source_term_ele(r_abscissa, r_weight, s_weighted_abscissa, s_weight, & - &D, have_D, have_growth, growth_type, growth_r, have_internal_dispersion, internal_dispersion_coeff, & - &have_aggregation, aggregation_freq_type, aggregation_freq_const, C5, & - &have_breakage, breakage_freq_type, breakage_freq_const, breakage_freq_degree, breakage_dist_type, & - &turbulent_dissipation, viscosity_continuous, X, singular_option, perturb_val, cond, i) - end do - - ! for non-DG we apply inverse mass globally - if(continuity(r_abscissa(1))>=0) then - if(have_option(trim(option_path)//'/adv_diff_source_term_interpolation/use_full_mass_matrix')) then - mass_matrix => get_mass_matrix(state, r_abscissa(1)%mesh) - do j = 1, N - call zero(dummy_scalar) - call petsc_solve(dummy_scalar, mass_matrix, s_weight(j)%ptr, trim(option_path)//'/adv_diff_source_term_interpolation/use_full_mass_matrix') - call set(s_weight(j)%ptr, dummy_scalar) - call zero(dummy_scalar) - call petsc_solve(dummy_scalar, mass_matrix, s_weighted_abscissa(j)%ptr, trim(option_path)//'/adv_diff_source_term_interpolation/use_full_mass_matrix') - call set(s_weighted_abscissa(j)%ptr, dummy_scalar) - end do - else if(have_option(trim(option_path)//'/adv_diff_source_term_interpolation/use_mass_lumping')) then - lumped_mass => get_lumped_mass(state, r_abscissa(1)%mesh) - do j = 1, N - do i = 1, node_count(r_abscissa(1)) - call set(s_weighted_abscissa(j)%ptr, i, node_val(s_weighted_abscissa(j)%ptr,i)& - &/node_val(lumped_mass,i)) - call set(s_weight(j)%ptr, i, node_val(s_weight(j)%ptr,i)& - &/node_val(lumped_mass,i)) - end do - end do - else - FLAbort("Check the .flml file. You must specify an option under 'population_balance/adv_diff_source_term_interpolation'") - end if - end if - - ! Checking if the source terms need to be implemented as absorption - if(have_option(trim(option_path)//'/apply_source_as_absorption')) then - do i =1, N - a_weight(i)%ptr => extract_scalar_field(state, trim(weight(i)%ptr%name)//'Absorption', stat) - if (stat/=0) then - FLAbort("Absorption scalar field could not be extracted for population balance weights. How can I apply the source as absorption now!") - end if - where (weight(i)%ptr%val >= fields_min) - a_weight(i)%ptr%val=-1./weight(i)%ptr%val - elsewhere - a_weight(i)%ptr%val=-1./fields_min - end where - call scale(a_weight(i)%ptr, s_weight(i)%ptr) - - call get_option(trim(option_path)//'/weighted_abscissa/scalar_field['// & - int2str(i - 1)//']/name', field_name) - a_weighted_abscissa(i)%ptr => extract_scalar_field(state, trim(field_name)//'Absorption', stat) - if (stat/=0) then - FLAbort("Absorption scalar field could not be extracted for population balance weighted_abscissa. How can I apply the source as absorption now!") - end if - ! set dummy_scalar = weight * abscissa - call set(dummy_scalar, abscissa(i)%ptr) - call scale(dummy_scalar, weight(i)%ptr) - where (dummy_scalar%val >= fields_min) - a_weighted_abscissa(i)%ptr%val=-1./dummy_scalar%val - elsewhere - a_weighted_abscissa(i)%ptr%val=-1./fields_min - end where - call scale(a_weighted_abscissa(i)%ptr, s_weighted_abscissa(i)%ptr) - - ! make source terms zero now to prevent applying them twice - call zero(s_weight(i)%ptr) - call zero(s_weighted_abscissa(i)%ptr) - end do - if(have_option(trim(option_path)//'/apply_source_as_absorption/include_sponge_region')) then - ! extract name of the sponge field - call get_option(trim(option_path)//'/apply_source_as_absorption/include_sponge_region/sponge_scalar_field_name', field_name) - sponge_field => extract_scalar_field(state, field_name, stat) - if (stat/=0) then - FLAbort("Scalar sponge field could not be located in the state.") - end if - ! define temp_field - use dummy_scalar - call zero(dummy_scalar) - where (sponge_field%val<0.001) - dummy_scalar%val = 1.0 - end where - ! abs_new = abs_old*temp_field + sponge_field... make sure the sponge field stays the same - do i=1, N - call scale(a_weight(i)%ptr, dummy_scalar) - call addto(a_weight(i)%ptr, sponge_field) - call scale(a_weighted_abscissa(i)%ptr, dummy_scalar) - call addto(a_weighted_abscissa(i)%ptr, sponge_field) - end do - end if - - end if - - ! S = S_c + S_p phi_p. If S is positive, S=S_c otherwise S=S_p phi_p. This makes sure that the scalar remains non-negative. - ! See Pg 145 Numerical Heat Transfer and Fluid Flow by Suhas V. Patankar - if(have_option(trim(option_path)//'/apply_source_as_absorption_for_negative_source_only')) then - do i =1, N - a_weight(i)%ptr => extract_scalar_field(state, trim(weight(i)%ptr%name)//'Absorption', stat) - if (stat/=0) then - FLAbort("Absorption scalar field could not be extracted for population balance weights. How can I apply the source as absorption now!") - end if - call zero(a_weight(i)%ptr) - do i_node=1, node_count(weight(i)%ptr) - if (node_val(s_weight(i)%ptr, i_node)<0.0) then - if (node_val(weight(i)%ptr, i_node)>fields_min) then - call set(a_weight(i)%ptr, i_node, -1.0*node_val(s_weight(i)%ptr, i_node)*(1./node_val(weight(i)%ptr, i_node))) - else - call set(a_weight(i)%ptr, i_node, -1.0*node_val(s_weight(i)%ptr, i_node)*(1./fields_min)) - end if - call set(s_weight(i)%ptr, i_node, 0.0) - end if - end do - - call get_option(trim(option_path)//'/weighted_abscissa/scalar_field['// & - int2str(i - 1)//']/name', field_name) - a_weighted_abscissa(i)%ptr => extract_scalar_field(state, trim(field_name)//'Absorption', stat) - if (stat/=0) then - FLAbort("Absorption scalar field could not be extracted for population balance weighted_abscissa. How can I apply the source as absorption now!") - end if - call zero(a_weighted_abscissa(i)%ptr) - ! set dummy_scalar = weight * abscissa - call set(dummy_scalar, abscissa(i)%ptr) - call scale(dummy_scalar, weight(i)%ptr) - do i_node=1, node_count(weight(i)%ptr) - if (node_val(s_weighted_abscissa(i)%ptr, i_node)<0.0) then - if (node_val(dummy_scalar, i_node)>fields_min) then - call set(a_weighted_abscissa(i)%ptr, i_node, -1.0*node_val(s_weighted_abscissa(i)%ptr, i_node)*(1./node_val(dummy_scalar, i_node))) - else - call set(a_weighted_abscissa(i)%ptr, i_node, -1.0*node_val(s_weighted_abscissa(i)%ptr, i_node)*(1./fields_min)) - end if - call set(s_weighted_abscissa(i)%ptr, i_node, 0.0) - end if - end do - end do - - if(have_option(trim(option_path)//'/apply_source_as_absorption_for_negative_source_only/include_sponge_region')) then - ! extract name of the sponge field - call get_option(trim(option_path)//'/apply_source_as_absorption_for_negative_source_only/include_sponge_region/sponge_scalar_field_name', field_name) - sponge_field => extract_scalar_field(state, field_name, stat) - if (stat/=0) then - FLAbort("Scalar sponge field could not be located in the state.") - end if - ! define temp_field - use dummy_scalar - call zero(dummy_scalar) - where (sponge_field%val<0.001) - dummy_scalar%val = 1.0 - end where - ! abs_new = abs_old*temp_field + sponge_field... make sure the sponge field stays the same - do i=1, N - call scale(a_weight(i)%ptr, dummy_scalar) - call addto(a_weight(i)%ptr, sponge_field) - call scale(a_weighted_abscissa(i)%ptr, dummy_scalar) - call addto(a_weighted_abscissa(i)%ptr, sponge_field) - end do - end if - - end if - - - call deallocate(dummy_scalar) - do i = 1, N - call deallocate(r_abscissa(i)) - call deallocate(r_weight(i)) - end do - deallocate(abscissa, weight, it_abscissa, it_weight, & + call allocate(r_weight(i), weight(i)%ptr%mesh, "RelaxedWeight"//int2str(i)) + call set(r_abscissa(i), it_abscissa(i)%ptr) + call scale(r_abscissa(i), theta) + call addto(r_abscissa(i), abscissa(i)%ptr, 1.0-theta) + call set(r_weight(i), it_weight(i)%ptr) + call scale(r_weight(i), theta) + call addto(r_weight(i), weight(i)%ptr, 1.0-theta) + end do + + call allocate(dummy_scalar, r_abscissa(1)%mesh, name="DummyScalar") + + ! get diffusion + D => extract_tensor_field(state, trim(weight(1)%ptr%name)//'Diffusivity',stat) + if (stat == 0) then + have_D = .true. + end if + + ! check for growth term + if (have_option(trim(option_path)//'/population_balance_source_terms/growth')) then + have_growth = .TRUE. + if (have_option(trim(option_path)//'/population_balance_source_terms/growth/power_law_growth')) then + growth_type = 'power_law_growth'; + call get_option(trim(option_path)//'/population_balance_source_terms/growth/power_law_growth', growth_r) + end if + else + have_growth = .FALSE. + end if + + ! check for internal dispersion term + if (have_option(trim(option_path)//'/population_balance_source_terms/internal_dispersion')) then + have_internal_dispersion = .TRUE. + call get_option(trim(option_path)//'/population_balance_source_terms/internal_dispersion', internal_dispersion_coeff) + else + have_internal_dispersion = .FALSE. + end if + + ! check for aggregation term + if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation')) then + have_aggregation = .TRUE. + if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/constant_aggregation')) then + aggregation_freq_type = 'constant_aggregation' + call get_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/constant_aggregation', aggregation_freq_const) + else if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/hydrodynamic_aggregation')) then + aggregation_freq_type = 'hydrodynamic_aggregation' + else if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/sum_aggregation')) then + aggregation_freq_type = 'sum_aggregation' + call get_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/sum_aggregation', aggregation_freq_const) + else if (have_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/laakkonen_2007_aggregation')) then + aggregation_freq_type = 'laakkonen_2007_aggregation' + call get_option(trim(option_path)//'/population_balance_source_terms/aggregation/aggregation_frequency/laakkonen_2007_aggregation/C5', C5, default = 0.88) + if (.not. have_option("/population_balance_continuous_phase_name")) then + FLAbort("Enable the option population_balance_continuous_phase_name and provide a name for the continuous phase& + as it is needed for extracting the turbulence dissipation needed in laakkonen_2007_aggregation kernel") + end if + turbulent_dissipation => extract_scalar_field(states(cont_state), "TurbulentDissipation", stat=stat) + if (stat/=0) then + FLAbort("I can't find the Turbulent Dissipation field of continuous phase for population balance aggregation term calculations.") + end if + if (have_option(trim(states(cont_state)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then + viscosity_continuous => extract_tensor_field(states(cont_state), "BackgroundViscosity", stat=stat) + if (stat/=0) then + FLAbort("I can't find the Background Viscosity field in k-epsilon for continuous phase for population balance aggregation term calculations.") + end if + else + viscosity_continuous => extract_tensor_field(states(cont_state), "Viscosity", stat=stat) + if (stat/=0) then + FLAbort("I can't find the Viscosity field for continuous phase for population balance aggregation term calculations.") + end if + end if + end if + else + have_aggregation = .FALSE. + end if + + ! check for breakage term + if (have_option(trim(option_path)//'/population_balance_source_terms/breakage')) then + have_breakage = .TRUE. + if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/constant_breakage')) then + breakage_freq_type = 'constant_breakage' + call get_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/constant_breakage', breakage_freq_const) + else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/power_law_breakage')) then + breakage_freq_type = 'power_law_breakage' + call get_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/power_law_breakage/coefficient', breakage_freq_const) + call get_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/power_law_breakage/degree', breakage_freq_degree) + else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/breakage_frequency/laakkonen_breakage')) then + breakage_freq_type = 'laakkonen_frequency' + if (aggregation_freq_type /= 'laakkonen_2007_aggregation') then + if (.not. have_option("/population_balance_continuous_phase_name")) then + FLAbort("Enable the option population_balance_continuous_phase_name and provide a name for the continuous phase & + as it is needed for extracting the turbulence dissipation needed in laakkonen_frequency kernel") + end if + turbulent_dissipation => extract_scalar_field(states(cont_state), "TurbulentDissipation", stat=stat) + if (stat/=0) then + FLAbort("I can't find the Turbulent Dissipation field of continuous phase for population balance breakage term calculations.") + end if + if (have_option(trim(states(cont_state)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then + viscosity_continuous => extract_tensor_field(states(cont_state), "BackgroundViscosity", stat=stat) + if (stat/=0) then + FLAbort("I can't find the Background Viscosity field in k-epsilon for continuous phase for population balance aggregation term calculations.") + end if + else + viscosity_continuous => extract_tensor_field(states(cont_state), "Viscosity", stat=stat) + if (stat/=0) then + FLAbort("I can't find the Viscosity field for continuous phase for population balance aggregation term calculations.") + end if + end if + end if + end if + + if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/distribution_function/symmetric_fragmentation')) then + breakage_dist_type = 'symmetric_fragmentation' + else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/distribution_function/mcCoy_madras_2003')) then + breakage_dist_type = 'mcCoy_madras_2003' + else if (have_option(trim(option_path)//'/population_balance_source_terms/breakage/distribution_function/laakkonen_2007')) then + breakage_dist_type = 'laakkonen_2007' + end if + + else + have_breakage = .FALSE. + end if + + ! get ill-conditioned matrix settings + call get_option(trim(option_path)//'/ill_conditioned_matrices/required_condition_number', cond) + if (have_option(trim(option_path)//'/ill_conditioned_matrices/set_source_to_zero')) then + singular_option = 'set_source_to_zero'; + else if (have_option(trim(option_path)//'/ill_conditioned_matrices/perturbate')) then + singular_option = 'perturbate'; + call get_option(trim(option_path)//'/ill_conditioned_matrices/perturbate/perturbation', perturb_val) + else if (have_option(trim(option_path)//'/ill_conditioned_matrices/do_nothing')) then + singular_option = 'do_nothing'; + end if + + X => extract_vector_field(state, 'Coordinate') + + ! assembly loop + do i = 1, ele_count(r_abscissa(1)) + call dqmom_calculate_source_term_ele(r_abscissa, r_weight, s_weighted_abscissa, s_weight, & + &D, have_D, have_growth, growth_type, growth_r, have_internal_dispersion, internal_dispersion_coeff, & + &have_aggregation, aggregation_freq_type, aggregation_freq_const, C5, & + &have_breakage, breakage_freq_type, breakage_freq_const, breakage_freq_degree, breakage_dist_type, & + &turbulent_dissipation, viscosity_continuous, X, singular_option, perturb_val, cond, i) + end do + + ! for non-DG we apply inverse mass globally + if(continuity(r_abscissa(1))>=0) then + if(have_option(trim(option_path)//'/adv_diff_source_term_interpolation/use_full_mass_matrix')) then + mass_matrix => get_mass_matrix(state, r_abscissa(1)%mesh) + do j = 1, N + call zero(dummy_scalar) + call petsc_solve(dummy_scalar, mass_matrix, s_weight(j)%ptr, trim(option_path)//'/adv_diff_source_term_interpolation/use_full_mass_matrix') + call set(s_weight(j)%ptr, dummy_scalar) + call zero(dummy_scalar) + call petsc_solve(dummy_scalar, mass_matrix, s_weighted_abscissa(j)%ptr, trim(option_path)//'/adv_diff_source_term_interpolation/use_full_mass_matrix') + call set(s_weighted_abscissa(j)%ptr, dummy_scalar) + end do + else if(have_option(trim(option_path)//'/adv_diff_source_term_interpolation/use_mass_lumping')) then + lumped_mass => get_lumped_mass(state, r_abscissa(1)%mesh) + do j = 1, N + do i = 1, node_count(r_abscissa(1)) + call set(s_weighted_abscissa(j)%ptr, i, node_val(s_weighted_abscissa(j)%ptr,i)& + &/node_val(lumped_mass,i)) + call set(s_weight(j)%ptr, i, node_val(s_weight(j)%ptr,i)& + &/node_val(lumped_mass,i)) + end do + end do + else + FLAbort("Check the .flml file. You must specify an option under 'population_balance/adv_diff_source_term_interpolation'") + end if + end if + + ! Checking if the source terms need to be implemented as absorption + if(have_option(trim(option_path)//'/apply_source_as_absorption')) then + do i =1, N + a_weight(i)%ptr => extract_scalar_field(state, trim(weight(i)%ptr%name)//'Absorption', stat) + if (stat/=0) then + FLAbort("Absorption scalar field could not be extracted for population balance weights. How can I apply the source as absorption now!") + end if + where (weight(i)%ptr%val >= fields_min) + a_weight(i)%ptr%val=-1./weight(i)%ptr%val + elsewhere + a_weight(i)%ptr%val=-1./fields_min + end where + call scale(a_weight(i)%ptr, s_weight(i)%ptr) + + call get_option(trim(option_path)//'/weighted_abscissa/scalar_field['// & + int2str(i - 1)//']/name', field_name) + a_weighted_abscissa(i)%ptr => extract_scalar_field(state, trim(field_name)//'Absorption', stat) + if (stat/=0) then + FLAbort("Absorption scalar field could not be extracted for population balance weighted_abscissa. How can I apply the source as absorption now!") + end if + ! set dummy_scalar = weight * abscissa + call set(dummy_scalar, abscissa(i)%ptr) + call scale(dummy_scalar, weight(i)%ptr) + where (dummy_scalar%val >= fields_min) + a_weighted_abscissa(i)%ptr%val=-1./dummy_scalar%val + elsewhere + a_weighted_abscissa(i)%ptr%val=-1./fields_min + end where + call scale(a_weighted_abscissa(i)%ptr, s_weighted_abscissa(i)%ptr) + + ! make source terms zero now to prevent applying them twice + call zero(s_weight(i)%ptr) + call zero(s_weighted_abscissa(i)%ptr) + end do + if(have_option(trim(option_path)//'/apply_source_as_absorption/include_sponge_region')) then + ! extract name of the sponge field + call get_option(trim(option_path)//'/apply_source_as_absorption/include_sponge_region/sponge_scalar_field_name', field_name) + sponge_field => extract_scalar_field(state, field_name, stat) + if (stat/=0) then + FLAbort("Scalar sponge field could not be located in the state.") + end if + ! define temp_field - use dummy_scalar + call zero(dummy_scalar) + where (sponge_field%val<0.001) + dummy_scalar%val = 1.0 + end where + ! abs_new = abs_old*temp_field + sponge_field... make sure the sponge field stays the same + do i=1, N + call scale(a_weight(i)%ptr, dummy_scalar) + call addto(a_weight(i)%ptr, sponge_field) + call scale(a_weighted_abscissa(i)%ptr, dummy_scalar) + call addto(a_weighted_abscissa(i)%ptr, sponge_field) + end do + end if + + end if + + ! S = S_c + S_p phi_p. If S is positive, S=S_c otherwise S=S_p phi_p. This makes sure that the scalar remains non-negative. + ! See Pg 145 Numerical Heat Transfer and Fluid Flow by Suhas V. Patankar + if(have_option(trim(option_path)//'/apply_source_as_absorption_for_negative_source_only')) then + do i =1, N + a_weight(i)%ptr => extract_scalar_field(state, trim(weight(i)%ptr%name)//'Absorption', stat) + if (stat/=0) then + FLAbort("Absorption scalar field could not be extracted for population balance weights. How can I apply the source as absorption now!") + end if + call zero(a_weight(i)%ptr) + do i_node=1, node_count(weight(i)%ptr) + if (node_val(s_weight(i)%ptr, i_node)<0.0) then + if (node_val(weight(i)%ptr, i_node)>fields_min) then + call set(a_weight(i)%ptr, i_node, -1.0*node_val(s_weight(i)%ptr, i_node)*(1./node_val(weight(i)%ptr, i_node))) + else + call set(a_weight(i)%ptr, i_node, -1.0*node_val(s_weight(i)%ptr, i_node)*(1./fields_min)) + end if + call set(s_weight(i)%ptr, i_node, 0.0) + end if + end do + + call get_option(trim(option_path)//'/weighted_abscissa/scalar_field['// & + int2str(i - 1)//']/name', field_name) + a_weighted_abscissa(i)%ptr => extract_scalar_field(state, trim(field_name)//'Absorption', stat) + if (stat/=0) then + FLAbort("Absorption scalar field could not be extracted for population balance weighted_abscissa. How can I apply the source as absorption now!") + end if + call zero(a_weighted_abscissa(i)%ptr) + ! set dummy_scalar = weight * abscissa + call set(dummy_scalar, abscissa(i)%ptr) + call scale(dummy_scalar, weight(i)%ptr) + do i_node=1, node_count(weight(i)%ptr) + if (node_val(s_weighted_abscissa(i)%ptr, i_node)<0.0) then + if (node_val(dummy_scalar, i_node)>fields_min) then + call set(a_weighted_abscissa(i)%ptr, i_node, -1.0*node_val(s_weighted_abscissa(i)%ptr, i_node)*(1./node_val(dummy_scalar, i_node))) + else + call set(a_weighted_abscissa(i)%ptr, i_node, -1.0*node_val(s_weighted_abscissa(i)%ptr, i_node)*(1./fields_min)) + end if + call set(s_weighted_abscissa(i)%ptr, i_node, 0.0) + end if + end do + end do + + if(have_option(trim(option_path)//'/apply_source_as_absorption_for_negative_source_only/include_sponge_region')) then + ! extract name of the sponge field + call get_option(trim(option_path)//'/apply_source_as_absorption_for_negative_source_only/include_sponge_region/sponge_scalar_field_name', field_name) + sponge_field => extract_scalar_field(state, field_name, stat) + if (stat/=0) then + FLAbort("Scalar sponge field could not be located in the state.") + end if + ! define temp_field - use dummy_scalar + call zero(dummy_scalar) + where (sponge_field%val<0.001) + dummy_scalar%val = 1.0 + end where + ! abs_new = abs_old*temp_field + sponge_field... make sure the sponge field stays the same + do i=1, N + call scale(a_weight(i)%ptr, dummy_scalar) + call addto(a_weight(i)%ptr, sponge_field) + call scale(a_weighted_abscissa(i)%ptr, dummy_scalar) + call addto(a_weighted_abscissa(i)%ptr, sponge_field) + end do + end if + + end if + + + call deallocate(dummy_scalar) + do i = 1, N + call deallocate(r_abscissa(i)) + call deallocate(r_weight(i)) + end do + deallocate(abscissa, weight, it_abscissa, it_weight, & r_abscissa, r_weight, weighted_abscissa, s_weight, s_weighted_abscissa, a_weight, a_weighted_abscissa) - end subroutine dqmom_calculate_source_term_pop - - subroutine dqmom_calculate_source_term_ele(abscissa, weight, s_weighted_abscissa, s_weight, & - &D, have_D, have_growth, growth_type, growth_r, have_internal_dispersion, internal_dispersion_coeff, & - &have_aggregation, aggregation_freq_type, aggregation_freq_const, C5, & - &have_breakage, breakage_freq_type, breakage_freq_const, breakage_freq_degree, breakage_dist_type, & - &turbulent_dissipation, viscosity_continuous, & - &X, singular_option, perturb_val, cond, ele) - - type(scalar_field), dimension(:), intent(in) :: abscissa, weight - type(scalar_field), pointer, intent(in) :: turbulent_dissipation - type(tensor_field), pointer, intent(in) :: viscosity_continuous - type(scalar_field_pointer), dimension(:), intent(inout) :: s_weighted_abscissa, s_weight - type(tensor_field), pointer, intent(in) :: D - type(vector_field), pointer, intent(in) :: X - integer, intent(in) :: ele - real, intent(in) :: cond, growth_r, internal_dispersion_coeff, aggregation_freq_const, breakage_freq_const, breakage_freq_degree, perturb_val, C5 - logical, intent(in) :: have_D, have_growth, have_internal_dispersion, have_aggregation, have_breakage - character(len=FIELD_NAME_LEN), intent(in) :: growth_type, aggregation_freq_type, breakage_freq_type, breakage_dist_type, singular_option - - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: abscissa_val_at_quad - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2, size(abscissa)*2) :: A - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2, size(abscissa)) :: A_3 - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: C - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2) :: S_rhs ! source term (includes growth, breakage and coalescence term) - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2, size(abscissa)) :: moment_daughter_dist_func - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: break_freq - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa), size(abscissa)) :: aggregation_freq ! at present it is not dependent on space coordinate, but can be dependent and will have to be a scalar field - real, dimension(size(abscissa)*2, 1) :: b - real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: abscissa_S_at_quad - real, dimension(ele_ngi(abscissa(1), ele), size(weight)) :: weight_S_at_quad - real, dimension(ele_loc(abscissa(1), ele)) :: abscissa_S_at_nodes - real, dimension(ele_loc(abscissa(1), ele)) :: weight_S_at_nodes - real, dimension(ele_loc(abscissa(1), ele), ele_loc(abscissa(1), ele)) :: invmass - real, dimension(ele_ngi(abscissa(1), ele)) :: detwei, eps_ngi - real, dimension(X%dim, ele_ngi(abscissa(1), ele)) :: grad_D - real, dimension(X%dim, X%dim, ele_ngi(abscissa(1), ele)) :: D_at_quad - type(element_type), pointer :: shape - integer, dimension(:), pointer :: nodes - real, dimension(ele_loc(abscissa(1), ele), ele_ngi(abscissa(1), ele), X%dim) :: dshape - real, dimension(:,:,:), allocatable :: visc_ngi - real, dimension(size(abscissa)*2, size(abscissa)*2) :: svd_tmp1, svd_tmp2 - real, dimension(size(abscissa)*2) :: SV - integer :: stat, N, i, j, k - - real :: sigma, density_continuous, density_dispersed - - N = size(abscissa) - - nodes => ele_nodes(abscissa(1), ele) - shape => ele_shape(abscissa(1), ele) - - call transform_to_physical(X, ele, shape, dshape=dshape, detwei=detwei) - - ! construct A matrices (lhs knowns) - do i = 1, N - abscissa_val_at_quad(:,i) = ele_val_at_quad(abscissa(i), ele) - end do - A = A_matrix(abscissa_val_at_quad) - - ! construct A_3 matrix (rhs pt.1) - do i = 1, 2*N - do j = 1, N - A_3(:,i,j) = (i-1)*(i-2)*ele_val_at_quad(abscissa(j), ele)**(i-3) - end do - end do - - ! construct C matrix (rhs pt.2) - if (have_D) then - do i = 1, N - D_at_quad = ele_val_at_quad(D, ele) - do j = 1, X%dim - grad_D(j,:) = D_at_quad(j,j,:) - end do - grad_D = ((ele_grad_at_quad(abscissa(i), ele, dshape))**2)*grad_D - C(:,i) = ele_val_at_quad(weight(i), ele)*sum(grad_D,1) - end do - else - C = 0.0 - end if - - ! initialize dqmom source term to zero - S_rhs = 0.0 - - ! construct S vector (rhs pt.3) for GROWTH term - if (have_growth) then - if (growth_type=='power_law_growth') then - do i = 1, 2*N - do j = 1, N - S_rhs(:,i) = S_rhs(:,i) + (i-1)*ele_val_at_quad(weight(j), ele)*(ele_val_at_quad(abscissa(j), ele)**(i-2+growth_r)) - end do - end do - end if - end if - - ! construct S vector (rhs pt.3) for INTERNAL DISPERSION - if (have_internal_dispersion) then - do i = 1, 2*N - do j = 1, N - S_rhs(:,i) = S_rhs(:,i) + (i-1)*(i-2)*ele_val_at_quad(weight(j), ele)*(abscissa_val_at_quad(:,j)**(i-3))*internal_dispersion_coeff - end do - end do - end if - - ! construct S vector for BREAKAGE - - if (have_breakage) then - if (breakage_freq_type=='constant_breakage') then - break_freq = breakage_freq_const - else if (breakage_freq_type=='power_law_breakage') then - do i = 1, N - break_freq(:,i) = breakage_freq_const*abscissa_val_at_quad(:,i)**breakage_freq_degree - end do - else if (breakage_freq_type=='laakkonen_frequency') then - density_continuous = 998.2 - density_dispersed = 1.205 - sigma = 0.072 - eps_ngi = ele_val_at_quad(turbulent_dissipation,ele) - ! Assuming isotropic molecular viscosity here - allocate(visc_ngi(ele_ngi(abscissa(1), ele), viscosity_continuous%dim(1), viscosity_continuous%dim(1))) - visc_ngi = ele_val_at_quad(viscosity_continuous,ele) - do i = 1, N - break_freq(:,i) = 6.0*eps_ngi**(1./3) * erfc(sqrt( 0.04*(sigma/density_continuous)*(1./(eps_ngi**(2./3) * abscissa_val_at_quad(:,i)**(5./3))) + 0.01*(visc_ngi(:,1,1)/sqrt(density_continuous*density_dispersed))*(1./(eps_ngi**(1./3)*abscissa_val_at_quad(:,i)**(4./3))))) - end do - deallocate(visc_ngi) - end if - - if (breakage_dist_type=='symmetric_fragmentation') then - do i = 1, 2*N - do j = 1, N - moment_daughter_dist_func(:,i,j) = (2.0**(((3-(i-1))/3.0)))*(abscissa_val_at_quad(:,j)**(i-1)) - end do - end do - else if (breakage_dist_type=='mcCoy_madras_2003') then - do i = 1, 2*N - do j = 1, N - moment_daughter_dist_func(:,i,j) = (6.0/((i-1)+3.0))*(abscissa_val_at_quad(:,j)**(i-1)) - end do - end do - else if (breakage_dist_type=='laakkonen_2007') then - do i = 1, 2*N - do j = 1, N - moment_daughter_dist_func(:,i,j) = 180.0*(abscissa_val_at_quad(:,j)**(i-1))*(1./((i-1)+15) - 2./((i-1)+12) + 1./((i-1)+9)) - end do - end do - end if - - do i = 1, 2*N - do j = 1, N - ! birth term due to breakage - S_rhs(:,i) = S_rhs(:,i) + break_freq(:,j)*ele_val_at_quad(weight(j), ele)*moment_daughter_dist_func(:,i,j) ! daughter distribution function already includes the factor for number of particles formed after breakage - ! death term due to breakage - S_rhs(:,i) = S_rhs(:,i) - break_freq(:,j)*ele_val_at_quad(weight(j), ele)*(abscissa_val_at_quad(:,j)**(i-1)) - end do - end do - endif - - - !!! construct S vector for AGGREGATION - if (have_aggregation) then - if (aggregation_freq_type=='constant_aggregation') then - aggregation_freq = aggregation_freq_const - else if (aggregation_freq_type=='hydrodynamic_aggregation') then - do i = 1, N - do j = 1, N - aggregation_freq(:,i,j) = abscissa_val_at_quad(:,i)**3 + abscissa_val_at_quad(:,j)**3 - end do - end do - else if (aggregation_freq_type=='sum_aggregation') then - do i = 1, N - do j = 1, N - aggregation_freq(:,i,j) = (abscissa_val_at_quad(:,i) + abscissa_val_at_quad(:,j))*aggregation_freq_const - end do - end do - else if (aggregation_freq_type=='laakkonen_2007_aggregation') then - density_continuous = 998.2 - sigma = 0.072 - eps_ngi = ele_val_at_quad(turbulent_dissipation,ele) - ! Assuming isotropic molecular viscosity here - allocate(visc_ngi(ele_ngi(abscissa(1), ele), viscosity_continuous%dim(1), viscosity_continuous%dim(1))) - visc_ngi = ele_val_at_quad(viscosity_continuous,ele) - do i = 1, N - do j = 1, N - aggregation_freq(:,i,j) = C5 * eps_ngi**(1./3) * (abscissa_val_at_quad(:,i) + abscissa_val_at_quad(:,j))**2 * (abscissa_val_at_quad(:,i)**(2./3) + abscissa_val_at_quad(:,j)**(2./3))**(1./2) * exp(-6.0E9*((visc_ngi(:,1,1)*density_continuous)/sigma**2)*eps_ngi*((abscissa_val_at_quad(:,i)*abscissa_val_at_quad(:,j))/(abscissa_val_at_quad(:,i)+abscissa_val_at_quad(:,j)))**4) - end do - end do - deallocate(visc_ngi) - end if - - do i = 1, 2*N - do j = 1, N - do k = 1, N - ! birth term due to aggregation - S_rhs(:,i) = S_rhs(:,i) + 0.5 * aggregation_freq(:,j,k) * ele_val_at_quad(weight(j), ele) * ele_val_at_quad(weight(k), ele) * & - ((abs(abscissa_val_at_quad(:,j)**3 + abscissa_val_at_quad(:,k)**3)**(1.0/3.0)) * & - sign(1.0,(abscissa_val_at_quad(:,j)**3 + abscissa_val_at_quad(:,k)**3)))**(i-1) - ! death term due to aggregation - S_rhs(:,i) = S_rhs(:,i) - aggregation_freq(:,j,k) * ele_val_at_quad(weight(j), ele) * ele_val_at_quad(weight(k), ele) * abscissa_val_at_quad(:,j)**(i-1) - end do - end do - end do - endif - - ! check for ill-conditioned matrices - if (singular_option=='set_source_to_zero') then - do i = 1, ele_ngi(abscissa(1), ele) - call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) - if (SV(size(SV))/SV(1) < cond) then - ewrite(2,*) 'ill-conditioned matrix found', SV(size(SV))/SV(1) - S_rhs(i,:)=0.0 - A(i,:,:) = 0.0 - A_3(i,:,:) = 0.0 - C(i,:) = 0.0 - do j = 1, 2*N - A(i,j,j) = 1.0 - end do - end if - end do - else if (singular_option=='do_nothing') then - do i = 1, ele_ngi(abscissa(1), ele) - call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) - if (SV(size(SV))/SV(1) < cond) then - ewrite(2,*) 'ill-conditioned matrix found but doing nothing about it', SV(size(SV))/SV(1) - end if - end do - else if (singular_option=='perturbate') then - do i = 1, ele_ngi(abscissa(1), ele) - call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) - if (SV(size(SV))/SV(1) < cond) then - ewrite(2,*) 'ill-conditioned matrix found and perturbating', SV(size(SV))/SV(1) - do j = 1, N - abscissa_val_at_quad(i,j) = abscissa_val_at_quad(i,j)-perturb_val - end do - A = A_matrix(abscissa_val_at_quad) - call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) - ewrite(2,*) 'Condition number after perturbating', SV(size(SV))/SV(1) - end if - end do - end if - - ! solve linear system to find source values for weights and weighted-abscissa equations - do i = 1, ele_ngi(abscissa(1), ele) - b(:,1) = matmul(A_3(i,:,:), C(i,:)) + S_rhs(i,:) - call dqmom_solve(A(i,:,:), b, stat) - weight_S_at_quad(i,:) = b(:N,1) - abscissa_S_at_quad(i,:) = b(N+1:,1) - end do - - ! In the DG case we apply the inverse mass locally. - invmass = inverse(shape_shape(shape, shape, detwei)) - - ! integrate and add to source fields - do i = 1, N - weight_S_at_nodes = shape_rhs(shape, detwei* weight_S_at_quad(:,i)) - abscissa_S_at_nodes = shape_rhs(shape, detwei* abscissa_S_at_quad(:,i)) - if(continuity(abscissa(1))<0) then - weight_S_at_nodes = matmul(weight_S_at_nodes, invmass) - abscissa_S_at_nodes = matmul(abscissa_S_at_nodes, invmass) - end if - call addto(s_weight(i)%ptr, nodes, weight_S_at_nodes) - call addto(s_weighted_abscissa(i)%ptr, nodes, abscissa_S_at_nodes) - end do - - end subroutine dqmom_calculate_source_term_ele - - function A_matrix(abscissa) - - real, dimension(:,:), intent(in) :: abscissa - - real, dimension(size(abscissa,1), size(abscissa,2)*2, size(abscissa,2)*2) :: A_matrix - integer :: i, j, N - - N = size(abscissa,2) - do i = 1, 2*N - do j = 1, N - A_matrix(:,i,j) = (2-i)*abscissa(:,j)**(i-1) - A_matrix(:,i,j+N) = (i-1)*abscissa(:,j)**(i-2) - end do - end do - - end function A_matrix - - subroutine dqmom_solve(A, b, stat) - !!< Solve Ax=b for right hand sides b putting the result in b. - !!< - !!< This is simply a wrapper for lapack. - real, dimension(:,:), intent(in) :: A - real, dimension(:,:), intent(inout) :: b - integer, optional, intent(out) :: stat - - real, dimension(size(A,1), size(A,2)) :: Atmp - integer, dimension(size(A,1)) :: ipiv - integer :: info - - interface + end subroutine dqmom_calculate_source_term_pop + + subroutine dqmom_calculate_source_term_ele(abscissa, weight, s_weighted_abscissa, s_weight, & + &D, have_D, have_growth, growth_type, growth_r, have_internal_dispersion, internal_dispersion_coeff, & + &have_aggregation, aggregation_freq_type, aggregation_freq_const, C5, & + &have_breakage, breakage_freq_type, breakage_freq_const, breakage_freq_degree, breakage_dist_type, & + &turbulent_dissipation, viscosity_continuous, & + &X, singular_option, perturb_val, cond, ele) + + type(scalar_field), dimension(:), intent(in) :: abscissa, weight + type(scalar_field), pointer, intent(in) :: turbulent_dissipation + type(tensor_field), pointer, intent(in) :: viscosity_continuous + type(scalar_field_pointer), dimension(:), intent(inout) :: s_weighted_abscissa, s_weight + type(tensor_field), pointer, intent(in) :: D + type(vector_field), pointer, intent(in) :: X + integer, intent(in) :: ele + real, intent(in) :: cond, growth_r, internal_dispersion_coeff, aggregation_freq_const, breakage_freq_const, breakage_freq_degree, perturb_val, C5 + logical, intent(in) :: have_D, have_growth, have_internal_dispersion, have_aggregation, have_breakage + character(len=FIELD_NAME_LEN), intent(in) :: growth_type, aggregation_freq_type, breakage_freq_type, breakage_dist_type, singular_option + + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: abscissa_val_at_quad + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2, size(abscissa)*2) :: A + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2, size(abscissa)) :: A_3 + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: C + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2) :: S_rhs ! source term (includes growth, breakage and coalescence term) + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)*2, size(abscissa)) :: moment_daughter_dist_func + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: break_freq + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa), size(abscissa)) :: aggregation_freq ! at present it is not dependent on space coordinate, but can be dependent and will have to be a scalar field + real, dimension(size(abscissa)*2, 1) :: b + real, dimension(ele_ngi(abscissa(1), ele), size(abscissa)) :: abscissa_S_at_quad + real, dimension(ele_ngi(abscissa(1), ele), size(weight)) :: weight_S_at_quad + real, dimension(ele_loc(abscissa(1), ele)) :: abscissa_S_at_nodes + real, dimension(ele_loc(abscissa(1), ele)) :: weight_S_at_nodes + real, dimension(ele_loc(abscissa(1), ele), ele_loc(abscissa(1), ele)) :: invmass + real, dimension(ele_ngi(abscissa(1), ele)) :: detwei, eps_ngi + real, dimension(X%dim, ele_ngi(abscissa(1), ele)) :: grad_D + real, dimension(X%dim, X%dim, ele_ngi(abscissa(1), ele)) :: D_at_quad + type(element_type), pointer :: shape + integer, dimension(:), pointer :: nodes + real, dimension(ele_loc(abscissa(1), ele), ele_ngi(abscissa(1), ele), X%dim) :: dshape + real, dimension(:,:,:), allocatable :: visc_ngi + real, dimension(size(abscissa)*2, size(abscissa)*2) :: svd_tmp1, svd_tmp2 + real, dimension(size(abscissa)*2) :: SV + integer :: stat, N, i, j, k + + real :: sigma, density_continuous, density_dispersed + + N = size(abscissa) + + nodes => ele_nodes(abscissa(1), ele) + shape => ele_shape(abscissa(1), ele) + + call transform_to_physical(X, ele, shape, dshape=dshape, detwei=detwei) + + ! construct A matrices (lhs knowns) + do i = 1, N + abscissa_val_at_quad(:,i) = ele_val_at_quad(abscissa(i), ele) + end do + A = A_matrix(abscissa_val_at_quad) + + ! construct A_3 matrix (rhs pt.1) + do i = 1, 2*N + do j = 1, N + A_3(:,i,j) = (i-1)*(i-2)*ele_val_at_quad(abscissa(j), ele)**(i-3) + end do + end do + + ! construct C matrix (rhs pt.2) + if (have_D) then + do i = 1, N + D_at_quad = ele_val_at_quad(D, ele) + do j = 1, X%dim + grad_D(j,:) = D_at_quad(j,j,:) + end do + grad_D = ((ele_grad_at_quad(abscissa(i), ele, dshape))**2)*grad_D + C(:,i) = ele_val_at_quad(weight(i), ele)*sum(grad_D,1) + end do + else + C = 0.0 + end if + + ! initialize dqmom source term to zero + S_rhs = 0.0 + + ! construct S vector (rhs pt.3) for GROWTH term + if (have_growth) then + if (growth_type=='power_law_growth') then + do i = 1, 2*N + do j = 1, N + S_rhs(:,i) = S_rhs(:,i) + (i-1)*ele_val_at_quad(weight(j), ele)*(ele_val_at_quad(abscissa(j), ele)**(i-2+growth_r)) + end do + end do + end if + end if + + ! construct S vector (rhs pt.3) for INTERNAL DISPERSION + if (have_internal_dispersion) then + do i = 1, 2*N + do j = 1, N + S_rhs(:,i) = S_rhs(:,i) + (i-1)*(i-2)*ele_val_at_quad(weight(j), ele)*(abscissa_val_at_quad(:,j)**(i-3))*internal_dispersion_coeff + end do + end do + end if + + ! construct S vector for BREAKAGE + + if (have_breakage) then + if (breakage_freq_type=='constant_breakage') then + break_freq = breakage_freq_const + else if (breakage_freq_type=='power_law_breakage') then + do i = 1, N + break_freq(:,i) = breakage_freq_const*abscissa_val_at_quad(:,i)**breakage_freq_degree + end do + else if (breakage_freq_type=='laakkonen_frequency') then + density_continuous = 998.2 + density_dispersed = 1.205 + sigma = 0.072 + eps_ngi = ele_val_at_quad(turbulent_dissipation,ele) + ! Assuming isotropic molecular viscosity here + allocate(visc_ngi(ele_ngi(abscissa(1), ele), viscosity_continuous%dim(1), viscosity_continuous%dim(1))) + visc_ngi = ele_val_at_quad(viscosity_continuous,ele) + do i = 1, N + break_freq(:,i) = 6.0*eps_ngi**(1./3) * erfc(sqrt( 0.04*(sigma/density_continuous)*(1./(eps_ngi**(2./3) * abscissa_val_at_quad(:,i)**(5./3))) + 0.01*(visc_ngi(:,1,1)/sqrt(density_continuous*density_dispersed))*(1./(eps_ngi**(1./3)*abscissa_val_at_quad(:,i)**(4./3))))) + end do + deallocate(visc_ngi) + end if + + if (breakage_dist_type=='symmetric_fragmentation') then + do i = 1, 2*N + do j = 1, N + moment_daughter_dist_func(:,i,j) = (2.0**(((3-(i-1))/3.0)))*(abscissa_val_at_quad(:,j)**(i-1)) + end do + end do + else if (breakage_dist_type=='mcCoy_madras_2003') then + do i = 1, 2*N + do j = 1, N + moment_daughter_dist_func(:,i,j) = (6.0/((i-1)+3.0))*(abscissa_val_at_quad(:,j)**(i-1)) + end do + end do + else if (breakage_dist_type=='laakkonen_2007') then + do i = 1, 2*N + do j = 1, N + moment_daughter_dist_func(:,i,j) = 180.0*(abscissa_val_at_quad(:,j)**(i-1))*(1./((i-1)+15) - 2./((i-1)+12) + 1./((i-1)+9)) + end do + end do + end if + + do i = 1, 2*N + do j = 1, N + ! birth term due to breakage + S_rhs(:,i) = S_rhs(:,i) + break_freq(:,j)*ele_val_at_quad(weight(j), ele)*moment_daughter_dist_func(:,i,j) ! daughter distribution function already includes the factor for number of particles formed after breakage + ! death term due to breakage + S_rhs(:,i) = S_rhs(:,i) - break_freq(:,j)*ele_val_at_quad(weight(j), ele)*(abscissa_val_at_quad(:,j)**(i-1)) + end do + end do + endif + + + !!! construct S vector for AGGREGATION + if (have_aggregation) then + if (aggregation_freq_type=='constant_aggregation') then + aggregation_freq = aggregation_freq_const + else if (aggregation_freq_type=='hydrodynamic_aggregation') then + do i = 1, N + do j = 1, N + aggregation_freq(:,i,j) = abscissa_val_at_quad(:,i)**3 + abscissa_val_at_quad(:,j)**3 + end do + end do + else if (aggregation_freq_type=='sum_aggregation') then + do i = 1, N + do j = 1, N + aggregation_freq(:,i,j) = (abscissa_val_at_quad(:,i) + abscissa_val_at_quad(:,j))*aggregation_freq_const + end do + end do + else if (aggregation_freq_type=='laakkonen_2007_aggregation') then + density_continuous = 998.2 + sigma = 0.072 + eps_ngi = ele_val_at_quad(turbulent_dissipation,ele) + ! Assuming isotropic molecular viscosity here + allocate(visc_ngi(ele_ngi(abscissa(1), ele), viscosity_continuous%dim(1), viscosity_continuous%dim(1))) + visc_ngi = ele_val_at_quad(viscosity_continuous,ele) + do i = 1, N + do j = 1, N + aggregation_freq(:,i,j) = C5 * eps_ngi**(1./3) * (abscissa_val_at_quad(:,i) + abscissa_val_at_quad(:,j))**2 * (abscissa_val_at_quad(:,i)**(2./3) + abscissa_val_at_quad(:,j)**(2./3))**(1./2) * exp(-6.0E9*((visc_ngi(:,1,1)*density_continuous)/sigma**2)*eps_ngi*((abscissa_val_at_quad(:,i)*abscissa_val_at_quad(:,j))/(abscissa_val_at_quad(:,i)+abscissa_val_at_quad(:,j)))**4) + end do + end do + deallocate(visc_ngi) + end if + + do i = 1, 2*N + do j = 1, N + do k = 1, N + ! birth term due to aggregation + S_rhs(:,i) = S_rhs(:,i) + 0.5 * aggregation_freq(:,j,k) * ele_val_at_quad(weight(j), ele) * ele_val_at_quad(weight(k), ele) * & + ((abs(abscissa_val_at_quad(:,j)**3 + abscissa_val_at_quad(:,k)**3)**(1.0/3.0)) * & + sign(1.0,(abscissa_val_at_quad(:,j)**3 + abscissa_val_at_quad(:,k)**3)))**(i-1) + ! death term due to aggregation + S_rhs(:,i) = S_rhs(:,i) - aggregation_freq(:,j,k) * ele_val_at_quad(weight(j), ele) * ele_val_at_quad(weight(k), ele) * abscissa_val_at_quad(:,j)**(i-1) + end do + end do + end do + endif + + ! check for ill-conditioned matrices + if (singular_option=='set_source_to_zero') then + do i = 1, ele_ngi(abscissa(1), ele) + call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) + if (SV(size(SV))/SV(1) < cond) then + ewrite(2,*) 'ill-conditioned matrix found', SV(size(SV))/SV(1) + S_rhs(i,:)=0.0 + A(i,:,:) = 0.0 + A_3(i,:,:) = 0.0 + C(i,:) = 0.0 + do j = 1, 2*N + A(i,j,j) = 1.0 + end do + end if + end do + else if (singular_option=='do_nothing') then + do i = 1, ele_ngi(abscissa(1), ele) + call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) + if (SV(size(SV))/SV(1) < cond) then + ewrite(2,*) 'ill-conditioned matrix found but doing nothing about it', SV(size(SV))/SV(1) + end if + end do + else if (singular_option=='perturbate') then + do i = 1, ele_ngi(abscissa(1), ele) + call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) + if (SV(size(SV))/SV(1) < cond) then + ewrite(2,*) 'ill-conditioned matrix found and perturbating', SV(size(SV))/SV(1) + do j = 1, N + abscissa_val_at_quad(i,j) = abscissa_val_at_quad(i,j)-perturb_val + end do + A = A_matrix(abscissa_val_at_quad) + call svd(A(i,:,:), svd_tmp1, SV, svd_tmp2) + ewrite(2,*) 'Condition number after perturbating', SV(size(SV))/SV(1) + end if + end do + end if + + ! solve linear system to find source values for weights and weighted-abscissa equations + do i = 1, ele_ngi(abscissa(1), ele) + b(:,1) = matmul(A_3(i,:,:), C(i,:)) + S_rhs(i,:) + call dqmom_solve(A(i,:,:), b, stat) + weight_S_at_quad(i,:) = b(:N,1) + abscissa_S_at_quad(i,:) = b(N+1:,1) + end do + + ! In the DG case we apply the inverse mass locally. + invmass = inverse(shape_shape(shape, shape, detwei)) + + ! integrate and add to source fields + do i = 1, N + weight_S_at_nodes = shape_rhs(shape, detwei* weight_S_at_quad(:,i)) + abscissa_S_at_nodes = shape_rhs(shape, detwei* abscissa_S_at_quad(:,i)) + if(continuity(abscissa(1))<0) then + weight_S_at_nodes = matmul(weight_S_at_nodes, invmass) + abscissa_S_at_nodes = matmul(abscissa_S_at_nodes, invmass) + end if + call addto(s_weight(i)%ptr, nodes, weight_S_at_nodes) + call addto(s_weighted_abscissa(i)%ptr, nodes, abscissa_S_at_nodes) + end do + + end subroutine dqmom_calculate_source_term_ele + + function A_matrix(abscissa) + + real, dimension(:,:), intent(in) :: abscissa + + real, dimension(size(abscissa,1), size(abscissa,2)*2, size(abscissa,2)*2) :: A_matrix + integer :: i, j, N + + N = size(abscissa,2) + do i = 1, 2*N + do j = 1, N + A_matrix(:,i,j) = (2-i)*abscissa(:,j)**(i-1) + A_matrix(:,i,j+N) = (i-1)*abscissa(:,j)**(i-2) + end do + end do + + end function A_matrix + + subroutine dqmom_solve(A, b, stat) + !!< Solve Ax=b for right hand sides b putting the result in b. + !!< + !!< This is simply a wrapper for lapack. + real, dimension(:,:), intent(in) :: A + real, dimension(:,:), intent(inout) :: b + integer, optional, intent(out) :: stat + + real, dimension(size(A,1), size(A,2)) :: Atmp + integer, dimension(size(A,1)) :: ipiv + integer :: info + + interface #ifdef DOUBLEP - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - INTEGER :: INFO, LDA, LDB, N, NRHS - INTEGER :: IPIV( * ) - REAL :: A( LDA, * ), B( LDB, * ) - END SUBROUTINE DGESV + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + INTEGER :: INFO, LDA, LDB, N, NRHS + INTEGER :: IPIV( * ) + REAL :: A( LDA, * ), B( LDB, * ) + END SUBROUTINE DGESV #else - SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - INTEGER :: INFO, LDA, LDB, N, NRHS - INTEGER :: IPIV( * ) - REAL :: A( LDA, * ), B( LDB, * ) - END SUBROUTINE SGESV + SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + INTEGER :: INFO, LDA, LDB, N, NRHS + INTEGER :: IPIV( * ) + REAL :: A( LDA, * ), B( LDB, * ) + END SUBROUTINE SGESV #endif - end interface + end interface - if (present(stat)) stat = 0 + if (present(stat)) stat = 0 - Atmp=A + Atmp=A #ifdef DOUBLEP - call dgesv(& + call dgesv(& #else - call sgesv(& + call sgesv(& #endif - size(A,1), size(b,2), Atmp, size(A,1), ipiv, b, size(b,1), info) - - if (present(stat)) then - stat = info - end if - - end subroutine dqmom_solve - - subroutine dqmom_calculate_moments(state) - - type(state_type), intent(in) :: state - - type(scalar_field), pointer :: abscissa, weight, moment - type(scalar_field) :: work - integer :: i_pop, N, i_moment, i_abscissa, i - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: type - - ewrite(1, *) "In dqmom_calculate_moments" - do i_pop = 1, option_count(trim(state%option_path)//'/population_balance') - call get_pop_option_path(state, i_pop, option_path) - N = option_count(trim(option_path)//'/abscissa/scalar_field') - do i_moment = 1, 2*N - type = 'moments' - call get_pop_field(state, i_pop, i_moment, type, moment) - call zero(moment) - call allocate(work, moment%mesh, 'work') - do i_abscissa = 1, N - ! get required fields - type = 'abscissa' - call get_pop_field(state, i_pop, i_abscissa, type, abscissa) - type = 'weights' - call get_pop_field(state, i_pop, i_abscissa, type, weight) - - ! calculate moment -> m(i) = sum_j(w(j)*q(j)**i) - call zero(work) - call set(work, 1.0) - do i = 1, i_moment - 1 - call scale(work, abscissa) - end do - call scale(work, weight) - call addto(moment, work) - end do - call deallocate(work) - end do - end do - ewrite(1, *) "Exiting dqmom_calculate_moments" - end subroutine dqmom_calculate_moments - - subroutine dqmom_calculate_statistics(state) - - type(state_type), intent(in) :: state - - type(scalar_field_pointer), dimension(:), allocatable :: moments - type(scalar_field), pointer :: stats - integer :: i_pop, N, i, j, i_stat - real :: mean, std, scaling_factor_Dia - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: type - - ewrite(1, *) "In dqmom_calculate_statistics" - do i_pop = 1, option_count(trim(state%option_path)//'/population_balance') - call get_pop_option_path(state, i_pop, option_path) - - if (option_count(trim(option_path)//'/statistics/scalar_field') > 0) then - - N = option_count(trim(option_path)//'/moments/scalar_field') - allocate(moments(N)) - do i = 1, N - ! get required fields - type = 'moments' - call get_pop_field(state, i_pop, i, type, moments(i)%ptr) - end do - - type = 'statistics' - do i_stat = 1, option_count(trim(option_path)//'/statistics/scalar_field') - call get_pop_field(state, i_pop, i_stat, type, stats) - if (trim(stats%name) == "Mean") then - call zero(stats) - do j = 1, node_count(stats) - call set(stats, j, node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j)) - end do - end if - if (trim(stats%name) == "StandardDeviation") then - call zero(stats) - do j = 1, node_count(stats) - mean = node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j) - call set(stats, j, (node_val(moments(3)%ptr,j)/node_val(moments(1)%ptr,j) -& + size(A,1), size(b,2), Atmp, size(A,1), ipiv, b, size(b,1), info) + + if (present(stat)) then + stat = info + end if + + end subroutine dqmom_solve + + subroutine dqmom_calculate_moments(state) + + type(state_type), intent(in) :: state + + type(scalar_field), pointer :: abscissa, weight, moment + type(scalar_field) :: work + integer :: i_pop, N, i_moment, i_abscissa, i + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: type + + ewrite(1, *) "In dqmom_calculate_moments" + do i_pop = 1, option_count(trim(state%option_path)//'/population_balance') + call get_pop_option_path(state, i_pop, option_path) + N = option_count(trim(option_path)//'/abscissa/scalar_field') + do i_moment = 1, 2*N + type = 'moments' + call get_pop_field(state, i_pop, i_moment, type, moment) + call zero(moment) + call allocate(work, moment%mesh, 'work') + do i_abscissa = 1, N + ! get required fields + type = 'abscissa' + call get_pop_field(state, i_pop, i_abscissa, type, abscissa) + type = 'weights' + call get_pop_field(state, i_pop, i_abscissa, type, weight) + + ! calculate moment -> m(i) = sum_j(w(j)*q(j)**i) + call zero(work) + call set(work, 1.0) + do i = 1, i_moment - 1 + call scale(work, abscissa) + end do + call scale(work, weight) + call addto(moment, work) + end do + call deallocate(work) + end do + end do + ewrite(1, *) "Exiting dqmom_calculate_moments" + end subroutine dqmom_calculate_moments + + subroutine dqmom_calculate_statistics(state) + + type(state_type), intent(in) :: state + + type(scalar_field_pointer), dimension(:), allocatable :: moments + type(scalar_field), pointer :: stats + integer :: i_pop, N, i, j, i_stat + real :: mean, std, scaling_factor_Dia + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: type + + ewrite(1, *) "In dqmom_calculate_statistics" + do i_pop = 1, option_count(trim(state%option_path)//'/population_balance') + call get_pop_option_path(state, i_pop, option_path) + + if (option_count(trim(option_path)//'/statistics/scalar_field') > 0) then + + N = option_count(trim(option_path)//'/moments/scalar_field') + allocate(moments(N)) + do i = 1, N + ! get required fields + type = 'moments' + call get_pop_field(state, i_pop, i, type, moments(i)%ptr) + end do + + type = 'statistics' + do i_stat = 1, option_count(trim(option_path)//'/statistics/scalar_field') + call get_pop_field(state, i_pop, i_stat, type, stats) + if (trim(stats%name) == "Mean") then + call zero(stats) + do j = 1, node_count(stats) + call set(stats, j, node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j)) + end do + end if + if (trim(stats%name) == "StandardDeviation") then + call zero(stats) + do j = 1, node_count(stats) + mean = node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j) + call set(stats, j, (node_val(moments(3)%ptr,j)/node_val(moments(1)%ptr,j) -& mean**2)**0.5) - end do - end if - if (trim(stats%name) == "Skew") then - call zero(stats) - do j = 1, node_count(stats) - mean = node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j) - std = (node_val(moments(3)%ptr,j)/node_val(moments(1)%ptr,j) - mean**2)**0.5 - call set(stats, j, & + end do + end if + if (trim(stats%name) == "Skew") then + call zero(stats) + do j = 1, node_count(stats) + mean = node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j) + std = (node_val(moments(3)%ptr,j)/node_val(moments(1)%ptr,j) - mean**2)**0.5 + call set(stats, j, & (node_val(moments(4)%ptr,j)/node_val(moments(1)%ptr,j) - & 3*mean*std**2.0 - mean**3.0) / std**3.0) - end do - end if - if (trim(stats%name) == "SauterMeanDia") then - call zero(stats) - if (have_option(trim(option_path)//'/scaling_factor_Dia')) then - call get_option(trim(option_path)//'/scaling_factor_Dia', scaling_factor_Dia) - else - scaling_factor_Dia=1.0 - end if - do j = 1, node_count(stats) - call set(stats, j, scaling_factor_Dia*(node_val(moments(4)%ptr,j)/node_val(moments(3)%ptr,j)) ) - end do - end if - if (trim(stats%name) == "MeanDia10") then - call zero(stats) - if (have_option(trim(option_path)//'/scaling_factor_Dia')) then - call get_option(trim(option_path)//'/scaling_factor_Dia', scaling_factor_Dia) - else - scaling_factor_Dia=1.0 - end if - do j = 1, node_count(stats) - call set(stats, j, scaling_factor_Dia*(node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j)) ) - end do - end if - - end do - - deallocate(moments) - - end if - end do - ewrite(1, *) "Exiting dqmom_calculate_statistics" - - - end subroutine dqmom_calculate_statistics - - subroutine dqmom_check_options + end do + end if + if (trim(stats%name) == "SauterMeanDia") then + call zero(stats) + if (have_option(trim(option_path)//'/scaling_factor_Dia')) then + call get_option(trim(option_path)//'/scaling_factor_Dia', scaling_factor_Dia) + else + scaling_factor_Dia=1.0 + end if + do j = 1, node_count(stats) + call set(stats, j, scaling_factor_Dia*(node_val(moments(4)%ptr,j)/node_val(moments(3)%ptr,j)) ) + end do + end if + if (trim(stats%name) == "MeanDia10") then + call zero(stats) + if (have_option(trim(option_path)//'/scaling_factor_Dia')) then + call get_option(trim(option_path)//'/scaling_factor_Dia', scaling_factor_Dia) + else + scaling_factor_Dia=1.0 + end if + do j = 1, node_count(stats) + call set(stats, j, scaling_factor_Dia*(node_val(moments(2)%ptr,j)/node_val(moments(1)%ptr,j)) ) + end do + end if + + end do + + deallocate(moments) + + end if + end do + ewrite(1, *) "Exiting dqmom_calculate_statistics" + + + end subroutine dqmom_calculate_statistics + + subroutine dqmom_check_options ! type(state_type), intent(in) :: state - integer :: i_pop, i_state, i_field, stat - integer :: n_abscissa, n_weights, n_weighted_abscissa, n_moments, n_statistics - character(len=OPTION_PATH_LEN) :: option_path - character(len=FIELD_NAME_LEN) :: old_msh, amsh, wmsh, wamsh, mmsh, smsh, type + integer :: i_pop, i_state, i_field, stat + integer :: n_abscissa, n_weights, n_weighted_abscissa, n_moments, n_statistics + character(len=OPTION_PATH_LEN) :: option_path + character(len=FIELD_NAME_LEN) :: old_msh, amsh, wmsh, wamsh, mmsh, smsh, type - ewrite(1,*) 'in dqmom_check_options' + ewrite(1,*) 'in dqmom_check_options' - do i_state = 1, option_count("/material_phase") - do i_pop = 1, option_count('material_phase['//int2str(i_state-1)//']/population_balance') - option_path = 'material_phase['//int2str(i_state-1)//']/population_balance['//int2str(i_pop-1)//']' + do i_state = 1, option_count("/material_phase") + do i_pop = 1, option_count('material_phase['//int2str(i_state-1)//']/population_balance') + option_path = 'material_phase['//int2str(i_state-1)//']/population_balance['//int2str(i_pop-1)//']' - ! Check there are the same number of abscissa, weight and weighted abscissa fields - n_abscissa = option_count(trim(option_path)//'/abscissa/scalar_field') - n_weights = option_count(trim(option_path)//'/weights/scalar_field') - n_weighted_abscissa = option_count(trim(option_path)// & + ! Check there are the same number of abscissa, weight and weighted abscissa fields + n_abscissa = option_count(trim(option_path)//'/abscissa/scalar_field') + n_weights = option_count(trim(option_path)//'/weights/scalar_field') + n_weighted_abscissa = option_count(trim(option_path)// & '/weighted_abscissa/scalar_field') - if((n_weights /= n_abscissa) .or. (n_weights /= n_weighted_abscissa)) then - FLExit("The number of weights, abscissas and weighted abscissa scalar fields must be the same in the population balance solver") - end if - - ! Check there are sufficient abscissas to calculate requested moments - n_moments = option_count(trim(option_path)//'/moments/scalar_field') - if((n_moments / 2) /= n_abscissa) then - FLExit("The number of moments must be twice the number of abscissas in the population balance solver") - end if - - ! Need to check that all fields are on the same mesh - - type='abscissa' - do i_field = 1, n_abscissa - call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/diagnostic/mesh/name', amsh, stat) - if (stat /= 0) then - FLExit("Abscissa scalar field must be diagnostic in population balance solver") - else - if (i_field==1) then - old_msh=amsh - else - if (trim(amsh)/=trim(old_msh)) then - FLExit("All abscissas must be on the same mesh") - else - old_msh=amsh - end if - end if - end if - end do - - type='weights' - do i_field = 1, n_abscissa - call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/prognostic/mesh/name', wmsh, stat) - if (stat /= 0) then - FLExit("Weight scalar field must be prognostic in population balance solver") - else - if (i_field==1) then - old_msh=wmsh - else - if (trim(wmsh)/=trim(old_msh)) then - FLExit("All weights must be on the same mesh") - else - old_msh=wmsh - end if - end if - end if - end do - - type='weighted_abscissa' - do i_field = 1, n_abscissa - call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/prognostic/mesh/name', wamsh, stat) - if (stat /= 0) then - FLExit("Weighted abscissa scalar field must be prognostic in population balance solver") - else - if (i_field==1) then - old_msh=wamsh - else - if (trim(wamsh)/=trim(old_msh)) then - FLExit("All weighted abscissas must be on the same mesh") - else - old_msh=wamsh - end if - end if - end if - end do - - type='moments' - do i_field = 1, n_moments - call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/diagnostic/mesh/name', mmsh, stat) - if (stat /= 0) then - FLExit("Moment scalar field must be diagnostic in population balance solver") - else - if (i_field==1) then - old_msh=mmsh - else - if (trim(mmsh)/=trim(old_msh)) then - FLExit("All moments must be on the same mesh") - else - old_msh=mmsh - end if - end if - end if - end do - - n_statistics = option_count(trim(option_path)//'/statistics/scalar_field') - type='statistics' - do i_field = 1, n_statistics - call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/diagnostic/mesh/name', smsh, stat) - if (stat /= 0) then - FLExit("Statitics scalar field must be diagnostic in population balance solver") - else - if (i_field==1) then - old_msh=smsh - else - if (trim(smsh)/=trim(old_msh)) then - FLExit("All statistics must be on the same mesh") - else - old_msh=smsh - end if - end if - end if - end do - - if (n_statistics == 0) then - smsh = amsh - end if - - if ((amsh/=wmsh) .or. (amsh/=wamsh) .or. (amsh/=mmsh) .or. (amsh/=smsh)) then - FLExit("Abscissas, weights, weighted abscissas, moments and statistics - all must be on the same mesh in population balance solver") - end if - - end do - end do - - ewrite(1,*) 'Finished dqmom_check_options' - end subroutine dqmom_check_options + if((n_weights /= n_abscissa) .or. (n_weights /= n_weighted_abscissa)) then + FLExit("The number of weights, abscissas and weighted abscissa scalar fields must be the same in the population balance solver") + end if + + ! Check there are sufficient abscissas to calculate requested moments + n_moments = option_count(trim(option_path)//'/moments/scalar_field') + if((n_moments / 2) /= n_abscissa) then + FLExit("The number of moments must be twice the number of abscissas in the population balance solver") + end if + + ! Need to check that all fields are on the same mesh + + type='abscissa' + do i_field = 1, n_abscissa + call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/diagnostic/mesh/name', amsh, stat) + if (stat /= 0) then + FLExit("Abscissa scalar field must be diagnostic in population balance solver") + else + if (i_field==1) then + old_msh=amsh + else + if (trim(amsh)/=trim(old_msh)) then + FLExit("All abscissas must be on the same mesh") + else + old_msh=amsh + end if + end if + end if + end do + + type='weights' + do i_field = 1, n_abscissa + call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/prognostic/mesh/name', wmsh, stat) + if (stat /= 0) then + FLExit("Weight scalar field must be prognostic in population balance solver") + else + if (i_field==1) then + old_msh=wmsh + else + if (trim(wmsh)/=trim(old_msh)) then + FLExit("All weights must be on the same mesh") + else + old_msh=wmsh + end if + end if + end if + end do + + type='weighted_abscissa' + do i_field = 1, n_abscissa + call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/prognostic/mesh/name', wamsh, stat) + if (stat /= 0) then + FLExit("Weighted abscissa scalar field must be prognostic in population balance solver") + else + if (i_field==1) then + old_msh=wamsh + else + if (trim(wamsh)/=trim(old_msh)) then + FLExit("All weighted abscissas must be on the same mesh") + else + old_msh=wamsh + end if + end if + end if + end do + + type='moments' + do i_field = 1, n_moments + call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/diagnostic/mesh/name', mmsh, stat) + if (stat /= 0) then + FLExit("Moment scalar field must be diagnostic in population balance solver") + else + if (i_field==1) then + old_msh=mmsh + else + if (trim(mmsh)/=trim(old_msh)) then + FLExit("All moments must be on the same mesh") + else + old_msh=mmsh + end if + end if + end if + end do + + n_statistics = option_count(trim(option_path)//'/statistics/scalar_field') + type='statistics' + do i_field = 1, n_statistics + call get_option(trim(option_path)//'/'//trim(type)//'/scalar_field['//int2str(i_field - 1)//']/diagnostic/mesh/name', smsh, stat) + if (stat /= 0) then + FLExit("Statitics scalar field must be diagnostic in population balance solver") + else + if (i_field==1) then + old_msh=smsh + else + if (trim(smsh)/=trim(old_msh)) then + FLExit("All statistics must be on the same mesh") + else + old_msh=smsh + end if + end if + end if + end do + + if (n_statistics == 0) then + smsh = amsh + end if + + if ((amsh/=wmsh) .or. (amsh/=wamsh) .or. (amsh/=mmsh) .or. (amsh/=smsh)) then + FLExit("Abscissas, weights, weighted abscissas, moments and statistics - all must be on the same mesh in population balance solver") + end if + + end do + end do + + ewrite(1,*) 'Finished dqmom_check_options' + end subroutine dqmom_check_options end module dqmom diff --git a/preprocessor/Boundary_Conditions_From_Options.F90 b/preprocessor/Boundary_Conditions_From_Options.F90 index 7c526012ab..3688046923 100644 --- a/preprocessor/Boundary_Conditions_From_Options.F90 +++ b/preprocessor/Boundary_Conditions_From_Options.F90 @@ -27,532 +27,532 @@ #include "fdebug.h" module boundary_conditions_from_options - use fldebug - use global_parameters, only: OPTION_PATH_LEN, PYTHON_FUNC_LEN, pi,& -current_debug_level, FIELD_NAME_LEN - use futils, only: int2str, present_and_true - use vector_tools - use quadrature - use spud - use integer_set_module - use parallel_tools - use halos_base - use sparse_tools - use elements - use embed_python, only: real_from_python - use transform_elements - use halos_numbering - use halos_derivation - use transform_elements - use fetools - use fields - use sparse_tools_petsc - use state_module - use field_options - use vtk_interfaces - use fefields - use boundary_conditions - use coordinates - use initialise_fields_module - use tidal_module - use samplenetcdf - use synthetic_bc, only : add_sem_bc, initialise_sem_memory, synthetic_eddy_method - use pickers_inquire, only: picker_inquire - use bulk_parameterisations, only: get_forcing_surface_element_list - use k_epsilon, only: keps_bcs - use sediment, only: set_sediment_reentrainment - - implicit none - - private - - public :: populate_boundary_conditions, set_boundary_conditions_values, & - apply_dirichlet_conditions_inverse_mass, impose_reference_pressure_node, & - find_reference_node_from_coordinates, impose_reference_velocity_node - public :: populate_scalar_boundary_conditions, & - & populate_vector_boundary_conditions, initialise_rotated_bcs - - interface apply_dirichlet_conditions_inverse_mass - module procedure apply_dirichlet_conditions_inverse_mass_vector, & - apply_dirichlet_conditions_inverse_mass_vector_lumped - end interface apply_dirichlet_conditions_inverse_mass - - interface + use fldebug + use global_parameters, only: OPTION_PATH_LEN, PYTHON_FUNC_LEN, pi,& + current_debug_level, FIELD_NAME_LEN + use futils, only: int2str, present_and_true + use vector_tools + use quadrature + use spud + use integer_set_module + use parallel_tools + use halos_base + use sparse_tools + use elements + use embed_python, only: real_from_python + use transform_elements + use halos_numbering + use halos_derivation + use transform_elements + use fetools + use fields + use sparse_tools_petsc + use state_module + use field_options + use vtk_interfaces + use fefields + use boundary_conditions + use coordinates + use initialise_fields_module + use tidal_module + use samplenetcdf + use synthetic_bc, only : add_sem_bc, initialise_sem_memory, synthetic_eddy_method + use pickers_inquire, only: picker_inquire + use bulk_parameterisations, only: get_forcing_surface_element_list + use k_epsilon, only: keps_bcs + use sediment, only: set_sediment_reentrainment + + implicit none + + private + + public :: populate_boundary_conditions, set_boundary_conditions_values, & + apply_dirichlet_conditions_inverse_mass, impose_reference_pressure_node, & + find_reference_node_from_coordinates, impose_reference_velocity_node + public :: populate_scalar_boundary_conditions, & + & populate_vector_boundary_conditions, initialise_rotated_bcs + + interface apply_dirichlet_conditions_inverse_mass + module procedure apply_dirichlet_conditions_inverse_mass_vector, & + apply_dirichlet_conditions_inverse_mass_vector_lumped + end interface apply_dirichlet_conditions_inverse_mass + + interface !! Explicit interface for get_era40_fluxes function as defined in !! ocean_forcing/forcingERA40.cpp - subroutine get_era40_fluxes( time, X, Y, Z, temp,& - Vx, Vy, Vz, sal,F_as, Q_as, Tau_u, Tau_v, Q_s, & - NNodes, on_sphere, bulk_formula) + subroutine get_era40_fluxes( time, X, Y, Z, temp,& + Vx, Vy, Vz, sal,F_as, Q_as, Tau_u, Tau_v, Q_s, & + NNodes, on_sphere, bulk_formula) - real :: time - real, dimension(*) :: X, Y, Z, temp, Vx, Vy, Vz, sal, F_as,& + real :: time + real, dimension(*) :: X, Y, Z, temp, Vx, Vy, Vz, sal, F_as,& Q_as, Tau_u, Tau_v, Q_s - integer :: NNodes, bulk_formula - logical*1 :: on_sphere + integer :: NNodes, bulk_formula + logical*1 :: on_sphere - end subroutine get_era40_fluxes - end interface + end subroutine get_era40_fluxes + end interface - interface + interface !! Explicit interface for projections_spherical_cartesion function as defined in !! femtools/projections.cpp - subroutine projections_spherical_cartesian(n, x, y, z) - integer :: n - real, dimension(:) :: x,y,z - end subroutine projections_spherical_cartesian + subroutine projections_spherical_cartesian(n, x, y, z) + integer :: n + real, dimension(:) :: x,y,z + end subroutine projections_spherical_cartesian - end interface + end interface contains - subroutine populate_boundary_conditions(states, suppress_warnings) - ! Populate the boundary conditions of all fields - ! This is called as part of populate_state but also - ! after an adapt. - type(state_type), dimension(:), intent(in):: states - ! suppress warnings about non-existant surface ids - logical, optional, intent(in) :: suppress_warnings + subroutine populate_boundary_conditions(states, suppress_warnings) + ! Populate the boundary conditions of all fields + ! This is called as part of populate_state but also + ! after an adapt. + type(state_type), dimension(:), intent(in):: states + ! suppress warnings about non-existant surface ids + logical, optional, intent(in) :: suppress_warnings - ! these must be pointers as bc's should be added to the original field - type(scalar_field), pointer:: sfield - type(vector_field), pointer:: vfield + ! these must be pointers as bc's should be added to the original field + type(scalar_field), pointer:: sfield + type(vector_field), pointer:: vfield - type(vector_field), pointer:: position - character(len=OPTION_PATH_LEN) phase_path, field_path - integer, dimension(:), allocatable:: surface_ids - integer shape_option(2) - integer p, f, nphases, nfields + type(vector_field), pointer:: position + character(len=OPTION_PATH_LEN) phase_path, field_path + integer, dimension(:), allocatable:: surface_ids + integer shape_option(2) + integer p, f, nphases, nfields - ewrite(1,*) "In populate_boundary_conditions" + ewrite(1,*) "In populate_boundary_conditions" - nphases = option_count('/material_phase') - do p = 0, nphases-1 + nphases = option_count('/material_phase') + do p = 0, nphases-1 - phase_path = '/material_phase['//int2str(p)//']' + phase_path = '/material_phase['//int2str(p)//']' - position => extract_vector_field(states(p+1), "Coordinate") + position => extract_vector_field(states(p+1), "Coordinate") - ! Scalar fields: + ! Scalar fields: - nfields = scalar_field_count(states(p+1)) - do f = 1, nfields - sfield => extract_scalar_field(states(p+1),f) - field_path=sfield%option_path + nfields = scalar_field_count(states(p+1)) + do f = 1, nfields + sfield => extract_scalar_field(states(p+1),f) + field_path=sfield%option_path - call populate_scalar_boundary_conditions(sfield, & + call populate_scalar_boundary_conditions(sfield, & trim(field_path)//'/prognostic/boundary_conditions', position, suppress_warnings=suppress_warnings) - call populate_scalar_boundary_conditions(sfield, & + call populate_scalar_boundary_conditions(sfield, & trim(field_path)//'/diagnostic/algorithm/boundary_conditions', position, suppress_warnings=suppress_warnings) - end do + end do - ! Vector fields: + ! Vector fields: - nfields = vector_field_count(states(p+1)) - do f = 1, nfields - vfield => extract_vector_field(states(p+1), f) - field_path=vfield%option_path + nfields = vector_field_count(states(p+1)) + do f = 1, nfields + vfield => extract_vector_field(states(p+1), f) + field_path=vfield%option_path - if (.not. have_option(trim(field_path)//'/prognostic')) cycle + if (.not. have_option(trim(field_path)//'/prognostic')) cycle - ! only prognostic fields from here: - call populate_vector_boundary_conditions(states(p+1),vfield, & + ! only prognostic fields from here: + call populate_vector_boundary_conditions(states(p+1),vfield, & trim(field_path)//'/prognostic/boundary_conditions', position, suppress_warnings=suppress_warnings) - end do - - end do - - ! special case 'boundary conditions', include: - ! - ocean boundaries - ! - ocean forcing - ! - GLS stable boundaries - if (have_option('/geometry/ocean_boundaries')) then - ! NOTE: has to be a pointer, as bcs should be added to original field - sfield => extract_scalar_field(states(1), "DistanceToTop") - ! Get vector of surface ids - shape_option=option_shape('/geometry/ocean_boundaries/top_surface_ids') - allocate(surface_ids(1:shape_option(1))) - call get_option('/geometry/ocean_boundaries/top_surface_ids', surface_ids) - ! Add boundary condition that marks the top of the domain - call add_boundary_condition(sfield, "top", "surface", surface_ids) - deallocate(surface_ids) - - ! NOTE: has to be a pointer, as bcs should be added to original field - sfield => extract_scalar_field(states(1), "DistanceToBottom") - ! Get vector of surface ids - shape_option=option_shape('/geometry/ocean_boundaries/bottom_surface_ids') - allocate(surface_ids(1:shape_option(1))) - call get_option('/geometry/ocean_boundaries/bottom_surface_ids', surface_ids) - ! Add boundary condition that marks the top of the domain - call add_boundary_condition(sfield, "bottom", "surface", surface_ids) - deallocate(surface_ids) - - call ocean_boundaries_stats(states(1)) - - end if - - if (have_option('/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries')) then - call populate_gls_boundary_conditions(states(1)) - end if - - if (have_option('/turbine_model')) then - call populate_flux_turbine_boundary_conditions(states(1)) - end if - - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries')) then - call populate_iceshelf_boundary_conditions(states(1)) - end if - - end subroutine populate_boundary_conditions - - subroutine populate_scalar_boundary_conditions(field, bc_path, position, suppress_warnings) - ! Populate the boundary conditions of one scalar field - ! needs to be a pointer: - type(scalar_field), pointer:: field - character(len=*), intent(in):: bc_path - type(vector_field), intent(in):: position - ! suppress warnings about non-existant surface ids - logical, optional, intent(in) :: suppress_warnings - - type(mesh_type), pointer:: surface_mesh - type(scalar_field) surface_field - type(vector_field) bc_position - integer, dimension(:), pointer:: surface_element_list - character(len=OPTION_PATH_LEN) bc_path_i - character(len=FIELD_NAME_LEN) bc_name, bc_type - integer, dimension(:), allocatable:: surface_ids - integer i, nbcs, shape_option(2) - - ! Get number of boundary conditions - nbcs=option_count(trim(bc_path)) - - ! Loop over boundary conditions - boundary_conditions: do i=0, nbcs-1 - - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - - ! Get vector of surface ids - shape_option=option_shape(trim(bc_path_i)//"/surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option(trim(bc_path_i)//"/surface_ids", surface_ids) - - ! Get name of boundary - call get_option(trim(bc_path_i)//"/name", bc_name) - - ! Get type of boundary condition - call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) - ! If we've an bulk_formulae type, this is actually a Neumann bc - ! on the Temperature and Salinity, or a weak Dirichlet on - ! PhotosyntheticRadiation. We therefore need to amend the - ! bc_type that was added - - ! Re-add boundary condition with correct type - if (trim(bc_type) .eq. "bulk_formulae" .and. trim(field%name) .eq. "PhotosyntheticRadiation") then - bc_type = "weakdirichlet" - else if (trim(bc_type) .eq. "bulk_formulae") then - ! Any other scalar fields that have a bulk_formulae will be - ! neumann. Options check should prevent this from - ! being anything other than Temperature or Salinity - ewrite(2,*) "Changing bulk_formulae BC type to neumann" - bc_type = "neumann" - end if - - ! Same thing for sediments. It's of type sediment_reentrainment - if (trim(bc_type) .eq. "sediment_reentrainment") then - ewrite(2,*) "Changing sediment_reentrainment BC type to neumann" - bc_type = "neumann" - end if - - ! Same thing for k_epsilon turbulence model. - if (trim(bc_type) .eq. "k_epsilon") then - call get_option(trim(bc_path_i)//"/type::k_epsilon/", bc_type) - if (trim(bc_type) .eq. "low_Re" .and. trim(field%name) .eq. "TurbulentDissipation") then - ewrite(2,*) "Changing low_Re epsilon BC type to neumann" - bc_type = "neumann" - else - ewrite(2,*) "Changing k_epsilon BC type to dirichlet" - bc_type = "dirichlet" - end if - end if - - if(have_option(trim(bc_path_i)//"/type[0]/apply_weakly")) then - bc_type = "weak"//trim(bc_type) - end if - - ! Add boundary condition - call add_boundary_condition(field, trim(bc_name), trim(bc_type), & + end do + + end do + + ! special case 'boundary conditions', include: + ! - ocean boundaries + ! - ocean forcing + ! - GLS stable boundaries + if (have_option('/geometry/ocean_boundaries')) then + ! NOTE: has to be a pointer, as bcs should be added to original field + sfield => extract_scalar_field(states(1), "DistanceToTop") + ! Get vector of surface ids + shape_option=option_shape('/geometry/ocean_boundaries/top_surface_ids') + allocate(surface_ids(1:shape_option(1))) + call get_option('/geometry/ocean_boundaries/top_surface_ids', surface_ids) + ! Add boundary condition that marks the top of the domain + call add_boundary_condition(sfield, "top", "surface", surface_ids) + deallocate(surface_ids) + + ! NOTE: has to be a pointer, as bcs should be added to original field + sfield => extract_scalar_field(states(1), "DistanceToBottom") + ! Get vector of surface ids + shape_option=option_shape('/geometry/ocean_boundaries/bottom_surface_ids') + allocate(surface_ids(1:shape_option(1))) + call get_option('/geometry/ocean_boundaries/bottom_surface_ids', surface_ids) + ! Add boundary condition that marks the top of the domain + call add_boundary_condition(sfield, "bottom", "surface", surface_ids) + deallocate(surface_ids) + + call ocean_boundaries_stats(states(1)) + + end if + + if (have_option('/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries')) then + call populate_gls_boundary_conditions(states(1)) + end if + + if (have_option('/turbine_model')) then + call populate_flux_turbine_boundary_conditions(states(1)) + end if + + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries')) then + call populate_iceshelf_boundary_conditions(states(1)) + end if + + end subroutine populate_boundary_conditions + + subroutine populate_scalar_boundary_conditions(field, bc_path, position, suppress_warnings) + ! Populate the boundary conditions of one scalar field + ! needs to be a pointer: + type(scalar_field), pointer:: field + character(len=*), intent(in):: bc_path + type(vector_field), intent(in):: position + ! suppress warnings about non-existant surface ids + logical, optional, intent(in) :: suppress_warnings + + type(mesh_type), pointer:: surface_mesh + type(scalar_field) surface_field + type(vector_field) bc_position + integer, dimension(:), pointer:: surface_element_list + character(len=OPTION_PATH_LEN) bc_path_i + character(len=FIELD_NAME_LEN) bc_name, bc_type + integer, dimension(:), allocatable:: surface_ids + integer i, nbcs, shape_option(2) + + ! Get number of boundary conditions + nbcs=option_count(trim(bc_path)) + + ! Loop over boundary conditions + boundary_conditions: do i=0, nbcs-1 + + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + + ! Get vector of surface ids + shape_option=option_shape(trim(bc_path_i)//"/surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option(trim(bc_path_i)//"/surface_ids", surface_ids) + + ! Get name of boundary + call get_option(trim(bc_path_i)//"/name", bc_name) + + ! Get type of boundary condition + call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) + ! If we've an bulk_formulae type, this is actually a Neumann bc + ! on the Temperature and Salinity, or a weak Dirichlet on + ! PhotosyntheticRadiation. We therefore need to amend the + ! bc_type that was added + + ! Re-add boundary condition with correct type + if (trim(bc_type) .eq. "bulk_formulae" .and. trim(field%name) .eq. "PhotosyntheticRadiation") then + bc_type = "weakdirichlet" + else if (trim(bc_type) .eq. "bulk_formulae") then + ! Any other scalar fields that have a bulk_formulae will be + ! neumann. Options check should prevent this from + ! being anything other than Temperature or Salinity + ewrite(2,*) "Changing bulk_formulae BC type to neumann" + bc_type = "neumann" + end if + + ! Same thing for sediments. It's of type sediment_reentrainment + if (trim(bc_type) .eq. "sediment_reentrainment") then + ewrite(2,*) "Changing sediment_reentrainment BC type to neumann" + bc_type = "neumann" + end if + + ! Same thing for k_epsilon turbulence model. + if (trim(bc_type) .eq. "k_epsilon") then + call get_option(trim(bc_path_i)//"/type::k_epsilon/", bc_type) + if (trim(bc_type) .eq. "low_Re" .and. trim(field%name) .eq. "TurbulentDissipation") then + ewrite(2,*) "Changing low_Re epsilon BC type to neumann" + bc_type = "neumann" + else + ewrite(2,*) "Changing k_epsilon BC type to dirichlet" + bc_type = "dirichlet" + end if + end if + + if(have_option(trim(bc_path_i)//"/type[0]/apply_weakly")) then + bc_type = "weak"//trim(bc_type) + end if + + ! Add boundary condition + call add_boundary_condition(field, trim(bc_name), trim(bc_type), & surface_ids, option_path=bc_path_i, suppress_warnings=suppress_warnings) - ! mesh of only the part of the surface where this b.c. applies - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + ! mesh of only the part of the surface where this b.c. applies + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - ! Dirichlet and Neumann boundary conditions require one input - ! while a Robin boundary condition requires two. This input can - ! be constant or set from a generic or python function. - select case(trim(bc_type)) + ! Dirichlet and Neumann boundary conditions require one input + ! while a Robin boundary condition requires two. This input can + ! be constant or set from a generic or python function. + select case(trim(bc_type)) - case("dirichlet", "neumann", "weakdirichlet", & - "buoyancy", "flux") + case("dirichlet", "neumann", "weakdirichlet", & + "buoyancy", "flux") - call allocate(surface_field, surface_mesh, name="value") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) + call allocate(surface_field, surface_mesh, name="value") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) - case("robin") + case("robin") - call allocate(surface_field, surface_mesh, name="order_zero_coefficient") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) + call allocate(surface_field, surface_mesh, name="order_zero_coefficient") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) - call allocate(surface_field, surface_mesh, name="order_one_coefficient") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) + call allocate(surface_field, surface_mesh, name="order_one_coefficient") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) - case("zero_flux") + case("zero_flux") - ! nothing to be done here + ! nothing to be done here - case( "k_epsilon" ) + case( "k_epsilon" ) - FLAbort("Oops, you shouldn't get a k_epsilon type of BC. It should have been converted") + FLAbort("Oops, you shouldn't get a k_epsilon type of BC. It should have been converted") - case( "bulk_formulae" ) + case( "bulk_formulae" ) - FLAbort("Oops, you shouldn't get a bulk_formulae type of BC. It should have been converted") + FLAbort("Oops, you shouldn't get a bulk_formulae type of BC. It should have been converted") - case( "sediment_reentrainment" ) + case( "sediment_reentrainment" ) - FLAbort("Oops, you shouldn't get a sediment_reentrainment type of BC. It should have been converted") + FLAbort("Oops, you shouldn't get a sediment_reentrainment type of BC. It should have been converted") - case default + case default - ! This really shouldn't happen - FLAbort("Incorrect boundary condition type for field") + ! This really shouldn't happen + FLAbort("Incorrect boundary condition type for field") - end select + end select - deallocate(surface_ids) - call deallocate(bc_position) + deallocate(surface_ids) + call deallocate(bc_position) - end do boundary_conditions + end do boundary_conditions - end subroutine populate_scalar_boundary_conditions + end subroutine populate_scalar_boundary_conditions - subroutine populate_vector_boundary_conditions(state, field, bc_path, position, suppress_warnings) - ! Populate the boundary conditions of one vector field - ! needs to be a pointer: - type(state_type), intent(in) :: state - type(vector_field), pointer:: field - character(len=*), intent(in):: bc_path - type(vector_field), intent(in):: position - ! suppress warnings about non-existant surface ids - logical, optional, intent(in) :: suppress_warnings + subroutine populate_vector_boundary_conditions(state, field, bc_path, position, suppress_warnings) + ! Populate the boundary conditions of one vector field + ! needs to be a pointer: + type(state_type), intent(in) :: state + type(vector_field), pointer:: field + character(len=*), intent(in):: bc_path + type(vector_field), intent(in):: position + ! suppress warnings about non-existant surface ids + logical, optional, intent(in) :: suppress_warnings - ! possible vector components for vector b.c.s - ! either carteisan aligned or aligned with the surface - character(len=20), parameter, dimension(3) :: & + ! possible vector components for vector b.c.s + ! either carteisan aligned or aligned with the surface + character(len=20), parameter, dimension(3) :: & cartesian_aligned_components=(/ & - "x_component", & - "y_component", & - "z_component" /), & + "x_component", & + "y_component", & + "z_component" /), & surface_aligned_components=(/ & - "normal_component ", & - "tangent_component_1", & - "tangent_component_2" /) - - character(len=20), dimension(3) :: aligned_components - - type(mesh_type), pointer:: mesh, surface_mesh - type(mesh_type) :: linear_surface_mesh - type(vector_field) surface_field, surface_field2, bc_position - type(vector_field):: normal, tangent_1, tangent_2 - type(scalar_field) :: scalar_surface_field - character(len=OPTION_PATH_LEN) bc_path_i, bc_type_path, bc_component_path - character(len=FIELD_NAME_LEN) bc_name, bc_type - logical applies(3), have_sem_bc, have_smoothing, debugging_mode, prescribed(3) - integer, dimension(:), allocatable:: surface_ids - integer, dimension(:), pointer:: surface_element_list, surface_node_list - integer i, j, nbcs, shape_option(2) - - nbcs=option_count(trim(bc_path)) - - boundary_conditions: do i=0, nbcs-1 - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - shape_option=option_shape(trim(bc_path_i)//"/surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option(trim(bc_path_i)//"/surface_ids", surface_ids) - call get_option(trim(bc_path_i)//"/name", bc_name) - - call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) - - if(have_option(trim(bc_path_i)//"/type[0]/apply_weakly")) then - bc_type = "weak"//trim(bc_type) - end if - - select case(trim(bc_type)) - case("dirichlet", "neumann", "weakdirichlet", "flux") - - if(have_option(trim(bc_path_i)//"/type[0]/align_bc_with_cartesian")) then - aligned_components=cartesian_aligned_components - bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_cartesian" - else - aligned_components=surface_aligned_components - bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_surface" - end if - - have_sem_bc=.false. - have_smoothing = .false. - do j=1,3 - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) - applies(j)=have_option(trim(bc_component_path)) - if (.not. applies(j)) cycle - ! check for SEM bc: - have_sem_bc = have_sem_bc .or. have_option(trim(bc_component_path)//'/synthetic_eddy_method') - have_smoothing = have_smoothing .or. have_option(trim(bc_component_path)//'/smoothing') - end do - call add_sem_bc(have_sem_bc) - - call add_boundary_condition(field, trim(bc_name), trim(bc_type),& - & surface_ids, applies=applies, option_path=bc_path_i, suppress_warnings=suppress_warnings) - deallocate(surface_ids) - - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - call allocate(surface_field, field%dim, surface_mesh, name="value") - - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - - if (have_smoothing) then - if (field%mesh%shape%degree/=1 .or. continuity(field)<0) then - ! if the mesh is not linear and continuous, we first evalutate - ! the value on a linear continuous mesh, smooth it and then remap to the actual "value" field - ! create linear inputs - call get_boundary_condition(field, i+1, surface_element_list=surface_element_list) - call find_linear_parent_mesh(state, field%mesh, mesh) - call create_surface_mesh(linear_surface_mesh, surface_node_list, & - mesh, surface_element_list, name="Linear"//trim(surface_mesh%name)) - call generate_surface_mesh_halos(mesh, linear_surface_mesh, surface_node_list) - call allocate(surface_field, field%dim, linear_surface_mesh, name="smoothed_value") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - call deallocate(linear_surface_mesh) - deallocate(surface_node_list) + "normal_component ", & + "tangent_component_1", & + "tangent_component_2" /) + + character(len=20), dimension(3) :: aligned_components + + type(mesh_type), pointer:: mesh, surface_mesh + type(mesh_type) :: linear_surface_mesh + type(vector_field) surface_field, surface_field2, bc_position + type(vector_field):: normal, tangent_1, tangent_2 + type(scalar_field) :: scalar_surface_field + character(len=OPTION_PATH_LEN) bc_path_i, bc_type_path, bc_component_path + character(len=FIELD_NAME_LEN) bc_name, bc_type + logical applies(3), have_sem_bc, have_smoothing, debugging_mode, prescribed(3) + integer, dimension(:), allocatable:: surface_ids + integer, dimension(:), pointer:: surface_element_list, surface_node_list + integer i, j, nbcs, shape_option(2) + + nbcs=option_count(trim(bc_path)) + + boundary_conditions: do i=0, nbcs-1 + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + shape_option=option_shape(trim(bc_path_i)//"/surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option(trim(bc_path_i)//"/surface_ids", surface_ids) + call get_option(trim(bc_path_i)//"/name", bc_name) + + call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) + + if(have_option(trim(bc_path_i)//"/type[0]/apply_weakly")) then + bc_type = "weak"//trim(bc_type) + end if + + select case(trim(bc_type)) + case("dirichlet", "neumann", "weakdirichlet", "flux") + + if(have_option(trim(bc_path_i)//"/type[0]/align_bc_with_cartesian")) then + aligned_components=cartesian_aligned_components + bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_cartesian" + else + aligned_components=surface_aligned_components + bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_surface" + end if + + have_sem_bc=.false. + have_smoothing = .false. + do j=1,3 + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) + applies(j)=have_option(trim(bc_component_path)) + if (.not. applies(j)) cycle + ! check for SEM bc: + have_sem_bc = have_sem_bc .or. have_option(trim(bc_component_path)//'/synthetic_eddy_method') + have_smoothing = have_smoothing .or. have_option(trim(bc_component_path)//'/smoothing') + end do + call add_sem_bc(have_sem_bc) + + call add_boundary_condition(field, trim(bc_name), trim(bc_type),& + & surface_ids, applies=applies, option_path=bc_path_i, suppress_warnings=suppress_warnings) + deallocate(surface_ids) + + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + call allocate(surface_field, field%dim, surface_mesh, name="value") + + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + + if (have_smoothing) then + if (field%mesh%shape%degree/=1 .or. continuity(field)<0) then + ! if the mesh is not linear and continuous, we first evalutate + ! the value on a linear continuous mesh, smooth it and then remap to the actual "value" field + ! create linear inputs + call get_boundary_condition(field, i+1, surface_element_list=surface_element_list) + call find_linear_parent_mesh(state, field%mesh, mesh) + call create_surface_mesh(linear_surface_mesh, surface_node_list, & + mesh, surface_element_list, name="Linear"//trim(surface_mesh%name)) + call generate_surface_mesh_halos(mesh, linear_surface_mesh, surface_node_list) + call allocate(surface_field, field%dim, linear_surface_mesh, name="smoothed_value") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + call deallocate(linear_surface_mesh) + deallocate(surface_node_list) + else + ! mesh is already linear, we don't need an extra inbetween field + ! but we do need halos on the surface mesh to make the smoothing work in parallel + call get_boundary_condition(field, i+1, surface_node_list=surface_node_list) + call generate_surface_mesh_halos(field%mesh, surface_mesh, surface_node_list) + end if + end if + + if (have_sem_bc) then + call allocate(surface_field, field%dim, surface_mesh, name="TurbulenceLengthscale") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + + call allocate(surface_field, field%dim, surface_mesh, name="MeanProfile") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + + call allocate(surface_field, field%dim, surface_mesh, name="ReStressesProfile") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + end if + + case("robin") + + if(have_option(trim(bc_path_i)//"/type[0]/align_bc_with_cartesian")) then + aligned_components=cartesian_aligned_components + bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_cartesian" else - ! mesh is already linear, we don't need an extra inbetween field - ! but we do need halos on the surface mesh to make the smoothing work in parallel - call get_boundary_condition(field, i+1, surface_node_list=surface_node_list) - call generate_surface_mesh_halos(field%mesh, surface_mesh, surface_node_list) + aligned_components=surface_aligned_components + bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_surface" + end if + + do j=1,3 + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) + applies(j)=have_option(trim(bc_component_path)) + end do + + call add_boundary_condition(field, trim(bc_name), trim(bc_type),& + & surface_ids, applies=applies, option_path=bc_path_i, suppress_warnings=suppress_warnings) + deallocate(surface_ids) + + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + + call allocate(surface_field, field%dim, surface_mesh, name="order_zero_coefficient") + call allocate(surface_field2, field%dim, surface_mesh, name="order_one_coefficient") + call insert_surface_field(field, i+1, surface_field) + call insert_surface_field(field, i+1, surface_field2) + call deallocate(surface_field) + call deallocate(surface_field2) + + case("drag") + + call add_boundary_condition(field, trim(bc_name), trim(bc_type), & + & surface_ids, option_path=bc_path_i, suppress_warnings=suppress_warnings) + deallocate(surface_ids) + + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="DragCoefficient") + call insert_surface_field(field, i+1, scalar_surface_field) + call deallocate(scalar_surface_field) + + case ("wind_forcing") + + call add_boundary_condition(field, trim(bc_name), trim(bc_type), & + & surface_ids, option_path=bc_path_i, suppress_warnings=suppress_warnings) + deallocate(surface_ids) + + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + call allocate(surface_field, field%dim-1, surface_mesh, name="WindSurfaceField") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + bc_path_i=trim(bc_path_i)//"/type[0]/wind_velocity" + if (have_option(bc_path_i)) then + call allocate(scalar_surface_field, surface_mesh, name="WindDragCoefficient") + call insert_surface_field(field, i+1, scalar_surface_field) + call deallocate(scalar_surface_field) end if - end if - - if (have_sem_bc) then - call allocate(surface_field, field%dim, surface_mesh, name="TurbulenceLengthscale") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - - call allocate(surface_field, field%dim, surface_mesh, name="MeanProfile") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - - call allocate(surface_field, field%dim, surface_mesh, name="ReStressesProfile") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - end if - - case("robin") - - if(have_option(trim(bc_path_i)//"/type[0]/align_bc_with_cartesian")) then - aligned_components=cartesian_aligned_components - bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_cartesian" - else - aligned_components=surface_aligned_components - bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_surface" - end if - - do j=1,3 - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) - applies(j)=have_option(trim(bc_component_path)) - end do - - call add_boundary_condition(field, trim(bc_name), trim(bc_type),& - & surface_ids, applies=applies, option_path=bc_path_i, suppress_warnings=suppress_warnings) - deallocate(surface_ids) - - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - - call allocate(surface_field, field%dim, surface_mesh, name="order_zero_coefficient") - call allocate(surface_field2, field%dim, surface_mesh, name="order_one_coefficient") - call insert_surface_field(field, i+1, surface_field) - call insert_surface_field(field, i+1, surface_field2) - call deallocate(surface_field) - call deallocate(surface_field2) - - case("drag") - - call add_boundary_condition(field, trim(bc_name), trim(bc_type), & - & surface_ids, option_path=bc_path_i, suppress_warnings=suppress_warnings) - deallocate(surface_ids) - - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="DragCoefficient") - call insert_surface_field(field, i+1, scalar_surface_field) - call deallocate(scalar_surface_field) - - case ("wind_forcing") - - call add_boundary_condition(field, trim(bc_name), trim(bc_type), & - & surface_ids, option_path=bc_path_i, suppress_warnings=suppress_warnings) - deallocate(surface_ids) - - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - call allocate(surface_field, field%dim-1, surface_mesh, name="WindSurfaceField") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - bc_path_i=trim(bc_path_i)//"/type[0]/wind_velocity" - if (have_option(bc_path_i)) then - call allocate(scalar_surface_field, surface_mesh, name="WindDragCoefficient") - call insert_surface_field(field, i+1, scalar_surface_field) - call deallocate(scalar_surface_field) - end if - - case ("prescribed_normal_flow") - - ! Just add to the first dimension - call add_boundary_condition(field, trim(bc_name), trim(bc_type),& - & surface_ids, applies=(/ .true., .false., .false. /) , option_path=bc_path_i,& - & suppress_warnings=suppress_warnings) - deallocate(surface_ids) - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - call allocate(surface_field, field%dim, surface_mesh, name="value") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - - case ("bulk_formulae") - - ! The bulk_formulae type is actually a wind forcing on velocity... - call add_boundary_condition(field, trim(bc_name) ,& - &'wind_forcing', surface_ids, option_path=bc_path_i,suppress_warnings=suppress_warnings) - deallocate(surface_ids) - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - call allocate(surface_field, field%dim-1, surface_mesh, name="WindSurfaceField") - call insert_surface_field(field, i+1, surface_field) - call deallocate(surface_field) - - case ("free_surface", "no_normal_flow") - - ! these are marked as applying in the 1st direction only - ! so they could potentially be combined with rotated bcs - ! applying in the tangential directions only - call add_boundary_condition(field, trim(bc_name), trim(bc_type), & - & surface_ids, option_path=bc_path_i, & - & applies=(/ .true., .false., .false. /),suppress_warnings=suppress_warnings) - deallocate(surface_ids) - - if (trim(bc_type)=="free_surface") then - if(have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then + + case ("prescribed_normal_flow") + + ! Just add to the first dimension + call add_boundary_condition(field, trim(bc_name), trim(bc_type),& + & surface_ids, applies=(/ .true., .false., .false. /) , option_path=bc_path_i,& + & suppress_warnings=suppress_warnings) + deallocate(surface_ids) + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + call allocate(surface_field, field%dim, surface_mesh, name="value") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + + case ("bulk_formulae") + + ! The bulk_formulae type is actually a wind forcing on velocity... + call add_boundary_condition(field, trim(bc_name) ,& + &'wind_forcing', surface_ids, option_path=bc_path_i,suppress_warnings=suppress_warnings) + deallocate(surface_ids) + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + call allocate(surface_field, field%dim-1, surface_mesh, name="WindSurfaceField") + call insert_surface_field(field, i+1, surface_field) + call deallocate(surface_field) + + case ("free_surface", "no_normal_flow") + + ! these are marked as applying in the 1st direction only + ! so they could potentially be combined with rotated bcs + ! applying in the tangential directions only + call add_boundary_condition(field, trim(bc_name), trim(bc_type), & + & surface_ids, option_path=bc_path_i, & + & applies=(/ .true., .false., .false. /),suppress_warnings=suppress_warnings) + deallocate(surface_ids) + + if (trim(bc_type)=="free_surface") then + if(have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then ! Wetting and drying needs an auxiliary field on the pressure mesh mesh => extract_pressure_mesh(state) call get_boundary_condition(field, i+1, surface_element_list=surface_element_list) @@ -563,2110 +563,2110 @@ subroutine populate_vector_boundary_conditions(state, field, bc_path, position, call deallocate(scalar_surface_field) call deallocate(surface_mesh) deallocate(surface_mesh) - end if - if (have_option(trim(bc_path_i)//"/type[0]/external_density")) then - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, "ExternalDensity") - call insert_surface_field(field, i+1, scalar_surface_field) - call deallocate(scalar_surface_field) - end if - end if - - case ("outflow") - ! dummy bc for outflow planes - call add_boundary_condition(field, trim(bc_name), trim(bc_type), surface_ids, option_path=bc_path_i, & - & applies=(/ .true., .true., .true. /),suppress_warnings=suppress_warnings ) - deallocate(surface_ids) - - case default - FLAbort("Incorrect boundary condition type for field") - end select - - ! now check for user-specified normal/tangent vectors (rotation matrix) - select case (bc_type) - case ("dirichlet", "neumann", "robin", "weakdirichlet", "flux") - ! this is the same for all 3 b.c. types - - bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_surface" - - ! map the coordinate field onto this mesh - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + end if + if (have_option(trim(bc_path_i)//"/type[0]/external_density")) then + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, "ExternalDensity") + call insert_surface_field(field, i+1, scalar_surface_field) + call deallocate(scalar_surface_field) + end if + end if + + case ("outflow") + ! dummy bc for outflow planes + call add_boundary_condition(field, trim(bc_name), trim(bc_type), surface_ids, option_path=bc_path_i, & + & applies=(/ .true., .true., .true. /),suppress_warnings=suppress_warnings ) + deallocate(surface_ids) + + case default + FLAbort("Incorrect boundary condition type for field") + end select + + ! now check for user-specified normal/tangent vectors (rotation matrix) + select case (bc_type) + case ("dirichlet", "neumann", "robin", "weakdirichlet", "flux") + ! this is the same for all 3 b.c. types + + bc_type_path=trim(bc_path_i)//"/type[0]/align_bc_with_surface" + + ! map the coordinate field onto this mesh + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & surface_element_list=surface_element_list) - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - - if (have_option(bc_type_path)) then - - prescribed = .false. - - call allocate(normal, field%dim, surface_mesh, name="normal") - bc_component_path=trim(bc_type_path)//"/normal_direction" - if (have_option(bc_component_path)) then - prescribed(1) = .true. - call initialise_field(normal, bc_component_path, bc_position) - else - call zero(normal) - end if - call insert_surface_field(field, i+1, normal) - - call allocate(tangent_1, field%dim, surface_mesh, name="tangent1") - bc_component_path=trim(bc_type_path)//"/tangent_direction_1" - if (have_option(bc_component_path)) then - prescribed(2) = .true. - call initialise_field(tangent_1, bc_component_path, bc_position) - else - call zero(tangent_1) - end if - call insert_surface_field(field, i+1, tangent_1) - - call allocate(tangent_2, field%dim, surface_mesh, name="tangent2") - bc_component_path=trim(bc_type_path)//"/tangent_direction_2" - if (have_option(bc_component_path)) then - prescribed(3) = .true. - call initialise_field(tangent_2, bc_component_path, bc_position) - else - call zero(tangent_2) - end if - call insert_surface_field(field, i+1, tangent_2) - - debugging_mode=have_option(trim(bc_type_path)//"/debugging_mode") - - ! calculate the normal, tangent_1 and tangent_2 on every boundary node - call initialise_rotated_bcs(surface_element_list, & + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + + if (have_option(bc_type_path)) then + + prescribed = .false. + + call allocate(normal, field%dim, surface_mesh, name="normal") + bc_component_path=trim(bc_type_path)//"/normal_direction" + if (have_option(bc_component_path)) then + prescribed(1) = .true. + call initialise_field(normal, bc_component_path, bc_position) + else + call zero(normal) + end if + call insert_surface_field(field, i+1, normal) + + call allocate(tangent_1, field%dim, surface_mesh, name="tangent1") + bc_component_path=trim(bc_type_path)//"/tangent_direction_1" + if (have_option(bc_component_path)) then + prescribed(2) = .true. + call initialise_field(tangent_1, bc_component_path, bc_position) + else + call zero(tangent_1) + end if + call insert_surface_field(field, i+1, tangent_1) + + call allocate(tangent_2, field%dim, surface_mesh, name="tangent2") + bc_component_path=trim(bc_type_path)//"/tangent_direction_2" + if (have_option(bc_component_path)) then + prescribed(3) = .true. + call initialise_field(tangent_2, bc_component_path, bc_position) + else + call zero(tangent_2) + end if + call insert_surface_field(field, i+1, tangent_2) + + debugging_mode=have_option(trim(bc_type_path)//"/debugging_mode") + + ! calculate the normal, tangent_1 and tangent_2 on every boundary node + call initialise_rotated_bcs(surface_element_list, & position, debugging_mode, normal, tangent_1, tangent_2, prescribed) - call deallocate(normal) - call deallocate(tangent_1) - call deallocate(tangent_2) + call deallocate(normal) + call deallocate(tangent_1) + call deallocate(tangent_2) - end if - call deallocate(bc_position) + end if + call deallocate(bc_position) - case default - ! nothing to do for other bcs - end select + case default + ! nothing to do for other bcs + end select - end do boundary_conditions + end do boundary_conditions - end subroutine populate_vector_boundary_conditions + end subroutine populate_vector_boundary_conditions - subroutine set_boundary_conditions_values(states, shift_time) - !!< Set the values of the boundary conditions of all fields - !!< This is called each time step. - type(state_type), dimension(:), intent(in):: states - !! if present and true the time level at which the bcs are evaluated - !! is shifted according to: - !! "dirichlet": current_time+dt - !! all others: current_time+theta*dt - !! Otherwise (no shift_time) current_time is used, which is how this - !! routine should be called for initialisation, so that for instance - !! the fields can be overwritten with the right initial bc values. - logical, optional, intent(in):: shift_time + subroutine set_boundary_conditions_values(states, shift_time) + !!< Set the values of the boundary conditions of all fields + !!< This is called each time step. + type(state_type), dimension(:), intent(in):: states + !! if present and true the time level at which the bcs are evaluated + !! is shifted according to: + !! "dirichlet": current_time+dt + !! all others: current_time+theta*dt + !! Otherwise (no shift_time) current_time is used, which is how this + !! routine should be called for initialisation, so that for instance + !! the fields can be overwritten with the right initial bc values. + logical, optional, intent(in):: shift_time - type(scalar_field), pointer:: sfield - type(vector_field), pointer:: vfield + type(scalar_field), pointer:: sfield + type(vector_field), pointer:: vfield - type(vector_field), pointer:: position - character(len=OPTION_PATH_LEN) phase_path, field_path - integer p, f, nphases, nfields + type(vector_field), pointer:: position + character(len=OPTION_PATH_LEN) phase_path, field_path + integer p, f, nphases, nfields - ewrite(1,*) "In set_boundary_conditions" + ewrite(1,*) "In set_boundary_conditions" - if (have_option('/ocean_forcing/bulk_formulae')) then - call set_ocean_forcings_boundary_conditions(states(1)) - end if + if (have_option('/ocean_forcing/bulk_formulae')) then + call set_ocean_forcings_boundary_conditions(states(1)) + end if - if (have_option('/material_phase[0]/sediment')) then - call set_sediment_reentrainment(states(1)) - end if + if (have_option('/material_phase[0]/sediment')) then + call set_sediment_reentrainment(states(1)) + end if - nphases = size(states) - do p = 0, nphases-1 + nphases = size(states) + do p = 0, nphases-1 - phase_path = '/material_phase['//int2str(p)//']' + phase_path = '/material_phase['//int2str(p)//']' - position => extract_vector_field(states(p+1), "Coordinate") + position => extract_vector_field(states(p+1), "Coordinate") - ! Scalar fields: + ! Scalar fields: - nfields = scalar_field_count(states(p+1)) - do f = 1, nfields - sfield => extract_scalar_field(states(p+1),f) - field_path=sfield%option_path + nfields = scalar_field_count(states(p+1)) + do f = 1, nfields + sfield => extract_scalar_field(states(p+1),f) + field_path=sfield%option_path - call set_scalar_boundary_conditions_values(states(p+1), sfield, & + call set_scalar_boundary_conditions_values(states(p+1), sfield, & trim(field_path)//'/prognostic/boundary_conditions', & position, shift_time=shift_time) - call set_scalar_boundary_conditions_values(states(p+1), sfield, & + call set_scalar_boundary_conditions_values(states(p+1), sfield, & trim(field_path)//'/diagnostic/algorithm/boundary_conditions', & position, shift_time=shift_time) - end do + end do - ! Vector fields: + ! Vector fields: - nfields = vector_field_count(states(p+1)) - do f = 1, nfields - vfield => extract_vector_field(states(p+1), f) - field_path=vfield%option_path - if (.not. have_option(trim(field_path)//'/prognostic')) cycle + nfields = vector_field_count(states(p+1)) + do f = 1, nfields + vfield => extract_vector_field(states(p+1), f) + field_path=vfield%option_path + if (.not. have_option(trim(field_path)//'/prognostic')) cycle - ! only prognostic fields from here: - call set_vector_boundary_conditions_values(states(p+1), vfield, & + ! only prognostic fields from here: + call set_vector_boundary_conditions_values(states(p+1), vfield, & trim(field_path)//'/prognostic/boundary_conditions', & position, shift_time=shift_time) - end do + end do - ! Special k-epsilon boundary conditions - if (have_option(trim(states(p+1)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then - ewrite(2,*) "Calling keps_bcs" - call keps_bcs(states(p+1)) - end if + ! Special k-epsilon boundary conditions + if (have_option(trim(states(p+1)%option_path)//'/subgridscale_parameterisations/k-epsilon')) then + ewrite(2,*) "Calling keps_bcs" + call keps_bcs(states(p+1)) + end if - end do + end do - if (have_option('/turbine_model')) then - call set_dirichlet_turbine_boundary_conditions(states(1)) - call set_flux_turbine_boundary_conditions(states(1)) - end if + if (have_option('/turbine_model')) then + call set_dirichlet_turbine_boundary_conditions(states(1)) + call set_flux_turbine_boundary_conditions(states(1)) + end if - end subroutine set_boundary_conditions_values + end subroutine set_boundary_conditions_values - subroutine set_scalar_boundary_conditions_values(state, field, bc_path, position, shift_time) - ! Set the boundary condition values of one scalar field - type(state_type), intent(in) :: state - type(scalar_field), intent(inout):: field - character(len=*), intent(in):: bc_path - type(vector_field), intent(in):: position - ! see above in set_boundary_conditions: - logical, optional, intent(in):: shift_time + subroutine set_scalar_boundary_conditions_values(state, field, bc_path, position, shift_time) + ! Set the boundary condition values of one scalar field + type(state_type), intent(in) :: state + type(scalar_field), intent(inout):: field + character(len=*), intent(in):: bc_path + type(vector_field), intent(in):: position + ! see above in set_boundary_conditions: + logical, optional, intent(in):: shift_time - type(mesh_type), pointer:: surface_mesh - type(scalar_field), pointer:: surface_field - type(vector_field) bc_position, temp_position - character(len=OPTION_PATH_LEN) bc_path_i, bc_type_path - character(len=FIELD_NAME_LEN) bc_name, bc_type - real:: time, theta, dt - integer, dimension(:), pointer:: surface_element_list - integer i, nbcs + type(mesh_type), pointer:: surface_mesh + type(scalar_field), pointer:: surface_field + type(vector_field) bc_position, temp_position + character(len=OPTION_PATH_LEN) bc_path_i, bc_type_path + character(len=FIELD_NAME_LEN) bc_name, bc_type + real:: time, theta, dt + integer, dimension(:), pointer:: surface_element_list + integer i, nbcs - integer :: stat - type(scalar_field), pointer:: parent_field - character(len=OPTION_PATH_LEN) :: parent_field_name + integer :: stat + type(scalar_field), pointer:: parent_field + character(len=OPTION_PATH_LEN) :: parent_field_name - ! Get number of boundary conditions - nbcs=option_count(trim(bc_path)) + ! Get number of boundary conditions + nbcs=option_count(trim(bc_path)) - ! Loop over boundary conditions - boundary_conditions: do i=0, nbcs-1 + ! Loop over boundary conditions + boundary_conditions: do i=0, nbcs-1 - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - ! Get name of boundary (or set a default if none present) - call get_option(trim(bc_path_i)//"/name", bc_name) + ! Get name of boundary (or set a default if none present) + call get_option(trim(bc_path_i)//"/name", bc_name) - ! Get type of boundary condition - call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) + ! Get type of boundary condition + call get_option(trim(bc_path_i)//"/type[0]/name", bc_type) - if (trim(bc_type) .eq. "bulk_formulae") then - ! skip bulk_formulae types; they are dealt with seperately - ! See set_ocean_forcing_boundary_conditions - cycle boundary_conditions - end if + if (trim(bc_type) .eq. "bulk_formulae") then + ! skip bulk_formulae types; they are dealt with seperately + ! See set_ocean_forcing_boundary_conditions + cycle boundary_conditions + end if - if (trim(bc_type) .eq. "sediment_reentrainment") then - ! skip sediment boundaries - done seperately - ! see assemble/Sediment.F90 - cycle boundary_conditions - end if + if (trim(bc_type) .eq. "sediment_reentrainment") then + ! skip sediment boundaries - done seperately + ! see assemble/Sediment.F90 + cycle boundary_conditions + end if - if (trim(bc_type) .eq. "k_epsilon") then + if (trim(bc_type) .eq. "k_epsilon") then ! skip k_epsilon boundaries - done seperately ! see parameterisation/k_epsilon.F90 cycle boundary_conditions - end if + end if - if(have_option(trim(bc_path_i)//"/type[0]/apply_weakly")) then - bc_type = "weak"//trim(bc_type) - end if + if(have_option(trim(bc_path_i)//"/type[0]/apply_weakly")) then + bc_type = "weak"//trim(bc_type) + end if - ! mesh of only the part of the surface where this b.c. applies - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + ! mesh of only the part of the surface where this b.c. applies + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & surface_element_list=surface_element_list) - if((surface_mesh%shape%degree==0).and.(bc_type=="dirichlet")) then + if((surface_mesh%shape%degree==0).and.(bc_type=="dirichlet")) then - ! if the boundary condition is on a 0th degree mesh and is of type strong dirichlet - ! then the positions used to calculate the bc should be body element centred not - ! surface element centred - call allocate(temp_position, position%dim, field%mesh, "TemporaryPositions") - ! first remap to body element centred positions - call remap_field(position, temp_position) - ! then remap these to the surface - bc_position = get_coordinates_remapped_to_surface(temp_position, surface_mesh, surface_element_list) - call deallocate(temp_position) + ! if the boundary condition is on a 0th degree mesh and is of type strong dirichlet + ! then the positions used to calculate the bc should be body element centred not + ! surface element centred + call allocate(temp_position, position%dim, field%mesh, "TemporaryPositions") + ! first remap to body element centred positions + call remap_field(position, temp_position) + ! then remap these to the surface + bc_position = get_coordinates_remapped_to_surface(temp_position, surface_mesh, surface_element_list) + call deallocate(temp_position) - else - ! in all other cases the positions are remapped to the actual surface - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - end if + else + ! in all other cases the positions are remapped to the actual surface + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + end if - ! Dirichlet and Neumann boundary conditions require one input - ! while a Robin boundary condition requires two. This input can - ! be constant or set from a generic or python function. - select case(trim(bc_type)) + ! Dirichlet and Neumann boundary conditions require one input + ! while a Robin boundary condition requires two. This input can + ! be constant or set from a generic or python function. + select case(trim(bc_type)) - case("dirichlet", "neumann", "weakdirichlet", "flux") + case("dirichlet", "neumann", "weakdirichlet", "flux") - bc_type_path=trim(bc_path_i)//"/type[0]" + bc_type_path=trim(bc_path_i)//"/type[0]" - surface_field => extract_surface_field(field, bc_name, "value") + surface_field => extract_surface_field(field, bc_name, "value") - ! work out time level at which to evaluate: - call get_option("/timestepping/current_time", time) - if (present_and_true(shift_time)) then - call get_option("/timestepping/timestep", dt) - if (bc_type=="dirichlet") then - time=time+dt - else - call get_option( trim(field%option_path)// & - "/prognostic/temporal_discretisation/theta", theta, default=0.5) - time=time+theta*dt + ! work out time level at which to evaluate: + call get_option("/timestepping/current_time", time) + if (present_and_true(shift_time)) then + call get_option("/timestepping/timestep", dt) + if (bc_type=="dirichlet") then + time=time+dt + else + call get_option( trim(field%option_path)// & + "/prognostic/temporal_discretisation/theta", theta, default=0.5) + time=time+theta*dt + end if end if - end if - ! Tidal: set free surface height at the boundary. - if (have_option(trim(bc_type_path)//"/from_file")) then - ! Special case for tidal harmonic boundary conditions - call set_tidal_bc_value(surface_field, bc_position, trim(bc_type_path), field%name) + ! Tidal: set free surface height at the boundary. + if (have_option(trim(bc_type_path)//"/from_file")) then + ! Special case for tidal harmonic boundary conditions + call set_tidal_bc_value(surface_field, bc_position, trim(bc_type_path), field%name) - else if (have_option(trim(bc_type_path)//"/NEMO_data")) then - call set_nemo_bc_value(state, surface_field, bc_position, trim(bc_type_path), field%name, surface_element_list) + else if (have_option(trim(bc_type_path)//"/NEMO_data")) then + call set_nemo_bc_value(state, surface_field, bc_position, trim(bc_type_path), field%name, surface_element_list) - else if (have_option(trim(bc_type_path)//"/from_field")) then - ! The parent field contains the boundary values that you want to apply to surface_field. - call get_option(trim(bc_type_path)//"/from_field/parent_field_name", parent_field_name) - parent_field => extract_scalar_field(state, parent_field_name, stat) - if(stat /= 0) then - ewrite(-1,*) "For boundary conditions specified at " // trim(bc_type_path) - ewrite(-1,*) "Could not find scalar parent field " // trim(parent_field_name) - FLExit("Could not extract scalar parent field. Check options file?") - end if + else if (have_option(trim(bc_type_path)//"/from_field")) then + ! The parent field contains the boundary values that you want to apply to surface_field. + call get_option(trim(bc_type_path)//"/from_field/parent_field_name", parent_field_name) + parent_field => extract_scalar_field(state, parent_field_name, stat) + if(stat /= 0) then + ewrite(-1,*) "For boundary conditions specified at " // trim(bc_type_path) + ewrite(-1,*) "Could not find scalar parent field " // trim(parent_field_name) + FLExit("Could not extract scalar parent field. Check options file?") + end if - call remap_field_to_surface(parent_field, surface_field, surface_element_list, stat) + call remap_field_to_surface(parent_field, surface_field, surface_element_list, stat) - else - call initialise_field(surface_field, bc_type_path, bc_position, & - time=time) - end if + else + call initialise_field(surface_field, bc_type_path, bc_position, & + time=time) + end if - case("robin") + case("robin") - bc_type_path=trim(bc_path_i)//"/type[0]/order_zero_coefficient" - surface_field => extract_surface_field(field, bc_name, name="order_zero_coefficient") - call initialise_field(surface_field, bc_type_path, bc_position) + bc_type_path=trim(bc_path_i)//"/type[0]/order_zero_coefficient" + surface_field => extract_surface_field(field, bc_name, name="order_zero_coefficient") + call initialise_field(surface_field, bc_type_path, bc_position) - bc_type_path=trim(bc_path_i)//"/type[0]/order_one_coefficient" - surface_field => extract_surface_field(field, bc_name, name="order_one_coefficient") - call initialise_field(surface_field, bc_type_path, bc_position) + bc_type_path=trim(bc_path_i)//"/type[0]/order_one_coefficient" + surface_field => extract_surface_field(field, bc_name, name="order_one_coefficient") + call initialise_field(surface_field, bc_type_path, bc_position) - case( "buoyancy") + case( "buoyancy") - bc_type_path=trim(bc_path_i)//"/type::buoyancy/scalar_field/prognostic/initial_condition" - surface_field => extract_surface_field(field, bc_name, "value") - call initialise_field(surface_field, bc_type_path, bc_position) + bc_type_path=trim(bc_path_i)//"/type::buoyancy/scalar_field/prognostic/initial_condition" + surface_field => extract_surface_field(field, bc_name, "value") + call initialise_field(surface_field, bc_type_path, bc_position) - case( "zero_flux" ) + case( "zero_flux" ) - ! nothing to be done here + ! nothing to be done here - case( "k_epsilon" ) + case( "k_epsilon" ) - if(.not. have_option & - ("/material_phase[0]/subgridscale_parameterisations/k-epsilon/") ) then + if(.not. have_option & + ("/material_phase[0]/subgridscale_parameterisations/k-epsilon/") ) then FLAbort("Incorrect boundary condition type for field") - end if + end if - case default + case default - ! This really shouldn't happen - FLAbort("Incorrect boundary condition type for field") + ! This really shouldn't happen + FLAbort("Incorrect boundary condition type for field") - end select + end select - call deallocate(bc_position) + call deallocate(bc_position) - end do boundary_conditions + end do boundary_conditions - end subroutine set_scalar_boundary_conditions_values + end subroutine set_scalar_boundary_conditions_values - subroutine set_vector_boundary_conditions_values(state, field, bc_path, position, & - shift_time) - !for foamvel bc - type(state_type), intent(in) :: state - ! Set the boundary condition values of one vector field - type(vector_field), intent(inout):: field - character(len=*), intent(in):: bc_path - type(vector_field), intent(in):: position - ! see above in set_boundary_conditions: - logical, optional, intent(in):: shift_time + subroutine set_vector_boundary_conditions_values(state, field, bc_path, position, & + shift_time) + !for foamvel bc + type(state_type), intent(in) :: state + ! Set the boundary condition values of one vector field + type(vector_field), intent(inout):: field + character(len=*), intent(in):: bc_path + type(vector_field), intent(in):: position + ! see above in set_boundary_conditions: + logical, optional, intent(in):: shift_time - ! possible vector components for vector b.c.s - ! either cartesian aligned or aligned with the surface - character(len=20), parameter, dimension(3) :: & + ! possible vector components for vector b.c.s + ! either cartesian aligned or aligned with the surface + character(len=20), parameter, dimension(3) :: & cartesian_aligned_components=(/ & - "x_component", & - "y_component", & - "z_component" /), & + "x_component", & + "y_component", & + "z_component" /), & surface_aligned_components=(/ & - "normal_component ", & - "tangent_component_1", & - "tangent_component_2" /) - - character(len=20), dimension(3) :: aligned_components - - ! for sem - logical have_sem_bc - integer ns, nots - - type(mesh_type), pointer:: surface_mesh - type(scalar_field) :: surface_field_component, smoothed_value_component - type(scalar_field), pointer:: scalar_surface_field, scalar_parent_field - type(vector_field), pointer:: surface_field, surface_field11, smoothed_value - type(vector_field), pointer:: surface_field2, surface_field21, surface_field22 - type(vector_field) :: bc_position, temp_position, linear_bc_position - character(len=OPTION_PATH_LEN) bc_path_i, bc_type_path, bc_component_path - character(len=FIELD_NAME_LEN) bc_name, bc_type, parent_field_name - logical applies(3), have_smoothing(3) - real:: time, theta, dt - integer, dimension(:), pointer:: surface_element_list - integer i, j, k, nbcs, smoothing_iterations, stat - - ns=1 - nbcs=option_count(trim(bc_path)) - - boundary_conditions: do i=0, nbcs-1 - bc_path_i=trim(bc_path)//"["//int2str(i)//"]" - call get_option(trim(bc_path_i)//"/name", bc_name) - - bc_path_i=trim(bc_path_i)//'/type[0]' - call get_option(trim(bc_path_i)//"/name", bc_type) - - if (trim(bc_type) .eq. "bulk_formulae") then - ! skip bulk_formulae types; they are dealt with seperately - ! See set_ocean_forcing_boundary_conditions - cycle boundary_conditions - end if - - if(have_option(trim(bc_path_i)//"/apply_weakly")) then - bc_type = "weak"//trim(bc_type) - end if - - ! work out time level at which to evaluate: - call get_option("/timestepping/current_time", time) - if (present_and_true(shift_time)) then - call get_option("/timestepping/timestep", dt) - if (bc_type=="dirichlet") then - time=time+dt - else - call get_option( trim(field%option_path)// & - "/prognostic/temporal_discretisation/theta", theta, default=0.5) - time=time+theta*dt + "normal_component ", & + "tangent_component_1", & + "tangent_component_2" /) + + character(len=20), dimension(3) :: aligned_components + + ! for sem + logical have_sem_bc + integer ns, nots + + type(mesh_type), pointer:: surface_mesh + type(scalar_field) :: surface_field_component, smoothed_value_component + type(scalar_field), pointer:: scalar_surface_field, scalar_parent_field + type(vector_field), pointer:: surface_field, surface_field11, smoothed_value + type(vector_field), pointer:: surface_field2, surface_field21, surface_field22 + type(vector_field) :: bc_position, temp_position, linear_bc_position + character(len=OPTION_PATH_LEN) bc_path_i, bc_type_path, bc_component_path + character(len=FIELD_NAME_LEN) bc_name, bc_type, parent_field_name + logical applies(3), have_smoothing(3) + real:: time, theta, dt + integer, dimension(:), pointer:: surface_element_list + integer i, j, k, nbcs, smoothing_iterations, stat + + ns=1 + nbcs=option_count(trim(bc_path)) + + boundary_conditions: do i=0, nbcs-1 + bc_path_i=trim(bc_path)//"["//int2str(i)//"]" + call get_option(trim(bc_path_i)//"/name", bc_name) + + bc_path_i=trim(bc_path_i)//'/type[0]' + call get_option(trim(bc_path_i)//"/name", bc_type) + + if (trim(bc_type) .eq. "bulk_formulae") then + ! skip bulk_formulae types; they are dealt with seperately + ! See set_ocean_forcing_boundary_conditions + cycle boundary_conditions end if - end if - - select case(trim(bc_type)) - case("dirichlet", "neumann", "weakdirichlet", "flux") - - if(have_option(trim(bc_path_i)//"/align_bc_with_cartesian")) then - aligned_components=cartesian_aligned_components - bc_type_path=trim(bc_path_i)//"/align_bc_with_cartesian" - else - aligned_components=surface_aligned_components - bc_type_path=trim(bc_path_i)//"/align_bc_with_surface" - end if - - have_sem_bc=.false. - have_smoothing = .false. - do j=1,3 - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) - applies(j)=have_option(trim(bc_component_path)) - if (.not. applies(j)) cycle - have_sem_bc = have_sem_bc .or. have_option(trim(bc_component_path)//'/synthetic_eddy_method') - have_smoothing(j) = have_option(trim(bc_component_path)//'/smoothing') - end do - - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - surface_field => extract_surface_field(field, bc_name, name="value") - if((surface_mesh%shape%degree==0).and.(bc_type=="dirichlet")) then - ! if the boundary condition is on a 0th degree mesh and is of type strong dirichlet - ! then the positions used to calculate the bc should be body element centred not - ! surface element centred - call allocate(temp_position, position%dim, field%mesh, "TemporaryPositions") - ! first remap to body element centred positions - call remap_field(position, temp_position) - ! then remap these to the surface - bc_position = get_coordinates_remapped_to_surface(temp_position, surface_mesh, surface_element_list) - call deallocate(temp_position) - else - ! in all other cases the positions are remapped to the actual surface - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + if(have_option(trim(bc_path_i)//"/apply_weakly")) then + bc_type = "weak"//trim(bc_type) end if - if (any(have_smoothing)) then - if (has_surface_field(field, i+1, "smoothed_value")) then - smoothed_value => extract_surface_field(field, i+1, "smoothed_value") - ! we initialise the value on the linear field smoothed_value first - ! so we need a position on its mesh - linear_bc_position = get_coordinates_remapped_to_surface(position, smoothed_value%mesh, surface_element_list) + ! work out time level at which to evaluate: + call get_option("/timestepping/current_time", time) + if (present_and_true(shift_time)) then + call get_option("/timestepping/timestep", dt) + if (bc_type=="dirichlet") then + time=time+dt else - smoothed_value => surface_field - linear_bc_position = bc_position - call incref(linear_bc_position) + call get_option( trim(field%option_path)// & + "/prognostic/temporal_discretisation/theta", theta, default=0.5) + time=time+theta*dt end if - end if - - - ! Synthetic Eddy Method for generating inflow turbulence - if (have_sem_bc) then - surface_field11 => extract_surface_field(field, bc_name, name="MeanProfile") - do k=1,3 - surface_field_component=extract_scalar_field(surface_field11, k) - bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(k))//"/synthetic_eddy_method/mean_profile" - call initialise_field(surface_field_component, trim(bc_component_path), bc_position, & - time=time) - enddo + end if - surface_field22 => extract_surface_field(field, bc_name, name="TurbulenceLengthscale") - do k=1,3 - surface_field_component=extract_scalar_field(surface_field22, k) - bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(k))//"/synthetic_eddy_method/turbulence_lengthscale" - call initialise_field(surface_field_component, trim(bc_component_path), bc_position, & - time=time) - enddo - - surface_field21 => extract_surface_field(field, bc_name, name="ReStressesProfile") - do k=1,3 - surface_field_component=extract_scalar_field(surface_field21, k) - bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(k))//"/synthetic_eddy_method/Re_stresses_profile" - call initialise_field(surface_field_component, trim(bc_component_path), bc_position, & - time=time) - enddo - - bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(1))//"/synthetic_eddy_method/number_of_eddies" - call get_option(trim(bc_component_path),nots) - - ! allocate memory for eddies... - call initialise_sem_memory(ns,nots) - ! calculate the boundary condition... - call synthetic_eddy_method(surface_field, surface_field11, surface_field21, surface_field22, & - bc_position, bc_component_path, ns) - ns=ns+1 + select case(trim(bc_type)) + case("dirichlet", "neumann", "weakdirichlet", "flux") - else + if(have_option(trim(bc_path_i)//"/align_bc_with_cartesian")) then + aligned_components=cartesian_aligned_components + bc_type_path=trim(bc_path_i)//"/align_bc_with_cartesian" + else + aligned_components=surface_aligned_components + bc_type_path=trim(bc_path_i)//"/align_bc_with_surface" + end if + have_sem_bc=.false. + have_smoothing = .false. do j=1,3 - if (applies(j)) then - if (j>surface_field%dim) then - FLAbort("Too many dimensions in boundary condition") - end if + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) + applies(j)=have_option(trim(bc_component_path)) + if (.not. applies(j)) cycle + have_sem_bc = have_sem_bc .or. have_option(trim(bc_component_path)//'/synthetic_eddy_method') + have_smoothing(j) = have_option(trim(bc_component_path)//'/smoothing') + end do - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) - surface_field_component=extract_scalar_field(surface_field, j) - if (have_smoothing(j)) then - ! initialise on the linear and continuous "smoothed_value" surface field first - smoothed_value_component=extract_scalar_field(smoothed_value, j) - call initialise_vector_field_component(smoothed_value_component, state, & - bc_component_path, linear_bc_position, surface_element_list, j, time) - ! then smooth - call get_option(trim(bc_component_path)//"/smoothing/iterations", smoothing_iterations) - call smoothing(smoothed_value_component, bc_position, smoothing_iterations) - if (.not. associated(surface_field, smoothed_value)) then - ! if surface field and smoothed_value are the same, we're done - ! otherwise, remap to the actual value component field - call remap_field(smoothed_value_component, surface_field_component) - end if - else - ! initialise directly on the value component surface field - call initialise_vector_field_component(surface_field_component, state, & - bc_component_path, bc_position, surface_element_list, j, time) - end if + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + surface_field => extract_surface_field(field, bc_name, name="value") + + if((surface_mesh%shape%degree==0).and.(bc_type=="dirichlet")) then + ! if the boundary condition is on a 0th degree mesh and is of type strong dirichlet + ! then the positions used to calculate the bc should be body element centred not + ! surface element centred + call allocate(temp_position, position%dim, field%mesh, "TemporaryPositions") + ! first remap to body element centred positions + call remap_field(position, temp_position) + ! then remap these to the surface + bc_position = get_coordinates_remapped_to_surface(temp_position, surface_mesh, surface_element_list) + call deallocate(temp_position) + else + ! in all other cases the positions are remapped to the actual surface + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + end if + if (any(have_smoothing)) then + if (has_surface_field(field, i+1, "smoothed_value")) then + smoothed_value => extract_surface_field(field, i+1, "smoothed_value") + ! we initialise the value on the linear field smoothed_value first + ! so we need a position on its mesh + linear_bc_position = get_coordinates_remapped_to_surface(position, smoothed_value%mesh, surface_element_list) + else + smoothed_value => surface_field + linear_bc_position = bc_position + call incref(linear_bc_position) end if - end do - end if + end if - call deallocate(bc_position) - if (any(have_smoothing)) then - call deallocate(linear_bc_position) - end if - case("robin") + ! Synthetic Eddy Method for generating inflow turbulence + if (have_sem_bc) then + surface_field11 => extract_surface_field(field, bc_name, name="MeanProfile") + do k=1,3 + surface_field_component=extract_scalar_field(surface_field11, k) + bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(k))//"/synthetic_eddy_method/mean_profile" + call initialise_field(surface_field_component, trim(bc_component_path), bc_position, & + time=time) + enddo + + surface_field22 => extract_surface_field(field, bc_name, name="TurbulenceLengthscale") + do k=1,3 + surface_field_component=extract_scalar_field(surface_field22, k) + bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(k))//"/synthetic_eddy_method/turbulence_lengthscale" + call initialise_field(surface_field_component, trim(bc_component_path), bc_position, & + time=time) + enddo + + surface_field21 => extract_surface_field(field, bc_name, name="ReStressesProfile") + do k=1,3 + surface_field_component=extract_scalar_field(surface_field21, k) + bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(k))//"/synthetic_eddy_method/Re_stresses_profile" + call initialise_field(surface_field_component, trim(bc_component_path), bc_position, & + time=time) + enddo + + bc_component_path=trim(bc_type_path)//"/"//trim(aligned_components(1))//"/synthetic_eddy_method/number_of_eddies" + call get_option(trim(bc_component_path),nots) + + ! allocate memory for eddies... + call initialise_sem_memory(ns,nots) + ! calculate the boundary condition... + call synthetic_eddy_method(surface_field, surface_field11, surface_field21, surface_field22, & + bc_position, bc_component_path, ns) + ns=ns+1 + + else + + do j=1,3 + if (applies(j)) then + if (j>surface_field%dim) then + FLAbort("Too many dimensions in boundary condition") + end if + + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) + surface_field_component=extract_scalar_field(surface_field, j) + if (have_smoothing(j)) then + ! initialise on the linear and continuous "smoothed_value" surface field first + smoothed_value_component=extract_scalar_field(smoothed_value, j) + call initialise_vector_field_component(smoothed_value_component, state, & + bc_component_path, linear_bc_position, surface_element_list, j, time) + ! then smooth + call get_option(trim(bc_component_path)//"/smoothing/iterations", smoothing_iterations) + call smoothing(smoothed_value_component, bc_position, smoothing_iterations) + if (.not. associated(surface_field, smoothed_value)) then + ! if surface field and smoothed_value are the same, we're done + ! otherwise, remap to the actual value component field + call remap_field(smoothed_value_component, surface_field_component) + end if + else + ! initialise directly on the value component surface field + call initialise_vector_field_component(surface_field_component, state, & + bc_component_path, bc_position, surface_element_list, j, time) + end if + + end if + end do + end if + + call deallocate(bc_position) + if (any(have_smoothing)) then + call deallocate(linear_bc_position) + end if - if(have_option(trim(bc_path_i)//"/align_bc_with_cartesian")) then - aligned_components=cartesian_aligned_components - bc_type_path=trim(bc_path_i)//"/align_bc_with_cartesian" - else - aligned_components=surface_aligned_components - bc_type_path=trim(bc_path_i)//"/align_bc_with_surface" - end if + case("robin") - do j=1,3 - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) - applies(j)=have_option(trim(bc_component_path)) - end do + if(have_option(trim(bc_path_i)//"/align_bc_with_cartesian")) then + aligned_components=cartesian_aligned_components + bc_type_path=trim(bc_path_i)//"/align_bc_with_cartesian" + else + aligned_components=surface_aligned_components + bc_type_path=trim(bc_path_i)//"/align_bc_with_surface" + end if - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + do j=1,3 + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j) + applies(j)=have_option(trim(bc_component_path)) + end do + + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & surface_element_list=surface_element_list) - ! map the coordinate field onto this mesh - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - - surface_field => extract_surface_field(field, bc_name, name="order_zero_coeffcient") - surface_field2 => extract_surface_field(field, bc_name, name="order_one_coeffcient") - do j=1,3 - if (j>surface_field%dim) then - FLAbort("Too many dimensions in boundary condition") - end if - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j)//"/order_zero_coefficient" - surface_field_component=extract_scalar_field(surface_field, j) - call initialise_vector_field_component(surface_field_component, state, & - bc_component_path, bc_position, surface_element_list, j, time) - - bc_component_path=trim(bc_type_path)//"/"//aligned_components(j)//"/order_one_coefficient" - surface_field_component=extract_scalar_field(surface_field2, j) - call initialise_vector_field_component(surface_field_component, state, & - bc_component_path, bc_position, surface_element_list, j, time) - end do - call deallocate(bc_position) - - case("drag") - - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + ! map the coordinate field onto this mesh + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + + surface_field => extract_surface_field(field, bc_name, name="order_zero_coeffcient") + surface_field2 => extract_surface_field(field, bc_name, name="order_one_coeffcient") + do j=1,3 + if (j>surface_field%dim) then + FLAbort("Too many dimensions in boundary condition") + end if + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j)//"/order_zero_coefficient" + surface_field_component=extract_scalar_field(surface_field, j) + call initialise_vector_field_component(surface_field_component, state, & + bc_component_path, bc_position, surface_element_list, j, time) + + bc_component_path=trim(bc_type_path)//"/"//aligned_components(j)//"/order_one_coefficient" + surface_field_component=extract_scalar_field(surface_field2, j) + call initialise_vector_field_component(surface_field_component, state, & + bc_component_path, bc_position, surface_element_list, j, time) + end do + call deallocate(bc_position) + + case("drag") + + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & surface_element_list=surface_element_list) - scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="DragCoefficient") - ! map the coordinate field onto this mesh - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="DragCoefficient") + ! map the coordinate field onto this mesh + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - call initialise_field(scalar_surface_field, bc_path_i, bc_position, & - time=time) - call deallocate(bc_position) + call initialise_field(scalar_surface_field, bc_path_i, bc_position, & + time=time) + call deallocate(bc_position) - case("prescribed_normal_flow") + case("prescribed_normal_flow") - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & surface_element_list=surface_element_list) - surface_field => extract_surface_field(field, bc_name, name="value") - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - surface_field_component=extract_scalar_field(surface_field, 1) - call initialise_vector_field_component(surface_field_component, state, & - bc_path_i, bc_position, surface_element_list, 1, time) + surface_field => extract_surface_field(field, bc_name, name="value") + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + surface_field_component=extract_scalar_field(surface_field, 1) + call initialise_vector_field_component(surface_field_component, state, & + bc_path_i, bc_position, surface_element_list, 1, time) - call deallocate(bc_position) + call deallocate(bc_position) - case("wind_forcing") + case("wind_forcing") - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & surface_element_list=surface_element_list) - surface_field => extract_surface_field(field, bc_name, name="WindSurfaceField") - ! map the coordinate field onto this mesh - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + surface_field => extract_surface_field(field, bc_name, name="WindSurfaceField") + ! map the coordinate field onto this mesh + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - if (have_option(trim(bc_path_i)//"/wind_stress")) then - bc_type_path=trim(bc_path_i)//"/wind_stress" - call initialise_field(surface_field, bc_type_path, bc_position, & - time=time) - else if (have_option(trim(bc_path_i)//"/wind_velocity")) then - bc_type_path=trim(bc_path_i)//"/wind_velocity" + if (have_option(trim(bc_path_i)//"/wind_stress")) then + bc_type_path=trim(bc_path_i)//"/wind_stress" + call initialise_field(surface_field, bc_type_path, bc_position, & + time=time) + else if (have_option(trim(bc_path_i)//"/wind_velocity")) then + bc_type_path=trim(bc_path_i)//"/wind_velocity" - scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="WindDragCoefficient") - call initialise_field(scalar_surface_field, & + scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="WindDragCoefficient") + call initialise_field(scalar_surface_field, & trim(bc_type_path)//"/wind_drag_coefficient", bc_position, & time=time) - call initialise_field(surface_field, & + call initialise_field(surface_field, & trim(bc_type_path)//"/wind_velocity", bc_position, & time=time) - end if - call deallocate(bc_position) - - case("free_surface") - if(have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then - scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="WettingDryingAlpha") - call zero(scalar_surface_field) - end if - if (have_option(trim(bc_path_i)//"/external_density")) then - call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="ExternalDensity") - if (have_option(trim(bc_path_i)//"/external_density/from_field")) then - ! from_field: The parent field contains the boundary values that you want to apply to surface_field. - call get_option(trim(bc_path_i)//"/external_density/from_field/parent_field_name", parent_field_name) - scalar_parent_field => extract_scalar_field(state, parent_field_name, stat) - if(stat /= 0) then - ewrite(-1,*) "For external_density specified under " // trim(bc_path_i) - ewrite(-1,*) "Could not find scalar parent field " // trim(parent_field_name) - FLExit("Could not extract scalar parent field. Check options file?") - end if - call remap_field_to_surface(scalar_parent_field, scalar_surface_field, surface_element_list, stat) - else - ! constant or python - bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) - call initialise_field(scalar_surface_field, trim(bc_path_i)//"/external_density", & - bc_position, time=time) - call deallocate(bc_position) - end if - end if + end if + call deallocate(bc_position) + + case("free_surface") + if(have_option("/mesh_adaptivity/mesh_movement/free_surface/wetting_and_drying")) then + scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="WettingDryingAlpha") + call zero(scalar_surface_field) + end if + if (have_option(trim(bc_path_i)//"/external_density")) then + call get_boundary_condition(field, i+1, surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + scalar_surface_field => extract_scalar_surface_field(field, bc_name, name="ExternalDensity") + if (have_option(trim(bc_path_i)//"/external_density/from_field")) then + ! from_field: The parent field contains the boundary values that you want to apply to surface_field. + call get_option(trim(bc_path_i)//"/external_density/from_field/parent_field_name", parent_field_name) + scalar_parent_field => extract_scalar_field(state, parent_field_name, stat) + if(stat /= 0) then + ewrite(-1,*) "For external_density specified under " // trim(bc_path_i) + ewrite(-1,*) "Could not find scalar parent field " // trim(parent_field_name) + FLExit("Could not extract scalar parent field. Check options file?") + end if + call remap_field_to_surface(scalar_parent_field, scalar_surface_field, surface_element_list, stat) + else + ! constant or python + bc_position = get_coordinates_remapped_to_surface(position, surface_mesh, surface_element_list) + call initialise_field(scalar_surface_field, trim(bc_path_i)//"/external_density", & + bc_position, time=time) + call deallocate(bc_position) + end if + end if - case ("no_normal_flow", "outflow") + case ("no_normal_flow", "outflow") - ! nothing to be done (yet?) + ! nothing to be done (yet?) - case default - FLAbort("Incorrect boundary condition type for field") - end select + case default + FLAbort("Incorrect boundary condition type for field") + end select - end do boundary_conditions + end do boundary_conditions - end subroutine set_vector_boundary_conditions_values + end subroutine set_vector_boundary_conditions_values - recursive subroutine initialise_vector_field_component(surface_field_component, state, & + recursive subroutine initialise_vector_field_component(surface_field_component, state, & bc_component_path, bc_position, surface_element_list, j, time) - type(scalar_field), intent(inout) :: surface_field_component - type(state_type), intent(in) :: state - character(len=*), intent(in) :: bc_component_path - type(vector_field), intent(in) :: bc_position - integer, dimension(:), intent(in) :: surface_element_list - ! which component are we setting (used in from_field to determine which component to copy from) - integer, intent(in) :: j - real, intent(in) :: time - - type(scalar_field) :: foamvel_component - type(scalar_field) :: vector_parent_field_component - type(scalar_field), pointer:: scalar_parent_field - type(vector_field), pointer :: vector_parent_field - type(vector_field), pointer :: foamvel - character(len=FIELD_NAME_LEN) parent_field_name - integer:: stat - - ! first check for options that require state - if (have_option(trim(bc_component_path)//"/foam_flow")) then - - foamvel => extract_vector_field(state, "FoamVelocity") - - foamvel_component=extract_scalar_field(foamvel, j) - call remap_field_to_surface(foamvel_component, surface_field_component, surface_element_list) - - else if (have_option(trim(bc_component_path)//"/from_field")) then - ! The parent field contains the boundary values that you want to apply to surface_field. - call get_option(trim(bc_component_path)//"/from_field/parent_field_name", parent_field_name) - - ! Is the parent field a scalar field? Let's check using 'stat'... - scalar_parent_field => extract_scalar_field(state, parent_field_name, stat) - if(stat /= 0) then - ! Parent field is not a scalar field. Let's try a vector field extraction... - vector_parent_field => extract_vector_field(state, parent_field_name, stat) - if(stat /= 0) then - ! Parent field not found. - ewrite(-1,*) "For boundary condition set from_field under " // trim(bc_component_path) - ewrite(-1,*) "Could not find scalar or vector parent field " // trim(parent_field_name) - FLExit("Could not extract parent field. Check options file?") - else - ! Apply the j-th component of parent_field to the j-th component - ! of surface_field. - vector_parent_field_component = extract_scalar_field(vector_parent_field, j) - call remap_field_to_surface(vector_parent_field_component, surface_field_component, surface_element_list, stat) - end if - else - ! Apply the scalar field to the j-th component of surface_field. - call remap_field_to_surface(scalar_parent_field, surface_field_component, surface_element_list, stat) - end if - - else - - ! options that don't require state: constant/python/from_field are handled by the generic routine - call initialise_field(surface_field_component, bc_component_path, bc_position, & - time=time) - end if - - end subroutine initialise_vector_field_component - - subroutine smoothing(field, position, iterations) - type(scalar_field), intent(inout) :: field - type(vector_field), intent(in) :: position - integer, intent(in) :: iterations - - type(scalar_field) :: masslump, rhs - integer i, ele - - ewrite(1,*) "Inside smoothing" - - ewrite_minmax(field) - call allocate(masslump, field%mesh, trim(field%mesh%name)//"LumpedMass") - call allocate(rhs, field%mesh, "SmoothingRHS") - call zero(masslump) - do i=1, iterations - call zero(rhs) - do ele=1, element_count(field) - call smoothing_ele(ele, i) - end do - if (i==1) then - call invert(masslump) + type(scalar_field), intent(inout) :: surface_field_component + type(state_type), intent(in) :: state + character(len=*), intent(in) :: bc_component_path + type(vector_field), intent(in) :: bc_position + integer, dimension(:), intent(in) :: surface_element_list + ! which component are we setting (used in from_field to determine which component to copy from) + integer, intent(in) :: j + real, intent(in) :: time + + type(scalar_field) :: foamvel_component + type(scalar_field) :: vector_parent_field_component + type(scalar_field), pointer:: scalar_parent_field + type(vector_field), pointer :: vector_parent_field + type(vector_field), pointer :: foamvel + character(len=FIELD_NAME_LEN) parent_field_name + integer:: stat + + ! first check for options that require state + if (have_option(trim(bc_component_path)//"/foam_flow")) then + + foamvel => extract_vector_field(state, "FoamVelocity") + + foamvel_component=extract_scalar_field(foamvel, j) + call remap_field_to_surface(foamvel_component, surface_field_component, surface_element_list) + + else if (have_option(trim(bc_component_path)//"/from_field")) then + ! The parent field contains the boundary values that you want to apply to surface_field. + call get_option(trim(bc_component_path)//"/from_field/parent_field_name", parent_field_name) + + ! Is the parent field a scalar field? Let's check using 'stat'... + scalar_parent_field => extract_scalar_field(state, parent_field_name, stat) + if(stat /= 0) then + ! Parent field is not a scalar field. Let's try a vector field extraction... + vector_parent_field => extract_vector_field(state, parent_field_name, stat) + if(stat /= 0) then + ! Parent field not found. + ewrite(-1,*) "For boundary condition set from_field under " // trim(bc_component_path) + ewrite(-1,*) "Could not find scalar or vector parent field " // trim(parent_field_name) + FLExit("Could not extract parent field. Check options file?") + else + ! Apply the j-th component of parent_field to the j-th component + ! of surface_field. + vector_parent_field_component = extract_scalar_field(vector_parent_field, j) + call remap_field_to_surface(vector_parent_field_component, surface_field_component, surface_element_list, stat) + end if + else + ! Apply the scalar field to the j-th component of surface_field. + call remap_field_to_surface(scalar_parent_field, surface_field_component, surface_element_list, stat) + end if + + else + + ! options that don't require state: constant/python/from_field are handled by the generic routine + call initialise_field(surface_field_component, bc_component_path, bc_position, & + time=time) end if - call set(field, rhs) - call scale(field, masslump) - call halo_update(field, verbose=.false.) - end do - ewrite_minmax(field) - call deallocate(masslump) - call deallocate(rhs) + end subroutine initialise_vector_field_component + + subroutine smoothing(field, position, iterations) + type(scalar_field), intent(inout) :: field + type(vector_field), intent(in) :: position + integer, intent(in) :: iterations + + type(scalar_field) :: masslump, rhs + integer i, ele + + ewrite(1,*) "Inside smoothing" - ewrite(1,*) "Finished smoothing" + ewrite_minmax(field) + call allocate(masslump, field%mesh, trim(field%mesh%name)//"LumpedMass") + call allocate(rhs, field%mesh, "SmoothingRHS") + call zero(masslump) + do i=1, iterations + call zero(rhs) + do ele=1, element_count(field) + call smoothing_ele(ele, i) + end do + if (i==1) then + call invert(masslump) + end if + call set(field, rhs) + call scale(field, masslump) + call halo_update(field, verbose=.false.) + end do + ewrite_minmax(field) - contains + call deallocate(masslump) + call deallocate(rhs) + + ewrite(1,*) "Finished smoothing" + + contains + + subroutine smoothing_ele(ele, i) + integer, intent(in):: ele, i + type(element_type), pointer:: shape + real, dimension(ele_ngi(field, ele)):: detwei + + shape => ele_shape(field, ele) + call transform_to_physical(position, ele, detwei) + if (i==1) then + call addto(masslump, ele_nodes(field, ele), shape_rhs(shape, detwei)) + end if + call addto(rhs, ele_nodes(field, ele), shape_rhs(shape, detwei*ele_val_at_quad(field, ele))) - subroutine smoothing_ele(ele, i) - integer, intent(in):: ele, i - type(element_type), pointer:: shape - real, dimension(ele_ngi(field, ele)):: detwei + end subroutine smoothing_ele - shape => ele_shape(field, ele) - call transform_to_physical(position, ele, detwei) - if (i==1) then - call addto(masslump, ele_nodes(field, ele), shape_rhs(shape, detwei)) + end subroutine smoothing + + + subroutine set_tidal_bc_value(surface_field, bc_position, bc_type_path, field_name) + ! tidal_forcing - asc + type(scalar_field), intent(inout):: surface_field + type(vector_field), intent(in):: bc_position + character(len=*), intent(in):: bc_type_path, field_name + + real :: current_time, frequency, amplitude_factor + integer :: constituent_count, i, j, id, stat + character(len=3) :: constituent_name + character(len=4096) :: file_name, variable_name_amplitude, variable_name_phase + real, dimension(:), allocatable::amplitude, phase + real :: xyz(3), longitude, latitude + real :: gravty + + allocate(amplitude(node_count(surface_field)), phase(node_count(surface_field))) + + if(have_option(trim(bc_type_path)//"/from_file/tidal")) then + call set(surface_field, 0.0) + call get_option("/timestepping/current_time", current_time) + constituent_count = option_count(trim(bc_type_path)//"/from_file/tidal") + + do i=0, constituent_count-1 + amplitude = 0.0 + phase = 0.0 + call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"/amplitude_factor", amplitude_factor, stat=stat) + if (stat/=0) then + amplitude_factor = 1.0 + end if + + ! Taken from E.W. Schwiderski - Rev. Geophys. Space Phys. Vol. 18 No. 1 pp. 243--268, 1980 + call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/name", constituent_name, stat=stat) + + frequency = get_tidal_frequency(constituent_name) + + call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/file_name", file_name, stat=stat) + call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/variable_name_amplitude", variable_name_amplitude, stat=stat) + call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/variable_name_phase", variable_name_phase, stat=stat) + + call SampleNetCDF_Open(trim(file_name), id) + call SampleNetCDF_SetVariable(id, trim(variable_name_amplitude)) + do j=1, node_count(bc_position) + xyz = node_val(bc_position, j) + call LongitudeLatitude(xyz, longitude, latitude) + call SampleNetCDF_GetValue(id, longitude, latitude, amplitude(j)) + end do + call SampleNetCDF_SetVariable(id, trim(variable_name_phase)) + do j=1, node_count(bc_position) + xyz = node_val(bc_position, j) + call LongitudeLatitude(xyz, longitude, latitude) + call SampleNetCDF_GetValue(id, longitude, latitude, phase(j)) + end do + + call get_option('/physical_parameters/gravity/magnitude', gravty) + do j=1, node_count(bc_position) + if (field_name=="Pressure") then + call addto(surface_field, j, & + gravty * amplitude(j) * cos( frequency * current_time - ( phase(j) * pi / 180 ) )) + else + call addto(surface_field, j, & + amplitude(j) * cos( frequency * current_time - ( phase(j) * pi / 180 ) )) + end if + end do + call SampleNetCDF_Close(id) + end do end if - call addto(rhs, ele_nodes(field, ele), shape_rhs(shape, detwei*ele_val_at_quad(field, ele))) - - end subroutine smoothing_ele - - end subroutine smoothing - - - subroutine set_tidal_bc_value(surface_field, bc_position, bc_type_path, field_name) - ! tidal_forcing - asc - type(scalar_field), intent(inout):: surface_field - type(vector_field), intent(in):: bc_position - character(len=*), intent(in):: bc_type_path, field_name - - real :: current_time, frequency, amplitude_factor - integer :: constituent_count, i, j, id, stat - character(len=3) :: constituent_name - character(len=4096) :: file_name, variable_name_amplitude, variable_name_phase - real, dimension(:), allocatable::amplitude, phase - real :: xyz(3), longitude, latitude - real :: gravty - - allocate(amplitude(node_count(surface_field)), phase(node_count(surface_field))) - - if(have_option(trim(bc_type_path)//"/from_file/tidal")) then - call set(surface_field, 0.0) - call get_option("/timestepping/current_time", current_time) - constituent_count = option_count(trim(bc_type_path)//"/from_file/tidal") - - do i=0, constituent_count-1 - amplitude = 0.0 - phase = 0.0 - call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"/amplitude_factor", amplitude_factor, stat=stat) - if (stat/=0) then - amplitude_factor = 1.0 - end if - - ! Taken from E.W. Schwiderski - Rev. Geophys. Space Phys. Vol. 18 No. 1 pp. 243--268, 1980 - call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/name", constituent_name, stat=stat) - - frequency = get_tidal_frequency(constituent_name) - - call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/file_name", file_name, stat=stat) - call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/variable_name_amplitude", variable_name_amplitude, stat=stat) - call get_option(trim(bc_type_path)//"/from_file/tidal["//int2str(i)//"]/variable_name_phase", variable_name_phase, stat=stat) - - call SampleNetCDF_Open(trim(file_name), id) - call SampleNetCDF_SetVariable(id, trim(variable_name_amplitude)) - do j=1, node_count(bc_position) - xyz = node_val(bc_position, j) - call LongitudeLatitude(xyz, longitude, latitude) - call SampleNetCDF_GetValue(id, longitude, latitude, amplitude(j)) - end do - call SampleNetCDF_SetVariable(id, trim(variable_name_phase)) - do j=1, node_count(bc_position) - xyz = node_val(bc_position, j) - call LongitudeLatitude(xyz, longitude, latitude) - call SampleNetCDF_GetValue(id, longitude, latitude, phase(j)) - end do - - call get_option('/physical_parameters/gravity/magnitude', gravty) - do j=1, node_count(bc_position) + end subroutine set_tidal_bc_value + + subroutine set_nemo_bc_value(state, surface_field, bc_position, bc_type_path, field_name, surface_element_list) + ! This subroutine sets the pressure at the boundary from NEMO data + type(state_type), intent(in) :: state + type(scalar_field), intent(inout):: surface_field + type(vector_field), intent(in):: bc_position + integer, dimension(:), intent(in) :: surface_element_list + character(len=*), intent(in):: bc_type_path, field_name + + type(scalar_field) :: nemo_pressure_bc + type(scalar_field), pointer :: NEMOpressure + character(len=4096) :: data_field_name + + integer :: j + real :: gravty, boundary_pressure + + if(have_option(trim(bc_type_path)//"/NEMO_data")) then + call set(surface_field, 0.0) + + + call get_option(trim(bc_type_path)//"/NEMO_data/field_name", data_field_name) + call get_option('/physical_parameters/gravity/magnitude', gravty) + + NEMOpressure => extract_scalar_field(state, data_field_name) + call allocate(nemo_pressure_bc, surface_field%mesh, name="NPBC") + call remap_field_to_surface(NEMOpressure, nemo_pressure_bc, surface_element_list) + + do j=1, node_count(bc_position) + boundary_pressure=node_val(nemo_pressure_bc,j) if (field_name=="Pressure") then - call addto(surface_field, j, & - gravty * amplitude(j) * cos( frequency * current_time - ( phase(j) * pi / 180 ) )) + call addto(surface_field, j, boundary_pressure) else - call addto(surface_field, j, & - amplitude(j) * cos( frequency * current_time - ( phase(j) * pi / 180 ) )) - end if - end do - call SampleNetCDF_Close(id) - end do - end if - end subroutine set_tidal_bc_value - - subroutine set_nemo_bc_value(state, surface_field, bc_position, bc_type_path, field_name, surface_element_list) - ! This subroutine sets the pressure at the boundary from NEMO data - type(state_type), intent(in) :: state - type(scalar_field), intent(inout):: surface_field - type(vector_field), intent(in):: bc_position - integer, dimension(:), intent(in) :: surface_element_list - character(len=*), intent(in):: bc_type_path, field_name - - type(scalar_field) :: nemo_pressure_bc - type(scalar_field), pointer :: NEMOpressure - character(len=4096) :: data_field_name - - integer :: j - real :: gravty, boundary_pressure - - if(have_option(trim(bc_type_path)//"/NEMO_data")) then - call set(surface_field, 0.0) - - - call get_option(trim(bc_type_path)//"/NEMO_data/field_name", data_field_name) - call get_option('/physical_parameters/gravity/magnitude', gravty) - - NEMOpressure => extract_scalar_field(state, data_field_name) - call allocate(nemo_pressure_bc, surface_field%mesh, name="NPBC") - call remap_field_to_surface(NEMOpressure, nemo_pressure_bc, surface_element_list) - - do j=1, node_count(bc_position) - boundary_pressure=node_val(nemo_pressure_bc,j) - if (field_name=="Pressure") then - call addto(surface_field, j, boundary_pressure) - else - call addto(surface_field, j, boundary_pressure/gravty) - end if - end do - end if - end subroutine set_nemo_bc_value - - subroutine apply_dirichlet_conditions_inverse_mass_vector(inverse_mass, field) - !!< Zeroes the rows of dirichlet boundary conditions in - !!< the inverse mass matrix - type(block_csr_matrix), intent(inout) :: inverse_mass - type(vector_field), intent(in) :: field - - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - real, dimension(:), pointer:: vals - integer, dimension(:), pointer:: cols - integer, dimension(:), pointer:: surface_node_list - logical, dimension(:), allocatable:: dirichlet_mask - integer :: i,j,k - - allocate(dirichlet_mask(1:node_count(field))) - - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) - - if (bctype/="dirichlet") cycle bcloop - - ! first zero rows: - do j=1,size(surface_node_list) - do k = 1, field%dim - if(applies(k)) then - call zero_row(inverse_mass, k, surface_node_list(j)) + call addto(surface_field, j, boundary_pressure/gravty) end if - end do - end do - - ! then zero columns: - dirichlet_mask=.false. - dirichlet_mask(surface_node_list)=.true. - do j=1, node_count(field) - cols => row_m_ptr(inverse_mass, j) - do k=1, field%dim - if (applies(k)) then - vals => row_val_ptr(inverse_mass, k, k, j) - where (dirichlet_mask(cols)) - vals=0.0 - end where - end if end do - end do + end if + end subroutine set_nemo_bc_value + + subroutine apply_dirichlet_conditions_inverse_mass_vector(inverse_mass, field) + !!< Zeroes the rows of dirichlet boundary conditions in + !!< the inverse mass matrix + type(block_csr_matrix), intent(inout) :: inverse_mass + type(vector_field), intent(in) :: field + + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + real, dimension(:), pointer:: vals + integer, dimension(:), pointer:: cols + integer, dimension(:), pointer:: surface_node_list + logical, dimension(:), allocatable:: dirichlet_mask + integer :: i,j,k + + allocate(dirichlet_mask(1:node_count(field))) + + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) + + if (bctype/="dirichlet") cycle bcloop + + ! first zero rows: + do j=1,size(surface_node_list) + do k = 1, field%dim + if(applies(k)) then + call zero_row(inverse_mass, k, surface_node_list(j)) + end if + end do + end do - end do bcloop + ! then zero columns: + dirichlet_mask=.false. + dirichlet_mask(surface_node_list)=.true. + do j=1, node_count(field) + cols => row_m_ptr(inverse_mass, j) + do k=1, field%dim + if (applies(k)) then + vals => row_val_ptr(inverse_mass, k, k, j) + where (dirichlet_mask(cols)) + vals=0.0 + end where + end if + end do + end do - end subroutine apply_dirichlet_conditions_inverse_mass_vector + end do bcloop - subroutine apply_dirichlet_conditions_inverse_mass_vector_lumped(inverse_masslump, field) - !!< Zeroes the rows of dirichlet boundary conditions in - !!< the lumped mass vector field - type(vector_field), intent(inout) :: inverse_masslump - type(vector_field), intent(in) :: field + end subroutine apply_dirichlet_conditions_inverse_mass_vector - logical, dimension(field%dim):: applies - character(len=FIELD_NAME_LEN):: bctype - integer, dimension(:), pointer:: surface_node_list - integer :: i,j,k + subroutine apply_dirichlet_conditions_inverse_mass_vector_lumped(inverse_masslump, field) + !!< Zeroes the rows of dirichlet boundary conditions in + !!< the lumped mass vector field + type(vector_field), intent(inout) :: inverse_masslump + type(vector_field), intent(in) :: field - bcloop: do i=1, get_boundary_condition_count(field) - call get_boundary_condition(field, i, type=bctype, & - surface_node_list=surface_node_list, applies=applies) + logical, dimension(field%dim):: applies + character(len=FIELD_NAME_LEN):: bctype + integer, dimension(:), pointer:: surface_node_list + integer :: i,j,k - if (bctype/="dirichlet") cycle bcloop + bcloop: do i=1, get_boundary_condition_count(field) + call get_boundary_condition(field, i, type=bctype, & + surface_node_list=surface_node_list, applies=applies) - do j=1,size(surface_node_list) - do k = 1, field%dim - if(applies(k)) then + if (bctype/="dirichlet") cycle bcloop - call set(inverse_masslump, k, surface_node_list(j), 0.0) + do j=1,size(surface_node_list) + do k = 1, field%dim + if(applies(k)) then - end if + call set(inverse_masslump, k, surface_node_list(j), 0.0) + + end if + end do end do - end do - end do bcloop + end do bcloop - end subroutine apply_dirichlet_conditions_inverse_mass_vector_lumped + end subroutine apply_dirichlet_conditions_inverse_mass_vector_lumped - subroutine ocean_boundaries_stats(state) - type(state_type), intent(in):: state + subroutine ocean_boundaries_stats(state) + type(state_type), intent(in):: state - if (current_debug_level>=1) then - call single_ocean_boundary_stats(state, "DistanceToTop", "top") - call single_ocean_boundary_stats(state, "DistanceToBottom", "bottom") - end if + if (current_debug_level>=1) then + call single_ocean_boundary_stats(state, "DistanceToTop", "top") + call single_ocean_boundary_stats(state, "DistanceToBottom", "bottom") + end if + + end subroutine ocean_boundaries_stats - end subroutine ocean_boundaries_stats + subroutine single_ocean_boundary_stats(state, field_name, surface_name) + type(state_type), intent(in):: state + character(len=*), intent(in):: field_name, surface_name - subroutine single_ocean_boundary_stats(state, field_name, surface_name) - type(state_type), intent(in):: state - character(len=*), intent(in):: field_name, surface_name + type(vector_field), pointer:: gravity_direction, positions + type(scalar_field), pointer:: distance_field + real, dimension(:,:), allocatable:: face_normal, grav_normal + real, dimension(:), allocatable:: detwei_f + real area, max_inn, min_inn, inn + integer, dimension(:), pointer:: surface_element_list, surface_node_list + integer i, j, ele, sele, sngi - type(vector_field), pointer:: gravity_direction, positions - type(scalar_field), pointer:: distance_field - real, dimension(:,:), allocatable:: face_normal, grav_normal - real, dimension(:), allocatable:: detwei_f - real area, max_inn, min_inn, inn - integer, dimension(:), pointer:: surface_element_list, surface_node_list - integer i, j, ele, sele, sngi + ewrite(1,*) "Stats for "//trim(surface_name)//" ocean boundary:" - ewrite(1,*) "Stats for "//trim(surface_name)//" ocean boundary:" + distance_field => extract_scalar_field(state, field_name) + gravity_direction => extract_vector_field(state, "GravityDirection") + positions => extract_vector_field(state, "Coordinate") + call get_boundary_condition(distance_field, 1, & + surface_element_list=surface_element_list, & + surface_node_list=surface_node_list) - distance_field => extract_scalar_field(state, field_name) - gravity_direction => extract_vector_field(state, "GravityDirection") - positions => extract_vector_field(state, "Coordinate") - call get_boundary_condition(distance_field, 1, & - surface_element_list=surface_element_list, & - surface_node_list=surface_node_list) + ewrite(2,*) "Number of surface nodes:", size(surface_node_list) + ewrite(2,*) "Number of surface elements:", size(surface_element_list) - ewrite(2,*) "Number of surface nodes:", size(surface_node_list) - ewrite(2,*) "Number of surface elements:", size(surface_element_list) + sngi = face_ngi(distance_field, 1) - sngi = face_ngi(distance_field, 1) + allocate( detwei_f(1:sngi), & + face_normal(1:gravity_direction%dim, 1:sngi), & + grav_normal(1:gravity_direction%dim, 1:sngi) ) - allocate( detwei_f(1:sngi), & - face_normal(1:gravity_direction%dim, 1:sngi), & - grav_normal(1:gravity_direction%dim, 1:sngi) ) + area=0.0 + min_inn=huge(1.0) + max_inn=-min_inn + do i=1, size(surface_element_list) - area=0.0 - min_inn=huge(1.0) - max_inn=-min_inn - do i=1, size(surface_element_list) + sele=surface_element_list(i) + ! 3D element behind the surface element: + ele=face_ele(distance_field, sele) - sele=surface_element_list(i) - ! 3D element behind the surface element: - ele=face_ele(distance_field, sele) + call transform_facet_to_physical(positions, sele, & + detwei_f=detwei_f, normal=face_normal) - call transform_facet_to_physical(positions, sele, & - detwei_f=detwei_f, normal=face_normal) + area=area+sum(detwei_f) - area=area+sum(detwei_f) + ! gravity normal at face gauss points + grav_normal=face_val_at_quad(gravity_direction, sele) - ! gravity normal at face gauss points - grav_normal=face_val_at_quad(gravity_direction, sele) + ! inner product of face_normal and grav_normal at gauss points: + do j=1, sngi + inn=dot_product(face_normal(:,j), grav_normal(:,j)) - ! inner product of face_normal and grav_normal at gauss points: - do j=1, sngi - inn=dot_product(face_normal(:,j), grav_normal(:,j)) + min_inn=min(min_inn, inn) + max_inn=max(max_inn, inn) + end do - min_inn=min(min_inn, inn) - max_inn=max(max_inn, inn) end do - end do - - ewrite(2, *) "Surface area:", area - ewrite(2, *) "Maximum of inner product gravity and face normal", min_inn - ewrite(2, *) "Minimum of inner product gravity and face normal", max_inn - ewrite(2, *) "" - - end subroutine single_ocean_boundary_stats - - subroutine set_ocean_forcings_boundary_conditions(state) - type(state_type), intent(in) :: state - - type(mesh_type) :: ocean_mesh, input_mesh - ! output from the get_fluxes call on the ocean_mesh - type(scalar_field) :: salinity_flux, heat_flux, solar_flux - type(vector_field) :: stress_flux - ! the current state to be put on the ocean_mesh - input to the fluxes call - type(scalar_field) :: temperature, salinity - type(vector_field) :: velocity, position, position_remapped - ! these are pointers to the fields in the state - type(scalar_field), pointer :: p_temperature, p_salinity - type(vector_field), pointer :: p_velocity, p_position - - ! some temporary storage arrays - ! some of this need hiding inside get_fluxes - real, dimension(3) :: temp_vector_3D, transformation - real, dimension(2) :: temp_vector_2D - real, dimension(:), allocatable :: temp, sal, X, Y, Z, Vx, Vy, Vz - real, dimension(:), allocatable :: F_as, Q_as, Q_s, Tau_u, Tau_v - integer :: NNodes, i - integer, dimension(:), pointer :: surface_element_list, surface_nodes - real :: current_time - type(scalar_field), pointer :: scalar_source_field, sfield - type(vector_field), pointer :: vector_source_field, vfield - type(scalar_field), pointer :: scalar_surface - type(vector_field), pointer :: vector_surface - logical*1 :: on_sphere ! needs to be handed over to C, which has 1 bit booleans - real, dimension(:), allocatable :: lat_long - integer :: shape_option(2), stat, bulk_formula - integer :: force_temperature, force_salinity, force_velocity, force_solar - - - ! First job is to construct a mesh for the upper surface. From this - ! we can construct a number of temporary fields to store i/o from - ! the fluxes routines - call get_forcing_surface_element_list(state, surface_element_list, & - & force_temperature, force_solar, force_velocity, force_salinity) - if (force_temperature .eq. -1 .and. & - &force_solar .eq. -1 .and. & - &force_velocity .eq. -1 .and. & - &force_salinity .eq. -1) then - ewrite(-1,*)("You have bulk forcing on, but no fields have a bulk_formulae boundary condition") - FLExit("See the manual for more details") - end if - input_mesh = extract_velocity_mesh(state,stat) - if (stat /= 0) then - FLAbort("The ocean_forcing routines had difficulty getting a Velocity mesh.") - end if - call create_surface_mesh(ocean_mesh, surface_nodes, input_mesh, surface_element_list, 'OceanSurface') - NNodes = node_count(ocean_mesh) - - - ! temp arrays for fluxes - allocate(temp(NNodes)) - allocate(sal(NNodes)) - allocate(X(NNodes)) - allocate(Y(NNodes)) - allocate(Z(NNodes)) - allocate(Vx(NNodes)) - allocate(Vy(NNodes)) - allocate(Vz(NNodes)) - allocate(F_as(NNodes)) - allocate(Q_as(NNodes)) - allocate(Q_s(NNodes)) - allocate(Tau_u(NNodes)) - allocate(Tau_v(NNodes)) - - - ! allocate field on ocean mesh to store output of get_fluxes - if (force_velocity .ge. 0) then - call allocate(stress_flux, 2, ocean_mesh, name="stress_flux") - end if - if (force_temperature .ge. 0) then - call allocate(heat_flux, ocean_mesh, name="heat_flux") - end if - if (force_salinity .ge. 0) then - call allocate(salinity_flux, ocean_mesh, name="salinity_flux") - end if - if (force_solar .ge. 0) then - call allocate(solar_flux, ocean_mesh, name="solar_flux") - end if - ! allocate space to store current state of parameters required - ! to get the fluxes - call allocate(temperature, ocean_mesh, name="temperature") - call allocate(velocity, 3, ocean_mesh, name="velocity") - call allocate(position, 3, ocean_mesh, name="position") - call allocate(salinity, ocean_mesh, name="salinity") - - ! grab current state, this needs doing regardless of which BCs - ! are applied - p_temperature => extract_scalar_field(state, "Temperature") - p_velocity => extract_vector_field(state, "Velocity") - p_position => extract_vector_field(state, "Coordinate") - - ! remap modelled params onto the appropriate field in ocean_mesh - call remap_field_to_surface(p_temperature, temperature, & - surface_element_list) - call remap_field_to_surface(p_velocity, velocity, & - surface_element_list) - call remap_field_to_surface(p_position, position, & - surface_element_list) - - ! check if we are transforming the coordinates to a specified lat/long - if (have_option('/ocean_forcing/bulk_formulae/position')) then - shape_option=option_shape('/ocean_forcing/bulk_formulae/position') - if (shape_option(1) .ne. 2) then + ewrite(2, *) "Surface area:", area + ewrite(2, *) "Maximum of inner product gravity and face normal", min_inn + ewrite(2, *) "Minimum of inner product gravity and face normal", max_inn + ewrite(2, *) "" + + end subroutine single_ocean_boundary_stats + + subroutine set_ocean_forcings_boundary_conditions(state) + type(state_type), intent(in) :: state + + type(mesh_type) :: ocean_mesh, input_mesh + ! output from the get_fluxes call on the ocean_mesh + type(scalar_field) :: salinity_flux, heat_flux, solar_flux + type(vector_field) :: stress_flux + ! the current state to be put on the ocean_mesh - input to the fluxes call + type(scalar_field) :: temperature, salinity + type(vector_field) :: velocity, position, position_remapped + ! these are pointers to the fields in the state + type(scalar_field), pointer :: p_temperature, p_salinity + type(vector_field), pointer :: p_velocity, p_position + + ! some temporary storage arrays + ! some of this need hiding inside get_fluxes + real, dimension(3) :: temp_vector_3D, transformation + real, dimension(2) :: temp_vector_2D + real, dimension(:), allocatable :: temp, sal, X, Y, Z, Vx, Vy, Vz + real, dimension(:), allocatable :: F_as, Q_as, Q_s, Tau_u, Tau_v + integer :: NNodes, i + integer, dimension(:), pointer :: surface_element_list, surface_nodes + real :: current_time + type(scalar_field), pointer :: scalar_source_field, sfield + type(vector_field), pointer :: vector_source_field, vfield + type(scalar_field), pointer :: scalar_surface + type(vector_field), pointer :: vector_surface + logical*1 :: on_sphere ! needs to be handed over to C, which has 1 bit booleans + real, dimension(:), allocatable :: lat_long + integer :: shape_option(2), stat, bulk_formula + integer :: force_temperature, force_salinity, force_velocity, force_solar + + + ! First job is to construct a mesh for the upper surface. From this + ! we can construct a number of temporary fields to store i/o from + ! the fluxes routines + call get_forcing_surface_element_list(state, surface_element_list, & + & force_temperature, force_solar, force_velocity, force_salinity) + if (force_temperature .eq. -1 .and. & + &force_solar .eq. -1 .and. & + &force_velocity .eq. -1 .and. & + &force_salinity .eq. -1) then + ewrite(-1,*)("You have bulk forcing on, but no fields have a bulk_formulae boundary condition") + FLExit("See the manual for more details") + end if + input_mesh = extract_velocity_mesh(state,stat) + if (stat /= 0) then + FLAbort("The ocean_forcing routines had difficulty getting a Velocity mesh.") + end if + call create_surface_mesh(ocean_mesh, surface_nodes, input_mesh, surface_element_list, 'OceanSurface') + NNodes = node_count(ocean_mesh) + + + ! temp arrays for fluxes + allocate(temp(NNodes)) + allocate(sal(NNodes)) + allocate(X(NNodes)) + allocate(Y(NNodes)) + allocate(Z(NNodes)) + allocate(Vx(NNodes)) + allocate(Vy(NNodes)) + allocate(Vz(NNodes)) + allocate(F_as(NNodes)) + allocate(Q_as(NNodes)) + allocate(Q_s(NNodes)) + allocate(Tau_u(NNodes)) + allocate(Tau_v(NNodes)) + + + ! allocate field on ocean mesh to store output of get_fluxes + if (force_velocity .ge. 0) then + call allocate(stress_flux, 2, ocean_mesh, name="stress_flux") + end if + if (force_temperature .ge. 0) then + call allocate(heat_flux, ocean_mesh, name="heat_flux") + end if + if (force_salinity .ge. 0) then + call allocate(salinity_flux, ocean_mesh, name="salinity_flux") + end if + if (force_solar .ge. 0) then + call allocate(solar_flux, ocean_mesh, name="solar_flux") + end if + ! allocate space to store current state of parameters required + ! to get the fluxes + call allocate(temperature, ocean_mesh, name="temperature") + call allocate(velocity, 3, ocean_mesh, name="velocity") + call allocate(position, 3, ocean_mesh, name="position") + call allocate(salinity, ocean_mesh, name="salinity") + + ! grab current state, this needs doing regardless of which BCs + ! are applied + p_temperature => extract_scalar_field(state, "Temperature") + p_velocity => extract_vector_field(state, "Velocity") + p_position => extract_vector_field(state, "Coordinate") + + ! remap modelled params onto the appropriate field in ocean_mesh + call remap_field_to_surface(p_temperature, temperature, & + surface_element_list) + call remap_field_to_surface(p_velocity, velocity, & + surface_element_list) + call remap_field_to_surface(p_position, position, & + surface_element_list) + + ! check if we are transforming the coordinates to a specified lat/long + if (have_option('/ocean_forcing/bulk_formulae/position')) then + shape_option=option_shape('/ocean_forcing/bulk_formulae/position') + if (shape_option(1) .ne. 2) then FLExit("Only specify a latitude and longitude under /ocean_forcing/bulk_formulae/positions, i.e. two numbers expected.") - end if - allocate(lat_long(1:shape_option(1))) - call get_option('/ocean_forcing/bulk_formulae/position', lat_long) - transformation(1) = lat_long(2) ! Longtitude - transformation(2) = lat_long(1) ! latitude - transformation(3) = 0.0 - call projections_spherical_cartesian(1, transformation(1:1), transformation(2:2), transformation(3:3)) - else - transformation = 0.0 - end if - - ! we now have the modelled parameters, temperature, etc on the same - ! mesh as the surface - we can now grab these, so... - ! loop over surface mesh points, grabbing field values at each and - ! shoving them unceremoniously into my temporary arrays - do i=1,NNodes - temp_vector_3D = node_val(position,i) - X(i) = temp_vector_3D(1)+transformation(1) - Y(i) = temp_vector_3D(2)+transformation(2) - Z(i) = temp_vector_3D(3)+transformation(3) - temp(i) = node_val(temperature,i) - temp_vector_3D = node_val(velocity,i) - Vx(i) = temp_vector_3D(1) - Vy(i) = temp_vector_3D(2) - Vz(i) = temp_vector_3D(3) - end do - - ! finally, check if the single position option is on, if so, make all - ! positions the same - if (have_option('/ocean_forcing/bulk_formulae/position/single_location')) then - do i=1, NNodes + end if + allocate(lat_long(1:shape_option(1))) + call get_option('/ocean_forcing/bulk_formulae/position', lat_long) + transformation(1) = lat_long(2) ! Longtitude + transformation(2) = lat_long(1) ! latitude + transformation(3) = 0.0 + call projections_spherical_cartesian(1, transformation(1:1), transformation(2:2), transformation(3:3)) + else + transformation = 0.0 + end if + + ! we now have the modelled parameters, temperature, etc on the same + ! mesh as the surface - we can now grab these, so... + ! loop over surface mesh points, grabbing field values at each and + ! shoving them unceremoniously into my temporary arrays + do i=1,NNodes + temp_vector_3D = node_val(position,i) + X(i) = temp_vector_3D(1)+transformation(1) + Y(i) = temp_vector_3D(2)+transformation(2) + Z(i) = temp_vector_3D(3)+transformation(3) + temp(i) = node_val(temperature,i) + temp_vector_3D = node_val(velocity,i) + Vx(i) = temp_vector_3D(1) + Vy(i) = temp_vector_3D(2) + Vz(i) = temp_vector_3D(3) + end do + + ! finally, check if the single position option is on, if so, make all + ! positions the same + if (have_option('/ocean_forcing/bulk_formulae/position/single_location')) then + do i=1, NNodes X(i) = transformation(1) Y(i) = transformation(2) Z(i) = transformation(3) - end do - end if + end do + end if - if (force_salinity .ge. 0) then - ! we only need to worry about salinity if the flux is on - p_salinity => extract_scalar_field(state, "Salinity", stat) - if (stat /= 0) then + if (force_salinity .ge. 0) then + ! we only need to worry about salinity if the flux is on + p_salinity => extract_scalar_field(state, "Salinity", stat) + if (stat /= 0) then FLExit("If you switch on a salinity flux, you'd better have a Salinity field...") - end if - call remap_field_to_surface(p_salinity, salinity, & - surface_element_list) - do i=1,NNodes + end if + call remap_field_to_surface(p_salinity, salinity, & + surface_element_list) + do i=1,NNodes sal(i) = node_val(salinity,i) - end do - else - ! use a decent estimate for the surface salinity - do i=1,NNodes + end do + else + ! use a decent estimate for the surface salinity + do i=1,NNodes sal(i) = 35.0 - end do - end if - - call get_option("/timestepping/current_time", current_time) - on_sphere=have_option('/geometry/spherical_earth') - - if (have_option('/ocean_forcing/bulk_formulae/bulk_formulae/type::COARE')) then - bulk_formula = 1 - else if (have_option('/ocean_forcing/bulk_formulae/bulk_formulae/type::BVW')) then - bulk_formula = 2 - else if (have_option('/ocean_forcing/bulk_formulae/bulk_formulae/type::Kara')) then - bulk_formula = 3 - else ! Defualt: Ncar - bulk_formula = 0 - end if - - call get_era40_fluxes(current_time, X, Y, Z, temp, Vx, Vy, Vz, sal, & - F_as, Q_as, Tau_u, Tau_v, Q_s, & - NNodes, on_sphere, bulk_formula) - - ! finally, we need to reverse-map the temporary fields on the ocean mesh - ! to the actual fields in state using remap unless - ! the continuity of the two fields does not match, in which case we project - - if (force_velocity .ge. 0) then - do i=1,NNodes + end do + end if + + call get_option("/timestepping/current_time", current_time) + on_sphere=have_option('/geometry/spherical_earth') + + if (have_option('/ocean_forcing/bulk_formulae/bulk_formulae/type::COARE')) then + bulk_formula = 1 + else if (have_option('/ocean_forcing/bulk_formulae/bulk_formulae/type::BVW')) then + bulk_formula = 2 + else if (have_option('/ocean_forcing/bulk_formulae/bulk_formulae/type::Kara')) then + bulk_formula = 3 + else ! Defualt: Ncar + bulk_formula = 0 + end if + + call get_era40_fluxes(current_time, X, Y, Z, temp, Vx, Vy, Vz, sal, & + F_as, Q_as, Tau_u, Tau_v, Q_s, & + NNodes, on_sphere, bulk_formula) + + ! finally, we need to reverse-map the temporary fields on the ocean mesh + ! to the actual fields in state using remap unless + ! the continuity of the two fields does not match, in which case we project + + if (force_velocity .ge. 0) then + do i=1,NNodes temp_vector_2D(1) = Tau_u(i) temp_vector_2D(2) = Tau_v(i) call set(stress_flux,i,temp_vector_2D) - end do - vector_source_field => extract_vector_field(state, 'Velocity') - vector_surface => extract_surface_field(vector_source_field, force_velocity , "WindSurfaceField") + end do + vector_source_field => extract_vector_field(state, 'Velocity') + vector_surface => extract_surface_field(vector_source_field, force_velocity , "WindSurfaceField") - ! Fluxes are calculated on the velocity mesh, so we will only ever need - ! to remap, never project as we may have to do on the other fields - call remap_field(stress_flux, vector_surface) + ! Fluxes are calculated on the velocity mesh, so we will only ever need + ! to remap, never project as we may have to do on the other fields + call remap_field(stress_flux, vector_surface) - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/vector_field::MomentumFlux")) then + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/vector_field::MomentumFlux")) then vector_source_field => extract_vector_field(state, 'MomentumFlux') ! copy the values onto the mesh using the global node id do i=1,size(surface_nodes) - call set(vector_source_field,1,surface_nodes(i),node_val(vector_surface,1,i)) + call set(vector_source_field,1,surface_nodes(i),node_val(vector_surface,1,i)) end do do i=1,size(surface_nodes) - call set(vector_source_field,2,surface_nodes(i),node_val(vector_surface,2,i)) + call set(vector_source_field,2,surface_nodes(i),node_val(vector_surface,2,i)) end do do i=1,size(surface_nodes) - call set(vector_source_field,3,surface_nodes(i),0.0) + call set(vector_source_field,3,surface_nodes(i),0.0) end do vfield => extract_vector_field(state, 'OldMomentumFlux',stat) - if (stat == 0) then - call set(vfield,vector_source_field) + if (stat == 0) then + call set(vfield,vector_source_field) end if - end if - call deallocate(stress_flux) - end if - if (force_temperature .ge. 0) then - do i=1,NNodes - call set(heat_flux,i,Q_as(i)) - end do - scalar_source_field => extract_scalar_field(state, 'Temperature') - scalar_surface => extract_surface_field(scalar_source_field, force_temperature,& - "value") - if (heat_flux%mesh%continuity .ne. scalar_surface%mesh%continuity) then + end if + call deallocate(stress_flux) + end if + if (force_temperature .ge. 0) then + do i=1,NNodes + call set(heat_flux,i,Q_as(i)) + end do + scalar_source_field => extract_scalar_field(state, 'Temperature') + scalar_surface => extract_surface_field(scalar_source_field, force_temperature,& + "value") + if (heat_flux%mesh%continuity .ne. scalar_surface%mesh%continuity) then position_remapped=get_coordinates_remapped_to_surface(p_position, & - scalar_surface%mesh, surface_element_list) + scalar_surface%mesh, surface_element_list) call project_field(heat_flux, scalar_surface, position_remapped) call deallocate(position_remapped) - else + else call remap_field(heat_flux, scalar_surface) - end if + end if - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::HeatFlux")) then + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::HeatFlux")) then scalar_source_field => extract_scalar_field(state, 'HeatFlux') ! copy the values onto the mesh using the global node id do i=1,node_count(heat_flux) - call set(scalar_source_field,surface_nodes(i),node_val(heat_flux,i)) + call set(scalar_source_field,surface_nodes(i),node_val(heat_flux,i)) end do sfield => extract_scalar_field(state, 'OldHeatFlux',stat) if (stat == 0) then - call set(sfield,scalar_source_field) + call set(sfield,scalar_source_field) end if - end if - call deallocate(heat_flux) - end if - if (force_salinity .ge. 0) then - do i=1,NNodes + end if + call deallocate(heat_flux) + end if + if (force_salinity .ge. 0) then + do i=1,NNodes call set(salinity_flux,i,F_as(i)) - end do - scalar_source_field => extract_scalar_field(state, 'Salinity') - scalar_surface => extract_surface_field(scalar_source_field, force_salinity, & - "value") - if (salinity_flux%mesh%continuity .ne. scalar_surface%mesh%continuity) then + end do + scalar_source_field => extract_scalar_field(state, 'Salinity') + scalar_surface => extract_surface_field(scalar_source_field, force_salinity, & + "value") + if (salinity_flux%mesh%continuity .ne. scalar_surface%mesh%continuity) then call allocate(position_remapped, p_position%dim, scalar_surface%mesh, "Remapped_pos") call remap_field_to_surface(p_position, position_remapped, & - surface_element_list) + surface_element_list) call project_field(salinity_flux, scalar_surface, position_remapped) call deallocate(position_remapped) - else + else call remap_field(salinity_flux, scalar_surface) - end if + end if - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::SalinityFlux")) then + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::SalinityFlux")) then scalar_source_field => extract_scalar_field(state, 'SalinityFlux') ! copy the values onto the mesh using the global node id do i=1,node_count(salinity_flux) - call set(scalar_source_field,surface_nodes(i),node_val(salinity_flux,i)) + call set(scalar_source_field,surface_nodes(i),node_val(salinity_flux,i)) end do sfield => extract_scalar_field(state, 'OldSalinityFlux',stat) if (stat == 0) then - call set(sfield,scalar_source_field) + call set(sfield,scalar_source_field) end if - end if - call deallocate(salinity_flux) - end if - if (force_solar .ge. 0) then - do i=1,NNodes + end if + call deallocate(salinity_flux) + end if + if (force_solar .ge. 0) then + do i=1,NNodes call set(solar_flux,i,Q_s(i)) - end do - scalar_source_field => extract_scalar_field(state, 'PhotosyntheticRadiation') - scalar_surface => extract_surface_field(scalar_source_field, force_solar ,& - "value") - if (solar_flux%mesh%continuity .ne. scalar_surface%mesh%continuity) then + end do + scalar_source_field => extract_scalar_field(state, 'PhotosyntheticRadiation') + scalar_surface => extract_surface_field(scalar_source_field, force_solar ,& + "value") + if (solar_flux%mesh%continuity .ne. scalar_surface%mesh%continuity) then call allocate(position_remapped, p_position%dim, scalar_surface%mesh, "Remapped_pos") call remap_field_to_surface(p_position, position_remapped, & - surface_element_list) + surface_element_list) call project_field(solar_flux, scalar_surface, position_remapped) call deallocate(position_remapped) - else + else call remap_field(solar_flux, scalar_surface) - end if + end if - if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::PhotosyntheticRadiationDownward")) then + if (have_option("/ocean_forcing/bulk_formulae/output_fluxes_diagnostics/scalar_field::PhotosyntheticRadiationDownward")) then scalar_source_field => extract_scalar_field(state, 'PhotosyntheticRadiationDownward') ! copy the values onto the mesh using the global node id do i=1,node_count(solar_flux) - call set(scalar_source_field,surface_nodes(i),node_val(solar_flux,i)) + call set(scalar_source_field,surface_nodes(i),node_val(solar_flux,i)) end do sfield => extract_scalar_field(state, 'OldPhotosyntheticRadiationDownward',stat) if (stat == 0) then - call set(sfield,scalar_source_field) + call set(sfield,scalar_source_field) end if - end if - call deallocate(solar_flux) - end if - - call deallocate(temperature) - call deallocate(salinity) - call deallocate(velocity) - call deallocate(position) - call deallocate(ocean_mesh) - deallocate(temp) - deallocate(sal) - deallocate(X) - deallocate(Y) - deallocate(Z) - deallocate(Vx) - deallocate(Vy) - deallocate(Vz) - deallocate(F_as) - deallocate(Q_as) - deallocate(Q_s) - deallocate(Tau_u) - deallocate(Tau_v) - - end subroutine set_ocean_forcings_boundary_conditions - - subroutine set_dirichlet_turbine_boundary_conditions(state) - type(state_type), intent(in) :: state - type(vector_field), pointer :: vel_field, coord_field - type(vector_field), pointer :: surface_field - type(vector_field) :: bc_positions - type(scalar_field) :: surface_field_normal - type(scalar_field), pointer :: fs_field - - integer :: notur, i, j,ele, stat - character(len=FIELD_NAME_LEN) :: turbine_path - character(len=FIELD_NAME_LEN), dimension(2) :: bc_name - character(len=PYTHON_FUNC_LEN) :: func - real, dimension(3) :: picker - real,dimension(:),allocatable :: local_coord - real, dimension(2) :: fs_val, surface_area - real :: flux - integer, dimension(:), pointer :: surface_element_list - real :: time - logical :: have_fs - ewrite(1,*) "In dirichlet turbine model" - - have_fs=.False. - ! We made sure in populate_boundary_conditions that FreeSurface exists. - vel_field => extract_vector_field(state, "Velocity") - fs_field => extract_scalar_field(state, "FreeSurface", stat) - if(stat==0) have_fs = .True. - coord_field => extract_vector_field(state, "Coordinate") - allocate(local_coord(coord_field%dim+1)) - - ! loop through turbines - notur = option_count("/turbine_model/turbine") - do i=0, notur-1 - turbine_path="/turbine_model/turbine["//int2str(i)//"]" - if (.not. have_option(trim(turbine_path)//"/dirichlet")) cycle - ! We need a FreeSurface field for the dirchlet turbine model. - if (.not. have_fs) FLExit("Turbine error: No FreeSurface field found.") - do j=1,2 - call get_option(trim(turbine_path)//"/dirichlet/boundary_condition_name_"//int2str(j)//"/name", bc_name(j)) - end do - - call get_option("/timestepping/current_time", time) - - ! Get free surface values at the user specified points - do j=1,2 - call get_option(trim(turbine_path)//"/dirichlet/free_surface_point_"//int2str(j), picker(1:coord_field%dim)) - if (coord_field%dim==1) then - call picker_inquire(coord_field, coordx=picker(1), ele=ele, local_coord=local_coord, global=.true.) - elseif (coord_field%dim==2) then - call picker_inquire(coord_field, coordx=picker(1), coordy=picker(2), ele=ele, local_coord=local_coord, global=.true.) - elseif (coord_field%dim==3) then - call picker_inquire(coord_field, picker(1), picker(2), picker(3), ele, local_coord, global=.true.) end if - if (ele<0) then - FLExit("Turbine error: The point defined in "//trim(turbine_path)//"/free_surface_point_"//int2str(j)//" is not located in a mesh element") + call deallocate(solar_flux) + end if + + call deallocate(temperature) + call deallocate(salinity) + call deallocate(velocity) + call deallocate(position) + call deallocate(ocean_mesh) + deallocate(temp) + deallocate(sal) + deallocate(X) + deallocate(Y) + deallocate(Z) + deallocate(Vx) + deallocate(Vy) + deallocate(Vz) + deallocate(F_as) + deallocate(Q_as) + deallocate(Q_s) + deallocate(Tau_u) + deallocate(Tau_v) + + end subroutine set_ocean_forcings_boundary_conditions + + subroutine set_dirichlet_turbine_boundary_conditions(state) + type(state_type), intent(in) :: state + type(vector_field), pointer :: vel_field, coord_field + type(vector_field), pointer :: surface_field + type(vector_field) :: bc_positions + type(scalar_field) :: surface_field_normal + type(scalar_field), pointer :: fs_field + + integer :: notur, i, j,ele, stat + character(len=FIELD_NAME_LEN) :: turbine_path + character(len=FIELD_NAME_LEN), dimension(2) :: bc_name + character(len=PYTHON_FUNC_LEN) :: func + real, dimension(3) :: picker + real,dimension(:),allocatable :: local_coord + real, dimension(2) :: fs_val, surface_area + real :: flux + integer, dimension(:), pointer :: surface_element_list + real :: time + logical :: have_fs + ewrite(1,*) "In dirichlet turbine model" + + have_fs=.False. + ! We made sure in populate_boundary_conditions that FreeSurface exists. + vel_field => extract_vector_field(state, "Velocity") + fs_field => extract_scalar_field(state, "FreeSurface", stat) + if(stat==0) have_fs = .True. + coord_field => extract_vector_field(state, "Coordinate") + allocate(local_coord(coord_field%dim+1)) + + ! loop through turbines + notur = option_count("/turbine_model/turbine") + do i=0, notur-1 + turbine_path="/turbine_model/turbine["//int2str(i)//"]" + if (.not. have_option(trim(turbine_path)//"/dirichlet")) cycle + ! We need a FreeSurface field for the dirchlet turbine model. + if (.not. have_fs) FLExit("Turbine error: No FreeSurface field found.") + do j=1,2 + call get_option(trim(turbine_path)//"/dirichlet/boundary_condition_name_"//int2str(j)//"/name", bc_name(j)) + end do + + call get_option("/timestepping/current_time", time) + + ! Get free surface values at the user specified points + do j=1,2 + call get_option(trim(turbine_path)//"/dirichlet/free_surface_point_"//int2str(j), picker(1:coord_field%dim)) + if (coord_field%dim==1) then + call picker_inquire(coord_field, coordx=picker(1), ele=ele, local_coord=local_coord, global=.true.) + elseif (coord_field%dim==2) then + call picker_inquire(coord_field, coordx=picker(1), coordy=picker(2), ele=ele, local_coord=local_coord, global=.true.) + elseif (coord_field%dim==3) then + call picker_inquire(coord_field, picker(1), picker(2), picker(3), ele, local_coord, global=.true.) + end if + if (ele<0) then + FLExit("Turbine error: The point defined in "//trim(turbine_path)//"/free_surface_point_"//int2str(j)//" is not located in a mesh element") + end if + fs_val(j) = eval_field(ele, fs_field, local_coord) + end do + ! Function head -> outflow + call get_option(trim(turbine_path)//"/dirichlet/head_flux", func) + call real_from_python(func, fs_val(1)-fs_val(2), flux) + + ! Get surface areas of the boundaries + ! This could be done only once if no free surface mesh movement is performed. + do j=1,2 + surface_field => extract_surface_field(vel_field, bc_name(j), name="value") + call get_boundary_condition(vel_field, bc_name(j), surface_element_list=surface_element_list) + ! Map the coord_field field to the surface mesh + call allocate(bc_positions, coord_field%dim, surface_field%mesh) + call remap_field_to_surface(coord_field, bc_positions, surface_element_list) + surface_area(j)=get_surface_area(bc_positions) + call deallocate(bc_positions) + end do + + ! Overwrite the normal component of the dichilet boundaries + do j=1,2 + surface_field => extract_surface_field(vel_field, bc_name(j), name="value") + ! Extract the scalar normal component + surface_field_normal = extract_scalar_field(surface_field, 1) + ! speed = outflow/area + ewrite(3,*) "Surface area of boundary ", trim(bc_name(j)), ": ", surface_area(j) + ewrite(3,*) "Setting normal flow speed at boundary ", trim(bc_name(j)), " to: ", flux/surface_area(j) + call set(surface_field_normal, (-1)**(j+1)*flux/surface_area(j)) + end do + end do + ! Tidying up + deallocate(local_coord) + ewrite(3,*) "Out dirichlet turbine model." + + contains + ! Calculates the surface area by integrating the unit function over the domain defined by "positions" + function get_surface_area(positions) result(surface_area) + type(vector_field), intent(in) :: positions + integer :: i + real :: surface_area + real, dimension(1:ele_ngi(positions%mesh,1)):: detwei + + surface_area=0.0 + do i=1, element_count(positions) + call transform_to_physical(positions, i, detwei) + surface_area=surface_area+sum(detwei) + end do + end function get_surface_area + + end subroutine set_dirichlet_turbine_boundary_conditions + + subroutine set_flux_turbine_boundary_conditions(state) + type(state_type), intent(in) :: state + type(vector_field), pointer :: vel_field, coord_field, surface_field + type(scalar_field) :: scalar_surface_field + + integer :: notur, i, j + character(len=FIELD_NAME_LEN) :: turbine_path, turbine_type + character(len=FIELD_NAME_LEN), dimension(2) :: bc_name + character(len=PYTHON_FUNC_LEN) :: func + real :: flux, h + logical :: active + + ewrite(1,*) "In flux turbine model" + vel_field => extract_vector_field(state, "Velocity") + coord_field => extract_vector_field(state, "Coordinate") + + ! loop through turbines + notur = option_count("/turbine_model/turbine") + do i=0, notur-1 + turbine_path="/turbine_model/turbine["//int2str(i)//"]" + if (.not. have_option(trim(turbine_path)//"/flux")) cycle + if (have_option(trim(turbine_path)//"/flux/penalty")) then + turbine_type="penalty" + else + turbine_type="dg" end if - fs_val(j) = eval_field(ele, fs_field, local_coord) - end do - ! Function head -> outflow - call get_option(trim(turbine_path)//"/dirichlet/head_flux", func) - call real_from_python(func, fs_val(1)-fs_val(2), flux) - - ! Get surface areas of the boundaries - ! This could be done only once if no free surface mesh movement is performed. - do j=1,2 - surface_field => extract_surface_field(vel_field, bc_name(j), name="value") - call get_boundary_condition(vel_field, bc_name(j), surface_element_list=surface_element_list) - ! Map the coord_field field to the surface mesh - call allocate(bc_positions, coord_field%dim, surface_field%mesh) - call remap_field_to_surface(coord_field, bc_positions, surface_element_list) - surface_area(j)=get_surface_area(bc_positions) - call deallocate(bc_positions) - end do - - ! Overwrite the normal component of the dichilet boundaries - do j=1,2 - surface_field => extract_surface_field(vel_field, bc_name(j), name="value") - ! Extract the scalar normal component - surface_field_normal = extract_scalar_field(surface_field, 1) - ! speed = outflow/area - ewrite(3,*) "Surface area of boundary ", trim(bc_name(j)), ": ", surface_area(j) - ewrite(3,*) "Setting normal flow speed at boundary ", trim(bc_name(j)), " to: ", flux/surface_area(j) - call set(surface_field_normal, (-1)**(j+1)*flux/surface_area(j)) - end do - end do - ! Tidying up - deallocate(local_coord) - ewrite(3,*) "Out dirichlet turbine model." - - contains - ! Calculates the surface area by integrating the unit function over the domain defined by "positions" - function get_surface_area(positions) result(surface_area) - type(vector_field), intent(in) :: positions - integer :: i - real :: surface_area - real, dimension(1:ele_ngi(positions%mesh,1)):: detwei - - surface_area=0.0 - do i=1, element_count(positions) - call transform_to_physical(positions, i, detwei) - surface_area=surface_area+sum(detwei) - end do - end function get_surface_area - - end subroutine set_dirichlet_turbine_boundary_conditions - - subroutine set_flux_turbine_boundary_conditions(state) - type(state_type), intent(in) :: state - type(vector_field), pointer :: vel_field, coord_field, surface_field - type(scalar_field) :: scalar_surface_field - - integer :: notur, i, j - character(len=FIELD_NAME_LEN) :: turbine_path, turbine_type - character(len=FIELD_NAME_LEN), dimension(2) :: bc_name - character(len=PYTHON_FUNC_LEN) :: func - real :: flux, h - logical :: active - - ewrite(1,*) "In flux turbine model" - vel_field => extract_vector_field(state, "Velocity") - coord_field => extract_vector_field(state, "Coordinate") - - ! loop through turbines - notur = option_count("/turbine_model/turbine") - do i=0, notur-1 - turbine_path="/turbine_model/turbine["//int2str(i)//"]" - if (.not. have_option(trim(turbine_path)//"/flux")) cycle - if (have_option(trim(turbine_path)//"/flux/penalty")) then - turbine_type="penalty" - else - turbine_type="dg" - end if - do j=1,2 - call get_option(trim(turbine_path)//"/flux/boundary_condition_name_"//int2str(j)//"/name", bc_name(j)) - end do - ! TODO: Set h to pressure jump or free surface jump? - h=1.0 - call get_option(trim(turbine_path)//"/flux/"//trim(turbine_type)//"/factor", func) - call real_from_python(func, h, flux) - - ! Set the turbine dg fluxes - do j=1,2 - surface_field => extract_surface_field(vel_field, trim(bc_name(j))//"_turbine", name="value") - scalar_surface_field = extract_scalar_field(surface_field, 1) - !scalar_surface_field => extract_scalar_surface_field(vel_field, trim(bc_name(j))//"_dgflux", name="value") - call set(scalar_surface_field, flux) - end do - - ! Decide if turbine is active or not - if (have_option(trim(turbine_path)//"/flux/always_on")) then - active=.true. - elseif (have_option(trim(turbine_path)//"/flux/always_off")) then - active=.false. - end if - - ! De/Activate the Dirichlet conditions and turbine boundary condition by changing their "applied" flag - if (active) then do j=1,2 - call set_boundary_condition_applies_flag(vel_field, trim(bc_name(j))//"_turbine", (/.true., .true., .true./)) - call set_boundary_condition_applies_flag(vel_field, trim(bc_name(j)), (/.false., .false., .false./)) + call get_option(trim(turbine_path)//"/flux/boundary_condition_name_"//int2str(j)//"/name", bc_name(j)) end do - else + ! TODO: Set h to pressure jump or free surface jump? + h=1.0 + call get_option(trim(turbine_path)//"/flux/"//trim(turbine_type)//"/factor", func) + call real_from_python(func, h, flux) + + ! Set the turbine dg fluxes do j=1,2 - call set_boundary_condition_applies_flag(vel_field, trim(bc_name(j))//"_turbine", (/.false., .false., .false./)) - call set_boundary_condition_applies_flag_from_options_path(vel_field, trim(bc_name(j))) + surface_field => extract_surface_field(vel_field, trim(bc_name(j))//"_turbine", name="value") + scalar_surface_field = extract_scalar_field(surface_field, 1) + !scalar_surface_field => extract_scalar_surface_field(vel_field, trim(bc_name(j))//"_dgflux", name="value") + call set(scalar_surface_field, flux) end do - end if - end do - ewrite(3,*) "Out flux turbine model." + + ! Decide if turbine is active or not + if (have_option(trim(turbine_path)//"/flux/always_on")) then + active=.true. + elseif (have_option(trim(turbine_path)//"/flux/always_off")) then + active=.false. + end if + + ! De/Activate the Dirichlet conditions and turbine boundary condition by changing their "applied" flag + if (active) then + do j=1,2 + call set_boundary_condition_applies_flag(vel_field, trim(bc_name(j))//"_turbine", (/.true., .true., .true./)) + call set_boundary_condition_applies_flag(vel_field, trim(bc_name(j)), (/.false., .false., .false./)) + end do + else + do j=1,2 + call set_boundary_condition_applies_flag(vel_field, trim(bc_name(j))//"_turbine", (/.false., .false., .false./)) + call set_boundary_condition_applies_flag_from_options_path(vel_field, trim(bc_name(j))) + end do + end if + end do + ewrite(3,*) "Out flux turbine model." contains - subroutine set_boundary_condition_applies_flag(field, name, applies) - type(vector_field), intent(in):: field - ! Name of the boundary condition - character(len=*), intent(in):: name - logical, dimension(3):: applies - integer i - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then + subroutine set_boundary_condition_applies_flag(field, name, applies) + type(vector_field), intent(in):: field + ! Name of the boundary condition + character(len=*), intent(in):: name + logical, dimension(3):: applies + integer i + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + field%bc%boundary_condition(i)%applies=applies + return + end if + end do + FLExit("Internal Error: Field "//trim(field%name)//" does not have boundary condition of name "//trim(name)) + end subroutine set_boundary_condition_applies_flag + + ! Sets the "applies" flags according to the option path. + subroutine set_boundary_condition_applies_flag_from_options_path(field, name) + type(vector_field), intent(in):: field + ! Name of the boundary condition + character(len=*), intent(in):: name + logical, dimension(3):: applies + logical :: bc_found + integer i, j + character(len=OPTION_PATH_LEN) bc_path, bc_component_path + character(len=OPTION_PATH_LEN), dimension(3) :: components + + do i=1, size(field%bc%boundary_condition) + if (field%bc%boundary_condition(i)%name==name) then + bc_path=field%bc%boundary_condition(i)%option_path + bc_found=.true. + exit + end if + end do + if (.not. bc_found) FLExit("Internal Error: Field "//trim(field%name)//" does not have boundary condition of name "//trim(name)) + bc_path=trim(bc_path)//"/type" + if(have_option(trim(bc_path)//"/align_bc_with_cartesian")) then + bc_path=trim(bc_path)//"/align_bc_with_cartesian" + components=(/ & + "x_component", & + "y_component", & + "z_component" /) + else + bc_path=trim(bc_path)//"/align_bc_with_surface" + components=(/ & + "normal_component ", & + "tangent_component_1", & + "tangent_component_2" /) + end if + do j=1,3 + bc_component_path=trim(bc_path)//"/"//trim(components(j)) + applies(j)=have_option(trim(bc_component_path)) + end do + ! Finally set the "applies" flags field%bc%boundary_condition(i)%applies=applies - return - end if - end do - FLExit("Internal Error: Field "//trim(field%name)//" does not have boundary condition of name "//trim(name)) - end subroutine set_boundary_condition_applies_flag - - ! Sets the "applies" flags according to the option path. - subroutine set_boundary_condition_applies_flag_from_options_path(field, name) - type(vector_field), intent(in):: field - ! Name of the boundary condition - character(len=*), intent(in):: name - logical, dimension(3):: applies - logical :: bc_found - integer i, j - character(len=OPTION_PATH_LEN) bc_path, bc_component_path - character(len=OPTION_PATH_LEN), dimension(3) :: components - - do i=1, size(field%bc%boundary_condition) - if (field%bc%boundary_condition(i)%name==name) then - bc_path=field%bc%boundary_condition(i)%option_path - bc_found=.true. - exit - end if - end do - if (.not. bc_found) FLExit("Internal Error: Field "//trim(field%name)//" does not have boundary condition of name "//trim(name)) - bc_path=trim(bc_path)//"/type" - if(have_option(trim(bc_path)//"/align_bc_with_cartesian")) then - bc_path=trim(bc_path)//"/align_bc_with_cartesian" - components=(/ & - "x_component", & - "y_component", & - "z_component" /) - else - bc_path=trim(bc_path)//"/align_bc_with_surface" - components=(/ & - "normal_component ", & - "tangent_component_1", & - "tangent_component_2" /) - end if - do j=1,3 - bc_component_path=trim(bc_path)//"/"//trim(components(j)) - applies(j)=have_option(trim(bc_component_path)) - end do - ! Finally set the "applies" flags - field%bc%boundary_condition(i)%applies=applies - end subroutine set_boundary_condition_applies_flag_from_options_path - - end subroutine set_flux_turbine_boundary_conditions - - - subroutine initialise_rotated_bcs(surface_element_list, x, & - debugging_mode, normal, tangent_1, tangent_2, prescribed) - - integer, dimension(:),intent(in):: surface_element_list - ! vector fields on the surface mesh - type(vector_field),intent(inout):: normal - type(vector_field),intent(inout)::tangent_1, tangent_2 - logical, dimension(3) :: prescribed - ! positions on the entire mesh (may not be same order as surface mesh!!) - type(vector_field),intent(in) :: x - logical, intent(in):: debugging_mode - - type(vector_field) :: bc_position - - real, dimension(x%dim, face_ngi(x, 1)):: normal_bdy - real, dimension(face_ngi(x, 1)) :: detwei_bdy - real, dimension(x%dim) :: normal_av - - integer :: i, bcnod - integer :: sele - integer :: t1_max - real, dimension(x%dim) :: t1, t2, t1_norm, n - real :: proj1, det - - if(.not.all(prescribed)) then - - if(.not.prescribed(1)) then - do i=1, size(surface_element_list) - - sele = surface_element_list(i) - - call transform_facet_to_physical(x, sele, & - detwei_f=detwei_bdy, normal=normal_bdy) - - normal_av = matmul(normal_bdy, detwei_bdy) - - call addto(normal, ele_nodes(normal, i), spread(normal_av, 2, ele_loc(normal, i))) - - end do ! surface_element_list - end if + end subroutine set_boundary_condition_applies_flag_from_options_path + + end subroutine set_flux_turbine_boundary_conditions + - t1 = 0.0 - t2 = 0.0 + subroutine initialise_rotated_bcs(surface_element_list, x, & + debugging_mode, normal, tangent_1, tangent_2, prescribed) - bcnod=normal%mesh%nodes - do i=1, bcnod + integer, dimension(:),intent(in):: surface_element_list + ! vector fields on the surface mesh + type(vector_field),intent(inout):: normal + type(vector_field),intent(inout)::tangent_1, tangent_2 + logical, dimension(3) :: prescribed + ! positions on the entire mesh (may not be same order as surface mesh!!) + type(vector_field),intent(in) :: x + logical, intent(in):: debugging_mode - ! get node normal - n=node_val(normal,i) + type(vector_field) :: bc_position + + real, dimension(x%dim, face_ngi(x, 1)):: normal_bdy + real, dimension(face_ngi(x, 1)) :: detwei_bdy + real, dimension(x%dim) :: normal_av + + integer :: i, bcnod + integer :: sele + integer :: t1_max + real, dimension(x%dim) :: t1, t2, t1_norm, n + real :: proj1, det + + if(.not.all(prescribed)) then if(.not.prescribed(1)) then - ! normalise it - n=n/sqrt(sum(n**2)) + do i=1, size(surface_element_list) + + sele = surface_element_list(i) + + call transform_facet_to_physical(x, sele, & + detwei_f=detwei_bdy, normal=normal_bdy) + + normal_av = matmul(normal_bdy, detwei_bdy) - call set(normal, i, n) + call addto(normal, ele_nodes(normal, i), spread(normal_av, 2, ele_loc(normal, i))) + + end do ! surface_element_list end if - if (x%dim>1) then + t1 = 0.0 + t2 = 0.0 + + bcnod=normal%mesh%nodes + do i=1, bcnod - if(prescribed(2)) then - t1=node_val(tangent_1,i) - else - t1_max=minloc( abs(n), dim=1 ) - t1_norm=0. - t1_norm(t1_max)=1. + ! get node normal + n=node_val(normal,i) - proj1=dot_product(n, t1_norm) - t1= t1_norm - proj1 * n + if(.not.prescribed(1)) then + ! normalise it + n=n/sqrt(sum(n**2)) - ! normalise it - t1=t1/sqrt(sum(t1**2)) + call set(normal, i, n) + end if - call set( tangent_1, i, t1 ) - end if + if (x%dim>1) then - if ((x%dim>2).and.(.not.prescribed(3))) then + if(prescribed(2)) then + t1=node_val(tangent_1,i) + else + t1_max=minloc( abs(n), dim=1 ) + t1_norm=0. + t1_norm(t1_max)=1. - t2 = cross_product(n, t1) + proj1=dot_product(n, t1_norm) + t1= t1_norm - proj1 * n - call set( tangent_2, i, t2 ) + ! normalise it + t1=t1/sqrt(sum(t1**2)) - end if + call set( tangent_1, i, t1 ) + end if - endif + if ((x%dim>2).and.(.not.prescribed(3))) then - ! dump normals when debugging - if (debugging_mode) then + t2 = cross_product(n, t1) + + call set( tangent_2, i, t2 ) + + end if - det = abs( & + endif + + ! dump normals when debugging + if (debugging_mode) then + + det = abs( & n(1) * (t1(2) * t2(3) - t2(2) * t1(3) ) + & t1(1) * (t2(2) * n(3) - n(2) * t2(3) ) + & t2(1) * ( n(2) * t1(3) - t1(2) * n(3) ) ) - if ( abs( det - 1.) > 1.e-5) then - call allocate(bc_position, normal%dim, normal%mesh, "BoundaryPosition") - call remap_field_to_surface(x, bc_position, surface_element_list) - call vtk_write_fields( "normals", 0, bc_position, bc_position%mesh, & - vfields=(/ normal, tangent_1, tangent_2/)) - call deallocate(bc_position) - ewrite(-1,*) "rotation matrix determinant", det - FLAbort("rotation matrix is messed up, rotated bcs have exploded...") + if ( abs( det - 1.) > 1.e-5) then + call allocate(bc_position, normal%dim, normal%mesh, "BoundaryPosition") + call remap_field_to_surface(x, bc_position, surface_element_list) + call vtk_write_fields( "normals", 0, bc_position, bc_position%mesh, & + vfields=(/ normal, tangent_1, tangent_2/)) + call deallocate(bc_position) + ewrite(-1,*) "rotation matrix determinant", det + FLAbort("rotation matrix is messed up, rotated bcs have exploded...") + end if end if - end if - end do ! bcnod - - end if - - ! dump normals when debugging - if (debugging_mode) then - bc_position = get_coordinates_remapped_to_surface(x, normal%mesh, surface_element_list) - call vtk_write_fields( "normals", 0, bc_position, bc_position%mesh, & - vfields=(/ normal, tangent_1, tangent_2/)) - call deallocate(bc_position) - end if - - end subroutine initialise_rotated_bcs - - subroutine populate_gls_boundary_conditions(state) - type(state_type), intent(in) :: state - - integer, dimension(:), pointer :: surface_element_list - type(scalar_field) :: scalar_surface_field - type(vector_field), pointer :: position - type(scalar_field), pointer :: tke, psi, scalar_surface - type(mesh_type), pointer :: surface_mesh - character(len=FIELD_NAME_LEN) :: bc_type - integer, dimension(:), allocatable :: surface_ids - integer, dimension(2) :: shape_option - integer :: stat - real :: k_min - - ewrite(1,*) "Initialising GLS stable boundaries" - - position => extract_vector_field(state, "Coordinate") - tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy",stat) - if(stat/=0) FLExit("Need GLSTurbulentKineticEnergy field") - psi => extract_scalar_field(state, "GLSGenericSecondQuantity",stat) - if(stat/=0) FLExit("Need GLSGenericSecondQuantity field") - - ! Get vector of surface ids - shape_option=option_shape("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/top_surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/top_surface_ids", surface_ids) - - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/", bc_type) - - ! Add boundary condition - call add_boundary_condition(tke, 'tke_top_boundary', bc_type, surface_ids) - call add_boundary_condition(psi, 'psi_top_boundary', bc_type, surface_ids) - deallocate(surface_ids) - - ! mesh of only the part of the surface where this b.c. applies - call get_boundary_condition(tke, 'tke_top_boundary', surface_mesh=surface_mesh, & - surface_element_list=surface_element_list) - - call get_boundary_condition(tke, 'tke_top_boundary', surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="value") - call insert_surface_field(tke, 'tke_top_boundary', scalar_surface_field) - call deallocate(scalar_surface_field) - - call get_boundary_condition(psi, 'psi_top_boundary', surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="value") - call insert_surface_field(psi, 'psi_top_boundary', scalar_surface_field) - call deallocate(scalar_surface_field) - - ! Bottom boundary on tke and psi - ! Get vector of surface ids - shape_option=option_shape("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/bottom_surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/bottom_surface_ids", surface_ids) - - ! Add boundary condition - call add_boundary_condition(tke, 'tke_bottom_boundary', bc_type, surface_ids) - call add_boundary_condition(psi, 'psi_bottom_boundary', bc_type, surface_ids) - deallocate(surface_ids) - - ! mesh of only the part of the surface where this b.c. applies - call get_boundary_condition(tke, 'tke_bottom_boundary', surface_mesh=surface_mesh) - call get_boundary_condition(tke, 'tke_bottom_boundary', surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="value") - call insert_surface_field(tke, 'tke_bottom_boundary', scalar_surface_field) - call deallocate(scalar_surface_field) - - call get_boundary_condition(psi, 'psi_bottom_boundary', surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="value") - call insert_surface_field(psi, 'psi_bottom_boundary', scalar_surface_field) - call deallocate(scalar_surface_field) - - if (trim(bc_type) .eq. 'dirichlet') then - ! The dirichlet BCs are called before we get chance to set the - ! value to something sensible, so set them to the tke_min - ! and 0 for Psi - call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/& - &scalar_field::GLSTurbulentKineticEnergy/prognostic/minimum_value", k_min) - scalar_surface => extract_surface_field(tke, 'tke_bottom_boundary', "value") - call set(scalar_surface,k_min) - scalar_surface => extract_surface_field(tke, 'tke_top_boundary', "value") - call set(scalar_surface,k_min) - scalar_surface => extract_surface_field(psi, 'psi_bottom_boundary', "value") - call set(scalar_surface,0.0) - scalar_surface => extract_surface_field(psi, 'psi_top_boundary', "value") - call set(scalar_surface,0.0) - end if - - end subroutine populate_gls_boundary_conditions - - subroutine populate_iceshelf_boundary_conditions(state) - type(state_type), intent(in) :: state - type(scalar_field), pointer :: T,S - character(len=FIELD_NAME_LEN) :: bc_type - integer, dimension(:), allocatable :: surf_id - integer, dimension(2) :: shape_option - type(integer_set) :: surface_ids - !! - type(mesh_type), pointer :: surface_mesh - type(scalar_field) :: scalar_surface_field - - ewrite(1,*) "-----*** Begin iceshelf BC-----" - ! Get vector of surface ids - shape_option=option_shape("/ocean_forcing/iceshelf_meltrate/Holland08/melt_surfaceID") - allocate(surf_id(1:shape_option(1))) - call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/melt_surfaceID", surf_id) - ewrite(1,*) "surf_id", surf_id - call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries", bc_type) - call allocate(surface_ids) - call insert(surface_ids,surf_id) - ewrite(1,*) "set2vector(surface_ids)", set2vector(surface_ids) - - ewrite(1,*) "bc_type: ", bc_type - ! Add boundary condition - T => extract_scalar_field(state,"Temperature") - S => extract_scalar_field(state,"Salinity") + end do ! bcnod + + end if + + ! dump normals when debugging + if (debugging_mode) then + bc_position = get_coordinates_remapped_to_surface(x, normal%mesh, surface_element_list) + call vtk_write_fields( "normals", 0, bc_position, bc_position%mesh, & + vfields=(/ normal, tangent_1, tangent_2/)) + call deallocate(bc_position) + end if + + end subroutine initialise_rotated_bcs + + subroutine populate_gls_boundary_conditions(state) + type(state_type), intent(in) :: state + + integer, dimension(:), pointer :: surface_element_list + type(scalar_field) :: scalar_surface_field + type(vector_field), pointer :: position + type(scalar_field), pointer :: tke, psi, scalar_surface + type(mesh_type), pointer :: surface_mesh + character(len=FIELD_NAME_LEN) :: bc_type + integer, dimension(:), allocatable :: surface_ids + integer, dimension(2) :: shape_option + integer :: stat + real :: k_min + + ewrite(1,*) "Initialising GLS stable boundaries" + + position => extract_vector_field(state, "Coordinate") + tke => extract_scalar_field(state, "GLSTurbulentKineticEnergy",stat) + if(stat/=0) FLExit("Need GLSTurbulentKineticEnergy field") + psi => extract_scalar_field(state, "GLSGenericSecondQuantity",stat) + if(stat/=0) FLExit("Need GLSGenericSecondQuantity field") + + ! Get vector of surface ids + shape_option=option_shape("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/top_surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/top_surface_ids", surface_ids) + + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/", bc_type) + + ! Add boundary condition + call add_boundary_condition(tke, 'tke_top_boundary', bc_type, surface_ids) + call add_boundary_condition(psi, 'psi_top_boundary', bc_type, surface_ids) + deallocate(surface_ids) + + ! mesh of only the part of the surface where this b.c. applies + call get_boundary_condition(tke, 'tke_top_boundary', surface_mesh=surface_mesh, & + surface_element_list=surface_element_list) + + call get_boundary_condition(tke, 'tke_top_boundary', surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="value") + call insert_surface_field(tke, 'tke_top_boundary', scalar_surface_field) + call deallocate(scalar_surface_field) + + call get_boundary_condition(psi, 'psi_top_boundary', surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="value") + call insert_surface_field(psi, 'psi_top_boundary', scalar_surface_field) + call deallocate(scalar_surface_field) + + ! Bottom boundary on tke and psi + ! Get vector of surface ids + shape_option=option_shape("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/bottom_surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/calculate_boundaries/bottom_surface_ids", surface_ids) + + ! Add boundary condition + call add_boundary_condition(tke, 'tke_bottom_boundary', bc_type, surface_ids) + call add_boundary_condition(psi, 'psi_bottom_boundary', bc_type, surface_ids) + deallocate(surface_ids) + + ! mesh of only the part of the surface where this b.c. applies + call get_boundary_condition(tke, 'tke_bottom_boundary', surface_mesh=surface_mesh) + call get_boundary_condition(tke, 'tke_bottom_boundary', surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="value") + call insert_surface_field(tke, 'tke_bottom_boundary', scalar_surface_field) + call deallocate(scalar_surface_field) + + call get_boundary_condition(psi, 'psi_bottom_boundary', surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="value") + call insert_surface_field(psi, 'psi_bottom_boundary', scalar_surface_field) + call deallocate(scalar_surface_field) + + if (trim(bc_type) .eq. 'dirichlet') then + ! The dirichlet BCs are called before we get chance to set the + ! value to something sensible, so set them to the tke_min + ! and 0 for Psi + call get_option("/material_phase[0]/subgridscale_parameterisations/GLS/& + &scalar_field::GLSTurbulentKineticEnergy/prognostic/minimum_value", k_min) + scalar_surface => extract_surface_field(tke, 'tke_bottom_boundary', "value") + call set(scalar_surface,k_min) + scalar_surface => extract_surface_field(tke, 'tke_top_boundary', "value") + call set(scalar_surface,k_min) + scalar_surface => extract_surface_field(psi, 'psi_bottom_boundary', "value") + call set(scalar_surface,0.0) + scalar_surface => extract_surface_field(psi, 'psi_top_boundary', "value") + call set(scalar_surface,0.0) + end if + + end subroutine populate_gls_boundary_conditions + + subroutine populate_iceshelf_boundary_conditions(state) + type(state_type), intent(in) :: state + type(scalar_field), pointer :: T,S + character(len=FIELD_NAME_LEN) :: bc_type + integer, dimension(:), allocatable :: surf_id + integer, dimension(2) :: shape_option + type(integer_set) :: surface_ids + !! + type(mesh_type), pointer :: surface_mesh + type(scalar_field) :: scalar_surface_field + + ewrite(1,*) "-----*** Begin iceshelf BC-----" + ! Get vector of surface ids + shape_option=option_shape("/ocean_forcing/iceshelf_meltrate/Holland08/melt_surfaceID") + allocate(surf_id(1:shape_option(1))) + call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/melt_surfaceID", surf_id) + ewrite(1,*) "surf_id", surf_id + call get_option("/ocean_forcing/iceshelf_meltrate/Holland08/calculate_boundaries", bc_type) + call allocate(surface_ids) + call insert(surface_ids,surf_id) + ewrite(1,*) "set2vector(surface_ids)", set2vector(surface_ids) + + ewrite(1,*) "bc_type: ", bc_type + ! Add boundary condition + T => extract_scalar_field(state,"Temperature") + S => extract_scalar_field(state,"Salinity") ! do i=1,node_count(T) ! ewrite(1,*) "line2100,i,node_val(T,i): ",i, node_val(T,i) ! enddo - call add_boundary_condition(T, 'temperature_iceshelf_BC', bc_type, surf_id) - call add_boundary_condition(S, 'salinity_iceshelf_BC', bc_type, surf_id) - deallocate(surf_id) + call add_boundary_condition(T, 'temperature_iceshelf_BC', bc_type, surf_id) + call add_boundary_condition(S, 'salinity_iceshelf_BC', bc_type, surf_id) + deallocate(surf_id) - ! mesh of only the part of the surface where this b.c. applies for temperature - call get_boundary_condition(T, 'temperature_iceshelf_BC', surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="value") - call insert_surface_field(T, 'temperature_iceshelf_BC', scalar_surface_field) - call deallocate(scalar_surface_field) + ! mesh of only the part of the surface where this b.c. applies for temperature + call get_boundary_condition(T, 'temperature_iceshelf_BC', surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="value") + call insert_surface_field(T, 'temperature_iceshelf_BC', scalar_surface_field) + call deallocate(scalar_surface_field) - ! mesh of only the part of the surface where this b.c. applies for salinity - call get_boundary_condition(S, 'salinity_iceshelf_BC', surface_mesh=surface_mesh) - call allocate(scalar_surface_field, surface_mesh, name="value") - call insert_surface_field(S, 'salinity_iceshelf_BC', scalar_surface_field) - call deallocate(scalar_surface_field) + ! mesh of only the part of the surface where this b.c. applies for salinity + call get_boundary_condition(S, 'salinity_iceshelf_BC', surface_mesh=surface_mesh) + call allocate(scalar_surface_field, surface_mesh, name="value") + call insert_surface_field(S, 'salinity_iceshelf_BC', scalar_surface_field) + call deallocate(scalar_surface_field) - ewrite(1,*) "-----*** End iceshelf BC-----" - end subroutine populate_iceshelf_boundary_conditions + ewrite(1,*) "-----*** End iceshelf BC-----" + end subroutine populate_iceshelf_boundary_conditions - subroutine populate_flux_turbine_boundary_conditions(state) - type(state_type), intent(in) :: state + subroutine populate_flux_turbine_boundary_conditions(state) + type(state_type), intent(in) :: state - type(vector_field), pointer :: velocity - character(len=OPTION_PATH_LEN) :: bc_path_i - character(len=FIELD_NAME_LEN) :: bc_name_ij, turbine_type - integer :: i, j, nbtur + type(vector_field), pointer :: velocity + character(len=OPTION_PATH_LEN) :: bc_path_i + character(len=FIELD_NAME_LEN) :: bc_name_ij, turbine_type + integer :: i, j, nbtur - ewrite(1,*) "Populate flux turbine boundaries" - velocity => extract_vector_field(state, "Velocity") - nbtur=option_count("/turbine_model/turbine") + ewrite(1,*) "Populate flux turbine boundaries" + velocity => extract_vector_field(state, "Velocity") + nbtur=option_count("/turbine_model/turbine") + + do i=0, nbtur-1 + bc_path_i="/turbine_model/turbine["//int2str(i)//"]" + if (.not. have_option(trim(bc_path_i)//"/flux")) cycle + if (have_option(trim(bc_path_i)//"/flux/penalty")) then + turbine_type="penalty" + else + turbine_type="dg" + end if + do j=1,2 + call get_option(trim(bc_path_i)//"/flux/boundary_condition_name_"//int2str(j)//"/name", bc_name_ij) + call insert_flux_turbine_boundary_condition(velocity, bc_name_ij, turbine_type) + end do + end do + + contains + subroutine insert_flux_turbine_boundary_condition(field, bc_name, turbine_type) + character(len=FIELD_NAME_LEN), intent(in) :: bc_name + type(vector_field), pointer :: field + integer, dimension(:), allocatable:: surface_ids + character(len=FIELD_NAME_LEN) :: bc_type, turbine_type ! turbine type is either "dg" or "penalty" + character(len=OPTION_PATH_LEN) :: option_path + integer, dimension(2) :: shape_option + !type(scalar_field) :: scalar_surface_field + type(vector_field) :: surface_field + type(mesh_type), pointer :: surface_mesh + + bc_type="turbine_flux_"//trim(turbine_type) + call get_boundary_condition(field, bc_name, option_path=option_path) + shape_option=option_shape(trim(option_path)//"/surface_ids") + allocate(surface_ids(1:shape_option(1))) + call get_option(trim(option_path)//"/surface_ids", surface_ids) + call add_boundary_condition(velocity, trim(bc_name)//"_turbine", bc_type, surface_ids) + deallocate(surface_ids) + + call get_boundary_condition(field, trim(bc_name)//"_turbine", surface_mesh=surface_mesh) + call allocate(surface_field, field%dim, surface_mesh, name="value") + call insert_surface_field(field, trim(bc_name)//"_turbine", surface_field) + call deallocate(surface_field) + !call allocate(scalar_surface_field, surface_mesh, name="value") + !call insert_surface_field(field, trim(bc_name)//"_flux", scalar_surface_field) + !call deallocate(scalar_surface_field) + end subroutine insert_flux_turbine_boundary_condition + end subroutine populate_flux_turbine_boundary_conditions + + subroutine impose_reference_pressure_node(cmc_m, rhs, positions, option_path) + !!< If there are only Neumann boundaries on P, it is necessary to pin + !!< the value of the pressure at one point. As the rhs of the equation + !!< needs to be zeroed for this node, you will have to call this for + !!< both pressure equations. + type(csr_matrix), intent(inout) :: cmc_m + type(scalar_field), intent(inout):: rhs + type(vector_field), intent(inout) :: positions + character(len=*), intent(in) :: option_path + + integer :: stat, stat2 + integer :: reference_node + + logical :: apply_reference_node, apply_reference_node_from_coordinates, reference_node_owned + + apply_reference_node = have_option(trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_node") + apply_reference_node_from_coordinates = have_option(trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_coordinates") + + if(apply_reference_node) then + + call get_option(trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_node", reference_node, stat=stat) + + if (stat==0) then + ! all processors now have to call this routine, although only + ! process 1 sets it + ewrite(1,*) 'Imposing_reference_pressure_node at node',reference_node + call set_reference_node(cmc_m, reference_node, rhs) + end if + + elseif(apply_reference_node_from_coordinates) then + + ewrite(1,*) 'Imposing_reference_pressure_node at user-specified coordinates' + call find_reference_node_from_coordinates(positions,rhs%mesh,option_path,reference_node,reference_node_owned) + + if(IsParallel()) then + call set_reference_node(cmc_m, reference_node, rhs, reference_node_owned=reference_node_owned) + else + call set_reference_node(cmc_m, reference_node, rhs) + end if + + end if + + end subroutine impose_reference_pressure_node + + subroutine find_reference_node_from_coordinates(positions,mesh,option_path,reference_node,reference_node_owned) + !! This routine determines which element contains the reference coordinates and, + !! subsequently, which vertex is nearest to the specified coordinates. In parallel + !! simulations, we ensure that only one reference node is applied across the whole domain. + + type(vector_field), intent(inout) :: positions + ! the mesh in which to look for the refence node: + type(mesh_type), intent(in) :: mesh + character(len=*), intent(in) :: option_path + + integer, intent(inout) :: reference_node + logical, intent(inout) :: reference_node_owned + + real, dimension(:), allocatable :: reference_coordinates, local_coord + integer, dimension(:), allocatable:: ele_local_vertices + integer, dimension(:), pointer :: nodes + integer :: stat, stat2, ele, first_owned_node, total_owned_nodes, local_vertex + integer :: universal_reference_node + + allocate(reference_coordinates(positions%dim)) + + call get_option(trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_coordinates", reference_coordinates, stat=stat) + + if (stat==0) then + allocate(local_coord(ele_loc(positions,1))) + ! Determine which element contains desired coordinates: + call picker_inquire(positions, reference_coordinates, ele, local_coord=local_coord, global=.false.) + if(ele > 0) then + allocate(ele_local_vertices(ele_vertices(mesh,ele))) + ! List vertices of element incorporating desired coordinates: + ele_local_vertices = local_vertices(ele_shape(mesh,ele)) + ! Find nearest vertex: + local_vertex = maxloc(local_coord,dim=1) + ! List of nodes in element: + nodes => ele_nodes(mesh,ele) + ! Reference node: + reference_node = nodes(ele_local_vertices(local_vertex)) + deallocate(ele_local_vertices) + end if + + ! Deal with parallel issues: + if(IsParallel()) then + if(ele > 0) then + universal_reference_node = halo_universal_number(mesh%halos(1),reference_node) + else + universal_reference_node = -1 + end if + + ! Ensure that only 1 reference node is specified across all processors: + call allmax(universal_reference_node) + + if(universal_reference_node < 0) then + FLExit("Reference coordinate error: point defined in "//trim(complete_field_path(option_path, stat=stat2))//"/reference_coordinates is not located in a mesh element") + end if + + first_owned_node = halo_universal_number(mesh%halos(1),1) + total_owned_nodes = halo_nowned_nodes(mesh%halos(1)) + + ! Is the reference node on this process? + reference_node_owned = (universal_reference_node >= first_owned_node .AND. universal_reference_node < first_owned_node+total_owned_nodes) + + ! To get local node number (we shouldn't really make this assumption): + if(reference_node_owned) then + reference_node = universal_reference_node - first_owned_node + 1 + else + reference_node = 0 + end if + + else ! serial + + ! Check that this node nuber is sensible: + if(reference_node < 0 .OR. reference_node > node_count(mesh)) then + FLExit("Reference coordinate error: point defined in "//trim(complete_field_path(option_path, stat=stat2))//"/reference_coordinates is not located in a mesh element") + end if + + end if + + deallocate(local_coord) + + end if + + deallocate(reference_coordinates) + + end subroutine find_reference_node_from_coordinates + + subroutine impose_reference_velocity_node(big_m, rhs, option_path, positions) + !!< If solving the Stokes equation and there + !!< are only Neumann boundaries on u, it is necessary to pin + !!< the value of the velocity at one point. + !!< This is currently done using a big spring (unlike for pressure). + type(petsc_csr_matrix), intent(inout) :: big_m + type(vector_field), intent(inout):: rhs + character(len=*), intent(in) :: option_path + type(vector_field), intent(inout):: positions + + character(len=OPTION_PATH_LEN):: reference_node_path + integer :: reference_node, stat2 + logical, dimension(blocks(big_m, 1)) :: mask + logical :: apply_reference_node, apply_reference_node_from_coordinates, reference_node_owned + + apply_reference_node = have_option(trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_node") + apply_reference_node_from_coordinates = have_option(trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_coordinates") + + if(apply_reference_node) then + + reference_node_path=trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_node" + call get_option(reference_node_path, reference_node) + + elseif(apply_reference_node_from_coordinates) then + + ewrite(1,*) 'Imposing_reference_velocity_node at user-specified coordinates' + call find_reference_node_from_coordinates(positions,rhs%mesh,option_path,reference_node,reference_node_owned) + reference_node_path=trim(complete_field_path(option_path, stat=stat2))//& + &"/reference_coordinates" - do i=0, nbtur-1 - bc_path_i="/turbine_model/turbine["//int2str(i)//"]" - if (.not. have_option(trim(bc_path_i)//"/flux")) cycle - if (have_option(trim(bc_path_i)//"/flux/penalty")) then - turbine_type="penalty" else - turbine_type="dg" + + ! nothing to do + return + end if - do j=1,2 - call get_option(trim(bc_path_i)//"/flux/boundary_condition_name_"//int2str(j)//"/name", bc_name_ij) - call insert_flux_turbine_boundary_condition(velocity, bc_name_ij, turbine_type) - end do - end do - - contains - subroutine insert_flux_turbine_boundary_condition(field, bc_name, turbine_type) - character(len=FIELD_NAME_LEN), intent(in) :: bc_name - type(vector_field), pointer :: field - integer, dimension(:), allocatable:: surface_ids - character(len=FIELD_NAME_LEN) :: bc_type, turbine_type ! turbine type is either "dg" or "penalty" - character(len=OPTION_PATH_LEN) :: option_path - integer, dimension(2) :: shape_option - !type(scalar_field) :: scalar_surface_field - type(vector_field) :: surface_field - type(mesh_type), pointer :: surface_mesh - - bc_type="turbine_flux_"//trim(turbine_type) - call get_boundary_condition(field, bc_name, option_path=option_path) - shape_option=option_shape(trim(option_path)//"/surface_ids") - allocate(surface_ids(1:shape_option(1))) - call get_option(trim(option_path)//"/surface_ids", surface_ids) - call add_boundary_condition(velocity, trim(bc_name)//"_turbine", bc_type, surface_ids) - deallocate(surface_ids) - - call get_boundary_condition(field, trim(bc_name)//"_turbine", surface_mesh=surface_mesh) - call allocate(surface_field, field%dim, surface_mesh, name="value") - call insert_surface_field(field, trim(bc_name)//"_turbine", surface_field) - call deallocate(surface_field) - !call allocate(scalar_surface_field, surface_mesh, name="value") - !call insert_surface_field(field, trim(bc_name)//"_flux", scalar_surface_field) - !call deallocate(scalar_surface_field) - end subroutine insert_flux_turbine_boundary_condition - end subroutine populate_flux_turbine_boundary_conditions - - subroutine impose_reference_pressure_node(cmc_m, rhs, positions, option_path) - !!< If there are only Neumann boundaries on P, it is necessary to pin - !!< the value of the pressure at one point. As the rhs of the equation - !!< needs to be zeroed for this node, you will have to call this for - !!< both pressure equations. - type(csr_matrix), intent(inout) :: cmc_m - type(scalar_field), intent(inout):: rhs - type(vector_field), intent(inout) :: positions - character(len=*), intent(in) :: option_path - - integer :: stat, stat2 - integer :: reference_node - - logical :: apply_reference_node, apply_reference_node_from_coordinates, reference_node_owned - - apply_reference_node = have_option(trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_node") - apply_reference_node_from_coordinates = have_option(trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_coordinates") - - if(apply_reference_node) then - - call get_option(trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_node", reference_node, stat=stat) - - if (stat==0) then - ! all processors now have to call this routine, although only - ! process 1 sets it - ewrite(1,*) 'Imposing_reference_pressure_node at node',reference_node - call set_reference_node(cmc_m, reference_node, rhs) - end if - - elseif(apply_reference_node_from_coordinates) then - - ewrite(1,*) 'Imposing_reference_pressure_node at user-specified coordinates' - call find_reference_node_from_coordinates(positions,rhs%mesh,option_path,reference_node,reference_node_owned) - - if(IsParallel()) then - call set_reference_node(cmc_m, reference_node, rhs, reference_node_owned=reference_node_owned) - else - call set_reference_node(cmc_m, reference_node, rhs) - end if - - end if - - end subroutine impose_reference_pressure_node - - subroutine find_reference_node_from_coordinates(positions,mesh,option_path,reference_node,reference_node_owned) - !! This routine determines which element contains the reference coordinates and, - !! subsequently, which vertex is nearest to the specified coordinates. In parallel - !! simulations, we ensure that only one reference node is applied across the whole domain. - - type(vector_field), intent(inout) :: positions - ! the mesh in which to look for the refence node: - type(mesh_type), intent(in) :: mesh - character(len=*), intent(in) :: option_path - - integer, intent(inout) :: reference_node - logical, intent(inout) :: reference_node_owned - - real, dimension(:), allocatable :: reference_coordinates, local_coord - integer, dimension(:), allocatable:: ele_local_vertices - integer, dimension(:), pointer :: nodes - integer :: stat, stat2, ele, first_owned_node, total_owned_nodes, local_vertex - integer :: universal_reference_node - - allocate(reference_coordinates(positions%dim)) - - call get_option(trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_coordinates", reference_coordinates, stat=stat) - - if (stat==0) then - allocate(local_coord(ele_loc(positions,1))) - ! Determine which element contains desired coordinates: - call picker_inquire(positions, reference_coordinates, ele, local_coord=local_coord, global=.false.) - if(ele > 0) then - allocate(ele_local_vertices(ele_vertices(mesh,ele))) - ! List vertices of element incorporating desired coordinates: - ele_local_vertices = local_vertices(ele_shape(mesh,ele)) - ! Find nearest vertex: - local_vertex = maxloc(local_coord,dim=1) - ! List of nodes in element: - nodes => ele_nodes(mesh,ele) - ! Reference node: - reference_node = nodes(ele_local_vertices(local_vertex)) - deallocate(ele_local_vertices) - end if - - ! Deal with parallel issues: - if(IsParallel()) then - if(ele > 0) then - universal_reference_node = halo_universal_number(mesh%halos(1),reference_node) - else - universal_reference_node = -1 - end if - - ! Ensure that only 1 reference node is specified across all processors: - call allmax(universal_reference_node) - - if(universal_reference_node < 0) then - FLExit("Reference coordinate error: point defined in "//trim(complete_field_path(option_path, stat=stat2))//"/reference_coordinates is not located in a mesh element") - end if - - first_owned_node = halo_universal_number(mesh%halos(1),1) - total_owned_nodes = halo_nowned_nodes(mesh%halos(1)) - - ! Is the reference node on this process? - reference_node_owned = (universal_reference_node >= first_owned_node .AND. universal_reference_node < first_owned_node+total_owned_nodes) - - ! To get local node number (we shouldn't really make this assumption): - if(reference_node_owned) then - reference_node = universal_reference_node - first_owned_node + 1 - else - reference_node = 0 - end if - - else ! serial - - ! Check that this node nuber is sensible: - if(reference_node < 0 .OR. reference_node > node_count(mesh)) then - FLExit("Reference coordinate error: point defined in "//trim(complete_field_path(option_path, stat=stat2))//"/reference_coordinates is not located in a mesh element") - end if - - end if - - deallocate(local_coord) - - end if - - deallocate(reference_coordinates) - - end subroutine find_reference_node_from_coordinates - - subroutine impose_reference_velocity_node(big_m, rhs, option_path, positions) - !!< If solving the Stokes equation and there - !!< are only Neumann boundaries on u, it is necessary to pin - !!< the value of the velocity at one point. - !!< This is currently done using a big spring (unlike for pressure). - type(petsc_csr_matrix), intent(inout) :: big_m - type(vector_field), intent(inout):: rhs - character(len=*), intent(in) :: option_path - type(vector_field), intent(inout):: positions - - character(len=OPTION_PATH_LEN):: reference_node_path - integer :: reference_node, stat2 - logical, dimension(blocks(big_m, 1)) :: mask - logical :: apply_reference_node, apply_reference_node_from_coordinates, reference_node_owned - - apply_reference_node = have_option(trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_node") - apply_reference_node_from_coordinates = have_option(trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_coordinates") - - if(apply_reference_node) then - - reference_node_path=trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_node" - call get_option(reference_node_path, reference_node) - - elseif(apply_reference_node_from_coordinates) then - - ewrite(1,*) 'Imposing_reference_velocity_node at user-specified coordinates' - call find_reference_node_from_coordinates(positions,rhs%mesh,option_path,reference_node,reference_node_owned) - reference_node_path=trim(complete_field_path(option_path, stat=stat2))//& - &"/reference_coordinates" - - else - - ! nothing to do - return - - end if - - mask = .true. - if(have_option(trim(reference_node_path)//"/specify_components")) then - mask(1) = have_option(trim(reference_node_path)//"/specify_components/x_component") - if(blocks(big_m,1)>1) then - mask(2) = have_option(trim(reference_node_path)//"/specify_components/y_component") - end if - if(blocks(big_m,2)>2) then - mask(3) = have_option(trim(reference_node_path)//"/specify_components/z_component") - end if - ewrite(1,*) 'Imposing_reference_velocity_node on specified components: ', mask - else - ewrite(1,*) 'Imposing_reference_velocity_node on all components' - end if - if(IsParallel()) then - call set_reference_node(big_m, reference_node, rhs, mask, reference_node_owned=reference_node_owned) - else - call set_reference_node(big_m, reference_node, rhs, mask) - end if - - end subroutine impose_reference_velocity_node + + mask = .true. + if(have_option(trim(reference_node_path)//"/specify_components")) then + mask(1) = have_option(trim(reference_node_path)//"/specify_components/x_component") + if(blocks(big_m,1)>1) then + mask(2) = have_option(trim(reference_node_path)//"/specify_components/y_component") + end if + if(blocks(big_m,2)>2) then + mask(3) = have_option(trim(reference_node_path)//"/specify_components/z_component") + end if + ewrite(1,*) 'Imposing_reference_velocity_node on specified components: ', mask + else + ewrite(1,*) 'Imposing_reference_velocity_node on all components' + end if + if(IsParallel()) then + call set_reference_node(big_m, reference_node, rhs, mask, reference_node_owned=reference_node_owned) + else + call set_reference_node(big_m, reference_node, rhs, mask) + end if + + end subroutine impose_reference_velocity_node end module boundary_conditions_from_options diff --git a/preprocessor/Field_Priority_Lists.F90 b/preprocessor/Field_Priority_Lists.F90 index 550c6859fa..3a7ba3b571 100644 --- a/preprocessor/Field_Priority_Lists.F90 +++ b/preprocessor/Field_Priority_Lists.F90 @@ -29,58 +29,58 @@ module field_priority_lists - use fldebug - use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN - use futils, only: int2str - use spud - use fields - use state_module - use sediment, only: get_n_sediment_fields, get_sediment_item - - implicit none - - !! Field name list for tracers (from 1 to NTSOL) - character(len=FIELD_NAME_LEN), save, & - dimension(:), allocatable :: field_name_list - !! Field list for tracters (from 1 to NTSOL) - type(scalar_field), dimension(:), allocatable, save :: field_list - !! Options path list for tracers (from 1 to NTSOL) - character(len=OPTION_PATH_LEN), save, & - dimension(:), allocatable :: field_optionpath_list - !! State list for tracers (from 1 to NTSOL) - integer, save, dimension(:), allocatable :: field_state_list - - private - public :: field_name_list, field_list, field_optionpath_list,& - & field_state_list, initialise_field_lists_from_options,& - & get_ntsol + use fldebug + use global_parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use futils, only: int2str + use spud + use fields + use state_module + use sediment, only: get_n_sediment_fields, get_sediment_item + + implicit none + + !! Field name list for tracers (from 1 to NTSOL) + character(len=FIELD_NAME_LEN), save, & + dimension(:), allocatable :: field_name_list + !! Field list for tracters (from 1 to NTSOL) + type(scalar_field), dimension(:), allocatable, save :: field_list + !! Options path list for tracers (from 1 to NTSOL) + character(len=OPTION_PATH_LEN), save, & + dimension(:), allocatable :: field_optionpath_list + !! State list for tracers (from 1 to NTSOL) + integer, save, dimension(:), allocatable :: field_state_list + + private + public :: field_name_list, field_list, field_optionpath_list,& + & field_state_list, initialise_field_lists_from_options,& + & get_ntsol contains - subroutine initialise_field_lists_from_options(state, ntsol) - type(state_type), dimension(:), intent(in) :: state - integer, intent(in) :: ntsol + subroutine initialise_field_lists_from_options(state, ntsol) + type(state_type), dimension(:), intent(in) :: state + integer, intent(in) :: ntsol - logical, save:: initialised=.false. - integer :: nsol, nphases, nfields, p, f, tmpint - character(len=FIELD_NAME_LEN) :: tmpstring - logical :: aliased, pressure + logical, save:: initialised=.false. + integer :: nsol, nphases, nfields, p, f, tmpint + character(len=FIELD_NAME_LEN) :: tmpstring + logical :: aliased, pressure - integer, dimension(:), allocatable :: priority - !! Field list for tracers (from 1 to NTSOL) - character(len=FIELD_NAME_LEN), save, & - dimension(:), allocatable :: temp_field_name_list - !! Options path list for tracers (from 1 to NTSOL) - character(len=OPTION_PATH_LEN), save, & - dimension(:), allocatable :: temp_field_optionpath_list - !! State list for tracers (from 1 to NTSOL) - integer, save, dimension(:), allocatable :: temp_field_state_list + integer, dimension(:), allocatable :: priority + !! Field list for tracers (from 1 to NTSOL) + character(len=FIELD_NAME_LEN), save, & + dimension(:), allocatable :: temp_field_name_list + !! Options path list for tracers (from 1 to NTSOL) + character(len=OPTION_PATH_LEN), save, & + dimension(:), allocatable :: temp_field_optionpath_list + !! State list for tracers (from 1 to NTSOL) + integer, save, dimension(:), allocatable :: temp_field_state_list - ! if called for the second time return immediately - if (.not.initialised) then + ! if called for the second time return immediately + if (.not.initialised) then - allocate( field_name_list(ntsol), & + allocate( field_name_list(ntsol), & field_state_list(ntsol), & field_optionpath_list(ntsol),& priority(ntsol), & @@ -89,325 +89,325 @@ subroutine initialise_field_lists_from_options(state, ntsol) temp_field_state_list(ntsol), & temp_field_optionpath_list(ntsol) ) - nsol = 0 + nsol = 0 - nphases = option_count('/material_phase') - do p = 0, nphases-1 - nfields = option_count('/material_phase[' & + nphases = option_count('/material_phase') + do p = 0, nphases-1 + nfields = option_count('/material_phase[' & //int2str(p)//']/scalar_field') - do f = 0,nfields-1 - aliased = have_option('/material_phase['// & + do f = 0,nfields-1 + aliased = have_option('/material_phase['// & int2str(p)//']/scalar_field['//int2str(f)//']/aliased') - call get_option('/material_phase['// & + call get_option('/material_phase['// & int2str(p)// & ']/scalar_field['//int2str(f)//']/name', & tmpstring) - call get_option('/material_phase['// & + call get_option('/material_phase['// & int2str(p)// & ']/scalar_field['//int2str(f)//']/& - &prognostic/priority', & + &prognostic/priority', & tmpint, default=0) - pressure = (trim(tmpstring)=='Pressure') + pressure = (trim(tmpstring)=='Pressure') - if (.not. aliased .and. .not. pressure) then - nsol = nsol + 1 - temp_field_name_list(nsol) = tmpstring - temp_field_optionpath_list(nsol) = '/material_phase['// & + if (.not. aliased .and. .not. pressure) then + nsol = nsol + 1 + temp_field_name_list(nsol) = tmpstring + temp_field_optionpath_list(nsol) = '/material_phase['// & int2str(p)// & ']/scalar_field::'//trim(tmpstring) - temp_field_state_list(nsol) = p+1 - priority(nsol) = tmpint - end if - end do - - ! prognostic sediment fields - if (have_option('/material_phase['//int2str(p)//']/sediment')) then - nfields = get_n_sediment_fields() - do f = 1, nfields - nsol=nsol+1 - - call get_sediment_item(state(p+1), f, temp_field_name_list(nsol)) - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + temp_field_state_list(nsol) = p+1 + priority(nsol) = tmpint + end if + end do + + ! prognostic sediment fields + if (have_option('/material_phase['//int2str(p)//']/sediment')) then + nfields = get_n_sediment_fields() + do f = 1, nfields + nsol=nsol+1 + + call get_sediment_item(state(p+1), f, temp_field_name_list(nsol)) + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/sediment/scalar_field['//int2str(f-1)//']' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=0) - priority(nsol) = tmpint - end do - end if - - ! this whole set up of fields could be improved to ensure that multiple PBEs can be used per phase - ! prognostic pop balance fields - very limited applicability - if (have_option('/material_phase['//int2str(p)//']/population_balance/')) then - do f = 0, option_count('/material_phase['//int2str(p)//& + priority(nsol) = tmpint + end do + end if + + ! this whole set up of fields could be improved to ensure that multiple PBEs can be used per phase + ! prognostic pop balance fields - very limited applicability + if (have_option('/material_phase['//int2str(p)//']/population_balance/')) then + do f = 0, option_count('/material_phase['//int2str(p)//& ']/population_balance/weights/scalar_field') - 1 - nsol=nsol+1 - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/population_balance/weights/scalar_field['//int2str(f)//']' - call get_option('/material_phase['//int2str(p)//& + call get_option('/material_phase['//int2str(p)//& ']/population_balance/weights/scalar_field['//int2str(f)//& ']/name',temp_field_name_list(nsol)) - call get_option('/material_phase['//int2str(p)//& + call get_option('/material_phase['//int2str(p)//& ']/population_balance/weights/scalar_field['//int2str(f)//& ']/prognostic/priority', priority(nsol), default=0) - temp_field_state_list(nsol) = p+1 - end do - do f = 0, option_count('/material_phase['//int2str(p)//& + temp_field_state_list(nsol) = p+1 + end do + do f = 0, option_count('/material_phase['//int2str(p)//& ']/population_balance/weighted_abscissa/scalar_field') - 1 - nsol=nsol+1 - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/population_balance/weighted_abscissa/scalar_field['//int2str(f)//']' - call get_option('/material_phase['//int2str(p)//& + call get_option('/material_phase['//int2str(p)//& ']/population_balance/weighted_abscissa/scalar_field['//int2str(f)//& ']/name',temp_field_name_list(nsol)) - call get_option('/material_phase['//int2str(p)//& + call get_option('/material_phase['//int2str(p)//& ']/population_balance/weighted_abscissa/scalar_field['//int2str(f)//& ']/prognostic/priority', priority(nsol), default=0) - temp_field_state_list(nsol) = p+1 - end do - end if + temp_field_state_list(nsol) = p+1 + end do + end if - ! prognostic Mellor Yamada fields: - if (have_option('/material_phase[' & + ! prognostic Mellor Yamada fields: + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/Mellor_Yamada/scalar_field::KineticEnergy/prognostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "KineticEnergy" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_name_list(nsol) = "KineticEnergy" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/subgridscale_parameterisations/Mellor_Yamada/scalar_field::KineticEnergy' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=0) - priority(nsol) = tmpint - end if - if (have_option('/material_phase[' & + priority(nsol) = tmpint + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/Mellor_Yamada/scalar_field::TurbulentLengthScalexKineticEnergy/prognostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "TurbulentLengthScalexKineticEnergy" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_name_list(nsol) = "TurbulentLengthScalexKineticEnergy" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/subgridscale_parameterisations/Mellor_Yamada/scalar_field::TurbulentLengthScalexKineticEnergy' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=0) - priority(nsol) = tmpint - end if - - ! Check for GLS - we need to make sure these fields are solved *after* - ! everything else, so set to a big negative value. In addition, the - ! Psi solve *must* come after the TKE solve, so make sure the priority - ! is set such that this happens - if (have_option('/material_phase[' & + priority(nsol) = tmpint + end if + + ! Check for GLS - we need to make sure these fields are solved *after* + ! everything else, so set to a big negative value. In addition, the + ! Psi solve *must* come after the TKE solve, so make sure the priority + ! is set such that this happens + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/GLS/scalar_field::GLSTurbulentKineticEnergy/prognostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "GLSTurbulentKineticEnergy" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_name_list(nsol) = "GLSTurbulentKineticEnergy" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/subgridscale_parameterisations/GLS/scalar_field::GLSTurbulentKineticEnergy' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*100 - end if - if (have_option('/material_phase[' & + priority(nsol) = -tmpint*100 + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/GLS/scalar_field::GLSGenericSecondQuantity/prognostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "GLSGenericSecondQuantity" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_name_list(nsol) = "GLSGenericSecondQuantity" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/subgridscale_parameterisations/GLS/scalar_field::GLSGenericSecondQuantity' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*100 - end if - - ! Check for k-epsilon - we need to make sure these fields are solved *after* - ! everything else, so set to a big negative value. In addition, the - ! TurbulentDissipation (Epsilon) solve *must* come after the TKE solve, - ! so make sure the priority is set such that this happens. - if (have_option('/material_phase[' & + priority(nsol) = -tmpint*100 + end if + + ! Check for k-epsilon - we need to make sure these fields are solved *after* + ! everything else, so set to a big negative value. In addition, the + ! TurbulentDissipation (Epsilon) solve *must* come after the TKE solve, + ! so make sure the priority is set such that this happens. + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/k-epsilon/scalar_field::TurbulentKineticEnergy/prognostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "TurbulentKineticEnergy" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_name_list(nsol) = "TurbulentKineticEnergy" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/subgridscale_parameterisations/k-epsilon/scalar_field::TurbulentKineticEnergy' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*100 - end if - if (have_option('/material_phase[' & + priority(nsol) = -tmpint*100 + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/k-epsilon/scalar_field::TurbulentDissipation/prognostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "TurbulentDissipation" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + nsol=nsol+1 + temp_field_name_list(nsol) = "TurbulentDissipation" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & ']/subgridscale_parameterisations/k-epsilon/scalar_field::TurbulentDissipation' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*100 - end if - ! Check for subgrid-scale kinetic energy equation - ! - we need to make sure this is solved *after* - ! everything else, so set to a big negative value. - if(have_option('/material_phase['//int2str(p)// & - ']/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/scalar_field::SubgridKineticEnergy')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "SubgridKineticEnergy" - temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & - ']/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/scalar_field::SubgridKineticEnergy' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & + priority(nsol) = -tmpint*100 + end if + ! Check for subgrid-scale kinetic energy equation + ! - we need to make sure this is solved *after* + ! everything else, so set to a big negative value. + if(have_option('/material_phase['//int2str(p)// & + ']/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/scalar_field::SubgridKineticEnergy')) then + nsol=nsol+1 + temp_field_name_list(nsol) = "SubgridKineticEnergy" + temp_field_optionpath_list(nsol)='/material_phase['//int2str(p)// & + ']/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/scalar_field::SubgridKineticEnergy' + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/prognostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*200 - end if + priority(nsol) = -tmpint*200 + end if !!! Melt rate should be the last thing to calculate, Sb - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Sb/diagnostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "Sb" - temp_field_optionpath_list(nsol)='/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Sb' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/diagnostic/priority', & + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Sb/diagnostic')) then + nsol=nsol+1 + temp_field_name_list(nsol) = "Sb" + temp_field_optionpath_list(nsol)='/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Sb' + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/diagnostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*200 - end if + priority(nsol) = -tmpint*200 + end if !!! Melt rate should be the last thing to calculate, Tb - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Tb/diagnostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "Tb" - temp_field_optionpath_list(nsol)='/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Tb' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/diagnostic/priority', & - tmpint, default=nsol) - priority(nsol) = -tmpint*200 - end if + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Tb/diagnostic')) then + nsol=nsol+1 + temp_field_name_list(nsol) = "Tb" + temp_field_optionpath_list(nsol)='/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Tb' + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/diagnostic/priority', & + tmpint, default=nsol) + priority(nsol) = -tmpint*200 + end if !!!/ocean_forcing/iceshelf_meltrate/Holland08 - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::MeltRate/diagnostic')) then - nsol=nsol+1 - temp_field_name_list(nsol) = "MeltRate" - temp_field_optionpath_list(nsol)='/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::MeltRate' - temp_field_state_list(nsol) = p+1 - call get_option(trim(temp_field_optionpath_list(nsol))//'/diagnostic/priority', & + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::MeltRate/diagnostic')) then + nsol=nsol+1 + temp_field_name_list(nsol) = "MeltRate" + temp_field_optionpath_list(nsol)='/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::MeltRate' + temp_field_state_list(nsol) = p+1 + call get_option(trim(temp_field_optionpath_list(nsol))//'/diagnostic/priority', & tmpint, default=nsol) - priority(nsol) = -tmpint*200 - end if - end do - - ! make sure we have found all ntsol scalar fields: - assert(nsol==ntsol) - - nsol=0 - do p=maxval(priority),minval(priority),-1 - do f=1,ntsol - if (priority(f)==p) then - nsol = nsol + 1 - field_name_list(nsol) = temp_field_name_list(f) - field_optionpath_list(nsol) = temp_field_optionpath_list(f) - field_state_list(nsol) = temp_field_state_list(f) - end if - end do - end do - - deallocate( priority, & + priority(nsol) = -tmpint*200 + end if + end do + + ! make sure we have found all ntsol scalar fields: + assert(nsol==ntsol) + + nsol=0 + do p=maxval(priority),minval(priority),-1 + do f=1,ntsol + if (priority(f)==p) then + nsol = nsol + 1 + field_name_list(nsol) = temp_field_name_list(f) + field_optionpath_list(nsol) = temp_field_optionpath_list(f) + field_state_list(nsol) = temp_field_state_list(f) + end if + end do + end do + + deallocate( priority, & temp_field_name_list, & temp_field_state_list, & temp_field_optionpath_list ) - initialised = .true. + initialised = .true. - end if ! End of if(initialised) + end if ! End of if(initialised) - ! Point the list of fields. This has to be done every adapt as the - ! field structures will be reallocated. + ! Point the list of fields. This has to be done every adapt as the + ! field structures will be reallocated. - ! Note that we use borrowed references for this so as not to interfere - ! with adaptivity. - do f=1,ntsol - field_list(f) = extract_scalar_field(state(field_state_list(f)),& - & field_name_list(f)) - end do + ! Note that we use borrowed references for this so as not to interfere + ! with adaptivity. + do f=1,ntsol + field_list(f) = extract_scalar_field(state(field_state_list(f)),& + & field_name_list(f)) + end do - end subroutine initialise_field_lists_from_options + end subroutine initialise_field_lists_from_options - subroutine get_ntsol(ntsol) - integer, intent(out) :: ntsol - integer :: nphases, nfields, p, f - character(len=FIELD_NAME_LEN) :: tmpstring - logical :: aliased, pressure + subroutine get_ntsol(ntsol) + integer, intent(out) :: ntsol + integer :: nphases, nfields, p, f + character(len=FIELD_NAME_LEN) :: tmpstring + logical :: aliased, pressure - ntsol = 0 + ntsol = 0 - nphases = option_count('/material_phase') - do p = 0, nphases-1 - nfields = option_count('/material_phase[' & + nphases = option_count('/material_phase') + do p = 0, nphases-1 + nfields = option_count('/material_phase[' & //int2str(p)//']/scalar_field') - do f = 0, nfields-1 - aliased = have_option('/material_phase['// & + do f = 0, nfields-1 + aliased = have_option('/material_phase['// & int2str(p)//']/scalar_field['//int2str(f)//']/aliased') - call get_option('/material_phase['// & + call get_option('/material_phase['// & int2str(p)//']/scalar_field['//int2str(f)//']/name', tmpstring) - pressure = (trim(tmpstring)=='Pressure') + pressure = (trim(tmpstring)=='Pressure') - if (.not. aliased .and. .not. pressure) then - ntsol = ntsol + 1 - end if - end do + if (.not. aliased .and. .not. pressure) then + ntsol = ntsol + 1 + end if + end do - ! added as hack for now - but this whole set up of fields could be way better! - ! prognostic pop balance fields - very limited applicability - if (have_option('/material_phase['//int2str(p)//']/population_balance/')) then - ntsol = ntsol + & + ! added as hack for now - but this whole set up of fields could be way better! + ! prognostic pop balance fields - very limited applicability + if (have_option('/material_phase['//int2str(p)//']/population_balance/')) then + ntsol = ntsol + & option_count('/material_phase['//int2str(p)//& ']/population_balance/weights/scalar_field') + & option_count('/material_phase['//int2str(p)//& ']/population_balance/weighted_abscissa/scalar_field') - end if + end if - ! prognostic scalar fields for Mellor Yamada: - if (have_option('/material_phase[' & + ! prognostic scalar fields for Mellor Yamada: + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/Mellor_Yamada/scalar_field::KineticEnergy/prognostic')) then - ntsol=ntsol + 1 - end if - if (have_option('/material_phase[' & + ntsol=ntsol + 1 + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/Mellor_Yamada/scalar_field::TurbulentLengthScalexKineticEnergy/prognostic')) then - ntsol=ntsol + 1 - end if - if (have_option('/material_phase[' & + ntsol=ntsol + 1 + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/GLS/scalar_field::GLSTurbulentKineticEnergy/prognostic')) then - ntsol=ntsol + 1 - end if - if (have_option('/material_phase[' & + ntsol=ntsol + 1 + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/GLS/scalar_field::GLSGenericSecondQuantity/prognostic')) then - ntsol=ntsol + 1 - end if - ! prognostic scalar fields for k-epsilon turbulence model: - if (have_option('/material_phase[' & + ntsol=ntsol + 1 + end if + ! prognostic scalar fields for k-epsilon turbulence model: + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/k-epsilon/scalar_field::TurbulentKineticEnergy/prognostic')) then - ntsol=ntsol + 1 - end if - if (have_option('/material_phase[' & + ntsol=ntsol + 1 + end if + if (have_option('/material_phase[' & //int2str(p)//']/subgridscale_parameterisations/k-epsilon/scalar_field::TurbulentDissipation/prognostic')) then - ntsol=ntsol + 1 - end if - ! prognostic scalar fields for subgrid-scale kinetic energy model: - if(have_option('/material_phase['//int2str(p)// & + ntsol=ntsol + 1 + end if + ! prognostic scalar fields for subgrid-scale kinetic energy model: + if(have_option('/material_phase['//int2str(p)// & ']/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/scalar_field::SubgridKineticEnergy')) then - ntsol=ntsol + 1 - end if - !Melting - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Tb/diagnostic')) then - ntsol=ntsol + 1 - end if - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Sb/diagnostic')) then - ntsol=ntsol + 1 - end if - if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::MeltRate/diagnostic')) then - ntsol=ntsol + 1 - end if - !Sediments - if (have_option('/material_phase['//int2str(p)//']/sediment')) then - ntsol=ntsol + get_n_sediment_fields() - end if - - end do - - end subroutine get_ntsol + ntsol=ntsol + 1 + end if + !Melting + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Tb/diagnostic')) then + ntsol=ntsol + 1 + end if + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::Sb/diagnostic')) then + ntsol=ntsol + 1 + end if + if (have_option('/ocean_forcing/iceshelf_meltrate/Holland08/scalar_field::MeltRate/diagnostic')) then + ntsol=ntsol + 1 + end if + !Sediments + if (have_option('/material_phase['//int2str(p)//']/sediment')) then + ntsol=ntsol + get_n_sediment_fields() + end if + + end do + + end subroutine get_ntsol end module field_priority_lists diff --git a/preprocessor/Initialise_Fields.F90 b/preprocessor/Initialise_Fields.F90 index 6a30b5c7fc..e26e80f2d4 100644 --- a/preprocessor/Initialise_Fields.F90 +++ b/preprocessor/Initialise_Fields.F90 @@ -27,174 +27,174 @@ #include "fdebug.h" module initialise_fields_module -use spud -use global_parameters, only: OPTION_PATH_LEN, PYTHON_FUNC_LEN, is_active_process -use futils -use parallel_tools -use fields -use coordinates -use tictoc -use vtk_cache_module -use climatology -use fluxes -use nemo_states_module -use physics_from_options -use load_netcdf_module + use spud + use global_parameters, only: OPTION_PATH_LEN, PYTHON_FUNC_LEN, is_active_process + use futils + use parallel_tools + use fields + use coordinates + use tictoc + use vtk_cache_module + use climatology + use fluxes + use nemo_states_module + use physics_from_options + use load_netcdf_module -implicit none + implicit none - interface initialise_field_over_regions + interface initialise_field_over_regions - module procedure initialise_scalar_field_over_regions, initialise_vector_field_over_regions, & - initialise_tensor_field_over_regions + module procedure initialise_scalar_field_over_regions, initialise_vector_field_over_regions, & + initialise_tensor_field_over_regions - end interface + end interface - interface initialise_field + interface initialise_field - module procedure initialise_scalar_field, initialise_vector_field, initialise_tensor_field + module procedure initialise_scalar_field, initialise_vector_field, initialise_tensor_field - end interface + end interface - interface apply_region_ids + interface apply_region_ids - module procedure apply_region_ids_scalar, apply_region_ids_vector, apply_region_ids_tensor + module procedure apply_region_ids_scalar, apply_region_ids_vector, apply_region_ids_tensor - end interface + end interface - private - public initialise_field, initialise_field_over_regions, apply_region_ids + private + public initialise_field, initialise_field_over_regions, apply_region_ids contains - recursive subroutine initialise_scalar_field(field, path, position, time, phase_path) - !!< Initialises field with values prescribed in option_path - !!< This is used for initial conditions, prescribed fields and - !!< setting a boundary condition surface_field, a.o. - type(scalar_field), intent(inout) :: field - character(len=*), intent(in) :: path - type(vector_field), intent(in):: position - !! if present use this time level, instead of that in the options tree - real, optional, intent(in):: time - character(len=*), intent(in), optional :: phase_path - - type(scalar_field), pointer:: read_field - type(vector_field), pointer:: vtk_position - type(vector_field) :: field_position - real :: const - character(len=OPTION_PATH_LEN) :: format, field_name, filename - character(len=PYTHON_FUNC_LEN) :: func - real :: current_time - - real value - integer nid - - ! Find out whether initial condition is constant or generated by a - ! python function (or comes from something else). - if(have_option(trim(path)//"/constant")) then - call get_option(trim(path)//"/constant", const) - ! Set field to constant - call set(field, const) - else if(have_option(trim(path)//"/python")) then - call get_option(trim(path)//"/python", func) - ! Get current time - if (present(time)) then - current_time=time - else - call get_option("/timestepping/current_time", current_time) - end if - ! Set initial condition from python function - call set_from_python_function(field, trim(func), position, current_time) - else if(have_option(trim(path)//"/generic_function")) then - FLExit("Generic functions are obsolete. Please use a Python function.") - else if(have_option(trim(path)//"/internally_calculated")) then - continue - else if(have_option(trim(path)//"/free_surface")) then - call initialise_field(field, trim(path)//"/free_surface", position, time=time, phase_path=trim(phase_path)) - ! Scale the entered freesurface height by the magnitude of gravity to give the pressure initial condition - ewrite(3, *) "Free-surface to pressure minmax pre-conversion ", minval(field), maxval(field) - call convert_free_surface_to_pressure(field, phase_path) - ewrite(3, *) "Free-surface to pressure minmax post-conversion ", minval(field), maxval(field) - - else if(have_option(trim(path) // "/from_file")) then - - if(is_active_process) then - - call tic(TICTOC_ID_IO_READ) - - call get_option(trim(path) // "/from_file/format/name", format) - call get_option(trim(path) // "/from_file/file_name", filename) - if(isparallel()) then - filename = parallel_filename(trim_file_extension(filename), ".vtu") + recursive subroutine initialise_scalar_field(field, path, position, time, phase_path) + !!< Initialises field with values prescribed in option_path + !!< This is used for initial conditions, prescribed fields and + !!< setting a boundary condition surface_field, a.o. + type(scalar_field), intent(inout) :: field + character(len=*), intent(in) :: path + type(vector_field), intent(in):: position + !! if present use this time level, instead of that in the options tree + real, optional, intent(in):: time + character(len=*), intent(in), optional :: phase_path + + type(scalar_field), pointer:: read_field + type(vector_field), pointer:: vtk_position + type(vector_field) :: field_position + real :: const + character(len=OPTION_PATH_LEN) :: format, field_name, filename + character(len=PYTHON_FUNC_LEN) :: func + real :: current_time + + real value + integer nid + + ! Find out whether initial condition is constant or generated by a + ! python function (or comes from something else). + if(have_option(trim(path)//"/constant")) then + call get_option(trim(path)//"/constant", const) + ! Set field to constant + call set(field, const) + else if(have_option(trim(path)//"/python")) then + call get_option(trim(path)//"/python", func) + ! Get current time + if (present(time)) then + current_time=time + else + call get_option("/timestepping/current_time", current_time) end if - ewrite(2, *) "Initialising field " // trim(field%name) // " from file " // trim(filename) - - select case (format) - case ("vtu") - call get_option(trim(path) // "/from_file/format::vtu/field_name", field_name, default = field%name) - read_field => vtk_cache_read_scalar_field(filename, field_name) - - if (.not. field%mesh%periodic) then - ! check that the vtk mesh is the same as the derived mesh from state - ! by comparing its coordinate fields (currently not done for periodic meshes) - - vtk_position => vtk_cache_read_positions_field(filename) - ! get the right field to compare it with - if (field%mesh==position%mesh .or. element_degree(field,1)==0) then - ! if the vtk mesh is the same mesh as the position%mesh, use position - ! (for P0 the vtk_position is that of the linear vertex mesh, so we also can directly use it) - field_position=position - call incref(field_position) - else - ! otherwise the position mapped onto field%mesh - field_position = get_remapped_coordinates(position, field%mesh) - end if - if (.not. mesh_compatible(vtk_position, field_position)) then - ! repeat, this to make sure it ends up in any error log - ewrite(-1,*) "Initialising field " // trim(field%name) // " from file " // trim(filename) - ! give useful error message (make sure to blame the user) - ewrite(-1,*) "Error: The mesh in the vtu file is not the same as mesh " // & - &trim(field%mesh%name) // & - &" specified under " // trim(field%mesh%option_path) - ! treat this as a user error! - call print_mesh_incompatibility(-1, vtk_position, field_position) - FLExit("Mesh from file and in state are not compatible") - end if - call deallocate(field_position) + ! Set initial condition from python function + call set_from_python_function(field, trim(func), position, current_time) + else if(have_option(trim(path)//"/generic_function")) then + FLExit("Generic functions are obsolete. Please use a Python function.") + else if(have_option(trim(path)//"/internally_calculated")) then + continue + else if(have_option(trim(path)//"/free_surface")) then + call initialise_field(field, trim(path)//"/free_surface", position, time=time, phase_path=trim(phase_path)) + ! Scale the entered freesurface height by the magnitude of gravity to give the pressure initial condition + ewrite(3, *) "Free-surface to pressure minmax pre-conversion ", minval(field), maxval(field) + call convert_free_surface_to_pressure(field, phase_path) + ewrite(3, *) "Free-surface to pressure minmax post-conversion ", minval(field), maxval(field) + + else if(have_option(trim(path) // "/from_file")) then + + if(is_active_process) then + + call tic(TICTOC_ID_IO_READ) + + call get_option(trim(path) // "/from_file/format/name", format) + call get_option(trim(path) // "/from_file/file_name", filename) + if(isparallel()) then + filename = parallel_filename(trim_file_extension(filename), ".vtu") end if + ewrite(2, *) "Initialising field " // trim(field%name) // " from file " // trim(filename) + + select case (format) + case ("vtu") + call get_option(trim(path) // "/from_file/format::vtu/field_name", field_name, default = field%name) + read_field => vtk_cache_read_scalar_field(filename, field_name) + + if (.not. field%mesh%periodic) then + ! check that the vtk mesh is the same as the derived mesh from state + ! by comparing its coordinate fields (currently not done for periodic meshes) + + vtk_position => vtk_cache_read_positions_field(filename) + ! get the right field to compare it with + if (field%mesh==position%mesh .or. element_degree(field,1)==0) then + ! if the vtk mesh is the same mesh as the position%mesh, use position + ! (for P0 the vtk_position is that of the linear vertex mesh, so we also can directly use it) + field_position=position + call incref(field_position) + else + ! otherwise the position mapped onto field%mesh + field_position = get_remapped_coordinates(position, field%mesh) + end if + if (.not. mesh_compatible(vtk_position, field_position)) then + ! repeat, this to make sure it ends up in any error log + ewrite(-1,*) "Initialising field " // trim(field%name) // " from file " // trim(filename) + ! give useful error message (make sure to blame the user) + ewrite(-1,*) "Error: The mesh in the vtu file is not the same as mesh " // & + &trim(field%mesh%name) // & + &" specified under " // trim(field%mesh%option_path) + ! treat this as a user error! + call print_mesh_incompatibility(-1, vtk_position, field_position) + FLExit("Mesh from file and in state are not compatible") + end if + call deallocate(field_position) + end if - call set(field, read_field) + call set(field, read_field) - case ("climatology (Boyer2005)") + case ("climatology (Boyer2005)") - do nid=1, node_count(position) - if(field%name=="Temperature") then - call climatology_GetSurfaceValue("temperature", node_val(position, nid), value) - else if(field%name=="Salinity") then - call climatology_GetSurfaceValue("salinity", node_val(position, nid), value) - else - FLExit("No climatology data available for field: "//field%name) - end if - call set(field, nid, value) - end do + do nid=1, node_count(position) + if(field%name=="Temperature") then + call climatology_GetSurfaceValue("temperature", node_val(position, nid), value) + else if(field%name=="Salinity") then + call climatology_GetSurfaceValue("salinity", node_val(position, nid), value) + else + FLExit("No climatology data available for field: "//field%name) + end if + call set(field, nid, value) + end do - case default + case default - ewrite(-1,*) 'Format: ', trim(format) - FLExit("Unknown file format") + ewrite(-1,*) 'Format: ', trim(format) + FLExit("Unknown file format") - end select + end select - call toc(TICTOC_ID_IO_READ) + call toc(TICTOC_ID_IO_READ) - end if + end if - else if(have_option(trim(path)//"/NEMO_data")) then + else if(have_option(trim(path)//"/NEMO_data")) then call insert_nemo_scalar_field(field) - else if(have_option(trim(path)//"/from_netcdf")) then + else if(have_option(trim(path)//"/from_netcdf")) then ! This will set your initial field from data contained in a ! netcdf file. The file should be in netcdf format and in @@ -203,504 +203,504 @@ recursive subroutine initialise_scalar_field(field, path, position, time, phase_ ! to a range of fields). call set_scalar_field_from_netcdf(field,path,position) - else if (have_option(trim(path)//"/no_initial_condition")) then - continue - else - ! This really shouldn't happen (with a valid flml) - ewrite(-1,*) "Incorrect initial or boundary condition for field ", trim(field%name) - ewrite(-1,*) "specified in the options at ", trim(path) - FLAbort("Incorrect initial or boundary condition for field") - end if - - end subroutine initialise_scalar_field - - subroutine initialise_vector_field(field, path, position, time, phase_path) - !!< Initialises field with values prescribed in option_path - !!< This is used for initial conditions, prescribed fields and - !!< setting a boundary condition surface_field, a.o. - type(vector_field), intent(inout) :: field - character(len=*), intent(in) :: path - type(vector_field), intent(in) :: position - !! if present use this time level, instead of that in the options tree - real, optional, intent(in):: time - character(len=*), intent(in), optional :: phase_path - - type(vector_field), pointer:: read_field, vtk_position - type(vector_field) :: field_position - real, dimension(1:field%dim) :: const - character(len=OPTION_PATH_LEN) :: format, field_name, filename, varname1, varname2 - character(len=PYTHON_FUNC_LEN) :: func - real :: current_time - integer :: i - real :: longitude, latitude, scalars(2), x, y - logical :: spherical_earth - - ! Find out whether initial condition is constant or generated by a - ! a python function - - if(have_option(trim(path)//"/constant")) then - call get_option(trim(path)//"/constant", const) - call set(field, const) - else if (have_option(trim(path)//"/python")) then - call get_option(trim(path)//"/python", func) - ! Get current time - if (present(time)) then - current_time=time - else - call get_option("/timestepping/current_time", current_time) - end if - ! Set initial condition from python function - call set_from_python_function(field, trim(func), position, current_time) - else if (have_option(trim(path)//"/generic_function")) then - call get_option(trim(path)//"/generic_function", func) - ! Python rules - FLExit("Generic functions are obsolete. Try Python instead.") - else if(have_option(trim(path)//"/internally_calculated")) then - continue - else if(have_option(trim(path) // "/from_file")) then - - if(is_active_process) then - - call tic(TICTOC_ID_IO_READ) - - call get_option(trim(path) // "/from_file/format/name", format) - call get_option(trim(path) // "/from_file/file_name", filename) - if(isparallel()) then - filename = parallel_filename(trim_file_extension(filename), ".vtu") + else if (have_option(trim(path)//"/no_initial_condition")) then + continue + else + ! This really shouldn't happen (with a valid flml) + ewrite(-1,*) "Incorrect initial or boundary condition for field ", trim(field%name) + ewrite(-1,*) "specified in the options at ", trim(path) + FLAbort("Incorrect initial or boundary condition for field") + end if + + end subroutine initialise_scalar_field + + subroutine initialise_vector_field(field, path, position, time, phase_path) + !!< Initialises field with values prescribed in option_path + !!< This is used for initial conditions, prescribed fields and + !!< setting a boundary condition surface_field, a.o. + type(vector_field), intent(inout) :: field + character(len=*), intent(in) :: path + type(vector_field), intent(in) :: position + !! if present use this time level, instead of that in the options tree + real, optional, intent(in):: time + character(len=*), intent(in), optional :: phase_path + + type(vector_field), pointer:: read_field, vtk_position + type(vector_field) :: field_position + real, dimension(1:field%dim) :: const + character(len=OPTION_PATH_LEN) :: format, field_name, filename, varname1, varname2 + character(len=PYTHON_FUNC_LEN) :: func + real :: current_time + integer :: i + real :: longitude, latitude, scalars(2), x, y + logical :: spherical_earth + + ! Find out whether initial condition is constant or generated by a + ! a python function + + if(have_option(trim(path)//"/constant")) then + call get_option(trim(path)//"/constant", const) + call set(field, const) + else if (have_option(trim(path)//"/python")) then + call get_option(trim(path)//"/python", func) + ! Get current time + if (present(time)) then + current_time=time + else + call get_option("/timestepping/current_time", current_time) end if - ewrite(2, *) "Initialising field " // trim(field%name) // " from file " // trim(filename) - - select case (format) - case ("vtu") - call get_option(trim(path) // "/from_file/format::vtu/field_name", field_name, default = field%name) - read_field => vtk_cache_read_vector_field(filename, field_name) - - if (.not. field%mesh%periodic) then - ! check that the vtk mesh is the same as the derived mesh from state - ! by comparing its coordinate fields (currently not done for periodic meshes) - - ! get the right field to compare it with - vtk_position => vtk_cache_read_positions_field(filename) - if (field%mesh==position%mesh .or. element_degree(field,1)==0) then - ! if the vtk mesh is the same mesh as the position%mesh, use position - ! (for P0 the vtk_position is that of the linear vertex mesh, so we also can directly use it) - field_position=position - call incref(field_position) - else - ! otherwise the position mapped onto field%mesh - field_position = get_remapped_coordinates(position, field%mesh) - end if - - if (.not. mesh_compatible(vtk_position, field_position)) then - ! repeat, this to make sure it ends up in any error log - ewrite(-1,*) "Initialising field " // trim(field%name) // " from file " // trim(filename) - ! give useful error message (make sure to blame the user) - ewrite(-1,*) "Error: The mesh in the vtu file is not the same as mesh " // & - &trim(field%mesh%name) // & - &" specified under " // trim(field%mesh%option_path) - ! treat this as a user error! - call print_mesh_incompatibility(-1, vtk_position, field_position) - FLExit("Mesh from file and in state are not compatible") - end if - - call deallocate(field_position) + ! Set initial condition from python function + call set_from_python_function(field, trim(func), position, current_time) + else if (have_option(trim(path)//"/generic_function")) then + call get_option(trim(path)//"/generic_function", func) + ! Python rules + FLExit("Generic functions are obsolete. Try Python instead.") + else if(have_option(trim(path)//"/internally_calculated")) then + continue + else if(have_option(trim(path) // "/from_file")) then + + if(is_active_process) then + + call tic(TICTOC_ID_IO_READ) + + call get_option(trim(path) // "/from_file/format/name", format) + call get_option(trim(path) // "/from_file/file_name", filename) + if(isparallel()) then + filename = parallel_filename(trim_file_extension(filename), ".vtu") end if + ewrite(2, *) "Initialising field " // trim(field%name) // " from file " // trim(filename) + + select case (format) + case ("vtu") + call get_option(trim(path) // "/from_file/format::vtu/field_name", field_name, default = field%name) + read_field => vtk_cache_read_vector_field(filename, field_name) + + if (.not. field%mesh%periodic) then + ! check that the vtk mesh is the same as the derived mesh from state + ! by comparing its coordinate fields (currently not done for periodic meshes) + + ! get the right field to compare it with + vtk_position => vtk_cache_read_positions_field(filename) + if (field%mesh==position%mesh .or. element_degree(field,1)==0) then + ! if the vtk mesh is the same mesh as the position%mesh, use position + ! (for P0 the vtk_position is that of the linear vertex mesh, so we also can directly use it) + field_position=position + call incref(field_position) + else + ! otherwise the position mapped onto field%mesh + field_position = get_remapped_coordinates(position, field%mesh) + end if + + if (.not. mesh_compatible(vtk_position, field_position)) then + ! repeat, this to make sure it ends up in any error log + ewrite(-1,*) "Initialising field " // trim(field%name) // " from file " // trim(filename) + ! give useful error message (make sure to blame the user) + ewrite(-1,*) "Error: The mesh in the vtu file is not the same as mesh " // & + &trim(field%mesh%name) // & + &" specified under " // trim(field%mesh%option_path) + ! treat this as a user error! + call print_mesh_incompatibility(-1, vtk_position, field_position) + FLExit("Mesh from file and in state are not compatible") + end if + + call deallocate(field_position) + end if - call set(field, read_field) + call set(field, read_field) - case default + case default - ewrite(-1,*) 'Format: ', trim(format) - FLExit("Unknown file format") + ewrite(-1,*) 'Format: ', trim(format) + FLExit("Unknown file format") - end select + end select - call toc(TICTOC_ID_IO_READ) + call toc(TICTOC_ID_IO_READ) - end if + end if - else if(have_option(trim(path)//"/NEMO_data")) then + else if(have_option(trim(path)//"/NEMO_data")) then call insert_nemo_vector_field(field) - else if(have_option(trim(path) // "/from_netcdf")) then + else if(have_option(trim(path) // "/from_netcdf")) then - ! Get file name - call get_option(trim(path)//"/from_netcdf/file_name", filename) - call fluxes_registerdatafile(trim(filename)) + ! Get file name + call get_option(trim(path)//"/from_netcdf/file_name", filename) + call fluxes_registerdatafile(trim(filename)) - ! Get current time - call get_option("/timestepping/current_time", current_time) - call fluxes_settimeseconds(current_time) + ! Get current time + call get_option("/timestepping/current_time", current_time) + call fluxes_settimeseconds(current_time) - spherical_earth = have_option("/geometry/spherical_earth") + spherical_earth = have_option("/geometry/spherical_earth") - call get_option(trim(path)//"/from_netcdf/east_west", varname1) - call fluxes_addfieldofinterest(trim(varname1)) + call get_option(trim(path)//"/from_netcdf/east_west", varname1) + call fluxes_addfieldofinterest(trim(varname1)) - call get_option(trim(path)//"/from_netcdf/north_south", varname2) - call fluxes_addfieldofinterest(trim(varname2)) + call get_option(trim(path)//"/from_netcdf/north_south", varname2) + call fluxes_addfieldofinterest(trim(varname2)) - do i=1, node_count(position) - if(spherical_earth) then - call LongitudeLatitude(node_val(position, i), & + do i=1, node_count(position) + if(spherical_earth) then + call LongitudeLatitude(node_val(position, i), & longitude, latitude) - call fluxes_getscalars(longitude, latitude, scalars) - else - x=node_val(position, 1, i) - y=node_val(position, 2, i) - call fluxes_getscalars(x, y, scalars) - end if - end do - elseif(have_option(trim(path)//"/balanced")) then - !This option exists in shallow_water schema - !This will get reset in shallow_water after populate_state - const = 0.0 - call set(field,const) - else if (have_option(trim(path)//"/no_initial_condition")) then - continue - else - ! This really shouldn't happen - ewrite(-1,*) "Incorrect initial or boundary condition for field ", trim(field%name) - FLExit("Incorrect initial or boundary condition for field") - end if - - end subroutine initialise_vector_field - - subroutine initialise_tensor_field(field, path, position, time, phase_path) - !!< Initialises field with values prescribed in option_path - !!< This is used for initial conditions, prescribed fields and - !!< setting a boundary condition surface_field, a.o. - - type(tensor_field), intent(inout) :: field - character(len=*), intent(in) :: path - type(vector_field), intent(in) :: position - !! if present use this time level, instead of that in the options tree - real, optional, intent(in):: time - character(len=*), intent(in), optional :: phase_path - - integer :: i - logical :: is_isotropic, is_diagonal, is_symmetric - ! name of python function - character(len=OPTION_PATH_LEN) :: func - ! time and position needed for python function... - real :: current_time - ! to read in constant initial value - real:: const - real, dimension(1:field%dim(1)) :: const_vec - real, dimension(1:field%dim(1),1:field%dim(2)) :: const_array - character(len=OPTION_PATH_LEN):: tpath - ! Temporary field for calculating isotropic tensor fields from python... - type(scalar_field) :: sfield - type(vector_field) :: vfield - - ! Find out whether tensor is isotropic or symmetric or not - is_isotropic=have_option(trim(path)//"/isotropic") - is_diagonal=have_option(trim(path)//"/diagonal") - is_symmetric=have_option(trim(path)//"/anisotropic_symmetric") - - if(is_isotropic) then - - ! Zero tensor - call zero(field) - - tpath=trim(path)//"/isotropic" - - ! Find out if tensor diagonal components are constant or whether - ! the tensor is generated by a python function. - - if(have_option(trim(tpath)//"/constant")) then - ! Allocate constant array - const_array=0.0 - ! Put constant on diagonal of tensor - call get_option(trim(tpath)//"/constant", const) - do i=1, field%dim(1) - const_array(i,i)=const - end do - call set(field, const_array) - else if(have_option(trim(tpath)//"/python")) then - call get_option(trim(tpath)//"/python", func) - ! Get current time - if (present(time)) then - current_time=time - else - call get_option("/timestepping/current_time", current_time) - end if - call allocate(sfield, field%mesh, name="TemporaryIsotropic") - call set_from_python_function(sfield, trim(func), position,& - & current_time) - ! Put isotropic value on diagonal of tensor - do i=1, field%dim(1) - call set(field, i, i, sfield) - end do - call deallocate(sfield) - else if (have_option(trim(tpath)//"/generic_function")) then - FLExit("Generic functions are obsolete. Use a Python function.") - else if(have_option(trim(path)//"/internally_calculated")) then - continue - else - FLExit("Incorrect initial condition for field") - end if - - else if(is_diagonal) then - - ! Zero tensor - call zero(field) - - tpath=trim(path)//"/diagonal" - - ! Find out if tensor diagonal components are constant or whether - ! the tensor is generated by a python function. - - if(have_option(trim(tpath)//"/constant")) then - ! Allocate constant array - const_array=0.0 - ! Put constant on diagonal of tensor - call get_option(trim(tpath)//"/constant", const_vec) - do i=1, minval(field%dim) - const_array(i,i)=const_vec(i) - end do - call set(field, const_array) - else if(have_option(trim(tpath)//"/python")) then - call get_option(trim(tpath)//"/python", func) - ! Get current time - if (present(time)) then - current_time=time - else - call get_option("/timestepping/current_time", current_time) - end if - call allocate(vfield, minval(field%dim), field%mesh, name="TemporaryDiagonal") - call set_from_python_function(vfield, trim(func), position,& - & current_time) - ! Put values on diagonal of tensor - call set(field, vfield) - - call deallocate(vfield) - else if (have_option(trim(tpath)//"/generic_function")) then - FLExit("Generic functions are obsolete. Use a Python function.") - else - FLExit("Incorrect initial condition for field") - end if - - else - - ! Set path - if(is_symmetric) then - tpath=trim(path)//"/anisotropic_symmetric" - else - tpath=trim(path)//"/anisotropic_asymmetric" - end if - - - if(have_option(trim(tpath)//"/constant")) then - call get_option(trim(tpath)//"/constant", const_array) - call set(field, const_array) - else if (have_option(trim(tpath)//"/python")) then - call get_option(trim(tpath)//"/python", func) - ! Get current time - if (present(time)) then - current_time=time - else - call get_option("/timestepping/current_time", current_time) - end if - call set_from_python_function(field, trim(func), position,& - & current_time) - else if (have_option(trim(tpath)//"/generic_function")) then - FLExit("Generic functions are obsolete. Use a Python function.") - else - FLExit("Incorrect initial condition for field") - end if - - end if - - end subroutine initialise_tensor_field - - subroutine initialise_scalar_field_over_regions(field, path, position, time, phase_path) - !!< Wrapper to initialise_scalar_field for prescribed and prognostic - !!< fields in case mesh regions are being used - type(scalar_field), intent(inout) :: field - !! path should point to either /"path to field"/prescribed/value - !! or /"path to field"/prognostic/initial_condition - character(len=*), intent(in) :: path - type(vector_field), intent(in):: position - real, intent(in), optional :: time - character(len=*), intent(in), optional :: phase_path - - type(scalar_field) :: tempfield - integer :: value, nvalues - - call allocate(tempfield, field%mesh, field%name, field_type=field%field_type) - - nvalues = option_count(trim(path)) - - do value = 0, nvalues-1 - call zero(tempfield) - call initialise_field(tempfield, & + call fluxes_getscalars(longitude, latitude, scalars) + else + x=node_val(position, 1, i) + y=node_val(position, 2, i) + call fluxes_getscalars(x, y, scalars) + end if + end do + elseif(have_option(trim(path)//"/balanced")) then + !This option exists in shallow_water schema + !This will get reset in shallow_water after populate_state + const = 0.0 + call set(field,const) + else if (have_option(trim(path)//"/no_initial_condition")) then + continue + else + ! This really shouldn't happen + ewrite(-1,*) "Incorrect initial or boundary condition for field ", trim(field%name) + FLExit("Incorrect initial or boundary condition for field") + end if + + end subroutine initialise_vector_field + + subroutine initialise_tensor_field(field, path, position, time, phase_path) + !!< Initialises field with values prescribed in option_path + !!< This is used for initial conditions, prescribed fields and + !!< setting a boundary condition surface_field, a.o. + + type(tensor_field), intent(inout) :: field + character(len=*), intent(in) :: path + type(vector_field), intent(in) :: position + !! if present use this time level, instead of that in the options tree + real, optional, intent(in):: time + character(len=*), intent(in), optional :: phase_path + + integer :: i + logical :: is_isotropic, is_diagonal, is_symmetric + ! name of python function + character(len=OPTION_PATH_LEN) :: func + ! time and position needed for python function... + real :: current_time + ! to read in constant initial value + real:: const + real, dimension(1:field%dim(1)) :: const_vec + real, dimension(1:field%dim(1),1:field%dim(2)) :: const_array + character(len=OPTION_PATH_LEN):: tpath + ! Temporary field for calculating isotropic tensor fields from python... + type(scalar_field) :: sfield + type(vector_field) :: vfield + + ! Find out whether tensor is isotropic or symmetric or not + is_isotropic=have_option(trim(path)//"/isotropic") + is_diagonal=have_option(trim(path)//"/diagonal") + is_symmetric=have_option(trim(path)//"/anisotropic_symmetric") + + if(is_isotropic) then + + ! Zero tensor + call zero(field) + + tpath=trim(path)//"/isotropic" + + ! Find out if tensor diagonal components are constant or whether + ! the tensor is generated by a python function. + + if(have_option(trim(tpath)//"/constant")) then + ! Allocate constant array + const_array=0.0 + ! Put constant on diagonal of tensor + call get_option(trim(tpath)//"/constant", const) + do i=1, field%dim(1) + const_array(i,i)=const + end do + call set(field, const_array) + else if(have_option(trim(tpath)//"/python")) then + call get_option(trim(tpath)//"/python", func) + ! Get current time + if (present(time)) then + current_time=time + else + call get_option("/timestepping/current_time", current_time) + end if + call allocate(sfield, field%mesh, name="TemporaryIsotropic") + call set_from_python_function(sfield, trim(func), position,& + & current_time) + ! Put isotropic value on diagonal of tensor + do i=1, field%dim(1) + call set(field, i, i, sfield) + end do + call deallocate(sfield) + else if (have_option(trim(tpath)//"/generic_function")) then + FLExit("Generic functions are obsolete. Use a Python function.") + else if(have_option(trim(path)//"/internally_calculated")) then + continue + else + FLExit("Incorrect initial condition for field") + end if + + else if(is_diagonal) then + + ! Zero tensor + call zero(field) + + tpath=trim(path)//"/diagonal" + + ! Find out if tensor diagonal components are constant or whether + ! the tensor is generated by a python function. + + if(have_option(trim(tpath)//"/constant")) then + ! Allocate constant array + const_array=0.0 + ! Put constant on diagonal of tensor + call get_option(trim(tpath)//"/constant", const_vec) + do i=1, minval(field%dim) + const_array(i,i)=const_vec(i) + end do + call set(field, const_array) + else if(have_option(trim(tpath)//"/python")) then + call get_option(trim(tpath)//"/python", func) + ! Get current time + if (present(time)) then + current_time=time + else + call get_option("/timestepping/current_time", current_time) + end if + call allocate(vfield, minval(field%dim), field%mesh, name="TemporaryDiagonal") + call set_from_python_function(vfield, trim(func), position,& + & current_time) + ! Put values on diagonal of tensor + call set(field, vfield) + + call deallocate(vfield) + else if (have_option(trim(tpath)//"/generic_function")) then + FLExit("Generic functions are obsolete. Use a Python function.") + else + FLExit("Incorrect initial condition for field") + end if + + else + + ! Set path + if(is_symmetric) then + tpath=trim(path)//"/anisotropic_symmetric" + else + tpath=trim(path)//"/anisotropic_asymmetric" + end if + + + if(have_option(trim(tpath)//"/constant")) then + call get_option(trim(tpath)//"/constant", const_array) + call set(field, const_array) + else if (have_option(trim(tpath)//"/python")) then + call get_option(trim(tpath)//"/python", func) + ! Get current time + if (present(time)) then + current_time=time + else + call get_option("/timestepping/current_time", current_time) + end if + call set_from_python_function(field, trim(func), position,& + & current_time) + else if (have_option(trim(tpath)//"/generic_function")) then + FLExit("Generic functions are obsolete. Use a Python function.") + else + FLExit("Incorrect initial condition for field") + end if + + end if + + end subroutine initialise_tensor_field + + subroutine initialise_scalar_field_over_regions(field, path, position, time, phase_path) + !!< Wrapper to initialise_scalar_field for prescribed and prognostic + !!< fields in case mesh regions are being used + type(scalar_field), intent(inout) :: field + !! path should point to either /"path to field"/prescribed/value + !! or /"path to field"/prognostic/initial_condition + character(len=*), intent(in) :: path + type(vector_field), intent(in):: position + real, intent(in), optional :: time + character(len=*), intent(in), optional :: phase_path + + type(scalar_field) :: tempfield + integer :: value, nvalues + + call allocate(tempfield, field%mesh, field%name, field_type=field%field_type) + + nvalues = option_count(trim(path)) + + do value = 0, nvalues-1 + call zero(tempfield) + call initialise_field(tempfield, & trim(path)//'['//int2str(value)//']', & position, time=time, phase_path=trim(phase_path)) - call apply_region_ids(field, tempfield, & + call apply_region_ids(field, tempfield, & trim(path)//'['//int2str(value)//']') - end do + end do - call deallocate(tempfield) + call deallocate(tempfield) - end subroutine initialise_scalar_field_over_regions + end subroutine initialise_scalar_field_over_regions - subroutine initialise_vector_field_over_regions(field, path, position, time, phase_path) - !!< Wrapper to initialise_field for prescribed fields in case - !!< mesh regions are being used - type(vector_field), intent(inout) :: field - !! path should point to either /"path to field"/prescribed/value - !! or /"path to field"/prognostic/initial_condition - character(len=*), intent(in) :: path - type(vector_field), intent(in):: position - real, intent(in), optional :: time - character(len=*), intent(in), optional :: phase_path + subroutine initialise_vector_field_over_regions(field, path, position, time, phase_path) + !!< Wrapper to initialise_field for prescribed fields in case + !!< mesh regions are being used + type(vector_field), intent(inout) :: field + !! path should point to either /"path to field"/prescribed/value + !! or /"path to field"/prognostic/initial_condition + character(len=*), intent(in) :: path + type(vector_field), intent(in):: position + real, intent(in), optional :: time + character(len=*), intent(in), optional :: phase_path - type(vector_field) :: tempfield - integer :: value, nvalues + type(vector_field) :: tempfield + integer :: value, nvalues - call allocate(tempfield, field%dim, field%mesh, field%name, & - field_type=field%field_type) + call allocate(tempfield, field%dim, field%mesh, field%name, & + field_type=field%field_type) - nvalues = option_count(trim(path)) + nvalues = option_count(trim(path)) - do value = 0, nvalues-1 - call zero(tempfield) - call initialise_field(tempfield, & + do value = 0, nvalues-1 + call zero(tempfield) + call initialise_field(tempfield, & trim(path)//'['//int2str(value)//']', & position, time=time, phase_path=trim(phase_path)) - call apply_region_ids(field, tempfield, & + call apply_region_ids(field, tempfield, & trim(path)//'['//int2str(value)//']') - end do + end do - call deallocate(tempfield) + call deallocate(tempfield) - end subroutine initialise_vector_field_over_regions + end subroutine initialise_vector_field_over_regions - subroutine initialise_tensor_field_over_regions(field, path, position, time, phase_path) - !!< Wrapper to initialise_field for prescribed fields in case - !!< mesh regions are being used - type(tensor_field), intent(inout) :: field - !! path should point to either /"path to field"/prescribed/value - !! or /"path to field"/prognostic/initial_condition - character(len=*), intent(in) :: path - type(vector_field), intent(in):: position - real, intent(in), optional :: time - character(len=*), intent(in), optional :: phase_path + subroutine initialise_tensor_field_over_regions(field, path, position, time, phase_path) + !!< Wrapper to initialise_field for prescribed fields in case + !!< mesh regions are being used + type(tensor_field), intent(inout) :: field + !! path should point to either /"path to field"/prescribed/value + !! or /"path to field"/prognostic/initial_condition + character(len=*), intent(in) :: path + type(vector_field), intent(in):: position + real, intent(in), optional :: time + character(len=*), intent(in), optional :: phase_path - type(tensor_field) :: tempfield - integer :: value, nvalues + type(tensor_field) :: tempfield + integer :: value, nvalues - call allocate(tempfield, field%mesh, field%name, field_type=field%field_type) + call allocate(tempfield, field%mesh, field%name, field_type=field%field_type) - nvalues = option_count(trim(path)) + nvalues = option_count(trim(path)) - do value = 0, nvalues-1 - call zero(tempfield) - call initialise_field(tempfield, & + do value = 0, nvalues-1 + call zero(tempfield) + call initialise_field(tempfield, & trim(path)//'['//int2str(value)//']', & position, time=time, phase_path=trim(phase_path)) - call apply_region_ids(field, tempfield, & + call apply_region_ids(field, tempfield, & trim(path)//'['//int2str(value)//']') - end do - - call deallocate(tempfield) - - end subroutine initialise_tensor_field_over_regions - - subroutine apply_region_ids_scalar(field, tempfield, path) - - type(scalar_field), intent(inout) :: field - type(scalar_field), intent(in) :: tempfield - character(len=*), intent(in) :: path - - integer :: stat, ele - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: region_ids - - stat = 1 - if(have_option(trim(path)//"/region_ids")) then - shape_option=option_shape(trim(path)//"/region_ids") - allocate(region_ids(1:shape_option(1))) - call get_option(trim(path)//"/region_ids", region_ids, stat) - end if - - ! Set field - if((associated(field%mesh%region_ids)).and.(stat==0)) then - do ele = 1, element_count(field%mesh) - if(any(region_ids==field%mesh%region_ids(ele))) then - call set(field, ele_nodes(field, ele), ele_val(tempfield, ele)) - end if - end do - else - call set(field, tempfield) - end if - - end subroutine apply_region_ids_scalar - - subroutine apply_region_ids_vector(field, tempfield, path) - - type(vector_field), intent(inout) :: field - type(vector_field), intent(in) :: tempfield - character(len=*), intent(in) :: path - - integer :: stat, ele, dim - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: region_ids - - stat = 1 - if(have_option(trim(path)//"/region_ids")) then - shape_option=option_shape(trim(path)//"/region_ids") - allocate(region_ids(1:shape_option(1))) - call get_option(trim(path)//"/region_ids", region_ids, stat) - end if - - ! Get dimension - call get_option("/geometry/dimension", dim) - - ! Set field - if((associated(field%mesh%region_ids)).and.(stat==0)) then - do ele = 1, element_count(field%mesh) - if(any(region_ids==field%mesh%region_ids(ele))) then - call set(field, ele_nodes(field, ele), ele_val(tempfield, ele)) - end if - end do - else - call set(field, tempfield) - end if - - end subroutine apply_region_ids_vector - - subroutine apply_region_ids_tensor(field, tempfield, path) - - type(tensor_field), intent(inout) :: field - type(tensor_field), intent(in) :: tempfield - character(len=*), intent(in) :: path - - integer :: stat, ele - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: region_ids - - stat = 1 - if(have_option(trim(path)//"/region_ids")) then - shape_option=option_shape(trim(path)//"/region_ids") - allocate(region_ids(1:shape_option(1))) - call get_option(trim(path)//"/region_ids", region_ids, stat) - end if - - ! Set field - if((associated(field%mesh%region_ids)).and.(stat==0)) then - do ele = 1, element_count(field%mesh) - if(any(region_ids==field%mesh%region_ids(ele))) then - call set(field, ele_nodes(field, ele), ele_val(tempfield, ele)) - end if - end do - else - call set(field, tempfield) - end if - - end subroutine apply_region_ids_tensor + end do + + call deallocate(tempfield) + + end subroutine initialise_tensor_field_over_regions + + subroutine apply_region_ids_scalar(field, tempfield, path) + + type(scalar_field), intent(inout) :: field + type(scalar_field), intent(in) :: tempfield + character(len=*), intent(in) :: path + + integer :: stat, ele + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: region_ids + + stat = 1 + if(have_option(trim(path)//"/region_ids")) then + shape_option=option_shape(trim(path)//"/region_ids") + allocate(region_ids(1:shape_option(1))) + call get_option(trim(path)//"/region_ids", region_ids, stat) + end if + + ! Set field + if((associated(field%mesh%region_ids)).and.(stat==0)) then + do ele = 1, element_count(field%mesh) + if(any(region_ids==field%mesh%region_ids(ele))) then + call set(field, ele_nodes(field, ele), ele_val(tempfield, ele)) + end if + end do + else + call set(field, tempfield) + end if + + end subroutine apply_region_ids_scalar + + subroutine apply_region_ids_vector(field, tempfield, path) + + type(vector_field), intent(inout) :: field + type(vector_field), intent(in) :: tempfield + character(len=*), intent(in) :: path + + integer :: stat, ele, dim + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: region_ids + + stat = 1 + if(have_option(trim(path)//"/region_ids")) then + shape_option=option_shape(trim(path)//"/region_ids") + allocate(region_ids(1:shape_option(1))) + call get_option(trim(path)//"/region_ids", region_ids, stat) + end if + + ! Get dimension + call get_option("/geometry/dimension", dim) + + ! Set field + if((associated(field%mesh%region_ids)).and.(stat==0)) then + do ele = 1, element_count(field%mesh) + if(any(region_ids==field%mesh%region_ids(ele))) then + call set(field, ele_nodes(field, ele), ele_val(tempfield, ele)) + end if + end do + else + call set(field, tempfield) + end if + + end subroutine apply_region_ids_vector + + subroutine apply_region_ids_tensor(field, tempfield, path) + + type(tensor_field), intent(inout) :: field + type(tensor_field), intent(in) :: tempfield + character(len=*), intent(in) :: path + + integer :: stat, ele + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: region_ids + + stat = 1 + if(have_option(trim(path)//"/region_ids")) then + shape_option=option_shape(trim(path)//"/region_ids") + allocate(region_ids(1:shape_option(1))) + call get_option(trim(path)//"/region_ids", region_ids, stat) + end if + + ! Set field + if((associated(field%mesh%region_ids)).and.(stat==0)) then + do ele = 1, element_count(field%mesh) + if(any(region_ids==field%mesh%region_ids(ele))) then + call set(field, ele_nodes(field, ele), ele_val(tempfield, ele)) + end if + end do + else + call set(field, tempfield) + end if + + end subroutine apply_region_ids_tensor end module initialise_fields_module diff --git a/preprocessor/Physics_From_Options.F90 b/preprocessor/Physics_From_Options.F90 index 6a77a57cef..1a8e05c244 100644 --- a/preprocessor/Physics_From_Options.F90 +++ b/preprocessor/Physics_From_Options.F90 @@ -28,82 +28,82 @@ module physics_from_options -use spud -use fldebug -use fields -use state_module + use spud + use fldebug + use fields + use state_module -implicit none + implicit none -private + private -public get_fs_reference_density_from_options, convert_free_surface_to_pressure + public get_fs_reference_density_from_options, convert_free_surface_to_pressure contains - subroutine get_fs_reference_density_from_options(rho0, phase_path) - ! The density returned by this routine defines the relation between - ! free surface elevation and barotropic pressure: p = \rho0 g \eta - ! For equation types Boussinesq and ShallowWater this is simply 1.0 - ! (corresponding to the constant in front of the du/dt term in the mom. eqn.) - ! For LinearMomentum, we return the reference density. By default it is indeed - ! assumed that the density near the f.s. is equal to the reference density and - ! thus p = \rho0 g \eta. Density variations are taken into account in assemble/Free_Surface.F90 - ! when using the variable_density option under the fs. bc. - - real, intent(out) :: rho0 - character(len=*), intent(in), optional :: phase_path - - if (have_option(trim(phase_path)//'/vector_field::Velocity/prognostic/equation::ShallowWater') .or. & - have_option(trim(phase_path)//'/vector_field::Velocity/prognostic/equation::Boussinesq')) then - - ! with Boussinesq \rho0 is already divided out of the mom. eqn. (and therefore out of Pressure) - ! same goes for ShallowWater - rho0 = 1.0 - - else if (have_option(trim(phase_path)//'/vector_field::Velocity/prognostic/equation::LinearMomentum')) then - if (have_option(trim(phase_path)//'/equation_of_state/fluids/linear/')) then - - ! for other equation types the pressure is really the pressure so we do need to - ! divide by the real reference density - call get_option(trim(phase_path)//'/equation_of_state/fluids/linear/reference_density', rho0) - else if (have_option(trim(phase_path)//'/equation_of_state/fluids/ocean_pade_approximation/')) then - ! The reference density is hard-coded to be 1.0 for the Ocean Pade Approximation - rho0=1.0 + subroutine get_fs_reference_density_from_options(rho0, phase_path) + ! The density returned by this routine defines the relation between + ! free surface elevation and barotropic pressure: p = \rho0 g \eta + ! For equation types Boussinesq and ShallowWater this is simply 1.0 + ! (corresponding to the constant in front of the du/dt term in the mom. eqn.) + ! For LinearMomentum, we return the reference density. By default it is indeed + ! assumed that the density near the f.s. is equal to the reference density and + ! thus p = \rho0 g \eta. Density variations are taken into account in assemble/Free_Surface.F90 + ! when using the variable_density option under the fs. bc. + + real, intent(out) :: rho0 + character(len=*), intent(in), optional :: phase_path + + if (have_option(trim(phase_path)//'/vector_field::Velocity/prognostic/equation::ShallowWater') .or. & + have_option(trim(phase_path)//'/vector_field::Velocity/prognostic/equation::Boussinesq')) then + + ! with Boussinesq \rho0 is already divided out of the mom. eqn. (and therefore out of Pressure) + ! same goes for ShallowWater + rho0 = 1.0 + + else if (have_option(trim(phase_path)//'/vector_field::Velocity/prognostic/equation::LinearMomentum')) then + if (have_option(trim(phase_path)//'/equation_of_state/fluids/linear/')) then + + ! for other equation types the pressure is really the pressure so we do need to + ! divide by the real reference density + call get_option(trim(phase_path)//'/equation_of_state/fluids/linear/reference_density', rho0) + else if (have_option(trim(phase_path)//'/equation_of_state/fluids/ocean_pade_approximation/')) then + ! The reference density is hard-coded to be 1.0 for the Ocean Pade Approximation + rho0=1.0 + else + ewrite(-1,*) "Unless using Boussinesq Velocity, you must specify a" + ewrite(-1,*) "linear or pade equation of state for the free surface." + FLExit("Error retrieving reference density from options.") + end if + else if (.not. have_option(trim(phase_path)//'vector_field::Velocity/prognostic')) then + ! this should have been options checked somewhere else, so flabort + FLAbort("Need a prognostic velocity to retrieve free surface reference density.") else - ewrite(-1,*) "Unless using Boussinesq Velocity, you must specify a" - ewrite(-1,*) "linear or pade equation of state for the free surface." - FLExit("Error retrieving reference density from options.") + ! this must mean it doesn't have Velocity equation option, or an unknown equation type + ! both are not allowed in the schema, so flabort + FLAbort("Unknown equation type for Velocity") + endif + + end subroutine get_fs_reference_density_from_options + + subroutine convert_free_surface_to_pressure(field, phase_path) + type(scalar_field), intent(inout) :: field + character(len=*), intent(in) :: phase_path + + real :: rho0, gravity_magnitude + + call get_fs_reference_density_from_options(rho0, phase_path) + + if(have_option("/physical_parameters/gravity")) then + call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) + ! Note this is rescale is limited to the region this condition is applied + call scale(field, gravity_magnitude * rho0) + else + !FLExit("Specifying a free surface initial condition requires gravity to be defined.") + ewrite(-1,*) "Converting free-surface height to a pressure field requires gravity to be defined." + FLExit("Have you specified a free-surface initial condition without defining gravity?") end if - else if (.not. have_option(trim(phase_path)//'vector_field::Velocity/prognostic')) then - ! this should have been options checked somewhere else, so flabort - FLAbort("Need a prognostic velocity to retrieve free surface reference density.") - else - ! this must mean it doesn't have Velocity equation option, or an unknown equation type - ! both are not allowed in the schema, so flabort - FLAbort("Unknown equation type for Velocity") - endif - - end subroutine get_fs_reference_density_from_options - - subroutine convert_free_surface_to_pressure(field, phase_path) - type(scalar_field), intent(inout) :: field - character(len=*), intent(in) :: phase_path - - real :: rho0, gravity_magnitude - - call get_fs_reference_density_from_options(rho0, phase_path) - - if(have_option("/physical_parameters/gravity")) then - call get_option("/physical_parameters/gravity/magnitude", gravity_magnitude) - ! Note this is rescale is limited to the region this condition is applied - call scale(field, gravity_magnitude * rho0) - else - !FLExit("Specifying a free surface initial condition requires gravity to be defined.") - ewrite(-1,*) "Converting free-surface height to a pressure field requires gravity to be defined." - FLExit("Have you specified a free-surface initial condition without defining gravity?") - end if - - end subroutine convert_free_surface_to_pressure + + end subroutine convert_free_surface_to_pressure end module physics_from_options diff --git a/preprocessor/Populate_State.F90 b/preprocessor/Populate_State.F90 index 157458902a..d8f06ef191 100644 --- a/preprocessor/Populate_State.F90 +++ b/preprocessor/Populate_State.F90 @@ -28,3929 +28,3929 @@ #include "fdebug.h" module populate_state_module - use fldebug - use global_parameters, only: OPTION_PATH_LEN, is_active_process, pi, & -no_active_processes, topology_mesh_name, adaptivity_mesh_name, & -periodic_boundary_option_path, domain_bbox, domain_volume, surface_radius - use futils, only: int2str, present_and_true, starts_with - use quadrature - use element_numbering - use elements - use spud - use mpi_interfaces, only: MPI_bcast - use parallel_tools - use data_structures - use metric_tools - use transform_elements - use fields - use profiler - use state_module - use boundary_conditions, only: set_dirichlet_consistent - use mesh_files - use vtk_cache_module - use field_options - use reserve_state_module - use field_options - use halos - use surfacelabels - use diagnostic_variables, only: convergence_field, steady_state_field - use climatology - use coordinates - use tictoc - use hadapt_extrude - use nemo_states_module - use initialise_fields_module - use boundary_conditions_from_options - use fields_halos - use read_triangle - use initialise_ocean_forcing_module - - implicit none - - private - - public populate_state - public populate_state_module_check_options - public insert_external_mesh, insert_derived_meshes, & - allocate_field_as_constant, allocate_and_insert_fields, & - initialise_prognostic_fields, set_prescribed_field_values, & - alias_fields, mesh_name, & - allocate_and_insert_auxilliary_fields, & - initialise_field, allocate_metric_limits, & - make_mesh_periodic_from_options, make_mesh_unperiodic_from_options, & - compute_domain_statistics - - interface allocate_field_as_constant - - module procedure allocate_field_as_constant_scalar, allocate_field_as_constant_vector, & - allocate_field_as_constant_tensor - - end interface allocate_field_as_constant - - !! A list of locations in which additional scalar/vector/tensor fields - !! are to be found. These are absolute paths in the schema. - character(len=OPTION_PATH_LEN), dimension(7) :: additional_fields_absolute=& - (/ & - "/ocean_biology/pznd ", & - "/ocean_biology/six_component ", & - "/ocean_forcing/iceshelf_meltrate/Holland08 ", & - "/ocean_forcing/bulk_formulae/output_fluxes_diagnostics ", & - "/material_phase[0]/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/dynamic_les ", & - "/material_phase[0]/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/second_order", & - "/material_phase[0]/sediment/ " & - /) - - !! A list of relative paths under /material_phase[i] - !! that are searched for additional fields to be added. - character(len=OPTION_PATH_LEN), dimension(20) :: additional_fields_relative=& - (/ & - "/subgridscale_parameterisations/Mellor_Yamada ", & - "/subgridscale_parameterisations/prescribed_diffusivity ", & - "/subgridscale_parameterisations/GLS ", & - "/subgridscale_parameterisations/k-epsilon ", & - "/subgridscale_parameterisations/k-epsilon/debugging_options/source_term_output_fields ", & - "/subgridscale_parameterisations/k-epsilon/debugging_options/prescribed_source_terms ", & - "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/second_order", & - "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/fourth_order", & - "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/wale ", & - "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/dynamic_les ", & - "/vector_field::Velocity/prognostic/spatial_discretisation/discontinuous_galerkin/les_model/ ", & - "/vector_field::Velocity/prognostic/spatial_discretisation/discontinuous_galerkin/les_model/debug/ ", & - "/vector_field::Velocity/prognostic/equation::ShallowWater ", & - "/vector_field::Velocity/prognostic/equation::ShallowWater/bottom_drag ", & - "/vector_field::BedShearStress/diagnostic/calculation_method/velocity_gradient ", & - "/population_balance[#]/abscissa/ ", & - "/population_balance[#]/weights/ ", & - "/population_balance[#]/weighted_abscissa/ ", & - "/population_balance[#]/moments/ ", & - "/population_balance[#]/statistics/ " & - /) - - !! Relative paths under a field that are searched for grandchildren - !! (moved here because of extremely obscure intel ICE -Stephan) - character(len=OPTION_PATH_LEN), dimension(1):: & - grandchild_paths = (/& - & "/spatial_discretisation/inner_element" & - /) + use fldebug + use global_parameters, only: OPTION_PATH_LEN, is_active_process, pi, & + no_active_processes, topology_mesh_name, adaptivity_mesh_name, & + periodic_boundary_option_path, domain_bbox, domain_volume, surface_radius + use futils, only: int2str, present_and_true, starts_with + use quadrature + use element_numbering + use elements + use spud + use mpi_interfaces, only: MPI_bcast + use parallel_tools + use data_structures + use metric_tools + use transform_elements + use fields + use profiler + use state_module + use boundary_conditions, only: set_dirichlet_consistent + use mesh_files + use vtk_cache_module + use field_options + use reserve_state_module + use field_options + use halos + use surfacelabels + use diagnostic_variables, only: convergence_field, steady_state_field + use climatology + use coordinates + use tictoc + use hadapt_extrude + use nemo_states_module + use initialise_fields_module + use boundary_conditions_from_options + use fields_halos + use read_triangle + use initialise_ocean_forcing_module + + implicit none + + private + + public populate_state + public populate_state_module_check_options + public insert_external_mesh, insert_derived_meshes, & + allocate_field_as_constant, allocate_and_insert_fields, & + initialise_prognostic_fields, set_prescribed_field_values, & + alias_fields, mesh_name, & + allocate_and_insert_auxilliary_fields, & + initialise_field, allocate_metric_limits, & + make_mesh_periodic_from_options, make_mesh_unperiodic_from_options, & + compute_domain_statistics + + interface allocate_field_as_constant + + module procedure allocate_field_as_constant_scalar, allocate_field_as_constant_vector, & + allocate_field_as_constant_tensor + + end interface allocate_field_as_constant + + !! A list of locations in which additional scalar/vector/tensor fields + !! are to be found. These are absolute paths in the schema. + character(len=OPTION_PATH_LEN), dimension(7) :: additional_fields_absolute=& + (/ & + "/ocean_biology/pznd ", & + "/ocean_biology/six_component ", & + "/ocean_forcing/iceshelf_meltrate/Holland08 ", & + "/ocean_forcing/bulk_formulae/output_fluxes_diagnostics ", & + "/material_phase[0]/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/dynamic_les ", & + "/material_phase[0]/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/second_order", & + "/material_phase[0]/sediment/ " & + /) + + !! A list of relative paths under /material_phase[i] + !! that are searched for additional fields to be added. + character(len=OPTION_PATH_LEN), dimension(20) :: additional_fields_relative=& + (/ & + "/subgridscale_parameterisations/Mellor_Yamada ", & + "/subgridscale_parameterisations/prescribed_diffusivity ", & + "/subgridscale_parameterisations/GLS ", & + "/subgridscale_parameterisations/k-epsilon ", & + "/subgridscale_parameterisations/k-epsilon/debugging_options/source_term_output_fields ", & + "/subgridscale_parameterisations/k-epsilon/debugging_options/prescribed_source_terms ", & + "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/second_order", & + "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/fourth_order", & + "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/wale ", & + "/vector_field::Velocity/prognostic/spatial_discretisation/continuous_galerkin/les_model/dynamic_les ", & + "/vector_field::Velocity/prognostic/spatial_discretisation/discontinuous_galerkin/les_model/ ", & + "/vector_field::Velocity/prognostic/spatial_discretisation/discontinuous_galerkin/les_model/debug/ ", & + "/vector_field::Velocity/prognostic/equation::ShallowWater ", & + "/vector_field::Velocity/prognostic/equation::ShallowWater/bottom_drag ", & + "/vector_field::BedShearStress/diagnostic/calculation_method/velocity_gradient ", & + "/population_balance[#]/abscissa/ ", & + "/population_balance[#]/weights/ ", & + "/population_balance[#]/weighted_abscissa/ ", & + "/population_balance[#]/moments/ ", & + "/population_balance[#]/statistics/ " & + /) + + !! Relative paths under a field that are searched for grandchildren + !! (moved here because of extremely obscure intel ICE -Stephan) + character(len=OPTION_PATH_LEN), dimension(1):: & + grandchild_paths = (/& + & "/spatial_discretisation/inner_element" & + /) contains - subroutine populate_state(states) - type(state_type), pointer, dimension(:) :: states + subroutine populate_state(states) + type(state_type), pointer, dimension(:) :: states - integer :: nstates ! number of states - integer :: i + integer :: nstates ! number of states + integer :: i - ewrite(1,*) "In populate_state" - call profiler_tic("I/O") - call tictoc_clear(TICTOC_ID_IO_READ) + ewrite(1,*) "In populate_state" + call profiler_tic("I/O") + call tictoc_clear(TICTOC_ID_IO_READ) - ! Find out how many states there are - nstates=option_count("/material_phase") - allocate(states(1:nstates)) - do i = 1, nstates - call nullify(states(i)) - call set_option_path(states(i), "/material_phase["//int2str(i-1)//"]") - end do + ! Find out how many states there are + nstates=option_count("/material_phase") + allocate(states(1:nstates)) + do i = 1, nstates + call nullify(states(i)) + call set_option_path(states(i), "/material_phase["//int2str(i-1)//"]") + end do - call initialise_ocean_forcing_readers + call initialise_ocean_forcing_readers - call insert_external_mesh(states, save_vtk_cache = .true.) + call insert_external_mesh(states, save_vtk_cache = .true.) - call insert_derived_meshes(states) - - !If any meshes have constraints, allocate an appropriate trace mesh - call insert_trace_meshes(states) - - call compute_domain_statistics(states) - - call allocate_and_insert_fields(states) - - call initialise_prognostic_fields(states, save_vtk_cache=.true., & - initial_mesh=.true.) - - call set_prescribed_field_values(states, initial_mesh=.true.) - - call populate_boundary_conditions(states) - - call set_boundary_conditions_values(states) - - call set_dirichlet_consistent(states) - - call alias_fields(states) - - call create_reserve_state(states) - - call tictoc_report(2, TICTOC_ID_IO_READ) - call profiler_toc("I/O") - ewrite(1, *) "Exiting populate_state" - end subroutine populate_state - - subroutine insert_external_mesh(states, save_vtk_cache) - !!< Read in external meshes from file as specified in options tree and - !!< insert in state - type(state_type), intent(inout), dimension(:) :: states - !! By default the vtk_cache, build up by the vtu mesh reads in this - !! subroutine, is flushed at the end of this subroutine. This cache can be - !! reused however in subsequent calls reading from vtu files. - logical, intent(in), optional:: save_vtk_cache - - type(mesh_type) :: mesh - type(vector_field) :: position - type(vector_field), pointer :: position_ptr - character(len=OPTION_PATH_LEN) :: mesh_path, mesh_file_name,& - & mesh_file_format, from_file_path - integer, dimension(:), pointer :: coplanar_ids - integer, dimension(4) :: mesh_dims - integer :: i, j, nmeshes, nstates, quad_degree, stat - type(element_type), pointer :: shape - type(quadrature_type), pointer :: quad - logical :: from_file, extruded - integer :: dim, mdim, loc, column_ids - integer :: quad_family - - call tic(TICTOC_ID_IO_READ) - - ! Find out how many states there are - nstates=option_count("/material_phase") - ! Get number of meshes - nmeshes=option_count("/geometry/mesh") - ewrite(2,*) "There are", nmeshes, "meshes." - - external_mesh_loop: do i=0, nmeshes-1 - - ! Save mesh path - mesh_path="/geometry/mesh["//int2str(i)//"]" - - from_file_path = trim(mesh_path) // "/from_file" - from_file = have_option(from_file_path) - if (.not. from_file) then - from_file_path = trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file" - extruded = have_option(from_file_path) - else - extruded = .false. - end if - - if(from_file .or. extruded) then - - ! Get file format - ! Can remove stat test when mesh format data backwards compatibility is removed - call get_option(trim(from_file_path)//"/format/name", mesh_file_format, stat) - ! Can remove following when mesh format data backwards compatibility is removed - if(stat /= 0) then - ewrite(0, *) "Warning: Mesh format name attribute missing for mesh " // trim(mesh_path) - call get_option(trim(from_file_path)//"/format", mesh_file_format) - end if - - ! Get filename for mesh, and other options - call get_option(trim(from_file_path)//"/file_name", mesh_file_name) - call get_option("/geometry/quadrature/degree", quad_degree) - quad_family = get_quad_family() - - ! to make sure that the dimension is set even if MPI is not being used - call get_option('/geometry/dimension', dim) - - if (is_active_process) then - select case (mesh_file_format) - case ("triangle", "gmsh", "exodusii") - ! Get mesh dimension if present - call get_option(trim(mesh_path)//"/from_file/dimension", mdim, stat) - ! Read mesh - if(stat==0) then - position=read_mesh_files(trim(mesh_file_name), & - quad_degree=quad_degree, & - quad_family=quad_family, mdim=mdim, & - format=mesh_file_format) - else - position=read_mesh_files(trim(mesh_file_name), & - quad_degree=quad_degree, & - quad_family=quad_family, & - format=mesh_file_format) - end if - ! After successfully reading in an ExodusII mesh, change the option - ! mesh file format to "gmsh", as the write routines for ExodusII are currently - ! not implemented. Thus, checkpoints etc are dumped as gmsh mesh files - if (trim(mesh_file_format)=="exodusii") then - mesh_file_format = "gmsh" - call set_option_attribute(trim(from_file_path)//"/format/name", trim(mesh_file_format), stat=stat) - if (stat /= SPUD_NO_ERROR) then - FLAbort("Failed to set the mesh format to gmsh (required for checkpointing). Spud error code is: "//int2str(stat)) - end if - end if - mesh=position%mesh - case ("vtu") - position_ptr => vtk_cache_read_positions_field(mesh_file_name) - ! No hybrid mesh support here - assert(ele_count(position_ptr) > 0) - dim = position_ptr%dim - loc = ele_loc(position_ptr, 1) - - ! Generate a copy, and swap the quadrature degree - ! Note: Even if positions_ptr has the correct quadrature degree, it - ! won't have any faces and hence a copy is still required (as - ! add_faces is a construction routine only) - allocate(quad) - allocate(shape) - quad = make_quadrature(loc, dim, degree = quad_degree, family=quad_family) - shape = make_element_shape(loc, dim, 1, quad) - call allocate(mesh, nodes = node_count(position_ptr), elements = ele_count(position_ptr), shape = shape, name = position_ptr%mesh%name) - do j = 1, ele_count(mesh) - call set_ele_nodes(mesh, j, ele_nodes(position_ptr%mesh, j)) - end do - call add_faces(mesh) - call allocate(position, dim, mesh, position_ptr%name) - call set(position, position_ptr) - call deallocate(mesh) - call deallocate(shape) - call deallocate(quad) - deallocate(quad) - deallocate(shape) - - mesh = position%mesh - case default - ewrite(-1,*) trim(mesh_file_format), " is not a valid format for a mesh file" - FLAbort("Invalid format for mesh file") - end select - end if - - if (no_active_processes /= getnprocs()) then - ! not all processes are active, they need to be told the mesh dimensions - - ! receive the mesh dimension from rank 0 - if (getrank()==0) then - if (is_active_process) then - ! normally rank 0 should always be active, so it knows the dimensions - mesh_dims(1)=mesh_dim(mesh) - mesh_dims(2)=ele_loc(mesh,1) - if (associated(mesh%columns)) then - mesh_dims(3)=1 - else - mesh_dims(3)=0 - end if - if (mesh%faces%has_discontinuous_internal_boundaries) then - mesh_dims(4)=1 - else - mesh_dims(4)=0 - end if - ! The coordinate dimension is not the same as the mesh dimension - ! in the case of spherical shells, and needs to be broadcast as - ! well. And this needs to be here to allow for the special case - ! below - dim=position%dim - else - ! this is a special case for a unit test with 1 inactive process - call get_option('/geometry/dimension', mesh_dims(1)) - mesh_dims(2)=mesh_dims(1)+1 - mesh_dims(3)=0 - mesh_dims(4)=0 - dim = mesh_dims(1) - end if - end if - call MPI_bcast(mesh_dims, 4, getpinteger(), 0, MPI_COMM_FEMTOOLS, stat) - call MPI_bcast(dim, 1, getpinteger(), 0, MPI_COMM_FEMTOOLS, stat) - end if - - - if (.not. is_active_process) then - ! is_active_process records whether we have data on disk or not - ! see the comment in Global_Parameters. In this block, - ! we want to allocate an empty mesh and positions. - - mdim=mesh_dims(1) - loc=mesh_dims(2) - column_ids=mesh_dims(3) - - allocate(quad) - allocate(shape) - quad = make_quadrature(loc, mdim, degree=quad_degree, family=quad_family) - shape=make_element_shape(loc, mdim, 1, quad) - call allocate(mesh, nodes=0, elements=0, shape=shape, name="EmptyMesh") - call allocate(position, dim, mesh, "EmptyCoordinate") - call add_faces(mesh) - if (mesh_dims(4)>0) then - ! rank 0 has element ownership for facets, allowing for multi-valued internal - ! facets (needed for periodic meshes). Setting this flag will allow us the - ! same when we receive facets after the redecomposition - mesh%faces%has_discontinuous_internal_boundaries=.true. + call insert_derived_meshes(states) + + !If any meshes have constraints, allocate an appropriate trace mesh + call insert_trace_meshes(states) + + call compute_domain_statistics(states) + + call allocate_and_insert_fields(states) + + call initialise_prognostic_fields(states, save_vtk_cache=.true., & + initial_mesh=.true.) + + call set_prescribed_field_values(states, initial_mesh=.true.) + + call populate_boundary_conditions(states) + + call set_boundary_conditions_values(states) + + call set_dirichlet_consistent(states) + + call alias_fields(states) + + call create_reserve_state(states) + + call tictoc_report(2, TICTOC_ID_IO_READ) + call profiler_toc("I/O") + ewrite(1, *) "Exiting populate_state" + end subroutine populate_state + + subroutine insert_external_mesh(states, save_vtk_cache) + !!< Read in external meshes from file as specified in options tree and + !!< insert in state + type(state_type), intent(inout), dimension(:) :: states + !! By default the vtk_cache, build up by the vtu mesh reads in this + !! subroutine, is flushed at the end of this subroutine. This cache can be + !! reused however in subsequent calls reading from vtu files. + logical, intent(in), optional:: save_vtk_cache + + type(mesh_type) :: mesh + type(vector_field) :: position + type(vector_field), pointer :: position_ptr + character(len=OPTION_PATH_LEN) :: mesh_path, mesh_file_name,& + & mesh_file_format, from_file_path + integer, dimension(:), pointer :: coplanar_ids + integer, dimension(4) :: mesh_dims + integer :: i, j, nmeshes, nstates, quad_degree, stat + type(element_type), pointer :: shape + type(quadrature_type), pointer :: quad + logical :: from_file, extruded + integer :: dim, mdim, loc, column_ids + integer :: quad_family + + call tic(TICTOC_ID_IO_READ) + + ! Find out how many states there are + nstates=option_count("/material_phase") + ! Get number of meshes + nmeshes=option_count("/geometry/mesh") + ewrite(2,*) "There are", nmeshes, "meshes." + + external_mesh_loop: do i=0, nmeshes-1 + + ! Save mesh path + mesh_path="/geometry/mesh["//int2str(i)//"]" + + from_file_path = trim(mesh_path) // "/from_file" + from_file = have_option(from_file_path) + if (.not. from_file) then + from_file_path = trim(mesh_path) // "/from_mesh/extrude/checkpoint_from_file" + extruded = have_option(from_file_path) + else + extruded = .false. + end if + + if(from_file .or. extruded) then + + ! Get file format + ! Can remove stat test when mesh format data backwards compatibility is removed + call get_option(trim(from_file_path)//"/format/name", mesh_file_format, stat) + ! Can remove following when mesh format data backwards compatibility is removed + if(stat /= 0) then + ewrite(0, *) "Warning: Mesh format name attribute missing for mesh " // trim(mesh_path) + call get_option(trim(from_file_path)//"/format", mesh_file_format) end if - if (column_ids>0) then - ! the association status of mesh%columns should be collective - allocate(mesh%columns(1:0)) + + ! Get filename for mesh, and other options + call get_option(trim(from_file_path)//"/file_name", mesh_file_name) + call get_option("/geometry/quadrature/degree", quad_degree) + quad_family = get_quad_family() + + ! to make sure that the dimension is set even if MPI is not being used + call get_option('/geometry/dimension', dim) + + if (is_active_process) then + select case (mesh_file_format) + case ("triangle", "gmsh", "exodusii") + ! Get mesh dimension if present + call get_option(trim(mesh_path)//"/from_file/dimension", mdim, stat) + ! Read mesh + if(stat==0) then + position=read_mesh_files(trim(mesh_file_name), & + quad_degree=quad_degree, & + quad_family=quad_family, mdim=mdim, & + format=mesh_file_format) + else + position=read_mesh_files(trim(mesh_file_name), & + quad_degree=quad_degree, & + quad_family=quad_family, & + format=mesh_file_format) + end if + ! After successfully reading in an ExodusII mesh, change the option + ! mesh file format to "gmsh", as the write routines for ExodusII are currently + ! not implemented. Thus, checkpoints etc are dumped as gmsh mesh files + if (trim(mesh_file_format)=="exodusii") then + mesh_file_format = "gmsh" + call set_option_attribute(trim(from_file_path)//"/format/name", trim(mesh_file_format), stat=stat) + if (stat /= SPUD_NO_ERROR) then + FLAbort("Failed to set the mesh format to gmsh (required for checkpointing). Spud error code is: "//int2str(stat)) + end if + end if + mesh=position%mesh + case ("vtu") + position_ptr => vtk_cache_read_positions_field(mesh_file_name) + ! No hybrid mesh support here + assert(ele_count(position_ptr) > 0) + dim = position_ptr%dim + loc = ele_loc(position_ptr, 1) + + ! Generate a copy, and swap the quadrature degree + ! Note: Even if positions_ptr has the correct quadrature degree, it + ! won't have any faces and hence a copy is still required (as + ! add_faces is a construction routine only) + allocate(quad) + allocate(shape) + quad = make_quadrature(loc, dim, degree = quad_degree, family=quad_family) + shape = make_element_shape(loc, dim, 1, quad) + call allocate(mesh, nodes = node_count(position_ptr), elements = ele_count(position_ptr), shape = shape, name = position_ptr%mesh%name) + do j = 1, ele_count(mesh) + call set_ele_nodes(mesh, j, ele_nodes(position_ptr%mesh, j)) + end do + call add_faces(mesh) + call allocate(position, dim, mesh, position_ptr%name) + call set(position, position_ptr) + call deallocate(mesh) + call deallocate(shape) + call deallocate(quad) + deallocate(quad) + deallocate(shape) + + mesh = position%mesh + case default + ewrite(-1,*) trim(mesh_file_format), " is not a valid format for a mesh file" + FLAbort("Invalid format for mesh file") + end select end if - ! Reference counting cleanups. - call deallocate(mesh) - call deallocate(quad) - call deallocate(shape) + if (no_active_processes /= getnprocs()) then + ! not all processes are active, they need to be told the mesh dimensions + + ! receive the mesh dimension from rank 0 + if (getrank()==0) then + if (is_active_process) then + ! normally rank 0 should always be active, so it knows the dimensions + mesh_dims(1)=mesh_dim(mesh) + mesh_dims(2)=ele_loc(mesh,1) + if (associated(mesh%columns)) then + mesh_dims(3)=1 + else + mesh_dims(3)=0 + end if + if (mesh%faces%has_discontinuous_internal_boundaries) then + mesh_dims(4)=1 + else + mesh_dims(4)=0 + end if + ! The coordinate dimension is not the same as the mesh dimension + ! in the case of spherical shells, and needs to be broadcast as + ! well. And this needs to be here to allow for the special case + ! below + dim=position%dim + else + ! this is a special case for a unit test with 1 inactive process + call get_option('/geometry/dimension', mesh_dims(1)) + mesh_dims(2)=mesh_dims(1)+1 + mesh_dims(3)=0 + mesh_dims(4)=0 + dim = mesh_dims(1) + end if + end if + call MPI_bcast(mesh_dims, 4, getpinteger(), 0, MPI_COMM_FEMTOOLS, stat) + call MPI_bcast(dim, 1, getpinteger(), 0, MPI_COMM_FEMTOOLS, stat) + end if - deallocate(quad) - deallocate(shape) - end if + if (.not. is_active_process) then + ! is_active_process records whether we have data on disk or not + ! see the comment in Global_Parameters. In this block, + ! we want to allocate an empty mesh and positions. + + mdim=mesh_dims(1) + loc=mesh_dims(2) + column_ids=mesh_dims(3) + + allocate(quad) + allocate(shape) + quad = make_quadrature(loc, mdim, degree=quad_degree, family=quad_family) + shape=make_element_shape(loc, mdim, 1, quad) + call allocate(mesh, nodes=0, elements=0, shape=shape, name="EmptyMesh") + call allocate(position, dim, mesh, "EmptyCoordinate") + call add_faces(mesh) + if (mesh_dims(4)>0) then + ! rank 0 has element ownership for facets, allowing for multi-valued internal + ! facets (needed for periodic meshes). Setting this flag will allow us the + ! same when we receive facets after the redecomposition + mesh%faces%has_discontinuous_internal_boundaries=.true. + end if + if (column_ids>0) then + ! the association status of mesh%columns should be collective + allocate(mesh%columns(1:0)) + end if + + ! Reference counting cleanups. + call deallocate(mesh) + call deallocate(quad) + call deallocate(shape) + + deallocate(quad) + deallocate(shape) - ! if there is a derived mesh which specifies periodic bcs - ! to be *removed*, we assume the external mesh is periodic - mesh%periodic = option_count("/geometry/mesh/from_mesh/& - &periodic_boundary_conditions/remove_periodicity")>0 + end if - ! Get mesh name. This must be done after the mesh file has - ! been read otherwise the filename is automatically inserted - ! as the mesh name. - call get_option(trim(mesh_path)//"/name", mesh%name) + ! if there is a derived mesh which specifies periodic bcs + ! to be *removed*, we assume the external mesh is periodic + mesh%periodic = option_count("/geometry/mesh/from_mesh/& + &periodic_boundary_conditions/remove_periodicity")>0 - ! Set mesh option path. - mesh%option_path = mesh_path + ! Get mesh name. This must be done after the mesh file has + ! been read otherwise the filename is automatically inserted + ! as the mesh name. + call get_option(trim(mesh_path)//"/name", mesh%name) - ! Copy those changes back to the descriptor under position%mesh - position%mesh=mesh + ! Set mesh option path. + mesh%option_path = mesh_path - if (mesh%name/="CoordinateMesh") then - position%name=trim(mesh%name)//"Coordinate" - else - position%name="Coordinate" - end if + ! Copy those changes back to the descriptor under position%mesh + position%mesh=mesh - ! If running in parallel, additionally read in halo information and register the elements halo - if(isparallel()) then - if (no_active_processes == 1) then - call create_empty_halo(position) + if (mesh%name/="CoordinateMesh") then + position%name=trim(mesh%name)//"Coordinate" else - call read_halos(mesh_file_name, position) + position%name="Coordinate" end if - ! Local element ordering needs to be consistent between processes, otherwise - ! code in Halos_Repair (used in halo construction of derived meshes) will fail - if (.not. verify_consistent_local_element_numbering(position%mesh)) then - ewrite(-1,*) "The local element ordering is not the same between processes" - ewrite(-1,*) "that see the same element. This is a necessary condition on the" - ewrite(-1,*) "decomposed input meshes for fluidity. The fact that you've" - ewrite(-1,*) "obtained such meshes is likely a bug in fldecomp or the" - ewrite(-1,*) "checkpointing code. Please report to the fluidity mailing" - ewrite(-1,*) "list and state exactly how you've obtained your input files." - FLAbort("Inconsistent local element ordering") + + ! If running in parallel, additionally read in halo information and register the elements halo + if(isparallel()) then + if (no_active_processes == 1) then + call create_empty_halo(position) + else + call read_halos(mesh_file_name, position) + end if + ! Local element ordering needs to be consistent between processes, otherwise + ! code in Halos_Repair (used in halo construction of derived meshes) will fail + if (.not. verify_consistent_local_element_numbering(position%mesh)) then + ewrite(-1,*) "The local element ordering is not the same between processes" + ewrite(-1,*) "that see the same element. This is a necessary condition on the" + ewrite(-1,*) "decomposed input meshes for fluidity. The fact that you've" + ewrite(-1,*) "obtained such meshes is likely a bug in fldecomp or the" + ewrite(-1,*) "checkpointing code. Please report to the fluidity mailing" + ewrite(-1,*) "list and state exactly how you've obtained your input files." + FLAbort("Inconsistent local element ordering") + end if + mesh = position%mesh end if - mesh = position%mesh - end if - - ! coplanar ids are create here already and stored on the mesh, - ! so its derived meshes get the same coplanar ids - ! (must be done after halo registration) - if (.not. mesh_periodic(mesh)) then - ! for periodic meshes, we postpone till we've derived the non-periodic mesh - call get_coplanar_ids(mesh, position, coplanar_ids) - end if - - if (.not. have_option(trim(mesh_path)//'/exclude_from_mesh_adaptivity')) then - ! We register this as the topology mesh - ! this is the mesh used by adaptivity for error measures and such - ! (it may gets replaced if adding periodicity or extrusion) - topology_mesh_name = mesh%name - ! same for the mesh to be handled by adapt_state() - ! (this gets replaced in case adding periodicity but not by extrusion) - adaptivity_mesh_name = mesh%name - end if - call surface_id_stats(mesh, position) + ! coplanar ids are create here already and stored on the mesh, + ! so its derived meshes get the same coplanar ids + ! (must be done after halo registration) + if (.not. mesh_periodic(mesh)) then + ! for periodic meshes, we postpone till we've derived the non-periodic mesh + call get_coplanar_ids(mesh, position, coplanar_ids) + end if - end if - - if (from_file) then - - ! Insert mesh and position field into states(1) and - ! alias it to all the others - call insert(states, mesh, mesh%name) - call insert(states, position, position%name) - call deallocate(position) - - else if (extruded) then - - ! This will be picked up by insert_derived_meshes and changed - ! appropriately - call insert(states, position, "AdaptedExtrudedPositions") - call deallocate(position) - - end if - - end do external_mesh_loop - - if(.not. present_and_true(save_vtk_cache)) then - ! Flush the cache - call vtk_cache_finalise() - end if - - call toc(TICTOC_ID_IO_READ) - - end subroutine insert_external_mesh - - subroutine insert_derived_meshes(states, skip_extrusion) - ! Insert derived meshes in state - type(state_type), intent(inout), dimension(:) :: states - ! if present and true: skip extrusion of meshes, and insert 0 node dummy meshes - ! instead (will have correct shape and dimension) - logical, optional, intent(in):: skip_extrusion - - character(len=FIELD_NAME_LEN) :: mesh_name - character(len=OPTION_PATH_LEN) :: mesh_path - logical :: incomplete, updated - integer :: i - integer :: nmeshes - - ! Get number of meshes - nmeshes=option_count("/geometry/mesh") - periodic_boundary_option_path="" - - outer_loop: do - ! Updated becomes true if we manage to set up at least one mesh on - ! this pass. - updated=.false. - ! Incomplete becomes true if we have to skip over at least one mesh - ! on this pass. - incomplete=.false. - - derived_mesh_loop: do i=0, nmeshes-1 - - ! Save mesh path - mesh_path="/geometry/mesh["//int2str(i)//"]" - - ! Get mesh name. - call get_option(trim(mesh_path)//"/name", mesh_name) - - call insert_derived_mesh(trim(mesh_path), & - trim(mesh_name), & - incomplete, & - updated, & - states, & - skip_extrusion = skip_extrusion) - - end do derived_mesh_loop - - ! If we didn't skip any fields then we are done. - if (.not.incomplete) exit outer_loop - - ! If we did skip fields and didn't update any fields this pass, then - ! we have unresolvable dependencies. - if (.not.updated) then - FLExit("Unresolvable mesh dependencies") - end if - - end do outer_loop - - ! not really a derived mesh but this is a relatively clean place to set the transform_to_physical - ! spherical flag so that the main Coordinate field is interpretted as being spherical at the gauss - ! points - if (have_option('/geometry/spherical_earth/analytical_mapping/')) then - call set_analytical_spherical_mapping() - end if - - end subroutine insert_derived_meshes - - subroutine insert_derived_mesh(mesh_path, mesh_name, incomplete, updated, states, skip_extrusion) - - ! Insert one derived mesh given by mesh path and mesh_name - - character(len=*), intent(in) :: mesh_path - character(len=*), intent(in) :: mesh_name - logical, intent(inout) :: incomplete - logical, intent(inout) :: updated - type(state_type), intent(inout), dimension(:) :: states - ! if present and true: skip extrusion of meshes, and insert 0 node dummy meshes - ! instead (will have correct shape and dimension) - logical, optional, intent(in):: skip_extrusion - - type(mesh_type) :: mesh, model_mesh - type(vector_field), pointer :: position, modelposition - type(vector_field) :: periodic_position, nonperiodic_position, extrudedposition, coordinateposition - type(element_type) :: full_shape - type(quadrature_type) :: quad - - character(len=FIELD_NAME_LEN) :: model_mesh_name - character(len=OPTION_PATH_LEN) :: shape_type, cont - logical :: new_cont, extrusion, periodic, remove_periodicity - logical :: new_shape_type, new_degree, from_shape, make_new_mesh - integer :: from_degree, from_shape_type, from_cont, j, stat - integer :: quadrature_degree, h_dim - logical :: exclude_from_mesh_adaptivity - - if (has_mesh(states(1), mesh_name)) then - ! We already did this one. - return - end if - - if(have_option(trim(mesh_path)//"/from_mesh")) then - - ! Get model mesh name - call get_option(trim(mesh_path)//"/from_mesh/mesh[0]/name", model_mesh_name) - - ! Extract model mesh - model_mesh=extract_mesh(states(1), trim(model_mesh_name), stat=stat) - if (stat/=0) then - ! The mesh from which this mesh is derived is not yet - ! present. - incomplete=.true. - return - end if - - ! Find out if the new mesh is different from the old mesh and if - ! so, find out how it differs - in the options check - ! we've made sure only one of those (or both new_shape and new_cont) are .true. - ! If there are no differences, do not create new mesh. - from_shape=have_option(trim(mesh_path)//"/from_mesh/mesh_shape") - - ! 1. If mesh shape options are specified, check if they are different to the model mesh. - if (from_shape) then - ! 1.1. Check polynomial_degree option - call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/polynomial_degree", & - from_degree, stat) - if(stat==0) then - ! Is polynomial_degree the same as model mesh? - if(from_degree==model_mesh%shape%degree) then - new_degree=.false. - else - new_degree=.true. - end if - ! If degree is not specified, use the model mesh degree. + if (.not. have_option(trim(mesh_path)//'/exclude_from_mesh_adaptivity')) then + ! We register this as the topology mesh + ! this is the mesh used by adaptivity for error measures and such + ! (it may gets replaced if adding periodicity or extrusion) + topology_mesh_name = mesh%name + ! same for the mesh to be handled by adapt_state() + ! (this gets replaced in case adding periodicity but not by extrusion) + adaptivity_mesh_name = mesh%name + end if + + call surface_id_stats(mesh, position) + + end if + + if (from_file) then + + ! Insert mesh and position field into states(1) and + ! alias it to all the others + call insert(states, mesh, mesh%name) + call insert(states, position, position%name) + call deallocate(position) + + else if (extruded) then + + ! This will be picked up by insert_derived_meshes and changed + ! appropriately + call insert(states, position, "AdaptedExtrudedPositions") + call deallocate(position) + + end if + + end do external_mesh_loop + + if(.not. present_and_true(save_vtk_cache)) then + ! Flush the cache + call vtk_cache_finalise() + end if + + call toc(TICTOC_ID_IO_READ) + + end subroutine insert_external_mesh + + subroutine insert_derived_meshes(states, skip_extrusion) + ! Insert derived meshes in state + type(state_type), intent(inout), dimension(:) :: states + ! if present and true: skip extrusion of meshes, and insert 0 node dummy meshes + ! instead (will have correct shape and dimension) + logical, optional, intent(in):: skip_extrusion + + character(len=FIELD_NAME_LEN) :: mesh_name + character(len=OPTION_PATH_LEN) :: mesh_path + logical :: incomplete, updated + integer :: i + integer :: nmeshes + + ! Get number of meshes + nmeshes=option_count("/geometry/mesh") + periodic_boundary_option_path="" + + outer_loop: do + ! Updated becomes true if we manage to set up at least one mesh on + ! this pass. + updated=.false. + ! Incomplete becomes true if we have to skip over at least one mesh + ! on this pass. + incomplete=.false. + + derived_mesh_loop: do i=0, nmeshes-1 + + ! Save mesh path + mesh_path="/geometry/mesh["//int2str(i)//"]" + + ! Get mesh name. + call get_option(trim(mesh_path)//"/name", mesh_name) + + call insert_derived_mesh(trim(mesh_path), & + trim(mesh_name), & + incomplete, & + updated, & + states, & + skip_extrusion = skip_extrusion) + + end do derived_mesh_loop + + ! If we didn't skip any fields then we are done. + if (.not.incomplete) exit outer_loop + + ! If we did skip fields and didn't update any fields this pass, then + ! we have unresolvable dependencies. + if (.not.updated) then + FLExit("Unresolvable mesh dependencies") + end if + + end do outer_loop + + ! not really a derived mesh but this is a relatively clean place to set the transform_to_physical + ! spherical flag so that the main Coordinate field is interpretted as being spherical at the gauss + ! points + if (have_option('/geometry/spherical_earth/analytical_mapping/')) then + call set_analytical_spherical_mapping() + end if + + end subroutine insert_derived_meshes + + subroutine insert_derived_mesh(mesh_path, mesh_name, incomplete, updated, states, skip_extrusion) + + ! Insert one derived mesh given by mesh path and mesh_name + + character(len=*), intent(in) :: mesh_path + character(len=*), intent(in) :: mesh_name + logical, intent(inout) :: incomplete + logical, intent(inout) :: updated + type(state_type), intent(inout), dimension(:) :: states + ! if present and true: skip extrusion of meshes, and insert 0 node dummy meshes + ! instead (will have correct shape and dimension) + logical, optional, intent(in):: skip_extrusion + + type(mesh_type) :: mesh, model_mesh + type(vector_field), pointer :: position, modelposition + type(vector_field) :: periodic_position, nonperiodic_position, extrudedposition, coordinateposition + type(element_type) :: full_shape + type(quadrature_type) :: quad + + character(len=FIELD_NAME_LEN) :: model_mesh_name + character(len=OPTION_PATH_LEN) :: shape_type, cont + logical :: new_cont, extrusion, periodic, remove_periodicity + logical :: new_shape_type, new_degree, from_shape, make_new_mesh + integer :: from_degree, from_shape_type, from_cont, j, stat + integer :: quadrature_degree, h_dim + logical :: exclude_from_mesh_adaptivity + + if (has_mesh(states(1), mesh_name)) then + ! We already did this one. + return + end if + + if(have_option(trim(mesh_path)//"/from_mesh")) then + + ! Get model mesh name + call get_option(trim(mesh_path)//"/from_mesh/mesh[0]/name", model_mesh_name) + + ! Extract model mesh + model_mesh=extract_mesh(states(1), trim(model_mesh_name), stat=stat) + if (stat/=0) then + ! The mesh from which this mesh is derived is not yet + ! present. + incomplete=.true. + return + end if + + ! Find out if the new mesh is different from the old mesh and if + ! so, find out how it differs - in the options check + ! we've made sure only one of those (or both new_shape and new_cont) are .true. + ! If there are no differences, do not create new mesh. + from_shape=have_option(trim(mesh_path)//"/from_mesh/mesh_shape") + + ! 1. If mesh shape options are specified, check if they are different to the model mesh. + if (from_shape) then + ! 1.1. Check polynomial_degree option + call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/polynomial_degree", & + from_degree, stat) + if(stat==0) then + ! Is polynomial_degree the same as model mesh? + if(from_degree==model_mesh%shape%degree) then + new_degree=.false. + else + new_degree=.true. + end if + ! If degree is not specified, use the model mesh degree. + else + new_degree=.false. + end if + + ! 1.2. Check element_type option + call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/element_type", & + shape_type, stat) + if(stat==0) then + ! Set comparison variable from_shape_type + if(trim(shape_type)=="lagrangian") then + from_shape_type=ELEMENT_LAGRANGIAN + else if(trim(shape_type)=="bubble") then + from_shape_type=ELEMENT_BUBBLE + else if(trim(shape_type)=="trace") then + from_shape_type=ELEMENT_TRACE + end if + ! If new_shape_type does not match model mesh shape type, make new mesh. + if(from_shape_type == model_mesh%shape%numbering%type) then + new_shape_type=.false. + else + new_shape_type=.true. + end if + ! If no element_type is specified, assume it is the same as model mesh + ! and do not create new mesh. + else + new_shape_type=.false. + end if + ! Else if no mesh shape options are set, do not make new mesh. else - new_degree=.false. + new_degree=.false.; new_shape_type=.false. end if - ! 1.2. Check element_type option - call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/element_type", & - shape_type, stat) + ! 2. If mesh_continuity is specified, check if it is different to the model mesh. + call get_option(trim(mesh_path)//"/from_mesh/mesh_continuity", cont, stat) if(stat==0) then - ! Set comparison variable from_shape_type - if(trim(shape_type)=="lagrangian") then - from_shape_type=ELEMENT_LAGRANGIAN - else if(trim(shape_type)=="bubble") then - from_shape_type=ELEMENT_BUBBLE - else if(trim(shape_type)=="trace") then - from_shape_type=ELEMENT_TRACE - end if - ! If new_shape_type does not match model mesh shape type, make new mesh. - if(from_shape_type == model_mesh%shape%numbering%type) then - new_shape_type=.false. - else - new_shape_type=.true. - end if - ! If no element_type is specified, assume it is the same as model mesh - ! and do not create new mesh. - else - new_shape_type=.false. - end if - ! Else if no mesh shape options are set, do not make new mesh. - else - new_degree=.false.; new_shape_type=.false. - end if - - ! 2. If mesh_continuity is specified, check if it is different to the model mesh. - call get_option(trim(mesh_path)//"/from_mesh/mesh_continuity", cont, stat) - if(stat==0) then - if(trim(cont)=="discontinuous") then - from_cont=-1 - else if(trim(cont)=="continuous") then - from_cont=0 - end if - ! 2.1. If continuity is not the same as model mesh, create new mesh. - if(from_cont==model_mesh%continuity) then - new_cont=.false. + if(trim(cont)=="discontinuous") then + from_cont=-1 + else if(trim(cont)=="continuous") then + from_cont=0 + end if + ! 2.1. If continuity is not the same as model mesh, create new mesh. + if(from_cont==model_mesh%continuity) then + new_cont=.false. + else + new_cont=.true. + end if + ! If no continuity is specified, assume it is the same as model mesh, + ! and do not create a new mesh. else - new_cont=.true. + new_cont=.false. end if - ! If no continuity is specified, assume it is the same as model mesh, - ! and do not create a new mesh. - else - new_cont=.false. - end if - ! 3. If any of the above are true, make new mesh. - make_new_mesh = new_shape_type .or. new_degree .or. new_cont + ! 3. If any of the above are true, make new mesh. + make_new_mesh = new_shape_type .or. new_degree .or. new_cont + + extrusion=have_option(trim(mesh_path)//"/from_mesh/extrude") + periodic=have_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions") + exclude_from_mesh_adaptivity=have_option(trim(mesh_path)//"/exclude_from_mesh_adaptivity") + + if (periodic) then + ! there is an options check to guarantee that all periodic bcs have remove_periodicity + remove_periodicity=option_count(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions/remove_periodicity")>0 + if (remove_periodicity) then + if (.not. mesh_periodic(model_mesh)) then + ewrite(0,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(model_mesh_name) + FLExit("Trying to remove periodic bcs from non-periodic mesh.") + end if + end if + end if - extrusion=have_option(trim(mesh_path)//"/from_mesh/extrude") - periodic=have_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions") - exclude_from_mesh_adaptivity=have_option(trim(mesh_path)//"/exclude_from_mesh_adaptivity") + ! We added at least one mesh on this pass. + updated=.true. - if (periodic) then - ! there is an options check to guarantee that all periodic bcs have remove_periodicity - remove_periodicity=option_count(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions/remove_periodicity")>0 - if (remove_periodicity) then - if (.not. mesh_periodic(model_mesh)) then - ewrite(0,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(model_mesh_name) - FLExit("Trying to remove periodic bcs from non-periodic mesh.") - end if - end if - end if + if (extrusion) then - ! We added at least one mesh on this pass. - updated=.true. + ! see if adaptivity has left us something: + extrudedposition=extract_vector_field(states(1), & + "AdaptedExtrudedPositions", stat=stat) - if (extrusion) then + if (stat==0) then - ! see if adaptivity has left us something: - extrudedposition=extract_vector_field(states(1), & - "AdaptedExtrudedPositions", stat=stat) + ! extrusion has already done by adaptivity - if (stat==0) then + ! we remove them here, as we want to insert them under different names + call incref(extrudedposition) + do j=1, size(states) + call remove_vector_field(states(j), "AdaptedExtrudedPositions") + end do - ! extrusion has already done by adaptivity + else - ! we remove them here, as we want to insert them under different names - call incref(extrudedposition) - do j=1, size(states) - call remove_vector_field(states(j), "AdaptedExtrudedPositions") - end do + ! extrusion by user specifed layer depths - else + modelposition => extract_vector_field(states(1), trim(model_mesh_name)//"Coordinate") + + if (present_and_true(skip_extrusion)) then - ! extrusion by user specifed layer depths + ! the dummy mesh does need a shape of the right dimension + h_dim = mesh_dim(modelposition) + call get_option("/geometry/quadrature/degree", quadrature_degree) + quad = make_quadrature(vertices=h_dim + 2, dim=h_dim + 1, degree=quadrature_degree) + full_shape = make_element_shape(vertices=h_dim + 2, dim=h_dim + 1, degree=1, quad=quad) + call deallocate(quad) - modelposition => extract_vector_field(states(1), trim(model_mesh_name)//"Coordinate") + call allocate(mesh, nodes=0, elements=0, shape=full_shape, name=mesh_name) + call deallocate(full_shape) + allocate(mesh%columns(1:0)) + call add_faces(mesh) + mesh%periodic=modelposition%mesh%periodic + call allocate(extrudedposition, h_dim+1, mesh, "EmptyCoordinate") ! name is fixed below + call deallocate(mesh) + if (IsParallel()) call create_empty_halo(extrudedposition) + else + call extrude(modelposition, mesh_path, extrudedposition) + end if - if (present_and_true(skip_extrusion)) then + end if - ! the dummy mesh does need a shape of the right dimension - h_dim = mesh_dim(modelposition) - call get_option("/geometry/quadrature/degree", quadrature_degree) - quad = make_quadrature(vertices=h_dim + 2, dim=h_dim + 1, degree=quadrature_degree) - full_shape = make_element_shape(vertices=h_dim + 2, dim=h_dim + 1, degree=1, quad=quad) - call deallocate(quad) + mesh = extrudedposition%mesh - call allocate(mesh, nodes=0, elements=0, shape=full_shape, name=mesh_name) - call deallocate(full_shape) - allocate(mesh%columns(1:0)) - call add_faces(mesh) - mesh%periodic=modelposition%mesh%periodic - call allocate(extrudedposition, h_dim+1, mesh, "EmptyCoordinate") ! name is fixed below - call deallocate(mesh) - if (IsParallel()) call create_empty_halo(extrudedposition) + ! the positions of this mesh have to be stored now + ! as it cannot be interpolated later. + if (mesh_name=="CoordinateMesh") then + extrudedposition%name = "Coordinate" else - call extrude(modelposition, mesh_path, extrudedposition) + extrudedposition%name = trim(mesh_name)//"Coordinate" end if + call insert(states, extrudedposition, extrudedposition%name) + call deallocate(extrudedposition) - end if + call incref(mesh) + + else if (make_new_mesh) then + + mesh = make_mesh_from_options(model_mesh, mesh_path) - mesh = extrudedposition%mesh + else if (periodic) then + + if (remove_periodicity) then + ! model mesh can't be the CoordinateMesh: + periodic_position=extract_vector_field(states(1), trim(model_mesh_name)//"Coordinate") + nonperiodic_position = make_mesh_unperiodic_from_options( & + periodic_position, mesh_path) + + ! the positions of this mesh have to be stored now + ! as it cannot be interpolated later. + if (mesh_name=="CoordinateMesh") then + nonperiodic_position%name = "Coordinate" + else + nonperiodic_position%name = trim(mesh_name)//"Coordinate" + end if + call insert(states, nonperiodic_position, nonperiodic_position%name) + call deallocate(nonperiodic_position) + + mesh=nonperiodic_position%mesh + call incref(mesh) + + else + ! this means we can only periodise a mesh with an associated position field + if (trim(model_mesh_name) == "CoordinateMesh") then + position => extract_vector_field(states(1), 'Coordinate') + else + position => extract_vector_field(states(1), trim(model_mesh_name)//'Coordinate') + end if + periodic_position = make_mesh_periodic_from_options(position, mesh_path) + ! Ensure the name and option path are set on the original + ! mesh descriptor. + periodic_position%mesh%name = mesh_name + periodic_position%mesh%option_path = trim(mesh_path) + + mesh = periodic_position%mesh + call incref(mesh) + call insert(states, periodic_position, trim(periodic_position%name)) + call deallocate(periodic_position) + end if - ! the positions of this mesh have to be stored now - ! as it cannot be interpolated later. - if (mesh_name=="CoordinateMesh") then - extrudedposition%name = "Coordinate" else - extrudedposition%name = trim(mesh_name)//"Coordinate" + ! copy mesh unchanged, new reference + mesh=model_mesh + call incref(mesh) + end if - call insert(states, extrudedposition, extrudedposition%name) - call deallocate(extrudedposition) - call incref(mesh) + mesh%name = mesh_name - else if (make_new_mesh) then + ! Set mesh option path. + mesh%option_path = trim(mesh_path) - mesh = make_mesh_from_options(model_mesh, mesh_path) + ! if this is the coordinate mesh then we should insert the coordinate field + ! also meshes excluded from adaptivity all have their own coordinate field + ! for extrusion and periodic: the coordinate field has already been inserted above + if ((trim(mesh_name)=="CoordinateMesh" .or. exclude_from_mesh_adaptivity) & + .and. .not. (extrusion .or. periodic)) then - else if (periodic) then + if (model_mesh_name=="CoordinateMesh") then + modelposition => extract_vector_field(states(1), "Coordinate") + else + modelposition => extract_vector_field(states(1), trim(model_mesh_name)//"Coordinate") + end if - if (remove_periodicity) then - ! model mesh can't be the CoordinateMesh: - periodic_position=extract_vector_field(states(1), trim(model_mesh_name)//"Coordinate") - nonperiodic_position = make_mesh_unperiodic_from_options( & - periodic_position, mesh_path) + if (mesh_name=="CoordinateMesh") then + call allocate(coordinateposition, modelposition%dim, mesh, "Coordinate") + else + call allocate(coordinateposition, modelposition%dim, mesh, trim(mesh_name)//"Coordinate") + end if - ! the positions of this mesh have to be stored now - ! as it cannot be interpolated later. - if (mesh_name=="CoordinateMesh") then - nonperiodic_position%name = "Coordinate" - else - nonperiodic_position%name = trim(mesh_name)//"Coordinate" - end if - call insert(states, nonperiodic_position, nonperiodic_position%name) - call deallocate(nonperiodic_position) + ! remap the external mesh positions onto the CoordinateMesh... this requires that the space + ! of the coordinates spans that of the external mesh + call remap_field(from_field=modelposition, to_field=coordinateposition) - mesh=nonperiodic_position%mesh - call incref(mesh) + if (mesh_name=="CoordinateMesh" .and. have_option('/geometry/spherical_earth/')) then - else - ! this means we can only periodise a mesh with an associated position field - if (trim(model_mesh_name) == "CoordinateMesh") then - position => extract_vector_field(states(1), 'Coordinate') - else - position => extract_vector_field(states(1), trim(model_mesh_name)//'Coordinate') - end if - periodic_position = make_mesh_periodic_from_options(position, mesh_path) - ! Ensure the name and option path are set on the original - ! mesh descriptor. - periodic_position%mesh%name = mesh_name - periodic_position%mesh%option_path = trim(mesh_path) - - mesh = periodic_position%mesh - call incref(mesh) - call insert(states, periodic_position, trim(periodic_position%name)) - call deallocate(periodic_position) - end if - - else - ! copy mesh unchanged, new reference - mesh=model_mesh - call incref(mesh) - - end if - - mesh%name = mesh_name - - ! Set mesh option path. - mesh%option_path = trim(mesh_path) - - ! if this is the coordinate mesh then we should insert the coordinate field - ! also meshes excluded from adaptivity all have their own coordinate field - ! for extrusion and periodic: the coordinate field has already been inserted above - if ((trim(mesh_name)=="CoordinateMesh" .or. exclude_from_mesh_adaptivity) & - .and. .not. (extrusion .or. periodic)) then - - if (model_mesh_name=="CoordinateMesh") then - modelposition => extract_vector_field(states(1), "Coordinate") - else - modelposition => extract_vector_field(states(1), trim(model_mesh_name)//"Coordinate") - end if - - if (mesh_name=="CoordinateMesh") then - call allocate(coordinateposition, modelposition%dim, mesh, "Coordinate") - else - call allocate(coordinateposition, modelposition%dim, mesh, trim(mesh_name)//"Coordinate") - end if - - ! remap the external mesh positions onto the CoordinateMesh... this requires that the space - ! of the coordinates spans that of the external mesh - call remap_field(from_field=modelposition, to_field=coordinateposition) - - if (mesh_name=="CoordinateMesh" .and. have_option('/geometry/spherical_earth/')) then - - if (have_option('/geometry/spherical_earth/superparametric_mapping/')) then - call higher_order_sphere_projection(modelposition, coordinateposition) + if (have_option('/geometry/spherical_earth/superparametric_mapping/')) then + call higher_order_sphere_projection(modelposition, coordinateposition) + end if + + endif + + ! insert into states(1) and alias to all others + call insert(states, coordinateposition, coordinateposition%name) + ! drop reference to the local copy of the Coordinate field + call deallocate(coordinateposition) + end if + if (trim(mesh_name)=="CoordinateMesh" .and. mesh_periodic(mesh)) then + FLExit("CoordinateMesh may not be periodic") + end if + + ! Insert mesh into all states + call insert(states, mesh, mesh%name) + + if (.not. have_option(trim(mesh_path)//'/exclude_from_mesh_adaptivity')) then + ! update info for adaptivity/error metric code: + + if (extrusion .or. (periodic .and. .not. remove_periodicity)) then + ! this is the name of the mesh to be used by the error metric for adaptivity + topology_mesh_name=mesh%name end if - endif - - ! insert into states(1) and alias to all others - call insert(states, coordinateposition, coordinateposition%name) - ! drop reference to the local copy of the Coordinate field - call deallocate(coordinateposition) - end if - if (trim(mesh_name)=="CoordinateMesh" .and. mesh_periodic(mesh)) then - FLExit("CoordinateMesh may not be periodic") - end if - - ! Insert mesh into all states - call insert(states, mesh, mesh%name) - - if (.not. have_option(trim(mesh_path)//'/exclude_from_mesh_adaptivity')) then - ! update info for adaptivity/error metric code: - - if (extrusion .or. (periodic .and. .not. remove_periodicity)) then - ! this is the name of the mesh to be used by the error metric for adaptivity - topology_mesh_name=mesh%name - end if - - if ((extrusion.and..not.have_option('/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity')) & - .or.(periodic .and. .not. remove_periodicity)) then - ! this is the name of the mesh to be adapted by adaptivity - adaptivity_mesh_name=mesh%name - end if - - if (periodic .and. trim(periodic_boundary_option_path(mesh%shape%dim)) == "") then - periodic_boundary_option_path(mesh%shape%dim) = trim(mesh_path) - end if - end if - - call deallocate(mesh) - - end if - - end subroutine insert_derived_mesh - - subroutine insert_trace_meshes(states) - !If any meshes have constraints, allocate an appropriate trace mesh - type(state_type), dimension(:), intent(inout) :: states - ! - type(mesh_type) :: from_mesh, model_mesh - type(mesh_type) :: trace_mesh - type(quadrature_type) :: quad - type(element_type) :: trace_shape - integer :: mesh_no, trace_degree, dim, loc, constraint_choice, & - &quad_degree - logical :: allocate_trace_mesh - character(len=FIELD_NAME_LEN) :: model_mesh_name - - do mesh_no = 1, mesh_count(states(1)) - allocate_trace_mesh = .false. - from_mesh = extract_mesh(states(1),mesh_no) - if(associated(from_mesh%shape%constraints)) then - constraint_choice = from_mesh%shape%constraints%type - if(constraint_choice.ne.CONSTRAINT_NONE) then - select case(constraint_choice) - case (CONSTRAINT_BDM) - trace_degree = from_mesh%shape%degree - case (CONSTRAINT_RT) - trace_degree = from_mesh%shape%degree-1 - case (CONSTRAINT_BDFM) - trace_degree = from_mesh%shape%degree-1 - case default - FLAbort('Constraint type not supported') - end select - dim = from_mesh%shape%dim - loc=from_mesh%shape%quadrature%vertices - - ! Get model mesh name - call get_option("/geometry/mesh["//int2str(mesh_no)//& - &"]/from_mesh/mesh[0]/name",& - &model_mesh_name) - - ! Extract model mesh - model_mesh=extract_mesh(states(1), trim(model_mesh_name)) - - !Make quadrature - call get_option("/geometry/quadrature/degree",& - & quad_degree) - quad=make_quadrature(loc, dim, & + if ((extrusion.and..not.have_option('/mesh_adaptivity/hr_adaptivity/vertically_structured_adaptivity')) & + .or.(periodic .and. .not. remove_periodicity)) then + ! this is the name of the mesh to be adapted by adaptivity + adaptivity_mesh_name=mesh%name + end if + + if (periodic .and. trim(periodic_boundary_option_path(mesh%shape%dim)) == "") then + periodic_boundary_option_path(mesh%shape%dim) = trim(mesh_path) + end if + end if + + call deallocate(mesh) + + end if + + end subroutine insert_derived_mesh + + subroutine insert_trace_meshes(states) + !If any meshes have constraints, allocate an appropriate trace mesh + type(state_type), dimension(:), intent(inout) :: states + ! + type(mesh_type) :: from_mesh, model_mesh + type(mesh_type) :: trace_mesh + type(quadrature_type) :: quad + type(element_type) :: trace_shape + integer :: mesh_no, trace_degree, dim, loc, constraint_choice, & + &quad_degree + logical :: allocate_trace_mesh + character(len=FIELD_NAME_LEN) :: model_mesh_name + + do mesh_no = 1, mesh_count(states(1)) + allocate_trace_mesh = .false. + from_mesh = extract_mesh(states(1),mesh_no) + if(associated(from_mesh%shape%constraints)) then + constraint_choice = from_mesh%shape%constraints%type + if(constraint_choice.ne.CONSTRAINT_NONE) then + select case(constraint_choice) + case (CONSTRAINT_BDM) + trace_degree = from_mesh%shape%degree + case (CONSTRAINT_RT) + trace_degree = from_mesh%shape%degree-1 + case (CONSTRAINT_BDFM) + trace_degree = from_mesh%shape%degree-1 + case default + FLAbort('Constraint type not supported') + end select + dim = from_mesh%shape%dim + loc=from_mesh%shape%quadrature%vertices + + ! Get model mesh name + call get_option("/geometry/mesh["//int2str(mesh_no)//& + &"]/from_mesh/mesh[0]/name",& + &model_mesh_name) + + ! Extract model mesh + model_mesh=extract_mesh(states(1), trim(model_mesh_name)) + + !Make quadrature + call get_option("/geometry/quadrature/degree",& + & quad_degree) + quad=make_quadrature(loc, dim, & degree=quad_degree, family=get_quad_family()) - !allocate shape - trace_shape=make_element_shape(loc, dim, trace_degree, & - &quad,type=ELEMENT_TRACE) - !deallocate quadrature (just drop a reference) - call deallocate(quad) - !allocate mesh - trace_mesh=make_mesh(model_mesh, trace_shape, continuity=-1,& + !allocate shape + trace_shape=make_element_shape(loc, dim, trace_degree, & + &quad,type=ELEMENT_TRACE) + !deallocate quadrature (just drop a reference) + call deallocate(quad) + !allocate mesh + trace_mesh=make_mesh(model_mesh, trace_shape, continuity=-1,& name=trim(from_mesh%name)//"Trace") - !deallocate shape (just drop a reference) - call deallocate(trace_shape) - !insert into states - call insert(states,trace_mesh,trace_mesh%name) - !deallocate mesh (just drop a reference) - call deallocate(trace_mesh) - end if - end if - end do - - end subroutine insert_trace_meshes - - function make_mesh_from_options(from_mesh, mesh_path) result (mesh) - ! make new mesh changing shape or continuity of from_mesh - type(mesh_type):: mesh - type(mesh_type), intent(in):: from_mesh - character(len=*), intent(in):: mesh_path - - character(len=FIELD_NAME_LEN) :: mesh_name - character(len=OPTION_PATH_LEN) :: continuity_option, element_option, constraint_option_string - type(quadrature_type):: quad - type(element_type):: shape - integer :: constraint_choice - integer:: loc, dim, poly_degree, continuity, new_shape_type, quad_degree, stat - logical :: new_shape - - ! Get new mesh shape information - - new_shape = have_option(trim(mesh_path)//"/from_mesh/mesh_shape") - if(new_shape) then - ! Get new mesh element type - call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/element_type", & - element_option, stat) - if(stat==0) then - if(trim(element_option)=="lagrangian") then - new_shape_type=ELEMENT_LAGRANGIAN - else if(trim(element_option)=="bubble") then - new_shape_type=ELEMENT_BUBBLE - else if(trim(element_option)=="trace") then - new_shape_type=ELEMENT_TRACE - end if + !deallocate shape (just drop a reference) + call deallocate(trace_shape) + !insert into states + call insert(states,trace_mesh,trace_mesh%name) + !deallocate mesh (just drop a reference) + call deallocate(trace_mesh) + end if + end if + end do + + end subroutine insert_trace_meshes + + function make_mesh_from_options(from_mesh, mesh_path) result (mesh) + ! make new mesh changing shape or continuity of from_mesh + type(mesh_type):: mesh + type(mesh_type), intent(in):: from_mesh + character(len=*), intent(in):: mesh_path + + character(len=FIELD_NAME_LEN) :: mesh_name + character(len=OPTION_PATH_LEN) :: continuity_option, element_option, constraint_option_string + type(quadrature_type):: quad + type(element_type):: shape + integer :: constraint_choice + integer:: loc, dim, poly_degree, continuity, new_shape_type, quad_degree, stat + logical :: new_shape + + ! Get new mesh shape information + + new_shape = have_option(trim(mesh_path)//"/from_mesh/mesh_shape") + if(new_shape) then + ! Get new mesh element type + call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/element_type", & + element_option, stat) + if(stat==0) then + if(trim(element_option)=="lagrangian") then + new_shape_type=ELEMENT_LAGRANGIAN + else if(trim(element_option)=="bubble") then + new_shape_type=ELEMENT_BUBBLE + else if(trim(element_option)=="trace") then + new_shape_type=ELEMENT_TRACE + end if + else + new_shape_type=from_mesh%shape%numbering%type + end if + + ! degree is the degree of the Lagrange polynomials (even if you add in a bubble function) + call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/polynomial_degree", & + poly_degree, default=from_mesh%shape%degree) + + ! loc is the number of vertices of the element + loc=from_mesh%shape%loc + ! dim is the dimension + dim=from_mesh%shape%dim + ! Make quadrature + call get_option("/geometry/quadrature/degree",& + & quad_degree) + quad=make_quadrature(loc, dim, degree=quad_degree, family=get_quad_family()) + ! Get element constraints + call get_option(trim(mesh_path)//"/from_mesh/constraint_type",& + constraint_option_string, stat) + if(stat==0) then + if(trim(constraint_option_string)=="BDFM") then + constraint_choice=CONSTRAINT_BDFM + else if(trim(constraint_option_string)=="RT") then + constraint_choice=CONSTRAINT_RT + else if(trim(constraint_option_string)=="BDM") then + constraint_choice=CONSTRAINT_BDM + else if(trim(constraint_option_string)=="none") then + constraint_choice=CONSTRAINT_NONE + end if + else + constraint_choice = CONSTRAINT_NONE + end if + + ! Make new mesh shape + shape=make_element_shape(loc, dim, poly_degree, quad,& + &type=new_shape_type,constraint_type_choice=constraint_choice) + call deallocate(quad) ! Really just drop a reference. else - new_shape_type=from_mesh%shape%numbering%type - end if - - ! degree is the degree of the Lagrange polynomials (even if you add in a bubble function) - call get_option(trim(mesh_path)//"/from_mesh/mesh_shape/polynomial_degree", & - poly_degree, default=from_mesh%shape%degree) - - ! loc is the number of vertices of the element - loc=from_mesh%shape%loc - ! dim is the dimension - dim=from_mesh%shape%dim - ! Make quadrature - call get_option("/geometry/quadrature/degree",& - & quad_degree) - quad=make_quadrature(loc, dim, degree=quad_degree, family=get_quad_family()) - ! Get element constraints - call get_option(trim(mesh_path)//"/from_mesh/constraint_type",& - constraint_option_string, stat) + shape=from_mesh%shape + call incref(shape) + end if + + ! Get new mesh continuity + call get_option(trim(mesh_path)//"/from_mesh/mesh_continuity", continuity_option, stat) if(stat==0) then - if(trim(constraint_option_string)=="BDFM") then - constraint_choice=CONSTRAINT_BDFM - else if(trim(constraint_option_string)=="RT") then - constraint_choice=CONSTRAINT_RT - else if(trim(constraint_option_string)=="BDM") then - constraint_choice=CONSTRAINT_BDM - else if(trim(constraint_option_string)=="none") then - constraint_choice=CONSTRAINT_NONE + if(trim(continuity_option)=="discontinuous") then + continuity=-1 + else if(trim(continuity_option)=="continuous") then + continuity=0 end if else - constraint_choice = CONSTRAINT_NONE - end if - - ! Make new mesh shape - shape=make_element_shape(loc, dim, poly_degree, quad,& - &type=new_shape_type,constraint_type_choice=constraint_choice) - call deallocate(quad) ! Really just drop a reference. - else - shape=from_mesh%shape - call incref(shape) - end if - - ! Get new mesh continuity - call get_option(trim(mesh_path)//"/from_mesh/mesh_continuity", continuity_option, stat) - if(stat==0) then - if(trim(continuity_option)=="discontinuous") then - continuity=-1 - else if(trim(continuity_option)=="continuous") then - continuity=0 - end if - else - continuity=from_mesh%continuity - end if - - ! Get mesh name. - call get_option(trim(mesh_path)//"/name", mesh_name) - - ! Make new mesh - mesh=make_mesh(from_mesh, shape, continuity, mesh_name) - - ! Set mesh option path - mesh%option_path = trim(mesh_path) - - ! Drop one reference to shape - call deallocate(shape) - - end function make_mesh_from_options - - function make_mesh_periodic_from_options(position, mesh_path) result (position_out) - ! make a periodic mesh as specified by options - type(vector_field):: position_out - type(vector_field), intent(in):: position - character(len=*), intent(in):: mesh_path - - - type(vector_field):: from_position - type(integer_hash_table):: periodic_face_map - character(len=FIELD_NAME_LEN):: bc_name, mesh_name - character(len=OPTION_PATH_LEN) :: periodic_mapping_python - integer, dimension(:), allocatable :: physical_boundary_ids, aliased_boundary_ids - integer, dimension(2) :: shape_option - integer:: n_periodic_bcs - integer:: j - logical :: fiddled_with_faces - - assert(has_faces(position%mesh)) - - from_position=position - - ! builds up a map from aliased to physical faces - call allocate(periodic_face_map) - - n_periodic_bcs=option_count(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions") - ewrite(2,*) "n_periodic_bcs=", n_periodic_bcs - call incref(from_position) - do j=0, n_periodic_bcs-1 - - ! get some options - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/name", bc_name) - ewrite(1,*) "applying boundary condition: ", trim(bc_name) - shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids") - allocate( physical_boundary_ids(shape_option(1)) ) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids",physical_boundary_ids) - shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids") - allocate( aliased_boundary_ids(shape_option(1)) ) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids",aliased_boundary_ids) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/coordinate_map",periodic_mapping_python) - - ewrite(2,*) 'Making periodic mesh' - - - fiddled_with_faces = .false. - if (.not. has_faces(from_position%mesh)) then - from_position%mesh%faces => position%mesh%faces - fiddled_with_faces = .true. - end if - position_out=make_mesh_periodic(from_position,& - physical_boundary_ids,aliased_boundary_ids, & - periodic_mapping_python, periodic_face_map=periodic_face_map) - if (fiddled_with_faces) then - from_position%mesh%faces => null() - end if - call deallocate(from_position) - from_position=position_out - - deallocate( physical_boundary_ids, aliased_boundary_ids ) - end do - - call add_faces(position_out%mesh, model=position%mesh, periodic_face_map=periodic_face_map) - - call deallocate(periodic_face_map) - - ! finally fix the name of the produced mesh and its coordinate field - call get_option(trim(mesh_path)//'/name', mesh_name) - position_out%mesh%name=mesh_name - if (mesh_name=="CoordinateMesh") then - position_out%name="Coordinate" - else - position_out%name=trim(mesh_name)//"Coordinate" - end if - - end function make_mesh_periodic_from_options - - function make_mesh_unperiodic_from_options(from_position, mesh_path, aliased_to_new_node_number, stat) result (position) - ! make a periodic mesh as specified by options - type(vector_field):: position - type(vector_field), intent(in):: from_position - character(len=*), intent(in):: mesh_path - integer, intent(out), optional :: stat - type(integer_hash_table), optional, intent(out) :: aliased_to_new_node_number - - type(vector_field):: lfrom_position, nonperiodic_position - character(len=FIELD_NAME_LEN):: bc_name, mesh_name - character(len=OPTION_PATH_LEN) :: periodic_mapping_python - integer, dimension(:), allocatable :: physical_boundary_ids, aliased_boundary_ids - integer, dimension(2) :: shape_option - integer:: n_periodic_bcs - integer:: j - type(integer_hash_table) :: laliased_to_new_node_number - type(integer_set) :: all_periodic_bc_ids - logical :: fiddled_with_faces - - if (present(stat)) then - stat = 0 - end if - - ! Get mesh name. - call get_option(trim(mesh_path)//"/name", mesh_name) - - ! get our own reference of from_position, that we can throw away again - lfrom_position=from_position - call incref(lfrom_position) - - n_periodic_bcs=option_count(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions") - ewrite(2,*) "n_periodic_bcs=", n_periodic_bcs - if (n_periodic_bcs == 0) then - ewrite(-1,*) "You almost certainly didn't mean to pass in this option path." - ewrite(-1,*) "trim(mesh_path): ", trim(mesh_path) - ewrite(-1,*) "mesh_name: ", trim(mesh_name) - FLAbort("No periodic boundary conditions to unwrap!") - end if - - call allocate(all_periodic_bc_ids) - do j=0, n_periodic_bcs-1 - shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids") - allocate( physical_boundary_ids(shape_option(1)) ) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids",physical_boundary_ids) - call insert(all_periodic_bc_ids, physical_boundary_ids) - deallocate(physical_boundary_ids) - - shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids") - allocate( aliased_boundary_ids(shape_option(1)) ) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids",aliased_boundary_ids) - call insert(all_periodic_bc_ids, aliased_boundary_ids) - deallocate(aliased_boundary_ids) - end do - - do j=0, n_periodic_bcs-1 - - ! get some options - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/name", bc_name) - ewrite(1,*) "applying boundary condition: ", trim(bc_name) - shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids") - allocate( physical_boundary_ids(shape_option(1)) ) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids",physical_boundary_ids) - shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids") - allocate( aliased_boundary_ids(shape_option(1)) ) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids",aliased_boundary_ids) - call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/coordinate_map",periodic_mapping_python) - - ewrite(2,*) 'Removing periodicity from mesh' - - fiddled_with_faces = .false. - if (.not. has_faces(lfrom_position%mesh)) then - lfrom_position%mesh%faces => from_position%mesh%faces - fiddled_with_faces = .true. - end if - - nonperiodic_position=make_mesh_unperiodic(lfrom_position,& - physical_boundary_ids,aliased_boundary_ids, & - periodic_mapping_python, mesh_name, all_periodic_bc_ids, laliased_to_new_node_number) - - if (fiddled_with_faces) then - lfrom_position%mesh%faces => null() - end if - - if (associated(lfrom_position%mesh%halos)) then - assert(associated(lfrom_position%mesh%element_halos)) - call derive_nonperiodic_halos_from_periodic_halos(nonperiodic_position, lfrom_position, laliased_to_new_node_number) - end if - call deallocate(lfrom_position) - if (present(aliased_to_new_node_number)) then - aliased_to_new_node_number = laliased_to_new_node_number - else - call deallocate(laliased_to_new_node_number) - end if - lfrom_position=nonperiodic_position - - deallocate( physical_boundary_ids, aliased_boundary_ids ) - end do - - ! assumes all periodic bcs have been removed - ! this is checked for in add_faces - ! this flag needs setting before the call to add_faces - nonperiodic_position%mesh%periodic=.false. - - assert(associated(nonperiodic_position%mesh%shape%numbering)) - - if (has_faces(from_position%mesh)) then - call add_faces(nonperiodic_position%mesh, model=from_position%mesh, stat=stat) - end if - - position=nonperiodic_position - - call deallocate(all_periodic_bc_ids) - - end function make_mesh_unperiodic_from_options - - subroutine allocate_and_insert_fields(states, dont_allocate_prognostic_value_spaces) - !!< allocates and inserts all fields present in the options tree - !!< zeros field, but does not yet set initial conditions - type(state_type), dimension(:), intent(inout):: states - !! If provided and true will not allocate a full value space - !! for those fields for which defer_allocation(option_path, mesh) is .true. - !! but instead allocate them as constant fields. This is used - !! for fields that are passed down to SAM in which case we want to be - !! able to one by one allocate them as we get them back from SAM. - logical, optional, intent(in):: dont_allocate_prognostic_value_spaces - - character(len=OPTION_PATH_LEN) :: field_name, absolute_path - integer :: i, istate ! counters - integer :: nstates ! number of states - type(scalar_field), pointer :: fshistory_sfield - integer :: fshistory_levels - - nstates=option_count("/material_phase") - - ! Loop over states for the first time to get prognostic, prescribed and diagnostic fields. - state_loop: do i=0, nstates-1 - - ! Assign the material_phase name to state(i+1)%name - call get_option('/material_phase['//int2str(i)//']/name', states(i+1)%name) - - call allocate_and_insert_one_phase(& + continuity=from_mesh%continuity + end if + + ! Get mesh name. + call get_option(trim(mesh_path)//"/name", mesh_name) + + ! Make new mesh + mesh=make_mesh(from_mesh, shape, continuity, mesh_name) + + ! Set mesh option path + mesh%option_path = trim(mesh_path) + + ! Drop one reference to shape + call deallocate(shape) + + end function make_mesh_from_options + + function make_mesh_periodic_from_options(position, mesh_path) result (position_out) + ! make a periodic mesh as specified by options + type(vector_field):: position_out + type(vector_field), intent(in):: position + character(len=*), intent(in):: mesh_path + + + type(vector_field):: from_position + type(integer_hash_table):: periodic_face_map + character(len=FIELD_NAME_LEN):: bc_name, mesh_name + character(len=OPTION_PATH_LEN) :: periodic_mapping_python + integer, dimension(:), allocatable :: physical_boundary_ids, aliased_boundary_ids + integer, dimension(2) :: shape_option + integer:: n_periodic_bcs + integer:: j + logical :: fiddled_with_faces + + assert(has_faces(position%mesh)) + + from_position=position + + ! builds up a map from aliased to physical faces + call allocate(periodic_face_map) + + n_periodic_bcs=option_count(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions") + ewrite(2,*) "n_periodic_bcs=", n_periodic_bcs + call incref(from_position) + do j=0, n_periodic_bcs-1 + + ! get some options + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/name", bc_name) + ewrite(1,*) "applying boundary condition: ", trim(bc_name) + shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids") + allocate( physical_boundary_ids(shape_option(1)) ) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids",physical_boundary_ids) + shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids") + allocate( aliased_boundary_ids(shape_option(1)) ) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids",aliased_boundary_ids) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/coordinate_map",periodic_mapping_python) + + ewrite(2,*) 'Making periodic mesh' + + + fiddled_with_faces = .false. + if (.not. has_faces(from_position%mesh)) then + from_position%mesh%faces => position%mesh%faces + fiddled_with_faces = .true. + end if + position_out=make_mesh_periodic(from_position,& + physical_boundary_ids,aliased_boundary_ids, & + periodic_mapping_python, periodic_face_map=periodic_face_map) + if (fiddled_with_faces) then + from_position%mesh%faces => null() + end if + call deallocate(from_position) + from_position=position_out + + deallocate( physical_boundary_ids, aliased_boundary_ids ) + end do + + call add_faces(position_out%mesh, model=position%mesh, periodic_face_map=periodic_face_map) + + call deallocate(periodic_face_map) + + ! finally fix the name of the produced mesh and its coordinate field + call get_option(trim(mesh_path)//'/name', mesh_name) + position_out%mesh%name=mesh_name + if (mesh_name=="CoordinateMesh") then + position_out%name="Coordinate" + else + position_out%name=trim(mesh_name)//"Coordinate" + end if + + end function make_mesh_periodic_from_options + + function make_mesh_unperiodic_from_options(from_position, mesh_path, aliased_to_new_node_number, stat) result (position) + ! make a periodic mesh as specified by options + type(vector_field):: position + type(vector_field), intent(in):: from_position + character(len=*), intent(in):: mesh_path + integer, intent(out), optional :: stat + type(integer_hash_table), optional, intent(out) :: aliased_to_new_node_number + + type(vector_field):: lfrom_position, nonperiodic_position + character(len=FIELD_NAME_LEN):: bc_name, mesh_name + character(len=OPTION_PATH_LEN) :: periodic_mapping_python + integer, dimension(:), allocatable :: physical_boundary_ids, aliased_boundary_ids + integer, dimension(2) :: shape_option + integer:: n_periodic_bcs + integer:: j + type(integer_hash_table) :: laliased_to_new_node_number + type(integer_set) :: all_periodic_bc_ids + logical :: fiddled_with_faces + + if (present(stat)) then + stat = 0 + end if + + ! Get mesh name. + call get_option(trim(mesh_path)//"/name", mesh_name) + + ! get our own reference of from_position, that we can throw away again + lfrom_position=from_position + call incref(lfrom_position) + + n_periodic_bcs=option_count(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions") + ewrite(2,*) "n_periodic_bcs=", n_periodic_bcs + if (n_periodic_bcs == 0) then + ewrite(-1,*) "You almost certainly didn't mean to pass in this option path." + ewrite(-1,*) "trim(mesh_path): ", trim(mesh_path) + ewrite(-1,*) "mesh_name: ", trim(mesh_name) + FLAbort("No periodic boundary conditions to unwrap!") + end if + + call allocate(all_periodic_bc_ids) + do j=0, n_periodic_bcs-1 + shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids") + allocate( physical_boundary_ids(shape_option(1)) ) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids",physical_boundary_ids) + call insert(all_periodic_bc_ids, physical_boundary_ids) + deallocate(physical_boundary_ids) + + shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids") + allocate( aliased_boundary_ids(shape_option(1)) ) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids",aliased_boundary_ids) + call insert(all_periodic_bc_ids, aliased_boundary_ids) + deallocate(aliased_boundary_ids) + end do + + do j=0, n_periodic_bcs-1 + + ! get some options + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/name", bc_name) + ewrite(1,*) "applying boundary condition: ", trim(bc_name) + shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids") + allocate( physical_boundary_ids(shape_option(1)) ) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/physical_boundary_ids",physical_boundary_ids) + shape_option = option_shape(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids") + allocate( aliased_boundary_ids(shape_option(1)) ) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/aliased_boundary_ids",aliased_boundary_ids) + call get_option(trim(mesh_path)//"/from_mesh/periodic_boundary_conditions["//int2str(j)//"]/coordinate_map",periodic_mapping_python) + + ewrite(2,*) 'Removing periodicity from mesh' + + fiddled_with_faces = .false. + if (.not. has_faces(lfrom_position%mesh)) then + lfrom_position%mesh%faces => from_position%mesh%faces + fiddled_with_faces = .true. + end if + + nonperiodic_position=make_mesh_unperiodic(lfrom_position,& + physical_boundary_ids,aliased_boundary_ids, & + periodic_mapping_python, mesh_name, all_periodic_bc_ids, laliased_to_new_node_number) + + if (fiddled_with_faces) then + lfrom_position%mesh%faces => null() + end if + + if (associated(lfrom_position%mesh%halos)) then + assert(associated(lfrom_position%mesh%element_halos)) + call derive_nonperiodic_halos_from_periodic_halos(nonperiodic_position, lfrom_position, laliased_to_new_node_number) + end if + call deallocate(lfrom_position) + if (present(aliased_to_new_node_number)) then + aliased_to_new_node_number = laliased_to_new_node_number + else + call deallocate(laliased_to_new_node_number) + end if + lfrom_position=nonperiodic_position + + deallocate( physical_boundary_ids, aliased_boundary_ids ) + end do + + ! assumes all periodic bcs have been removed + ! this is checked for in add_faces + ! this flag needs setting before the call to add_faces + nonperiodic_position%mesh%periodic=.false. + + assert(associated(nonperiodic_position%mesh%shape%numbering)) + + if (has_faces(from_position%mesh)) then + call add_faces(nonperiodic_position%mesh, model=from_position%mesh, stat=stat) + end if + + position=nonperiodic_position + + call deallocate(all_periodic_bc_ids) + + end function make_mesh_unperiodic_from_options + + subroutine allocate_and_insert_fields(states, dont_allocate_prognostic_value_spaces) + !!< allocates and inserts all fields present in the options tree + !!< zeros field, but does not yet set initial conditions + type(state_type), dimension(:), intent(inout):: states + !! If provided and true will not allocate a full value space + !! for those fields for which defer_allocation(option_path, mesh) is .true. + !! but instead allocate them as constant fields. This is used + !! for fields that are passed down to SAM in which case we want to be + !! able to one by one allocate them as we get them back from SAM. + logical, optional, intent(in):: dont_allocate_prognostic_value_spaces + + character(len=OPTION_PATH_LEN) :: field_name, absolute_path + integer :: i, istate ! counters + integer :: nstates ! number of states + type(scalar_field), pointer :: fshistory_sfield + integer :: fshistory_levels + + nstates=option_count("/material_phase") + + ! Loop over states for the first time to get prognostic, prescribed and diagnostic fields. + state_loop: do i=0, nstates-1 + + ! Assign the material_phase name to state(i+1)%name + call get_option('/material_phase['//int2str(i)//']/name', states(i+1)%name) + + call allocate_and_insert_one_phase(& '/material_phase['//int2str(i)//']', states(i+1), & dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end do state_loop + end do state_loop - ! special case fields outside material_phases: - ! distance to top and bottom - if (have_option('/geometry/ocean_boundaries')) then - ! set up DistanceToTop field and insert in first state - ! it is only allowed to be diagnostic by the schema, so not much to do - call allocate_and_insert_scalar_field('/geometry/ocean_boundaries/scalar_field::DistanceToTop', & + ! special case fields outside material_phases: + ! distance to top and bottom + if (have_option('/geometry/ocean_boundaries')) then + ! set up DistanceToTop field and insert in first state + ! it is only allowed to be diagnostic by the schema, so not much to do + call allocate_and_insert_scalar_field('/geometry/ocean_boundaries/scalar_field::DistanceToTop', & states(1)) - ! set up DistanceToBottom field and insert in first state - call allocate_and_insert_scalar_field('/geometry/ocean_boundaries/scalar_field::DistanceToBottom', & + ! set up DistanceToBottom field and insert in first state + call allocate_and_insert_scalar_field('/geometry/ocean_boundaries/scalar_field::DistanceToBottom', & states(1), & dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if + end if - ! direction of gravity - if (have_option('/physical_parameters/gravity/vector_field::GravityDirection')) then - call allocate_and_insert_vector_field('/physical_parameters/gravity/vector_field::GravityDirection', & + ! direction of gravity + if (have_option('/physical_parameters/gravity/vector_field::GravityDirection')) then + call allocate_and_insert_vector_field('/physical_parameters/gravity/vector_field::GravityDirection', & states(1), dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if + end if - ! Field that controls the weighting of partitions: - if (have_option('/flredecomp/field_weighted_partitions')) then - call allocate_and_insert_scalar_field('/flredecomp/field_weighted_partitions/scalar_field::FieldWeightedPartitionValues', states(1)) - end if + ! Field that controls the weighting of partitions: + if (have_option('/flredecomp/field_weighted_partitions')) then + call allocate_and_insert_scalar_field('/flredecomp/field_weighted_partitions/scalar_field::FieldWeightedPartitionValues', states(1)) + end if - if (have_option('/mesh_adaptivity/hr_adaptivity/zoltan_options/field_weighted_partitions')) then - call allocate_and_insert_scalar_field('/mesh_adaptivity/hr_adaptivity/zoltan_options/field_weighted_partitions/scalar_field::FieldWeightedPartitionValues', states(1)) - end if + if (have_option('/mesh_adaptivity/hr_adaptivity/zoltan_options/field_weighted_partitions')) then + call allocate_and_insert_scalar_field('/mesh_adaptivity/hr_adaptivity/zoltan_options/field_weighted_partitions/scalar_field::FieldWeightedPartitionValues', states(1)) + end if - ! grid velocity - if (have_option('/mesh_adaptivity/mesh_movement/vector_field::GridVelocity')) then - call allocate_and_insert_vector_field('/mesh_adaptivity/mesh_movement/vector_field::GridVelocity', & + ! grid velocity + if (have_option('/mesh_adaptivity/mesh_movement/vector_field::GridVelocity')) then + call allocate_and_insert_vector_field('/mesh_adaptivity/mesh_movement/vector_field::GridVelocity', & states(1), dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if - - ! solar irradiance submodel (hyperlight) - if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight")) then - call allocate_and_insert_irradiance(states(1)) - end if - - ! Harmonic Analysis History fields - if (has_scalar_field(states(1),'FreeSurfaceHistory') ) then - fshistory_sfield => extract_scalar_field(states(1), 'FreeSurfaceHistory') - ! levels: the number of levels which will be saved. Too old levels will be overwritten by new ones. - if (have_option(trim(complete_field_path(fshistory_sfield%option_path)) // "/algorithm/levels")) then - call get_option(trim(complete_field_path(fshistory_sfield%option_path)) // "/algorithm/levels", fshistory_levels) - fshistory_levels=max(fshistory_levels,0) - else - fshistory_levels=50 end if - do i=1,fshistory_levels - call allocate_and_insert_scalar_field('', states(1), parent_mesh='PressureMesh', field_name='harmonic'//int2str(i)) + + ! solar irradiance submodel (hyperlight) + if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight")) then + call allocate_and_insert_irradiance(states(1)) + end if + + ! Harmonic Analysis History fields + if (has_scalar_field(states(1),'FreeSurfaceHistory') ) then + fshistory_sfield => extract_scalar_field(states(1), 'FreeSurfaceHistory') + ! levels: the number of levels which will be saved. Too old levels will be overwritten by new ones. + if (have_option(trim(complete_field_path(fshistory_sfield%option_path)) // "/algorithm/levels")) then + call get_option(trim(complete_field_path(fshistory_sfield%option_path)) // "/algorithm/levels", fshistory_levels) + fshistory_levels=max(fshistory_levels,0) + else + fshistory_levels=50 + end if + do i=1,fshistory_levels + call allocate_and_insert_scalar_field('', states(1), parent_mesh='PressureMesh', field_name='harmonic'//int2str(i)) + end do + end if + + ! insert miscellaneous scalar fields + do i=1, size(additional_fields_absolute) + if (have_option(trim(additional_fields_absolute(i)))) then + + call allocate_and_insert_one_phase(additional_fields_absolute(i), states(1), & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + + end if + end do + + do i=1, size(additional_fields_relative) + do istate = 1, size(states) + absolute_path = "/material_phase["//int2str(istate-1)//"]/"//trim(additional_fields_relative(i)) + if (have_option(absolute_path)) then + + call allocate_and_insert_one_phase(absolute_path, states(istate), & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + + end if + end do end do - end if - ! insert miscellaneous scalar fields - do i=1, size(additional_fields_absolute) - if (have_option(trim(additional_fields_absolute(i)))) then + call allocate_metric_limits(states(1)) + + contains + + subroutine allocate_and_insert_one_phase(state_path, state, dont_allocate_prognostic_value_spaces) + !! Perform the allocation and insertion of the fields found under + !! state_path into state. + character(len=*), intent(in) :: state_path + type(state_type), intent(inout) :: state + logical, optional, intent(in):: dont_allocate_prognostic_value_spaces + + character(len=OPTION_PATH_LEN) :: path + integer :: nfields ! number of fields + logical :: is_aliased + + integer :: j + + ! Get number of scalar fields that are children of this state + nfields=option_count(trim(state_path)//"/scalar_field") + + ! Loop over scalar fields + scalar_field_loop: do j=0, nfields-1 + + ! Save path to field + path=trim(state_path)//"/scalar_field["//int2str(j)//"]" + + ! Get field name + call get_option(trim(path)//"/name", field_name) + ! Reset path to have field name rather than index + path=trim(state_path)//"/scalar_field::"//trim(field_name) + + ! If field is not aliased call allocate_and_insert_scalar_field + is_aliased=have_option(trim(path)//"/aliased") + if(.not.is_aliased) then + call allocate_and_insert_scalar_field(path, state, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end if + + end do scalar_field_loop + + ! Get number of vector fields that are children of this state + nfields=option_count(trim(state_path)//"/vector_field") + + ! Loop over vector fields + vector_field_loop: do j=0, nfields-1 + + ! Save path to field + path=trim(state_path)//"/vector_field["//int2str(j)//"]" + ! Get field name + call get_option(trim(path)//"/name", field_name) + ! Reset path to have field name rather than index + path=trim(state_path)//"/vector_field::"//trim(field_name) + + ! If field is not aliased call allocate_and_insert_vector_field + is_aliased=have_option(trim(path)//"/aliased") + if(.not.is_aliased) then + call allocate_and_insert_vector_field(path, state, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end if + + end do vector_field_loop + + ! Get number of tensor fields that are children of this state + nfields=option_count(trim(state_path)//"/tensor_field") + + tensor_field_loop: do j=0, nfields-1 + + ! Save path to field + path=trim(state_path)//"/tensor_field["//int2str(j)//"]" + ! Get field name + call get_option(trim(path)//"/name", field_name) + ! Reset path to have field name rather than index + path=trim(state_path)//"/tensor_field::"//trim(field_name) + + ! If field is not aliased call allocate_and_insert_tensor_field + is_aliased=have_option(trim(path)//"/aliased") + if(.not.is_aliased) then + call allocate_and_insert_tensor_field(path, state, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end if + + end do tensor_field_loop + + end subroutine allocate_and_insert_one_phase + + subroutine allocate_and_insert_irradiance(state) + ! Allocate irradiance fields for 36 wavebands in PAR + type(state_type), intent(inout) :: state + integer :: j + real :: lambda + character(len=OPTION_PATH_LEN) :: light_path, field_name + + ! Replicate irradiance template field for all wavebands + light_path = "/ocean_biology/lagrangian_ensemble/hyperlight" + frequency_field_loop: do j=0,35 + lambda = 350.0 + (j * 10.0) + field_name="Irradiance_"//int2str(NINT(lambda)) + call allocate_and_insert_scalar_field(& + trim(light_path)& + //"/scalar_field::IrradianceTemplate", & + state, field_name=trim(field_name), & + dont_allocate_prognostic_value_spaces& + =dont_allocate_prognostic_value_spaces) + end do frequency_field_loop + + ! Create PAR irradiance field + if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/scalar_field::IrradiancePAR")) then + call allocate_and_insert_scalar_field(& + trim(light_path)& + //"/scalar_field::IrradiancePAR", & + state, field_name="IrradiancePAR", & + dont_allocate_prognostic_value_spaces& + =dont_allocate_prognostic_value_spaces) + end if + end subroutine allocate_and_insert_irradiance + + end subroutine allocate_and_insert_fields + + subroutine alias_fields(states) + type(state_type), dimension(:), intent(inout) :: states + + character(len=OPTION_PATH_LEN) :: path + character(len=OPTION_PATH_LEN) :: state_name, aliased_field_name, field_name + integer :: i, j, k ! counters + integer :: nstates ! number of states + integer :: nfields ! number of fields + ! logicals to find out if we have certain options + logical :: is_aliased + type(scalar_field) :: sfield + type(vector_field) :: vfield + type(tensor_field) :: tfield + + nstates=option_count("/material_phase") + + state_loop: do i=0, nstates-1 + + ! Get number of scalar fields that are children of this state + nfields=option_count("/material_phase["//int2str(i)//"]/scalar_field") + + ! Loop over scalar fields + scalar_field_loop: do j=0, nfields-1 + + ! Save path to field + path="/material_phase["//int2str(i)//"]/scalar_field["& + &//int2str(j)//"]" + + ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into current state + is_aliased=have_option(trim(path)//"/aliased") + if(is_aliased) then + call get_option(trim(path)//"/name", field_name) + call get_option(trim(path)//"/aliased/field_name", aliased_field_name) + call get_option(trim(path)//"/aliased/material_phase_name", state_name) + + k=get_state_index(states, trim(state_name)) + sfield=extract_scalar_field(states(k), trim(aliased_field_name)) + sfield%name = trim(field_name) ! this seems to be necessary + ! to preserve the aliased field's original name + sfield%aliased = .true. + call insert(states(i+1), sfield, trim(field_name)) + end if + + end do scalar_field_loop + + ! Get number of vector fields that are children of this state + nfields=option_count("/material_phase["//int2str(i)//"]/vecto& + &r_field") + + ! Loop over vector fields + vector_field_loop: do j=0, nfields-1 + + ! Save path to field + path="/material_phase["//int2str(i)//"]/vector_field["& + &//int2str(j)//"]" + + ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into current state + is_aliased=have_option(trim(path)//"/aliased") + if(is_aliased) then + call get_option(trim(path)//"/name", field_name) + call get_option(trim(path)//"/aliased/material_phase_name", state_name) + call get_option(trim(path)//"/aliased/field_name", aliased_field_name) + + k=get_state_index(states, trim(state_name)) + vfield=extract_vector_field(states(k), trim(aliased_field_name)) + vfield%name = trim(field_name) ! this seems to be necessary to preserve the aliased field's original name + vfield%aliased = .true. + call insert(states(i+1), vfield, trim(field_name)) + + end if + + end do vector_field_loop + + ! Get number of tensor fields that are children of this state + nfields=option_count("/material_phase["//int2str(i)//"]/tensor_field") + + tensor_field_loop: do j=0, nfields-1 + + ! Save path to field + path="/material_phase["//int2str(i)//"]/tensor_field["& + &//int2str(j)//"]" + + ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into current state + is_aliased=have_option(trim(path)//"/aliased") + if(is_aliased) then + call get_option(trim(path)//"/name", field_name) + call get_option(trim(path)//"/aliased/material_phase_name", state_name) + call get_option(trim(path)//"/aliased/field_name", aliased_field_name) + + k=get_state_index(states, trim(state_name)) + tfield=extract_tensor_field(states(k), trim(aliased_field_name)) + tfield%name = trim(field_name) ! this seems to be necessary to preserve the aliased field's original name + tfield%aliased = .true. + call insert(states(i+1), tfield, trim(field_name)) + + end if + + end do tensor_field_loop + + end do state_loop + + ! special case fields outside material_phases: + ! distance to top and bottom + if (have_option('/geometry/ocean_boundaries')) then + + sfield = extract_scalar_field(states(1), 'DistanceToTop') + sfield%aliased = .true. + do i = 1,nstates-1 + call insert(states(i+1), sfield, 'DistanceToTop') + end do + + sfield = extract_scalar_field(states(1), 'DistanceToBottom') + sfield%aliased = .true. + do i = 1,nstates-1 + call insert(states(i+1), sfield, 'DistanceToBottom') + end do + + end if + + ! direction of gravity + if (have_option('/physical_parameters/gravity/vector_field::GravityDirection')) then + vfield=extract_vector_field(states(1), 'GravityDirection') + vfield%aliased = .true. + do i = 1,nstates-1 + + call insert(states(i+1), vfield, 'GravityDirection') + + end do + end if + + ! grid velocity + if (have_option('/mesh_adaptivity/mesh_movement/vector_field::GridVelocity')) then + + ! Save path to field + path="/mesh_adaptivity/mesh_movement/vector_field::GridVelocity" + + ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into state(1) + is_aliased=have_option(trim(path)//"/aliased") + if(is_aliased) then + call get_option(trim(path)//"/name", field_name) + call get_option(trim(path)//"/aliased/material_phase_name", state_name) + call get_option(trim(path)//"/aliased/field_name", aliased_field_name) + + k=get_state_index(states, trim(state_name)) + vfield=extract_vector_field(states(k), trim(aliased_field_name)) + vfield%name = trim(field_name) ! this seems to be necessary to preserve the aliased field's original name + vfield%aliased = .true. + call insert(states(1), vfield, trim(field_name)) + + end if + + vfield=extract_vector_field(states(1), 'GridVelocity') + vfield%aliased = .true. + do i = 1,nstates-1 + + call insert(states(i+1), vfield, 'GridVelocity') + + end do + end if + + ! Deal with subgridscale parameterisations. + call alias_diffusivity(states) + + end subroutine alias_fields + + subroutine alias_diffusivity(states) + !!< Where fields get their diffusivity from a subgridscale + !!< parameterisation, it is necessary to alias their diffusivity to the + !!< diffusivity provided by the parameterisation. + !!< + !!< At this stage only prescribed diffusivity, the Generic Length Scale ocean model + !!< and the K-Epsilon turbulence model are handled via this route. + !!< Mellor-Yamada is pending a rewrite. + type(state_type), dimension(:), intent(inout) :: states + type(scalar_field), pointer :: sfield + type(tensor_field) :: tfield + + integer :: i, s, stat + + ! Prescribed diffusivity + do i = 1, size(states) + + tfield=extract_tensor_field(states(i), "PrescribedDiffusivity", stat) + + if (stat/=0) cycle + + tfield%aliased=.True. + + do s = 1, scalar_field_count(states(i)) + + sfield => extract_scalar_field(states(i), s) + + if (have_option(trim(sfield%option_path)//& + "/prognostic/subgridscale_parameterisation& + &::prescribed_diffusivity")) then + + tfield%name=trim(sfield%name)//"Diffusivity" + call insert(states(i), tfield, tfield%name) + + end if + + end do + + end do + + ! Eddy diffusivity from Generic Length Scale Ocean model + do i = 1, size(states) + + tfield=extract_tensor_field(states(i), "GLSEddyDiffusivityKH", stat) + + if (stat/=0) cycle + + tfield%aliased=.True. + + do s = 1, scalar_field_count(states(i)) + + sfield => extract_scalar_field(states(i), s) + + if (have_option(trim(sfield%option_path)//& + "/prognostic/subgridscale_parameterisation& + &::GLS")) then + + tfield%name=trim(sfield%name)//"Diffusivity" + call insert(states(i), tfield, tfield%name) + + end if + + end do + + end do + + end subroutine alias_diffusivity + + function allocate_scalar_field_as_constant(option_path) result(is_constant) + !!< Return whether the supplied option path signals a constant + !!< field + + character(len = *), intent(in) :: option_path + + logical :: is_constant + + is_constant = .false. + if(option_count(trim(option_path) // "/prescribed/value") == 1) then + is_constant = have_option(trim(option_path) // "/prescribed/value[0]/constant") + end if + + end function allocate_scalar_field_as_constant + + function allocate_vector_field_as_constant(option_path) result(is_constant) + !!< Return whether the supplied option path signals a constant + !!< field + + character(len = *), intent(in) :: option_path + + logical :: is_constant + + is_constant = .false. + if(option_count(trim(option_path) // "/prescribed/value") == 1) then + is_constant = have_option(trim(option_path) // "/prescribed/value[0]/constant") + end if + + end function allocate_vector_field_as_constant + + function allocate_tensor_field_as_constant(option_path) result(is_constant) + !!< Return whether the supplied option path signals a constant + !!< field + + character(len = *), intent(in) :: option_path + + logical :: is_constant + + if(option_count(trim(option_path) // "/prescribed/value") == 1) then + is_constant = have_option(trim(option_path) // "/prescribed/value/isotropic/constant") .or. & + & have_option(trim(option_path) // "/prescribed/value/anisotropic_symmetric/constant") .or. & + & have_option(trim(option_path) // "/prescribed/value/anisotropic_asymmetric/constant") + else + is_constant = .false. + end if + + end function allocate_tensor_field_as_constant + + function allocate_field_as_constant_scalar(s_field) result(is_constant) + !!< Return whether the options tree defines the supplied scalar field to + !!< be constant + + type(scalar_field), intent(in) :: s_field + + logical :: is_constant + + is_constant = allocate_scalar_field_as_constant(s_field%option_path) + + end function allocate_field_as_constant_scalar + + function allocate_field_as_constant_vector(v_field) result(is_constant) + !!< Return whether the options tree defines the supplied vector field to + !!< be constant + + type(vector_field), intent(in) :: v_field + + logical :: is_constant + + is_constant = allocate_vector_field_as_constant(v_field%option_path) + + end function allocate_field_as_constant_vector + + function allocate_field_as_constant_tensor(t_field) result(is_constant) + !!< Return whether the options tree defines the supplied tensor field to + !!< be constant + + type(tensor_field), intent(in) :: t_field + + logical :: is_constant + + if(trim(t_field%name) == "MinMetricEigenbound") then + is_constant = have_option("/mesh_adaptivity/hr_adaptivity/tensor_field::MinimumEdgeLengths/anisotropic_symmetric/constant") + else if(trim(t_field%name) == "MaxMetricEigenbound") then + is_constant = have_option("/mesh_adaptivity/hr_adaptivity/tensor_field::MaximumEdgeLengths/anisotropic_symmetric/constant") + else + is_constant = allocate_tensor_field_as_constant(t_field%option_path) + end if + + end function allocate_field_as_constant_tensor + + recursive subroutine allocate_and_insert_scalar_field(option_path, state, & + parent_mesh, parent_name, field_name, & + dont_allocate_prognostic_value_spaces) + + character(len=*), intent(in) :: option_path + type(state_type), intent(inout) :: state + character(len=*), intent(in), optional :: parent_mesh + character(len=*), intent(in), optional :: parent_name + character(len=*), optional, intent(in):: field_name + logical, optional, intent(in):: dont_allocate_prognostic_value_spaces + + logical :: is_prognostic, is_prescribed, is_diagnostic, is_aliased + ! paths for options and child fields + character(len=OPTION_PATH_LEN) :: path, adapt_path + ! Strings for names + character(len=OPTION_PATH_LEN) :: lfield_name, mesh_name + type(scalar_field) :: field + type(mesh_type), pointer :: mesh + logical :: backward_compatibility, is_constant + + is_aliased=have_option(trim(option_path)//"/aliased") + if(is_aliased) return + + ! Save option_path + path=trim(option_path) + + if (present(field_name)) then + lfield_name=field_name + else + call get_option(trim(path)//"/name", lfield_name) + end if + + if(present(parent_name)) then + lfield_name=trim(parent_name)//trim(lfield_name) + end if + ewrite(1,*) "In allocate_and_insert_scalar_field, field is: ", trim(lfield_name) + + ! Do we need backward compatibility? + ! If we need backward compatibility, then no matter how the field + ! is described in XML, a value space will be allocated, for old-style + ! code to use. + ! If we do not need backward compatibility, we can make big savings + ! on constant fields. + ! Any fields that require backward compatibility are badly behaved, as they + ! modify constant fields. *Do not add to this list!* Construct an + ! appropriate diagnostic algorithm instead (possibly an internal). + backward_compatibility = .false. + + ! Find out what kind of field we have + is_prognostic=have_option(trim(path)//"/prognostic") + is_prescribed=have_option(trim(path)//"/prescribed") + is_diagnostic=have_option(trim(path)//"/diagnostic") + + is_constant=allocate_tensor_field_as_constant(path) + + ewrite(1,*) "Is field prognostic? ", is_prognostic + ewrite(1,*) "Is field prescribed? ", is_prescribed + ewrite(1,*) "Is field constant? ", is_constant + ewrite(1,*) "Is field diagnostic? ", is_diagnostic + + if (is_prognostic) then + + path=trim(path)//"/prognostic" + + else if(is_prescribed) then + + path=trim(path)//"/prescribed" + + else if(is_diagnostic) then + + path=trim(path)//"/diagnostic" + + end if + + ! Get mesh + if(present(parent_mesh).and.& + .not.have_option(trim(path)//"/mesh[0]/name")) then + mesh => extract_mesh(state, trim(parent_mesh)) + mesh_name=parent_mesh + else + call get_option(trim(path)//"/mesh[0]/name", mesh_name) + mesh => extract_mesh(state, trim(mesh_name)) + end if + + if (defer_allocation(option_path, mesh, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces)) then + ! If we want to defer allocation (for sam), don't allocate the value space yet + call allocate(field, mesh, name=trim(lfield_name), & + field_type=FIELD_TYPE_DEFERRED) + else if(is_constant .and. .not. backward_compatibility) then + + ! Allocate as constant field if possible (and we don't need backward compatibility) + call allocate(field, mesh, name=trim(lfield_name), & + field_type=FIELD_TYPE_CONSTANT) + + call zero(field) + else + ! If we have to keep backward compatibility, then + ! just allocate the value space as normal, + ! and don't try any funny tricks to save memory. + + ! Allocate field + call allocate(field, mesh, name=trim(lfield_name)) + call zero(field) + end if + - call allocate_and_insert_one_phase(additional_fields_absolute(i), states(1), & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + ewrite(2,*) trim(lfield_name), " is on mesh ", trim(mesh%name) - end if - end do + ! Set field%option_path + field%option_path=trim(option_path) - do i=1, size(additional_fields_relative) - do istate = 1, size(states) - absolute_path = "/material_phase["//int2str(istate-1)//"]/"//trim(additional_fields_relative(i)) - if (have_option(absolute_path)) then + ! Finally! Insert field into state! + call insert(state, field, field%name) + call deallocate(field) - call allocate_and_insert_one_phase(absolute_path, states(istate), & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + ! Check for fields that are children of this field: + call allocate_and_insert_children(path, state, mesh_name, lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + call allocate_and_insert_grandchildren(path, state, mesh_name,& + & lfield_name, & + & dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if - end do - end do + ! Check for adaptivity weights associated with this field: + adapt_path=trim(path)//"/adaptivity_options" + if(have_option(trim(adapt_path)//"/absolute_measure")) then + adapt_path=trim(adapt_path)//"/absolute_measure/scalar_field::InterpolationErrorBound" + call allocate_and_insert_scalar_field(adapt_path, state, parent_mesh=topology_mesh_name, & + parent_name=lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + else if(have_option(trim(adapt_path)//"/relative_measure")) then + adapt_path=trim(adapt_path)//"/relative_measure/scalar_field::InterpolationErrorBound" + call allocate_and_insert_scalar_field(adapt_path, state, parent_mesh=topology_mesh_name, & + parent_name=lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end if - call allocate_metric_limits(states(1)) + end subroutine allocate_and_insert_scalar_field - contains + recursive subroutine allocate_and_insert_vector_field(option_path, state, parent_mesh, parent_name, & + field_name, dont_allocate_prognostic_value_spaces) - subroutine allocate_and_insert_one_phase(state_path, state, dont_allocate_prognostic_value_spaces) - !! Perform the allocation and insertion of the fields found under - !! state_path into state. - character(len=*), intent(in) :: state_path + character(len=*), intent(in) :: option_path type(state_type), intent(inout) :: state - logical, optional, intent(in):: dont_allocate_prognostic_value_spaces - - character(len=OPTION_PATH_LEN) :: path - integer :: nfields ! number of fields - logical :: is_aliased - - integer :: j + character(len=*), intent(in), optional :: parent_mesh + character(len=*), intent(in), optional :: parent_name + character(len=*), optional, intent(in):: field_name + logical, intent(in), optional :: dont_allocate_prognostic_value_spaces + + integer :: dim + logical :: is_prognostic, is_prescribed, is_diagnostic, is_aliased + ! paths for options and child fields + character(len=OPTION_PATH_LEN) :: path, adapt_path + ! strings for names + character(len=OPTION_PATH_LEN) :: lfield_name, mesh_name + type(mesh_type), pointer :: mesh + type(vector_field) :: field + logical :: backward_compatibility, is_constant + + is_aliased=have_option(trim(option_path)//"/aliased") + if(is_aliased) return + + ! Save option_path + path=trim(option_path) + + if (present(field_name)) then + lfield_name=field_name + else + call get_option(trim(path)//"/name", lfield_name) + end if - ! Get number of scalar fields that are children of this state - nfields=option_count(trim(state_path)//"/scalar_field") + if(present(parent_name)) then + lfield_name=trim(parent_name)//trim(lfield_name) + end if + ewrite(1,*) "In allocate_and_insert_vector_field, field is: ", trim(lfield_name) + + ! Do we need backward compatibility? + ! If we need backward compatibility, then no matter how the field + ! is described in XML, a value space will be allocated, for old-style + ! code to use. + ! If we do not need backward compatibility, we can make big savings + ! on constant fields. + ! Any fields that require backward compatibility are badly behaved, as they + ! modify constant fields. *Do not add to this list!* Construct an + ! appropriate diagnostic algorithm instead (possibly an internal). + backward_compatibility = .false. + + ! Find out what kind of field we have + is_prognostic=have_option(trim(path)//"/prognostic") + is_prescribed=have_option(trim(path)//"/prescribed") + is_diagnostic=have_option(trim(path)//"/diagnostic") + + is_constant=allocate_vector_field_as_constant(path) + + ewrite(1,*) "Is field prognostic? ", is_prognostic + ewrite(1,*) "Is field prescribed? ", is_prescribed + ewrite(1,*) "Is field constant? ", is_constant + ewrite(1,*) "Is field diagnostic? ", is_diagnostic + + ! Get dimension of vector - currently the dimension of the problem + call get_option("/geometry/dimension", dim) + + if(is_prognostic) then + path=trim(path)//"/prognostic" + else if(is_prescribed) then + path=trim(path)//"/prescribed" + else if(is_diagnostic) then + path=trim(path)//"/diagnostic" + end if - ! Loop over scalar fields - scalar_field_loop: do j=0, nfields-1 + ! Get mesh + if(present(parent_mesh).and.& + .not.have_option(trim(path)//"/mesh[0]/name")) then + mesh => extract_mesh(state, trim(parent_mesh)) + mesh_name=parent_mesh + else + call get_option(trim(path)//"/mesh[0]/name", mesh_name) + mesh => extract_mesh(state, trim(mesh_name)) + end if - ! Save path to field - path=trim(state_path)//"/scalar_field["//int2str(j)//"]" + if (defer_allocation(option_path, mesh, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces)) then + ! If we want to defer allocation (for sam), don't allocate the value space yet + call allocate(field, dim, mesh, name=trim(lfield_name), & + field_type=FIELD_TYPE_DEFERRED) + else if(is_constant .and. .not. backward_compatibility) then - ! Get field name - call get_option(trim(path)//"/name", field_name) - ! Reset path to have field name rather than index - path=trim(state_path)//"/scalar_field::"//trim(field_name) + ! Allocate as constant field if possible (and we don't need backward compatibility) + call allocate(field, dim, mesh, name=trim(lfield_name), & + field_type=FIELD_TYPE_CONSTANT) + call zero(field) - ! If field is not aliased call allocate_and_insert_scalar_field - is_aliased=have_option(trim(path)//"/aliased") - if(.not.is_aliased) then - call allocate_and_insert_scalar_field(path, state, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if + else + ! If we have to keep backward compatibility, then + ! just allocate the value space as normal, + ! and don't try any funny tricks to save memory. - end do scalar_field_loop + ! Allocate field + call allocate(field, dim, mesh, trim(lfield_name)) + call zero(field) + end if - ! Get number of vector fields that are children of this state - nfields=option_count(trim(state_path)//"/vector_field") + ewrite(2,*) trim(lfield_name), " is on mesh ", trim(mesh%name) - ! Loop over vector fields - vector_field_loop: do j=0, nfields-1 + ! Set field%option_path + field%option_path=trim(option_path) - ! Save path to field - path=trim(state_path)//"/vector_field["//int2str(j)//"]" - ! Get field name - call get_option(trim(path)//"/name", field_name) - ! Reset path to have field name rather than index - path=trim(state_path)//"/vector_field::"//trim(field_name) + ! Finally! Insert field into state! + call insert(state, field, field%name) + call deallocate(field) - ! If field is not aliased call allocate_and_insert_vector_field - is_aliased=have_option(trim(path)//"/aliased") - if(.not.is_aliased) then - call allocate_and_insert_vector_field(path, state, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if + ! Check for fields that are children of this field: + call allocate_and_insert_children(path, state, mesh_name, lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + call allocate_and_insert_grandchildren(path, state, mesh_name, lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end do vector_field_loop + ! Check for adaptivity weights associated with this field: + adapt_path=trim(path)//"/adaptivity_options" + if(have_option(trim(adapt_path)//"/absolute_measure")) then + adapt_path=trim(adapt_path)//"/absolute_measure/vector_field::InterpolationErrorBound" + call allocate_and_insert_vector_field(adapt_path, state, topology_mesh_name, lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + else if(have_option(trim(adapt_path)//"/relative_measure")) then + adapt_path=trim(adapt_path)//"/relative_measure/vector_field::InterpolationErrorBound" + call allocate_and_insert_vector_field(adapt_path, state, topology_mesh_name, lfield_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end if - ! Get number of tensor fields that are children of this state - nfields=option_count(trim(state_path)//"/tensor_field") + end subroutine allocate_and_insert_vector_field - tensor_field_loop: do j=0, nfields-1 + recursive subroutine allocate_and_insert_tensor_field(option_path, state, parent_mesh, parent_name, & + dont_allocate_prognostic_value_spaces) + !!< This subroutine sets up the initial condition of a tensor field. + !!< Note that the tensor dimensions are set to be the dimension of the + !!< problem. - ! Save path to field - path=trim(state_path)//"/tensor_field["//int2str(j)//"]" - ! Get field name - call get_option(trim(path)//"/name", field_name) - ! Reset path to have field name rather than index - path=trim(state_path)//"/tensor_field::"//trim(field_name) + character(len=*), intent(in) :: option_path + type(state_type), intent(inout) :: state + character(len=*), intent(in), optional :: parent_mesh + character(len=*), intent(in), optional :: parent_name + logical, intent(in), optional :: dont_allocate_prognostic_value_spaces + + logical :: backward_compatibility, is_prescribed, is_diagnostic, is_constant, is_aliased + ! paths for options and child fields + character(len=OPTION_PATH_LEN) :: path, adapt_path + character(len=OPTION_PATH_LEN) :: field_name, mesh_name + type(tensor_field) :: field + type(mesh_type), pointer:: mesh + + is_aliased=have_option(trim(option_path)//"/aliased") + if(is_aliased) return + + ! Save option_path + path=trim(option_path) + + call get_option(trim(path)//"/name", field_name) + if(present(parent_name)) then + if(trim(field_name)/="Viscosity") then + field_name=trim(parent_name)//trim(field_name) + end if + end if + ewrite(1,*) "In allocate_and_insert_tensor_field, field is: ", trim(field_name) - ! If field is not aliased call allocate_and_insert_tensor_field - is_aliased=have_option(trim(path)//"/aliased") - if(.not.is_aliased) then - call allocate_and_insert_tensor_field(path, state, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if + ! Do we need backward compatibility? + ! If we need backward compatibility, then no matter how the field + ! is described in XML, a value space will be allocated, for old-style + ! code to use. + ! If we do not need backward compatibility, we can make big savings + ! on constant fields. + ! Any fields that require backward compatibility are badly behaved, as they + ! modify constant fields. *Do not add to this list!* Construct an + ! appropriate diagnostic algorithm instead (possibly an internal). + backward_compatibility = any(field_name == (/"ElectricalPotentialDiffusivity "/)) - end do tensor_field_loop + ! Find out what kind of field we have + is_prescribed=have_option(trim(path)//"/prescribed") + is_diagnostic=have_option(trim(path)//"/diagnostic") + is_constant=allocate_tensor_field_as_constant(path) - end subroutine allocate_and_insert_one_phase + ewrite(1,*) "Is field prescribed? ", is_prescribed + ewrite(1,*) "Is field diagnostic? ", is_diagnostic + ewrite(1,*) "Is field constant? ", is_constant - subroutine allocate_and_insert_irradiance(state) - ! Allocate irradiance fields for 36 wavebands in PAR - type(state_type), intent(inout) :: state - integer :: j - real :: lambda - character(len=OPTION_PATH_LEN) :: light_path, field_name - - ! Replicate irradiance template field for all wavebands - light_path = "/ocean_biology/lagrangian_ensemble/hyperlight" - frequency_field_loop: do j=0,35 - lambda = 350.0 + (j * 10.0) - field_name="Irradiance_"//int2str(NINT(lambda)) - call allocate_and_insert_scalar_field(& - trim(light_path)& - //"/scalar_field::IrradianceTemplate", & - state, field_name=trim(field_name), & - dont_allocate_prognostic_value_spaces& - =dont_allocate_prognostic_value_spaces) - end do frequency_field_loop - - ! Create PAR irradiance field - if (have_option("/ocean_biology/lagrangian_ensemble/hyperlight/scalar_field::IrradiancePAR")) then - call allocate_and_insert_scalar_field(& - trim(light_path)& - //"/scalar_field::IrradiancePAR", & - state, field_name="IrradiancePAR", & - dont_allocate_prognostic_value_spaces& - =dont_allocate_prognostic_value_spaces) - end if - end subroutine allocate_and_insert_irradiance - - end subroutine allocate_and_insert_fields - - subroutine alias_fields(states) - type(state_type), dimension(:), intent(inout) :: states - - character(len=OPTION_PATH_LEN) :: path - character(len=OPTION_PATH_LEN) :: state_name, aliased_field_name, field_name - integer :: i, j, k ! counters - integer :: nstates ! number of states - integer :: nfields ! number of fields - ! logicals to find out if we have certain options - logical :: is_aliased - type(scalar_field) :: sfield - type(vector_field) :: vfield - type(tensor_field) :: tfield - - nstates=option_count("/material_phase") - - state_loop: do i=0, nstates-1 - - ! Get number of scalar fields that are children of this state - nfields=option_count("/material_phase["//int2str(i)//"]/scalar_field") - - ! Loop over scalar fields - scalar_field_loop: do j=0, nfields-1 - - ! Save path to field - path="/material_phase["//int2str(i)//"]/scalar_field["& - &//int2str(j)//"]" - - ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into current state - is_aliased=have_option(trim(path)//"/aliased") - if(is_aliased) then - call get_option(trim(path)//"/name", field_name) - call get_option(trim(path)//"/aliased/field_name", aliased_field_name) - call get_option(trim(path)//"/aliased/material_phase_name", state_name) - - k=get_state_index(states, trim(state_name)) - sfield=extract_scalar_field(states(k), trim(aliased_field_name)) - sfield%name = trim(field_name) ! this seems to be necessary - ! to preserve the aliased field's original name - sfield%aliased = .true. - call insert(states(i+1), sfield, trim(field_name)) - end if - - end do scalar_field_loop - - ! Get number of vector fields that are children of this state - nfields=option_count("/material_phase["//int2str(i)//"]/vecto& - &r_field") - - ! Loop over vector fields - vector_field_loop: do j=0, nfields-1 - - ! Save path to field - path="/material_phase["//int2str(i)//"]/vector_field["& - &//int2str(j)//"]" - - ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into current state - is_aliased=have_option(trim(path)//"/aliased") - if(is_aliased) then - call get_option(trim(path)//"/name", field_name) - call get_option(trim(path)//"/aliased/material_phase_name", state_name) - call get_option(trim(path)//"/aliased/field_name", aliased_field_name) - - k=get_state_index(states, trim(state_name)) - vfield=extract_vector_field(states(k), trim(aliased_field_name)) - vfield%name = trim(field_name) ! this seems to be necessary to preserve the aliased field's original name - vfield%aliased = .true. - call insert(states(i+1), vfield, trim(field_name)) - - end if - - end do vector_field_loop - - ! Get number of tensor fields that are children of this state - nfields=option_count("/material_phase["//int2str(i)//"]/tensor_field") - - tensor_field_loop: do j=0, nfields-1 - - ! Save path to field - path="/material_phase["//int2str(i)//"]/tensor_field["& - &//int2str(j)//"]" - - ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into current state - is_aliased=have_option(trim(path)//"/aliased") - if(is_aliased) then - call get_option(trim(path)//"/name", field_name) - call get_option(trim(path)//"/aliased/material_phase_name", state_name) - call get_option(trim(path)//"/aliased/field_name", aliased_field_name) + if(is_prescribed) then - k=get_state_index(states, trim(state_name)) - tfield=extract_tensor_field(states(k), trim(aliased_field_name)) - tfield%name = trim(field_name) ! this seems to be necessary to preserve the aliased field's original name - tfield%aliased = .true. - call insert(states(i+1), tfield, trim(field_name)) + path=trim(path)//"/prescribed" - end if + else if(is_diagnostic) then - end do tensor_field_loop + path=trim(path)//"/diagnostic" - end do state_loop + end if - ! special case fields outside material_phases: - ! distance to top and bottom - if (have_option('/geometry/ocean_boundaries')) then + ! Get mesh + if(present(parent_mesh).and.& + .not.have_option(trim(path)//"/mesh[0]/name")) then + mesh => extract_mesh(state, trim(parent_mesh)) + mesh_name=parent_mesh + else + call get_option(trim(path)//"/mesh[0]/name", mesh_name) + mesh => extract_mesh(state, trim(mesh_name)) + end if - sfield = extract_scalar_field(states(1), 'DistanceToTop') - sfield%aliased = .true. - do i = 1,nstates-1 - call insert(states(i+1), sfield, 'DistanceToTop') - end do + if (defer_allocation(option_path, mesh, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces)) then - sfield = extract_scalar_field(states(1), 'DistanceToBottom') - sfield%aliased = .true. - do i = 1,nstates-1 - call insert(states(i+1), sfield, 'DistanceToBottom') - end do + ! If we want to defer allocation (for sam), don't allocate the value space yet + call allocate(field, mesh, name=trim(field_name), & + field_type=FIELD_TYPE_DEFERRED) - end if + else if(is_constant .and. .not. backward_compatibility) then - ! direction of gravity - if (have_option('/physical_parameters/gravity/vector_field::GravityDirection')) then - vfield=extract_vector_field(states(1), 'GravityDirection') - vfield%aliased = .true. - do i = 1,nstates-1 + ! Allocate as constant field if possible (and we don't need backward compatibility) + call allocate(field, mesh, name=trim(field_name), & + field_type=FIELD_TYPE_CONSTANT) + call zero(field) + else - call insert(states(i+1), vfield, 'GravityDirection') + ! Allocate field + call allocate(field, mesh, trim(field_name)) + call zero(field) + end if - end do - end if - ! grid velocity - if (have_option('/mesh_adaptivity/mesh_movement/vector_field::GridVelocity')) then + ! Set field%option_path + field%option_path=trim(option_path) - ! Save path to field - path="/mesh_adaptivity/mesh_movement/vector_field::GridVelocity" + ! Finally! Insert field into state! + call insert(state, field, field%name) + call deallocate(field) - ! If field is aliased, find which field it is aliased to, extract that field from the correct state and insert into state(1) - is_aliased=have_option(trim(path)//"/aliased") - if(is_aliased) then - call get_option(trim(path)//"/name", field_name) - call get_option(trim(path)//"/aliased/material_phase_name", state_name) - call get_option(trim(path)//"/aliased/field_name", aliased_field_name) + ! Check for fields that are children of this field: + call allocate_and_insert_children(path, state, mesh_name, field_name, & + & dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + call allocate_and_insert_grandchildren(path, state, mesh_name, & + & field_name, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - k=get_state_index(states, trim(state_name)) - vfield=extract_vector_field(states(k), trim(aliased_field_name)) - vfield%name = trim(field_name) ! this seems to be necessary to preserve the aliased field's original name - vfield%aliased = .true. - call insert(states(1), vfield, trim(field_name)) + ! Check for adaptivity weights associated with this field: + adapt_path=trim(path)//"/adaptivity_options" + if(have_option(trim(adapt_path)//"/absolute_measure")) then + adapt_path=trim(adapt_path)//"/absolute_measure/tensor_field::InterpolationErrorBound" + call allocate_and_insert_tensor_field(adapt_path, state, topology_mesh_name, field_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + else if(have_option(trim(adapt_path)//"/relative_measure")) then + adapt_path=trim(adapt_path)//"/relative_measure/tensor_field::InterpolationErrorBound" + call allocate_and_insert_tensor_field(adapt_path, state, topology_mesh_name, field_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end if - end if + end subroutine allocate_and_insert_tensor_field - vfield=extract_vector_field(states(1), 'GridVelocity') - vfield%aliased = .true. - do i = 1,nstates-1 + recursive subroutine allocate_and_insert_children(path, state, parent_mesh, parent_name, & + dont_allocate_prognostic_value_spaces) + character(len=*), intent(in) :: path !! option_path including prescribed/prognostic + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: parent_mesh + character(len=*), intent(in) :: parent_name + logical, optional, intent(in) :: dont_allocate_prognostic_value_spaces + + character(len=OPTION_PATH_LEN) child_path, child_name + character(len=FIELD_NAME_LEN) :: mesh_name + integer i + + ewrite(2,*) " Inserting children of: ",trim(path) + do i=0, option_count(trim(path)//"/scalar_field")-1 + child_path=trim(path)//"/scalar_field["//int2str(i)//"]" + ! Reset path to have name instead of index + call get_option(trim(child_path)//"/name", child_name) + child_path=trim(path)//"/scalar_field::"//trim(child_name) + call get_option(trim(complete_field_path(trim(child_path)))//"/mesh/name", & + mesh_name, default=trim(parent_mesh)) + call allocate_and_insert_scalar_field(child_path, state, & + parent_mesh=mesh_name, parent_name=parent_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end do + do i=0, option_count(trim(path)//"/vector_field")-1 + child_path=trim(path)//"/vector_field["//int2str(i)//"]" + ! Reset path to have name instead of index + call get_option(trim(child_path)//"/name", child_name) + child_path=trim(path)//"/vector_field::"//trim(child_name) + call get_option(trim(complete_field_path(trim(child_path)))//"/mesh/name", & + mesh_name, default=trim(parent_mesh)) + call allocate_and_insert_vector_field(child_path, state, & + parent_mesh=mesh_name, parent_name=parent_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end do + do i=0, option_count(trim(path)//"/tensor_field")-1 + child_path=trim(path)//"/tensor_field["//int2str(i)//"]" + ! Reset path to have name instead of index + call get_option(trim(child_path)//"/name", child_name) + child_path=trim(path)//"/tensor_field::"//trim(child_name) + call get_option(trim(complete_field_path(trim(child_path)))//"/mesh/name", & + mesh_name, default=trim(parent_mesh)) + call allocate_and_insert_tensor_field(child_path, state, & + parent_mesh=mesh_name, parent_name=parent_name, & + dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end do - call insert(states(i+1), vfield, 'GridVelocity') + end subroutine allocate_and_insert_children - end do - end if + subroutine allocate_and_insert_grandchildren(path, state,& + & parent_mesh, parent_name, dont_allocate_prognostic_value_spaces) + !!< Allocate those fields contained in a field which are not direct + !!< children. + character(len=*), intent(in) :: path !! option_path including prescribed/prognostic + type(state_type), intent(inout) :: state + character(len=*), intent(in) :: parent_mesh + character(len=*), intent(in) :: parent_name + logical, optional, intent(in) :: dont_allocate_prognostic_value_spaces - ! Deal with subgridscale parameterisations. - call alias_diffusivity(states) - end subroutine alias_fields + integer :: i - subroutine alias_diffusivity(states) - !!< Where fields get their diffusivity from a subgridscale - !!< parameterisation, it is necessary to alias their diffusivity to the - !!< diffusivity provided by the parameterisation. - !!< - !!< At this stage only prescribed diffusivity, the Generic Length Scale ocean model - !!< and the K-Epsilon turbulence model are handled via this route. - !!< Mellor-Yamada is pending a rewrite. - type(state_type), dimension(:), intent(inout) :: states - type(scalar_field), pointer :: sfield - type(tensor_field) :: tfield + ! This is necessarily somewhat more sui generis than + ! allocate_and_insert_children. - integer :: i, s, stat + do i = 1, size(grandchild_paths) + call allocate_and_insert_children(trim(path)& + &//trim(grandchild_paths(i)), state, parent_mesh, parent_name, & + &dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) + end do - ! Prescribed diffusivity - do i = 1, size(states) + end subroutine allocate_and_insert_grandchildren - tfield=extract_tensor_field(states(i), "PrescribedDiffusivity", stat) + logical function defer_allocation(option_path, mesh, & + dont_allocate_prognostic_value_spaces) + !!< Determines whether allocation of %val is deferred. + !!< This is used for fields that have been passed to SAM and + !!< only are allocate one by one when we get them back from SAM. + !!< Currently this is for all prognostic fields that are on a mesh + !!< that is not excluded from mesh adaptivity. + character(len=*), intent(in):: option_path + type(mesh_type), intent(in):: mesh + logical, optional, intent(in):: dont_allocate_prognostic_value_spaces - if (stat/=0) cycle + defer_allocation=present_and_true(dont_allocate_prognostic_value_spaces) & + .and. have_option(trim(option_path)//'/prognostic') & + .and. .not. have_option(trim(mesh%option_path)//'/exclude_from_mesh_adaptivity') + + end function defer_allocation + + subroutine set_prescribed_field_values(states, & + exclude_interpolated, exclude_nonreprescribed, initial_mesh, time) + + type(state_type), dimension(:), intent(in):: states + !! don't prescribe the fields with interpolation options + logical, intent(in), optional :: exclude_interpolated + !! do not prescribe the fields that have requested not to be represcribed + logical, intent(in), optional :: exclude_nonreprescribed + !! indicates whether we're prescribing on the initial mesh, if not (default) + !! the fields with needs_initial_mesh(field) are left untouched, they have to + !! be interpolated (somewhere else) + logical, intent(in), optional:: initial_mesh + !! current time if not using that in the options tree + real, intent(in), optional :: time + + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield + type(tensor_field), pointer :: tfield + type(vector_field), pointer :: position + character(len=OPTION_PATH_LEN):: phase_path + logical :: mesh_changed + integer :: p, f, nphases, nsfields, nvfields, ntfields + + ewrite(1,*) "In set_prescribed_field_values" + + mesh_changed = .not. present_and_true(initial_mesh) + + nphases = option_count('/material_phase') + do p = 0, nphases-1 + + phase_path = '/material_phase['//int2str(p)//']' + + ! Scalar fields: + nsfields = scalar_field_count(states(p+1)) + do f = 1, nsfields + sfield => extract_scalar_field(states(p+1),f) + if (have_option(trim(sfield%option_path)//'/prescribed') .and. & + .not. aliased(sfield) .and. & + .not. (present_and_true(exclude_interpolated) .and. & + interpolate_field(sfield)) .and. & + .not. (present_and_true(exclude_nonreprescribed) .and. & + do_not_recalculate(sfield%option_path)) .and. & + .not. (mesh_changed .and. needs_initial_mesh(sfield)) & + ) then + + position => get_external_coordinate_field(states(p+1), sfield%mesh) + + call zero(sfield) + call initialise_field_over_regions(sfield, & + trim(sfield%option_path)//'/prescribed/value', & + position, time=time) + end if + end do + + nvfields = vector_field_count(states(p+1)) + do f = 1, nvfields + vfield => extract_vector_field(states(p+1), f) + if (have_option(trim(vfield%option_path)//'/prescribed') .and. & + .not. aliased(vfield) .and. & + .not. (present_and_true(exclude_interpolated) .and. & + interpolate_field(vfield)) .and. & + .not. (present_and_true(exclude_nonreprescribed) .and. & + do_not_recalculate(vfield%option_path)) .and. & + .not. (mesh_changed .and. needs_initial_mesh(vfield)) & + ) then + + position => get_external_coordinate_field(states(p+1), vfield%mesh) + + call zero(vfield) + call initialise_field_over_regions(vfield, & + trim(vfield%option_path)//'/prescribed/value', & + position, time=time) + end if + end do + + ntfields = tensor_field_count(states(p+1)) + do f = 1, ntfields + tfield => extract_tensor_field(states(p+1), f) + if (have_option(trim(tfield%option_path)//'/prescribed') .and. & + .not. aliased(tfield) .and. & + .not. (present_and_true(exclude_interpolated) .and. & + interpolate_field(tfield)) .and. & + .not. (present_and_true(exclude_nonreprescribed) .and. & + do_not_recalculate(tfield%option_path)) .and. & + .not. (mesh_changed .and. needs_initial_mesh(tfield)) & + ) then + + position => get_external_coordinate_field(states(p+1), tfield%mesh) + + call zero(tfield) + call initialise_field_over_regions(tfield, & + trim(tfield%option_path)//'/prescribed/value', & + position, time=time) + end if + end do - tfield%aliased=.True. + end do - do s = 1, scalar_field_count(states(i)) + if(have_option('/ocean_forcing/external_data_boundary_conditions')) then - sfield => extract_scalar_field(states(i), s) + call set_nemo_fields(states(1)) - if (have_option(trim(sfield%option_path)//& - "/prognostic/subgridscale_parameterisation& - &::prescribed_diffusivity")) then + endif - tfield%name=trim(sfield%name)//"Diffusivity" - call insert(states(i), tfield, tfield%name) + ! flush the cache + call vtk_cache_finalise() - end if + end subroutine set_prescribed_field_values - end do + subroutine initialise_prognostic_fields(states, save_vtk_cache, & + initial_mesh) + !!< Set the values of prognostic fields with their initial conditions + type(state_type), dimension(:), intent(in):: states + !! By default the vtk_cache, build up by the from_file initialisations + !! in this subroutine, is flushed at the end of this subroutine. This + !! cache can be reused however in subsequent calls reading from vtu files + logical, intent(in), optional:: save_vtk_cache + !! indicates whether we're initalising on the initial mesh, if not (default) + !! the fields with needs_initial_mesh(field) are left untouched, they have to + !! be interpolated (somewhere else) + logical, intent(in), optional:: initial_mesh - end do + ! these must be pointers as bc's should be added to the original field + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield - ! Eddy diffusivity from Generic Length Scale Ocean model - do i = 1, size(states) + type(vector_field), pointer:: position + character(len=OPTION_PATH_LEN):: phase_path + integer p, f, nphases, nsfields, nvfields + logical:: mesh_changed - tfield=extract_tensor_field(states(i), "GLSEddyDiffusivityKH", stat) + ewrite(1,*) "In initialise_prognostic_fields" - if (stat/=0) cycle + mesh_changed = .not. present_and_true(initial_mesh) - tfield%aliased=.True. + nphases = option_count('/material_phase') + do p = 0, nphases-1 - do s = 1, scalar_field_count(states(i)) + phase_path = '/material_phase['//int2str(p)//']' - sfield => extract_scalar_field(states(i), s) + position => extract_vector_field(states(p+1), "Coordinate") - if (have_option(trim(sfield%option_path)//& - "/prognostic/subgridscale_parameterisation& - &::GLS")) then + ! Scalar fields: + nsfields = scalar_field_count(states(p+1)) + do f = 1, nsfields + sfield => extract_scalar_field(states(p+1),f) + if (mesh_changed .and. needs_initial_mesh(sfield)) cycle + if (.not. aliased(sfield) .and. & + have_option(trim(sfield%option_path)//'/prognostic')) then + call zero(sfield) + call initialise_field_over_regions(sfield, & + trim(sfield%option_path)//'/prognostic/initial_condition', & + position, phase_path=trim(phase_path)) + end if + end do + + nvfields = vector_field_count(states(p+1)) + do f = 1, nvfields + vfield => extract_vector_field(states(p+1), f) + if (mesh_changed .and. needs_initial_mesh(vfield)) cycle + if (.not. aliased(vfield) .and. & + have_option(trim(vfield%option_path)//'/prognostic')) then + call zero(vfield) + call initialise_field_over_regions(vfield, & + trim(vfield%option_path)//'/prognostic/initial_condition', & + position, phase_path=trim(phase_path)) + end if + end do - tfield%name=trim(sfield%name)//"Diffusivity" - call insert(states(i), tfield, tfield%name) + end do - end if + if (.not. present_and_true(save_vtk_cache)) then + ! flush the cache + call vtk_cache_finalise() + end if - end do + end subroutine initialise_prognostic_fields - end do + subroutine allocate_and_insert_auxilliary_fields(states) + ! Set up some auxilliary fields to the prognostic fields. + ! i.e. old and iterated fields depending on options set + type(state_type), dimension(:), intent(inout):: states - end subroutine alias_diffusivity + type(scalar_field), pointer :: sfield + type(vector_field), pointer :: vfield - function allocate_scalar_field_as_constant(option_path) result(is_constant) - !!< Return whether the supplied option path signals a constant - !!< field + type(scalar_field) :: aux_sfield + type(vector_field) :: aux_vfield - character(len = *), intent(in) :: option_path + integer :: iterations + logical :: steady_state_global, prognostic, prescribed, diagnostic, gravity - logical :: is_constant + character(len=FIELD_NAME_LEN) :: field_name + character(len=OPTION_PATH_LEN) :: state_path, field_path - is_constant = .false. - if(option_count(trim(option_path) // "/prescribed/value") == 1) then - is_constant = have_option(trim(option_path) // "/prescribed/value[0]/constant") - end if + integer :: nsfields, nvfields, p, f, p2, stat + real :: current_time - end function allocate_scalar_field_as_constant + type(mesh_type), pointer :: x_mesh - function allocate_vector_field_as_constant(option_path) result(is_constant) - !!< Return whether the supplied option path signals a constant - !!< field + ewrite(1,*) "In allocate_and_insert_auxilliary_fields" - character(len = *), intent(in) :: option_path + call get_option("/timestepping/nonlinear_iterations", iterations, default=1) + steady_state_global = have_option("/timestepping/steady_state") - logical :: is_constant + ! old and iterated fields + do p = 1, size(states) - is_constant = .false. - if(option_count(trim(option_path) // "/prescribed/value") == 1) then - is_constant = have_option(trim(option_path) // "/prescribed/value[0]/constant") - end if + ! Get number of scalar fields that are children of this state + nsfields=scalar_field_count(states(p)) - end function allocate_vector_field_as_constant + ! Loop over scalar fields + sfields_loop: do f=1, nsfields - function allocate_tensor_field_as_constant(option_path) result(is_constant) - !!< Return whether the supplied option path signals a constant - !!< field + sfield => extract_scalar_field(states(p), f) - character(len = *), intent(in) :: option_path + ! Save path to field + field_path=trim(sfield%option_path) - logical :: is_constant + ! Get field name - this checks if the field has an option_path + call get_option(trim(field_path)//"/name", field_name, stat) - if(option_count(trim(option_path) // "/prescribed/value") == 1) then - is_constant = have_option(trim(option_path) // "/prescribed/value/isotropic/constant") .or. & - & have_option(trim(option_path) // "/prescribed/value/anisotropic_symmetric/constant") .or. & - & have_option(trim(option_path) // "/prescribed/value/anisotropic_asymmetric/constant") - else - is_constant = .false. - end if + if((stat==0).and.(.not.aliased(sfield))) then - end function allocate_tensor_field_as_constant + prognostic=have_option(trim(sfield%option_path)//"/prognostic") + prescribed=have_option(trim(sfield%option_path)//"/prescribed") + diagnostic=have_option(trim(sfield%option_path)//"/diagnostic") - function allocate_field_as_constant_scalar(s_field) result(is_constant) - !!< Return whether the options tree defines the supplied scalar field to - !!< be constant + ! if (prognostic or diagnostic) and (doing a steady state check on this field or doing more than 1 global iteration) + if((prognostic.or.diagnostic)& + .and.((steady_state_global.and.steady_state_field(sfield)).or.(iterations>1) .or. & + have_option(trim(sfield%option_path) // '/prognostic/spatial_discretisation/discontinuous_galerkin/slope_limiter::FPN') )) then - type(scalar_field), intent(in) :: s_field + call allocate(aux_sfield, sfield%mesh, "Old"//trim(sfield%name)) + call zero(aux_sfield) + call insert(states(p), aux_sfield, trim(aux_sfield%name)) + call deallocate(aux_sfield) - logical :: is_constant + else - is_constant = allocate_scalar_field_as_constant(s_field%option_path) + aux_sfield = extract_scalar_field(states(p), trim(sfield%name)) + aux_sfield%name = "Old"//trim(sfield%name) + aux_sfield%option_path="" ! blank the option path so that it + ! doesn't get picked up in the next + ! aliased field loop + aux_sfield%aliased=.true. + call insert(states(p), aux_sfield, trim(aux_sfield%name)) - end function allocate_field_as_constant_scalar + end if - function allocate_field_as_constant_vector(v_field) result(is_constant) - !!< Return whether the options tree defines the supplied vector field to - !!< be constant + if((prognostic.or.diagnostic)& + .and.((convergence_field(sfield).and.(iterations>1)))) then - type(vector_field), intent(in) :: v_field + call allocate(aux_sfield, sfield%mesh, "Iterated"//trim(sfield%name)) + call zero(aux_sfield) + call insert(states(p), aux_sfield, trim(aux_sfield%name)) + call deallocate(aux_sfield) - logical :: is_constant + else - is_constant = allocate_vector_field_as_constant(v_field%option_path) + aux_sfield = extract_scalar_field(states(p), trim(sfield%name)) + aux_sfield%name = "Iterated"//trim(sfield%name) + aux_sfield%option_path="" ! blank the option path so that it + ! doesn't get picked up in the next + ! aliased field loop + aux_sfield%aliased=.true. + call insert(states(p), aux_sfield, trim(aux_sfield%name)) - end function allocate_field_as_constant_vector + end if - function allocate_field_as_constant_tensor(t_field) result(is_constant) - !!< Return whether the options tree defines the supplied tensor field to - !!< be constant + end if - type(tensor_field), intent(in) :: t_field + end do sfields_loop - logical :: is_constant + ! Get number of vector fields that are children of this state + nvfields=vector_field_count(states(p)) - if(trim(t_field%name) == "MinMetricEigenbound") then - is_constant = have_option("/mesh_adaptivity/hr_adaptivity/tensor_field::MinimumEdgeLengths/anisotropic_symmetric/constant") - else if(trim(t_field%name) == "MaxMetricEigenbound") then - is_constant = have_option("/mesh_adaptivity/hr_adaptivity/tensor_field::MaximumEdgeLengths/anisotropic_symmetric/constant") - else - is_constant = allocate_tensor_field_as_constant(t_field%option_path) - end if + ! Loop over vector fields + do f=1, nvfields - end function allocate_field_as_constant_tensor + vfield => extract_vector_field(states(p), f) - recursive subroutine allocate_and_insert_scalar_field(option_path, state, & - parent_mesh, parent_name, field_name, & - dont_allocate_prognostic_value_spaces) + ! Save path to field + field_path=trim(vfield%option_path) - character(len=*), intent(in) :: option_path - type(state_type), intent(inout) :: state - character(len=*), intent(in), optional :: parent_mesh - character(len=*), intent(in), optional :: parent_name - character(len=*), optional, intent(in):: field_name - logical, optional, intent(in):: dont_allocate_prognostic_value_spaces + ! Get field name - this checks if the field has an option_path + call get_option(trim(field_path)//"/name", field_name, stat) - logical :: is_prognostic, is_prescribed, is_diagnostic, is_aliased - ! paths for options and child fields - character(len=OPTION_PATH_LEN) :: path, adapt_path - ! Strings for names - character(len=OPTION_PATH_LEN) :: lfield_name, mesh_name - type(scalar_field) :: field - type(mesh_type), pointer :: mesh - logical :: backward_compatibility, is_constant + if((stat==0).and.(.not.aliased(vfield))) then - is_aliased=have_option(trim(option_path)//"/aliased") - if(is_aliased) return + prognostic=have_option(trim(vfield%option_path)//"/prognostic") + prescribed=have_option(trim(vfield%option_path)//"/prescribed") + diagnostic=have_option(trim(vfield%option_path)//"/diagnostic") - ! Save option_path - path=trim(option_path) + if((prognostic.or.diagnostic)& + .and.((steady_state_global.and.steady_state_field(vfield)).or.(iterations>1))) then - if (present(field_name)) then - lfield_name=field_name - else - call get_option(trim(path)//"/name", lfield_name) - end if + call allocate(aux_vfield, vfield%dim, vfield%mesh, "Old"//trim(vfield%name)) + call zero(aux_vfield) + call insert(states(p), aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - if(present(parent_name)) then - lfield_name=trim(parent_name)//trim(lfield_name) - end if - ewrite(1,*) "In allocate_and_insert_scalar_field, field is: ", trim(lfield_name) + else if((prescribed).and.(trim(vfield%name)=="Velocity")) then - ! Do we need backward compatibility? - ! If we need backward compatibility, then no matter how the field - ! is described in XML, a value space will be allocated, for old-style - ! code to use. - ! If we do not need backward compatibility, we can make big savings - ! on constant fields. - ! Any fields that require backward compatibility are badly behaved, as they - ! modify constant fields. *Do not add to this list!* Construct an - ! appropriate diagnostic algorithm instead (possibly an internal). - backward_compatibility = .false. + call allocate(aux_vfield, vfield%dim, vfield%mesh, "Old"//trim(vfield%name), field_type = vfield%field_type) + call zero(aux_vfield) + call insert(states(p), aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - ! Find out what kind of field we have - is_prognostic=have_option(trim(path)//"/prognostic") - is_prescribed=have_option(trim(path)//"/prescribed") - is_diagnostic=have_option(trim(path)//"/diagnostic") + else - is_constant=allocate_tensor_field_as_constant(path) + aux_vfield = extract_vector_field(states(p), trim(vfield%name)) + aux_vfield%name = "Old"//trim(vfield%name) + aux_vfield%option_path="" ! blank the option path so that it + ! doesn't get picked up in the next + ! aliased field loop + aux_vfield%aliased=.true. + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - ewrite(1,*) "Is field prognostic? ", is_prognostic - ewrite(1,*) "Is field prescribed? ", is_prescribed - ewrite(1,*) "Is field constant? ", is_constant - ewrite(1,*) "Is field diagnostic? ", is_diagnostic + end if - if (is_prognostic) then + if((prognostic.or.diagnostic)& + .and.(convergence_field(vfield).and.(iterations>1))) then - path=trim(path)//"/prognostic" + call allocate(aux_vfield, vfield%dim, vfield%mesh, "Iterated"//trim(vfield%name)) + call zero(aux_vfield) + call insert(states(p), aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - else if(is_prescribed) then + else if((prescribed).and.((trim(vfield%name)=="Velocity"))) then - path=trim(path)//"/prescribed" + call allocate(aux_vfield, vfield%dim, vfield%mesh, "Iterated"//trim(vfield%name)) + call zero(aux_vfield) + call insert(states(p), aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - else if(is_diagnostic) then + else - path=trim(path)//"/diagnostic" + aux_vfield = extract_vector_field(states(p), trim(vfield%name)) + aux_vfield%name = "Iterated"//trim(vfield%name) + aux_vfield%option_path="" ! blank the option path so that it + ! doesn't get picked up in the next + ! aliased field loop + aux_vfield%aliased=.true. + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - end if + end if - ! Get mesh - if(present(parent_mesh).and.& - .not.have_option(trim(path)//"/mesh[0]/name")) then - mesh => extract_mesh(state, trim(parent_mesh)) - mesh_name=parent_mesh - else - call get_option(trim(path)//"/mesh[0]/name", mesh_name) - mesh => extract_mesh(state, trim(mesh_name)) - end if - - if (defer_allocation(option_path, mesh, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces)) then - ! If we want to defer allocation (for sam), don't allocate the value space yet - call allocate(field, mesh, name=trim(lfield_name), & - field_type=FIELD_TYPE_DEFERRED) - else if(is_constant .and. .not. backward_compatibility) then - - ! Allocate as constant field if possible (and we don't need backward compatibility) - call allocate(field, mesh, name=trim(lfield_name), & - field_type=FIELD_TYPE_CONSTANT) - - call zero(field) - else - ! If we have to keep backward compatibility, then - ! just allocate the value space as normal, - ! and don't try any funny tricks to save memory. - - ! Allocate field - call allocate(field, mesh, name=trim(lfield_name)) - call zero(field) - end if - - - ewrite(2,*) trim(lfield_name), " is on mesh ", trim(mesh%name) - - ! Set field%option_path - field%option_path=trim(option_path) - - ! Finally! Insert field into state! - call insert(state, field, field%name) - call deallocate(field) - - ! Check for fields that are children of this field: - call allocate_and_insert_children(path, state, mesh_name, lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - call allocate_and_insert_grandchildren(path, state, mesh_name,& - & lfield_name, & - & dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - - ! Check for adaptivity weights associated with this field: - adapt_path=trim(path)//"/adaptivity_options" - if(have_option(trim(adapt_path)//"/absolute_measure")) then - adapt_path=trim(adapt_path)//"/absolute_measure/scalar_field::InterpolationErrorBound" - call allocate_and_insert_scalar_field(adapt_path, state, parent_mesh=topology_mesh_name, & - parent_name=lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - else if(have_option(trim(adapt_path)//"/relative_measure")) then - adapt_path=trim(adapt_path)//"/relative_measure/scalar_field::InterpolationErrorBound" - call allocate_and_insert_scalar_field(adapt_path, state, parent_mesh=topology_mesh_name, & - parent_name=lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if - - end subroutine allocate_and_insert_scalar_field - - recursive subroutine allocate_and_insert_vector_field(option_path, state, parent_mesh, parent_name, & - field_name, dont_allocate_prognostic_value_spaces) - - character(len=*), intent(in) :: option_path - type(state_type), intent(inout) :: state - character(len=*), intent(in), optional :: parent_mesh - character(len=*), intent(in), optional :: parent_name - character(len=*), optional, intent(in):: field_name - logical, intent(in), optional :: dont_allocate_prognostic_value_spaces - - integer :: dim - logical :: is_prognostic, is_prescribed, is_diagnostic, is_aliased - ! paths for options and child fields - character(len=OPTION_PATH_LEN) :: path, adapt_path - ! strings for names - character(len=OPTION_PATH_LEN) :: lfield_name, mesh_name - type(mesh_type), pointer :: mesh - type(vector_field) :: field - logical :: backward_compatibility, is_constant - - is_aliased=have_option(trim(option_path)//"/aliased") - if(is_aliased) return - - ! Save option_path - path=trim(option_path) - - if (present(field_name)) then - lfield_name=field_name - else - call get_option(trim(path)//"/name", lfield_name) - end if - - if(present(parent_name)) then - lfield_name=trim(parent_name)//trim(lfield_name) - end if - ewrite(1,*) "In allocate_and_insert_vector_field, field is: ", trim(lfield_name) - - ! Do we need backward compatibility? - ! If we need backward compatibility, then no matter how the field - ! is described in XML, a value space will be allocated, for old-style - ! code to use. - ! If we do not need backward compatibility, we can make big savings - ! on constant fields. - ! Any fields that require backward compatibility are badly behaved, as they - ! modify constant fields. *Do not add to this list!* Construct an - ! appropriate diagnostic algorithm instead (possibly an internal). - backward_compatibility = .false. - - ! Find out what kind of field we have - is_prognostic=have_option(trim(path)//"/prognostic") - is_prescribed=have_option(trim(path)//"/prescribed") - is_diagnostic=have_option(trim(path)//"/diagnostic") - - is_constant=allocate_vector_field_as_constant(path) - - ewrite(1,*) "Is field prognostic? ", is_prognostic - ewrite(1,*) "Is field prescribed? ", is_prescribed - ewrite(1,*) "Is field constant? ", is_constant - ewrite(1,*) "Is field diagnostic? ", is_diagnostic - - ! Get dimension of vector - currently the dimension of the problem - call get_option("/geometry/dimension", dim) - - if(is_prognostic) then - path=trim(path)//"/prognostic" - else if(is_prescribed) then - path=trim(path)//"/prescribed" - else if(is_diagnostic) then - path=trim(path)//"/diagnostic" - end if - - ! Get mesh - if(present(parent_mesh).and.& - .not.have_option(trim(path)//"/mesh[0]/name")) then - mesh => extract_mesh(state, trim(parent_mesh)) - mesh_name=parent_mesh - else - call get_option(trim(path)//"/mesh[0]/name", mesh_name) - mesh => extract_mesh(state, trim(mesh_name)) - end if - - if (defer_allocation(option_path, mesh, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces)) then - ! If we want to defer allocation (for sam), don't allocate the value space yet - call allocate(field, dim, mesh, name=trim(lfield_name), & - field_type=FIELD_TYPE_DEFERRED) - else if(is_constant .and. .not. backward_compatibility) then - - ! Allocate as constant field if possible (and we don't need backward compatibility) - call allocate(field, dim, mesh, name=trim(lfield_name), & - field_type=FIELD_TYPE_CONSTANT) - call zero(field) - - else - ! If we have to keep backward compatibility, then - ! just allocate the value space as normal, - ! and don't try any funny tricks to save memory. - - ! Allocate field - call allocate(field, dim, mesh, trim(lfield_name)) - call zero(field) - end if - - ewrite(2,*) trim(lfield_name), " is on mesh ", trim(mesh%name) - - ! Set field%option_path - field%option_path=trim(option_path) - - ! Finally! Insert field into state! - call insert(state, field, field%name) - call deallocate(field) - - ! Check for fields that are children of this field: - call allocate_and_insert_children(path, state, mesh_name, lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - call allocate_and_insert_grandchildren(path, state, mesh_name, lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - - ! Check for adaptivity weights associated with this field: - adapt_path=trim(path)//"/adaptivity_options" - if(have_option(trim(adapt_path)//"/absolute_measure")) then - adapt_path=trim(adapt_path)//"/absolute_measure/vector_field::InterpolationErrorBound" - call allocate_and_insert_vector_field(adapt_path, state, topology_mesh_name, lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - else if(have_option(trim(adapt_path)//"/relative_measure")) then - adapt_path=trim(adapt_path)//"/relative_measure/vector_field::InterpolationErrorBound" - call allocate_and_insert_vector_field(adapt_path, state, topology_mesh_name, lfield_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if - - end subroutine allocate_and_insert_vector_field - - recursive subroutine allocate_and_insert_tensor_field(option_path, state, parent_mesh, parent_name, & - dont_allocate_prognostic_value_spaces) - !!< This subroutine sets up the initial condition of a tensor field. - !!< Note that the tensor dimensions are set to be the dimension of the - !!< problem. - - character(len=*), intent(in) :: option_path - type(state_type), intent(inout) :: state - character(len=*), intent(in), optional :: parent_mesh - character(len=*), intent(in), optional :: parent_name - logical, intent(in), optional :: dont_allocate_prognostic_value_spaces - - logical :: backward_compatibility, is_prescribed, is_diagnostic, is_constant, is_aliased - ! paths for options and child fields - character(len=OPTION_PATH_LEN) :: path, adapt_path - character(len=OPTION_PATH_LEN) :: field_name, mesh_name - type(tensor_field) :: field - type(mesh_type), pointer:: mesh - - is_aliased=have_option(trim(option_path)//"/aliased") - if(is_aliased) return - - ! Save option_path - path=trim(option_path) - - call get_option(trim(path)//"/name", field_name) - if(present(parent_name)) then - if(trim(field_name)/="Viscosity") then - field_name=trim(parent_name)//trim(field_name) - end if - end if - ewrite(1,*) "In allocate_and_insert_tensor_field, field is: ", trim(field_name) - - ! Do we need backward compatibility? - ! If we need backward compatibility, then no matter how the field - ! is described in XML, a value space will be allocated, for old-style - ! code to use. - ! If we do not need backward compatibility, we can make big savings - ! on constant fields. - ! Any fields that require backward compatibility are badly behaved, as they - ! modify constant fields. *Do not add to this list!* Construct an - ! appropriate diagnostic algorithm instead (possibly an internal). - backward_compatibility = any(field_name == (/"ElectricalPotentialDiffusivity "/)) - - ! Find out what kind of field we have - is_prescribed=have_option(trim(path)//"/prescribed") - is_diagnostic=have_option(trim(path)//"/diagnostic") - is_constant=allocate_tensor_field_as_constant(path) - - ewrite(1,*) "Is field prescribed? ", is_prescribed - ewrite(1,*) "Is field diagnostic? ", is_diagnostic - ewrite(1,*) "Is field constant? ", is_constant - - if(is_prescribed) then - - path=trim(path)//"/prescribed" - - else if(is_diagnostic) then - - path=trim(path)//"/diagnostic" - - end if - - ! Get mesh - if(present(parent_mesh).and.& - .not.have_option(trim(path)//"/mesh[0]/name")) then - mesh => extract_mesh(state, trim(parent_mesh)) - mesh_name=parent_mesh - else - call get_option(trim(path)//"/mesh[0]/name", mesh_name) - mesh => extract_mesh(state, trim(mesh_name)) - end if - - if (defer_allocation(option_path, mesh, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces)) then - - ! If we want to defer allocation (for sam), don't allocate the value space yet - call allocate(field, mesh, name=trim(field_name), & - field_type=FIELD_TYPE_DEFERRED) - - else if(is_constant .and. .not. backward_compatibility) then - - ! Allocate as constant field if possible (and we don't need backward compatibility) - call allocate(field, mesh, name=trim(field_name), & - field_type=FIELD_TYPE_CONSTANT) - call zero(field) - else - - ! Allocate field - call allocate(field, mesh, trim(field_name)) - call zero(field) - end if - - - ! Set field%option_path - field%option_path=trim(option_path) - - ! Finally! Insert field into state! - call insert(state, field, field%name) - call deallocate(field) - - ! Check for fields that are children of this field: - call allocate_and_insert_children(path, state, mesh_name, field_name, & - & dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - call allocate_and_insert_grandchildren(path, state, mesh_name, & - & field_name, dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - - ! Check for adaptivity weights associated with this field: - adapt_path=trim(path)//"/adaptivity_options" - if(have_option(trim(adapt_path)//"/absolute_measure")) then - adapt_path=trim(adapt_path)//"/absolute_measure/tensor_field::InterpolationErrorBound" - call allocate_and_insert_tensor_field(adapt_path, state, topology_mesh_name, field_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - else if(have_option(trim(adapt_path)//"/relative_measure")) then - adapt_path=trim(adapt_path)//"/relative_measure/tensor_field::InterpolationErrorBound" - call allocate_and_insert_tensor_field(adapt_path, state, topology_mesh_name, field_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end if - - end subroutine allocate_and_insert_tensor_field - - recursive subroutine allocate_and_insert_children(path, state, parent_mesh, parent_name, & - dont_allocate_prognostic_value_spaces) - character(len=*), intent(in) :: path !! option_path including prescribed/prognostic - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: parent_mesh - character(len=*), intent(in) :: parent_name - logical, optional, intent(in) :: dont_allocate_prognostic_value_spaces - - character(len=OPTION_PATH_LEN) child_path, child_name - character(len=FIELD_NAME_LEN) :: mesh_name - integer i - - ewrite(2,*) " Inserting children of: ",trim(path) - do i=0, option_count(trim(path)//"/scalar_field")-1 - child_path=trim(path)//"/scalar_field["//int2str(i)//"]" - ! Reset path to have name instead of index - call get_option(trim(child_path)//"/name", child_name) - child_path=trim(path)//"/scalar_field::"//trim(child_name) - call get_option(trim(complete_field_path(trim(child_path)))//"/mesh/name", & - mesh_name, default=trim(parent_mesh)) - call allocate_and_insert_scalar_field(child_path, state, & - parent_mesh=mesh_name, parent_name=parent_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end do - do i=0, option_count(trim(path)//"/vector_field")-1 - child_path=trim(path)//"/vector_field["//int2str(i)//"]" - ! Reset path to have name instead of index - call get_option(trim(child_path)//"/name", child_name) - child_path=trim(path)//"/vector_field::"//trim(child_name) - call get_option(trim(complete_field_path(trim(child_path)))//"/mesh/name", & - mesh_name, default=trim(parent_mesh)) - call allocate_and_insert_vector_field(child_path, state, & - parent_mesh=mesh_name, parent_name=parent_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end do - do i=0, option_count(trim(path)//"/tensor_field")-1 - child_path=trim(path)//"/tensor_field["//int2str(i)//"]" - ! Reset path to have name instead of index - call get_option(trim(child_path)//"/name", child_name) - child_path=trim(path)//"/tensor_field::"//trim(child_name) - call get_option(trim(complete_field_path(trim(child_path)))//"/mesh/name", & - mesh_name, default=trim(parent_mesh)) - call allocate_and_insert_tensor_field(child_path, state, & - parent_mesh=mesh_name, parent_name=parent_name, & - dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end do - - end subroutine allocate_and_insert_children - - subroutine allocate_and_insert_grandchildren(path, state,& - & parent_mesh, parent_name, dont_allocate_prognostic_value_spaces) - !!< Allocate those fields contained in a field which are not direct - !!< children. - character(len=*), intent(in) :: path !! option_path including prescribed/prognostic - type(state_type), intent(inout) :: state - character(len=*), intent(in) :: parent_mesh - character(len=*), intent(in) :: parent_name - logical, optional, intent(in) :: dont_allocate_prognostic_value_spaces - - - integer :: i - - ! This is necessarily somewhat more sui generis than - ! allocate_and_insert_children. - - do i = 1, size(grandchild_paths) - call allocate_and_insert_children(trim(path)& - &//trim(grandchild_paths(i)), state, parent_mesh, parent_name, & - &dont_allocate_prognostic_value_spaces=dont_allocate_prognostic_value_spaces) - end do - - end subroutine allocate_and_insert_grandchildren - - logical function defer_allocation(option_path, mesh, & - dont_allocate_prognostic_value_spaces) - !!< Determines whether allocation of %val is deferred. - !!< This is used for fields that have been passed to SAM and - !!< only are allocate one by one when we get them back from SAM. - !!< Currently this is for all prognostic fields that are on a mesh - !!< that is not excluded from mesh adaptivity. - character(len=*), intent(in):: option_path - type(mesh_type), intent(in):: mesh - logical, optional, intent(in):: dont_allocate_prognostic_value_spaces - - defer_allocation=present_and_true(dont_allocate_prognostic_value_spaces) & - .and. have_option(trim(option_path)//'/prognostic') & - .and. .not. have_option(trim(mesh%option_path)//'/exclude_from_mesh_adaptivity') - - end function defer_allocation - - subroutine set_prescribed_field_values(states, & - exclude_interpolated, exclude_nonreprescribed, initial_mesh, time) - - type(state_type), dimension(:), intent(in):: states - !! don't prescribe the fields with interpolation options - logical, intent(in), optional :: exclude_interpolated - !! do not prescribe the fields that have requested not to be represcribed - logical, intent(in), optional :: exclude_nonreprescribed - !! indicates whether we're prescribing on the initial mesh, if not (default) - !! the fields with needs_initial_mesh(field) are left untouched, they have to - !! be interpolated (somewhere else) - logical, intent(in), optional:: initial_mesh - !! current time if not using that in the options tree - real, intent(in), optional :: time - - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - type(tensor_field), pointer :: tfield - type(vector_field), pointer :: position - character(len=OPTION_PATH_LEN):: phase_path - logical :: mesh_changed - integer :: p, f, nphases, nsfields, nvfields, ntfields - - ewrite(1,*) "In set_prescribed_field_values" - - mesh_changed = .not. present_and_true(initial_mesh) - - nphases = option_count('/material_phase') - do p = 0, nphases-1 - - phase_path = '/material_phase['//int2str(p)//']' - - ! Scalar fields: - nsfields = scalar_field_count(states(p+1)) - do f = 1, nsfields - sfield => extract_scalar_field(states(p+1),f) - if (have_option(trim(sfield%option_path)//'/prescribed') .and. & - .not. aliased(sfield) .and. & - .not. (present_and_true(exclude_interpolated) .and. & - interpolate_field(sfield)) .and. & - .not. (present_and_true(exclude_nonreprescribed) .and. & - do_not_recalculate(sfield%option_path)) .and. & - .not. (mesh_changed .and. needs_initial_mesh(sfield)) & - ) then - - position => get_external_coordinate_field(states(p+1), sfield%mesh) - - call zero(sfield) - call initialise_field_over_regions(sfield, & - trim(sfield%option_path)//'/prescribed/value', & - position, time=time) - end if - end do - - nvfields = vector_field_count(states(p+1)) - do f = 1, nvfields - vfield => extract_vector_field(states(p+1), f) - if (have_option(trim(vfield%option_path)//'/prescribed') .and. & - .not. aliased(vfield) .and. & - .not. (present_and_true(exclude_interpolated) .and. & - interpolate_field(vfield)) .and. & - .not. (present_and_true(exclude_nonreprescribed) .and. & - do_not_recalculate(vfield%option_path)) .and. & - .not. (mesh_changed .and. needs_initial_mesh(vfield)) & - ) then - - position => get_external_coordinate_field(states(p+1), vfield%mesh) - - call zero(vfield) - call initialise_field_over_regions(vfield, & - trim(vfield%option_path)//'/prescribed/value', & - position, time=time) - end if - end do - - ntfields = tensor_field_count(states(p+1)) - do f = 1, ntfields - tfield => extract_tensor_field(states(p+1), f) - if (have_option(trim(tfield%option_path)//'/prescribed') .and. & - .not. aliased(tfield) .and. & - .not. (present_and_true(exclude_interpolated) .and. & - interpolate_field(tfield)) .and. & - .not. (present_and_true(exclude_nonreprescribed) .and. & - do_not_recalculate(tfield%option_path)) .and. & - .not. (mesh_changed .and. needs_initial_mesh(tfield)) & - ) then - - position => get_external_coordinate_field(states(p+1), tfield%mesh) - - call zero(tfield) - call initialise_field_over_regions(tfield, & - trim(tfield%option_path)//'/prescribed/value', & - position, time=time) - end if - end do - - end do - - if(have_option('/ocean_forcing/external_data_boundary_conditions')) then - - call set_nemo_fields(states(1)) - - endif - - ! flush the cache - call vtk_cache_finalise() - - end subroutine set_prescribed_field_values - - subroutine initialise_prognostic_fields(states, save_vtk_cache, & - initial_mesh) - !!< Set the values of prognostic fields with their initial conditions - type(state_type), dimension(:), intent(in):: states - !! By default the vtk_cache, build up by the from_file initialisations - !! in this subroutine, is flushed at the end of this subroutine. This - !! cache can be reused however in subsequent calls reading from vtu files - logical, intent(in), optional:: save_vtk_cache - !! indicates whether we're initalising on the initial mesh, if not (default) - !! the fields with needs_initial_mesh(field) are left untouched, they have to - !! be interpolated (somewhere else) - logical, intent(in), optional:: initial_mesh - - ! these must be pointers as bc's should be added to the original field - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield - - type(vector_field), pointer:: position - character(len=OPTION_PATH_LEN):: phase_path - integer p, f, nphases, nsfields, nvfields - logical:: mesh_changed - - ewrite(1,*) "In initialise_prognostic_fields" - - mesh_changed = .not. present_and_true(initial_mesh) - - nphases = option_count('/material_phase') - do p = 0, nphases-1 - - phase_path = '/material_phase['//int2str(p)//']' - - position => extract_vector_field(states(p+1), "Coordinate") - - ! Scalar fields: - nsfields = scalar_field_count(states(p+1)) - do f = 1, nsfields - sfield => extract_scalar_field(states(p+1),f) - if (mesh_changed .and. needs_initial_mesh(sfield)) cycle - if (.not. aliased(sfield) .and. & - have_option(trim(sfield%option_path)//'/prognostic')) then - call zero(sfield) - call initialise_field_over_regions(sfield, & - trim(sfield%option_path)//'/prognostic/initial_condition', & - position, phase_path=trim(phase_path)) - end if - end do - - nvfields = vector_field_count(states(p+1)) - do f = 1, nvfields - vfield => extract_vector_field(states(p+1), f) - if (mesh_changed .and. needs_initial_mesh(vfield)) cycle - if (.not. aliased(vfield) .and. & - have_option(trim(vfield%option_path)//'/prognostic')) then - call zero(vfield) - call initialise_field_over_regions(vfield, & - trim(vfield%option_path)//'/prognostic/initial_condition', & - position, phase_path=trim(phase_path)) - end if - end do - - end do + if(trim(vfield%name)=="Velocity") then - if (.not. present_and_true(save_vtk_cache)) then - ! flush the cache - call vtk_cache_finalise() - end if + if(iterations>1 .or. prescribed) then - end subroutine initialise_prognostic_fields + call allocate(aux_vfield, vfield%dim, vfield%mesh, "Nonlinear"//trim(vfield%name)) + call zero(aux_vfield) + call insert(states(p), aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - subroutine allocate_and_insert_auxilliary_fields(states) - ! Set up some auxilliary fields to the prognostic fields. - ! i.e. old and iterated fields depending on options set - type(state_type), dimension(:), intent(inout):: states + else - type(scalar_field), pointer :: sfield - type(vector_field), pointer :: vfield + aux_vfield = extract_vector_field(states(p), trim(vfield%name)) + aux_vfield%name = "Nonlinear"//trim(vfield%name) + aux_vfield%option_path="" + aux_vfield%aliased = .true. + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - type(scalar_field) :: aux_sfield - type(vector_field) :: aux_vfield + end if - integer :: iterations - logical :: steady_state_global, prognostic, prescribed, diagnostic, gravity + if(prognostic) then + gravity = have_option("/physical_parameters/gravity") + if(gravity) then + sfield => extract_scalar_field(states(p), "Density", stat) + if(stat==0) then + call allocate(aux_sfield, sfield%mesh, "VelocityBuoyancyDensity") + else + call allocate(aux_sfield, vfield%mesh, "VelocityBuoyancyDensity") + end if + call zero(aux_sfield) + aux_sfield%option_path="" + call insert(states(p), aux_sfield, trim(aux_sfield%name)) + call deallocate(aux_sfield) + end if + end if - character(len=FIELD_NAME_LEN) :: field_name - character(len=OPTION_PATH_LEN) :: state_path, field_path + end if - integer :: nsfields, nvfields, p, f, p2, stat - real :: current_time + if(trim(vfield%name)=="VelocityInnerElement") then - type(mesh_type), pointer :: x_mesh + if(iterations>1) then - ewrite(1,*) "In allocate_and_insert_auxilliary_fields" + call allocate(aux_vfield, vfield%dim, vfield%mesh, "Nonlinear"//trim(vfield%name)) + call zero(aux_vfield) + call insert(states(p), aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - call get_option("/timestepping/nonlinear_iterations", iterations, default=1) - steady_state_global = have_option("/timestepping/steady_state") + else - ! old and iterated fields - do p = 1, size(states) + aux_vfield = extract_vector_field(states(p), trim(vfield%name)) + aux_vfield%name = "Nonlinear"//trim(vfield%name) + aux_vfield%option_path="" + aux_vfield%aliased = .true. + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - ! Get number of scalar fields that are children of this state - nsfields=scalar_field_count(states(p)) + end if - ! Loop over scalar fields - sfields_loop: do f=1, nsfields + end if - sfield => extract_scalar_field(states(p), f) + end if - ! Save path to field - field_path=trim(sfield%option_path) + end do - ! Get field name - this checks if the field has an option_path - call get_option(trim(field_path)//"/name", field_name, stat) + end do - if((stat==0).and.(.not.aliased(sfield))) then + ! old and iterated fields - aliased + do p = 1, size(states) ! now the aliased fields - prognostic=have_option(trim(sfield%option_path)//"/prognostic") - prescribed=have_option(trim(sfield%option_path)//"/prescribed") - diagnostic=have_option(trim(sfield%option_path)//"/diagnostic") + ! Get number of scalar fields that are children of this state + nsfields=scalar_field_count(states(p)) - ! if (prognostic or diagnostic) and (doing a steady state check on this field or doing more than 1 global iteration) - if((prognostic.or.diagnostic)& - .and.((steady_state_global.and.steady_state_field(sfield)).or.(iterations>1) .or. & - have_option(trim(sfield%option_path) // '/prognostic/spatial_discretisation/discontinuous_galerkin/slope_limiter::FPN') )) then + ! Loop over scalar fields + do f=1, nsfields - call allocate(aux_sfield, sfield%mesh, "Old"//trim(sfield%name)) - call zero(aux_sfield) - call insert(states(p), aux_sfield, trim(aux_sfield%name)) - call deallocate(aux_sfield) + sfield => extract_scalar_field(states(p), f) - else + ! Save path to field + field_path=trim(sfield%option_path) - aux_sfield = extract_scalar_field(states(p), trim(sfield%name)) - aux_sfield%name = "Old"//trim(sfield%name) - aux_sfield%option_path="" ! blank the option path so that it - ! doesn't get picked up in the next - ! aliased field loop - aux_sfield%aliased=.true. - call insert(states(p), aux_sfield, trim(aux_sfield%name)) + ! Get field name - this checks if the field has an option_path + ! but if it's aliased the name that it gets from the option path will be of the field it's aliased to! + call get_option(trim(field_path)//"/name", field_name, stat) - end if + if((stat==0).and.aliased(sfield).and.(sfield%option_path(:15)=="/material_phase")) then - if((prognostic.or.diagnostic)& - .and.((convergence_field(sfield).and.(iterations>1)))) then + prognostic=have_option(trim(sfield%option_path)//"/prognostic") + prescribed=have_option(trim(sfield%option_path)//"/prescribed") + diagnostic=have_option(trim(sfield%option_path)//"/diagnostic") - call allocate(aux_sfield, sfield%mesh, "Iterated"//trim(sfield%name)) - call zero(aux_sfield) - call insert(states(p), aux_sfield, trim(aux_sfield%name)) - call deallocate(aux_sfield) + if(prognostic.or.prescribed.or.diagnostic) then - else + do p2 = 1, size(states) + write(state_path, '(a,i0,a)') "/material_phase[",p2-1,"]" + if(starts_with(trim(field_path), trim(state_path))) exit + end do - aux_sfield = extract_scalar_field(states(p), trim(sfield%name)) - aux_sfield%name = "Iterated"//trim(sfield%name) - aux_sfield%option_path="" ! blank the option path so that it - ! doesn't get picked up in the next - ! aliased field loop - aux_sfield%aliased=.true. - call insert(states(p), aux_sfield, trim(aux_sfield%name)) + if(p2==size(states)+1) then + FLAbort("scalar_field aliased but could not find to which material_phase") + end if - end if + aux_sfield=extract_scalar_field(states(p2), "Old"//trim(field_name)) + aux_sfield%name = "Old"//trim(sfield%name) + aux_sfield%aliased = .true. + aux_sfield%option_path = "" ! blank the option path for consistency + call insert(states(p), aux_sfield, trim(aux_sfield%name)) - end if + aux_sfield=extract_scalar_field(states(p2), "Iterated"//trim(field_name)) + aux_sfield%name = "Iterated"//trim(sfield%name) + aux_sfield%aliased = .true. + aux_sfield%option_path = "" ! blank the option path for consistency + call insert(states(p), aux_sfield, trim(aux_sfield%name)) - end do sfields_loop + end if - ! Get number of vector fields that are children of this state - nvfields=vector_field_count(states(p)) + end if - ! Loop over vector fields - do f=1, nvfields + end do - vfield => extract_vector_field(states(p), f) + ! Get number of vector fields that are children of this state + nvfields=vector_field_count(states(p)) - ! Save path to field - field_path=trim(vfield%option_path) + ! Loop over vector fields + do f=1, nvfields - ! Get field name - this checks if the field has an option_path - call get_option(trim(field_path)//"/name", field_name, stat) + vfield => extract_vector_field(states(p), f) - if((stat==0).and.(.not.aliased(vfield))) then + ! Save path to field + field_path=trim(vfield%option_path) - prognostic=have_option(trim(vfield%option_path)//"/prognostic") - prescribed=have_option(trim(vfield%option_path)//"/prescribed") - diagnostic=have_option(trim(vfield%option_path)//"/diagnostic") + ! Get field name - this checks if the field has an option_path + ! but if it's aliased the name that it gets from the option path will be of the field it's aliased to! + call get_option(trim(field_path)//"/name", field_name, stat) - if((prognostic.or.diagnostic)& - .and.((steady_state_global.and.steady_state_field(vfield)).or.(iterations>1))) then + if((stat==0).and.aliased(vfield).and.(vfield%option_path(:15)=="/material_phase")) then - call allocate(aux_vfield, vfield%dim, vfield%mesh, "Old"//trim(vfield%name)) - call zero(aux_vfield) - call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) + prognostic=have_option(trim(vfield%option_path)//"/prognostic") + prescribed=have_option(trim(vfield%option_path)//"/prescribed") + diagnostic=have_option(trim(vfield%option_path)//"/diagnostic") - else if((prescribed).and.(trim(vfield%name)=="Velocity")) then + do p2 = 1, size(states) + write(state_path, '(a,i0,a)') "/material_phase[",p2-1,"]" + if(starts_with(trim(field_path), trim(state_path))) exit + end do - call allocate(aux_vfield, vfield%dim, vfield%mesh, "Old"//trim(vfield%name), field_type = vfield%field_type) - call zero(aux_vfield) - call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) + if(p2==size(states)+1) then + FLAbort("vector_field aliased but could not find to which material_phase") + end if - else + if(prognostic.or.prescribed.or.diagnostic) then - aux_vfield = extract_vector_field(states(p), trim(vfield%name)) - aux_vfield%name = "Old"//trim(vfield%name) - aux_vfield%option_path="" ! blank the option path so that it - ! doesn't get picked up in the next - ! aliased field loop - aux_vfield%aliased=.true. - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + aux_vfield=extract_vector_field(states(p2), "Old"//trim(field_name)) + aux_vfield%name = "Old"//trim(vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" ! blank the option path for consistency + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - end if + aux_vfield=extract_vector_field(states(p2), "Iterated"//trim(field_name)) + aux_vfield%name = "Iterated"//trim(vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" ! blank the option path for consistency + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - if((prognostic.or.diagnostic)& - .and.(convergence_field(vfield).and.(iterations>1))) then + end if - call allocate(aux_vfield, vfield%dim, vfield%mesh, "Iterated"//trim(vfield%name)) - call zero(aux_vfield) - call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) + if(trim(vfield%name)=="Velocity") then - else if((prescribed).and.((trim(vfield%name)=="Velocity"))) then + aux_vfield=extract_vector_field(states(p2), "Nonlinear"//trim(field_name)) + aux_vfield%name = "Nonlinear"//trim(vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call allocate(aux_vfield, vfield%dim, vfield%mesh, "Iterated"//trim(vfield%name)) - call zero(aux_vfield) - call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) + end if - else + if(trim(vfield%name)=="VelocityInnerElement") then - aux_vfield = extract_vector_field(states(p), trim(vfield%name)) - aux_vfield%name = "Iterated"//trim(vfield%name) - aux_vfield%option_path="" ! blank the option path so that it - ! doesn't get picked up in the next - ! aliased field loop - aux_vfield%aliased=.true. - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + aux_vfield=extract_vector_field(states(p2), "Nonlinear"//trim(field_name)) + aux_vfield%name = "Nonlinear"//trim(vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" + call insert(states(p), aux_vfield, trim(aux_vfield%name)) - end if + end if - if(trim(vfield%name)=="Velocity") then + end if - if(iterations>1 .or. prescribed) then + end do - call allocate(aux_vfield, vfield%dim, vfield%mesh, "Nonlinear"//trim(vfield%name)) - call zero(aux_vfield) - call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) + end do - else - aux_vfield = extract_vector_field(states(p), trim(vfield%name)) - aux_vfield%name = "Nonlinear"//trim(vfield%name) - aux_vfield%option_path="" - aux_vfield%aliased = .true. - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + ! for mesh movement we need a "OriginalCoordinate", + ! "OldCoordinate" and "IteratedCoordinate" fields + ! inserted in each state similar to "Coordinate" + if (have_option('/mesh_adaptivity/mesh_movement')) then + vfield => extract_vector_field(states(1), name="Coordinate") + + ! first original coordinate field: + call allocate(aux_vfield, vfield%dim, vfield%mesh, & + name="Original"//trim(vfield%name)) + call set(aux_vfield, vfield) + aux_vfield%option_path="" + ! insert into states(1) and alias it to all other states. + call insert(states, aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) + + ! exactly the same for old coordinate field: + call allocate(aux_vfield, vfield%dim, vfield%mesh, & + name="Old"//trim(vfield%name)) + call set(aux_vfield, vfield) + aux_vfield%option_path="" + ! insert into states(1) and alias it to all other states. + call insert(states, aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) + + ! and again for the iterated coordinate field (the most up to date one): + call allocate(aux_vfield, vfield%dim, vfield%mesh, & + name="Iterated"//trim(vfield%name)) + call set(aux_vfield, vfield) + aux_vfield%option_path="" + ! insert into states(1) and alias it to all other states. + call insert(states, aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) - end if + else - if(prognostic) then - gravity = have_option("/physical_parameters/gravity") - if(gravity) then - sfield => extract_scalar_field(states(p), "Density", stat) - if(stat==0) then - call allocate(aux_sfield, sfield%mesh, "VelocityBuoyancyDensity") - else - call allocate(aux_sfield, vfield%mesh, "VelocityBuoyancyDensity") - end if - call zero(aux_sfield) - aux_sfield%option_path="" - call insert(states(p), aux_sfield, trim(aux_sfield%name)) - call deallocate(aux_sfield) - end if - end if + aux_vfield=extract_vector_field(states(1), name="Coordinate") + aux_vfield%name = "Original"//trim(aux_vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" + ! insert into states(1) and alias it to all other states. + call insert(states, aux_vfield, trim(aux_vfield%name)) + + aux_vfield=extract_vector_field(states(1), name="Coordinate") + aux_vfield%name = "Old"//trim(aux_vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" + ! insert into states(1) and alias it to all other states. + call insert(states, aux_vfield, trim(aux_vfield%name)) + + aux_vfield=extract_vector_field(states(1), name="Coordinate") + aux_vfield%name = "Iterated"//trim(aux_vfield%name) + aux_vfield%aliased = .true. + aux_vfield%option_path = "" + ! insert into states(1) and alias it to all other states. + call insert(states, aux_vfield, trim(aux_vfield%name)) - end if + end if - if(trim(vfield%name)=="VelocityInnerElement") then + x_mesh => extract_mesh(states(1), "CoordinateMesh") + ! need a GridVelocity even if we're not moving the mesh + if (.not.have_option('/mesh_adaptivity/mesh_movement')) then + call allocate(aux_vfield, mesh_dim(x_mesh), x_mesh, "GridVelocity", field_type = FIELD_TYPE_CONSTANT) + call zero(aux_vfield) + aux_vfield%option_path = "" + call insert(states, aux_vfield, trim(aux_vfield%name)) + call deallocate(aux_vfield) + end if - if(iterations>1) then + ! Disgusting and vomitous hack to ensure that time is output in + ! vtu files. + call allocate(aux_sfield, x_mesh, "Time", field_type=FIELD_TYPE_CONSTANT) + call get_option("/timestepping/current_time", current_time) + call set(aux_sfield, current_time) + aux_sfield%option_path = "" + call insert(states, aux_sfield, trim(aux_sfield%name)) + call deallocate(aux_sfield) - call allocate(aux_vfield, vfield%dim, vfield%mesh, "Nonlinear"//trim(vfield%name)) - call zero(aux_vfield) - call insert(states(p), aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) + end subroutine allocate_and_insert_auxilliary_fields - else + function mesh_name(field_path) + !!< given a field path, establish the mesh that the field is on. + character(len=FIELD_NAME_LEN) :: mesh_name + character(len=*), intent(in) :: field_path - aux_vfield = extract_vector_field(states(p), trim(vfield%name)) - aux_vfield%name = "Nonlinear"//trim(vfield%name) - aux_vfield%option_path="" - aux_vfield%aliased = .true. - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + integer :: stat + call get_option(trim(field_path)//'/prognostic/mesh[0]/name', & + mesh_name, stat=stat) + if (stat/=0) then + call get_option(trim(field_path)//'/diagnostic/mesh[0]/name', & + mesh_name, stat=stat) + if (stat/=0) then + call get_option(trim(field_path)//'/prescribed/mesh[0]/name', & + mesh_name, stat=stat) + if (stat/=0) then + FLExit("No mesh for field "//trim(field_path)) end if + end if + end if - end if + end function mesh_name - end if + subroutine surface_id_stats(mesh, positions) + type(mesh_type), target, intent(in):: mesh + type(vector_field), intent(in):: positions - end do + real, dimension(1:face_ngi(mesh,1)):: detwei + integer, dimension(:), pointer:: surface_ids + real, dimension(:), allocatable:: area + integer, dimension(:), allocatable:: no_elements + integer i, sid, sidmin, sidmax - end do + if (current_debug_level<=1) return - ! old and iterated fields - aliased - do p = 1, size(states) ! now the aliased fields + ewrite(2,*) "Surface id stats for mesh ", trim(mesh%name) - ! Get number of scalar fields that are children of this state - nsfields=scalar_field_count(states(p)) + surface_ids => mesh%faces%boundary_ids + sidmin=minval(surface_ids) + sidmax=maxval(surface_ids) - ! Loop over scalar fields - do f=1, nsfields + allocate( no_elements(sidmin:sidmax), & + area(sidmin:sidmax)) + no_elements=0 + area=0.0 - sfield => extract_scalar_field(states(p), f) + do i=1, surface_element_count(mesh) + sid=surface_ids(i) + no_elements(sid)=no_elements(sid)+1 + call transform_facet_to_physical(positions, i, detwei_f=detwei) + area(sid)=area(sid)+sum(detwei) + end do - ! Save path to field - field_path=trim(sfield%option_path) + ewrite(2, *) 'Surface id, n/o surface elements, surface area' + do i=sidmin, sidmax + ewrite(2, "(i10,i23,es20.9)") i, no_elements(i), area(i) + end do - ! Get field name - this checks if the field has an option_path - ! but if it's aliased the name that it gets from the option path will be of the field it's aliased to! - call get_option(trim(field_path)//"/name", field_name, stat) + ewrite(2,*) 'Total number of surface elements:', surface_element_count(mesh) + ewrite(2,'(a,es20.9)') 'Total surface area:', sum(area) + + end subroutine surface_id_stats + + subroutine create_empty_halo(position) + !!< Auxilary subroutine that creates node and element halos for position with no sends or receives + type(vector_field), intent(inout):: position + + integer:: nprocs, j + + nprocs = getnprocs() + allocate(position%mesh%halos(2)) + allocate(position%mesh%element_halos(2)) + do j=1,2 + ! Nodal halo + call allocate(position%mesh%halos(j), nprocs = nprocs, nreceives = spread(0, 1, nprocs), & + nsends = spread(0, 1, nprocs), & + data_type=HALO_TYPE_CG_NODE, ordering_scheme=HALO_ORDER_TRAILING_RECEIVES, & + nowned_nodes = node_count(position),& + name="EmptyHalo") + assert(trailing_receives_consistent(position%mesh%halos(j))) + call create_global_to_universal_numbering(position%mesh%halos(j)) + call create_ownership(position%mesh%halos(j)) + + ! Element halo + call allocate(position%mesh%element_halos(j), nprocs = nprocs, nreceives = spread(0, 1, nprocs), & + nsends = spread(0, 1, nprocs), & + data_type=HALO_TYPE_ELEMENT, ordering_scheme=HALO_ORDER_TRAILING_RECEIVES, & + nowned_nodes = ele_count(position), & + name="EmptyHalo") + assert(trailing_receives_consistent(position%mesh%element_halos(j))) + call create_global_to_universal_numbering(position%mesh%element_halos(j)) + call create_ownership(position%mesh%element_halos(j)) + end do - if((stat==0).and.aliased(sfield).and.(sfield%option_path(:15)=="/material_phase")) then + end subroutine create_empty_halo - prognostic=have_option(trim(sfield%option_path)//"/prognostic") - prescribed=have_option(trim(sfield%option_path)//"/prescribed") - diagnostic=have_option(trim(sfield%option_path)//"/diagnostic") - if(prognostic.or.prescribed.or.diagnostic) then + subroutine allocate_metric_limits(state) + type(state_type), intent(inout) :: state + type(tensor_field) :: min_edge, max_edge + type(tensor_field) :: min_eigen, max_eigen + character(len=*), parameter :: path = & + & "/mesh_adaptivity/hr_adaptivity/" + logical :: is_constant + type(mesh_type), pointer :: mesh + type(vector_field), pointer :: X + integer :: node + + if (.not. have_option(path)) then + return + end if - do p2 = 1, size(states) - write(state_path, '(a,i0,a)') "/material_phase[",p2-1,"]" - if(starts_with(trim(field_path), trim(state_path))) exit - end do + X => extract_vector_field(state, "Coordinate") + ! We can't use the external mesh in the extruded case -- these have to go on the + ! CoordinateMesh. + !mesh => get_external_mesh((/state/)) + mesh => extract_mesh(state, trim(topology_mesh_name)) - if(p2==size(states)+1) then - FLAbort("scalar_field aliased but could not find to which material_phase") - end if + if (.not. have_option(path // "/tensor_field::MinimumEdgeLengths")) then + ewrite(-1,*) "Warning: adaptivity turned on, but no edge length limits available?" + return + end if - aux_sfield=extract_scalar_field(states(p2), "Old"//trim(field_name)) - aux_sfield%name = "Old"//trim(sfield%name) - aux_sfield%aliased = .true. - aux_sfield%option_path = "" ! blank the option path for consistency - call insert(states(p), aux_sfield, trim(aux_sfield%name)) + is_constant = (have_option(path // "/tensor_field::MinimumEdgeLengths/anisotropic_symmetric/constant")) + if (is_constant) then + call allocate(min_edge, mesh, "MinimumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) + call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", X) + call allocate(max_eigen, mesh, "MaxMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) + call set(max_eigen, eigenvalue_from_edge_length(node_val(min_edge, 1))) + else + call allocate(min_edge, mesh, "MinimumEdgeLengths") + call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", X) + call allocate(max_eigen, mesh, "MaxMetricEigenbound") + do node=1,node_count(mesh) + call set(max_eigen, node, eigenvalue_from_edge_length(node_val(min_edge, node))) + end do + end if - aux_sfield=extract_scalar_field(states(p2), "Iterated"//trim(field_name)) - aux_sfield%name = "Iterated"//trim(sfield%name) - aux_sfield%aliased = .true. - aux_sfield%option_path = "" ! blank the option path for consistency - call insert(states(p), aux_sfield, trim(aux_sfield%name)) + call insert(state, max_eigen, "MaxMetricEigenbound") + call deallocate(min_edge) + call deallocate(max_eigen) - end if + is_constant = (have_option(path // "/tensor_field::MaximumEdgeLengths/anisotropic_symmetric/constant")) + if (is_constant) then + call allocate(max_edge, mesh, "MaximumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) + call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", X) + call allocate(min_eigen, mesh, "MinMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) + call set(min_eigen, eigenvalue_from_edge_length(node_val(max_edge, 1))) + else + call allocate(max_edge, mesh, "MaximumEdgeLengths") + call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", X) + call allocate(min_eigen, mesh, "MinMetricEigenbound") + do node=1,node_count(mesh) + call set(min_eigen, node, eigenvalue_from_edge_length(node_val(max_edge, node))) + end do + end if - end if + call insert(state, min_eigen, "MinMetricEigenbound") + call deallocate(max_edge) + call deallocate(min_eigen) + + end subroutine allocate_metric_limits + + function get_quad_family() result(quad_family) + character(len=OPTION_PATH_LEN) :: quad_family_str + integer :: quad_family + + if (have_option("/geometry/quadrature/quadrature_family")) then + call get_option("/geometry/quadrature/quadrature_family", quad_family_str) + select case (quad_family_str) + case("family_cools") + quad_family = FAMILY_COOLS + case("family_grundmann_moeller") + quad_family = FAMILY_GM + case ("family_wandzura") + quad_family = FAMILY_WANDZURA + end select + else + quad_family = FAMILY_COOLS + end if + end function get_quad_family + + subroutine compute_domain_statistics(states) + type(state_type), dimension(:), intent(in) :: states + integer :: dim + type(vector_field), pointer :: positions + integer :: ele + real :: vol + type(scalar_field) :: temp_s_field + + positions => extract_vector_field(states(1), "Coordinate") + if (allocated(domain_bbox)) then + deallocate(domain_bbox) + end if + allocate(domain_bbox(positions%dim, 2)) + domain_bbox = 0.0 + do dim=1,positions%dim + domain_bbox(dim, 1) = minval(positions%val(dim,:)) + domain_bbox(dim, 2) = maxval(positions%val(dim,:)) + ewrite(2,*) "domain_bbox - dim, range =", dim, domain_bbox(dim,:) end do - ! Get number of vector fields that are children of this state - nvfields=vector_field_count(states(p)) - - ! Loop over vector fields - do f=1, nvfields - - vfield => extract_vector_field(states(p), f) + vol = 0.0 + do ele=1,ele_count(positions) + vol = vol + element_volume(positions, ele) + end do - ! Save path to field - field_path=trim(vfield%option_path) + domain_volume = vol + ewrite(2,*) "domain_volume =", domain_volume - ! Get field name - this checks if the field has an option_path - ! but if it's aliased the name that it gets from the option path will be of the field it's aliased to! - call get_option(trim(field_path)//"/name", field_name, stat) + !If on-the-sphere, calculate the radius of the sphere. + if (have_option("/geometry/spherical_earth/")) then + temp_s_field = magnitude(positions) + surface_radius = maxval(temp_s_field) + call allmax(surface_radius) + ! Need to deallocate the magnitude field create, or we get a leak + call deallocate(temp_s_field) + end if - if((stat==0).and.aliased(vfield).and.(vfield%option_path(:15)=="/material_phase")) then - prognostic=have_option(trim(vfield%option_path)//"/prognostic") - prescribed=have_option(trim(vfield%option_path)//"/prescribed") - diagnostic=have_option(trim(vfield%option_path)//"/diagnostic") + end subroutine compute_domain_statistics + + subroutine populate_state_module_check_options + + character(len=OPTION_PATH_LEN) :: problem_type + + ! Check mesh options + call check_mesh_options + + call check_geometry_options + + ! check problem specific options: + call get_option("/problem_type", problem_type) + select case (problem_type) + case ("fluids") + case ("oceans") + call check_ocean_options + case ("large_scale_ocean_options") + call check_large_scale_ocean_options + case ("multimaterial") + call check_multimaterial_options + case ("stokes") + call check_stokes_options + case ("foams") + call check_foams_options + case ("multiphase") + call check_multiphase_options + case default + ewrite(0,*) "Problem type:", trim(problem_type) + FLAbort("Error unknown problem_type") + end select + ewrite(2,*) 'Done with problem type choice' - do p2 = 1, size(states) - write(state_path, '(a,i0,a)') "/material_phase[",p2-1,"]" - if(starts_with(trim(field_path), trim(state_path))) exit - end do + end subroutine populate_state_module_check_options - if(p2==size(states)+1) then - FLAbort("vector_field aliased but could not find to which material_phase") - end if + subroutine check_geometry_options - if(prognostic.or.prescribed.or.diagnostic) then + logical :: on_sphere + integer :: i, nstates - aux_vfield=extract_vector_field(states(p2), "Old"//trim(field_name)) - aux_vfield%name = "Old"//trim(vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" ! blank the option path for consistency - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + on_sphere = have_option("/geometry/spherical_earth") - aux_vfield=extract_vector_field(states(p2), "Iterated"//trim(field_name)) - aux_vfield%name = "Iterated"//trim(vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" ! blank the option path for consistency - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + if (on_sphere) then + nstates=option_count("/material_phase") - end if + state_loop: do i=0, nstates-1 + if (have_option("/material_phase[" // int2str(i) // "]/vector_field::Velocity/prognostic")) then + if (.not. (have_option("/material_phase[" // int2str(i) // "]/vector_field::Velocity/prognostic" // & + "/spatial_discretisation/continuous_galerkin/buoyancy" // & + "/radial_gravity_direction_at_gauss_points") .or. & + have_option("/material_phase[" // int2str(i) // "]/vector_field::Velocity/prognostic" // & + "/spatial_discretisation/discontinuous_galerkin/buoyancy" // & + "/radial_gravity_direction_at_gauss_points"))) then + ewrite(0,*) "WARNING: the /geometry/spherical_earth option no long automatically makes the buoyancy radial." + ewrite(0,*) "To recreate the previous behaviour it is now necessary to turn on the " + ewrite(0,*) "buoyancy/radial_gravity_direction_at_gauss_points underneath the Velocity spatial_discretisation." + end if + end if + end do state_loop + end if - if(trim(vfield%name)=="Velocity") then + end subroutine check_geometry_options - aux_vfield=extract_vector_field(states(p2), "Nonlinear"//trim(field_name)) - aux_vfield%name = "Nonlinear"//trim(vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + subroutine check_mesh_options - end if + character(len=OPTION_PATH_LEN) :: path + character(len=OPTION_PATH_LEN) :: field_name, mesh_name, from_mesh_name, phase_name + integer :: i, j ! counters + integer :: nstates ! number of states + integer :: nfields ! number of fields + integer :: nmeshes ! number of meshes + integer :: n_external_meshes ! number of meshes from file + integer :: n_external_meshes_excluded_from_mesh_adaptivity + integer :: periodic_mesh_count ! number of meshes with periodic_boundary_conition options + ! logicals to find out if we have certain options + logical :: is_aliased - if(trim(vfield%name)=="VelocityInnerElement") then + ! Get number of meshes + nmeshes=option_count("/geometry/mesh") - aux_vfield=extract_vector_field(states(p2), "Nonlinear"//trim(field_name)) - aux_vfield%name = "Nonlinear"//trim(vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" - call insert(states(p), aux_vfield, trim(aux_vfield%name)) + ewrite(2,*) "Checking mesh options." + ewrite(2,*) "There are", nmeshes, "meshes." - end if + n_external_meshes=0 + n_external_meshes_excluded_from_mesh_adaptivity=0 - end if + mesh_loop1: do i=0, nmeshes-1 - end do + ! Save mesh path + path="/geometry/mesh["//int2str(i)//"]" - end do - - - ! for mesh movement we need a "OriginalCoordinate", - ! "OldCoordinate" and "IteratedCoordinate" fields - ! inserted in each state similar to "Coordinate" - if (have_option('/mesh_adaptivity/mesh_movement')) then - vfield => extract_vector_field(states(1), name="Coordinate") - - ! first original coordinate field: - call allocate(aux_vfield, vfield%dim, vfield%mesh, & - name="Original"//trim(vfield%name)) - call set(aux_vfield, vfield) - aux_vfield%option_path="" - ! insert into states(1) and alias it to all other states. - call insert(states, aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) - - ! exactly the same for old coordinate field: - call allocate(aux_vfield, vfield%dim, vfield%mesh, & - name="Old"//trim(vfield%name)) - call set(aux_vfield, vfield) - aux_vfield%option_path="" - ! insert into states(1) and alias it to all other states. - call insert(states, aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) - - ! and again for the iterated coordinate field (the most up to date one): - call allocate(aux_vfield, vfield%dim, vfield%mesh, & - name="Iterated"//trim(vfield%name)) - call set(aux_vfield, vfield) - aux_vfield%option_path="" - ! insert into states(1) and alias it to all other states. - call insert(states, aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) - - else - - aux_vfield=extract_vector_field(states(1), name="Coordinate") - aux_vfield%name = "Original"//trim(aux_vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" - ! insert into states(1) and alias it to all other states. - call insert(states, aux_vfield, trim(aux_vfield%name)) - - aux_vfield=extract_vector_field(states(1), name="Coordinate") - aux_vfield%name = "Old"//trim(aux_vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" - ! insert into states(1) and alias it to all other states. - call insert(states, aux_vfield, trim(aux_vfield%name)) - - aux_vfield=extract_vector_field(states(1), name="Coordinate") - aux_vfield%name = "Iterated"//trim(aux_vfield%name) - aux_vfield%aliased = .true. - aux_vfield%option_path = "" - ! insert into states(1) and alias it to all other states. - call insert(states, aux_vfield, trim(aux_vfield%name)) - - end if - - x_mesh => extract_mesh(states(1), "CoordinateMesh") - ! need a GridVelocity even if we're not moving the mesh - if (.not.have_option('/mesh_adaptivity/mesh_movement')) then - call allocate(aux_vfield, mesh_dim(x_mesh), x_mesh, "GridVelocity", field_type = FIELD_TYPE_CONSTANT) - call zero(aux_vfield) - aux_vfield%option_path = "" - call insert(states, aux_vfield, trim(aux_vfield%name)) - call deallocate(aux_vfield) - end if - - ! Disgusting and vomitous hack to ensure that time is output in - ! vtu files. - call allocate(aux_sfield, x_mesh, "Time", field_type=FIELD_TYPE_CONSTANT) - call get_option("/timestepping/current_time", current_time) - call set(aux_sfield, current_time) - aux_sfield%option_path = "" - call insert(states, aux_sfield, trim(aux_sfield%name)) - call deallocate(aux_sfield) - - end subroutine allocate_and_insert_auxilliary_fields - - function mesh_name(field_path) - !!< given a field path, establish the mesh that the field is on. - character(len=FIELD_NAME_LEN) :: mesh_name - character(len=*), intent(in) :: field_path - - integer :: stat - - call get_option(trim(field_path)//'/prognostic/mesh[0]/name', & - mesh_name, stat=stat) - if (stat/=0) then - call get_option(trim(field_path)//'/diagnostic/mesh[0]/name', & - mesh_name, stat=stat) - if (stat/=0) then - call get_option(trim(field_path)//'/prescribed/mesh[0]/name', & - mesh_name, stat=stat) - if (stat/=0) then - FLExit("No mesh for field "//trim(field_path)) - end if - end if - end if - - end function mesh_name - - subroutine surface_id_stats(mesh, positions) - type(mesh_type), target, intent(in):: mesh - type(vector_field), intent(in):: positions - - real, dimension(1:face_ngi(mesh,1)):: detwei - integer, dimension(:), pointer:: surface_ids - real, dimension(:), allocatable:: area - integer, dimension(:), allocatable:: no_elements - integer i, sid, sidmin, sidmax - - if (current_debug_level<=1) return - - ewrite(2,*) "Surface id stats for mesh ", trim(mesh%name) - - surface_ids => mesh%faces%boundary_ids - sidmin=minval(surface_ids) - sidmax=maxval(surface_ids) - - allocate( no_elements(sidmin:sidmax), & - area(sidmin:sidmax)) - no_elements=0 - area=0.0 - - do i=1, surface_element_count(mesh) - sid=surface_ids(i) - no_elements(sid)=no_elements(sid)+1 - call transform_facet_to_physical(positions, i, detwei_f=detwei) - area(sid)=area(sid)+sum(detwei) - end do - - ewrite(2, *) 'Surface id, n/o surface elements, surface area' - do i=sidmin, sidmax - ewrite(2, "(i10,i23,es20.9)") i, no_elements(i), area(i) - end do - - ewrite(2,*) 'Total number of surface elements:', surface_element_count(mesh) - ewrite(2,'(a,es20.9)') 'Total surface area:', sum(area) - - end subroutine surface_id_stats - - subroutine create_empty_halo(position) - !!< Auxilary subroutine that creates node and element halos for position with no sends or receives - type(vector_field), intent(inout):: position - - integer:: nprocs, j - - nprocs = getnprocs() - allocate(position%mesh%halos(2)) - allocate(position%mesh%element_halos(2)) - do j=1,2 - ! Nodal halo - call allocate(position%mesh%halos(j), nprocs = nprocs, nreceives = spread(0, 1, nprocs), & - nsends = spread(0, 1, nprocs), & - data_type=HALO_TYPE_CG_NODE, ordering_scheme=HALO_ORDER_TRAILING_RECEIVES, & - nowned_nodes = node_count(position),& - name="EmptyHalo") - assert(trailing_receives_consistent(position%mesh%halos(j))) - call create_global_to_universal_numbering(position%mesh%halos(j)) - call create_ownership(position%mesh%halos(j)) - - ! Element halo - call allocate(position%mesh%element_halos(j), nprocs = nprocs, nreceives = spread(0, 1, nprocs), & - nsends = spread(0, 1, nprocs), & - data_type=HALO_TYPE_ELEMENT, ordering_scheme=HALO_ORDER_TRAILING_RECEIVES, & - nowned_nodes = ele_count(position), & - name="EmptyHalo") - assert(trailing_receives_consistent(position%mesh%element_halos(j))) - call create_global_to_universal_numbering(position%mesh%element_halos(j)) - call create_ownership(position%mesh%element_halos(j)) - end do - - end subroutine create_empty_halo - - - subroutine allocate_metric_limits(state) - type(state_type), intent(inout) :: state - type(tensor_field) :: min_edge, max_edge - type(tensor_field) :: min_eigen, max_eigen - character(len=*), parameter :: path = & - & "/mesh_adaptivity/hr_adaptivity/" - logical :: is_constant - type(mesh_type), pointer :: mesh - type(vector_field), pointer :: X - integer :: node - - if (.not. have_option(path)) then - return - end if - - X => extract_vector_field(state, "Coordinate") - ! We can't use the external mesh in the extruded case -- these have to go on the - ! CoordinateMesh. - !mesh => get_external_mesh((/state/)) - mesh => extract_mesh(state, trim(topology_mesh_name)) - - if (.not. have_option(path // "/tensor_field::MinimumEdgeLengths")) then - ewrite(-1,*) "Warning: adaptivity turned on, but no edge length limits available?" - return - end if - - is_constant = (have_option(path // "/tensor_field::MinimumEdgeLengths/anisotropic_symmetric/constant")) - if (is_constant) then - call allocate(min_edge, mesh, "MinimumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) - call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", X) - call allocate(max_eigen, mesh, "MaxMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) - call set(max_eigen, eigenvalue_from_edge_length(node_val(min_edge, 1))) - else - call allocate(min_edge, mesh, "MinimumEdgeLengths") - call initialise_field(min_edge, path // "/tensor_field::MinimumEdgeLengths", X) - call allocate(max_eigen, mesh, "MaxMetricEigenbound") - do node=1,node_count(mesh) - call set(max_eigen, node, eigenvalue_from_edge_length(node_val(min_edge, node))) - end do - end if - - call insert(state, max_eigen, "MaxMetricEigenbound") - call deallocate(min_edge) - call deallocate(max_eigen) - - is_constant = (have_option(path // "/tensor_field::MaximumEdgeLengths/anisotropic_symmetric/constant")) - if (is_constant) then - call allocate(max_edge, mesh, "MaximumEdgeLengths", field_type=FIELD_TYPE_CONSTANT) - call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", X) - call allocate(min_eigen, mesh, "MinMetricEigenbound", field_type=FIELD_TYPE_CONSTANT) - call set(min_eigen, eigenvalue_from_edge_length(node_val(max_edge, 1))) - else - call allocate(max_edge, mesh, "MaximumEdgeLengths") - call initialise_field(max_edge, path // "/tensor_field::MaximumEdgeLengths", X) - call allocate(min_eigen, mesh, "MinMetricEigenbound") - do node=1,node_count(mesh) - call set(min_eigen, node, eigenvalue_from_edge_length(node_val(max_edge, node))) - end do - end if - - call insert(state, min_eigen, "MinMetricEigenbound") - call deallocate(max_edge) - call deallocate(min_eigen) - - end subroutine allocate_metric_limits - - function get_quad_family() result(quad_family) - character(len=OPTION_PATH_LEN) :: quad_family_str - integer :: quad_family - - if (have_option("/geometry/quadrature/quadrature_family")) then - call get_option("/geometry/quadrature/quadrature_family", quad_family_str) - select case (quad_family_str) - case("family_cools") - quad_family = FAMILY_COOLS - case("family_grundmann_moeller") - quad_family = FAMILY_GM - case ("family_wandzura") - quad_family = FAMILY_WANDZURA - end select - else - quad_family = FAMILY_COOLS - end if - end function get_quad_family - - subroutine compute_domain_statistics(states) - type(state_type), dimension(:), intent(in) :: states - integer :: dim - type(vector_field), pointer :: positions - integer :: ele - real :: vol - type(scalar_field) :: temp_s_field - - positions => extract_vector_field(states(1), "Coordinate") - if (allocated(domain_bbox)) then - deallocate(domain_bbox) - end if - allocate(domain_bbox(positions%dim, 2)) - domain_bbox = 0.0 - - do dim=1,positions%dim - domain_bbox(dim, 1) = minval(positions%val(dim,:)) - domain_bbox(dim, 2) = maxval(positions%val(dim,:)) - ewrite(2,*) "domain_bbox - dim, range =", dim, domain_bbox(dim,:) - end do - - vol = 0.0 - do ele=1,ele_count(positions) - vol = vol + element_volume(positions, ele) - end do - - domain_volume = vol - ewrite(2,*) "domain_volume =", domain_volume - - !If on-the-sphere, calculate the radius of the sphere. - if (have_option("/geometry/spherical_earth/")) then - temp_s_field = magnitude(positions) - surface_radius = maxval(temp_s_field) - call allmax(surface_radius) - ! Need to deallocate the magnitude field create, or we get a leak - call deallocate(temp_s_field) - end if - - - end subroutine compute_domain_statistics - - subroutine populate_state_module_check_options - - character(len=OPTION_PATH_LEN) :: problem_type - - ! Check mesh options - call check_mesh_options - - call check_geometry_options - - ! check problem specific options: - call get_option("/problem_type", problem_type) - select case (problem_type) - case ("fluids") - case ("oceans") - call check_ocean_options - case ("large_scale_ocean_options") - call check_large_scale_ocean_options - case ("multimaterial") - call check_multimaterial_options - case ("stokes") - call check_stokes_options - case ("foams") - call check_foams_options - case ("multiphase") - call check_multiphase_options - case default - ewrite(0,*) "Problem type:", trim(problem_type) - FLAbort("Error unknown problem_type") - end select - ewrite(2,*) 'Done with problem type choice' - - end subroutine populate_state_module_check_options - - subroutine check_geometry_options - - logical :: on_sphere - integer :: i, nstates - - on_sphere = have_option("/geometry/spherical_earth") - - if (on_sphere) then - nstates=option_count("/material_phase") + if(have_option(trim(path)//"/from_file")) then - state_loop: do i=0, nstates-1 - if (have_option("/material_phase[" // int2str(i) // "]/vector_field::Velocity/prognostic")) then - if (.not. (have_option("/material_phase[" // int2str(i) // "]/vector_field::Velocity/prognostic" // & - "/spatial_discretisation/continuous_galerkin/buoyancy" // & - "/radial_gravity_direction_at_gauss_points") .or. & - have_option("/material_phase[" // int2str(i) // "]/vector_field::Velocity/prognostic" // & - "/spatial_discretisation/discontinuous_galerkin/buoyancy" // & - "/radial_gravity_direction_at_gauss_points"))) then - ewrite(0,*) "WARNING: the /geometry/spherical_earth option no long automatically makes the buoyancy radial." - ewrite(0,*) "To recreate the previous behaviour it is now necessary to turn on the " - ewrite(0,*) "buoyancy/radial_gravity_direction_at_gauss_points underneath the Velocity spatial_discretisation." - end if - end if - end do state_loop - end if + n_external_meshes=n_external_meshes+1 - end subroutine check_geometry_options + if (have_option(trim(path)//"/exclude_from_mesh_adaptivity")) then + n_external_meshes_excluded_from_mesh_adaptivity=n_external_meshes_excluded_from_mesh_adaptivity+1 + end if - subroutine check_mesh_options + else if (.not. have_option(trim(path)//"/from_mesh")) then - character(len=OPTION_PATH_LEN) :: path - character(len=OPTION_PATH_LEN) :: field_name, mesh_name, from_mesh_name, phase_name - integer :: i, j ! counters - integer :: nstates ! number of states - integer :: nfields ! number of fields - integer :: nmeshes ! number of meshes - integer :: n_external_meshes ! number of meshes from file - integer :: n_external_meshes_excluded_from_mesh_adaptivity - integer :: periodic_mesh_count ! number of meshes with periodic_boundary_conition options - ! logicals to find out if we have certain options - logical :: is_aliased + call get_option(trim(path)//"/name", mesh_name) + ewrite(-1,*) "In options for /geometry/mesh ("//trim(mesh_name)//"):" + FLExit("Error: unknown way of specifying mesh source.") - ! Get number of meshes - nmeshes=option_count("/geometry/mesh") + end if - ewrite(2,*) "Checking mesh options." - ewrite(2,*) "There are", nmeshes, "meshes." + end do mesh_loop1 - n_external_meshes=0 - n_external_meshes_excluded_from_mesh_adaptivity=0 + ! Check that at least one mesh is read in from a file. + if(n_external_meshes==0) then + FLExit("At least one mesh must come from a file.") + end if + if(isparallel() .and. n_external_meshes > 1) then + FLExit("Only one mesh may be from_file in parallel.") + end if + if(n_external_meshes-n_external_meshes_excluded_from_mesh_adaptivity>1) then + ewrite(-1,*) "With multiple external (from_file) meshes" + FLExit("Only one external mesh may leave out the exclude_from_mesh_adaptivity option.") + end if - mesh_loop1: do i=0, nmeshes-1 + ! Check that dimension of mesh is the same as the dimension defined in the options file + ! ...that's not so easy: let's just do this in insert_external_mesh() with a nice FLEXit - ! Save mesh path - path="/geometry/mesh["//int2str(i)//"]" + periodic_mesh_count = 0 + ! Check that the meshes required to make other meshes are present. + mesh_loop2: do i=0, nmeshes-1 - if(have_option(trim(path)//"/from_file")) then + ! Save mesh path + path="/geometry/mesh["//int2str(i)//"]" + call get_option(trim(path)//"/name", mesh_name) - n_external_meshes=n_external_meshes+1 + if (have_option(trim(path)//"/from_mesh")) then - if (have_option(trim(path)//"/exclude_from_mesh_adaptivity")) then - n_external_meshes_excluded_from_mesh_adaptivity=n_external_meshes_excluded_from_mesh_adaptivity+1 - end if + call get_option(trim(path)//"/from_mesh/mesh[0]/name", from_mesh_name) + if (.not. have_option("/geometry/mesh::"//trim(from_mesh_name))) then - else if (.not. have_option(trim(path)//"/from_mesh")) then + ewrite(-1,*) "Unknown mesh: ", trim(from_mesh_name) + ewrite(-1,*) "Specified as source (from_mesh) for ", trim(mesh_name) + FLExit("Error in /geometry/mesh: unknown mesh.") - call get_option(trim(path)//"/name", mesh_name) - ewrite(-1,*) "In options for /geometry/mesh ("//trim(mesh_name)//"):" - FLExit("Error: unknown way of specifying mesh source.") + end if - end if + if (have_option("/geometry/mesh::"//trim(from_mesh_name)//& + "/exclude_from_mesh_adaptivity") .and. .not. & + have_option(trim(path)//"/exclude_from_mesh_adaptivity") .and. .not. & + have_option(trim(path)//"/from_mesh/extrude")) then + ! if the from_mesh is excluded, the mesh itself also needs to be + ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) + ewrite(-1,*) "A mesh derived from a mesh with exclude_from_mesh_adaptivity needs to have this options as well." + FLExit("Missing exclude_from_mesh_adaptivity option") + end if - end do mesh_loop1 + if (have_option(trim(path)//"/from_mesh/extrude") .and. ( & - ! Check that at least one mesh is read in from a file. - if(n_external_meshes==0) then - FLExit("At least one mesh must come from a file.") - end if - if(isparallel() .and. n_external_meshes > 1) then - FLExit("Only one mesh may be from_file in parallel.") - end if - if(n_external_meshes-n_external_meshes_excluded_from_mesh_adaptivity>1) then - ewrite(-1,*) "With multiple external (from_file) meshes" - FLExit("Only one external mesh may leave out the exclude_from_mesh_adaptivity option.") - end if + have_option(trim(path)//"/from_mesh/mesh_shape") .or. & + have_option(trim(path)//"/from_mesh/mesh_continuity") .or. & + have_option(trim(path)//"/from_mesh/periodic_boundary_conditions") & + ) ) then - ! Check that dimension of mesh is the same as the dimension defined in the options file - ! ...that's not so easy: let's just do this in insert_external_mesh() with a nice FLEXit + ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) + ewrite(-1,*) "When extruding a mesh, you cannot at the same time" + ewrite(-1,*) "change its shape, continuity or add periodic bcs." + ewrite(-1,*) "Need to do this in seperate step (derivation)." + FLExit("Error in /geometry/mesh with extrude option") - periodic_mesh_count = 0 - ! Check that the meshes required to make other meshes are present. - mesh_loop2: do i=0, nmeshes-1 + end if - ! Save mesh path - path="/geometry/mesh["//int2str(i)//"]" - call get_option(trim(path)//"/name", mesh_name) + if (have_option(trim(path)//"/from_mesh/periodic_boundary_conditions")) then - if (have_option(trim(path)//"/from_mesh")) then + ! can't combine with anything else + if ( & - call get_option(trim(path)//"/from_mesh/mesh[0]/name", from_mesh_name) - if (.not. have_option("/geometry/mesh::"//trim(from_mesh_name))) then + have_option(trim(path)//"/from_mesh/mesh_shape") .or. & + have_option(trim(path)//"/from_mesh/mesh_continuity") .or. & + have_option(trim(path)//"/from_mesh/extrude") & + ) then - ewrite(-1,*) "Unknown mesh: ", trim(from_mesh_name) - ewrite(-1,*) "Specified as source (from_mesh) for ", trim(mesh_name) - FLExit("Error in /geometry/mesh: unknown mesh.") + ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) + ewrite(-1,*) "When adding or removing periodicity to a mesh, you cannot at the same time" + ewrite(-1,*) "change its shape, continuity or extrude a mesh." + ewrite(-1,*) "Need to do this in seperate step (derivation)." + FLExit("Error in /geometry/mesh with extrude option") - end if + end if - if (have_option("/geometry/mesh::"//trim(from_mesh_name)//& - "/exclude_from_mesh_adaptivity") .and. .not. & - have_option(trim(path)//"/exclude_from_mesh_adaptivity") .and. .not. & - have_option(trim(path)//"/from_mesh/extrude")) then - ! if the from_mesh is excluded, the mesh itself also needs to be - ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) - ewrite(-1,*) "A mesh derived from a mesh with exclude_from_mesh_adaptivity needs to have this options as well." - FLExit("Missing exclude_from_mesh_adaptivity option") - end if + if (have_option(trim(path)//"/from_mesh/periodic_boundary_conditions/remove_periodicity")) then - if (have_option(trim(path)//"/from_mesh/extrude") .and. ( & + ! check to see the from_mesh is not non-periodic is done above - have_option(trim(path)//"/from_mesh/mesh_shape") .or. & - have_option(trim(path)//"/from_mesh/mesh_continuity") .or. & - have_option(trim(path)//"/from_mesh/periodic_boundary_conditions") & - ) ) then + ! check that all periodic bcs have remove_periodicity + if (option_count(trim(path)//"/from_mesh/periodic_boundary_conditions")/= & + option_count(trim(path)//"/from_mesh/periodic_boundary_conditions/remove_periodicity")) then + ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) + FLExit("All or none of the periodic_boundary_conditions need to have the option remove_periodicity.") + end if - ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) - ewrite(-1,*) "When extruding a mesh, you cannot at the same time" - ewrite(-1,*) "change its shape, continuity or add periodic bcs." - ewrite(-1,*) "Need to do this in seperate step (derivation)." - FLExit("Error in /geometry/mesh with extrude option") + else - end if + ! really periodic - if (have_option(trim(path)//"/from_mesh/periodic_boundary_conditions")) then + if (mesh_name=="CoordinateMesh") then + ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) + FLExit("CoordinateMesh may not be made periodic.") + end if - ! can't combine with anything else - if ( & + periodic_mesh_count=periodic_mesh_count+1 - have_option(trim(path)//"/from_mesh/mesh_shape") .or. & - have_option(trim(path)//"/from_mesh/mesh_continuity") .or. & - have_option(trim(path)//"/from_mesh/extrude") & - ) then + if (periodic_mesh_count>1) then + ewrite(-1,*) "In the derivation of periodic meshes, all periodic boundary conditions" + ewrite(-1,*) "have to be applied at once. Thus only one mesh may have periodic_boundary_conditions" + ewrite(-1,*) "specified under /geometry/mesh::PeriodicMesh/from_mesh and all other periodic meshes" + ewrite(-1,*) "should be derived from this mesh." + FLExit("More than one mesh with periodic_boundary_conditions") + end if - ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) - ewrite(-1,*) "When adding or removing periodicity to a mesh, you cannot at the same time" - ewrite(-1,*) "change its shape, continuity or extrude a mesh." - ewrite(-1,*) "Need to do this in seperate step (derivation)." - FLExit("Error in /geometry/mesh with extrude option") + if (.not. have_option("/geometry/mesh::"//trim(from_mesh_name)// & + "/from_file")) then + ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) + ewrite(-1,*) "In the derivation of periodic meshes, the first periodic mesh," + ewrite(-1,*) "which has the periodic_boundary_conditions specified, must be derived" + ewrite(-1,*) "directly from the external (from_file) mesh." + FLExit("Periodic mesh not from from_file mesh") + end if + end if - end if + end if - if (have_option(trim(path)//"/from_mesh/periodic_boundary_conditions/remove_periodicity")) then + end if - ! check to see the from_mesh is not non-periodic is done above + end do mesh_loop2 - ! check that all periodic bcs have remove_periodicity - if (option_count(trim(path)//"/from_mesh/periodic_boundary_conditions")/= & - option_count(trim(path)//"/from_mesh/periodic_boundary_conditions/remove_periodicity")) then - ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) - FLExit("All or none of the periodic_boundary_conditions need to have the option remove_periodicity.") - end if + ! Check that mesh associated with each field exists - else + nstates=option_count("/material_phase") - ! really periodic + state_loop: do i=0, nstates-1 - if (mesh_name=="CoordinateMesh") then - ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) - FLExit("CoordinateMesh may not be made periodic.") - end if + call get_option("/material_phase["//int2str(i)//"]/name", phase_name) - periodic_mesh_count=periodic_mesh_count+1 + ! Get number of scalar fields that are children of this state + nfields=option_count("/material_phase["//int2str(i)//"]/scalar_field") - if (periodic_mesh_count>1) then - ewrite(-1,*) "In the derivation of periodic meshes, all periodic boundary conditions" - ewrite(-1,*) "have to be applied at once. Thus only one mesh may have periodic_boundary_conditions" - ewrite(-1,*) "specified under /geometry/mesh::PeriodicMesh/from_mesh and all other periodic meshes" - ewrite(-1,*) "should be derived from this mesh." - FLExit("More than one mesh with periodic_boundary_conditions") - end if + ! Loop over scalar fields + scalar_field_loop: do j=0, nfields-1 - if (.not. have_option("/geometry/mesh::"//trim(from_mesh_name)// & - "/from_file")) then - ewrite(-1,*) "In derivation of mesh ", trim(mesh_name), " from ", trim(from_mesh_name) - ewrite(-1,*) "In the derivation of periodic meshes, the first periodic mesh," - ewrite(-1,*) "which has the periodic_boundary_conditions specified, must be derived" - ewrite(-1,*) "directly from the external (from_file) mesh." - FLExit("Periodic mesh not from from_file mesh") - end if - end if + ! Save path to field + path="/material_phase["//int2str(i)//"]/scalar_field["& + &//int2str(j)//"]" + ! Get field name + call get_option(trim(path)//"/name", field_name) + ! Reset path to have field name rather than index + path="/material_phase["//int2str(i)//"]/scalar_field::"//trim(field_name) - end if + ! If field is not aliased check mesh name + is_aliased=have_option(trim(path)//"/aliased") + if(.not.is_aliased) then + call get_option(trim(complete_field_path(path))//"/mesh[0]/name", mesh_name) - end if + if (.not. have_option("/geometry/mesh::"//trim(mesh_name))) then - end do mesh_loop2 + ewrite(-1,*) "Unknown mesh: ", trim(mesh_name) + ewrite(-1,*) "Specified as mesh for scalar_field ", trim(field_name) + ewrite(-1,*) "In material_phase ", trim(phase_name) + FLExit("Error: unknown mesh.") - ! Check that mesh associated with each field exists + end if - nstates=option_count("/material_phase") + end if - state_loop: do i=0, nstates-1 + end do scalar_field_loop - call get_option("/material_phase["//int2str(i)//"]/name", phase_name) + ! Get number of vector fields that are children of this state + nfields=option_count("/material_phase["//int2str(i)//"]/vecto& + &r_field") - ! Get number of scalar fields that are children of this state - nfields=option_count("/material_phase["//int2str(i)//"]/scalar_field") + ! Loop over vector fields + vector_field_loop: do j=0, nfields-1 - ! Loop over scalar fields - scalar_field_loop: do j=0, nfields-1 + ! Save path to field + path="/material_phase["//int2str(i)//"]/vector_field["& + &//int2str(j)//"]" + ! Get field name + call get_option(trim(path)//"/name", field_name) + ! Reset path to have field name rather than index + path="/material_phase["//int2str(i)//"]/vector_field::"//trim(field_name) - ! Save path to field - path="/material_phase["//int2str(i)//"]/scalar_field["& - &//int2str(j)//"]" - ! Get field name - call get_option(trim(path)//"/name", field_name) - ! Reset path to have field name rather than index - path="/material_phase["//int2str(i)//"]/scalar_field::"//trim(field_name) + ! If field is not aliased check mesh name + is_aliased=have_option(trim(path)//"/aliased") + if(.not.is_aliased) then + call get_option(trim(complete_field_path(path))//"/mesh[0]/name", mesh_name) - ! If field is not aliased check mesh name - is_aliased=have_option(trim(path)//"/aliased") - if(.not.is_aliased) then - call get_option(trim(complete_field_path(path))//"/mesh[0]/name", mesh_name) + if (.not. have_option("/geometry/mesh::"//trim(mesh_name))) then - if (.not. have_option("/geometry/mesh::"//trim(mesh_name))) then + ewrite(-1,*) "Unknown mesh: ", trim(mesh_name) + ewrite(-1,*) "Specified as mesh for vector_field ", trim(field_name) + ewrite(-1,*) "In material_phase ", trim(phase_name) + FLExit("Error: unknown mesh.") - ewrite(-1,*) "Unknown mesh: ", trim(mesh_name) - ewrite(-1,*) "Specified as mesh for scalar_field ", trim(field_name) - ewrite(-1,*) "In material_phase ", trim(phase_name) - FLExit("Error: unknown mesh.") + end if - end if + end if - end if + end do vector_field_loop - end do scalar_field_loop + ! Get number of tensor fields that are children of this state + nfields=option_count("/material_phase["//int2str(i)//"]/tensor_field") - ! Get number of vector fields that are children of this state - nfields=option_count("/material_phase["//int2str(i)//"]/vecto& - &r_field") + tensor_field_loop: do j=0, nfields-1 - ! Loop over vector fields - vector_field_loop: do j=0, nfields-1 + ! Save path to field + path="/material_phase["//int2str(i)//"]/tensor_field["& + &//int2str(j)//"]" + ! Get field name + call get_option(trim(path)//"/name", field_name) + ! Reset path to have field name rather than index + path="/material_phase["//int2str(i)//"]/tensor_field::"//trim(field_name) - ! Save path to field - path="/material_phase["//int2str(i)//"]/vector_field["& - &//int2str(j)//"]" - ! Get field name - call get_option(trim(path)//"/name", field_name) - ! Reset path to have field name rather than index - path="/material_phase["//int2str(i)//"]/vector_field::"//trim(field_name) + ! If field is not aliased check mesh name + is_aliased=have_option(trim(path)//"/aliased") + if(.not.is_aliased) then + call get_option(trim(complete_field_path(path))//"/mesh[0]/name", mesh_name) - ! If field is not aliased check mesh name - is_aliased=have_option(trim(path)//"/aliased") - if(.not.is_aliased) then - call get_option(trim(complete_field_path(path))//"/mesh[0]/name", mesh_name) + if (.not. have_option("/geometry/mesh::"//trim(mesh_name))) then - if (.not. have_option("/geometry/mesh::"//trim(mesh_name))) then + ewrite(-1,*) "Unknown mesh: ", trim(mesh_name) + ewrite(-1,*) "Specified as mesh for tensor_field ", trim(field_name) + ewrite(-1,*) "In material_phase ", trim(phase_name) + FLExit("Error: unknown mesh.") - ewrite(-1,*) "Unknown mesh: ", trim(mesh_name) - ewrite(-1,*) "Specified as mesh for vector_field ", trim(field_name) - ewrite(-1,*) "In material_phase ", trim(phase_name) - FLExit("Error: unknown mesh.") + end if - end if + end if - end if + end do tensor_field_loop - end do vector_field_loop + end do state_loop - ! Get number of tensor fields that are children of this state - nfields=option_count("/material_phase["//int2str(i)//"]/tensor_field") + end subroutine check_mesh_options - tensor_field_loop: do j=0, nfields-1 + subroutine check_ocean_options - ! Save path to field - path="/material_phase["//int2str(i)//"]/tensor_field["& - &//int2str(j)//"]" - ! Get field name - call get_option(trim(path)//"/name", field_name) - ! Reset path to have field name rather than index - path="/material_phase["//int2str(i)//"]/tensor_field::"//trim(field_name) + character(len=OPTION_PATH_LEN) str, velocity_path, pressure_path, tmpstring + logical on_sphere, constant_gravity, new_navsto - ! If field is not aliased check mesh name - is_aliased=have_option(trim(path)//"/aliased") - if(.not.is_aliased) then - call get_option(trim(complete_field_path(path))//"/mesh[0]/name", mesh_name) + if (option_count('/material_phase')/=1) then + FLExit("The checks for problem_type oceans only work for single phase.") + endif - if (.not. have_option("/geometry/mesh::"//trim(mesh_name))) then + ! from now on we may assume single material/phase + velocity_path="/material_phase[0]/vector_field::Velocity/prognostic" + if (have_option(trim(velocity_path))) then + new_navsto=have_option(trim(velocity_path)//'/spatial_discretisation/continuous_galerkin') .or. & + have_option(trim(velocity_path)//'/spatial_discretisation/discontinuous_galerkin') + ! Check that for ocean problems with prognostic velocity the mass is lumped + ! in case of Continuous Galerkin: + str=trim(velocity_path)//'/spatial_discretisation/legacy_continuous_galerkin' + if (have_option(trim(str)) .and. .not. & + have_option(trim(str)//"/lump_mass_matrix")) then + ewrite(0,*) "Missing option spatial_discretisation/legacy_continuous_galerkin/lump_mass_matrix" + ewrite(0,*) "under the prognostic velocity field." + FLExit("For ocean problems you need to lump the mass matrix.") + end if + ! in case of legacy discretisation options: + str=trim(velocity_path)//'/spatial_discretisation/legacy_discretisation' + if (have_option(trim(str)).and. .not. & + have_option(trim(str)//"/legacy_mlump")) then + ewrite(0,*) "Missing option spatial_discretisation/legacy_discretisation/legacy_mlump" + ewrite(0,*) "under the prognostic velocity field." + FLExit("For ocean problems you need to lump the mass matrix.") + end if - ewrite(-1,*) "Unknown mesh: ", trim(mesh_name) - ewrite(-1,*) "Specified as mesh for tensor_field ", trim(field_name) - ewrite(-1,*) "In material_phase ", trim(phase_name) - FLExit("Error: unknown mesh.") + ! check we have the right equation type for velocity + if (.not. have_option(trim(velocity_path)//'/equation::Boussinesq')) then + ewrite(0,*) "For ocean problems you need to set the equation type" + ewrite(0,*) "for velocity to Boussinesq." + FLExit("Wrong Velocity equation type") + end if - end if + end if - end if + pressure_path="/material_phase[0]/scalar_field::Pressure/prognostic" + if(have_option("/material_phase[0]/scalar_field::Pressure/prognostic")) then + if (.not.have_option(trim(pressure_path)//"/scheme/use_projection_method")) then + FLExit("For ocean problems you should use the projection method under scheme for pressure") + end if + call get_option(trim(pressure_path)//"/scheme/poisson_pressure_solution", tmpstring) + select case (tmpstring) + case ("never", "every timestep") + ewrite(0,*) ("WARNING: For ocean problems you should use the Poisson pressure solution at the first timestep only.") + end select + end if - end do tensor_field_loop + ! Warning about salinity options + ! Density is only affected when you have salinity and either linear EoS with + ! salinity dependency or Pade Approximation turned on + if(have_option("/material_phase[0]/scalar_field::Salinity")& + .and.(.not.(have_option("/material_phase[0]/equation_of_state/fluids/linear/salinity_dependency") .or.& + have_option("/material_phase[0]/equation_of_state/fluids/ocean_pade_approximation")))) then + ewrite(0,*) "WARNING: You have a salinity field but it will not affect the density of the fluid." + end if - end do state_loop + ! Check that the gravity field is not constant for spherical problems + on_sphere=have_option("/geometry/spherical_earth") + constant_gravity=have_option("/physical_parameters/gravity/vector_field::GravityDirection/prescribed/value[0]/constant") + if(on_sphere .and. constant_gravity) then + ewrite(0,*) "If you are using spherical geometry you cannot have" + ewrite(0,*) "a constant gravity direction." + ewrite(0,*) "See the waterworld test case for an example of how" + ewrite(0,*) "to set this properly" + FLExit("GravityDirection set incorrectly for spherical geometry.") + end if - end subroutine check_mesh_options + end subroutine check_ocean_options - subroutine check_ocean_options + subroutine check_large_scale_ocean_options - character(len=OPTION_PATH_LEN) str, velocity_path, pressure_path, tmpstring - logical on_sphere, constant_gravity, new_navsto + character(len=OPTION_PATH_LEN) str, velocity_path, pressure_path, tmpstring, temperature_path, salinity_path,continuity2, continuity1, velmesh, pressuremesh, preconditioner + logical on_sphere, constant_gravity + integer iterations, poly + if (option_count('/material_phase')/=1) then + FLExit("The checks for problem_type oceans only work for single phase.") + endif - if (option_count('/material_phase')/=1) then - FLExit("The checks for problem_type oceans only work for single phase.") - endif + ! Velocity options checks + velocity_path="/material_phase[0]/vector_field::Velocity/prognostic" + if (have_option(trim(velocity_path))) then + str=trim(velocity_path)//'/spatial_discretisation/continuous_galerkin' + if (have_option(trim(str))) then + FLExit("For large scale ocean problems you need discontinuous galerkin velocity.") + end if + if (.not. have_option(trim(velocity_path)//'/equation::Boussinesq')) then + FLExit("Wrong Velocity equation type - should be Boussinesq") + end if + if(.not.(have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/advection_scheme/upwind")).and. & + (.not.(have_option("timestepping/steady_state")))) then + ewrite(0,*)("WARNING: You should probably have advection_scheme/upwind under velocity") + end if + if(.not.(have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/advection_scheme/integrate_advection_by_parts/twice"))) then + FLExit("Should have Velocity/spatial_discretisation/advection_scheme/integrate_advection_by_parts/twice") + end if + if(have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/mass_terms/lump_mass_matrix")) then + FLExit("Should not lump mass matrix in large-scale ocean simulations") + end if + if (.not.have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/viscosity_scheme/bassi_rebay").and. .not.have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/viscosity_scheme/compact_discontinuous_galerkin")) then + FLExit("Should have Bassi Rebay or compact discontinuous galerkin Viscosity scheme (under Velocity)") + end if + if (have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/viscosity_scheme/compact_discontinuous_galerkin") ) then + call get_option(trim(velocity_path)//"/solver/preconditioner/name",preconditioner) + if (preconditioner .ne. "sor") then + FLExit("You need sor preconditioner for velocity with compact discontinuous galerkin viscosity.") + end if + end if + if (.not.have_option(trim(velocity_path)//"/temporal_discretisation/discontinuous_galerkin/maximum_courant_number_per_subcycle")) then + ewrite(0,*) ("WARNING: You may wish to switch on velocity/prognostic/temporal_discretisation/discontinuous_galerkin/maximum_courant_number_per_subcycle ") + end if + if (.not.have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/advection_scheme/project_velocity_to_continuous")) then + FLExit("You need to switch on velocity/prognostic/spatial_discretisation/discontinuous_galerkin/advection_scheme/project_velocity_to_continuous ") + end if - ! from now on we may assume single material/phase - velocity_path="/material_phase[0]/vector_field::Velocity/prognostic" - if (have_option(trim(velocity_path))) then - new_navsto=have_option(trim(velocity_path)//'/spatial_discretisation/continuous_galerkin') .or. & - have_option(trim(velocity_path)//'/spatial_discretisation/discontinuous_galerkin') - ! Check that for ocean problems with prognostic velocity the mass is lumped - ! in case of Continuous Galerkin: - str=trim(velocity_path)//'/spatial_discretisation/legacy_continuous_galerkin' - if (have_option(trim(str)) .and. .not. & - have_option(trim(str)//"/lump_mass_matrix")) then - ewrite(0,*) "Missing option spatial_discretisation/legacy_continuous_galerkin/lump_mass_matrix" - ewrite(0,*) "under the prognostic velocity field." - FLExit("For ocean problems you need to lump the mass matrix.") - end if - ! in case of legacy discretisation options: - str=trim(velocity_path)//'/spatial_discretisation/legacy_discretisation' - if (have_option(trim(str)).and. .not. & - have_option(trim(str)//"/legacy_mlump")) then - ewrite(0,*) "Missing option spatial_discretisation/legacy_discretisation/legacy_mlump" - ewrite(0,*) "under the prognostic velocity field." - FLExit("For ocean problems you need to lump the mass matrix.") - end if - - ! check we have the right equation type for velocity - if (.not. have_option(trim(velocity_path)//'/equation::Boussinesq')) then - ewrite(0,*) "For ocean problems you need to set the equation type" - ewrite(0,*) "for velocity to Boussinesq." - FLExit("Wrong Velocity equation type") - end if - - end if - - pressure_path="/material_phase[0]/scalar_field::Pressure/prognostic" - if(have_option("/material_phase[0]/scalar_field::Pressure/prognostic")) then - if (.not.have_option(trim(pressure_path)//"/scheme/use_projection_method")) then - FLExit("For ocean problems you should use the projection method under scheme for pressure") - end if - call get_option(trim(pressure_path)//"/scheme/poisson_pressure_solution", tmpstring) - select case (tmpstring) - case ("never", "every timestep") - ewrite(0,*) ("WARNING: For ocean problems you should use the Poisson pressure solution at the first timestep only.") - end select - end if - - ! Warning about salinity options - ! Density is only affected when you have salinity and either linear EoS with - ! salinity dependency or Pade Approximation turned on - if(have_option("/material_phase[0]/scalar_field::Salinity")& - .and.(.not.(have_option("/material_phase[0]/equation_of_state/fluids/linear/salinity_dependency") .or.& - have_option("/material_phase[0]/equation_of_state/fluids/ocean_pade_approximation")))) then - ewrite(0,*) "WARNING: You have a salinity field but it will not affect the density of the fluid." - end if - - ! Check that the gravity field is not constant for spherical problems - on_sphere=have_option("/geometry/spherical_earth") - constant_gravity=have_option("/physical_parameters/gravity/vector_field::GravityDirection/prescribed/value[0]/constant") - if(on_sphere .and. constant_gravity) then - ewrite(0,*) "If you are using spherical geometry you cannot have" - ewrite(0,*) "a constant gravity direction." - ewrite(0,*) "See the waterworld test case for an example of how" - ewrite(0,*) "to set this properly" - FLExit("GravityDirection set incorrectly for spherical geometry.") - end if - - end subroutine check_ocean_options - - subroutine check_large_scale_ocean_options - - character(len=OPTION_PATH_LEN) str, velocity_path, pressure_path, tmpstring, temperature_path, salinity_path,continuity2, continuity1, velmesh, pressuremesh, preconditioner - logical on_sphere, constant_gravity - integer iterations, poly - if (option_count('/material_phase')/=1) then - FLExit("The checks for problem_type oceans only work for single phase.") - endif - - ! Velocity options checks - velocity_path="/material_phase[0]/vector_field::Velocity/prognostic" - if (have_option(trim(velocity_path))) then - str=trim(velocity_path)//'/spatial_discretisation/continuous_galerkin' - if (have_option(trim(str))) then - FLExit("For large scale ocean problems you need discontinuous galerkin velocity.") - end if - if (.not. have_option(trim(velocity_path)//'/equation::Boussinesq')) then - FLExit("Wrong Velocity equation type - should be Boussinesq") - end if - if(.not.(have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/advection_scheme/upwind")).and. & - (.not.(have_option("timestepping/steady_state")))) then - ewrite(0,*)("WARNING: You should probably have advection_scheme/upwind under velocity") - end if - if(.not.(have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/advection_scheme/integrate_advection_by_parts/twice"))) then - FLExit("Should have Velocity/spatial_discretisation/advection_scheme/integrate_advection_by_parts/twice") - end if - if(have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/mass_terms/lump_mass_matrix")) then - FLExit("Should not lump mass matrix in large-scale ocean simulations") - end if - if (.not.have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/viscosity_scheme/bassi_rebay").and. .not.have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/viscosity_scheme/compact_discontinuous_galerkin")) then - FLExit("Should have Bassi Rebay or compact discontinuous galerkin Viscosity scheme (under Velocity)") - end if - if (have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/viscosity_scheme/compact_discontinuous_galerkin") ) then - call get_option(trim(velocity_path)//"/solver/preconditioner/name",preconditioner) - if (preconditioner .ne. "sor") then - FLExit("You need sor preconditioner for velocity with compact discontinuous galerkin viscosity.") - end if - end if - if (.not.have_option(trim(velocity_path)//"/temporal_discretisation/discontinuous_galerkin/maximum_courant_number_per_subcycle")) then - ewrite(0,*) ("WARNING: You may wish to switch on velocity/prognostic/temporal_discretisation/discontinuous_galerkin/maximum_courant_number_per_subcycle ") - end if - if (.not.have_option(trim(velocity_path)//"/spatial_discretisation/discontinuous_galerkin/advection_scheme/project_velocity_to_continuous")) then - FLExit("You need to switch on velocity/prognostic/spatial_discretisation/discontinuous_galerkin/advection_scheme/project_velocity_to_continuous ") - end if - - end if + end if !Timestepping options - if(.not.(have_option("/timestepping/nonlinear_iterations"))) then - FLExit("You should turn on timestepping/nonlinear_iterations and set to a number greater than 1") - end if - if((have_option("/timestepping/nonlinear_iterations"))) then - call get_option(("/timestepping/nonlinear_iterations"), iterations) - if(iterations .lt. 2 ) then - FLExit("timestepping/nonlinear_iterations should be set to a number greater than 1") - end if - end if + if(.not.(have_option("/timestepping/nonlinear_iterations"))) then + FLExit("You should turn on timestepping/nonlinear_iterations and set to a number greater than 1") + end if + if((have_option("/timestepping/nonlinear_iterations"))) then + call get_option(("/timestepping/nonlinear_iterations"), iterations) + if(iterations .lt. 2 ) then + FLExit("timestepping/nonlinear_iterations should be set to a number greater than 1") + end if + end if ! Subtract out hydrostatic level option - if(.not.(have_option("material_phase/equation_of_state/fluids/linear/subtract_out_hydrostatic_level"))) then - FLExit("You should switch on material_phase/equation_of_state/subtract_out_hydrostatic_level") - end if + if(.not.(have_option("material_phase/equation_of_state/fluids/linear/subtract_out_hydrostatic_level"))) then + FLExit("You should switch on material_phase/equation_of_state/subtract_out_hydrostatic_level") + end if ! Geometry ocean boundaries - if(.not.(have_option("/geometry/ocean_boundaries"))) then - FLExit("You need to switch on geometry/ocean_boundaries") - end if + if(.not.(have_option("/geometry/ocean_boundaries"))) then + FLExit("You need to switch on geometry/ocean_boundaries") + end if !Pressure options checks - pressure_path="/material_phase[0]/scalar_field::Pressure/prognostic" - if(have_option("/material_phase[0]/scalar_field::Pressure/prognostic")) then - if (.not.have_option(trim(pressure_path)//"/scheme/use_projection_method")) then - FLExit("For ocean problems you should use the projection method under scheme for pressure") - end if - call get_option(trim(pressure_path)//"/scheme/poisson_pressure_solution", tmpstring) - select case (tmpstring) - case ("never") - ewrite(0,*) ("WARNING: Poisson pressure solution is set to never.") - case ("only first timestep") - ewrite(0,*)("WARNING: Poisson pressure solution is set to only first time step") - end select - if (.not.have_option(trim(pressure_path)//"/spatial_discretisation/continuous_galerkin")) then - FLExit("For ocean problems you should use continuous galerkin pressure") - end if - if (.not.have_option(trim(pressure_path)//"/solver/preconditioner/vertical_lumping")) then - ewrite(0,*)("WARNING: Vertical lumping not used during pressure solve. Consider switching on pressure/vertical_lumping.") - end if - if (.not.have_option(trim(pressure_path)//"/spatial_discretisation/continuous_galerkin/remove_stabilisation_term")) then - FLExit("Use remove stabilisation term under pressure") - end if - if (.not.have_option(trim(pressure_path)//"/spatial_discretisation/continuous_galerkin/integrate_continuity_by_parts")) then - FLExit("Use integrate continuity by parts under pressure") - end if - end if - - ! Salinity options checks - salinity_path="/material_phase[0]/scalar_field::Salinity/prognostic" - if(have_option("/material_phase[0]/scalar_field::Salinity")& + pressure_path="/material_phase[0]/scalar_field::Pressure/prognostic" + if(have_option("/material_phase[0]/scalar_field::Pressure/prognostic")) then + if (.not.have_option(trim(pressure_path)//"/scheme/use_projection_method")) then + FLExit("For ocean problems you should use the projection method under scheme for pressure") + end if + call get_option(trim(pressure_path)//"/scheme/poisson_pressure_solution", tmpstring) + select case (tmpstring) + case ("never") + ewrite(0,*) ("WARNING: Poisson pressure solution is set to never.") + case ("only first timestep") + ewrite(0,*)("WARNING: Poisson pressure solution is set to only first time step") + end select + if (.not.have_option(trim(pressure_path)//"/spatial_discretisation/continuous_galerkin")) then + FLExit("For ocean problems you should use continuous galerkin pressure") + end if + if (.not.have_option(trim(pressure_path)//"/solver/preconditioner/vertical_lumping")) then + ewrite(0,*)("WARNING: Vertical lumping not used during pressure solve. Consider switching on pressure/vertical_lumping.") + end if + if (.not.have_option(trim(pressure_path)//"/spatial_discretisation/continuous_galerkin/remove_stabilisation_term")) then + FLExit("Use remove stabilisation term under pressure") + end if + if (.not.have_option(trim(pressure_path)//"/spatial_discretisation/continuous_galerkin/integrate_continuity_by_parts")) then + FLExit("Use integrate continuity by parts under pressure") + end if + end if + + ! Salinity options checks + salinity_path="/material_phase[0]/scalar_field::Salinity/prognostic" + if(have_option("/material_phase[0]/scalar_field::Salinity")& .and.(.not.(have_option("/material_phase[0]/equation_of_state/fluids/linear/salinity_dependency")))) then - ewrite(0,*) "WARNING: You have a salinity field but it will not affect the density of the fluid." - end if + ewrite(0,*) "WARNING: You have a salinity field but it will not affect the density of the fluid." + end if - ! Temperature options checks - temperature_path="/material_phase[0]/scalar_field::Temperature/prognostic" - if(have_option("/material_phase[0]/scalar_field::Temperature")& + ! Temperature options checks + temperature_path="/material_phase[0]/scalar_field::Temperature/prognostic" + if(have_option("/material_phase[0]/scalar_field::Temperature")& .and.(.not.(have_option("/material_phase[0]/equation_of_state/fluids/linear/temperature_dependency") ))) then - ewrite(0,*) "WARNING: You have a temperature field but it will not affect the density of the fluid." - end if + ewrite(0,*) "WARNING: You have a temperature field but it will not affect the density of the fluid." + end if - ! Check that the gravity field is not constant for spherical problems - on_sphere=have_option("/geometry/spherical_earth") - constant_gravity=have_option("/physical_parameters/gravity/vector_field::GravityDirection/prescribed/value[0]/constant") - if(on_sphere .and. constant_gravity) then - FLExit("GravityDirection set incorrectly for spherical geometry.") - end if + ! Check that the gravity field is not constant for spherical problems + on_sphere=have_option("/geometry/spherical_earth") + constant_gravity=have_option("/physical_parameters/gravity/vector_field::GravityDirection/prescribed/value[0]/constant") + if(on_sphere .and. constant_gravity) then + FLExit("GravityDirection set incorrectly for spherical geometry.") + end if ! Check velocity mesh continuity - call get_option("/material_phase[0]/vector_field::Velocity/prognostic/mesh/name",velmesh) - call get_option("/geometry/mesh::"//trim(velmesh)//"/from_mesh/mesh_continuity",continuity2) - - if (trim(continuity2).ne."discontinuous") then - FLExit("The velocity mesh is not discontinuous") - end if - - ! Check pressure mesh continuity - call get_option("/material_phase[0]/scalar_field::Pressure/prognostic/mesh/name",pressuremesh) - if (have_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_continuity"))then - call get_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_continuity",continuity1) - if (trim(continuity1).ne."continuous")then - FLExit ("Pressure mesh is not continuous") - end if - end if - ! Check pressure mesh polynomial order - if (.not.have_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_shape"))then - ewrite (0,*)"WARNING: You should have the pressure mesh shape set to polynomial order 2" - end if - if (have_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_shape/polynomial_degree"))then - call get_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_shape/polynomial_degree",poly) - if (poly.ne.2) then - ewrite (0,*)"WARNING: You should have the pressure mesh shape set to polynomial order 2" - end if - end if - - !Check for viscosity field - if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/tensor_field::Viscosity"))then - ewrite(0,*)"WARNING: You have no viscosity field" - end if - ! Check for absorption term -if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/vector_field::Absorption"))then - ewrite(0,*)"WARNING: you may wish to add an absorption term under velocity" - end if - !Check for temperature diffusivity - if (have_option("/material_phase[0]/scalar_field::Temperature/prognostic")) then - if (.not. have_option("/material_phase[0]/scalar_field::Temperature/prognostic/tensor_field::Diffusivity")) then - ewrite(0,*)"WARNING: you have a prognostic temperature field but no diffusivity" - end if - end if - !Check for salinity diffusivity - if (have_option("/material_phase[0]/scalar_field::Salinity/prognostic")) then - if (.not. have_option("/material_phase[0]/scalar_field::Salinity/prognostic/tensor_field::Diffusivity")) then - ewrite(0,*)"WARNING: you have a prognostic salinity field but no diffusivity" - end if - end if - - end subroutine check_large_scale_ocean_options - - subroutine check_multimaterial_options - - integer :: neos, nmat, i - logical :: have_vfrac, have_dens - - integer :: diagnosticvolumefraction_count, density_count, & - viscosity_count, surfacetension_count - - neos = option_count("/material_phase/equation_of_state/multimaterial") - nmat = option_count("/material_phase") - - if(neos>0) then - if(nmat/=neos) then - FLExit("Not all the material_phases have compressible equations of state.") - end if - end if - - do i = 0, nmat-1 - have_vfrac = have_option("/material_phase["//int2str(i)//& + call get_option("/material_phase[0]/vector_field::Velocity/prognostic/mesh/name",velmesh) + call get_option("/geometry/mesh::"//trim(velmesh)//"/from_mesh/mesh_continuity",continuity2) + + if (trim(continuity2).ne."discontinuous") then + FLExit("The velocity mesh is not discontinuous") + end if + + ! Check pressure mesh continuity + call get_option("/material_phase[0]/scalar_field::Pressure/prognostic/mesh/name",pressuremesh) + if (have_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_continuity"))then + call get_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_continuity",continuity1) + if (trim(continuity1).ne."continuous")then + FLExit ("Pressure mesh is not continuous") + end if + end if + ! Check pressure mesh polynomial order + if (.not.have_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_shape"))then + ewrite (0,*)"WARNING: You should have the pressure mesh shape set to polynomial order 2" + end if + if (have_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_shape/polynomial_degree"))then + call get_option("/geometry/mesh::"//trim(pressuremesh)//"/from_mesh/mesh_shape/polynomial_degree",poly) + if (poly.ne.2) then + ewrite (0,*)"WARNING: You should have the pressure mesh shape set to polynomial order 2" + end if + end if + + !Check for viscosity field + if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/tensor_field::Viscosity"))then + ewrite(0,*)"WARNING: You have no viscosity field" + end if + ! Check for absorption term + if (.not.have_option("/material_phase[0]/vector_field::Velocity/prognostic/vector_field::Absorption"))then + ewrite(0,*)"WARNING: you may wish to add an absorption term under velocity" + end if + !Check for temperature diffusivity + if (have_option("/material_phase[0]/scalar_field::Temperature/prognostic")) then + if (.not. have_option("/material_phase[0]/scalar_field::Temperature/prognostic/tensor_field::Diffusivity")) then + ewrite(0,*)"WARNING: you have a prognostic temperature field but no diffusivity" + end if + end if + !Check for salinity diffusivity + if (have_option("/material_phase[0]/scalar_field::Salinity/prognostic")) then + if (.not. have_option("/material_phase[0]/scalar_field::Salinity/prognostic/tensor_field::Diffusivity")) then + ewrite(0,*)"WARNING: you have a prognostic salinity field but no diffusivity" + end if + end if + + end subroutine check_large_scale_ocean_options + + subroutine check_multimaterial_options + + integer :: neos, nmat, i + logical :: have_vfrac, have_dens + + integer :: diagnosticvolumefraction_count, density_count, & + viscosity_count, surfacetension_count + + neos = option_count("/material_phase/equation_of_state/multimaterial") + nmat = option_count("/material_phase") + + if(neos>0) then + if(nmat/=neos) then + FLExit("Not all the material_phases have compressible equations of state.") + end if + end if + + do i = 0, nmat-1 + have_vfrac = have_option("/material_phase["//int2str(i)//& "]/scalar_field::MaterialVolumeFraction") - have_dens = have_option("/material_phase["//int2str(i)//& + have_dens = have_option("/material_phase["//int2str(i)//& "]/scalar_field::MaterialDensity").or.& have_option("/material_phase["//int2str(i)//& "]/equation_of_state/fluids/linear/reference_density") - if((.not.have_vfrac).or.(.not.have_dens)) then - FLExit("All material_phases need a MaterialVolumeFraction and either a MaterialDensity or an eos.") - end if - end do - - diagnosticvolumefraction_count = option_count(& - &'/material_phase/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::Internal') - if(diagnosticvolumefraction_count>1) then - ewrite(-1,*) diagnosticvolumefraction_count, 'diagnostic MaterialVolumeFractions.' - FLExit("Only 1 internal diagnostic MaterialVolumeFraction is allowed") - end if - - density_count = option_count('/material_phase/& - &scalar_field::Density/diagnostic') - if(density_count>1) then - ewrite(-1,*) density_count, 'diagnostic bulk Densities.' - FLExit("Only 1 diagnostic bulk Density is allowed") - end if - - viscosity_count = option_count('/material_phase/& - &vector_field::Velocity/prognostic/& - &tensor_field::Viscosity/diagnostic') - if(viscosity_count>1) then - ewrite(-1,*) viscosity_count, 'diagnostic bulk Viscosities.' - FLExit("Only 1 diagnostic bulk Viscosity is allowed") - end if - - surfacetension_count = option_count('/material_phase/& - &vector_field::Velocity/prognostic& - &/tensor_field::SurfaceTension/diagnostic') - if(surfacetension_count>1) then - ewrite(-1,*) surfacetension_count, 'diagnostic surface tensions.' - FLExit("Only 1 diagnostic surface tension is allows") - end if - - end subroutine check_multimaterial_options - - subroutine check_stokes_options - - ! Check options for Stokes flow simulations. - - integer :: i, nmat - character(len=OPTION_PATH_LEN) :: velocity_path, pressure_path, schur_path - character(len=FIELD_NAME_LEN) :: schur_preconditioner, inner_matrix, pc_type - logical :: exclude_mass, exclude_advection - real :: theta - - nmat = option_count("/material_phase") - - do i = 0, nmat-1 - velocity_path="/material_phase["//int2str(i)//"]/vector_field::Velocity/prognostic" - - if (have_option(trim(velocity_path))) then - - ! Check that mass and advective terms are excluded: - exclude_mass = have_option(trim(velocity_path)//& + if((.not.have_vfrac).or.(.not.have_dens)) then + FLExit("All material_phases need a MaterialVolumeFraction and either a MaterialDensity or an eos.") + end if + end do + + diagnosticvolumefraction_count = option_count(& + &'/material_phase/scalar_field::MaterialVolumeFraction/diagnostic/algorithm::Internal') + if(diagnosticvolumefraction_count>1) then + ewrite(-1,*) diagnosticvolumefraction_count, 'diagnostic MaterialVolumeFractions.' + FLExit("Only 1 internal diagnostic MaterialVolumeFraction is allowed") + end if + + density_count = option_count('/material_phase/& + &scalar_field::Density/diagnostic') + if(density_count>1) then + ewrite(-1,*) density_count, 'diagnostic bulk Densities.' + FLExit("Only 1 diagnostic bulk Density is allowed") + end if + + viscosity_count = option_count('/material_phase/& + &vector_field::Velocity/prognostic/& + &tensor_field::Viscosity/diagnostic') + if(viscosity_count>1) then + ewrite(-1,*) viscosity_count, 'diagnostic bulk Viscosities.' + FLExit("Only 1 diagnostic bulk Viscosity is allowed") + end if + + surfacetension_count = option_count('/material_phase/& + &vector_field::Velocity/prognostic& + &/tensor_field::SurfaceTension/diagnostic') + if(surfacetension_count>1) then + ewrite(-1,*) surfacetension_count, 'diagnostic surface tensions.' + FLExit("Only 1 diagnostic surface tension is allows") + end if + + end subroutine check_multimaterial_options + + subroutine check_stokes_options + + ! Check options for Stokes flow simulations. + + integer :: i, nmat + character(len=OPTION_PATH_LEN) :: velocity_path, pressure_path, schur_path + character(len=FIELD_NAME_LEN) :: schur_preconditioner, inner_matrix, pc_type + logical :: exclude_mass, exclude_advection + real :: theta + + nmat = option_count("/material_phase") + + do i = 0, nmat-1 + velocity_path="/material_phase["//int2str(i)//"]/vector_field::Velocity/prognostic" + + if (have_option(trim(velocity_path))) then + + ! Check that mass and advective terms are excluded: + exclude_mass = have_option(trim(velocity_path)//& "/spatial_discretisation/continuous_galerkin/mass_terms"//& - &"/exclude_mass_terms").or.& + &"/exclude_mass_terms").or.& have_option(trim(velocity_path)//& "/spatial_discretisation/discontinuous_galerkin/mass_terms"//& - &"/exclude_mass_terms") + &"/exclude_mass_terms") - exclude_advection = have_option(trim(velocity_path)//& + exclude_advection = have_option(trim(velocity_path)//& "/spatial_discretisation/continuous_galerkin/advection_terms"//& - &"/exclude_advection_terms").or.& + &"/exclude_advection_terms").or.& have_option(trim(velocity_path)//& "/spatial_discretisation/discontinuous_galerkin/advection_scheme/none") - if(.not.(exclude_mass) .OR. .not.(exclude_advection)) then - FLExit("For Stokes problems you need to exclude the mass and advection terms.") - end if + if(.not.(exclude_mass) .OR. .not.(exclude_advection)) then + FLExit("For Stokes problems you need to exclude the mass and advection terms.") + end if - ! Check that theta = 1 (we must be implicit as we have no time term!) - call get_option(trim(velocity_path)//'/temporal_discretisation/theta/', theta) - if(theta /= 1.) then - FLExit("For Stokes problems, theta (under velocity) must = 1") - end if + ! Check that theta = 1 (we must be implicit as we have no time term!) + call get_option(trim(velocity_path)//'/temporal_discretisation/theta/', theta) + if(theta /= 1.) then + FLExit("For Stokes problems, theta (under velocity) must = 1") + end if - end if + end if - pressure_path="/material_phase["//int2str(i)//"]/scalar_field::Pressure/prognostic" + pressure_path="/material_phase["//int2str(i)//"]/scalar_field::Pressure/prognostic" - if (have_option(trim(pressure_path))) then + if (have_option(trim(pressure_path))) then - schur_path = "/material_phase["//int2str(i)//"]/scalar_field::Pressure/prognostic/"//& - &"scheme/use_projection_method/full_schur_complement" + schur_path = "/material_phase["//int2str(i)//"]/scalar_field::Pressure/prognostic/"//& + &"scheme/use_projection_method/full_schur_complement" - if(have_option(trim(schur_path))) then + if(have_option(trim(schur_path))) then - call get_option(trim(schur_path)//"/preconditioner_matrix[0]/name", schur_preconditioner) + call get_option(trim(schur_path)//"/preconditioner_matrix[0]/name", schur_preconditioner) - select case(schur_preconditioner) - case("ScaledPressureMassMatrix") - ! Check pressure_mass_matrix preconditioner is compatible with viscosity tensor: - if(have_option(trim(velocity_path)//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/anisotropic_symmetric").or.& + select case(schur_preconditioner) + case("ScaledPressureMassMatrix") + ! Check pressure_mass_matrix preconditioner is compatible with viscosity tensor: + if(have_option(trim(velocity_path)//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/anisotropic_symmetric").or.& have_option(trim(velocity_path)//& - &"/tensor_field::Viscosity/prescribed/value"//& - &"/anisotropic_asymmetric")) then - ewrite(-1,*) "WARNING - At present, the viscosity scaling for the pressure mass matrix is" - ewrite(-1,*) "taken from the 1st component of the viscosity tensor. Such a scaling" - ewrite(-1,*) "is only valid when all components of each viscosity tensor are constant." - end if - case("NoPreconditionerMatrix") - ! Check no preconditioner is selected when no preconditioner matrix is desired: - call get_option("/material_phase["//int2str(i)//& + &"/tensor_field::Viscosity/prescribed/value"//& + &"/anisotropic_asymmetric")) then + ewrite(-1,*) "WARNING - At present, the viscosity scaling for the pressure mass matrix is" + ewrite(-1,*) "taken from the 1st component of the viscosity tensor. Such a scaling" + ewrite(-1,*) "is only valid when all components of each viscosity tensor are constant." + end if + case("NoPreconditionerMatrix") + ! Check no preconditioner is selected when no preconditioner matrix is desired: + call get_option("/material_phase["//int2str(i)//& "]/scalar_field::Pressure/prognostic/solver/preconditioner/name", pc_type) - if(pc_type /= 'none') FLExit("If no preconditioner is desired, set pctype='none'.") - end select + if(pc_type /= 'none') FLExit("If no preconditioner is desired, set pctype='none'.") + end select - ! Check inner matrix is valid for Stokes - must have full viscous terms - ! included. Stokes does not have a mass matrix. - call get_option(trim(schur_path)//"/inner_matrix[0]/name", inner_matrix) + ! Check inner matrix is valid for Stokes - must have full viscous terms + ! included. Stokes does not have a mass matrix. + call get_option(trim(schur_path)//"/inner_matrix[0]/name", inner_matrix) - if(trim(inner_matrix)/="FullMomentumMatrix") then - ewrite(-1,*) "For Stokes problems, FullMomentumMatrix must be specified under:" - ewrite(-1,*) "scalar_field::Pressure/prognostic/scheme/use_projection_method& " - ewrite(-1,*) "&/full_schur_complement/inner_matrix" - FLExit("For Stokes problems, change --> FullMomentumMatrix") - end if + if(trim(inner_matrix)/="FullMomentumMatrix") then + ewrite(-1,*) "For Stokes problems, FullMomentumMatrix must be specified under:" + ewrite(-1,*) "scalar_field::Pressure/prognostic/scheme/use_projection_method& " + ewrite(-1,*) "&/full_schur_complement/inner_matrix" + FLExit("For Stokes problems, change --> FullMomentumMatrix") + end if - end if + end if - end if + end if - end do + end do - end subroutine check_stokes_options + end subroutine check_stokes_options - subroutine check_foams_options - ! Check options for liquid drainage in foam simulations. + subroutine check_foams_options + ! Check options for liquid drainage in foam simulations. - character(len=OPTION_PATH_LEN) :: velocity_path, pressure_path, drainage_lambda_path, compressible_eos_path, foam_velocity_path - logical :: exclude_mass, equation_drainage, compressible_projection, prescribed_lambda, foam_eos, foam_velocity, Drainage_K1, Drainage_K2, source, absorption + character(len=OPTION_PATH_LEN) :: velocity_path, pressure_path, drainage_lambda_path, compressible_eos_path, foam_velocity_path + logical :: exclude_mass, equation_drainage, compressible_projection, prescribed_lambda, foam_eos, foam_velocity, Drainage_K1, Drainage_K2, source, absorption - ! Check that the local length of Plateau borders per unit volume (lambda) is provided. - compressible_eos_path="/material_phase[0]/equation_of_state/compressible" - foam_eos = have_option(trim(compressible_eos_path)//& - "/foam") - if(.not.(foam_eos)) then - FLExit("The first material_phase in a foam problem must have a foam equation of state.") - end if + ! Check that the local length of Plateau borders per unit volume (lambda) is provided. + compressible_eos_path="/material_phase[0]/equation_of_state/compressible" + foam_eos = have_option(trim(compressible_eos_path)//& + "/foam") + if(.not.(foam_eos)) then + FLExit("The first material_phase in a foam problem must have a foam equation of state.") + end if - pressure_path="/material_phase[0]/scalar_field::Pressure/prognostic" - if (have_option(trim(pressure_path))) then + pressure_path="/material_phase[0]/scalar_field::Pressure/prognostic" + if (have_option(trim(pressure_path))) then - ! Check that compressible projection method is used: - compressible_projection = have_option("/material_phase[0]"//& + ! Check that compressible projection method is used: + compressible_projection = have_option("/material_phase[0]"//& "/equation_of_state/compressible") - if(.not.(compressible_projection)) then - FLExit("For foam problems you need to use a compressible eos.") - end if - end if + if(.not.(compressible_projection)) then + FLExit("For foam problems you need to use a compressible eos.") + end if + end if - velocity_path="/material_phase[0]/vector_field::Velocity/prognostic" - if (have_option(trim(velocity_path))) then + velocity_path="/material_phase[0]/vector_field::Velocity/prognostic" + if (have_option(trim(velocity_path))) then - ! Check that the equation type for drainage of liquid in foams is selected: - equation_drainage = have_option(trim(velocity_path)//& + ! Check that the equation type for drainage of liquid in foams is selected: + equation_drainage = have_option(trim(velocity_path)//& "/equation::Drainage") - if(.not.(equation_drainage)) then - FLExit("For foam problems you need to select Drainage as your equation type.") - end if + if(.not.(equation_drainage)) then + FLExit("For foam problems you need to select Drainage as your equation type.") + end if - ! Check that the mass term is excluded: - exclude_mass = have_option(trim(velocity_path)//& + ! Check that the mass term is excluded: + exclude_mass = have_option(trim(velocity_path)//& "/spatial_discretisation& - &/continuous_galerkin/mass_terms& - &/exclude_mass_terms").or.& - have_option(trim(velocity_path)//& + &/continuous_galerkin/mass_terms& + &/exclude_mass_terms").or.& + have_option(trim(velocity_path)//& "/spatial_discretisation& - &/discontinuous_galerkin/mass_terms& - &/exclude_mass_terms") + &/discontinuous_galerkin/mass_terms& + &/exclude_mass_terms") - if(.not.(exclude_mass)) then - FLExit("For foam problems you need to exclude the mass term.") - end if + if(.not.(exclude_mass)) then + FLExit("For foam problems you need to exclude the mass term.") + end if - ! Check that source and absorption are provided: - source = have_option(trim(velocity_path)//& - "/vector_field::Source") + ! Check that source and absorption are provided: + source = have_option(trim(velocity_path)//& + "/vector_field::Source") - if(.not.(source)) then - FLExit("You need a velocity source term for foam simulations.") - end if + if(.not.(source)) then + FLExit("You need a velocity source term for foam simulations.") + end if - absorption = have_option(trim(velocity_path)//& - "/vector_field::Absorption") + absorption = have_option(trim(velocity_path)//& + "/vector_field::Absorption") - if(.not.(absorption)) then - FLExit("You need a velocity absorption term for foam simulations.") - end if + if(.not.(absorption)) then + FLExit("You need a velocity absorption term for foam simulations.") + end if - ! Check that K1 and K2 fields are provided: - Drainage_K1 = have_option(trim(velocity_path)//& - "/vector_field::DrainageK1") + ! Check that K1 and K2 fields are provided: + Drainage_K1 = have_option(trim(velocity_path)//& + "/vector_field::DrainageK1") - if(.not.(Drainage_K1)) then - FLExit("You need DrainageK1 vector field for foam simulations.") - end if + if(.not.(Drainage_K1)) then + FLExit("You need DrainageK1 vector field for foam simulations.") + end if - Drainage_K2 = have_option(trim(velocity_path)//& - "/scalar_field::DrainageK2") + Drainage_K2 = have_option(trim(velocity_path)//& + "/scalar_field::DrainageK2") - if(.not.(Drainage_K2)) then - FLExit("You need DrainageK2 scalar field for foam simulations.") - end if + if(.not.(Drainage_K2)) then + FLExit("You need DrainageK2 scalar field for foam simulations.") + end if - end if + end if - ! Check that there is a Foam Velocity field. - foam_velocity_path="/material_phase[0]/vector_field::FoamVelocity" - foam_velocity = have_option(trim(foam_velocity_path)//& - "/prescribed").or.& - have_option(trim(foam_velocity_path)//& - "/diagnostic") - if(.not.(foam_velocity)) then - FLExit("For foam simulations you need either a prescribed or a diagnostic Foam Velocity field.") - end if + ! Check that there is a Foam Velocity field. + foam_velocity_path="/material_phase[0]/vector_field::FoamVelocity" + foam_velocity = have_option(trim(foam_velocity_path)//& + "/prescribed").or.& + have_option(trim(foam_velocity_path)//& + "/diagnostic") + if(.not.(foam_velocity)) then + FLExit("For foam simulations you need either a prescribed or a diagnostic Foam Velocity field.") + end if - ! Check that the local length of Plateau borders per unit volume (lambda) is provided. - drainage_lambda_path="/material_phase[0]/scalar_field::DrainageLambda" - prescribed_lambda = have_option(trim(drainage_lambda_path)//& - "/prescribed") - if(.not.(prescribed_lambda)) then - FLExit("For foam simulations you need a DrainageLambda field which at the moment must be prescribed.") - end if + ! Check that the local length of Plateau borders per unit volume (lambda) is provided. + drainage_lambda_path="/material_phase[0]/scalar_field::DrainageLambda" + prescribed_lambda = have_option(trim(drainage_lambda_path)//& + "/prescribed") + if(.not.(prescribed_lambda)) then + FLExit("For foam simulations you need a DrainageLambda field which at the moment must be prescribed.") + end if - end subroutine check_foams_options + end subroutine check_foams_options - subroutine check_multiphase_options - !!< Options checking for multi-phase flow simulations. - ! This currently assumes that all phases have prognostic velocity fields; - ! we will deal with prescribed velocities later. + subroutine check_multiphase_options + !!< Options checking for multi-phase flow simulations. + ! This currently assumes that all phases have prognostic velocity fields; + ! we will deal with prescribed velocities later. - integer :: nmat, i - logical :: have_vfrac, prognostic_velocity + integer :: nmat, i + logical :: have_vfrac, prognostic_velocity - integer :: diagnostic_vfrac_count + integer :: diagnostic_vfrac_count - nmat = option_count("/material_phase") + nmat = option_count("/material_phase") - do i = 0, nmat-1 - have_vfrac = have_option("/material_phase["//int2str(i)//& + do i = 0, nmat-1 + have_vfrac = have_option("/material_phase["//int2str(i)//& "]/scalar_field::PhaseVolumeFraction") - prognostic_velocity = have_option("/material_phase["//int2str(i)//& + prognostic_velocity = have_option("/material_phase["//int2str(i)//& "]/vector_field::Velocity/prognostic") - if(prognostic_velocity .and. .not.have_vfrac) then - FLExit("All phases need a PhaseVolumeFraction.") - end if - end do - - diagnostic_vfrac_count = option_count(& - &'/material_phase/scalar_field::PhaseVolumeFraction/diagnostic') - if(diagnostic_vfrac_count > 1) then - ewrite(-1,*) diagnostic_vfrac_count, 'diagnostic PhaseVolumeFractions.' - FLExit("Only 1 diagnostic PhaseVolumeFraction is allowed") - end if - - end subroutine check_multiphase_options + if(prognostic_velocity .and. .not.have_vfrac) then + FLExit("All phases need a PhaseVolumeFraction.") + end if + end do + + diagnostic_vfrac_count = option_count(& + &'/material_phase/scalar_field::PhaseVolumeFraction/diagnostic') + if(diagnostic_vfrac_count > 1) then + ewrite(-1,*) diagnostic_vfrac_count, 'diagnostic PhaseVolumeFractions.' + FLExit("Only 1 diagnostic PhaseVolumeFraction is allowed") + end if + + end subroutine check_multiphase_options end module populate_state_module diff --git a/preprocessor/Populate_Sub_State.F90 b/preprocessor/Populate_Sub_State.F90 index eb9ea723df..b741d75c84 100644 --- a/preprocessor/Populate_Sub_State.F90 +++ b/preprocessor/Populate_Sub_State.F90 @@ -28,517 +28,517 @@ #include "fdebug.h" module populate_sub_state_module - use fldebug - use global_parameters, only: OPTION_PATH_LEN, is_active_process, pi, & -no_active_processes, topology_mesh_name, adaptivity_mesh_name, & -periodic_boundary_option_path, domain_bbox, domain_volume - use futils, only: int2str - use elements - use spud - use parallel_tools - use data_structures - use metric_tools - use transform_elements - use fields - use profiler - use state_module - use boundary_conditions, only: set_dirichlet_consistent - use mesh_files - use vtk_cache_module - use vtk_interfaces - use field_options - use reserve_state_module - use field_options - use halos_registration - use halos - use surfacelabels - use climatology - use coordinates - use tictoc - use hadapt_extrude - use nemo_states_module - use initialise_fields_module - use fefields - use boundary_conditions_from_options - use fields_halos - use read_triangle - use diagnostic_variables - use populate_state_module - - implicit none - - private - - public populate_sub_state, set_full_domain_prescribed_fields, & - & sub_state_remap_to_full_mesh, update_subdomain_fields, & - & use_sub_state, populate_sub_state_module_check_options + use fldebug + use global_parameters, only: OPTION_PATH_LEN, is_active_process, pi, & + no_active_processes, topology_mesh_name, adaptivity_mesh_name, & + periodic_boundary_option_path, domain_bbox, domain_volume + use futils, only: int2str + use elements + use spud + use parallel_tools + use data_structures + use metric_tools + use transform_elements + use fields + use profiler + use state_module + use boundary_conditions, only: set_dirichlet_consistent + use mesh_files + use vtk_cache_module + use vtk_interfaces + use field_options + use reserve_state_module + use field_options + use halos_registration + use halos + use surfacelabels + use climatology + use coordinates + use tictoc + use hadapt_extrude + use nemo_states_module + use initialise_fields_module + use fefields + use boundary_conditions_from_options + use fields_halos + use read_triangle + use diagnostic_variables + use populate_state_module + + implicit none + + private + + public populate_sub_state, set_full_domain_prescribed_fields, & + & sub_state_remap_to_full_mesh, update_subdomain_fields, & + & use_sub_state, populate_sub_state_module_check_options contains - subroutine populate_sub_state(states,sub_states) - ! This routine initialises all meshes, fields and boundary conditions - ! that will be used in partially prognostic solves - i.e. where certain - ! variables are only solved for in part of the computational domain. + subroutine populate_sub_state(states,sub_states) + ! This routine initialises all meshes, fields and boundary conditions + ! that will be used in partially prognostic solves - i.e. where certain + ! variables are only solved for in part of the computational domain. - type(state_type), intent(in), dimension(:) :: states - type(state_type), pointer, dimension(:) :: sub_states + type(state_type), intent(in), dimension(:) :: states + type(state_type), pointer, dimension(:) :: sub_states - integer :: nstates ! number of states - integer :: istate + integer :: nstates ! number of states + integer :: istate - ewrite(1,*) "In populate_sub_state" - call profiler_tic("I/O") - call tictoc_clear(TICTOC_ID_IO_READ) + ewrite(1,*) "In populate_sub_state" + call profiler_tic("I/O") + call tictoc_clear(TICTOC_ID_IO_READ) - ! Find out how many states there are and initialise: - nstates=size(states) - allocate(sub_states(1:nstates)) - do istate = 1, nstates - call nullify(sub_states(istate)) - sub_states(istate)%option_path = states(istate)%option_path - end do + ! Find out how many states there are and initialise: + nstates=size(states) + allocate(sub_states(1:nstates)) + do istate = 1, nstates + call nullify(sub_states(istate)) + sub_states(istate)%option_path = states(istate)%option_path + end do - ! Form subdomain external mesh from full state: - call derive_external_subdomain_mesh(states,sub_states) + ! Form subdomain external mesh from full state: + call derive_external_subdomain_mesh(states,sub_states) - ! Derive other subdomain meshes from subdomain external mesh: - call insert_derived_meshes(sub_states) + ! Derive other subdomain meshes from subdomain external mesh: + call insert_derived_meshes(sub_states) - ! Determine mapping functions for derived meshes, to and from full mesh: - call insert_subdomain_mesh_maps(states,sub_states) + ! Determine mapping functions for derived meshes, to and from full mesh: + call insert_subdomain_mesh_maps(states,sub_states) - call allocate_and_insert_fields(sub_states) + call allocate_and_insert_fields(sub_states) - call populate_boundary_conditions(sub_states, suppress_warnings=.true.) + call populate_boundary_conditions(sub_states, suppress_warnings=.true.) - call set_boundary_conditions_values(sub_states) + call set_boundary_conditions_values(sub_states) - call set_dirichlet_consistent(sub_states) + call set_dirichlet_consistent(sub_states) - call alias_fields(sub_states) + call alias_fields(sub_states) - call allocate_and_insert_auxilliary_fields(sub_states) + call allocate_and_insert_auxilliary_fields(sub_states) - ! Update field values in subdomain from state values: - call update_subdomain_fields(states,sub_states) + ! Update field values in subdomain from state values: + call update_subdomain_fields(states,sub_states) - ! Set prescribed fields on full mesh: - call set_full_domain_prescribed_fields(states) + ! Set prescribed fields on full mesh: + call set_full_domain_prescribed_fields(states) - call tictoc_report(2, TICTOC_ID_IO_READ) - call profiler_toc("I/O") - ewrite(1, *) "Exiting populate_sub_state" + call tictoc_report(2, TICTOC_ID_IO_READ) + call profiler_toc("I/O") + ewrite(1, *) "Exiting populate_sub_state" - end subroutine populate_sub_state + end subroutine populate_sub_state - logical function use_sub_state() - ! Routine to determine whether or not sub_state is set up: + logical function use_sub_state() + ! Routine to determine whether or not sub_state is set up: - integer :: number_of_prescribed_regions + integer :: number_of_prescribed_regions - number_of_prescribed_regions = option_count("/material_phase/vector_field::Velocity/prognostic/prescribed_region") + number_of_prescribed_regions = option_count("/material_phase/vector_field::Velocity/prognostic/prescribed_region") - use_sub_state = (number_of_prescribed_regions > 0) + use_sub_state = (number_of_prescribed_regions > 0) - end function use_sub_state + end function use_sub_state - subroutine derive_external_subdomain_mesh(states,sub_states) + subroutine derive_external_subdomain_mesh(states,sub_states) - ! This routine derives a subdomain mesh equivalent - ! to the externally derived mesh. This is later used as a basis - ! for deriving all other meshes on the prognostic subdomain. + ! This routine derives a subdomain mesh equivalent + ! to the externally derived mesh. This is later used as a basis + ! for deriving all other meshes on the prognostic subdomain. - type(state_type), intent(in), dimension(:) :: states - type(state_type), intent(inout), dimension(:) :: sub_states + type(state_type), intent(in), dimension(:) :: states + type(state_type), intent(inout), dimension(:) :: sub_states - ! Integer sets containing list of elements on subdomain_mesh: - type(integer_set) :: subdomain_element_set - ! same thing as list - integer, dimension(:), pointer :: subele_list - ! list of nodes in subdomain - integer, dimension(:), pointer :: node_list + ! Integer sets containing list of elements on subdomain_mesh: + type(integer_set) :: subdomain_element_set + ! same thing as list + integer, dimension(:), pointer :: subele_list + ! list of nodes in subdomain + integer, dimension(:), pointer :: node_list - ! External mesh and subdomain_meshes: - type(mesh_type) :: subdomain_mesh - type(mesh_type), pointer :: external_mesh - character(len=FIELD_NAME_LEN) :: mesh_name + ! External mesh and subdomain_meshes: + type(mesh_type) :: subdomain_mesh + type(mesh_type), pointer :: external_mesh + character(len=FIELD_NAME_LEN) :: mesh_name - ! Others: - integer, dimension(2) :: prescribed_regions_shape - integer :: number_of_prescribed_regions - type(integer_set) :: prescribed_region_id_set - integer, dimension(:), allocatable :: prescribed_region_ids + ! Others: + integer, dimension(2) :: prescribed_regions_shape + integer :: number_of_prescribed_regions + type(integer_set) :: prescribed_region_id_set + integer, dimension(:), allocatable :: prescribed_region_ids - type(vector_field), pointer :: external_mesh_position - type(vector_field) :: position + type(vector_field), pointer :: external_mesh_position + type(vector_field) :: position - type(vector_field), pointer :: velocity - integer :: ele, i + type(vector_field), pointer :: velocity + integer :: ele, i - ewrite(1,*) "Entering derive external subdomain mesh" + ewrite(1,*) "Entering derive external subdomain mesh" - ! Create subdomain_meshes -- begin with external mesh as we must add faces etc... to this before - ! deriving other meshes: + ! Create subdomain_meshes -- begin with external mesh as we must add faces etc... to this before + ! deriving other meshes: - external_mesh => get_external_mesh(states) - mesh_name = external_mesh%name + external_mesh => get_external_mesh(states) + mesh_name = external_mesh%name - velocity => extract_vector_field(states(1),"Velocity") + velocity => extract_vector_field(states(1),"Velocity") - number_of_prescribed_regions = & + number_of_prescribed_regions = & option_count(trim(velocity%option_path)// "/prognostic/prescribed_region") - ewrite(2,*) 'Number of prescribed_regions',number_of_prescribed_regions - - call allocate(prescribed_region_id_set) - do i = 1, number_of_prescribed_regions - prescribed_regions_shape = option_shape(trim(velocity%option_path)// & - "/prognostic/prescribed_region["//int2str(i-1)//"]/region_ids") - allocate(prescribed_region_ids(prescribed_regions_shape(1))) - call get_option(trim(velocity%option_path)// & - "/prognostic/prescribed_region["//int2str(i-1)//"]/region_ids", prescribed_region_ids) - - call insert(prescribed_region_id_set, prescribed_region_ids) - - deallocate(prescribed_region_ids) - end do - - ! failing this may be caused by not preserving region ids in adaptivity - see options check below - assert(associated(external_mesh%region_ids)) - - ! Derive subdomain_element_set - call allocate(subdomain_element_set) - do ele = 1, element_count(external_mesh) - if(.not.has_value(prescribed_region_id_set, external_mesh%region_ids(ele))) then - call insert(subdomain_element_set,ele) - end if - end do - ! convert to array: - allocate(subele_list(key_count(subdomain_element_set))) ! Map from sub mesh --> full mesh - subele_list = set2vector(subdomain_element_set) - - call create_subdomain_mesh(external_mesh, subele_list, mesh_name, subdomain_mesh, node_list) - - ! Store subdomain_mesh element list, node list as mesh attributes: - allocate(subdomain_mesh%subdomain_mesh) - subdomain_mesh%subdomain_mesh%element_list => subele_list - subdomain_mesh%subdomain_mesh%node_list => node_list - - ! Insert mesh and position fields for subdomain_mesh into sub_states: - if(mesh_name=="CoordinateMesh") then - external_mesh_position => extract_vector_field(states(1), "Coordinate") - else - external_mesh_position => extract_vector_field(states(1), trim(mesh_name)//"Coordinate") - end if + ewrite(2,*) 'Number of prescribed_regions',number_of_prescribed_regions + + call allocate(prescribed_region_id_set) + do i = 1, number_of_prescribed_regions + prescribed_regions_shape = option_shape(trim(velocity%option_path)// & + "/prognostic/prescribed_region["//int2str(i-1)//"]/region_ids") + allocate(prescribed_region_ids(prescribed_regions_shape(1))) + call get_option(trim(velocity%option_path)// & + "/prognostic/prescribed_region["//int2str(i-1)//"]/region_ids", prescribed_region_ids) + + call insert(prescribed_region_id_set, prescribed_region_ids) + + deallocate(prescribed_region_ids) + end do + + ! failing this may be caused by not preserving region ids in adaptivity - see options check below + assert(associated(external_mesh%region_ids)) + + ! Derive subdomain_element_set + call allocate(subdomain_element_set) + do ele = 1, element_count(external_mesh) + if(.not.has_value(prescribed_region_id_set, external_mesh%region_ids(ele))) then + call insert(subdomain_element_set,ele) + end if + end do + ! convert to array: + allocate(subele_list(key_count(subdomain_element_set))) ! Map from sub mesh --> full mesh + subele_list = set2vector(subdomain_element_set) + + call create_subdomain_mesh(external_mesh, subele_list, mesh_name, subdomain_mesh, node_list) + + ! Store subdomain_mesh element list, node list as mesh attributes: + allocate(subdomain_mesh%subdomain_mesh) + subdomain_mesh%subdomain_mesh%element_list => subele_list + subdomain_mesh%subdomain_mesh%node_list => node_list + + ! Insert mesh and position fields for subdomain_mesh into sub_states: + if(mesh_name=="CoordinateMesh") then + external_mesh_position => extract_vector_field(states(1), "Coordinate") + else + external_mesh_position => extract_vector_field(states(1), trim(mesh_name)//"Coordinate") + end if - call allocate(position, mesh_dim(subdomain_mesh), subdomain_mesh, trim(external_mesh_position%name)) + call allocate(position, mesh_dim(subdomain_mesh), subdomain_mesh, trim(external_mesh_position%name)) - call remap_to_subdomain(external_mesh_position, position) + call remap_to_subdomain(external_mesh_position, position) - ewrite(2,*) 'MinMax info for subdomain_mesh positions_field: ' - ewrite_minmax(position) + ewrite(2,*) 'MinMax info for subdomain_mesh positions_field: ' + ewrite_minmax(position) - ! Load into sub_states: - call insert(sub_states, subdomain_mesh, subdomain_mesh%name) - call insert(sub_states, position, position%name) + ! Load into sub_states: + call insert(sub_states, subdomain_mesh, subdomain_mesh%name) + call insert(sub_states, position, position%name) - ! If parallel, verify substate halos: - call verify_halos(position) + ! If parallel, verify substate halos: + call verify_halos(position) - ! Clean up: - call deallocate(subdomain_mesh) - call deallocate(position) + ! Clean up: + call deallocate(subdomain_mesh) + call deallocate(position) - call deallocate(subdomain_element_set) - call deallocate(prescribed_region_id_set) + call deallocate(subdomain_element_set) + call deallocate(prescribed_region_id_set) - ewrite(1,*) "Leaving derive external subdomain mesh" + ewrite(1,*) "Leaving derive external subdomain mesh" - end subroutine derive_external_subdomain_mesh + end subroutine derive_external_subdomain_mesh - subroutine insert_subdomain_mesh_maps(states,sub_states) - !! Forms mapping functions for subdomain derived meshes: - type(state_type), intent(in), dimension(:) :: states - type(state_type), intent(inout), dimension(:) :: sub_states + subroutine insert_subdomain_mesh_maps(states,sub_states) + !! Forms mapping functions for subdomain derived meshes: + type(state_type), intent(in), dimension(:) :: states + type(state_type), intent(inout), dimension(:) :: sub_states - ! Externally created mesh: - type(mesh_type), pointer :: external_mesh - ! Meshes on full domain / subdomain: - type(mesh_type), pointer :: full_mesh, subdomain_mesh - ! List of elements in subdomain: - integer, dimension(:), pointer :: subele_list - ! Integer array with this list of nodes: - integer, dimension(:), allocatable :: node_list - ! List of element nodes: - integer, dimension(:), pointer :: nodesf, nodess + ! Externally created mesh: + type(mesh_type), pointer :: external_mesh + ! Meshes on full domain / subdomain: + type(mesh_type), pointer :: full_mesh, subdomain_mesh + ! List of elements in subdomain: + integer, dimension(:), pointer :: subele_list + ! Integer array with this list of nodes: + integer, dimension(:), allocatable :: node_list + ! List of element nodes: + integer, dimension(:), pointer :: nodesf, nodess - ! Other declarations: - integer :: nmeshes, imesh, ele, i, inode + ! Other declarations: + integer :: nmeshes, imesh, ele, i, inode - ewrite(1,*) "In insert_subdomain_mesh_maps" + ewrite(1,*) "In insert_subdomain_mesh_maps" - ! Extract sub mesh of external mesh from sub_state: - external_mesh => get_external_mesh(sub_states) + ! Extract sub mesh of external mesh from sub_state: + external_mesh => get_external_mesh(sub_states) - ! List of element on sub domain_mesh: - subele_list => external_mesh%subdomain_mesh%element_list + ! List of element on sub domain_mesh: + subele_list => external_mesh%subdomain_mesh%element_list - ! Get number of meshes - nmeshes=mesh_count(states(1)) + ! Get number of meshes + nmeshes=mesh_count(states(1)) - ! Loop over meshes and derive list of nodes: - do imesh = 1, nmeshes + ! Loop over meshes and derive list of nodes: + do imesh = 1, nmeshes - full_mesh => extract_mesh(states(1),imesh) + full_mesh => extract_mesh(states(1),imesh) - if(have_option(trim(full_mesh%option_path)// "/from_mesh")) then + if(have_option(trim(full_mesh%option_path)// "/from_mesh")) then - subdomain_mesh => extract_mesh(sub_states(1), imesh) + subdomain_mesh => extract_mesh(sub_states(1), imesh) - ! Allocate subdomain_mesh attributes: - allocate(subdomain_mesh%subdomain_mesh) - allocate(subdomain_mesh%subdomain_mesh%element_list(size(subele_list))) + ! Allocate subdomain_mesh attributes: + allocate(subdomain_mesh%subdomain_mesh) + allocate(subdomain_mesh%subdomain_mesh%element_list(size(subele_list))) - ! Set subdomain_mesh's element list attribute: - subdomain_mesh%subdomain_mesh%element_list = subele_list + ! Set subdomain_mesh's element list attribute: + subdomain_mesh%subdomain_mesh%element_list = subele_list - ! Allocate subdomain_mesh's node list and set up: - allocate(subdomain_mesh%subdomain_mesh%node_list(node_count(subdomain_mesh))) - allocate(node_list(node_count(subdomain_mesh))) + ! Allocate subdomain_mesh's node list and set up: + allocate(subdomain_mesh%subdomain_mesh%node_list(node_count(subdomain_mesh))) + allocate(node_list(node_count(subdomain_mesh))) - do ele = 1, size(subele_list) - nodess => ele_nodes(subdomain_mesh,ele) ! List of element nodes on subdomain_mesh - nodesf => ele_nodes(full_mesh,subele_list(ele)) ! Corresponding list on global_mesh - do inode = 1, size(nodess) - node_list(nodess(inode)) = nodesf(inode) - end do - end do + do ele = 1, size(subele_list) + nodess => ele_nodes(subdomain_mesh,ele) ! List of element nodes on subdomain_mesh + nodesf => ele_nodes(full_mesh,subele_list(ele)) ! Corresponding list on global_mesh + do inode = 1, size(nodess) + node_list(nodess(inode)) = nodesf(inode) + end do + end do - ! Store in subdomain mesh node_list attribute: - subdomain_mesh%subdomain_mesh%node_list = node_list + ! Store in subdomain mesh node_list attribute: + subdomain_mesh%subdomain_mesh%node_list = node_list - deallocate(node_list) + deallocate(node_list) - ! Insert into all sub_states: - do i = 2, size(sub_states) - call insert(sub_states(i), subdomain_mesh, trim(subdomain_mesh%name)) - end do + ! Insert into all sub_states: + do i = 2, size(sub_states) + call insert(sub_states(i), subdomain_mesh, trim(subdomain_mesh%name)) + end do - end if + end if - end do + end do - ewrite(1,*) "Leaving insert_subdomain_mesh_maps" + ewrite(1,*) "Leaving insert_subdomain_mesh_maps" - end subroutine insert_subdomain_mesh_maps + end subroutine insert_subdomain_mesh_maps - subroutine update_subdomain_fields(states,sub_states) + subroutine update_subdomain_fields(states,sub_states) - ! This routine updates fields on the prognostic subdomain - ! in partially prognostic simulations: + ! This routine updates fields on the prognostic subdomain + ! in partially prognostic simulations: - type(state_type), intent(in), dimension(:) :: states - type(state_type), intent(inout), dimension(:) :: sub_states + type(state_type), intent(in), dimension(:) :: states + type(state_type), intent(inout), dimension(:) :: sub_states - ! Full domain and subdomain fields: - type(scalar_field), pointer :: sfield, sfield_sub - type(vector_field), pointer :: vfield, vfield_sub - type(tensor_field), pointer :: tfield, tfield_sub + ! Full domain and subdomain fields: + type(scalar_field), pointer :: sfield, sfield_sub + type(vector_field), pointer :: vfield, vfield_sub + type(tensor_field), pointer :: tfield, tfield_sub - ! Other declarations: - integer :: nstates, nsfields, nvfields, ntfields - integer :: istate, ifield, stat + ! Other declarations: + integer :: nstates, nsfields, nvfields, ntfields + integer :: istate, ifield, stat - ewrite(1,*) "Entering update_subdomain_fields" + ewrite(1,*) "Entering update_subdomain_fields" - ! How many states exist? - nstates = size(states) + ! How many states exist? + nstates = size(states) - ! Loop over states: - do istate = 1, nstates + ! Loop over states: + do istate = 1, nstates - ! Loop over fields (scalar, vector, tensor) in order. - ! Start with scalar fields: - nsfields = scalar_field_count(sub_states(istate)) - do ifield = 1, nsfields - ! Extract subdomain field from sub_state: - sfield_sub => extract_scalar_field(sub_states(istate),ifield) - if(.not. aliased(sfield_sub)) then - ! Extract full domain field from State: - sfield => extract_scalar_field(states(istate),trim(sfield_sub%name), stat=stat) - if(stat==0) then - ! Zero: - call zero(sfield_sub) - ! Then remap: - call remap_to_subdomain(sfield,sfield_sub) + ! Loop over fields (scalar, vector, tensor) in order. + ! Start with scalar fields: + nsfields = scalar_field_count(sub_states(istate)) + do ifield = 1, nsfields + ! Extract subdomain field from sub_state: + sfield_sub => extract_scalar_field(sub_states(istate),ifield) + if(.not. aliased(sfield_sub)) then + ! Extract full domain field from State: + sfield => extract_scalar_field(states(istate),trim(sfield_sub%name), stat=stat) + if(stat==0) then + ! Zero: + call zero(sfield_sub) + ! Then remap: + call remap_to_subdomain(sfield,sfield_sub) + end if end if - end if - end do - - ! Vector fields: - nvfields = vector_field_count(sub_states(istate)) - do ifield = 1, nvfields - vfield_sub => extract_vector_field(sub_states(istate),ifield) - if(.not. aliased(vfield_sub)) then - vfield => extract_vector_field(states(istate), trim(vfield_sub%name), stat=stat) - if(stat==0) then - call zero(vfield_sub) - call remap_to_subdomain(vfield,vfield_sub) + end do + + ! Vector fields: + nvfields = vector_field_count(sub_states(istate)) + do ifield = 1, nvfields + vfield_sub => extract_vector_field(sub_states(istate),ifield) + if(.not. aliased(vfield_sub)) then + vfield => extract_vector_field(states(istate), trim(vfield_sub%name), stat=stat) + if(stat==0) then + call zero(vfield_sub) + call remap_to_subdomain(vfield,vfield_sub) + end if end if - end if - end do - - ! Tensor fields: - ntfields = tensor_field_count(sub_states(istate)) - do ifield = 1, ntfields - tfield_sub => extract_tensor_field(sub_states(istate),ifield) - if(.not. aliased(tfield_sub)) then - tfield => extract_tensor_field(states(istate),trim(tfield_sub%name), stat=stat) - if(stat==0) then - call zero(tfield_sub) - call remap_to_subdomain(tfield,tfield_sub) + end do + + ! Tensor fields: + ntfields = tensor_field_count(sub_states(istate)) + do ifield = 1, ntfields + tfield_sub => extract_tensor_field(sub_states(istate),ifield) + if(.not. aliased(tfield_sub)) then + tfield => extract_tensor_field(states(istate),trim(tfield_sub%name), stat=stat) + if(stat==0) then + call zero(tfield_sub) + call remap_to_subdomain(tfield,tfield_sub) + end if end if - end if - end do + end do - end do + end do - ewrite(1,*) "Leaving update_subdomain_fields" + ewrite(1,*) "Leaving update_subdomain_fields" - end subroutine update_subdomain_fields + end subroutine update_subdomain_fields - subroutine set_full_domain_prescribed_fields(states,time) - !! Initialises prescribed fields in prescribed - !! regions of domain (i.e. in full state): + subroutine set_full_domain_prescribed_fields(states,time) + !! Initialises prescribed fields in prescribed + !! regions of domain (i.e. in full state): - !! Note currently only set up for vector field velocity + !! Note currently only set up for vector field velocity - type(state_type), dimension(:), intent(in):: states + type(state_type), dimension(:), intent(in):: states - type(vector_field), pointer :: vfield - type(vector_field), pointer :: position - !! current time if not using that in the options tree - real, intent(in), optional :: time + type(vector_field), pointer :: vfield + type(vector_field), pointer :: position + !! current time if not using that in the options tree + real, intent(in), optional :: time - integer :: istate, ifield, nstates, nvfields + integer :: istate, ifield, nstates, nvfields - ewrite(1,*) 'Setting full domain prescribed fields' + ewrite(1,*) 'Setting full domain prescribed fields' - ! Determine number of states: - nstates = size(states) + ! Determine number of states: + nstates = size(states) - ! Loop over states: - do istate = 1, nstates + ! Loop over states: + do istate = 1, nstates - ! Deal with vector fields: - nvfields = vector_field_count(states(istate)) + ! Deal with vector fields: + nvfields = vector_field_count(states(istate)) - do ifield = 1, nvfields + do ifield = 1, nvfields - vfield => extract_vector_field(states(istate), ifield) + vfield => extract_vector_field(states(istate), ifield) - ! At present this only works for velocity: - if (have_option(trim(vfield%option_path)// "/prognostic/prescribed_region") .and. & + ! At present this only works for velocity: + if (have_option(trim(vfield%option_path)// "/prognostic/prescribed_region") .and. & .not. aliased(vfield) ) then - position => get_external_coordinate_field(states(istate), vfield%mesh) + position => get_external_coordinate_field(states(istate), vfield%mesh) - call initialise_field_over_regions(vfield, & - trim(vfield%option_path)// "/prognostic/prescribed_region", & - position,time=time) + call initialise_field_over_regions(vfield, & + trim(vfield%option_path)// "/prognostic/prescribed_region", & + position,time=time) - end if - end do + end if + end do - end do + end do - ewrite(1,*) 'Finished setting full domain prescribed fields' + ewrite(1,*) 'Finished setting full domain prescribed fields' - end subroutine set_full_domain_prescribed_fields + end subroutine set_full_domain_prescribed_fields - subroutine sub_state_remap_to_full_mesh(states, sub_states) + subroutine sub_state_remap_to_full_mesh(states, sub_states) - ! Remap fields from subdomain to full mesh so that - ! full mesh prognostic fields that depend on submesh - ! variables can be solved. + ! Remap fields from subdomain to full mesh so that + ! full mesh prognostic fields that depend on submesh + ! variables can be solved. - type(state_type), dimension(:), intent(in):: states - type(state_type), dimension(:), intent(in):: sub_states + type(state_type), dimension(:), intent(in):: states + type(state_type), dimension(:), intent(in):: sub_states - type(scalar_field), pointer :: sfield, sfield_sub - type(vector_field), pointer :: vfield, vfield_sub - type(tensor_field), pointer :: tfield, tfield_sub + type(scalar_field), pointer :: sfield, sfield_sub + type(vector_field), pointer :: vfield, vfield_sub + type(tensor_field), pointer :: tfield, tfield_sub - integer :: istate, ifield, nstates, nsfields, nvfields, ntfields, stat + integer :: istate, ifield, nstates, nsfields, nvfields, ntfields, stat - ! Determine number of states: - nstates = size(states) - assert(size(states)==size(sub_states)) + ! Determine number of states: + nstates = size(states) + assert(size(states)==size(sub_states)) - ! Loop over states: - do istate = 1, nstates + ! Loop over states: + do istate = 1, nstates - ! Deal with scalar fields: - nsfields = scalar_field_count(states(istate)) + ! Deal with scalar fields: + nsfields = scalar_field_count(states(istate)) - do ifield = 1, nsfields + do ifield = 1, nsfields - sfield => extract_scalar_field(states(istate),ifield) - if(.not. aliased(sfield)) then - sfield_sub => extract_scalar_field(sub_states(istate), trim(sfield%name), stat=stat) - if(stat==0) then - call remap_to_full_domain(sfield_sub,sfield) + sfield => extract_scalar_field(states(istate),ifield) + if(.not. aliased(sfield)) then + sfield_sub => extract_scalar_field(sub_states(istate), trim(sfield%name), stat=stat) + if(stat==0) then + call remap_to_full_domain(sfield_sub,sfield) + end if end if - end if - end do + end do - ! Deal with vector fields: - nvfields = vector_field_count(states(istate)) + ! Deal with vector fields: + nvfields = vector_field_count(states(istate)) - do ifield = 1, nvfields + do ifield = 1, nvfields - vfield => extract_vector_field(states(istate), ifield) - if(.not. aliased(vfield)) then - vfield_sub => extract_vector_field(sub_states(istate), trim(vfield%name), stat=stat) - if(stat==0) then - call remap_to_full_domain(vfield_sub,vfield) + vfield => extract_vector_field(states(istate), ifield) + if(.not. aliased(vfield)) then + vfield_sub => extract_vector_field(sub_states(istate), trim(vfield%name), stat=stat) + if(stat==0) then + call remap_to_full_domain(vfield_sub,vfield) + end if end if - end if - end do + end do - ! Deal with tensor fields: - ntfields = tensor_field_count(states(istate)) + ! Deal with tensor fields: + ntfields = tensor_field_count(states(istate)) - do ifield = 1, ntfields + do ifield = 1, ntfields - tfield => extract_tensor_field(states(istate),ifield) - if(.not. aliased(tfield)) then - tfield_sub => extract_tensor_field(sub_states(istate), trim(tfield%name), stat=stat) - if(stat==0) then - call remap_to_full_domain(tfield_sub,tfield) + tfield => extract_tensor_field(states(istate),ifield) + if(.not. aliased(tfield)) then + tfield_sub => extract_tensor_field(sub_states(istate), trim(tfield%name), stat=stat) + if(stat==0) then + call remap_to_full_domain(tfield_sub,tfield) + end if end if - end if - end do + end do - end do + end do - end subroutine sub_state_remap_to_full_mesh + end subroutine sub_state_remap_to_full_mesh - subroutine populate_sub_state_module_check_options + subroutine populate_sub_state_module_check_options - if (option_count('/material_phase/vector_field::Velocity/prognostic/prescribed_region')>0) then + if (option_count('/material_phase/vector_field::Velocity/prognostic/prescribed_region')>0) then - if (have_option('/mesh_adaptivity/hr_adaptivity') .and. & - .not. have_option('/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions')) then + if (have_option('/mesh_adaptivity/hr_adaptivity') .and. & + .not. have_option('/mesh_adaptivity/hr_adaptivity/preserve_mesh_regions')) then - ewrite(0,*) "When using prescribed regions with mesh adaptivity:" - FLExit("Need /mesh_adaptivity/hr_adaptivity/preserve_mesh_regions option") + ewrite(0,*) "When using prescribed regions with mesh adaptivity:" + FLExit("Need /mesh_adaptivity/hr_adaptivity/preserve_mesh_regions option") - end if + end if - end if - end subroutine populate_sub_state_module_check_options + end if + end subroutine populate_sub_state_module_check_options end module populate_sub_state_module diff --git a/preprocessor/Reserve_State.F90 b/preprocessor/Reserve_State.F90 index a62e51e447..5d963d28fb 100644 --- a/preprocessor/Reserve_State.F90 +++ b/preprocessor/Reserve_State.F90 @@ -28,149 +28,149 @@ #include "fdebug.h" module reserve_state_module - !!< This module creates a reserve_state into which additional external meshes - !!< (other than CoordinateMesh) are put in. All the fields associated with - !!< them are also saved. After an adapt, all this information is reinserted - !!< into state + !!< This module creates a reserve_state into which additional external meshes + !!< (other than CoordinateMesh) are put in. All the fields associated with + !!< them are also saved. After an adapt, all this information is reinserted + !!< into state - use global_parameters, only: OPTION_PATH_LEN - use spud - use fields - use state_module + use global_parameters, only: OPTION_PATH_LEN + use spud + use fields + use state_module - implicit none + implicit none - private + private - type (state_type), dimension(:), save, allocatable :: reserve_state + type (state_type), dimension(:), save, allocatable :: reserve_state - public :: no_reserved_meshes, create_reserve_state, restore_reserved_meshes, & - & restore_reserved_fields, deallocate_reserve_state + public :: no_reserved_meshes, create_reserve_state, restore_reserved_meshes, & + & restore_reserved_fields, deallocate_reserve_state contains - function no_reserved_meshes() - logical :: no_reserved_meshes - - if(allocated(reserve_state)) then - no_reserved_meshes = mesh_count(reserve_state(1)) == 0 - else - no_reserved_meshes = .true. - end if - - end function no_reserved_meshes - - subroutine create_reserve_state(state) - !!< Create a reserve state, and point it to any additional meshes that were - !!< imported (not the CoordinateMesh), and any fields that are associated - !!< with them. exclude_from_mesh_adaptivity must be switched on for this to - !!< work. - - type (state_type), dimension(:), intent(in) :: state - - type (scalar_field) :: sfield - type (vector_field) :: vfield - type (tensor_field) :: tfield - type (mesh_type) :: mesh - integer i,j - - if(.not. allocated(reserve_state)) allocate(reserve_state(size(state))) - - !Loop over all meshes, insert those that are to be excluded into reserve_state - mesh_loop: do i = 1, mesh_count(state(1)) - mesh = extract_mesh(state(1), i) - if(have_option(trim(mesh%option_path) // "/exclude_from_mesh_adaptivity")) then - call insert(reserve_state, mesh, mesh%name) - end if - end do mesh_loop - - if(no_reserved_meshes()) return - - !Loop over states, inserting all fields that are associated with the meshes inserted in - !the previous mesh loop. - state_loop: do i = 1,size(state) - scalar_loop: do j = 1, scalar_field_count(state(i)) - sfield = extract_scalar_field(state(i), j) - if(has_mesh(reserve_state(i), sfield%mesh%name)) then - call insert(reserve_state(i), sfield, sfield%name) - end if - end do scalar_loop - vector_loop: do j = 1, vector_field_count(state(i)) - vfield = extract_vector_field(state(i), j) - if(has_mesh(reserve_state(i), vfield%mesh%name)) then - call insert(reserve_state(i), vfield, vfield%name) - end if - end do vector_loop - tensor_loop: do j = 1, tensor_field_count(state(i)) - tfield = extract_tensor_field(state(i), j) - if(has_mesh(reserve_state(i), tfield%mesh%name)) then - call insert(reserve_state(i), tfield, tfield%name) + function no_reserved_meshes() + logical :: no_reserved_meshes + + if(allocated(reserve_state)) then + no_reserved_meshes = mesh_count(reserve_state(1)) == 0 + else + no_reserved_meshes = .true. + end if + + end function no_reserved_meshes + + subroutine create_reserve_state(state) + !!< Create a reserve state, and point it to any additional meshes that were + !!< imported (not the CoordinateMesh), and any fields that are associated + !!< with them. exclude_from_mesh_adaptivity must be switched on for this to + !!< work. + + type (state_type), dimension(:), intent(in) :: state + + type (scalar_field) :: sfield + type (vector_field) :: vfield + type (tensor_field) :: tfield + type (mesh_type) :: mesh + integer i,j + + if(.not. allocated(reserve_state)) allocate(reserve_state(size(state))) + + !Loop over all meshes, insert those that are to be excluded into reserve_state + mesh_loop: do i = 1, mesh_count(state(1)) + mesh = extract_mesh(state(1), i) + if(have_option(trim(mesh%option_path) // "/exclude_from_mesh_adaptivity")) then + call insert(reserve_state, mesh, mesh%name) end if - end do tensor_loop - end do state_loop - - end subroutine create_reserve_state - - subroutine restore_reserved_meshes(state) - !!< This subroutine re-inserts the mesh information saved by reserve_state - !!< back into state. - - type (state_type) , intent(inout), dimension(:) :: state - type (mesh_type) :: mesh - integer i - - !if there are no associated meshes... skip this routine - if(no_reserved_meshes()) return - - !Loop over all meshes, reinserting them into state. - mesh_loop: do i = 1, mesh_count(reserve_state(1)) - mesh = extract_mesh(reserve_state(1), i) - call insert(state, mesh, mesh%name) - end do mesh_loop - - end subroutine restore_reserved_meshes - - subroutine restore_reserved_fields(state) - !!< This subroutine re-inserts the field information saved by reserve_state - !!< back into state. - - type (state_type) , intent(inout), dimension(:) :: state - type (scalar_field) :: sfield - type (vector_field) :: vfield - type (tensor_field) :: tfield - integer i,j - - !if there are no associated meshes... skip this routine - if (no_reserved_meshes()) return - - !Loop over reserve_state, reinserting all fields into state. - state_loop: do i = 1,size(reserve_state) - scalar_loop: do j = 1, scalar_field_count(reserve_state(i)) - sfield = extract_scalar_field(reserve_state(i), j) - call insert(state(i), sfield, sfield%name) - end do scalar_loop - vector_loop: do j = 1, vector_field_count(reserve_state(i)) - vfield = extract_vector_field(reserve_state(i), j) - call insert(state(i), vfield, vfield%name) - end do vector_loop - tensor_loop: do j = 1, tensor_field_count(reserve_state(i)) - tfield = extract_tensor_field(reserve_state(i), j) - call insert(state(i), tfield, tfield%name) - end do tensor_loop - end do state_loop - - end subroutine restore_reserved_fields - - subroutine deallocate_reserve_state() - integer i - - if(allocated(reserve_state)) then - do i=1,size(reserve_state) - call deallocate(reserve_state(i)) - end do - deallocate(reserve_state) - end if - - end subroutine deallocate_reserve_state + end do mesh_loop + + if(no_reserved_meshes()) return + + !Loop over states, inserting all fields that are associated with the meshes inserted in + !the previous mesh loop. + state_loop: do i = 1,size(state) + scalar_loop: do j = 1, scalar_field_count(state(i)) + sfield = extract_scalar_field(state(i), j) + if(has_mesh(reserve_state(i), sfield%mesh%name)) then + call insert(reserve_state(i), sfield, sfield%name) + end if + end do scalar_loop + vector_loop: do j = 1, vector_field_count(state(i)) + vfield = extract_vector_field(state(i), j) + if(has_mesh(reserve_state(i), vfield%mesh%name)) then + call insert(reserve_state(i), vfield, vfield%name) + end if + end do vector_loop + tensor_loop: do j = 1, tensor_field_count(state(i)) + tfield = extract_tensor_field(state(i), j) + if(has_mesh(reserve_state(i), tfield%mesh%name)) then + call insert(reserve_state(i), tfield, tfield%name) + end if + end do tensor_loop + end do state_loop + + end subroutine create_reserve_state + + subroutine restore_reserved_meshes(state) + !!< This subroutine re-inserts the mesh information saved by reserve_state + !!< back into state. + + type (state_type) , intent(inout), dimension(:) :: state + type (mesh_type) :: mesh + integer i + + !if there are no associated meshes... skip this routine + if(no_reserved_meshes()) return + + !Loop over all meshes, reinserting them into state. + mesh_loop: do i = 1, mesh_count(reserve_state(1)) + mesh = extract_mesh(reserve_state(1), i) + call insert(state, mesh, mesh%name) + end do mesh_loop + + end subroutine restore_reserved_meshes + + subroutine restore_reserved_fields(state) + !!< This subroutine re-inserts the field information saved by reserve_state + !!< back into state. + + type (state_type) , intent(inout), dimension(:) :: state + type (scalar_field) :: sfield + type (vector_field) :: vfield + type (tensor_field) :: tfield + integer i,j + + !if there are no associated meshes... skip this routine + if (no_reserved_meshes()) return + + !Loop over reserve_state, reinserting all fields into state. + state_loop: do i = 1,size(reserve_state) + scalar_loop: do j = 1, scalar_field_count(reserve_state(i)) + sfield = extract_scalar_field(reserve_state(i), j) + call insert(state(i), sfield, sfield%name) + end do scalar_loop + vector_loop: do j = 1, vector_field_count(reserve_state(i)) + vfield = extract_vector_field(reserve_state(i), j) + call insert(state(i), vfield, vfield%name) + end do vector_loop + tensor_loop: do j = 1, tensor_field_count(reserve_state(i)) + tfield = extract_tensor_field(reserve_state(i), j) + call insert(state(i), tfield, tfield%name) + end do tensor_loop + end do state_loop + + end subroutine restore_reserved_fields + + subroutine deallocate_reserve_state() + integer i + + if(allocated(reserve_state)) then + do i=1,size(reserve_state) + call deallocate(reserve_state(i)) + end do + deallocate(reserve_state) + end if + + end subroutine deallocate_reserve_state end module reserve_state_module diff --git a/preprocessor/Tidal_Modelling.F90 b/preprocessor/Tidal_Modelling.F90 index 98850206bb..5ef3de31eb 100644 --- a/preprocessor/Tidal_Modelling.F90 +++ b/preprocessor/Tidal_Modelling.F90 @@ -41,53 +41,53 @@ module Tidal_module private public :: find_chi, equilibrium_tide, get_tidal_frequency, & - &compute_pressure_and_tidal_gradient, & - &calculate_diagnostic_equilibrium_pressure,& - &calculate_shelf_depth + &compute_pressure_and_tidal_gradient, & + &calculate_diagnostic_equilibrium_pressure,& + &calculate_shelf_depth contains - function get_tidal_frequency(constituent) result(frequency) - character(len=*), intent(in)::constituent - real frequency - - ! Taken from E.W. Schwiderski - Rev. Geophys. Space Phys. Vol. 18 - ! No. 1 pp. 243--268, 1980 - select case(trim(constituent)) - case("M2") - if (have_option("/ocean_forcing/tidal_forcing/M2/frequency")) then - call get_option("/ocean_forcing/tidal_forcing/M2/frequency",frequency) - else - frequency = 1.40519E-04 - end if - case("S2") - frequency = 1.45444E-04 - case("N2") - frequency = 1.3788E-04 - case("K2") - frequency = 1.45842E-04 - case("K1") - frequency = 0.72921E-04 - case("O1") - frequency = 0.67598E-04 - case("P1") - frequency = 0.72523E-04 - case("Q1") - frequency = 0.64959E-04 - case("Mf") - frequency = 0.053234E-04 - case("Mm") - frequency = 0.026392E-04 - case("Ssa") - frequency = 0.003982E-04 - case default - write(0, *) "constituent = ", constituent - FLAbort("Unknown tidal constituent") - end select - - end function get_tidal_frequency - - SUBROUTINE FIND_CHI(CHI,NCHI,ACCTIM,HORIZ_RESCALE) + function get_tidal_frequency(constituent) result(frequency) + character(len=*), intent(in)::constituent + real frequency + + ! Taken from E.W. Schwiderski - Rev. Geophys. Space Phys. Vol. 18 + ! No. 1 pp. 243--268, 1980 + select case(trim(constituent)) + case("M2") + if (have_option("/ocean_forcing/tidal_forcing/M2/frequency")) then + call get_option("/ocean_forcing/tidal_forcing/M2/frequency",frequency) + else + frequency = 1.40519E-04 + end if + case("S2") + frequency = 1.45444E-04 + case("N2") + frequency = 1.3788E-04 + case("K2") + frequency = 1.45842E-04 + case("K1") + frequency = 0.72921E-04 + case("O1") + frequency = 0.67598E-04 + case("P1") + frequency = 0.72523E-04 + case("Q1") + frequency = 0.64959E-04 + case("Mf") + frequency = 0.053234E-04 + case("Mm") + frequency = 0.026392E-04 + case("Ssa") + frequency = 0.003982E-04 + case default + write(0, *) "constituent = ", constituent + FLAbort("Unknown tidal constituent") + end select + + end function get_tidal_frequency + + SUBROUTINE FIND_CHI(CHI,NCHI,ACCTIM,HORIZ_RESCALE) INTEGER NCHI,I REAL CHI(NCHI),ACCTIM,HORIZ_RESCALE,TIM @@ -156,12 +156,12 @@ SUBROUTINE FIND_CHI(CHI,NCHI,ACCTIM,HORIZ_RESCALE) CHI(12) = 0.0 !c Convert to Radians do I=1,NCHI ! Was loop - CHI(I) = CHI(I)/DEGRAD + CHI(I) = CHI(I)/DEGRAD ENDDO - END SUBROUTINE FIND_CHI + END SUBROUTINE FIND_CHI - FUNCTION equilibrium_tide(which_tide,LAT,LONG,ACCTIM,HORIZ_RESCALE) result(eqtide) + FUNCTION equilibrium_tide(which_tide,LAT,LONG,ACCTIM,HORIZ_RESCALE) result(eqtide) logical, dimension(11), intent(in) :: which_tide(11) REAL, intent(in) :: LAT,LONG,ACCTIM,HORIZ_RESCALE ! HORIZ_RESCALE is normally set to 1.0 @@ -194,14 +194,14 @@ FUNCTION equilibrium_tide(which_tide,LAT,LONG,ACCTIM,HORIZ_RESCALE) result(eqtid real, dimension(nchi) :: chi if (have_option("/ocean_forcing/tidal_forcing/M2/frequency")) then - call get_option("/ocean_forcing/tidal_forcing/M2/frequency", M2FREQ) + call get_option("/ocean_forcing/tidal_forcing/M2/frequency", M2FREQ) else - M2FREQ = 1.40519E-04 + M2FREQ = 1.40519E-04 end if if (have_option("/ocean_forcing/tidal_forcing/M2/amplitude")) then - call get_option("/ocean_forcing/tidal_forcing/M2/amplitude", M2AMP) + call get_option("/ocean_forcing/tidal_forcing/M2/amplitude", M2AMP) else - M2AMP = 0.242334 + M2AMP = 0.242334 end if eqtide = 0.0 @@ -211,10 +211,10 @@ FUNCTION equilibrium_tide(which_tide,LAT,LONG,ACCTIM,HORIZ_RESCALE) result(eqtid TIME = ACCTIM*HORIZ_RESCALE if (have_option('/ocean_forcing/tidal_forcing/chi')) then - ! Calculate chi - call FIND_CHI(chi, nchi, acctim, horiz_rescale) + ! Calculate chi + call FIND_CHI(chi, nchi, acctim, horiz_rescale) else - chi = 0 + chi = 0 end if @@ -257,25 +257,25 @@ FUNCTION equilibrium_tide(which_tide,LAT,LONG,ACCTIM,HORIZ_RESCALE) result(eqtid eqtide = eqtide + SsaAMP*(3*(SIN(COLAT)**2.0) -2.0)*COS(SsaFREQ*TIME + chi(11)) ENDIF - END FUNCTION EQUILIBRIUM_TIDE + END FUNCTION EQUILIBRIUM_TIDE - function calculate_shelf_depth(x) result (depth) - real, intent(in) :: x - real :: depth + function calculate_shelf_depth(x) result (depth) + real, intent(in) :: x + real :: depth ! TODO (asc): clean up these values - real :: shelflength = 500000 - real :: shelfslopeheight = 900 - real :: minoceandepth = 100 - real :: oceandepth = 1000 + real :: shelflength = 500000 + real :: shelfslopeheight = 900 + real :: minoceandepth = 100 + real :: oceandepth = 1000 - if (x .le. shelflength) then + if (x .le. shelflength) then depth = ( ((x/shelflength) * shelfslopeheight + minoceandepth) - oceandepth ) - else + else depth = 0.0 - end if - end function calculate_shelf_depth + end if + end function calculate_shelf_depth - subroutine calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure) + subroutine calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure) type(state_type), intent(inout) :: state type(scalar_field), intent(inout) :: equilibrium_pressure @@ -297,12 +297,12 @@ subroutine calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure positions => extract_vector_field(state, "Coordinate") if(positions%mesh == equilibrium_pressure%mesh) then - positions_mapped_to_equilibrium_pressure_space => positions + positions_mapped_to_equilibrium_pressure_space => positions else - allocate(positions_mapped_to_equilibrium_pressure_space) - call allocate(positions_mapped_to_equilibrium_pressure_space, positions%dim, & - & equilibrium_pressure%mesh, "CoordinateMappedToEquilibriumPressureSpace") - call remap_field(positions, positions_mapped_to_equilibrium_pressure_space) + allocate(positions_mapped_to_equilibrium_pressure_space) + call allocate(positions_mapped_to_equilibrium_pressure_space, positions%dim, & + & equilibrium_pressure%mesh, "CoordinateMappedToEquilibriumPressureSpace") + call remap_field(positions, positions_mapped_to_equilibrium_pressure_space) end if call get_option('/ocean_forcing/shelf/amplitude', ep_amplitude, default=1.0) @@ -332,9 +332,9 @@ subroutine calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure do node=1,node_count(positions_mapped_to_equilibrium_pressure_space) x = node_val(positions_mapped_to_equilibrium_pressure_space,node) if (x(1) .le. shelflength) then - shelfdepth = depthsign * ( ((x(1)/shelflength) * shelfslopeheight + minoceandepth) - oceandepth ) + shelfdepth = depthsign * ( ((x(1)/shelflength) * shelfslopeheight + minoceandepth) - oceandepth ) else - shelfdepth = 0.0 + shelfdepth = 0.0 end if if (include_density_change_of_ice) then ! TODO (asc): clean up these values @@ -352,13 +352,13 @@ subroutine calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure end do if(.not. positions%mesh == equilibrium_pressure%mesh) then - call deallocate(positions_mapped_to_equilibrium_pressure_space) - deallocate(positions_mapped_to_equilibrium_pressure_space) + call deallocate(positions_mapped_to_equilibrium_pressure_space) + deallocate(positions_mapped_to_equilibrium_pressure_space) end if - end subroutine calculate_diagnostic_equilibrium_pressure + end subroutine calculate_diagnostic_equilibrium_pressure - subroutine compute_pressure_and_tidal_gradient(state, delta_u, ct_m, p_theta, position) + subroutine compute_pressure_and_tidal_gradient(state, delta_u, ct_m, p_theta, position) ! computes gradient of pressure and tidal forcing term ! to be added to the momentum rhs type(state_type), intent(inout):: state @@ -394,7 +394,7 @@ subroutine compute_pressure_and_tidal_gradient(state, delta_u, ct_m, p_theta, po call incref(equilibrium_pressure) end if if (stat==0) then - call calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure) + call calculate_diagnostic_equilibrium_pressure(state, equilibrium_pressure) end if @@ -410,65 +410,65 @@ subroutine compute_pressure_and_tidal_gradient(state, delta_u, ct_m, p_theta, po which_tide=.true. else if (have_option('/ocean_forcing/tidal_forcing/M2')) & - & which_tide(1)=.true. + & which_tide(1)=.true. if (have_option('/ocean_forcing/tidal_forcing/S2')) & - & which_tide(2)=.true. + & which_tide(2)=.true. if (have_option('/ocean_forcing/tidal_forcing/N2')) & - & which_tide(3)=.true. + & which_tide(3)=.true. if (have_option('/ocean_forcing/tidal_forcing/K2')) & - & which_tide(4)=.true. + & which_tide(4)=.true. if (have_option('/ocean_forcing/tidal_forcing/K1')) & - & which_tide(5)=.true. + & which_tide(5)=.true. if (have_option('/ocean_forcing/tidal_forcing/O1')) & - & which_tide(6)=.true. + & which_tide(6)=.true. if (have_option('/ocean_forcing/tidal_forcing/P1')) & - & which_tide(7)=.true. + & which_tide(7)=.true. if (have_option('/ocean_forcing/tidal_forcing/Q1')) & - & which_tide(8)=.true. + & which_tide(8)=.true. if (have_option('/ocean_forcing/tidal_forcing/Mf')) & - & which_tide(9)=.true. + & which_tide(9)=.true. if (have_option('/ocean_forcing/tidal_forcing/Mm')) & - & which_tide(10)=.true. + & which_tide(10)=.true. if (have_option('/ocean_forcing/tidal_forcing/Ssa')) & - & which_tide(11)=.true. + & which_tide(11)=.true. end if if (have_option('/ocean_forcing/tidal_forcing/love_number'))& - & then - call get_option('/ocean_forcing/tidal_forcing/love_number/value', love_number) - else - love_number=1.0 - end if - - call get_option("/timestepping/current_time", current_time) - call get_option('/physical_parameters/gravity/magnitude',& - & gravity_magnitude) - ! Simple scalar Self-Attraction and Loading term (SAL) - call get_option('/ocean_forcing/tidal_forcing/sal/beta', beta, default=0.0) - - if (have_option('/ocean_forcing/tidal_forcing')) then - if (have_option('/geometry/spherical_earth/')) then - do node=1,node_count(positions_mapped_to_pressure_space) - call LongitudeLatitude(node_val(positions_mapped_to_pressure_space,node), long,& - & lat) - sal_term = node_val(free_surface,node)* beta - eqtide=equilibrium_tide(which_tide,lat*acos(-1.0)/180.0& - &,long*acos(-1.0)/180.0,current_time,1.0) - eqtide=love_number*eqtide - sal_term - call set(tidal_pressure, node, eqtide*gravity_magnitude) - end do - else - ewrite(-1,*) "Tidal forcing in non spherical geometries"//& - &"is yet to be added. Would you like "//& - &"to add this functionality?" - FLExit('Exiting as code missing') - end if - end if + & then + call get_option('/ocean_forcing/tidal_forcing/love_number/value', love_number) + else + love_number=1.0 + end if + + call get_option("/timestepping/current_time", current_time) + call get_option('/physical_parameters/gravity/magnitude',& + & gravity_magnitude) + ! Simple scalar Self-Attraction and Loading term (SAL) + call get_option('/ocean_forcing/tidal_forcing/sal/beta', beta, default=0.0) + + if (have_option('/ocean_forcing/tidal_forcing')) then + if (have_option('/geometry/spherical_earth/')) then + do node=1,node_count(positions_mapped_to_pressure_space) + call LongitudeLatitude(node_val(positions_mapped_to_pressure_space,node), long,& + & lat) + sal_term = node_val(free_surface,node)* beta + eqtide=equilibrium_tide(which_tide,lat*acos(-1.0)/180.0& + &,long*acos(-1.0)/180.0,current_time,1.0) + eqtide=love_number*eqtide - sal_term + call set(tidal_pressure, node, eqtide*gravity_magnitude) + end do + else + ewrite(-1,*) "Tidal forcing in non spherical geometries"//& + &"is yet to be added. Would you like "//& + &"to add this functionality?" + FLExit('Exiting as code missing') + end if + end if end if do node=1,node_count(positions_mapped_to_pressure_space) call set(combined_p, node, node_val(p_theta, node) - node_val(tidal_pressure, node)) call set(combined_p, node, node_val(p_theta, node) - node_val(tidal_pressure, node) & - & - node_val(equilibrium_pressure, node) ) + & - node_val(equilibrium_pressure, node) ) end do call mult_T(delta_u, ct_m, combined_p) @@ -478,6 +478,6 @@ subroutine compute_pressure_and_tidal_gradient(state, delta_u, ct_m, p_theta, po call deallocate(equilibrium_pressure) call deallocate(positions_mapped_to_pressure_space) - end subroutine compute_pressure_and_tidal_gradient + end subroutine compute_pressure_and_tidal_gradient end module Tidal_module diff --git a/preprocessor/VTK_Cache.F90 b/preprocessor/VTK_Cache.F90 index 0bb85bf457..03d364912e 100644 --- a/preprocessor/VTK_Cache.F90 +++ b/preprocessor/VTK_Cache.F90 @@ -30,183 +30,183 @@ !! in atomic calls where the state objects of vtu files that have been !! read before are cached. module vtk_cache_module -use fldebug -use fields -use state_module -use vtk_interfaces -implicit none + use fldebug + use fields + use state_module + use vtk_interfaces + implicit none ! the vtu states that have previously been read: ! the name of the state refers to the filename -type(state_type), dimension(:), pointer:: vtk_states_read => null() + type(state_type), dimension(:), pointer:: vtk_states_read => null() -private + private -public :: vtk_cache_finalise, vtk_cache_read_positions_field, & - & vtk_cache_read_scalar_field, vtk_cache_read_vector_field, & - & vtk_cache_read_tensor_field + public :: vtk_cache_finalise, vtk_cache_read_positions_field, & + & vtk_cache_read_scalar_field, vtk_cache_read_vector_field, & + & vtk_cache_read_tensor_field -interface vtk_cache_read_positions_field - module procedure vtk_cache_read_positions_field_unnamed, & - & vtk_cache_read_positions_field_named -end interface vtk_cache_read_positions_field + interface vtk_cache_read_positions_field + module procedure vtk_cache_read_positions_field_unnamed, & + & vtk_cache_read_positions_field_named + end interface vtk_cache_read_positions_field contains -subroutine vtk_cache_finalise() + subroutine vtk_cache_finalise() - integer:: i + integer:: i - if (.not. associated(vtk_states_read)) return + if (.not. associated(vtk_states_read)) return - do i=1, size(vtk_states_read) - call deallocate(vtk_states_read(i)) - end do + do i=1, size(vtk_states_read) + call deallocate(vtk_states_read(i)) + end do - deallocate( vtk_states_read ) - nullify(vtk_states_read) + deallocate( vtk_states_read ) + nullify(vtk_states_read) -end subroutine vtk_cache_finalise + end subroutine vtk_cache_finalise -function vtk_cache_read_file(filename) result(state) + function vtk_cache_read_file(filename) result(state) !! If not yet present in cache, reads vtu file to state and adds it !! to the cache. In either case returns a pointer to this state. -type(state_type), pointer:: state -character(len=*), intent(in):: filename + type(state_type), pointer:: state + character(len=*), intent(in):: filename - type(state_type), dimension(:), pointer:: vtk_states_old - integer:: stat, n + type(state_type), dimension(:), pointer:: vtk_states_old + integer:: stat, n - ! increase n/o states in cache by 1 and point state to last added - if (associated(vtk_states_read)) then - ! read already? - state => extract_state(vtk_states_read, filename, stat=stat) - if (stat==0) return + ! increase n/o states in cache by 1 and point state to last added + if (associated(vtk_states_read)) then + ! read already? + state => extract_state(vtk_states_read, filename, stat=stat) + if (stat==0) return - ! if not, add a new state - n=size(vtk_states_read) - vtk_states_old => vtk_states_read - allocate( vtk_states_read(1:n+1) ) - vtk_states_read(1:n)=vtk_states_old - deallocate(vtk_states_old) + ! if not, add a new state + n=size(vtk_states_read) + vtk_states_old => vtk_states_read + allocate( vtk_states_read(1:n+1) ) + vtk_states_read(1:n)=vtk_states_old + deallocate(vtk_states_old) - state => vtk_states_read(n+1) + state => vtk_states_read(n+1) - else - ! no read states yet, so create one - allocate( vtk_states_read(1) ) - state => vtk_states_read(1) - end if + else + ! no read states yet, so create one + allocate( vtk_states_read(1) ) + state => vtk_states_read(1) + end if - ewrite(1, *) "In vtk_cache_read_file, reading file: " // trim(filename) - call vtk_read_state(filename, state) - state%name=filename + ewrite(1, *) "In vtk_cache_read_file, reading file: " // trim(filename) + call vtk_read_state(filename, state) + state%name=filename -end function vtk_cache_read_file + end function vtk_cache_read_file -function vtk_cache_read_positions_field_unnamed(filename) result(positions) - !!< Searches cache for state read from vtu file filename, if not present reads - !!< vtu file and add to caches. Returns a pointer to the requested field. - !!< Borrows a references from the cached state, i.e. don't deallocate! + function vtk_cache_read_positions_field_unnamed(filename) result(positions) + !!< Searches cache for state read from vtu file filename, if not present reads + !!< vtu file and add to caches. Returns a pointer to the requested field. + !!< Borrows a references from the cached state, i.e. don't deallocate! - character(len = *), intent(in) :: filename + character(len = *), intent(in) :: filename - type(vector_field), pointer :: positions + type(vector_field), pointer :: positions - positions => vtk_cache_read_positions_field(filename, positions_fieldname = "Coordinate") + positions => vtk_cache_read_positions_field(filename, positions_fieldname = "Coordinate") -end function vtk_cache_read_positions_field_unnamed + end function vtk_cache_read_positions_field_unnamed -function vtk_cache_read_positions_field_named(filename, positions_fieldname) result(positions) - !!< Searches cache for state read from vtu file filename, if not present reads - !!< vtu file and add to caches. Returns a pointer to the requested field. - !!< Borrows a references from the cached state, i.e. don't deallocate! + function vtk_cache_read_positions_field_named(filename, positions_fieldname) result(positions) + !!< Searches cache for state read from vtu file filename, if not present reads + !!< vtu file and add to caches. Returns a pointer to the requested field. + !!< Borrows a references from the cached state, i.e. don't deallocate! - character(len = *), intent(in) :: filename - character(len = *), intent(in) :: positions_fieldname + character(len = *), intent(in) :: filename + character(len = *), intent(in) :: positions_fieldname - type(vector_field), pointer :: positions + type(vector_field), pointer :: positions - positions => vtk_cache_read_vector_field(filename, positions_fieldname) + positions => vtk_cache_read_vector_field(filename, positions_fieldname) -end function vtk_cache_read_positions_field_named + end function vtk_cache_read_positions_field_named -function vtk_cache_read_scalar_field(filename, fieldname) result(field) + function vtk_cache_read_scalar_field(filename, fieldname) result(field) !! Searches cache for state read from vtu file filename, if not present !! reads vtu file and adds to cache. Returns a pointer to the requested !! field. Borrows a reference from the cached state, i.e. don't deallocate! -type(scalar_field), pointer:: field -character(len=*), intent(in):: filename -character(len=*), intent(in):: fieldname + type(scalar_field), pointer:: field + character(len=*), intent(in):: filename + character(len=*), intent(in):: fieldname - type(state_type), pointer:: state - integer:: stat + type(state_type), pointer:: state + integer:: stat - ewrite(2,*) "vtk_cache_read_scalar_field - filename, fieldname: ", & - trim(filename), ", ", trim(fieldname) + ewrite(2,*) "vtk_cache_read_scalar_field - filename, fieldname: ", & + trim(filename), ", ", trim(fieldname) - state => vtk_cache_read_file(filename) + state => vtk_cache_read_file(filename) - field => extract_scalar_field(state, fieldname, stat=stat) - if (stat/=0) then - ewrite(-1,*) "In vtk_cache_read_scalar_field" - ewrite(-1,*) "filename: ", trim(filename) - ewrite(-1,*) "fieldname: ", trim(fieldname) - FLExit("Requested field is not in the vtu") - end if + field => extract_scalar_field(state, fieldname, stat=stat) + if (stat/=0) then + ewrite(-1,*) "In vtk_cache_read_scalar_field" + ewrite(-1,*) "filename: ", trim(filename) + ewrite(-1,*) "fieldname: ", trim(fieldname) + FLExit("Requested field is not in the vtu") + end if -end function vtk_cache_read_scalar_field + end function vtk_cache_read_scalar_field -function vtk_cache_read_vector_field(filename, fieldname) result(field) + function vtk_cache_read_vector_field(filename, fieldname) result(field) !! Searches cache for state read from vtu file filename, if not present !! reads vtu file and adds to cache. Returns a pointer to the requested !! field. Borrows a reference from the cached state, i.e. don't deallocate! -type(vector_field), pointer:: field -character(len=*), intent(in):: filename -character(len=*), intent(in):: fieldname + type(vector_field), pointer:: field + character(len=*), intent(in):: filename + character(len=*), intent(in):: fieldname - type(state_type), pointer:: state - integer:: stat + type(state_type), pointer:: state + integer:: stat - ewrite(2,*) "vtk_cache_read_vector_field - filename, fieldname: ", & - trim(filename), ", ", trim(fieldname) + ewrite(2,*) "vtk_cache_read_vector_field - filename, fieldname: ", & + trim(filename), ", ", trim(fieldname) - state => vtk_cache_read_file(filename) + state => vtk_cache_read_file(filename) - field => extract_vector_field(state, fieldname, stat=stat) - if (stat/=0) then - ewrite(-1,*) "In vtk_cache_read_vector_field" - ewrite(-1,*) "filename: ", trim(filename) - ewrite(-1,*) "fieldname: ", trim(fieldname) - FLExit("Requested field is not in the vtu") - end if + field => extract_vector_field(state, fieldname, stat=stat) + if (stat/=0) then + ewrite(-1,*) "In vtk_cache_read_vector_field" + ewrite(-1,*) "filename: ", trim(filename) + ewrite(-1,*) "fieldname: ", trim(fieldname) + FLExit("Requested field is not in the vtu") + end if -end function vtk_cache_read_vector_field + end function vtk_cache_read_vector_field -function vtk_cache_read_tensor_field(filename, fieldname) result(field) + function vtk_cache_read_tensor_field(filename, fieldname) result(field) !! Searches cache for state read from vtu file filename, if not present !! reads vtu file and adds to cache. Returns a pointer to the requested !! field. Borrows a reference from the cached state, i.e. don't deallocate! -type(tensor_field), pointer:: field -character(len=*), intent(in):: filename -character(len=*), intent(in):: fieldname + type(tensor_field), pointer:: field + character(len=*), intent(in):: filename + character(len=*), intent(in):: fieldname - type(state_type), pointer:: state - integer:: stat + type(state_type), pointer:: state + integer:: stat - ewrite(2,*) "vtk_cache_read_tensor_field - filename, fieldname: ", & - trim(filename), ", ", trim(fieldname) + ewrite(2,*) "vtk_cache_read_tensor_field - filename, fieldname: ", & + trim(filename), ", ", trim(fieldname) - state => vtk_cache_read_file(filename) + state => vtk_cache_read_file(filename) - field => extract_tensor_field(state, fieldname, stat=stat) - if (stat/=0) then - ewrite(-1,*) "In vtk_cache_read_tensor_field" - ewrite(-1,*) "filename: ", trim(filename) - ewrite(-1,*) "fieldname: ", trim(fieldname) - FLExit("Requested field is not in the vtu") - end if + field => extract_tensor_field(state, fieldname, stat=stat) + if (stat/=0) then + ewrite(-1,*) "In vtk_cache_read_tensor_field" + ewrite(-1,*) "filename: ", trim(filename) + ewrite(-1,*) "fieldname: ", trim(fieldname) + FLExit("Requested field is not in the vtu") + end if -end function vtk_cache_read_tensor_field + end function vtk_cache_read_tensor_field end module vtk_cache_module diff --git a/preprocessor/synthetic_bc.F90 b/preprocessor/synthetic_bc.F90 index cd07894007..c1b514d76b 100644 --- a/preprocessor/synthetic_bc.F90 +++ b/preprocessor/synthetic_bc.F90 @@ -29,42 +29,42 @@ module synthetic_bc -use fldebug -use spud -use global_parameters, only: dt, option_path_len -use elements -use mpi_interfaces -use parallel_tools -use transform_elements -use fetools -use fields -use state_module + use fldebug + use spud + use global_parameters, only: dt, option_path_len + use elements + use mpi_interfaces + use parallel_tools + use transform_elements + use fetools + use fields + use state_module -implicit none + implicit none -private -public synthetic_eddy_method, add_sem_bc, initialise_sem_memory + private + public synthetic_eddy_method, add_sem_bc, initialise_sem_memory -type eddy - !!< Store eddy info, for synthetic eddy method - real, dimension(:),pointer:: xeddy - real, dimension(:),pointer:: yeddy - real, dimension(:),pointer:: zeddy + type eddy + !!< Store eddy info, for synthetic eddy method + real, dimension(:),pointer:: xeddy + real, dimension(:),pointer:: yeddy + real, dimension(:),pointer:: zeddy - integer, dimension(:),pointer:: eu - integer, dimension(:),pointer:: ev - integer, dimension(:),pointer:: ew -end type eddy + integer, dimension(:),pointer:: eu + integer, dimension(:),pointer:: ev + integer, dimension(:),pointer:: ew + end type eddy -integer, save:: sem_bc_count=0 -type(eddy),dimension(:),pointer,save:: eddies + integer, save:: sem_bc_count=0 + type(eddy),dimension(:),pointer,save:: eddies contains - subroutine synthetic_eddy_method(surface_field, surface_field1, & - surface_field2, surface_field3, bc_position, bc_path_i, ns) + subroutine synthetic_eddy_method(surface_field, surface_field1, & + surface_field2, surface_field3, bc_position, bc_path_i, ns) ! declarations type(vector_field),intent(inout) :: surface_field @@ -523,11 +523,11 @@ subroutine synthetic_eddy_method(surface_field, surface_field1, & deallocate(ufl,vfl,wfl) ewrite(3,*) 'leaving turbulent inlet boundary conditions routine' - end subroutine synthetic_eddy_method + end subroutine synthetic_eddy_method - !---------------------------------------------------------- + !---------------------------------------------------------- - function esign() + function esign() integer :: esign real :: i @@ -535,50 +535,50 @@ function esign() call random_number(i) if (i<0.5) then - esign = -1 + esign = -1 else - esign = +1 + esign = +1 endif return - end function esign + end function esign - !---------------------------------------------------------- + !---------------------------------------------------------- - subroutine initialise_sem_memory(ns,nots) + subroutine initialise_sem_memory(ns,nots) - logical,save::initialise_memory=.false. - logical,allocatable,dimension(:),save::initeddymem - integer:: ns, nots, nsem + logical,save::initialise_memory=.false. + logical,allocatable,dimension(:),save::initeddymem + integer:: ns, nots, nsem - nsem=sem_bc_count + nsem=sem_bc_count - if(.not.initialise_memory)then - allocate(initeddymem(nsem)) - initeddymem=.true. - allocate(eddies(nsem)) - initialise_memory=.true. - endif + if(.not.initialise_memory)then + allocate(initeddymem(nsem)) + initeddymem=.true. + allocate(eddies(nsem)) + initialise_memory=.true. + endif - if(initeddymem(ns))then - allocate(eddies(ns)%xeddy(nots));allocate (eddies(ns)%yeddy(nots));allocate(eddies(ns)%zeddy(nots)) - allocate(eddies(ns)%eu(nots)) ;allocate(eddies(ns)%ev(nots)) ;allocate(eddies(ns)%ew(nots)) - initeddymem(ns)=.false. - endif + if(initeddymem(ns))then + allocate(eddies(ns)%xeddy(nots));allocate (eddies(ns)%yeddy(nots));allocate(eddies(ns)%zeddy(nots)) + allocate(eddies(ns)%eu(nots)) ;allocate(eddies(ns)%ev(nots)) ;allocate(eddies(ns)%ew(nots)) + initeddymem(ns)=.false. + endif - end subroutine initialise_sem_memory + end subroutine initialise_sem_memory - !---------------------------------------------------------- + !---------------------------------------------------------- - subroutine add_sem_bc(have_sem_bc) + subroutine add_sem_bc(have_sem_bc) - logical:: have_sem_bc + logical:: have_sem_bc - if (have_sem_bc) then - sem_bc_count=sem_bc_count+1 - end if + if (have_sem_bc) then + sem_bc_count=sem_bc_count+1 + end if - end subroutine add_sem_bc + end subroutine add_sem_bc - end module synthetic_bc +end module synthetic_bc diff --git a/sediments/Sediment.F90 b/sediments/Sediment.F90 index bd7f7ebbf8..a3a18883df 100644 --- a/sediments/Sediment.F90 +++ b/sediments/Sediment.F90 @@ -29,693 +29,693 @@ module sediment - use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN, dt, timestep - use fldebug - use futils, only: int2str, present_and_true - use vector_tools - use quadrature - use elements - use spud - use fetools - use fields - use state_module - use boundary_conditions - use field_derivatives - use sparse_matrices_fields - use state_fields_module - - implicit none - - private - public set_sediment_reentrainment, sediment_check_options, get_n_sediment_fields, & - & get_sediment_item, surface_horizontal_divergence - - interface get_sediment_item - module procedure get_sediment_field, get_sediment_field_name,& - & get_sediment_option_string, get_sediment_option_real,& - & get_sediment_option_scalar_field - end interface get_sediment_item + use global_parameters, only: OPTION_PATH_LEN, FIELD_NAME_LEN, dt, timestep + use fldebug + use futils, only: int2str, present_and_true + use vector_tools + use quadrature + use elements + use spud + use fetools + use fields + use state_module + use boundary_conditions + use field_derivatives + use sparse_matrices_fields + use state_fields_module + + implicit none + + private + public set_sediment_reentrainment, sediment_check_options, get_n_sediment_fields, & + & get_sediment_item, surface_horizontal_divergence + + interface get_sediment_item + module procedure get_sediment_field, get_sediment_field_name,& + & get_sediment_option_string, get_sediment_option_real,& + & get_sediment_option_scalar_field + end interface get_sediment_item contains - function get_n_sediment_fields() result (n_fields) + function get_n_sediment_fields() result (n_fields) - ! Returns the number of sediment fields - integer :: n_fields + ! Returns the number of sediment fields + integer :: n_fields - n_fields = option_count('/material_phase[0]/sediment/scalar_field') + n_fields = option_count('/material_phase[0]/sediment/scalar_field') - if (have_option('/material_phase[0]/sediment/scalar_field::SedimentBedActiveLayer& - &D50')) n_fields = n_fields - 1 - if (have_option('/material_phase[0]/sediment/scalar_field::SedimentBedActiveLayer& - &Sigma')) n_fields = n_fields - 1 - if (have_option('/material_phase[0]/sediment/scalar_field::ZeroSedimentConcentrat& - &ionViscosity')) n_fields = n_fields - 1 + if (have_option('/material_phase[0]/sediment/scalar_field::SedimentBedActiveLayer& + &D50')) n_fields = n_fields - 1 + if (have_option('/material_phase[0]/sediment/scalar_field::SedimentBedActiveLayer& + &Sigma')) n_fields = n_fields - 1 + if (have_option('/material_phase[0]/sediment/scalar_field::ZeroSedimentConcentrat& + &ionViscosity')) n_fields = n_fields - 1 - end function get_n_sediment_fields + end function get_n_sediment_fields - subroutine get_sediment_field(state, i_field, item, stat, old) + subroutine get_sediment_field(state, i_field, item, stat, old) - ! Returns sediment field pointer - type(state_type), intent(in) :: state - integer, intent(in) :: i_field - type(scalar_field), pointer, intent(out) :: item - integer, intent(out), optional :: stat - character(len=FIELD_NAME_LEN) :: name - logical, intent(in), optional :: old + ! Returns sediment field pointer + type(state_type), intent(in) :: state + integer, intent(in) :: i_field + type(scalar_field), pointer, intent(out) :: item + integer, intent(out), optional :: stat + character(len=FIELD_NAME_LEN) :: name + logical, intent(in), optional :: old - ! had to remove trim(state%option_path)// as this didn't work with flredecomp - call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& - & 1)//']/name', name) + ! had to remove trim(state%option_path)// as this didn't work with flredecomp + call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& + & 1)//']/name', name) - if (present_and_true(old)) then - name = "Old"//trim(name) - end if - item => extract_scalar_field(state, trim(name), stat) + if (present_and_true(old)) then + name = "Old"//trim(name) + end if + item => extract_scalar_field(state, trim(name), stat) - end subroutine get_sediment_field + end subroutine get_sediment_field - subroutine get_sediment_field_name(state, i_field, item, stat) + subroutine get_sediment_field_name(state, i_field, item, stat) - ! Returns sediment field string option - type(state_type), intent(in) :: state - integer, intent(in) :: i_field - character(len=FIELD_NAME_LEN), intent(out) :: item - integer, intent(out), optional :: stat + ! Returns sediment field string option + type(state_type), intent(in) :: state + integer, intent(in) :: i_field + character(len=FIELD_NAME_LEN), intent(out) :: item + integer, intent(out), optional :: stat - ! had to remove trim(state%option_path)// as this didn't work with flredecomp - call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& - & 1)//']/name', item, stat=stat) + ! had to remove trim(state%option_path)// as this didn't work with flredecomp + call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& + & 1)//']/name', item, stat=stat) - end subroutine get_sediment_field_name + end subroutine get_sediment_field_name - subroutine get_sediment_option_string(state, i_field, option, item, stat) + subroutine get_sediment_option_string(state, i_field, option, item, stat) - ! Returns sediment field string option - type(state_type), intent(in) :: state - integer, intent(in) :: i_field - character(len=*), intent(in) :: option - character(len=FIELD_NAME_LEN), intent(out) :: item - integer, intent(out), optional :: stat + ! Returns sediment field string option + type(state_type), intent(in) :: state + integer, intent(in) :: i_field + character(len=*), intent(in) :: option + character(len=FIELD_NAME_LEN), intent(out) :: item + integer, intent(out), optional :: stat - ! had to remove trim(state%option_path)// as this didn't work with flredecomp - call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& - & 1)//']/prognostic/'//option, item, stat=stat) + ! had to remove trim(state%option_path)// as this didn't work with flredecomp + call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& + & 1)//']/prognostic/'//option, item, stat=stat) - end subroutine get_sediment_option_string + end subroutine get_sediment_option_string - subroutine get_sediment_option_real(state, i_field, option, item, stat, default) + subroutine get_sediment_option_real(state, i_field, option, item, stat, default) - ! Returns sediment field real option - type(state_type), intent(in) :: state - integer, intent(in) :: i_field - character(len=*), intent(in) :: option - real, intent(out) :: item - integer, intent(out), optional :: stat - real, intent(in), optional :: default + ! Returns sediment field real option + type(state_type), intent(in) :: state + integer, intent(in) :: i_field + character(len=*), intent(in) :: option + real, intent(out) :: item + integer, intent(out), optional :: stat + real, intent(in), optional :: default - ! had to remove trim(state%option_path)// as this didn't work with flredecomp - call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& - & 1)//']/prognostic/'//option, item, stat = stat, default = default) + ! had to remove trim(state%option_path)// as this didn't work with flredecomp + call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& + & 1)//']/prognostic/'//option, item, stat = stat, default = default) - end subroutine get_sediment_option_real + end subroutine get_sediment_option_real - subroutine get_sediment_option_scalar_field(state, i_field, option, item, stat) + subroutine get_sediment_option_scalar_field(state, i_field, option, item, stat) - ! Returns sediment field related scalar field - type(state_type), intent(in) :: state - integer, intent(in) :: i_field - type(scalar_field), pointer, intent(out) :: item - character(len=*), intent(in) :: option - integer, intent(out), optional :: stat + ! Returns sediment field related scalar field + type(state_type), intent(in) :: state + integer, intent(in) :: i_field + type(scalar_field), pointer, intent(out) :: item + character(len=*), intent(in) :: option + integer, intent(out), optional :: stat - character(len=FIELD_NAME_LEN) :: field_name + character(len=FIELD_NAME_LEN) :: field_name - ! had to remove trim(state%option_path)// as this didn't work with flredecomp - call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& - & 1)//']/name', field_name) - item => extract_scalar_field(state, trim(field_name)//option, stat) + ! had to remove trim(state%option_path)// as this didn't work with flredecomp + call get_option('/material_phase[0]/sediment/scalar_field['//int2str(i_field -& + & 1)//']/name', field_name) + item => extract_scalar_field(state, trim(field_name)//option, stat) - end subroutine get_sediment_option_scalar_field + end subroutine get_sediment_option_scalar_field - subroutine set_sediment_reentrainment(state) + subroutine set_sediment_reentrainment(state) - type(state_type), intent(in) :: state - type(scalar_field), pointer :: sediment_field - integer :: i_field, i_bc, n_bc - character(len = FIELD_NAME_LEN) :: bc_name, bc_type - character(len = OPTION_PATH_LEN) :: bc_path, bc_path_ - - ewrite(1,*) "In set_sediment_reentrainment" - - sediment_fields: do i_field = 1, get_n_sediment_fields() + type(state_type), intent(in) :: state + type(scalar_field), pointer :: sediment_field + integer :: i_field, i_bc, n_bc + character(len = FIELD_NAME_LEN) :: bc_name, bc_type + character(len = OPTION_PATH_LEN) :: bc_path, bc_path_ + + ewrite(1,*) "In set_sediment_reentrainment" + + sediment_fields: do i_field = 1, get_n_sediment_fields() - ! extract sediment field from state - call get_sediment_item(state, i_field, sediment_field) - - ! get boundary condition path and number of boundary conditions - bc_path = trim(sediment_field%option_path)//'/prognostic/boundary_conditions' - n_bc = option_count(trim(bc_path)) - - ! Loop over boundary conditions for field - boundary_conditions: do i_bc = 0, n_bc - 1 - - ! Get name and type of boundary condition - bc_path_ = trim(bc_path)//"["//int2str(i_bc)//"]" - call get_option(trim(bc_path_)//"/name", bc_name) - call get_option(trim(bc_path_)//"/type[0]/name", bc_type) - - ! skip if this is not a reentrainment boundary - if (.not. (trim(bc_type) .eq. "sediment_reentrainment")) then - cycle boundary_conditions - end if - - ewrite(1,*) "Setting reentrainment boundary condition "//trim(bc_name)//" for fi& - &eld: "//trim(sediment_field%name) - - call set_reentrainment_bc(state, sediment_field, bc_name, bc_path_, i_field) - - end do boundary_conditions - - end do sediment_fields - - end subroutine set_sediment_reentrainment - - subroutine set_reentrainment_bc(state, sediment_field, bc_name, bc_path, i_field) - - type(state_type), intent(in) :: state - type(scalar_field), intent(in), pointer :: sediment_field - type(scalar_field), pointer :: reentrainment, bedload, sink_U, d50,& - & sigma, volume_fraction, diagnostic_field, old_diagnostic_field - type(scalar_field) :: masslump, bedload_remap - type(tensor_field), pointer :: viscosity_pointer - type(tensor_field), target :: viscosity - type(vector_field), pointer :: x, shear_stress - type(mesh_type), pointer :: surface_mesh - character(len = FIELD_NAME_LEN) :: bc_name, bc_path, algorithm - integer :: stat, i_ele, i_field, i_node, i_face, i, j - integer, dimension(:), pointer :: surface_element_list - real, dimension(2,2) :: algorithm_viscosity - - ! get boundary condition field and zero - reentrainment => extract_surface_field(sediment_field, bc_name, 'value') - call set(reentrainment, 0.0) - - ! get boundary condition info - call get_boundary_condition(sediment_field, name=bc_name,& - & surface_mesh=surface_mesh, surface_element_list=surface_element_list) - - ! get bedload field - call get_sediment_item(state, i_field, 'Bedload', bedload) - - ! get volume fraction - call get_sediment_item(state, i_field, 'BedloadVolumeFraction', volume_fraction) - - ! get sinking velocity - call get_sediment_item(state, i_field, 'SinkingVelocity', sink_U) - - ! get d50 - d50 => extract_scalar_field(state, 'SedimentBedActiveLayerD50', stat) - - ! get sigma - sigma => extract_scalar_field(state, 'SedimentBedActiveLayerSigma', stat) - - call allocate(viscosity, sediment_field%mesh, "Viscosity") - ! get viscosity - call get_option(trim(bc_path)//"/type[0]/viscosity", algorithm_viscosity(1,1), stat& - &=stat) - if (stat == 0) then - do j = 1, 2 - do i = 1, 2 - algorithm_viscosity(i,j) = algorithm_viscosity(1,1) - end do - end do - call zero(viscosity) - call set(viscosity, algorithm_viscosity) - viscosity_pointer => viscosity - else - viscosity_pointer => extract_tensor_field(state, "Viscosity", stat) - if (stat /= 0) then - FLExit("A viscosity must be specified to calculate reentrainment") - end if - end if - - ! get shear stress - shear_stress => extract_vector_field(state, "BedShearStress", stat) - if (stat /= 0) then - FLExit("A bed shear stress must be specified to calculate reentrainment") - end if - - ! get coordinate field - x => extract_vector_field(state, "Coordinate") - - if (continuity(surface_mesh)>=0) then - ! For continuous fields we need a global lumped mass. For dg we'll - ! do the mass inversion on a per face basis inside the element loop. - ! Continuity must be the same for all bedload meshes - call allocate(masslump, surface_mesh, "SurfaceMassLump") - call zero(masslump) - end if - - call get_option(trim(bc_path)//"/type[0]/algorithm", algorithm) - ! loop through elements in surface field and calculate reentrainment - elements: do i_ele = 1, element_count(reentrainment) - - select case(trim(algorithm)) - case("Generic") - call assemble_generic_reentrainment_ele(state, i_field, i_ele, reentrainment,& - & shear_stress, surface_element_list, x, masslump, sink_U, volume_fraction) - case("Garcia_1991") - call assemble_garcia_1991_reentrainment_ele(state, i_field, i_ele, reentrainment,& - & x, masslump, surface_element_list, viscosity_pointer,& - & shear_stress, d50, sink_U, sigma, volume_fraction) - case default - FLExit("A valid re-entrainment algorithm must be selected") - end select - - end do elements - - ! invert global lumped mass for continuous fields - if(continuity(surface_mesh)>=0) then - where (masslump%val/=0.0) - masslump%val=1./masslump%val - end where - call scale(reentrainment, masslump) - call deallocate(masslump) - end if - - ! check bound of entrainment so that it does not exceed the available sediment in the - ! bed and is larger than zero. - call allocate(bedload_remap, surface_mesh, name="bedload_remap") - call remap_field_to_surface(bedload, bedload_remap, surface_element_list) - nodes: do i_node = 1, node_count(reentrainment) - if(dt/=0.0) then - call set(reentrainment, i_node, min(max(node_val(reentrainment, i_node), 0.0),& - & node_val(bedload_remap, i_node)/dt)) - else - call set(reentrainment, i_node, max(node_val(reentrainment, i_node), 0.0)) - end if - end do nodes - - ! store erosion rate in diagnositc field - call get_sediment_item(state, i_field, "BedloadErosionRate", diagnostic_field, stat) - if (stat == 0 .and. dt > 1e-15) then - call zero(diagnostic_field) - do i_ele = 1, ele_count(reentrainment) - i_face=surface_element_list(i_ele) - call set(diagnostic_field, face_global_nodes(diagnostic_field, i_face), & - & ele_val(reentrainment, i_ele)) - end do - ! I also need to set the old field value otherwise this get overwritten with zero straight away - ! This is a bit messy but the important thing is that at the end of the timestep we have recorded - ! the erosion rate, this fools Fluidity such that we get that. - old_diagnostic_field => extract_scalar_field(state, "Old"//trim(diagnostic_field%name), stat) - if (stat == 0) then - call set(old_diagnostic_field, diagnostic_field) - end if - end if - - ! only for mms tests - if (have_option(trim(bc_path)//"/type[0]/set_to_zero")) then - ! zero reentrainment - call zero(reentrainment) - end if - - ewrite_minmax(bedload) - ewrite_minmax(reentrainment) - - call deallocate(bedload_remap) - call deallocate(viscosity) - - end subroutine set_reentrainment_bc - - subroutine assemble_garcia_1991_reentrainment_ele(state, i_field, i_ele, reentrainment,& - & x, masslump, surface_element_list, viscosity, shear_stress, d50,& - & sink_U, sigma, volume_fraction) - - type(state_type), intent(in) :: state - integer, intent(in) :: i_ele, i_field - type(tensor_field), pointer, intent(in) :: viscosity - type(vector_field), intent(in) :: x, shear_stress - type(scalar_field), intent(inout) :: masslump - type(scalar_field), pointer, intent(inout) :: reentrainment - type(scalar_field), pointer, intent(in) :: d50, sink_U, sigma,& - & volume_fraction - integer, dimension(:), pointer, intent(in) :: surface_element_list - type(element_type), pointer :: shape - integer, dimension(:), pointer :: ele - real, dimension(ele_ngi(reentrainment, i_ele)) :: detwei - real, dimension(ele_loc(reentrainment, i_ele), & - & ele_loc(reentrainment, i_ele)) :: invmass - real :: A, R, d, g, density - real, dimension(ele_ngi(reentrainment, i_ele)) :: R_p, u_star, Z - real, dimension(ele_loc(reentrainment, i_ele)) :: E - real, dimension(ele_ngi(reentrainment, i_ele)) :: shear, lambda_m - real, dimension(shear_stress%dim, & - & ele_ngi(reentrainment, i_ele)) :: shear_quad - integer :: i_gi, stat - - A = 1.3*10.0**(-7.0) - - ele => ele_nodes(reentrainment, i_ele) - shape => ele_shape(reentrainment, i_ele) - - call transform_facet_to_physical(x, surface_element_list(i_ele), detwei) - - if(continuity(reentrainment)>=0) then - call addto(masslump, ele, & + ! extract sediment field from state + call get_sediment_item(state, i_field, sediment_field) + + ! get boundary condition path and number of boundary conditions + bc_path = trim(sediment_field%option_path)//'/prognostic/boundary_conditions' + n_bc = option_count(trim(bc_path)) + + ! Loop over boundary conditions for field + boundary_conditions: do i_bc = 0, n_bc - 1 + + ! Get name and type of boundary condition + bc_path_ = trim(bc_path)//"["//int2str(i_bc)//"]" + call get_option(trim(bc_path_)//"/name", bc_name) + call get_option(trim(bc_path_)//"/type[0]/name", bc_type) + + ! skip if this is not a reentrainment boundary + if (.not. (trim(bc_type) .eq. "sediment_reentrainment")) then + cycle boundary_conditions + end if + + ewrite(1,*) "Setting reentrainment boundary condition "//trim(bc_name)//" for fi& + &eld: "//trim(sediment_field%name) + + call set_reentrainment_bc(state, sediment_field, bc_name, bc_path_, i_field) + + end do boundary_conditions + + end do sediment_fields + + end subroutine set_sediment_reentrainment + + subroutine set_reentrainment_bc(state, sediment_field, bc_name, bc_path, i_field) + + type(state_type), intent(in) :: state + type(scalar_field), intent(in), pointer :: sediment_field + type(scalar_field), pointer :: reentrainment, bedload, sink_U, d50,& + & sigma, volume_fraction, diagnostic_field, old_diagnostic_field + type(scalar_field) :: masslump, bedload_remap + type(tensor_field), pointer :: viscosity_pointer + type(tensor_field), target :: viscosity + type(vector_field), pointer :: x, shear_stress + type(mesh_type), pointer :: surface_mesh + character(len = FIELD_NAME_LEN) :: bc_name, bc_path, algorithm + integer :: stat, i_ele, i_field, i_node, i_face, i, j + integer, dimension(:), pointer :: surface_element_list + real, dimension(2,2) :: algorithm_viscosity + + ! get boundary condition field and zero + reentrainment => extract_surface_field(sediment_field, bc_name, 'value') + call set(reentrainment, 0.0) + + ! get boundary condition info + call get_boundary_condition(sediment_field, name=bc_name,& + & surface_mesh=surface_mesh, surface_element_list=surface_element_list) + + ! get bedload field + call get_sediment_item(state, i_field, 'Bedload', bedload) + + ! get volume fraction + call get_sediment_item(state, i_field, 'BedloadVolumeFraction', volume_fraction) + + ! get sinking velocity + call get_sediment_item(state, i_field, 'SinkingVelocity', sink_U) + + ! get d50 + d50 => extract_scalar_field(state, 'SedimentBedActiveLayerD50', stat) + + ! get sigma + sigma => extract_scalar_field(state, 'SedimentBedActiveLayerSigma', stat) + + call allocate(viscosity, sediment_field%mesh, "Viscosity") + ! get viscosity + call get_option(trim(bc_path)//"/type[0]/viscosity", algorithm_viscosity(1,1), stat& + &=stat) + if (stat == 0) then + do j = 1, 2 + do i = 1, 2 + algorithm_viscosity(i,j) = algorithm_viscosity(1,1) + end do + end do + call zero(viscosity) + call set(viscosity, algorithm_viscosity) + viscosity_pointer => viscosity + else + viscosity_pointer => extract_tensor_field(state, "Viscosity", stat) + if (stat /= 0) then + FLExit("A viscosity must be specified to calculate reentrainment") + end if + end if + + ! get shear stress + shear_stress => extract_vector_field(state, "BedShearStress", stat) + if (stat /= 0) then + FLExit("A bed shear stress must be specified to calculate reentrainment") + end if + + ! get coordinate field + x => extract_vector_field(state, "Coordinate") + + if (continuity(surface_mesh)>=0) then + ! For continuous fields we need a global lumped mass. For dg we'll + ! do the mass inversion on a per face basis inside the element loop. + ! Continuity must be the same for all bedload meshes + call allocate(masslump, surface_mesh, "SurfaceMassLump") + call zero(masslump) + end if + + call get_option(trim(bc_path)//"/type[0]/algorithm", algorithm) + ! loop through elements in surface field and calculate reentrainment + elements: do i_ele = 1, element_count(reentrainment) + + select case(trim(algorithm)) + case("Generic") + call assemble_generic_reentrainment_ele(state, i_field, i_ele, reentrainment,& + & shear_stress, surface_element_list, x, masslump, sink_U, volume_fraction) + case("Garcia_1991") + call assemble_garcia_1991_reentrainment_ele(state, i_field, i_ele, reentrainment,& + & x, masslump, surface_element_list, viscosity_pointer,& + & shear_stress, d50, sink_U, sigma, volume_fraction) + case default + FLExit("A valid re-entrainment algorithm must be selected") + end select + + end do elements + + ! invert global lumped mass for continuous fields + if(continuity(surface_mesh)>=0) then + where (masslump%val/=0.0) + masslump%val=1./masslump%val + end where + call scale(reentrainment, masslump) + call deallocate(masslump) + end if + + ! check bound of entrainment so that it does not exceed the available sediment in the + ! bed and is larger than zero. + call allocate(bedload_remap, surface_mesh, name="bedload_remap") + call remap_field_to_surface(bedload, bedload_remap, surface_element_list) + nodes: do i_node = 1, node_count(reentrainment) + if(dt/=0.0) then + call set(reentrainment, i_node, min(max(node_val(reentrainment, i_node), 0.0),& + & node_val(bedload_remap, i_node)/dt)) + else + call set(reentrainment, i_node, max(node_val(reentrainment, i_node), 0.0)) + end if + end do nodes + + ! store erosion rate in diagnositc field + call get_sediment_item(state, i_field, "BedloadErosionRate", diagnostic_field, stat) + if (stat == 0 .and. dt > 1e-15) then + call zero(diagnostic_field) + do i_ele = 1, ele_count(reentrainment) + i_face=surface_element_list(i_ele) + call set(diagnostic_field, face_global_nodes(diagnostic_field, i_face), & + & ele_val(reentrainment, i_ele)) + end do + ! I also need to set the old field value otherwise this get overwritten with zero straight away + ! This is a bit messy but the important thing is that at the end of the timestep we have recorded + ! the erosion rate, this fools Fluidity such that we get that. + old_diagnostic_field => extract_scalar_field(state, "Old"//trim(diagnostic_field%name), stat) + if (stat == 0) then + call set(old_diagnostic_field, diagnostic_field) + end if + end if + + ! only for mms tests + if (have_option(trim(bc_path)//"/type[0]/set_to_zero")) then + ! zero reentrainment + call zero(reentrainment) + end if + + ewrite_minmax(bedload) + ewrite_minmax(reentrainment) + + call deallocate(bedload_remap) + call deallocate(viscosity) + + end subroutine set_reentrainment_bc + + subroutine assemble_garcia_1991_reentrainment_ele(state, i_field, i_ele, reentrainment,& + & x, masslump, surface_element_list, viscosity, shear_stress, d50,& + & sink_U, sigma, volume_fraction) + + type(state_type), intent(in) :: state + integer, intent(in) :: i_ele, i_field + type(tensor_field), pointer, intent(in) :: viscosity + type(vector_field), intent(in) :: x, shear_stress + type(scalar_field), intent(inout) :: masslump + type(scalar_field), pointer, intent(inout) :: reentrainment + type(scalar_field), pointer, intent(in) :: d50, sink_U, sigma,& + & volume_fraction + integer, dimension(:), pointer, intent(in) :: surface_element_list + type(element_type), pointer :: shape + integer, dimension(:), pointer :: ele + real, dimension(ele_ngi(reentrainment, i_ele)) :: detwei + real, dimension(ele_loc(reentrainment, i_ele), & + & ele_loc(reentrainment, i_ele)) :: invmass + real :: A, R, d, g, density + real, dimension(ele_ngi(reentrainment, i_ele)) :: R_p, u_star, Z + real, dimension(ele_loc(reentrainment, i_ele)) :: E + real, dimension(ele_ngi(reentrainment, i_ele)) :: shear, lambda_m + real, dimension(shear_stress%dim, & + & ele_ngi(reentrainment, i_ele)) :: shear_quad + integer :: i_gi, stat + + A = 1.3*10.0**(-7.0) + + ele => ele_nodes(reentrainment, i_ele) + shape => ele_shape(reentrainment, i_ele) + + call transform_facet_to_physical(x, surface_element_list(i_ele), detwei) + + if(continuity(reentrainment)>=0) then + call addto(masslump, ele, & sum(shape_shape(shape, shape, detwei), 1)) - else - ! In the DG case we will apply the inverse mass locally. - invmass=inverse(shape_shape(shape, shape, detwei)) - end if - - ! calculate particle Reynolds number - call get_sediment_item(state, i_field, 'submerged_specific_gravity', R) - call get_sediment_item(state, i_field, 'diameter', d) - call get_option("/physical_parameters/gravity/magnitude", g) - ! VISCOSITY ASSUMED TO BE ISOTROPIC - maybe should be in normal direction to surface - where (face_val_at_quad(viscosity, surface_element_list(i_ele), 1, 1) > 0.0) - R_p = sqrt(R*g*d**3.0)/face_val_at_quad(viscosity, surface_element_list(i_ele), 1, 1) - elsewhere - R_p = 0.0 - end where - - ! calculate u_star (shear velocity) - call get_option(trim(shear_stress%option_path)//"/diagnostic/density", density, stat) - if (stat /= 0) density = 1.0 - ! calculate magnitude of shear stress at quadrature points - shear_quad = face_val_at_quad(shear_stress, surface_element_list(i_ele)) - do i_gi = 1, ele_ngi(reentrainment, i_ele) - shear(i_gi) = norm2(shear_quad(:, i_gi)) - end do - u_star = sqrt(shear/density) - - ! calculate lambda_m - lambda_m = 1.0 - 0.288 * face_val_at_quad(sigma, surface_element_list(i_ele)) - - ! calculate Z - where (face_val_at_quad(d50, surface_element_list(i_ele)) > 0.0) - Z = lambda_m * u_star/face_val_at_quad(sink_U, surface_element_list(i_ele)) * R_p& - &**0.6 * (d / face_val_at_quad(d50, surface_element_list(i_ele)))**0.2 - elsewhere - Z = 0.0 - end where - - ! calculate reentrainment F*v_s*E - E = shape_rhs(shape, face_val_at_quad(volume_fraction, surface_element_list(i_ele)) *& - & face_val_at_quad(sink_U, surface_element_list(i_ele)) * A*Z**5 / (1 + A*Z**5& - &/0.3) * detwei) - - if(continuity(reentrainment)<0) then - ! DG case. - E = matmul(invmass, E) - end if - - call addto(reentrainment, ele, E) - - end subroutine assemble_garcia_1991_reentrainment_ele - - subroutine assemble_generic_reentrainment_ele(state, i_field, i_ele, reentrainment,& - & shear_stress, surface_element_list, x, masslump, sink_U, volume_fraction) - - type(state_type), intent(in) :: state - integer, intent(in) :: i_ele, i_field - type(scalar_field), pointer, intent(inout) :: reentrainment - type(vector_field), intent(in) :: x, shear_stress - integer, dimension(:), pointer, intent(in) :: surface_element_list - type(scalar_field), intent(inout) :: masslump - type(scalar_field), pointer, intent(in) :: sink_U, volume_fraction - type(element_type), pointer :: shape - integer, dimension(:), pointer :: ele - real, dimension(ele_ngi(reentrainment, i_ele)) :: detwei - real, dimension(ele_loc(reentrainment, i_ele), & - & ele_loc(reentrainment, i_ele)) :: invmass - integer, dimension(2) :: stat - real :: shear_crit, d, R, g, erod,& - & poro, density, rho_0 - real, dimension(ele_loc(reentrainment, i_ele)) :: E - real, dimension(ele_ngi(reentrainment, i_ele)) :: shear - real, dimension(shear_stress%dim, & - & ele_ngi(reentrainment, i_ele)) :: shear_quad - - integer :: i_gi - - call get_sediment_item(state, i_field, 'critical_shear_stress', shear_crit, stat(1)) - call get_sediment_item(state, i_field, 'diameter', d, stat(2)) - ! non-dimensionalise shear stress - call get_option('/material_phase::'//trim(state%name)//'/equation_of_state/fluids/line& - &ar/reference_density', rho_0) - ! get or calculate critical shear stress - if (.not.any(stat .eq. 0)) then - FLExit("You need to either specify a critical shear stress or a & - &sediment diameter to use the generic formula for reentrainment") - else if (stat(1) /= 0) then - ! estimate of critical shear stress assuming grains larger than - ! 10 microns and constant viscosity - ! critical stress is either given by user (optional) or calculated - ! using Shield's formula (depends on grain size and density and - ! (vertical) viscosity) - call get_sediment_item(state, i_field, 'submerged_specific_gravity', R) - call get_option("/physical_parameters/gravity/magnitude", g) - shear_crit = 0.041 * R * rho_0 * g * d - end if - - ! calculate eroded sediment flux and set reentrainment BC - ! we only need to add to the source the reentrainment of sediment from the - ! bedload into the neumann BC term - ! - ! The source depends on the erodability of that sediment - ! (usually 1 unless you want to do something like mud which sticks), - ! the porosity in the bedload and the bed shear stress. - ! - ! Each sediment class has a critical shear stress, which if exceeded - ! by the bed shear stress, sediment is placed into suspension - ! - ! loop over nodes in bottom surface - call get_sediment_item(state, i_field, 'erodability', erod, default=1.0) - call get_sediment_item(state, i_field, 'bed_porosity', poro, default=0.3) - - ele => ele_nodes(reentrainment, i_ele) - shape => ele_shape(reentrainment, i_ele) - - call transform_facet_to_physical(x, surface_element_list(i_ele), detwei) - - if(continuity(reentrainment)>=0) then - call addto(masslump, ele, & + else + ! In the DG case we will apply the inverse mass locally. + invmass=inverse(shape_shape(shape, shape, detwei)) + end if + + ! calculate particle Reynolds number + call get_sediment_item(state, i_field, 'submerged_specific_gravity', R) + call get_sediment_item(state, i_field, 'diameter', d) + call get_option("/physical_parameters/gravity/magnitude", g) + ! VISCOSITY ASSUMED TO BE ISOTROPIC - maybe should be in normal direction to surface + where (face_val_at_quad(viscosity, surface_element_list(i_ele), 1, 1) > 0.0) + R_p = sqrt(R*g*d**3.0)/face_val_at_quad(viscosity, surface_element_list(i_ele), 1, 1) + elsewhere + R_p = 0.0 + end where + + ! calculate u_star (shear velocity) + call get_option(trim(shear_stress%option_path)//"/diagnostic/density", density, stat) + if (stat /= 0) density = 1.0 + ! calculate magnitude of shear stress at quadrature points + shear_quad = face_val_at_quad(shear_stress, surface_element_list(i_ele)) + do i_gi = 1, ele_ngi(reentrainment, i_ele) + shear(i_gi) = norm2(shear_quad(:, i_gi)) + end do + u_star = sqrt(shear/density) + + ! calculate lambda_m + lambda_m = 1.0 - 0.288 * face_val_at_quad(sigma, surface_element_list(i_ele)) + + ! calculate Z + where (face_val_at_quad(d50, surface_element_list(i_ele)) > 0.0) + Z = lambda_m * u_star/face_val_at_quad(sink_U, surface_element_list(i_ele)) * R_p& + &**0.6 * (d / face_val_at_quad(d50, surface_element_list(i_ele)))**0.2 + elsewhere + Z = 0.0 + end where + + ! calculate reentrainment F*v_s*E + E = shape_rhs(shape, face_val_at_quad(volume_fraction, surface_element_list(i_ele)) *& + & face_val_at_quad(sink_U, surface_element_list(i_ele)) * A*Z**5 / (1 + A*Z**5& + &/0.3) * detwei) + + if(continuity(reentrainment)<0) then + ! DG case. + E = matmul(invmass, E) + end if + + call addto(reentrainment, ele, E) + + end subroutine assemble_garcia_1991_reentrainment_ele + + subroutine assemble_generic_reentrainment_ele(state, i_field, i_ele, reentrainment,& + & shear_stress, surface_element_list, x, masslump, sink_U, volume_fraction) + + type(state_type), intent(in) :: state + integer, intent(in) :: i_ele, i_field + type(scalar_field), pointer, intent(inout) :: reentrainment + type(vector_field), intent(in) :: x, shear_stress + integer, dimension(:), pointer, intent(in) :: surface_element_list + type(scalar_field), intent(inout) :: masslump + type(scalar_field), pointer, intent(in) :: sink_U, volume_fraction + type(element_type), pointer :: shape + integer, dimension(:), pointer :: ele + real, dimension(ele_ngi(reentrainment, i_ele)) :: detwei + real, dimension(ele_loc(reentrainment, i_ele), & + & ele_loc(reentrainment, i_ele)) :: invmass + integer, dimension(2) :: stat + real :: shear_crit, d, R, g, erod,& + & poro, density, rho_0 + real, dimension(ele_loc(reentrainment, i_ele)) :: E + real, dimension(ele_ngi(reentrainment, i_ele)) :: shear + real, dimension(shear_stress%dim, & + & ele_ngi(reentrainment, i_ele)) :: shear_quad + + integer :: i_gi + + call get_sediment_item(state, i_field, 'critical_shear_stress', shear_crit, stat(1)) + call get_sediment_item(state, i_field, 'diameter', d, stat(2)) + ! non-dimensionalise shear stress + call get_option('/material_phase::'//trim(state%name)//'/equation_of_state/fluids/line& + &ar/reference_density', rho_0) + ! get or calculate critical shear stress + if (.not.any(stat .eq. 0)) then + FLExit("You need to either specify a critical shear stress or a & + &sediment diameter to use the generic formula for reentrainment") + else if (stat(1) /= 0) then + ! estimate of critical shear stress assuming grains larger than + ! 10 microns and constant viscosity + ! critical stress is either given by user (optional) or calculated + ! using Shield's formula (depends on grain size and density and + ! (vertical) viscosity) + call get_sediment_item(state, i_field, 'submerged_specific_gravity', R) + call get_option("/physical_parameters/gravity/magnitude", g) + shear_crit = 0.041 * R * rho_0 * g * d + end if + + ! calculate eroded sediment flux and set reentrainment BC + ! we only need to add to the source the reentrainment of sediment from the + ! bedload into the neumann BC term + ! + ! The source depends on the erodability of that sediment + ! (usually 1 unless you want to do something like mud which sticks), + ! the porosity in the bedload and the bed shear stress. + ! + ! Each sediment class has a critical shear stress, which if exceeded + ! by the bed shear stress, sediment is placed into suspension + ! + ! loop over nodes in bottom surface + call get_sediment_item(state, i_field, 'erodability', erod, default=1.0) + call get_sediment_item(state, i_field, 'bed_porosity', poro, default=0.3) + + ele => ele_nodes(reentrainment, i_ele) + shape => ele_shape(reentrainment, i_ele) + + call transform_facet_to_physical(x, surface_element_list(i_ele), detwei) + + if(continuity(reentrainment)>=0) then + call addto(masslump, ele, & sum(shape_shape(shape, shape, detwei), 1)) - else - ! In the DG case we will apply the inverse mass locally. - invmass=inverse(shape_shape(shape, shape, detwei)) - end if - - ! calculate magnitude of shear stress at quadrature points - shear_quad = face_val_at_quad(shear_stress, surface_element_list(i_ele)) - do i_gi = 1, ele_ngi(reentrainment, i_ele) - shear(i_gi) = norm2(shear_quad(:, i_gi)) - end do - ! non-dimensionalise shear stress - call get_option(trim(shear_stress%option_path)//"/diagnostic/density", density) - shear = shear / density - - ! calculate reentrainment F*vs*E - E = shape_rhs(shape, face_val_at_quad(volume_fraction, surface_element_list(i_ele)) *& - & face_val_at_quad(sink_U, surface_element_list(i_ele)) * erod * (1-poro) *& - & (shear - shear_crit)/shear_crit * detwei) - - if(continuity(reentrainment)<0) then - ! DG case. - E = matmul(invmass, E) - end if - - call addto(reentrainment, ele, E) - - end subroutine assemble_generic_reentrainment_ele - - subroutine surface_horizontal_divergence(source, positions, output, surface_ids) - !!< Return a field containing: - !!< div_HS source - !!< where div_hs is a divergence operator restricted to the surface and - !!< of spatial dimension one degree lower than the full mesh. - - type(vector_field), intent(in) :: source - type(vector_field), intent(in) :: positions - type(scalar_field), intent(inout) :: output - integer, dimension(:), intent(in) :: surface_ids - - type(mesh_type) :: surface_mesh, source_surface_mesh, output_surface_mesh - - integer :: i, idx - - integer, dimension(surface_element_count(output)) :: surface_elements - integer, dimension(:), pointer :: surface_nodes, source_surface_nodes,& + else + ! In the DG case we will apply the inverse mass locally. + invmass=inverse(shape_shape(shape, shape, detwei)) + end if + + ! calculate magnitude of shear stress at quadrature points + shear_quad = face_val_at_quad(shear_stress, surface_element_list(i_ele)) + do i_gi = 1, ele_ngi(reentrainment, i_ele) + shear(i_gi) = norm2(shear_quad(:, i_gi)) + end do + ! non-dimensionalise shear stress + call get_option(trim(shear_stress%option_path)//"/diagnostic/density", density) + shear = shear / density + + ! calculate reentrainment F*vs*E + E = shape_rhs(shape, face_val_at_quad(volume_fraction, surface_element_list(i_ele)) *& + & face_val_at_quad(sink_U, surface_element_list(i_ele)) * erod * (1-poro) *& + & (shear - shear_crit)/shear_crit * detwei) + + if(continuity(reentrainment)<0) then + ! DG case. + E = matmul(invmass, E) + end if + + call addto(reentrainment, ele, E) + + end subroutine assemble_generic_reentrainment_ele + + subroutine surface_horizontal_divergence(source, positions, output, surface_ids) + !!< Return a field containing: + !!< div_HS source + !!< where div_hs is a divergence operator restricted to the surface and + !!< of spatial dimension one degree lower than the full mesh. + + type(vector_field), intent(in) :: source + type(vector_field), intent(in) :: positions + type(scalar_field), intent(inout) :: output + integer, dimension(:), intent(in) :: surface_ids + + type(mesh_type) :: surface_mesh, source_surface_mesh, output_surface_mesh + + integer :: i, idx + + integer, dimension(surface_element_count(output)) :: surface_elements + integer, dimension(:), pointer :: surface_nodes, source_surface_nodes,& output_surface_nodes - type(vector_field) :: surface_source, surface_positions - type(scalar_field) :: surface_output - real, dimension(mesh_dim(positions)) :: val + type(vector_field) :: surface_source, surface_positions + type(scalar_field) :: surface_output + real, dimension(mesh_dim(positions)) :: val - call zero(output) + call zero(output) - !!! get the relevant surface. This wastes a bit of memory. - idx=1 - do i = 1, surface_element_count(output) - if (any(surface_ids == surface_element_id(positions, i))) then - surface_elements(idx)=i - idx=idx+1 - end if - end do + !!! get the relevant surface. This wastes a bit of memory. + idx=1 + do i = 1, surface_element_count(output) + if (any(surface_ids == surface_element_id(positions, i))) then + surface_elements(idx)=i + idx=idx+1 + end if + end do - !!! make the surface meshes + !!! make the surface meshes - call create_surface_mesh(surface_mesh, surface_nodes, & + call create_surface_mesh(surface_mesh, surface_nodes, & positions%mesh, surface_elements=surface_elements(:idx-1), & name='CoordinateSurfaceMesh') - call create_surface_mesh(source_surface_mesh, source_surface_nodes, & + call create_surface_mesh(source_surface_mesh, source_surface_nodes, & source%mesh, surface_elements=surface_elements(:idx-1), & name='SourceSurfaceMesh') - call create_surface_mesh(output_surface_mesh, output_surface_nodes, & + call create_surface_mesh(output_surface_mesh, output_surface_nodes, & output%mesh, surface_elements=surface_elements(:idx-1), & name='OutputSurfaceMesh') - call allocate(surface_positions,mesh_dim(surface_mesh),surface_mesh,& + call allocate(surface_positions,mesh_dim(surface_mesh),surface_mesh,& "Coordinates") - call allocate(surface_source,mesh_dim(surface_mesh),source_surface_mesh,& + call allocate(surface_source,mesh_dim(surface_mesh),source_surface_mesh,& "Source") - call allocate(surface_output,output_surface_mesh,"Divergence") + call allocate(surface_output,output_surface_mesh,"Divergence") - do i=1,size(surface_nodes) - val=node_val(positions,surface_nodes(i)) - call set(surface_positions,i,val(:mesh_dim(surface_mesh))) - end do + do i=1,size(surface_nodes) + val=node_val(positions,surface_nodes(i)) + call set(surface_positions,i,val(:mesh_dim(surface_mesh))) + end do - do i=1,size(source_surface_nodes) - val=node_val(source,source_surface_nodes(i)) - call set(surface_source,i,val(:mesh_dim(surface_mesh))) - end do + do i=1,size(source_surface_nodes) + val=node_val(source,source_surface_nodes(i)) + call set(surface_source,i,val(:mesh_dim(surface_mesh))) + end do !!! now do the low dimensional divergence operation - call div(surface_source,surface_positions,surface_output) + call div(surface_source,surface_positions,surface_output) - do i=1,size(output_surface_nodes) - call set(output,output_surface_nodes(i),node_val(surface_output,i)) - end do + do i=1,size(output_surface_nodes) + call set(output,output_surface_nodes(i),node_val(surface_output,i)) + end do !!! I *think* this surfices for parallel, due to the relatively locality of the !!! divergence operator - call halo_update(output) + call halo_update(output) - call deallocate(surface_positions) - call deallocate(surface_source) - call deallocate(surface_output) + call deallocate(surface_positions) + call deallocate(surface_source) + call deallocate(surface_output) - call deallocate(surface_mesh) - call deallocate(source_surface_mesh) - call deallocate(output_surface_mesh) + call deallocate(surface_mesh) + call deallocate(source_surface_mesh) + call deallocate(output_surface_mesh) - deallocate(surface_nodes, source_surface_nodes, output_surface_nodes) + deallocate(surface_nodes, source_surface_nodes, output_surface_nodes) - end subroutine surface_horizontal_divergence + end subroutine surface_horizontal_divergence - subroutine sediment_check_options + subroutine sediment_check_options - character(len=FIELD_NAME_LEN) :: field_mesh, sediment_mesh, bc_type - character(len=OPTION_PATH_LEN) :: field_option_path - integer :: i_field, i_bc, i_bc_surf, i_bedload_surf,& - & n_sediment_fields, nbcs - integer, dimension(2) :: bc_surface_id_count, bedload_surface_id_count - integer, dimension(:), allocatable :: bc_surface_ids, bedload_surface_ids + character(len=FIELD_NAME_LEN) :: field_mesh, sediment_mesh, bc_type + character(len=OPTION_PATH_LEN) :: field_option_path + integer :: i_field, i_bc, i_bc_surf, i_bedload_surf,& + & n_sediment_fields, nbcs + integer, dimension(2) :: bc_surface_id_count, bedload_surface_id_count + integer, dimension(:), allocatable :: bc_surface_ids, bedload_surface_ids - if (have_option('/material_phase[0]/sediment/')) then + if (have_option('/material_phase[0]/sediment/')) then - ewrite(1,*) 'Checking sediment model options' + ewrite(1,*) 'Checking sediment model options' - n_sediment_fields = get_n_sediment_fields() + n_sediment_fields = get_n_sediment_fields() - call get_option('/material_phase[0]/sediment/scalar_field[0]/prognostic/mesh[0]/name', sediment_mesh) + call get_option('/material_phase[0]/sediment/scalar_field[0]/prognostic/mesh[0]/name', sediment_mesh) - sediment_fields: do i_field=1,n_sediment_fields + sediment_fields: do i_field=1,n_sediment_fields - field_option_path = '/material_phase[0]/sediment/scalar_field['//int2str(i_field - 1)//']/pro& - &gnostic' + field_option_path = '/material_phase[0]/sediment/scalar_field['//int2str(i_field - 1)//']/pro& + &gnostic' - ! check sinking velocity is specified for every sediment field - if (.not.(have_option(trim(field_option_path)//'/scalar_field::SinkingVelocity')))& - & then - FLExit("You must specify a sinking velocity for every sediment field") - end if + ! check sinking velocity is specified for every sediment field + if (.not.(have_option(trim(field_option_path)//'/scalar_field::SinkingVelocity')))& + & then + FLExit("You must specify a sinking velocity for every sediment field") + end if - ! check all sediment fields are on the same mesh - call get_option(trim(field_option_path)//'/mesh[0]/name', field_mesh) - if (.not.(trim(field_mesh) .eq. trim(sediment_mesh))) then - FLExit("All sediment fields must be on the same mesh") - end if + ! check all sediment fields are on the same mesh + call get_option(trim(field_option_path)//'/mesh[0]/name', field_mesh) + if (.not.(trim(field_mesh) .eq. trim(sediment_mesh))) then + FLExit("All sediment fields must be on the same mesh") + end if - ! check re-entrainment options - ! get boundary condition path and number of boundary conditions - nbcs=option_count(trim(field_option_path)//'/boundary_conditions') - ! Loop over boundary conditions for field - boundary_conditions: do i_bc=0, nbcs-1 + ! check re-entrainment options + ! get boundary condition path and number of boundary conditions + nbcs=option_count(trim(field_option_path)//'/boundary_conditions') + ! Loop over boundary conditions for field + boundary_conditions: do i_bc=0, nbcs-1 - ! Get name and type of boundary condition - call get_option(trim(field_option_path)//& + ! Get name and type of boundary condition + call get_option(trim(field_option_path)//& '/boundary_conditions['//int2str(i_bc)//& ']/type[0]/name', bc_type) - ! check whether this is a reentrainment boundary - if (.not. (trim(bc_type) .eq. "sediment_reentrainment")) then - cycle boundary_conditions - end if + ! check whether this is a reentrainment boundary + if (.not. (trim(bc_type) .eq. "sediment_reentrainment")) then + cycle boundary_conditions + end if - ! check a 'BedShearStress' field exists - if (.not.(have_option('/material_phase[0]/vector_field::BedShearStress'))) then - FLExit("Reentrainment boundary condition requires a BedShearStress field") - end if + ! check a 'BedShearStress' field exists + if (.not.(have_option('/material_phase[0]/vector_field::BedShearStress'))) then + FLExit("Reentrainment boundary condition requires a BedShearStress field") + end if - ! check boundary id's are the same for re-entrainment and bedload + ! check boundary id's are the same for re-entrainment and bedload - ! get bedload surface ids - bedload_surface_id_count=option_shape(trim(field_option_path)// & + ! get bedload surface ids + bedload_surface_id_count=option_shape(trim(field_option_path)// & '/scalar_field::Bedload/prognostic/surface_ids') - allocate(bedload_surface_ids(bedload_surface_id_count(1))) - call get_option(trim(field_option_path)// & + allocate(bedload_surface_ids(bedload_surface_id_count(1))) + call get_option(trim(field_option_path)// & '/scalar_field::Bedload/prognostic/surface_ids', bedload_surface_ids) - ! get reentrainment surface ids - bc_surface_id_count=option_shape(trim(field_option_path)//'/boundary_conditions['& - &//int2str(i_bc)//']/surface_ids') - allocate(bc_surface_ids(bc_surface_id_count(1))) - call get_option(trim(field_option_path)// & + ! get reentrainment surface ids + bc_surface_id_count=option_shape(trim(field_option_path)//'/boundary_conditions['& + &//int2str(i_bc)//']/surface_ids') + allocate(bc_surface_ids(bc_surface_id_count(1))) + call get_option(trim(field_option_path)// & '/boundary_conditions['//int2str(i_bc)//']/surface_ids', bc_surface_ids) - bc_surface_id: do i_bc_surf=1, bc_surface_id_count(1) + bc_surface_id: do i_bc_surf=1, bc_surface_id_count(1) - bedload_surface_id: do i_bedload_surf=1, bedload_surface_id_count(1) + bedload_surface_id: do i_bedload_surf=1, bedload_surface_id_count(1) - if (bc_surface_ids(i_bc_surf) .eq. bedload_surface_ids(i_bedload_surf)) then - cycle bc_surface_id - end if + if (bc_surface_ids(i_bc_surf) .eq. bedload_surface_ids(i_bedload_surf)) then + cycle bc_surface_id + end if - end do bedload_surface_id + end do bedload_surface_id - FLExit("Reentrainment boundary condition is specified on a surface with no bedload") + FLExit("Reentrainment boundary condition is specified on a surface with no bedload") - end do bc_surface_id + end do bc_surface_id - deallocate(bc_surface_ids) - deallocate(bedload_surface_ids) + deallocate(bc_surface_ids) + deallocate(bedload_surface_ids) - end do boundary_conditions + end do boundary_conditions - end do sediment_fields + end do sediment_fields - ewrite(1,*) 'Sediment model options check complete' + ewrite(1,*) 'Sediment model options check complete' - end if + end if - end subroutine sediment_check_options + end subroutine sediment_check_options end module sediment diff --git a/sediments/Sediment_Diagnostics.F90 b/sediments/Sediment_Diagnostics.F90 index 0e3d377d58..aa89a28176 100644 --- a/sediments/Sediment_Diagnostics.F90 +++ b/sediments/Sediment_Diagnostics.F90 @@ -29,756 +29,756 @@ module sediment_diagnostics - use fldebug - use global_parameters, only:FIELD_NAME_LEN, OPTION_PATH_LEN, dt, timestep - use futils, only: int2str - use vector_tools - use quadrature - use elements - use spud - use sparse_tools - use fetools - use fields - use state_module - use fefields - use boundary_conditions - use sediment, only: get_n_sediment_fields, get_sediment_item - - implicit none - - private - - public calculate_sediment_flux, calculate_sediment_sinking_velocity,& - & calculate_sediment_active_layer_d50, calculate_sediment_active_layer_sigma,& - & calculate_sediment_active_layer_volume_fractions + use fldebug + use global_parameters, only:FIELD_NAME_LEN, OPTION_PATH_LEN, dt, timestep + use futils, only: int2str + use vector_tools + use quadrature + use elements + use spud + use sparse_tools + use fetools + use fields + use state_module + use fefields + use boundary_conditions + use sediment, only: get_n_sediment_fields, get_sediment_item + + implicit none + + private + + public calculate_sediment_flux, calculate_sediment_sinking_velocity,& + & calculate_sediment_active_layer_d50, calculate_sediment_active_layer_sigma,& + & calculate_sediment_active_layer_volume_fractions contains - subroutine calculate_sediment_flux(state) - !!< Calculate the advected flux of the sediment through the surfaces of - !!< the domain. - !!< This is determined based upon a fixed theta of 0.5 - !!< Currently erosion bc is calculated explicitly and the value is consistent here - type(state_type), intent(inout) :: state - type(mesh_type), dimension(:), allocatable :: surface_mesh - type surface_nodes_array - integer, dimension(:), pointer :: nodes - end type surface_nodes_array - type(surface_nodes_array), dimension(:), allocatable :: surface_nodes - type(vector_field), pointer :: X, old_U, new_U, gravity - type(scalar_field), dimension(:), allocatable :: deposited_sediment, erosion - type(scalar_field), pointer :: erosion_flux, bedload_field& - &, old_sediment_field, new_sediment_field, sink_U, diagnostic_field - type(vector_field) :: U - type(scalar_field) :: masslump, sediment_field - integer :: n_sediment_fields,& - & i_field, i_bcs, i_node, ele, n_bcs, stat - integer, dimension(2) :: surface_id_count - integer, dimension(:), allocatable :: surface_ids - integer, dimension(:), pointer :: to_nodes, surface_element_list - real, dimension(:), allocatable :: values - character(len=FIELD_NAME_LEN) :: bc_name, bc_type - character(len=OPTION_PATH_LEN) :: bc_path - - ewrite(1,*) "In calculate_sediment_bedload" - - ! obtain some required model variables - n_sediment_fields = get_n_sediment_fields() - if (n_sediment_fields == 0) return - - X => extract_vector_field(state, "Coordinate") - gravity => extract_vector_field(state, "GravityDirection") - - new_U => extract_vector_field(state, "Velocity") - old_U => extract_vector_field(state, "OldVelocity") - call allocate(U, new_U%dim, new_U%mesh, name="CNVelocity") - call zero(U) - call addto(U, old_U, 0.5) - call addto(U, new_U, 0.5) - - ! allocate space for erosion and deposit field arrays - allocate(erosion(n_sediment_fields)) - allocate(deposited_sediment(n_sediment_fields)) - allocate(surface_mesh(n_sediment_fields)) - allocate(surface_nodes(n_sediment_fields)) - - ! first loop obtains eroded sediment quantities from reentrainment bc's (calculated - ! in sediment::set_sediment_reentrainment) - erosion_fields_loop: do i_field=1, n_sediment_fields - - ! obtain scalar fields for this sediment class - call get_sediment_item(state, i_field, new_sediment_field) - call get_sediment_item(state, i_field, "Bedload", bedload_field) - - ! generate a surface mesh for this field - call create_surface_mesh(surface_mesh(i_field), surface_nodes(i_field)%nodes, & - & mesh=bedload_field%mesh, name='SurfaceMesh') - - ! allocate a field that will hold the quantity of sediment eroded from the bed in - ! this timestep - call allocate(erosion(i_field), surface_mesh(i_field), "ErosionAmount") - call zero(erosion(i_field)) - - ! get boundary condition path and number of boundary conditions - bc_path = trim(new_sediment_field%option_path)//'/prognostic/boundary_conditions' - n_bcs = option_count(bc_path) - - ! Loop over boundary conditions for field - do i_bcs=0, n_bcs-1 - - ! Get name and type of boundary condition - call get_option(trim(bc_path)//"["//int2str(i_bcs)//"]"//"/name", bc_name) - call get_option(trim(bc_path)//"["//int2str(i_bcs)//"]"//"/type[0]/name", bc_type) - - ! find reentrainment boundary condition (if there is one) - if ((trim(bc_type) .eq. "sediment_reentrainment")) then - - ! get boundary condition info - call get_boundary_condition(new_sediment_field, name=bc_name, type=bc_type, & - surface_element_list=surface_element_list) - - ! get erosion flux - erosion_flux => extract_surface_field(new_sediment_field, bc_name=bc_name,& - & name="value") - - ! set erosion field values - allocate(values(erosion(i_field)%mesh%shape%loc)) - do ele=1,ele_count(erosion_flux) - to_nodes => ele_nodes(erosion(i_field), surface_element_list(ele)) - values = ele_val(erosion_flux,ele) - do i_node=1,size(to_nodes) - call set(erosion(i_field),to_nodes(i_node),values(i_node)) - end do - end do - - call scale(erosion(i_field),dt) - deallocate(values) - - end if - - end do - - end do erosion_fields_loop - - ! second loop calculates the amount of sediment that has been deposited during the - ! timestep - deposit_fields_loop: do i_field=1, n_sediment_fields - - ! obtain scalar fields for this sediment class - call get_sediment_item(state, i_field, old_sediment_field, old = .true.) - call get_sediment_item(state, i_field, new_sediment_field) - call allocate(sediment_field, new_sediment_field%mesh, name="CNSedimentField") - call zero(sediment_field) - call addto(sediment_field, old_sediment_field, 0.5) - call addto(sediment_field, new_sediment_field, 0.5) - call get_sediment_item(state, i_field, "Bedload", bedload_field) - call get_sediment_item(state, i_field, "SinkingVelocity", sink_U) - - ! allocate surface field that will contain the calculated deposited sediment for - ! this timestep - call allocate(deposited_sediment(i_field), surface_mesh(i_field), "DepositedSediment") - call zero(deposited_sediment(i_field)) - - ! For continuous fields we need a global lumped mass. For dg we'll - ! do the mass inversion on a per face basis inside the element loop. - if(continuity(surface_mesh(i_field))>=0) then - call allocate(masslump, surface_mesh(i_field), "SurfaceMassLump") - call zero(masslump) - end if - - ! obtain surface ids over which to record deposition - surface_id_count=option_shape(trim(bedload_field%option_path)//& - &"/prognostic/surface_ids") - allocate(surface_ids(surface_id_count(1))) - call get_option(trim(bedload_field%option_path)//"/prognostic/surface_ids", & - & surface_ids) - - ! loop through elements in surface field - elements: do ele=1,element_count(deposited_sediment(i_field)) - - ! check if element is on bedload surface - if (.not.any(surface_element_id(bedload_field, ele)& - &==surface_ids)) then - cycle elements - end if - - ! assemble bedload element - call assemble_sediment_flux_ele(ele, deposited_sediment,& - & sediment_field, X, U, sink_U, gravity, masslump, i_field) - - end do elements - - deallocate(surface_ids) - - ! For continuous fields we divide by the inverse global lumped mass - if(continuity(surface_mesh(i_field))>=0) then - where (masslump%val/=0.0) - masslump%val=1./masslump%val - end where - call scale(deposited_sediment(i_field), masslump) - call deallocate(masslump) - end if - - ! get erosion rate diagnostic field - call get_sediment_item(state, i_field, "BedloadDepositRate", diagnostic_field, stat) - if (stat == 0) then - call zero(diagnostic_field) - do i_node = 1, node_count(surface_mesh(i_field)) - call set(diagnostic_field, surface_nodes(i_field)%nodes(i_node), & - & node_val(deposited_sediment(i_field), i_node)) - end do - call scale(diagnostic_field, 1./dt) - end if - - call deallocate(sediment_field) - - end do deposit_fields_loop - - ! third loop to calculate net flux of sediment for this timestep - net_flux_loop: do i_field=1, n_sediment_fields - - ! obtain scalar fields for this sediment class - call get_sediment_item(state, i_field, "Bedload", bedload_field) - - if (.not. have_option(trim(bedload_field%option_path)//'/prognostic/disable_calculation')) then - ! Add on sediment falling in and subtract sediment coming out - do i_node = 1, node_count(surface_mesh(i_field)) - ! add deposited sediment - call addto(bedload_field, surface_nodes(i_field)%nodes(i_node), & - & node_val(deposited_sediment(i_field), i_node)) - ! remove eroded sediment - call addto(bedload_field, surface_nodes(i_field)%nodes(i_node), & - & -1.0 * node_val(erosion(i_field), i_node)) - end do - end if - - ewrite_minmax(deposited_sediment(i_field)) - ewrite_minmax(erosion(i_field)) - ewrite_minmax(bedload_field) - - call deallocate(deposited_sediment(i_field)) - call deallocate(erosion(i_field)) - call deallocate(surface_mesh(i_field)) - deallocate(surface_nodes(i_field)%nodes) - - end do net_flux_loop - - call deallocate(U) - deallocate(deposited_sediment) - deallocate(erosion) - deallocate(surface_mesh) - deallocate(surface_nodes) - - end subroutine calculate_sediment_flux - - subroutine assemble_sediment_flux_ele(ele, deposited_sediment, sediment_field,& - & X, U, sink_U, gravity, masslump, i_field) - - integer, intent(in) :: ele, i_field - type(scalar_field), dimension(:), intent(inout) :: deposited_sediment - type(vector_field), intent(in) :: X, U, gravity - type(scalar_field), intent(in) :: sink_U, sediment_field - type(scalar_field), intent(inout) :: masslump - - integer, dimension(:), pointer :: s_ele - real, dimension(ele_loc(deposited_sediment(i_field), ele), & - & ele_loc(deposited_sediment(i_field), ele)) :: invmass - real, dimension(ele_loc(deposited_sediment(i_field), ele)) :: flux - real, dimension(ele_ngi(deposited_sediment(i_field), ele)) :: detwei,& - & G_normal_detwei, U_sink_detwei - real, dimension(U%dim, ele_ngi(deposited_sediment(i_field), ele)) :: normal - type(element_type), pointer :: s_shape - - s_ele=>ele_nodes(deposited_sediment(i_field), ele) - s_shape=>ele_shape(deposited_sediment(i_field), ele) - - call transform_facet_to_physical(X, ele, detwei, normal) - - if(continuity(deposited_sediment(i_field))>=0) then - call addto(masslump, s_ele, & + subroutine calculate_sediment_flux(state) + !!< Calculate the advected flux of the sediment through the surfaces of + !!< the domain. + !!< This is determined based upon a fixed theta of 0.5 + !!< Currently erosion bc is calculated explicitly and the value is consistent here + type(state_type), intent(inout) :: state + type(mesh_type), dimension(:), allocatable :: surface_mesh + type surface_nodes_array + integer, dimension(:), pointer :: nodes + end type surface_nodes_array + type(surface_nodes_array), dimension(:), allocatable :: surface_nodes + type(vector_field), pointer :: X, old_U, new_U, gravity + type(scalar_field), dimension(:), allocatable :: deposited_sediment, erosion + type(scalar_field), pointer :: erosion_flux, bedload_field& + &, old_sediment_field, new_sediment_field, sink_U, diagnostic_field + type(vector_field) :: U + type(scalar_field) :: masslump, sediment_field + integer :: n_sediment_fields,& + & i_field, i_bcs, i_node, ele, n_bcs, stat + integer, dimension(2) :: surface_id_count + integer, dimension(:), allocatable :: surface_ids + integer, dimension(:), pointer :: to_nodes, surface_element_list + real, dimension(:), allocatable :: values + character(len=FIELD_NAME_LEN) :: bc_name, bc_type + character(len=OPTION_PATH_LEN) :: bc_path + + ewrite(1,*) "In calculate_sediment_bedload" + + ! obtain some required model variables + n_sediment_fields = get_n_sediment_fields() + if (n_sediment_fields == 0) return + + X => extract_vector_field(state, "Coordinate") + gravity => extract_vector_field(state, "GravityDirection") + + new_U => extract_vector_field(state, "Velocity") + old_U => extract_vector_field(state, "OldVelocity") + call allocate(U, new_U%dim, new_U%mesh, name="CNVelocity") + call zero(U) + call addto(U, old_U, 0.5) + call addto(U, new_U, 0.5) + + ! allocate space for erosion and deposit field arrays + allocate(erosion(n_sediment_fields)) + allocate(deposited_sediment(n_sediment_fields)) + allocate(surface_mesh(n_sediment_fields)) + allocate(surface_nodes(n_sediment_fields)) + + ! first loop obtains eroded sediment quantities from reentrainment bc's (calculated + ! in sediment::set_sediment_reentrainment) + erosion_fields_loop: do i_field=1, n_sediment_fields + + ! obtain scalar fields for this sediment class + call get_sediment_item(state, i_field, new_sediment_field) + call get_sediment_item(state, i_field, "Bedload", bedload_field) + + ! generate a surface mesh for this field + call create_surface_mesh(surface_mesh(i_field), surface_nodes(i_field)%nodes, & + & mesh=bedload_field%mesh, name='SurfaceMesh') + + ! allocate a field that will hold the quantity of sediment eroded from the bed in + ! this timestep + call allocate(erosion(i_field), surface_mesh(i_field), "ErosionAmount") + call zero(erosion(i_field)) + + ! get boundary condition path and number of boundary conditions + bc_path = trim(new_sediment_field%option_path)//'/prognostic/boundary_conditions' + n_bcs = option_count(bc_path) + + ! Loop over boundary conditions for field + do i_bcs=0, n_bcs-1 + + ! Get name and type of boundary condition + call get_option(trim(bc_path)//"["//int2str(i_bcs)//"]"//"/name", bc_name) + call get_option(trim(bc_path)//"["//int2str(i_bcs)//"]"//"/type[0]/name", bc_type) + + ! find reentrainment boundary condition (if there is one) + if ((trim(bc_type) .eq. "sediment_reentrainment")) then + + ! get boundary condition info + call get_boundary_condition(new_sediment_field, name=bc_name, type=bc_type, & + surface_element_list=surface_element_list) + + ! get erosion flux + erosion_flux => extract_surface_field(new_sediment_field, bc_name=bc_name,& + & name="value") + + ! set erosion field values + allocate(values(erosion(i_field)%mesh%shape%loc)) + do ele=1,ele_count(erosion_flux) + to_nodes => ele_nodes(erosion(i_field), surface_element_list(ele)) + values = ele_val(erosion_flux,ele) + do i_node=1,size(to_nodes) + call set(erosion(i_field),to_nodes(i_node),values(i_node)) + end do + end do + + call scale(erosion(i_field),dt) + deallocate(values) + + end if + + end do + + end do erosion_fields_loop + + ! second loop calculates the amount of sediment that has been deposited during the + ! timestep + deposit_fields_loop: do i_field=1, n_sediment_fields + + ! obtain scalar fields for this sediment class + call get_sediment_item(state, i_field, old_sediment_field, old = .true.) + call get_sediment_item(state, i_field, new_sediment_field) + call allocate(sediment_field, new_sediment_field%mesh, name="CNSedimentField") + call zero(sediment_field) + call addto(sediment_field, old_sediment_field, 0.5) + call addto(sediment_field, new_sediment_field, 0.5) + call get_sediment_item(state, i_field, "Bedload", bedload_field) + call get_sediment_item(state, i_field, "SinkingVelocity", sink_U) + + ! allocate surface field that will contain the calculated deposited sediment for + ! this timestep + call allocate(deposited_sediment(i_field), surface_mesh(i_field), "DepositedSediment") + call zero(deposited_sediment(i_field)) + + ! For continuous fields we need a global lumped mass. For dg we'll + ! do the mass inversion on a per face basis inside the element loop. + if(continuity(surface_mesh(i_field))>=0) then + call allocate(masslump, surface_mesh(i_field), "SurfaceMassLump") + call zero(masslump) + end if + + ! obtain surface ids over which to record deposition + surface_id_count=option_shape(trim(bedload_field%option_path)//& + &"/prognostic/surface_ids") + allocate(surface_ids(surface_id_count(1))) + call get_option(trim(bedload_field%option_path)//"/prognostic/surface_ids", & + & surface_ids) + + ! loop through elements in surface field + elements: do ele=1,element_count(deposited_sediment(i_field)) + + ! check if element is on bedload surface + if (.not.any(surface_element_id(bedload_field, ele)& + &==surface_ids)) then + cycle elements + end if + + ! assemble bedload element + call assemble_sediment_flux_ele(ele, deposited_sediment,& + & sediment_field, X, U, sink_U, gravity, masslump, i_field) + + end do elements + + deallocate(surface_ids) + + ! For continuous fields we divide by the inverse global lumped mass + if(continuity(surface_mesh(i_field))>=0) then + where (masslump%val/=0.0) + masslump%val=1./masslump%val + end where + call scale(deposited_sediment(i_field), masslump) + call deallocate(masslump) + end if + + ! get erosion rate diagnostic field + call get_sediment_item(state, i_field, "BedloadDepositRate", diagnostic_field, stat) + if (stat == 0) then + call zero(diagnostic_field) + do i_node = 1, node_count(surface_mesh(i_field)) + call set(diagnostic_field, surface_nodes(i_field)%nodes(i_node), & + & node_val(deposited_sediment(i_field), i_node)) + end do + call scale(diagnostic_field, 1./dt) + end if + + call deallocate(sediment_field) + + end do deposit_fields_loop + + ! third loop to calculate net flux of sediment for this timestep + net_flux_loop: do i_field=1, n_sediment_fields + + ! obtain scalar fields for this sediment class + call get_sediment_item(state, i_field, "Bedload", bedload_field) + + if (.not. have_option(trim(bedload_field%option_path)//'/prognostic/disable_calculation')) then + ! Add on sediment falling in and subtract sediment coming out + do i_node = 1, node_count(surface_mesh(i_field)) + ! add deposited sediment + call addto(bedload_field, surface_nodes(i_field)%nodes(i_node), & + & node_val(deposited_sediment(i_field), i_node)) + ! remove eroded sediment + call addto(bedload_field, surface_nodes(i_field)%nodes(i_node), & + & -1.0 * node_val(erosion(i_field), i_node)) + end do + end if + + ewrite_minmax(deposited_sediment(i_field)) + ewrite_minmax(erosion(i_field)) + ewrite_minmax(bedload_field) + + call deallocate(deposited_sediment(i_field)) + call deallocate(erosion(i_field)) + call deallocate(surface_mesh(i_field)) + deallocate(surface_nodes(i_field)%nodes) + + end do net_flux_loop + + call deallocate(U) + deallocate(deposited_sediment) + deallocate(erosion) + deallocate(surface_mesh) + deallocate(surface_nodes) + + end subroutine calculate_sediment_flux + + subroutine assemble_sediment_flux_ele(ele, deposited_sediment, sediment_field,& + & X, U, sink_U, gravity, masslump, i_field) + + integer, intent(in) :: ele, i_field + type(scalar_field), dimension(:), intent(inout) :: deposited_sediment + type(vector_field), intent(in) :: X, U, gravity + type(scalar_field), intent(in) :: sink_U, sediment_field + type(scalar_field), intent(inout) :: masslump + + integer, dimension(:), pointer :: s_ele + real, dimension(ele_loc(deposited_sediment(i_field), ele), & + & ele_loc(deposited_sediment(i_field), ele)) :: invmass + real, dimension(ele_loc(deposited_sediment(i_field), ele)) :: flux + real, dimension(ele_ngi(deposited_sediment(i_field), ele)) :: detwei,& + & G_normal_detwei, U_sink_detwei + real, dimension(U%dim, ele_ngi(deposited_sediment(i_field), ele)) :: normal + type(element_type), pointer :: s_shape + + s_ele=>ele_nodes(deposited_sediment(i_field), ele) + s_shape=>ele_shape(deposited_sediment(i_field), ele) + + call transform_facet_to_physical(X, ele, detwei, normal) + + if(continuity(deposited_sediment(i_field))>=0) then + call addto(masslump, s_ele, & sum(shape_shape(s_shape, s_shape, detwei), 1)) - else - ! In the DG case we will apply the inverse mass locally. - invmass=inverse(shape_shape(s_shape, s_shape, detwei)) - end if + else + ! In the DG case we will apply the inverse mass locally. + invmass=inverse(shape_shape(s_shape, s_shape, detwei)) + end if - G_normal_detwei=sum(face_val_at_quad(gravity,ele)*normal,1)*detwei - U_sink_detwei=G_normal_detwei*face_val_at_quad(sink_U,ele) + G_normal_detwei=sum(face_val_at_quad(gravity,ele)*normal,1)*detwei + U_sink_detwei=G_normal_detwei*face_val_at_quad(sink_U,ele) - flux=dt*shape_rhs(s_shape, & + flux=dt*shape_rhs(s_shape, & face_val_at_quad(sediment_field, ele)*U_sink_detwei) - if(continuity(deposited_sediment(i_field))<0) then - ! DG case. - flux=matmul(invmass, flux) - end if + if(continuity(deposited_sediment(i_field))<0) then + ! DG case. + flux=matmul(invmass, flux) + end if - call addto(deposited_sediment(i_field), s_ele, flux) + call addto(deposited_sediment(i_field), s_ele, flux) - end subroutine assemble_sediment_flux_ele + end subroutine assemble_sediment_flux_ele - subroutine calculate_sediment_sinking_velocity(state) + subroutine calculate_sediment_sinking_velocity(state) - type(state_type), intent(inout) :: state + type(state_type), intent(inout) :: state - type(scalar_field_pointer), dimension(:), allocatable :: sediment_concs - type(scalar_field), pointer :: unhindered_sink_u, sink_u - type(vector_field), pointer :: X - type(scalar_field) :: rhs, rhs_projection - integer :: n_sediment_fields,& - & i_field, i_node + type(scalar_field_pointer), dimension(:), allocatable :: sediment_concs + type(scalar_field), pointer :: unhindered_sink_u, sink_u + type(vector_field), pointer :: X + type(scalar_field) :: rhs, rhs_projection + integer :: n_sediment_fields,& + & i_field, i_node - ewrite(1,*) 'In calculate sediment sinking velocities' + ewrite(1,*) 'In calculate sediment sinking velocities' - n_sediment_fields = get_n_sediment_fields() + n_sediment_fields = get_n_sediment_fields() - allocate(sediment_concs(n_sediment_fields)) + allocate(sediment_concs(n_sediment_fields)) - ! allocate storage for rhs and set all to 1 - call get_sediment_item(state, 1, sediment_concs(1)%ptr) - call allocate(rhs, sediment_concs(1)%ptr%mesh, name="Rhs") - call set(rhs, 1.0) + ! allocate storage for rhs and set all to 1 + call get_sediment_item(state, 1, sediment_concs(1)%ptr) + call allocate(rhs, sediment_concs(1)%ptr%mesh, name="Rhs") + call set(rhs, 1.0) - ! get sediment concentrations and remove from rhs - do i_field=1, n_sediment_fields - call get_sediment_item(state, i_field, sediment_concs(i_field)%ptr) - call addto(rhs, sediment_concs(i_field)%ptr, scale=-1.0) - end do + ! get sediment concentrations and remove from rhs + do i_field=1, n_sediment_fields + call get_sediment_item(state, i_field, sediment_concs(i_field)%ptr) + call addto(rhs, sediment_concs(i_field)%ptr, scale=-1.0) + end do - ! raise rhs to power of 2.39 - do i_node = 1, node_count(rhs) - if (node_val(rhs, i_node) > 1e-3) then - call set(rhs, i_node, node_val(rhs, i_node)**2.39) - else - call set(rhs, i_node, 1e-3**2.39) - end if - end do + ! raise rhs to power of 2.39 + do i_node = 1, node_count(rhs) + if (node_val(rhs, i_node) > 1e-3) then + call set(rhs, i_node, node_val(rhs, i_node)**2.39) + else + call set(rhs, i_node, 1e-3**2.39) + end if + end do - do i_field=1, n_sediment_fields + do i_field=1, n_sediment_fields - ! check for diagnostic sinking velocity - if (have_option(trim(sediment_concs(i_field)%ptr%option_path)// & - &'/prognostic/scalar_field::SinkingVelocity/diagnostic')) then + ! check for diagnostic sinking velocity + if (have_option(trim(sediment_concs(i_field)%ptr%option_path)// & + &'/prognostic/scalar_field::SinkingVelocity/diagnostic')) then - ewrite(2,*) 'Calculating diagnostic sink velocity for sediment field: ' //& - & trim(sediment_concs(i_field)%ptr%name) + ewrite(2,*) 'Calculating diagnostic sink velocity for sediment field: ' //& + & trim(sediment_concs(i_field)%ptr%name) - ! check for presence of unhindered sinking velocity value - if (.not. have_option(trim(sediment_concs(i_field)%ptr%option_path)// & + ! check for presence of unhindered sinking velocity value + if (.not. have_option(trim(sediment_concs(i_field)%ptr%option_path)// & &'/prognostic/scalar_field::UnhinderedSinkingVelocity')) then - FLExit('You must specify an unhindered sinking velocity field to be able to calculate diagnostic sinking velocity field values for sediments') - endif - - unhindered_sink_u => extract_scalar_field(state, & - & trim(sediment_concs(i_field)%ptr%name)//'UnhinderedSinkingVelocity') - ewrite_minmax(unhindered_sink_u) - - sink_u => extract_scalar_field(state, & - & trim(sediment_concs(i_field)%ptr%name)//'SinkingVelocity') - - ! calculate hindered sinking velocity - call set(sink_u, unhindered_sink_u) - if (rhs%mesh==sink_u%mesh) then - call scale(sink_u, rhs) - else - call allocate(rhs_projection, sink_u%mesh, name="RhsProjection") - X => extract_vector_field(state, 'Coordinate') - call project_field(rhs, rhs_projection, X) - call scale(sink_u, rhs_projection) - call deallocate(rhs_projection) - end if - ewrite_minmax(sink_u) - endif - - end do - - call deallocate(rhs) - deallocate(sediment_concs) - - end subroutine calculate_sediment_sinking_velocity - - subroutine calculate_sediment_active_layer_d50(state) - - type(state_type), intent(inout) :: state - type(scalar_field), pointer :: d50 - type(scalar_field) :: total_bedload - type(scalar_field_pointer), dimension(:), allocatable :: sorted_bedload - real, dimension(:), allocatable :: sorted_diameter - type(scalar_field_pointer) :: temp_bedload - real :: temp_diameter - real :: cumulative_bedload - logical :: sorted = .false. - integer :: i_field, n_fields, i_node, stat - real :: min_bedload = 1.0e-20 - - ewrite(1,*) 'In calculate sediment_active_layer_d50' - - d50 => extract_scalar_field(state, 'SedimentBedActiveLayerD50', stat) - if (stat /= 0) return - - n_fields = get_n_sediment_fields() - - allocate(sorted_bedload(n_fields)) - allocate(sorted_diameter(n_fields)) - - do i_field = 1, n_fields - call get_sediment_item(state, i_field, 'diameter', sorted_diameter(i_field), stat) - if (stat /= 0) FLExit('All sediment fields must have a diameter to be able to calculate the SedimentBedActiveLayerD50') - call get_sediment_item(state, i_field, 'Bedload', sorted_bedload(i_field)& - &%ptr, stat) - end do - - do while (.not. sorted) - sorted = .true. - do i_field = 2, n_fields - if (sorted_diameter(i_field-1) > sorted_diameter(i_field)) then - temp_diameter = sorted_diameter(i_field) - sorted_diameter(i_field) = sorted_diameter(i_field-1) - sorted_diameter(i_field-1) = temp_diameter - temp_bedload = sorted_bedload(i_field) - sorted_bedload(i_field) = sorted_bedload(i_field-1) - sorted_bedload(i_field-1) = temp_bedload - sorted = .false. - end if - end do - end do - - call allocate(total_bedload, sorted_bedload(1)%ptr%mesh, 'TotalBedload') - call zero(d50) - call zero(total_bedload) - - do i_field = 1, n_fields - call addto(total_bedload, sorted_bedload(i_field)%ptr) - end do - - nodes: do i_node = 1, node_count(d50) - - if (node_val(total_bedload, i_node) > min_bedload) then - i_field = 0 - cumulative_bedload = 0.0 - do while (cumulative_bedload < 0.5*node_val(total_bedload, i_node)) - i_field = i_field + 1 - cumulative_bedload = cumulative_bedload + node_val(sorted_bedload(i_field)%ptr,& - & i_node) - end do - call set(d50, i_node, sorted_diameter(i_field)) - else - call set(d50, i_node, 0.0) - end if - - end do nodes - - ewrite_minmax(d50) - - deallocate(sorted_diameter) - deallocate(sorted_bedload) - call deallocate(total_bedload) - - end subroutine calculate_sediment_active_layer_d50 - - subroutine calculate_sediment_active_layer_sigma(state) - - type(state_type), intent(inout) :: state - type(scalar_field), pointer :: sigma - type(mesh_type) :: surface_mesh - integer, dimension(:), pointer :: surface_node_list - type(vector_field), pointer :: x - type(scalar_field_pointer), dimension(:), allocatable :: bedload - real, dimension(:), allocatable :: diameter - type(scalar_field) :: mean, & - & masslump, sigma_surface - integer :: n_fields, i_field, i_ele,& - & i_node, stat - integer, dimension(2) :: surface_id_count - integer, dimension(:), allocatable :: surface_ids - - ewrite(1,*) 'In calculate_sediment_active_layer_sigma' - - sigma => extract_scalar_field(state, 'SedimentBedActiveLayerSigma', stat) - if (stat /= 0) return - x => extract_vector_field(state, 'Coordinate') - - n_fields = get_n_sediment_fields() - allocate(bedload(n_fields)) - allocate(diameter(n_fields)) - - ! collect information required to calculate standard deviation - data_collection_loop: do i_field = 1, n_fields - call get_sediment_item(state, i_field, 'diameter', diameter(i_field), stat) - if (stat /= 0) FLExit('All sediment fields must have a diameter to be able to calculate the SedimentBedActiveLayerSigma') - call get_sediment_item(state, i_field, 'Bedload', bedload(i_field)%ptr) - end do data_collection_loop - - ! allocate surface field that will contain the calculated sigma values - call create_surface_mesh(surface_mesh, surface_node_list, mesh=sigma%mesh, & - &name='SurfaceMesh') - call allocate(sigma_surface, surface_mesh, 'SigmaSurface') - call zero(sigma_surface) - - ! For continuous fields we need a global lumped mass. For dg we'll - ! do the mass inversion on a per face basis inside the element loop. - if(continuity(sigma_surface)>=0) then - call allocate(masslump, surface_mesh, 'SurfaceMassLump') - call zero(masslump) - end if - - ! obtain surface ids over which to calculate sigma - surface_id_count=option_shape(trim(sigma%option_path)//'/diagnostic/surface_ids') - allocate(surface_ids(surface_id_count(1))) - call get_option(trim(sigma%option_path)//'/diagnostic/surface_ids', surface_ids) - - ! loop through elements in surface field - elements: do i_ele=1, element_count(sigma_surface) - - ! check if element is on prescribed surface - if (.not.any(surface_element_id(sigma, i_ele) == surface_ids)) then - cycle elements - end if - - ! calculate sigma - call calculate_sediment_active_layer_element_sigma(i_ele, sigma_surface, bedload,& - & masslump, x, diameter, n_fields) - - end do elements - - ! For continuous fields we divide by the inverse global lumped mass - if(continuity(surface_mesh)>=0) then - where (masslump%val/=0.0) - masslump%val=1./masslump%val - end where - call scale(sigma_surface, masslump) - call deallocate(masslump) - end if - - ! remap surface node values on to sigma field - do i_node = 1, node_count(surface_mesh) - call set(sigma, surface_node_list(i_node), node_val(sigma_surface, i_node)) - end do - - ewrite_minmax(sigma) - - deallocate(bedload) - deallocate(diameter) - call deallocate(sigma_surface) - call deallocate(surface_mesh) - deallocate(surface_node_list) - deallocate(surface_ids) - - end subroutine calculate_sediment_active_layer_sigma - - subroutine calculate_sediment_active_layer_element_sigma(i_ele, sigma_surface, bedload,& - & masslump, x, diameter, n_fields) - - integer, intent(in) :: i_ele - type(scalar_field), intent(inout) :: sigma_surface - type(scalar_field_pointer), dimension(:), intent(in) :: bedload - type(scalar_field), intent(inout) :: masslump - type(vector_field), pointer, intent(in) :: x - real, dimension(:), intent(in) :: diameter - integer, intent(in) :: n_fields - integer, dimension(:), pointer :: ele - type(element_type), pointer :: shape - real, dimension(ele_loc(sigma_surface, i_ele), & - & ele_loc(sigma_surface, i_ele)) :: invmass - real, dimension(ele_ngi(sigma_surface, i_ele)) :: detwei, total_bedload, & - & mean_diameter, sigma_squared - real, dimension(ele_loc(sigma_surface, i_ele)) :: sigma - integer :: i_field, i_gi - real :: min_bedload = 1.0e-20 - - ele => ele_nodes(sigma_surface, i_ele) - shape => ele_shape(sigma_surface, i_ele) - - call transform_facet_to_physical(x, i_ele, detwei) - - if(continuity(sigma_surface)>=0) then - call addto(masslump, ele, & + FLExit('You must specify an unhindered sinking velocity field to be able to calculate diagnostic sinking velocity field values for sediments') + endif + + unhindered_sink_u => extract_scalar_field(state, & + & trim(sediment_concs(i_field)%ptr%name)//'UnhinderedSinkingVelocity') + ewrite_minmax(unhindered_sink_u) + + sink_u => extract_scalar_field(state, & + & trim(sediment_concs(i_field)%ptr%name)//'SinkingVelocity') + + ! calculate hindered sinking velocity + call set(sink_u, unhindered_sink_u) + if (rhs%mesh==sink_u%mesh) then + call scale(sink_u, rhs) + else + call allocate(rhs_projection, sink_u%mesh, name="RhsProjection") + X => extract_vector_field(state, 'Coordinate') + call project_field(rhs, rhs_projection, X) + call scale(sink_u, rhs_projection) + call deallocate(rhs_projection) + end if + ewrite_minmax(sink_u) + endif + + end do + + call deallocate(rhs) + deallocate(sediment_concs) + + end subroutine calculate_sediment_sinking_velocity + + subroutine calculate_sediment_active_layer_d50(state) + + type(state_type), intent(inout) :: state + type(scalar_field), pointer :: d50 + type(scalar_field) :: total_bedload + type(scalar_field_pointer), dimension(:), allocatable :: sorted_bedload + real, dimension(:), allocatable :: sorted_diameter + type(scalar_field_pointer) :: temp_bedload + real :: temp_diameter + real :: cumulative_bedload + logical :: sorted = .false. + integer :: i_field, n_fields, i_node, stat + real :: min_bedload = 1.0e-20 + + ewrite(1,*) 'In calculate sediment_active_layer_d50' + + d50 => extract_scalar_field(state, 'SedimentBedActiveLayerD50', stat) + if (stat /= 0) return + + n_fields = get_n_sediment_fields() + + allocate(sorted_bedload(n_fields)) + allocate(sorted_diameter(n_fields)) + + do i_field = 1, n_fields + call get_sediment_item(state, i_field, 'diameter', sorted_diameter(i_field), stat) + if (stat /= 0) FLExit('All sediment fields must have a diameter to be able to calculate the SedimentBedActiveLayerD50') + call get_sediment_item(state, i_field, 'Bedload', sorted_bedload(i_field)& + &%ptr, stat) + end do + + do while (.not. sorted) + sorted = .true. + do i_field = 2, n_fields + if (sorted_diameter(i_field-1) > sorted_diameter(i_field)) then + temp_diameter = sorted_diameter(i_field) + sorted_diameter(i_field) = sorted_diameter(i_field-1) + sorted_diameter(i_field-1) = temp_diameter + temp_bedload = sorted_bedload(i_field) + sorted_bedload(i_field) = sorted_bedload(i_field-1) + sorted_bedload(i_field-1) = temp_bedload + sorted = .false. + end if + end do + end do + + call allocate(total_bedload, sorted_bedload(1)%ptr%mesh, 'TotalBedload') + call zero(d50) + call zero(total_bedload) + + do i_field = 1, n_fields + call addto(total_bedload, sorted_bedload(i_field)%ptr) + end do + + nodes: do i_node = 1, node_count(d50) + + if (node_val(total_bedload, i_node) > min_bedload) then + i_field = 0 + cumulative_bedload = 0.0 + do while (cumulative_bedload < 0.5*node_val(total_bedload, i_node)) + i_field = i_field + 1 + cumulative_bedload = cumulative_bedload + node_val(sorted_bedload(i_field)%ptr,& + & i_node) + end do + call set(d50, i_node, sorted_diameter(i_field)) + else + call set(d50, i_node, 0.0) + end if + + end do nodes + + ewrite_minmax(d50) + + deallocate(sorted_diameter) + deallocate(sorted_bedload) + call deallocate(total_bedload) + + end subroutine calculate_sediment_active_layer_d50 + + subroutine calculate_sediment_active_layer_sigma(state) + + type(state_type), intent(inout) :: state + type(scalar_field), pointer :: sigma + type(mesh_type) :: surface_mesh + integer, dimension(:), pointer :: surface_node_list + type(vector_field), pointer :: x + type(scalar_field_pointer), dimension(:), allocatable :: bedload + real, dimension(:), allocatable :: diameter + type(scalar_field) :: mean, & + & masslump, sigma_surface + integer :: n_fields, i_field, i_ele,& + & i_node, stat + integer, dimension(2) :: surface_id_count + integer, dimension(:), allocatable :: surface_ids + + ewrite(1,*) 'In calculate_sediment_active_layer_sigma' + + sigma => extract_scalar_field(state, 'SedimentBedActiveLayerSigma', stat) + if (stat /= 0) return + x => extract_vector_field(state, 'Coordinate') + + n_fields = get_n_sediment_fields() + allocate(bedload(n_fields)) + allocate(diameter(n_fields)) + + ! collect information required to calculate standard deviation + data_collection_loop: do i_field = 1, n_fields + call get_sediment_item(state, i_field, 'diameter', diameter(i_field), stat) + if (stat /= 0) FLExit('All sediment fields must have a diameter to be able to calculate the SedimentBedActiveLayerSigma') + call get_sediment_item(state, i_field, 'Bedload', bedload(i_field)%ptr) + end do data_collection_loop + + ! allocate surface field that will contain the calculated sigma values + call create_surface_mesh(surface_mesh, surface_node_list, mesh=sigma%mesh, & + &name='SurfaceMesh') + call allocate(sigma_surface, surface_mesh, 'SigmaSurface') + call zero(sigma_surface) + + ! For continuous fields we need a global lumped mass. For dg we'll + ! do the mass inversion on a per face basis inside the element loop. + if(continuity(sigma_surface)>=0) then + call allocate(masslump, surface_mesh, 'SurfaceMassLump') + call zero(masslump) + end if + + ! obtain surface ids over which to calculate sigma + surface_id_count=option_shape(trim(sigma%option_path)//'/diagnostic/surface_ids') + allocate(surface_ids(surface_id_count(1))) + call get_option(trim(sigma%option_path)//'/diagnostic/surface_ids', surface_ids) + + ! loop through elements in surface field + elements: do i_ele=1, element_count(sigma_surface) + + ! check if element is on prescribed surface + if (.not.any(surface_element_id(sigma, i_ele) == surface_ids)) then + cycle elements + end if + + ! calculate sigma + call calculate_sediment_active_layer_element_sigma(i_ele, sigma_surface, bedload,& + & masslump, x, diameter, n_fields) + + end do elements + + ! For continuous fields we divide by the inverse global lumped mass + if(continuity(surface_mesh)>=0) then + where (masslump%val/=0.0) + masslump%val=1./masslump%val + end where + call scale(sigma_surface, masslump) + call deallocate(masslump) + end if + + ! remap surface node values on to sigma field + do i_node = 1, node_count(surface_mesh) + call set(sigma, surface_node_list(i_node), node_val(sigma_surface, i_node)) + end do + + ewrite_minmax(sigma) + + deallocate(bedload) + deallocate(diameter) + call deallocate(sigma_surface) + call deallocate(surface_mesh) + deallocate(surface_node_list) + deallocate(surface_ids) + + end subroutine calculate_sediment_active_layer_sigma + + subroutine calculate_sediment_active_layer_element_sigma(i_ele, sigma_surface, bedload,& + & masslump, x, diameter, n_fields) + + integer, intent(in) :: i_ele + type(scalar_field), intent(inout) :: sigma_surface + type(scalar_field_pointer), dimension(:), intent(in) :: bedload + type(scalar_field), intent(inout) :: masslump + type(vector_field), pointer, intent(in) :: x + real, dimension(:), intent(in) :: diameter + integer, intent(in) :: n_fields + integer, dimension(:), pointer :: ele + type(element_type), pointer :: shape + real, dimension(ele_loc(sigma_surface, i_ele), & + & ele_loc(sigma_surface, i_ele)) :: invmass + real, dimension(ele_ngi(sigma_surface, i_ele)) :: detwei, total_bedload, & + & mean_diameter, sigma_squared + real, dimension(ele_loc(sigma_surface, i_ele)) :: sigma + integer :: i_field, i_gi + real :: min_bedload = 1.0e-20 + + ele => ele_nodes(sigma_surface, i_ele) + shape => ele_shape(sigma_surface, i_ele) + + call transform_facet_to_physical(x, i_ele, detwei) + + if(continuity(sigma_surface)>=0) then + call addto(masslump, ele, & sum(shape_shape(shape, shape, detwei), 1)) - else - ! In the DG case we will apply the inverse mass locally. - invmass=inverse(shape_shape(shape, shape, detwei)) - end if - - do i_gi = 1, ele_ngi(sigma_surface, i_ele) - total_bedload(i_gi) = 0.0 - mean_diameter(i_gi) = 0.0 - sigma_squared(i_gi) = 0.0 - end do - - mean_calculation_loop: do i_field = 1, n_fields - total_bedload = total_bedload + face_val_at_quad(bedload(i_field)%ptr, i_ele) - mean_diameter = mean_diameter + face_val_at_quad(bedload(i_field)%ptr, i_ele) & + else + ! In the DG case we will apply the inverse mass locally. + invmass=inverse(shape_shape(shape, shape, detwei)) + end if + + do i_gi = 1, ele_ngi(sigma_surface, i_ele) + total_bedload(i_gi) = 0.0 + mean_diameter(i_gi) = 0.0 + sigma_squared(i_gi) = 0.0 + end do + + mean_calculation_loop: do i_field = 1, n_fields + total_bedload = total_bedload + face_val_at_quad(bedload(i_field)%ptr, i_ele) + mean_diameter = mean_diameter + face_val_at_quad(bedload(i_field)%ptr, i_ele) & *diameter(i_field) - end do mean_calculation_loop - where ((total_bedload > min_bedload)) - mean_diameter = mean_diameter / total_bedload - elsewhere - mean_diameter = 0.0 - end where - - sigma_calculation_loop: do i_field = 1, n_fields - sigma_squared = sigma_squared + face_val_at_quad(bedload(i_field)%ptr, i_ele) & + end do mean_calculation_loop + where ((total_bedload > min_bedload)) + mean_diameter = mean_diameter / total_bedload + elsewhere + mean_diameter = 0.0 + end where + + sigma_calculation_loop: do i_field = 1, n_fields + sigma_squared = sigma_squared + face_val_at_quad(bedload(i_field)%ptr, i_ele) & *(diameter(i_field) - mean_diameter)**2.0 - end do sigma_calculation_loop - where ((total_bedload > min_bedload)) - sigma_squared = sigma_squared / total_bedload - elsewhere - sigma_squared = 0.0 - end where - sigma = shape_rhs(shape, dsqrt(sigma_squared) * detwei) - - if(continuity(sigma_surface)<0) then - ! DG case. - sigma = matmul(invmass, sigma) - end if - - call addto(sigma_surface, ele, sigma) - - end subroutine calculate_sediment_active_layer_element_sigma - - subroutine calculate_sediment_active_layer_volume_fractions(state) - - type(state_type), intent(inout) :: state - type(scalar_field), pointer :: volume_fraction, bedload - type(mesh_type) :: surface_mesh - integer, dimension(:), pointer :: surface_node_list - type(vector_field), pointer :: x - type(scalar_field) :: total_bedload,& - & volume_fraction_surface, masslump - integer :: n_fields, i_field, i_ele,& - & i_node - integer, dimension(2) :: surface_id_count - integer, dimension(:), allocatable :: surface_ids - - ewrite(1,*) 'In calculate_sediment_active_layer_volume_fractions' - - x => extract_vector_field(state, 'Coordinate') - - n_fields = get_n_sediment_fields() - - ! calculate combined bedload - data_collection_loop: do i_field = 1, n_fields - call get_sediment_item(state, i_field, 'Bedload', bedload) - if (i_field == 1) then - call allocate(total_bedload, bedload%mesh, 'TotalBedload') - call zero(total_bedload) - end if - call addto(total_bedload, bedload) - end do data_collection_loop - - calculation_loop: do i_field = 1, n_fields - - ! get sediment bedload and volume fraction fields - call get_sediment_item(state, i_field, 'Bedload', bedload) - call get_sediment_item(state, i_field, 'BedloadVolumeFraction', volume_fraction) - - ! generate surface_mesh for calculation of volume fraction and create surface field - call create_surface_mesh(surface_mesh, surface_node_list, & - & mesh=bedload%mesh, name='SurfaceMesh') - call allocate(volume_fraction_surface, surface_mesh, 'VolumeFraction') - call zero(volume_fraction_surface) - - ! For continuous fields we need a global lumped mass. For dg we'll - ! do the mass inversion on a per face basis inside the element loop. - if(continuity(volume_fraction_surface)>=0) then - call allocate(masslump, surface_mesh, 'SurfaceMassLump') - call zero(masslump) - end if - - ! obtain sediment bedload surface ids - surface_id_count=option_shape(trim(bedload%option_path)//& - &"/prognostic/surface_ids") - allocate(surface_ids(surface_id_count(1))) - call get_option(trim(bedload%option_path)//"/prognostic/surface_ids", & - & surface_ids) - - ! loop through elements in surface field - elements: do i_ele=1, element_count(volume_fraction_surface) - - ! check if element is on prescribed surface - if (.not.any(surface_element_id(volume_fraction, i_ele) == surface_ids)) then - cycle elements - end if - - ! calculate volume_fraction - call calculate_sediment_active_layer_element_volume_fractions(i_ele,& - & volume_fraction_surface, bedload, total_bedload, masslump, x) - - end do elements - - ! For continuous fields we divide by the inverse global lumped mass - if(continuity(volume_fraction_surface)>=0) then - where (masslump%val/=0.0) - masslump%val=1./masslump%val - end where - call scale(volume_fraction_surface, masslump) - call deallocate(masslump) - end if - - ! remap surface node values on to sigma field - do i_node = 1, node_count(surface_mesh) - call set(volume_fraction, surface_node_list(i_node),& - & node_val(volume_fraction_surface, i_node)) - end do - - ewrite_minmax(volume_fraction) - - call deallocate(volume_fraction_surface) - call deallocate(surface_mesh) - deallocate(surface_node_list) - deallocate(surface_ids) - - end do calculation_loop - - call deallocate(total_bedload) - - end subroutine calculate_sediment_active_layer_volume_fractions - - subroutine calculate_sediment_active_layer_element_volume_fractions(i_ele,& - & volume_fraction_surface, bedload, total_bedload, masslump, x) - - integer, intent(in) :: i_ele - type(scalar_field), intent(inout) :: volume_fraction_surface - type(scalar_field), intent(in) :: bedload, total_bedload - type(scalar_field), intent(inout) :: masslump - type(vector_field), pointer, intent(in) :: x - integer, dimension(:), pointer :: ele - type(element_type), pointer :: shape - real, dimension(ele_loc(volume_fraction_surface, i_ele), & - & ele_loc(volume_fraction_surface, i_ele)) :: invmass - real, dimension(ele_ngi(volume_fraction_surface, i_ele)) :: detwei, & - & volume_fraction_at_quad - real, dimension(ele_loc(volume_fraction_surface, i_ele)) :: volume_fraction - real :: min_bedload = 1.0e-20 - - ele => ele_nodes(volume_fraction_surface, i_ele) - shape => ele_shape(volume_fraction_surface, i_ele) - - call transform_facet_to_physical(x, i_ele, detwei) - - if(continuity(volume_fraction_surface)>=0) then - call addto(masslump, ele, & + end do sigma_calculation_loop + where ((total_bedload > min_bedload)) + sigma_squared = sigma_squared / total_bedload + elsewhere + sigma_squared = 0.0 + end where + sigma = shape_rhs(shape, dsqrt(sigma_squared) * detwei) + + if(continuity(sigma_surface)<0) then + ! DG case. + sigma = matmul(invmass, sigma) + end if + + call addto(sigma_surface, ele, sigma) + + end subroutine calculate_sediment_active_layer_element_sigma + + subroutine calculate_sediment_active_layer_volume_fractions(state) + + type(state_type), intent(inout) :: state + type(scalar_field), pointer :: volume_fraction, bedload + type(mesh_type) :: surface_mesh + integer, dimension(:), pointer :: surface_node_list + type(vector_field), pointer :: x + type(scalar_field) :: total_bedload,& + & volume_fraction_surface, masslump + integer :: n_fields, i_field, i_ele,& + & i_node + integer, dimension(2) :: surface_id_count + integer, dimension(:), allocatable :: surface_ids + + ewrite(1,*) 'In calculate_sediment_active_layer_volume_fractions' + + x => extract_vector_field(state, 'Coordinate') + + n_fields = get_n_sediment_fields() + + ! calculate combined bedload + data_collection_loop: do i_field = 1, n_fields + call get_sediment_item(state, i_field, 'Bedload', bedload) + if (i_field == 1) then + call allocate(total_bedload, bedload%mesh, 'TotalBedload') + call zero(total_bedload) + end if + call addto(total_bedload, bedload) + end do data_collection_loop + + calculation_loop: do i_field = 1, n_fields + + ! get sediment bedload and volume fraction fields + call get_sediment_item(state, i_field, 'Bedload', bedload) + call get_sediment_item(state, i_field, 'BedloadVolumeFraction', volume_fraction) + + ! generate surface_mesh for calculation of volume fraction and create surface field + call create_surface_mesh(surface_mesh, surface_node_list, & + & mesh=bedload%mesh, name='SurfaceMesh') + call allocate(volume_fraction_surface, surface_mesh, 'VolumeFraction') + call zero(volume_fraction_surface) + + ! For continuous fields we need a global lumped mass. For dg we'll + ! do the mass inversion on a per face basis inside the element loop. + if(continuity(volume_fraction_surface)>=0) then + call allocate(masslump, surface_mesh, 'SurfaceMassLump') + call zero(masslump) + end if + + ! obtain sediment bedload surface ids + surface_id_count=option_shape(trim(bedload%option_path)//& + &"/prognostic/surface_ids") + allocate(surface_ids(surface_id_count(1))) + call get_option(trim(bedload%option_path)//"/prognostic/surface_ids", & + & surface_ids) + + ! loop through elements in surface field + elements: do i_ele=1, element_count(volume_fraction_surface) + + ! check if element is on prescribed surface + if (.not.any(surface_element_id(volume_fraction, i_ele) == surface_ids)) then + cycle elements + end if + + ! calculate volume_fraction + call calculate_sediment_active_layer_element_volume_fractions(i_ele,& + & volume_fraction_surface, bedload, total_bedload, masslump, x) + + end do elements + + ! For continuous fields we divide by the inverse global lumped mass + if(continuity(volume_fraction_surface)>=0) then + where (masslump%val/=0.0) + masslump%val=1./masslump%val + end where + call scale(volume_fraction_surface, masslump) + call deallocate(masslump) + end if + + ! remap surface node values on to sigma field + do i_node = 1, node_count(surface_mesh) + call set(volume_fraction, surface_node_list(i_node),& + & node_val(volume_fraction_surface, i_node)) + end do + + ewrite_minmax(volume_fraction) + + call deallocate(volume_fraction_surface) + call deallocate(surface_mesh) + deallocate(surface_node_list) + deallocate(surface_ids) + + end do calculation_loop + + call deallocate(total_bedload) + + end subroutine calculate_sediment_active_layer_volume_fractions + + subroutine calculate_sediment_active_layer_element_volume_fractions(i_ele,& + & volume_fraction_surface, bedload, total_bedload, masslump, x) + + integer, intent(in) :: i_ele + type(scalar_field), intent(inout) :: volume_fraction_surface + type(scalar_field), intent(in) :: bedload, total_bedload + type(scalar_field), intent(inout) :: masslump + type(vector_field), pointer, intent(in) :: x + integer, dimension(:), pointer :: ele + type(element_type), pointer :: shape + real, dimension(ele_loc(volume_fraction_surface, i_ele), & + & ele_loc(volume_fraction_surface, i_ele)) :: invmass + real, dimension(ele_ngi(volume_fraction_surface, i_ele)) :: detwei, & + & volume_fraction_at_quad + real, dimension(ele_loc(volume_fraction_surface, i_ele)) :: volume_fraction + real :: min_bedload = 1.0e-20 + + ele => ele_nodes(volume_fraction_surface, i_ele) + shape => ele_shape(volume_fraction_surface, i_ele) + + call transform_facet_to_physical(x, i_ele, detwei) + + if(continuity(volume_fraction_surface)>=0) then + call addto(masslump, ele, & sum(shape_shape(shape, shape, detwei), 1)) - else - ! In the DG case we will apply the inverse mass locally. - invmass=inverse(shape_shape(shape, shape, detwei)) - end if - - where (face_val_at_quad(total_bedload, i_ele) > min_bedload) - volume_fraction_at_quad = face_val_at_quad(bedload, i_ele) / & - & face_val_at_quad(total_bedload, i_ele) - elsewhere - volume_fraction_at_quad = 0.0 - end where - volume_fraction = shape_rhs(shape, volume_fraction_at_quad * detwei) - - if(continuity(volume_fraction_surface)<0) then - ! DG case. - volume_fraction = matmul(invmass, volume_fraction) - end if - - call addto(volume_fraction_surface, ele, volume_fraction) - - end subroutine calculate_sediment_active_layer_element_volume_fractions + else + ! In the DG case we will apply the inverse mass locally. + invmass=inverse(shape_shape(shape, shape, detwei)) + end if + + where (face_val_at_quad(total_bedload, i_ele) > min_bedload) + volume_fraction_at_quad = face_val_at_quad(bedload, i_ele) / & + & face_val_at_quad(total_bedload, i_ele) + elsewhere + volume_fraction_at_quad = 0.0 + end where + volume_fraction = shape_rhs(shape, volume_fraction_at_quad * detwei) + + if(continuity(volume_fraction_surface)<0) then + ! DG case. + volume_fraction = matmul(invmass, volume_fraction) + end if + + call addto(volume_fraction_surface, ele, volume_fraction) + + end subroutine calculate_sediment_active_layer_element_volume_fractions end module sediment_diagnostics diff --git a/tools/Checkmesh.F90 b/tools/Checkmesh.F90 index 59381a78ba..1b56bbbb41 100644 --- a/tools/Checkmesh.F90 +++ b/tools/Checkmesh.F90 @@ -1,468 +1,468 @@ #include "fdebug.h" subroutine checkmesh(filename_, filename_len) bind(c) - !!< Checks the validity of the supplied mesh + !!< Checks the validity of the supplied mesh ! these 5 need to be on top and in this order, so as not to confuse silly old intel compiler - use quadrature - use element_numbering, only: FAMILY_SIMPLEX - use elements - use transform_elements - use sparse_tools - use fields - use state_module + use quadrature + use element_numbering, only: FAMILY_SIMPLEX + use elements + use transform_elements + use sparse_tools + use fields + use state_module ! - use fldebug - use futils - use reference_counting, only: print_references - use vector_tools, only: eigendecomposition_symmetric - use parallel_tools - use parallel_fields - use halos - use intersection_finder_module - use linked_lists - use meshdiagnostics - use metric_tools - use mesh_files - use supermesh_construction - use tetrahedron_intersection_module - use iso_c_binding + use fldebug + use futils + use reference_counting, only: print_references + use vector_tools, only: eigendecomposition_symmetric + use parallel_tools + use parallel_fields + use halos + use intersection_finder_module + use linked_lists + use meshdiagnostics + use metric_tools + use mesh_files + use supermesh_construction + use tetrahedron_intersection_module + use iso_c_binding - implicit none + implicit none - character(kind=c_char, len=1) :: filename_(*) - integer(kind=c_size_t), value :: filename_len + character(kind=c_char, len=1) :: filename_(*) + integer(kind=c_size_t), value :: filename_len - character(len = filename_len) :: filename - character(len = real_format_len()) :: rformat - integer :: global_ele, global_nodes, global_sele, global_facets, i - type(vector_field) :: positions + character(len = filename_len) :: filename + character(len = real_format_len()) :: rformat + integer :: global_ele, global_nodes, global_sele, global_facets, i + type(vector_field) :: positions - do i=1, filename_len - filename(i:i)=filename_(i) - end do + do i=1, filename_len + filename(i:i)=filename_(i) + end do - rformat = real_format() + rformat = real_format() - print "(a)", "Reading in mesh mesh with base name " // trim(filename) - positions = read_mesh_files(filename, quad_degree = 4, format="gmsh") - if(isparallel()) call read_halos(filename, positions) - print "(a)", "Read successful" + print "(a)", "Reading in mesh mesh with base name " // trim(filename) + positions = read_mesh_files(filename, quad_degree = 4, format="gmsh") + if(isparallel()) call read_halos(filename, positions) + print "(a)", "Read successful" - call mesh_stats(positions%mesh, elements = global_ele, nodes = global_nodes, surface_elements = global_sele, facets=global_facets) + call mesh_stats(positions%mesh, elements = global_ele, nodes = global_nodes, surface_elements = global_sele, facets=global_facets) - call print_mesh_statistics(positions) + call print_mesh_statistics(positions) - call check_node_connectivity(positions) - call check_elements(positions) - call check_volume_element_tangling(positions) + call check_node_connectivity(positions) + call check_elements(positions) + call check_volume_element_tangling(positions) - call deallocate(positions) + call deallocate(positions) - call print_references(0) + call print_references(0) contains - subroutine print_mesh_statistics(positions) - !!< Print some statistics for the supplied mesh - - type(vector_field), intent(in) :: positions - - type(ilist) :: seeds - - print "(a)", "Mesh statistics:" - print "(a,i0)", "Dimension: ", positions%dim - print "(a,i0)", "Nodes: ", global_nodes - print "(a,i0)", "Volume elements: ", global_ele - print "(a,i0)", "Surface elements: ", global_sele - print "(a,i0)", "Facets: ", global_facets - if(associated(positions%mesh%faces)) then - if(associated(positions%mesh%faces%boundary_ids)) then - if(any(positions%mesh%faces%boundary_ids /= 0)) then - print "(a)", "Has boundary IDs" - else - print "(a)", "Has no boundary IDs" - end if + subroutine print_mesh_statistics(positions) + !!< Print some statistics for the supplied mesh + + type(vector_field), intent(in) :: positions + + type(ilist) :: seeds + + print "(a)", "Mesh statistics:" + print "(a,i0)", "Dimension: ", positions%dim + print "(a,i0)", "Nodes: ", global_nodes + print "(a,i0)", "Volume elements: ", global_ele + print "(a,i0)", "Surface elements: ", global_sele + print "(a,i0)", "Facets: ", global_facets + if(associated(positions%mesh%faces)) then + if(associated(positions%mesh%faces%boundary_ids)) then + if(any(positions%mesh%faces%boundary_ids /= 0)) then + print "(a)", "Has boundary IDs" + else + print "(a)", "Has no boundary IDs" + end if + else + print "(a)", "Has no boundary IDs" + end if else - print "(a)", "Has no boundary IDs" + print "(a)", "Has no faces information" end if - else - print "(a)", "Has no faces information" - end if - if(associated(positions%mesh%region_ids)) then - print "(a)", "Has region IDs" - else - print "(a)", "Has no region IDs" - end if - - seeds = advancing_front_intersection_finder_seeds(positions) - if(isparallel()) then - print "(a,i0)", "Partition connectivity: ", seeds%length - else - print "(a,i0)", "Connectivity: ", seeds%length - end if - call deallocate(seeds) - - call print_mesh_edge_statistics(positions) - call print_mesh_volume_statistics(positions) - - end subroutine print_mesh_statistics - - subroutine print_mesh_volume_statistics(positions) - type(vector_field), intent(in) :: positions - - integer :: i - real :: domain_volume, domain_surface_area, max_volume, min_volume, volume - real, dimension(:), allocatable :: detwei - - domain_volume = 0.0 - min_volume = huge(0.0) - max_volume = 0.0 - do i = 1, ele_count(positions) - if(.not. element_owned(positions, i)) cycle - - volume = element_volume(positions, i) - domain_volume = domain_volume + volume - min_volume = min(min_volume, volume) - max_volume = max(max_volume, volume) - end do - domain_surface_area = 0.0 - do i = 1, surface_element_count(positions) - if(.not. surface_element_owned(positions, i)) cycle - - allocate(detwei(face_ngi(positions, i))) - call transform_facet_to_physical(positions, i, & - detwei_f = detwei) - domain_surface_area = domain_surface_area + abs(sum(detwei)) - deallocate(detwei) - end do - - call allsum(domain_volume) - call allmin(min_volume) - call allmax(max_volume) - call allsum(domain_surface_area) - - print "(a," // rformat // ")", "Volume: ", domain_volume - print "(a," // rformat // ")", "Surface area: ", domain_surface_area - if(global_ele > 0) then - print "(a," // rformat // ")", "Min element volume: ", min_volume - print "(a," // rformat // ")", "Max element volume: ", max_volume - print "(a," // rformat // ")", "Ratio of max to min element volumes: ", max_volume / min_volume - end if - - end subroutine print_mesh_volume_statistics - - subroutine print_mesh_edge_statistics(positions) - type(vector_field), intent(in) :: positions - - integer :: i, j - integer, dimension(:), pointer :: nodes - logical :: all_linear_simplices - integer, dimension(2) :: edge_nodes - integer, dimension(2, 2), parameter :: edge_nodes_2d = reshape((/3, 3, 2, 1/), (/2, 2/)) - integer, dimension(6, 2), parameter :: edge_nodes_3d = reshape((/4, 3, 2, 1, 1, 1, 2, 4, 3, 4, 3, 2/), (/6, 2/)) - real :: length, max_length, min_length - real :: anisotropy, max_anisotropy, min_anisotropy - real, dimension(positions%dim) :: evals - real, dimension(positions%dim, positions%dim) :: edge_lengths, evecs - type(element_type), pointer :: shape - - if(global_ele == 0) then - return - end if - - all_linear_simplices = .true. - min_length = huge(0.0) - max_length = 0.0 - min_anisotropy = huge(0.0) - max_anisotropy = 0.0 - do i = 1, ele_count(positions) - shape => ele_shape(positions, i) - if(shape%degree /= 1 .or. ele_numbering_family(shape) /= FAMILY_SIMPLEX) then - all_linear_simplices = .false. - exit + if(associated(positions%mesh%region_ids)) then + print "(a)", "Has region IDs" + else + print "(a)", "Has no region IDs" end if - nodes => ele_nodes(positions, i) - select case(positions%dim) - case(3) - do j = 1, size(edge_nodes_3d, 1) - edge_nodes = (/nodes(edge_nodes_3d(j, 1)), nodes(edge_nodes_3d(j, 2))/) - length = sqrt(sum((node_val(positions, edge_nodes(2)) - node_val(positions, edge_nodes(1))) ** 2)) - - min_length = min(min_length, length) - max_length = max(max_length, length) - end do - case(2) - do j = 1, size(edge_nodes_2d, 1) - edge_nodes = (/nodes(edge_nodes_2d(j, 1)), nodes(edge_nodes_2d(j, 2))/) - length = sqrt(sum((node_val(positions, edge_nodes(2)) - node_val(positions, edge_nodes(1))) ** 2)) - - min_length = min(min_length, length) - max_length = max(max_length, length) - end do - case(1) - edge_nodes = (/nodes(2), nodes(1)/) - length = sqrt(sum((node_val(positions, edge_nodes(2)) - node_val(positions, edge_nodes(1))) ** 2)) - - min_length = min(min_length, length) - max_length = max(max_length, length) - case default - ewrite(-1, *) "For dimension: ", positions%dim - FLAbort("Invalid dimension") - end select - - edge_lengths = edge_lengths_from_metric(simplex_tensor(positions, i)) - call eigendecomposition_symmetric(edge_lengths, evecs, evals) - anisotropy = maxval(evals) / minval(evals) - min_anisotropy = min(min_anisotropy, anisotropy) - max_anisotropy = max(max_anisotropy, anisotropy) - end do - - call alland(all_linear_simplices) - if(.not. all_linear_simplices) return - call allmin(min_length) - call allmax(max_length) - call allmin(min_anisotropy) - call allmax(max_anisotropy) - - print "(a," // rformat // ")", "Min edge length: ", min_length - print "(a," // rformat // ")", "Max edge length: ", max_length - print "(a," // rformat // ")", "Ratio of max to min edge lengths: ", max_length / min_length - print "(a," // rformat // ")", "Min anisotropy: ", min_anisotropy - print "(a," // rformat // ")", "Max anisotropy: ", max_anisotropy - - end subroutine print_mesh_edge_statistics - - subroutine check_node_connectivity(positions) - !!< Check the nodal connectivity of the supplied mesh - - type(vector_field), intent(in) :: positions - - integer :: i - logical, dimension(node_count(positions)) :: connected_node - - print "(a)", "Checking nodal connectivity ..." - - connected_node = .false. - do i = 1, ele_count(positions) - connected_node(ele_nodes(positions, i)) = .true. - end do - if(all(connected_node)) then - print "(a)", "All nodes are connected to volume elements" - else - do i = 1, size(connected_node) - if(.not. connected_node(i)) then - call print_node(positions, i) - print "(a)", "Node not connected to any volume elements" - end if - end do - end if + seeds = advancing_front_intersection_finder_seeds(positions) + if(isparallel()) then + print "(a,i0)", "Partition connectivity: ", seeds%length + else + print "(a,i0)", "Connectivity: ", seeds%length + end if + call deallocate(seeds) - end subroutine check_node_connectivity + call print_mesh_edge_statistics(positions) + call print_mesh_volume_statistics(positions) - subroutine check_elements(positions) - !!< Check that the supplied mesh for inverted or degenerate elements + end subroutine print_mesh_statistics - type(vector_field), intent(in) :: positions + subroutine print_mesh_volume_statistics(positions) + type(vector_field), intent(in) :: positions - integer :: i - logical :: all_ok - real :: min_volume, volume - real, dimension(:), allocatable :: detwei - type(element_type), pointer :: shape + integer :: i + real :: domain_volume, domain_surface_area, max_volume, min_volume, volume + real, dimension(:), allocatable :: detwei - if(global_ele > 0) then - print "(a)", "Checking volume elements ..." + domain_volume = 0.0 min_volume = huge(0.0) - all_ok = .true. + max_volume = 0.0 do i = 1, ele_count(positions) - shape => ele_shape(positions, i) - if(shape%degree == 1 .and. ele_numbering_family(shape) == FAMILY_SIMPLEX .and. positions%dim == 3) then - volume = simplex_volume(positions, i) - if(volume < 0.0) then - print "(a)", "Inverted volume element found: " - call print_element(i, ele_val(positions, i), ele_nodes(positions, i)) - end if - volume = abs(volume) - else - volume = element_volume(positions, i) - end if - min_volume = min(min_volume, volume) - if(volume < epsilon(0.0)) then - print "(a)", "Degenerate volume element found: " - call print_element(i, ele_val(positions, i), ele_nodes(positions, i)) - all_ok = .false. - end if + if(.not. element_owned(positions, i)) cycle + + volume = element_volume(positions, i) + domain_volume = domain_volume + volume + min_volume = min(min_volume, volume) + max_volume = max(max_volume, volume) end do + domain_surface_area = 0.0 + do i = 1, surface_element_count(positions) + if(.not. surface_element_owned(positions, i)) cycle - call alland(all_ok) + allocate(detwei(face_ngi(positions, i))) + call transform_facet_to_physical(positions, i, & + detwei_f = detwei) + domain_surface_area = domain_surface_area + abs(sum(detwei)) + deallocate(detwei) + end do + + call allsum(domain_volume) call allmin(min_volume) + call allmax(max_volume) + call allsum(domain_surface_area) + + print "(a," // rformat // ")", "Volume: ", domain_volume + print "(a," // rformat // ")", "Surface area: ", domain_surface_area + if(global_ele > 0) then + print "(a," // rformat // ")", "Min element volume: ", min_volume + print "(a," // rformat // ")", "Max element volume: ", max_volume + print "(a," // rformat // ")", "Ratio of max to min element volumes: ", max_volume / min_volume + end if - print "(a," // rformat // ")", "Min volume element volume: ", min_volume - if(all_ok) then - print "(a)", "All volume elements are non-degenerate" + end subroutine print_mesh_volume_statistics + + subroutine print_mesh_edge_statistics(positions) + type(vector_field), intent(in) :: positions + + integer :: i, j + integer, dimension(:), pointer :: nodes + logical :: all_linear_simplices + integer, dimension(2) :: edge_nodes + integer, dimension(2, 2), parameter :: edge_nodes_2d = reshape((/3, 3, 2, 1/), (/2, 2/)) + integer, dimension(6, 2), parameter :: edge_nodes_3d = reshape((/4, 3, 2, 1, 1, 1, 2, 4, 3, 4, 3, 2/), (/6, 2/)) + real :: length, max_length, min_length + real :: anisotropy, max_anisotropy, min_anisotropy + real, dimension(positions%dim) :: evals + real, dimension(positions%dim, positions%dim) :: edge_lengths, evecs + type(element_type), pointer :: shape + + if(global_ele == 0) then + return end if - end if - if(global_sele > 0) then - print "(a)", "Checking surface elements ..." - min_volume = huge(0.0) - all_ok = .true. - do i = 1, surface_element_count(positions) - allocate(detwei(face_ngi(positions, i))) - call transform_facet_to_physical(positions, i, detwei_f = detwei) - volume = abs(sum(detwei)) - deallocate(detwei) - min_volume = min(min_volume, volume) - if(volume < epsilon(0.0)) then - print "(a)", "Degenerate surface element found: " - call print_element(i, face_val(positions, i), face_global_nodes(positions, i)) - all_ok = .false. - end if + all_linear_simplices = .true. + min_length = huge(0.0) + max_length = 0.0 + min_anisotropy = huge(0.0) + max_anisotropy = 0.0 + do i = 1, ele_count(positions) + shape => ele_shape(positions, i) + if(shape%degree /= 1 .or. ele_numbering_family(shape) /= FAMILY_SIMPLEX) then + all_linear_simplices = .false. + exit + end if + + nodes => ele_nodes(positions, i) + select case(positions%dim) + case(3) + do j = 1, size(edge_nodes_3d, 1) + edge_nodes = (/nodes(edge_nodes_3d(j, 1)), nodes(edge_nodes_3d(j, 2))/) + length = sqrt(sum((node_val(positions, edge_nodes(2)) - node_val(positions, edge_nodes(1))) ** 2)) + + min_length = min(min_length, length) + max_length = max(max_length, length) + end do + case(2) + do j = 1, size(edge_nodes_2d, 1) + edge_nodes = (/nodes(edge_nodes_2d(j, 1)), nodes(edge_nodes_2d(j, 2))/) + length = sqrt(sum((node_val(positions, edge_nodes(2)) - node_val(positions, edge_nodes(1))) ** 2)) + + min_length = min(min_length, length) + max_length = max(max_length, length) + end do + case(1) + edge_nodes = (/nodes(2), nodes(1)/) + length = sqrt(sum((node_val(positions, edge_nodes(2)) - node_val(positions, edge_nodes(1))) ** 2)) + + min_length = min(min_length, length) + max_length = max(max_length, length) + case default + ewrite(-1, *) "For dimension: ", positions%dim + FLAbort("Invalid dimension") + end select + + edge_lengths = edge_lengths_from_metric(simplex_tensor(positions, i)) + call eigendecomposition_symmetric(edge_lengths, evecs, evals) + anisotropy = maxval(evals) / minval(evals) + min_anisotropy = min(min_anisotropy, anisotropy) + max_anisotropy = max(max_anisotropy, anisotropy) end do - call alland(all_ok) - call allmin(min_volume) + call alland(all_linear_simplices) + if(.not. all_linear_simplices) return + call allmin(min_length) + call allmax(max_length) + call allmin(min_anisotropy) + call allmax(max_anisotropy) - print "(a," // rformat // ")", "Min surface element area: ", min_volume - if(all_ok) then - print "(a)", "All surface elements are non-degenerate" - end if - end if + print "(a," // rformat // ")", "Min edge length: ", min_length + print "(a," // rformat // ")", "Max edge length: ", max_length + print "(a," // rformat // ")", "Ratio of max to min edge lengths: ", max_length / min_length + print "(a," // rformat // ")", "Min anisotropy: ", min_anisotropy + print "(a," // rformat // ")", "Max anisotropy: ", max_anisotropy + + end subroutine print_mesh_edge_statistics + + subroutine check_node_connectivity(positions) + !!< Check the nodal connectivity of the supplied mesh + + type(vector_field), intent(in) :: positions - end subroutine check_elements + integer :: i + logical, dimension(node_count(positions)) :: connected_node - subroutine check_volume_element_tangling(positions) - !!< Check the supplied mesh for tangling of the volume elements + print "(a)", "Checking nodal connectivity ..." - type(vector_field), intent(in) :: positions + connected_node = .false. + do i = 1, ele_count(positions) + connected_node(ele_nodes(positions, i)) = .true. + end do + if(all(connected_node)) then + print "(a)", "All nodes are connected to volume elements" + else + do i = 1, size(connected_node) + if(.not. connected_node(i)) then + call print_node(positions, i) + print "(a)", "Node not connected to any volume elements" + end if + end do + end if - integer :: dim, i, j, stat - logical :: all_ok, intersection_found - real :: ele_volume, intersection_volume - real, parameter :: relative_tolerance = 1.0e-8 - type(inode), pointer :: llnode - type(ilist), dimension(ele_count(positions)) :: intersection_map - type(plane_type), dimension(4) :: planes_b - type(tet_type) :: tet_a, tet_b - type(vector_field) :: intersection + end subroutine check_node_connectivity + + subroutine check_elements(positions) + !!< Check that the supplied mesh for inverted or degenerate elements + + type(vector_field), intent(in) :: positions + + integer :: i + logical :: all_ok + real :: min_volume, volume + real, dimension(:), allocatable :: detwei + type(element_type), pointer :: shape + + if(global_ele > 0) then + print "(a)", "Checking volume elements ..." + min_volume = huge(0.0) + all_ok = .true. + do i = 1, ele_count(positions) + shape => ele_shape(positions, i) + if(shape%degree == 1 .and. ele_numbering_family(shape) == FAMILY_SIMPLEX .and. positions%dim == 3) then + volume = simplex_volume(positions, i) + if(volume < 0.0) then + print "(a)", "Inverted volume element found: " + call print_element(i, ele_val(positions, i), ele_nodes(positions, i)) + end if + volume = abs(volume) + else + volume = element_volume(positions, i) + end if + min_volume = min(min_volume, volume) + if(volume < epsilon(0.0)) then + print "(a)", "Degenerate volume element found: " + call print_element(i, ele_val(positions, i), ele_nodes(positions, i)) + all_ok = .false. + end if + end do + + call alland(all_ok) + call allmin(min_volume) + + print "(a," // rformat // ")", "Min volume element volume: ", min_volume + if(all_ok) then + print "(a)", "All volume elements are non-degenerate" + end if + end if + + if(global_sele > 0) then + print "(a)", "Checking surface elements ..." + min_volume = huge(0.0) + all_ok = .true. + do i = 1, surface_element_count(positions) + allocate(detwei(face_ngi(positions, i))) + call transform_facet_to_physical(positions, i, detwei_f = detwei) + volume = abs(sum(detwei)) + deallocate(detwei) + min_volume = min(min_volume, volume) + if(volume < epsilon(0.0)) then + print "(a)", "Degenerate surface element found: " + call print_element(i, face_val(positions, i), face_global_nodes(positions, i)) + all_ok = .false. + end if + end do + + call alland(all_ok) + call allmin(min_volume) + + print "(a," // rformat // ")", "Min surface element area: ", min_volume + if(all_ok) then + print "(a)", "All surface elements are non-degenerate" + end if + end if - if(global_ele == 0) then - return - end if + end subroutine check_elements - print "(a)", "Checking volume elements for tangling ..." + subroutine check_volume_element_tangling(positions) + !!< Check the supplied mesh for tangling of the volume elements - dim = positions%dim - call intersector_set_dimension(dim) - call intersector_set_exactness(.false.) + type(vector_field), intent(in) :: positions - all_ok = .true. - intersection_map = intersection_finder(positions, positions) - map_loop: do i = 1, size(intersection_map) - ele_volume = element_volume(positions, i) + integer :: dim, i, j, stat + logical :: all_ok, intersection_found + real :: ele_volume, intersection_volume + real, parameter :: relative_tolerance = 1.0e-8 + type(inode), pointer :: llnode + type(ilist), dimension(ele_count(positions)) :: intersection_map + type(plane_type), dimension(4) :: planes_b + type(tet_type) :: tet_a, tet_b + type(vector_field) :: intersection - if(dim == 3 .and. (intersector_exactness .eqv. .false.)) then - tet_b%v = ele_val(positions, i) - planes_b = get_planes(tet_b) + if(global_ele == 0) then + return end if - llnode => intersection_map(i)%firstnode - intersection_found = .false. - do while(associated(llnode)) - if(dim == 3 .and. (intersector_exactness .eqv. .false.)) then - tet_a%v = ele_val(positions, llnode%value) - call intersect_tets(tet_a, planes_b, ele_shape(positions, llnode%value), stat = stat, output = intersection) - if(stat /= 0) then - llnode => llnode%next - cycle - end if - else - intersection = intersect_elements(positions, llnode%value, ele_val(positions, i), ele_shape(positions, i)) - if(ele_count(intersection) == 0) then + print "(a)", "Checking volume elements for tangling ..." + + dim = positions%dim + call intersector_set_dimension(dim) + call intersector_set_exactness(.false.) + + all_ok = .true. + intersection_map = intersection_finder(positions, positions) + map_loop: do i = 1, size(intersection_map) + ele_volume = element_volume(positions, i) + + if(dim == 3 .and. (intersector_exactness .eqv. .false.)) then + tet_b%v = ele_val(positions, i) + planes_b = get_planes(tet_b) + end if + + llnode => intersection_map(i)%firstnode + intersection_found = .false. + do while(associated(llnode)) + if(dim == 3 .and. (intersector_exactness .eqv. .false.)) then + tet_a%v = ele_val(positions, llnode%value) + call intersect_tets(tet_a, planes_b, ele_shape(positions, llnode%value), stat = stat, output = intersection) + if(stat /= 0) then + llnode => llnode%next + cycle + end if + else + intersection = intersect_elements(positions, llnode%value, ele_val(positions, i), ele_shape(positions, i)) + if(ele_count(intersection) == 0) then + call deallocate(intersection) + llnode => llnode%next + cycle + end if + end if + + intersection_volume = 0.0 + do j = 1, ele_count(intersection) + intersection_volume = intersection_volume + element_volume(intersection, j) + end do + if(abs(intersection_volume) > abs(max(relative_tolerance, relative_tolerance * ele_volume))) then + ! intersection_found traps the equal volume overlaid elements + ! case. The volume test traps the non-equal volume intersecting + ! elements case. + if(intersection_found .or. abs(ele_volume - intersection_volume) > abs(max(relative_tolerance, relative_tolerance * ele_volume))) then + print "(a)", "Tangled volume element found: " + call print_element(i, ele_val(positions, i), ele_nodes(positions, i)) + call deallocate(intersection) + all_ok = .false. + exit map_loop + end if + intersection_found = .true. + end if + call deallocate(intersection) llnode => llnode%next - cycle - end if - end if - - intersection_volume = 0.0 - do j = 1, ele_count(intersection) - intersection_volume = intersection_volume + element_volume(intersection, j) - end do - if(abs(intersection_volume) > abs(max(relative_tolerance, relative_tolerance * ele_volume))) then - ! intersection_found traps the equal volume overlaid elements - ! case. The volume test traps the non-equal volume intersecting - ! elements case. - if(intersection_found .or. abs(ele_volume - intersection_volume) > abs(max(relative_tolerance, relative_tolerance * ele_volume))) then - print "(a)", "Tangled volume element found: " - call print_element(i, ele_val(positions, i), ele_nodes(positions, i)) - call deallocate(intersection) - all_ok = .false. - exit map_loop - end if - intersection_found = .true. - end if - - call deallocate(intersection) - llnode => llnode%next - end do - end do map_loop + end do + end do map_loop - call alland(all_ok) + call alland(all_ok) - if(all_ok) then - print "(a)", "No volume element tangling" - end if + if(all_ok) then + print "(a)", "No volume element tangling" + end if - if(dim == 3) call finalise_tet_intersector() + if(dim == 3) call finalise_tet_intersector() - end subroutine check_volume_element_tangling + end subroutine check_volume_element_tangling - subroutine print_node(positions, number) - type(vector_field), intent(in) :: positions - integer, intent(in) :: number + subroutine print_node(positions, number) + type(vector_field), intent(in) :: positions + integer, intent(in) :: number - character(len = 1 + int2str_len(positions%dim) + real_format_len(padding = 1) + 1) :: format_buffer - integer :: i - real, dimension(positions%dim) :: coord + character(len = 1 + int2str_len(positions%dim) + real_format_len(padding = 1) + 1) :: format_buffer + integer :: i + real, dimension(positions%dim) :: coord - print "(a,i0)", "Node: ", number + print "(a,i0)", "Node: ", number - print "(a)", "Coordinates:" - coord = node_val(positions, number) - format_buffer = "(" // trim(real_format()) // ")" - do i = 1, size(coord) - print trim(format_buffer), coord(i) - end do + print "(a)", "Coordinates:" + coord = node_val(positions, number) + format_buffer = "(" // trim(real_format()) // ")" + do i = 1, size(coord) + print trim(format_buffer), coord(i) + end do - end subroutine print_node + end subroutine print_node - subroutine print_element(number, coords, numbering) - !!< Print the supplied element information + subroutine print_element(number, coords, numbering) + !!< Print the supplied element information - integer, intent(in) :: number - real, dimension(:, :), intent(in) :: coords - integer, dimension(size(coords, 2)), intent(in) :: numbering + integer, intent(in) :: number + real, dimension(:, :), intent(in) :: coords + integer, dimension(size(coords, 2)), intent(in) :: numbering - character(len = 1 + int2str_len(size(coords, 1)) + real_format_len(padding = 1) + 1) :: format_buffer - integer :: i + character(len = 1 + int2str_len(size(coords, 1)) + real_format_len(padding = 1) + 1) :: format_buffer + integer :: i - print "(a,i0)", "Element: ", number + print "(a,i0)", "Element: ", number - print "(a)", "Coordinates:" - format_buffer = "(" // int2str(size(coords, 1)) // trim(real_format(padding = 1)) // ")" - do i = 1, size(coords, 2) - print trim(format_buffer), coords(:, i) - end do + print "(a)", "Coordinates:" + format_buffer = "(" // int2str(size(coords, 1)) // trim(real_format(padding = 1)) // ")" + do i = 1, size(coords, 2) + print trim(format_buffer), coords(:, i) + end do - print "(a)", "Numbering:" - do i = 1, size(numbering) - print "(i0)", numbering(i) - end do + print "(a)", "Numbering:" + do i = 1, size(numbering) + print "(i0)", numbering(i) + end do - end subroutine print_element + end subroutine print_element end subroutine checkmesh diff --git a/tools/Differentiate_Vtu.F90 b/tools/Differentiate_Vtu.F90 index d4e56380f8..a590b0d017 100644 --- a/tools/Differentiate_Vtu.F90 +++ b/tools/Differentiate_Vtu.F90 @@ -28,189 +28,189 @@ #include "fdebug.h" subroutine differentiate_vtu(input_filename_, input_filename_len, output_filename_, & - output_filename_len, input_fieldname_, input_fieldname_len) bind(c) + output_filename_len, input_fieldname_, input_fieldname_len) bind(c) ! these 5 need to be on top and in this order, so as not to confuse silly old intel compiler - use quadrature - use elements - use sparse_tools - use fields - use state_module + use quadrature + use elements + use sparse_tools + use fields + use state_module ! - use reference_counting, only: print_references - use vector_tools, only: solve - use fetools, only: shape_shape, shape_vector_rhs - use transform_elements, only: transform_to_physical - use field_derivatives - use fldebug - use state_module - use vtk_interfaces - use iso_c_binding - implicit none - - - character(kind=c_char, len=1) :: input_filename_(*) - integer(kind=c_size_t), value :: input_filename_len - character(kind=c_char, len=1) :: output_filename_(*) - integer(kind=c_size_t), value :: output_filename_len - character(kind=c_char, len=1) :: input_fieldname_(*) - integer(kind=c_size_t), value :: input_fieldname_len - - - character(len = input_filename_len) :: input_filename - character(len = output_filename_len) :: output_filename - character(len = input_fieldname_len) :: input_fieldname - - integer :: dim, i, j, nfields - logical :: allocated - type(mesh_type), pointer :: mesh - type(scalar_field) :: masslump - type(scalar_field), dimension(:), allocatable :: s_fields - type(scalar_field), pointer :: s_field - type(state_type) :: collapsed_state, state - type(vector_field) :: field_grad - type(vector_field), dimension(:), allocatable :: field_grads - type(vector_field), pointer :: positions - - ewrite(1, *) "In differentiate_vtu" - - do i=1, input_filename_len - input_filename(i:i)=input_filename_(i) - end do - do i=1, output_filename_len - output_filename(i:i)=output_filename_(i) - end do - do i=1, input_fieldname_len - input_fieldname(i:i)=input_fieldname_(i) - end do - - call vtk_read_state(trim(input_filename), state) - - positions => extract_vector_field(state, "Coordinate") - dim = positions%dim - mesh => extract_mesh(state, "Mesh") - - if(len_trim(input_fieldname) == 0) then - call collapse_fields_in_state(state, collapsed_state) - nfields = scalar_field_count(collapsed_state) - allocate(s_fields(nfields)) - do i = 1, scalar_field_count(collapsed_state) - s_fields(i) = extract_scalar_field(collapsed_state, i) - end do - allocate(field_grads(nfields)) - do i = 1, nfields - s_field => extract_scalar_field(collapsed_state, i) - call allocate(field_grads(i), dim, mesh, trim(s_field%name) // "Gradient") - end do - call deallocate(collapsed_state) - - select case(continuity(positions)) - case(-1) - do i = 1, ele_count(mesh) - call solve_grad_ele(i, positions, s_fields, field_grads) - end do - case(0) - call allocate(masslump, mesh, "LumpedMass") - call zero(masslump) - do i = 1, nfields - call zero(field_grads(i)) - end do - - do i = 1, ele_count(mesh) - call assemble_grad_ele(i, positions, s_fields, masslump, field_grads) - end do - - do i = 1, nfields - do j = 1, dim - field_grads(i)%val(j,:) = field_grads(i)%val(j,:) / masslump%val - end do - end do - call deallocate(masslump) - case default - ewrite(-1, *) "For continuity ", continuity(positions) - FLAbort("Unrecognised continuity") - end select - - do i = 1, nfields - call insert(state, field_grads(i), field_grads(i)%name) - call deallocate(field_grads(i)) - end do - deallocate(field_grads) - deallocate(s_fields) - else - s_field => extract_scalar_field(state, trim(input_fieldname), allocated = allocated) - - call allocate(field_grad, dim, mesh, trim(s_field%name) // "Gradient") - call grad(s_field, positions, field_grad) - call insert(state, field_grad, field_grad%name) - call deallocate(field_grad) - - if(allocated) deallocate(s_field) - end if - - call vtk_write_state(output_filename, state = (/state/)) - call deallocate(state) - - call print_references(0) - - ewrite(1, *) "Exiting differentate_vtu" + use reference_counting, only: print_references + use vector_tools, only: solve + use fetools, only: shape_shape, shape_vector_rhs + use transform_elements, only: transform_to_physical + use field_derivatives + use fldebug + use state_module + use vtk_interfaces + use iso_c_binding + implicit none + + + character(kind=c_char, len=1) :: input_filename_(*) + integer(kind=c_size_t), value :: input_filename_len + character(kind=c_char, len=1) :: output_filename_(*) + integer(kind=c_size_t), value :: output_filename_len + character(kind=c_char, len=1) :: input_fieldname_(*) + integer(kind=c_size_t), value :: input_fieldname_len + + + character(len = input_filename_len) :: input_filename + character(len = output_filename_len) :: output_filename + character(len = input_fieldname_len) :: input_fieldname + + integer :: dim, i, j, nfields + logical :: allocated + type(mesh_type), pointer :: mesh + type(scalar_field) :: masslump + type(scalar_field), dimension(:), allocatable :: s_fields + type(scalar_field), pointer :: s_field + type(state_type) :: collapsed_state, state + type(vector_field) :: field_grad + type(vector_field), dimension(:), allocatable :: field_grads + type(vector_field), pointer :: positions + + ewrite(1, *) "In differentiate_vtu" + + do i=1, input_filename_len + input_filename(i:i)=input_filename_(i) + end do + do i=1, output_filename_len + output_filename(i:i)=output_filename_(i) + end do + do i=1, input_fieldname_len + input_fieldname(i:i)=input_fieldname_(i) + end do + + call vtk_read_state(trim(input_filename), state) + + positions => extract_vector_field(state, "Coordinate") + dim = positions%dim + mesh => extract_mesh(state, "Mesh") + + if(len_trim(input_fieldname) == 0) then + call collapse_fields_in_state(state, collapsed_state) + nfields = scalar_field_count(collapsed_state) + allocate(s_fields(nfields)) + do i = 1, scalar_field_count(collapsed_state) + s_fields(i) = extract_scalar_field(collapsed_state, i) + end do + allocate(field_grads(nfields)) + do i = 1, nfields + s_field => extract_scalar_field(collapsed_state, i) + call allocate(field_grads(i), dim, mesh, trim(s_field%name) // "Gradient") + end do + call deallocate(collapsed_state) + + select case(continuity(positions)) + case(-1) + do i = 1, ele_count(mesh) + call solve_grad_ele(i, positions, s_fields, field_grads) + end do + case(0) + call allocate(masslump, mesh, "LumpedMass") + call zero(masslump) + do i = 1, nfields + call zero(field_grads(i)) + end do + + do i = 1, ele_count(mesh) + call assemble_grad_ele(i, positions, s_fields, masslump, field_grads) + end do + + do i = 1, nfields + do j = 1, dim + field_grads(i)%val(j,:) = field_grads(i)%val(j,:) / masslump%val + end do + end do + call deallocate(masslump) + case default + ewrite(-1, *) "For continuity ", continuity(positions) + FLAbort("Unrecognised continuity") + end select + + do i = 1, nfields + call insert(state, field_grads(i), field_grads(i)%name) + call deallocate(field_grads(i)) + end do + deallocate(field_grads) + deallocate(s_fields) + else + s_field => extract_scalar_field(state, trim(input_fieldname), allocated = allocated) + + call allocate(field_grad, dim, mesh, trim(s_field%name) // "Gradient") + call grad(s_field, positions, field_grad) + call insert(state, field_grad, field_grad%name) + call deallocate(field_grad) + + if(allocated) deallocate(s_field) + end if + + call vtk_write_state(output_filename, state = (/state/)) + call deallocate(state) + + call print_references(0) + + ewrite(1, *) "Exiting differentate_vtu" contains - subroutine solve_grad_ele(ele, positions, fields, field_grads) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), dimension(:), intent(in) :: fields - type(vector_field), dimension(size(fields)), intent(inout) :: field_grads - - integer :: i - integer, dimension(:), pointer :: nodes - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(positions, ele), ele_loc(positions, ele)) :: little_mass - real, dimension(ele_loc(positions, ele), size(fields) * positions%dim) :: little_rhs - real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), positions%dim) :: dshape - type(element_type), pointer :: shape - - shape => ele_shape(positions, ele) - call transform_to_physical(positions, ele, shape, & + subroutine solve_grad_ele(ele, positions, fields, field_grads) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), dimension(:), intent(in) :: fields + type(vector_field), dimension(size(fields)), intent(inout) :: field_grads + + integer :: i + integer, dimension(:), pointer :: nodes + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(positions, ele), ele_loc(positions, ele)) :: little_mass + real, dimension(ele_loc(positions, ele), size(fields) * positions%dim) :: little_rhs + real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), positions%dim) :: dshape + type(element_type), pointer :: shape + + shape => ele_shape(positions, ele) + call transform_to_physical(positions, ele, shape, & & detwei = detwei, dshape = dshape) - little_mass = shape_shape(shape, shape, detwei) - do i = 1, size(fields) - little_rhs(:, (i - 1) * positions%dim + 1:i * positions%dim) = transpose(shape_vector_rhs(shape, ele_grad_at_quad(fields(i), ele, dshape), detwei)) - end do - call solve(little_mass, little_rhs) - - nodes => ele_nodes(positions, ele) - do i = 1, size(field_grads) - call set(field_grads(i), nodes, little_rhs(:, (i - 1) * positions%dim + 1:i * positions%dim)) - end do - - end subroutine solve_grad_ele - - subroutine assemble_grad_ele(ele, positions, fields, masslump, rhs) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(scalar_field), dimension(:), intent(in) :: fields - type(scalar_field), intent(inout) :: masslump - type(vector_field), dimension(size(fields)), intent(inout) :: rhs - - integer :: i - integer, dimension(:), pointer :: nodes - real, dimension(ele_ngi(positions, ele)) :: detwei - real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), positions%dim) :: dshape - type(element_type), pointer :: shape - - shape => ele_shape(positions, ele) - call transform_to_physical(positions, ele, shape, & + little_mass = shape_shape(shape, shape, detwei) + do i = 1, size(fields) + little_rhs(:, (i - 1) * positions%dim + 1:i * positions%dim) = transpose(shape_vector_rhs(shape, ele_grad_at_quad(fields(i), ele, dshape), detwei)) + end do + call solve(little_mass, little_rhs) + + nodes => ele_nodes(positions, ele) + do i = 1, size(field_grads) + call set(field_grads(i), nodes, little_rhs(:, (i - 1) * positions%dim + 1:i * positions%dim)) + end do + + end subroutine solve_grad_ele + + subroutine assemble_grad_ele(ele, positions, fields, masslump, rhs) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(scalar_field), dimension(:), intent(in) :: fields + type(scalar_field), intent(inout) :: masslump + type(vector_field), dimension(size(fields)), intent(inout) :: rhs + + integer :: i + integer, dimension(:), pointer :: nodes + real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_loc(positions, ele), ele_ngi(positions, ele), positions%dim) :: dshape + type(element_type), pointer :: shape + + shape => ele_shape(positions, ele) + call transform_to_physical(positions, ele, shape, & & detwei = detwei, dshape = dshape) - nodes => ele_nodes(positions, ele) - call addto(masslump, nodes, sum(shape_shape(shape, shape, detwei), 2)) - do i = 1, size(rhs) - call addto(rhs(i), nodes, shape_vector_rhs(shape, ele_grad_at_quad(fields(i), ele, dshape), detwei)) - end do + nodes => ele_nodes(positions, ele) + call addto(masslump, nodes, sum(shape_shape(shape, shape, detwei), 2)) + do i = 1, size(rhs) + call addto(rhs(i), nodes, shape_vector_rhs(shape, ele_grad_at_quad(fields(i), ele, dshape), detwei)) + end do - end subroutine assemble_grad_ele + end subroutine assemble_grad_ele end subroutine differentiate_vtu diff --git a/tools/Fladapt.F90 b/tools/Fladapt.F90 index 1d5fa0c728..9be8dbebdb 100644 --- a/tools/Fladapt.F90 +++ b/tools/Fladapt.F90 @@ -28,164 +28,164 @@ #include "fdebug.h" subroutine fladapt(input_basename_, input_basename_len, & - & output_basename_, output_basename_len) bind(c) - !!< Peforms a mesh adapt based on the supplied input options file. - !!< Outputs the resulting mesh. - - use iso_c_binding - use global_parameters, only: FIELD_NAME_LEN - use fldebug - use parallel_tools, only: isparallel - use reference_counting - use spud - use fields - use edge_length_module - use state_module - use field_options - use vtk_interfaces - use diagnostic_fields_wrapper, only: calculate_diagnostic_variables - use limit_metric_module - use mesh_files - use populate_state_module - use metric_assemble - use adapt_state_module - use diagnostic_fields_new, only : & - & calculate_diagnostic_variables_new => calculate_diagnostic_variables - - implicit none - - interface - subroutine check_options() - end subroutine check_options +& output_basename_, output_basename_len) bind(c) + !!< Peforms a mesh adapt based on the supplied input options file. + !!< Outputs the resulting mesh. + + use iso_c_binding + use global_parameters, only: FIELD_NAME_LEN + use fldebug + use parallel_tools, only: isparallel + use reference_counting + use spud + use fields + use edge_length_module + use state_module + use field_options + use vtk_interfaces + use diagnostic_fields_wrapper, only: calculate_diagnostic_variables + use limit_metric_module + use mesh_files + use populate_state_module + use metric_assemble + use adapt_state_module + use diagnostic_fields_new, only : & + & calculate_diagnostic_variables_new => calculate_diagnostic_variables + + implicit none + + interface + subroutine check_options() + end subroutine check_options #ifdef HAVE_PYTHON - subroutine python_init() - end subroutine python_init + subroutine python_init() + end subroutine python_init #endif - end interface - - character(kind=c_char, len=1) :: input_basename_(*) - integer(kind=c_size_t), value :: input_basename_len - character(kind=c_char, len=1) :: output_basename_(*) - integer(kind=c_size_t), value :: output_basename_len - - character(len=input_basename_len):: input_basename - character(len=output_basename_len):: output_basename - integer :: i - type(mesh_type), pointer :: old_mesh - type(state_type), dimension(:), pointer :: states - type(vector_field) :: new_mesh_field - type(vector_field), pointer :: new_mesh_field_ptr, old_mesh_field - type(tensor_field) :: metric, t_edge_lengths - character(len=FIELD_NAME_LEN) :: mesh_format - - ! now turn into proper fortran strings (is there an easier way to do this?) - do i=1, input_basename_len - input_basename(i:i)=input_basename_(i) - end do - do i=1, output_basename_len - output_basename(i:i)=output_basename_(i) - end do - - ewrite(1, *) "In fladapt" + end interface + + character(kind=c_char, len=1) :: input_basename_(*) + integer(kind=c_size_t), value :: input_basename_len + character(kind=c_char, len=1) :: output_basename_(*) + integer(kind=c_size_t), value :: output_basename_len + + character(len=input_basename_len):: input_basename + character(len=output_basename_len):: output_basename + integer :: i + type(mesh_type), pointer :: old_mesh + type(state_type), dimension(:), pointer :: states + type(vector_field) :: new_mesh_field + type(vector_field), pointer :: new_mesh_field_ptr, old_mesh_field + type(tensor_field) :: metric, t_edge_lengths + character(len=FIELD_NAME_LEN) :: mesh_format + + ! now turn into proper fortran strings (is there an easier way to do this?) + do i=1, input_basename_len + input_basename(i:i)=input_basename_(i) + end do + do i=1, output_basename_len + output_basename(i:i)=output_basename_(i) + end do + + ewrite(1, *) "In fladapt" #ifdef HAVE_PYTHON - call python_init() + call python_init() #endif - ewrite(2, *) "Input base name: " // trim(input_basename) - ewrite(2, *) "Output base name: " // trim(output_basename) - - ! Load the options tree - call load_options(trim(input_basename) // ".flml") - if(.not. have_option("/simulation_name")) then - FLExit("Failed to find simulation name after loading options file") - end if - if(debug_level() >= 1) then - ewrite(1, *) "Options tree:" - call print_options() - end if + ewrite(2, *) "Input base name: " // trim(input_basename) + ewrite(2, *) "Output base name: " // trim(output_basename) + + ! Load the options tree + call load_options(trim(input_basename) // ".flml") + if(.not. have_option("/simulation_name")) then + FLExit("Failed to find simulation name after loading options file") + end if + if(debug_level() >= 1) then + ewrite(1, *) "Options tree:" + call print_options() + end if #ifdef DDEBUG - ewrite(1, *) "Performing options sanity check" - call check_options() - ewrite(1, *) "Options sanity check successful" + ewrite(1, *) "Performing options sanity check" + call check_options() + ewrite(1, *) "Options sanity check successful" #endif - ! Populate the system state - call populate_state(states) - - ! Calculate diagnostic fields - call calculate_diagnostic_variables(states) - call calculate_diagnostic_variables_new(states) - - ! Find the external mesh field - !call find_mesh_field_to_adapt(states(1), old_mesh_field) - old_mesh_field => extract_vector_field(states(1), "Coordinate") - old_mesh => old_mesh_field%mesh - - ! Assemble the error metric - call allocate(metric, old_mesh, "ErrorMetric") - call assemble_metric(states, metric) - - ewrite(0, *) "Expected nodes = ", expected_nodes(old_mesh_field, metric) - - call allocate(t_edge_lengths, metric%mesh, "TensorEdgeLengths") - call get_edge_lengths(metric, t_edge_lengths) - call vtk_write_fields(trim(output_basename) // "EdgeLengths", position = old_mesh_field, model = metric%mesh, & - & tfields = (/t_edge_lengths, metric/)) - call deallocate(t_edge_lengths) - - ! Adapt the mesh - call allocate_metric_limits(states(1)) - if(isparallel()) then - call adapt_state(states, metric) - call find_mesh_field_to_adapt(states(1), new_mesh_field_ptr) - new_mesh_field = new_mesh_field_ptr - call incref(new_mesh_field) - new_mesh_field_ptr => null() - else - call adapt_mesh(old_mesh_field, metric, new_mesh_field) - end if - - call get_option(trim(old_mesh_field%mesh%option_path)//"/from_file/format/name", mesh_format) - ! Write the output mesh - call write_mesh_files(output_basename, mesh_format, new_mesh_field) - - ! Deallocate - do i = 1, size(states) - call deallocate(states(i)) - end do - call deallocate(metric) - call deallocate(new_mesh_field) - - call print_references(0) - - ewrite(1, *) "Exiting fladapt" + ! Populate the system state + call populate_state(states) + + ! Calculate diagnostic fields + call calculate_diagnostic_variables(states) + call calculate_diagnostic_variables_new(states) + + ! Find the external mesh field + !call find_mesh_field_to_adapt(states(1), old_mesh_field) + old_mesh_field => extract_vector_field(states(1), "Coordinate") + old_mesh => old_mesh_field%mesh + + ! Assemble the error metric + call allocate(metric, old_mesh, "ErrorMetric") + call assemble_metric(states, metric) + + ewrite(0, *) "Expected nodes = ", expected_nodes(old_mesh_field, metric) + + call allocate(t_edge_lengths, metric%mesh, "TensorEdgeLengths") + call get_edge_lengths(metric, t_edge_lengths) + call vtk_write_fields(trim(output_basename) // "EdgeLengths", position = old_mesh_field, model = metric%mesh, & + & tfields = (/t_edge_lengths, metric/)) + call deallocate(t_edge_lengths) + + ! Adapt the mesh + call allocate_metric_limits(states(1)) + if(isparallel()) then + call adapt_state(states, metric) + call find_mesh_field_to_adapt(states(1), new_mesh_field_ptr) + new_mesh_field = new_mesh_field_ptr + call incref(new_mesh_field) + new_mesh_field_ptr => null() + else + call adapt_mesh(old_mesh_field, metric, new_mesh_field) + end if + + call get_option(trim(old_mesh_field%mesh%option_path)//"/from_file/format/name", mesh_format) + ! Write the output mesh + call write_mesh_files(output_basename, mesh_format, new_mesh_field) + + ! Deallocate + do i = 1, size(states) + call deallocate(states(i)) + end do + call deallocate(metric) + call deallocate(new_mesh_field) + + call print_references(0) + + ewrite(1, *) "Exiting fladapt" contains - subroutine find_mesh_field_to_adapt(state, mesh_field) - !!< Find the external mesh field to be used by adaptivity + subroutine find_mesh_field_to_adapt(state, mesh_field) + !!< Find the external mesh field to be used by adaptivity - type(state_type), intent(in) :: state - type(vector_field), pointer :: mesh_field + type(state_type), intent(in) :: state + type(vector_field), pointer :: mesh_field - character(len = FIELD_NAME_LEN) :: mesh_field_name - type(mesh_type), pointer :: mesh + character(len = FIELD_NAME_LEN) :: mesh_field_name + type(mesh_type), pointer :: mesh - call find_mesh_to_adapt(state, mesh) - if(trim(mesh%name) == "CoordinateMesh") then - mesh_field_name = "Coordinate" - else - mesh_field_name = trim(mesh%name) // "Coordinate" - end if + call find_mesh_to_adapt(state, mesh) + if(trim(mesh%name) == "CoordinateMesh") then + mesh_field_name = "Coordinate" + else + mesh_field_name = trim(mesh%name) // "Coordinate" + end if - if(.not. has_vector_field(state, mesh_field_name)) then - FLAbort("External mesh field " // trim(mesh_field_name) // " not found in the system state") - end if + if(.not. has_vector_field(state, mesh_field_name)) then + FLAbort("External mesh field " // trim(mesh_field_name) // " not found in the system state") + end if - mesh_field => extract_vector_field(state, mesh_field_name) + mesh_field => extract_vector_field(state, mesh_field_name) - end subroutine find_mesh_field_to_adapt + end subroutine find_mesh_field_to_adapt end subroutine fladapt diff --git a/tools/Flredecomp.F90 b/tools/Flredecomp.F90 index 2bea707c50..34bbdd315b 100644 --- a/tools/Flredecomp.F90 +++ b/tools/Flredecomp.F90 @@ -29,241 +29,241 @@ #include "confdefs.h" subroutine flredecomp(input_basename, input_basename_len, output_basename, output_basename_len, & - & input_nprocs, target_nprocs) bind(c) - !!< Peform a redecomposition of an input checkpoint with input_nprocs - !!< processes to a new checkpoint with target_nprocs processes. - - use checkpoint - use fldebug - use global_parameters, only: is_active_process, no_active_processes, OPTION_PATH_LEN - use parallel_tools - use populate_state_module - use particles - use spud - use sam_integration - use fields - use field_options +& input_nprocs, target_nprocs) bind(c) + !!< Peform a redecomposition of an input checkpoint with input_nprocs + !!< processes to a new checkpoint with target_nprocs processes. + + use checkpoint + use fldebug + use global_parameters, only: is_active_process, no_active_processes, OPTION_PATH_LEN + use parallel_tools + use populate_state_module + use particles + use spud + use sam_integration + use fields + use field_options #ifdef HAVE_ZOLTAN - use zoltan + use zoltan #endif - use zoltan_integration - use state_module - use initialise_ocean_forcing_module - use iso_c_binding + use zoltan_integration + use state_module + use initialise_ocean_forcing_module + use iso_c_binding - implicit none + implicit none - character(kind=c_char, len=1) :: input_basename(*) - integer(kind=c_size_t), value :: input_basename_len - character(kind=c_char, len=1) :: output_basename(*) - integer(kind=c_size_t), value :: output_basename_len - integer(kind=c_int), value :: input_nprocs - integer(kind=c_int), value :: target_nprocs + character(kind=c_char, len=1) :: input_basename(*) + integer(kind=c_size_t), value :: input_basename_len + character(kind=c_char, len=1) :: output_basename(*) + integer(kind=c_size_t), value :: output_basename_len + integer(kind=c_int), value :: input_nprocs + integer(kind=c_int), value :: target_nprocs - interface - subroutine check_options() - end subroutine check_options + interface + subroutine check_options() + end subroutine check_options #ifdef HAVE_PYTHON - subroutine python_init() - end subroutine python_init + subroutine python_init() + end subroutine python_init #endif - end interface - - character(len=input_basename_len):: input_base - character(len=output_basename_len):: output_base - character(len=OPTION_PATH_LEN) :: filename - integer :: nprocs - type(state_type), dimension(:), pointer :: state - logical :: any_field_from_file, write_extruded_mesh_only, input_extruded_mesh_from_file - integer :: i, nstates + end interface + + character(len=input_basename_len):: input_base + character(len=output_basename_len):: output_base + character(len=OPTION_PATH_LEN) :: filename + integer :: nprocs + type(state_type), dimension(:), pointer :: state + logical :: any_field_from_file, write_extruded_mesh_only, input_extruded_mesh_from_file + integer :: i, nstates #ifdef HAVE_ZOLTAN - real(zoltan_float) :: ver - integer(zoltan_int) :: ierr + real(zoltan_float) :: ver + integer(zoltan_int) :: ierr - ierr = Zoltan_Initialize(ver) - assert(ierr == ZOLTAN_OK) + ierr = Zoltan_Initialize(ver) + assert(ierr == ZOLTAN_OK) #endif - ewrite(1, *) "In flredecomp" + ewrite(1, *) "In flredecomp" #ifdef HAVE_PYTHON - call python_init() + call python_init() #endif - nprocs = getnprocs() - ! now turn into proper fortran strings (is there an easier way to do this?) - do i=1, input_basename_len - input_base(i:i)=input_basename(i) - end do - do i=1, output_basename_len - output_base(i:i)=output_basename(i) - end do - - ewrite(2, "(a)") "Input base name: " // trim(input_base) - ewrite(2, "(a)") "Output base name: " // trim(output_base) - ewrite(2, "(a,i0)") "Input number of processes: ", input_nprocs - ewrite(2, "(a,i0)") "Target number of processes: ", target_nprocs - ewrite(2, "(a,i0)") "Job number of processes: ", nprocs - - ! Input check - if(input_nprocs < 0) then - FLExit("Input number of processes cannot be negative!") - else if(target_nprocs < 0) then - FLExit("Target number of processes cannot be negative!") - else if(input_nprocs > nprocs) then - ewrite(-1, *) "The input number of processes must be equal or less than the number of processes currently running." - FLExit("Running on insufficient processes.") - else if(target_nprocs > nprocs) then - ewrite(-1, *) "The target number of processes must be equal or less than the number of processes currently running." - FLExit("Running on insufficient processes.") - end if - - ! Load the options tree - call load_options(trim(input_base) // ".flml") - if(.not. have_option("/simulation_name")) then - FLExit("Failed to find simulation name after loading options file") - end if - - if(debug_level() >= 1) then - ewrite(1, *) "Options tree:" - call print_options() - end if + nprocs = getnprocs() + ! now turn into proper fortran strings (is there an easier way to do this?) + do i=1, input_basename_len + input_base(i:i)=input_basename(i) + end do + do i=1, output_basename_len + output_base(i:i)=output_basename(i) + end do + + ewrite(2, "(a)") "Input base name: " // trim(input_base) + ewrite(2, "(a)") "Output base name: " // trim(output_base) + ewrite(2, "(a,i0)") "Input number of processes: ", input_nprocs + ewrite(2, "(a,i0)") "Target number of processes: ", target_nprocs + ewrite(2, "(a,i0)") "Job number of processes: ", nprocs + + ! Input check + if(input_nprocs < 0) then + FLExit("Input number of processes cannot be negative!") + else if(target_nprocs < 0) then + FLExit("Target number of processes cannot be negative!") + else if(input_nprocs > nprocs) then + ewrite(-1, *) "The input number of processes must be equal or less than the number of processes currently running." + FLExit("Running on insufficient processes.") + else if(target_nprocs > nprocs) then + ewrite(-1, *) "The target number of processes must be equal or less than the number of processes currently running." + FLExit("Running on insufficient processes.") + end if + + ! Load the options tree + call load_options(trim(input_base) // ".flml") + if(.not. have_option("/simulation_name")) then + FLExit("Failed to find simulation name after loading options file") + end if + + if(debug_level() >= 1) then + ewrite(1, *) "Options tree:" + call print_options() + end if #ifdef DDEBUG - ewrite(1, *) "Performing options sanity check" - call check_options() - ewrite(1, *) "Options sanity check successful" + ewrite(1, *) "Performing options sanity check" + call check_options() + ewrite(1, *) "Options sanity check successful" #endif - any_field_from_file = (option_count('/material_phase/scalar_field/prognostic/initial_condition/from_file') + & - option_count('/material_phase/scalar_field/prescribed/value/from_file') + & - option_count('/material_phase/vector_field/prognostic/initial_condition/from_file') + & - option_count('/material_phase/vector_field/prescribed/value/from_file') + & - option_count('/material_phase/vector_field/prescribed/value/from_file')) > 0 - input_extruded_mesh_from_file = option_count('/geometry/mesh/from_mesh/extrude/checkpoint_from_file')>0 - if (any_field_from_file .and. option_count('/geometry/mesh/from_mesh/extrude')>0 & + any_field_from_file = (option_count('/material_phase/scalar_field/prognostic/initial_condition/from_file') + & + option_count('/material_phase/scalar_field/prescribed/value/from_file') + & + option_count('/material_phase/vector_field/prognostic/initial_condition/from_file') + & + option_count('/material_phase/vector_field/prescribed/value/from_file') + & + option_count('/material_phase/vector_field/prescribed/value/from_file')) > 0 + input_extruded_mesh_from_file = option_count('/geometry/mesh/from_mesh/extrude/checkpoint_from_file')>0 + if (any_field_from_file .and. option_count('/geometry/mesh/from_mesh/extrude')>0 & .and. .not. input_extruded_mesh_from_file) then - ewrite(-1,*) "Missing extruded mesh checpoint under extrude/checkpoint_from_file" - FLExit("With fields that are initialised from_file on extruded meshes, we need a checkpoint of the extruded mesh") - end if + ewrite(-1,*) "Missing extruded mesh checpoint under extrude/checkpoint_from_file" + FLExit("With fields that are initialised from_file on extruded meshes, we need a checkpoint of the extruded mesh") + end if - write_extruded_mesh_only = have_option('/flredecomp/write_extruded_mesh_only') - if (write_extruded_mesh_only .and. option_count('/geometry/mesh/from_mesh/extrude')==0) then - FLExit("Using /flredecomp/write_extruded_mesh_only, but no extruded mesh is defined") - end if + write_extruded_mesh_only = have_option('/flredecomp/write_extruded_mesh_only') + if (write_extruded_mesh_only .and. option_count('/geometry/mesh/from_mesh/extrude')==0) then + FLExit("Using /flredecomp/write_extruded_mesh_only, but no extruded mesh is defined") + end if - is_active_process = getprocno() <= input_nprocs - no_active_processes = input_nprocs + is_active_process = getprocno() <= input_nprocs + no_active_processes = input_nprocs - ! ! Below is a (partial) copy of the first bit of populate_state + ! ! Below is a (partial) copy of the first bit of populate_state - ! Find out how many states there are - nstates=option_count("/material_phase") - allocate(state(1:nstates)) - do i = 1, nstates - call nullify(state(i)) - end do + ! Find out how many states there are + nstates=option_count("/material_phase") + allocate(state(1:nstates)) + do i = 1, nstates + call nullify(state(i)) + end do - call initialise_ocean_forcing_readers + call initialise_ocean_forcing_readers - call insert_external_mesh(state, save_vtk_cache = .true.) + call insert_external_mesh(state, save_vtk_cache = .true.) - ! don't extrude if there isn't anything on the extruded mesh to migrate - ! (ignoring the corner case where the from_file fields are only on horizontal meshes) - ! extrusion may be time consuming and/or not fit on the input_nprocs - ! NOTE that extrude/checkpoint_from_file will be read by insert_external_mesh regardless - call insert_derived_meshes(state, skip_extrusion=.not. any_field_from_file) + ! don't extrude if there isn't anything on the extruded mesh to migrate + ! (ignoring the corner case where the from_file fields are only on horizontal meshes) + ! extrusion may be time consuming and/or not fit on the input_nprocs + ! NOTE that extrude/checkpoint_from_file will be read by insert_external_mesh regardless + call insert_derived_meshes(state, skip_extrusion=.not. any_field_from_file) - call compute_domain_statistics(state) + call compute_domain_statistics(state) - call allocate_and_insert_fields(state) + call allocate_and_insert_fields(state) - call initialise_prognostic_fields(state, save_vtk_cache=.true., & - initial_mesh=.true.) + call initialise_prognostic_fields(state, save_vtk_cache=.true., & + initial_mesh=.true.) - call set_prescribed_field_values(state, initial_mesh=.true.) + call set_prescribed_field_values(state, initial_mesh=.true.) - call get_option("/simulation_name", filename) - ! we can't use global pickers, since not all processes are participating - call initialise_particles(filename, state, global=.false., & - setup_output=.false., ignore_analytical=.true., number_of_partitions=input_nprocs) + call get_option("/simulation_name", filename) + ! we can't use global pickers, since not all processes are participating + call initialise_particles(filename, state, global=.false., & + setup_output=.false., ignore_analytical=.true., number_of_partitions=input_nprocs) - ! ! End populate_state calls + ! ! End populate_state calls - is_active_process = .true. - no_active_processes = target_nprocs + is_active_process = .true. + no_active_processes = target_nprocs #ifdef HAVE_ZOLTAN - ! if we have an extruded mesh, we only need to migrate it if it's picked up from file - ! (we migrate regardless of whether the mesh extrusion could be redone of decomposition, as we don't - ! know whether we can or not (in the case of a 2+1 extruded mesh) - ! if the mesh is migrated, the extrusion afterwards is automatically skipped - ! in other cases we only need to extrude afterwards, if we are using the write_extruded_mesh_only option - call zoltan_drive(state, .true., initialise_fields=.true., & - skip_extruded_mesh_migration=.not. input_extruded_mesh_from_file, & - skip_extrusion_after=.not. write_extruded_mesh_only, & - flredecomping=.true., input_procs = input_nprocs, target_procs = target_nprocs) + ! if we have an extruded mesh, we only need to migrate it if it's picked up from file + ! (we migrate regardless of whether the mesh extrusion could be redone of decomposition, as we don't + ! know whether we can or not (in the case of a 2+1 extruded mesh) + ! if the mesh is migrated, the extrusion afterwards is automatically skipped + ! in other cases we only need to extrude afterwards, if we are using the write_extruded_mesh_only option + call zoltan_drive(state, .true., initialise_fields=.true., & + skip_extruded_mesh_migration=.not. input_extruded_mesh_from_file, & + skip_extrusion_after=.not. write_extruded_mesh_only, & + flredecomping=.true., input_procs = input_nprocs, target_procs = target_nprocs) #else - call sam_integration_check_options() - call strip_level_2_halo(state, initialise_fields=.true.) - call sam_drive(state, sam_options(target_nprocs), initialise_fields=.true.) + call sam_integration_check_options() + call strip_level_2_halo(state, initialise_fields=.true.) + call sam_drive(state, sam_options(target_nprocs), initialise_fields=.true.) #endif - if (write_extruded_mesh_only) then - ! remove the horizontal meshes from the options tree, so they don't get checkpointed - ! and make the extruded mesh the external from_file mesh - call remove_non_extruded_mesh_options(state) - ! if the output flml is redecomposed again (for instance to get a proper 3D decomposition) - ! we don't want it to trip our little check at the top - call delete_option("/flredecomp/write_extruded_mesh_only") - end if + if (write_extruded_mesh_only) then + ! remove the horizontal meshes from the options tree, so they don't get checkpointed + ! and make the extruded mesh the external from_file mesh + call remove_non_extruded_mesh_options(state) + ! if the output flml is redecomposed again (for instance to get a proper 3D decomposition) + ! we don't want it to trip our little check at the top + call delete_option("/flredecomp/write_extruded_mesh_only") + end if - ! Output - assert(associated(state)) - call checkpoint_simulation(state, prefix = output_base, postfix = "", protect_simulation_name = .false., & - keep_initial_data=.true., number_of_partitions=target_nprocs) + ! Output + assert(associated(state)) + call checkpoint_simulation(state, prefix = output_base, postfix = "", protect_simulation_name = .false., & + keep_initial_data=.true., number_of_partitions=target_nprocs) - do i = 1, size(state) - call deallocate(state(i)) - end do + do i = 1, size(state) + call deallocate(state(i)) + end do - ewrite(1, *) "Exiting flredecomp" + ewrite(1, *) "Exiting flredecomp" contains - function sam_options(target_nparts) - !!< Return sam options array + function sam_options(target_nparts) + !!< Return sam options array - integer, intent(in) :: target_nparts + integer, intent(in) :: target_nparts - integer, dimension(10) :: sam_options + integer, dimension(10) :: sam_options - sam_options = 0 + sam_options = 0 - ! Target number of partitions - 0 indicates size of MPI_COMM_FEMTOOLS - sam_options(1) = target_nparts + ! Target number of partitions - 0 indicates size of MPI_COMM_FEMTOOLS + sam_options(1) = target_nparts - ! Graph partitioning options: - sam_options(2) = 1 ! Clean partitioning to optimise the length of the - ! interface boundary. - ! sam_options(2) = 2 ! Local diffusion - ! sam_options(2) = 3 ! Directed diffusion - ! sam_options(2) = 4 ! Clean partitioning to optimise the length of the - ! interface boundary. This partitioning is then remapped - ! onto the original partitioning to maximise overlap and - ! therefore the volume of data migration. + ! Graph partitioning options: + sam_options(2) = 1 ! Clean partitioning to optimise the length of the + ! interface boundary. + ! sam_options(2) = 2 ! Local diffusion + ! sam_options(2) = 3 ! Directed diffusion + ! sam_options(2) = 4 ! Clean partitioning to optimise the length of the + ! interface boundary. This partitioning is then remapped + ! onto the original partitioning to maximise overlap and + ! therefore the volume of data migration. - ! Heterogerious options (disabled) - sam_options(3) = 1 - ! No node weights - sam_options(4) = 1 - ! No edge weights - sam_options(5) = 1 - ! Mixed formulation options - sam_options(6) = 2 ! Enabled - ! Restore the level 2 halo + ! Heterogerious options (disabled) + sam_options(3) = 1 + ! No node weights + sam_options(4) = 1 + ! No edge weights + sam_options(5) = 1 + ! Mixed formulation options + sam_options(6) = 2 ! Enabled + ! Restore the level 2 halo - end function sam_options + end function sam_options end subroutine flredecomp diff --git a/tools/Meshconv.F90 b/tools/Meshconv.F90 index 034bff8969..87de7c9542 100644 --- a/tools/Meshconv.F90 +++ b/tools/Meshconv.F90 @@ -29,104 +29,104 @@ #include "confdefs.h" subroutine Meshconv(c_input_basename, input_basename_len, c_input_mesh_format, input_mesh_format_len, & - & c_output_mesh_format, output_mesh_format_len) bind(c) - !!< Converts a mesh file of a given mesh format into the specified output mesh format. - - use fldebug - use fields - use parallel_tools, only: isparallel, parallel_filename, getnprocs - use halos_registration, only: read_halos, write_halos - use fields_halos, only: verify_consistent_local_element_numbering - use mesh_files - use state_module - use iso_c_binding - - implicit none - - character(kind=c_char, len=1) :: c_input_basename(*) - integer(kind=c_size_t), value :: input_basename_len - character(kind=c_char, len=1) :: c_input_mesh_format(*) - integer(kind=c_size_t), value :: input_mesh_format_len - character(kind=c_char, len=1) :: c_output_mesh_format(*) - integer(kind=c_size_t), value :: output_mesh_format_len - - character(len=input_basename_len):: input_basename - character(len=input_mesh_format_len):: input_mesh_format - character(len=output_mesh_format_len):: output_mesh_format - - integer :: nprocs - type(state_type) :: state - type(mesh_type) :: mesh - type(vector_field) :: position - - integer :: quad_degree - integer :: i - - ewrite(1, *) "In Meshconv" - - nprocs = getnprocs() - if (nprocs > 1 .and. input_mesh_format == 'exodusii') then - FLExit("Meshconv must be run in serial when reading in an ExodusII mesh!") - end if - ! now turn into proper fortran strings (is there an easier way to do this?) - do i=1, input_basename_len - input_basename(i:i)=c_input_basename(i) - end do - do i=1, input_mesh_format_len - input_mesh_format(i:i)=c_input_mesh_format(i) - end do - do i=1, output_mesh_format_len - output_mesh_format(i:i)=c_output_mesh_format(i) - end do - - ewrite(1,*) "Reading in mesh file: "//trim(input_basename) - ewrite(1,*) "input_mesh_format: "//trim(input_mesh_format) - - ! Use hard coded values for quad_degree, - ! this doesn't matter for the conversion of the mesh file, - ! but is required for the subroutine below - quad_degree = 5 - - ! Read in the mesh file: - position=read_mesh_files(trim(input_basename), & - quad_degree=quad_degree, & - format=input_mesh_format) - ! If reading in a decomposed mesh, read in halos as well: - if(isparallel()) then - call read_halos(trim(input_basename), position) - ! Local element ordering needs to be consistent between processes, otherwise - ! code in Halos_Repair (used in halo construction of derived meshes) will fail - if (.not. verify_consistent_local_element_numbering(position%mesh)) then - ewrite(-1,*) "The local element ordering is not the same between processes" - ewrite(-1,*) "that see the same element. This is a necessary condition on the" - ewrite(-1,*) "decomposed input meshes for fluidity. The fact that you've" - ewrite(-1,*) "obtained such meshes is likely a bug in fldecomp or the" - ewrite(-1,*) "checkpointing code. Please report to the fluidity mailing" - ewrite(-1,*) "list and state exactly how you've obtained your input files." - FLAbort("Inconsistent local element ordering") - end if - end if - mesh=position%mesh - ! Insert mesh and position field into state and - call insert(state, mesh, mesh%name) - call insert(state, position, position%name) - call deallocate(position) - ewrite(1,*) "Mesh file was successfully read in" - - ! Writing mesh file: - ewrite(1,*) "**********************************" - ewrite(1,*) "Writing mesh file of format: "//trim(output_mesh_format) - ! If this runs in parallel, write mesh and halos: - if(isparallel()) then - call write_mesh_files(parallel_filename(trim(input_basename)), output_mesh_format, state, mesh) - call write_halos(trim(input_basename), mesh) - else - call write_mesh_files(trim(input_basename), output_mesh_format, state, mesh) - end if - - ! We are done here, deallocating state: - call deallocate(state) - - ewrite(1, *) "Exiting Meshconv" +& c_output_mesh_format, output_mesh_format_len) bind(c) + !!< Converts a mesh file of a given mesh format into the specified output mesh format. + + use fldebug + use fields + use parallel_tools, only: isparallel, parallel_filename, getnprocs + use halos_registration, only: read_halos, write_halos + use fields_halos, only: verify_consistent_local_element_numbering + use mesh_files + use state_module + use iso_c_binding + + implicit none + + character(kind=c_char, len=1) :: c_input_basename(*) + integer(kind=c_size_t), value :: input_basename_len + character(kind=c_char, len=1) :: c_input_mesh_format(*) + integer(kind=c_size_t), value :: input_mesh_format_len + character(kind=c_char, len=1) :: c_output_mesh_format(*) + integer(kind=c_size_t), value :: output_mesh_format_len + + character(len=input_basename_len):: input_basename + character(len=input_mesh_format_len):: input_mesh_format + character(len=output_mesh_format_len):: output_mesh_format + + integer :: nprocs + type(state_type) :: state + type(mesh_type) :: mesh + type(vector_field) :: position + + integer :: quad_degree + integer :: i + + ewrite(1, *) "In Meshconv" + + nprocs = getnprocs() + if (nprocs > 1 .and. input_mesh_format == 'exodusii') then + FLExit("Meshconv must be run in serial when reading in an ExodusII mesh!") + end if + ! now turn into proper fortran strings (is there an easier way to do this?) + do i=1, input_basename_len + input_basename(i:i)=c_input_basename(i) + end do + do i=1, input_mesh_format_len + input_mesh_format(i:i)=c_input_mesh_format(i) + end do + do i=1, output_mesh_format_len + output_mesh_format(i:i)=c_output_mesh_format(i) + end do + + ewrite(1,*) "Reading in mesh file: "//trim(input_basename) + ewrite(1,*) "input_mesh_format: "//trim(input_mesh_format) + + ! Use hard coded values for quad_degree, + ! this doesn't matter for the conversion of the mesh file, + ! but is required for the subroutine below + quad_degree = 5 + + ! Read in the mesh file: + position=read_mesh_files(trim(input_basename), & + quad_degree=quad_degree, & + format=input_mesh_format) + ! If reading in a decomposed mesh, read in halos as well: + if(isparallel()) then + call read_halos(trim(input_basename), position) + ! Local element ordering needs to be consistent between processes, otherwise + ! code in Halos_Repair (used in halo construction of derived meshes) will fail + if (.not. verify_consistent_local_element_numbering(position%mesh)) then + ewrite(-1,*) "The local element ordering is not the same between processes" + ewrite(-1,*) "that see the same element. This is a necessary condition on the" + ewrite(-1,*) "decomposed input meshes for fluidity. The fact that you've" + ewrite(-1,*) "obtained such meshes is likely a bug in fldecomp or the" + ewrite(-1,*) "checkpointing code. Please report to the fluidity mailing" + ewrite(-1,*) "list and state exactly how you've obtained your input files." + FLAbort("Inconsistent local element ordering") + end if + end if + mesh=position%mesh + ! Insert mesh and position field into state and + call insert(state, mesh, mesh%name) + call insert(state, position, position%name) + call deallocate(position) + ewrite(1,*) "Mesh file was successfully read in" + + ! Writing mesh file: + ewrite(1,*) "**********************************" + ewrite(1,*) "Writing mesh file of format: "//trim(output_mesh_format) + ! If this runs in parallel, write mesh and halos: + if(isparallel()) then + call write_mesh_files(parallel_filename(trim(input_basename)), output_mesh_format, state, mesh) + call write_halos(trim(input_basename), mesh) + else + call write_mesh_files(trim(input_basename), output_mesh_format, state, mesh) + end if + + ! We are done here, deallocating state: + call deallocate(state) + + ewrite(1, *) "Exiting Meshconv" end subroutine Meshconv diff --git a/tools/Probe_Vtu.F90 b/tools/Probe_Vtu.F90 index 0593d7777e..d7b3e5e1cb 100644 --- a/tools/Probe_Vtu.F90 +++ b/tools/Probe_Vtu.F90 @@ -28,101 +28,101 @@ #include "fdebug.h" subroutine probe_vtu(vtu_filename_, vtu_filename_len, fieldname_, & - & fieldname_len, x, y, z, dim) bind(c) - - use element_numbering, only: FAMILY_SIMPLEX - use fields - use fldebug - use futils - use pickers - use reference_counting, only: print_references - use state_module - use vtk_interfaces - use iso_c_binding - - implicit none - - - character(kind=c_char, len=1) :: vtu_filename_(*) - character(kind=c_char, len=1) :: fieldname_(*) - integer(kind=c_int), value :: dim, vtu_filename_len, fieldname_len - real(kind=c_double), value :: x, y, z - - character(len = 1 + 1 + real_format_len(padding = 1) + 1) :: format - integer :: ele, stat, i - logical :: allocated - real :: s_val - real, dimension(dim) :: coord, v_val - real, dimension(dim + 1) :: local_coord - real, dimension(dim, dim) :: t_val - type(scalar_field), pointer :: s_field - type(vector_field), pointer :: positions, v_field - type(state_type) :: state - type(tensor_field), pointer :: t_field - character(len=vtu_filename_len) :: vtu_filename - character(len=fieldname_len) :: fieldname - - - ewrite(1, *) "In probe_vtu" - - do i=1, vtu_filename_len - vtu_filename(i:i)=vtu_filename_(i) - end do - do i=1, fieldname_len - fieldname(i:i)=fieldname_(i) - end do - - - - call vtk_read_state(vtu_filename, state = state) - - positions => extract_vector_field(state, "Coordinate") - if(positions%dim /= dim) then - FLExit("Expected " // int2str(dim) // " dimensional probe coord") - else if(ele_numbering_family(ele_shape(positions, 1)) /= FAMILY_SIMPLEX) then - FLExit("Mesh in vtu " // vtu_filename // " is not composed of linear simplices") - end if - - if(dim > 0) coord(1) = x - if(dim > 1) coord(2) = y - if(dim > 2) coord(3) = z - ewrite(2, *) "Probe coord: ", coord - call picker_inquire(positions, coord, ele, local_coord = local_coord) - if(ele < 0) then - FLExit("Probe point not contained in vtu " // vtu_filename) - end if - - s_field => extract_scalar_field(state, fieldname, allocated = allocated, stat = stat) - if(stat == 0) then - format = "(" // real_format() // ")" - s_val = eval_field(ele, s_field, local_coord) - ewrite(2, *) fieldname // " value:" - print format, s_val - if(allocated) deallocate(s_field) - else - v_field => extract_vector_field(state, fieldname, stat = stat) - if(stat == 0) then - format = "(" // int2str(dim) // real_format(padding = 1) // ")" - v_val = eval_field(ele, v_field, local_coord) +& fieldname_len, x, y, z, dim) bind(c) + + use element_numbering, only: FAMILY_SIMPLEX + use fields + use fldebug + use futils + use pickers + use reference_counting, only: print_references + use state_module + use vtk_interfaces + use iso_c_binding + + implicit none + + + character(kind=c_char, len=1) :: vtu_filename_(*) + character(kind=c_char, len=1) :: fieldname_(*) + integer(kind=c_int), value :: dim, vtu_filename_len, fieldname_len + real(kind=c_double), value :: x, y, z + + character(len = 1 + 1 + real_format_len(padding = 1) + 1) :: format + integer :: ele, stat, i + logical :: allocated + real :: s_val + real, dimension(dim) :: coord, v_val + real, dimension(dim + 1) :: local_coord + real, dimension(dim, dim) :: t_val + type(scalar_field), pointer :: s_field + type(vector_field), pointer :: positions, v_field + type(state_type) :: state + type(tensor_field), pointer :: t_field + character(len=vtu_filename_len) :: vtu_filename + character(len=fieldname_len) :: fieldname + + + ewrite(1, *) "In probe_vtu" + + do i=1, vtu_filename_len + vtu_filename(i:i)=vtu_filename_(i) + end do + do i=1, fieldname_len + fieldname(i:i)=fieldname_(i) + end do + + + + call vtk_read_state(vtu_filename, state = state) + + positions => extract_vector_field(state, "Coordinate") + if(positions%dim /= dim) then + FLExit("Expected " // int2str(dim) // " dimensional probe coord") + else if(ele_numbering_family(ele_shape(positions, 1)) /= FAMILY_SIMPLEX) then + FLExit("Mesh in vtu " // vtu_filename // " is not composed of linear simplices") + end if + + if(dim > 0) coord(1) = x + if(dim > 1) coord(2) = y + if(dim > 2) coord(3) = z + ewrite(2, *) "Probe coord: ", coord + call picker_inquire(positions, coord, ele, local_coord = local_coord) + if(ele < 0) then + FLExit("Probe point not contained in vtu " // vtu_filename) + end if + + s_field => extract_scalar_field(state, fieldname, allocated = allocated, stat = stat) + if(stat == 0) then + format = "(" // real_format() // ")" + s_val = eval_field(ele, s_field, local_coord) ewrite(2, *) fieldname // " value:" - print format, v_val - else - t_field => extract_tensor_field(state, fieldname, stat = stat) + print format, s_val + if(allocated) deallocate(s_field) + else + v_field => extract_vector_field(state, fieldname, stat = stat) if(stat == 0) then - format = "(" // int2str(dim ** 2) // real_format(padding = 1) // ")" - t_val = eval_field(ele, t_field, local_coord) - ewrite(2, *) fieldname // " value:" - print format, t_val + format = "(" // int2str(dim) // real_format(padding = 1) // ")" + v_val = eval_field(ele, v_field, local_coord) + ewrite(2, *) fieldname // " value:" + print format, v_val else - FLExit("Field " // fieldname // " not found in vtu " // vtu_filename) + t_field => extract_tensor_field(state, fieldname, stat = stat) + if(stat == 0) then + format = "(" // int2str(dim ** 2) // real_format(padding = 1) // ")" + t_val = eval_field(ele, t_field, local_coord) + ewrite(2, *) fieldname // " value:" + print format, t_val + else + FLExit("Field " // fieldname // " not found in vtu " // vtu_filename) + end if end if - end if - end if + end if - call deallocate(state) + call deallocate(state) - call print_references(0) + call print_references(0) - ewrite(1, *) "Exiting probe_vtu" + ewrite(1, *) "Exiting probe_vtu" end subroutine probe_vtu diff --git a/tools/Project_Vtu.F90 b/tools/Project_Vtu.F90 index 12d1288ca9..26c02e0265 100644 --- a/tools/Project_Vtu.F90 +++ b/tools/Project_Vtu.F90 @@ -28,194 +28,194 @@ #include "fdebug.h" subroutine project_vtu(input_filename_, input_filename_len, donor_basename_, donor_basename_len, & - &target_basename_, target_basename_len, output_filename_, output_filename_len) bind(c) - - use conservative_interpolation_module - use elements - use fields - use fldebug - use reference_counting, only: print_references - use global_parameters, only : current_debug_level - use intersection_finder_module - use linked_lists - use solvers - use spud - use state_module - use mesh_files - use vtk_interfaces - use iso_c_binding - implicit none - - integer(kind=c_size_t), value :: input_filename_len, donor_basename_len - integer(kind=c_size_t), value :: target_basename_len, output_filename_len - character(kind=c_char, len=1) :: input_filename_(*), donor_basename_(*) - character(kind=c_char, len=1) :: target_basename_(*), output_filename_(*) - - character(len = input_filename_len) :: input_filename - character(len = donor_basename_len) :: donor_basename - character(len = target_basename_len) :: target_basename - character(len = output_filename_len) :: output_filename - character(len = *), parameter :: fields_path = "/dummy" - integer :: i - integer, parameter :: quad_degree = 4 - type(element_type), pointer :: shape - type(ilist), dimension(:), allocatable :: map_BA - type(mesh_type) :: output_mesh, output_p0mesh - type(mesh_type), pointer :: input_mesh - type(state_type) :: input_state, output_state - type(state_type), dimension(:), allocatable :: input_mesh_states, output_mesh_states - type(scalar_field) :: output_s_field - type(scalar_field), pointer :: input_s_field - type(vector_field) :: donor_positions, output_v_field, target_positions - type(vector_field), pointer :: input_v_field - type(tensor_field) :: output_t_field - type(tensor_field), pointer :: input_t_field - - ewrite(1, *) "In project_vtu" - - do i=1, input_filename_len - input_filename(i:i)=input_filename_(i) - end do - do i=1, donor_basename_len - donor_basename(i:i)=donor_basename_(i) - end do - do i=1, target_basename_len - target_basename(i:i)=target_basename_(i) - end do - do i=1, output_filename_len - output_filename(i:i)=output_filename_(i) - end do - - - call set_solver_options(fields_path // "/galerkin_projection/continuous", & - & ksptype = "cg", pctype = "sor", atol = epsilon(0.0), rtol = 0.0, max_its = 2000, start_from_zero = .true.) - - call vtk_read_state(trim(input_filename), input_state, quad_degree = quad_degree) - - donor_positions = extract_vector_field(input_state, "Coordinate") - input_mesh => extract_mesh(input_state, "Mesh") - - target_positions = read_mesh_files(trim(target_basename), quad_degree = quad_degree, format="gmsh") - - shape => ele_shape(donor_positions, 1) - if (shape==ele_shape(target_positions,1) .and. continuity(donor_positions)==continuity(target_positions)) then - output_mesh = target_positions%mesh - call incref(output_mesh) - else - output_mesh = make_mesh(target_positions%mesh, shape, continuity = continuity(donor_positions)) - end if - if (has_mesh(input_state, "P0Mesh")) then - output_p0mesh = piecewise_constant_mesh(target_positions%mesh, "P0Mesh") - end if - - if (donor_basename_len>0) then - donor_positions = read_mesh_files(trim(donor_basename), quad_degree = quad_degree, format="gmsh") - else - ! no donor mesh specified: - ! use the one we got from vtk_read_state - ! this only works in serial and with a P1CG vtu - if (continuity(donor_positions)<0 .or. shape%degree/=1) then - FLExit("No donor mesh specified. This only works for a serial, continuous, linear input vtu") - end if - call incref(donor_positions) - end if - - allocate(map_BA(ele_count(target_positions))) - map_BA = rtree_intersection_finder(target_positions, donor_positions) - - call insert(output_state, output_mesh, "Mesh") - if (has_mesh(input_state, "P0Mesh")) then - call insert(output_state, output_p0mesh, "P0Mesh") - end if - do i = 1, scalar_field_count(input_state) - input_s_field => extract_scalar_field(input_state, i) - if(input_s_field%name == "vtkGhostType") then - call remove_scalar_field(input_state, input_s_field%name) - cycle - end if - if (input_s_field%mesh%name=="Mesh") then - call allocate(output_s_field, output_mesh, input_s_field%name) - else if (input_s_field%mesh%name=="P0Mesh") then - call allocate(output_s_field, output_p0mesh, input_s_field%name) - else - FLAbort("State from vtk_read_state should contain Mesh and P0Mesh only") - end if - call zero(output_s_field) - output_s_field%option_path = fields_path - call insert(output_state, output_s_field, output_s_field%name) - call deallocate(output_s_field) - end do - do i = 1, vector_field_count(input_state) - input_v_field => extract_vector_field(input_state, i) - if(input_v_field%name == "Coordinate") cycle - if (input_v_field%mesh%name=="Mesh") then - call allocate(output_v_field, input_v_field%dim, output_mesh, input_v_field%name) - else if (input_v_field%mesh%name=="P0Mesh") then - call allocate(output_v_field, input_v_field%dim, output_p0mesh, input_v_field%name) - else - FLAbort("State from vtk_read_state should contain Mesh and P0Mesh only") - end if - call zero(output_v_field) - output_v_field%option_path = fields_path - call insert(output_state, output_v_field, output_v_field%name) - call deallocate(output_v_field) - end do - do i = 1, tensor_field_count(input_state) - input_t_field => extract_tensor_field(input_state, i) - if (input_t_field%mesh%name=="Mesh") then - call allocate(output_t_field, output_mesh, input_t_field%name) - else if (input_t_field%mesh%name=="P0Mesh") then - call allocate(output_t_field, output_p0mesh, input_t_field%name) - else - FLAbort("State from vtk_read_state should contain Mesh and P0Mesh only") - end if - call zero(output_t_field) - output_t_field%option_path = fields_path - call insert(output_state, output_t_field, output_t_field%name) - call deallocate(output_t_field) - end do - - - if(current_debug_level >= 2) then - ewrite(2, *) "Options tree:" - call print_options() - ewrite(2, *) "Input state:" - call print_state(input_state) - ewrite(2, *) "Output state:" - call print_state(output_state) - end if - - call sort_states_by_mesh( (/ input_state /), input_mesh_states) - call sort_states_by_mesh( (/ output_state /), output_mesh_states) - do i=1, size(input_mesh_states) - call insert(input_mesh_states(i), donor_positions, "Coordinate") - end do - do i=1, size(output_mesh_states) - call insert(output_mesh_states(i), target_positions, "Coordinate") - end do - ! do this insert after the sort_states_by_mesh as target_positions%mesh is seen as a different mesh - call insert(output_state, target_positions, "Coordinate") - call deallocate(donor_positions) - call deallocate(target_positions) - - call interpolation_galerkin(input_mesh_states, output_mesh_states, map_BA = map_BA) - call deallocate(map_BA) - deallocate(map_BA) - call deallocate(input_mesh_states) - deallocate(input_mesh_states) - call deallocate(output_mesh_states) - deallocate(output_mesh_states) - call deallocate(input_state) - - call vtk_write_state(trim(output_filename), model = "Mesh", state = (/output_state/)) - call deallocate(output_mesh) - if (has_mesh(output_state, "P0Mesh")) then - call deallocate(output_p0mesh) - end if - call deallocate(output_state) - - call print_references(0) - - ewrite(1, *) "Exiting project_vtu" +&target_basename_, target_basename_len, output_filename_, output_filename_len) bind(c) + + use conservative_interpolation_module + use elements + use fields + use fldebug + use reference_counting, only: print_references + use global_parameters, only : current_debug_level + use intersection_finder_module + use linked_lists + use solvers + use spud + use state_module + use mesh_files + use vtk_interfaces + use iso_c_binding + implicit none + + integer(kind=c_size_t), value :: input_filename_len, donor_basename_len + integer(kind=c_size_t), value :: target_basename_len, output_filename_len + character(kind=c_char, len=1) :: input_filename_(*), donor_basename_(*) + character(kind=c_char, len=1) :: target_basename_(*), output_filename_(*) + + character(len = input_filename_len) :: input_filename + character(len = donor_basename_len) :: donor_basename + character(len = target_basename_len) :: target_basename + character(len = output_filename_len) :: output_filename + character(len = *), parameter :: fields_path = "/dummy" + integer :: i + integer, parameter :: quad_degree = 4 + type(element_type), pointer :: shape + type(ilist), dimension(:), allocatable :: map_BA + type(mesh_type) :: output_mesh, output_p0mesh + type(mesh_type), pointer :: input_mesh + type(state_type) :: input_state, output_state + type(state_type), dimension(:), allocatable :: input_mesh_states, output_mesh_states + type(scalar_field) :: output_s_field + type(scalar_field), pointer :: input_s_field + type(vector_field) :: donor_positions, output_v_field, target_positions + type(vector_field), pointer :: input_v_field + type(tensor_field) :: output_t_field + type(tensor_field), pointer :: input_t_field + + ewrite(1, *) "In project_vtu" + + do i=1, input_filename_len + input_filename(i:i)=input_filename_(i) + end do + do i=1, donor_basename_len + donor_basename(i:i)=donor_basename_(i) + end do + do i=1, target_basename_len + target_basename(i:i)=target_basename_(i) + end do + do i=1, output_filename_len + output_filename(i:i)=output_filename_(i) + end do + + + call set_solver_options(fields_path // "/galerkin_projection/continuous", & + & ksptype = "cg", pctype = "sor", atol = epsilon(0.0), rtol = 0.0, max_its = 2000, start_from_zero = .true.) + + call vtk_read_state(trim(input_filename), input_state, quad_degree = quad_degree) + + donor_positions = extract_vector_field(input_state, "Coordinate") + input_mesh => extract_mesh(input_state, "Mesh") + + target_positions = read_mesh_files(trim(target_basename), quad_degree = quad_degree, format="gmsh") + + shape => ele_shape(donor_positions, 1) + if (shape==ele_shape(target_positions,1) .and. continuity(donor_positions)==continuity(target_positions)) then + output_mesh = target_positions%mesh + call incref(output_mesh) + else + output_mesh = make_mesh(target_positions%mesh, shape, continuity = continuity(donor_positions)) + end if + if (has_mesh(input_state, "P0Mesh")) then + output_p0mesh = piecewise_constant_mesh(target_positions%mesh, "P0Mesh") + end if + + if (donor_basename_len>0) then + donor_positions = read_mesh_files(trim(donor_basename), quad_degree = quad_degree, format="gmsh") + else + ! no donor mesh specified: + ! use the one we got from vtk_read_state + ! this only works in serial and with a P1CG vtu + if (continuity(donor_positions)<0 .or. shape%degree/=1) then + FLExit("No donor mesh specified. This only works for a serial, continuous, linear input vtu") + end if + call incref(donor_positions) + end if + + allocate(map_BA(ele_count(target_positions))) + map_BA = rtree_intersection_finder(target_positions, donor_positions) + + call insert(output_state, output_mesh, "Mesh") + if (has_mesh(input_state, "P0Mesh")) then + call insert(output_state, output_p0mesh, "P0Mesh") + end if + do i = 1, scalar_field_count(input_state) + input_s_field => extract_scalar_field(input_state, i) + if(input_s_field%name == "vtkGhostType") then + call remove_scalar_field(input_state, input_s_field%name) + cycle + end if + if (input_s_field%mesh%name=="Mesh") then + call allocate(output_s_field, output_mesh, input_s_field%name) + else if (input_s_field%mesh%name=="P0Mesh") then + call allocate(output_s_field, output_p0mesh, input_s_field%name) + else + FLAbort("State from vtk_read_state should contain Mesh and P0Mesh only") + end if + call zero(output_s_field) + output_s_field%option_path = fields_path + call insert(output_state, output_s_field, output_s_field%name) + call deallocate(output_s_field) + end do + do i = 1, vector_field_count(input_state) + input_v_field => extract_vector_field(input_state, i) + if(input_v_field%name == "Coordinate") cycle + if (input_v_field%mesh%name=="Mesh") then + call allocate(output_v_field, input_v_field%dim, output_mesh, input_v_field%name) + else if (input_v_field%mesh%name=="P0Mesh") then + call allocate(output_v_field, input_v_field%dim, output_p0mesh, input_v_field%name) + else + FLAbort("State from vtk_read_state should contain Mesh and P0Mesh only") + end if + call zero(output_v_field) + output_v_field%option_path = fields_path + call insert(output_state, output_v_field, output_v_field%name) + call deallocate(output_v_field) + end do + do i = 1, tensor_field_count(input_state) + input_t_field => extract_tensor_field(input_state, i) + if (input_t_field%mesh%name=="Mesh") then + call allocate(output_t_field, output_mesh, input_t_field%name) + else if (input_t_field%mesh%name=="P0Mesh") then + call allocate(output_t_field, output_p0mesh, input_t_field%name) + else + FLAbort("State from vtk_read_state should contain Mesh and P0Mesh only") + end if + call zero(output_t_field) + output_t_field%option_path = fields_path + call insert(output_state, output_t_field, output_t_field%name) + call deallocate(output_t_field) + end do + + + if(current_debug_level >= 2) then + ewrite(2, *) "Options tree:" + call print_options() + ewrite(2, *) "Input state:" + call print_state(input_state) + ewrite(2, *) "Output state:" + call print_state(output_state) + end if + + call sort_states_by_mesh( (/ input_state /), input_mesh_states) + call sort_states_by_mesh( (/ output_state /), output_mesh_states) + do i=1, size(input_mesh_states) + call insert(input_mesh_states(i), donor_positions, "Coordinate") + end do + do i=1, size(output_mesh_states) + call insert(output_mesh_states(i), target_positions, "Coordinate") + end do + ! do this insert after the sort_states_by_mesh as target_positions%mesh is seen as a different mesh + call insert(output_state, target_positions, "Coordinate") + call deallocate(donor_positions) + call deallocate(target_positions) + + call interpolation_galerkin(input_mesh_states, output_mesh_states, map_BA = map_BA) + call deallocate(map_BA) + deallocate(map_BA) + call deallocate(input_mesh_states) + deallocate(input_mesh_states) + call deallocate(output_mesh_states) + deallocate(output_mesh_states) + call deallocate(input_state) + + call vtk_write_state(trim(output_filename), model = "Mesh", state = (/output_state/)) + call deallocate(output_mesh) + if (has_mesh(output_state, "P0Mesh")) then + call deallocate(output_p0mesh) + end if + call deallocate(output_state) + + call print_references(0) + + ewrite(1, *) "Exiting project_vtu" end subroutine project_vtu diff --git a/tools/Streamfunction_2D.F90 b/tools/Streamfunction_2D.F90 index 48dc1c50de..c076f3df58 100644 --- a/tools/Streamfunction_2D.F90 +++ b/tools/Streamfunction_2D.F90 @@ -28,166 +28,166 @@ #include "fdebug.h" subroutine streamfunction_2d(input_basename_, input_basename_len, & - & output_basename_, output_basename_len) bind(c) - - use elements - use fields - use fetools - use fldebug - use global_parameters, only : FIELD_NAME_LEN - use reference_counting - use solvers - use sparse_tools - use sparsity_patterns_meshes - use state_module - use vtk_interfaces - use iso_c_binding - implicit none - - integer(kind=c_size_t), value :: input_basename_len, output_basename_len - - character(kind=c_char, len=1) :: input_basename_(*) - character(kind=c_char, len=1) :: output_basename_(*) - - character(len = input_basename_len) :: input_basename - character(len = output_basename_len) :: output_basename - character(len = FIELD_NAME_LEN) :: model - integer :: i, stat - type(csr_matrix) :: matrix - type(csr_sparsity), pointer :: sparsity - type(scalar_field) :: psi, rhs - type(state_type), pointer :: state - type(state_type), dimension(1), target :: states - type(vector_field), pointer :: positions, velocity - - ewrite(1, *) "In streamfunction_2d" - - do i=1, input_basename_len - input_basename(i:i)=input_basename_(i) - end do - do i=1, output_basename_len - output_basename(i:i)=output_basename_(i) - end do - - - state => states(1) - - call vtk_read_state(input_basename, state) - - positions => extract_vector_field(state, "Coordinate") - if(positions%dim /= 2) then - ewrite(-1,*) "Your problem is of dimension ", positions%dim - FLExit("streamfunction_2d requires a 2D input vtu") - end if - if(positions%mesh%continuity /= 0) then - ewrite(-1,*) "Your Coordinates mesh is not continuous" - FLExit("streamfunction_2d requires a continuous input vtu") - end if - - velocity => extract_vector_field(state, "Velocity") - assert(velocity%dim == positions%dim) - assert(ele_count(velocity) == ele_count(positions)) - ewrite_minmax(velocity) - - psi = extract_scalar_field(state, "StreamFunction", stat) - ! Horrible hack - actually need to allocate a new mesh here and add the - ! faces (but this is ok as we cheat below) - mesh%faces really needs to be a - ! pointer to a pointer to make this work nicely - if(stat == 0) then - if(.not. associated(psi%mesh%faces)) call add_faces(psi%mesh) - call incref(psi) - else - call allocate(psi, positions%mesh, "StreamFunction") - call zero(psi) - if(.not. associated(psi%mesh%faces)) call add_faces(psi%mesh) - call insert(state, psi, psi%name) - end if - assert(mesh_dim(psi) == positions%dim) - assert(ele_count(psi) == ele_count(positions)) - ewrite_minmax(psi) - - sparsity => get_csr_sparsity_firstorder(state, psi%mesh, psi%mesh) - call allocate(matrix, sparsity, name = trim(psi%name) // "Matrix") - call allocate(rhs, psi%mesh, name = trim(psi%name) // "Rhs") - - call zero(matrix) - call zero(rhs) - do i = 1, ele_count(psi) - call assemble_streamfunction_2d_element(i, matrix, rhs, positions, velocity) - end do - ewrite_minmax(rhs) - - do i = 1, surface_element_count(psi) - call set_inactive(matrix, face_global_nodes(rhs, i)) - call set(rhs, face_global_nodes(rhs, i), spread(0.0, 1, face_loc(rhs, i))) - end do - - call set_solver_options(psi, ksptype = "cg", pctype = "sor", rtol = 1.0e-10, max_its = 3000) - call petsc_solve(psi, matrix, rhs) - ewrite_minmax(psi) - - if(has_mesh(state, "CoordinateMesh")) then - model = "CoordinateMesh" - else - model = "Mesh" - end if - call vtk_write_state(output_basename, model = model, state = states) - - ! A hack so that we can manually deallocate the mesh, and hence deallocate the - ! faces - James was too busy to go digging in vtk_read_state - call incref(psi%mesh) - - call deallocate(psi) - call deallocate(matrix) - call deallocate(rhs) - call deallocate(state) - call deallocate(psi%mesh) - - call print_references(0) - - ewrite(1, *) "Exiting streamfunction_2d" +& output_basename_, output_basename_len) bind(c) + + use elements + use fields + use fetools + use fldebug + use global_parameters, only : FIELD_NAME_LEN + use reference_counting + use solvers + use sparse_tools + use sparsity_patterns_meshes + use state_module + use vtk_interfaces + use iso_c_binding + implicit none + + integer(kind=c_size_t), value :: input_basename_len, output_basename_len + + character(kind=c_char, len=1) :: input_basename_(*) + character(kind=c_char, len=1) :: output_basename_(*) + + character(len = input_basename_len) :: input_basename + character(len = output_basename_len) :: output_basename + character(len = FIELD_NAME_LEN) :: model + integer :: i, stat + type(csr_matrix) :: matrix + type(csr_sparsity), pointer :: sparsity + type(scalar_field) :: psi, rhs + type(state_type), pointer :: state + type(state_type), dimension(1), target :: states + type(vector_field), pointer :: positions, velocity + + ewrite(1, *) "In streamfunction_2d" + + do i=1, input_basename_len + input_basename(i:i)=input_basename_(i) + end do + do i=1, output_basename_len + output_basename(i:i)=output_basename_(i) + end do + + + state => states(1) + + call vtk_read_state(input_basename, state) + + positions => extract_vector_field(state, "Coordinate") + if(positions%dim /= 2) then + ewrite(-1,*) "Your problem is of dimension ", positions%dim + FLExit("streamfunction_2d requires a 2D input vtu") + end if + if(positions%mesh%continuity /= 0) then + ewrite(-1,*) "Your Coordinates mesh is not continuous" + FLExit("streamfunction_2d requires a continuous input vtu") + end if + + velocity => extract_vector_field(state, "Velocity") + assert(velocity%dim == positions%dim) + assert(ele_count(velocity) == ele_count(positions)) + ewrite_minmax(velocity) + + psi = extract_scalar_field(state, "StreamFunction", stat) + ! Horrible hack - actually need to allocate a new mesh here and add the + ! faces (but this is ok as we cheat below) - mesh%faces really needs to be a + ! pointer to a pointer to make this work nicely + if(stat == 0) then + if(.not. associated(psi%mesh%faces)) call add_faces(psi%mesh) + call incref(psi) + else + call allocate(psi, positions%mesh, "StreamFunction") + call zero(psi) + if(.not. associated(psi%mesh%faces)) call add_faces(psi%mesh) + call insert(state, psi, psi%name) + end if + assert(mesh_dim(psi) == positions%dim) + assert(ele_count(psi) == ele_count(positions)) + ewrite_minmax(psi) + + sparsity => get_csr_sparsity_firstorder(state, psi%mesh, psi%mesh) + call allocate(matrix, sparsity, name = trim(psi%name) // "Matrix") + call allocate(rhs, psi%mesh, name = trim(psi%name) // "Rhs") + + call zero(matrix) + call zero(rhs) + do i = 1, ele_count(psi) + call assemble_streamfunction_2d_element(i, matrix, rhs, positions, velocity) + end do + ewrite_minmax(rhs) + + do i = 1, surface_element_count(psi) + call set_inactive(matrix, face_global_nodes(rhs, i)) + call set(rhs, face_global_nodes(rhs, i), spread(0.0, 1, face_loc(rhs, i))) + end do + + call set_solver_options(psi, ksptype = "cg", pctype = "sor", rtol = 1.0e-10, max_its = 3000) + call petsc_solve(psi, matrix, rhs) + ewrite_minmax(psi) + + if(has_mesh(state, "CoordinateMesh")) then + model = "CoordinateMesh" + else + model = "Mesh" + end if + call vtk_write_state(output_basename, model = model, state = states) + + ! A hack so that we can manually deallocate the mesh, and hence deallocate the + ! faces - James was too busy to go digging in vtk_read_state + call incref(psi%mesh) + + call deallocate(psi) + call deallocate(matrix) + call deallocate(rhs) + call deallocate(state) + call deallocate(psi%mesh) + + call print_references(0) + + ewrite(1, *) "Exiting streamfunction_2d" contains - subroutine assemble_streamfunction_2d_element(ele, matrix, rhs, positions, velocity) - integer, intent(in) :: ele - type(csr_matrix), intent(inout) :: matrix - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(vector_field), intent(in) :: velocity + subroutine assemble_streamfunction_2d_element(ele, matrix, rhs, positions, velocity) + integer, intent(in) :: ele + type(csr_matrix), intent(inout) :: matrix + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(vector_field), intent(in) :: velocity - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(rhs, ele)) :: detwei, vorticity_gi - real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), mesh_dim(rhs)) :: dn_t - real, dimension(ele_loc(velocity, ele), ele_ngi(rhs, ele), mesh_dim(rhs)) :: du_t - type(element_type), pointer :: positions_shape, psi_shape, velocity_shape + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(rhs, ele)) :: detwei, vorticity_gi + real, dimension(ele_loc(rhs, ele), ele_ngi(rhs, ele), mesh_dim(rhs)) :: dn_t + real, dimension(ele_loc(velocity, ele), ele_ngi(rhs, ele), mesh_dim(rhs)) :: du_t + type(element_type), pointer :: positions_shape, psi_shape, velocity_shape - assert(ele_ngi(positions, ele) == ele_ngi(rhs, ele)) - assert(ele_ngi(velocity, ele) == ele_ngi(rhs, ele)) + assert(ele_ngi(positions, ele) == ele_ngi(rhs, ele)) + assert(ele_ngi(velocity, ele) == ele_ngi(rhs, ele)) - positions_shape => ele_shape(positions, ele) - psi_shape => ele_shape(rhs, ele) - velocity_shape => ele_shape(velocity, ele) + positions_shape => ele_shape(positions, ele) + psi_shape => ele_shape(rhs, ele) + velocity_shape => ele_shape(velocity, ele) - call transform_to_physical(positions, ele, psi_shape, & + call transform_to_physical(positions, ele, psi_shape, & & dshape = dn_t, detwei = detwei) - assert(sum(abs(detwei)) > epsilon(0.0)) + assert(sum(abs(detwei)) > epsilon(0.0)) - if(psi_shape == velocity_shape) then - du_t = dn_t - else - call transform_to_physical(positions, ele, velocity_shape, & - & dshape = du_t) - end if + if(psi_shape == velocity_shape) then + du_t = dn_t + else + call transform_to_physical(positions, ele, velocity_shape, & + & dshape = du_t) + end if - vorticity_gi = ele_2d_curl_at_quad(velocity, ele, du_t) + vorticity_gi = ele_2d_curl_at_quad(velocity, ele, du_t) - element_nodes => ele_nodes(rhs, ele) + element_nodes => ele_nodes(rhs, ele) - call addto(matrix, element_nodes, element_nodes, dshape_dot_dshape(dn_t, dn_t, detwei)) - call addto(rhs, element_nodes, shape_rhs(psi_shape, vorticity_gi * detwei)) + call addto(matrix, element_nodes, element_nodes, dshape_dot_dshape(dn_t, dn_t, detwei)) + call addto(rhs, element_nodes, shape_rhs(psi_shape, vorticity_gi * detwei)) - end subroutine assemble_streamfunction_2d_element + end subroutine assemble_streamfunction_2d_element end subroutine streamfunction_2d diff --git a/tools/Supermesh_Difference.F90 b/tools/Supermesh_Difference.F90 index b1165ef44d..d83c4e8a6b 100644 --- a/tools/Supermesh_Difference.F90 +++ b/tools/Supermesh_Difference.F90 @@ -28,353 +28,353 @@ #include "fdebug.h" subroutine supermesh_difference(vtu1_filename_, vtu1_filename_len, vtu2_filename_, & - &vtu2_filename_len, output_filename_, output_filename_len) bind(c) - use elements - use fields - use fldebug - use interpolation_module - use intersection_finder_module - use linked_lists - use reference_counting - use state_module - use supermesh_construction - use unify_meshes_module - use vtk_interfaces - use iso_c_binding - - implicit none - - integer(kind=c_size_t), value :: vtu1_filename_len, vtu2_filename_len, output_filename_len - character(kind=c_char, len=1) :: vtu1_filename_(*), vtu2_filename_(*), output_filename_(*) - - character(len = vtu1_filename_len) :: vtu1_filename - character(len = vtu2_filename_len) :: vtu2_filename - character(len = output_filename_len) :: output_filename - integer :: dim, ele_1, ele_2, ele_3, i, j, nintersections, nintersections_max - integer, dimension(:), allocatable :: ele_map_13, ele_map_23, node_map_13, & - & node_map_23 - integer, dimension(:, :), allocatable :: intersection_parents - logical :: p0 - type(element_type), pointer :: shape - type(ilist), dimension(:), allocatable :: ele_map_21 - type(inode), pointer :: node - type(mesh_type) :: pwc_mesh_3 - type(mesh_type), pointer :: mesh_3 - type(scalar_field) :: s_field_3 - type(scalar_field), pointer :: s_field, s_field_13, s_field_23 - type(state_type) :: state_1, state_2, state_3 - type(state_type), dimension(2) :: state_13, state_1_split, state_23, & - & state_2_split, state_3_split - type(tensor_field) :: t_field_3 - type(tensor_field), pointer :: t_field, t_field_13, t_field_23 - type(vector_field), pointer :: positions_1, positions_2, v_field, & - & v_field_13, v_field_23 - type(vector_field) :: intersection, v_field_3 - type(vector_field), target :: positions_3 - type(vector_field), dimension(:), allocatable :: intersections - - ewrite(1, *) "In supermesh_difference" - - do i=1, vtu1_filename_len - vtu1_filename(i:i)=vtu1_filename_(i) - end do - do i=1, vtu2_filename_len - vtu2_filename(i:i)=vtu2_filename_(i) - end do - do i=1, output_filename_len - output_filename(i:i)=output_filename_(i) - end do - - - call vtk_read_state(vtu1_filename, state_1) - call vtk_read_state(vtu2_filename, state_2) - - p0 = has_mesh(state_1, "P0Mesh") - - positions_1 => extract_vector_field(state_1, "Coordinate") - positions_2 => extract_vector_field(state_2, "Coordinate") - - dim = positions_1%dim - if(positions_2%dim /= dim) then - FLExit("Input vtu dimensions do not match") - end if - call intersector_set_dimension(dim) - call intersector_set_exactness(.false.) - - allocate(ele_map_21(ele_count(positions_1))) - ! Use the rtree to avoid continuity assumptions - ele_map_21 = rtree_intersection_finder(positions_1, positions_2) - - nintersections_max = sum(ele_map_21%length) - ewrite(2, "(a,i0)") "Maximum number of intersections: ", nintersections_max - allocate(intersections(nintersections_max)) - allocate(intersection_parents(nintersections_max, 2)) - nintersections = 0 - - do ele_1 = 1, ele_count(positions_1) - node => ele_map_21(ele_1)%firstnode - do while(associated(node)) - ele_2 = node%value - - ! TODO: Integrate the tet intersector - intersection = intersect_elements(positions_1, ele_1, ele_val(positions_2, ele_2), ele_shape(positions_1, ele_1)) - if(ele_count(intersection) > 0) then - nintersections = nintersections + 1 - intersections(nintersections) = intersection - intersection_parents(nintersections, :) = (/ele_1, ele_2/) +&vtu2_filename_len, output_filename_, output_filename_len) bind(c) + use elements + use fields + use fldebug + use interpolation_module + use intersection_finder_module + use linked_lists + use reference_counting + use state_module + use supermesh_construction + use unify_meshes_module + use vtk_interfaces + use iso_c_binding + + implicit none + + integer(kind=c_size_t), value :: vtu1_filename_len, vtu2_filename_len, output_filename_len + character(kind=c_char, len=1) :: vtu1_filename_(*), vtu2_filename_(*), output_filename_(*) + + character(len = vtu1_filename_len) :: vtu1_filename + character(len = vtu2_filename_len) :: vtu2_filename + character(len = output_filename_len) :: output_filename + integer :: dim, ele_1, ele_2, ele_3, i, j, nintersections, nintersections_max + integer, dimension(:), allocatable :: ele_map_13, ele_map_23, node_map_13, & + & node_map_23 + integer, dimension(:, :), allocatable :: intersection_parents + logical :: p0 + type(element_type), pointer :: shape + type(ilist), dimension(:), allocatable :: ele_map_21 + type(inode), pointer :: node + type(mesh_type) :: pwc_mesh_3 + type(mesh_type), pointer :: mesh_3 + type(scalar_field) :: s_field_3 + type(scalar_field), pointer :: s_field, s_field_13, s_field_23 + type(state_type) :: state_1, state_2, state_3 + type(state_type), dimension(2) :: state_13, state_1_split, state_23, & + & state_2_split, state_3_split + type(tensor_field) :: t_field_3 + type(tensor_field), pointer :: t_field, t_field_13, t_field_23 + type(vector_field), pointer :: positions_1, positions_2, v_field, & + & v_field_13, v_field_23 + type(vector_field) :: intersection, v_field_3 + type(vector_field), target :: positions_3 + type(vector_field), dimension(:), allocatable :: intersections + + ewrite(1, *) "In supermesh_difference" + + do i=1, vtu1_filename_len + vtu1_filename(i:i)=vtu1_filename_(i) + end do + do i=1, vtu2_filename_len + vtu2_filename(i:i)=vtu2_filename_(i) + end do + do i=1, output_filename_len + output_filename(i:i)=output_filename_(i) + end do + + + call vtk_read_state(vtu1_filename, state_1) + call vtk_read_state(vtu2_filename, state_2) + + p0 = has_mesh(state_1, "P0Mesh") + + positions_1 => extract_vector_field(state_1, "Coordinate") + positions_2 => extract_vector_field(state_2, "Coordinate") + + dim = positions_1%dim + if(positions_2%dim /= dim) then + FLExit("Input vtu dimensions do not match") + end if + call intersector_set_dimension(dim) + call intersector_set_exactness(.false.) + + allocate(ele_map_21(ele_count(positions_1))) + ! Use the rtree to avoid continuity assumptions + ele_map_21 = rtree_intersection_finder(positions_1, positions_2) + + nintersections_max = sum(ele_map_21%length) + ewrite(2, "(a,i0)") "Maximum number of intersections: ", nintersections_max + allocate(intersections(nintersections_max)) + allocate(intersection_parents(nintersections_max, 2)) + nintersections = 0 + + do ele_1 = 1, ele_count(positions_1) + node => ele_map_21(ele_1)%firstnode + do while(associated(node)) + ele_2 = node%value + + ! TODO: Integrate the tet intersector + intersection = intersect_elements(positions_1, ele_1, ele_val(positions_2, ele_2), ele_shape(positions_1, ele_1)) + if(ele_count(intersection) > 0) then + nintersections = nintersections + 1 + intersections(nintersections) = intersection + intersection_parents(nintersections, :) = (/ele_1, ele_2/) + else + call deallocate(intersection) + end if + + node => node%next + end do + end do + call deallocate(ele_map_21) + deallocate(ele_map_21) + + ewrite(2, "(a,i0)") "Number of intersections: ", nintersections + + positions_3 = unify_meshes(intersections(:nintersections)) + positions_3%name = "Coordinate" + allocate(node_map_13(node_count(positions_3))) + allocate(node_map_23(node_count(positions_3))) + if(p0) then + allocate(ele_map_13(ele_count(positions_3))) + allocate(ele_map_23(ele_count(positions_3))) + end if + ele_3 = 0 + do i = 1, nintersections + do j = 1, ele_count(intersections(i)) + ele_3 = ele_3 + 1 + node_map_13(ele_nodes(positions_3, ele_3)) = intersection_parents(i, 1) + node_map_23(ele_nodes(positions_3, ele_3)) = intersection_parents(i, 2) + if(p0) then + ele_map_13(ele_3) = intersection_parents(i, 1) + ele_map_23(ele_3) = intersection_parents(i, 2) + end if + end do + call deallocate(intersections(i)) + end do + deallocate(intersections) + deallocate(intersection_parents) + + mesh_3 => positions_3%mesh + pwc_mesh_3 = piecewise_constant_mesh(mesh_3, "PiecewiseConstantMesh") + + call insert(state_3, positions_3, "Coordinate") + call insert(state_1_split(1), positions_1, "Coordinate") + call insert(state_2_split(1), positions_2, "Coordinate") + call insert(state_13(1), positions_3, "Coordinate") + call insert(state_23(1), positions_3, "Coordinate") + call insert(state_3_split(1), positions_3, "Coordinate") + call insert(state_1_split(1), positions_1%mesh, "Mesh") + call insert(state_13(1), mesh_3, "Mesh") + call insert(state_2_split(1), positions_2%mesh, "Mesh") + call insert(state_23(1), mesh_3, "Mesh") + call insert(state_3, mesh_3, "Mesh") + call insert(state_3_split(1), mesh_3, "Mesh") + if(p0) then + call insert(state_1_split(2), positions_1, "Coordinate") + call insert(state_2_split(2), positions_2, "Coordinate") + call insert(state_13(2), positions_3, "Coordinate") + call insert(state_23(2), positions_3, "Coordinate") + call insert(state_3_split(2), positions_3, "Coordinate") + call insert(state_1_split(2), extract_mesh(state_1, "P0Mesh"), "Mesh") + call insert(state_2_split(2), extract_mesh(state_2, "P0Mesh"), "Mesh") + call insert(state_13(2), pwc_mesh_3, "Mesh") + call insert(state_23(2), pwc_mesh_3, "Mesh") + call insert(state_3_split(2), pwc_mesh_3, "Mesh") + end if + call deallocate(positions_3) + + do i = 1, scalar_field_count(state_1) + s_field => extract_scalar_field(state_1, i) + shape => ele_shape(s_field, 1) + + if(shape%degree == 0) then + assert(p0) + call insert(state_1_split(2), s_field, s_field%name) + call insert(state_2_split(2), extract_scalar_field(state_2, s_field%name), s_field%name) + + call allocate(s_field_3, pwc_mesh_3, s_field%name) + call insert(state_13(2), s_field_3, s_field_3%name) + else + call insert(state_1_split(1), s_field, s_field%name) + call insert(state_2_split(1), extract_scalar_field(state_2, s_field%name), s_field%name) + + call allocate(s_field_3, mesh_3, s_field%name) + call insert(state_13(1), s_field_3, s_field_3%name) + end if + call deallocate(s_field_3) + + if(shape%degree == 0) then + call allocate(s_field_3, pwc_mesh_3, s_field%name) + call insert(state_23(2), s_field_3, s_field_3%name) + else + call allocate(s_field_3, mesh_3, s_field%name) + call insert(state_23(1), s_field_3, s_field_3%name) + end if + call deallocate(s_field_3) + + if(shape%degree == 0) then + call allocate(s_field_3, pwc_mesh_3, s_field%name) + call insert(state_3_split(2), s_field_3, s_field_3%name) + else + call allocate(s_field_3, mesh_3, s_field%name) + call insert(state_3_split(1), s_field_3, s_field_3%name) + end if + call insert(state_3, s_field_3, s_field_3%name) + call deallocate(s_field_3) + end do + do i = 1, vector_field_count(state_1) + v_field => extract_vector_field(state_1, i) + if(v_field%name == "Coordinate") cycle + shape => ele_shape(v_field, 1) + + if(shape%degree == 0) then + assert(p0) + call insert(state_1_split(2), v_field, v_field%name) + call insert(state_2_split(2), extract_vector_field(state_2, v_field%name), v_field%name) + + call allocate(v_field_3, dim, pwc_mesh_3, v_field%name) + call insert(state_13(2), v_field_3, v_field_3%name) + else + call insert(state_1_split(1), v_field, v_field%name) + call insert(state_2_split(1), extract_vector_field(state_2, v_field%name), v_field%name) + + call allocate(v_field_3, dim, mesh_3, v_field%name) + call insert(state_13(1), v_field_3, v_field_3%name) + end if + call deallocate(v_field_3) + + if(shape%degree == 0) then + call allocate(v_field_3, dim, pwc_mesh_3, v_field%name) + call insert(state_23(2), v_field_3, v_field_3%name) + else + call allocate(v_field_3, dim, mesh_3, v_field%name) + call insert(state_23(1), v_field_3, v_field_3%name) + end if + call deallocate(v_field_3) + + if(shape%degree == 0) then + call allocate(v_field_3, dim, pwc_mesh_3, v_field%name) + call insert(state_3_split(2), v_field_3, v_field_3%name) + else + call allocate(v_field_3, dim, mesh_3, v_field%name) + call insert(state_3_split(1), v_field_3, v_field_3%name) + end if + call insert(state_3, v_field_3, v_field_3%name) + call deallocate(v_field_3) + end do + do i = 1, tensor_field_count(state_1) + t_field => extract_tensor_field(state_1, i) + shape => ele_shape(t_field, 1) + + if(shape%degree == 0) then + assert(p0) + call insert(state_1_split(2), t_field, t_field%name) + call insert(state_2_split(2), extract_tensor_field(state_2, t_field%name), t_field%name) + + call allocate(t_field_3, pwc_mesh_3, t_field%name) + call insert(state_13(2), t_field_3, t_field_3%name) + else + call insert(state_1_split(1), t_field, t_field%name) + call insert(state_2_split(1), extract_tensor_field(state_2, t_field%name), t_field%name) + + call allocate(t_field_3, mesh_3, t_field%name) + call insert(state_13(1), t_field_3, t_field_3%name) + end if + call deallocate(t_field_3) + + if(shape%degree == 0) then + call allocate(t_field_3, pwc_mesh_3, t_field%name) + call insert(state_23(2), t_field_3, t_field_3%name) else - call deallocate(intersection) + call allocate(t_field_3, mesh_3, t_field%name) + call insert(state_23(1), t_field_3, t_field_3%name) end if + call deallocate(t_field_3) - node => node%next - end do - end do - call deallocate(ele_map_21) - deallocate(ele_map_21) - - ewrite(2, "(a,i0)") "Number of intersections: ", nintersections - - positions_3 = unify_meshes(intersections(:nintersections)) - positions_3%name = "Coordinate" - allocate(node_map_13(node_count(positions_3))) - allocate(node_map_23(node_count(positions_3))) - if(p0) then - allocate(ele_map_13(ele_count(positions_3))) - allocate(ele_map_23(ele_count(positions_3))) - end if - ele_3 = 0 - do i = 1, nintersections - do j = 1, ele_count(intersections(i)) - ele_3 = ele_3 + 1 - node_map_13(ele_nodes(positions_3, ele_3)) = intersection_parents(i, 1) - node_map_23(ele_nodes(positions_3, ele_3)) = intersection_parents(i, 2) - if(p0) then - ele_map_13(ele_3) = intersection_parents(i, 1) - ele_map_23(ele_3) = intersection_parents(i, 2) + if(shape%degree == 0) then + call allocate(t_field_3, pwc_mesh_3, t_field%name) + call insert(state_3_split(2), t_field_3, t_field_3%name) + else + call allocate(t_field_3, mesh_3, t_field%name) + call insert(state_3_split(1), t_field_3, t_field_3%name) end if - end do - call deallocate(intersections(i)) - end do - deallocate(intersections) - deallocate(intersection_parents) - - mesh_3 => positions_3%mesh - pwc_mesh_3 = piecewise_constant_mesh(mesh_3, "PiecewiseConstantMesh") - - call insert(state_3, positions_3, "Coordinate") - call insert(state_1_split(1), positions_1, "Coordinate") - call insert(state_2_split(1), positions_2, "Coordinate") - call insert(state_13(1), positions_3, "Coordinate") - call insert(state_23(1), positions_3, "Coordinate") - call insert(state_3_split(1), positions_3, "Coordinate") - call insert(state_1_split(1), positions_1%mesh, "Mesh") - call insert(state_13(1), mesh_3, "Mesh") - call insert(state_2_split(1), positions_2%mesh, "Mesh") - call insert(state_23(1), mesh_3, "Mesh") - call insert(state_3, mesh_3, "Mesh") - call insert(state_3_split(1), mesh_3, "Mesh") - if(p0) then - call insert(state_1_split(2), positions_1, "Coordinate") - call insert(state_2_split(2), positions_2, "Coordinate") - call insert(state_13(2), positions_3, "Coordinate") - call insert(state_23(2), positions_3, "Coordinate") - call insert(state_3_split(2), positions_3, "Coordinate") - call insert(state_1_split(2), extract_mesh(state_1, "P0Mesh"), "Mesh") - call insert(state_2_split(2), extract_mesh(state_2, "P0Mesh"), "Mesh") - call insert(state_13(2), pwc_mesh_3, "Mesh") - call insert(state_23(2), pwc_mesh_3, "Mesh") - call insert(state_3_split(2), pwc_mesh_3, "Mesh") - end if - call deallocate(positions_3) - - do i = 1, scalar_field_count(state_1) - s_field => extract_scalar_field(state_1, i) - shape => ele_shape(s_field, 1) - - if(shape%degree == 0) then - assert(p0) - call insert(state_1_split(2), s_field, s_field%name) - call insert(state_2_split(2), extract_scalar_field(state_2, s_field%name), s_field%name) - - call allocate(s_field_3, pwc_mesh_3, s_field%name) - call insert(state_13(2), s_field_3, s_field_3%name) - else - call insert(state_1_split(1), s_field, s_field%name) - call insert(state_2_split(1), extract_scalar_field(state_2, s_field%name), s_field%name) - - call allocate(s_field_3, mesh_3, s_field%name) - call insert(state_13(1), s_field_3, s_field_3%name) - end if - call deallocate(s_field_3) - - if(shape%degree == 0) then - call allocate(s_field_3, pwc_mesh_3, s_field%name) - call insert(state_23(2), s_field_3, s_field_3%name) - else - call allocate(s_field_3, mesh_3, s_field%name) - call insert(state_23(1), s_field_3, s_field_3%name) - end if - call deallocate(s_field_3) - - if(shape%degree == 0) then - call allocate(s_field_3, pwc_mesh_3, s_field%name) - call insert(state_3_split(2), s_field_3, s_field_3%name) - else - call allocate(s_field_3, mesh_3, s_field%name) - call insert(state_3_split(1), s_field_3, s_field_3%name) - end if - call insert(state_3, s_field_3, s_field_3%name) - call deallocate(s_field_3) - end do - do i = 1, vector_field_count(state_1) - v_field => extract_vector_field(state_1, i) - if(v_field%name == "Coordinate") cycle - shape => ele_shape(v_field, 1) - - if(shape%degree == 0) then - assert(p0) - call insert(state_1_split(2), v_field, v_field%name) - call insert(state_2_split(2), extract_vector_field(state_2, v_field%name), v_field%name) - - call allocate(v_field_3, dim, pwc_mesh_3, v_field%name) - call insert(state_13(2), v_field_3, v_field_3%name) - else - call insert(state_1_split(1), v_field, v_field%name) - call insert(state_2_split(1), extract_vector_field(state_2, v_field%name), v_field%name) - - call allocate(v_field_3, dim, mesh_3, v_field%name) - call insert(state_13(1), v_field_3, v_field_3%name) - end if - call deallocate(v_field_3) - - if(shape%degree == 0) then - call allocate(v_field_3, dim, pwc_mesh_3, v_field%name) - call insert(state_23(2), v_field_3, v_field_3%name) - else - call allocate(v_field_3, dim, mesh_3, v_field%name) - call insert(state_23(1), v_field_3, v_field_3%name) - end if - call deallocate(v_field_3) - - if(shape%degree == 0) then - call allocate(v_field_3, dim, pwc_mesh_3, v_field%name) - call insert(state_3_split(2), v_field_3, v_field_3%name) - else - call allocate(v_field_3, dim, mesh_3, v_field%name) - call insert(state_3_split(1), v_field_3, v_field_3%name) - end if - call insert(state_3, v_field_3, v_field_3%name) - call deallocate(v_field_3) - end do - do i = 1, tensor_field_count(state_1) - t_field => extract_tensor_field(state_1, i) - shape => ele_shape(t_field, 1) - - if(shape%degree == 0) then - assert(p0) - call insert(state_1_split(2), t_field, t_field%name) - call insert(state_2_split(2), extract_tensor_field(state_2, t_field%name), t_field%name) - - call allocate(t_field_3, pwc_mesh_3, t_field%name) - call insert(state_13(2), t_field_3, t_field_3%name) - else - call insert(state_1_split(1), t_field, t_field%name) - call insert(state_2_split(1), extract_tensor_field(state_2, t_field%name), t_field%name) - - call allocate(t_field_3, mesh_3, t_field%name) - call insert(state_13(1), t_field_3, t_field_3%name) - end if - call deallocate(t_field_3) - - if(shape%degree == 0) then - call allocate(t_field_3, pwc_mesh_3, t_field%name) - call insert(state_23(2), t_field_3, t_field_3%name) - else - call allocate(t_field_3, mesh_3, t_field%name) - call insert(state_23(1), t_field_3, t_field_3%name) - end if - call deallocate(t_field_3) - - if(shape%degree == 0) then - call allocate(t_field_3, pwc_mesh_3, t_field%name) - call insert(state_3_split(2), t_field_3, t_field_3%name) - else - call allocate(t_field_3, mesh_3, t_field%name) - call insert(state_3_split(1), t_field_3, t_field_3%name) - end if - call insert(state_3, t_field_3, t_field_3%name) - call deallocate(t_field_3) - end do - call deallocate(pwc_mesh_3) - - call linear_interpolation(state_1_split(1), state_13(1), map = node_map_13) - deallocate(node_map_13) - call linear_interpolation(state_2_split(1), state_23(1), map = node_map_23) - deallocate(node_map_23) - if(p0) then - call linear_interpolation(state_1_split(2), state_13(2), map = ele_map_13) - deallocate(ele_map_13) - call linear_interpolation(state_2_split(2), state_23(2), map = ele_map_23) - deallocate(ele_map_23) - end if - call deallocate(state_1_split) - call deallocate(state_1) - call deallocate(state_2_split) - call deallocate(state_2) - - do i = 1, scalar_field_count(state_13(1)) - s_field_13 => extract_scalar_field(state_13(1), i) - s_field_23 => extract_scalar_field(state_23(1), s_field_13%name) - s_field_3 = extract_scalar_field(state_3_split(1), s_field_13%name) - s_field_3%val = s_field_13%val - s_field_23%val - end do - do i = 1, vector_field_count(state_13(1)) - v_field_13 => extract_vector_field(state_13(1), i) - if(v_field_13%name == "Coordinate") cycle - v_field_23 => extract_vector_field(state_23(1), v_field_13%name) - v_field_3 = extract_vector_field(state_3_split(1), v_field_13%name) - do j = 1, dim - v_field_3%val(i,:) = v_field_13%val(i,:) - v_field_23%val(i,:) - end do - end do - do i = 1, tensor_field_count(state_13(1)) - t_field_13 => extract_tensor_field(state_13(1), i) - t_field_23 => extract_tensor_field(state_23(1), t_field_13%name) - t_field_3 = extract_tensor_field(state_3_split(1), t_field_13%name) - t_field_3%val = t_field_13%val - t_field_23%val - end do - if(p0) then - do i = 1, scalar_field_count(state_13(2)) - s_field_13 => extract_scalar_field(state_13(2), i) - s_field_23 => extract_scalar_field(state_23(2), s_field_13%name) - s_field_3 = extract_scalar_field(state_3_split(2), s_field_13%name) + call insert(state_3, t_field_3, t_field_3%name) + call deallocate(t_field_3) + end do + call deallocate(pwc_mesh_3) + + call linear_interpolation(state_1_split(1), state_13(1), map = node_map_13) + deallocate(node_map_13) + call linear_interpolation(state_2_split(1), state_23(1), map = node_map_23) + deallocate(node_map_23) + if(p0) then + call linear_interpolation(state_1_split(2), state_13(2), map = ele_map_13) + deallocate(ele_map_13) + call linear_interpolation(state_2_split(2), state_23(2), map = ele_map_23) + deallocate(ele_map_23) + end if + call deallocate(state_1_split) + call deallocate(state_1) + call deallocate(state_2_split) + call deallocate(state_2) + + do i = 1, scalar_field_count(state_13(1)) + s_field_13 => extract_scalar_field(state_13(1), i) + s_field_23 => extract_scalar_field(state_23(1), s_field_13%name) + s_field_3 = extract_scalar_field(state_3_split(1), s_field_13%name) s_field_3%val = s_field_13%val - s_field_23%val - end do - do i = 1, vector_field_count(state_13(2)) - v_field_13 => extract_vector_field(state_13(2), i) + end do + do i = 1, vector_field_count(state_13(1)) + v_field_13 => extract_vector_field(state_13(1), i) if(v_field_13%name == "Coordinate") cycle - v_field_23 => extract_vector_field(state_23(2), v_field_13%name) - v_field_3 = extract_vector_field(state_3_split(2), v_field_13%name) + v_field_23 => extract_vector_field(state_23(1), v_field_13%name) + v_field_3 = extract_vector_field(state_3_split(1), v_field_13%name) do j = 1, dim - v_field_3%val(i,:) = v_field_13%val(i,:) - v_field_23%val(i,:) + v_field_3%val(i,:) = v_field_13%val(i,:) - v_field_23%val(i,:) end do - end do - do i = 1, tensor_field_count(state_13(2)) - t_field_13 => extract_tensor_field(state_13(2), i) - t_field_23 => extract_tensor_field(state_23(2), t_field_13%name) - t_field_3 = extract_tensor_field(state_3_split(2), t_field_13%name) + end do + do i = 1, tensor_field_count(state_13(1)) + t_field_13 => extract_tensor_field(state_13(1), i) + t_field_23 => extract_tensor_field(state_23(1), t_field_13%name) + t_field_3 = extract_tensor_field(state_3_split(1), t_field_13%name) t_field_3%val = t_field_13%val - t_field_23%val - end do - end if - call deallocate(state_13) - call deallocate(state_23) - call deallocate(state_3_split) + end do + if(p0) then + do i = 1, scalar_field_count(state_13(2)) + s_field_13 => extract_scalar_field(state_13(2), i) + s_field_23 => extract_scalar_field(state_23(2), s_field_13%name) + s_field_3 = extract_scalar_field(state_3_split(2), s_field_13%name) + s_field_3%val = s_field_13%val - s_field_23%val + end do + do i = 1, vector_field_count(state_13(2)) + v_field_13 => extract_vector_field(state_13(2), i) + if(v_field_13%name == "Coordinate") cycle + v_field_23 => extract_vector_field(state_23(2), v_field_13%name) + v_field_3 = extract_vector_field(state_3_split(2), v_field_13%name) + do j = 1, dim + v_field_3%val(i,:) = v_field_13%val(i,:) - v_field_23%val(i,:) + end do + end do + do i = 1, tensor_field_count(state_13(2)) + t_field_13 => extract_tensor_field(state_13(2), i) + t_field_23 => extract_tensor_field(state_23(2), t_field_13%name) + t_field_3 = extract_tensor_field(state_3_split(2), t_field_13%name) + t_field_3%val = t_field_13%val - t_field_23%val + end do + end if + call deallocate(state_13) + call deallocate(state_23) + call deallocate(state_3_split) - call vtk_write_state(output_filename, state = (/state_3/)) - call deallocate(state_3) + call vtk_write_state(output_filename, state = (/state_3/)) + call deallocate(state_3) - call print_references(0) + call print_references(0) - ewrite(1, *) "Exiting supermesh_difference" + ewrite(1, *) "Exiting supermesh_difference" end subroutine supermesh_difference diff --git a/tools/Vertical_Integration.F90 b/tools/Vertical_Integration.F90 index 7376ab4ac8..3c4feba590 100644 --- a/tools/Vertical_Integration.F90 +++ b/tools/Vertical_Integration.F90 @@ -1,363 +1,363 @@ #include "fdebug.h" subroutine vertical_integration(target_basename_, target_basename_len, & - & integrated_filename_, integrated_filename_len, & - & output_basename_, output_basename_len, & - & top, bottom, sizing, field_b_continuity, field_b_degree) bind(c) - - use fetools, only: shape_shape, shape_rhs - use transform_elements - use elements - use fields - use fldebug - use global_parameters, only : current_debug_level, OPTION_PATH_LEN - use hadapt_extrude - use halos - use intersection_finder_module - use linked_lists - use read_gmsh - use reference_counting - use solvers - use sparse_tools - use sparsity_patterns - use spud - use state_module - use supermesh_assembly - use supermesh_construction - use tetrahedron_intersection_module - use vtk_interfaces - use mesh_files - use iso_c_binding - - implicit none - - integer(kind=c_size_t), value :: target_basename_len - integer(kind=c_size_t), value :: integrated_filename_len - integer(kind=c_size_t), value :: output_basename_len - real(kind=c_double), value :: top, bottom, sizing - integer(kind=c_int), value :: field_b_continuity - integer(kind=c_int), value :: field_b_degree - character(kind=c_char, len=1) :: target_basename_(*) - character(kind=c_char, len=1) :: integrated_filename_(*), output_basename_(*) - - - character(len = target_basename_len) :: target_basename - character(len = integrated_filename_len) :: integrated_filename - character(len = output_basename_len) :: output_basename - character(len = *), parameter :: solver_path = "/temporary/solver/path" - character(len = OPTION_PATH_LEN) :: base_path, mesh_path - integer :: dim, ele_a, ele_b, ele_b_surf, i, index, j, k, nele_as, stat - integer, parameter :: quad_degree = 4 - real, dimension(:, :), allocatable :: lshape - type(csr_matrix) :: matrix - type(csr_sparsity) :: sparsity - type(element_type) :: field_b_shape, field_b_shape_ext - type(element_type), pointer :: field_c_shape, positions_b_surf_shape - type(mesh_type), pointer :: field_a_mesh, field_c_mesh - type(mesh_type) :: field_b_mesh - type(plane_type), dimension(4) :: planes_b - type(scalar_field), dimension(:), allocatable :: field_a, field_b, field_c, rhs - type(state_type) :: state_a, state_b - type(tet_type) :: tet_a, tet_b - type(vector_field) :: positions_b_ext, positions_b_surf, vfield_b - type(vector_field), pointer :: positions_a, vfield_a - type(vector_field), target :: positions_c - logical :: empty_intersection - - ewrite(-1, *) "In vertical_integration" - - do i=1, target_basename_len - target_basename(i:i)=target_basename_(i) - end do - do i=1, integrated_filename_len - integrated_filename(i:i)=integrated_filename_(i) - end do - do i=1, output_basename_len - output_basename(i:i)=output_basename_(i) - end do - ! Step 1: Read in the data - write(*,*) target_basename, output_basename, integrated_filename - - positions_b_surf = read_gmsh_file(target_basename, quad_degree = quad_degree) - dim = positions_b_surf%dim + 1 - - call vtk_read_state(integrated_filename, state_a, quad_degree = quad_degree) - positions_a => extract_vector_field(state_a, "Coordinate") - field_a_mesh => extract_mesh(state_a, "Mesh") - if(positions_a%dim /= positions_b_surf%dim + 1) then - ewrite(-1, *) "Integrated mesh dimension: ", positions_a%dim - ewrite(-1, *) "Target mesh dimension: ", positions_b_surf%dim - FLExit("Integrated mesh must have dimension one higher than the target mesh") - end if - - assert(ele_count(positions_b_surf) > 0) - positions_b_surf_shape => ele_shape(positions_b_surf, 1) - field_b_shape = make_element_shape(positions_b_surf_shape%numbering%vertices, positions_b_surf_shape%dim, field_b_degree, quad = positions_b_surf_shape%quadrature) - if(field_b_degree == 0) then - field_b_mesh = make_mesh(positions_b_surf%mesh, field_b_shape, name = "VerticalIntegralMesh", continuity = field_b_continuity) - else - field_b_mesh = make_mesh(positions_b_surf%mesh, field_b_shape, name = "VerticalIntegralMesh", continuity = field_b_continuity) - end if - call deallocate(field_b_shape) - - call insert(state_b, field_b_mesh, field_b_mesh%name) - call insert(state_b, positions_b_surf, "Coordinate") - assert(has_vector_field(state_a, "Coordinate")) - allocate(field_a(scalar_field_count(state_a) + dim * (vector_field_count(state_a) - 1))) - allocate(field_b(size(field_a))) - do i = 1, scalar_field_count(state_a) - field_a(i) = extract_scalar_field(state_a, i) - if(.not. field_a(i)%mesh == field_a_mesh) then - if(field_a(i)%mesh%shape%degree == 0) then - FLExit("vertical_integration does not support degree zero donor fields") - else - ewrite(-1, *) "Donor field mesh: " // trim(field_a(i)%mesh%name) - ewrite(-1, *) "With degree: ", field_a(i)%mesh%shape%degree - FLAbort("Unexpected donor field mesh") +& integrated_filename_, integrated_filename_len, & +& output_basename_, output_basename_len, & +& top, bottom, sizing, field_b_continuity, field_b_degree) bind(c) + + use fetools, only: shape_shape, shape_rhs + use transform_elements + use elements + use fields + use fldebug + use global_parameters, only : current_debug_level, OPTION_PATH_LEN + use hadapt_extrude + use halos + use intersection_finder_module + use linked_lists + use read_gmsh + use reference_counting + use solvers + use sparse_tools + use sparsity_patterns + use spud + use state_module + use supermesh_assembly + use supermesh_construction + use tetrahedron_intersection_module + use vtk_interfaces + use mesh_files + use iso_c_binding + + implicit none + + integer(kind=c_size_t), value :: target_basename_len + integer(kind=c_size_t), value :: integrated_filename_len + integer(kind=c_size_t), value :: output_basename_len + real(kind=c_double), value :: top, bottom, sizing + integer(kind=c_int), value :: field_b_continuity + integer(kind=c_int), value :: field_b_degree + character(kind=c_char, len=1) :: target_basename_(*) + character(kind=c_char, len=1) :: integrated_filename_(*), output_basename_(*) + + + character(len = target_basename_len) :: target_basename + character(len = integrated_filename_len) :: integrated_filename + character(len = output_basename_len) :: output_basename + character(len = *), parameter :: solver_path = "/temporary/solver/path" + character(len = OPTION_PATH_LEN) :: base_path, mesh_path + integer :: dim, ele_a, ele_b, ele_b_surf, i, index, j, k, nele_as, stat + integer, parameter :: quad_degree = 4 + real, dimension(:, :), allocatable :: lshape + type(csr_matrix) :: matrix + type(csr_sparsity) :: sparsity + type(element_type) :: field_b_shape, field_b_shape_ext + type(element_type), pointer :: field_c_shape, positions_b_surf_shape + type(mesh_type), pointer :: field_a_mesh, field_c_mesh + type(mesh_type) :: field_b_mesh + type(plane_type), dimension(4) :: planes_b + type(scalar_field), dimension(:), allocatable :: field_a, field_b, field_c, rhs + type(state_type) :: state_a, state_b + type(tet_type) :: tet_a, tet_b + type(vector_field) :: positions_b_ext, positions_b_surf, vfield_b + type(vector_field), pointer :: positions_a, vfield_a + type(vector_field), target :: positions_c + logical :: empty_intersection + + ewrite(-1, *) "In vertical_integration" + + do i=1, target_basename_len + target_basename(i:i)=target_basename_(i) + end do + do i=1, integrated_filename_len + integrated_filename(i:i)=integrated_filename_(i) + end do + do i=1, output_basename_len + output_basename(i:i)=output_basename_(i) + end do + ! Step 1: Read in the data + write(*,*) target_basename, output_basename, integrated_filename + + positions_b_surf = read_gmsh_file(target_basename, quad_degree = quad_degree) + dim = positions_b_surf%dim + 1 + + call vtk_read_state(integrated_filename, state_a, quad_degree = quad_degree) + positions_a => extract_vector_field(state_a, "Coordinate") + field_a_mesh => extract_mesh(state_a, "Mesh") + if(positions_a%dim /= positions_b_surf%dim + 1) then + ewrite(-1, *) "Integrated mesh dimension: ", positions_a%dim + ewrite(-1, *) "Target mesh dimension: ", positions_b_surf%dim + FLExit("Integrated mesh must have dimension one higher than the target mesh") + end if + + assert(ele_count(positions_b_surf) > 0) + positions_b_surf_shape => ele_shape(positions_b_surf, 1) + field_b_shape = make_element_shape(positions_b_surf_shape%numbering%vertices, positions_b_surf_shape%dim, field_b_degree, quad = positions_b_surf_shape%quadrature) + if(field_b_degree == 0) then + field_b_mesh = make_mesh(positions_b_surf%mesh, field_b_shape, name = "VerticalIntegralMesh", continuity = field_b_continuity) + else + field_b_mesh = make_mesh(positions_b_surf%mesh, field_b_shape, name = "VerticalIntegralMesh", continuity = field_b_continuity) + end if + call deallocate(field_b_shape) + + call insert(state_b, field_b_mesh, field_b_mesh%name) + call insert(state_b, positions_b_surf, "Coordinate") + assert(has_vector_field(state_a, "Coordinate")) + allocate(field_a(scalar_field_count(state_a) + dim * (vector_field_count(state_a) - 1))) + allocate(field_b(size(field_a))) + do i = 1, scalar_field_count(state_a) + field_a(i) = extract_scalar_field(state_a, i) + if(.not. field_a(i)%mesh == field_a_mesh) then + if(field_a(i)%mesh%shape%degree == 0) then + FLExit("vertical_integration does not support degree zero donor fields") + else + ewrite(-1, *) "Donor field mesh: " // trim(field_a(i)%mesh%name) + ewrite(-1, *) "With degree: ", field_a(i)%mesh%shape%degree + FLAbort("Unexpected donor field mesh") + end if end if - end if - call allocate(field_b(i), field_b_mesh, field_a(i)%name) - call zero(field_b(i)) - call insert(state_b, field_b(i), field_b(i)%name) - call deallocate(field_b(i)) - field_b(i) = extract_scalar_field(state_b, i) - end do - index = scalar_field_count(state_a) - do i = 1, vector_field_count(state_a) - vfield_a => extract_vector_field(state_a, i) - if(.not. vfield_a%mesh == field_a_mesh) then - if(vfield_a%mesh%shape%degree == 0) then - FLExit("vertical_integration does not support degree zero donor fields") - else - ewrite(-1, *) "Donor field mesh: " // trim(vfield_a%mesh%name) - ewrite(-1, *) "With degree: ", vfield_a%mesh%shape%degree - FLAbort("Unexpected donor field mesh") + call allocate(field_b(i), field_b_mesh, field_a(i)%name) + call zero(field_b(i)) + call insert(state_b, field_b(i), field_b(i)%name) + call deallocate(field_b(i)) + field_b(i) = extract_scalar_field(state_b, i) + end do + index = scalar_field_count(state_a) + do i = 1, vector_field_count(state_a) + vfield_a => extract_vector_field(state_a, i) + if(.not. vfield_a%mesh == field_a_mesh) then + if(vfield_a%mesh%shape%degree == 0) then + FLExit("vertical_integration does not support degree zero donor fields") + else + ewrite(-1, *) "Donor field mesh: " // trim(vfield_a%mesh%name) + ewrite(-1, *) "With degree: ", vfield_a%mesh%shape%degree + FLAbort("Unexpected donor field mesh") + end if end if - end if - if(vfield_a%name == "Coordinate") cycle - call allocate(vfield_b, dim, field_b_mesh, vfield_a%name) - call zero(vfield_b) - call insert(state_b, vfield_b, vfield_b%name) - call deallocate(vfield_b) - vfield_b = extract_vector_field(state_b, vfield_a%name) - do j = 1, dim - field_a(index + j) = extract_scalar_field(vfield_a, j) - field_b(index + j) = extract_scalar_field(vfield_b, j) - end do - index = index + dim - end do - ! Currently no way to handle dim dimensional tensors on a (dim - 1) - ! dimensional mesh - assert(index == size(field_a)) - - ! Step 2: Set up the options - - mesh_path = "/geometry/mesh::ExtrudedCoordinateMesh" - base_path = trim(mesh_path) // "/from_mesh/extrude/regions[0]" - call set_option("/geometry/quadrature/degree", quad_degree, stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call set_option(trim(base_path) // "/bottom_depth/constant", top - bottom, stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call set_option(trim(base_path) // "/sizing_function/constant", sizing, stat) - assert(stat == SPUD_NEW_KEY_WARNING) - call set_solver_options(solver_path, ksptype = "cg", pctype = "sor", rtol = 1.0e-10, max_its = 3000) - if(current_debug_level >= 2) then - ewrite(2, *) "Options tree:" - call print_options() - end if - - ! Step 3: Extrude the target mesh, supermesh and assemble - - ! Extrude the surface mesh - call extrude(positions_b_surf, mesh_path, positions_b_ext) - ! and apply the offset - positions_b_ext%val(dim,:) = positions_b_ext%val(dim,:) + top + if(vfield_a%name == "Coordinate") cycle + call allocate(vfield_b, dim, field_b_mesh, vfield_a%name) + call zero(vfield_b) + call insert(state_b, vfield_b, vfield_b%name) + call deallocate(vfield_b) + vfield_b = extract_vector_field(state_b, vfield_a%name) + do j = 1, dim + field_a(index + j) = extract_scalar_field(vfield_a, j) + field_b(index + j) = extract_scalar_field(vfield_b, j) + end do + index = index + dim + end do + ! Currently no way to handle dim dimensional tensors on a (dim - 1) + ! dimensional mesh + assert(index == size(field_a)) + + ! Step 2: Set up the options + + mesh_path = "/geometry/mesh::ExtrudedCoordinateMesh" + base_path = trim(mesh_path) // "/from_mesh/extrude/regions[0]" + call set_option("/geometry/quadrature/degree", quad_degree, stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call set_option(trim(base_path) // "/bottom_depth/constant", top - bottom, stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call set_option(trim(base_path) // "/sizing_function/constant", sizing, stat) + assert(stat == SPUD_NEW_KEY_WARNING) + call set_solver_options(solver_path, ksptype = "cg", pctype = "sor", rtol = 1.0e-10, max_its = 3000) + if(current_debug_level >= 2) then + ewrite(2, *) "Options tree:" + call print_options() + end if + + ! Step 3: Extrude the target mesh, supermesh and assemble + + ! Extrude the surface mesh + call extrude(positions_b_surf, mesh_path, positions_b_ext) + ! and apply the offset + positions_b_ext%val(dim,:) = positions_b_ext%val(dim,:) + top #ifdef DUMP_EXTRUSION - call write_mesh_files("extruded_vertical_integration_mesh", format="gmsh", positions=positions_b_ext) + call write_mesh_files("extruded_vertical_integration_mesh", format="gmsh", positions=positions_b_ext) #endif - sparsity = make_sparsity(field_b_mesh, field_b_mesh, name = "Sparsity") - call allocate(matrix, sparsity, name = "Matrix") - call deallocate(sparsity) - call zero(matrix) - allocate(rhs(size(field_b))) - do i = 1, size(field_b) - call allocate(rhs(i), field_b_mesh, "RHS") - call zero(rhs(i)) - end do - - call rtree_intersection_finder_set_input(positions_a) - call intersector_set_dimension(dim) - call intersector_set_exactness(.false.) - - ! Assemble the mass matrix - do ele_b_surf = 1, ele_count(positions_b_surf) - call assemble_mass_ele(ele_b_surf, positions_b_surf, field_b_mesh, matrix) - end do - - ! Assemble the RHS - allocate(field_c(size(rhs))) - do ele_b = 1, ele_count(positions_b_ext) - ewrite(2, "(a,i0,a,i0)") "Processing element ", ele_b, " of ", ele_count(positions_b_ext) - - assert(associated(positions_b_ext%mesh%element_columns)) - ele_b_surf = positions_b_ext%mesh%element_columns(ele_b) - - ! Find intersections with the mesh we are vertically integrating - call rtree_intersection_finder_find(positions_b_ext, ele_b) - call rtree_intersection_finder_query_output(nele_as) - - if(nele_as > 0 .and. dim == 3 .and. (intersector_exactness .eqv. .false.)) then - tet_b%v = ele_val(positions_b_ext, ele_b) - planes_b = get_planes(tet_b) - end if - - do i = 1, nele_as - call rtree_intersection_finder_get_output(ele_a, i) - - ! Supermesh each intersection - if(dim == 3 .and. (intersector_exactness .eqv. .false.)) then - tet_A%v = ele_val(positions_a, ele_a) - call intersect_tets(tet_a, planes_b, ele_shape(positions_a, ele_a), stat = stat, output = positions_c) - if(stat == 1) then - ! No intersection to integrate - cycle - end if - else - positions_c = intersect_elements(positions_b_ext, ele_b, ele_val(positions_a, ele_a), ele_shape(positions_a, ele_a), empty_intersection=empty_intersection) - if(empty_intersection) then - ! No intersection to integrate - cycle - end if - if(volume(positions_c) < epsilon(0.0)) then - ! Negligable intersection to integrate - call deallocate(positions_c) - cycle - end if + sparsity = make_sparsity(field_b_mesh, field_b_mesh, name = "Sparsity") + call allocate(matrix, sparsity, name = "Matrix") + call deallocate(sparsity) + call zero(matrix) + allocate(rhs(size(field_b))) + do i = 1, size(field_b) + call allocate(rhs(i), field_b_mesh, "RHS") + call zero(rhs(i)) + end do + + call rtree_intersection_finder_set_input(positions_a) + call intersector_set_dimension(dim) + call intersector_set_exactness(.false.) + + ! Assemble the mass matrix + do ele_b_surf = 1, ele_count(positions_b_surf) + call assemble_mass_ele(ele_b_surf, positions_b_surf, field_b_mesh, matrix) + end do + + ! Assemble the RHS + allocate(field_c(size(rhs))) + do ele_b = 1, ele_count(positions_b_ext) + ewrite(2, "(a,i0,a,i0)") "Processing element ", ele_b, " of ", ele_count(positions_b_ext) + + assert(associated(positions_b_ext%mesh%element_columns)) + ele_b_surf = positions_b_ext%mesh%element_columns(ele_b) + + ! Find intersections with the mesh we are vertically integrating + call rtree_intersection_finder_find(positions_b_ext, ele_b) + call rtree_intersection_finder_query_output(nele_as) + + if(nele_as > 0 .and. dim == 3 .and. (intersector_exactness .eqv. .false.)) then + tet_b%v = ele_val(positions_b_ext, ele_b) + planes_b = get_planes(tet_b) end if - ! Assume here that the donor Coordinate and fields are on the same mesh - assert(positions_a%mesh == field_a_mesh) - field_c_mesh => positions_c%mesh - allocate(lshape(ele_loc(field_c_mesh, 1), node_count(field_c_mesh))) - do j = 1, node_count(field_c_mesh) - lshape(:, j) = eval_shape(ele_shape(field_a_mesh, 1), local_coords(positions_a, ele_a, node_val(positions_c, j))) - end do - - do j = 1, size(rhs) - call allocate(field_c(j), field_c_mesh, "IntersectionIntegratedField") - ! Project the donor field onto the supermesh - do k = 1, node_count(field_c(j)) - call set(field_c(j), k, & - & dot_product( & - & ele_val(field_a(j), ele_a), & - & lshape(:, k) & - & ) & - & ) - end do - end do - deallocate(lshape) - - do j = 1, ele_count(positions_c) - ! Project the extruded target test function onto the supermesh - field_c_shape => ele_shape(field_c(1), j) - field_b_shape_ext = extruded_shape_function(ele_b_surf, j, positions_b_surf, positions_c, field_b_mesh%shape, field_c_shape, & - & form_dn = .false.) - - do k = 1, size(rhs) - ! Assemble the RHS for this intersection for this element - call assemble_rhs_ele(j, ele_b_surf, field_b_shape_ext, positions_c, field_c(k), rhs(k)) - end do - - call deallocate(field_b_shape_ext) + do i = 1, nele_as + call rtree_intersection_finder_get_output(ele_a, i) + + ! Supermesh each intersection + if(dim == 3 .and. (intersector_exactness .eqv. .false.)) then + tet_A%v = ele_val(positions_a, ele_a) + call intersect_tets(tet_a, planes_b, ele_shape(positions_a, ele_a), stat = stat, output = positions_c) + if(stat == 1) then + ! No intersection to integrate + cycle + end if + else + positions_c = intersect_elements(positions_b_ext, ele_b, ele_val(positions_a, ele_a), ele_shape(positions_a, ele_a), empty_intersection=empty_intersection) + if(empty_intersection) then + ! No intersection to integrate + cycle + end if + if(volume(positions_c) < epsilon(0.0)) then + ! Negligable intersection to integrate + call deallocate(positions_c) + cycle + end if + end if + + ! Assume here that the donor Coordinate and fields are on the same mesh + assert(positions_a%mesh == field_a_mesh) + field_c_mesh => positions_c%mesh + allocate(lshape(ele_loc(field_c_mesh, 1), node_count(field_c_mesh))) + do j = 1, node_count(field_c_mesh) + lshape(:, j) = eval_shape(ele_shape(field_a_mesh, 1), local_coords(positions_a, ele_a, node_val(positions_c, j))) + end do + + do j = 1, size(rhs) + call allocate(field_c(j), field_c_mesh, "IntersectionIntegratedField") + ! Project the donor field onto the supermesh + do k = 1, node_count(field_c(j)) + call set(field_c(j), k, & + & dot_product( & + & ele_val(field_a(j), ele_a), & + & lshape(:, k) & + & ) & + & ) + end do + end do + deallocate(lshape) + + do j = 1, ele_count(positions_c) + ! Project the extruded target test function onto the supermesh + field_c_shape => ele_shape(field_c(1), j) + field_b_shape_ext = extruded_shape_function(ele_b_surf, j, positions_b_surf, positions_c, field_b_mesh%shape, field_c_shape, & + & form_dn = .false.) + + do k = 1, size(rhs) + ! Assemble the RHS for this intersection for this element + call assemble_rhs_ele(j, ele_b_surf, field_b_shape_ext, positions_c, field_c(k), rhs(k)) + end do + + call deallocate(field_b_shape_ext) + end do + + do j = 1, size(rhs) + call deallocate(field_c(j)) + end do + call deallocate(positions_c) end do + end do + deallocate(field_c) - do j = 1, size(rhs) - call deallocate(field_c(j)) - end do - call deallocate(positions_c) - end do - end do - deallocate(field_c) + call deallocate(positions_b_ext) + call rtree_intersection_finder_reset() + if(dim == 3) call finalise_tet_intersector() - call deallocate(positions_b_ext) - call rtree_intersection_finder_reset() - if(dim == 3) call finalise_tet_intersector() + ! Step 4: Solve - ! Step 4: Solve + call petsc_solve(field_b, matrix, rhs, option_path = solver_path) + call deallocate(matrix) + do i = 1, size(field_a) + call deallocate(rhs(i)) + end do - call petsc_solve(field_b, matrix, rhs, option_path = solver_path) - call deallocate(matrix) - do i = 1, size(field_a) - call deallocate(rhs(i)) - end do + ! Step 5: Write output - ! Step 5: Write output + call vtk_write_state(output_basename, model = field_b_mesh%name, state = (/state_b/)) - call vtk_write_state(output_basename, model = field_b_mesh%name, state = (/state_b/)) + ! Step 6: Cleanup - ! Step 6: Cleanup + call deallocate(positions_b_surf) + call deallocate(field_b_mesh) + call deallocate(state_a) + call deallocate(state_b) + deallocate(field_a) + deallocate(field_b) - call deallocate(positions_b_surf) - call deallocate(field_b_mesh) - call deallocate(state_a) - call deallocate(state_b) - deallocate(field_a) - deallocate(field_b) + call print_references(0) - call print_references(0) - - ewrite(1, *) "Exiting vertical_integration" + ewrite(1, *) "Exiting vertical_integration" contains - function volume(positions) - type(vector_field), intent(in) :: positions + function volume(positions) + type(vector_field), intent(in) :: positions - real :: volume + real :: volume - integer :: i + integer :: i - volume = 0.0 - do i = 1, ele_count(positions) - volume = volume + element_volume(positions, i) - end do + volume = 0.0 + do i = 1, ele_count(positions) + volume = volume + element_volume(positions, i) + end do - end function volume + end function volume - subroutine assemble_mass_ele(ele, positions, mesh, matrix) - integer, intent(in) :: ele - type(vector_field), intent(in) :: positions - type(mesh_type), intent(in) :: mesh - type(csr_matrix), intent(inout) :: matrix + subroutine assemble_mass_ele(ele, positions, mesh, matrix) + integer, intent(in) :: ele + type(vector_field), intent(in) :: positions + type(mesh_type), intent(in) :: mesh + type(csr_matrix), intent(inout) :: matrix - integer, dimension(:), pointer :: element_nodes - real, dimension(ele_ngi(positions, ele)) :: detwei - type(element_type), pointer :: shape + integer, dimension(:), pointer :: element_nodes + real, dimension(ele_ngi(positions, ele)) :: detwei + type(element_type), pointer :: shape - shape => ele_shape(mesh, ele) + shape => ele_shape(mesh, ele) - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - element_nodes => ele_nodes(mesh, ele) - call addto(matrix, element_nodes, element_nodes, shape_shape(shape, shape, detwei)) + element_nodes => ele_nodes(mesh, ele) + call addto(matrix, element_nodes, element_nodes, shape_shape(shape, shape, detwei)) - end subroutine assemble_mass_ele + end subroutine assemble_mass_ele - subroutine assemble_rhs_ele(ele, ele_out, test_function, positions, field, rhs) - integer, intent(in) :: ele - integer, intent(in) :: ele_out - type(element_type), intent(in) :: test_function - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: field - type(scalar_field), intent(inout) :: rhs + subroutine assemble_rhs_ele(ele, ele_out, test_function, positions, field, rhs) + integer, intent(in) :: ele + integer, intent(in) :: ele_out + type(element_type), intent(in) :: test_function + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: field + type(scalar_field), intent(inout) :: rhs - real, dimension(ele_ngi(positions, ele)) :: detwei + real, dimension(ele_ngi(positions, ele)) :: detwei - call transform_to_physical(positions, ele, detwei = detwei) + call transform_to_physical(positions, ele, detwei = detwei) - call addto(rhs, ele_nodes(rhs, ele_out), shape_rhs(test_function, detwei * ele_val_at_quad(field, ele))) + call addto(rhs, ele_nodes(rhs, ele_out), shape_rhs(test_function, detwei * ele_val_at_quad(field, ele))) - end subroutine assemble_rhs_ele + end subroutine assemble_rhs_ele end subroutine vertical_integration diff --git a/tools/Vtu_Bins.F90 b/tools/Vtu_Bins.F90 index 805243601d..958de79b53 100644 --- a/tools/Vtu_Bins.F90 +++ b/tools/Vtu_Bins.F90 @@ -28,84 +28,84 @@ #include "fdebug.h" subroutine vtu_bins(input_filename_, input_filename_len, input_fieldname_, & - & input_fieldname_len, bounds, nbounds) bind(c) - - use transform_elements, only: element_volume - use fields - use fldebug - use futils - use mixing_statistics - use quicksort - use reference_counting - use state_module - use vtk_interfaces - use iso_c_binding - - implicit none - - integer(kind=c_size_t), value :: input_filename_len - integer(kind=c_size_t), value :: input_fieldname_len - integer(kind=c_size_t), value :: nbounds - character(kind=c_char, len=1) :: input_filename_(*) - character(kind=c_char, len=1) :: input_fieldname_(*) - real(kind=c_double), dimension(nbounds) :: bounds - - character(len = input_filename_len) :: input_filename - character(len = input_fieldname_len) :: input_fieldname - character(len = real_format_len()) :: rformat - character(len = real_format_len(padding = 1)) :: rformatp - integer :: i - integer, dimension(nbounds) :: permutation - logical :: allocated - real :: volume - real, dimension(nbounds) :: lbounds - real, dimension(nbounds + 1) :: integrals - type(scalar_field), pointer :: field - type(state_type) :: state - type(vector_field), pointer :: positions - - ewrite(1, *) "In vtu_bins" - - do i=1, input_filename_len - input_filename(i:i)=input_filename_(i) - end do - do i=1, input_fieldname_len - input_fieldname(i:i)=input_fieldname_(i) - end do - - - ewrite(2, *) "Input file: ", trim(input_filename) - ewrite(2, *) "Input field: ", trim(input_fieldname) - ewrite(2, *) "Bounds: ", bounds - - call qsort(bounds, permutation) - lbounds = bounds(permutation) - - call vtk_read_state(input_filename, state = state) - positions => extract_vector_field(state, "Coordinate") - field => extract_scalar_field(state, input_fieldname, allocated = allocated) - - volume = 0.0 - do i = 1, ele_count(positions) - volume = volume + element_volume(positions, i) - end do - - integrals = heaviside_integral(field, lbounds, positions) - integrals(nbounds + 1) = heaviside_integral(field, huge(0.0), positions) - - rformat = real_format() - rformatp = real_format(padding = 1) - print "(a," // rformatp // ",a," // rformat // ")", " -inf - ", lbounds(1), " : ", (volume - integrals(1)) / volume - do i = 1, nbounds - 1 - print "(" // rformatp // ",a," // rformatp // ",a," // rformat // ")", lbounds(i), " - ", lbounds(i + 1), " : ", (-integrals(i + 1) + integrals(i)) / volume - end do - print "(" // rformatp // "a," // rformat // ")", lbounds(nbounds), " - inf : ", (-integrals(nbounds + 1) + integrals(nbounds)) / volume - - if(allocated) deallocate(field) - call deallocate(state) - - call print_references(0) - - ewrite(1, *) "Exiting vtu_bins" +& input_fieldname_len, bounds, nbounds) bind(c) + + use transform_elements, only: element_volume + use fields + use fldebug + use futils + use mixing_statistics + use quicksort + use reference_counting + use state_module + use vtk_interfaces + use iso_c_binding + + implicit none + + integer(kind=c_size_t), value :: input_filename_len + integer(kind=c_size_t), value :: input_fieldname_len + integer(kind=c_size_t), value :: nbounds + character(kind=c_char, len=1) :: input_filename_(*) + character(kind=c_char, len=1) :: input_fieldname_(*) + real(kind=c_double), dimension(nbounds) :: bounds + + character(len = input_filename_len) :: input_filename + character(len = input_fieldname_len) :: input_fieldname + character(len = real_format_len()) :: rformat + character(len = real_format_len(padding = 1)) :: rformatp + integer :: i + integer, dimension(nbounds) :: permutation + logical :: allocated + real :: volume + real, dimension(nbounds) :: lbounds + real, dimension(nbounds + 1) :: integrals + type(scalar_field), pointer :: field + type(state_type) :: state + type(vector_field), pointer :: positions + + ewrite(1, *) "In vtu_bins" + + do i=1, input_filename_len + input_filename(i:i)=input_filename_(i) + end do + do i=1, input_fieldname_len + input_fieldname(i:i)=input_fieldname_(i) + end do + + + ewrite(2, *) "Input file: ", trim(input_filename) + ewrite(2, *) "Input field: ", trim(input_fieldname) + ewrite(2, *) "Bounds: ", bounds + + call qsort(bounds, permutation) + lbounds = bounds(permutation) + + call vtk_read_state(input_filename, state = state) + positions => extract_vector_field(state, "Coordinate") + field => extract_scalar_field(state, input_fieldname, allocated = allocated) + + volume = 0.0 + do i = 1, ele_count(positions) + volume = volume + element_volume(positions, i) + end do + + integrals = heaviside_integral(field, lbounds, positions) + integrals(nbounds + 1) = heaviside_integral(field, huge(0.0), positions) + + rformat = real_format() + rformatp = real_format(padding = 1) + print "(a," // rformatp // ",a," // rformat // ")", " -inf - ", lbounds(1), " : ", (volume - integrals(1)) / volume + do i = 1, nbounds - 1 + print "(" // rformatp // ",a," // rformatp // ",a," // rformat // ")", lbounds(i), " - ", lbounds(i + 1), " : ", (-integrals(i + 1) + integrals(i)) / volume + end do + print "(" // rformatp // "a," // rformat // ")", lbounds(nbounds), " - inf : ", (-integrals(nbounds + 1) + integrals(nbounds)) / volume + + if(allocated) deallocate(field) + call deallocate(state) + + call print_references(0) + + ewrite(1, *) "Exiting vtu_bins" end subroutine vtu_bins diff --git a/tools/fldiagnostics.F90 b/tools/fldiagnostics.F90 index ccdf9ac01b..7bfb5531cd 100644 --- a/tools/fldiagnostics.F90 +++ b/tools/fldiagnostics.F90 @@ -5,95 +5,95 @@ #include "fdebug.h" subroutine fldiag_add_diag(input_name_, input_name_len, & - & output_name_, output_name_len, & - & outfield_name_, outfield_name_len, & - & meshfield_name_, meshfield_name_len, & - & state_name_, state_name_len, outfield_rank) bind(c) - !!< Read data from the vtu with name input_name, add a specified diagnostic - !!< field with name outfield_name, and write the new data to a vtu with name - !!< output_name. See fldiagnostics help for more information. - - use diagnostic_fields - use fields_data_types - use fields - use fldebug - use spud - use state_module - use vtk_interfaces - use iso_c_binding - - implicit none - - integer(kind=c_size_t), value :: input_name_len, output_name_len, outfield_name_len, & - & meshfield_name_len, state_name_len - integer(kind=c_int32_t), value :: outfield_rank - - character(kind=c_char, len=1) :: input_name_(*), output_name_(*), outfield_name_(*), & - & meshfield_name_(*), state_name_(*) - - character(len = input_name_len) :: input_name - character(len = output_name_len) :: output_name - character(len = outfield_name_len) :: outfield_name - character(len = meshfield_name_len):: meshfield_name - character(len = state_name_len) :: state_name - - integer :: i, rank, stat - type(mesh_type), pointer :: mesh - type(state_type), dimension(1) :: state - - do i=1, input_name_len - input_name(i:i)=input_name_(i) - end do - do i=1, output_name_len - output_name(i:i)=output_name_(i) - end do - do i=1, outfield_name_len - outfield_name(i:i)=outfield_name_(i) - end do - do i=1, meshfield_name_len - meshfield_name(i:i)=meshfield_name_(i) - end do - do i=1, state_name_len - state_name(i:i)=state_name_(i) - end do - - if(.not. have_option("/simulation_name")) then - ewrite(0, *) "Warning: No options file supplied to fldiag_add_diag" - end if - - call vtk_read_state(trim(input_name), state(1)) - if(state_name_len > 0) then - state(1)%name = state_name - else - call get_option("/material_phase[0]/name", state(1)%name, stat) - end if - - mesh => extract_field_mesh(state(1), meshfield_name) - - rank = field_rank(state(1), outfield_name) - - if(outfield_rank .ne. 0) then - if(rank > 0 .and. rank /= outfield_rank) then - FLExit("Requested diagnostic field rank and rank of existing field in input file do not match") - end if - call insert_diagnostic_field(state(1), outfield_name, mesh, outfield_rank) - else - do i = 0, 3 - call insert_diagnostic_field(state(1), outfield_name, mesh, i, stat) - if(stat == 0) then - if(rank >= 0 .and. rank /= i) then - FLExit("Rank of calculated diagnostic field and existing field in input file do not match") - end if - exit - else if(i == 3) then - FLExit("Failed to calculate diagnostic variable - try specifying the rank") +& output_name_, output_name_len, & +& outfield_name_, outfield_name_len, & +& meshfield_name_, meshfield_name_len, & +& state_name_, state_name_len, outfield_rank) bind(c) + !!< Read data from the vtu with name input_name, add a specified diagnostic + !!< field with name outfield_name, and write the new data to a vtu with name + !!< output_name. See fldiagnostics help for more information. + + use diagnostic_fields + use fields_data_types + use fields + use fldebug + use spud + use state_module + use vtk_interfaces + use iso_c_binding + + implicit none + + integer(kind=c_size_t), value :: input_name_len, output_name_len, outfield_name_len, & + & meshfield_name_len, state_name_len + integer(kind=c_int32_t), value :: outfield_rank + + character(kind=c_char, len=1) :: input_name_(*), output_name_(*), outfield_name_(*), & + & meshfield_name_(*), state_name_(*) + + character(len = input_name_len) :: input_name + character(len = output_name_len) :: output_name + character(len = outfield_name_len) :: outfield_name + character(len = meshfield_name_len):: meshfield_name + character(len = state_name_len) :: state_name + + integer :: i, rank, stat + type(mesh_type), pointer :: mesh + type(state_type), dimension(1) :: state + + do i=1, input_name_len + input_name(i:i)=input_name_(i) + end do + do i=1, output_name_len + output_name(i:i)=output_name_(i) + end do + do i=1, outfield_name_len + outfield_name(i:i)=outfield_name_(i) + end do + do i=1, meshfield_name_len + meshfield_name(i:i)=meshfield_name_(i) + end do + do i=1, state_name_len + state_name(i:i)=state_name_(i) + end do + + if(.not. have_option("/simulation_name")) then + ewrite(0, *) "Warning: No options file supplied to fldiag_add_diag" + end if + + call vtk_read_state(trim(input_name), state(1)) + if(state_name_len > 0) then + state(1)%name = state_name + else + call get_option("/material_phase[0]/name", state(1)%name, stat) + end if + + mesh => extract_field_mesh(state(1), meshfield_name) + + rank = field_rank(state(1), outfield_name) + + if(outfield_rank .ne. 0) then + if(rank > 0 .and. rank /= outfield_rank) then + FLExit("Requested diagnostic field rank and rank of existing field in input file do not match") end if - end do - end if - - call vtk_write_state(trim(output_name), state = state) - - call deallocate(state(1)) + call insert_diagnostic_field(state(1), outfield_name, mesh, outfield_rank) + else + do i = 0, 3 + call insert_diagnostic_field(state(1), outfield_name, mesh, i, stat) + if(stat == 0) then + if(rank >= 0 .and. rank /= i) then + FLExit("Rank of calculated diagnostic field and existing field in input file do not match") + end if + exit + else if(i == 3) then + FLExit("Failed to calculate diagnostic variable - try specifying the rank") + end if + end do + end if + + call vtk_write_state(trim(output_name), state = state) + + call deallocate(state(1)) end subroutine fldiag_add_diag diff --git a/tools/gmsh2vtu.F90 b/tools/gmsh2vtu.F90 index 49f057e43b..c774ce2126 100644 --- a/tools/gmsh2vtu.F90 +++ b/tools/gmsh2vtu.F90 @@ -26,39 +26,39 @@ ! USA subroutine gmsh2vtu(filename_, filename_len) bind(c) - !!< Read in a gmsh mesh and output a vtu mesh. + !!< Read in a gmsh mesh and output a vtu mesh. - use fields - use read_gmsh - use vtk_interfaces - use iso_c_binding - implicit none + use fields + use read_gmsh + use vtk_interfaces + use iso_c_binding + implicit none - integer(kind=c_size_t), value :: filename_len - character(kind=c_char, len=1) :: filename_(*) + integer(kind=c_size_t), value :: filename_len + character(kind=c_char, len=1) :: filename_(*) - character(len=filename_len) :: filename + character(len=filename_len) :: filename - integer :: i - type(vector_field), target :: positions - type(scalar_field) :: regions + integer :: i + type(vector_field), target :: positions + type(scalar_field) :: regions - do i=1, filename_len - filename(i:i)=filename_(i) - end do + do i=1, filename_len + filename(i:i)=filename_(i) + end do - positions=read_gmsh_file(filename, quad_degree=3) + positions=read_gmsh_file(filename, quad_degree=3) - if (associated(positions%mesh%region_ids)) then - regions=piecewise_constant_field(positions%mesh, name="Regions") - regions%val=float(positions%mesh%region_ids) - call vtk_write_fields(filename, position=positions, & - model=positions%mesh, vfields=(/positions/), sfields=(/ regions /)) - call deallocate(regions) - else - call vtk_write_fields(filename, position=positions, model=positions%mesh) - end if + if (associated(positions%mesh%region_ids)) then + regions=piecewise_constant_field(positions%mesh, name="Regions") + regions%val=float(positions%mesh%region_ids) + call vtk_write_fields(filename, position=positions, & + model=positions%mesh, vfields=(/positions/), sfields=(/ regions /)) + call deallocate(regions) + else + call vtk_write_fields(filename, position=positions, model=positions%mesh) + end if - call deallocate(positions) + call deallocate(positions) end subroutine gmsh2vtu diff --git a/tools/periodise.F90 b/tools/periodise.F90 index 4ada3a723e..8b48e56fdd 100644 --- a/tools/periodise.F90 +++ b/tools/periodise.F90 @@ -2,198 +2,198 @@ program periodise - !! Take in an flml with an external mesh and one periodic mesh derived from it. - !! Make it so that the periodic mesh is external, and the previously external mesh - !! is derived from it instead. - - use fldebug - use futils, only: int2str - use global_parameters, only: FIELD_NAME_LEN - use populate_state_module - use state_module - use fields - use reference_counting - use spud - use field_options - use mesh_files - use integer_set_module - implicit none - - character(len=4096) :: filename, external_filename, new_external_filename, new_filename - integer :: status - type(state_type), dimension(:), pointer :: states - integer :: ierr - character(len=FIELD_NAME_LEN) :: external_name, periodic_name, mesh_format - type(mesh_type), pointer :: periodic_mesh, external_mesh - type(vector_field) :: periodic_positions, external_positions - integer :: stat, i, nstates - logical :: skip_initial_extrusion - - call set_debug_level(0) - call mpi_init(ierr) - call python_init - - call get_command_argument(1, value=filename, status=status) - if (status > 0) then - call usage - stop - else if (status < 0) then - write(0,*) "Warning: truncating filename" - end if - - call load_options(trim(filename)) - - ! for extruded meshes, if no checkpointed extruded mesh is present, don't bother - ! extruding (this may be time consuming or not fit on the input_nprocs) - skip_initial_extrusion = option_count('/geometry/mesh/from_mesh/extrude')>0 .and. & - option_count('/geometry/mesh/from_mesh/extrude/checkpoint_from_file')==0 - - ! ! Below is a (partial) copy of the first bit of populate_state - - ! Find out how many states there are - nstates=option_count("/material_phase") - allocate(states(1:nstates)) - do i = 1, nstates - call nullify(states(i)) - end do - - call insert_external_mesh(states, save_vtk_cache = .true.) - - call insert_derived_meshes(states, skip_extrusion=skip_initial_extrusion) - - ! ! End populate_state calls - - call check_valid_input(states, external_filename, external_name, periodic_name) - - external_mesh => extract_mesh(states(1), trim(external_name)) - periodic_mesh => extract_mesh(states(1), trim(periodic_name)) - if (trim(external_name) /= "CoordinateMesh") then - external_positions = extract_vector_field(states(1), trim(external_name) // 'Coordinate') - else - external_positions = extract_vector_field(states(1), 'Coordinate') - end if - call incref(external_positions) - call allocate(periodic_positions, external_positions%dim, periodic_mesh, trim(periodic_name) // 'Coordinate') - call remap_field(external_positions, periodic_positions, stat=stat) - if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then - FLAbort("Just remapped from a discontinuous to a continuous field!") - else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then - FLAbort("Just remapped from a higher order to a lower order continuous field!") - end if - ! we've allowed it to remap from periodic to unperiodic - - call postprocess_periodic_mesh(external_mesh, external_positions, periodic_mesh, periodic_positions) - - ! Dump out the periodic mesh to disk: - new_external_filename = trim(external_filename) // '_periodic' - call get_option(trim(external_mesh%option_path)//"/from_file/format/name", mesh_format) - call write_mesh_files(new_external_filename, mesh_format, periodic_positions) - - ! OK! Now we need to do some setting of options. - call manipulate_options(external_mesh, trim(external_mesh%option_path), periodic_mesh, trim(periodic_mesh%option_path), new_external_filename) - - new_filename = filename(1:len_trim(filename)-5) // '_periodised.flml' - call write_options(new_filename) - - call deallocate(states) - call deallocate(external_positions) - call deallocate(periodic_positions) - call print_references(1) - call python_end - call mpi_finalize(ierr) - - contains - - subroutine usage - write(0,*) "Usage: periodise input.flml" - write(0,*) " where input.flml has exactly one external mesh and one periodic mesh" - write(0,*) " derived immediately from it. The tool produces input_periodised.flml" - write(0,*) " which has the periodic mesh as the external one, and the previously" - write(0,*) " external mesh derived from it." - end subroutine usage - - subroutine check_valid_input(states, external_filename, external_name, periodic_name) - type(state_type), dimension(:), intent(in) :: states - character(len=FIELD_NAME_LEN), intent(out) :: external_name, periodic_name - integer :: j - integer :: seen_external_meshes, seen_periodic_meshes - character(len=4096), intent(out) :: external_filename - type(mesh_type), pointer :: mesh - - seen_external_meshes = 0 - seen_periodic_meshes = 0 - - do j=1,mesh_count(states(1)) - mesh => extract_mesh(states(1), j) - - if (have_option(trim(mesh%option_path) // '/from_file')) then - seen_external_meshes = seen_external_meshes + 1 - external_name = mesh%name - call get_option(trim(mesh%option_path) // '/from_file/file_name', external_filename) - end if - - if (have_option(trim(mesh%option_path) // '/from_mesh/periodic_boundary_conditions') .and. & - .not. have_option(trim(mesh%option_path) // '/from_mesh/periodic_boundary_conditions/remove_periodicity')) then - seen_periodic_meshes = seen_periodic_meshes + 1 - periodic_name = mesh%name - end if - end do - - if (seen_external_meshes /= 1 .or. seen_periodic_meshes /= 1) then + !! Take in an flml with an external mesh and one periodic mesh derived from it. + !! Make it so that the periodic mesh is external, and the previously external mesh + !! is derived from it instead. + + use fldebug + use futils, only: int2str + use global_parameters, only: FIELD_NAME_LEN + use populate_state_module + use state_module + use fields + use reference_counting + use spud + use field_options + use mesh_files + use integer_set_module + implicit none + + character(len=4096) :: filename, external_filename, new_external_filename, new_filename + integer :: status + type(state_type), dimension(:), pointer :: states + integer :: ierr + character(len=FIELD_NAME_LEN) :: external_name, periodic_name, mesh_format + type(mesh_type), pointer :: periodic_mesh, external_mesh + type(vector_field) :: periodic_positions, external_positions + integer :: stat, i, nstates + logical :: skip_initial_extrusion + + call set_debug_level(0) + call mpi_init(ierr) + call python_init + + call get_command_argument(1, value=filename, status=status) + if (status > 0) then call usage stop - end if - end subroutine check_valid_input - - subroutine manipulate_options(external_mesh, external_path, periodic_mesh, periodic_path, new_external_filename) - type(mesh_type), intent(in) :: external_mesh, periodic_mesh - character(len=*), intent(in) :: new_external_filename - character(len=*), intent(in) :: external_path, periodic_path - character(len=8192) :: str, mesh_format - integer :: stat, periodic_bc - integer, dimension(2) :: shape_option - integer, dimension(:), allocatable :: boundary_ids - - ! The periodic sub-branch of the options tree has useful information that - ! we don't want to lose just yet. So set the external mesh to be periodic - ! first, and then overwrite - - call get_option(external_path // '/from_file/format/name',mesh_format) - - call delete_option(external_path // '/from_file', stat=stat) - call set_option_attribute(external_path // '/from_mesh/mesh/name', trim(periodic_mesh%name), stat=stat) - do periodic_bc=0,option_count(periodic_path // '/from_mesh/periodic_boundary_conditions')-1 - - call get_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/name', str) - call set_option_attribute(external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/name', trim(str), stat=stat) - - call add_option(external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/remove_periodicity', stat=stat) - - call move_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/coordinate_map', & - & external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/coordinate_map', stat=stat) - if (have_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/inverse_coordinate_map')) then - call move_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/inverse_coordinate_map', & - & external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/inverse_coordinate_map') + else if (status < 0) then + write(0,*) "Warning: truncating filename" + end if + + call load_options(trim(filename)) + + ! for extruded meshes, if no checkpointed extruded mesh is present, don't bother + ! extruding (this may be time consuming or not fit on the input_nprocs) + skip_initial_extrusion = option_count('/geometry/mesh/from_mesh/extrude')>0 .and. & + option_count('/geometry/mesh/from_mesh/extrude/checkpoint_from_file')==0 + + ! ! Below is a (partial) copy of the first bit of populate_state + + ! Find out how many states there are + nstates=option_count("/material_phase") + allocate(states(1:nstates)) + do i = 1, nstates + call nullify(states(i)) + end do + + call insert_external_mesh(states, save_vtk_cache = .true.) + + call insert_derived_meshes(states, skip_extrusion=skip_initial_extrusion) + + ! ! End populate_state calls + + call check_valid_input(states, external_filename, external_name, periodic_name) + + external_mesh => extract_mesh(states(1), trim(external_name)) + periodic_mesh => extract_mesh(states(1), trim(periodic_name)) + if (trim(external_name) /= "CoordinateMesh") then + external_positions = extract_vector_field(states(1), trim(external_name) // 'Coordinate') + else + external_positions = extract_vector_field(states(1), 'Coordinate') + end if + call incref(external_positions) + call allocate(periodic_positions, external_positions%dim, periodic_mesh, trim(periodic_name) // 'Coordinate') + call remap_field(external_positions, periodic_positions, stat=stat) + if(stat==REMAP_ERR_DISCONTINUOUS_CONTINUOUS) then + FLAbort("Just remapped from a discontinuous to a continuous field!") + else if(stat==REMAP_ERR_HIGHER_LOWER_CONTINUOUS) then + FLAbort("Just remapped from a higher order to a lower order continuous field!") + end if + ! we've allowed it to remap from periodic to unperiodic + + call postprocess_periodic_mesh(external_mesh, external_positions, periodic_mesh, periodic_positions) + + ! Dump out the periodic mesh to disk: + new_external_filename = trim(external_filename) // '_periodic' + call get_option(trim(external_mesh%option_path)//"/from_file/format/name", mesh_format) + call write_mesh_files(new_external_filename, mesh_format, periodic_positions) + + ! OK! Now we need to do some setting of options. + call manipulate_options(external_mesh, trim(external_mesh%option_path), periodic_mesh, trim(periodic_mesh%option_path), new_external_filename) + + new_filename = filename(1:len_trim(filename)-5) // '_periodised.flml' + call write_options(new_filename) + + call deallocate(states) + call deallocate(external_positions) + call deallocate(periodic_positions) + call print_references(1) + call python_end + call mpi_finalize(ierr) + +contains + + subroutine usage + write(0,*) "Usage: periodise input.flml" + write(0,*) " where input.flml has exactly one external mesh and one periodic mesh" + write(0,*) " derived immediately from it. The tool produces input_periodised.flml" + write(0,*) " which has the periodic mesh as the external one, and the previously" + write(0,*) " external mesh derived from it." + end subroutine usage + + subroutine check_valid_input(states, external_filename, external_name, periodic_name) + type(state_type), dimension(:), intent(in) :: states + character(len=FIELD_NAME_LEN), intent(out) :: external_name, periodic_name + integer :: j + integer :: seen_external_meshes, seen_periodic_meshes + character(len=4096), intent(out) :: external_filename + type(mesh_type), pointer :: mesh + + seen_external_meshes = 0 + seen_periodic_meshes = 0 + + do j=1,mesh_count(states(1)) + mesh => extract_mesh(states(1), j) + + if (have_option(trim(mesh%option_path) // '/from_file')) then + seen_external_meshes = seen_external_meshes + 1 + external_name = mesh%name + call get_option(trim(mesh%option_path) // '/from_file/file_name', external_filename) + end if + + if (have_option(trim(mesh%option_path) // '/from_mesh/periodic_boundary_conditions') .and. & + .not. have_option(trim(mesh%option_path) // '/from_mesh/periodic_boundary_conditions/remove_periodicity')) then + seen_periodic_meshes = seen_periodic_meshes + 1 + periodic_name = mesh%name + end if + end do + + if (seen_external_meshes /= 1 .or. seen_periodic_meshes /= 1) then + call usage + stop end if - - shape_option = option_shape(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids') - allocate(boundary_ids(shape_option(1))) - call get_option(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids', boundary_ids) - call set_option(external_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids', boundary_ids, stat=stat) - deallocate(boundary_ids) - - shape_option = option_shape(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids') - allocate(boundary_ids(shape_option(1))) - call get_option(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids', boundary_ids) - call set_option(external_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids', boundary_ids, stat=stat) - deallocate(boundary_ids) - end do - - call delete_option(periodic_path // '/from_mesh', stat=stat) - call set_option_attribute(periodic_path // '/from_file/file_name', new_external_filename, stat=stat) - call set_option_attribute(periodic_path // '/from_file/format/name', mesh_format, stat=stat) - call add_option(periodic_path // '/from_file/stat/include_in_stat', stat=stat) - call add_option(external_path // '/from_mesh/stat/include_in_stat', stat=stat) - end subroutine manipulate_options + end subroutine check_valid_input + + subroutine manipulate_options(external_mesh, external_path, periodic_mesh, periodic_path, new_external_filename) + type(mesh_type), intent(in) :: external_mesh, periodic_mesh + character(len=*), intent(in) :: new_external_filename + character(len=*), intent(in) :: external_path, periodic_path + character(len=8192) :: str, mesh_format + integer :: stat, periodic_bc + integer, dimension(2) :: shape_option + integer, dimension(:), allocatable :: boundary_ids + + ! The periodic sub-branch of the options tree has useful information that + ! we don't want to lose just yet. So set the external mesh to be periodic + ! first, and then overwrite + + call get_option(external_path // '/from_file/format/name',mesh_format) + + call delete_option(external_path // '/from_file', stat=stat) + call set_option_attribute(external_path // '/from_mesh/mesh/name', trim(periodic_mesh%name), stat=stat) + do periodic_bc=0,option_count(periodic_path // '/from_mesh/periodic_boundary_conditions')-1 + + call get_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/name', str) + call set_option_attribute(external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/name', trim(str), stat=stat) + + call add_option(external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/remove_periodicity', stat=stat) + + call move_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/coordinate_map', & + & external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/coordinate_map', stat=stat) + if (have_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/inverse_coordinate_map')) then + call move_option(periodic_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/inverse_coordinate_map', & + & external_path // '/from_mesh/periodic_boundary_conditions[' // int2str(periodic_bc) // ']/inverse_coordinate_map') + end if + + shape_option = option_shape(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids') + allocate(boundary_ids(shape_option(1))) + call get_option(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids', boundary_ids) + call set_option(external_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/aliased_boundary_ids', boundary_ids, stat=stat) + deallocate(boundary_ids) + + shape_option = option_shape(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids') + allocate(boundary_ids(shape_option(1))) + call get_option(periodic_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids', boundary_ids) + call set_option(external_path // '/from_mesh/periodic_boundary_conditions['//int2str(periodic_bc)//']/physical_boundary_ids', boundary_ids, stat=stat) + deallocate(boundary_ids) + end do + + call delete_option(periodic_path // '/from_mesh', stat=stat) + call set_option_attribute(periodic_path // '/from_file/file_name', new_external_filename, stat=stat) + call set_option_attribute(periodic_path // '/from_file/format/name', mesh_format, stat=stat) + call add_option(periodic_path // '/from_file/stat/include_in_stat', stat=stat) + call add_option(external_path // '/from_mesh/stat/include_in_stat', stat=stat) + end subroutine manipulate_options end program periodise diff --git a/tools/petsc_readnsolve.F90 b/tools/petsc_readnsolve.F90 index 44c1813129..ddd859f36b 100644 --- a/tools/petsc_readnsolve.F90 +++ b/tools/petsc_readnsolve.F90 @@ -18,412 +18,495 @@ !! solver: put PETSc options -ksp_type preonly and -pc_type lu. Although !! for ill-conditioned matrices its accuracy may be limited. subroutine petsc_readnsolve -use quadrature -use elements -use fields -use halos -use state_module -use Multigrid -use FLDebug -use Sparse_Tools -use Petsc_Tools -use solvers -use sparse_tools_petsc -use petsc_solve_state_module -use Global_Parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN -use spud -use populate_state_module -use field_options -use halos_registration -use parallel_tools -use petsc -implicit none + use quadrature + use elements + use fields + use halos + use state_module + use Multigrid + use FLDebug + use Sparse_Tools + use Petsc_Tools + use solvers + use sparse_tools_petsc + use petsc_solve_state_module + use Global_Parameters, only: FIELD_NAME_LEN, OPTION_PATH_LEN + use spud + use populate_state_module + use field_options + use halos_registration + use parallel_tools + use petsc + implicit none #include "petsc_legacy.h" - ! options read from command-line (-prns_... options) - character(len=4096) filename, flml - character(len=FIELD_NAME_LEN):: field - logical zero_init_guess, scipy, random_rhs - - PetscViewer viewer - PetscRandom pr - Mat matrix - Vec rhs, x - PetscErrorCode ierr - - call petsc_readnsolve_options(filename, flml, field, & - zero_init_guess, & - scipy, random_rhs) - - ewrite(1,*) 'Opening: ', trim(filename) - - ! read in the matrix equation and init. guess: - call PetscViewerBinaryOpen(MPI_COMM_FEMTOOLS, trim(filename), & - FILE_MODE_READ, viewer, ierr) - call MatCreate(MPI_COMM_FEMTOOLS, matrix, ierr) - call VecCreate(MPI_COMM_FEMTOOLS, rhs, ierr) - if (IsParallel()) then - call MatSetType(matrix, MATMPIAIJ, ierr) - call VecSetType(rhs, VECMPI, ierr) - else - call MatSetType(matrix, MATSEQAIJ, ierr) - call VecSetType(rhs, VECSEQ, ierr) - end if - call MatLoad(matrix, viewer, ierr) - call VecLoad(rhs, viewer, ierr) - if (zero_init_guess) then - call VecDuplicate(rhs, x, ierr) - else - call VecCreate(MPI_COMM_FEMTOOLS, x, ierr) - if (IsParallel()) then - call VecSetType(x, VECMPI, ierr) - else - call VecSetType(x, VECSEQ, ierr) - end if - call VecLoad(x, viewer, ierr) - end if - call PetscViewerDestroy(viewer, ierr) - if (random_rhs) then - call PetscRandomCreate(PETSC_COMM_WORLD, pr, ierr) - call VecSetRandom(rhs, pr, ierr) - call PetscRandomDestroy(pr, ierr) - end if - - - if (flml=='') then - call petsc_readnsolve_old_style(filename, & - zero_init_guess, scipy, & - matrix, x, rhs) - else - call petsc_readnsolve_flml(flml, field, & - matrix, x, rhs) - end if + ! options read from command-line (-prns_... options) + character(len=4096) filename, flml + character(len=FIELD_NAME_LEN):: field + logical zero_init_guess, scipy, random_rhs + + PetscViewer viewer + PetscRandom pr + Mat matrix + Vec rhs, x + PetscErrorCode ierr + + call petsc_readnsolve_options(filename, flml, field, & + zero_init_guess, & + scipy, random_rhs) + + ewrite(1,*) 'Opening: ', trim(filename) + + ! read in the matrix equation and init. guess: + call PetscViewerBinaryOpen(MPI_COMM_FEMTOOLS, trim(filename), & + FILE_MODE_READ, viewer, ierr) + call MatCreate(MPI_COMM_FEMTOOLS, matrix, ierr) + call VecCreate(MPI_COMM_FEMTOOLS, rhs, ierr) + if (IsParallel()) then + call MatSetType(matrix, MATMPIAIJ, ierr) + call VecSetType(rhs, VECMPI, ierr) + else + call MatSetType(matrix, MATSEQAIJ, ierr) + call VecSetType(rhs, VECSEQ, ierr) + end if + call MatLoad(matrix, viewer, ierr) + call VecLoad(rhs, viewer, ierr) + if (zero_init_guess) then + call VecDuplicate(rhs, x, ierr) + else + call VecCreate(MPI_COMM_FEMTOOLS, x, ierr) + if (IsParallel()) then + call VecSetType(x, VECMPI, ierr) + else + call VecSetType(x, VECSEQ, ierr) + end if + call VecLoad(x, viewer, ierr) + end if + call PetscViewerDestroy(viewer, ierr) + if (random_rhs) then + call PetscRandomCreate(PETSC_COMM_WORLD, pr, ierr) + call VecSetRandom(rhs, pr, ierr) + call PetscRandomDestroy(pr, ierr) + end if + + + if (flml=='') then + call petsc_readnsolve_old_style(filename, & + zero_init_guess, scipy, & + matrix, x, rhs) + else + call petsc_readnsolve_flml(flml, field, & + matrix, x, rhs) + end if contains - subroutine petsc_readnsolve_old_style(filename, & + subroutine petsc_readnsolve_old_style(filename, & zero_init_guess, scipy, & matrix, x, rhs) - !! this is the old way of running petsc_readnsolve, everything - !! is handled with PETSc calls locally, i.e. nothing from petsc_solve() - !! in fluidity is used - ! options read from command line: - character(len=*), intent(in):: filename - logical, intent(in):: zero_init_guess, scipy - ! PETSc matrix, rhs vector and initial guess vector read from matrixdump: - Mat, intent(inout):: matrix - Vec, intent(inout):: x, rhs - - real, allocatable:: xv(:), rv(:), rhsv(:), dv(:) - KSPType krylov_method - PCType pc_method - KSP krylov - PC prec - Vec y - PetscViewer viewer - PetscBool flag - PetscErrorCode ierr - KSPConvergedReason reason - type(csr_matrix) A - real value - real time1, time2, time3 - integer i, n, n1, n2, iterations - - ewrite(0,*) "Called petsc_readnsolve without specifying flml." - ewrite(0,*) "The recommend way of calling petsc_readnsolve is now"//& - &" by specifying both the .flml and field to solve for"//& - &" on the command line, e.g.:" - ewrite(0,*) " petsc_readnsolve mycase.flml Pressure" - ewrite(0,*) - - ! output initial basic statistics: - call VecNorm(rhs, NORM_2, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'Right-hand side 2-norm:', value - call VecNorm(rhs, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'Right-hand side inf-norm:', value - call VecNorm(x, NORM_2, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'init. guess 2-norm:', value - call VecNorm(x, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'init. guess inf-norm:', value - - ! including inital residual: - call VecDuplicate(x,y, ierr) - call MatMult(matrix, x, y, ierr) - call VecAXPY(y, real(-1.0, kind = PetscScalar_kind), rhs, ierr) - call VecNorm(y, NORM_2, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'init. residual 2-norm:', value - call VecNorm(y, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'init. residual inf-norm:', value - - ! get values to locate 'large sping' boundary conditions: - call VecGetOwnershipRange(rhs, n1, n2, ierr) - n=n2-n1 - allocate(rv(1:n), xv(1:n), rhsv(1:n), dv(1:n)) - call VecGetValues(y, n, (/ (i, i=0, n-1) /)+n1, & - real(rv, kind = PetscScalar_kind),ierr) - call VecGetValues(x, n, (/ (i, i=0, n-1) /)+n1, & - real(xv, kind = PetscScalar_kind),ierr) - call VecGetValues(rhs, n, (/ (i, i=0, n-1) /)+n1, & - real(rhsv, kind = PetscScalar_kind),ierr) - call MatGetDiagonal(matrix, y, ierr) - call VecGetValues(y, n, (/ (i, i=0, n-1) /)+n1, & - real(dv, kind = PetscScalar_kind),ierr) - - ! This can get massive so lower verbosity if you don't want it: - ewrite(3,*) 'Large spring boundary conditions found at:' - ewrite(3,*) ' rownumber, init. guess, rhs and init. residual' - do i=1, n - if (abs(dv(i))>1d15) then - ewrite(3, *) i, xv(i), rhsv(i), rv(i) + !! this is the old way of running petsc_readnsolve, everything + !! is handled with PETSc calls locally, i.e. nothing from petsc_solve() + !! in fluidity is used + ! options read from command line: + character(len=*), intent(in):: filename + logical, intent(in):: zero_init_guess, scipy + ! PETSc matrix, rhs vector and initial guess vector read from matrixdump: + Mat, intent(inout):: matrix + Vec, intent(inout):: x, rhs + + real, allocatable:: xv(:), rv(:), rhsv(:), dv(:) + KSPType krylov_method + PCType pc_method + KSP krylov + PC prec + Vec y + PetscViewer viewer + PetscBool flag + PetscErrorCode ierr + KSPConvergedReason reason + type(csr_matrix) A + real value + real time1, time2, time3 + integer i, n, n1, n2, iterations + + ewrite(0,*) "Called petsc_readnsolve without specifying flml." + ewrite(0,*) "The recommend way of calling petsc_readnsolve is now"//& + &" by specifying both the .flml and field to solve for"//& + &" on the command line, e.g.:" + ewrite(0,*) " petsc_readnsolve mycase.flml Pressure" + ewrite(0,*) + + ! output initial basic statistics: + call VecNorm(rhs, NORM_2, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'Right-hand side 2-norm:', value + call VecNorm(rhs, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'Right-hand side inf-norm:', value + call VecNorm(x, NORM_2, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'init. guess 2-norm:', value + call VecNorm(x, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'init. guess inf-norm:', value + + ! including inital residual: + call VecDuplicate(x,y, ierr) + call MatMult(matrix, x, y, ierr) + call VecAXPY(y, real(-1.0, kind = PetscScalar_kind), rhs, ierr) + call VecNorm(y, NORM_2, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'init. residual 2-norm:', value + call VecNorm(y, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'init. residual inf-norm:', value + + ! get values to locate 'large sping' boundary conditions: + call VecGetOwnershipRange(rhs, n1, n2, ierr) + n=n2-n1 + allocate(rv(1:n), xv(1:n), rhsv(1:n), dv(1:n)) + call VecGetValues(y, n, (/ (i, i=0, n-1) /)+n1, & + real(rv, kind = PetscScalar_kind),ierr) + call VecGetValues(x, n, (/ (i, i=0, n-1) /)+n1, & + real(xv, kind = PetscScalar_kind),ierr) + call VecGetValues(rhs, n, (/ (i, i=0, n-1) /)+n1, & + real(rhsv, kind = PetscScalar_kind),ierr) + call MatGetDiagonal(matrix, y, ierr) + call VecGetValues(y, n, (/ (i, i=0, n-1) /)+n1, & + real(dv, kind = PetscScalar_kind),ierr) + + ! This can get massive so lower verbosity if you don't want it: + ewrite(3,*) 'Large spring boundary conditions found at:' + ewrite(3,*) ' rownumber, init. guess, rhs and init. residual' + do i=1, n + if (abs(dv(i))>1d15) then + ewrite(3, *) i, xv(i), rhsv(i), rv(i) + end if + end do + + ! set up PETSc solver: + ! default values: + krylov_method=KSPGMRES + pc_method=PCSOR + + call PetscOptionsGetString(PETSC_NULL_OPTIONS, '', "-ksp_type", krylov_method, flag, ierr) + call PetscOptionsGetString(PETSC_NULL_OPTIONS, '', "-pc_type", pc_method, flag, ierr) + call KSPCreate(MPI_COMM_FEMTOOLS, krylov, ierr) + call KSPSetType(krylov, krylov_method, ierr) + call KSPSetOperators(krylov, matrix, matrix, ierr) + call KSPSetTolerances(krylov, 1.0d-100, 1d-12, PETSC_DEFAULT_REAL, & + 3000, ierr) + if (zero_init_guess) then + call KSPSetInitialGuessNonzero(krylov, PETSC_FALSE, ierr) + ! also explicitly zero x vector for output purposes + call VecZeroEntries(x, ierr) + else + call KSPSetInitialGuessNonzero(krylov, PETSC_TRUE, ierr) end if - end do - - ! set up PETSc solver: - ! default values: - krylov_method=KSPGMRES - pc_method=PCSOR - - call PetscOptionsGetString(PETSC_NULL_OPTIONS, '', "-ksp_type", krylov_method, flag, ierr) - call PetscOptionsGetString(PETSC_NULL_OPTIONS, '', "-pc_type", pc_method, flag, ierr) - call KSPCreate(MPI_COMM_FEMTOOLS, krylov, ierr) - call KSPSetType(krylov, krylov_method, ierr) - call KSPSetOperators(krylov, matrix, matrix, ierr) - call KSPSetTolerances(krylov, 1.0d-100, 1d-12, PETSC_DEFAULT_REAL, & - 3000, ierr) - if (zero_init_guess) then - call KSPSetInitialGuessNonzero(krylov, PETSC_FALSE, ierr) - ! also explicitly zero x vector for output purposes - call VecZeroEntries(x, ierr) - else - call KSPSetInitialGuessNonzero(krylov, PETSC_TRUE, ierr) - end if - - ! first timer includes set up time: - call cpu_time(time1) - call KSPGetPC(krylov, prec, ierr) - call PCSetType(prec, pc_method, ierr) - if (pc_method==PCMG) then - call SetupSmoothedAggregation(prec, matrix, ierr) - if (ierr/=0) then - ewrite(0,*) 'WARNING: setup of mg preconditioner failed' - stop + + ! first timer includes set up time: + call cpu_time(time1) + call KSPGetPC(krylov, prec, ierr) + call PCSetType(prec, pc_method, ierr) + if (pc_method==PCMG) then + call SetupSmoothedAggregation(prec, matrix, ierr) + if (ierr/=0) then + ewrite(0,*) 'WARNING: setup of mg preconditioner failed' + stop + end if end if - end if - call PCSetFromOptions(prec, ierr) - call PCSetUp(prec, ierr) - call KSPSetFromOptions(krylov, ierr) - call KSPSetUp(krylov, ierr) - - ! pure solving: - call cpu_time(time2) - call KSPSolve(krylov, rhs, x, ierr) - call cpu_time(time3) - call KSPGetConvergedReason(krylov, reason, ierr) - call KSPGetIterationNumber(krylov, iterations, ierr) - - ! this also kills the pc: - call KSPDestroy(krylov, ierr) - - ! most basic solver statistics: - ewrite(2,*) 'Convergence reason:', reason - ewrite(2,*) 'after iterations: ', iterations - ewrite(2,*) 'Total time including set up: ', time3-time1 - ewrite(2,*) 'Time in solving: ', time3-time2 - - ! output final residual: - call MatMult(matrix, x, y, ierr) - call VecAXPY(y, real(-1.0, kind = PetscScalar_kind), rhs, ierr) - call VecNorm(y, NORM_2, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'Final residual 2-norm:', value - call VecNorm(y, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) - ewrite(2,*) 'Final residual inf-norm:', value - - ! write matrix and rhs in scipy readable format - if (scipy) then - - A=petsc2csr(matrix) - call mmwrite(trim(filename)//'.mm', A) - call deallocate(A) + call PCSetFromOptions(prec, ierr) + call PCSetUp(prec, ierr) + call KSPSetFromOptions(krylov, ierr) + call KSPSetUp(krylov, ierr) + + ! pure solving: + call cpu_time(time2) + call KSPSolve(krylov, rhs, x, ierr) + call cpu_time(time3) + call KSPGetConvergedReason(krylov, reason, ierr) + call KSPGetIterationNumber(krylov, iterations, ierr) + + ! this also kills the pc: + call KSPDestroy(krylov, ierr) + + ! most basic solver statistics: + ewrite(2,*) 'Convergence reason:', reason + ewrite(2,*) 'after iterations: ', iterations + ewrite(2,*) 'Total time including set up: ', time3-time1 + ewrite(2,*) 'Time in solving: ', time3-time2 + + ! output final residual: + call MatMult(matrix, x, y, ierr) + call VecAXPY(y, real(-1.0, kind = PetscScalar_kind), rhs, ierr) + call VecNorm(y, NORM_2, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'Final residual 2-norm:', value + call VecNorm(y, NORM_INFINITY, real(value, kind = PetscScalar_kind), ierr) + ewrite(2,*) 'Final residual inf-norm:', value + + ! write matrix and rhs in scipy readable format + if (scipy) then + + A=petsc2csr(matrix) + call mmwrite(trim(filename)//'.mm', A) + call deallocate(A) + + ! RHS + call PetscViewerASCIIOpen(MPI_COMM_FEMTOOLS, & + trim(filename)//'.rhs.vec', & + viewer, ierr) + call VecView(rhs, viewer, ierr) + call PetscViewerDestroy(viewer, ierr) + + ! solution + call PetscViewerASCIIOpen(MPI_COMM_FEMTOOLS, & + trim(filename)//'.sol.vec', & + viewer, ierr) + call VecView(x, viewer, ierr) + call PetscViewerDestroy(viewer, ierr) - ! RHS - call PetscViewerASCIIOpen(MPI_COMM_FEMTOOLS, & - trim(filename)//'.rhs.vec', & - viewer, ierr) - call VecView(rhs, viewer, ierr) - call PetscViewerDestroy(viewer, ierr) + end if + + call VecDestroy(y, ierr) + call MatDestroy(matrix, ierr) + call VecDestroy(x, ierr) + call VecDestroy(rhs, ierr) + + end subroutine petsc_readnsolve_old_style - ! solution - call PetscViewerASCIIOpen(MPI_COMM_FEMTOOLS, & - trim(filename)//'.sol.vec', & - viewer, ierr) - call VecView(x, viewer, ierr) - call PetscViewerDestroy(viewer, ierr) + subroutine petsc_readnsolve_flml(flml, field, & + matrix, x, rhs) + character(len=*), intent(in):: flml, field + Mat, intent(inout):: matrix + Vec, intent(inout):: x, rhs + + type(petsc_numbering_type):: petsc_numbering + type(element_type):: shape + type(quadrature_type):: quad + type(mesh_type):: mesh + type(state_type), pointer:: states(:) + type(petsc_csr_matrix):: A + type(scalar_field):: x_field, rhs_field + character(len=OPTION_PATH_LEN):: option_path + character(len=FIELD_NAME_LEN):: field_name, mesh_name + logical read_state, fail + integer i, n, istate, stat + type(halo_type), pointer :: my_halo + integer nstates, universal_nodes, components, dim + + ewrite(1,*) "Opening flml file ", trim(flml) + call load_options(flml) + if (.not. have_option('/simulation_name')) then + ! backtrace not very useful, here: + FLExit("Failed to load options tree from flml.") + end if - end if + option_path=workout_option_path(field, fail) + if (fail) then - call VecDestroy(y, ierr) - call MatDestroy(matrix, ierr) - call VecDestroy(x, ierr) - call VecDestroy(rhs, ierr) + ewrite(1,*) "Since I can't work out the option path for the specified field" + ewrite(1,*) "I'll try populating the states first." + read_state=.true. - end subroutine petsc_readnsolve_old_style + else + + read_state=petsc_solve_needs_state(option_path) + if (read_state) then + ewrite(1,*) "The specified solver options require geometry information" + ewrite(1,*) "Will read in all state information first" + end if + + end if - subroutine petsc_readnsolve_flml(flml, field, & - matrix, x, rhs) - character(len=*), intent(in):: flml, field - Mat, intent(inout):: matrix - Vec, intent(inout):: x, rhs - - type(petsc_numbering_type):: petsc_numbering - type(element_type):: shape - type(quadrature_type):: quad - type(mesh_type):: mesh - type(state_type), pointer:: states(:) - type(petsc_csr_matrix):: A - type(scalar_field):: x_field, rhs_field - character(len=OPTION_PATH_LEN):: option_path - character(len=FIELD_NAME_LEN):: field_name, mesh_name - logical read_state, fail - integer i, n, istate, stat - type(halo_type), pointer :: my_halo - integer nstates, universal_nodes, components, dim - - ewrite(1,*) "Opening flml file ", trim(flml) - call load_options(flml) - if (.not. have_option('/simulation_name')) then - ! backtrace not very useful, here: - FLExit("Failed to load options tree from flml.") - end if - - option_path=workout_option_path(field, fail) - if (fail) then - - ewrite(1,*) "Since I can't work out the option path for the specified field" - ewrite(1,*) "I'll try populating the states first." - read_state=.true. - - else - - read_state=petsc_solve_needs_state(option_path) if (read_state) then - ewrite(1,*) "The specified solver options require geometry information" - ewrite(1,*) "Will read in all state information first" + + call populate_state(states) + + ! work out option_path (possibly again) + call workout_option_path_from_state(states, field, option_path, istate) + + else if (IsParallel()) then + + ! we have an option_path, so we can + ! short track by only reading the meshes: + + ! Find out how many states there are + nstates=option_count("/material_phase") + allocate(states(1:nstates)) + do i = 1, nstates + call nullify(states(i)) + end do + + call insert_external_mesh(states) + + call insert_derived_meshes(states) + + ! for meshes all states are the same: + istate=1 + end if - end if + ! now we have an option_path + ! let's find or construct a mesh: + call VecGetSize(x, n, ierr) - if (read_state) then - call populate_state(states) + if (read_state .or. IsParallel()) then - ! work out option_path (possibly again) - call workout_option_path_from_state(states, field, option_path, istate) + call get_option(trim(complete_field_path(option_path))// & + '/mesh[0]/name', mesh_name) + mesh=extract_mesh(states(istate), mesh_name) - else if (IsParallel()) then + ! now work out the number of nodes according to the mesh + if (IsParallel()) then - ! we have an option_path, so we can - ! short track by only reading the meshes: + assert(halo_count(mesh) > 0) + my_halo => mesh%halos(halo_count(mesh)) + call allocate(petsc_numbering, node_count(mesh), 1, halo=my_halo) + else - ! Find out how many states there are - nstates=option_count("/material_phase") - allocate(states(1:nstates)) - do i = 1, nstates - call nullify(states(i)) - end do + call allocate(petsc_numbering, node_count(mesh), 1) - call insert_external_mesh(states) + end if - call insert_derived_meshes(states) + universal_nodes=petsc_numbering%universal_length - ! for meshes all states are the same: - istate=1 + ! Escape division by zero in mod() by exiting prior to evaluation + if (universal_nodes==0) FLExit("Cannot have 0 nodes in specified mesh") - end if + ! and compare it with the size of the PETSc vector + if (universal_nodes==n) then - ! now we have an option_path - ! let's find or construct a mesh: - call VecGetSize(x, n, ierr) + ewrite(1,*) "Node count of mesh agrees with that of the matrixdump: ", n + components=1 + else if (mod(n, universal_nodes)==0) then - if (read_state .or. IsParallel()) then + components=universal_nodes/n + call petsc_readnsolve_vector(mesh, n, universal_nodes, option_path, x, matrix, rhs, & + states(istate), read_state) - call get_option(trim(complete_field_path(option_path))// & - '/mesh[0]/name', mesh_name) - mesh=extract_mesh(states(istate), mesh_name) + else - ! now work out the number of nodes according to the mesh - if (IsParallel()) then + ewrite(1,*) "Number of nodes in specified mesh: ", universal_nodes + ewrite(1,*) "Vector length in matrixdump:", n + FLExit("Mesh and matrixdump size don't agree") + + end if - assert(halo_count(mesh) > 0) - my_halo => mesh%halos(halo_count(mesh)) - call allocate(petsc_numbering, node_count(mesh), 1, halo=my_halo) else - call allocate(petsc_numbering, node_count(mesh), 1) + ! allocate a dummy quadrature, shape and mesh + ! all we need is a mesh with node_count(mesh)=n + call get_option('/geometry/dimension/', dim) + quad=make_quadrature(vertices=dim+1, dim=dim, degree=1) + shape=make_element_shape(vertices=dim+1, dim=dim, degree=1, quad=quad) + ! allocate the mesh with n nodes and 1 element + call allocate(mesh, n, 1, shape, "Mesh") + call deallocate(shape) + call deallocate(quad) + + ! setup trivial petsc numbering + call allocate(petsc_numbering, n, 1) + universal_nodes=n + components=1 end if - universal_nodes=petsc_numbering%universal_length + if (components==1) then - ! Escape division by zero in mod() by exiting prior to evaluation - if (universal_nodes==0) FLExit("Cannot have 0 nodes in specified mesh") + if (IsParallel()) then - ! and compare it with the size of the PETSc vector - if (universal_nodes==n) then + call redistribute_matrix(matrix, x, rhs, petsc_numbering) - ewrite(1,*) "Node count of mesh agrees with that of the matrixdump: ", n - components=1 + end if - else if (mod(n, universal_nodes)==0) then + call allocate(A, matrix, petsc_numbering, petsc_numbering, "PetscReadNSolveMatrix") - components=universal_nodes/n - call petsc_readnsolve_vector(mesh, n, universal_nodes, option_path, x, matrix, rhs, & - states(istate), read_state) + ! this might not be the full name, but it's only for log output: + call get_option(trim(option_path)//'/name', field_name) + call allocate(x_field, mesh, field_name) + x_field%option_path=option_path + call allocate(rhs_field, mesh, "RHS") - else + call petsc2field(x, petsc_numbering, x_field, rhs_field) + call petsc2field(rhs, petsc_numbering, rhs_field, rhs_field) - ewrite(1,*) "Number of nodes in specified mesh: ", universal_nodes - ewrite(1,*) "Vector length in matrixdump:", n - FLExit("Mesh and matrixdump size don't agree") + call VecDestroy(rhs, ierr) + call VecDestroy(x, ierr) - end if + ! prevent rewriting the matrixdump on failure + call add_option(trim(complete_solver_option_path(x_field%option_path))//'/no_matrixdump', stat=stat) - else + ewrite(1,*) 'Going into petsc_solve' + ewrite(1,*) '-------------------------------------------------------------' - ! allocate a dummy quadrature, shape and mesh - ! all we need is a mesh with node_count(mesh)=n - call get_option('/geometry/dimension/', dim) - quad=make_quadrature(vertices=dim+1, dim=dim, degree=1) - shape=make_element_shape(vertices=dim+1, dim=dim, degree=1, quad=quad) - ! allocate the mesh with n nodes and 1 element - call allocate(mesh, n, 1, shape, "Mesh") - call deallocate(shape) - call deallocate(quad) + if (read_state) then + call petsc_solve(x_field, A, rhs_field, states(istate)) + else + call petsc_solve(x_field, A, rhs_field) + end if - ! setup trivial petsc numbering - call allocate(petsc_numbering, n, 1) - universal_nodes=n - components=1 + ewrite_minmax(x_field) - end if + ewrite(1,*) '-------------------------------------------------------------' + ewrite(1,*) 'Finished petsc_solve' - if (components==1) then + call deallocate(A) + call deallocate(x_field) + call deallocate(rhs_field) - if (IsParallel()) then + end if - call redistribute_matrix(matrix, x, rhs, petsc_numbering) + if (associated(states)) then + do istate=1, size(states) + call deallocate(states(istate)) + end do + else + call deallocate(mesh) + end if + call deallocate(petsc_numbering) + end subroutine petsc_readnsolve_flml + + subroutine petsc_readnsolve_vector(mesh, n, universal_nodes, option_path, x, matrix, rhs, & + state, read_state) + + type(mesh_type), intent(inout):: mesh + integer, intent(in):: n ! matrixdump size + integer, intent(in):: universal_nodes ! mesh size + character(len=*), intent(in):: option_path + Mat, intent(inout):: matrix + Vec, intent(inout):: x, rhs + type(state_type), intent(in):: state + logical, intent(in):: read_state ! have we actually called populate state fully? + + type(petsc_csr_matrix):: A + type(halo_type), pointer:: halo + type(vector_field):: x_field, rhs_field + type(petsc_numbering_type):: petsc_numbering + character(len=FIELD_NAME_LEN):: field_name + PetscErrorCode:: ierr + integer:: components, stat + + components=n/universal_nodes + ewrite(1,*) "Number of nodes in the mesh is an integer multiple of the matrixdump size" + ewrite(1,*) "Assuming it's a vector field with" + ewrite(1,*) components, " components and ", universal_nodes, " nodes." + + ! redo the petsc_numbering, this time with the right n/o nodes and components + if (isparallel()) then + halo => mesh%halos(halo_count(mesh)) + call allocate(petsc_numbering, node_count(mesh), components, & + & halo=halo) + call redistribute_matrix(matrix, x, rhs, petsc_numbering) + else + call allocate(petsc_numbering, node_count(mesh), components) end if call allocate(A, matrix, petsc_numbering, petsc_numbering, "PetscReadNSolveMatrix") ! this might not be the full name, but it's only for log output: call get_option(trim(option_path)//'/name', field_name) - call allocate(x_field, mesh, field_name) + call allocate(x_field, components, mesh, name=field_name) x_field%option_path=option_path - call allocate(rhs_field, mesh, "RHS") + call allocate(rhs_field, components, mesh, "RHS") - call petsc2field(x, petsc_numbering, x_field, rhs_field) - call petsc2field(rhs, petsc_numbering, rhs_field, rhs_field) + call petsc2field(x, petsc_numbering, x_field) + call petsc2field(rhs, petsc_numbering, rhs_field) call VecDestroy(rhs, ierr) call VecDestroy(x, ierr) @@ -435,7 +518,7 @@ subroutine petsc_readnsolve_flml(flml, field, & ewrite(1,*) '-------------------------------------------------------------' if (read_state) then - call petsc_solve(x_field, A, rhs_field, states(istate)) + call petsc_solve(x_field, A, rhs_field, state=state) else call petsc_solve(x_field, A, rhs_field) end if @@ -446,345 +529,262 @@ subroutine petsc_readnsolve_flml(flml, field, & ewrite(1,*) 'Finished petsc_solve' call deallocate(A) + call deallocate(x_field) call deallocate(rhs_field) - - end if - - if (associated(states)) then - do istate=1, size(states) - call deallocate(states(istate)) - end do - else - call deallocate(mesh) - end if - call deallocate(petsc_numbering) - - end subroutine petsc_readnsolve_flml - - subroutine petsc_readnsolve_vector(mesh, n, universal_nodes, option_path, x, matrix, rhs, & - state, read_state) - - type(mesh_type), intent(inout):: mesh - integer, intent(in):: n ! matrixdump size - integer, intent(in):: universal_nodes ! mesh size - character(len=*), intent(in):: option_path - Mat, intent(inout):: matrix - Vec, intent(inout):: x, rhs - type(state_type), intent(in):: state - logical, intent(in):: read_state ! have we actually called populate state fully? - - type(petsc_csr_matrix):: A - type(halo_type), pointer:: halo - type(vector_field):: x_field, rhs_field - type(petsc_numbering_type):: petsc_numbering - character(len=FIELD_NAME_LEN):: field_name - PetscErrorCode:: ierr - integer:: components, stat - - components=n/universal_nodes - ewrite(1,*) "Number of nodes in the mesh is an integer multiple of the matrixdump size" - ewrite(1,*) "Assuming it's a vector field with" - ewrite(1,*) components, " components and ", universal_nodes, " nodes." - - ! redo the petsc_numbering, this time with the right n/o nodes and components - if (isparallel()) then - halo => mesh%halos(halo_count(mesh)) - call allocate(petsc_numbering, node_count(mesh), components, & - & halo=halo) - call redistribute_matrix(matrix, x, rhs, petsc_numbering) - else - call allocate(petsc_numbering, node_count(mesh), components) - end if - - call allocate(A, matrix, petsc_numbering, petsc_numbering, "PetscReadNSolveMatrix") - - ! this might not be the full name, but it's only for log output: - call get_option(trim(option_path)//'/name', field_name) - call allocate(x_field, components, mesh, name=field_name) - x_field%option_path=option_path - call allocate(rhs_field, components, mesh, "RHS") - - call petsc2field(x, petsc_numbering, x_field) - call petsc2field(rhs, petsc_numbering, rhs_field) - - call VecDestroy(rhs, ierr) - call VecDestroy(x, ierr) - - ! prevent rewriting the matrixdump on failure - call add_option(trim(complete_solver_option_path(x_field%option_path))//'/no_matrixdump', stat=stat) - - ewrite(1,*) 'Going into petsc_solve' - ewrite(1,*) '-------------------------------------------------------------' - - if (read_state) then - call petsc_solve(x_field, A, rhs_field, state=state) - else - call petsc_solve(x_field, A, rhs_field) - end if - - ewrite_minmax(x_field) - - ewrite(1,*) '-------------------------------------------------------------' - ewrite(1,*) 'Finished petsc_solve' - - call deallocate(A) - - call deallocate(x_field) - call deallocate(rhs_field) - call deallocate(petsc_numbering) - - end subroutine petsc_readnsolve_vector - - function workout_option_path(field, fail) - character(len=OPTION_PATH_LEN):: workout_option_path - character(len=*), intent(in):: field - logical, optional, intent(out):: fail - - character(len=FIELD_NAME_LEN):: phase_name, field_name - integer i, stat - - if (field(1:1)=='/') then - ! complete option path is provided - call get_option(trim(field)//'/name', field_name, stat=stat) - if (stat/=0) then - ewrite(-1,*) "Option path:", field - FLExit("Provided option path is not valid") + call deallocate(petsc_numbering) + + end subroutine petsc_readnsolve_vector + + function workout_option_path(field, fail) + character(len=OPTION_PATH_LEN):: workout_option_path + character(len=*), intent(in):: field + logical, optional, intent(out):: fail + + character(len=FIELD_NAME_LEN):: phase_name, field_name + integer i, stat + + if (field(1:1)=='/') then + ! complete option path is provided + call get_option(trim(field)//'/name', field_name, stat=stat) + if (stat/=0) then + ewrite(-1,*) "Option path:", field + FLExit("Provided option path is not valid") + end if + workout_option_path=field + else + ! assume it's the field name + + ! search for double colon + do i=1, len_trim(field)-1 + if (field(i:i+1)=='::') exit + end do + if (i1) then + ewrite(-1,*) "For multi-material/phase you need to provide& + &the material_phase and the field name, e.g. SolidPhase::Pressure" + FLExit("Missing material_phase name") + end if + call get_option('/material_phase[0]/name', phase_name) + field_name=field + end if + ewrite(2,*) "Phase name: ", trim(phase_name) + ! try scalar/vector/tensor field directly under material_phase + workout_option_path='/material_phase::'//trim(phase_name)// & + '/scalar_field::'//trim(field_name) + if (.not. have_option(workout_option_path)) then + workout_option_path='/material_phase::'//trim(phase_name)// & + '/vector_field::'//trim(field_name) + if (.not. have_option(workout_option_path)) then + if (present(fail)) then + fail=.true. + return + end if + ewrite(-1,*) "Field name: ", trim(field_name) + ewrite(-1,*) "Cannot find specified field directly under /material_phase" + ewrite(-1,*) "If it is not, you have to specify the full option_path" + FLExit("Unable to workout option path") + end if + end if + end if + ewrite(2,*) "Field name: ", trim(field_name) + ewrite(2,*) "Full option_path: ", trim(workout_option_path) + if (present(fail)) then + fail=.false. end if - workout_option_path=field - else - ! assume it's the field name - ! search for double colon - do i=1, len_trim(field)-1 - if (field(i:i+1)=='::') exit - end do - if (i1) then - ewrite(-1,*) "For multi-material/phase you need to provide& + ! search for double colon + do i=1, len_trim(field)-1 + if (field(i:i+1)=='::') exit + end do + if (isize(states)) then + ewrite(-1,*) "Material_phase name:", trim(phase_name) + FLExit("This phase name is not known in the flml") + end if + istate=i end if - end if - ewrite(2,*) "Field name: ", trim(field_name) - ewrite(2,*) "Full option_path: ", trim(workout_option_path) - if (present(fail)) then - fail=.false. - end if - - end function workout_option_path - - subroutine workout_option_path_from_state(states, field, & - option_path, istate) - type(state_type), dimension(:), intent(in):: states - ! the field name or option path specified on the command line - character(len=*), intent(in):: field - - character(len=*), intent(out):: option_path - integer, intent(out):: istate - - type(vector_field), pointer:: vfield - type(scalar_field), pointer:: sfield - character(len=FIELD_NAME_LEN) phase_name, field_name - integer i, stat - - istate=0 - - ! try to work out name of material_phase - if (field(1:1)=='/') then - ! we've been given an option_path - option_path=field - if (field(1:17)=='/material_phase::') then - do i=18, len(field) - if (field(i:i)=='/') exit - end do - phase_name=field(18:i-1) - else if (size(states)==1) then - istate=1 - return - else - ewrite(-1,*) "Try PhaseName::FieldName instead" - FLAbort("Can't work out material_phase name from option path") + + if (field(i:i)=='/') then + ! we have the option_path already + return end if - else - ! search for double colon - do i=1, len_trim(field)-1 - if (field(i:i+1)=='::') exit - end do - if (i extract_scalar_field( states(istate), field_name, stat=stat) + if (stat==0) then + option_path=sfield%option_path else - ewrite(-1,*) "For multi-material/phase you need to provide& - &the material_phase and the field name, e.g. SolidPhase::Pressure" - FLExit("Missing material_phase name") + ! maybe a vector field then? + vfield => extract_vector_field( states(istate), field_name, stat=stat) + if (stat/=0) then + ewrite(-1,*) "Field name:", trim(field_name) + ewrite(-1,*) "Material_phase name:", trim(phase_name) + FLExit("Not a field in this material_phase") + end if + option_path=vfield%option_path end if - end if - if (istate==0) then - ! now find the right state - do i=1, size(states) - if (states(i)%name==phase_name) exit - end do - if (i>size(states)) then - ewrite(-1,*) "Material_phase name:", trim(phase_name) - FLExit("This phase name is not known in the flml") + end subroutine workout_option_path_from_state + + subroutine redistribute_matrix(matrix, x, rhs, petsc_numbering) + Mat, intent(inout):: matrix + Vec, intent(inout):: x, rhs + type(petsc_numbering_type), intent(in):: petsc_numbering + + VecScatter scatter + IS row_indexset + Mat new_matrix + Vec new_x, new_rhs + PetscErrorCode ierr + integer, dimension(:), allocatable:: unns + integer n, m, ncomponents + + integer mm,nn + + n=petsc_numbering%nprivatenodes ! local length + ncomponents=size(petsc_numbering%gnn2unn, 2) + allocate(unns(1:n*ncomponents)) + unns=reshape( petsc_numbering%gnn2unn(1:n,:), (/ n*ncomponents /)) + call ISCreateGeneral(MPI_COMM_FEMTOOLS, & + size(unns), unns, PETSC_COPY_VALUES, row_indexset, ierr) + + m=petsc_numbering%universal_length ! global length + + ! we only ask for owned columns (although presumably + ! still all columns of owned rows are stored locally) + ! we only deal with square matrices (same d.o.f. for rows and columns) + ! in fluidity, so we can simply reuse row_indexset as the col_indexset + call MatCreateSubMatrix(matrix, row_indexset, row_indexset, & + MAT_INITIAL_MATRIX, new_matrix, ierr) + + ! destroy the old read-in matrix and replace by the new one + call MatDestroy(matrix, ierr) + matrix=new_matrix + + call matgetsize(matrix, mm, nn, ierr) + ewrite(2,*) "Matrix global size", mm, nn + call matgetlocalsize(matrix, mm, nn, ierr) + ewrite(2,*) "Matrix local size", mm, nn + + ! create a Vec according to the proper partioning: + call VecCreateMPI(MPI_COMM_FEMTOOLS, n*ncomponents, m, new_x, ierr) + ! fill it with values from the read x by asking for its row numbers + call VecScatterCreate(x, row_indexset, new_x, PETSC_NULL_IS, & + scatter, ierr) + call VecScatterBegin(scatter, x, new_x, INSERT_VALUES, & + SCATTER_FORWARD, ierr) + call VecScatterEnd(scatter, x, new_x, INSERT_VALUES, & + SCATTER_FORWARD, ierr) + ! destroy the read x and replace by new_x + call VecDestroy(x, ierr) + x=new_x + + ! do the same for the rhs Vec: + call VecDuplicate(new_x, new_rhs, ierr) + call VecScatterBegin(scatter, rhs, new_rhs, INSERT_VALUES, & + SCATTER_FORWARD, ierr) + call VecScatterEnd(scatter, rhs, new_rhs, INSERT_VALUES, & + SCATTER_FORWARD, ierr) + call VecDestroy(rhs, ierr) + rhs=new_rhs + + call VecScatterDestroy(scatter, ierr) + call ISDestroy(row_indexset, ierr) + + end subroutine redistribute_matrix + + subroutine petsc_readnsolve_options(filename, flml, field, & + zero_init_guess, & + scipy, random_rhs) + character(len=*), intent(out):: filename, flml, field + logical, intent(out):: zero_init_guess, scipy, random_rhs + + PetscBool flag + PetscErrorCode ierr + + call PetscOptionsGetString(PETSC_NULL_OPTIONS, 'prns_', '-filename', filename, flag, ierr) + if (.not. flag) then + filename='matrixdump' end if - istate=i - end if - - if (field(i:i)=='/') then - ! we have the option_path already - return - end if - - ! now pull out the field from state to find its option_path - sfield => extract_scalar_field( states(istate), field_name, stat=stat) - if (stat==0) then - option_path=sfield%option_path - else - ! maybe a vector field then? - vfield => extract_vector_field( states(istate), field_name, stat=stat) - if (stat/=0) then - ewrite(-1,*) "Field name:", trim(field_name) - ewrite(-1,*) "Material_phase name:", trim(phase_name) - FLExit("Not a field in this material_phase") + + call PetscOptionsGetString(PETSC_NULL_OPTIONS, 'prns_', '-flml', flml, flag, ierr) + if (.not. flag) then + flml='' + end if + + call PetscOptionsGetString(PETSC_NULL_OPTIONS, 'prns_', '-field', field, flag, ierr) + if (.not. flag) then + field='' end if - option_path=vfield%option_path - end if - - end subroutine workout_option_path_from_state - - subroutine redistribute_matrix(matrix, x, rhs, petsc_numbering) - Mat, intent(inout):: matrix - Vec, intent(inout):: x, rhs - type(petsc_numbering_type), intent(in):: petsc_numbering - - VecScatter scatter - IS row_indexset - Mat new_matrix - Vec new_x, new_rhs - PetscErrorCode ierr - integer, dimension(:), allocatable:: unns - integer n, m, ncomponents - - integer mm,nn - - n=petsc_numbering%nprivatenodes ! local length - ncomponents=size(petsc_numbering%gnn2unn, 2) - allocate(unns(1:n*ncomponents)) - unns=reshape( petsc_numbering%gnn2unn(1:n,:), (/ n*ncomponents /)) - call ISCreateGeneral(MPI_COMM_FEMTOOLS, & - size(unns), unns, PETSC_COPY_VALUES, row_indexset, ierr) - - m=petsc_numbering%universal_length ! global length - - ! we only ask for owned columns (although presumably - ! still all columns of owned rows are stored locally) - ! we only deal with square matrices (same d.o.f. for rows and columns) - ! in fluidity, so we can simply reuse row_indexset as the col_indexset - call MatCreateSubMatrix(matrix, row_indexset, row_indexset, & - MAT_INITIAL_MATRIX, new_matrix, ierr) - - ! destroy the old read-in matrix and replace by the new one - call MatDestroy(matrix, ierr) - matrix=new_matrix - - call matgetsize(matrix, mm, nn, ierr) - ewrite(2,*) "Matrix global size", mm, nn - call matgetlocalsize(matrix, mm, nn, ierr) - ewrite(2,*) "Matrix local size", mm, nn - - ! create a Vec according to the proper partioning: - call VecCreateMPI(MPI_COMM_FEMTOOLS, n*ncomponents, m, new_x, ierr) - ! fill it with values from the read x by asking for its row numbers - call VecScatterCreate(x, row_indexset, new_x, PETSC_NULL_IS, & - scatter, ierr) - call VecScatterBegin(scatter, x, new_x, INSERT_VALUES, & - SCATTER_FORWARD, ierr) - call VecScatterEnd(scatter, x, new_x, INSERT_VALUES, & - SCATTER_FORWARD, ierr) - ! destroy the read x and replace by new_x - call VecDestroy(x, ierr) - x=new_x - - ! do the same for the rhs Vec: - call VecDuplicate(new_x, new_rhs, ierr) - call VecScatterBegin(scatter, rhs, new_rhs, INSERT_VALUES, & - SCATTER_FORWARD, ierr) - call VecScatterEnd(scatter, rhs, new_rhs, INSERT_VALUES, & - SCATTER_FORWARD, ierr) - call VecDestroy(rhs, ierr) - rhs=new_rhs - - call VecScatterDestroy(scatter, ierr) - call ISDestroy(row_indexset, ierr) - - end subroutine redistribute_matrix - - subroutine petsc_readnsolve_options(filename, flml, field, & - zero_init_guess, & - scipy, random_rhs) - character(len=*), intent(out):: filename, flml, field - logical, intent(out):: zero_init_guess, scipy, random_rhs - - PetscBool flag - PetscErrorCode ierr - - call PetscOptionsGetString(PETSC_NULL_OPTIONS, 'prns_', '-filename', filename, flag, ierr) - if (.not. flag) then - filename='matrixdump' - end if - - call PetscOptionsGetString(PETSC_NULL_OPTIONS, 'prns_', '-flml', flml, flag, ierr) - if (.not. flag) then - flml='' - end if - - call PetscOptionsGetString(PETSC_NULL_OPTIONS, 'prns_', '-field', field, flag, ierr) - if (.not. flag) then - field='' - end if - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, 'prns_', '-zero_init_guess', zero_init_guess, ierr) - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, 'prns_', '-scipy', scipy, ierr) - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, 'prns_', '-random_rhs', random_rhs, ierr) - - call PetscOptionsGetInt(PETSC_NULL_OPTIONS, 'prns_', '-verbosity', current_debug_level, flag, ierr) - if (.not.flag) then - current_debug_level=3 - end if - - end subroutine petsc_readnsolve_options + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, 'prns_', '-zero_init_guess', zero_init_guess, ierr) + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, 'prns_', '-scipy', scipy, ierr) + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, 'prns_', '-random_rhs', random_rhs, ierr) + + call PetscOptionsGetInt(PETSC_NULL_OPTIONS, 'prns_', '-verbosity', current_debug_level, flag, ierr) + if (.not.flag) then + current_debug_level=3 + end if + + end subroutine petsc_readnsolve_options end subroutine petsc_readnsolve diff --git a/tools/project_to_continuous.F90 b/tools/project_to_continuous.F90 index fe2e8011ea..52fb813be5 100644 --- a/tools/project_to_continuous.F90 +++ b/tools/project_to_continuous.F90 @@ -28,101 +28,101 @@ #include "fdebug.h" subroutine project_to_continuous(vtuname_, vtuname_len, meshname_,& - & meshname_len) bind(c) - !!< Given a vtu file containing fields on a discontinuous mesh, and the - !!< mesh files for the corresponding continuous mesh, produce a vtu - !!< with its fields projected onto the continuous mesh. - use state_module - use elements - use fields - use mesh_files - use vtk_interfaces - use sparse_tools - use fefields - use sparse_matrices_fields - use iso_c_binding - implicit none - - character(kind=c_char, len=1) :: vtuname_(*) - integer(kind=c_size_t), value :: vtuname_len - character(kind=c_char, len=1) :: meshname_(*) - integer(kind=c_size_t), value :: meshname_len - - character(len=vtuname_len):: vtuname - character(len=meshname_len):: meshname - - type(state_type) :: dg_state, cg_state - type(vector_field) :: cg_coordinate - type(mesh_type) :: cg_mesh - type(scalar_field) :: dg_scalar, cg_scalar - type(vector_field) :: dg_vector, cg_vector - type(tensor_field) :: dg_tensor, cg_tensor - - integer :: i, j, k +& meshname_len) bind(c) + !!< Given a vtu file containing fields on a discontinuous mesh, and the + !!< mesh files for the corresponding continuous mesh, produce a vtu + !!< with its fields projected onto the continuous mesh. + use state_module + use elements + use fields + use mesh_files + use vtk_interfaces + use sparse_tools + use fefields + use sparse_matrices_fields + use iso_c_binding + implicit none + + character(kind=c_char, len=1) :: vtuname_(*) + integer(kind=c_size_t), value :: vtuname_len + character(kind=c_char, len=1) :: meshname_(*) + integer(kind=c_size_t), value :: meshname_len + + character(len=vtuname_len):: vtuname + character(len=meshname_len):: meshname + + type(state_type) :: dg_state, cg_state + type(vector_field) :: cg_coordinate + type(mesh_type) :: cg_mesh + type(scalar_field) :: dg_scalar, cg_scalar + type(vector_field) :: dg_vector, cg_vector + type(tensor_field) :: dg_tensor, cg_tensor + + integer :: i, j, k ! now turn into proper fortran strings (is there an easier way to do this?) - do i=1, vtuname_len - vtuname(i:i)=vtuname_(i) - end do - do i=1, meshname_len - meshname(i:i)=meshname_(i) - end do + do i=1, vtuname_len + vtuname(i:i)=vtuname_(i) + end do + do i=1, meshname_len + meshname(i:i)=meshname_(i) + end do - call vtk_read_state(vtuname, dg_state, quad_degree=6) + call vtk_read_state(vtuname, dg_state, quad_degree=6) - cg_coordinate= read_mesh_files(meshname, quad_degree=6, format="gmsh") - cg_mesh=cg_coordinate%mesh + cg_coordinate= read_mesh_files(meshname, quad_degree=6, format="gmsh") + cg_mesh=cg_coordinate%mesh - do i=1,size(dg_state%scalar_fields) - dg_scalar=dg_state%scalar_fields(i)%ptr - call allocate(cg_scalar, cg_mesh, name=dg_scalar%name) + do i=1,size(dg_state%scalar_fields) + dg_scalar=dg_state%scalar_fields(i)%ptr + call allocate(cg_scalar, cg_mesh, name=dg_scalar%name) - ! Perform projection. - call project_field(dg_scalar, cg_scalar, cg_coordinate) + ! Perform projection. + call project_field(dg_scalar, cg_scalar, cg_coordinate) - call insert(cg_state, cg_scalar, cg_scalar%name) + call insert(cg_state, cg_scalar, cg_scalar%name) - ! Drop the additional reference. - call deallocate(cg_scalar) - end do + ! Drop the additional reference. + call deallocate(cg_scalar) + end do - do i=1,size(dg_state%vector_fields) - dg_vector=dg_state%vector_fields(i)%ptr - call allocate(cg_vector, dg_vector%dim, cg_mesh, name=dg_vector%name) + do i=1,size(dg_state%vector_fields) + dg_vector=dg_state%vector_fields(i)%ptr + call allocate(cg_vector, dg_vector%dim, cg_mesh, name=dg_vector%name) - call project_field(dg_vector, cg_vector, cg_coordinate) + call project_field(dg_vector, cg_vector, cg_coordinate) - call insert(cg_state, cg_vector, cg_vector%name) + call insert(cg_state, cg_vector, cg_vector%name) - ! Drop the additional reference. - call deallocate(cg_vector) - end do + ! Drop the additional reference. + call deallocate(cg_vector) + end do - do i=1,size(dg_state%tensor_fields) - dg_tensor=dg_state%tensor_fields(i)%ptr - call allocate(cg_tensor, cg_mesh, name=dg_tensor%name) + do i=1,size(dg_state%tensor_fields) + dg_tensor=dg_state%tensor_fields(i)%ptr + call allocate(cg_tensor, cg_mesh, name=dg_tensor%name) - ! Perform projection. - do j=1,cg_tensor%dim(1) - do k=1,cg_tensor%dim(2) - cg_scalar=extract_scalar_field_from_tensor_field(cg_tensor, j, k) - dg_scalar=extract_scalar_field_from_tensor_field(dg_tensor, j, k) - call project_field(dg_scalar, cg_scalar, cg_coordinate) - end do - end do + ! Perform projection. + do j=1,cg_tensor%dim(1) + do k=1,cg_tensor%dim(2) + cg_scalar=extract_scalar_field_from_tensor_field(cg_tensor, j, k) + dg_scalar=extract_scalar_field_from_tensor_field(dg_tensor, j, k) + call project_field(dg_scalar, cg_scalar, cg_coordinate) + end do + end do - call insert(cg_state, cg_tensor, cg_tensor%name) + call insert(cg_state, cg_tensor, cg_tensor%name) - ! Drop the additional reference. - call deallocate(cg_tensor) - end do + ! Drop the additional reference. + call deallocate(cg_tensor) + end do - ! We do this insertion last because otherwise we end up with a projection - ! of coordinate and that gives us a wonky mesh. - call insert(cg_state, cg_coordinate, "Coordinate") - call insert(cg_state, cg_mesh, "CoordinateMesh") + ! We do this insertion last because otherwise we end up with a projection + ! of coordinate and that gives us a wonky mesh. + call insert(cg_state, cg_coordinate, "Coordinate") + call insert(cg_state, cg_mesh, "CoordinateMesh") - call vtk_write_state(vtuname(1:len_trim(vtuname)-4)//"_continuous", & - state=(/cg_state/)) + call vtk_write_state(vtuname(1:len_trim(vtuname)-4)//"_continuous", & + state=(/cg_state/)) end subroutine project_to_continuous diff --git a/tools/test_laplacian.F90 b/tools/test_laplacian.F90 index aac1a93934..7f36eb12cb 100644 --- a/tools/test_laplacian.F90 +++ b/tools/test_laplacian.F90 @@ -1,512 +1,512 @@ #include "confdefs.h" program test_laplacian - ! A small program to solve laplacian psi = f - ! - ! This tests and illustrates the use of fields and shape functions to - ! solve finite element problems. - ! - ! The analytical solution provided is valid on a 1x1 square or - ! 1x1x1 cube with the boundary conditions 1 and 2 applied on the - ! sides of the first coordinates direction (e.g. test_laplacian.poly - ! - create a mesh with 'triangle -a0.01 -e test_laplacian.poly' ) - use quadrature - use mesh_files - use fields - use FEtools - use elements - use sparse_tools - use vtk_interfaces - use transform_elements - use sparsity_patterns - use solvers - use state_module - use adapt_state_module - use boundary_conditions - use petsc - implicit none + ! A small program to solve laplacian psi = f + ! + ! This tests and illustrates the use of fields and shape functions to + ! solve finite element problems. + ! + ! The analytical solution provided is valid on a 1x1 square or + ! 1x1x1 cube with the boundary conditions 1 and 2 applied on the + ! sides of the first coordinates direction (e.g. test_laplacian.poly + ! - create a mesh with 'triangle -a0.01 -e test_laplacian.poly' ) + use quadrature + use mesh_files + use fields + use FEtools + use elements + use sparse_tools + use vtk_interfaces + use transform_elements + use sparsity_patterns + use solvers + use state_module + use adapt_state_module + use boundary_conditions + use petsc + implicit none #include "petsc_legacy.h" - character, parameter:: NEWLINE_CHAR=achar(10) - character(len=*), parameter:: BC_PYTHON_FUNCTION= & - "def val(X, t):"//NEWLINE_CHAR// & - " import math"//NEWLINE_CHAR// & - " return math.cos(math.pi*X[1])" - real, parameter:: BC_CONST_VALUE=1.0 - - type(vector_field), target :: positions - type(scalar_field), target :: psi - type(mesh_type) :: psi_mesh - integer :: degree, quad_degree, dim, vertices - type(quadrature_type), target :: quad - type(element_type), target :: psi_shape - type(state_type) :: state - interface - function rhs_func(X) - ! A function which evaluates the right hand side at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - interface - function solution(X) - ! A function which evaluates the analytic solution at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: solution - end function solution - end interface - character(len=256) :: filename - - integer :: ierr - call PetscInitialize(PETSC_NULL_CHARACTER, ierr) - - call python_init - - call read_command_line(filename, degree, quad_degree) - - positions=read_mesh_files(filename, quad_degree=quad_degree, format="gmsh") - - call insert(state, positions, "Coordinate") - - call insert(state, positions%mesh, "Coordinate_mesh") - - ! Shape functions for psi - dim=mesh_dim(positions) - vertices=dim+1 - quad=make_quadrature(vertices, dim, degree=quad_degree) - - psi_shape=make_element_shape(vertices, dim, degree=degree, quad=quad) - psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) - - call insert(state, psi_mesh, "Psi_Mesh") - - call allocate(psi, psi_mesh, "Psi") - - ! Add two boundary conditions, specify their name, something to identify - ! the type of b.c. with, and to which part of the surface to apply - ! this b.c., i.e to all surface elements with a boundary_ids in the list - call add_boundary_condition(psi, name="my_first_boundary", & - type="neumann", boundary_ids=(/ 1 /) ) - call add_boundary_condition(psi, name="my_second_boundary", & - type="neumann", boundary_ids=(/ 2 /) ) - - call set_boundary_condition_values(psi, positions) - - call insert(state, psi, "Psi") - - ! Do the actual finite element calculation. - call run_model(state, rhs_func) - - call analyse_output(positions, psi, solution) - - if (degree<=2.and.dim>=2) then - ! Output to a vtk file. - call vtk_write_state(trim(filename), index=1, state=(/ state /), & - model="Psi_Mesh") - end if - - call python_end - -contains - - subroutine set_boundary_condition_values(psi, positions) - type(scalar_field), intent(inout):: psi - type(vector_field), intent(in):: positions - - type(mesh_type), pointer:: bc_surface_mesh - type(scalar_field) bc_field - type(vector_field) bc_positions - integer, dimension(:), pointer:: bc_surface_elements - - ! First boundary condition, let's keep it simple and constant. - ! ask for a mesh of this part of the surface only - call get_boundary_condition(psi, name="my_first_boundary", & - surface_mesh=bc_surface_mesh) - - ! allocate a field on it to set b.c. values on - call allocate(bc_field, bc_surface_mesh, name='value') - - ! set it to some constant - call set(bc_field, BC_CONST_VALUE) - - ! insert it to the boundary condition: - call insert_surface_field(psi, "my_first_boundary", bc_field) - - ! deallocate our reference - call deallocate(bc_field) - - ! For the second boundary condition, let's do something more audacious: - ! we're gonna initialise it with a python function! - ! we start the same, but also ask for list of surface_elements - call get_boundary_condition(psi, name="my_second_boundary", & - surface_mesh=bc_surface_mesh, surface_element_list=bc_surface_elements) - call allocate(bc_field, bc_surface_mesh, name='value') - - ! need a positions field on the surface mesh only - ! note: this is a dim vector field on a dim-1 mesh - call allocate(bc_positions, positions%dim, bc_surface_mesh) - call remap_field_to_surface(positions, bc_positions, bc_surface_elements) - - ! initialise with python function - call set_from_python_function(bc_field, BC_PYTHON_FUNCTION, bc_positions, 0.0) - call deallocate(bc_positions) - - ! same as above insert it to the boundary condition and deallocate our reference: - call insert_surface_field(psi, "my_second_boundary", bc_field) - call deallocate(bc_field) - - end subroutine set_boundary_condition_values - - subroutine run_model(state, rhs_func) - type(state_type), intent(inout) :: state - interface - function rhs_func(X) + character, parameter:: NEWLINE_CHAR=achar(10) + character(len=*), parameter:: BC_PYTHON_FUNCTION= & + "def val(X, t):"//NEWLINE_CHAR// & + " import math"//NEWLINE_CHAR// & + " return math.cos(math.pi*X[1])" + real, parameter:: BC_CONST_VALUE=1.0 + + type(vector_field), target :: positions + type(scalar_field), target :: psi + type(mesh_type) :: psi_mesh + integer :: degree, quad_degree, dim, vertices + type(quadrature_type), target :: quad + type(element_type), target :: psi_shape + type(state_type) :: state + interface + function rhs_func(X) ! A function which evaluates the right hand side at a number of ! points. Each column of X describes a set of points at which the ! right hand side is to be evaluated. real, dimension(:,:), intent(in) :: X real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - - type(vector_field), pointer :: positions - type(scalar_field), pointer :: psi - - ! We form and solve the equation A*psi=rhs - type(csr_matrix) :: A - type(csr_sparsity) :: A_sparsity - type(scalar_field) :: RHS - integer :: ele - - ! Extract the required fields from state. - positions=>extract_vector_field(state, "Coordinate") - psi=>extract_scalar_field(state, "Psi") - - ! Calculate the sparsity of A based on the connectivity of psi. - A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') - call allocate(A, A_sparsity) - - call zero(A) - - call allocate(rhs, psi%mesh, "RHS") - call zero(rhs) - - ! Assemble A element by element. - do ele=1, element_count(psi) - call assemble_element_contribution(A, rhs, positions, psi, rhs_func,& - & ele) - end do - - call assemble_boundary_contribution(rhs, positions, psi, "my_first_boundary") - - call assemble_boundary_contribution(rhs, positions, psi, "my_second_boundary") - - ! It is necessary to fix the value of one node in the solution. - ! We choose node 1. - call set(A, 1, 1, INFINITY) - - call zero(psi) - - call matrix2file("A", A) - - call set_solver_options(psi, ksptype='cg', pctype='sor', rtol=1e-7) - - call petsc_solve(psi, A, rhs) - - call vtk_write_fields('test', 0, positions, positions%mesh, & - sfields=(/ psi /) ) - - call deallocate(A) - call deallocate(A_sparsity) - call deallocate(rhs) - - end subroutine run_model - - subroutine assemble_element_contribution(A, rhs, positions, psi, rhs_func& - &, ele) - type(csr_matrix), intent(inout) :: A - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - interface - function rhs_func(X) - ! A function which evaluates the right hand side at a number of + end function rhs_func + end interface + interface + function solution(X) + ! A function which evaluates the analytic solution at a number of ! points. Each column of X describes a set of points at which the ! right hand side is to be evaluated. real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - end function rhs_func - end interface - integer, intent(in) :: ele - - ! Locations of quadrature points - real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad - ! Derivatives of shape function: - real, dimension(ele_loc(psi,ele), & - ele_ngi(psi,ele), positions%dim) :: dshape_psi - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of psi element. - integer, dimension(:), pointer :: ele_psi - ! Shape functions. - type(element_type), pointer :: shape_psi - ! Local Laplacian matrix - real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat - ! Local right hand side. - real, dimension(ele_loc(psi, ele)) :: lrhs - - ele_psi=>ele_nodes(psi, ele) - shape_psi=>ele_shape(psi, ele) - - ! Locations of quadrature points. - X_quad=ele_val_at_quad(positions, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& - & detwei=detwei) - - ! Local assembly: - psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei) - - lrhs=-shape_rhs(shape_psi, rhs_func(X_quad)*detwei) - - ! Global assembly: - call addto(A, ele_psi, ele_psi, psi_mat) - - call addto(rhs, ele_psi, lrhs) - - end subroutine assemble_element_contribution - - subroutine assemble_boundary_contribution(rhs, positions, psi, bc_name) - type(scalar_field), intent(inout) :: rhs - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - character(len=*), intent(in):: bc_name - - type(scalar_field), pointer:: bc_surface_field - integer, dimension(:), pointer:: surface_element_list - type(element_type), pointer:: psi_face_shape - ! note that we assume all shapes to be the same in each element - real, dimension(face_ngi(positions,1)) :: detwei_face - real, dimension(face_loc(psi,1)) :: bc_val_face - real, dimension(face_loc(psi,1), face_loc(psi,1)) :: face_mat - integer, dimension(face_loc(psi,1)) :: psi_face_nodes - - integer ele, face + real, dimension(size(X,2)) :: solution + end function solution + end interface + character(len=256) :: filename - ! pull out the b.c value field again: - bc_surface_field => extract_surface_field(psi, bc_name, 'value') - ! retrieve the list of surface elements/faces where this bc is applied - call get_boundary_condition(psi, bc_name, & - surface_element_list=surface_element_list) + integer :: ierr + call PetscInitialize(PETSC_NULL_CHARACTER, ierr) - ! now do the surface integral: + call python_init - ! loop over the elements of the surface field - ! NOTE: for a 3D (resp. 2D) problem each element of the 2D (resp. 1D) - ! surface field is a face in the 3D (resp. 2D) mesh(es) of psi and - ! positions - do ele=1, ele_count(bc_surface_field) + call read_command_line(filename, degree, quad_degree) - ! get the values in the 2D element in the usual way: - bc_val_face=ele_val(bc_surface_field, ele) + positions=read_mesh_files(filename, quad_degree=quad_degree, format="gmsh") - ! to acces value in the 3D fields, we need to know the face number - face=surface_element_list(ele) + call insert(state, positions, "Coordinate") - ! given those calculate the quadrature weights - call transform_facet_to_physical(positions, face, detwei_face) + call insert(state, positions%mesh, "Coordinate_mesh") - ! integral over the face of the form \int N_i N_j - ! where N_i and N_j are shape functions of psi - psi_face_shape => face_shape(psi, face) - face_mat=shape_shape(psi_face_shape, psi_face_shape, detwei_face) + ! Shape functions for psi + dim=mesh_dim(positions) + vertices=dim+1 + quad=make_quadrature(vertices, dim, degree=quad_degree) - ! global node numbers of nodes of this face in psi%mesh - psi_face_nodes=face_global_nodes(psi, face) + psi_shape=make_element_shape(vertices, dim, degree=degree, quad=quad) + psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) - call addto(rhs, psi_face_nodes, matmul(face_mat, bc_val_face)) - end do + call insert(state, psi_mesh, "Psi_Mesh") - end subroutine assemble_boundary_contribution + call allocate(psi, psi_mesh, "Psi") - subroutine read_command_line(filename, degree, quad_degree) - ! Read the input filename, degree and quadrature degree on the command - ! line. - character(len=*), intent(out) :: filename - integer, intent(out) :: degree, quad_degree - character(len=256) :: degree_buffer - integer :: status + ! Add two boundary conditions, specify their name, something to identify + ! the type of b.c. with, and to which part of the surface to apply + ! this b.c., i.e to all surface elements with a boundary_ids in the list + call add_boundary_condition(psi, name="my_first_boundary", & + type="neumann", boundary_ids=(/ 1 /) ) + call add_boundary_condition(psi, name="my_second_boundary", & + type="neumann", boundary_ids=(/ 2 /) ) - call get_command_argument(1, value=filename, status=status) + call set_boundary_condition_values(psi, positions) - select case(status) - case(1:) - call usage - stop - case(:-1) - write(0,*) "Warning: truncating filename" - end select + call insert(state, psi, "Psi") - call get_command_argument(2, value=degree_buffer, status=status) + ! Do the actual finite element calculation. + call run_model(state, rhs_func) - select case(status) - case(1:) - ! No degree specified. - degree=1 + call analyse_output(positions, psi, solution) - case default - read(degree_buffer, *, iostat=status) degree + if (degree<=2.and.dim>=2) then + ! Output to a vtk file. + call vtk_write_state(trim(filename), index=1, state=(/ state /), & + model="Psi_Mesh") + end if - if (status/=0) then - write (0,*) trim(degree_buffer)//" is not an integer." - call usage - stop - end if + call python_end - end select +contains - call get_command_argument(3, value=degree_buffer, status=status) + subroutine set_boundary_condition_values(psi, positions) + type(scalar_field), intent(inout):: psi + type(vector_field), intent(in):: positions - select case(status) - case(1:) - ! No quadrature degree specified. - quad_degree=2*degree + type(mesh_type), pointer:: bc_surface_mesh + type(scalar_field) bc_field + type(vector_field) bc_positions + integer, dimension(:), pointer:: bc_surface_elements - case default - read(degree_buffer, *, iostat=status) quad_degree - - if (status/=0) then - write (0,*) trim(degree_buffer)//" is not an integer." - call usage - stop - end if + ! First boundary condition, let's keep it simple and constant. + ! ask for a mesh of this part of the surface only + call get_boundary_condition(psi, name="my_first_boundary", & + surface_mesh=bc_surface_mesh) - end select - - end subroutine read_command_line + ! allocate a field on it to set b.c. values on + call allocate(bc_field, bc_surface_mesh, name='value') - subroutine analyse_output(positions, psi, solution) - type(vector_field), target :: positions - type(scalar_field), target :: psi - interface - function solution(X) - ! A function which evaluates the analytic solution at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: solution - end function solution - end interface + ! set it to some constant + call set(bc_field, BC_CONST_VALUE) - type(vector_field) :: newpos - real, dimension(:, :), allocatable :: val - ! Total error in the solution. - real :: error + ! insert it to the boundary condition: + call insert_surface_field(psi, "my_first_boundary", bc_field) - integer :: ele + ! deallocate our reference + call deallocate(bc_field) - call allocate(newpos, positions%dim, psi%mesh, "Coordinate") - call remap_field(from_field=positions, to_field=newpos) + ! For the second boundary condition, let's do something more audacious: + ! we're gonna initialise it with a python function! + ! we start the same, but also ask for list of surface_elements + call get_boundary_condition(psi, name="my_second_boundary", & + surface_mesh=bc_surface_mesh, surface_element_list=bc_surface_elements) + call allocate(bc_field, bc_surface_mesh, name='value') + + ! need a positions field on the surface mesh only + ! note: this is a dim vector field on a dim-1 mesh + call allocate(bc_positions, positions%dim, bc_surface_mesh) + call remap_field_to_surface(positions, bc_positions, bc_surface_elements) + + ! initialise with python function + call set_from_python_function(bc_field, BC_PYTHON_FUNCTION, bc_positions, 0.0) + call deallocate(bc_positions) + + ! same as above insert it to the boundary condition and deallocate our reference: + call insert_surface_field(psi, "my_second_boundary", bc_field) + call deallocate(bc_field) + + end subroutine set_boundary_condition_values + + subroutine run_model(state, rhs_func) + type(state_type), intent(inout) :: state + interface + function rhs_func(X) + ! A function which evaluates the right hand side at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface + + type(vector_field), pointer :: positions + type(scalar_field), pointer :: psi + + ! We form and solve the equation A*psi=rhs + type(csr_matrix) :: A + type(csr_sparsity) :: A_sparsity + type(scalar_field) :: RHS + integer :: ele + + ! Extract the required fields from state. + positions=>extract_vector_field(state, "Coordinate") + psi=>extract_scalar_field(state, "Psi") + + ! Calculate the sparsity of A based on the connectivity of psi. + A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') + call allocate(A, A_sparsity) + + call zero(A) + + call allocate(rhs, psi%mesh, "RHS") + call zero(rhs) + + ! Assemble A element by element. + do ele=1, element_count(psi) + call assemble_element_contribution(A, rhs, positions, psi, rhs_func,& + & ele) + end do + + call assemble_boundary_contribution(rhs, positions, psi, "my_first_boundary") + + call assemble_boundary_contribution(rhs, positions, psi, "my_second_boundary") + + ! It is necessary to fix the value of one node in the solution. + ! We choose node 1. + call set(A, 1, 1, INFINITY) + + call zero(psi) + + call matrix2file("A", A) + + call set_solver_options(psi, ksptype='cg', pctype='sor', rtol=1e-7) + + call petsc_solve(psi, A, rhs) + + call vtk_write_fields('test', 0, positions, positions%mesh, & + sfields=(/ psi /) ) + + call deallocate(A) + call deallocate(A_sparsity) + call deallocate(rhs) + + end subroutine run_model + + subroutine assemble_element_contribution(A, rhs, positions, psi, rhs_func& + &, ele) + type(csr_matrix), intent(inout) :: A + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + interface + function rhs_func(X) + ! A function which evaluates the right hand side at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + end function rhs_func + end interface + integer, intent(in) :: ele + + ! Locations of quadrature points + real, dimension(positions%dim,ele_ngi(positions,ele)) :: X_quad + ! Derivatives of shape function: + real, dimension(ele_loc(psi,ele), & + ele_ngi(psi,ele), positions%dim) :: dshape_psi + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of psi element. + integer, dimension(:), pointer :: ele_psi + ! Shape functions. + type(element_type), pointer :: shape_psi + ! Local Laplacian matrix + real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat + ! Local right hand side. + real, dimension(ele_loc(psi, ele)) :: lrhs - error=0 - do ele=1,element_count(positions) - error=error+element_error(newpos, psi, solution, ele) - end do + ele_psi=>ele_nodes(psi, ele) + shape_psi=>ele_shape(psi, ele) - call field2file("Coordinate", newpos) - call field2file("Psi", psi) + ! Locations of quadrature points. + X_quad=ele_val_at_quad(positions, ele) + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& + & detwei=detwei) + + ! Local assembly: + psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei) - write(0,*) "Degree = ", psi%mesh%shape%degree - write(0,*) "Quad Degree = ", psi%mesh%shape%quadrature%degree - write(0,'(a, i0, e22.8)') "Nodes, Error = ", node_count(psi), error + lrhs=-shape_rhs(shape_psi, rhs_func(X_quad)*detwei) - end subroutine analyse_output + ! Global assembly: + call addto(A, ele_psi, ele_psi, psi_mat) - function element_error(positions, psi, solution, ele) - real :: element_error - type(vector_field), target :: positions - type(scalar_field), target :: psi - interface - function solution(X) - ! A function which evaluates the analytic solution at a number of - ! points. Each column of X describes a set of points at which the - ! right hand side is to be evaluated. - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: solution - end function solution - end interface - integer, intent(in) :: ele + call addto(rhs, ele_psi, lrhs) - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Offset for zero pressure node - real, dimension(1) :: offset + end subroutine assemble_element_contribution - ! Transform weights into physical space. - call transform_to_physical(positions, ele, detwei=detwei) + subroutine assemble_boundary_contribution(rhs, positions, psi, bc_name) + type(scalar_field), intent(inout) :: rhs + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + character(len=*), intent(in):: bc_name - offset=-solution(spread(node_val(positions,1),2,1)) + type(scalar_field), pointer:: bc_surface_field + integer, dimension(:), pointer:: surface_element_list + type(element_type), pointer:: psi_face_shape + ! note that we assume all shapes to be the same in each element + real, dimension(face_ngi(positions,1)) :: detwei_face + real, dimension(face_loc(psi,1)) :: bc_val_face + real, dimension(face_loc(psi,1), face_loc(psi,1)) :: face_mat + integer, dimension(face_loc(psi,1)) :: psi_face_nodes + + integer ele, face + + ! pull out the b.c value field again: + bc_surface_field => extract_surface_field(psi, bc_name, 'value') + ! retrieve the list of surface elements/faces where this bc is applied + call get_boundary_condition(psi, bc_name, & + surface_element_list=surface_element_list) + + ! now do the surface integral: + + ! loop over the elements of the surface field + ! NOTE: for a 3D (resp. 2D) problem each element of the 2D (resp. 1D) + ! surface field is a face in the 3D (resp. 2D) mesh(es) of psi and + ! positions + do ele=1, ele_count(bc_surface_field) + + ! get the values in the 2D element in the usual way: + bc_val_face=ele_val(bc_surface_field, ele) + + ! to acces value in the 3D fields, we need to know the face number + face=surface_element_list(ele) + + ! given those calculate the quadrature weights + call transform_facet_to_physical(positions, face, detwei_face) + + ! integral over the face of the form \int N_i N_j + ! where N_i and N_j are shape functions of psi + psi_face_shape => face_shape(psi, face) + face_mat=shape_shape(psi_face_shape, psi_face_shape, detwei_face) + + ! global node numbers of nodes of this face in psi%mesh + psi_face_nodes=face_global_nodes(psi, face) + + call addto(rhs, psi_face_nodes, matmul(face_mat, bc_val_face)) + end do + + end subroutine assemble_boundary_contribution + + subroutine read_command_line(filename, degree, quad_degree) + ! Read the input filename, degree and quadrature degree on the command + ! line. + character(len=*), intent(out) :: filename + integer, intent(out) :: degree, quad_degree + character(len=256) :: degree_buffer + integer :: status + + call get_command_argument(1, value=filename, status=status) + + select case(status) + case(1:) + call usage + stop + case(:-1) + write(0,*) "Warning: truncating filename" + end select + + call get_command_argument(2, value=degree_buffer, status=status) + + select case(status) + case(1:) + ! No degree specified. + degree=1 - element_error=dot_product(detwei, & + case default + read(degree_buffer, *, iostat=status) degree + + if (status/=0) then + write (0,*) trim(degree_buffer)//" is not an integer." + call usage + stop + end if + + end select + + call get_command_argument(3, value=degree_buffer, status=status) + + select case(status) + case(1:) + ! No quadrature degree specified. + quad_degree=2*degree + + case default + read(degree_buffer, *, iostat=status) quad_degree + + if (status/=0) then + write (0,*) trim(degree_buffer)//" is not an integer." + call usage + stop + end if + + end select + + end subroutine read_command_line + + subroutine analyse_output(positions, psi, solution) + type(vector_field), target :: positions + type(scalar_field), target :: psi + interface + function solution(X) + ! A function which evaluates the analytic solution at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: solution + end function solution + end interface + + type(vector_field) :: newpos + real, dimension(:, :), allocatable :: val + ! Total error in the solution. + real :: error + + integer :: ele + + call allocate(newpos, positions%dim, psi%mesh, "Coordinate") + call remap_field(from_field=positions, to_field=newpos) + + error=0 + do ele=1,element_count(positions) + error=error+element_error(newpos, psi, solution, ele) + end do + + call field2file("Coordinate", newpos) + call field2file("Psi", psi) + + write(0,*) "Degree = ", psi%mesh%shape%degree + write(0,*) "Quad Degree = ", psi%mesh%shape%quadrature%degree + write(0,'(a, i0, e22.8)') "Nodes, Error = ", node_count(psi), error + + end subroutine analyse_output + + function element_error(positions, psi, solution, ele) + real :: element_error + type(vector_field), target :: positions + type(scalar_field), target :: psi + interface + function solution(X) + ! A function which evaluates the analytic solution at a number of + ! points. Each column of X describes a set of points at which the + ! right hand side is to be evaluated. + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: solution + end function solution + end interface + integer, intent(in) :: ele + + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Offset for zero pressure node + real, dimension(1) :: offset + + ! Transform weights into physical space. + call transform_to_physical(positions, ele, detwei=detwei) + + offset=-solution(spread(node_val(positions,1),2,1)) + + element_error=dot_product(detwei, & abs(ele_val_at_quad(psi, ele) & - & - solution(ele_val_at_quad(positions, ele)) & - - offset(1) )) + & - solution(ele_val_at_quad(positions, ele)) & + - offset(1) )) - end function element_error + end function element_error - subroutine usage + subroutine usage - write (0,*) "usage: test_laplacian [ []]" + write (0,*) "usage: test_laplacian [ []]" - end subroutine usage + end subroutine usage end program test_laplacian function rhs_func(X) - ! Right hand side function for laplacian operator. - ! - ! Each column of X is interpretted as a position at which RHS should be - ! evaluated. - use fetools - implicit none - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: rhs_func - real, parameter :: PI=4.0*atan(1.0) - integer :: i,dim + ! Right hand side function for laplacian operator. + ! + ! Each column of X is interpretted as a position at which RHS should be + ! evaluated. + use fetools + implicit none + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: rhs_func + real, parameter :: PI=4.0*atan(1.0) + integer :: i,dim - dim=size(X,1) + dim=size(X,1) - rhs_func=2*(dim-1+0.25)*PI*cos(0.5*PI*X(1,:)) + rhs_func=2*(dim-1+0.25)*PI*cos(0.5*PI*X(1,:)) - do i=2,dim - rhs_func=rhs_func*cos(PI*X(i,:)) - end do + do i=2,dim + rhs_func=rhs_func*cos(PI*X(i,:)) + end do - rhs_func=rhs_func+0.5*PI*sin(0.5*PI*X(1,:)) + rhs_func=rhs_func+0.5*PI*sin(0.5*PI*X(1,:)) end function rhs_func function solution(X) - ! Analytic solution of scheme at a set of points, X. - use fetools - implicit none - real, dimension(:,:), intent(in) :: X - real, dimension(size(X,2)) :: solution - real, parameter :: PI=4.0*atan(1.0) - integer :: i,dim + ! Analytic solution of scheme at a set of points, X. + use fetools + implicit none + real, dimension(:,:), intent(in) :: X + real, dimension(size(X,2)) :: solution + real, parameter :: PI=4.0*atan(1.0) + integer :: i,dim - dim=size(X,1) + dim=size(X,1) - solution=-2*cos(0.5*PI*X(1,:))/PI + solution=-2*cos(0.5*PI*X(1,:))/PI - do i=2,dim - solution=solution*cos(PI*X(i,:)) - end do + do i=2,dim + solution=solution*cos(PI*X(i,:)) + end do - solution=solution-2*sin(0.5*PI*X(1,:))/PI + solution=solution-2*sin(0.5*PI*X(1,:))/PI end function solution diff --git a/tools/test_pressure_solve.F90 b/tools/test_pressure_solve.F90 index 382307ef7d..f4b31336f0 100644 --- a/tools/test_pressure_solve.F90 +++ b/tools/test_pressure_solve.F90 @@ -1,366 +1,366 @@ - !! test pressure solvers on large aspect ratio domains - !! WE SOLVE MINUS LAPLACE EQUATION -- i.e. geometric Laplacian - !! This is to make a positive definite matrix (instead of negative) + !! test pressure solvers on large aspect ratio domains + !! WE SOLVE MINUS LAPLACE EQUATION -- i.e. geometric Laplacian + !! This is to make a positive definite matrix (instead of negative) #include "fdebug.h" - subroutine test_pressure_solve - - use futils, only: free_unit - use quadrature - use unittest_tools - use solvers - use fields - use state_module - use elements - use sparse_tools - use mesh_files - use vtk_interfaces - use boundary_conditions - use global_parameters, only: OPTION_PATH_LEN, PYTHON_FUNC_LEN - use free_surface_module - use FLDebug - use petsc - implicit none +subroutine test_pressure_solve + + use futils, only: free_unit + use quadrature + use unittest_tools + use solvers + use fields + use state_module + use elements + use sparse_tools + use mesh_files + use vtk_interfaces + use boundary_conditions + use global_parameters, only: OPTION_PATH_LEN, PYTHON_FUNC_LEN + use free_surface_module + use FLDebug + use petsc + implicit none #include "petsc_legacy.h" - type(state_type) :: state - type(vector_field), target:: positions, vertical_normal - type(scalar_field) :: psi, DistanceToTop, exact - type(mesh_type) :: psi_mesh - type(mesh_type), pointer :: x_mesh - type(element_type) :: psi_shape - type(quadrature_type) :: quad - integer :: quad_degree=4, unit - integer, parameter:: DIM=3 - real :: eps0 - character(len=999) filename, exact_sol_filename - character(len=PYTHON_FUNC_LEN) :: func, buffer - logical :: vl_as, vl, no_vl, sor, vl_as_wsor - logical :: file_exists + type(state_type) :: state + type(vector_field), target:: positions, vertical_normal + type(scalar_field) :: psi, DistanceToTop, exact + type(mesh_type) :: psi_mesh + type(mesh_type), pointer :: x_mesh + type(element_type) :: psi_shape + type(quadrature_type) :: quad + integer :: quad_degree=4, unit + integer, parameter:: DIM=3 + real :: eps0 + character(len=999) filename, exact_sol_filename + character(len=PYTHON_FUNC_LEN) :: func, buffer + logical :: vl_as, vl, no_vl, sor, vl_as_wsor + logical :: file_exists - call set_global_debug_level(3) + call set_global_debug_level(3) - ewrite(1,*) 'test_pressure_solve' + ewrite(1,*) 'test_pressure_solve' - call pressure_solve_options(filename, eps0, & - & exact_sol_filename, vl_as, vl_as_wsor, vl, no_vl, sor) + call pressure_solve_options(filename, eps0, & + & exact_sol_filename, vl_as, vl_as_wsor, vl, no_vl, sor) - ewrite(2,*) 'Using mesh files:',trim(filename) - ewrite(2,*) 'epsilon =', eps0 - ewrite(2,*) 'using exact solution file', trim(exact_sol_filename) - ewrite(2,*) vl_as, vl_as_wsor, vl, no_vl, sor + ewrite(2,*) 'Using mesh files:',trim(filename) + ewrite(2,*) 'epsilon =', eps0 + ewrite(2,*) 'using exact solution file', trim(exact_sol_filename) + ewrite(2,*) vl_as, vl_as_wsor, vl, no_vl, sor - if(vl_as.or.(vl.or.(no_vl.or.(vl_as_wsor.or.sor)))) then + if(vl_as.or.(vl.or.(no_vl.or.(vl_as_wsor.or.sor)))) then - positions=read_mesh_files(trim(filename), & - quad_degree=QUAD_DEGREE, format="gmsh") + positions=read_mesh_files(trim(filename), & + quad_degree=QUAD_DEGREE, format="gmsh") - x_mesh => positions%mesh + x_mesh => positions%mesh - call insert(state, positions, name="Coordinate") - call insert(state, positions%mesh, "Coordinate_mesh") + call insert(state, positions, name="Coordinate") + call insert(state, positions%mesh, "Coordinate_mesh") - call allocate(vertical_normal, mesh_dim(x_mesh), x_mesh, & + call allocate(vertical_normal, mesh_dim(x_mesh), x_mesh, & field_type=FIELD_TYPE_CONSTANT, name="GravityDirection") - call zero(vertical_normal) - call set(vertical_normal, mesh_dim(x_mesh), -1.0) - call insert(state, vertical_normal, name="GravityDirection") - call deallocate(vertical_normal) - - ! Shape functions for psi - assert(dim==mesh_dim(positions)) - quad=make_quadrature(vertices=dim+1, dim=dim, degree=quad_degree) - - psi_shape=make_element_shape(vertices=dim+1, dim=dim, degree=1, quad=quad) - psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) - - call insert(state, psi_mesh, "Psi_Mesh") - call allocate(psi, psi_mesh, "Psi") - call allocate(DistanceToTop, psi_mesh, "DistanceToTop") - call add_boundary_condition(DistanceToTop,"top","surface",(/1/) ) - - call insert(state, psi, "Psi") - call insert(state, DistanceToTop,"DistanceToTop") - - inquire(file=trim(exact_sol_filename),exist=file_exists) - if (.not.file_exists) FLAbort('Couldnt find exact_sol_filename file') - unit=free_unit() - open(unit, file=trim(exact_sol_filename), action="read",& - & status="old") - read(unit, '(a)', end=43) func - ! Read all the lines of the file and put in newlines between them. - do - read(unit, '(a)', end=43) buffer - func=trim(func)//achar(10)//trim(buffer) - end do -43 func=trim(func)//achar(10) - close(unit) - - call allocate(exact,psi%mesh,name='Exact') - call set_from_python_function(exact, trim(func), positions, 0.0) - - positions%val(1,:) = positions%val(1,:)/eps0 - positions%val(2,:) = positions%val(2,:)/eps0 - - call insert(state,exact,'Exact') - - call run_model(state,vl_as,vl_as_wsor,vl,no_vl,sor) - end if - - end subroutine test_pressure_solve - - subroutine run_model(state,vl_as,vl_as_wsor,vl,no_vl,sor) - use global_parameters, only: PYTHON_FUNC_LEN - use unittest_tools - use sparse_tools - use solvers - use boundary_conditions - use fields - use fetools - use state_module - use elements - use sparse_tools_petsc - use sparsity_patterns - use boundary_conditions - use free_surface_module - use FLDebug - use multigrid - use spud - implicit none - type(state_type), intent(inout) :: state - logical, intent(in) :: vl_as, vl_as_wsor, vl, no_vl, sor - - type(vector_field), pointer :: positions - type(scalar_field), pointer :: psi, exact - type(scalar_field) :: error - type(scalar_field), pointer :: topdis - type(mesh_type) :: top_surface_mesh - type(petsc_csr_matrix) :: vprolongator - integer, dimension(:), pointer :: top_surface_node_list => null() - integer, dimension(:), pointer :: top_surface_element_list => null() - !character(len=OPTION_PATH_LEN) solver_option_path - integer :: stat - - ! We form and solve the equation A*psi=rhs - type(csr_sparsity) :: A_sparsity - type(csr_matrix) :: A - type(scalar_field) :: RHS - - ! Extract the required fields from state. - psi=>extract_scalar_field(state, "Psi") - positions=>extract_vector_field(state, "Coordinate") - exact=>extract_scalar_field(state, "Exact") - - !======================= - !Get Boundary conditions - !======================= - topdis => extract_scalar_field(state,"DistanceToTop",stat=stat) - if(stat/=0) then - FLExit('DistanceToTop is not present') - end if - call get_boundary_condition(topdis,1,& - surface_element_list=top_surface_element_list) - call create_surface_mesh(top_surface_mesh, & - top_surface_node_list, psi%mesh, & - top_surface_element_list, name="PsiTopSurfaceMesh") - !======================= - - !Calculate the sparsity of A based on the connectivity of psi. - A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') - call allocate(A, A_sparsity) - call zero(A) - - call allocate(rhs, psi%mesh, "RHS") - call zero(rhs) - - call get_laplacian(A,positions,psi) - !call set_reference_node(A, top_surface_node_list(1), rhs, 0.0) - call set(A, top_surface_node_list(1),top_surface_node_list(1), INFINITY) - - call allocate(error, psi%mesh, "Error") - call zero(error) - - exact%val = exact%val - exact%val(top_surface_node_list(1)) - exact%val(top_surface_node_list(1)) = 0.0 - - call mult(rhs%val,A,exact%val) - - call zero(psi) - - ! supplying the prolongator to petsc_solve makes 'mg' - ! use the vertical_lumping option - vprolongator = & - vertical_prolongator_from_free_surface(state, psi%mesh) - - call set_solver_options(psi, & - ksptype="cg", pctype="mg", & - atol=1.0e-100, rtol=1.0e-20, max_its=10000, & - start_from_zero=.true.) - - call add_option(trim(psi%option_path)//'/solver/diagnostics/monitors/true_error', stat=stat) - - if(vl_as) then - ewrite(1,*) 'with vertical lumping and internal smoother' - - call petsc_solve_monitor_exact(exact, error_filename='with_vl_and_is.dat') - call petsc_solve(psi, A, rhs, prolongators=(/ vprolongator /), & - & surface_node_list=top_surface_node_list, & - & internal_smoothing_option=INTERNAL_SMOOTHING_SEPARATE_SOR) - end if - - if(vl_as_wsor) then - ewrite(1,*) 'with vertical lumping and internal smoother and wrapped & - &sor' - call petsc_solve_monitor_exact(exact, error_filename='with_vl_and_is_wrap_sor.dat') - call petsc_solve(psi, A, rhs, prolongators=(/ vprolongator /), & - & surface_node_list=top_surface_node_list, & - & internal_smoothing_option=INTERNAL_SMOOTHING_WRAP_SOR) - end if - - if(vl) then - ewrite(1,*) 'with vertical lumping, no additive smoother' - - call petsc_solve_monitor_exact(exact, error_filename='with_vl_without_is.dat') - call petsc_solve(psi, A, rhs, prolongators=(/ vprolongator /)) - end if - - if(no_vl) then - ewrite(1,*) 'without vertical lumping' - - call petsc_solve_monitor_exact(exact, error_filename='without_vl.dat') - call petsc_solve(psi, A, rhs) - end if - - if(sor) then - ewrite(1,*) 'Using SOR' - - call petsc_solve_monitor_exact(exact, error_filename='sor.dat') - call petsc_solve(psi, A, rhs) - end if - - end subroutine run_model - - subroutine get_laplacian(A,positions,psi) - use sparse_tools - use fields - use fetools - implicit none - type(csr_matrix), intent(inout) :: A - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - ! - integer :: ele - - do ele = 1, element_count(psi) - call assemble_laplacian_element_contribution(& - &A, positions, psi, ele) - end do - - end subroutine get_laplacian - - subroutine assemble_laplacian_element_contribution(A, positions, psi, ele) - use unittest_tools - use solvers - use fields - use fetools - use transform_elements - use state_module - use elements - use sparse_tools - implicit none - type(csr_matrix), intent(inout) :: A - type(vector_field), intent(in) :: positions - type(scalar_field), intent(in) :: psi - integer, intent(in) :: ele - - ! Derivatives of shape function: - real, dimension(ele_loc(psi,ele), & - ele_ngi(psi,ele), positions%dim) :: dshape_psi - ! Coordinate transform * quadrature weights. - real, dimension(ele_ngi(positions,ele)) :: detwei - ! Node numbers of psi element. - integer, dimension(:), pointer :: ele_psi - ! Shape functions. - type(element_type), pointer :: shape_psi - ! Local Laplacian matrix - real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat - ! tensor - - ele_psi=>ele_nodes(psi, ele) - shape_psi=>ele_shape(psi, ele) - - ! Transform derivatives and weights into physical space. - call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& - & detwei=detwei) - - ! Local assembly: - psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei) - - ! Global assembly: - call addto(A, ele_psi, ele_psi, psi_mat) - - end subroutine assemble_laplacian_element_contribution - - subroutine pressure_solve_options(filename, eps0, & - & exact_sol_filename, vl_as, vl_as_wsor, vl, no_vl, sor) - use Fldebug - use petsc_tools - use petsc - implicit none + call zero(vertical_normal) + call set(vertical_normal, mesh_dim(x_mesh), -1.0) + call insert(state, vertical_normal, name="GravityDirection") + call deallocate(vertical_normal) + + ! Shape functions for psi + assert(dim==mesh_dim(positions)) + quad=make_quadrature(vertices=dim+1, dim=dim, degree=quad_degree) + + psi_shape=make_element_shape(vertices=dim+1, dim=dim, degree=1, quad=quad) + psi_mesh=make_mesh(model=positions%mesh, shape=psi_shape) + + call insert(state, psi_mesh, "Psi_Mesh") + call allocate(psi, psi_mesh, "Psi") + call allocate(DistanceToTop, psi_mesh, "DistanceToTop") + call add_boundary_condition(DistanceToTop,"top","surface",(/1/) ) + + call insert(state, psi, "Psi") + call insert(state, DistanceToTop,"DistanceToTop") + + inquire(file=trim(exact_sol_filename),exist=file_exists) + if (.not.file_exists) FLAbort('Couldnt find exact_sol_filename file') + unit=free_unit() + open(unit, file=trim(exact_sol_filename), action="read",& + & status="old") + read(unit, '(a)', end=43) func + ! Read all the lines of the file and put in newlines between them. + do + read(unit, '(a)', end=43) buffer + func=trim(func)//achar(10)//trim(buffer) + end do +43 func=trim(func)//achar(10) + close(unit) + + call allocate(exact,psi%mesh,name='Exact') + call set_from_python_function(exact, trim(func), positions, 0.0) + + positions%val(1,:) = positions%val(1,:)/eps0 + positions%val(2,:) = positions%val(2,:)/eps0 + + call insert(state,exact,'Exact') + + call run_model(state,vl_as,vl_as_wsor,vl,no_vl,sor) + end if + +end subroutine test_pressure_solve + +subroutine run_model(state,vl_as,vl_as_wsor,vl,no_vl,sor) + use global_parameters, only: PYTHON_FUNC_LEN + use unittest_tools + use sparse_tools + use solvers + use boundary_conditions + use fields + use fetools + use state_module + use elements + use sparse_tools_petsc + use sparsity_patterns + use boundary_conditions + use free_surface_module + use FLDebug + use multigrid + use spud + implicit none + type(state_type), intent(inout) :: state + logical, intent(in) :: vl_as, vl_as_wsor, vl, no_vl, sor + + type(vector_field), pointer :: positions + type(scalar_field), pointer :: psi, exact + type(scalar_field) :: error + type(scalar_field), pointer :: topdis + type(mesh_type) :: top_surface_mesh + type(petsc_csr_matrix) :: vprolongator + integer, dimension(:), pointer :: top_surface_node_list => null() + integer, dimension(:), pointer :: top_surface_element_list => null() + !character(len=OPTION_PATH_LEN) solver_option_path + integer :: stat + + ! We form and solve the equation A*psi=rhs + type(csr_sparsity) :: A_sparsity + type(csr_matrix) :: A + type(scalar_field) :: RHS + + ! Extract the required fields from state. + psi=>extract_scalar_field(state, "Psi") + positions=>extract_vector_field(state, "Coordinate") + exact=>extract_scalar_field(state, "Exact") + + !======================= + !Get Boundary conditions + !======================= + topdis => extract_scalar_field(state,"DistanceToTop",stat=stat) + if(stat/=0) then + FLExit('DistanceToTop is not present') + end if + call get_boundary_condition(topdis,1,& + surface_element_list=top_surface_element_list) + call create_surface_mesh(top_surface_mesh, & + top_surface_node_list, psi%mesh, & + top_surface_element_list, name="PsiTopSurfaceMesh") + !======================= + + !Calculate the sparsity of A based on the connectivity of psi. + A_sparsity=make_sparsity(psi%mesh, psi%mesh, name='LaplacianSparsity') + call allocate(A, A_sparsity) + call zero(A) + + call allocate(rhs, psi%mesh, "RHS") + call zero(rhs) + + call get_laplacian(A,positions,psi) + !call set_reference_node(A, top_surface_node_list(1), rhs, 0.0) + call set(A, top_surface_node_list(1),top_surface_node_list(1), INFINITY) + + call allocate(error, psi%mesh, "Error") + call zero(error) + + exact%val = exact%val - exact%val(top_surface_node_list(1)) + exact%val(top_surface_node_list(1)) = 0.0 + + call mult(rhs%val,A,exact%val) + + call zero(psi) + + ! supplying the prolongator to petsc_solve makes 'mg' + ! use the vertical_lumping option + vprolongator = & + vertical_prolongator_from_free_surface(state, psi%mesh) + + call set_solver_options(psi, & + ksptype="cg", pctype="mg", & + atol=1.0e-100, rtol=1.0e-20, max_its=10000, & + start_from_zero=.true.) + + call add_option(trim(psi%option_path)//'/solver/diagnostics/monitors/true_error', stat=stat) + + if(vl_as) then + ewrite(1,*) 'with vertical lumping and internal smoother' + + call petsc_solve_monitor_exact(exact, error_filename='with_vl_and_is.dat') + call petsc_solve(psi, A, rhs, prolongators=(/ vprolongator /), & + & surface_node_list=top_surface_node_list, & + & internal_smoothing_option=INTERNAL_SMOOTHING_SEPARATE_SOR) + end if + + if(vl_as_wsor) then + ewrite(1,*) 'with vertical lumping and internal smoother and wrapped & + &sor' + call petsc_solve_monitor_exact(exact, error_filename='with_vl_and_is_wrap_sor.dat') + call petsc_solve(psi, A, rhs, prolongators=(/ vprolongator /), & + & surface_node_list=top_surface_node_list, & + & internal_smoothing_option=INTERNAL_SMOOTHING_WRAP_SOR) + end if + + if(vl) then + ewrite(1,*) 'with vertical lumping, no additive smoother' + + call petsc_solve_monitor_exact(exact, error_filename='with_vl_without_is.dat') + call petsc_solve(psi, A, rhs, prolongators=(/ vprolongator /)) + end if + + if(no_vl) then + ewrite(1,*) 'without vertical lumping' + + call petsc_solve_monitor_exact(exact, error_filename='without_vl.dat') + call petsc_solve(psi, A, rhs) + end if + + if(sor) then + ewrite(1,*) 'Using SOR' + + call petsc_solve_monitor_exact(exact, error_filename='sor.dat') + call petsc_solve(psi, A, rhs) + end if + +end subroutine run_model + +subroutine get_laplacian(A,positions,psi) + use sparse_tools + use fields + use fetools + implicit none + type(csr_matrix), intent(inout) :: A + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + ! + integer :: ele + + do ele = 1, element_count(psi) + call assemble_laplacian_element_contribution(& + &A, positions, psi, ele) + end do + +end subroutine get_laplacian + +subroutine assemble_laplacian_element_contribution(A, positions, psi, ele) + use unittest_tools + use solvers + use fields + use fetools + use transform_elements + use state_module + use elements + use sparse_tools + implicit none + type(csr_matrix), intent(inout) :: A + type(vector_field), intent(in) :: positions + type(scalar_field), intent(in) :: psi + integer, intent(in) :: ele + + ! Derivatives of shape function: + real, dimension(ele_loc(psi,ele), & + ele_ngi(psi,ele), positions%dim) :: dshape_psi + ! Coordinate transform * quadrature weights. + real, dimension(ele_ngi(positions,ele)) :: detwei + ! Node numbers of psi element. + integer, dimension(:), pointer :: ele_psi + ! Shape functions. + type(element_type), pointer :: shape_psi + ! Local Laplacian matrix + real, dimension(ele_loc(psi, ele), ele_loc(psi, ele)) :: psi_mat + ! tensor + + ele_psi=>ele_nodes(psi, ele) + shape_psi=>ele_shape(psi, ele) + + ! Transform derivatives and weights into physical space. + call transform_to_physical(positions, ele, shape_psi, dshape=dshape_psi,& + & detwei=detwei) + + ! Local assembly: + psi_mat=dshape_dot_dshape(dshape_psi, dshape_psi, detwei) + + ! Global assembly: + call addto(A, ele_psi, ele_psi, psi_mat) + +end subroutine assemble_laplacian_element_contribution + +subroutine pressure_solve_options(filename, eps0, & +& exact_sol_filename, vl_as, vl_as_wsor, vl, no_vl, sor) + use Fldebug + use petsc_tools + use petsc + implicit none #include "petsc_legacy.h" - character(len=*), intent(out):: filename, exact_sol_filename - logical, intent(out) :: vl_as, vl, no_vl, sor, vl_as_wsor - real, intent(out) :: eps0 - - PetscBool:: flag - PetscErrorCode :: ierr - PetscReal :: number_in=0.0 - - call PetscOptionsGetString(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-filename', filename, flag, ierr) - if (.not. flag) then - call usage() - end if - - call PetscOptionsGetReal(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-epsilon', number_in, flag, ierr) - if(.not. flag) then - call usage() - end if - eps0 = number_in - - call PetscOptionsGetString(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-exact_solution', exact_sol_filename, flag, ierr) - if (.not. flag) then - call usage() - end if - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-vl_as', vl_as, ierr) - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-vl_as_wsor', vl_as_wsor, ierr) - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-vl', vl, ierr) - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-no_vl', no_vl, ierr) - - call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-sor', sor, ierr) - - end subroutine pressure_solve_options - - subroutine usage() - use FLDebug - ewrite(0,*) 'Usage: test_pressure_solve -filename & - &-exact_solution -epsilon & - & [options ...]' - ewrite(0,*) 'Options:' - ewrite(0,*) '-vl_as' - ewrite(0,*) ' Performs a solve using vertical lumping with additive & - &smoother' - ewrite(0,*) '-vl_as_wsor' - ewrite(0,*) ' Performs a solve using vertical lumping with additive & - &smoother and wrapped sor' - ewrite(0,*) '-vl' - ewrite(0,*) ' Performs a solve using vertical lumping without additi& - &ve smoother' - ewrite(0,*) '-no_vl' - ewrite(0,*) ' Performs a solve using regular mg' - stop - end subroutine usage + character(len=*), intent(out):: filename, exact_sol_filename + logical, intent(out) :: vl_as, vl, no_vl, sor, vl_as_wsor + real, intent(out) :: eps0 + + PetscBool:: flag + PetscErrorCode :: ierr + PetscReal :: number_in=0.0 + + call PetscOptionsGetString(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-filename', filename, flag, ierr) + if (.not. flag) then + call usage() + end if + + call PetscOptionsGetReal(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-epsilon', number_in, flag, ierr) + if(.not. flag) then + call usage() + end if + eps0 = number_in + + call PetscOptionsGetString(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-exact_solution', exact_sol_filename, flag, ierr) + if (.not. flag) then + call usage() + end if + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-vl_as', vl_as, ierr) + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-vl_as_wsor', vl_as_wsor, ierr) + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-vl', vl, ierr) + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-no_vl', no_vl, ierr) + + call PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-sor', sor, ierr) + +end subroutine pressure_solve_options + +subroutine usage() + use FLDebug + ewrite(0,*) 'Usage: test_pressure_solve -filename & + &-exact_solution -epsilon & + & [options ...]' + ewrite(0,*) 'Options:' + ewrite(0,*) '-vl_as' + ewrite(0,*) ' Performs a solve using vertical lumping with additive & + &smoother' + ewrite(0,*) '-vl_as_wsor' + ewrite(0,*) ' Performs a solve using vertical lumping with additive & + &smoother and wrapped sor' + ewrite(0,*) '-vl' + ewrite(0,*) ' Performs a solve using vertical lumping without additi& + &ve smoother' + ewrite(0,*) '-no_vl' + ewrite(0,*) ' Performs a solve using regular mg' + stop +end subroutine usage diff --git a/tools/triangle2vtu.F90 b/tools/triangle2vtu.F90 index fb78d9698d..7ce39e252b 100644 --- a/tools/triangle2vtu.F90 +++ b/tools/triangle2vtu.F90 @@ -26,56 +26,56 @@ ! USA subroutine triangle2vtu(filename_, filename_len) bind(c) - !!< Read in a triangle mesh and output a vtu mesh. + !!< Read in a triangle mesh and output a vtu mesh. - use fields - use read_triangle - use vtk_interfaces - use iso_c_binding - implicit none + use fields + use read_triangle + use vtk_interfaces + use iso_c_binding + implicit none - integer(kind=c_size_t), value :: filename_len - character(kind=c_char, len=1) :: filename_(*) + integer(kind=c_size_t), value :: filename_len + character(kind=c_char, len=1) :: filename_(*) - character(len=filename_len) :: filename + character(len=filename_len) :: filename - integer :: stat, i - type(vector_field), target :: positions - type(scalar_field) :: mapA, mapB, regions + integer :: stat, i + type(vector_field), target :: positions + type(scalar_field) :: mapA, mapB, regions - do i=1, filename_len - filename(i:i)=filename_(i) - end do + do i=1, filename_len + filename(i:i)=filename_(i) + end do - positions=read_triangle_files(filename, quad_degree=3, no_faces=.true.) + positions=read_triangle_files(filename, quad_degree=3, no_faces=.true.) - ! For supermesh stuff. - ! It tests for the existence of the mapping files - ! mapping from elements in the supermesh to elements - ! in the original mesh. - ! If they're not there, nothing changes in the output. - mapA = read_elemental_mappings(positions, filename, "mapCA", stat = stat) - if(stat == 0) mapB = read_elemental_mappings(positions, filename, "mapCB", stat = stat) + ! For supermesh stuff. + ! It tests for the existence of the mapping files + ! mapping from elements in the supermesh to elements + ! in the original mesh. + ! If they're not there, nothing changes in the output. + mapA = read_elemental_mappings(positions, filename, "mapCA", stat = stat) + if(stat == 0) mapB = read_elemental_mappings(positions, filename, "mapCB", stat = stat) - if (stat == 0) then - call vtk_write_fields(filename, position=positions, & + if (stat == 0) then + call vtk_write_fields(filename, position=positions, & model=positions%mesh, sfields=(/mapA, mapB/), vfields=(/positions/)) - else if (associated(positions%mesh%region_ids)) then - regions=piecewise_constant_field(positions%mesh, name="Regions") - regions%val=float(positions%mesh%region_ids) - call vtk_write_fields(filename, position=positions, & + else if (associated(positions%mesh%region_ids)) then + regions=piecewise_constant_field(positions%mesh, name="Regions") + regions%val=float(positions%mesh%region_ids) + call vtk_write_fields(filename, position=positions, & model=positions%mesh, vfields=(/positions/), sfields=(/ regions /)) - call deallocate(regions) - else - call vtk_write_fields(filename, position=positions, model=positions%mesh) - end if + call deallocate(regions) + else + call vtk_write_fields(filename, position=positions, model=positions%mesh) + end if - call deallocate(positions) - if (associated(mapA%val)) then - call deallocate(mapA) - end if - if (associated(mapB%val)) then - call deallocate(mapB) - end if + call deallocate(positions) + if (associated(mapA%val)) then + call deallocate(mapA) + end if + if (associated(mapB%val)) then + call deallocate(mapB) + end if end subroutine triangle2vtu diff --git a/tools/unifiedmesh.F90 b/tools/unifiedmesh.F90 index d6d62b5547..70030847fb 100644 --- a/tools/unifiedmesh.F90 +++ b/tools/unifiedmesh.F90 @@ -2,74 +2,74 @@ #include "fdebug.h" subroutine unifiedmesh(filename1_, filename1_len, & - filename2_, filename2_len, & - output_, output_len) bind(c) - - use quadrature - use mpi_interfaces - use fldebug - use mesh_files - use fields - use linked_lists - use intersection_finder_module - use transform_elements - use elements - use supermesh_construction - use vtk_interfaces - use unify_meshes_module - use iso_c_binding - - implicit none - - integer(kind=c_size_t), value :: filename1_len, filename2_len, output_len - character(kind=c_char, len=1) :: filename1_(*), filename2_(*), output_(*) - - character(len=filename1_len) :: filename1 - character(len=filename2_len) :: filename2 - character(len=output_len) :: output - - type(vector_field) :: positionsA, positionsB - type(ilist), dimension(:), allocatable :: map_BA - real, dimension(:), allocatable :: tri_detwei - type(element_type) :: supermesh_shape - type(quadrature_type) :: supermesh_quad - integer :: i, dim - - type(mesh_type) :: accum_mesh - type(vector_field) :: accum_positions - - do i=1, filename1_len - filename1(i:i)=filename1_(i) - end do - do i=1, filename2_len - filename2(i:i)=filename2_(i) - end do - do i=1, output_len - output(i:i)=output_(i) - end do - - call set_global_debug_level(0) - - positionsA = read_mesh_files(trim(filename1), quad_degree=1, format="gmsh") - positionsB = read_mesh_files(trim(filename2), quad_degree=1, format="gmsh") - - dim = positionsA%dim - - allocate(map_BA(ele_count(positionsB))) - - supermesh_quad = make_quadrature(vertices=dim+1, dim=dim, degree=5) - supermesh_shape = make_element_shape(vertices=dim+1, dim=dim, degree=1, quad=supermesh_quad) - allocate(tri_detwei(supermesh_shape%ngi)) - - call allocate(accum_mesh, 0, 0, supermesh_shape, "AccumulatedMesh") - call allocate(accum_positions, dim, accum_mesh, "AccumulatedPositions") - - map_BA = intersection_finder(positionsB, positionsA) - call intersector_set_dimension(dim) - - ! inputs: positionsB, map_BA, positionsA, supermesh_shape - ! output: the supermesh! - call recursive_supermesh(positionsA, positionsB, map_BA, supermesh_shape, 1, ele_count(positionsB), accum_positions) + filename2_, filename2_len, & + output_, output_len) bind(c) + + use quadrature + use mpi_interfaces + use fldebug + use mesh_files + use fields + use linked_lists + use intersection_finder_module + use transform_elements + use elements + use supermesh_construction + use vtk_interfaces + use unify_meshes_module + use iso_c_binding + + implicit none + + integer(kind=c_size_t), value :: filename1_len, filename2_len, output_len + character(kind=c_char, len=1) :: filename1_(*), filename2_(*), output_(*) + + character(len=filename1_len) :: filename1 + character(len=filename2_len) :: filename2 + character(len=output_len) :: output + + type(vector_field) :: positionsA, positionsB + type(ilist), dimension(:), allocatable :: map_BA + real, dimension(:), allocatable :: tri_detwei + type(element_type) :: supermesh_shape + type(quadrature_type) :: supermesh_quad + integer :: i, dim + + type(mesh_type) :: accum_mesh + type(vector_field) :: accum_positions + + do i=1, filename1_len + filename1(i:i)=filename1_(i) + end do + do i=1, filename2_len + filename2(i:i)=filename2_(i) + end do + do i=1, output_len + output(i:i)=output_(i) + end do + + call set_global_debug_level(0) + + positionsA = read_mesh_files(trim(filename1), quad_degree=1, format="gmsh") + positionsB = read_mesh_files(trim(filename2), quad_degree=1, format="gmsh") + + dim = positionsA%dim + + allocate(map_BA(ele_count(positionsB))) + + supermesh_quad = make_quadrature(vertices=dim+1, dim=dim, degree=5) + supermesh_shape = make_element_shape(vertices=dim+1, dim=dim, degree=1, quad=supermesh_quad) + allocate(tri_detwei(supermesh_shape%ngi)) + + call allocate(accum_mesh, 0, 0, supermesh_shape, "AccumulatedMesh") + call allocate(accum_positions, dim, accum_mesh, "AccumulatedPositions") + + map_BA = intersection_finder(positionsB, positionsA) + call intersector_set_dimension(dim) + + ! inputs: positionsB, map_BA, positionsA, supermesh_shape + ! output: the supermesh! + call recursive_supermesh(positionsA, positionsB, map_BA, supermesh_shape, 1, ele_count(positionsB), accum_positions) ! do ele_B=1,ele_count(positionsB) ! llnode => map_BA(ele_B)%firstnode ! do while(associated(llnode)) @@ -89,65 +89,65 @@ subroutine unifiedmesh(filename1_, filename1_len, & ! call write_triangle_files(trim(output), accum_positions_tmp) ! call deallocate(accum_positions_tmp) - call write_mesh_files(trim(output), format="gmsh", positions=accum_positions) - call vtk_write_fields(trim(output), 0, accum_positions, accum_positions%mesh) - - contains - recursive subroutine recursive_supermesh(positionsA, positionsB, map_BA, supermesh_shape, start_ele, end_ele, supermesh) - type(vector_field), intent(in) :: positionsA, positionsB - type(ilist), dimension(:), intent(in) :: map_BA - type(element_type), intent(in) :: supermesh_shape - integer, intent(in) :: start_ele, end_ele - type(vector_field), intent(out) :: supermesh - - integer, parameter :: blocksize = 4 - integer :: i - - type(vector_field) :: supermesh_tmp - type(mesh_type) :: supermesh_mesh - type(vector_field) :: supermesh_accum - type(inode), pointer :: llnode - - integer :: ele_A, ele_B - integer :: new_start, new_end, step - logical :: empty_intersection - - call allocate(supermesh_mesh, 0, 0, supermesh_shape, "AccumulatedMesh") - call allocate(supermesh, positionsA%dim, supermesh_mesh, "AccumulatedPositions") - call deallocate(supermesh_mesh) - - if ((end_ele - start_ele) <= blocksize) then - do ele_B=start_ele,end_ele - llnode => map_BA(ele_B)%firstnode - do while(associated(llnode)) - ele_A = llnode%value - supermesh_tmp = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), supermesh_shape, empty_intersection=empty_intersection) - if (.not. empty_intersection) then + call write_mesh_files(trim(output), format="gmsh", positions=accum_positions) + call vtk_write_fields(trim(output), 0, accum_positions, accum_positions%mesh) + +contains + recursive subroutine recursive_supermesh(positionsA, positionsB, map_BA, supermesh_shape, start_ele, end_ele, supermesh) + type(vector_field), intent(in) :: positionsA, positionsB + type(ilist), dimension(:), intent(in) :: map_BA + type(element_type), intent(in) :: supermesh_shape + integer, intent(in) :: start_ele, end_ele + type(vector_field), intent(out) :: supermesh + + integer, parameter :: blocksize = 4 + integer :: i + + type(vector_field) :: supermesh_tmp + type(mesh_type) :: supermesh_mesh + type(vector_field) :: supermesh_accum + type(inode), pointer :: llnode + + integer :: ele_A, ele_B + integer :: new_start, new_end, step + logical :: empty_intersection + + call allocate(supermesh_mesh, 0, 0, supermesh_shape, "AccumulatedMesh") + call allocate(supermesh, positionsA%dim, supermesh_mesh, "AccumulatedPositions") + call deallocate(supermesh_mesh) + + if ((end_ele - start_ele) <= blocksize) then + do ele_B=start_ele,end_ele + llnode => map_BA(ele_B)%firstnode + do while(associated(llnode)) + ele_A = llnode%value + supermesh_tmp = intersect_elements(positionsA, ele_A, ele_val(positionsB, ele_B), supermesh_shape, empty_intersection=empty_intersection) + if (.not. empty_intersection) then + call unify_meshes_quadratic(supermesh, supermesh_tmp, supermesh_accum) + call deallocate(supermesh) + call deallocate(supermesh_tmp) + supermesh = supermesh_accum + end if + llnode => llnode%next + end do + end do + else + do i=1,blocksize + step = (end_ele - start_ele)/blocksize + new_start = start_ele + (i-1)*step + if (i /= blocksize) then + new_end = start_ele + (i)*step - 1 + else + new_end = end_ele ! step might not divide exactly + end if + write(0,*) "Calling recursive_supermesh with element range ", new_start, new_end + call recursive_supermesh(positionsA, positionsB, map_BA, supermesh_shape, new_start, new_end, supermesh_tmp) call unify_meshes_quadratic(supermesh, supermesh_tmp, supermesh_accum) call deallocate(supermesh) call deallocate(supermesh_tmp) supermesh = supermesh_accum - end if - llnode => llnode%next - end do - end do - else - do i=1,blocksize - step = (end_ele - start_ele)/blocksize - new_start = start_ele + (i-1)*step - if (i /= blocksize) then - new_end = start_ele + (i)*step - 1 - else - new_end = end_ele ! step might not divide exactly - end if - write(0,*) "Calling recursive_supermesh with element range ", new_start, new_end - call recursive_supermesh(positionsA, positionsB, map_BA, supermesh_shape, new_start, new_end, supermesh_tmp) - call unify_meshes_quadratic(supermesh, supermesh_tmp, supermesh_accum) - call deallocate(supermesh) - call deallocate(supermesh_tmp) - supermesh = supermesh_accum - end do - endif - end subroutine recursive_supermesh + end do + endif + end subroutine recursive_supermesh end subroutine unifiedmesh diff --git a/tools/visualise_elements.F90 b/tools/visualise_elements.F90 index 67b925312f..69a732d952 100644 --- a/tools/visualise_elements.F90 +++ b/tools/visualise_elements.F90 @@ -1,464 +1,464 @@ #include "confdefs.h" program visualise_elements - use quadrature - use element_numbering, only: tr, ELEMENT_LAGRANGIAN - use elements - use spud - use fields - use state_module - use vtk_interfaces - use populate_state_module - use field_derivatives - implicit none - - type(element_type) :: element, visualisation_element - type(vector_field) :: position, visualisation_position, outline_position - type(scalar_field) :: shape_values, visualisation_shape_values, tracer - type(mesh_type) :: linear_mesh, visualisation_mesh - type(state_type), dimension(:), pointer :: state - type(vector_field) :: derivative, visualisation_derivative - type(scalar_field), dimension(2) :: dx - character(len=1024) :: projectname + use quadrature + use element_numbering, only: tr, ELEMENT_LAGRANGIAN + use elements + use spud + use fields + use state_module + use vtk_interfaces + use populate_state_module + use field_derivatives + implicit none + + type(element_type) :: element, visualisation_element + type(vector_field) :: position, visualisation_position, outline_position + type(scalar_field) :: shape_values, visualisation_shape_values, tracer + type(mesh_type) :: linear_mesh, visualisation_mesh + type(state_type), dimension(:), pointer :: state + type(vector_field) :: derivative, visualisation_derivative + type(scalar_field), dimension(2) :: dx + character(len=1024) :: projectname #ifdef HAVE_MPI - integer :: ierror, stat + integer :: ierror, stat - call set_global_debug_level(0) + call set_global_debug_level(0) - call mpi_init(ierror) + call mpi_init(ierror) #endif - call python_init() - call read_command_line(projectname) + call python_init() + call read_command_line(projectname) - call set_option("/timestepping/current_time", 0.0, stat=stat) + call set_option("/timestepping/current_time", 0.0, stat=stat) - if (have_option("/geometry/mesh")) then - call populate_state(state) + if (have_option("/geometry/mesh")) then + call populate_state(state) - position=extract_vector_field(state(1),"Coordinate") + position=extract_vector_field(state(1),"Coordinate") - tracer=extract_scalar_field(state(1), "Tracer") + tracer=extract_scalar_field(state(1), "Tracer") - element=construct_element() - visualisation_element=construct_visualisation_element() - visualisation_mesh=make_mesh(tracer%mesh, visualisation_element,& - & continuity=-1) - call allocate(visualisation_position, 2, visualisation_mesh, "Coordinate") - call remap_field(position, visualisation_position) - call allocate(visualisation_shape_values, visualisation_mesh, & - "Tracer" ) - call remap_field(tracer, visualisation_shape_values) + element=construct_element() + visualisation_element=construct_visualisation_element() + visualisation_mesh=make_mesh(tracer%mesh, visualisation_element,& + & continuity=-1) + call allocate(visualisation_position, 2, visualisation_mesh, "Coordinate") + call remap_field(position, visualisation_position) + call allocate(visualisation_shape_values, visualisation_mesh, & + "Tracer" ) + call remap_field(tracer, visualisation_shape_values) - linear_mesh=subdivide_elements(visualisation_position%mesh) + linear_mesh=subdivide_elements(visualisation_position%mesh) - visualisation_shape_values%mesh=linear_mesh - visualisation_position%mesh=linear_mesh + visualisation_shape_values%mesh=linear_mesh + visualisation_position%mesh=linear_mesh - outline_position=construct_outline_positions(element) + outline_position=construct_outline_positions(element) - if (has_vector_field(state(1),"Derivative")) then + if (has_vector_field(state(1),"Derivative")) then - derivative=extract_vector_field(state(1), "Derivative") + derivative=extract_vector_field(state(1), "Derivative") - dx(1)=extract_scalar_field(derivative, 1) - dx(2)=extract_scalar_field(derivative, 2) + dx(1)=extract_scalar_field(derivative, 1) + dx(2)=extract_scalar_field(derivative, 2) - print *, dx(1)%val + print *, dx(1)%val - call differentiate_field(tracer, position, (/.true.,.true./), dx) + call differentiate_field(tracer, position, (/.true.,.true./), dx) - print *, tracer%val - print *, dx(1)%val + print *, tracer%val + print *, dx(1)%val - call allocate(visualisation_derivative, 2,visualisation_mesh, & - "Derivative" ) - call remap_field(derivative, visualisation_derivative) + call allocate(visualisation_derivative, 2,visualisation_mesh, & + "Derivative" ) + call remap_field(derivative, visualisation_derivative) - call vtk_write_fields(projectname, 0, & - visualisation_position, & - linear_mesh, & - sfields=(/visualisation_shape_values/), & - vfields=(/visualisation_derivative/)) + call vtk_write_fields(projectname, 0, & + visualisation_position, & + linear_mesh, & + sfields=(/visualisation_shape_values/), & + vfields=(/visualisation_derivative/)) - call vtk_write_fields("linear"//projectname, 0, & - position, & - derivative%mesh, vfields=(/derivative/)) + call vtk_write_fields("linear"//projectname, 0, & + position, & + derivative%mesh, vfields=(/derivative/)) - else - call vtk_write_fields(projectname, 0, & - visualisation_position, & - linear_mesh, & - sfields=(/visualisation_shape_values/)) + else + call vtk_write_fields(projectname, 0, & + visualisation_position, & + linear_mesh, & + sfields=(/visualisation_shape_values/)) - call vtk_write_fields("outline"//projectname, 0, & - outline_position, & - outline_position%mesh) + call vtk_write_fields("outline"//projectname, 0, & + outline_position, & + outline_position%mesh) - end if + end if - else + else - element=construct_element() - position=construct_positions(element) - shape_values=construct_shape_values(position%mesh) + element=construct_element() + position=construct_positions(element) + shape_values=construct_shape_values(position%mesh) - visualisation_element=construct_visualisation_element() - visualisation_mesh=make_mesh(position%mesh, visualisation_element) + visualisation_element=construct_visualisation_element() + visualisation_mesh=make_mesh(position%mesh, visualisation_element) - call allocate(visualisation_position, 2, visualisation_mesh, "Coordinate") - call remap_field(position, visualisation_position) - call allocate(visualisation_shape_values, visualisation_mesh, & - "ShapeValues" ) - call remap_field(shape_values, visualisation_shape_values) + call allocate(visualisation_position, 2, visualisation_mesh, "Coordinate") + call remap_field(position, visualisation_position) + call allocate(visualisation_shape_values, visualisation_mesh, & + "ShapeValues" ) + call remap_field(shape_values, visualisation_shape_values) - linear_mesh=subdivide_elements(visualisation_position%mesh) + linear_mesh=subdivide_elements(visualisation_position%mesh) - ! Note memory leak - visualisation_shape_values%mesh=linear_mesh - visualisation_position%mesh=linear_mesh + ! Note memory leak + visualisation_shape_values%mesh=linear_mesh + visualisation_position%mesh=linear_mesh - outline_position=construct_outline_positions(element) + outline_position=construct_outline_positions(element) - call vtk_write_fields(projectname, 0, & - visualisation_position, & - linear_mesh, & - sfields=(/visualisation_shape_values/)) + call vtk_write_fields(projectname, 0, & + visualisation_position, & + linear_mesh, & + sfields=(/visualisation_shape_values/)) - call vtk_write_fields("outline"//projectname, 0, & - outline_position, & - outline_position%mesh) + call vtk_write_fields("outline"//projectname, 0, & + outline_position, & + outline_position%mesh) - end if + end if contains - function subdivide_elements(mesh) result (linear_mesh) - type(mesh_type), intent(in) :: mesh - type(mesh_type) :: linear_mesh + function subdivide_elements(mesh) result (linear_mesh) + type(mesh_type), intent(in) :: mesh + type(mesh_type) :: linear_mesh - type(element_type) :: element, linear_element - integer :: triangles, e, n, row, column, rowlen, ele + type(element_type) :: element, linear_element + integer :: triangles, e, n, row, column, rowlen, ele - element=mesh%shape + element=mesh%shape - linear_element=make_element_shape(element%numbering%vertices, 2, degree=1, & + linear_element=make_element_shape(element%numbering%vertices, 2, degree=1, & quad=element%quadrature) - triangles=tr(element%degree) + tr(element%degree-1) + triangles=tr(element%degree) + tr(element%degree-1) - call allocate(linear_mesh, nodes=node_count(mesh), & + call allocate(linear_mesh, nodes=node_count(mesh), & elements=triangles*element_count(mesh), shape=linear_element, & name="Linear"//mesh%name) - e=0 - do ele=1, element_count(mesh) - ! Point up triangles. - n=element%loc*(ele-1) - do row=1, element%degree - rowlen=element%degree+2-row - do column=1,element%degree+1-row - n=n+1 - e=e+1 - linear_mesh%ndglno((e-1)*3+1:e*3)& + e=0 + do ele=1, element_count(mesh) + ! Point up triangles. + n=element%loc*(ele-1) + do row=1, element%degree + rowlen=element%degree+2-row + do column=1,element%degree+1-row + n=n+1 + e=e+1 + linear_mesh%ndglno((e-1)*3+1:e*3)& =(/n, n+1, n+rowlen/) - end do - n=n+1 - end do - - ! Point down triangles. - n=element%loc*(ele-1)+1 - do row=1, element%degree-1 - rowlen=element%degree+2-row - do column=1,element%degree-row - n=n+1 - e=e+1 - linear_mesh%ndglno((e-1)*3+1:e*3)& + end do + n=n+1 + end do + + ! Point down triangles. + n=element%loc*(ele-1)+1 + do row=1, element%degree-1 + rowlen=element%degree+2-row + do column=1,element%degree-row + n=n+1 + e=e+1 + linear_mesh%ndglno((e-1)*3+1:e*3)& =(/n, n+rowlen, n+rowlen-1/) - end do - n=n+2 - end do - end do + end do + n=n+2 + end do + end do - end function subdivide_elements + end function subdivide_elements - function construct_shape_values(mesh) result (sfield) - type(scalar_field) :: sfield - type(mesh_type) :: mesh + function construct_shape_values(mesh) result (sfield) + type(scalar_field) :: sfield + type(mesh_type) :: mesh - integer :: ele, node - integer, dimension(:), pointer :: nodes + integer :: ele, node + integer, dimension(:), pointer :: nodes - call allocate(sfield, mesh, "ShapeValues") + call allocate(sfield, mesh, "ShapeValues") - call zero(sfield) + call zero(sfield) - do ele=1,element_count(mesh) - nodes=>ele_nodes(mesh,ele) - do node=1,size(nodes) - if (node==ele) then - call set(sfield, nodes(node), 1.0) - end if - end do - end do + do ele=1,element_count(mesh) + nodes=>ele_nodes(mesh,ele) + do node=1,size(nodes) + if (node==ele) then + call set(sfield, nodes(node), 1.0) + end if + end do + end do - end function construct_shape_values + end function construct_shape_values - function construct_element() result(element) - type(element_type) :: element - type(quadrature_type) :: quadrature + function construct_element() result(element) + type(element_type) :: element + type(quadrature_type) :: quadrature - integer :: degree, dim, vertices, type - character(len=1024) :: family + integer :: degree, dim, vertices, type + character(len=1024) :: family - call get_option("/geometry/element_degree", degree) - call get_option("/geometry/dimension", dim) - call get_option("/geometry/element_vertices", vertices) - call get_option("/geometry/element_family", family) + call get_option("/geometry/element_degree", degree) + call get_option("/geometry/dimension", dim) + call get_option("/geometry/element_vertices", vertices) + call get_option("/geometry/element_family", family) - select case(family) - case("lagrange") - type=ELEMENT_LAGRANGIAN - case("default") - write(0,*) "Unknown element type "//trim(family) - end select + select case(family) + case("lagrange") + type=ELEMENT_LAGRANGIAN + case("default") + write(0,*) "Unknown element type "//trim(family) + end select - quadrature = make_quadrature(vertices, dim, degree) + quadrature = make_quadrature(vertices, dim, degree) - element = make_element_shape(vertices, dim, degree, quadrature, type) + element = make_element_shape(vertices, dim, degree, quadrature, type) - end function construct_element + end function construct_element - function construct_visualisation_element() result(element) - type(element_type) :: element - type(quadrature_type) :: quadrature + function construct_visualisation_element() result(element) + type(element_type) :: element + type(quadrature_type) :: quadrature - integer :: degree, dim, vertices, type - character(len=1024) :: family + integer :: degree, dim, vertices, type + character(len=1024) :: family - call get_option("/geometry/visualisation_degree", degree) - call get_option("/geometry/dimension", dim) - call get_option("/geometry/element_vertices", vertices) - call get_option("/geometry/element_family", family) + call get_option("/geometry/visualisation_degree", degree) + call get_option("/geometry/dimension", dim) + call get_option("/geometry/element_vertices", vertices) + call get_option("/geometry/element_family", family) - select case(family) - case("lagrange") - type=ELEMENT_LAGRANGIAN - case("default") - write(0,*) "Unknown element type "//trim(family) - end select + select case(family) + case("lagrange") + type=ELEMENT_LAGRANGIAN + case("default") + write(0,*) "Unknown element type "//trim(family) + end select - ! Don't care about quadrature as we won't do any calculus - quadrature = make_quadrature(vertices, dim, degree=1) + ! Don't care about quadrature as we won't do any calculus + quadrature = make_quadrature(vertices, dim, degree=1) - element = make_element_shape(vertices, dim, degree, quadrature, type) + element = make_element_shape(vertices, dim, degree, quadrature, type) - end function construct_visualisation_element + end function construct_visualisation_element - function construct_positions(element) result (position) - type(element_type), intent(inout) :: element - type(vector_field) :: position + function construct_positions(element) result (position) + type(element_type), intent(inout) :: element + type(vector_field) :: position - type(mesh_type) :: mesh, linear_mesh, one_mesh_linear, one_mesh - type(vector_field) :: linear_position, one_element_linear, one_element - type(element_type) :: linear_element + type(mesh_type) :: mesh, linear_mesh, one_mesh_linear, one_mesh + type(vector_field) :: linear_position, one_element_linear, one_element + type(element_type) :: linear_element - real,dimension(2,element%numbering%vertices) :: vertices, lvertices - real,dimension(2) :: node_loc - real :: scale - integer :: i, d + real,dimension(2,element%numbering%vertices) :: vertices, lvertices + real,dimension(2) :: node_loc + real :: scale + integer :: i, d - vertices=regular_figure(element%numbering%vertices, 1.0) + vertices=regular_figure(element%numbering%vertices, 1.0) - linear_element=make_element_shape(element%numbering%vertices, 2, degree=1, & + linear_element=make_element_shape(element%numbering%vertices, 2, degree=1, & quad=element%quadrature) - linear_mesh=construct_mesh(linear_element, element, "LinearMesh") + linear_mesh=construct_mesh(linear_element, element, "LinearMesh") - one_mesh_linear=construct_one_element_mesh(linear_element, & + one_mesh_linear=construct_one_element_mesh(linear_element, & "OneLinearMesh") - one_mesh=construct_one_element_mesh(element, "OneMesh") + one_mesh=construct_one_element_mesh(element, "OneMesh") - call allocate(one_element_linear, 2, one_mesh_linear, & + call allocate(one_element_linear, 2, one_mesh_linear, & "OneLinearCoordinate") - call allocate(one_element, 2, one_mesh, "OneCoordinate") + call allocate(one_element, 2, one_mesh, "OneCoordinate") - call set(one_element_linear, ele_nodes(one_element_linear,1), vertices) + call set(one_element_linear, ele_nodes(one_element_linear,1), vertices) - call remap_field(one_element_linear, one_element) + call remap_field(one_element_linear, one_element) - call allocate(linear_position, 2, linear_mesh, "LinearCoordinate") + call allocate(linear_position, 2, linear_mesh, "LinearCoordinate") - scale=1.5*element%degree + scale=1.5*element%degree - do i=1, node_count(one_element) - node_loc=node_val(one_element, i) - do d=1,2 - lvertices(d,:)=vertices(d,:)+scale*node_loc(d) - end do + do i=1, node_count(one_element) + node_loc=node_val(one_element, i) + do d=1,2 + lvertices(d,:)=vertices(d,:)+scale*node_loc(d) + end do - call set(linear_position, ele_nodes(linear_mesh,i), lvertices) - end do + call set(linear_position, ele_nodes(linear_mesh,i), lvertices) + end do - mesh = construct_mesh(element, element, "Mesh") - call allocate(position, 2, mesh, "Coordinate") + mesh = construct_mesh(element, element, "Mesh") + call allocate(position, 2, mesh, "Coordinate") - call remap_field(linear_position, position) + call remap_field(linear_position, position) - call deallocate(linear_position) - call deallocate(linear_mesh) - call deallocate(linear_element) - call deallocate(one_element) - call deallocate(one_element_linear) - call deallocate(one_mesh) - call deallocate(one_mesh_linear) + call deallocate(linear_position) + call deallocate(linear_mesh) + call deallocate(linear_element) + call deallocate(one_element) + call deallocate(one_element_linear) + call deallocate(one_mesh) + call deallocate(one_mesh_linear) - end function construct_positions + end function construct_positions - function construct_outline_positions(element) result (position) - type(element_type), intent(inout) :: element - type(vector_field) :: position + function construct_outline_positions(element) result (position) + type(element_type), intent(inout) :: element + type(vector_field) :: position - type(mesh_type) :: mesh, linear_mesh, one_mesh_linear, one_mesh - type(vector_field) :: linear_position, one_element_linear, one_element - type(element_type) :: linear_element + type(mesh_type) :: mesh, linear_mesh, one_mesh_linear, one_mesh + type(vector_field) :: linear_position, one_element_linear, one_element + type(element_type) :: linear_element - real,dimension(2,element%numbering%vertices) :: vertices, lvertices - real,dimension(2) :: node_loc - real :: scale - integer :: i, d + real,dimension(2,element%numbering%vertices) :: vertices, lvertices + real,dimension(2) :: node_loc + real :: scale + integer :: i, d - vertices=regular_figure(element%numbering%vertices, 1.0) + vertices=regular_figure(element%numbering%vertices, 1.0) - linear_element=make_element_shape(element%numbering%vertices, 2, degree=1, & + linear_element=make_element_shape(element%numbering%vertices, 2, degree=1, & quad=element%quadrature) - linear_mesh=construct_mesh(linear_element, element, "LinearMesh") + linear_mesh=construct_mesh(linear_element, element, "LinearMesh") - one_mesh_linear=construct_one_element_mesh(linear_element, & + one_mesh_linear=construct_one_element_mesh(linear_element, & "OneLinearMesh") - one_mesh=construct_one_element_mesh(element, "OneMesh") + one_mesh=construct_one_element_mesh(element, "OneMesh") - call allocate(one_element_linear, 2, one_mesh_linear, & + call allocate(one_element_linear, 2, one_mesh_linear, & "OneLinearCoordinate") - call allocate(one_element, 2, one_mesh, "OneCoordinate") + call allocate(one_element, 2, one_mesh, "OneCoordinate") - call set(one_element_linear, ele_nodes(one_element_linear,1), vertices) + call set(one_element_linear, ele_nodes(one_element_linear,1), vertices) - call remap_field(one_element_linear, one_element) + call remap_field(one_element_linear, one_element) - call allocate(position, 2, linear_mesh, "LinearCoordinate") + call allocate(position, 2, linear_mesh, "LinearCoordinate") - scale=1.5*element%degree + scale=1.5*element%degree - do i=1, node_count(one_element) - node_loc=node_val(one_element, i) - do d=1,2 - lvertices(d,:)=vertices(d,:)+scale*node_loc(d) - end do + do i=1, node_count(one_element) + node_loc=node_val(one_element, i) + do d=1,2 + lvertices(d,:)=vertices(d,:)+scale*node_loc(d) + end do - call set(position, ele_nodes(linear_mesh,i), lvertices) - end do + call set(position, ele_nodes(linear_mesh,i), lvertices) + end do - call deallocate(linear_mesh) - call deallocate(linear_element) - call deallocate(one_element) - call deallocate(one_element_linear) - call deallocate(one_mesh) - call deallocate(one_mesh_linear) + call deallocate(linear_mesh) + call deallocate(linear_element) + call deallocate(one_element) + call deallocate(one_element_linear) + call deallocate(one_mesh) + call deallocate(one_mesh_linear) - end function construct_outline_positions + end function construct_outline_positions - function construct_mesh(mesh_element, layout_element, name) result(mesh) - type(mesh_type) :: mesh - type(element_type), intent(inout) :: mesh_element - type(element_type), intent(in) :: layout_element - character(len=*), intent(in) :: name + function construct_mesh(mesh_element, layout_element, name) result(mesh) + type(mesh_type) :: mesh + type(element_type), intent(inout) :: mesh_element + type(element_type), intent(in) :: layout_element + character(len=*), intent(in) :: name - integer :: i + integer :: i - call allocate(mesh, nodes=mesh_element%loc*layout_element%loc, & + call allocate(mesh, nodes=mesh_element%loc*layout_element%loc, & elements=layout_element%loc, shape=mesh_element, name=name) - ! Definitely a DG mesh - mesh%continuity=-1 + ! Definitely a DG mesh + mesh%continuity=-1 - ! Usual dg numbering. - mesh%ndglno=(/(i, i=1,mesh_element%loc*layout_element%loc)/) + ! Usual dg numbering. + mesh%ndglno=(/(i, i=1,mesh_element%loc*layout_element%loc)/) - end function construct_mesh + end function construct_mesh - function construct_one_element_mesh(element, name) result(mesh) - type(mesh_type) :: mesh - type(element_type), intent(inout) :: element - character(len=*), intent(in) :: name + function construct_one_element_mesh(element, name) result(mesh) + type(mesh_type) :: mesh + type(element_type), intent(inout) :: element + character(len=*), intent(in) :: name - integer :: i + integer :: i - call allocate(mesh, nodes=element%loc, elements=1, shape& - &=element, name=name) + call allocate(mesh, nodes=element%loc, elements=1, shape& + &=element, name=name) - ! Usual dg numbering. - mesh%ndglno=(/(i, i=1,element%loc)/) + ! Usual dg numbering. + mesh%ndglno=(/(i, i=1,element%loc)/) - end function construct_one_element_mesh + end function construct_one_element_mesh - subroutine read_command_line(projectname) - ! Read the input filename, degree and quadrature degree on the command - ! line. - character(len=*), intent(out) :: projectname + subroutine read_command_line(projectname) + ! Read the input filename, degree and quadrature degree on the command + ! line. + character(len=*), intent(out) :: projectname - character(len=1024) :: filename - integer :: status + character(len=1024) :: filename + integer :: status - call get_command_argument(1, value=filename, status=status) + call get_command_argument(1, value=filename, status=status) - if (status/=0) then - call usage - stop - end if + if (status/=0) then + call usage + stop + end if - call load_options(filename) + call load_options(filename) - call get_option("/project_name", projectname) + call get_option("/project_name", projectname) - end subroutine read_command_line + end subroutine read_command_line - subroutine usage + subroutine usage - write (0,*) "usage: visualise_elements " + write (0,*) "usage: visualise_elements " - end subroutine usage + end subroutine usage - function regular_figure(nodes, length) result (vertex) - ! Return the locations of the vertices of the interval, square or - ! triangle centred at the origin with side length length. - integer, intent(in) :: nodes - real, intent(in) :: length - real, dimension(2, nodes) :: vertex + function regular_figure(nodes, length) result (vertex) + ! Return the locations of the vertices of the interval, square or + ! triangle centred at the origin with side length length. + integer, intent(in) :: nodes + real, intent(in) :: length + real, dimension(2, nodes) :: vertex - real :: height + real :: height - select case (nodes) - case(2) - vertex(2,:)=0.0 - vertex(1,:)=(/-length/2,length/2/) - case(3) - height=sqrt(0.75)*length - vertex(:,1)=(/-0.5*length, -1./3. * height/) - vertex(:,2)=(/0.5*length, -1./3. * height/) - vertex(:,3)=(/0.0, 2./3.*height/) - case(4) - vertex(:,1)=(/-length/2,-length/2/) - vertex(:,2)=(/length/2,-length/2/) - vertex(:,3)=(/-length/2,length/2/) - vertex(:,4)=(/length/2,length/2/) - case default - write(0,*) "Illegal number of nodes" - end select - end function regular_figure + select case (nodes) + case(2) + vertex(2,:)=0.0 + vertex(1,:)=(/-length/2,length/2/) + case(3) + height=sqrt(0.75)*length + vertex(:,1)=(/-0.5*length, -1./3. * height/) + vertex(:,2)=(/0.5*length, -1./3. * height/) + vertex(:,3)=(/0.0, 2./3.*height/) + case(4) + vertex(:,1)=(/-length/2,-length/2/) + vertex(:,2)=(/length/2,-length/2/) + vertex(:,3)=(/-length/2,length/2/) + vertex(:,4)=(/length/2,length/2/) + case default + write(0,*) "Illegal number of nodes" + end select + end function regular_figure end program visualise_elements diff --git a/tools/vtu2gmsh.F90 b/tools/vtu2gmsh.F90 index e99c764ac0..e81bc4105a 100644 --- a/tools/vtu2gmsh.F90 +++ b/tools/vtu2gmsh.F90 @@ -26,32 +26,32 @@ ! USA subroutine vtu2gmsh(filename_, filename_len) bind(c) - !!< Read in a vtu and output a gmsh mesh. + !!< Read in a vtu and output a gmsh mesh. - use fields - use state_module - use mesh_files - use vtk_interfaces - use iso_c_binding - implicit none + use fields + use state_module + use mesh_files + use vtk_interfaces + use iso_c_binding + implicit none - character(kind=c_char, len=1) :: filename_(*) - integer(kind=c_size_t), value :: filename_len + character(kind=c_char, len=1) :: filename_(*) + integer(kind=c_size_t), value :: filename_len - character(len=filename_len) :: filename - type(vector_field), pointer :: positions - type(state_type) :: state - integer :: i + character(len=filename_len) :: filename + type(vector_field), pointer :: positions + type(state_type) :: state + integer :: i - do i=1, filename_len - filename(i:i)=filename_(i) - end do + do i=1, filename_len + filename(i:i)=filename_(i) + end do - call vtk_read_state(filename // ".vtu", state) - positions => extract_vector_field(state, "Coordinate") - call add_faces(positions%mesh) - call write_mesh_files(filename, format="gmsh", positions=positions) + call vtk_read_state(filename // ".vtu", state) + positions => extract_vector_field(state, "Coordinate") + call add_faces(positions%mesh) + call write_mesh_files(filename, format="gmsh", positions=positions) - call deallocate(state) + call deallocate(state) end subroutine vtu2gmsh diff --git a/tools/vtu2triangle.F90 b/tools/vtu2triangle.F90 index db11e3d20b..251dcf806c 100644 --- a/tools/vtu2triangle.F90 +++ b/tools/vtu2triangle.F90 @@ -26,33 +26,33 @@ ! USA subroutine vtu2triangle(filename_, filename_len) bind(c) - !!< Read in a triangle mesh and output a vtu mesh. + !!< Read in a triangle mesh and output a vtu mesh. - use fields - use state_module - use write_triangle - use vtk_interfaces - use iso_c_binding + use fields + use state_module + use write_triangle + use vtk_interfaces + use iso_c_binding - implicit none + implicit none - character(kind=c_char, len=1) :: filename_(*) - integer(kind=c_size_t), value :: filename_len + character(kind=c_char, len=1) :: filename_(*) + integer(kind=c_size_t), value :: filename_len - character(len = filename_len) :: filename - type(vector_field), pointer :: positions - type(state_type) :: state - integer :: i + character(len = filename_len) :: filename + type(vector_field), pointer :: positions + type(state_type) :: state + integer :: i - do i=1, filename_len - filename(i:i)=filename_(i) - end do + do i=1, filename_len + filename(i:i)=filename_(i) + end do - call vtk_read_state(filename // ".vtu", state) - positions => extract_vector_field(state, "Coordinate") - call add_faces(positions%mesh) - call write_triangle_files(filename, positions, print_internal_faces=.true.) + call vtk_read_state(filename // ".vtu", state) + positions => extract_vector_field(state, "Coordinate") + call add_faces(positions%mesh) + call write_triangle_files(filename, positions, print_internal_faces=.true.) - call deallocate(state) + call deallocate(state) end subroutine vtu2triangle